2006-10-02

Ajaxでチャット＆Ajax:JSON簡易フレームワーク

PerlのリハビリとJavaScriptの勉強がてら、定番のAjaxを用いたチャットを作ってみました。
JavaScriptのほうでは、prototype.jsを使ってみました。
サーバ側はともかく、クライアント側はなかなか難しくて試行錯誤の連続でしたが一応は完成しました。
大した物じゃないんですが、やっぱり画面遷移なしでチャットができちゃうというのは感動します。
発言→サーバ側CGIがログに書き込む、定期的にログを直接読み込んで表示という流れなんですが、ログを読みに行く間隔がなかなか難しい。
LAN内ですと0.5秒設定とかでかなり良い動きをするんですが、インターネット経由となるとどうなるのかなぁと思ったり。
本当はログを丸ごと読んだりせず、必要な分だけ読み込む、等の措置も必要なのかもしれません。

サーバとブラウザの通信にはすべてJSONを使うことにして、簡単なフレームワーク(?)みたいな物を作りました。

# LLALD.pm
package LLALD;

use strict;
use JSON::Syck;

sub new{
    my $class = shift;
    my $self  = bless({
                       req => {},
                       res => {},
                      }, $class);
    
    $self->_init;
    
    return $self;
}

sub _init{
    my $self  = shift;
    my $query;
    
    if( $ENV{REQUEST_METHOD} eq 'POST' ){
        read( STDIN, $query, $ENV{CONTENT_LENGTH} );
    } else {
        $query = $ENV{QUERY_STRING};
    }
    
    $self->{req} = JSON::Syck::Load( $query );
}

sub forward_to{
    my $self      = shift;
    my $controler = shift;
    my $runmode   = shift;
    
    $runmode = $self->{req}->{_runmode} || 'default' if( !$runmode );
    
    $controler->$runmode( $self );
}

sub request{
    my $self = shift;
    return $self->{req};
}

sub response{
    my $self = shift;
    return $self->{res};
}

sub put_results{
    my $self = shift;
    
    print 
        "Content-type: text/plain\n\n", 
        $self->results;
}

sub results{
    my $self = shift;
    return
        '(' .
        JSON::Syck::Dump( $self->{res} ) .
        ')';
}

1;

これだけでもある程度想像はつくと思うのですが、本体のCGIはこんな感じです。

# chat.cgi
#! /usr/bin/perl

use strict;
use LLALD;

use Controler;

my $d = new LLALD();
$d->forward_to( 'Controler' );
$d->put_results;

そして、Controlerは

# Controler.pm
package Controler;

use Model;
use strict;

sub default{
    my $c = shift;
    my $j = shift;
}

sub newMessage{
    my $c = shift;
    my $j = shift;
    
    if( !$j->request->{name} or !$j->request->{message} ){
        return;
    }
    
    Model::unshiftAMessage( name => $j->request->{name}, message => $j->request->{message} );
}

1;

そしてブラウザ側。json.jsを使用します。

function sendRequest( url, obj, complete ){
    new Ajax.Request(
        url,
        {
        asynchronous : 1,
        method       : 'post',
        postBody     : obj.toJSONString(),
        onComplete   : function(request){
            complete( eval(request.responseText) );
        }
        }
    );
}

要するに、ブラウザ側からJSON形式でデータをPOSTし$j->responseに格納、そのデータによって処理を振り分けControler内でうじゃうじゃし、$j->responseにデータをぶち込んで、LLALD.pmがそのデータをJSON形式に変換してブラウザに返す。
（今回はサーバ側からとくにデータを返していませんが。）
ブラウザはJSON形式のデータをObjectに戻して、いろんな処理をする。

2006-09-29

ザの人カウンターのコード

プログラミング Perl CGI

#! /usr/bin/perl
# ザの人用カウンター
# http://d.hatena.ne.jp/jjx/
#
# -.cgi
# gifcat.pl (http://www.tohoho-web.com/wwwsoft.htm)
# log
# img---+---normal
#       +---fuga
# img/fuga(画像コード)ディレクトリには0.gif-9.gifという名前で書く番号の画像ファイルをおいて下さい。
#
use strict;

my $locknewuser = 0;    # 新規利用停止( 停止しない:0  停止する:1 )
my $logdir     = 'log'; # ログファイルを格納するディレクトリの名前
my $imagedir   = 'img'; # カウンター画像を格納するディレクトリの名前

my $id = $ENV{QUERY_STRING};

my $sp  = 'normal'; # デフォルトの画像コードはnormal
my $day;
if( $id =~ s/(T|Y)$// ){ $day = $1; }
if( $id =~ s/([a-z]{1,})$// ){ $sp = $1; }

# 不正
if( $id !~ /^\d+$/ ){ die; }
if( $id >=  100000 ){ die; }

if( ! -e "$logdir/$id.txt" ){
    if( $locknewuser ){
        die;
    } else {
        open( my $o, '>>', "$logdir/$id.txt" );
        close($o);
    }
}

open( my $io, '+<', "$logdir/$id.txt" ) or die;
flock( $io, 2 );
chomp( my $counter = <$io> );
chomp( my @counted = <$io> );
seek($io, 0, 0);

my( $total, $today, $yesterday ) = split(/\$/, $counter);

# 最終アクセス日が今日でなければVisitorログを初期化
if( (localtime( (stat($io))[9]) )[3] != (localtime(time))[3] ){
    $yesterday = $today;
    $today = 0;
    @counted = ();
}
unless( grep{ $_ eq $ENV{REMOTE_ADDR} }@counted ){ # ユニークである
    $total++;
    $today++;
    push(@counted, $ENV{REMOTE_ADDR});
}

print $io join("\n", join('$', $total, $today, $yesterday), @counted);
truncate( $io, tell($io) );
close($io);

require "gifcat.pl"; # by tohoho

my @giflist;
foreach my $s ( split(//, sprintf("%05d", ( $day eq 'T' ? $today : ( $day eq 'Y' ? $yesterday : $total ) )  )) ){
    push( @giflist, "$imagedir/$sp/$s.gif" );
}

print 
    "Content-type: image/gif\n\n",
    gifcat::gifcat( @giflist );

2006-09-28

06年9月末のある日

不明

あーあー実に何ヶ月ぶりだろう。はてなを使うのは。
もともとこの日記はちょっとまじめなプログラミングとかのことを書こうと思ってました。
最近はまったくプログラミングもしてなかったし、サーバにも触ってなかったのでご無沙汰してたというわけでございます。
それで、今日このはてなの日記をもう一度使おうと思いまして、過去の訳のわからん記事を盛大に消してたわけですが、2004年9月頃つまり丁度二年前の私は実にまじめだったようです。
そのころの記事をみると、私はがりがりPerlやらCやら毎日カキカキして、ApacheやらSQLやらいじっていたみたいで。
それなのに2年たった今はといえば、パソコンをつけたと思えば、ゲームに励むか2chロムってるか･･･。
別に受験とか関係なく、だめだめでございます。
最近はもうPerlすらいまいち思い出せません。だめだめでございます。
2年前は情報関係の進路に進むつもりでしたが、今は機械関係にシフトしました。
それでも、趣味としてソフトなものを触るのはなかなか楽しいと思うんです。ゲームつくりてーとかいう気持ちは今でもありますし。
ということで、勉強の合間にPerlのリハビリでもしようかなと思います。
たしか中三のころくらいからせっかくPerlを勉強したのにこのまま忘れてしまってなにもまともな物を残さないのは寂しいですし。
よってこの日記も使いますので、よろしくお願いします。

2005-02-27

超超簡易テンプレート関数

プログラミング Perl

HTML::TemplateやTemplate-Toolkitなどのたいそうなものを使うほどでは無いが、あんまりコード内にHTMLを書きたくないとき。こういうのはどうでしょ。なんの変哲もないですが。
第一引数に、テンプレートファイルの名前、第二引数以降に、
置換文字列 => 置換結果
のハッシュです。
print print_template( 'template.html', '%%message%%' => 'メッセージ' );
こういう感じで利用します。

sub print_template{
    my $template_name = shift;
    my %replice       = @_;
    my $data;
    
    open( my $in, '<', $template_name ) or die $!;
    { local $/; $data = <$in>; };
    close $in;
    
    $data =~ s/$_/$replice{$_}/g foreach (keys %replice);
    
    return $data;
}

2005-01-23

Net::POP3::GetAsStruct

プログラミング Perl

久々だ・・・。ザの人（http://4104.hito.thebbs.jp/Madam/）ばっか使ってました。
それはともかく、Net::POP3::GetAsStructモジュール。正直適当です。動けばいいってレベルです。
Net::POP3のget()をオーバーライドしてメールをハッシュのリファレンスとして受け取ります。 multipartなデータ用の処理はいま書いてる途中です。

package Net::POP3::GetAsStruct;

use strict;
use base 'Net::POP3';
use Jcode;
use MIME::Base64;

our $Charset    = 'sjis';
our @NeedDecode = qw( SUBJECT );

sub get{
    my $self   = shift;
    my $msgnum = shift;
    my %mail   = ( headers => {}, file => {}, message => '' );
    
    my $msg = $self->Net::POP3::get( $msgnum );
    
    # ヘッダを処理
    while( my $line = splice(@$msg, 0, 1) ){
        $line =~ s/[\r\n]*$//; # chompでは\rを消せない可能性あるから
        $line eq '' && last;   # ヘッダ処理終了
        
        my( $name, $value ) = split(/: */, $line, 2);
        $name =~ s/-/_/g;
        $name = uc($name); # 大文字に統一
        
        # デコードするのと、文字コード変換
        if( grep { $name eq $_ } @NeedDecode ){
            $value =~ s/=\?ISO-2022-JP\?B\?(.*?)=*\?=/decode_base64($1)/gei;
            
            if( $Charset eq 'sjis' or $Charset eq 'shift_jis' ){
                $value = Jcode->new($value)->sjis;
            } elsif( $Charset eq 'euc' or $Charset eq 'euc-jp' ){
                $value = Jcode->new($value)->euc;
            } elsif( $Charset eq 'utf8' ){
                $value = Jcode->new($value)->utf8;
            }
        }
        
        $mail{headers}->{$name} = $value;
    }
    
    # multipartな場合はあら大変
    if( $mail{headers}->{CONTENT_TYPE} =~ /^multipart/ ){
    } else {
        $mail{message} = ( $Charset eq 'sjis' or $Charset eq 'shift_jis' ) ? Jcode->new(join('', @$msg))->sjis : 
                         ( $Charset eq 'euc' or $Charset eq 'euc-jp' )     ? Jcode->new(join('', @$msg))->euc  : 
                         ( $Charset eq 'utf8' )                            ? Jcode->new(join('', @$msg))->utf8 :
                                                                                        join('', @$msg);
    }
    
    return \%mail;
}

1;

2004-12-18

コンマを挿入する

プログラミング C言語

ちょっと頼まれて考えたんだけど、Cがわかってないので結構頭捻ってしまった。
で、結局超頭悪そうなのができてしまった・・・。 Perlだったら1行なんだけどなぁ。

#include <stdio.h>
#include <string.h>

int main(){
    char x[100];
    int  len;
    
    // 入力を受け取る
    scanf("%s", x);
    
    len = strlen(x);
    
    // -のとき
    if(x[0] == '-'){
        printf("-");
        strcpy(x, x+1);
        len--;
    }
    
    // 3桁以下ならそのまま出力
    if( len <= 3 )
        printf("%s", x);
    else {
        int h = len % 3 /* xのけた数/3の余り */; 
        int t = 0;
        
        if( h > 0 )
            while( t < h )
                printf("%c", x[t++]);
        
        while( t < len ){
            printf(",%c%c%c", x[t], x[t+1], x[t+2]);
            t += 3;
        }
    }
    return 0;
}

2004-12-17

ロリコンの法則

プログラミング Perl

http://jjx.xxperlxx.org/cgi-bin/lolicom.cgi
衝動的にこんなものを作成。うーん。むなしい。んでもCGIMini::Templateは便利だぜ！と自画自賛。

コードです。
テンプレは別ファイルでも良いんですが面倒なので__DATA__にしてみた。
それにしても普通にプログラムよりテンプレの方が長い・・・。

#! /usr/bin/perl

use strict;
use CGIMini;
use CGIMini::FormData;
use CGIMini::Template;

use constant Pi => 3.141592;

my $cgi = CGIMini->new;
my $q   = CGIMini::FormData->new;
my $tmpl= CGIMini::Template->new( template => \*DATA );

$tmpl->param( ENV => { %ENV } );
$tmpl->param( age => $q->param('age') );
$tmpl->param( result => Pi * sqrt($q->param('age'))) if($q->param('age') >= 0);

print $cgi->header, $tmpl->output;

__DATA__
<?xml version="1.0" encoding="Shift_JIS"?>
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
  "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="ja" lang="ja">
<head>
        <meta http-equiv="content-type" content="text/html" />
        <link rel="stylesheet" type="text/css" href="/main.css" />
        <script src="/common.js" type="text/javascript"></script>
        <title>ロリコンの法則</title>
</head>
<body>
<h1>ロリコンの法則 pi * √age</h1>
<div class="topmenu">
    <a href="http://xxperlxx.org/">[xxperlxx.org server]</a>
    <a href="/">[TopPage]</a>
    <a href="mailto:admin@xxperlxx.org">[Mail]</a>
</div>
<hr />
<tmpl:if name="result">
    <span style="font-size: 30px; font-weight: bold; color: red;">%%result%%</span>才以下の女の子が好きならあなたは<strong>ロリコン</strong>です。
</tmpl:if>

<form action="%%ENV::REQUEST_URI%%">
    あなたの年齢:<input type="text" name="age" value="%%age%%" size="2" /><input type="submit" value="測定" />
</form>

<img src="lolicom_img.gif" alt="pi*√age" />
<hr />
<div class="banners">
    <a href="http://www.apache.jp/" target="_blank"><img src="/images/apache_pb.gif" alt="Apache" /></a>
    <a href="http://www.perl.com/" target="_blank"><img src="/images/rectangle_power_perl.gif" alt="Perl" /></a>
</div>
</body>
</html>