wiki:Perl

Version 8 (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 (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 $child = new Child(childname => "michael", parentname => "mike");
    $child->parent();
    $child->child();