プログラム本体
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 http-equiv=\"Content-Type\" content=\"text/html; charset=euc-jp\" />");
0083: &prnt("<meta http-equiv=\"Content-Style-Type\" content=\"text/css\" />");
0084: &prnt("<link rel=\"stylesheet\" type=\"text/css\" href=\"".&fnini("CSS_JPN2SPC")."\" />");
0085: &prnt("<link rel=\"stylesheet\" type=\"text/css\" href=\"".&fnini("CSS_COMMON")."\" />");
0086: &prnt("<link rel=\"stylesheet\" type=\"text/css\" href=\"".&fnini("CSS_NAVIBAR")."\" />");
0087: &prnt("<link rev=\"made\" href=\"".&fnini("REV_MADE")."\" />");
0088: &prnt("<link rel=\"index\" href=\"".&fnini("URI_JPN2SPCCGI")."\" />");
0089: #&prnt("<link rel=\"prev\" href=\"".&fnini("URI_JPN2SPCCGI")."\" />");
0090: #&prnt("<link rel=\"next\" href=\"".&fnini("URI_JPN2SPCCGI")."\" />");
0091: &prnt("<title>");
0092: &prnt("世界の鳥類 名検索辞典");
0093: &prnt("</title>");
0094: &prnt("</head>");
0095:
0096: ## ---------------------------------------------------------------- ##
0097: ## HTML BODY 部開始
0098: ##
0099: ##
0100: &prnt("<body class=\"FNOTES\">");
0101: &prnt("<table class=\"FNOTES\" summary=\"jpn2spc\">");
0102: &prnt("<tr>");
0103: &prnt("<td colspan=\"6\">");
0104: ##&print_navibar(\ "100001000", 0, 6);
0105: &print_navibar(\ "1111111111", 0, 6);
0106: &prnt("</td>");
0107: &prnt("</tr>");
0108:
0109: &prnt("<tr>");
0110: &prnt("<td class=\"HEAD1\" colspan=\"6\">");
0111: &prnt("<h1 class=\"H1CENTER\">");
0112: &prnt("世界の鳥類名検索");
0113: &prnt("</h1>");
0114: &prnt("</td>");
0115: &prnt("</tr>");
0116:
0117: ## ---------------------------------------------------------------- ##
0118: ## シブリー博士と、世界鳥類リスト勉強会 への謝辞
0119: ##
0120: ##
0121: &prnt("<tr>");
0122: &prnt("<td class=\"LINEB\" colspan=\"6\">");
0123: &prnt("<div class=\"SERIFCENTER\">");
0124: &prnt("謝辞<br />");
0125: &prnt("このプログラムが使用するデータベースの作成に当たっては、<br />");
0126: &prnt("1995年にシブリー博士が公開された「Birds of the World」の学名(約9900種)と<br />");
0127: &prnt("対応する和名は<a href=\"http://www.eonet.ne.jp/~saezuri/\" rel=\"nofollow\">「明石のはらくらぶ]のページ</a>で公開されている<br />");
0128: &prnt("「世界鳥類リスト勉強会」のリストを参考にさせていただきました。<br />");
0129: &prnt("シブリー博士、ならびに世界鳥類リスト勉強会の皆様に、感謝いたします。<br />");
0130: &prnt("</div>");
0131: &prnt("</td>");
0132: &prnt("</tr>");
0133:
0134: ## ---------------------------------------------------------------- ##
0135: ## 分類体系について
0136: ##
0137: ##
0138: &prnt("<tr>");
0139: &prnt("<td class=\"LINEB\" colspan=\"6\">");
0140: &prnt("<div class=\"SERIFCENTER\">");
0141: &prnt("なお、目および科の分類はおおよそシブリー・アールキスト分類に準拠したつもりです。<br />");
0142: &prnt("古典的分類に慣れていると違和感ありますが、慣れましょう(^^;<br />");
0143: &prnt("</div>");
0144: &prnt("</td>");
0145: &prnt("</tr>");
0146:
0147: my($sql);
0148: my($c)=0;
0149: ## ---------------------------------------------------------------- ##
0150: ## 和名から変換
0151: ##
0152:
0153: ####
0154: # フォーム印字
0155: #
0156: printform("和名から変換", "和名", "WAMEI", 68, $pvalue{USAGE});
0157:
0158: ####
0159: # 検索表示
0160: #
0161: if ($pvalue{WAMEI}){
0162: ########
0163: # 名前の正規化をする
0164: # 前後の空白を削除する
0165: #
0166: $pvalue{SPECS}=~s/^ *//g;
0167: $pvalue{SPECS}=~s/ *$//g;
0168: #
0169: # ひらがなだったらカタカナにする
0170: # (EUC-JPにべったり依存なコード) スマートな方法が他にあるとは思うが
0171: my($hname)=unpack("H*", $pvalue{WAMEI});
0172: $hname=~s/a4a4/a4XX/g;
0173: $hname=~s/a5a4/a5XX/g;
0174: $hname=~s/a4/a5/g;
0175: $hname=~s/a5XX/a5a4/g;
0176: $pvalue{WAMEI}=pack("H*", $hname);
0177:
0178: if ($DBCODE eq "UTF8"){
0179: &Encode::from_to($pvalue{WAMEI}, "eucjp", "utf8");
0180: }
0181: my($t1)=&Time::HiRes::time();
0182: #
0183: # Transaction 開始
0184: my($trans);
0185: &startTransaction(\$DB, \$trans);
0186: #
0187: # 見出し行印字
0188: &printcolhead;
0189: #
0190: # 配列にパラメータを入れる
0191: my(@param)=($pvalue{WAMEI});
0192: #
0193: # PROCEDURE 呼び出し
0194: my(%hash)=&execProcedure(\$trans, \ "PS_J_SGFO", 1, \@param, 0, \$sql);
0195: #
0196: # Transaction 終了
0197: &commitTransaction(\$trans);
0198: # カウンタ変数
0199: $c=0;
0200: if ($hash{SPECIESNAME}){
0201: # 検索結果行印字
0202: ## &prcolg($hash{ORDERNAME}, $hash{ORDERJPN},
0203: ## $hash{FAMILYNAME}, $hash{FAMILYJPN});
0204: &prcolg($hash{ORDERNAME}, $hash{ORDERJPN},
0205: $hash{FAMILYNAME}, $hash{FAMILYJPN},
0206: $hash{GENUSNAME}, $hash{GENUSJPN});
0207: &prcols($hash{SPECIESNAME}, $hash{SPECIESJPN}, $hash{SPECIESENG});
0208: $c++;
0209: }
0210: # サマリ行印字
0211: &printsum($pvalue{WAMEI}, $c, $t1);
0212: }
0213:
0214: ## ---------------------------------------------------------------- ##
0215: ## 学名から変換
0216: ##
0217:
0218: ####
0219: # フォーム印字
0220: #
0221: printform("学名から変換", "学名", "SPECS", 68, $pvalue{"USAGE"});
0222:
0223: ####
0224: # 検索表示
0225: #
0226: if ($pvalue{"SPECS"}){
0227: ########
0228: # 名前の正規化をする
0229: # 連続する空白を1個に詰める
0230: $pvalue{SPECS}=~s/ */ /g;
0231: #
0232: # 前後の空白を削除する
0233: $pvalue{SPECS}=~s/^ *//g;
0234: $pvalue{SPECS}=~s/ *$//g;
0235: #
0236: # 先頭文字を大文字、その他を小文字にする
0237: $pvalue{SPECS}=ucfirst(lc($pvalue{SPECS}));
0238:
0239: my($t1)=&Time::HiRes::time();
0240: my($trans);
0241: &startTransaction(\$DB, \$trans);
0242: my(@param)=($pvalue{SPECS});
0243: my(%hash)=&execProcedure(\$trans, \ "PS_N_SGFO", 1, \@param, 0, \$sql);
0244: &commitTransaction(\$trans);
0245: &printcolhead;
0246: $c=0;
0247: if ($hash{SPECIESNAME}){
0248: &prcolg($hash{ORDERNAME}, $hash{ORDERJPN},
0249: $hash{FAMILYNAME}, $hash{FAMILYJPN},
0250: $hash{GENUSNAME}, $hash{GENUSJPN});
0251: &prcols($hash{SPECIESNAME}, $hash{SPECIESJPN}, $hash{SPECIESENG});
0252: $c++;
0253: }
0254: # サマリ行印字
0255: &printsum($pvalue{SPECS}, $c, $t1);
0256: }
0257:
0258: ## ---------------------------------------------------------------- ##
0259: ## 英名から変換
0260: ##
0261:
0262: ####
0263: # フォーム印字
0264: #
0265: printform("英名から変換", "英名", "ENAME", 68, $pvalue{"USAGE"});
0266:
0267: ####
0268: # 検索表示
0269: #
0270: if ($pvalue{"ENAME"}){
0271: # 名前の正規化
0272: # 連続する空白を1個に詰める
0273: $pvalue{ENAME}=~s/ */ /g;
0274: # 前後の空白を削除する
0275: $pvalue{ENAME}=~s/^ *//g;
0276: $pvalue{ENAME}=~s/ *$//g;
0277: # 大文字に揃える
0278: my($uc)=uc($pvalue{ENAME});
0279: my($t1)=&Time::HiRes::time();
0280: my($trans);
0281: &startTransaction(\$DB, \$trans);
0282: my(@param)=($uc);
0283: my(%hash)=&execProcedure(\$trans, \ "PS_ECAP_SGFO", 1, \@param, 0, \$sql);
0284: &commitTransaction(\$trans);
0285: &printcolhead;
0286: $c=0;
0287: if ($hash{SPECIESNAME}){
0288: &prcolg($hash{ORDERNAME}, $hash{ORDERJPN},
0289: $hash{FAMILYNAME}, $hash{FAMILYJPN},
0290: $hash{GENUSNAME}, $hash{GENUSJPN});
0291: &prcols($hash{SPECIESNAME}, $hash{SPECIESJPN}, $hash{SPECIESENG});
0292: $c++;
0293: }
0294: # サマリ行印字
0295: &printsum($pvalue{ENAME}, $c, $t1);
0296: }
0297:
0298: ## ---------------------------------------------------------------- ##
0299: ## 属名から検索
0300: ##
0301:
0302: ####
0303: # フォーム印字
0304: #
0305: printform("属名から検索", "属名", "GENUS", 68, $pvalue{"USAGE"});
0306:
0307: ####
0308: # 検索表示
0309: #
0310: if ($pvalue{"GENUS"}){
0311: # # 名前の正規化をする
0312: # # 連続する空白を1個に詰める
0313: # $pvalue{GENUS}=~s/ */ /g;
0314: # # 前後の空白を削除する
0315: # $pvalue{GENUS}=~s/^ *//g;
0316: # $pvalue{GENUS}=~s/ *$//g;
0317: # # 先頭文字を大文字、その他を小文字にする
0318: # $pvalue{GENUS}=ucfirst(lc($pvalue{GENUS}));
0319: #
0320: # my($t1)=&Time::HiRes::time();
0321: # my($trans);
0322: # &startTransaction(\$DB, \$trans);
0323: # my(@param)=($pvalue{GENUS});
0324: # my($st)=&execProcedure(\$trans, \ "PG_N_SGFO", 2, \@param, \ "ORDER BY SEQNO", \$sql);
0325: # &printcolhead;
0326: # $c=0;
0327: # my(%hash);
0328: # while ($st->fetch(\%hash)==0){
0329: # &prcolg($hash{ORDERNAME}, $hash{ORDERJPN},
0330: # $hash{FAMILYNAME}, $hash{FAMILYJPN},
0331: # $hash{GENUSNAME}, $hash{GENUSJPN});
0332: # &prcols($hash{SPECIESNAME}, $hash{SPECIESJPN}, $hash{SPECIESENG});
0333: # $c++;
0334: # }
0335: # &commitTransaction(\$trans);
0336: # &printsum($pvalue{"GENUS"}, $c, $t1);
0337:
0338: ##---------------------------------
0339:
0340: #
0341: # 学名か和名か判断して名前の正規化をする
0342: # 連続する空白を1個に詰める
0343: $pvalue{GENUS}=~s/ */ /g;
0344: # 前後の空白を削除する
0345: $pvalue{GENUS}=~s/^ *//g;
0346: $pvalue{GENUS}=~s/ *$//g;
0347: my($WA);
0348: if ($pvalue{"GENUS"}=~/[a-zA-Z]/){
0349: # ASCII文字があるのでたぶん学名とラフな判断
0350: # 学名の規則に従い、先頭文字を大文字、その他を小文字にする
0351: $pvalue{GENUS}=ucfirst(lc($pvalue{GENUS}));
0352: $WA=0;
0353: }else{
0354: # 学名じゃないようなので和名
0355: # ひらがなはカタカナに (EUC-JP依存ベタベタ)
0356: my($hname)=unpack("H*", $pvalue{GENUS});
0357: $hname=~s/a4a4/a4XX/g;
0358: $hname=~s/a5a4/a5XX/g;
0359: $hname=~s/a4/a5/g;
0360: $hname=~s/a5XX/a5a4/g;
0361: $pvalue{GENUS}=pack("H*", $hname);
0362: # 末尾に「属」がついてなければ補完
0363: $pvalue{GENUS}.="属" unless ($pvalue{GENUS}=~/属$/);
0364: $WA=1;
0365: }
0366:
0367:
0368: #### &prnt($pvalue{GENUS});
0369: my($t1)=&Time::HiRes::time();
0370: # Transaction 開始
0371: my($trans);
0372: &startTransaction(\$DB, \$trans);
0373: # 見出し印字
0374: &printcolhead;
0375: my(@param)=($pvalue{GENUS});
0376: my($st)=&execProcedure(\$trans,
0377: \ (($WA)?"PG_J_SGFO":"PG_N_SGFO"),
0378: 2, \@param, \ "ORDER BY SEQNO", \$sql);
0379: # 検索数カウンタ
0380: $c=0;
0381: my(%hash);
0382: # データセットを FETCH
0383: while ($st->fetch(\%hash)==0){
0384: # 行印字
0385: &prcolg($hash{ORDERNAME}, $hash{ORDERJPN},
0386: $hash{FAMILYNAME}, $hash{FAMILYJPN},
0387: $hash{GENUSNAME}, $hash{GENUSJPN});
0388: &prcols($hash{SPECIESNAME}, $hash{SPECIESJPN}, $hash{SPECIESENG});
0389: $c++;
0390: }
0391: # Transaction 終了
0392: &commitTransaction(\$trans);
0393: # サマリ行印字
0394: &printsum($pvalue{GENUS}, $c, $t1);
0395:
0396:
0397:
0398: }
0399:
0400: ## ---------------------------------------------------------- ##
0401: ## 科名から検索
0402: ##
0403:
0404: ####
0405: # フォームの印字
0406: #
0407: printform("科名から検索", "科名", "FAMLY", 68, $pvalue{USAGE});
0408:
0409: ####
0410: # 検索結果の印字
0411: #
0412: if ($pvalue{FAMLY}){
0413: #
0414: # 学名か和名か判断して名前の正規化をする
0415: # 連続する空白を1個に詰める
0416: $pvalue{FAMLY}=~s/ */ /g;
0417: # 前後の空白を削除する
0418: $pvalue{FAMLY}=~s/^ *//g;
0419: $pvalue{FAMLY}=~s/ *$//g;
0420: my($WA);
0421: if ($pvalue{"FAMLY"}=~/[a-zA-Z]/){
0422: # ASCII文字があるのでたぶん学名とラフな判断
0423: # 学名の規則に従い、先頭文字を大文字、その他を小文字にする
0424: $pvalue{FAMLY}=ucfirst(lc($pvalue{FAMLY}));
0425: $WA=0;
0426: }else{
0427: # 学名じゃないようなので和名
0428: # ひらがなはカタカナに (EUC-JP依存ベタベタ)
0429: my($hname)=unpack("H*", $pvalue{FAMLY});
0430: $hname=~s/a4a4/a4XX/g;
0431: $hname=~s/a5a4/a5XX/g;
0432: $hname=~s/a4/a5/g;
0433: $hname=~s/a5XX/a5a4/g;
0434: $pvalue{FAMLY}=pack("H*", $hname);
0435: # 末尾に「科」がついてなければ補完
0436: $pvalue{FAMLY}.="科" unless ($pvalue{FAMLY}=~/科$/);
0437: $WA=1;
0438: }
0439:
0440: my($t1)=&Time::HiRes::time();
0441: # Transaction 開始
0442: my($trans);
0443: &startTransaction(\$DB, \$trans);
0444: # 見出し印字
0445: &printcolhead;
0446: my(@param)=($pvalue{FAMLY});
0447: my($st)=&execProcedure(\$trans,
0448: \ (($WA)?"PF_J_SGFO":"PF_N_SGFO"),
0449: 2, \@param, \ "ORDER BY SEQNO", \$sql);
0450: # 検索数カウンタ
0451: $c=0;
0452: my(%hash);
0453: # データセットを FETCH
0454: while ($st->fetch(\%hash)==0){
0455: # 行印字
0456: &prcolg($hash{ORDERNAME}, $hash{ORDERJPN},
0457: $hash{FAMILYNAME}, $hash{FAMILYJPN},
0458: $hash{GENUSNAME}, $hash{GENUSJPN});
0459: &prcols($hash{SPECIESNAME}, $hash{SPECIESJPN}, $hash{SPECIESENG});
0460: $c++;
0461: }
0462: # Transaction 終了
0463: &commitTransaction(\$trans);
0464: # サマリ行印字
0465: &printsum($pvalue{FAMLY}, $c, $t1);
0466: }
0467:
0468: ## ---------------------------------------------------------- ##
0469: ## 目名から検索
0470: ##
0471:
0472: ####
0473: # フォームの印字
0474: #
0475: printform("目名から検索", "目名", "ORDER", 68, $pvalue{USAGE});
0476:
0477: ####
0478: # 検索結果の印字
0479: #
0480: if ($pvalue{ORDER}){
0481: # 学名か和名か判断して名前の正規化をする
0482: # 連続する空白を1個に詰める
0483: $pvalue{ORDER}=~s/ */ /g;
0484: # 前後の空白を削除する
0485: $pvalue{ORDER}=~s/^ *//g;
0486: $pvalue{ORDER}=~s/ *$//g;
0487: my($WA);
0488: if ($pvalue{"ORDER"}=~/[a-zA-Z]/){
0489: # ASCII文字があるのでたぶん学名とラフな判断
0490: # 先頭文字を大文字、その他を小文字にする
0491: $pvalue{ORDER}=ucfirst(lc($pvalue{ORDER}));
0492: $WA=0;
0493: }else{
0494: # 学名じゃないようなので和名
0495: # ひらがなはカタカナに (EUC-JP依存ベタベタ)
0496: my($hname)=unpack("H*", $pvalue{ORDER});
0497: $hname=~s/a4a4/a4XX/g;
0498: $hname=~s/a5a4/a5XX/g;
0499: $hname=~s/a4/a5/g;
0500: $hname=~s/a5XX/a5a4/g;
0501: $pvalue{ORDER}=pack("H*", $hname);
0502: # 末尾に「目」がついてなければ補完
0503: $pvalue{ORDER}.="目" unless ($pvalue{ORDER}=~/目$/);
0504: $WA=1;
0505: }
0506:
0507: my($t1)=&Time::HiRes::time();
0508: # Transaction 開始
0509: my($trans);
0510: &startTransaction(\$DB, \$trans);
0511: # 見出し印字
0512: &printcolhead;
0513: my(@param)=($pvalue{ORDER});
0514: my($st)=&execProcedure(\$trans,
0515: \ (($WA)?"PO_J_SGFO":"PO_N_SGFO"),
0516: 2, \@param, \ "ORDER BY SEQNO", \$sql);
0517: $c=0;
0518: my(%hash);
0519: # データセットを FETCH
0520: while ($st->fetch(\%hash)==0){
0521: # 行印字
0522: &prcolg($hash{ORDERNAME}, $hash{ORDERJPN},
0523: $hash{FAMILYNAME}, $hash{FAMILYJPN},
0524: $hash{GENUSNAME}, $hash{GENUSJPN});
0525: &prcols($hash{SPECIESNAME}, $hash{SPECIESJPN}, $hash{SPECIESENG});
0526: $c++;
0527: }
0528: # Transaction 終了
0529: &commitTransaction(\$trans);
0530: # サマリ行印字
0531: &printsum($pvalue{"ORDER"}, $c, $t1);
0532: }
0533:
0534:
0535: ## ---------------------------------------------------------- ##
0536: ## 和名から部分一致検索
0537: ##
0538:
0539: ####
0540: # フォームの印字
0541: #
0542: printform("和名から部分一致検索", "和名の一部", "WPART", 60, $pvalue{"USAGE"});
0543:
0544: ####
0545: # 検索結果の印字
0546: #
0547: if ($pvalue{WPART}){
0548: ########
0549: # 名前の正規化をする
0550: # 前後の空白を削除する
0551: #
0552: $pvalue{WPART}=~s/^ *//g;
0553: $pvalue{WPART}=~s/ *$//g;
0554: #
0555: # 1バイト文字は削除する
0556: $pvalue{WPART}=~s/[ -~]//g;
0557: #
0558: # ひらがなだったらカタカナにする
0559: # (EUC-JPにべったり依存なコード) スマートな方法が他にあるとは思うが
0560: my($hname)=unpack("H*", $pvalue{WPART});
0561: $hname=~s/a4a4/a4XX/g;
0562: $hname=~s/a5a4/a5XX/g;
0563: $hname=~s/a4/a5/g;
0564: $hname=~s/a5XX/a5a4/g;
0565: $pvalue{WPART}=pack("H*", $hname);
0566:
0567: my($t1)=&Time::HiRes::time();
0568: # Transaction 開始
0569: my($trans);
0570: &startTransaction(\$DB, \$trans);
0571: # 見出し印字
0572: &printcolhead;
0573: # 検索数カウンタ
0574: $c=0;
0575: if ($pvalue{WPART}){
0576: my(@param)=("%".$pvalue{WPART}."%");
0577: my($st)=&execProcedure(\$trans, \ "PS_JLIKE_SGFO",
0578: 2, \@param, \ "ORDER BY SEQNO", \$sql);
0579: my(%hash);
0580: # データセットを FETCH
0581: while ($st->fetch(\%hash)==0){
0582: # 行印字
0583: &prcolg($hash{ORDERNAME}, $hash{ORDERJPN},
0584: $hash{FAMILYNAME}, $hash{FAMILYJPN},
0585: $hash{GENUSNAME}, $hash{GENUSJPN});
0586: &prcols($hash{SPECIESNAME}, $hash{SPECIESJPN}, $hash{SPECIESENG});
0587: $c++;
0588: }
0589: }
0590: # Transaction 終了
0591: &commitTransaction(\$trans);
0592: # サマリ行印字
0593: &printsum($pvalue{WPART}, $c, $t1);
0594: }
0595:
0596:
0597: ## ---------------------------------------------------------- ##
0598: ## 学名から部分一致検索
0599: ##
0600:
0601: ####
0602: # フォームの印字
0603: #
0604: printform("学名から部分一致検索", "学名の一部", "SPART", 60, $pvalue{"USAGE"});
0605:
0606: ####
0607: # 検索結果の印字
0608: #
0609: if ($pvalue{"SPART"}){
0610: my($t1)=&Time::HiRes::time();
0611: my($trans);
0612: &startTransaction(\$DB, \$trans);
0613:
0614: $pvalue{SPART}=~s/[^ A-Za-z]//g;
0615: # Upper-Case に変換
0616: my($uc)=uc($pvalue{SPART});
0617: # シングルクォートをエスケープ
0618: $uc=~s/\'/\'\'/g;
0619: # 連続する空白を1個に
0620: $uc=~s/ */ /g;
0621:
0622: $c=0;
0623: if ($uc){
0624: my(@param)=("%".$uc."%");
0625: my($st)=&execProcedure(\$trans, \ "PS_NLIKE_SGFO",
0626: 2, \@param, \ "ORDER BY SEQNO", \$sql);
0627: &printcolhead;
0628: my(%hash);
0629: while ($st->fetch(\%hash)==0){
0630: &prcolg($hash{ORDERNAME}, $hash{ORDERJPN},
0631: $hash{FAMILYNAME}, $hash{FAMILYJPN},
0632: $hash{GENUSNAME}, $hash{GENUSJPN});
0633: &prcols($hash{SPECIESNAME}, $hash{SPECIESJPN}, $hash{SPECIESENG});
0634: $c++;
0635: }
0636: }
0637: &printsum($pvalue{"SPART"}, $c, $t1);
0638: &commitTransaction(\$trans);
0639: }
0640:
0641: ## ---------------------------------------------------------- ##
0642: ## 英名から部分一致検索
0643: ##
0644:
0645: ####
0646: # フォームの印字
0647: #
0648: printform("英名から部分一致検索", "英名の一部", "EPART", 60, $pvalue{"USAGE"});
0649:
0650: ####
0651: # 検索結果の印字
0652: #
0653: if ($pvalue{"EPART"}){
0654: my($t1)=&Time::HiRes::time();
0655: my($trans);
0656: &startTransaction(\$DB, \$trans);
0657: my(%khash);
0658:
0659: $pvalue{EPART}=~s/[^ A-Za-z\']//g;
0660: my($uc)=uc($pvalue{EPART});
0661: $uc=~s/ */ /g;
0662: $c=0;
0663: if ($uc){
0664: my(@param)=("%".$uc."%");
0665: my($st)=&execProcedure(\$trans, \ "PS_ELIKE_SGFO",
0666: 2, \@param, \ "ORDER BY SEQNO", \$sql);
0667: &printcolhead;
0668: my(%hash);
0669: while ($st->fetch(\%hash)==0){
0670: &prcolg($hash{ORDERNAME}, $hash{ORDERJPN},
0671: $hash{FAMILYNAME}, $hash{FAMILYJPN},
0672: $hash{GENUSNAME}, $hash{GENUSJPN});
0673: &prcols($hash{SPECIESNAME}, $hash{SPECIESJPN}, $hash{SPECIESENG});
0674: $c++;
0675: }
0676: }
0677: &printsum($pvalue{"EPART"}, $c, $t1);
0678: &commitTransaction(\$trans);
0679: }
0680:
0681:
0682: ## /*---- 目科属のリスト ----------------*/
0683: &prnt("<tr>");
0684: &prnt("<td class=\"LINEA\" colspan=\"6\">");
0685: &prnt("<div class=\"JSCOMMENTHEAD\">");
0686:
0687: &prnt("【目・科・属のリスト】");
0688: &prnt("</div>");
0689: &prnt("</td>");
0690: &prnt("</tr>");
0691: &prnt("<tr>");
0692: &prnt("<td class=\"LINEB\" colspan=\"6\">");
0693: &prnt("<form method=\"post\" action=\"".&fnini("URI_JPN2SPCCGI")."\">");
0694: &prnt("<div class=\"SERIF\">");
0695: &prnt("参考：このデータベースで採用している分類一覧を表示します");
0696: &prnt("<input name=\"GLIST\" type=\"hidden\" value=\"1\" />");
0697: &prnt("<input type=\"submit\" accesskey=\"S\" tabindex=\"6\" value=\"実行\" />");
0698: &prnt("</div>");
0699: &prnt("</form>");
0700: #&prnt("<div class=\"SERIF\">");
0701: #&prnt("属名の和訳の体系的なリストが手に入りません。どなたかご存じでしたら教えてください。<br/>");
0702: #&prnt("属の和訳名だけは暇を見てぼつぼつと手入力していますので、少しずつ増えています。");
0703: #&prnt("</div>");
0704:
0705: &prnt("</td>");
0706: &prnt("</tr>");
0707:
0708: my($t1)=&Time::HiRes::time();
0709:
0710: if ($pvalue{"GLIST"}){
0711: &prnt("<tr>");
0712: &prnt("<td class=\"LINEA\" colspan=\"2\">");
0713: &prnt("<div class=\"JSCOMMENTHEAD\">目</div>");
0714: &prnt("</td>");
0715: &prnt("<td class=\"LINEA\" colspan=\"2\">");
0716: &prnt("<div class=\"JSCOMMENTHEAD\">科</div>");
0717: &prnt("</td>");
0718: &prnt("<td class=\"LINEA\" colspan=\"1\">");
0719: &prnt("<div class=\"JSCOMMENTHEAD\">属</div>");
0720: &prnt("</td>");
0721: &prnt("</tr>");
0722:
0723: my($trans);
0724: &startTransaction(\$DB, \$trans);
0725: my($st)=&execProcedure(\$trans, \ "PG_LIST", 2, 0, 0, \$sql);
0726: $c=0;
0727: my(%r);
0728: while($st->fetch(\%r)==0){
0729: if ($DBCODE eq "UTF8"){
0730: &Encode::from_to($r{ORDERJPN}, "utf8", "eucjp");
0731: &Encode::from_to($r{FAMILYJPN}, "utf8", "eucjp");
0732: &Encode::from_to($r{SPECIESJPN}, "utf8", "eucjp");
0733: }
0734: &prnt("<tr>");
0735: &prnt("<td class=\"LINEE\" colspan=\"2\">");
0736: &prnt("<div class=\"JSDETAIL\">");
0737: &prnt("<a class=\"LINK\" href=\"/cgi-bin/jpn2spccgi?ORDER=$r{ORDERNAME}\">");
0738: &prnt("$r{ORDERNAME} $r{ORDERJPN}");
0739: &prnt("</a>");
0740: &prnt("</div>");
0741: &prnt("</td>");
0742: &prnt("<td class=\"LINEE\" colspan=\"2\">");
0743: &prnt("<div class=\"JSDETAIL\">");
0744: &prnt("<a class=\"LINK\" href=\"/cgi-bin/jpn2spccgi?FAMLY=$r{FAMILYNAME}\">");
0745: &prnt("$r{FAMILYNAME} $r{FAMILYJPN}");
0746: &prnt("</a>");
0747: &prnt("</div>");
0748: &prnt("</td>");
0749: &prnt("<td class=\"LINEE\">");
0750: &prnt("<div class=\"JSDETAIL\">");
0751: &prnt("<a class=\"LINK\" href=\"/cgi-bin/jpn2spccgi?GENUS=$r{GENUSNAME}\">");
0752: &prnt("$r{GENUSNAME} $r{GENUSJPN}");
0753: &prnt("</a>");
0754: &prnt("</div>");
0755: &prnt("</td>");
0756: &prnt("</tr>");
0757: $c++;
0758: }
0759: printsum("目・科・属", $c, $t1);
0760: &commitTransaction(\$trans);
0761: }
0762:
0763: ## ---------------------------------------------------------------- ##
0764: ## このプログラムとデータについて
0765: ##
0766: ##
0767: &prnt("<tr>");
0768: &prnt("<td class=\"LINEB\" colspan=\"6\">");
0769: &prnt("<div class=\"SERIFCENTER\">");
0770: &prnt("<a href=\"http://www.oosato.org/firebird/\">このプログラムとデータについて</a>");
0771: &prnt("</div>");
0772: &prnt("</td>");
0773: &prnt("</tr>");
0774:
0775: ## ---------------------------------------------------------------- ##
0776: ## ロギング
0777: ##
0778: ##
0779: my($trans);
0780: &startTransaction(\$DB, \$trans);
0781: # 今回発行された SQL 文
0782: # シングルクォートをエスケープ
0783: $sql=~s/\'/\'\'/g;
0784:
0785: # ACCLOG テーブルに書き込
0786: my($procname)="P_INSERT_ACCLOG";
0787: my($datetime)=strftime("%F %T", localtime);
0788: my(@param)=($datetime, # 日付時刻
0789: $$, # プロセスID
0790: $ENV{REMOTE_ADDR}, # IP アドレス
0791: &get_elapsed(), # 処理時間
0792: $c, # 抽出件数
0793: substr($paramStr, 0, 128), # 問合せパラメータ
0794: substr($sql, 0, 256)); # SQL 文
0795: &execProcedure(\$trans, \$procname, 0, \@param);
0796:
0797: # REMOTEHOST テーブルに書き込む
0798: if ($ENV{REMOTE_ADDR}){
0799: my($tablename)="REMOTEHOST";
0800: # IPアドレスがテーブルに存在するかチェック
0801: # 存在すれば 日付時刻のみ更新
0802: # 存在しなければホスト名を逆引きし、日付時刻 IP アドレス ホスト名を 作成
0803: my(%khash)=(IPADDR=>$ENV{REMOTE_ADDR});
0804: my(%vhash);
0805: if (&checkSelect(\$trans, \$tablename, \%khash)){
0806: %vhash=(DATETIME=>$datetime);
0807: &updateData(\$trans, \$tablename, \%khash, \%vhash);
0808: }else{
0809: my($hostname)=gethostbyaddr(inet_aton($ENV{REMOTE_ADDR}), AF_INET);
0810: %vhash=(DATETIME=>$datetime, IPADDR=>$ENV{REMOTE_ADDR}, HOSTNAME=>$hostname);
0811: &insertData(\$trans, \$tablename, \%vhash);
0812: }
0813: }
0814: &commitTransaction(\$trans);
0815:
0816: ## ---------------------------------------------------------------- ##
0817: ## 処理時間表示
0818: ## validation 表示
0819: ##
0820: #&prnt("<tr>");
0821: &end_elapsed(6);
0822: #&prnt("</tr>");
0823:
0824: if ($ENV{REQUEST_METHOD} ne "POST"){
0825: my($counter);
0826: # open(FILE, &fnini("CMP_TEXTDIR")."counter.txt");
0827: # read(FILE, $counter, 10);
0828: # close(FILE);
0829: # unless ($ENV{"REMOTE_ADDR"}=~/^192.168.1/ ||
0830: # $ENV{"REMOTE_ADDR"}=~/^210.138.117.70/ ||
0831: # $ENV{"REMOTE_ADDR"}=~/^125.30.97/ ){
0832: # open(FILE, ">".&fnini("CMP_TEXTDIR")."counter.txt");
0833: # $counter++;
0834: # print(FILE $counter."\n");
0835: # close(FILE);
0836: # }
0837: $counter=&inc_acccounter;
0838: &print_author($counter, 5);
0839: }
0840:
0841: &prnt("<tr>");
0842: &prnt("<td class=\"LINEC\" colspan=\"6\">");
0843: &print_validation;
0844: &prnt("</td>");
0845: &prnt("</tr>");
0846:
0847: &prnt("</table>");
0848: &prnt("</body>");
0849: &prnt("</html>");
0850: &disconnectDB(\$DB);
0851: exit(0);
0852:
0853: ##
0854: ## end of main
0855: ## ---------------------------------------------------------------- ##
0856: ## subroutine
0857: ##
0858:
0859: sub printform
0860: {
0861: my($title, $label, $name, $width, $usage)=@_;
0862:
0863: &prnt("<tr>");
0864: &prnt("<td class=\"LINEA\" colspan=\"6\">");
0865: &prnt("<div class=\"JSCOMMENTHEAD\">");
0866: &prnt("【$title】 <a href=\"".&fnini("URI_JPN2SPCCGI")."?USAGE=$name\"".
0867: " rel=\"nofollow,noimdex\">(使い方を表示)</a>");
0868: &prnt("</div>");
0869: if ($usage eq $name){
0870: if ($usage eq "WAMEI"){
0871: &prnt("<div class=\"SERIF\">");
0872: &prnt("和名を全角カタカナまたはひらがなで入れてください<br />");
0873: &prnt("例:「マガモ」と入力すると");
0874: &prnt("学名 Anas platyrhynchos 英名 Mallard が表示されます<br />");
0875: &prnt("例:「かわう」と入力すると");
0876: &prnt("学名 Phalacrocorax carbo 英名 Great Cormorant が表示されます<br />");
0877: &prnt("</div>");
0878: }
0879: if ($usage eq "SPECS"){
0880: &prnt("<div class=\"SERIF\">");
0881: &prnt("学名をローマ字で入れてください。大文字小文字は区別しません<br />");
0882: &prnt("例:「Calidris alpina」と入力すると");
0883: &prnt("和名ハマシギ 英名 Dunlin が表示されます<br />");
0884: &prnt("例:「cettia diphone 」と入力すると");
0885: &prnt("和名ウグイス 英名 Japanese Bush-Warbler が表示されます<br />");
0886: &prnt("</div>");
0887: }
0888: if ($usage eq "ENAME"){
0889: &prnt("<div class=\"SERIF\">");
0890: &prnt("英名をローマ字で入れてください。大文字小文字は区別しません<br />");
0891: &prnt("例:「Common Gull」と入力すると");
0892: &prnt("和名カモメ 学名 Larus canus が表示されます<br />");
0893: &prnt("例:「asian rosy-finch」と入力すると");
0894: &prnt("和名ハギマシコ 学名 Leucosticte arctoa が表示されます<br />");
0895: &prnt("</div>");
0896: }
0897: if ($usage eq "GENUS"){
0898: &prnt("<div class=\"SERIF\">");
0899: &prnt("属名(種の学名の前半部分)をローマ字で入れてください。".
0900: "大文字小文字は区別しません<br />");
0901: &prnt("例:「Accipiter」と入力すると");
0902: &prnt("オオタカ、ツミ、…などハイタカ属が表示されます<br />");
0903: &prnt("例:「クサシギ属」と入力すると");
0904: &prnt("アカアシシギ、アオアシシギ、…などクサシギ属が表示されます<br />");
0905: &prnt("ただし、属の和名は全てがデータ化されてはいません。和名で検索できない時は");
0906: &prnt("学名を入れてみてください<br />");
0907: &prnt("</div>");
0908: }
0909: if ($usage eq "FAMLY"){
0910: &prnt("<div class=\"SERIF\">");
0911: &prnt("科名を学名または和名で入れてください。<br />");
0912: &prnt("例:「Gaviidae」と入力すると");
0913: &prnt("アビ科に属する全てが表示されます<br />");
0914: &prnt("例:「ペンギン科」と入力すると");
0915: &prnt("ペンギン科に属する全てが表示されます<br />");
0916: &prnt("</div>");
0917: }
0918: if ($usage eq "ORDER"){
0919: &prnt("<div class=\"SERIF\">");
0920: &prnt("目名を学名または和名で入れてください<br />");
0921: &prnt("例:「Gruiformes」と入力すると");
0922: &prnt("ツル目に属する全てが表示されます<br />");
0923: &prnt("例:「ブッポウソウ目」と入力すると");
0924: &prnt("ブッポウソウ目に属する全てが表示されます<br />");
0925: &prnt("注意:うかつに「スズメ目」と入れたりして".
0926: "表示に猛烈な時間がかかっても知りません(^^;;");
0927: &prnt("</div>");
0928: }
0929: if ($usage eq "WPART"){
0930: &prnt("<div class=\"SERIF\">");
0931: &prnt("和名の一部を入れてください<br />");
0932: &prnt("例:「ホオジロ」と入力すると");
0933: &prnt("ミヤマホオジロ、ホオジロガモ、…などが表示されます<br />");
0934: &prnt("</div>");
0935: }
0936: if ($usage eq "SPART"){
0937: &prnt("<div class=\"SERIF\">");
0938: &prnt("学名の一部を入れてください<br />");
0939: &prnt("例:「major」と入力すると");
0940: &prnt("Dendrocopos major、Parus major、…などが表示されます<br />");
0941: &prnt("</div>");
0942: }
0943: if ($usage eq "EPART"){
0944: &prnt("<div class=\"SERIF\">");
0945: &prnt("英名の一部を入れてください<br />");
0946: &prnt("例:「red-necked」と入力すると");
0947: &prnt("Red-necked Stint、Red-necked Grebe、…などが表示されます<br />");
0948: &prnt("</div>");
0949: }
0950: }
0951: &prnt("</td>");
0952: &prnt("</tr>");
0953: &prnt("<tr>");
0954: &prnt("<td class=\"LINEB\" colspan=\"6\">");
0955: &prnt("<form method=\"post\" action=\"".&fnini("URI_JPN2SPCCGI")."\">");
0956: ## &prnt("<form method=\"get\" action=\"".&fnini("URI_JPN2SPCCGI")."\">");
0957: &prnt("<div class=\"SERIF\">");
0958: &prnt("<label>$label");
0959: &prnt("<input name=\"$name\" type=\"text\" accesskey=\"S\" tabindex=\"1\"");
0960: &prnt(" size=\"68\" maxlength=\"$width\" value=\"\" />");
0961: &prnt("</label>");
0962: &prnt("<label>送信");
0963: &prnt("<input type=\"submit\" accesskey=\"S\" tabindex=\"6\" value=\"実行\" />");
0964: &prnt("</label>");
0965: &prnt("<label>クリア");
0966: &prnt("<input type=\"reset\" accesskey=\"R\" tabindex=\"7\" value=\"クリア\" />");
0967: &prnt("</label>");
0968: &prnt("</div>");
0969: &prnt("</form>");
0970: &prnt("</td>");
0971: &prnt("</tr>");
0972: }
0973:
0974: sub prcolg
0975: {
0976: my($os, $ow, $fs, $fw, $gs, $gw)=@_;
0977:
0978: &prnt("<tr>");
0979: &prnt("<td class=\"LINEE\">");
0980: &prnt("<div class=\"JSDETAIL\">");
0981: if ($DBCODE eq "UTF8"){
0982: &Encode::from_to($ow, "utf8", "eucjp");
0983: &Encode::from_to($fw, "utf8", "eucjp");
0984: &Encode::from_to($gw, "utf8", "eucjp");
0985: }
0986: &prnt($os." ".$ow);
0987: &prnt("</div>");
0988: &prnt("</td>");
0989: &prnt("<td class=\"LINEE\">");
0990: &prnt("<div class=\"JSDETAIL\">");
0991: &prnt($fs." ".$fw);
0992: &prnt("</div>");
0993: &prnt("</td>");
0994: &prnt("<td class=\"LINEE\">");
0995: &prnt("<div class=\"JSDETAIL\">");
0996: ## &prnt($gs." ".$gw);
0997: &prnt($gw);
0998: &prnt("</div>");
0999: &prnt("</td>");
1000: }
1001:
1002: sub prcols
1003: {
1004: my($s, $w, $e)=@_;
1005: if ($DBCODE eq "UTF8"){
1006: &Encode::from_to($w, "utf8", "eucjp");
1007: }
1008: &prnt("<td class=\"LINEE\">");
1009: &prnt("<div class=\"JSDETAIL\">");
1010: &prnt($s);
1011: &prnt("</div>");
1012: &prnt("</td>");
1013: &prnt("<td class=\"LINEE\">");
1014: &prnt("<div class=\"JSDETAIL\">");
1015: &prnt($w);
1016: &prnt("</div>");
1017: &prnt("</td>");
1018: &prnt("<td class=\"LINEE\">");
1019: &prnt("<div class=\"JSDETAIL\">");
1020: &prnt($e);
1021: &prnt("</div>");
1022: &prnt("</td>");
1023: &prnt("</tr>");
1024: }
1025:
1026: sub printcolhead
1027: {
1028: my(@ttl)=("目","科","属和訳","学名","和名","英名");
1029: my($i);
1030:
1031: &prnt("<tr>");
1032: for $i (@ttl){
1033: &prnt("<td class=\"LINEA\">");
1034: &prnt("<div class=\"JSDETAILHEAD\">");
1035: &prnt($i);
1036: &prnt("</div>");
1037: &prnt("</td>");
1038: }
1039: &prnt("</tr>");
1040: }
1041:
1042: ## ---------------------------------------------------------------- ##
1043: ## subroutine
1044: ## マッチ結果の表示
1045: ##
1046: sub printsum
1047: {
1048: my($s, $c, $t1)=@_;
1049: my($t2)=&Time::HiRes::time();
1050: $s=~s/\'\'/\'/g;
1051: &prnt("<tr>");
1052: &prnt("<td class=\"LINEB\" colspan=\"6\">");
1053: &prnt("<div class=\"SERIF\">");
1054: if ($c){
1055: &prnt("$s に $c 件マッチしました");
1056: }else{
1057: &prnt("$s にマッチするものはありません");
1058: }
1059: &prnt(sprintf(" (所要時間 %3.3f秒)",$t2-$t1));
1060: &prnt("</div>");
1061: &prnt("</td>");
1062: &prnt("</tr>");
1063: }
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 )