{{mobile}}
!!!PERLに関してメモ
!!PERL構文
 if (EXPR) BLOCK
 if (EXPR) BLOCK else BLOCK
 if (EXPR) BLOCK elsif (EXPR) BLOCK ... else BLOCK
 unless (EXPR) BLOCK
 unless (EXPR) BLOCK else BLOCK
 unless (EXPR) BLOCK elsif (EXPR) BLOCK ... else BLOCK
 LABEL while (EXPR) BLOCK
 LABEL while (EXPR) BLOCK continue BLOCK
 LABEL until (EXPR) BLOCK
 LABEL until (EXPR) BLOCK continue BLOCK
 LABEL for (EXPR; EXPR; EXPR) BLOCK
 LABEL foreach VAR (LIST) BLOCK
 LABEL foreach VAR (LIST) BLOCK continue BLOCK
 LABEL BLOCK continue BLOCK
 EXPR は「条件」として参照されます。 その真偽値が修飾子の振る舞いを決定します。
!!UTF8の文字変換
下記は、UTF8以外の文字で書かれたスクリプトの場合で
フラグ付きUTF8を使用する場合、
{{code Perl,0,0
 use Encode qw/ from_to decode encode /;#// utf8用(decodeファイル読みencode書込)
 open (IN,$outlog) || die "open error $outlog $!";
 @datax=<IN>; #//euc-jpで書かれたファイル
 close IN;
 foreach ( @datax ) {
   next if($_ =~ m/^\x23/);  #//comment delete
   $jj=decode("euc-jp", $_); #//euc-jpからutf8に変換(F付)
   $jj=encode("shiftjis", $jj); #//utf8からshiftjisへ変換
   print ("$jj\n");
 }
}}
フラグ付きUTF8を使用しない場合、
{{code Perl,0,0
 use Encode qw/ from_to decode encode /;#// utf8用(decodeファイル読みencode書込)
 open (IN,$outlog) || die "open error $outlog $!";
 @datax=<IN>; #//euc-jpで書かれたファイル
 close IN;
 foreach ( @datax ) {
   next if($_ =~ m/^\x23/);  #//comment delete
   from_to($_,'euc-jp','shiftjis'); #//UTF8フラグなし文字変換（euc-jpからshiftjisへ変換）
   print ("$_\n");
 }
}}


ファイルへの出力、次のように一度UTF8に変換してから希望のコードで書き出す。
ただし、UTF8からUTF8へは多重になるので変換しない。その代わりUTF8フラグなしにする。
{{code Perl,0,0
 $jj=decode("euc-jp", $_); #//フラグ付きUTF8
 #open(OUT, ">:encoding(shiftjis)", "$filename"); #//sjisに変換
 #open(OUT, ">:encoding(euc-jp)", "$filename");   #//eucに変換
 #open(OUT, ">:encoding(jis)", "$filename");      #//jisに変換
 open(OUT, ">:utf8", "$filename"); #utf8で出力（utf8フラグなし）
 print OUT $jj;
 close OUT;
 または
 open(OUT,">$filename");
 binmode OUT,":encoding(jis)";
 print OUT,$jj;
 close OUT;
}}

注意：utf8 フラグ付きのマルチバイト文字列をそのまま出力(print)しようとすると警告がでます。(Wide charactor error..)
注意：utf8 フラグ付きでは、length($str_utf8) は、正常にカウントされる。フラグなしでは、バイト数としてカウントされる。正規表現も正常に機能する。

!!UTF8の文字変換(プラグマ)
use utf8; を使う場合、つぎの様に入出力およびエラー出力コードを指定する。
特に、これを指示しないとprint の場合、Wide charactor error..　になります。
{{code Perl,0,0
 use utf8; #//このスクリプトはutf8で書いていますという意味
 my $charset = 'utf8'; #//このスクリプトはutf8の指示
 my $outchar = 'utf8';
 my $inpchar = 'utf8';
 
 binmode STDOUT, ":utf8" if($outchar eq 'utf8'); #//フラグを外してから出力
 binmode STDERR, ":utf8" if($outchar eq 'utf8'); #//フラグを外してから出力
 binmode STDIN,  ":utf8" if($inpchar eq 'utf8'); #//フラグを外したまま入力
 
 $str = "こんいちは"; #//フラグ付き文字列
 $encode  =$outchar;
 $fromcode=$charset; 
 if($encode && lc($encode) ne lc($fromcode)){#//同じコードでない場合
   Jcode::convert(\$str, lc($encode),lc($fromcode)); #//指定の日本語コードに変換
 }
 print $str; #//stdoutでフラグ外して出力
}}

ファイルへの入出力は、UTF8の文字変換を参照してください。

{{code Perl,0,0
 #//WEBからの取り込み(STDINからUTF8フラグなしで)
 if ($ENV{'REQUEST_METHOD'} eq "POST"){read(STDIN, $buf,$ENV{'CONTENT_LENGTH'});}
 else { $buf = $ENV{'QUERY_STRING'}; }
 foreach ( split(/&/, $buf) ) {
    ($key, $val) = split(/=/);
    $val =~ tr/+/ /;
    $val =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack('H2', $1)/eg;
    utf8::decode($val); #//UTF8フラグををつける
    $in{$key} = $val;
 }
}}


!!UTF8スクリプトの書き始め
SHIFTJISのクッキーまたはファイルを取得した場合は内部コード（UTF8フラグ付き）に変換する
UTF8のINPUTデーター、クッキーまたはファイルを取得した場合は内部コード（UTF8フラグ付き）に変換する
{{code Perl,0,0
 use utf8; #//スクリプトはUTF8で書いてます
 use CGI::Carp qw(fatalsToBrowser);
 use Encode qw(from_to encode decode);
 binmode STDOUT, ':utf8'; #//内部コードをUTF8に変換
 binmode STDERR, ':utf8'; #//内部コードをUTF8に変換
 binmode STDIN,  ':utf8'; #//UTF8コードを内部コードに変換
 
 use strict;
 use warnings;
 use Data::Dumper; #for use utf-8用
  {
    package Data::Dumper; 
    sub qquote {return shift;}
  }    
  $Data::Dumper::Useperl = 1; 
 ------------------------------------------------------------
 
 #//各内部コードへの変換
 @array_item = map{decode('shiftjis', $_) } @array_item; #//Shiftjisを内部コードに変換
 @array_item = map{encode('shiftjis', $_) } @array_item; #//内部コードをShiftjisに変換
 utf8::decode($msg1); #//UTF8を内部コードに変換
 utf8::encode($msg1); #//内部コードをUTF8に変換
 #//POSTとGETメソッドの両方からの入力 %keyss
 my %keyss = map{$_,decode('utf-8',$keyss{$_})} keys %keyss;#//UTF8フラグなしを内部コードに変換
 my $msg3=&get_gengou2('2015');#// 返値："平成27年"この関数のスクリプトコードはEUCです。
 $msg3=decode('euc-jp',$msg3);#// EUC-JPを内部コードに変換
 #//ファイルへの入出力はSHIFJISのみなら
 use open ":encoding(shiftjis)"; #//すべての入出力ファイルはSJIS指定
 #//そのあとの個別指定
 open(my $fh, ">:encoding(UTF-8)", "filename");
 close($fh);
 #//内部コードでなかったら内部コードに変換
 my $utf8 = Encode::is_utf8($bytes) ? $bytes : decode_utf8($bytes);

 
 


}}
!!BOMについて
BOM付とBOM付き出ないでない文字コード（UTF8）他にもあるが。
−（全角ハイフン）のコードは、
jis(215D),EUC(A1DD),SJIS(817C)-->BOM付き(EFBC8D) BOMなし(E28892) 
〜（全角チルダ）（波ダッシュ）のコードは、
jis(2141),EUC(A1C1),SJIS(8160)-->BOM付き(EFBD9E：全角チルダ) BOMなし(E3809C:波ダッシュ) 
Windowsでは、（全角チルダ:EFBD9E）が採用されている。

BOMは、文字の最初に、またはUTF8ファイルの最初に、（EFBBBF）が記入されている。

スクリプトはBOMなしでの保存が望ましい。
データは、入力の時はBOMなしを想定して、出力時は、BOMなしで書き出される。

PERLでの変換
{{code Perl,0,0
 $line = jcode($line, $read_code)->h2z->utf8;
 $line =~ s/\xE2\x88\x92/\xEF\xBC\x8D/g; #// ハイフン
 $line =~ s/\xE3\x80\x9C/\xEF\xBD\x9E/g; #// チルダ
}}

""UTF-8で符号されたテキストデータはエンディアン(メモリーに記憶するときの羅列方法)に関わらず同じ内容になるので、UTF-8で符号化されていることが確定しているのならバイトオーダーマーク (英: Byte Order Mark。以下BOM) を付加する必要はない。しかし、一部のテキスト処理アプリケーション (エディタなど) では、作成したテキストデータの先頭にBOMを付加する (付加するかどうかを選択できるものもある)。付加する場合は、EF BB BF (16進。U+FEFFのUTF-8での表現) をデータの先頭に付加する。なお、BOMありの方をUTF-8、なしの方をUTF-8Nと呼ぶこともあるが、このような呼び分けは日本以外ではほとんど知られておらず、また公的規格などによる裏付けもない。このため、UTF-8という呼び名を使っていれば情報交換の相手が文書先頭にBOMがあると見なすと期待すべきではないし、いっぽう、UTF-8Nという呼び名は情報交換の際に用いるべきではない。
!!Windows配下のPERLからIEなどの標準に指定したブラウザーを呼び出すには
{{code Perl,0,0
 $url = "http://abc/foo.com?m=84&po=567";
 $url =~ s/&/\^&/g;
 system("start $url");
}}

!!Perlから指定URLをGETするには
{{code Perl,0,0
 use LWP::Simple;
 $url="http://abc/foo.com?m=84&po=567"
 $str1 = LWP::Simple::get("$url") or die "cannot get content from $url";
}}
!!Host名をGetする
{{code Perl,0,0
 #// LOCALHOST　の場合、'localhost'を返す
 my $httphost  = $ENV{'HTTP_HOST'};
 $httphost ="" unless($httphost);
}}
!!@ARGV の引数について
次のCGIスクリプトを
{{code Perl,0,0
 print "Content-type: text/plain\n\n";
 print "ARGV--------------------------\n";
 my $ii=0;
 foreach (@ARGV) {
  print "($ii)$_\n";
  $ii++;
 }
}}
DOS画面で実行した結果
{{code Text,0,0
 C:\>perl testargcv.cgi key1=value1^&key2=value2^&key2=value3 w tt^&hhd^&ttt
 Content-type: text/plain
 
 ARGV--------------------------
 (0)key1=value1&key2=value2&key2=value3
 (1)w
 (2)tt&&hhd&ttt
}}

ブラウザーで実行した結果
{{code Text,0,0
 http://hoge.com/testargcv.cgi?key1=value1&key2=value2&key2=value3+w tt&hhd&ttt
 ARGV--------------------------
 (0)key1=value1&key2=value2&key2=value3
 (1)w
 (2)tt&hhd&ttt
}}

ARGVからハッシュに変換（ブラウザー＆DOS両方から引数を得ることができます）
{{code Perl,0,0
 my (@tt,@tt1,%tt);
 foreach (@ARGV) {
   @tt1 = map{if(m/([^=]+)=+(.+)/){($1,$2)}else{s/=+//g;($_,undef);}}split(/&/,$_);
   @tt = (@tt,@tt1);
 }
 %tt = @tt;
 print Data::Dumper->Dump( [\%tt],[qw(*tt)]),"\n";
}}

ブラウザー、DOSで実行した結果
{{code Text,0,0
 http://hoge.com/testargcv.cgi?key1=value1&key2=value2&key2=value3+w tt&hhd&ttt
 C:\>perl testargcv.cgi key1=value1^&key2=value2^&key2=value3 w tt^&hhd^&ttt
 %tt = (
        'w' => undef,
        'key2' => 'value3',
        'ttt' => undef,
        'key1' => 'value1',
        'hhd' => undef,
        'tt' => undef
       );
}}
!!use CGI の引数について
次のCGIスクリプトを
{{code Perl,0,0
 use CGI;
 my $query = new CGI; #//この時点でPOST/GET,Cookie取得を行う
 print "KEY---hash-------------------\n";
 my %keys;
 %keys= $query->Vars; # 全てのパラメータ名取得（perl5以上）
 $ii=0;
 foreach (keys %keys){
   $keys{$_}=~ s/\0/|/g; 
   print "($ii)$_ -> $keys{$_}\n";
   $ii++;
 }
 print "KEY2-------------------------\n";
 $ii=0;
 my @jj=$query->param('key2');
 foreach (@jj){
   $_=~ s/\0/|/g; 
   print "($ii)$_\n";
   $ii++;
 }
 
 print "KEY---param-------------------\n";
 $ii=0;
 foreach ($query->param()){
   my $a=$query->param($_); # パラメータ値取得
   $a=~ s/\0/|/g; 
   $keys{$_}=$a; #//Varsに習って%keysに格納する
   print "($ii)$_ [$a]\n";
   $ii++;
 }
}}

DOS画面で実行した結果（空白で区切、その後＆で区切られている）
{{code Text,0,0
 C:\>perl testargcv.cgi key1=value1^&key2=value2^&key2=value3 w tt^&hhd^&ttt
 Content-type: text/plain
 
 KEY----Hash-------------------
 (0)w ->
 (1)key2 -> value2|value3
 (2)ttt ->
 (3)key1 -> value1
 (4)hhd ->
 (5)tt ->
 KEY2--------------------------
 (0)value2
 (1)value3
 KEY--param--------------------
 (0)key1 [value1]
 (1)key2 [value2]
 (2)w []
 (3)tt []
 (4)hhd []
 (5)ttt []
 KEY---array-------------------
 (0)key1
 (1)value1
 (2)key2
 (3)value2|value3
 (4)w
 (5)
 (6)tt
 (7)
 (8)hhd
 (9)
 (10)ttt
 (11)
}}

ブラウザーで実行した結果（＆で区切られている）
{{code Text,0,0
 http://hoge.com/testargcv.cgi?key1=value1&key2=value2&key2=value3+w tt&hhd&ttt
 KEY---- Hash-----------------
 (0)key2 -> value2|value3 w tt
 (1)ttt -> 
 (2)key1 -> value1
 (3)hhd -> 
 KEY2-------------------------
 (0)value2
 (1)value3 w tt
 KEY--param--------------------
 (0)key1 [value1]
 (1)key2 [value2]
 (2)hhd []
 (3)ttt []
 KEY---array-------------------
 (0)key1
 (1)value1
 (2)key2
 (3)value2|value3 w tt
 (4)hhd
 (5)
 (6)ttt
 (7)
}}

補足 実用スクリプト
{{code Perl,0,0
 #//C:\>perl testargcv.cgi key1 key2 key3 のようにキーのみで値がひとつもない場合
 #//次の様に'keyword'のhashキーに格納されます。
 #//それを %keyss に改めて分けて格納しています。
 my $q = new CGI; #//この時点でPOST/GET,Cookie取得を行う
 my %keyss= $q->Vars;
 if (exists $keyss{'keywords'}){
   foreach (split(/\0/,$keyss{'keywords'})){
     $keyss{$_}="";
   }
 }
 #//
 #// param() の場合処理
 #//
 my %keyss;
 foreach  ($q->param()){
   if ($_ eq 'keywords'){
      foreach ($q->param($_)){
          $keyss{$_}="";
      }
   }else{
      my $a=$q->param($_); # パラメータ値取得
      $a=~ s/\0/|/g; 
      $keyss{$_}=$a; #//Varsに習って%keyssに格納する
   }
 }
}}

!!CGI の引数について
次のCGIスクリプトを(モジュールも使わない場合)環境変数$ENV{'QUERY_STRING'}使う
{{code Perl,0,0
 print "KEY3-------------------------\n";
 # query の取得
 if (exists $ENV{'REQUEST_METHOD'} and $ENV{'REQUEST_METHOD'} eq "POST") {
   read(STDIN, $buffer, $ENV{'CONTENT_LENGTH'});
 }
 else {
   $buffer = exists $ENV{'QUERY_STRING'} ? $ENV{'QUERY_STRING'}:"";
 }
 # query の分解
 my ($name, $value);
 my %in;
 foreach my $pair (split(/&/,$buffer)) {
   ($name, $value) = split(/=/, $pair);
   $value =~ tr/+/ /;
   $value =~ s/%([0-9A-Fa-f][0-9A-Fa-f])/pack('H2', $1)/eg;
   if(exists $in{$name}){ $in{$name} .= "\t".$value; }
   else{  $in{$name} = $value;}
 }
 $ii=0;
 foreach (keys %in){
   print "($ii)$_ [$in{$_}]\n";
   $ii++;
 }
}}
ブラウザーで実行した結果
{{code Text,0,0
 http://hoge.com/testargcv.cgi?key1=value1&key2=value2&key2=value3+w tt&hhd&ttt
 KEY3-------------------------
 (0)key2 [value2\tvalue3 w tt]
 (1)ttt []
 (2)key1 [value1]
 (3)hhd []
}}

DOS画面で実行した結果では何も出ない
＠ARGV を使って取り込む必要有り

!!数秒以内のキー入力を求める。
次のスクリプトです。
{{code Perl,0,0
 use Term::ReadKey;
 while(1){
  print("処理中止は3秒以内にいずれかのキーを押します。");
  my $char = ReadKey(3);
  last if defined $char;
  ....
 }
}}

Readkeyの引数は、
　０：改行キー待ち
　-１：キー待ちなし
　＞０：指定時間


!!代入初期値設定
配列にリスト値を代入、参照、配列の箱中身を要素(Element)といいます。配列の箱番号を要素番号(Index)といいます。
展開とは、変数名($dat1)の内容を代入することです。展開できないことは、$dat1がそのまま代入されます。
リファレンスとは、配列箱の住所です。配列箱は長屋（家）全体です。配列箱番号は、長屋の各部屋番号（０からはじまる）です。
配列名（配列箱）は、長屋の家の名前（はなまる荘）
{{code Perl,0,0
 #//いくつかの文字列を（）で括るとリストになり、それに名前をつけると配列名、
 #//リストの始まりから番号を暗黙的に０から付けるとその呼び名は要素[部屋]番号、その内容は要素です
 #//リストの集まりは配列だから、(split(',',"1,2,3,asdcf"))[3] という使い方もできます。 結果'asdcf'
 #// 同様に　qw(1, 2, 3, asdcf)[3] 結果 'asdcf'
 #// 同様に配列にはできない、リストでは　(@{ [1,2,3,"asdcf"] })[1,3]ができます。結果 '2','asdcf'
 @array = (); #//空リストは配列の中身を空にします。
 @array = (1, 2, 3, "asdcf",$dat1, $dat2); #//カンマで区切らてた内容の羅列をそれぞれの配列の箱に代入します。
 @array = qw(1 2 3 asdcf); #//qw 演算子は空白で区切ってリストを返す。展開できない
 $fog0 = $array[0]; #//部屋番号０の値（中身）を代入します。
 $fog1 = $array[1];
 $refarray = \@array;  #//リファレンス
 $fog2 = $refarray->[2]; #//住所->部屋番号２の中身を代入します。
 @array2 = @array; #//配列全体のコピー複写
 push(@array2,@array1); #//配列全体の追加
 push(@{$array2[0]},"hatu") #//２次元配列への指定要素番号への追加
 @array2 = map{$_}@array; #//条件付き配列複写｛｝の中を条件付きに変更
 @array2 = @array[0..2]; #//配列のスライス 0,1,2の要素をarray2へ複写
 foreach(@{$refarray}){.....;} #//配列全体をリスト展開して、ひとつずつ取り出す
 foreach(@array){.....;}       #//配列全体をリスト展開して、ひとつずつ取り出す
 foreach my $member (1, 2, 3, "asdcf",$dat1, $dat2){...:} #//リストひとつずつ取り出す
 foreach my $member (@{ [1, 2, 3, "asdcf"] }){...;} #//@{中身}は中身のリファレンス、無名配列をリスト展開します。
 &subxx(\@array); #//サブルーチンに渡す。住所を渡す。
 $count = scalar(@array);      #//要素の数、部屋の数
 $count = scalar(@{$refarray});#//要素の数
 #//ほかの呼び出し、代入例
 my @a = ('foo','bar','zot','qui');
 my @x = @a[0,2];
 my @y = ($a[0],$a[2]);
 my @xy = (0,3); #//配列の番号
 my @z = @a[@xy];
 print "@x , @y , @z , @a\n";
 @a[1,2]=('aaa','bbb'); #//入れ替え
 print "@x , @y , @z . @a\n";
 #//結果
 foo zot , foo zot , foo qui , foo bar zot qui
 foo zot , foo zot , foo qui . foo aaa bbb qui
}}

ハッシュにキー値を代入、参照
{{code Perl,0,0
 undef %hash; #//ハッシュすべてのKEYと値を削除します。
 %hash = ( "a"=>1, "b"=>2, "c"=>3, "data1"=>"saa");
 %hash = ( "a",1, "b",2, "c",3, "data1","saa");
 %hash = qw(a 1 b 2 c 3 dat1 saa);
 $fog0 = $hash{'a'}; #//KEY{a}の値を取得
 $fog1 = $hash{'b'}; #//KEY{b}の値を取得
 $refhash = \%hash;    #//リファレンス（参照値）
 $fog2 = $refhash->{'c'}; #//KEY{c}の値を取得
 %hash1 = %hash; #//ハッシュ全体のコピー複写
 foreach(keys %{$refhash}){......;} #//ハッシュ全体を表す
 foreach(keys %hash){.....;} #//ハッシュ全体を表す
 &subyy(\%hash); #//サブルーチンに渡す。
 $count = scalar( keys %hash );        #//要素の数
 $count = scalar( keys %{$refhash} );  #//要素の数
 $count = keys %hash;        #//要素の数、受け側がスカラーの場合
 $count = keys %{$refhash};  #//要素の数、受け側がスカラーの場合
 undef $hash{'b'}; #//KEY B の値 2 をundefにする。
 delete $hash{'b'};#//KEY B とその値 2 を削除する。
 undef %{$refxxx_hash} unless $refxxx_hash; #//HASHの初期化
 %marge = ( %hash1, %hash2 ); #//ハッシュの併合
 $refmarge = { $refhash1, $refhash2 }; #//ハッシュの併合
 $refhash = {}: #//リファレンスで空ブレースで初期化
 $chk1 = grep /$kensaku/,@hash{keys %hash}; #//ハッシュスライス(ハッシュの内容検索)
}}

サブルーチンの受け取り側（配列、ハッシュ）参照
値渡しは、呼び出し元の変数の内容はサブルーチン内では変化しない。
参照渡しは、呼び出し元の変数の内容はサブルーチン内で処理により変化します。
{{code Perl,0,0
 &subxxyy(\@array,\%hash);  #//呼び出し（引数の参照渡し）
 sub subxxyy{ #//サブルーチン側
    my ($arrayref,$hashref) = @_; #//引数の受取り
    my $dat0=@$arrayref[0];
    my $dat1=$$arrayref[2];
    my $dat2=$arrayref->[3];
    my $dat3=$hashref->{'a'};
    my $dat4=$$hashref{'c'};
    foreach(@$arrayref){.....;} #//全体
    foreach(keys %{$hashref}){.....;} #//全体
    $arrayref->[4]="ssss";  #//配列要素の書き換え
    $hashref->{'data1'}="ddddd";  #//ハッシュ要素の書き換え
    return;
 }
 &subzz('asa'=>'teru','yoru'=>'tuki'); #//ハッシュを引数として（引数の値渡し）
 sub subzz{
    my %has = @_;
    my $a = %has{'asa'};
    my $b = %has{'yoru'};
 }
 
 @kotae = &subyy(@arrayc); #//配列の値渡し、この場合は必ず引数はひとつにすべきです
 sub subyy{
    my @hairetu = @_;
    処理
    return(@hairetu);
 }
 
 %kotae = &subyy(%hashc); #//ハッシュの値渡し、この場合は必ず引数はひとつにすべきです
 sub subyy{
    my %san = @_;
    処理
    return(%san);
 }
}}

無名配列[]、ブラケットで囲めば無名配列を生成
{{code Perl,0,0
 $refarray = [1, 2, 3, "asdcf",$dat1, $dat2];
 #//参照：配列全体 @{$refarray} なので @{[1, 2, 3, "asdcf",$dat1, $dat2]};も可能
}}
無名ハッシュ{}、ブレースで囲めば無名ハッシュを生成
{{code Perl,0,0
 $refhash  = {"a"=>1, "b"=>2, "c"=>3, "data1"=>"saa"};
}}

無名配列、無名ハッシュのサブルーチン側の引数受け取り
{{code Perl,0,0
 sub tref{
  my ($a)=@_;
  return unless (defined $a);
  if(ref $a eq 'ARRAY'){
    foreach (@$a){
      print "$_"."-ARRAY ";
    }
  }elsif(ref $a eq 'HASH'){
    foreach (keys %$a){
      print "$_:$a->{$_}"."-HASH ";
    }
  }elsif(ref $a eq 'SCALAR'){
    print "$$a"."-Scalar ";
  }else{
    print "$a";
  }
  print "(".ref($a) ."---REF)\n";
 }
}}

無名配列、無名ハッシュのサブルーチン呼び出し側
{{code Perl,0,0
 my $trpew="S1";
 my @ar = ("A3","A4");
 my %ha = ("H3"=>"789", "H4"=>"000");
 &tref(["A1","A2"]);
 &tref({"H1"=>"123","H2"=>"456"});
 &tref(\$typew);
 &tref(\@ar);
 &tref(\%ha);
 &tref("MOJI");
 
 結果
 A1-ARRAY A2-ARRAY (ARRAY---REF)
 H1:123-HASH H2:456-HASH (HASH---REF)
 S1-Scalar (SCALAR---REF)
 A3-ARRAY A4-ARRAY (ARRAY---REF)
 H4:000-HASH H3:789-HASH (HASH---REF)
 MOJI(---REF)
}}

!リファレンスにおいてハッシュの要素がハッシュと配列の場合
{{code Perl,0,0
 my %hb = ("H3"=>{'title'=>"789", 'link'=>"000"},
           'H4'=>['A123','A456']
 );
 my $refa = \%hb;
 print "$refa->{'H3'}->{'title'},";
 print "$refa->{'H4'}->[0],";
 print scalar @{$refa->{H4}},"\n";
 結果 789,A123,2
}}

!リファレンスにおいて配列の要素が配列の場合（2次元配列は2階建てアパートです）
２次元配列を行（横行）と列（縦列）に考えた場合
{{code Perl,0,0
 #//初期設定　(行[列,列,列],行[列,列])
 @list = (['a','b','c'],['000','111','222','333']); #//配列へ代入
 $refarray = \@list;
 $refarray = [['a','b','c'],['000','111','222','333']]; #//直接リファレンスへ
 #//代入　行の追加
 push (@list,['x','y','z']);
 push (@list,['666','777','888','999']);
 #
 print $list[1][2]; #//結果 222
 print $refarray->[1][2]; #// 結果 222
 push (@{$list[0]},'d'); #//配列（カラム列）へ追加
 push (@{$refarray->[0]},'d'); #//リファレンス配列（カラム列）への追加
 #その配列の要素の数
 my $cnt1 = scalar(@{$refarray->[1]});
 #その配列の取りだし
 foreach my $dat (map{@$_}$refarray->[1]){
  print Dumper $dat;
 }
 print Dumper $refarray,$cnt1;
 結果$VAR1 = '000'; $VAR1 = '111'; $VAR1 = '222'; $VAR1 = '333'; 
 $VAR1 = [ [ 'a', 'b', 'c' ], [ '000', '111', '222', '333' ] ]; 
 $VAR2 = 4; 
}}

文字列から2次元配列に代入する
\nで区切って $team2[0]->[0] がAAA、$team2[0]->[1] が010、代入される
{{code Perl,0,0
 my $content="AAA,010\nBBB,023\nCCC,333\n";
 push (@team2,map{[split (/,/,$_)]}split(/\n/,$content));
}}

２次元配列全体の表示
ここで使用されているMYは、各々のforeachの内側のみで有効です。これを局所変数といいます。
{{code Perl,0,0
 foreach my $ref (@{$refarray}){ #//横行の読出し
  foreach my $ref2 (@{$ref}){ #//その行内の縦列の読出し
   print $ref2,;
  }
 }
}}
!二次元配列の一つの要素を1次元配列にしてコピー
{{code Perl,0,0
 my @array1=@{ $array2[0] }; #// @{ 2次元配列[要素番号]=>1次元配列リスト }取り出し
}}
!二次元配列の各要素をカンマで整列させる
{{code Perl,0,0
 my @pmt = map{[ map{split(/,/,$_) } @{$_} ]}(["a,e,r","f,d,s","g"],["w","t,s,a","y"]);
 同様に、push (@pmt,map{[map{split(',',$_)}@{$_}]}(["a,e,r","f,d,s","g"],["w","t,s,a","y"]));
 print Dumper \@pmt;
 $VAR1 = [['a','e','r','f','d','s','g'],['w','t','s','a','y']];
 #他に
 push (@pmt,map{ map{ [split(',',$_)] }@{$_} }(["a,e,r","f,d,s","g"],["w","t,s,a","y"])
 $VAR1 = [['a','e','r'],['f','d','s'],['g'],['w'],['t','s','a'],['y']];
}}
!配列の要素がハッシュの場合ハッシュ要素を検索してその値を取り出す
$#array は、配列最大要素を返す。次の場合７を返す、scalar(@array)は８を返す
次の場合、GREPはマッチした要素を返す。
下の場合は、検索文字'tokyo'で該当箇所を抽出しています
{{code Perl,0,0,
 my @array = ({'name'=>"asahi",'address'=>"nigata",'color'=>"red"},{'name'=>"hirumae",'address'=>"tokyo",'color'=>"blue"});
 my $refarray = \@array;
 my @ans   = grep({  $_->{'address'} eq 'tokyo'  }@{$refarray});
 print Dumper \@ans;
 結果 $VAR1 = [ { 'color' => 'blue', 'name' => 'hirumae', 'address' => 'tokyo' } ]; 
}}
!ハッシュの要素を大きい順にソートして2次元配列に入れる
{{code Perl,0,0,
 my %kkaz3 = ('c'=>'3','a'=>'1','b'=>'2','e','5');
 my @ddd = map { [$_,$kkaz3{$_}]}(sort{$kkaz3{$b}<=> $kkaz3{$a}}keys %kkaz3);
 結果 = [ [ 'e', 5 ], [ 'c', 3 ], [ 'b', 2 ], [ 'a', 1 ] ]; 
}}
!ハッシュの内容を配列に変換(カンマ区切り)
{{code Perl,0,0,
 my @array = [map{qq("$_","$ref_hdata->{$_}")}sort keys %{$ref_hdata}]
}}
!ハッシュへの初期設定
{{code Perl,0,0,
 sub get_colorcodelist{
  my $col =qq(
  aliceblue,#f0f8ff,antiquewhite,#faebd7,
  aqua,#00ffff,
  green,#008000,
  );
  my ($key,%colorcode);
  foreach(split(",",$col)){
     $_=~s/\s*//g;
     next unless $_;
     ($ix++%2 == 0)?$key=$_:$colorcode{$key}=$_;
  }
  return (%colorcode);
 }
}}
!ハッシュの要素が配列の場合の配列への追加
{{code Perl,0,0,
 my %ans2;
 push(@{$ans2{'red'}},@array)
}}
!２次元ハッシュの作成例
{{code Perl,0,0,
 my @ar1 = ('qwe','wr','ee');
 my %hash = ( 'A1' => {"a"=>1, "b"=>2, "data1"=>"saa"} );#作成
 $hash{'A2'} = {"q"=>1, "w"=>2, "data2"=>"aha"};#//追加
 $hash{'A1'}->{'b'} = 32; #// 変更
 #$hash{'C1'} = [@ar1]; #//配列追加方法１
 @{$hash{'C1'}} = @ar1; #//配列追加方法２
 push(@{$hash{'C1'}},'total'); #//配列へ要素追加
 print Data::Dumper->Dump([\%hash],[qw(*hash)]); 
 結果　%hash = ('A1' => {'a' => 1,'b' => 32,'data1' => 'saa'},
 		'A2' => {'data2' => 'aha','q' => 1,'w' => 2},
 		'C1' => ['qwe','wr','ee','total']);
 
}}
!２次元配列を昇順ソートする
@adatの各要素の頭４桁を抽出して昇順ソートした結果を返す
{{code Perl,0,0,
 my @adat = [ [0,'0','9','2','2','3','9','2'], [0,'9','9','3','3','5','3','7'], [0,'9','3','1','7','9','0','0']];
 my @aaf = sort{$a->[0] <=> $b->[0] or $a->[1] <=> $b->[1] or $a->[2] <=> $b->[2]}map{@{$_}}@adat;
 print Data::Dumper->Dump([\@aaf],[qw(*aaf)]);
 結果：@aaf = ([0,0,9,2,2,3,9,2],[0,9,1,3,3,5,3,7],[0,9,3,1,7,9,0,0]);
}}
!配列の要素が配列のリファレンスの場合
{{code Perl,0,0,
 my (@waku4,@waku3,@waku2,@waku1);
 my (@in4,@in3,@in2,@in1);
 my @wakux   =(\@waku4,\@waku3,\@waku2,\@waku1);
 my @inx     =(\@in4,\@in3,\@in2,\@in1);
 ...
 map{ @{$wakux[$_]}=&keisan($inx[$_]) }(0 .. scalar(@inx)-1);
}}
!サブルーチンの受け取り側の処理
{{code Perl,0,0,
 #//呼び出し例
 &yobi(['sai']);
 &yobi('sai');
 &yobi(\@array);
 #//サブルーチン側
 sub yobi{
    my ($cdata,$cdata2)=@_; 
    my $refdata = (ref ($cdata) eq 'ARRAY' )?$cdata:($cdata)?[split(/,/,$cdata)]:[]; #//[配列]か"文字列,文字列,,,"
    my $reflabel = (ref ($cdata2) eq 'HASH'  )?$cdata2:($cdata2)?{split(/,/,$cdata2)}:{};#//{ハッシュ}か"キー文字列"
    処理
    return;
 }
}}
!条件付き配列要素の削除
{{code Perl,0,0,
    for(my $i=0;$i<scalar(@array);$i++){
        if(   ...   ){splice(@array,$i--,1);next;}
        ....
    }
}}
!配列の各要素のデーター整理（ファイルから読んだ一行ごとのデーター整理）
{{code Perl,0,0,
sub readdata{
    my ($cdata)=@_;
    my $refdata = (ref ($cdata) eq 'ARRAY' )?$cdata:($cdata)?[split(/,/,$cdata)]:[]; #//[配列]か"文字列,文字列,,,"
    my @ans;
    foreach my $dat (@$refdata){ 
        next if($dat =~ /^\x23/);#//コメント削除
        $dat =~ s/,/\t/g;
        push (@ans,$dat);
    }
    return(@ans):
}
}}
!リファレンスのまとめ
*配列 \@refarray
**参照 @$refarray,{{color red,@{$refarray} }}
*配列要素 \$refarray[index]
**参照 $$refarray[index],{{color red,$refarray->[index]}}
*ハッシュ \%refhash
**参照 %$refhash,{{color red,%{$refhash} }}
*ハッシュ要素 \%refhash{index}
**参照 $$refhash{index},{{color red,$refhash->{index} }}
*スカラー \$refscalar
**参照 $$refscalaer,{{color red,${$refscalaer} }}
*サブルーチン \&refsub
**参照 &$refsub,{{color red,&{$refsub} }}
!!指定フォルダーのファイル名リストの取得
{{code Perl,0,0
 my $datafiledir="./"; my @filelist;
 opendir(DIR,"$datafiledir") && (@filelist = readdir(DIR), closedir(DIR));
 if(scalar (@filelist) >= 0){ }
 
}}

!!偽と真の判定
""一般的に 0 と "" と '' と "0" は偽、それ以外は真、undef(未定義)で偽
""if,while,untilでは、undef,0,"",'',"0"　は偽、それ以外は真。
""defined では、undef(未定義)は偽、それ以外は真。
""for では、undefは真。
{{code Perl,0,0
 my $test;
 #//$TESTの値が定義されていないならばundefをPrintする。
 print "undef" unless defined $test;
 #//$TESTの値の評価が偽ならば偽をPrintする。
 print  $test ? "真":"偽";
 結果 undef偽
 my @test;
 print "undef" unless defined $test[0];
 print  $test[0] ? "真":"偽";
 結果 undef偽
 my %test;
 print "undef" unless defined $test{0};
 print  $test{0} ? "真":"偽";
 結果 undef偽
 my $test="0";
 print "undef" unless defined $test;
 print  $test ? "真":"偽";
 結果 偽
}}
""PERLでは論理演算の結果、偽(false)とは論理値""で、真(true)とは論理値１である。（boolean）
{{code Perl,0,0
 my $test;
 $test=("" eq "");
 print "undef" unless defined $test;
 print  $test ? "真":"偽","($test)";
 結果 真(1)
 my $test;
 $test=("" eq "ABC");　または　$test=(0 == 1);
 print "undef" unless defined $test;
 print  $test ? "真":"偽","($test)";
 結果 偽()
}}

""undefの値を持った変数を参照(print,m//)するとエラーとなります。注意
 Use of uninitialized value in string at test.cgi line 128.
 Use of uninitialized value in pattern match (m//) at test.cgi line 132.
!!論理演算
$Aと$Bは、"ABC" か "" とする。この場合"ABC"は論理値1、""は論理値０と評価される
$aと$bは、1   か　0 とする。この場合１は論理値１、０は論理値０と評価される
::否定 
:::真のものを否定すれば偽。偽を否定すれば真。 
 !($A and $B) または Not($a || $b) など
::論理積　and 
:::２つの論理値が同時に真である時のみ真。それ以外は全て偽。 
 ($A and $B) または ($a && $b) または　($a * $b)
::論理和　or 
:::２つの論理値が同時に偽である時のみ偽。それ以外は全て真。
 ($A or $B) または ($a || $b) または ($a + $b)
::排他的論理和　xor
:::２つの論理値が同一の時のみ偽、それ以外はすべて真。
 ($A xor $B) または ($a xor $b)
::優先順位
::: !>&&>||>not>and>or.xor

!!関数（サブルーチン）の呼び出しについて
次の関数の呼び出しは、
 &subname(undef,1,,3);
次と同様にです。(,,は,とみなされるので引数の途中の省略は誤りです)
 &subname(undef,1,3);
関数内で引数が定義されていなければ、undef が変数に付与されます。またこのような変数は、初期設定値が必要です。
{{code Perl,0,0
 &subname(undef,1,3);
 subname{
    ($a,$b,$c,$d)=@_; #//最後尾の引数は省略できます。
    $a="" unless defined $a;
    $b=0 unless defined $b;
    $c=0 unless defined $c;
    $d="" unless defined $d;
 }
}}

偽すべてについて初期設定する場合、
{{code Perl,0,0
 &subname(undef,1,"");
 subname{
    ($a,$b,$c,$d)=@_; #//最後尾の引数は省略できます。
    $a="" unless $a;
    $b=0 unless $b;
    $c=0 unless $c;
    $d="" unless $d;
 }
}}

!!元年１月１日から指定日までの日数および曜日計算
１月および２月は前年の１３月および１４月として計算する。月は3月から14月まであると考える。元年３月１日は、31+28+1日。
基本　うるう年分加算 int($year/4) - int($year/100) + int($year/400)
基本計算式１my $dday = (int(21*$yc/4) + int(5*$yy/4) + int(26*($mon+1)/10) + ($day-1))%7;
ただし、$yy=$year%100;
基本計算式２my $dday = ($year + int($year/4) - int($year/100) + int($year/400) + int((13*$mon+8)/5) + $day)%7;
基本計算式 my $tday = 365*($year-1)+int($year/4)-int($year/100)+int($year/400)+31+28+1+int(306*($mon+1)/10)-122+($day-1);
Fairfield公式とツェラーの公式を参考に！
{{code Perl,0,0
 sub get_days{
  my ($year,$mon,$day)=@_;
  if ($mon<3){$year--; $mon += 12;}
  my $yc=int($year/100);
  my $leapd = int($year >> 2) - $yc + int($yc >> 2); #//うるう年分加算する値
  my $tday = 365 * $year + $leapd + int(306 * ($mon+1) / 10) + $day - 428;
  my $dday = ($year + $leapd + int((13*$mon+8)/5) + $day)%7;
  return($tday,$dday);
 }
 my ($day,$mon,$year)=(30,11,2007); #//金曜日
 my ($tday,$dday)=&get_days($year,$mon,$day);
 print "日数: $tday \n"; #//結果 733010
 print "曜日: $dday \n"; #//結果 5 (0:日曜日 1:月曜日 .. 6:土曜日)
 my $time = ($tday - 719163)*24*3600;  #//1970_1_1=>719163　TIME関数の返値と同じ
}}
!まとめ
指定日の月が
*１月から２月の場合、それぞれの年＋月＋日＝日数となります
**年＝前々年までの日数＋前年までの閏年の加算分＋前年の１月と２月の日数
**月＝前年の３月から指定日の月が１月若しくは２月未満までの日数
**日＝指定日の日
*３月から１２月の場合、それぞれの年＋月＋日＝日数となります
**年＝前年までの日数＋指定日の年までの閏年の加算分＋指定日の年の１月と２月の日数
**月＝指定日の月未満までの日数
**日＝指定日の日
注意：１月は３１日と２月は２８日で計算します。
!!Int関数
符号に関係なく【小数部を切り捨てた整数部】を返します。
{{code Perl,0,0
 int(-8.4)--> -8 を返す。 
}}
!!Foreach、Map関数などの$_の注意
＄＿に対して変更を加えると元の値が書き換えられます。
{{code Perl,0,0
 foreach (@array){
    $_ =~ tr/0-9//cd; #//配列の中身は全て数字のみに置き換えられます
 }
}}
これを避けるには、
{{code Perl,0,0
 foreach my $dat (@array){
    $dat =~ tr/0-9//cd;
 }
}}
!!SJISのスクリプトで''表示''が''侮ｦ''にならないために
次の スクリプトを埋め込む、もちろんこのスクリプトはSJISで書きます。
{{code Perl,0,0
 use Encode qw(encode decode);
 use encoding "shiftjis"; #<----これを使うと表示などのもじは文字化けしません。
 #// ただしこれにより内部処理はコードは、utf8 になります。
 #// しかし、標準入力(input)は、SJISコードは自動でutf8に変換されます。
 #// しかし、標準出力(print)は、内部コードのutf8は自動でSJISコードに変換されます。
 binmode STDERR, ":encoding(shiftjis)"; #<---　エラー出力をSJISに変換します。
 #// @ARGVからの読み込みは自動でutf8に変換しないので、下の処理をする
 my @array;
 push(@array,map{decode('shiftjis',$_)}@ARGV);
 print join(/,/,@array);
 #//標準出力への表示を出力
 print "現在の時間を表示";
}}
ファイルへの入出力は、UTF8の文字変換を参照してください。

!!TR演算子（文字を変換/削除する）の動作について
TR/検索リスト/変換する文字リスト/cds;
C：検索リスト部に含まれない文字が検索対象
D：検索リスト部に含まれているが変換文字リスト部に対応する文字がない文字を削除する
変換文字リストが検索リストより短い場合、短い部分については、変換文字リストの最後文字がセットされる
S：連続している同じ文字をまとめて1文字にする。
漢字交じりの文字列を扱う場合は、一度EUCコードに変換後TR演算子にかけて、元の文字コード戻すことが望ましい。
数字(０−９)までの検査では、コード変換の必要はありません。（SJISのまま）
{{code Perl,0,0
TRの検査         (検査　Date: Fri, 04 Jul 金曜日 2008 17:25:44 +09:00) length51
tr/0-9/*/     => (検査　Date: Fri, ** Jul 金曜日 **** **:**:** +**:**) count(16) <=検索文字と対応する文字に置き換える、ないところは最後の置き換え文字を用いる
tr/0-9/*/c    => (*****************04************2008*17*25*44**09*00) count(35) <=上述の反対を行う 
tr/0-9/*/d    => (検査　Date: Fri, * Jul 金曜日 ** :: +*:**) count(16)   <=対応する文字がない箇所は削除
tr/0-9/*/dc   => (0420081725440900) count(35) <=上述のCをしてからDを実施
tr/0-9/*/s    => (検査　Date: Fri, * Jul 金曜日 * *:*:* +*:*) count(16)
tr/0-9/*/cs   => (*04*2008*17*25*44*09*00) count(35)
tr/0-9/a-z/   => (検査　Date: Fri, ae Jul 金曜日 caai bh:cf:ee +aj:aa) count(16)
tr/0-9/a-z/c  => (zzzzzzzzzzzzzzzzz04zzzzzzzzzzzz2008z17z25z44zz09z00) count(35)
tr/0-9/a-z/dc => (0420081725440900) count(35)
tr/0-9/0-9/   => (検査　Date: Fri, 04 Jul 金曜日 2008 17:25:44 +09:00) count(16)
tr/0-9/0-9/s  => (検査　Date: Fri, 04 Jul 金曜日 208 17:25:4 +09:0) count(16)
tr/ //d       => (検査　Date:Fri,04Jul金曜日200817:25:44+09:00) count(7)
tr/\x00-\x7f/\x00-\x7f/ => (検査　Date: Fri, 04 Jul 金曜日 2008 17:25:44 +09:00) count(39)
tr/0-9//dc   => (0420081725440900) count(35) <=数字のみ取り出し
tr/\x20|\t//d   => (検査　Date:Fri,04Jul金曜日200817:25:44+09:00) count(7) <=空白とタブの削除
}}
検査の直後にSHIFTJISの全角空白(\x81\x40)がある場合、\x40は＠で表示される
{{code Perl,0,0
tr/\81/K/  => (検査K@Date: Fri, 04 Jul 金曜日 2008 17:25:44 +09:00) count(1)
}}
文字列数値の列順整形
{{code Perl,0,0
 $day = "7851952244555";
 $day =~ tr/0-7//cd;$day =join(//,sort(split(//,$day)));$day=~tr/0-7//s;
 結果 "12457"
}}
!!スクリプトエラー（SJISで記述されたスクリプト）
検査の直後にSHIFTJISの全角空白(\x81\x40)があるので配列宣言と勘違いしている
{{code Perl,0,0
###Global symbol "@Date" requires explicit package name のエラー発生
$str = "検査　Date: Fri, 04 Jul 金曜日 2008 17:25:44 +09:00";
### 回避策
$str = q(検査　Date: Fri, 04 Jul 金曜日 2008 17:25:44 +09:00);
}}
!!HTMLにて特殊コードの表記
書式「＆＃10進数；」
{{code Perl,0,0
 print "&#63879;";  #// １０進数表記、ドコモ携帯　　１の表示
 print "&#57884;";  #// １０進数表記、SoftBank携帯　１の表示 
}}
書式「＆＃ｘ１６進数；」
{{code Perl,0,0
 print "&#xE6E2;";  #// １６進数表記、docomo  携帯　１の表示 
 print "&#xE21C;";  #// １６進数表記、SoftBank携帯　１の表示 
}}
!!CSVデーター形式の取り出し
{{code Perl,0,0
 my @csvdata=qq("yuki","umi",23,"hare","234,900");#//データー
 foreach my $line (@csvdata){
    $line =~ s/,*$/,/;
    push(@ans,[ map{/"(.*?)"/?$1:$_}($line =~ /(".*?"|[^,]*),/g) ]);
 }
 print Dumper \@ans;
 結果 [ [ 'yuki', 'umi', '23', 'hare', '234,900' ] ]; 
}}
!!デバッグのブレークポイント設定
DOSコマンドラインで、"perl -d スクリプト名.cgi"を実行して、
DB<1>　c 　を入力するとブレークポイントまで実行して止まります。
{{code Perl,0,0
 #//実行を中断したい箇所に挿入してください
 $DB::single = 1;
}}
DB<1> x $abc,@array,%hash を入力すると変数の値を表示します
DB<1> b kansu を入力すると kansu サブルーチンの始めにブレークポイントを設定します
DB<1> n スクリプトの一行実行します。サブルーチンは一挙に実行します
DB<1> s スクリプトの一行実行します。サブルーチンの中でも１行実行します
DB<1> b 353 を入力するとスクリプトの行番号353手前まで実行して中断します。
!!実行エラー内容がブラウザ上に表示
{{code Perl,0,0
 use CGI::Carp qw(fatalsToBrowser);#//confess
 ...
 open (IN,$fname) || confess  "open error $fname $!";
 ...
}}
!!パッケージごとにバージョンの設定
{{code Perl,0,0
 #//バージョン設定
 package hoge;
 use CGI::Carp qw(fatalsToBrowser);#//confess 
 use strict;
 use warnings;
 our $VERSION = '1.0';#//Perl5.6　以降で有効
 #//----------------これは5.6未満の場合
 #// use vars qw($VERSION);
 #// $VERSION = '1.0';
 #//-----------------
 ....
 1;
 #//通常スクリプト
 use hoge;
 print $hoge::VERSION; #//バージョンの番号印刷
 #//通常スクリプト
 use hoge 1.01;
 #エラーが発生　Utilsub version 1.01 required--this is only version 1.0 
}}