wiki:Perl

Context Navigation

Version 49 (modified by atzm, 14 years ago) (diff)
--

Perl
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 してやる等の処置が重要

マジカルインクリメント

出展: http://www.takaaki.info/archives/000101.html

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

高速バージョン from http://hori-uchi.com/archives/000243.html#comments

$ perl -e '@A=reverse split//,$ARGV[0];for(@A){$s+=(ord($_)-96)*(26**$i++)};print $s-1,"\n";'

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

こういうのもあるらしい http://www.kawa.net/works/perl/i18n-emoji/EntityRef.pm.html

スタックトレース関連

基本的には 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 可能．

Download in other formats:

Plain Text