wiki:Perl
Last modified 15 years ago

  1. Perl
    1.  Perltidy
      1. 設定
      2. Emacs から使う
    2. データの永続化
      1. オブジェクトの永続化
    3. constant とハッシュ
    4. ファイルハンドル関連
      1. in memory file
    5. ハッシュ関連
      1. ハッシュが格納されている配列中で，ハッシュの中のある特定のキーの値が同じものを削除する
      2. each の罠
    6. 動的ほげ
      1. 動的関数呼び出し
    7. Java で言う instanceof
    8. あるオブジェクトにあるメソッドが定義されているかどうか調べる
    9. マジカルインクリメント
      1. "perl" と表示
      2. "atzm" と表示
      3. 調べる
    10. HTML 関連
      1. 実体参照，文字参照をほげる
    11. スタックトレース関連
      1. 予期せぬエラーにスタックトレースをつけてくれ宣言
    12. データの分離
      1. 特殊ファイルハンドル DATA
      2. DATA の罠
    13. スクリプトを直接実行した時だけ呼ぶコード
    14. 時刻/日付操作
      1. strptime
    15. AUTOLOAD
    16. IP アドレス
      1. IP アドレス ←→ 数値変換
    17. I/O バッファ
  2. PersistentPerl
    1. DATA ファイルハンドルの罠

Perl

 Perltidy

  • Perl の Pretty Printer

設定

  • by Perl Best Practices 
    $ cat ~/.perltidyrc
-l=78   # Max line width is 78 cols
-i=4    # Indent level is 4 cols
-ci=4   # Continuation indent is 4 cols
-st     # Output to STDOUT
-se     # Errors to STDERR
-vt=2   # Maximal vertical tightness
-cti=0  # No extra indentation for closing brackets
-pt=1   # Medium parenthesis tightness
-bt=1   # Medium brace tightness
-sbt=1  # Medium square brace tightness
-bbt=1  # Medium block brace tightness
-nsfs   # No space before semicolons
-nolq   # Don't outdent long quoted strings
-wbb="% + - * / x != == >= <= =~ !~ < > | & >= < = **= += *= &= <<= &&= -= /= |= >>= ||= .= %= ^= x="
        # Break before all operators

Emacs から使う

  • indent-region (C-M-\) が呼ばれた際，cperl-mode の時は代わりに  perltidy-region を呼ぶ
    • .emacs に以下を追加 
      ;;; perltidy-region
(defun perltidy-region ()
  "Run perltidy on the current region."
  (interactive)
  (save-excursion
    (shell-command-on-region (point) (mark) "perltidy -q" nil t)))
(add-hook 'cperl-mode-hook '(lambda ()
                              (defalias 'cperl-indent-region 'perltidy-region)
                              ))

データの永続化

Storable を使って文字列で Perl オブジェクトをやりとりしてみる．nfreeze を使う場合，改行をエスケープする必要がある．

バイナリでのやりとりも可であれば，nstore を使うのが良い．

  • freeze.pl 
    #!/usr/bin/perl

use strict;
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 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 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 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 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 な値をハッシュのキーにすると，そのままでは文字列として解釈されてしまい，ハマる原因になる． 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";
print $hash{+HOGE}, "\n";

ファイルハンドル関連

in memory file

  • Python で言うところの StringIO みたいなもの
    • ↓とすれば $buf 内へ追記されていく 
      my $buf;
open( HANDLE, '>', \$buf );

print HANDLE "hogehoge";
    • OO 的に扱いたければ↓な感じでいけるみたい 
      use IO::Handle;
my $fh = new IO::Handle();
my $buf;
open( $fh, '>', \$buf );

$fh->print("hogehoge");

ハッシュ関連

ハッシュが格納されている配列中で，ハッシュの中のある特定のキーの値が同じものを削除する

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}] で返る．

each の罠

  • パッと見，以下のコードでは ===unreachable=== は出力されないように見える．
    • しかし，1 度目の dump コールにより $data のイテレータが $vv->{'uge'} を過ぎた状態で保存されるため，2 度目の dump コールでは該当コードに到達する．
    • each を使う際は最後までイテレートさせないとハマる危険性大．
  • イメージ的には Python で言う yield に近い． 
    use YAML::Syck qw(Load Dump);

&hoge();

sub hoge {
    my $data = Load( join( '', <DATA> ) );
    &dump($data);
    &dump($data);
}

sub dump {
    my $data = shift;
    while ( my ( $k, $v ) = each( %{$data} ) ) {
        foreach my $vv ( @{$v} ) {
            return if ( $vv->{'uge'} eq 'uhi-' );
        }
    }
    print "=== unreachable ===\n";
    print Dump($data);
}

__DATA__
hoge:
  - hage: hige
    huge: unko
    uge:  goge
  - hage: hihi
    huge: uho
    uge:  uhi-

    $ perl hogehoge.pl 
=== unreachable ===
--- 
hoge: 
  - 
    hage: hige
    huge: unko
    uge: goge
  - 
    hage: hihi
    huge: uho
    uge: uhi-
  • なお，keys や values を利用することでイテレータを初期化することができる．
    • 上記コードのうち，hoge 関数内の 2 連 dump の間に keys(%{$data}); を挿入するだけで実行結果が変化することに注目．

動的ほげ

動的関数呼び出し

  • 局所的にシンボリックリファレンスを使って関数を動的に呼び出してみる 
    use strict;
use warnings;
use YAML::Syck qw(Load);

sub _default_handler {
    return -1;
}

sub _handle_hoge {
    return scalar( @{ $_[0] } );
}

sub _handle_unko {
    return scalar( @{ $_[0] } ) + 50;
}

if ( $0 eq __FILE__ ) {
    my $data = Load( join( '', <DATA> ) );

    while ( my ( $k, $v ) = each( %{$data} ) ) {
        ( my $handler = '_handle_' . $k ) =~ s/\s+/_/g;

        my $r = eval {
            no strict 'refs';
            $handler->($v);
        };
        if ($@) {
            $r = _default_handler($v);
        }

        print "$k: $r\n";
    }
}

__DATA__
hoge:
  - one
  - two
  - three
unko:
  - four
  - five
dame:
  - damedame
    • __DATA__ に書かれた YAML の各キー名に対応した _handle_XXXX を動的に呼び出している． ハンドラがなければ _default_handler に fallback している

Java で言う instanceof

  • UNIVERSAL を使う 
    use strict;
use warnings;
use UNIVERSAL qw(isa);
use IO::File;

my $fh = new IO::File("hoge");

if ( isa( $fh, "IO::Handle" ) ) {
  ...
}
    • IO::File は IO::Handle のサブクラスなので true
  • $obj->isa("myclass") というのも可能． ただしこの場合 $obj の内容を選ぶ (undef だったら? とか) ので， 場合によって eval してやる等の処置が重要

あるオブジェクトにあるメソッドが定義されているかどうか調べる

  • UNIVERSAL を使う 
    use strict;
use warnings;
use UNIVERSAL qw(can);
use IO::File;

my $fh = new IO::File("hoge");

if ( can( $fh, "print" ) ) {
  ...
}
    • IO::File には print メソッドが定義されているので true
  • $obj->can("mymethod") というのも可能． ただしこの場合 $obj の内容を選ぶ (undef だったら? とか) ので， 場合によって eval してやる等の処置が重要

マジカルインクリメント

"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;

データの分離

特殊ファイルハンドル DATA

  • __DATA__，__END__ 以下は DATA ファイルハンドルで読み出せる． 
    print while(<DATA>);

__END__
hoge
hage
hige

DATA の罠

  • hoge.pm 内の DATA の position が 1 回目の new で EOF に到達するため，2 回目の new では $self->{'data'} が空になる． 
    package hoge;

sub new {
    my $class = shift;
    my @data  = <DATA>;
    return bless {'data' => \@data}, $class;
}

sub hoge {
    my $self = shift;
    return $self->{'data'};
}

1;

__DATA__
hoge
hage
hige

    use hoge;

my $hoge1 = new hoge();
print "*** 1\n";
print @{$hoge1->hoge()};


my $hoge2 = new hoge();
print "*** 2\n";
print @{$hoge2->hoge()};
  • 何度も new できるようにするためには，以下のようにする必要がある． 
    @@ -5,7 +5,9 @@
 
 sub new {
     my $class = shift;
+    my $pos   = tell DATA;
     my @data  = <DATA>;
+    seek DATA, $pos, 0;
     return bless {'data' => \@data}, $class;
 }

スクリプトを直接実行した時だけ呼ぶコード

  • とどのつまりは Python で言うところの if __name__ == "__main__":... ． 
    if (__FILE__ eq $0) {
  ...
}

時刻/日付操作

strptime

ふざけたことに標準では strptime を使うことができないので，以下のいずれかを別途インストールする必要がある． 両者で strptime 関数への引数の順番が違うので注意．

  •  POSIX::strptime 
    use POSIX qw(strftime mktime locale_h);
use POSIX::strptime;

setlocale(LC_TIME, 'C');

my $date  = '08:52:20 JST Wed Apr 11 2007';
my $fmt   = '%H:%M:%S %Z %a %b %d %Y';
my @times = POSIX::strptime( $date, $fmt );
my $epoch = mktime( @times[0..5] );

print  "before: $date\n";
printf "after:  %s\n", strftime( $fmt, localtime($epoch) );

    $ perl hoge.pl 
before: 08:52:20 JST Wed Apr 11 2007
after:  08:52:20 JST Wed Apr 11 2007
    • POSIX の strptime ではナノ秒の解析はできない
    • setlocale しないとバグる可能性大なので注意
  •  DateTime::Format::Strptime 
    use POSIX qw(strftime);
use DateTime::Format::Strptime qw(strptime);

my $date  = '08:52:20.343 JST Wed Apr 11 2007';
my $fmt   = '%H:%M:%S.%N %Z %a %b %d %Y';
my $dt    = strptime( $fmt, $date );
my $epoch = $dt->epoch();

print  "before: $date\n";
printf "after:  %s\n", strftime( $fmt, localtime($epoch) );

    $ perl hoge.pl
before: 08:52:20.343 JST Wed Apr 11 2007
after:  08:52:20.%N JST 水  4月 11 2007
    • こちらはナノ秒の解析も OK
    • setlocale しなくてもよしなに解析してくれる
    • 実行結果について補足
      • 日本語で表示されているのは，POSIX の strftime が勝手に整形したから (ロケールが ja_JP になっているため)
      • %N は POSIX の strptime がナノ秒を認識できないから (DateTime?->strftime / !DateTime::Format::Strptime::strftime を使えばどうにかなることはなる)

AUTOLOAD

  • 存在しないメソッドをコールしたときに呼ばれるメソッドの定義ができる
    • 以下は，これを利用した getter/setter の実装 
      use strict;
use warnings;

package Hoge;

sub new {
    return bless( {}, shift );
}

sub AUTOLOAD {
    my $self   = shift;
    my $value  = shift;
    my $method = our $AUTOLOAD;

    $method =~ s/.*:://o;

    if ( $method =~ /^get_(.+)/ ) {
        return $self->{$1};
    }
    elsif ( $method =~ /^set_(.+)/ ) {
        $self->{$1} = $value;
        return;
    }
    elsif ( $method eq 'DESTROY' ) {
        return;
    }

    die sprintf( "Can't locate object method \"%s\" via package \"%s\" at %s line %u.\n",
                 $method, __PACKAGE__, __FILE__, __LINE__ );
}


package main;

use Data::Dumper;

if ( __FILE__ eq $0 ) {
    exit( &main(@ARGV) );
}

sub main {
    my $hoge = new Hoge();

    $hoge->set_hoge("unko");
    print $hoge->get_hoge(), "\n";
    print Dumper($hoge);

    return 0;
}
    • 実行結果 
      $ perl ./hoge.pl
unko
$VAR1 = bless( {
                 'hoge' => 'unko'
               }, 'Hoge' );

IP アドレス

IP アドレス ←→ 数値変換

  • これだけのためにいちいち CPAN モジュールをインストールするのはイヤとかそんな理由 
    sub num2ipv4addr {
    return join( '.', unpack( 'C*', pack( 'N', shift ) ) );
}

sub ipv4addr2num {
    return unpack( 'N', pack( 'C*', split( /\./, shift ) ) );
}

sub main {
    foreach my $arg (@_) {
        if ( $arg =~ /^\d+$/ ) {
            print num2ipv4addr($arg), "\n";
        }
        else {
            print ipv4addr2num($arg), "\n";
        }
    }
}

if ( $0 eq __FILE__ ) {
    &main( @ARGV ? @ARGV : <STDIN> );
}

I/O バッファ

sys* な I/O 操作関数の間違った使い方をすると酷い目に遭うというお話

  • iotest.pl 
    use strict;
use warnings;
use IO::File;
use Fcntl qw(:seek);

my $io = IO::File->new($0);

$io->sysseek( 0, SEEK_END );
printf "%s\n", defined( $io->getline() ) ? "defined" : "undef";

while (1) {
    if ( defined( my $line = $io->getline() ) ) {
        my $h = `hostname`;
        print $line;
        next;
    }
    sleep(1);
}

__END__
  • 実行 
    $ perl iotest.pl 
undef
  • 実行中に別端末から追記 
    $ echo -en "hogehoge\nfoofoo\n" >> iotest.pl

最大 1 秒後に追記された行が表示されるかと思いきや，そうはならない (少なくとも 5.8.8 では)．

ポインタがファイル先頭から 9 バイト ("hogehoge\n") 目に移動し， そこからファイル内容が全て読み出される．

8 行目の sysseek を seek に変更すれば解決する．

PersistentPerl

  • PersistentPerl に限った話

DATA ファイルハンドルの罠

  • PersistentPerl を使った時は DATA ファイルハンドルを seek できない? 
    #!/usr/bin/perperl

use strict;
use warnings;

&main(@ARGV);

sub main {
    my $pos = tell(DATA);
    print "$pos\n";

    print while (<DATA>);

    seek( DATA, $pos, 0 );
    printf "pos: %d, tell: %d\n", $pos, tell(DATA);
}

__DATA__
ちょwwwwwwwww
なんぞこれー
    • 実行結果
      • seek 後の tell 値が $pos を示していない． もちろん perperl_backend は DATA を保持するので， 二度目以降の実行では DATA が即 EOF になる 
        $ ./hoge.pl
258
ちょwwwwwwwww
なんぞこれー

pos: 258, tell: 297

$ ./hoge.pl
297
pos: 297, tell: 297
  • ちなみに，普通のファイルハンドルなら seek 可能．