perlの覚書

2007/5/22

print "Hello, Perl World!";

上の一行をたとえばhello.plに記述し, 実行する

$ perl hello.pl

あるいは直接全てをコマンドライン上から

$ perl -e 'print "Hello, Perl World!"'

結果はいずれもHello, Perl World!と表示される。

配列

#!/bin/perl
# 配列の初期設定の方法
@value = (1, 2, 3);
#$value[0]=1;
#$value[1]=2;
#$value[2]=3;
#に等しい。
$value[3]=$value[0]+$value[1]+$value[2];
print "$value[3]\n";

# 連想配列(ハッシュ)
#   Cでは理解できない。
$color{"red"}="赤";
$color{"blue"}="青";
$color{"yellow"}="黄";

$iro="red";
print "$color{$iro}\n";

# 連想ハッシュは次のようにも定義できる。
%color=("red", "赤", "blue", "青", "yellow", "黄");

$iro="red";
print "$color{$iro}\n";

実行結果

$ perl array.pl
6
赤
赤

配列の配列

$a[0] = 'a';
$a[1] = 'b';

print $#a."\n"; # 配列の最大値

# bの0番目にaを配列として入れたい。
# $b[0] = [ @a ];  # []を使うことに注意
@b[0] = @a;

# bの0番目に格納されている配列の0番目を
# 取り出したい。
@c = @{$b[0]};
print $c[0];
# あるいは
print $b[0][0];

# 参考
#   http://perldoc.jp/docs/perl/5.6.1/perllol.pod
#   http://www.att.or.jp/perl/pdsc/pdsc0ext.html
#   http://takenaka-akio.cool.ne.jp/doc/perl_kiso/reference3.html

コマンドラインの引数

sum.pl

#!/bin/perl

#大文字であることに注意。
print $ARGV[0] + $ARGV[1];
print "\n";

実行結果

$ perl sum.pl 3 4
7
$

標準入力からの入力

read.pl

#/bin/perl

$len = read(STDIN, $value, 4);
print "$value\n";
print "$len文字読みました。\n";

exit 0;

実行結果

$ perl read.pl
123456
1234
4文字読みました。
$ perl read.pl
12
3
12
3
4文字読みました。

改行ではなく, 4文字読むまで続ける。改行も1文字にカウントされる。

関数

function.pl

#!/bin/perl

# 引数, 返り値なし
sub print_hello { #subで関数宣言
   print "hello\n";
}

# 返り値が一個
#   引数は配列@_に入っている。
sub sum{
   local(@value) = @_;    # ローカル変数である宣言と代入。
   $value[0] + $value[1]; # 最後に評価された値が返される。
                          # returnも使える。
   # $_[0]+$_[1]; でもOK
}

# リストを返す。
#   xとyを与えて, その和と差を返す。
sub trans {
   local($x,$y) = @_;
   local($w)=$x+$y;
   local($z)=$x-$y;
   ($w,$z); #このようにすると, リストで返すことが出来る。
}

&print_hello; #引数, 返り値なし。関数は&(function_name)で呼び出す。
print &sum;(3, 4); #引数は関数名の後に, ()で括って渡す。
@value = &trans(10, 20);
print "\n";
print "w=$value[0], z=$value[1]\n";

実行結果

$ perl function.pl
hello
7
w=30, z=-10
$

関数のリファレンス

#!/bin/perl
$a = \&foo;
print $a->(1);
    # 2と表示される。

sub foo() {
    $_ = shift;
    return $_+1;
}

foreach

foreach $x (@y){
   $xに関する処理
}

$xに@yの要素が次々に入り処理される。$xを省略したときは, $_が使われる。

文字列の置換

次のような構文を使う。

置換したい文字列を含む文字列 =~ s/置換される文字列/置換する文字列/g;

レファレンス

もっとも基本的な形

#!/bin/perl
$a = 'b';
$b = 1;
print $$a;
   # 1と表示される。

関数で使用する場合

#!/bin/perl
$a = 5;

&foo(\$a);
print ($a."\n");
   # aが加算され, 6と表示される。

&hoge(\$a);
print ($a."\n");
   # aの実体には影響がないので
   # 6と表示される。

sub foo() {
   my ($v) = @_;
      # 引数は$aのリファレンスである。
   $$v = $$v + 1;
      # $$vの$aの実体
}

sub hoge() {
   my ($v) = @_;
      # 引数は$aのリファレンスである。
   $v = $v+1;
      # 意味のない危険な演算
}

関数の返り値にリファレンスを使用。

#!/bin/perl
$a = 5;

# $bでリファレンスを受け取る
$b = &foo(\$a); 
print $b."\n";
   # リファレンスそのものを表示
   # SCALAR(0x1002f9b8)などと表示される。
print $$b."\n";
   # リファレンスの中身を表示
   # 6と表示される。
print $a."\n";
   # 6と表示される。

sub foo() {
   local($c) = @_;

   $$c = $$c + 1;  # $cは$aのリファレンス

   return $c; # リファレンスを返す。
}

関数の引数はリファレンス

#!/bin/perl

$a = 5;

sub ok_a() {
   $_[0] = $_[0]+1;
      # 引数配列"_"はリファレンス
}
&ok_a($a);
print $a."\n";
   # 6と表示される。

sub ok_b() {
   my ($b) = @_;
   $_[0] = $b + 1;
}
&ok_b($a);
print $a."\n";
   # 7と表示される。

# shiftを使うとだめ
sub ng_a() {
   $b = shift;
   $_[0] = $b+1;
}
&ng_a($a);
print $a."\n";
   # 7と表示される。

# @_そのものを変えてはだめ。
sub ng_b() {
   my ($b) = @_;
   @_ = ($b+1);
      # @_そのものの定義が変わるのでだめ
}
&ng_b($a);
print $a."\n";
   # 7と表示される。

連想配列とともに使う場合

#!/bin/perl

%color = ('yellow'=>'黄色', 'red'=>'赤');
# 通常の連想配列での表示
print $color{'yellow'}."\n";

# hash referenceで使える"->"
$a = \%color;
print $a->{'yellow'}."\n";

# 関数でハッシュのリファレンスを受け取る
sub print_color() {
   my ($colortable) = @_;
   print $colortable->{'yellow'}."\n";
}
&print_color(\%color);

# ややこしい書き方。
print ${%{$a}}{'yellow'}."\n";

配列とともに使う場合

#!/bin/perl

@a = ('x', 'y', 'z');
$b = \@a;
print $b->[1]."\n";
   # yと表示される。

tie

tieする変数というか構造というか

tiuecho.pl

#!/bin/perl

# tieして変数に代入すると, 
# それを出力する。

package tiuecho;

# tieで変数と結合
# newと一緒
sub TIESCALAR {
    my ($class) = @_;  # おまじない
    my $self = { };    # おまじない

    bless $self, $class;  # おまじない
    return $self;
} # /TIESCALAR

# tie変数に値が代入されたら出力
sub STORE {
    my ($self, $value) = @_;
    print($value."\n");
} # /STORE

1;

tieで呼ばれるとTIESCALARが実行され, tieされた変数に代入が行われるとSTOREが実行される。その他にも参照が行われたときなどいくつかの場合が規定されている。

利用例

tiuecho_test.pl

#!/bin/perl

require 'tiuecho.pl';

# tiuechoはクラス?です。
tie my $foo, tiuecho;

$foo = 'Hello, world!';
# tiuechoにtieされた変数に
# 代入を行うと, それが出力される。

実行結果

$ perl tiuecho_test.pl
Hello, world!
$

ファイル操作(open, close, $_)

ファイルから一行ずつ取り出し, それを表示する。

#!/bin/perl

if ($#ARGV != 0) { #コマンドラインからの引数が1個でなければ
                   # $#には配列の最後の数値が入る。
   print STDERR 'perl cat.pl <filename>';
   print "\n";
   exit 1;
}
   
open(FP, $ARGV[0]); #$ARGV[0]のファイルを開け, FPでやり取りする。
while (( $_ = <FP> ) ne '') { #<FP>でこのファイルディスクリプタから
                              #1行取り出す。
   print; #printは引数を省略すると, $_を出力する。
}  #Cと違い たとえ1行でも{}は必要らしい。
close(FP);
exit 0;

ハッシュ/配列を保存

ハッシュや配列をそのままファイルに保存し, 後で読み取り利用する。use Storableを使用し, 関数storeで保存, 関数retrieveで取り出す。

保存するファイル, save_hash.pl。

#!/bin/perl

# こちらでハッシュを作成し, 
# load_hash.plで取り出してみてください。

use Storable;

my %hash;

# 普通のハッシュ
$hash{'あ'} = 'い';

# 要素がさらにハッシュ
%{$hash{'う'}} = ('え', 'お', 'か', 'き');

# 要素がハッシュでその要素もハッシュ
%{${%{$hash{'く'}}}{'け'}} = ();
$g = \%{$hash{'く'}{'け'}};
$g->{'こ'} = 'さ';

store \%hash, 'hash.cache';
exit;

取り出して利用するファイル, load_hash.pl。

#!/bin/perl

# もとになるハッシュは
# save_hash.plで作成, 保存しています。

use Storable;
$refhash = retrieve('hash.cache');

print($refhash->{'あ'}."\n");
print($refhash->{'う'}->{'え'}."\n");
print($refhash->{'く'}->{'け'}->{'こ'}."\n");

二つを実行した結果。

$ perl save_hash.pl
$ perl load_hash.pl
い
お
さ
$

例えば, 辞書から辞書ツリーを構築して利用するプログラムを作成するとき, 辞書ツリーをこの方法で保存すれば, 保存したファイルを利用することで, 辞書ツリーを実行の都度作り直さずに済む。

参考: http://perldoc.jp/docs/modules/Storable-2.05/Storable.pod

chop

行末の文字を取り除く。

$ perl -e '$x="123456";chop($x);print "$x";'
12345$
$ perl -e '$x="123456";print chop($x);'
6$
$ perl -e '$_="123456";chop;print;'
12345$

通常は文字列の改行を取り除くのに使われるようだ。

push

配列に新しい要素を追加する。

$ perl -e '@x=(1,2,3);print "@x";push(x,4);print "@x";'
1 2 31 2 3 4$
$ perl -e '@x=(1,2,3);print "@x";push(@x,4);print "@x";'
1 2 31 2 3 4$

sort

文字列順に並び替える。

$ perl -e '@x=(1,5,12);@x=sort @x;print "@x"';
1 12 5$
$ perl -e '@x=('a','c','b','ab');@x=sort(@x);print "@x";'
a ab b c$

文字ではなく, 数字的に比較した場合は, どのように比較するのかを示した比較ルーチンを作成し, これを指定する。

sort.pl

#!/bin/perl
@x = (1, 12, 34, 24, 3);
@y = sort @x;
print "@y\n"; #今までの場合

@y = sort by_number @x;
print "@y\n";

#比較ルーチン by_fooというように名をつけることが多いようだ。
sub by_number {
   if ($a < $b) { #ここで$aと$bは比較ルーチン特有の変数である。
                  #sort内部で比較される二つの量を表す。
      -1;
   } elsif ($a == $b) {
      0;
   } else { # i.e. ($a > $b)
      1;
   }
}

# by_numberは演算子<=>を使って, 
# sub by_number {
#   $a <=> $b;
# }
# としても同じ効果が得られる。

実行結果

$ perl sort.pl
1 12 24 3 34
1 3 12 24 34

split

文字列の分割

配列 = split(/分割の区切りとなる文字列(正規表現)/,分割する文字列);

Grepもどき

正規表現によるマッチングの具体例。簡単のため, マッチングする文字列はソースコードに埋め込まれている。

#!/bin/perl

foreach $file (@ARGV) {
   open(FP, $file); #$ARGV[0]のファイルを開け, FPでやり取りする。
   while (( $_ =  ) ne '') { #でこのファイルディスクリプタから
                                 #1行取り出す。
      if ($_ =~ /^(テスト)/) { # 正規表現は//で囲む。
         print;
         # 下2行のコメントをはずすと "テスト"で始まる次の行も表示
         # $_ = ;
         # print;
      }
   }
}
exit 0;

実行結果

$ cat test.txt
どうも
日本語の
テストですが,
どうでしょう。
$ perl grep.pl test.txt
テストですが,
$

ブラウザのようなもの

使い方 : perl ncat.pl http://<domain>/<path>

#!/bin/perl
# 20020828

# http://username:password@domain:port/path; 予定

use Socket;

foreach (@ARGV) {
#    $_ =~ s/^http:\/\/(\1)\/?.*/$1/g;
    $_ =~ s/http:\/\///g;
    $j = index($_, '/');
    if ($j >= 0 ) {
	$addr = substr($_, 0, $j-1);
	$path = substr($_, $j);
    } else {
	$addr = $_;
	$path = '/';
    }

    &getWebPage($_, $path, 80);
    # print "$addr get $path \n";
}

exit;

sub getWebPage(){
    local ( $addr, $path, $port ) = @_;
    local ($protocol_num, $inetaddr, $packaddr);
    local *S;

    # プロトコル番号取得
    $protocol_num = getprotobyname('tcp');
    socket(S, &AF_INET, &SOCK_STREAM, $protocol_num);

    # Connect
    $inetaddr = Socket::inet_aton( $addr ) || exit 0;
    $packaddr = Socket::sockaddr_in( $port, $inetaddr );
    connect( S, $packaddr ) || (close(S), exit 0);

    # バッファリングを無効に
    $_ = select(S); $| = 1; select($_);
    
    print S "GET $path HTTP/1.0\n\n";
    print while <S>
    
    shutdown( S, 2 );
    close(S);

    return 0;
}

より簡単なバージョン

より簡単のため, URLをソースコードに埋め込んである。

#!/bin/perl
# lang="ja"   charset="Shift-JIS"
use Socket;

# 目的のドメインとポート番号
$addr = 'http://www.example.com';
$port = 80;

# プロトコル番号取得
$protocol_num = getprotobyname('tcp');
socket(S, &AF_INET, &SOCK_STREAM, $protocol_num);

# 接続
$inetaddr = Socket::inet_aton( $addr ) || exit 0;
$packaddr = Socket::sockaddr_in( $port, $inetaddr );
connect( S, $packaddr ) || (close(S), exit 0);

# バッファリングを無効に
$_ = select(S); $| = 1; select($_);

# HTTPでの通信
print S "GET /index.html HTTP/1.0\n\n";
print while <S>;

# 通信とプログラムの終了
shutdown( S, 2 );
close(S);
exit 0;

HTMLタグを除去する

とても簡単に作ったバージョン。わかりやすいが, タグが複数行にわたっている場合などはうまく動作しない。

#!/bin/perl
#
# 使い方
#   perl striphtml1.pl < <html-file>
#
# 注意
#   結果は, 標準出力に出されます。
#
# 2005/4/12
#   至極単純にHTMLタグを取り除く
#   似たようなものがあるだろうが, 自分で作ってみたかった。
###

while(<>){
     print(striphtml($_));
}

# striphtml
# タグが複数行にわたった場合などはいくつかの場合に対応できない。
sub striphtml(){
     my ($inStr) = @_;

     $_ = $inStr;
     s/<[^>]*>//g;

     return $_;
}

かなり改良したバージョン。複数行になるタグ, HTMLのコメント, 値の中でタグが出てきても平気なはず。その分複雑。

#!/bin/perl
#
# 使い方
#   perl striphtml.pl < <html-file>
#
# 注意
#   結果は, 標準出力に出されます。
#
# 2005/5/8
#   単純なバージョンを改良
###

my %strip_html_global_vars;

# スタック用の設定
$strip_html_global_vars{'STACK_INDEX'} = -1;
$strip_html_global_vars{'STACK'} = (); # この書き方は正しい..?

while(<>){
    print(&striphtml($_));
}

# striphtml
#
# タグが複数行にわたっている場合, 値を指定するダブルクォーテーションと
# その中に>がある場合, コメントの場合を考慮
#
# 状態は擬似スタックにつんで記録する。
sub striphtml(){
    # ",<,>の区切り文字を見つける。
    my ($inStr) = @_;
    my ($s, $t, $p, $retStr);

    $retStr = '';
    $t = $inStr;
    # $j = 0;

    while($t ne ''){   # 与えられた文字列がなくなるまで
        # $j++;
        # exit if($j>10);
        $s = $t;
        $p = &show_stack();
        # この条件分岐も関数に分けていくべきなんだろうなぁ...
        # print $p."\n".$t;
        if($p eq 'NO_STACKED'){
            $s .= '<';      # 番兵
            $t .= '<';      # 番兵
            $s =~ s/<.*//g;      # 最初の<以降をすべて消す。
            # print 's='.$s;
            $t =~ s/^[^<]*<//;   # <以降, <も消す。

            $retStr .= $s;
            if($t =~ /^!--/){
                &push_stack('HTML_COMMENT');
            } elsif ($t ne '') {
                &push_stack('HTML_TAG');
            }
            $t =~ s/<$//;   # 番兵を取り去る
        } elsif ($p eq 'HTML_TAG'){  # ------------------ html_tagの場合
            # タグの終わりか, 値の設定に入る
            $t =~ s/^[^'">]*//;
            # 全部消えたら, '">はなかったということ。
            next if($t eq '');
            if($t =~ /^'/) {
                &push_stack('VAR_STRING1');
            } elsif($t =~ /^"/ ) {
                &push_stack('VAR_STRING');
            } elsif($t =~ /^>/ ) {
                &pop_stack();
            }
            $t =~ s/^['">]//; # 判別の要素となったものをすえる
        } elsif ($p eq 'HTML_COMMENT') { # -------------- commentの場合
            $t .= '-->';   # 番兵
            $t =~ s/^[\s\S]*?-->//;    # ものぐさマッチ。使えない場合は...?
            &pop_stack() if($t ne '');  # -->があったということだ
            $t =~ s/-->$//;   # 番兵を取り去る
        } elsif ($p eq 'VAR_STRING') { # ---------------- VAR_STINGの場合
            $t .= '"';     # 番兵
            $t =~ s/^[^"]*"//;
            &pop_stack() if($t ne '');
            $t =~ s/"$//;   # 番兵を取り去る
        } elsif ($p eq 'VAR_STRING1') { # ---------------- VAR_STING1の場合
            # こうやって増やすのはあまり好ましくない。
            $t .= "'";     # 番兵
            $t =~ s/^[^']*'//;
            &pop_stack() if($t ne '');
            $t =~ s/'$//;   # 番兵を取り去る
        } else {
            die "unknown parameters\n";
        }
    }

    return $retStr;
} # striphtml


# スタック関係の関数など
sub pop_stack(){
    $strip_html_global_vars{'STACK_INDEX'}--;
    # こんな場合はないはずだが, 念のため。
    # エラーにした方がよいかもしれない。
    if($strip_html_global_vars{'STACK_INDEX'}<-1){
        $strip_html_global_vars{'STACK_INDEX'} = -1;
    }
}

sub push_stack(){
    my ($stackValue) = @_;
    my($i);
    $strip_html_global_vars{'STACK_INDEX'}++;
    $i = $strip_html_global_vars{'STACK_INDEX'};
    $strip_html_global_vars{'STACK'}[$i] = $stackValue;
}

# スタックのてっぺんを覗く
sub show_stack(){
    if($strip_html_global_vars{'STACK_INDEX'}<0) {
        return 'NO_STACKED';
    }
    return $strip_html_global_vars{'STACK'}[$strip_html_global_vars{'STACK_INDEX'}];
}

URLDecode

URLデコードする。CGIなどで使う。POSTメソッドの場合は今回は考えていない。

sub getGetRequest(){
    local ($s,@t,$name,%r);
    $s = $ENV{QUERY_STRING};
    @t = split(/&/,$s);
    foreach (@t) {
        $name = $_;
        $name =~ s/=.*$//;
        s/^.*=//;
        s/\+/ /g;
        s/%([A-Za-z0-9][A-Za-z0-9])/pack('H2',$1)/ge;
        $r{$name} = $_;
    }
    return %r;
}