[[PageOutline]] = Perl = == 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"; }}} == ハッシュ関連 == === ハッシュが格納されている配列中で,ハッシュの中のある特定のキーの値が同じものを削除する === {{{ #!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}] で返る. == 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 (defined($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(); }}}