Version 11 (modified by atzm, 18 years ago) (diff) |
---|
Perl
Python で言うところの getattr してみる
ていうかむしろ eval してるだけ. eval じゃなくてホントに getattr したいんだけど,どうやってやるんだろう?
- hoge.pm
use strict; use warnings; package hoge; our $foo = "hogeraccho"; 1; __END__
- unko.pm
use strict; use warnings; package unko; our $foo = "unkokko"; 1; __END__
- modules ファイル
unko hoge foo
- main.pl
#!/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);
- 実行結果
bash$ perl main.pl $unko::foo = unkokko $hoge::foo = hogeraccho WARNING: Can't locate foo.pm in @INC ...
データの永続化
Storable を使って文字列で Perl オブジェクトをやりとりしてみる.nfreeze を使う場合,改行をエスケープする必要があるようだ.
バイナリでのやりとりも可であれば,nstore を使うのが良い.
- freeze.pl
#!/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
#!/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; }
- 実行結果
$ ./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
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
#!/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
#!/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; }
- 実行結果
$ ./freeze.pl | ./thaw.pl hage
constant とハッシュ
constant な値をハッシュのキーにすると,そのままでは文字列として解釈されてしまい,ハマる原因になる.括弧をつけること.
- ダメな例
use constant HOGE => "hoge"; my %hash = ("hoge" => "raccho"); print $hash{HOGE}, "\n";
- OK な例
use constant HOGE => "hoge"; my %hash = ("hoge" => "raccho"); print $hash{(HOGE)}, "\n";
ハッシュ関連
ハッシュが格納されている配列中で,ハッシュの中のある特定のキーの値が同じものを削除する
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 関連
引数設定の自動化もどき
- 意味があるのかどうかは知らん.
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();
マジカルインクリメント
"perl" と表示
my $A="a";for(1..285075){$A++;}print"$A";
"atzm" と表示
my $A="a";for(1..31784){$A++;}print"$A";
調べる
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];}