[[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 から使う ===
 * from http://unknownplace.org/memo/2005/12/11#e001
{{{
;;; perltidy-region
(defun perltidy-region ()
  "Run perltidy on the current region."
  (interactive)
  (save-excursion
    (shell-command-on-region (point) (mark) "perltidy -q" nil t)))
(global-set-key "\C-ct" 'perltidy-region)
}}}

== Python で言うところの getattr してみる ==
ていうかむしろ eval してるだけ．
eval じゃなくてホントに getattr したいんだけど，どうやってやるんだろう？

 * {{{hoge.pm}}}
{{{
#!perl
use strict;
use warnings;

package hoge;

our $foo = "hogeraccho";

1;

__END__
}}}
 * {{{unko.pm}}}
{{{
#!perl
use strict;
use warnings;

package unko;

our $foo = "unkokko";

1;

__END__
}}}
 * {{{modules}}} ファイル
{{{
unko
hoge
foo
}}}
 * {{{main.pl}}}
{{{
#!perl
#!/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);
}}}
 * 実行結果
{{{
#!sh
bash$ perl main.pl
$unko::foo = unkokko
$hoge::foo = hogeraccho
WARNING: Can't locate foo.pm in @INC ...
}}}

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

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

 * freeze.pl
{{{
#!perl
#!/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
{{{
#!perl
#!/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;
}
}}}

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

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

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

== ハッシュ関連 ==
=== ハッシュが格納されている配列中で，ハッシュの中のある特定のキーの値が同じものを削除する ===
{{{
#!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}] で返る．

== OOP 関連 ==
=== 引数設定の自動化もどき ===
 * 意味があるのかどうかは知らん．
{{{
#!perl
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 (exists($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 $parent = new Parent(parentname => "jobs");
$parent->parent();

my $child = new Child(childname => "michael", parentname => "mike");
$child->parent();
$child->child();
}}}

== マジカルインクリメント ==
 * 出展: 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;
}}}

== ステップつきスライス ==
 * つまるところ Python での {{{list[start:end:step]}}}．ただし Python のように step に 0 以下の値を入れられない．
{{{
#!perl
use Clone qw(clone);

my @array = (100 .. 150);
my $step  = 3;

for (0 .. 10) {
  print join(", ", &slice(\@array, $_, $#array, $step)), "\n";
}

sub slice($$$$) {
  my ($array, $start, $end, $step) = @_;
  my @subs = ();

  for (my $i = $start; $i < $end; $i += $step) {
    push(@subs, clone($array->[$i]));
  }

  return @subs;
}
}}}
 * 実行結果
{{{
100, 103, 106, 109, 112, 115, 118, 121, 124, 127, 130, 133, 136, 139, 142, 145, 148
101, 104, 107, 110, 113, 116, 119, 122, 125, 128, 131, 134, 137, 140, 143, 146, 149
102, 105, 108, 111, 114, 117, 120, 123, 126, 129, 132, 135, 138, 141, 144, 147
103, 106, 109, 112, 115, 118, 121, 124, 127, 130, 133, 136, 139, 142, 145, 148
104, 107, 110, 113, 116, 119, 122, 125, 128, 131, 134, 137, 140, 143, 146, 149
105, 108, 111, 114, 117, 120, 123, 126, 129, 132, 135, 138, 141, 144, 147
106, 109, 112, 115, 118, 121, 124, 127, 130, 133, 136, 139, 142, 145, 148
107, 110, 113, 116, 119, 122, 125, 128, 131, 134, 137, 140, 143, 146, 149
108, 111, 114, 117, 120, 123, 126, 129, 132, 135, 138, 141, 144, 147
109, 112, 115, 118, 121, 124, 127, 130, 133, 136, 139, 142, 145, 148
110, 113, 116, 119, 122, 125, 128, 131, 134, 137, 140, 143, 146, 149
}}}

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

__END__
hoge
hage
hige
}}}