add Perl

+# XML::Simple を使って XML を読む

+[[_TOC_]]

+

+## 概要

+- Amazon Web Services の BrowseNodeSearch の結果をXML::Simpleを使って解析し、子ノードを探索する。

+- 親ノード/子ノードの表示だけ行いファイル保存はしないようにした。(2009/12/05)

+- AssociateTagを指定するようにした。(2011/10/27)

+- [Web版](http://www.takeash.net/cgi-bin/Amazon/BrowseNodes.cgi)

+

+## BrowseNodeSearch

+- 下記URLにリクエストすることで、あるBrowseNodeの子ノード一覧を取得できる。

+ - XXXXは調べたいBrowseNode。

+```

+http://webservices.amazon.co.jp/onca/xml

+ ?Service=AWSECommerceService

+ &Operation=BrowseNodeLookup

+ &ResponseGroup=BrowseNodeInfo

+ &AssociateTag=xxxx-22

+ &BrowseNodeId=XXXX

+```

+

+## スクリプト

+- [BrowseNodes2.zip](BrowseNodes2.zip)

+```perl

+#!/usr/local/bin/perl

+#

+# BrowseNodes2.pl

+# Amazon Web Services BrowseNodes 探索スクリプト

+# by TakeAsh

+#

+# http://docs.amazonwebservices.com/AWSECommerceService/latest/DG/BrowseNodeIDs.html

+#

+# 2009.12.05 v2.00 親ノード/子ノードの表示だけ行いファイル保存はしないようにした。

+# 2011.10.27 v2.01 AssociateTagを指定するようにした。

+

+use strict;

+use warnings;

+use utf8;

+use Encode;

+use URI::Amazon::APA;

+use LWP::UserAgent;

+use XML::Simple;

+use YAML::Syck;

+

+$YAML::Syck::ImplicitUnicode = 1;

+

+my $charsetConsole = 'CP932';

+#my $charsetInFile = 'UTF-8';

+#my $charsetOutFile = 'UTF-8';

+

+binmode( STDIN, ":encoding($charsetConsole)" );

+binmode( STDOUT, ":encoding($charsetConsole)" );

+binmode( STDERR, ":encoding($charsetConsole)" );

+

+my $confyaml = './ID.yaml';

+my $conf = YAML::Syck::LoadFile( $confyaml )

+ or die( "$confyaml: $!\n" );

+

+my $nodelistbaseyaml = './BrowseNodeIDs-JP.yaml';

+my $nodelistbase = YAML::Syck::LoadFile( $nodelistbaseyaml )

+ or die( "$nodelistbaseyaml: $!\n" );

+

+unless ( @ARGV ){

+ print "BrowseNodeId\tCategory\n";

+ foreach my $nodeid ( sort by_number ( keys( %{$nodelistbase} ) ) ){

+ print "$nodeid\t$nodelistbase->{$nodeid}\n";

+ }

+ die( "usage: $0 <browse_node_id> [ <browse_node_id> ...]\n" );

+}

+my $browsenodeid = join( ",", @ARGV ) || '465610';

+

+my $u = URI::Amazon::APA->new( 'http://ecs.amazonaws.jp/onca/xml' );

+$u->query_form(

+ Service => 'AWSECommerceService',

+ Operation => 'BrowseNodeLookup',

+ ResponseGroup => 'BrowseNodeInfo',

+ AssociateTag => $conf->{'ASSOCIATE_TAG'},

+ BrowseNodeId => $browsenodeid,

+);

+$u->sign(

+ key => $conf->{'AWS_ACCESS_KEY_ID'},

+ secret => $conf->{'SECRET_ACCESS_KEY'},

+);

+

+my $ua = LWP::UserAgent->new;

+my $r = $ua->get($u);

+if ( $r->is_success ){

+ my $content = XMLin(

+ $r->content,

+ ForceArray => [ 'BrowseNode', 'Error' ],

+ KeyAttr => { 'BrowseNode' => '+BrowseNodeId' }

+ );

+# die( YAML::Syck::Dump( $content ) );

+ if ( my $errors = $content->{'BrowseNodes'}->{'Request'}->{'Errors'} ){

+ die( YAML::Syck::Dump( $errors ) );

+ }

+ my $nodelist = $content->{'BrowseNodes'}->{'BrowseNode'};

+# die( YAML::Syck::Dump( $nodelist ) );

+ foreach my $nodeid ( sort by_number ( keys( %{$nodelist} ) ) ){

+ my $node = $nodelist->{$nodeid};

+ print "Node\t\t$node->{'BrowseNodeId'}\t$node->{'Name'}\n";

+ printAncestors( $node );

+ my $children = $node->{'Children'}->{'BrowseNode'};

+ foreach my $childid ( sort by_number ( keys( %{$children} ) ) ){

+ my $child = $children->{$childid};

+ print "Child\t\t$child->{'BrowseNodeId'}\t$child->{'Name'}\n";

+ }

+ }

+} else {

+ die( $r->status_line, "\n" );

+}

+

+exit;

+

+sub by_number

+{

+ $a <=> $b;

+}

+

+sub printAncestors

+{

+ my( $browsenode ) = @_;

+ if ( my $ancestors = $browsenode->{'Ancestors'}->{'BrowseNode'} ){

+ foreach my $nodeid ( keys( %{$ancestors} ) ){

+ my $node = $ancestors->{$nodeid};

+ print "Ancestor\t$node->{'BrowseNodeId'}\t$node->{'Name'}\n";

+ printAncestors( $node );

+ }

+ }

+}

+

+# EOF

+```

+

+## エラーメッセージ対応

+- XML::Simple で下記エラーメッセージが表示される。

+```

+could not find ParserDetails.ini in D:/Perl64/site/lib/XML/SAX

+```

+- 次の行を追加する。

+```

+$XML::Simple::PREFERRED_PARSER = 'XML::Parser';

+```

+

+- [xml - Could not find ParserDetails.ini - Stack Overflow](https://stackoverflow.com/questions/%32%32%30%32%33%38%39%34)

+

+## リンク

+- [[Perl/XML-XPath]]

+

+- [CPAN:XML-Simple](http://search.cpan.org/dist/XML-Simple)

+- [CPAN:URI-Amazon-APA](http://search.cpan.org/dist/URI-Amazon-APA)

+

+- [Perl 開発者のための XML: 第 1 回 XML と Perl -- 魔法の組み合わせ](http://www.ibm.com/developerworks/jp/xml/library/x-xmlperl1.html)

+- [作って学ぶ、今どきのWebサービス： 第3回　XML::SimpleであらゆるXML文書を料理する](http://www.itmedia.co.jp/enterprise/articles/0702/26/news011.html)

+- [XML::Simple は遅い説における意外な落とし穴](http://iandeth.dyndns.org/mt/ian/archives/000589.html)

+

+- [PerlでAmazon Product Advertising APIのBrowseNodeLookupを行なう](http://tech.lampetty.net/tech/index.php/archives/338)

+# Amazon Web Services

+[[_TOC_]]

+~~#ls2~~

+

+## リンク

+- Amazon Web Services [日本語](http://aws.amazon.com/jp/) / [英語](http://aws.amazon.com/)

+ - [Product Advertising API](https://affiliate.amazon.co.jp/gp/advertising/api/detail/main.html)

+ - [Release Notes](http://aws.amazon.com/releasenotes/Product-Advertising-API)

+ - [Product Advertising API Developer Guide](http://docs.amazonwebservices.com/AWSECommerceService/latest/DG/)

+ - [Anatomy of a REST Request (Locale Endpoint)](http://docs.amazonwebservices.com/AWSECommerceService/latest/DG/AnatomyOfaRESTRequest.html)

+ - [Browse Node IDs](http://docs.amazonwebservices.com/AWSECommerceService/latest/DG/BrowseNodeIDs.html)

+<!----- [[Amazon E-Commerce Service API (2005-10-05):http://docs.amazonwebservices.com/AWSEcommerceService/2005-10-05/]]-->

+<!------ [[Browse Nodes for JP:http://docs.amazonwebservices.com/AWSEcommerceService/2005-10-05/ApiReference/JPBrowseNodesArticle.html]]-->

+ - [ファイル名について](http://www.amazon.co.jp/gp/help/customer/display.html?ie=UTF8&nodeId=200129350)

+ - [Amazon Web Services ブログ](http://aws.typepad.com/aws_japan/)

+ - [Amazon アソシエイト (アフィリエイト)](https://affiliate.amazon.co.jp/)

+- [perl - URI::Amazon::APA released!](http://blog.livedoor.jp/dankogai/archives/51211577.html)

+ - [CPAN:URI-Amazon-APA](http://search.cpan.org/dist/URI-Amazon-APA)

+- [Amazon Web サービス(AWS)の概要](http://www.rfs.jp/sb/perl/10/aws01.html)

+- [Shizラボ](http://shizlabs.amonya.com/) / [技術資料](http://shizlabs.amonya.com/tecnorogy/) / [Amazon商品画像のカスタマイズ(理論編)](http://shizlabs.amonya.com/amazon/image-uri01.html)

+- [PE２プレイ記録ほか](http://parasiteeve2.blog65.fc2.com/) / [Amazonの画像加工について(まとめ)](http://parasiteeve2.blog65.fc2.com/blog-entry-33.html)

+# 大きな画像を表示する

+[[_TOC_]]

+

+## 概要

+- ASINから大きな画像のURIを求めて存在するかどうか確認する。

+- 「content-type」が「image/jpeg」なら存在する、「image/gif」なら存在しない。

+

+## 動作サンプル

+- [CGI Top](http://www.takeash.net/cgi-bin/Amazon/getImages.cgi)

+ - &amazon(B001EQ6A80);<br />

+[画像一覧](http://www.takeash.net/cgi-bin/Amazon/getImages.cgi?ASIN=B001EQ6A80)

+ - &amazon(B002MZZ33K);<br />

+[画像一覧](http://www.takeash.net/cgi-bin/Amazon/getImages.cgi?ASIN=B002MZZ33K)

+ - &amazon(B0026RIRRS);<br />

+[画像一覧](http://www.takeash.net/cgi-bin/Amazon/getImages.cgi?ASIN=B0026RIRRS)

+ - &amazon(B002H9WBNQ);<br />

+[画像一覧](http://www.takeash.net/cgi-bin/Amazon/getImages.cgi?ASIN=B002H9WBNQ)

+ - &amazon(B002L16FZU);<br />

+[画像一覧](http://www.takeash.net/cgi-bin/Amazon/getImages.cgi?ASIN=B002L16FZU)

+ - &amazon(B0019JNTQS);<br />

+[画像一覧](http://www.takeash.net/cgi-bin/Amazon/getImages.cgi?ASIN=B0019JNTQS)

+ - &amazon(B002SW3N16);<br />

+[画像一覧](http://www.takeash.net/cgi-bin/Amazon/getImages.cgi?ASIN=B002SW3N16)

+ - &amazon(4775307614);<br />

+[画像一覧](http://www.takeash.net/cgi-bin/Amazon/getImages.cgi?ASIN=4775307614&SHOT=IN)

+

+## Bookmarklet

+```

+javascript:location='http://www.takeash.net/cgi-bin/Amazon/getImages.cgi?ASIN='+(location.href.match(/\/(dp|ASIN|product)\/([\w]+)/))[2];

+```

+

+## スクリプト

+- [getImages.zip](getImages.zip)

+```perl

+#!/usr/bin/perl

+

+use strict;

+use warnings;

+use utf8;

+use Encode;

+use LWP::UserAgent;

+use URI::Amazon::APA;

+use XML::Simple;

+use YAML::Syck;

+use CGI::Pretty qw( -no_xhtml *table *ol ); # //HTML 4.01 Transitional//EN

+use URI::Escape;

+

+$YAML::Syck::ImplicitUnicode = 1;

+$CGI::POST_MAX = 1024;

+

+binmode( STDIN, ":utf8" );

+binmode( STDOUT, ":utf8" );

+binmode( STDERR, ":utf8" );

+

+# 自動フラッシュ有効化 (バッファリングを無効化)

+$| = 1;

+

+my $confyaml = './ID.yaml';

+my $conf = YAML::Syck::LoadFile( $confyaml ) or die( "$confyaml: $!\n" );

+

+my $cginame = 'Amazon getImages-JP';

+my $ImageUriBase =

+ 'http://images-jp.amazon.com/images/P/%ASIN%.09.%SHOT%._SC%SIZE%ZZZZZZ_.jpg';

+my $NoImageUri = 'http://images-jp.amazon.com/images/G/09/nav2/dp/no-image-no-ciu.gif';

+my $DetailUri = 'http://www.amazon.co.jp/dp/%ASIN%/';

+my $CustomerImageUri = 'http://www.amazon.co.jp/gp/customer-media/product-gallery/%ASIN%';

+

+my @ShotsFixList = (

+ { 'name' => 'Main', 'key' => 'MAIN', },

+ { 'name' => 'Top', 'key' => 'TOPP', },

+ { 'name' => 'Bottom', 'key' => 'BOTT', },

+ { 'name' => 'Left', 'key' => 'LEFT', },

+ { 'name' => 'Right', 'key' => 'RGHT', },

+ { 'name' => 'Front', 'key' => 'FRNT', },

+ { 'name' => 'Back', 'key' => 'BACK', },

+);

+

+my @ShotsVarList = qw( PT IN );

+my %ShotsTypeList = (

+ 0 => 'PIECE SHOTS / 書籍以外のその他の画像',

+ 1 => 'INTERIOR SHOTS / 書籍のその他の画像',

+);

+

+my @SizeList = (

+ { 'name' => 'Large', 'key' => 'RM' },

+ { 'name' => 'Medium', 'key' => 'L' },

+# { 'name' => 'Small', 'key' => 'M' },

+);

+

+my $Step = 20;

+my %PageLabels = ();

+for( my $i=0; $i * $Step < 99; ++$i){

+ $PageLabels{ $i } = 'PT' . substr( '0' . ( $i * $Step + 1 ), -2 )

+ . '-PT'. substr( '0' . ( ( $i + 1 ) * $Step ), -2 )

+}

+$PageLabels{ 0 } = 'Main, ' . $PageLabels{ 0 };

+my $PageMax = @{ [ sort { $b <=> $a } ( keys( %PageLabels ) ) ] }[ 0 ];

+$PageLabels{ $PageMax } =~ s/\d+$/99/;

+

+my $q = new CGI;

+$q->charset('utf-8');

+my $cgipath = $q->url( -absolute => 1 );

+

+my $URI = $q->param( 'URI' ) || '';

+my $ASIN = '';

+unless ( $ASIN = $q->param( 'ASIN' ) ){

+ # Perl 5.10

+ $URI =~ /\/(dp|ASIN|product)\/(?'asin'[\w]+)/;

+ $ASIN = $+{asin};

+ # Perl 5.8

+ #$URI =~ /\/(dp|ASIN|product)\/([\w]+)/;

+ #$ASIN = $2;

+}

+if ( $ASIN ){

+ $URI = $DetailUri;

+ $URI =~ s/%ASIN%/$ASIN/;

+}

+my $SHOT = ( $q->param( 'SHOT' ) ) ? 1 : 0;

+my $shottype = $ShotsVarList[ $SHOT ];

+

+my $PAGE = $q->param( 'PAGE' ) || 0;

+if ( $PAGE < 0 || $PageMax < $PAGE ){

+ $PAGE = 0;

+}

+

+my $MOD = $q->param( 'MOD' ) || 0;

+

+my $ua = LWP::UserAgent->new( keep_alive => ( 7 + $Step ) * 3 );

+

+my @Anchors = ();

+

+printHeader();

+

+if ( !$ASIN || $MOD ){

+ print $q->start_form( -action => $q->url ),

+ $q->table( { -summary => 'enter ASIN and so on.', -border => 1 },

+ $q->Tr(

+ $q->th( 'ASIN' ),

+ $q->td( $q->textfield( -name => 'ASIN', -value => $ASIN ) )

+ ),

+ $q->Tr(

+ $q->th( 'URI' ),

+ $q->td( $q->textfield( -name => 'URI', -value => $URI, -size => 80 ) )

+ ),

+ $q->Tr( $q->th( 'SHOT' ), $q->td( $q->popup_menu(

+ -name => 'SHOT',

+ -values => [sort {$a<=>$b} keys(%ShotsTypeList)],

+ -default => $SHOT,

+ -labels => \%ShotsTypeList,

+ ) ) ),

+ $q->Tr( $q->th( 'PAGE' ), $q->td( $q->popup_menu(

+ -name => 'PAGE',

+ -values => [sort {$a<=>$b} keys(%PageLabels)],

+ -default => $PAGE,

+ -labels => \%PageLabels,

+ ) ) ),

+ $q->Tr( $q->td(

+ { -colspan => 2, -align => 'center' },

+ $q->submit, " ", $q->reset

+ ) ),

+ ),

+ $q->end_form;

+} else {

+ my $u = URI::Amazon::APA->new( 'http://ecs.amazonaws.jp/onca/xml' );

+ $u->query_form(

+ Service => 'AWSECommerceService',

+ Operation => 'ItemLookup',

+ ResponseGroup => 'ItemAttributes,Images',

+ AssociateTag => $conf->{'ASSOCIATE_TAG'},

+ ItemId => $ASIN,

+ );

+ $u->sign(

+ key => $conf->{'AWS_ACCESS_KEY_ID'},

+ secret => $conf->{'SECRET_ACCESS_KEY'},

+ );

+

+ my $r = $ua->get($u);

+ if ( $r->is_success ){

+ print $q->h2( 'Bibliography' );

+ my $content = XMLin(

+ $r->content,

+ ForceArray => [

+ 'Item', 'Error', 'DetailPageURL', 'SalesRank', 'ProductGroup', 'Title',

+ ],

+ KeyAttr => { 'Item' => '+ASIN', },

+ );

+ my( $title, $detailpageurl, $customerimage );

+ if ( my $errors = $content->{'Items'}->{'Request'}->{'Errors'}->{'Error'} ){

+ printErrors( $errors );

+ } else {

+ my $items = $content->{'Items'}->{'Item'};

+ my $item = $items->{$ASIN};

+ $title = $item->{'ItemAttributes'}->{'Title'};

+ $detailpageurl = $item->{'DetailPageURL'}[0];

+ $detailpageurl = decode( 'utf8', uri_unescape( $detailpageurl ) );

+ # $detailpageurl =~ s#/[^/]+/(?=dp/)#/#;

+ # $detailpageurl = uri_unescape( $detailpageurl );

+ $customerimage = $CustomerImageUri;

+ $customerimage =~ s/%ASIN%/$ASIN/;

+ }

+

+ my $pagelabel = $PageLabels{ $PAGE };

+ $pagelabel =~ s/PT/$ShotsVarList[ $SHOT ]/g;

+ print $q->table( { -summary => 'Bibliography', -border => 1 },

+ ( $title ) ? $q->Tr(

+ $q->th( 'TITLE' ) ,

+ $q->td(

+ $q->a(

+ { -href => $detailpageurl || $URI . $conf->{'ASSOCIATE_TAG'} },

+ $title

+ ), $q->br(),

+ $q->a( { -href => $customerimage }, 'Customer Image' )

+ )

+ ) : '',

+ $q->Tr( $q->th( 'ASIN' ), $q->td( $ASIN ) ),

+ $q->Tr( $q->th( 'SHOT' ), $q->td( $ShotsTypeList{ $SHOT } ) ),

+ $q->Tr( $q->th( 'PAGE' ), $q->td( $pagelabel ) ),

+ );

+

+ print $q->h2( 'Search Results' );

+ $ImageUriBase =~ s/%ASIN%/$ASIN/;

+ print $q->p( { -id => 'status' }, 'Now searching...' );

+ if ( $PAGE == 0 ){

+ foreach my $shot ( @ShotsFixList ){

+ my $ImageUri = $ImageUriBase;

+ my $shotkey = $shot->{'key'};

+ $ImageUri =~ s/%SHOT%/$shotkey/;

+ searchSize( $ImageUri, $shot->{'name'} );

+ }

+ }

+ for( my $i=$PAGE*$Step; $i<($PAGE+1)*$Step && $i<99; ++$i ){

+ my $ImageUri = $ImageUriBase;

+ my $shotkey = $shottype . substr( '0' . ( $i + 1 ), -2 );

+ $ImageUri =~ s/%SHOT%/$shotkey/;

+ searchSize( $ImageUri, $shotkey );

+ }

+ if ( @Anchors ){

+ print $q->h2( $q->a( { -name => 'INDEX', -id => 'INDEX' }, 'Index' ) ),

+ $q->start_ol(),

+ $q->li( [ map { $q->a( { -href => '#' . $_ }, $_ ) } @Anchors ] ),

+ $q->end_ol();

+ } else {

+ print $q->p( $q->img(

+ { -src => $NoImageUri, -title => 'No Image', -alt => 'No Image' }

+ ) );

+ }

+ print $q->p( $q->a( { -href => '#top', -name => 'bottom' }, 'Page Top' ) );

+ } else {

+ print $q->p( $r->status_line );

+ }

+}

+

+printFooter();

+

+exit;

+

+sub printHeader

+{

+ my $jscript = qq{

+ function changeStatus(){

+ document.getElementById('status').innerHTML = 'Finished.'

+ + ( ( document.getElementById( 'INDEX' ) )

+ ? '<br><a href=\"#INDEX\">Index<'+'/a>'

+ : '' );

+ }

+ };

+ print $q->header(),

+ $q->start_html(

+ -title => $cginame,

+ -lang => 'ja-JP',

+ -head => [

+ $q->meta( { -http_equiv=>'Content-style-type', -content=>"text/css" } ),

+ $q->meta( { -http_equiv=>'Content-script-type', -content=>"text/javascript" } ),

+ ],

+ -style => { 'src'=>'/take.css' },

+ -script => $jscript,

+ -onLoad => 'changeStatus()',

+ ),

+ $q->h1( $q->a( { -name => 'top' }, $cginame ) ),

+ $q->ul(

+ $q->li( $q->a( { -href => $cgipath }, 'CGI Top' ) ),

+ ( $ASIN && !$MOD )

+ ? $q->li( [ $q->a( {

+ -href => "$cgipath?ASIN=$ASIN&SHOT=$SHOT&PAGE=$PAGE&MOD=1&URI="

+ . uri_escape_utf8( $URI )

+ }, 'Modify' ), ] )

+ : '',

+ );

+}

+

+sub printFooter

+{

+ print $q->end_html . "\n";

+}

+

+sub printErrors

+{

+ my( $errors ) = @_;

+# print $q->h2( 'Error' );

+ print $q->start_table( { -summary => 'Error Message', -border => 1 } );

+ foreach my $error ( @{$errors} ){

+ print $q->Tr( $q->th( $error->{'Code'} ), $q->td( $error->{'Message'} ) );

+ }

+ print $q->end_table();

+}

+

+sub searchSize

+{

+ my( $ImageUriBase, $Shot ) = @_;

+ foreach my $size ( @SizeList ){

+ my $ImageUri = $ImageUriBase;

+ my $sizekey = $size->{'key'};

+ $ImageUri =~ s/%SIZE%/$sizekey/;

+ my $title = $Shot . '_' . $size->{'name'};

+ #print $title . ': ';

+ my $r = $ua->request( HTTP::Request->new( HEAD => $ImageUri ) );

+ if ( $r->header( 'content-type' ) eq 'image/jpeg' ){

+ #print 'Exist.' . $q->br();

+ print $q->p(

+ $title, $q->a( { -name => $title, -href => '#INDEX' }, '*' ), $q->br(),

+ $q->img( { -src => $ImageUri, -title => $title, -alt => $title, } )

+ );

+ push( @Anchors, $title );

+ last;

+ } else {

+ #print 'Not exist.' . $q->br();

+ }

+ }

+}

+

+# EOF

+```

+

+## リンク

+- [Shizラボ](http://shizlabs.amonya.com/) / [技術資料](http://shizlabs.amonya.com/tecnorogy/) / [Amazon商品画像のカスタマイズ(理論編)](http://shizlabs.amonya.com/amazon/image-uri01.html)

+

+- [PE２プレイ記録ほか](http://parasiteeve2.blog65.fc2.com/)

+ - [Amazonの画像加工について(まとめ)](http://parasiteeve2.blog65.fc2.com/blog-entry-33.html)

+ - [Amazonの画像加工（ツール編5）ASINから利用可能な全画像を求める・５](http://parasiteeve2.blog65.fc2.com/blog-entry-372.html)

+ - [Amazonの画像加工（ツール編7）ASINから利用可能な全画像を求める・６](http://parasiteeve2.blog65.fc2.com/blog-entry-425.html)

+

+- [rubyu備忘録](http://d.hatena.ne.jp/ruby-U/) / [perlとpython用encodeURIComponent()](http://d.hatena.ne.jp/ruby-U/20081110/1226313786)

+

+- [CPAN:URI-Amazon-APA](http://search.cpan.org/dist/URI-Amazon-APA)

+- [CPAN:CGI](http://search.cpan.org/dist/CGI)

+- [CPAN:URI](http://search.cpan.org/dist/URI) / [CPAN:URI/URI/Escape.pm](http://search.cpan.org/dist/URI/URI/Escape.pm)

+[[_TOC_]]

+----

+# 概要

+- Apache の error_log を HTML テーブルとして整形する。

+- mod_security 対応。

+

+# 動作サンプル

+- http://www.takeash.net/AELF/

+

+# ソース

+- [AELF.zip](AELF.zip)

+

+## index.cgi

+```perl

+#!/usr/bin/perl

+# Apache のエラーログを整形

+

+use strict;

+use warnings;

+use utf8;

+use Encode;

+use CGI::Pretty qw( -no_xhtml *table *ol );

+use Net::DNS::Resolver;

+

+$CGI::POST_MAX = 80 * 1024;

+

+my $charsetConsole = 'UTF-8';

+#my $charsetConsole = 'CP932';

+my $charsetFile = 'UTF-8';

+

+binmode( STDIN, ":encoding($charsetConsole)" );

+binmode( STDOUT, ":encoding($charsetConsole)" );

+binmode( STDERR, ":encoding($charsetConsole)" );

+

+my $cgiName = 'Apache Error Log Formatter';

+

+my @pair_type = (

+ { # mod_security

+ header => qr/(ModSecurity:.*\.)\s(\[.*)\s*/,

+ to_pair => qr/\[\S+\s[^\]]+\]\s*/,

+ to_keyval => qr/\[(\S+)\s"([^\]]+)"\]\s*/,

+ },

+ { # default, detail部無し

+ header => qr/(.*)\s*/,

+ },

+);

+

+my $q = new CGI;

+$q->charset( $charsetFile );

+my $br = $q->br();

+

+my %processer = (

+ Client => \&toHostName,

+ data => sub{

+ my $word = shift;

+ $word =~ s/(\s(ARGS|ARGS_NAMES):)/$1$br/;

+ return $word;

+ },

+);

+

+my $log = $q->param('LOG') || '';

+if ( ( ! $ENV{'SERVER_ADDR'} ) && ( ! $log ) && ( my $file = $q->param('FILE') ) ){

+ open( my $IN, "<:encoding($charsetFile)", $file ) or die( "$file: $!\n" );

+ my @body = <$IN>;

+ close( $IN );

+ $log = join( "", @body );

+}

+

+print $q->header(

+ -type => 'text/html',

+ -charset => $charsetConsole,

+);

+print $q->start_html(

+ -title => $cgiName,

+ -head => [

+ $q->meta( { -http_equiv=>'Content-Type', -content=>"text/html; charset=" . $charsetConsole } ),

+ $q->meta( { -http_equiv=>'Content-style-type', -content=>"text/css" } ),

+ ],

+ -style => [ { 'src'=>'/take.css' }, ],

+);

+print $q->h1( $cgiName );

+

+if ( $log ){

+ print_result( $log );

+} else {

+ print_form();

+}

+

+print $q->end_html . "\n";

+

+exit;

+

+sub print_result

+{

+ my( $log ) = @_;

+ $log =~ s/\r\n|\n\r/\n/gmx;

+ $log =~ s/\r/\n/gmx;

+ $log =~ s/"([^\"]*)"/'"'.encodeURIComponent($1).'"'/gmxe;

+

+ print $q->p( $q->a( { -href => $q->url( -absolute => 1 ) }, 'form' ) );

+

+ my $index = 0;

+ foreach my $line ( split( "\n", $log ) ){

+ if ( $line =~ /^\x{feff}?\s*$/ ){

+ next;

+ }

+# print $q->h2( ++$index );

+ print $q->start_table( { -border => 1 } );

+# print $q->Tr( $q->th( 'Line' ), $q->td( $line ) );

+ my( $datetime, $level, $client, $line2 ) =

+ ( $line =~ /\[([^\]]+)\]\s\[([^\]]+)\](?:\s\[client\s([^\]]+)\])?\s*(.*)\s*$/ );

+ print $q->Tr( $q->th( 'Date Time' ), $q->td( $datetime ) );

+ print $q->Tr( $q->th( 'Level' ), $q->td( $level ) );

+ if ( $client ){

+ print $q->Tr( $q->th( 'Client' ), $q->td( toHostName( $client ) ) );

+ }

+# print $q->Tr( $q->th( 'Line2' ), $q->td( $line2 ) );

+ foreach my $type ( @pair_type ){

+ if ( $line2 =~ /^$type->{'header'}/ ){

+ my( $summary, $detail ) = ( $1, $2 );

+ $summary =~ s/([\.\,])\s/$1$br/;

+ print $q->Tr( $q->th( 'Summary' ), $q->td( decodeURIComponent( $summary ) ) );

+ if ( $detail ){

+ foreach my $pair ( getPair( $type->{'to_pair'}, $type->{'to_keyval'}, $detail ) ){

+ my( $key, $val ) = ( $pair->[0], $pair->[1] );

+ if ( my $proc = $processer{$key} ){

+ $val = $proc->( $val );

+ }

+ print $q->Tr( $q->th( $key ), $q->td( $val ) );

+ }

+ }

+ last;

+ }

+ }

+ print $q->end_table(), $q->br();

+ }

+

+ print $q->p( $q->a( { -href => $q->url( -absolute => 1 ) }, 'form' ) );

+}

+

+sub getPair

+{

+ my( $to_pair, $to_keyval, $line ) = @_;

+ my @ret = ();

+# print "'$to_pair'\n'$line'\n";

+ foreach my $pair ( $line =~ /$to_pair/g ){

+# print "'$pair'\n";

+ my( $key, $val ) = ( $pair =~ /^$to_keyval$/ );

+ $val = decodeURIComponent( $val );

+ push( @ret, [ $key, $val ] );

+ }

+ return @ret;

+}

+

+sub print_form

+{

+ print

+ $q->start_form( -action => $q->url, -enctype => 'multipart/form-data' ),

+ $q->submit, " ", $q->reset, $q->br(),

+ $q->textarea( -name=>'LOG', -rows=>20, -columns=>80 ),

+ $q->end_form;

+}

+

+sub encodeURIComponent

+{

+ my $str = encode( 'utf-8', shift );

+ $str =~ s/([^0-9A-Za-z!\x27()*\-._~])/sprintf("%%%02X", ord($1))/eg; # \x27 = '

+ return $str;

+}

+

+sub decodeURIComponent

+{

+ my $str = shift;

+ $str =~ s/%([0-9A-F][0-9A-F])/pack( "H*", $1 )/egi;

+ return decode( 'utf-8', $str );

+}

+

+sub toHostName

+{

+ my $ip_address = shift || '';

+ my $ret = '';

+

+ my $resolver = Net::DNS::Resolver->new;

+ if ( my $ans = $resolver->query( $ip_address ) ){

+ for my $rr ( $ans->answer ){

+ #print $rr->string, "\n";

+ if ( $rr->type eq 'PTR' ){

+ $ret = $rr->ptrdname;

+ last;

+ }

+ }

+ }

+

+ return $ip_address . '; ' . $ret;

+}

+

+# EOF

+```

+

+# リンク

+- [[Perl/MatchList]]

+- [[Linux/Apache]]

+# AutoHashedFuncs

+[[_TOC_]]

+

+## 概要

+- 関数名を指定しなくても関数定義するだけで自動的にハッシュに登録されるサンプル。

+- 型グロブを使って定義されている関数をスキャンする。

+

+## ソース

+- [AutoHashedFuncs.zip](AutoHashedFuncs.zip)

+```Perl

+# 関数名を指定しなくても関数定義するだけで自動的にハッシュに登録される。

+

+use strict;

+use warnings;

+use utf8;

+use Encode;

+use YAML::Syck;

+

+{

+ package MyDecoder;

+

+ # 関数へのリファレンスが格納されるハッシュ

+ our %Decoders = ();

+

+ foreach my $key ( sort( keys( %MyDecoder:: ) ) ){

+ no strict "refs";

+ if ( $key =~ /decode(.*)/ && *{"MyDecoder::$key"}{CODE} ){

+ $Decoders{$1} = *{"MyDecoder::$key"}{CODE};

+ }

+ }

+

+ # 型グロブからアクセスできるけど CODE ではないので登録されない

+ my $decode1 = "aaa";

+ my @decode2 = qw( bbb ccc ddd );

+ our $decode3 = "eee";

+ our @decode4 = qw( fff ggg hhh );

+

+ # 登録される

+ sub decodeAdd {

+ my( $a, $b ) = @_;

+ return $a + $b;

+ }

+

+ # 登録される

+ sub decodeMul {

+ my( $a, $b ) = @_;

+ return $a * $b;

+ }

+

+ # 関数名がルールから外れているので登録されない

+ sub helper1 {

+ my( $a, $b ) = @_;

+ return $a - $b;

+ }

+}

+

+# $main::refDecoders にリファレンスをコピーして使い易くする

+my $refDecoders = \%MyDecoder::Decoders;

+

+print Dump( $refDecoders ) . "\n";

+

+for my $key ( qw( decode1 decode2 decode3 decode4 decodeAdd Add decodeMul Mul helper1 ) ){

+ if ( my $dc = $refDecoders->{$key} ){

+ print "$key:\t" . &{$dc}( 2, 4 ) . "\n";

+ } else {

+ print "$key:\t-\n";

+ }

+}

+

+# EOF

+```

+

+## リンク

+- [perldoc.jp](http://perldoc.jp/) / [Perlのリファレンスとネストしたデータ構造](http://perldoc.jp/pod/perlref)

+

+- [サンプルコードによるPerl入門](http://d.hatena.ne.jp/perlcodesample/) / [型グロブとシンボルテーブル](http://d.hatena.ne.jp/perlcodesample/20080614/1213428778)

+[[_TOC_]]

+

+# 概要

+- CGI.pm のテストサンプル

+- [動作サンプル](http://www.takeash.net/cgi-bin/etc/testCGI.cgi)

+- フォームタグが閉じていなかったのを修正。(2012/10/02)

+

+# 注意点

+

+## textfield や hidden などの値を加工してセットしても前の値が表示される

+```perl

+my $param1 = $q->param('param1');

+++$param1;

+print $param1;

+print $q->textfield( -name => 'param1', -default => $param1 ); # 前の値のまま

+```

+- 対応方法

+ 1. タグを表示する前に param で値をセットする。

+```perl

+$q->param( 'param1', $somevalue ); # $q->param( -name => 'param1', -values => [ $somevalue ] );

+```

+ - [つかのぺ](http://tuka.s12.xrea.com/) / [CGI.pm](http://tuka.s12.xrea.com/index.xcg?p=CGI.pm)

+ 1. override を指定すると強制的に上書きできる。

+```perl

+print $q->textfield( -name => 'param1', -default => $somevalue, -override => 1 );

+```

+

+## リストコンテキストでのパラメータ読み出し

+- セキュリティ上の問題のため、リストコンテキストで「$q->param('name')」を使うと警告が表示される。<br />リストコンテキストが必要な場合は代わりに「$q->multi_param('name')」を使う。

+- [Fetching the value or values of a single named parameter](http://search.cpan.org/dist/CGI/lib/CGI.pod#Fetching_the_value_or_values_of_a_single_named_parameter)

+

+# ソース

+- [testCGI.zip](testCGI.zip)

+```perl

+#!/usr/bin/perl

+#

+# CGI.pm のテスト

+

+use strict;

+use warnings;

+use utf8;

+use Encode;

+use YAML::Syck;

+use CGI::Pretty qw( -no_xhtml *table ); # //HTML 4.01 Transitional//EN

+#use CGI::Carp qw/fatalsToBrowser warningsToBrowser/;

+

+$YAML::Syck::ImplicitUnicode = 1;

+

+binmode( STDIN, ":utf8" );

+binmode( STDOUT, ":utf8" );

+binmode( STDERR, ":utf8" );

+

+my $cginame = 'testCGI';

+my $cookiename = 'クッキー';

+my $charset = 'utf-8';

+

+# フォームのエンコーディングタイプ。

+# CGI.pm Version 3.48 の param メソッドに影響する。

+# 1: application/x-www-form-urlencoded, param メソッドでバイナリ文字列が返る。

+# 0: multipart/form-data, param メソッドで utf8 フラグ付き文字列が返る。

+my $enctype = 1;

+

+my $q = new CGI;

+$q->charset( $charset );

+

+my %popupgroup = (

+ 'popup1' => 'ポップアップ1', 'popup2' => 'ポップアップ2',

+ 'popup3' => 'ポップアップ3', 'popup4' => 'ポップアップ4',

+);

+my %scrollgroup = (

+ 'scroll1' => 'スクロール1', 'scroll2' => 'スクロール2',

+ 'scroll3' => 'スクロール3', 'scroll4' => 'スクロール4',

+ 'scroll5' => 'スクロール5',

+);

+my %checkgroup = (

+ 'check1'=>'チェック1', 'check2'=>'チェック2',

+ 'check3'=>'チェック3',

+);

+my %radiogroup = (

+ 'radio1'=>'ラジオ1', 'radio2'=>'ラジオ2',

+ 'radio3'=>'ラジオ3',

+);

+

+my @names;

+if ( $enctype ){

+ # 'application/x-www-form-urlencoded'

+ @names = map{ decode( 'utf8', $_ ) } $q->param();

+} else {

+ # 'multipart/form-data'

+ @names = $q->param();

+}

+

+printHeader();

+

+if ( @names ){

+ print $q->h2('Param');

+ print $q->start_table( { '-summary' => 'Parameters', '-border' => 1 } );

+ foreach my $name ( @names ){

+ if ( $enctype ){

+ # 'application/x-www-form-urlencoded'

+ print $q->Tr(

+ $q->th( $name ),

+ $q->td( join( $q->br(), map{ decode( 'utf8', $_ ) } $q->param( encode( 'utf8', $name ) ) ) )

+ );

+ } else {

+ # 'multipart/form-data'

+ print $q->Tr(

+ $q->th( $name ),

+ $q->td( join( $q->br(), $q->param( $name ) ) )

+ );

+ }

+ }

+ print $q->end_table();

+ print $q->h2('Cookie');

+ print $q->start_table( { '-summary' => 'Cookie', '-border' => 1 } );

+ foreach my $cookiename ( $q->cookie() ){

+ print $q->Tr(

+ $q->th( decode( 'utf8', $cookiename ) ),

+ $q->td( join( $q->br(), map{ decode( 'utf8', $_ ) } $q->cookie( $cookiename ) ) )

+ );

+ }

+ print $q->end_table();

+} else {

+ print $q->start_form(

+ '-action' => $q->url,

+ '-enctype' => (

+ ( $enctype )

+ ? 'application/x-www-form-urlencoded'

+ : 'multipart/form-data'

+ ),

+ );

+ print $q->start_table( { '-summary' => 'Parameters', '-border' => 1 } );

+ print $q->Tr(

+ $q->th( 'テキスト' ),

+ $q->td( $q->textfield(

+ '-name' => 'テキスト',

+ '-value' => 'あいうえお漢字'

+ ) )

+ );

+ print $q->Tr(

+ $q->th( 'テキストエリア' ),

+ $q->td( $q->textarea(

+ '-name' => 'テキストエリア',

+ '-default' => "予定表\n\x{20B9F}",

+ '-rows' => 3,

+ '-columns' => 20

+ ) )

+ );

+ print $q->Tr(

+ $q->th( 'ポップアップ' ),

+ $q->td( $q->popup_menu(

+ '-name' => 'ポップアップ',

+ '-values' => [ sort( keys( %popupgroup ) ) ],

+ '-default' => ( sort( keys( %popupgroup ) ) )[0],

+ '-labels' => \%popupgroup,

+ ) )

+ );

+ print $q->Tr(

+ $q->th( 'スクロール' ),

+ $q->td( $q->scrolling_list(

+ '-name' => 'スクロール',

+ '-values' => [ sort( keys( %scrollgroup ) ) ],

+ '-default' => ( sort( keys( %scrollgroup ) ) )[0],

+ '-size' => 3,

+ '-multiple' => 'true',

+ '-labels' => \%scrollgroup,

+ ) )

+ );

+ print $q->Tr(

+ $q->th( 'チェックボックス' ),

+ $q->td( $q->checkbox_group(

+ '-name' => 'チェックボックス',

+ '-values' => [ sort( keys( %checkgroup ) ) ],

+ '-default' => ( sort( keys( %checkgroup ) ) )[0],

+ '-linebreak' => 'true',

+ '-labels' => \%checkgroup,

+ ) )

+ );

+ print $q->Tr(

+ $q->th( 'ラジオボタン' ),

+ $q->td( $q->radio_group(

+ '-name' => 'ラジオボタン',

+ '-values' => [ sort( keys( %radiogroup ) ) ],

+ '-default' => ( sort( keys( %radiogroup ) ) )[0],

+ '-linebreak' => 'true',

+ '-labels' => \%radiogroup,

+ ) )

+ );

+ print $q->Tr( $q->td(

+ { '-colspan' => 2, '-align' => 'center' },

+ $q->submit . ' ' . $q->reset

+ ) );

+ print $q->end_table();

+ print $q->end_form;

+}

+

+printFooter();

+

+exit;

+

+sub printHeader

+{

+ my $cookieval = decode( 'utf8',

+ $q->cookie( encode( 'utf8', $cookiename ) ) || ''

+ );

+ $cookieval .= 'あ';

+ my $cookie = $q->cookie(

+ '-name' => encode( 'utf8', $cookiename ),

+ '-value' => encode( 'utf8', $cookieval ),

+ );

+ print $q->header( '-cookie' => [ $cookie ] );

+ print $q->start_html(

+ '-title' => $cginame,

+ '-lang' => 'ja-JP',

+ '-head' => [

+ $q->meta( { '-http_equiv' => 'Content-style-type', '-content' => 'text/css' } ),

+ $q->meta( { '-http_equiv' => 'Content-script-type', '-content' => 'text/javascript' } ),

+ ],

+ '-style' => [ { 'src' => '/take.css' }, ],

+ );

+ print $q->h1( $cginame );

+}

+

+sub printFooter

+{

+ print $q->end_html . "\n";

+}

+

+# EOF

+```

+

+# システム設定

+

+## Windows Server 2012(IIS8)

+- IIS インストール時に、「CGI」「ISAPI 拡張」「要求フィルター」を有効にする。

+ - IPアドレスによるアクセス制限を行う場合は「IPおよびドメインの制限」も有効にする。

+- IIS マネージャ

+ - 「アプリケーションプール - DefaultAppPool - 詳細設定 - 32ビットアプリケーションの有効化」を「True」に設定する。

+ - 「Default Web Site」または該当フォルダ

+ - 「ハンドラーマッピング」を開き、「スクリプトマップ」を追加する。

+| 要求パス | *.cgi |

+| --- | --- |

+| 実行可能ファイル | C:\Perl\bin\perlis.dll |

+| 名前 | Perl CGI |

+ - 「既定のドキュメント」を開き、「index.cgi」を追加する。

+ - 「要求フィルター」のアップロード許可最大サイズの既定値は30MB弱。

+ - 最大値を変更する場合は、「要求フィルター」から、「機能設定の編集」を開き、「許可されたコンテンツ最大長」を変更する。

+ - [IIS で要求フィルタリングを構成する](http://technet.microsoft.com/ja-jp/library/hh831621.aspx)

+ - [要求フィルターの使用方法](http://technet.microsoft.com/ja-jp/library/dd939071.aspx)

+ - [要求制限 <requestLimits>](http://technet.microsoft.com/ja-jp/library/ee431638.aspx)

+

+- Active Perl は 32bit 版をインストールする。

+ - 64bit 版は、「perlis.dll」が含まれていない。

+ - CGI.pm でのアップロードサイズ制限設定は $CGI::POST_MAX で行う。

+

+# リンク

+- [[Perl/環境変数]]

+

+- [CPAN:CGI-Alternatives](http://search.cpan.org/dist/CGI-Alternatives)

+- [CPAN:Mojolicious](http://search.cpan.org/dist/Mojolicious)

+ - [CPAN:Mojolicious/lib/Mojolicious/Lite.pm](http://search.cpan.org/dist/Mojolicious/lib/Mojolicious/Lite.pm)

+

+- [CPAN:CGI](http://search.cpan.org/dist/CGI)

+- [CPAN:Encode](http://search.cpan.org/dist/Encode)

+

+- [perl - use CGI; use Encode; # 非英語Webプログラミング3原則](http://blog.livedoor.jp/dankogai/archives/51227060.html)

+[[_TOC_]]

+

+# CPAN

+## シェルを起動して対話的にインストール

+```

+# perl -MCPAN -e shell

+```

+

+## bash 等からインストール

+```

+# perl -MCPAN -e "CPAN::Shell->install('Bundle::CPAN')"

+```

+

+## 更新可能なパッケージ一覧の表示

+```

+# perl -MCPAN -e "CPAN::Shell->r"

+```

+

+## 一括更新

+```

+# perl -MCPAN -e "CPAN::Shell->install(CPAN::Shell->r)"

+```

+- 途中で Yes/No の確認を求められる。

+

+## バージョンを指定してインストール

+```

+# perl -MCPAN -e "CPAN::Shell->install('LEMBARK/FindBin-libs-1.55.tar.gz')"

+```

+- [CPAN:FindBin-libs](http://search.cpan.org/dist/FindBin-libs) は Perl v5.10.0 以上が必要で v5.8.8 にはインストールできない。

+

+## シェルでヒストリが効かない (Bundle::CPANをインストール)

+```

+> install Bundle::CPAN

+```

+

+## 強制的に再インストール

+- インストール済みであっても強制に再インストールするには「force」を付ける。

+```

+> force install Scalar::Util

+```

+- 「IO::Socket::SSL」が下記エラーにてインストールできなかったら、依存する「Scalar::Util」を強制再インストールする。

+```

+Net::SSL from Crypt-SSLeay can't verify hostnames; either install IO::Socket::SSL or turn off verification by setting the PERL_LWP_SSL_VERIFY_HOSTNAME environment variable to 0 at /usr/lib/perl5/site_perl/5.8.8/LWP/Protocol/http.pm line 51.

+```

+&#x20;

+```

+You need the XS Version of Scalar::Util for dualvar() support at Makefile.PL line 56.

+```

+

+## 複数のパッケージをまとめてインストール

+- インストールしたいパッケージ名を書いた適当な *.pm ファイルを作成し、それをインストールする。

+```

+# cd ~

+# perl -MCPAN -e "CPAN::Shell->install('Bundle::MyPackages')"

+```

+- /root/Bundle/MyPackages.pm

+```perl

+package Bundle::MyPackages;

+

+use strict;

+use utf8;

+use vars qw( $VERSION );

+$VERSION = "0.01";

+1;

+

+=head1 CONTENTS

+

+Env

+Fatal

+Test::Warnings

+Test::Output

+Test::Deep

+Time::Piece

+CGI

+URI::Escape::XS

+File::Basename

+FindBin::libs

+Getopt::Long

+HTTP::Date

+JSON::XS

+Lingua::JA::Numbers

+Lingua::JA::Regular::Unicode

+Log::Dispatch

+MIME::Base64

+Socket

+Net::IP

+Net::Wake

+Crypt::SSLeay

+Perl::Tidy

+String::Util

+Text::CSV_XS

+Text::xSV::Slurp

+XML::Simple

+XML::XPath

+enum::hash

+Attribute::Constant

+Number::Format

+PadWalker

+Term::Encoding

+

+=cut

+```

+- [複数のCPANモジュールを一括インストール - Kawa.net 旧ゆうすけブログ (Yahoo!版)](http://blogs.yahoo.co.jp/kawa_kawa_kawa_kawa/650645.html)

+

+## インストール済みのモジュールのバージョン確認

+- Linux

+```

+# perl -M(モジュール名) -e 'print "$(モジュール名)::VERSION\n";'

+# perl -MJSON::Syck -e 'print "$JSON::Syck::VERSION\n";'

+```

+- Win

+```

+> perl -M(モジュール名) -e "print $(モジュール名)::VERSION;"

+> perl -MJSON::Syck -e "print $JSON::Syck::VERSION;"

+```

+

+# cpanminus

+## インストール

+- yum

+```

+# yum install perl-App-cpanminus

+```

+- CPAN

+```

+# perl -MCPAN -e "CPAN::Shell->install('App::cpanminus')"

+# cpanm App::cpanoutdated

+```

+

+## cpanm 自身のアップグレード

+```

+# cpanm --self-upgrade

+```

+

+## 一括更新

+```

+# cpan-outdated | cpanm

+```

+

+# ppm

+## 一括更新

+```

+> ppm upgrade --install

+```

+

+## 複数のパッケージをまとめてインストール

+- パッケージを複数指定する。

+```

+> ppm install Env Fatal Test::Warnings Test::Output Test::Deep Time::Piece

+> ppm install CGI URI::Escape::XS File::Basename FindBin::libs Getopt::Long

+> ppm install HTTP::Date JSON::XS Lingua::JA::Numbers Lingua::JA::Regular::Unicode

+> ppm install Log::Dispatch MIME::Base64 Socket Net::IP Net::Wake Crypt::SSLeay Perl::Tidy

+> ppm install String::Util Text::CSV_XS Text::xSV::Slurp XML::Simple XML::XPath

+> ppm install enum::hash Attribute::Constant Number::Format PadWalker Term::Encoding

+```

+

+# リンク

+- [CPAN:CPAN/lib/CPAN.pm](http://search.cpan.org/dist/CPAN/lib/CPAN.pm)

+

+- [CPAN:App-cpanminus](http://search.cpan.org/dist/App-cpanminus)

+- https://github.com/miyagawa/cpanminus

+- [perl-App-cpanminus](http://rpm.pbone.net/index.php3?stat=3&search=perl-App-cpanminus&srodzaj=3)

+

+- [CPAN:Module-CoreList/lib/Module/CoreList.pod](http://search.cpan.org/dist/Module-CoreList/lib/Module/CoreList.pod)

+- [$shibayu36->blog;](http://shibayu36.hatenablog.com/)

+ - [perlであるモジュールがコアモジュールかどうか調べる;](http://shibayu36.hatenablog.com/entry/2014/03/08/115105)

+

+- [CPAN:ExtUtils-Install/lib/ExtUtils/Installed.pm](http://search.cpan.org/dist/ExtUtils-Install/lib/ExtUtils/Installed.pm)

+- [Using Perl](http://nozawashinichi.sakura.ne.jp/usingmt/)

+ - [Perl インストールされているモジュールを出力するコマンド](http://nozawashinichi.sakura.ne.jp/usingmt/2014/03/perl-8.html)

+# DBIx::Custom

+[[_TOC_]]

+

+## 概要

+- [CPAN:DBIx-Custom](http://search.cpan.org/dist/DBIx-Custom) を使用して MS SQL Server に対してクエリを実行するサンプル。

+- Where 句に「:UserID{=}」とか付け加えたいとこだけど、「$dbi->not_exists」がうまく働いてなくて値無しだとハングアップするみたいだ。

+- というか MS SQL Server の ODBC はハングアップし過ぎ。ちゃんとエラー出して止まってくれ。

+

+## ソース

+- [DBIx-Custom.zip](DBIx-Custom.zip)

+

+### summarize.pl

+```perl

+#!/usr/bin/perl

+# DBIx::Custom サンプル

+# 注文履歴集計 MS SQL Server 用

+

+use strict;

+use warnings;

+use utf8;

+use Encode;

+use YAML::Syck;

+use DBIx::Custom;

+use DateTime;

+use Text::xSV::Slurp qw( xsv_slurp );

+

+$YAML::Syck::ImplicitUnicode = 1;

+

+my $charsetConsole = 'CP932';

+#my $charsetFile = 'UTF-8';

+my $charsetFile = 'CP932';

+

+binmode( STDIN, ":encoding($charsetConsole)" );

+binmode( STDOUT, ":encoding($charsetConsole)" );

+binmode( STDERR, ":encoding($charsetConsole)" );

+

+my $DB_Connect_yaml = './DB_Connect.yaml';

+my $fnOders = './DB/Orders.txt';

+

+my $start_date = '2012-08-20';

+my $end_date = '2012-09-01';

+

+my $DB_Connect = YAML::Syck::LoadFile( $DB_Connect_yaml )

+ or die( "$DB_Connect_yaml: $!\n" );

+foreach( %{$DB_Connect} ){

+ $DB_Connect->{'DSN'} =~ s/_${_}_/$DB_Connect->{$_}/;

+}

+

+my $dbi = DBIx::Custom->connect(

+ dsn => 'DBI:' . $DB_Connect->{'DSN'},

+ user => $DB_Connect->{'User'},

+ password => $DB_Connect->{'Password'},

+ option => $DB_Connect->{'Options'}

+);

+

+#insertOrderRandom();

+#insertOrderFromFile();

+

+my $Orders = getOrders( $start_date, $end_date );

+print Dump( $Orders );

+exit;

+

+sub getOrders

+{

+ my( $start_date, $end_date ) = @_;

+

+ my $where = $dbi->where;

+ $where->clause( [ 'and', ':OrderDateTime{>=}', ':OrderDateTime{<}' ] );

+ $where->param({

+ OrderDateTime => [

+ $start_date ? $start_date : '1900-01-01', # $dbi->not_exists だとハングアップする？

+ $end_date ? $end_date : '9999-12-31', # $dbi->not_exists だとハングアップする？

+ ],

+ });

+

+ my $sortOrder = $dbi->order;

+ $sortOrder->prepend( 'UserID', 'OrderDateTime' );

+

+ my $Orders = $dbi->select(

+ table => 'Orders',

+ column => [

+ '[Orders].[OrderDateTime]', '[Orders].[OrderQuantity]', # Orders

+ '[Users].[UserID]', '[Users].[UserName]', # Users

+ '[Items].[ItemName]', '[Items].[ItemUnitPrice]', # Items

+ '[Items].[ItemUnitPrice] * [Orders].[OrderQuantity] as [SubTotalPrice]', # 追加計算

+ ],

+ join => [

+ 'JOIN [Users] ON [Orders].[OrderUser] = [Users].[UserID]',

+ 'JOIN [Items] ON [Orders].[OrderItem] = [Items].[ItemID]',

+ ],

+ where => $where,

+ append => $sortOrder->to_string,

+ )->all;

+

+ return $Orders;

+}

+

+sub insertOrderRandom

+{

+ my $userMax = 5;

+ my $itemMax = 7;

+ my $quantityMax = 30;

+ for( my $orderNum = 20; $orderNum > 0; --$orderNum ){

+ my $datetime = DateTime->new(

+ time_zone => 'local',

+ year => 2012,

+ month => int( rand( 4 ) + 7 ),

+ day => int( rand( 31 ) + 1 ),

+ hour => int( rand( 10 ) + 9 ),

+ minute => int( rand( 60 ) ),

+ );

+ $dbi->insert(

+ {

+ OrderDateTime => $datetime->ymd('-') . ' ' . $datetime->hms(':'),

+ OrderUser => int( rand( $userMax ) + 1 ),

+ OrderItem => int( rand( $itemMax ) + 1 ),

+ OrderQuantity => int( rand( $quantityMax ) + 1 ),

+ },

+ table => 'Orders',

+ );

+ }

+}

+

+sub insertOrderFromFile

+{

+ my @orders = readXSV( $fnOders, { sep_char => "\t" } );

+ foreach my $order ( @orders ){

+ delete $order->{'OrderID'}; # IDENTITY 列を追加しようとするとハングアップする。

+ $dbi->insert(

+ $order,

+ table => 'Orders',

+ );

+ }

+}

+

+sub readXSV

+{

+ my( $fname, $opt ) = @_;

+ $opt = { binary => 1, %{$opt} };

+ open( my $fhin, "<:encoding($charsetFile)", encode( $charsetConsole, $fname ) )

+ or die( "$fname: $!" );

+ my @body = <$fhin>;

+ close( $fhin );

+ my $ret = xsv_slurp(

+ string => join( "", @body ),

+ text_csv => $opt,

+ );

+ return ( ref( $ret ) eq 'ARRAY' )

+ ? @{ $ret }

+ : $ret ;

+}

+

+# EOF

+```

+

+### DB_Connect.yaml

+```

+# DB接続情報

+Driver: ODBC

+Server: localhost\SQLExpress,1433 # <サーバ名>\<インスタンス名>[,<ポート番号>]

+User: TestUser

+Password: "TestPass" # 記号を含む場合は""で括る。

+DB: TestShop1

+Trusted_Connection: No

+AutoTranslate: No

+Options:

+ LongTruncOk: 1

+ LongReadLen: 8192

+DSN: _Driver_:Driver={SQL Server}; Server={_Server_}; Database=_DB_; Trusted_Connection=_Trusted_Connection_; AutoTranslate=_AutoTranslate_;

+```

+

+## リンク

+- [[DBIx::NamedParams|Perl/DBIx-NamedParams]]

+

+- [CPAN:DBIx-Custom](http://search.cpan.org/dist/DBIx-Custom)

+ - [CPAN:DBIx-Custom/lib/DBIx/Custom/Where.pm](http://search.cpan.org/dist/DBIx-Custom/lib/DBIx/Custom/Where.pm)

+ - [CPAN:DBIx-Custom/lib/DBIx/Custom/Order.pm](http://search.cpan.org/dist/DBIx-Custom/lib/DBIx/Custom/Order.pm)

+# DBIx::NamedParams

+[[_TOC_]]

+

+## 概要

+- mysql でも prepare でプレースホルダとして ? じゃなく名前で指定できるようにする。

+- 同じ名前を繰り返し使ってもエラーにならない。

+- こっちより [CPAN:DBIx-Custom](http://search.cpan.org/dist/DBIx-Custom) の方が柔軟で高機能だなー。どうしたもんか。

+- [CPAN:DBIx-NamedBinding](http://search.cpan.org/dist/DBIx-NamedBinding) に比べると、bind_param_ex の１回でバインドできるのと型指定できる点が勝ってるかな。

+

+## 使用法

+### スカラーのバインド

+- 「:名前-型」でスカラー値を bind する。

+```perl

+my $sql_insert = qq{

+ INSERT INTO `Users` ( `ID`, `Name`, `Status`, `RegDate` )

+ VALUES ( NULL, :Name-VARCHAR, :State-INTEGER, :RegDate-DATETIME );

+};

+$sth_insert = $dbh->prepare_ex( $sql_insert ) or die( "$DBI::errstr\n" );

+$sth_insert->bind_param_ex( { 'Name' => 'リオ', 'State' => 1, 'RegDate' => '2011-02-21 10:00' } );

+$sth_insert->execute() or die( "$DBI::errstr\n" );

+```

+

+### 配列(個数指定あり)のバインド

+- 「:名前{個数}-型」で配列値を個数個分 bind する。

+```perl

+my $sql_select = qq{

+ SELECT `ID`, `Name`, `Status`, `RegDate`

+ FROM `Users`

+ WHERE `Status` in ( :State{4}-INTEGER );

+};

+$sth_select = $dbh->prepare_ex( $sql_select ) or die( "$DBI::errstr\n" );

+$sth_select->bind_param_ex( { 'State' => [ 1,2,4,8 ] } );

+$sth_select->execute() or die( "$DBI::errstr\n" );

+```

+

+### 配列(個数指定なし)のバインド

+- 「:名前+-型」で配列値を配列要素個分 bind する。<br />

+prepare_exの引数としてSQL文と共に割り当てるハッシュを指定する必要がある。

+```perl

+my $sql_select = qq{

+ SELECT `ID`, `Name`, `Status`, `RegDate`

+ FROM `Users`

+ WHERE `Status` in ( :State+-INTEGER );

+};

+$sth_select = $dbh->prepare_ex( $sql_select, { 'State' => [ 1,2,4,8 ] } )

+ or die( "$DBI::errstr\n" );

+$sth_select->execute() or die( "$DBI::errstr\n" );

+```

+

+### デバッグログの採取

+- プレースホルダの解析結果、解析後の SQL 文、バインドされる値をログファイルに書き出します。

+- ファイル名を省略すると、ホームディレクトリ(Linux: 環境変数 HOME, Windows: 環境変数 USERPROFILE)にログファイル(DBIx-NamedParams.log)が作られます。

+```

+DBIx::NamedParams::debug_log( 'testNamedParams.log' );

+```

+

+### DBD のデータタイプに対応する SQL タイプのハッシュ

+```

+my %DrvTypeToSQLType = $dbh->driver_typename_map();

+```

+- [[MySQL の例|#MySQL_DataType_Map]]

+- [[MS SQL Server の例|#MSSQL_DataType_Map]]

+

+## 変更履歴

+### 0.0.5 / 2011/09/28

+- driver_typename_map メソッドが返すハッシュを調整。DB が MS SQL Server の場合、datetime および smalldatetime に対して DATE ではなく WVARCHAR を割り当てるようにした。

+

+### 0.0.4 / 2011/09/17

+- driver_typename_map メソッド追加。その DBD で使用できるデータタイプに対応する SQL タイプ名のハッシュを返す。

+- デバッグログのファイル名を指定できるようにした。ログの体裁の調整。

+- MS SQL Server 版のサンプルを作成。datetime 型にバインドするのに DATETIME じゃなくて WVARCHAR(VARCHAR) 使わなくちゃいけないなんて、そんなん考慮しとらんよ…。

+

+### 0.0.3 / 2011/04/17

+- 機能面での追加・変更はなし。

+- 「use base;」を「use parent;」に変更。

+- import にて、継承元である DBI の import を呼び出すようにしたけど、不要かも？

+- ソース内の関数の順序を呼び出し元と呼び出し先が近くになるように変更。

+- _parse_ex にて、$repeat の既定値を '' から 0 に変更。

+- bind_param_ex にて、「no warnings;」を「no warnings 'uninitialized';」に変更。

+- bind_param_ex にて、$ref_hash が HASH であることを確認するようにした。

+

+### 0.0.2 / 2011/03/07

+- prepare_ex のときに @_NamedParams をクリアするようにした。

+

+## ソース

+- [NamedParams.zip](NamedParams.zip)

+

+### NamedParams.pm

+```perl

+# DBI::db::prepare, DBI::st::bind_param を拡張する。

+# http://www.TakeAsh.net/wiki/?Perl/DBIx-NamedParams

+#

+# prepare_ex では「:名前-型」形式のようにプレースホルダを書く。

+# bind_param_ex では名前と値の対応を示すハッシュを渡す。

+

+package DBIx::NamedParams;

+

+use strict;

+use warnings;

+use utf8;

+use Encode;

+use Carp qw( croak );

+use parent qw( DBI );

+use DBI::Const::GetInfoType;

+use Log::Dispatch;

+use POSIX qw( strftime );

+

+use version; our $VERSION = qv( '0.0.5' );

+

+( $ENV{'LANG'} || '' ) =~ /\.(.*)$/; # ja_JP.UTF-8

+my $charsetConsole = $1 || 'CP932';

+my $charsetFile = 'UTF-8';

+

+my $_default_log_filename = ( $ENV{'HOME'} || $ENV{'USERPROFILE'} );

+$_default_log_filename =~ s#\\#/#g;

+$_default_log_filename .= '/DBIx-NamedParams.log';

+

+my %_SQL_TypeRefs = ();

+my %_SQL_TypeInvs = ();

+my $_SQL_Types = "";

+my @_NamedParams = ();

+my $_index;

+my $_log = undef;

+

+sub import {

+ DBI->import(); # 不要か？

+ _init();

+ *{DBI::db::driver_typename_map} = \&driver_typename_map;

+ *{DBI::db::prepare_ex} = \&prepare_ex;

+ *{DBI::st::bind_param_ex} = \&bind_param_ex;

+}

+

+sub _init

+{

+ foreach( @{ $DBI::EXPORT_TAGS{sql_types} } ){

+ my $refFunc = \&{"DBI::$_"};

+ if ( /^SQL_(.*)$/i ){

+ $_SQL_TypeRefs{ $1 } = &{ $refFunc };

+ $_SQL_TypeInvs{ &{ $refFunc } } = $1;

+ }

+ }

+ $_SQL_Types = all_sql_types();

+}

+

+sub debug_log

+{

+ my( $filename ) = @_;

+ $filename = encode( $charsetConsole, ( $filename || $_default_log_filename ) );

+ $_log = Log::Dispatch->new(

+ outputs => [ [

+ 'File',

+ min_level => 'debug',

+ filename => $filename,

+ binmode => ":encoding($charsetFile)",

+ permissions => 0666,

+ newline => 1,

+ ], ],

+ );