戻る

プログラム本体

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&nbsp;alpina」と入力すると");
0883:             &prnt("和名ハマシギ 英名 Dunlin が表示されます<br />");
0884:             &prnt("例:「cettia&nbsp;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&nbsp;Gull」と入力すると");
0892:             &prnt("和名カモメ 学名 Larus canus が表示されます<br />");
0893:             &prnt("例:「asian&nbsp;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_TEXTDIR"));
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 )