wiki:Perl

Version 20 (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];}

HTML 関連

実体参照,文字参照をほげる

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

スタックトレース関連

  • 基本的には Carp モジュールを利用する

予期せぬエラーにスタックトレースをつけてくれ宣言

  • die や warn を置き換えてやれば良い
    use Carp;
    $SIG{__DIE__}  = \&Carp::confess;
    $SIG{__WARN__} = \&Carp::cluck;
    

ステップつきスライス

  • つまるところ Python での list[start:end:step].ただし Python のように step に 0 以下の値を入れられない.
    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