今日のMENTA、2回目

2008年12月 4日
のぶりん
 | コメント(0) | トラックバック(0) 今日のMENTA、2回目

zipファイルは、lang_perl_MENTA_tags_release-0.09-r25814.zipになっていました。

マニュアルとデモとが分かれています。
マニュアルのほうには、実際のサーバーで使うためのアップロード方法だけでなく、ディレクトリ構造も紹介されています。
デモのほうは、（個人的に必須な）Session管理のデモもありました。


そろそろ何か作りたくなってきました。

今見るととても恥ずかしいですが、Perlを覚えたての頃に作った、HTMLの出力にこだわったチャットがあります。
今となっては、スタイルシートでレイアウトするのは当たり前ですが、この当時はスタイルシートもブラウザの実装が中途半端で使う人も少なかったんじゃないかと思います。

まあ、そんな遺物をMENTAを使って書き直してみようかなと、ふと思いました。
使い道があるのかと訊かれれば、まずないでしょうが。
そんな昔に書いたソースコードを、恥ずかしげもなく「続き」に書いてみました。
perltidyで味付けはしましたが。
コメントが痛々しいですが、当時はこういうテーマも面白いなという思い付きだったので大目に見ましょう。

ファイル構成
nanochat.cgi (705) : メインスクリプト
main.log (606) : 会話記録用ファイル
member.log (606) : メンバー記録用ファイル
nanochat.css (604) : スタイルシート

main.logとmember.logは空ファイルでOK（のはず）。

サンプル

nanochat.cgi

#!/usr/bin/perl
# ↑は「#!/usr/local/bin/perl」が一般的みたいなの。
# 動かないときはプロバイダに訊くの。
 
#BEGIN{
#    print "Content-type: text/plain\n\n";
#    open(STDERR, ">&STDOUT");
#    $|=1;
#}
# ↑はエラーが出て困った時にコメントを外すの。
 
require 5.005;
use strict;
 
# ↑はさわったらだめなの。
 
# いくつか設定することがあるの。
 
my @max_list = qw(10 20 30 40 50);
 
# 入口では表示する件数を選べるの。
# ここに書いたのがドロップダウンに表示されるの。
# でも、あんまり大きい数はいやなの。
# 数字以外も書けるけど、書いたらいやなの。
 
my $return_uri = '../nanochat.htm';
 
# 「戻るの。」でリンクする場所を決める事ができるの。
 
my $ss_uri = './nanochat.css';
 
# スタイルシートの場所なの。
# このファイルはスクリプトと同じ場所だと効かない事があるらしいの。
# そういう人はスタイルシートを他の場所において、ここを変えるの。
# その時は「http://」から書いたほうが確実なの。
 
my $timeout = 1800;
 
# 書込みしてない人はクッキーの期限が切れるの。
# その時間を決める事ができるの。単位は秒なの。
 
my $main_log = './main.log';
 
# 会話の中身を記録するファイルの名前なの。
# 最初はこの名前だから、そのまま使うときは変えなくてもいいの。
 
my $member_log = './member.log';
 
# 誰が居るかを記録するファイルの名前なの。
# 最初はこの名前だから、そのまま使うときは変えなくてもいいの。
 
my $nano = 'なの';
 
# これを変えたらなのじゃなくなるの。でもべつにいいの。
 
my $script_uri = $ENV{SCRIPT_NAME} || './nanochat.cgi';
 
# このファイルの名前を変えたら、右側の方にその名前を書くの。
 
# ここから・・・
my $msg_max = ( sort { $b <=> $a } @max_list )[0];
my $msg_min = ( sort { $a <=> $b } @max_list )[0];
my $script_name  = 'NANOChat';
my $print_str    = '';
my $print_header = '';
my %members      = ();
my %ip           = ();
my @logs         = ();
my @logs_now     = ();
 
# ここまでは変えたらいやなの。
# お仕事できなくなるの。
 
check_env();
 
# ↑はうまく動くか試してるの。ちゃんと動いたら消してもいいの。
# 心配な人は消さなくてもいいの。
 
# ここから最後までは細かい事をやってるの。
# わからない人はさわったらダメなの。
main();
print_exit();
 
sub main {
    my $cookie = get_cookie();
 
    # HTMLのチェック用なの。
    #    $cookie = ',10';
    #    $cookie = '61,10';
    #    $ENV{QUERY_STRING} = 'logout=1';
    # ここまでなの。でも、下のほうにもう少しあるの。
    if ( defined $cookie ) {
        my ( $name, $tmp ) = split /,/, $cookie, 3;
        if ($name) {
            $name = pack( "H*", $name );
            check_max($tmp);
        }
        my %form = ();    # (ua => $ENV{HTTP_USER_AGENT});
        foreach ( split /[&;]/, $ENV{QUERY_STRING} ) {
            my ( $key, $value ) = split /=/, $_, 2;
            if ( $value =~ /[%\+]/ ) {
                my $space = "(?:\xA1\xA1)";
                $value =~ tr/+/ /;
                $value =~ s/%([0-9a-fA-F][0-9a-fA-F])/pack("H2", $1)/eg;
                $value =~ s/&/&amp;/g;
                $value =~ s/</&lt;/g;
                $value =~ s/>/&gt;/g;
                $value =~ s/\t/  /g;
                $value =~ s/^(\s|$space)+//o;
                $value =~ s/(\s|$space)+$//o;
                $value =~ s/  / &nbsp;/g;
                $value =~ tr/\x0D\x0A//d;
            }
            $form{$key} = $value;
        }
        member_read();
 
        # HTMLチェック用なの。
        #        $members{'a'} = time; $ip{'a'} = '127.0.0.1';
        # これだけなの。
        if ( exists $form{logout} ) {
            ref_logout( \%form, $name );
            print_exit();
        }
        elsif ( exists $form{login} and $name eq '' ) {
            ref_login( \%form );
            $name = $form{n};
            check_max( $form{max} );
        }
        log_read();
        if ($name) {
            $form{msg} ne '' and ref_make_log( \%form, $name );
            my $cname = unpack( "H*", $name );
            $print_header = "Set-Cookie: $script_name=$cname,$msg_max; expires="
              . gmtime( time + $timeout ) . "\n";
            reload($name);
        }
        else {
            stock_header('名前を教えてほしいの。');
            stock_member();
            my $sel = qq(<select name="max">);
            my $sd  = qq( selected);
            foreach (@max_list) {
                $sel .= qq(<option value="$_"$sd>$_ 件</option>);
                $sd = '';
            }
            $sel .= '</select>';
            $print_str .= <<EOM;
<div class="nano">
<form method="get" action="$script_uri">
<p><input type="text" name="n" size="20" maxlength="20" tabindex="1"> ←ここに名前を書いてほしいの。</p>
<p>書いたら、表示するメッセージ数を $sel にして <input type="submit" value="部屋に入るの。" tabindex="2"><input type="hidden" name="login" value="1"></p>
<p><input type="submit" name="logout" value="やっぱり帰るの。" tabindex="3"></p>
</form></div><hr>
EOM
            stock_log($msg_min);
            stock_footer();
        }
    }
    else {
        $print_header = "Set-Cookie: $script_name=,10; expires="
          . gmtime( time + $timeout ) . "\n";
        stock_header('いらっしゃいなの。');
        my $limit = int( $timeout / 60 );
        $print_str .= <<EOM;
<div class="nano">
<p>ここの入退室管理を任されてる <strong class="name">$nano</strong> なの。よろしくなの。</p>
<p>この部屋へ入るにはクッキーが必要なの。退室するときにちゃんと消してあげるから、名札だと思ってつけてほしいの。今つけた人は、ついてるかどうかわからないから１回読みなおしてほしいの。</p>
<p>JavaScriptが使えると、マウスを使わなくてもチャットできるの。とってもおすすめなの。</p>
<p>あと、$limit分くらい何も発言しないと部屋から追い出されちゃうの。気をつけてほしいの。</p>
<p>あ、ホームページ（http://から書くの）とかメールアドレス（mailto:から書くの）とかを書くと、リンクしてあげるの。よくわからないから発言を全部リンクしちゃうけど、そのくらいは許してほしいの。</p>
<p>準備ができたら<a href="$script_uri">入口</a>で名前を教えてほしいの。</p>
</div>
EOM
        stock_footer();
    }
}
 
sub member_read {
    open IN, $member_log or die;
    my $member = <IN>;
    my $ip     = <IN>;
    close IN;
    chomp $member;
    chomp $ip;
    %members = split /\t/, $member;
    %ip      = split /\t/, $ip;
    foreach ( keys %members ) {
 
        if ( $timeout < time - $members{$_} ) {
            delete $members{$_};
            delete $ip{$_};
        }
    }
}
 
sub member_write {
    my $member = join( "\t", %members );
    my $ip     = join( "\t", %ip );
    open OUT, "> $member_log" or die;
    print OUT $member . "\n";
    print OUT $ip . "\n";
    close OUT;
}
 
# ファイルを最後の方から読むの。
# Perlメモ（http://www.din.or.jp/~ohzaki/perl.htm）を参考にしたの。
# でも、ほとんどそのままなの。
sub log_read {
    my $bufsize = 1024;
    my $pos     = 0;
    open IN, $main_log or die;
    binmode(IN);
    my $size = ( -s IN ) / $bufsize;
    $pos += $size <=> ( $pos = int($size) );
    my $buf_tmp = '';
    while ( $pos-- ) {
        my $buf   = '';
        my @lines = ();
        seek( IN, $bufsize * $pos, 0 );
        read( IN, $buf, $bufsize );
        $buf .= $buf_tmp;
        ( $buf_tmp, @lines ) = $buf =~ /[^\x0D\x0A]*\x0D?\x0A?/g;
        pop(@lines);
        unshift( @logs, @lines );
        next if @logs < $msg_max;
        last;
    }
    close IN;
    unshift( @logs, $buf_tmp ) if $buf_tmp;
 
    # 最後まで読んでる事も多いから必要なの。
    #    @logs = @logs[-$msg_max .. -1] if @logs > $msg_max;
    # 本当は余ったら切らないといけないの。
    # でも、表示する時に切るから放っておくの。
}
 
sub log_write {
 
    open OUT, ">> $main_log" or die;
    seek OUT, 0, 2;
    print OUT "$_\n" foreach reverse @logs_now;
    close OUT;
    return if %members;
    $msg_max = ( sort { $b <=> $a } @max_list )[0];
    @logs = ();
    log_read();
    open OUT, "> $main_log" or die;
 
    foreach (@logs) {
        tr/\x0D\x0A//d;
        $_ or next;
        print OUT "$_\n";
    }
    close OUT;
}
 
sub ref_login {
    my ($f) = @_;
    $f->{n}
      or error_exit("名前を教えてほしいって言ってるの。名無しさんはいやなの。");
    $f->{n} eq $nano
      and error_exit(
qq(<strong class="name">$f->{n}</strong> はわたしなの。同じ名前はいやなの。)
      );
    exists $members{ $f->{n} }
      and $ip{ $f->{n} } ne $ENV{REMOTE_ADDR}
      and error_exit(
qq(<strong class="name">$f->{n}</strong> さんはもういるの。名前を変えてほしいの。)
      );
    $members{ $f->{n} } = time;
    exists $ip{ $f->{n} } and return;
    $ip{ $f->{n} } = $ENV{REMOTE_ADDR};
    ref_make_log(
        {
            msg =>
qq(<strong class="name">$f->{n}</strong> さんが入室したの。仲良くしてなの。),
        },
        $nano
    );
}
 
sub ref_logout {
    my ( $f, $name ) = @_;
    $print_header =
      "Set-Cookie: $script_name=,0; expires=Sat Jan 1 00:00:00 2000\n";
    if ( delete $members{$name} and delete $ip{$name} ) {
        ref_make_log(
            {
                msg =>
qq(<strong class="name">$name</strong> さんが退室したの。ちょっと淋しいの。),
            },
            $nano
        );
        %members
          or
          ref_make_log( { msg => '誰もいなくなったの。淋しいの。', }, $nano );
        stock_header('ばいばいなの。');
        $print_str .= <<EOM;
<div class="nano">
<p><strong class="name">$name</strong> さん、ありがとうなの。また来てほしいの。</p>
<p>そういえば、ブラウザに履歴がいっぱいあると思うの。ごめんねなの。</p>
<p><a href="$return_uri">戻るの。</a></p>
</div>
EOM
        log_write();
        member_write();
        stock_footer();
    }
    else {
        stock_header('残念なの。');
        $print_str .= <<EOM;
<div class="nano">
<p>今度はちゃんと入ってほしいの。また来てなの。</p>
<p><a href="$return_uri">戻るの。</a></p>
</div>
EOM
        stock_footer();
    }
}
 
sub get_cookie {
    return undef unless my $http_cookie = $ENV{HTTP_COOKIE};
    $http_cookie =~ tr/ //d;
    foreach ( split( /;/, $http_cookie ) ) {
        my ( $key, $value ) = split( /=/, $_, 2 );
        next if $key ne $script_name;
        return $value;
    }
    return undef;
}
 
sub ref_make_log {
    my ( $f, $name ) = @_;
    my $str  = '';
    my @date = localtime;
    if (   index( $f->{msg}, "http://" ) == 0
        or index( $f->{msg}, "mailto:" ) == 0 )
    {
        $f->{msg} = qq(<a href="$f->{msg}">$f->{msg}</a>);
    }
    $f->{msg} .= sprintf " <small>(%ld/%02d/%02d %02d:%02d:%02d)</small>",
      $date[5] + 1900, $date[4] + 1, @date[ 3, 2, 1, 0 ];
    if ( $name eq $nano ) {
        $str = qq(<p class="nano">);
    }
    else {
        $str = "<p>";
        $members{$name} = time;
    }
    unshift @logs_now,
      qq($str<strong class="name">$name</strong> ： $f->{msg}</p>);
}
 
sub reload {
    stock_header( $nano . 'チャットなの。' );
    stock_member();
    $print_str .= <<EOM;
<div class="nano">
<form method="get" action="$script_uri">
<p>あなたは <strong class="name">$_[0]</strong> さんなの。改行するとたぶん送信するの。何も書いてない時は再読込になるの。</p>
<p><input type="text" name="msg" size="80" value="" tabindex="1"><br><input type="submit" value="送信するの。" tabindex="2"> <input type="submit" name="logout" value="退室するの。" tabindex="3"></p>
</form></div><hr>
EOM
    stock_log($msg_max);
    stock_footer();
    if (@logs_now) {
        log_write();
        member_write();
    }
}
 
sub stock_member {
    my $cnt = 0;
    $print_str .= qq(<p class="nano">今は、 );
    foreach ( sort { $members{$b} <=> $members{$a} } keys %members ) {
        $print_str .= qq(<strong class="name">$_</strong> さんと );
        ++$cnt;
    }
    my $only = $cnt ? " " : " だけ";
    $print_str .= qq(<strong class="name">$nano</strong>$onlyがいるの。</p>\n);
}
 
sub stock_log {
    my $cnt = 0;
    @logs_now or @logs or return;
    $print_str .= qq(<div class="logs">);
    foreach ( @logs_now, reverse @logs ) {
        $_[0] < ++$cnt and last;
        tr/\x0D\x0A//d;
        $print_str .= $_;
    }
    $print_str .= '</div>';
}
 
sub stock_header {
    $print_str .= <<EOM;
<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01//EN"
    "http://www.w3.org/TR/html4/strict.dtd">
<html lang="ja">
<head>
<link rel="stylesheet" type="text/css" href="$ss_uri" title="Default" media="screen">
<meta name="ROBOTS" content="NOINDEX">
<title>$_[0]</title>
</head>
<body onload="obj = document.forms[0];if(obj)obj.elements[0].focus();">
<h2 class="nano">$_[0]</h2><hr>
EOM
}
 
sub stock_footer {
    my $cost = sprintf "このお仕事に %.2f 秒くらいかかったの。", times;
    my $copy =
qq(<a href="http://www.age.ne.jp/x/nobu3/perl/nanochat.htm" title="このスクリプトの最新版はこのリンク先にあるの。">$script_name Ver0.12</a>);
    $print_str .= <<EOM;
<hr>
<p class="nano">$cost</p>
<address>$copy</address>
</body>
</html>
EOM
}
 
sub error_exit {
    $print_str = '';
    stock_header('そんな事したらダメなの。');
    $print_str .= <<EOM;
<div class="nano">
<p>$_[0]</p>
<p>お仕事の邪魔しないでほしいの。<a href="$script_uri">入口まで戻るの。</a></p>
</div>
EOM
    stock_footer();
    print_exit();
}
 
sub print_exit {
    $print_str =~ tr/\x0D\x0A//d;
    print "Content-Type: text/html; charset=euc-jp\n";
    print "Content-Language: ja\n";
    print "Content-Script-Type: text/javascript\n";
    print "Content-Style-Type: text/css\n";
    print "Pragma: no-cache\n";
    print "Cache-Control: no-cache\n";
 
    $print_header and print $print_header;
    printf "Content-Length: %ld\n", length $print_str;
    print "\n";
    print $print_str;
    exit;
}
 
sub check_max {
    my ($num) = @_;
    $num = $msg_min if $num =~ /\D/;
    $msg_max = $msg_max < $num ? $msg_max : $num < $msg_min ? $msg_min : $num;
}
 
sub check_env {
    my $str = '';
    -r $main_log   or $str .= $main_log . 'が読めないの。<br>';
    -w $main_log   or $str .= $main_log . 'に書けないの。<br>';
    -r $member_log or $str .= $member_log . 'が読めないの。<br>';
    -w $member_log or $str .= $member_log . 'に書けないの。<br>';
    ord('漢') == 0xb4
      or $str .=
qq(<strong class="name">$nano</strong> は、eucが好きなの。変えてほしいの。<br>);
    $str and error_exit($str);
}
 
__END__
 
Ver 0.10 (2000/12/27)
    公開版。
Ver 0.11 (2001/04/19)
    入室時の２重投稿チェックをして入室ミスをなるべく防ぐようにした。
    ログの表示件数を正確にした。
    URIとMailに自動リンク。ただしとっても手抜き。
    出力するHTMLをHTML4.01Strict相当にした。
Ver 0.12 (2001/04/26)
    名前の変更ができてしまうのを修正。
    最大表示件数のチェックを強化。
    ロボット対策をつけた。
    スタイルシートを若干変更。

nanochat.css

/***********************/
/*    for  NANOChat    */
/* Designed by NANO(?) */
/***********************/
 
body{
    color: #642;
    background-color: #fed;
}
a:link{
    color: #c36;
}
a:visited{
    color: #63c;
}
a:active, a:hover{
    color: #f63;
    text-decoration: none;
}
.nano{
    color: #862;
}
.name{
    color: #621;
}
h2, form{
    margin: 1px 5px;
}
p{
    margin: 1px 5px;
    text-indent: 0.6em;
}
input{
    margin: 0;
    text-indent: 0;
}
div.logs p{
    padding: 1px 5px;
    border-width: 0px 0px 1px 0px;
    border-style: solid;
    border-color: #9cf;
}
small{
    font-size: 80%;
    color: #ac8;
}
address{
    text-align: right;
    font-size: 80%;
    font-family: "Times New Roman", Times, serif;
}

« 今日のMENTA｜トップ｜さようなら、ActivePerl。こんにちは、StrawberryPerl。 »

カテゴリ:

タグ:

タグによる関連記事

トラックバック(0)

このブログ記事に対するトラックバックURL:

コメントする

Google検索

Last.fm

このブログ記事について

このページは、のぶりんが2008年12月 4日 03:19に書いたブログ記事です。

ひとつ前のブログ記事は「今日のMENTA」です。

次のブログ記事は「さようなら、ActivePerl。こんにちは、StrawberryPerl。」です。

最近のコンテンツはインデックスページで見られます。過去に書かれたものはアーカイブのページで見られます。

カテゴリ

月別 アーカイブ

Links

Creative Commons License
このブログのライセンスは クリエイティブ・コモンズライセンス.
Powered by Movable Type