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();