Perl basics - sed, Awk の発展系としての Perl

[Perl正規表現] [Perl more basics]
[2014/03/24新規] [2014/09/12更新]

Contents

主な形式

perl -[n|p][l]e 'script' [file...]
perl [-n|-p][-l] script_file [file...]

sed, Awk 風な説明

perl -n は『レコード』と呼ばれる行を一つずつパターンスペース '$_' に入力する。perl -p はさらにそのパターンスペース '$_' を出力する。Perl スクリプトを '-e script' や 'script_file' で指定することにより様々な処理をすることができる。

まず、入力行は sed, Awk とは異なり、レコードセパレータである改行コード '\n' が取り除かれずにパターンスペース '$_' に入る。但し、'-l' オプションを指定すると、改行コードが取り除かれ、出力のレコードセパレータに改行コード '\n' が設定される。

また、perl -na は、Awk のように、フィールドセパレータである空白を区切りとして '$F[0]', '$F[1]', '$F[2]', 〜 にその行の『フィールド』群が入る。

sed, Awk 風な Perl スクリプトの概要

Awk のように 'BEGIN', 'END' のような前処理と、後処理を記す特殊ブロックが使えるが、他はすべてサブルーチンか主処理となる。そして、sed, Awk のようなマッチの範囲「式, 式」に処理されるブロックはサポートされないが、条件式で '..' 演算子(２つの式が sed スタイルのときは '...' 演算子)を用いることでそれと似た制御ができる。

例えば以下は、Awk では awk '/^<pre>/,/<\/pre>$/' となる、HTML の 'pre' タグを含むそれに囲まれた行を表示する Perl スクリプトである。 

	perl -ne 'print if (/^<pre>/../<\/pre>$/)'

ここで、'print' は 'print $_' と等価である。

例えば以下は、sed では sed -e 's/&/\&amp;/g;s/</\&lt;/g;s/>/\&gt;/g' となる、ソースコードを HTML にペーストできるように「<」から「&lt;」への変換等を行なう Perl スクリプトである。 

	perl -pe 's/&/&amp;/g; s/</&lt;/g; s/>/&gt;/g'

このように Perl スクリプトは、オプションにより sed, Awk 風に書けるようになっている。

簡単な説明

perl -n は『レコード』と呼ばれる行を一つずつパターンスペース '$_' に入力する、以下とほぼ等価なスクリプトとなる。 

	perl -e 'while (<>) {…}'

これはさらに以下とほぼ等価なスクリプトとなる。 

	perl -e '
unshift(@ARGV, "-") unless @ARGV;
while (defined($ARGV = shift @ARGV)) {
  open(FH, $ARGV);
  while ($_ = <FH>) {
    …
  }
  close(FH)
}'

perl -p はさらにそのパターンスペース '$_' を出力する、以下とほぼ等価なスクリプトとなる。 

	perl -e '
while (<>) {
  …
}
continue {
  print
}'

これはさらに以下とほぼ等価なスクリプトとなる。 

	perl -e '
unshift(@ARGV, "-") unless @ARGV;
while (defined($ARGV = shift @ARGV)) {
  open(FH, $ARGV);
  while ($_ = <FH>) {
    …
  }
  continue {
    print $_
  }
  close(FH)
}

まず、入力行は sed, Awk とは異なり、レコードセパレータである改行コード '\n' が取り除かれずにパターンスペース '$_' に入る。但し、'-l' オプションを指定すると、改行コードが取り除かれ、出力のレコードセパレータに改行コード '\n' が設定される、以下とほぼ等価なスクリプトとなる。 

	perl -e 'BEGIN{ $\ = "\n" } while (<>) { chomp; … }'

また、perl -na は、Awk のように、フィールドセパレータである空白を区切りとして '$F[0]', '$F[1]', '$F[2]', 〜 にその行の『フィールド』群が入る、以下とほぼ等価なスクリプトとなる。 

	perl -e 'while (<>) { @F = split(' ', $_); … }'

このように Perl は様々な場面で省略可能な引数などのサポートが手厚く、簡素に書ける反面、一見不明瞭なコードになりがちである。

Perl スクリプトの概要

例えば先の、HTML の 'pre' タグを含むそれに囲まれた行を表示する Perl スクリプトは、省略せずに書けば以下のようになる。 

	perl -e '
while (<>) {
  print $_ if ($_ =~ /^<pre>/ .. $_ =~ /<\/pre>$/)
}'

例えば先の、ソースコードを HTML にペーストできるように「<」から「&lt;」への変換等を行なう Perl スクリプトは、省略せずに書けば以下のようになる。 

	perl -e '
while (<>) {
  $_ =~ s/&/&amp;/g;
  $_ =~ s/</&lt;/g;
  $_ =~ s/>/&gt;/g
}
continue {
  print $_
}'

スクリプトは宣言か文のリストからなり、宣言はピクチャ書式とサブルーチン、文は代入式、制御構文、関数呼び出し、ブロック '{' 宣言か文のリスト '}' である。宣言か文の区切りは ';' で区切る。シェルや C/C++ の文と似ているが '}' 直前の ';' が省略できることが異なる。

型

Perl の変数には、'$' から始まるスカラ変数、'@' から始まる配列変数、'%' から始まるハッシュ変数があり、その値は数値、文字列、リファレンスの型を扱える。配列、ハッシュの値は '$' から始まる変数名と '[添字]' や '{キー}' でアクセスする。

特に、変数には数値と文字列が区別なく扱える一方で、文字列の '0' を意図せず数値として評価されてしまうなど、注意が必要となる。

配列変数は: 

#!/usr/bin/perl
@list = (1, 2, 3, 4, 5);
print $list[1], "\n";	# 要素: 2
print $list[3], "\n";	# 要素: 4
print scalar @list, "\n";	# 要素数: 5

ハッシュ変数は: 

#!/usr/bin/perl
%hash = ('foo' => 'Foo',
	 'bar' => 'Bar');
print $hash{'foo'}, "\n";	# 値: 'Foo'
print $hash{'bar'}, "\n";	# 値: 'Bar'
print scalar keys %hash, "\n";	# 要素数: 2

変数へのリファレンスは '\' で表し、デリファレンスはアクセスしたい型に応じて '$', '@', '%' を用いる。

スカラ変数へのリファレンス: 

#!/usr/bin/perl
$scalar = 'A Happy New Year!';
$ref = \$scalar;
print $$ref, "\n";	# 文字列: A Happy New Year!

配列変数へのリファレンスは: 

#!/usr/bin/perl
@list = (1, 2, 3, 4, 5);
$ref = \@list;
print $$ref[1], "\n";	# 要素: 2
print $$ref[3], "\n";	# 要素: 4
print scalar @$ref, "\n";	# 要素数: 5

ハッシュ変数へのリファレンスは: 

#!/usr/bin/perl
%hash = ('foo' => 'Foo',
         'bar' => 'Bar');
$ref = \%hash;
print $$ref{'foo'}, "\n";	# 値: 'Foo'
print $$ref{'bar'}, "\n";	# 値: 'Bar'
print scalar keys %$ref, "\n";	# 要素数: 2

スカラへのリファレンスは '\' で表し、無名配列へのリファレンスは […]、無名ハッシュへのリファレンスは {…} で記述できる。

スカラへのリファレンス: 

#!/usr/bin/perl
$ref = \'A Happy New Year!';
print $$ref, "\n";	# 文字列: A Happy New Year!

無名配列へのリファレンスは: 

#!/usr/bin/perl
$ref = [ 1, 2, 3, 4, 5 ];
print $$ref[1], "\n";	# 要素: 2
print $$ref[3], "\n";	# 要素: 4
print scalar @$ref, "\n";	# 要素数: 5

無名ハッシュへのリファレンスは: 

#!/usr/bin/perl
$ref = { 'foo' => 'Foo',
         'bar' => 'Bar' };
print $$ref{'foo'}, "\n";	# 値: 'Foo'
print $$ref{'bar'}, "\n";	# 値: 'Bar'
print scalar keys %$ref, "\n";	# 要素数: 2

他に、上記を応用した「多次元配列」や「構造体」がある。

制御構文

以下の制御構文が使用できる。シェルの 'elif', C の 'else if' ではなく 'elsif' であること、C の 'continue' ではなく 'next'、シェル/C の 'break' ではなく 'last' であることに注意。

'switch' は基本的にはサポートされないが、代わりに 'switch' 風なブロックや 'given', 'when' 構文が存在する。

以上は C/C++ とは異なり必ずブロックを必要とし、単文は書けない。しかし、以下のような制御構文であれば、ブロックではなく単文で記述できる。

演算子

Perl の演算子は C/C++ のそれとおよそ同じだが、加えて、文字列や正規表現のための演算子など多数存在する。特に注意すべき演算子を以下にあげる。

PerlC/C++備考
expr1 . expr2string(expr1) + string(expr2)文字列の連結
lvalue .= exprstring(lvalue) += string(expr)文字列の連結の代入
expr1 ** expr2pow(expr1, expr2)指数関数
lvalue **= exprlvalue = pow(lvalue, expr)指数関数の代入
expr1 =~ expr2regex_search(expr1, , regex(expr2, ...))C/C++ の ビット否定ではなく、正規表現のマッチ
expr1 !~ expr2!regex_search(expr1, , regex(expr2, ...))C/C++ の ビット否定ではなく、正規表現のマッチの否定
expr1 eq expr2string(expr1) == string(expr2)文字列の比較として、等しい
expr1 ne expr2string(expr1) != string(expr2)文字列の比較として、等しくない
expr1 lt expr2string(expr1) < string(expr2)文字列の比較として、小さい
expr1 gt expr2string(expr1) > string(expr2)文字列の比較として、大きい
expr1 le expr2string(expr1) <= string(expr2)文字列の比較として、等しいか小さい
expr1 ge expr2string(expr1) >= string(expr2)文字列の比較として、等しいか大きい

特殊変数

Perl における主な特殊変数は以下の通りである。

エスケープ文字

Perl におけるエスケープ文字は以下の通りである。

このように Perl では非常に多くのエスケープ文字がサポートされる。

組み込み関数

算術関数

配列関数

リスト関数

ハッシュ関数

文字列関数

入出力関数

その他の関数

これ以外にも、ファイル検査、ファイル操作、スコープ、制御フロー、プロセス、モジュール、オブジェクト指向、ソケット、System V プロセス間通信、ユーザ・グループ、時刻関連などの標準の組み込み関数がサポートされる。

例題

代表的な Unix コマンドに相当する Perl スクリプトを以下にあげる。

`cat`

	perl -pe ''

このように、cat と同じ perl スクリプトは「空」となるが、「perl -ne 'print'」でもよいし、「perl -ne 'print $_'」でもよいし、「perl -e 'print while (<>)'」でもよいし、「perl -e 'while (<>) { print }'」でもよい。

[sed] [Awk] [Perl] [Ruby] [Python]

`head -n 1`

	perl -ne 'print if ($. == 1)'

このように、head -n 1 と同じ perl スクリプトは以上のようになるが、「perl -ne 'if ($. == 1) { print; last }'」の方が効率がよいだろう。

[sed] [Awk] [Perl] [Ruby] [Python]

`tail -n 1`

	perl -ne 'print if (eof())'

このように、tail -n 1 と同じ perl スクリプト以上のようになるが、Awk のように「END{ print }」では動作せず、この場合「perl -ne '$b = $_; END{ print $b }'」となる。

[sed] [Awk] [Perl] [Ruby] [Python]
	perl -ne 'print if !($. > 8)'

このように、head -n 8 と同じ perl スクリプトは以上のようになるが、「perl -ne 'if (!($. > 8)) { print } else { last }'」の方が効率がよいだろう。

[sed] [Awk] [Perl] [Ruby] [Python]

`tail -n 8`

さて、`head -n 1`, `tail -n 1`, `head -n n` は以上のように大変簡単であるが、`tail -n n` は少し工夫が必要であり、以下のようになる。 

	perl -ne '
BEGIN{
  $n = 8
}
{
  $A[$.%$n] = $_
}
END{
  for ($i=0; $i<$n; $i++) {
    print $A[($.+$i+1)%$n]
  }
}'

ここでは、配列にラウンドロビン的に行を格納していき、最後にそれらを出力している。

このように、tail -n 8 と同じ perl スクリプトは以上のようになる。

[sed] [Awk] [Perl] [Ruby] [Python]

`wc -l`

	perl -ne 'END{ print $. }'

このように、wc -l と同じ perl スクリプトは以上のようになる。

[sed] [Awk] [Perl] [Ruby] [Python]

`wc -c`

sed では大変面倒になる `wc -c` は perl だと算術演算があるので簡単である。 

	perl -ne '{ $l += length() } END{ print $l . "\n" }'

このように、wc -c と同じ perl スクリプトは以上のようになる。

[sed] [Awk] [Perl] [Ruby] [Python]

`wc -w`

sed では大変面倒になる `wc -w` は perl だと算術演算があるので簡単であるが、少々工夫が必要であり、以下のようになる。 

	perl -ne '
{
  $h = $_;
  while ($h =~ "[^\t\n ]+") {
    $w++;
    $h = ${^POSTMATCH}
  }
}
END{
  print $w . "\n"
}'

この '${^POSTMATCH}' によるマッチの繰り返しは Perl では大域マッチによりさらに簡単に書けて、以下のようになる。 

	perl -ne '
{
  $w++ while (/[^\t\n ]+/g)
}
END{
  print $w . "\n"
}'

この方法は他に応用が効くのでこれでもよいのだが、置換の手続きが置換の数をカウントしてくれるので、この場合は以下の方が簡単である。 

	perl -ne '
{
  $w += (s/[^\t\n ]+//g)
}
END{
  print $w . "\n" 
}'

このように、wc -w と同じ perl スクリプトは以上のようになる。

[sed] [Awk] [Perl] [Ruby] [Python]

`grep '^$'`

	perl -ne 'print if (/^$/)'

このように、基本正規表現の grep '^$' と同じ perl スクリプトは以上のようになるが、Perl では基本正規表現はサポートされないので、他のパターンではPerl正規表現に書き直す必要がある。

[sed] [Awk] [Perl] [Ruby] [Python]

`grep -v '^$'`

	perl -ne 'print unless (/^$/)'

このように、マッチの否定、基本正規表現の grep -v '^$' と同じ perl スクリプトは以上のようになるが、Perl では基本正規表現はサポートされないので、他のパターンではPerl正規表現に書き直す必要がある。

[sed] [Awk] [Perl] [Ruby] [Python]

`grep -E '^.+'`

	perl -ne 'print if (/^.+/)'

このように、拡張正規表現の grep -E '^.+' と同じ perl スクリプトは以上のようになる。

[sed] [Awk] [Perl] [Ruby] [Python]

`grep -E -v '^.+'`

	perl -ne 'print unless (/^.+/)'

このように、拡張正規表現のマッチの否定、grep -E -v '^.+' と同じ perl スクリプトは以上のようになる。

[sed] [Awk] [Perl] [Ruby] [Python]

`cut -d ':' -f 1,6`

	perl -F':' -ane '{ if (@F >= 6) { print $F[0], ":", $F[5], "\n" } else { print } }'

ここで "-F':'" は "-a" オプションと共にフィールドセパレータを指定するものである。

このように、区切り ':' のフィールド切り取り、cut -d ':' -f 1,6 但しフィールド数不足の行はそのまま出力と同じ perl スクリプトは以上のようになる。

[sed] [Awk] [Perl] [Ruby] [Python]

`cut -d ':' -f 1,6 -s`

	perl -F':' -ane 'if (@F >= 6) { print $F[0], ":", $F[5], "\n" }'

ここで "-F':'" は "-a" オプションと共にフィールドセパレータを指定するものである。

このように、区切り ':' のフィールド切り取り、cut -d ':' -f 1,6 但しフィールド数不足の行は出力しないと同じ perl スクリプトは以上のようになる。

[sed] [Awk] [Perl] [Ruby] [Python]

`fold -b`

この例、１行あたりの文字数(既定値は80)を越えたら改行を挿入する perl スクリプトを示そう。まずは正規表現を使わない方法： 

	perl -nle '
BEGIN{
  $w = 80
}
{
  $h = $_;
  while (defined $h) {
    if (length($h) > $w) {
      print substr($h, 0, $w);
      $h = substr($h, $w)
    }
    else {
      print $h;
      $h = undef
    }
  }
}'

もしくは、正規表現を使った方法： 

	perl -nle '
BEGIN{
  $w = 80
}
{
  $h = $_;
  while ($h !~ /^.{$w}$/ && $h =~ /^.{$w}/) {
    print $&;
    $h = $'
  }
  print $h
}'

後者の方が少しだけ単純だ。

このように、fold -b と同じ perl スクリプトは以上のようになる。

[sed] [Awk] [Perl] [Ruby] [Python]

`tee filename`

	perl -ne 'BEGIN{ open(OUT, ">", "filename.out") } { print; print OUT } END{ close(OUT) }'

このように、標準入力を標準出力とファイルに書き出し、tee と同じ perl スクリプトは以上のようになる。

[sed] [Awk] [Perl] [Ruby] [Python]

`tr 'A-Za-z' 'N-ZA-Mn-za-m'`

この例、ROT13(と呼ばれる暗号化と言うより難読化)は tr コマンドを使うと表題のように簡単に実現できる。そして、perl には tr コマンドに似た 'y' コマンドがあるので、以下のようになる。 

	perl -pe 'y/A-Za-z/N-ZA-Mn-za-m/'

このように、文字置換、tr 'A-Za-z' 'N-ZA-Mn-za-m' と同じ perl スクリプトは以上のようになる。

[sed] [Awk] [Perl] [Ruby] [Python]

`cat -n`

sed ではいささか面倒になる `cat -n` は perl だと極めて簡単である。 

	perl -ne '{ printf("%6d\t%s", $., $_) }'

このように、cat -n と同じ perl スクリプトは以上のようになる。

[sed] [Awk] [Perl] [Ruby] [Python]

`cat -b`

sed では大変面倒になる `cat -n` は perl だと極めて簡単である。 

	perl -pe 'if (!/^$/) { $i++; $_ = sprintf("%6d\t%s", $i, $_) }'

このように、cat -b と同じ perl スクリプトは以上のようになる。

[sed] [Awk] [Perl] [Ruby] [Python]

`uniq`, `uniq -d`, `uniq -u`

ところで、これらは GNU sed や GNU Awk で示される好例となっている。

  1. `uniq` - 重複する行を一行にする in GNU sed
  2. `uniq -d` - 重複する行のみを一行にして表示する in GNU sed
  3. `uniq -u` - 重複しない行のみを表示する in GNU sed
  4. `uniq [-du]` - 以上すべてに対応 in GNU Awk

sed ではいずれも 'N' コマンドで入力行をパターンスペースの末尾に '\n' に続いて追加し、正規表現にて '^\(.*\)\n\1$' のように後方参照 '\1' を利用していることにある。awk においては、基本的には以下に示す例と同等である。

これらを perl で実現すると、単純に文字列の比較と制御の組み合わせとなり、順に以下のようになる。 

	perl -ne 'if ($. == 1) { $h = $_; print } else { if ($h ne $_) { $h = $_; print } }'

	perl -ne 'if ($. == 1) { $h = $_ } else { if ($h ne $_) { $h = $_; $d = 0 } else { print if (!$d); $d = !0 } }'

	perl -ne 'if ($. == 1) { $h = $_ } else { if ($h ne $_) { print $h if (!$d); $h = $_; $d = 0 } else { $d = !0 } } END{ print $h if (!$d) }'

このように、uniq, uniq -d, uniq -u と同じ perl スクリプトは以上のようになる。

[sed] [Awk] [Perl] [Ruby] [Python]

`expand`

このタブを複数の空白に置換するコマンドを perl スクリプトで示そう。まずは正規表現を使った方法： 

	perl -nle '
BEGIN{
  $\ = undef;
  $n = 8 if (!$n)
}
{
  $h = $_;
  while ($h =~ ("^([^\t]{0," . ($n-1) . "}\t|[^\t]{$n})")) {
    $u = $&;
    $h = ${^POSTMATCH};
    $p = index($u, "\t");
    $p = length($u) if ($p < 0);
    $u = substr($u, 0, $p);
    for ($i=0; $i<$n-$p; $i++) {
      $u = $u . " "
    }
    print $u
  }
  print $h, "\n"
}'

もしくは、正規表現を使わない方法： 

	perl -nle '
BEGIN{
  $\ = undef;
  $n = 8 if (!$n)
}
{
  $l = 0;
  for ($i=0; $i<length($_); $i++) {
    $c = substr($_, $i, 1);
    $d = ($c eq "\t") ? $n - ($l % $n) : 1;
    if ($c eq "\t") {
      $c = "";
      for ($j=0; $j<$d; $j++) {
        $c = $c . " "
      }
    }
    print $c;
    $l += $d
  }
  print "\n"
}'

両者の効率と柔軟性におけるメリット・デメリットを考えてみるのも興味深い。個人的には、前者の方が判り易くてよいと思うが、例えば、'\b' が一文字戻るとみなす処理を加えるには後者の方が簡単である。

このように、expand と同じ perl スクリプトは以上のようになる。

[sed] [Awk] [Perl] [Ruby] [Python]

`unexpand -a`

この複数の空白をタブに置換するコマンドを perl スクリプトを示そう。まずは正規表現を使った方法： 

	perl -nle '
BEGIN{
  $\ = undef;
  $n = 8 if (!$n)
}
{
  $h = $_;
  while ($h =~ ("^([^\t]{0," . ($n-1) . "}\t|[^\t]{$n})")) {
    $u = $&;
    $h = ${^POSTMATCH};
    if ($h =~ /^ /) {
      if ($u =~ / {1,}$/) {
        $u = ${^PREMATCH} . "\t"
      }
    }
    else {
      if ($u =~ ("^([^\t]{" . ($n-1) . "})\t\$")) {
        $u = $1 . " "
      }
      if ($u =~ / {2,}$/) {
        $u = ${^PREMATCH} . "\t"
      }
    }
    print $u
  }
  print $h, "\n"
}'

ちなみに、最初の 'if' 文は、完全に `unexpand -a` の挙動を再現するためのものである。

もしくは、一文字ずつ調べる方法： 

	perl -nle '
BEGIN{
  $\ = undef;
  $n = 8 if (!$n)
}
{
  $buf = "";
  $l = 0;
  for ($i=0; $i<length(); $i++) {
    $c = substr($_, $i, 1);
    $d = ($c eq "\t") ? $n - ($l % $n) : 1;
    $l += $d;
    $buf = $buf . $c;
    if ($l % $n == 0) {
      if (substr($_, $i+1, 1) eq " ") {
        if ($buf =~ / +$/) {
          $buf = ${^PREMATCH} . "\t"
        }
      }
      else {
        if ($buf =~ ("^([^\t]{" . ($n-1) . "})\t\$")) {
          $buf = $1 . " "
        }
        if ($buf =~ /  +$/) {
          $buf = ${^PREMATCH} . "\t"
        }
      }
      print $buf;
      $buf = ""
    }
  }
  print $buf, "\n"
}'

両者の効率と柔軟性におけるメリット・デメリットを考えてみるのも興味深い。個人的には、前者の方が判り易くてよいと思うが、例えば、'\b' が一文字戻るとみなす処理を加えるには後者の方が簡単である。

このように、unexpand -a と同じ perl スクリプトは以上のようになる。

[sed] [Awk] [Perl] [Ruby] [Python]

`rev`

行毎に文字列を反転する BSD rev(1) コマンド。実用したことはないが、sed で実現するには秀逸な技法が必要であった。しかし、perl では極めて単純に、文字列を逆順に取り出して出力すればよい。 

	perl -ne '{ chomp; for ($i=length()-1; $i>=0; $i--) { print substr($_, $i, 1) } print "\n" }'

このように、BSD rev(1) と同じ perl スクリプトは以上のようになる。

[sed] [Awk] [Perl] [Ruby] [Python]

`tac`, `tail -r`

最終行から先頭行まで逆順で出力する GNU tac コマンド、`tail -r` に同じ。これも実用したことはないが、GNU sed における、好ましくない実現例のように、perl における好ましくない実装は以下の通りである。 

	perl -ne '
if ($. == 1) {
  $b = $_
}
else {
  $b = $_ . $b
}
END{ print $b }'

変数に行を逆順に連結して最後にそれを出力するという処理なので、メモリが足りなくなるか、仮想メモリで非常に遅くなるだろう。しかし、Perl には 'tell', 'seek' がある。より安全な実装は以下のようになる。 

	perl -e '
open(IN, "$ARGV[0]");
$p[$n++] = tell(IN);
while (<IN>) {
  $p[$n++] = tell(IN)
}
for ($i=$n-2; $i>=0; $i--) {
  seek(IN, $p[$i], 0);
  $b = <IN>;
  print $b
}'

ここではファイルを入力しながらすべての改行の次のファイルハンドルの位置を配列に覚えておき、改めてその配列の逆順にファイルハンドルを移動する処理を行なっている。ファイル全体をオンメモリで処理しないので、先の例よりは安全であるが、改行が膨大に存在する長大なファイルの場合、配列のためのメモリ不足になるかもしれない。よって、以下のような安全な実装も考えられる。 

	perl -e '
open(IN, "$ARGV[0]");
seek(IN, 0, 2);
$p = tell(IN) - 2;
while ($p >= 0) {
  seek(IN, $p--, 0);
  read(IN, $c, 1) if ($p >= 0);
  if ($p < 0 || $c eq "\n") {
    $b = <IN>;
    print $b
  }
}'

ここでは始めにファイルハンドルの位置をファイルのの末尾に移動し、１バイト読み込みつつ、そのファイルハンドルの位置を１バイトずつ戻す処理を行なっている。ファイル全体をオンメモリで処理しないので、先の例よりは安全である。

[sed] [Awk] [Perl] [Ruby] [Python]

`fold`

この例、１行あたりの制御コードを考慮した文字数(既定値は80)を越えたら改行を挿入する perl スクリプトを示そう。これはカウントが必要になるので sed では困難な好例となっている。 

	perl -nle '
BEGIN{
  $\ = undef;
  $n = 8 if (!$n);
  $w = 80 if (!$w)
}
{
  $l = 0;
  for ($i=0; $i<length(); $i++) {
    $c = substr($_, $i, 1);
    $d = ($c eq "\b") ? (($l > 0) ? -1 : 0) : ($c eq "\r") ? -$l : ($c eq "\t") ? $n - ($l % $n) : 1;
    if ($l+$d > $w) {
      print "\n";
      $l = $d
    }
    else {
      $l += $d
    }
    print $c
  }
  print "\n"
}'

このように、fold と同じ perl スクリプトは以上のようになる。

[sed] [Awk] [Perl] [Ruby] [Python]

`fold -s`

この例、１行あたりの制御コードを考慮した文字数(既定値は80)を越えようとするブランクに変わり改行を挿入する perl スクリプトを示そう。これもカウントが必要になるので sed では困難な好例となっているだけでなく、perl でもかなり複雑にならざるを得ない。 

	perl -nle '
BEGIN{
  $n = 8 if (!$n);
  $w = 80 if (!$w)
}
sub increment
{
  my ($l, $c) = @_;
  ($c eq "\b") ? (($l > 0) ? -1 : 0) : ($c eq "\r") ? -$l : ($c eq "\t") ? $n - ($l % $n) : 1
}
{
  $buf = "";
  $l = $len = 0;
  if ($_ eq "") { print ""; next }
  for ($i=0; $i<length(); $i++) {
    $c = substr($_, $i, 1);
    if ($l + increment($l, $c) > $w) {
      {
        $j = $len;
        while (--$j >= 0 && substr($buf, $j, 1) !~ "[\t-\r ]") {}
        $space = $j
      }
      if ($space != -1) {
        $space++;
        printf("%.*s\n", $space, $buf);
        $buf = substr($buf, $space, $len - $space);
        $len -= $space;
        $l = 0;
        for ($j=0; $j<$len; $j++) {
          $l += increment($l, substr($buf, $j, 1))
        }
      }
      else {
        printf("%.*s\n", $len, $buf);
        $l = $len = 0
      }
    }
    $l += increment($l, $c);
    $buf = substr($buf, 0, $len) . $c;
    $len++
  }
  if ($len != 0) {
    printf("%.*s\n", $len, $buf)
  }
}'

ここでユーザ定義関数を効果的に使用していることに注目したい。しかし、もっと簡単になるような気もする…

このように、fold -s と同じ perl スクリプトは以上のようになる。

[sed] [Awk] [Perl] [Ruby] [Python]

`strings -a [-n 4] [-t d|o|x]`

この例、ファイルの連続した印字可能な４文字以上の文字列を表示する perl スクリプトを示す。この例では strings.pl という実行権のついたファイルに記述するものとする。 

#!/usr/bin/perl -l -n -s
BEGIN{
  $n = 4 if (!$n);
  if ($t) {
    if ($t eq "x") {
      $fmt = "%x %s\n"
    }
    elsif ($t eq "o") {
      $fmt = "%o %s\n"
    }
    else {
      $fmt = "%d %s\n"
    }
  }
}
if (!$t) {
  s/([\f[:print:]]{$n,})/print $1/ge;
}
else {
  printf $fmt, (tell() - (length() + 1) + $-[1]), $& while (/([\f[:print:]]{$n,})/g);
}

この strings.pl では、'-n=4', '-t=d|o|x' オプションが指定でき、このように、オプション解析は Perl の '-s' オプションに任せると柔軟な perl スクリプトが書ける。

このように、strings -a と同じ perl スクリプトは以上のようになる。

[sed] [Awk] [Perl] [Ruby] [Python]

`printenv`

さて、ここまでは入力ファイル駆動型のプログラムばかりであったが、そうではなく自律型のプログラムを書くには、Perl では普通に '-n' や '-p' オプションを指定しなければよい。

この例、環境変数をすべて表示する perl スクリプトを示す。 

	perl -l -e 'for (keys %ENV) { print "$_=$ENV{$_}" }'

連想配列のキーをすべて取り出すには 'keys %' とする。

このように、printenv と同じ perl スクリプトは以上のようになる。

[sed] [Awk] [Perl] [Ruby] [Python]

`yes [expletive]`

この例、プロセス停止まで永遠に "yes^J" を印字し続ける perl スクリプトを示す。但しこのコマンド、第一引数を指定した場合には "yes" の代わりにそれを印字する仕様となっている。この例では yes.pl という実行権のついたファイルに記述するものとする。 

#!/usr/bin/perl
$y = @ARGV ? $ARGV[0] : 'yes';
print $y . "\n" while (!0);

このように、yes と同じ perl スクリプトは以上のようになる。

[sed] [Awk] [Perl] [Ruby] [Python]

`cmp [-l|-s] file1 file2`

この例、二つのファイルのバイトの差異を返す perl スクリプトを示す。バイナリファイルとしての扱いが可能な Perl での好例となる。 

#!/usr/bin/perl -s
$blksize = 4096;
local($bc, $lc, $rv) = (0, 0, 0);
exit 0 if ($ARGV[0] eq $ARGV[1]);
open($f[0], '<', $ARGV[0]); binmode($f[0]);
open($f[1], '<', $ARGV[1]); binmode($f[1]);
do {
  local(@b);
  $rv[0] = read($f[0], $b[0], $blksize);
  $rv[1] = read($f[1], $b[1], $blksize);
  $sz = ($rv[0] < $rv[1]) ? $rv[0] : $rv[1];
  if (!$l) {
    for (my $i=0; $i<$sz; ++$i) {
      $s[0] = substr($b[0], $i, 1);
      $s[1] = substr($b[1], $i, 1);
      ++$lc if ($s[0] eq "\n");
      if ($s[0] ne $s[1]) {
	print $ARGV[0], " ", $ARGV[1], " differ: char ", $bc + $i + 1, ", line ", $lc + 1, "\n" if (!$s);
	$rv = 1;
	last;
      }
    }
    $bc += $sz;
  }
  else {
    for (my $i=0; $i<$sz; ++$i) {
      $s[0] = substr($b[0], $i, 1);
      $s[1] = substr($b[1], $i, 1);
      if ($s[0] ne $s[1]) {
	printf "%4d %3o %3o\n", $bc + $i + 1, ord($s[0]), ord($s[1]);
	$rv = 1;
      }
    }
    $bc += $sz;
  }
  if (!($rv[0] == $blksize && $rv[1] == $blksize)) {
    print STDERR "cmp: EOF on ", ($rv[0] < $rv[1]) ? $ARGV[0] : $ARGV[1], "\n";
    $rv = 1;
  }
} while ($rv[0] == $blksize && $rv[1] == $blksize);
close($f[0]);
close($f[1]);
exit $rv;

このように cmp と同じ perl スクリプトは以上のようになる。

[sed] [Awk] [Perl] [Ruby] [Python]

`paste [-d delimiter] [-s] file ...`

この例、複数のファイルの内容を行毎に結合する perl スクリプトを示す。但しこのコマンド、'-s' オプションを指定した場合はファイル毎に改行を除去して結合する仕様となっており、特に難しくはない。この例では paste.pl という実行権のついたファイルに記述するものとする。

Perl ではファイル操作関数が揃っているので、以下のように sed では困難な、複数のファイルの平行な入力に対応できる。 

#!/usr/bin/perl -l -s
sub getlinepos {
  local($f, $p) = @_;
  my($b) = (undef);
  return $b if ($p == -1);
  open(FH, $f);
  seek(FH, $p, 0) if ($p > 0);
  $b = <FH>;
  $p = (!eof(FH)) ? tell(FH) : -1;
  close(FH);
  ($b, $p);
}
$d = "\t" if (!$d);
if (!$s) {
  $c = @ARGV;
  while ($c) {
    $S = undef;
    for ($a = 0; $a < @ARGV; $a++) {
      $S .= sprintf('%s', $d) if ($a != 0);
      next if (!defined $ARGV[$a]);
      ($b, $po[$a]) = getlinepos($ARGV[$a], $po[$a]);
      if (!defined $b) {
	$ARGV[$a] = undef;
	--$c;
	next;
      }
      chomp($b);
      $S .= sprintf('%s', $b);
    }
    print $S if ($c);
  }
}
else {
  while (<>) {
    $FNR = $. - $PREVIOUS_NR;
    chomp;
    printf '' . $\ if ($FNR == 1 && $PREVIOUS_NR > 0);
    printf '%s', $d if ($FNR != 1);
    printf '%s', $_;
  }
  continue {
    $PREVIOUS_NR = $. if eof;
  }
  if ($.) {
    printf '' . $\;
  }
}

このように、paste と同じ perl スクリプトは以上のようになる。

[sed] [Awk] [Perl] [Ruby] [Python]

`comm [-1] [-2] [-3] file1 file2`

この例、複数のファイルの内容を行毎に比較する perl スクリプトを示す。この例では comm.pl という実行権のついたファイルに記述するものとする。

入力ファイルは、行でソートされていることが前提となっているので、複数のファイルをキーの文字列の大小で並行して読み進めていけば良い。 

#!/usr/bin/perl
sub getlinepos {
  local($f, $p) = @_;
  my($b) = (undef);
  return $b if ($p == -1);
  open(FH, $f);
  seek(FH, $p, 0) if ($p > 0);
  $b = <FH>;
  $p = (!eof(FH)) ? tell(FH) : -1;
  close(FH);
  ($b, $p);
}

while (@ARGV) {
  if ($ARGV[0] eq '--') { shift; last }
  elsif ($ARGV[0] eq '-1') { $s0 = !0 }
  elsif ($ARGV[0] eq '-2') { $s1 = !0 }
  elsif ($ARGV[0] eq '-3') { $s2 = !0 }
  else { last }
  shift
}

$\ = "\n";

@cf = (-1)x@ARGV;
$s[0] = $s0;
$s[1] = $s1;
$s[2] = $s2;
for ($a=1; $a<=@ARGV; $a++) {
  for (my $i=0; $i<=$a; $i++) {
    $sc[$a]++ if ($s[$i]);
  }
}
$km = undef;
$c = @ARGV;
{
  $ceq = 0;
  while ($c) {
    for ($a = 0; $a < @ARGV; $a++) {
      $cf[$a] = -1;
      while (defined $ARGV[$a] && $cf[$a] == -1) {
	($b, $po[$a]) = getlinepos($ARGV[$a], $po[$a]);
	if (!defined $b) {
	  $ARGV[$a] = undef;
	  --$c;
          if ($c == 0 && defined $km) {
            if ($ceq + 1 != @ARGV) {
              printf("%s%s\n", "\t"x($last_a-$sc[$last_a]), $km) if (!$s[$last_a]);
            }
          }
	  next;
	}
        chomp($b);
	if (!defined $km) {
	  $km = $b;
	  $cf[$last_a = $a] = undef;
          $ceq = 0;
	}
	else {
	  if ($km lt $b) {
            if ($ceq + 1 != @ARGV) {
              printf("%s%s\n", "\t"x($last_a-$sc[$last_a]), $km) if (!$s[$last_a]);
            }
	    $km = $b;
            $cf[$last_a = $a] = 1;
            $ceq = 0;
          }
	  elsif ($km eq $b) {
	    if ($ceq + 1 != @ARGV) {
              printf("%s%s\n", "\t"x(@ARGV-$sc[@ARGV]), $b) if (!$s[@ARGV]);
              ++$ceq;
	    }
            else {
              $ceq = 0;
            }
	    $cf[$last_a = $a] = 0;
          }
	  else {
            printf("%s%s\n", "\t"x($a-$sc[$a]), $b) if (!$s[$a]);
            $cf[a] = -1;
            $ceq = 0;
	  }
	}
      }
    }
  }
}

このように、comm と同じ perl スクリプトは以上のようになる。

[sed] [Awk] [Perl] [Ruby] [Python]

`join [-a file_number|-v file_number] ... [-t char] [-1 field] [-2 field] file1 file2`

この例、複数のファイルの内容を行のキー毎に結合する perl スクリプトを示す。この例では join.pl という実行権のついたファイルに記述するものとする。

入力ファイルは、キーとなるフィールドでソートされていることが前提となっているので、複数のファイルをキーの文字列の大小で並行して読み進めていけば良い。とは言え、以下のように多少繁雑になるだろう。 

#!/usr/bin/perl
sub getlinepos {
  local($f, $p) = @_;
  my($b) = (undef);
  return $b if ($p == -1);
  open(FH, $f);
  seek(FH, $p, 0) if ($p > 0);
  $b = <FH>;
  $p = (!eof(FH)) ? tell(FH) : -1;
  close(FH);
  ($b, $p);
}

sub printout {
  my($n, $M, $o, $i);
  $o = undef;
  for ($i = 0; $i < @ARGV; $i++) {
    next if (!defined $va[$i]);
    $n = $i + 1;
    $M++;
    if (!defined $o) {
      $o = $va[$i];
    }
    else {
      $o .= $, . $va[$i];
    }
    $va[$i] = undef;
  }
  print $km, $o if ($o && ($M == @ARGV || (grep { $_ == $n } @na)));
}

@na = ();
@nv = ();
$t = ' ';
$n1 = 1;
$n2 = 1;
while (@ARGV) {
  if ($ARGV[0] eq '--') { shift; last }
  elsif ($ARGV[0] eq '-a' && 1 < @ARGV) { shift; push(@na, $ARGV[0]) }
  elsif ($ARGV[0] eq '-v' && 1 < @ARGV) { shift; push(@nv, $ARGV[0]) }
  elsif ($ARGV[0] eq '-t' && 1 < @ARGV) { shift; $t = $ARGV[0] }
  elsif ($ARGV[0] eq '-1' && 1 < @ARGV) { shift; $n1 = $ARGV[0] }
  elsif ($ARGV[0] eq '-2' && 1 < @ARGV) { shift; $n2 = $ARGV[0] }
  else { last }
  shift
}

$, = $t;
$\ = "\n";

for ($a = 0; $a < @ARGV; $a++) {
  $cf[$a] = -1;
  $kn[$a] = 1;
  $va[$a] = undef;
  $po[$a] = 0;
}
$kn[0] = $n1;
$kn[1] = $n2;
$km = undef;
$c = @ARGV;
{
  while ($c) {
    for ($a = 0; $a < @ARGV; $a++) {
      $cf[$a] = -1;
      while (defined $ARGV[$a] && $cf[$a] == -1) {
	($b, $po[$a]) = getlinepos($ARGV[$a], $po[$a]);
	if (!defined $b) {
	  $ARGV[$a] = undef;
	  --$c;
	  &printout() if (!$c);
	  next;
	}
	chomp($b);
	@f = split($t, $b);
	$k = $f[$kn[$a]-1];
	$v = undef;
	for ($i = 0; $i < @f; $i++) {
	  next if ($i+1 == $kn[$a]);
	  if (!defined $v) {
	    $v = $f[$i];
	  }
	  else {
	    $v .= $, . $f[$i];
	  }
	}
	if (!defined $km) {
	  $km = $k;
	  $va[$a] = $v;
	  $cf[$last_a = $a] = 0;
	}
	else {
	  if ($km lt $k) {
	    if (grep { $_ == $last_a+1 } @nv) {
	      print $km, $va[$last_a] if ($va[$last_a]);
	      $va[$last_a] = undef;
	    }
	    print $k, $v if ((grep { $_ == $a+1 } @nv) && $last_a == $a);
	    &printout() if (!@nv);
	    $km = $k;
	    $va[$a] = $v if (!@nv);
	    $cf[$last_a = $a] = 1;
	  }
	  elsif ($km eq $k) {
	    $va[$a] = $v if (!@nv);
	    $cf[$last_a = $a] = 0;
	  }
	  else {
	    print $k, $v if ((grep { $_ == $a+1 } @na) || (grep { $_ == $a+1 } @nv));
	    $va[$a] = undef;
	    $cf[$a] = -1;
	  }
	}
      }
    }
  }
}

このように、join と同じ perl スクリプトは以上のようになる。但し、正確には単一ファイル内の重複するキーにおける挙動には対応していない。

[sed] [Awk] [Perl] [Ruby] [Python]

`split [-l line_count|-b number[k|m]] [-a suffix_length] [file [name]]`

この例、単一のファイルの内容を行数で複数のファイルに分割する perl スクリプトを示す。この例では split.pl という実行権のついたファイルに記述するものとする。

Perl では、`split` コマンドにおける '-b' オプションによるバイナリファイルとしての分割にも対応可能である。 

#!/usr/bin/perl
sub outputfilename_digit {
  local($nf) = @_;
  sprintf('%s%0*d%s', $pre, $n, $nf, $suf);
}
sub outputfilename_lower {
  local($nf) = @_;
  my($b, $d, $r, $q);
  $b = $d = 26;
  while (int($nf / $d)) {
    $d *= $b;
  }
  $d /= $b;
  $xxxxxx = '';
  do {
    $r = int($nf / $d);
    $nf -= $d * $r;
    $xxxxxx = $xxxxxx . sprintf('%c', $r + 97);
    $d = int($d / $b);
  } while ($d);
  while (length($xxxxxx) < $n) {
    $xxxxxx = sprintf('%c', 0 + 97) . $xxxxxx;
  }
  sprintf('%s%s%s', $pre, $xxxxxx, $suf);
}
sub outputfilename {
  local($nf) = @_;
  ($d ? &outputfilename_digit($nf) : &outputfilename_lower($nf));
}

%units = (
  'b'	=>            512, # blocks
  'KB'	=>           1000, # KiloBytes
  'K'	=>           1024, # KibiBytes
  'k'	=>           1024, # KibiBytes
  'MB'	=>      1000*1000, # MegaBytes
  'M'	=>      1024*1024, # MebiBytes
  'm'	=>      1024*1024, # MebiBytes
  'GB'	=> 1000*1000*1000, # GigaBytes
  'G'	=> 1024*1024*1024, # GibiBytes
  'g'	=> 1024*1024*1024, # GibiBytes
);
$k = undef;
$s = !0;
$d = undef;
$pre = undef;
$suf = undef;
$n = 2;
$lc = 1000;
$bc = 0;
$f = undef;
while (@ARGV) {
  if ($ARGV[0] eq '--') { shift; last }
  elsif ($ARGV[0] eq '-k') { $k = !0 }
  elsif ($ARGV[0] eq '--verbose') { $s = undef }
  elsif ($ARGV[0] eq '-d') { $d = !0 }
  elsif ($ARGV[0] eq '-f' && 1 < @ARGV) { shift; $pre = $ARGV[0] }
  elsif ($ARGV[0] eq '-x' && 1 < @ARGV) { shift; $suf = $ARGV[0] }
  elsif ($ARGV[0] eq '-a' && 1 < @ARGV) { shift; $n = $ARGV[0] }
  elsif ($ARGV[0] eq '-l' && 1 < @ARGV) { shift; $lc = $ARGV[0] }
  elsif ($ARGV[0] eq '-b') {
    shift @ARGV;
    if ($ARGV[0] =~ /^(\d+)(KB|MB|GB|[KMGbkmg])?$/) {
      $bc = $1;
      $bc *= $units{$2} if ($2);
    }
  }
  else { if (!$f) { $f = $ARGV[0] } else { last } }
  shift
}
$pre = $ARGV[0] if (@ARGV);
if (!$bc) {
  $nr = 0;
  open(of, '>', outputfilename($nf = 0));
  open(f, '<', $f);
  while ($_ = <f>) {
    ++$nr;
    print of $_;
    if ($nr % $lc == 0) {
      print $l if (!$s);
      $l = 0;
      close(of); open(of, '>', outputfilename(++$nf));
    }
    $l += length;
  }
  print $l if (!$s);
}
else {
  open(f, '<', $f); binmode(f);
  while (read(f, $_, $bc)) {
    close(of) if (!$nf);
    open(of, '>', outputfilename($nf++)); binmode(of);
    print of $_;
  }
}

このように、split と同じ perl スクリプトは以上のようになる。

[sed] [Awk] [Perl] [Ruby] [Python]

`csplit [-k] [-s] [-f prefix] [-n number] file arg1 ...argn`

この例、単一のファイルの内容を行のパターンや行番号で複数のファイルに分割する perl スクリプトを示す。この例では csplit.pl という実行権のついたファイルに記述するものとする。

Perl では、'seek' 等のファイル操作関数が揃っているので、なんら問題はない。 

#!/usr/bin/perl
sub outputfilename {
  local($nf) = @_;
  sprintf('%s%0*d%s', $pre, $n, $nf, $suf);
}

%p = %op = ();

sub regexp_split {
  local($rep, $reg, $ofs, $stl) = @_;
  do {
    my($ol, $np, $c, $oc) = (0, -$ofs+1, 0, 0);
    open(of, '>', outputfilename($nf++)) if (!$stl);
    $p[$c++ % $np] = tell(f) if (!($ofs > 0));
    while (<f>) {
      $op[$oc++ % $np] = $ol if (!($ofs > 0));
      print of if (!$stl);
      last if ($ol && $_ =~ /$reg/ && ($ol += length));
      $ol += length;
      $p[$c++ % $np] = tell(f) if (!($ofs > 0));
    }
    if (!($ofs > 0)) {
      if ($_) {
	seek(f, $p[($c-1-($np-1)) % $np], 0);
	$. -= $np;
	$ol = $op[($oc-1-($np-1)) % $np];
	truncate(of, $ol) if (!$stl);
      }
    }
    else {
      my $n = $ofs;
      while (--$n > 0 && ($_ = <f>)) {
	print of if (!$stl);
	$ol += length;
      }
      close(of) if (!$stl);
    }
    print $ol . "\n" if (!$s && !$stl);
  } while ($rep--);
}

sub lineno_split {
  local($rep, $ln) = @_;
  my($nl) = $ln;
  do {
    open(of, '>', outputfilename($nf++));
    my $ol = 0;
    while ($. + 1 != $nl && ($_ = <f>)) {
      print of;
      $ol += length;
    } 
    $nl += $ln;
    print $ol . "\n" if (!$s);
    close(of);
  } while ($rep--);
}

$k = undef;
$s = undef;
$d = undef;
$pre = xx;
$suf = undef;
$n = 2;
$f = '-';
while (@ARGV) {
  if ($ARGV[0] eq '--') { shift; last }
  elsif ($ARGV[0] eq '-k') { $k = !0 }
  elsif ($ARGV[0] eq '-s') { $s = !0 }
  elsif ($ARGV[0] eq '-d') { $d = !0 }
  elsif ($ARGV[0] eq '-f' && 1 < @ARGV) { shift; $pre = $ARGV[0] }
  elsif ($ARGV[0] eq '-x' && 1 < @ARGV) { shift; $suf = $ARGV[0] }
  elsif ($ARGV[0] eq '-n' && 1 < @ARGV) { shift; $n = $ARGV[0] }
  else { $f = $ARGV[0]; shift; last }
  shift
}

open(f, $f);
$nf = 0;
$ope = undef;
while (defined($ope = shift @ARGV)) {
  $rep = 0;
  if ($ARGV[0] =~ /^{(\d+)}$/) {
    $rep = $1;
    shift @ARGV
  }
  if ($ope =~ /^\/(.*)\/([-+]?\d+)?$/) {
    regexp_split($rep, $1, ($#+ == 2) ? $2 : 0, 0)
  }
  elsif ($ope =~ /^\%(.*)\%([-+]?\d+)?$/) {
    regexp_split($rep, $1, ($#+ == 2) ? $2 : 0, !0)
  }
  elsif ($ope =~ /^(\d+)$/) {
    lineno_split($rep, $1)
  }
}
if (!eof(f)) {
  open(of, '>', outputfilename($nf++));
  my $ol = 0;
  while (<f>) {
    print of;
    $ol += length;
  }
  print $ol . "\n" if (!$s);
  close(of);
}
close(f);

実は、この実装例は FreeBSD 由来の実装を多少無駄を省きつつ移植したものであり、負だけでなく零のオフセットのときも seek を必要とする、あまり美しくない実装例である。よって、負のオフセット以外は seek を必要としない制御構造に改めた実装例を以下に紹介する。 

#!/usr/bin/perl
sub outputfilename {
  local($nf) = @_;
  sprintf('%s%0*d%s', $pre, $n, $nf, $suf);
}

sub nextsplit {
  $previous_stl = $stl;
  ($ope, $rep, $stl, $ln) = (@ARGV ? shift @ARGV : undef, 0, 0, 0);
  shift @ARGV if (defined $ope && $ARGV[0] =~ /^{(\d+)}$/ && ($rep = $1));
  if ($ope =~ /^[\/\%](.*)[\/\%]([-+]?\d+)?$/) {
    ($reg, $ofs) = ($1, ($#+ == 2) ? $2 : 0);
    ($np, $c, $oc) = (-$ofs+1, 0, 0);
    $stl = $ope =~ /^\%(.*)\%([-+]?\d+)?$/;
    $ope = 1;
  }
  elsif ($ope =~ /^(\d+)$/) {
    $ln = $1;
    $ope = 2;
  }
  else {
    $ope = 0;
  }
}

%p = %op = ();

$k = undef;
$s = undef;
$d = undef;
$pre = xx;
$suf = undef;
$n = 2;
$f = '-';
while (@ARGV) {
  if ($ARGV[0] eq '--') { shift; last }
  elsif ($ARGV[0] eq '-k') { $k = !0 }
  elsif ($ARGV[0] eq '-s') { $s = !0 }
  elsif ($ARGV[0] eq '-d') { $d = !0 }
  elsif ($ARGV[0] eq '-f' && 1 < @ARGV) { shift; $pre = $ARGV[0] }
  elsif ($ARGV[0] eq '-x' && 1 < @ARGV) { shift; $suf = $ARGV[0] }
  elsif ($ARGV[0] eq '-n' && 1 < @ARGV) { shift; $n = $ARGV[0] }
  else { $f = $ARGV[0]; shift; last }
  shift
}

open(f, $f);
$nf = 0;
open(of, '>', outputfilename($nf++));
nextsplit;
$p[$c++ % ($np+1)] = tell(f) if ($ope == 1 && $ofs < 0);
$op[$oc++ % ($np+1)] = tell(of) if ($ope == 1 && $ofs < 0 && !$stl);
while (<f>) {
  $p[$c++ % ($np+1)] = tell(f) if ($ofs < 0);
  if ($ope == 1) {
    if (/$reg/) {
      if (!($ofs < 0)) {
	for (my $i=0; $i<$ofs; $i++) {
	  if (!$stl) {
	    print of;
	    $ol += length;
	  }
	  last if !($_ = <f>);
	}
      }
      if (!$stl) {
	if ($ofs < 0) {
	  truncate(of, $op[($oc-1-($np-1)) % ($np+1)]);
	  $ol -= tell(of) - $op[($oc-1-($np-1)) % ($np+1)];
	}
	print $ol . "\n" if (!$s);
	close(of); open(of, '>', outputfilename($nf++));
	$ol = 0;
      }
      if ($ofs < 0) {
	for (my $i=0; $i<$np-1; $i++) {
	  seek(f, $p[($c-1-($np-$i)) % ($np+1)], 0);
	  my $_ = <f>;
	  print of;
	  $ol += length;
	}
	$. -= $np-1;
	seek(f, $p[($c-1-($np-$np)) % ($np+1)], 0);
	if (!$stl) {
	  open(tf, '>>', outputfilename($nf-2));
	  truncate(tf, $op[($oc-1-($np-1)) % ($np+1)]);
	  close(tf);
	}
      }
      nextsplit if (!($rep--));
    }
  }
  elsif ($ope == 2) {
    if ($. % $ln == 0) {
      print $ol . "\n" if (!$s);
      close(of); open(of, '>', outputfilename($nf++));
      $ol = 0;
      nextsplit if (!($rep--));
    }
  }
  if ($previous_stl || !$stl) {
    print of;
    $ol += length;
  }
  $op[$oc++ % ($np+1)] = tell(of) if ($ope == 1 && $ofs < 0 && !$stl);
}
print $ol . "\n" if (!$s);
close(f);
close(of);

このように、csplit と同じ perl スクリプトは以上のようになる。

[sed] [Awk] [Perl] [Ruby] [Python]

`seq [-f format] [-s separator] [low [increment]] hi`

この例、GNU coreutils seq コマンドのように、単調増加する数列を生成する perl スクリプト seq.pl を示す。 

#!/usr/bin/perl
$s = "\n";
($rep, $beg, $dlt, $end) = (undef, 1, 1, undef);
while (@ARGV) {
  if ($ARGV[0] eq '--') { shift; last }
  elsif ($ARGV[0] eq '-f' && 1 < @ARGV) { shift; $f = $ARGV[0] }
  elsif ($ARGV[0] eq '-s' && 1 < @ARGV) { shift; $s = $ARGV[0] }
  else { last }
  shift
}
if (@ARGV == 1) {
  $end = $ARGV[0];
}
elsif (@ARGV == 2) {
  ($beg, $end) = ($ARGV[0], $ARGV[1]);
}
elsif (@ARGV == 3) {
  ($beg, $dlt, $end) = ($ARGV[0], $ARGV[1], $ARGV[2]);
}
else {
  die;
}
if (!defined $f) {
  $f = "%d";
  $f = "%g" if ($beg =~ /\./ || $end =~ /\./);
}
$rep = ($end - $beg)/$dlt;
printf $f, $beg if ($rep);
for (1 .. $rep) {
  printf $s . $f, $dlt*$_ + $beg;
}
print "\n" if ($rep)

このように、GNU coreutils seq と同じ perl スクリプトは以上のようになる。

[sed] [Awk] [Perl] [Ruby] [Python]

`jot [-c|-n|-r] [-b word] [-w word] [-s string] [reps [begin [end [s]]]]`

この例、BSD jot コマンドのように、単調増減する数列、乱数列、定数列を生成する perl スクリプト jot.pl を示す。 

#!/usr/bin/perl
$s = "\n";
($rep, $beg, $dlt, $end) = (undef, 1, 1, undef);
while (@ARGV) {
  if ($ARGV[0] eq '--') { shift; last }
  elsif ($ARGV[0] eq '-w' && 1 < @ARGV) { shift; $w = $ARGV[0] }
  elsif ($ARGV[0] eq '-c') { $f = "%c" }
  elsif ($ARGV[0] eq '-b' && 1 < @ARGV) { shift; $b = $ARGV[0] }
  elsif ($ARGV[0] eq '-s' && 1 < @ARGV) { shift; $s = $ARGV[0] }
  elsif ($ARGV[0] eq '-r') { $r = !0; $dlt = undef }
  else { last }
  shift
}
if (@ARGV == 1) {
  $rep = $ARGV[0]-1;
}
elsif (@ARGV == 2) {
  ($rep, $beg) = ($ARGV[0]-1, $ARGV[1]);
}
elsif (@ARGV == 3) {
  ($rep, $beg, $end) = (($ARGV[0] eq "-") ? undef : $ARGV[0]-1,
			($ARGV[1] eq "-") ? undef : $ARGV[1],
			($ARGV[2] eq "-") ? undef : $ARGV[2]);
}
elsif (@ARGV == 4) {
  ($rep, $beg, $end, $dlt) = (($ARGV[0] eq "-") ? undef : $ARGV[0]-1,
			      ($ARGV[1] eq "-") ? undef : $ARGV[1],
			      ($ARGV[2] eq "-") ? undef : $ARGV[2],
			      ($ARGV[3] eq "-") ? undef : $ARGV[3]);
}
else {
  die;
}
if (!defined $f) {
  $f = "%d";
  $f = "%g" if ($beg =~ /\./ || $end =~ /\./);
}
if ($w) {
  if ($w =~ /%/) {
    $f = $w;
  }
  else {
    $f = $w . $f;
  }
}
if ($beg =~ /^\D$/) { $beg = ord($beg) }
if ($end =~ /^\D$/) { $end = ord($end) }
if ($r) {
  srand($dlt);
  $dlt = undef;
}
if ($rep == -1) {}
elsif (defined $rep) {
  $beg = $end - $dlt*$rep if (!defined $beg);
  $end = $beg + $dlt*$rep if (!defined $end);
  $dlt = ($end - $beg)/$rep;
}
else {
  $rep = ($end - $beg)/$dlt;
}
if ($b) {
  if ($rep == -1) {
    print $b . $s while (!0);
  }
  else {
    print $b if ($rep);
    print $s . $b for (1 .. $rep);
    print "\n" if ($rep);
  }
}
elsif ($r) {
  $dlt = ($end - $beg);
  if ($rep == -1) {
    $_ = 0;
    printf $f . $s, rand($dlt) + $beg while (!0);
  }
  else {
    printf $f, rand($dlt) + $beg if ($rep);
    printf $s . $f, rand($dlt) + $beg for (1 .. $rep);
    print "\n" if ($rep);
  }
}
else {
  if ($rep == -1) {
    $_ = 0;
    printf $f . $s, $dlt*$_++ + $beg while (!0);
  }
  else {
    printf $f, $beg if ($rep);
    printf $s . $f, $dlt*$_ + $beg for (1 .. $rep);
    print "\n" if ($rep);
  }
}

オリジナルと微妙に既定の書式の扱いが異なるが、ほぼ等価な実装となっている。

このように、BSD jot と同じ perl スクリプトは以上のようになる。

[sed] [Awk] [Perl] [Ruby] [Python]

`shuf [-r [-n times]] -e arg...`, `shuf [-r [-n times]] -i 1-6`, `shuf [-r [-n times]] [filename]`

この例、GNU coreutils shuf コマンドはオプションの有無によって以下の機能を持つ。

  1. `shuf [-r [-n times]] -e arg...` - コマンドライン引数の配列をシャッフル。 '-r' のとき無限回数または '-n times' で指定回数で生成。
  2. `shuf [-r [-n times]] -i 1-6` - 1から6までの数列(数値は任意)をシャッフル。 '-r' のとき無限回数または '-n times' で指定回数で生成。
  3. `shuf [-r [-n times]] [filename]` - ファイルの行をシャッフル。 '-r' のとき無限回数または '-n times' で指定回数で生成。

ここでは、shuf.pl という実行権のついたファイルに記述するものとし、以下のように使用するものとする。

  1. `shuf.pl [-r [-n=times]] -e arg...`
  2. `shuf.pl [-r [-n=times]] -i=1-6`
  3. `shuf.pl [-r [-n=times]] [filename]`
#!/usr/bin/perl -s
use feature "say";

if (!defined $r) {
  if ($e) {
    srand();
    while (@ARGV) {
      say splice(@ARGV, int(rand(@ARGV)), 1);
    }
  }
  elsif ($i) {
    ($lo, $hi) = (1, 6);
    ($lo, $hi) = ($1, $2) if ($i =~ /(\d+)-(\d+)/);
    !($lo > $hi) || die;
    @a = ();
    for (my $i=$lo; !($hi<$i); ++$i) {
      push(@a, $i);
    }
    srand();
    while (@a) {
      say splice(@a, int(rand(@a)), 1);
    }
  }
  else {
    unshift(@ARGV, "-") unless (@ARGV);
    open($f, $ARGV[0]);
    @a = ();
    push(@a, tell($f));
    while (<$f>) {
      push(@a, tell($f));
    }
    srand();
    while (@a) {
      seek($f, splice(@a, int(rand(@a)), 1), 0);
      $b = <$f>;
      print $b;
    }
    close($f) if ($f != STDIN);
  }
}
else {
  if ($e) {
    srand();
    if (defined($n)) {
      for (1..$n) {
	say $ARGV[int(rand(@ARGV))];
      }
    }
    else {
      while (!0) {
	say $ARGV[int(rand(@ARGV))];
      }
    }
  }
  elsif ($i) {
    ($lo, $hi) = (1, 6);
    ($lo, $hi) = ($1, $2) if ($i =~ /(\d+)-(\d+)/);
    !($lo > $hi) || die;
    $a = int($hi - $lo + 1);
    srand();
    if (defined($n)) {
      for (1..$n) {
	say int(rand($a)) + $lo;
      }
    }
    else {
      while (!0) {
	say int(rand($a)) + $lo;
      }
    }
  }
  else {
    unshift(@ARGV, "-") unless (@ARGV);
    open($f, $ARGV[0]);
    @a = ();
    push(@a, tell($f));
    while (<$f>) {
      push(@a, tell($f));
    }
    srand();
    if (defined($n)) {
      for (1..$n) {
	seek($f, $a[int(rand(@a))], 0);
	$b = <$f>;
	print $b;
      }
    }
    else {
      while (!0) {
	seek($f, $a[int(rand(@a))], 0);
	$b = <$f>;
	print $b;
      }
    }
    close($f) if ($f != STDIN);
  }
}

このように、shuf と同じ perl スクリプトは以上のようになる。

[sed] [Awk] [Perl] [Ruby] [Python]

`sort [-c|-m] [-u] [-r] [-d|-f|-i]`

POSIX sort コマンドは主に以下の３つの機能がある。

  1. `sort -c file` - 一つのファイルがソート済みか否かをチェックする。
  2. `sort -m file[...]` - ソート済みの複数のファイルをソートしてマージする。
  3. `sort file[...]` - 複数のファイルをソートしてマージする。

また、'-u' オプションで重複する行の出力の抑止、'-r' オプションで逆順、'-d|-f|-i' オプションで順に、blank と alnum のみの比較、小文字を大文字と見なして比較、印字可能文字のみの比較でソートする。

さらに、'-k key' オプションでソートのキーフィールド指定、'-t char' オプションでフィールド区切りを指定できる。'-k key', '-t char' オプションの実装は多少複雑になるので、行そのものをキーとするソートの実装を示す。

`sort -c [-u] [-r] [-d|-f|-i]`

#!/usr/bin/perl
$r = 1;
while (@ARGV) {
  if ($ARGV[0] eq '--') { shift; last }
  elsif ($ARGV[0] eq '-r') { $r = -1 }
  elsif ($ARGV[0] eq '-d') { $d = !0 }
  elsif ($ARGV[0] eq '-f') { $f = !0 }
  elsif ($ARGV[0] eq '-i') { $i = !0 }
  elsif ($ARGV[0] eq '-u') { $u = !0 }
  else { last }
  shift
}

sub normalize_line {
  my($b) = @_;
  chomp $$b;
  $$b =~ s/[^[:blank:][:alnum:]]//g if ($d);
  $$b = uc($$b) if ($f);
  $$b =~ s/[^[:print:]]//g if ($i);
}
sub compare_lines {
  my($a, $b) = @_;
  normalize_line(\$a);
  normalize_line(\$b);
  ($a cmp $b)*$r;
}
{
  unshift(@ARGV, "-") unless (@ARGV);
  open(FH, $ARGV[0]);
  my $b0 = <FH>;
  while (my $b = <FH>) {
    if ((!$u && compare_lines($b0, $b) == 1) || ($u && compare_lines($b0, $b) != -1)) {
      print STDERR "sort: $ARGV[0]:$.: disorder: $_\n";
      exit 1;
    }
    $b0 = $b;
  }
  close(FH);
}

行を読み込み、前の行と比較して 1 以外なら正常終了となる。'-u' オプションのときは 0 つまり重複する行も異常終了となる。

[sed] [Awk] [Perl] [Ruby] [Python]

`sort -m [-u] [-r] [-d|-f|-i]`

#!/usr/bin/perl

sub getlinepos {
  local($f, $p) = @_;
  my($b) = (undef);
  return $b if ($p == -1);
  open(FH, $f);
  seek(FH, $p, 0) if ($p > 0);
  $b = <FH>;
  $p = (!eof(FH)) ? tell(FH) : -1;
  close(FH);
  ($b, $p);
}

$OFH = STDOUT;
$r = 1;
while (@ARGV) {
  if ($ARGV[0] eq '--') { shift; last }
  elsif ($ARGV[0] eq '-o' && 1 < @ARGV) { shift; open($OFH, '>', $ARGV[0]) }
  elsif ($ARGV[0] eq '-r') { $r = -1 }
  elsif ($ARGV[0] eq '-d') { $d = !0 }
  elsif ($ARGV[0] eq '-f') { $f = !0 }
  elsif ($ARGV[0] eq '-i') { $i = !0 }
  elsif ($ARGV[0] eq '-u') { $u = !0 }
  else { last }
  shift
}

sub normalize_line {
  my($b) = @_;
  chomp $$b;
  $$b =~ s/[^[:blank:][:alnum:]]//g if ($d);
  $$b = uc($$b) if ($f);
  $$b =~ s/[^[:print:]]//g if ($i);
}
sub compare_lines {
  my($a, $b) = @_;
  normalize_line(\$a);
  normalize_line(\$b);
  ($a cmp $b)*$r;
}
{
  my(@a, @p) = ((), ());
  for (my $a = 0; $a < @ARGV; $a++) {
    push @a, $a;
    $p[$a] = 0;
  }
  my $b0;
  while (@a > 1) {
    @a = sort {
      (my $A, undef) = getlinepos($ARGV[$a], $p[$a]);
      (my $B, undef) = getlinepos($ARGV[$b], $p[$b]);
      compare_lines($A, $B);
    } @a;
    (my $b, $p[$a[0]]) = getlinepos($ARGV[$a[0]], $p[$a[0]]);
    print $OFH ($b0=$b) if (!$u || ($u && (!defined $b0 || compare_lines($b0, $b) != 0)));
    for (my $a = 0; $a < @a; $a++) {
      splice @a, $a, 1 if ($a < @a && $p[$a[$a]] == -1);
    }
  }
  while ($p[$a[0]] != -1) {
    (my $b, $p[$a[0]]) = getlinepos($ARGV[$a[0]], $p[$a[0]]);
    print $OFH ($b0=$b) if (!$u || ($u && (!defined $b0 || compare_lines($b0, $b) != 0)));
  }
}

各ファイルはソート済みであることが前提としてあるので、すべてのファイルを並行して読み、それらの行を並び変えて先頭のファイルの行のみを出力して進めばよい。

[sed] [Awk] [Perl] [Ruby] [Python]

`sort [-r] [-u] [-d|-f|-i]`

#!/usr/bin/perl
$OFH = STDOUT;
$r = 1;
while (@ARGV) {
  if ($ARGV[0] eq '--') { shift; last }
  elsif ($ARGV[0] eq '-o' && 1 < @ARGV) { shift; open($OFH, '>', $ARGV[0]) }
  elsif ($ARGV[0] eq '-r') { $r = -1 }
  elsif ($ARGV[0] eq '-d') { $d = !0 }
  elsif ($ARGV[0] eq '-f') { $f = !0 }
  elsif ($ARGV[0] eq '-i') { $i = !0 }
  elsif ($ARGV[0] eq '-u') { $u = !0 }
  else { last }
  shift
}

sub normalize_line {
  my($b) = @_;
  chomp $$b;
  $$b =~ s/[^[:blank:][:alnum:]]//g if ($d);
  $$b = uc($$b) if ($f);
  $$b =~ s/[^[:print:]]//g if ($i);
}
sub compare_lines {
  my($a, $b) = @_;
  normalize_line(\$a);
  normalize_line(\$b);
  ($a cmp $b)*$r;
}

my @file_position_list = ();

sub file_position_getline {
  my($file_position) = @_;
  open(FH, '<', ${$$file_position{name}});
  seek(FH, $$file_position{position}, 0);
  my $b = <FH>;
  close(FH);
  return $b;
}
{
  local $a = 0;
  while ($a < @ARGV) {
    open(FH, '<', $ARGV[$a]);
    do {
      push(@file_position_list,
	   {
	     name => \$ARGV[$a],
	     position => tell(FH),
	   });
    } while (<FH>);
    close(FH);
    ++$a;
  }
  @file_position_list = sort {
    my $A = file_position_getline($a);
    my $B = file_position_getline($b);
    compare_lines($A, $B);
  } @file_position_list;
  my $b0;
  for my $file_position (@file_position_list) {
    my $b = file_position_getline($file_position);
    print $OFH ($b0=$b) if (!$u || ($u && (!defined $b0 || compare_lines($b0, $b) != 0)));
  }
}

各ファイルの行頭のファイルポジションをファイル名とのペアで保持しておき、それを行の比較でソートすればよい。

このように、sort (但し、キーフィールド指定なし) と同じ perl スクリプトは以上のようになる。

[sed] [Awk] [Perl] [Ruby] [Python]

参考文献

  1. Perl のコアドキュメント
Written by Taiji Yamada <taiji@aihara.co.jp>