プログラム本体
0001: #! /usr/bin/perl
0002: ## ---------------------------------------------------------------- ##
0003: ## jpn2spccgi 世界の鳥類名検索 CGI プロフラム
0004: ## copyright(c)2009 Kazzrou OOSATO
0005: ## Licensed under GPL2
0006: ##
0007: ## $Id: jpn2spccgi.pl,v 1.17 ########## $
0008: ## ---------------------------------------------------------------- ##
0009: use strict;
0010: use lib "/var/www/birds/lib";
0011: use FNCommon;
0012: use FNNavibar;
0013: use Validation;
0014: use JSCommon;
0015: use JSInitParam;
0016: use IBCommon;
0017: use lib "/usr/lib/perl5/5.8.0/i386-linux-thread-multi";
0018: use Time::HiRes;
0019: use Time::Local;
0020: use Encode;
0021: use POSIX;
0022: use Socket;
0023: use License;
0024:
0025: ## ----------------
0026: # 時間測定開始
0027: #
0028: &start_elapsed;
0029:
0030: ## ---------------------------------------------------------------- ##
0031: ## 環境変数 QUERY_STRING を読み、パラメータをハッシュ %pvalue に格納する
0032: ## FNCommon::getparam
0033: ##
0034: my(%pvalue);
0035:
0036: ##&JSCommon::getparam2(\%pvalue);
0037:
0038: my($paramStr);
0039: if ($ENV{REQUEST_METHOD} eq "POST"){
0040: $paramStr=<STDIN>;
0041: }else{
0042: $paramStr=$ENV{QUERY_STRING};
0043: }
0044: $paramStr=~s/\+/ /g;
0045: $paramStr=~s/\%([0-9A-Fa-f][0-9A-Fa-f])/chr(hex($1))/ge;
0046: $paramStr=~s/\'/\'\'/g;
0047: for (split("&", $paramStr)){
0048: my($k, $v)=split('=');
0049: $pvalue{$k}=$v;
0050: }
0051:
0052: ## ---------------------------------------------------------------- ##
0053: ## fini モジュールから初期条件その他を取得する
0054: ## FNInitParam::fnini
0055: ##
0056: my($DBHOST)=&fnini("JPN2SPC_DBHOST");
0057: my($DBCODE)=&fnini("JPN2SPC_DBCODE");
0058:
0059: ## ----------------
0060: # DataBase コネクション
0061: #
0062: my($DB);
0063: &connectDB(\$DB, $DBHOST.":/DB/birds/birds.fdb", "SYSDBA", "********", $DBCODE);
0064:
0065:
0066: ## ---------------------------------------------------------------- ##
0067: ## HTML を開始する
0068: ##
0069: ##
0070: print("Content-type: text/html\n\n");
0071:
0072: # ----
0073: # HTML 本文
0074: #
0075: &prnt("<?" . &fnini("XML_DECLARATION") . "?>");
0076: &prnt("<!" . &fnini("DOCTYPE_DECLARATION") . ">");
0077: &prnt("<" . &fnini("HTML_DECLARATION") . ">");
0078: # ----
0079: # HTML Head
0080: #
0081: &prnt("<head>");
0082: &prnt("<meta name=\"referrer\" content=\"unsafe-url\" />");
0083: &prnt("<meta http-equiv=\"Content-Type\" content=\"text/html; charset=euc-jp\" />");
0084: &prnt("<meta http-equiv=\"Content-Style-Type\" content=\"text/css\" />");
0085: &prnt("<link rel=\"stylesheet\" type=\"text/css\" href=\"".&fnini("CSS_JPN2SPC")."\" />");
0086: &prnt("<link rel=\"stylesheet\" type=\"text/css\" href=\"".&fnini("CSS_COMMON")."\" />");
0087: &prnt("<link rel=\"stylesheet\" type=\"text/css\" href=\"".&fnini("CSS_NAVIBAR")."\" />");
0088: &prnt("<link rev=\"made\" href=\"".&fnini("REV_MADE")."\" />");
0089: &prnt("<link rel=\"index\" href=\"".&fnini("URI_JPN2SPCCGI")."\" />");
0090: #&prnt("<link rel=\"prev\" href=\"".&fnini("URI_JPN2SPCCGI")."\" />");
0091: #&prnt("<link rel=\"next\" href=\"".&fnini("URI_JPN2SPCCGI")."\" />");
0092: &prnt("<title>");
0093: &prnt("世界の鳥類 名検索辞典");
0094: &prnt("</title>");
0095: &prnt("</head>");
0096:
0097: ## ---------------------------------------------------------------- ##
0098: ## HTML BODY 部開始
0099: ##
0100: ##
0101: &prnt("<body class=\"FNOTES\">");
0102: &prnt("<table class=\"FNOTES\" summary=\"jpn2spc\">");
0103: &prnt("<tr>");
0104: &prnt("<td colspan=\"6\">");
0105: ##&print_navibar(\ "100001000", 0, 6);
0106: &print_navibar(\ "1111111111", 0, 6);
0107: &prnt("</td>");
0108: &prnt("</tr>");
0109:
0110: &prnt("<tr>");
0111: &prnt("<td class=\"HEAD1\" colspan=\"6\">");
0112: &prnt("<h1 class=\"H1CENTER\">");
0113: &prnt("世界の鳥類名検索");
0114: &prnt("</h1>");
0115: &prnt("</td>");
0116: &prnt("</tr>");
0117:
0118: ## ---------------------------------------------------------------- ##
0119: ## シブリー博士と、世界鳥類リスト勉強会 への謝辞
0120: ##
0121: ##
0122: &prnt("<tr>");
0123: &prnt("<td class=\"LINEB\" colspan=\"6\">");
0124: &prnt("<div class=\"SERIFCENTER\">");
0125: &prnt("謝辞<br />");
0126: &prnt("このプログラムが使用するデータベースの作成に当たっては、<br />");
0127: &prnt("1995年にシブリー博士が公開された「Birds of the World」の学名(約9900種)と<br />");
0128: &prnt("対応する和名は<a href=\"http://www.eonet.ne.jp/~saezuri/\" rel=\"nofollow\">「明石のはらくらぶ]のページ</a>で公開されている<br />");
0129: &prnt("「世界鳥類リスト勉強会」のリストを参考にさせていただきました。<br />");
0130: &prnt("シブリー博士、ならびに世界鳥類リスト勉強会の皆様に、感謝いたします。<br />");
0131: &prnt("</div>");
0132: &prnt("</td>");
0133: &prnt("</tr>");
0134:
0135: ## ---------------------------------------------------------------- ##
0136: ## 分類体系について
0137: ##
0138: ##
0139: &prnt("<tr>");
0140: &prnt("<td class=\"LINEB\" colspan=\"6\">");
0141: &prnt("<div class=\"SERIFCENTER\">");
0142: &prnt("なお、目および科の分類はおおよそシブリー・アールキスト分類に準拠したつもりです。<br />");
0143: &prnt("古典的分類に慣れていると違和感ありますが、慣れましょう(^^;<br />");
0144: &prnt("</div>");
0145: &prnt("</td>");
0146: &prnt("</tr>");
0147:
0148: my($sql);
0149: my($c)=0;
0150: ## ---------------------------------------------------------------- ##
0151: ## 和名から変換
0152: ##
0153:
0154: ####
0155: # フォーム印字
0156: #
0157: printform("和名から変換", "和名", "WAMEI", 68, $pvalue{USAGE});
0158:
0159: ####
0160: # 検索表示
0161: #
0162: if ($pvalue{WAMEI}){
0163: ########
0164: # 名前の正規化をする
0165: # 前後の空白を削除する
0166: #
0167: $pvalue{SPECS}=~s/^ *//g;
0168: $pvalue{SPECS}=~s/ *$//g;
0169: #
0170: # ひらがなだったらカタカナにする
0171: # (EUC-JPにべったり依存なコード) スマートな方法が他にあるとは思うが
0172: my($hname)=unpack("H*", $pvalue{WAMEI});
0173: $hname=~s/a4a4/a4XX/g;
0174: $hname=~s/a5a4/a5XX/g;
0175: $hname=~s/a4/a5/g;
0176: $hname=~s/a5XX/a5a4/g;
0177: $pvalue{WAMEI}=pack("H*", $hname);
0178:
0179: if ($DBCODE eq "UTF8"){
0180: &Encode::from_to($pvalue{WAMEI}, "eucjp", "utf8");
0181: }
0182: my($t1)=&Time::HiRes::time();
0183: #
0184: # Transaction 開始
0185: my($trans);
0186: &startTransaction(\$DB, \$trans);
0187: #
0188: # 見出し行印字
0189: &printcolhead;
0190: #
0191: # 配列にパラメータを入れる
0192: my(@param)=($pvalue{WAMEI});
0193: #
0194: # PROCEDURE 呼び出し
0195: my(%hash)=&execProcedure(\$trans, \ "PS_J_SGFO", 1, \@param, 0, \$sql);
0196: #
0197: # Transaction 終了
0198: &commitTransaction(\$trans);
0199: # カウンタ変数
0200: $c=0;
0201: if ($hash{SPECIESNAME}){
0202: # 検索結果行印字
0203: ## &prcolg($hash{ORDERNAME}, $hash{ORDERJPN},
0204: ## $hash{FAMILYNAME}, $hash{FAMILYJPN});
0205: &prcolg($hash{ORDERNAME}, $hash{ORDERJPN},
0206: $hash{FAMILYNAME}, $hash{FAMILYJPN},
0207: $hash{GENUSNAME}, $hash{GENUSJPN});
0208: &prcols($hash{SPECIESNAME}, $hash{SPECIESJPN}, $hash{SPECIESENG});
0209: $c++;
0210: }
0211: # サマリ行印字
0212: &printsum($pvalue{WAMEI}, $c, $t1);
0213: }
0214:
0215: ## ---------------------------------------------------------------- ##
0216: ## 学名から変換
0217: ##
0218:
0219: ####
0220: # フォーム印字
0221: #
0222: printform("学名から変換", "学名", "SPECS", 68, $pvalue{"USAGE"});
0223:
0224: ####
0225: # 検索表示
0226: #
0227: if ($pvalue{"SPECS"}){
0228: ########
0229: # 名前の正規化をする
0230: # 連続する空白を1個に詰める
0231: $pvalue{SPECS}=~s/ */ /g;
0232: #
0233: # 前後の空白を削除する
0234: $pvalue{SPECS}=~s/^ *//g;
0235: $pvalue{SPECS}=~s/ *$//g;
0236: #
0237: # 先頭文字を大文字、その他を小文字にする
0238: $pvalue{SPECS}=ucfirst(lc($pvalue{SPECS}));
0239:
0240: my($t1)=&Time::HiRes::time();
0241: my($trans);
0242: &startTransaction(\$DB, \$trans);
0243: my(@param)=($pvalue{SPECS});
0244: my(%hash)=&execProcedure(\$trans, \ "PS_N_SGFO", 1, \@param, 0, \$sql);
0245: &commitTransaction(\$trans);
0246: &printcolhead;
0247: $c=0;
0248: if ($hash{SPECIESNAME}){
0249: &prcolg($hash{ORDERNAME}, $hash{ORDERJPN},
0250: $hash{FAMILYNAME}, $hash{FAMILYJPN},
0251: $hash{GENUSNAME}, $hash{GENUSJPN});
0252: &prcols($hash{SPECIESNAME}, $hash{SPECIESJPN}, $hash{SPECIESENG});
0253: $c++;
0254: }
0255: # サマリ行印字
0256: &printsum($pvalue{SPECS}, $c, $t1);
0257: }
0258:
0259: ## ---------------------------------------------------------------- ##
0260: ## 英名から変換
0261: ##
0262:
0263: ####
0264: # フォーム印字
0265: #
0266: printform("英名から変換", "英名", "ENAME", 68, $pvalue{"USAGE"});
0267:
0268: ####
0269: # 検索表示
0270: #
0271: if ($pvalue{"ENAME"}){
0272: # 名前の正規化
0273: # 連続する空白を1個に詰める
0274: $pvalue{ENAME}=~s/ */ /g;
0275: # 前後の空白を削除する
0276: $pvalue{ENAME}=~s/^ *//g;
0277: $pvalue{ENAME}=~s/ *$//g;
0278: # 大文字に揃える
0279: my($uc)=uc($pvalue{ENAME});
0280: my($t1)=&Time::HiRes::time();
0281: my($trans);
0282: &startTransaction(\$DB, \$trans);
0283: my(@param)=($uc);
0284: my(%hash)=&execProcedure(\$trans, \ "PS_ECAP_SGFO", 1, \@param, 0, \$sql);
0285: &commitTransaction(\$trans);
0286: &printcolhead;
0287: $c=0;
0288: if ($hash{SPECIESNAME}){
0289: &prcolg($hash{ORDERNAME}, $hash{ORDERJPN},
0290: $hash{FAMILYNAME}, $hash{FAMILYJPN},
0291: $hash{GENUSNAME}, $hash{GENUSJPN});
0292: &prcols($hash{SPECIESNAME}, $hash{SPECIESJPN}, $hash{SPECIESENG});
0293: $c++;
0294: }
0295: # サマリ行印字
0296: &printsum($pvalue{ENAME}, $c, $t1);
0297: }
0298:
0299: ## ---------------------------------------------------------------- ##
0300: ## 属名から検索
0301: ##
0302:
0303: ####
0304: # フォーム印字
0305: #
0306: printform("属名から検索", "属名", "GENUS", 68, $pvalue{"USAGE"});
0307:
0308: ####
0309: # 検索表示
0310: #
0311: if ($pvalue{"GENUS"}){
0312: # # 名前の正規化をする
0313: # # 連続する空白を1個に詰める
0314: # $pvalue{GENUS}=~s/ */ /g;
0315: # # 前後の空白を削除する
0316: # $pvalue{GENUS}=~s/^ *//g;
0317: # $pvalue{GENUS}=~s/ *$//g;
0318: # # 先頭文字を大文字、その他を小文字にする
0319: # $pvalue{GENUS}=ucfirst(lc($pvalue{GENUS}));
0320: #
0321: # my($t1)=&Time::HiRes::time();
0322: # my($trans);
0323: # &startTransaction(\$DB, \$trans);
0324: # my(@param)=($pvalue{GENUS});
0325: # my($st)=&execProcedure(\$trans, \ "PG_N_SGFO", 2, \@param, \ "ORDER BY SEQNO", \$sql);
0326: # &printcolhead;
0327: # $c=0;
0328: # my(%hash);
0329: # while ($st->fetch(\%hash)==0){
0330: # &prcolg($hash{ORDERNAME}, $hash{ORDERJPN},
0331: # $hash{FAMILYNAME}, $hash{FAMILYJPN},
0332: # $hash{GENUSNAME}, $hash{GENUSJPN});
0333: # &prcols($hash{SPECIESNAME}, $hash{SPECIESJPN}, $hash{SPECIESENG});
0334: # $c++;
0335: # }
0336: # &commitTransaction(\$trans);
0337: # &printsum($pvalue{"GENUS"}, $c, $t1);
0338:
0339: ##---------------------------------
0340:
0341: #
0342: # 学名か和名か判断して名前の正規化をする
0343: # 連続する空白を1個に詰める
0344: $pvalue{GENUS}=~s/ */ /g;
0345: # 前後の空白を削除する
0346: $pvalue{GENUS}=~s/^ *//g;
0347: $pvalue{GENUS}=~s/ *$//g;
0348: my($WA);
0349: if ($pvalue{"GENUS"}=~/[a-zA-Z]/){
0350: # ASCII文字があるのでたぶん学名とラフな判断
0351: # 学名の規則に従い、先頭文字を大文字、その他を小文字にする
0352: $pvalue{GENUS}=ucfirst(lc($pvalue{GENUS}));
0353: $WA=0;
0354: }else{
0355: # 学名じゃないようなので和名
0356: # ひらがなはカタカナに (EUC-JP依存ベタベタ)
0357: my($hname)=unpack("H*", $pvalue{GENUS});
0358: $hname=~s/a4a4/a4XX/g;
0359: $hname=~s/a5a4/a5XX/g;
0360: $hname=~s/a4/a5/g;
0361: $hname=~s/a5XX/a5a4/g;
0362: $pvalue{GENUS}=pack("H*", $hname);
0363: # 末尾に「属」がついてなければ補完
0364: $pvalue{GENUS}.="属" unless ($pvalue{GENUS}=~/属$/);
0365: $WA=1;
0366: }
0367:
0368:
0369: #### &prnt($pvalue{GENUS});
0370: my($t1)=&Time::HiRes::time();
0371: # Transaction 開始
0372: my($trans);
0373: &startTransaction(\$DB, \$trans);
0374: # 見出し印字
0375: &printcolhead;
0376: my(@param)=($pvalue{GENUS});
0377: my($st)=&execProcedure(\$trans,
0378: \ (($WA)?"PG_J_SGFO":"PG_N_SGFO"),
0379: 2, \@param, \ "ORDER BY SEQNO", \$sql);
0380: # 検索数カウンタ
0381: $c=0;
0382: my(%hash);
0383: # データセットを FETCH
0384: while ($st->fetch(\%hash)==0){
0385: # 行印字
0386: &prcolg($hash{ORDERNAME}, $hash{ORDERJPN},
0387: $hash{FAMILYNAME}, $hash{FAMILYJPN},
0388: $hash{GENUSNAME}, $hash{GENUSJPN});
0389: &prcols($hash{SPECIESNAME}, $hash{SPECIESJPN}, $hash{SPECIESENG});
0390: $c++;
0391: }
0392: # Transaction 終了
0393: &commitTransaction(\$trans);
0394: # サマリ行印字
0395: &printsum($pvalue{GENUS}, $c, $t1);
0396:
0397:
0398:
0399: }
0400:
0401: ## ---------------------------------------------------------- ##
0402: ## 科名から検索
0403: ##
0404:
0405: ####
0406: # フォームの印字
0407: #
0408: printform("科名から検索", "科名", "FAMLY", 68, $pvalue{USAGE});
0409:
0410: ####
0411: # 検索結果の印字
0412: #
0413: if ($pvalue{FAMLY}){
0414: #
0415: # 学名か和名か判断して名前の正規化をする
0416: # 連続する空白を1個に詰める
0417: $pvalue{FAMLY}=~s/ */ /g;
0418: # 前後の空白を削除する
0419: $pvalue{FAMLY}=~s/^ *//g;
0420: $pvalue{FAMLY}=~s/ *$//g;
0421: my($WA);
0422: if ($pvalue{"FAMLY"}=~/[a-zA-Z]/){
0423: # ASCII文字があるのでたぶん学名とラフな判断
0424: # 学名の規則に従い、先頭文字を大文字、その他を小文字にする
0425: $pvalue{FAMLY}=ucfirst(lc($pvalue{FAMLY}));
0426: $WA=0;
0427: }else{
0428: # 学名じゃないようなので和名
0429: # ひらがなはカタカナに (EUC-JP依存ベタベタ)
0430: my($hname)=unpack("H*", $pvalue{FAMLY});
0431: $hname=~s/a4a4/a4XX/g;
0432: $hname=~s/a5a4/a5XX/g;
0433: $hname=~s/a4/a5/g;
0434: $hname=~s/a5XX/a5a4/g;
0435: $pvalue{FAMLY}=pack("H*", $hname);
0436: # 末尾に「科」がついてなければ補完
0437: $pvalue{FAMLY}.="科" unless ($pvalue{FAMLY}=~/科$/);
0438: $WA=1;
0439: }
0440:
0441: my($t1)=&Time::HiRes::time();
0442: # Transaction 開始
0443: my($trans);
0444: &startTransaction(\$DB, \$trans);
0445: # 見出し印字
0446: &printcolhead;
0447: my(@param)=($pvalue{FAMLY});
0448: my($st)=&execProcedure(\$trans,
0449: \ (($WA)?"PF_J_SGFO":"PF_N_SGFO"),
0450: 2, \@param, \ "ORDER BY SEQNO", \$sql);
0451: # 検索数カウンタ
0452: $c=0;
0453: my(%hash);
0454: # データセットを FETCH
0455: while ($st->fetch(\%hash)==0){
0456: # 行印字
0457: &prcolg($hash{ORDERNAME}, $hash{ORDERJPN},
0458: $hash{FAMILYNAME}, $hash{FAMILYJPN},
0459: $hash{GENUSNAME}, $hash{GENUSJPN});
0460: &prcols($hash{SPECIESNAME}, $hash{SPECIESJPN}, $hash{SPECIESENG});
0461: $c++;
0462: }
0463: # Transaction 終了
0464: &commitTransaction(\$trans);
0465: # サマリ行印字
0466: &printsum($pvalue{FAMLY}, $c, $t1);
0467: }
0468:
0469: ## ---------------------------------------------------------- ##
0470: ## 目名から検索
0471: ##
0472:
0473: ####
0474: # フォームの印字
0475: #
0476: printform("目名から検索", "目名", "ORDER", 68, $pvalue{USAGE});
0477:
0478: ####
0479: # 検索結果の印字
0480: #
0481: if ($pvalue{ORDER}){
0482: # 学名か和名か判断して名前の正規化をする
0483: # 連続する空白を1個に詰める
0484: $pvalue{ORDER}=~s/ */ /g;
0485: # 前後の空白を削除する
0486: $pvalue{ORDER}=~s/^ *//g;
0487: $pvalue{ORDER}=~s/ *$//g;
0488: my($WA);
0489: if ($pvalue{"ORDER"}=~/[a-zA-Z]/){
0490: # ASCII文字があるのでたぶん学名とラフな判断
0491: # 先頭文字を大文字、その他を小文字にする
0492: $pvalue{ORDER}=ucfirst(lc($pvalue{ORDER}));
0493: $WA=0;
0494: }else{
0495: # 学名じゃないようなので和名
0496: # ひらがなはカタカナに (EUC-JP依存ベタベタ)
0497: my($hname)=unpack("H*", $pvalue{ORDER});
0498: $hname=~s/a4a4/a4XX/g;
0499: $hname=~s/a5a4/a5XX/g;
0500: $hname=~s/a4/a5/g;
0501: $hname=~s/a5XX/a5a4/g;
0502: $pvalue{ORDER}=pack("H*", $hname);
0503: # 末尾に「目」がついてなければ補完
0504: $pvalue{ORDER}.="目" unless ($pvalue{ORDER}=~/目$/);
0505: $WA=1;
0506: }
0507:
0508: my($t1)=&Time::HiRes::time();
0509: # Transaction 開始
0510: my($trans);
0511: &startTransaction(\$DB, \$trans);
0512: # 見出し印字
0513: &printcolhead;
0514: my(@param)=($pvalue{ORDER});
0515: my($st)=&execProcedure(\$trans,
0516: \ (($WA)?"PO_J_SGFO":"PO_N_SGFO"),
0517: 2, \@param, \ "ORDER BY SEQNO", \$sql);
0518: $c=0;
0519: my(%hash);
0520: # データセットを FETCH
0521: while ($st->fetch(\%hash)==0){
0522: # 行印字
0523: &prcolg($hash{ORDERNAME}, $hash{ORDERJPN},
0524: $hash{FAMILYNAME}, $hash{FAMILYJPN},
0525: $hash{GENUSNAME}, $hash{GENUSJPN});
0526: &prcols($hash{SPECIESNAME}, $hash{SPECIESJPN}, $hash{SPECIESENG});
0527: $c++;
0528: }
0529: # Transaction 終了
0530: &commitTransaction(\$trans);
0531: # サマリ行印字
0532: &printsum($pvalue{"ORDER"}, $c, $t1);
0533: }
0534:
0535:
0536: ## ---------------------------------------------------------- ##
0537: ## 和名から部分一致検索
0538: ##
0539:
0540: ####
0541: # フォームの印字
0542: #
0543: printform("和名から部分一致検索", "和名の一部", "WPART", 60, $pvalue{"USAGE"});
0544:
0545: ####
0546: # 検索結果の印字
0547: #
0548: if ($pvalue{WPART}){
0549: ########
0550: # 名前の正規化をする
0551: # 前後の空白を削除する
0552: #
0553: $pvalue{WPART}=~s/^ *//g;
0554: $pvalue{WPART}=~s/ *$//g;
0555: #
0556: # 1バイト文字は削除する
0557: $pvalue{WPART}=~s/[ -~]//g;
0558: #
0559: # ひらがなだったらカタカナにする
0560: # (EUC-JPにべったり依存なコード) スマートな方法が他にあるとは思うが
0561: my($hname)=unpack("H*", $pvalue{WPART});
0562: $hname=~s/a4a4/a4XX/g;
0563: $hname=~s/a5a4/a5XX/g;
0564: $hname=~s/a4/a5/g;
0565: $hname=~s/a5XX/a5a4/g;
0566: $pvalue{WPART}=pack("H*", $hname);
0567:
0568: my($t1)=&Time::HiRes::time();
0569: # Transaction 開始
0570: my($trans);
0571: &startTransaction(\$DB, \$trans);
0572: # 見出し印字
0573: &printcolhead;
0574: # 検索数カウンタ
0575: $c=0;
0576: if ($pvalue{WPART}){
0577: my(@param)=("%".$pvalue{WPART}."%");
0578: my($st)=&execProcedure(\$trans, \ "PS_JLIKE_SGFO",
0579: 2, \@param, \ "ORDER BY SEQNO", \$sql);
0580: my(%hash);
0581: # データセットを FETCH
0582: while ($st->fetch(\%hash)==0){
0583: # 行印字
0584: &prcolg($hash{ORDERNAME}, $hash{ORDERJPN},
0585: $hash{FAMILYNAME}, $hash{FAMILYJPN},
0586: $hash{GENUSNAME}, $hash{GENUSJPN});
0587: &prcols($hash{SPECIESNAME}, $hash{SPECIESJPN}, $hash{SPECIESENG});
0588: $c++;
0589: }
0590: }
0591: # Transaction 終了
0592: &commitTransaction(\$trans);
0593: # サマリ行印字
0594: &printsum($pvalue{WPART}, $c, $t1);
0595: }
0596:
0597:
0598: ## ---------------------------------------------------------- ##
0599: ## 学名から部分一致検索
0600: ##
0601:
0602: ####
0603: # フォームの印字
0604: #
0605: printform("学名から部分一致検索", "学名の一部", "SPART", 60, $pvalue{"USAGE"});
0606:
0607: ####
0608: # 検索結果の印字
0609: #
0610: if ($pvalue{"SPART"}){
0611: my($t1)=&Time::HiRes::time();
0612: my($trans);
0613: &startTransaction(\$DB, \$trans);
0614:
0615: $pvalue{SPART}=~s/[^ A-Za-z]//g;
0616: # Upper-Case に変換
0617: my($uc)=uc($pvalue{SPART});
0618: # シングルクォートをエスケープ
0619: $uc=~s/\'/\'\'/g;
0620: # 連続する空白を1個に
0621: $uc=~s/ */ /g;
0622:
0623: $c=0;
0624: if ($uc){
0625: my(@param)=("%".$uc."%");
0626: my($st)=&execProcedure(\$trans, \ "PS_NLIKE_SGFO",
0627: 2, \@param, \ "ORDER BY SEQNO", \$sql);
0628: &printcolhead;
0629: my(%hash);
0630: while ($st->fetch(\%hash)==0){
0631: &prcolg($hash{ORDERNAME}, $hash{ORDERJPN},
0632: $hash{FAMILYNAME}, $hash{FAMILYJPN},
0633: $hash{GENUSNAME}, $hash{GENUSJPN});
0634: &prcols($hash{SPECIESNAME}, $hash{SPECIESJPN}, $hash{SPECIESENG});
0635: $c++;
0636: }
0637: }
0638: &printsum($pvalue{"SPART"}, $c, $t1);
0639: &commitTransaction(\$trans);
0640: }
0641:
0642: ## ---------------------------------------------------------- ##
0643: ## 英名から部分一致検索
0644: ##
0645:
0646: ####
0647: # フォームの印字
0648: #
0649: printform("英名から部分一致検索", "英名の一部", "EPART", 60, $pvalue{"USAGE"});
0650:
0651: ####
0652: # 検索結果の印字
0653: #
0654: if ($pvalue{"EPART"}){
0655: my($t1)=&Time::HiRes::time();
0656: my($trans);
0657: &startTransaction(\$DB, \$trans);
0658: my(%khash);
0659:
0660: $pvalue{EPART}=~s/[^ A-Za-z\']//g;
0661: my($uc)=uc($pvalue{EPART});
0662: $uc=~s/ */ /g;
0663: $c=0;
0664: if ($uc){
0665: my(@param)=("%".$uc."%");
0666: my($st)=&execProcedure(\$trans, \ "PS_ELIKE_SGFO",
0667: 2, \@param, \ "ORDER BY SEQNO", \$sql);
0668: &printcolhead;
0669: my(%hash);
0670: while ($st->fetch(\%hash)==0){
0671: &prcolg($hash{ORDERNAME}, $hash{ORDERJPN},
0672: $hash{FAMILYNAME}, $hash{FAMILYJPN},
0673: $hash{GENUSNAME}, $hash{GENUSJPN});
0674: &prcols($hash{SPECIESNAME}, $hash{SPECIESJPN}, $hash{SPECIESENG});
0675: $c++;
0676: }
0677: }
0678: &printsum($pvalue{"EPART"}, $c, $t1);
0679: &commitTransaction(\$trans);
0680: }
0681:
0682:
0683: ## /*---- 目科属のリスト ----------------*/
0684: &prnt("<tr>");
0685: &prnt("<td class=\"LINEA\" colspan=\"6\">");
0686: &prnt("<div class=\"JSCOMMENTHEAD\">");
0687:
0688: &prnt("【目・科・属のリスト】");
0689: &prnt("</div>");
0690: &prnt("</td>");
0691: &prnt("</tr>");
0692: &prnt("<tr>");
0693: &prnt("<td class=\"LINEB\" colspan=\"6\">");
0694: &prnt("<form method=\"post\" action=\"".&fnini("URI_JPN2SPCCGI")."\">");
0695: &prnt("<div class=\"SERIF\">");
0696: &prnt("参考：このデータベースで採用している分類一覧を表示します");
0697: &prnt("<input name=\"GLIST\" type=\"hidden\" value=\"1\" />");
0698: &prnt("<input type=\"submit\" accesskey=\"S\" tabindex=\"6\" value=\"実行\" />");
0699: &prnt("</div>");
0700: &prnt("</form>");
0701: #&prnt("<div class=\"SERIF\">");
0702: #&prnt("属名の和訳の体系的なリストが手に入りません。どなたかご存じでしたら教えてください。<br/>");
0703: #&prnt("属の和訳名だけは暇を見てぼつぼつと手入力していますので、少しずつ増えています。");
0704: #&prnt("</div>");
0705:
0706: &prnt("</td>");
0707: &prnt("</tr>");
0708:
0709: my($t1)=&Time::HiRes::time();
0710:
0711: if ($pvalue{"GLIST"}){
0712: &prnt("<tr>");
0713: &prnt("<td class=\"LINEA\" colspan=\"2\">");
0714: &prnt("<div class=\"JSCOMMENTHEAD\">目</div>");
0715: &prnt("</td>");
0716: &prnt("<td class=\"LINEA\" colspan=\"2\">");
0717: &prnt("<div class=\"JSCOMMENTHEAD\">科</div>");
0718: &prnt("</td>");
0719: &prnt("<td class=\"LINEA\" colspan=\"1\">");
0720: &prnt("<div class=\"JSCOMMENTHEAD\">属</div>");
0721: &prnt("</td>");
0722: &prnt("</tr>");
0723:
0724: my($trans);
0725: &startTransaction(\$DB, \$trans);
0726: my($st)=&execProcedure(\$trans, \ "PG_LIST", 2, 0, 0, \$sql);
0727: $c=0;
0728: my(%r);
0729: while($st->fetch(\%r)==0){
0730: if ($DBCODE eq "UTF8"){
0731: &Encode::from_to($r{ORDERJPN}, "utf8", "eucjp");
0732: &Encode::from_to($r{FAMILYJPN}, "utf8", "eucjp");
0733: &Encode::from_to($r{SPECIESJPN}, "utf8", "eucjp");
0734: }
0735: &prnt("<tr>");
0736: &prnt("<td class=\"LINEE\" colspan=\"2\">");
0737: &prnt("<div class=\"JSDETAIL\">");
0738: &prnt("<a class=\"LINK\" href=\"/cgi-bin/jpn2spccgi?ORDER=$r{ORDERNAME}\">");
0739: &prnt("$r{ORDERNAME} $r{ORDERJPN}");
0740: &prnt("</a>");
0741: &prnt("</div>");
0742: &prnt("</td>");
0743: &prnt("<td class=\"LINEE\" colspan=\"2\">");
0744: &prnt("<div class=\"JSDETAIL\">");
0745: &prnt("<a class=\"LINK\" href=\"/cgi-bin/jpn2spccgi?FAMLY=$r{FAMILYNAME}\">");
0746: &prnt("$r{FAMILYNAME} $r{FAMILYJPN}");
0747: &prnt("</a>");
0748: &prnt("</div>");
0749: &prnt("</td>");
0750: &prnt("<td class=\"LINEE\">");
0751: &prnt("<div class=\"JSDETAIL\">");
0752: &prnt("<a class=\"LINK\" href=\"/cgi-bin/jpn2spccgi?GENUS=$r{GENUSNAME}\">");
0753: &prnt("$r{GENUSNAME} $r{GENUSJPN}");
0754: &prnt("</a>");
0755: &prnt("</div>");
0756: &prnt("</td>");
0757: &prnt("</tr>");
0758: $c++;
0759: }
0760: printsum("目・科・属", $c, $t1);
0761: &commitTransaction(\$trans);
0762: }
0763:
0764: ## ---------------------------------------------------------------- ##
0765: ## このプログラムとデータについて
0766: ##
0767: ##
0768: &prnt("<tr>");
0769: &prnt("<td class=\"LINEB\" colspan=\"6\">");
0770: &prnt("<div class=\"SERIFCENTER\">");
0771: &prnt("<a href=\"http://www.oosato.org/firebird/\">このプログラムとデータについて</a>");
0772: &prnt("</div>");
0773: &prnt("</td>");
0774: &prnt("</tr>");
0775:
0776: ## ---------------------------------------------------------------- ##
0777: ## ロギング
0778: ##
0779: ##
0780: my($trans);
0781: &startTransaction(\$DB, \$trans);
0782: # 今回発行された SQL 文
0783: # シングルクォートをエスケープ
0784: $sql=~s/\'/\'\'/g;
0785:
0786: # ACCLOG テーブルに書き込
0787: my($procname)="P_INSERT_ACCLOG";
0788: my($datetime)=strftime("%F %T", localtime);
0789: my(@param)=($datetime, # 日付時刻
0790: $$, # プロセスID
0791: $ENV{REMOTE_ADDR}, # IP アドレス
0792: &get_elapsed(), # 処理時間
0793: $c, # 抽出件数
0794: substr($paramStr, 0, 128), # 問合せパラメータ
0795: substr($sql, 0, 256)); # SQL 文
0796: &execProcedure(\$trans, \$procname, 0, \@param);
0797:
0798: # REMOTEHOST テーブルに書き込む
0799: if ($ENV{REMOTE_ADDR}){
0800: my($tablename)="REMOTEHOST";
0801: # IPアドレスがテーブルに存在するかチェック
0802: # 存在すれば 日付時刻のみ更新
0803: # 存在しなければホスト名を逆引きし、日付時刻 IP アドレス ホスト名を 作成
0804: my(%khash)=(IPADDR=>$ENV{REMOTE_ADDR});
0805: my(%vhash);
0806: if (&checkSelect(\$trans, \$tablename, \%khash)){
0807: %vhash=(DATETIME=>$datetime);
0808: &updateData(\$trans, \$tablename, \%khash, \%vhash);
0809: }else{
0810: my($hostname)=gethostbyaddr(inet_aton($ENV{REMOTE_ADDR}), AF_INET);
0811: %vhash=(DATETIME=>$datetime, IPADDR=>$ENV{REMOTE_ADDR}, HOSTNAME=>$hostname);
0812: &insertData(\$trans, \$tablename, \%vhash);
0813: }
0814: }
0815: &commitTransaction(\$trans);
0816:
0817: ## ---------------------------------------------------------------- ##
0818: ## 処理時間表示
0819: ## validation 表示
0820: ##
0821: #&prnt("<tr>");
0822: &end_elapsed(6);
0823: #&prnt("</tr>");
0824:
0825: if ($ENV{REQUEST_METHOD} ne "POST"){
0826: my($counter);
0827: # open(FILE, &fnini("CMP_TEXTDIR")."counter.txt");
0828: # read(FILE, $counter, 10);
0829: # close(FILE);
0830: # unless ($ENV{"REMOTE_ADDR"}=~/^192.168.1/ ||
0831: # $ENV{"REMOTE_ADDR"}=~/^210.138.117.70/ ||
0832: # $ENV{"REMOTE_ADDR"}=~/^125.30.97/ ){
0833: # open(FILE, ">".&fnini("CMP_TEXTDIR")."counter.txt");
0834: # $counter++;
0835: # print(FILE $counter."\n");
0836: # close(FILE);
0837: # }
0838: $counter=&inc_acccounter;
0839: &print_author($counter, 5);
0840: }
0841:
0842: &prnt("<tr>");
0843: &prnt("<td class=\"LINEC\" colspan=\"6\">");
0844: &print_validation;
0845: &prnt("</td>");
0846: &prnt("</tr>");
0847:
0848: &prnt("</table>");
0849: &prnt("</body>");
0850: &prnt("</html>");
0851: &disconnectDB(\$DB);
0852: exit(0);
0853:
0854: ##
0855: ## end of main
0856: ## ---------------------------------------------------------------- ##
0857: ## subroutine
0858: ##
0859:
0860: sub printform
0861: {
0862: my($title, $label, $name, $width, $usage)=@_;
0863:
0864: &prnt("<tr>");
0865: &prnt("<td class=\"LINEA\" colspan=\"6\">");
0866: &prnt("<div class=\"JSCOMMENTHEAD\">");
0867: &prnt("【$title】 <a href=\"".&fnini("URI_JPN2SPCCGI")."?USAGE=$name\"".
0868: " rel=\"nofollow,noimdex\">(使い方を表示)</a>");
0869: &prnt("</div>");
0870: if ($usage eq $name){
0871: if ($usage eq "WAMEI"){
0872: &prnt("<div class=\"SERIF\">");
0873: &prnt("和名を全角カタカナまたはひらがなで入れてください<br />");
0874: &prnt("例:「マガモ」と入力すると");
0875: &prnt("学名 Anas platyrhynchos 英名 Mallard が表示されます<br />");
0876: &prnt("例:「かわう」と入力すると");
0877: &prnt("学名 Phalacrocorax carbo 英名 Great Cormorant が表示されます<br />");
0878: &prnt("</div>");
0879: }
0880: if ($usage eq "SPECS"){
0881: &prnt("<div class=\"SERIF\">");
0882: &prnt("学名をローマ字で入れてください。大文字小文字は区別しません<br />");
0883: &prnt("例:「Calidris alpina」と入力すると");
0884: &prnt("和名ハマシギ 英名 Dunlin が表示されます<br />");
0885: &prnt("例:「cettia diphone 」と入力すると");
0886: &prnt("和名ウグイス 英名 Japanese Bush-Warbler が表示されます<br />");
0887: &prnt("</div>");
0888: }
0889: if ($usage eq "ENAME"){
0890: &prnt("<div class=\"SERIF\">");
0891: &prnt("英名をローマ字で入れてください。大文字小文字は区別しません<br />");
0892: &prnt("例:「Common Gull」と入力すると");
0893: &prnt("和名カモメ 学名 Larus canus が表示されます<br />");
0894: &prnt("例:「asian rosy-finch」と入力すると");
0895: &prnt("和名ハギマシコ 学名 Leucosticte arctoa が表示されます<br />");
0896: &prnt("</div>");
0897: }
0898: if ($usage eq "GENUS"){
0899: &prnt("<div class=\"SERIF\">");
0900: &prnt("属名(種の学名の前半部分)をローマ字で入れてください。".
0901: "大文字小文字は区別しません<br />");
0902: &prnt("例:「Accipiter」と入力すると");
0903: &prnt("オオタカ、ツミ、…などハイタカ属が表示されます<br />");
0904: &prnt("例:「クサシギ属」と入力すると");
0905: &prnt("アカアシシギ、アオアシシギ、…などクサシギ属が表示されます<br />");
0906: &prnt("ただし、属の和名は全てがデータ化されてはいません。和名で検索できない時は");
0907: &prnt("学名を入れてみてください<br />");
0908: &prnt("</div>");
0909: }
0910: if ($usage eq "FAMLY"){
0911: &prnt("<div class=\"SERIF\">");
0912: &prnt("科名を学名または和名で入れてください。<br />");
0913: &prnt("例:「Gaviidae」と入力すると");
0914: &prnt("アビ科に属する全てが表示されます<br />");
0915: &prnt("例:「ペンギン科」と入力すると");
0916: &prnt("ペンギン科に属する全てが表示されます<br />");
0917: &prnt("</div>");
0918: }
0919: if ($usage eq "ORDER"){
0920: &prnt("<div class=\"SERIF\">");
0921: &prnt("目名を学名または和名で入れてください<br />");
0922: &prnt("例:「Gruiformes」と入力すると");
0923: &prnt("ツル目に属する全てが表示されます<br />");
0924: &prnt("例:「ブッポウソウ目」と入力すると");
0925: &prnt("ブッポウソウ目に属する全てが表示されます<br />");
0926: &prnt("注意:うかつに「スズメ目」と入れたりして".
0927: "表示に猛烈な時間がかかっても知りません(^^;;");
0928: &prnt("</div>");
0929: }
0930: if ($usage eq "WPART"){
0931: &prnt("<div class=\"SERIF\">");
0932: &prnt("和名の一部を入れてください<br />");
0933: &prnt("例:「ホオジロ」と入力すると");
0934: &prnt("ミヤマホオジロ、ホオジロガモ、…などが表示されます<br />");
0935: &prnt("</div>");
0936: }
0937: if ($usage eq "SPART"){
0938: &prnt("<div class=\"SERIF\">");
0939: &prnt("学名の一部を入れてください<br />");
0940: &prnt("例:「major」と入力すると");
0941: &prnt("Dendrocopos major、Parus major、…などが表示されます<br />");
0942: &prnt("</div>");
0943: }
0944: if ($usage eq "EPART"){
0945: &prnt("<div class=\"SERIF\">");
0946: &prnt("英名の一部を入れてください<br />");
0947: &prnt("例:「red-necked」と入力すると");
0948: &prnt("Red-necked Stint、Red-necked Grebe、…などが表示されます<br />");
0949: &prnt("</div>");
0950: }
0951: }
0952: &prnt("</td>");
0953: &prnt("</tr>");
0954: &prnt("<tr>");
0955: &prnt("<td class=\"LINEB\" colspan=\"6\">");
0956: &prnt("<form method=\"post\" action=\"".&fnini("URI_JPN2SPCCGI")."\">");
0957: ## &prnt("<form method=\"get\" action=\"".&fnini("URI_JPN2SPCCGI")."\">");
0958: &prnt("<div class=\"SERIF\">");
0959: &prnt("<label>$label");
0960: &prnt("<input name=\"$name\" type=\"text\" accesskey=\"S\" tabindex=\"1\"");
0961: &prnt(" size=\"68\" maxlength=\"$width\" value=\"\" />");
0962: &prnt("</label>");
0963: &prnt("<label>送信");
0964: &prnt("<input type=\"submit\" accesskey=\"S\" tabindex=\"6\" value=\"実行\" />");
0965: &prnt("</label>");
0966: &prnt("<label>クリア");
0967: &prnt("<input type=\"reset\" accesskey=\"R\" tabindex=\"7\" value=\"クリア\" />");
0968: &prnt("</label>");
0969: &prnt("</div>");
0970: &prnt("</form>");
0971: &prnt("</td>");
0972: &prnt("</tr>");
0973: }
0974:
0975: sub prcolg
0976: {
0977: my($os, $ow, $fs, $fw, $gs, $gw)=@_;
0978:
0979: &prnt("<tr>");
0980: &prnt("<td class=\"LINEE\">");
0981: &prnt("<div class=\"JSDETAIL\">");
0982: if ($DBCODE eq "UTF8"){
0983: &Encode::from_to($ow, "utf8", "eucjp");
0984: &Encode::from_to($fw, "utf8", "eucjp");
0985: &Encode::from_to($gw, "utf8", "eucjp");
0986: }
0987: &prnt($os." ".$ow);
0988: &prnt("</div>");
0989: &prnt("</td>");
0990: &prnt("<td class=\"LINEE\">");
0991: &prnt("<div class=\"JSDETAIL\">");
0992: &prnt($fs." ".$fw);
0993: &prnt("</div>");
0994: &prnt("</td>");
0995: &prnt("<td class=\"LINEE\">");
0996: &prnt("<div class=\"JSDETAIL\">");
0997: ## &prnt($gs." ".$gw);
0998: &prnt($gw);
0999: &prnt("</div>");
1000: &prnt("</td>");
1001: }
1002:
1003: sub prcols
1004: {
1005: my($s, $w, $e)=@_;
1006: if ($DBCODE eq "UTF8"){
1007: &Encode::from_to($w, "utf8", "eucjp");
1008: }
1009: &prnt("<td class=\"LINEE\">");
1010: &prnt("<div class=\"JSDETAIL\">");
1011: &prnt($s);
1012: &prnt("</div>");
1013: &prnt("</td>");
1014: &prnt("<td class=\"LINEE\">");
1015: &prnt("<div class=\"JSDETAIL\">");
1016: &prnt($w);
1017: &prnt("</div>");
1018: &prnt("</td>");
1019: &prnt("<td class=\"LINEE\">");
1020: &prnt("<div class=\"JSDETAIL\">");
1021: &prnt($e);
1022: &prnt("</div>");
1023: &prnt("</td>");
1024: &prnt("</tr>");
1025: }
1026:
1027: sub printcolhead
1028: {
1029: my(@ttl)=("目","科","属和訳","学名","和名","英名");
1030: my($i);
1031:
1032: &prnt("<tr>");
1033: for $i (@ttl){
1034: &prnt("<td class=\"LINEA\">");
1035: &prnt("<div class=\"JSDETAILHEAD\">");
1036: &prnt($i);
1037: &prnt("</div>");
1038: &prnt("</td>");
1039: }
1040: &prnt("</tr>");
1041: }
1042:
1043: ## ---------------------------------------------------------------- ##
1044: ## subroutine
1045: ## マッチ結果の表示
1046: ##
1047: sub printsum
1048: {
1049: my($s, $c, $t1)=@_;
1050: my($t2)=&Time::HiRes::time();
1051: $s=~s/\'\'/\'/g;
1052: &prnt("<tr>");
1053: &prnt("<td class=\"LINEB\" colspan=\"6\">");
1054: &prnt("<div class=\"SERIF\">");
1055: if ($c){
1056: &prnt("$s に $c 件マッチしました");
1057: }else{
1058: &prnt("$s にマッチするものはありません");
1059: }
1060: &prnt(sprintf(" (所要時間 %3.3f秒)",$t2-$t1));
1061: &prnt("</div>");
1062: &prnt("</td>");
1063: &prnt("</tr>");
1064: }
DB 操作ルーチン
0001: package IBCommon;
0002: use 5.006_001;
0003: use strict;
0004: use IBPerl;
0005:
0006: our (@ISA, @EXPORT);
0007: use Exporter();
0008: @ISA = qw(Exporter);
0009: @EXPORT = qw(
0010: connectDB
0011: disconnectDB
0012: startTransaction
0013: commitTransaction
0014: checkSelect
0015: checkInsert
0016: checkInsertUpdate
0017: insertData
0018: updateData
0019: selectRows
0020: selectRowsLike
0021: selectOneLine
0022: deleteRows
0023: execProcedure
0024: );
0025:
0026: # subroutine ######################################################
0027: # DB 接続
0028: # 引数 $p_db : データベースハンドラへのポインタ
0029: # $dbpath : データベースへのパス(文字列)
0030: # $user : ユーザ名(文字列)
0031: # $password : パスワード(文字列)
0032: # $chaeset : CharacterSet(文字列)
0033: # 返値 データベースハンドラへのポインタ
0034: # エラー STDERRにメッセージを書いてexit(1)
0035: #
0036: sub connectDB
0037: {
0038: my($p_db, $dbpath, $user, $password, $charset)=@_;
0039: $$p_db=IBPerl::Connection->new(Path=>$dbpath,
0040: User=>$user,
0041: Password=>$password,
0042: Charset=>$charset,
0043: Dialect=>3);
0044: if ($$p_db->{Handle}<0){
0045: print(STDERR "connectDB: $$p_db->{Handle} $$p_db->{Error}\n");
0046: exit(1);
0047: }
0048: }
0049:
0050: # subroutine ######################################################
0051: # DB 切断
0052: # 引数 $p_db : データベースハンドラへのポインタ
0053: # 返値 データベースハンドラへのポインタ
0054: # エラー STDERRにメッセージを書いてexit(1)
0055: #
0056: sub disconnectDB
0057: {
0058: my($p_db)=@_;
0059: if ($$p_db->disconnect()<0){
0060: print(STDERR "disconnectDB: $$p_db->{Handle} $$p_db->{Error}\n");
0061: exit(1);
0062: }
0063: }
0064:
0065: # subroutine ######################################################
0066: # Transaction 開始
0067: # 引数 $p_db : データベースハンドラへのポインタ
0068: # $p_trans : トランザクションハンドラへのポインタ
0069: # 返値 トランザクションハンドラへのポインタ
0070: # エラー STDERRにメッセージを書いてexit(1)
0071: #
0072: sub startTransaction
0073: {
0074: my($p_db, $p_trans)=@_;
0075: $$p_trans=IBPerl::Transaction->new(Database=>$$p_db);
0076: if ($$p_trans->{Handle}<0){
0077: print(STDERR "startTransaction: $$p_trans->{Handle} $$p_db->{Error}\n");
0078: exit(1);
0079: }
0080: }
0081:
0082: # subroutine ######################################################
0083: # Transaction コミット
0084: # 引数 $p_trans : トランザクションハンドラへのポインタ
0085: # 返値 トランザクションハンドラへのポインタ
0086: # エラー STDERRにメッセージを書いてexit(1)
0087: #
0088: sub commitTransaction
0089: {
0090: my($p_trans)=@_;
0091: if ($$p_trans->commit()<0){
0092: print(STDERR "commitTransaction: $$p_trans->{Handle}\n");
0093: exit(1);
0094: }
0095: }
0096:
0097: # subroutine ######################################################
0098: # Transaction ロールバック
0099: # 引数 $p_trans : トランザクションハンドラへのポインタ
0100: # 返値 トランザクションハンドラへのポインタ
0101: # エラー STDERRにメッセージを書いてexit(1)
0102: #
0103: sub rollbackTransaction
0104: {
0105: my($p_trans)=@_;
0106: if ($$p_trans->rollback()<0){
0107: print(STDERR "rollbackTransaction: $$p_trans->{Handle}\n");
0108: exit(1);
0109: }
0110: }
0111:
0112: # subroutine ######################################################
0113: # 行の存在チェック
0114: # 引数 $p_trans : トランザクションハンドラへのポインタ
0115: # $p_tbl : テーブル名(文字列)へのポインタ
0116: # $p_khash : キー名=>キー値のハッシュへのポインタ
0117: # $p_option : SQL文のオプション(文字列)へのポインタ
0118: # $p_sql : SQL を返すポインタ
0119: # 返値 存在すれば 1
0120: # 存在しなければ 0
0121: #
0122: sub checkSelect
0123: {
0124: my($p_trans, $p_tbl, $p_khash, $p_option, $p_sql)=@_;
0125: my($sql)="SELECT * FROM $$p_tbl WHERE ";
0126: for (keys %$p_khash){
0127: $sql.="$_='" . $p_khash->{$_} . "' AND ";
0128: }
0129: $sql=~s/ AND $//;
0130: $sql.=" ".$$p_option if ($p_option);
0131: $$p_sql=$sql if ($p_sql);
0132: my($st)=IBPerl::Statement->new(Transaction=>$$p_trans, SQL=>$sql);
0133: my(%hash);
0134: $st->fetch(\%hash);
0135: return((%hash==0)?0:1);
0136: }
0137:
0138: # subroutine ######################################################
0139: # 行の追加
0140: # 行の存在をチェックし、存在しなければ新規に追加する
0141: # 引数 $p_trans : トランザクションハンドラへのポインタ
0142: # $p_tbl : テーブル名(文字列)へのポインタ
0143: # $p_khash : キー名=>キー値のハッシュへのポインタ
0144: # $p_vhash : カラム名=>値のハッシュへのポインタ
0145: # $p_option : SQL文のオプション(文字列)へのポインタ
0146: # $p_sql : SQL文 を返すポインタ
0147: # 返値 INSERT すれば 1
0148: # スキップすれば 0
0149: # エラー STDERRにメッセージを書いてexit(1)
0150: #
0151: sub checkInsert
0152: {
0153: my($p_trans, $p_tbl, $p_khash, $p_vhash, $p_option, $p_sql)=@_;
0154: my($sql)="SELECT * FROM $$p_tbl WHERE ";
0155: for (keys %$p_khash){
0156: $sql.="$_='" . $p_khash->{$_} . "' AND ";
0157: }
0158: $sql=~s/ AND $//;
0159: $sql.=$$p_option if ($p_option);
0160: $$p_sql=$sql if ($p_sql);
0161: my($st)=IBPerl::Statement->new(Transaction=>$$p_trans, SQL=>$sql);
0162: my(%hash);
0163: $st->fetch(\%hash);
0164: if (%hash){
0165: # 存在する
0166: return(0);
0167: }else{
0168: # 存在しない
0169: my($sql)="INSERT INTO $$p_tbl(";
0170: for (keys %$p_vhash){
0171: $sql.="$_,";
0172: }
0173: $sql=~s/,$//;
0174: $sql.=") VALUES(";
0175: for (values %$p_vhash){
0176: $sql.="'".$_."',";
0177: }
0178: $sql=~s/,$//;
0179: $sql.=")";
0180: $$p_sql.=" ".$sql if ($p_sql);
0181: my($st)=IBPerl::Statement->new(Transaction=>$$p_trans, SQL=>$sql);
0182: if ($st->{Handle}<0){
0183: print(STDERR "checkInsert new: $st->{Handle} $st->{Error}\n");
0184: exit(1);
0185: }
0186: $st->execute();
0187: if ($st->{Handle}<0){
0188: print(STDERR "checkInsert execute: $st->{Handle} $st->{Error}\n");
0189: exit(1);
0190: }
0191: return(1);
0192: }
0193: }
0194:
0195: # subroutine ######################################################
0196: # 行の追加または更新
0197: # 行の存在をチェックし、存在すれば更新する
0198: # 存在しなければ新規に追加する
0199: # 引数 $p_trans : トランザクションハンドラへのポインタ
0200: # $p_tbl : テーブル名(文字列)へのポインタ
0201: # $p_khash : キー名=>キー値のハッシュへのポインタ
0202: # $p_vhash : カラム名=>値のハッシュへのポインタ
0203: # $p_option : SQL文のオプション(文字列)へのポインタ
0204: # $p_sql : SQL文 を返すポインタ
0205: # 返値 INSERT ならば 1
0206: # UPDATE ならば 0
0207: # エラー STDERRにメッセージを書いてexit(1)
0208: #
0209: sub checkInsertUpdate
0210: {
0211: my($p_trans, $p_tbl, $p_khash, $p_vhash, $p_option, $p_sql)=@_;
0212: my($sql)="SELECT * FROM $$p_tbl WHERE ";
0213: for (keys %$p_khash){
0214: $sql.="$_='" . $p_khash->{$_} . "' AND ";
0215: }
0216: $sql=~s/ AND $//;
0217: $$p_sql=$sql if ($p_sql);
0218: my($st)=IBPerl::Statement->new(Transaction=>$$p_trans, SQL=>$sql);
0219: my(%hash);
0220: $st->fetch(\%hash);
0221: unless (%hash){
0222: # 存在しない
0223: my($sql)="INSERT INTO $$p_tbl(";
0224: for (keys %$p_vhash){
0225: $sql.="$_,";
0226: }
0227: $sql=~s/,$//;
0228: $sql.=") VALUES(";
0229: for (values %$p_vhash){
0230: $sql.="'".$_."',";
0231: }
0232: $sql=~s/,$//;
0233: $sql.=")";
0234: $$p_sql.=" ".$sql if ($p_sql);
0235: my($st)=IBPerl::Statement->new(Transaction=>$$p_trans, SQL=>$sql);
0236: if ($st->{Handle}<0){
0237: print(STDERR "checkInsertUpdate new: $st->{Handle} $st->{Error}\n");
0238: exit(1);
0239: }
0240: $st->execute();
0241: if ($st->{Handle}<0){
0242: print(STDERR "checkInsertUpdate execute: $st->{Handle} $st->{Error}\n");
0243: exit(1);
0244: }
0245: return(1);
0246: }else{
0247: # 存在する
0248: my($sql)="UPDATE $$p_tbl SET ";
0249: for (keys %$p_vhash){
0250: $sql.="$_='".$$p_vhash{$_}."',";
0251: }
0252: $sql=~s/,$//;
0253: $sql.=" WHERE ";
0254: for (keys %$p_khash){
0255: $sql.="$_='".$$p_khash{$_}."' AND ";
0256: }
0257: $sql=~s/ AND $//;
0258: $$p_sql.=" ".$sql if ($p_sql);
0259: my($st)=IBPerl::Statement->new(Transaction=>$$p_trans, SQL=>$sql);
0260: if ($st->{Handle}<0){
0261: print(STDERR "checkInsertUpdate new: $st->{Handle} $st->{Error}\n");
0262: exit(1);
0263: }
0264: $st->execute();
0265: if ($st->{Handle}<0){
0266: print(STDERR "checkInsertUpdate execute: $st->{Handle} $st->{Error}\n");
0267: exit(1);
0268: }
0269: return(0);
0270: }
0271: }
0272:
0273: # subroutine ######################################################
0274: # 行の追加
0275: # 引数 $p_trans : トランザクションハンドラへのポインタ
0276: # $p_tbl : テーブル名(文字列)へのポインタ
0277: # $p_vhash : カラム名=>値のハッシュへのポインタ
0278: # $p_sql : SQL文 を返すポインタ
0279: # 返値 SQL実行後のステートメントハンドラ
0280: # エラー STDERRにメッセージを書いてexit(1)
0281: #
0282: sub insertData
0283: {
0284: my($p_trans, $p_tbl, $p_vhash, $p_sql)=@_;
0285: my($sql)="INSERT INTO $$p_tbl(";
0286: for (keys %$p_vhash){
0287: $sql.="$_,";
0288: }
0289: $sql=~s/,$//;
0290: $sql.=") VALUES(";
0291: for (values %$p_vhash){
0292: $sql.="'".$_."',";
0293: }
0294: $sql=~s/,$//;
0295: $sql.=")";
0296: $$p_sql=$sql if ($p_sql);
0297: my($st)=IBPerl::Statement->new(Transaction=>$$p_trans, SQL=>$sql);
0298: if ($st->{'Handle'}<0){
0299: print(STDERR "insertData new: $st->{Handle} $st->{Error}\n");
0300: return 0;
0301: # exit(1);
0302: }
0303: $st->execute();
0304: if ($st->{'Handle'}<0){
0305: print(STDERR "insertData execute: $st->{Handle} $st->{Error}\n");
0306: return 0;
0307: # exit(1);
0308: }
0309: }
0310:
0311: # subroutine ######################################################
0312: # 行の更新
0313: # 引数 $p_trans : トランザクションハンドラへのポインタ
0314: # $p_tbl : テーブル名(文字列)へのポインタ
0315: # $p_khash : キー名=>キー値のハッシュへのポインタ
0316: # $p_vhash : カラム名=>値のハッシュへのポインタ
0317: # $p_option : SQL文のオプション(文字列)へのポインタ
0318: # $p_sql : SQL文 を返すポインタ
0319: # 返値 SQL実行後のステートメントハンドラ
0320: # エラー STDERRにメッセージを書いてexit(1)
0321: #
0322: sub updateData
0323: {
0324: my($p_trans, $p_tbl, $p_khash, $p_vhash, $p_sql)=@_;
0325: my($sql);
0326: $sql="UPDATE $$p_tbl SET ";
0327: for (keys %$p_vhash){
0328: $sql.="$_='".$$p_vhash{$_}."',";
0329: }
0330: $sql=~s/,$//;
0331: $sql.=" WHERE ";
0332: for (keys %$p_khash){
0333: $sql.="$_='".$$p_khash{$_}."' AND ";
0334: }
0335: $sql=~s/ AND $//;
0336: $$p_sql=$sql if ($p_sql);
0337: my($st)=IBPerl::Statement->new(Transaction=>$$p_trans, SQL=>$sql);
0338: if ($st->{Handle}<0){
0339: print(STDERR "updateData new: $st->{Handle} $st->{Error}\n");
0340: exit(1);
0341: }
0342: $st->execute();
0343: if ($st->{Handle}<0){
0344: print(STDERR "updateData execute: $st->{Handle} $st->{Error}\n");
0345: exit(1);
0346: }
0347: }
0348:
0349: # subroutine ######################################################
0350: # 行の検索
0351: # 引数 $p_trans : トランザクションハンドラへのポインタ
0352: # $p_tbl : テーブル名(文字列)へのポインタ
0353: # $p_khash : キー名=>キー値のハッシュへのポインタ
0354: # $p_option : SQL文のオプション(文字列)へのポインタ
0355: # $p_sql : SQL文 を返すポインタ
0356: # $dtfmt : 日付フォーマット(デフォルト %F)
0357: # $tmfmt : 時刻フォーマット(デフォルト %T)
0358: # 返値 生成したステートメントオブジェクト
0359: # エラー STDERRにメッセージを書いてexit(1)
0360: #
0361: sub selectRows{
0362: my($p_trans, $p_tbl, $p_khash, $p_option, $p_sql, $dtfmt, $tmfmt)=@_;
0363: my($sql)="SELECT * FROM $$p_tbl";
0364: if ($p_khash){
0365: $sql.=" WHERE ";
0366: for (keys %$p_khash){
0367: $sql.="$_='".$$p_khash{$_}."' AND ";
0368: }
0369: $sql=~s/AND $//;
0370: }
0371: $sql.=" ".$$p_option if ($p_option);
0372: $$p_sql=$sql if ($p_sql);
0373: my($dtformat)="%F";
0374: my($tmformat)="%T";
0375: $dtformat=$dtfmt if ($dtfmt);
0376: $tmformat=$tmfmt if ($tmfmt);
0377: my($tsformat)=$dtformat." ".$tmformat;
0378: my($st)=IBPerl::Statement->new(Transaction=>$$p_trans,
0379: SQL=>"$sql",
0380: TimeFormat=>$tmformat,
0381: DateFormat=>$dtformat,
0382: TimeStampFormat=>$tsformat);
0383: if ($st->{Handle}<0){
0384: print(STDERR "selectRowsbyKey new: $st->{Handle} $st->{Error}\n");
0385: exit(1);
0386: }
0387: return($st);
0388: }
0389:
0390: # subroutine ######################################################
0391: # 行の検索
0392: # 引数 $p_trans : トランザクションハンドラへのポインタ
0393: # $p_tbl : テーブル名(文字列)へのポインタ
0394: # $p_khash : キー名=>キー値のハッシュへのポインタ
0395: # $p_option : SQL文のオプション(文字列)へのポインタ
0396: # $p_sql : SQL文 を返すポインタ
0397: # $dtfmt : 日付フォーマット(デフォルト %F)
0398: # $tmfmt : 時刻フォーマット(デフォルト %T)
0399: # 返値 生成したステートメントオブジェクト
0400: # エラー STDERRにメッセージを書いてexit(1)
0401: #
0402: sub selectRowsLike{
0403: my($p_trans, $p_tbl, $p_khash, $p_option, $p_sql, $dtfmt, $tmfmt)=@_;
0404: my($sql)="SELECT * FROM $$p_tbl";
0405: if ($p_khash){
0406: $sql.=" WHERE ";
0407: for (keys %$p_khash){
0408: $sql.="$_ LIKE '".$$p_khash{$_}."' AND ";
0409: }
0410: $sql=~s/AND $//;
0411: }
0412: $sql.=" ".$$p_option if ($p_option);
0413: $$p_sql=$sql if ($p_sql);
0414: my($dtformat)="%F";
0415: my($tmformat)="%T";
0416: $dtformat=$dtfmt if ($dtfmt);
0417: $tmformat=$tmfmt if ($tmfmt);
0418: my($tsformat)=$dtformat." ".$tmformat;
0419: my($st)=IBPerl::Statement->new(Transaction=>$$p_trans,
0420: SQL=>"$sql",
0421: TimeFormat=>$tmformat,
0422: DateFormat=>$dtformat,
0423: TimeStampFormat=>$tsformat);
0424: if ($st->{Handle}<0){
0425: print(STDERR "selectRowsbyKey new: $st->{Handle} $st->{Error}\n");
0426: exit(1);
0427: }
0428: return($st);
0429: }
0430:
0431: # subroutine ######################################################
0432: # 1行のみfetchして返す
0433: # 引数 $p_trans : トランザクションハンドラへのポインタ
0434: # $p_tbl : テーブル名(文字列)へのポインタ
0435: # $p_khash : キー名=>キー値のハッシュへのポインタ
0436: # $p_sql : SQL文 を返すポインタ
0437: # $dtfmt : 日付フォーマット(デフォルト %F)
0438: # $tmfmt : 時刻フォーマット(デフォルト %T)
0439: # 返値 検索結果のハッシュ
0440: # エラー STDERRにメッセージを書いてexit(1)
0441: #
0442: sub selectOneLine{
0443: my($p_trans, $p_tbl, $p_khash, $p_option, $p_sql, $dtfmt, $tmfmt)=@_;
0444: my($sql)="SELECT * FROM $$p_tbl WHERE ";
0445: for (keys %$p_khash){
0446: $sql.="$_='".$$p_khash{$_}."' AND ";
0447: }
0448: $sql=~s/AND $//;
0449: $$p_sql=$sql if ($p_sql);
0450: my($dtformat)="%F";
0451: my($tmformat)="%T";
0452: $dtformat=$dtfmt if ($dtfmt);
0453: $tmformat=$tmfmt if ($tmfmt);
0454: my($tsformat)=$dtformat." ".$tmformat;
0455: my($st)=IBPerl::Statement->new(Transaction=>$$p_trans,
0456: SQL=>"$sql",
0457: TimeFormat=>$tmformat,
0458: DateFormat=>$dtformat,
0459: TimeStampFormat=>$tsformat);
0460: if ($st->{Handle}<0){
0461: print(STDERR "selectOneLine new: $st->{Handle} $st->{Error}\n");
0462: exit(1);
0463: }
0464: my(%hash);
0465: $st->fetch(\%hash);
0466: if ($st->{Handle}<0){
0467: print(STDERR "selectOneLine fetch: $st->{Handle} $st->{Error}\n");
0468: exit(1);
0469: }
0470: return(%hash);
0471: }
0472:
0473: # subroutine ######################################################
0474: # 行の削除
0475: # 引数 $p_trans : トランザクションハンドラへのポインタ
0476: # $p_tbl : テーブル名(文字列)へのポインタ
0477: # $p_khash : キー名=>キー値のハッシュへのポインタ
0478: # $p_sql : SQL文 を返すポインタ
0479: # 返値 生成したステートメントオブジェクト
0480: # エラー STDERRにメッセージを書いてexit(1)
0481: #
0482: sub deleteRows{
0483: my($p_trans, $p_tbl, $p_khash, $p_sql)=@_;
0484: my($sql)="DELETE FROM $$p_tbl";
0485: if ($p_khash){
0486: $sql.=" WHERE ";
0487: for (keys %$p_khash){
0488: $sql.="$_='".$$p_khash{$_}."' AND ";
0489: }
0490: }
0491: $sql=~s/AND $//;
0492: $$p_sql=$sql if ($p_sql);
0493: my($st)=IBPerl::Statement->new(Transaction=>$$p_trans, SQL=>"$sql");
0494: if ($st->{Handle}<0){
0495: print(STDERR "deleteRows new: $st->{Handle} $st->{Error}\n");
0496: exit(1);
0497: }
0498: $st->execute();
0499: if ($st->{Handle}<0){
0500: print(STDERR "deleteRows execute: $st->{Handle} $st->{Error}\n");
0501: exit(1);
0502: }
0503: return($st);
0504: }
0505:
0506: # subroutine ######################################################
0507: # Stored Procedure の実行
0508: # 引数 $p_trans : トランザクションハンドラへのポインタ
0509: # $p_proc : プロシージャ名(文字列)へのポインタ
0510: # $mode : 実行指示
0511: # 0 : EXECUTE した結果のステートメントハンドラを返す
0512: # 1 : fetch した1行のハッシュを返す
0513: # 2 : SELECT した結果のステートメントハンドラを返す
0514: # $p_params : パラメータの配列へのポインタ
0515: # $p_option : オプション文字列へのポインタ
0516: # $p_sql : SQL文 を返すポインタ
0517: # $dtfmt : 日付フォーマット(デフォルト %F)
0518: # $tmfmt : 時刻フォーマット(デフォルト %T)
0519: # 返値 生成したステートメントオブジェクト or 1行のハッシュ
0520: # エラー STDERRにメッセージを書いてexit(1)
0521: #
0522: sub execProcedure
0523: {
0524: my($p_trans, $p_proc, $mode, $p_params, $p_option, $p_sql, $dtfmt, $tmfmt)=@_;
0525: my($sql)=(($mode==2)?"SELECT * FROM":"EXECUTE PROCEDURE")." $$p_proc";
0526: $$p_sql=$sql if ($p_sql);
0527: if ($p_params){
0528: $sql.="(";
0529: for (@$p_params){
0530: $sql.="'" . $_ ."',";
0531: }
0532: $sql=~s/,$/\)/;
0533: }
0534: $sql.=" ".$$p_option if ($p_option);
0535: $$p_sql=$sql if ($p_sql);
0536: my($dtformat)="%F";
0537: my($tmformat)="%T";
0538: $dtformat=$dtfmt if ($dtfmt);
0539: $tmformat=$tmfmt if ($tmfmt);
0540: my($tsformat)=$dtformat." ".$tmformat;
0541: my($st)=IBPerl::Statement->new(Transaction=>$$p_trans,
0542: SQL=>"$sql",
0543: TimeFormat=>$tmformat,
0544: DateFormat=>$dtformat,
0545: TimeStampFormat=>$tsformat);
0546: $st->execute();
0547: if ($mode==1){
0548: my(%hash);
0549: $st->fetch(\%hash);
0550: return %hash;
0551: }else{
0552: return($st);
0553: }
0554: }
0555:
0556: return 1;
共通ルーチン
0001: # ----------------------------------------------------------- #
0002: # JSCommon,pm
0003: # ===========
0004: # 共通パッケージ
0005: #
0006: # :$Id: JSCommon.pm,v 1.2 ########## $
0007: #
0008: # ----------------------------------------------------------- #
0009:
0010: package JSCommon;
0011: use 5.006_001;
0012: use strict;
0013: use lib "/usr/lib/perl5/5.8.0/i386-linux-thread-multi";
0014: use Time::HiRes;
0015:
0016: our (@ISA, @EXPORT);
0017: use Exporter();
0018: @ISA = qw(Exporter);
0019: @EXPORT = qw(prnt getparam get_jpnbyspec get_byspec get_byjname get_byename
0020: make_spectable make_familytable make_genustable get_genus
0021: pers_photoid start_elapsed end_elapsed get_elapsed);
0022:
0023: my($elapsed_t1);
0024: my($elapsed_t2);
0025:
0026: sub start_elapsed
0027: {
0028: $elapsed_t1=&Time::HiRes::time();
0029: }
0030:
0031: sub get_elapsed
0032: {
0033: &Time::HiRes::time()-$elapsed_t1;
0034: }
0035:
0036:
0037: sub end_elapsed
0038: {
0039: my($columns)=@_;
0040: $columns=1 unless ($columns);
0041: $elapsed_t2=&Time::HiRes::time();
0042: &prnt("<tr>");
0043: &prnt("<td class=\"LINEC\" colspan=\"$columns\">");
0044: &prnt("<div class=\"ELAPSED\">");
0045: my($e)=($elapsed_t2-$elapsed_t1)*1000;
0046: my($b)=int($e)+1;
0047: my($bb)=int($b/500);
0048: $bb=60 if ($bb>60);
0049: $b=500 if ($bb);
0050: $b=int($b*0.75);
0051: my($bar);
0052: while ($bb--){
0053: $bar.=sprintf("<img class=\"ELAPSED2\" src=\"/img/barGreen.png\"".
0054: " width=\"4\" height=\"12\" alt=\"elapsed bar\" />");
0055: }
0056: $bar.=sprintf("<img class=\"ELAPSED1\" src=\"/img/barBlue.png\"".
0057: " width=\"%d\" height=\"12\" alt=\"elapsed bar\" />",
0058: $b);
0059: &prnt($bar.sprintf(" elapsed=%5.2f msec", $e));
0060: &prnt("</div>");
0061: &prnt("</td>");
0062: &prnt("</tr>");
0063: }
0064:
0065: my($ind)=0;
0066: my($inp)=0;
0067: sub prnt {
0068: my($txt)=@_;
0069: my($inx)=0;
0070:
0071: return unless($txt);
0072: while ($txt=~/<[a-z]/g){
0073: $ind++;
0074: $inx=$inp;
0075: }
0076: $ind-- while ($txt=~/<\//g);
0077: $ind-- while ($txt=~/ \/>/g);
0078: $ind=0 if ($ind<0);
0079: $inp=0 if ($inp<0);
0080: $inx=$ind unless($inx);
0081: print(substr(" "x40, 0, $inx), $txt, "\n");
0082: $inp=$ind;
0083: }
0084:
0085: sub getparam{
0086: my($p)=@_;
0087: for (split("&", $ENV{"QUERY_STRING"})){
0088: s/\+/ /g;
0089: s/\%([0-9A-Fa-f][0-9A-Fa-f])/chr(hex($1))/ge;
0090: my($k, $v)=split('=');
0091: $v=1 if ($k eq "error");
0092: $p->{$k}=$v;
0093: }
0094: }
0095:
0096: sub getparam2{
0097: my($p)=@_;
0098: my($paramStr);
0099: if ($ENV{REQUEST_METHOD} eq "POST"){
0100: $paramStr=<STDIN>;
0101: }else{
0102: $paramStr=$ENV{QUERY_STRING};
0103: }
0104: $paramStr=~s/\+/ /g;
0105: $paramStr=~s/\%([0-9A-Fa-f][0-9A-Fa-f])/chr(hex($1))/ge;
0106: $paramStr=~s/\'/\'\'/g;
0107: for (split("&", $paramStr)){
0108: my($k, $v)=split('=');
0109: $p->{$k}=$v;
0110: }
0111: }
0112:
0113:
0114: return 1;
初期化定数等
0001: package JSInitParam;
0002: use 5.006_001;
0003: use strict;
0004:
0005: our (@ISA, @EXPORT);
0006: use Exporter();
0007: @ISA = qw(Exporter);
0008: @EXPORT = qw(fnini);
0009:
0010: sub fnini {
0011: my($key)=@_;
0012:
0013: my(%val)=
0014: (
0015: DOMAIN => "birds.oosato.org",
0016: CMP_CGIDIR => "/var/www/birds/cgi-bin/",
0017: CMP_HOMEDIR => "/var/www/birds/",
0018:
0019: CSS_COMMON => "/FieldNotes/css/fncommon.css",
0020: CSS_JPN2SPC => "/FieldNotes/css/fnjpn2spc.css",
0021: CSS_NAVIBAR => "/FieldNotes/css/fnnavibar.css",
0022:
0023: REV_MADE => "mailto:birdinfo\@oosato.org",
0024:
0025: # CGI プログラムの URI
0026: URI_TESTCGI => "http://birds.oosato.org/cgi-bin/testcgi",
0027: URI_INDEXCGI => "http://birds.oosato.org/cgi-bin/indexcgi",
0028: URI_NOTECGI => "http://birds.oosato.org/cgi-bin/notecgi",
0029: URI_SHOWPHOTO => "http://birds.oosato.org/cgi-bin/showphoto",
0030: URI_SHOWAMEDAS => "http://birds.oosato.org/cgi-bin/showamedas",
0031: URI_SHOWTIDE => "http://birds.oosato.org/cgi-bin/showtide",
0032: URI_JPN2SPCCGI => "http://birds.oosato.org/cgi-bin/jpn2spccgi",
0033: URI_PHOTOLISTCGI => "http://birds.oosato.org/cgi-bin/photolistcgi",
0034: URI_BOOKMARKSCGI => "http://birds.oosato.org/cgi-bin/bookmarkscgi",
0035: URI_SITEMAPCGI => "http://birds.oosato.org/cgi-bin/sitemapcgi",
0036: # URI
0037: URI_NOTFOUND => "http://birds.oosato.org/notfound.html",
0038: URI_ANOTHER_HTML_LINT => "http://htmllint.oosato.org/htmllint.cgi?V;js",
0039:
0040: # jpn2spccgi の動作
0041: # JPN2SPC_USEDB 0 個別定義に従う
0042: # JPN2SPC_USEDB 1 テキストファイルベタ読み
0043: # JPN2SPC_USEDB 2 DBを使う JOIN した VIEW を使う
0044: # JPN2SPC_USEDB 3 DBを使う program で自前でカーソル回す
0045: # JPN2SPC_USEDB 4 DBを使う STORED-PROCEDURE を使う
0046: # JPN2SPC_USEDB 99 全部テストしてみる
0047: JPN2SPC_USEDB => 0, # 共通の設定
0048: JPN2SPC_WAMEIDB => 4,
0049: JPN2SPC_SPECSDB => 4, # 学名で検索 procedure
0050: JPN2SPC_ENAMEDB => 4, # 英名で検索 procedure
0051: JPN2SPC_GENUSDB => 4, # 属名で検索 procedure
0052: JPN2SPC_FAMLYDB => 4, # 科名で検索 JOIN
0053: JPN2SPC_ORDERDB => 4, # 目名で検索 procedure
0054: JPN2SPC_WPARTDB => 4,
0055: JPN2SPC_SPARTDB => 4,
0056: JPN2SPC_EPARTDB => 4,
0057:
0058: JPN2SPC_DBHOST => "mars",
0059: JPN2SPC_DBCODE => "EUCJ_0208",
0060: # JPN2SPC_DBHOST => "mercury",
0061: # JPN2SPC_DBCODE => "UTF8",
0062:
0063: # XML 宣言文
0064: XML_DECLARATION => "xml version=\"1.0\" encoding=\"euc-jp\"",
0065:
0066: # DOCTYPE 宣言文
0067: DOCTYPE_DECLARATION => "DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\"".
0068: " \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\"",
0069:
0070: # HTML 宣言文
0071: HTML_DECLARATION => "html xmlns=\"http://www.w3.org/1999/xhtml\"".
0072: " lang=\"ja-JP\" xml:lang=\"ja-JP\""
0073: );
0074:
0075: return $val{$key};
0076: }
0077:
0078: return 1;
ナヴィゲーションバー
0001: package FNNavibar;
0002: use 5.006_001;
0003: use strict;
0004: use FNCommon;
0005: use FNInitParam;
0006:
0007: our (@ISA, @EXPORT);
0008: use Exporter();
0009:
0010: @ISA = qw(Exporter);
0011: @EXPORT = qw(print_navibar);
0012:
0013: sub print_navibar{
0014: my($flag, $dateStr, $indx)=@_;
0015: my($flags)=unpack("I", pack("b32", $$flag)); # 32bit bit-array
0016: &prnt("<table class=\"NAVIHEAD\" summary=\"head\" width=\"100%\">");
0017: &prnt("<tr>");
0018:
0019: if (($flags & 2)&&(! $dateStr)){
0020: opendir(DIR, &fnini("CMP_TEXTNOTEDIR"));
0021: $dateStr=substr((sort {$b cmp $a}
0022: grep(/^n20[0-9]{6}\.txt$/, readdir(DIR)))[0],
0023: 1, 8);
0024: closedir(DIR);
0025: }
0026: my(@txt)=("top,". &fnini("URI_INDEXCGI"),
0027: "fieldnote,". &fnini("URI_NOTECGI"). "?date=$dateStr",
0028: "amedas,". &fnini("URI_SHOWAMEDAS"),
0029: "chart,". &fnini("URI_WEATHERCHART"),
0030: "tide,". &fnini("NEWURI_SHOWTIDE"),
0031: "dictionary,". &fnini("URI_JPN2SPCCGI"),
0032: ##### "miscellaneous,".&fnini("URI_MISCELLANEOUS"),
0033: "photolist,". &fnini("URI_PHOTOLISTCGI"),
0034: "soundlist,". &fnini("URI_SOUNDLIST"),
0035: "bookmark,". &fnini("URI_BOOKMARKSCGI"),
0036: "sitemap,". &fnini("URI_SITEMAPCGI"),
0037: ",");
0038: my($mask)=1;
0039: foreach (@txt){
0040: chomp;
0041: my($s, $h)=split(",");
0042: last if ($s eq "");
0043: if (2**($indx-1) & $mask){
0044: &prnt("<td class=\"NAVIHEAD12C\">");
0045: &prnt("<a class=\"NAVITAB\" href=\"$h\" rel=\"nofollow,noindex\">$s</a>");
0046: &prnt("</td>");
0047: }elsif ($flags & $mask){
0048: &prnt("<td class=\"NAVIHEAD12\">");
0049: &prnt("<a class=\"NAVITABR\" href=\"$h\" rel=\"nofollow,noindex\">$s</a>");
0050: &prnt("</td>");
0051: }else{
0052: &prnt("<td class=\"NAVIHEAD12D\">");
0053: &prnt("$s");
0054: &prnt("</td>");
0055: }
0056: $mask<<=1;
0057: }
0058: &prnt("</tr>");
0059: &prnt("</table>");
0060: }
0061:
0062: return 1;
0063:
HTML Validation
0001: package Validation;
0002: use 5.006_001;
0003: use strict;
0004: use FNInitParam;
0005: use FNCommon;
0006:
0007: our (@ISA, @EXPORT);
0008: use Exporter();
0009: @ISA = qw(Exporter);
0010: @EXPORT = qw(print_validation);
0011:
0012: sub print_validation {
0013: my($p)=@_;
0014: my($br)="";
0015: $br="<br />" if ($p==2);
0016: &prnt("<table class=\"PLAIN\" summary=\"validation\" width=\"100%\">");
0017: &prnt("<tr>");
0018: &prnt("<td class=\"PLAIN\">");
0019: &prnt("<a class=\"WHITE\"".
0020: " href=\"".&fnini("URI_ANOTHER_HTML_LINT")."\"".
0021: " rel=\"nofollow\">");
0022: &prnt("<img class=\"VALIDICON\" src=\"/img/ahl-verygoodS.gif\"".
0023: " width=\"65\" height=\"22\"");
0024: #### " width=\"88\" height=\"31\"");
0025: &prnt(" alt=\"Validation icon Another html lint\" />");
0026: &prnt("</a>");
0027: &prnt("</td>");
0028: &prnt("<td class=\"PLAIN\">");
0029: &prnt("<div class=\"VALIDPOLICY\">");
0030: &prnt("このサイトはいかなる特定のブラウザの実装も推奨しません。$br");
0031: &prnt("しかし、w3c (X)HTML規格には比較的忠実です。");
0032: &prnt("</div>");
0033: &prnt("</td>");
0034: &prnt("</tr>");
0035: &prnt("</table>");
0036: }
0037: sub ____print_validation {
0038: my($p)=@_;
0039: my($br)="";
0040: $br="<br />" if ($p==2);
0041: &prnt("<table summary=\"tail line\" width=\"100%\">");
0042: &prnt("<tr>");
0043: &prnt("<td style=\"background-color:DarkGray;width:90px;margine:0em;padding:0em\">");
0044: &prnt("<a style=\"visited.color:White; link.color:Red; hover.color:Blue; \"".
0045: " href=\"".&fnini("URI_ANOTHER_HTML_LINT")."\"".
0046: " rel=\"nofollow\">");
0047: &prnt("<img style=\"border:0px;margin:0px;padding:0px\" src=\"/img/ahl-verygood.gif\"".
0048: " width=\"88\" height=\"31\"");
0049: &prnt(" alt=\"Validation icon Another html lint\" />");
0050: &prnt("</a>");
0051: &prnt("</td>");
0052: &prnt("<td style=\"background-color:DarkGray;margine:0em;padding:0em\">");
0053: &prnt("<div style=\"font-amily:serif;font-size:0.75em;padding-left:0.25em;".
0054: "padding-right:0.25em;text-align:left\">");
0055: &prnt("このサイトはいかなる特定のブラウザの実装も推奨しません。$br");
0056: &prnt("しかし、w3c (X)HTML規格には比較的忠実です。");
0057: &prnt("</div>");
0058: &prnt("</td>");
0059: &prnt("</tr>");
0060: &prnt("</table>");
0061: }
0062: return 1;
この HTML を検査する。( XHTML 1.0 Strict で書かれています )
Another HTML Lint Gateway ( Mirrored by htmllint.oosato.org )