[[PageOutline]] = Perl = == [http://perltidy.sourceforge.net/ Perltidy] == * Perl の Pretty Printer === 設定 === * by Perl Best Practices {{{ $ cat ~/.perltidyrc -l=78 # Max line width is 78 cols -i=4 # Indent level is 4 cols -ci=4 # Continuation indent is 4 cols -st # Output to STDOUT -se # Errors to STDERR -vt=2 # Maximal vertical tightness -cti=0 # No extra indentation for closing brackets -pt=1 # Medium parenthesis tightness -bt=1 # Medium brace tightness -sbt=1 # Medium square brace tightness -bbt=1 # Medium block brace tightness -nsfs # No space before semicolons -nolq # Don't outdent long quoted strings -wbb="% + - * / x != == >= <= =~ !~ < > | & >= < = **= += *= &= <<= &&= -= /= |= >>= ||= .= %= ^= x=" # Break before all operators }}} === Emacs から使う === * indent-region (C-M-\) が呼ばれた際,cperl-mode の時は代わりに [http://unknownplace.org/memo/2005/12/11#e001 perltidy-region] を呼ぶ * .emacs に以下を追加 {{{ #!el ;;; perltidy-region (defun perltidy-region () "Run perltidy on the current region." (interactive) (save-excursion (shell-command-on-region (point) (mark) "perltidy -q" nil t))) (add-hook 'cperl-mode-hook '(lambda () (defalias 'cperl-indent-region 'perltidy-region) )) }}} == Python で言うところの getattr してみる == ていうかむしろ eval してるだけ. eval じゃなくてホントに getattr したいんだけど,どうやってやるんだろう? * {{{hoge.pm}}} {{{ #!perl use strict; use warnings; package hoge; our $foo = "hogeraccho"; 1; __END__ }}} * {{{unko.pm}}} {{{ #!perl use strict; use warnings; package unko; our $foo = "unkokko"; 1; __END__ }}} * {{{modules}}} ファイル {{{ unko hoge foo }}} * {{{main.pl}}} {{{ #!perl #!/usr/bin/env perl use strict; use warnings; use Symbol; my $sym = gensym; open($sym, "modules"); while (my $module = <$sym>) { chomp $module; next unless $module; eval { require $module . '.pm'; my $foo = eval("\$${module}::foo"); print "\$${module}::foo = $foo\n"; }; warn "WARNING: $@" if $@; } close($sym); }}} * 実行結果 {{{ #!sh bash$ perl main.pl $unko::foo = unkokko $hoge::foo = hogeraccho WARNING: Can't locate foo.pm in @INC ... }}} == データの永続化 == Storable を使って文字列で Perl オブジェクトをやりとりしてみる.nfreeze を使う場合,改行をエスケープする必要があるようだ. バイナリでのやりとりも可であれば,nstore を使うのが良い. * freeze.pl {{{ #!perl #!/usr/bin/perl use strict; use diagnostics; use warnings; use Storable qw(nfreeze); my $hash = { "1" => "hogera", "2" => 1, "3" => [1, 2, 3], "4" => {"a" => 1}, "5" => { "a" => 1, "b" => [1, 2, 3], "c" => {"i" => 2}, }, }; my $serialized = nfreeze($hash); print r_escape($serialized); sub r_escape { my $s = shift; $s =~ s/([%\r\n])/sprintf("%%%02X", ord($1))/ge; return $s; } }}} * thaw.pl {{{ #!perl #!/usr/bin/perl use strict; use diagnostics; use warnings; use Storable qw(thaw); use Data::Dumper; my $line = ""; $line .= $_ while (<>); my $hash = thaw(r_unescape($line)); print Dumper($hash); sub r_unescape { my $s = shift; $s =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/ge; return $s; } }}} * 実行結果 {{{ #!sh $ ./freeze.pl | ./thaw.pl $VAR1 = { '1' => 'hogera', '4' => { 'a' => 1 }, '3' => [ 1, 2, 3 ], '2' => 1, '5' => { 'c' => { 'i' => 2 }, 'a' => 1, 'b' => [ 1, 2, 3 ] } }; }}} === オブジェクトの永続化 === 当然のことながら,展開先ソースコードが必要になる. * object.pm {{{ #!perl use strict; use diagnostics; use warnings; package object; sub new { my $class = shift; bless { "1" => "hogera" }, $class; } sub set_1 { my ($self, $val) = @_; $self->{"1"} = $val; } sub unko { my $self = shift; return $self->{"1"}; } 1; __END__ }}} * freeze.pl {{{ #!perl #!/usr/bin/perl use strict; use diagnostics; use warnings; use Storable qw(nfreeze); use object; my $obj = new object; $obj->set_1("hage"); my $serialized = nfreeze($obj); print r_escape($serialized); sub r_escape { my $s = shift; $s =~ s/([%\r\n])/sprintf("%%%02X", ord($1))/ge; return $s; } }}} * thaw.pl {{{ #!perl #!/usr/bin/perl use strict; use diagnostics; use warnings; use Storable qw(thaw); use object; my $str = ""; $str .= $_ while (<>); my $obj = thaw(r_unescape($str)); print $obj->unko(), "\n"; sub r_unescape { my $s = shift; $s =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/ge; return $s; } }}} * 実行結果 {{{ #!sh $ ./freeze.pl | ./thaw.pl hage }}} == constant とハッシュ == constant な値をハッシュのキーにすると,そのままでは文字列として解釈されてしまい,ハマる原因になる.括弧をつけること. * ダメな例 {{{ #!perl use constant HOGE => "hoge"; my %hash = ("hoge" => "raccho"); print $hash{HOGE}, "\n"; }}} * OK な例 {{{ #!perl use constant HOGE => "hoge"; my %hash = ("hoge" => "raccho"); print $hash{(HOGE)}, "\n"; }}} * なお constant の実体は関数なので,{{{&HOGE}}} としても同じ意味. == ハッシュ関連 == === ハッシュが格納されている配列中で,ハッシュの中のある特定のキーの値が同じものを削除する === {{{ #!perl sub keygrep($$) { my $array = shift; my $key = shift; my %seen = (); my @res = (); @res = sort { $a->{$key} cmp $b->{$key} } @{$array}; @res = grep(!$seen{$_->{$key}}++, @res); return \@res; } }}} * ([{a=>1, b=>2}, {a=>2, b=>3}, {a=>1, b=>3}], "a") が [{a=>1, b=>2}, {a=>2, b=>3}] で返る. === each の罠 === * パッと見,以下のコードでは {{{===unreachable===}}} は出力されないように見える. * しかし,1 度目の {{{dump}}} コールにより {{{$data}}} のイテレータが {{{$vv->{'uge'}}}} を過ぎた状態で保存されるため,2 度目の {{{dump}}} コールでは該当コードに到達する. * each を使う際は最後までイテレートさせないとハマる危険性大. * イメージ的には Python で言う yield に近い. {{{ #!perl use YAML::Syck qw(Load Dump); &hoge(); sub hoge { my $data = Load( join( '', ) ); &dump($data); &dump($data); } sub dump { my $data = shift; while ( my ( $k, $v ) = each( %{$data} ) ) { foreach my $vv ( @{$v} ) { return if ( $vv->{'uge'} eq 'uhi-' ); } } print "=== unreachable ===\n"; print Dump($data); } __DATA__ hoge: - hage: hige huge: unko uge: goge - hage: hihi huge: uho uge: uhi- }}} {{{ #!sh $ perl hogehoge.pl === unreachable === --- hoge: - hage: hige huge: unko uge: goge - hage: hihi huge: uho uge: uhi- }}} * なお,{{{keys}}} や {{{values}}} を利用することでイテレータを初期化することができる. * 上記コードのうち,{{{hoge}}} 関数内の 2 連 {{{dump}}} の間に {{{keys(%{$data});}}} を挿入するだけで実行結果が変化することに注目. == OOP 関連 == === 引数設定の自動化もどき === * 意味があるのかどうかは知らん. {{{ #!perl use strict; use warnings; use diagnostics; use Carp; { package Base; sub new ($%) { my ($class, %argv) = @_; my $self = bless {__class__ => $class}, $class; return $self->__init__(%argv); } sub __init__ ($%) { my ($self, %argv) = @_; while (my ($key, $val) = each(%argv)) { $self->{$key} = $val; } return $self; } sub __class__ ($) { my $self = shift; return $self->{__class__}; } sub __check__ ($@) { my ($self, @requisite) = @_; foreach (@requisite) { Carp::confess $self->__class__(), " requires argument ", $_ unless (exists($self->{$_})); } } 1; } { package Parent; use base qw(Base); sub __init__ ($%) { my @requisite = qw(parentname); my ($self, %argv) = @_; $self->SUPER::__init__(%argv); $self->SUPER::__check__(@requisite); return $self; } sub parent ($) { my $self = shift; printf "parent is %s\n", $self->{parentname}; } 1; } { package Child; use base qw(Parent); sub __init__ ($%) { my @requisite = qw(childname); my ($self, %argv) = @_; $self->SUPER::__init__(%argv); $self->SUPER::__check__(@requisite); return $self; } sub child ($) { my $self = shift; printf "child is %s\n", $self->{childname}; } 1; } my $parent = new Parent(parentname => "jobs"); $parent->parent(); my $child = new Child(childname => "michael", parentname => "mike"); $child->parent(); $child->child(); }}} == マジカルインクリメント == * 出展: http://www.takaaki.info/archives/000101.html === "perl" と表示 === {{{ #!perl my $A="a";for(1..285075){$A++;}print"$A"; }}} === "atzm" と表示 === {{{ #!perl my $A="a";for(1..31784){$A++;}print"$A"; }}} === 調べる === {{{ #!perl my $A="a";for(my $i=0;;$i++,$A++){printf'my $A="a";for(1..%d){$A++;}print"$A";%s',$i,"\n"and last if $A eq $ARGV[0];} }}} * 高速バージョン from http://hori-uchi.com/archives/000243.html#comments {{{ #!sh $ perl -e '@A=reverse split//,$ARGV[0];for(@A){$s+=(ord($_)-96)*(26**$i++)};print $s-1,"\n";' }}} == HTML 関連 == === 実体参照,文字参照をほげる === {{{ #!perl my %entref_map = ( amp => "&", apos => "'", gt => ">", lt => "<", nbsp => " ", quot => '"', ); $body =~ s/&(\w+?);/$entref_map{$1}/ge; # entityref $body =~ s/&#([0-9]+?);/chr($1)/ge; # dec charref $body =~ s/&#x([0-9A-Fa-f]+?);/chr(hex($1))/ge; # hex charref }}} * こういうのもあるらしい http://www.kawa.net/works/perl/i18n-emoji/EntityRef.pm.html == スタックトレース関連 == * 基本的には Carp モジュールを利用する === 予期せぬエラーにスタックトレースをつけてくれ宣言 === * die や warn を置き換えてやれば良い {{{ #!perl use Carp; $SIG{__DIE__} = \&Carp::confess; $SIG{__WARN__} = \&Carp::cluck; }}} == ステップつきスライス == * つまるところ Python での {{{list[start:end:step]}}}.ただし Python のように step に 0 以下の値を入れられない. {{{ #!perl use Clone qw(clone); my @array = (100 .. 150); my $step = 3; for (0 .. 10) { print join(", ", &slice(\@array, $_, $#array, $step)), "\n"; } sub slice($$$$) { my ($array, $start, $end, $step) = @_; my @subs = (); for (my $i = $start; $i < $end; $i += $step) { push(@subs, clone($array->[$i])); } return @subs; } }}} * 実行結果 {{{ 100, 103, 106, 109, 112, 115, 118, 121, 124, 127, 130, 133, 136, 139, 142, 145, 148 101, 104, 107, 110, 113, 116, 119, 122, 125, 128, 131, 134, 137, 140, 143, 146, 149 102, 105, 108, 111, 114, 117, 120, 123, 126, 129, 132, 135, 138, 141, 144, 147 103, 106, 109, 112, 115, 118, 121, 124, 127, 130, 133, 136, 139, 142, 145, 148 104, 107, 110, 113, 116, 119, 122, 125, 128, 131, 134, 137, 140, 143, 146, 149 105, 108, 111, 114, 117, 120, 123, 126, 129, 132, 135, 138, 141, 144, 147 106, 109, 112, 115, 118, 121, 124, 127, 130, 133, 136, 139, 142, 145, 148 107, 110, 113, 116, 119, 122, 125, 128, 131, 134, 137, 140, 143, 146, 149 108, 111, 114, 117, 120, 123, 126, 129, 132, 135, 138, 141, 144, 147 109, 112, 115, 118, 121, 124, 127, 130, 133, 136, 139, 142, 145, 148 110, 113, 116, 119, 122, 125, 128, 131, 134, 137, 140, 143, 146, 149 }}} == データの分離 == === 特殊ファイルハンドル DATA === * {{{__DATA__}}},{{{__END__}}} 以下は DATA ファイルハンドルで読み出せる. {{{ #!perl print while(); __END__ hoge hage hige }}} === DATA の罠 === * hoge.pm 内の DATA の position が 1 回目の new で EOF に到達するため,2 回目の new では $self->{'data'} が空になる. {{{ #!perl package hoge; sub new { my $class = shift; my @data = ; return bless {'data' => \@data}, $class; } sub hoge { my $self = shift; return $self->{'data'}; } 1; __DATA__ hoge hage hige }}} {{{ #!perl use hoge; my $hoge1 = new hoge(); print "*** 1\n"; print @{$hoge1->hoge()}; my $hoge2 = new hoge(); print "*** 2\n"; print @{$hoge2->hoge()}; }}} * 何度も new できるようにするためには,以下のようにする必要がある. {{{ @@ -5,7 +5,9 @@ sub new { my $class = shift; + my $pos = tell DATA; my @data = ; + seek DATA, $pos, 0; return bless {'data' => \@data}, $class; } }}} == スクリプトを直接実行した時だけ呼ぶコード == * とどのつまりは Python で言うところの {{{if __name__ == "__main__":...}}} . {{{ #!perl if (__FILE__ eq $0) { ... } }}} == 時刻/日付操作 == === strptime === ふざけたことに標準では strptime を使うことができないので,以下のいずれかを別途インストールする必要がある. 両者で strptime 関数への引数の順番が違うので注意. * [http://search.cpan.org/dist/POSIX-strptime/lib/POSIX/strptime.pm POSIX::strptime] {{{ #!perl use POSIX qw(strftime mktime locale_h); use POSIX::strptime; setlocale(LC_TIME, 'C'); my $date = '08:52:20 JST Wed Apr 11 2007'; my $fmt = '%H:%M:%S %Z %a %b %d %Y'; my @times = POSIX::strptime( $date, $fmt ); my $epoch = mktime( @times[0..5] ); print "before: $date\n"; printf "after: %s\n", strftime( $fmt, localtime($epoch) ); }}} {{{ #!sh $ perl hoge.pl before: 08:52:20 JST Wed Apr 11 2007 after: 08:52:20 JST Wed Apr 11 2007 }}} * POSIX の strptime ではナノ秒の解析はできない * setlocale しないとバグる可能性大なので注意 * [http://search.cpan.org/dist/DateTime-Format-Strptime/lib/DateTime/Format/Strptime.pm DateTime::Format::Strptime] {{{ #!perl use POSIX qw(strftime); use DateTime::Format::Strptime qw(strptime); my $date = '08:52:20.343 JST Wed Apr 11 2007'; my $fmt = '%H:%M:%S.%N %Z %a %b %d %Y'; my $dt = strptime( $fmt, $date ); my $epoch = $dt->epoch(); print "before: $date\n"; printf "after: %s\n", strftime( $fmt, localtime($epoch) ); }}} {{{ #!sh $ perl hoge.pl before: 08:52:20.343 JST Wed Apr 11 2007 after: 08:52:20.%N JST 水 4月 11 2007 }}} * こちらはナノ秒の解析も OK * setlocale しなくてもよしなに解析してくれる * 実行結果について補足 * 日本語で表示されているのは,POSIX の strftime が勝手に整形したから (ロケールが ja_JP になっているため) * {{{%N}}} は POSIX の strptime がナノ秒を認識できないから (DateTime->strftime / !DateTime::Format::Strptime::strftime を使えばどうにかなることはなる) == AUTOLOAD == * 存在しないメソッドをコールしたときに呼ばれるメソッドの定義ができる {{{ #!perl use strict; use warnings; package Hoge; our $AUTOLOAD; sub new { return bless( {}, shift ); } sub huge { my $self = shift; return "huge"; } sub AUTOLOAD { my $self = shift; ( my $method = $AUTOLOAD ) =~ s/.*://g; return "AUTOLOAD: $method"; } package main; my $hoge = new Hoge(); print $hoge->hoge(), "\n"; print $hoge->huge(), "\n"; }}} * 実行結果 {{{ $ perl Hoge.pm AUTOLOAD: hoge huge }}} = !PersistentPerl = * !PersistentPerl に限った話 == DATA ファイルハンドルの罠 == * !PersistentPerl を使った時は DATA ファイルハンドルを seek できない? {{{ #!perl #!/usr/bin/perperl use strict; use warnings; &main(@ARGV); sub main { my $pos = tell(DATA); print "$pos\n"; print while (); seek( DATA, $pos, 0 ); printf "pos: %d, tell: %d\n", $pos, tell(DATA); } __DATA__ ちょwwwwwwwww なんぞこれー }}} * 実行結果 * seek 後の tell 値が $pos を示していない. もちろん二度目以降の実行では DATA が即 EOF になる {{{ $ ./hoge.pl 258 ちょwwwwwwwww なんぞこれー pos: 258, tell: 297 }}} * ちなみに,普通のファイルハンドルなら seek 可能.