タヌキのお散歩
タヌキのお散歩

PERLに関して

現在人来訪中
トップ 差分 一覧 ソース 検索 ヘルプ RSS ログイン 印刷

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を使用する場合、

 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を使用しない場合、

 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フラグなしにする。

 $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.. になります。

 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の文字変換を参照してください。

 #//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フラグ付き)に変換する

 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での変換

 $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などの標準に指定したブラウザーを呼び出すには

 $url = "http://abc/foo.com?m=84&po=567";
 $url =~ s/&/\^&/g;
 system("start $url");

Perlから指定URLをGETするには

 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する

 #// LOCALHOST の場合、'localhost'を返す
 my $httphost  = $ENV{'HTTP_HOST'};
 $httphost ="" unless($httphost);

@ARGV の引数について

次のCGIスクリプトを

 print "Content-type: text/plain\n\n";
 print "ARGV--------------------------\n";
 my $ii=0;
 foreach (@ARGV) {
  print "($ii)$_\n";
  $ii++;
 }

DOS画面で実行した結果

 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

ブラウザーで実行した結果

 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両方から引数を得ることができます)

 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で実行した結果

 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スクリプトを

 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画面で実行した結果(空白で区切、その後&で区切られている)

 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)

ブラウザーで実行した結果(&で区切られている)

 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)

補足 実用スクリプト

 #//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'}使う

 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++;
 }

ブラウザーで実行した結果

 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 を使って取り込む必要有り

数秒以内のキー入力を求める。

次のスクリプトです。

 use Term::ReadKey;
 while(1){
  print("処理中止は3秒以内にいずれかのキーを押します。");
  my $char = ReadKey(3);
  last if defined $char;
  ....
 }

Readkeyの引数は、
 0:改行キー待ち
 -1:キー待ちなし
 >0:指定時間

代入初期値設定

配列にリスト値を代入、参照、配列の箱中身を要素(Element)といいます。配列の箱番号を要素番号(Index)といいます。
展開とは、変数名($dat1)の内容を代入することです。展開できないことは、$dat1がそのまま代入されます。
リファレンスとは、配列箱の住所です。配列箱は長屋(家)全体です。配列箱番号は、長屋の各部屋番号(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]; #//部屋番号0の値(中身)を代入します。
 $fog1 = $array[1];
 $refarray = \@array;  #//リファレンス
 $fog2 = $refarray->[2]; #//住所->部屋番号2の中身を代入します。
 @array2 = @array; #//配列全体のコピー複写
 push(@array2,@array1); #//配列全体の追加
 push(@{$array2[0]},"hatu") #//2次元配列への指定要素番号への追加
 @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

ハッシュにキー値を代入、参照

 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}; #//ハッシュスライス(ハッシュの内容検索)

サブルーチンの受け取り側(配列、ハッシュ)参照
値渡しは、呼び出し元の変数の内容はサブルーチン内では変化しない。
参照渡しは、呼び出し元の変数の内容はサブルーチン内で処理により変化します。

 &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);
 }

無名配列[]、ブラケットで囲めば無名配列を生成

 $refarray = [1, 2, 3, "asdcf",$dat1, $dat2];
 #//参照:配列全体 @{$refarray} なので @{[1, 2, 3, "asdcf",$dat1, $dat2]};も可能

無名ハッシュ{}、ブレースで囲めば無名ハッシュを生成

 $refhash  = {"a"=>1, "b"=>2, "c"=>3, "data1"=>"saa"};

無名配列、無名ハッシュのサブルーチン側の引数受け取り

 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";
 }

無名配列、無名ハッシュのサブルーチン呼び出し側

 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)

リファレンスにおいてハッシュの要素がハッシュと配列の場合

 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階建てアパートです)

2次元配列を行(横行)と列(縦列)に考えた場合

 #//初期設定 (行[列,列,列],行[列,列])
 @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、代入される

 my $content="AAA,010\nBBB,023\nCCC,333\n";
 push (@team2,map{[split (/,/,$_)]}split(/\n/,$content));

2次元配列全体の表示
ここで使用されているMYは、各々のforeachの内側のみで有効です。これを局所変数といいます。

 foreach my $ref (@{$refarray}){ #//横行の読出し
  foreach my $ref2 (@{$ref}){ #//その行内の縦列の読出し
   print $ref2,;
  }
 }

二次元配列の一つの要素を1次元配列にしてコピー

 my @array1=@{ $array2[0] }; #// @{ 2次元配列[要素番号]=>1次元配列リスト }取り出し

二次元配列の各要素をカンマで整列させる

 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 は、配列最大要素を返す。次の場合7を返す、scalar(@array)は8を返す
次の場合、GREPはマッチした要素を返す。
下の場合は、検索文字'tokyo'で該当箇所を抽出しています

 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次元配列に入れる

 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 ] ]; 

ハッシュの内容を配列に変換(カンマ区切り)

 my @array = [map{qq("$_","$ref_hdata->{$_}")}sort keys %{$ref_hdata}]

ハッシュへの初期設定

 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);
 }

ハッシュの要素が配列の場合の配列への追加

 my %ans2;
 push(@{$ans2{'red'}},@array)

2次元ハッシュの作成例

 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]; #//配列追加方法1
 @{$hash{'C1'}} = @ar1; #//配列追加方法2
 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']);
 

2次元配列を昇順ソートする

@adatの各要素の頭4桁を抽出して昇順ソートした結果を返す

 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]);

配列の要素が配列のリファレンスの場合

 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);

サブルーチンの受け取り側の処理

 #//呼び出し例
 &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;
 }

条件付き配列要素の削除

    for(my $i=0;$i<scalar(@array);$i++){
        if(   ...   ){splice(@array,$i--,1);next;}
        ....
    }

配列の各要素のデーター整理(ファイルから読んだ一行ごとのデーター整理)

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,@{$refarray}
  • 配列要素 \$refarray[index]
    • 参照 $$refarray[index],$refarray->[index]
  • ハッシュ \%refhash
    • 参照 %$refhash,%{$refhash}
  • ハッシュ要素 \%refhash{index}
    • 参照 $$refhash{index},$refhash->{index}
  • スカラー \$refscalar
    • 参照 $$refscalaer,${$refscalaer}
  • サブルーチン \&refsub
    • 参照 &$refsub,&{$refsub}

指定フォルダーのファイル名リストの取得

 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は真。

 my $test;
 #//$TESTの値が定義されていないならばundefをPrintする。
 print "undef" unless defined $test;
 #//$TESTの値の評価が偽ならば偽をPrintする。
 print  $test ? "真":"偽";
 結果 undefmy @test;
 print "undef" unless defined $test[0];
 print  $test[0] ? "真":"偽";
 結果 undefmy %test;
 print "undef" unless defined $test{0};
 print  $test{0} ? "真":"偽";
 結果 undefmy $test="0";
 print "undef" unless defined $test;
 print  $test ? "真":"偽";
 結果 偽

PERLでは論理演算の結果、偽(false)とは論理値""で、真(true)とは論理値1である。(boolean)

 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、""は論理値0と評価される
$aと$bは、1 か 0 とする。この場合1は論理値1、0は論理値0と評価される

否定
真のものを否定すれば偽。偽を否定すれば真。

!($A and $B) または Not($a || $b) など
論理積 and
2つの論理値が同時に真である時のみ真。それ以外は全て偽。
($A and $B) または ($a && $b) または ($a * $b)
論理和 or
2つの論理値が同時に偽である時のみ偽。それ以外は全て真。
($A or $B) または ($a || $b) または ($a + $b)
排他的論理和 xor
2つの論理値が同一の時のみ偽、それ以外はすべて真。
($A xor $B) または ($a xor $b)
優先順位
!>&&>||>not>and>or.xor

関数(サブルーチン)の呼び出しについて

次の関数の呼び出しは、

&subname(undef,1,,3);

次と同様にです。(,,は,とみなされるので引数の途中の省略は誤りです)

&subname(undef,1,3);

関数内で引数が定義されていなければ、undef が変数に付与されます。またこのような変数は、初期設定値が必要です。

 &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;
 }

偽すべてについて初期設定する場合、

 &subname(undef,1,"");
 subname{
    ($a,$b,$c,$d)=@_; #//最後尾の引数は省略できます。
    $a="" unless $a;
    $b=0 unless $b;
    $c=0 unless $c;
    $d="" unless $d;
 }

元年1月1日から指定日までの日数および曜日計算

1月および2月は前年の13月および14月として計算する。月は3月から14月まであると考える。元年3月1日は、31+28+1日。
基本 うるう年分加算 int($year/4) - int($year/100) + int($year/400)
基本計算式1my $dday = (int(21*$yc/4) + int(5*$yy/4) + int(26*($mon+1)/10) + ($day-1))%7;
ただし、$yy=$year%100;
基本計算式2my $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公式とツェラーの公式を参考に!

 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関数の返値と同じ

まとめ

指定日の月が

  • 1月から2月の場合、それぞれの年+月+日=日数となります
    • 年=前々年までの日数+前年までの閏年の加算分+前年の1月と2月の日数
    • 月=前年の3月から指定日の月が1月若しくは2月未満までの日数
    • 日=指定日の日
  • 3月から12月の場合、それぞれの年+月+日=日数となります
    • 年=前年までの日数+指定日の年までの閏年の加算分+指定日の年の1月と2月の日数
    • 月=指定日の月未満までの日数
    • 日=指定日の日

注意:1月は31日と2月は28日で計算します。

Int関数

符号に関係なく【小数部を切り捨てた整数部】を返します。

 int(-8.4)--> -8 を返す。 

Foreach、Map関数などの$_の注意

$_に対して変更を加えると元の値が書き換えられます。

 foreach (@array){
    $_ =~ tr/0-9//cd; #//配列の中身は全て数字のみに置き換えられます
 }

これを避けるには、

 foreach my $dat (@array){
    $dat =~ tr/0-9//cd;
 }

SJISのスクリプトで表示侮ヲにならないために

次の スクリプトを埋め込む、もちろんこのスクリプトはSJISで書きます。

 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演算子にかけて、元の文字コード戻すことが望ましい。
数字(0−9)までの検査では、コード変換の必要はありません。(SJISのまま)

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は@で表示される

tr/\81/K/  => (検査K@Date: Fri, 04 Jul 金曜日 2008 17:25:44 +09:00) count(1)

文字列数値の列順整形

 $day = "7851952244555";
 $day =~ tr/0-7//cd;$day =join(//,sort(split(//,$day)));$day=~tr/0-7//s;
 結果 "12457"

スクリプトエラー(SJISで記述されたスクリプト)

検査の直後にSHIFTJISの全角空白(\x81\x40)があるので配列宣言と勘違いしている

###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進数;」

 print "&#63879;";  #// 10進数表記、ドコモ携帯  1の表示
 print "&#57884;";  #// 10進数表記、SoftBank携帯 1の表示 

書式「&#x16進数;」

 print "&#xE6E2;";  #// 16進数表記、docomo  携帯 1の表示 
 print "&#xE21C;";  #// 16進数表記、SoftBank携帯 1の表示 

CSVデーター形式の取り出し

 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  を入力するとブレークポイントまで実行して止まります。

 #//実行を中断したい箇所に挿入してください
 $DB::single = 1;

DB<1> x $abc,@array,%hash を入力すると変数の値を表示します
DB<1> b kansu を入力すると kansu サブルーチンの始めにブレークポイントを設定します
DB<1> n スクリプトの一行実行します。サブルーチンは一挙に実行します
DB<1> s スクリプトの一行実行します。サブルーチンの中でも1行実行します
DB<1> b 353 を入力するとスクリプトの行番号353手前まで実行して中断します。

実行エラー内容がブラウザ上に表示

 use CGI::Carp qw(fatalsToBrowser);#//confess
 ...
 open (IN,$fname) || confess  "open error $fname $!";
 ...

パッケージごとにバージョンの設定

 #//バージョン設定
 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 

最終更新時間:2019年09月10日 17時11分46秒