[[PageOutline]]

= Perl =
== [http://perltidy.sourceforge.net/ 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 の時は代わりに [http://unknownplace.org/memo/2005/12/11#e001 perltidy-region] を呼ぶ
   * .emacs に以下を追加
{{{
#!el
;;; 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
{{{
#!perl
#!/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
{{{
#!perl
#!/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;
}
}}}

 * 実行結果
{{{
#!sh
$ ./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
{{{
#!perl
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
{{{
#!perl
#!/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
{{{
#!perl
#!/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;
}
}}}

 * 実行結果
{{{
#!sh
$ ./freeze.pl | ./thaw.pl
hage
}}}

== constant とハッシュ ==
constant な値をハッシュのキーにすると，そのままでは文字列として解釈されてしまい，ハマる原因になる．
constant で定義したものの実体は関数なので，{{{&}}} をつけると良い．

 * ダメな例
{{{
#!perl
use constant HOGE => "hoge";

my %hash = ("hoge" => "raccho");
print $hash{HOGE}, "\n";
}}}

 * OK な例
{{{
#!perl
use constant HOGE => "hoge";

my %hash = ("hoge" => "raccho");
print $hash{&HOGE}, "\n";
}}}

== ファイルハンドル関連 ==
=== in memory file ===
 * Python で言うところの StringIO みたいなもの
   * ↓とすれば $buf 内へ追記されていく
{{{
#!perl
my $buf;
open( HANDLE, '>', \$buf );

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

$fh->print("hogehoge");
}}}

== ハッシュ関連 ==
=== ハッシュが格納されている配列中で，ハッシュの中のある特定のキーの値が同じものを削除する ===
{{{
#!perl
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 に近い．
{{{
#!perl
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-
}}}
{{{
#!sh
$ perl hogehoge.pl 
=== unreachable ===
--- 
hoge: 
  - 
    hage: hige
    huge: unko
    uge: goge
  - 
    hage: hihi
    huge: uho
    uge: uhi-
}}}
 * なお，{{{keys}}} や {{{values}}} を利用することでイテレータを初期化することができる．
   * 上記コードのうち，{{{hoge}}} 関数内の 2 連 {{{dump}}} の間に {{{keys(%{$data});}}} を挿入するだけで実行結果が変化することに注目．

== Java で言う instanceof ==
 * UNIVERSAL を使う
{{{
#!perl
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

== あるオブジェクトにあるメソッドが定義されているかどうか調べる ==
 * UNIVERSAL を使う
{{{
#!perl
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

== マジカルインクリメント ==
 * 出展: http://www.takaaki.info/archives/000101.html
=== "perl" と表示 ===
{{{
#!perl
my $A="a";for(1..285075){$A++;}print"$A";
}}}

=== "atzm" と表示 ===
{{{
#!perl
my $A="a";for(1..31784){$A++;}print"$A";
}}}

=== 調べる ===
{{{
#!perl
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
{{{
#!sh
$ perl -e '@A=reverse split//,$ARGV[0];for(@A){$s+=(ord($_)-96)*(26**$i++)};print $s-1,"\n";' 
}}}

== HTML 関連 ==
=== 実体参照，文字参照をほげる ===
{{{
#!perl
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 を置き換えてやれば良い
{{{
#!perl
use Carp;
$SIG{__DIE__}  = \&Carp::confess;
$SIG{__WARN__} = \&Carp::cluck;
}}}

== データの分離 ==
=== 特殊ファイルハンドル DATA ===
 * {{{__DATA__}}}，{{{__END__}}} 以下は DATA ファイルハンドルで読み出せる．
{{{
#!perl
print while(<DATA>);

__END__
hoge
hage
hige
}}}

=== DATA の罠 ===
 * hoge.pm 内の DATA の position が 1 回目の new で EOF に到達するため，2 回目の new では $self->{'data'} が空になる．
{{{
#!perl
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
}}}
{{{
#!perl
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__":...}}} ．
{{{
#!perl
if (__FILE__ eq $0) {
  ...
}
}}}

== 時刻/日付操作 ==
=== strptime ===
ふざけたことに標準では strptime を使うことができないので，以下のいずれかを別途インストールする必要がある．
両者で strptime 関数への引数の順番が違うので注意．
 * [http://search.cpan.org/dist/POSIX-strptime/lib/POSIX/strptime.pm POSIX::strptime]
{{{
#!perl
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) );
}}}
{{{
#!sh
$ perl hoge.pl 
before: 08:52:20 JST Wed Apr 11 2007
after:  08:52:20 JST Wed Apr 11 2007
}}}
   * POSIX の strptime ではナノ秒の解析はできない
   * setlocale しないとバグる可能性大なので注意
 * [http://search.cpan.org/dist/DateTime-Format-Strptime/lib/DateTime/Format/Strptime.pm DateTime::Format::Strptime]
{{{
#!perl
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) );
}}}
{{{
#!sh
$ 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 の実装
{{{
#!perl
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;
}
}}}
   * 実行結果
{{{
#!sh
$ perl ./hoge.pl
unko
$VAR1 = bless( {
                 'hoge' => 'unko'
               }, 'Hoge' );
}}}

== IP アドレス ==
=== IP アドレス ←→ 数値変換 ===
 * これだけのためにいちいち CPAN モジュールをインストールするのはイヤとかそんな理由
{{{
#!perl
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> );
}
}}}

= !PersistentPerl =
 * !PersistentPerl に限った話

== DATA ファイルハンドルの罠 ==
 * !PersistentPerl を使った時は DATA ファイルハンドルを seek できない?
{{{
#!perl
#!/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 可能．