Perlメモ

更新履歴

はじめに

排他制御(ファイルロック)をする

sub my_flock { my %lfh = (dir => './lockdir/', basename => 'lockfile', timeout => 60, trytime => 10, @_); $lfh{path} = $lfh{dir} . $lfh{basename}; for (my $i = 0; $i < $lfh{trytime}; $i++, sleep 1) { return \%lfh if (rename($lfh{path}, $lfh{current} = $lfh{path} . time)); } opendir(LOCKDIR, $lfh{dir}); my @filelist = readdir(LOCKDIR); closedir(LOCKDIR); foreach (@filelist) { if (/^$lfh{basename}(\d+)/) { return \%lfh if (time - $1 > $lfh{timeout} and rename($lfh{dir} . $_, $lfh{current} = $lfh{path} . time)); last; } } undef; } sub my_funlock { rename($_[0]->{current}, $_[0]->{path}); } # ロックする(タイムアウトあり) $lfh = my_flock() or die 'Busy!'; # アンロックする my_funlock($lfh);

複数のプロセスが同時にある 1つのファイルを読み書きする可能性 がある場合，排他制御をしなければなりません．排他制 御をする方法はいくつかありますが，このスクリプトは次の方針に基づいています．

1. どんなプラットフォームでも使えること
2. 異常なロック状態を回避できること

排他制御をする方法として flock 関数 や symlink 関数を使う方法がありますが，これらの関数は プラットフォームによってはサポートされていません．したがって，1 を満たすため にはこれらの方法を使うことはできません．それ以外の方法としては， mkdir 関数を使う方法と rename 関数を使う方法が考えられます．次に 2 につい てですが，異常なロック状態とは，あるプロセスがロックした状態のまま何らかの原 因で死んだ場合に，ロックが解除されずに残ってしまった状態のことです． flock を使っている場合は，ロック状態でプロセスが死んだとき自動的にロックが解除されますので，異常なロック状態は起こ りません．しかし， symlink や mkdir， rename などを使う場合にはスクリプト側での 対処が必要になります．

具体的にどのように対処するかですが，ロック状態がある一定の時間を経過して いた場合には異常と判断し，他のプロセスがロック状態を解除してもよいことにしま す．実はここに落とし穴が存在します．排他制御をする方法としてなぜ symlink や mkdir， rename を使うのか？ それはこれらの関数が，ロックできるかどうかのテストと実際に ロックする操作を同時に行なうことができる atomic な関数であるからです． 話を戻して，異常なロック状態を解除するときのことを考えます．たとえば， mkdir を使ったロックの方法において，異常なロック状態のときにロッ クを解除するには，次のようなスクリプトになります．

rmdir($lockdir) if (time - (stat($lockdir))[9] > 60);

ロック状態が 60秒以上経過していた場合にはロックを解除すると いうスクリプトですが，これが symlink や mkdir， rename のときと違って，ロックを解除するかどうかの判断と実際にロッ クを解除する操作を同時に行なっているわけではないということが問題となります． 具体的に何がまずいのかというと，正常なロック状態も解除して しまうことがあるということです．それは次のような場合です．

プロセスＡ	プロセスＢ	プロセスＣ
異常と判断	異常と判断	↓
↓	↓	↓
ロック解除	↓	↓
↓	↓	ロック
↓	ロック解除	↓

複数のプロセスでロック状態が異常であると判断し，そのうちの 1つがロックを解除したことにより，別のプロセスがロックしたにもか かわらず，先ほどロック状態が異常であると判断したプロセスによってこの正常なロッ クを解除されてしまう可能性があります．

この方法の問題点は，異常なロック状態を解除する操作が正常なロック状態をも 解除できてしまうことにあります．逆に言えば，異常なロック状態を解除する操作に よって正常なロック状態を解除できなければ問題ないわけです．そのためにはどうす ればよいのか？ 答えはロック状態が常に変化していけば よいということです．そして，これを実現するのに都合がよいのが rename による方法になります．

最初のスクリプトで説明しますと，ロックファイルが lockfile という 名前のときがロックが解除されている状態で，lockfile987654321 のよう に後ろに作成時刻がついた状態がロック状態になります．こうすることで 先ほどの例で，プロセスＢによってプロセスＣのロック が解除されてしまったという状況を回避することができます． なぜなら，プロセスＣによって rename されたロックファ イルの名前はすでにプロセスＢが知っている名前とは違っているから です．最初のスクリプトでは一旦ロックを解除するのではなく，異常なロック状態を 解除しつつ，新たなロック状態へと移行させています．

スクリプトの注意点としては，あらかじめロック用のディレクトリとファイルを 用意しておくこと，ディレクトリに書き込み属性をつけておくこと， dir の値には最後に / などのデリミタをつけておくこ とです． $lfh = my_flock(basename => 'lockfileA'); のように呼び出すことでパラメータを変更できます．また，my_flock() はロックに失敗(タイムアウト)すると undef を返します． ロックするまでブロックしたい場合には次のように書きます．

# ロックする(タイムアウトなし)
1 while (not defined($lfh = my_flock()));

最後に，ファイルを読み込み，それを加工した上で書き込む場合の安全な排他制 御の手順を書いておきます．

1. ロックする
2. ファイルを読み込む
3. 一時ファイルに書き込む
4. 一時ファイルを元ファイルにリネームする
5. アンロックする

ファイルの中身を逆順に表示する

# ファイル $file の中身を逆順に表示する

$bufsize = 1024;
open(FILE, "< $file");
binmode(FILE);
$size = (-s FILE) / $bufsize;
$pos += $size <=> ($pos = int($size));
while ($pos--) {
  seek(FILE, $bufsize * $pos, 0);  
  read(FILE, $buf, $bufsize);
  $buf .= $buf_tmp;
  ($buf_tmp, @lines) = $buf =~ /[^\x0D\x0A]*\x0D?\x0A?/g;
  pop(@lines);
  foreach (reverse @lines) {
    print $_;
    print "\n" if $_ !~ /[\x0D\x0A]$/;
  }
}
close(FILE);
print $buf_tmp;

このスクリプトはファイルを $bufsize バイトずつ 読み込んで逆順に表示するので，ファイル全体を一度に読み込む方法に 比べて少ないメモリで実行させることができます．

$size への代入文にある -s はファイルテスト演算子の 1つでファイルサイズを返します． $pos にはファイルサイズを $bufsize で割って切り上げた値が代入されます．切り上げに関しては 「数字を切り上げる」を参照してください． while ブロックは $pos 回に分けてファイルを読み込んで処理するということをやっています．

$buf には $bufsize バイトずつ 読み込んだファイルの一部が代入されます．ファイルの中身を逆順に表示する ためには，まずは $buf の中身を行ごとに分ける必要が あります．それを行なっているのが $buf =~ /[^\x0D\x0A]*\x0D?\x0A?/g; の部分になります． この正規表現は，改行コード以外の文字が 0文字以上続き，その後の 改行コードまでを表わしています．つまり，これで 1行分を 取り出しているわけです．改行コード以外の文字が 0文字以上で あるので空行にもマッチします．また，改行コードの部分の正規表現 \x0D?\x0A? は改行コードが \x0D\x0A でも \x0D でも \x0A でもよいことはもちろ んのこと，ファイルの最後が改行で終わっていない行だった場合にもマッチします． ここまでの話ですでにお気づきの人もいるかもしれませんが，この 1行分にマッチする正規表現は，実は空文字列にも マッチします．そして，それは必ず $buf の最後で マッチさせる文字が何もない状態で一度だけ起こります．したがって，この無意味な 空文字列を削除するために，次の行で pop(@lines); しています．

$buf の中身を行ごとに分けるには split 関数を使って， split(/\x0D\x0A|\x0D|\x0A/, $buf); とすればいいのでは ないかと思うかもしれませんが，この方法では $buf の 最後に空行があった場合にまずいことになります． split 関数の第 3引数を省略すると， split した結果の最後が空文字列であった 場合には自動的に削除されます．つまり，最後に空行が連続する文字列 "foo\nbar\n\n\n" のようなものを split すると ('foo', 'bar') しか残らないため，本来 ('foo', 'bar', '', '') となってほしかった最後の空行がなくなってしまいます．

そこで最後の空文字列を自動的に削除させないために，第 3引数に split(/\x0D\x0A|\x0D|\x0A/, $buf, -1); のように負数を指定すればいいのではないかと思うかも しれませんが，これでもまだうまくいきません．例えば， "foo\nbar\n" を split すると，今度は ('foo', 'bar', '') のように最後の改行コードの後ろの空文字列が削除されずに残ってしまいます． そこで，これに対処するために最後が空文字列であった場合には削除するように， pop(@lines) if $lines[-1] eq ''; とする手があります． しかし，これを行なうことによって，ちょうど $bufsize ずつ区切った前後が改行コードであった場合には 必要な空行まで削除してしまいます．そのためさらに， read の後に $buf_tmp = "\n" if $buf_tmp eq ''; を入れる必要があります． これで正規表現を使った方法とほぼ同じ動作をするようになります． ただ，私がベンチマークをとって調べたところ，正規表現を使った方法の 方が速かったためそちらを採用しました．

ファイルの最後の数行だけ表示する

# ファイル $file の最後の最大 $n行だけ表示する

$bufsize = 1024;
open(FILE, "< $file");
binmode(FILE);
$size = (-s FILE) / $bufsize;
$pos += $size <=> ($pos = int($size));
while ($pos--) {
  seek(FILE, $bufsize * $pos, 0);  
  read(FILE, $buf, $bufsize);
  $buf .= $buf_tmp;
  ($buf_tmp, @lines) = $buf =~ /[^\x0D\x0A]*\x0D?\x0A?/g;
  pop(@lines);
  unshift(@tail, @lines);
  last if @tail >= $n;
}
close(FILE);
unshift(@tail, $buf_tmp);
@tail = @tail[-$n .. -1] if @tail > $n;
foreach (@tail) {
  print $_;
}

このスクリプトの基本は 「ファイルの中身を逆順に表示する」のスクリプトと 同じです．スクリプトの詳細についてはそちらを参照してください．違いとしては $n 行を取り出すことができた時点ですぐに while ブロックを抜けるようにしているところです．

実際に表示する直前では @tail の大きさを調べ，もし $n よりも大きければ最後の $n 個だけを 配列スライスで取り出して代入し直しています． .. は範囲演算子と言い， リストコンテキストで実行した場合は範囲演算子の前の 値から後ろの値までのリストを返します．つまり，この場合は (-$n, -$n+1,..., -2, -1) というリストになります． 配列の添え字が負数だった場合には後ろから数えた場所になるので，この場合は 配列の最後の $n 個分ということになります．

ファイルから 1行ランダムに選択する

# ファイル $file から 1行ランダムに選択する

srand;
open(FILE, "< $file");
rand($.) < 1 and $line = $_ while <FILE>;
close(FILE);
print $line;

このスクリプトではファイル全体をメモリに読み込まない ので少ないメモリで実行させることができます．また， ファイルの行数があらかじめわかっている必要もありません．

ファイル全体に対して while 文を回すわけですが， 1行ずつ読み込んで実行される部分が while よりも左側の部分です．この部分は 2つの式の and を取っています． 論理演算子 and は左側が真の場合に限り右側が評価されます．つまり，この部分は if 文を使って次のように書いたものと同じ意味になります．

if (rand($.) < 1) {
  $line = $_;
}

特殊変数 $. は最後に読み込んだファイルの行番号を返します．したがって，この条件が 成立する確率は 1/$. になります．たとえば， 1行目のときは 1/1， 2行目のときは 1/2， 3行目のときは 1/3 の確率というようになります． これでなぜランダムに 1行選択できるのかという問題は数学の 問題です．簡単に書きますと，全部で 3行のファイルだった場合に， 1行目が選択されるのは，1行目で条件が真となり， 2行目と3行目では条件が偽となる必要があります． したがって，確率は 1/1 * (1 - 1/2) * (1 - 1/3) = 1/3 となり， ちゃんと行数で割った確率になります．2行目が選択されるのは， 条件が 2行目で真で 3行目で偽の場合です． 2行目で真になればそれ以前の条件は無関係だというのはいい ですよね？ その結果，確率はやはり 1/2 * (1 - 1/3) = 1/3 となり， 行数で割った確率になります．

ディレクトリ(フォルダ)サイズを求める

# ディレクトリ $dir のサイズ $size を求める

use File::Find;

find(sub {$size += -s if -f}, $dir);
print $size, "bytes\n";

このスクリプトはディレクトリ $dir 以下の すべてのファイルのファイルサイズの合計を求めています．あるディレクトリ以下の すべてのファイルまたはディレクトリに対して何か処理したい 場合には標準モジュール File::Find の find 関数を使うのが簡単です． この関数は第 2引数で与えたディレクトリに対して，ファイル またはディレクトリを幅優先で探索し，見つかった ファイルまたはディレクトリを $_ に 1つ代入しては第 1引数で与えた関数を実行します． 正確には第 1引数に は関数へのリファレンスを与えます． このスクリプトでは無名関数へのリファレンスを 与えています．これは次のように書いても同じです．

# ディレクトリ $dir のサイズ $size を求める(わかりやすく)

use File::Find;

find(\&wanted, $dir);
print $size, "bytes\n";

sub wanted {
  $size += -s $_ if -f $_;
}

-s はファイルテスト演算子の 1つで ファイルサイズを返します． -f はディレクトリやシンボリックリンクなどではなく普通のファイルのときに 真となります．幅優先ではなく深さ優先で 処理したい場合には finddepth 関数を使います．

タグを削除する

$str は EUC-JP という前提ですので， 必要ならばあらかじめ EUC-JP に変換しておいてください． 漢字コードの変換に関しては 「漢字コードを EUC-JP に変換して処理する」を参照．

# $str の中のタグを削除した $result を作る
# $tag_regex と $tag_regex_ は別途参照

$text_regex = q{[^<]*};

$result = '';
while ($str =~ /($text_regex)($tag_regex)?/gso) {
  last if $1 eq '' and $2 eq '';
  $result .= $1;
  $tag_tmp = $2;
  if ($tag_tmp =~ /^<(XMP|PLAINTEXT|SCRIPT)(?![0-9A-Za-z])/i) {
    $str =~ /(.*?)(?:<\/$1(?![0-9A-Za-z])$tag_regex_|$)/gsi;
    ($text_tmp = $1) =~ s/</&lt;/g;
    $text_tmp =~ s/>/&gt;/g;
    $result .= $text_tmp;
  }
}

このスクリプトの基本は 「自動で URI(URL) のリンクを張る」のスクリプトと 同じです．詳しくはそちらを参照してください． $tag_regex および $tag_regex_ については 「HTMLタグの正規表現」のスクリプトを 正規表現として使います．また， $str には HTML文書全体を入れておきます． 注意が必要な点としましては， XMPタグや PLAINTEXTタグを削除した場合には， それまでその中で無効だったタグが有効になってしまう可能性があることです． そのため，XMPタグや PLAINTEXTタグを削除するときには， その中の < を < に， > を > に変換しています．SCRIPTタグについても同様です．

次のようにしてタグの開始 < と終了 > にだけ注目してタグを削除する方法では うまくいかない場合があります．

# $str の中のタグを削除した $result を作る(不完全)

($result = $str) =~ s/<[^>]*>//g;

具体的には次のような不具合があります．

• <!-- <FOO> --> のようなコメントの <!-- <FOO> を削除してしまう．
• <FOO BAR=">"> のようにダブルクォートで囲んだ中に > があると，そこをタグの終了と間違って <FOO BAR="> を削除してしまう．
• <XMP><FOO></XMP> のように XMPタグや PLAINTEXTタグ， SCRIPTタグの中の一見タグに見える <FOO> も削除してしまう．

最初のスクリプトではこのような場合にもうまくいくようになっています． ただし，HTML文書として正しく書かれている場合を想定して いますので，< に対応する > がないときなどは予期せぬ動作をすることに なります．

もし BRタグや Aタグなど特定のタグだけは 削除したくない場合には， $tag_tmp = $2; の後に， 次のようにして $tag_tmp を $result に加えるようにすればできます．

  $result .= $tag_tmp if $tag_tmp =~ /^<\/?(BR|A)(?![0-9A-Za-z])/i;

逆に FONTタグや IMGタグなど特定のタグだけ 削除したい場合には， $tag_tmp = $2; の後に， 次のようにして $tag_tmp を $result に加えるようにすればできます．

  $result .= $tag_tmp if $tag_tmp !~ /^<\/?(FONT|IMG)(?![0-9A-Za-z])/i;

モジュール HTML::TokeParser の get_text メソッド，または get_trimmed_text メソッドや， striphtml を使っても同じようなことができます．

自動で URI(URL) のリンクを張る

$str は EUC-JP という前提ですので， 必要ならばあらかじめ EUC-JP に変換しておいてください． 漢字コードの変換に関しては 「漢字コードを EUC-JP に変換して処理する」を参照． # $str の中の URI(URL) にリンクを張った $result を作る # $tag_regex と $tag_regex_ は別途参照 # $http_URL_regex と $ftp_URL_regex および $mail_regex は別途参照 $text_regex = q{[^<]*}; $result = ''; $skip = 0; while ($str =~ /($text_regex)($tag_regex)?/gso) { last if $1 eq '' and $2 eq ''; $text_tmp = $1; $tag_tmp = $2; if ($skip) { $result .= $text_tmp . $tag_tmp; $skip = 0 if $tag_tmp =~ /^<\/[aA](?![0-9A-Za-z])/; } else { $text_tmp =~ s{($http_URL_regex|$ftp_URL_regex|($mail_regex))} {my($org, $mail) = ($1, $2); (my $tmp = $org) =~ s/"/&quot;/g; '<A HREF="' . ($mail ne '' ? 'mailto:' : '') . "$tmp\">$org</A>"}ego; $result .= $text_tmp . $tag_tmp; $skip = 1 if $tag_tmp =~ /^<[aA](?![0-9A-Za-z])/; if ($tag_tmp =~ /^<(XMP|PLAINTEXT|SCRIPT)(?![0-9A-Za-z])/i) { $str =~ /(.*?(?:<\/$1(?![0-9A-Za-z])$tag_regex_|$))/gsi; $result .= $1; } } }

$http_URL_regex については 「http URL の正規表現」， $ftp_URL_regex については 「ftp URL の正規表現」， $mail_regex については「メールアドレスの正規表現」の最後に書いてある スクリプトを正規表現として使います．また， $tag_regex および $tag_regex_ については 「HTMLタグの正規表現」のスクリプトを 正規表現として使います．また， $str には HTML文書全体を入れておきます． このスクリプトは以下の項目に 当てはまらない http URL と ftp URL およびメールアドレスについてリンクを張ります．

• タグ(コメント)の内部である．
• Aタグでリンクが張ってある．
• XMPタグ，PLAINTEXTタグ， SCRIPTタグの有効範囲内である．

このスクリプトの説明を簡単にします． $str に対して，テキスト部分とタグ部分をそれぞれ 1つずつ探して while 文 をまわします．タグ部分は特に処理する必要は ないのでそのままです． $skip は Aタグでリンクを張り始めたときに 1 になります．このときは テキスト部分を特に処理することなくそのままにします．Aタグが 閉じたときに $skip を 0 に戻します． Aタグでリンクを張っていないとき，テキスト部分に http URL か ftp URL またはメールアドレスを見つけた 場合にはリンクを張ります．

もし，タグ部分が XMPタグ，または， PLAINTEXTタグだった場合には，次に対応する閉じタグまで無条件に スキップします．無条件というのは，while 文にある条件でテキスト部分とタグ部分を取り出すことができなくなるため， 閉じタグだけに注目するということです．なぜなら，これらのタグの有効範囲内では 他のタグが無効になり， そのまま表示されるからです．逆に言えば，これらのタグの有効範囲内では タグに見えてもタグではなく，普通のテキストと同じように扱わなくてはならないと いうことです．ただし，この部分に http URL や ftp URL，メールアドレスがある場合でもリンクは張りません． もし張ったとしても，それはそのまま表示されてしまい意味がないからです． SCRIPTタグについても同様です．

$str に対するパターンマッチが行なわれている 2ヶ所とも に修飾子 g がつけられていることに注目してください．修飾子 g をつけたパターンマッチをスカラーコンテキストで 行なうと，前回どこまでパターンマッチを行なったかを保存しておいて，次回 その続きから検索を始めてくれます．このスクリプトでは基本的にテキスト部分と タグ部分を 1つずつ探して while 文をまわしているのですが，XMPタグ， PLAINTEXTタグ，SCRIPTタグのときだけは 別処理をする必要があります．その処理終了後 while 文に戻ったときには，その続きからパターンマッチをしてもらう 必要があります． このようなときに， $str に対するどちらのパターンマッチに おいても修飾子 g がつけられていますので， どちらの場合も都合よく続きからパターンマッチを始めることができるわけです．

置換によってリンクを張る処理ですが，単純に次のように行なったのでは 2つの理由からまずいことになります．

    $text_tmp =~ s/($http_URL_regex)/<A HREF="$1">$1<\/A>/go;
    $text_tmp =~ s/($ftp_URL_regex)/<A HREF="$1">$1<\/A>/go;
    $text_tmp =~ s/($mail_regex)/<A HREF="mailto:$1">$1<\/A>/go;

1つ目の理由は，タグの中ではダブルクォートで囲む都合上， マッチしたものがダブルクォートを含んでいるとまずいことになるということです． そこで，ダブルクォートで囲む部分については，マッチしたものに含まれる ダブルクォートを &quot; に変換するという処理が 必要になります．

2つ目の理由ですが，置換の処理が http URL， ftp URL，メールアドレスのそれぞれについて独立して 行なわれているということです．これらは互いに他の正規表現にマッチする部分を 含むことができます．具体的な例で言いますと，次のようなものが挙げられます．

http://www.din.or.jp/~ohzaki/?ftp://ftp.din.or.jp/+foobar@example.com
ftp://ftp.din.or.jp/foobar@example.com
"http://www.din.or.jp/~ohzaki/?ftp://ftp.din.or.jp/"@example.com

上から順に http URL，ftp URL，メールアドレス となっています．これらを独立して置換処理した場合，メールアドレスの一部を http URL として置換してしまったり，http URL の一部を ftp URL として置換してしまうというようなことが 起こってしまいます．どちらがどちらに含まれるのかわからないので，置換処理の 順番でどうこうできる問題ではありません．幸いなことに，先頭部分が他の 正規表現にマッチすることはありませんので，これらの置換処理を 1つの正規表現としてまとめて，1回の置換処理で 行なうことにより，うまくリンクを張ることができます．

文字の正規表現

# 半角スペース
$space = '\x20';

# 全角スペース
$Zspace = '(?:\xA1\xA1)'; # EUC-JP
$Zspace_sjis = '(?:\x81\x40)'; # SJIS

# 全角数字 [０-９]
$Zdigit = '(?:\xA3[\xB0-\xB9])'; # EUC-JP
$Zdigit_sjis = '(?:\x82[\x4F-\x58])'; # SJIS

# 全角大文字 [Ａ-Ｚ]
$Zuletter = '(?:\xA3[\xC1-\xDA])'; # EUC-JP
$Zuletter_sjis = '(?:\x82[\x60-\x79])'; # SJIS

# 全角小文字 [ａ-ｚ]
$Zlletter = '(?:\xA3[\xE1-\xFA])'; # EUC-JP
$Zlletter_sjis = '(?:\x82[\x81-\x9A])'; # SJIS

# 全角アルファベット [Ａ-Ｚａ-ｚ]
$Zalphabet = '(?:\xA3[\xC1-\xDA\xE1-\xFA])'; # EUC-JP
$Zalphabet_sjis = '(?:\x82[\x60-\x79\x81-\x9A])'; # SJIS

# 全角ひらがな [ぁ-ん]
$Zhiragana = '(?:\xA4[\xA1-\xF3])'; # EUC-JP
$Zhiragana_sjis = '(?:\x82[\x9F-\xF1])'; # SJIS

# 全角ひらがな(拡張) [ぁ-ん゛゜ゝゞ]
$ZhiraganaExt = '(?:\xA4[\xA1-\xF3]|\xA1[\xAB\xAC\xB5\xB6])'; # EUC-JP
$ZhiraganaExt_sjis = '(?:\x82[\x9F-\xF1]|\x81[\x4A\x4B\x54\x55])'; # SJIS

# 全角カタカナ [ァ-ヶ]
$Zkatakana = '(?:\xA5[\xA1-\xF6])'; # EUC-JP
$Zkatakana_sjis = '(?:\x83[\x40-\x96])'; # SJIS

# 全角カタカナ(拡張) [ァ-ヶ・ーヽヾ]
$ZkatakanaExt = '(?:\xA5[\xA1-\xF6]|\xA1[\xA6\xBC\xB3\xB4])'; # EUC-JP
$ZkatakanaExt_sjis = '(?:\x83[\x40-\x96]|\x81[\x45\x5B\x52\x53])'; # SJIS

# 半角カタカナ [ヲ-゜]
$Hkatakana = '(?:\x8E[\xA6-\xDF])'; # EUC-JP
$Hkatakana_sjis = '[\xA6-\xDF]'; # SJIS

# EUC-JP文字
$ascii = '[\x00-\x7F]'; # 1バイト EUC-JP文字
$twoBytes = '(?:[\x8E\xA1-\xFE][\xA1-\xFE])'; # 2バイト EUC-JP文字
$threeBytes = '(?:\x8F[\xA1-\xFE][\xA1-\xFE])'; # 3バイト EUC-JP文字
$character = "(?:$ascii|$twoBytes|$threeBytes)"; # EUC-JP文字

# EUC-JP文字(機種依存文字・未定義領域・3バイト文字を含まない)
$character_strict = '(?:[\x00-\x7F]|' # ASCII
  . '\x8E[\xA1-\xDF]|' # 半角カタカナ
  . '[\xA1\xB0-\xCE\xD0-\xF3][\xA1-\xFE]|' # 1,16-46,48-83区
  . '\xA2[\xA1-\xAE\xBA-\xC1\xCA-\xD0\xDC-\xEA\xF2-\xF9\xFE]|' # 2区
  . '\xA3[\xB0-\xB9\xC1-\xDA\xE1-\xFA]|' # 3区
  . '\xA4[\xA1-\xF3]|' # 4区
  . '\xA5[\xA1-\xF6]|' # 5区
  . '\xA6[\xA1-\xB8\xC1-\xD8]|' # 6区
  . '\xA7[\xA1-\xC1\xD1-\xF1]|' # 7区
  . '\xA8[\xA1-\xC0]|' # 8区
  . '\xCF[\xA1-\xD3]|' # 47区
  . '\xF4[\xA1-\xA6])'; # 84区

# EUC-JP未定義文字(機種依存文字・3バイト文字を含む)
$character_undef = '(?:[\xA9-\xAF\xF5-\xFE][\xA1-\xFE]|' # 9-15,85-94区
  . '\x8E[\xE0-\xFE]|' # 半角カタカナ
  . '\xA2[\xAF-\xB9\xC2-\xC9\xD1-\xDB\xEB-\xF1\xFA-\xFD]|' # 2区
  . '\xA3[\XA1-\xAF\xBA-\xC0\xDB-\xE0\xFB-\xFE]|' # 3区
  . '\xA4[\xF4-\xFE]|' # 4区
  . '\xA5[\xF7-\xFE]|' # 5区
  . '\xA6[\xB9-\xC0\xD9-\xFE]|' # 6区
  . '\xA7[\xC2-\xD0\xF2-\xFE]|' # 7区
  . '\xA8[\xC1-\xFE]|' # 8区
  . '\xCF[\xD4-\xFE]|' # 47区
  . '\xF4[\xA7-\xFE]|' # 84区
  . '\x8F[\xA1-\xFE][\xA1-\xFE])'; # 3バイト文字

# SJIS文字
$oneByte_sjis = '[\x00-\x7F\xA1-\xDF]'; # 1バイト SJIS文字
$twoBytes_sjis =
  '(?:[\x81-\x9F\xE0-\xFC][\x40-\x7E\x80-\xFC])'; # 2バイト SJIS文字
$character_sjis = "(?:$oneByte_sjis|$twoBytes_sjis)"; # SJIS文字

# SJIS文字(機種依存文字・未定義領域を含まない)
$character_sjis_strict = '(?:[\x00-\x7F\xA1-\xDF]|' # ASCII，半角カタカナ
  . '[\x89-\x97\x99-\x9F\xE0-\xE9][\x40-\x7E\x80-\xFC]|' # 17-46,49-82区
  . '\x81[\x40-\x7E\x80-\xAC\xB8-\xBF\xC8-\xCE\xDA-\xE8\xF0-\xF7\xFC]|' # 1,2区
  . '\x82[\x4F-\x58\x60-\x79\x81-\x9A\x9F-\xF1]|' # 3,4区
  . '\x83[\x40-\x7E\x80-\x96\x9F-\xB6\xBF-\xD6]|' # 5,6区
  . '\x84[\x40-\x60\x70-\x7E\x80-\x91\x9F-\xBE]|' # 7,8区
  . '\x88[\x9F-\xFC]|' # 15,16区
  . '\x98[\x40-\x72\x9F-\xFC]|' # 47,48区
  . '\xEA[\x40-\x7E\x80-\xA4])'; # 83,84区

# SJIS未定義文字(機種依存文字を含む)
$character_sjis_undef =
  '(?:[\x85-\x87\xEB-\xFC][\x40-\x7E\x80-\xFC]|' # 9-14,85-120区
  . '\x81[\xAD-\xB7\xC0-\xC7\xCF-\xD9\xE9-\xEF\xF8-\xFB]|' # 1,2区
  . '\x82[\x40-\x4E\x59-\x5F\x7A-\x7E\x80\x9B-\x9E\xF2-\xFC]|' # 3,4区
  . '\x83[\x97-\x9E\xB7-\xBE\xD7-\xFC]|' # 5,6区
  . '\x84[\x61-\x6F\x92-\x9E\xBF-\xFC]|' # 7,8区
  . '\x88[\x40-\x7E\x80-\x9E]|' # 15,16区
  . '\x98[\x73-\x7E\x80-\x9E]|' # 47,48区
  . '\xEA[\xA5-\xFC])'; # 83,84区

# ドコモ絵文字
$iPictograph_base = '(?:\xF8[\x9F-\xFC]|' # 基本絵文字(SJIS)
  . '\xF9[\x40-\x49\x50-\x52\x55-\x57\x5B-\x5E\x72-\x7E\x80-\xB0])';
$iPictograph_ext = '(?:\xF9[\xB1-\xFC])'; # 拡張絵文字(SJIS)
$iPictograph =
  '(?:$iPictograph_base|$iPictograph_ext)'; # iモード対応 絵文字(SJIS)

日本語の扱いについては「日本語を扱う」を参照．

個々の機種依存文字についてはここでは扱わないこととする． なぜなら，機種依存文字は各ベンダ・文字コードごとに非常に多くの種類が存在し， そのすべてを把握することは不可能なためである． 以下のリンク先の文書の外字(ユーザ定義とベンダ定義)の欄が機種依存文字に 該当する．

• ベンダ別 EUC コード一覧
• ベンダ別 SJIS コード一覧

HTMLタグの正規表現

# HTMLタグの正規表現 $tag_regex

$tag_regex_ = q{[^"'<>]*(?:"[^"]*"[^"'<>]*|'[^']*'[^"'<>]*)*(?:>|(?=<)|$(?!\n))}; #'}}}}
$comment_tag_regex =
    '<!(?:--[^-]*-(?:[^-]+-)*?-(?:[^>-]*(?:-[^>-]+)*?)??)*(?:>|$(?!\n)|--.*$)';
$tag_regex = qq{$comment_tag_regex|<$tag_regex_};

このスクリプトの $comment_tag_regex がコメントタグの正規表現で， $tag_regex_ がコメントタグ以外の普通の タグの < 以降の正規表現になります．

最初に普通のタグの正規表現について説明します．普通のタグの中身の 正規表現として最初に思いつくのは [^>]* です． しかし，これではダブルクォートやシングルクォートで囲まれた中に > があった場合にまずいことになります． そこで，ダブルクォートやシングルクォートについて考えます．

ダブルクォートで囲まれている部分の正規表現は "[^"]*" と書くことができます． シングルクォートで囲まれている部分についても同様です． これでダブルクォートやシングルクォートで囲まれている内側には > を含むことができます．それ以外のダブルクォートでもシングルクォートでも 囲まれていない部分は今度こそ [^>] だから，結局 (?:[^>]|"[^"]*"|'[^']')* でいいか，というとそううまくはいきません． [^>] ではダブルクォートや シングルクォートまで含んでしまうため，せっかく用意したダブルクォートや シングルクォートで囲まれている部分の正規表現が使われることなくそのまま マッチングが進んで，ダブルクォートやシングルクォートの 中の > をタグの終わりと間違えてマッチが成功してしまいます．

これを回避するには， (?:"[^"]*"|'[^']*'|[^>])* のように最初にダブルクォートかシングルクォートで囲まれているかどうかを 調べる方法があります．しかし，これは明らかに遅いです． なぜかというと，ダブルクォートやシングルクォートで囲まれていない部分の場合， 1文字ごとにダブルクォートとシングルクォートのマッチングが 失敗してからでないと [^>] にマッチしないためです． そこで次のように [^"'>] とするとすべてがうまくいきます．

$tag_regex_ = q{(?:[^"'>]|"[^"]*"|'[^']*')*}; #'}}}

次に閉じないタグのことを考えます．閉じないタグとは <P<B> のように > を省略してあるものです．このとき <P を正しくタグとして認識するためには，タグの中身は [^>]* ではなく [^<>]* としなければならないことになります． また，タグの最後は必ず > で終わるとは限らないので， (?:>|(?=<)|$(?!\n)) とする必要があります． これは > で終わる普通のタグか，または， その次の文字がタグの開始文字である < であるか，または， 文字列の最後である場合を表しています．$(?!\n) については後で詳しく説明します．結局，これをまとめると次のようになります．

$tag_regex_ = q{(?:[^"'<>]|"[^"]*"|'[^']*')*(?:>|(?=<)|$(?!\n))}; #'}}}

これを Jeffrey E. F. Friedl氏原著による 「詳説 正規表現」で 「ループ展開」として書かれている 手法で実行速度を速くしたものが最初のスクリプトの 正規表現です．簡単なベンチマークをとってみたところ約 1.5倍ほど 速かったです．

次にコメントタグの正規表現の説明をします．コメントタグについては， まずは水無月 ばけらさんによる 「 SGMLの注釈宣言」を一読することをお勧めします．

コメントタグ，すなわち，注釈宣言は --コメントの中身-- というコメントだけから構成されています． コメントタグは複数のコメントを持つことができ， コメントの後ろには空白文字のみあってもかまいません． また，コメントの中身やコメントの数が 0個であってもかまいません． ただし，<! とコメントの間に空白文字があることは 許されていないので，<! の直後にはコメントか 閉じ括弧の > しか来てはいけないことになります．以上のことから， 正常なコメントタグの正規表現は次のようになります．

# 正常なコメントタグの正規表現 $comment_tag_regex

$comment_tag_regex = q{<!(?:--(?:(?!--).)*--\s*)*>};

この正常なコメントタグの正規表現をもとに，閉じないコメントタグだった場合と， コメントの後ろに空白文字以外の文字があって不正であるコメントタグだった場合にも 対応した正規表現が最初のスクリプトになります．

最後の (?:>|$(?!\n)|--.*$) の選択はそれぞれ， コメントタグが閉じていた場合，コメントの後に > がなく閉じて いなかった場合，コメントの終わりの -- がなくコメントの中身が最後まで続いている場合を表わしています． $(?!\n) ですが，ただの $ でもよいのではないかと疑問に思われる人もいるかと 思いますが，$(?!\n) と $ では 少し意味が違います．たとえば， $str = "test\n"; のとき， m/^test$/ はマッチしますが，m/^test$(?!\n)/ はマッチしません． なぜなら，$ は文字列の最後に改行があった場合には， 改行の直前でもマッチするからです．もし， 'test' にはマッチしてほしいが， "test\n" にはマッチしてほしくないというときに，ただの $ では困るわけです．コメントタグの正規表現では "<!\n" のような場合にマッチしてもらっては困るのでこのような正規表現になっています． perl5.005 以降ならば $(?!\n) を \z とすることができます． \z は $ や \Z と違って本当の意味で文字列の最後にマッチします．

実は次のようにコメントタグの正規表現を書いても同じことができます． 理解するにはまずこちらの正規表現をもとに考えた方がよいかもしれません．

# コメントタグの正規表現(遅い)

$comment_tag_regex = '<!(?:--(?:(?!--).)*--(?:(?!--)[^>])*)*(?:>|$(?!\n)|--.*$)';

この正規表現では，コメントの中身を表わす正規表現として (?:(?!--).)* としています．これの意味は，次に -- が来ないような何か 1文字の繰り返しということです．つまり， - が単独で現れた場合には問題ないわけで， -- と続けて現れる - は駄目だということになります． これでコメントの中身には -- が絶対に現れないことが 保証されます．コメントの中身を表わす正規表現としてはこれで正しいのですが， 1文字ごとに -- でないことを チェックしているのでこのままでは実行速度が遅いです．

そこで普通のタグのときと同様に「ループ展開」の 手法を用いることとします．まず，-- が来ない何か 1文字の繰り返しを表わす (?:(?!--).)* を少し違う考え方で表現し直します．この正規表現は -- が含まれない部分ということですので，まず，-以外の 文字ならば問題ないことはすぐにわかると思います．仮に - が来たとしてもその次の文字が -以外の文字であればその場合もまた大丈夫です． ということは，(?:(?!--).)* は (?:[^-]|-[^-])* と変形することができます． これに対して「ループ展開」の手法を用いると， [^-]*(?:-[^-][^-]*)* となり，結局 [^-]*(?:-[^-]+)* となります．

これでコメント部分の正規表現は --[^-]*(?:-[^-]+)*-- となりました． 簡単なベンチマークをとったところ 約 2倍ほど速くなりました． しかし，まだ最初のスクリプトとは少し違っています． このコメント部分の正規表現には非決定性なところが あります．それは - が来たときに，その時点では それがコメントの中身なのか，コメントの終了を表わす -- の最初の 1文字なのかわかりませんが， 正規表現でもやはりマッチする可能性がある場所が 2ヶ所に なっているということです．つまり，(?:-[^-]+)* の (?: 直後の - にマッチするかもしれないし， (?:-[^-]+)* 直後の - にマッチするかもしれないのです．このような非決定性はバックトラック発生時に 多くの負担を強いることになります．そこで， [^-]*(?:-[^-]+)*-- を変形し，非決定性を排除すると [^-]*-(?:[^-]+-)*- となります．これで - が来たときにマッチする正規表現の部分は [^-]* 直後の - の 1ヶ所 となります．

ここまでの変形でかなり最初のスクリプトに近づきましたが，まだ 1ヶ所違っています．それは (?:[^-]+-)* と (?:[^-]+-)*?，つまり， * と *? の違いです．一般に * と *? を変えたらマッチするものも 変わってしまいます．しかし，今回の場合は * でも *? でも必ず同じ結果となります． 必ず同じ結果となることがわかっているので，実行速度が速い方を考えます． 一般にコメントタグというものは <-- これはコメントタグです --> というようなものが ほとんどでしょう．つまり，コメントタグの中身として - を含んでいるものの出現頻度は，含んでいないものの出現頻度よりも 低いということです．もし，コメントタグの中身に - を含んでいた 場合は (?:[^-]+-) の部分を通過することになります． しかし，実際には含んでいないことの方が多いわけですから， (?:[^-]+-) の部分をチェックするのは無駄な ことになります．そこで，* を *? と することでこの無駄を可能な限り排除することができます．

次に (?:(?!--)[^>])* の部分について考えます． ここもコメントタグの中身の部分と同様にまずは 「ループ展開」の手法を用いて (?:[^>-]*(?:-[^>-]+)* と変形します．更に， * を *? とすることができますので， (?:[^>-]*(?:-[^>-]+)*? と変形するところまでは同じです．

最初のスクリプトでは更に全体を (?: regex)?? というように ?? をつけた形にしています． これは，コメントタグの中身と違って，一般にコメントの終了を表わす -- の後ろには何か文字が入ることなく直後に > で閉じられているものの出現頻度が高いと思われるためです．言い換えると， (?:[^>-]*(?:-[^>-]+)*? がマッチすることはほとんどない，つまり，マッチさせようとすると無駄に終わる ことが多いと思われるため，この部分の正規表現全体に ?? をつけて，可能な限りチェックさせないように しています．

URI(URL) の正規表現

# $uri が正しい URI か判定する

$digit = q{[0-9]};
$upalpha = q{[A-Z]};
$lowalpha = q{[a-z]};
$alpha = qq{(?:$lowalpha|$upalpha)};
$alphanum = qq{(?:$alpha|$digit)};
$hex = qq{(?:$digit|[A-Fa-f])};
$escaped = qq{%$hex$hex};
$mark = q{[-_.!~*'()]};
$unreserved = qq{(?:$alphanum|$mark)};
$reserved = q{[;/?:@&=+$,]};
$uric = qq{(?:$reserved|$unreserved|$escaped)};
$fragment = qq{$uric*};
$query = qq{$uric*};
$pchar = qq{(?:$unreserved|$escaped|} . q{[:@&=+$,])};
$param = qq{$pchar*};
$segment = qq{$pchar*(?:;$param)*};
$path_segments = qq{$segment(?:/$segment)*};
$abs_path = qq{/$path_segments};
$uric_no_slash = qq{(?:$unreserved|$escaped|} . q{[;?:@&=+$,])};
$opaque_part = qq{$uric_no_slash$uric*};
$path = qq{(?:$abs_path|$opaque_part)?};
$port = qq{$digit*};
$IPv4address = qq{$digit+\\.$digit+\\.$digit+\\.$digit+};
$toplabel = qq{(?:$alpha|$alpha(?:$alphanum|-)*$alphanum)};
$domainlabel = qq{(?:$alphanum|$alphanum(?:$alphanum|-)*$alphanum)};
$hostname = qq{(?:$domainlabel\\.)*$toplabel\\.?};
$host = qq{(?:$hostname|$IPv4address)};
$hostport = qq{$host(?::$port)?};
$userinfo = qq{(?:$unreserved|$escaped|} . q{[;:&=+$,])*};
$server = qq{(?:(?:$userinfo\@)?$hostport)?};
$reg_name = qq{(?:$unreserved|$escaped|} . q{[$,;:@&=+])+};
$authority = qq{(?:$server|$reg_name)};
$scheme = qq{$alpha(?:$alpha|$digit|[-+.])*};
$rel_segment = qq{(?:$unreserved|$escaped|} . q{[;@&=+$,])+};
$rel_path = qq{$rel_segment(?:$abs_path)?};
$net_path = qq{//$authority(?:$abs_path)?};
$hier_part = qq{(?:$net_path|$abs_path)(?:\\?$query)?};
$relativeURI = qq{(?:$net_path|$abs_path|$rel_path)(?:\\?$query)?};
$absoluteURI = qq{$scheme:(?:$hier_part|$opaque_part)};
$URI_reference = qq{(?:$absoluteURI|$relativeURI)?(?:#$fragment)?};

$pattern = $URI_reference;

print "ok\n" if $uri =~ /^$pattern$/o;

URI については RFC 2396( 日本語訳 )に書かれています．それを機械的に素直に正規表現にした ものが上のスクリプトです．これから求めた URI References の正規表現は 次のようになりました．

(?:(?:[a-z]|[A-Z])(?:(?:[a-z]|[A-Z])|[0-9]|[-+.])*:(?:(?://(?:(?:(
?:(?:(?:(?:(?:[a-z]|[A-Z])|[0-9])|[-_.!~*'()])|%(?:[0-9]|[A-Fa-f])
(?:[0-9]|[A-Fa-f])|[;:&=+$,])*@)?(?:(?:(?:(?:(?:[a-z]|[A-Z])|[0-9]
)|(?:(?:[a-z]|[A-Z])|[0-9])(?:(?:(?:[a-z]|[A-Z])|[0-9])|-)*(?:(?:[
a-z]|[A-Z])|[0-9]))\.)*(?:(?:[a-z]|[A-Z])|(?:[a-z]|[A-Z])(?:(?:(?:
[a-z]|[A-Z])|[0-9])|-)*(?:(?:[a-z]|[A-Z])|[0-9]))\.?|[0-9]+\.[0-9]
+\.[0-9]+\.[0-9]+)(?::[0-9]*)?)?|(?:(?:(?:(?:[a-z]|[A-Z])|[0-9])|[
-_.!~*'()])|%(?:[0-9]|[A-Fa-f])(?:[0-9]|[A-Fa-f])|[$,;:@&=+])+)(?:
/(?:(?:(?:(?:[a-z]|[A-Z])|[0-9])|[-_.!~*'()])|%(?:[0-9]|[A-Fa-f])(
?:[0-9]|[A-Fa-f])|[:@&=+$,])*(?:;(?:(?:(?:(?:[a-z]|[A-Z])|[0-9])|[
-_.!~*'()])|%(?:[0-9]|[A-Fa-f])(?:[0-9]|[A-Fa-f])|[:@&=+$,])*)*(?:
/(?:(?:(?:(?:[a-z]|[A-Z])|[0-9])|[-_.!~*'()])|%(?:[0-9]|[A-Fa-f])(
?:[0-9]|[A-Fa-f])|[:@&=+$,])*(?:;(?:(?:(?:(?:[a-z]|[A-Z])|[0-9])|[
-_.!~*'()])|%(?:[0-9]|[A-Fa-f])(?:[0-9]|[A-Fa-f])|[:@&=+$,])*)*)*)
?|/(?:(?:(?:(?:[a-z]|[A-Z])|[0-9])|[-_.!~*'()])|%(?:[0-9]|[A-Fa-f]
)(?:[0-9]|[A-Fa-f])|[:@&=+$,])*(?:;(?:(?:(?:(?:[a-z]|[A-Z])|[0-9])
|[-_.!~*'()])|%(?:[0-9]|[A-Fa-f])(?:[0-9]|[A-Fa-f])|[:@&=+$,])*)*(
?:/(?:(?:(?:(?:[a-z]|[A-Z])|[0-9])|[-_.!~*'()])|%(?:[0-9]|[A-Fa-f]
)(?:[0-9]|[A-Fa-f])|[:@&=+$,])*(?:;(?:(?:(?:(?:[a-z]|[A-Z])|[0-9])
|[-_.!~*'()])|%(?:[0-9]|[A-Fa-f])(?:[0-9]|[A-Fa-f])|[:@&=+$,])*)*)
*)(?:\?(?:[;/?:@&=+$,]|(?:(?:(?:[a-z]|[A-Z])|[0-9])|[-_.!~*'()])|%
(?:[0-9]|[A-Fa-f])(?:[0-9]|[A-Fa-f]))*)?|(?:(?:(?:(?:[a-z]|[A-Z])|
[0-9])|[-_.!~*'()])|%(?:[0-9]|[A-Fa-f])(?:[0-9]|[A-Fa-f])|[;?:@&=+
$,])(?:[;/?:@&=+$,]|(?:(?:(?:[a-z]|[A-Z])|[0-9])|[-_.!~*'()])|%(?:
[0-9]|[A-Fa-f])(?:[0-9]|[A-Fa-f]))*)|(?://(?:(?:(?:(?:(?:(?:(?:[a-
z]|[A-Z])|[0-9])|[-_.!~*'()])|%(?:[0-9]|[A-Fa-f])(?:[0-9]|[A-Fa-f]
)|[;:&=+$,])*@)?(?:(?:(?:(?:(?:[a-z]|[A-Z])|[0-9])|(?:(?:[a-z]|[A-
Z])|[0-9])(?:(?:(?:[a-z]|[A-Z])|[0-9])|-)*(?:(?:[a-z]|[A-Z])|[0-9]
))\.)*(?:(?:[a-z]|[A-Z])|(?:[a-z]|[A-Z])(?:(?:(?:[a-z]|[A-Z])|[0-9
])|-)*(?:(?:[a-z]|[A-Z])|[0-9]))\.?|[0-9]+\.[0-9]+\.[0-9]+\.[0-9]+
)(?::[0-9]*)?)?|(?:(?:(?:(?:[a-z]|[A-Z])|[0-9])|[-_.!~*'()])|%(?:[
0-9]|[A-Fa-f])(?:[0-9]|[A-Fa-f])|[$,;:@&=+])+)(?:/(?:(?:(?:(?:[a-z
]|[A-Z])|[0-9])|[-_.!~*'()])|%(?:[0-9]|[A-Fa-f])(?:[0-9]|[A-Fa-f])
|[:@&=+$,])*(?:;(?:(?:(?:(?:[a-z]|[A-Z])|[0-9])|[-_.!~*'()])|%(?:[
0-9]|[A-Fa-f])(?:[0-9]|[A-Fa-f])|[:@&=+$,])*)*(?:/(?:(?:(?:(?:[a-z
]|[A-Z])|[0-9])|[-_.!~*'()])|%(?:[0-9]|[A-Fa-f])(?:[0-9]|[A-Fa-f])
|[:@&=+$,])*(?:;(?:(?:(?:(?:[a-z]|[A-Z])|[0-9])|[-_.!~*'()])|%(?:[
0-9]|[A-Fa-f])(?:[0-9]|[A-Fa-f])|[:@&=+$,])*)*)*)?|/(?:(?:(?:(?:[a
-z]|[A-Z])|[0-9])|[-_.!~*'()])|%(?:[0-9]|[A-Fa-f])(?:[0-9]|[A-Fa-f
])|[:@&=+$,])*(?:;(?:(?:(?:(?:[a-z]|[A-Z])|[0-9])|[-_.!~*'()])|%(?
:[0-9]|[A-Fa-f])(?:[0-9]|[A-Fa-f])|[:@&=+$,])*)*(?:/(?:(?:(?:(?:[a
-z]|[A-Z])|[0-9])|[-_.!~*'()])|%(?:[0-9]|[A-Fa-f])(?:[0-9]|[A-Fa-f
])|[:@&=+$,])*(?:;(?:(?:(?:(?:[a-z]|[A-Z])|[0-9])|[-_.!~*'()])|%(?
:[0-9]|[A-Fa-f])(?:[0-9]|[A-Fa-f])|[:@&=+$,])*)*)*|(?:(?:(?:(?:[a-
z]|[A-Z])|[0-9])|[-_.!~*'()])|%(?:[0-9]|[A-Fa-f])(?:[0-9]|[A-Fa-f]
)|[;@&=+$,])+(?:/(?:(?:(?:(?:[a-z]|[A-Z])|[0-9])|[-_.!~*'()])|%(?:
[0-9]|[A-Fa-f])(?:[0-9]|[A-Fa-f])|[:@&=+$,])*(?:;(?:(?:(?:(?:[a-z]
|[A-Z])|[0-9])|[-_.!~*'()])|%(?:[0-9]|[A-Fa-f])(?:[0-9]|[A-Fa-f])|
[:@&=+$,])*)*(?:/(?:(?:(?:(?:[a-z]|[A-Z])|[0-9])|[-_.!~*'()])|%(?:
[0-9]|[A-Fa-f])(?:[0-9]|[A-Fa-f])|[:@&=+$,])*(?:;(?:(?:(?:(?:[a-z]
|[A-Z])|[0-9])|[-_.!~*'()])|%(?:[0-9]|[A-Fa-f])(?:[0-9]|[A-Fa-f])|
[:@&=+$,])*)*)*)?)(?:\?(?:[;/?:@&=+$,]|(?:(?:(?:[a-z]|[A-Z])|[0-9]
)|[-_.!~*'()])|%(?:[0-9]|[A-Fa-f])(?:[0-9]|[A-Fa-f]))*)?)?(?:#(?:[
;/?:@&=+$,]|(?:(?:(?:[a-z]|[A-Z])|[0-9])|[-_.!~*'()])|%(?:[0-9]|[A
-Fa-f])(?:[0-9]|[A-Fa-f]))*)?

この正規表現はあまりにも一般的すぎて，ほとんどの入力に対してマッチして しまいます．RFC 2396 はもともと URI の一般形を定義した ものであるので，この正規表現を使うことはほとんどないと言っていいでしょう．

http URL の正規表現

# $http が正しい http URL か判定する

$digit = q{[0-9]};
$upalpha = q{[A-Z]};
$lowalpha = q{[a-z]};
$alpha = qq{(?:$lowalpha|$upalpha)};
$alphanum = qq{(?:$alpha|$digit)};
$hex = qq{(?:$digit|[A-Fa-f])};
$escaped = qq{%$hex$hex};
$mark = q{[-_.!~*'()]};
$unreserved = qq{(?:$alphanum|$mark)};
$reserved = q{[;/?:@&=+$,]};
$uric = qq{(?:$reserved|$unreserved|$escaped)};
$query = qq{$uric*};
$pchar = qq{(?:$unreserved|$escaped|} . q{[:@&=+$,])};
$param = qq{$pchar*};
$segment = qq{$pchar*(?:;$param)*};
$path_segments = qq{$segment(?:/$segment)*};
$abs_path = qq{/$path_segments};
$port = qq{$digit*};
$IPv4address = qq{$digit+\\.$digit+\\.$digit+\\.$digit+};
$toplabel = qq{(?:$alpha|$alpha(?:$alphanum|-)*$alphanum)};
$domainlabel = qq{(?:$alphanum|$alphanum(?:$alphanum|-)*$alphanum)};
$hostname = qq{(?:$domainlabel\\.)*$toplabel\\.?};
$host = qq{(?:$hostname|$IPv4address)};
$http_URL = qq{http://$host(?::$port)?(?:$abs_path(?:\\?$query)?)?};

$pattern = $http_URL;

print "ok\n" if $http =~ /^$pattern$/;

http URL については RFC 2616 の 3.2.2 http URL に書かれています． このスクリプトは， 「URI(URL) の正規表現」で書いた URI(URL) の 正規表現のスクリプトを修正し， http URL の正規表現にしたものです．このスクリプトから求めた http URL の正規表現は次のようになりました．

http://(?:(?:(?:(?:(?:[a-z]|[A-Z])|[0-9])|(?:(?:[a-z]|[A-Z])|[0-9]
)(?:(?:(?:[a-z]|[A-Z])|[0-9])|-)*(?:(?:[a-z]|[A-Z])|[0-9]))\.)*(?:
(?:[a-z]|[A-Z])|(?:[a-z]|[A-Z])(?:(?:(?:[a-z]|[A-Z])|[0-9])|-)*(?:
(?:[a-z]|[A-Z])|[0-9]))\.?|[0-9]+\.[0-9]+\.[0-9]+\.[0-9]+)(?::[0-9
]*)?(?:/(?:(?:(?:(?:[a-z]|[A-Z])|[0-9])|[-_.!~*'()])|%(?:[0-9]|[A-
Fa-f])(?:[0-9]|[A-Fa-f])|[:@&=+$,])*(?:;(?:(?:(?:(?:[a-z]|[A-Z])|[
0-9])|[-_.!~*'()])|%(?:[0-9]|[A-Fa-f])(?:[0-9]|[A-Fa-f])|[:@&=+$,]
)*)*(?:/(?:(?:(?:(?:[a-z]|[A-Z])|[0-9])|[-_.!~*'()])|%(?:[0-9]|[A-
Fa-f])(?:[0-9]|[A-Fa-f])|[:@&=+$,])*(?:;(?:(?:(?:(?:[a-z]|[A-Z])|[
0-9])|[-_.!~*'()])|%(?:[0-9]|[A-Fa-f])(?:[0-9]|[A-Fa-f])|[:@&=+$,]
)*)*)*(?:\?(?:[;/?:@&=+$,]|(?:(?:(?:[a-z]|[A-Z])|[0-9])|[-_.!~*'()
])|%(?:[0-9]|[A-Fa-f])(?:[0-9]|[A-Fa-f]))*)?)?

この http URL の正規表現は，文字クラス同士の選択が まとめられていないので無駄が多いことがわかります．そこで，文字クラスを なるべくまとめるように以下のように一部改良します．

# $http が正しい http URL か判定する(文字クラス改良版)

$alpha = q{[a-zA-Z]};
$alphanum = q{[a-zA-Z0-9]};
$hex = q{[0-9A-Fa-f]};
$uric = q{(?:[-_.!~*'()a-zA-Z0-9;/?:@&=+$,]} . qq{|$escaped)};
$pchar = q{(?:[-_.!~*'()a-zA-Z0-9:@&=+$,]} . qq{|$escaped)};
$toplabel = qq{(?:$alpha|$alpha} . q{[-a-zA-Z0-9]*} . qq{$alphanum)};
$domainlabel = qq{(?:$alphanum|$alphanum} . q{[-a-zA-Z0-9]*} . qq{$alphanum)};

このスクリプトから求めた http URL の正規表現は次のように なりました．

http://(?:(?:(?:[a-zA-Z0-9]|[a-zA-Z0-9][-a-zA-Z0-9]*[a-zA-Z0-9])\.
)*(?:[a-zA-Z]|[a-zA-Z][-a-zA-Z0-9]*[a-zA-Z0-9])\.?|[0-9]+\.[0-9]+\
.[0-9]+\.[0-9]+)(?::[0-9]*)?(?:/(?:[-_.!~*'()a-zA-Z0-9:@&=+$,]|%[0
-9A-Fa-f][0-9A-Fa-f])*(?:;(?:[-_.!~*'()a-zA-Z0-9:@&=+$,]|%[0-9A-Fa
-f][0-9A-Fa-f])*)*(?:/(?:[-_.!~*'()a-zA-Z0-9:@&=+$,]|%[0-9A-Fa-f][
0-9A-Fa-f])*(?:;(?:[-_.!~*'()a-zA-Z0-9:@&=+$,]|%[0-9A-Fa-f][0-9A-F
a-f])*)*)*(?:\?(?:[-_.!~*'()a-zA-Z0-9;/?:@&=+$,]|%[0-9A-Fa-f][0-9A
-Fa-f])*)?)?

この正規表現は前述しましたが，RFC 2616 の 3.2.2 http URL に書かれています．RFC 2616 には HTTPプロトコルに関することが書かれており，3.2.2 http URL に書かれている http URL も，HTTPプロトコルの中での話になります． 一般に，HTML のリンクに使用されるものは，純粋に HTTPプロトコルの中で使用される http URL ではなく， scheme が http であるURI References です．

たとえば http://user:passwd@www.din.or.jp/~ohzaki/perl.htm#URI は URI References ですが，user:passwd@ の部分，すなわち，userinfo や，#URI の部分，すなわち， Fragment Identifier は HTTPプロトコルの中で使用される http URL としては不正なものとなります．しかし，HTML のリンクとしては問題ありません．なぜなら，クライアント(ブラウザ)が HTTPプロトコルで通信する際にはそれらを削除しているからです．余談ですが， RFC 2396( 日本語訳 ) の第 4章には Fragment Identifier は URI の一部ではないと書かれています．Fragment Identifier は user agent によって解釈される付加的参照情報だそうです．

次に，scheme が http である URI References を考えます． そこで再び「URI(URL) の正規表現」で書いた URI(URL) の 正規表現のスクリプトを修正して作ります．その際， HTTPプロトコルの中で使用される http URL を構築するのに必要な情報を必ず含んでいれば， それ以外に冗長な情報を含んでいてもよいとします．必要な情報とは，host，port， abs_path，query です．また，scheme は当然 http ですが，この際， Secure Hyper Text Tranasfer Protocol(S-HTTP)と呼ばれる プロトコルを使う shttp: や Secure Sockets Layer(SSL) というプロトコルを使う https: にも対応するようにしておきます． 修正した結果は，以下のように一部を修正することになりました．

$server = qq{(?:$userinfo\@)?$hostport};
$authority = qq{$server};
$scheme = q{(?:https?|shttp)};
$hier_part = qq{$net_path(?:\\?$query)?};
$absoluteURI = qq{$scheme:$hier_part};
$URI_reference = qq{$absoluteURI(?:#$fragment)?};

これに先ほどと同じように文字クラスをまとめる改良として，以下のように一部 を修正しました．

$alpha = q{[a-zA-Z]};
$alphanum = q{[a-zA-Z0-9]};
$hex = q{[0-9A-Fa-f]};
$unreserved = q{[-_.!~*'()a-zA-Z0-9]};
$uric = q{(?:[-_.!~*'()a-zA-Z0-9;/?:@&=+$,]} . qq{|$escaped)};
$pchar = q{(?:[-_.!~*'()a-zA-Z0-9:@&=+$,]} . qq{|$escaped)};
$toplabel = qq{(?:$alpha|$alpha} . q{[-a-zA-Z0-9]*} . qq{$alphanum)};
$domainlabel = qq{(?:$alphanum|$alphanum} . q{[-a-zA-Z0-9]*} . qq{$alphanum)};
$userinfo = q{(?:[-_.!~*'()a-zA-Z0-9;:&=+$,]|} . qq{$escaped)*};

このようにして求めた正規表現は次のようになりました．

(?:https?|shttp)://(?:(?:[-_.!~*'()a-zA-Z0-9;:&=+$,]|%[0-9A-Fa-f][
0-9A-Fa-f])*@)?(?:(?:(?:[a-zA-Z0-9]|[a-zA-Z0-9][-a-zA-Z0-9]*[a-zA-
Z0-9])\.)*(?:[a-zA-Z]|[a-zA-Z][-a-zA-Z0-9]*[a-zA-Z0-9])\.?|[0-9]+\
.[0-9]+\.[0-9]+\.[0-9]+)(?::[0-9]*)?(?:/(?:[-_.!~*'()a-zA-Z0-9:@&=
+$,]|%[0-9A-Fa-f][0-9A-Fa-f])*(?:;(?:[-_.!~*'()a-zA-Z0-9:@&=+$,]|%
[0-9A-Fa-f][0-9A-Fa-f])*)*(?:/(?:[-_.!~*'()a-zA-Z0-9:@&=+$,]|%[0-9
A-Fa-f][0-9A-Fa-f])*(?:;(?:[-_.!~*'()a-zA-Z0-9:@&=+$,]|%[0-9A-Fa-f
][0-9A-Fa-f])*)*)*)?(?:\?(?:[-_.!~*'()a-zA-Z0-9;/?:@&=+$,]|%[0-9A-
Fa-f][0-9A-Fa-f])*)?(?:#(?:[-_.!~*'()a-zA-Z0-9;/?:@&=+$,]|%[0-9A-F
a-f][0-9A-Fa-f])*)?

この正規表現を使えば， $http が， scheme が http である URI References かどうか判定することはできます． ところが，ある文字列の 中から http URL を抽出する目的でこの正規表現を使っても うまくいきません．たとえば，次のような スクリプトを実行するとうまくいかないことがわかります．

# $str から http URI References を抽出する

$str = "このページの URI は http://www.din.or.jp/~ohzaki/perl.htm です";

$pattern = $URI_reference;

while ($str =~ /($pattern)/g) {
  print $1, "\n";
}

実行結果(失敗例)
http://www.din.or.j

なぜこのような結果になってしまったのでしょうか．それは Perl のパターン マッチエンジンが非決定性有限オートマトン NFAs(Nondeterministic Finite Automata) だからです． 次のようなスクリプトを考えてみてください．

print "数字 1文字 or 数字で始まり数字か小文字が続くもの\n";
$str = '123abc';
@patterns = ('(?:\d|\d[0-9a-z]+)', '(?:\d[0-9a-z]*)');
foreach $pattern (@patterns) {
  print "  文字列 $str  パターン $pattern  ";
  print '結果 ' . join('/', $str =~ /$pattern/g) . "\n";
}
print "\n数字 1文字 or 最初が数字か小文字で，次が小文字のもの\n";
$str = '1a';
@patterns = ('(?:\d|[\da-z][a-z])', '(?:[\da-z][a-z]|\d)');
foreach $pattern (@patterns) {
  print "  文字列 $str  パターン $pattern  ";
  print '結果 ' . join('/', $str =~ /$pattern/g) . "\n";
}

実行結果
数字 1文字 or 最初が数字で，その後数字か小文字が続くもの
  文字列 123abc  パターン (?:\d|\d[0-9a-z]+)  結果 1/2/3
  文字列 123abc  パターン (?:\d[0-9a-z]*)  結果 123abc

数字 1文字 or 最初が数字か小文字で，次が小文字のもの
  文字列 1a  パターン (?:\d|[\da-z][a-z])  結果 1
  文字列 1a  パターン (?:[\da-z][a-z]|\d)  結果 1a

2つの例のうち，どちらも最初の正規表現では文字列の一部にしか マッチしていないことがわかると思います． このように Perl のパターンマッチエンジンはうまくマッチさせていけば もっと長い文字列にマッチさせることができる場合でも，最初に見つかった方法で パターンマッチを進めてしまいます．それではなぜもう一方の正規表現では うまく文字列全体にマッチさせることができたのでしょうか．

1つめの例では， (?:regex1|regex1regex2+) という選択を regex1regex2* という形に変形し， 選択が現れないようにしています．このようにすることで， より長くマッチさせることができ，また，ほとんどの 場合にバックトラックを減らすことができるので 効率的になります．これと同じこと行ない，以下のように一部改良します．

$toplabel = qq{$alpha(?:} . q{[-a-zA-Z0-9]*} . qq{$alphanum)?};
$domainlabel = qq{$alphanum(?:} . q{[-a-zA-Z0-9]*} . qq{$alphanum)?};

2つめの例では， (?:regex1|regex2) という選択で，regex1 が regex2 の一部とマッチしてしまう場合に， より長くマッチできる可能性である．regex2 を試すことなく regex1 が選択されてしまった ために文字列の一部にマッチしてしまったのです．選択を逆にした， (?:regex2|regex1) の形に修正することで，このような事態を避けることができます．実際に その可能性のある選択を持つ部分というと，host の正規表現の hostname と IPv4address の選択の部分になります．なぜなら，IPv4address の正規表現は hostname の一部とマッチしてしまう可能性があるからです．例えば， 127.0.0.1.www.din.or.jp という host があった場合，先に IPv4address をマッチさせてしまうと 127.0.0.1 の部分に マッチしてしまいます．幸い，最初から host の正規表現は先に hostname をマッチさせるようになっていますので，特に修正する必要はないことになります．

最後に，pseudohttp://foo/bar.htm のように HTTP ではない scheme の途中からマッチしてしまうことがないように， 以下のように改良します．

$http_URL_regex = q{\b} . $URI_reference;

以上の改良をすべてまとめた最終的なスクリプトは以下のようになりました．

# http URL の正規表現 $http_URL_regex

$digit = q{[0-9]};
$alpha = q{[a-zA-Z]};
$alphanum = q{[a-zA-Z0-9]};
$hex = q{[0-9A-Fa-f]};
$escaped = qq{%$hex$hex};
$uric = q{(?:[-_.!~*'()a-zA-Z0-9;/?:@&=+$,]} . qq{|$escaped)};
$fragment = qq{$uric*};
$query = qq{$uric*};
$pchar = q{(?:[-_.!~*'()a-zA-Z0-9:@&=+$,]} . qq{|$escaped)};
$param = qq{$pchar*};
$segment = qq{$pchar*(?:;$param)*};
$path_segments = qq{$segment(?:/$segment)*};
$abs_path = qq{/$path_segments};
$port = qq{$digit*};
$IPv4address = qq{$digit+\\.$digit+\\.$digit+\\.$digit+};
$toplabel = qq{$alpha(?:} . q{[-a-zA-Z0-9]*} . qq{$alphanum)?};
$domainlabel = qq{$alphanum(?:} . q{[-a-zA-Z0-9]*} . qq{$alphanum)?};
$hostname = qq{(?:$domainlabel\\.)*$toplabel\\.?};
$host = qq{(?:$hostname|$IPv4address)};
$hostport = qq{$host(?::$port)?};
$userinfo = q{(?:[-_.!~*'()a-zA-Z0-9;:&=+$,]|} . qq{$escaped)*};
$server = qq{(?:$userinfo\@)?$hostport};
$authority = qq{$server};
$scheme = q{(?:https?|shttp)};
$net_path = qq{//$authority(?:$abs_path)?};
$hier_part = qq{$net_path(?:\\?$query)?};
$absoluteURI = qq{$scheme:$hier_part};
$URI_reference = qq{$absoluteURI(?:#$fragment)?};
$http_URL_regex = q{\b} . $URI_reference;

このスクリプトから求めた http URL の正規表現は次のように なりました． \b(?:https?|shttp)://(?:(?:[-_.!~*'()a-zA-Z0-9;:&=+$,]|%[0-9A-Fa-f ][0-9A-Fa-f])*@)?(?:(?:[a-zA-Z0-9](?:[-a-zA-Z0-9]*[a-zA-Z0-9])?\.) *[a-zA-Z](?:[-a-zA-Z0-9]*[a-zA-Z0-9])?\.?|[0-9]+\.[0-9]+\.[0-9]+\. [0-9]+)(?::[0-9]*)?(?:/(?:[-_.!~*'()a-zA-Z0-9:@&=+$,]|%[0-9A-Fa-f] [0-9A-Fa-f])*(?:;(?:[-_.!~*'()a-zA-Z0-9:@&=+$,]|%[0-9A-Fa-f][0-9A- Fa-f])*)*(?:/(?:[-_.!~*'()a-zA-Z0-9:@&=+$,]|%[0-9A-Fa-f][0-9A-Fa-f ])*(?:;(?:[-_.!~*'()a-zA-Z0-9:@&=+$,]|%[0-9A-Fa-f][0-9A-Fa-f])*)*) *)?(?:\?(?:[-_.!~*'()a-zA-Z0-9;/?:@&=+$,]|%[0-9A-Fa-f][0-9A-Fa-f]) *)?(?:#(?:[-_.!~*'()a-zA-Z0-9;/?:@&=+$,]|%[0-9A-Fa-f][0-9A-Fa-f])* )? この正規表現を使えば，http URL の抽出がうまくいくように なります．以下がこれを直接代入して使うスクリプトになります． $http_URL_regex = q{\b(?:https?|shttp)://(?:(?:[-_.!~*'()a-zA-Z0-9;:&=+$,]|%[0-9A-Fa-f} . q{][0-9A-Fa-f])*@)?(?:(?:[a-zA-Z0-9](?:[-a-zA-Z0-9]*[a-zA-Z0-9])?\.)} . q{*[a-zA-Z](?:[-a-zA-Z0-9]*[a-zA-Z0-9])?\.?|[0-9]+\.[0-9]+\.[0-9]+\.} . q{[0-9]+)(?::[0-9]*)?(?:/(?:[-_.!~*'()a-zA-Z0-9:@&=+$,]|%[0-9A-Fa-f]} . q{[0-9A-Fa-f])*(?:;(?:[-_.!~*'()a-zA-Z0-9:@&=+$,]|%[0-9A-Fa-f][0-9A-} . q{Fa-f])*)*(?:/(?:[-_.!~*'()a-zA-Z0-9:@&=+$,]|%[0-9A-Fa-f][0-9A-Fa-f} . q{])*(?:;(?:[-_.!~*'()a-zA-Z0-9:@&=+$,]|%[0-9A-Fa-f][0-9A-Fa-f])*)*)} . q{*)?(?:\?(?:[-_.!~*'()a-zA-Z0-9;/?:@&=+$,]|%[0-9A-Fa-f][0-9A-Fa-f])} . q{*)?(?:#(?:[-_.!~*'()a-zA-Z0-9;/?:@&=+$,]|%[0-9A-Fa-f][0-9A-Fa-f])*} . q{)?}; さて，ここまで長々と書いてきましたが，正確に正規表現を書くことを あきらめて，もっと簡単でいいやという人のための http URL の正規表現が以下になります． s?https?://[-_.!~*'()a-zA-Z0-9;/?:@&=+$,%#]+

この正規表現を一旦変数に代入して使用する場合は問題ありませんが，直接正規 表現として利用する場合は次のように書く必要があります．

# 文書 $text から http URL を抽出して @http に格納する

@http = $text =~ /s?https?:\/\/[-_.!~*'()a-zA-Z0-9;\/?:\@&=+\$,%#]+/g;

/ が \/ になっているのは問題ないと思います． 特に注意しなければいけないのは，$ と @ の部分です．これらはそのままではそれぞれスカラー変数・配列変数として扱われ， 変数展開の対象となってしまいます．そこでこの 2つについても \$ と \@ のようにする必要があります．もし，この 2つに \ をつけ忘れていた場合はどうなるのか？ そのときは，$ については特殊変数 $, として通常は空文字列に展開されてしまいます． @ については @& で始まるような配列変数は存在しないので， 配列変数としては扱われずそのままになります．

ftp URL の正規表現

# ftp URL の正規表現 $ftp_URL_regex

$digit = q{[0-9]};
$alpha = q{[a-zA-Z]};
$alphanum = q{[a-zA-Z0-9]};
$hex = q{[0-9A-Fa-f]};
$escaped = qq{%$hex$hex};
$uric = q{(?:[-_.!~*'()a-zA-Z0-9;/?:@&=+$,]} . qq{|$escaped)};
$fragment = qq{$uric*};
$query = qq{$uric*};
$pchar = q{(?:[-_.!~*'()a-zA-Z0-9:@&=+$,]} . qq{|$escaped)};
$segment = qq{$pchar*};
$ftptype = q{[AIDaid]};
$path_segments = qq{$segment(?:/$segment)*(?:;type=$ftptype)?};
$abs_path = qq{/$path_segments};
$port = qq{$digit*};
$IPv4address = qq{$digit+\\.$digit+\\.$digit+\\.$digit+};
$toplabel = qq{$alpha(?:} . q{[-a-zA-Z0-9]*} . qq{$alphanum)?};
$domainlabel = qq{$alphanum(?:} . q{[-a-zA-Z0-9]*} . qq{$alphanum)?};
$hostname = qq{(?:$domainlabel\\.)*$toplabel\\.?};
$host = qq{(?:$hostname|$IPv4address)};
$hostport = qq{$host(?::$port)?};
$user = q{(?:[-_.!~*'()a-zA-Z0-9;&=+$,]|} . qq{$escaped)*};
$password = $user;
$userinfo = qq{$user(?::$password)?};
$server = qq{(?:$userinfo\@)?$hostport};
$authority = qq{$server};
$scheme = q{ftp};
$net_path = qq{//$authority(?:$abs_path)?};
$hier_part = qq{$net_path(?:\\?$query)?};
$absoluteURI = qq{$scheme:$hier_part};
$URI_reference = qq{$absoluteURI(?:#$fragment)?};
$ftp_URL_regex = q{\b} . $URI_reference;

ftp URL については RFC 1738 に書かれています．ただし，現在では RFC 1738 は RFC 2396( 日本語訳 )によって更新されています．更新されていると言っても RFC 2396 は URI の一般形を定義したものになっているので， ftp URL の定義について直接書かれている部分はありません． そこで，ftp URLの正規表現として，RFC 2396 の URI の一般形の定義をもとに， 「http URL の正規表現」でスキームが http である URI References として求めた方法と同様の方法で， スキームが ftp である URI References を考えます．

RFC 1738 に書かれている ftp URL の定義を考慮して書き換えた部分は以下のようになります．

$segment = qq{$pchar*};
$ftptype = q{[AIDaid]};
$path_segments = qq{$segment(?:/$segment)*(?:;type=$ftptype)?};
$user = q{(?:[-_.!~*'()a-zA-Z0-9;&=+$,]|} . qq{$escaped)*};
$password = $user;
$userinfo = qq{$user(?::$password)?};
$server = qq{(?:$userinfo\@)?$hostport};
$authority = qq{$server};
$scheme = q{ftp};
$net_path = qq{//$authority(?:$abs_path)?};
$hier_part = qq{$net_path(?:\\?$query)?};
$absoluteURI = qq{$scheme:$hier_part};
$URI_reference = qq{$absoluteURI(?:#$fragment)?};
$ftp_URL_regex = q{\b} . $URI_reference;

ftp URL は RFC 1738 で ftpurl = "ftp://" login [ "/" fpath [ ";type=" ftptype ]] と定義されています．login より後ろの部分は path_segments に当たるわけですが， ; は fpath とその後ろの部分を区切る目的で使用されます．そこで，segment から ; と param を削除し，path_segments を ftp URL の定義に適合するように修正しました．同様に login 部分は login = [ user [ ":" password ] "@" ] hostport と定義されており， userinfo は user [ ":" password ] となっています．つまり，: が user と password を区切る目的で使用されるため，userinfo から : を取り除いたものを新たに user，password として定義し userinfo を修正しました． scheme は当然 ftp であり，スキームが ftp である URI References としてはあり得ない選択部分を削除するなどして URI_reference や absoluteURI などを修正しました．

このスクリプトから求めた ftp URL の正規表現は 次のようになりました．

\bftp://(?:(?:[-_.!~*'()a-zA-Z0-9;&=+$,]|%[0-9A-Fa-f][0-9A-Fa-f])*
(?::(?:[-_.!~*'()a-zA-Z0-9;&=+$,]|%[0-9A-Fa-f][0-9A-Fa-f])*)?@)?(?
:(?:[a-zA-Z0-9](?:[-a-zA-Z0-9]*[a-zA-Z0-9])?\.)*[a-zA-Z](?:[-a-zA-
Z0-9]*[a-zA-Z0-9])?\.?|[0-9]+\.[0-9]+\.[0-9]+\.[0-9]+)(?::[0-9]*)?
(?:/(?:[-_.!~*'()a-zA-Z0-9:@&=+$,]|%[0-9A-Fa-f][0-9A-Fa-f])*(?:/(?
:[-_.!~*'()a-zA-Z0-9:@&=+$,]|%[0-9A-Fa-f][0-9A-Fa-f])*)*(?:;type=[
AIDaid])?)?(?:\?(?:[-_.!~*'()a-zA-Z0-9;/?:@&=+$,]|%[0-9A-Fa-f][0-9
A-Fa-f])*)?(?:#(?:[-_.!~*'()a-zA-Z0-9;/?:@&=+$,]|%[0-9A-Fa-f][0-9A
-Fa-f])*)?

以下がこれを直接代入して使うスクリプトになります．

$ftp_URL_regex =
q{\bftp://(?:(?:[-_.!~*'()a-zA-Z0-9;&=+$,]|%[0-9A-Fa-f][0-9A-Fa-f])*} .
q{(?::(?:[-_.!~*'()a-zA-Z0-9;&=+$,]|%[0-9A-Fa-f][0-9A-Fa-f])*)?@)?(?} .
q{:(?:[a-zA-Z0-9](?:[-a-zA-Z0-9]*[a-zA-Z0-9])?\.)*[a-zA-Z](?:[-a-zA-} .
q{Z0-9]*[a-zA-Z0-9])?\.?|[0-9]+\.[0-9]+\.[0-9]+\.[0-9]+)(?::[0-9]*)?} .
q{(?:/(?:[-_.!~*'()a-zA-Z0-9:@&=+$,]|%[0-9A-Fa-f][0-9A-Fa-f])*(?:/(?} .
q{:[-_.!~*'()a-zA-Z0-9:@&=+$,]|%[0-9A-Fa-f][0-9A-Fa-f])*)*(?:;type=[} .
q{AIDaid])?)?(?:\?(?:[-_.!~*'()a-zA-Z0-9;/?:@&=+$,]|%[0-9A-Fa-f][0-9} .
q{A-Fa-f])*)?(?:#(?:[-_.!~*'()a-zA-Z0-9;/?:@&=+$,]|%[0-9A-Fa-f][0-9A} .
q{-Fa-f])*)?};

メールアドレスの正規表現

ここの記述は内容が古くなっているので， こちら に新しく書き起こしました．
以降の記述は参考に残しておきます．

RFC 2821 と RFC 2822 は RFC 5321 と RFC 5322 によって obsolete となりました．

RFC 821 と RFC 822 は RFC 2821( 日本語訳 1～3章 4,5章 6章～ )と RFC 2822( 日本語訳 )によって obsolete となりました．

メールアドレスについては RFC 821( 日本語訳 )と RFC 822( 日本語訳 )に書かれています．perl5.6.0以前の perl ではメールアドレスの正規表現を正確に記述することは できませんでした．Jeffrey E. F. Friedl氏原著による 「詳説 正規表現」にはメールアドレスはネストした コメントを持つことができるので正規表現で表わすのは不可能であると 書いてあります．そこで，Jeffrey E. F. Friedl氏はネストした コメントをあきらめて，次のような 6,598バイトにも及ぶ 正規表現を作っています． https://resources.oreilly.com/examples/9781565922570/blob/master/email-opt.pl にソースコードがあります．

[\040\t]*(?:\([^\\\x80-\xff\n\015()]*(?:(?:\\[^\x80-\xff]|\([^\\\x 80-\xff\n\015()]*(?:\\[^\x80-\xff][^\\\x80-\xff\n\015()]*)*\))[^\\ \x80-\xff\n\015()]*)*\)[\040\t]*)*(?:(?:[^(\040)<>@,;:".\\\[\]\000 -\037\x80-\xff]+(?![^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff])|"[^\ \\x80-\xff\n\015"]*(?:\\[^\x80-\xff][^\\\x80-\xff\n\015"]*)*")[\04 0\t]*(?:\([^\\\x80-\xff\n\015()]*(?:(?:\\[^\x80-\xff]|\([^\\\x80-\ xff\n\015()]*(?:\\[^\x80-\xff][^\\\x80-\xff\n\015()]*)*\))[^\\\x80 -\xff\n\015()]*)*\)[\040\t]*)*(?:\.[\040\t]*(?:\([^\\\x80-\xff\n\0 15()]*(?:(?:\\[^\x80-\xff]|\([^\\\x80-\xff\n\015()]*(?:\\[^\x80-\x ff][^\\\x80-\xff\n\015()]*)*\))[^\\\x80-\xff\n\015()]*)*\)[\040\t] *)*(?:[^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff]+(?![^(\040)<>@,;:" .\\\[\]\000-\037\x80-\xff])|"[^\\\x80-\xff\n\015"]*(?:\\[^\x80-\xf f][^\\\x80-\xff\n\015"]*)*")[\040\t]*(?:\([^\\\x80-\xff\n\015()]*( ?:(?:\\[^\x80-\xff]|\([^\\\x80-\xff\n\015()]*(?:\\[^\x80-\xff][^\\ \x80-\xff\n\015()]*)*\))[^\\\x80-\xff\n\015()]*)*\)[\040\t]*)*)*@[ \040\t]*(?:\([^\\\x80-\xff\n\015()]*(?:(?:\\[^\x80-\xff]|\([^\\\x8 0-\xff\n\015()]*(?:\\[^\x80-\xff][^\\\x80-\xff\n\015()]*)*\))[^\\\ x80-\xff\n\015()]*)*\)[\040\t]*)*(?:[^(\040)<>@,;:".\\\[\]\000-\03 7\x80-\xff]+(?![^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff])|\[(?:[^\ \\x80-\xff\n\015\[\]]|\\[^\x80-\xff])*\])[\040\t]*(?:\([^\\\x80-\x ff\n\015()]*(?:(?:\\[^\x80-\xff]|\([^\\\x80-\xff\n\015()]*(?:\\[^\ x80-\xff][^\\\x80-\xff\n\015()]*)*\))[^\\\x80-\xff\n\015()]*)*\)[\ 040\t]*)*(?:\.[\040\t]*(?:\([^\\\x80-\xff\n\015()]*(?:(?:\\[^\x80- \xff]|\([^\\\x80-\xff\n\015()]*(?:\\[^\x80-\xff][^\\\x80-\xff\n\01 5()]*)*\))[^\\\x80-\xff\n\015()]*)*\)[\040\t]*)*(?:[^(\040)<>@,;:" .\\\[\]\000-\037\x80-\xff]+(?![^(\040)<>@,;:".\\\[\]\000-\037\x80- \xff])|\[(?:[^\\\x80-\xff\n\015\[\]]|\\[^\x80-\xff])*\])[\040\t]*( ?:\([^\\\x80-\xff\n\015()]*(?:(?:\\[^\x80-\xff]|\([^\\\x80-\xff\n\ 015()]*(?:\\[^\x80-\xff][^\\\x80-\xff\n\015()]*)*\))[^\\\x80-\xff\ n\015()]*)*\)[\040\t]*)*)*|(?:[^(\040)<>@,;:".\\\[\]\000-\037\x80- \xff]+(?![^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff])|"[^\\\x80-\xff \n\015"]*(?:\\[^\x80-\xff][^\\\x80-\xff\n\015"]*)*")[^()<>@,;:".\\ \[\]\x80-\xff\000-\010\012-\037]*(?:(?:\([^\\\x80-\xff\n\015()]*(? :(?:\\[^\x80-\xff]|\([^\\\x80-\xff\n\015()]*(?:\\[^\x80-\xff][^\\\ x80-\xff\n\015()]*)*\))[^\\\x80-\xff\n\015()]*)*\)|"[^\\\x80-\xff\ n\015"]*(?:\\[^\x80-\xff][^\\\x80-\xff\n\015"]*)*")[^()<>@,;:".\\\ [\]\x80-\xff\000-\010\012-\037]*)*<[\040\t]*(?:\([^\\\x80-\xff\n\0 15()]*(?:(?:\\[^\x80-\xff]|\([^\\\x80-\xff\n\015()]*(?:\\[^\x80-\x ff][^\\\x80-\xff\n\015()]*)*\))[^\\\x80-\xff\n\015()]*)*\)[\040\t] *)*(?:@[\040\t]*(?:\([^\\\x80-\xff\n\015()]*(?:(?:\\[^\x80-\xff]|\ ([^\\\x80-\xff\n\015()]*(?:\\[^\x80-\xff][^\\\x80-\xff\n\015()]*)* \))[^\\\x80-\xff\n\015()]*)*\)[\040\t]*)*(?:[^(\040)<>@,;:".\\\[\] \000-\037\x80-\xff]+(?![^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff])| \[(?:[^\\\x80-\xff\n\015\[\]]|\\[^\x80-\xff])*\])[\040\t]*(?:\([^\ \\x80-\xff\n\015()]*(?:(?:\\[^\x80-\xff]|\([^\\\x80-\xff\n\015()]* (?:\\[^\x80-\xff][^\\\x80-\xff\n\015()]*)*\))[^\\\x80-\xff\n\015() ]*)*\)[\040\t]*)*(?:\.[\040\t]*(?:\([^\\\x80-\xff\n\015()]*(?:(?:\ \[^\x80-\xff]|\([^\\\x80-\xff\n\015()]*(?:\\[^\x80-\xff][^\\\x80-\ xff\n\015()]*)*\))[^\\\x80-\xff\n\015()]*)*\)[\040\t]*)*(?:[^(\040 )<>@,;:".\\\[\]\000-\037\x80-\xff]+(?![^(\040)<>@,;:".\\\[\]\000-\ 037\x80-\xff])|\[(?:[^\\\x80-\xff\n\015\[\]]|\\[^\x80-\xff])*\])[\ 040\t]*(?:\([^\\\x80-\xff\n\015()]*(?:(?:\\[^\x80-\xff]|\([^\\\x80 -\xff\n\015()]*(?:\\[^\x80-\xff][^\\\x80-\xff\n\015()]*)*\))[^\\\x 80-\xff\n\015()]*)*\)[\040\t]*)*)*(?:,[\040\t]*(?:\([^\\\x80-\xff\ n\015()]*(?:(?:\\[^\x80-\xff]|\([^\\\x80-\xff\n\015()]*(?:\\[^\x80 -\xff][^\\\x80-\xff\n\015()]*)*\))[^\\\x80-\xff\n\015()]*)*\)[\040 \t]*)*@[\040\t]*(?:\([^\\\x80-\xff\n\015()]*(?:(?:\\[^\x80-\xff]|\ ([^\\\x80-\xff\n\015()]*(?:\\[^\x80-\xff][^\\\x80-\xff\n\015()]*)* \))[^\\\x80-\xff\n\015()]*)*\)[\040\t]*)*(?:[^(\040)<>@,;:".\\\[\] \000-\037\x80-\xff]+(?![^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff])| \[(?:[^\\\x80-\xff\n\015\[\]]|\\[^\x80-\xff])*\])[\040\t]*(?:\([^\ \\x80-\xff\n\015()]*(?:(?:\\[^\x80-\xff]|\([^\\\x80-\xff\n\015()]* (?:\\[^\x80-\xff][^\\\x80-\xff\n\015()]*)*\))[^\\\x80-\xff\n\015() ]*)*\)[\040\t]*)*(?:\.[\040\t]*(?:\([^\\\x80-\xff\n\015()]*(?:(?:\ \[^\x80-\xff]|\([^\\\x80-\xff\n\015()]*(?:\\[^\x80-\xff][^\\\x80-\ xff\n\015()]*)*\))[^\\\x80-\xff\n\015()]*)*\)[\040\t]*)*(?:[^(\040 )<>@,;:".\\\[\]\000-\037\x80-\xff]+(?![^(\040)<>@,;:".\\\[\]\000-\ 037\x80-\xff])|\[(?:[^\\\x80-\xff\n\015\[\]]|\\[^\x80-\xff])*\])[\ 040\t]*(?:\([^\\\x80-\xff\n\015()]*(?:(?:\\[^\x80-\xff]|\([^\\\x80 -\xff\n\015()]*(?:\\[^\x80-\xff][^\\\x80-\xff\n\015()]*)*\))[^\\\x 80-\xff\n\015()]*)*\)[\040\t]*)*)*)*:[\040\t]*(?:\([^\\\x80-\xff\n \015()]*(?:(?:\\[^\x80-\xff]|\([^\\\x80-\xff\n\015()]*(?:\\[^\x80- \xff][^\\\x80-\xff\n\015()]*)*\))[^\\\x80-\xff\n\015()]*)*\)[\040\ t]*)*)?(?:[^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff]+(?![^(\040)<>@ ,;:".\\\[\]\000-\037\x80-\xff])|"[^\\\x80-\xff\n\015"]*(?:\\[^\x80 -\xff][^\\\x80-\xff\n\015"]*)*")[\040\t]*(?:\([^\\\x80-\xff\n\015( )]*(?:(?:\\[^\x80-\xff]|\([^\\\x80-\xff\n\015()]*(?:\\[^\x80-\xff] [^\\\x80-\xff\n\015()]*)*\))[^\\\x80-\xff\n\015()]*)*\)[\040\t]*)* (?:\.[\040\t]*(?:\([^\\\x80-\xff\n\015()]*(?:(?:\\[^\x80-\xff]|\([ ^\\\x80-\xff\n\015()]*(?:\\[^\x80-\xff][^\\\x80-\xff\n\015()]*)*\) )[^\\\x80-\xff\n\015()]*)*\)[\040\t]*)*(?:[^(\040)<>@,;:".\\\[\]\0 00-\037\x80-\xff]+(?![^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff])|"[ ^\\\x80-\xff\n\015"]*(?:\\[^\x80-\xff][^\\\x80-\xff\n\015"]*)*")[\ 040\t]*(?:\([^\\\x80-\xff\n\015()]*(?:(?:\\[^\x80-\xff]|\([^\\\x80 -\xff\n\015()]*(?:\\[^\x80-\xff][^\\\x80-\xff\n\015()]*)*\))[^\\\x 80-\xff\n\015()]*)*\)[\040\t]*)*)*@[\040\t]*(?:\([^\\\x80-\xff\n\0 15()]*(?:(?:\\[^\x80-\xff]|\([^\\\x80-\xff\n\015()]*(?:\\[^\x80-\x ff][^\\\x80-\xff\n\015()]*)*\))[^\\\x80-\xff\n\015()]*)*\)[\040\t] *)*(?:[^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff]+(?![^(\040)<>@,;:" .\\\[\]\000-\037\x80-\xff])|\[(?:[^\\\x80-\xff\n\015\[\]]|\\[^\x80 -\xff])*\])[\040\t]*(?:\([^\\\x80-\xff\n\015()]*(?:(?:\\[^\x80-\xf f]|\([^\\\x80-\xff\n\015()]*(?:\\[^\x80-\xff][^\\\x80-\xff\n\015() ]*)*\))[^\\\x80-\xff\n\015()]*)*\)[\040\t]*)*(?:\.[\040\t]*(?:\([^ \\\x80-\xff\n\015()]*(?:(?:\\[^\x80-\xff]|\([^\\\x80-\xff\n\015()] *(?:\\[^\x80-\xff][^\\\x80-\xff\n\015()]*)*\))[^\\\x80-\xff\n\015( )]*)*\)[\040\t]*)*(?:[^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff]+(?! [^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff])|\[(?:[^\\\x80-\xff\n\01 5\[\]]|\\[^\x80-\xff])*\])[\040\t]*(?:\([^\\\x80-\xff\n\015()]*(?: (?:\\[^\x80-\xff]|\([^\\\x80-\xff\n\015()]*(?:\\[^\x80-\xff][^\\\x 80-\xff\n\015()]*)*\))[^\\\x80-\xff\n\015()]*)*\)[\040\t]*)*)*>)

email-opt.pl を元に冗長部分を削り落としたのが 以下のスクリプトです．冗長部分を削り落としてもかなりの量です．
(注意：$ctrl は本当は '\000-\037\0177' の間違いです)
(注意：正確には，RFC822 では $CRlist に \n は含まれていません)

# $email が正しいメールアドレスか判定する

$esc         = '\\\\';               $Period      = '\.';
$space       = '\040';               $tab         = '\t';
$OpenBR      = '\[';                 $CloseBR     = '\]';
$OpenParen   = '\(';                 $CloseParen  = '\)';
$NonASCII    = '\x80-\xff';          $ctrl        = '\000-\037';
$CRlist      = '\n\015';
$qtext       = qq/[^$esc$NonASCII$CRlist\"]/;
$dtext       = qq/[^$esc$NonASCII$CRlist$OpenBR$CloseBR]/;
$quoted_pair = qq<${esc}[^$NonASCII]>;
$ctext       = qq<[^$esc$NonASCII$CRlist()]>;
$Cnested     = qq<$OpenParen$ctext*(?:$quoted_pair$ctext*)*$CloseParen>;
$comment     =
    qq<$OpenParen$ctext*(?:(?:$quoted_pair|$Cnested)$ctext*)*$CloseParen>;
$X           = qq<[$space$tab]*(?:${comment}[$space$tab]*)*>;
$atom_char   = qq/[^($space)<>\@,;:\".$esc$OpenBR$CloseBR$ctrl$NonASCII]/;
$atom        = qq<$atom_char+(?!$atom_char)>;
$quoted_str  = qq<\"$qtext*(?:$quoted_pair$qtext*)*\">;
$word        = qq<(?:$atom|$quoted_str)>;
$domain_ref  = $atom;
$domain_lit  = qq<$OpenBR(?:$dtext|$quoted_pair)*$CloseBR>;
$sub_domain  = qq<(?:$domain_ref|$domain_lit)$X>;
$domain      = qq<$sub_domain(?:$Period$X$sub_domain)*>;
$route       = qq<\@$X$domain(?:,$X\@$X$domain)*:$X>;
$local_part  = qq<$word$X(?:$Period$X$word$X)*>;
$addr_spec   = qq<$local_part\@$X$domain>;
$route_addr  = qq[<$X(?:$route)?$addr_spec>];
$phrase_ctrl = '\000-\010\012-\037';
$phrase_char =
   qq/[^()<>\@,;:\".$esc$OpenBR$CloseBR$NonASCII$phrase_ctrl]/;
$phrase      =
    qq<$word$phrase_char*(?:(?:$comment|$quoted_str)$phrase_char*)*>;
$mailbox     = qq<$X(?:$addr_spec|$phrase$route_addr)>;

print "ok\n" if $email =~ /^$mailbox$/o;

perl5.6.0以前の perl では表現できなかったネストしたコメント 部分は，このスクリプトでは $Cnested と $comment の代入文で定義されており， 1回だけネストを許した正規表現となっています．この 2つの代入文を以下のように変更することでメール アドレスの正規表現を正確に記述することができるようになります．

use re 'eval';
$comment     =
  qr<$OpenParen$ctext*(?:(?:$quoted_pair|(??{$comment}))$ctext*)*$CloseParen>;

ただし，ここで使用している正規表現 (??{ code }) は 実験的なものなので今後変更されたり削除されるかもしれませんので注意が必要です． また， use re 'eval'; しているので，この点にも十分注意する必要があります． 何をどう注意する必要があるのかはマニュアルを読んでください． メールアドレスのパターンマッチが終わった時点で no re 'eval'; しておくことをお勧めします．

メールアドレスが正しいかどうかを調べるには モジュール Email::Valid または モジュール Mail::CheckUser を使うのがいいと思います． このモジュールを使えば，メールアドレスが RFC 822 に書かれている文法的に正しいかどうかだけではなく， そのメールアドレスが実際に有効かどうかもある程度調べることができます． ただし，その場合はもちろんインターネットに接続されている必要があります． 詳しい使い方はマニュアルを読んでください．

さて，ここまでで書いてきたメールアドレスというのは From行などで指定できるもののことでして，RFC 822 においては mailbox として定義されています． この mailbox をある文字列からメールアドレスを抽出する目的で使うのは 無茶というものです．そのような目的のときに必要とされるのは mailbox ではなく， addr-spec の方でしょう．mailbox や addr-spec がどのようなものかと言いますと，たとえば， Foo Bar <foobar@example.com> というのは mailbox ですが addr-spec ではありません． foobar@exmaple.com というのは addr-spec だけから成る mailbox になります．

そこで先ほどのスクリプトを修正し，ある文字列からメールアドレスを抽出する 目的で使うための addr-spec の正規表現を以下のように作りました．

# メールアドレスの正規表現 $mail_regex

$esc         = '\\\\';               $Period      = '\.';
$space       = '\040';
$OpenBR      = '\[';                 $CloseBR     = '\]';
$NonASCII    = '\x80-\xff';          $ctrl        = '\000-\037';
$CRlist      = '\n\015';
$qtext       = qq/[^$esc$NonASCII$CRlist\"]/;
$dtext       = qq/[^$esc$NonASCII$CRlist$OpenBR$CloseBR]/;
$quoted_pair = qq<${esc}[^$NonASCII]>;
$atom_char   = qq/[^($space)<>\@,;:\".$esc$OpenBR$CloseBR$ctrl$NonASCII]/;
$atom        = qq<$atom_char+(?!$atom_char)>;
$quoted_str  = qq<\"$qtext*(?:$quoted_pair$qtext*)*\">;
$word        = qq<(?:$atom|$quoted_str)>;
$domain_ref  = $atom;
$domain_lit  = qq<$OpenBR(?:$dtext|$quoted_pair)*$CloseBR>;
$sub_domain  = qq<(?:$domain_ref|$domain_lit)>;
$domain      = qq<$sub_domain(?:$Period$sub_domain)*>;
$local_part  = qq<$word(?:$Period$word)*>;
$addr_spec   = qq<$local_part\@$domain>;
$mail_regex  = $addr_spec;

このスクリプトは，先ほどのスクリプトから， 途中にコメントとスペースやタブがないように変更し，冗長部分を削除したものです． このスクリプトから求めた addr-spec は以下のようになりました．

(?:[^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff]+(?![^(\040)<>@,;:".\\
\[\]\000-\037\x80-\xff])|"[^\\\x80-\xff\n\015"]*(?:\\[^\x80-\xff][
^\\\x80-\xff\n\015"]*)*")(?:\.(?:[^(\040)<>@,;:".\\\[\]\000-\037\x
80-\xff]+(?![^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff])|"[^\\\x80-\
xff\n\015"]*(?:\\[^\x80-\xff][^\\\x80-\xff\n\015"]*)*"))*@(?:[^(\0
40)<>@,;:".\\\[\]\000-\037\x80-\xff]+(?![^(\040)<>@,;:".\\\[\]\000
-\037\x80-\xff])|\[(?:[^\\\x80-\xff\n\015\[\]]|\\[^\x80-\xff])*\])
(?:\.(?:[^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff]+(?![^(\040)<>@,;
:".\\\[\]\000-\037\x80-\xff])|\[(?:[^\\\x80-\xff\n\015\[\]]|\\[^\x
80-\xff])*\]))*

以下がこれを直接代入して使うスクリプトになります．

$mail_regex =
q{(?:[^(\040)<>@,;:".\\\\\[\]\000-\037\x80-\xff]+(?![^(\040)<>@,;:".\\\\} .
q{\[\]\000-\037\x80-\xff])|"[^\\\\\x80-\xff\n\015"]*(?:\\\\[^\x80-\xff][} .
q{^\\\\\x80-\xff\n\015"]*)*")(?:\.(?:[^(\040)<>@,;:".\\\\\[\]\000-\037\x} .
q{80-\xff]+(?![^(\040)<>@,;:".\\\\\[\]\000-\037\x80-\xff])|"[^\\\\\x80-} .
q{\xff\n\015"]*(?:\\\\[^\x80-\xff][^\\\\\x80-\xff\n\015"]*)*"))*@(?:[^(} .
q{\040)<>@,;:".\\\\\[\]\000-\037\x80-\xff]+(?![^(\040)<>@,;:".\\\\\[\]\0} .
q{00-\037\x80-\xff])|\[(?:[^\\\\\x80-\xff\n\015\[\]]|\\\\[^\x80-\xff])*} .
q{\])(?:\.(?:[^(\040)<>@,;:".\\\\\[\]\000-\037\x80-\xff]+(?![^(\040)<>@,} .
q{;:".\\\\\[\]\000-\037\x80-\xff])|\[(?:[^\\\\\x80-\xff\n\015\[\]]|\\\\[} .
q{^\x80-\xff])*\]))*};

このメールアドレスの正規表現 $mail_regex を使って，$email が正しいメールアドレスか判定するには次のように書きます． perl5.004以前の場合は \z の部分を $(?!\n) に置き換えてください．

# $email が正しいメールアドレス(addr_spec)か判定する

if ($email !~ /^$mail_regex\z/o) {
  print "不正なメールアドレスです\n";
}

余談ですが，DoCoMo(i-mode) と J-Phone(J-Sky) ではメールアドレスとして irregular.@docomo.ne.jp のように @ の直前が .(ピリオド) であるものも 使用できます．しかし，これは RFC 822 に適合しない不正なメールアドレスです．@ の前の local-part の部分では .(ピリオド) は必ず他の文字に挟まれていなければならないのです．したがって， .(ピリオド) が先頭にある場合と，@ の直前にある場合は不正なメールアドレスということになります． DoCoMo(i-mode)同士や J-Phone(J-Sky)同士でのメールのやりとりであれば 問題ありませんが，そうでなければ使用するべきではありません．

日本語を扱う

perl スクリプトは EUC-JP で書く

perl で日本語を扱うにはいろいろと注意しなければならないことがあります． なぜなら，日本語の文字コードには perl が特別な意味として解釈してしまう 文字が含まれているからです．たとえば，perl スクリプトを JIS で次のように書いたとします．

$str = "このTESTで充分";
$str =~ s/このTESTで充分/このテストで十分/;  # JIS でも SJIS でも駄目
print $str, "\n";

これを正常に実行することはできません． unmatched () in regexp となってしまうはずです． なぜなら，エスケープシーケンスの ESC ( B が含まれているために，( をグループ化のための開き括弧として 解釈してしまうからです．もちろん，このエラーは閉じ括弧の ) がないために括弧が対応していないというエラーです． それではこのスクリプトを SJIS で書いた場合はどうでしょう．今度は unmatched [] in regexp となってしまうはずです．なぜなら SJIS の「充」の文字コードは 0x8F 0x5B であり，0x5B というのは ASCII の [ の文字コードであるからです．

そこで SJIS の場合には正規表現でエラーにならないように， 次のようにパターンの部分を \Q と \E で挟んでエスケープするという回避方法があります．

$str = "このTESTで充分";
$str =~ s/\QこのTESTで充分\E/このテストで十分/;  # これで SJIS でも大丈夫？
print $str, "\n";

ところが，これを実際に実行してみると文字化けして しまいます．なぜなら，SJIS の「十」の文字コードは 0x8F 0x5C であり，0x5C というのは ASCII の \ の文字コードであるため，「分」の 1バイト目と合わせて特別な 意味として解釈しようとするためです．\ と「分」の 1バイト目を合わせたエスケープシーケンスというものは ありませんので，結果的に「十」の 2バイト目の \ は無視されることになります．

このように SJIS には 2バイト目が \ である文字が あるために文字化けしてしまいます．同様に，2バイト目が @ である文字では配列と解釈されてしまうことがあります． 2バイト目が \ である文字については，その後ろに \ を書けば回避することができますが，2バイト目が @ である文字についてはさらに別の回避手段を取らざるを得なくなります． ちなみに，SJIS で 2バイト目が \ である文字は 「―ソЫ噂浬欺圭構蚕十申曾箪貼能表暴予禄兔喀媾彌拿杤歃濬畚秉綵臀藹觸軆鐔饅鷭」 です．また，2バイト目が @ である文字は全角スペースと 「ァА院魁機掘后察宗拭繊叩邸如鼻法諭蓮僉咫奸廖戞曄檗漾瓠磧紂隋蕁襦蹇錙顱鵝」 です．これらの文字以外にも SJIS では問題となる文字がまだまだあります．

なお，さきほど SJIS の場合に \Q と \E で挟んでエスケープするという回避方法について 触れましたが，実はこの方法は完全ではありません． たとえば，次のスクリプトを見てください．

if ($str =~ /\Q$keyword\E/) {
  print "マッチした\n";
}

このスクリプトのように，あるキーワード $keyword を \Q と \E で挟めばエラーにならずにうまくパターンマッチできるという話があります． たしかにエラーにはなりませんが，たとえば SJIS で $str = 'テスト'; のときに $keyword = 'X'; でパターンマッチを行なうと マッチしてしまいます．これは SJIS の「ス」の文字コードが 0x83 0x58 であり，0x58 というのが ASCII の X の文字コードで あるためです．また， $str = 'ｃａ＜ｂ'; のときに $keyword = 'モ＝モ'; のときもマッチしてしまいます． これは「ｃａ＜ｂ」という文字列の文字コード 0x82 0x83 0x82 0x81 0x81 0x83 0x82 0x82 に対して， 1バイトずつずれた位置で 「モ＝モ」という文字列の文字コード 0x83 0x82 0x81 0x81 0x83 0x82 がマッチしてしまうからです．

perl で日本語を扱うための手段の 1つが jperl を使うということです． jperl はオリジナルの perl にパッチをあてて，日本語を扱えるようにしたものです． Windows用の jperl は以下の場所(鈴木 紀夫さん提供)から入手することができます．

http://homepage2.nifty.com/kipp/perl/jperl/

それでは最初のスクリプトを EUC-JP で書いた場合はどうでしょうか．EUC-JP で書いた場合には正常に実行できるはずです．なぜなら，EUC-JP には JIS や SJIS のように perl が特別な意味として解釈してしまうような 文字が含まれていないからです．perl で日本語を扱うには perl スクリプトを EUC-JP で書くのが一番簡単な方法です．以下では，EUC-JP でスクリプトを書くことを前提としています．

実は EUC-JP のパターンマッチにおいても SJIS と同じように 間違ってマッチしてしまう場合があります．このことについては 「正しくパターンマッチさせる」を参照してください．

トップへ

---

漢字コードを EUC-JP に変換して処理する

perl スクリプトは EUC-JP で書いたとしても， 入力した日本語の漢字コードが SJIS や JIS では正常な動作を期待することはできません．そこで何らかの処理を 行なうときには一度 EUC-JP に変換してから行ないます．perl スクリプトを EUC-JP で書き， 漢字コードが EUC-JP である日本語を 処理するというのが，perl で日本語を扱うときに一番問題が 起きにくい方法です．

入力した日本語の漢字コードが EUC-JP ではない場合，または， 漢字コードがわからない場合には，漢字コードを jcode.pl (歌代 和正さん作)を使って EUC-JP に変換してあげます． $str を EUC-JP に変換するには次のように書きます．

# $str を EUC-JP に変換する

require 'jcode.pl';

jcode::convert(\$str, 'euc');

'euc' の部分を 'sjis' や 'jis' にすれば， SJIS や JIS に変換できます．もし，入力した日本語の漢字コードが $code であるとわかっている場合には，次のように 明示的に指定することで内部で自動判別しないようにすることができます．

# 漢字コードが $code である $str を EUC-JP に変換する

require 'jcode.pl';

jcode::convert(\$str, 'euc', $code);

「漢字コードを調べる」で自動判別の判定精度を 上げて求めた $code を使いたいときにもこの書式を 使います．

余談ですが，次のように my 宣言された変数に対して， 型グロブを使って変換しようと するのは間違いです．

# my 宣言された変数を変換するときの間違った例

require 'jcode.pl';

my $str = 'my 宣言された変数の型グロブはない';

jcode::convert(*str, 'euc');

my 宣言された変数の型グロブはないので，これでは 変換することはできません． my 宣言された変数の ハードリファレンスは求めることができるので，最初のスクリプトのように 常に \$str のように書くのが一番問題の起きにくい 書き方です．

---

jcode.pl は以下の場所に最新バージョンが置いてあります．

ftp://ftp.iij.ad.jp/pub/IIJ/dist/utashiro/perl/

現在の最新バージョンは jcode.pl-2.13 です． これを取ってきて jcode.pl に名前を変更して使います． jcode.pl の使い方は jcode.pl の中に書かれています．よくわからなければ， 小塚 敦さんによる 「jcode.pl の私的な解説書」を読むといいかもしれません．

Jcode.pm - jcode.pl の後継(小飼 弾さん作)というものも公開されています． Jcode.pm は UNICODE に対応していますが，使用するには jcode.pl のようにコピーするだけでは駄目で，ちゃんと インストールする必要があります．なお，Windows用の perl である ActivePerl 5.6用に，コンパイル済みのパッケージが以下の場所(鈴木 紀夫さん 提供)で配布されています．

http://homepage2.nifty.com/kipp/perl/Jcode/index.html

バージョン 2.10以前の jcode.pl はスレッドが有効になっている perlでは使用することが できません．スレッドが有効になっている perl では特殊変数 $_ や @_ はレキシカル変数となります．レキシカル変数とは my 宣言された変数のことです． このレキシカル変数というのは local 宣言することが できないのですが，バージョン 2.10以前の jcode.pl では関数の引数を local 宣言した型グロブ *_ に代入しようとしているために正常に動作しません．最新バージョンの jcode.pl 及び Jcode.pm はスレッドが有効になっている perl でも正常に動作します．

手元の perl のスレッドが有効になっているかどうかを調べるには perl -V と入力し実行します．このとき usethreads=undef となっていれば無効になっているので jcode.pl を安心して使うことができます． perl5.005より前の perl もスレッド機能がないので問題ありません． もし，スレッドが有効になっていた場合にはバージョン 2.10以前の jcode.pl が使えないことはもちろんの こと，特殊変数 $_ や @_ がレキシカル変数になっていることにも注意してスクリプトを書く必要があります．

トップへ

---

漢字コードを調べる

# $str の漢字コードを調べる

require 'jcode.pl';

($match, $code) = jcode::getcode(\$str);
$code = 'euc' if $code eq undef and $match > 0;

jcode.pl の getcode 関数を使います． $code には 'euc' や 'sjis'，'jis' といった文字列が入っています．詳しくは jcode.pl の中の説明を読んでください．

ここで注意が必要なのは，漢字コードを正確に 調べることには限界があるということです．SJIS の漢字(第二水準)の一部や SJIS の半角カタカナ 2文字は EUC-JP の漢字 1文字と区別がつきません．もし，漢字コードが EUC-JP か SJIS の両方の可能性があり，どちらか判断できないときには jcode::getcode() は undef を返します．ただ， 厳密にはどちらか判断できないとは言え，半角カタカナが含まれていない場合にはほ とんどの場合 EUC-JP であるので，上のスクリプトでは最終的に undef ではなく EUC-JP としています．

jcode::getcode() は SJIS の半角カタカナを考慮せずに判定しています． このため，SJIS だと判断できる半角カタカナが含まれている文字 列でも EUC-JP と間違ってしまうことがあります．そこで，次のよう に書くことで判定精度を上げることができます．

# $str の漢字コードを調べる

require 'jcode.pl';

($match, $code) = jcode::getcode(\$str);
$code = 'euc' if $code eq undef and $match > 0;

$ascii = '[\x00-\x7F]';
if ($code eq 'euc') {
  if ($str !~ /^(?:$jcode::re_euc_c|$jcode::re_euc_kana|
                   $jcode::re_euc_0212|$ascii)*$/ox) {
    if ($str =~ /^(?:$jcode::re_sjis_c|$jcode::re_sjis_kana|$ascii)*$/o) {
      $code = 'sjis';
    }
  }
}

これで SJIS を EUC-JP と間違って判定する可能性を 減らすことができますが， その分処理に時間がかかってしまうことを忘れてはいけません．このようにして 自動判定の判定精度を上げて求めた $code は漢字コードを変換するときにも利用することができます． 漢字コードの変換に関しては 「漢字コードを EUC-JP に変換して処理する」を参照．

トップへ

---

全角文字が含まれているか判定する

$str は EUC-JP という前提ですので， 必要ならばあらかじめ EUC-JP に変換しておいてください． 漢字コードの変換に関しては 「漢字コードを EUC-JP に変換して処理する」を参照．

# $str に全角文字(半角カタカナを含まない)が含まれているか判定する

if ($str =~ /[\xA1-\xFE][\xA1-\xFE]/) {
  print "含まれている\n";
}

全角文字は JIS X 0208 と JIS X 0212 なので， 半角カタカナである JIS X 0201片仮名 は含みません．全角文字が 含まれているかどうかを判定するには，JIS X 0208 と JIS X 0212 の共通部分であり，ASCII や JIS X 0201片仮名 では現れないパターン /[\xA1-\xFE][\xA1-\xFE]/ を使って判定します．

# $str に半角カタカナが含まれているか判定する

if ($str =~ /\x8E/) {
  print "含まれている\n";
}

半角カタカナが含まれているかどうかを判定するには，EUC-JP では /\x8E/ を調べるだけでできます．

# $str に ASCII 以外が含まれているか判定する

if ($str =~ /[\x8E\xA1-\xFE]/) {
  print "含まれている\n";
}

ASCII 以外の文字が含まれているかを判定するには， /[\x8E\xA1-\xFE]/ を調べることでできます． \x8E があれば JIS X 0201片仮名 の 1バイト目でマッチし， [\xA1-\xFE] があれば JIS X 0208 の 1バイト目か， JIS X 0212 の 2バイト目でマッチしますので， ASCII 以外の文字が含まれていることがわかります．

$str が EUC-JP かどうかも わからないときは jcode.pl を使って調べることもできます． jcode.pl を使って 「漢字コードを調べる」で書いたスクリプトで $str の漢字コードを調べた結果が undef の場合は ASCII 以外の文字は含まれていないとすることができます． 逆に言えば，undef ではない場合は ASCII 以外の文字が 含まれているとすることができます．このとき，次のように慌てて $match を使わずに，いきなり undef かどうかを調べる方法は間違っています．

# $str に ASCII 以外が含まれているか判定するときの間違った例

require 'jcode.pl';
$code = jcode::getcode(\$str);

if ($code eq undef) {
  print "ASCII以外は含まれていない\n";
  print "この判断は間違い\n";
}

jcode::getcode() は EUC-JP か SJIS の両方の可能性があり，どちらか判断できないときにも undef を返します．「漢字コードを調べる」で書いて あるように $match を使って undef の場合を処理する必要があります．

トップへ

---

文字が途切れているか判定する

$str は EUC-JP という前提ですので， 必要ならばあらかじめ EUC-JP に変換しておいてください． 漢字コードの変換に関しては 「漢字コードを EUC-JP に変換して処理する」を参照．

# $str の最後の文字が途切れているか判定する

if ($str =~ /\x8F$/ or $str =~ tr/\x8E\xA1-\xFE// % 2) {
  print "最後の文字が途切れている\n";
}

EUC-JP で文字が途切れる可能性があるのは，JIS X 0201片仮名(半角カタカナ)とJIS X 0208(全角文字)と JIS X 0212(補助漢字)です． JIS X 0212 は 3バイトで表わされ，最初が \x8F で始まります．最初の条件は $str が \x8F で終わっていた場合， すなわち，JIS X 0212 が 1バイト目で 途切れていた場合を表わしています． 次の条件が JIS X 0201片仮名 と JIS X 0208 が 1バイト目で途切れていた場合と，JIS X 0212 が 2バイト目で途切れていた場合です． tr/\x8E\xA1-\xFE// は $str の中の，JIS X 0201片仮名 と JIS X 0208 の 1バイト目と 2バイト目， JIS X 0212 の 2バイト目と 3バイト目の数を数えています．この数がもし奇数ならば文字が 途切れていることがわかります．

トップへ

---

全角英数字を半角英数字に変換する

$str は EUC-JP という前提ですので， 必要ならばあらかじめ EUC-JP に変換しておいてください． 漢字コードの変換に関しては 「漢字コードを EUC-JP に変換して処理する」を参照．

# $str の全角英数字を半角英数字に変換する

require 'jcode.pl';

jcode::tr(\$str, '０-９Ａ-Ｚａ-ｚ', '0-9A-Za-z');

jcode.pl の tr 関数を使います．この関数は全角文字に対応した tr です．詳しくは jcode.pl の中の説明を 読んでください．基本的に tr なので，全角英数字以外にも全角スペースを半角スペースにするなどの変換も 次のように書くことで簡単にできます．

# $str の全角スペースなどを半角スペースなどに変換する

require 'jcode.pl';

jcode::tr(\$str, '　（）＿＠－', ' ()_@-');

逆に，第 1引数と第 2引数を逆にすれば， 半角文字を全角文字にすることもできます． 半角カタカナと全角カタカナの相互変換に関しては 「半角カタカナを全角カタカナに変換する」を参照．

トップへ

---

半角カタカナを全角カタカナに変換する

$str は EUC-JP という前提ですので， 必要ならばあらかじめ EUC-JP に変換しておいてください． 漢字コードの変換に関しては 「漢字コードを EUC-JP に変換して処理する」を参照．

# $str の半角カタカナを全角カタカナに変換する

require 'jcode.pl';

jcode::h2z_euc(\$str);

jcode.pl の h2z_euc 関数を使います．

トップへ

---

正しくパターンマッチさせる

$str および $pattern は EUC-JP という前提ですので， 必要ならばあらかじめ EUC-JP に変換しておいてください． 漢字コードの変換に関しては 「漢字コードを EUC-JP に変換して処理する」を参照． perl で日本語を扱う場合にはスクリプトを EUC-JP で書き， 漢字コードが EUC-JP である日本語を処理するというのが 一番問題が起きにくい方法であるということを 「perl スクリプトは EUC-JP で書く」と 「漢字コードを EUC-JP に変換して処理する」で述べました．しかし，それだけでは少し困ったことが 起きることがあります．たとえば，次のようなスクリプトを実行すると 間違ってマッチしてしまいます． # 間違ってマッチしてしまう例 $str = 'これはテストです'; $pattern = '好'; if ($str =~ /$pattern/) { print "マッチした\n"; } なぜこのようなことが起きてしまうのかというと，EUC-JP の「ス」の文字コードは 0xA5 0xB9 ，「ト」は 0xA5 0xC8，「好」は 0xB9 0xA5 であり，ちょうど「スト」の真ん中の部分が「好」と同じになるのでマッチして しまうのです．このようにずれた場所でマッチして しまっては困る場合には次のように書きます． # $str に $pattern を正しくマッチさせる $ascii = '[\x00-\x7F]'; $twoBytes = '[\x8E\xA1-\xFE][\xA1-\xFE]'; $threeBytes = '\x8F[\xA1-\xFE][\xA1-\xFE]'; if ($str =~ /^(?:$ascii|$twoBytes|$threeBytes)*?(?:$pattern)/) { print "マッチした\n"; }

なぜこのような書き方になるのか説明します．最初の間違ってマッチしてしまう スクリプトでは /$pattern/ というように無造作にマッチ させようとしたためにずれた場所でマッチしてしまいました．そこで，ずれた場所で マッチしないようにするには，$pattern の前には日本語の 文字が何文字かあって，その後に $pattern がくると いうことを明示的に書いてあげる必要があります．EUC-JP での 1文字というのは 1バイト文字である ASCII， 2バイト文字である JIS X 0201片仮名(半角 カタカナ)と JIS X 0208(全角文字)，3バイト文字で ある JIS X 0212(補助漢字)のことです．これを正規表現で 表わしたのが (?:$ascii|$twoBytes|$threeBytes) の部分です．この文字が文字列の先頭から何文字か続いた後に $pattern がくるということを正規表現で書いたのが 上のスクリプトです．

正規表現で任意の一文字を表わすには普通 .(ピリオド)を使いますが， 日本語の文字列に対するマッチングでは， .(ピリオド) で書きたくなる場所を (?:$ascii|$twoBytes|$threeBytes) とすればいいことに なります．最初のスクリプトの /$pattern/ も /^.*?(?:$pattern)/ だと思えば上のスクリプトのように なるのも納得していただけるのではないでしょうか．

日本語の文字列に対して正しくマッチさせる方法として，これまで 書いてきたように EUC-JP での 1文字というものを ちゃんと意識して正規表現を書くという方法以外に，あらかじめマッチさせる 前に 2バイト文字と 3バイト文字の後ろに 文字の区切りがわかるように区切り文字をつけておくと いう方法があります． 具体的には次のように，マッチの対象となっている日本語の文字列 $str と，マッチさせようとしているパターン $pattern の両方に区切り文字をつける処理をしてから マッチングを行ないます．このスクリプトでは区切り文字として \000 を使っています．

# 区切り文字をつけて正しくマッチさせる(非常に遅い)

$twoBytes = '[\x8E\xA1-\xFE][\xA1-\xFE]';
$threeBytes = '\x8F[\xA1-\xFE][\xA1-\xFE]';

$pattern =~ s/($twoBytes|$threeBytes)/$1\000/og;
$str =~ s/($twoBytes|$threeBytes)/$1\000/og;

if ($str =~ /$pattern/) {
  print "マッチした\n";
}

この方法ではマッチさせる前に区切り文字をつける処理を行なうことで， 正規表現そのものは普通に書くことができます．この方法はわかりやすいところは いいのですが，おそらくほとんどの 場合区切り文字を使わない最初のスクリプト よりも実行速度が遅いでしょう．

この 2つ方法の特徴を考えてみます．区切り文字を使わない方法は， 前処理なしにすぐにパターンマッチを始めることができる．しかし，パターンマッチ そのものは正規表現が複雑なため少し遅い．区切り文字を使った方法は，あらかじめ 文字列全体に対し区切り文字を入れる前処理を行なう必要がある．ただ，パターン マッチそのものは正規表現が複雑にならないために速い．

それでは実際に比較したらどうなるか調べてみました． パターンマッチが成功しなかった場合，文字列全体に対し検索を行なうことに なりますが，私がベンチマークをとってみたところ，区切り文字を使わない 方法の方が圧倒的に速かった (約 15倍) です．パターン マッチが成功する場合には，文字列の途中で検索を止めることができるので， 文字列全体に対して必ず前処理を行なわなければならない区切り文字を使った 方法の方が遅いことは言うまでもありません．結局，区切り文字を使わない方法は 正規表現が複雑になった分パターンマッチそのものは少し遅くなりますが， 区切り文字を使う方法の方は，いかんせん区切り文字を入れる処理が遅すぎて パターンマッチそのものの速さが全然活きなかったようです．

この結果からすると，データの中 からマッチするものだけ取り出すような処理には明らかに区切り文字を使わない 最初のスクリプトの方がいいと言えます．区切り文字を使った方法の方がいい 場合としては，前処理の遅さをパターンマッチの速さで 補えるほど何度も同じ文字列に対してパターンマッチを行なう場合です． もちろん，これら実行速度に関しては環境に依存する話ですので，実際に自分の 環境で試してみるのがいいでしょう．

次に，日本語の文字列を正しく置換する方法について説明します．次のような スクリプトが間違って置換してしまうということはすでに説明したとおりです．

# 間違って置換してしまう例

$str = 'これはテストです';
$pattern = '好';
$replace = '嫌';

$str =~ s/$pattern/$replace/g;

次のように書くことで正しく置換することができます．

# $str の $pattern を $replace に正しく置換する

$ascii = '[\x00-\x7F]';
$twoBytes = '[\x8E\xA1-\xFE][\xA1-\xFE]';
$threeBytes = '\x8F[\xA1-\xFE][\xA1-\xFE]';

$str =~ s/\G((?:$ascii|$twoBytes|$threeBytes)*?)(?:$pattern)/$1$replace/g;

このスクリプトの基本的な考え方は，EUC-JP での 1文字というものをちゃんと意識して正規表現を書くマッチの 方法と同じです．ただ，マッチさせるだけの場合と違うのは $1 と \G を使っているところです． $1 を使うのは，置換する部分をマッチさせるときに $pattern の前にある文字もいっしょにマッチさせる ことになるため，この部分を置換せずにそのまま残してあげる必要があるからです． そこで $pattern の前の部分に当たる正規表現 (?:$ascii|$twoBytes|$threeBytes)*? を括弧で囲って $1 で参照できるようにしています．

次に \G の説明をします． \G を使うのは修飾子 g がつけられているためです． 修飾子 g は，マッチするかどうか判定するだけならば 必要ないですし， また，1回しか置換しない場合も必要ありません． そのときは修飾子 g をつけるのをやめて， \G を文字列の先頭にマッチする ^ に変えることができます．逆に言えば，修飾子 g をつけて $str の中の $pattern をすべて置換したいときに，文字列の先頭にだけマッチする ^ を使うことができないということです．\G は修飾子 g がつけられている ときに，パターンマッチの開始位置にマッチします． つまり，\G は 一番最初は ^ と同じで，次からは $pattern のすぐ後ろでマッチします．わかりやすく簡単に 言うと，\G はマッチするかどうかこれから調べようと している残りの部分の先頭にマッチすると言えます．\G を使うことで，ずれた位置で $pattern がマッチすることがないようになります．

置換の場合にも次のように区切り文字をつけて正しく置換する方法があります．

# 区切り文字をつけて正しく置換させる(非常に遅い)

$twoBytes = '[\x8E\xA1-\xFE][\xA1-\xFE]';
$threeBytes = '\x8F[\xA1-\xFE][\xA1-\xFE]';

$pattern =~ s/($twoBytes|$threeBytes)/$1\000/og;
$str =~ s/($twoBytes|$threeBytes)/$1\000/og;

$str =~ s/$pattern/$replace/g;
$str =~ tr/\000//d;
# $str =~ s/($twoBytes|$threeBytes)\000/$1/og;

基本的に区切り文字をつけて正しくマッチさせる方法と同じです．ただ， マッチさせるだけの場合と違って，置換後に区切り文字を削除する必要があります． このスクリプトでは区切り文字に \000 を使っていて， 置換後にこの区切り文字を tr を使って削除しています．ところが， $str の中に初めから含まれていた \000 もいっしょに削除してしまいます． tr を使って削除できるのは $str の中に区切り文字と同じ \000 が含まれていないという前提が必要です．もし， $str の中に \000 が含まれて いるかもしれない場合には tr を使って区切り文字を削除するのを止めて， $str =~ tr/\000//d; を $str =~ s/($twoBytes|$threeBytes)\000/$1/og; に変更します．

実行速度について 2つの方法を比較してみました． 与えた文字列に対して全く置換するところがなかった場合には，区切り文字を使わない 方法の方が圧倒的に速かった (約 35倍) です．全部の文字を置換する必要がある文字列を与えた 場合でも，区切り文字を使わない方法の方が 4割程度速かったです．もし，区切り文字を使う場合の 方法で後処理に tr を使わなかった場合には更にスピード差が出るでしょう． 結局，置換の場合でも区切り文字を使う場合は，前処理と後処理に時間がかかり すぎるということが言えます． 実行速度に関しては環境に依存する話なので，どちらが速いか自分の環境で試してみる のが一番だということは言うまでもありません．

さて，ここまでの話では $pattern は Perl の文法的に 正しい正規表現という前提でした．ですから， たとえば開き括弧 ( にマッチさせたい場合には \( というようにエスケープする必要があります．CGI などにおいて，ユーザ入力の文字列でマッチするものを検索したい場合などには， 入力された文字列を正規表現として解釈するのではなく，その文字列そのもので 検索したい場合がほとんどでしょう．そのようなときに， $pattern としてパターンマッチを行なうと，先ほどの例で 挙げた開き括弧 ( などが入力されたときに正規表現として 正しくないとエラーになってしまいます．そこで正規表現で特別な意味として 解釈される開き括弧などのメタ文字はエスケープして パターンマッチさせる必要があります．

そのためには，ユーザ入力 $keyword に対して， これまでに書いたスクリプトの $pattern の部分を \Q$keyword\E に変更して，パターンマッチの場合は，

if ($str =~ /^(?:$ascii|$twoBytes|$threeBytes)*?\Q$keyword\E/) {
  print "マッチした\n";
}

置換の場合は，

$str =~ s/\G((?:$ascii|$twoBytes|$threeBytes)*?)\Q$keyword\E/$1$replace/g;

というようにします．\Q から \E までメタ文字が無視されるようになります．

次に実行速度を上げるための方法を 1つ書いておきます． これまで 書いてきたように，日本語の文字列に対して正しくマッチさせたり置換する ためには少々複雑な正規表現を使う必要があります．そのため，その複雑に なった分だけ実行速度が遅くなってしまいます． これは，大量のデータの中から 検索したり置換したりする場合には非常に時間がかかるようになってしまうことを 意味します．

ここで少し考えてみてください．大量のデータの中から検索するとき， そのほとんどの場合はマッチしないのです． つまり，マッチしないのですから正しくマッチさせる必要はないのです． そこで $pattern を検索したいときには， 次のようにすることでほとんどの 場合実行速度を上げることができます．

if ($str =~ /$pattern/) {
  if ($str =~ /^(?:$ascii|$twoBytes|$threeBytes)*?(?:$pattern)/) {
    print "マッチした\n";
  }
}

$keyword の場合は， /\Q$keyword\E/ という正規表現は使わずに次のように index 関数を使います．

if (index($str, $keyword) > -1) {
  if ($str =~ /^(?:$ascii|$twoBytes|$threeBytes)*?\Q$keyword\E/) {
    print "マッチした\n";
  }
}

index 関数は正規表現 に比べて実行速度が圧倒的に速いので，なんでもかんでも 正規表現ではなく，index 関数が使えないか常に 考えたいものです．

※上記の内容について
最近の perl(perl5.8.8等)では，index 関数を使うよりも， /\Q$keyword\E/ という正規表現を使った方が 速いようです．実行速度は perl のバージョンや実行環境，スクリプト等に 影響されるため，必要に応じてベンチマークをとるのがよいでしょう．

これまで書いてきた方法は EUC-JP だけではなく，SJIS の場合に も応用することができます．SJIS の場合にも SJIS での 1文字という ものを意識して正規表現を書くことになります．SJIS での 1文字に ついては，「文字の正規表現」を参照．

実は，EUC-JP で perl5.005 以降という条件におい ては，ほとんどの場合にこれまで書いてきた方法よりも実行速度 が速く，より扱いやすい方法があります．以下に まとめて列挙します．

# EUC-JP で perl5.005 以降限定の方法

$eucpre = qr{(?<!\x8F)};
$eucpost = qr{
    (?=                         
     (?:[\xA1-\xFE][\xA1-\xFE])* # JIS X 0208 が 0文字以上続いて
     (?:[\x00-\x7F\x8E\x8F]|\z)  # ASCII, SS2, SS3 または終端
    )
 }x;

if ($str =~ /$eucpre(?:$pattern)$eucpost/) {          # パターンマッチ
  print "マッチした\n";
}

if ($str =~ /$eucpre\Q$keyword\E$eucpost/) {      # キーワードマッチ
  print "マッチした\n";
}

$str =~ s/$eucpre(?:$pattern)$eucpost/$replace/g;     # パターン置換

$str =~ s/$eucpre\Q$keyword\E$eucpost/$replace/g; # キーワード置換

いずれの場合においても，$eucpre と $eucpost で挟むだけになります．この方法は 正規表現の後読み(lookbehind) と先読み(lookahead) を使っています．後読みは (?<regex)，先読みは (?=regex) という正規表現になります．このスクリプトでは後読みは否定後読みの (?<!regex) の方を使っています．

この方法はマッチさせたい正規表現にマッチしたものがずれた位置ではないこと を後読みと先読みによって保証しています．具体的には，後読みの部分で JIS X 0212 の 2バイト目からずれてマッチしてい ないかチェックしています．JIS X 0212 の 2バイト目からマッチしていた場合は，マッチした部分の直前に JIS X 0212 の 1バイト目，すなわち， \x8F があることになります．しかし，後読みによって \x8F ではないことが保証されているので， JIS X 0212 の 2バイト目からずれてマッチすることは なくなります．

また，JIS X 0208 の 2バイト目からずれてマッチし てしまう場合と JIS X 0212 の 3バイト目からずれてマッ チしてしまう場合についてのチェックは先読み部分で行なっています．もし，このよ うな位置からずれてマッチしてしまった場合，先読み部分にマッチしなくなります． 先読み部分はマッチした部分の後ろに正しく EUC-JP の文字列が続い ているかどうかをチェックしています．具体的には，マッチした部分の後ろから， JIS X 0208以外のものが来るまで，正しく JIS X 0208 文字が続いているかどうかをチェックしています．

この方法では先読みと後読みだけで正しくマッチさせることができます．先読み と後読みはどちらもそれ自体にはマッチした文字列を含まない 0文字幅の正規表現です．したがって，置 換する場合に置換後の文字列の中に $eucpre や $eucpost にマッチした部分のことを考えての $1 のようなものを必要としなくなります．

トップへ

---

前後の空白文字(全角スペース含)を削除する

# $str の先頭の空白文字(全角スペース含)を削除する
$str =~ s/^(?:\s|$Zspace)+//o; # $str が EUC-JP の場合
$str =~ s/^(?:\s|$Zspace_sjis)+//o; # $str が SJIS の場合

# $str の末尾の空白文字(全角スペース含)を削除する
$str =~ s/^($character*?)(?:\s|$Zspace)+$/$1/o; # $str が EUC-JP の場合
$str =~ s/$eucpre(?:\s|$Zspace)+$//o; # $str が EUC-JP の場合(perl5.005以降)

$str =~ s/^($character_sjis*?)(?:\s|$Zspace_sjis)+$/$1/o; # $str が SJIS の場合

上記スクリプトで使用している変数については 「文字の正規表現」 および 「正しくパターンマッチさせる」 を参照してください．

前後の全角スペースを含む空白文字を削除するとき，次のように書くと 間違って削除してしまう可能性があります．

# $str の末尾の空白文字(全角スペース含)を削除する(間違い)
$str =~ s/(?:\s|$Zspace)+$//o; # $str が EUC-JP の場合
$str =~ s/(?:\s|$Zspace_sjis)+$//o; # $str が SJIS の場合

先頭の空白文字を削除する場合については特に問題ありませんが， 末尾の空白文字を削除するときには全角スペースがマルチバイト文字の一部などに 間違ってマッチしてしまう可能性があります．例えば，SJIS で $str = '＠＝@'; の場合， 間違って末尾を削除してしまいます．詳しくは， 「perl スクリプトは EUC-JP で書く」 および 「正しくパターンマッチさせる」 を参照してください．

トップへ

---

文字単位に分割する

$str は EUC-JP という前提ですので， 必要ならばあらかじめ EUC-JP に変換しておいてください． 漢字コードの変換に関しては 「漢字コードを EUC-JP に変換して処理する」を参照．

# $str を文字単位に分割して配列 @chars に代入する

$ascii = '[\x00-\x7F]';
$twoBytes = '[\x8E\xA1-\xFE][\xA1-\xFE]';
$threeBytes = '\x8F[\xA1-\xFE][\xA1-\xFE]';

@chars = $str =~ /$ascii|$twoBytes|$threeBytes/og;

最後の代入文をわかりやすく， @chars = ($str =~ /($ascii|$twoBytes|$threeBytes)/og; と書いてもほぼ同等の動作をします．先にそのように書いた場合の説明をします． EUC-JP での 1文字が $ascii|$twoBytes|$threeBytes と正規表現で表わすことができることを 「正しくパターンマッチさせる」で述べました． これを括弧で囲ってグループにしています．一方，この代入文は 配列 @chars への代入なので， 右辺はリストコンテキストで実行されます． パターンマッチをリストコンテキストで実行すると，グループにされた正規表現に マッチする文字列のリストが返されます．つまり， ($1, $2, $3,…) というリストが返されます． さらに修飾子 g がつけられていますので， ($1, $2, $3,…, $1, $2, $3,…) というリストが 返されることになります．この場合はグループにされている正規表現が 1つですので，ちょうど EUC-JP での 1文字に分割されたリストが返されることになります．

最初のスクリプトでは @chars への代入文の右辺全体を 括弧で囲っていませんが，これは = よりも =~ の方が演算子の優先順位が高いので， @char = $str を先に実行してしまうということはありません．

また，正規表現の全体を括弧で囲っていませんが，修飾子 g がつけられているパターンマッチをリストコンテキストで実行したとき， 正規表現の中に括弧が 1つもなかった 場合は自動的に正規表現全体を括弧で囲ってあるものと して動作します．このとき，正規表現全体を括弧で囲った 場合よりも実行速度が速いです．後から $1 として使用するわけでもなく正規表現全体を括弧で囲う ような場合には括弧をつけない方がよいでしょう．

トップへ

---

特定の長さで折り返す

# $str を $bytesバイトで折り返す

require 'fold.pl';

while (length($str)) {
  (my $folded, $str) = fold($str, $bytes);
  print $folded, "\n";
}

fold.pl (歌代 和正さん作)を使うのが簡単です．fold.pl を 使わず，「文字が途切れているか判定する」で書いたように 文字が途切れていないか判定しながら substr 関数を使って折り返すという方法もありますが， わざわざ書く必要はないでしょう． fold 関数 の第 3引数に 1 を指定すれば， 折り返した結果 $bytesバイトに満たない場合には スペースを補って $bytesバイトになるようにすることが できます．また， 第 4引数に 1 を指定すれば単語境界で折り返すようになります． 詳しくは fold.pl の中の説明を読んでください．なお， fold.pl は補助漢字と SJIS の半角カタカナには対応して いません．また，EUC-JP の半角カタカナは 2バイト文字として扱いますので，半角カタカナが混じっていると 表示幅にずれが発生します．表示幅をそろえたい場合には，半角カタカナを あらかじめ全角カタカナに変換しておくか，折り返すバイト数を適当に処理して あげる必要があります．

Jcode.pm の jfold 関数 を使っても同じことができますが，単語境界で折り返したりはできません．

おまけとして，半角カタカナに対応した禁則処理しつつ折り返すスクリプトを 載せておきます．このスクリプトは EUC-JP で書かれ， $str も EUC-JP という前提ですので，必要ならばあらかじめ EUC-JP に変換しておいてください．漢字コードの変換に関しては 「漢字コードを EUC-JP に変換して処理する」を参照．

# $str を禁則処理しつつ折り返す

require 'fold.pl';
require 'jcode.pl';

$no_begin = "!%),.:;?]}￠°’”‰′″℃、。々〉》」』】〕" .
    "ぁぃぅぇぉっゃゅょゎ゛゜ゝゞァィゥェォッャュョヮヵヶ" .
    "・ーヽヾ！％），．：；？］｝";              # 行頭禁則文字
$no_begin_jisx0201 = "。」、・ァィゥェォャュョッー゛゜";
jcode::z2h_euc(\$no_begin_jisx0201);
$no_begin .= $no_begin_jisx0201;                 # 行頭禁則文字(半角カタカナ)
$no_end = "\$([{￡\‘“〈《「『【〔＄（［｛￥";  # 行末禁則文字
$no_end_jisx0201 = "「";
jcode::z2h_euc(\$no_end_jisx0201);
$no_end .= $no_end_jisx0201;                     # 行末禁則文字(半角カタカナ)
$allow_end = $no_begin;                          # ぶら下げ行頭禁則文字
$del_space = '(?:\s|\xA1\xA1)';                  # 削除する行頭行末空白
$basebytes = 74;                                 # 基本長
$maxbytes = 76;                                  # 最大長
$ascii = '[\x00-\x7F]';
$twoBytes = '[\x8E\xA1-\xFE][\xA1-\xFE]';
$threeBytes = '\x8F[\xA1-\xFE][\xA1-\xFE]';

map {$no_begin{$_} = 1;} ($no_begin =~ /$ascii|$twoBytes|$threeBytes/og);
map {$no_end{$_} = 1;} ($no_end =~ /$ascii|$twoBytes|$threeBytes/og);
map {$allow_end{$_} = 1 + /[\xA1-\xFE]/ - /\x8E/;}
    ($allow_end =~ /$ascii|$twoBytes|$threeBytes/og);

sub fold_properly {
  my $str = shift;
  my($folded, $strtmp, $bytestmp, $begin_char, $end_char, $flag);
  $flag = 1; # 行頭禁則処理状態(1:ぶら下げ, 0:追い出し)
  $bytestmp = $basebytes;
  $str =~ tr/\t\n\r\f/ /; # 空白文字をスペースに変換
  $str =~ s/^$del_space+//o; # 行頭空白削除
  ($begin_char) = %no_begin; # 行頭禁則文字を 1文字代入
  while ($no_begin{$begin_char} or $no_end{$end_char}) {
    ($folded, $strtmp) = fold($str, $bytestmp, 0, 1);
    while (length($folded) - ($folded =~ tr/\x8E//) <= $basebytes and
   $strtmp ne '' and $flag) { # 半角カタカナのための表示幅処理
      ($folded, $strtmp) = fold($str, $bytestmp, 0, 1);
      my ($folded_tmp, $strtmp_tmp) = fold($str, $bytestmp + 1, 0, 1);
      if (length($folded_tmp) - ($folded_tmp =~ tr/\x8E//) <= $basebytes) {
        ($folded, $strtmp) = ($folded_tmp, $strtmp_tmp);
        $bytestmp++;
      } else {
        last;
      }
    }
    ($begin_char) = $strtmp =~ /^$del_space*($ascii|$twoBytes|$threeBytes)/o;
    ($end_char) = $folded =~ /($threeBytes|$twoBytes|$ascii)$/o;
    if ($flag) { # ぶら下げ禁則処理
      if ($no_begin{$begin_char} and $allow_end{$begin_char}) { # ぶら下げ可能
        if (length($folded) - ($folded =~ tr/\x8E//)
            + $allow_end{$begin_char} <= $maxbytes) {
          $bytestmp++;
        } else {
          $flag = 0;
          $bytestmp = $basebytes - 1 + ($folded =~ tr/\x8E//);
        }
      } else {
        $flag = 0;
        $bytestmp--;
      }
    } else {
      $bytestmp--;
    }
    if ($bytestmp == 0) { # 禁則処理不可能
      ($folded, $strtmp) = fold($str, $basebytes, 0, 1);
      last;
    }
  }
  $folded =~ s/^((?:$ascii|$twoBytes|$threeBytes)*?(?=$del_space))
      $del_space+$/$1/ox; # 行末空白削除
  ($folded, $strtmp);
}

while (length($str)) {
  (my $folded, $str) = fold_properly($str);
  print $folded, "\n";
}

トップへ

---

Base64エンコード・デコードする

$str は EUC-JP という前提ですので， 必要ならばあらかじめ EUC-JP に変換しておいてください． 漢字コードの変換に関しては 「漢字コードを EUC-JP に変換して処理する」を参照．

# $data を Base64エンコードして $encoded_data を求める

use MIME::Base64;

$encoded_data = encode_base64($data);

Base64エンコードするには， モジュール MIME::Base64 の encode_base64 関数を使います． Base64エンコード・デコードについては RFC 2045( 日本語訳 )に書かれています．これによると Base64エンコード した出力ストリームの各行は 76文字以内でなければならないと 書かれています． encode_base64 関数は第 2引数を 指定しないで呼んだ場合には自動的に 76文字ごとに改行コードを 入れて折り返してくれます．

# $encoded_data を Base64デコードして元のデータ $data に戻す

use MIME::Base64;

$data = decode_base64($encoded_data);

Base64デコードするには， モジュール MIME::Base64 の decode_base64 関数を使います． $encoded_data には 76文字ごとに 折り返すために挿入されている改行コードが入ったままでもかまいません．

次に encoded-word について説明します．encoded-word については RFC 2047( 日本語訳 )に書かれています．encoded-word というのは =?charset?encoding?encoded-text?= という形をしたものです．たとえば =?ISO-2022-JP?B?GyRCTmMbKEI=?= は "例" という文字列を encoded-word にしたものです．ここでは encoding に B を指定した encoded-word について説明します．

encoding が B というのは encoded-text の部分が Bエンコードされたものであることを 表わしています．Bエンコードというのは Base64エンコードと同じエンコード方法ですが， encoded-word の場合は Base64エンコードとは呼ばずに Bエンコードと呼びます．

# $str を Bエンコードして encoded-word に変換する(不完全)

require 'jcode.pl';
use MIME::Base64;

jcode::convert(\$str, 'jis', 'euc', 'z');
$str = '=?ISO-2022-JP?B?' . encode_base64($str, '') . '?=';

Bエンコードするには encode_base64 関数を使えばいいのですが，第 2引数を指定しない場合は エンコードした結果に改行コードがついてしまうので，空文字列を指定して 改行コードがつかないようにしています． また，charset に ISO-2022-JP を指定する都合上， あらかじめ $str を JIS に変換する必要があります．正確には ISO-2022-JP に変換する必要があります．ISO-2022-JP に変換するには基本的に JIS に変換してあげればいいのですが， ISO-2022-JP では半角カタカナを使うことができません．そこで 半角カタカナが含まれていた場合には全角カタカナに変換する必要があります． これをやるには jcode::convert 関数の第 4引数に 'z' を指定してあげます．

encoded-word に変換する基礎はこれだけなのですが， これはあくまでも基礎であって RFC 2047 を満たすことができない 不完全なものです． RFC 2047 には encoded-word に変換する上で 守らなければならない決まりについて．だいたい次のようなことが書かれています．

1. encoded-word は 75バイト以内でなければならない．
2. encoded-word を含む行は 76バイト以内でなければならない．
3. encoded-word はそれぞれ独立してデコード可能でなければならない．
4. encoded-text をデコードした文字列の文字コードは，最後に ASCII が指定された状態でなければならない．
5. encoded-word が現れる出現位置に関する決まり．
   • Subject や Comment のヘッダフィールドなどの， 'text' 内に出現．
   • "(" と ")" で区切られた 'comment' 内に出現．
   • From や To，CC ヘッダなどで，'phrase' 内に出現．
   • 'addr-spec' 内で出現してはならない．
   • 'quoted-string' 内で出現してはならない．などなど．
6. 隣り合う encoded-word の間の 'linear-white-space' は無視する．

1 から 4 までが encoded-word に変換するときに関係してきます． さきほどのスクリプトでは 3 と 4 についてはクリアしていますが，1 と 2 については全然気にしていません．1 と 2 についても対応するためには少々困った 問題が起きます．

まず，1 についてですが，encoded-word の長さが 75バイトを超えるような場合には，Bエンコードする 対象を短くして，2つ以上の encoded-word に分けて 変換しなければなりません．2つ以上の encoded-word に分けるために，Bエンコードした後の encoded-text を 3 が満たされるようにうまく分割することもできますが，それでは 4 を満たすことができなくなってしまいます．4 を満たしつつ対象を短くするには， 適当なところで対象の文字列を分割しては駄目で， ちゃんと日本語の文字単位で短くしなければ なりません．つまり，漢字などの 2バイト文字や 3バイト文字の途中で分割しては駄目だということです． 日本語の文字単位で短くすることができたら，後は jcode.pl を使って JIS に 変換すれば，自動的に最後の文字コードが ASCII の状態になるようにしてくれます．

次に，2 についての困った問題というのを説明します．encoded-word を含む行が 76バイト以内でなければならないということは， encoded-word に変換するときに，変換した後の行が 76バイト以内になっているように encoded-word の長さを調整しなければならないということになります．もし， encoded-word に変換するとその行が 76バイトを超えて しまう場合には，改行して折り返す必要があります．

以上が encoded-word への変換そのものについての少々困った問題 ということになるのですが，実はそれ以前に一番困った問題というのがありまして， それが 5 です．つまり，どの部分を encoded-word に変換すれば いいのか，ということが一番問題なのです．同様に，どの部分をデコードしたら いいのかというのも問題になります．文字列を与えられてうまく処理しろと 言われたら字句解析や構文解析が必要になってしまいます．ここではとても そこまではできませんので，encoded-word に変換したい部分，逆変換 したい部分を与えられた場合のスクリプトを書きます．

# $str を encoded-word に変換し $line に追加する

require 'jcode.pl';
use MIME::Base64;

$ascii = '[\x00-\x7F]';
$twoBytes = '[\x8E\xA1-\xFE][\xA1-\xFE]';
$threeBytes = '\x8F[\xA1-\xFE][\xA1-\xFE]';

sub add_encoded_word {
  my($str, $line) = @_;
  my $result;

  while (length($str)) {
    my $target = $str;
    $str = '';
    if (length($line) + 22 +
	($target =~ /^(?:$twoBytes|$threeBytes)/o) * 8 > 76) {
      $line =~ s/[ \t\n\r]*$/\n/;
      $result .= $line;
      $line = ' ';
    }
    while (1) {
      my $encoded = '=?ISO-2022-JP?B?' .
      encode_base64(jcode::jis($target, 'euc', 'z'), '') . '?=';
      if (length($encoded) + length($line) > 76) {
	$target =~ s/($threeBytes|$twoBytes|$ascii)$//o;
	$str = $1 . $str;
      } else {
	$line .= $encoded;
	last;
      }
    }
  }
  $result . $line;
}

$line = add_encoded_word($str, $line);

実行例
$line = 'Subject: ';
$str = 'これはテストです．This is test.';
$line = add_encoded_word($str, $line);
print $line, "\n";

実行結果
Subject: =?ISO-2022-JP?B?GyRCJDMkbCRPJUYlOSVIJEckOSElGyhCVGhpcyBpcyB0ZXN0?=
 =?ISO-2022-JP?B?Lg==?=

このスクリプトは $line に $str を encoded-word に変換してから追加します． $str がかなり長い場合は，encoded-word が速く 75バイト以内になるように当たりをつけてからやった方が いいのですがこのスクリプトでは行なっていません． また，どの部分を encoded-word にするかですが，RFC 2047 には本来 encoded-word に変換する必要のないもの，つまり，ASCII だけから 成る単語まで変換するのは推奨できないと 書かれています．ですから，実行例のように is や test. までいっしょに encoded-word に変換 するのはあまりいい例とは言えません．これについては，Subject などの unstructured header の場合に対応したスクリプトを次に書きます．

# unstructured header $header を MIMEエンコードする
# add_encoded_word() については上のスクリプトを参照

sub mime_unstructured_header {
  my $oldheader = shift;
  my($header, @words, @wordstmp, $i) = ('');
  my $crlf = $oldheader =~ /\n$/;
  $oldheader =~ s/\s+$//;
  @wordstmp = split /\s+/, $oldheader;
  for ($i = 0; $i < $#wordstmp; $i++) {
    if ($wordstmp[$i] !~ /^[\x21-\x7E]+$/ and
	$wordstmp[$i + 1] !~ /^[\x21-\x7E]+$/) {
      $wordstmp[$i + 1] = "$wordstmp[$i] $wordstmp[$i + 1]";
    } else {
      push(@words, $wordstmp[$i]);
    }
  }
  push(@words, $wordstmp[-1]);
  foreach $word (@words) {
    if ($word =~ /^[\x21-\x7E]+$/) {
      $header =~ /(?:.*\n)*(.*)/;
      if (length($1) + length($word) > 76) {
	$header .= "\n $word";
      } else {
	$header .= $word;
      }
    } else {
      $header = add_encoded_word($word, $header);
    }
    $header =~ /(?:.*\n)*(.*)/;
    if (length($1) == 76) {
      $header .= "\n ";
    } else {
      $header .= ' ';
    }
  }
  $header =~ s/\n? $//mg;
  $crlf ? "$header\n" : $header;
}

$header = mime_unstructured_header($header);

実行例
$header = "Subject: ASCII 日本語 ASCIIと日本語 ASCII ASCII\n";
$header = mime_unstructured_header($header);
print $header;

実行結果
Subject: ASCII =?ISO-2022-JP?B?GyRCRnxLXDhsGyhCIEFTQ0lJGyRCJEhGfEtcGyhC?=
 =?ISO-2022-JP?B?GyRCOGwbKEI=?= ASCII ASCII

このスクリプトは前述のスクリプトの関数 add_encoded_word() を利用しています． 前述のスクリプトの最後の $line = add_encoded_word($str, $line); を削除し，このスクリプトに変更して使います．

このスクリプトの前半部分で単語ごとに分割しています．ここで分割された 単語ごとに，ASCII だけから成る単語かどうかを判定して encoded-word に変換するかどうかを決定していきます．このとき 6 に注意する必要があります．デコードのときに encoded-word の間の 'linear-white-space' は無視されるのですが，これは 1行の長さが長くなってしまう場合に，encoded-word を分割するために挿入された本来不必要な 'linear-white-space' を削除するためのものです．しかし，元から存在する 'linear-white-space' の両側を encoded-word に変換してしまうと，デコードのときに間違って削除されてしまうこと になります． そこで，'linear-white-space' の両側を encoded-word に変換する必要がある場合には，'linear-white-space' を含めた両側の 単語を 1つの encoded-word として変換します．

# $str を Bデコードして encoded-word を元に戻す

require 'jcode.pl';
use MIME::Base64;

$lws = '(?:(?:\x0D\x0A|\x0D|\x0A)?[ \t])+';
$ew_regex = '=\?ISO-2022-JP\?B\?([A-Za-z0-9+/]+=*)\?=';
$str =~ s/($ew_regex)$lws(?=$ew_regex)/$1/gio;
$str =~ s/$lws/ /go;
$str =~ s/$ew_regex/decode_base64($1)/egio;
jcode::convert(\$str, 'euc', 'jis');

このスクリプトは与えられた文字列 $str の中の encoded-word を元に戻します．隣り合う encoded-word の間の 'linear-white-space' は無視します．encoded-word は "(" の直後であるとか，'linear-white-space' の直後であるような場合に encoded-word であって，そうでない場合は一見 encoded-word に見えても，偶然そういう 文字列であると解釈し， 勝手に元に戻そうとすべきではありません．しかし，このスクリプトでは encoded-word に見えたものはすべて元に戻してしまいますので， 文字列 $str を与える方でその判定を行ない， 元に戻しても問題ないものだけを与える必要があります．たとえば， $str = q{"=?ISO-2022-JP?B?GyRCTmMbKEI=?="}; のときは quoted-string であるので，この中に encoded-word が現れるはずがありません．これを勝手に元に戻そうとしてはいけません．

古い Outlook Express などは encoded-word に変換したものをダブルクォートで囲んで quoted-string にするので，RFC 2047 を満たすことができません．Outlook Express 5 ではこの点は 修正されたようです．しかし，Outlook Express 5 を含む ほとんどのメーラーは encoded-word を含む行が 76バイト以内でなければならないという制約を 満たしていません．

encoded-word への変換を行なうスクリプトとして， mime_pls(mimew.pl) (生田 昇さん作)というものも公開されています．しかし，これも RFC 2047 を完全に満たしているわけではありません． encoded-word への変換に関しては， Subject 行や From 行の違いを 考慮せずに同じコメント処理をしてしまいます． また，word単位で行なっていないので， たとえば $str = "testテスト"; のような文字列を変換，逆変換を行なうと "test テスト" のように余分なスペースが入ってしまいます． 特殊変数 $`， $&， $' を使用しているので， すべてのパターンマッチの速度が少し遅くなってしまう点は改良の余地があります． encoded-word からの逆変換に関しては，さきほど述べたように一見 encoded-word に見えるものまで元に戻してしまいます．これを 正しく行なうためにはどうしても構文解析が必要になります．

Jcode.pm の MIMEエンコード 関数 mime_encode と MIMEデコード関数 mime_decode はバージョン 0.63以降で上記のスクリプ トが採用されています．

RFC 2047 を完全に満たしている encoded-word への変換を行なうスクリプトとしては IM(Internet Message) の IM::Iso2022jp モジュールがあります． 標準モジュールではないので，使うためには IM をインストールする必要があります． 使い方は Iso2022jp.pm の中身を見てください．

トップへ

---

URIエスケープ・アンエスケープする

'エスケープ' という文字列を '%a5%a8%a5%b9%a5%b1%a1%bc%a5%d7' のように URIエスケープするには次のように書きます．

# $str を URIエスケープする

$str =~ s/(\W)/'%' . unpack('H2', $1)/eg;

逆に '%a5%a8%a5%b9%a5%b1%a1%bc%a5%d7' という文字列を URIアンエスケープして 'エスケープ' という文字列に戻すには次のように書きます．

# $str を URIアンエスケープする

$str =~ s/%([0-9A-Fa-f][0-9A-Fa-f])/pack('H2', $1)/eg;

私がベンチマークをとって調べた限りでは，上記のように URIエスケープ・アンエスケープする 方法が一番実行速度が速いでしょう． これ以外の方法としては unpack 関数を使わずに sprintf 関数と ord 関数を使うとか， pack 関数をフォーマット 'H2' で使わずに hex 関数と chr 関数， あるいは， hex 関数と pack 関数をフォーマット 'C' で使うとか， 修飾子 i を使うとか， {2} を使うとかいろいろありますが， 特に書く必要はないでしょう． また，'%A5%A8%A5%B9%A5%B1%A1%BC%A5%D7' のようにアルファベットを大文字に変換してもいいのですが，その場合は sprintf 関数と ord 関数を使った方法となり，処理が遅くなります．

また，ハッシュと演算子 ||= を使って，次のように計算結果を再利用する方法がありますが，CGI などで使う 程度ではほとんどの場合上記のスクリプト より遅いでしょう．

# $str を URIエスケープする(再利用版)

$str =~ s/(\W)/$escape{$1} ||= '%' . unpack('H2', $1)/eg;

# $str を URIアンエスケープする(再利用版)

$str =~ s/%([0-9A-Fa-f][0-9A-Fa-f])/$unescape{$1} ||= pack('H2', $1)/eg;

再利用版が遅い理由は，再利用しようとする計算部分，つまり， '%' . unpack('H2', $1) や pack('H2', $1) がそれほど遅い処理ではないからです． この部分が遅い処理である場合には，一度計算した結果を数回再利用することで 十分に効果が出ますが，今回の場合のようにそれほど遅い処理ではない場合には， ハッシュを使用したり ||= による演算のオーバー ヘッドのために逆に遅くなってしまいます．私がベンチマークをとって調べたところ， URIアンエスケープの再利用版では再利用率700%ぐらい， つまり，一度計算したすべての結果を 7回再利用したころから ようやく効果が出始めるという程度でした．

逆に言えば，大量の文章を処理しようとした場合には効果があるということ なのですが，そのような場合は次のようにあらかじめ変換テーブルを用意しておく 方が実行速度が速いです．

# $str を URIエスケープする(変換テーブル版)

foreach $i (0x00 .. 0xFF) {
  $escape{chr($i)} = sprintf('%%%02x', $i);
}

$str =~ s/(\W)/$escape{$1}/g;

# $str を URIアンエスケープする(変換テーブル版)

foreach $i (0x00 .. 0xFF) {
  $unescape{sprintf('%02x', $i)} = chr($i);
  $unescape{sprintf('%02X', $i)} = chr($i);
}

$str =~ s/%([0-9A-Fa-f][0-9A-Fa-f])/$unescape{$1}/g;

変換テーブル版では最初に変換テーブルを用意するという前処理が必要に なりますが，変換そのものは 修飾子 e がなくなり，文字列展開のみになるので最も実行速度が速いです．

URIエスケープの対象となる文字ですが，上記のスクリプトでは 単純に \W としていました． しかし，これは厳密にはURIエスケープの必要がない文字までも URIエスケープしてしまいます． 必ずURIエスケープしなければならない文字は RFC 2396( 日本語訳 )で unreserved として定義されている文字以外になります． unreserved 以外の文字だけをURIエスケープするスクリプトは 以下のようになります．

# $str を URIエスケープする(必要最小限版)

$str =~ s/([^a-zA-Z0-9_.!~*'()-])/'%' . unpack('H2', $1)/eg;

ここから先は CGI や URI 特有の話になります．

URIエスケープするには，「RFC 2396で URI文字として使用できる文字 uric として定義されているもの以外を エスケープすればいいので， モジュール URI::Escape の uri_escape 関数を使って， 正規表現 [;\/?:@&=+\$,A-Za-z0-9\-_.!~*'()] で表わされる文字以外をエスケープすればいい」という話がありますが， これは間違いです．正確には，ある意味では それでいいのですが，おそらく CGI を書く人にとってはほとんどの場合 間違いでしょう．uri_escape 関数がやろうとしているのは， URI を入力としたときに URI文字以外の文字をエスケープする ことであって，CGI を書く人がなんらかの値をエスケープしようとすることとは 意味が違います．たとえば， $value = 'A&B=C'; のとき， print "http://foo.bar/cgi-bin/hoge.cgi?value=$value"; とすることを考えたらどうなると思いますか？ uri_escape 関数を使って $value をエスケープしても & や = は URI文字なのでエスケープはされません．この結果， value=A と B=C という 2つを & でつなげていると解釈されてしまいます． 実は uri_escape 関数は第 2引数で 変換対象とする文字を与えることができます．ただ，やっている内容は上に書いた スクリプトと同じことなので，わざわざ標準ではないモジュール URI::Escape をインストールして使うこともないでしょう．

次に，スペースと + の相互変換の話をします．CGI に何らかのデータを 渡す方法としては，FORM の GET または POST を使う方法とコマンドライン引数として 渡す方法の 2つがあります．この 2つ方法ではそれぞれ スペースと + の相互変換の話が違っています．FORM の GET または POST を 使う方法については HTML 4.0( 日本語訳 ) の 17.13.4 Form content types に content types が デフォルトの application/x-www-form-urlencoded のときの エンコード方法として書かれています．コマンドライン引数として渡す方法に ついては CGI/1.1の 5. The CGI Script Command Line に書かれています．

application/x-www-form-urlencoded でのエンコードでは control names と values のスペースは + に変換し，それ以外の 予約文字を %HH の形式に URIエスケープしま す．そして，controle names と values を = で区切った組とし，その組 を & で区切って並べます．つまり，スペースは + に変換し，それ以外の予約文字を URIエスケープした上で， name1=value1&name2=value2 というような形式にすることです． control names や values に対して行なう文字処理部分は次のようになります．

# $str に対しエンコードの文字処理部分を行なう

$str =~ s/([^\w ])/'%' . unpack('H2', $1)/eg;
$str =~ tr/ /+/;

スペースは + に変換しなければならないので， URIエスケープした後で s/%20/+/g; と再度 変換しなおす方法もありますが，このスクリプトのようにスペースに対して余計な 処理を行なわないようにした方が実行速度が速いです．

# $str に対しデコードの文字処理部分を行なう

$str =~ tr/+/ /;
$str =~ s/%([0-9A-Fa-f][0-9A-Fa-f])/pack('H2', $1)/eg;

先に URIアンエスケープしてしまうと，+ に変換されているスペースと区別がつかなくなるので，その前に + をスペースに戻しておきます． このとき $str =~ s/\+/ /g; としても可能ですが， 文字単位の変換なので実行速度が速い tr 関数を使います．

世間一般で使用されている URLエンコードというのが何を 指しているのか私にはよくわからないのですが， application/x-www-form-urlencoded でのエンコードのことを URLエンコードと言うのであれば，予約文字を %HH の形式に変換する URIエスケープの処理 だけを指して URLエンコードと言うのは間違いになりま す．もし，URIエスケープ のことを URLエンコードと 言うのであれば，スペースを + に変換しなければならないというのは間違いになります．

一方，コマンドライン引数として渡す方法ですが，この方法の書式は search-string = search-word *( "+" search-word ) となっています．具体的な例で言いますと， http://foo.bar/cgi-bin/hoge.cgi?arg1+arg2+arg3 のように なります．このときスペースを + に変換するという 話はどこにもありません．search-string 同士を 区切っている + は最初から + であって，スペースを変換したもの ではないのです．もし，search-string にスペースが 含まれていた場合には，その他の予約文字と同様 URIエスケープされることになるので %20 に 変換されることになります．スペースを間違って + に変換してしまうと， たとえば $value = 'A B C'; のとき，これを CGI の引数として渡そうと print "http://foo.bar/cgi-bin/hoge.cgi?$value"; とすることを考えたら， http://foo.bar/cgi-bin/hoge.cgi?A+B+C となり，このとき hoge.cgi は 3つの引数 'A'，'B'， 'C' を受け取ることになってしまいます． これは http://foo.bar/cgi-bin/hoge.cgi?A%20B%20C とするのが正解になります．

コマンドライン引数として渡す方法ではスペースが + に変換されている わけではないので，受け取った側で + をスペースに戻すようなことを してはいけないということになります．コマンドライン引数として渡す方法でも QUERY_STRING から query 部分，つまり， ? 以降の部分を取得することができます．もし， FORM の GET または POST を使う方法とコマンドライン引数として 渡す方法のどちらでデータが渡されるのかわからない場合に， QUERY_STRING からデータをもらって処理するためには， + をスペースに変換すべきか変換すべきではないのか判断する必要が あります．判断する方法は簡単で，QUERY_STRING に = が含まれているかどうかを調べます．もし含まれていれば，それは application/x-www-form-urlencoded でのエンコードをされている ことになります．含まれていなければ，コマンドライン引数としてデータが 渡されたことになります．

改行コードを統一する

s/\x0D\x0A|\x0D|\x0A/\n/g;

このスクリプトは Windows(DOS)，Mac，UNIX のいずれかのプラットフォームの改 行コードを自プラットフォームの改行コードに統一します．改行コードは Windows(DOS)では \x0D\x0A， Macでは \x0D，UNIX では \x0A なので， これらすべての改行コードに対応するには \x0D\x0A|\x0D|\x0A とする必要があります． このとき順番は \x0D\x0A を必ず最初にしなければなりません．

改行コードを統一するために s/\r\n|\r/\n/g; と書くのは間違いです． このように書いて正常に動作するのは Windows(DOS) と UNIX の perl のみで，Mac の perl では正常に動作しません．よ く「改行コードは Windows(DOS) では \r\n，Mac では \r，UNIX では \n である」という人がいますが，これはある意味正しいと言えなくもないのですが， 根本的には間違っています． 以降で何がどう間違っているのか説明しますが，その前に実際の値として の改行コード値と論理的な改行文字が別物であるということを頭の片隅にとどめてお いてください．

まず，実際の値としての改行コード値が Windows(DOS)では \x0D\x0A，Macでは \x0D， UNIX では \x0A であるということは特に問題ないでしょう．それでは \r や \n というのは一体何なのでしょうか？ 答えはそれぞれ Perl という言語の中で論理的に 定義された復帰文字と改行文字です． プラットフォームによって改行コード値は \x0D\x0A であったり，\x0D や \x0A であったりするわけですが，改行するためにはどのプラットフォームであろうと Perl という言語では論理的な改行文字である \n を出力することになります．つまり，「改行は Windows(DOS) でも Mac でも UNIX でも \n」なのです．

それでは \r と \n が実際にどのようなコード値になっているのかまとめたものが以下の表になります (Macは推測．間違いはご指摘ください)．

	Windows(DOS)	Mac	UNIX
改行コード値	\x0D\x0A	\x0D	\x0A
改行文字	\n	\n	\n
復帰文字	\r	\r	\r
print FH "\n";	\x0D\x0A を出力	\x0D を出力	\x0A を出力
print FH "\r";	\x0D を出力	\x0A を出力	\x0D を出力
binmode FH; print FH "\n";	\x0A を出力	\x0D を出力	\x0A を出力
print FH "\r\n";	\x0D\x0D\x0A を出力	\x0A\x0D を出力	\x0D\x0A を出力
binmode FH; print FH "\r\n";	\x0D\x0A を出力	\x0A\x0D を出力	\x0D\x0A を出力

自プラットフォームの改行コード値だけを対象にしているのならば，たとえば， UNIX の perl ならば \x0D は \r であり， \x0A は \n であるとすることができます． ただし，その場合でもテキスト処理するときに限られます． 何らかのバイナリファイル内の \x0A が改行を意味するわけではないからです． 当然，改行コードを統一するスクリプトというように， 自プラットフォーム以外の改行コード値のことも考えて処理する場合には勝手に \x0D は \r で， \x0A は \n だと決めつけてはいけません．\r や \n はあくまでも論理的な文字なのです． 最初のスクリプトは，Windows(DOS)，Mac，UNIX での実際の改行コード値を論理的な改行文字に置換しているという意味になります．

最初のスクリプトは簡潔でわかりやすく書かれてはいますが， 実行速度は遅いで す． 次のように tr を使って 2文でやった方が圧倒的に速いです．

s/\x0D\x0A/\n/g;
tr/\x0D\x0A/\n\n/;

なお，Perl内部では Windows(DOS) でも Mac でも UNIX でも， \r は \x0D か \x0A のどちらかであり， \n はその逆であるという特性を利用することで， 次のように書くことが可能です．

s/\x0D\x0A/\n/g;
tr/\r/\n/;        # 意味的には tr/\x0D\x0A/\n\n/;

このスクリプトの方が，tr で変換が行なわれなかった場合において，わずかに実行速度が速くなります． ただし，これまで述べてきたように意味的には間違った書き方であることを 十分理解した上で使う必要があります．

改行コードを <BR> に変換する

s/\x0D\x0A|\x0D|\x0A/<BR>/g;

改行コードは Windows(DOS)では \x0D\x0A， Macでは \x0D， UNIX では \x0A なので， これらすべての改行コードに対応するには \x0D\x0A|\x0D|\x0A とする必要があります．このとき順番は \x0D\x0A を必ず最初にしなければなりません． このスクリプトは簡潔でわかりやすく書かれてはいますが， 実行速度は遅いです． s/\x0D\x0A|[\x0D\x0A]/<BR>/g; とするとほんの少し速くなりますが，ほとんどの場合次のように 3文でやった方が圧倒的に速いです．

s/\x0D\x0A/<BR>/g;
s/\x0D/<BR>/g;
s/\x0A/<BR>/g;

改行について詳しくは「改行コードを統一する」 を参照．

改行コードを削除する

tr/\x0D\x0A//d;

「改行コードを <BR> に変換する」と同じ手法で， s/\x0D\x0A|\x0D|\x0A//g; と書いても改行コードを削除することができます．また， <BR>に変換する場合と違って， \x0D，\x0A という 2つの文字を両方とも削除すればいいので， s/[\x0D\x0A]//g; と書いても同じことができます． しかし，このように文字単位で変換する場合は， tr/\x0D\x0A//d; と書いた方が s/\x0D\x0A|\x0D|\x0A//g; や s/[\x0D\x0A]//g; とするよりも実行速度が速いので， tr を使って改行コードを削除するようにするのがいいでしょう．

ここで注意が必要なのは，この方法で改行コードを削除すると， 文字列の中に含まれるすべての改行コードが 削除されるということです．1行入力された場合のように， 文字列の最後にだけ改行コードがあるとわかっている ときは， chomp を使います．ただし， chomp は Windows(DOS) や Mac，UNIX といった処理系に依存します． \x0D\x0A を UNIX の perl で chomp した場合は， \x0D が残ってしまいます． もし，複数の処理系の改行コードを想定しなければならない場合は，次のように して文字列の最後の改行を削除します．

s/\x0D?\x0A?$//;

改行について詳しくは「改行コードを統一する」 を参照．

CSV形式の行から値のリストを取り出す

# CSV形式の $line から値を取り出して @values に入れる

{
  my $tmp = $line;
  $tmp =~ s/(?:\x0D\x0A|[\x0D\x0A])?$/,/;
  @values = map {/^"(.*)"$/ ? scalar($_ = $1, s/""/"/g, $_) : $_}
                ($tmp =~ /("[^"]*(?:""[^"]*)*"|[^,]*),/g);
}

CSV(Comma Separated Value)形式というのは， 完全にアプリケーションに依存した形式であるので， このスクリプトであらゆるアプリケーションが扱う CSV形式の 行から値を取り出せるわけではありません．このスクリプトはもっとも需要が あると思われ，また，比較的一般的な定義である Excel が出力する CSV形式について扱うこととしました．Excel が出力する CSV形式がどのようなものか Excel のヘルプに載って いませんでしたが，私が独自に調べた結果以下のようなものであるとしました．

1. 基本的にコンマで区切った部分がスペースを含めて値である．
2. 値にコンマやダブルクウォートが含まれる場合は， 値全体をダブルクウォートで囲む．
3. 値に含まれるダブルクウォートは "" となる．

このスクリプトでは，まずはじめに $line のコピーを $tmp に取ってから処理しています． コピーを取らずに処理すると， 次の処理で $line を変更してしまうことになるためです． 具体的には，抽出処理を簡単にするために，最後の値の後ろに コンマをつけ加えています．このとき $line の最後に 改行コードがついていた場合を考え，改行コードの削除も同時に行なっています． ここまでの処理で $line の中身は 値,値,値, というように 値, の繰り返しになっています．

次に 値,値,値, という形から個々の値を 取り出すわけですが，これを行なう ために修飾子 g をつけた パターンマッチを行ないます．修飾子 g をつけた パターンマッチをリストコンテキストで実行すると， ()によるグループにマッチした部分文字列のリストを 返します．値の部分にマッチする正規表現をグループにしておけば， 値のリストを取り出すことができるわけです．

ここで注意が必要なのは，値, となっているものと， "値", となっているものの 2種類があることです．そして，"値", の形の方の値にはコンマが含まれている可能性があります．したがって， 単純に split /,/, $tmp や ($tmp =~ /([^,]*),/g) のようにしてしまうと， 値の中のコンマによって値が 2つに別れてしまうことになります． そこでまずは値を区切っているコンマで 値 と "値" を正確に取り出すことを考えます．

値, の形の値にはコンマが含まれていませんから， 値 の部分にマッチさせるには /([^,]*),/ とすればいいことになります． 一方，"値", の形の "値" の部分にマッチさせるには，/("[^"]*"),/ とすればいいように思うかもしれませんが，CSV形式の 3番目の定義により，値には "" というのが含まれている可能性があります．そこで， [^"] 以外に "" の場合も考え， /("(?:[^"]|"")*"),/ とすればいいことになります．この 2つの形を合成して， ($tmp =~ /("(?:[^"]|"")*"|[^,]*),/g) となります． これで 値 または "値" のリストとして 取り出すことができます．ただ，正規表現の部分はこのままでもいいのですが， スクリプトではさらにこの正規表現を Jeffrey E. F. Friedl氏 原著による「詳説 正規表現」で 「ループ展開」として書かれている 手法で変形し実行速度を速くしてあります．

最後に "値" から値を復元する必要があります． 値 の形ならそのまま，"値" の形ならば両側のダブルクウォートを取り除き，さらに "" は " に変換します． この処理を map 関数 の中で行なっています． これでCSV形式の行から値を取り出すことができます．

モジュール Text::CSV を使えば同じようなことが できますが，ASCII しか扱えないので日本語が含まれる場合には使えません． モジュール Text::CSV_XS をバイナリモードで使えば日本語を扱うことができます． ただし，どちらのモジュールも標準ではないため アーカイブファイルを取ってきてインストールする必要があります．

値に改行コードを含む CSV形式を扱う

# 値に改行コードを含む CSV形式を扱う

while (my $line = <DATA>) {
  $line .= <DATA> while ($line =~ tr/"// % 2 and !eof(DATA));

  $line =~ s/(?:\x0D\x0A|[\x0D\x0A])?$/,/;
  @values = map {/^"(.*)"$/s ? scalar($_ = $1, s/""/"/g, $_) : $_}
                ($line =~ /("[^"]*(?:""[^"]*)*"|[^,]*),/g);

  # @values を処理する
}

値に改行コードを含む CSV形式は 「CSV形式の行から値のリストを取り出す」 で書いた Excel が出力する CSV形式を以下のように修正したものであるとしました．

1. 基本的にコンマで区切った部分がスペースを含めて値である．
2. 値にコンマやダブルクウォート， 改行コードが含まれる場合は， 値全体をダブルクウォートで囲む．
3. 値に含まれるダブルクウォートは "" となる．

CSV形式の 1行に現れるダブルクウォートは， "値" のように値を囲む場合と， 値に含まれていたダブルクウォートが "" となっている場合です． したがって，CSV形式の 1行には， ダブルクウォートが必ず偶数個あることになります． もし，ダブルクウォートが奇数個だった場合には，値に含まれる改行コードによって， もともと 1行の CSV形式だった行が複数行に別れてしまっ ていることになります．

そこでダブルクウォートの数を数え，奇数個だった場合には次の行を追加します． これをダブルクウォートが偶数個になるまで繰り返します． tr/"// でダブルクウォートの数を数えています． こうして正しく CSV形式の 1行を取り出すことができたら，あとは 「CSV形式の行から値のリストを取り出す」 とほとんど同じスクリプトで処理することができます．唯一の違いは map 関数の中でのパターンマッチで， 修飾子 s をつけていることです． 修飾子 s をつけることによって， ピリオドが改行コードにもマッチするようになります．

値のリストから CSV形式に変換する

# 値の配列 @values から CSV形式の行 $line に変換する

$line = join ',', map {(s/"/""/g or /[\r\n,]/) ? qq("$_") : $_} @values;

このスクリプトは，値の配列から 「CSV形式の行から値のリストを 取り出す」や「値に改行コードを含む CSV形式を扱う」で定義した CSV形式の行に 変換するものです．

値をコンマで区切って結合させる前に， ダブルクウォート・改行コード・コンマのいずれかが含まれる値については， "値" の形に変換する必要があります．また， ダブルクウォートについては，"" に変換しておく必要があります． これを map 関数によって一度に行なってしまっています．

s/// は置換を行ない， その回数を返します． したがって， s/"/""/g というのは， ダブルクウォートがあればそれを "" に置換し，置換した回数， つまりこの場合は値に含まれていたダブルクウォートの個数を返すことになります． この個数が 1以上，または改行コードかコンマが含まれていた場合に "値" の形に変換しています．

このスクリプトによって得られる $line には最後に改行コードが含まれていませんので， ファイルなどに書き出すときには次のように改行コードをつける必要があります．

print $line, "\n";

特定の項目でソートする

ここでは以下のようなデータに対するソートを例に説明します．1つ 1つの要素は第 1～3項をコンマで 区切った形式をしています．

@data = ('A,7,緑',
         'C,6,青',
         'B,4,赤',
         'A,9,紫',
         'A,2,黄緑',
         'B,10,黄',
         'C,3,青紫');

---

# 第 2項でソートする

@data = map {$_->[0]}
            sort {$a->[2] <=> $b->[2]}
                 map {[$_, split /,/]} @data;

ソート後のデータ
@data = ('A,2,黄緑',
         'C,3,青紫',
         'B,4,赤',
         'C,6,青',
         'A,7,緑',
         'A,9,紫',
         'B,10,黄');

この方法は Schwartzian Transform と呼ばれている方法です．このスクリプトはデータを要素の第 2項の 数字の部分でソートしています．ソートを行なうには sort 関数を使えばいいのですが， もとの要素のままではアルファベット，数字，色がコンマで区切られた 1つの文字列になってしまっているので， 数字の部分だけでソートすることができません． そこで，要素から数字の部分を抜き出してソートする必要があります． 要素から数字の部分を抜き出してソートするには次のように書けばできます．

@data = sort {
  my ($alpha_a, $num_a, $color_a) = split(/,/, $a);
  my ($alpha_b, $num_b, $color_b) = split(/,/, $b);
  $num_a <=> $num_b;
} @data;

しかし，この方法は非常に効率が悪いものです． なぜならば，比較が行なわれるたびに要素を分解しているからです．そこで， あらかじめ要素を分解しておき，比較するときに余計な処理をさせないことが 重要となります．要素を分解，比較，もとの要素に戻すという ことを一度に効率的にやってしまうのが Schwartzian Transform です．

最初のスクリプトに戻って説明します．ソートは 3行に渡って 書かれていますが，これで 1文です．実際の実行は 3行目， 2行目， 1行目の順番で 行なわれます．それぞれ，要素を分解，比較，もとの要素に戻すということを やっています．まず，3行目でデータの 1つ 1つの要素に対して， 無名配列へのリファレンスを作って， これを要素とする新たな配列に変換しています．新しい要素は [$_, split /,/] です．これは簡単に言ってしまえば， (もとの要素, 第 1項, 第 2項, 第 3項) という配列だと思えば いいでしょう．次に，2行目で実際にソートします． $a->[2] や $b->[2] は，3行目であらかじめ分解して新しい要素に変換した 無名配列の添え字 2の要素，つまり， 第 2項 を表わしています．ここでは要素を取り出しているだけなので， 毎回分解していたやり方に比べて効率がよいことが わかると思います．最後に 1行目でもとの要素に戻しています．

Schwartzian Transform には，毎回分解していたやり方に比べて効率が よい，無名配列を使うことによって中間データを保持するため作業用の配列を 特別に用意する必要がない，すべての 処理を簡潔に記述することができる といった特徴があります．しかし，無名配列を使用しているために，無名配列から 要素を取り出すというオーバーヘッドが生じてしまいます．このため，次のように 作業用の配列を用意して行なう方法の 方が実行速度が速いです．

# 第 2項でソートする(作業用配列を使った高速版)

@tmp = map {(split /,/)[1]} @data;
@data = @data[sort {$tmp[$a] <=> $tmp[$b]} 0 .. $#tmp];

このスクリプトは，最初に作業用配列 @tmp に第 2項を取り出しておき，配列の添え字のリスト値 0 .. $#tmp に対してソートを行ない，ソートされた 添え字をもとに配列スライスで @data からリスト値を取り出すことでソートしています．

複数の項目でソートする

ここでは以下のようなデータに対するソートを例に説明します．1つ 1つの要素は第 1～3項をコンマで 区切った形式をしています．

@data = ('A,7,緑',
         'C,6,青',
         'B,4,赤',
         'A,9,紫',
         'A,2,黄緑',
         'B,10,黄',
         'C,3,青紫');

---

# 第 1項でソートし，さらに第 2項で降順ソートする

@data = map {$_->[0]}
            sort {$a->[1] cmp $b->[1] or $b->[2] <=> $a->[2]}
                 map {[$_, split /,/]} @data;

ソート後のデータ
@data = ('A,9,紫',
         'A,7,緑',
         'A,2,黄緑',
         'B,10,黄',
         'B,4,赤',
         'C,6,青',
         'C,3,青紫');

このスクリプトは，まず第 1項のアルファベットでソートし， 同じアルファベットの中ではさらに第 2項の数字を比較して降順に なるようにソートしています．基本的な動作は 「特定の項目でソートする」で説明した内容と同じです． 違いは 2行目の sort 関数の中だけです． 複数の項目でソートしたい場合は，このようにソート条件を or を使って並べてやるだけです． 第 1項のアルファベットでソートする ときは文字列の比較になりますので cmp を使います． 第 2項は数字の比較になりますので <=> を使います． また，第 2項は降順で ソートしたいので， $a と $b を左右逆にしなければなりません．

上のスクリプトを作業用配列を使って実行速度が速くなるようにしたものが 次のスクリプトになります．

# 第 1項でソートし，さらに第 2項で降順ソートする(作業用配列を使った高速版)

@tmp1 = @tmp2 = ();
foreach (@data) {
  my ($first, $second) = split /,/;
  push(@tmp1, $first);
  push(@tmp2, $second);
}
@data = @data[sort {$tmp1[$a] cmp $tmp1[$b] or
			$tmp2[$b] <=> $tmp2[$a]} 0 .. $#tmp1];

このスクリプトの基本的な 動作は「特定の項目でソートする」で説明した内容と 同じです．簡潔に記述したいのであれば Schwartzian Transform ですが， 実行速度を速くしたいのであれば簡潔に記述することをあきらめるしかないようです．

おまけとして，数字で始まる文字列を含まない任意の項目数のデータを昇順で多 重ソートするスクリプトを載せておきます．このスクリプトは perl5.005 以降でしか動作しませんが， expr foreach () の形を foreach () {expr} の形にすれば， perl5.005 以前の perl5 でも動作するようになります．

# 任意の項目数のデータを昇順で多重ソートする

@data = map {$_->[0]}
            sort {$x = ($a->[$_] <=> $b->[$_] or $a->[$_] cmp $b->[$_])
		    and return $x foreach (1 .. $#$a); -1}
                 map {[$_, split /,/]} @data;

自分で決めた順番でソートする

ここでは以下のようなデータに対するソートを例に説明します．1つ 1つの要素は第 1～3項をコンマで 区切った形式をしています．

@data = ('A,7,緑',
         'C,6,青',
         'B,4,赤',
         'A,9,紫',
         'A,2,黄緑',
         'B,10,黄',
         'C,3,青紫');

---

# 第 3項が自分で決めた順番になるようにソートする

$i = 0;
undef(%color);
foreach $name ('赤', '黄赤', '黄', '黄緑', '緑', '青緑', '青', '青紫',
               '紫', '赤紫') {
  $color{$name} = $i++;
}
@data = map {$_->[0]}
            sort {$color{$a->[3]} <=> $color{$b->[3]}}
                 map {[$_, split /,/]} @data;

ソート後のデータ
@data = ('B,4,赤',
         'B,10,黄',
         'A,2,黄緑',
         'A,7,緑',
         'C,6,青',
         'C,3,青紫',
         'A,9,紫');

ソートの基本的な動作は「特定の項目でソートする」 で説明した内容と同じです． 自分で決めた順番でソートするためには，その順番を数字に変換できる ようにハッシュに定義しておき，あとはその数字を 使ってソートするだけです．このスクリプトでは， 第 3項の色が赤，黄赤，黄，黄緑，緑，青緑，青，青紫，紫， 赤紫という順番になるようにソートしています．色の名前のままではソートする ことはできませんので，順に 0～9 の数字に対応するように ハッシュを定義しています．ソートするときは，このハッシュから対応する数字に 変換し，数字の比較でソートします．

年月日から曜日を求める

# $year年 $mon月 $mday日の曜日を求める

use Time::Local;

$time = timelocal(0, 0, 0, $mday, $mon - 1, $year - 1900);
($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst) =
  localtime($time);
$wday_string = (qw(日 月 火 水 木 金 土))[$wday];

timelocal 関数を使って，まずは年月日時分秒を 1970年1月1日00時00分00秒からの秒数(MacPerl では 1904年1月1日00時00分00秒からの秒数)に変換します．このとき年と月の引数は それぞれ - 1900， - 1 する必要があります．次に，その秒数から localtime 関数を使って曜日 $wday (0～6)を求めます． 最後にその数字を文字列に変換してあげます．

通常は上の書き方で問題ないのですが， ほとんどの計算機で 1970年～2037年までしか 計算できないという制限があります．そこで，この範囲を超えるような 場合があるときはツェラー(Zellar)の公式というものを使って 次のように書きます． ツェラーの公式を使えば制限はありませんし， 実行速度も速いのですが， すぐに思い出せない，覚えられないという欠点があります．

# $year年 $mon月 $mday日の曜日を求める

$wday = getwday($year, $mon, $mday);
$wday_string = (qw(日 月 火 水 木 金 土))[$wday];

sub getwday {
  my($year, $mon, $mday) = @_;

  if ($mon == 1 or $mon == 2) {
    $year--;
    $mon += 12;
  }
  int($year + int($year / 4) - int($year / 100) + int($year / 400)
      + int((13 * $mon + 8) / 5) + $mday) % 7;
}

一週間前の年月日を求める

# 一週間前の年月日($year年 $mon月 $mday日)を求める

use Time::Local;

# 一週間前の時間を求める
$time = time() - 60 * 60 * 24 * 7;

($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst) =
    localtime($time);
$year += 1900;
$mon++;

現在の時間を time 関数で求め，その秒数から 一週間前の時間に なるように 60 * 60 * 24 * 7 を引いてあげます． この秒数を localtime 関数を使って年月日に変換します． localtime 関数が返す値は，年が西暦から 1900を引いた値で，月は 0～11までの値を返します． したがって，最後に年と月をそれぞれ + 1900， + 1 する必要があります．time 関数を返す値を大きく すれば未来の年月日を求めることができます．

年月日や時間に関する モジュール Date::Calc を使っても同じようなことができますが，標準のモジュールではないため アーカイブファイルを取ってきてインストールする必要があります．

年月から末日を求める

# $year年 $mon月の末日 $lastday を求める

$lastday = (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31)[$mon - 1]
           + ($mon == 2 and $year % 4 == 0 and
	      ($year % 400 == 0 or $year % 100 != 0));

最初の行は 1月から 12月までの末日を 並べたリスト値に 対して，添え字 $mon - 1 に対応する値を 取り出しています． 2行目，3行目は閏年のための補正です． 基本的に 4で割れる年は閏年だが， 100で割れる年のときは閏年ではない，ただし，400で割れる年は閏年である． 言い換えると，4で割れる年のうち and ( 400で割れる年と or 100で割れない年 ) が閏年ということになります． 閏年の 2月の末日を計算するときという条件を表わしたものが 2行目，3行目です．

Perlでは and や or は， 最後に評価した値を返します． また，== や != は真のときに 1， 偽のときに空文字列を返します．このことから， 2行目，3行目の条件式は閏年の 2月の末日を計算するときは 1， そうでないときは空文字列を返すことになります． これをリスト値から取り出した末日に加えます．+ は数値の和を求める 演算子ですので，空文字列のときは数値として解釈できないので 0 に変換されます．

第N W曜日の日付を求める

# $year年 $mon月の第$n $wday(0-6)曜日が何日か求める
# getwday() は別途参照

$wday1 = getwday($year, $mon, 1);
$mday = 1 + ($wday - $wday1) % 7 + 7 * ($n - 1);
print $mday, "\n";

まず初めに，その月の 1日の曜日 $wday1 を求めます．年月日から曜日を求める方法については， 「年月日から曜日を求める」を参照してください．

次に 1日を基準に求めたい日付を計算します． 求めたい曜日 $wday と 1日の曜日 $wday1 の差を加えて あげれば第1 $wday曜日の日付を 求めることができます．しかし，ここで単純に加えたのでは差が負数の場合に まずいことになります． そこで if 文で場合分けしてもよいのですが， 7 で割った余り(必ず非負数)を求めれば， うまく第1 $wday曜日の日付を求めることができます． 最後に $n番目の $wday曜日の 日付を求めるために 7 * ($n - 1) を加えて終わりです．

求めた日付が本当に存在するかどうかは， 「年月から末日を求める」で書いたように末日を 求めて比較すればよいことになります．

年月日や時間に関する モジュール Date::Calc を使っても同じようなことができますが，標準のモジュールではないため アーカイブファイルを取ってきてインストールする必要があります．

数字を 3桁ごとにコンマで区切る

1 while s/^([-+]?\d+)(\d\d\d)/$1,$2/;

このスクリプトの while の前の 1 は特に意味が ないダミーの式です．本当に行ないたい部分は while 文の条件式の部分 の置換です． このスクリプトは，置換が行なわれると条件式が真になり，ダミーの式である 1 を実行し，再び置換を行なおうとします．置換が行なわれるとコンマが 1つ追加されます．つまり，コンマを 1つずつ 追加していき，追加できなく なった時点で while 文が終了することになります．

では，実際にどのように置換しコンマを追加しているのか説明します． ^([-+]?\d+) の部分が，数字を先頭から見て， 符号を考慮にいれつつ数字である限りできるだけ伸ばそうとします． ところが，その後ろに (\d\d\d) というのがあるので，少なくとも数字を 3つ残さなければ パターンマッチできません．したがって，$1 には 後ろに数字を 3つ 残した前の部分の数字，$2 には残された 3つの数字が代入されることに なります．その間にコンマを入れてあげます．これでコンマが 1つ追加されます． これを繰り返すことで数字全体に対して 3桁ごとにコンマで 区切ることができます． つまり，このスクリプトでは数字を桁の小さい方から 3桁ずつ大きい方に向かって区切っています．

while 文を使った方法よりも，次のように書いた 方が桁が大きい場合には実行速度が速いです．

s/(\d{1,3})(?=(?:\d\d\d)+(?!\d))/$1,/g;

このスクリプトは修飾子g を使うことで，置換文だけで数字をコンマで区切っています．コンマで区切る方法も while 文を使った置換と違い， 桁の大きい方から区切っています．どのように 区切っているのか説明します．

ここで一番注目しなければいけないのが， (?=regex) の部分です．これは正規表現 regex にマッチする 文字列が次にくる場合に マッチする 0文字幅の正規表現です． 「0文字幅」と いうのは，文字列の先頭や最後を表わす ^ や $ のように， 文字としての幅がないという意味です．ちょうど \b が単語の境界に マッチするように，(?=regex) も文字と文字の間で マッチするものと 考えるといいでしょう．「次にくる場合」というのは，たとえば foo(?=bar) という正規表現の場合，foo や foohoge などはマッチしません．なぜなら foo の次に bar がこないからです．foobar の場合はマッチするわけですが， マッチするのは foo の部分だけです．(?=bar) は次に bar が こなければならないと言っているだけで bar を含んでいるわけでは ないからです．これが正規表現 foobar と foo(?=bar) の違いです．(?!regex) は (?=regex) の否定の形で， 次にこない場合にマッチします．

話をスクリプトに戻しますと，(?=(?:\d\d\d)+(?!\d)) は数字が次にこないような，3桁の数字の 1回以上の繰り返しが次にくることを表わ しています．数字が次にこないということは数字の終わりを意味しています． $ と違って文字列の最後でなくても数字が終わっている部分に マッチするということです．全体として，桁の小さい方から 3桁ずつ数字を まとめているわけです．ただし，(?=regex) ですので， 3桁ずつ数字をまとめたものが次にくると言っているだけで， それを含んでしまっているわけではありません．そして，一番桁の大きい部分が (\d{1,3}) にマッチします．この部分の後ろにコンマを 追加します． これで 1つコンマが追加されたわけですが， 修飾子 g によって他にも 置換できるところをすべて置換しにいきます．このときに先ほど「含んでいない」 と言った部分が効いてきます．最初の置換で実際にマッチした数字は一番桁の 大きい部分のところです．次に修飾子g によって 他のところを 置換しにいくときは，このマッチした部分の次から置換を始めようとします． もし，含んでしまっていたら，数字全体にマッチしてしまいますので， コンマが 1つしか追加されずに終了してしまいます．

このスクリプトでは小数のことを考えていないので，小数点以下の部分まで コンマで区切ってしまうという問題点があります．これを修正したものが次のスクリ プトです．

s/\G((?:^[-+])?\d{1,3})(?=(?:\d\d\d)+(?!\d))/$1,/g;

\G はパターンマッチの開始位置にマッチします． これが入っていることで，いきなり小数点以下部分にマッチしたりすることがなくな り，前回マッチした部分のすぐ次の桁からの部分にだけ注目して置換を行なうことが できるようになります．\G のことは 「正しくパターンマッチさせる」の中でも触れています．

実行速度ですが，私がベンチマークをとって調べたところ， 2番目の方法よりもその修正版である 3番目の方法の方 があらゆる場合において実行速度が速かったです． 1番目の方法と 3番目の方法ですが， 6桁以上の数字においては 3番目の方法の方が実行速度が速かったです．5桁以下で は 1番目の方法が一番速かったのです．

もし，実行速度を気にするのであれば，次のように書く方法があります．実行速 度は上記のどの方法よりも速いです．符号や小数にも対 応しています．

# $num を3桁ごとにコンマで区切る(高速版)

$num = reverse(join(',', reverse($num) =~ /((?:^\d+\.)?\d{1,3}[-+]?)/g))
  if $num =~ /^[-+]?\d\d\d\d/;

このスクリプトは数字を一旦ひっくり返してから，前から 3桁ごとに区切り，それらをコンマで連結した上で再度ひっくり返し ています．このスクリプトのように複雑な正規表現を避けたり，パターンマッチ文の 評価回数を少なくしたりすることで実行速度を速くできる場合があります． if 文ですが，これがなくても動作します．しかし，その場 合は 3桁以下の場合，つまり，全くコンマで区切る必要がない場合に おいても，数字をひっくり返してから元に戻すという作業が発生してしまい実行速度 が遅くなってしまいます．if 文は数字の絶対値が 1000 以上であるとしてもいいのですが，私がベンチマークをとってみたところ，このスク リプトのように正規表現で判断した方が実行速度が速かったです．ただ，一般にパター ンマッチは遅いものなので，他の組み込み関数で簡単に代用できる場合は正規表現を 避けた方が実行速度が速くなることが多いです．

次のスクリプトは複雑な正規表現を避け，組み込み関数で代用するということを 更に進めたものです．実行速度は最速です．もちろん， 符号や小数にも対応しています．

# $num を3桁ごとにコンマで区切る(最速版)

if ($num =~ /^[-+]?\d\d\d\d+/g) {
  for ($i = pos($num) - 3, $j = $num =~ /^[-+]/; $i > $j; $i -= 3) {
    substr($num, $i, 0) = ',';
  }
}

このスクリプトはまず初めに if 文で，全くコンマで区 切る必要がない場合に無駄な処理をさせないという判断を行なうと同時に，どこまで が整数部分であるのかということもチェックしています．正規表現の最後に + がつけてあるので小数点が来るか，または，文字列の最後に達するかす るまでできるだけ長くマッチしようとします．したがって，この正規表現で整数部分 がすべてマッチすることになります．

このパターンマッチに おいてに修飾子 g がつけられているところに注意してください． 修飾子 g をつけたパターンマッチを スカラーコンテキストで評価した場合，パターンマッチ対象となった文字 列は前回マッチした場所を記憶しています．そのため，もう一度同じ文字列に 対して修飾子 g をつけたパターンマッチを行なうと，続き からパターンマッチが行なわれるようになります．このスクリプトでは pos 関数によって前回マッチした場所の記憶， すなわち，整数部分が文字列のどの位置までかということを取得しています． この情報を使ってコンマを追加することで 小数点以下の場所までコンマを追加することがなくなります．

整数部分の最後の場所がわかれば，後は 3文字ごとにコンマを追加 していくことになります． このスクリプトでは追加の作業を substr 関数で行なっています．この関数の第 3引数が 0 なので文字と文字の間に文字列，この場合は，コンマを追加することになります．こ のとき単純に 3文字ごとに追加していったのでは，符号がついていた 場合に符号と数字の間に間違ってコンマを追加してしまう場合があります．そのため， 符号がついていた場合には符号を含めないように処理を止めるようにしています．具 体的には，$j の値は符号が ついていなければ空文字列，符号がついていれば 1 になります．空文字列は比較するときには 0 と解釈されます．

数字を四捨五入する

# $num を四捨五入して小数点以下 $decimals桁にする

sub round {
  my ($num, $decimals) = @_;
  my ($format, $magic);
  $format = '%.' . $decimals . 'f';
  $magic = ($num > 0) ? 0.5 : -0.5;
  sprintf($format, int(($num * (10 ** $decimals)) + $magic) /
                   (10 ** $decimals));
}

# 計算例
$number = 1.2345;
$number_0 = round($number, 0);  # 四捨五入して整数にする
$number_2 = round($number, 2);  # 小数点以下2桁まで求める
$number_3 = round($number, 3);  # 小数点以下3桁まで求める
print $number_0, "\n";          # --> 1
print $number_2, "\n";          # --> 1.23
print $number_3, "\n";          # --> 1.235

四捨五入の基本は，正数の小数点以下を四捨五入して正整数にすることです． これをやるには，0.5 を加えて int 関数で小数点以下を削除すればできます． 小数点以下 n 桁のところで四捨五入したい場合は，まず 10 の (n - 1) 乗します．これで四捨五入したい桁の 部分が小数第 1位のところにきます． あとは基本どおりに四捨五入し，今度は 10 の -(n - 1) 乗してもとの桁に戻します． 負数の場合は，0.5 を加えるのではなく引くというところが違い， あとは正数の場合と同じです．

こうして求めた数値はそのままでは正確に求めたい桁数になっていない場合が あります．そこで最後に sprintf 関数を使って不要な桁を削除しています．

単に小数点以下の特定の桁までに数字を丸めたい場合には，次にように sprintf の %f を使えば可能です．

# $num を小数点以下 $decimals桁までに丸める(完全な四捨五入ではない)

$num = sprintf("%.${decimals}f", $num);

完全な四捨五入ではないと書いたのは，特定の条件下では 結果が四捨五入とならないからです．例えば 0.15 を小数第2位で四捨五入して，小数点以下1桁までにした結果の 0.2 を期待して， printf("%.1f\n", 0.15); と書いても， ほとんどの環境で 0.2 とはならずに 0.1 と表示されることでしょう．

数字を切り上げる

# $num を切り上げて小数点以下 $decimals桁にする

sub ceil {
  my ($num, $decimals) = @_;
  my ($format, $tmp1, $tmp2);
  $format = '%.' . $decimals . 'f';
  $tmp1 = $num * (10 ** $decimals);
  $tmp2 += $tmp1 <=> ($tmp2 = int($tmp1));
  sprintf($format, $tmp2 / (10 ** $decimals));
}

# 計算例
$number = 1.2345;
$number_0 = ceil($number, 0);  # 切り上げて整数にする
$number_2 = ceil($number, 2);  # 小数点以下2桁まで求める
$number_3 = ceil($number, 3);  # 小数点以下3桁まで求める
print $number_0, "\n";          # --> 2
print $number_2, "\n";          # --> 1.24
print $number_3, "\n";          # --> 1.235

このスクリプトの基本は「数字を四捨五入する」の スクリプトと同じです．実際に切り上げを行なっている部分は， sprintf 関数の直前の文です．この文をわかりやすく 書きかえると次のようになります．

  $tmp2 = int($tmp1) + ($tmp1 <=> int($tmp1));

これは，小数点以下を切り落とした数字と元の数字を比較して，もし違えば 切り上げるということを行なっています．切り上げる方向は絶対値が大きくなる 方向です．

モジュール POSIX の ceil 関数を使えば切り上げを行なうことができますが，この関数は切り上げて整 数にすることしかやってくれません．また，切り上げる方向は正の方向ですので，負 数を切り上げる場合には注意が必要です．

配列から重複した要素を取り除く

# 配列 @array から重複した要素を取り除く

{
  my %count;
  @array = grep(!$count{$_}++, @array);
}

このようにすると配列の 要素の出現順序が保存されます． また，ハッシュ %count には配列の要素をキーとし， その値には出現回数が入っています．出現回数の否定を条件式とすることで 重複した要素を取り除くことができます．具体的には，初めて出現したときは 出現回数を 0回から 1回に ++ するわけですが， そのときの条件式は !0 となり真となります． 次に出現したとき，つまり，重複していたときは，出現回数 1 以上の数値に対しての否定となり必ず偽となります．

ハッシュ %count は局所化されていますので， このブロックを抜けた時点で自動的に消滅します． もし，出現回数を利用したいのであれば，このブロック内で利用するか， または，次のように書くことで後から利用することができます．

# 配列 @array から重複した要素を取り除く
# 後から出現回数を利用したい

undef(%count);
@array = grep(!$count{$_}++, @array);

配列をランダムに並び替える

# 配列 @array をランダムに並び替える

srand;
for (my $i = @array; --$i; ) {
  my $j = int rand ($i + 1);
  next if $i == $j;
  @array[$i, $j] = @array[$j, $i];
}

srand 関数は rand 関数を使う前に 一度だけ実行しておく必要があります．もし， srand 関数を実行しておかないといつも同じ結果に なってしまいます．ただ，perl5.004 以降では rand 関数が使われたときに，まだ一度も srand 関数を 実行していなかった場合には自動で実行してくれます． $i = @array では @array がスカラーコンテキストで実行されますので， 配列の大きさを返します． このスクリプトの for 文は (配列の大きさ - 1)回実行され，for 文の ブロックの中の 3つ目の文で要素の 入れ替えを配列スライスを 使って行なっています．$i の初期値は配列の大きさ， つまり，(最後の添え字の値 + 1) となっているのですが， 条件文 --$i が評価されるときに - 1 されますので，for 文のブロックの中に 入るときには (最後の添え字の値) になっています．

もし，元の配列を残しておきたいのならば次のように書きます．

# 配列 @old をランダムに並び替えた配列 @new を作る

srand;
@new = ();
foreach (@old) {
  my $r = int rand (@new + 1);
  push(@new, $new[$r]);
  $new[$r] = $_;
}

このスクリプトは配列の要素を入れ替えるという先ほどのスクリプトと違い， 要素を 1つずつ新しい配列に追加していくのですが， そのときに新しい要素は ランダムに選んだ場所に入れ，もともとそこにあった要素を一番最後に 移動させるというものです．