Perl/Amazon/BrowseNodeSearch.md
... ...
@@ -0,0 +1,157 @@
1
+# XML::Simple を使って XML を読む
2
+[[_TOC_]]
3
+
4
+## 概要
5
+- Amazon Web Services の BrowseNodeSearch の結果をXML::Simpleを使って解析し、子ノードを探索する。
6
+- 親ノード/子ノードの表示だけ行いファイル保存はしないようにした。(2009/12/05)
7
+- AssociateTagを指定するようにした。(2011/10/27)
8
+- [Web版](http://www.takeash.net/cgi-bin/Amazon/BrowseNodes.cgi)
9
+
10
+## BrowseNodeSearch
11
+- 下記URLにリクエストすることで、あるBrowseNodeの子ノード一覧を取得できる。
12
+ - XXXXは調べたいBrowseNode。
13
+```
14
+http://webservices.amazon.co.jp/onca/xml
15
+ ?Service=AWSECommerceService
16
+ &Operation=BrowseNodeLookup
17
+ &ResponseGroup=BrowseNodeInfo
18
+ &AssociateTag=xxxx-22
19
+ &BrowseNodeId=XXXX
20
+```
21
+
22
+## スクリプト
23
+- [BrowseNodes2.zip](BrowseNodes2.zip)
24
+```perl
25
+#!/usr/local/bin/perl
26
+#
27
+# BrowseNodes2.pl
28
+# Amazon Web Services BrowseNodes 探索スクリプト
29
+# by TakeAsh
30
+#
31
+# http://docs.amazonwebservices.com/AWSECommerceService/latest/DG/BrowseNodeIDs.html
32
+#
33
+# 2009.12.05 v2.00 親ノード/子ノードの表示だけ行いファイル保存はしないようにした。
34
+# 2011.10.27 v2.01 AssociateTagを指定するようにした。
35
+
36
+use strict;
37
+use warnings;
38
+use utf8;
39
+use Encode;
40
+use URI::Amazon::APA;
41
+use LWP::UserAgent;
42
+use XML::Simple;
43
+use YAML::Syck;
44
+
45
+$YAML::Syck::ImplicitUnicode = 1;
46
+
47
+my $charsetConsole = 'CP932';
48
+#my $charsetInFile = 'UTF-8';
49
+#my $charsetOutFile = 'UTF-8';
50
+
51
+binmode( STDIN, ":encoding($charsetConsole)" );
52
+binmode( STDOUT, ":encoding($charsetConsole)" );
53
+binmode( STDERR, ":encoding($charsetConsole)" );
54
+
55
+my $confyaml = './ID.yaml';
56
+my $conf = YAML::Syck::LoadFile( $confyaml )
57
+ or die( "$confyaml: $!\n" );
58
+
59
+my $nodelistbaseyaml = './BrowseNodeIDs-JP.yaml';
60
+my $nodelistbase = YAML::Syck::LoadFile( $nodelistbaseyaml )
61
+ or die( "$nodelistbaseyaml: $!\n" );
62
+
63
+unless ( @ARGV ){
64
+ print "BrowseNodeId\tCategory\n";
65
+ foreach my $nodeid ( sort by_number ( keys( %{$nodelistbase} ) ) ){
66
+ print "$nodeid\t$nodelistbase->{$nodeid}\n";
67
+ }
68
+ die( "usage: $0 <browse_node_id> [ <browse_node_id> ...]\n" );
69
+}
70
+my $browsenodeid = join( ",", @ARGV ) || '465610';
71
+
72
+my $u = URI::Amazon::APA->new( 'http://ecs.amazonaws.jp/onca/xml' );
73
+$u->query_form(
74
+ Service => 'AWSECommerceService',
75
+ Operation => 'BrowseNodeLookup',
76
+ ResponseGroup => 'BrowseNodeInfo',
77
+ AssociateTag => $conf->{'ASSOCIATE_TAG'},
78
+ BrowseNodeId => $browsenodeid,
79
+);
80
+$u->sign(
81
+ key => $conf->{'AWS_ACCESS_KEY_ID'},
82
+ secret => $conf->{'SECRET_ACCESS_KEY'},
83
+);
84
+
85
+my $ua = LWP::UserAgent->new;
86
+my $r = $ua->get($u);
87
+if ( $r->is_success ){
88
+ my $content = XMLin(
89
+ $r->content,
90
+ ForceArray => [ 'BrowseNode', 'Error' ],
91
+ KeyAttr => { 'BrowseNode' => '+BrowseNodeId' }
92
+ );
93
+# die( YAML::Syck::Dump( $content ) );
94
+ if ( my $errors = $content->{'BrowseNodes'}->{'Request'}->{'Errors'} ){
95
+ die( YAML::Syck::Dump( $errors ) );
96
+ }
97
+ my $nodelist = $content->{'BrowseNodes'}->{'BrowseNode'};
98
+# die( YAML::Syck::Dump( $nodelist ) );
99
+ foreach my $nodeid ( sort by_number ( keys( %{$nodelist} ) ) ){
100
+ my $node = $nodelist->{$nodeid};
101
+ print "Node\t\t$node->{'BrowseNodeId'}\t$node->{'Name'}\n";
102
+ printAncestors( $node );
103
+ my $children = $node->{'Children'}->{'BrowseNode'};
104
+ foreach my $childid ( sort by_number ( keys( %{$children} ) ) ){
105
+ my $child = $children->{$childid};
106
+ print "Child\t\t$child->{'BrowseNodeId'}\t$child->{'Name'}\n";
107
+ }
108
+ }
109
+} else {
110
+ die( $r->status_line, "\n" );
111
+}
112
+
113
+exit;
114
+
115
+sub by_number
116
+{
117
+ $a <=> $b;
118
+}
119
+
120
+sub printAncestors
121
+{
122
+ my( $browsenode ) = @_;
123
+ if ( my $ancestors = $browsenode->{'Ancestors'}->{'BrowseNode'} ){
124
+ foreach my $nodeid ( keys( %{$ancestors} ) ){
125
+ my $node = $ancestors->{$nodeid};
126
+ print "Ancestor\t$node->{'BrowseNodeId'}\t$node->{'Name'}\n";
127
+ printAncestors( $node );
128
+ }
129
+ }
130
+}
131
+
132
+# EOF
133
+```
134
+
135
+## エラーメッセージ対応
136
+- XML::Simple で下記エラーメッセージが表示される。
137
+```
138
+could not find ParserDetails.ini in D:/Perl64/site/lib/XML/SAX
139
+```
140
+- 次の行を追加する。
141
+```
142
+$XML::Simple::PREFERRED_PARSER = 'XML::Parser';
143
+```
144
+
145
+- [xml - Could not find ParserDetails.ini - Stack Overflow](https://stackoverflow.com/questions/%32%32%30%32%33%38%39%34)
146
+
147
+## リンク
148
+- [[Perl/XML-XPath]]
149
+
150
+- [CPAN:XML-Simple](http://search.cpan.org/dist/XML-Simple)
151
+- [CPAN:URI-Amazon-APA](http://search.cpan.org/dist/URI-Amazon-APA)
152
+
153
+- [Perl 開発者のための XML: 第 1 回 XML と Perl -- 魔法の組み合わせ](http://www.ibm.com/developerworks/jp/xml/library/x-xmlperl1.html)
154
+- [作って学ぶ、今どきのWebサービス: 第3回 XML::SimpleであらゆるXML文書を料理する](http://www.itmedia.co.jp/enterprise/articles/0702/26/news011.html)
155
+- [XML::Simple は遅い説における意外な落とし穴](http://iandeth.dyndns.org/mt/ian/archives/000589.html)
156
+
157
+- [PerlでAmazon Product Advertising APIのBrowseNodeLookupを行なう](http://tech.lampetty.net/tech/index.php/archives/338)
0 158
\ No newline at end of file
Perl/Amazon/Home.md
... ...
@@ -0,0 +1,21 @@
1
+# Amazon Web Services
2
+[[_TOC_]]
3
+~~#ls2~~
4
+
5
+## リンク
6
+- Amazon Web Services [日本語](http://aws.amazon.com/jp/) / [英語](http://aws.amazon.com/)
7
+ - [Product Advertising API](https://affiliate.amazon.co.jp/gp/advertising/api/detail/main.html)
8
+ - [Release Notes](http://aws.amazon.com/releasenotes/Product-Advertising-API)
9
+ - [Product Advertising API Developer Guide](http://docs.amazonwebservices.com/AWSECommerceService/latest/DG/)
10
+ - [Anatomy of a REST Request (Locale Endpoint)](http://docs.amazonwebservices.com/AWSECommerceService/latest/DG/AnatomyOfaRESTRequest.html)
11
+ - [Browse Node IDs](http://docs.amazonwebservices.com/AWSECommerceService/latest/DG/BrowseNodeIDs.html)
12
+<!----- [[Amazon E-Commerce Service API (2005-10-05):http://docs.amazonwebservices.com/AWSEcommerceService/2005-10-05/]]-->
13
+<!------ [[Browse Nodes for JP:http://docs.amazonwebservices.com/AWSEcommerceService/2005-10-05/ApiReference/JPBrowseNodesArticle.html]]-->
14
+ - [ファイル名について](http://www.amazon.co.jp/gp/help/customer/display.html?ie=UTF8&nodeId=200129350)
15
+ - [Amazon Web Services ブログ](http://aws.typepad.com/aws_japan/)
16
+ - [Amazon アソシエイト (アフィリエイト)](https://affiliate.amazon.co.jp/)
17
+- [perl - URI::Amazon::APA released!](http://blog.livedoor.jp/dankogai/archives/51211577.html)
18
+ - [CPAN:URI-Amazon-APA](http://search.cpan.org/dist/URI-Amazon-APA)
19
+- [Amazon Web サービス(AWS)の概要](http://www.rfs.jp/sb/perl/10/aws01.html)
20
+- [Shizラボ](http://shizlabs.amonya.com/) / [技術資料](http://shizlabs.amonya.com/tecnorogy/) / [Amazon商品画像のカスタマイズ(理論編)](http://shizlabs.amonya.com/amazon/image-uri01.html)
21
+- [PE2プレイ記録ほか](http://parasiteeve2.blog65.fc2.com/) / [Amazonの画像加工について(まとめ)](http://parasiteeve2.blog65.fc2.com/blog-entry-33.html)
0 22
\ No newline at end of file
Perl/Amazon/getImages.md
... ...
@@ -0,0 +1,346 @@
1
+# 大きな画像を表示する
2
+[[_TOC_]]
3
+
4
+## 概要
5
+- ASINから大きな画像のURIを求めて存在するかどうか確認する。
6
+- 「content-type」が「image/jpeg」なら存在する、「image/gif」なら存在しない。
7
+
8
+## 動作サンプル
9
+- [CGI Top](http://www.takeash.net/cgi-bin/Amazon/getImages.cgi)
10
+ - &amazon(B001EQ6A80);<br />
11
+[画像一覧](http://www.takeash.net/cgi-bin/Amazon/getImages.cgi?ASIN=B001EQ6A80)
12
+ - &amazon(B002MZZ33K);<br />
13
+[画像一覧](http://www.takeash.net/cgi-bin/Amazon/getImages.cgi?ASIN=B002MZZ33K)
14
+ - &amazon(B0026RIRRS);<br />
15
+[画像一覧](http://www.takeash.net/cgi-bin/Amazon/getImages.cgi?ASIN=B0026RIRRS)
16
+ - &amazon(B002H9WBNQ);<br />
17
+[画像一覧](http://www.takeash.net/cgi-bin/Amazon/getImages.cgi?ASIN=B002H9WBNQ)
18
+ - &amazon(B002L16FZU);<br />
19
+[画像一覧](http://www.takeash.net/cgi-bin/Amazon/getImages.cgi?ASIN=B002L16FZU)
20
+ - &amazon(B0019JNTQS);<br />
21
+[画像一覧](http://www.takeash.net/cgi-bin/Amazon/getImages.cgi?ASIN=B0019JNTQS)
22
+ - &amazon(B002SW3N16);<br />
23
+[画像一覧](http://www.takeash.net/cgi-bin/Amazon/getImages.cgi?ASIN=B002SW3N16)
24
+ - &amazon(4775307614);<br />
25
+[画像一覧](http://www.takeash.net/cgi-bin/Amazon/getImages.cgi?ASIN=4775307614&SHOT=IN)
26
+
27
+## Bookmarklet
28
+```
29
+javascript:location='http://www.takeash.net/cgi-bin/Amazon/getImages.cgi?ASIN='+(location.href.match(/\/(dp|ASIN|product)\/([\w]+)/))[2];
30
+```
31
+
32
+## スクリプト
33
+- [getImages.zip](getImages.zip)
34
+```perl
35
+#!/usr/bin/perl
36
+
37
+use strict;
38
+use warnings;
39
+use utf8;
40
+use Encode;
41
+use LWP::UserAgent;
42
+use URI::Amazon::APA;
43
+use XML::Simple;
44
+use YAML::Syck;
45
+use CGI::Pretty qw( -no_xhtml *table *ol ); # //HTML 4.01 Transitional//EN
46
+use URI::Escape;
47
+
48
+$YAML::Syck::ImplicitUnicode = 1;
49
+$CGI::POST_MAX = 1024;
50
+
51
+binmode( STDIN, ":utf8" );
52
+binmode( STDOUT, ":utf8" );
53
+binmode( STDERR, ":utf8" );
54
+
55
+# 自動フラッシュ有効化 (バッファリングを無効化)
56
+$| = 1;
57
+
58
+my $confyaml = './ID.yaml';
59
+my $conf = YAML::Syck::LoadFile( $confyaml ) or die( "$confyaml: $!\n" );
60
+
61
+my $cginame = 'Amazon getImages-JP';
62
+my $ImageUriBase =
63
+ 'http://images-jp.amazon.com/images/P/%ASIN%.09.%SHOT%._SC%SIZE%ZZZZZZ_.jpg';
64
+my $NoImageUri = 'http://images-jp.amazon.com/images/G/09/nav2/dp/no-image-no-ciu.gif';
65
+my $DetailUri = 'http://www.amazon.co.jp/dp/%ASIN%/';
66
+my $CustomerImageUri = 'http://www.amazon.co.jp/gp/customer-media/product-gallery/%ASIN%';
67
+
68
+my @ShotsFixList = (
69
+ { 'name' => 'Main', 'key' => 'MAIN', },
70
+ { 'name' => 'Top', 'key' => 'TOPP', },
71
+ { 'name' => 'Bottom', 'key' => 'BOTT', },
72
+ { 'name' => 'Left', 'key' => 'LEFT', },
73
+ { 'name' => 'Right', 'key' => 'RGHT', },
74
+ { 'name' => 'Front', 'key' => 'FRNT', },
75
+ { 'name' => 'Back', 'key' => 'BACK', },
76
+);
77
+
78
+my @ShotsVarList = qw( PT IN );
79
+my %ShotsTypeList = (
80
+ 0 => 'PIECE SHOTS / 書籍以外のその他の画像',
81
+ 1 => 'INTERIOR SHOTS / 書籍のその他の画像',
82
+);
83
+
84
+my @SizeList = (
85
+ { 'name' => 'Large', 'key' => 'RM' },
86
+ { 'name' => 'Medium', 'key' => 'L' },
87
+# { 'name' => 'Small', 'key' => 'M' },
88
+);
89
+
90
+my $Step = 20;
91
+my %PageLabels = ();
92
+for( my $i=0; $i * $Step < 99; ++$i){
93
+ $PageLabels{ $i } = 'PT' . substr( '0' . ( $i * $Step + 1 ), -2 )
94
+ . '-PT'. substr( '0' . ( ( $i + 1 ) * $Step ), -2 )
95
+}
96
+$PageLabels{ 0 } = 'Main, ' . $PageLabels{ 0 };
97
+my $PageMax = @{ [ sort { $b <=> $a } ( keys( %PageLabels ) ) ] }[ 0 ];
98
+$PageLabels{ $PageMax } =~ s/\d+$/99/;
99
+
100
+my $q = new CGI;
101
+$q->charset('utf-8');
102
+my $cgipath = $q->url( -absolute => 1 );
103
+
104
+my $URI = $q->param( 'URI' ) || '';
105
+my $ASIN = '';
106
+unless ( $ASIN = $q->param( 'ASIN' ) ){
107
+ # Perl 5.10
108
+ $URI =~ /\/(dp|ASIN|product)\/(?'asin'[\w]+)/;
109
+ $ASIN = $+{asin};
110
+ # Perl 5.8
111
+ #$URI =~ /\/(dp|ASIN|product)\/([\w]+)/;
112
+ #$ASIN = $2;
113
+}
114
+if ( $ASIN ){
115
+ $URI = $DetailUri;
116
+ $URI =~ s/%ASIN%/$ASIN/;
117
+}
118
+my $SHOT = ( $q->param( 'SHOT' ) ) ? 1 : 0;
119
+my $shottype = $ShotsVarList[ $SHOT ];
120
+
121
+my $PAGE = $q->param( 'PAGE' ) || 0;
122
+if ( $PAGE < 0 || $PageMax < $PAGE ){
123
+ $PAGE = 0;
124
+}
125
+
126
+my $MOD = $q->param( 'MOD' ) || 0;
127
+
128
+my $ua = LWP::UserAgent->new( keep_alive => ( 7 + $Step ) * 3 );
129
+
130
+my @Anchors = ();
131
+
132
+printHeader();
133
+
134
+if ( !$ASIN || $MOD ){
135
+ print $q->start_form( -action => $q->url ),
136
+ $q->table( { -summary => 'enter ASIN and so on.', -border => 1 },
137
+ $q->Tr(
138
+ $q->th( 'ASIN' ),
139
+ $q->td( $q->textfield( -name => 'ASIN', -value => $ASIN ) )
140
+ ),
141
+ $q->Tr(
142
+ $q->th( 'URI' ),
143
+ $q->td( $q->textfield( -name => 'URI', -value => $URI, -size => 80 ) )
144
+ ),
145
+ $q->Tr( $q->th( 'SHOT' ), $q->td( $q->popup_menu(
146
+ -name => 'SHOT',
147
+ -values => [sort {$a<=>$b} keys(%ShotsTypeList)],
148
+ -default => $SHOT,
149
+ -labels => \%ShotsTypeList,
150
+ ) ) ),
151
+ $q->Tr( $q->th( 'PAGE' ), $q->td( $q->popup_menu(
152
+ -name => 'PAGE',
153
+ -values => [sort {$a<=>$b} keys(%PageLabels)],
154
+ -default => $PAGE,
155
+ -labels => \%PageLabels,
156
+ ) ) ),
157
+ $q->Tr( $q->td(
158
+ { -colspan => 2, -align => 'center' },
159
+ $q->submit, " ", $q->reset
160
+ ) ),
161
+ ),
162
+ $q->end_form;
163
+} else {
164
+ my $u = URI::Amazon::APA->new( 'http://ecs.amazonaws.jp/onca/xml' );
165
+ $u->query_form(
166
+ Service => 'AWSECommerceService',
167
+ Operation => 'ItemLookup',
168
+ ResponseGroup => 'ItemAttributes,Images',
169
+ AssociateTag => $conf->{'ASSOCIATE_TAG'},
170
+ ItemId => $ASIN,
171
+ );
172
+ $u->sign(
173
+ key => $conf->{'AWS_ACCESS_KEY_ID'},
174
+ secret => $conf->{'SECRET_ACCESS_KEY'},
175
+ );
176
+
177
+ my $r = $ua->get($u);
178
+ if ( $r->is_success ){
179
+ print $q->h2( 'Bibliography' );
180
+ my $content = XMLin(
181
+ $r->content,
182
+ ForceArray => [
183
+ 'Item', 'Error', 'DetailPageURL', 'SalesRank', 'ProductGroup', 'Title',
184
+ ],
185
+ KeyAttr => { 'Item' => '+ASIN', },
186
+ );
187
+ my( $title, $detailpageurl, $customerimage );
188
+ if ( my $errors = $content->{'Items'}->{'Request'}->{'Errors'}->{'Error'} ){
189
+ printErrors( $errors );
190
+ } else {
191
+ my $items = $content->{'Items'}->{'Item'};
192
+ my $item = $items->{$ASIN};
193
+ $title = $item->{'ItemAttributes'}->{'Title'};
194
+ $detailpageurl = $item->{'DetailPageURL'}[0];
195
+ $detailpageurl = decode( 'utf8', uri_unescape( $detailpageurl ) );
196
+ # $detailpageurl =~ s#/[^/]+/(?=dp/)#/#;
197
+ # $detailpageurl = uri_unescape( $detailpageurl );
198
+ $customerimage = $CustomerImageUri;
199
+ $customerimage =~ s/%ASIN%/$ASIN/;
200
+ }
201
+
202
+ my $pagelabel = $PageLabels{ $PAGE };
203
+ $pagelabel =~ s/PT/$ShotsVarList[ $SHOT ]/g;
204
+ print $q->table( { -summary => 'Bibliography', -border => 1 },
205
+ ( $title ) ? $q->Tr(
206
+ $q->th( 'TITLE' ) ,
207
+ $q->td(
208
+ $q->a(
209
+ { -href => $detailpageurl || $URI . $conf->{'ASSOCIATE_TAG'} },
210
+ $title
211
+ ), $q->br(),
212
+ $q->a( { -href => $customerimage }, 'Customer Image' )
213
+ )
214
+ ) : '',
215
+ $q->Tr( $q->th( 'ASIN' ), $q->td( $ASIN ) ),
216
+ $q->Tr( $q->th( 'SHOT' ), $q->td( $ShotsTypeList{ $SHOT } ) ),
217
+ $q->Tr( $q->th( 'PAGE' ), $q->td( $pagelabel ) ),
218
+ );
219
+
220
+ print $q->h2( 'Search Results' );
221
+ $ImageUriBase =~ s/%ASIN%/$ASIN/;
222
+ print $q->p( { -id => 'status' }, 'Now searching...' );
223
+ if ( $PAGE == 0 ){
224
+ foreach my $shot ( @ShotsFixList ){
225
+ my $ImageUri = $ImageUriBase;
226
+ my $shotkey = $shot->{'key'};
227
+ $ImageUri =~ s/%SHOT%/$shotkey/;
228
+ searchSize( $ImageUri, $shot->{'name'} );
229
+ }
230
+ }
231
+ for( my $i=$PAGE*$Step; $i<($PAGE+1)*$Step && $i<99; ++$i ){
232
+ my $ImageUri = $ImageUriBase;
233
+ my $shotkey = $shottype . substr( '0' . ( $i + 1 ), -2 );
234
+ $ImageUri =~ s/%SHOT%/$shotkey/;
235
+ searchSize( $ImageUri, $shotkey );
236
+ }
237
+ if ( @Anchors ){
238
+ print $q->h2( $q->a( { -name => 'INDEX', -id => 'INDEX' }, 'Index' ) ),
239
+ $q->start_ol(),
240
+ $q->li( [ map { $q->a( { -href => '#' . $_ }, $_ ) } @Anchors ] ),
241
+ $q->end_ol();
242
+ } else {
243
+ print $q->p( $q->img(
244
+ { -src => $NoImageUri, -title => 'No Image', -alt => 'No Image' }
245
+ ) );
246
+ }
247
+ print $q->p( $q->a( { -href => '#top', -name => 'bottom' }, 'Page Top' ) );
248
+ } else {
249
+ print $q->p( $r->status_line );
250
+ }
251
+}
252
+
253
+printFooter();
254
+
255
+exit;
256
+
257
+sub printHeader
258
+{
259
+ my $jscript = qq{
260
+ function changeStatus(){
261
+ document.getElementById('status').innerHTML = 'Finished.'
262
+ + ( ( document.getElementById( 'INDEX' ) )
263
+ ? '<br><a href=\"#INDEX\">Index<'+'/a>'
264
+ : '' );
265
+ }
266
+ };
267
+ print $q->header(),
268
+ $q->start_html(
269
+ -title => $cginame,
270
+ -lang => 'ja-JP',
271
+ -head => [
272
+ $q->meta( { -http_equiv=>'Content-style-type', -content=>"text/css" } ),
273
+ $q->meta( { -http_equiv=>'Content-script-type', -content=>"text/javascript" } ),
274
+ ],
275
+ -style => { 'src'=>'/take.css' },
276
+ -script => $jscript,
277
+ -onLoad => 'changeStatus()',
278
+ ),
279
+ $q->h1( $q->a( { -name => 'top' }, $cginame ) ),
280
+ $q->ul(
281
+ $q->li( $q->a( { -href => $cgipath }, 'CGI Top' ) ),
282
+ ( $ASIN && !$MOD )
283
+ ? $q->li( [ $q->a( {
284
+ -href => "$cgipath?ASIN=$ASIN&SHOT=$SHOT&PAGE=$PAGE&MOD=1&URI="
285
+ . uri_escape_utf8( $URI )
286
+ }, 'Modify' ), ] )
287
+ : '',
288
+ );
289
+}
290
+
291
+sub printFooter
292
+{
293
+ print $q->end_html . "\n";
294
+}
295
+
296
+sub printErrors
297
+{
298
+ my( $errors ) = @_;
299
+# print $q->h2( 'Error' );
300
+ print $q->start_table( { -summary => 'Error Message', -border => 1 } );
301
+ foreach my $error ( @{$errors} ){
302
+ print $q->Tr( $q->th( $error->{'Code'} ), $q->td( $error->{'Message'} ) );
303
+ }
304
+ print $q->end_table();
305
+}
306
+
307
+sub searchSize
308
+{
309
+ my( $ImageUriBase, $Shot ) = @_;
310
+ foreach my $size ( @SizeList ){
311
+ my $ImageUri = $ImageUriBase;
312
+ my $sizekey = $size->{'key'};
313
+ $ImageUri =~ s/%SIZE%/$sizekey/;
314
+ my $title = $Shot . '_' . $size->{'name'};
315
+ #print $title . ': ';
316
+ my $r = $ua->request( HTTP::Request->new( HEAD => $ImageUri ) );
317
+ if ( $r->header( 'content-type' ) eq 'image/jpeg' ){
318
+ #print 'Exist.' . $q->br();
319
+ print $q->p(
320
+ $title, $q->a( { -name => $title, -href => '#INDEX' }, '*' ), $q->br(),
321
+ $q->img( { -src => $ImageUri, -title => $title, -alt => $title, } )
322
+ );
323
+ push( @Anchors, $title );
324
+ last;
325
+ } else {
326
+ #print 'Not exist.' . $q->br();
327
+ }
328
+ }
329
+}
330
+
331
+# EOF
332
+```
333
+
334
+## リンク
335
+- [Shizラボ](http://shizlabs.amonya.com/) / [技術資料](http://shizlabs.amonya.com/tecnorogy/) / [Amazon商品画像のカスタマイズ(理論編)](http://shizlabs.amonya.com/amazon/image-uri01.html)
336
+
337
+- [PE2プレイ記録ほか](http://parasiteeve2.blog65.fc2.com/)
338
+ - [Amazonの画像加工について(まとめ)](http://parasiteeve2.blog65.fc2.com/blog-entry-33.html)
339
+ - [Amazonの画像加工(ツール編5)ASINから利用可能な全画像を求める・5](http://parasiteeve2.blog65.fc2.com/blog-entry-372.html)
340
+ - [Amazonの画像加工(ツール編7)ASINから利用可能な全画像を求める・6](http://parasiteeve2.blog65.fc2.com/blog-entry-425.html)
341
+
342
+- [rubyu備忘録](http://d.hatena.ne.jp/ruby-U/) / [perlとpython用encodeURIComponent()](http://d.hatena.ne.jp/ruby-U/20081110/1226313786)
343
+
344
+- [CPAN:URI-Amazon-APA](http://search.cpan.org/dist/URI-Amazon-APA)
345
+- [CPAN:CGI](http://search.cpan.org/dist/CGI)
346
+- [CPAN:URI](http://search.cpan.org/dist/URI) / [CPAN:URI/URI/Escape.pm](http://search.cpan.org/dist/URI/URI/Escape.pm)
0 347
\ No newline at end of file
Perl/ApacheErrorLogFormatter.md
... ...
@@ -0,0 +1,202 @@
1
+[[_TOC_]]
2
+----
3
+# 概要
4
+- Apache の error_log を HTML テーブルとして整形する。
5
+- mod_security 対応。
6
+
7
+# 動作サンプル
8
+- http://www.takeash.net/AELF/
9
+
10
+# ソース
11
+- [AELF.zip](AELF.zip)
12
+
13
+## index.cgi
14
+```perl
15
+#!/usr/bin/perl
16
+# Apache のエラーログを整形
17
+
18
+use strict;
19
+use warnings;
20
+use utf8;
21
+use Encode;
22
+use CGI::Pretty qw( -no_xhtml *table *ol );
23
+use Net::DNS::Resolver;
24
+
25
+$CGI::POST_MAX = 80 * 1024;
26
+
27
+my $charsetConsole = 'UTF-8';
28
+#my $charsetConsole = 'CP932';
29
+my $charsetFile = 'UTF-8';
30
+
31
+binmode( STDIN, ":encoding($charsetConsole)" );
32
+binmode( STDOUT, ":encoding($charsetConsole)" );
33
+binmode( STDERR, ":encoding($charsetConsole)" );
34
+
35
+my $cgiName = 'Apache Error Log Formatter';
36
+
37
+my @pair_type = (
38
+ { # mod_security
39
+ header => qr/(ModSecurity:.*\.)\s(\[.*)\s*/,
40
+ to_pair => qr/\[\S+\s[^\]]+\]\s*/,
41
+ to_keyval => qr/\[(\S+)\s"([^\]]+)"\]\s*/,
42
+ },
43
+ { # default, detail部無し
44
+ header => qr/(.*)\s*/,
45
+ },
46
+);
47
+
48
+my $q = new CGI;
49
+$q->charset( $charsetFile );
50
+my $br = $q->br();
51
+
52
+my %processer = (
53
+ Client => \&toHostName,
54
+ data => sub{
55
+ my $word = shift;
56
+ $word =~ s/(\s(ARGS|ARGS_NAMES):)/$1$br/;
57
+ return $word;
58
+ },
59
+);
60
+
61
+my $log = $q->param('LOG') || '';
62
+if ( ( ! $ENV{'SERVER_ADDR'} ) && ( ! $log ) && ( my $file = $q->param('FILE') ) ){
63
+ open( my $IN, "<:encoding($charsetFile)", $file ) or die( "$file: $!\n" );
64
+ my @body = <$IN>;
65
+ close( $IN );
66
+ $log = join( "", @body );
67
+}
68
+
69
+print $q->header(
70
+ -type => 'text/html',
71
+ -charset => $charsetConsole,
72
+);
73
+print $q->start_html(
74
+ -title => $cgiName,
75
+ -head => [
76
+ $q->meta( { -http_equiv=>'Content-Type', -content=>"text/html; charset=" . $charsetConsole } ),
77
+ $q->meta( { -http_equiv=>'Content-style-type', -content=>"text/css" } ),
78
+ ],
79
+ -style => [ { 'src'=>'/take.css' }, ],
80
+);
81
+print $q->h1( $cgiName );
82
+
83
+if ( $log ){
84
+ print_result( $log );
85
+} else {
86
+ print_form();
87
+}
88
+
89
+print $q->end_html . "\n";
90
+
91
+exit;
92
+
93
+sub print_result
94
+{
95
+ my( $log ) = @_;
96
+ $log =~ s/\r\n|\n\r/\n/gmx;
97
+ $log =~ s/\r/\n/gmx;
98
+ $log =~ s/"([^\"]*)"/'"'.encodeURIComponent($1).'"'/gmxe;
99
+
100
+ print $q->p( $q->a( { -href => $q->url( -absolute => 1 ) }, 'form' ) );
101
+
102
+ my $index = 0;
103
+ foreach my $line ( split( "\n", $log ) ){
104
+ if ( $line =~ /^\x{feff}?\s*$/ ){
105
+ next;
106
+ }
107
+# print $q->h2( ++$index );
108
+ print $q->start_table( { -border => 1 } );
109
+# print $q->Tr( $q->th( 'Line' ), $q->td( $line ) );
110
+ my( $datetime, $level, $client, $line2 ) =
111
+ ( $line =~ /\[([^\]]+)\]\s\[([^\]]+)\](?:\s\[client\s([^\]]+)\])?\s*(.*)\s*$/ );
112
+ print $q->Tr( $q->th( 'Date Time' ), $q->td( $datetime ) );
113
+ print $q->Tr( $q->th( 'Level' ), $q->td( $level ) );
114
+ if ( $client ){
115
+ print $q->Tr( $q->th( 'Client' ), $q->td( toHostName( $client ) ) );
116
+ }
117
+# print $q->Tr( $q->th( 'Line2' ), $q->td( $line2 ) );
118
+ foreach my $type ( @pair_type ){
119
+ if ( $line2 =~ /^$type->{'header'}/ ){
120
+ my( $summary, $detail ) = ( $1, $2 );
121
+ $summary =~ s/([\.\,])\s/$1$br/;
122
+ print $q->Tr( $q->th( 'Summary' ), $q->td( decodeURIComponent( $summary ) ) );
123
+ if ( $detail ){
124
+ foreach my $pair ( getPair( $type->{'to_pair'}, $type->{'to_keyval'}, $detail ) ){
125
+ my( $key, $val ) = ( $pair->[0], $pair->[1] );
126
+ if ( my $proc = $processer{$key} ){
127
+ $val = $proc->( $val );
128
+ }
129
+ print $q->Tr( $q->th( $key ), $q->td( $val ) );
130
+ }
131
+ }
132
+ last;
133
+ }
134
+ }
135
+ print $q->end_table(), $q->br();
136
+ }
137
+
138
+ print $q->p( $q->a( { -href => $q->url( -absolute => 1 ) }, 'form' ) );
139
+}
140
+
141
+sub getPair
142
+{
143
+ my( $to_pair, $to_keyval, $line ) = @_;
144
+ my @ret = ();
145
+# print "'$to_pair'\n'$line'\n";
146
+ foreach my $pair ( $line =~ /$to_pair/g ){
147
+# print "'$pair'\n";
148
+ my( $key, $val ) = ( $pair =~ /^$to_keyval$/ );
149
+ $val = decodeURIComponent( $val );
150
+ push( @ret, [ $key, $val ] );
151
+ }
152
+ return @ret;
153
+}
154
+
155
+sub print_form
156
+{
157
+ print
158
+ $q->start_form( -action => $q->url, -enctype => 'multipart/form-data' ),
159
+ $q->submit, " ", $q->reset, $q->br(),
160
+ $q->textarea( -name=>'LOG', -rows=>20, -columns=>80 ),
161
+ $q->end_form;
162
+}
163
+
164
+sub encodeURIComponent
165
+{
166
+ my $str = encode( 'utf-8', shift );
167
+ $str =~ s/([^0-9A-Za-z!\x27()*\-._~])/sprintf("%%%02X", ord($1))/eg; # \x27 = '
168
+ return $str;
169
+}
170
+
171
+sub decodeURIComponent
172
+{
173
+ my $str = shift;
174
+ $str =~ s/%([0-9A-F][0-9A-F])/pack( "H*", $1 )/egi;
175
+ return decode( 'utf-8', $str );
176
+}
177
+
178
+sub toHostName
179
+{
180
+ my $ip_address = shift || '';
181
+ my $ret = '';
182
+
183
+ my $resolver = Net::DNS::Resolver->new;
184
+ if ( my $ans = $resolver->query( $ip_address ) ){
185
+ for my $rr ( $ans->answer ){
186
+ #print $rr->string, "\n";
187
+ if ( $rr->type eq 'PTR' ){
188
+ $ret = $rr->ptrdname;
189
+ last;
190
+ }
191
+ }
192
+ }
193
+
194
+ return $ip_address . '; ' . $ret;
195
+}
196
+
197
+# EOF
198
+```
199
+
200
+# リンク
201
+- [[Perl/MatchList]]
202
+- [[Linux/Apache]]
0 203
\ No newline at end of file
Perl/AutoHashedFuncs.md
... ...
@@ -0,0 +1,76 @@
1
+# AutoHashedFuncs
2
+[[_TOC_]]
3
+
4
+## 概要
5
+- 関数名を指定しなくても関数定義するだけで自動的にハッシュに登録されるサンプル。
6
+- 型グロブを使って定義されている関数をスキャンする。
7
+
8
+## ソース
9
+- [AutoHashedFuncs.zip](AutoHashedFuncs.zip)
10
+```Perl
11
+# 関数名を指定しなくても関数定義するだけで自動的にハッシュに登録される。
12
+
13
+use strict;
14
+use warnings;
15
+use utf8;
16
+use Encode;
17
+use YAML::Syck;
18
+
19
+{
20
+ package MyDecoder;
21
+
22
+ # 関数へのリファレンスが格納されるハッシュ
23
+ our %Decoders = ();
24
+
25
+ foreach my $key ( sort( keys( %MyDecoder:: ) ) ){
26
+ no strict "refs";
27
+ if ( $key =~ /decode(.*)/ && *{"MyDecoder::$key"}{CODE} ){
28
+ $Decoders{$1} = *{"MyDecoder::$key"}{CODE};
29
+ }
30
+ }
31
+
32
+ # 型グロブからアクセスできるけど CODE ではないので登録されない
33
+ my $decode1 = "aaa";
34
+ my @decode2 = qw( bbb ccc ddd );
35
+ our $decode3 = "eee";
36
+ our @decode4 = qw( fff ggg hhh );
37
+
38
+ # 登録される
39
+ sub decodeAdd {
40
+ my( $a, $b ) = @_;
41
+ return $a + $b;
42
+ }
43
+
44
+ # 登録される
45
+ sub decodeMul {
46
+ my( $a, $b ) = @_;
47
+ return $a * $b;
48
+ }
49
+
50
+ # 関数名がルールから外れているので登録されない
51
+ sub helper1 {
52
+ my( $a, $b ) = @_;
53
+ return $a - $b;
54
+ }
55
+}
56
+
57
+# $main::refDecoders にリファレンスをコピーして使い易くする
58
+my $refDecoders = \%MyDecoder::Decoders;
59
+
60
+print Dump( $refDecoders ) . "\n";
61
+
62
+for my $key ( qw( decode1 decode2 decode3 decode4 decodeAdd Add decodeMul Mul helper1 ) ){
63
+ if ( my $dc = $refDecoders->{$key} ){
64
+ print "$key:\t" . &{$dc}( 2, 4 ) . "\n";
65
+ } else {
66
+ print "$key:\t-\n";
67
+ }
68
+}
69
+
70
+# EOF
71
+```
72
+
73
+## リンク
74
+- [perldoc.jp](http://perldoc.jp/) / [Perlのリファレンスとネストしたデータ構造](http://perldoc.jp/pod/perlref)
75
+
76
+- [サンプルコードによるPerl入門](http://d.hatena.ne.jp/perlcodesample/) / [型グロブとシンボルテーブル](http://d.hatena.ne.jp/perlcodesample/20080614/1213428778)
0 77
\ No newline at end of file
Perl/CGI.pm.md
... ...
@@ -0,0 +1,266 @@
1
+[[_TOC_]]
2
+
3
+# 概要
4
+- CGI.pm のテストサンプル
5
+- [動作サンプル](http://www.takeash.net/cgi-bin/etc/testCGI.cgi)
6
+- フォームタグが閉じていなかったのを修正。(2012/10/02)
7
+
8
+# 注意点
9
+
10
+## textfield や hidden などの値を加工してセットしても前の値が表示される
11
+```perl
12
+my $param1 = $q->param('param1');
13
+++$param1;
14
+print $param1;
15
+print $q->textfield( -name => 'param1', -default => $param1 ); # 前の値のまま
16
+```
17
+- 対応方法
18
+ 1. タグを表示する前に param で値をセットする。
19
+```perl
20
+$q->param( 'param1', $somevalue ); # $q->param( -name => 'param1', -values => [ $somevalue ] );
21
+```
22
+ - [つかのぺ](http://tuka.s12.xrea.com/) / [CGI.pm](http://tuka.s12.xrea.com/index.xcg?p=CGI.pm)
23
+ 1. override を指定すると強制的に上書きできる。
24
+```perl
25
+print $q->textfield( -name => 'param1', -default => $somevalue, -override => 1 );
26
+```
27
+
28
+## リストコンテキストでのパラメータ読み出し
29
+- セキュリティ上の問題のため、リストコンテキストで「$q->param('name')」を使うと警告が表示される。<br />リストコンテキストが必要な場合は代わりに「$q->multi_param('name')」を使う。
30
+- [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)
31
+
32
+# ソース
33
+- [testCGI.zip](testCGI.zip)
34
+```perl
35
+#!/usr/bin/perl
36
+#
37
+# CGI.pm のテスト
38
+
39
+use strict;
40
+use warnings;
41
+use utf8;
42
+use Encode;
43
+use YAML::Syck;
44
+use CGI::Pretty qw( -no_xhtml *table ); # //HTML 4.01 Transitional//EN
45
+#use CGI::Carp qw/fatalsToBrowser warningsToBrowser/;
46
+
47
+$YAML::Syck::ImplicitUnicode = 1;
48
+
49
+binmode( STDIN, ":utf8" );
50
+binmode( STDOUT, ":utf8" );
51
+binmode( STDERR, ":utf8" );
52
+
53
+my $cginame = 'testCGI';
54
+my $cookiename = 'クッキー';
55
+my $charset = 'utf-8';
56
+
57
+# フォームのエンコーディングタイプ。
58
+# CGI.pm Version 3.48 の param メソッドに影響する。
59
+# 1: application/x-www-form-urlencoded, param メソッドでバイナリ文字列が返る。
60
+# 0: multipart/form-data, param メソッドで utf8 フラグ付き文字列が返る。
61
+my $enctype = 1;
62
+
63
+my $q = new CGI;
64
+$q->charset( $charset );
65
+
66
+my %popupgroup = (
67
+ 'popup1' => 'ポップアップ1', 'popup2' => 'ポップアップ2',
68
+ 'popup3' => 'ポップアップ3', 'popup4' => 'ポップアップ4',
69
+);
70
+my %scrollgroup = (
71
+ 'scroll1' => 'スクロール1', 'scroll2' => 'スクロール2',
72
+ 'scroll3' => 'スクロール3', 'scroll4' => 'スクロール4',
73
+ 'scroll5' => 'スクロール5',
74
+);
75
+my %checkgroup = (
76
+ 'check1'=>'チェック1', 'check2'=>'チェック2',
77
+ 'check3'=>'チェック3',
78
+);
79
+my %radiogroup = (
80
+ 'radio1'=>'ラジオ1', 'radio2'=>'ラジオ2',
81
+ 'radio3'=>'ラジオ3',
82
+);
83
+
84
+my @names;
85
+if ( $enctype ){
86
+ # 'application/x-www-form-urlencoded'
87
+ @names = map{ decode( 'utf8', $_ ) } $q->param();
88
+} else {
89
+ # 'multipart/form-data'
90
+ @names = $q->param();
91
+}
92
+
93
+printHeader();
94
+
95
+if ( @names ){
96
+ print $q->h2('Param');
97
+ print $q->start_table( { '-summary' => 'Parameters', '-border' => 1 } );
98
+ foreach my $name ( @names ){
99
+ if ( $enctype ){
100
+ # 'application/x-www-form-urlencoded'
101
+ print $q->Tr(
102
+ $q->th( $name ),
103
+ $q->td( join( $q->br(), map{ decode( 'utf8', $_ ) } $q->param( encode( 'utf8', $name ) ) ) )
104
+ );
105
+ } else {
106
+ # 'multipart/form-data'
107
+ print $q->Tr(
108
+ $q->th( $name ),
109
+ $q->td( join( $q->br(), $q->param( $name ) ) )
110
+ );
111
+ }
112
+ }
113
+ print $q->end_table();
114
+ print $q->h2('Cookie');
115
+ print $q->start_table( { '-summary' => 'Cookie', '-border' => 1 } );
116
+ foreach my $cookiename ( $q->cookie() ){
117
+ print $q->Tr(
118
+ $q->th( decode( 'utf8', $cookiename ) ),
119
+ $q->td( join( $q->br(), map{ decode( 'utf8', $_ ) } $q->cookie( $cookiename ) ) )
120
+ );
121
+ }
122
+ print $q->end_table();
123
+} else {
124
+ print $q->start_form(
125
+ '-action' => $q->url,
126
+ '-enctype' => (
127
+ ( $enctype )
128
+ ? 'application/x-www-form-urlencoded'
129
+ : 'multipart/form-data'
130
+ ),
131
+ );
132
+ print $q->start_table( { '-summary' => 'Parameters', '-border' => 1 } );
133
+ print $q->Tr(
134
+ $q->th( 'テキスト' ),
135
+ $q->td( $q->textfield(
136
+ '-name' => 'テキスト',
137
+ '-value' => 'あいうえお漢字'
138
+ ) )
139
+ );
140
+ print $q->Tr(
141
+ $q->th( 'テキストエリア' ),
142
+ $q->td( $q->textarea(
143
+ '-name' => 'テキストエリア',
144
+ '-default' => "予定表\n\x{20B9F}",
145
+ '-rows' => 3,
146
+ '-columns' => 20
147
+ ) )
148
+ );
149
+ print $q->Tr(
150
+ $q->th( 'ポップアップ' ),
151
+ $q->td( $q->popup_menu(
152
+ '-name' => 'ポップアップ',
153
+ '-values' => [ sort( keys( %popupgroup ) ) ],
154
+ '-default' => ( sort( keys( %popupgroup ) ) )[0],
155
+ '-labels' => \%popupgroup,
156
+ ) )
157
+ );
158
+ print $q->Tr(
159
+ $q->th( 'スクロール' ),
160
+ $q->td( $q->scrolling_list(
161
+ '-name' => 'スクロール',
162
+ '-values' => [ sort( keys( %scrollgroup ) ) ],
163
+ '-default' => ( sort( keys( %scrollgroup ) ) )[0],
164
+ '-size' => 3,
165
+ '-multiple' => 'true',
166
+ '-labels' => \%scrollgroup,
167
+ ) )
168
+ );
169
+ print $q->Tr(
170
+ $q->th( 'チェックボックス' ),
171
+ $q->td( $q->checkbox_group(
172
+ '-name' => 'チェックボックス',
173
+ '-values' => [ sort( keys( %checkgroup ) ) ],
174
+ '-default' => ( sort( keys( %checkgroup ) ) )[0],
175
+ '-linebreak' => 'true',
176
+ '-labels' => \%checkgroup,
177
+ ) )
178
+ );
179
+ print $q->Tr(
180
+ $q->th( 'ラジオボタン' ),
181
+ $q->td( $q->radio_group(
182
+ '-name' => 'ラジオボタン',
183
+ '-values' => [ sort( keys( %radiogroup ) ) ],
184
+ '-default' => ( sort( keys( %radiogroup ) ) )[0],
185
+ '-linebreak' => 'true',
186
+ '-labels' => \%radiogroup,
187
+ ) )
188
+ );
189
+ print $q->Tr( $q->td(
190
+ { '-colspan' => 2, '-align' => 'center' },
191
+ $q->submit . ' ' . $q->reset
192
+ ) );
193
+ print $q->end_table();
194
+ print $q->end_form;
195
+}
196
+
197
+printFooter();
198
+
199
+exit;
200
+
201
+sub printHeader
202
+{
203
+ my $cookieval = decode( 'utf8',
204
+ $q->cookie( encode( 'utf8', $cookiename ) ) || ''
205
+ );
206
+ $cookieval .= 'あ';
207
+ my $cookie = $q->cookie(
208
+ '-name' => encode( 'utf8', $cookiename ),
209
+ '-value' => encode( 'utf8', $cookieval ),
210
+ );
211
+ print $q->header( '-cookie' => [ $cookie ] );
212
+ print $q->start_html(
213
+ '-title' => $cginame,
214
+ '-lang' => 'ja-JP',
215
+ '-head' => [
216
+ $q->meta( { '-http_equiv' => 'Content-style-type', '-content' => 'text/css' } ),
217
+ $q->meta( { '-http_equiv' => 'Content-script-type', '-content' => 'text/javascript' } ),
218
+ ],
219
+ '-style' => [ { 'src' => '/take.css' }, ],
220
+ );
221
+ print $q->h1( $cginame );
222
+}
223
+
224
+sub printFooter
225
+{
226
+ print $q->end_html . "\n";
227
+}
228
+
229
+# EOF
230
+```
231
+
232
+# システム設定
233
+
234
+## Windows Server 2012(IIS8)
235
+- IIS インストール時に、「CGI」「ISAPI 拡張」「要求フィルター」を有効にする。
236
+ - IPアドレスによるアクセス制限を行う場合は「IPおよびドメインの制限」も有効にする。
237
+- IIS マネージャ
238
+ - 「アプリケーションプール - DefaultAppPool - 詳細設定 - 32ビットアプリケーションの有効化」を「True」に設定する。
239
+ - 「Default Web Site」または該当フォルダ
240
+ - 「ハンドラーマッピング」を開き、「スクリプトマップ」を追加する。
241
+| 要求パス | *.cgi |
242
+| --- | --- |
243
+| 実行可能ファイル | C:\Perl\bin\perlis.dll |
244
+| 名前 | Perl CGI |
245
+ - 「既定のドキュメント」を開き、「index.cgi」を追加する。
246
+ - 「要求フィルター」のアップロード許可最大サイズの既定値は30MB弱。
247
+ - 最大値を変更する場合は、「要求フィルター」から、「機能設定の編集」を開き、「許可されたコンテンツ最大長」を変更する。
248
+ - [IIS で要求フィルタリングを構成する](http://technet.microsoft.com/ja-jp/library/hh831621.aspx)
249
+ - [要求フィルターの使用方法](http://technet.microsoft.com/ja-jp/library/dd939071.aspx)
250
+ - [要求制限 <requestLimits>](http://technet.microsoft.com/ja-jp/library/ee431638.aspx)
251
+
252
+- Active Perl は 32bit 版をインストールする。
253
+ - 64bit 版は、「perlis.dll」が含まれていない。
254
+ - CGI.pm でのアップロードサイズ制限設定は $CGI::POST_MAX で行う。
255
+
256
+# リンク
257
+- [[Perl/環境変数]]
258
+
259
+- [CPAN:CGI-Alternatives](http://search.cpan.org/dist/CGI-Alternatives)
260
+- [CPAN:Mojolicious](http://search.cpan.org/dist/Mojolicious)
261
+ - [CPAN:Mojolicious/lib/Mojolicious/Lite.pm](http://search.cpan.org/dist/Mojolicious/lib/Mojolicious/Lite.pm)
262
+
263
+- [CPAN:CGI](http://search.cpan.org/dist/CGI)
264
+- [CPAN:Encode](http://search.cpan.org/dist/Encode)
265
+
266
+- [perl - use CGI; use Encode; # 非英語Webプログラミング3原則](http://blog.livedoor.jp/dankogai/archives/51227060.html)
0 267
\ No newline at end of file
Perl/CPAN.md
... ...
@@ -0,0 +1,169 @@
1
+[[_TOC_]]
2
+
3
+# CPAN
4
+## シェルを起動して対話的にインストール
5
+```
6
+# perl -MCPAN -e shell
7
+```
8
+
9
+## bash 等からインストール
10
+```
11
+# perl -MCPAN -e "CPAN::Shell->install('Bundle::CPAN')"
12
+```
13
+
14
+## 更新可能なパッケージ一覧の表示
15
+```
16
+# perl -MCPAN -e "CPAN::Shell->r"
17
+```
18
+
19
+## 一括更新
20
+```
21
+# perl -MCPAN -e "CPAN::Shell->install(CPAN::Shell->r)"
22
+```
23
+- 途中で Yes/No の確認を求められる。
24
+
25
+## バージョンを指定してインストール
26
+```
27
+# perl -MCPAN -e "CPAN::Shell->install('LEMBARK/FindBin-libs-1.55.tar.gz')"
28
+```
29
+- [CPAN:FindBin-libs](http://search.cpan.org/dist/FindBin-libs) は Perl v5.10.0 以上が必要で v5.8.8 にはインストールできない。
30
+
31
+## シェルでヒストリが効かない (Bundle::CPANをインストール)
32
+```
33
+> install Bundle::CPAN
34
+```
35
+
36
+## 強制的に再インストール
37
+- インストール済みであっても強制に再インストールするには「force」を付ける。
38
+```
39
+> force install Scalar::Util
40
+```
41
+- 「IO::Socket::SSL」が下記エラーにてインストールできなかったら、依存する「Scalar::Util」を強制再インストールする。
42
+```
43
+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.
44
+```
45
+&#x20;
46
+```
47
+You need the XS Version of Scalar::Util for dualvar() support at Makefile.PL line 56.
48
+```
49
+
50
+## 複数のパッケージをまとめてインストール
51
+- インストールしたいパッケージ名を書いた適当な *.pm ファイルを作成し、それをインストールする。
52
+```
53
+# cd ~
54
+# perl -MCPAN -e "CPAN::Shell->install('Bundle::MyPackages')"
55
+```
56
+- /root/Bundle/MyPackages.pm
57
+```perl
58
+package Bundle::MyPackages;
59
+
60
+use strict;
61
+use utf8;
62
+use vars qw( $VERSION );
63
+$VERSION = "0.01";
64
+1;
65
+
66
+=head1 CONTENTS
67
+
68
+Env
69
+Fatal
70
+Test::Warnings
71
+Test::Output
72
+Test::Deep
73
+Time::Piece
74
+CGI
75
+URI::Escape::XS
76
+File::Basename
77
+FindBin::libs
78
+Getopt::Long
79
+HTTP::Date
80
+JSON::XS
81
+Lingua::JA::Numbers
82
+Lingua::JA::Regular::Unicode
83
+Log::Dispatch
84
+MIME::Base64
85
+Socket
86
+Net::IP
87
+Net::Wake
88
+Crypt::SSLeay
89
+Perl::Tidy
90
+String::Util
91
+Text::CSV_XS
92
+Text::xSV::Slurp
93
+XML::Simple
94
+XML::XPath
95
+enum::hash
96
+Attribute::Constant
97
+Number::Format
98
+PadWalker
99
+Term::Encoding
100
+
101
+=cut
102
+```
103
+- [複数のCPANモジュールを一括インストール - Kawa.net 旧ゆうすけブログ (Yahoo!版)](http://blogs.yahoo.co.jp/kawa_kawa_kawa_kawa/650645.html)
104
+
105
+## インストール済みのモジュールのバージョン確認
106
+- Linux
107
+```
108
+# perl -M(モジュール名) -e 'print "$(モジュール名)::VERSION\n";'
109
+# perl -MJSON::Syck -e 'print "$JSON::Syck::VERSION\n";'
110
+```
111
+- Win
112
+```
113
+> perl -M(モジュール名) -e "print $(モジュール名)::VERSION;"
114
+> perl -MJSON::Syck -e "print $JSON::Syck::VERSION;"
115
+```
116
+
117
+# cpanminus
118
+## インストール
119
+- yum
120
+```
121
+# yum install perl-App-cpanminus
122
+```
123
+- CPAN
124
+```
125
+# perl -MCPAN -e "CPAN::Shell->install('App::cpanminus')"
126
+# cpanm App::cpanoutdated
127
+```
128
+
129
+## cpanm 自身のアップグレード
130
+```
131
+# cpanm --self-upgrade
132
+```
133
+
134
+## 一括更新
135
+```
136
+# cpan-outdated | cpanm
137
+```
138
+
139
+# ppm
140
+## 一括更新
141
+```
142
+> ppm upgrade --install
143
+```
144
+
145
+## 複数のパッケージをまとめてインストール
146
+- パッケージを複数指定する。
147
+```
148
+> ppm install Env Fatal Test::Warnings Test::Output Test::Deep Time::Piece
149
+> ppm install CGI URI::Escape::XS File::Basename FindBin::libs Getopt::Long
150
+> ppm install HTTP::Date JSON::XS Lingua::JA::Numbers Lingua::JA::Regular::Unicode
151
+> ppm install Log::Dispatch MIME::Base64 Socket Net::IP Net::Wake Crypt::SSLeay Perl::Tidy
152
+> ppm install String::Util Text::CSV_XS Text::xSV::Slurp XML::Simple XML::XPath
153
+> ppm install enum::hash Attribute::Constant Number::Format PadWalker Term::Encoding
154
+```
155
+
156
+# リンク
157
+- [CPAN:CPAN/lib/CPAN.pm](http://search.cpan.org/dist/CPAN/lib/CPAN.pm)
158
+
159
+- [CPAN:App-cpanminus](http://search.cpan.org/dist/App-cpanminus)
160
+- https://github.com/miyagawa/cpanminus
161
+- [perl-App-cpanminus](http://rpm.pbone.net/index.php3?stat=3&search=perl-App-cpanminus&srodzaj=3)
162
+
163
+- [CPAN:Module-CoreList/lib/Module/CoreList.pod](http://search.cpan.org/dist/Module-CoreList/lib/Module/CoreList.pod)
164
+- [$shibayu36->blog;](http://shibayu36.hatenablog.com/)
165
+ - [perlであるモジュールがコアモジュールかどうか調べる;](http://shibayu36.hatenablog.com/entry/2014/03/08/115105)
166
+
167
+- [CPAN:ExtUtils-Install/lib/ExtUtils/Installed.pm](http://search.cpan.org/dist/ExtUtils-Install/lib/ExtUtils/Installed.pm)
168
+- [Using Perl](http://nozawashinichi.sakura.ne.jp/usingmt/)
169
+ - [Perl インストールされているモジュールを出力するコマンド](http://nozawashinichi.sakura.ne.jp/usingmt/2014/03/perl-8.html)
0 170
\ No newline at end of file
Perl/DBIx-Custom.md
... ...
@@ -0,0 +1,177 @@
1
+# DBIx::Custom
2
+[[_TOC_]]
3
+
4
+## 概要
5
+- [CPAN:DBIx-Custom](http://search.cpan.org/dist/DBIx-Custom) を使用して MS SQL Server に対してクエリを実行するサンプル。
6
+- Where 句に「:UserID{=}」とか付け加えたいとこだけど、「$dbi->not_exists」がうまく働いてなくて値無しだとハングアップするみたいだ。
7
+- というか MS SQL Server の ODBC はハングアップし過ぎ。ちゃんとエラー出して止まってくれ。
8
+
9
+## ソース
10
+- [DBIx-Custom.zip](DBIx-Custom.zip)
11
+
12
+### summarize.pl
13
+```perl
14
+#!/usr/bin/perl
15
+# DBIx::Custom サンプル
16
+# 注文履歴集計 MS SQL Server 用
17
+
18
+use strict;
19
+use warnings;
20
+use utf8;
21
+use Encode;
22
+use YAML::Syck;
23
+use DBIx::Custom;
24
+use DateTime;
25
+use Text::xSV::Slurp qw( xsv_slurp );
26
+
27
+$YAML::Syck::ImplicitUnicode = 1;
28
+
29
+my $charsetConsole = 'CP932';
30
+#my $charsetFile = 'UTF-8';
31
+my $charsetFile = 'CP932';
32
+
33
+binmode( STDIN, ":encoding($charsetConsole)" );
34
+binmode( STDOUT, ":encoding($charsetConsole)" );
35
+binmode( STDERR, ":encoding($charsetConsole)" );
36
+
37
+my $DB_Connect_yaml = './DB_Connect.yaml';
38
+my $fnOders = './DB/Orders.txt';
39
+
40
+my $start_date = '2012-08-20';
41
+my $end_date = '2012-09-01';
42
+
43
+my $DB_Connect = YAML::Syck::LoadFile( $DB_Connect_yaml )
44
+ or die( "$DB_Connect_yaml: $!\n" );
45
+foreach( %{$DB_Connect} ){
46
+ $DB_Connect->{'DSN'} =~ s/_${_}_/$DB_Connect->{$_}/;
47
+}
48
+
49
+my $dbi = DBIx::Custom->connect(
50
+ dsn => 'DBI:' . $DB_Connect->{'DSN'},
51
+ user => $DB_Connect->{'User'},
52
+ password => $DB_Connect->{'Password'},
53
+ option => $DB_Connect->{'Options'}
54
+);
55
+
56
+#insertOrderRandom();
57
+#insertOrderFromFile();
58
+
59
+my $Orders = getOrders( $start_date, $end_date );
60
+print Dump( $Orders );
61
+exit;
62
+
63
+sub getOrders
64
+{
65
+ my( $start_date, $end_date ) = @_;
66
+
67
+ my $where = $dbi->where;
68
+ $where->clause( [ 'and', ':OrderDateTime{>=}', ':OrderDateTime{<}' ] );
69
+ $where->param({
70
+ OrderDateTime => [
71
+ $start_date ? $start_date : '1900-01-01', # $dbi->not_exists だとハングアップする?
72
+ $end_date ? $end_date : '9999-12-31', # $dbi->not_exists だとハングアップする?
73
+ ],
74
+ });
75
+
76
+ my $sortOrder = $dbi->order;
77
+ $sortOrder->prepend( 'UserID', 'OrderDateTime' );
78
+
79
+ my $Orders = $dbi->select(
80
+ table => 'Orders',
81
+ column => [
82
+ '[Orders].[OrderDateTime]', '[Orders].[OrderQuantity]', # Orders
83
+ '[Users].[UserID]', '[Users].[UserName]', # Users
84
+ '[Items].[ItemName]', '[Items].[ItemUnitPrice]', # Items
85
+ '[Items].[ItemUnitPrice] * [Orders].[OrderQuantity] as [SubTotalPrice]', # 追加計算
86
+ ],
87
+ join => [
88
+ 'JOIN [Users] ON [Orders].[OrderUser] = [Users].[UserID]',
89
+ 'JOIN [Items] ON [Orders].[OrderItem] = [Items].[ItemID]',
90
+ ],
91
+ where => $where,
92
+ append => $sortOrder->to_string,
93
+ )->all;
94
+
95
+ return $Orders;
96
+}
97
+
98
+sub insertOrderRandom
99
+{
100
+ my $userMax = 5;
101
+ my $itemMax = 7;
102
+ my $quantityMax = 30;
103
+ for( my $orderNum = 20; $orderNum > 0; --$orderNum ){
104
+ my $datetime = DateTime->new(
105
+ time_zone => 'local',
106
+ year => 2012,
107
+ month => int( rand( 4 ) + 7 ),
108
+ day => int( rand( 31 ) + 1 ),
109
+ hour => int( rand( 10 ) + 9 ),
110
+ minute => int( rand( 60 ) ),
111
+ );
112
+ $dbi->insert(
113
+ {
114
+ OrderDateTime => $datetime->ymd('-') . ' ' . $datetime->hms(':'),
115
+ OrderUser => int( rand( $userMax ) + 1 ),
116
+ OrderItem => int( rand( $itemMax ) + 1 ),
117
+ OrderQuantity => int( rand( $quantityMax ) + 1 ),
118
+ },
119
+ table => 'Orders',
120
+ );
121
+ }
122
+}
123
+
124
+sub insertOrderFromFile
125
+{
126
+ my @orders = readXSV( $fnOders, { sep_char => "\t" } );
127
+ foreach my $order ( @orders ){
128
+ delete $order->{'OrderID'}; # IDENTITY 列を追加しようとするとハングアップする。
129
+ $dbi->insert(
130
+ $order,
131
+ table => 'Orders',
132
+ );
133
+ }
134
+}
135
+
136
+sub readXSV
137
+{
138
+ my( $fname, $opt ) = @_;
139
+ $opt = { binary => 1, %{$opt} };
140
+ open( my $fhin, "<:encoding($charsetFile)", encode( $charsetConsole, $fname ) )
141
+ or die( "$fname: $!" );
142
+ my @body = <$fhin>;
143
+ close( $fhin );
144
+ my $ret = xsv_slurp(
145
+ string => join( "", @body ),
146
+ text_csv => $opt,
147
+ );
148
+ return ( ref( $ret ) eq 'ARRAY' )
149
+ ? @{ $ret }
150
+ : $ret ;
151
+}
152
+
153
+# EOF
154
+```
155
+
156
+### DB_Connect.yaml
157
+```
158
+# DB接続情報
159
+Driver: ODBC
160
+Server: localhost\SQLExpress,1433 # <サーバ名>\<インスタンス名>[,<ポート番号>]
161
+User: TestUser
162
+Password: "TestPass" # 記号を含む場合は""で括る。
163
+DB: TestShop1
164
+Trusted_Connection: No
165
+AutoTranslate: No
166
+Options:
167
+ LongTruncOk: 1
168
+ LongReadLen: 8192
169
+DSN: _Driver_:Driver={SQL Server}; Server={_Server_}; Database=_DB_; Trusted_Connection=_Trusted_Connection_; AutoTranslate=_AutoTranslate_;
170
+```
171
+
172
+## リンク
173
+- [[DBIx::NamedParams|Perl/DBIx-NamedParams]]
174
+
175
+- [CPAN:DBIx-Custom](http://search.cpan.org/dist/DBIx-Custom)
176
+ - [CPAN:DBIx-Custom/lib/DBIx/Custom/Where.pm](http://search.cpan.org/dist/DBIx-Custom/lib/DBIx/Custom/Where.pm)
177
+ - [CPAN:DBIx-Custom/lib/DBIx/Custom/Order.pm](http://search.cpan.org/dist/DBIx-Custom/lib/DBIx/Custom/Order.pm)
0 178
\ No newline at end of file
Perl/DBIx-NamedParams.md
... ...
@@ -0,0 +1,825 @@
1
+# DBIx::NamedParams
2
+[[_TOC_]]
3
+
4
+## 概要
5
+- mysql でも prepare でプレースホルダとして ? じゃなく名前で指定できるようにする。
6
+- 同じ名前を繰り返し使ってもエラーにならない。
7
+- こっちより [CPAN:DBIx-Custom](http://search.cpan.org/dist/DBIx-Custom) の方が柔軟で高機能だなー。どうしたもんか。
8
+- [CPAN:DBIx-NamedBinding](http://search.cpan.org/dist/DBIx-NamedBinding) に比べると、bind_param_ex の1回でバインドできるのと型指定できる点が勝ってるかな。
9
+
10
+## 使用法
11
+### スカラーのバインド
12
+- 「:名前-型」でスカラー値を bind する。
13
+```perl
14
+my $sql_insert = qq{
15
+ INSERT INTO `Users` ( `ID`, `Name`, `Status`, `RegDate` )
16
+ VALUES ( NULL, :Name-VARCHAR, :State-INTEGER, :RegDate-DATETIME );
17
+};
18
+$sth_insert = $dbh->prepare_ex( $sql_insert ) or die( "$DBI::errstr\n" );
19
+$sth_insert->bind_param_ex( { 'Name' => 'リオ', 'State' => 1, 'RegDate' => '2011-02-21 10:00' } );
20
+$sth_insert->execute() or die( "$DBI::errstr\n" );
21
+```
22
+
23
+### 配列(個数指定あり)のバインド
24
+- 「:名前{個数}-型」で配列値を個数個分 bind する。
25
+```perl
26
+my $sql_select = qq{
27
+ SELECT `ID`, `Name`, `Status`, `RegDate`
28
+ FROM `Users`
29
+ WHERE `Status` in ( :State{4}-INTEGER );
30
+};
31
+$sth_select = $dbh->prepare_ex( $sql_select ) or die( "$DBI::errstr\n" );
32
+$sth_select->bind_param_ex( { 'State' => [ 1,2,4,8 ] } );
33
+$sth_select->execute() or die( "$DBI::errstr\n" );
34
+```
35
+
36
+### 配列(個数指定なし)のバインド
37
+- 「:名前+-型」で配列値を配列要素個分 bind する。<br />
38
+prepare_exの引数としてSQL文と共に割り当てるハッシュを指定する必要がある。
39
+```perl
40
+my $sql_select = qq{
41
+ SELECT `ID`, `Name`, `Status`, `RegDate`
42
+ FROM `Users`
43
+ WHERE `Status` in ( :State+-INTEGER );
44
+};
45
+$sth_select = $dbh->prepare_ex( $sql_select, { 'State' => [ 1,2,4,8 ] } )
46
+ or die( "$DBI::errstr\n" );
47
+$sth_select->execute() or die( "$DBI::errstr\n" );
48
+```
49
+
50
+### デバッグログの採取
51
+- プレースホルダの解析結果、解析後の SQL 文、バインドされる値をログファイルに書き出します。
52
+- ファイル名を省略すると、ホームディレクトリ(Linux: 環境変数 HOME, Windows: 環境変数 USERPROFILE)にログファイル(DBIx-NamedParams.log)が作られます。
53
+```
54
+DBIx::NamedParams::debug_log( 'testNamedParams.log' );
55
+```
56
+
57
+### DBD のデータタイプに対応する SQL タイプのハッシュ
58
+```
59
+my %DrvTypeToSQLType = $dbh->driver_typename_map();
60
+```
61
+- [[MySQL の例|#MySQL_DataType_Map]]
62
+- [[MS SQL Server の例|#MSSQL_DataType_Map]]
63
+
64
+## 変更履歴
65
+### 0.0.5 / 2011/09/28
66
+- driver_typename_map メソッドが返すハッシュを調整。DB が MS SQL Server の場合、datetime および smalldatetime に対して DATE ではなく WVARCHAR を割り当てるようにした。
67
+
68
+### 0.0.4 / 2011/09/17
69
+- driver_typename_map メソッド追加。その DBD で使用できるデータタイプに対応する SQL タイプ名のハッシュを返す。
70
+- デバッグログのファイル名を指定できるようにした。ログの体裁の調整。
71
+- MS SQL Server 版のサンプルを作成。datetime 型にバインドするのに DATETIME じゃなくて WVARCHAR(VARCHAR) 使わなくちゃいけないなんて、そんなん考慮しとらんよ…。
72
+
73
+### 0.0.3 / 2011/04/17
74
+- 機能面での追加・変更はなし。
75
+- 「use base;」を「use parent;」に変更。
76
+- import にて、継承元である DBI の import を呼び出すようにしたけど、不要かも?
77
+- ソース内の関数の順序を呼び出し元と呼び出し先が近くになるように変更。
78
+- _parse_ex にて、$repeat の既定値を '' から 0 に変更。
79
+- bind_param_ex にて、「no warnings;」を「no warnings 'uninitialized';」に変更。
80
+- bind_param_ex にて、$ref_hash が HASH であることを確認するようにした。
81
+
82
+### 0.0.2 / 2011/03/07
83
+- prepare_ex のときに @_NamedParams をクリアするようにした。
84
+
85
+## ソース
86
+- [NamedParams.zip](NamedParams.zip)
87
+
88
+### NamedParams.pm
89
+```perl
90
+# DBI::db::prepare, DBI::st::bind_param を拡張する。
91
+# http://www.TakeAsh.net/wiki/?Perl/DBIx-NamedParams
92
+#
93
+# prepare_ex では「:名前-型」形式のようにプレースホルダを書く。
94
+# bind_param_ex では名前と値の対応を示すハッシュを渡す。
95
+
96
+package DBIx::NamedParams;
97
+
98
+use strict;
99
+use warnings;
100
+use utf8;
101
+use Encode;
102
+use Carp qw( croak );
103
+use parent qw( DBI );
104
+use DBI::Const::GetInfoType;
105
+use Log::Dispatch;
106
+use POSIX qw( strftime );
107
+
108
+use version; our $VERSION = qv( '0.0.5' );
109
+
110
+( $ENV{'LANG'} || '' ) =~ /\.(.*)$/; # ja_JP.UTF-8
111
+my $charsetConsole = $1 || 'CP932';
112
+my $charsetFile = 'UTF-8';
113
+
114
+my $_default_log_filename = ( $ENV{'HOME'} || $ENV{'USERPROFILE'} );
115
+$_default_log_filename =~ s#\\#/#g;
116
+$_default_log_filename .= '/DBIx-NamedParams.log';
117
+
118
+my %_SQL_TypeRefs = ();
119
+my %_SQL_TypeInvs = ();
120
+my $_SQL_Types = "";
121
+my @_NamedParams = ();
122
+my $_index;
123
+my $_log = undef;
124
+
125
+sub import {
126
+ DBI->import(); # 不要か?
127
+ _init();
128
+ *{DBI::db::driver_typename_map} = \&driver_typename_map;
129
+ *{DBI::db::prepare_ex} = \&prepare_ex;
130
+ *{DBI::st::bind_param_ex} = \&bind_param_ex;
131
+}
132
+
133
+sub _init
134
+{
135
+ foreach( @{ $DBI::EXPORT_TAGS{sql_types} } ){
136
+ my $refFunc = \&{"DBI::$_"};
137
+ if ( /^SQL_(.*)$/i ){
138
+ $_SQL_TypeRefs{ $1 } = &{ $refFunc };
139
+ $_SQL_TypeInvs{ &{ $refFunc } } = $1;
140
+ }
141
+ }
142
+ $_SQL_Types = all_sql_types();
143
+}
144
+
145
+sub debug_log
146
+{
147
+ my( $filename ) = @_;
148
+ $filename = encode( $charsetConsole, ( $filename || $_default_log_filename ) );
149
+ $_log = Log::Dispatch->new(
150
+ outputs => [ [
151
+ 'File',
152
+ min_level => 'debug',
153
+ filename => $filename,
154
+ binmode => ":encoding($charsetFile)",
155
+ permissions => 0666,
156
+ newline => 1,
157
+ ], ],
158
+ );
159
+ $_log->info( _thisFuncName(), strftime( "%Y-%m-%d %H:%M:%S", localtime ) );
160
+}
161
+
162
+sub _thisFuncName
163
+{
164
+ ( caller( 1 ) )[3] =~ /([^:]+)$/;
165
+ return $1;
166
+}
167
+
168
+sub all_sql_types
169
+{
170
+ return wantarray
171
+ ? sort( keys( %_SQL_TypeRefs ) )
172
+ : join( "|", sort( keys( %_SQL_TypeRefs ) ) );
173
+}
174
+sub driver_typename_map
175
+{
176
+ my( $self ) = @_;
177
+ my %map = ();
178
+ foreach my $refType ( $self->type_info() ){
179
+ my $datatype = $refType->{ 'SQL_DATA_TYPE' } # MS SQL Server
180
+ || $refType->{ 'SQL_DATATYPE' }; # MySQL
181
+ $map{ $refType->{ 'TYPE_NAME' } } = $_SQL_TypeInvs{ $datatype } || 'WVARCHAR';
182
+ }
183
+ if ( $self->get_info( $GetInfoType{ 'SQL_DBMS_NAME' } ) eq 'Microsoft SQL Server' ){
184
+ $map{ 'datetime' } = 'WVARCHAR';
185
+ $map{ 'smalldatetime' } = 'WVARCHAR';
186
+ }
187
+ return %map;
188
+}
189
+
190
+sub prepare_ex
191
+{
192
+ my( $self, $sqlex, $refHash ) = @_;
193
+ my $ret = undef;
194
+ my $validHash = defined( $refHash ) && ref( $refHash ) eq 'HASH';
195
+ if ( $sqlex =~ /\:([\w]+)\+-($_SQL_Types)\b/ ){
196
+ if ( $validHash ){
197
+ $sqlex =~ s/\:([\w]+)\+-($_SQL_Types)\b/_parse_ex1($refHash,$1,$2);/ge;
198
+ } else {
199
+ croak( "prepare_ex need a hash reference when SQL is variable length.\n" );
200
+ }
201
+ }
202
+ @_NamedParams = ();
203
+ $_index = 1;
204
+ $sqlex =~ s/\:([\w]+)(?:\{(\d+)\})?-($_SQL_Types)\b/_parse_ex2($1,$2,$3);/ge;
205
+ if ( $_log ){
206
+ $_log->info( _thisFuncName(), 'sql_raw', "{{$sqlex}}" );
207
+ }
208
+ $ret = $self->prepare( $sqlex ) or croak( "$DBI::errstr" );
209
+ if ( $validHash ){
210
+ $ret->bind_param_ex( $refHash );
211
+ }
212
+ return $ret;
213
+}
214
+
215
+sub _parse_ex1
216
+{
217
+ my( $refHash, $name, $type ) = @_;
218
+ return ":${name}{" . scalar( @{ $refHash->{ $name } } ) . "}-$type";
219
+}
220
+
221
+sub _parse_ex2
222
+{
223
+ my $name = shift || '';
224
+ my $repeat = shift || 0;
225
+ my $type = shift || '';
226
+ my $ret = '';
227
+ # '' や 0 も有効値として使いたい場合 (Perl 5.9 以降)
228
+ # my $param = shift // -1;
229
+ if ( $_log ){
230
+ $_log->info(
231
+ _thisFuncName(),
232
+ "[$_index]",
233
+ "\"$name\"",
234
+ (!$repeat) ? "scalar" : "array[$repeat]",
235
+ $type
236
+ );
237
+ }
238
+ if ( !$repeat ){
239
+ # scalar
240
+ $_NamedParams[ $_index++ ] = {
241
+ Name => $name,
242
+ Type => $_SQL_TypeRefs{ $type },
243
+ Array => -1,
244
+ };
245
+ $ret = '?';
246
+ } else {
247
+ # array
248
+ for( my $i=0; $i<$repeat; ++$i ){
249
+ $_NamedParams[ $_index++ ] = {
250
+ Name => $name,
251
+ Type => $_SQL_TypeRefs{ $type },
252
+ Array => $i,
253
+ };
254
+ }
255
+ $ret = substr( '?,' x $repeat, 0, -1 );
256
+ }
257
+ return $ret;
258
+}
259
+
260
+sub bind_param_ex
261
+{
262
+ no warnings 'uninitialized';
263
+ my( $self, $refHash ) = @_;
264
+ if ( !defined( $refHash ) || ref( $refHash ) ne 'HASH' ){
265
+ croak( "bind_param_ex need a hash reference.\n" );
266
+ }
267
+ my $thisFunc = _thisFuncName();
268
+ for( my $i=1; $i<@_NamedParams; ++$i ){
269
+ my $idx = $_NamedParams[ $i ]{ 'Array' };
270
+ my $value1 = $refHash->{ $_NamedParams[ $i ]{ 'Name' } };
271
+ my $value2 = ( $idx < 0 || ref( $value1 ) ne 'ARRAY' )
272
+ ? $value1
273
+ : @{ $value1 }[ $idx ];
274
+ my $datatype = $_NamedParams[ $i ]{ 'Type' };
275
+ if ( $_log ){
276
+ $_log->info(
277
+ $thisFunc, "[$i]", "\"$value2\"", $_SQL_TypeInvs{ $datatype }
278
+ );
279
+ }
280
+ $self->bind_param( $i, $value2 , { TYPE => $datatype } )
281
+ or croak( "$DBI::errstr\n" );
282
+ }
283
+ return $self;
284
+}
285
+
286
+1;
287
+
288
+# EOF
289
+```
290
+
291
+### testNamedParams_MySQL.pl
292
+```perl
293
+#!/usr/bin/perl
294
+# DBIx::NamedParams のテスト
295
+
296
+use strict;
297
+use warnings;
298
+use utf8;
299
+use Encode;
300
+use YAML::Syck;
301
+use POSIX qw( strftime );
302
+use FindBin::libs;
303
+use lib qw( /home/Shared/lib );
304
+use DBIx::NamedParams;
305
+
306
+( $ENV{'LANG'} || '' ) =~ /\.(.*)$/; # ja_JP.UTF-8
307
+my $charsetConsole = $1 || 'CP932';
308
+my $charsetFile = 'UTF-8';
309
+
310
+binmode( STDIN, ":encoding($charsetConsole)" );
311
+binmode( STDOUT, ":encoding($charsetConsole)" );
312
+binmode( STDERR, ":encoding($charsetConsole)" );
313
+
314
+$YAML::Syck::ImplicitUnicode = 1;
315
+
316
+my $path = $FindBin::RealBin . '/';
317
+my $yaml = $path . 'DB_Connect_MySQL.yml';
318
+my $input = $path . 'InputData.yml';
319
+
320
+my $DB_Info = YAML::Syck::LoadFile( $yaml ) or die( "$yaml: $!\n" );
321
+foreach( keys( %{$DB_Info} ) ){
322
+ $DB_Info->{'DSN'} =~ s/_${_}_/$DB_Info->{$_}/;
323
+}
324
+
325
+my $dbh = DBI->connect(
326
+ 'DBI:' . $DB_Info->{'DSN'},
327
+ $DB_Info->{'User'},
328
+ $DB_Info->{'Password'},
329
+ $DB_Info->{'Options'}
330
+) or die( "$DBI::errstr\n" );
331
+
332
+#DBIx::NamedParams::debug_log( 'testNamedParams.log' );
333
+
334
+#my %DrvTypeToSQLType = $dbh->driver_typename_map();
335
+#print Dump( \%DrvTypeToSQLType );
336
+
337
+my $sql_insert = qq{
338
+ INSERT INTO
339
+ `Users`
340
+ ( `Name`, `Status`, `RegDate` )
341
+ VALUES
342
+ ( :Name-VARCHAR, :State-INTEGER, :Now-DATETIME );
343
+};
344
+
345
+my $sth_insert = $dbh->prepare_ex( $sql_insert ) or die( "$DBI::errstr\n" );
346
+
347
+my $users = YAML::Syck::LoadFile( $input ) or die( "$input: $!\n" );
348
+#print Dump( $users );
349
+#exit;
350
+
351
+foreach( @{$users} ){
352
+ $_->{'Now'} = strftime( "%Y-%m-%d %H:%M:%S", localtime );
353
+ print Dump( $_ );
354
+ $sth_insert->bind_param_ex( $_ );
355
+ $sth_insert->execute() or die( "$DBI::errstr\n" );
356
+ sleep( 1 );
357
+}
358
+$sth_insert->finish;
359
+
360
+my $sql_select = qq{
361
+ SELECT
362
+ `ID`, `Name`, `Status`, `RegDate`
363
+ FROM
364
+ `Users`
365
+ WHERE
366
+ `Status` in ( :State+-INTEGER );
367
+};
368
+
369
+my $sth_select = $dbh->prepare_ex( $sql_select, { 'State' => [ 1,2,5 ] } )
370
+ or die( "$DBI::errstr\n" );
371
+$sth_select->execute() or die( "$DBI::errstr\n" );
372
+do {
373
+ no warnings 'uninitialized';
374
+ while( my @a = $sth_select->fetchrow_array ){
375
+ printf( "%s\n", join( "\t", @a ) );
376
+ }
377
+}while( $sth_select->{odbc_more_results} );
378
+$sth_select->finish;
379
+
380
+$dbh->disconnect;
381
+
382
+exit;
383
+
384
+# EOF
385
+```
386
+
387
+### DB_Connect_MySQL.yml
388
+```
389
+# DB接続情報
390
+Driver: mysql
391
+Server: localhost
392
+Port: 3306
393
+User: TestUser
394
+Password: "Test" # 記号を含む場合は""で括る
395
+DB: TestDB
396
+Options:
397
+ mysql_enable_utf8: 1
398
+DSN: "_Driver_:database=_DB_; host=_Server_; port=_Port_;" # Linux
399
+#DSN: "_Driver_:database=_DB_:host=_Server_" # Windows
400
+```
401
+
402
+### createUsers_MySQL.sql
403
+```sql
404
+SET SQL_MODE="NO_AUTO_VALUE_ON_ZERO";
405
+
406
+CREATE TABLE `Users` (
407
+ `ID` int(11) NOT NULL AUTO_INCREMENT,
408
+ `Name` varchar(40) NOT NULL,
409
+ `Status` int(11) NOT NULL DEFAULT '0',
410
+ `RegDate` timestamp NOT NULL DEFAULT CURRENT_TIMESTAMP,
411
+ PRIMARY KEY (`ID`)
412
+) ENGINE=MyISAM DEFAULT CHARSET=utf8 AUTO_INCREMENT=1 ;
413
+```
414
+
415
+### InputData.yml (MySQL/MSSQL 共通)
416
+```
417
+---
418
+- { Name: リオ, State: 1 }
419
+- { Name: ミント, State: 2 }
420
+- { Name: ローザ, State: 3 }
421
+- { Name: リンダ, State: 4 }
422
+- { Name: リナ, State: 5 }
423
+- { Name: アーニャ, State: 6 }
424
+```
425
+
426
+### testNamedParams_MSSQL.pl
427
+```perl
428
+#!/usr/bin/perl
429
+# DBIx::NamedParams のテスト
430
+
431
+use strict;
432
+use warnings;
433
+use utf8;
434
+use Encode;
435
+use YAML::Syck;
436
+use POSIX qw( strftime );
437
+use FindBin::libs;
438
+use lib qw( /home/Shared/lib );
439
+use DBIx::NamedParams;
440
+
441
+( $ENV{'LANG'} || '' ) =~ /\.(.*)$/; # ja_JP.UTF-8
442
+my $charsetConsole = $1 || 'CP932';
443
+my $charsetFile = 'UTF-8';
444
+
445
+binmode( STDIN, ":encoding($charsetConsole)" );
446
+binmode( STDOUT, ":encoding($charsetConsole)" );
447
+binmode( STDERR, ":encoding($charsetConsole)" );
448
+
449
+$YAML::Syck::ImplicitUnicode = 1;
450
+
451
+my $path = $FindBin::RealBin . '/';
452
+my $yaml = $path . 'DB_Connect_MSSQL.yml';
453
+my $input = $path . 'InputData.yml';
454
+
455
+my $DB_Info = YAML::Syck::LoadFile( $yaml ) or die( "$yaml: $!\n" );
456
+foreach( keys( %{$DB_Info} ) ){
457
+ $DB_Info->{'DSN'} =~ s/_${_}_/$DB_Info->{$_}/;
458
+}
459
+
460
+my $dbh = DBI->connect(
461
+ 'DBI:' . $DB_Info->{'DSN'},
462
+ $DB_Info->{'User'},
463
+ $DB_Info->{'Password'},
464
+ $DB_Info->{'Options'}
465
+) or die( "$DBI::errstr\n" );
466
+
467
+#DBIx::NamedParams::debug_log( 'testNamedParams.log' );
468
+
469
+#my %DrvTypeToSQLType = $dbh->driver_typename_map();
470
+#print Dump( \%DrvTypeToSQLType );
471
+
472
+my $sql_insert = qq{
473
+ INSERT INTO
474
+ [Users]
475
+ ( [Name], [Status], [RegDate] )
476
+ VALUES
477
+ ( :Name-WVARCHAR, :State-INTEGER, :Now-WVARCHAR );
478
+};
479
+
480
+my $sth_insert = $dbh->prepare_ex( $sql_insert ) or die( "$DBI::errstr\n" );
481
+
482
+my $users = YAML::Syck::LoadFile( $input ) or die( "$input: $!\n" );
483
+#print Dump( $users );
484
+#exit;
485
+
486
+foreach( @{$users} ){
487
+ $_->{'Now'} = strftime( "%Y-%m-%d %H:%M:%S", localtime );
488
+ print Dump( $_ );
489
+ $sth_insert->bind_param_ex( $_ );
490
+ $sth_insert->execute() or die( "$DBI::errstr\n" );
491
+ sleep( 1 );
492
+}
493
+$sth_insert->finish;
494
+
495
+my $sql_select = qq{
496
+ SELECT
497
+ [ID], [Name], [Status], [RegDate]
498
+ FROM
499
+ [Users]
500
+ WHERE
501
+ [Status] in ( :State+-INTEGER );
502
+};
503
+
504
+my $sth_select = $dbh->prepare_ex( $sql_select, { 'State' => [ 1,2,5 ] } )
505
+ or die( "$DBI::errstr\n" );
506
+$sth_select->execute() or die( "$DBI::errstr\n" );
507
+do {
508
+ no warnings 'uninitialized';
509
+ while( my @a = $sth_select->fetchrow_array ){
510
+ printf( "%s\n", join( "\t", @a ) );
511
+ }
512
+}while( $sth_select->{odbc_more_results} );
513
+$sth_select->finish;
514
+
515
+$dbh->disconnect;
516
+
517
+exit;
518
+
519
+# EOF
520
+```
521
+
522
+### DB_Connect_MSSQL.yml
523
+```
524
+# DB接続情報
525
+Driver: ODBC
526
+Server: localhost\SQLExress,1433 # <サーバ名>\<インスタンス名>[,<ポート>]
527
+User: TestUser
528
+Password: "Test" # 記号を含む場合は""で括る
529
+DB: TestDB
530
+Options:
531
+ LongTruncOk: 1
532
+ LongReadLen: 8192
533
+DSN: _Driver_:Driver={SQL Server}; Server={_Server_}; Database=_DB_;
534
+```
535
+
536
+### createUsers_MSSQL.sql
537
+```sql
538
+USE [TestDB]
539
+GO
540
+
541
+SET ANSI_NULLS ON
542
+GO
543
+
544
+SET QUOTED_IDENTIFIER ON
545
+GO
546
+
547
+CREATE TABLE [dbo].[Users](
548
+ [ID] [int] IDENTITY(1,1) NOT NULL,
549
+ [Name] [nvarchar](40) NOT NULL,
550
+ [Status] [int] NOT NULL,
551
+ [RegDate] [datetime] NULL,
552
+ CONSTRAINT [PK_Users] PRIMARY KEY CLUSTERED
553
+ (
554
+ [ID] ASC
555
+ ) WITH (
556
+ PAD_INDEX = OFF,
557
+ STATISTICS_NORECOMPUTE = OFF,
558
+ IGNORE_DUP_KEY = OFF,
559
+ ALLOW_ROW_LOCKS = ON,
560
+ ALLOW_PAGE_LOCKS = ON
561
+ ) ON [PRIMARY]
562
+) ON [PRIMARY]
563
+GO
564
+
565
+ALTER TABLE [dbo].[Users]
566
+ADD CONSTRAINT [DF_Users_RegDate]
567
+DEFAULT (getdate()) FOR [RegDate]
568
+GO
569
+```
570
+
571
+## SQLTypes
572
+### getSQLTypes.pl
573
+```perl
574
+# SQLタイプ一覧
575
+
576
+use strict;
577
+use warnings;
578
+use utf8;
579
+use Encode;
580
+use POSIX qw( strftime );
581
+use FindBin::libs;
582
+use lib qw( /home/Shared/lib );
583
+use DBIx::NamedParams;
584
+
585
+print "Perl version: " . $] . "\n";
586
+print "DBI version: " . $DBI::VERSION . "\n";
587
+print strftime( "%Y-%m-%d %H:%M:%S\n\n", localtime );
588
+print join( "\n", DBIx::NamedParams::all_sql_types() ) . "\n";
589
+
590
+# EOF
591
+```
592
+
593
+### 出力
594
+```
595
+Perl version: 5.010001
596
+DBI version: 1.616
597
+2011-06-17 00:37:32
598
+
599
+ALL_TYPES
600
+ARRAY
601
+ARRAY_LOCATOR
602
+BIGINT
603
+BINARY
604
+BIT
605
+BLOB
606
+BLOB_LOCATOR
607
+BOOLEAN
608
+CHAR
609
+CLOB
610
+CLOB_LOCATOR
611
+DATE
612
+DATETIME
613
+DECIMAL
614
+DOUBLE
615
+FLOAT
616
+GUID
617
+INTEGER
618
+INTERVAL
619
+INTERVAL_DAY
620
+INTERVAL_DAY_TO_HOUR
621
+INTERVAL_DAY_TO_MINUTE
622
+INTERVAL_DAY_TO_SECOND
623
+INTERVAL_HOUR
624
+INTERVAL_HOUR_TO_MINUTE
625
+INTERVAL_HOUR_TO_SECOND
626
+INTERVAL_MINUTE
627
+INTERVAL_MINUTE_TO_SECOND
628
+INTERVAL_MONTH
629
+INTERVAL_SECOND
630
+INTERVAL_YEAR
631
+INTERVAL_YEAR_TO_MONTH
632
+LONGVARBINARY
633
+LONGVARCHAR
634
+MULTISET
635
+MULTISET_LOCATOR
636
+NUMERIC
637
+REAL
638
+REF
639
+ROW
640
+SMALLINT
641
+TIME
642
+TIMESTAMP
643
+TINYINT
644
+TYPE_DATE
645
+TYPE_TIME
646
+TYPE_TIMESTAMP
647
+TYPE_TIMESTAMP_WITH_TIMEZONE
648
+TYPE_TIME_WITH_TIMEZONE
649
+UDT
650
+UDT_LOCATOR
651
+UNKNOWN_TYPE
652
+VARBINARY
653
+VARCHAR
654
+WCHAR
655
+WLONGVARCHAR
656
+WVARCHAR
657
+```
658
+
659
+## MySQLのデータタイプ
660
+```
661
+---
662
+bigint: BIGINT
663
+bigint auto_increment: BIGINT
664
+bigint unsigned: BIGINT
665
+bigint unsigned auto_increment: BIGINT
666
+bit: BIT
667
+bit auto_increment: BIT
668
+blob: LONGVARBINARY
669
+char: CHAR
670
+date: DATE
671
+datetime: TIMESTAMP
672
+decimal: NUMERIC
673
+double: DOUBLE
674
+double auto_increment: DOUBLE
675
+enum: ALL_TYPES
676
+float: FLOAT
677
+float auto_increment: FLOAT
678
+int: INTEGER
679
+int auto_increment: INTEGER
680
+int unsigned: INTEGER
681
+int unsigned auto_increment: INTEGER
682
+integer: INTEGER
683
+integer auto_increment: INTEGER
684
+integer unsigned: INTEGER
685
+integer unsigned auto_increment: INTEGER
686
+long varbinary: LONGVARBINARY
687
+long varchar: LONGVARCHAR
688
+longblob: LONGVARBINARY
689
+mediumblob: LONGVARBINARY
690
+mediumint: INTEGER
691
+mediumint auto_increment: INTEGER
692
+mediumint unsigned: INTEGER
693
+mediumint unsigned auto_increment: INTEGER
694
+mediumtext: LONGVARCHAR
695
+numeric: NUMERIC
696
+set: ALL_TYPES
697
+smallint: SMALLINT
698
+smallint auto_increment: SMALLINT
699
+smallint unsigned: SMALLINT
700
+smallint unsigned auto_increment: SMALLINT
701
+text: LONGVARCHAR
702
+time: TIME
703
+timestamp: TIMESTAMP
704
+tinyblob: VARBINARY
705
+tinyint: TINYINT
706
+tinyint auto_increment: TINYINT
707
+tinyint unsigned: TINYINT
708
+tinyint unsigned auto_increment: TINYINT
709
+varchar: VARCHAR
710
+year: SMALLINT
711
+```
712
+
713
+## MS SQL Server のデータタイプ
714
+```
715
+---
716
+bigint: BIGINT
717
+bigint identity: BIGINT
718
+binary: BINARY
719
+bit: BIT
720
+char: CHAR
721
+date: WVARCHAR
722
+datetime: WVARCHAR
723
+datetime2: WVARCHAR
724
+datetimeoffset: WVARCHAR
725
+decimal: DECIMAL
726
+decimal() identity: DECIMAL
727
+float: FLOAT
728
+image: LONGVARBINARY
729
+int: INTEGER
730
+int identity: INTEGER
731
+money: DECIMAL
732
+nchar: WCHAR
733
+ntext: WLONGVARCHAR
734
+numeric: NUMERIC
735
+numeric() identity: NUMERIC
736
+nvarchar: WVARCHAR
737
+real: REAL
738
+smalldatetime: WVARCHAR
739
+smallint: SMALLINT
740
+smallint identity: SMALLINT
741
+smallmoney: DECIMAL
742
+sql_variant: WVARCHAR
743
+sysname: WVARCHAR
744
+text: LONGVARCHAR
745
+time: WVARCHAR
746
+timestamp: BINARY
747
+tinyint: TINYINT
748
+tinyint identity: TINYINT
749
+uniqueidentifier: GUID
750
+varbinary: VARBINARY
751
+varchar: VARCHAR
752
+xml: WLONGVARCHAR
753
+```
754
+
755
+## リンク
756
+- [[DBIx::Custom|Perl/DBIx-Custom]]
757
+
758
+- [安全なウェブサイトの作り方](http://www.ipa.go.jp/security/vuln/websecurity.html) 安全なSQLの呼び出し方
759
+
760
+- http://perldoc.jp/
761
+ - [perlobj - Perl のオブジェクト](http://perldoc.jp/docs/perl/5.10.0/perlobj.pod)
762
+ - [perlmod - Perl のモジュール (パッケージとシンボルテーブル)](http://perldoc.jp/docs/perl/5.10.0/perlmod.pod)
763
+
764
+- [ダウンロードたけし(寅年)の日記](http://d.hatena.ne.jp/download_takeshi/)
765
+ - [DBIでbindした後のSQL文を引っ張り出す方法](http://d.hatena.ne.jp/download_takeshi/20081209/1228837813)
766
+ - [DBI/Executed.pm](http://coderepos.org/share/browser/lang/perl/DBI-Executed/trunk/lib/DBI/Executed.pm)
767
+
768
+- [ブログが続かないわけ](http://en.yummy.stripper.jp/)
769
+ - [[Perl][微エロ注意]画像収集のときにいつも同じイディオムを書いているのをやめたい](http://en.yummy.stripper.jp/?eid=1159981)
770
+
771
+- [404 Blog Not Found](http://blog.livedoor.jp/dankogai/)
772
+ - [perl - use Carp; # warn() と die() だけじゃなくて](http://blog.livedoor.jp/dankogai/archives/51073468.html)
773
+ - [perl - no warnings 'unintialized'](http://blog.livedoor.jp/dankogai/archives/50622749.html)
774
+ - [perl - デフォルト値のperlらしい指定法](http://blog.livedoor.jp/dankogai/archives/51074877.html)
775
+ - [perl - 継承を使いたいワケ](http://blog.livedoor.jp/dankogai/archives/50706327.html)
776
+
777
+- [サンプルコードによるPerl入門](http://d.hatena.ne.jp/perlcodesample/)
778
+ - [Exporter - 関数のエクスポート / Perlモジュール徹底解説](http://d.hatena.ne.jp/perlcodesample/20100426/1270894115)
779
+ - [柔軟なSQL / DBIx::Customの特徴](http://d.hatena.ne.jp/perlcodesample/20110118/1300165343)
780
+ - [DBIx::Connectorを利用する / DBIx::Custom Tips](http://d.hatena.ne.jp/perlcodesample/20110123/1300165343)
781
+ - [DBIx::Connectorによるトランザクション処理 / DBIx::Custom Tips](http://d.hatena.ne.jp/perlcodesample/20110125/1300165343)
782
+ - [行の挿入 insert / DBIx::Custom Tips](http://d.hatena.ne.jp/perlcodesample/20110129/1300165343)
783
+ - [行の更新 update / DBIx::Custom Tips](http://d.hatena.ne.jp/perlcodesample/20110130/1300165343)
784
+ - [DBIx::Customの紹介(1) - モデル](http://d.hatena.ne.jp/perlcodesample/20110131/1300165343)
785
+ - [すべての行の更新 update_all / DBIx::Custom Tips](http://d.hatena.ne.jp/perlcodesample/20110201/1300165343)
786
+ - [行の削除 delete / DBIx::Custom Tips](http://d.hatena.ne.jp/perlcodesample/20110202/1300165343)
787
+ - [すべての行の削除 delete_all / DBIx::Custom Tips](http://d.hatena.ne.jp/perlcodesample/20110203/1300165343)
788
+ - [Where句で日付の範囲を指定する / DBIx::Custom Tips](http://d.hatena.ne.jp/perlcodesample/20110204/1300165343)
789
+ - [予約語を使用している列やテーブルに対応する / DBIx::Custom Tips](http://d.hatena.ne.jp/perlcodesample/20110207/1300165343)
790
+ - [DBIx::Customの特徴(2) SQLの知識がそのまま利用できる](http://d.hatena.ne.jp/perlcodesample/20110208/1300165343)
791
+
792
+- [Islands in the byte stream](http://d.hatena.ne.jp/gfx/)
793
+ - [Don't use base.pm, use parent.pm instead!](http://d.hatena.ne.jp/gfx/20101226/1293342019)
794
+
795
+- [Perl-users.jp](http://perl-users.jp/)
796
+ - [Perl 5 今昔](http://perl-users.jp/nowpast.html)
797
+ - [使っちゃいけない標準モジュール - JPerl advent calendar 2010 casual Track](http://perl-users.jp/articles/advent-calendar/2010/casual/23)
798
+
799
+- [Part1 正しいPerl/CGIの書き方 - Webプログラミング実力アップ:ITpro](http://itpro.nikkeibp.co.jp/article/COLUMN/20071011/284280/) Module::Starter::PBP によるモジュール開発例
800
+
801
+- [楽:技林ブログ](http://tech.bayashi.jp/)
802
+ - [はじめてのPerlモジュール開発メモ/楽](http://tech.bayashi.jp/archives/entry/perl/2008/002326.html)
803
+
804
+- [個人的なメモのページ](http://www12.atpages.jp/~lottz/pukiwikiplus/)
805
+ - [Perl_Modules](http://www12.atpages.jp/~lottz/pukiwikiplus/index.php?Perl_Modules)
806
+
807
+- [CPAN:DBI](http://search.cpan.org/dist/DBI)
808
+- [CPAN:DBD-mysql](http://search.cpan.org/dist/DBD-mysql)
809
+- [CPAN:DBD-ODBC](http://search.cpan.org/dist/DBD-ODBC)
810
+
811
+- [CPAN:DBIx-Custom](http://search.cpan.org/dist/DBIx-Custom)
812
+ - [CPAN:DBIx-Custom/lib/DBIx/Custom/Guide/Ja.pod](http://search.cpan.org/dist/DBIx-Custom/lib/DBIx/Custom/Guide/Ja.pod)
813
+ - [DBIx::Custom Wiki - GitHub](https://github.com/yuki-kimoto/DBIx-Custom/wiki)
814
+- [CPAN:DBIx-NamedBinding](http://search.cpan.org/dist/DBIx-NamedBinding)
815
+- [CPAN:DBIx-Simple](http://search.cpan.org/dist/DBIx-Simple)
816
+- [CPAN:DBIx-InsertHash](http://search.cpan.org/dist/DBIx-InsertHash)
817
+
818
+- [CPAN:perl/lib/Carp.pm](http://search.cpan.org/dist/perl/lib/Carp.pm)
819
+- [CPAN:parent](http://search.cpan.org/dist/parent)
820
+- [CPAN:base](http://search.cpan.org/dist/base)
821
+- [CPAN:Log-Dispatch](http://search.cpan.org/dist/Log-Dispatch)
822
+
823
+- [CPAN:perl](http://search.cpan.org/dist/perl) POSIX strftime
824
+
825
+- [CPAN:FindBin-libs](http://search.cpan.org/dist/FindBin-libs)
0 826
\ No newline at end of file
1 827
diff --git "a/Perl/EPS\343\203\225\343\202\241\343\202\244\343\203\253\344\275\234\346\210\220/Home.md" "b/Perl/EPS\343\203\225\343\202\241\343\202\244\343\203\253\344\275\234\346\210\220/Home.md"
2 828
new file mode 100644
3 829
index 0000000..6ce7d84
4
--- /dev/null
830
+++ "b/Perl/EPS\343\203\225\343\202\241\343\202\244\343\203\253\344\275\234\346\210\220/Home.md"
... ...
@@ -0,0 +1,24 @@
1
+# EPSファイル作成
2
+[[_TOC_]]
3
+~~#ls2~~
4
+----
5
+## 幾何学図形と文字
6
+### 概要
7
+- 使用しているフォントは「小塚明朝 Std - M」。
8
+- EPS中で「Shift_JIS」で指定する場合は「KozMinStd-Medium-90ms-RKSJ-H」と記述する。(横書き)
9
+- 画像の埋め込みは行っていない。
10
+
11
+### ダウンロード
12
+- ソースコードと出力されるEPSファイル<br />
13
+[createEPS.zip](createEPS.zip)
14
+- EPSファイルをAcrobat Distiller 6でPDFに変換したもの<br />
15
+[ToneChart.pdf](ToneChart.pdf)
16
+
17
+## リンク
18
+- [[Typography_PDF|etc/Typography_PDF]]
19
+- [[文字コード|Perl/文字コード]]
20
+
21
+- [CPAN:PostScript-Simple](http://search.cpan.org/dist/PostScript-Simple)
22
+- [CPAN:Font-TTF](http://search.cpan.org/dist/Font-TTF) / [Manual](http://search.cpan.org/dist/Font-TTF/lib/Font/TTF/Manual.pod)
23
+
24
+- [中島 靖](http://hp1.jonex.ne.jp/~nakajima.yasushi/) / [PDFJ - 日本語PDF生成モジュール](http://hp1.jonex.ne.jp/~nakajima.yasushi/PDFJ.jp.html)
0 25
\ No newline at end of file
1 26
diff --git "a/Perl/EPS\343\203\225\343\202\241\343\202\244\343\203\253\344\275\234\346\210\220/SimpleEPS.md" "b/Perl/EPS\343\203\225\343\202\241\343\202\244\343\203\253\344\275\234\346\210\220/SimpleEPS.md"
2 27
new file mode 100644
3 28
index 0000000..7d58bdf
4
--- /dev/null
29
+++ "b/Perl/EPS\343\203\225\343\202\241\343\202\244\343\203\253\344\275\234\346\210\220/SimpleEPS.md"
... ...
@@ -0,0 +1,41 @@
1
+[[_TOC_]]
2
+
3
+# 概要
4
+- 単純なEPSの例。
5
+- ドキュメントサイズ: 200 x 200pt (70.6 x 70.6 mm)
6
+- 背景: M20%
7
+- 文字: 小塚明朝Pro Regular, 36pt
8
+- 文字コード: UTF-8, BOM無し (BOMを付けるとDistillerでエラーとなる)
9
+- 改行コード: CRLF
10
+
11
+# ソース
12
+- [Simple.zip](Simple.zip)
13
+```
14
+%!PS-Adobe-3.0 EPSF-3.0
15
+%%BoundingBox: 0 0 200 200
16
+%%EndComments
17
+
18
+%%BeginProlog
19
+%%EndProlog
20
+
21
+%%Page: 1 1
22
+
23
+% Frame
24
+0 0 moveto
25
+0 200 lineto
26
+200 200 lineto
27
+200 0 lineto
28
+0 0.2 0 0 setcmykcolor
29
+fill
30
+
31
+% Font
32
+/KozMinPro-Regular-UniJIS-UTF8-H findfont 18 scalefont setfont
33
+0 0 0 1 setcmykcolor
34
+
35
+% String
36
+27 90 moveto
37
+(ポストスクリプト) show
38
+
39
+showpage
40
+
41
+% EOF
0 42
\ No newline at end of file
1 43
diff --git "a/Perl/EPS\343\203\225\343\202\241\343\202\244\343\203\253\344\275\234\346\210\220/V\345\234\247\347\235\200\350\221\211\346\233\270\343\203\206\343\203\263\343\203\227\343\203\254\343\203\274\343\203\210.md" "b/Perl/EPS\343\203\225\343\202\241\343\202\244\343\203\253\344\275\234\346\210\220/V\345\234\247\347\235\200\350\221\211\346\233\270\343\203\206\343\203\263\343\203\227\343\203\254\343\203\274\343\203\210.md"
2 44
new file mode 100644
3 45
index 0000000..0b8b6f4
4
--- /dev/null
46
+++ "b/Perl/EPS\343\203\225\343\202\241\343\202\244\343\203\253\344\275\234\346\210\220/V\345\234\247\347\235\200\350\221\211\346\233\270\343\203\206\343\203\263\343\203\227\343\203\254\343\203\274\343\203\210.md"
... ...
@@ -0,0 +1,225 @@
1
+~~#navi(Perl/EPSファイル作成)~~
2
+[[_TOC_]]
3
+# V圧着葉書テンプレート
4
+## 概要
5
+- V圧着葉書をデザインする際のテンプレート。
6
+- Perl使っていない素のEPSファイルだけど、関連ってことで。
7
+
8
+## 中面
9
+```
10
+%!PS-Adobe-3.0 EPSF-3.0
11
+%%BoundingBox: 0 0 841.89 595.28
12
+
13
+% V圧着葉書テンプレート (中面)
14
+
15
+% mm -> point 換算係数
16
+/mm2point 72 25.4 div def
17
+
18
+/width 297 mm2point mul def
19
+/height 210 mm2point mul def
20
+
21
+/x0 297 mm2point mul def
22
+/y0 210 mm2point mul def
23
+
24
+/x1 27 mm2point mul def
25
+/x2 47 mm2point mul def
26
+/x3 50 mm2point mul def
27
+/x4 56 mm2point mul def
28
+/x5 150 mm2point mul def
29
+/x6 245 mm2point mul def
30
+/x7 248 mm2point mul def
31
+/x8 268 mm2point mul def
32
+
33
+/y1 7 mm2point mul neg y0 add def
34
+/y2 27 mm2point mul neg y0 add def
35
+/y3 30 mm2point mul neg y0 add def
36
+/y4 175 mm2point mul neg y0 add def
37
+/y5 178 mm2point mul neg y0 add def
38
+/y6 198 mm2point mul neg y0 add def
39
+
40
+/tx 55 mm2point mul def
41
+/ty 20 mm2point mul neg y0 add def
42
+
43
+0.3 setlinewidth
44
+
45
+% 全体枠
46
+0 0 moveto
47
+0 height lineto
48
+width height lineto
49
+width 0 lineto
50
+closepath
51
+0 0 0 1 setcmykcolor
52
+stroke
53
+
54
+%タイトル
55
+/KozGoPro-Medium-UniJIS-UTF8-H findfont 14 scalefont setfont
56
+tx ty moveto
57
+0 0 0 1 setcmykcolor
58
+(V圧着葉書テンプレート (中面)) show
59
+
60
+% 断ち落とし込みの領域
61
+x2 y2 moveto x7 y2 lineto x7 y5 lineto x2 y5 lineto
62
+closepath
63
+1 0 0 0 setcmykcolor
64
+stroke
65
+
66
+% 断裁後の領域
67
+x3 y3 moveto x6 y3 lineto x6 y4 lineto x3 y4 lineto
68
+closepath
69
+1 0 0 0 setcmykcolor
70
+stroke
71
+
72
+% トンボ
73
+x2 y1 moveto x2 y3 lineto x1 y3 lineto
74
+x3 y1 moveto x3 y2 lineto x1 y2 lineto
75
+x6 y1 moveto x6 y2 lineto x8 y2 lineto
76
+x7 y1 moveto x7 y3 lineto x8 y3 lineto
77
+x1 y4 moveto x2 y4 lineto x2 y6 lineto
78
+x1 y5 moveto x3 y5 lineto x3 y6 lineto
79
+x6 y6 moveto x6 y5 lineto x8 y5 lineto
80
+x7 y6 moveto x7 y4 lineto x8 y4 lineto
81
+x5 y1 moveto x5 y2 lineto
82
+x5 y5 moveto x5 y6 lineto
83
+0 0 0 1 setcmykcolor
84
+stroke
85
+
86
+% 剥がししろ
87
+x2 y2 moveto x4 y2 lineto x4 y5 lineto x2 y5 lineto
88
+1 0.8 0 0 setcmykcolor
89
+fill
90
+
91
+showpage
92
+
93
+% EOF
94
+```
95
+
96
+## 宛名面
97
+```
98
+%!PS-Adobe-3.0 EPSF-3.0
99
+%%BoundingBox: 0 0 841.89 595.28
100
+
101
+% V圧着葉書テンプレート (宛名面)
102
+
103
+% mm -> point 換算係数
104
+/mm2point 72 25.4 div def
105
+
106
+/width 297 mm2point mul def
107
+/height 210 mm2point mul def
108
+
109
+/x0 297 mm2point mul def
110
+/y0 210 mm2point mul def
111
+
112
+/x1 27 mm2point mul neg x0 add def
113
+/x2 47 mm2point mul neg x0 add def
114
+/x3 50 mm2point mul neg x0 add def
115
+/x4 150 mm2point mul neg x0 add def
116
+/x5 245 mm2point mul neg x0 add def
117
+/x6 248 mm2point mul neg x0 add def
118
+/x7 268 mm2point mul neg x0 add def
119
+
120
+/y1 7 mm2point mul neg y0 add def
121
+/y2 27 mm2point mul neg y0 add def
122
+/y3 30 mm2point mul neg y0 add def
123
+/y4 175 mm2point mul neg y0 add def
124
+/y5 178 mm2point mul neg y0 add def
125
+/y6 198 mm2point mul neg y0 add def
126
+
127
+/tx 55 mm2point mul def
128
+/ty 20 mm2point mul neg y0 add def
129
+
130
+/bx1 48.1 8 add mm2point mul neg x4 add def
131
+/bx2 7.0 mm2point mul bx1 add def
132
+/bx3 14.0 mm2point mul bx1 add def
133
+/bx4 21.7 mm2point mul bx1 add def
134
+/bx5 28.5 mm2point mul bx1 add def
135
+/bx6 35.3 mm2point mul bx1 add def
136
+/bx7 42.1 mm2point mul bx1 add def
137
+/bx8 20.2 mm2point mul bx1 add def
138
+/by1 11.8 mm2point mul neg y3 add def
139
+/by2 15.8 mm2point mul neg y3 add def
140
+
141
+/bw 6.1 mm2point mul def
142
+/bh 8.4 mm2point mul neg def
143
+
144
+/drawBox {
145
+ 2 dict begin
146
+ /yy exch def
147
+ /xx exch def
148
+ xx yy moveto
149
+ bw 0 rlineto
150
+ 0 bh rlineto
151
+ bw neg 0 rlineto
152
+ closepath
153
+ stroke
154
+ end
155
+} def
156
+
157
+0.3 setlinewidth
158
+
159
+% 全体枠
160
+0 0 moveto
161
+0 height lineto
162
+width height lineto
163
+width 0 lineto
164
+closepath
165
+0 0 0 1 setcmykcolor
166
+stroke
167
+
168
+%タイトル
169
+/KozGoPro-Medium-UniJIS-UTF8-H findfont 14 scalefont setfont
170
+tx ty moveto
171
+0 0 0 1 setcmykcolor
172
+(V圧着葉書テンプレート (宛名面)) show
173
+
174
+% 断ち落とし込みの領域
175
+x2 y2 moveto x6 y2 lineto x6 y5 lineto x2 y5 lineto
176
+closepath
177
+1 0 0 0 setcmykcolor
178
+stroke
179
+
180
+% 断裁後の領域
181
+x3 y3 moveto x5 y3 lineto x5 y4 lineto x3 y4 lineto
182
+closepath
183
+1 0 0 0 setcmykcolor
184
+stroke
185
+
186
+% トンボ
187
+x2 y1 moveto x2 y3 lineto x1 y3 lineto
188
+x3 y1 moveto x3 y2 lineto x1 y2 lineto
189
+x5 y1 moveto x5 y2 lineto x7 y2 lineto
190
+x6 y1 moveto x6 y3 lineto x7 y3 lineto
191
+x1 y4 moveto x2 y4 lineto x2 y6 lineto
192
+x1 y5 moveto x3 y5 lineto x3 y6 lineto
193
+x5 y6 moveto x5 y5 lineto x7 y5 lineto
194
+x6 y6 moveto x6 y4 lineto x7 y4 lineto
195
+x4 y1 moveto x4 y2 lineto
196
+x4 y5 moveto x4 y6 lineto
197
+0 0 0 1 setcmykcolor
198
+stroke
199
+
200
+% 郵便番号枠
201
+0 1 1 0 setcmykcolor
202
+
203
+0.5 mm2point mul setlinewidth
204
+bx1 by1 drawBox
205
+bx2 by1 drawBox
206
+bx3 by1 drawBox
207
+0.3 mm2point mul setlinewidth
208
+bx4 by1 drawBox
209
+bx5 by1 drawBox
210
+bx6 by1 drawBox
211
+bx7 by1 drawBox
212
+0.5 mm2point mul setlinewidth
213
+bx8 by2 moveto bx4 by2 lineto
214
+stroke
215
+
216
+showpage
217
+
218
+% EOF
219
+```
220
+
221
+## ダウンロード
222
+- EPSファイルとそれをAcrobat Distiller 6でPDFに変換したもの<br />
223
+[VAH.zip](VAH.zip)
224
+
225
+~~#navi(Perl/EPSファイル作成)~~
0 226
\ No newline at end of file
1 227
diff --git "a/Perl/EPS\343\203\225\343\202\241\343\202\244\343\203\253\344\275\234\346\210\220/\343\202\250\343\203\263\343\202\263\343\203\274\343\203\207\343\202\243\343\203\263\343\202\260.md" "b/Perl/EPS\343\203\225\343\202\241\343\202\244\343\203\253\344\275\234\346\210\220/\343\202\250\343\203\263\343\202\263\343\203\274\343\203\207\343\202\243\343\203\263\343\202\260.md"
2 228
new file mode 100644
3 229
index 0000000..d6ba5c2
4
--- /dev/null
230
+++ "b/Perl/EPS\343\203\225\343\202\241\343\202\244\343\203\253\344\275\234\346\210\220/\343\202\250\343\203\263\343\202\263\343\203\274\343\203\207\343\202\243\343\203\263\343\202\260.md"
... ...
@@ -0,0 +1,144 @@
1
+~~#navi(Perl/EPSファイル作成)~~
2
+[[_TOC_]]
3
+# エンコーディングと文字列の原点
4
+## 概要
5
+- 使用しているフォントは「小塚ゴシック Pro - M」。
6
+- EPS中で「Unicode(UTF8)」で指定する場合は「KozGoPro-Medium-UniJIS-UTF8-H」と記述する。(横書き)
7
+- EPS中で「Unicode(UCS2)」で指定する場合は「KozGoPro-Medium-UniJIS-UCS2-H」と記述する。(横書き)
8
+- EPS中で「Unicode(UTF8)」で指定する場合は「KozGoPro-Medium-UniJIS-UTF8-V」と記述する。(縦書き)
9
+- EPS中で「Unicode(UCS2)」で指定する場合は「KozGoPro-Medium-UniJIS-UCS2-V」と記述する。(縦書き)
10
+
11
+## ソースコード
12
+```
13
+# EPS作成
14
+# テキストの配置
15
+# このソースは UTF8N, LF で保存すること
16
+
17
+use strict;
18
+use utf8;
19
+use Encode qw/encode decode/;
20
+
21
+my $eps_file = 'GA2.eps';
22
+my $mm2point = 72 / 25.4;
23
+
24
+# A4サイズ
25
+my $width = sprintf( "%.2f", 210 * $mm2point );
26
+my $height = sprintf( "%.2f", 297 * $mm2point );
27
+
28
+my $String = "ギャラクシーエンジェる〜ん Oct 2006";
29
+my $String_ucs2 = &str_to_ucs2( $String );
30
+my $String_utf8 = &str_to_utf8( $String );
31
+my $StringFontSize = 24;
32
+
33
+my $x1 = 4 * $StringFontSize;
34
+my $y1 = $height - 4 * $StringFontSize;
35
+
36
+my $x2 = $x1;
37
+my $y2 = $height - 6 * $StringFontSize;
38
+
39
+my $x3 = $x1;
40
+my $y3 = $height - 8 * $StringFontSize;
41
+
42
+my $x4 = 9 * $StringFontSize;
43
+my $y4 = $height - 11 * $StringFontSize;
44
+
45
+my $x5 = 13 * $StringFontSize;
46
+my $y5 = $y4;
47
+
48
+my $x6 = 17 * $StringFontSize;
49
+my $y6 = $y4;
50
+
51
+my $eps = '';
52
+
53
+$eps .=<<EOL;
54
+%!PS-Adobe-3.0 EPSF-3.0
55
+%%BoundingBox: 0 0 $width $height
56
+
57
+/putText {
58
+ 4 dict begin
59
+ /str exch def
60
+ /encode exch def
61
+ /ty exch def
62
+ /tx exch def
63
+ 0 1 1 0 setcmykcolor
64
+ tx ty moveto
65
+ tx ty 2 0 360 arc
66
+ fill
67
+ 0 0 0 1 setcmykcolor
68
+ encode findfont $StringFontSize scalefont setfont
69
+ tx ty moveto
70
+ str show
71
+ end
72
+} def
73
+
74
+% 全体枠
75
+0 0 moveto
76
+0 $height lineto
77
+$width $height lineto
78
+$width 0 lineto
79
+closepath
80
+1 setlinewidth
81
+0 0 0 1 setcmykcolor
82
+stroke
83
+
84
+% 小塚ゴシック Pro - M
85
+$x1 $y1 /KozGoPro-Medium-UniJIS-UTF8-H <$String_utf8> putText
86
+$x2 $y2 /KozGoPro-Medium-UniJIS-UCS2-H <$String_ucs2> putText
87
+$x3 $y3 /KozGoPro-Medium-UniJIS-UCS2-HW-H <$String_ucs2> putText
88
+$x4 $y4 /KozGoPro-Medium-UniJIS-UTF8-V <$String_utf8> putText
89
+$x5 $y5 /KozGoPro-Medium-UniJIS-UCS2-V <$String_ucs2> putText
90
+$x6 $y6 /KozGoPro-Medium-UniJIS-UCS2-HW-V <$String_ucs2> putText
91
+
92
+showpage
93
+EOL
94
+
95
+open( OUT, ">:encoding(utf8)", $eps_file ) || die( "can't open '" . $eps_file . "'.\n" );
96
+print OUT $eps;
97
+close( OUT );
98
+
99
+exit();
100
+
101
+#### Subroutine ####
102
+
103
+sub str_to_ucs2
104
+{
105
+ my( $sIn ) = @_;
106
+ my( $sOut, $len, $i );
107
+
108
+ $sOut = '';
109
+
110
+ $len = length( $sIn );
111
+ for( $i=0; $i<$len; ++$i ){
112
+ $sOut .= sprintf( "%04x ", unpack( "U", substr( $sIn, $i, 1 )));
113
+ }
114
+ chop( $sOut );
115
+
116
+ return $sOut;
117
+}
118
+
119
+sub str_to_utf8
120
+{
121
+ my( $sIn ) = @_;
122
+ my( $sOut, $len, $i );
123
+
124
+ $sOut = '';
125
+
126
+ $len = length( $sIn );
127
+ for( $i=0; $i<$len; ++$i ){
128
+ $sOut .= unpack( "H8", substr( $sIn, $i, 1 ) ) . ' ';
129
+ }
130
+ chop( $sOut );
131
+
132
+ return $sOut;
133
+}
134
+
135
+# EOF
136
+```
137
+
138
+## ダウンロード
139
+- ソースコードと出力されるEPSファイル<br />
140
+[GA2.zip](GA2.zip)
141
+- EPSファイルをAcrobat Distiller 6でPDFに変換したもの<br />
142
+[GA2.pdf](GA2.pdf)
143
+
144
+~~#navi(Perl/EPSファイル作成)~~
0 145
\ No newline at end of file
1 146
diff --git "a/Perl/EPS\343\203\225\343\202\241\343\202\244\343\203\253\344\275\234\346\210\220/\346\226\207\345\255\227\343\201\256\345\233\236\350\273\242.md" "b/Perl/EPS\343\203\225\343\202\241\343\202\244\343\203\253\344\275\234\346\210\220/\346\226\207\345\255\227\343\201\256\345\233\236\350\273\242.md"
2 147
new file mode 100644
3 148
index 0000000..6bb8263
4
--- /dev/null
149
+++ "b/Perl/EPS\343\203\225\343\202\241\343\202\244\343\203\253\344\275\234\346\210\220/\346\226\207\345\255\227\343\201\256\345\233\236\350\273\242.md"
... ...
@@ -0,0 +1,111 @@
1
+~~#navi(Perl/EPSファイル作成)~~
2
+[[_TOC_]]
3
+# 文字の回転
4
+## 概要
5
+- 使用しているフォントは「小塚明朝 Std - M」。
6
+- EPS中で「Unicode(UCS2)」で指定する場合は「KozMinStd-Medium-UniJIS-UCS2-V」と記述する。(縦書き)
7
+- EPS中で「Shift_JIS」で指定する場合は「KozMinStd-Medium-90ms-RKSJ-V」と記述する。(縦書き)
8
+
9
+## ソースコード
10
+```
11
+# EPS作成
12
+# テキストの配置
13
+# このソースは UTF8N, LF で保存すること
14
+
15
+use strict;
16
+use utf8;
17
+use Encode qw/encode decode/;
18
+
19
+my $eps_file = 'Jugemu_u.eps';
20
+my $mm2point = 72 / 25.4;
21
+
22
+# A4サイズ
23
+my $width = sprintf( "%.2f", 210 * $mm2point );
24
+my $height = sprintf( "%.2f", 297 * $mm2point );
25
+
26
+my $x0 = sprintf( "%.2f", $width / 2 );
27
+my $y0 = sprintf( "%.2f", $height / 2 );
28
+
29
+my $String = "寿限無 寿限無 五劫の擦り切れ 海砂利水魚の 水行末 雲来末 風来末 "
30
+ . "食う寝る処に住む処 やぶら小路の藪柑子 パイポパイポ パイポのシューリンガン "
31
+ . "シューリンガンのグーリンダイ グーリンダイのポンポコピーのポンポコナーの 長久命の長助";
32
+my $StringFontSize = 32;
33
+
34
+my $Pi = 3.141592;
35
+
36
+my ( $len, $x, $y, $r, $theta, $i );
37
+
38
+my $eps = '';
39
+
40
+$eps .=<<EOL;
41
+%!PS-Adobe-3.0 EPSF-3.0
42
+%%BoundingBox: 0 0 $width $height
43
+
44
+/putText {
45
+ 4 dict begin
46
+ /char exch def
47
+ /angle exch def
48
+ /ty exch def
49
+ /tx exch def
50
+ gsave
51
+ tx ty translate
52
+ angle rotate
53
+ 0 0 moveto
54
+ char show
55
+ grestore
56
+ end
57
+} def
58
+
59
+% 全体枠
60
+0 0 moveto
61
+0 $height lineto
62
+$width $height lineto
63
+$width 0 lineto
64
+closepath
65
+1 setlinewidth
66
+0 0 0 1 setcmykcolor
67
+stroke
68
+
69
+% 小塚明朝 Std - M (縦書き)
70
+/KozMinStd-Medium-UniJIS-UCS2-V findfont $StringFontSize scalefont setfont
71
+0 0 0 1 setcmykcolor
72
+
73
+EOL
74
+
75
+$len = length( $String );
76
+$r = $StringFontSize * 8;
77
+$theta = 0;
78
+
79
+for( $i=0; $i<$len; ++ $i ){
80
+ $x = $x0 + $r * cos( $theta );
81
+ $y = $y0 + $r * sin( $theta );
82
+ $eps .= sprintf( "%.2f %.2f %.1f <%04x> putText\n",
83
+ $x, $y, $theta*180/$Pi, unpack("U",substr($String,$i,1)) );
84
+ $theta -= $StringFontSize * 1.05 / $r;
85
+ if ( $theta < -2 * $Pi ){
86
+ $theta += 2 * $Pi;
87
+ }
88
+ $r -= $StringFontSize * $StringFontSize * 1.4 / ( 2 * $Pi * $r );
89
+}
90
+
91
+$eps .=<<EOL;
92
+
93
+showpage
94
+EOL
95
+
96
+open( OUT, ">:encoding(utf8)", $eps_file ) || die( "can't open '" . $eps_file . "'.\n" );
97
+print OUT $eps;
98
+close( OUT );
99
+
100
+exit();
101
+
102
+# EOF
103
+```
104
+
105
+## ダウンロード
106
+- ソースコード(UCS2版, Shift_JIS版)と出力されるEPSファイル(UCS2版, Shift_JIS版)<br />
107
+[Jugemu.zip](Jugemu.zip)
108
+- EPSファイルをAcrobat Distiller 6でPDFに変換したもの<br />
109
+[Jugemu.pdf](Jugemu.pdf)
110
+
111
+~~#navi(Perl/EPSファイル作成)~~
0 112
\ No newline at end of file
Perl/EscapeSlash.md
... ...
@@ -0,0 +1,124 @@
1
+# C言語スタイルで文字列のエスケープ/アンエスケープを行う
2
+[[_TOC_]]
3
+
4
+## 概要
5
+- 入力された文字列の中の改行など直接記述できない文字にバックスラッシュを付けてエスケープする。
6
+- PHP関数 [addcslashes](http://jp2.php.net/manual/ja/%66%75%6e%63%74%69%6f%6e%2e%61%64%64%63%73%6c%61%73%68%65%73%2e%70%68%70) / [stripcslashes](http://jp2.php.net/manual/ja/%66%75%6e%63%74%69%6f%6e%2e%73%74%72%69%70%63%73%6c%61%73%68%65%73%2e%70%68%70)
7
+- 2つ目の引数にハッシュを指定することで別の変換を行うことができます。
8
+ - 書いたはいいが、2番目のパラメータをハッシュだと思い込んでたがホントは文字列だった。(--;)<br />
9
+addcslashes, stripcslashes という関数名は付けられないなぁ。
10
+- \xXX 形式には対応していません。
11
+
12
+## ソースコード
13
+- [EscapeSlash.zip](EscapeSlash.zip)
14
+
15
+### EscapeSlash.pm
16
+```
17
+# C言語スタイルで文字列のエスケープ/アンエスケープを行う
18
+# by TakeAsh
19
+# ネタ元 http://jp2.php.net/manual/ja/function.addcslashes.php
20
+# ネタ元 http://blog.livedoor.jp/dankogai/archives/50940023.html
21
+#
22
+# v0.00 2009.03.04
23
+# v0.01 2009.03.12 空文字列が渡されたときはundefではなく空文字列を返すようにした。
24
+# unescapeslashはescapeslashを呼ぶようにした。
25
+# \e(0x1b)もエスケープするようにした。
26
+# v0.02 2009.03.17 数値0が渡されたときに""ではなく0を返すようにした。
27
+# v0.03 2009.08.14 ",'もエスケープするようにした。
28
+#
29
+# 書いたはいいが、2番目のパラメータをハッシュだと思い込んでたがホントは文字列だった。(--;)
30
+# addcslashes, stripcslashes という関数名は付けられないなぁ。
31
+# \xXX 形式には対応していません。
32
+
33
+package EscapeSlash;
34
+
35
+use strict;
36
+use warnings;
37
+use utf8;
38
+
39
+use Exporter;
40
+our @ISA = qw(Exporter);
41
+our @EXPORT = qw(escapeslash unescapeslash);
42
+
43
+## スケープする文字セット
44
+my %charset_factory = (
45
+ "\\"=>"\\\\", "\n"=>"\\n", "\r"=>"\\r", "\t"=>"\\t", "\0"=>"\\0",
46
+ "\a"=>"\\a", "\b"=>"\\b", "\f"=>"\\f", "\e" => "\\e",
47
+ "\""=>"\\\"", "'"=>"\\'"
48
+ # , "\v"=>"\\v"
49
+);
50
+
51
+## C言語スタイルで文字列のエスケープを行う
52
+# @param $str [in] 変換対象文字列
53
+# @param %charset [in] エスケープする文字セット(オプション)
54
+# @return エスケープされた文字列
55
+sub escapeslash{
56
+ my $str;
57
+ $str = shift or return $str; # undef, "", 0 ならリターン
58
+ my %charset = defined( $_[0] ) ? %{shift()} : %charset_factory ; # %{shift} だとハッシュへのリファレンスが受け取れない
59
+ my $charclass = join( '|', map{ quotemeta } keys( %charset ) );
60
+ $str =~ s/($charclass)/$charset{$1}/msgex;
61
+ return $str;
62
+}
63
+
64
+## C言語スタイルで文字列のアンエスケープを行う
65
+# @param $str [in] 変換対象文字列
66
+# @param %charset [in] アンエスケープする文字セット(オプション)
67
+# @return アンエスケープされた文字列
68
+sub unescapeslash{
69
+ my $str = shift;
70
+ my %charset = defined( $_[0] ) ? %{shift()} : %charset_factory ; # %{shift} だとハッシュへのリファレンスが受け取れない
71
+ %charset = reverse( %charset );
72
+ return escapeslash( $str, \%charset );
73
+}
74
+
75
+1;
76
+
77
+# EOF
78
+```
79
+
80
+### TestEscapeSlash.pl
81
+```
82
+# EscapeSlash.pm の動作テスト
83
+
84
+use strict;
85
+use warnings;
86
+use utf8;
87
+use Data::Dump qw(dump);
88
+
89
+use EscapeSlash;
90
+
91
+my @Sample = (
92
+ "ab\\cd", "ab\ncd", "ab\rcd", "ab\tcd", "ab\0cd", "ab\"cd", "ab'cd", "ab?cd", "ab&cd",
93
+ "ab\\\\cd", "ab\\ncd", "ab\\rcd", "ab\\tcd", "ab\\0cd", "ab\\\"cd", "ab\\'cd", "ab\\?cd", "ab\\&cd",
94
+ "", undef, 0, "0",
95
+);
96
+
97
+my %ConvSet = ( "\\" => "\\\\", "?" => "\\?", "&"=>"\\&" );
98
+
99
+my @TestData = ( @ARGV > 0 ) ? @ARGV : @Sample ;
100
+
101
+print "ConvSet for esc2,unesc2\n" . dump(%ConvSet)."\n\n";
102
+
103
+foreach my $test ( @TestData ){
104
+ printf( "org:\t%s\n", dump($test) );
105
+ printf( "esc:\t%s\n", dump(escapeslash($test)) );
106
+ printf( "unesc:\t%s\n", dump(unescapeslash($test)) );
107
+ printf( "esc2:\t%s\n", dump(escapeslash($test,\%ConvSet)) );
108
+ printf( "unesc2:\t%s\n", dump(unescapeslash($test,\%ConvSet)) );
109
+ #printf( "Reverse:\t%d\n", $test eq unescapeslash(escapeslash($test)) );
110
+ print "\n";
111
+}
112
+
113
+# EOF
114
+```
115
+
116
+## Link
117
+- [[Microsoft SQL Server インポート/エクスポート|Perl/MSSQL_ImpExp]]
118
+
119
+- [勝手に添削 - 40行で作るPerl用テンプレートエンジン](http://blog.livedoor.jp/dankogai/archives/50940023.html)
120
+- [javascript - String.prototype.quotemeta() があればいいんじゃね?](http://blog.livedoor.jp/dankogai/archives/51058313.html)
121
+- [Perlメモ](http://www.din.or.jp/~ohzaki/perl.htm) / [改行コードを統一する](http://www.din.or.jp/~ohzaki/perl.htm#CRLF_Unify)
122
+
123
+- [perldoc.jp](http://perldoc.jp/) / [Perlのリファレンスとネストしたデータ構造](http://perldoc.jp/pod/perlref) / [あまりシンボリックではないリファレンス](http://perldoc.jp/pod/perlref#Not-so-symbolic32references)
124
+ - perl のバージョン 5.001 で、中かっこに囲まれたシンボリックリファレンスが よりクォートのように、ちょうどそれが文字列の中にあるかのように 振る舞うという新たな機能が読みやすさのために追加されました。
0 125
\ No newline at end of file
Perl/GD.md
... ...
@@ -0,0 +1,64 @@
1
+# GDライブラリを使って画像の縮小版を作成する
2
+[[_TOC_]]
3
+
4
+## 概要
5
+GDライブラリを使って画像の 1/2, 1/3, 1/4 縮小版を一括で作成する。
6
+
7
+## スクリプト
8
+- [shrink.zip](shrink.zip)
9
+
10
+## shrink.pl
11
+```
12
+# 画像一括縮小
13
+# 「PDATA」以下のpngファイルを1/2,1/3,1/4に縮小し「PDATA2」「PDATA3」「PDATA4」へ保存する。
14
+
15
+use strict;
16
+use warnings;
17
+use utf8;
18
+use GD;
19
+
20
+my @filelist = <./PDATA/*.png>;
21
+# print join( "\n", @filelist );
22
+
23
+my $filein; # 入力ファイル名
24
+my $imgsrc; # 入力画像
25
+my( $width, $height ); # 入力画像の幅と高さ
26
+my $num; # 画像ファイル数
27
+my $cnt = 0; # カウンタ
28
+
29
+$num = scalar( @filelist );
30
+$| = 1;
31
+foreach $filein ( @filelist ){
32
+ $imgsrc = GD::Image->new( $filein ) || die( $! );
33
+ ( $width, $height ) = $imgsrc->getBounds();
34
+ shrink( $filein, 2 );
35
+ shrink( $filein, 3 );
36
+ shrink( $filein, 4 );
37
+ printf STDERR ( "%d/%d\r", ++$cnt, $num );
38
+}
39
+$| = 0;
40
+
41
+sub shrink
42
+{
43
+ my( $filein, $div ) = @_;
44
+ my $fhout; # 出力ファイルハンドル
45
+ my $imgdst; # 出力画像
46
+ my( $w2, $h2 ); # 出力画像の幅と高さ
47
+ my $fileout; # 出力ファイル名
48
+
49
+ $w2 = int( $width / $div ); # intが無いとクラッシュする
50
+ $h2 = int( $height / $div ); # intが無いとクラッシュする
51
+ $imgdst = new GD::Image( $w2, $h2, 0 );
52
+ $imgdst->copyResized( $imgsrc, 0, 0, 0, 0, $w2, $h2, $width, $height );
53
+ $fileout = $filein;
54
+ $fileout =~ s#/PDATA/#/PDATA${div}/#;
55
+ open( $fhout, ">:bytes", $fileout ) || die( $! );
56
+ binmode( $fhout ); # ">:bytes" があればいらないはずだが、無いと読めないファイルが出来る。
57
+ print $fhout $imgdst->png;
58
+ close( $fhout );
59
+}
60
+
61
+# EOF
62
+```
63
+
64
+## リンク
0 65
\ No newline at end of file
Perl/GMTtoLocalTime.md
... ...
@@ -0,0 +1,96 @@
1
+# GMT からローカルタイム(JST)に変換
2
+[[_TOC_]]
3
+
4
+## 概要
5
+- GMT を [CPAN:HTTP-Date](http://search.cpan.org/dist/HTTP-Date) および Perl 標準機能のみを使ってローカルタイムに変換する。
6
+- GMTtoLocal2 は時差の指定は無視する。
7
+
8
+## ソース
9
+- [GMTtoLocal.zip](GMTtoLocal.zip)
10
+```perl
11
+#!/usr/bin/perl
12
+# GMT からローカルタイム(JST)に変換
13
+
14
+use strict;
15
+use warnings;
16
+use utf8;
17
+use Encode;
18
+use HTTP::Date qw( time2str str2time time2iso );
19
+use POSIX qw(strftime);
20
+use Time::Local;
21
+
22
+my $charsetConsole = 'CP932';
23
+my $charsetFile = 'UTF-8';
24
+
25
+binmode( STDIN, ":encoding($charsetConsole)" );
26
+binmode( STDOUT, ":encoding($charsetConsole)" );
27
+binmode( STDERR, ":encoding($charsetConsole)" );
28
+
29
+my @sample = (
30
+ '2011-11-23T00:00:00Z',
31
+ '2011-12-31T20:00:00Z',
32
+ '2012-02-28T21:00:00+00:00',
33
+ '2012-02-28T21:00:00+09:00',
34
+);
35
+
36
+foreach my $src ( @sample ){
37
+ printf( "Source\t\t%s\nHTTP::Date\t%s\nStandard\t%s\n\n",
38
+ $src, GMTtoLocal1( $src ), GMTtoLocal2( $src ) );
39
+}
40
+
41
+exit();
42
+
43
+# HTTP::Date を使用
44
+# http://search.cpan.org/dist/HTTP-Date/
45
+sub GMTtoLocal1
46
+{
47
+ my( $gmt ) = @_;
48
+ return time2iso( str2time( $gmt, 'Asia/Tokyo' ) );
49
+}
50
+
51
+# Perl標準機能のみ
52
+# http://chalow.net/2010-03-01-5.html
53
+# 時差の指定は無視して常にGMTと見なす。
54
+sub GMTtoLocal2
55
+{
56
+ my( $gmt ) = @_;
57
+ my $ret = $gmt;
58
+ if ( $gmt =~ /^(\d+)-(\d+)-(\d+)T(\d+):(\d+):(\d+)/ ){
59
+ my $utm = timegm( $6, $5, $4, $3, $2-1, $1 );
60
+ $ret = strftime( "%Y-%m-%d %H:%M:%S", localtime( $utm ) );
61
+ }
62
+ return $ret;
63
+}
64
+
65
+# EOF
66
+```
67
+
68
+## 出力
69
+```
70
+Source 2011-11-23T00:00:00Z
71
+HTTP::Date 2011-11-23 09:00:00
72
+Standard 2011-11-23 09:00:00
73
+
74
+Source 2011-12-31T20:00:00Z
75
+HTTP::Date 2012-01-01 05:00:00
76
+Standard 2012-01-01 05:00:00
77
+
78
+Source 2012-02-28T21:00:00+00:00
79
+HTTP::Date 2012-02-29 06:00:00
80
+Standard 2012-02-29 06:00:00
81
+
82
+Source 2012-02-28T21:00:00+09:00
83
+HTTP::Date 2012-02-28 21:00:00
84
+Standard 2012-02-29 06:00:00
85
+```
86
+
87
+## リンク
88
+- [CPAN:HTTP-Date](http://search.cpan.org/dist/HTTP-Date)
89
+- [CPAN:Time-Local](http://search.cpan.org/dist/Time-Local)
90
+- [CPAN:Time-Piece](http://search.cpan.org/dist/Time-Piece)
91
+
92
+- [たつをの ChangeLog](http://chalow.net/)
93
+ - [GMT による時間表現文字列を JST に変換する Perl コード片](http://chalow.net/2010-03-01-5.html)
94
+
95
+- [サンプルコードによるPerl入門](http://d.hatena.ne.jp/perlcodesample/)
96
+ - [今月の最初の日を表すTime::Pieceオブジェクトを取得する / Time::Piece Tips](http://d.hatena.ne.jp/perlcodesample/20120911/1347331536)
0 97
\ No newline at end of file
Perl/GoogleMapAPI.md
... ...
@@ -0,0 +1,115 @@
1
+# Google Map API を使って始点終点の経路情報と地図画像を得る
2
+[[_TOC_]]
3
+
4
+## 概要
5
+- [Google Directions API](http://code.google.com/intl/ja/apis/maps/documentation/directions/)を使って経路情報を得る。
6
+- [Static Maps API](http://code.google.com/intl/ja/apis/maps/documentation/staticmaps/)を使って経路情報付き画像を得る。
7
+- 事前にカレントディレクトリに保存用ディレクトリ「map」を作成しておく必要がある。
8
+- 使用例
9
+```
10
+>gmap.pl 東京 ビックサイト
11
+>gmap.pl 東京 サンフランシスコ
12
+```
13
+
14
+## ソース
15
+- [gmap.pl](gmap.pl)
16
+```
17
+#!/usr/bin/perl
18
+# gmap.pl
19
+# 始点終点の経路情報と地図画像を得る。
20
+# 使用法: gmap.pl <始点> <終点>
21
+
22
+use strict;
23
+use warnings;
24
+use utf8;
25
+use Encode;
26
+use LWP::UserAgent;
27
+use HTTP::Request;
28
+use JSON;
29
+use YAML::Syck;
30
+
31
+my $GoogleMapDirectionsAPI = 'http://maps.google.com/maps/api/directions/json?mode=walking&language=ja&sensor=false';
32
+my $GoogleMapStaticAPI = 'http://maps.google.com/maps/api/staticmap?size=640x640&language=ja&sensor=false';
33
+my $MapPath = './map/';
34
+
35
+$YAML::Syck::ImplicitUnicode = 1;
36
+
37
+binmode( STDIN, ":encoding(CP932)" );
38
+binmode( STDOUT, ":encoding(CP932)" );
39
+binmode( STDERR, ":encoding(CP932)" );
40
+
41
+my $usStart = decode( 'CP932', shift ); # unicode string
42
+my $usGoal = decode( 'CP932', shift ); # unicode string
43
+if ( !defined( $usStart ) || $usStart eq "" || !defined( $usGoal ) || $usGoal eq "" ){
44
+ die( "使用法: $0 <始点> <終点>\n" );
45
+}
46
+
47
+my $esStart = encodeURIComponent( $usStart ); # encoded string
48
+my $esGoal = encodeURIComponent( $usGoal ); # encoded string
49
+my $usFName = $usStart . '_' . $usGoal; # unicode string
50
+my $bsFName = encode( 'CP932', $MapPath . $usFName ); # byte string
51
+
52
+#printf( "start:\t%s\t%s\ngoal:\t%s\t%s\n", $usStart, $esStart, $usGoal, $esGoal );
53
+
54
+my $ua = LWP::UserAgent->new( keep_alive => 2 );
55
+
56
+my $res = $ua->get( $GoogleMapDirectionsAPI . '&origin=' . $esStart . '&destination=' . $esGoal );
57
+if ( $res->is_success ){
58
+ #print $res->content, "\n";
59
+ # http://www.donzoko.net/cgi-bin/tdiary/20100406.html#p01
60
+ my $json = JSON->new->utf8;
61
+ my $usRoute = $json->decode( $res->content );
62
+ #print Dump( $usRoute );
63
+ if ( $usRoute->{'status'} eq 'OK' ){
64
+ my $usLegs = $usRoute->{'routes'}[0]{'legs'}[0];
65
+ #delete $usLegs->{'steps'};
66
+ open( my $fout, ">:utf8", $bsFName . '.yaml' ) or die( "$usFName: $!\n" );
67
+ print $fout Dump( $usLegs );
68
+ close( $fout );
69
+
70
+ my $start_lat = $usLegs->{'start_location'}{'lat'};
71
+ my $start_lng = $usLegs->{'start_location'}{'lng'};
72
+ my $end_lat = $usLegs->{'end_location'}{'lat'};
73
+ my $end_lng = $usLegs->{'end_location'}{'lng'};
74
+ my $center_lng = ( $start_lng + $end_lng ) / 2;
75
+ if ( $start_lng * $end_lng < 0 && abs( $start_lng ) + abs( $end_lng ) > 180 ){
76
+ if ( $center_lng >= 0 ){
77
+ $center_lng -= 180;
78
+ } else {
79
+ $center_lng += 180;
80
+ }
81
+ }
82
+ my $mapURI = $GoogleMapStaticAPI
83
+ . '&center=' . (( $start_lat + $end_lat ) / 2 ) . ',' . $center_lng
84
+ . '&markers=label:S|' . $start_lat . ',' . $start_lng
85
+ . '&markers=label:G|' . $end_lat . ',' . $end_lng
86
+ . '&path=enc:' . $usRoute->{'routes'}[0]{'overview_polyline'}{'points'};
87
+ $ua->request( HTTP::Request->new( GET => $mapURI ), $bsFName . '.png' );
88
+ } else {
89
+ die( "Error: $usRoute->{'status'}\n" );
90
+ }
91
+} else {
92
+ die( "Error: $res->status_line\n" );
93
+}
94
+
95
+sub encodeURIComponent {
96
+ my $str = encode( 'utf-8', shift );
97
+ $str =~ s/([^0-9A-Za-z!'()*\-._~])/sprintf("%%%02X", ord($1))/eg;
98
+ return $str;
99
+}
100
+
101
+# EOF
102
+```
103
+
104
+## リンク
105
+- [[JavaScript/GoogleMapAPI]]
106
+
107
+- [Google Maps API ファミリー - Google Code](http://code.google.com/intl/ja/apis/maps/)
108
+ - [Google Directions API](http://code.google.com/intl/ja/apis/maps/documentation/directions/)
109
+ - [Static Maps API](http://code.google.com/intl/ja/apis/maps/documentation/staticmaps/)
110
+
111
+- [CPAN:JSON-XS](http://search.cpan.org/dist/JSON-XS)
112
+- [CPAN:URI](http://search.cpan.org/dist/URI) (URI::Escape)
113
+
114
+- [どんぞこCGI+--](http://www.donzoko.net/) / [どんぞこ日誌](http://www.donzoko.net/cgi-bin/tdiary/) / [JSONのドキュメントに追加した部分](http://www.donzoko.net/cgi-bin/tdiary/20100406.html#p01)
115
+- [rubyu備忘録](http://d.hatena.ne.jp/ruby-U/) / [perlとpython用encodeURIComponent()](http://d.hatena.ne.jp/ruby-U/20081110/1226313786)
0 116
\ No newline at end of file
1 117
diff --git "a/Perl/HTTP\343\202\242\343\202\257\343\202\273\343\202\271.md" "b/Perl/HTTP\343\202\242\343\202\257\343\202\273\343\202\271.md"
2 118
new file mode 100644
3 119
index 0000000..bf1c840
4
--- /dev/null
120
+++ "b/Perl/HTTP\343\202\242\343\202\257\343\202\273\343\202\271.md"
... ...
@@ -0,0 +1,81 @@
1
+# HTTPアクセス
2
+[[_TOC_]]
3
+
4
+## 情報源
5
+
6
+~[ActivePerl](http://www.activestate.com/ActivePerl/)には、[libwww-perl](http://lwp.linpro.no/lwp/)がパッケージとして含まれているので、ローカルの Perl/html/site/lib/lwpcook.html を参照すること。
7
+
8
+## サンプル
9
+- [TinyProxy.zip](TinyProxy.zip)
10
+```perl
11
+#!/usr/bin/perl
12
+# TinyProxy.pl
13
+# コマンドラインで指定した URI を utf8 としてファイルに保存。
14
+
15
+use strict;
16
+use warnings;
17
+use utf8;
18
+use Encode;
19
+use LWP::UserAgent;
20
+#use URI::Escape;
21
+use EscapeSlash;
22
+
23
+my $charsetConsole = 'CP932';
24
+my $charsetFile = 'UTF-8';
25
+
26
+# ファイル名/パス名として使用できない文字+α
27
+my %ConvSet = map{ $_ => '%' . uc( unpack( 'H02', $_ ) ) } split( //, '\\/*?|<>:,;% \"' );
28
+
29
+@ARGV = map{ decode( $charsetConsole, $_ ); } @ARGV;
30
+
31
+my $url = $ARGV[0] or die( "usage: TinyProxy.pl <URI>\n" );
32
+my $fileNameOut = $url;
33
+if ( $fileNameOut =~ m#^.*/$# ){
34
+ $fileNameOut .= 'index.html';
35
+}
36
+$fileNameOut =~ s#^\w+://(.*)$#$1#;
37
+#$fileNameOut = uri_escape_utf8( $fileNameOut );
38
+$fileNameOut = escapeslash( $fileNameOut, \%ConvSet );
39
+
40
+binmode( STDIN, ":encoding($charsetConsole)" );
41
+binmode( STDOUT, ":encoding($charsetConsole)" );
42
+binmode( STDERR, ":encoding($charsetConsole)" );
43
+
44
+open( my $OUT, ">:encoding($charsetFile)", encode( $charsetConsole, $fileNameOut ) )
45
+ or die( "$fileNameOut: $!\n" );
46
+print $OUT getURI( $url );
47
+close( $OUT );
48
+
49
+exit();
50
+
51
+# --- Subroutine ---
52
+sub getURI {
53
+ my( $URI ) = @_;
54
+
55
+ my $ua = LWP::UserAgent->new;
56
+ my $req = HTTP::Request->new( GET => $URI );
57
+
58
+ # send request
59
+ my $res = $ua->request( $req );
60
+
61
+ # check the outcome
62
+ if ( $res->is_success ){
63
+ return $res->decoded_content; # utf8フラグ付テキスト
64
+ } else {
65
+ return "Error: " . $res->status_line . "\n";
66
+ }
67
+}
68
+
69
+# EOF
70
+```
71
+
72
+## リンク
73
+- [[Perl/EscapeSlash]]
74
+- [[Perl/nicoget]]
75
+
76
+- [CPAN:libwww-perl](http://search.cpan.org/dist/libwww-perl)
77
+- [CPAN:HTTP-Message](http://search.cpan.org/dist/HTTP-Message)
78
+- [libwww-perl](http://lwp.linpro.no/lwp/)
79
+- [CPAN:URI/URI/Escape.pm](http://search.cpan.org/dist/URI/URI/Escape.pm)
80
+
81
+- [LWP::UserAgentでdecoded_contentしたら特定のContent-Typeで文字化けするのでハックした](http://blog.livedoor.jp/sasata299/archives/51212133.html) @ [(゚∀゚)o彡 sasata299's blog](http://blog.livedoor.jp/sasata299/)
0 82
\ No newline at end of file
Perl/Home.md
... ...
@@ -1,3 +1,32 @@
1
-# Perl
1
+[[_TOC_]]
2 2
3
-- [[Http]]
3
+# サンプルスクリプト
4
+~~#ls2()~~
5
+- [GitHub:TakeAsh/p-usDownload](https://github.com/TakeAsh/p-usDownload) Ustream Archive Downloader
6
+- [GitHub:TakeAsh/p-RecRadiru](https://github.com/TakeAsh/p-RecRadiru) NHK Net Radio らじる★らじる を rtmpdump で録音するスクリプト
7
+
8
+# リンク
9
+- http://perldoc.jp/
10
+ - [コアドキュメント](http://perldoc.jp/index/core)
11
+ - [組み込み関数](http://perldoc.jp/index/function)
12
+ - [翻訳済モジュール](http://perldoc.jp/index/module)
13
+
14
+- [The CPAN Search Site](http://search.cpan.org/)
15
+- [スマートスマート](http://www.rfs.jp/) / [Perl講座](http://www.rfs.jp/sb/perl/)
16
+- [ActiveState Tool Corp.](https://www.activestate.com/)
17
+ - [ActivePerl](https://www.activestate.com/activeperl/)
18
+ - [ActivePerl Documentation](https://docs.activestate.com/activeperl/)
19
+ - [ActivePerl 5.24 Documentation](https://docs.activestate.com/activeperl/5.24/) / [Release Notes](https://docs.activestate.com/activeperl/5.24/release.html) / [PPM, Proxies and Firewalls](https://docs.activestate.com/activeperl/5.24/faq/ActivePerl-faq2.html#ppm_and_proxies)
20
+ - [ActivePerl 5.22 Documentation](https://docs.activestate.com/activeperl/5.22/) / [Release Notes](https://docs.activestate.com/activeperl/5.22/release.html) / [PPM, Proxies and Firewalls](https://docs.activestate.com/activeperl/5.22/faq/ActivePerl-faq2.html#ppm_and_proxies)
21
+ - [ActivePerl 5.20 Documentation](https://docs.activestate.com/activeperl/5.20/) / [Release Notes](https://docs.activestate.com/activeperl/5.20/release.html) / [PPM, Proxies and Firewalls](https://docs.activestate.com/activeperl/5.20/faq/ActivePerl-faq2.html#ppm_and_proxies)
22
+ - [ActivePerl 5.18 Documentation](https://docs.activestate.com/activeperl/5.18/) / [Release Notes](https://docs.activestate.com/activeperl/5.18/release.html) / [PPM, Proxies and Firewalls](https://docs.activestate.com/activeperl/5.18/faq/ActivePerl-faq2.html#ppm_and_proxies)
23
+ - [ActivePerl 5.16 Documentation](https://docs.activestate.com/activeperl/5.16/) / [Release Notes](https://docs.activestate.com/activeperl/5.16/release.html) / [PPM, Proxies and Firewalls](https://docs.activestate.com/activeperl/5.16/faq/ActivePerl-faq2.html#ppm_and_proxies)
24
+ - [ActivePerl 5.14 Documentation](https://docs.activestate.com/activeperl/5.14/) / [Release Notes](https://docs.activestate.com/activeperl/5.14/release.html)
25
+ - [ActivePerl 5.12 Documentation](https://docs.activestate.com/activeperl/5.12/) / [Release Notes](https://docs.activestate.com/activeperl/5.12/release.html)
26
+ - [ActivePerl 5.10 Documentation](https://docs.activestate.com/activeperl/5.10/)
27
+ - [ActivePerl 5.8 Documentation](https://docs.activestate.com/activeperl/5.8/)
28
+- [Perl入門@ITpro](http://itpro.nikkeibp.co.jp/article/COLUMN/20080528/304529/)
29
+- [Perlリファレンス@ITpro](http://itpro.nikkeibp.co.jp/article/Reference/20081111/318984/)
30
+ - [目的別インデックス](http://itpro.nikkeibp.co.jp/article/Reference/20080926/315520/)
31
+ - [関数順インデックス](http://itpro.nikkeibp.co.jp/article/Reference/20080926/315499/)
32
+- [Perlでフォトショップ CS](http://www2.tba.t-com.ne.jp/tail/prog/perl/photoshop.html) @ [Storeroom](http://www2.tba.t-com.ne.jp/tail/)
Perl/HostToIP.md
... ...
@@ -0,0 +1,45 @@
1
+# HostToIP
2
+[[_TOC_]]
3
+
4
+## 概要
5
+- ホスト名からIPアドレスを求め、IPアドレスからホスト名を逆引きする。
6
+
7
+## ソース
8
+- [HostToIP.zip](HostToIP.zip)
9
+```perl
10
+#!/usr/bin/perl
11
+# HostToIP.pl
12
+# ホスト名からIPアドレスを求める。(IPv4)
13
+# さらにIPアドレスからホスト名を逆引きする。
14
+
15
+use strict;
16
+use warnings;
17
+use utf8;
18
+use Encode;
19
+use Socket;
20
+
21
+my $charsetConsole = 'CP932';
22
+#my $charsetConsole = 'UTF-8';
23
+my $charsetFile = 'UTF-8';
24
+
25
+binmode( STDIN, ":encoding($charsetConsole)" );
26
+binmode( STDOUT, ":encoding($charsetConsole)" );
27
+binmode( STDERR, ":encoding($charsetConsole)" );
28
+
29
+@ARGV = map{ decode( $charsetConsole, $_ ); } @ARGV;
30
+
31
+my $host1 = $ARGV[0] || 'localhost';
32
+my $ipn = inet_aton( $host1 );
33
+my $ipa = inet_ntoa( $ipn );
34
+my $host2 = gethostbyaddr( $ipn, AF_INET );
35
+
36
+print "$host1\n$ipa\n$host2\n";
37
+
38
+# EOF
39
+```
40
+
41
+## リンク
42
+- [[Perl/getHostName]]
43
+
44
+- [CPAN:Socket](http://search.cpan.org/dist/Socket)
45
+- [CPAN:Socket6](http://search.cpan.org/dist/Socket6)
0 46
\ No newline at end of file
Perl/Http.md
... ...
@@ -1,3 +0,0 @@
1
-# HTTP
2
-
3
-- HTTP アクセス
Perl/HttpHeader.md
... ...
@@ -0,0 +1,45 @@
1
+[[_TOC_]]
2
+
3
+# 概要
4
+- 指定 URL のレスポンスの HTTP Header を表示する。
5
+
6
+# ソース
7
+- [showHeaders.zip](showHeaders.zip)
8
+```perl
9
+#!/usr/bin/perl
10
+# HTTP Header の表示
11
+
12
+use strict;
13
+use warnings;
14
+use utf8;
15
+use Encode;
16
+use LWP::UserAgent;
17
+
18
+#my $charsetConsole = 'UTF-8'; # Linux
19
+my $charsetConsole = 'CP932'; # Windows
20
+my $charsetFile = 'UTF-8';
21
+
22
+binmode( STDIN, ":encoding($charsetConsole)" );
23
+binmode( STDOUT, ":encoding($charsetConsole)" );
24
+binmode( STDERR, ":encoding($charsetConsole)" );
25
+
26
+my $url = $ARGV[0] or die("usage: showHeaders.pl <URL>\n");
27
+
28
+my $ua = LWP::UserAgent->new;
29
+my $req = HTTP::Request->new( HEAD => $url );
30
+
31
+# send request
32
+my $res = $ua->request($req);
33
+if ( !$res->is_success ) {
34
+ die( "Error: " . $res->status_line . "\n" );
35
+}
36
+foreach my $field ( sort( $res->header_field_names ) ) {
37
+ printf( "%s\t%s\n", $field, $res->header($field) );
38
+}
39
+
40
+# EOF
41
+```
42
+
43
+# リンク
44
+- [CPAN:libwww-perl](http://search.cpan.org/dist/libwww-perl)
45
+- [CPAN:HTTP-Message](http://search.cpan.org/dist/HTTP-Message)
0 46
\ No newline at end of file
1 47
diff --git "a/Perl/IP\343\202\242\343\203\211\343\203\254\343\202\271\347\257\204\345\233\262\343\202\222\343\203\236\343\202\271\343\202\257\350\241\250\347\217\276\343\201\253\345\244\211\346\217\233.md" "b/Perl/IP\343\202\242\343\203\211\343\203\254\343\202\271\347\257\204\345\233\262\343\202\222\343\203\236\343\202\271\343\202\257\350\241\250\347\217\276\343\201\253\345\244\211\346\217\233.md"
2 48
new file mode 100644
3 49
index 0000000..d4cad88
4
--- /dev/null
50
+++ "b/Perl/IP\343\202\242\343\203\211\343\203\254\343\202\271\347\257\204\345\233\262\343\202\222\343\203\236\343\202\271\343\202\257\350\241\250\347\217\276\343\201\253\345\244\211\346\217\233.md"
... ...
@@ -0,0 +1,161 @@
1
+[[_TOC_]]
2
+
3
+# 概要
4
+- [IP List for PeerGuardian 2](http://iplist.wave.prohosting.com/)のIPアドレス情報(IP1 - IP2)をマスク表現(IP/mask)に変換します。
5
+- IP List for PeerGuardian 2 が公開されなくなったのね。
6
+- Net::IP 使わないけど、[世界の国別 IPv4 アドレス割り当てリスト](http://nami.jp/ipv4bycc/)から国別の IP アドレスを抽出するスクリプトを作成。(2013/04/11)
7
+
8
+# ソース
9
+## makeIPBlockList.pl
10
+- [makeIPBlockList.zip](makeIPBlockList.zip)
11
+```perl
12
+#!/usr/bin/perl
13
+# makeIPBlockList.pl
14
+# http://iplist.wave.prohosting.com/ のIPリストから接続をブロックするIPアドレスのリストを作成する。
15
+
16
+use strict;
17
+use warnings;
18
+use utf8;
19
+use Encode;
20
+use Net::IP;
21
+
22
+my $fileNameIn = "cn.txt";
23
+my $fileNameOut = "cn_block.txt";
24
+
25
+binmode( STDIN, ":encoding(CP932)" );
26
+binmode( STDOUT, ":encoding(CP932)" );
27
+binmode( STDERR, ":encoding(CP932)" );
28
+
29
+$| = 1;
30
+
31
+open( my $fin, "<:utf8", encode( 'CP932', $fileNameIn ) ) or die( "$fileNameIn: $!\n" );
32
+my @body = <$fin>;
33
+close( $fin );
34
+chomp( @body );
35
+
36
+open( my $fout, ">:utf8", encode( 'CP932', $fileNameOut ) ) or die( "$fileNameOut: $!\n" );
37
+
38
+my $max = scalar( @body );
39
+my $count = 0;
40
+
41
+while( @body > 0 ){
42
+ printf STDERR ( "%d/%d\r", ++$count, $max );
43
+ my $line = shift( @body );
44
+ if ( $line =~ /[^:]+:(\d+\.\d+\.\d+\.\d+)-(\d+\.\d+\.\d+\.\d+)/ ){
45
+ my $ip = new Net::IP( "$1-$2" ) or die( Net::IP::Error() );
46
+ foreach ( $ip->find_prefixes() ){
47
+ /([^\/]+)\/([^\/]+)/;
48
+ printf $fout ( "%s/%s\n", $1, makeMask( $2 ) );
49
+ }
50
+ }
51
+}
52
+
53
+close( $fout );
54
+
55
+sub makeMask
56
+{
57
+ my( $x ) = @_;
58
+ my $ret = '';
59
+ my $b = "1";
60
+ while( $x > 0 ){
61
+ if ( $x & 1 ){
62
+ $ret .= $b;
63
+ }
64
+ $b .= $b;
65
+ $x >>= 1;
66
+ }
67
+ return join( '.', unpack( 'C*', pack( 'B32', substr( $ret . "00000000000000000000000000000000", 0, 32 ) ) ) );
68
+}
69
+
70
+# EOF
71
+```
72
+
73
+### 入力
74
+```
75
+CN:58.14.0.0-58.25.255.255
76
+CN:58.30.0.0-58.63.255.255
77
+CN:58.66.0.0-58.67.255.255
78
+CN:58.68.128.0-58.68.255.255
79
+CN:58.82.0.0-58.83.255.255
80
+CN:58.87.64.0-58.87.127.255
81
+CN:58.99.128.0-58.101.255.255
82
+CN:58.116.0.0-58.119.255.255
83
+CN:58.128.0.0-58.135.255.255
84
+CN:58.144.0.0-58.144.255.255
85
+```
86
+
87
+### 出力
88
+```
89
+58.14.0.0/255.254.0.0
90
+58.16.0.0/255.248.0.0
91
+58.24.0.0/255.254.0.0
92
+58.30.0.0/255.254.0.0
93
+58.32.0.0/255.224.0.0
94
+58.66.0.0/255.254.0.0
95
+58.68.128.0/255.255.128.0
96
+58.82.0.0/255.254.0.0
97
+58.87.64.0/255.255.192.0
98
+58.99.128.0/255.255.128.0
99
+58.100.0.0/255.254.0.0
100
+58.116.0.0/255.252.0.0
101
+58.128.0.0/255.248.0.0
102
+58.144.0.0/255.255.0.0
103
+```
104
+
105
+## makeIPBlockList2.pl
106
+- [makeIPBlockList2.zip](makeIPBlockList2.zip)
107
+```perl
108
+#!/usr/bin/perl
109
+# makeIPBlockList2.pl
110
+# http://nami.jp/ipv4bycc/mask.txt からアクセス禁止国のIPアドレスを抽出
111
+
112
+use strict;
113
+use warnings;
114
+use utf8;
115
+use Encode;
116
+
117
+#my $charset_console = 'UTF-8';
118
+my $charset_console = 'CP932';
119
+my $charset_file = 'UTF-8';
120
+
121
+binmode( STDIN, ":encoding($charset_console)" );
122
+binmode( STDOUT, ":encoding($charset_console)" );
123
+binmode( STDERR, ":encoding($charset_console)" );
124
+
125
+my $fileNameIn = 'mask.txt';
126
+my $fileNameOut = 'block_list.txt';
127
+
128
+my @countries = qw( CN KR RU BR );
129
+my $block_countries = '^(' . join( "|", map{ quotemeta($_); } @countries ) . ')$';
130
+
131
+open( my $fin, "<:encoding($charset_file)", encode( $charset_console, $fileNameIn ) )
132
+ or die( "$fileNameIn: $!\n" );
133
+open( my $fout, ">:encoding($charset_file)", encode( $charset_console, $fileNameOut ) )
134
+ or die( "$fileNameOut: $!\n" );
135
+
136
+foreach my $line ( <$fin> ){
137
+ my( $country, $ip ) = split( /\s/, $line );
138
+ if ( $country =~ /$block_countries/i ){
139
+ #$ip =~ s{/}{,};
140
+ printf $fout ( "%s\n", $ip );
141
+ }
142
+}
143
+
144
+close( $fin );
145
+close( $fout );
146
+
147
+# EOF
148
+```
149
+
150
+# リンク
151
+- [CPAN:Net-IP](http://search.cpan.org/dist/Net-IP)
152
+
153
+- [Office Nami](http://nami.jp/)
154
+ - [世界の国別 IPv4 アドレス割り当てリスト](http://nami.jp/ipv4bycc/)
155
+- [IP List for PeerGuardian 2](http://iplist.wave.prohosting.com/)
156
+- [PeerGuardian](http://peerguardian.sourceforge.net/)
157
+
158
+- [Perlの数値変換](http://mikeneko.creator.club.ne.jp/~lab/perl/numerical_transform/)
159
+
160
+- [iptab と ipcount](http://tkoshima.net/wp/archives/350)
161
+- [IPCount Tool](http://www.ripe.net/cgi-bin/wwwipcount.cgi)
0 162
\ No newline at end of file
Perl/ListDownloader.md
... ...
@@ -0,0 +1,57 @@
1
+[[_TOC_]]
2
+
3
+# 概要
4
+- 1行に1つ URL が書かれたファイルにしたがって該当ファイルをダウンロードする。
5
+- リストファイルがあるフォルダにダウンロードしたファイルを保存する。
6
+- アクセス結果を表示するよう変更。(2016-09-12)
7
+
8
+# ソース
9
+- [ListDownloader.zip](ListDownloader.zip)
10
+```perl
11
+use strict;
12
+use warnings;
13
+use utf8;
14
+use Encode;
15
+use File::Basename;
16
+use File::chdir;
17
+use LWP::UserAgent;
18
+use HTTP::Request;
19
+
20
+my $charsetConsole = $^O eq 'MSWin32' ? 'CP932' : 'UTF-8';
21
+
22
+binmode( STDIN, ":encoding($charsetConsole)" );
23
+binmode( STDOUT, ":encoding($charsetConsole)" );
24
+binmode( STDERR, ":encoding($charsetConsole)" );
25
+
26
+@ARGV = map { decode( $charsetConsole, $_ ); } @ARGV;
27
+
28
+my $charsetFile = 'UTF-8';
29
+my $ioLayer = $^O eq 'MSWin32' ? "raw:encoding($charsetFile):crlf" : "encoding($charsetFile)";
30
+my $listFile = $ARGV[0] or die("usage: ListDownloader <list file>\n");
31
+$CWD = dirname( encode( $charsetConsole, $listFile ) );
32
+open( my $fin, "<:$ioLayer", encode( $charsetConsole, $listFile ) )
33
+ or die("$listFile: $!\n");
34
+my @lines = <$fin>;
35
+close($fin);
36
+chomp(@lines);
37
+my %listHash = map { $_ => 1 } @lines;
38
+my @list = sort( keys(%listHash) );
39
+
40
+my $ua = LWP::UserAgent->new( keep_alive => 4 );
41
+$ua->cookie_jar( {} );
42
+
43
+my $count = 0;
44
+my $max = scalar(@list);
45
+foreach my $url (@list) {
46
+ ++$count;
47
+ $url =~ m{([^\/]+)$};
48
+ my $filename = $1;
49
+ print "$count/$max\t$filename\n";
50
+ my $res
51
+ = $ua->request( HTTP::Request->new( GET => $url ), encode( $charsetConsole, $filename ) );
52
+ sleep(1);
53
+}
54
+```
55
+
56
+# リンク
57
+- [CPAN:perl/lib/File/Basename.pm](http://search.cpan.org/dist/perl/lib/File/Basename.pm)
0 58
\ No newline at end of file
Perl/MSSQL_ImpExp.md
... ...
@@ -0,0 +1,464 @@
1
+# Microsoft SQL Server インポート/エクスポート
2
+[[_TOC_]]
3
+
4
+## 概要
5
+- MS SQL Server のテーブルを CSV ファイル(K3フォーマット)としてインポート/エクスポートする。
6
+- 第1フィールドをプライマリフィールドとして、レコードが未登録か登録済みかを判別し、INSERT または UPDATE を行なう。
7
+- NULLは「NULL」として書き出される。文字列としてのNULLは「"NULL"」になる。
8
+- INDEX(オートナンバー)制約があるフィールドには未対応(ハングアップする)。(2011/09/28)
9
+
10
+## ソースコード
11
+- [MSSQL_ImpExp.zip](MSSQL_ImpExp.zip)
12
+
13
+### DB_Connect.yaml
14
+```
15
+# DB接続情報
16
+Driver: ODBC
17
+Server: localhost\SQLEXPRESS,1433 # <サーバ名>\<インスタンス名>[,<ポート番号>]
18
+User: TestUser
19
+Password: "TestPass" # 記号を含む場合は""で括る。
20
+DB: TestDB
21
+Options:
22
+ LongTruncOk: 1
23
+ LongReadLen: 8192
24
+DSN: _Driver_:Driver={SQL Server}; Server={_Server_}; Database=_DB_;
25
+```
26
+
27
+### getSchema.pl
28
+```perl
29
+#!/usr/bin/perl
30
+# MSSQLサーバからスキーマを読み出す
31
+
32
+use strict;
33
+use warnings;
34
+use utf8;
35
+use Encode;
36
+use YAML::Syck;
37
+use FindBin::libs;
38
+use DBIx::NamedParams;
39
+
40
+$YAML::Syck::ImplicitUnicode = 1;
41
+
42
+my $charsetConsole = 'CP932';
43
+my $charsetFile = 'UTF-8';
44
+
45
+binmode( STDIN, ":encoding($charsetConsole)" );
46
+binmode( STDOUT, ":encoding($charsetConsole)" );
47
+binmode( STDERR, ":encoding($charsetConsole)" );
48
+
49
+my $DB_Connect_yaml = './DB_Connect.yaml';
50
+my $DB_Schema_yaml = './DB_Schema.yaml';
51
+
52
+my @SchemaColumns = qw(
53
+ COLUMN_NAME DATA_TYPE CHARACTER_MAXIMUM_LENGTH COLUMN_DEFAULT IS_NULLABLE
54
+);
55
+
56
+$| = 1;
57
+
58
+my $Schemas = {};
59
+
60
+my $DB_Connect = YAML::Syck::LoadFile( $DB_Connect_yaml )
61
+ or die( "$DB_Connect_yaml: $!" );
62
+foreach( keys( %{$DB_Connect} ) ){
63
+ $DB_Connect->{'DSN'} =~ s/_${_}_/$DB_Connect->{$_}/;
64
+}
65
+#print Dump( $DB_Connect );
66
+#exit;
67
+
68
+my $dbh = DBI->connect(
69
+ "DBI:" . $DB_Connect->{'DSN'},
70
+ $DB_Connect->{'User'},
71
+ $DB_Connect->{'Password'},
72
+ $DB_Connect->{'Options'}
73
+) or die( "$DBI::errstr\n" );
74
+#print Dump( $dbh );
75
+#exit;
76
+
77
+my $DBName = $DB_Connect->{'DB'};
78
+my $sql_getTables = qq{
79
+ SELECT [TABLE_NAME]
80
+ FROM [INFORMATION_SCHEMA].[TABLES]
81
+ WHERE [TABLE_CATALOG] = '$DBName'
82
+ and [TABLE_TYPE]='BASE TABLE'
83
+ ORDER BY [TABLE_NAME];
84
+};
85
+my $sth = $dbh->prepare( $sql_getTables ) or die( "$DBI::errstr\n" );
86
+$sth->execute() or die( "$DBI::errstr\n" );
87
+
88
+do {
89
+ while( my @a = $sth->fetchrow_array ){
90
+ #printf( "%s\n", join( "\t", @a ) );
91
+ $Schemas->{ $a[0] } = [];
92
+ }
93
+}while( $sth->{odbc_more_results} );
94
+$sth->finish;
95
+
96
+my @TableNames = sort( keys( %{ $Schemas } ) );
97
+#print "Tables: " . scalar(@TableNames) ."\n";
98
+#print join( "\n", DBIx::NamedParams::all_sql_types() ) . "\n";
99
+#exit;
100
+
101
+$_ = '[' . join( "], [", @SchemaColumns ) . ']';
102
+my $sql_getColumns = qq{
103
+ SELECT $_
104
+ FROM [INFORMATION_SCHEMA].[COLUMNS]
105
+ WHERE [TABLE_CATALOG] = '$DBName'
106
+ and [TABLE_NAME] = :TableName-WVARCHAR
107
+};
108
+$sth = $dbh->prepare_ex( $sql_getColumns ) or die( "$DBI::errstr\n" );
109
+
110
+my $count = 0;
111
+foreach my $tbl ( @TableNames ){
112
+ printf( "%d/%d\t%s\n", ++$count, scalar(@TableNames), $tbl );
113
+ my @columns = ();
114
+ $sth->bind_param_ex( { 'TableName' => $tbl } );
115
+ $sth->execute() or die( "$DBI::errstr\n" );
116
+ do {
117
+ while( my @a = $sth->fetchrow_array ){
118
+ #printf( "%s\n", join( "\t", @a ) );
119
+ my $ColumnsInfo = {};
120
+ for( my $i=0; $i<@SchemaColumns; ++$i ){
121
+ $ColumnsInfo->{ $SchemaColumns[ $i ] } = $a[ $i ];
122
+ }
123
+ push( @columns, $ColumnsInfo );
124
+ }
125
+ }while( $sth->{odbc_more_results} );
126
+ $Schemas->{ $tbl } = [ @columns ];
127
+}
128
+$sth->finish;
129
+
130
+$dbh->disconnect;
131
+
132
+open( my $fhout, ">:utf8", encode( $charsetConsole, $DB_Schema_yaml ) )
133
+ or die( "$DB_Schema_yaml: $!\n" );
134
+print $fhout YAML::Syck::Dump( $Schemas );
135
+#print dump( $Schemas );
136
+close( $fhout );
137
+
138
+# EOF
139
+```
140
+
141
+### getTbl.pl
142
+```perl
143
+#!/usr/bin/perl
144
+# MSSQLサーバからデータ読み出し
145
+
146
+use strict;
147
+use warnings;
148
+use utf8;
149
+use Encode;
150
+use YAML::Syck;
151
+use FindBin::libs;
152
+use DBIx::NamedParams;
153
+use EscapeSlash;
154
+
155
+$YAML::Syck::ImplicitUnicode = 1;
156
+
157
+my $charsetConsole = 'CP932';
158
+my $charsetFile = 'UTF-8';
159
+
160
+binmode( STDIN, ":encoding($charsetConsole)" );
161
+binmode( STDOUT, ":encoding($charsetConsole)" );
162
+binmode( STDERR, ":encoding($charsetConsole)" );
163
+
164
+my $DB_Connect_yaml = './DB_Connect.yaml';
165
+my $DB_Tables_yaml = './DB_Schema.yaml';
166
+
167
+# ""で括る文字列型
168
+my $StrType = join( "|", qw(
169
+ CHAR GUID UNKNOWN_TYPE VARCHAR WCHAR WLONGVARCHAR WVARCHAR
170
+) );
171
+
172
+my $DB_Connect = YAML::Syck::LoadFile( $DB_Connect_yaml )
173
+ or die( "$DB_Connect_yaml: $!\n" );
174
+foreach( %{$DB_Connect} ){
175
+ $DB_Connect->{'DSN'} =~ s/_${_}_/$DB_Connect->{$_}/;
176
+}
177
+#print dump( $DB_Connect );
178
+
179
+my $DB_Tables = YAML::Syck::LoadFile( $DB_Tables_yaml )
180
+ or die( "$DB_Tables_yaml: $!\n" );
181
+#print dump( $DB_Tables );
182
+my @DB_TableNames = sort( keys( %{$DB_Tables} ) );
183
+
184
+my $dbh = DBI->connect(
185
+ "DBI:" . $DB_Connect->{'DSN'},
186
+ $DB_Connect->{'User'},
187
+ $DB_Connect->{'Password'},
188
+ $DB_Connect->{'Options'}
189
+) or die( "$DBI::errstr\n" );
190
+
191
+my %DrvTypeToSQLType = $dbh->driver_typename_map();
192
+
193
+my $count=0;
194
+my $TableNum = scalar(@DB_TableNames);
195
+
196
+foreach my $tbl ( @DB_TableNames ){
197
+ printf STDERR ( "%d/%d\t%s\n", ++$count, $TableNum, $tbl );
198
+ my @FieldName = map { ${$_ }{'COLUMN_NAME'}; } @{ $DB_Tables->{ $tbl } };
199
+ my @DataType = map { ${$_ }{'DATA_TYPE'}; } @{ $DB_Tables->{ $tbl } };
200
+
201
+ my $sql = "SELECT [" . join( "],[", @FieldName ) . "] FROM [$tbl];";
202
+ my $sth = $dbh->prepare( $sql ) or die( "$DBI::errstr\n" );
203
+ $sth->execute() or die( "$DBI::errstr\n" );
204
+
205
+ my $fout = './_DB/' . $tbl . '.txt';
206
+ open( my $fhout, ">:encoding($charsetFile)", encode( $charsetConsole, $fout ) )
207
+ or die( "$fout: $!\n" );
208
+
209
+ printf $fhout ( "\"%s\"\n", join( "\"\t\"", @FieldName ) );
210
+ do {
211
+ while( my @a = $sth->fetchrow_array ){
212
+ for( my $i=0; $i<@a; ++$i ){
213
+ no warnings 'uninitialized';
214
+ $a[$i] =~ s/\x00//g;
215
+ #$a[$i] =~ s/[\r\n\t]+$//;
216
+ $a[$i] = escapeslash( $a[$i] );
217
+ if ( !defined($a[$i]) ){
218
+ # NULL だったら
219
+ $a[$i] = "NULL";
220
+ } elsif ( $DrvTypeToSQLType{ $DataType[$i] } =~ /$StrType/ ){
221
+ # 文字列ならば
222
+ $a[$i] = '"' . $a[$i] . '"';
223
+ }
224
+ }
225
+ printf $fhout ( "%s\n", join( "\t", @a ) );
226
+ }
227
+ }while( $sth->{odbc_more_results} );
228
+ $sth->finish;
229
+
230
+ close( $fhout );
231
+}
232
+
233
+$dbh->disconnect;
234
+
235
+# EOF
236
+```
237
+
238
+### setTbl.pl
239
+```perl
240
+#!/usr/bin/perl
241
+# MSSQLサーバへデータ書込み
242
+# 2011/09/28 オートナンバー型非対応
243
+
244
+use strict;
245
+use warnings;
246
+use utf8;
247
+use Encode;
248
+use YAML::Syck;
249
+use FindBin::libs;
250
+use DBIx::NamedParams;
251
+use EscapeSlash;
252
+
253
+$YAML::Syck::ImplicitUnicode = 1;
254
+
255
+my $charsetConsole = 'CP932';
256
+my $charsetFile = 'UTF-8';
257
+
258
+binmode( STDIN, ":encoding($charsetConsole)" );
259
+binmode( STDOUT, ":encoding($charsetConsole)" );
260
+binmode( STDERR, ":encoding($charsetConsole)" );
261
+
262
+my $DB_Connect_yaml = './DB_Connect.yaml';
263
+my $DB_Tables_yaml = './DB_Schema.yaml';
264
+
265
+my $DB_Connect = YAML::Syck::LoadFile( $DB_Connect_yaml )
266
+ or die( "$DB_Connect_yaml: $!" );
267
+foreach( %{$DB_Connect} ){
268
+ $DB_Connect->{'DSN'} =~ s/_${_}_/$DB_Connect->{$_}/;
269
+}
270
+#print Dump( $DB_Connect );
271
+
272
+my $DB_Tables = YAML::Syck::LoadFile( $DB_Tables_yaml )
273
+ or die( "$DB_Tables_yaml: $!" );
274
+#print Dump( $DB_Tables );
275
+my @DB_TableNames = keys( %{$DB_Tables} );
276
+
277
+my $dbh = DBI->connect(
278
+ "DBI:" . $DB_Connect->{'DSN'},
279
+ $DB_Connect->{'User'},
280
+ $DB_Connect->{'Password'},
281
+ $DB_Connect->{'Options'}
282
+) or die( "$DBI::errstr\n" );
283
+
284
+#DBIx::NamedParams::debug_log( 'MSSQL_ImpExp.log' );
285
+
286
+my %DrvTypeToSQLType = $dbh->driver_typename_map();
287
+
288
+my $count=0;
289
+my $TableNum = scalar(@DB_TableNames);
290
+my $fNoLocalize = 0;
291
+
292
+foreach my $tbl ( @DB_TableNames ){
293
+ ++$count;
294
+ print "$count/$TableNum\t$tbl\n";
295
+ my( @field_org, @field_len, @field_type, @field_name_type, @field_prm );
296
+ foreach ( @{ $DB_Tables->{ $tbl } } ){
297
+ my $column_name = ${ $_ }{'COLUMN_NAME'};
298
+ my $data_type = ${ $_ }{'DATA_TYPE'};
299
+ my $name_type = ":$column_name-" . $DrvTypeToSQLType{ $data_type };
300
+ push( @field_org, $column_name );
301
+ push( @field_type, $data_type );
302
+ push( @field_len, ${ $_ }{'CHARACTER_MAXIMUM_LENGTH'} );
303
+ push( @field_name_type, $name_type );
304
+ push( @field_prm, "[$column_name]=$name_type" );
305
+ }
306
+ my $i = 0;
307
+ my %FN2I = map{ s/^"(.*)"$/$1/; $_ => $i++; } @field_org;
308
+ #print Dump( \%FN2I );
309
+
310
+ my $FieldList = "[" . join( "],[", @field_org ) . "]";
311
+ my $ValueList = join( ",", @field_name_type );
312
+ my $UpdateList = join( ",", @field_prm );
313
+
314
+ my $PrimaryFieldName = $field_org[0];
315
+ my $PrimaryFieldNameType = $field_name_type[0];
316
+ my $sql_InsOrUpd = qq{
317
+ IF NOT EXISTS (
318
+ SELECT $FieldList
319
+ FROM [$tbl]
320
+ WHERE [$PrimaryFieldName] = $PrimaryFieldNameType
321
+ )
322
+ BEGIN
323
+ INSERT INTO [$tbl]
324
+ ($FieldList)
325
+ VALUES ($ValueList)
326
+ END
327
+ ELSE
328
+ BEGIN
329
+ UPDATE [$tbl]
330
+ SET $UpdateList
331
+ WHERE [$PrimaryFieldName] = $PrimaryFieldNameType
332
+ END;
333
+ };
334
+ #warn "$sql_InsOrUpd\n";
335
+ #exit();
336
+
337
+ my $sth = $dbh->prepare_ex( $sql_InsOrUpd )
338
+ or die( "$DBI::errstr\n" );
339
+
340
+ my $fin = './_DB/' . $tbl . '.txt';
341
+ open( my $fhin, "<:encoding($charsetFile)", encode( $charsetConsole, $fin ) )
342
+ or die( "$fin: $!\n" );
343
+ <$fhin>; # ヘッダ行を捨てる
344
+ my @DB_Body = <$fhin>;
345
+ close( $fhin );
346
+ chomp( @DB_Body );
347
+
348
+ foreach my $row ( @DB_Body ){
349
+ #warn $row."\n";
350
+ my @param = split( "\t", $row );
351
+ map{ if( /^NULL$/i ){ undef($_) } else { s/^"(.*)"$/$1/; } } @param;
352
+ for( my $i=0; $i<@param; ++$i ){
353
+ if (
354
+ $field_len[ $i ] && ( $field_len[ $i ] > 0 )
355
+ && $param[ $i ] && ( length( $param[ $i ] ) > $field_len[ $i ] )
356
+ ){
357
+ print "Too long. ID:$param[0], $field_org[$i]: $param[$i]\n";
358
+ $param[ $i ] = substr( $param[ $i ], 0, $field_len[ $i ] );
359
+ }
360
+ }
361
+ my %bind = ();
362
+ for( my $i=0; $i<@field_org; ++$i ){
363
+ $bind{ $field_org[ $i ] } = unescapeslash( $param[ $i ] );
364
+ }
365
+ #print Dump( \%bind ) ."\n";
366
+ $sth->bind_param_ex( \%bind );
367
+ #exit();
368
+ $sth->execute() or die( "$DBI::errstr\n" );
369
+ }
370
+ $sth->finish;
371
+}
372
+$dbh->disconnect;
373
+
374
+# EOF
375
+```
376
+
377
+### makeTable.sql
378
+```
379
+USE [TestDB]
380
+GO
381
+
382
+/****** Object: Table [dbo].[会員Table] Script Date: 08/15/2009 04:13:13 ******/
383
+SET ANSI_NULLS ON
384
+GO
385
+
386
+SET QUOTED_IDENTIFIER ON
387
+GO
388
+
389
+CREATE TABLE [dbo].[会員Table](
390
+ [ID] [int] NOT NULL,
391
+ [姓] [nvarchar](50) NOT NULL,
392
+ [名] [nvarchar](50) NOT NULL,
393
+ [誕生日] [date] NOT NULL,
394
+ [性別] [int] NOT NULL,
395
+ [Email] [nvarchar](50) NULL,
396
+ [電話番号] [nvarchar](50) NULL,
397
+ [郵便番号] [nvarchar](8) NULL,
398
+ [住所1] [nvarchar](max) NULL,
399
+ [住所2] [nvarchar](max) NULL,
400
+ [クラスレベル] [int] NOT NULL,
401
+ [前回ログイン] [datetime] NULL,
402
+ [備考] [nvarchar](max) NULL,
403
+ CONSTRAINT [PK_会員Table] PRIMARY KEY CLUSTERED
404
+(
405
+ [ID] ASC
406
+)WITH (PAD_INDEX = OFF, STATISTICS_NORECOMPUTE = OFF, IGNORE_DUP_KEY = OFF, ALLOW_ROW_LOCKS = ON, ALLOW_PAGE_LOCKS = ON) ON [PRIMARY]
407
+) ON [PRIMARY]
408
+
409
+GO
410
+
411
+/****** Object: Table [dbo].[性別Table] Script Date: 08/15/2009 04:13:59 ******/
412
+SET ANSI_NULLS ON
413
+GO
414
+
415
+SET QUOTED_IDENTIFIER ON
416
+GO
417
+
418
+CREATE TABLE [dbo].[性別Table](
419
+ [ID] [int] NOT NULL,
420
+ [性別] [nvarchar](10) NOT NULL,
421
+ CONSTRAINT [PK_性別Table] PRIMARY KEY CLUSTERED
422
+(
423
+ [ID] ASC
424
+)WITH (PAD_INDEX = OFF, STATISTICS_NORECOMPUTE = OFF, IGNORE_DUP_KEY = OFF, ALLOW_ROW_LOCKS = ON, ALLOW_PAGE_LOCKS = ON) ON [PRIMARY]
425
+) ON [PRIMARY]
426
+
427
+GO
428
+
429
+/****** Object: Table [dbo].[クラスレベルTable] Script Date: 08/15/2009 04:14:09 ******/
430
+SET ANSI_NULLS ON
431
+GO
432
+
433
+SET QUOTED_IDENTIFIER ON
434
+GO
435
+
436
+CREATE TABLE [dbo].[クラスレベルTable](
437
+ [ID] [int] NOT NULL,
438
+ [クラスレベル] [nvarchar](30) NOT NULL,
439
+ CONSTRAINT [PK_クラスレベルTable] PRIMARY KEY CLUSTERED
440
+(
441
+ [ID] ASC
442
+)WITH (PAD_INDEX = OFF, STATISTICS_NORECOMPUTE = OFF, IGNORE_DUP_KEY = OFF, ALLOW_ROW_LOCKS = ON, ALLOW_PAGE_LOCKS = ON) ON [PRIMARY]
443
+) ON [PRIMARY]
444
+
445
+GO
446
+```
447
+
448
+## Link
449
+- [[MS SQL Server|MSSQLSrv]]
450
+- [[Perl/EscapeSlash]]
451
+- [[Perl/DBIx-NamedParams]]
452
+- [[Perl/キーワード置換]]
453
+
454
+- [SQL Server - 情報スキーマ ビュー](http://msdn.microsoft.com/ja-jp/library/ms186778.aspx)
455
+ - [TABLES](http://msdn.microsoft.com/ja-jp/library/ms186224.aspx)
456
+ - [COLUMNS](http://msdn.microsoft.com/ja-jp/library/ms188348.aspx)
457
+- [sys.columns](http://msdn.microsoft.com/ja-jp/library/ms176106.aspx)
458
+- [データ型](http://msdn.microsoft.com/ja-jp/library/ms187752.aspx)
459
+
460
+- [MDB生成/テーブル定義取得ツール](http://www.asahi-net.or.jp/~ef2o-inue/download/sub09_010_070.html)
461
+
462
+- [「IDENTITY属性を持つ列を探すには」をお題にやったことをBlogる](http://d.hatena.ne.jp/CAMUSs_BLACKBOARD/20040618) @ [CAMUS’s BLACKBOARD](http://d.hatena.ne.jp/CAMUSs_BLACKBOARD/)
463
+```
464
+EXEC sp_MShelpcolumns [テーブル名]
0 465
\ No newline at end of file
Perl/MailForm.md
... ...
@@ -0,0 +1,333 @@
1
+[[_TOC_]]
2
+----
3
+# 概要
4
+- ファイルが添付できるメールフォーム。
5
+- 宛先は config.yaml で指定する。フォームから宛先の追加も可能。
6
+- 名前, 宛先は Cookie に保存される。(1ヶ月)
7
+- アクセス元のホスト名を表示。
8
+- cookie の path を設定。
9
+
10
+# ソース
11
+- [MailForm.zip](MailForm.zip)
12
+
13
+## index.cgi
14
+```perl
15
+#!/usr/bin/perl
16
+# MailForm
17
+# Web フォームから入力されたコメントとファイルを、
18
+# 特定の Email アドレスへ添付ファイル付きで送信する。
19
+
20
+use strict;
21
+use warnings;
22
+use utf8;
23
+use Encode;
24
+use YAML::Syck;
25
+use JSON::Syck;
26
+use FindBin;
27
+use CGI::Pretty qw( -no_xhtml *table ); # //HTML 4.01 Transitional//EN
28
+use CGI::Cookie;
29
+use Email::Sender::Simple qw( sendmail );
30
+use Email::Sender::Transport::SMTP;
31
+use Email::MIME;
32
+use Email::MIME::Creator;
33
+use Net::DNS::Resolver;
34
+
35
+$YAML::Syck::ImplicitUnicode = 1;
36
+$YAML::Syck::ImplicitTyping = 1;
37
+$YAML::Syck::Headless = 1;
38
+$JSON::Syck::ImplicitUnicode = 1;
39
+
40
+my $charset_console = 'UTF-8';
41
+my $charset_file = 'UTF-8';
42
+my $charset_input = 'UTF-8';
43
+
44
+#binmode( STDIN, ":encoding($charset_console)" ); # バイナリファイルが化ける
45
+binmode( STDIN, ":raw" ); # バイナリファイルをアップロードする場合に必要
46
+binmode( STDOUT, ":encoding($charset_console)" );
47
+binmode( STDERR, ":encoding($charset_console)" );
48
+
49
+my $base_path = $FindBin::RealBin . '/';
50
+my $config_file = $base_path . 'config.yaml';
51
+my $cgi_name = 'MailForm';
52
+my $cookie_name = $cgi_name;
53
+
54
+my $q = new CGI;
55
+$q->charset( $charset_console );
56
+my $br = $q->br();
57
+
58
+$JSON::Syck::ImplicitUnicode = 1;
59
+my $cookies = CGI::Cookie->fetch;
60
+my $cookie = ( $cookies && $cookies->{$cookie_name} )
61
+ ? JSON::Syck::Load( $cookies->{$cookie_name}->value || '{}' )
62
+ : {} ;
63
+# クッキーにゴミデータが入っていた場合に消去
64
+if ( ref( $cookie ) ne 'HASH' ){
65
+ $cookie = {};
66
+}
67
+
68
+my $config = YAML::Syck::LoadFile( $config_file ) or die( "$config_file: $!\n" );
69
+
70
+my $command = $q->param( 'Command' ) || '';
71
+my $comment = decode( $charset_input, $q->param( 'Comment' ) || '' );
72
+my $file_name = $q->param( 'Attachment' ) || '';
73
+my $file_type = $q->uploadInfo( $file_name )
74
+ ? $q->uploadInfo( $file_name )->{ 'Content-Type' } || ''
75
+ : '';
76
+$file_name = decode( $charset_input, $file_name );
77
+my $file_body = '';
78
+if ( my $lightweight_fh = $q->upload( 'Attachment' ) ){
79
+ my $io_handle = $lightweight_fh->handle;
80
+ while ( my $bytesread = $io_handle->read( my $buffer, 1024 ) ){
81
+ $file_body .= $buffer;
82
+ }
83
+}
84
+my $user_name = decode( $charset_input, $q->param( 'UserName' ) || '' )
85
+ || $cookie->{ 'UserName' } || '';
86
+my $user_email = decode( $charset_input, $q->param( 'UserEmail' ) || '' )
87
+ || $cookie->{ 'UserEmail' } || '';
88
+
89
+$cookie = {
90
+ 'UserName' => $user_name,
91
+ 'UserEmail' => $user_email,
92
+};
93
+
94
+my $remote_ip = $ENV{ 'REMOTE_ADDR' };
95
+my $remote_name = getHostName( $remote_ip );
96
+
97
+print makeHeader();
98
+if ( $command eq 'doPost' ){
99
+ my $mail_result;
100
+ if ( length( $file_body ) > 0 ){
101
+ $mail_result = sendMail();
102
+ }
103
+ print showPostedInfo();
104
+} else {
105
+ print makeForm();
106
+}
107
+print makeFooter();
108
+
109
+exit;
110
+
111
+sub makeHeader
112
+{
113
+ my $ret = '';
114
+ $JSON::Syck::ImplicitUnicode = 0;
115
+ my $cookie_header = CGI::Cookie->new(
116
+ -name => $cookie_name,
117
+ -value => JSON::Syck::Dump( $cookie ),
118
+ -expires => '+1M',
119
+ -path => $ENV{'REQUEST_URI'},
120
+ );
121
+ $ret .= $q->header( -cookie => [ $cookie_header ] );
122
+ $ret .= $q->start_html(
123
+ -title => $cgi_name,
124
+ -lang => 'ja-JP',
125
+ -head => [
126
+ $q->meta( { -http_equiv => 'Content-style-type', -content => 'text/css' } ),
127
+ $q->meta( { -http_equiv => 'Content-script-type', -content => 'text/javascript' } ),
128
+ ],
129
+ -style => [ { -src => $config->{ 'CSSFile' } }, ],
130
+ );
131
+ $ret .= $q->h1( $q->a( { -href => $q->url }, $cgi_name ) );
132
+# $ret .= $q->pre( YAML::Syck::Dump( $cookie ) );
133
+ return $ret;
134
+}
135
+
136
+sub makeFooter
137
+{
138
+ my $ret = '';
139
+ $ret .= $q->end_html . "\n";
140
+ return $ret;
141
+}
142
+
143
+sub makeForm
144
+{
145
+ my $ret = '';
146
+ $ret .= $q->start_multipart_form( -action => $q->url, );
147
+ $ret .= $q->table(
148
+ $q->Tr(
149
+ $q->th( '名前' ),
150
+ $q->td( $q->textfield(
151
+ -name => 'UserName',
152
+ -default => $user_name,
153
+ -size => 60,
154
+ -override => 1,
155
+ ) ),
156
+ ),
157
+ $q->Tr(
158
+ $q->th( 'Email' ),
159
+ $q->td( $q->textfield(
160
+ -name => 'UserEmail',
161
+ -default => $user_email,
162
+ -size => 60,
163
+ -override => 1,
164
+ ) ),
165
+ ),
166
+ $q->Tr(
167
+ $q->th( '添付ファイル' ),
168
+ $q->td( $q->filefield(
169
+ -name => 'Attachment',
170
+ -default => '',
171
+ -size => 60,
172
+ -override => 1,
173
+ ) ),
174
+ ),
175
+ $q->Tr(
176
+ $q->th( 'コメント' ),
177
+ $q->td( $q->textarea(
178
+ -name => 'Comment',
179
+ -default => '',
180
+ -columns => 60,
181
+ -rows => 5,
182
+ -override => 1,
183
+ ) ),
184
+ ),
185
+ $q->Tr(
186
+ $q->th( 'アクセス元' ),
187
+ $q->td( "$remote_ip; $remote_name" ),
188
+ ),
189
+ $q->Tr( $q->td(
190
+ { -colspan => 2, -align => 'center', },
191
+ $q->submit( -name => 'Submit', -value => 'Submit' ),
192
+ ), ),
193
+ );
194
+ $ret .= $q->hidden( -name => 'Command', -default => 'doPost', -override => 1 );
195
+ $ret .= $q->end_multipart_form;
196
+ return $ret;
197
+}
198
+
199
+sub showPostedInfo
200
+{
201
+ my $ret = '';
202
+ $ret .= $q->table(
203
+ $q->Tr( $q->th( '名前' ), $q->td( $user_name ), ),
204
+ $q->Tr( $q->th( 'Email' ), $q->td( $user_email ), ),
205
+ $q->Tr( $q->th( 'コメント' ), $q->td( $comment ), ),
206
+ $q->Tr( $q->th( 'アクセス元' ), $q->td( "$remote_ip; $remote_name" ), ),
207
+ $q->Tr( $q->th( 'ファイル名' ), $q->td( $file_name ), ),
208
+ $q->Tr( $q->th( 'ファイルタイプ' ), $q->td( $file_type ), ),
209
+ $q->Tr( $q->th( 'ファイルサイズ' ), $q->td( length( $file_body ), ), ),
210
+ $q->Tr( $q->th( 'Hex' ), $q->td( dumpStr( $file_body ) ), ),
211
+ );
212
+ return $ret;
213
+}
214
+
215
+sub dumpStr
216
+{
217
+ my $dump_limit = 64;
218
+ my $str = shift || '';
219
+ my $head = shift || $dump_limit;
220
+ if ( $head > $dump_limit ){
221
+ $head = $dump_limit;
222
+ }
223
+ if ( $head > length( $str ) ){
224
+ $head = length( $str );
225
+ }
226
+ $str = substr( $str, 0, $head );
227
+ my $ret = '';
228
+ my @buffer = ();
229
+ for( my $i=0; $i<$head; $i+=16 ){
230
+ for( my $j=0; $j<16 && ( $i + $j < $head ); ++$j ){
231
+ push( @buffer, unpack( "H*", substr( $str, $i + $j, 1 ) ) );
232
+ }
233
+ push( @buffer, $br );
234
+ }
235
+ $ret = join( " ", @buffer );
236
+ return $ret;
237
+}
238
+
239
+sub sendMail
240
+{
241
+ my $body = "名前:\n${user_name}\n\nEmail:\n${user_email}\n\nコメント:\n${comment}\n\n"
242
+ . "アクセス元:\n${remote_ip}; ${remote_name}\n\n";
243
+ my $email = Email::MIME->create(
244
+ attributes => {
245
+ content_type => 'text/plain',
246
+ charset => 'UTF-8',
247
+ encoding => '8bit',
248
+ #encoding => 'base64',
249
+ },
250
+ header_str => [
251
+ From => $config->{ 'FromAddress' },
252
+ To => join( ", ", $config->{ 'ToAddress' }, $user_email, ) ,
253
+ Subject => $config->{ 'MailTitle' },
254
+ ],
255
+ parts => [
256
+ Email::MIME->create(
257
+ attributes => {
258
+ content_type => 'text/plain',
259
+ charset => 'UTF-8',
260
+ #encoding => '8bit',
261
+ encoding => 'base64',
262
+ },
263
+ body => encode( $charset_input, $body ),
264
+ ),
265
+ Email::MIME->create(
266
+ attributes => {
267
+ content_type => $file_type,
268
+ name => encode( 'MIME-Header', $file_name ),
269
+ filename => encode( 'MIME-Header', $file_name ),
270
+ encoding => 'base64',
271
+ disposition => 'attachment',
272
+ },
273
+ body => $file_body,
274
+ ),
275
+ ],
276
+ );
277
+
278
+ return sendmail($email);
279
+}
280
+
281
+sub getHostName
282
+{
283
+ my $ip_address = shift || '';
284
+ my $ret = '';
285
+
286
+ my $resolver = Net::DNS::Resolver->new;
287
+ if ( my $ans = $resolver->query( $ip_address ) ){
288
+ for my $rr ( $ans->answer ){
289
+ #print $rr->string, "\n";
290
+ if ( $rr->type eq 'PTR' ){
291
+ $ret = $rr->ptrdname;
292
+ last;
293
+ }
294
+ }
295
+ }
296
+
297
+ return $ret;
298
+}
299
+
300
+# EOF
301
+```
302
+
303
+## config.yaml
304
+```
305
+# MailForm 設定
306
+FromAddress: '"メールフォーム" <MailForm@example.com>'
307
+ToAddress: '"YourAddress" <YourAddress@example.com>'
308
+MailTitle: "レポート"
309
+CSSFile: "/take.css"
310
+```
311
+
312
+# mod_security
313
+- セッション使わず、クッキーの中にユーザ名と Email がそのまま入っていて、mod_security の crs でエラーになる。
314
+- 該当するルール
315
+ - file: modsecurity_crs_41_sql_injection_attacks.conf
316
+ - id: 960024, 981172, 981243, 981245, 981246, 981257
317
+
318
+# リンク
319
+- [CPAN:Email-Sender](http://search.cpan.org/dist/Email-Sender)
320
+ - [CPAN:Email-Sender/lib/Email/Sender/Manual/QuickStart.pm](http://search.cpan.org/dist/Email-Sender/lib/Email/Sender/Manual/QuickStart.pm)
321
+- [CPAN:Email-Address](http://search.cpan.org/dist/Email-Address)
322
+- [CPAN:Email-MIME](http://search.cpan.org/dist/Email-MIME)
323
+- [CPAN:CGI](http://search.cpan.org/dist/CGI)
324
+ - [CPAN:CGI/lib/CGI.pm](http://search.cpan.org/dist/CGI/lib/CGI.pm)
325
+ - [CPAN:CGI/lib/CGI/Cookie.pm](http://search.cpan.org/dist/CGI/lib/CGI/Cookie.pm)
326
+- [CPAN:CGI-Session](http://search.cpan.org/dist/CGI-Session)
327
+ - [CPAN:CGI-Session/lib/CGI/Session/Tutorial.pm](http://search.cpan.org/dist/CGI-Session/lib/CGI/Session/Tutorial.pm)
328
+
329
+- [モダンPerlの世界へようこそ … 技術評論社](http://gihyo.jp/dev/serial/01/modern-perl)
330
+ - [第20回 Email::Sender:メールを送信する](http://gihyo.jp/dev/serial/01/modern-perl/0020)
331
+
332
+- [404 Blog Not Found](http://blog.livedoor.jp/dankogai/)
333
+ - [ドコモもauはとりあえず"da..me."@を受け取れるようにしとくべし](http://blog.livedoor.jp/dankogai/archives/50954045.html)
0 334
\ No newline at end of file
Perl/MatchList.md
... ...
@@ -0,0 +1,79 @@
1
+[[_TOC_]]
2
+----
3
+# 概要
4
+- 正規表現によるマッチ結果をリスト化する。
5
+- リストコンテキストで /g を付けて評価する。
6
+
7
+# ソース
8
+- [matchlist.zip](matchlist.zip)
9
+```perl
10
+# マッチ結果のリスト化
11
+# リストコンテキストで /g を付けて評価する。
12
+
13
+use strict;
14
+use warnings;
15
+use utf8;
16
+use Encode;
17
+
18
+#my $charsetConsole = 'UTF-8';
19
+my $charsetConsole = 'CP932';
20
+my $charsetFile = 'UTF-8';
21
+
22
+binmode( STDIN, ":encoding($charsetConsole)" );
23
+binmode( STDOUT, ":encoding($charsetConsole)" );
24
+binmode( STDERR, ":encoding($charsetConsole)" );
25
+
26
+# 次の文字列を「key=val」として分解する
27
+# key は空白を含みうる。val は空白を含まない。
28
+# 「t u」はマッチしないので無視される
29
+my $line = "aa = bb cc dd= ee ff gg hh= ii jj kk = ll mm=nn o= p q r= s t u";
30
+print "${line}\n\n";
31
+
32
+# ペア単位でリスト化した後、key/valに分解。順序は保存される。
33
+foreach my $pair ( $line =~ /[^=]*\S\s*=\s*\S+\s*/g ){
34
+ my( $key, $val ) = ( $pair =~ /^([^=]*\S)\s*=\s*(\S+)\s*$/ );
35
+ print "key:'${key}'\tval:'${val}'\n";
36
+}
37
+print "\n";
38
+
39
+# マッチ結果リストをハッシュとして受ける。順序は保存されない。
40
+my %pairs = ( $line =~ /([^=]*\S)\s*=\s*(\S+)\s*/g );
41
+foreach my $key ( keys( %pairs ) ){
42
+ print "key:'${key}'\tval:'${pairs{$key}}'\n";
43
+}
44
+
45
+# EOF
46
+```
47
+
48
+# 出力結果
49
+```
50
+aa = bb cc dd= ee ff gg hh= ii jj kk = ll mm=nn o= p q r= s t u
51
+
52
+key:'aa' val:'bb'
53
+key:'cc dd' val:'ee'
54
+key:'ff gg hh' val:'ii'
55
+key:'jj kk' val:'ll'
56
+key:'mm' val:'nn'
57
+key:'o' val:'p'
58
+key:'q r' val:'s'
59
+
60
+key:'jj kk' val:'ll'
61
+key:'mm' val:'nn'
62
+key:'q r' val:'s'
63
+key:'ff gg hh' val:'ii'
64
+key:'cc dd' val:'ee'
65
+key:'aa' val:'bb'
66
+key:'o' val:'p'
67
+```
68
+
69
+# リンク
70
+- [[Perl/ApacheErrorLogFormatter]]
71
+
72
+- http://perldoc.jp/
73
+ - [Perl の正規表現のチュートリアル](http://perldoc.jp/docs/perl/5.14.1/perlretut.pod)
74
+
75
+- [Perl programming documentation](http://perldoc.perl.org/)
76
+ - [perlrequick](http://perldoc.perl.org/perlrequick.html)
77
+
78
+- [DebugIto's](http://debugitos.main.jp/)
79
+ - [一つの正規表現パターンで複数回マッチ](http://debugitos.main.jp/?Perl/Tips#y2638d73)
0 80
\ No newline at end of file
Perl/MySQL-BIT.md
... ...
@@ -0,0 +1,291 @@
1
+# MySQL BIT型
2
+[[_TOC_]]
3
+
4
+## 概要
5
+- DBI から BIT 型にバインドする際には pack('C*',$x) してからバインドするべし。
6
+- BIT は TINYINT として実装されている。
7
+- 格納できる数値より大きな値を格納しようとした場合は全ビットが1になった値が格納される。
8
+
9
+## ソース
10
+- [testBit.zip](testBit.zip)
11
+
12
+### testBit.pl
13
+```perl
14
+#!/usr/bin/perl
15
+# testBit.pl
16
+# MySQL の Bit 型の取り扱いテスト
17
+
18
+use strict;
19
+use warnings;
20
+use utf8;
21
+use Encode;
22
+use YAML::Syck;
23
+use JSON::Syck;
24
+use lib qw( /home/Shared/lib/ );
25
+use DBIx::NamedParams;
26
+
27
+$YAML::Syck::ImplicitUnicode = 1;
28
+$YAML::Syck::ImplicitTyping = 1;
29
+$YAML::Syck::Headless = 1;
30
+
31
+my $charsetConsole = 'UTF-8';
32
+#my $charsetConsole = 'CP932';
33
+my $charsetFile = 'UTF-8';
34
+
35
+binmode( STDIN, ":encoding($charsetConsole)" );
36
+binmode( STDOUT, ":encoding($charsetConsole)" );
37
+binmode( STDERR, ":encoding($charsetConsole)" );
38
+
39
+my $config_file = 'config.yaml';
40
+
41
+my $sql_insert = qq{
42
+ INSERT INTO
43
+ `test_bit`
44
+ ( `packtype`, `value`, `bit1`, `bit4`, `bit8`, `bit12`, `bit16` )
45
+ VALUES
46
+ ( :packtype-VARCHAR, :value-VARCHAR, :bit1-BIT, :bit4-BIT, :bit8-BIT, :bit12-BIT, :bit16-BIT );
47
+};
48
+my $sql_select = qq{
49
+ SELECT `id`, `packtype`, `value`, `bit1`, `bit4`, `bit8`, `bit12`, `bit16`
50
+ FROM `test_bit`
51
+ ORDER BY `id`
52
+};
53
+
54
+my @input_types = qw( N B C );
55
+my @input_values = qw(
56
+ 0 1 10 100 1000 10000 100000000 100000000000 1000000000000 10000000000000000
57
+ 01 001 0001 00001 000000001 000000000001 0000000000001 00000000000000001
58
+ 010 0010 00010 000010 0000000010 0000000000010 00000000000010 000000000000000010
59
+ 2 3 4 5 6 7 8 10 12 15 16 17 255 256 512 513
60
+);
61
+
62
+my $config = YAML::Syck::LoadFile( $config_file )
63
+ or die( "$config_file: $!\n" );
64
+foreach( keys( %{$config} ) ){
65
+ $config->{'DSN'} =~ s/_${_}_/$config->{$_}/;
66
+}
67
+
68
+my $dbh = DBI->connect(
69
+ 'DBI:' . $config->{'DSN'},
70
+ $config->{'User'},
71
+ $config->{'Password'},
72
+ $config->{'Options'}
73
+) or die( "$DBI::errstr\n" );
74
+
75
+my $sth_insert = $dbh->prepare_ex( $sql_insert ) or die( "$DBI::errstr\n" );
76
+foreach my $type ( @input_types ){
77
+ foreach my $value ( @input_values ){
78
+ my $params = { packtype => $type, value => $value };
79
+ foreach my $bit ( qw( 1 4 8 12 16 ) ){
80
+ if ( $type eq 'B' ){
81
+ $params->{ "bit${bit}" } = pack( "B${bit}", $value );
82
+ } elsif( $type eq 'C' ){
83
+ $params->{ "bit${bit}" } = pack( 'C*', int2array( $value ) );
84
+ } else {
85
+ $params->{ "bit${bit}" } = $value;
86
+ }
87
+ }
88
+ $sth_insert->bind_param_ex( $params );
89
+ $sth_insert->execute() or die( "$DBI::errstr\n" );
90
+ }
91
+}
92
+$sth_insert->finish;
93
+
94
+my $sth_select = $dbh->prepare_ex( $sql_select ) or die( "$DBI::errstr\n" );
95
+$sth_select->execute() or die( "$DBI::errstr\n" );
96
+my @result = ();
97
+while( my $array_ref = $sth_select->fetchrow_arrayref ){
98
+ my @result2 = split( "\n", Dump( $array_ref ) );
99
+ push( @result, join( "\t", map{ /^\s*-\s*(.*)$/msx; $1; } @result2 ) );
100
+}
101
+$sth_select->finish;
102
+
103
+$dbh->disconnect;
104
+
105
+print join( "\n", @result ) . "\n";
106
+
107
+exit;
108
+
109
+sub int2array
110
+{
111
+ my $arg = shift || 0;
112
+ my @ret = ();
113
+ if ( !!$arg ){
114
+ while( !!$arg ){
115
+ my $m = $arg & 0xff;
116
+ unshift( @ret, $m );
117
+ $arg >>= 8;
118
+ }
119
+ } else {
120
+ @ret = ( 0 );
121
+ }
122
+ return @ret;
123
+}
124
+
125
+# EOF
126
+```
127
+
128
+## 結果
129
+
130
+### 無変換
131
+| id | Type | 値 | bit1 | bit4 | bit8 | bit12 | bit16 |
132
+| --- | --- | --- | --- | --- | --- | --- | --- |
133
+| 1 | 'N' | | "\x01" | "\x0F" | | "\00" | "\00" |
134
+| 2 | 'N' | 1 | "\x01" | "\x0F" | 1 | "\01" | "\01" |
135
+| 3 | 'N' | 10 | "\x01" | "\x0F" | "\xFF" | "\x0F\xFF" | 10 |
136
+| 4 | 'N' | 100 | "\x01" | "\x0F" | "\xFF" | "\x0F\xFF" | "\xFF\xFF" |
137
+| 5 | 'N' | 1000 | "\x01" | "\x0F" | "\xFF" | "\x0F\xFF" | "\xFF\xFF" |
138
+| 6 | 'N' | 10000 | "\x01" | "\x0F" | "\xFF" | "\x0F\xFF" | "\xFF\xFF" |
139
+| 7 | 'N' | 100000000 | "\x01" | "\x0F" | "\xFF" | "\x0F\xFF" | "\xFF\xFF" |
140
+| 8 | 'N' | '100000000000' | "\x01" | "\x0F" | "\xFF" | "\x0F\xFF" | "\xFF\xFF" |
141
+| 9 | 'N' | '1000000000000' | "\x01" | "\x0F" | "\xFF" | "\x0F\xFF" | "\xFF\xFF" |
142
+| 10 | 'N' | '10000000000000000' | "\x01" | "\x0F" | "\xFF" | "\x0F\xFF" | "\xFF\xFF" |
143
+| 11 | 'N' | '01' | "\x01" | "\x0F" | "\xFF" | "\x0F\xFF" | '01' |
144
+| 12 | 'N' | '001' | "\x01" | "\x0F" | "\xFF" | "\x0F\xFF" | "\xFF\xFF" |
145
+| 13 | 'N' | '0001' | "\x01" | "\x0F" | "\xFF" | "\x0F\xFF" | "\xFF\xFF" |
146
+| 14 | 'N' | '00001' | "\x01" | "\x0F" | "\xFF" | "\x0F\xFF" | "\xFF\xFF" |
147
+| 15 | 'N' | '000000001' | "\x01" | "\x0F" | "\xFF" | "\x0F\xFF" | "\xFF\xFF" |
148
+| 16 | 'N' | '000000000001' | "\x01" | "\x0F" | "\xFF" | "\x0F\xFF" | "\xFF\xFF" |
149
+| 17 | 'N' | '0000000000001' | "\x01" | "\x0F" | "\xFF" | "\x0F\xFF" | "\xFF\xFF" |
150
+| 18 | 'N' | '00000000000000001' | "\x01" | "\x0F" | "\xFF" | "\x0F\xFF" | "\xFF\xFF" |
151
+| 19 | 'N' | '010' | "\x01" | "\x0F" | "\xFF" | "\x0F\xFF" | "\xFF\xFF" |
152
+| 20 | 'N' | '0010' | "\x01" | "\x0F" | "\xFF" | "\x0F\xFF" | "\xFF\xFF" |
153
+| 21 | 'N' | '00010' | "\x01" | "\x0F" | "\xFF" | "\x0F\xFF" | "\xFF\xFF" |
154
+| 22 | 'N' | '000010' | "\x01" | "\x0F" | "\xFF" | "\x0F\xFF" | "\xFF\xFF" |
155
+| 23 | 'N' | '0000000010' | "\x01" | "\x0F" | "\xFF" | "\x0F\xFF" | "\xFF\xFF" |
156
+| 24 | 'N' | '0000000000010' | "\x01" | "\x0F" | "\xFF" | "\x0F\xFF" | "\xFF\xFF" |
157
+| 25 | 'N' | '00000000000010' | "\x01" | "\x0F" | "\xFF" | "\x0F\xFF" | "\xFF\xFF" |
158
+| 26 | 'N' | '000000000000000010' | "\x01" | "\x0F" | "\xFF" | "\x0F\xFF" | "\xFF\xFF" |
159
+| 27 | 'N' | 2 | "\x01" | "\x0F" | 2 | "\02" | "\02" |
160
+| 28 | 'N' | 3 | "\x01" | "\x0F" | 3 | "\03" | "\03" |
161
+| 29 | 'N' | 4 | "\x01" | "\x0F" | 4 | "\04" | "\04" |
162
+| 30 | 'N' | 5 | "\x01" | "\x0F" | 5 | "\05" | "\05" |
163
+| 31 | 'N' | 6 | "\x01" | "\x0F" | 6 | "\06" | "\06" |
164
+| 32 | 'N' | 7 | "\x01" | "\x0F" | 7 | "\07" | "\07" |
165
+| 33 | 'N' | 8 | "\x01" | "\x0F" | 8 | "\08" | "\08" |
166
+| 34 | 'N' | 10 | "\x01" | "\x0F" | "\xFF" | "\x0F\xFF" | 10 |
167
+| 35 | 'N' | 12 | "\x01" | "\x0F" | "\xFF" | "\x0F\xFF" | 12 |
168
+| 36 | 'N' | 15 | "\x01" | "\x0F" | "\xFF" | "\x0F\xFF" | 15 |
169
+| 37 | 'N' | 16 | "\x01" | "\x0F" | "\xFF" | "\x0F\xFF" | 16 |
170
+| 38 | 'N' | 17 | "\x01" | "\x0F" | "\xFF" | "\x0F\xFF" | 17 |
171
+| 39 | 'N' | 255 | "\x01" | "\x0F" | "\xFF" | "\x0F\xFF" | "\xFF\xFF" |
172
+| 40 | 'N' | 256 | "\x01" | "\x0F" | "\xFF" | "\x0F\xFF" | "\xFF\xFF" |
173
+| 41 | 'N' | 512 | "\x01" | "\x0F" | "\xFF" | "\x0F\xFF" | "\xFF\xFF" |
174
+| 42 | 'N' | 513 | "\x01" | "\x0F" | "\xFF" | "\x0F\xFF" | "\xFF\xFF" |
175
+
176
+### pack('Bn',$x)
177
+| id | Type | 値 | bit1 | bit4 | bit8 | bit12 | bit16 |
178
+| --- | --- | --- | --- | --- | --- | --- | --- |
179
+| 43 | B | | "\0" | "\0" | "\0" | "\0\0" | "\0\0" |
180
+| 44 | B | 1 | "\x01" | "\x0F" | "\x80" | "\x0F\xFF" | "\x80\0" |
181
+| 45 | B | 10 | "\x01" | "\x0F" | "\x80" | "\x0F\xFF" | "\x80\0" |
182
+| 46 | B | 100 | "\x01" | "\x0F" | "\x80" | "\x0F\xFF" | "\x80\0" |
183
+| 47 | B | 1000 | "\x01" | "\x0F" | "\x80" | "\x0F\xFF" | "\x80\0" |
184
+| 48 | B | 10000 | "\x01" | "\x0F" | "\x80" | "\x0F\xFF" | "\x80\0" |
185
+| 49 | B | 100000000 | "\x01" | "\x0F" | "\x80" | "\x0F\xFF" | "\x80\0" |
186
+| 50 | B | '100000000000' | "\x01" | "\x0F" | "\x80" | "\x0F\xFF" | "\x80\0" |
187
+| 51 | B | '1000000000000' | "\x01" | "\x0F" | "\x80" | "\x0F\xFF" | "\x80\0" |
188
+| 52 | B | '10000000000000000' | "\x01" | "\x0F" | "\x80" | "\x0F\xFF" | "\x80\0" |
189
+| 53 | B | '01' | "\0" | "\x0F" | "@" | "\x0F\xFF" | "@\0" |
190
+| 54 | B | '001' | "\0" | "\x0F" | " " | "\x0F\xFF" | " \0" |
191
+| 55 | B | '0001' | "\0" | "\x0F" | "\x10" | "\x0F\xFF" | "\x10\0" |
192
+| 56 | B | '00001' | "\0" | "\0" | "\b" | "\b\0" | "\b\0" |
193
+| 57 | B | '000000001' | "\0" | "\0" | "\0" | "\0\x80" | "\0\x80" |
194
+| 58 | B | '000000000001' | "\0" | "\0" | "\0" | "\0\x10" | "\0\x10" |
195
+| 59 | B | '0000000000001' | "\0" | "\0" | "\0" | "\0\0" | "\0\b" |
196
+| 60 | B | '00000000000000001' | "\0" | "\0" | "\0" | "\0\0" | "\0\0" |
197
+| 61 | B | '010' | "\0" | "\x0F" | "@" | "\x0F\xFF" | "@\0" |
198
+| 62 | B | '0010' | "\0" | "\x0F" | " " | "\x0F\xFF" | " \0" |
199
+| 63 | B | '00010' | "\0" | "\x0F" | "\x10" | "\x0F\xFF" | "\x10\0" |
200
+| 64 | B | '000010' | "\0" | "\0" | "\b" | "\b\0" | "\b\0" |
201
+| 65 | B | '0000000010' | "\0" | "\0" | "\0" | "\0\x80" | "\0\x80" |
202
+| 66 | B | '0000000000010' | "\0" | "\0" | "\0" | "\0\x10" | "\0\x10" |
203
+| 67 | B | '00000000000010' | "\0" | "\0" | "\0" | "\0\0" | "\0\b" |
204
+| 68 | B | '000000000000000010' | "\0" | "\0" | "\0" | "\0\0" | "\0\0" |
205
+| 69 | B | 2 | "\0" | "\0" | "\0" | "\0\0" | "\0\0" |
206
+| 70 | B | 3 | "\x01" | "\x0F" | "\x80" | "\x0F\xFF" | "\x80\0" |
207
+| 71 | B | 4 | "\0" | "\0" | "\0" | "\0\0" | "\0\0" |
208
+| 72 | B | 5 | "\x01" | "\x0F" | "\x80" | "\x0F\xFF" | "\x80\0" |
209
+| 73 | B | 6 | "\0" | "\0" | "\0" | "\0\0" | "\0\0" |
210
+| 74 | B | 7 | "\x01" | "\x0F" | "\x80" | "\x0F\xFF" | "\x80\0" |
211
+| 75 | B | 8 | "\0" | "\0" | "\0" | "\0\0" | "\0\0" |
212
+| 76 | B | 10 | "\x01" | "\x0F" | "\x80" | "\x0F\xFF" | "\x80\0" |
213
+| 77 | B | 12 | "\x01" | "\x0F" | "\x80" | "\x0F\xFF" | "\x80\0" |
214
+| 78 | B | 15 | "\x01" | "\x0F" | "\xC0" | "\x0F\xFF" | "\xC0\0" |
215
+| 79 | B | 16 | "\x01" | "\x0F" | "\x80" | "\x0F\xFF" | "\x80\0" |
216
+| 80 | B | 17 | "\x01" | "\x0F" | "\xC0" | "\x0F\xFF" | "\xC0\0" |
217
+| 81 | B | 255 | "\0" | "\x0F" | "`" | "\x0F\xFF" | "`\0" |
218
+| 82 | B | 256 | "\0" | "\x0F" | "@" | "\x0F\xFF" | "@\0" |
219
+| 83 | B | 512 | "\x01" | "\x0F" | "\xC0" | "\x0F\xFF" | "\xC0\0" |
220
+| 84 | B | 513 | "\x01" | "\x0F" | "\xE0" | "\x0F\xFF" | "\xE0\0" |
221
+
222
+### pack('C*',$x)
223
+| id | Type | 値 | bit1 | bit4 | bit8 | bit12 | bit16 |
224
+| --- | --- | --- | --- | --- | --- | --- | --- |
225
+| 85 | C | | "\0" | "\0" | "\0" | "\0\0" | "\0\0" |
226
+| 86 | C | 1 | "\x01" | "\x01" | "\x01" | "\0\x01" | "\0\x01" |
227
+| 87 | C | 10 | "\x01" | "\n" | "\n" | "\0\n" | "\0\n" |
228
+| 88 | C | 100 | "\x01" | "\x0F" | d | "\0d" | "\0d" |
229
+| 89 | C | 1000 | "\x01" | "\x0F" | "\xFF" | "\x03\xE8" | "\x03\xE8" |
230
+| 90 | C | 10000 | "\x01" | "\x0F" | "\xFF" | "\x0F\xFF" | "'\x10" |
231
+| 91 | C | 100000000 | "\x01" | "\x0F" | "\xFF" | "\x0F\xFF" | "\xFF\xFF" |
232
+| 92 | C | '100000000000' | "\x01" | "\x0F" | "\xFF" | "\x0F\xFF" | "\xFF\xFF" |
233
+| 93 | C | '1000000000000' | "\x01" | "\x0F" | "\xFF" | "\x0F\xFF" | "\xFF\xFF" |
234
+| 94 | C | '10000000000000000' | "\x01" | "\x0F" | "\xFF" | "\x0F\xFF" | "\xFF\xFF" |
235
+| 95 | C | '01' | "\x01" | "\x01" | "\x01" | "\0\x01" | "\0\x01" |
236
+| 96 | C | '001' | "\x01" | "\x01" | "\x01" | "\0\x01" | "\0\x01" |
237
+| 97 | C | '0001' | "\x01" | "\x01" | "\x01" | "\0\x01" | "\0\x01" |
238
+| 98 | C | '00001' | "\x01" | "\x01" | "\x01" | "\0\x01" | "\0\x01" |
239
+| 99 | C | '000000001' | "\x01" | "\x01" | "\x01" | "\0\x01" | "\0\x01" |
240
+| 100 | C | '000000000001' | "\x01" | "\x01" | "\x01" | "\0\x01" | "\0\x01" |
241
+| 101 | C | '0000000000001' | "\x01" | "\x01" | "\x01" | "\0\x01" | "\0\x01" |
242
+| 102 | C | '00000000000000001' | "\x01" | "\x01" | "\x01" | "\0\x01" | "\0\x01" |
243
+| 103 | C | '010' | "\x01" | "\n" | "\n" | "\0\n" | "\0\n" |
244
+| 104 | C | '0010' | "\x01" | "\n" | "\n" | "\0\n" | "\0\n" |
245
+| 105 | C | '00010' | "\x01" | "\n" | "\n" | "\0\n" | "\0\n" |
246
+| 106 | C | '000010' | "\x01" | "\n" | "\n" | "\0\n" | "\0\n" |
247
+| 107 | C | '0000000010' | "\x01" | "\n" | "\n" | "\0\n" | "\0\n" |
248
+| 108 | C | '0000000000010' | "\x01" | "\n" | "\n" | "\0\n" | "\0\n" |
249
+| 109 | C | '00000000000010' | "\x01" | "\n" | "\n" | "\0\n" | "\0\n" |
250
+| 110 | C | '000000000000000010' | "\x01" | "\n" | "\n" | "\0\n" | "\0\n" |
251
+| 111 | C | 2 | "\x01" | "\x02" | "\x02" | "\0\x02" | "\0\x02" |
252
+| 112 | C | 3 | "\x01" | "\x03" | "\x03" | "\0\x03" | "\0\x03" |
253
+| 113 | C | 4 | "\x01" | "\x04" | "\x04" | "\0\x04" | "\0\x04" |
254
+| 114 | C | 5 | "\x01" | "\x05" | "\x05" | "\0\x05" | "\0\x05" |
255
+| 115 | C | 6 | "\x01" | "\x06" | "\x06" | "\0\x06" | "\0\x06" |
256
+| 116 | C | 7 | "\x01" | "\a" | "\a" | "\0\a" | "\0\a" |
257
+| 117 | C | 8 | "\x01" | "\b" | "\b" | "\0\b" | "\0\b" |
258
+| 118 | C | 10 | "\x01" | "\n" | "\n" | "\0\n" | "\0\n" |
259
+| 119 | C | 12 | "\x01" | "\f" | "\f" | "\0\f" | "\0\f" |
260
+| 120 | C | 15 | "\x01" | "\x0F" | "\x0F" | "\0\x0F" | "\0\x0F" |
261
+| 121 | C | 16 | "\x01" | "\x0F" | "\x10" | "\0\x10" | "\0\x10" |
262
+| 122 | C | 17 | "\x01" | "\x0F" | "\x11" | "\0\x11" | "\0\x11" |
263
+| 123 | C | 255 | "\x01" | "\x0F" | "\xFF" | "\0\xFF" | "\0\xFF" |
264
+| 124 | C | 256 | "\x01" | "\x0F" | "\xFF" | "\x01\0" | "\x01\0" |
265
+| 125 | C | 512 | "\x01" | "\x0F" | "\xFF" | "\x02\0" | "\x02\0" |
266
+| 126 | C | 513 | "\x01" | "\x0F" | "\xFF" | "\x02\x01" | "\x02\x01" |
267
+
268
+## テーブル
269
+```sql
270
+CREATE TABLE IF NOT EXISTS `test_bit` (
271
+ `id` int(11) NOT NULL AUTO_INCREMENT,
272
+ `packtype` varchar(1) DEFAULT NULL,
273
+ `value` varchar(20) DEFAULT NULL,
274
+ `bit1` bit(1) DEFAULT NULL,
275
+ `bit4` bit(4) DEFAULT NULL,
276
+ `bit8` bit(8) DEFAULT NULL,
277
+ `bit12` bit(12) DEFAULT NULL,
278
+ `bit16` bit(16) DEFAULT NULL,
279
+ PRIMARY KEY (`id`)
280
+) ENGINE=MyISAM DEFAULT CHARSET=utf8 AUTO_INCREMENT=1 ;
281
+
282
+DELETE FROM `test_bit` WHERE 1;
283
+ALTER TABLE `test_bit` AUTO_INCREMENT = 1;
284
+```
285
+
286
+## リンク
287
+- Perl/packBit
288
+- MySQL
289
+
290
+- [PerlMonks - The Monastery Gates](http://www.perlmonks.org/)
291
+ - [Handle MySQL BIT data type in Perl](http://www.perlmonks.org/?node_id=504470)
0 292
\ No newline at end of file
Perl/NetWatcher.md
... ...
@@ -0,0 +1,547 @@
1
+[[_TOC_]]
2
+
3
+# 概要
4
+- ネットワーク上のサーバの ping による死活監視および WakeOnLan によるリモート起動を行う。
5
+- 監視するのはスクリプトを呼び出した時1回だけで履歴は取らない。
6
+- 再度監視したい場合はタイトルがリンクになっているので、そこをクリックする。
7
+- Windows/IIS 版を追加。(2012/03/28)
8
+- [CPAN:Doxygen-Filter-Perl](http://search.cpan.org/dist/Doxygen-Filter-Perl) 用タグの書き方が間違っていたのを訂正。(2012/03/28)
9
+- Linux/Apache 版で<form>が閉じていなかったのを修正。(2012/03/28)
10
+- 関数内で print するのを止め、HTML文字列を返すように変更。(2012/03/29)
11
+- NIC が2枚以上ある場合に対応。「/」で連結して書く。(2012/05/30)
12
+- Name の先頭に「#」が付いている行はコメントとして無視される。(2012/06/04)
13
+
14
+# ソース
15
+- [NetWatcher.zip](NetWatcher.zip)
16
+
17
+## index.cgi (Linux/Apache)
18
+```perl
19
+#!/usr/bin/perl
20
+## @mainpage NetWatcher
21
+# サーバの監視およびリモート起動
22
+
23
+use strict;
24
+use warnings;
25
+use utf8;
26
+use Encode;
27
+use YAML::Syck;
28
+use CGI::Pretty qw( -no_xhtml *table ); # //HTML 4.01 Transitional//EN
29
+use Text::xSV::Slurp qw( xsv_slurp );
30
+use Net::Ping::External qw( ping );
31
+use Net::Wake;
32
+use Parallel::ForkManager;
33
+use IPC::Shareable;
34
+
35
+$YAML::Syck::ImplicitUnicode = 1;
36
+
37
+#my $charsetConsole = 'CP932';
38
+my $charsetConsole = 'UTF-8';
39
+my $charsetFile = 'UTF-8';
40
+
41
+binmode( STDIN, ":encoding($charsetConsole)" );
42
+binmode( STDOUT, ":encoding($charsetConsole)" );
43
+binmode( STDERR, ":encoding($charsetConsole)" );
44
+
45
+my $cginame = 'NetWatcher'; ##< CGI名
46
+my $cookiename = 'NWCookie'; ##< 現在は使用していない
47
+my $configfile = './conf/config.txt'; ##< 設定ファイル
48
+my $csvoption = { sep_char => "\t" }; ##< 設定ファイルを読み込むためのオプション
49
+my $maxchildren = 10; ##< 子プロセスの最大数
50
+my $markignore = '#'; ##< 行頭がこの文字列で始まっている行は無視する。
51
+
52
+my @Targets = readXSV( $configfile, $csvoption );
53
+my %Targets = map{ $_->{'Name'} => $_; } @Targets;
54
+
55
+#print Dump( \%Targets ) . "\n";
56
+#exit;
57
+
58
+my %results = pingTargets( \@Targets );
59
+
60
+my $q = new CGI;
61
+$q->charset( $charsetFile );
62
+my $scripturl = $q->url( );
63
+
64
+my @paramnames = $q->param();
65
+
66
+printHeader();
67
+
68
+if ( @paramnames ){
69
+ action();
70
+}
71
+printForm();
72
+
73
+printFooter();
74
+
75
+exit;
76
+
77
+## @function readXSV( $fname, %$opt )
78
+# CSV(TSV)ファイルを読み込んでヘッダ行をキーとしたハッシュの配列を返す。
79
+# @param fname [in] ファイル名
80
+# @param opt [in] Text::CSV_XS に渡されるオプション
81
+# @return CSVを配列化したもの
82
+sub readXSV
83
+{
84
+ my( $fname, $opt ) = @_;
85
+ $opt = { binary => 1, %{$opt} };
86
+ open( my $fhin, "<:encoding($charsetFile)", encode( $charsetConsole, $fname ) )
87
+ or die( "$fname: $!" );
88
+ my @body = <$fhin>;
89
+ close( $fhin );
90
+ my $ret = xsv_slurp(
91
+ string => join( "", @body ),
92
+ text_csv => $opt,
93
+ );
94
+ return ( ref( $ret ) eq 'ARRAY' )
95
+ ? @{ $ret }
96
+ : $ret ;
97
+}
98
+
99
+## @function pingTargets( @$targets_ref )
100
+# ターゲット情報に従い、各ターゲット宛に ping を打ち、結果をハッシュにして返す。
101
+# @param targets_ref [in] ターゲット情報の配列のリファレンス
102
+# @return ping 結果のハッシュ
103
+sub pingTargets
104
+{
105
+ my( $targets_ref ) = @_;
106
+
107
+ my $handle = tie my %results, 'IPC::Shareable', undef, { destroy => 1 };
108
+ %results = ();
109
+
110
+ my $pm = Parallel::ForkManager->new( $maxchildren );
111
+
112
+# $pm->run_on_start(
113
+# sub {
114
+# my( $pid, $ident ) = @_;
115
+# print "** $ident started, pid: $pid\n";
116
+# }
117
+# );
118
+
119
+ foreach my $target ( @{$targets_ref} ){
120
+ my $name = $target->{ 'Name' } || '';
121
+ if ( substr( $name, 0, length($markignore) ) eq $markignore ){
122
+ next;
123
+ }
124
+ my $ip = $target->{ 'IP' } || '';
125
+ $pm->start( $name ) and next;
126
+ my $status = ping( host => $ip, timeout => 1 );
127
+ $handle->shlock;
128
+ $results{ $name } = $status;
129
+ $handle->shunlock;
130
+ $pm->finish( $name );
131
+ }
132
+ $pm->wait_all_children;
133
+
134
+ my %ret = %results;
135
+ $handle->remove();
136
+
137
+ return %ret;
138
+}
139
+
140
+## @function printHeader()
141
+# HTTP ヘッダおよび HTML ヘッダを出力する。
142
+sub printHeader
143
+{
144
+ my $cookieval = decode( 'utf8',
145
+ $q->cookie( encode( 'utf8', $cookiename ) ) || ''
146
+ );
147
+# $cookieval .= 'あ';
148
+ my $cookie = $q->cookie(
149
+ '-name' => encode( 'utf8', $cookiename ),
150
+ '-value' => encode( 'utf8', $cookieval ),
151
+ );
152
+ print $q->header( '-cookie' => [ $cookie ] );
153
+ print $q->start_html(
154
+ '-title' => $cginame,
155
+ '-lang' => 'ja-JP',
156
+ '-head' => [
157
+ $q->meta( { '-http_equiv' => 'Content-style-type', '-content' => 'text/css' } ),
158
+ $q->meta( { '-http_equiv' => 'Content-script-type', '-content' => 'text/javascript' } ),
159
+ ],
160
+ '-style' => [ { 'src' => 'NetWatcher.css' }, ],
161
+ );
162
+ print $q->h1( $q->a( { -href => $scripturl }, $cginame ) );
163
+}
164
+
165
+## @function printFooter()
166
+# HTML フッタを出力する。
167
+sub printFooter
168
+{
169
+ print $q->end_html . "\n";
170
+}
171
+
172
+## @function action()
173
+# フォームから送信されたコマンドを処理する。
174
+sub action
175
+{
176
+ print $q->h2( 'Command' );
177
+ print $q->start_table( { '-summary' => 'Servers', '-border' => 1 } );
178
+ foreach my $key ( @paramnames ){
179
+ print $q->Tr(
180
+ { -class => 'even' },
181
+ $q->th( { -class => 'title' }, $key ), $q->td( $q->param( $key ) )
182
+ );
183
+ }
184
+ print $q->end_table();
185
+ my $target = $q->param( 'Wake' ) || '';
186
+ if ( $target && $Targets{$target} ){
187
+ foreach my $mac ( split( /\//, $Targets{$target}{'MAC'} ) ){
188
+ Net::Wake::by_udp( undef, $mac );
189
+ }
190
+ }
191
+}
192
+
193
+## @function printForm()
194
+# フォームを出力する。
195
+sub printForm
196
+{
197
+ print $q->h2( 'ステータス' );
198
+ print $q->start_form(
199
+ '-action' => $scripturl,
200
+ '-enctype' => ( 'multipart/form-data' ),
201
+ );
202
+ print $q->start_table( { '-summary' => 'Statuses', '-border' => 1 } );
203
+ print $q->Tr( $q->th( { -class => 'title' }, [ 'Name', 'Type', 'IP', 'Status', 'Wake', '備考' ] ) );
204
+ for( my $i=0; $i<@Targets; ++$i ){
205
+ my $name = $Targets[ $i ]{'Name'} || '';
206
+ if ( substr( $name, 0, length($markignore) ) eq $markignore ){
207
+ next;
208
+ }
209
+ my $type = $Targets[ $i ]{'Type'} || '';
210
+ my $ip = $Targets[ $i ]{'IP'} || '';
211
+ my $status = ( $results{ $name } )
212
+ ? $q->td( { -class => 'state_up' }, 'Up' )
213
+ : $q->td( { -class => 'state_down' }, 'Down' );
214
+ my $comment = $Targets[ $i ]{'Comment'} || '';
215
+ print $q->Tr(
216
+ { -class => ( $i % 2 ) ? 'odd' : 'even' },
217
+ $q->th( $name ),
218
+ $q->td( [ $type, $ip ] ),
219
+ $status,
220
+ $q->td( [ $q->submit( -name=>'Wake', -value=>$name ), $comment, ] ),
221
+ );
222
+ }
223
+ print $q->end_table();
224
+ $q->end_form;
225
+}
226
+
227
+# EOF
228
+```
229
+
230
+## index_IIS.cgi (Windows/IIS)
231
+```perl
232
+#!/usr/bin/perl
233
+# NetWatcher (IIS用)
234
+# サーバの監視およびリモート起動
235
+
236
+use strict;
237
+use warnings;
238
+use utf8;
239
+use Encode;
240
+use YAML::Syck;
241
+use CGI::Pretty qw( -no_xhtml *table ); # //HTML 4.01 Transitional//EN
242
+use Text::xSV::Slurp qw( xsv_slurp );
243
+use Net::Ping::External qw( ping );
244
+use Net::Wake;
245
+use threads;
246
+use threads::shared;
247
+
248
+$YAML::Syck::ImplicitUnicode = 1;
249
+
250
+#my $charsetConsole = 'CP932';
251
+my $charsetConsole = 'UTF-8';
252
+my $charsetFile = 'UTF-8';
253
+
254
+# Encode モジュールは Thread Safe ではない。
255
+# http://search.cpan.org/dist/Encode/encoding.pm
256
+#binmode( STDIN, ":encoding($charsetConsole)" );
257
+#binmode( STDOUT, ":encoding($charsetConsole)" );
258
+#binmode( STDERR, ":encoding($charsetConsole)" );
259
+
260
+my $encoder = find_encoding( $charsetConsole );
261
+
262
+my $cginame = 'NetWatcher';
263
+my $cookiename = 'NWCookie'; ##< 現在は使用していない
264
+my $configfile = './conf/config.txt';
265
+my $csvoption = { sep_char => "\t" };
266
+my $markignore = '#'; ##< 行頭がこの文字列で始まっている行は無視する。
267
+
268
+my @Targets = readXSV( $configfile, $csvoption );
269
+my %Targets = map{ $_->{'Name'} => $_; } @Targets;
270
+
271
+#print $encoder->encode( Dump( \%Targets ) . "\n" );
272
+#exit;
273
+
274
+my %results = pingTargets( \@Targets );
275
+
276
+my $q = new CGI;
277
+$q->charset( $charsetConsole );
278
+my $scripturl = $q->url( -path_info=>1 );
279
+
280
+my @paramnames = $q->param();
281
+
282
+printHeader();
283
+
284
+if ( @paramnames ){
285
+ action();
286
+}
287
+printForm();
288
+
289
+printFooter();
290
+
291
+exit;
292
+
293
+## @function readXSV( $fname, %$opt )
294
+# CSV(TSV)ファイルを読み込んでヘッダ行をキーとしたハッシュの配列を返す。
295
+# @param fname [in] ファイル名
296
+# @param opt [in] Text::CSV_XS に渡されるオプション
297
+# @return CSVを配列化したもの
298
+sub readXSV
299
+{
300
+ my( $fname, $opt ) = @_;
301
+ $opt = { binary => 1, %{$opt} };
302
+ open( my $fhin, "<:encoding($charsetFile)", encode( $charsetConsole, $fname ) )
303
+ or die( "$fname: $!" );
304
+ my @body = <$fhin>;
305
+ close( $fhin );
306
+ my $ret = xsv_slurp(
307
+ string => join( "", @body ),
308
+ text_csv => $opt,
309
+ );
310
+ return ( ref( $ret ) eq 'ARRAY' )
311
+ ? @{ $ret }
312
+ : $ret ;
313
+}
314
+
315
+## @function pingTargets( @%targetsref )
316
+# ターゲット情報に従い、各ターゲット宛に ping を打ち、結果をハッシュにして返す。
317
+# @param targets [in] ターゲット情報の配列
318
+# @return ping 結果のハッシュ
319
+sub pingTargets
320
+{
321
+ my( $targets_ref ) = @_;
322
+
323
+ my %results;
324
+ my %threads;
325
+ foreach my $target ( @{$targets_ref} ) {
326
+ my $name = $target->{ 'Name' } || '';
327
+ if ( substr( $name, 0, length($markignore) ) eq $markignore ){
328
+ next;
329
+ }
330
+ my $ip = $target->{ 'IP' } || '';
331
+ $threads{ $name } = threads->new(
332
+ sub {
333
+ my( $ip ) = @_;
334
+ return ping( host => $ip, timeout => 1 );
335
+ },
336
+ $ip
337
+ );
338
+ }
339
+ foreach my $t ( keys( %threads ) ){
340
+ $results{ $t } = $threads{ $t }->join();
341
+ }
342
+
343
+ return %results;
344
+}
345
+
346
+## @function printHeader()
347
+# HTTP ヘッダおよび HTML ヘッダを出力する。
348
+sub printHeader
349
+{
350
+ if ( defined( $ENV{PERLXS} ) && $ENV{PERLXS} eq 'PerlIS' ){
351
+ print $encoder->encode( "HTTP/1.0 200 OK\n" );
352
+ }
353
+
354
+ my $cookieval = decode( 'utf8',
355
+ $q->cookie( encode( 'utf8', $cookiename ) ) || ''
356
+ );
357
+# $cookieval .= 'あ';
358
+ my $cookie = $q->cookie(
359
+ '-name' => encode( 'utf8', $cookiename ),
360
+ '-value' => encode( 'utf8', $cookieval ),
361
+ );
362
+ print $encoder->encode( $q->header( '-cookie' => [ $cookie ] ) );
363
+ print $encoder->encode( $q->start_html(
364
+ '-title' => $cginame,
365
+ '-lang' => 'ja-JP',
366
+ '-head' => [
367
+ $q->meta( { '-http_equiv' => 'Content-style-type', '-content' => 'text/css' } ),
368
+ $q->meta( { '-http_equiv' => 'Content-script-type', '-content' => 'text/javascript' } ),
369
+ ],
370
+ '-style' => [ { 'src' => 'NetWatcher.css' }, ],
371
+ ) );
372
+ print $encoder->encode( $q->h1( $q->a( { -href => $scripturl }, $cginame ) ) );
373
+}
374
+
375
+## @function printFooter()
376
+# HTML フッタを出力する。
377
+sub printFooter
378
+{
379
+ print $encoder->encode( $q->end_html . "\n" );
380
+}
381
+
382
+## @function action()
383
+# フォームから送信されたコマンドを処理する。
384
+sub action
385
+{
386
+ print $encoder->encode( $q->h2( 'Command' ) );
387
+ print $encoder->encode( $q->start_table( { '-summary' => 'Servers', '-border' => 1 } ) );
388
+ foreach my $key ( @paramnames ){
389
+ print $encoder->encode( $q->Tr(
390
+ { -class => 'even' },
391
+ $q->th( { -class => 'title' }, $key ), $q->td( $q->param( $key ) )
392
+ ) );
393
+ }
394
+ print $encoder->encode( $q->end_table() );
395
+ my $target = $q->param( 'Wake' ) || '';
396
+ if ( $target && $Targets{$target} ){
397
+ foreach my $mac ( split( /\//, $Targets{$target}{'MAC'} ) ){
398
+ Net::Wake::by_udp( undef, $mac );
399
+ }
400
+ }
401
+}
402
+
403
+## @function printForm()
404
+# フォームを出力する。
405
+sub printForm
406
+{
407
+ print $encoder->encode( $q->h2( 'ステータス' ) );
408
+ print $encoder->encode( $q->start_form(
409
+ '-action' => $scripturl,
410
+ '-enctype' => ( 'multipart/form-data' ),
411
+ ) );
412
+ print $encoder->encode( $q->start_table( { '-summary' => 'Statuses', '-border' => 1 } ) );
413
+ print $encoder->encode( $q->Tr( $q->th( { -class => 'title' }, [ 'Name', 'Type', 'IP', 'Status', 'Wake', '備考' ] ) ) );
414
+ for( my $i=0; $i<@Targets; ++$i ){
415
+ my $name = $Targets[ $i ]{'Name'} || '';
416
+ if ( substr( $name, 0, length($markignore) ) eq $markignore ){
417
+ next;
418
+ }
419
+ my $type = $Targets[ $i ]{'Type'} || '';
420
+ my $ip = $Targets[ $i ]{'IP'} || '';
421
+ my $status = ( $results{ $name } )
422
+ ? $q->td( { -class => 'state_up' }, 'Up' )
423
+ : $q->td( { -class => 'state_down' }, 'Down' );
424
+ my $comment = $Targets[ $i ]{'Comment'} || '';
425
+ print $encoder->encode( $q->Tr(
426
+ { -class => ( $i % 2 ) ? 'odd' : 'even' },
427
+ $q->th( $name ),
428
+ $q->td( [ $type, $ip ] ),
429
+ $status,
430
+ $q->td( [ $q->submit( -name=>'Wake', -value=>$name ), $comment, ] ),
431
+ ) );
432
+ }
433
+ print $encoder->encode( $q->end_table() );
434
+ print $encoder->encode( $q->end_form() );
435
+}
436
+
437
+# EOF
438
+```
439
+
440
+## config.txt
441
+- サーバ情報設定TSVファイル。
442
+- MAC は WakeOnLan のパケットを送信する NIC の MAC アドレス。
443
+- NIC が2枚以上ある場合は、「/」で連結して書く。
444
+- Name の先頭に「#」が付いている行はコメントとして無視される。
445
+```
446
+"Name" "Type" "IP" "MAC" "Comment"
447
+"Srv01" "Win2003" "192.168.0.10" "XX:XX:XX:XX:XX:XX" "Web Hosting"
448
+"Srv02" "CentOS6" "192.168.0.11" "XX:XX:XX:XX:XX:XX/XX:XX:XX:XX:XX:XX" "Mail, MySQL"
449
+"#Srv03" "Win2008R2" "192.168.0.12" "XX:XX:XX:XX:XX:XX" "Streaming"
450
+"Srv04" "MacOSX 10.6" "192.168.0.13" "XX:XX:XX:XX:XX:XX" "FileSrv"
451
+```
452
+
453
+## NetWatcher.conf
454
+- Apache 用設定ファイル。
455
+- .htaccess でも代用可能。
456
+```apache
457
+<Directory "/var/www/html/NetWatcher">
458
+ Options ExecCGI Indexes
459
+ DirectoryIndex index.cgi
460
+ Order allow,deny
461
+ Allow from 127.0.0.1
462
+ Allow from 192.168.0.0/24
463
+ Allow from 10.8.0.0/24
464
+</Directory>
465
+
466
+<Directory "/var/www/html/NetWatcher/conf">
467
+ Options None
468
+ Order allow,deny
469
+</Directory>
470
+```
471
+
472
+# システム設定
473
+
474
+## パッケージ追加
475
+- EPEL, RPMForge リポジトリを追加しておくこと。<br />
476
+[[リポジトリ追加|Linux/Install/CentOS6#Repository]]
477
+```
478
+# yum install perl-Net-Ping-External perl-Parallel-ForkManager perl-IPC-Shareable
479
+```
480
+
481
+## SELinux設定
482
+- audit.log を元にポリシーを作成しインストールする。<br />
483
+[[ログ分析|Linux/SELinux#AnalyseLog]]
484
+```
485
+# semodule -d mypol
486
+# setenforce 0
487
+# service auditd rotate
488
+(NetWatcher実行)
489
+# setenforce 1
490
+# grep "index.cgi\|ping" /var/log/audit/audit.log | audit2allow -M mypol_NetWatcher
491
+# semodule -i mypol_NetWatcher.pp
492
+```
493
+- mypol_NetWatcher.te<br />
494
+こんなポリシーができてるはず。
495
+```
496
+module mypol_NetWatcher 1.0;
497
+
498
+require {
499
+ type httpd_sys_script_t;
500
+ type tmpfs_t;
501
+ class capability { setuid net_raw };
502
+ class sem { unix_read write unix_write read destroy create };
503
+ class shm { write associate read create unix_read getattr unix_write destroy };
504
+ class file { read write };
505
+ class rawip_socket { write getopt create read