diff -urN tiarra-20040319/ChangeLog tiarra-20040327/ChangeLog --- tiarra-20040319/ChangeLog 2004-03-26 13:04:03.000000000 +0900 +++ tiarra-20040327/ChangeLog 2004-03-27 19:55:51.000000000 +0900 @@ -1,3 +1,26 @@ +2004-03-27 Topia + + * tiarra: + - quiet モード時に STDIN を閉じないと握りっぱなしになって + (sshd が落ちないなどの)不具合が発生するようなので閉じる。 + - STDERR を何かにリダイレクトするのは、とりあえずは保留。 + +2004-03-27 phonohawk + + * main/LinedINETSocket.pm (recvbuf): + 追加。通信終了後に改行が付かなかった行の内容を取り出すために使う。 + + * main/RunLoop.pm (run): + select前フックは、タイマーの次回発動時刻を計算する前に呼ぶ。 + フック内でタイマーの状態を変更しても問題を起こさないため。 + + * main/Timer.pm (time_to_fire): + 引数を指定した場合、タイマーの発動時刻を変更できるように。 + + * module/Tools/HTTPClient.pm: + 追加。 + HTTP/1.0専用のhttpクライアント。手抜き。 + 2004-03-19 Topia * main/IrcIO.pm, main/LinedINETSocket.pm: @@ -1502,7 +1525,7 @@ * これ以前のログは書いていません。 -# Id: $Id: ChangeLog,v 1.139 2004/03/19 13:21:06 topia Exp $ +# Id: $Id: ChangeLog,v 1.141 2004/03/27 10:42:51 topia Exp $ # Author: $Author: topia $ -# Date: $Date: 2004/03/19 13:21:06 $ -# Revision: $Revision: 1.139 $ +# Date: $Date: 2004/03/27 10:42:51 $ +# Revision: $Revision: 1.141 $ diff -urN tiarra-20040319/main/LinedINETSocket.pm tiarra-20040327/main/LinedINETSocket.pm --- tiarra-20040319/main/LinedINETSocket.pm 2004-03-26 13:04:03.000000000 +0900 +++ tiarra-20040327/main/LinedINETSocket.pm 2004-03-27 19:55:51.000000000 +0900 @@ -1,5 +1,5 @@ # -*- cperl -*- -# $Id: LinedINETSocket.pm,v 1.7 2004/03/19 13:21:06 topia Exp $ +# $Id: LinedINETSocket.pm,v 1.8 2004/03/27 10:41:17 admin Exp $ # copyright (C) 2003 Topia . all rights reserved. # this module based IrcIO.pm, thanks phonohawk! package LinedINETSocket; @@ -224,4 +224,8 @@ } } +sub recvbuf { + shift->{recvbuf}; +} + 1; diff -urN tiarra-20040319/main/RunLoop.pm tiarra-20040327/main/RunLoop.pm --- tiarra-20040319/main/RunLoop.pm 2004-03-26 13:04:03.000000000 +0900 +++ tiarra-20040327/main/RunLoop.pm 2004-03-27 19:55:51.000000000 +0900 @@ -1,5 +1,5 @@ # ----------------------------------------------------------------------------- -# $Id: RunLoop.pm,v 1.56 2004/03/13 07:17:34 admin Exp $ +# $Id: RunLoop.pm,v 1.57 2004/03/27 10:41:17 admin Exp $ # ----------------------------------------------------------------------------- # このクラスはTiarraのメインループを実装します。 # select()を実行し、サーバーやクライアントとのI/Oを行うのはこのクラスです。 @@ -862,6 +862,12 @@ # (普段は何かしら登録されていると思うが)タイマーが一つも登録されていなければ、タイムアウトはundefである。すなわちタイムアウトしない。 # タイマーが一つでも登録されていた場合は、全てのタイマーの中で最も発動時間が早いものを調べ、 # それが発動するまでの時間をselectのタイムアウト時間とする。 + + # select前フックを呼ぶ + $this->call_hooks('before-select'); + + # フック内でタイマーをinstall/発動時刻変更をした場合に備え、 + # タイムアウトの計算はbefore-selectフックの実行後にする。 my $timeout = undef; my $eariest_timer = $this->get_earliest_timer; if (defined $eariest_timer) { @@ -871,9 +877,9 @@ $timeout = 0; } - $this->_update_send_selector; # 書き込むべきデータがあるソケットだけをsend_selectorに登録する。そうでないソケットは除外。 - # select前フックを呼ぶ - $this->call_hooks('before-select'); + # 書き込むべきデータがあるソケットだけをsend_selectorに登録する。そうでないソケットは除外。 + $this->_update_send_selector; + # select実行 my $time_before_select = CORE::time; my ($readable_socks,$writable_socks) = diff -urN tiarra-20040319/main/Timer.pm tiarra-20040327/main/Timer.pm --- tiarra-20040319/main/Timer.pm 2004-03-26 13:04:03.000000000 +0900 +++ tiarra-20040327/main/Timer.pm 2004-03-27 19:55:51.000000000 +0900 @@ -1,5 +1,5 @@ # ----------------------------------------------------------------------------- -# $Id: Timer.pm,v 1.6 2003/07/19 05:15:57 admin Exp $ +# $Id: Timer.pm,v 1.7 2004/03/27 10:41:17 admin Exp $ # ----------------------------------------------------------------------------- # RunLoopに登録され、指定された時刻に起動するタイマーです。 # 現在の実装では、精度は秒となっています。 @@ -90,7 +90,11 @@ } sub time_to_fire { - shift->{fire_time}; + my ($this, $time) = @_; + if ($time) { + $this->{fire_time} = $time; + } + $this->{fire_time}; } sub install { diff -urN tiarra-20040319/module/Tools/HTTPClient.pm tiarra-20040327/module/Tools/HTTPClient.pm --- tiarra-20040319/module/Tools/HTTPClient.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20040327/module/Tools/HTTPClient.pm 2004-03-27 19:55:52.000000000 +0900 @@ -0,0 +1,237 @@ +# -*- cperl -*- +# ----------------------------------------------------------------------------- +# $Id: HTTPClient.pm,v 1.1 2004/03/27 10:41:17 admin Exp $ +# ----------------------------------------------------------------------------- +# HTTP/1.1非対応。 +# ----------------------------------------------------------------------------- +package Tools::HTTPClient; +use strict; +use warnings; +use LinedINETSocket; +use Carp; +use RunLoop; +use Timer; +# 本当はHTTP::RequestとHTTP::Responseを使いたいが… + +my $DEBUG = 0; + +sub new { + my ($class, %args) = @_; + my $this = bless {} => $class; + + if (!$args{Method}) { + croak "Argument `Method' is required"; + } + if (!$args{Url}) { + croak "Argument `Url' is required"; + } + + $this->{method} = $args{Method}; # GET | POST + $this->{url} = $args{Url}; + $this->{content} = $args{Content}; # undef可 + $this->{header} = $args{Header} || {}; # {key => value} undef可 + $this->{timeout} = $args{Timeout}; # undef可 + + $this->{callback} = undef; + $this->{socket} = undef; + $this->{hook} = undef; + $this->{timeout_timer} = undef; + + $this->{expire_time} = undef; # タイムアウト時刻 + + $this->{status_fetched} = undef; + $this->{header_fetched} = undef; + + $this->{reply} = {Header => {}, Content => ''}; + + $this; +} + +sub start { + # $callback: セッション終了後に呼ばれる関数。省略不可。 + # この関数には次のようなハッシュが渡される。 + # { + # Protocol => 'HTTP/1.0', + # Code => 200, + # Message => 'OK', + # Header => { + # 'Content-Length' => 6, + # }, + # Content => 'foobar', + # } + # エラーが発生した場合はエラーメッセージ(文字列)が渡される。 + my ($this, $callback) = @_; + if ($this->{callback}) { + croak "This client is already started"; + } + $this->{callback} = $callback; + + if (!$callback or ref($callback) ne 'CODE') { + croak "Callback function is required"; + } + + # URLを分解し、ホスト名とパスを得る。 + my ($host, $path); + $this->{url} =~ s/#.+//; + if ($this->{url} =~ m|^http://(.+)$|) { + if ($1 =~ m|^(.+?)(/.*)|) { + $host = $1; + $path = $2; + } + else { + $host = $1; + $path = '/'; + } + } + else { + croak "Unsupported scheme: $this->{url}"; + } + + # ヘッダにHostが含まれていなければ追加。 + if (!$this->{Header}{Host}) { + $this->{Header}{Host} = $host; + } + + # ホスト名にポートが含まれていたら分解。 + my $port = 80; + if ($host =~ s/:(\d+)//) { + $port = $1; + } + + # 接続 + $this->{socket} = LinedINETSocket->new("\x0a")->connect($host, $port); + if (!$this->{socket}) { + # 接続不可能 + croak "Failed to connect: $host:$port"; + } + + # 必要ならタイムアウト用のタイマーをインストール + if ($this->{timeout}) { + $this->{expire_time} = time + $this->{timeout}; + $this->{timeout_timer} = Timer->new( + After => $this->{timeout}, + Code => sub { + $this->{timeout_timer} = undef; + $this->_main; + })->install; + } + + # リクエストを発行し、フックをかけて終了。 + my @request = ( + "$this->{method} $this->{url} HTTP/1.0", + do { + map { + "$_: ".$this->{header}{$_} + } keys %{$this->{header}} + }, + '', + do { + $this->{content} ? $this->{content} : (); + }, + ); + foreach (@request) { + $DEBUG and print "> $_\n"; + $this->{socket}->send_reserve($_); + } + + $this->{hook} = RunLoop::Hook->new( + sub { + $this->_main; + })->install('before-select'); + + $this; +} + +sub _main { + my $this = shift; + + # タイムアウト判定 + if ($this->{expire_time} and time >= $this->{expire_time}) { + $this->_end("timeout"); + return; + } + + while (defined(my $line = $this->{socket}->pop_queue)) { + $DEBUG and print "< $line\n"; + + if (!$this->{status_fetched}) { + # ステータス行 + $line =~ tr/\n\r//d; + if ($line =~ m|^(HTTP/.+?) (\d+?) (.+)$|) { + $this->{reply}{Protocol} = $1; + $this->{reply}{Code} = $2; + $this->{reply}{Message} = $3; + $this->{status_fetched} = 1; + } + else { + $this->_end("invalid status line: $line"); + return; + } + } + elsif (!$this->{header_fetched}) { + $line =~ tr/\n\r//d; + if (length $line == 0) { + # ヘッダ終わり + $this->{header_fetched} = 1; + } + else { + if ($line =~ m|(.+?): (.+)$|) { + $this->{reply}{Header}{$1} = $2; + } + else { + $this->_end("invalid header line: $line"); + return; + } + } + } + else { + # 中身 + $this->{reply}{Content} .= $line . "\x0d\x0a"; + } + } + + # 切断されていたら、ここで終わり。 + if (!$this->{socket}->connected) { + if (!$this->{status_fetched} or + !$this->{header_fetched}) { + $this->_end("unexpected disconnect by server"); + } + else { + $this->{reply}{Content} .= $this->{socket}->recvbuf; + $this->_end; + } + } +} + +sub _end { + my ($this, $err) = @_; + + $this->stop; + + if ($err) { + $this->{callback}->($err); + } + else { + $this->{callback}->($this->{reply}); + } +} + +sub alive_p { + my $this = shift; + defined $this->{socket}; +} + +sub stop { + my $this = shift; + + $this->{socket}->disconnect if $this->{socket}; + $this->{hook}->uninstall if $this->{hook}; + $this->{timeout_timer}->uninstall if $this->{timeout_timer}; + + $this->{socket} = + $this->{hook} = + $this->{timeout_timer} = + undef; +} + +1; diff -urN tiarra-20040319/tiarra tiarra-20040327/tiarra --- tiarra-20040319/tiarra 2004-03-26 13:04:03.000000000 +0900 +++ tiarra-20040327/tiarra 2004-03-27 19:55:51.000000000 +0900 @@ -5,7 +5,7 @@ # This is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # ----------------------------------------------------------------------------- -# $Id: tiarra,v 1.34 2004/03/07 10:34:19 topia Exp $ +# $Id: tiarra,v 1.35 2004/03/27 10:42:51 topia Exp $ # ----------------------------------------------------------------------------- require 5.006; use strict; @@ -208,14 +208,6 @@ $quiet = &find_option('quiet'); $no_fork = &find_option('no-fork'); -# quietモードならSTDOUTとSTDERRを閉じる。 -if ($quiet) { - close STDOUT; - close STDERR; - #open(STDOUT,"> /dev/null"); - #open(STDERR,"> /dev/null"); -} - my $load_config = sub { local($|) = 1; @@ -255,6 +247,16 @@ $start_runloop->(); }; +# quietモードならSTDIN, STDOUT, STDERRを閉じる。 +# config の read の関連(STDIN)で boot の寸前に。 +if ($quiet) { + close STDIN; + close STDOUT; + close STDERR; + #open(STDOUT,"> /dev/null"); + #open(STDERR,"> /dev/null"); +} + # quietモードであり、且つno-forkオプションが指定されなかったらfork。 if ($quiet && !$no_fork) { my $child_pid = fork;