#!/usr/bin/perl

use strict;
use warnings;
use IO::Socket;
use IO::Poll qw( POLLIN POLLOUT POLLHUP POLLERR );
use Data::Dumper;
use HTTP::Request;
use CGI;

my $_timeout = 15;
$SIG{ALRM} = \&timeout;
alarm($_timeout);

my $port = shift || 3000;

my $server = IO::Socket::INET->new(
    LocalPort => $port,
    Listen    => 10,
    Reuse     => 1,
) or die $@;

my $poll = IO::Poll->new();
$poll->mask( $server => POLLIN );

my $clients = {};
my @messages = ();

while (1) {
    my $cnt = $poll->poll();

    my @readers = $poll->handles( POLLIN | POLLHUP | POLLERR );

    for (@readers) {
        if ( $server eq $_ ) {
            my $socket = $_->accept;
            $socket->blocking(0);

            # add client socket
            $poll->mask( $socket => POLLIN );

            my $fileno = fileno($socket);
            $clients->{$fileno} = $socket;
        }
        else {
            my $buf;

            while ( defined $_->sysread( $buf, 8192 ) ) {
                my $req = HTTP::Request->parse($buf);

                unless ($buf) {
                    remove( $poll, $_, $clients );
                    last;
                }

                my $params = $req->uri->as_string;
                if ( $params eq '/' ) {

                    open( F, './index.html' );
                    my $root_content = do { local $/; <F> };
                    close F;
                    $_->syswrite($root_content);
                    remove( $poll, $_, $clients );

                    #clear all
                    for my $_client ( values %{$clients} ) {
                        remove( $poll, $_client, $clients );
                    }
                    $clients = {};

                }
                else {
                    $params =~ s/\/\?//g;
                    my $q      = new CGI($params);
                    my $action = $q->param('a');

                    if ( $action eq 'write' ) {
                        my $message  = $q->param('message');
                        my $nickname = $q->param('nickname');

                        my $content = "{ \"message\": \"$message\", \"nickname\":\"$nickname\" }";
                        push @messages , $content;
                        for my $client ( values %{$clients} ) {

                            $client->syswrite(
                                              "HTTP/1.1 200 OK\r\n".
                                              "Content-Type:text/html; charset=utf-8\r\n".
                                              "Content-Length:".(length $content) ."\r\n".
                                              "Expires:-1\r\n".
                                              "Pragma:no-cache\r\n".
                                              "Cache-Control:must-revalidate, no-cache, no-store\r\n".
                                              "\r\n".
                                              $content
                                              );
                            #clear all
                            remove( $poll, $client, $clients );
                        }
                        $clients = {};
                    }
                    elsif ( $action eq 'poll' ) {
                        #for debug
                        print "now polling ..." . fileno($_);
                    }
                    elsif ( $action eq 'init' ) {
                        #disconnect
                        my $message;
                        $message = join ',' , @messages;
                        $_->syswrite("{ \"init\": [" . $message . "] }");
                        remove( $poll, $_, $clients );
                    }
                    else {
                        #disconnect
                        $_->syswrite("oops bad request !!");
                        remove( $poll, $_, $clients );
                    }
                }
            }
        }
    }
}

sub remove {
    my ( $poll, $client, $clients ) = @_;
    delete $clients->{ fileno($client) } if ($clients);
    $poll->remove($client);
    $client->close();
}

sub timeout {
    print "called timeout";
    for my $client ( values %{$clients} ) {
        $poll->remove($client);
        $client->close();
        #$client->shutdown(2);
    }
    $clients = {};
    alarm($_timeout);
}

サーバ側の解説

* 15秒毎にタイムアウトさせています。
 pollingしているクライアントの接続も切っています。

my $_timeout = 15;
$SIG{ALRM} = \&timeout;
alarm($_timeout);

* IO::Pollオブジェクトにサーバの待機ソケットを監視対象に加えています。
　POLLINは監視の条件

my $poll = IO::Poll->new();
$poll->mask( $server => POLLIN );

* イベント待機

$poll->poll();

* イベントが発生したファイルディスクリプタのリスト取得
my @readers = $poll->handles( POLLIN | POLLHUP | POLLERR );

* 待機ソケットの接続要求を受けてクライアントソケットを監視対象に追加
  読み取りのみ監視、でノンブロッキングモード

my $socket = $_->accept;
$socket->blocking(0);
$poll->mask( $socket => POLLIN );

* 保持しているソケットに一斉書き込み
ヘッダーにcacheを無効にするように設定

for my $client ( values %{$clients} ) {
  $client->syswrite(
   "HTTP/1.1 200 OK\r\n".
   "Content-Type:text/html; charset=utf-8\r\n".
   "Content-Length:".(length $content) ."\r\n".
   "Expires:-1\r\n".
   "Pragma:no-cache\r\n".
   "Cache-Control:must-revalidate, no-cache, no-store\r\n".
   "\r\n".
   $content
);


* pollingの時はなにもしない。これでつなぎっぱなし状態
elsif ( $action eq 'poll' ) {

index.html

<html>
<head>
<meta HTTP-EQUIV="Pragma" CONTENT="no-cache">
<meta HTTP-EQUIV="Expires" CONTENT="-1">
<title>IO::Poll</title>
<script src="/path/to/prototype.js"></script>
<script>
Event.observe(window, 'load', function (){
    function poll(){
        new Ajax.Request(
                         '/?a=poll',
                         {
                             method: 'GET',
                             parameters: {},
                             onComplete: writeMessage
                         } );
    };
    
    function writeMessage(res){
        try{
            var m = $('messages');
            var resObj = eval('('+res.responseText+')');
            m.innerHTML = ('<span>' + resObj.nickname + ' >> ' + resObj.message + '</span><br>' + m.innerHTML);
        }catch(e){}
        poll();
    }
    
    Event.observe($('input_form'), 'submit',
                  function(event){
                      event = event || window.event;
                      Event.stop(event);
                      var message = $('message').value;
                      var nickname = $('nickname').value;
                      new Ajax.Request(
                                       '/?a=write&message='+encodeURIComponent(message)
                                       +'&nickname='+encodeURIComponent(nickname), 
                                       {
                                           method: 'GET',
                                           parameters: {},
                                           onComplete: function(res){ $('message').value = ""; }
                                       } );
                  } );

    //init
    new Ajax.Request(
                     '/?a=init',
                     {
                         method: 'GET',
                         parameters: {},
                         onComplete: function(res){
                             var m = $('messages');
                             var resObj = eval('('+res.responseText+')');
                             var data = resObj.init; 
                             for(var i=0; data.length > i; i++){
                             m.innerHTML = ('<span>' + data[i].nickname + ' >> ' + data[i].message + '</span><br>' + m.innerHTML);
                             }
                             poll();
                         }
                     } );
    
} );
</script>
</head>
<body>
<form action="#" method="POST" id="input_form" >
  <input type="text" id="nickname" value="guest" size="8"> <input type="text" id="message"><span style="" ><input type="submit" ></span>
</form>
<div id="messages">
<div>
</body>
</html>

クライアント側解説

* サーバからのタイムアウト、または書き込みによる切断の後
  すぐにpollingしています
function writeMessage(res){
       .
       .
       .

      poll();
}

2007-06-11

Macのterminalで日本語を扱うときどうしてますか？

わたしは

~/.inputrc に

set convert-meta off
set meta-flag on
set output-meta on

ターミナル->ウインドウ設定->エミュレーション

非ASCII文字をエスケープする　のチェックはずす

ターミナル->ウインドウ設定->ディスプレイ

日本語や中国語にワイドグリフを使う　にチェック
ワイドグリフを２桁とカウントする

文字セットエンコード
utf-8

.emacsに

(set-language-environment "Japanese")
(set-default-coding-systems 'utf-8)
(set-keyboard-coding-system 'utf-8)
(set-terminal-coding-system 'utf-8)
(set-buffer-file-coding-system 'utf-8) 

追加

でもなんかいまいち

2007-06-07

macにstraceがなかったので ktrace / kdump

ktrace -p pid
kdump -f ktrace.out

2007-05-03

いまさらDBIx::Class::Relationshipのmight_haveで

親子テーブルで

Parent->might_have(
        "parent_child",
        "Child",
        { "foreign.parent_child_seq" => "self.parent_seq" },
);

みたいに書いておくと、親レコードのdeleteの時にリレーションしている子のレコードまでdeleteに走ってしまう。

そんなときは { cascade_delete => 0 } を付けるとデフォルトではdeleteしにいかなくなる

perldocにしっかりかいてありますね。。。

If you update or delete an object in a class with a might_have relationship, the related object will be updated or deleted as well. To turn off this behavior, add cascade_delete => 0 to the $attr hashref. Any database-level update or delete constraints will override this behavior.

それが嫌なら設定で上書きしてねって

はまった

2007-04-27

perlのlocalに助けられるとき

Catalystのsetup時なんかに設定されるconfigの値を一時的に設定し直したい、
でも他にも影響がでるので自分のところだけっていう時にlocalに助けられます。
変更前の値保持しておいて　変更して　また前の値に戻すのってめんどくさいし。。。

例えばエラーメッセージのフォーマットを一時的に変えたい時

local FormValidator::Simple->messages->{_format} 
= '<span style="color:red">%s</span>';

例えばリクエストの値を一時的に汚染せずに変えたいとき

local $c->req->{parameters} = {};
$c->req->parameters->{'hoge'} = 'fuga';

。。。他にもあったのですが、思い出せない。。。

2007-04-22

straceしてみようかな。。。

興味でBINARY HACKS買ってちょっと読んでしばらく放置していたんですけど(あまりに濃い内容で)
システムコールのことを調べてて、全部読まなくてもちょっとずつ理解できる部分だけ読んで行こうかなと思いました。

で straceでシステムコールをトレースすると言うのをためしてみようかなと思います。

Apache+Catalyst+FCGIでたまにレスポンスがこない。
F5の再読み込みだと元気に起動

みたいな挙動をしていて
どっかのタイミングでstraceを仕込みたいなーと思ってます。

ちなみに　 strace perl script/myapp_server.pl -r
すると

execve("/usr/bin/perl", ["perl", "script/myapp_server.pl", "-r"], [/* 45 vars */])
・・・
略（わーっとログ）
・・・
でいつもの[debug]ログ
・・・
socket(PF_INET, SOCK_STREAM, IPPROTO_TCP) = 4
setsockopt(4, SOL_SOCKET, SO_REUSEADDR, [1], 4) = 0
bind(4, {sa_family=AF_INET, sin_port=htons(3000), sin_addr=inet_addr("0.0.0.0")}, 16) = 0
listen(4, 128) = 0
write(1, "You can connect to your server a"..., 58You can connect to your server at http://localhost:3000
) = 58
accept(4,

わー
soket開いて、soketオプション設定して、バインドして、ポートにlisten命令して、writeして、acceptシステムコールで待ち構えてるわーみたいなことがわかるなー。

2007-04-06

labelタグって

labelタグってイベント同期するんですね。
知りませんでした。。。ちょっとはまってしました。
お恥ずかしい。。。

<input type="checkbox" id="c1">
<label for="c1">おしてみて<label/>

<script type="text/javascript">                                                                               
var elm = document.getElementById('c1');                                                                      
elm.onclick = function(){alert('おされたよ')};                                                                
</script>

遥かな時代の階段を

IO::Pollでcometなチャットサーバを書いてみた