1. 文字列に含まれるURLを自動的にリンク化する
2. 文字列から不要なHTMLタグを取り除く
3. 重複しない乱数を生成する
4. 条件に合わない要素を配列から取り除く
5. プロキシを超えてリモートホストを特定する
6. 美味しいクッキーの焼き方・食べ方
7. 安全に排他処理を行う

$text =~ s/([^\=\"]|^)((http|ftp):\/\/[\w\.\/\~\-\+\:\;\?\=\&\%\#]+)/$1<a href=\"$2\">$2<\/a>/ig ;

文字列中にURL（http://、ftp://で始まるもの）を見つけたら、それを自動的にHTMLのリンクとして書き直す処理です。チャット等で他人にサイトを教える際に、URLを書くだけでリンクを作れて便利です。

実際にはWEBチャットはフレームを切ってその中にログが表示されていることが多いため、単純にリンクを記述するとログのフレームの中にリンク先を展開してしまいます。変換後の書式に「TARGET="_blank"」あるいは「TARGET="_top"」を追加するのがベターでしょう。

なお、パターンマッチの最初で「ダブルクオート以外」を指定しているのは、もし最初から「A HREF="http://・・・"」と書いてあった場合に二重展開してしまうのを防ぐためです。

sub tagremover{
    local (*_ , $VALIDTAGS) = @_ ;
    s/\036//ig ;
    s/<(\/?($VALIDTAGS)[>\s])/\036$1/ig ;
    s/<[^>]*>//ig ;
    s/\036/</ig ;
}

掲示板などで、使ってもらっては困るHTMLタグを発言から取り除く場合などに使います。引数*_に変換元の文字列の型グロブ、$VALIDTAGSに「残す」タグを「|」で区切って並べた文字列を渡します。具体的には、

&tagremover(*text, 'a|b|font|h6') ;

といった感じに呼び出します。「$textからa、b、font、h6以外のタグを取り除け」という意味になります。

単純に考えれば、任意のタグを削除する処理

s/<\/?タグ名[^<>]*>//ig ;

を、取り除きたいタグの数だけ並べれば目的は達成されますが、パターンマッチをそれだけの数繰り返すことになり効率がよくありません。また、取り除くべきタグの見落としがあるかもしれませんし、もし今後新たなタグが使われるようになったりすると、その都度対処する必要が出てきます。ですので、逆を考えて「必要なタグだけを残す」という処理にしてあります。この方法であれば、どれだけ残すタグの数が増えても４回のパターンマッチで処理することができます。

なお、上のスクリプト中に出てくる「\036」は、一般的なテキスト中にはほぼ確実に出現しない文字ですので、「残すべきタグのマーキング」として使われています（旧ラクダ本中のサンプルでも使われてましたね）。

srand($$) ;
do {
    $newid = int(rand(9999))+1 ;
}
while (grep(/^$newid$/ , @id)) ;
push (@id, $newid) ;

@idに含まれる数値と重複しない乱数$newidを生成します。
まずsrandにプロセス番号を渡して乱数を初期化し、do〜whileループで、$newidが@idに含まれないユニークな数となるまで生成を繰り返します

注意しなければならないのは、grepのパターンマッチで先頭＆末尾一致のチェック（^と$）を怠ると、「10」と「2108」を混同してしまったりする点です。要は完全な「数値」としてIDが比較されなければなりません。

@vector = grep(!/条件/ , @vector) ;

配列@vectorから、条件に合わない要素を取り除きます。

例えば掲示板で「指定された記事をログファイルから削除したい」という様な場合に便利です。
具体的には、ログファイルの書式が「ID \t タイトル \t 本文」という風であるとして、複数のログファイル@logfilenamelistの中から該当のIDの記事を削除して更新する場合、

foreach $filename(@logfilenamelist){
    open (FILE, "$filename") ;
    @temp = <FILE> ;
    close (FILE) ;
    
    if (grep(/^$id\t/, @temp)){
        open (FILE, ">$filename") ;
        print FILE grep(!/^$id\t/, @temp) ;
        close (FILE) ;
        last ;
    }
}

という具合に書けます。

sub getremotehost{
    my ($isproxy) = '';
    #---- check X_FORWARDED_FOR and FORWARDED
    local ($_) =    $ENV{'HTTP_X_FORWARDED_FOR'} or 
                    $ENV{'HTTP_FORWARDED'} and
                    split(/\s/, $ENV{'HTTP_FORWARDED'}) and
                    pop(@_);
    
    #---- use REMOTE_HOST or REMOTE_ADDR if cannnot get
    $_ = $ENV{'REMOTE_HOST'} or $ENV{'REMOTE_ADDR'} unless $_;
    
    #---- try to convert IP-type address to hostname
    if (/(\d+)\.(\d+)\.(\d+)\.(\d+)/){
        ($_) = (gethostbyaddr(pack('C4',$1,$2,$3,$4),2) or "$1.$2.$3.$4");
    }
    
    #---- check via proxy
       if ($ENV{'HTTP_X_FORWARDED_FOR'} or 
           $ENV{'HTTP_FORWARDED'} or 
           $ENV{'HTTP_PROXY_CONNECTION'} or 
           $ENV{'HTTP_VIA'} or 
           $ENV{'HTTP_USER_AGENT'} =~ /via|squid|delegate|httpd|proxy|cache/i){
        $isproxy = '(PROXY)';
    }
    
    return $_ . $isproxy ;
}

環境変数REMOTE_HOSTには「どこからアクセスしているか」という情報が保持されています。とかく匿名性が高くなりがちなインターネット上で個人を特定する数少ない（そして容易な）手段のひとつとして、「あなたは××というプロバイダからアクセスしてますね」といった具合によく用いられています（有体に言えば、掲示板やチャット等で悪さをしにくいようにというわけです）。

ところが、プロキシサーバを介してアクセスされると（意味の分からない人は「中継地点を挟んで」くらいに読み替えておいて下さい）、REMOTE_HOSTの値は正しいローカルホストではなくそのプロキシサーバの名前になってしまいます。そこで、プロキシの向こうにある正しいローカルホストの情報を取得しようとするのがこの処理です。

具体的には、プロキシを介してアクセスしている場合、環境変数HTTP_FORWARDEDもしくはHTTP_X_FORWARDED_FORに「プロキシへの接続元」のホストの情報が入っています。HTTP_X_FORWARDEDにはそのまま、HTTP_FORWARDEDには「by プロキシ for ホスト」という形式で入っていますので、それらを取り出し、IPアドレスの形式（***.***.***.***）ならばgethostbyaddr関数によってホスト名を取得します。そうやって「プロキシの先のホスト名」が取得できた場合はそれを、取得できなかった場合はREMOTE_HOSTをホスト名として返しています。

なお変数 $isproxy は、プロキシを介してアクセスはしてるんだけどどうしても元ホストが取得できなかった場合に「ホストは特定できなかったけどプロキシ介してることは分かるんだぞ！」という悔し紛れの宣言を行うために設定してあります（笑）。具体的には、そういった場合にはREMOTE_HOSTの後ろに （PROXY) という表示が付け加えられます。

$cookie_name  クッキーの名前
$limit        クッキーの賞味期限。日数で指定
%cookies      クッキーに焼きたい材料が入っているハッシュ

sub set_cookie{
    my ($cookie_name, $limit, %cookies) = @_ ;
    return '' unless $cookie_name ;
    
    my ($youbi, $month, $date_gmt, $cookie) ;
    my ($secg,$ming,$hourg,$mdayg,$mong,$yearg,$wdayg) = gmtime(time() + $limit * 86400);
    $yearg += 1900 ; #---- 2000年は「100」で帰ってくる
    $yearg = "0$yearg" if ($yearg < 10);
    $secg  = "0$secg" if ($secg < 10);
    $ming  = "0$ming" if ($ming < 10);
    $hourg = "0$hourg" if ($hourg < 10);
    $mdayg = "0$mdayg" if ($mdayg < 10);
    $youbi = ('Sunday','Monday','Tuesday','Wednesday','Thursday','Friday','Saturday')[$wdayg] ;
    $month = ('Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep','Oct','Nov','Dec')[$mong];
    $date_gmt = "$youbi, $mdayg\-$month\-$yearg $hourg:$ming:$secg GMT";
    
    if (%cookies) {
        for (sort keys %cookies){
            $cookie .= "$_\:$cookies{$_}," ;
        }
        chop ($cookie) ;
        print "Set-Cookie: $cookie_name=$cookie; expires=$date_gmt\n";
    }
    else {
        print "Set-Cookie: $cookie_name=; expires=$date_gmt\n";
    }
    return $date_gmt;
}

sub get_cookie{
    my ($cookie_name) = shift ;
    my (%cookies, $name, $value) ;
    
    foreach (split(/;/,$ENV{'HTTP_COOKIE'})) {
        ($name, $value) = split(/=/);
        $name =~ s/ //g;
        last if $name eq $cookie_name ;
    }
    
    foreach (split(/,/,$value)) {
        ($name , $value) = split(/:/);
        $cookies{$name} = $value;
    }
    return %cookies ;
}

[焼く]

    $cookies{'name'} = 'inuro' ;
    $cookies{'age'} = '25' ;
    $cookie_name = 'test' ;
    &set_cookie($cookie_name, 30, %cookies) ;

[食べる]

    $cookie_name = "test" ;
    %cookies = &get_cookie($cookie_name) ;

クッキーの焼き方自体はカンタンで、決まった形式（" Set-Cookie: クッキー名=内容; expires=賞味期限 " という形式）を標準出力に通してやるだけであとはブラウザが自動的に焼き上げてくれます。
実際には「決まった形式」に整えるために色々面倒な処理が必用ですが、上のレシピはそれらの処理をラップしてくれるので、焼く時にはクッキーの名前と有効期限と焼きたい内容を渡すだけ、食べる時は取得したいクッキーの名前を渡すだけでOKです。

ただし気を付けなければならないのは、一般にCGIからブラウザに出力する場合「Content-type: text/html\n\n」等といったヘッダを冒頭に出力しますが、この一文が出力されると（正確にはヘッダの空行、つまり二つ目の\nが出力されると）、それ以降の出力はすべてテキスト（HTML）だと見なされてしまうためクッキーを焼くことができない、ということです。
よって、set_cookieを呼び出す場合は必ずヘッダの出力の前に。几帳面に処理するなら、

    print "Content-type: text/html\n" ;
    &set_cookie ;
    print "\n" ;

という具合にヘッダに含めて呼び出すのが良いでしょう。

sub lock{
    my ($lockfile, $retry, $expiration) = @_ ;
    my ($tmpfile, $count, $pid_of_lockfile) ;
    
    $lockfile or return (1) ;
    $retry or $retry = 5 ;
    $expiration or $expiration = 30 ;
    
    $lockfile   =~ /[^\/]+$/;
    $tmpfile    = "$`$$.lock";
    open (TMP, ">$tmpfile") or return (2);
    print TMP $$ ;
    close(TMP) ;
    
    for ($count = 0 ; $count < $retry ; $count++){
        last unless -e $lockfile ;
        sleep(1) ;
    }
    
    if (-e $lockfile){
        if ((time - (stat($lockfile))[9]) > $expiration){
            unlink ($lockfile) ;
        }
        else{
            -e $tmpfile and unlink ($tmpfile) ;
            return (3) ;
        }
    }
    
    if (rename ($tmpfile, $lockfile)){
        open (TMP, $lockfile) or return (1);
        $pid_of_lockfile = <TMP> ;
        close(TMP) ;
        $pid_of_lockfile ne $$ and return (4) ;
    }
    else{
        -e $tmpfile and unlink ($tmpfile) ;
        return (4) ;
    }
    
    return (0) ;
}


sub unlock{
    my ($lockfile) = @_ ;
    my ($pid_of_lockfile) ;
    
    $lockfile or return (1);
    
    open (TMP, $lockfile) or return (1);
    $pid_of_lockfile = <TMP> ;
    close(TMP) ;
    
    $pid_of_lockfile ne $$ and return (4) ;
    unlink($lockfile) or return (5) ;
	return (0) ;
}

    $lockfile       ロックファイルの名前。書き込み可能なディレクトリを指定する必要あり
    $retry          アンロック待ちする時間（単位は秒。デフォルトは10秒）
    $expiration     ロックファイルの「有効期限」（単位は秒。デフォルトは30秒）

    0   ロック（あるいはアンロック）が無事成功。
    1   テンポラリファイル又はロックファイルを読み取り用にオープンできない。存在していないかも？
    2   テンポラリファイルを書き出し用にオープンできない。ロックファイルを指定したディレクトリはちゃんと書き込み可能になってるかい？
    3   アンロック待ちでタイムアウト。どうやらサーバが凄く混んでるようだ。
    4   ほんのちょっとのタイミングのズレでロックに失敗した模様。何てツイてないんだ。
    5   アンロック時にロックファイルを削除できない（何故だ？？）。

排他処理、いわゆる「ファイルロック」というやつは、不特定多数がどんなタイミングで呼び出すか分からないCGIには必須の処理です。

ここに紹介した処理では、「ユニークな名前で生成したテンポラリファイルを、共通の名前のロックファイルにリネームする」ことでロックを実現しています。加えて、「リネームしたファイルがちゃんと自分が生成したファイルか」ということを確認することで確実な排他処理を保証しています（失敗する可能性が低い、ということではなく「ロックした」と誤認することが無い、ということ）。