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)
... ...
\ 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
+- [PE２プレイ記録ほか](http://parasiteeve2.blog65.fc2.com/) / [Amazonの画像加工について(まとめ)](http://parasiteeve2.blog65.fc2.com/blog-entry-33.html)
... ...
\ 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
+- [PE２プレイ記録ほか](http://parasiteeve2.blog65.fc2.com/)
338
+ - [Amazonの画像加工について(まとめ)](http://parasiteeve2.blog65.fc2.com/blog-entry-33.html)
339
+ - [Amazonの画像加工（ツール編5）ASINから利用可能な全画像を求める・５](http://parasiteeve2.blog65.fc2.com/blog-entry-372.html)
340
+ - [Amazonの画像加工（ツール編7）ASINから利用可能な全画像を求める・６](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)
... ...
\ 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]]
... ...
\ 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)
... ...
\ 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)
... ...
\ 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)
... ...
\ 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)
... ...
\ 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 の１回でバインドできるのと型指定できる点が勝ってるかな。
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)
... ...
\ No newline at end of file
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)
... ...
\ No newline at end of file
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
... ...
\ No newline at end of file
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
+% Ｖ圧着葉書テンプレート (中面)
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
+(Ｖ圧着葉書テンプレート (中面)) 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
+% Ｖ圧着葉書テンプレート (宛名面)
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
+(Ｖ圧着葉書テンプレート (宛名面)) 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ファイル作成)~~
... ...
\ No newline at end of file
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ファイル作成)~~
... ...
\ No newline at end of file
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ファイル作成)~~
... ...
\ 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
+- ２つ目の引数にハッシュを指定することで別の変換を行うことができます。
8
+ - 書いたはいいが、２番目のパラメータをハッシュだと思い込んでたがホントは文字列だった。(--;)<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
+# 書いたはいいが、２番目のパラメータをハッシュだと思い込んでたがホントは文字列だった。(--;)
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 で、中かっこに囲まれたシンボリックリファレンスが よりクォートのように、ちょうどそれが文字列の中にあるかのように 振る舞うという新たな機能が読みやすさのために追加されました。
... ...
\ 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
+## リンク
... ...
\ 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)
... ...
\ 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)
... ...
\ No newline at end of file
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/)
... ...
\ 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)
... ...
\ 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)
... ...
\ No newline at end of file
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)
... ...
\ No newline at end of file
Perl/ListDownloader.md
... ...
@@ -0,0 +1,57 @@
1
+[[_TOC_]]
2
+
3
+# 概要
4
+- １行に１つ 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)
... ...
\ 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
+- 第１フィールドをプライマリフィールドとして、レコードが未登録か登録済みかを判別し、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 [テーブル名]
... ...
\ No newline at end of file
Perl/MailForm.md
... ...
@@ -0,0 +1,333 @@
1
+[[_TOC_]]
2
+----
3
+# 概要
4
+- ファイルが添付できるメールフォーム。
5
+- 宛先は config.yaml で指定する。フォームから宛先の追加も可能。
6
+- 名前, 宛先は Cookie に保存される。(１ヶ月)
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)
... ...
\ 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)
... ...
\ 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)
... ...
\ No newline at end of file
Perl/NetWatcher.md
... ...
@@ -0,0 +1,547 @@
1
+[[_TOC_]]
2
+
3
+# 概要
4
+- ネットワーク上のサーバの ping による死活監視および WakeOnLan によるリモート起動を行う。
5
+- 監視するのはスクリプトを呼び出した時１回だけで履歴は取らない。
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 が２枚以上ある場合に対応。「/」で連結して書く。(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 が２枚以上ある場合は、「/」で連結して書く。
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 setopt };
506
+}
507
+
508
+#============= httpd_sys_script_t ==============
509
+allow httpd_sys_script_t self:capability { setuid net_raw };
510
+allow httpd_sys_script_t self:rawip_socket { write getopt create read setopt };
511
+allow httpd_sys_script_t self:sem { unix_read write unix_write read destroy create };
512
+allow httpd_sys_script_t self:shm { unix_read associate read create write getattr unix_write destroy };
513
+allow httpd_sys_script_t tmpfs_t:file { read write };
514
+```
515
+
516
+- IIS の場合は、ping.exe の「プロパティ - セキュリティ」を開き、「インターネットゲストアカウント(IUSR_<マシン名>)」に「読み取りと実行」権限を付加する。
517
+ - [[PRB] [IIS 6.0] 外部アプリケーションを呼び出す CGI コードが失敗する](http://support.microsoft.com/kb/311481/)
518
+
519
+# リンク
520
+- [[Perl/CGI.pm]]
521
+- [[Perl/readXSV]]
522
+
523
+- [CPAN:Net-Ping-External](http://search.cpan.org/dist/Net-Ping-External)
524
+- [CPAN:Net-Arping](http://search.cpan.org/dist/Net-Arping)
525
+- [CPAN:Net-Wake](http://search.cpan.org/dist/Net-Wake)
526
+- [CPAN:Parallel-ForkManager](http://search.cpan.org/dist/Parallel-ForkManager)
527
+- [CPAN:IPC-Shareable](http://search.cpan.org/dist/IPC-Shareable)
528
+- [CPAN:threads](http://search.cpan.org/dist/threads)
529
+- [CPAN:threads-shared](http://search.cpan.org/dist/threads-shared)
530
+- [CPAN:Encode](http://search.cpan.org/dist/Encode)
531
+ - [CPAN:Encode/encoding.pm](http://search.cpan.org/dist/Encode/encoding.pm)<br />
532
+use encoding ... is not thread-safe.
533
+
534
+- [(Obsolete) Parallel::ForkManager + IPC::Shareable で複数のプロセスで変数を共有する - Yet Another Hackadelic](http://d.hatena.ne.jp/ZIGOROu/20090112/1231756261)
535
+- [パターン青の集い: memo::Perlによる複数並列処理プログラム](http://todayd308.blogspot.com/2009/10/memoperl.html)
536
+
537
+- [Forkが気になりつつthread - ito.tetsunosuke/notebook](http://d.hatena.ne.jp/kidd-number5/20070328/1175065357)
538
+
539
+- [404 Blog Not Found:perl - Encode 入門](http://blog.livedoor.jp/dankogai/archives/51031595.html)
540
+- [use threads; するときに注意すべきこと - punitan (a.k.a. punytan) のメモ](http://d.hatena.ne.jp/punitan/20091018/1255892339)<br />
541
+threads と binmode を同時に使うとクラッシュする。
542
+
543
+- [404 Blog Not Found:perl - 勝手に添削 - Webサイト死活管理](http://blog.livedoor.jp/dankogai/archives/51511557.html)
544
+
545
+- [お手軽に死活監視をPerlのCPANモジュールApp::MadEyeで行う](http://hirobanex.net/article/2012/02/1330308330) @ [hirobanex.net](http://hirobanex.net/)
546
+
547
+- [gWakeOnLan](http://code.google.com/p/gwakeonlan/)<br />gWakeOnLan is a GTK+ utility to awake turned off machines using the Wake on LAN feature.
... ...
\ No newline at end of file
Perl/Perl-Tidy.md
... ...
@@ -0,0 +1,43 @@
1
+# インストール
2
+
3
+## Windows Active Perl
4
+```
5
+> ppm install perl-tidy
6
+```
7
+- ホームフォルダに設定ファイルを作成
8
+```
9
+%HOMEPATH%/.perltidyrc
10
+```
11
+
12
+## Linux
13
+```
14
+# cpanm Perl::Tidy
15
+```
16
+- ホームフォルダに設定ファイルを作成
17
+```
18
+$HOME/.perltidyrc
19
+```
20
+
21
+# ウチの設定
22
+```
23
+-l=100 # Max line width is 100 cols
24
+-i=4 # Indent level is 4 cols
25
+-ci=4 # Continuation indent is 4 cols
26
+#-st # Output to STDOUT
27
+-se # Errors to STDERR
28
+-vt=2 # Maximal vertical tightness
29
+-cti=0 # No extra indentation for closing brackets
30
+-pt=1 # Medium parenthesis tightness
31
+-bt=1 # Medium brace tightness
32
+-sbt=1 # Medium square brace tightness
33
+-bbt=1 # Medium block brace tightness
34
+-nsfs # No space before semicolons
35
+-nolq # Don't outdent long quoted strings
36
+-wbb="% + - * / x != == >= <= =~ !~ < > | & >= < = **= += *= &= <<= &&= -= /= |= >>= ||= .= %= ^= x="
37
+ # Break before all operators
38
+-b # backup original to .bak and modify file in-place
39
+-ce # cuddled else; use this style: '} else {'
40
+```
41
+
42
+# リンク
43
+- [CPAN:Perl-Tidy](http://search.cpan.org/dist/Perl-Tidy)
... ...
\ No newline at end of file
Perl/SHA1.md
... ...
@@ -0,0 +1,86 @@
1
+[[_TOC_]]
2
+
3
+# 概要
4
+- ファイルから平文を読み込んでSHA1を計算する。
5
+
6
+# ソース
7
+- [sha1.zip](sha1.zip)
8
+
9
+## sha1.pl
10
+```perl
11
+# SHA1 の計算
12
+
13
+use strict;
14
+use warnings;
15
+use utf8;
16
+use Encode;
17
+use Digest::SHA1 qw( sha1_hex );
18
+
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
+my $srcFile = "./Password_Org.txt";
27
+my $dstFile = "./Password_Enc.txt";
28
+
29
+open( my $fhin, "<:utf8", encode( $charsetConsole, $srcFile ) )
30
+ or die( "$srcFile: $!\n" );
31
+<$fhin>; # ヘッダ行を捨てる
32
+my @Body = <$fhin>;
33
+close( $fhin );
34
+chomp( @Body );
35
+
36
+open( my $fhout, ">:utf8", encode( $charsetConsole, $dstFile ) )
37
+ or die( "$dstFile: $!\n" );
38
+print $fhout "ID\tPlain\tEncrypted\n";
39
+
40
+foreach my $row ( @Body ){
41
+ my @fields = split( /\t/, $row );
42
+ printf $fhout ( "%s\t%s\n", $row, sha1_hex( encode( 'utf8', $fields[1] ) ) );
43
+}
44
+
45
+close( $fhout );
46
+
47
+# EOF
48
+```
49
+
50
+# 計算サンプル
51
+## 入力 Password_Org.txt
52
+```
53
+ID Plain
54
+1 0000
55
+2 1111
56
+3 2222
57
+4 3333
58
+5 あいう
59
+```
60
+
61
+## 出力 Password_Enc.txt
62
+```
63
+ID Plain Encrypted
64
+1 0000 39dfa55283318d31afe5a3ff4a0e3253e2045e43
65
+2 1111 011c945f30ce2cbafc452f39840f025693339c42
66
+3 2222 fea7f657f56a2a448da7d4b535ee5e279caf3d9a
67
+4 3333 f56d6351aa71cff0debea014d13525e42036187a
68
+5 あいう eb636ba7c320e00b3749ad404b7adc7609560dee
69
+```
70
+
71
+# SHA256 ハッシュの計算
72
+
73
+## perl
74
+```
75
+perl -MDigest::SHA -e 'my $sha = Digest::SHA->new(256); $sha->addfile("filename"); print $sha->b64digest . "\n";'
76
+```
77
+
78
+## OpenSSL
79
+```
80
+openssl sha256 -binary "filename" | openssl base64
81
+```
82
+
83
+# リンク
84
+- [CPAN:Digest](http://search.cpan.org/dist/Digest)
85
+- [CPAN:Digest-SHA](http://search.cpan.org/dist/Digest-SHA)
86
+- [CPAN:Digest-SHA1](http://search.cpan.org/dist/Digest-SHA1)
... ...
\ No newline at end of file
Perl/SortUnicode.md
... ...
@@ -0,0 +1,51 @@
1
+[[_TOC_]]
2
+
3
+# 概要
4
+- Unicode 順でのソート。
5
+- ひらがな/カタカナを区別せずにソートするには「Unicode::Collate」でソートする。
6
+
7
+# ソース
8
+- [sortUnicode.zip](sortUnicode.zip)
9
+```perl
10
+#!/usr/bin/perl
11
+# Unicode 順のソート
12
+
13
+use strict;
14
+use warnings;
15
+use utf8;
16
+use Encode;
17
+use POSIX qw(locale_h);
18
+use locale;
19
+use Unicode::Collate;
20
+
21
+my $charsetConsole = 'UTF-8';
22
+
23
+binmode( STDIN, ":encoding($charsetConsole)" );
24
+binmode( STDOUT, ":encoding($charsetConsole)" );
25
+binmode( STDERR, ":encoding($charsetConsole)" );
26
+
27
+my @list = split( //, 'あぁＡAアｱaはばぱがかぴひび' );
28
+
29
+my $locale = "ja_JP.UTF-8";
30
+setlocale( LC_ALL, $locale );
31
+print "locale($locale)\n";
32
+print join( "", sort(@list) ) . "\n";
33
+print "\n";
34
+my $Collator = Unicode::Collate->new();
35
+print "Unicode::Collate\n";
36
+print join( "", $Collator->sort(@list) ) . "\n";
37
+```
38
+
39
+# 出力
40
+- Cent OS 6, perl v5.10.1
41
+```
42
+locale(ja_JP.UTF-8)
43
+AaｱＡぁあかがはばぱひびぴア
44
+
45
+Unicode::Collate
46
+aAＡぁあアｱかがはばぱひびぴ
47
+```
48
+
49
+# リンク
50
+- [CPAN:Unicode-Collate](http://search.cpan.org/dist/Unicode-Collate)
51
+- [Perl のロケール操作 (国際化と地域化)](http://perldoc.jp/pod/perllocale)
... ...
\ No newline at end of file
Perl/W03_FOMA.md
... ...
@@ -0,0 +1,101 @@
1
+# W-ZERO3のアドレス帳をFOMAのデータリンクソフト用に変換
2
+[[_TOC_]]
3
+
4
+## 概要
5
+- [アドレス帳CSVコンバータ](http://dev.officeservice.co.jp/top/index.php?%A5%BD%A5%D5%A5%C8%A5%A6%A5%A7%A5%A2%2FPocketPC%2FPOCSV)でCSVに書き出した[W-ZERO3]]のアドレス帳を、FOMA [[N701i](http://www.n-keitai.com/n701i/opn.html)に[データリンクソフト](http://www.n-keitai2.com/guide/download/index.html)で読み込める形式に変換する。
6
+
7
+## ソースコード
8
+```
9
+$fin = "W03.csv";
10
+$fout = "FOMA.csv";
11
+
12
+# メモリ番号の最初の値
13
+$MemoryNo = 10;
14
+
15
+@TelKeys =(
16
+ "BusinessTelephoneNumber", "BusinessFaxNumber", "CompanyTelephoneNumber",
17
+ "MobileTelephoneNumber", "HomeTelephoneNumber", "Home2TelephoneNumber",
18
+);
19
+
20
+@EMailKeys = (
21
+ "Email1Address", "Email2Address", "Email3Address",
22
+);
23
+
24
+%Icon =(
25
+ "BusinessTelephoneNumber" => 3, "BusinessFaxNumber" => 4, "CompanyTelephoneNumber" => 3,
26
+ "MobileTelephoneNumber" => 1, "HomeTelephoneNumber" => 2, "Home2TelephoneNumber" => 2,
27
+ "Email1Address" => 24, "Email2Address" => 24, "Email3Address" => 24,
28
+);
29
+
30
+open( IN, $fin ) || die( "can't open'".$fin."'.\n" );
31
+open( OUT, ">".$fout ) || die( "can't open'".$fout."'.\n" );
32
+
33
+$line = <IN>;
34
+chop( $line );
35
+@fields = split( ",", $line );
36
+@addr_in = <IN>;
37
+close( IN );
38
+chop( @addr_in );
39
+
40
+for( $i=0; $i<@addr_in; ++$i ){
41
+ @addr_tmp = split( ",", $addr_in[ $i ] );
42
+ %addr_out = ();
43
+ for( $j=0; $j<@fields; ++$j ){
44
+ if ( $addr_tmp[ $j ] =~ /^"(.*)"$/ ){
45
+ $addr_tmp[ $j ] = $1;
46
+ }
47
+ $addr_out{ $fields[ $j ] } = $addr_tmp[ $j ];
48
+ }
49
+
50
+ $Name = $addr_out{ "FileAs" };
51
+ $Yomi = $addr_out{ "YomiLastName" }.$addr_out{ "YomiFirstName" };
52
+ $Group = "0";
53
+ $Secret = "0";
54
+ $PostalCode = $addr_out{ "BusinessAddressPostalCode" };
55
+ $Addr = $addr_out{ "BusinessAddressState" }.$addr_out{ "BusinessAddressCity" }.$addr_out{ "BusinessAddressStreet" };
56
+ $Memo = $addr_out{ "CompanyName" };
57
+ if ( $addr_out{ "Birthday" } ne "" ){
58
+ $Birthday = "19".$addr_out{ "Birthday" };
59
+ }
60
+ $step = 0;
61
+ foreach $telkey ( @TelKeys ){
62
+ $addr_out{ $telkey } =~ tr/-() //d;
63
+ if ( $addr_out{ $telkey } ne "" ){
64
+ printf OUT (
65
+ "\"%s\",\"%s\",\"%s\",\"%s\",\"%s\",\"%s\",\"%s\",\"%s\",\"%s\",\"%s\",\"%s\",\"%s\"\n",
66
+ $MemoryNo+$i+$step, $Name, $Yomi, $addr_out{ $telkey }, $Group, $Icon{ $telkey },
67
+ $Secret, "", $PostalCode, $Addr, $Memo, $Birthday
68
+ );
69
+ $step += 700;
70
+ }
71
+ }
72
+ $step = 2800;
73
+ foreach $emailkey ( @EMailKeys ){
74
+ if ( $addr_out{ $emailkey } ne "" ){
75
+ printf OUT (
76
+ "\"%s\",\"%s\",\"%s\",\"%s\",\"%s\",\"%s\",\"%s\",\"%s\",\"%s\",\"%s\",\"%s\",\"%s\"\n",
77
+ $MemoryNo+$i+$step, $Name, $Yomi, "", $Group, $Icon{ $emailkey },
78
+ $Secret, $addr_out{ $emailkey }, $PostalCode, $Addr, $Memo, $Birthday
79
+ );
80
+ $step += 700;
81
+ }
82
+ }
83
+
84
+}
85
+
86
+close( OUT );
87
+
88
+# EOF
89
+```
90
+
91
+## アイコン番号
92
+| | 固定電話 |
93
+| --- | --- |
94
+| 1 | 携帯電話 |
95
+| 2 | 自宅電話 |
96
+| 3 | 会社電話 |
97
+| 4 | 会社FAX |
98
+| 24 | 一般メール |
99
+| 25 | 自宅メール |
100
+| 26 | 会社メール |
101
+| 27 | 携帯メール |
... ...
\ No newline at end of file
Perl/WhoisGW.md
... ...
@@ -0,0 +1,124 @@
1
+# WhoisGW
2
+[[_TOC_]]
3
+
4
+## 概要
5
+- jwhois を実行し、ドメイン管理者情報を表示します。
6
+- spam 送信の元になるため、パスワードを設定するなどして濫用させないようにすること。
7
+
8
+## ソース
9
+- [WhoisGW.zip](WhoisGW.zip)
10
+
11
+### WhoisGW.cgi
12
+```perl
13
+#!/usr/bin/perl
14
+# Whois ゲートウェイ
15
+# spam 送信の元になるため、パスワードを設定するなどして濫用させないようにすること。
16
+
17
+use strict;
18
+use warnings;
19
+use utf8;
20
+use Encode;
21
+use CGI::Pretty qw( -no_xhtml *table ); # //HTML 4.01 Transitional//EN
22
+
23
+my $charsetConsole = 'UTF-8';
24
+my $charsetFile = 'UTF-8';
25
+
26
+binmode( STDIN, ":encoding($charsetConsole)" );
27
+binmode( STDOUT, ":encoding($charsetConsole)" );
28
+binmode( STDERR, ":encoding($charsetConsole)" );
29
+
30
+my $cgiName = 'WhoisGW';
31
+
32
+my $q = new CGI;
33
+$q->charset( $charsetConsole );
34
+
35
+my $domain = $q->param( 'domain' ) || '';
36
+
37
+print makeHeader();
38
+if ( $domain ){
39
+ if ( $domain =~ /^(\d+\.\d+\.\d+\.\d+|[a-z0-9][\-\.a-z0-9]+[a-z0-9])$/i ){
40
+ print execWhois( $domain );
41
+ } else {
42
+ print makeForm();
43
+ print $q->p('ドメイン名が不正です。');
44
+ }
45
+} else {
46
+ print makeForm();
47
+}
48
+print makeFooter();
49
+
50
+exit;
51
+
52
+sub makeHeader
53
+{
54
+ my $ret = '';
55
+ $ret .= $q->header();
56
+ $ret .= $q->start_html(
57
+ -title => $cgiName,
58
+ -lang => 'ja-JP',
59
+ -head => [
60
+ $q->meta( { -http_equiv => 'Content-style-type', -content => 'text/css' } ),
61
+ $q->meta( { -http_equiv => 'Content-script-type', -content => 'text/javascript' } ),
62
+ ],
63
+ -style => [ { -src => '/take.css' }, ],
64
+ );
65
+ $ret .= $q->h1( $q->a( { -href => $q->url }, $cgiName ) );
66
+ return $ret;
67
+}
68
+
69
+sub makeFooter
70
+{
71
+ my $ret = '';
72
+ $ret .= $q->end_html . "\n";
73
+ return $ret;
74
+}
75
+
76
+sub execWhois
77
+{
78
+ my $domain = shift || '';
79
+ my $ret = $q->pre( join( "", `jwhois -df $domain` ) );
80
+ return $ret;
81
+}
82
+
83
+sub makeForm
84
+{
85
+ my $ret = '';
86
+ $ret .= $q->start_form(
87
+ -action => $q->url,
88
+ -enctype => 'multipart/form-data',
89
+ );
90
+ $ret .= $q->start_table( { -summary => 'Parameters', -border => 1 } );
91
+ $ret .= $q->Tr(
92
+ $q->th( 'Domain' ),
93
+ $q->td( $q->textfield( -name => 'domain', -size => 50 ) ),
94
+ );
95
+ $ret .= $q->Tr( $q->th(
96
+ { -colspan => 2, -align => 'center' },
97
+ $q->submit( -name => 'action', -value => 'search' ),
98
+ ) );
99
+ $ret .= $q->end_table();
100
+ $ret .= $q->end_form;
101
+ return $ret;
102
+}
103
+
104
+# EOF
105
+```
106
+
107
+### WhoisGW.conf
108
+```apache
109
+<Directory "/var/www/html/WhoisGW">
110
+ AllowOverride AuthConfig
111
+ AuthType Digest
112
+ AuthName "WhoisGW"
113
+ AuthUserFile /var/www/passwd/passwords_digest
114
+ Require user whois
115
+ Options +ExecCGI
116
+ DirectoryIndex index.html index.htm index.cgi
117
+ Order allow,deny
118
+ Allow from all
119
+</Directory>
120
+```
121
+
122
+## リンク
123
+- [aguse.jp](http://www.aguse.jp/) ウェブ調査
124
+- [ANSI Whois Gateway](http://whois.ansi.co.jp/) ドメイン名 / IPアドレス検索サービス
... ...
\ No newline at end of file
Perl/Windows_DLL_Call.md
... ...
@@ -0,0 +1,132 @@
1
+[[_TOC_]]
2
+
3
+# MessageBox
4
+## 概要
5
+- [MessageBox function](http://msdn.microsoft.com/en-us/library/windows/desktop/ms645505.aspx)を呼び出す。
6
+
7
+## ソース
8
+- [Win32MsdBox.zip](Win32MsdBox.zip)
9
+```perl
10
+#!/usr/bin/perl
11
+
12
+use strict;
13
+use warnings;
14
+use utf8;
15
+use Encode;
16
+use Win32::Unicode::Native;
17
+use Win32::API;
18
+
19
+#my $charsetFile = 'UTF-8';
20
+my $charsetConsole = 'CP932';
21
+my $charsetApiA = 'CP932';
22
+my $charsetApiW = 'UTF-16LE';
23
+
24
+my $message = "Hello, world!\nこんにちは世界？";
25
+my $type = 0x0000_0004 | 0x0000_0020;
26
+
27
+print "コンソール\n${message}\n";
28
+
29
+my $messageBoxA = Win32::API::More->new(
30
+ 'User32',
31
+ 'int MessageBoxA(HWND hWnd, LPCTSTR lpText, LPCTSTR lpCaption, UINT uType)'
32
+) or die(decode($charsetConsole, Win32::FormatMessage(Win32::GetLastError())));
33
+my $retA = $messageBoxA->Call(
34
+ 0, encode($charsetApiA, $message), encode($charsetApiA, "ApiA 版"), $type
35
+);
36
+print "${retA}\n";
37
+
38
+my $win32w = Win32::API::More->Import(
39
+ 'User32',
40
+ 'int MessageBoxW(HWND hWnd, LPCTSTR lpText, LPCTSTR lpCaption, UINT uType)'
41
+) or die(decode($charsetConsole, Win32::FormatMessage(Win32::GetLastError())));
42
+my $retW = MessageBoxW(
43
+ 0, encode($charsetApiW, $message), encode($charsetApiW, "ApiW 版"), $type
44
+);
45
+print "${retW}\n";
46
+
47
+# EOF
48
+```
49
+
50
+# 郵政バーコード
51
+## 概要
52
+- [Rolan社](http://www.rolan.co.jp/)の[郵便カスタマーバーコード開発キット](http://www.rolan.co.jp/shouhin/s_yubar.html)を呼び出す。
53
+- 住所データベース中の「郵便番号」と「丁目番地」から郵政バーコードを計算する。
54
+
55
+## ソース
56
+- [YuBar.zip](YuBar.zip)
57
+- Rolan社の YuBar.dll がインストールされていないと動作しません。
58
+- 住所データベースは架空のものであって、実在の人物、住所とは関係ありません。
59
+```perl
60
+# 郵政バーコード作成 (Rolan社 YuBar)
61
+# 郵便カスタマーバーコード開発キット http://www.rolan.co.jp/shouhin/s_yubar.html
62
+
63
+use strict;
64
+use warnings;
65
+use utf8;
66
+use encoding 'Shift_JIS';
67
+use Win32::API;
68
+#use Data::Dump 'dump';
69
+
70
+my $FileIn = 'Customer.txt'; # 入力ファイル
71
+my $FileOut = 'Customer2.txt'; # 出力ファイル
72
+
73
+open( IN, "<:encoding(Shift_JIS)", $FileIn ) || die( "can't open'".$FileIn."'.\n" );
74
+open( OUT, ">:encoding(Shift_JIS)", $FileOut ) || die( "can't open'".$FileOut."'.\n" );
75
+
76
+# ヘッダ行解析
77
+my $Line = <IN>;
78
+$Line =~ /(\s+)$/;
79
+$/ = $1; # 改行コード設定
80
+chomp( $Line );
81
+my @Fields = split( "\t", $Line );
82
+my $i = 0;
83
+#my %FN2I = (); # FieldName to Index
84
+#foreach $_ ( @Fields ){
85
+# $_ =~ s/^"(.*)"$/$1/;
86
+# $FN2I{ $_ } = $i++;
87
+#}
88
+my %FN2I = map{ s/^"(.*)"$/$1/; $_ => $i++; } @Fields;
89
+
90
+#print dump( %FN2I );
91
+
92
+print OUT $Line . "\t\"YuBar\"\n";
93
+
94
+my( @Records, $ZipCode, $Street, $YuBar );
95
+
96
+while( $Line = <IN> ){
97
+ chomp( $Line );
98
+ @Records = split( "\t", $Line );
99
+ $ZipCode = $Records[ $FN2I{ 'ZipCode' } ];
100
+ $ZipCode =~ s/^"(.*)"$/$1/;
101
+ $Street = $Records[ $FN2I{ 'Addr2' } ];
102
+ $Street =~ s/^"(.*)"$/$1/;
103
+ $YuBar = &YuBar( $ZipCode, $Street );
104
+ printf OUT ( "%s\t\"%s\"\n", $Line, $YuBar );
105
+}
106
+
107
+close( IN );
108
+close( OUT );
109
+
110
+exit();
111
+
112
+sub YuBar
113
+{
114
+ my( $ZipCode, $Street ) = @_;
115
+ my $GetYuBar = new Win32::API("YuBar", "YubinBarcode", 'PPP', 'I');
116
+ my $YuBarStr = "\x00" x 23;
117
+ my $Ret = ($GetYuBar->Call($ZipCode, $Street, $YuBarStr) & 0xFFFF);
118
+ return $YuBarStr;
119
+}
120
+
121
+# EOF
122
+```
123
+
124
+## リンク
125
+- [CPAN:Win32-API](http://search.cpan.org/dist/Win32-API)
126
+
127
+- [Rolan](http://www.rolan.co.jp/)
128
+ - [郵便カスタマーバーコード開発キット](http://www.rolan.co.jp/shouhin/s_yubar.html)
129
+
130
+- [郵便番号](http://www.post.japanpost.jp/zipcode/)
131
+ - [郵便番号制マニュアル](http://www.post.japanpost.jp/zipcode/zipmanual/)
132
+ - [ダウンロード](http://www.post.japanpost.jp/zipcode/download.html)
... ...
\ No newline at end of file
Perl/XML-Simple.md
... ...
@@ -0,0 +1 @@
1
+~~#include(Perl/Amazon/BrowseNodeSearch,notitle)~~
... ...
\ No newline at end of file
Perl/XML-XPath.md
... ...
@@ -0,0 +1,71 @@
1
+[[_TOC_]]
2
+----
3
+# 概要
4
+- XPathを使ってXMLを読む。
5
+
6
+# サンプルXML
7
+- [Monitor_6500K.zip](Monitor_6500K.zip)
8
+
9
+# ソース
10
+- dumpCXF.pl
11
+```perl
12
+#!/usr/local/bin/perl
13
+
14
+# CxF file からスペクトルの値を抜き出して表示
15
+# by take-ash
16
+# 2006.01.13
17
+# 注) 文字コード:UTF-8N、改行:LF で、このperlスクリプトを保存すること。
18
+
19
+use strict;
20
+use utf8;
21
+use XML::XPath;
22
+#use Data::Dump qw(dump);
23
+
24
+my $xp = XML::XPath->new( filename => 'Monitor_6500K.cxf' );
25
+# print dump( $xp );
26
+
27
+my $nodeset_samples = $xp->find( '/CXF/SampleSet/Sample' );
28
+
29
+foreach my $node_sample ( $nodeset_samples->get_nodelist() ) {
30
+ my $name = $xp->findvalue( './Name', $node_sample );
31
+ printf( "Name:\t%s\n", $name );
32
+
33
+ my $nodeset_values = $xp->find( './SampleAttribute/Spectrum/Value', $node_sample );
34
+ foreach my $node_value ( $nodeset_values->get_nodelist() ) {
35
+ my $name = $xp->findvalue( './@Name', $node_value );
36
+ my $value = $xp->findvalue( '.', $node_value );
37
+ printf( "%s\t%s\n", $name, $value );
38
+ }
39
+ print "\n";
40
+}
41
+
42
+#EOF
43
+```
44
+
45
+# XPathモジュールのインストール
46
+```
47
+ppm install XML-XPath
48
+```
49
+
50
+# DTD を読ませない
51
+- DTD を読ませないようにするには、LWP を無効化したパーサを指定する。
52
+```perl
53
+my $p = XML::Parser->new( NoLWP => 1 );
54
+my $xp = XML::XPath->new( parser => $p, filename => "a.xhtml" );
55
+```
56
+
57
+- [How can I prevent XML::XPath from fetching a DTD while processing an XML file? - Stack Overflow](http://stackoverflow.com/questions/303510/)
58
+
59
+# リンク
60
+- Perl/XML-Simple
61
+
62
+- [CPAN:XML-XPath](http://search.cpan.org/dist/XML-XPath)
63
+ - [Node/Element](http://search.cpan.org/dist/XML-XPath/lib/XML/XPath/Node/Element.pm)
64
+
65
+- [Walrus,Digit.:Perlモジュール/インストール(PPM)](http://digit.que.ne.jp/work/index.cgi?%50%65%72%6c%a5%e2%a5%b8%a5%e5%a1%bc%a5%eb%2f%a5%a4%a5%f3%a5%b9%a5%c8%a1%bc%a5%eb%28%50%50%4d%29)
66
+
67
+- [PerlでXMLを扱う](http://park8.wakwak.com/~da101/nikky/archives/000103.html)
68
+
69
+- [Perl XMLでencoding='Shift_JIS'や'euc-jp'を使う](http://homepage3.nifty.com/hippo2000/perltips/xml/xmlenc.htm)
70
+
71
+- [CxF](http://www.xrite.com/color-exchange-format) Color Exchange Format
... ...
\ No newline at end of file
Perl/YAML.md
... ...
@@ -0,0 +1,400 @@
1
+[[_TOC_]]
2
+
3
+# 記号の読み込みテスト
4
+
5
+## 概要
6
+- 記号そのものを値として読み込みたい場合、"" または '' で括る必要がある。
7
+
8
+## ソース
9
+- [marks.zip](marks.zip)
10
+
11
+- marks.pl
12
+```perl
13
+# YAML 記号の読み込みテスト
14
+# ハイフン, コロン, 角括弧, 波括弧, ハッシュ記号,
15
+# バックスラッシュ, シングルクォート, ダブルクォート,
16
+# 改行, タブ等の# 記号そのものを値として読み込みたい場合、
17
+# "" または '' で括る必要がある。
18
+
19
+use strict;
20
+use warnings;
21
+use utf8;
22
+use Encode;
23
+use YAML::Syck;
24
+use Data::Dump qw(dump);
25
+
26
+$YAML::Syck::ImplicitUnicode = 1;
27
+
28
+my $charset = 'CP932';
29
+
30
+binmode( STDIN, ":encoding($charset)" );
31
+binmode( STDOUT, ":encoding($charset)" );
32
+binmode( STDERR, ":encoding($charset)" );
33
+
34
+# バージョン確認
35
+print "Perl version: " . $] . "\n";
36
+print "YAML::Syck version: " . $YAML::Syck::VERSION . "\n";
37
+
38
+# 括るまたはエスケープ
39
+my $MarksFile = './marks.yaml';
40
+my $MarksIn = YAML::Syck::LoadFile( $MarksFile ) or die( "$MarksFile:$!" );
41
+print dump( $MarksIn ) . "\n";
42
+
43
+# 変数をシリアライズ
44
+my $MarksOut = [ '-', ':', '[', ']', '{', '}', '#', '\\', '\'', '\"', "\n", "\t", ];
45
+print Dump( $MarksOut ) . "\n";
46
+
47
+# EOF
48
+```
49
+
50
+- marks.yaml
51
+```
52
+---
53
+- "-"
54
+- ":"
55
+- "["
56
+- "]"
57
+- "{"
58
+- "}"
59
+- #
60
+- \#
61
+- "#"
62
+- \
63
+- \\
64
+- \'
65
+- "'"
66
+- \"
67
+- '"'
68
+- \n
69
+- "\n"
70
+- \t
71
+- "\t"
72
+```
73
+
74
+## 出力結果
75
+```
76
+Perl version: 5.010001
77
+YAML::Syck version: 1.15
78
+[
79
+ "-",
80
+ ":",
81
+ "[",
82
+ "]",
83
+ "{",
84
+ "}",
85
+ undef,
86
+ "\\#",
87
+ "#",
88
+ "\\",
89
+ "\\\\",
90
+ "\\'",
91
+ "'",
92
+ "\\\"",
93
+ "\"",
94
+ "\\n",
95
+ "\n",
96
+ "\\t",
97
+ "\t",
98
+]
99
+---
100
+- "-"
101
+- ":"
102
+- "["
103
+- "]"
104
+- "{"
105
+- "}"
106
+- "#"
107
+- \
108
+- "'"
109
+- \"
110
+- "\n"
111
+- "\t"
112
+```
113
+
114
+# 16進数等の読み込み
115
+
116
+## 概要
117
+- YAML::Syck で16進数等を解釈させたい場合は「$YAML::Syck::ImplicitTyping = 1;」が必要。
118
+
119
+## ソース
120
+- [NumberString1.zip](NumberString1.zip)
121
+
122
+- NumberString1.pl
123
+```perl
124
+#!/usr/bin/perl
125
+# YamlString.pl
126
+# YAML::Syck での数値文字列の読み込みテスト
127
+# 数値や論理値等として解釈させるには「$YAML::Syck::ImplicitTyping = 1;」が必要。
128
+
129
+use strict;
130
+use warnings;
131
+use utf8;
132
+use Encode;
133
+use YAML::Syck qw( Load Dump );
134
+
135
+$YAML::Syck::ImplicitUnicode = 1;
136
+
137
+#my $charsetConsole = 'UTF-8';
138
+my $charsetConsole = 'CP932';
139
+my $charsetFile = 'UTF-8';
140
+
141
+binmode( STDIN, ":encoding($charsetConsole)" );
142
+binmode( STDOUT, ":encoding($charsetConsole)" );
143
+binmode( STDERR, ":encoding($charsetConsole)" );
144
+
145
+# バージョン確認
146
+print "Perl version: $]\n";
147
+print "YAML::Syck version: $YAML::Syck::VERSION\n";
148
+
149
+my $yamlString = qq{
150
+Decimal: [ 0, 1, 2, 4, 8, 10, 16 ]
151
+Binal: [ 0b00000, 0b00001, 0b00010, 0b00100, 0b01000, 0b01010, 0b10000 ]
152
+Octal: [ 000, 001, 002, 004, 010, 012, 020 ]
153
+Hexadecimal: [ 0x00, 0x01, 0x02, 0x04, 0x08, 0x0a, 0x10 ]
154
+Boolean: [ true, false, yes, no, on, off, null, ~ ]
155
+漢字: [ 壱, 弐, 参, 四, 五 ]
156
+HexKey: { 0x00: "00", 0x01: "01", 0x02: "02", 0x04: "04", 0x08: "08", 0x0a: "0a", 0x10: "10" }
157
+};
158
+
159
+$YAML::Syck::ImplicitTyping = 0; # Default
160
+print "\n\$YAML::Syck::ImplicitTyping = 0\n";
161
+print Dump( Load( $yamlString ) );
162
+
163
+$YAML::Syck::ImplicitTyping = 1;
164
+print "\n\$YAML::Syck::ImplicitTyping = 1\n";
165
+print Dump( Load( $yamlString ) );
166
+
167
+# EOF
168
+```
169
+
170
+## 出力結果
171
+```
172
+Perl version: 5.014002
173
+YAML::Syck version: 1.21
174
+
175
+$YAML::Syck::ImplicitTyping = 0
176
+---
177
+Binal:
178
+ - 0b00000
179
+ - 0b00001
180
+ - 0b00010
181
+ - 0b00100
182
+ - 0b01000
183
+ - 0b01010
184
+ - 0b10000
185
+Boolean:
186
+ - 'true'
187
+ - 'false'
188
+ - 'yes'
189
+ - 'no'
190
+ - 'on'
191
+ - 'off'
192
+ - 'null'
193
+ - ~
194
+Decimal:
195
+ - 0
196
+ - 1
197
+ - 2
198
+ - 4
199
+ - 8
200
+ - 10
201
+ - 16
202
+HexKey:
203
+ 0x00: '00'
204
+ 0x01: '01'
205
+ 0x02: '02'
206
+ 0x04: '04'
207
+ 0x08: '08'
208
+ 0x0a: 0a
209
+ 0x10: 10
210
+Hexadecimal:
211
+ - 0x00
212
+ - 0x01
213
+ - 0x02
214
+ - 0x04
215
+ - 0x08
216
+ - 0x0a
217
+ - 0x10
218
+Octal:
219
+ - '000'
220
+ - '001'
221
+ - '002'
222
+ - '004'
223
+ - '010'
224
+ - '012'
225
+ - '020'
226
+漢字:
227
+ - 壱
228
+ - 弐
229
+ - 参
230
+ - 四
231
+ - 五
232
+
233
+$YAML::Syck::ImplicitTyping = 1
234
+---
235
+Binal:
236
+ - 0b00000
237
+ - 0b00001
238
+ - 0b00010
239
+ - 0b00100
240
+ - 0b01000
241
+ - 0b01010
242
+ - 0b10000
243
+Boolean:
244
+ - 1
245
+ - ''
246
+ - 1
247
+ - ''
248
+ - 1
249
+ - ''
250
+ - ~
251
+ - ~
252
+Decimal:
253
+ - 0
254
+ - 1
255
+ - 2
256
+ - 4
257
+ - 8
258
+ - 10
259
+ - 16
260
+HexKey:
261
+ 0: '00'
262
+ 1: '01'
263
+ 10: 0a
264
+ 16: 10
265
+ 2: '02'
266
+ 4: '04'
267
+ 8: '08'
268
+Hexadecimal:
269
+ - 0
270
+ - 1
271
+ - 2
272
+ - 4
273
+ - 8
274
+ - 10
275
+ - 16
276
+Octal:
277
+ - 0
278
+ - 1
279
+ - 2
280
+ - 4
281
+ - 8
282
+ - 10
283
+ - 16
284
+漢字:
285
+ - 壱
286
+ - 弐
287
+ - 参
288
+ - 四
289
+ - 五
290
+```
291
+
292
+# 正規表現
293
+
294
+## 概要
295
+- YAML 中での正規表現の表記方法。
296
+- YAML::Syck で Dump すると、非 ASCII 文字列はバイト列となる。
297
+- バイト列を Load しても utf8 フラグが失われているため、ユニコード文字列にはマッチしない。
298
+- 正規表現中にユニコード文字を入れたい場合は、\x{xxxx} または \N{U+xxxx} と表記しなければならない。
299
+- 正規表現の文字列化 ([perl v5.14.0 での変更点](http://perldoc.jp/docs/perl/5.14.0/perl5140delta.pod#Regular32Expressions))
300
+ - perl 5.14 以降: (?^:...)
301
+ - perl 5.14 前: (?-xism:...)
302
+
303
+## ソース
304
+- [RegExp.zip](RegExp.zip)
305
+```perl
306
+#!/usr/bin/perl
307
+# 正規表現の読み込み
308
+
309
+use strict;
310
+use warnings;
311
+use utf8;
312
+use Encode;
313
+use YAML::Syck qw( Load Dump );
314
+use Win32::Unicode::Native;
315
+
316
+$YAML::Syck::ImplicitUnicode = 1;
317
+
318
+# バージョン確認
319
+print "Perl version: $]\n";
320
+print "YAML::Syck version: $YAML::Syck::VERSION\n";
321
+
322
+my $obj = {
323
+ '\[AD\]$' => qr/\[AD\]$/i,
324
+ '\[広\s?告\]$' => qr/\[広\s?告\]$/,
325
+ '(吉|\x{20bb7})野' => qr/(吉|\x{20bb7})野/,
326
+};
327
+my $yaml = Dump( $obj );
328
+print $yaml;
329
+my $yaml2 = q{
330
+---
331
+'\[AD\]$':
332
+ !!perl/regexp (?^i:\[AD\]$)
333
+'\[広\s?告\]$':
334
+ !!perl/regexp (?^:\[\x{5e83}\s?\x{544a}\]$)
335
+'(吉|\x{20bb7})野':
336
+ !!perl/regexp (?^:(\x{5409}|\x{20bb7})\x{91ce})
337
+};
338
+print $yaml2;
339
+my $conf = Load($yaml2);
340
+print Dump($conf);
341
+
342
+print "====\n";
343
+
344
+my @samples = (
345
+ "無料で始める恋愛ドラマアプリ[広 告]",
346
+ "この夏をもっと楽しもう[Ad]",
347
+ "\x{20BB7}野家",
348
+);
349
+
350
+foreach my $sample (@samples){
351
+ my $isMatch = '';
352
+ foreach my $regex (keys(%{$conf})){
353
+ if ( $sample =~ $conf->{$regex} ){
354
+ $isMatch = $regex;
355
+ last;
356
+ }
357
+ }
358
+ if ( $isMatch ){
359
+ printf("match(%s): '%s'\n", $isMatch, $sample);
360
+ } else {
361
+ printf("not match: '%s'\n", $sample);
362
+ }
363
+}
364
+
365
+# EOF
366
+```
367
+
368
+## 出力結果
369
+```
370
+Perl version: 5.014004
371
+YAML::Syck version: 1.22
372
+---
373
+"(吉|\\x{20bb7})野": !!perl/regexp "(?^u:(\xE5\x90\x89|\\x{20bb7})\xE9\x87\x8E)"
374
+
375
+\[AD\]$: !!perl/regexp (?^i:\[AD\]$)
376
+"\\[広\\s?告\\]$": !!perl/regexp "(?^u:\\[\xE5\xBA\x83\\s?\xE5\x91\x8A\\]$)"
377
+
378
+---
379
+'\[AD\]$':
380
+ !!perl/regexp (?^i:\[AD\]$)
381
+'\[広\s?告\]$':
382
+ !!perl/regexp (?^:\[\x{5e83}\s?\x{544a}\]$)
383
+'(吉|\x{20bb7})野':
384
+ !!perl/regexp (?^:(\x{5409}|\x{20bb7})\x{91ce})
385
+---
386
+"(吉|\\x{20bb7})野": !!perl/regexp (?^u:(?^:(\x{5409}|\x{20bb7})\x{91ce}))
387
+\[AD\]$: !!perl/regexp (?^:(?^i:\[AD\]$))
388
+"\\[広\\s?告\\]$": !!perl/regexp (?^u:(?^:\[\x{5e83}\s?\x{544a}\]$))
389
+====
390
+match(\[広\s?告\]$): '無料で始める恋愛ドラマアプリ[広 告]'
391
+match(\[AD\]$): 'この夏をもっと楽しもう[Ad]'
392
+match((吉|\x{20bb7})野): '𠮷野家'
393
+```
394
+
395
+# リンク
396
+- http://yaml.org/ / [仕様](http://yaml.org/spec/current.html)
397
+- [CPAN:YAML-Syck](http://search.cpan.org/dist/YAML-Syck)
398
+- [Rubyist Magazine - プログラマーのための YAML 入門 (初級編)](http://jp.rubyist.net/magazine/?0009-YAML)
399
+
400
+- [CPAN:Config-IniFiles](http://search.cpan.org/dist/Config-IniFiles)
... ...
\ No newline at end of file
Perl/compareXML.md
... ...
@@ -0,0 +1,378 @@
1
+# XMLファイルを比較
2
+[[_TOC_]]
3
+
4
+## 概要
5
+- XMLファイルを比較し、要素/属性が一致する場合は「=:」、不一致の場合は行頭に「!」を付けて表示します。
6
+- 他方に項目が無かった場合は「~」が表示されます。
7
+- XMLの要素も属性も共に配列ではなくハッシュとして取り扱います。
8
+- 設定を外部ファイルから読み込むようにしました。(2012/05/20)
9
+ - Settings.yml では、PARAM要素を、NAME属性をキー、VALUE属性を値とするハッシュに変換します。
10
+- ３つ以上のXMLファイルも比較できるようにしました。(2012/05/20)
11
+- 初版(2012/05/18)
12
+
13
+## ソース
14
+- [compareXML.zip](compareXML.zip)
15
+
16
+## compareXML.pl
17
+```perl
18
+# XMLファイルを比較
19
+
20
+use strict;
21
+use warnings;
22
+use utf8;
23
+use Encode;
24
+use XML::Simple;
25
+use YAML::Syck;
26
+use Getopt::Long;
27
+
28
+$YAML::Syck::ImplicitUnicode = 1;
29
+
30
+my $charsetConsole = 'CP932';
31
+my $charsetFile = 'UTF-8';
32
+
33
+binmode( STDIN, ":encoding($charsetConsole)" );
34
+binmode( STDOUT, ":encoding($charsetConsole)" );
35
+binmode( STDERR, ":encoding($charsetConsole)" );
36
+
37
+my $configFile = "";
38
+my $config = {
39
+ 'Output' => "diff.txt",
40
+ 'Indent' => "\t",
41
+ 'XMLOpt' => {},
42
+};
43
+my @FileNames = ();
44
+my $root = {};
45
+
46
+@ARGV = map{ decode( $charsetConsole, $_ ); } @ARGV;
47
+
48
+my $result = GetOptions(
49
+ "config=s" => \$configFile,
50
+);
51
+
52
+if ( @ARGV < 2 ){
53
+ die( "usage: compareXML [-config <yml>] <xml> <xml> [<xml> ...]\n" );
54
+}
55
+
56
+if ( $configFile ){
57
+ my $config2 = YAML::Syck::LoadFile( encode( $charsetConsole, $configFile ) )
58
+ or die( "$configFile: $!\n" );
59
+ $config = { %{$config}, %{$config2} };
60
+}
61
+my $fileOut = $config->{'Output'};
62
+my $IndentBase = $config->{'Indent'};
63
+
64
+my $xs = XML::Simple->new( %{$config->{'XMLOpt'}} );
65
+
66
+foreach my $file ( @ARGV ){
67
+ if ( -f encode( $charsetConsole, $file ) ){
68
+ push( @FileNames, $file );
69
+ $root->{$file} = $xs->XMLin( encode( $charsetConsole, $file ) );
70
+ } else {
71
+ die( "Not exist: $file\n" );
72
+ }
73
+}
74
+
75
+open( my $fhout, ">:encoding($charsetFile)", encode( $charsetConsole, $fileOut ) )
76
+ or die( "$fileOut: $!" );
77
+
78
+#print $fhout Dump( $xml );
79
+compareNodes( $root, 0 );
80
+
81
+close( $fhout );
82
+
83
+sub compareNodes
84
+{
85
+ my( $href, $indent ) = @_;
86
+ my $IndentText1 = $IndentBase x $indent;
87
+ my $IndentText2 = $IndentBase x ( $indent + 1 );
88
+
89
+ # すべてのキーを列挙
90
+ my %currentkeys = ();
91
+ foreach my $fn ( @FileNames ){
92
+ if ( ref( $href->{$fn} ) eq 'HASH' ){
93
+ foreach my $key ( keys( %{$href->{$fn}} ) ){
94
+ $currentkeys{$key} = 1;
95
+ }
96
+ }
97
+ }
98
+ foreach my $key ( sort( keys( %currentkeys ) ) ){
99
+ printf $fhout ( "%s%s:\n", $IndentText1, $key );
100
+ my $bHash = 0; # どちらかがハッシュなら1
101
+ my $child = {};
102
+ foreach my $fn ( @FileNames ){
103
+ if ( ref( $href->{$fn} ) eq 'HASH' ){
104
+ my $t1 = $href->{$fn}{$key} // '~'; # undef は '~'
105
+ $child->{$fn} = $t1;
106
+ if ( ref( $t1 ) eq 'HASH' ){
107
+ $bHash = 1;
108
+ }
109
+ } else {
110
+ $child->{$fn} = '~';
111
+ }
112
+ }
113
+ if ( $bHash ){
114
+ # どちらかがハッシュの場合は再帰探索
115
+ compareNodes( $child, $indent + 1 );
116
+ } else {
117
+ # 両方共ハッシュでなければ値の表示
118
+ if ( eqAll( $child ) ){
119
+ # 一致する場合は「=:」でまとめて表示
120
+ printf $fhout (
121
+ "%s=:%s%s\n",
122
+ $IndentText2, $IndentBase, $child->{$FileNames[0]}
123
+ );
124
+ } else {
125
+ # 不一致の場合は行頭に「!」を付けて表示
126
+ foreach my $fn ( @FileNames ){
127
+ printf $fhout (
128
+ "!%s%s:%s%s\n",
129
+ $IndentText2, $fn, $IndentBase, $child->{$fn}
130
+ );
131
+ }
132
+ }
133
+ }
134
+ }
135
+}
136
+
137
+## @function eqAll( %$refHash )
138
+# ハッシュの全ての値を比較する。
139
+# @retval 一致 1
140
+# @retval 不一致 0
141
+sub eqAll
142
+{
143
+ my( $refHash ) = @_;
144
+ my $bEqual = 1;
145
+ my @Keys = keys( %{$refHash} );
146
+ my $first = $refHash->{ shift( @Keys ) };
147
+ foreach my $key ( @Keys ){
148
+ if ( $first ne $refHash->{ $key } ){
149
+ $bEqual = 0;
150
+ last;
151
+ }
152
+ }
153
+ return $bEqual;
154
+}
155
+
156
+# EOF
157
+```
158
+
159
+## 入力
160
+### Settings.yml
161
+```
162
+Output: diff.txt
163
+Indent: "\t"
164
+
165
+XMLOpt:
166
+ ForceArray:
167
+ - PARAM
168
+ KeyAttr:
169
+ PARAM: NAME
170
+ OPERATION: NAME
171
+ ContentKey:
172
+ "-VALUE"
173
+```
174
+
175
+### Item1.xml
176
+```
177
+<SETTINGS NAME="Item1" VERSION="8" >
178
+ <DOCUMENT DOCUMENT_ID="79" NAME="Doc02.indd" SRC="//localhost/Data/2/2/" TYPE="INDD" />
179
+ <OUTPUT>
180
+ <PARAM NAME="START_RECORD" VALUE="1" />
181
+ <PARAM NAME="END_RECORD" VALUE="100" />
182
+ <PARAM NAME="TYPE" VALUE="PDF" />
183
+ <PARAM NAME="CENTER_PAGE" VALUE="0" />
184
+ </OUTPUT>
185
+ <ASSET_LIST Resolve="1">
186
+ <ASSET ID="73" NAME="Assets1" PRIORITY="1" TYPE="LOCAL" >
187
+ <PARAM NAME="BaseID" VALUE="1" />
188
+ </ASSET>
189
+ </ASSET_LIST>
190
+ <DATA_SOURCES>
191
+ <DATA_SOURCE ID="13" >
192
+ <PARAM NAME="FILENAME" VALUE="db1.csv" />
193
+ <PARAM NAME="TYPE" VALUE="TEXT" />
194
+ </DATA_SOURCE>
195
+ </DATA_SOURCES>
196
+ <FONT_LIST>
197
+ <FONT ID="20" NAME="Arial" OPTION="OpenType" />
198
+ </FONT_LIST>
199
+ <POST_PRODUCTION />
200
+</SETTINGS>
201
+```
202
+
203
+### Item2.xml
204
+```
205
+<SETTINGS NAME="Item2" VERSION="8" >
206
+ <DOCUMENT DOCUMENT_ID="78" NAME="Doc01.indd" SRC="//localhost/Data/2/1/" TYPE="INDD" />
207
+ <ASSET_LIST Resolve="1">
208
+ <ASSET ID="73" NAME="Assets1" PRIORITY="1" TYPE="LOCAL" >
209
+ <PARAM NAME="BaseID" VALUE="1" />
210
+ </ASSET>
211
+ </ASSET_LIST>
212
+ <JOB ID="330" TYPE="PRINT">
213
+ <PARAM NAME="HOST_NAME" VALUE="localhost" />
214
+ <JOB_CONTEXT JobID="330" JobName="Doc01" JobType="1" />
215
+ </JOB>
216
+ <OUTPUT MEDIA="1" OUTPUT_FILE_NAME="Doc01" TYPE="PDF">
217
+ <PARAM NAME="TYPE" VALUE="PDF" />
218
+ <PARAM NAME="START_RECORD" VALUE="80" />
219
+ <PARAM NAME="END_RECORD" VALUE="100" />
220
+ <PARAM NAME="FONTS_POLICY" VALUE="1" />
221
+ <PARAM NAME="OVERFLOW_POLICY" VALUE="0" />
222
+ </OUTPUT>
223
+ <FONT_LIST>
224
+ <FONT ID="20" NAME="Arial" />
225
+ </FONT_LIST>
226
+ <POST_PRODUCTION JOBID="330">
227
+ <OPERATION NAME="IMPOSITION">
228
+ <PARAM NAME="NUPX" VALUE="1" />
229
+ <PARAM NAME="NUPY" VALUE="2" />
230
+ </OPERATION>
231
+ <OPERATION NAME="DISTILLER">
232
+ <PARAM NAME="DSTL_SETTINGS" VALUE="HighQuality" />
233
+ </OPERATION>
234
+ <OPERATION NAME="COPY">
235
+ <PARAM NAME="DEST_PATH" VALUE="//localhost/Output/2/1/" />
236
+ </OPERATION>
237
+ </POST_PRODUCTION>
238
+ <TRACK_INFO />
239
+</SETTINGS>
240
+```
241
+
242
+## 出力
243
+```
244
+ASSET_LIST:
245
+ ASSET:
246
+ ID:
247
+ =: 73
248
+ NAME:
249
+ =: Assets1
250
+ PARAM:
251
+ BaseID:
252
+ =: 1
253
+ PRIORITY:
254
+ =: 1
255
+ TYPE:
256
+ =: LOCAL
257
+ Resolve:
258
+ =: 1
259
+DATA_SOURCES:
260
+ DATA_SOURCE:
261
+ ID:
262
+! Item1.xml: 13
263
+! Item2.xml: ~
264
+ PARAM:
265
+ FILENAME:
266
+! Item1.xml: db1.csv
267
+! Item2.xml: ~
268
+ TYPE:
269
+! Item1.xml: TEXT
270
+! Item2.xml: ~
271
+DOCUMENT:
272
+ DOCUMENT_ID:
273
+! Item1.xml: 79
274
+! Item2.xml: 78
275
+ NAME:
276
+! Item1.xml: Doc02.indd
277
+! Item2.xml: Doc01.indd
278
+ SRC:
279
+! Item1.xml: //localhost/Data/2/2/
280
+! Item2.xml: //localhost/Data/2/1/
281
+ TYPE:
282
+ =: INDD
283
+FONT_LIST:
284
+ FONT:
285
+ ID:
286
+ =: 20
287
+ NAME:
288
+ =: Arial
289
+ OPTION:
290
+! Item1.xml: OpenType
291
+! Item2.xml: ~
292
+JOB:
293
+ ID:
294
+! Item1.xml: ~
295
+! Item2.xml: 330
296
+ JOB_CONTEXT:
297
+ JobID:
298
+! Item1.xml: ~
299
+! Item2.xml: 330
300
+ JobName:
301
+! Item1.xml: ~
302
+! Item2.xml: Doc01
303
+ JobType:
304
+! Item1.xml: ~
305
+! Item2.xml: 1
306
+ PARAM:
307
+ HOST_NAME:
308
+! Item1.xml: ~
309
+! Item2.xml: localhost
310
+ TYPE:
311
+! Item1.xml: ~
312
+! Item2.xml: PRINT
313
+NAME:
314
+! Item1.xml: Item1
315
+! Item2.xml: Item2
316
+OUTPUT:
317
+ MEDIA:
318
+! Item1.xml: ~
319
+! Item2.xml: 1
320
+ OUTPUT_FILE_NAME:
321
+! Item1.xml: ~
322
+! Item2.xml: Doc01
323
+ PARAM:
324
+ CENTER_PAGE:
325
+! Item1.xml: 0
326
+! Item2.xml: ~
327
+ END_RECORD:
328
+ =: 100
329
+ FONTS_POLICY:
330
+! Item1.xml: ~
331
+! Item2.xml: 1
332
+ OVERFLOW_POLICY:
333
+! Item1.xml: ~
334
+! Item2.xml: 0
335
+ START_RECORD:
336
+! Item1.xml: 1
337
+! Item2.xml: 80
338
+ TYPE:
339
+ =: PDF
340
+ TYPE:
341
+! Item1.xml: ~
342
+! Item2.xml: PDF
343
+POST_PRODUCTION:
344
+ JOBID:
345
+! Item1.xml: ~
346
+! Item2.xml: 330
347
+ OPERATION:
348
+ COPY:
349
+ PARAM:
350
+ DEST_PATH:
351
+! Item1.xml: ~
352
+! Item2.xml: //localhost/Output/2/1/
353
+ DISTILLER:
354
+ PARAM:
355
+ DSTL_SETTINGS:
356
+! Item1.xml: ~
357
+! Item2.xml: HighQuality
358
+ IMPOSITION:
359
+ PARAM:
360
+ NUPX:
361
+! Item1.xml: ~
362
+! Item2.xml: 1
363
+ NUPY:
364
+! Item1.xml: ~
365
+! Item2.xml: 2
366
+TRACK_INFO:
367
+VERSION:
368
+ =: 8
369
+```
370
+
371
+## Link
372
+- Perl/XML-Simple
373
+
374
+- [CPAN:XML-Simple](http://search.cpan.org/dist/XML-Simple)
375
+- [CPAN:Getopt-Long](http://search.cpan.org/dist/Getopt-Long)
376
+
377
+- [XML Notepad](http://www.microsoft.com/en-us/download/details.aspx?id=7973) XmlDiff機能あり
378
+- [diffxml](http://diffxml.sourceforge.net/) XML Diff and Patch Utilities
... ...
\ No newline at end of file
Perl/createUniqKeyList.md
... ...
@@ -0,0 +1,86 @@
1
+[[_TOC_]]
2
+
3
+# 概要
4
+- 重複のないランダムなキーの一群を作る。
5
+- キーの長さと使用可能文字数が、キーの個数に対して十分かどうかチェック。(2007/06/18)
6
+- Text::CSV_XS, Win32::Unicode::Native を使用するようにした。(2013/06/07)
7
+
8
+# ソース
9
+- [createUniqKeyList.zip](createUniqKeyList.zip)
10
+```perl
11
+# ユニークキー作成スクリプト
12
+# by take-ash
13
+# 2013.06.07
14
+#
15
+# 重複のないランダムなキーの一群を作る。
16
+
17
+use strict;
18
+use warnings;
19
+use utf8;
20
+use Encode;
21
+use Text::CSV_XS;
22
+use Win32::Unicode::Native;
23
+
24
+my $charsetFile = 'UTF-8';
25
+
26
+my $fileNameOut = 'uniqueKeys.txt'; # 出力ファイル名。
27
+my $keyLength = 6; # キーの長さ
28
+my $keyMax = 50; # キーの個数
29
+my $possibleChar = # 使用可能文字
30
+# 'あいうえお' .
31
+ 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' .
32
+ 'abcdefghijklmnopqrstuvwxyz' .
33
+ '0123456789';
34
+my $keyCharMax = length( $possibleChar );
35
+
36
+if ( ( $keyCharMax ** $keyLength ) < $keyMax ){
37
+ die( "Too short KeyLength or Too few PossibleChar against KeyMax.\n" );
38
+}
39
+
40
+my %keyPool = ();
41
+my @keyList = ( [ 'ID', 'Key' ] );
42
+
43
+srand( time );
44
+
45
+$| = 1;
46
+
47
+for( my $i=1; $i <= $keyMax; ++$i ){
48
+ printf( "%d/%d\r", $i, $keyMax );
49
+ my $tmpKey = makeNewKey();
50
+ while( $keyPool{ $tmpKey } ){
51
+ $tmpKey = makeNewKey();
52
+ }
53
+ $keyPool{ $tmpKey } = 1;
54
+ push( @keyList, [ $i, $tmpKey ] );
55
+}
56
+print "\n";
57
+$| = 0;
58
+
59
+my $csv = Text::CSV_XS->new({ binary => 1, sep_char => "\t", eol => $/ });
60
+open( my $OUT, ">:encoding($charsetFile)", $fileNameOut )
61
+ or die( "$fileNameOut: $!\n" );
62
+foreach my $row ( @keyList ){
63
+ $csv->print( $OUT, $row );
64
+}
65
+close( $OUT );
66
+
67
+exit;
68
+
69
+sub makeNewKey {
70
+ my $result = '';
71
+
72
+ while( length( $result ) < $keyLength ){
73
+ $result .= substr( $possibleChar, int( rand( $keyCharMax ) ), 1 );
74
+ }
75
+
76
+ return $result;
77
+}
78
+
79
+# EOF
80
+```
81
+
82
+# リンク
83
+- [[Perl/readXSV]]
84
+
85
+- [CPAN:Text-CSV_XS](http://search.cpan.org/dist/Text-CSV_XS)
86
+- [CPAN:Win32-Unicode](http://search.cpan.org/dist/Win32-Unicode)
... ...
\ No newline at end of file
Perl/decodeQuotedPrintable.md
... ...
@@ -0,0 +1,58 @@
1
+# Quoted Printableのデコード
2
+[[_TOC_]]
3
+
4
+## 概要
5
+- ファイルとして保存された Quoted Printable をデコードする。
6
+- デコードされたファイルの名前は元のファイル名に「.html」を付けたものになる。
7
+- 既存ファイルは問い合わせなしに上書きされる。
8
+- 対象のファイルを選択し、コンテキストメニューの「送る」(SendTo) からスクリプトを呼び出す。
9
+- スクリプトへのショートカットのリンク先には「%1」を付けてはいけない。
10
+```
11
+C:\Perl\bin\perl.exe "D:\myscripts\decodeQuotedPrintable.pl"
12
+```
13
+
14
+## ソース
15
+- [decodeQuotedPrintable.zip](decodeQuotedPrintable.zip)
16
+```
17
+# quoted-printable のデコード
18
+
19
+use strict;
20
+use warnings;
21
+use utf8;
22
+use Encode;
23
+use MIME::QuotedPrint;
24
+use Term::ReadKey;
25
+
26
+my $charset = 'CP932';
27
+
28
+binmode( STDIN, ":encoding($charset)" );
29
+binmode( STDOUT, ":encoding($charset)" );
30
+binmode( STDERR, ":encoding($charset)" );
31
+
32
+@ARGV = map{ decode( $charset, $_ ); } @ARGV;
33
+
34
+foreach my $fileNameIn ( @ARGV ){
35
+ warn( "$fileNameIn\n" );
36
+ my $fileNameOut = $fileNameIn . '.html';
37
+
38
+ open( my $fin, "<:utf8", encode( $charset, $fileNameIn ) ) or die( "$fileNameIn: $!\n" );
39
+ my @lines = <$fin>;
40
+ close( $fin );
41
+ my $body = join( '', @lines );
42
+
43
+ $body = decode_qp( $body );
44
+
45
+ open( my $fout, ">:utf8", encode( $charset, $fileNameOut ) ) or die( "$fileNameOut: $!\n" );
46
+ print $fout $body;
47
+ close( $fout );
48
+}
49
+
50
+warn( "Hit Enter.\n" );
51
+ReadKey(0);
52
+
53
+# EOF
54
+```
55
+
56
+## リンク
57
+- [CPAN:MIME-Base64](http://search.cpan.org/dist/MIME-Base64)
58
+- [CPAN:TermReadKey](http://search.cpan.org/dist/TermReadKey)
... ...
\ No newline at end of file
Perl/getDiskUsage.md
... ...
@@ -0,0 +1,55 @@
1
+[[_TOC_]]
2
+
3
+# 概要
4
+- 指定したパスを含むパーティションの使用容量(%)を調べる。
5
+
6
+# Filesys::Df 版
7
+- 使用パーセントは「per」で得られる。
8
+
9
+## ソース
10
+- [getDiskUsage.zip](getDiskUsage.zip)
11
+```perl
12
+#!/usr/bin/perl
13
+# 指定したパスを含むパーティションの使用状況を調べる。
14
+
15
+use strict;
16
+use warnings;
17
+use utf8;
18
+use Filesys::Df;
19
+use Number::Format qw(:subs);
20
+
21
+my $path = shift or die("usage: getDiskUsage <path>\n");
22
+my $refDf = df($path, 1) or die("$!\n");
23
+foreach my $key (sort(keys(%{$refDf}))){
24
+ print $key . ":\t" . format_bytes($refDf->{$key}) . "\n";
25
+}
26
+
27
+# EOF
28
+```
29
+
30
+# 自前版
31
+- OSコマンド・インジェクション対策はしてないので、安全なパスのみ渡すようにすること。
32
+- エラー時には「-1」が戻る。
33
+
34
+## ソース
35
+```perl
36
+sub getDiskUsage
37
+{
38
+ my $path = shift || '/';
39
+ my $result = `df -h $path`;
40
+ $result =~ /(\d+)%\s+\//;
41
+ return $1 || -1;
42
+}
43
+```
44
+
45
+# リンク
46
+- [CPAN:Filesys-Df](http://search.cpan.org/dist/Filesys-Df)
47
+- [CPAN:Filesys-DfPortable](http://search.cpan.org/dist/Filesys-DfPortable)
48
+- [CPAN:Number-Format](http://search.cpan.org/dist/Number-Format)
49
+
50
+- [IPA セキュア・プログラミング講座：Webアプリケーション編](http://www.ipa.go.jp/security/awareness/vendor/programmingv2/web.html)
51
+ - [第6章 入力対策：コマンド注入攻撃対策](http://www.ipa.go.jp/security/awareness/vendor/programmingv2/contents/501.html)
52
+- [安全なウェブサイトの作り方：IPA](http://www.ipa.go.jp/security/vuln/websecurity.html)
53
+
54
+- [Linuxコマンド集 - 【 df 】 ディスク・ドライブの使用量を表示する：ITpro](http://itpro.nikkeibp.co.jp/article/COLUMN/20060227/230742/)
55
+- [Linuxコマンド集 - 【 du 】 ディレクトリ内のファイル容量を表示する：ITpro](http://itpro.nikkeibp.co.jp/article/COLUMN/20060227/230748/)
... ...
\ No newline at end of file
Perl/getHostName.md
... ...
@@ -0,0 +1,54 @@
1
+[[_TOC_]]
2
+----
3
+# 概要
4
+- IPアドレスからホスト名を逆引きする。
5
+- IPv6 対応。
6
+
7
+# ソース
8
+- [getHostName.zip](getHostName.zip)
9
+```perl
10
+#!/usr/bin/perl
11
+# ホスト名逆引き(IPv6にも対応)
12
+# http://www.alib.jp/perl/resolv.html
13
+
14
+use strict;
15
+use warnings;
16
+use utf8;
17
+use Encode;
18
+use Net::DNS::Resolver;
19
+
20
+my $ip = $ARGV[0] || '';
21
+my $name = getHostName( $ip );
22
+print "IP:\t${ip}\nHost:\t${name}\n";
23
+
24
+sub getHostName
25
+{
26
+ my $ip_address = shift || '';
27
+ my $ret = '';
28
+
29
+ my $resolver = Net::DNS::Resolver->new;
30
+ if ( my $ans = $resolver->query( $ip_address ) ){
31
+ for my $rr ( $ans->answer ){
32
+ #print $rr->string, "\n";
33
+ if ( $rr->type eq 'PTR' ){
34
+ $ret = $rr->ptrdname;
35
+ last;
36
+ }
37
+ }
38
+ }
39
+
40
+ return $ret;
41
+}
42
+
43
+# EOF
44
+```
45
+
46
+# リンク
47
+- [[Perl/HostToIP]]
48
+
49
+- [CPAN:Net-DNS](http://search.cpan.org/dist/Net-DNS)
50
+ - [CPAN:Net-DNS/lib/Net/DNS/Resolver.pm](http://search.cpan.org/dist/Net-DNS/lib/Net/DNS/Resolver.pm)
51
+ - [CPAN:Net-DNS/lib/Net/DNS/RR.pm](http://search.cpan.org/dist/Net-DNS/lib/Net/DNS/RR.pm)
52
+
53
+- [Ancient library](http://www.alib.jp/)
54
+ - [IPv4/IPv6 アドレスから、ホスト名を取得する](http://www.alib.jp/perl/resolv.html)
... ...
\ No newline at end of file
Perl/initConsole.md
... ...
@@ -0,0 +1,49 @@
1
+# initConsole
2
+[[_TOC_]]
3
+
4
+## 概要
5
+- Linux/Windows共通に環境変数からコンソールの文字コードとホームディレクトリを設定する。
6
+
7
+## ソース
8
+- [initConsole.zip](initConsole.zip)
9
+
10
+### initConsole.pl
11
+```perl
12
+#!/usr/bin/perl
13
+# Linux/Windows共通に環境変数からコンソールの文字コードとホームディレクトリを設定する
14
+
15
+use strict;
16
+use warnings;
17
+use utf8;
18
+use Encode;
19
+
20
+( $ENV{'LANG'} || '' ) =~ /\.(.*)$/; # ja_JP.UTF-8
21
+my $charsetConsole = $1 || 'CP932';
22
+my $charsetFile = 'UTF-8';
23
+
24
+binmode( STDIN, ":encoding($charsetConsole)" );
25
+binmode( STDOUT, ":encoding($charsetConsole)" );
26
+binmode( STDERR, ":encoding($charsetConsole)" );
27
+
28
+my $home = $ENV{'HOME'} || $ENV{'USERPROFILE'};
29
+$home =~ s#\\#/#g;
30
+
31
+my $fileOut = $home . '/環境変数テスト.txt';
32
+
33
+@ARGV = map{ decode( $charsetConsole, $_ ); } @ARGV;
34
+
35
+print "$home\n$fileOut\n";
36
+print join( "\n", @ARGV ) . "\n";
37
+
38
+open( my $fhout, ">:encoding($charsetFile)", encode( $charsetConsole, $fileOut ) )
39
+ or die( "$fileOut: " . decode( $charsetConsole, $! ) . "\n" );
40
+print $fhout "テスト\n";
41
+print $fhout join( "\n", @ARGV ) . "\n";
42
+close( $fhout );
43
+
44
+# EOF
45
+```
46
+
47
+## リンク
48
+- [[Perl/環境変数]]
49
+- [[Perl/文字コード]]
... ...
\ No newline at end of file
Perl/makeCodeHighlightKeyword.md
... ...
@@ -0,0 +1,350 @@
1
+[[_TOC_]]
2
+----
3
+# 概要
4
+- PukiWiki の [codehighlight](http://pukiwiki.sourceforge.jp/?%e8%87%aa%e4%bd%9c%e3%83%97%e3%83%a9%e3%82%b0%e3%82%a4%e3%83%b3%2f%63%6f%64%65%68%69%67%68%6c%69%67%68%74%2e%69%6e%63%2e%70%68%70) プラグイン用のキーワード設定ファイルを作成する。
5
+- CSS のグループとキーワードを .yml ファイルから読み取る。
6
+- 単語一つ一つにどのグループに属するか書くのが面倒なので…。
7
+- 文字スイッチとコメントも設定ファイルから設定できるように機能追加。(2013/02/02)
8
+- アウトライン用文字スイッチも設定できるように機能追加。(2013-02-10)
9
+- Script-Fu用設定ファイルのサンプルを追加。(2013-02-10)
10
+
11
+# ソース
12
+- [makeKeyword.zip](makeKeyword.zip)
13
+
14
+## makeKeyword.pl
15
+```perl
16
+#!/usr/bin/perl
17
+# PukiWiki CodeHighlight プラグイン用キーワード設定ファイル生成スクリプト
18
+
19
+use strict;
20
+use warnings;
21
+use utf8;
22
+use Encode;
23
+use YAML::Syck;
24
+
25
+$YAML::Syck::ImplicitUnicode = 1;
26
+#$YAML::Syck::ImplicitTyping = 1;
27
+$YAML::Syck::Headless = 1;
28
+
29
+my $config_file = $ARGV[0] or die( "usage: makeKeyword <Config>\n" );
30
+my $inputname = my $outputname = 'keyword.template.php';
31
+
32
+my $config = YAML::Syck::LoadFile( "$config_file" ) or die( "$config_file: $!\n" );
33
+$outputname =~ s/template/lc($config->{'Name'})/e;
34
+my $ignore_case = ( $config->{'IgnoreCase'} =~ /true|1/i );
35
+
36
+my $charclass = "";
37
+foreach my $class ( sort( keys( %{$config->{'CharClass'}} ) ) ){
38
+ foreach my $char ( @{$config->{'CharClass'}{$class}} ){
39
+ $charclass .= "\$switchHash['$char']\t= PLUGIN_CODE_$class;\n";
40
+ }
41
+}
42
+
43
+my $comment = "";
44
+my @comment_switches = sort( keys( %{$config->{'Comment'}} ) );
45
+foreach my $char ( @comment_switches ){
46
+ $comment .= "\$switchHash['$char']\t= PLUGIN_CODE_COMMENT;\n";
47
+}
48
+$comment .= "\$code_comment = Array(\n";
49
+foreach my $char ( @comment_switches ){
50
+ $comment .= "\t'$char' => Array(\n";
51
+ foreach my $def ( @{$config->{'Comment'}{$char}} ){
52
+ $comment .= "\t\tArray( '/^" . quotemeta( $def->[0] ). "/', \"$def->[1]\", $def->[2] ),\n";
53
+ }
54
+ $comment .= "\t),\n";
55
+}
56
+$comment .= ");\n";
57
+
58
+my $outline = "";
59
+foreach my $outline_pair ( @{$config->{'Outline'}} ){
60
+ $outline .= "\t\$switchHash['" . $outline_pair->[0] . "']\t= PLUGIN_CODE_BLOCK_START;\n";
61
+ $outline .= "\t\$switchHash['" . $outline_pair->[1] . "']\t= PLUGIN_CODE_BLOCK_END;\n";
62
+}
63
+
64
+my $keywords = "";
65
+my @types = sort( keys( %{$config->{'Keywords'}} ) );
66
+for( my $i=0; $i<@types; ++$i ){
67
+ $keywords .= "// " . $types[$i] . "\n";
68
+ my $index = $i + 1;
69
+ foreach my $word ( sort( @{$config->{'Keywords'}{$types[$i]}} ) ){
70
+ if ( $ignore_case ){ $word = lc( $word ); }
71
+ $keywords .= "\t'$word'\t=> $index,\n";
72
+ }
73
+}
74
+
75
+open( my $IN, "<:utf8", $inputname )
76
+ or die( "$inputname: $!\n" );
77
+my @body = <$IN>;
78
+close( $IN );
79
+my $body = join( "", @body );
80
+
81
+$body =~ s/__Name__/$config->{'Name'}/g;
82
+$body =~ s/__IgnoreCase__/($ignore_case)?'true':'false'/e;
83
+$body =~ s/__CharClass__\n/$charclass/;
84
+$body =~ s/__Comment__\n/$comment/;
85
+$body =~ s/__Outline__\n/$outline/;
86
+$body =~ s/__Types__\n/join("",map{"\t'$_',\n";}@types)/e;
87
+$body =~ s/__Keywords__\n/$keywords/;
88
+
89
+# CrLf で保存される
90
+open( my $OUT, ">:utf8", $outputname )
91
+ or die( "$outputname: $!\n" );
92
+print $OUT $body;
93
+close( $OUT );
94
+
95
+# EOF
96
+```
97
+
98
+## keyword.template.php
99
+```php
100
+<?php
101
+/**
102
+ * __Name__ キーワード定義ファイル
103
+ */
104
+
105
+$capital = __IgnoreCase__;
106
+
107
+__CharClass__
108
+
109
+// コメント定義
110
+__Comment__
111
+
112
+// アウトライン用
113
+if($mkoutline){
114
+__Outline__
115
+}
116
+
117
+$code_css = Array(
118
+__Types__
119
+);
120
+
121
+$code_keyword = Array(
122
+__Keywords__
123
+);
124
+?>
125
+```
126
+
127
+# Dummy
128
+## ymlファイル
129
+```perl
130
+# Dummy キーワード
131
+
132
+Name: Dummy
133
+IgnoreCase: false
134
+
135
+CharClass:
136
+ SPECIAL_IDENTIFIRE: [ "#", @ ]
137
+ NONESCAPE_LITERAL: [ \' ]
138
+
139
+Comment:
140
+ "/": [
141
+ [ /*, */, 2 ],
142
+ [ //, \n, 1 ]
143
+ ]
144
+ "-": [
145
+ [ --, \n, 1 ]
146
+ ]
147
+
148
+Outline:
149
+ - [ "{", "}" ]
150
+
151
+Keywords:
152
+ # オペレータ
153
+ operator: [
154
+ Mod, Div, Not, Or, And
155
+ ]
156
+
157
+ # 識別子
158
+ identifier: [
159
+ New, In, This, Var, Const, With, Function
160
+ ]
161
+
162
+ # 制御構文
163
+ control: [
164
+ If, Else, While, For, Break, Continue, Switch, Case, Default,
165
+ Return, Try, Catch
166
+ ]
167
+
168
+ # 標準関数
169
+ function: [
170
+ Abs, Floor, Ceil, Rand, Round
171
+ ]
172
+
173
+ # 定数
174
+ constant: [
175
+ "True", "False", "Null"
176
+ ]
177
+
178
+ # module, import, 将来対応する pragma
179
+ pragma: [
180
+ module, import, using,
181
+ '#define', '#undef', '#if', '#elif', '#else', '#endif',
182
+ '#error', '#warning', '#region', '#endregion', '#line'
183
+ ]
184
+
185
+ # __stdcall などの処理系専用の奴とか
186
+ system: [
187
+ Console, Dictionary, Encoding, Exception, IDictionary, Match,
188
+ MatchCollection, Object, Program, Regex, String
189
+ ]
190
+
191
+ # 環境変数
192
+ environment: [
193
+ Env
194
+ ]
195
+
196
+ # SQL
197
+ sql: [
198
+ SELECT, INTO, FROM, WHERE, IN, GROUP, HAVING, ORDER, BY, ASC, DESC,
199
+ AS, DISTINCT, TOP, JOIN, "ON", LIMIT, UNION, ALL,
200
+ INSERT, VALUES, DUPLICATE, KEY, UPDATE, SET, DELETE,
201
+ USE, GO
202
+ ]
203
+
204
+# EOF
205
+```
206
+
207
+## 適用結果
208
+```dummy
209
+/**
210
+ Dummy サンプル
211
+*/
212
+#if !defined(BUFFER)
213
+#define BUFFER (1024)
214
+#endif
215
+
216
+Var sql1 = qq{
217
+-- ユーザ選択
218
+ SELECT `ID`, `Gender`, `Age`
219
+ FROM `Users`
220
+ WHERE `Name` == :Name
221
+};
222
+
223
+Function isExistUser( username ){
224
+ Var find = False;
225
+ Var id = "";
226
+ Var gender = 0;
227
+ Var age = 0;
228
+ Var sth = dbh.prepare( sql1 );
229
+ sth.bind( "Name", username );
230
+ sth.execute();
231
+ While( Var record = sth.fetchrow_array() ){
232
+ find = True;
233
+ id = record[0];
234
+ gender = record[1];
235
+ age = record[2];
236
+ If ( gender == 2 And age > 30 ){
237
+ age = Ceil( age / 10 ) * 10;
238
+ }
239
+ Console.WriteLine("{0}: {1}, {2}", username, id, age);
240
+ }
241
+ Return ( find, id, age );
242
+}
243
+
244
+// EOF
245
+```
246
+
247
+# Script-Fu
248
+## ymlファイル
249
+```perl
250
+# Script-Fu キーワード
251
+
252
+Name: Script-Fu
253
+IgnoreCase: false
254
+
255
+CharClass:
256
+ SPECIAL_IDENTIFIRE: [ "*", "!", "-" ]
257
+
258
+Comment:
259
+ ";": [
260
+ [ ;, \n, 1 ]
261
+ ]
262
+
263
+Outline:
264
+ - [ "{", "}" ]
265
+ - [ "(", ")" ]
266
+ - [ "[", "]" ]
267
+
268
+Keywords:
269
+ # オペレータ
270
+ operator: [
271
+ ]
272
+
273
+ # 識別子
274
+ identifier: [
275
+ define, let, let*, cons, list, vector, vector-, set, set!, for-each, lambda,
276
+ if, char,
277
+ car, cdr, caar, cadr, cdar, cddr,
278
+ string-append, string-ref,
279
+ gimp-context-pop,
280
+ gimp-context-push,
281
+ gimp-context-set-background,
282
+ gimp-context-set-foreground,
283
+ gimp-display-new,
284
+ gimp-displays-flush,
285
+ gimp-drawable-fill,
286
+ gimp-drawable-get-name,
287
+ gimp-drawable-height,
288
+ gimp-drawable-width,
289
+ gimp-edit-fill,
290
+ gimp-file-save,
291
+ gimp-image-add-layer,
292
+ gimp-image-clean-all,
293
+ gimp-image-flatten,
294
+ gimp-image-get-layers,
295
+ gimp-image-lower-layer,
296
+ gimp-image-lower-layer-to-bottom,
297
+ gimp-image-merge-down,
298
+ gimp-image-new,
299
+ gimp-image-resize,
300
+ gimp-image-undo-group-end,
301
+ gimp-image-undo-group-start,
302
+ gimp-layer-copy,
303
+ gimp-layer-new,
304
+ gimp-layer-set-lock-alpha,
305
+ gimp-layer-set-name,
306
+ gimp-layer-set-offsets,
307
+ gimp-layer-resize,
308
+ gimp-selection-grow,
309
+ gimp-selection-layer-alpha,
310
+ gimp-selection-none,
311
+ gimp-text-fontname,
312
+ script-fu-menu-register,
313
+ script-fu-register,
314
+ script-fu-text-box,
315
+ script-fu-util-image-add-layers
316
+ ]
317
+
318
+ # 制御構文
319
+ control: [
320
+ ]
321
+
322
+ # 標準関数
323
+ function: [
324
+ ]
325
+
326
+ # 定数
327
+ constant: [
328
+ "TRUE", "FALSE",
329
+ PIXELS, RGB-IMAGE, NORMAL,
330
+ BACKGROUND-FILL, FOREGROUND-FILL,
331
+ SF-IMAGE, SF-DRAWABLE, SF-VALUE, SF-STRING, SF-COLOR, SF-TOGGLE,
332
+ SF-ADJUSTMENT, SF-FONT, SF-BRUSH, SF-PATTERN, SF-GRADIENT,
333
+ SF-PALETTE, SF-FILENAME, SF-DIRNAME, SF-OPTION, SF-ENUM,
334
+ RUN-INTERACTIVE, RUN-NONINTERACTIVE, RUN-WITH-LAST-VALS
335
+ ]
336
+
337
+ # module, import, 将来対応する pragma
338
+ pragma: [
339
+ ]
340
+
341
+ # __stdcall などの処理系専用の奴とか
342
+ system: [
343
+ ]
344
+
345
+ # 環境変数
346
+ environment: [
347
+ ]
348
+
349
+# EOF
350
+```
... ...
\ No newline at end of file
Perl/nicoget.md
... ...
@@ -0,0 +1,142 @@
1
+# nicoget - ニコニコ動画のダウンロード
2
+[[_TOC_]]
3
+
4
+## 概要
5
+- ニコニコ動画の flv/mp4/swf と、コメントのXMLをダウンロードします。
6
+
7
+### 改変元
8
+- [perl - 勝手に添削 - ニコニコ動画ダウンローダー](http://blog.livedoor.jp/dankogai/archives/50885358.html)
9
+- [perl - ニコニコ動画ダウンローダー新認証対応版](http://blog.livedoor.jp/dankogai/archives/50900305.html)
10
+- [perl - LWP::UserAgentで進捗表示しつつダウンロード](http://blog.livedoor.jp/dankogai/archives/51141631.html)
11
+
12
+### 変更点
13
+- ファイルの種類に合わせて、拡張子を flv/mp4/swf に変える。
14
+- 設定ファイルをスクリプトと同じ場所に置く。
15
+- 保存先も設定ファイルに記述する。
16
+- ログイン用のURL変更。
17
+- エコノミーモードの判定を行う。
18
+- ファイルをバイナリモードで保存。
19
+- 進捗状況を表示する。
20
+- オプションなしで起動したときにwarningが出るのに対処。(2009/04/12)
21
+- openのレイヤーをbytesからrawに変更。(2009/04/12)
22
+
23
+## ソース
24
+- [nicoget.zip](nicoget.zip)
25
+
26
+- nicoget.pl
27
+```
28
+#!/usr/local/bin/perl
29
+#
30
+# nicoget.pl,v 0.1+0.2 2009/04/12 15:00:00 take-ash
31
+#
32
+# original: http://blog.livedoor.jp/dankogai/archives/50885358.html
33
+# original: http://blog.livedoor.jp/dankogai/archives/51141631.html
34
+
35
+use strict;
36
+use warnings;
37
+use utf8;
38
+use LWP::UserAgent;
39
+use HTTP::Cookies;
40
+use HTTP::Request;
41
+use HTTP::Headers;
42
+use CGI;
43
+use YAML::Syck;
44
+
45
+my %Ext = ( 'f'=>'flv', 'm'=>'mp4', 's'=>'swf', );
46
+
47
+my $yaml = "./nicovideo.yml";
48
+my $conf = YAML::Syck::LoadFile($yaml) or die "$yaml:$!";
49
+my $savepath = $conf->{ 'savepath' };
50
+delete $conf->{ 'savepath' };
51
+if ( $savepath !~ /[\/|\\]$/ ){
52
+ $savepath .= '/';
53
+}
54
+
55
+my $video_id = $ARGV[0] or die "usage: $0 [video_id|uri]\n";
56
+$video_id =~ /((sm|nm|ca)?\d+)(\?.*)?$/;
57
+$video_id = $1;
58
+
59
+my $ua = LWP::UserAgent->new( keep_alive => 4 );
60
+$ua->cookie_jar( {} );
61
+
62
+warn "login as $conf->{mail}\n";
63
+$ua->post( "https://secure.nicovideo.jp/secure/login?site=niconico" => $conf );
64
+
65
+$ua->get("http://www.nicovideo.jp/watch/$video_id");
66
+my $res = $ua->get("http://www.nicovideo.jp/api/getflv?v=$video_id");
67
+my $q = CGI->new( $res->content );
68
+my $uri = $q->param('url') or die "Failed: " . $res->content;
69
+$uri =~ /\/smile\?(.)\=[\d\.]+(\w+)?$/;
70
+my $ext = $Ext{ $1 } || 'flv';
71
+my $low = ( defined( $2 ) ) ? $2 : "" ;
72
+my $filename = $savepath."$video_id$low.$ext";
73
+my $req = HTTP::Request->new(
74
+ GET => $uri
75
+);
76
+if ( $low ){
77
+ warn "economy mode\n";
78
+}
79
+savewithprogress( $req, $filename );
80
+
81
+$filename = $savepath."$video_id$low.xml";
82
+my $header = HTTP::Headers->new;
83
+$header->header( Content_Type => 'text/xml' );
84
+my $thread_id = $q->param('thread_id');
85
+$req = HTTP::Request->new(
86
+ POST => $q->param('ms'),
87
+ $header,
88
+ qq{<thread res_from="-500" version="20061206" thread="$thread_id" />}
89
+);
90
+savewithprogress( $req, $filename );
91
+
92
+exit();
93
+
94
+sub savewithprogress {
95
+ my( $req, $filename ) = @_;
96
+ my $uri = $req->uri;
97
+ warn "$filename <= $uri\n";
98
+ open my $wfh, '>:raw', "$filename" or die "$filename:$!";
99
+ $res = $ua->request(
100
+ $req,
101
+ sub {
102
+ my ( $chunk, $res, $proto ) = @_;
103
+ print $wfh $chunk;
104
+ my $size = tell $wfh;
105
+ if (my $total = $res->header('Content-Length')){
106
+ printf STDERR ( "%d/%d (%.1f%%)\r", $size, $total, $size / $total * 100 );
107
+ } else {
108
+ printf STDERR ( "%d/Unknown bytes\r", $size );
109
+ }
110
+ }
111
+ );
112
+ close $wfh;
113
+ warn "\n", $res->status_line, "\n";
114
+}
115
+
116
+# EOF
117
+```
118
+
119
+- nicovideo.yml
120
+```
121
+mail: your@host.name
122
+password: yourpassword
123
+savepath: C:/temp
124
+```
125
+
126
+## リンク
127
+- [404 Blog Not Found](http://blog.livedoor.jp/dankogai/)
128
+ - [perl - 勝手に添削 - ニコニコ動画ダウンローダー](http://blog.livedoor.jp/dankogai/archives/50885358.html)
129
+ - [perl - ニコニコ動画ダウンローダー新認証対応版](http://blog.livedoor.jp/dankogai/archives/50900305.html)
130
+ - [perl - LWP::UserAgentで進捗表示しつつダウンロード](http://blog.livedoor.jp/dankogai/archives/51141631.html)
131
+
132
+- [ニコニコ動画のFLVをダウンロードする userChrome.js スクリプト](http://blog.libelabo.jp/2007/04/05/nicovideo-download-userchrome-js/)
133
+
134
+- [ニコニコ動画をダウンロードできるようになるGreasemonkeyスクリプトのOpera版](http://muumoo.jp/news/2007/08/27/0nicovideodownloader.html)
135
+
136
+- [ニコニコ公式アニメポータルのrtmpeプロトコル動画をダウンロードする覚え書き](https://gist.github.com/tondol/7039259)
137
+
138
+- [プログラマーのための YAML 入門 (初級編)](http://jp.rubyist.net/magazine/?0009-YAML)
139
+
140
+- [CPAN:libwww-perl](http://search.cpan.org/dist/libwww-perl)
141
+- [CPAN:CGI](http://search.cpan.org/dist/CGI)
142
+- [CPAN:YAML](http://search.cpan.org/dist/YAML)
... ...
\ No newline at end of file
Perl/packBit.md
... ...
@@ -0,0 +1,132 @@
1
+# pack関数でのビットフィールドの取り扱い
2
+[[_TOC_]]
3
+
4
+## 概要
5
+- pack関数のテンプレートで'B'を指定した場合、どのように変換されるのかを確認する。
6
+- pack する対象は、0/1が連なった文字列。
7
+- 1文字が1ビットに対応する。
8
+- 左詰で解釈され、不足分は 0 とみなされる。
9
+- 指定桁より大きい部分は切り捨てられる。
10
+- 0/1 以外の文字は ($x & 0x01) されて解釈される。(10進数として解釈されない)<br />
11
+例) '256'→'010', '512'→'110', '513'→'111'
12
+
13
+## ソース
14
+- [packBit.zip](packBit.zip)
15
+```perl
16
+# pack('B',$x), pack('C',$x) のテスト
17
+
18
+use strict;
19
+use warnings;
20
+use utf8;
21
+use Encode;
22
+use YAML::Syck;
23
+
24
+$YAML::Syck::ImplicitUnicode = 1;
25
+$YAML::Syck::ImplicitTyping = 1;
26
+$YAML::Syck::SortKeys = 1;
27
+
28
+my $charsetConsole = 'CP932';
29
+#my $charsetConsole = 'UTF-8';
30
+my $charsetFile = 'UTF-8';
31
+
32
+my @in = qw(
33
+ 0 1 10 100 1000 10000
34
+ 01 001 0001 00001
35
+ 2 3 4 5 02 03 04 05
36
+ 256 512 513
37
+);
38
+my @result = ();
39
+foreach my $in ( @in ){
40
+ my $pb = pack( 'B4', $in );
41
+ my $upb = unpack( 'B4', $pb );
42
+ my $pc = pack( 'C*', Int2Array( $in ) );
43
+ my $upc = [ unpack( 'C*', $pc ) ];
44
+ push( @result, {
45
+ _in => $in,
46
+ bit_pack => $pb,
47
+ bit_unpack => $upb,
48
+ char_pack => $pc,
49
+ char_unpack => $upc,
50
+ });
51
+}
52
+
53
+print "Perl version: $]\n";
54
+print join( "\t", qw( _in bit_pack bit_unpack char_pack char_unpack ) ) . "\n";
55
+
56
+my $result = Dump( \@result );
57
+{
58
+ no warnings 'uninitialized';
59
+ $result =~ s{
60
+ ^-\s*\n
61
+ \s+[^:]+:\s+(.*)\n
62
+ \s+[^:]+:\s+(.*)\n
63
+ \s+[^:]+:\s+(.*)\n
64
+ \s+[^:]+:\s+(.*)\n
65
+ \s+[^:]+:\s*\n
66
+ \s+-\s+([^\s]+)\n
67
+ (?:\s+-\s+([^\s]+)\n)?
68
+ }{
69
+ $1\t$2\t$3\t$4\t$5,$6\n
70
+ }gmx;
71
+}
72
+$result =~ s/^\s+//gmx;
73
+
74
+print $result;
75
+
76
+exit;
77
+
78
+sub Int2Array
79
+{
80
+ my $arg = shift || 0;
81
+ my @ret = ();
82
+ if ( !!$arg ){
83
+ while( !!$arg ){
84
+ my $m = $arg & 0xff;
85
+ unshift( @ret, $m );
86
+ $arg >>= 8;
87
+ }
88
+ } else {
89
+ @ret = ( 0 );
90
+ }
91
+ return @ret;
92
+}
93
+
94
+# EOF
95
+```
96
+
97
+## 結果
98
+```
99
+Perl version: 5.014002
100
+_in bit_pack bit_unpack char_pack char_unpack
101
+---
102
+0 "\0" '0000' "\0" 0,
103
+1 "\x80" 1000 "\x01" 1,
104
+10 "\x80" 1000 "\n" 10,
105
+100 "\x80" 1000 d 100,
106
+1000 "\x80" 1000 "\x03\xE8" 3,232
107
+10000 "\x80" 1000 "'\x10" 39,16
108
+'01' "@" '0100' "\x01" 1,
109
+'001' " " '0010' "\x01" 1,
110
+'0001' "\x10" '0001' "\x01" 1,
111
+'00001' "\0" '0000' "\x01" 1,
112
+2 "\0" '0000' "\x02" 2,
113
+3 "\x80" 1000 "\x03" 3,
114
+4 "\0" '0000' "\x04" 4,
115
+5 "\x80" 1000 "\x05" 5,
116
+'02' "\0" '0000' "\x02" 2,
117
+'03' "@" '0100' "\x03" 3,
118
+'04' "\0" '0000' "\x04" 4,
119
+'05' "@" '0100' "\x05" 5,
120
+256 "@" '0100' "\x01\0" 1,0
121
+512 "\xC0" 1100 "\x02\0" 2,0
122
+513 "\xE0" 1110 "\x02\x01" 2,1
123
+```
124
+
125
+## リンク
126
+- Perl/MySQL-BIT
127
+
128
+- http://perldoc.jp/
129
+ - [perldoc.jp:func/pack](http://perldoc.jp/func/pack)
130
+ - [perldoc.jp:func/vec](http://perldoc.jp/func/vec)
131
+
132
+- [Perl の数値変換](http://mikeneko.creator.club.ne.jp/~lab/perl/numerical_transform/)
... ...
\ No newline at end of file
Perl/readXSV.md
... ...
@@ -0,0 +1,102 @@
1
+# CSV(TSV)の読み込み
2
+[[_TOC_]]
3
+
4
+## 概要
5
+- CSV(TSV)を読み込んで、ヘッダ行をキーにしたハッシュの配列を作成する。
6
+- ファイルの文字コードは UTF-8。
7
+- { binary => 1 } がデフォルトで指定されるように変更。(2012/02/28)
8
+- 戻り値が配列のリファレンスであることを確認してからデリファレンスするようにした。(2012/02/28)
9
+
10
+## ソース
11
+- [readCSV.zip](readCSV.zip)
12
+
13
+### readCSV.pl
14
+```perl
15
+#!/usr/bin/perl
16
+# CSV(TSV)を読み込んで、ヘッダ行をキーにしたハッシュの配列を作成する。
17
+
18
+use strict;
19
+use warnings;
20
+use utf8;
21
+use Encode;
22
+use Text::xSV::Slurp qw( xsv_slurp );
23
+use YAML::Syck;
24
+
25
+$YAML::Syck::ImplicitUnicode = 1;
26
+
27
+my $charsetConsole = 'CP932';
28
+#my $charsetConsole = 'UTF-8';
29
+my $charsetFile = 'UTF-8';
30
+
31
+binmode( STDIN, ":encoding($charsetConsole)" );
32
+binmode( STDOUT, ":encoding($charsetConsole)" );
33
+binmode( STDERR, ":encoding($charsetConsole)" );
34
+
35
+my $filename = 'データ.txt';
36
+my $csvoption = { sep_char => "\t" };
37
+
38
+my @csv = readXSV( $filename, $csvoption );
39
+print Dump( \@csv ) . "\n" ;
40
+
41
+sub readXSV
42
+{
43
+ my( $fname, $opt ) = @_;
44
+ $opt = { binary => 1, %{$opt} };
45
+ open( my $fhin, "<:encoding($charsetFile)", encode( $charsetConsole, $fname ) )
46
+ or die( "$fname: $!" );
47
+ my @body = <$fhin>;
48
+ close( $fhin );
49
+ my $ret = xsv_slurp(
50
+ string => join( "", @body ),
51
+ text_csv => $opt,
52
+ );
53
+ return ( ref( $ret ) eq 'ARRAY' )
54
+ ? @{ $ret }
55
+ : $ret ;
56
+}
57
+
58
+# EOF
59
+```
60
+
61
+### 入力
62
+| ID | Name | Gender | DOB | Comment |
63
+| --- | --- | --- | --- | --- |
64
+| 1 | 芳佳 | 2 | 1930/08/18 | 九字兼定 |
65
+| 2 | 美緒 | 2 | 1925/08/26 | ドーベルマン |
66
+| 3 | ミーナ | 2 | 1926/03/11 | 灰色狼 |
67
+
68
+### 出力
69
+```
70
+---
71
+-
72
+ Comment: 九字兼定
73
+ DOB: 1930/08/18
74
+ Gender: 2
75
+ ID: 1
76
+ Name: 芳佳
77
+-
78
+ Comment: ドーベルマン
79
+ DOB: 1925/08/26
80
+ Gender: 2
81
+ ID: 2
82
+ Name: 美緒
83
+-
84
+ Comment: 灰色狼
85
+ DOB: 1926/03/11
86
+ Gender: 2
87
+ ID: 3
88
+ Name: ミーナ
89
+```
90
+
91
+## リンク
92
+- [[Perl/NetWatcher]]
93
+
94
+- [CPAN:Text-xSV-Slurp](http://search.cpan.org/dist/Text-xSV-Slurp)
95
+- [CPAN:Text-CSV-Slurp](http://search.cpan.org/dist/Text-CSV-Slurp)
96
+- [CPAN:Text-CSV_XS](http://search.cpan.org/dist/Text-CSV_XS)
97
+- [CPAN:Text-CSV-Simple](http://search.cpan.org/dist/Text-CSV-Simple)
98
+
99
+- [404 Blog Not Found](http://blog.livedoor.jp/dankogai/)
100
+ - [perl - CSVはText::CSV(_XS)?で](http://blog.livedoor.jp/dankogai/archives/50765677.html)
101
+ - [TSV vs CSV](http://blog.livedoor.jp/dankogai/archives/50509945.html)
102
+ - [perl - デフォルト値のperlらしい指定法](http://blog.livedoor.jp/dankogai/archives/51074877.html)
... ...
\ No newline at end of file
Perl/updateEarth.md
... ...
@@ -0,0 +1,93 @@
1
+# updateEarth
2
+[[_TOC_]]
3
+
4
+## 機能
5
+[Earth Dynamic DNS](http://mydns.to/)に登録した情報を更新するスクリプトです。
6
+
7
+## ダウンロード
8
+- [updateEarth.zip](updateEarth.zip)
9
+
10
+## updateEarth.cgi
11
+```
12
+#!/usr/local/bin/perl
13
+
14
+# Earth DynamicDNS の更新スクリプト
15
+
16
+$sUserName = 'username'; # ユーザ名
17
+$sPassword = 'password'; # パスワード
18
+$sSubDomain = 'subdomain'; # サブドメイン
19
+$sDomain = 'mydns.to'; # ドメイン
20
+#$sDomain = 'ur.to';
21
+$sMXHost = ''; # メールホスト
22
+$sMX = 'f'; # メールサーバ t:使う f:使わない
23
+$sWildcard = 't'; # ワイルドカード t:使う f:使わない
24
+
25
+# 成功した場合の結果
26
+$sFileSuccess = 'updateEarth_success.log';
27
+
28
+# IPアドレスを調べるサービスを行うアドレス
29
+$sIPCheckURI = 'http://www02.so-net.ne.jp/~shintan/gateway/ipcheck.cgi';
30
+
31
+open( IN, $sFileSuccess ) || die( "can't open '".$sFileSuccess."'\n" );
32
+@lines = <IN>;
33
+close( IN );
34
+$sSuccessLog = join( "", @lines );
35
+
36
+$sMyIP = &getURI( $sIPCheckURI );
37
+
38
+if ( $sMyIP =~ /(\d+\.\d+\.\d+\.\d+)/ ){
39
+ $sMyIP = $1;
40
+ $sEarthUpdateURI = 'http://' . $sUserName . ':' . $sPassword
41
+ . '@mydns.to/member/domainedit.php?ip=' . $sMyIP
42
+ . '&mxhost=' . $sMXHost . '&mx=' . $sMX . '&wc=' . $sWildcard
43
+ . '&domain=' . $sDomain . '&subdomain=' . $sSubDomain . '&mode=e';
44
+ $sResult = &getURI( $sEarthUpdateURI );
45
+ if ( $sResult ne $sSuccessLog ){
46
+ print "Content-type: text/html; charset=Shift_JIS\n\n";
47
+ print $sResult."\n";
48
+ } else {
49
+ # 成功したときは何もしない
50
+ }
51
+} else {
52
+ print "Content-type: text/plain; charset=Shift_JIS\n\n";
53
+ print "can't get my IP.\n";
54
+}
55
+
56
+exit();
57
+
58
+# --- Subroutine ---
59
+sub getURI {
60
+ my( $URI ) = @_;
61
+
62
+ use LWP::UserAgent;
63
+
64
+ $ua = LWP::UserAgent->new;
65
+
66
+ $req = HTTP::Request->new( GET => $URI);
67
+
68
+ # send request
69
+ $res = $ua->request( $req );
70
+
71
+ # check the outcome
72
+ if ( $res->is_success ){
73
+ return $res->content;
74
+ } else {
75
+ return "Error: " . $res->status_line . "\n";
76
+ }
77
+}
78
+
79
+# EOF
80
+```
81
+
82
+## ipcheck.cgi
83
+```
84
+#!/usr/local/bin/perl
85
+
86
+print "Content-type: text/plain; charset=Shift_JIS\n\n";
87
+
88
+$remote_addr = $ENV{"REMOTE_ADDR"};
89
+printf( "%s", $remote_addr );
90
+
91
+exit();
92
+
93
+# EOF
... ...
\ No newline at end of file
Perl/\343\202\252\343\203\226\343\202\270\343\202\247\343\202\257\343\203\210\346\214\207\345\220\221\343\203\227\343\203\255\343\202\260\343\203\251\343\203\237\343\203\263\343\202\260.md
... ...
@@ -0,0 +1,448 @@
1
+# オブジェクト指向プログラミング
2
+[[_TOC_]]
3
+
4
+## 概要
5
+- 3x3のビットパターンを表現するクラスを作成し、これを使って回転しても重複しないパターンを探索する。
6
+- ソース<br />
7
+[BitPattern.zip](BitPattern.zip)
8
+
9
+## BitPattern.pm
10
+```
11
+# BitPattern.pm
12
+# ビットパターンクラス
13
+# 数値に対応するNxNのマトリックスを表現するクラス
14
+#
15
+# N=3 (default)
16
+# | bit0 | bit1 | bit2 |
17
+# | bit3 | bit4 | bit5 |
18
+# | bit6 | bit7 | bit8 |
19
+
20
+package BitPattern;
21
+
22
+use strict;
23
+use warnings;
24
+use utf8;
25
+
26
+sub new {
27
+ my $pkg = shift;
28
+ bless {
29
+ number => 0,
30
+ unit => 3,
31
+ pattern => [ [0,0,0], [0,0,0], [0,0,0], ],
32
+ }, $pkg;
33
+}
34
+
35
+sub toString {
36
+ my $self = shift;
37
+ my $unit = $self->{unit};
38
+ my $pattern = "[ ";
39
+ for( my $i=0; $i<$unit; $i++ ){
40
+ $pattern .= "[ ";
41
+ for( my $j=0; $j<$unit; $j++ ){
42
+ $pattern .= ${$self->{pattern}}[ $i ][ $j ] . " ";
43
+ }
44
+ $pattern .= "] ";
45
+ }
46
+ $pattern .= "]";
47
+
48
+ return sprintf( "%04x / %s", $self->{number}, $pattern );
49
+}
50
+
51
+sub clone {
52
+ my $self = shift;
53
+ my $unit = $self->{unit};
54
+ my $tmp = BitPattern->new();
55
+ # $tmp->{number} = $self->{number};
56
+ # $tmp->{unit} = $self->{unit};
57
+ # @{$tmp->{pattern}} = @{$self->{pattern}}; # rotateで失敗する？
58
+ $tmp->set( $self->{number}, $self->{unit} );
59
+ return $tmp;
60
+}
61
+
62
+sub equals {
63
+ my $self = shift;
64
+ my $target = shift;
65
+ return ( $self->{number} == $target->{number} );
66
+}
67
+
68
+sub set {
69
+ my $self = shift;
70
+ my $num = $self->{number} = int( shift );
71
+ my $unit = $self->{unit} = int( shift || $self->{unit} || 3 ); # default=3
72
+ my @pattern = ();
73
+ for( my $i=0; $i<$unit; $i++ ){
74
+ for( my $j=0; $j<$unit; $j++ ){
75
+ if ( $num & 1 ){
76
+ $pattern[ $i ][ $j ] = 1;
77
+ } else {
78
+ $pattern[ $i ][ $j ] = 0;
79
+ }
80
+ $num >>= 1;
81
+ }
82
+ }
83
+ @{$self->{pattern}} = @pattern;
84
+ return $self;
85
+}
86
+
87
+sub getNumber {
88
+ my $self = shift;
89
+ return $self->{number};
90
+}
91
+
92
+sub getPatternArray {
93
+ my $self = shift;
94
+ return wantarray ? @{$self->{pattern}} : $self->{pattern};
95
+}
96
+
97
+sub getPattern {
98
+ my $self = shift;
99
+ my $unit = $self->{unit};
100
+ my $pattern = "";
101
+ for( my $i=0; $i<$unit; $i++ ){
102
+ for( my $j=0; $j<$unit; $j++ ){
103
+ $pattern .= ${$self->{pattern}}[ $i ][ $j ] ? "*" : "-" ;
104
+ }
105
+ $pattern .= "\n";
106
+ }
107
+ return $pattern;
108
+}
109
+
110
+# 時計回りに回転
111
+sub rotate {
112
+ my $self = shift;
113
+ my $unit = $self->{unit};
114
+ my $tmp = $self->clone();
115
+ for( my $i=0; $i<$unit; $i++ ){
116
+ for( my $j=0; $j<$unit; $j++ ){
117
+ ${$self->{pattern}}[ $i ][ $j ] =
118
+ ${$tmp->{pattern}}[ $unit - 1 - $j ][ $i ];
119
+ }
120
+ }
121
+
122
+ my $num = 0;
123
+ for( my $i=$unit-1; $i>=0; $i-- ){
124
+ for( my $j=$unit-1; $j>=0; $j-- ){
125
+ $num <<= 1;
126
+ $num += ${$self->{pattern}}[ $i ][ $j ];
127
+ }
128
+ }
129
+ $self->{number} = $num;
130
+
131
+ return $self;
132
+}
133
+
134
+1;
135
+
136
+# EOF
137
+```
138
+
139
+## testBitPattern.pl
140
+### ソース
141
+```
142
+# testBitPattern.pl
143
+# ビットパターンクラスの動作テスト
144
+
145
+use strict;
146
+use warnings;
147
+use utf8;
148
+use Data::Dump qw(dump);
149
+
150
+use BitPattern;
151
+
152
+my $unit = 3;
153
+
154
+my $pattern = BitPattern->new();
155
+my( @pat1, @pat2, $pattern2 );
156
+
157
+$pattern->set( 0, $unit );
158
+
159
+foreach ( 1, 2, 4, 8, 16, 32, 64, 128, 256, 170, 325 ){
160
+ $pattern->set( $_ );
161
+ @pat1 = split( "\n", $pattern->getPattern() );
162
+ $pattern2 = $pattern->clone();
163
+ $pattern2->rotate();
164
+ @pat2 = split( "\n", $pattern2->getPattern() );
165
+ printf(
166
+ "%s\n%d\n%s\neq: %b\n",
167
+ $pattern->toString(), $pattern->getNumber(),
168
+ dump( $pattern->getPatternArray() ), $pattern->equals($pattern2)
169
+ );
170
+ for( my $i=0; $i<$unit; $i++ ){
171
+ printf( "%s -> %s\n", $pat1[ $i ], $pat2[ $i ] );
172
+ }
173
+ print "\n";
174
+}
175
+
176
+# EOF
177
+```
178
+
179
+### 実行結果
180
+```
181
+0001 / [ [ 1 0 0 ] [ 0 0 0 ] [ 0 0 0 ] ]
182
+1
183
+([1, 0, 0], [0, 0, 0], [0, 0, 0])
184
+eq: 0
185
+*-- -> --*
186
+--- -> ---
187
+--- -> ---
188
+
189
+0002 / [ [ 0 1 0 ] [ 0 0 0 ] [ 0 0 0 ] ]
190
+2
191
+([0, 1, 0], [0, 0, 0], [0, 0, 0])
192
+eq: 0
193
+-*- -> ---
194
+--- -> --*
195
+--- -> ---
196
+
197
+0004 / [ [ 0 0 1 ] [ 0 0 0 ] [ 0 0 0 ] ]
198
+4
199
+([0, 0, 1], [0, 0, 0], [0, 0, 0])
200
+eq: 0
201
+--* -> ---
202
+--- -> ---
203
+--- -> --*
204
+
205
+0008 / [ [ 0 0 0 ] [ 1 0 0 ] [ 0 0 0 ] ]
206
+8
207
+([0, 0, 0], [1, 0, 0], [0, 0, 0])
208
+eq: 0
209
+--- -> -*-
210
+*-- -> ---
211
+--- -> ---
212
+
213
+0010 / [ [ 0 0 0 ] [ 0 1 0 ] [ 0 0 0 ] ]
214
+16
215
+([0, 0, 0], [0, 1, 0], [0, 0, 0])
216
+eq: 1
217
+--- -> ---
218
+-*- -> -*-
219
+--- -> ---
220
+
221
+0020 / [ [ 0 0 0 ] [ 0 0 1 ] [ 0 0 0 ] ]
222
+32
223
+([0, 0, 0], [0, 0, 1], [0, 0, 0])
224
+eq: 0
225
+--- -> ---
226
+--* -> ---
227
+--- -> -*-
228
+
229
+0040 / [ [ 0 0 0 ] [ 0 0 0 ] [ 1 0 0 ] ]
230
+64
231
+([0, 0, 0], [0, 0, 0], [1, 0, 0])
232
+eq: 0
233
+--- -> *--
234
+--- -> ---
235
+*-- -> ---
236
+
237
+0080 / [ [ 0 0 0 ] [ 0 0 0 ] [ 0 1 0 ] ]
238
+128
239
+([0, 0, 0], [0, 0, 0], [0, 1, 0])
240
+eq: 0
241
+--- -> ---
242
+--- -> *--
243
+-*- -> ---
244
+
245
+0100 / [ [ 0 0 0 ] [ 0 0 0 ] [ 0 0 1 ] ]
246
+256
247
+([0, 0, 0], [0, 0, 0], [0, 0, 1])
248
+eq: 0
249
+--- -> ---
250
+--- -> ---
251
+--* -> *--
252
+
253
+00aa / [ [ 0 1 0 ] [ 1 0 1 ] [ 0 1 0 ] ]
254
+170
255
+([0, 1, 0], [1, 0, 1], [0, 1, 0])
256
+eq: 1
257
+-*- -> -*-
258
+*-* -> *-*
259
+-*- -> -*-
260
+
261
+0145 / [ [ 1 0 1 ] [ 0 0 0 ] [ 1 0 1 ] ]
262
+325
263
+([1, 0, 1], [0, 0, 0], [1, 0, 1])
264
+eq: 1
265
+*-* -> *-*
266
+--- -> ---
267
+*-* -> *-*
268
+```
269
+
270
+## checkPattern.pl
271
+### ソース
272
+```
273
+# checkPattern.pl
274
+# ビットパターンのチェック
275
+# 回転しても重複しないビットパターンを探索する
276
+
277
+use strict;
278
+use warnings;
279
+use utf8;
280
+
281
+use BitPattern;
282
+
283
+my $pattern = BitPattern->new();
284
+my @check = ();
285
+my $count = 0;
286
+
287
+for( my $i=1; $i<512; $i++ ){
288
+ if ( !defined( $check[ $i ] ) ){
289
+ $count++;
290
+ $pattern->set( $i );
291
+ printf( "%s\n", $pattern->toString() );
292
+ $check[ $pattern->rotate()->getNumber() ] = 0;
293
+ $check[ $pattern->rotate()->getNumber() ] = 0;
294
+ $check[ $pattern->rotate()->getNumber() ] = 0;
295
+ $check[ $i ] = 1;
296
+ }
297
+}
298
+printf( "count: %d\n", $count );
299
+
300
+# EOF
301
+```
302
+
303
+### 実行結果
304
+```
305
+0001 / [ [ 1 0 0 ] [ 0 0 0 ] [ 0 0 0 ] ]
306
+0002 / [ [ 0 1 0 ] [ 0 0 0 ] [ 0 0 0 ] ]
307
+0003 / [ [ 1 1 0 ] [ 0 0 0 ] [ 0 0 0 ] ]
308
+0005 / [ [ 1 0 1 ] [ 0 0 0 ] [ 0 0 0 ] ]
309
+0006 / [ [ 0 1 1 ] [ 0 0 0 ] [ 0 0 0 ] ]
310
+0007 / [ [ 1 1 1 ] [ 0 0 0 ] [ 0 0 0 ] ]
311
+000a / [ [ 0 1 0 ] [ 1 0 0 ] [ 0 0 0 ] ]
312
+000b / [ [ 1 1 0 ] [ 1 0 0 ] [ 0 0 0 ] ]
313
+000c / [ [ 0 0 1 ] [ 1 0 0 ] [ 0 0 0 ] ]
314
+000d / [ [ 1 0 1 ] [ 1 0 0 ] [ 0 0 0 ] ]
315
+000e / [ [ 0 1 1 ] [ 1 0 0 ] [ 0 0 0 ] ]
316
+000f / [ [ 1 1 1 ] [ 1 0 0 ] [ 0 0 0 ] ]
317
+0010 / [ [ 0 0 0 ] [ 0 1 0 ] [ 0 0 0 ] ]
318
+0011 / [ [ 1 0 0 ] [ 0 1 0 ] [ 0 0 0 ] ]
319
+0012 / [ [ 0 1 0 ] [ 0 1 0 ] [ 0 0 0 ] ]
320
+0013 / [ [ 1 1 0 ] [ 0 1 0 ] [ 0 0 0 ] ]
321
+0015 / [ [ 1 0 1 ] [ 0 1 0 ] [ 0 0 0 ] ]
322
+0016 / [ [ 0 1 1 ] [ 0 1 0 ] [ 0 0 0 ] ]
323
+0017 / [ [ 1 1 1 ] [ 0 1 0 ] [ 0 0 0 ] ]
324
+001a / [ [ 0 1 0 ] [ 1 1 0 ] [ 0 0 0 ] ]
325
+001b / [ [ 1 1 0 ] [ 1 1 0 ] [ 0 0 0 ] ]
326
+001c / [ [ 0 0 1 ] [ 1 1 0 ] [ 0 0 0 ] ]
327
+001d / [ [ 1 0 1 ] [ 1 1 0 ] [ 0 0 0 ] ]
328
+001e / [ [ 0 1 1 ] [ 1 1 0 ] [ 0 0 0 ] ]
329
+001f / [ [ 1 1 1 ] [ 1 1 0 ] [ 0 0 0 ] ]
330
+0021 / [ [ 1 0 0 ] [ 0 0 1 ] [ 0 0 0 ] ]
331
+0023 / [ [ 1 1 0 ] [ 0 0 1 ] [ 0 0 0 ] ]
332
+0025 / [ [ 1 0 1 ] [ 0 0 1 ] [ 0 0 0 ] ]
333
+0027 / [ [ 1 1 1 ] [ 0 0 1 ] [ 0 0 0 ] ]
334
+0028 / [ [ 0 0 0 ] [ 1 0 1 ] [ 0 0 0 ] ]
335
+0029 / [ [ 1 0 0 ] [ 1 0 1 ] [ 0 0 0 ] ]
336
+002a / [ [ 0 1 0 ] [ 1 0 1 ] [ 0 0 0 ] ]
337
+002b / [ [ 1 1 0 ] [ 1 0 1 ] [ 0 0 0 ] ]
338
+002c / [ [ 0 0 1 ] [ 1 0 1 ] [ 0 0 0 ] ]
339
+002d / [ [ 1 0 1 ] [ 1 0 1 ] [ 0 0 0 ] ]
340
+002e / [ [ 0 1 1 ] [ 1 0 1 ] [ 0 0 0 ] ]
341
+002f / [ [ 1 1 1 ] [ 1 0 1 ] [ 0 0 0 ] ]
342
+0031 / [ [ 1 0 0 ] [ 0 1 1 ] [ 0 0 0 ] ]
343
+0033 / [ [ 1 1 0 ] [ 0 1 1 ] [ 0 0 0 ] ]
344
+0035 / [ [ 1 0 1 ] [ 0 1 1 ] [ 0 0 0 ] ]
345
+0037 / [ [ 1 1 1 ] [ 0 1 1 ] [ 0 0 0 ] ]
346
+0038 / [ [ 0 0 0 ] [ 1 1 1 ] [ 0 0 0 ] ]
347
+0039 / [ [ 1 0 0 ] [ 1 1 1 ] [ 0 0 0 ] ]
348
+003a / [ [ 0 1 0 ] [ 1 1 1 ] [ 0 0 0 ] ]
349
+003b / [ [ 1 1 0 ] [ 1 1 1 ] [ 0 0 0 ] ]
350
+003c / [ [ 0 0 1 ] [ 1 1 1 ] [ 0 0 0 ] ]
351
+003d / [ [ 1 0 1 ] [ 1 1 1 ] [ 0 0 0 ] ]
352
+003e / [ [ 0 1 1 ] [ 1 1 1 ] [ 0 0 0 ] ]
353
+003f / [ [ 1 1 1 ] [ 1 1 1 ] [ 0 0 0 ] ]
354
+0044 / [ [ 0 0 1 ] [ 0 0 0 ] [ 1 0 0 ] ]
355
+0045 / [ [ 1 0 1 ] [ 0 0 0 ] [ 1 0 0 ] ]
356
+0046 / [ [ 0 1 1 ] [ 0 0 0 ] [ 1 0 0 ] ]
357
+0047 / [ [ 1 1 1 ] [ 0 0 0 ] [ 1 0 0 ] ]
358
+004c / [ [ 0 0 1 ] [ 1 0 0 ] [ 1 0 0 ] ]
359
+004d / [ [ 1 0 1 ] [ 1 0 0 ] [ 1 0 0 ] ]
360
+004e / [ [ 0 1 1 ] [ 1 0 0 ] [ 1 0 0 ] ]
361
+004f / [ [ 1 1 1 ] [ 1 0 0 ] [ 1 0 0 ] ]
362
+0054 / [ [ 0 0 1 ] [ 0 1 0 ] [ 1 0 0 ] ]
363
+0055 / [ [ 1 0 1 ] [ 0 1 0 ] [ 1 0 0 ] ]
364
+0056 / [ [ 0 1 1 ] [ 0 1 0 ] [ 1 0 0 ] ]
365
+0057 / [ [ 1 1 1 ] [ 0 1 0 ] [ 1 0 0 ] ]
366
+005c / [ [ 0 0 1 ] [ 1 1 0 ] [ 1 0 0 ] ]
367
+005d / [ [ 1 0 1 ] [ 1 1 0 ] [ 1 0 0 ] ]
368
+005e / [ [ 0 1 1 ] [ 1 1 0 ] [ 1 0 0 ] ]
369
+005f / [ [ 1 1 1 ] [ 1 1 0 ] [ 1 0 0 ] ]
370
+0061 / [ [ 1 0 0 ] [ 0 0 1 ] [ 1 0 0 ] ]
371
+0062 / [ [ 0 1 0 ] [ 0 0 1 ] [ 1 0 0 ] ]
372
+0063 / [ [ 1 1 0 ] [ 0 0 1 ] [ 1 0 0 ] ]
373
+0065 / [ [ 1 0 1 ] [ 0 0 1 ] [ 1 0 0 ] ]
374
+0066 / [ [ 0 1 1 ] [ 0 0 1 ] [ 1 0 0 ] ]
375
+0067 / [ [ 1 1 1 ] [ 0 0 1 ] [ 1 0 0 ] ]
376
+0069 / [ [ 1 0 0 ] [ 1 0 1 ] [ 1 0 0 ] ]
377
+006a / [ [ 0 1 0 ] [ 1 0 1 ] [ 1 0 0 ] ]
378
+006b / [ [ 1 1 0 ] [ 1 0 1 ] [ 1 0 0 ] ]
379
+006c / [ [ 0 0 1 ] [ 1 0 1 ] [ 1 0 0 ] ]
380
+006d / [ [ 1 0 1 ] [ 1 0 1 ] [ 1 0 0 ] ]
381
+006e / [ [ 0 1 1 ] [ 1 0 1 ] [ 1 0 0 ] ]
382
+006f / [ [ 1 1 1 ] [ 1 0 1 ] [ 1 0 0 ] ]
383
+0071 / [ [ 1 0 0 ] [ 0 1 1 ] [ 1 0 0 ] ]
384
+0072 / [ [ 0 1 0 ] [ 0 1 1 ] [ 1 0 0 ] ]
385
+0073 / [ [ 1 1 0 ] [ 0 1 1 ] [ 1 0 0 ] ]
386
+0075 / [ [ 1 0 1 ] [ 0 1 1 ] [ 1 0 0 ] ]
387
+0076 / [ [ 0 1 1 ] [ 0 1 1 ] [ 1 0 0 ] ]
388
+0077 / [ [ 1 1 1 ] [ 0 1 1 ] [ 1 0 0 ] ]
389
+0079 / [ [ 1 0 0 ] [ 1 1 1 ] [ 1 0 0 ] ]
390
+007a / [ [ 0 1 0 ] [ 1 1 1 ] [ 1 0 0 ] ]
391
+007b / [ [ 1 1 0 ] [ 1 1 1 ] [ 1 0 0 ] ]
392
+007c / [ [ 0 0 1 ] [ 1 1 1 ] [ 1 0 0 ] ]
393
+007d / [ [ 1 0 1 ] [ 1 1 1 ] [ 1 0 0 ] ]
394
+007e / [ [ 0 1 1 ] [ 1 1 1 ] [ 1 0 0 ] ]
395
+007f / [ [ 1 1 1 ] [ 1 1 1 ] [ 1 0 0 ] ]
396
+008d / [ [ 1 0 1 ] [ 1 0 0 ] [ 0 1 0 ] ]
397
+008e / [ [ 0 1 1 ] [ 1 0 0 ] [ 0 1 0 ] ]
398
+008f / [ [ 1 1 1 ] [ 1 0 0 ] [ 0 1 0 ] ]
399
+009d / [ [ 1 0 1 ] [ 1 1 0 ] [ 0 1 0 ] ]
400
+009e / [ [ 0 1 1 ] [ 1 1 0 ] [ 0 1 0 ] ]
401
+009f / [ [ 1 1 1 ] [ 1 1 0 ] [ 0 1 0 ] ]
402
+00aa / [ [ 0 1 0 ] [ 1 0 1 ] [ 0 1 0 ] ]
403
+00ab / [ [ 1 1 0 ] [ 1 0 1 ] [ 0 1 0 ] ]
404
+00ad / [ [ 1 0 1 ] [ 1 0 1 ] [ 0 1 0 ] ]
405
+00af / [ [ 1 1 1 ] [ 1 0 1 ] [ 0 1 0 ] ]
406
+00ba / [ [ 0 1 0 ] [ 1 1 1 ] [ 0 1 0 ] ]
407
+00bb / [ [ 1 1 0 ] [ 1 1 1 ] [ 0 1 0 ] ]
408
+00bd / [ [ 1 0 1 ] [ 1 1 1 ] [ 0 1 0 ] ]
409
+00bf / [ [ 1 1 1 ] [ 1 1 1 ] [ 0 1 0 ] ]
410
+00c5 / [ [ 1 0 1 ] [ 0 0 0 ] [ 1 1 0 ] ]
411
+00c6 / [ [ 0 1 1 ] [ 0 0 0 ] [ 1 1 0 ] ]
412
+00c7 / [ [ 1 1 1 ] [ 0 0 0 ] [ 1 1 0 ] ]
413
+00cd / [ [ 1 0 1 ] [ 1 0 0 ] [ 1 1 0 ] ]
414
+00ce / [ [ 0 1 1 ] [ 1 0 0 ] [ 1 1 0 ] ]
415
+00cf / [ [ 1 1 1 ] [ 1 0 0 ] [ 1 1 0 ] ]
416
+00d5 / [ [ 1 0 1 ] [ 0 1 0 ] [ 1 1 0 ] ]
417
+00d6 / [ [ 0 1 1 ] [ 0 1 0 ] [ 1 1 0 ] ]
418
+00d7 / [ [ 1 1 1 ] [ 0 1 0 ] [ 1 1 0 ] ]
419
+00dd / [ [ 1 0 1 ] [ 1 1 0 ] [ 1 1 0 ] ]
420
+00de / [ [ 0 1 1 ] [ 1 1 0 ] [ 1 1 0 ] ]
421
+00df / [ [ 1 1 1 ] [ 1 1 0 ] [ 1 1 0 ] ]
422
+00e5 / [ [ 1 0 1 ] [ 0 0 1 ] [ 1 1 0 ] ]
423
+00e7 / [ [ 1 1 1 ] [ 0 0 1 ] [ 1 1 0 ] ]
424
+00ed / [ [ 1 0 1 ] [ 1 0 1 ] [ 1 1 0 ] ]
425
+00ee / [ [ 0 1 1 ] [ 1 0 1 ] [ 1 1 0 ] ]
426
+00ef / [ [ 1 1 1 ] [ 1 0 1 ] [ 1 1 0 ] ]
427
+00f5 / [ [ 1 0 1 ] [ 0 1 1 ] [ 1 1 0 ] ]
428
+00f7 / [ [ 1 1 1 ] [ 0 1 1 ] [ 1 1 0 ] ]
429
+00fd / [ [ 1 0 1 ] [ 1 1 1 ] [ 1 1 0 ] ]
430
+00fe / [ [ 0 1 1 ] [ 1 1 1 ] [ 1 1 0 ] ]
431
+00ff / [ [ 1 1 1 ] [ 1 1 1 ] [ 1 1 0 ] ]
432
+0145 / [ [ 1 0 1 ] [ 0 0 0 ] [ 1 0 1 ] ]
433
+0147 / [ [ 1 1 1 ] [ 0 0 0 ] [ 1 0 1 ] ]
434
+014f / [ [ 1 1 1 ] [ 1 0 0 ] [ 1 0 1 ] ]
435
+0155 / [ [ 1 0 1 ] [ 0 1 0 ] [ 1 0 1 ] ]
436
+0157 / [ [ 1 1 1 ] [ 0 1 0 ] [ 1 0 1 ] ]
437
+015f / [ [ 1 1 1 ] [ 1 1 0 ] [ 1 0 1 ] ]
438
+016d / [ [ 1 0 1 ] [ 1 0 1 ] [ 1 0 1 ] ]
439
+016f / [ [ 1 1 1 ] [ 1 0 1 ] [ 1 0 1 ] ]
440
+017d / [ [ 1 0 1 ] [ 1 1 1 ] [ 1 0 1 ] ]
441
+017f / [ [ 1 1 1 ] [ 1 1 1 ] [ 1 0 1 ] ]
442
+01ef / [ [ 1 1 1 ] [ 1 0 1 ] [ 1 1 1 ] ]
443
+01ff / [ [ 1 1 1 ] [ 1 1 1 ] [ 1 1 1 ] ]
444
+count: 139
445
+```
446
+
447
+## リンク
448
+- [Perlオブジェクト指向プログラミング](http://www.rwds.net/kuroita/program/Perl_oo.html)
... ...
\ No newline at end of file
Perl/\343\202\255\343\203\274\343\203\257\343\203\274\343\203\211\347\275\256\346\217\233.md
... ...
@@ -0,0 +1,547 @@
1
+[[_TOC_]]
2
+----
3
+# 概要
4
+- 置換キーワードリストに従って、入力ファイル中のキーワードを置換してファイルへ出力する。
5
+- キーワード毎に何件置換したかをレポートする。
6
+- 正規表現による置換も行える。(2007/06/08 更新)
7
+- SendTo から呼び出せるように変更。(2011/04/16)
8
+- オプションで、文字セットの指定、辞書の選択、エンターキー待ちするかどうかの選択、レポート出力するかどうかの選択をできるようにしました。(2011/05/08)
9
+- 置換時にマルチラインオプション(m)を使用するようにしました。(2011/05/08)
10
+- 複数行にわたる置換ルールを書けるようにしました。(2011/05/08)
11
+- 入力ファイルが指定されていないときはクリップボードに対して処理するようにしました。(2011/05/17)
12
+- １つのルールの中でTabを複数回使えるようにしました。(2011/09/07)
13
+- 置換対象とするファイルに yml, yaml を加えました。(2011/09/07)
14
+
15
+# ダウンロード
16
+- [replaceKeyword.zip](replaceKeyword.zip)
17
+
18
+# ソースコード
19
+```perl
20
+# replaceKeyword.pl
21
+# by TakeAsh, 2011/09/07
22
+#
23
+# 置換キーワードリストに従って、入力ファイル中のキーワードを置換してファイルへ出力する。
24
+# 入力ファイルを指定しなかった場合は、クリップボードを対象に置換処理を行なう。
25
+# 置換キーワードリストはこのスクリプトと同じディレクトリに保存しておくこと。
26
+#
27
+# 置換キーワードリストは、下記の書式で必要な個数を列記する。
28
+# {置換対象キーワード} \t+ {置換後の文字列} \n
29
+# 行頭に # がある行と空行は無視される。
30
+# 置換後の文字列として「eval(～)」と記述しておくと、Perlの式として評価される。
31
+#
32
+# このスクリプトはUTF-8Nで保存すること
33
+
34
+use strict;
35
+use warnings;
36
+use utf8;
37
+use Encode;
38
+use FindBin;
39
+#use FindBin::libs;
40
+use File::Basename;
41
+use Term::ReadKey;
42
+use Tkx;
43
+#use YAML::Syck;
44
+
45
+#$YAML::Syck::ImplicitUnicode = 1;
46
+
47
+my $charsetConsole = 'CP932';
48
+my $charsetDefault = 'utf-8';
49
+my $charsetFile = $charsetDefault;
50
+
51
+binmode( STDIN, ":encoding($charsetConsole)" );
52
+binmode( STDOUT, ":encoding($charsetConsole)" );
53
+binmode( STDERR, ":encoding($charsetConsole)" );
54
+
55
+my $extDic = '.dic';
56
+my $fileNameRepLst = 'replaceKeyword'; # 既定置換キーワードリストファイル名
57
+my $fileNameReport = 'ReplaceReport.txt'; # レポート出力ファイル名
58
+my $fileNameReportFull = ''; # レポート出力ファイルフルパス名(CP932)
59
+my $flgPause = 0; # 処理終了後エンターキー待ちするかどうか 0:しない 1:する
60
+my $flgReport = 0; # レポート出力するかどうか 0:しない 1:する
61
+
62
+my @extIn = map{ quotemeta( '.' . $_ ); } qw( txt htm html c cpp cs h pl pm js yml yaml );
63
+
64
+my %Options = (
65
+ 'c' => {
66
+ 'desc' => "<charset>\tファイルの文字セットを指定します。",
67
+ 'sub' => sub{
68
+ $charsetFile = shift( @ARGV );
69
+ print STDERR ( "CharSet: $charsetFile\n" );
70
+ },
71
+ },
72
+ 'd' => {
73
+ 'desc' => "<file>\tfile を辞書ファイルとして読み込みます。",
74
+ 'sub' => sub{ loadDic( shift( @ARGV ) ); },
75
+ },
76
+ 'h' => {
77
+ 'desc' => "\t\tヘルプを表示します。",
78
+ 'sub' => \&help,
79
+ },
80
+ 'p' => {
81
+ 'desc' => "\t\t処理終了後エンターキーの入力を待ちます。",
82
+ 'sub' => sub{ $flgPause = 1; },
83
+ },
84
+ 'v' => {
85
+ 'desc' => "\t\t$fileNameReport に処理結果を出力します。",
86
+ 'sub' => sub{ $flgReport = 1; },
87
+ },
88
+);
89
+
90
+@ARGV = map{ decode( $charsetConsole, $_ ); } @ARGV;
91
+
92
+my @RepPairs =();
93
+loadDic();
94
+
95
+my @Files = ();
96
+
97
+# オプションはファイルより先に処理
98
+while( my $arg = shift( @ARGV ) ){
99
+ if ( $arg =~ /^-(\w+)/ ){
100
+ my $optsub = $Options{$1}{'sub'};
101
+ if ( ref( $optsub ) eq 'CODE' ){
102
+ &{$optsub};
103
+ } else {
104
+ die( "不正なオプション: $1\n" );
105
+ }
106
+ } else {
107
+ push( @Files, $arg );
108
+ }
109
+}
110
+
111
+my $REPO;
112
+
113
+# 自動フラッシュ有効化
114
+$| = 1;
115
+
116
+if ( @Files <= 0 ){
117
+ # クリップボードに対して処理
118
+ $flgReport = 0;
119
+ my $buffer = doReplace( Tkx::clipboard( 'get' ), \@RepPairs );
120
+ Tkx::clipboard( 'clear' );
121
+ Tkx::clipboard( 'append', $buffer );
122
+} else {
123
+ # ファイルに対して処理
124
+ my( $name, $path, $suffix ) = fileparse( $Files[0], @extIn );
125
+ if ( $flgReport ){
126
+ $fileNameReportFull = encode( $charsetConsole, $path . $fileNameReport );
127
+ open( $REPO, ">:utf8", $fileNameReportFull )
128
+ or die( "$path$fileNameReport: $!" );
129
+ }
130
+
131
+ # ファイルの処理
132
+ while( my $fileNameIn = shift( @Files ) ){
133
+ print STDERR ( "$fileNameIn\n" );
134
+ my( $name, $path, $suffix ) = fileparse( $fileNameIn, @extIn );
135
+ if ( !$suffix ){
136
+ print STDERR ( "Skipped.\n" );
137
+ next;
138
+ }
139
+
140
+ # 出力ファイル名。既存のものは確認なしで上書きされる。
141
+ my $fileNameOut = $path . $name . '_replace' . $suffix;
142
+ report( "InFile:\t%s\nOutFile:\t%s\n#\tN\tOld\tNew\n", $fileNameIn, $fileNameOut );
143
+
144
+ # 入力ファイル読み込み
145
+ open( my $IN, "<:encoding($charsetFile)", encode( $charsetConsole, $fileNameIn ) )
146
+ or die( "$fileNameIn: $!\n" );
147
+ my $buffer = join( "", <$IN> );
148
+ close( $IN );
149
+
150
+ # 置換処理
151
+ $buffer = doReplace( $buffer, \@RepPairs );
152
+
153
+ # 置換結果出力
154
+ open( my $OUT, ">:encoding($charsetFile)", encode( $charsetConsole, $fileNameOut ) )
155
+ or die( "$fileNameOut: $!\n" );
156
+ print $OUT $buffer;
157
+ close( $OUT );
158
+ }
159
+
160
+ if ( $flgReport ){
161
+ close( $REPO );
162
+ }
163
+}
164
+
165
+# 自動フラッシュ無効化
166
+$| = 0;
167
+
168
+if ( $flgPause ){
169
+ print STDERR ( "Hit Enter.\n" );
170
+ ReadKey(0);
171
+}
172
+
173
+exit();
174
+
175
+# ヘルプの表示
176
+sub help
177
+{
178
+ die( "使用法: replaceKeyword.pl [<オプション>] [<source> [<source2>...]]\n" .
179
+ "$fileNameRepLst$extDic に従って文字列を置換します。\n" .
180
+ "入力ファイルを省略した場合はクリップボードに対して処理が行なわれます。\n" .
181
+ "オプション:\n" .
182
+ join( "\n", map{ '-'.$_.' '.$Options{$_}{'desc'} } sort( keys( %Options ) ) ) . "\n"
183
+ );
184
+}
185
+
186
+# 置換キーワード取り込み
187
+sub loadDic
188
+{
189
+ my $fDic = ( shift || $fileNameRepLst ) . $extDic;
190
+ open( my $REPLST, "<:utf8", encode( $charsetConsole, $FindBin::RealBin . '/' . $fDic ) )
191
+ or die( "$fDic: $!\n" );
192
+ @RepPairs =();
193
+ while( my $line = <$REPLST> ){
194
+ chomp( $line );
195
+ while( $line =~ /^(.*\S)\s+\\$/ ){ # 末尾が \ だったら次の行と結合
196
+ $line = $1;
197
+ <$REPLST> =~ /^(.*)\s*$/; # 行末の空白を削除する
198
+ $line .= $1;
199
+ }
200
+ if ( ( length( $line ) == 0 ) || ( $line =~ /^#/ ) ){ next };
201
+ $line =~ /^([^\t]+)(?:\t+)?([\s\S]*)$/; # Old, New を分割 (２回目以降のTabはそのまま残る)
202
+ push( @RepPairs, [ $1, $2 || '' ] ); # New が undef の場合は空白にする
203
+ }
204
+ close( $REPLST );
205
+ if ( $fDic ne $fileNameRepLst . $extDic ){
206
+ print STDERR ( "Dictionary: $fDic\n" );
207
+ }
208
+}
209
+
210
+#レポート出力
211
+sub report
212
+{
213
+ if ( $flgReport ){
214
+ printf $REPO ( @_ );
215
+ }
216
+}
217
+
218
+# 置換処理
219
+sub doReplace
220
+{
221
+ my( $buf, $refPairs ) = @_;
222
+ my $current = 0;
223
+ foreach my $pair ( @{$refPairs} ){
224
+ my( $old, $new ) = @{ $pair };
225
+ my $n = 0;
226
+ if ( $new =~ /^eval\((.*)\)$/ ){
227
+ no warnings 'uninitialized';
228
+ my $exp = $1;
229
+ $n = ( $buf =~ s/$old/eval($exp)/egm );
230
+ } else {
231
+ $n = ( $buf =~ s/$old/$new/gm );
232
+ }
233
+ report( "%d\t%d\t%s\t%s\n", ++$current, $n, $old, $new );
234
+ printf STDERR ( "%d/%d\r", $current, scalar(@RepPairs) );
235
+ }
236
+ report( "\n" );
237
+ print STDERR ( "\n" );
238
+ return $buf;
239
+}
240
+
241
+# EOF
242
+```
243
+
244
+# 置換例
245
+
246
+## 一括置換
247
+### キーワードリスト
248
+```
249
+# Old New
250
+
251
+# ラム
252
+です。 だ。
253
+。 っちゃ。
254
+私 ウチ
255
+
256
+# こども
257
+さ ちゃ
258
+し ち
259
+す ちゅ
260
+せ ちぇ
261
+そ ちょ
262
+サ チャ
263
+シ チ
264
+ス チュ
265
+セ チェ
266
+ソ チョ
267
+```
268
+
269
+### 変換結果
270
+| 入力 | 出力 |
271
+| --- | --- |
272
+| この度、私は、内閣総理大臣に任命されました。日本が、厳しい時期を乗り越え、新世紀の発展に向けた出発点に立った今、初の戦後生まれの総理として、国政を預かる重責を与えられたことに、身の引き締まる思いです。多くの国民の期待を正面から真摯に受け止め、身命を賭して、職務に取り組んでまいります。<br />　国政を遂行するに当たり、私は、まず、自らの政治姿勢を、国民の皆様並びに議員各位に明らかにいたします。私は、特定の団体や個人のための政治を行うつもりは一切ありません。額に汗して勤勉に働き、家族を愛し、自分の暮らす地域や故郷を良くしたいと思い、日本の未来を信じたいと願っている人々、そしてすべての国民の期待に応える政治を行ってまいります。みんなが参加する、新しい時代を切り拓く政治、誰に対しても開かれ、誰もがチャレンジできる社会を目指し、全力投球することを約束いたします。<br />　我が国は、経済、社会全般にわたる構造改革と、国民の自助努力の相乗効果により、長い停滞のトンネルを抜け出し、デフレからの脱却が視野に入るなど、改革の成果が現われ、未来への明るい展望が開けてきました。<br />　一方、人口減少が現実のものになるとともに、都市と地方の間における不均衡や、勝ち組、負け組が固定化することへの懸念、厳しい財政事情など、我が国の今後の発展にとって解決すべき重要な課題が、我々の前に立ちはだかっています。家族の価値観、地域の温かさが失われたことによる痛ましい事件や、ルール意識を欠いた企業活動による不祥事が多発しています。さらに、北朝鮮のミサイル発射や、テロの頻発など、国際社会の平和と安全に対する新たな脅威も生じています。<br />　このような状況にあって、今後のあるべき日本の方向を、勇気をもって、国民に指し示すことこそ、一国のトップリーダーの果たすべき使命であると考えます。私が目指すこの国のかたちは、活力とチャンスと優しさに満ちあふれ、自律の精神を大事にする、世界に開かれた、「美しい国、日本」であります。この「美しい国」の姿を、私は次のように考えます。<br />　１つ目は、文化、伝統、自然、歴史を大切にする国であります。<br />　２つ目は、自由な社会を基本とし、規律を知る、凛とした国であります。<br />　３つ目は、未来へ向かって成長するエネルギーを持ち続ける国であります。<br />　４つ目は、世界に信頼され、尊敬され、愛される、リーダーシップのある国であります。<br />　この「美しい国」の実現のため、私は、自由民主党及び公明党による連立政権の安定した基盤に立って、「美しい国創り内閣」を組織しました。世界のグローバル化が進む中で、時代の変化に迅速かつ的確に対応した政策決定を行うため、官邸で総理を支えるスタッフについて、各省からの順送り人事を排し、民間からの人材も含め、総理自らが人選する枠組みを早急に構築するなど、官邸の機能を抜本的に強化し、政治のリーダーシップを確立します。未来は開かれているとの信念の下、たじろぐことなく、改革の炎を燃やし続けてまいります。 | この度、ウチは、内閣総理大臣に任命ちゃれまちたっちゃ。日本が、厳ちい時期を乗り越え、新世紀の発展に向けた出発点に立った今、初の戦後生まれの総理とちて、国政を預かる重責を与えられたことに、身の引き締まる思いだっちゃ。多くの国民の期待を正面から真摯に受け止め、身命を賭ちて、職務に取り組んでまいりまちゅっちゃ。<br />　国政を遂行ちゅるに当たり、ウチは、まず、自らの政治姿勢を、国民の皆様並びに議員各位に明らかにいたちまちゅっちゃ。ウチは、特定の団体や個人のための政治を行うつもりは一切ありまちぇんっちゃ。額に汗ちて勤勉に働き、家族を愛ち、自分の暮らちゅ地域や故郷を良くちたいと思い、日本の未来を信じたいと願っている人々、ちょちてちゅべての国民の期待に応える政治を行ってまいりまちゅっちゃ。みんなが参加ちゅる、新ちい時代を切り拓く政治、誰に対ちても開かれ、誰もがチャレンジできる社会を目指ち、全力投球ちゅることを約束いたちまちゅっちゃ。<br />　我が国は、経済、社会全般にわたる構造改革と、国民の自助努力の相乗効果により、長い停滞のトンネルを抜け出ち、デフレからの脱却が視野に入るなど、改革の成果が現われ、未来への明るい展望が開けてきまちたっちゃ。<br />　一方、人口減少が現実のものになるとともに、都市と地方の間における不均衡や、勝ち組、負け組が固定化ちゅることへの懸念、厳ちい財政事情など、我が国の今後の発展にとって解決ちゅべき重要な課題が、我々の前に立ちはだかっていまちゅっちゃ。家族の価値観、地域の温かちゃが失われたことによる痛まちい事件や、ルール意識を欠いた企業活動による不祥事が多発ちていまちゅっちゃ。ちゃらに、北朝鮮のミチャイル発射や、テロの頻発など、国際社会の平和と安全に対ちゅる新たな脅威も生じていまちゅっちゃ。<br />　このような状況にあって、今後のあるべき日本の方向を、勇気をもって、国民に指ち示ちゅことこちょ、一国のトップリーダーの果たちゅべき使命であると考えまちゅっちゃ。ウチが目指ちゅこの国のかたちは、活力とチャンチュと優ちちゃに満ちあふれ、自律の精神を大事にちゅる、世界に開かれた、「美ちい国、日本」でありまちゅっちゃ。この「美ちい国」の姿を、ウチは次のように考えまちゅっちゃ。<br />　１つ目は、文化、伝統、自然、歴史を大切にちゅる国でありまちゅっちゃ。<br />　２つ目は、自由な社会を基本とち、規律を知る、凛とちた国でありまちゅっちゃ。<br />　３つ目は、未来へ向かって成長ちゅるエネルギーを持ち続ける国でありまちゅっちゃ。<br />　４つ目は、世界に信頼ちゃれ、尊敬ちゃれ、愛ちゃれる、リーダーチップのある国でありまちゅっちゃ。<br />　この「美ちい国」の実現のため、ウチは、自由民主党及び公明党による連立政権の安定ちた基盤に立って、「美ちい国創り内閣」を組織ちまちたっちゃ。世界のグローバル化が進む中で、時代の変化に迅速かつ的確に対応ちた政策決定を行うため、官邸で総理を支えるチュタッフについて、各省からの順送り人事を排ち、民間からの人材も含め、総理自らが人選ちゅる枠組みを早急に構築ちゅるなど、官邸の機能を抜本的に強化ち、政治のリーダーチップを確立ちまちゅっちゃ。未来は開かれているとの信念の下、たじろぐことなく、改革の炎を燃やち続けてまいりまちゅっちゃ。 |
273
+
274
+## 正規表現置換
275
+### キーワードリスト
276
+```
277
+\$Buf\[([^\]]+)\]({[^}]+}) eval('$Ref'.$2.'{\'A'.$1.'\'}')
278
+```
279
+
280
+### 変換結果
281
+| 入力 | 出力 |
282
+| --- | --- |
283
+| $result = sprintf( <br /> "%s : %d, %d, %d, %d\n" .<br /> "%s : %d, %d, %d, %d\n" .<br /> "%s : %d, %d, %d, %d\n", <br /> $Buf[0]{'x'}, $Buf[0]{'y'}, $Buf[0]{'dx'}, $Buf[0]{'dy'},<br /> $Buf[1]{'x'}, $Buf[1]{'y'}, $Buf[1]{'dx'}, $Buf[1]{'dy'},<br /> $Buf[2]{'x'}, $Buf[2]{'y'}, $Buf[2]{'dx'}, $Buf[2]{'dy'},<br /> );<br /> | $result = sprintf( <br /> "%s : %d, %d, %d, %d\n" .<br /> "%s : %d, %d, %d, %d\n" .<br /> "%s : %d, %d, %d, %d\n", <br /> $Ref{'x'}{'A0'}, $Ref{'y'}{'A0'}, $Ref{'dx'}{'A0'}, $Ref{'dy'}{'A0'},<br /> $Ref{'x'}{'A1'}, $Ref{'y'}{'A1'}, $Ref{'dx'}{'A1'}, $Ref{'dy'}{'A1'},<br /> $Ref{'x'}{'A2'}, $Ref{'y'}{'A2'}, $Ref{'dx'}{'A2'}, $Ref{'dy'}{'A2'},<br /> );<br /> |
284
+
285
+## HTML/XML をタグ単位で改行
286
+### キーワードリスト
287
+```
288
+# Old New
289
+
290
+# HTML/XML をタグ単位で改行
291
+> eval(">\n")
292
+\n\s+ eval("\n")
293
+<([\w_-]+)([^>]*)>\n+([^<]*)<\/\1> eval("<$1$2>$3</$1>")
294
+#>(\s+)< eval("><") # 逆変換(改行を削除)
295
+```
296
+
297
+## タブ区切りを PukiWiki のテーブルに変換
298
+### キーワードリスト
299
+```
300
+# タブ区切りを PukiWiki 用テーブルに変換
301
+
302
+# メタ文字をエスケープ
303
+([|~>:]) eval(sprintf("&#x%02x;",ord($1)))
304
+
305
+# "" を削除
306
+(?<=\t)?"([^\t\n]+)"(?=\s) eval($_=$1; s/""/"/g; $_;)
307
+
308
+# 単独の - は中央揃え
309
+(?<=\s)(-)(?=\s) eval("CENTER:$1")
310
+
311
+# 数値は右詰め
312
+(?<=\s)((?:[-+\d.e'"]|&#x3a;)+)(?=\s) eval("RIGHT:$1")
313
+
314
+# OK,NG を中央揃えかつカラーに
315
+\b(OK|NG)\b eval("CENTER:COLOR(#".{ 'OK'=>'00FF00', 'NG'=>'FF0000' }->{$1}."):$1")
316
+
317
+# 末尾が「h/f」の行をヘッダ行/フッタ行と見なして各々の列に「~」を追加 (最大20列まで対応)
318
+^((?:[^\t\n]*)\t)?((?:[^\t\n]*)\t)?((?:[^\t\n]*)\t)?((?:[^\t\n]*)\t)? \
319
+((?:[^\t\n]*)\t)?((?:[^\t\n]*)\t)?((?:[^\t\n]*)\t)?((?:[^\t\n]*)\t)? \
320
+((?:[^\t\n]*)\t)?((?:[^\t\n]*)\t)?((?:[^\t\n]*)\t)?((?:[^\t\n]*)\t)? \
321
+((?:[^\t\n]*)\t)?((?:[^\t\n]*)\t)?((?:[^\t\n]*)\t)?((?:[^\t\n]*)\t)? \
322
+((?:[^\t\n]*)\t)?((?:[^\t\n]*)\t)?((?:[^\t\n]*)\t)?((?:[^\t\n]*)\t)?(h|f)$ \
323
+ eval("~$1~$2~$3~$4~$5~$6~$7~$8~$9~$10~$11~$12~$13~$14~$15~$16~$17~$18~$19~$20$21")
324
+^(.*\t)~+(h|f)$ eval("$1$2")
325
+
326
+# ヘッダ行/フッタ行以外の第１列をヘッダに
327
+^([^:]+:)?([^~].*)$ eval("$1~$2")
328
+
329
+# colspan
330
+(~[^\t]+\t)((?:~\t)+) eval(@_=($1,$2); $_=$2; s/~/>/g; "$_$_[0]";)
331
+
332
+# rowspan
333
+(?<=\t)(?=\s) ~
334
+
335
+\t |
336
+\A([\s\S]*)\Z eval("\n$1\n")
337
+\n eval("|\n|")
338
+\|(h|f)\|\n eval("|$1\n")
339
+^\|~?\|$
340
+\A\|\n([\s\S]*[^\n]\n)\n*\|\Z eval("$1")
341
+```
342
+
343
+### 変換結果
344
+- 入力
345
+```
346
+"#" "文字コード" "改行コード" "Win" "Mac" h
347
+ "結果" "サイズ/KB" "処理時間" "結果" "サイズ/KB" "処理時間" h
348
+1 "Shift_JIS" "CRLF" "OK" 8.00 "0:00'10""" "OK" 10.00 "0:00'08"""
349
+2 "CR" "NG" "-" "-" "OK" 10.00 "0:00'08"""
350
+3 "LF" "OK" 8.00 "0:00'10""" "NG" "-" "-"
351
+4 "UTF16" "CRLF" "OK" 12.00 "0:00'30""" "OK" 15.00 "0:00'30"""
352
+5 "CR" "NG" "-" "-" "OK" 15.00 "0:00'30"""
353
+6 "LF" "OK" 12.00 "0:00'30""" "NG" "-" "-"
354
+"#" "文字コード" "改行コード" "結果" "サイズ" "処理時間" "結果" "サイズ" "処理時間" f
355
+```
356
+
357
+- 出力
358
+| # | 文字コード | 改行コード | > | > | Win | > | > | Mac |
359
+| --- | --- | --- | --- | --- | --- | --- | --- | --- |
360
+| | | | 結果 | サイズ/KB | 処理時間 | 結果 | サイズ/KB | 処理時間 |
361
+| 1 | Shift_JIS | CRLF | OK | 8.00 | 0&#x3a;00'10" | OK | 10.00 | 0&#x3a;00'08" |
362
+| 2 | | CR | NG | - | - | OK | 10.00 | 0&#x3a;00'08" |
363
+| 3 | | LF | OK | 8.00 | 0&#x3a;00'10" | NG | - | - |
364
+| 4 | UTF16 | CRLF | OK | 12.00 | 0&#x3a;00'30" | OK | 15.00 | 0&#x3a;00'30" |
365
+| 5 | | CR | NG | - | - | OK | 15.00 | 0&#x3a;00'30" |
366
+| 6 | | LF | OK | 12.00 | 0&#x3a;00'30" | NG | - | - |
367
+| # | 文字コード | 改行コード | 結果 | サイズ | 処理時間 | 結果 | サイズ | 処理時間 |
368
+
369
+## Schema から XML に変換
370
+### キーワードリスト
371
+```
372
+# Schema から XML に変換
373
+
374
+# フィールド
375
+\s+-\s+[^:]+:\s+[^\n]+\n \
376
+\s+[^:]+:\s+[^\n]+\n \
377
+\s+COLUMN_NAME:\s+([^\n]+)\n \
378
+\s+DATA_TYPE:\s+([^\n]+)\n \
379
+\s+[^:]+:\s+[^\n]+\n \
380
+(?=\s*(-\s|\S|\Z)) \
381
+ eval( "\t<FIELD\tName=\"$1\"\tType=\"" . { \
382
+ 'int' => 'NUMBER', \
383
+ 'decimal' => 'NUMBER', \
384
+ 'money' => 'NUMBER', \
385
+ 'bit' => 'BOOL', \
386
+ 'date' => 'DATE', \
387
+ 'datetime' => 'DATE', \
388
+ 'time' => 'DATE', \
389
+ 'timestamp' => 'DATE', \
390
+ 'char' => 'TEXT', \
391
+ 'text' => 'TEXT', \
392
+ 'varchar' => 'TEXT', \
393
+ 'nchar' => 'TEXT', \
394
+ 'ntext' => 'TEXT', \
395
+ 'nvarchar' => 'TEXT', \
396
+ 'binary' => 'TEXT', \
397
+ 'image' => 'TEXT', \
398
+ 'varbinary' => 'TEXT', \
399
+ 'uniqueidentifier' => 'TEXT', \
400
+ }->{$2} . "\"\t/>\n" )
401
+
402
+# テーブル名
403
+^([^-\s][^:]+): \
404
+ eval("</TABLE>\n<TABLE\tName=\"$1\"\tPrimaryField=\"\">\n")
405
+
406
+# 後始末
407
+\A---\s+</TABLE>\s+([\s\S]*)\Z \
408
+ eval("$1</TABLE>\n")
409
+```
410
+
411
+### 変換結果
412
+- 入力
413
+```
414
+---
415
+クラスレベルTable:
416
+ -
417
+ CHARACTER_MAXIMUM_LENGTH: ~
418
+ COLUMN_DEFAULT: ~
419
+ COLUMN_NAME: ID
420
+ DATA_TYPE: int
421
+ IS_NULLABLE: 'NO'
422
+ -
423
+ CHARACTER_MAXIMUM_LENGTH: 30
424
+ COLUMN_DEFAULT: ~
425
+ COLUMN_NAME: クラスレベル
426
+ DATA_TYPE: nvarchar
427
+ IS_NULLABLE: 'NO'
428
+会員Table:
429
+ -
430
+ CHARACTER_MAXIMUM_LENGTH: ~
431
+ COLUMN_DEFAULT: ~
432
+ COLUMN_NAME: ID
433
+ DATA_TYPE: int
434
+ IS_NULLABLE: 'NO'
435
+ -
436
+ CHARACTER_MAXIMUM_LENGTH: 50
437
+ COLUMN_DEFAULT: ~
438
+ COLUMN_NAME: 姓
439
+ DATA_TYPE: nvarchar
440
+ IS_NULLABLE: 'NO'
441
+ -
442
+ CHARACTER_MAXIMUM_LENGTH: 50
443
+ COLUMN_DEFAULT: ~
444
+ COLUMN_NAME: 名
445
+ DATA_TYPE: nvarchar
446
+ IS_NULLABLE: 'NO'
447
+ …(省略)…
448
+```
449
+- 出力
450
+```
451
+<TABLE Name="クラスレベルTable" PrimaryField="">
452
+ <FIELD Name="ID" Type="NUMBER" />
453
+ <FIELD Name="クラスレベル" Type="TEXT" />
454
+</TABLE>
455
+<TABLE Name="会員Table" PrimaryField="">
456
+ <FIELD Name="ID" Type="NUMBER" />
457
+ <FIELD Name="姓" Type="TEXT" />
458
+ <FIELD Name="名" Type="TEXT" />
459
+ <FIELD Name="誕生日" Type="DATE" />
460
+ <FIELD Name="性別" Type="NUMBER" />
461
+ <FIELD Name="Email" Type="TEXT" />
462
+ <FIELD Name="電話番号" Type="TEXT" />
463
+ <FIELD Name="郵便番号" Type="TEXT" />
464
+ <FIELD Name="住所1" Type="TEXT" />
465
+ <FIELD Name="住所2" Type="TEXT" />
466
+ <FIELD Name="クラスレベル" Type="NUMBER" />
467
+ <FIELD Name="前回ログイン" Type="DATE" />
468
+ <FIELD Name="備考" Type="TEXT" />
469
+</TABLE>
470
+<TABLE Name="性別Table" PrimaryField="">
471
+ <FIELD Name="ID" Type="NUMBER" />
472
+ <FIELD Name="性別" Type="TEXT" />
473
+</TABLE>
474
+```
475
+
476
+## メール返信時の余分な行を削除
477
+### キーワードリスト
478
+```
479
+# Email返信時の余分な行を削除 (クリップボード用)
480
+# 「\r\r\n」があると余分な行になる？
481
+
482
+\n>\n(?=>) eval("\n")
483
+(>\n){2,} eval(">\n")
484
+\n\n(?!\n) eval("\n")
485
+\n{3,} eval("\n\n")
486
+>\x20(?=>) >
487
+\Z eval("\n\n")
488
+```
489
+
490
+### 変換結果
491
+- 入力
492
+```
493
+>
494
+>
495
+>
496
+> Dear John-san,
497
+>
498
+> I want to know ～～
499
+>
500
+> Could you let us know ～～
501
+>
502
+```
503
+- 出力
504
+```
505
+>
506
+> Dear John-san,
507
+> I want to know ～～
508
+> Could you let us know ～～
509
+>
510
+```
511
+
512
+## Email アドレスの引用符を統一
513
+### キーワードリスト
514
+```
515
+# Email アドレスの「"'～'"」を「"～"」に統一
516
+
517
+"'([^']+)'" eval("\"$1\"")
518
+```
519
+
520
+# 参考: Win32::Clipboard の場合
521
+```perl
522
+use Win32::Clipboard;
523
+
524
+my $clip = Win32::Clipboard();
525
+if ( $clip->IsText() ){
526
+ my $buffer = decode( 'UTF16LE', $clip->GetAs(CF_UNICODETEXT) || '' );
527
+ $buffer = doReplace( $buffer, \@RepPairs );
528
+ $clip->Set( encode( 'CP932', $buffer ) ); # UTF16LE で書き戻せない --;
529
+}
530
+```
531
+
532
+# リンク
533
+- [[Perl/MSSQL_ImpExp]]
534
+
535
+- [スクリプティング言語資料室(仮)](http://www.kt.rim.or.jp/~kbk/)
536
+ - [正規表現メモ](http://www.kt.rim.or.jp/~kbk/regex/regex.html)
537
+
538
+- [ハードなソフトの話](http://hardsoft.at.webry.info/)
539
+ - [Windows版ActivePerlでUnicodeを正しくクリップボードにコピーする方法](http://hardsoft.at.webry.info/200904/article_9.html)
540
+
541
+- [CPAN:FindBin](http://search.cpan.org/dist/perl/lib/FindBin.pm)
542
+- [CPAN:FindBin::libs](http://search.cpan.org/dist/FindBin-libs/lib/FindBin/libs.pm)
543
+- [CPAN:File::Basename](http://search.cpan.org/dist/perl/lib/File/Basename.pm)
544
+- [CPAN:Term::ReadKey](http://search.cpan.org/dist/TermReadKey/ReadKey.pm)
545
+- [CPAN:Getopt-Long](http://search.cpan.org/dist/Getopt-Long)
546
+- [CPAN:Tkx](http://search.cpan.org/dist/Tkx)
547
+- [CPAN:Win32-Clipboard](http://search.cpan.org/dist/Win32-Clipboard)
... ...
\ No newline at end of file
Perl/\343\203\207\343\202\243\343\203\254\343\202\257\343\203\210\343\203\252\343\201\256\345\206\215\345\270\260\345\207\246\347\220\206.md
... ...
@@ -0,0 +1,153 @@
1
+[[_TOC_]]
2
+- [[Perl/ファイルの一括処理]]
3
+- [[Perl/文字コード]]
4
+
5
+# 概要
6
+- ディレクトリを再帰的に処理するサンプル。
7
+
8
+# ソースコード
9
+## Win32::Unicode::Native 版
10
+```perl
11
+# ファイル名のリストアップ, ファイル名の長さ付き
12
+
13
+use strict;
14
+use warnings;
15
+use utf8;
16
+use Encode;
17
+use Win32::Unicode::Native;
18
+
19
+my $charsetFile = 'UTF-8';
20
+
21
+my $fileNameOut = "FileNames.txt";
22
+my @targetDirs = map { 'D:/' . $_; } qw(
23
+ aaa bbb ccc
24
+);
25
+
26
+my $prevDir = '';
27
+
28
+open( my $OUT, '>', $fileNameOut ) or die( "$fileNameOut: $!\n" );
29
+binmode( $OUT, ":encoding($charsetFile)" );
30
+find( \&getName, @targetDirs );
31
+close( $OUT );
32
+
33
+sub getName
34
+{
35
+ my $args = shift;
36
+ my $curFile = $args->{name};
37
+ my $curDir = $args->{dir};
38
+ if ( $prevDir ne $curDir ){
39
+ print( "$curDir\n" );
40
+ $prevDir = $curDir;
41
+ }
42
+ printf $OUT ( "%d\t%s\n", length( $curFile ), $curFile );
43
+}
44
+
45
+# EOF
46
+```
47
+
48
+## File::Next 版
49
+```perl
50
+# ファイル名のリストアップ, ファイル名の長さ付き
51
+
52
+use strict;
53
+use warnings;
54
+use utf8;
55
+use Encode;
56
+use File::Next;
57
+use Path::Class;
58
+use Win32;
59
+
60
+#my $charsetConsole = 'UTF-8';
61
+my $charsetConsole = 'CP932';
62
+my $charsetFile = 'UTF-8';
63
+
64
+binmode( STDIN, ":encoding($charsetConsole)" );
65
+binmode( STDOUT, ":encoding($charsetConsole)" );
66
+binmode( STDERR, ":encoding($charsetConsole)" );
67
+
68
+my $fileNameOut = "FileNames.txt";
69
+
70
+# 「RECYCLER」を拾わないように
71
+my @targetDirs = map{ encode( $charsetConsole, 'D:/' . $_ ); } qw(
72
+ aaa bbb ccc
73
+);
74
+
75
+my $prevDir = '';
76
+my $nextFiles = File::Next::files( @targetDirs );
77
+
78
+open( my $OUT, ">:encoding($charsetFile)", encode( $charsetConsole, $fileNameOut ) )
79
+ or die( "$fileNameOut: $!\n" );
80
+while( defined ( my $file = $nextFiles->() ) ){
81
+ # $file は CP932 エンコードかつ短いファイルネーム
82
+ my $curFile = getUtf8PathName( $file );
83
+ my $curDir = getUtf8PathName( file( $file )->dir );
84
+ if ( $prevDir ne $curDir ){
85
+ print "$curDir\n";
86
+ $prevDir = $curDir;
87
+ }
88
+ printf $OUT ( "%d\t%s\n", length( $curFile ), $curFile );
89
+}
90
+close( $OUT );
91
+
92
+sub getUtf8PathName
93
+{
94
+ my $path = shift;
95
+ $path = Win32::GetLongPathName( $path );
96
+ if ( ! Encode::is_utf8( $path ) ){
97
+ $path = decode( $charsetConsole, $path );
98
+ }
99
+ return $path;
100
+}
101
+
102
+# EOF
103
+```
104
+
105
+## 自前で再帰版
106
+```perl
107
+#!/usr/local/bin/perl
108
+
109
+# カレントディレクトリ以下の全てのファイルを処理する。
110
+
111
+recursive( '.' );
112
+
113
+exit();
114
+
115
+##### Subroutine
116
+
117
+# 再帰的にコピーする
118
+# @param[in] $sBaseDir 基準となるディレクトリ
119
+sub recursive
120
+{
121
+ my( $sBaseDir ) = @_;
122
+ my( @FileLists, $sFileName );
123
+
124
+ @FileLists = glob( $sBaseDir.'/*' );
125
+
126
+ foreach $sFileName ( sort( @FileLists ) ){
127
+ if ( -d $sFileName ){
128
+ # ディレクトリだったら再帰呼び出し
129
+ &recursive( $sFileName );
130
+ } elsif ( -f $sFileName ){
131
+ # ファイルだったら処理する
132
+ print( $sFileName . "\n" );
133
+ }
134
+ }
135
+}
136
+
137
+# EOF
138
+```
139
+
140
+# リンク
141
+- [CPAN:Win32-Unicode](http://search.cpan.org/dist/Win32-Unicode)
142
+
143
+- [CPAN:perl/lib/File/Find.pm](http://search.cpan.org/dist/perl/lib/File/Find.pm)
144
+- [CPAN:File-Find-Rule](http://search.cpan.org/dist/File-Find-Rule)
145
+
146
+- [CPAN:File-Next](http://search.cpan.org/dist/File-Next)
147
+ - Windows では、「RECYCLER」のようなシステム管理フォルダにアクセスして失敗することがある。
148
+ - ロングファイルネームではなく、8.3 形式の短いファイル名を返す。
149
+
150
+- [CPAN:Win32](http://search.cpan.org/dist/Win32)
151
+ - GetLongPathName()
152
+
153
+- [CPAN:Path-Class](http://search.cpan.org/dist/Path-Class)
... ...
\ No newline at end of file
Perl/\343\203\225\343\202\241\343\202\244\343\203\253\343\201\256\344\270\200\346\213\254\345\207\246\347\220\206.md
... ...
@@ -0,0 +1,96 @@
1
+[[_TOC_]]
2
+- Perl/ディレクトリの再帰処理
3
+
4
+# サイズがゼロのファイルを削除
5
+## 概要
6
+- カレントディレクトリからサイズがゼロのファイルを削除する。
7
+- 「-d」オプションを付けると削除実行、無しだと削除対象のリストアップのみ行う。
8
+- ドットファイルも対象とする。
9
+
10
+## ソースコード
11
+- [delSizeZero.zip](delSizeZero.zip)
12
+```perl
13
+#!/usr/bin/perl
14
+# カレントディレクトリからサイズゼロのファイルを削除する
15
+
16
+use strict;
17
+use warnings;
18
+use utf8;
19
+
20
+my $progName = 'delSizeZero';
21
+my $delete = 0;
22
+
23
+if ( @ARGV > 0 ){
24
+ if ( $ARGV[0] eq '-d' ){
25
+ $delete = 1;
26
+ } else {
27
+ die("List up files that are size 0.\nusage: $progName [-d]\n -d: delete them\n");
28
+ }
29
+}
30
+
31
+foreach my $file (sort(glob("{.*,*}"))){
32
+ if ( -f $file && -s $file == 0 ){
33
+ $file =~ m{([^;]+)$};
34
+ my $fileName = $1;
35
+ print "$fileName\n";
36
+ if ( $delete ){
37
+ unlink($file) or die("$progName: $fileName: $!\n");
38
+ }
39
+ }
40
+}
41
+
42
+# EOF
43
+```
44
+
45
+## リンク
46
+- [CPAN:Path-Tiny](http://search.cpan.org/dist/Path-Tiny)
47
+
48
+- [File::Glob Ignores Dot Files](http://www.perlmonks.org/?node_id=309995)
49
+
50
+# テキストファイルからXML部分を抜き出し
51
+## 概要
52
+- テキストファイルからXML部分を抜き出す。
53
+- １ファイルにXMLは１個。
54
+- 文字コードはEUC。
55
+- 処理はWindows上で行う。
56
+
57
+## ソースコード
58
+```perl
59
+#!/usr/local/bin/perl
60
+
61
+# カレントディレクトリのテキストファイルのリスト
62
+@filelists = <./*.txt>;
63
+# print join( "\n", @filelists );
64
+
65
+foreach $fname_in (@filelists){
66
+ $fname_out = $fname_in;
67
+ $fname_out =~ s/\.txt/\.xml/;
68
+
69
+ open( IN, $fname_in );
70
+ @lines = < IN >;
71
+ close( IN );
72
+ $body = join( "", @lines );
73
+
74
+ # XML部分を正規表現で抜き出す
75
+ # '.' は改行にマッチしないので、代わりに [\x00-\xff] を使う (マルチバイトストリングの場合)
76
+ # unicode だと [\x0000-\xffff] を使う
77
+ if ( $body =~ /^[\x00-\xff]*(\<\?xml [\x00-\xff]*\<\/[^\>]+\>)[\x00-\xff]*$/ ){
78
+ $body = $1 . "\n";
79
+ # CRLF から CR を削除
80
+ # $body =~ tr/\r//d;
81
+ open( OUT, ">" . $fname_out );
82
+ # テキストモードだと自動的に CR が付加されるのでバイナリモードで書き出し
83
+ binmode( OUT );
84
+ print OUT $body;
85
+ close( OUT );
86
+ }
87
+}
88
+
89
+#EOF
90
+```
91
+
92
+## リンク
93
+- [CPAN:Path-Class](http://search.cpan.org/dist/Path-Class)
94
+
95
+- [JPerl Advent Calendar 2010 Casual Trac](http://perl-users.jp/articles/advent-calendar/2010/casual/)
96
+ - [Path::Classで簡単ファイル操作](http://perl-users.jp/articles/advent-calendar/2010/casual/15)
... ...
\ No newline at end of file
Perl/\343\203\225\343\202\241\343\202\244\343\203\253\345\220\215\346\255\243\350\246\217\345\214\226.md
... ...
@@ -0,0 +1,65 @@
1
+# ファイル名の正規化
2
+[[_TOC_]]
3
+
4
+## 概要
5
+- カレントディレクトリのファイル名をルールに従って正規化する。
6
+- 正規化したいファイルを選択した後、SendTo から呼び出す。
7
+```
8
+perl.exe {fullpath}\normFileName.pl
9
+```
10
+- 空白 -> _
11
+- _v/r. -> _v/r ("v"または"r"に続く"."を削除。ただし拡張子の前の"."だったら削除しない)
12
+- エラー時にメッセージを表示するようにした。(2012/07/13)
13
+
14
+## ソース
15
+- [normFileName.zip](normFileName.zip)
16
+```perl
17
+# normFileName.pl
18
+# ファイル名を正規化する。
19
+# 空白 -> _
20
+# _v/r. -> _v/r ("v"または"r"に続く"."を削除。ただし拡張子の前の"."だったら削除しない)
21
+
22
+use strict;
23
+use warnings;
24
+use utf8;
25
+use Encode;
26
+use File::Basename;
27
+use Term::ReadKey;
28
+
29
+my $charset = 'CP932';
30
+
31
+binmode( STDIN, ":encoding($charset)" );
32
+binmode( STDOUT, ":encoding($charset)" );
33
+binmode( STDERR, ":encoding($charset)" );
34
+
35
+@ARGV = map{ decode( $charset, $_ ); } @ARGV;
36
+
37
+my @Ext = map{ ".$_" } qw( pdf zip mbs htm html txt doc docx xls xlsx mdb accdb ppt pptx );
38
+
39
+foreach my $fileNameIn ( @ARGV ){
40
+ my( $name, $path, $suffix ) = fileparse( $fileNameIn, @Ext );
41
+ if ( $suffix ){
42
+ my $fn2 = $name;
43
+ $fn2 =~ s/\s+/_/g;
44
+ $fn2 =~ s/_+/_/g;
45
+ $fn2 =~ s/(_[vr])\./$1/ig;
46
+ $fn2 =~ s/(_[vr])[-\.](\d+)[-\.](\d+)/$1$2.$3/ig;
47
+ if ( $name ne $fn2 ){
48
+ print( "old: ${name}${suffix}\nnew: ${fn2}${suffix}\n" );
49
+ rename( encode( $charset, $fileNameIn ), encode( $charset, $path . $fn2 . $suffix ) )
50
+ or print( "${name}${suffix}: $!\n" );
51
+ print( "\n" );
52
+ }
53
+ }
54
+}
55
+
56
+warn( "Hit Enter.\n" );
57
+ReadKey(0);
58
+
59
+# EOF
60
+```
61
+
62
+## リンク
63
+- [[文字コード|Perl/文字コード]]
64
+
65
+- [CPAN:perl/lib/File/Basename.pm](http://search.cpan.org/dist/perl/lib/File/Basename.pm)
... ...
\ No newline at end of file
Perl/\345\205\250\350\247\222\343\201\213\343\202\211\345\215\212\350\247\222\343\201\270\345\244\211\346\217\233.md
... ...
@@ -0,0 +1,27 @@
1
+# 全角から半角へ変換
2
+[[_TOC_]]
3
+
4
+## ソースコード
5
+```
6
+#!/usr/local/bin/perl
7
+
8
+# 全角英数記号を半角英数記号に置換
9
+# このスクリプトは「UTF-8N」として保存すること
10
+
11
+use utf8;
12
+binmode( STDIN, ":encoding(utf8)" );
13
+binmode( STDOUT, ":encoding(utf8)" );
14
+
15
+while(<STDIN>){
16
+ tr/Ａ-Ｚａ-ｚ０-９！”＃＄％＆’（）／．\x{3000}/A-Za-z0-9!\"\#$%&'\(\)\/\.\x{0020}/;
17
+ print STDOUT $_;
18
+}
19
+
20
+#EOF
21
+```
22
+
23
+## リンク
24
+- [perl5.8のUnicodeサポート](http://www.lr.pi.titech.ac.jp/~abekawa/perl/perl_unicode.html)
25
+
26
+- [CPAN:Lingua-JA-Regular-Unicode](http://search.cpan.org/dist/Lingua-JA-Regular-Unicode)
27
+- [CPAN:Lingua-JA-Numbers](http://search.cpan.org/dist/Lingua-JA-Numbers)
... ...
\ No newline at end of file
Perl/\345\217\202\347\205\247.md
... ...
@@ -0,0 +1,64 @@
1
+# 参照
2
+[[_TOC_]]
3
+
4
+## 概要
5
+- ハッシュへの参照のテスト
6
+
7
+## ソース
8
+- [testRef.pl](testRef.pl)
9
+```
10
+# ハッシュへの参照のテスト
11
+
12
+use strict;
13
+use warnings;
14
+use utf8;
15
+use Encode;
16
+
17
+binmode( STDIN, ':encoding(CP932)' );
18
+binmode( STDOUT, ':encoding(CP932)' );
19
+binmode( STDERR, ':encoding(CP932)' );
20
+
21
+my $refHash = {};
22
+p();
23
+
24
+$refHash->{'distance'} = {};
25
+p();
26
+
27
+$refHash = func( $refHash );
28
+p();
29
+
30
+$refHash->{'distance'}{'value'} = 5;
31
+p();
32
+
33
+$refHash = func( $refHash );
34
+p();
35
+
36
+sub p
37
+{
38
+ my $dist = $refHash->{'distance'} && $refHash->{'distance'}{'value'} || -1;
39
+ printf( "%d\n", $dist );
40
+}
41
+
42
+sub func
43
+{
44
+ my( $r ) = @_;
45
+ if (
46
+ ref( $r ) eq 'HASH'
47
+ && ref( $r->{'distance'} ) eq 'HASH'
48
+ && $r->{'distance'}{'value'}
49
+ ){
50
+ $r->{'distance'}{'value'} *= 2;
51
+ }
52
+ return $r;
53
+}
54
+
55
+# EOF
56
+```
57
+
58
+## 出力結果
59
+```
60
+-1
61
+-1
62
+-1
63
+5
64
+10
... ...
\ No newline at end of file
Perl/\345\244\232\346\254\241\345\205\203\351\205\215\345\210\227.md
... ...
@@ -0,0 +1,192 @@
1
+[[_TOC_]]
2
+
3
+# 概要
4
+Perlでは配列の中に配列への参照を入れることができるので、これを使うと多次元配列が実現できる。
5
+
6
+- [MultiDimensional.zip](MultiDimensional.zip)
7
+
8
+# 配列
9
+- ソース
10
+```perl
11
+# 多次元配列
12
+
13
+use strict;
14
+use warnings;
15
+use utf8;
16
+
17
+my @Array = ();
18
+$Array[0][0] = "a";
19
+$Array[0][2] = "b";
20
+$Array[1][1] = "c";
21
+$Array[2][0] = "d";
22
+$Array[2][3] = "e";
23
+
24
+printAll1( \@Array );
25
+printAll2( \@Array );
26
+
27
+# @Array の内容を全置き換え。以前の内容は失われる
28
+@Array = (
29
+ [ undef, "a", undef, "b", ],
30
+ [ "c", ],
31
+ [ "d", undef, "e", ],
32
+);
33
+
34
+printAll1( \@Array );
35
+printAll2( \@Array );
36
+
37
+exit();
38
+
39
+# 一定範囲を出力
40
+sub printAll1
41
+{
42
+ my( $refArray ) = @_;
43
+ for( my $i=0; $i<3; ++$i ){
44
+ printf( "%d /", $i );
45
+ for( my $j=0; $j<4; ++$j ){
46
+ printf( "\t%d:'%s'", $j, ($refArray->[$i][$j] || '') );
47
+ }
48
+ printf( "\n" );
49
+ }
50
+ printf( "\n" );
51
+}
52
+
53
+# ０から最大の添え字までを出力
54
+sub printAll2
55
+{
56
+ my( $refArray ) = @_;
57
+ for( my $i=0; $i<scalar(@{$refArray}); ++$i ){
58
+ printf( "%d /", $i );
59
+ for( my $j=0; $j<scalar(@{$refArray->[$i]}); ++$j ){
60
+ printf( "\t%d:'%s'", $j, ($refArray->[$i][$j] || '') );
61
+ }
62
+ printf( "\n" );
63
+ }
64
+ printf( "\n" );
65
+}
66
+
67
+# EOF
68
+```
69
+
70
+- 出力結果
71
+```
72
+0 / 0:'a' 1:'' 2:'b' 3:''
73
+1 / 0:'' 1:'c' 2:'' 3:''
74
+2 / 0:'d' 1:'' 2:'' 3:'e'
75
+
76
+0 / 0:'a' 1:'' 2:'b'
77
+1 / 0:'' 1:'c'
78
+2 / 0:'d' 1:'' 2:'' 3:'e'
79
+
80
+0 / 0:'' 1:'a' 2:'' 3:'b'
81
+1 / 0:'c' 1:'' 2:'' 3:''
82
+2 / 0:'d' 1:'' 2:'e' 3:''
83
+
84
+0 / 0:'' 1:'a' 2:'' 3:'b'
85
+1 / 0:'c'
86
+2 / 0:'d' 1:'' 2:'e'
87
+```
88
+
89
+# 連想配列 (ハッシュ)
90
+- ソース
91
+```perl
92
+# 多次元ハッシュ
93
+
94
+use strict;
95
+use warnings;
96
+use utf8;
97
+
98
+my %Hash = ();
99
+$Hash{'A'}{'a'} = "1";
100
+$Hash{'A'}{'b'} = "2";
101
+$Hash{'B'}{'a'} = "3";
102
+$Hash{'B'}{'b'} = "4";
103
+$Hash{'B'}{'c'} = "5";
104
+$Hash{'C'}{'b'} = "6";
105
+$Hash{'C'}{'c'} = "7";
106
+
107
+printAll1( \%Hash );
108
+printAll2( \%Hash );
109
+
110
+# %Hash の内容を全置き換え。以前の内容は失われる
111
+%Hash = (
112
+ 'A' => { 'b'=>"11", },
113
+ 'B' => { 'a'=>"12", 'b'=>"13", 'c'=>"14", },
114
+);
115
+
116
+printAll1( \%Hash );
117
+printAll2( \%Hash );
118
+
119
+# %{$Hash{'B'}} の内容を置き換え
120
+$Hash{'B'} = { 'b'=>"15", };
121
+# %{$Hash{'C'}} の内容を追加
122
+$Hash{'C'} = { 'a'=>"16", 'c'=>"17", };
123
+
124
+printAll1( \%Hash );
125
+printAll2( \%Hash );
126
+
127
+exit();
128
+
129
+# 一定範囲を出力
130
+sub printAll1
131
+{
132
+ my( $refHash ) = @_;
133
+ my @Xs = qw( A B C );
134
+ my @Ys = qw( a b c );
135
+
136
+ foreach my $x ( @Xs ){
137
+ printf( "%s /", $x );
138
+ foreach my $y ( @Ys ){
139
+ printf( "\t%s:'%s'", $y, ($refHash->{$x}{$y} || '') );
140
+ }
141
+ printf( "\n" );
142
+ }
143
+ printf( "\n" );
144
+}
145
+
146
+# 存在する要素を出力
147
+sub printAll2
148
+{
149
+ my( $refHash ) = @_;
150
+ foreach my $x ( sort( keys( %{$refHash} ) ) ){
151
+ printf( "%s /", $x );
152
+ foreach my $y ( sort( keys( %{$refHash->{$x}} ) ) ){
153
+ printf( "\t%s:'%d'", $y, ($refHash->{$x}{$y} || '') );
154
+ }
155
+ printf( "\n" );
156
+ }
157
+ printf( "\n" );
158
+}
159
+
160
+# EOF
161
+```
162
+
163
+- 出力結果
164
+```
165
+A / a:'1' b:'2' c:''
166
+B / a:'3' b:'4' c:'5'
167
+C / a:'' b:'6' c:'7'
168
+
169
+A / a:'1' b:'2'
170
+B / a:'3' b:'4' c:'5'
171
+C / b:'6' c:'7'
172
+
173
+A / a:'' b:'11' c:''
174
+B / a:'12' b:'13' c:'14'
175
+C / a:'' b:'' c:''
176
+
177
+A / b:'11'
178
+B / a:'12' b:'13' c:'14'
179
+C /
180
+
181
+A / a:'' b:'11' c:''
182
+B / a:'' b:'15' c:''
183
+C / a:'16' b:'' c:'17'
184
+
185
+A / b:'11'
186
+B / b:'15'
187
+C / a:'16' c:'17'
188
+```
189
+
190
+# リンク
191
+- [サンプルコードによるPerl入門](http://d.hatena.ne.jp/perlcodesample/)
192
+ - [Perlの配列とハッシュを自由に扱う](http://d.hatena.ne.jp/perlcodesample/20100930/1278596435)
... ...
\ No newline at end of file
Perl/\346\226\207\345\255\227\343\202\263\343\203\274\343\203\211.md
... ...
@@ -0,0 +1,456 @@
1
+[[_TOC_]]
2
+
3
+# 文字列 -> 16進表記
4
+
5
+## ソースコード
6
+```perl
7
+#!/usr/local/bin/perl
8
+
9
+# 文字列を16進表記に変換
10
+# このスクリプトは、文字コード:UTF8N, 改行:LF として保存すること。
11
+
12
+use utf8;
13
+use Encode qw/encode decode/;
14
+#binmode( STDOUT, ":encoding(utf8)" );
15
+
16
+$message = 'ABCXYZあいうえおわゐゑをん';
17
+$output = 'output.txt';
18
+
19
+open( OUT, ">:encoding(utf8)", $output ) || die( "can't open '$output'.\n" );
20
+
21
+printf OUT ( "str : %s\n", $message );
22
+printf OUT ( "UCS2: %s\n", &str_to_ucs2( $message ) );
23
+printf OUT ( "UTF8: %s\n", &str_to_utf8( $message ) );
24
+printf OUT ( "UTF8: %s\n", &str_to_byte( $message, "utf8" ) );
25
+printf OUT ( "SJIS: %s\n", &str_to_byte( $message, "shift_jis" ) );
26
+printf OUT ( "euc : %s\n", &str_to_byte( $message, "euc-jp" ) );
27
+
28
+close( OUT );
29
+
30
+exit();
31
+
32
+#### Subroutine ####
33
+
34
+# wide character 文字列として取り扱う
35
+sub str_to_ucs2
36
+{
37
+ my( $sIn ) = @_;
38
+ my( $sOut, $len, $i );
39
+
40
+ $sOut = '';
41
+
42
+ $len = length( $sIn );
43
+ for( $i=0; $i<$len; ++$i ){
44
+ $sOut .= sprintf( "%04x ", unpack( "U", substr( $sIn, $i, 1 )));
45
+ }
46
+ chop( $sOut );
47
+
48
+ return $sOut;
49
+}
50
+
51
+# wide character 文字列 として取り扱う
52
+sub str_to_utf8
53
+{
54
+ my( $sIn ) = @_;
55
+ my( $sOut, $len, $i );
56
+
57
+ $sOut = '';
58
+
59
+ $len = length( $sIn );
60
+ for( $i=0; $i<$len; ++$i ){
61
+ $sOut .= unpack( "H8", substr( $sIn, $i, 1 ) ) . ' ';
62
+ }
63
+ chop( $sOut );
64
+
65
+ return $sOut;
66
+}
67
+
68
+# multi byte 文字列として取り扱う
69
+sub str_to_byte
70
+{
71
+ my( $sIn, $encoding ) = @_;
72
+ my( $sOut, $len, $i );
73
+
74
+ $sOut = '';
75
+
76
+ $sIn = encode( $encoding, $sIn );
77
+
78
+ $len = length( $sIn );
79
+ for( $i=0; $i<$len; ++$i ){
80
+ $sOut .= unpack( "H2", substr( $sIn, $i, 1 ) ) . ' ';
81
+ }
82
+ chop( $sOut );
83
+
84
+ return $sOut;
85
+}
86
+
87
+# EOF
88
+```
89
+
90
+## 出力結果
91
+```
92
+str : ABCXYZあいうえおわゐゑをん
93
+UCS2: 0041 0042 0043 0058 0059 005a 3042 3044 3046 3048 304a 308f 3090 3091 3092 3093
94
+UTF8: 41 42 43 58 59 5a e38182 e38184 e38186 e38188 e3818a e3828f e38290 e38291 e38292 e38293
95
+UTF8: 41 42 43 58 59 5a e3 81 82 e3 81 84 e3 81 86 e3 81 88 e3 81 8a e3 82 8f e3 82 90 e3 82 91 e3 82 92 e3 82 93
96
+SJIS: 41 42 43 58 59 5a 82 a0 82 a2 82 a4 82 a6 82 a8 82 ed 82 ee 82 ef 82 f0 82 f1
97
+euc : 41 42 43 58 59 5a a4 a2 a4 a4 a4 a6 a4 a8 a4 aa a4 ef a4 f0 a4 f1 a4 f2 a4 f3
98
+```
99
+
100
+# 16進表記 -> 文字列
101
+- 「16進表記」「Base64エンコード」で7bitにされたUTF-8文字列を復元する。
102
+
103
+## ソースコード
104
+```perl
105
+# UTF-8 <-> 16進 変換
106
+# utf8-hex.pl
107
+# このスクリプトは、文字コード:UTF8N, 改行:LF として保存すること。
108
+
109
+use strict;
110
+use warnings;
111
+use utf8;
112
+use Encode;
113
+use MIME::Base64;
114
+
115
+my $utf8str = "ABCあいうえお";
116
+my $hexstr = "414243E38182E38184E38186E38188E3818A";
117
+my $b64str = "QUJD44GC44GE44GG44GI44GK";
118
+
119
+open( OUT, ">:utf8", "output.txt" ) || die( "can't open 'output.txt'.\n" );
120
+
121
+printf OUT ( "utf8:\t'%s'\n", $utf8str );
122
+printf OUT ( "->hex:\t'%s'\n", &Utf8ToHex( $utf8str ) );
123
+printf OUT ( "hex:\t'%s'\n", $hexstr );
124
+printf OUT ( "->utf8:\t'%s'\n", &HexToUtf8( $hexstr ) );
125
+printf OUT ( "utf8:\t'%s'\n", $utf8str );
126
+printf OUT ( "->B64:\t'%s'\n", &Utf8ToB64( $utf8str ) );
127
+printf OUT ( "B64:\t'%s'\n", $b64str );
128
+printf OUT ( "->utf8:\t'%s'\n", &B64ToUtf8( $b64str ) );
129
+
130
+close( OUT );
131
+
132
+exit();
133
+
134
+sub Utf8ToHex
135
+{
136
+ my( $src ) = @_;
137
+ return unpack( "H*", encode( "utf8", $src ) );
138
+}
139
+
140
+sub HexToUtf8
141
+{
142
+ my( $src ) = @_;
143
+ return decode( "utf8", pack( "H*", $src ) );
144
+}
145
+
146
+sub Utf8ToB64
147
+{
148
+ my( $src ) = @_;
149
+ return encode_base64( encode( "utf8", $src ), "" );
150
+}
151
+
152
+sub B64ToUtf8
153
+{
154
+ my( $src ) = @_;
155
+ return decode( "utf8", decode_base64( $src ) );
156
+}
157
+
158
+# EOF
159
+```
160
+
161
+## 出力結果
162
+```
163
+utf8: 'ABCあいうえお'
164
+->hex: '414243e38182e38184e38186e38188e3818a'
165
+hex: '414243E38182E38184E38186E38188E3818A'
166
+->utf8: 'ABCあいうえお'
167
+utf8: 'ABCあいうえお'
168
+->B64: 'QUJD44GC44GE44GG44GI44GK'
169
+B64: 'QUJD44GC44GE44GG44GI44GK'
170
+->utf8: 'ABCあいうえお'
171
+```
172
+
173
+# バイナリ <-> 16進変換
174
+- [bin2hex.zip](bin2hex.zip)
175
+- バイナリファイルを16進表記のテキストファイルに変換します。
176
+- アドレスとかチェックサムとか気の利いたものはつきません。
177
+- .hexファイル中に[0-9a-fA-F][0-9a-fA-F]以外の文字があるとゴミデータになり、元のバイナリが再現されません。
178
+
179
+## ソースコード bin2hex.pl
180
+```perl
181
+#!/usr/local/bin/perl
182
+
183
+# bin2hex.pl
184
+# バイナリファイルを16進に変換する。
185
+
186
+use strict;
187
+use warnings;
188
+use utf8;
189
+
190
+my $ext = "hex";
191
+
192
+my $fin = $ARGV[0] or die( "usage: $0 <binfile>\n" );
193
+
194
+open( my $fhin, "<:raw", $fin ) or die( "$fin: $!\n" );
195
+open( my $fhout, ">:utf8", "$fin.$ext" ) or die( "$fin.$ext: $!\n" );
196
+while( <$fhin> ){
197
+ print $fhout unpack( "H*", $_ );
198
+}
199
+close( $fhin );
200
+close( $fhout );
201
+
202
+# EOF
203
+```
204
+
205
+## ソースコード hex2bin.pl
206
+```perl
207
+#!/usr/local/bin/perl
208
+
209
+# hex2bin.pl
210
+# 16進をバイナリファイルに変換する。
211
+
212
+use strict;
213
+use warnings;
214
+use utf8;
215
+
216
+my $ext = "bin";
217
+
218
+my $fin = $ARGV[0] or die( "usage: $0 <hexfile>\n" );
219
+
220
+open( my $fhin, "<:utf8", $fin ) or die( "$fin: $!\n" );
221
+open( my $fhout, ">:raw", "$fin.$ext" ) or die( "$fin.$ext: $!\n" );
222
+while( <$fhin> ){
223
+ print $fhout pack( "H*", $_ );
224
+}
225
+close( $fhin );
226
+close( $fhout );
227
+
228
+# EOF
229
+```
230
+
231
+# ユニコード表現(&#xXXXX;)変換
232
+## ダウンロード
233
+- [DecEncUni.zip](DecEncUni.zip)
234
+
235
+## decodeUni.pl
236
+```perl
237
+#!/usr/bin/perl
238
+# decodeUni.pl
239
+# ユニコード表現(&#xXXXX;)をUTF8文字に変換
240
+
241
+use strict;
242
+use warnings;
243
+use utf8;
244
+use Encode;
245
+
246
+my $fileNameIn = 'Text1.txt';
247
+my $fileNameOut = 'Text2.txt';
248
+
249
+my $charsetConsole = 'CP932';
250
+my $charsetFile = 'UTF-8';
251
+
252
+binmode( STDIN, ":encoding($charsetConsole)" );
253
+binmode( STDOUT, ":encoding($charsetConsole)" );
254
+binmode( STDERR, ":encoding($charsetConsole)" );
255
+
256
+open( my $fin, "<:encoding($charsetFile)", encode( $charsetConsole, $fileNameIn ) )
257
+ or die( "$fileNameIn: $!\n" );
258
+my @body = <$fin>;
259
+close( $fin );
260
+
261
+my $body = join( "", @body );
262
+$body =~ s/&#x([0-9a-f]+);/chr( hex( $1 ) )/igmeo;
263
+
264
+open( my $fout, ">:encoding($charsetFile)", encode( $charsetConsole, $fileNameOut ) )
265
+ or die( "$fileNameOut: $!\n" );
266
+print $fout $body;
267
+close( $fout );
268
+
269
+# EOF
270
+```
271
+
272
+## encodeUni.pl
273
+```perl
274
+#!/usr/bin/perl
275
+# encodeUni.pl
276
+# UTF8文字の内、ShiftJIS外の文字をユニコード表現(&#xXXXX;)に変換
277
+
278
+use strict;
279
+use warnings;
280
+use utf8;
281
+use Encode;
282
+
283
+my $fileNameIn = 'Text2.txt';
284
+my $fileNameOut = 'Text3.txt';
285
+
286
+my $charsetConsole = 'CP932';
287
+my $charsetFile = 'UTF-8';
288
+
289
+binmode( STDIN, ":encoding($charsetConsole)" );
290
+binmode( STDOUT, ":encoding($charsetConsole)" );
291
+binmode( STDERR, ":encoding($charsetConsole)" );
292
+
293
+open( my $fin, "<:encoding($charsetFile)", encode( $charsetConsole, $fileNameIn ) )
294
+ or die( "$fileNameIn: $!\n" );
295
+my @body = <$fin>;
296
+close( $fin );
297
+
298
+my $body = join( "", @body );
299
+$body =~ s/([^\x00-\xff])/encodeUnlessSJIS( $1 )/igmeo;
300
+$body =~ s/([^[:print:]])/sprintf( "&#x%X;", ord( $1 ) )/gmeo;
301
+
302
+open( my $fout, ">:encoding($charsetFile)", encode( $charsetConsole, $fileNameOut ) )
303
+ or die( "$fileNameOut: $!\n" );
304
+print $fout $body;
305
+close( $fout );
306
+
307
+sub issjis
308
+{
309
+ my( $utf8 ) = @_;
310
+ return ( $utf8 eq '?' || encode( 'CP932', $utf8 ) ne '?' );
311
+}
312
+
313
+sub encodeUnlessSJIS
314
+{
315
+ my( $utf8 ) = @_;
316
+ return ( issjis( $utf8 ) ) ? $utf8 : sprintf( "&#x%X;", ord( $utf8 ) ) ;
317
+}
318
+
319
+# EOF
320
+```
321
+
322
+## サンプルデータ Text1.txt
323
+```
324
+漢字のファイル
325
+ちゃんと変換されていますか？
326
+Is this file converted correctly?
327
+&#x9AD8;&#X9ad9;
328
+&#X5D0E;&#xfa11;
329
+&#x5409;&#x20BB7;
330
+&#x53F1;&#x20B9F;
331
+&#x5265;&#x525D;
332
+&#x586B;&#x5861;
333
+&#x982C;&#x9830;
334
+&#x09;タブ&#x1A;制御コード
335
+```
336
+
337
+## 出力結果 Text2.txt
338
+![Text2.png](Text2.png)
339
+
340
+## 出力結果 Text3.txt
341
+```
342
+漢字のファイル
343
+ちゃんと変換されていますか？
344
+Is this file converted correctly?
345
+高髙
346
+崎﨑
347
+吉&#x20BB7;
348
+叱&#x20B9F;
349
+剥&#x525D;
350
+填&#x5861;
351
+頬&#x9830;
352
+ タブ&#x1A;制御コード
353
+```
354
+
355
+# Shift_JIS から UTF16LE(BOM付き)へ変換
356
+- [perlでUTF-16LE + BOM - d.aql](http://d.hatena.ne.jp/aql/20090326/1238085344)
357
+- [Perl 5.8.x 以降で BOM を操作するモジュール ハードなソフトの話/ウェブリブログ](http://hardsoft.at.webry.info/200802/article_2.html)
358
+- [CPAN:File-BOM](http://search.cpan.org/dist/File-BOM)
359
+- [convSJIStoUTF16.pl](convSJIStoUTF16.pl)
360
+```perl
361
+# convSJIStoUTF16.pl
362
+# 行単位で加工を行う。
363
+# 文字コードを Shift_JIS から UTF-16LE(BOM付き)に変換する。
364
+
365
+use strict;
366
+use warnings;
367
+use utf8;
368
+use Encode;
369
+
370
+my $fileNameIn = "Data_SJIS.txt";
371
+my $fileNameOut = "Data_UTF16.txt";
372
+
373
+binmode( STDIN, ":encoding(CP932)" );
374
+binmode( STDOUT, ":encoding(CP932)" );
375
+binmode( STDERR, ":encoding(CP932)" );
376
+
377
+$| = 1;
378
+
379
+open( my $fin, "<:encoding(CP932)", encode( 'CP932', $fileNameIn ) )
380
+ or die( "$fileNameIn: $!\n" );
381
+my @body = <$fin>;
382
+close( $fin );
383
+
384
+$body[ 0 ] =~ /(\s+)$/;
385
+$/ = $1;
386
+chomp( @body );
387
+
388
+open( my $fout, ">:raw", encode( 'CP932', $fileNameOut ) )
389
+ or die( "$fileNameOut: $!\n" );
390
+print $fout pack( 'H*', 'fffe' ); # BOMの出力
391
+binmode( $fout, ":encoding(UTF16LE)" );
392
+
393
+my $max = scalar( @body );
394
+my $count = 0;
395
+
396
+while( @body > 0 ){
397
+ printf STDERR ( "%d/%d\r", ++$count, $max );
398
+ my $line = shift( @body );
399
+ # $line =~ s///; # なにか加工を行う。
400
+ print $fout $line . "\n";
401
+}
402
+
403
+close( $fout );
404
+
405
+# EOF
406
+```
407
+- UTF-8 BOM の場合
408
+```perl
409
+print $fout pack( 'H*', 'efbbbf' );
410
+binmode( $fout, ":utf8" );
411
+```
412
+
413
+# ユニコード表示
414
+- コマンドラインから渡された文字列のユニコードを表示する。
415
+```perl
416
+#!/usr/bin/perl
417
+# UTF32 コードの取得
418
+
419
+use strict;
420
+use warnings;
421
+use utf8;
422
+use Encode;
423
+use Win32::Unicode::Native;
424
+
425
+foreach my $arg (@ARGV){
426
+ foreach my $ch (split(//, $arg)){
427
+ my $u = unpack('H*', encode('UTF32BE', $ch));
428
+ $u =~ s/^0*//;
429
+ print "$ch: $u\n";
430
+ }
431
+}
432
+```
433
+
434
+# リンク
435
+- [[Perl/initConsole]]
436
+- [[Perl/EPSファイル作成]]
437
+- [[Perl/ディレクトリの再帰処理]]
438
+
439
+- [Unicode support in Perl](http://perldoc.perl.org/perlunicode.html)
440
+ - [Perl における Unicode サポート](http://perldoc.jp/pod/perlunicode)
441
+
442
+- [UCSとUTF](http://homepage1.nifty.com/nomenclator/unicode/ucs_utf.htm)
443
+- [perl5.8のUnicodeサポート](http://www.lr.pi.titech.ac.jp/~abekawa/perl/perl_unicode.html)
444
+- [Perl 5.8.x Unicode関連](http://www.rwds.net/kuroita/program/Perl_unicode.html)
445
+
446
+- [Perl の数値変換](http://mikeneko.creator.club.ne.jp/~lab/perl/numerical_transform/)
447
+
448
+- [404 Blog Not Found](http://blog.livedoor.jp/dankogai/)
449
+ - [perl, python & ruby - chr() vs. Unicode](http://blog.livedoor.jp/dankogai/archives/50696206.html)
450
+ - [perl, python & ruby - ord() vs. Unicode](http://blog.livedoor.jp/dankogai/archives/50698007.html)
451
+
452
+- [文字コードを変換するプログラム(Ruby)](http://itpro.nikkeibp.co.jp/article/COLUMN/20060927/249167/)
453
+
454
+- [新常用漢字表が迫るUnicode移行、「シフトJIS」では対応不可能 - 新常用漢字が引き起こす文字コード問題：ITpro](http://itpro.nikkeibp.co.jp/article/COLUMN/20091209/341831/)
455
+
456
+- [WikiPedia.ja:バイトオーダーマーク](http://ja.wikipedia.org/wiki/%e3%83%90%e3%82%a4%e3%83%88%e3%82%aa%e3%83%bc%e3%83%80%e3%83%bc%e3%83%9e%e3%83%bc%e3%82%af)
... ...
\ No newline at end of file
Perl/\346\227\245\347\265\214ITpro.md
... ...
@@ -0,0 +1,12 @@
1
+# 日経ITpro
2
+[[_TOC_]]
3
+----
4
+## いまさら聞けないPerlのお役立ちワザ
5
+1. [処理系のインストール, エンコーディング, PPM](http://itpro.nikkeibp.co.jp/article/COLUMN/20050829/220194/)
6
+1. [文字列置換, 正規表現作成](http://itpro.nikkeibp.co.jp/article/COLUMN/20050901/220432/)
7
+1. [ファイルのリネーム, 実行速度測定](http://itpro.nikkeibp.co.jp/article/COLUMN/20050905/220595/)
8
+1. [QRコード](http://itpro.nikkeibp.co.jp/article/COLUMN/20050909/220867/)
9
+
10
+## Webプログラミング実力アップ
11
+1. [正しいPerl/CGIの書き方](http://itpro.nikkeibp.co.jp/article/COLUMN/20071011/284280/)
12
+1. [Webアプリケーション・フレームワーク入門](http://itpro.nikkeibp.co.jp/article/COLUMN/20071011/284283/)
... ...
\ No newline at end of file
Perl/\346\233\234\346\227\245\343\201\256\350\250\210\347\256\227(Zeller\343\201\256\345\205\254\345\274\217).md
... ...
@@ -0,0 +1,64 @@
1
+# 曜日の計算 (Zellerの公式)
2
+[[_TOC_]]
3
+----
4
+## 概要
5
+- ある日付の曜日を計算する。
6
+- 計算できるのは、1582年10月15日（金）以降。
7
+
8
+## ソース
9
+```
10
+#!/usr/bin/perl
11
+
12
+# 年月日の指定（例：1945年8月15日水曜日）
13
+$year = 1945;
14
+$month = 8;
15
+$day = 15;
16
+
17
+$wday = &calcZeller( $year, $month, $day );
18
+
19
+$youbi = ( "Sunday", "Monday", "Tuesday", "Wednesday",
20
+ "Thursday", "Friday", "Saturday" )[ $wday ];
21
+$monthname = ( "-", "Jan", "Feb", "Mar", "Apr", "May", "Jun",
22
+ "Jul", "Aug", "Sep", "Oct", "Nov", "Dec" )[ $month ];
23
+printf( "%s, %02d %s %04d\n", $youbi, $day, $monthname, $year );
24
+
25
+exit();
26
+
27
+# 曜日の計算
28
+# @param[in] $year 年
29
+# @param[in] $month 月
30
+# @param[in] $day 日
31
+# @return 曜日 ( 0:日 1:月 2:火 3:水 4:木 5:金 6:土 )
32
+sub calcZeller
33
+{
34
+ my( $year, $month, $day ) = @_;
35
+ my( $year2, $month2 ) = ( $year, $month );
36
+ if ( $month == 1 || $month == 2 ) {
37
+ $year2--;
38
+ $month2 += 12;
39
+ }
40
+ return ( $year2 + int( $year2 / 4 ) - int( $year2 / 100 ) + int( $year2 / 400 )
41
+ + int(( 13 * $month2 + 8 ) / 5 ) + $day ) % 7;
42
+}
43
+
44
+# EOF
45
+```
46
+
47
+## リンク
48
+- [曜日 〜Zeller(ツェラー)の公式〜](http://easycgi.xrea.jp/tips/perl/zeller.htm)
49
+- [WikiPedia.ja:ツェラーの公式](http://ja.wikipedia.org/wiki/%e3%83%84%e3%82%a7%e3%83%a9%e3%83%bc%e3%81%ae%e5%85%ac%e5%bc%8f)
50
+- [WikiPedia.ja:月_(暦)](http://ja.wikipedia.org/wiki/%e6%9c%88%5f%28%e6%9a%a6%29)
51
+
52
+- [AddinBox](http://www.h3.dion.ne.jp/~sakatsu/) / [祝日について](http://www.h3.dion.ne.jp/~sakatsu/holiday_topic.htm)
53
+- [転倒夢想庵](http://akiba.geocities.jp/tendomusoan/) / [和洋百万年暦](http://akiba.geocities.jp/tendomusoan/100mannenreki.htm)
54
+- [Internet Mail Consortium](http://www.imc.org/) / [Personal Data Interchange (vCard/vCalendar)](http://www.imc.org/pdi/)
55
+ - [RFC5545 iCalendar](http://www.ietf.org/rfc/rfc5545.txt)
56
+ - [RFC2445 iCalendar](http://www.ietf.org/rfc/rfc2445.txt)
57
+ - [iCalendar 仕様](http://www.asahi-net.or.jp/~CI5M-NMR/iCal/ref.html)
58
+ - [iCal カレンダーライブラリ](http://www.apple.com/jp/ical/library/)
59
+- [WikiPedia.ja:元号から西暦への変換表](http://ja.wikipedia.org/wiki/%e5%85%83%e5%8f%b7%e3%81%8b%e3%82%89%e8%a5%bf%e6%9a%a6%e3%81%b8%e3%81%ae%e5%a4%89%e6%8f%9b%e8%a1%a8)
60
+
61
+- [CPAN:DateTime](http://search.cpan.org/dist/DateTime)
62
+- [iandeth.](http://iandeth.dyndns.org/mt/ian/)
63
+ - [Perlで日付・時間を操作 - DateTime モジュールの使い方](http://iandeth.dyndns.org/mt/ian/archives/000619.html)
64
+- [CPAN:Time-Piece](http://search.cpan.org/dist/Time-Piece)
... ...
\ No newline at end of file
Perl/\346\234\252\345\256\232\347\276\251\343\202\263\343\203\274\343\203\211\347\275\256\346\217\233.md
... ...
@@ -0,0 +1,58 @@
1
+# テキストファイル中の Latin-1 未定義コードの置換
2
+[[_TOC_]]
3
+
4
+## 概要
5
+- 置換コードリストに従って、入力テキストファイル中の未定義コードを置換してファイルへ出力する。
6
+- コード毎に何件置換したかをレポートする。
7
+
8
+## ダウンロード
9
+- [replaceCode.zip](replaceCode.zip)
10
+
11
+## ソースコード
12
+```
13
+# テキストファイル中の Latin-1 未定義コードの置き換え
14
+
15
+use strict;
16
+use warnings;
17
+use utf8;
18
+
19
+my $infile = "readme.txt";
20
+my $outfile = "readme_.txt";
21
+
22
+my %cnvtbl = (
23
+ 0x91 => '{{',
24
+ 0x92 => '}}',
25
+ 0x93 => '[[',
26
+ 0x94 => ']]',
27
+);
28
+
29
+open( IN, $infile ) || die( "can't open '$infile'.\n" );
30
+my @file = <IN>;
31
+close( IN );
32
+
33
+my $body = join( "", @file );
34
+
35
+my $len = length( $body );
36
+
37
+my ( $i, %codes, $c );
38
+
39
+my $outbody = "";
40
+
41
+for( $i=0; $i<$len; $i++ ){
42
+ $c = substr( $body, $i, 1 );
43
+ if ( ord( $c ) > 127 ){
44
+ $codes{ ord( $c ) } += 1;
45
+ $c = $cnvtbl{ ord( $c ) };
46
+ }
47
+ $outbody .= $c;
48
+}
49
+
50
+foreach $c ( sort( keys( %codes ) ) ){
51
+ printf( "%02x: %d\n", $c, $codes{ $c } );
52
+}
53
+
54
+open( OUT, '>'.$outfile ) || die( "can't open '$outfile'.\n" );
55
+print OUT $outbody;
56
+close( OUT );
57
+
58
+# EOF
... ...
\ No newline at end of file
Perl/\347\211\271\346\256\212\346\226\207\345\255\227\343\201\256\343\202\250\343\202\271\343\202\261\343\203\274\343\203\227.md
... ...
@@ -0,0 +1,92 @@
1
+# 特殊文字のエスケープ
2
+[[_TOC_]]
3
+
4
+## 注意
5
+- HTML のエスケープには encode_entities を使いましょう。([CPAN:HTML-Parser/lib/HTML/Entities.pm](http://search.cpan.org/dist/HTML-Parser/lib/HTML/Entities.pm))
6
+- URI のエスケープには uri_escape を使いましょう。([CPAN:URI/URI/Escape.pm](http://search.cpan.org/dist/URI/URI/Escape.pm))
7
+- 正規表現をエスケープする時は quotemeta 。([perldoc.jp:func/quotemeta](http://perldoc.jp/func/quotemeta))
8
+- SQL は自分でエスケープせず、プレースホルダと bind を使いましょう。
9
+
10
+## 概要
11
+- 入力された文字列などの中のHTMLとして直接記述できない文字をエスケープする。
12
+
13
+## ソースコード
14
+```perl
15
+#!/usr/bin/perl
16
+# HTML用にエスケープ処理を行う。
17
+
18
+use strict;
19
+use warnings;
20
+use utf8;
21
+use Encode;
22
+use HTML::Entities qw( encode_entities );
23
+
24
+my $test = 'He said, "<em>Enjoy & Exciting!</em>."';
25
+
26
+my @subs = (
27
+ [ 'htmlEscapeN', \&htmlEscapeN, ],
28
+ [ 'htmlEscapeE', \&htmlEscapeE, ],
29
+ [ 'encode_entities', \&encode_entities, ],
30
+);
31
+
32
+printf( "Test:\n%s\n\n", $test );
33
+foreach my $s ( @subs ){
34
+ printf( "%s:\n%s\n\n", $s->[0], &{$s->[1]}($test) );
35
+}
36
+
37
+exit;
38
+
39
+# 数値文字参照(16進)に変換
40
+sub htmlEscapeN {
41
+ my( $str ) = @_;
42
+ $str =~ s/([&<>"'])/sprintf( "&#x%02X;", ord( $1 ) )/egmos;
43
+ return $str;
44
+}
45
+
46
+# 文字実体参照に変換
47
+# http://blog.livedoor.jp/dankogai/archives/50940023.html
48
+sub htmlEscapeE {
49
+ my $str = shift or return;
50
+ my %escaped = ( '&' => 'amp', '<' => 'lt', '>' => 'gt', '"' => 'quot' );
51
+ my $cclass2escape = '[' . join('', keys %escaped) . ']';
52
+ $str =~ s{(${cclass2escape})(?!amp;)}{'&' . $escaped{$1} . ';'}msxgeo;
53
+ return $str;
54
+}
55
+
56
+# EOF
57
+```
58
+
59
+## 出力
60
+```
61
+Test:
62
+He said, "<em>Enjoy & Exciting!</em>."
63
+
64
+htmlEscapeN:
65
+He said, &#x22;&#x3C;em&#x3E;Enjoy &#x26; Exciting!&#x3C;/em&#x3E;.&#x22;
66
+
67
+htmlEscapeE:
68
+He said, &quot;&lt;em&gt;Enjoy &amp; Exciting!&lt;/em&gt;.&quot;
69
+
70
+encode_entities:
71
+He said, &quot;&lt;em&gt;Enjoy &amp; Exciting!&lt;/em&gt;.&quot;
72
+```
73
+
74
+## ユニコード(サロゲートペア)をHTML数値参照へエスケープ
75
+```perl
76
+sub escapeSurrogatePair {
77
+ my ($str) = @_;
78
+ $str =~ s/([^\x{0000}-\x{ffff}])/sprintf( "&#x%x;", ord( $1 ) )/egmos;
79
+ return $str;
80
+}
81
+```
82
+
83
+## Link
84
+- [[EscapeSlash|Perl/EscapeSlash]]
85
+
86
+- [勝手に添削 - 40行で作るPerl用テンプレートエンジン](http://blog.livedoor.jp/dankogai/archives/50940023.html)
87
+- [Perlメモ](http://www.din.or.jp/~ohzaki/perl.htm) / [改行コードを統一する](http://www.din.or.jp/~ohzaki/perl.htm#CRLF_Unify)
88
+
89
+- [CPAN:HTML-Parser/lib/HTML/Entities.pm](http://search.cpan.org/dist/HTML-Parser/lib/HTML/Entities.pm)
90
+- [CPAN:URI/URI/Escape.pm](http://search.cpan.org/dist/URI/URI/Escape.pm)
91
+- [CPAN:String-Util](http://search.cpan.org/dist/String-Util) trim, htmlesc, jsquote
92
+- [CPAN:Unicode-Escape](http://search.cpan.org/dist/Unicode-Escape) \uXXXX 形式のエスケープ
... ...
\ No newline at end of file
Perl/\347\222\260\345\242\203\345\244\211\346\225\260.md
... ...
@@ -0,0 +1,228 @@
1
+[[_TOC_]]
2
+
3
+# 概要
4
+- CGIで環境変数を表示します。
5
+- 「HTTPS」を表示するように修正。(2012/04/29)
6
+- 「GeoIP」を表示するように修正。(2012/09/06)
7
+
8
+# 動作サンプル
9
+| HTML版 | [http](http://www.takeash.net/cgi-bin/etc/PrintEnv.cgi) | [https](https://www.takeash.net/cgi-bin/etc/PrintEnv.cgi) |
10
+| --- | --- | --- |
11
+| Text版 | [http](http://www.takeash.net/cgi-bin/etc/PrintEnv_txt.cgi) | [https](https://www.takeash.net/cgi-bin/etc/PrintEnv_txt.cgi) |
12
+
13
+# ソースコード
14
+- [PrintEnv.zip](PrintEnv.zip)
15
+
16
+## HTML版
17
+- [PrintEnv.cgi](http://www.takeash.net/cgi-bin/etc/PrintEnv.cgi)
18
+
19
+```perl
20
+#!/usr/bin/perl
21
+
22
+use strict;
23
+use warnings;
24
+use utf8;
25
+use Encode;
26
+use CGI::Pretty qw( -no_xhtml *table ); # //HTML 4.01 Transitional//EN
27
+
28
+my $charsetConsole = 'UTF-8';
29
+my $charsetFile = 'UTF-8';
30
+
31
+binmode( STDIN, ":encoding($charsetConsole)" );
32
+binmode( STDOUT, ":encoding($charsetConsole)" );
33
+binmode( STDERR, ":encoding($charsetConsole)" );
34
+
35
+my $q = new CGI;
36
+$q->charset( $charsetFile );
37
+
38
+my $cginame = 'PrintEnv';
39
+
40
+printHeader();
41
+
42
+print $q->start_table( { '-summary' => 'ENV', '-border' => 1 } );
43
+print $q->Tr( $q->th( [ 'Key', 'Value' ] ) );
44
+foreach ( sort( keys( %ENV ) ) ){
45
+ if ( /^(GEOIP_|HTTPS|HTTP_|QUERY_|REMOTE_|REQUEST_|SERVER_(ADDR|NAME|PORT|PROTOCOL))/i ){
46
+ print $q->Tr( $q->td( [ $_, $ENV{$_} ] ) );
47
+ }
48
+}
49
+print $q->end_table();
50
+
51
+printFooter();
52
+
53
+exit;
54
+
55
+sub printHeader
56
+{
57
+ print $q->header();
58
+ print $q->start_html(
59
+ '-title' => $cginame,
60
+ '-lang' => 'ja-JP',
61
+ '-head' => [
62
+ $q->meta( { '-http_equiv' => 'Content-style-type', '-content' => 'text/css' } ),
63
+ $q->meta( { '-http_equiv' => 'Content-script-type', '-content' => 'text/javascript' } ),
64
+ ],
65
+ '-style' => [ { 'src' => '/take.css' }, ],
66
+ );
67
+ print $q->h1( $cginame );
68
+}
69
+
70
+sub printFooter
71
+{
72
+ print $q->end_html . "\n";
73
+}
74
+
75
+# EOF
76
+```
77
+
78
+## Text版
79
+- [PrintEnv_txt.cgi](http://www.takeash.net/cgi-bin/etc/PrintEnv_txt.cgi)
80
+
81
+```perl
82
+#!/usr/bin/perl
83
+# 環境変数の表示(テキスト版)
84
+
85
+use strict;
86
+use warnings;
87
+use utf8;
88
+
89
+print "Content-type: text/plain; charset=UTF-8\n\n";
90
+
91
+foreach ( sort( keys( %ENV ) ) ){
92
+ if ( /^(GEOIP_|HTTPS|HTTP_|QUERY_|REMOTE_|REQUEST_|SERVER_(ADDR|NAME|PORT|PROTOCOL))/i ){
93
+ print $_ . "\t" . $ENV{ $_ } . "\n";
94
+ }
95
+}
96
+
97
+# EOF
98
+```
99
+
100
+## IIS8用
101
+```perl
102
+#!/usr/bin/perl
103
+# 環境変数の表示
104
+
105
+use strict;
106
+use warnings;
107
+use utf8;
108
+use Encode;
109
+use CGI::Pretty qw( -no_xhtml *table ); # //HTML 4.01 Transitional//EN
110
+
111
+my $charsetConsole = 'UTF-8';
112
+my $charsetFile = 'UTF-8';
113
+
114
+#binmode( STDIN, ":encoding($charsetConsole)" );
115
+#binmode( STDOUT, ":encoding($charsetConsole)" );
116
+#binmode( STDERR, ":encoding($charsetConsole)" );
117
+
118
+my $encoder = find_encoding( $charsetConsole );
119
+if ( defined( $ENV{PERLXS} ) && $ENV{PERLXS} eq 'PerlIS' ){
120
+ print $encoder->encode( "HTTP/1.0 200 OK\n" );
121
+}
122
+
123
+my $q = new CGI;
124
+$q->charset( $charsetFile );
125
+
126
+my $cginame = '環境変数の表示';
127
+
128
+print $encoder->encode(makeHeader($q));
129
+
130
+my $output = '';
131
+$output .= $q->start_table( { '-summary' => 'ENV', '-border' => 1 } );
132
+$output .= $q->Tr( $q->th( [ 'キー', '値' ] ) );
133
+foreach ( sort( keys( %ENV ) ) ){
134
+ if ( /^(GEOIP_|HTTPS|HTTP_|QUERY_|REMOTE_|REQUEST_|SERVER_(ADDR|NAME|PORT|PROTOCOL))/i ){
135
+ $output .= $q->Tr( $q->td( [ $_, $ENV{$_} ] ) );
136
+ }
137
+}
138
+$output .= $q->end_table();
139
+print $encoder->encode($output);
140
+
141
+print $encoder->encode(makeFooter($q));
142
+
143
+exit;
144
+
145
+sub makeHeader
146
+{
147
+ my $q = shift or return;
148
+ my $ret = '';
149
+ $ret .= $q->header();
150
+ $ret .= $q->start_html(
151
+ '-title' => $cginame,
152
+ '-lang' => 'ja-JP',
153
+ '-head' => [
154
+ $q->meta( { '-http_equiv' => 'Content-style-type', '-content' => 'text/css' } ),
155
+ $q->meta( { '-http_equiv' => 'Content-script-type', '-content' => 'text/javascript' } ),
156
+ ],
157
+ '-style' => [ { 'src' => '/take.css' }, ],
158
+ );
159
+ $ret .= $q->h1( $cginame );
160
+ return $ret;
161
+}
162
+
163
+sub makeFooter
164
+{
165
+ my $q = shift or return;
166
+ my $ret = '';
167
+ $ret .= $q->end_html . "\n";
168
+ return $ret;
169
+}
170
+
171
+# EOF
172
+```
173
+
174
+## IIS6用
175
+```perl
176
+#!/usr/bin/perl
177
+# printEnv.pl
178
+# Linuxの場合は、EUC-JP,LFで保存
179
+
180
+print "Content-type: text/html\n\n";
181
+
182
+print <<EOL;
183
+<html>
184
+<body>
185
+%ENV
186
+<table border="1">
187
+<tr><th>key</th><th>value</th></tr>
188
+EOL
189
+
190
+foreach $key (sort keys(%ENV)){
191
+ printf("<tr><td>%s</td><td>%s</td></tr>\n", $key, $ENV{$key});
192
+}
193
+
194
+print <<EOL;
195
+</table>
196
+<br>
197
+%ALL_HTTP
198
+<table border="1">
199
+<tr><th>key</th><th>value</th></tr>
200
+EOL
201
+
202
+# IIS用
203
+@ALL_HTTP = split( "\n", $ENV{ "ALL_HTTP" } );
204
+%ALL_HTTP = ();
205
+foreach $line ( @ALL_HTTP ){
206
+ if ( $line =~ /([^:]+):(.*)\s*/){
207
+ $ALL_HTTP{ $1 } = $2;
208
+ }
209
+}
210
+foreach $key (sort keys(%ALL_HTTP)){
211
+ printf("<tr><td>%s</td><td>%s</td></tr>\n", $key, $ALL_HTTP{$key});
212
+}
213
+
214
+print <<EOL;
215
+</table>
216
+</body>
217
+</html>
218
+EOL
219
+
220
+exit();
221
+
222
+# EOF
223
+```
224
+
225
+# リンク
226
+- [MaxMind](http://www.maxmind.com/)
227
+ - [mod_geoip2 Apache module](http://dev.maxmind.com/geoip/mod_geoip2) EPEL リポジトリ
228
+ - [GeoLite Databases](http://www.maxmind.com/app/geolite)
... ...
\ No newline at end of file
Perl/\350\207\252\345\213\225\343\203\225\343\203\251\343\203\203\343\202\267\343\203\245(\343\203\220\343\203\203\343\203\225\343\202\241\343\203\252\343\203\263\343\202\260)\343\201\256\345\210\266\345\276\241.md
... ...
@@ -0,0 +1,21 @@
1
+# 自動フラッシュ(バッファリング)の制御
2
+```
3
+# 自動フラッシュ有効化 (バッファリングを無効化)
4
+$| = 1;
5
+
6
+$end = 10;
7
+
8
+for( $i=0; $i<=$end; $i++){
9
+ printf( "%d/%d\r", $i, $end );
10
+ sleep(1);
11
+}
12
+printf( "\n" );
13
+
14
+# 自動フラッシュ無効化 (バッファリングを有効化)
15
+$| = 0;
16
+
17
+for( $i=0; $i<=$end; $i++){
18
+ printf( "%d/%d\r", $i, $end );
19
+ sleep(1);
20
+}
21
+printf( "\n" );
... ...
\ No newline at end of file
Perl/\350\241\214\346\234\253\346\224\271\350\241\214\343\201\256\345\211\212\351\231\244.md
... ...
@@ -0,0 +1,27 @@
1
+# 行末改行の削除
2
+[[_TOC_]]
3
+
4
+## 概要
5
+- ファイルを読み込み、行末改行を一括削除する。
6
+- 「CRLF」「LF」のどちらでも対応できるようにする。
7
+
8
+## ソースコード
9
+```
10
+use strict;
11
+use utf8;
12
+
13
+my $fin = "input.txt";
14
+
15
+my @file;
16
+
17
+open( IN, "<:utf8", $fin ) || die( "can't open '" . $fin . "'.\n" );
18
+@file = <IN>;
19
+close( IN );
20
+
21
+$file[ 0 ] =~ /(\s+)$/;
22
+$/ = $1;
23
+chomp( @file );
24
+
25
+# 実際の処理
26
+
27
+# EOF
... ...
\ No newline at end of file