diff -urN /non-existant-dir/.svnversion tiarra-20080510/.svnversion --- /non-existant-dir/.svnversion 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/.svnversion 2008-05-11 00:25:24.000000000 +0900 @@ -0,0 +1 @@ +11365 \ No newline at end of file diff -urN /non-existant-dir/AUTHORS tiarra-20080510/AUTHORS --- /non-existant-dir/AUTHORS 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/AUTHORS 2008-05-11 00:25:24.000000000 +0900 @@ -0,0 +1,64 @@ +-*- text -*- +$Id: AUTHORS,v 1.1 2004/02/14 08:44:24 admin Exp $ +プログラム: Tiarra +オリジナル開発者: phonohawk + +Authors (敬称略) +=============== + +* tiarra, main/* + +phonohawk: 設計, 殆どのクラスの実装 +Topia: 幾つかのクラスの設計と実装, 多数の改良とバグ修正 + +* module/下、Auto関連 + +Topia: ほぼ全て +phonohawk: (初期バージョンのみ)設計と実装 + +* module/下、Auto以外 + +phonohawk: ほぼ全て +Topia: 幾つかのクラスの設計と実装, 多数の改良とバグ修正 + +* module/System/SendMessage.pm + +Yoichi Imai: 初期設計と実装。 +Topia: 改良 + +* bundle/IO/Socket/INET6.pm + +phonohawk + +* tiarra-conf.el + +phonohawk + +* tiarra-conf.l + +Noboruhi: tiarra-conf.elからの移植 + +* doc/*, doc-src/* + +phonohawk: ほぼ全て +other: モジュールから ./makedoc により自動生成。 + +* アーカイブの作成と配布 + +Topia (2004年10月現在) + +* bundle/ にバンドルされている外部モジュール + (IO/Socket/INET6.pm は除きます。) + +Unicode::Japanese(PurePerl): + Copyright 2001-2004 + SANO Taku (SAWATARI Mikage) and YAMASHINA Hio. + All right reserved. + +=============== +その他、多数の方々よりバグ報告や改良案等を頂き、Tiarraは改善されております。 +この場を借りて感謝の意を申し上げます。 + +- phonohawk - http://ccm.sherry.jp/ +OpenPGP public key: 1024D/1A86EF72 +Fpr: 5F3E 5B5F 535C CE27 8254 4D1A 14E7 9CA7 1A86 EF72 diff -urN /non-existant-dir/ChangeLog tiarra-20080510/ChangeLog --- /non-existant-dir/ChangeLog 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/ChangeLog 2008-05-11 00:25:24.000000000 +0900 @@ -0,0 +1,1999 @@ +2004-08-22 Topia + + * HACKING: + - ModuleManager/*_blacklist, Multicast/attach_for_client, + remark/IRCMessage/always-use-colon-on-last-param, + Hook の使い方を追加。 + + * tiarra: + (shutdown): + - runloop->terminate を使った shutdown を行うようにした。 + - runloop->terminate が失敗した時のために、2度以上 shutdown が + 呼ばれれば強制終了する。 + + * doc-src/conf-main.tdoc, main/Configuration.pm: + - general/messages/quit/netconf-changed-{re,dis}connect を追加。 + + * main/IrcIO.pm: + (disconnect): + - runloop->unregister_receive_socket を呼ぶ。 + + * main/IRCMessage.pm: + (serialize): + - remark/always-use-colon-on-last-param 追加。最後のパラメータの + シリアライズ時に必ずコロンを使うようにする。 + 主にクライアント対策用。 + + * main/ModuleManager.pm: + (add_to_blacklist, remove_from_blacklist, check_blacklist, _set_blacklist): + - blacklist の実装。 + (_clear_module_cache, get_modules): + - blacklist を除いた、使用可能モジュールのキャッシュを作る。 + (terminate): + - mod_timestamp にあるモジュールも destruct/_unload する。 + (check_timestamp_update): + - 共通ルーチンとしてメソッドにした。 + (update_modules): + - blacklist 関連処理と、設定は変更されていないがアップデート + されていて、前回ロード失敗しているモジュールの再試行を追加した。 + (reload_modules_if_modified, _unload): + - blacklist 関連処理の追加。 + + * main/Multicast.pm: + (_NOTICE_from_server): + - 追加。 MODE で代用していると、メッセージとして global nick + のみが送られてきたときに、改変してしまう。 + ($server_sent): + - NOTICE と PRIVMSG を _NOTICE_from_server へ変更。 + (attach_for_client): + - 追加。multi-server-mode のときのみ attach する。 + + * main/RunLoop.pm: + - set-current-nick フックを追加した。 + (_new): + - 一時変数として $conf を追加して見やすくする。 + - terminated_networks, terminating を追加。 + (network): + - networks, disconnected_networks, terminated_networks の各 + ジャンルを順に検索して、最初に見つかったものとジャンル名を返す。 + (set_current_nick): + - set-current-nick フックを呼ぶようにした。 + (_conf, _conf_{general,networks,messages}): + - Configuration::shared_conf->... の短縮形として追加。 + (_cleanup_closed_link): + - unregister_receive_socket を使うようにした。 + - state として reconnecting/terminating/finalizing を受け入れる。 + (_action_{part_and_join,message_for_each}): + - Multicast::attach_for_client を使うようにした。 + (update_networks): + - ->_conf* を使うようにした。 + - state として reconnecting/finalizing を使う。 + (terminate_server): + - 追加。 quit し、 conf 変更がない限り自動再接続しない。 + - state として terminating を使う。 + (reconnect_server): + - 何らかのジャンルにあるネットワークを再接続する。 + (disconnect_server): + - セレクタからの削除は IO->disconnect に任せる。 + (close_client): + - ERROR を送信してクライアントを切断する。 + ({,un}install_socket): + - ->{,un}register_receive_socket を使うようにした。 + ({,un}register_receive_socket): + - 追加。 ->{receive_selector}->{add,remove} を呼ぶだけ。 + (run): + - ->_conf* を使うようにした。 + - ->{,un}register_receive_socket を使うようにした。 + - 終了処理中はクライアントからの接続を受けても即切断する。 + - 終了処理を追加。また、 400 回以上ループを回ったら強制終了する。 + (terminate): + - 全てのサーバ・クライアントを切断する。 + - 終了処理フラグを立てる。 + (apply_filters): + - エラーメッセージを表示するときに、再帰を防ぐために一時的に + ブラックリストに入れる。 + - 処理がまわってきているということはブラックリストにないという + ことなので、そのまま解除しても大丈夫なはず。 + (_apply_filters): + - バージョン管理もしているし、いらないコメントを削除する。 + (notify_msg): + - ->_conf* を使うようにした。 + + * main/TiarraDoc.pm: + (_makeconf): + - 空行のときはインデントしないようにした。 + + * main/Configuration/Preprocessor.pm: + - 解説コメントが間違っているので訂正。 + + * main/IrcIO/Client.pm: + (new): + - runloop->register_receive_socket を呼ぶようにした。 + (username, client_host): + - 追加。プロパティ取得専用。 + (do_namreply): + - ->inform_joinning_channels の中の names 関連処理だけ分けた。 + (inform_joinning_channels): + - ->do_namreply を使うようにした。 + + * main/IrcIO/Server.pm: + - RunLoop 用の ->state を追加。 + (connect): + - runloop->register_receive_socket を呼ぶようにした。 + (quit): + - quit メッセージを送信する。 + + * module/Skelton.pm: + (message_io_hook): + - 過去から現在進行へ修正。 + + * module/Auto/Utils.pm: + (sendto_channel_closure): + - Multicast::attach_for_client を使うようにした。 + + * module/Client/Cache.pm: + - network が存在しないのはあまり特別な事態ではなくなったので、 + debug 時でさえも表示しないようにした。 + + * module/Client/Eval.pm: + - 無意味なリスト生成をやめて、配列をそのまま使うようにした。 + + * module/Client/Rehash.pm: + - 追加。 nick と names による rehash を行う。 + + * module/Log/Channel.pm: + - Log::Writer フレームワークを使うようにした。 + - always-flush 設定を追加。 + - 現在、 dir の都合によりプロトコルを混ぜることはできません。 + + * module/Log/Writer.pm: + - 追加。ログ記録に必要なメソッド(reserve, flush)に限った + マルチプロトコル対応可能なフレームワーク。 + + * module/Log/Writer/Base.pm: + - Log::Writer のプロトコルプラグインのベースクラス。 + + * module/Log/Writer/File.pm: + - Log::Writer の File プロトコルプラグイン。 + - fallback として動作するため、プロトコルを省略したときも + (そして他の fallback によってハンドルされなかったときも) + このプロトコルで処理する。 + - ないディレクトリは勝手に作るので注意。 + + * module/System/Error.pm: + - 追加。 ERROR メッセージをクライアントに送る前に NOTICE に埋め込む。 + - デフォルトオンです。機構的に以前からの conf は救済できません(^^;; + + * module/System/Shutdown.pm: + - シャットダウンメッセージを受け入れるようにした。 + + * module/System/NotifyIcon/Win32.pm: + - iconfile と hide-console-on-load 設定を追加。 + - 他の雑多な機能は 128 文字対応が全然動いてくれない上に、 + 実装自体も全然進んでいないので見送りです。 + + * module/Tools/FileCache.pm: + - use Carp を追加。 + - shared で __PACKAGE__ を使うようにした。 + + * module/Tools/FileCache/EachFile.pm: + - ->{add,del}_refcount を ->{add_ref,release} に変更。 + 内部 API だから影響はないはず。 + +2004-07-29 Topia + + * main/ModuleManager.pm: + - ->notify_error(...) を ->notify_error->(...) と間違えていた + ので修正。 + (reload_modules_if_modified): + - USED に対してメッセージは出しても実際にはリロードして + いなかったので修正。 + (_unload): + - 自分でシンボルテーブルをクリアする代わりに、 Symbol::delete_package を + 使うようにした。ただしサブパッケージは退避している。 + + * main/Timer.pm: + (reset): + - 追加。現在の時刻を元に fire_time を設定しなおす。 + + * main/Module/Use.pm: + (import): + - @USE にそのまま設定する代わりに push をするようにした。 + + * module/Client/Eval.pm: + - いくつか関数を追加。 + (conf, module_manager, module, shutdown, reload) + + * module/System/NotifyIcon/Win32.pm: + - 追加。タスクバーの通知領域にアイコンを表示し、コンソールの + 表示・非表示、 conf リロード、終了などができる。 + +2004-07-24 Topia + + * HACKING: + - Auto::Utils::sendto_channel_closure の説明を追加。 + - remark の説明をいくつか追加。 + - Emacs で自動的に text-mode になるようにした。 + (Local variables) + + * Makefile: + - 間違っているコメントを削除した(etags/update もするし)。 + - ターゲット名を clean に変えた。 + - clean の一行目だけでも sh で通るようにした。 + + * main/ControlPort.pm: + - SelfLoader が動作しない例の一つだった。修正もれ。 + コメントアウトして対処した。 + + * module/Auto/Utils.pm: + - いくつか説明コメントを修正。 + (sendto_channel_closure): + - $sender が省略されれば自分で調査して送信する。 + ($sendto, $command) だけで呼べるようになった。 + - シングルサーバモード時の処理をしていなかったので修正。 + +2004-07-09 phonohawk + + * module/Auto/Reply.pm, + module/User/ServerOper.pm, + module/User/Vanish.pm: + typoの訂正。動作に変更は無い。 + +2004-07-08 Topia + + * main/Configuration.pm: + - include されたファイルの更新も感知するようにした。 + + * main/Mask.pm: + (_split): + - $mask が未定義の時に warning がでるのを防止した。 + + * main/ModuleManager.pm: + (reload_modules_if_modified): + - エラー通知に notify_error を使うようにした。 + + * main/ReloadTrigger.pm: + - Configuration::Hook/reloaded について追記。 + + * main/Timer.pm: + - notify_error の発行対象にしているパッケージの間違いを修正。 + + * main/Configuration/Preprocessor.pm: + - ->included_files を追加。 + + * main/IrcIO/Client.pm: + (_receive_while_logging_in): + - $network が未定義(未接続)の時にエラーがでていたので修正。 + (inform_joinning_channels): + - 固定チャンネルの mask は一致した分を全部飲み込むように変更。 + #*@ircnet,#*@ircnet:* のようなことが出来るようになるはず。 + + * module/System/Reload.pm: + - conf-reloaded-notify を追加。 + +2004-06-19 Topia + + * doc-src/conf-main.tdoc: + - ./tiarra --make-password のことを書き加えた。 + + * main/Timer.pm: + - code 中で die が起こっても abort しないようにした。 + + * module/Channel/Mode/Oper/Grant.pm: + - $myself が undef でないかチェックするようにした。 + + * module/Client/Cotton.pm: + - 追加。いくつかの Cotton の不具合を回避する(予定)。 + - 今は network rejoin 時の自動 part を無視する。 + + * module/Client/Eval.pm: + - runloop に括弧を付け(て関数形式に認識させ)るのを + 忘れていたので修正。 + + * module/Client/GetVersion.pm: + - 追加。クライアントの接続時に CTCP Version を発行して + クライアントのバージョンを取得する。 + +2004-06-09 Topia + + * main/IrcIO/Server.pm: + (_receive_while_logging_in): + - PING に対応した。 + - RPL_WELCOME / NOTICE / PRIVMSG 以外で無視することになった場合、 + 警告を出す。 + +2004-06-04 Topia + + * main/IRCMessage.pm: + - MAX_PARAMS(= 14) 定数を追加した。 + (params): + - 呼び出し時に未定義なら強制的に初期化するようにした。 + (n_params): + - params を使用するようにした。 + (_parse): + - $this->push を使用するようにした。 + (length, push, pop): + - 追加した。 + + * main/IrcIO/Client.pm: + (_receive_while_logging_in): + - シングルサーバモード時にサーバから RPL_ISUPPORT が提供されていれば、 + それを送信するようにした。 + + * module/Client/Cache.pm: + - MODE キャッシュ、 WHO キャッシュともに、取得中フラグに有効期限を + つけるようにした。デフォルトで 5 分、 conf では指定できない。 + - 念のため RPL_ENDOFWHO もハンドリング。 + + * module/Client/Eval.pm: + - メッセージを再構築して、 : をつけなくても良いようにした。 + もちろん ::shutdown を実行するには /eval :::shutdown と + しなければならない(笑)。 + - $err を初期化して warning が出ないようにした。 + (network, runloop): + - eval 内部からよく使いそうなものを function 化した。 + + * module/System/Raw.pm: + - 配列の最後の要素は (n_params - 1) なので修正して warning が + でないようにした。 + +2004-06-04 phonohawk + + * main/Unicode/Japanese.pm: + Unicode::Japanese 0.22に更新。 + +2004-05-26 phonohawk + + * main/Unicode/Japanese.pm: + Unicode::Japanese 0.21に更新。 + +2004-05-09 phonohawk + + * main/IrcIO.pm (receive): + サーバーやクライアントから空行を送られた場合に、エラーが出る問題を修正。 + +2004-05-09 Topia + + * main/Multicast.pm: + (nick_p): + - 省略可能な nicklen を引数に追加した。 + (channel_p): + - 省略可能な chantypes を引数に追加した。 + + * main/IrcIO/Server.pm: + - isupport を remark からインスタンス変数に変更した。 + (nick_p, channel_p): + - 追加した。 ISUPPORT として NICKLEN, CHANTYPES が指定されていた + 場合にそれを使って検査する。 + (_set_to_next_nick): + - 簡略化した。 + +2004-05-08 Topia + + * HACKING: + - typo を修正した。 + - IrcIO::Server->remark に isupport と uid を追加した。 + - ChannelInfo->remark に creation-time を追加した。 + + * main/Multicast.pm: + - $server_sent, $client_sent: RPL_CREATIONTIME へ対応した。 + - $client_sent: admin コマンドを追加した。 + + * main/NumericReply.pm: + - RPL_BOUNCE を RPL_REDIR に変更。 RPL_BOUNCE はエイリアスとして + そのまま残すようにした。 + - RPL_CREATIONTIME を追加した。 + - RPL_TOPICWHOTIME を RPL_TOPIC_WHO_TIME に変更した。 + RPL_TOPICWHOTIME はエイリアスとしてそのまま残すようにした。 + - irc2.11 なものをいくつか追加した。 + + RPL_HELLO(020) + + RPL_YOURID(042) + + RPL_SAVENICK(043) + + RPL_REOPLIST(344) + + RPL_ENDOFREOPLIST(345) + + * main/IrcIO/Server.pm: + - RPL_{CREATIONTIME,ISUPPORT,YOURID} に対応した。 + (_receive_while_logging_in): + - RPL_HELLO 対策を追加した。 + (modify_nick): + - 第二引数で nicklen を指定できるようにした。 + (_set_to_next_nick): + - ISUPPORT に NICKLEN が含まれていれば、それを使うようにした。 + + * module/Client/Cache.pm: + (_send_mode_cache): + - creation-time が存在すれば、それも返すようにした。 + +2004-04-18 Topia + + * HACKING: + - BulletinBoard と remark についてを追記。 + - こまかい修正。 + + * main/IrcIO/Client.pm, module/Client/Cache.pm: + - __PACKAGE__ がダブルクォートの中では展開されないことを + 忘れていたので修正。 + + * module/Channel/Rejoin.pm: + - 自分自身がいないチャンネル(そもそもふつうはこんなことには + ならないのだが)の rejoin 判定時に error が起きるのを修正。 + +2004-04-18 phonohawk + + * main/ControlPort.pm (ControlPort::Session::main): + 誤字修正。 NOTIFT => NOTIFY + +2004-04-07 phonohawk + + * main/IrcIO/Server.pm (new): + $this->{channels}のキーを、小文字に変換しておく。 + + 大文字小文字に一貫性の無いチャンネル名をクライアントに送る、 + EFnetやFreenet(IRC)のようなircdに接続していると、しばしば + Tiarraは混乱する。この問題を回避するため、チャンネル名同士の + 比較は一旦小文字に変換した上で行うようにする。 + + (channel): + 大文字小文字を無視してチャンネルを探索するように変更。 + $server->channel($name)のようにしてChannelInfoを得ている + 場合には、何ら変更は必要無い。 + + チャンネル名 => ChannelInfoのハッシュを返す、$server->channels + を使っている場合は、そのキーが小文字に変換されている事に注意しなければ + ならない。 + + * main/Multicast.pm (lc, uc): 追加 + IRC方式で大文字と小文字の変換を行う。IRC方式とは、[]\がそれぞれ{}|の + 大文字であると定義されている方式である。 + + * main/Mask.pm (compile): 追加 + マスクからコンパイル済み正規表現を生成する部分を、独立した関数にした。 + 大量のマッチングを高速に行う場合は、Mask::の関数を何度も呼ぶ代わりに + マスクを一度だけコンパイルする事を考えた方が良い。 + Mask.pm内でコンパイル済みマスクはキャッシュしているが、それでも速度は違う。 + + +2004-04-01 Topia + + * module/Client/Cache.pm: + - single-server-mode 時の不具合をいろいろ修正。 + - mode/who に共通な一部のコードを関数リファレンスの形でまとめた。 + +2004-04-01 phonohawk + + * tiarra: + confファイルが読み込まれる前に::printmsgを実行するとdieする問題を回避。 + そのような場合には、文字コード変換を行わない。 + +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: + - IO::Handle 1.21 において、 LEN が存在しないと croak がでる bug + の回避。 + + * main/ModuleManager.pm: + - モジュールの destruct を呼ぶ際に、 $show_msg でなく + RunLoop->shared_loop->notify_error を使うように。 + + * main/IrcIO/Client.pm: + (inform_joinning_channels): + - フックの引数を変更。 + - フックコール中にエラーが発生しても + 最低限すべてのチャンネル情報だけは送信するように。 + + * module/Client/Cache.pm: + - IrcIO::Client::Hook/channel-info を使用して、 + 知っているチャンネルモードを強制的に先行して送るようにした。 + + * module/Log/Recent.pm: + (IrcIO::Client::Hook/channel-info): + - 引数変更に同期。 + - クライアントオプション no-recent-logs をみるようにした。 + +2004-03-13 phonohawk + + * main/Hook.pm (Hook::call, HookTarget::call_hooks): + フック関数に引数を渡せるように変更。 + + * main/RunLoop.pm: + Hook.pmで一般化したためにコメントアウトしてあったフック関連のコードを削除。 + + * main/IrcIO/Client.pm (inform_joinning_channels): + チャンネル情報一つ転送される度に呼ばれるフック channel-info を定義。 + このフックには引数としてIrcIO::Client自身とチャンネル名が渡される。 + フッククラスは同ファイルで定義されるIrcIO::Client::Hook。 + + * module/Log/Recent/pm: + クライアントに送られるチャンネルと同じ順番でログも送るように変更。 + この動作はIrcIO::Clientのフックを利用している。 + + * main/RunLoop.pm (run): + Tiarra暴走検出のコードにバグがあったので修正。 + 0秒selectに2秒以上の間隔が開いた場合にはカウンタをリセットする意図があったと思うが + 2秒*以下*の間隔でリセットしていた。 + ついでなので警告の閾値も300まで引き上げ。 + +2004-03-09 Topia + + * module/Client/Cache.pm: + - destruct において、呼ぶメソッドを勘違いしていたのを修正。 + +2004-03-08 phonohawk + + * module/Unicode/Japanese.pm: + UniJP 0.20に置換え。 + +2004-03-07 Topia + + * tiarra: + - untaint を行うようにした。 + + * main/Configuration.pm: + - 呼び出す関数名を間違えていた bug を修正。 + + * main/Mask.pm: + - untaint を行うようにした。 + + * main/Multicast.pm: + - ERR_NOTONCHANNEL, ERR_NOSUCHCHANNEL を *_sent に追加。 + + * main/IrcIO/Server.pm: + - nick 変更の prefix category を nick::system にした。 + - _START_WHOIS_REPLY を呼ぶときに defined check をしてない bug + を修正。 + + * module/Client/Cache.pm: + - destruct を追加。 + - ChannelInfo につける remark にパッケージ名をつけて、 + 他のモジュールとかぶらないようにした。 + + * module/Client/Eval.pm: + - untaint を行うようにした。 + - 複数行の出力をちゃんと処理するようにした。 + +2004-02-23 Topia + + * module/Debug/RawLog.pm: + - 追加。生の IRC メッセージ(のようなもの?)を ::printmsg を使って + 表示する。 + + * main/IrcIO/Client.pm: + - RunLoop を Runloop と typo していたのを修正。 + + * main/IrcIO/Server.pm: + (_received_after_logged_in, _set_to_next_nick): + - sysmsg_prefix を使うようにした。 + (_RPL_CHANNELMODEIS): + - 存在しないチャンネルが対象だったときにエラーがでるという + どうしようもないミスを修正。 + + * main/RunLoop.pm: + (_multi_server_mode_changed): + - sysmsg_prefix を使うようにした。 + + * makedoc: + - sample.conf を出力するようにした。 + - 全体にわたってモジュール名のソートを行うようにした。 + - block 構文への暫定対応。 + - #key:value という *コメント* をきちんと認識していなかったのを fix + - グループ名に説明が定義されていなかったときに警告を出すようにした。 + + * tiarra: + - --enable-debug 時にも、 couldn't connect 関連のメッセージなら + スタックトレースを省略するようにした。 + + * sample.conf: + - TiarraDoc を使用するようになった。 + + * doc/module-toc.html, doc/module/*.html: + - regen. + + * doc-src/conf-main.tdoc: + - general/omit-sysmsg-prefix-when-possible 削除。 + - general/sysmsg-prefix-use-masks ブロック追加。 + - 書かれていなかった networks/multi-server-mode の解説を + sample.conf から持ってきて追加。 + - typo したままだった networks/channel-network-separator の + コメントを sample.conf に従って修正。 + - ircnet/host を irc.nara.wide.ad.jp に変更。 + いまは停止しているのだが、復活を願うということで。 + + * doc-src/module-group.tdoc: + - Channel の最後が typo していたのを修正。 + - Client, CTCP, Debug を追加。 + とはいえ Debug はまだ cvs repo. には存在していないが…。 + + * doc-src/sample.conf.in: + - RCS Tag 'Id' を追加。 + + * main/Configuration.pm: + - general/omit-sysmsg-prefix-when-possible のデフォルト値を消して、 + general/sysmsg-prefix-use-masks のデフォルトブロックを追加。 + (_complete_table_with_defaults): + - _complete_{table,block}_with_defaults に分割。 + (_complete_table_with_defaults): + - Block を使った実装に変更。 + - Configuration::Block->table の追加が必須。 + (_complete_block_with_defaults): + - block(hash_ref) と array_ref のデフォルト値に対応。 + + * main/ModuleManager.pm: + (update_modules): + - %loaded_mods に古いモジュールが無かった場合は無視するようにした。 + (_unload): + - デバッグモード時でも、同じモジュールからの 11 以上の export は表示しない。 + + * main/Multicast.pm: + - $server_sent, $client_sent: NumericReply 化。 + ERR_TOOMANYCHANNELS と RPL_WHOISCHANNELS を追加。 + (_NJOIN_from_server, _RPL_NAMREPLY): + - /[@+]/ が変数展開されているようなので /[\@+]/ に変更。 + (_WHOIS_from_client): + - RunLoop->shared_loop->sysmsg_prefix を使用するようにした。 + (_{attach,detach}_RPL_WHOISCHANNELS): + - 追加。 WHOIS で表示されるチャンネル名に network をつける。 + + * main/RunLoop.pm: + - sysmsg_prefix を追加。 + (_action_one_message, _action_message_for_each, notify_msg): + - RunLoop->shared_loop->sysmsg_prefix を使用するようにした。 + + * main/TiarraDoc.pm: + (_makeconf): + - block への暫定対応。 + + * main/Configuration/Block.pm: + - ->table を追加。 + (eval_code): + - original の typo を修正。 + + * main/IrcIO/Client.pm: + - RunLoop->shared_loop->sysmsg_prefix を使用するようにした。 + (inform_joinning_channels): + - 暫定的に networks/fixed-channels ブロックに channel の mask を + 書くことで、送信順を指定できるようにしたが、 conf エントリ名が + 気に入らないため、名前が決まるまでは sample.conf に + 書かないことにする。 + + * main/IrcIO/Server.pm: + - ->server_hostname を追加。 RPL_WELCOME(001) で送られてきた + サーバ名を保持する。 + - サーバで nick 変更が起こったときに、以前の nick も表示するようにした。 + + * module/Auto/Reply.pm: + - 返答時に mask をチェックするようにした。 + + * module/Channel/Freeze.pm: + - RunLoop->shared_loop->sysmsg_prefix を使用するようにした。 + - 不要になった use Configuration; を削除。 + + * module/Client/Cache.pm: + - RunLoop->shared_loop->sysmsg_prefix を使用するようにした。 + - WHO キャッシュ送信時において、 Multicast::global_to_local を + 使って nick を変換していなかった bug を修正。 + - 不要になった use Configuration; を削除。 + + * module/Client/Eval.pm: + - RunLoop->shared_loop->sysmsg_prefix を使用するようにした。 + - 無用な remark('fill-prefix-when-sending-to-client') をなくした。 + + * module/Log/Recent.pm: + - no-recent-logs クライアントオプションを追加。 + - RunLoop->shared_loop->sysmsg_prefix を使用するようにした。 + - 不要になった use Configuration; を削除。 + + * module/System/Pong.pm: + - NumericReply 化。 ERR_NOORIGIN を返せるようにした。 + - PING もここで破棄するようにした。 + (message_arrived): + - $sender->server_hostname を使用して正確なホスト名に返す。 + + * module/System/Raw.pm: + - RunLoop->shared_loop->sysmsg_prefix を使用するようにした。 + - NumericReply 化。 NOTICE の代わりに ERR_NEEDMOREPARAMS を返す。 + - 不要になった use Configuration; を削除。 + + * module/User/Ignore.pm: + - sample conf の mask に例示用ドメインを使用するようにした。 + + * module/Auto/Alias.pm, module/Auto/Answer.pm, + module/Auto/ChannelWithoutOper.pm, module/Auto/Joined.pm, + module/Auto/MesMail.pm, module/Auto/Oper.pm, + module/Auto/Random.pm, module/Auto/Reply.pm, + module/Auto/Response.pm, module/CTCP/*.pm, + module/Channel/*.pm, module/Channel/Join/Invite.pm, + module/Channel/Join/Kicked.pm, module/Channel/Mode/*.pm, + module/Channel/Mode/Oper/Grant.pm, module/Log/Recent.pm, + module/System/Macro.pm, module/System/Pong.pm, + module/System/Raw.pm, module/System/RemoteControl.pm, + module/System/Shutdown.pm, module/User/Filter.pm, + module/User/ServerOper.pm, module/User/Vanish.pm, + module/User/Away/Client.pm, module/User/Away/Nick.pm, + module/User/Nick/Detached.pm: + - TiarraDoc 化。 sample.conf から取ってきて一部まずいところは + 変更している。 + +2004-02-21 phonohawk + + * module/Channel/Freeze.pm: + freezeコマンドの引数は、これまでは完全なチャンネル名であったが、 + これはマスクに変更。その時にJOINしている全てのチャンネルの中から + マスクに一致した全てのチャンネルを凍結する。 + + * sample.conf, doc-src/conf-main.tdoc: + 設定 general/omit-sysmsg-prefix-when-possible 追加。 + これが1である時、sysmsg-prefixはチャンネルに対してのメッセージ + でなければ省略する。デフォルトは1。 + + * main/Configuration.pm: + general/omit-sysmsg-prefix-when-possible のデフォルト値を追加。 + + * main/Multicast.pm, main/RunLoop.pm, + main/IrcIO/Client.pm, module/Channel/Freeze.pm, + main/Log/Recent.pm, module/System/Raw.pm: + omit-sysmsg-prefix-when-possibleを反映。 + +2004-02-15 Topia + + * module/Client/Cache.pm: + - message_io_hook を追加。サーバとの通信を監視して、 + MODE や WHO を発行(して返答をもらっている)途中かどうかを + 記憶しておくように。 + - message_io_hook で記憶した情報を使って、 + (ほかのクライアントなどによって)サーバに情報を問い合わせている + 途中の時も、メッセージを破棄するようにした。 + 2つ以上のクライアントが同時につながったときに効果が出るはず。 + テストには LimeChat を 3 つ同時に接続させたが、 + サーバへの問い合わせは各チャンネルにつき1回までに抑えられていた。 + - クライアントに伝達される必要のあるメッセージではないので、 + RunLoop->shared_loop->notify_warn() if ::debug_mode; から + ::debug_printmsg(); に変更。 + - WHO キャッシュにおいて、 + データ不足であきらめたときのメッセージ表示をやめた。 + +2004-02-14 Topia + + * 全般: + (a) NumericReply を使うようにした。 + (b) general/sysmsg-prefix を使うようにした。 + + * doc-src/conf-main.tdoc, sample.conf: + - sysmsg-prefix を追加。 + + * sample.conf: + - Client::Eval と Client::Cache を追加。 + + * main/ChannelInfo.pm: + - mode_string method を追加。 + + * main/Configuration.pm: + - general/sysmsg-prefix のデフォルト値を追加。 + + * main/IRCMessage.pm: + - clone(deep => 1) を追加。 + - s/unvalid/invalid/; fix typo. + - $this->[PARAMS] がそもそも未定義なときは、 + n_params は中身なし配列の長さ(=0)を返すようにした。 + + * main/ModuleManager.pm: + - module の reload の時に、一時的に $this->{modules} の + 該当箇所に undef を入れて実行されないようにした。 + (main/RunLoop.pm の変更とセットです。) + + * main/Multicast.pm: (b) + - シングルサーバモードで、どこのネットワークにも + 繋がっていないときは、デフォルトネットワークに + $networks->default を使うようにした。 + + * main/NumericReply.pm: + - irc2.10.3p5+hemp2 に合わせた。 + ISUPPORT は使用する設定。 + - fetch_number(名前から番号), fetch_name(番号から名前) + のそれぞれを得る関数を追加した。 + + * main/PersonInChannel.pm: + - priv_symbol method (privilege symbol) を追加。 + has_[ov] の状態によって、 @, +, 空文字列のどれかを返す。 + + * main/PersonalInfo.pm: + - AWAY を追加。できるだけ更新しますが、 + 性質上情報の正確さは保証できません。 + + * main/RunLoop.pm: (b) + - single-server-mode 時に、切断・接続のアナウンスの + 送信先チャンネル名からネットワーク名をはずすようにした。 + - サーバへの接続処理時に、 couldn't connect to 以外の + エラーメッセージ表示には notify_error を使うようにした。 + - クライアントからの接続処理時は、エラーメッセージ表示に + notify_msg を使うようにした。 + - apply_filters で、 modules_list の中に undef が出てきたら、 + それを無視するようにした。 + (main/ModuleManager.pm の変更も参照。) + + * main/IrcIO/Client.pm: (a)(b) + - credit を RPL_YOURHOST でなく MOTD として表示するようにした。 + - RPL_YOURHOST では、 Tiarra のバージョンを表示する。 + + * main/IrcIO/Server.pm: (a) + - _RPL_* の処理を NumericReply::fetch_name を使ってまとめた。 + - _START_WHOIS_REPLY, _RPL_ENDOFWHOIS, _RPL_AWAY を追加。 + - _RPL_WHOREPLY + + 空白を含む realname に関するバグを修正。 + + away 情報を記憶するようにした。 + + server hop 情報を network の 'server-hops' remark に保存。 + - _RPL_CHANNELMODEIS で、 switches と parameters の情報は + この reply で得られると決めつけて、クリア処理を行う。 + + * module/Channel/Freeze.pm: (b) + + * module/Channel/Rejoin.pm: (a) + - ChannelInfo->mode_string を使用するようにした。 + + * module/Channel/Join/Connect.pm: + - コンマの直後にスペースがあった場合、削除する処理が、 + 最初の一つに対してしか実行されていなかったのを修正…(^^;;; + + * module/Client/Cache.pm: + - 追加。いまのところ MODE キャッシュと、 WHO キャッシュを実装。 + + * module/Client/Eval.pm: + - 追加。クライアントからのコマンドしか受け付けないが、 + その代わりすべてのコマンドを実行できる。 + 事実上 IRC パスワードがわかれば Tiarra が動いているホスト上で + 動作しているアカウントの権限で何でもできる、 + ということに注意すること。 + + * module/Log/Recent.pm: (b) + - network name が不正な場合は、 notify_warn で警告して、 + エラーなしに抜けるようにした。 + + * module/System/Pong.pm: + - prefix がついているのは不自然だったので、削った。 + + * module/System/Raw.pm: (b) + + * module/Tools/LinedDB.pm: + - ファイルが存在しない場合に、 + 更新チェック部分でエラーが発生していたのを修正。 + +2004-02-04 phonohawk + + * main/IrcIO.pm, main/IrcIO/*.pm, main/Module.pm: + notification_of_message_ioを削除。 + + * main/Module.pm (message_io_hook): + 追加。これはnotification_of_message_ioの代わりに呼ばれる。 + このメソッドはメッセージを改変する事が出来る。詳しくはコメントに。 + + * main/IrcIO.pm (send_message, receive): + 各モジュールのmessage_io_hookを呼ぶ。 + + * main/RunLoop.pm (apply_filters): + 追加。モジュールによるメッセージフィルタリングの一般形。 + +2004-01-27 phonohawk + + * main/NumericReply.pm: 追加 + ニューメリックリプライをシンボルとして定義するクラス。 + useで全シンボルをエクスポート。 + + * main/IrcIO.pm: + CRが無く、LFだけで終わっているメッセージも受け入れる。 + +2004-01-23 Topia + + * tiarra: $0 自体が symlink だったときに、@INC に symlink 先の + main/module を含めるようにした。 + カレントディレクトリ・$0 のディレクトリは常に含むようにした。 + (make_password): --make-password=password を可能にした。 + +2004-01-23 phonohawk + + * tiarra: 起動時オプション --make-password 追加。 + make-passwordの機能をtiarra本体に移した。 + + * make-password: 削除 + +2004-01-20 phonohawk + + * main/Unicode/Japanese.pm: + 同梱のUniJPを0.18から0.19に。JISの問題は解決。 + +2004-01-14 phonohawk + + * main/Mask.pm: + マスクから作った正規表現をqrでコンパイルする際、 + iフラグを付け忘れて大文字小文字の区別が*されていた*ので修正。 + + * main/IRCMessage.pm (_parse): + 空文字列については文字コード変換処理を明示的に省略する。 + Unicode::JapaneseにはISO-2022-JP→UTF-8変換において空文字列を"\x00"にしてしまう問題あり。 + +2003-11-17 Topia + + * tiarra: enhancement. + パッケージ用にいくつかのバージョン変数を追加した。 + + * module/Log/Channel.pm: enhancement/need reload. + + デフォルトのログファイルパーミッションを 644 から 600 にした。 + ディレクトリ作成時のパーミッションを指定できるようにした。(dir-mode) + デフォルトは 700 。 + + * tiarra: enhancement. + + --dumpversion を追加した。 + パッケージ作成時にバージョン情報を得るため等に使う予定。 + +2003-11-09 Topia + + * module/System/Reload.pm (message_arrived): bugfix/need reload. + + Timer を使って遅延処理することによって、reload command での + 自分自身のリロードを可能にした。 + + * main/RunLoop.pm (run): bugfix(single-server-mode)/need reboot. + + single-server-mode 時の、クライアントから送られて来た + PRIVMSG/NOTICE のブロードキャストで、 network-suffix 付きの + チャンネルに送信してしまっていた。 + +2003-11-09 phonohawk + + * tiarra (help): + メッセージ中のstdinとstderrの間違いを修正。 + +2003-11-08 Topia + + * make-password: enhancement. + + パスワードの入力に、 Term::ReadLine を使用するようにした。 + + * module/Log/Recent.pm (client_attached): bugfix(single-server-mode)/need reload. + + single-server-mode 時に、送信チャンネル名から network-suffix + をはずす。 + + * main/RunLoop.pm (run): bugfix(single-server-mode)/need reboot. + + single-server-mode 時に、クライアントから送られて来るメッセージに + network-suffix を付けるようにした。 + +2003-10-25 phonohawk + + * main/IRCMessage.pm (serialize): + 最後のパラメータが空文字列だった場合、コロンを残さない為に + シリアライズ後のパラメタが減ってしまう問題を解決。 + + * main/IrcIO/Server.pm (_receive_while_logging_in): + サーバーがERRORを返した時、その内容でdieするように。 + +2003-10-24 phonohawk + + * main/Configuration/Block.pm: + $block->foo_bar('block') とした時、戻り値が常にブロックとなる。 + 未定義であれば空のブロックを、既定義かつ値がブロックであれば + そのブロックを、既定義かつ値がブロックでなければキーと値のペアを + 一つだけ含むブロックを生成して返す。 + +2003-10-19 Topia + + * HACKING: + モジュール作成者向けのドキュメントを書いた。 + まだ、Timer / Hook / Socket I/O 関連の記述がない。 + + * module/Skelton.pm: + 新規モジュールのスケルトン。中身のほとんどは main/Module.pm と同一。 + + * module/Auto/Alias.pm (message_arrived): + 返り値がおかしかったのを修正。 + +2003-10-19 phonohawk + + * main/IrcIO/Server.pm + (person_if_exists): + 追加。指定されたnickを持つ人物が居れば、そのPersonalInfoを返す。 + (_RPL_WHOREPLY): + サーバー名とnickの位置を間違えていたので修正。 + +2003-10-16 phonohawk + + * module/System/Raw.pm: + 追加。Tiarraに改変されない生のメッセージをサーバーに送るためのモジュール。 + + * main/RunLoop.pm (update_networks): + confからサーバー名を削除する事でサーバーから切断した時に、 + そのサーバーで入っていた全てのチャンネルに対するPARTを全クライアントへ送る。 + +2003-10-14 Topia + + * main/Multicast.pm (distribute_to_servers): + hijack_forward_to_server を適用(nickで使う) + + * main/RunLoop.pm (_multi_server_mode_changed): + nick 変更を追加。 + + * main/IrcIO/Server.pm (_receive_while_logging_in): + single-server-mode 時の NICK 処理を追加。 + + * main/IrcIO/Server.pm (_receive_after_logged_in): + single-server-mode 時の NICK 処理に RunLoop/set_current_nick を追加。 + 437 での if 条件であほなミスをしていたので修正。 + +2003-10-12 phonohawk + + * main/IRCMessage.pm (serialize): + 最後のパラメータがコロンを含んでいる時に、間違った文字列化をする問題を解決。 + +2003-09-28 phonohawk + + * tiarra-conf.el: + mmm-modeがインストールされていて、(require 'mmm-mode)または + (require 'mmm-auto)されている場合に、tiarra-conf用の設定を + 行った後、それを有効にする。 + + mmm-modeのサイトは次のURLに。 + http://mmm-mode.sourceforge.net/ + + * main/PersonalInfo.pm (remark): + 追加。 + これを保存するためのhashは、必要になった時まで作られない。 + +2003-09-26 Topia + + * tiarra: + --debug 時に warn と die に長いスタックトレースを表示する。 + + * main/ChannelInfo.pm: + topic_who と topic_time を追加。 + エラーメッセージのミスを修正。 + + * main/Multicast.pm: + RPL_TOPICWHOTIME の追加。 + hijack_local_to_global 時のフォールバック条件を訂正。 + + * main/IrcIO/Client.pm: + 431 No nickname given の実装。 + multi-server-mode でないときには nick 関連の特殊処理をしないように。 + RPL_TOPICWHOTIME の実装。 + + * main/IrcIO/Server.pm: + 437 nick/channel is temporarily unavailable に対応。 + multi-server-mode でないときには nick 関連の特殊処理をしないように。 + RPL_TOPICWHOTIME の実装。 + 9文字以上のnickが来たときに、可能な限り必要以上短くしないように。 + +2003-09-25 Topia + + * tiarra: + --version と --debug の実装。 + ::debug_printmsg(...), ::debug_mode を使用できます。 + ::printmsg への autoflash 指定を追加。 + + * main/ModuleManager.pm: + (update_modules): $this->{modules} の再構成を、アンロード前に移動。 + notification_of_message_io の呼び出しでエラーが発生するのを回避。 + (_load): デバッグモード時に UNIVERSAL::isa が嘘を付いた場合、 + 標準出力に出力する。 + (_unload): + no strict の場所を変更。 + シンボルテーブル内に存在する関数のうち、 + 自分自身が定義した訳ではない関数は undef しないようにした。 + デバッグモードなら、 undef したスカラ・配列・シンボルテーブル・関数、 + undef しなかった関数、に付いてそれぞれ標準出力に出力する。 + + * module/Channel/Join/Connect.pm: + コンマの直後にあるスペースは削除するようにした。 + TiarraDoc を追加。 + + * module/Tools/FileCache.pm: + destruct メソッドを実装。 + RCSタグを標準のものにした。 + + * module/Tools/GroupDB.pm: + Module::Use が抜けていたので追加。 + RCSタグを標準のものにした。 + + * sample.conf: + Channel::Join::Connect の ブロックを TiarraDoc から再生成。 + 指定項目の変化はありません。 + +2003-09-24 phonohawk + + * main/Multicast.pm (nick_p): + 「|」を含むnickをnickと認識していなかったので修正。 + + * module/Log/Recent.pm: + configのcommandを小文字で書くとログが取られない問題を解決。 + +2003-09-23 phonohawk + + * main/ModuleManager.pm: + use Module::Useされたサブモジュールが破棄される時に、 + そのパッケージの destruct メソッドを引数無しで呼ぶ。 + + * main/Mask.pm: + メモリを食い過ぎるので、コンパイル済み正規表現の + キャッシュ保存数を150個に減少。 + + * main/PersonalInfo.pm: + メソッドinfoに引数として真偽値を渡した時、 + それが真であればnickとnameとhostの配列を返す。 + wantarrayにすると互換性が失われるため。 + + * main/PersonalInfo.pm: + 動作速度向上のため、AUTOLOADを廃止。 + + * module/Log/Channel.pm: + configのcommandを小文字で書くとログが取られない問題を解決。 + +2003-09-20 phonohawk + + * main/ChannelInfo.pm, main/IRCMessage.pm, + main/PersonInChannel.pm, main/PersonalInfo.pm, + main/Configuration/Block.pm: + これらのクラスはオブジェクトが大量に作られるので、 + メモリの節約のためにインスタンス型を配列に変更。 + + * main/IrcIO.pm: + メソッド remarks を remark のエイリアスに。 + $io->remark(foo => undef); のように明示的にundefを設定すると + その註釈を削除。 + + * IrcIO/Server.pm: + remarkをIrcIO.pmに移動したので、こちらは削除。 + + * main/L10N.pm: + * main/LocalChannelManager.pm: + 未完成であり、まだ使われてもいないが、存在しても害は無い。 + それぞれ多言語メッセージとTiarra内部チャンネルを扱う。 + + * main/Mask.pm: + マスク文字列から変換した正規表現のコンパイル結果をキャッシュとして保存するように。 + 大量のマスクを扱う条件下で動作が非常に重くなる問題を回避する。 + ベンチマークの結果では、62.5%のマッチング速度の向上が見られた。 + +2003-08-18 Topia + + * main/Multicast.pm: + ${server,client}_sent に ENDOFWHO を追加。 + これで LimeChat などのクライアントで、 + アドレスコピーなどの機能が使えない症状が無くなった。 + $client_sent の numeric reply にコメントを補完。 + +2003-08-12 phonohawk + + * main/FunctionalVariable.pm: + 追加。与えられた任意のハンドラを変数にtieする。 + 通常のtieとの違いは、ハンドラを変数毎に関数リファで指定する点。 + + * main/Hook.pm: + フックの一般的な定義。このファイルはクラスHookとクラスHookTargetを定義する。 + + * main/Configuration.pm: + リロードした時、フック`reloaded'を呼ぶ。 + + * main/Multicast.pm: + シングルサーバーモード対応。 + forward_to_serverやlocal_to_globalを動的スコープのフラグで乗っ取る等、 + 最早スパゲティどころではない。ジャングル。 + + * main/RunLoop.pm: + シングルサーバーモード対応。 + このモードでは、同時に接続出来るサーバーの数が一つに限定され、 + チャンネル名等にネットワーク名が付加されなくなる。 + + * main/IrcIO/Client.pm: + _inform_joinning_channelsをプライベートメソッドでなくした。 + 新しいメソッド名はinform_joinning_channels。 + +2003-08-04 phonohawk + + * makedoc: + 追加。このスクリプトはdoc-src下のファイルとmodule下のモジュール、 + main下のモジュールを読み、tdoc形式で書かれたドキュメントを認識し、 + sample.confおよびdoc下のhtmlドキュメントを生成する。 + tdocについてはdoc-src/READMEを参照。 + 尚、各モジュールへのtdocの記述が完了していない為、 + 完全なsample.confは生成出来ない。完了するまではsample.confでなく + sample.conf.tmpに書き出す。 + + * doc-src/README: 追加。tdocについての説明。 + + * doc-src/conf-main.tdoc: 追加。generalやnetworksのドキュメント。 + + * doc-src/contents.html: 追加。htmlドキュメントのテンプレート。 + + * doc-src/module-group.tdoc: 追加。モジュールの分類情報。 + + * doc-src/module-toc.html: 追加。モジュールの目次のhtmlテンプレート。 + + * doc-src/sample.conf.in: 追加。sample.confのテンプレート。 + + * main/Template.pm: 追加。テンプレートを扱うクラス。 + + * main/TiarraDoc.pm: 追加。tdocパーサ。 + + * module/System/PrivTranslator.pm + * module/User/Ignore.pm: tdoc追加。 + +2003-07-31 Topia + + * 全般: + ・インデントの変更 + ・コメントの整備 + ・mask で使うチャンネル名をネットワーク付きに修正(a) + ・不要な use のクリーンアップ(b) + ・不要な変数のクリーンアップ(c) + + * Auto/Oper.pm: + (a) + + * Auto/Random.pm: + (a)(b) + + * Auto/Reply.pm: + (a)(b)(c) + + * Auto/MesMail.pm: + (b)(c) + + * Auto/Alias.pm: + (c) + + * Auto/Response.pm: + (a)(c) + + * Auto/Utils.pm: + get_ch_name -> (get_raw_ch_name): ネットワーク名無しの(server 的に raw な)チャンネル名 or undef を得る。 + (get_full_ch_name): ネットワーク名付きのチャンネル名 or undef を得る。 + (generate_reply_closures): 返り値に $get_full_ch_name を追加。 + 中身としては、$msg->param(place) 以上の意味は無いが、値の指定場所は一ヶ所にした方が良い。 + + * Tools/DateConvert.pm: + use_posix を import/unimport を使って再実装した。 + + * Tools/FileCache/EachFile.pm: + (can_remove): 実装。 + (AUTOLOAD): eval して関数コールするのではなく、その場でメソッドを定義して飛ぶようにした。 + + * Tools/FileCache.pm: + (main_loop): refcount を使ったチェックの代わりに、 can_remove を使ったチェックにした。 + + * Tools/HashDB.pm: + Module::Use を追加。 + + * Tools/HashTools.pm: + (get_array): 見付からなかった場合に () を返していたが、 undef を返すべきなので修正。 + (replace_recursive): こっかの補完処理を修正 + (_format): regexp の修正( %. -> %(.) )。バグでした。 + + * Tools/MailSend/EachServer.pm + ::printmsg -> RunLoop->shared->notify_warn 。 + LinedINETSocket を生成するときに $E_MAIL_EOL を使っていなかった。修正。 + MessageID の作られ方をコメントとして記述。 + + * Tools/MailSend.pm + (b) + + * Mask.pm: + s/exclude/include/ 。無意味な三項演算子を消した。 + + * sample.conf: + mask 関連を修正。 + +2003-07-28 phonohawk + + * main/IrcIO/Server.pm (person_list): + 追加。覚えている全てのPersonalInfoのリストを返す。 + +2003-07-26 phonohawk + + * tiarra: + 起動時に`-Dfoo'や`-Dfoo=bar'を指定すると、confに`@define foo'や + `@define foo bar'が書かれているものと見做す。 + + * module/Configuration/Preprocessor.pm + (initial_define): + @defineの初期設定の為の静的メソッド。 + + (_eval_at): + @ifdef文、@ifndef文を処理可能に。 + +2003-07-24 Topia + + * tiarra, make-password: + require 5.6.0 は古いバージョンだと解釈されないようなので require 5.006 に。 + lib, module を tiarra からの相対パスで解釈するように。 + + * main/Multicast.pm: + 352(WHOREPLY)のチャンネル名にネットワーク名をアタッチするようにした。 + +2003-07-23 phonohawk + + * main/InstantCapsule.pm: + SelfLoader使用中止。SelfLoaderでDESTROYが定義されると + カプセル内にDESTROYを定義出来なくなってしまう。 + + * module/User/Vanish.pm: + コマンド「/VANISHDEBUG 1」でメッセージの改変される様子が見えるように。 + 現在残っている妙な不具合の原因が解り次第削除。 + +2003-07-22 phonohawk + + * module/Channel/Freeze.pm + (freeze): + カンマで区切られた複数のチャンネル名を認識。 + + (defrost): + 凍結していないチャンネルをdefrostするとエラーが起こる問題を解決。 + チャンネル名をマスクとして扱うように変更。 + +2003-07-20 phonohawk + + * main/IrcIO/Server.pm (_PART): + PART受信時、入っているどのチャンネルにも最早その人物が + 居なくなった場合は、その人物についてのPersonalInfoを削除する。 + +2003-07-19 phonohawk + + * main/ChannelInfo.pm (remark): + remarks()のエイリアスとしてremark()を使用可能に。 + + * main/Timer.pm (interval): + 明示的にundefを渡す事で、リピート終了可能に。 + uninstallすれば一緒なので大した意味は無い。 + + * main/IrcIO/Server.pm (_TOPIC): + TOPICメッセージを受信した時、古いトピックを'old-topic'として註釈を付ける。 + +2003-07-17 phonohawk + + * tiarra-conf.el (tiarra-conf-jump-to-block): + ブロック名を入力し、その位置へジャンプするコマンド。 + デフォルトでは C-c C-. 及び C-c . に割当てられている。 + +2003-07-16 phonohawk + + * tiarra-conf.el (tiarra-conf-next-token): + 追加。カレントバッファの現在のカーソル位置の次にあるトークンを返す。 + カーソルはそのトークンの終わりの位置へ移動する。 + + * tiarra-conf.el + (tiarra-conf-next-block), + (tiarra-conf-prev-block): + 追加。それぞれ現在のカーソル位置の次や前にあるブロックへカーソルを飛ばす。 + プリプロセッサ指令があると変な動作をするバグ有り。 + nextは M-n に、prevは M-p に割当てた。 + +2003-07-10 phonohawk + + * module/Channel/Freeze.pm: + 追加。特定のチャンネルのNOTICEやPRIVMSGの中継を + 一時的に中断するためのモジュール。 + 発言を見たくないがPARTはしたくない、といった場合に有効。 + +2003-07-03 phonohawk + + * main/Configuration/Block.pm (get): + $config->foo('random')のような呼出しを可能に。 + 複数の定義があればランダムに一つ選んで返す。 + + * main/IrcIO/Server.pm (new, reload_config, connect): + 切断された後に再接続すると、以前のNICKが引継がれるように。 + + * module/Auto/Oper.pm: + 複数の応答が定義されていれば、ランダムに一つ選んで発言する。省略も可能。 + + * module/Auto/Utils.pm + (sendto_channel_closure, generate_reply_closures): + 作成されたクロージャに、発言内容としてundefを渡した場合、 + 何もせずに処理を終える。 + +2003-06-21 phonohawk + + * tiarra: + ActivePerlで起動時に出ていた警告を出ないように変更。 + SIGHUPのハンドラをインストールする際の警告だった。 + +2003-06-19 phonohawk + + * Multicast.pm (attach,detach) : + チャンネル/nickとネットワーク名の区切り文字として、二文字以上の文字列も使用可能に。 + つまり、今後は区切り文字として「空白を含まない1文字以上の任意の文字列」を使う事が出来ます。 + +2003-06-06 phonohawk + + * PersonInChannel.pm (remark) : + 明示的に二番目の引数にundefを渡すと、その註釈が削除される。 + + * RunLoop.pm (update_networks) : + 同一ホストへの複数の接続には、それぞれ時間差を設ける。 + + * RunLoop.pm (run) : + 既に始動時刻が過ぎているタイマーが存在すると、タイムアウト無期限のselectを行なうバグを修正。 + + * Configuration/Block.pm (eval_code) : + %CODE{...}EDOC%ブロックを、パッケージConfiguration::Implanted内で実行する。 + + * Configuration/Preprocessor.pm (_eval_pre) : + %PRE{...}ERP%ブロックを、パッケージConfiguration::Implanted内で実行する。 + + * IrcIO/Server.pm (reload_config) : + general/nickを、それぞれのネットワーク設定ブロックのnickでオーバーライド可能に。 + +2003-06-04 Topia + + * RunLoop.pm (run) : can_read を先に処理する。少しでも send で切断された状況をなくすため。 + 意味があるのかは不明だが、実害は無いはず。 + + * IrcIO.pm (send) : 接続チェックの対象に $this->{sock}->connected も追加。 + これが接続されてない状態で書き込もうとすると perl 自体がエラー落ちすることがあるらしい。 + +2003-06-04 phonohawk + + * tiarra (ipv6_enabled) : IPv6が有効かどうかを真偽値で返す。 + + * IrcIO.pm: 閉じられたソケットに対して書き込みを行なう可能性のある問題を(多分)解決。 + + * CTCP.pm, ControlPort.pm, Crypt.pm, ExternalSocket.pm, + InstantCapsule.pm, LinedINETSocket.pm: これらは一度も使われない可能性があるため、SelfLoaderを用いて遅延ロード。 + + * ChannelInfo.pm, PersonalInfo.pm: DESTROY時にエラーが起こる問題を解決。 + +2003-05-27 phonohawk + + * RunLoop.pm: + (notify_warn): 追加。全クライアントとコンソールに警告文を出力する。 + (run): 経過時間ゼロ秒のselectを連続で100回以上検出すると、10秒ごとに、CPU時間を食い潰している可能性を警告する。 + + * ControlPort.pm: + ソケットの作成に失敗した時に出たエラーが表示されなかったのを修正。 + + * ExternalSocket.pm: + WantToWriteが返した真偽値によらず、常に「書き込みが必要」として処理していた問題を解決。 + +2003-05-26 phonohawk + + * Timer.pm (new): + AtとAfter(又はInterval)が、両方とも指定されていなければcroakする。 + + * Configuration/Preprocessor.pm: + elseifやelseの解釈が正しくなかったのを修正。 + %PREの評価結果がundefになった時に警告が出ていたのを修正。 + @if文や@elsif文の評価結果がエラーになった時、そのエラー内容を表示していなかったので修正。 + +2003-05-24 phonohawk + + * IO/Socket/INET6.pm: 追加。 + IO::Socket::INETをIPv6に移植。Socket6.pmが必要。 + + * RunLoop.pm, IrcIO/Server.pm: IPv6対応。 + general/tiarra-ip-versionに'v6'を指定する事で、IPv6でのリスニングを行なう。 + また、サーバーには最初にIPv6での接続を試みてからIPv4にフォールバックする。 + 詳細はsample.confに。 + +2003-05-23 Topia + + * sample.conf: Auto::Random の説明中の 確立 を 確率 に修正した。 + + * Auto/Reply.pm: 追加。 + + * Auto/Alias.pm (message_arrived/remove): #(count) を使用可能にした。 + value が省略された場合はキーごと削除するようにした。 + + * Tools/HashDB.pm: 追加。 + + * Tools/HashTools.pm: Tools/GroupDB.pm, Tools/HashDB.pm の共通部分を取り出したモジュール。 + + * Tools/GroupDB.pm: キー名にコロンを使用可能にした。使用不能な半角スペースが来た場合は拒否する。 + コメントを修正し、詳細にした。 + 無視する行を指定するクロージャを引数に取れるようになった。省略された場合は # で始まる行を無視する。(従来) + del_value は削除出来た値の数を返すようになった。また、 value が未指定ならキーごと削除する。 + +2003-05-21 phonohawk + + * tiarra-conf.l: 追加。 + Noboruhiさんによるxyzzy用tiarra.conf編集モード。 + インストール方法はtiarra-conf.l内に記述されています。 + +2003-05-17 Topia + + * Auto/Utils.pm: sendto_channel_closure 関数追加。 + NOTICE/PRIVMSG の処理は面倒なので、これを自動的に処理する。 + sendto_channel_closure, generate_reply_closures に使用方法のコメントを追加。 + +2003-05-15 phonohawk + + * conf: + general/control-socket-nameを定義すると、外部プログラムからtiarraをコントロールする為の + UNIXドメインソケットを作成する。詳しくはsample.confに。 + + * ControlPort.pm: 追加。外部コントロール用。 + + * IRCMessage.pm: dieメッセージのtypoを修正。 + + * IrcIO.pm,LinedINETSocket.pm: sendの代わりにsyswriteを使う。 + + * Module.pm: メソッドcontrol_requested追加 + + * ModuleManager.pm: メソッドget追加 + + * RunLoop.pm: ControlPortを起動する為のコードを追加。 + + * Log/Channel.pm: "ID: synchronize"で外部からのログの同期を可能に。 + +2003-04-29 phonohawk + + * IrcIO/Server.pm: ログイン時、サーバーから送られてきたニューメリックリプライ以外のメッセージを無視する。 + ログイン前にNOTICEを送るようなサーバーに繋げられない問題を解決。 + + * RunLoop.pm: IrcIO->pop_queueがdieした時のメッセージを表示せずに捨てていたのを修正。 + + * Channel/Join/Kicked.pm: 追加。チャンネルから蹴られた時に、自動JOINするモジュール。 + + * IrcIO/Server.pm: 自分がチャンネルから蹴られた場合、そのチャンネル情報を消さずに + ChannelInfoに'kicked-out' => 1というremarkを付ける。 + + * RunLoop.pm: サーバーへの再接続時、+kされたチャンネルへの再JOINに失敗していたのを修正。 + +2003-04-25 phonohawk + + * main/Configuration.pm: general/client-allowedが省略された場合、 + 間違った値をデフォルト値として設定していたので修正。 + + * main/Configuration.pm: channel-network-separatorが未定義だった場合に + 正しくデフォルト値を設定しないミスがあったので修正。 + + * Configuration.pm: networksのnameで列挙されたネットワーク名に対応する + ブロックの定義が無かった場合、適切なエラーメッセージを出さずに処理を止めていたので修正。 + +2003-04-18 phonohawk + + * tiarra: SIGHUPを受信した時の動作を変更。 + これまではシャットダウンしていたが、以後は設定をリロードする。 + + * ChannelInfo.pm (fullname): 追加 + + * RunLoop.pm: 各ネットワークの設定を変更した後リロードすると、 + そのネットワークとの接続を一旦切ってから繋ぎ直す。 + + * IrcIO/Server.pm (config): 追加。 + コンストラクタの引数をネットワーク名のみに変更。 + + * IrcIO.pm (server_p,client_p): 追加。 + それぞれIrcIO::Serverであれば1を返すメソッドと + IrcIO::Clientであれば1を返すメソッド。 + +2003-04-13 phonohawk + + * User/Vanish.pm: 追加 + 特定のチャンネルでの特定の人物の存在をクライアントに隠すモジュール。 + JOINやPART、QUIT等を消去する。 + + * IrcIO/Server.pm (channels_list): 追加 + + * RunLoop.pm (networks_list,channel): 追加 + + * ChannelInfo.pm (AUTOLOAD): ハッシュマップの操作コマンドとして'keys'と'values'を追加。 + +2003-04-10 phonohawk + + * RunLoop.pm: 切断に気付かない場合があるので、3分毎に各サーバーにPINGを発行する。 + PING自動発行後にサーバーから来た最初のPONGは破棄される。 + + * IrcIO/Server.pm: メソッドremark追加。使い方は他のクラスのremarkと同じ。 + + * LinedINETSocket.pm: メソッドconnectの動作をconnectとattachの二つに分けた。 + これにより予め開かれたIO::Socket::INETに対してLinedINETSocketの機能を適用可能。 + +2003-04-05 phonohawk + + * Auto/Joined.pm: 追加。 + 特定のチャンネルに誰かがJOINする度に特定の発言を行なうモジュール。 + チャンネル移転通知以外に使うのはやめた方が良い。 + +2003-03-28 Topia + + * sample.conf (Auto/Random.pm): mention mask property. + + * Auto/Random.pm: use array_or_all on mask. + + * Auto/Alias.pm: use array_or_all on modifier. + + * Mask.pm: add array_or_(all|all_chan), (all|all_chan)_mask. + for not known maskmode, use Tiarra mode; and do warn. + +2003-03-23 phonohawk + + * IrcIO/Server.pm: general/bind-addrでサーバーへの接続時のローカルアドレスを指定可能に。 + また、各ネットワーク設定でbind-addrはオーバーライドできる。 + +2003-03-23 Topia + + * tiarra: ソースの判別部分自体が展開されていた…ので修正。 + + * ChangeLog: Id/Author/Date/RevisionのRCSタグを末尾に追加した。 + + * tiarra: ChangeLogからDateとRevisionを読んでバージョン情報に付加するようにした。 + +2003-03-23 phonohawk + + * User/Filter.pm: 追加。特定のユーザーの発言にフィルタをかけるモジュール。 + +2003-03-23 Topia + + * CTCP/Version.pm: add perl version infomation. + + * CTCP/ClientInfo.pm: separate ' ' instead of '/'. (ref. TAGGED DATA) + + * CTCP/{ClientInfo|Ping|Time|UserInfo|Version}.pm>: reply to channel CTCP. + + * CTCP.pm: fix wrong-quote dequoting. + + * sample.conf (Channel/Join/Invite.pm): add Channel/Join/Invite.pm sample configuration. + + * NEWS: add. news for non-developer. please write major changes, and so on. + if developer, see ChangeLog and check NEWS, please :-) + + * Channel/Join/Invite.pm: add. + + * Auto/Utils.pm (get_ch_name): add. + (generate_reply_closures): + add param ch_place(6th). default:0. + place of channel name in msg->params. + $get_ch_name closure return static string. + + * Auto/Response.pm: use register_extcallbacks. + generate_reply_closures's 3rd param(use_alias) to undef.(use default) + + * Auto/AliasDB/CallbackUtils.pm: add register_extcallbacks. + (for regist insecure callbacks) + +2003-03-19 Topia + + * sample.conf: change sample configuration. + + * Auto/Random.pm: can use multiple random datas. + +2003-03-17 Topia + + * Tools/MailSend/EachServer.pm (clean): fix cleaning code. + (DESTROY): unnesessary; remove. + + * sample.conf: mention Auto::Random/(mask|count-query|count-format), and format change. + mention Auto::Response's DB format. + + * sample.conf (Auto/Alias.pm): s/#(message)/#(value)/ at sample config. sorry. + + * Tools/FileCache.pm, Tools/FileCache/EachFile.pm: add. Tools::LinedDB based cached file i/o. + + * Tools/LinedDB.pm: add. line based i/o framework. + + * Tools/GroupDB.pm (add_group): add $this->synchronize. + + * Log/DateTime.pm: this module is obsolete. remove. + + * Log/Channel.pm, Log/Recent.pm: use Tools::DateConvert instead Log::DateTime. + + * Auto/Response.pm: add callback: read_file/file_lines. + add mask check in database 'mask' entry. + + * Auto/Random.pm: use Tools::FileCache. + add count query. + + * Auto/AliasDB/CallbackUtils.pm: add #(read_file:fpath:mode:charset). + add #(file_lines:fpath:mode:charset). + (register_callback): $reg_callback accept scalar function name. + +2003-03-15 phonohawk + + * BulletinBoard.pm: + ・AUTOLOAD経由で値を設定可能に。 + ・メソッドkeys()を追加。 + + * CTCP.pm: 追加。CTCPエンコード/デコードを行なうモジュール。 + + * IrcIO.pm: メソッドremark()追加。 + + * CTCP/ClientInfo.pm, + CTCP/Ping.pm, + CTCP/Time.pm, + CTCP/UserInfo.pm, + CTCP/Version.pm : 追加。 + +2003-03-10 phonohawk + + * IrcIO/Server.pm: ネットワーク毎の設定でin-encoding,out-encodingを定義する事により + 文字エンコーディングの設定をオーバーライド可能に。 + +2003-03-09 Topia + + * Auto/Response.pm: plum でのキー名が response だったのを勘違いして reply にしていた。 + (りんりんさんバグレポートありがとうございます) + +2003-03-09 phonohawk + + * Configuration/Block.pm: %CODE{ }EDOC%の解釈でメモリリークを起こす不具合を回避。 + +2003-03-09 Topia + + * Auto/AliasDB/CallbackUtils.pm: register_RandomNickConvertでメッセージがIrcIO::Client + 発信だった場合に登録しないようにした。 (りんりんさんバグレポートありがとうございます) + +2003-03-08 phonohawk + + * IrcIO/Server.pm: オプションnetworks/always-notify-new-nickが設定されていたら + nickを変更する度に、変更したサーバーの新しいグローバルnickをNOTICEで通知する。 + + * IrcIO/Client.pm: ログイン時に本名として渡された$key=value;key=value...$のオプションを + パースする部分を書き直し。$ key =value ;key = value$のような設定でも + 期待された通りに解釈する。 + また、メソッドoption追加。このようにして渡されたオプションを取得する。 + + * tiarra, Configuration.pm, Configuration/Preprocessor.pm: + 起動時にオプション--configを省略された場合の動作を変更。 + ターミナル上から起動した場合は従来のようにデフォルトのファイル名であるtiarra.confを読むが、 + 標準入力がターミナルに接続されていなかった場合、つまりパイプ経由でリダイレクトされている場合は + tiarra.confでなく標準入力から設定を読む。この場合は設定のリロードは不可能となる。 + 例: cat tiarra.conf | sed -e 's/Tiarra/arraiT/g' | ./tiarra --quiet + + * Configuration/Block.pm: + %CODE{ ... }EDOC%で挟まれた部分を、値の取得時に毎回評価する。 + +2003-03-04 Topia + + * Tools/MailSend/EachServer.pm: RunLoop::Hookを使用するように変更。 + ループをなるべく回すように変更。flushはclose時とDATA時に行うことにした。 + フェイルセーフの為に5sec間隔のTimerも使うことにする。 + + * Tools/GroupDB.pm: fpathで指定されたファイルが存在しないときにエラーとなるのを修正。 + + * Auto/Alias.pm: 配列の参照を渡すべきところを配列を渡してしまっていた。修正。 + + * LinedINETSocket.pm: ExternalSocketのuninstall等も必要かも知れないので + DESTROYを復活させる。 + +2003-03-04 phonohawk + + * ExternalSocket.pm: read/write/want_to_writeで、callerをチェックする位置を変更。 + + * Configuration/Block.pm: 文字コードの再解釈に失敗する不具合を解決。 + + * RunLoop.pm: クラスRunLoop::Hook追加。 + RunLoopのループが一回実行される度に呼ばれるフック。 + 呼ばれるタイミングとしてはselect実行直前または直後。どちらかを選択可能。 + 詳しくはRunLoop::Hookの先頭のコメントを参照の事。 + +2003-03-04 Topia + + * Auto/MesMail.pm: Tools/MailSend.pmを使うように修正。 + + * Tools/MailSend/EachServer.pm: 新規追加。SMTPサーバ毎に具体的なメール送信を行う。 + POP before SMTPの場合はexpireまで待って、そうでない場合はすぐにオブジェクトを破棄する。 + + * Tools/MailSend.pm: 新規追加。メール送信を行う。 + 複数のサーバと同時に通信するためにTools/MailSend/EachServer.pmを管理している。 + + * Auto/Response.pm: rateを使えるようにした。 + +2003-03-03 phonohawk + + * Configuration/Block.pm: ブロック内ブロックを扱えるように。 + + * Configuration/LexicalAnalyzer.pm: 新規追加。confの字句解析器。 + + * Configuration/Parser.pm: 新規追加。confの構文解析器。 + + * Configuration.pm: パーサを書き直し。上記二つのクラス、及びプリプロセッサを使用。 + +2003-03-02 Topia + + * Auto/Response.pm: 新規追加。plumのauto/response.plmの動作をする。 + + * Auto/AliasDB/CallbackUtils.pm: 存在してはいけないuninstallがあったので削除。 + + * Auto/Utils.pm: コールバックを追加できる引数の追加。 + + * Tools/GroupDB.pm: regexpを利用できるようにする引数の追加。 + find_groups/find_groups_with_primaryの追加。 + + * Channel/Mode/Oper/Grant.pm: Auto/Oper.pmとmask処理を統一した。 + + * sample.conf: maskの説明が変わってしまうので書き換えた。 + + * sample.conf: '-*- tiarra-conf -*-' を一行目に追加した。Auto/MesMailのエントリ追加。 + + * Auto/MesMail.pm: 新規追加。伝言をメールとして送信する。メール送信部分は分けられてTools下に + 行く可能性もある。 + + * Auto/Utils.pm: AliasDBの変更に同期。'(nick|user|host).now'はAliasDB内部に移動している。 + + * Auto/Oper.pm: AliasDBの変更に同期。Mask::match_deep_chanを使用するように。 + + * Auto/Alias.pm: AliasDBはオートフラッシュなのでデストラクタを消した。 + + * Auto/AliasDB/CallbackUtils.pm: RandomAliasConvert, JoinedListConvertを追加。 + MessageReplaceにmessage_replace_lastを追加。 + + * Auto/AliasDB.pm: GroupDBを使用するように変更。関数名を一部変更した。 + confでprivateとreadonlyなキーの指定が出来る。readonlyはまだ対応モジュールが存在しない。 + + * Tools/GroupDB.pm: 新規追加。AliasDBから独立させた。 + +2003-03-02 phonohawk + + * Configuration/Preprocessor.pm: 新規追加。 + confファイルのプリプロセッサとして使用する。 + +2003-03-01 phonohawk + + * ConfigBlock.pm: 削除。Configuration::Blockに移動。 + + * InstantCapsule.pm: 新規追加。 + フィールドとメソッドを持つオブジェクトを一時的に生成するクラス。 + サンプルコードはInstantCapsule.pm内にあります。 + +2003-02-27 Topia + + * Mask.pm: チャンネルとユーザのマスクをconfで切替え可能にした。 + sample.confにも説明を追加している。 + + * Mask.pm: mask_chanで[+-]を使用可能にした。+channelは++channelまたは + -+channelと表記する必要がある。 + _split_with_chanのsplit処理を_splitに委託した。 + + * Mask.pm: channelを含めたmaskを処理する関数を追加した。 + mask_chan, mask_deep_chanはstrの次にchanが追加されているだけで仕様は同じ。 + mask_array_chanはstr_masks, chan_masks, str, chanと言う引数になっている。 + 次にcommitされる予定のAuto::Oper辺りがサンプルコードになるはず。 + +2003-02-26 Topia + + * Multicast.pm: channel_pを追加した。 + nick_pに文字数チェック(length != 0)とdetachの処理を追加した。 + + * LinedINETSocket.pm: デストラクタを実行するより前にsocketが開放されているようだ。 + デストラクタをコメントアウトした。 + + * LinedINETSocket.pm: 新規追加。行単位のキューを使用した入出力を行う。 + +2003-02-26 phonohawk + + * ExternalSocket.pm: 新規追加。 + + * RunLoop.pm: RunLoopが任意のソケットを監視出来るように。 + ソケットの監視にはExternalSocketを用いる。使い方はExternalSocket.pmにある。 + + * Timer.pm: uninstallした時はrunloopにundefを代入する。 + +2003-02-20 phonohawk + + * Module.pm (notification_of_message_io) : 新規追加。 + サーバーやクライアントと実際に送受信したメッセージが通知されるメソッド。デバッグ用。 + + * IrcIO/(Client/Server).pm : notification_of_message_ioを呼ぶための修正。 + + * IrcIO/Client.pm : 複数のクライアントを接続している際、 + NICKの変更が他のクライアントへ伝わっていなかったので修正。 + +2003-02-19 phonohawk + + * tiarra-conf.el: 新規追加。confファイルのEmacs用モード。試作品。 + このファイルが置かれている場所をload-pathに追加し、次のようなautoloadを実行すれば良い。 + (autoload 'tiarra-conf-mode "tiarra-conf" "tiarra.conf editing mode" t) + +2003-02-17 phonohawk + + * Configuration.pm: + ・@includeで他のファイルをインクルード可能に。 + 但し一つのファイルを複数回@includeする事は出来ない。 + ・ブロックの{}の位置をある程度自由に。 + ・ブロックの中身が空で良ければ{}を省略可能に。 + sample.confに詳しい説明があります。 + + * IrcIO/Client.pm: $key=value;key=value;...$形式の本名でログインすると、 + 特定のクライアントの間においてのみconfで設定された項目をオーバーライドする。 + 現在有効なキーはencodingで、これはクライアントとの通信に用いる文字コードである。 + 例: + $encoding=euc$ この本名でログインした場合、EUC-JPで通信を行なう。 + +2003-02-17 Topia + + * System/RemoteControl.pm: 複数行のmaskを使えるようにした。 + + * Mask.pm: コメント中の例が間違っていたので修正。 + + * Mask.pm: 正規表現マッチと+-機能のオン/オフを可能にした。 + comma-separeted mask arrayを渡せる関数を追加した。 + 単純にmask arrayを渡せる関数を追加した。 + wild cardを正規表現にするmake_regexを別関数として独立させた。 + + * Auto/Utils.pm: $get_ch_nameでparam(0)が無い場合undefを返すようにした。 + +2003-02-15 phonohawk + + * RunLoop.pm: Time::HiResがインストールされている環境では + Timerの精度がミリ秒に上がる。入っていなければ秒のまま。 + + * PersonInChannel.pm: メソッドremark,delete-remark追加。 + 註釈を付ける事が出来る。 + + * Multicast.pm: attach/detachでエラーチェックを行なう。 + +2003-02-13 Topia + + * Auto/AliasDB/CallbackUtils.pm: MessageReplace callback を追加しました。 + #(message_replace:[split_regexp]:[place]) です。placeはzero originとなっています。 + ex. test alias -> #(message_replace: :1) -> alias + また、この変更でregister_stdcallbacksの引数が$ch_name -> $msgとなり、 + その変更をAuto/AliasDB.pm, Auto/Utils.pmに反映させています。 + + * Auto/Answer.pm: 返答に$reply_anywhereを使うようにした。 + + * Auto/Random.pm: オートリロードと追加/削除の返答を追加しています。 + + * Auto/Alias.pm: Auto/AliasDB.pmに追加と削除を移しています。 + 追加/削除出来た場合に返答できるようにしました。 + + * Auto/Utils.pm: 返り値に、$reply_anywhere + (場合によってチャンネルに返したりprivで返したりする)を追加しました。 + $reply_as_privがextra_replacesを付けられるようにしました。 + reply_with_stdcallbacksを使用するようにしました。 + reply_with_stdcallbacksはrandomやdate、randomnick、randomselectなどのcallbackを + 登録します。 + user.now, host.now などのエイリアスを追加するようにしました。 + + * Auto/AliasDB.pm: Auto/Alias.pmから追加と削除機能を移しました。 + オートリロードするようにしました。 + 渡されたエイリアスからキーを見つけ出せなかった場合、callbackを呼ぶようにしました。 + #(name;%s さん) などの表記をサポートしました。 + サブフォーマット中に対応する括弧を含めます。 + #(namesuf;#(name)%s)のような表記ができます。 + + * Auto/AliasDB/CallbackUtils.pm: AliasDBのCallback機能を使った標準的な拡張です。 + + * Tools/DateConvert.pm: 新規追加。plumの&'dateに相当。 + + * System/Pong.pm: xchat対策に、pingの代わりにpongを消滅させるようにした。 + +2003-02-13 phonohawk + + * Multicast.pm: nick_pでのnicklen制限をやめた。 + +2003-02-12 phonohawk + + * RunLoop.pm: $(network)/userでgeneral/userをオーバーライド可能に。 + + * System/RemoteControl.pm: 新規追加 + + * これ以前のログは書いていません。 + +# Id: $Id: ChangeLog,v 1.158 2004/08/22 11:28:41 topia Exp $ +# Author: $Author: topia $ +# Date: $Date: 2004/08/22 11:28:41 $ +# Revision: $Revision: 1.158 $ diff -urN /non-existant-dir/ChangeLog.svn tiarra-20080510/ChangeLog.svn --- /non-existant-dir/ChangeLog.svn 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/ChangeLog.svn 2008-05-11 00:25:46.000000000 +0900 @@ -0,0 +1,1378 @@ +------------------------------------------------------------------------ +r11365 | topia | 2008-05-10 23:58:28 +0900 (Sat, 10 May 2008) | 1 line +Changed paths: + M /lang/perl/tiarra/trunk + M /lang/perl/tiarra/trunk/AUTHORS + M /lang/perl/tiarra/trunk/ChangeLog + M /lang/perl/tiarra/trunk/HACKING + M /lang/perl/tiarra/trunk/INSTALL + M /lang/perl/tiarra/trunk/LICENSE + M /lang/perl/tiarra/trunk/NEWS + M /lang/perl/tiarra/trunk/all.conf + M /lang/perl/tiarra/trunk/doc/default.css + M /lang/perl/tiarra/trunk/doc/module/Auto.html + M /lang/perl/tiarra/trunk/doc/module/CTCP.html + M /lang/perl/tiarra/trunk/doc/module/Channel.html + M /lang/perl/tiarra/trunk/doc/module/Client.html + M /lang/perl/tiarra/trunk/doc/module/Debug.html + M /lang/perl/tiarra/trunk/doc/module/Log.html + M /lang/perl/tiarra/trunk/doc/module/System.html + M /lang/perl/tiarra/trunk/doc/module/UNCLASSIFIED.html + M /lang/perl/tiarra/trunk/doc/module/User.html + M /lang/perl/tiarra/trunk/doc/module-toc.html + M /lang/perl/tiarra/trunk/doc-src/README + M /lang/perl/tiarra/trunk/doc-src/all.conf.in + M /lang/perl/tiarra/trunk/doc-src/conf-main.tdoc + M /lang/perl/tiarra/trunk/doc-src/contents.html + M /lang/perl/tiarra/trunk/doc-src/module-group.tdoc + M /lang/perl/tiarra/trunk/doc-src/module-toc.html + M /lang/perl/tiarra/trunk/doc-src/sample.conf.in + M /lang/perl/tiarra/trunk/main/BulletinBoard.pm + M /lang/perl/tiarra/trunk/main/CTCP.pm + M /lang/perl/tiarra/trunk/main/ChannelInfo.pm + M /lang/perl/tiarra/trunk/main/Configuration/Block.pm + M /lang/perl/tiarra/trunk/main/Configuration/LexicalAnalyzer.pm + M /lang/perl/tiarra/trunk/main/Configuration/Parser.pm + M /lang/perl/tiarra/trunk/main/Configuration/Preprocessor.pm + M /lang/perl/tiarra/trunk/main/Configuration.pm + M /lang/perl/tiarra/trunk/main/ControlPort.pm + M /lang/perl/tiarra/trunk/main/Crypt.pm + M /lang/perl/tiarra/trunk/main/Exception.pm + M /lang/perl/tiarra/trunk/main/ExternalSocket.pm + M /lang/perl/tiarra/trunk/main/FunctionalVariable.pm + M /lang/perl/tiarra/trunk/main/Hook.pm + M /lang/perl/tiarra/trunk/main/IRCMessage.pm + M /lang/perl/tiarra/trunk/main/InstantCapsule.pm + M /lang/perl/tiarra/trunk/main/IrcIO/Client.pm + M /lang/perl/tiarra/trunk/main/IrcIO/Server.pm + M /lang/perl/tiarra/trunk/main/IrcIO.pm + M /lang/perl/tiarra/trunk/main/Iterator/ArrayIterator.pm + M /lang/perl/tiarra/trunk/main/Iterator/BackwardIterator.pm + M /lang/perl/tiarra/trunk/main/Iterator/BidirectionalIterator.pm + M /lang/perl/tiarra/trunk/main/Iterator/ForwardIterator.pm + M /lang/perl/tiarra/trunk/main/Iterator/RandomAccessIterator.pm + M /lang/perl/tiarra/trunk/main/Iterator/RoundIterator.pm + M /lang/perl/tiarra/trunk/main/Iterator.pm + M /lang/perl/tiarra/trunk/main/L10N.pm + M /lang/perl/tiarra/trunk/main/LinedINETSocket.pm + M /lang/perl/tiarra/trunk/main/LocalChannelManager.pm + M /lang/perl/tiarra/trunk/main/Mask.pm + M /lang/perl/tiarra/trunk/main/Module/Use.pm + M /lang/perl/tiarra/trunk/main/Module.pm + M /lang/perl/tiarra/trunk/main/ModuleManager.pm + M /lang/perl/tiarra/trunk/main/Multicast.pm + M /lang/perl/tiarra/trunk/main/NumericReply.pm + M /lang/perl/tiarra/trunk/main/PersonInChannel.pm + M /lang/perl/tiarra/trunk/main/PersonalInfo.pm + M /lang/perl/tiarra/trunk/main/ReloadTrigger.pm + M /lang/perl/tiarra/trunk/main/RunLoop.pm + M /lang/perl/tiarra/trunk/main/Template.pm + M /lang/perl/tiarra/trunk/main/Tiarra/Encoding/UniJP.pm + M /lang/perl/tiarra/trunk/main/Tiarra/IRC/Message.pm + M /lang/perl/tiarra/trunk/main/Tiarra/Socket/Buffered.pm + M /lang/perl/tiarra/trunk/main/Tiarra/Socket/Lined.pm + M /lang/perl/tiarra/trunk/main/Tiarra/Socket.pm + M /lang/perl/tiarra/trunk/main/Tiarra/Utils.pm + M /lang/perl/tiarra/trunk/main/TiarraDoc.pm + M /lang/perl/tiarra/trunk/main/Timer.pm + M /lang/perl/tiarra/trunk/makedoc + M /lang/perl/tiarra/trunk/module/Auto/Alias.pm + M /lang/perl/tiarra/trunk/module/Auto/AliasDB/CallbackUtils.pm + M /lang/perl/tiarra/trunk/module/Auto/AliasDB.pm + M /lang/perl/tiarra/trunk/module/Auto/Answer.pm + M /lang/perl/tiarra/trunk/module/Auto/CacheManager.pm + M /lang/perl/tiarra/trunk/module/Auto/Calc.pm + M /lang/perl/tiarra/trunk/module/Auto/ChannelWithoutOper.pm + M /lang/perl/tiarra/trunk/module/Auto/Im.pm + M /lang/perl/tiarra/trunk/module/Auto/Joined.pm + M /lang/perl/tiarra/trunk/module/Auto/MesMail.pm + M /lang/perl/tiarra/trunk/module/Auto/Oper.pm + M /lang/perl/tiarra/trunk/module/Auto/Random.pm + M /lang/perl/tiarra/trunk/module/Auto/Reply.pm + M /lang/perl/tiarra/trunk/module/Auto/Response.pm + M /lang/perl/tiarra/trunk/module/Auto/Utils.pm + M /lang/perl/tiarra/trunk/module/CTCP/ClientInfo.pm + M /lang/perl/tiarra/trunk/module/CTCP/Ping.pm + M /lang/perl/tiarra/trunk/module/CTCP/Time.pm + M /lang/perl/tiarra/trunk/module/CTCP/UserInfo.pm + M /lang/perl/tiarra/trunk/module/CTCP/Version.pm + M /lang/perl/tiarra/trunk/module/Channel/Freeze.pm + M /lang/perl/tiarra/trunk/module/Channel/Join/Connect.pm + M /lang/perl/tiarra/trunk/module/Channel/Join/Invite.pm + M /lang/perl/tiarra/trunk/module/Channel/Join/Kicked.pm + M /lang/perl/tiarra/trunk/module/Channel/Mode/Get.pm + M /lang/perl/tiarra/trunk/module/Channel/Mode/Oper/Grant.pm + M /lang/perl/tiarra/trunk/module/Channel/Mode/Set.pm + M /lang/perl/tiarra/trunk/module/Channel/Rejoin.pm + M /lang/perl/tiarra/trunk/module/Client/Cache.pm + M /lang/perl/tiarra/trunk/module/Client/Conservative.pm + M /lang/perl/tiarra/trunk/module/Client/Cotton.pm + M /lang/perl/tiarra/trunk/module/Client/Eval.pm + M /lang/perl/tiarra/trunk/module/Client/GetVersion.pm + M /lang/perl/tiarra/trunk/module/Client/PatchworkMessage.pm + M /lang/perl/tiarra/trunk/module/Client/ProtectMyself.pm + M /lang/perl/tiarra/trunk/module/Client/Rehash.pm + M /lang/perl/tiarra/trunk/module/Client/ShowNick.pm + M /lang/perl/tiarra/trunk/module/Debug/AliasTest.pm + M /lang/perl/tiarra/trunk/module/Debug/Core.pm + M /lang/perl/tiarra/trunk/module/Debug/RawLog.pm + M /lang/perl/tiarra/trunk/module/Log/Channel.pm + M /lang/perl/tiarra/trunk/module/Log/ChannelList.pm + M /lang/perl/tiarra/trunk/module/Log/Logger.pm + M /lang/perl/tiarra/trunk/module/Log/Raw.pm + M /lang/perl/tiarra/trunk/module/Log/Recent.pm + M /lang/perl/tiarra/trunk/module/Log/Writer/File.pm + M /lang/perl/tiarra/trunk/module/Log/Writer.pm + M /lang/perl/tiarra/trunk/module/Skelton.pm + M /lang/perl/tiarra/trunk/module/System/Error.pm + M /lang/perl/tiarra/trunk/module/System/LivePatch.pm + M /lang/perl/tiarra/trunk/module/System/Macro.pm + M /lang/perl/tiarra/trunk/module/System/NotifyIcon/Win32.pm + M /lang/perl/tiarra/trunk/module/System/Pong.pm + M /lang/perl/tiarra/trunk/module/System/PrivTranslator.pm + M /lang/perl/tiarra/trunk/module/System/Raw.pm + M /lang/perl/tiarra/trunk/module/System/Reload.pm + M /lang/perl/tiarra/trunk/module/System/RemoteControl.pm + M /lang/perl/tiarra/trunk/module/System/SendMessage.pm + M /lang/perl/tiarra/trunk/module/System/Shutdown.pm + M /lang/perl/tiarra/trunk/module/Tools/DateConvert.pm + M /lang/perl/tiarra/trunk/module/Tools/FileCache/EachFile.pm + M /lang/perl/tiarra/trunk/module/Tools/FileCache.pm + M /lang/perl/tiarra/trunk/module/Tools/GroupDB.pm + M /lang/perl/tiarra/trunk/module/Tools/HTTPClient.pm + M /lang/perl/tiarra/trunk/module/Tools/Hash.pm + M /lang/perl/tiarra/trunk/module/Tools/HashDB.pm + M /lang/perl/tiarra/trunk/module/Tools/HashTools.pm + M /lang/perl/tiarra/trunk/module/Tools/LinedDB.pm + M /lang/perl/tiarra/trunk/module/Tools/MailSend/EachServer.pm + M /lang/perl/tiarra/trunk/module/Tools/MailSend.pm + M /lang/perl/tiarra/trunk/module/User/Away/Client.pm + M /lang/perl/tiarra/trunk/module/User/Away/Nick.pm + M /lang/perl/tiarra/trunk/module/User/Filter.pm + M /lang/perl/tiarra/trunk/module/User/Ignore.pm + M /lang/perl/tiarra/trunk/module/User/Kick.pm + M /lang/perl/tiarra/trunk/module/User/Nick/Detached.pm + M /lang/perl/tiarra/trunk/module/User/ServerOper.pm + M /lang/perl/tiarra/trunk/module/User/Vanish.pm + M /lang/perl/tiarra/trunk/sample.conf + M /lang/perl/tiarra/trunk/tiarra + M /lang/perl/tiarra/trunk/tiarra-conf.el + +* merge UTF-8 branch. +------------------------------------------------------------------------ +r11355 | topia | 2008-05-10 22:18:03 +0900 (Sat, 10 May 2008) | 1 line +Changed paths: + M /lang/perl/tiarra/trunk/all.conf + M /lang/perl/tiarra/trunk/doc/module/Auto.html + M /lang/perl/tiarra/trunk/doc/module/CTCP.html + M /lang/perl/tiarra/trunk/doc/module-toc.html + M /lang/perl/tiarra/trunk/sample.conf + +* regen documentation. +------------------------------------------------------------------------ +r11354 | topia | 2008-05-10 22:13:40 +0900 (Sat, 10 May 2008) | 4 lines +Changed paths: + M /lang/perl/tiarra/trunk/module/Auto/Im.pm + +* support password. +* support mask. +* explain default value of format. + +------------------------------------------------------------------------ +r11353 | topia | 2008-05-10 21:01:26 +0900 (Sat, 10 May 2008) | 3 lines +Changed paths: + M /lang/perl/tiarra/trunk/module/Auto/Im.pm + +* fix keyword splitting bug. +* small style change. + +------------------------------------------------------------------------ +r11347 | topia | 2008-05-10 19:15:42 +0900 (Sat, 10 May 2008) | 5 lines +Changed paths: + M /lang/perl/tiarra/trunk/module/Auto/Im.pm + +* support im.kayac.com secret mode. +* use Tools::HTTPClient (require r11345 or later). +* add regex-keyword configuration. +* add format configuration. + +------------------------------------------------------------------------ +r11346 | topia | 2008-05-10 17:46:51 +0900 (Sat, 10 May 2008) | 4 lines +Changed paths: + M /lang/perl/tiarra/trunk/module/Tools/HTTPClient.pm + +HTTP::Request support: + * set correct type scalar. + * style fix. + +------------------------------------------------------------------------ +r11345 | topia | 2008-05-10 17:20:26 +0900 (Sat, 10 May 2008) | 3 lines +Changed paths: + M /lang/perl/tiarra/trunk/module/Tools/HTTPClient.pm + +* support request information fetching from HTTP::Request. + Tools::HTTPClient->new(Request => $http_request_object. + +------------------------------------------------------------------------ +r11344 | topia | 2008-05-10 16:36:53 +0900 (Sat, 10 May 2008) | 1 line +Changed paths: + M /lang/perl/tiarra/trunk/module/Auto/Im.pm + +* set properties. +------------------------------------------------------------------------ +r11341 | ha1t | 2008-05-10 15:06:08 +0900 (Sat, 10 May 2008) | 1 line +Changed paths: + M /lang/perl/tiarra/trunk/module/Auto/Im.pm + +てきとーなpod追加 +------------------------------------------------------------------------ +r11340 | ha1t | 2008-05-10 14:52:44 +0900 (Sat, 10 May 2008) | 1 line +Changed paths: + M /lang/perl/tiarra/trunk/module/Auto/Im.pm + +チャンネル名が出るようにした +------------------------------------------------------------------------ +r11339 | ha1t | 2008-05-10 14:12:47 +0900 (Sat, 10 May 2008) | 1 line +Changed paths: + A /lang/perl/tiarra/trunk/module/Auto/Im.pm + +ぺるる使いが綺麗にしてくれる事を信じてコミット +------------------------------------------------------------------------ +r11256 | topia | 2008-05-08 00:50:47 +0900 (Thu, 08 May 2008) | 2 lines +Changed paths: + M /lang/perl/tiarra/trunk/module/Log/Writer.pm + +* trivial message fix. + +------------------------------------------------------------------------ +r11255 | topia | 2008-05-08 00:47:49 +0900 (Thu, 08 May 2008) | 1 line +Changed paths: + M /lang/perl/tiarra/trunk/main/CTCP.pm + M /lang/perl/tiarra/trunk/main/Crypt.pm + M /lang/perl/tiarra/trunk/main/ExternalSocket.pm + M /lang/perl/tiarra/trunk/main/LinedINETSocket.pm + +* disable SelfLoader to work under taint check. +------------------------------------------------------------------------ +r11254 | topia | 2008-05-08 00:25:16 +0900 (Thu, 08 May 2008) | 2 lines +Changed paths: + M /lang/perl/tiarra/trunk/main/Tiarra/Utils/DefineHelper.pm + +* kill redefine and prototype warning, instead of undef funcname GLOB. + +------------------------------------------------------------------------ +r11253 | topia | 2008-05-08 00:24:16 +0900 (Thu, 08 May 2008) | 2 lines +Changed paths: + M /lang/perl/tiarra/trunk/main/ExternalSocket.pm + +* fix bug. + +------------------------------------------------------------------------ +r11251 | topia | 2008-05-07 23:58:02 +0900 (Wed, 07 May 2008) | 2 lines +Changed paths: + M /lang/perl/tiarra/trunk/tiarra + +* drop IO::Socket::INET6 from bundle list. + +------------------------------------------------------------------------ +r11250 | topia | 2008-05-07 23:55:56 +0900 (Wed, 07 May 2008) | 2 lines +Changed paths: + M /lang/perl/tiarra/trunk/tiarra + +* mention about --show-env. + +------------------------------------------------------------------------ +r11203 | topia | 2008-05-06 17:34:36 +0900 (Tue, 06 May 2008) | 3 lines +Changed paths: + M /lang/perl/tiarra/trunk/main/Tiarra/Socket/Connect.pm + +* fix default option handling. +* add documentation about unix domain socket. + +------------------------------------------------------------------------ +r11202 | topia | 2008-05-06 17:13:24 +0900 (Tue, 06 May 2008) | 3 lines +Changed paths: + M /lang/perl/tiarra/trunk/main/Tiarra/Resolver.pm + +* support threads <= 1.33. +* trivial change of resolved data handling. + +------------------------------------------------------------------------ +r11201 | topia | 2008-05-06 17:11:07 +0900 (Tue, 06 May 2008) | 2 lines +Changed paths: + M /lang/perl/tiarra/trunk/main/Tiarra/Socket/Connect.pm + +* fix bug on unix connector. + +------------------------------------------------------------------------ +r11200 | topia | 2008-05-06 16:53:23 +0900 (Tue, 06 May 2008) | 3 lines +Changed paths: + M /lang/perl/tiarra/trunk/main/ControlPort.pm + +* set sticky bit to /tmp/tiarra-control. +* try unlink ControlPort if cannot connect. + +------------------------------------------------------------------------ +r11199 | topia | 2008-05-06 16:35:55 +0900 (Tue, 06 May 2008) | 2 lines +Changed paths: + M /lang/perl/tiarra/trunk/main/Tiarra/OptionalModules.pm + +* add Socket6 module to ipv6 support, explicitly. + +------------------------------------------------------------------------ +r11198 | topia | 2008-05-06 16:31:39 +0900 (Tue, 06 May 2008) | 2 lines +Changed paths: + M /lang/perl/tiarra/trunk/main/IrcIO/Client.pm + +* trivial message fix. + +------------------------------------------------------------------------ +r11197 | topia | 2008-05-06 16:26:45 +0900 (Tue, 06 May 2008) | 2 lines +Changed paths: + M /lang/perl/tiarra/trunk/main/IrcIO/Client.pm + +* more verbose log message on client acception sequence. + +------------------------------------------------------------------------ +r11164 | topia | 2008-05-05 17:59:02 +0900 (Mon, 05 May 2008) | 3 lines +Changed paths: + M /lang/perl/tiarra/trunk/module/CTCP/DCC/RewriteAddress.pm + +* rename closure to callback. +* fix documentation. + +------------------------------------------------------------------------ +r11131 | topia | 2008-05-05 02:22:08 +0900 (Mon, 05 May 2008) | 1 line +Changed paths: + M /lang/perl/tiarra/trunk/all.conf + M /lang/perl/tiarra/trunk/doc/module/CTCP.html + M /lang/perl/tiarra/trunk/sample.conf + +* regenerate documentation. +------------------------------------------------------------------------ +r11130 | topia | 2008-05-05 02:20:34 +0900 (Mon, 05 May 2008) | 3 lines +Changed paths: + M /lang/perl/tiarra/trunk/module/CTCP/DCC/RewriteAddress.pm + +* more refactored. +* add documentation. + +------------------------------------------------------------------------ +r11129 | topia | 2008-05-05 01:58:04 +0900 (Mon, 05 May 2008) | 3 lines +Changed paths: + M /lang/perl/tiarra/trunk/main/Tiarra/Resolver.pm + +* more efficient error handling. +* re-run resolver thread on dead. + +------------------------------------------------------------------------ +r11126 | topia | 2008-05-05 00:00:33 +0900 (Mon, 05 May 2008) | 2 lines +Changed paths: + M /lang/perl/tiarra/trunk/module/Tools/DateConvert.pm + +* cosmetic fixes. + +------------------------------------------------------------------------ +r11125 | topia | 2008-05-04 23:56:12 +0900 (Sun, 04 May 2008) | 2 lines +Changed paths: + M /lang/perl/tiarra/trunk/module/Tools/MailSend/EachServer.pm + +* use Tools::DateConvert::expand to set locale. + +------------------------------------------------------------------------ +r11123 | topia | 2008-05-04 23:54:30 +0900 (Sun, 04 May 2008) | 3 lines +Changed paths: + M /lang/perl/tiarra/trunk/module/Tools/DateConvert.pm + +* fix %O bug. +* add new interface: expand. + +------------------------------------------------------------------------ +r11121 | topia | 2008-05-04 23:41:38 +0900 (Sun, 04 May 2008) | 2 lines +Changed paths: + M /lang/perl/tiarra/trunk/module/CTCP/DCC/RewriteAddress.pm + +* refactored. + +------------------------------------------------------------------------ +r11117 | topia | 2008-05-04 23:23:06 +0900 (Sun, 04 May 2008) | 4 lines +Changed paths: + M /lang/perl/tiarra/trunk/main/Tiarra/Resolver.pm + +* support threading on QUERY_NAMEINFO. +* disable threading on QUERY_NAMEINFO. +* make error handling more efficient. + +------------------------------------------------------------------------ +r11101 | topia | 2008-05-04 20:05:35 +0900 (Sun, 04 May 2008) | 1 line +Changed paths: + M /lang/perl/tiarra/trunk/main/RunLoop.pm + +* use lazy loading for ControlPort. +------------------------------------------------------------------------ +r11099 | topia | 2008-05-04 20:04:39 +0900 (Sun, 04 May 2008) | 1 line +Changed paths: + M /lang/perl/tiarra/trunk/main/ControlPort.pm + +* use Tiarra::TerminateManager. +------------------------------------------------------------------------ +r11049 | topia | 2008-05-04 03:35:00 +0900 (Sun, 04 May 2008) | 1 line +Changed paths: + M /lang/perl/tiarra/trunk/all.conf + M /lang/perl/tiarra/trunk/doc/module/CTCP.html + M /lang/perl/tiarra/trunk/doc/module/System.html + M /lang/perl/tiarra/trunk/doc/module-toc.html + M /lang/perl/tiarra/trunk/sample.conf + +* regenerate documentation. +------------------------------------------------------------------------ +r11048 | topia | 2008-05-04 03:20:06 +0900 (Sun, 04 May 2008) | 1 line +Changed paths: + A /lang/perl/tiarra/trunk/module/CTCP/DCC + A /lang/perl/tiarra/trunk/module/CTCP/DCC/RewriteAddress.pm + +* add cTCP::DCC::RewriteAddress. +------------------------------------------------------------------------ +r11043 | topia | 2008-05-04 02:02:38 +0900 (Sun, 04 May 2008) | 2 lines +Changed paths: + M /lang/perl/tiarra/trunk/tiarra + +* drop cvsversion scanner. +* minor behavior fixes. +------------------------------------------------------------------------ +r11017 | hio | 2008-05-03 15:45:50 +0900 (Sat, 03 May 2008) | 2 lines +Changed paths: + M /lang/perl/tiarra/trunk/module/System/WebClient.pm + +WebClient, 入退室やトピックなんかも実装. + +------------------------------------------------------------------------ +r11016 | hio | 2008-05-03 15:43:45 +0900 (Sat, 03 May 2008) | 2 lines +Changed paths: + M /lang/perl/tiarra/trunk/module/Tools/HTTPParser.pm + +HTTP ステータスをすこし追加. + +------------------------------------------------------------------------ +r11015 | hio | 2008-05-03 15:42:38 +0900 (Sat, 03 May 2008) | 3 lines +Changed paths: + M /lang/perl/tiarra/trunk/module/Auto/FetchTitle.pm + +チャンネル別に明示的に使わないが出来なかったのを修正. +LANアドレス判定を毎回やってたのを修正. + +------------------------------------------------------------------------ +r11014 | hio | 2008-05-03 15:40:52 +0900 (Sat, 03 May 2008) | 2 lines +Changed paths: + M /lang/perl/tiarra/trunk/module/Tools/HTTPClient.pm + +HTTPClient, 正常終了判定の修正. shutdown処理をコメントアウト. + +------------------------------------------------------------------------ +r10996 | topia | 2008-05-03 05:47:32 +0900 (Sat, 03 May 2008) | 1 line +Changed paths: + M /lang/perl/tiarra/trunk/all.conf + M /lang/perl/tiarra/trunk/doc/module/Auto.html + +* regenerate documentation. +------------------------------------------------------------------------ +r10983 | topia | 2008-05-03 01:53:53 +0900 (Sat, 03 May 2008) | 1 line +Changed paths: + M /lang/perl/tiarra/trunk/main/Tiarra/Socket/Connect.pm + +* partially rewrite select result processing code in socket connector. +------------------------------------------------------------------------ +r10982 | topia | 2008-05-03 01:49:32 +0900 (Sat, 03 May 2008) | 1 line +Changed paths: + M /lang/perl/tiarra/trunk/main/Tiarra/Socket.pm + M /lang/perl/tiarra/trunk/main/Timer.pm + +* use lazy loading for RunLoop. +------------------------------------------------------------------------ +r10977 | topia | 2008-05-03 01:14:16 +0900 (Sat, 03 May 2008) | 4 lines +Changed paths: + M /lang/perl/tiarra/trunk/main/Tiarra/Resolver.pm + +* make timer mainloop interval to a second. +* add hook mainloop (to quick response). +* some informational comment added. +* fix some behavior on error. +------------------------------------------------------------------------ +r10975 | topia | 2008-05-03 01:09:53 +0900 (Sat, 03 May 2008) | 1 line +Changed paths: + M /lang/perl/tiarra/trunk/main/Tiarra/WrapMainLoop.pm + +* fix minor bug. +------------------------------------------------------------------------ +r10974 | topia | 2008-05-03 01:08:19 +0900 (Sat, 03 May 2008) | 1 line +Changed paths: + M /lang/perl/tiarra/trunk/main/ModuleManager.pm + +* use eval for ->destruct. +------------------------------------------------------------------------ +r10973 | topia | 2008-05-03 01:06:53 +0900 (Sat, 03 May 2008) | 1 line +Changed paths: + M /lang/perl/tiarra/trunk/module/Auto/Calc.pm + +* fix documentation bug. +------------------------------------------------------------------------ +r10972 | topia | 2008-05-03 00:49:49 +0900 (Sat, 03 May 2008) | 1 line +Changed paths: + M /lang/perl/tiarra/trunk/module/Tools/DateConvert.pm + +* Tools::DateConvert::replace: fix minor bug. +------------------------------------------------------------------------ +r10971 | topia | 2008-05-03 00:43:52 +0900 (Sat, 03 May 2008) | 2 lines +Changed paths: + M /lang/perl/tiarra/trunk/module/Tools/MailSend/EachServer.pm + M /lang/perl/tiarra/trunk/module/Tools/MailSend.pm + +* get rid of dependency to getpwuid (support win32). +* use pureperl dateconvert (fix locale related issue). +------------------------------------------------------------------------ +r10970 | topia | 2008-05-03 00:41:37 +0900 (Sat, 03 May 2008) | 1 line +Changed paths: + M /lang/perl/tiarra/trunk/module/Tools/DateConvert.pm + +* Tools::DateConvert::replace: add pureperl argument. +------------------------------------------------------------------------ +r10954 | hio | 2008-05-02 22:24:15 +0900 (Fri, 02 May 2008) | 2 lines +Changed paths: + M /lang/perl/tiarra/trunk/module/Auto/FetchTitle.pm + M /lang/perl/tiarra/trunk/module/Tools/HTTPClient/SSL.pm + M /lang/perl/tiarra/trunk/module/Tools/HTTPClient.pm + +lang/perl/tiarra: FetchTitle他, IPアドレスチェックがちゃんとできてなかったのを修正. + +------------------------------------------------------------------------ +r10908 | hio | 2008-05-02 01:57:24 +0900 (Fri, 02 May 2008) | 2 lines +Changed paths: + M /lang/perl/tiarra/trunk/module/Auto/FetchTitle/Plugin/Mixi.pm + M /lang/perl/tiarra/trunk/module/Auto/FetchTitle.pm + +lang/perl/tiarra: plugin単位での設定に対応. Privateアドレスのアクセス拒否を実装. + +------------------------------------------------------------------------ +r10907 | hio | 2008-05-02 01:52:07 +0900 (Fri, 02 May 2008) | 2 lines +Changed paths: + M /lang/perl/tiarra/trunk/module/Tools/HTTPClient.pm + +lang/perl/tiarra: HTTPClient, Tiarra::Resolverを使ってDNS解決をおこなうように. + +------------------------------------------------------------------------ +r10893 | hio | 2008-05-01 21:42:29 +0900 (Thu, 01 May 2008) | 2 lines +Changed paths: + M /lang/perl/tiarra/trunk/module/Auto/FetchTitle.pm + +lang/perl/tiarra: FetchTitle, DEBUGモードのままだった＞＜。 + +------------------------------------------------------------------------ +r10891 | hio | 2008-05-01 21:18:10 +0900 (Thu, 01 May 2008) | 4 lines +Changed paths: + A /lang/perl/tiarra/trunk/module/Auto/FetchTitle + A /lang/perl/tiarra/trunk/module/Auto/FetchTitle/Plugin + A /lang/perl/tiarra/trunk/module/Auto/FetchTitle/Plugin/ExtractHeading.pm + A /lang/perl/tiarra/trunk/module/Auto/FetchTitle/Plugin/Mixi.pm + A /lang/perl/tiarra/trunk/module/Auto/FetchTitle/Plugin/TouhouReplay.pm + A /lang/perl/tiarra/trunk/module/Auto/FetchTitle/Plugin.pm + M /lang/perl/tiarra/trunk/module/Auto/FetchTitle.pm + +lang/perl/tiarra: FetchTitle, カスタマイズ部分を独立モジュールでかけるように. +POSTでの再問い合わせに対応. +Cookieの対応. + +------------------------------------------------------------------------ +r10890 | hio | 2008-05-01 20:13:21 +0900 (Thu, 01 May 2008) | 2 lines +Changed paths: + M /lang/perl/tiarra/trunk/module/Tools/HTTPParser.pm + +lang/perl/tiarra: HTTPParser, 複数回でてきたヘッダもひとまず保持できるように. + +------------------------------------------------------------------------ +r10889 | hio | 2008-05-01 20:07:47 +0900 (Thu, 01 May 2008) | 2 lines +Changed paths: + M /lang/perl/tiarra/trunk/module/Tools/HTTPClient.pm + +lang/perl/tiarra: HTTPClient, リクエスト送信後, shutdownを発行するように修正. + +------------------------------------------------------------------------ +r10848 | topia | 2008-05-01 01:14:33 +0900 (Thu, 01 May 2008) | 1 line +Changed paths: + M /lang/perl/tiarra/trunk/main/RunLoop.pm + +* support new irc message remarks: do-not-broadcast-to-clients and do-not-send-to-server. +------------------------------------------------------------------------ +r10846 | topia | 2008-05-01 01:06:02 +0900 (Thu, 01 May 2008) | 2 lines +Changed paths: + M /lang/perl/tiarra/trunk/main/Tiarra/Resolver.pm + +* add nameinfo query type. +* add informational comments. +------------------------------------------------------------------------ +r10231 | topia | 2008-04-24 02:38:16 +0900 (Thu, 24 Apr 2008) | 2 lines +Changed paths: + M /lang/perl/tiarra/trunk/main/Tiarra/Socket/Lined.pm + +* Tiarra::Socket::Lined を EOL を無視して使えるようにした。 + send_reserve を使いたい時は eol を一時的に書き換えてください。 +------------------------------------------------------------------------ +r9987 | hio | 2008-04-20 16:52:19 +0900 (Sun, 20 Apr 2008) | 2 lines +Changed paths: + M /lang/perl/tiarra/trunk/module/Auto/FetchTitle.pm + +lang/perl/tiarra: 見出し抽出の追加, 200以外でも抽出を行えるように. + +------------------------------------------------------------------------ +r9947 | drry | 2008-04-20 08:43:24 +0900 (Sun, 20 Apr 2008) | 3 lines +Changed paths: + M /lang/perl/tiarra/trunk/main/Tiarra/Resolver.pm + +lang/perl/tiarra/trunk/main/Tiarra/Resolver.pm: + * ワイの環境ではこの部分で止まってしまったとばい。ワークアラウンドや。 + +------------------------------------------------------------------------ +r9724 | mumumu | 2008-04-18 23:03:21 +0900 (Fri, 18 Apr 2008) | 2 lines +Changed paths: + M /lang/perl/tiarra/trunk/main/IrcIO/Client.pm + +- fixed bug server numeric reply included user fullname. + +------------------------------------------------------------------------ +r9215 | hio | 2008-04-09 23:37:50 +0900 (Wed, 09 Apr 2008) | 2 lines +Changed paths: + M /lang/perl/tiarra/trunk/all.conf + M /lang/perl/tiarra/trunk/doc/module/System.html + M /lang/perl/tiarra/trunk/module/System/WebClient.pm + M /lang/perl/tiarra/trunk/module/Tools/HTTPParser.pm + M /lang/perl/tiarra/trunk/module/Tools/HTTPServer/Client.pm + M /lang/perl/tiarra/trunk/module/Tools/HTTPServer.pm + +lang/perl/tiarra: HTTPオブジェクトにRemoteAddrを持たせるように. X-Forwarded-For の展開をサポート. + +------------------------------------------------------------------------ +r9107 | hio | 2008-04-08 02:25:45 +0900 (Tue, 08 Apr 2008) | 1 line +Changed paths: + M /lang/perl/tiarra/trunk/module/System/WebClient.pm + +lang/perl/tiarra: use しないで使ってるモジュールがあった. +------------------------------------------------------------------------ +r9106 | hio | 2008-04-08 02:07:34 +0900 (Tue, 08 Apr 2008) | 1 line +Changed paths: + M /lang/perl/tiarra/trunk/module/Tools/HTTPServer/Client.pm + M /lang/perl/tiarra/trunk/module/Tools/HTTPServer.pm + +lang/perl/tiarra: デバッグメッセージの抑制 +------------------------------------------------------------------------ +r9104 | hio | 2008-04-08 01:22:54 +0900 (Tue, 08 Apr 2008) | 1 line +Changed paths: + M /lang/perl/tiarra/trunk/main/Tiarra/Resolver.pm + +lang/perl/tiarra: Win2kでlocalhostを解決できない現象の回避 +------------------------------------------------------------------------ +r9103 | hio | 2008-04-08 01:12:43 +0900 (Tue, 08 Apr 2008) | 1 line +Changed paths: + M /lang/perl/tiarra/trunk/main/RunLoop.pm + +lang/perl/tiarra: Win32/select()+Ctrl-C挙動のメモ追加 +------------------------------------------------------------------------ +r9023 | hio | 2008-04-06 23:36:56 +0900 (Sun, 06 Apr 2008) | 1 line +Changed paths: + M /lang/perl/tiarra/trunk/module/System/WebClient.pm + +lang/perl/tiarra: owner-mode/shared-modeの設定を追加 +------------------------------------------------------------------------ +r9021 | hio | 2008-04-06 22:17:41 +0900 (Sun, 06 Apr 2008) | 3 lines +Changed paths: + M /lang/perl/tiarra/trunk/module/System/WebClient.pm + +lang/perl/tiarra: System::WebClient, topicとメンバの表示を追加, +ログのページ分けを実装. + +------------------------------------------------------------------------ +r9012 | hio | 2008-04-06 19:55:41 +0900 (Sun, 06 Apr 2008) | 2 lines +Changed paths: + M /lang/perl/tiarra/trunk/all.conf + M /lang/perl/tiarra/trunk/doc/module/Auto.html + M /lang/perl/tiarra/trunk/module/Auto/FetchTitle.pm + +lang/perl/tiarra: System::WebClient, config-reload のチェックを追加. + +------------------------------------------------------------------------ +r9011 | hio | 2008-04-06 19:45:27 +0900 (Sun, 06 Apr 2008) | 2 lines +Changed paths: + M /lang/perl/tiarra/trunk/all.conf + M /lang/perl/tiarra/trunk/doc/module/System.html + M /lang/perl/tiarra/trunk/module/System/WebClient.pm + +lang/perl/tiarra: System::WebClient, ドキュメント加筆. + +------------------------------------------------------------------------ +r9010 | hio | 2008-04-06 19:42:15 +0900 (Sun, 06 Apr 2008) | 2 lines +Changed paths: + M /lang/perl/tiarra/trunk/main/Mask.pm + +lang/perl/tiarra: Mask#match_chan, コメント加筆. + +------------------------------------------------------------------------ +r9005 | hio | 2008-04-06 17:12:28 +0900 (Sun, 06 Apr 2008) | 2 lines +Changed paths: + M /lang/perl/tiarra/trunk/doc/default.css + +lang/perl/tiarra: モジュール一覧HTMLのスタイル調整. + +------------------------------------------------------------------------ +r8998 | hio | 2008-04-06 16:32:26 +0900 (Sun, 06 Apr 2008) | 2 lines +Changed paths: + M /lang/perl/tiarra/trunk/all.conf + M /lang/perl/tiarra/trunk/doc/module/System.html + M /lang/perl/tiarra/trunk/doc/module-toc.html + M /lang/perl/tiarra/trunk/module/System/WebClient.pm + +lang/perl/tiarra: System::WebClient, ドキュメント加筆. + +------------------------------------------------------------------------ +r8995 | hio | 2008-04-06 16:27:40 +0900 (Sun, 06 Apr 2008) | 2 lines +Changed paths: + M /lang/perl/tiarra/trunk/doc/module/Auto.html + M /lang/perl/tiarra/trunk/doc/module/Channel.html + M /lang/perl/tiarra/trunk/doc/module/Log.html + M /lang/perl/tiarra/trunk/doc/module/System.html + M /lang/perl/tiarra/trunk/doc/module/User.html + M /lang/perl/tiarra/trunk/doc/module-toc.html + M /lang/perl/tiarra/trunk/makedoc + +lang/perl/tiarra: モジュール一覧のHTMLがescapeされていなかったので修正. + +------------------------------------------------------------------------ +r8988 | hio | 2008-04-06 15:26:43 +0900 (Sun, 06 Apr 2008) | 2 lines +Changed paths: + A /lang/perl/tiarra/trunk/module/System/WebClient.pm + +lang/perl/tiarra: System::WebClient, HTTPでのIRCインターフェースを追加. + +------------------------------------------------------------------------ +r8985 | hio | 2008-04-06 15:17:58 +0900 (Sun, 06 Apr 2008) | 4 lines +Changed paths: + M /lang/perl/tiarra/trunk/module/Tools/HTTPClient.pm + A /lang/perl/tiarra/trunk/module/Tools/HTTPParser.pm + A /lang/perl/tiarra/trunk/module/Tools/HTTPServer + A /lang/perl/tiarra/trunk/module/Tools/HTTPServer/Client.pm + A /lang/perl/tiarra/trunk/module/Tools/HTTPServer.pm + +lang/perl/tiarra: HTTP通信解釈モジュール Tools::HTTPParser を追加. +Tools::HTTPServer追加. +Tools::HTTPClientをTools::HTTPParserを使うように修正. + +------------------------------------------------------------------------ +r8984 | hio | 2008-04-06 15:07:22 +0900 (Sun, 06 Apr 2008) | 2 lines +Changed paths: + M /lang/perl/tiarra/trunk/module/Tools/HTTPClient/SSL.pm + +lang/perl/tiarra: Tools::HTTPClient::SSL, こまごま調整. + +------------------------------------------------------------------------ +r8983 | hio | 2008-04-06 15:01:08 +0900 (Sun, 06 Apr 2008) | 7 lines +Changed paths: + M /lang/perl/tiarra/trunk/module/Auto/FetchTitle.pm + +lang/perl/tiarra: cookie指定の対応. +ドキュメント取得パラメータの調整. +複数のフィルタを呼べるように修正. +不完全なLocation(相対指定)に対応. +警告抑制, デバッグメッセージ追加. + + +------------------------------------------------------------------------ +r8981 | hio | 2008-04-06 14:53:10 +0900 (Sun, 06 Apr 2008) | 2 lines +Changed paths: + M /lang/perl/tiarra/trunk/module/System/LivePatch.pm + +lang/perl/tiarra: 条件判定が逆だったo__)o + +------------------------------------------------------------------------ +r8978 | hio | 2008-04-06 14:06:08 +0900 (Sun, 06 Apr 2008) | 2 lines +Changed paths: + M /lang/perl/tiarra/trunk/all.conf + M /lang/perl/tiarra/trunk/doc/module/Debug.html + M /lang/perl/tiarra/trunk/doc/module-toc.html + A /lang/perl/tiarra/trunk/module/Debug/Core.pm + +lang/perl/tiarra: Debug::Core, Tiarra の内部構造追跡モジュールを追加. + +------------------------------------------------------------------------ +r8977 | hio | 2008-04-06 14:00:17 +0900 (Sun, 06 Apr 2008) | 2 lines +Changed paths: + M /lang/perl/tiarra/trunk/module/Log/Logger.pm + +lang/perl/tiarra: TALK時の整形をLog::Channelから拝借. + +------------------------------------------------------------------------ +r8976 | hio | 2008-04-06 13:48:46 +0900 (Sun, 06 Apr 2008) | 2 lines +Changed paths: + M /lang/perl/tiarra/trunk/all.conf + M /lang/perl/tiarra/trunk/doc/module/System.html + M /lang/perl/tiarra/trunk/module/System/LivePatch.pm + +lang/perl/tiarra: System::LivePatch, /livepatch apply されるまで適用は行わないように変更. + +------------------------------------------------------------------------ +r8939 | topia | 2008-04-05 23:17:51 +0900 (Sat, 05 Apr 2008) | 1 line +Changed paths: + M /lang/perl/tiarra/trunk/AUTHORS + M /lang/perl/tiarra/trunk/main/Tiarra/IRC/Message.pm + M /lang/perl/tiarra/trunk/module/System/PrivTranslator.pm + M /lang/perl/tiarra/trunk/module/Tools/HTTPClient.pm + M /lang/perl/tiarra/trunk/tiarra + +lang/perl/tiarra: * change copyright style. +------------------------------------------------------------------------ +r8937 | topia | 2008-04-05 23:10:50 +0900 (Sat, 05 Apr 2008) | 1 line +Changed paths: + M /lang/perl/tiarra/trunk/tiarra + +lang/perl/tiarra: * change copyright style. +------------------------------------------------------------------------ +r8930 | hio | 2008-04-05 22:27:12 +0900 (Sat, 05 Apr 2008) | 2 lines +Changed paths: + M /lang/perl/tiarra/trunk/main/LinedINETSocket.pm + +lang/perl/tiarra: LinedINETSocket が接続失敗時もinstallされていたバグの修正. + +------------------------------------------------------------------------ +r8826 | topia | 2008-04-04 09:37:47 +0900 (Fri, 04 Apr 2008) | 1 line +Changed paths: + M /lang/perl/tiarra/trunk/module/System/LivePatch.pm + +lang/perl/tiarra: * set mime-type for System::LivePatch. +------------------------------------------------------------------------ +r8825 | hio | 2008-04-04 09:06:31 +0900 (Fri, 04 Apr 2008) | 2 lines +Changed paths: + M /lang/perl/tiarra/trunk/all.conf + M /lang/perl/tiarra/trunk/doc/module/System.html + M /lang/perl/tiarra/trunk/doc/module-toc.html + A /lang/perl/tiarra/trunk/module/System/LivePatch.pm + +lang/perl/tiarra: add System::LivePatch. + +------------------------------------------------------------------------ +r8810 | topia | 2008-04-03 23:48:46 +0900 (Thu, 03 Apr 2008) | 1 line +Changed paths: + M /lang/perl/tiarra/trunk/module/Tools/GroupDB.pm + +lang/perl/tiarra: * use dup_group instead of clone object method. +------------------------------------------------------------------------ +r8809 | topia | 2008-04-03 23:47:41 +0900 (Thu, 03 Apr 2008) | 1 line +Changed paths: + M /lang/perl/tiarra/trunk/main/ModuleManager.pm + +lang/perl/tiarra: * destruct modules before unloading it. +------------------------------------------------------------------------ +r8622 | hio | 2008-04-02 00:26:23 +0900 (Wed, 02 Apr 2008) | 2 lines +Changed paths: + M /lang/perl/tiarra/trunk/module/Auto/FetchTitle.pm + +コードの整理と見出し抽出の抽象化. + +------------------------------------------------------------------------ +r8620 | hio | 2008-04-02 00:16:24 +0900 (Wed, 02 Apr 2008) | 2 lines +Changed paths: + A /lang/perl/tiarra/trunk/module/Tools/HTTPClient + A /lang/perl/tiarra/trunk/module/Tools/HTTPClient/SSL.pm + M /lang/perl/tiarra/trunk/module/Tools/HTTPClient.pm + +かなり適当なHTTPClientのSSLサポート. + +------------------------------------------------------------------------ +r8435 | elim | 2008-03-27 12:20:36 +0900 (Thu, 27 Mar 2008) | 2 lines +Changed paths: + M /lang/perl/tiarra/trunk/tiarra-conf.el + M /lang/perl/tiarra/trunk/tiarra-conf.l + +lang/perl/tiarra: set svn:mime-type. + +------------------------------------------------------------------------ +r8273 | hio | 2008-03-22 20:45:17 +0900 (Sat, 22 Mar 2008) | 1 line +Changed paths: + M /lang/perl/tiarra/trunk/all.conf + M /lang/perl/tiarra/trunk/doc/module/Auto.html + A /lang/perl/tiarra/trunk/doc/module/UNCLASSIFIED.html + M /lang/perl/tiarra/trunk/doc/module-toc.html + +lang/perl/tiarra: update documents +------------------------------------------------------------------------ +r8272 | hio | 2008-03-22 20:41:58 +0900 (Sat, 22 Mar 2008) | 1 line +Changed paths: + A /lang/perl/tiarra/trunk/module/Auto/FetchTitle.pm + +lang/perl/tiarra: new module, Auto::FetchTitle +------------------------------------------------------------------------ +r8271 | hio | 2008-03-22 20:18:21 +0900 (Sat, 22 Mar 2008) | 1 line +Changed paths: + M /lang/perl/tiarra/trunk/main/Mask.pm + +lang/perl/tiarra: add comment +------------------------------------------------------------------------ +r8220 | hio | 2008-03-21 01:11:22 +0900 (Fri, 21 Mar 2008) | 4 lines +Changed paths: + M /lang/perl/tiarra/trunk/module/Tools/HTTPClient.pm + +lang/perl/tiarra: add ProgressCallback, and documents. +fix, error handring on connect/disconnect failure. +fix, content body after last CR-LF was lost. + +------------------------------------------------------------------------ +r8219 | hio | 2008-03-21 00:59:13 +0900 (Fri, 21 Mar 2008) | 1 line +Changed paths: + M /lang/perl/tiarra/trunk/main/Tiarra/Socket/Buffered.pm + +lang/perl/tiarra: fix, do not clear recvbuf on detach, it cause data lost +------------------------------------------------------------------------ +r8217 | hio | 2008-03-21 00:57:24 +0900 (Fri, 21 Mar 2008) | 1 line +Changed paths: + M /lang/perl/tiarra/trunk/main/Mask.pm + +lang/perl/tiarra: add comment for usage of Mask::match +------------------------------------------------------------------------ +r8216 | hio | 2008-03-21 00:55:04 +0900 (Fri, 21 Mar 2008) | 1 line +Changed paths: + M /lang/perl/tiarra/trunk/doc-src/module-group.tdoc + +lang/perl/tiarra: add description for unclassified modules +------------------------------------------------------------------------ +r8215 | hio | 2008-03-21 00:54:28 +0900 (Fri, 21 Mar 2008) | 1 line +Changed paths: + M /lang/perl/tiarra/trunk/main/TiarraDoc.pm + +lang/perl/tiarra: fix, show UNCLASSIFIED modules in module-toc.html +------------------------------------------------------------------------ +r8214 | hio | 2008-03-21 00:52:58 +0900 (Fri, 21 Mar 2008) | 1 line +Changed paths: + M /lang/perl/tiarra/trunk/module/Skelton.pm + +lang/perl/tiarra: add document for skelton +------------------------------------------------------------------------ +r8213 | hio | 2008-03-21 00:46:14 +0900 (Fri, 21 Mar 2008) | 1 line +Changed paths: + M /lang/perl/tiarra/trunk/makedoc + +lang/perl/tiarra: add, =begin tiarra-doc ... =end tiarra-doc style document. +------------------------------------------------------------------------ +r8081 | hio | 2008-03-18 19:46:39 +0900 (Tue, 18 Mar 2008) | 1 line +Changed paths: + M /lang/perl/tiarra/trunk/module/Auto/Answer.pm + +lang/perl/tiarra: new parameter channel-reply and answer-to-myself for Auto::Answer +------------------------------------------------------------------------ +r7640 | otsune | 2008-03-08 01:21:17 +0900 (Sat, 08 Mar 2008) | 2 lines +Changed paths: + A /lang/perl (from /lang/perl:7636) + +Resurrected lang/perl from revision 7636 + +------------------------------------------------------------------------ +r5918 | topia | 2008-01-31 04:00:25 +0900 (Thu, 31 Jan 2008) | 1 line +Changed paths: + M /lang/perl/tiarra/trunk/module/Auto/AliasDB.pm + +lang/perl/tiarra: * bugfix: use Tools::Hash instance instead of plain hash. +------------------------------------------------------------------------ +r5917 | topia | 2008-01-31 03:59:36 +0900 (Thu, 31 Jan 2008) | 1 line +Changed paths: + M /lang/perl/tiarra/trunk/module/Auto/MesMail.pm + +lang/perl/tiarra: * support smtp-auth, and small bugfixes. +------------------------------------------------------------------------ +r5916 | topia | 2008-01-31 03:58:33 +0900 (Thu, 31 Jan 2008) | 1 line +Changed paths: + M /lang/perl/tiarra/trunk/module/Tools/MailSend/EachServer.pm + M /lang/perl/tiarra/trunk/module/Tools/MailSend.pm + +lang/perl/tiarra: * implement SMTP-Auth, but supports PLAIN and LOGIN only. +------------------------------------------------------------------------ +r5911 | topia | 2008-01-31 01:06:47 +0900 (Thu, 31 Jan 2008) | 1 line +Changed paths: + D /dan/perl/tiarra + A /lang/perl/tiarra (from /dan/perl/tiarra:5910) + +ふっかつのじゅもんをまちがえていたので、わすれないうちになおす +------------------------------------------------------------------------ +r5905 | topia | 2008-01-31 00:05:09 +0900 (Thu, 31 Jan 2008) | 2 lines +Changed paths: + A /dan/perl/tiarra (from /lang/perl/tiarra:5903) + +なにもおもしろいことが起きなかったので復活の呪文 + +------------------------------------------------------------------------ +r5680 | drry | 2008-01-28 18:37:58 +0900 (Mon, 28 Jan 2008) | 2 lines +Changed paths: + M /lang/perl/tiarra/trunk/tiarra + +lang/perl/tiarra/trunk/tiarra: removed a mixed revision number. fixed a white space. + +------------------------------------------------------------------------ +r5636 | topia | 2008-01-27 17:52:28 +0900 (Sun, 27 Jan 2008) | 1 line +Changed paths: + M /lang/perl/tiarra/trunk/main/Multicast.pm + +lang/perl/tiarra/trunk: * BUGFIX: do not global/local nick convertion for TOPIC content. +------------------------------------------------------------------------ +r4748 | drry | 2008-01-17 04:22:16 +0900 (Thu, 17 Jan 2008) | 2 lines +Changed paths: + M /lang/perl/tiarra/trunk/tiarra + +lang/perl/tiarra/trunk/tiarra: system() が返すのは終了ステータスでした……。うわーん。 + +------------------------------------------------------------------------ +r4411 | topia | 2008-01-11 12:15:24 +0900 (Fri, 11 Jan 2008) | 1 line +Changed paths: + M /lang/perl/tiarra/trunk/all.conf + M /lang/perl/tiarra/trunk/doc/module/Auto.html + M /lang/perl/tiarra/trunk/doc/module/CTCP.html + M /lang/perl/tiarra/trunk/doc/module/Channel.html + M /lang/perl/tiarra/trunk/doc/module/Client.html + M /lang/perl/tiarra/trunk/doc/module/Debug.html + M /lang/perl/tiarra/trunk/doc/module/Log.html + M /lang/perl/tiarra/trunk/doc/module/System.html + M /lang/perl/tiarra/trunk/doc/module/User.html + M /lang/perl/tiarra/trunk/doc/module-toc.html + M /lang/perl/tiarra/trunk/sample.conf + +lang/perl/tiarra/trunk: * re-generate documentation. +------------------------------------------------------------------------ +r4410 | topia | 2008-01-11 12:14:37 +0900 (Fri, 11 Jan 2008) | 1 line +Changed paths: + M /lang/perl/tiarra/trunk/doc-src/conf-main.tdoc + M /lang/perl/tiarra/trunk/module/System/PrivTranslator.pm + +lang/perl/tiarra/trunk: * add caution for bad network-separator to use System::PrivTranslator. +------------------------------------------------------------------------ +r4404 | drry | 2008-01-11 08:37:30 +0900 (Fri, 11 Jan 2008) | 2 lines +Changed paths: + M /lang/perl/tiarra/trunk/main/Tiarra/IRC/Message.pm + M /lang/perl/tiarra/trunk/module/Client/Guess.pm + M /lang/perl/tiarra/trunk/tiarra + +lang/perl/tiarra/trunk: use system() instead of a backtick oper, etc. + +------------------------------------------------------------------------ +r3010 | topia | 2007-12-10 22:36:55 +0900 (Mon, 10 Dec 2007) | 1 line +Changed paths: + D /lang/perl/tiarra/AUTHORS + D /lang/perl/tiarra/ChangeLog + D /lang/perl/tiarra/ChangeLog.svn + D /lang/perl/tiarra/HACKING + D /lang/perl/tiarra/INSTALL + D /lang/perl/tiarra/LICENSE + D /lang/perl/tiarra/Makefile + D /lang/perl/tiarra/NEWS + D /lang/perl/tiarra/all.conf + A /lang/perl/tiarra/branches + D /lang/perl/tiarra/bundle + D /lang/perl/tiarra/common + D /lang/perl/tiarra/doc + D /lang/perl/tiarra/doc-src + D /lang/perl/tiarra/main + D /lang/perl/tiarra/makedoc + D /lang/perl/tiarra/module + D /lang/perl/tiarra/run + D /lang/perl/tiarra/run-main + D /lang/perl/tiarra/run-subr + D /lang/perl/tiarra/runtiarra.perl + D /lang/perl/tiarra/sample.conf + D /lang/perl/tiarra/tiarra + D /lang/perl/tiarra/tiarra-conf.el + D /lang/perl/tiarra/tiarra-conf.l + A /lang/perl/tiarra/trunk + A /lang/perl/tiarra/trunk/AUTHORS (from /lang/perl/tiarra/AUTHORS:3009) + A /lang/perl/tiarra/trunk/ChangeLog (from /lang/perl/tiarra/ChangeLog:3009) + A /lang/perl/tiarra/trunk/ChangeLog.svn (from /lang/perl/tiarra/ChangeLog.svn:3009) + A /lang/perl/tiarra/trunk/HACKING (from /lang/perl/tiarra/HACKING:3009) + A /lang/perl/tiarra/trunk/INSTALL (from /lang/perl/tiarra/INSTALL:3009) + A /lang/perl/tiarra/trunk/LICENSE (from /lang/perl/tiarra/LICENSE:3009) + A /lang/perl/tiarra/trunk/Makefile (from /lang/perl/tiarra/Makefile:3009) + A /lang/perl/tiarra/trunk/NEWS (from /lang/perl/tiarra/NEWS:3009) + A /lang/perl/tiarra/trunk/all.conf (from /lang/perl/tiarra/all.conf:3009) + A /lang/perl/tiarra/trunk/bundle (from /lang/perl/tiarra/bundle:3009) + A /lang/perl/tiarra/trunk/common (from /lang/perl/tiarra/common:3009) + A /lang/perl/tiarra/trunk/doc (from /lang/perl/tiarra/doc:3009) + A /lang/perl/tiarra/trunk/doc-src (from /lang/perl/tiarra/doc-src:3009) + A /lang/perl/tiarra/trunk/main (from /lang/perl/tiarra/main:3009) + A /lang/perl/tiarra/trunk/makedoc (from /lang/perl/tiarra/makedoc:3009) + A /lang/perl/tiarra/trunk/module (from /lang/perl/tiarra/module:3009) + A /lang/perl/tiarra/trunk/run (from /lang/perl/tiarra/run:3009) + A /lang/perl/tiarra/trunk/run-main (from /lang/perl/tiarra/run-main:3009) + A /lang/perl/tiarra/trunk/run-subr (from /lang/perl/tiarra/run-subr:3009) + A /lang/perl/tiarra/trunk/runtiarra.perl (from /lang/perl/tiarra/runtiarra.perl:3009) + A /lang/perl/tiarra/trunk/sample.conf (from /lang/perl/tiarra/sample.conf:3009) + A /lang/perl/tiarra/trunk/tiarra (from /lang/perl/tiarra/tiarra:3009) + A /lang/perl/tiarra/trunk/tiarra-conf.el (from /lang/perl/tiarra/tiarra-conf.el:3009) + A /lang/perl/tiarra/trunk/tiarra-conf.l (from /lang/perl/tiarra/tiarra-conf.l:3009) + +lang/perl/tiarra: migrate to trunk/branches. +------------------------------------------------------------------------ +r3009 | topia | 2007-12-10 22:35:53 +0900 (Mon, 10 Dec 2007) | 1 line +Changed paths: + M /lang/perl/tiarra/module/System/Inflate.pm + M /lang/perl/tiarra/tiarra + +lang/perl/tiarra: fix typo. +------------------------------------------------------------------------ +r3008 | tokuhirom | 2007-12-10 22:33:19 +0900 (Mon, 10 Dec 2007) | 1 line +Changed paths: + M /lang/perl/tiarra/HACKING + +lang/perl/tiarra: fixed typo +------------------------------------------------------------------------ +r3007 | topia | 2007-12-10 22:22:05 +0900 (Mon, 10 Dec 2007) | 1 line +Changed paths: + M /lang/perl/tiarra/doc/default.css + +lang/perl/tiarra: fix import url. +------------------------------------------------------------------------ +r3004 | topia | 2007-12-10 21:45:39 +0900 (Mon, 10 Dec 2007) | 1 line +Changed paths: + A /lang/perl/tiarra + A /lang/perl/tiarra/AUTHORS + A /lang/perl/tiarra/ChangeLog + A /lang/perl/tiarra/ChangeLog.svn + A /lang/perl/tiarra/HACKING + A /lang/perl/tiarra/INSTALL + A /lang/perl/tiarra/LICENSE + A /lang/perl/tiarra/Makefile + A /lang/perl/tiarra/NEWS + A /lang/perl/tiarra/all.conf + A /lang/perl/tiarra/bundle + A /lang/perl/tiarra/bundle/Unicode + A /lang/perl/tiarra/bundle/Unicode/Japanese.pm + A /lang/perl/tiarra/bundle/enum.pm + A /lang/perl/tiarra/common + A /lang/perl/tiarra/common/run-script + A /lang/perl/tiarra/common/run-script/add-rc-once.sh + A /lang/perl/tiarra/common/run-script/rc-onces + A /lang/perl/tiarra/common/run-script/rc-onces/remove-log.sh + A /lang/perl/tiarra/doc + A /lang/perl/tiarra/doc/default.css + A /lang/perl/tiarra/doc/module + A /lang/perl/tiarra/doc/module/Auto.html + A /lang/perl/tiarra/doc/module/CTCP.html + A /lang/perl/tiarra/doc/module/Channel.html + A /lang/perl/tiarra/doc/module/Client.html + A /lang/perl/tiarra/doc/module/Debug.html + A /lang/perl/tiarra/doc/module/Log.html + A /lang/perl/tiarra/doc/module/System.html + A /lang/perl/tiarra/doc/module/User.html + A /lang/perl/tiarra/doc/module-toc.html + A /lang/perl/tiarra/doc-src + A /lang/perl/tiarra/doc-src/README + A /lang/perl/tiarra/doc-src/all.conf.in + A /lang/perl/tiarra/doc-src/conf-main.tdoc + A /lang/perl/tiarra/doc-src/contents.html + A /lang/perl/tiarra/doc-src/module-group.tdoc + A /lang/perl/tiarra/doc-src/module-toc.html + A /lang/perl/tiarra/doc-src/sample.conf.in + A /lang/perl/tiarra/main + A /lang/perl/tiarra/main/BulletinBoard.pm + A /lang/perl/tiarra/main/CTCP.pm + A /lang/perl/tiarra/main/ChannelInfo.pm + A /lang/perl/tiarra/main/Configuration + A /lang/perl/tiarra/main/Configuration/Block.pm + A /lang/perl/tiarra/main/Configuration/LexicalAnalyzer.pm + A /lang/perl/tiarra/main/Configuration/Parser.pm + A /lang/perl/tiarra/main/Configuration/Preprocessor.pm + A /lang/perl/tiarra/main/Configuration.pm + A /lang/perl/tiarra/main/ControlPort.pm + A /lang/perl/tiarra/main/Crypt.pm + A /lang/perl/tiarra/main/Exception.pm + A /lang/perl/tiarra/main/ExternalSocket.pm + A /lang/perl/tiarra/main/FunctionalVariable.pm + A /lang/perl/tiarra/main/Hook.pm + A /lang/perl/tiarra/main/IRCMessage.pm + A /lang/perl/tiarra/main/InstantCapsule.pm + A /lang/perl/tiarra/main/IrcIO + A /lang/perl/tiarra/main/IrcIO/Client.pm + A /lang/perl/tiarra/main/IrcIO/Server.pm + A /lang/perl/tiarra/main/IrcIO.pm + A /lang/perl/tiarra/main/Iterator + A /lang/perl/tiarra/main/Iterator/ArrayIterator.pm + A /lang/perl/tiarra/main/Iterator/BackwardIterator.pm + A /lang/perl/tiarra/main/Iterator/BidirectionalIterator.pm + A /lang/perl/tiarra/main/Iterator/ForwardIterator.pm + A /lang/perl/tiarra/main/Iterator/RandomAccessIterator.pm + A /lang/perl/tiarra/main/Iterator/RoundIterator.pm + A /lang/perl/tiarra/main/Iterator.pm + A /lang/perl/tiarra/main/L10N.pm + A /lang/perl/tiarra/main/LinedINETSocket.pm + A /lang/perl/tiarra/main/LocalChannelManager.pm + A /lang/perl/tiarra/main/Mask.pm + A /lang/perl/tiarra/main/Module + A /lang/perl/tiarra/main/Module/Use.pm + A /lang/perl/tiarra/main/Module.pm + A /lang/perl/tiarra/main/ModuleManager.pm + A /lang/perl/tiarra/main/Multicast.pm + A /lang/perl/tiarra/main/NumericReply.pm + A /lang/perl/tiarra/main/PersonInChannel.pm + A /lang/perl/tiarra/main/PersonalInfo.pm + A /lang/perl/tiarra/main/ReloadTrigger.pm + A /lang/perl/tiarra/main/RunLoop.pm + A /lang/perl/tiarra/main/Template.pm + A /lang/perl/tiarra/main/Tiarra + A /lang/perl/tiarra/main/Tiarra/DefineEnumMixin.pm + A /lang/perl/tiarra/main/Tiarra/Encoding + A /lang/perl/tiarra/main/Tiarra/Encoding/Encode + A /lang/perl/tiarra/main/Tiarra/Encoding/Encode/CP932JIS.pm + A /lang/perl/tiarra/main/Tiarra/Encoding/Encode.pm + A /lang/perl/tiarra/main/Tiarra/Encoding/UniJP.pm + A /lang/perl/tiarra/main/Tiarra/Encoding.pm + A /lang/perl/tiarra/main/Tiarra/IRC + A /lang/perl/tiarra/main/Tiarra/IRC/Message.pm + A /lang/perl/tiarra/main/Tiarra/IRC/NewMessageMixin.pm + A /lang/perl/tiarra/main/Tiarra/IRC/Prefix.pm + A /lang/perl/tiarra/main/Tiarra/Mixin + A /lang/perl/tiarra/main/Tiarra/Mixin/AttachPackage.pm + A /lang/perl/tiarra/main/Tiarra/Mixin/NewIRCMessage.pm + A /lang/perl/tiarra/main/Tiarra/ModifiedFlagMixin.pm + A /lang/perl/tiarra/main/Tiarra/OptionalModules.pm + A /lang/perl/tiarra/main/Tiarra/Resolver.pm + A /lang/perl/tiarra/main/Tiarra/SessionMixin.pm + A /lang/perl/tiarra/main/Tiarra/SharedMixin.pm + A /lang/perl/tiarra/main/Tiarra/ShorthandConfMixin.pm + A /lang/perl/tiarra/main/Tiarra/Socket + A /lang/perl/tiarra/main/Tiarra/Socket/Buffered.pm + A /lang/perl/tiarra/main/Tiarra/Socket/Connect.pm + A /lang/perl/tiarra/main/Tiarra/Socket/Lined.pm + A /lang/perl/tiarra/main/Tiarra/Socket/Win32Errno.pm + A /lang/perl/tiarra/main/Tiarra/Socket.pm + A /lang/perl/tiarra/main/Tiarra/TerminateManager.pm + A /lang/perl/tiarra/main/Tiarra/Utils + A /lang/perl/tiarra/main/Tiarra/Utils/CallWrapper.pm + A /lang/perl/tiarra/main/Tiarra/Utils/Core.pm + A /lang/perl/tiarra/main/Tiarra/Utils/DefineHelper.pm + A /lang/perl/tiarra/main/Tiarra/Utils.pm + A /lang/perl/tiarra/main/Tiarra/WrapMainLoop.pm + A /lang/perl/tiarra/main/TiarraDoc.pm + A /lang/perl/tiarra/main/Timer.pm + A /lang/perl/tiarra/makedoc + A /lang/perl/tiarra/module + A /lang/perl/tiarra/module/Auto + A /lang/perl/tiarra/module/Auto/Alias.pm + A /lang/perl/tiarra/module/Auto/AliasDB + A /lang/perl/tiarra/module/Auto/AliasDB/CallbackUtils.pm + A /lang/perl/tiarra/module/Auto/AliasDB.pm + A /lang/perl/tiarra/module/Auto/Answer.pm + A /lang/perl/tiarra/module/Auto/CacheManager.pm + A /lang/perl/tiarra/module/Auto/Calc.pm + A /lang/perl/tiarra/module/Auto/ChannelWithoutOper.pm + A /lang/perl/tiarra/module/Auto/Joined.pm + A /lang/perl/tiarra/module/Auto/MesMail.pm + A /lang/perl/tiarra/module/Auto/Oper.pm + A /lang/perl/tiarra/module/Auto/Random.pm + A /lang/perl/tiarra/module/Auto/Reply.pm + A /lang/perl/tiarra/module/Auto/Response.pm + A /lang/perl/tiarra/module/Auto/Utils.pm + A /lang/perl/tiarra/module/CTCP + A /lang/perl/tiarra/module/CTCP/ClientInfo.pm + A /lang/perl/tiarra/module/CTCP/Ping.pm + A /lang/perl/tiarra/module/CTCP/Time.pm + A /lang/perl/tiarra/module/CTCP/UserInfo.pm + A /lang/perl/tiarra/module/CTCP/Version.pm + A /lang/perl/tiarra/module/Channel + A /lang/perl/tiarra/module/Channel/Freeze.pm + A /lang/perl/tiarra/module/Channel/Ignore.pm + A /lang/perl/tiarra/module/Channel/Join + A /lang/perl/tiarra/module/Channel/Join/Connect.pm + A /lang/perl/tiarra/module/Channel/Join/Invite.pm + A /lang/perl/tiarra/module/Channel/Join/Kicked.pm + A /lang/perl/tiarra/module/Channel/Mode + A /lang/perl/tiarra/module/Channel/Mode/Get.pm + A /lang/perl/tiarra/module/Channel/Mode/Oper + A /lang/perl/tiarra/module/Channel/Mode/Oper/Grant.pm + A /lang/perl/tiarra/module/Channel/Mode/Set.pm + A /lang/perl/tiarra/module/Channel/Rejoin.pm + A /lang/perl/tiarra/module/Client + A /lang/perl/tiarra/module/Client/Cache.pm + A /lang/perl/tiarra/module/Client/Conservative.pm + A /lang/perl/tiarra/module/Client/Cotton.pm + A /lang/perl/tiarra/module/Client/Eval.pm + A /lang/perl/tiarra/module/Client/GetVersion.pm + A /lang/perl/tiarra/module/Client/Guess.pm + A /lang/perl/tiarra/module/Client/PatchworkMessage.pm + A /lang/perl/tiarra/module/Client/ProtectMyself.pm + A /lang/perl/tiarra/module/Client/Rehash.pm + A /lang/perl/tiarra/module/Client/ShowNick.pm + A /lang/perl/tiarra/module/Debug + A /lang/perl/tiarra/module/Debug/AliasTest.pm + A /lang/perl/tiarra/module/Debug/RawLog.pm + A /lang/perl/tiarra/module/Log + A /lang/perl/tiarra/module/Log/Channel.pm + A /lang/perl/tiarra/module/Log/ChannelList.pm + A /lang/perl/tiarra/module/Log/Logger.pm + A /lang/perl/tiarra/module/Log/Raw.pm + A /lang/perl/tiarra/module/Log/Recent.pm + A /lang/perl/tiarra/module/Log/Writer + A /lang/perl/tiarra/module/Log/Writer/Base.pm + A /lang/perl/tiarra/module/Log/Writer/File.pm + A /lang/perl/tiarra/module/Log/Writer.pm + A /lang/perl/tiarra/module/Skelton.pm + A /lang/perl/tiarra/module/System + A /lang/perl/tiarra/module/System/Error.pm + A /lang/perl/tiarra/module/System/Inflate + A /lang/perl/tiarra/module/System/Inflate/Gzip.pm + A /lang/perl/tiarra/module/System/Inflate/Zlib.pm + A /lang/perl/tiarra/module/System/Inflate.pm + A /lang/perl/tiarra/module/System/Macro.pm + A /lang/perl/tiarra/module/System/NotifyIcon + A /lang/perl/tiarra/module/System/NotifyIcon/Win32.pm + A /lang/perl/tiarra/module/System/Pong.pm + A /lang/perl/tiarra/module/System/PrivTranslator.pm + A /lang/perl/tiarra/module/System/Raw.pm + A /lang/perl/tiarra/module/System/Reload.pm + A /lang/perl/tiarra/module/System/RemoteControl.pm + A /lang/perl/tiarra/module/System/SendMessage.pm + A /lang/perl/tiarra/module/System/Shutdown.pm + A /lang/perl/tiarra/module/Tools + A /lang/perl/tiarra/module/Tools/DateConvert.pm + A /lang/perl/tiarra/module/Tools/FileCache + A /lang/perl/tiarra/module/Tools/FileCache/EachFile.pm + A /lang/perl/tiarra/module/Tools/FileCache.pm + A /lang/perl/tiarra/module/Tools/GroupDB.pm + A /lang/perl/tiarra/module/Tools/HTTPClient.pm + A /lang/perl/tiarra/module/Tools/Hash.pm + A /lang/perl/tiarra/module/Tools/HashDB.pm + A /lang/perl/tiarra/module/Tools/HashTools.pm + A /lang/perl/tiarra/module/Tools/LinedDB.pm + A /lang/perl/tiarra/module/Tools/MailSend + A /lang/perl/tiarra/module/Tools/MailSend/EachServer.pm + A /lang/perl/tiarra/module/Tools/MailSend.pm + A /lang/perl/tiarra/module/User + A /lang/perl/tiarra/module/User/Away + A /lang/perl/tiarra/module/User/Away/Client.pm + A /lang/perl/tiarra/module/User/Away/Nick.pm + A /lang/perl/tiarra/module/User/Filter.pm + A /lang/perl/tiarra/module/User/Ignore.pm + A /lang/perl/tiarra/module/User/Kick.pm + A /lang/perl/tiarra/module/User/Nick + A /lang/perl/tiarra/module/User/Nick/Detached.pm + A /lang/perl/tiarra/module/User/ServerOper.pm + A /lang/perl/tiarra/module/User/Vanish.pm + A /lang/perl/tiarra/run + A /lang/perl/tiarra/run-main + A /lang/perl/tiarra/run-subr + A /lang/perl/tiarra/runtiarra.perl + A /lang/perl/tiarra/sample.conf + A /lang/perl/tiarra/status + A /lang/perl/tiarra/status/merged-tag + A /lang/perl/tiarra/test + A /lang/perl/tiarra/test/dateconvert-test.perl + A /lang/perl/tiarra/test/inflate-test.perl + A /lang/perl/tiarra/tiarra + A /lang/perl/tiarra/tiarra-conf.el + A /lang/perl/tiarra/tiarra-conf.l + A /lang/perl/tiarra/tools + A /lang/perl/tiarra/tools/archive.perl + A /lang/perl/tiarra/tools/ezpack.config + A /lang/perl/tiarra/tools/merge.sh + A /lang/perl/tiarra/tools/update.sh + A /lang/perl/tiarra/tools/upload.sh + +lang/perl/tiarra: import. +------------------------------------------------------------------------ diff -urN /non-existant-dir/HACKING tiarra-20080510/HACKING --- /non-existant-dir/HACKING 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/HACKING 2008-05-11 00:25:24.000000000 +0900 @@ -0,0 +1,186 @@ +モジュールについて + +* モジュールの新規作成 +module/Skelton.pm にモジュールのスケルトンがありますので、 +これをコピーして不要な関数を削除すれば、作ることが出来ます。 + +* 注意すべき事項 + - Tiarra はシングルスレッドです。時間がかかる処理をそのままやってはいけません。 + Timer や Hook, ソケット入出力なら ExternalSocket を使って少しずつ処理してください。 + - conf の変更が起きると、モジュールはインスタンスごと再初期化されます。 + 設定変更後にも必要なデータは、適切なオブジェクトの remark か、 BulletinBoard に + 書いてください。 + +* 良く使うモジュール/関数 + - Tiarra::SharedMixin(main/Tiarra/SharedMixin.pm) + インポートするだけで ->shared を簡単に実現する mixin です。 + ->_new(...) がインスタンス初期化に呼ばれ、 ->_initialize(...) が + (->shared を利用する文を含む)初期化用に呼ばれます。 ->_initialize は定義しなくても OK です。 + + $class_or_this->_this $class_or_this がただのパッケージ名だったとしても、 + ->shared を呼び出してインスタンス化します。 + クラスメソッド (package->func(...)) を簡単に実装したいときに + 使えます。 + - Tiarra::Utils(main/Tiarra/Utils.pm) + このモジュールの関数はすべて package->func(...) または package->shared->func(...) で呼んで + ください。 + + define_function($code, $funcname, ...) + 呼び出し元パッケージに $code で指定された関数を $funcname という + 名前で追加します。 + + define_attr_accessor($class_method, $name, ...) + 呼び出し元パッケージに $name で指定された属性アクセサ(値の取得設定 + ともに可能なもの)を定義します。 + $class_method には、この関数を package->name(...) でアクセスできる + ようにするかを指定します。 + $name には無名配列を指定することもでき、その場合は[関数名, 属性名] + と解釈されます。 + + define_attr_getter($class_method, $name, ...) + 呼び出し元パッケージに $name で指定された属性取得関数を定義します。 + 引数の意味は define_attr_accessor と同じです。 + + define_attr_setter($class_method, $name, ...) + 呼び出し元パッケージに $name で指定された属性設定関数を定義します。 + 引数の意味は define_attr_accessor と同じです。 + + get_package($level) 呼び出し元のパッケージ名を取得します。 + $level が省略された場合は 0 で、この値は呼び出し元の呼び出し元(通常 + 欲しいと思われる値)を返します。 + + cond_yesno($str, $default) + $str を yes か no か評価します。他には true と false を受け付け + ます。 $str が未定義だった場合は $default (または 0)を返します。 + + to_str($value, ...) 任意の値を文字化します。特に undef/ininitialized なエラーを無視して + 文字化します。 + + get_first_defined($value, ...) + 引数の中で一番最初に定義されていたものを返します。 + (with defined_or: $a // $b // $c // ...) + - Tiarra::ShorthandConfMixin(main/Tiarra/ShorthandConfMixin.pm) + _runloop を定義した状態でインポートすると、 _conf, _conf_general, _conf_networks, + _conf_messages を定義します。 + - Mask(main/Mask.pm) + 汎用に使えるマスクマッチング関数群が実装してあります。 + 良く使う形は + Mask::match_deep_chan([$this->config->mask('all')], $msg->prefix, $channel_name_with_network) + Mask::match_deep([$this->config->keyword('all')], $keyword) + だと思います。 + + - ModuleManager(main/ModuleManager.pm) + ここで紹介する関数は、全て ModuleManager->shared_manager->function(...) と呼んで下さい。 + + add_to_blacklist($modname) + $modname で指定されたモジュールをブラックリストに入れる。 + ブラックリストに入れられたモジュールは、リロードするか削除される + まで呼び出されない。成功したら正を返す。 + + remove_from_blacklist($modname) + $modname で指定されたモジュールをブラックリストから削除する。 + 成功したら正を返す。 + + check_blacklist($modname) $modname で指定されたモジュールがブラックリストに入っていれば + 正を返す。 + + + - Multicast(main/Multicast.pm) + + detach($str) 文字列 $str からネットワーク名を外す。 + 戻り値: (セパレータ前の文字列,ネットワーク名,ネットワーク名が明示されたかどうか) + ただしスカラーコンテクストではセパレータ前の文字列のみを返す。 + + attach($str, $network_name) + $str にネットワーク名を付ける。 + $strはChannelInfoのオブジェクトでも良い。 + $network_nameは省略可能。IrcIO::Serverのオブジェクトでも良い。 + + attach_for_client($str, $network_name) + クライアント向けに、 multi-server-mode でなければ attach しない。 + + nick_p($str) 文字列 $str が nick name として許される形式なら 1 を返す。 + ネットワーク名は付けたままでも構わない。処理前に detach される。 + + channel_p($str) 文字列 $str が channel name として許される形式なら 1 を返す。 + ネットワーク名は付けたままでも構わない。処理前に detach される。 + + - RunLoop(main/RunLoop.pm) + ここで紹介する関数は、全て RunLoop->shared_loop->function(...) と呼んで下さい。 + + channel($str) チャンネルを探す。 + ネットワーク名付きのチャンネル名が引数です。 + 無ければ undef を返します。 + + broadcast_to_clients(@messages) + メッセージを全てのクライアントに送信する。 + + notify_msg($str) 全てのクライアントと、 STDOUT にメッセージを通知します。 + + notify_error($str) notify_msg を使ってエラーを通知します。 + + notify_warn($str) notify_msg を使って警告を通知します。 + + terminate($message) サーバとクライアントを切断して終了します。 + + - main(tiarra) + + ::printmsg() STDOUT にのみメッセージを通知します。 + + ::debug_printmsg() デバッグモードの時のみメッセージを通知します。 + + ::debug_mode() デバッグモードなら 1 を返します。 + + ::ipv6_enabled() IPv6 が有効なら 1 を返します。 + + - BulletinBoard(main/BulletinBoard.pm) + ここで紹介する関数は、全て BulletinBoard->shared->function(...) と呼んで下さい。 + + set($key, $value) 掲示板に $key という名前で値 $value をセットします。 + $key を __PACKAGE__."/key" という名前にすれば + 被りにくいと思います。 + + get($key) $key でセットした値を得ます。 + + keys BulletinBoard が保持しているテーブルを返します。 + この内容を変更すると、当然 BulletinBoard の内容も変わります。 + + - Auto::Utils(module/Auto/Utils.pm) + + generate_reply_closures(...) + 一般的な自動反応をするのに有用なクロージャを生成する。 + + sendto_channel_closure(...) + チャンネル等に PRIVMSG / NOTICE を送るクロージャを生成する。 + 一般的な使い方は Skelton.pm に書いておきました。 + +* remark のあるオブジェクト + remark とは、オブジェクトに関連づけられた、自由に使える key/value pair です。 + remark 機能の存在するオブジェクトと、(あるなら)広く使われている既定の remark を挙げます。 + - IrcIO::Client + - IrcIO::Server + 再接続時には remark はクリアされません。 + + 情報取得系 + * server_hops 自分のつながっている server と、あるサーバの hop 数の対応を + (情報が得られたときに)記録しています。 + * isupport RPL_ISUPPORT が送ってくる情報を記録しています。 + RPL_ISUPPORT の詳細は http://www.irc.org/tech_docs/005.html 等を + 参照してください。 + 対応していないサーバでは remark は存在しません。 + * uid RPL_YOURID が送ってくる情報を記録しています。 + 対応していないサーバでは remark は存在しません。 + - IRCMessage + + 情報取得系 + * affected-channels NICK や QUIT などの全チャンネルに波及するメッセージのときに + 影響を受けたチャンネルが設定されていることがあります。 + * old-topic TOPIC 時に一つ前のトピックが設定されています。 + + 動作設定系 + * fill-prefix-when-sending-to-client + クライアントに送信するときに prefix (Tiarra が 001(RPL_WELCOME) + で返したもの) を補完します。 + * do-not-send-to-clients このメッセージを(ほかのモジュールで処理する可能性があるために + 残すけれど)クライアントには送信しないようにします。 + * do-not-send-to-servers do-not-send-to-clients と同じような理由で、サーバに送信しない + ようにします。 + * always-use-colon-on-last-param + シリアライズするとき、最終パラメータに常にコロンを使用する + ようにします。 + - ChannelInfo + + 情報取得系 + * kicked-out そのチャンネルから蹴り出されている(すでにそのチャンネルに + いない)かどうか。 + * switches-are-known チャンネルモードを取得済みかどうか。 + * creation-time RPL_CREATIONTIME が返した値。 + - PersonInChannel + - PersonalInfo + +* Hook + - 基本的な使い方: + use SomePackage::Hook; + my $hook = SomePackage::Hook->new(sub{ + my $hook = shift; + # do something + })->install('someplace'); + - Hook のあるパッケージ、 Hook 名と簡単な説明 + + RunLoop + * before-select select 前 + * after-select select 後 + * set-current-nick set_current_nick が呼ばれたとき + + Configuration + * reloaded conf が再読込されたとき + + IrcIO::Client + * channel-info($client, $ch_name, $network, $ch) + 接続時に Join しているチャンネルごとに呼ばれる。 + チャンネル情報とともに recent log を送ったりする場合に使える。 + +Local variables: +mode: text +End: diff -urN /non-existant-dir/INSTALL tiarra-20080510/INSTALL --- /non-existant-dir/INSTALL 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/INSTALL 2008-05-11 00:25:24.000000000 +0900 @@ -0,0 +1,65 @@ +-*- text -*- +$Id: INSTALL 11365 2008-05-10 14:58:28Z topia $ + +必要なもの +========== +* Perl: + 5.6.0 以上。 + +あるとよいもの +============== +* IO::Socket::INET6 または Socket6: + インストールすると IPv6 のサポートが追加されます。 +* Unicode::Japanese: + 特に XS モジュールをインストールすると性能が改善されます。 +* ithreads: + 5.8.0 以上で ithreads を有効にした場合に、 DNS 解決時の性能低下がなくなります。 +* Win32::GUI: + System::NotifyIcon:Win32 を使う場合に必須です。 + +手順 +==== +1. 必要なものをインストールしたら、 sample.conf をファイル名を変えてコピーします。 + $ cp sample.conf foo.conf + +2. コピーした conf ファイルを編集します。 + $ vi foo.conf + 最低でも main, network, そして network/name で指定したネットワークのブロック + (指定してないブロックは無視されるので書き換えていなくても大丈夫です) + を書き換えてください。 + 自動 Join 設定は Channel::Join::Connect に、ログ取り設定は Log::Channel にあります。 + 使うときはブロックの先頭の - を + に変えるのを忘れずに。 + +3. 起動します。 + $ ./tiarra --config=foo.conf --quiet + (これで起動しないときは perl ./tiarra ... で試す) + +TIPS +==== +* ログファイルなどのパスは起動時のディレクトリからの相対になります。 + (絶対指定も可能です) + たとえば: + | tiarra/test/tiarra.conf + | tiarra/tiarra + | tiarra/main/... + | tiarra/... + なディレクトリ構成の時に + $ cd tiarra/test + $ ../tiarra --config=tiarra.conf + とすれば、 + | tiarra/test/log/others/... + | tiarra/test/log/priv/... + といった感じになります。 + +* --config を省略した場合は、標準入力か tiarra.conf を読みます。 + +* シンボリックリンクを張った場合でも問題なく運用できます。 + たとえば: + | /home/foo/tiarra/test/tiarra -> /usr/share/tiarra/tiarra + | /usr/share/tiarra/main/... + | /usr/share/tiarra/... + という構成( -> はシンボリックリンク)でも問題ありません。 + その場合、 + | /home/foo/tiarra/test/module/Auto/Reply.pm + などを置いた場合は /usr/share/tiarra/module/Auto/Reply.pm より + 優先されます。 diff -urN /non-existant-dir/LICENSE tiarra-20080510/LICENSE --- /non-existant-dir/LICENSE 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/LICENSE 2008-05-11 00:25:24.000000000 +0900 @@ -0,0 +1,2 @@ +This is free software; you can redistribute it and/or modify it + under the same terms as Perl itself. diff -urN /non-existant-dir/NEWS tiarra-20080510/NEWS --- /non-existant-dir/NEWS 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/NEWS 2008-05-11 00:25:24.000000000 +0900 @@ -0,0 +1,292 @@ +2004-08-22 Topia + + * Client::Rehash + - 追加。クライアントの nick と names を訂正する。 + + * System::Error + - 追加。クライアントに送信するときに ERROR メッセージを + NOTICE に埋め込む。 + - このモジュールはデフォルトオンです。アップデートの際は忘れずに + 追加するようにしてください。 + + * Log::Channel + - Log::Writer フレームワークを使うようにしました。 + - file system full 等で書き込みに失敗しても、出来る限りログを + 保持します。 + +2004-07-29 Topia + + * System::NotifyIcon::Win32 + - 追加。タスクバーの通知領域にアイコンを表示し、コンソールの + 表示・非表示、 conf リロード、終了などができます。 + +2004-07-09 Topia + + * System::Reload + - conf-reloaded-notify を追加。(デフォルトで有効) + conf ファイルが再読込された場合に通知します。 + +2004-06-19 Topia + + * Client::Cotton + - 追加。いくつかの Cotton の不具合を回避する(予定)。 + 今は network rejoin 時の自動 part を無視します。 + Client::GetVersion と組み合わせると良いと思います。 + + * Client::GetVersion + - 追加。クライアントの接続時に CTCP Version を発行して + クライアントのバージョンを取得します。 + +2004-06-04 Topia + + * 全般 + - 今回の変更は RPL_ISUPPORT のクライアントへの送信が必要なければ、 + 再起動する必要はありません。 + 再起動せずにリロードしてもエラーが起こることはないと思います。 + - 書き忘れていましたが Unicode::Japanese 0.21 (の PurePerl) にて + SI/SO な jis への対応が行われています。(2004-05-26 の update) + +2004-03-07 Topia + + * 全般 + - taint check モードで動作するようになりました(多分)。 + +2004-02-23 Topia + + * Debug::RawLog + - 追加。生の IRC メッセージ(のようなもの?)を ::printmsg を使って + 表示する。 + + * sample.conf + - 順序が変わっています。注意してください。 + - general/omit-sysmsg-prefix-when-possible 削除。 + - general/sysmsg-prefix-use-masks ブロック追加。 + + * Log::Recent + - no-client-logs クライアントオプションが追加されました。 + クライアントオプションの使い方は、 + realname 部分に $no-client-logs=1$ を指定します。 + 複数ある場合は $no-client-logs=1;a=1;...$ のように指定できます。 + + * 全般 + - クライアントとの接続時にチャンネルの送出順を指定する patch を + 暫定的に取り込みました。 networks に fixed-channels ブロックを + 作り、中に channel をキー名としてマスクを列挙します。 + 例: + fixed-channels { + channel: #てすとちゃんねる@ircnet + channel: #てすと@localserver + channel: *@localserver + channel: *@localserver:*.jp + } + マッチしなかったチャンネルについては最後にまとめて + (順番がごちゃごちゃになって)送られてきます。 + conf の設定場所は暫定です。変わる可能性があるので注意してください。 + - doc/ 以下に HTML でのドキュメントが生成されていますが、 + まだ未調整な部分も多くあるので、正確な記述は sample.conf を参照してください。 + +2004-02-21 phonohawk + + * Channel::Freeze + freezeコマンドの引数は、これまでは完全なチャンネル名であったが、 + これはマスクに変更。その時にJOINしている全てのチャンネルの中から + マスクに一致した全てのチャンネルを凍結する。 + + * 設定 general/omit-sysmsg-prefix-when-possible 追加。 + これが1である時、sysmsg-prefixはチャンネルに対してのメッセージ + でなければ省略する。デフォルトは1。 + +2004-02-15 Topia + + * Client::Cache + - 昨日の分だけでは Excess Flood/Max SendQ Exceeded 対策として + 不十分だったので、アップデートを推奨します。 + - 2つ以上のクライアントが同時に同じ動作をする場合に、 + 今回の変更で効果が出ます。 + 長すぎず短すぎずの絶妙な差で同じ動作をされた場合には + 効きませんが、滅多にそんなことはない(と思いたい)です。 + +2004-02-14 Topia + + * Log::Recent, System::Raw, Channel::Freeze, Channel::Rejoin + - これらのモジュールのうち一つでも組み込んでいる場合は、 + リロードする前に Tiarra を再起動させてください。 + 新たに入った機能を使っています。 + + * Client::Cache + - 新規追加。クライアントからの問い合わせのうち、 + Tiarra が情報を持っていて、 + サーバに問い合わせる必要がないものをキャッシュとして返します。 + - いまのところ MODE キャッシュと、 WHO キャッシュを実装していて、 + どちらも、クライアントからの最初の問い合わせのときにのみ + キャッシュを使います。 + - LimeChat(1.18 で WHO 機能を切れるようになりましたが) や、 + X-Chat などのクライアントを使用されている場合は、 + 組み込むと便利です。 + + * Client::Eval + - 追加。クライアントからのコマンドしか受け付けませんが、 + その代わりすべてのコマンドを実行できます。 + 事実上 IRC パスワードがわかれば Tiarra が動いているホスト上で + 動作しているアカウントの権限で何でもできる、 + ということに注意してください。 + - 意味がわからなければ組み込まないことを推奨します。 + 必要な時だけ組み込んで、すぐはずす、というのも良いかもしれません。 + +2004-01-27 phonohawk + + * 行の終わりにCRLFでなくLFを付けるようなクライアントでも + 正しく動作するようになりました。 + +2004-01-23 phonohawk + + * tiarra: 起動時オプション --make-password 追加。 + make-passwordの機能をtiarra本体に移した。 + + * make-password: 削除 + +2003-11-17 Topia + + * Log::Channel + mode のデフォルトが 644 から 600 に変更されました。 + mode をコメントアウトしている場合は注意してください。 + dir-mode が追加され、デフォルトが 700 です。 + これも、必要に応じて 755 を指定するようにしてください。 + +2003-11-09 Topia + + * System::Reload + 自分自身がリロードできないバグの修正。 + kill -HUP pid は出来るので、これを使ってリロードしてください。 + + * single-server-mode の bugfix です。 + single-server-mode を使う予定が無い場合は再起動は不要です。 + single-server-mode を使っている方は、アップデートして再起動して下さい。 + +2003-11-08 Topia + + * single-server-mode の bugfix です。 + single-server-mode を使う予定が無い場合は再起動は不要です。 + single-server-mode を使っている方は、アップデートして再起動して下さい。 + +2003-10-16 phonohawk + + * System::Raw + 追加。Tiarraに改変されない生のメッセージをサーバーに送るためのモジュール。 + +2003-10-14 Topia + + * single-server-mode の bugfix です。 + single-server-mode を使う予定が無い場合は再起動は不要です。 + +2003-09-28 phonohawk + + * tiarra-conf.el: + mmm-modeがインストールされていて、(require 'mmm-mode)または + (require 'mmm-auto)されている場合に、tiarra-conf用の設定を + 行った後、それを有効にする。 + + mmm-modeのサイトは次のURLに。 + http://mmm-mode.sourceforge.net/ + +2003-09-25 Topia + + * このバージョン以前の Tiarra には、 + モジュールのアンロードをすると原因不明のエラーが起こるバグがあります。 + また、アップグレードの際には再起動が必要です。 + +2003-08-12 phonohawk + + * シングルサーバーモードを実装。 + networks/multi-server-modeを0に設定すると、シングルサーバーモードになります。 + この状態では同時に接続出来るサーバーの数が一つに制限され、クライアントから見た + チャンネル名にネットワーク名が付かなくなります。 + +2003-07-31 Topia + + * mask のチャンネル名にネットワーク名を必要とするように修正した。 + 影響を受けるモジュールは + - Auto::Oper + - Auto::Random + - Auto::Reply + - Auto::MesMail + - Auto::Alias + - Auto::Response + です。変更よろしくお願いします。(^^;; + +2003-07-10 phonohawk + + * Channel::Freeze + 追加。特定のチャンネルのNOTICEやPRIVMSGの中継を + 一時的に中断するためのモジュール。 + 発言を見たくないがPARTはしたくない、といった場合に有効。 + +003-07-03 phonohawk + + * Auto::Oper + 複数の応答が定義されていれば、ランダムに一つ選んで発言する。省略も可能。 + +2003-06-06 phonohawk + + * general/nickを、それぞれのネットワーク設定ブロックのnickでオーバーライド可能に。 + +2003-05-27 phonohawk + + * Tiarra本体の誤動作によりCPU時間を食い潰している可能性を検出して警告する。 + +2003-05-24 phonohawk + + * IPv6対応 + general/tiarra-ip-versionに'v6'を指定する事で、IPv6でのリスニングを行なう。 + また、サーバーには最初にIPv6での接続を試みてからIPv4にフォールバックする。 + 詳細はsample.confに。 + +2003-05-23 Topia + + * Auto/Reply.pm: 追加。 + plum の auto/reply.plm に相当する。 + + * Auto/Alias.pm: キーを指定しての値削除、削除した個数の表示が可能になったため、 + サンプルの removed-format が変更されています。好みに合わせて変更してください。 + +2003-05-21 phonohawk + + * tiarra-conf.l: 追加。 + Noboruhiさんによるxyzzy用tiarra.conf編集モード。 + インストール方法はtiarra-conf.l内に記述されています。 + +2003-04-29 phonohawk + + * Channel/Join/Kicked.pm: 追加。チャンネルから蹴られた時に、自動JOINするモジュール。 + +2003-04-13 phonohawk + + * User/Vanish.pm: 追加 + 特定のチャンネルでの特定の人物の存在をクライアントに隠すモジュール。 + JOINやPART、QUIT等を消去する。 + +2003-04-05 phonohawk + + * モジュール Auto::Joined 追加。 + 特定のチャンネルに誰かがJOINする度に特定の発言を行なうモジュール。 + チャンネル移転通知以外に使うのはやめた方が良い。 + +2003-03-28 Topia + + * sample.conf (Auto/Random.pm): 設定に mask プロパティが抜けていました。 + Auto/Random.pm を使っていた方は、 sample.conf にしたがって適当なところに追加してください。 + +2003-03-23 phonohawk + + * User/Filter.pm: 新規追加。 特定の人物の発言にフィルタをかける。 + + * general/bind-addrでサーバーへの接続時のローカル側アドレスを指定可能になりました。 + +2003-03-23 Topia + + * Channel/Join/Invite.pm: 新規追加。 Invite されたチャンネルに Join する。 + +2003-03-19 Topia + + * Auto/Random.pm: 設定ファイルの形式がかなり変わっています。 + sample.conf を参照して書き換えをお願いします。 diff -urN /non-existant-dir/all.conf tiarra-20080510/all.conf --- /non-existant-dir/all.conf 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/all.conf 2008-05-11 00:25:27.000000000 +0900 @@ -0,0 +1,1781 @@ +# -*- tiarra-conf -*- +# ----------------------------------------------------------------------------- +# $Id: all.conf.in 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +# tiarra.conf サンプル +# このファイルにはすべてのブロックの解説があります。 +# 必要なブロックがあればここからコピーしていってください。 +# ----------------------------------------------------------------------------- + +# ----------------------------------------------------------------------------- +# generalブロック +# +# tiarra.conf自身の文字コードやユーザー情報などを指定するブロックです。 +# ----------------------------------------------------------------------------- +general { + # tiarra.conf自身の文字コード + # コード名はjis,sjis,euc,utf8,utf16,utf32等。(この値はUnicode::Japaneseにそのまま渡されます) + # autoが指定された、または省略された場合は自動判別します。 + conf-encoding: utf8 + + # ユーザー情報 + # 省略不能です。 + nick: tiarra + user: tiarra + name: Tiarra the "Aeon" + + # どのようなユーザーモードでログインするか。+iwや+iのように指定する。 + # 省略された場合はユーザーモードを特に設定しない。 + #user-mode: +i + + # Tiarraへの接続を許可するホスト名を表わすマスク。 + # 制限をしないのであれば"*"を指定するか省略する。 + client-allowed: * + + # Tiarraが開くポート。ここに指定したポートへクライアントに接続させる。 + # 省略されたらポートを開かない。 + tiarra-port: 6667 + + # Tiarraがポートtiarra-portを開く際、IPv6とIPv4のどちらでリスニングを行なうか。 + # 'v4'または'v6'で指定します。デフォルトは'v4'です。 + # IPv6を使うためにはSocket6.pmが利用可能である必要があります。 + #tiarra-ip-version: v4 + + # Tiarraがポートtiarra-portを開く際のローカルアドレス。 + # 意味が分からなければ省略して下さい。 + # デフォルトは、IPv4のはINADDR_ANY、IPv6のはin6addr_anyになります。 + #tiarra-ipv4-bind-addr: 0.0.0.0 + #tiarra-ipv6-bind-addr: ::0 + + # Tiarraにクライアントが接続する際に要求するパスワードをcryptした文字列。 + # 空の文字列が指定されたり省略された場合はパスワードを要求しない。 + # crypt は ./tiarra --make-password で行えます。 + tiarra-password: xl7cflIcH9AwE + + # 外部プログラムからtiarraをコントロールする為のUNIXドメインソケットの名前。 + # 例えば"foo"を指定した場合、ソケット/tmp/tiarra-control/fooが作られる。 + # 省略された場合はこの機能を無効とする。 + # また、非UNIX環境ではそもそもUNIXドメインソケットが利用可能でないため、 + # そのような場合にもこの機能は無効となる。 + #control-socket-name: test + + # IRCサーバーから送られる文字のコードと、IRCサーバーへ送る文字のコード + # どちらも省略された場合はjis。 + server-in-encoding: jis + server-out-encoding: jis + + # クライアントから受け取る文字のコードと、クライアントへ伝える文字のコード + # どちらも省略された場合はjis。 + client-in-encoding: jis + client-out-encoding: jis + + # Tiarraは標準出力に様々なメッセージを出力するが、その文字コードを指定する。省略時にはeucとなる。 + # ただしtiarra.confのパースが完了するまでは文字コードの変換は行なわれない(つまりこの設定が有効にならない)ことに注意して下さい。 + stdout-encoding: utf8 + + # Tiarraはエラーメッセージを標準出力に出力するが、その時に接続しているクライアントがあればクライアントにもNOTICEで送る事が出来る。 + # この値を1にすると、その機能が有効になる。省略するか0を指定するとこの機能は無効になる。 + notice-error-messages: 1 + + # Tiarraでチャンネルとユーザーのマスクを指定するときの形式。 + # plum形式とTiarra形式が選択できます。 + #----------------- + # plum形式: (channelには+や-は使えない。channelは省略すると*とみなす。) + # + syntax: user[ channel[ channel[ ...]]] + # + # mask: +*!*@*.example.com #{example}@ircnet +{example3}@ircnet + # mask: -*!*@*.example.com #{example2}@2ch,+{example4}@2ch + # mask: -*!*@* + #----------------- + # Tiarra形式: (channelにも+や-を使える。) + # + syntax: channel user + # + # mask: #{example}@ircnet,-#{example2}@2ch +*!*@*.example.com + # mask: ++{example3}@ircnet,-+{example4}@2ch +*!*@*.example.com # +で始まるチャンネル。 + # mask: * -*!*@* + #----------------- + # となります。 この二つはまったく同じマスクを表しています。 + + # この値をplumにすると、plum形式、省略するかtiarraを指定すると、Tiarra形式になります。 + chanmask-mode: tiarra + + # サーバーに接続する際、ローカル側のどのアドレスにバインドするか。 + # 意味が分からなければ省略して下さい。 + # デフォルトは、IPv4のはINADDR_ANY、IPv6のはin6addr_anyになります。 + #ipv4-bind-addr: 0.0.0.0 + #ipv6-bind-addr: ::0 + + # tiarra が、 001 や 002 や、 recent log を送信するときなどに使う prefix + # を指定します。 hostname や fqdn っぽいものを指定すると良いかもしれません。 + # デフォルトは tiarra です。普通変える必要はありません。 + #sysmsg-prefix: tiarra + + sysmsg-prefix-use-masks { + # sysmsg-prefix を使用する場所を指定する。 + + # システムメッセージ(NumericReply など)。デフォルトは * です。 + # ふつうこれを変更する必要はありません。 + system: * + + # 個人宛メッセージ(Notice,Privmsg の中で)。デフォルトはなし。 + #priv: + + # チャンネル宛メッセージ(Notice,Privmsg の中で)。デフォルトは * です。 + # Ziciz などのクライアントを接続する場合は、 + # -*::log を指定しておくといいかもしれません。 + channel: * + } + + # Tiarra が nick 変更時の衝突等を処理するモードを指定します。 + # 0: Tiarra が接続時と同様に自動処理します。 + # 1: クライアントにそのまま投げます。 + # 複数のクライアントが nick 重複を処理する場合は非常に危険です。 + # (設定不足の IRC クライアントが複数つながっている場合も含みます) + # 2: 対応するエラーメッセージ付きの NOTICE に変換して、 + # クライアントに投げます。 + # multi-server-mode 時のデフォルトは 0 、 single-server-mode 時のデフォルトは 1 です。 + #nick-fix-mode: 0 + + messages { + # Tiarra が使用する、いくつかのメッセージを指定する。 + + quit { + # ネットワーク設定が変更され、再接続する場合の切断メッセージ + netconf-changed-reconnect: Server Configuration changed; reconnect + + # ネットワーク設定が変更され、切断する場合の切断メッセージ + netconf-changed-disconnect: Server Configuration changed; disconnect + } + } +} + +# ----------------------------------------------------------------------------- +# networksブロック +# +# Tiarraから接続するIRCネットワークの名称です。 +# 一つも定義しなかった場合やこのブロックを省略した場合は、 +# "main"というネットワークが一つだけ指定されたものと見做します。 +# ----------------------------------------------------------------------------- +networks { + # 複数のサーバーへの接続を可能にするかどうか。1(オン)と0(オフ)で指定。 + # これを1にすると、次のnameを複数個定義する事が可能になり、 + # 複数のサーバーに同時に接続出来るようになります。 + # その一方、これを1にしている時は、チャンネル名にネットワーク名が付加される等、 + # IRCの大部分のメッセージがTiarraによる改変を受けます。 + # これを0にしている間は、次のnameを複数個定義する事は出来なくなります。 + # マルチサーバーモードの設定を起動中に変えると、クライアントから見たチャンネル名が + # 変更になる為、全クライアントが一時的に全てのチャンネルからpartしたように見え、 + # その直後にjoinし直したように見えます。 + # デフォルトでは1です。 + multi-server-mode: 1 + + # 接続するIRCネットワークに名前を付けます。この名前は後で使用します。 + # 複数のネットワークに接続したい場合は多重定義して下さい。 + name: ircnet + name: 2ch + + # 通常Tiarraではチャンネル名を「#Tiarra@ircnet」のように表現します。 + # これはネットワークircnet内の#Tiarraというチャンネルを表わします。 + # @以降は省略可能ですが、省略された場合のデフォルトのネットワーク名をここで指定します。 + # 省略した場合は最も始めに定義されたnameがデフォルトになります。 + # (そしてnameが一つも無かった場合はmainがデフォルトになります) + #default: ircnet + + # 上に述べた通り、デフォルトではTiarraはチャンネル名とネットワーク名を@で区切ります。 + # この区切り文字は任意の文字に変更する事が出来ます。省略された場合は@になります。 + # + # System::PrivTranslator モジュールを利用している場合、 prefix の nick 部分にも + # 利用されます。そのため、 ! や @ を含む文字列を利用するとクライアントが誤作動する + # 場合がありますので注意してください。 + channel-network-separator: @ + + # 接続先のサーバーから切断された時に、joinしていたそのサーバーのチャンネルをどうするか。 + # 1. "part-and-join"の場合は、切断されるとクライアントにはチャンネルからpartしたように見せ掛け、 + # 再接続に成功すると再びjoinしたように見せ掛ける。最も負荷が高い。(これはplumに似た動作である) + # 2. "one-message"の場合は、切断されるとクライアントに宛ててTiarraがNOTICEでその旨を報告する。 + # 再接続に成功すると再びNOTICEで報告する。JOINやPARTはしないので、 + # クライアントからはまだそのチャンネルに残っているかのように見える。 + # 3. "message-for-each"の場合は、切断されるとクライアントに宛ててTiarraが + # 到達不能になった全てのチャンネルにNOTICEでその旨を報告する。 + # 再接続に成功すると再びNOTICEで報告する。JOINやPARTはしない。 + # デフォルトはpart-and-joinです。 + action-when-disconnected: message-for-each + + # NICKを変更する度に、変更したサーバーでの新しいNICKをNOTICEで常に通知するかどうか。 + # 1なら必ず通知し、0なら変更後のnickがローカルnick(クライアントが見る事の出来るnick)と違っている場合のみ通知する。 + # デフォルトは0です。 + always-notify-new-nick: 0 + + fixed-channels { + # Tiarra がクライアント接続時にチャンネル情報を送る順番を指定する。 + # マッチしなかったチャンネルについては最後にまとめて + # (順番がごちゃごちゃになって)送られてきます。 + channel: #てすとちゃんねる@ircnet + channel: #てすと@localserver + channel: *@localserver + channel: *@localserver:*.jp + } +} + +# ----------------------------------------------------------------------------- +# 各ネットワークの設定 +# +# networksブロックで定義した全てのネットワークについて、 +# そのアドレス、ポート、(必要なら)パスワードを定義します。 +# ----------------------------------------------------------------------------- +ircnet { + # サーバーのホストとポート。省略不可。 + host: irc.nara.wide.ad.jp + port: 6663 + + # general/userで設定したユーザ名を使わずに、各ネットワークで独自のユーザ名を使用する事も可能。 + # 省略されたら当然、general/userで設定したものが使われる。 + #user: hoge + + # general/nameで設定した本名(建前上)を使わずに、各ネットワークで独自の本名を使用可能。 + #name: hoge + + # このサーバーの要求するパスワード。省略可能。 + #password: hoge + + # general/setver-in/out-encodingで設定したエンコーディングを使わずに、 + # 各ネットワークで独自のエンコーディングを使用する事も可能。 + # 省略されたら当然、generalで設定したものが使われる。 + #in-encoding: jis + #out-encoding: jis + + # general/(ipv4|ipv6)bind-addrで設定したローカルアドレスを使わずに、 + # 各ネットワークで独自のbind_addrを使用する事も可能。 + # 省略されたらgeneralで設定したものが使われる。 + #ipv4-bind-addr: 0.0.0.0 + #ipv6-bind-addr: ::0 +} + +2ch { + host: irc.2ch.net + port: 6667 +} + +# ----------------------------------------------------------------------------- +# 必須の設定は以上です。以下はモジュール(プラグイン)の設定です。 +# ----------------------------------------------------------------------------- + +# +または-で始まる行はモジュール設定行と見做されます。 +# +で記述されたモジュールが使用され、-で記述されたモジュールは使用されません。 +# +や-の後の空白は幾つあっても無視されます。 + +# メッセージが各モジュールを通過する順番は、このconfファイルで記述された +# 順番の通りになります。ログを取るモジュールなどはconfでも後の方に +# 記述した方が良いということになります。 + +# モジュール名はperlのそれと同じようにディレクトリ区切り文字を「::」としたパスで表現されます。 +# 例えばモジュールChannel::Auto::Operの実体はファイルmodule/Channel/Auto/Oper.pm +# でなければならず、そのpackage宣言もChannel::Auto::Operでなければなりません。 +# Tiarraモジュールの名称は、perl標準モジュール群やmain/下の.pmファイルと重複しないように +# 気を付けて下さい。Tiarraはモジュールが本当にModuleのサブクラスかどうかをチェックするので +# 例えばIO::Socket::INETといったモジュールを置いても誤動作はしませんが、 +# そのようなモジュールはロード時にエラーを出して使用中止になります。 + +# 一つのモジュールを複数回定義して、何度も同じモジュールをメッセージが通過するようには出来ません。 + +# 幾つかのモジュールはパラメータとしてチャンネル名を必要とします。 +# ここで指定するチャンネル名は、ネットワーク名も含めた文字列でなければなりません。 +# 「#チャンネル」では駄目で「#チャンネル@ネットワーク」などとする必要があります。 + +# マスクの書式: +# ['+' / '-'] ( <マスク文字列> / "re:" 正規表現 ) +# これはカンマで幾つでも継ぐ事が出来ます。"\,"でカンマそのものを表します。 +# 先頭が+なら、それに続く部分にマッチするものが選ばれ、-なら除外されます。省略されたら+と見做されます。 +# マスク文字列とは"*"で0文字以上の任意の文字列を、"?"で1文字の任意の文字列を表す文字列です。 +# 例: +# tiarra* これはtiarraで始まる文字列を表す。 +# +*!*tiarra@*.jp,-re:\d これは*!*tiarra@*.jpにマッチして、かつ文字列中に数字を含まないものを表す。 + + +- Auto::Alias { + # ユーザエイリアス情報の管理を行ないます。 + + # エイリアスは基本的にname,userの二つのフィールドから成っており、 + # それぞれユーザー名、ユーザーマスクを表します。 + + # エイリアス定義ファイルのパスと、そのエンコーディング。 + # このファイルは次のようなフォーマットである。 + # 1. それぞれの行は「<キー>: <値>」の形式である。 + # 2. 空の行で、各ユーザーを区切る。 + # 3. <値>はカンマで区切られて複数の値とされる。 + # + # エイリアス定義ファイルの例: + # + # name: sample + # user: *!*sample@*.sample.net + # + # name: sample2,[sample2] + # user: *!sample2@*.sample.net,*!sample2@*.sample2.net + # + alias: alias.txt + alias-encoding: euc + + # この発言をした人のエイリアスが登録されていれば、それをprivで送る。 + confirm: エイリアス確認 + + # 「 user *!*user@*.user.net」のようにして情報を追加。 + # 発言をした人のエイリアスが未登録だった場合は、userのみ受け付けて新規追加とする。 + add: エイリアス追加 + + # 「 name ユーザー」のようにして情報を削除。 + # userを全て削除されたエイリアスは他の情報(name等)も含めて消滅する。 + remove: エイリアス削除 + + # メッセージが追加されたときの反応を指定します。 + # ランダムなメッセージを発言する際のフォーマットを指定します。 + # エイリアス置換が有効です。#(nick.now)、#(channel)は + # それぞれ相手のnick、チャンネル名に置換されます。 + # #(key)、#(value)は、追加されたキーと値に置換されます。 + added-format: #(name|nick.now): エイリアス #(key) に #(value) を追加しました。 + add-failed-format: #(name|nick.now): エイリアス #(key) の追加に失敗しました。 + + # メッセージが削除されたときの反応を指定します。 + # added-formatで指定できるものと同じです。 + removed-format: #(name|nick.now): エイリアス #(key) から #(value) を削除しました。 + remove-failed-format: #(name|nick.now): エイリアス #(key) からの削除に失敗しました。 + + # エイリアスの追加や削除が許されている人。省略された場合は「*!*@*」と見做される。 + modifier: *!*@* +} + +- Auto::Answer { + # 特定の発言に反応して対応する発言をする。 + + # Auto::Aliasを有効にしていれば、エイリアス置換を行ないます。 + + # 反応する発言と、それに対する返事を定義します。 + # エイリアス置換が有効です。#(nick.now)と$(channel)はそれぞれ + # 相手の現在のnickとチャンネル名に置換されます。 + # + # コマンド: reply + # 書式: <反応する発言のマスク> <それに対する返事> + # 例: + #reply: こんにちは* こんにちは、#(name|nick.now)さん。 + # この例では誰かが「こんにちは」で始まる発言をすると、 + # 発言した人のエイリアスを参照して「こんにちは、○○さん。」のように発言します。 + # + # コマンド: channel-reply + # 書式: <反応するチャンネルのマスク> <反応する発言のマスク> <それに対する返事> + # 例: + #channel-reply: #あいさつ@ircnet こんにちは* こんにちは、#(name|nick.now)さん。 + # この例では#あいさつ@ircnetで誰かが「こんにちは」で始まる発言をすると、 + # 発言した人のエイリアスを参照して「こんにちは、○○さん。」のように発言します。 + # + # コマンド: answer-to-myself + # 書式: <真偽値> + # 例: + #answer-to-myself: on + # 自分の発言にも反応するようになります。 + # デフォルトは off です。 +} + +- Auto::Calc { + # Perlの式を計算させるモジュール。 + + # 反応する発言を指定します。 + request: 計算 + + # 使用を許可する人&チャンネルのマスク。 + # 例はTiarraモード時。 [default: なし] + mask: * +*!*@* + # [plum-mode] mask: +*!*@* + + # 結果が未定義だったときに置き換えられる文字列。省略されると undef 。 + #undef: (未定義) + + # 正常に計算できたときのフォーマット + # method: 計算式, result: 結果, error: エラー, signal: シグナル + reply-format: #(method): #(result) + + # エラーが起きたときのフォーマット + # method: 計算式, result: 結果, error: エラー, signal: シグナル + error-format: #(method): エラーです。(#(error)) + + # シグナルが発生したときのフォーマット + #signal-format: #(method): シグナルです。(#(signal)) + + # signal-$SIGNALNAME-format 形式。 + # $SIGNALNAME には現状 alarm/sigfpe があります。 + # 該当がなければ signal-format にフォールバックします。 + + # いくつかの例を挙げます。 + #signal-alarm-format: #(method): 時間切れです。 + #signal-sigfpe-format: #(method): 浮動小数点計算例外です。 + + # タイムアウトする秒数を指定します。 alarm に渡されます。 + # 再帰を止めるのに使えますが、どうもメモリリークしていそうな雰囲気です。 + timeout: 1 + + # サブルーチン定義を許可するかどうかを指定する。 + # 再帰定義が可能なので、許可する場合はこのモジュール専用の + # Tiarra を動かすことをお勧めします。 + permit-sub: 0 + + # 初期化する発言を指定します。 + # このモジュールでは現状変数や関数定義などを行えます。 + # このコマンドが発行されるとそれらをクリアします。 + init: 計算初期化 + + # 初期化を許可する人&チャンネルのマスク。 + # 例はTiarraモード時。 [default: なし] + init-mask: * +*!*@* + # [plum-mode] mask: +*!*@* + + # 再初期化したときの発言を指定します。 + init-format: 初期化しました。 +} + +- Auto::ChannelWithoutOper { + # チャンネルオペレータ権限がなくなってしまったときに発言する。 + + # +で始まらない特定のチャンネルで、+aモードでも+rモードでもないのに + # 誰もチャンネルオペレータ権限を持っていない状態になっている時、 + # そこに誰かがJOINする度に特定のメッセージを発言するモジュールです。 + + # 書式: <チャンネル名> <メッセージ> + #channel: #IRC談話室@ircnet なると消失しました。 +} + +- Auto::FetchTitle { + # 発言に含まれるURLからタイトルを取得. + + # リクエストタイムアウトまでの時間(秒). + timeout: 3 + + # 有効にするチャンネルとオプションとURLの設定. + # 書式: mask: [...] + # + # mask: #test@ircnet &test http://* + # mask: * http://* + mask: * http://* + + # &test と設定すると conf-test ブロックの中身が使われる. + #conf-test { + # auth-test1 { + # url: http://example.com/* + # url: http://example.org/* + # user: test + # #pass: test + # pass: {BASE64}dGVzdAo= + # } + # filter-xx { + # url: http://example.com/*/xx/* + # type: xx + # } + #} + + # お返事の前や後ろにつける字句. + reply-prefix: "(FetchTitle) " + reply-suffix: " [AR]" + + # デバッグフラグ. + #debug: 0 + #debug-mask: #debug-chan your_nick!~you@example.com + #debug-dumpfile: fetchtitle.log + + # NOTE: + # 利用するにはcodereposから + # module/Tools/HTTPClient.pm rev.8220 + # main/Tiarra/Socket/Buffered.pm rev.8219 + # 以降が必要です. +} + +- Auto::Im { + # 名前が呼ばれると、その発言をim.kayac.comに送信する + + # 反応する人のマスクを指定します。 + # 省略すると全員に反応します。 + mask: * *!*@* + + # 反応するキーワードを正規表現で指定します。 + # 複数指定したい時は複数行指定してください。 + #regex-keyword: (?i:fugahoge) + + # 反応するキーワードを指定します。 + # 複数指定したい時は,(コンマ)で区切るか、複数行指定してください。 + keyword: hoge + + # im.kayac.com に送るメッセージのフォーマットを指定します。 + # デフォルト値: [tiarra][#(channel):#(nick.now)] #(text) + format: [tiarra][#(channel):#(nick.now)] #(text) + + # im.kayac.comで登録したユーザ名を入力します。 + # im.kayac.comについては http://im.kayac.com/#docs を参考にしてください。 + user: username + + # im.kayac.comで秘密鍵認証を選択した場合は設定してください。 + # 省略すると認証なしになります。 + #secret: some secret + + # im.kayac.comでパスワード認証を選択した場合は設定してください。 + # 省略すると認証なしになります。 + # secret と両方指定した場合は secret が優先されています。 + #password: some password +} + +- Auto::Joined { + # 特定のチャンネルに誰かがJOINする度に特定のメッセージを発言する。 + + # Auto::Aliasを有効にしていれば、エイリアス置換を行ないます。 + + # 発言を行なうチャンネルと、その内容を定義します。 + # #(nick.now)と$(channel)は、それぞれ相手の現在のnickとチャンネル名に置換されます。 + # + # 書式: <チャンネル名> <発言内容> + #channel: #チャンネル@ircnet 「#ちゃんねる」に移転しました。 +} + +- Auto::MesMail { + # 伝言をメールとして送信する。 + + # メールアドレスはエイリアスの mail を参照します。 + + # Fromアドレス。[default: OSのユーザ名] + from: example1@example.jp + + # 送信用のキーワード [default: mesmail_send] + send: 速達伝言 + + # 使用を許可する人&チャンネルのマスク。 + # 例はTiarraモード時。 [default: なし] + mask: * +*!*@* + # [plum-mode] mask: +*!*@* + + # maskで拒否されたときのメッセージ [default: なし] + deny: 伝言したくない。 + + # 一度に送れる宛先の量 [default: 無制限] + max-send-address: 5 + + # 宛先を探すエイリアスエントリ [default: なし] + alias-key: name + alias-key: nick + + # 宛先の人を判別出来なかったときのメッセージ [default: なし] + unknown: #(who)さんと言うのは誰ですか? + + # メールの日付形式 + date: %H:%M:%S + + # エイリアスは見付かったけれどメールアドレスが登録されていなかったときのメッセージ。 [default: なし] + #none-address: #(who)さんはアドレスを登録していません。 + + # SMTPのホスト [default: localhost] + #smtphost: localhost + + # SMTPのポート [default: smtp(25)] + #smtpport: 25 + + # SMTPで自ホストのFQDN [default: localhost] + #smtpfqdn: localhost + + # SMTPのユーザ。指定されれば SMTP Auth を行う [default: なし] + #smtpuser: example1 + + # SMTPのパスワード [default: 空パスワード('')] + #smtppass: test-password + + # 送信するメールの既定件名(エイリアス使用不可) [default: Message from IRC] + #subject: Message from IRC + + # 送信するメールの本文 [default: #(date) << #(from.name|from.nick|from.nick.now) >> #(message)] + #format: #(date)に#(from.name|from.nick|from.nick.now)さんから#(message)という伝言です。 + + # 送信したときのメッセージ。 [default: なし] + accept: #(who)さんに#(message)と伝言しておきました。 + + # ---- POP before SMTP の指定 ---- + # POP before SMTPを使う。 [default: no] + #use-pop3: yes + + # POP before SMTPのタイムアウト時間(分)。分からない場合は指定しなくて良い。 [default: 0] + #pop3-expire: 4 + + # POPのホスト。 [default: localhost] + #pop3host: localhost + + # POPのポート。 [default: pop(110)] + #pop3port: 110 + + # POPのユーザ [default: OSのユーザ名] + #pop3user: example1 + + # POPのパスワード [default: 空パスワード('')] + #pop3pass: test-password + + # ---- エラーメッセージの設定 ---- + + # 一般エラー。 + # error-[state] と言う形式で詳細エラーメッセージを指定できる。 + # [state]は、 + # * mailfrom(メールの送信者を指定しようとしてエラー) + # * rcptto(メールの送信先を指定しようとしてエラー) + # * norcptto(メールの送信先が全部無くなった) + # * data(メールの中身を送信しようとしてエラー) + # * finish(メールの中身を送信したらエラー) + # がある。特に欲しくなければerror-[state]は指定しなくても構わない。 + # メッセージを出したくないなら中身の無いエントリを指定すれば良い。 + # error-[state]が指定されてない場合は代わりに error を使う。 [default: 未定義] + + #error-rcptto: + #error-norcptto: #(who)さんには送れませんでした。送信できるメールアドレスがありません。 + #error-data: メールが送信できません。DATAコマンドに失敗しました。#(line;サーバ応答:%s|;) + #error: メール送信エラーです。#(line;サーバ応答:%s|;)#(state; on %s|;) + + # 致命的なエラー。メールに個別なエラーではないので送信者(のprefix)毎に1メッセージ送られる。 + # fatalerror-[state] + # [state]: + # * first(接続エラー) + # * helo(SMTPセッションを開始出来ない) + # がある。特に欲しくなければfatalerror-[state]は指定しなくても構わない。 + # メッセージを出したくないなら中身の無いエントリを指定すれば良い。 + # fatalerror-[state]が指定されてない場合は代わりに fatalerror を使う。 [default: 未定義] + + #fatalerror-first: SMTPサーバに接続できません。 + #fatalerror: SMTPセッションで致命的なエラーがありました。#(line; サーバ応答:%s|;)#(state; on %s|;) +} + +- Auto::Oper { + # 特定の文字列を発言した人を+oする。 + + # Auto::Aliasを有効にしていれば、エイリアス置換を行ないます。 + + # +oを要求する文字列(マスク)を指定します。 + request: なると寄越せ + + # チャンネルオペレータ権限を要求した人と要求されたチャンネルが + # ここで指定したマスクに一致しなかった場合は + # denyで指定した文字列を発言し、+oをやめます。 + # 省略された場合は誰にも+oしません。 + # 書式は「チャンネル 発言者」です。 + # マッチングのアルゴリズムは次の通りです。 + # 1. チャンネル名にマッチするmask定義を全て集める + # 2. 集まった定義の発言者マスクを、定義された順にカンマで結合する + # 3. そのようにして生成されたマスクで発言者のマッチングを行ない、結果を+o可能性とする。 + # 例1: + # mask: *@2ch* *!*@* + # mask: #*@ircnet* *!*@*.hoge.jp + # この例ではネットワーク 2ch の全てのチャンネルで誰にでも +o し、 + # ネットワーク ircnet の # で始まる全てのチャンネルでホスト名 *.hoge.jp の人に+oします。 + # #*@ircnetだと「#hoge@ircnet:*.jp」などにマッチしなくなります。 + # 例2: + # mask: #hoge@ircnet -*!*@*,+*!*@*.hoge.jp + # mask: * +*!*@* + # 基本的に全てのチャンネルで誰にでも +o するが、例外的に#hoge@ircnetでは + # ホスト名 *.hoge.jp の人にしか +o しない。 + # この順序を上下逆にすると、全てのチャンネルで全ての人を +o する事になります。 + # 何故なら最初の* +*!*@*が全ての人にマッチするからです。 + mask: * *!*@* + + # +oを要求した人を実際に+oする時、ここで指定した発言をしてから+oします。 + # #(name|nick)のようなエイリアス置換を行います。 + # エイリアス以外でも、#(nick.now)を相手のnickに、#(channel)を + # そのチャンネル名にそれぞれ置換します。 + message: 了解 + + # +oを要求されたが+oすべき相手ではなかった場合の発言。 + # 省略されたら何も喋りません。 + deny: 断わる + + # +oを要求されたが相手は既にチャンネルオペレータ権限を持っていた場合の発言。 + # 省略されたらdenyに設定されたものを使います。 + oper: 既に@を持っている + + # +oを要求されたが自分はチャンネルオペレータ権限を持っていなかった場合の発言。 + # 省略されたらdenyに設定されたものを使います。 + not-oper: @が無い + + # チャンネルに対してでなく自分に対して+oの要求を行なった場合の発言。 + # 省略されたらdenyに設定されたものを使います。 + private: チャンネルで要求せよ + + # チャンネルの外から+oを要求された場合の発言。+nチャンネルでは起こりません。 + # 省略されたらdenyに設定されたものを使います。 + out: チャンネルに入っていない +} + +- Auto::Random { + # 特定の発言に反応してランダムな発言をします。 + + # Auto::Aliasを有効にしていれば、エイリアス置換を行ないます。 + + # 使用するブロックの定義。 + blocks: wimikuji + + wimikuji { + # ランダムに発言するメッセージの書かれたファイルと、その文字コードを指定します。 + # ファイルの中では一行に一つのメッセージを書いて下さい。 + file: random.txt + file-encoding: euc + + # 反応する発言を表すマスクを指定します。 + request: ゐみくじ + + # メッセージの登録数を返答するキーワードを指定します。 + count-query: ゐみくじ登録数 + + # メッセージの登録数を返答するときの反応を指定します。 + # formatで指定できるものと同じです。#(count)は登録数になります。 + count-format: ゐみくじは#(count)件登録されています。 + + # ランダムなメッセージを発言する際のフォーマットを指定します。 + # エイリアス置換が有効です。#(message)、#(nick.now)、#(channel)は + # それぞれメッセージ内容、相手のnick、チャンネル名に置換されます。 + # 何も登録されていないときのために、#(message|;無登録)のように指定すると良いでしょう。 + format: #(name|nick.now)の運命は#(message) + + # 反応する人のマスク。 + mask: * *!*@* + # plum: mask: *!*@* + + # メッセージが追加されたときの反応を指定します。 + # formatで指定できるものと同じです。#(message)は追加されたメッセージになります。 + added-format: #(name|nick.now): ゐみくじ #(message) を追加しました。 + + # メッセージが削除されたときの反応を指定します。 + # formatで指定できるものと同じです。#(message)は削除されたメッセージになります。 + removed-format: #(name|nick.now): ゐみくじ #(message) を削除しました。 + + # 発言に反応する確率を指定します。百分率です。省略された場合は100と見做されます。 + rate: 100 + + # メッセージを追加するキーワードを指定します。 + # ここで指定したキーワードを発言すると、新しいメッセージを追加します。 + # 実際の追加方法は「 <追加するメッセージ>」です。 + add: ゐみくじ追加 + + # メッセージを削除するキーワードを指定します。 + # 実際の削除方法は「 <削除するキーワード>」です。 + remove: ゐみくじ削除 + + # addとremoveを許可する人。省略された場合は誰も変更できません。 + modifier: * *!*@* + # plum: modifier: *!*@* + } +} + +- Auto::Reply { + # 特定の発言に反応して発言をします。 + + # Auto::Aliasを有効にしていれば、エイリアス置換を行ないます。 + + # 使用するブロックの定義。 + blocks: std + + std { + # データファイルと文字コードを指定します。 + # ファイルの中では一行に一つの"反応:メッセージ"を書いて下さい。 + file: reply.txt + file-encoding: euc + + # 反応チェックを行うキーワードを指定します。 + # 実際の指定方法は、「 <チェックしたい発言>」です。 + request: 反応チェック + + # request に反応するときのフォーマットを指定します。 + # #(key) がキーワード、 #(message) が発言に置換されます。 + reply-format: 「#(key)」という発言に「#(message)」と反応します。 + + # request に反応する最大個数を指定します。 + # あまり大きな値を指定すると、アタックが可能になったり、ログが流れて邪魔なので注意してください。 + max-reply: 5 + + # メッセージの登録数を返答するキーワードを指定します。 + count-query: 反応登録数 + + # メッセージの登録数を返答するときの反応を指定します。 + # formatで指定できるものと同じです。#(count)は登録数になります。 + count-format: 反応は#(count)件登録されています。 + + # 反応する人のマスク。 + mask: * *!*@* + # plum: mask: *!*@* + + # 反応が追加されたときの反応を指定します。 + # formatで指定できるものと同じです。#(message)は追加されたメッセージになります。 + added-format: #(name|nick.now): #(key) に対する反応 #(message) を追加しました。 + + # メッセージが削除されたときの反応を指定します。 + # formatで指定できるものと同じです。#(message)は削除されたメッセージになります。 + removed-format: #(name|nick.now): #(key) #(message;に対する反応 %s|;) を #(count) 件削除しました。 + + # 発言に反応する確率を指定します。百分率です。省略された場合は100と見做されます。 + rate: 100 + + # メッセージを追加するキーワードを指定します。 + # ここで指定したキーワードを発言すると、新しいメッセージを追加します。 + # 実際の追加方法は「 <追加するメッセージ>」です。 + add: 反応追加 + + # メッセージを削除するキーワードを指定します。 + # 実際の削除方法は「 <削除するキーワード>」です。 + remove: 反応削除 + + # addとremoveを許可する人。省略された場合は「* *!*@*」と見做します。 + modifier: * *!*@* + + # 正規表現拡張を許可するか。省略された場合は禁止します。 + use-re: 1 + } +} + +- Auto::Response { + # データファイルの指定にしたがって反応する。 + + # 大量の反応データを定義するのに向いています。 + + # データファイルのフォーマット + # | pattern: re:^(こん(に)?ちは) + # | rate: 90 + # | mask: * *!*@* + # | #plum: mask: *!*@* + # | response: こんにちは。 + # | response: いらっしゃいませ。 + # | + # | pattern: おやすみ + # | rate: 20 + # | response: おやすみなさい。 + # patternは一行しか書けません。(手抜き + # maskもrateも省略できます。省略した場合はmaskは全員、rateは100となります。 + # responseは複数書いておけばランダムに選択されます。 + + # データファイル + file: response.txt + + # 文字コード + charset: euc + + # 使用を許可する人&チャンネルのマスク。 + mask: * *!*@* + # plum: mask: +*!*@* +} + +- CTCP::ClientInfo { + # CTCP CLIENTINFOに応答する。 + + # CTCP::Versionのintervalと同じ。 + interval: 3 +} + +- CTCP::DCC::RewriteAddress { + # クライアントが送信した CTCP DCC のアドレスを変換する。 + + # CTCP DCC に指定されているアドレスを、 tiarra で取得したものに + # 書き換えます。(EXPERIMENTAL) + # + # IPv4 のみサポートしています。 + # + # このモジュールは一旦 CTCP DCC メッセージを破棄するので、 + # 別のクライアントには送信されません。 + + # 変換する DCC タイプ。 [デフォルト値: CHAT SEND] + type: CHAT SEND + + # 変換用アドレスの取得方法を選択する。デフォルト値はありません。 + # 以下の取得方法(server-socket client-socket dns http)から + # 必要なもの(複数可)を指定してください。 + resolver: client-socket server-socket dns http + + + # 取得方法と設定 + # なにも設定がないときはブロック自体を省略することもできます。 + + server-socket { + # サーバソケットのローカルアドレスを取ります。 + # client <-> tiarra[this address] <-> server + } + + client-socket { + # クライアントソケットのリモートアドレスを取ります。 + # client [this address]<-> tiarra <-> server + } + + dns { + # DNS を引いて決定します。IPアドレスの指定も可能です。 + host: example.com + } + + http { + # 現状では単純な GET しかサポートしていません。 + + # アクセス先 URL + url: http://checkip.dyndns.org/ + + # IP アドレス取得用 regex + regex: Current IP Address: (\d+\.\d+\.\d+\.\d+) + } + + # リゾルバの選び方 + # + # * tiarra を動作させているサーバとインターネットの間にルータ等があり、 + # グローバルアドレスがない場合 + # *-socket は役に立ちません。 http を利用してください。 + # 適当な DDNS を持っていればdns も良いでしょう。 + # + # * tiarra がレンタルサーバなどLAN上にないサーバで動作している場合 + # server-socket, http は役に立ちません。 + # client-socket がお勧めです。 + # + # * tiarra がLAN上にあり、グローバルアドレスのついているホストで + # 動作している場合 + # client-socket は役に立ちません。 + # server-socket がお勧めです。 +} + +- CTCP::Ping { + # CTCP PINGに応答する。 + + # CTCP::Versionのintervalと同じ。 + interval: 3 +} + +- CTCP::Time { + # CTCP TIMEに応答する。 + + # CTCP::Versionのintervalと同じ。 + interval: 3 +} + +- CTCP::UserInfo { + # CTCP USERINFOに応答する。 + + # CTCP::Versionのintervalと同じ。 + interval: 3 + + # USERINFOとして返すメッセージ。 + message: テスト +} + ++ CTCP::Version { + # CTCP VERSIONに応答する。 + + # 連続したCTCPリクエストに対する応答の間隔。単位は秒。 + # 例えば3秒に設定した場合、一度応答してから3秒間は + # CTCPに一切応答しなくなる。デフォルトは3。 + # + # なお、CTCP受信時刻の記録は、全てのCTCPモジュールで共有される。 + # 例えばCTCP VERSIONを送った直後にCTCP CLIENTINFOを送ったとしても、 + # CTCP::ClientInfoのintervalで設定された時間を過ぎていなければ + # 後者は応答しない。 + interval: 3 +} + +- Channel::Freeze { + # 特定のチャンネルの発言を、一時的に受信するのをやめる。 + + # ログを取っているなら、ログには記録される。 + + # チャンネルの凍結に用いるコマンド名。 + # 省略時は freeze であり、/freeze #channel@network のように使う。 + # チャンネル名を省略すると、現在フリーズされているチャンネルのリストを表示する。 + freeze-command: freeze + + # 凍結解除に用いるコマンド名。 + # 省略時は defrost であり、/defrost #channel@network のように使う。 + defrost-command: defrost + + # 凍結しているチャンネルが存在する時、一定時間毎にその旨を報告する事も可能。 + # この機能は凍結した事を忘れないようにする為にある。 + # 単位は分、デフォルトはゼロ(報告しない)。 + reminder-interval: 30 +} + +- Channel::Ignore { + # 指定されたチャンネルの存在を、様々なメッセージから消去する。 + + # 対象となったチャンネルのJOIN、PART、INVITE、QUIT、NICK、NAMES、NJOINは消去される。 + + # 注意点 + # - この機能はまだ実装途中です。いろいろな不具合があるかもしれません。むしろきっとあります。 + # - サーバがわとの通信に割り込みますのでログにもとられません。 + # - この機能を使っている tiarra より上流に multi-server-mode な tiarra を置かないでください。 + + # チャンネルの定義。 + # また、privの場合は「priv@ネットワーク名」という文字列をチャンネル名の代わりとしてマッチングを行なう。 + # 書式: mask: <チャンネルのマスク> + mask: #example@example +} + +- Channel::Join::Connect { + # サーバーに初めて接続した時、指定したチャンネルに入るモジュール。 + + # 書式: <チャンネル1>[,<チャンネル2>,...] [<チャンネル1のキー>,...] + # コンマの直後のスペースは無視されます。 + # + # 例: + # 「#aaaaa@ircnet」に「aaaaa」というキーで入る。 + #channel: #aaaaa@ircnet aaaaa + # + # 「#aaaaa@ircnet」、「#bbbbb@ircnet:*.jp」、「#ccccc@ircnet」、「#ddddd@ircnet」の4つのチャンネルに入る。 + #channel: #aaaaa@ircnet,#bbbbb@ircnet:*.jp, #ccccc@ircnet + #channel: #ddddd@ircnet +} + +- Channel::Join::Invite { + # 招待されたらそのチャンネルに入る。 + + # 許可するユーザ/チャンネルのマスク。 + mask: * *!*@* + # plum: *!*@* + + # 招待されたチャンネルに流すメッセージのフォーマット。 + #message: こんばんわ〜。 +} + +- Channel::Join::Kicked { + # 特定のチャンネルからkickされた時に、自動で入りなおす。 + + # 対象となるチャンネル名のマスク + channel: * +} + +- Channel::Mode::Get { + # チャンネルにJOINした時、そのチャンネルのモードを取得します。 + + # Channel::Mode::Set等が正しく動くためには + # チャンネルのモードをTiarraが把握しておく必要があります。 + # 自動的にモードを取得するクライアントであれば必要ありませんが、 + # そうでなければこのモジュールを使うべきです。 + + # 設定項目は無し。 +} + +- Channel::Mode::Oper::Grant { + # 特定のチャンネルに特定の人間がjoinした時に、自分がチャンネルオペレータ権限を持っていれば+oする。 + + # splitからの復帰などで+o対象の人が一度に大量に入って来ても+oは少しずつ実行します。 + # Excess Floodにはならない筈ですが、本格的な防衛BOTに使える程の物ではありません。 + + # 対象の人間がjoinしてから実際に+oするまで何秒待つか。 + # 省略されたら待ちません。 + # 5-10 のように指定されると、その値の中でランダムに待ちます。 + wait: 2-5 + + # チャンネルと人間のマスクを定義。Auto::Operと同様。 + #mask: * example!~example@*.example.ne.jp +} + +- Channel::Mode::Set { + # チャンネルを作成した時に自動的にモードを設定するモジュール。 + + # 書式は<チャンネル名にマッチするマスク> <設定するモード>[,<設定するモード>,...]です。 + # #IRC談話室@ircnetなら+t+nを、それ以外なら+nを設定する例。 + #channel: #IRC談話室@ircnet +t + #channel: * +n + # LimeChat 標準設定を模倣する設定例。 + #channel: * +sn +} + +- Channel::Rejoin { + # チャンネルオペレータ権限を無くしたとき、一人ならjoinし直す。 + + # +チャンネルや+aされているチャンネル以外でチャンネルオペレータ権限を持たずに + # 一人きりになった時、そのチャンネルの@を復活させるために自動的にjoinし直すモジュール。 + # トピック、モード、banリスト等のあらゆるチャンネル属性をも保存します。 + + # +b,+I,+eリストの復旧を行なうかどうか。 + # あまりに長いリストを取得するとMax Send-Q Exceedで落とされるかも知れません。 + save-lists: 1 +} + +- Client::Cache { + # データをキャッシュしてサーバに問い合わせないようにする + + # キャッシュを使用しても、使われるのは接続後最初の一度だけです。 + # 二度目からは通常通りにサーバに問い合わせます。 + # また、クライアントオプションの no-cache を指定すれば動きません。 + + # mode キャッシュを使用するか + use-mode-cache: 1 + + # who キャッシュを使用するか + use-who-cache: 1 +} + ++ Client::Conservative { + # サーバが送信するような IRC メッセージを作成するようにする + + # サーバが実際に送信しているようなメッセージにあわせるようにします。 + # 多くのクライアントの設計ミスを回避でき(ると思われ)ます。 +} + +- Client::Cotton { + # Cotton の行うおかしな動作のいくつかを無視する + + # 該当クライアントのオプション client-type に cotton や unknown と指定するか、 + # Client::GetVersion を利用してクライアントのバージョンを取得するように + # してください。 + + # part shield (rejoin 時に自動で行われる part の無視)を使用するか + use-part-shield: 1 +} + +- Client::Eval { + # クライアントから Perl 式を実行できるようにする。 + + # eval を実行するコマンド名。省略されるとコマンドを追加しません。 + # この時コマンドはTiarraが握り潰すので、IRCプロトコル上で定義された + # コマンド名を設定すべきではありません。 + command: eval + + # hex eval を実行するコマンド名。省略されるとコマンドを追加しません。 + # この時コマンドはTiarraが握り潰すので、IRCプロトコル上で定義された + # コマンド名を設定すべきではありません。 + hex-command: hexeval + + # 表示する最大行数を指定します。省略するとすべての行を表示します。 + max-line: 30 +} + ++ Client::GetVersion { + # クライアントに CTCP Version を発行してバージョン情報を得る + + # オプションはいまのところありません。 + # (開発者向け情報: 取得した情報は remark の client-version に設定され、 + # Client::Guess から使用されます。) +} + +- Client::PatchworkMessage { + # IRC メッセージにちょっと変更を加えて、クライアントのバグを抑制する + + # 特に注意書きがない場合はデフォルトで有効です。 + # また、 Client::GetVersion も同時に入れておくと便利です。 + # とりあえず obsolete です。このモジュールで実装されていた機能は + # Client::Conservative によって実現できます。 + # Client::Conservative で実装してはいけないようなものがあった場合のみ + # このモジュールで対処します。 + + # WoolChat: + # 対応しているメッセージ: + # NICK(コロンが必須) + # 説明: + # NICK は接続直後にも発行されるため、 Client::GetVersion での判別まで + # 待てません。該当クライアントのオプション client-type に woolchat と + # 指定してください。実名欄に $client-type=woolchat$ と書けば OK です。 + enable-woolchat: 1 + + # X-Chat: + # 対応しているメッセージ: + # RPL_WHOISUSER(コロンが必須) + # 説明: + # WHOIS の realname にスペースが入っていないと最初の一文字が削られます。 + enable-xchat: 1 +} + +- Client::ProtectMyself { + # 意図せず自分のニックが変わってしまうのを防止する + + # {nick,part,quit,join}-format: それぞれのメッセージのフォーマットを指定します。 + # {nick,user,host,prefix}.now などはどこでも使えます。 + # そのほかには + # target : 表示するチャンネル(またはニック)。 + # nick.new : nick-format のみ。新しいニック。 + # message : part と quit 。メッセージ。 + + nick-format: Nick changed #(nick.now) -> #(nick.new) + part-format: Part #(nick.now) (#(message)) from #(target) + quit-format: Quit #(nick.now) (#(message)) + join-format: Join #(nick.now) (#(prefix.now)) to #(target) +} + +- Client::Rehash { + # 全チャンネル分の names の内部キャッシュをクライアントに送信する。 + + # もともとはクライアントの再初期化目的に作ったのですが、 names を送信しても + # 更新されないクライアントが多いので、主に multi-server-mode な Tiarra の + # 下にさらに Tiarra をつないでいる人向けにします。 + + # names でニックリストを更新してくれるクライアント: + # Tiarra + # してくれないクライアント: (括弧内は確認したバージョンまたは注釈) + # LimeChat(1.18) + + # nick rehash に使うコマンドを指定します。 + # 第二パラメータとして現在クライアントが認識している nick を指定してください。 + command-nick: rehash-nick + + # names rehash に使うコマンドを指定します。 + command-names: rehash-names + + # チャンネルとチャンネルの間のウェイトを指定します。 + interval: 2 +} + +- Client::ShowNick { + # show network + +} + +- Debug::Core { + # Tiarra の内部構造の追跡. + + # Tiarra の内部構造を出力します. + + # トリガー用コマンド. + # デフォルトは debugcore + command: debugcore + + # [top commands] + # help - show this usage. + # bbs - show BulletinBoard info. + # socket - show internal sockets. + # module - show module info. + + # [sub commands] + # help: + # bbs: + # keys - show keys in BulletinBoard. + # socket: + # help - show this usage. + # list - show installed socket. + # get - show socket in detail. + # uninstall - uninstall detached socket. + # module: + # help - show this usage. + # summary - show module summary. + # list - show module list in detail. + # dep - show module dependency. +} + +- Debug::RawLog { + # 標準出力にクライアントやサーバとの通信をダンプする。 + + # 0 または省略で表示しない。 1 で表示する。 + # クライアントオプションの logname によって、ダンプに使う名前を指定できます。 + + # サーバからの入力 + enable-server-in: 1 + + # サーバへの出力 + enable-server-out: 1 + + # クライアントからの入力 + enable-client-in: 0 + + # クライアントへの出力 + enable-client-out: 0 + + # PING/PONG を無視する + ignore-ping: 1 + + # NumericReply の名前を解決して表示する(ちゃんとした dump では無くなります) + resolve-numeric: 1 +} + +- Log::Channel { + # チャンネルやprivのログを取るモジュール。 + + # Log系のモジュールでは、以下のように日付や時刻の置換が行なわれる。 + # %% : % + # %Y : 年(4桁) + # %m : 月(2桁) + # %d : 日(2桁) + # %H : 時間(2桁) + # %M : 分(2桁) + # %S : 秒(2桁) + + # ログを保存するディレクトリ。Tiarraが起動した位置からの相対パス。~指定は使えない。 + directory: log + + # ログファイルの文字コード。省略されたらjis。 + charset: utf8 + + # 各行のヘッダのフォーマット。省略されたら'%H:%M'。 + header: %H:%M:%S + + # ファイル名のフォーマット。省略されたら'%Y.%m.%d.txt' + filename: %Y.%m.%d.txt + + # ログファイルのモード(8進数)。省略されたら600 + mode: 600 + + # ログディレクトリのモード(8進数)。省略されたら700 + dir-mode: 700 + + # ログを取るコマンドを表すマスク。省略されたら記録出来るだけのコマンドを記録する。 + command: privmsg,join,part,kick,invite,mode,nick,quit,kill,topic,notice + + # PRIVMSGとNOTICEを記録する際に、自分の発言と他人の発言でフォーマットを変えるかどうか。1/0。デフォルトで1。 + distinguish-myself: 1 + + # 各ログファイルを開きっぱなしにするかどうか。 + # このオプションは多くの場合、ディスクアクセスを抑えて効率良くログを保存しますが + # ログを記録すべき全てのファイルを開いたままにするので、50や100のチャンネルを + # 別々のファイルにログを取るような場合には使うべきではありません。 + # 万一 fd があふれた場合、クライアントから(またはサーバへ)接続できない・ + # 新たなモジュールをロードできない・ログが全然できないなどの症状が起こる可能性が + # あります。limit の詳細については OS 等のドキュメントを参照してください。 + #keep-file-open: 1 + + # keep-file-open 時に各行ごとに flush するかどうか。 + # open/close の負荷は気になるが、ログは失いたくない人向け。 + # keep-file-open が有効でないなら無視され(1になり)ます。 + #always-flush: 0 + + # keep-file-openを有効にした場合、発言の度にログファイルに追記するのではなく + # 一定の分量が溜まってから書き込まれる。そのため、ファイルを開いても + # 最近の発言はまだ書き込まれていない可能性がある。 + # syncを設定すると、即座にログをディスクに書き込むためのコマンドが追加される。 + # 省略された場合はコマンドを追加しない。 + sync: sync + + # 各チャンネルの設定。チャンネル名の部分はマスクである。 + # 個人宛てに送られたPRIVMSGやNOTICEはチャンネル名"priv"として検索される。 + # 記述された順序で検索されるので、全てのチャンネルにマッチする"*"などは最後に書かなければならない。 + # 指定されたディレクトリが存在しなかったら、Log::Channelはそれを勝手に作る。 + # フォーマットは次の通り。 + # channel: <ディレクトリ名> (<チャンネル名> / 'priv') + # 例: + # filename: %Y.%m.%d.txt + # channel: IRCDanwasitu #IRC談話室@ircnet + # channel: others * + # この例では、#IRC談話室@ircnetのログはIRCDanwasitu/%Y.%m.%d.txtに、 + # それ以外(privも含む)のログはothers/%Y.%m.%d.txtに保存される。 + channel: priv priv + channel: others * +} + +- Log::ChannelList { + # チャンネルリストをテンプレートに沿って HTML 化します。 + + # list コマンドが実行された際に動作します。 + + # 出力したいファイル名、ネットワーク名、使う設定のブロックを指定します。。 + networks: ircnet.html ircnet ircnet + + + ircnet { + # テンプレートファイルを指定します。 + template: channellist.html.tmpl + + # 出力とテンプレートファイルの文字コードを指定します。 + charset: euc + + # 取得を開始/終了した時刻のフォーマットを指定します。 + fetch-starttime: %Y年%m月%d日 %H時%M分(日本時間) + fetch-endtime: %Y年%m月%d日 %H時%M分(日本時間) + + # 表示するチャンネルの mask を指定します。 + mask: * + mask: -re:^\&(AUTH|SERVICES|LOCAL|HASH|SERVERS|NUMERICS|CHANNEL|KILLS|NOTICES|ERRORS) + + # 出力するファイルのモードを指定します。 + mode: 644 + } +} + +- Log::Raw { + # サーバとの生の通信を保存する + + # Log系のモジュールでは、以下のように日付や時刻の置換が行なわれる。 + # %% : % + # %Y : 年(4桁) + # %m : 月(2桁) + # %d : 日(2桁) + # %H : 時間(2桁) + # %M : 分(2桁) + # %S : 秒(2桁) + + # ログを保存するディレクトリ。Tiarraが起動した位置からの相対パス。~指定は使えない。 + directory: rawlog + + # 各行のヘッダのフォーマット。省略されたら'%H:%M'。 + header: %H:%M:%S + + # ファイル名のフォーマット。省略されたら'%Y.%m.%d.txt' + filename: %Y-%m-%d.txt + + # ログファイルのモード(8進数)。省略されたら600 + mode: 600 + + # ログディレクトリのモード(8進数)。省略されたら700 + dir-mode: 700 + + # 使っている文字コードがよくわからなかったときの文字コード。省略されたらutf8。 + # たぶんこの指定が生きることはないと思いますが……。 + charset: jis + + # NumericReply の名前を解決して表示する(ちゃんとした dump では無くなります) + resolve-numeric: 1 + + # ログを取るコマンドを表すマスク。省略されたら記録出来るだけのコマンドを記録する。 + command: *,-ping,-pong + + # 各ログファイルを開きっぱなしにするかどうか。 + # このオプションは多くの場合、ディスクアクセスを抑えて効率良くログを保存しますが + # ログを記録すべき全てのファイルを開いたままにするので、50や100のチャンネルを + # 別々のファイルにログを取るような場合には使うべきではありません。 + # 万一 fd があふれた場合、クライアントから(またはサーバへ)接続できない・ + # 新たなモジュールをロードできない・ログが全然できないなどの症状が起こる可能性が + # あります。limit の詳細については OS 等のドキュメントを参照してください。 + #keep-file-open: 1 + + # keep-file-open 時に各行ごとに flush するかどうか。 + # open/close の負荷は気になるが、ログは失いたくない人向け。 + # keep-file-open が有効でないなら無視され(1になり)ます。 + #always-flush: 0 + + # keep-file-openを有効にした場合、発言の度にログファイルに追記するのではなく + # 一定の分量が溜まってから書き込まれる。そのため、ファイルを開いても + # 最近の発言はまだ書き込まれていない可能性がある。 + # syncを設定すると、即座にログをディスクに書き込むためのコマンドが追加される。 + # 省略された場合はコマンドを追加しない。 + sync: sync + + # 各サーバの設定。サーバ名の部分はマスクである。 + # 記述された順序で検索されるので、全てのサーバにマッチする"*"などは最後に書かなければならない。 + # 指定されたディレクトリが存在しなかったら、勝手に作られる。 + # フォーマットは次の通り。 + # channel: <ディレクトリ名> <サーバ名マスク> + # 例: + # filename: %Y-%m-%d.txt + # server: ircnet ircnet + # server: others * + # この例では、ircnetのログはircnet/%Y.%m.%d.txtに、 + # それ以外のログはothers/%Y.%m.%d.txtに保存される。 + server: ircnet ircnet + server: others * +} + +- Log::Recent { + # クライアントを接続した時に、保存しておいた最近のメッセージを送る。 + + # クライアントオプションの no-recent-logs が指定されていれば送信しません。 + + # 各行のヘッダのフォーマット。省略されたら'%H:%M'。 + header: %H:%M:%S + + # ログをチャンネル毎に何行まで保存するか。省略されたら10。 + line: 15 + + # PRIVMSGとNOTICEを記録する際に、自分の発言と他人の発言でフォーマットを変えるかどうか。1/0。デフォルトで1。 + distinguish-myself: 1 + + # どのメッセージを保存するか。省略されたら保存可能な全てのメッセージを保存する。 + command: privmsg,notice,topic,join,part,quit,kill +} + +- Skelton { + # Skelton for tiarra-module. + + # モジュールの説明をこのあたりに書く. + # 詳細はこのソースみれば分かると思われ. + # 書式は tiarra.conf にそのままコピーできる形式. + + # もにゅもにゅ + mask: *!*@* + mask: ... +} + ++ System::Error { + # サーバーからのERRORメッセージをNOTICEに埋め込む + + # これをoffにするとクライアントにERRORメッセージがそのまま送られます。 + # クライアントとの間ではERRORメッセージは主に切断警告に使われており、 + # そのまま流してしまうとクライアントが混乱する可能性があります。 + # 設定項目はありません。 + + # このモジュールを回避してERRORメッセージをクライアントに送りたい場合は、 + # remarkのsend-error-as-is-to-clientを指定してください。 +} + +- System::LivePatch { + # Live Patch. + + # main/* に対する実行時パッチ + # 起動/ロード時に確認は行われるが, 実際の適用は指示があるまで行われない. + + # 対応している箇所. + # ModuleManager / reload_modules_if_modified / r3004 => r8809 + + # /livepatch check で確認. + # /livepatch apply で適用. + command: livepatch +} + +- System::Macro { + # 新規にコマンドを追加し、そのコマンドが使われた時に特定の動作をまとめて実行します。 + + # 書式: <コマンド> <動作> + # コマンド"switch"を追加して、それが使われると + # #a@ircnet,#b@ircnet,#c@ircnetにjoinして、 + # #d@ircnet,#e@ircnet,#f@ircnetからpartする例。 + #macro: switch join #a@ircnet,#b@ircnet,#c@ircnet + #macro: switch part #d@ircnet,#e@ircnet,#f@ircnet +} + +- System::NotifyIcon::Win32 { + # タスクトレイにアイコンを表示する。 + + # タスクトレイにアイコンを表示します。 + # クリックすると表示非表示を切り替えることができ、右クリックすると + # Reload と Exit ができるコンテキストメニューを表示します。 + # 多少反応が鈍いかもしれませんがちょっと待てば出てくると思います。 + + # Win32::GUI を必要とします。 + # コンテキストメニューは表示している間処理をブロックしています。 + + # Win32 イベントループを処理する最大間隔を指定します。 + #interval: 2 + + # 通知領域に表示するアイコンを指定します。 + # Win32::GUI の制限でちゃんとしたアイコンファイルしか指定できません。 + iconfile: guiperl.ico + + # モジュールが読み込まれたときにコンソールウィンドウを隠すかどうかを + # 指定します。 + hide-console-on-load: 1 +} + ++ System::Pong { + # サーバーからのPINGメッセージに対し、自動的にPONGを返す。 + + # これをoffにするとクライアントが自らPINGに応答せざるを得なくなりますが、 + # クライアントからのPONGメッセージはデフォルトのサーバーへ送られるので + # デフォルト以外のサーバーからはPing Timeoutで落とされるなど + # 全く良い事がありません。 + # 設定項目はありません。 +} + ++ System::PrivTranslator { + # クライアントからの個人的なprivが相手に届かなくなる現象を回避する。 + + # このモジュールは個人宛てのprivmsgの送信者のnickにネットワーク名を付加します。 + # また、最後に声をかけられてから5分以内の nick 変更をクライアントに伝えます。 + # 設定項目はありませんが、 networks/channel-network-separator を ! や @ 以外に + # 変更することをおすすめします。 +} + +- System::Raw { + # マスクで指定したサーバーにIRCメッセージを加工せずに直接送る。 + + # 例えばQUITを送る事で一時的な切断が可能。 + + # この機能を利用するためのコマンド名。デフォルトは「raw」。 + # 「/raw ircnet quit」のようにして使う。 + # 一つ目のパラメータは送り先のネットワーク名。ワイルドカード使用可能。 + # CHOCOA の場合、 raw がクライアントで使われてしまうので、 + # コマンド名を変えるか、 /raw raw ircnet quit のようにする必要がある。 + command: raw +} + ++ System::Reload { + # confファイルやモジュールの更新をリロードするコマンドを追加する。 + + # リロードを実行するコマンド名。省略されるとコマンドを追加しません。 + # 例えば"load"を設定すると、"/load"と発言しようとした時にリロードを実行します。 + # この時コマンドはTiarraが握り潰すので、IRCプロトコル上で定義された + # コマンド名を設定すべきではありません。 + command: load + + # command と同じですが、サーバにもブロードキャストします。 + #broadcast-command: load-all + + # confファイルをリロードしたときに通知します。 + # モジュールの設定が変更されていた場合は、ここでの設定にかかわらず、 + # モジュールごとに表示されます。1または省略された場合は通知します。 + conf-reloaded-notify: 1 +} + +- System::RemoteControl { + # 特定の発言が送られてきたとき、それに反応してIRCコマンドを実行します。 + + # 実行を許可する人間を表すマスク。 + #mask: *!*example@example.net + + # 構文: + + # は反応するbotのnickを表すマスク。 + # はサーバーに向けて発行するIRCメッセージ。 + # + # 例: + # + hoge NICK [hoge] + # hogeというBOTが[hoge]にnickを変更する。 +} + +- System::Shutdown { + # Tiarraを終了させる。 + + # クライアントから特定のコマンドが実行された時や、 + # 誰かから個人的に(privで)特定の発言が送られた時に + # Tiarra を終了させます。 + + # 追加するコマンド。省略された場合はコマンドでのシャットダウンは無効になります。 + #command: shutdown + + # Tiarraをシャットダウンさせるprivの発言。 + # 省略された場合はprivでのシャットダウンは無効になります。 + # パラメータとして shutdown メッセージを指定できます。 + #message: shutdown + + # privでのシャットダウンを許可する人。 + # 省略された場合はprivでのシャットダウンは無効になります。 + # 複数のマスクを指定した場合は、一つでもマッチするものがあればシャットダウンします。 + #mask: example!example@*.example.jp +} + +- System::WebClient { + # ブラウザ上でログを見たり発言したりできます. + + # WebClient を起動させる場所の指定. + bind-addr: 127.0.0.1 + bind-port: 8668 + path: /irc + css: /style/irc-style.css + # 上の設定をapacheでReverseProxyさせる場合, httpd.conf には次のように設定. + # ProxyPass /irc/ http://localhost:8667/irc/ + # ProxyPassReverse /irc/ http://localhost:8667/irc/ + # + # ... + # + + # ReverseProxy 利用時の追加設定. + # 接続元が全部プロキシサーバになっちゃうのでその対応. + #extract-forwarded-for: 127.0.0.1 + + # 利用する接続設定の一覧. + # + # 空白区切りで評価する順に記述. + # 使われる設定は, + # - 接続元 IP が一致する物. + # - user/passが送られてきていない(認証前/anonymous): + # - 認証不要の設定があればその設定を利用. + # - 認証不要の設定がなければ 401 Unauthorized. + # - user/passが送られてきている. + # - 一致する設定を利用. + # - 一致する設定がなければ 401 Unauthorized. + allow: private public + + # 許可する接続の設定. + allow-private { + # 接続元IPアドレスの制限. + host: 127.0.0.1 + # 認証設定. + auth: user pass + # 公開するチャンネルの指定. + mask: #*@* + mask: *@* + } + allow-public { + host: * + auth: user2 pass2 + mask: #公開チャンネル@ircnet + } + + # デバッグフラグ. + #debug: 0 + + # 保存する最大行数. + #max-lines: 100 + + # クライアントモード. + # owner か shared. + # mode: owner + + # ログの方向. + # asc (旧->新) か desc (新->旧). + # sort-order: asc + + # 発言BOXで名前指定しなかったときのデフォルトの名前. + # mode: shared の時に使われる. + #name-default: (noname) +} + +- User::Away::Client { + # クライアントが一つも接続されていない時にAWAYを設定します。 + + # どのようなAWAYメッセージを設定するか。省略された場合はAWAYを設定しません。 + #away: 居ない。 +} + +- User::Away::Nick { + # ニックネーム変更に応じて AWAY を設定します。 + + # ニックネームを変更したときに、そのニックネームに対応するAWAYが + # 設定されていれば、そのAWAYを設定します。そうでなければAWAYを取り消します。 + + # 書式: <設定するAWAYメッセージ> + # + # nickをhoge_zzzに変更すると、「寝ている」というAWAYを設定する。 + # hoge_workまたはhoge_zzzに変更した場合は、「仕事中」というAWAYを設定する。 + # それ以外のnickに変更した場合はAWAYを取り消す。 + # 後者は正規表現を利用して「away: re:hoge_(work|zzz) 仕事中」としても良い。 + #away: hoge_zzz 寝ている + #away: hoge_work,hoge_zzz 仕事中 +} + +- User::Filter { + # 指定された人物からのPRIVMSGやNOTICEを書き換える。 + + # 人物のマスクと、置換パターンを定義。 + # 置換パターン中の#(message)は、発言内容に置換されます。 + # 人物が複数のマスクに一致する場合は、最初に一致したものが使われます。 + pattern: *!*@* #(message) +} + +- User::Ignore { + # 指定された人間からのPRIVMSGやNOTICEを破棄してクライアントへ送らないようにするモジュール。 + + # 対象となるコマンドのマスク。省略時には"privmsg,notice"が設定されている。 + # ただしprivmsgとnotice以外を破棄してしまうと、(Tiarraは平気でも)クライアントが混乱する。 + command: privmsg,notice + + # maskは複数定義可能。定義された順番でマッチングが行なわれます。 + mask: example!*@*.example.net +} + +- User::Nick::Detached { + # クライアントが接続されていない時に、特定のnickに変更します。 + + # クライアントが接続されていない時のnick。 + # このnickが既に使われていたら、適当に変更が加えられて使用されます。 + # クライアントが再び接続されると、切断前のローカルnickに戻ります。 + detached: PHO_d +} + +- User::ServerOper { + # 特定のネットワークに接続した時、OPERコマンドを発行します。 + + # 書式: <ネットワーク名> <オペレータ名> <オペレータパスワード> + # + # ネットワーク"local"に接続した時、オペレータ名oper、 + # オペレータパスワードoper-passでOPERコマンドを発行する例。 + #oper: local oper oper-pass +} + +- User::Vanish { + # 指定された人物の存在を、様々なメッセージから消去する。 + + # 対象となった人物の発行したJOIN、PART、INVITE、QUIT、NICKは消去され、NAMESの返すネームリストからも消える。 + # また、対象となった人物のNJOINも消去される。 + + # Vanish対象が発行したMODEを消去するかどうか。デフォルトで0。 + # 消去するとは云え、本当にMODEそのものを消してしまうのではなく、 + # そのユーザーの代わりに"HIDDEN!HIDDEN@HIDDEN.BY.USER.VANISH"がMODEを実行した事にする。 + drop-mode-by-target: 1 + + # Vanish対象を対象とするMODE +o/-o/+v/-vを消去するかどうか。デフォルトで1。 + drop-mode-switch-for-target: 1 + + # Vanish対象が発行したKICKを消去するかどうか。デフォルトで0。 + # 本当に消すのではなく、"HIDDEN!HIDDEN@HIDDEN.BY.USER.VANISH"がKICKを実行した事にする。 + drop-kick-by-target: 1 + + # Vanish対象を対象とするKICKを消去するかどうか。デフォルトで0。 + drop-kick-for-target: 0 + + # Vanish対象が発行したTOPICを消去するかどうか。デフォルトで0。 + # 本当に消すのでは無いが、他の設定と同じ。 + drop-topic-by-target: 1 + + # チャンネルとVanish対象の定義。 + # 特定のチャンネルでのみ対象とする、といった事が可能。 + # また、privの場合は「#___priv___@ネットワーク名」という文字列をチャンネル名の代わりとしてマッチングを行なう。 + # 書式: mask: <チャンネルのマスク> <ユーザーのマスク> + mask: #example@example example!exapmle@example.com +} + diff -urN /non-existant-dir/bundle/Unicode/Japanese.pm tiarra-20080510/bundle/Unicode/Japanese.pm --- /non-existant-dir/bundle/Unicode/Japanese.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/bundle/Unicode/Japanese.pm 2008-05-11 00:25:24.000000000 +0900 @@ -0,0 +1,5173 @@ +# ----------------------------------------------------------------------------- +# Unicode::Japanese +# Unicode::Japanese::PurePerl +# ----------------------------------------------------------------------------- +# $Id: Japanese.pm,v 1.24 2007/09/14 05:28:43 hio Exp $ +# ----------------------------------------------------------------------------- +package Unicode::Japanese::PurePerl; +package Unicode::Japanese; + +use strict; +use vars qw($VERSION $PurePerl $xs_loaderror); +$VERSION = '0.44'; + +# `use bytes' and `use Encode' if on perl-5.8.0 or later. +if( $] >= 5.008 ) +{ + my $evalerr; + { + local($SIG{__DIE__}) = 'DEFAULT'; + local($@); + eval 'use bytes;use Encode;'; + $evalerr = $@; + } + $evalerr and CORE::die($evalerr); +} + +# ----------------------------------------------------------------------------- +# import +# +sub import +{ + my $pkg = shift; + my ($callerpkg) = caller; + my %exp = + ( + '&unijp' => \&unijp, + ); + my @na; + my @add = (grep{$_ eq ':all'} @_) ? keys %exp : (); + foreach(@_, @add) + { + $_ eq 'PurePerl' and $PurePerl=1, next; + if( $exp{$_} || $exp{'&'.$_} ) + { + no strict 'refs'; + (my $name = $_) =~ s/^\W//; + my $obj = $exp{$_} || $exp{'&'.$_}; + *{$callerpkg.'::'.$name} = $obj; + }elsif( $_ eq 'no_I18N_Japanese' ) + { + $^H &= ~0x0f00_0000; + package Unicode::Japanese::PurePerl; + $^H &= ~0x0f00_0000; + package Unicode::Japanese; + next; + } + push(@na,$_); + } + if( @na ) + { + #use Carp; + #croak("invalid parameter (".join(',',@na).")"); + } +} + +# ----------------------------------------------------------------------------- +# DESTROY +# +sub DESTROY +{ +} + +# ----------------------------------------------------------------------------- +# load_xs. +# loading xs-subs. +# this method is called from new (through new=>_init_table=>load_xs) +# +sub load_xs +{ + #print STDERR "load_xs\n"; + if( $PurePerl ) + { + #print STDERR "PurePerl mode\n"; + $xs_loaderror = 'disabled'; + return; + } + #print STDERR "XS mode\n"; + + my $use_xs; + LoadXS: + { + + #print STDERR "* * bootstrap...\n"; + eval q + { + use strict; + require DynaLoader; + use vars qw(@ISA); + @ISA = qw(DynaLoader); + local($SIG{__DIE__}) = 'DEFAULT'; + Unicode::Japanese->bootstrap($VERSION); + }; + #print STDERR "* * try done.\n"; + #undef @ISA; + if( $@ ) + { + #print STDERR "failed.\n"; + #print STDERR "$@\n"; + $use_xs = 0; + $xs_loaderror = $@; + undef $@; + last LoadXS; + } + #print STDERR "succeeded.\n"; + $use_xs = 1; + eval q + { + #print STDERR "over riding _s2u,_u2s\n"; + do_memmap(); + #print STDERR "memmap done\n"; + END{ do_memunmap(); } + #print STDERR "binding xsubs done.\n"; + }; + if( $@ ) + { + #print STDERR "error on last part of load XS.\n"; + $xs_loaderror = $@; + CORE::die($@); + } + + #print STDERR "done.\n"; + } + + if( $@ ) + { + $xs_loaderror = $@; + CORE::die("Cannot Load Unicode::Japanese either XS nor PurePerl\n$@"); + } + if( !$use_xs ) + { + #print STDERR "no xs.\n"; + eval q + { + sub do_memmap($){} + sub do_memunmap($){} + }; + } + $xs_loaderror = '' if( !defined($xs_loaderror) ); + #print STDERR "load_xs done.\n"; +} + +# ----------------------------------------------------------------------------- +# Unicode::Japanese->new(); +# cache for char convert. +# 2bytes. +# JIS C 6226-1979 \e$@ +# JIS X 0208-1983 \e$B +# JIS X 0208-1990 \e&@\e$B +# JIS X 0212-1990 \e$(D +# 1byte. +# JIS ROMAN \e(J +# JIS ROMAN \e(H +# ASCII \e(B +# JIS KANA \e(I +# ----------------------------------------------------------------------------- +# $unijp = Unicode::Japanese->new([$str,[$icode]]); +# +sub new +{ + my $pkg = shift; + my $this = {}; + + if( defined($pkg) ) + { + bless $this, $pkg; + $this->_init_table; + }else + { + bless $this; + $this->_init_table; + } + + @_ and $this->set(@_); + + $this; +} + + +# ----------------------------------------------------------------------------- +# _got_undefined_subroutine +# die with message 'undefiend subroutine'. +# +sub _got_undefined_subroutine +{ + my $subname = pop; + CORE::die "Undefined subroutine \&$subname called.\n"; +} + +# ----------------------------------------------------------------------------- +# AUTOLOAD +# AUTOLOAD of Unicode::Japanese. +# imports PurePerl methods. +# +AUTOLOAD +{ + # load pure perl subs. + use vars qw($AUTOLOAD); + my ($pkg,$subname) = $AUTOLOAD =~ /^(.*)::(\w+)$/ + or got_undefined_subroutine($AUTOLOAD); + no strict 'refs'; + if(!defined($Unicode::Japanese::xs_loaderror) ) + { + Unicode::Japanese::PurePerl::_init_table(); + if( defined(&$AUTOLOAD) ) + { + return &$AUTOLOAD; + } + } + my $ppsubname = "$pkg\:\:PurePerl\:\:$subname"; + my $sub = \&$ppsubname; + *$AUTOLOAD = $sub; # copy. + goto &$sub; +} + +# ----------------------------------------------------------------------------- +# Unicode::Japanese::PurePerl +# ----------------------------------------------------------------------------- +package Unicode::Japanese::PurePerl; + + +use strict; +use vars qw(%CHARCODE %ESC %RE); + +use vars qw(@J2S @S2J @S2E @E2S @U2T %T2U %S2U %U2S %SA2U1 %U2SA1 %SA2U2 %U2SA2); + +%CHARCODE = ( + UNDEF_EUC => "\xa2\xae", + UNDEF_SJIS => "\x81\xac", + UNDEF_JIS => "\xa2\xf7", + UNDEF_UNICODE => "\x20\x20", + ); + +%ESC = ( + JIS_0208 => "\e\$B", + JIS_0212 => "\e\$(D", + ASC => "\e\(B", + KANA => "\e\(I", + E_JSKY_START => "\e\$", + E_JSKY_END => "\x0f", + ); + +%RE = + ( + ASCII => '[\x00-\x7f]', + EUC_0212 => '\x8f[\xa1-\xfe][\xa1-\xfe]', + EUC_C => '[\xa1-\xfe][\xa1-\xfe]', + EUC_KANA => '\x8e[\xa1-\xdf]', + JIS_0208 => '\e\$\@|\e\$B|\e&\@\e\$B', + JIS_0212 => "\e" . '\$\(D', + JIS_ASC => "\e" . '\([BJ]', + JIS_KANA => "\e" . '\(I', + SJIS_DBCS => '[\x81-\x9f\xe0-\xef\xfa-\xfc][\x40-\x7e\x80-\xfc]', + SJIS_KANA => '[\xa1-\xdf]', + UTF8 => '[\x00-\x7f]|[\xc0-\xdf][\x80-\xbf]|[\xe0-\xef][\x80-\xbf]{2}|[\xf0-\xf7][\x80-\xbf]{3}|[\xf8-\xfb][\x80-\xbf]{4}|[\xfc-\xfd][\x80-\xbf]{5}', + BOM2_BE => '\xfe\xff', + BOM2_LE => '\xff\xfe', + BOM4_BE => '\x00\x00\xfe\xff', + BOM4_LE => '\xff\xfe\x00\x00', + UTF32_BE => '\x00[\x00-\x10][\x00-\xff]{2}', + UTF32_LE => '[\x00-\xff]{2}[\x00-\x10]\x00', + E_IMODEv1 => '\xf8[\x9f-\xfc]|\xf9[\x40-\x49\x50-\x52\x55-\x57\x5b-\x5e\x72-\x7e\x80-\xb0]', + E_IMODEv2 => '\xf9[\xb1-\xfc]', + E_IMODE => '\xf8[\x9f-\xfc]|\xf9[\x40-\x49\x50-\x52\x55-\x57\x5b-\x5e\x72-\x7e\x80-\xfc]', + E_JSKY1 => '[EFGOPQ]', + E_JSKY1v1 => '[EFG]', + E_JSKY1v2 => '[OPQ]', + E_JSKY2 => '[\!-z]', + E_DOTI => '\xf0[\x40-\x7e\x80-\xfc]|\xf1[\x40-\x7e\x80-\xd6]|\xf2[\x40-\x7e\x80-\xab\xb0-\xd5\xdf-\xfc]|\xf3[\x40-\x7e\x80-\xfa]|\xf4[\x40-\x4f\x80\x84-\x8a\x8c-\x8e\x90\x94-\x96\x98-\x9c\xa0-\xa4\xa8-\xaf\xb4\xb5\xbc-\xbe\xc4\xc5\xc8\xcc]', + E_JIS_AU => '[\x75-\x7b][\x21-\x7e]', + E_SJIS_AU => '[\xf3\xf4\xf6\xf7][\x40-\xfc]', + E_ICON_AU_START => '', + E_JSKY_START => quotemeta($ESC{E_JSKY_START}), + E_JSKY_END => '(?:'.quotemeta($ESC{E_JSKY_END}).'|\z)', + E_JSKYv1_UTF8 => qr/\xee(?:\x80[\x81-\xbf]|\x81[\x80-\x9a]|\x84[\x81-\xbf]|\x85[\x80-\x9a]|\x88[\x81-\xbf]|\x89[\x80-\x9a])/, + E_JSKYv2_UTF8 => qr/\xee(?:\x8c[\x81-\xbf]|\x8d[\x80-\x8d]|\x90[\x81-\xbf]|\x91[\x80-\x8c]|\x94[\x81-\xb7])/, + ); + +$RE{E_JSKY} = $RE{E_JSKY_START} + . $RE{E_JSKY1} . $RE{E_JSKY2} . '+' + . $RE{E_JSKY_END}; +$RE{E_JSKYv1} = $RE{E_JSKY_START} + . $RE{E_JSKY1v1} . $RE{E_JSKY2} . '+' + . $RE{E_JSKY_END}; +$RE{E_JSKYv2} = $RE{E_JSKY_START} + . $RE{E_JSKY1v2} . $RE{E_JSKY2} . '+' + . $RE{E_JSKY_END}; + +our @CHARSET_LIST = qw( + utf8 + ucs2 + ucs4 + utf16 + + sjis + sjis-imode + sjis-doti + sjis-jsky + sjis-icon-au + cp932 + + jis + jis-jsky + jis-au + jis-icon-au + + euc + euc-jp + euc-icon-au + + utf8-jsky + utf8-icon-au +); + +use vars qw($s2u_table $u2s_table); +use vars qw($ei2u1 $ei2u2 $ed2u $ej2u1 $ej2u2 $ea2u1 $ea2u2 $ea2u1s $ea2u2s); +use vars qw($eu2i1 $eu2i2 $eu2d $eu2j1 $eu2j2 $eu2a1 $eu2a2 $eu2a1s $eu2a2s); + +use vars qw(%_h2zNum %_z2hNum %_h2zAlpha %_z2hAlpha %_h2zSym %_z2hSym %_h2zKanaK %_z2hKanaK %_h2zKanaD %_z2hKanaD %_hira2kata %_kata2hira); + + + +use vars qw($FH $TABLE $HEADLEN $PROGLEN); + +# ----------------------------------------------------------------------------- +# AUTOLOAD +# AUTOLOAD of Unicode::Japanese::PurePerl. +# load PurePerl methods from embeded data. +# +AUTOLOAD +{ + use strict; + use vars qw($AUTOLOAD); + + #print STDERR "AUTOLOAD... $AUTOLOAD\n"; + + my $save = $@; + my @BAK = @_; + + my $subname = $AUTOLOAD; + $subname =~ s/^Unicode\:\:Japanese\:\:(?:PurePerl\:\:)?//; + + #print "subs..\n",join("\n",keys %$TABLE,''); + + # check + if(!defined($TABLE->{$subname}{offset})) + { + _init_table(); + if( !defined($TABLE->{$subname}{offset}) ) + { + if( substr($AUTOLOAD,-9) eq '::DESTROY' ) + { + { + no strict; + *$AUTOLOAD = sub {}; + } + $@ = $save; + @_ = @BAK; + goto &$AUTOLOAD; + } + + CORE::die "Undefined subroutine \&$AUTOLOAD called.\n"; + } + } + if($TABLE->{$subname}{offset} == -1) + { + CORE::die "Double loaded \&$AUTOLOAD. It has some error.\n"; + } + + seek($FH, $PROGLEN + $HEADLEN + $TABLE->{$subname}{offset}, 0) + or die "Can't seek $subname. [$!]\n"; + + my $sub; + read($FH, $sub, $TABLE->{$subname}{length}) + or die "Can't read $subname. [$!]\n"; + + if( $]>=5.008 ) + { + $sub = 'use bytes;'.$sub; + } + + CORE::eval(($sub=~/(.*)/s)[0]); + if ($@) + { + CORE::die $@; + } + $DB::sub = $AUTOLOAD; # Now debugger know where we are. + + # evaled + $TABLE->{$subname}{offset} = -1; + + $@ = $save; + @_ = @BAK; + goto &$AUTOLOAD; +} + +# ----------------------------------------------------------------------------- +# Unicode::Japanese::PurePerl->new() +# +sub new +{ + goto &Unicode::Japanese::new; +} + +# ----------------------------------------------------------------------------- +# DESTROY +# +sub DESTROY +{ +} + +# ----------------------------------------------------------------------------- +# gensym +# +sub gensym { + package Unicode::Japanese::Symbol; + no strict; + $genpkg = "Unicode::Japanese::Symbol::"; + $genseq = 0; + my $name = "GEN" . $genseq++; + my $ref = \*{$genpkg . $name}; + delete $$genpkg{$name}; + $ref; +} + +# ----------------------------------------------------------------------------- +# _init_table +# +sub _init_table { + + if(!defined($HEADLEN)) + { + $FH = gensym; + + my $file = "Unicode/Japanese.pm"; + OPEN: + { + if( $INC{$file} ) + { + open($FH,$INC{$file}) || CORE::die("could not open file [$INC{$file}] for input : $!"); + last OPEN; + } + foreach my $path (@INC) + { + my $mypath = $path; + $mypath =~ s#/$##; + if (-f "$mypath/$file") + { + open($FH,"$mypath/$file") || CORE::die("could not open file [$INC{$file}] for input : $!"); + last OPEN; + } + } + CORE::die "Can't find Japanese.pm in \@INC\n"; + } + binmode($FH); + + local($/) = "\n"; + my $line; + while($line = <$FH>) + { + last if($line =~ m/^__DATA__/); + } + $PROGLEN = tell($FH); + + read($FH, $HEADLEN, 4) + or die "Can't read table. [$!]\n"; + $HEADLEN = unpack('N', $HEADLEN); + read($FH, $TABLE, $HEADLEN) + or die "Can't seek table. [$!]\n"; + $TABLE =~ /(.*)/s; + $TABLE = eval(($TABLE=~/(.*)/s)[0]); + if($@) + { + die "Internal Error. [$@]\n"; + } + if(!defined($TABLE)) + { + die "Internal Error.\n"; + } + $HEADLEN += 4; + + # load xs. + Unicode::Japanese::load_xs(); + } +} + +# ----------------------------------------------------------------------------- +# _getFile +# load embeded file data. +# +sub _getFile { + my $this = shift; + + my $file = shift; + + exists($TABLE->{$file}) + or die "no such file [$file]\n"; + + #my $offset16 = $TABLE->{$file}{offset} % 16; + #print STDERR "_getFile($file, $TABLE->{$file}{offset}, $TABLE->{$file}{length}, $offset16)\n"; + seek($FH, $PROGLEN + $HEADLEN + $TABLE->{$file}{offset}, 0) + or die "Can't seek $file. [$!]\n"; + + my $data; + read($FH, $data, $TABLE->{$file}{length}) + or die "Can't read $file. [$!]\n"; + + $data; +} + +# ----------------------------------------------------------------------------- +# use_I18N_Japanese +# copy from I18N::Japanese in jperl-5.5.3 +# +sub use_I18N_Japanese +{ + shift; + if( @_ ) + { + my $bits = 0; + foreach( @_ ) + { + $bits |= 0x1000000 if $_ eq 're'; + $bits |= 0x2000000 if $_ eq 'tr'; + $bits |= 0x4000000 if $_ eq 'format'; + $bits |= 0x8000000 if $_ eq 'string'; + } + $^H |= $bits; + }else + { + $^H |= 0x0f00_0000; + } +} + +# ----------------------------------------------------------------------------- +# no_I18N_Japanese +# copy from I18N::Japanese in jperl-5.5.3 +# +sub no_I18N_Japanese +{ + shift; + if( @_ ) + { + my $bits = 0; + foreach( @_ ) + { + $bits |= 0x1000000 if $_ eq 're'; + $bits |= 0x2000000 if $_ eq 'tr'; + $bits |= 0x4000000 if $_ eq 'format'; + $bits |= 0x8000000 if $_ eq 'string'; + } + $^H &= ~$bits; + }else + { + $^H &= ~0x0f00_0000; + } +} + +1; + +=encoding utf-8 + +=head1 NAME + +Unicode::Japanese - Japanese Character Encoding Handler + + +=head1 SYNOPSIS + + use Unicode::Japanese; + use Unicode::Japanese qw(unijp); + + # convert utf8 -> sjis + + print Unicode::Japanese->new($str)->sjis; + print unijp($str)->sjis; # same as avobe. + + # convert sjis -> utf8 + + print Unicode::Japanese->new($str,'sjis')->get; + + # convert sjis (imode_EMOJI) -> utf8 + + print Unicode::Japanese->new($str,'sjis-imode')->get; + + # convert ZENKAKU (utf8) -> HANKAKU (utf8) + + print Unicode::Japanese->new($str)->z2h->get; + +=head1 DESCRIPTION + +Module for conversion among Japanese character encodings. + + +=head2 FEATURES + +=over 2 + +=item * + + + +The instance stores internal strings in UTF-8. + + +=item * + + + +Supports both XS and Non-XS. +Use XS for high performance, +or No-XS for ease to use (only by copying Japanese.pm). + + +=item * + + + +Supports conversion between ZENKAKU and HANKAKU. + + +=item * + + + +Safely handles "EMOJI" of the mobile phones (DoCoMo i-mode, ASTEL dot-i +and J-PHONE J-Sky) by mapping them on Unicode Private Use Area. + + +=item * + + + +Supports conversion of the same image of EMOJI +between different mobile phone's standard mutually. + + +=item * + + + +Considers Shift_JIS(SJIS) as MS-CP932. +(Shift_JIS on MS-Windows (MS-SJIS/MS-CP932) differ from +generic Shift_JIS encodings.) + + +=item * + + + +On converting Unicode to SJIS (and EUC-JP/JIS), those encodings that cannot +be converted to SJIS (except "EMOJI") are escaped in "&#dddd;" format. +"EMOJI" on Unicode Private Use Area is going to be '?'. +When converting strings from Unicode to SJIS of mobile phones, +any characters not up to their standard is going to be '?' + + +=item * + + + +On perl-5.8.0 and later, setting of utf-8 flag is performed properly. +utf8() method returns utf-8 `bytes' string and +getu() method returns utf-8 `char' string. + + +get() method returns utf-8 `bytes' string in current release. +in future, the behavior of get() maybe change. + + +sjis(), jis(), utf8(), etc.. methods return bytes string. +The input of new, set, and a getcode method is not asked about utf8-flaged/bytes. + + +=back + +=head1 METHODS + +=over 4 + +=item $s = Unicode::Japanese->new($str [, $icode [, $encode]]) + +Creates a new instance of Unicode::Japanese. + + +If arguments are specified, passes through to set method. + + +=item unijp($str [, $icode [, $encode]]) + +Same as Unicode::Janaese->new(...). + + +=item $s->set($str [, $icode [, $encode]]) + +=over 2 + +=item $str: string + +=item $icode: character encodings, may be omitted (default = 'utf8') + +=item $encode: ASCII encoding, may be omitted. + +=back + +Set a string in the instance. +If '$icode' is omitted, string is considered as UTF-8. + + +To specify a encodings, choose from the following; +'auto', 'utf8', 'ucs2', 'ucs4', 'utf16-be', 'utf16-le', 'utf16', +'utf32-be', 'utf32-le', 'utf32', 'jis', 'euc', 'euc-jp', +'sjis', 'cp932', 'sjis-imode', 'sjis-imode1', 'sjis-imode2', +'sjis-doti', 'sjis-doti1', 'sjis-jsky', 'sjis-jsky1', 'sjis-jsky2', +'jis-jsky', 'jis-jsky1', 'jis-jsky2', 'jis-au', 'jis-au1', 'jis-au2', +'sjis-au', 'sjis-au1', 'sjis-au2', 'sjis-icon-au', 'sjis-icon-au1', 'sjis-icon-au2', +'euc-icon-au', 'euc-icon-au1', 'euc-icon-au2', 'jis-icon-au', 'jis-icon-au1', 'jis-icon-au2', +'utf8-icon-au', 'utf8-icon-au1', 'utf8-icon-au2', 'ascii', 'binary' + + +For auto encoding detection, you MUST specify 'auto' +so as to call getcode() method automatically. + + +For ASCII encoding, only 'base64' may be specified. +With it, the string will be decoded before storing. + + +To decode binary, specify 'binary' as the encoding. + + +'&#dddd' will be converted to "EMOJI", when specified 'sjis-imode' +or 'sjis-doti'. + + +In some cases, character encoding detection is +misleaded because more than one encodings have +same code points. + + +sjis is returned if a string is valid for both sjis and utf8. +And sjis-au is return if a string is valid for both +sjis-au and sjis-doti. + + +=item $str = $s->get + +=over 2 + +=item $str: string (UTF-8) + +=back + +Gets a string with UTF-8. + + +return `bytes' string in current release, +this behavior will be changed. + + +utf8() method for `character' string or +getu() method for `bytes' string seems better. + + +=item $str = $s->getu + +=over 2 + +=item $str: string (UTF-8) + +=back + +Gets a string with UTF-8. + + +On perl-5.8.0 and later, return value is with utf-8 flag. + + +=item $code = $s->getcode($str) + +=over 2 + +=item $str: string + +=item $code: character encoding name + +=back + +Detects the character encodings of I<$str>. + + +Notice: This method detects B encoding of the string in the instance +but I<$str>. + + +Character encodings are distinguished by the following algorithm: + + +(In case of PurePerl) + + +=over 4 + +=item 1 + + + +If BOM of UTF-32 is found, the encoding is utf32. + + +=item 2 + + + +If BOM of UTF-16 is found, the encoding is utf16. + + +=item 3 + + + +If it is in proper UTF-32BE, the encoding is utf32-be. + + +=item 4 + + + +If it is in proper UTF-32LE, the encoding is utf32-le. + + +=item 5 + + + +Without NON-ASCII characters, the encoding is ascii. +(control codes except escape sequences has been included in ASCII) + + +=item 6 + + + +If it includes ISO-2022-JP(JIS) escape sequences, the encoding is jis. + + +=item 7 + + + +If it includes "J-PHONE EMOJI", the encoding is sjis-sky. + + +=item 8 + + + +If it is in proper EUC-JP, the encoding is euc. + + +=item 9 + + + +If it is in proper SJIS, the encoding is sjis. + + +If it is in proper SJIS and "EMOJI" of au, the encoding is sjis-au. + + +=item 10 + + + +If it is in proper SJIS and "EMOJI" of i-mode, the encoding is sjis-imode. + + +=item 11 + + + +If it is in proper SJIS and "EMOJI" of dot-i,the encoding is sjis-doti. + + +=item 12 + + + +If it is in proper UTF-8, the encoding is utf8. + + +=item 13 + + + +If none above is true, the encoding is unknown. + + +=back + +(In case of XS) + + +=over 4 + +=item 1 + + + +If BOM of UTF-32 is found, the encoding is utf32. + + +=item 2 + + + +If BOM of UTF-16 is found, the encoding is utf16. + + +=item 3 + + + +String is checked by State Transition if it is applicable +for any listed encodings below. + + +ascii / euc-jp / sjis / jis / utf8 / utf32-be / utf32-le / sjis-jsky / +sjis-imode / sjis-au / sjis-doti + + +=item 4 + + + +The listed order below is applied for a final determination. + + +utf32-be / utf32-le / ascii / jis / euc-jp / sjis / sjis-jsky / sjis-imode / +sjis-au / sjis-doti / utf8 + + +=item 5 + + + +If none above is true, the encoding is unknown. + + +=back + +Regarding the algorithm, pay attention to the following: + + +=over 2 + +=item * + + + +UTF-8 is occasionally detected as SJIS. + + +=item * + + + +Can NOT detect UCS2 automatically. + + +=item * + + + +Can detect UTF-16 only when the string has BOM. + + +=item * + + + +Can detect "EMOJI" when it is stored in binary, not in "&#dddd;" +format. (If only stored in "&#dddd;" format, getcode() will +return incorrect result. In that case, "EMOJI" will be crashed.) + + +=back + +Because each of XS and PurePerl has a different algorithm, A result of +the detection would be possibly different. In case that the string is +SJIS with escape characters, it would be considered as SJIS on +PurePerl. However, it can't be detected as S-JIS on XS. This is +because by using Algorithm, the string can't be distinguished between +SJIS and SJIS-Jsky. This exclusion of escape characters on XS from +the detection is suppose to be the same for EUC-JP. + + +=item $code = $s->getcodelist($str) + +=over 2 + +=item $str: string + +=item $code: character encoding name + +=back + +Detects the character encodings of I<$str>. + + +This function returns all acceptable character encodings. + + +=item $str = $s->conv($ocode, $encode) + +This function returns copy of contained string in $ocode encoding. + + +=over 2 + +=item $ocode: output character encoding (Choose from 'utf8', 'euc', 'euc-jp', 'jis', 'sjis', 'cp932', +'sjis-imode', 'sjis-imode1', 'sjis-imode2', 'sjis-doti', 'sjis-doti1', 'sjis-jsky', 'sjis-jsky1', 'sjis-jsky2', +'jis-jsky', 'jis-jsky1', 'jis-jsky2', 'jis-au', 'jis-au1', 'jis-au2', 'sjis-au', 'sjis-au1', 'sjis-au2', +'sjis-icon-au', 'sjis-icon-au1', 'sjis-icon-au2', 'euc-icon-au', 'euc-icon-au1', 'euc-icon-au2', +'jis-icon-au', 'jis-icon-au1', 'jis-icon-au2', 'utf8-icon-au', 'utf8-icon-au1', 'utf8-icon-au2', +'ucs2', 'ucs4', 'utf16', 'binary') + +Number at end of encoding names means emoji set version. +Larger number is newer set. +No number is same as newest set. +Generally you may use without digits. + + +=item $encode: encoding, may be omitted. + +=item $str: string + +=back + +Gets a string converted to I<$ocode>. + + +For ASCII encoding, only 'base64' may be specified. With it, the string +encoded in base64 will be returned. + + +On perl-5.8.0 and later, return value is not with utf-8 flag, and is +bytes string. + + +=item $s->tag2bin + +Replaces the substrings "&#dddd;" in the string with the binary entity +they mean. + + +=item $s->z2h + +Converts ZENKAKU to HANKAKU. + + +=item $s->h2z + +Converts HANKAKU to ZENKAKU. + + +=item $s->hira2kata + +Converts HIRAGANA to KATAKANA. + + +=item $s->kata2hira + +Converts KATAKANA to HIRAGANA. + + +=item $str = $s->jis + +$str: string (JIS) + + +Gets the string converted to ISO-2022-JP(JIS). + + +=item $str = $s->euc + +$str: string (EUC-JP) + + +Gets the string converted to EUC-JP. + + +=item $str = $s->utf8 + +$str: `bytes' string (UTF-8) + + +Gets the string converted to UTF-8. + + +On perl-5.8.0 and later, return value is not with utf-8 flag, and is +bytes string. + + +=item $str = $s->ucs2 + +$str: string (UCS2) + + +Gets the string converted to UCS2. + + +=item $str = $s->ucs4 + +$str: string (UCS4) + + +Gets the string converted to UCS4. + + +=item $str = $s->utf16 + +$str: string (UTF-16) + + +Gets the string converted to UTF-16(big-endian). +BOM is not added. + + +=item $str = $s->sjis + +$str: string (SJIS) + + +Gets the string converted to Shift_JIS(MS-SJIS/MS-CP932). + + +=item $str = $s->sjis_imode + +$str: string (SJIS/imode_EMOJI) + + +Gets the string converted to SJIS for i-mode. +This method is alias of sjis_imode2. + + +=item $str = $s->sjis_imode1 + +$str: string (SJIS/imode_EMOJI) + + +Gets the string converted to SJIS for i-mode. +$str includes only basic pictgraphs, and is without extended pictgraphs. + + +=item $str = $s->sjis_imode2 + +$str: string (SJIS/imode_EMOJI) + + +Gets the string converted to SJIS for i-mode. +$str includes both basic pictgraphs, and extended ones. + + +=item $str = $s->sjis_doti + +$str: string (SJIS/dot-i_EMOJI) + + +Gets the string converted to SJIS for dot-i. + + +=item $str = $s->sjis_jsky + +$str: string (SJIS/J-SKY_EMOJI) + + +Gets the string converted to SJIS for j-sky. +This method is alias of sjis_jsky2 on VERSION 0.15. + + +=item $str = $s->sjis_jsky1 + +$str: string (SJIS/J-SKY_EMOJI) + + +Gets the string converted to SJIS for j-sky. +$str includes from Page 1 to Page 3. + + +=item $str = $s->sjis_jsky + +$str: string (SJIS/J-SKY_EMOJI) + + +Gets the string converted to SJIS for j-sky. +$str includes from Page 1 to Page 6. + + +=item $str = $s->sjis_icon_au + +$str: string (SJIS/AU-ICON-TAG) + + +Gets the string converted to SJIS for au. + + +=item @str = $s->strcut($len) + +=over 2 + +=item $len: number of characters + +=item @str: strings + +=back + +Splits the string by length(I<$len>). + + +On perl-5.8.0 and later, each element in return array +is with utf-8 flag. + + +=item $len = $s->strlen + +$len: `visual width' of the string + + +Gets the length of the string. This method has been offered to +substitute for perl build-in length(). ZENKAKU characters are +assumed to have lengths of 2, regardless of the coding being +SJIS or UTF-8. + + +=item $s->join_csv(@values); + +@values: data array + + +Converts the array to a string in CSV format, then stores into the instance. +In the meantime, adds a newline("\n") at the end of string. + + +=item @values = $s->split_csv; + +@values: data array + + +Splits the string, accounting it is in CSV format. +Each newline("\n") is removed before split. + + +on perl-5.8.0 and later, utf-8 flag of return value depends on +icode of set method. if $s contains binary, return value is bytes +too. if $s contains any string, return value is with utf-8 flag. + + +=back + +=head1 DESCRIPTION OF UNICODE MAPPING + +Translation is proceedede as follows. + + +=over 2 + +=item SJIS + +Mapped as MS-CP932. Mapping table in the following URL is used. + + +ftp://ftp.unicode.org/Public/MAPPINGS/VENDORS/MICSFT/WINDOWS/CP932.TXT + + +If a character cannot be mapped to SJIS from Unicode, +it will be converted to &#dddd; format. +Pictgraphs are converted to "?"; + + +Also, any unmapped character will be converted into "?" when converting +to SJIS for mobile phones. + + +=item EUC-JP/JIS + +Converted to SJIS and then mapped to Unicode. Any non-SJIS character +in the string will not be mapped correctly. + + +=item DoCoMo i-mode + +Portion of involving "EMOJI" in F800 - F9FF is maapped + to U+0FF800 - U+0FF9FF. + + +=item ASTEL dot-i + +Portion of involving "EMOJI" in F000 - F4FF is mapped + to U+0FF000 - U+0FF4FF. + + +=item J-PHONE J-SKY + +"J-SKY EMOJI" are mapped down as follows: "\e\$"(\x1b\x24) escape +sequences, the first byte, the second byte and "\x0f". +With sequential "EMOJI"s of identical first bytes, +it may be compressed by arranging only the second bytes. + + +4500 - 47FF is mapped to U+0FFB00 - U+0FFDFF, accounting the first +and the second bytes make one EMOJI character. + + +Unicode::Japanese will compress "J-SKY_EMOJI" automatically when +the first bytes of a sequence of "EMOJI" are identical. + + +=item AU + +Portion of involving "EMOJI" is mapped to U+0FF500 - U+0FF6FF. + + +=back + +=head1 PurePerl mode + + use Unicode::Japanese qw(PurePerl); + +If module was loaded with 'PurePerl' keyword, +it works on Non-XS mode. + + +=head1 BUGS + +=over 2 + +=item * + + + +EUC-JP, JIS strings cannot be converted correctly when they include +non-SJIS characters because they are converted to SJIS before +being converted to UTF-8. + + +=item * + + + +When using XS, character encoding detection of EUC-JP and +SJIS(included all EMOJI) strings when they include "\e" will +fail. Also, getcode() and all convert method will not work. + + +=item * + + + +The Japanese.pm file will collapse if sent via ASCII mode of FTP, +as it has a trailing binary data. + + +=back + +=head1 AUTHOR INFORMATION + +Copyright 2001-2007 +SANO Taku (SAWATARI Mikage) and YAMASHINA Hio. +All right reserved. + + +This library is free software; you can redistribute it +and/or modify it under the same terms as Perl itself. + + +=head1 BUGS + +Bug reports and comments to: mikage@cpan.org. +Thank you. + + +Or, report any bugs or feature requests to +C, or through the web interface at +L. +I will be notified, and then you'll automatically be notified of progress on +your bug as I make changes. + + +=head1 SUPPORT + +You can find documentation for this module with the perldoc command. + + + perldoc Unicode::Japanese + +You can also look for information at: + + +=over 4 + +=item * AnnoCPAN: Annotated CPAN documentation + +L + + +=item * CPAN Ratings + +L + + +=item * RT: CPAN's request tracker + +L + + +=item * Search CPAN + +L + + +=back + +=head1 CREDITS + +Thanks very much to: + + +NAKAYAMA Nao + + +SUGIURA Tatsuki & Debian JP Project + + +=head1 COPYRIGHT & LICENSE + +Copyright 2001-2007 +SANO Taku (SAWATARI Mikage) and YAMASHINA Hio, +all rights reserved. + + +This program is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + + + +=cut + + + +__DATA__ +{'joinCsv'=>{'length'=>939,'offset'=>0},'_decodeBase64'=>{'length'=>609,'offset'=>939},'z2hNum'=>{'length'=>284,'offset'=>1548},'_utf16le_utf16'=>{'length'=>179,'offset'=>3074},'kata2hira'=>{'length'=>1242,'offset'=>1832},'jcode/emoji2/ea2u.dat'=>{'length'=>1320,'offset'=>372976},'_u2ai2'=>{'length'=>1062,'offset'=>3253},'z2hAlpha'=>{'length'=>836,'offset'=>4315},'_ucs4_utf8'=>{'length'=>936,'offset'=>5151},'h2zSym'=>{'length'=>316,'offset'=>6087},'utf8_icon_au1'=>{'length'=>73,'offset'=>6403},'h2z'=>{'length'=>114,'offset'=>6476},'jcode/emoji2/ea2u2s.dat'=>{'length'=>4096,'offset'=>430848},'sjis'=>{'length'=>177,'offset'=>6590},'euc_icon_au2'=>{'length'=>98,'offset'=>6767},'_u2si1'=>{'length'=>1619,'offset'=>6865},'_sj2u1'=>{'length'=>1144,'offset'=>8484},'euc_icon_au'=>{'length'=>97,'offset'=>9956},'tag2bin'=>{'length'=>328,'offset'=>9628},'z2hSym'=>{'length'=>596,'offset'=>10053},'ucs2'=>{'length'=>183,'offset'=>10649},'jis_au2'=>{'length'=>80,'offset'=>10832},'jcode/emoji2/ei2u2.dat'=>{'length'=>2048,'offset'=>244976},'_si2u1'=>{'length'=>1228,'offset'=>10912},'_utf8_utf16'=>{'length'=>950,'offset'=>12140},'jis_icon_au1'=>{'length'=>98,'offset'=>13090},'sjis_icon_au1'=>{'length'=>86,'offset'=>13188},'sjis_jsky2'=>{'length'=>70,'offset'=>13274},'jcode/emoji2/ei2u.dat'=>{'length'=>2048,'offset'=>226544},'getcode'=>{'length'=>2026,'offset'=>13344},'_j2s2'=>{'length'=>469,'offset'=>15370},'jcode/emoji2/ea2us.dat'=>{'length'=>4096,'offset'=>410368},'sjis_au2'=>{'length'=>95,'offset'=>15839},'h2zKanaD'=>{'length'=>810,'offset'=>15934},'sjis_imode1'=>{'length'=>71,'offset'=>16744},'eucjp'=>{'length'=>32,'offset'=>16815},'utf8'=>{'length'=>187,'offset'=>16847},'_s2e'=>{'length'=>244,'offset'=>17034},'jcode/emoji2/ea2u2.dat'=>{'length'=>3288,'offset'=>390688},'utf8_jsky'=>{'length'=>189,'offset'=>17278},'_uj2u2'=>{'length'=>874,'offset'=>17467},'utf8_jsky1'=>{'length'=>70,'offset'=>18341},'jcode/emoji2/eu2a2.dat'=>{'length'=>16384,'offset'=>393984},'jcode/s2u.dat'=>{'length'=>48573,'offset'=>177968},'conv'=>{'length'=>3663,'offset'=>18411},'_utf16be_utf16'=>{'length'=>71,'offset'=>22074},'jcode/emoji2/eu2j.dat'=>{'length'=>40960,'offset'=>266480},'hira2kata'=>{'length'=>1242,'offset'=>22145},'splitCsvu'=>{'length'=>197,'offset'=>23387},'sjis_doti1'=>{'length'=>69,'offset'=>23584},'_s2j'=>{'length'=>272,'offset'=>23653},'_sa2j2'=>{'length'=>384,'offset'=>23925},'_j2sa'=>{'length'=>179,'offset'=>24309},'sjis_au1'=>{'length'=>95,'offset'=>24488},'join_csv'=>{'length'=>29,'offset'=>24583},'_ai2u1'=>{'length'=>458,'offset'=>24612},'jcode/emoji2/eu2as.dat'=>{'length'=>16384,'offset'=>414464},'_s2u'=>{'length'=>988,'offset'=>25070},'jis_jsky1'=>{'length'=>82,'offset'=>26058},'jis_icon_au2'=>{'length'=>98,'offset'=>26140},'_j2sa3'=>{'length'=>434,'offset'=>26238},'sjis_jsky'=>{'length'=>189,'offset'=>26672},'_u2uj2'=>{'length'=>788,'offset'=>26861},'jis'=>{'length'=>179,'offset'=>27649},'jis_au1'=>{'length'=>80,'offset'=>27828},'_utf8_ucs4'=>{'length'=>1149,'offset'=>27908},'get'=>{'length'=>162,'offset'=>29057},'z2h'=>{'length'=>114,'offset'=>29219},'getu'=>{'length'=>266,'offset'=>29333},'_loadConvTable'=>{'length'=>18009,'offset'=>29599},'unijp'=>{'length'=>137,'offset'=>47608},'_u2uj1'=>{'length'=>806,'offset'=>47745},'jcode/emoji2/eu2a2s.dat'=>{'length'=>16384,'offset'=>434944},'_u2ja1'=>{'length'=>1639,'offset'=>48551},'_j2s'=>{'length'=>177,'offset'=>50190},'utf16'=>{'length'=>187,'offset'=>50367},'utf8_jsky2'=>{'length'=>70,'offset'=>50554},'_u2ai1'=>{'length'=>1203,'offset'=>50624},'sjis_icon_au2'=>{'length'=>86,'offset'=>51827},'_u2si2'=>{'length'=>1620,'offset'=>51913},'jcode/emoji2/eu2i.dat'=>{'length'=>16384,'offset'=>228592},'splitCsv'=>{'length'=>350,'offset'=>53533},'jcode/emoji2/eu2i2.dat'=>{'length'=>16384,'offset'=>247024},'sjis_jsky1'=>{'length'=>70,'offset'=>53883},'_s2j3'=>{'length'=>355,'offset'=>53953},'_sa2u1'=>{'length'=>1137,'offset'=>54308},'_u2s'=>{'length'=>2320,'offset'=>55445},'_sa2j3'=>{'length'=>455,'offset'=>57765},'_utf16_utf8'=>{'length'=>769,'offset'=>58220},'h2zNum'=>{'length'=>174,'offset'=>58989},'h2zKanaK'=>{'length'=>979,'offset'=>59163},'strlen'=>{'length'=>360,'offset'=>60142},'strcutu'=>{'length'=>195,'offset'=>60502},'sjis_imode2'=>{'length'=>71,'offset'=>60697},'_validate_utf8'=>{'length'=>855,'offset'=>60768},'jcode/emoji2/eu2a.dat'=>{'length'=>16384,'offset'=>374304},'set'=>{'length'=>5325,'offset'=>61623},'_ucs2_utf8'=>{'length'=>549,'offset'=>66948},'_utf16_utf16'=>{'length'=>300,'offset'=>67497},'h2zAlpha'=>{'length'=>264,'offset'=>67797},'z2hKanaK'=>{'length'=>979,'offset'=>68061},'getcodelist'=>{'length'=>2241,'offset'=>69040},'_sj2u2'=>{'length'=>1503,'offset'=>71281},'jcode/emoji2/ed2u.dat'=>{'length'=>5120,'offset'=>351472},'jis_icon_au'=>{'length'=>97,'offset'=>72784},'_utf32_ucs4'=>{'length'=>312,'offset'=>72881},'_ai2u2'=>{'length'=>410,'offset'=>73193},'utf8_icon_au2'=>{'length'=>73,'offset'=>73603},'_uj2u1'=>{'length'=>600,'offset'=>73676},'_sa2j'=>{'length'=>174,'offset'=>74276},'h2zKana'=>{'length'=>185,'offset'=>74450},'z2hKana'=>{'length'=>89,'offset'=>74635},'_si2u2'=>{'length'=>1227,'offset'=>74724},'_u2sj1'=>{'length'=>1772,'offset'=>75951},'_u2sj2'=>{'length'=>1794,'offset'=>77723},'utf8_icon_au'=>{'length'=>72,'offset'=>79517},'jis_jsky2'=>{'length'=>82,'offset'=>79589},'sjis_doti'=>{'length'=>188,'offset'=>79671},'_e2s'=>{'length'=>202,'offset'=>79859},'jcode/emoji2/ej2u2.dat'=>{'length'=>3072,'offset'=>307440},'euc'=>{'length'=>175,'offset'=>80061},'_j2s3'=>{'length'=>337,'offset'=>80236},'jcode/emoji2/ej2u.dat'=>{'length'=>3072,'offset'=>263408},'_j2sa2'=>{'length'=>446,'offset'=>80573},'ucs4'=>{'length'=>183,'offset'=>81019},'_sd2u'=>{'length'=>1221,'offset'=>81202},'_u2ja2'=>{'length'=>1640,'offset'=>82423},'_s2e2'=>{'length'=>446,'offset'=>84063},'z2hKanaD'=>{'length'=>498,'offset'=>84509},'_u2sd'=>{'length'=>1615,'offset'=>85007},'sjis_au'=>{'length'=>94,'offset'=>86622},'jcode/emoji2/eu2j2.dat'=>{'length'=>40960,'offset'=>310512},'jcode/emoji2/eu2d.dat'=>{'length'=>16384,'offset'=>356592},'jcode/u2s.dat'=>{'length'=>85504,'offset'=>92464},'_utf8_ucs2'=>{'length'=>755,'offset'=>86716},'euc_icon_au1'=>{'length'=>98,'offset'=>87471},'jis_au'=>{'length'=>195,'offset'=>87569},'_utf32le_ucs4'=>{'length'=>178,'offset'=>87764},'sjis_imode'=>{'length'=>192,'offset'=>87942},'_e2s2'=>{'length'=>535,'offset'=>88134},'_s2j2'=>{'length'=>377,'offset'=>88669},'_encodeBase64'=>{'length'=>741,'offset'=>89046},'validate_utf8'=>{'length'=>129,'offset'=>89787},'sjis_icon_au'=>{'length'=>85,'offset'=>89916},'split_csv'=>{'length'=>131,'offset'=>90001},'_sa2u2'=>{'length'=>1138,'offset'=>90132},'jis_jsky'=>{'length'=>200,'offset'=>91270},'strcut'=>{'length'=>888,'offset'=>91470},'cp932'=>{'length'=>33,'offset'=>92358},'_utf32be_ucs4'=>{'length'=>70,'offset'=>92391}} sub joinCsv { + my $this = shift; + my $list; + + if(ref($_[0]) eq 'ARRAY') + { + $list = shift; + if( $]>=5.008 ) + { + $list = [ @$list ]; + foreach(@$list) + { + defined($_) and Encode::_utf8_off($_); + } + } + } + elsif(!ref($_[0])) + { + $list = [ @_ ]; + if( $]>=5.008 ) + { + foreach(@$list) + { + defined($_) and Encode::_utf8_off($_); + } + } + } + else + { + my $ref = ref($_[0]); + die "String->joinCsv, Param[1] is not ARRAY/ARRRAY-ref. [$ref]\n"; + } + + my $text; + if( $^W && grep{!defined($_)}@$list ) + { + $_[0] && $list eq $_[0] and $list = [@$list]; + foreach(@$list) + { + defined($_) and next; + warn "Use of uninitialized value in Unicode::Japanese::joinCsv"; + $_ = ""; + } + } + $text = join ',', map {defined($_) ? (s/"/""/g or /[\r\n,]/) ? qq("$_") : $_ : ""} @$list; + + $this->{str} = $text."\n"; + $this->{icode} = 'binary'; + + $this; +} +sub _decodeBase64 +{ + local($^W) = 0; # unpack("u",...) gives bogus warning in 5.00[123] + + my $this = shift; + my $str = shift; + my $res = ""; + + $str =~ tr|A-Za-z0-9+=/||cd; # remove non-base64 chars + if (length($str) % 4) + { + warn("Length of base64 data not a multiple of 4"); + } + $str =~ s/=+$//; # remove padding + $str =~ tr|A-Za-z0-9+/| -_|; # convert to uuencoded format + while ($str =~ /(.{1,60})/gs) + { + my $len = chr(32 + length($1)*3/4); # compute length byte + $res .= unpack("u", $len . $1 ); # uudecode + } + $res; +} +sub z2hNum { + my $this = shift; + + if(!defined(%_z2hNum)) + { + $this->_loadConvTable; + } + + $this->{str} =~ s/(\xef\xbc\x90|\xef\xbc\x91|\xef\xbc\x92|\xef\xbc\x93|\xef\xbc\x94|\xef\xbc\x95|\xef\xbc\x96|\xef\xbc\x97|\xef\xbc\x98|\xef\xbc\x99)/$_z2hNum{$1}/eg; + + $this; +} +sub kata2hira { + my $this = shift; + + if(!defined(%_kata2hira)) + { + $this->_loadConvTable; + } + + $this->{str} =~ s/(\xe3\x82\xa1|\xe3\x82\xa2|\xe3\x82\xa3|\xe3\x82\xa4|\xe3\x82\xa5|\xe3\x82\xa6|\xe3\x82\xa7|\xe3\x82\xa8|\xe3\x82\xa9|\xe3\x82\xaa|\xe3\x82\xab|\xe3\x82\xac|\xe3\x82\xad|\xe3\x82\xae|\xe3\x82\xaf|\xe3\x82\xb0|\xe3\x82\xb1|\xe3\x82\xb2|\xe3\x82\xb3|\xe3\x82\xb4|\xe3\x82\xb5|\xe3\x82\xb6|\xe3\x82\xb7|\xe3\x82\xb8|\xe3\x82\xb9|\xe3\x82\xba|\xe3\x82\xbb|\xe3\x82\xbc|\xe3\x82\xbd|\xe3\x82\xbe|\xe3\x82\xbf|\xe3\x83\x80|\xe3\x83\x81|\xe3\x83\x82|\xe3\x83\x83|\xe3\x83\x84|\xe3\x83\x85|\xe3\x83\x86|\xe3\x83\x87|\xe3\x83\x88|\xe3\x83\x89|\xe3\x83\x8a|\xe3\x83\x8b|\xe3\x83\x8c|\xe3\x83\x8d|\xe3\x83\x8e|\xe3\x83\x8f|\xe3\x83\x90|\xe3\x83\x91|\xe3\x83\x92|\xe3\x83\x93|\xe3\x83\x94|\xe3\x83\x95|\xe3\x83\x96|\xe3\x83\x97|\xe3\x83\x98|\xe3\x83\x99|\xe3\x83\x9a|\xe3\x83\x9b|\xe3\x83\x9c|\xe3\x83\x9d|\xe3\x83\x9e|\xe3\x83\x9f|\xe3\x83\xa0|\xe3\x83\xa1|\xe3\x83\xa2|\xe3\x83\xa3|\xe3\x83\xa4|\xe3\x83\xa5|\xe3\x83\xa6|\xe3\x83\xa7|\xe3\x83\xa8|\xe3\x83\xa9|\xe3\x83\xaa|\xe3\x83\xab|\xe3\x83\xac|\xe3\x83\xad|\xe3\x83\xae|\xe3\x83\xaf|\xe3\x83\xb0|\xe3\x83\xb1|\xe3\x83\xb2|\xe3\x83\xb3)/$_kata2hira{$1}/eg; + + $this; +} +sub _utf16le_utf16 { + my $this = shift; + my $str = shift; + + my $result = ''; + foreach my $ch (unpack('v*', $str)) + { + $result .= pack('n', $ch); + } + + $result; +} +sub _u2ai2 { + my $this = shift; + my $str = shift; + + if(!defined($str)) + { + return ''; + } + + if(!defined($eu2a2)) + { + $eu2a2 = $this->_getFile('jcode/emoji2/eu2a2.dat'); + } + + my $c1; + my $c2; + my $c3; + my $c4; + my $c5; + my $c6; + my $c; + my $d; + my $ch; + $str =~ s/([\xc0-\xdf][\x80-\xbf]|[\xe0-\xef][\x80-\xbf]{2}|[\xf0-\xf7][\x80-\xbf]{3}|[\xf8-\xfb][\x80-\xbf]{4}|[\xfc-\xfd][\x80-\xbf]{5})|([^\x00-\x7f])/ + defined($2) ? '?' : + ((length($1) == 1) ? $1 : + (length($1) == 2) ? $1 : + (length($1) == 3) ? $1 : + (length($1) == 4) ? ( + ($c1,$c2,$c3,$c4) = unpack("C4", $1), + $ch = (($c1 & 0x07)<<18)|(($c2 & 0x3F)<<12)| + (($c3 & 0x3f) << 6)|($c4 & 0x3F), + ( + ($ch >= 0x0fe000 and $ch <= 0x0fffff) ? + ( + $c = substr($eu2a2, ($ch - 0x0fe000) * 2, 2), + $d = unpack('n', $c), + $c =~ tr,\0,,d, + ($d <= 0x0336) ? $RE{E_ICON_AU_START} . $d . $RE{E_ICON_AU_END} : + ($c eq '') ? '?' : $c + ) : + '?' + ) + ) : + '?' + ) + /eg; + + $str; +} +sub z2hAlpha { + my $this = shift; + + if(!defined(%_z2hAlpha)) + { + $this->_loadConvTable; + } + + $this->{str} =~ s/(\xef\xbc\xa1|\xef\xbc\xa2|\xef\xbc\xa3|\xef\xbc\xa4|\xef\xbc\xa5|\xef\xbc\xa6|\xef\xbc\xa7|\xef\xbc\xa8|\xef\xbc\xa9|\xef\xbc\xaa|\xef\xbc\xab|\xef\xbc\xac|\xef\xbc\xad|\xef\xbc\xae|\xef\xbc\xaf|\xef\xbc\xb0|\xef\xbc\xb1|\xef\xbc\xb2|\xef\xbc\xb3|\xef\xbc\xb4|\xef\xbc\xb5|\xef\xbc\xb6|\xef\xbc\xb7|\xef\xbc\xb8|\xef\xbc\xb9|\xef\xbc\xba|\xef\xbd\x81|\xef\xbd\x82|\xef\xbd\x83|\xef\xbd\x84|\xef\xbd\x85|\xef\xbd\x86|\xef\xbd\x87|\xef\xbd\x88|\xef\xbd\x89|\xef\xbd\x8a|\xef\xbd\x8b|\xef\xbd\x8c|\xef\xbd\x8d|\xef\xbd\x8e|\xef\xbd\x8f|\xef\xbd\x90|\xef\xbd\x91|\xef\xbd\x92|\xef\xbd\x93|\xef\xbd\x94|\xef\xbd\x95|\xef\xbd\x96|\xef\xbd\x97|\xef\xbd\x98|\xef\xbd\x99|\xef\xbd\x9a)/$_z2hAlpha{$1}/eg; + + $this; +} +sub _ucs4_utf8 { + my $this = shift; + my $str = shift; + + if(!defined($str)) + { + return ''; + } + + my $result = ''; + for my $uc (unpack("N*", $str)) + { + $result .= ($uc < 0x80) ? chr($uc) : + ($uc < 0x800) ? chr(0xC0 | ($uc >> 6)) . chr(0x80 | ($uc & 0x3F)) : + ($uc < 0x10000) ? chr(0xE0 | ($uc >> 12)) . chr(0x80 | (($uc >> 6) & 0x3F)) . chr(0x80 | ($uc & 0x3F)) : + ($uc < 0x200000) ? chr(0xF0 | ($uc >> 18)) . chr(0x80 | (($uc >> 12) & 0x3F)) . chr(0x80 | (($uc >> 6) & 0x3F)) . chr(0x80 | ($uc & 0x3F)) : + ($uc < 0x4000000) ? chr(0xF8 | ($uc >> 24)) . chr(0x80 | (($uc >> 18) & 0x3F)) . chr(0x80 | (($uc >> 12) & 0x3F)) . chr(0x80 | (($uc >> 6) & 0x3F)) . chr(0x80 | ($uc & 0x3F)) : + chr(0xFC | ($uc >> 30)) . chr(0x80 | (($uc >> 24) & 0x3F)) . chr(0x80 | (($uc >> 18) & 0x3F)) . chr(0x80 | (($uc >> 12) & 0x3F)) . chr(0x80 | (($uc >> 6) & 0x3F)) . chr(0x80 | ($uc & 0x3F)); + } + + $result; +} +sub h2zSym { + my $this = shift; + + if(!defined(%_h2zSym)) + { + $this->_loadConvTable; + } + + $this->{str} =~ s/(\x20|\x21|\x22|\x23|\x24|\x25|\x26|\x27|\x28|\x29|\x2a|\x2b|\x2c|\x2d|\x2e|\x2f|\x3a|\x3b|\x3c|\x3d|\x3e|\x3f|\x40|\x5b|\x5c|\x5d|\x5e|_|\x60|\x7b|\x7c|\x7d|\x7e)/$_h2zSym{$1}/eg; + + $this; +} +sub utf8_icon_au1 +{ + my $this = shift; + $this->_u2ai1($this->{str}); +} +sub h2z { + my $this = shift; + + $this->h2zKana; + $this->h2zNum; + $this->h2zAlpha; + $this->h2zSym; + + $this; +} +# ----------------------------------------------------------------------------- +# $bytes_sjis = $unijp->sjis(); +# +sub sjis +{ + my $this = shift; + $this->_u2s($this->{str}); +} +sub euc_icon_au2 +{ + my $this = shift; + $this->_s2e($this->_u2s($this->_u2ai2($this->{str}))); +} +sub _u2si1 { + my $this = shift; + my $str = shift; + + if(!defined($str)) + { + return ''; + } + + if(!defined($u2s_table)) + { + $u2s_table = $this->_getFile('jcode/u2s.dat'); + } + + if(!defined($eu2i1)) + { + $eu2i1 = $this->_getFile('jcode/emoji2/eu2i.dat'); + } + + my $c1; + my $c2; + my $c3; + my $c4; + my $c5; + my $c6; + my $c; + my $ch; + $str =~ s/([\xc0-\xdf][\x80-\xbf]|[\xe0-\xef][\x80-\xbf]{2}|[\xf0-\xf7][\x80-\xbf]{3}|[\xf8-\xfb][\x80-\xbf]{4}|[\xfc-\xfd][\x80-\xbf]{5})|([^\x00-\x7f])/ + defined($2) ? '?' : + ((length($1) == 1) ? $1 : + (length($1) == 2) ? ( + ($c1,$c2) = unpack("C2", $1), + $ch = (($c1 & 0x1F)<<6)|($c2 & 0x3F), + $c = substr($u2s_table, $ch * 2, 2), + ($c eq "\0\0") ? '?' : $c + ) : + (length($1) == 3) ? ( + ($c1,$c2,$c3) = unpack("C3", $1), + $ch = (($c1 & 0x0F)<<12)|(($c2 & 0x3F)<<6)|($c3 & 0x3F), + ( + ($ch <= 0x9fff) ? + $c = substr($u2s_table, $ch * 2, 2) : + ($ch >= 0xf900 and $ch <= 0xffff) ? + ( + $c = substr($u2s_table, ($ch - 0xf900 + 0xa000) * 2, 2), + (($c =~ tr,\0,,d)==2 and $c = "\0\0"), + ) : + ( + $c = '?' + ) + ), + ($c eq "\0\0") ? '?' : $c + ) : + (length($1) == 4) ? ( + ($c1,$c2,$c3,$c4) = unpack("C4", $1), + $ch = (($c1 & 0x07)<<18)|(($c2 & 0x3F)<<12)| + (($c3 & 0x3f) << 6)|($c4 & 0x3F), + ( + ($ch >= 0x0fe000 and $ch <= 0x0fffff) ? + ( + $c = substr($eu2i1, ($ch - 0x0fe000) * 2, 2), + $c =~ tr,\0,,d, + ($c eq '') ? '?' : $c + ) : + '?' + ) + ) : + '?' + ) + /eg; + $str; + +} +sub _sj2u1 { + my $this = shift; + my $str = shift; + + if(!defined($str)) + { + return ''; + } + + if(!defined($s2u_table)) + { + $s2u_table = $this->_getFile('jcode/s2u.dat'); + } + + if(!defined($ej2u1)) + { + $ej2u1 = $this->_getFile('jcode/emoji2/ej2u.dat'); + } + + my $l; + my $j1; + my $uc; + $str =~ s/($RE{SJIS_KANA}|$RE{SJIS_DBCS}|$RE{E_JSKYv1}|[\x80-\xff])/ + (length($1) <= 2) ? + ( + $l = (unpack('n', $1) or unpack('C', $1)), + ( + ($l >= 0xa1 and $l <= 0xdf) ? + ( + $uc = substr($s2u_table, ($l - 0xa1) * 3, 3), + $uc =~ tr,\0,,d, + $uc + ) : + ($l >= 0x8100 and $l <= 0x9fff) ? + ( + $uc = substr($s2u_table, ($l - 0x8100 + 0x3f) * 3, 3), + $uc =~ tr,\0,,d, + $uc + ) : + ($l >= 0xe000 and $l <= 0xffff) ? + ( + $uc = substr($s2u_table, ($l - 0xe000 + 0x1f3f) * 3, 3), + $uc =~ tr,\0,,d, + $uc + ) : + ($l < 0x80) ? + chr($l) : + '?' + ) + ) : + ( + $l = $1, + $l =~ s,^$RE{E_JSKY_START}($RE{E_JSKY1v1}),,o, + $j1 = $1, + $uc = '', + $l =~ s!($RE{E_JSKY2})!$uc .= substr($ej2u1, (unpack('n', $j1 . $1) - 0x4500) * 4, 4), ''!ego, + $uc =~ tr,\0,,d, + $uc + ) + /eg; + + $str; + +} +# ----------------------------------------------------------------------------- +# tag2bin +# +sub tag2bin { + my $this = shift; + + $this->{str} =~ s/\&(\#\d+|\#x[a-f0-9A-F]+);/ + (substr($1, 1, 1) eq 'x') ? $this->_ucs4_utf8(pack('N', hex(substr($1, 2)))) : + $this->_ucs4_utf8(pack('N', substr($1, 1))) + /eg; + + $this; +} +sub euc_icon_au +{ + my $this = shift; + $this->_s2e($this->_u2s($this->_u2ai2($this->{str}))); +} +sub z2hSym { + my $this = shift; + + if(!defined(%_z2hSym)) + { + $this->_loadConvTable; + } + + $this->{str} =~ s/(\xe3\x80\x80|\xef\xbc\x8c|\xef\xbc\x8e|\xef\xbc\x9a|\xef\xbc\x9b|\xef\xbc\x9f|\xef\xbc\x81|\xef\xbd\x80|\xef\xbc\xbe|\xef\xbc\xbf|\xef\xbc\x8f|\xef\xbd\x9e|\xef\xbd\x9c|\xe2\x80\x99|\xe2\x80\x9d|\xef\xbc\x88|\xef\xbc\x89|\xef\xbc\xbb|\xef\xbc\xbd|\xef\xbd\x9b|\xef\xbd\x9d|\xef\xbc\x8b|\xef\xbc\x8d|\xef\xbc\x9d|\xef\xbc\x9c|\xef\xbc\x9e|\xef\xbf\xa5|\xef\xbc\x84|\xef\xbc\x85|\xef\xbc\x83|\xef\xbc\x86|\xef\xbc\x8a|\xef\xbc\xa0|\xe3\x80\x9c)/$_z2hSym{$1}/eg; + + $this; +} +# ----------------------------------------------------------------------------- +# $bytes_ucs2 = $unijp->ucs2(); +# +sub ucs2 +{ + my $this = shift; + $this->_utf8_ucs2($this->{str}); +} +sub jis_au2 +{ + my $this = shift; + $this->_s2j($this->_u2ja2($this->{str})); +} +sub _si2u1 { + my $this = shift; + my $str = shift; + + if(!defined($str)) + { + return ''; + } + + if(!defined($s2u_table)) + { + $s2u_table = $this->_getFile('jcode/s2u.dat'); + } + + if(!defined($ei2u1)) + { + $ei2u1 = $this->_getFile('jcode/emoji2/ei2u.dat'); + } + + $str =~ s/(\&\#(\d+);)/ + ($2 >= 0xf800 and $2 <= 0xf9ff) ? pack('n', $2) : $1 + /eg; + + my $l; + my $uc; + $str =~ s/($RE{SJIS_KANA}|$RE{SJIS_DBCS}|$RE{E_IMODEv1}|[\x80-\xff])/ + $S2U{$1} + or ($S2U{$1} = + ( + $l = (unpack('n', $1) or unpack('C', $1)), + ( + ($l >= 0xa1 and $l <= 0xdf) ? + ( + $uc = substr($s2u_table, ($l - 0xa1) * 3, 3), + $uc =~ tr,\0,,d, + $uc + ) : + ($l >= 0x8100 and $l <= 0x9fff) ? + ( + $uc = substr($s2u_table, ($l - 0x8100 + 0x3f) * 3, 3), + $uc =~ tr,\0,,d, + $uc + ) : + ($l >= 0xf800 and $l <= 0xf9ff) ? + ( + $uc = substr($ei2u1, ($l - 0xf800) * 4, 4), + $uc =~ tr,\0,,d, + $uc + ) : + ($l >= 0xe000 and $l <= 0xffff) ? + ( + $uc = substr($s2u_table, ($l - 0xe000 + 0x1f3f) * 3, 3), + $uc =~ tr,\0,,d, + $uc + ) : + ($l < 0x80) ? + chr($l) : + '?' + ) + ) + )/eg; + + $str; + +} +sub _utf8_utf16 { + my $this = shift; + my $str = shift; + + if(!defined($str)) + { + return ''; + } + + my $c1; + my $c2; + my $c3; + my $c4; + my $uc; + $str =~ s/([\x00-\x7f]|[\xc0-\xdf][\x80-\xbf]|[\xe0-\xef][\x80-\xbf]{2}|[\xf0-\xf7][\x80-\xbf]{3}|[\xf8-\xfb][\x80-\xbf]{4}|[\xfc-\xfd][\x80-\xbf]{5})/ + $T2U{$1} + or ($T2U{$1} + = ((length($1) == 1) ? pack("n", unpack("C", $1)) : + (length($1) == 2) ? (($c1,$c2) = unpack("C2", $1), + pack("n", (($c1 & 0x1F)<<6)|($c2 & 0x3F))) : + (length($1) == 3) ? (($c1,$c2,$c3) = unpack("C3", $1), + pack("n", (($c1 & 0x0F)<<12)|(($c2 & 0x3F)<<6)|($c3 & 0x3F))) : + (length($1) == 4) ? (($c1,$c2,$c3,$c4) = unpack("C4", $1), + ($uc = ((($c1 & 0x07) << 18)|(($c2 & 0x3F) << 12)| + (($c3 & 0x3f) << 6)|($c4 & 0x3F)) - 0x10000), + (($uc < 0x100000) ? pack("nn", (($uc >> 10) | 0xd800), (($uc & 0x3ff) | 0xdc00)) : "\0?")) : + "\0?") + ); + /eg; + $str; +} +sub jis_icon_au1 +{ + my $this = shift; + $this->_s2j($this->_u2s($this->_u2ai1($this->{str}))); +} +sub sjis_icon_au1 +{ + my $this = shift; + $this->_u2s($this->_u2ai1($this->{str})); +} +sub sjis_jsky2 +{ + my $this = shift; + $this->_u2sj2($this->{str}); +} +# ----------------------------------------------------------------------------- +# $code = Unicode::Japanese->getcode($str); +# +sub getcode { + my $this = shift; + my $str = shift; + + if( $]>=5.008 ) + { + Encode::_utf8_off($str); + } + + my $l = length($str); + + if((($l % 4) == 0) + and ($str =~ m/^(?:$RE{BOM4_BE}|$RE{BOM4_LE})/o)) + { + return 'utf32'; + } + if((($l % 2) == 0) + and ($str =~ m/^(?:$RE{BOM2_BE}|$RE{BOM2_LE})/o)) + { + return 'utf16'; + } + + my $str2; + + if(($l % 4) == 0) + { + $str2 = $str; + 1 while($str2 =~ s/^(?:$RE{UTF32_BE})//o); + if($str2 eq '') + { + return 'utf32-be'; + } + + $str2 = $str; + 1 while($str2 =~ s/^(?:$RE{UTF32_LE})//o); + if($str2 eq '') + { + return 'utf32-le'; + } + } + + if($str !~ m/[\e\x80-\xff]/) + { + return 'ascii'; + } + + if($str =~ m/$RE{JIS_0208}|$RE{JIS_0212}|$RE{JIS_ASC}|$RE{JIS_KANA}/o) + { + if($str =~ m/(?:$RE{JIS_0208})(?:[^\e]{2})*$RE{E_JIS_AU}/o) + { + return 'jis-au'; + } + elsif($str =~ m/(?:$RE{E_JSKY})/o) + { + return 'jis-jsky'; + } + else + { + return 'jis'; + } + } + + if($str =~ m/(?:$RE{E_JSKY})/o) + { + return 'sjis-jsky'; + } + + $str2 = $str; + 1 while($str2 =~ s/^(?:$RE{ASCII}|$RE{EUC_0212}|$RE{EUC_KANA}|$RE{EUC_C})//o); + if($str2 eq '') + { + return 'euc'; + } + + $str2 = $str; + 1 while($str2 =~ s/^(?:$RE{ASCII}|$RE{SJIS_DBCS}|$RE{SJIS_KANA})//o); + if($str2 eq '') + { + return 'sjis'; + } + if($str =~ m/^(?:$RE{E_SJIS_AU})/o) + { + return 'sjis-au'; + } + + + my $str3; + $str3 = $str2; + 1 while($str3 =~ s/^(?:$RE{ASCII}|$RE{SJIS_DBCS}|$RE{SJIS_KANA}|$RE{E_IMODE})//o); + if($str3 eq '') + { + return 'sjis-imode'; + } + + $str3 = $str2; + 1 while($str3 =~ s/^(?:$RE{ASCII}|$RE{SJIS_DBCS}|$RE{SJIS_KANA}|$RE{E_DOTI})//o); + if($str3 eq '') + { + return 'sjis-doti'; + } + + $str2 = $str; + 1 while($str2 =~ s/^(?:$RE{UTF8})//o); + if($str2 eq '') + { + return 'utf8'; + } + + return 'unknown'; +} +sub _j2s2 { + my $this = shift; + my $esc = shift; + my $str = shift; + + if($esc eq $ESC{JIS_0212}) + { + $str =~ s/../$CHARCODE{UNDEF_SJIS}/g; + } + elsif($esc !~ m/^$RE{JIS_ASC}/) + { + $str =~ s{([\x21-\x7e]+)}{ + my $str = $1; + $str =~ tr/\x21-\x7e/\xa1-\xfe/; + if($esc =~ m/^$RE{JIS_0208}/) + { + $str =~ s/($RE{EUC_C})/ + $J2S[unpack('n', $1)] or $this->_j2s3($1) + /geo; + } + $str; + }e; + } + + $str; +} +sub sjis_au2 +{ + my $this = shift; + $this->_j2sa($this->_s2j($this->_u2ja2($this->{str}))); +} +sub h2zKanaD { + my $this = shift; + + if(!defined(%_h2zKanaD)) + { + $this->_loadConvTable; + } + + $this->{str} =~ s/(\xef\xbd\xb3\xef\xbe\x9e|\xef\xbd\xb6\xef\xbe\x9e|\xef\xbd\xb7\xef\xbe\x9e|\xef\xbd\xb8\xef\xbe\x9e|\xef\xbd\xb9\xef\xbe\x9e|\xef\xbd\xba\xef\xbe\x9e|\xef\xbd\xbb\xef\xbe\x9e|\xef\xbd\xbc\xef\xbe\x9e|\xef\xbd\xbd\xef\xbe\x9e|\xef\xbd\xbe\xef\xbe\x9e|\xef\xbd\xbf\xef\xbe\x9e|\xef\xbe\x80\xef\xbe\x9e|\xef\xbe\x81\xef\xbe\x9e|\xef\xbe\x82\xef\xbe\x9e|\xef\xbe\x83\xef\xbe\x9e|\xef\xbe\x84\xef\xbe\x9e|\xef\xbe\x8a\xef\xbe\x9e|\xef\xbe\x8a\xef\xbe\x9f|\xef\xbe\x8b\xef\xbe\x9e|\xef\xbe\x8b\xef\xbe\x9f|\xef\xbe\x8c\xef\xbe\x9e|\xef\xbe\x8c\xef\xbe\x9f|\xef\xbe\x8d\xef\xbe\x9e|\xef\xbe\x8d\xef\xbe\x9f|\xef\xbe\x8e\xef\xbe\x9e|\xef\xbe\x8e\xef\xbe\x9f)/$_h2zKanaD{$1}/eg; + + $this; +} +sub sjis_imode1 +{ + my $this = shift; + $this->_u2si1($this->{str}); +} +sub eucjp +{ + shift->euc(@_); +} +# ----------------------------------------------------------------------------- +# $bytes_utf8 = $unijp->utf8(); +# +sub utf8 +{ + my $this = shift; + $this->_validate_utf8($this->{str}); +} +sub _s2e { + my $this = shift; + my $str = shift; + + if( $]>=5.008 ) + { + Encode::_utf8_off($str); + } + + $str =~ s/($RE{SJIS_DBCS}|$RE{SJIS_KANA})/ + $S2E[unpack('n', $1) or unpack('C', $1)] or $this->_s2e2($1) + /geo; + + $str; +} +# ----------------------------------------------------------------------------- +# $bytes_utf8 = $unijp->utf8_jsky(); +# +sub utf8_jsky +{ + my $this = shift; + $this->_u2uj2($this->{str}); +} +# utf8-jsky2 => utf8. +sub _uj2u2 { + my $this = shift; + my $str = shift; + + if(!defined($str)) + { + return ''; + } + + if(!defined($s2u_table)) + { + $s2u_table = $this->_getFile('jcode/s2u.dat'); + } + + if(!defined($ej2u1)) + { + $ej2u1 = $this->_getFile('jcode/emoji2/ej2u.dat'); + } + if(!defined($ej2u2)) + { + $ej2u2 = $this->_getFile('jcode/emoji2/ej2u2.dat'); + } + + $str = $this->_validate_utf8($str); + + my @umap = (0x200, 0x000, 0x100); + $str =~ s{($RE{E_JSKYv1_UTF8}+)}{ + join('', + map{ + my $l = $_ - 0xe000; + substr($ej2u1, ($umap[$l/256]+($l&255)+0x20) * 4, 4); + } unpack("n*", $this->_utf8_ucs2($1)) + ) + }geo; + $str =~ s{($RE{E_JSKYv2_UTF8}+)}{ + join('', + map{ + my $l = $_ - 0xe300 + 0x20; + substr($ej2u2, $l * 4, 4); + } unpack("n*", $this->_utf8_ucs2($1)) + ) + }geo; + + $str; + +} +sub utf8_jsky1 +{ + my $this = shift; + $this->_u2uj1($this->{str}); +} +# ----------------------------------------------------------------------------- +# $bytes_str = $unijp->conv($ocode,[$encode]); +# +sub conv { + my $this = shift; + my $ocode = shift; + my $encode = shift; + my (@option) = @_; + + my $res; + if(!defined($ocode)) + { + use Carp; + croak(qq(String->conv, Param[1] is undef.)); + } + elsif($ocode eq 'utf8') + { + $res = $this->utf8; + } + elsif($ocode eq 'euc' || $ocode eq 'euc-jp' ) + { + $res = $this->euc; + } + elsif($ocode eq 'jis') + { + $res = $this->jis; + } + elsif($ocode eq 'sjis' || $ocode eq 'cp932') + { + $res = $this->sjis; + } + elsif($ocode eq 'sjis-imode') + { + $res = $this->sjis_imode; + } + elsif($ocode eq 'sjis-imode1') + { + $res = $this->sjis_imode1; + } + elsif($ocode eq 'sjis-imode2') + { + $res = $this->sjis_imode2; + } + elsif($ocode eq 'sjis-doti') + { + $res = $this->sjis_doti; + } + elsif($ocode eq 'sjis-doti1') + { + $res = $this->sjis_doti; + } + elsif($ocode eq 'sjis-jsky') + { + $res = $this->sjis_jsky; + } + elsif($ocode eq 'sjis-jsky1') + { + $res = $this->sjis_jsky1; + } + elsif($ocode eq 'sjis-jsky2') + { + $res = $this->sjis_jsky2; + } + elsif($ocode eq 'jis-jsky') + { + $res = $this->jis_jsky; + } + elsif($ocode eq 'jis-jsky1') + { + $res = $this->jis_jsky1; + } + elsif($ocode eq 'jis-jsky2') + { + $res = $this->jis_jsky2; + } + elsif($ocode eq 'utf8-jsky') + { + $res = $this->utf8_jsky; + } + elsif($ocode eq 'utf8-jsky1') + { + $res = $this->utf8_jsky1; + } + elsif($ocode eq 'utf8-jsky2') + { + $res = $this->utf8_jsky2; + } + elsif($ocode eq 'jis-au') + { + $res = $this->jis_au2; + } + elsif($ocode eq 'jis-au1') + { + $res = $this->jis_au1; + } + elsif($ocode eq 'jis-au2') + { + $res = $this->jis_au2; + } + elsif($ocode eq 'sjis-au') + { + $res = $this->sjis_au2; + } + elsif($ocode eq 'sjis-au1') + { + $res = $this->sjis_au1; + } + elsif($ocode eq 'sjis-au2') + { + $res = $this->sjis_au2; + } + elsif($ocode eq 'sjis-icon-au') + { + $res = $this->sjis_icon_au2; + } + elsif($ocode eq 'sjis-icon-au1') + { + $res = $this->sjis_icon_au1; + } + elsif($ocode eq 'sjis-icon-au2') + { + $res = $this->sjis_icon_au2; + } + elsif($ocode eq 'jis-icon-au') + { + $res = $this->jis_icon_au2; + } + elsif($ocode eq 'jis-icon-au1') + { + $res = $this->jis_icon_au1; + } + elsif($ocode eq 'jis-icon-au2') + { + $res = $this->jis_icon_au2; + } + elsif($ocode eq 'euc-icon-au') + { + $res = $this->euc_icon_au2; + } + elsif($ocode eq 'euc-icon-au1') + { + $res = $this->euc_icon_au1; + } + elsif($ocode eq 'euc-icon-au2') + { + $res = $this->euc_icon_au2; + } + elsif($ocode eq 'utf8-icon-au') + { + $res = $this->utf8_icon_au2; + } + elsif($ocode eq 'utf8-icon-au1') + { + $res = $this->utf8_icon_au1; + } + elsif($ocode eq 'utf8-icon-au2') + { + $res = $this->utf8_icon_au2; + } + elsif($ocode eq 'ucs2') + { + $res = $this->ucs2; + } + elsif($ocode eq 'ucs4') + { + $res = $this->ucs4; + } + elsif($ocode eq 'utf16') + { + $res = $this->utf16; + } + elsif($ocode eq 'binary') + { + $res = $this->{str}; + } + else + { + use Carp; + croak(qq(String->conv, Param[1] "$ocode" is error.)); + } + + if(defined($encode)) + { + if($encode eq 'base64') + { + $res = $this->_encodeBase64($res, @option); + } + else + { + use Carp; + croak(qq(String->conv, Param[2] "$encode" encode name error.)); + } + } + + $res; +} +sub _utf16be_utf16 { + my $this = shift; + my $str = shift; + + $str; +} +sub hira2kata { + my $this = shift; + + if(!defined(%_hira2kata)) + { + $this->_loadConvTable; + } + + $this->{str} =~ s/(\xe3\x81\x81|\xe3\x81\x82|\xe3\x81\x83|\xe3\x81\x84|\xe3\x81\x85|\xe3\x81\x86|\xe3\x81\x87|\xe3\x81\x88|\xe3\x81\x89|\xe3\x81\x8a|\xe3\x81\x8b|\xe3\x81\x8c|\xe3\x81\x8d|\xe3\x81\x8e|\xe3\x81\x8f|\xe3\x81\x90|\xe3\x81\x91|\xe3\x81\x92|\xe3\x81\x93|\xe3\x81\x94|\xe3\x81\x95|\xe3\x81\x96|\xe3\x81\x97|\xe3\x81\x98|\xe3\x81\x99|\xe3\x81\x9a|\xe3\x81\x9b|\xe3\x81\x9c|\xe3\x81\x9d|\xe3\x81\x9e|\xe3\x81\x9f|\xe3\x81\xa0|\xe3\x81\xa1|\xe3\x81\xa2|\xe3\x81\xa3|\xe3\x81\xa4|\xe3\x81\xa5|\xe3\x81\xa6|\xe3\x81\xa7|\xe3\x81\xa8|\xe3\x81\xa9|\xe3\x81\xaa|\xe3\x81\xab|\xe3\x81\xac|\xe3\x81\xad|\xe3\x81\xae|\xe3\x81\xaf|\xe3\x81\xb0|\xe3\x81\xb1|\xe3\x81\xb2|\xe3\x81\xb3|\xe3\x81\xb4|\xe3\x81\xb5|\xe3\x81\xb6|\xe3\x81\xb7|\xe3\x81\xb8|\xe3\x81\xb9|\xe3\x81\xba|\xe3\x81\xbb|\xe3\x81\xbc|\xe3\x81\xbd|\xe3\x81\xbe|\xe3\x81\xbf|\xe3\x82\x80|\xe3\x82\x81|\xe3\x82\x82|\xe3\x82\x83|\xe3\x82\x84|\xe3\x82\x85|\xe3\x82\x86|\xe3\x82\x87|\xe3\x82\x88|\xe3\x82\x89|\xe3\x82\x8a|\xe3\x82\x8b|\xe3\x82\x8c|\xe3\x82\x8d|\xe3\x82\x8e|\xe3\x82\x8f|\xe3\x82\x90|\xe3\x82\x91|\xe3\x82\x92|\xe3\x82\x93)/$_hira2kata{$1}/eg; + + $this; +} +sub splitCsvu +{ + my $this = shift; + my $result = &splitCsv; + + if( $]>=5.008 && $this->{icode} ne 'binary' ) + { + foreach(@$result) + { + Encode::_utf8_on($_); + } + } + + $result; +} +sub sjis_doti1 +{ + my $this = shift; + $this->_u2sd($this->{str}); +} +# ----------------------------------------------------------------------------- +# conversion methods (private). +# +sub _s2j { + my $this = shift; + my $str = shift; + + $str =~ s/((?:$RE{SJIS_DBCS}|$RE{SJIS_KANA})+)/ + $this->_s2j2($1) . $ESC{ASC} + /geo; + + $str; +} +sub _sa2j2 { + my $this = shift; + my $str = shift; + + $str =~ s/((?:$RE{SJIS_DBCS}|$RE{E_SJIS_AU})+|(?:$RE{SJIS_KANA})+)/ + my $s = $1; + if($s =~ m,^$RE{SJIS_KANA},o) + { + $s =~ tr,\xa1-\xdf,\x21-\x5f,; + $ESC{KANA} . $s + } + else + { + $s =~ s!($RE{SJIS_DBCS}|$RE{E_SJIS_AU})! + $this->_sa2j3($1) + !geo; + $ESC{JIS_0208} . $s; + } + /geo; + + $str; +} +sub _j2sa { + my $this = shift; + my $str = shift; + + $str =~ s/($RE{JIS_0208}|$RE{JIS_0212}|$RE{JIS_ASC}|$RE{JIS_KANA})([^\e]*)/ + $this->_j2sa2($1, $2) + /geo; + + $str; +} +sub sjis_au1 +{ + my $this = shift; + $this->_j2sa($this->_s2j($this->_u2ja1($this->{str}))); +} +sub join_csv { + &joinCsv; +} +# utf8ʸAUʸɤѴ +sub _ai2u1 { + my $this = shift; + my $str = shift; + + if(!defined($str)) + { + return ''; + } + + if(!defined($ea2u1)) + { + $ea2u1 = $this->_getFile('jcode/emoji2/ea2u.dat'); + } + + my $c; + $str =~ s/$RE{E_ICON_AU_START}(\d+)$RE{E_ICON_AU_END}/ + ($1 > 0 and $1 <= 0x14a) ? + ($c = substr($ea2u1, ($1-1) * 4, 4), $c =~ tr,\0,,d, ($c eq '') ? '?' : $c) : + '?' + /ige; + + $str; +} +# ----------------------------------------------------------------------------- +# sjis/ʸ => utf8 +# +sub _s2u { + my $this = shift; + my $str = shift; + + if(!defined($str)) + { + return ''; + } + + if(!defined($s2u_table)) + { + $s2u_table = $this->_getFile('jcode/s2u.dat'); + } + + my $l; + my $uc; + $str =~ s/($RE{SJIS_KANA}|$RE{SJIS_DBCS}|[\x80-\xff])/ + $S2U{$1} + or ($S2U{$1} = + ( + $l = (unpack('n', $1) or unpack('C', $1)), + ( + ($l >= 0xa1 and $l <= 0xdf) ? + ( + $uc = substr($s2u_table, ($l - 0xa1) * 3, 3), + $uc =~ tr,\0,,d, + $uc + ) : + ($l >= 0x8100 and $l <= 0x9fff) ? + ( + $uc = substr($s2u_table, ($l - 0x8100 + 0x3f) * 3, 3), + $uc =~ tr,\0,,d, + $uc + ) : + ($l >= 0xe000 and $l <= 0xfcff) ? + ( + $uc = substr($s2u_table, ($l - 0xe000 + 0x1f3f) * 3, 3), + $uc =~ tr,\0,,d, + $uc + ) : + ($l < 0x80) ? + chr($l) : + '?' + ) + ) + )/eg; + + $str; + +} +sub jis_jsky1 +{ + my $this = shift; + $this->_s2j($this->_u2sj1($this->{str})); +} +sub jis_icon_au2 +{ + my $this = shift; + $this->_s2j($this->_u2s($this->_u2ai2($this->{str}))); +} +sub _j2sa3 { + my $this = shift; + my $c = shift; + + my ($c1, $c2) = unpack('CC', $c); + if ($c1 % 2) + { + $c1 = ($c1>>1) + ($c1 < 0xdf ? 0x31 : 0x71); + $c2 -= 0x60 + ($c2 < 0xe0); + } + else + { + $c1 = ($c1>>1) + ($c1 < 0xdf ? 0x30 : 0x70); + $c2 -= 2; + } + $c1 = 0xf6 if($c1 == 0xeb); + $c1 = 0xf7 if($c1 == 0xec); + $c1 = 0xf3 if($c1 == 0xed); + $c1 = 0xf4 if($c1 == 0xee); + + pack('CC', $c1, $c2); +} +# ----------------------------------------------------------------------------- +# $bytes_jsky = $unijp->sjis_jsky(); +# +sub sjis_jsky +{ + my $this = shift; + $this->_u2sj2($this->{str}); +} +sub _u2uj2 +{ + my $this = shift; + + if(!defined($eu2j2)) + { + $eu2j2 = $this->_getFile('jcode/emoji2/eu2j2.dat'); + } + + my $str = $this->_validate_utf8($this->{str}); + + $str =~ s{([\xf0-\xf7][\x80-\xbf]{3})}{ + my ($c1,$c2,$c3,$c4) = unpack("C4", $1); + my $ch = (($c1 & 0x07)<<18) | (($c2 & 0x3F)<<12) | + (($c3 & 0x3f)<< 6) | ($c4 & 0x3F); + if( 0x0fe000 <= $ch && $ch <= 0x0fffff ) + { + my $c = substr($eu2j2, ($ch - 0x0fe000) * 5, 5); + $c =~ tr,\0,,d; + $c eq '' and $c = '?'; + if( $c =~ /^\e\$([GEFOPQ])(.)\x0f/ ) + { + my ($j1,$j2) = ($1,$2); + $j1 =~ tr/GEFOPQ/\xe0-\xe5/; + $j2 =~ tr/!-z/\x01-\x5a/; + $c = $this->_ucs2_utf8($j1.$j2); + } + $c; + }else + { + '?'; + } + }ge; + $str; +} +# ----------------------------------------------------------------------------- +# $bytes_iso2022jp = $unijp->jis(); +# +sub jis +{ + my $this = shift; + $this->_s2j($this->sjis); +} +sub jis_au1 +{ + my $this = shift; + $this->_s2j($this->_u2ja1($this->{str})); +} +sub _utf8_ucs4 { + my $this = shift; + my $str = shift; + + if(!defined($str)) + { + return ''; + } + + my $c1; + my $c2; + my $c3; + my $c4; + my $c5; + my $c6; + $str =~ s/([\x00-\x7f]|[\xc0-\xdf][\x80-\xbf]|[\xe0-\xef][\x80-\xbf]{2}|[\xf0-\xf7][\x80-\xbf]{3}|[\xf8-\xfb][\x80-\xbf]{4}|[\xfc-\xfd][\x80-\xbf]{5}|(.))/ + defined($2) ? "\0\0\0$2" : + (length($1) == 1) ? pack("N", unpack("C", $1)) : + (length($1) == 2) ? + do { + ($c1,$c2) = unpack("C2", $1); + my $n = (($c1 & 0x1F) << 6)|($c2 & 0x3F); + pack("N", $n>=0x80 ? $n : unpack("C",'?')); + } : + (length($1) == 3) ? + do { + ($c1,$c2,$c3) = unpack("C3", $1); + my $n = (($c1 & 0x0F) << 12)|(($c2 & 0x3F) << 6)| ($c3 & 0x3F); + pack("N", $n>=0x800 ? $n : unpack("C",'?')); + } : + (length($1) == 4) ? + do { + ($c1,$c2,$c3,$c4) = unpack("C4", $1); + my $n = (($c1 & 0x07) << 18)|(($c2 & 0x3F) << 12)| + (($c3 & 0x3f) << 6)|($c4 & 0x3F); + pack("N", ($n>=0x010000 && $n<=0x10FFFF) ? $n : unpack("C",'?')); + } : + pack("N", unpack("C",'?')) + /eg; + + $str; +} +# ----------------------------------------------------------------------------- +# $bytes_utf8 = $unijp->get(); +# +sub get { + my $this = shift; + $this->{str}; +} +sub z2h { + my $this = shift; + + $this->z2hKana; + $this->z2hNum; + $this->z2hAlpha; + $this->z2hSym; + + $this; +} +# ----------------------------------------------------------------------------- +# $chars_utf8 = $unijp->getu(); +# +sub getu { + my $this = shift; + my $str = $this->{str}; + if( $]>=5.008 && $this->{icode} ne 'binary' ) + { + Encode::_utf8_on($str); + } + $str; +} +sub _loadConvTable { + + +%_h2zNum = ( + "0" => "\xef\xbc\x90", "1" => "\xef\xbc\x91", + "2" => "\xef\xbc\x92", "3" => "\xef\xbc\x93", + "4" => "\xef\xbc\x94", "5" => "\xef\xbc\x95", + "6" => "\xef\xbc\x96", "7" => "\xef\xbc\x97", + "8" => "\xef\xbc\x98", "9" => "\xef\xbc\x99", + +); + + + +%_z2hNum = ( + "\xef\xbc\x90" => "0", "\xef\xbc\x91" => "1", + "\xef\xbc\x92" => "2", "\xef\xbc\x93" => "3", + "\xef\xbc\x94" => "4", "\xef\xbc\x95" => "5", + "\xef\xbc\x96" => "6", "\xef\xbc\x97" => "7", + "\xef\xbc\x98" => "8", "\xef\xbc\x99" => "9", + +); + + + +%_h2zAlpha = ( + "A" => "\xef\xbc\xa1", "B" => "\xef\xbc\xa2", + "C" => "\xef\xbc\xa3", "D" => "\xef\xbc\xa4", + "E" => "\xef\xbc\xa5", "F" => "\xef\xbc\xa6", + "G" => "\xef\xbc\xa7", "H" => "\xef\xbc\xa8", + "I" => "\xef\xbc\xa9", "J" => "\xef\xbc\xaa", + "K" => "\xef\xbc\xab", "L" => "\xef\xbc\xac", + "M" => "\xef\xbc\xad", "N" => "\xef\xbc\xae", + "O" => "\xef\xbc\xaf", "P" => "\xef\xbc\xb0", + "Q" => "\xef\xbc\xb1", "R" => "\xef\xbc\xb2", + "S" => "\xef\xbc\xb3", "T" => "\xef\xbc\xb4", + "U" => "\xef\xbc\xb5", "V" => "\xef\xbc\xb6", + "W" => "\xef\xbc\xb7", "X" => "\xef\xbc\xb8", + "Y" => "\xef\xbc\xb9", "Z" => "\xef\xbc\xba", + "a" => "\xef\xbd\x81", "b" => "\xef\xbd\x82", + "c" => "\xef\xbd\x83", "d" => "\xef\xbd\x84", + "e" => "\xef\xbd\x85", "f" => "\xef\xbd\x86", + "g" => "\xef\xbd\x87", "h" => "\xef\xbd\x88", + "i" => "\xef\xbd\x89", "j" => "\xef\xbd\x8a", + "k" => "\xef\xbd\x8b", "l" => "\xef\xbd\x8c", + "m" => "\xef\xbd\x8d", "n" => "\xef\xbd\x8e", + "o" => "\xef\xbd\x8f", "p" => "\xef\xbd\x90", + "q" => "\xef\xbd\x91", "r" => "\xef\xbd\x92", + "s" => "\xef\xbd\x93", "t" => "\xef\xbd\x94", + "u" => "\xef\xbd\x95", "v" => "\xef\xbd\x96", + "w" => "\xef\xbd\x97", "x" => "\xef\xbd\x98", + "y" => "\xef\xbd\x99", "z" => "\xef\xbd\x9a", + +); + + + +%_z2hAlpha = ( + "\xef\xbc\xa1" => "A", "\xef\xbc\xa2" => "B", + "\xef\xbc\xa3" => "C", "\xef\xbc\xa4" => "D", + "\xef\xbc\xa5" => "E", "\xef\xbc\xa6" => "F", + "\xef\xbc\xa7" => "G", "\xef\xbc\xa8" => "H", + "\xef\xbc\xa9" => "I", "\xef\xbc\xaa" => "J", + "\xef\xbc\xab" => "K", "\xef\xbc\xac" => "L", + "\xef\xbc\xad" => "M", "\xef\xbc\xae" => "N", + "\xef\xbc\xaf" => "O", "\xef\xbc\xb0" => "P", + "\xef\xbc\xb1" => "Q", "\xef\xbc\xb2" => "R", + "\xef\xbc\xb3" => "S", "\xef\xbc\xb4" => "T", + "\xef\xbc\xb5" => "U", "\xef\xbc\xb6" => "V", + "\xef\xbc\xb7" => "W", "\xef\xbc\xb8" => "X", + "\xef\xbc\xb9" => "Y", "\xef\xbc\xba" => "Z", + "\xef\xbd\x81" => "a", "\xef\xbd\x82" => "b", + "\xef\xbd\x83" => "c", "\xef\xbd\x84" => "d", + "\xef\xbd\x85" => "e", "\xef\xbd\x86" => "f", + "\xef\xbd\x87" => "g", "\xef\xbd\x88" => "h", + "\xef\xbd\x89" => "i", "\xef\xbd\x8a" => "j", + "\xef\xbd\x8b" => "k", "\xef\xbd\x8c" => "l", + "\xef\xbd\x8d" => "m", "\xef\xbd\x8e" => "n", + "\xef\xbd\x8f" => "o", "\xef\xbd\x90" => "p", + "\xef\xbd\x91" => "q", "\xef\xbd\x92" => "r", + "\xef\xbd\x93" => "s", "\xef\xbd\x94" => "t", + "\xef\xbd\x95" => "u", "\xef\xbd\x96" => "v", + "\xef\xbd\x97" => "w", "\xef\xbd\x98" => "x", + "\xef\xbd\x99" => "y", "\xef\xbd\x9a" => "z", + +); + + + +%_h2zSym = ( + "\x20" => "\xe3\x80\x80", "\x21" => "\xef\xbc\x81", + "\x22" => "\xe2\x80\x9d", "\x23" => "\xef\xbc\x83", + "\x24" => "\xef\xbc\x84", "\x25" => "\xef\xbc\x85", + "\x26" => "\xef\xbc\x86", "\x27" => "\xe2\x80\x99", + "\x28" => "\xef\xbc\x88", "\x29" => "\xef\xbc\x89", + "\x2a" => "\xef\xbc\x8a", "\x2b" => "\xef\xbc\x8b", + "\x2c" => "\xef\xbc\x8c", "\x2d" => "\xef\xbc\x8d", + "\x2e" => "\xef\xbc\x8e", "\x2f" => "\xef\xbc\x8f", + "\x3a" => "\xef\xbc\x9a", "\x3b" => "\xef\xbc\x9b", + "\x3c" => "\xef\xbc\x9c", "\x3d" => "\xef\xbc\x9d", + "\x3e" => "\xef\xbc\x9e", "\x3f" => "\xef\xbc\x9f", + "\x40" => "\xef\xbc\xa0", "\x5b" => "\xef\xbc\xbb", + "\x5c" => "\xef\xbf\xa5", "\x5d" => "\xef\xbc\xbd", + "\x5e" => "\xef\xbc\xbe", "_" => "\xef\xbc\xbf", + "\x60" => "\xef\xbd\x80", "\x7b" => "\xef\xbd\x9b", + "\x7c" => "\xef\xbd\x9c", "\x7d" => "\xef\xbd\x9d", + "\x7e" => "\xef\xbd\x9e", +); + + + +%_z2hSym = ( + "\xe3\x80\x80" => "\x20", "\xef\xbc\x8c" => "\x2c", + "\xef\xbc\x8e" => "\x2e", "\xef\xbc\x9a" => "\x3a", + "\xef\xbc\x9b" => "\x3b", "\xef\xbc\x9f" => "\x3f", + "\xef\xbc\x81" => "\x21", "\xef\xbd\x80" => "\x60", + "\xef\xbc\xbe" => "\x5e", "\xef\xbc\xbf" => "_", + "\xef\xbc\x8f" => "\x2f", "\xef\xbd\x9e" => "\x7e", + "\xef\xbd\x9c" => "\x7c", "\xe2\x80\x99" => "\x27", + "\xe2\x80\x9d" => "\x22", "\xef\xbc\x88" => "\x28", + "\xef\xbc\x89" => "\x29", "\xef\xbc\xbb" => "\x5b", + "\xef\xbc\xbd" => "\x5d", "\xef\xbd\x9b" => "\x7b", + "\xef\xbd\x9d" => "\x7d", "\xef\xbc\x8b" => "\x2b", + "\xef\xbc\x8d" => "\x2d", "\xef\xbc\x9d" => "\x3d", + "\xef\xbc\x9c" => "\x3c", "\xef\xbc\x9e" => "\x3e", + "\xef\xbf\xa5" => "\x5c", "\xef\xbc\x84" => "\x24", + "\xef\xbc\x85" => "\x25", "\xef\xbc\x83" => "\x23", + "\xef\xbc\x86" => "\x26", "\xef\xbc\x8a" => "\x2a", + "\xef\xbc\xa0" => "\x40", "\xe3\x80\x9c" => "\x7e", + +); + + + +%_h2zKanaK = ( + "\xef\xbd\xa1" => "\xe3\x80\x82", "\xef\xbd\xa2" => "\xe3\x80\x8c", + "\xef\xbd\xa3" => "\xe3\x80\x8d", "\xef\xbd\xa4" => "\xe3\x80\x81", + "\xef\xbd\xa5" => "\xe3\x83\xbb", "\xef\xbd\xa6" => "\xe3\x83\xb2", + "\xef\xbd\xa7" => "\xe3\x82\xa1", "\xef\xbd\xa8" => "\xe3\x82\xa3", + "\xef\xbd\xa9" => "\xe3\x82\xa5", "\xef\xbd\xaa" => "\xe3\x82\xa7", + "\xef\xbd\xab" => "\xe3\x82\xa9", "\xef\xbd\xac" => "\xe3\x83\xa3", + "\xef\xbd\xad" => "\xe3\x83\xa5", "\xef\xbd\xae" => "\xe3\x83\xa7", + "\xef\xbd\xaf" => "\xe3\x83\x83", "\xef\xbd\xb0" => "\xe3\x83\xbc", + "\xef\xbd\xb1" => "\xe3\x82\xa2", "\xef\xbd\xb2" => "\xe3\x82\xa4", + "\xef\xbd\xb3" => "\xe3\x82\xa6", "\xef\xbd\xb4" => "\xe3\x82\xa8", + "\xef\xbd\xb5" => "\xe3\x82\xaa", "\xef\xbd\xb6" => "\xe3\x82\xab", + "\xef\xbd\xb7" => "\xe3\x82\xad", "\xef\xbd\xb8" => "\xe3\x82\xaf", + "\xef\xbd\xb9" => "\xe3\x82\xb1", "\xef\xbd\xba" => "\xe3\x82\xb3", + "\xef\xbd\xbb" => "\xe3\x82\xb5", "\xef\xbd\xbc" => "\xe3\x82\xb7", + "\xef\xbd\xbd" => "\xe3\x82\xb9", "\xef\xbd\xbe" => "\xe3\x82\xbb", + "\xef\xbd\xbf" => "\xe3\x82\xbd", "\xef\xbe\x80" => "\xe3\x82\xbf", + "\xef\xbe\x81" => "\xe3\x83\x81", "\xef\xbe\x82" => "\xe3\x83\x84", + "\xef\xbe\x83" => "\xe3\x83\x86", "\xef\xbe\x84" => "\xe3\x83\x88", + "\xef\xbe\x85" => "\xe3\x83\x8a", "\xef\xbe\x86" => "\xe3\x83\x8b", + "\xef\xbe\x87" => "\xe3\x83\x8c", "\xef\xbe\x88" => "\xe3\x83\x8d", + "\xef\xbe\x89" => "\xe3\x83\x8e", "\xef\xbe\x8a" => "\xe3\x83\x8f", + "\xef\xbe\x8b" => "\xe3\x83\x92", "\xef\xbe\x8c" => "\xe3\x83\x95", + "\xef\xbe\x8d" => "\xe3\x83\x98", "\xef\xbe\x8e" => "\xe3\x83\x9b", + "\xef\xbe\x8f" => "\xe3\x83\x9e", "\xef\xbe\x90" => "\xe3\x83\x9f", + "\xef\xbe\x91" => "\xe3\x83\xa0", "\xef\xbe\x92" => "\xe3\x83\xa1", + "\xef\xbe\x93" => "\xe3\x83\xa2", "\xef\xbe\x94" => "\xe3\x83\xa4", + "\xef\xbe\x95" => "\xe3\x83\xa6", "\xef\xbe\x96" => "\xe3\x83\xa8", + "\xef\xbe\x97" => "\xe3\x83\xa9", "\xef\xbe\x98" => "\xe3\x83\xaa", + "\xef\xbe\x99" => "\xe3\x83\xab", "\xef\xbe\x9a" => "\xe3\x83\xac", + "\xef\xbe\x9b" => "\xe3\x83\xad", "\xef\xbe\x9c" => "\xe3\x83\xaf", + "\xef\xbe\x9d" => "\xe3\x83\xb3", "\xef\xbe\x9e" => "\xe3\x82\x9b", + "\xef\xbe\x9f" => "\xe3\x82\x9c", +); + + + +%_z2hKanaK = ( + "\xe3\x80\x81" => "\xef\xbd\xa4", "\xe3\x80\x82" => "\xef\xbd\xa1", + "\xe3\x83\xbb" => "\xef\xbd\xa5", "\xe3\x82\x9b" => "\xef\xbe\x9e", + "\xe3\x82\x9c" => "\xef\xbe\x9f", "\xe3\x83\xbc" => "\xef\xbd\xb0", + "\xe3\x80\x8c" => "\xef\xbd\xa2", "\xe3\x80\x8d" => "\xef\xbd\xa3", + "\xe3\x82\xa1" => "\xef\xbd\xa7", "\xe3\x82\xa2" => "\xef\xbd\xb1", + "\xe3\x82\xa3" => "\xef\xbd\xa8", "\xe3\x82\xa4" => "\xef\xbd\xb2", + "\xe3\x82\xa5" => "\xef\xbd\xa9", "\xe3\x82\xa6" => "\xef\xbd\xb3", + "\xe3\x82\xa7" => "\xef\xbd\xaa", "\xe3\x82\xa8" => "\xef\xbd\xb4", + "\xe3\x82\xa9" => "\xef\xbd\xab", "\xe3\x82\xaa" => "\xef\xbd\xb5", + "\xe3\x82\xab" => "\xef\xbd\xb6", "\xe3\x82\xad" => "\xef\xbd\xb7", + "\xe3\x82\xaf" => "\xef\xbd\xb8", "\xe3\x82\xb1" => "\xef\xbd\xb9", + "\xe3\x82\xb3" => "\xef\xbd\xba", "\xe3\x82\xb5" => "\xef\xbd\xbb", + "\xe3\x82\xb7" => "\xef\xbd\xbc", "\xe3\x82\xb9" => "\xef\xbd\xbd", + "\xe3\x82\xbb" => "\xef\xbd\xbe", "\xe3\x82\xbd" => "\xef\xbd\xbf", + "\xe3\x82\xbf" => "\xef\xbe\x80", "\xe3\x83\x81" => "\xef\xbe\x81", + "\xe3\x83\x83" => "\xef\xbd\xaf", "\xe3\x83\x84" => "\xef\xbe\x82", + "\xe3\x83\x86" => "\xef\xbe\x83", "\xe3\x83\x88" => "\xef\xbe\x84", + "\xe3\x83\x8a" => "\xef\xbe\x85", "\xe3\x83\x8b" => "\xef\xbe\x86", + "\xe3\x83\x8c" => "\xef\xbe\x87", "\xe3\x83\x8d" => "\xef\xbe\x88", + "\xe3\x83\x8e" => "\xef\xbe\x89", "\xe3\x83\x8f" => "\xef\xbe\x8a", + "\xe3\x83\x92" => "\xef\xbe\x8b", "\xe3\x83\x95" => "\xef\xbe\x8c", + "\xe3\x83\x98" => "\xef\xbe\x8d", "\xe3\x83\x9b" => "\xef\xbe\x8e", + "\xe3\x83\x9e" => "\xef\xbe\x8f", "\xe3\x83\x9f" => "\xef\xbe\x90", + "\xe3\x83\xa0" => "\xef\xbe\x91", "\xe3\x83\xa1" => "\xef\xbe\x92", + "\xe3\x83\xa2" => "\xef\xbe\x93", "\xe3\x83\xa3" => "\xef\xbd\xac", + "\xe3\x83\xa4" => "\xef\xbe\x94", "\xe3\x83\xa5" => "\xef\xbd\xad", + "\xe3\x83\xa6" => "\xef\xbe\x95", "\xe3\x83\xa7" => "\xef\xbd\xae", + "\xe3\x83\xa8" => "\xef\xbe\x96", "\xe3\x83\xa9" => "\xef\xbe\x97", + "\xe3\x83\xaa" => "\xef\xbe\x98", "\xe3\x83\xab" => "\xef\xbe\x99", + "\xe3\x83\xac" => "\xef\xbe\x9a", "\xe3\x83\xad" => "\xef\xbe\x9b", + "\xe3\x83\xaf" => "\xef\xbe\x9c", "\xe3\x83\xb2" => "\xef\xbd\xa6", + "\xe3\x83\xb3" => "\xef\xbe\x9d", +); + + + +%_h2zKanaD = ( + "\xef\xbd\xb3\xef\xbe\x9e" => "\xe3\x83\xb4", "\xef\xbd\xb6\xef\xbe\x9e" => "\xe3\x82\xac", + "\xef\xbd\xb7\xef\xbe\x9e" => "\xe3\x82\xae", "\xef\xbd\xb8\xef\xbe\x9e" => "\xe3\x82\xb0", + "\xef\xbd\xb9\xef\xbe\x9e" => "\xe3\x82\xb2", "\xef\xbd\xba\xef\xbe\x9e" => "\xe3\x82\xb4", + "\xef\xbd\xbb\xef\xbe\x9e" => "\xe3\x82\xb6", "\xef\xbd\xbc\xef\xbe\x9e" => "\xe3\x82\xb8", + "\xef\xbd\xbd\xef\xbe\x9e" => "\xe3\x82\xba", "\xef\xbd\xbe\xef\xbe\x9e" => "\xe3\x82\xbc", + "\xef\xbd\xbf\xef\xbe\x9e" => "\xe3\x82\xbe", "\xef\xbe\x80\xef\xbe\x9e" => "\xe3\x83\x80", + "\xef\xbe\x81\xef\xbe\x9e" => "\xe3\x83\x82", "\xef\xbe\x82\xef\xbe\x9e" => "\xe3\x83\x85", + "\xef\xbe\x83\xef\xbe\x9e" => "\xe3\x83\x87", "\xef\xbe\x84\xef\xbe\x9e" => "\xe3\x83\x89", + "\xef\xbe\x8a\xef\xbe\x9e" => "\xe3\x83\x90", "\xef\xbe\x8a\xef\xbe\x9f" => "\xe3\x83\x91", + "\xef\xbe\x8b\xef\xbe\x9e" => "\xe3\x83\x93", "\xef\xbe\x8b\xef\xbe\x9f" => "\xe3\x83\x94", + "\xef\xbe\x8c\xef\xbe\x9e" => "\xe3\x83\x96", "\xef\xbe\x8c\xef\xbe\x9f" => "\xe3\x83\x97", + "\xef\xbe\x8d\xef\xbe\x9e" => "\xe3\x83\x99", "\xef\xbe\x8d\xef\xbe\x9f" => "\xe3\x83\x9a", + "\xef\xbe\x8e\xef\xbe\x9e" => "\xe3\x83\x9c", "\xef\xbe\x8e\xef\xbe\x9f" => "\xe3\x83\x9d", + +); + + + +%_z2hKanaD = ( + "\xe3\x82\xac" => "\xef\xbd\xb6\xef\xbe\x9e", "\xe3\x82\xae" => "\xef\xbd\xb7\xef\xbe\x9e", + "\xe3\x82\xb0" => "\xef\xbd\xb8\xef\xbe\x9e", "\xe3\x82\xb2" => "\xef\xbd\xb9\xef\xbe\x9e", + "\xe3\x82\xb4" => "\xef\xbd\xba\xef\xbe\x9e", "\xe3\x82\xb6" => "\xef\xbd\xbb\xef\xbe\x9e", + "\xe3\x82\xb8" => "\xef\xbd\xbc\xef\xbe\x9e", "\xe3\x82\xba" => "\xef\xbd\xbd\xef\xbe\x9e", + "\xe3\x82\xbc" => "\xef\xbd\xbe\xef\xbe\x9e", "\xe3\x82\xbe" => "\xef\xbd\xbf\xef\xbe\x9e", + "\xe3\x83\x80" => "\xef\xbe\x80\xef\xbe\x9e", "\xe3\x83\x82" => "\xef\xbe\x81\xef\xbe\x9e", + "\xe3\x83\x85" => "\xef\xbe\x82\xef\xbe\x9e", "\xe3\x83\x87" => "\xef\xbe\x83\xef\xbe\x9e", + "\xe3\x83\x89" => "\xef\xbe\x84\xef\xbe\x9e", "\xe3\x83\x90" => "\xef\xbe\x8a\xef\xbe\x9e", + "\xe3\x83\x91" => "\xef\xbe\x8a\xef\xbe\x9f", "\xe3\x83\x93" => "\xef\xbe\x8b\xef\xbe\x9e", + "\xe3\x83\x94" => "\xef\xbe\x8b\xef\xbe\x9f", "\xe3\x83\x96" => "\xef\xbe\x8c\xef\xbe\x9e", + "\xe3\x83\x97" => "\xef\xbe\x8c\xef\xbe\x9f", "\xe3\x83\x99" => "\xef\xbe\x8d\xef\xbe\x9e", + "\xe3\x83\x9a" => "\xef\xbe\x8d\xef\xbe\x9f", "\xe3\x83\x9c" => "\xef\xbe\x8e\xef\xbe\x9e", + "\xe3\x83\x9d" => "\xef\xbe\x8e\xef\xbe\x9f", "\xe3\x83\xb4" => "\xef\xbd\xb3\xef\xbe\x9e", + +); + + + +%_hira2kata = ( + "\xe3\x81\x81" => "\xe3\x82\xa1", "\xe3\x81\x82" => "\xe3\x82\xa2", + "\xe3\x81\x83" => "\xe3\x82\xa3", "\xe3\x81\x84" => "\xe3\x82\xa4", + "\xe3\x81\x85" => "\xe3\x82\xa5", "\xe3\x81\x86" => "\xe3\x82\xa6", + "\xe3\x81\x87" => "\xe3\x82\xa7", "\xe3\x81\x88" => "\xe3\x82\xa8", + "\xe3\x81\x89" => "\xe3\x82\xa9", "\xe3\x81\x8a" => "\xe3\x82\xaa", + "\xe3\x81\x8b" => "\xe3\x82\xab", "\xe3\x81\x8c" => "\xe3\x82\xac", + "\xe3\x81\x8d" => "\xe3\x82\xad", "\xe3\x81\x8e" => "\xe3\x82\xae", + "\xe3\x81\x8f" => "\xe3\x82\xaf", "\xe3\x81\x90" => "\xe3\x82\xb0", + "\xe3\x81\x91" => "\xe3\x82\xb1", "\xe3\x81\x92" => "\xe3\x82\xb2", + "\xe3\x81\x93" => "\xe3\x82\xb3", "\xe3\x81\x94" => "\xe3\x82\xb4", + "\xe3\x81\x95" => "\xe3\x82\xb5", "\xe3\x81\x96" => "\xe3\x82\xb6", + "\xe3\x81\x97" => "\xe3\x82\xb7", "\xe3\x81\x98" => "\xe3\x82\xb8", + "\xe3\x81\x99" => "\xe3\x82\xb9", "\xe3\x81\x9a" => "\xe3\x82\xba", + "\xe3\x81\x9b" => "\xe3\x82\xbb", "\xe3\x81\x9c" => "\xe3\x82\xbc", + "\xe3\x81\x9d" => "\xe3\x82\xbd", "\xe3\x81\x9e" => "\xe3\x82\xbe", + "\xe3\x81\x9f" => "\xe3\x82\xbf", "\xe3\x81\xa0" => "\xe3\x83\x80", + "\xe3\x81\xa1" => "\xe3\x83\x81", "\xe3\x81\xa2" => "\xe3\x83\x82", + "\xe3\x81\xa3" => "\xe3\x83\x83", "\xe3\x81\xa4" => "\xe3\x83\x84", + "\xe3\x81\xa5" => "\xe3\x83\x85", "\xe3\x81\xa6" => "\xe3\x83\x86", + "\xe3\x81\xa7" => "\xe3\x83\x87", "\xe3\x81\xa8" => "\xe3\x83\x88", + "\xe3\x81\xa9" => "\xe3\x83\x89", "\xe3\x81\xaa" => "\xe3\x83\x8a", + "\xe3\x81\xab" => "\xe3\x83\x8b", "\xe3\x81\xac" => "\xe3\x83\x8c", + "\xe3\x81\xad" => "\xe3\x83\x8d", "\xe3\x81\xae" => "\xe3\x83\x8e", + "\xe3\x81\xaf" => "\xe3\x83\x8f", "\xe3\x81\xb0" => "\xe3\x83\x90", + "\xe3\x81\xb1" => "\xe3\x83\x91", "\xe3\x81\xb2" => "\xe3\x83\x92", + "\xe3\x81\xb3" => "\xe3\x83\x93", "\xe3\x81\xb4" => "\xe3\x83\x94", + "\xe3\x81\xb5" => "\xe3\x83\x95", "\xe3\x81\xb6" => "\xe3\x83\x96", + "\xe3\x81\xb7" => "\xe3\x83\x97", "\xe3\x81\xb8" => "\xe3\x83\x98", + "\xe3\x81\xb9" => "\xe3\x83\x99", "\xe3\x81\xba" => "\xe3\x83\x9a", + "\xe3\x81\xbb" => "\xe3\x83\x9b", "\xe3\x81\xbc" => "\xe3\x83\x9c", + "\xe3\x81\xbd" => "\xe3\x83\x9d", "\xe3\x81\xbe" => "\xe3\x83\x9e", + "\xe3\x81\xbf" => "\xe3\x83\x9f", "\xe3\x82\x80" => "\xe3\x83\xa0", + "\xe3\x82\x81" => "\xe3\x83\xa1", "\xe3\x82\x82" => "\xe3\x83\xa2", + "\xe3\x82\x83" => "\xe3\x83\xa3", "\xe3\x82\x84" => "\xe3\x83\xa4", + "\xe3\x82\x85" => "\xe3\x83\xa5", "\xe3\x82\x86" => "\xe3\x83\xa6", + "\xe3\x82\x87" => "\xe3\x83\xa7", "\xe3\x82\x88" => "\xe3\x83\xa8", + "\xe3\x82\x89" => "\xe3\x83\xa9", "\xe3\x82\x8a" => "\xe3\x83\xaa", + "\xe3\x82\x8b" => "\xe3\x83\xab", "\xe3\x82\x8c" => "\xe3\x83\xac", + "\xe3\x82\x8d" => "\xe3\x83\xad", "\xe3\x82\x8e" => "\xe3\x83\xae", + "\xe3\x82\x8f" => "\xe3\x83\xaf", "\xe3\x82\x90" => "\xe3\x83\xb0", + "\xe3\x82\x91" => "\xe3\x83\xb1", "\xe3\x82\x92" => "\xe3\x83\xb2", + "\xe3\x82\x93" => "\xe3\x83\xb3", +); + + + +%_kata2hira = ( + "\xe3\x82\xa1" => "\xe3\x81\x81", "\xe3\x82\xa2" => "\xe3\x81\x82", + "\xe3\x82\xa3" => "\xe3\x81\x83", "\xe3\x82\xa4" => "\xe3\x81\x84", + "\xe3\x82\xa5" => "\xe3\x81\x85", "\xe3\x82\xa6" => "\xe3\x81\x86", + "\xe3\x82\xa7" => "\xe3\x81\x87", "\xe3\x82\xa8" => "\xe3\x81\x88", + "\xe3\x82\xa9" => "\xe3\x81\x89", "\xe3\x82\xaa" => "\xe3\x81\x8a", + "\xe3\x82\xab" => "\xe3\x81\x8b", "\xe3\x82\xac" => "\xe3\x81\x8c", + "\xe3\x82\xad" => "\xe3\x81\x8d", "\xe3\x82\xae" => "\xe3\x81\x8e", + "\xe3\x82\xaf" => "\xe3\x81\x8f", "\xe3\x82\xb0" => "\xe3\x81\x90", + "\xe3\x82\xb1" => "\xe3\x81\x91", "\xe3\x82\xb2" => "\xe3\x81\x92", + "\xe3\x82\xb3" => "\xe3\x81\x93", "\xe3\x82\xb4" => "\xe3\x81\x94", + "\xe3\x82\xb5" => "\xe3\x81\x95", "\xe3\x82\xb6" => "\xe3\x81\x96", + "\xe3\x82\xb7" => "\xe3\x81\x97", "\xe3\x82\xb8" => "\xe3\x81\x98", + "\xe3\x82\xb9" => "\xe3\x81\x99", "\xe3\x82\xba" => "\xe3\x81\x9a", + "\xe3\x82\xbb" => "\xe3\x81\x9b", "\xe3\x82\xbc" => "\xe3\x81\x9c", + "\xe3\x82\xbd" => "\xe3\x81\x9d", "\xe3\x82\xbe" => "\xe3\x81\x9e", + "\xe3\x82\xbf" => "\xe3\x81\x9f", "\xe3\x83\x80" => "\xe3\x81\xa0", + "\xe3\x83\x81" => "\xe3\x81\xa1", "\xe3\x83\x82" => "\xe3\x81\xa2", + "\xe3\x83\x83" => "\xe3\x81\xa3", "\xe3\x83\x84" => "\xe3\x81\xa4", + "\xe3\x83\x85" => "\xe3\x81\xa5", "\xe3\x83\x86" => "\xe3\x81\xa6", + "\xe3\x83\x87" => "\xe3\x81\xa7", "\xe3\x83\x88" => "\xe3\x81\xa8", + "\xe3\x83\x89" => "\xe3\x81\xa9", "\xe3\x83\x8a" => "\xe3\x81\xaa", + "\xe3\x83\x8b" => "\xe3\x81\xab", "\xe3\x83\x8c" => "\xe3\x81\xac", + "\xe3\x83\x8d" => "\xe3\x81\xad", "\xe3\x83\x8e" => "\xe3\x81\xae", + "\xe3\x83\x8f" => "\xe3\x81\xaf", "\xe3\x83\x90" => "\xe3\x81\xb0", + "\xe3\x83\x91" => "\xe3\x81\xb1", "\xe3\x83\x92" => "\xe3\x81\xb2", + "\xe3\x83\x93" => "\xe3\x81\xb3", "\xe3\x83\x94" => "\xe3\x81\xb4", + "\xe3\x83\x95" => "\xe3\x81\xb5", "\xe3\x83\x96" => "\xe3\x81\xb6", + "\xe3\x83\x97" => "\xe3\x81\xb7", "\xe3\x83\x98" => "\xe3\x81\xb8", + "\xe3\x83\x99" => "\xe3\x81\xb9", "\xe3\x83\x9a" => "\xe3\x81\xba", + "\xe3\x83\x9b" => "\xe3\x81\xbb", "\xe3\x83\x9c" => "\xe3\x81\xbc", + "\xe3\x83\x9d" => "\xe3\x81\xbd", "\xe3\x83\x9e" => "\xe3\x81\xbe", + "\xe3\x83\x9f" => "\xe3\x81\xbf", "\xe3\x83\xa0" => "\xe3\x82\x80", + "\xe3\x83\xa1" => "\xe3\x82\x81", "\xe3\x83\xa2" => "\xe3\x82\x82", + "\xe3\x83\xa3" => "\xe3\x82\x83", "\xe3\x83\xa4" => "\xe3\x82\x84", + "\xe3\x83\xa5" => "\xe3\x82\x85", "\xe3\x83\xa6" => "\xe3\x82\x86", + "\xe3\x83\xa7" => "\xe3\x82\x87", "\xe3\x83\xa8" => "\xe3\x82\x88", + "\xe3\x83\xa9" => "\xe3\x82\x89", "\xe3\x83\xaa" => "\xe3\x82\x8a", + "\xe3\x83\xab" => "\xe3\x82\x8b", "\xe3\x83\xac" => "\xe3\x82\x8c", + "\xe3\x83\xad" => "\xe3\x82\x8d", "\xe3\x83\xae" => "\xe3\x82\x8e", + "\xe3\x83\xaf" => "\xe3\x82\x8f", "\xe3\x83\xb0" => "\xe3\x82\x90", + "\xe3\x83\xb1" => "\xe3\x82\x91", "\xe3\x83\xb2" => "\xe3\x82\x92", + "\xe3\x83\xb3" => "\xe3\x82\x93", +); + + +} +# ----------------------------------------------------------------------------- +# unijp(); +# +sub unijp +{ + Unicode::Japanese->new(@_); +} +# utf8 => utf8-jsky2 +sub _u2uj1 +{ + my $this = shift; + + if(!defined($eu2j1)) + { + $eu2j2 = $this->_getFile('jcode/emoji2/eu2j2.dat'); + } + + my $str = $this->_validate_utf8($this->{str}); + + $str =~ s{([\xf0-\xf7][\x80-\xbf]{3})}{ + my ($c1,$c2,$c3,$c4) = unpack("C4", $1); + my $ch = (($c1 & 0x07)<<18) | (($c2 & 0x3F)<<12) | + (($c3 & 0x3f)<< 6) | ($c4 & 0x3F); + if( 0x0fe000 <= $ch && $ch <= 0x0fffff ) + { + my $c = substr($eu2j1, ($ch - 0x0fe000) * 5, 5); + $c =~ tr,\0,,d; + $c eq '' and $c = '?'; + if( $c =~ /^\e\$([GEFOPQ])(.)\x0f/ ) + { + my ($j1,$j2) = ($1,$2); + $j1 =~ tr/GEF/\xe0-\xe5/; + $j2 =~ tr/!-z/\x01-\x5a/; + $c = $this->_ucs2_utf8($j1.$j2); + } + $c; + }else + { + '?'; + } + }ge; + $str; +} +# utf8 -> jis-au1 +sub _u2ja1 { + my $this = shift; + my $str = shift; + + if(!defined($str)) + { + return ''; + } + + if(!defined($u2s_table)) + { + $u2s_table = $this->_getFile('jcode/u2s.dat'); + } + + if(!defined($eu2a1s)) + { + $eu2a1s = $this->_getFile('jcode/emoji2/eu2as.dat'); + } + + my $c1; + my $c2; + my $c3; + my $c4; + my $c5; + my $c6; + my $c; + my $ch; + $str =~ s/([\xc0-\xdf][\x80-\xbf]|[\xe0-\xef][\x80-\xbf]{2}|[\xf0-\xf7][\x80-\xbf]{3}|[\xf8-\xfb][\x80-\xbf]{4}|[\xfc-\xfd][\x80-\xbf]{5})|([^\x00-\x7f])/ + defined($2) ? '?' : + ((length($1) == 1) ? $1 : + (length($1) == 2) ? ( + ($c1,$c2) = unpack("C2", $1), + $ch = (($c1 & 0x1F)<<6)|($c2 & 0x3F), + $c = substr($u2s_table, $ch * 2, 2), + ($c eq "\0\0") ? '?' : $c + ) : + (length($1) == 3) ? ( + ($c1,$c2,$c3) = unpack("C3", $1), + $ch = (($c1 & 0x0F)<<12)|(($c2 & 0x3F)<<6)|($c3 & 0x3F), + ( + ($ch <= 0x9fff) ? + $c = substr($u2s_table, $ch * 2, 2) : + ($ch >= 0xf900 and $ch <= 0xffff) ? + ( + $c = substr($u2s_table, ($ch - 0xf900 + 0xa000) * 2, 2), + (($c =~ tr,\0,,d)==2 and $c = "\0\0"), + ) : + ( + $c = '?' + ) + ), + ($c eq "\0\0") ? '?' : $c + ) : + (length($1) == 4) ? ( + ($c1,$c2,$c3,$c4) = unpack("C4", $1), + $ch = (($c1 & 0x07)<<18)|(($c2 & 0x3F)<<12)| + (($c3 & 0x3f) << 6)|($c4 & 0x3F), + ( + ($ch >= 0x0fe000 and $ch <= 0x0fffff) ? + ( + $c = substr($eu2a1s, ($ch - 0x0fe000) * 2, 2), + $c =~ tr,\0,,d, + ($c eq '') ? '?' : $c + ) : + '?' + ) + ) : + '?' + ) + /eg; + + $str; +} +sub _j2s { + my $this = shift; + my $str = shift; + + $str =~ s/($RE{JIS_0208}|$RE{JIS_0212}|$RE{JIS_ASC}|$RE{JIS_KANA})([^\e]*)/ + $this->_j2s2($1, $2) + /geo; + + $str; +} +# ----------------------------------------------------------------------------- +# $bytes_utf16 = $unijp->utf16(); +# +sub utf16 +{ + my $this = shift; + $this->_utf8_utf16($this->{str}); +} +sub utf8_jsky2 +{ + my $this = shift; + $this->_u2uj2($this->{str}); +} +# ----------------------------------------------------------------------------- +# AUʸѴ +# +# utf8AUʸѴ +sub _u2ai1 { + my $this = shift; + my $str = shift; + + if(!defined($str)) + { + return ''; + } + + if(!defined($eu2a1)) + { + $eu2a1 = $this->_getFile('jcode/emoji2/eu2a.dat'); + } + + my $c1; + my $c2; + my $c3; + my $c4; + my $c5; + my $c6; + my $c; + my $d; + my $ch; + $str =~ s/([\xc0-\xdf][\x80-\xbf]|[\xe0-\xef][\x80-\xbf]{2}|[\xf0-\xf7][\x80-\xbf]{3}|[\xf8-\xfb][\x80-\xbf]{4}|[\xfc-\xfd][\x80-\xbf]{5})|([^\x00-\x7f])/ + defined($2) ? '?' : + ((length($1) == 1) ? $1 : + (length($1) == 2) ? $1 : + (length($1) == 3) ? $1 : + (length($1) == 4) ? ( + ($c1,$c2,$c3,$c4) = unpack("C4", $1), + $ch = (($c1 & 0x07)<<18)|(($c2 & 0x3F)<<12)| + (($c3 & 0x3f) << 6)|($c4 & 0x3F), + ( + ($ch >= 0x0fe000 and $ch <= 0x0fffff) ? + ( + $c = substr($eu2a1, ($ch - 0x0fe000) * 2, 2), + $d = unpack('n', $c), + $c =~ tr,\0,,d, + ($d <= 0x0336) ? $RE{E_ICON_AU_START} . $d . $RE{E_ICON_AU_END} : + ($c eq '') ? '?' : $c + ) : + '?' + ) + ) : + '?' + ) + /eg; + + $str; +} +sub sjis_icon_au2 +{ + my $this = shift; + $this->_u2s($this->_u2ai2($this->{str})); +} +sub _u2si2 { + my $this = shift; + my $str = shift; + + if(!defined($str)) + { + return ''; + } + + if(!defined($u2s_table)) + { + $u2s_table = $this->_getFile('jcode/u2s.dat'); + } + + if(!defined($eu2i2)) + { + $eu2i2 = $this->_getFile('jcode/emoji2/eu2i2.dat'); + } + + my $c1; + my $c2; + my $c3; + my $c4; + my $c5; + my $c6; + my $c; + my $ch; + $str =~ s/([\xc0-\xdf][\x80-\xbf]|[\xe0-\xef][\x80-\xbf]{2}|[\xf0-\xf7][\x80-\xbf]{3}|[\xf8-\xfb][\x80-\xbf]{4}|[\xfc-\xfd][\x80-\xbf]{5})|([^\x00-\x7f])/ + defined($2) ? '?' : + ((length($1) == 1) ? $1 : + (length($1) == 2) ? ( + ($c1,$c2) = unpack("C2", $1), + $ch = (($c1 & 0x1F)<<6)|($c2 & 0x3F), + $c = substr($u2s_table, $ch * 2, 2), + ($c eq "\0\0") ? '?' : $c + ) : + (length($1) == 3) ? ( + ($c1,$c2,$c3) = unpack("C3", $1), + $ch = (($c1 & 0x0F)<<12)|(($c2 & 0x3F)<<6)|($c3 & 0x3F), + ( + ($ch <= 0x9fff) ? + $c = substr($u2s_table, $ch * 2, 2) : + ($ch >= 0xf900 and $ch <= 0xffff) ? + ( + $c = substr($u2s_table, ($ch - 0xf900 + 0xa000) * 2, 2), + (($c =~ tr,\0,,d)==2 and $c = "\0\0"), + ) : + ( + $c = '?' + ) + ), + ($c eq "\0\0") ? '?' : $c + ) : + (length($1) == 4) ? ( + ($c1,$c2,$c3,$c4) = unpack("C4", $1), + $ch = (($c1 & 0x07)<<18)|(($c2 & 0x3F)<<12)| + (($c3 & 0x3f) << 6)|($c4 & 0x3F), + ( + ($ch >= 0x0fe000 and $ch <= 0x0fffff) ? + ( + $c = substr($eu2i2, ($ch - 0x0fe000) * 2, 2), + $c =~ tr,\0,,d, + ($c eq '') ? '?' : $c + ) : + '?' + ) + ) : + '?' + ) + /eg; + $str; + +} +sub splitCsv { + my $this = shift; + my $text = $this->{str}; + my @field; + + chomp($text); + + while ($text =~ m/"([^"\\]*(?:(?:\\.|\"\")[^"\\]*)*)",?|([^,]+),?|,/g) { + my $field = defined($1) ? $1 : (defined($2) ? $2 : ''); + $field =~ s/["\\]"/"/g; + push(@field, $field); + } + push(@field, '') if($text =~ m/,$/); + + \@field; +} +sub sjis_jsky1 +{ + my $this = shift; + $this->_u2sj1($this->{str}); +} +sub _s2j3 { + my $this = shift; + my $c = shift; + + my ($c1, $c2) = unpack('CC', $c); + if (0x9f <= $c2) + { + $c1 = $c1 * 2 - ($c1 >= 0xe0 ? 0xe0 : 0x60); + $c2 += 2; + } + else + { + $c1 = $c1 * 2 - ($c1 >= 0xe0 ? 0xe1 : 0x61); + $c2 += 0x60 + ($c2 < 0x7f); + } + + $S2J[unpack('n', $c)] = pack('CC', $c1 - 0x80, $c2 - 0x80); +} +# sjis-au1 => utf8 +sub _sa2u1 { + my $this = shift; + my $str = shift; + + if(!defined($str)) + { + return ''; + } + + if(!defined($s2u_table)) + { + $s2u_table = $this->_getFile('jcode/s2u.dat'); + } + + if(!defined($ea2u1s)) + { + $ea2u1s = $this->_getFile('jcode/emoji2/ea2us.dat'); + } + + my $l; + my $uc; + $str =~ s/($RE{SJIS_KANA}|$RE{SJIS_DBCS}|[\x80-\xff])/ + $SA2U1{$1} + or ($SA2U1{$1} = + ( + $l = (unpack('n', $1) or unpack('C', $1)), + ( + ($l >= 0xa1 and $l <= 0xdf) ? + ( + $uc = substr($s2u_table, ($l - 0xa1) * 3, 3), + $uc =~ tr,\0,,d, + $uc + ) : + ($l >= 0x8100 and $l <= 0x9fff) ? + ( + $uc = substr($s2u_table, ($l - 0x8100 + 0x3f) * 3, 3), + $uc =~ tr,\0,,d, + $uc + ) : + ($l >= 0xeb00 and $l <= 0xeeff) ? + ( + $uc = substr($ea2u1s, ($l - 0xeb00) * 4, 4), + $uc =~ tr,\0,,d, + $uc + ) : + ($l >= 0xe000 and $l <= 0xfcff) ? + ( + $uc = substr($s2u_table, ($l - 0xe000 + 0x1f3f) * 3, 3), + $uc =~ tr,\0,,d, + $uc + ) : + ($l < 0x80) ? + chr($l) : + '?' + ) + ) + )/eg; + + $str; + +} +# ----------------------------------------------------------------------------- +# utf8 ==> sjis/ʸ +# +sub _u2s { + my $this = shift; + my $str = shift; + + if(!defined($str)) + { + return ''; + } + + if(!defined($u2s_table)) + { + $u2s_table = $this->_getFile('jcode/u2s.dat'); + } + + my $c1; + my $c2; + my $c3; + my $c4; + my $c5; + my $c6; + my $c; + my $ch; + $str =~ s/([\xc0-\xdf][\x80-\xbf]|[\xe0-\xef][\x80-\xbf]{2}|[\xf0-\xf7][\x80-\xbf]{3}|[\xf8-\xfb][\x80-\xbf]{4}|[\xfc-\xfd][\x80-\xbf]{5})|([^\x00-\x7f])/ + defined($2) ? '?' : ( + $U2S{$1} + or ($U2S{$1} + = ((length($1) == 1) ? $1 : + (length($1) == 2) ? ( + ($c1,$c2) = unpack("C2", $1), + $ch = (($c1 & 0x1F)<<6)|($c2 & 0x3F), + $c = substr($u2s_table, $ch * 2, 2), + # UTF-3Х(U+0x80-U+07FF)sjis-1ХȤؤΥޥåԥ󥰤ϤʤΤ\0ɬפϤʤ + $ch<0x80 ? '?' : ($c eq "\0\0") ? '&#' . $ch . ';' : $c + ) : + (length($1) == 3) ? ( + ($c1,$c2,$c3) = unpack("C3", $1), + $ch = (($c1 & 0x0F)<<12)|(($c2 & 0x3F)<<6)|($c3 & 0x3F), + ( + ($ch <= 0x9fff) ? + $c = substr($u2s_table, $ch * 2, 2) : + ($ch >= 0xf900 and $ch <= 0xffff) ? + ( + $c = substr($u2s_table, ($ch - 0xf900 + 0xa000) * 2, 2), + (($c =~ tr,\0,,d)==2 and $c = "\0\0"), + ) : + ( + $c = '&#' . $ch . ';' + ) + ), + $ch<0x0800 ? '?' : ($c eq "\0\0") ? '&#' . $ch . ';' : $c + ) : + (length($1) == 4) ? ( + ($c1,$c2,$c3,$c4) = unpack("C4", $1), + $ch = (($c1 & 0x07)<<18)|(($c2 & 0x3F)<<12)| + (($c3 & 0x3f) << 6)|($c4 & 0x3F), + ( + $ch <0x01_0000 ? '?' : + ($ch >= 0x0fe000 and $ch <= 0x0fffff) ? + '?' + : '&#' . $ch . ';' + ) + ) : + (length($1) == 5) ? (($c1,$c2,$c3,$c4,$c5) = unpack("C5", $1), + $ch = (($c1 & 0x03) << 24)|(($c2 & 0x3F) << 18)| + (($c3 & 0x3f) << 12)|(($c4 & 0x3f) << 6)| + ($c5 & 0x3F), + $ch<0x20_0000 ? '?' : '&#' . $ch . ';' + ) : + ( + ($c1,$c2,$c3,$c4,$c5,$c6) = unpack("C6", $1), + $ch = (($c1 & 0x03) << 30)|(($c2 & 0x3F) << 24)| + (($c3 & 0x3f) << 18)|(($c4 & 0x3f) << 12)| + (($c5 & 0x3f) << 6)|($c6 & 0x3F), + $ch<0x0400_0000 ? '?' : '&#' . $ch . ';' + ) + ) + ) + ) + /eg; + $str; + +} +sub _sa2j3 { + my $this = shift; + my $c = shift; + + my ($c1, $c2) = unpack('CC', $c); + $c1 = 0xeb if($c1 == 0xf6); + $c1 = 0xec if($c1 == 0xf7); + $c1 = 0xed if($c1 == 0xf3); + $c1 = 0xee if($c1 == 0xf4); + + if (0x9f <= $c2) + { + $c1 = $c1 * 2 - ($c1 >= 0xe0 ? 0xe0 : 0x60); + $c2 += 2; + } + else + { + $c1 = $c1 * 2 - ($c1 >= 0xe0 ? 0xe1 : 0x61); + $c2 += 0x60 + ($c2 < 0x7f); + } + + pack('CC', $c1 - 0x80, $c2 - 0x80); +} +sub _utf16_utf8 { + my $this = shift; + my $str = shift; + + if(!defined($str)) + { + return ''; + } + + my $result = ''; + my $sa; + foreach my $uc (unpack("n*", $str)) + { + ($uc >= 0xd800 and $uc <= 0xdbff and $sa = $uc and next); + + ($uc >= 0xdc00 and $uc <= 0xdfff and ($uc = ((($sa - 0xd800) << 10)|($uc - 0xdc00))+0x10000)); + + $result .= $U2T[$uc] ? $U2T[$uc] : + ($U2T[$uc] = ($uc < 0x80) ? chr($uc) : + ($uc < 0x800) ? chr(0xC0 | ($uc >> 6)) . chr(0x80 | ($uc & 0x3F)) : + ($uc < 0x10000) ? chr(0xE0 | ($uc >> 12)) . chr(0x80 | (($uc >> 6) & 0x3F)) . chr(0x80 | ($uc & 0x3F)) : + chr(0xF0 | ($uc >> 18)) . chr(0x80 | (($uc >> 12) & 0x3F)) . chr(0x80 | (($uc >> 6) & 0x3F)) . chr(0x80 | ($uc & 0x3F))); + } + + $result; +} +sub h2zNum { + my $this = shift; + + if(!defined(%_h2zNum)) + { + $this->_loadConvTable; + } + + $this->{str} =~ s/(0|1|2|3|4|5|6|7|8|9)/$_h2zNum{$1}/eg; + + $this; +} +sub h2zKanaK { + my $this = shift; + + if(!defined(%_h2zKanaK)) + { + $this->_loadConvTable; + } + + $this->{str} =~ s/(\xef\xbd\xa1|\xef\xbd\xa2|\xef\xbd\xa3|\xef\xbd\xa4|\xef\xbd\xa5|\xef\xbd\xa6|\xef\xbd\xa7|\xef\xbd\xa8|\xef\xbd\xa9|\xef\xbd\xaa|\xef\xbd\xab|\xef\xbd\xac|\xef\xbd\xad|\xef\xbd\xae|\xef\xbd\xaf|\xef\xbd\xb0|\xef\xbd\xb1|\xef\xbd\xb2|\xef\xbd\xb3|\xef\xbd\xb4|\xef\xbd\xb5|\xef\xbd\xb6|\xef\xbd\xb7|\xef\xbd\xb8|\xef\xbd\xb9|\xef\xbd\xba|\xef\xbd\xbb|\xef\xbd\xbc|\xef\xbd\xbd|\xef\xbd\xbe|\xef\xbd\xbf|\xef\xbe\x80|\xef\xbe\x81|\xef\xbe\x82|\xef\xbe\x83|\xef\xbe\x84|\xef\xbe\x85|\xef\xbe\x86|\xef\xbe\x87|\xef\xbe\x88|\xef\xbe\x89|\xef\xbe\x8a|\xef\xbe\x8b|\xef\xbe\x8c|\xef\xbe\x8d|\xef\xbe\x8e|\xef\xbe\x8f|\xef\xbe\x90|\xef\xbe\x91|\xef\xbe\x92|\xef\xbe\x93|\xef\xbe\x94|\xef\xbe\x95|\xef\xbe\x96|\xef\xbe\x97|\xef\xbe\x98|\xef\xbe\x99|\xef\xbe\x9a|\xef\xbe\x9b|\xef\xbe\x9c|\xef\xbe\x9d|\xef\xbe\x9e|\xef\xbe\x9f)/$_h2zKanaK{$1}/eg; + + $this; +} +sub strlen { + my $this = shift; + + my $ch_re = '[\x00-\x7f]|[\xc0-\xdf][\x80-\xbf]|[\xe0-\xef][\x80-\xbf]{2}|[\xf0-\xf7][\x80-\xbf]{3}|[\xf8-\xfb][\x80-\xbf]{4}|[\xfc-\xfd][\x80-\xbf]{5}'; + my $length = 0; + + foreach my $c(split(/($ch_re)/,$this->{str})) { + next if(length($c) == 0); + $length += ((length($c) >= 3) ? 2 : 1); + } + + return $length; +} +sub strcutu +{ + my $this = shift; + my $result = &strcut; + + if( $]>=5.008 && $this->{icode} ne 'binary' ) + { + foreach(@$result) + { + Encode::_utf8_on($_); + } + } + + $result; +} +sub sjis_imode2 +{ + my $this = shift; + $this->_u2si2($this->{str}); +} +sub _validate_utf8 +{ + my $pkg = shift; + my $str = shift; + + # ŬڤǤʤĹ˥󥳡ɤƤ + # ʸ ? ֤. + defined($str) and $str =~ s{ + # 2 bytes char which is restricted 1 byte. + # + [\xc0-\xc1] [\x80-\xbf] + | + # 3 bytes char which is restricted <= 2 bytes. + # + \xe0 [\x80-\x9f] [\x80-\xbf] + | + # 4 bytes char which is restricted <= 3 bytes. + # + \xf0 [\x80-\x8f] [\x80-\xbf] [\x80-\xbf] + | + # > U+10FFFF (4byte) + # + \xf4 [\x90-\xbf] [\x80-\xbf] [\x80-\xbf] + |[\xf5-\xf7] [\x80-\xbf] [\x80-\xbf] [\x80-\xbf] + | + # > U+10FFFF (5byte) + # + [\xf8-\xfb] [\x80-\xbf] [\x80-\xbf] [\x80-\xbf] [\x80-\xbf] + | + # > U+10FFFF (6byte) + # + [\xfc-\xfd] [\x80-\xbf] [\x80-\xbf] [\x80-\xbf] [\x80-\xbf] [\x80-\xbf] + }{?}xg; + $str; +} +# ----------------------------------------------------------------------------- +# $unijp->set($str,[$icode,[$encode]]); +# +sub set +{ + my $this = shift; + my $str = shift; + my $icode = shift; + my $encode = shift; + + if(ref($str)) + { + die "String->set, Param[1] is Ref.\n"; + } + if(ref($icode)) + { + die "String->set, Param[2] is Ref.\n"; + } + if(ref($encode)) + { + die "String->set, Param[3] is Ref.\n"; + } + + if( $]>=5.008 ) + { + Encode::_utf8_off($str); + } + + if(defined($encode)) + { + if($encode eq 'base64') + { + $str = $this->_decodeBase64($str); + } + else + { + die "String->set, Param[3] encode name error.\n"; + } + } + + if(!defined($icode)) + { # omitted then 'utf8' + $this->{str} = $this->_validate_utf8($str); + $this->{icode} = 'utf8'; + } + else + { + $icode = lc($icode); + if($icode eq 'auto') + { + $icode = $this->getcode($str); + if($icode eq 'unknown') + { + $icode = 'binary'; + } + } + + if($icode eq 'utf8') + { + $this->{str} = $this->_validate_utf8($str); + } + elsif($icode eq 'ucs2') + { + $this->{str} = $this->_ucs2_utf8($str); + } + elsif($icode eq 'ucs4') + { + $this->{str} = $this->_ucs4_utf8($str); + } + elsif($icode eq 'utf16-be') + { + $this->{str} = $this->_utf16_utf8($this->_utf16be_utf16($str)); + } + elsif($icode eq 'utf16-le') + { + $this->{str} = $this->_utf16_utf8($this->_utf16le_utf16($str)); + } + elsif($icode eq 'utf16') + { + $this->{str} = $this->_utf16_utf8($this->_utf16_utf16($str)); + } + elsif($icode eq 'utf32-be') + { + $this->{str} = $this->_ucs4_utf8($this->_utf32be_ucs4($str)); + } + elsif($icode eq 'utf32-le') + { + $this->{str} = $this->_ucs4_utf8($this->_utf32le_ucs4($str)); + } + elsif($icode eq 'utf32') + { + $this->{str} = $this->_ucs4_utf8($this->_utf32_ucs4($str)); + } + elsif($icode eq 'jis') + { + $this->{str} = $this->_s2u($this->_j2s($str)); + } + elsif($icode eq 'euc' || $icode eq 'euc-jp') + { + $this->{str} = $this->_s2u($this->_e2s($str)); + } + elsif($icode eq 'sjis' || $icode eq 'cp932') + { + $this->{str} = $this->_s2u($str); + } + elsif($icode eq 'sjis-imode') + { + $this->{str} = $this->_si2u2($str); + } + elsif($icode eq 'sjis-imode1') + { + $this->{str} = $this->_si2u1($str); + } + elsif($icode eq 'sjis-imode2') + { + $this->{str} = $this->_si2u2($str); + } + elsif($icode eq 'sjis-doti') + { + $this->{str} = $this->_sd2u($str); + } + elsif($icode eq 'sjis-doti1') + { + $this->{str} = $this->_sd2u($str); + } + elsif($icode eq 'sjis-jsky') + { + $this->{str} = $this->_sj2u2($str); + } + elsif($icode eq 'sjis-jsky1') + { + $this->{str} = $this->_sj2u1($str); + } + elsif($icode eq 'sjis-jsky2') + { + $this->{str} = $this->_sj2u2($str); + } + elsif($icode eq 'jis-jsky') + { + $this->{str} = $this->_sj2u2($this->_j2s($str)); + } + elsif($icode eq 'jis-jsky1') + { + $this->{str} = $this->_sj2u1($this->_j2s($str)); + } + elsif($icode eq 'jis-jsky2') + { + $this->{str} = $this->_sj2u2($this->_j2s($str)); + } + elsif($icode eq 'utf8-jsky') + { + $this->{str} = $this->_uj2u2($str); + } + elsif($icode eq 'utf8-jsky1') + { + $this->{str} = $this->_uj2u1($str); + } + elsif($icode eq 'utf8-jsky2') + { + $this->{str} = $this->_uj2u2($str); + } + elsif($icode eq 'jis-au') + { + $this->{str} = $this->_sa2u2($this->_j2s($str)); + } + elsif($icode eq 'jis-au1') + { + $this->{str} = $this->_sa2u1($this->_j2s($str)); + } + elsif($icode eq 'jis-au2') + { + $this->{str} = $this->_sa2u2($this->_j2s($str)); + } + elsif($icode eq 'sjis-au') + { + $this->{str} = $this->_sa2u2($this->_j2s($this->_sa2j($str))); + } + elsif($icode eq 'sjis-au1') + { + $this->{str} = $this->_sa2u1($this->_j2s($this->_sa2j($str))); + } + elsif($icode eq 'sjis-au2') + { + $this->{str} = $this->_sa2u2($this->_j2s($this->_sa2j($str))); + } + elsif($icode eq 'sjis-icon-au') + { + $this->{str} = $this->_ai2u2($this->_s2u($str)); + } + elsif($icode eq 'sjis-icon-au1') + { + $this->{str} = $this->_ai2u1($this->_s2u($str)); + } + elsif($icode eq 'sjis-icon-au2') + { + $this->{str} = $this->_ai2u2($this->_s2u($str)); + } + elsif($icode eq 'euc-icon-au') + { + $this->{str} = $this->_ai2u2($this->_s2u($this->_e2s($str))); + } + elsif($icode eq 'euc-icon-au1') + { + $this->{str} = $this->_ai2u1($this->_s2u($this->_e2s($str))); + } + elsif($icode eq 'euc-icon-au2') + { + $this->{str} = $this->_ai2u2($this->_s2u($this->_e2s($str))); + } + elsif($icode eq 'jis-icon-au') + { + $this->{str} = $this->_ai2u2($this->_s2u($this->_j2s($str))); + } + elsif($icode eq 'jis-icon-au1') + { + $this->{str} = $this->_ai2u1($this->_s2u($this->_j2s($str))); + } + elsif($icode eq 'jis-icon-au2') + { + $this->{str} = $this->_ai2u2($this->_s2u($this->_j2s($str))); + } + elsif($icode eq 'utf8-icon-au') + { + $this->{str} = $this->_ai2u2($str); + } + elsif($icode eq 'utf8-icon-au1') + { + $this->{str} = $this->_ai2u1($str); + } + elsif($icode eq 'utf8-icon-au2') + { + $this->{str} = $this->_ai2u2($str); + } + elsif($icode eq 'ascii') + { + $this->{str} = $str; + } + elsif($icode eq 'binary') + { + $this->{str} = $str; + } + else + { + use Carp; + croak "icode error [$icode]"; + } + $this->{icode} = $icode; + } + + $this; +} +# ----------------------------------------------------------------------------- +# Unicode Ѵ +# +sub _ucs2_utf8 { + my $this = shift; + my $str = shift; + + if(!defined($str)) + { + return ''; + } + + my $result = ''; + for my $uc (unpack("n*", $str)) + { + $result .= $U2T[$uc] ? $U2T[$uc] : + ($U2T[$uc] = ($uc < 0x80) ? chr($uc) : + ($uc < 0x800) ? chr(0xC0 | ($uc >> 6)) . chr(0x80 | ($uc & 0x3F)) : + chr(0xE0 | ($uc >> 12)) . chr(0x80 | (($uc >> 6) & 0x3F)) . + chr(0x80 | ($uc & 0x3F))); + } + + $result; +} +sub _utf16_utf16 { + my $this = shift; + my $str = shift; + + if($str =~ s/^\xfe\xff//) + { + $str = $this->_utf16be_utf16($str); + } + elsif($str =~ s/^\xff\xfe//) + { + $str = $this->_utf16le_utf16($str); + } + else + { + $str = $this->_utf16be_utf16($str); + } + + $str; +} +sub h2zAlpha { + my $this = shift; + + if(!defined(%_h2zAlpha)) + { + $this->_loadConvTable; + } + + $this->{str} =~ s/(A|B|C|D|E|F|G|H|I|J|K|L|M|N|O|P|Q|R|S|T|U|V|W|X|Y|Z|a|b|c|d|e|f|g|h|i|j|k|l|m|n|o|p|q|r|s|t|u|v|w|x|y|z)/$_h2zAlpha{$1}/eg; + + $this; +} +sub z2hKanaK { + my $this = shift; + + if(!defined(%_z2hKanaK)) + { + $this->_loadConvTable; + } + + $this->{str} =~ s/(\xe3\x80\x81|\xe3\x80\x82|\xe3\x83\xbb|\xe3\x82\x9b|\xe3\x82\x9c|\xe3\x83\xbc|\xe3\x80\x8c|\xe3\x80\x8d|\xe3\x82\xa1|\xe3\x82\xa2|\xe3\x82\xa3|\xe3\x82\xa4|\xe3\x82\xa5|\xe3\x82\xa6|\xe3\x82\xa7|\xe3\x82\xa8|\xe3\x82\xa9|\xe3\x82\xaa|\xe3\x82\xab|\xe3\x82\xad|\xe3\x82\xaf|\xe3\x82\xb1|\xe3\x82\xb3|\xe3\x82\xb5|\xe3\x82\xb7|\xe3\x82\xb9|\xe3\x82\xbb|\xe3\x82\xbd|\xe3\x82\xbf|\xe3\x83\x81|\xe3\x83\x83|\xe3\x83\x84|\xe3\x83\x86|\xe3\x83\x88|\xe3\x83\x8a|\xe3\x83\x8b|\xe3\x83\x8c|\xe3\x83\x8d|\xe3\x83\x8e|\xe3\x83\x8f|\xe3\x83\x92|\xe3\x83\x95|\xe3\x83\x98|\xe3\x83\x9b|\xe3\x83\x9e|\xe3\x83\x9f|\xe3\x83\xa0|\xe3\x83\xa1|\xe3\x83\xa2|\xe3\x83\xa3|\xe3\x83\xa4|\xe3\x83\xa5|\xe3\x83\xa6|\xe3\x83\xa7|\xe3\x83\xa8|\xe3\x83\xa9|\xe3\x83\xaa|\xe3\x83\xab|\xe3\x83\xac|\xe3\x83\xad|\xe3\x83\xaf|\xe3\x83\xb2|\xe3\x83\xb3)/$_z2hKanaK{$1}/eg; + + $this; +} +# ----------------------------------------------------------------------------- +# @codelist = Unicode::Japanese->getcodelist($str); +# +sub getcodelist { + my $this = shift; + my $str = shift; + my @codelist; + + if( $]>=5.008 ) + { + Encode::_utf8_off($str); + } + + my $l = length($str); + + if((($l % 4) == 0) + and ($str =~ m/^(?:$RE{BOM4_BE}|$RE{BOM4_LE})/o)) + { + push(@codelist, 'utf32'); + } + if((($l % 2) == 0) + and ($str =~ m/^(?:$RE{BOM2_BE}|$RE{BOM2_LE})/o)) + { + push(@codelist, 'utf16'); + } + + my $str2; + + if(($l % 4) == 0) + { + $str2 = $str; + 1 while($str2 =~ s/^(?:$RE{UTF32_BE})//o); + if($str2 eq '') + { + push(@codelist, 'utf32-be'); + } + + $str2 = $str; + 1 while($str2 =~ s/^(?:$RE{UTF32_LE})//o); + if($str2 eq '') + { + push(@codelist, 'utf32-le'); + } + } + + if($str !~ m/[\e\x80-\xff]/) + { + push(@codelist, 'ascii'); + } + + if($str =~ m/$RE{JIS_0208}|$RE{JIS_0212}|$RE{JIS_ASC}|$RE{JIS_KANA}/o) + { + if($str =~ m/(?:$RE{JIS_0208})(?:[^\e]{2})*$RE{E_JIS_AU}/o) + { + push(@codelist, 'jis-au'); + } + elsif($str =~ m/(?:$RE{E_JSKY})/o) + { + push(@codelist, 'jis-jsky'); + } + else + { + push(@codelist, 'jis'); + } + } + + if($str =~ m/(?:$RE{E_JSKY})/o) + { + push(@codelist, 'sjis-jsky'); + } + + $str2 = $str; + 1 while($str2 =~ s/^(?:$RE{ASCII}|$RE{EUC_0212}|$RE{EUC_KANA}|$RE{EUC_C})//o); + if($str2 eq '') + { + push(@codelist, 'euc'); + } + + $str2 = $str; + 1 while($str2 =~ s/^(?:$RE{ASCII}|$RE{SJIS_DBCS}|$RE{SJIS_KANA})//o); + if($str2 eq '') + { + push(@codelist, 'sjis'); + } + if($str =~ m/^(?:$RE{E_SJIS_AU})/o) + { + push(@codelist, 'sjis-au'); + } + + my $str3; + $str3 = $str2; + 1 while($str3 =~ s/^(?:$RE{ASCII}|$RE{SJIS_DBCS}|$RE{SJIS_KANA}|$RE{E_IMODE})//o); + if($str3 eq '') + { + push(@codelist, 'sjis-imode'); + } + + $str3 = $str2; + 1 while($str3 =~ s/^(?:$RE{ASCII}|$RE{SJIS_DBCS}|$RE{SJIS_KANA}|$RE{E_DOTI})//o); + if($str3 eq '') + { + push(@codelist, 'sjis-doti'); + } + + $str2 = $str; + 1 while($str2 =~ s/^(?:$RE{UTF8})//o); + if($str2 eq '') + { + push(@codelist, 'utf8'); + } + + @codelist or push(@codelist, 'unknown'); + @codelist; +} +sub _sj2u2 { + my $this = shift; + my $str = shift; + + if(!defined($str)) + { + return ''; + } + + if(!defined($s2u_table)) + { + $s2u_table = $this->_getFile('jcode/s2u.dat'); + } + + if(!defined($ej2u1)) + { + $ej2u1 = $this->_getFile('jcode/emoji2/ej2u.dat'); + } + if(!defined($ej2u2)) + { + $ej2u2 = $this->_getFile('jcode/emoji2/ej2u2.dat'); + } + + my $l; + my $j1; + my $uc; + $str =~ s/($RE{SJIS_KANA}|$RE{SJIS_DBCS}|$RE{E_JSKY}|[\x80-\xff])/ + (length($1) <= 2) ? + ( + $l = (unpack('n', $1) or unpack('C', $1)), + ( + ($l >= 0xa1 and $l <= 0xdf) ? + ( + $uc = substr($s2u_table, ($l - 0xa1) * 3, 3), + $uc =~ tr,\0,,d, + $uc + ) : + ($l >= 0x8100 and $l <= 0x9fff) ? + ( + $uc = substr($s2u_table, ($l - 0x8100 + 0x3f) * 3, 3), + $uc =~ tr,\0,,d, + $uc + ) : + ($l >= 0xe000 and $l <= 0xffff) ? + ( + $uc = substr($s2u_table, ($l - 0xe000 + 0x1f3f) * 3, 3), + $uc =~ tr,\0,,d, + $uc + ) : + ($l < 0x80) ? + chr($l) : + '?' + ) + ) : + ( + $l = $1, + ( $l =~ s,^$RE{E_JSKY_START}($RE{E_JSKY1v1}),,o + ? + ( + $j1 = $1, + $uc = '', + $l =~ s!($RE{E_JSKY2})!$uc .= substr($ej2u1, (unpack('n', $j1 . $1) - 0x4500) * 4, 4), ''!ego, + $uc =~ tr,\0,,d, + $uc + ) + : + ( + $l =~ s,^$RE{E_JSKY_START}($RE{E_JSKY1v2}),,o, + $j1 = $1, + $uc = '', + $l =~ s!($RE{E_JSKY2})!$uc .= substr($ej2u2, (unpack('n', $j1 . $1) - 0x4f00) * 4, 4), ''!ego, + $uc =~ tr,\0,,d, + $uc + ) + ) + ) + /eg; + + $str; + +} +sub jis_icon_au +{ + my $this = shift; + $this->_s2j($this->_u2s($this->_u2ai2($this->{str}))); +} +sub _utf32_ucs4 { + my $this = shift; + my $str = shift; + + if($str =~ s/^\x00\x00\xfe\xff//) + { + $str = $this->_utf32be_ucs4($str); + } + elsif($str =~ s/^\xff\xfe\x00\x00//) + { + $str = $this->_utf32le_ucs4($str); + } + else + { + $str = $this->_utf32be_ucs4($str); + } + + $str; +} +sub _ai2u2 { + my $this = shift; + my $str = shift; + + if(!defined($str)) + { + return ''; + } + + if(!defined($ea2u2)) + { + $ea2u2 = $this->_getFile('jcode/emoji2/ea2u2.dat'); + } + + my $c; + $str =~ s/$RE{E_ICON_AU_START}(\d+)$RE{E_ICON_AU_END}/ + ($1 > 0 and $1 <= 0x0336) ? + ($c = substr($ea2u2, ($1-1) * 4, 4), $c =~ tr,\0,,d, ($c eq '') ? '?' : $c) : + '?' + /ige; + + $str; +} +sub utf8_icon_au2 +{ + my $this = shift; + $this->_u2ai2($this->{str}); +} +# utf8-jsky1 => utf8. +sub _uj2u1 { + my $this = shift; + my $str = shift; + + if(!defined($str)) + { + return ''; + } + + if(!defined($s2u_table)) + { + $s2u_table = $this->_getFile('jcode/s2u.dat'); + } + + if(!defined($ej2u1)) + { + $ej2u1 = $this->_getFile('jcode/emoji2/ej2u.dat'); + } + + $str = $this->_validate_utf8($str); + + my @umap = (0x200, 0x000, 0x100); + $str =~ s{($RE{E_JSKYv1_UTF8}+)}{ + join('', + map{ + my $l = $_ - 0xe000 + 0x20; + substr($ej2u1, ($umap[$l/256]+($l&255)) * 4, 4); + } unpack("n*", $this->_utf8_ucs2($1)) + ) + }geo; + + $str; + +} +sub _sa2j { + my $this = shift; + my $str = shift; + + $str =~ s/((?:$RE{SJIS_DBCS}|$RE{E_SJIS_AU}|$RE{SJIS_KANA})+)/ + $this->_sa2j2($1) . $ESC{ASC} + /geo; + + $str; +} +# ----------------------------------------------------------------------------- +# h2z/z2h Kana +# +sub h2zKana +{ + my $this = shift; + + $this->h2zKanaD; + $this->h2zKanaK; + + $this; +} +sub z2hKana +{ + my $this = shift; + + $this->z2hKanaD; + $this->z2hKanaK; + + $this; +} +sub _si2u2 { + my $this = shift; + my $str = shift; + + if(!defined($str)) + { + return ''; + } + + if(!defined($s2u_table)) + { + $s2u_table = $this->_getFile('jcode/s2u.dat'); + } + + if(!defined($ei2u2)) + { + $ei2u2 = $this->_getFile('jcode/emoji2/ei2u2.dat'); + } + + $str =~ s/(\&\#(\d+);)/ + ($2 >= 0xf800 and $2 <= 0xf9ff) ? pack('n', $2) : $1 + /eg; + + my $l; + my $uc; + $str =~ s/($RE{SJIS_KANA}|$RE{SJIS_DBCS}|$RE{E_IMODE}|[\x80-\xff])/ + $S2U{$1} + or ($S2U{$1} = + ( + $l = (unpack('n', $1) or unpack('C', $1)), + ( + ($l >= 0xa1 and $l <= 0xdf) ? + ( + $uc = substr($s2u_table, ($l - 0xa1) * 3, 3), + $uc =~ tr,\0,,d, + $uc + ) : + ($l >= 0x8100 and $l <= 0x9fff) ? + ( + $uc = substr($s2u_table, ($l - 0x8100 + 0x3f) * 3, 3), + $uc =~ tr,\0,,d, + $uc + ) : + ($l >= 0xf800 and $l <= 0xf9ff) ? + ( + $uc = substr($ei2u2, ($l - 0xf800) * 4, 4), + $uc =~ tr,\0,,d, + $uc + ) : + ($l >= 0xe000 and $l <= 0xffff) ? + ( + $uc = substr($s2u_table, ($l - 0xe000 + 0x1f3f) * 3, 3), + $uc =~ tr,\0,,d, + $uc + ) : + ($l < 0x80) ? + chr($l) : + '?' + ) + ) + )/eg; + + $str; + +} +sub _u2sj1 { + my $this = shift; + my $str = shift; + + if(!defined($str)) + { + return ''; + } + + if(!defined($u2s_table)) + { + $u2s_table = $this->_getFile('jcode/u2s.dat'); + } + + if(!defined($eu2j1)) + { + $eu2j1 = $this->_getFile('jcode/emoji2/eu2j.dat'); + } + + my $c1; + my $c2; + my $c3; + my $c4; + my $c5; + my $c6; + my $c; + my $ch; + $str =~ s/([\xc0-\xdf][\x80-\xbf]|[\xe0-\xef][\x80-\xbf]{2}|[\xf0-\xf7][\x80-\xbf]{3}|[\xf8-\xfb][\x80-\xbf]{4}|[\xfc-\xfd][\x80-\xbf]{5})|([^\x00-\x7f])/ + defined($2) ? '?' : + ((length($1) == 1) ? $1 : + (length($1) == 2) ? ( + ($c1,$c2) = unpack("C2", $1), + $ch = (($c1 & 0x1F)<<6)|($c2 & 0x3F), + $c = substr($u2s_table, $ch * 2, 2), + ($c eq "\0\0") ? '?' : $c + ) : + (length($1) == 3) ? ( + ($c1,$c2,$c3) = unpack("C3", $1), + $ch = (($c1 & 0x0F)<<12)|(($c2 & 0x3F)<<6)|($c3 & 0x3F), + ( + ($ch <= 0x9fff) ? + $c = substr($u2s_table, $ch * 2, 2) : + ($ch >= 0xf900 and $ch <= 0xffff) ? + ( + $c = substr($u2s_table, ($ch - 0xf900 + 0xa000) * 2, 2), + (($c =~ tr,\0,,d)==2 and $c = "\0\0"), + ) : + ( + $c = '?' + ) + ), + ($c eq "\0\0") ? '?' : $c + ) : + (length($1) == 4) ? ( + ($c1,$c2,$c3,$c4) = unpack("C4", $1), + $ch = (($c1 & 0x07)<<18)|(($c2 & 0x3F)<<12)| + (($c3 & 0x3f) << 6)|($c4 & 0x3F), + ( + ($ch >= 0x0fe000 and $ch <= 0x0fffff) ? + ( + $c = substr($eu2j1, ($ch - 0x0fe000) * 5, 5), + $c =~ tr,\0,,d, + ($c eq '') ? '?' : $c + ) : + '?' + ) + ) : + '?' + ) + /eg; + + 1 while($str =~ s/($RE{E_JSKY_START})($RE{E_JSKY1})($RE{E_JSKY2}+)$RE{E_JSKY_END}$RE{E_JSKY_START}\2($RE{E_JSKY2})($RE{E_JSKY_END})/$1$2$3$4$5/o); + + $str; + +} +# utf8 => utf8-jsky1 +sub _u2sj2 { + my $this = shift; + my $str = shift; + + if(!defined($str)) + { + return ''; + } + + if(!defined($u2s_table)) + { + $u2s_table = $this->_getFile('jcode/u2s.dat'); + } + + if(!defined($eu2j2)) + { + $eu2j2 = $this->_getFile('jcode/emoji2/eu2j2.dat'); + } + + my $c1; + my $c2; + my $c3; + my $c4; + my $c5; + my $c6; + my $c; + my $ch; + $str =~ s/([\xc0-\xdf][\x80-\xbf]|[\xe0-\xef][\x80-\xbf]{2}|[\xf0-\xf7][\x80-\xbf]{3}|[\xf8-\xfb][\x80-\xbf]{4}|[\xfc-\xfd][\x80-\xbf]{5})|([^\x00-\x7f])/ + defined($2) ? '?' : + ((length($1) == 1) ? $1 : + (length($1) == 2) ? ( + ($c1,$c2) = unpack("C2", $1), + $ch = (($c1 & 0x1F)<<6)|($c2 & 0x3F), + $c = substr($u2s_table, $ch * 2, 2), + ($c eq "\0\0") ? '?' : $c + ) : + (length($1) == 3) ? ( + ($c1,$c2,$c3) = unpack("C3", $1), + $ch = (($c1 & 0x0F)<<12)|(($c2 & 0x3F)<<6)|($c3 & 0x3F), + ( + ($ch <= 0x9fff) ? + $c = substr($u2s_table, $ch * 2, 2) : + ($ch >= 0xf900 and $ch <= 0xffff) ? + ( + $c = substr($u2s_table, ($ch - 0xf900 + 0xa000) * 2, 2), + (($c =~ tr,\0,,d)==2 and $c = "\0\0"), + ) : + ( + $c = '?' + ) + ), + ($c eq "\0\0") ? '?' : $c + ) : + (length($1) == 4) ? ( + ($c1,$c2,$c3,$c4) = unpack("C4", $1), + $ch = (($c1 & 0x07)<<18)|(($c2 & 0x3F)<<12)| + (($c3 & 0x3f) << 6)|($c4 & 0x3F), + ( + ($ch >= 0x0fe000 and $ch <= 0x0fffff) ? + ( + $c = substr($eu2j2, ($ch - 0x0fe000) * 5, 5), + $c =~ tr,\0,,d, + ($c eq '') ? '?' : $c + ) : + '?' + ) + ) : + '?' + ) + /eg; + + 1 while($str =~ s/($RE{E_JSKY_START})($RE{E_JSKY1})($RE{E_JSKY2}+)$RE{E_JSKY_END}$RE{E_JSKY_START}\2($RE{E_JSKY2})($RE{E_JSKY_END})/$1$2$3$4$5/o); + + $str; + +} +sub utf8_icon_au +{ + my $this = shift; + $this->_u2ai2($this->{str}); +} +sub jis_jsky2 +{ + my $this = shift; + $this->_s2j($this->_u2sj2($this->{str})); +} +# ----------------------------------------------------------------------------- +# $bytes_doti = $unijp->sjis_doti(); +# +sub sjis_doti +{ + my $this = shift; + $this->_u2sd($this->{str}); +} +sub _e2s { + my $this = shift; + my $str = shift; + + $str =~ s/($RE{EUC_KANA}|$RE{EUC_0212}|$RE{EUC_C})/ + $E2S[unpack('n', $1) or unpack('N', "\0" . $1)] or $this->_e2s2($1) + /geo; + + $str; +} +# ----------------------------------------------------------------------------- +# $bytes_eucjp = $unijp->euc(); +# +sub euc +{ + my $this = shift; + $this->_s2e($this->sjis); +} +sub _j2s3 { + my $this = shift; + my $c = shift; + + my ($c1, $c2) = unpack('CC', $c); + if ($c1 % 2) + { + $c1 = ($c1>>1) + ($c1 < 0xdf ? 0x31 : 0x71); + $c2 -= 0x60 + ($c2 < 0xe0); + } + else + { + $c1 = ($c1>>1) + ($c1 < 0xdf ? 0x30 : 0x70); + $c2 -= 2; + } + + $J2S[unpack('n', $c)] = pack('CC', $c1, $c2); +} +sub _j2sa2 { + my $this = shift; + my $esc = shift; + my $str = shift; + + if($esc eq $ESC{JIS_0212}) + { + $str =~ s/../$CHARCODE{UNDEF_SJIS}/g; + } + elsif($esc !~ m/^$RE{JIS_ASC}/) + { + $str =~ s{([\x21-\x7e]+)}{ + my $str = $1; + $str =~ tr/\x21-\x7e/\xa1-\xfe/; + if($esc =~ m/^$RE{JIS_0208}/) + { + $str =~ s/($RE{EUC_C})/ + $this->_j2sa3($1) + /geo; + } + $str; + }e; + } + + $str; +} +# ----------------------------------------------------------------------------- +# $bytes_ucs4 = $unijp->ucs4(); +# +sub ucs4 +{ + my $this = shift; + $this->_utf8_ucs4($this->{str}); +} +sub _sd2u { + my $this = shift; + my $str = shift; + + if(!defined($str)) + { + return ''; + } + + if(!defined($s2u_table)) + { + $s2u_table = $this->_getFile('jcode/s2u.dat'); + } + + if(!defined($ed2u)) + { + $ed2u = $this->_getFile('jcode/emoji2/ed2u.dat'); + } + + $str =~ s/(\&\#(\d+);)/ + ($2 >= 0xf000 and $2 <= 0xf4ff) ? pack('n', $2) : $1 + /eg; + + my $l; + my $uc; + $str =~ s/($RE{SJIS_KANA}|$RE{SJIS_DBCS}|$RE{E_DOTI}|[\x80-\xff])/ + $S2U{$1} + or ($S2U{$1} = + ( + $l = (unpack('n', $1) or unpack('C', $1)), + ( + ($l >= 0xa1 and $l <= 0xdf) ? + ( + $uc = substr($s2u_table, ($l - 0xa1) * 3, 3), + $uc =~ tr,\0,,d, + $uc + ) : + ($l >= 0x8100 and $l <= 0x9fff) ? + ( + $uc = substr($s2u_table, ($l - 0x8100 + 0x3f) * 3, 3), + $uc =~ tr,\0,,d, + $uc + ) : + ($l >= 0xf000 and $l <= 0xf4ff) ? + ( + $uc = substr($ed2u, ($l - 0xf000) * 4, 4), + $uc =~ tr,\0,,d, + $uc + ) : + ($l >= 0xe000 and $l <= 0xffff) ? + ( + $uc = substr($s2u_table, ($l - 0xe000 + 0x1f3f) * 3, 3), + $uc =~ tr,\0,,d, + $uc + ) : + ($l < 0x80) ? + chr($l) : + '?' + ) + ) + )/eg; + + $str; + +} +# utf8 -> jis-au2 +sub _u2ja2 { + my $this = shift; + my $str = shift; + + if(!defined($str)) + { + return ''; + } + + if(!defined($u2s_table)) + { + $u2s_table = $this->_getFile('jcode/u2s.dat'); + } + + if(!defined($eu2a2s)) + { + $eu2a2s = $this->_getFile('jcode/emoji2/eu2a2s.dat'); + } + + my $c1; + my $c2; + my $c3; + my $c4; + my $c5; + my $c6; + my $c; + my $ch; + $str =~ s/([\xc0-\xdf][\x80-\xbf]|[\xe0-\xef][\x80-\xbf]{2}|[\xf0-\xf7][\x80-\xbf]{3}|[\xf8-\xfb][\x80-\xbf]{4}|[\xfc-\xfd][\x80-\xbf]{5})|([^\x00-\x7f])/ + defined($2) ? '?' : + ((length($1) == 1) ? $1 : + (length($1) == 2) ? ( + ($c1,$c2) = unpack("C2", $1), + $ch = (($c1 & 0x1F)<<6)|($c2 & 0x3F), + $c = substr($u2s_table, $ch * 2, 2), + ($c eq "\0\0") ? '?' : $c + ) : + (length($1) == 3) ? ( + ($c1,$c2,$c3) = unpack("C3", $1), + $ch = (($c1 & 0x0F)<<12)|(($c2 & 0x3F)<<6)|($c3 & 0x3F), + ( + ($ch <= 0x9fff) ? + $c = substr($u2s_table, $ch * 2, 2) : + ($ch >= 0xf900 and $ch <= 0xffff) ? + ( + $c = substr($u2s_table, ($ch - 0xf900 + 0xa000) * 2, 2), + (($c =~ tr,\0,,d)==2 and $c = "\0\0"), + ) : + ( + $c = '?' + ) + ), + ($c eq "\0\0") ? '?' : $c + ) : + (length($1) == 4) ? ( + ($c1,$c2,$c3,$c4) = unpack("C4", $1), + $ch = (($c1 & 0x07)<<18)|(($c2 & 0x3F)<<12)| + (($c3 & 0x3f) << 6)|($c4 & 0x3F), + ( + ($ch >= 0x0fe000 and $ch <= 0x0fffff) ? + ( + $c = substr($eu2a2s, ($ch - 0x0fe000) * 2, 2), + $c =~ tr,\0,,d, + ($c eq '') ? '?' : $c + ) : + '?' + ) + ) : + '?' + ) + /eg; + + $str; +} +sub _s2e2 { + my $this = shift; + my $c = shift; + + my ($c1, $c2) = unpack('CC', $c); + if (0xa1 <= $c1 && $c1 <= 0xdf) + { + $c2 = $c1; + $c1 = 0x8e; + } + elsif (0x9f <= $c2) + { + $c1 = $c1 * 2 - ($c1 >= 0xe0 ? 0xe0 : 0x60); + $c2 += 2; + } + else + { + $c1 = $c1 * 2 - ($c1 >= 0xe0 ? 0xe1 : 0x61); + $c2 += 0x60 + ($c2 < 0x7f); + } + + $S2E[unpack('n', $c) or unpack('C', $1)] = pack('CC', $c1, $c2); +} +sub z2hKanaD { + my $this = shift; + + if(!defined(%_z2hKanaD)) + { + $this->_loadConvTable; + } + + $this->{str} =~ s/(\xe3\x82\xac|\xe3\x82\xae|\xe3\x82\xb0|\xe3\x82\xb2|\xe3\x82\xb4|\xe3\x82\xb6|\xe3\x82\xb8|\xe3\x82\xba|\xe3\x82\xbc|\xe3\x82\xbe|\xe3\x83\x80|\xe3\x83\x82|\xe3\x83\x85|\xe3\x83\x87|\xe3\x83\x89|\xe3\x83\x90|\xe3\x83\x91|\xe3\x83\x93|\xe3\x83\x94|\xe3\x83\x96|\xe3\x83\x97|\xe3\x83\x99|\xe3\x83\x9a|\xe3\x83\x9c|\xe3\x83\x9d|\xe3\x83\xb4)/$_z2hKanaD{$1}/eg; + + $this; +} +sub _u2sd { + my $this = shift; + my $str = shift; + + if(!defined($str)) + { + return ''; + } + + if(!defined($u2s_table)) + { + $u2s_table = $this->_getFile('jcode/u2s.dat'); + } + + if(!defined($eu2d)) + { + $eu2d = $this->_getFile('jcode/emoji2/eu2d.dat'); + } + + my $c1; + my $c2; + my $c3; + my $c4; + my $c5; + my $c6; + my $c; + my $ch; + $str =~ s/([\xc0-\xdf][\x80-\xbf]|[\xe0-\xef][\x80-\xbf]{2}|[\xf0-\xf7][\x80-\xbf]{3}|[\xf8-\xfb][\x80-\xbf]{4}|[\xfc-\xfd][\x80-\xbf]{5})|([^\x00-\x7f])/ + defined($2) ? '?' : + ((length($1) == 1) ? $1 : + (length($1) == 2) ? ( + ($c1,$c2) = unpack("C2", $1), + $ch = (($c1 & 0x1F)<<6)|($c2 & 0x3F), + $c = substr($u2s_table, $ch * 2, 2), + ($c eq "\0\0") ? '?' : $c + ) : + (length($1) == 3) ? ( + ($c1,$c2,$c3) = unpack("C3", $1), + $ch = (($c1 & 0x0F)<<12)|(($c2 & 0x3F)<<6)|($c3 & 0x3F), + ( + ($ch <= 0x9fff) ? + $c = substr($u2s_table, $ch * 2, 2) : + ($ch >= 0xf900 and $ch <= 0xffff) ? + ( + $c = substr($u2s_table, ($ch - 0xf900 + 0xa000) * 2, 2), + (($c =~ tr,\0,,d)==2 and $c = "\0\0"), + ) : + ( + $c = '?' + ) + ), + ($c eq "\0\0") ? '?' : $c + ) : + (length($1) == 4) ? ( + ($c1,$c2,$c3,$c4) = unpack("C4", $1), + $ch = (($c1 & 0x07)<<18)|(($c2 & 0x3F)<<12)| + (($c3 & 0x3f) << 6)|($c4 & 0x3F), + ( + ($ch >= 0x0fe000 and $ch <= 0x0fffff) ? + ( + $c = substr($eu2d, ($ch - 0x0fe000) * 2, 2), + $c =~ tr,\0,,d, + ($c eq '') ? '?' : $c + ) : + '?' + ) + ) : + '?' + ) + /eg; + $str; + +} +sub sjis_au +{ + my $this = shift; + $this->_j2sa($this->_s2j($this->_u2ja2($this->{str}))); +} +sub _utf8_ucs2 { + my $this = shift; + my $str = shift; + + if(!defined($str)) + { + return ''; + } + + my $c1; + my $c2; + my $c3; + my $ch; + $str =~ s/([\xc0-\xdf][\x80-\xbf]|[\xe0-\xef][\x80-\xbf]{2}|[\xf0-\xf7][\x80-\xbf]{3}|[\xf8-\xfb][\x80-\xbf]{4}|[\xfc-\xfd][\x80-\xbf]{5}|.)/ + defined($2)?"\0?": + $T2U{$1} + or ($T2U{$1} + = ((length($1) == 1) ? pack("n", unpack("C", $1)) : + (length($1) == 2) ? (($c1,$c2) = unpack("C2", $1), + $ch = (($c1 & 0x1F)<<6)|($c2 & 0x3F), + $ch<0x80 ? "\0?" : pack("n", $ch) + ) : + (length($1) == 3) ? (($c1,$c2,$c3) = unpack("C3", $1), + $ch = (($c1 & 0x0F)<<12)|(($c2 & 0x3F)<<6)|($c3 & 0x3F), + $ch<0x0800 ? "\0?" : pack("n", $ch) + ) : "\0?")) + /eg; + $str; +} +sub euc_icon_au1 +{ + my $this = shift; + $this->_s2e($this->_u2s($this->_u2ai1($this->{str}))); +} +# ----------------------------------------------------------------------------- +# $bytes_au = $unijp->jis_au1(); +# +sub jis_au +{ + my $this = shift; + $this->_s2j($this->_u2ja2($this->{str})); +} +sub _utf32le_ucs4 { + my $this = shift; + my $str = shift; + + my $result = ''; + foreach my $ch (unpack('V*', $str)) + { + $result .= pack('N', $ch); + } + + $result; +} +# ----------------------------------------------------------------------------- +# $bytes_imode = $unijp->sjis_imode(); +# +sub sjis_imode +{ + my $this = shift; + $this->_u2si2($this->{str}); +} +sub _e2s2 { + my $this = shift; + my $c = shift; + + my ($c1, $c2) = unpack('CC', $c); + if ($c1 == 0x8e) + { # SS2 + $E2S[unpack('n', $c)] = chr($c2); + } + elsif ($c1 == 0x8f) + { # SS3 + $E2S[unpack('N', "\0" . $c)] = $CHARCODE{UNDEF_SJIS}; + } + else + { #SS1 or X0208 + if ($c1 % 2) + { + $c1 = ($c1>>1) + ($c1 < 0xdf ? 0x31 : 0x71); + $c2 -= 0x60 + ($c2 < 0xe0); + } + else + { + $c1 = ($c1>>1) + ($c1 < 0xdf ? 0x30 : 0x70); + $c2 -= 2; + } + $E2S[unpack('n', $c)] = pack('CC', $c1, $c2); + } +} +sub _s2j2 { + my $this = shift; + my $str = shift; + + $str =~ s/((?:$RE{SJIS_DBCS})+|(?:$RE{SJIS_KANA})+)/ + my $s = $1; + if($s =~ m,^$RE{SJIS_KANA},o) + { + $s =~ tr,\xa1-\xdf,\x21-\x5f,; + $ESC{KANA} . $s + } + else + { + $s =~ s!($RE{SJIS_DBCS})! + $S2J[unpack('n', $1)] or $this->_s2j3($1) + !geo; + $ESC{JIS_0208} . $s; + } + /geo; + + $str; +} +# ----------------------------------------------------------------------------- +# encode/decode +sub _encodeBase64 +{ + my $this = shift; + my $str = shift; + my $eol = shift; + my $res = ""; + + $eol = "\n" unless defined $eol; + pos($str) = 0; # ensure start at the beginning + while ($str =~ /(.{1,45})/gs) + { + $res .= substr(pack('u', $1), 1); + chop($res); + } + $res =~ tr|` -_|AA-Za-z0-9+/|; # `# help emacs + # fix padding at the end + my $padding = (3 - length($str) % 3) % 3; + $res =~ s/.{$padding}$/'=' x $padding/e if $padding; + # break encoded string into lines of no more than 76 characters each + if (length $eol) + { + $res =~ s/(.{1,76})/$1$eol/g; + } + $res; +} +sub validate_utf8 +{ + # my $safer_utf8 = Unicode::Japanese->validate_utf8($utf8_str); + # + $_[0]->_validate_utf8(@_[1..$#_]); +} +sub sjis_icon_au +{ + my $this = shift; + $this->_u2s($this->_u2ai2($this->{str})); +} +# ----------------------------------------------------------------------------- +# split/join Csv +# +sub split_csv { + &splitCsv; +} +# sjis-au2 => utf8 +sub _sa2u2 { + my $this = shift; + my $str = shift; + + if(!defined($str)) + { + return ''; + } + + if(!defined($s2u_table)) + { + $s2u_table = $this->_getFile('jcode/s2u.dat'); + } + + if(!defined($ea2u2s)) + { + $ea2u2s = $this->_getFile('jcode/emoji2/ea2u2s.dat'); + } + + my $l; + my $uc; + $str =~ s/($RE{SJIS_KANA}|$RE{SJIS_DBCS}|[\x80-\xff])/ + $SA2U2{$1} + or ($SA2U2{$1} = + ( + $l = (unpack('n', $1) or unpack('C', $1)), + ( + ($l >= 0xa1 and $l <= 0xdf) ? + ( + $uc = substr($s2u_table, ($l - 0xa1) * 3, 3), + $uc =~ tr,\0,,d, + $uc + ) : + ($l >= 0x8100 and $l <= 0x9fff) ? + ( + $uc = substr($s2u_table, ($l - 0x8100 + 0x3f) * 3, 3), + $uc =~ tr,\0,,d, + $uc + ) : + ($l >= 0xeb00 and $l <= 0xeeff) ? + ( + $uc = substr($ea2u2s, ($l - 0xeb00) * 4, 4), + $uc =~ tr,\0,,d, + $uc + ) : + ($l >= 0xe000 and $l <= 0xfcff) ? + ( + $uc = substr($s2u_table, ($l - 0xe000 + 0x1f3f) * 3, 3), + $uc =~ tr,\0,,d, + $uc + ) : + ($l < 0x80) ? + chr($l) : + '?' + ) + ) + )/eg; + + $str; + +} +# ----------------------------------------------------------------------------- +# $bytes_jsky = $unijp->jis_jsky(); +# +sub jis_jsky +{ + my $this = shift; + $this->_s2j($this->_u2sj2($this->{str})); +} +# ----------------------------------------------------------------------------- +# strcut, strlen +# +sub strcut +{ + my $this = shift; + my $cutlen = shift; + + if(ref($cutlen)) + { + die "String->strcut, Param[1] is Ref.\n"; + } + if($cutlen =~ m/\D/) + { + die "String->strcut, Param[1] must be NUMERIC.\n"; + } + + my $ch_re = '[\x00-\x7f]|[\xc0-\xdf][\x80-\xbf]|[\xe0-\xef][\x80-\xbf]{2}|[\xf0-\xf7][\x80-\xbf]{3}|[\xf8-\xfb][\x80-\xbf]{4}|[\xfc-\xfd][\x80-\xbf]{5}'; + + my $result; + my $line = ''; + my $linelength = 0; + + foreach my $c (split(/($ch_re)/, $this->{str})) + { + next if(length($c) == 0); + if($linelength + (length($c) >= 3 ? 2 : 1) > $cutlen) + { + $line ne '' and push(@$result, $line); + $line = ''; + $linelength = 0; + } + $linelength += (length($c) >= 3 ? 2 : 1); + $line .= $c; + } + push(@$result, $line); + + $result; +} +sub cp932 +{ + shift->sjis(@_); +} +sub _utf32be_ucs4 { + my $this = shift; + my $str = shift; + + $str; +} +  +  !"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|}~\N}L~ƒÃăŃƃǃȃɃʃ˃̃̓΃Ѓу҃ӃԃՃF@ABCDEGHIJKLMNOPQRSTUVWXYZ[\]^_`pqrstuwxyz{|}~v]\aefghdc~TUVWXYZ[\]݁ށ|假aȁɁ@ABCDEFGHIJKLMNOPQRS@ABVXYZqrstuvwxyzkl`‚ÂĂłƂǂȂɂʂ˂̂͂΂ςЂт҂ӂԂՂւׂ؂قڂۂ܂݂ނ߂JKTU@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|}~E[RSei`cakjdlfn_mbgh~rsopqut꒚O㉺s^NuLےO嘥TvVRh昩T\]܈jiS喒lYmwedtWM߈CNOPˆފꕚx`LQfAʒZCR]ØōƛCј͌gTSVUDNWErWܘۘMݘCoUZq{|[Yl㌑Ϙ`X^\Θ]UT_P×bBXC@AlDaEHFmGI`KJVMNLQPORSDUTWVXYZ[b[ƓeZ\}]cS_`ZaTbc~fegh`ijkdnlmyopq~ustrvwexyyz꣋{}}f~Mʉon؊Ygh䙍홎OUܔ虛nchiw[JNjuEk噫MlmkxnC\ߙڑ싦PmTƉKopɉpΙ~X}qQyFofrbpËْ@ڙ؉‘䎶jEiheg݉D@fNiܙߙz݌CĖuatBv@]PDCiAENFGLKNMJwSOHISBYXOPUR[VWTZQ`ea\fPxhA^b[슅c_igridcmkpjnlkorwutQqsRv}{|~\XxydXdlc͐}ޚy\nVByzR^C_{}|Wu|xꟉgYhUom큚n킕՚ϚҚdښܚӚߚmpsᐺ딄ϚĚ[OǏgVvΚޕt_턖zDz@DA@ܖDJWdBE툑WiF퉍GonKLIWHÕPpQORPNPMVWSKkUXwYT}ZQ[_\ś^]kda`bcefhgildjmnqopqrEs튎tuyFGǛvwwxyz{}~FvG@舶Xq鎺G{Qeh⛃ЖxQ@ǛJːRΎ˛ёqAڐKsAǛ͉rWjwRZx푛㛴풓sRśěÛɛ홗כޛۛBHIțߖbJFsztыAX蕝y햋NK􌶗cHLXM{xNfpLf@CDB_FEAGHILJKMNUOPMQTU|VOo팷WX^휒YJeZK[\]_`abSRc`FʕVjdeefihgamkjlk]ponqrzsOtJSKEuuYZzwyOxv|{|vӜ}}P~pbIxYߜ{fҜySĜz䜷DĜǜ‘ԍQT̜͜dSшԜʜМ׌c|J؜e荧匜^ʜ@ABCYDEF[G绔˝HKILJM}NQZOVPc}RSWTRe❫ZcS]d_fba[YUXS`qg@hminAE\kwlgjUҝp}Jqso{̝~xPv|{uzrt@||̒TyT[wdf͝}~`KghrgETQPdBohi^FC[xUq~ݔsŋǝUhG~ʝ|kl͎ҐώafzV{ѝԗٝڊU|{VՐftGE莞WWNAiqɝgÝb\A@BCjDFGHȉgXIJJ֑]\֍LÞK񒽞LN]MNO{DQpSVURTWǍޑZmXY۞[\aYt^ܝnf`f]cbʎ}ged_ki˞gmsȑuAt^_Mpoqnvljrhč`ɒ̓ȉhIxZz}ji{jy|~ˌKNJjVO~[旜BHǞ_IXoAŞk^ힾžƞ|OyT|PYɞ̍\Ƒl͞ߞW⏾͞~MӞk@ɞՊh@wKGFEBDCIELHJMQNORSTU~WVY\Ԋ\[]V^`_abc~cΗdefgihw}cjlBkmnopqsrtiuEkvaBwxꖈşyz|{~}CXiْ`ړ🇍]rܑDןBv@ݟAgDןjmk^FhlY_Q\CZߏOUtƟҟiWˈ[~䟹ǓYϏŸakЏًnԟ݈Q֑͟ύ`؟XNΓp팹anMHBYRAQ@NIRKHkEDMGFLCOPUTVYbSWQZX][^aZG\`_JdhfbcgemmjilnoqprsD܍FutxY{vzy_F}G~|wBRFonMRzWCݕઑu୕Дஔv௉Sq]@_ƋĒKTA͒LPQωblCDEXHFG]J䗝IKMLNԋՔilOPQZ@ZABCDFGErIHRKJLMONQPr[RYSpT팓cRb\jUV[YXEW\Z{L^l_]`aSfcbEidehgDa`^jklnmuvprt]usoqaxwyz|{ᅒs}~oᢔSTᤓIFcHWUVXM᱔u~mv᳓XᵖĔἔŌ^Z̖ruߖmZ⋸\uԋmCjv{]^d_VOqmA@CBDbFEGIH`JV_FSPOcLNj_MKI[QRh\TSВdfTUWXHYZ[׉ѓÏG\Hȕb]d`a`^_HbcBdetgfiljҌmkemsoωnnpqrntuvލwy{xzA|Eq~M}↗g⏏vhGj[^|J}y⤕M➒}͉Zk\⽕zUєӗԐ̌HeSl㊟WfnI@gC[RBэhAfaFݍGaIЍHIgDJmEoMQLUniROPNKGWTVSpXepa[_Zbfj\odY]^]ٔΏqgchjmiҊlknuovrtqwpcDks{~|z`}x@qJrDUyJ[@㚓Zs㫍ߌrul㭜rt㸌QA`HK|sVl͎̎k^ޒEW攣]IҎbmnx_wEE\ƘerE]BAtDCorTHIGFJBNOKLMpUQGPSRcVWVXZ^[Y^\]d_`acbefgbhLvijPklmnopqrs܊CwMtquwǔvDxzy|{}~䅐FH䎔mcF|䒗c꒗pv䗉֊s䟒t`rwx䮔yep،ԕHz“ĖGʈӗ{tⓟבKߕNf|葓~uWꖪDH@U@ԎB}C~nJPQDNFHRGKLOEEIFdOVTmSUWX[YZM\a`Abh]_^PAdcefgsi|jklqrm\naopztwsuvx`ua{^|}~gIwXIZIayOsȏpXqtˈ\΋UٗT琻JAA@CBDPEFGvHeIJKK`LoMONePQRSTUVpWXYGZ[\]vu`_P^LabcKidfehigٕ]frmwllkFlbYjopn_FsaUvrwtuqNbzxkyz_{懒~|@}慏dy抍u揗w擕T朕x桋c㿏]QJL涕^eLvnݔÊѐǒƋMȔ\fʘGdڑGo͎^qЍwԑӊqNzHHxH@DABCJEGIFLRKMNQPOSRUTVWYXgZ[]^_\`aORb]cfedygrihqkmjlpnPorySsAutx`wv{zyQ|}~Dh燒CJ_ӒҍHIv}犉猔R獏qޑ琋t磓r瘐痑畈ATiNِx礗V^Չ碓Bky穓K竑JIℊWM@xYSsXsAUޔz|ǗVy_X΍юחd؋B܊jt݊bnSzgeCLKNseI|K@BACdB^EDFBtKbGHLJIOZMNLPVYXLQRUWZTS^_`]\[dbcaefhgsiljkmopqtruwvxMyzJ[̊{|}~֊t}{hj虍~蚌@wA袒˓蜗zG@褊Ku襌ۏB讗ǔYW貎GJᎴ_뗋d軐kIP֐זrҊvxCfB쉹CŒ{aГzjopz{猰؊^@BACDEFHGIHQJKZOLM{a`NOPRSUQT܊VWXYZ\[^a]_`bcde]nfgyhʉwmljkiwnopqsrxtvRuxyz}|~{[ETS@鮖D鸕LNI~ӊkhوˉVߒLPDCEL@ABQJFKHG{LMNIOSTRQWPUVYX[\]hZ^_`abcdefghki[jlmnpqo˖sotuv썕wҖxzy{|}~Cl@Vꔗss~BYabceiluIij{C|D^OPQRSTUVWXFGH`abcdefghijklmnopqrstuvwxym_nOQMobp`ʁP｡｢｣､･ｦｧｨｩｪｫｬｭｮｯｰｱｲｳｴｵｶｷｸｹｺｻｼｽｾｿﾀﾁﾂﾃﾄﾅﾆﾇﾈﾉﾊﾋﾌﾍﾎﾏﾐﾑﾒﾓﾔﾕﾖﾗﾘﾙﾚﾛﾜﾝﾞﾟ????????????????????????????????????????????????????????????????　、。，．・：；？！゛゜´｀¨＾￣＿ヽヾゝゞ〃仝々〆〇ー―‐／＼～∥｜…‥‘’“”（）〔〕［］｛｝〈〉《》「」『』【】＋－±×?÷＝≠＜＞≦≧∞∴♂♀°′″℃￥＄￠￡％＃＆＊＠§☆★○●◎◇◆□■△▲▽▼※〒→←↑↓〓???????????∈∋⊆⊇⊂⊃∪∩????????∧∨￢⇒⇔∀∃???????????∠⊥⌒∂∇≡≒≪≫√∽∝∵∫∬???????ʼn♯♭♪†‡¶????◯??????????????????????????????????????????????????????????????????????????????????０１２３４５６７８９???????ＡＢＣＤＥＦＧＨＩＪＫＬＭＮＯＰＱＲＳＴＵＶＷＸＹＺ???????ａｂｃｄｅｆｇｈｉｊｋｌｍｎｏｐｑｒｓｔｕｖｗｘｙｚ????ぁあぃいぅうぇえぉおかがきぎくぐけげこごさざしじすずせぜそぞただちぢっつづてでとどなにぬねのはばぱひびぴふぶぷへべぺほぼぽまみむめもゃやゅゆょよらりるれろゎわゐゑをん??????????????????????????????????????????????????????????????????????????????ァアィイゥウェエォオカガキギクグケゲコゴサザシジスズセゼソゾタダチヂッツヅテデトドナニヌネノハバパヒビピフブプヘベペホボポマミ?ムメモャヤュユョヨラリルレロヮワヰヱヲンヴヵヶ????????ΑΒΓΔΕΖΗΘΙΚΛΜΝΞΟΠΡΣΤΥΦΧΨΩ????????αβγδεζηθικλμνξοπρστυφχψω?????????????????????????????????????????????????????????????????????????????????????????????????????????АБВГДЕЁЖЗИЙКЛМНОПРСТУФХЦЧШЩЪЫЬЭЮЯ???????????????абвгдеёжзийклмн?опрстуфхцчшщъыьэюя?????????????─│┌┐┘└├┬┤┴┼━┃┏┓┛┗┣┳┫┻╋┠┯┨┷┿┝┰┥┸╂?????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????①②③④⑤⑥⑦⑧⑨⑩⑪⑫⑬⑭⑮⑯⑰⑱⑲⑳ⅠⅡⅢⅣⅤⅥⅦⅧⅨⅩ?㍉㌔㌢㍍㌘㌧㌃㌶㍑㍗㌍㌦㌣㌫㍊㌻㎜㎝㎞㎎㎏㏄㎡????????㍻?〝〟№㏍℡㊤㊥㊦㊧㊨㈱㈲㈹㍾㍽㍼≒≡∫∮∑√⊥∠∟⊿∵∩∪??????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????亜唖娃阿哀愛挨姶逢葵茜穐悪握渥旭葦芦鯵梓圧斡扱宛姐虻飴絢綾鮎或粟袷安庵按暗案闇鞍杏以伊位依偉囲夷委威尉惟意慰易椅為畏異移維緯胃萎衣謂違遺医井亥域育郁磯一壱溢逸稲茨芋鰯允印咽員因姻引飲淫胤蔭???????????????????????????????????????????????????????????????????院陰隠韻吋右宇烏羽迂雨卯鵜窺丑碓臼渦嘘唄欝蔚鰻姥厩浦瓜閏噂云運雲荏餌叡営嬰影映曳栄永泳洩瑛盈穎頴英衛詠鋭液疫益駅悦謁越閲榎厭円?園堰奄宴延怨掩援沿演炎焔煙燕猿縁艶苑薗遠鉛鴛塩於汚甥凹央奥往応押旺横欧殴王翁襖鴬鴎黄岡沖荻億屋憶臆桶牡乙俺卸恩温穏音下化仮何伽価佳加可嘉夏嫁家寡科暇果架歌河火珂禍禾稼箇花苛茄荷華菓蝦課嘩貨迦過霞蚊俄峨我牙画臥芽蛾賀雅餓駕介会解回塊壊廻快怪悔恢懐戒拐改???????????????????????????????????????????????????????????????????魁晦械海灰界皆絵芥蟹開階貝凱劾外咳害崖慨概涯碍蓋街該鎧骸浬馨蛙垣柿蛎鈎劃嚇各廓拡撹格核殻獲確穫覚角赫較郭閣隔革学岳楽額顎掛笠樫?橿梶鰍潟割喝恰括活渇滑葛褐轄且鰹叶椛樺鞄株兜竃蒲釜鎌噛鴨栢茅萱粥刈苅瓦乾侃冠寒刊勘勧巻喚堪姦完官寛干幹患感慣憾換敢柑桓棺款歓汗漢澗潅環甘監看竿管簡緩缶翰肝艦莞観諌貫還鑑間閑関陥韓館舘丸含岸巌玩癌眼岩翫贋雁頑顔願企伎危喜器基奇嬉寄岐希幾忌揮机旗既期棋棄???????????????????????????????????????????????????????????????????機帰毅気汽畿祈季稀紀徽規記貴起軌輝飢騎鬼亀偽儀妓宜戯技擬欺犠疑祇義蟻誼議掬菊鞠吉吃喫桔橘詰砧杵黍却客脚虐逆丘久仇休及吸宮弓急救?朽求汲泣灸球究窮笈級糾給旧牛去居巨拒拠挙渠虚許距鋸漁禦魚亨享京供侠僑兇競共凶協匡卿叫喬境峡強彊怯恐恭挟教橋況狂狭矯胸脅興蕎郷鏡響饗驚仰凝尭暁業局曲極玉桐粁僅勤均巾錦斤欣欽琴禁禽筋緊芹菌衿襟謹近金吟銀九倶句区狗玖矩苦躯駆駈駒具愚虞喰空偶寓遇隅串櫛釧屑屈???????????????????????????????????????????????????????????????????掘窟沓靴轡窪熊隈粂栗繰桑鍬勲君薫訓群軍郡卦袈祁係傾刑兄啓圭珪型契形径恵慶慧憩掲携敬景桂渓畦稽系経継繋罫茎荊蛍計詣警軽頚鶏芸迎鯨?劇戟撃激隙桁傑欠決潔穴結血訣月件倹倦健兼券剣喧圏堅嫌建憲懸拳捲検権牽犬献研硯絹県肩見謙賢軒遣鍵険顕験鹸元原厳幻弦減源玄現絃舷言諺限乎個古呼固姑孤己庫弧戸故枯湖狐糊袴股胡菰虎誇跨鈷雇顧鼓五互伍午呉吾娯後御悟梧檎瑚碁語誤護醐乞鯉交佼侯候倖光公功効勾厚口向???????????????????????????????????????????????????????????????????后喉坑垢好孔孝宏工巧巷幸広庚康弘恒慌抗拘控攻昂晃更杭校梗構江洪浩港溝甲皇硬稿糠紅紘絞綱耕考肯肱腔膏航荒行衡講貢購郊酵鉱砿鋼閤降?項香高鴻剛劫号合壕拷濠豪轟麹克刻告国穀酷鵠黒獄漉腰甑忽惚骨狛込此頃今困坤墾婚恨懇昏昆根梱混痕紺艮魂些佐叉唆嵯左差査沙瑳砂詐鎖裟坐座挫債催再最哉塞妻宰彩才採栽歳済災采犀砕砦祭斎細菜裁載際剤在材罪財冴坂阪堺榊肴咲崎埼碕鷺作削咋搾昨朔柵窄策索錯桜鮭笹匙冊刷???????????????????????????????????????????????????????????????????察拶撮擦札殺薩雑皐鯖捌錆鮫皿晒三傘参山惨撒散桟燦珊産算纂蚕讃賛酸餐斬暫残仕仔伺使刺司史嗣四士始姉姿子屍市師志思指支孜斯施旨枝止?死氏獅祉私糸紙紫肢脂至視詞詩試誌諮資賜雌飼歯事似侍児字寺慈持時次滋治爾璽痔磁示而耳自蒔辞汐鹿式識鴫竺軸宍雫七叱執失嫉室悉湿漆疾質実蔀篠偲柴芝屡蕊縞舎写射捨赦斜煮社紗者謝車遮蛇邪借勺尺杓灼爵酌釈錫若寂弱惹主取守手朱殊狩珠種腫趣酒首儒受呪寿授樹綬需囚収周???????????????????????????????????????????????????????????????????宗就州修愁拾洲秀秋終繍習臭舟蒐衆襲讐蹴輯週酋酬集醜什住充十従戎柔汁渋獣縦重銃叔夙宿淑祝縮粛塾熟出術述俊峻春瞬竣舜駿准循旬楯殉淳?準潤盾純巡遵醇順処初所暑曙渚庶緒署書薯藷諸助叙女序徐恕鋤除傷償勝匠升召哨商唱嘗奨妾娼宵将小少尚庄床廠彰承抄招掌捷昇昌昭晶松梢樟樵沼消渉湘焼焦照症省硝礁祥称章笑粧紹肖菖蒋蕉衝裳訟証詔詳象賞醤鉦鍾鐘障鞘上丈丞乗冗剰城場壌嬢常情擾条杖浄状畳穣蒸譲醸錠嘱埴飾???????????????????????????????????????????????????????????????????拭植殖燭織職色触食蝕辱尻伸信侵唇娠寝審心慎振新晋森榛浸深申疹真神秦紳臣芯薪親診身辛進針震人仁刃塵壬尋甚尽腎訊迅陣靭笥諏須酢図厨?逗吹垂帥推水炊睡粋翠衰遂酔錐錘随瑞髄崇嵩数枢趨雛据杉椙菅頗雀裾澄摺寸世瀬畝是凄制勢姓征性成政整星晴棲栖正清牲生盛精聖声製西誠誓請逝醒青静斉税脆隻席惜戚斥昔析石積籍績脊責赤跡蹟碩切拙接摂折設窃節説雪絶舌蝉仙先千占宣専尖川戦扇撰栓栴泉浅洗染潜煎煽旋穿箭線???????????????????????????????????????????????????????????????????繊羨腺舛船薦詮賎践選遷銭銑閃鮮前善漸然全禅繕膳糎噌塑岨措曾曽楚狙疏疎礎祖租粗素組蘇訴阻遡鼠僧創双叢倉喪壮奏爽宋層匝惣想捜掃挿掻?操早曹巣槍槽漕燥争痩相窓糟総綜聡草荘葬蒼藻装走送遭鎗霜騒像増憎臓蔵贈造促側則即息捉束測足速俗属賊族続卒袖其揃存孫尊損村遜他多太汰詑唾堕妥惰打柁舵楕陀駄騨体堆対耐岱帯待怠態戴替泰滞胎腿苔袋貸退逮隊黛鯛代台大第醍題鷹滝瀧卓啄宅托択拓沢濯琢託鐸濁諾茸凧蛸只???????????????????????????????????????????????????????????????????叩但達辰奪脱巽竪辿棚谷狸鱈樽誰丹単嘆坦担探旦歎淡湛炭短端箪綻耽胆蛋誕鍛団壇弾断暖檀段男談値知地弛恥智池痴稚置致蜘遅馳築畜竹筑蓄?逐秩窒茶嫡着中仲宙忠抽昼柱注虫衷註酎鋳駐樗瀦猪苧著貯丁兆凋喋寵帖帳庁弔張彫徴懲挑暢朝潮牒町眺聴脹腸蝶調諜超跳銚長頂鳥勅捗直朕沈珍賃鎮陳津墜椎槌追鎚痛通塚栂掴槻佃漬柘辻蔦綴鍔椿潰坪壷嬬紬爪吊釣鶴亭低停偵剃貞呈堤定帝底庭廷弟悌抵挺提梯汀碇禎程締艇訂諦蹄逓???????????????????????????????????????????????????????????????????邸鄭釘鼎泥摘擢敵滴的笛適鏑溺哲徹撤轍迭鉄典填天展店添纏甜貼転顛点伝殿澱田電兎吐堵塗妬屠徒斗杜渡登菟賭途都鍍砥砺努度土奴怒倒党冬?凍刀唐塔塘套宕島嶋悼投搭東桃梼棟盗淘湯涛灯燈当痘祷等答筒糖統到董蕩藤討謄豆踏逃透鐙陶頭騰闘働動同堂導憧撞洞瞳童胴萄道銅峠鴇匿得徳涜特督禿篤毒独読栃橡凸突椴届鳶苫寅酉瀞噸屯惇敦沌豚遁頓呑曇鈍奈那内乍凪薙謎灘捺鍋楢馴縄畷南楠軟難汝二尼弐迩匂賑肉虹廿日乳入???????????????????????????????????????????????????????????????????如尿韮任妊忍認濡禰祢寧葱猫熱年念捻撚燃粘乃廼之埜嚢悩濃納能脳膿農覗蚤巴把播覇杷波派琶破婆罵芭馬俳廃拝排敗杯盃牌背肺輩配倍培媒梅?楳煤狽買売賠陪這蝿秤矧萩伯剥博拍柏泊白箔粕舶薄迫曝漠爆縛莫駁麦函箱硲箸肇筈櫨幡肌畑畠八鉢溌発醗髪伐罰抜筏閥鳩噺塙蛤隼伴判半反叛帆搬斑板氾汎版犯班畔繁般藩販範釆煩頒飯挽晩番盤磐蕃蛮匪卑否妃庇彼悲扉批披斐比泌疲皮碑秘緋罷肥被誹費避非飛樋簸備尾微枇毘琵眉美???????????????????????????????????????????????????????????????????鼻柊稗匹疋髭彦膝菱肘弼必畢筆逼桧姫媛紐百謬俵彪標氷漂瓢票表評豹廟描病秒苗錨鋲蒜蛭鰭品彬斌浜瀕貧賓頻敏瓶不付埠夫婦富冨布府怖扶敷?斧普浮父符腐膚芙譜負賦赴阜附侮撫武舞葡蕪部封楓風葺蕗伏副復幅服福腹複覆淵弗払沸仏物鮒分吻噴墳憤扮焚奮粉糞紛雰文聞丙併兵塀幣平弊柄並蔽閉陛米頁僻壁癖碧別瞥蔑箆偏変片篇編辺返遍便勉娩弁鞭保舗鋪圃捕歩甫補輔穂募墓慕戊暮母簿菩倣俸包呆報奉宝峰峯崩庖抱捧放方朋???????????????????????????????????????????????????????????????????法泡烹砲縫胞芳萌蓬蜂褒訪豊邦鋒飽鳳鵬乏亡傍剖坊妨帽忘忙房暴望某棒冒紡肪膨謀貌貿鉾防吠頬北僕卜墨撲朴牧睦穆釦勃没殆堀幌奔本翻凡盆?摩磨魔麻埋妹昧枚毎哩槙幕膜枕鮪柾鱒桝亦俣又抹末沫迄侭繭麿万慢満漫蔓味未魅巳箕岬密蜜湊蓑稔脈妙粍民眠務夢無牟矛霧鵡椋婿娘冥名命明盟迷銘鳴姪牝滅免棉綿緬面麺摸模茂妄孟毛猛盲網耗蒙儲木黙目杢勿餅尤戻籾貰問悶紋門匁也冶夜爺耶野弥矢厄役約薬訳躍靖柳薮鑓愉愈油癒???????????????????????????????????????????????????????????????????諭輸唯佑優勇友宥幽悠憂揖有柚湧涌猶猷由祐裕誘遊邑郵雄融夕予余与誉輿預傭幼妖容庸揚揺擁曜楊様洋溶熔用窯羊耀葉蓉要謡踊遥陽養慾抑欲?沃浴翌翼淀羅螺裸来莱頼雷洛絡落酪乱卵嵐欄濫藍蘭覧利吏履李梨理璃痢裏裡里離陸律率立葎掠略劉流溜琉留硫粒隆竜龍侶慮旅虜了亮僚両凌寮料梁涼猟療瞭稜糧良諒遼量陵領力緑倫厘林淋燐琳臨輪隣鱗麟瑠塁涙累類令伶例冷励嶺怜玲礼苓鈴隷零霊麗齢暦歴列劣烈裂廉恋憐漣煉簾練聯???????????????????????????????????????????????????????????????????蓮連錬呂魯櫓炉賂路露労婁廊弄朗楼榔浪漏牢狼篭老聾蝋郎六麓禄肋録論倭和話歪賄脇惑枠鷲亙亘鰐詫藁蕨椀湾碗腕????????????????????????????????????????????弌丐丕个丱丶丼丿乂乖乘亂亅豫亊舒弍于亞亟亠亢亰亳亶从仍仄仆仂仗仞仭仟价伉佚估佛佝佗佇佶侈侏侘佻佩佰侑佯來侖儘俔俟俎俘俛俑俚俐俤俥倚倨倔倪倥倅伜俶倡倩倬俾俯們倆偃假會偕偐偈做偖偬偸傀傚傅傴傲???????????????????????????????????????????????????????????????????僉僊傳僂僖僞僥僭僣僮價僵儉儁儂儖儕儔儚儡儺儷儼儻儿兀兒兌兔兢竸兩兪兮冀冂囘册冉冏冑冓冕冖冤冦冢冩冪冫决冱冲冰况冽凅凉凛几處凩凭?凰凵凾刄刋刔刎刧刪刮刳刹剏剄剋剌剞剔剪剴剩剳剿剽劍劔劒剱劈劑辨辧劬劭劼劵勁勍勗勞勣勦飭勠勳勵勸勹匆匈甸匍匐匏匕匚匣匯匱匳匸區卆卅丗卉卍凖卞卩卮夘卻卷厂厖厠厦厥厮厰厶參簒雙叟曼燮叮叨叭叺吁吽呀听吭吼吮吶吩吝呎咏呵咎呟呱呷呰咒呻咀呶咄咐咆哇咢咸咥咬哄哈咨???????????????????????????????????????????????????????????????????咫哂咤咾咼哘哥哦唏唔哽哮哭哺哢唹啀啣啌售啜啅啖啗唸唳啝喙喀咯喊喟啻啾喘喞單啼喃喩喇喨嗚嗅嗟嗄嗜嗤嗔嘔嗷嘖嗾嗽嘛嗹噎噐營嘴嘶嘲嘸?噫噤嘯噬噪嚆嚀嚊嚠嚔嚏嚥嚮嚶嚴囂嚼囁囃囀囈囎囑囓囗囮囹圀囿圄圉圈國圍圓團圖嗇圜圦圷圸坎圻址坏坩埀垈坡坿垉垓垠垳垤垪垰埃埆埔埒埓堊埖埣堋堙堝塲堡塢塋塰毀塒堽塹墅墹墟墫墺壞墻墸墮壅壓壑壗壙壘壥壜壤壟壯壺壹壻壼壽夂夊夐夛梦夥夬夭夲夸夾竒奕奐奎奚奘奢奠奧奬奩???????????????????????????????????????????????????????????????????奸妁妝佞侫妣妲姆姨姜妍姙姚娥娟娑娜娉娚婀婬婉娵娶婢婪媚媼媾嫋嫂媽嫣嫗嫦嫩嫖嫺嫻嬌嬋嬖嬲嫐嬪嬶嬾孃孅孀孑孕孚孛孥孩孰孳孵學斈孺宀?它宦宸寃寇寉寔寐寤實寢寞寥寫寰寶寳尅將專對尓尠尢尨尸尹屁屆屎屓屐屏孱屬屮乢屶屹岌岑岔妛岫岻岶岼岷峅岾峇峙峩峽峺峭嶌峪崋崕崗嵜崟崛崑崔崢崚崙崘嵌嵒嵎嵋嵬嵳嵶嶇嶄嶂嶢嶝嶬嶮嶽嶐嶷嶼巉巍巓巒巖巛巫已巵帋帚帙帑帛帶帷幄幃幀幎幗幔幟幢幤幇幵并幺麼广庠廁廂廈廐廏???????????????????????????????????????????????????????????????????廖廣廝廚廛廢廡廨廩廬廱廳廰廴廸廾弃弉彝彜弋弑弖弩弭弸彁彈彌彎弯彑彖彗彙彡彭彳彷徃徂彿徊很徑徇從徙徘徠徨徭徼忖忻忤忸忱忝悳忿怡恠?怙怐怩怎怱怛怕怫怦怏怺恚恁恪恷恟恊恆恍恣恃恤恂恬恫恙悁悍惧悃悚悄悛悖悗悒悧悋惡悸惠惓悴忰悽惆悵惘慍愕愆惶惷愀惴惺愃愡惻惱愍愎慇愾愨愧慊愿愼愬愴愽慂慄慳慷慘慙慚慫慴慯慥慱慟慝慓慵憙憖憇憬憔憚憊憑憫憮懌懊應懷懈懃懆憺懋罹懍懦懣懶懺懴懿懽懼懾戀戈戉戍戌戔戛???????????????????????????????????????????????????????????????????戞戡截戮戰戲戳扁扎扞扣扛扠扨扼抂抉找抒抓抖拔抃抔拗拑抻拏拿拆擔拈拜拌拊拂拇抛拉挌拮拱挧挂挈拯拵捐挾捍搜捏掖掎掀掫捶掣掏掉掟掵捫?捩掾揩揀揆揣揉插揶揄搖搴搆搓搦搶攝搗搨搏摧摯摶摎攪撕撓撥撩撈撼據擒擅擇撻擘擂擱擧舉擠擡抬擣擯攬擶擴擲擺攀擽攘攜攅攤攣攫攴攵攷收攸畋效敖敕敍敘敞敝敲數斂斃變斛斟斫斷旃旆旁旄旌旒旛旙无旡旱杲昊昃旻杳昵昶昴昜晏晄晉晁晞晝晤晧晨晟晢晰暃暈暎暉暄暘暝曁暹曉暾暼???????????????????????????????????????????????????????????????????曄暸曖曚曠昿曦曩曰曵曷朏朖朞朦朧霸朮朿朶杁朸朷杆杞杠杙杣杤枉杰枩杼杪枌枋枦枡枅枷柯枴柬枳柩枸柤柞柝柢柮枹柎柆柧檜栞框栩桀桍栲桎?梳栫桙档桷桿梟梏梭梔條梛梃檮梹桴梵梠梺椏梍桾椁棊椈棘椢椦棡椌棍棔棧棕椶椒椄棗棣椥棹棠棯椨椪椚椣椡棆楹楷楜楸楫楔楾楮椹楴椽楙椰楡楞楝榁楪榲榮槐榿槁槓榾槎寨槊槝榻槃榧樮榑榠榜榕榴槞槨樂樛槿權槹槲槧樅榱樞槭樔槫樊樒櫁樣樓橄樌橲樶橸橇橢橙橦橈樸樢檐檍檠檄檢檣???????????????????????????????????????????????????????????????????檗蘗檻櫃櫂檸檳檬櫞櫑櫟檪櫚櫪櫻欅蘖櫺欒欖鬱欟欸欷盜欹飮歇歃歉歐歙歔歛歟歡歸歹歿殀殄殃殍殘殕殞殤殪殫殯殲殱殳殷殼毆毋毓毟毬毫毳毯?麾氈氓气氛氤氣汞汕汢汪沂沍沚沁沛汾汨汳沒沐泄泱泓沽泗泅泝沮沱沾沺泛泯泙泪洟衍洶洫洽洸洙洵洳洒洌浣涓浤浚浹浙涎涕濤涅淹渕渊涵淇淦涸淆淬淞淌淨淒淅淺淙淤淕淪淮渭湮渮渙湲湟渾渣湫渫湶湍渟湃渺湎渤滿渝游溂溪溘滉溷滓溽溯滄溲滔滕溏溥滂溟潁漑灌滬滸滾漿滲漱滯漲滌???????????????????????????????????????????????????????????????????漾漓滷澆潺潸澁澀潯潛濳潭澂潼潘澎澑濂潦澳澣澡澤澹濆澪濟濕濬濔濘濱濮濛瀉瀋濺瀑瀁瀏濾瀛瀚潴瀝瀘瀟瀰瀾瀲灑灣炙炒炯烱炬炸炳炮烟烋烝?烙焉烽焜焙煥煕熈煦煢煌煖煬熏燻熄熕熨熬燗熹熾燒燉燔燎燠燬燧燵燼燹燿爍爐爛爨爭爬爰爲爻爼爿牀牆牋牘牴牾犂犁犇犒犖犢犧犹犲狃狆狄狎狒狢狠狡狹狷倏猗猊猜猖猝猴猯猩猥猾獎獏默獗獪獨獰獸獵獻獺珈玳珎玻珀珥珮珞璢琅瑯琥珸琲琺瑕琿瑟瑙瑁瑜瑩瑰瑣瑪瑶瑾璋璞璧瓊瓏瓔珱???????????????????????????????????????????????????????????????????瓠瓣瓧瓩瓮瓲瓰瓱瓸瓷甄甃甅甌甎甍甕甓甞甦甬甼畄畍畊畉畛畆畚畩畤畧畫畭畸當疆疇畴疊疉疂疔疚疝疥疣痂疳痃疵疽疸疼疱痍痊痒痙痣痞痾痿?痼瘁痰痺痲痳瘋瘍瘉瘟瘧瘠瘡瘢瘤瘴瘰瘻癇癈癆癜癘癡癢癨癩癪癧癬癰癲癶癸發皀皃皈皋皎皖皓皙皚皰皴皸皹皺盂盍盖盒盞盡盥盧盪蘯盻眈眇眄眩眤眞眥眦眛眷眸睇睚睨睫睛睥睿睾睹瞎瞋瞑瞠瞞瞰瞶瞹瞿瞼瞽瞻矇矍矗矚矜矣矮矼砌砒礦砠礪硅碎硴碆硼碚碌碣碵碪碯磑磆磋磔碾碼磅磊磬???????????????????????????????????????????????????????????????????磧磚磽磴礇礒礑礙礬礫祀祠祗祟祚祕祓祺祿禊禝禧齋禪禮禳禹禺秉秕秧秬秡秣稈稍稘稙稠稟禀稱稻稾稷穃穗穉穡穢穩龝穰穹穽窈窗窕窘窖窩竈窰?窶竅竄窿邃竇竊竍竏竕竓站竚竝竡竢竦竭竰笂笏笊笆笳笘笙笞笵笨笶筐筺笄筍笋筌筅筵筥筴筧筰筱筬筮箝箘箟箍箜箚箋箒箏筝箙篋篁篌篏箴篆篝篩簑簔篦篥籠簀簇簓篳篷簗簍篶簣簧簪簟簷簫簽籌籃籔籏籀籐籘籟籤籖籥籬籵粃粐粤粭粢粫粡粨粳粲粱粮粹粽糀糅糂糘糒糜糢鬻糯糲糴糶糺紆???????????????????????????????????????????????????????????????????紂紜紕紊絅絋紮紲紿紵絆絳絖絎絲絨絮絏絣經綉絛綏絽綛綺綮綣綵緇綽綫總綢綯緜綸綟綰緘緝緤緞緻緲緡縅縊縣縡縒縱縟縉縋縢繆繦縻縵縹繃縷?縲縺繧繝繖繞繙繚繹繪繩繼繻纃緕繽辮繿纈纉續纒纐纓纔纖纎纛纜缸缺罅罌罍罎罐网罕罔罘罟罠罨罩罧罸羂羆羃羈羇羌羔羞羝羚羣羯羲羹羮羶羸譱翅翆翊翕翔翡翦翩翳翹飜耆耄耋耒耘耙耜耡耨耿耻聊聆聒聘聚聟聢聨聳聲聰聶聹聽聿肄肆肅肛肓肚肭冐肬胛胥胙胝胄胚胖脉胯胱脛脩脣脯腋???????????????????????????????????????????????????????????????????隋腆脾腓腑胼腱腮腥腦腴膃膈膊膀膂膠膕膤膣腟膓膩膰膵膾膸膽臀臂膺臉臍臑臙臘臈臚臟臠臧臺臻臾舁舂舅與舊舍舐舖舩舫舸舳艀艙艘艝艚艟艤?艢艨艪艫舮艱艷艸艾芍芒芫芟芻芬苡苣苟苒苴苳苺莓范苻苹苞茆苜茉苙茵茴茖茲茱荀茹荐荅茯茫茗茘莅莚莪莟莢莖茣莎莇莊荼莵荳荵莠莉莨菴萓菫菎菽萃菘萋菁菷萇菠菲萍萢萠莽萸蔆菻葭萪萼蕚蒄葷葫蒭葮蒂葩葆萬葯葹萵蓊葢蒹蒿蒟蓙蓍蒻蓚蓐蓁蓆蓖蒡蔡蓿蓴蔗蔘蔬蔟蔕蔔蓼蕀蕣蕘蕈???????????????????????????????????????????????????????????????????蕁蘂蕋蕕薀薤薈薑薊薨蕭薔薛藪薇薜蕷蕾薐藉薺藏薹藐藕藝藥藜藹蘊蘓蘋藾藺蘆蘢蘚蘰蘿虍乕虔號虧虱蚓蚣蚩蚪蚋蚌蚶蚯蛄蛆蚰蛉蠣蚫蛔蛞蛩蛬?蛟蛛蛯蜒蜆蜈蜀蜃蛻蜑蜉蜍蛹蜊蜴蜿蜷蜻蜥蜩蜚蝠蝟蝸蝌蝎蝴蝗蝨蝮蝙蝓蝣蝪蠅螢螟螂螯蟋螽蟀蟐雖螫蟄螳蟇蟆螻蟯蟲蟠蠏蠍蟾蟶蟷蠎蟒蠑蠖蠕蠢蠡蠱蠶蠹蠧蠻衄衂衒衙衞衢衫袁衾袞衵衽袵衲袂袗袒袮袙袢袍袤袰袿袱裃裄裔裘裙裝裹褂裼裴裨裲褄褌褊褓襃褞褥褪褫襁襄褻褶褸襌褝襠襞???????????????????????????????????????????????????????????????????襦襤襭襪襯襴襷襾覃覈覊覓覘覡覩覦覬覯覲覺覽覿觀觚觜觝觧觴觸訃訖訐訌訛訝訥訶詁詛詒詆詈詼詭詬詢誅誂誄誨誡誑誥誦誚誣諄諍諂諚諫諳諧?諤諱謔諠諢諷諞諛謌謇謚諡謖謐謗謠謳鞫謦謫謾謨譁譌譏譎證譖譛譚譫譟譬譯譴譽讀讌讎讒讓讖讙讚谺豁谿豈豌豎豐豕豢豬豸豺貂貉貅貊貍貎貔豼貘戝貭貪貽貲貳貮貶賈賁賤賣賚賽賺賻贄贅贊贇贏贍贐齎贓賍贔贖赧赭赱赳趁趙跂趾趺跏跚跖跌跛跋跪跫跟跣跼踈踉跿踝踞踐踟蹂踵踰踴蹊???????????????????????????????????????????????????????????????????蹇蹉蹌蹐蹈蹙蹤蹠踪蹣蹕蹶蹲蹼躁躇躅躄躋躊躓躑躔躙躪躡躬躰軆躱躾軅軈軋軛軣軼軻軫軾輊輅輕輒輙輓輜輟輛輌輦輳輻輹轅轂輾轌轉轆轎轗轜?轢轣轤辜辟辣辭辯辷迚迥迢迪迯邇迴逅迹迺逑逕逡逍逞逖逋逧逶逵逹迸遏遐遑遒逎遉逾遖遘遞遨遯遶隨遲邂遽邁邀邊邉邏邨邯邱邵郢郤扈郛鄂鄒鄙鄲鄰酊酖酘酣酥酩酳酲醋醉醂醢醫醯醪醵醴醺釀釁釉釋釐釖釟釡釛釼釵釶鈞釿鈔鈬鈕鈑鉞鉗鉅鉉鉤鉈銕鈿鉋鉐銜銖銓銛鉚鋏銹銷鋩錏鋺鍄錮???????????????????????????????????????????????????????????????????錙錢錚錣錺錵錻鍜鍠鍼鍮鍖鎰鎬鎭鎔鎹鏖鏗鏨鏥鏘鏃鏝鏐鏈鏤鐚鐔鐓鐃鐇鐐鐶鐫鐵鐡鐺鑁鑒鑄鑛鑠鑢鑞鑪鈩鑰鑵鑷鑽鑚鑼鑾钁鑿閂閇閊閔閖閘閙?閠閨閧閭閼閻閹閾闊濶闃闍闌闕闔闖關闡闥闢阡阨阮阯陂陌陏陋陷陜陞陝陟陦陲陬隍隘隕隗險隧隱隲隰隴隶隸隹雎雋雉雍襍雜霍雕雹霄霆霈霓霎霑霏霖霙霤霪霰霹霽霾靄靆靈靂靉靜靠靤靦靨勒靫靱靹鞅靼鞁靺鞆鞋鞏鞐鞜鞨鞦鞣鞳鞴韃韆韈韋韜韭齏韲竟韶韵頏頌頸頤頡頷頽顆顏顋顫顯顰???????????????????????????????????????????????????????????????????顱顴顳颪颯颱颶飄飃飆飩飫餃餉餒餔餘餡餝餞餤餠餬餮餽餾饂饉饅饐饋饑饒饌饕馗馘馥馭馮馼駟駛駝駘駑駭駮駱駲駻駸騁騏騅駢騙騫騷驅驂驀驃?騾驕驍驛驗驟驢驥驤驩驫驪骭骰骼髀髏髑髓體髞髟髢髣髦髯髫髮髴髱髷髻鬆鬘鬚鬟鬢鬣鬥鬧鬨鬩鬪鬮鬯鬲魄魃魏魍魎魑魘魴鮓鮃鮑鮖鮗鮟鮠鮨鮴鯀鯊鮹鯆鯏鯑鯒鯣鯢鯤鯔鯡鰺鯲鯱鯰鰕鰔鰉鰓鰌鰆鰈鰒鰊鰄鰮鰛鰥鰤鰡鰰鱇鰲鱆鰾鱚鱠鱧鱶鱸鳧鳬鳰鴉鴈鳫鴃鴆鴪鴦鶯鴣鴟鵄鴕鴒鵁鴿鴾鵆鵈???????????????????????????????????????????????????????????????????鵝鵞鵤鵑鵐鵙鵲鶉鶇鶫鵯鵺鶚鶤鶩鶲鷄鷁鶻鶸鶺鷆鷏鷂鷙鷓鷸鷦鷭鷯鷽鸚鸛鸞鹵鹹鹽麁麈麋麌麒麕麑麝麥麩麸麪麭靡黌黎黏黐黔黜點黝黠黥黨黯?黴黶黷黹黻黼黽鼇鼈皷鼕鼡鼬鼾齊齒齔齣齟齠齡齦齧齬齪齷齲齶龕龜龠堯槇遙瑤凜熙???????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????纊褜鍈銈蓜俉炻昱棈鋹曻彅丨仡仼伀伃伹佖侒侊侚侔俍偀倢俿倞偆偰偂傔僴僘兊兤冝冾凬刕劜劦勀勛匀匇匤卲厓厲叝﨎咜咊咩哿喆坙坥垬埈埇﨏?塚增墲夋奓奛奝奣妤妺孖寀甯寘寬尞岦岺峵崧嵓﨑嵂嵭嶸嶹巐弡弴彧德忞恝悅悊惞惕愠惲愑愷愰憘戓抦揵摠撝擎敎昀昕昻昉昮昞昤晥晗晙晴晳暙暠暲暿曺朎朗杦枻桒柀栁桄棏﨓楨﨔榘槢樰橫橆橳橾櫢櫤毖氿汜沆汯泚洄涇浯涖涬淏淸淲淼渹湜渧渼溿澈澵濵瀅瀇瀨炅炫焏焄煜煆煇凞燁燾犱???????????????????????????????????????????????????????????????????犾猤猪獷玽珉珖珣珒琇珵琦琪琩琮瑢璉璟甁畯皂皜皞皛皦益睆劯砡硎硤硺礰礼神祥禔福禛竑竧靖竫箞精絈絜綷綠緖繒罇羡羽茁荢荿菇菶葈蒴蕓蕙?蕫﨟薰蘒﨡蠇裵訒訷詹誧誾諟諸諶譓譿賰賴贒赶﨣軏﨤逸遧郞都鄕鄧釚釗釞釭釮釤釥鈆鈐鈊鈺鉀鈼鉎鉙鉑鈹鉧銧鉷鉸鋧鋗鋙鋐﨧鋕鋠鋓錥錡鋻﨨錞鋿錝錂鍰鍗鎤鏆鏞鏸鐱鑅鑈閒隆﨩隝隯霳霻靃靍靏靑靕顗顥飯飼餧館馞驎髙髜魵魲鮏鮱鮻鰀鵰鵫鶴鸙黑??ⅰⅱⅲⅳⅴⅵⅶⅷⅸⅹ￢￤＇＂???????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????ⅰⅱⅲⅳⅴⅵⅶⅷⅸⅹⅠⅡⅢⅣⅤⅥⅦⅧⅨⅩ￢￤＇＂㈱№℡∵纊褜鍈銈蓜俉炻昱棈鋹曻彅丨仡仼伀伃伹佖侒侊侚侔俍偀倢俿倞偆偰偂傔僴僘兊?兤冝冾凬刕劜劦勀勛匀匇匤卲厓厲叝﨎咜咊咩哿喆坙坥垬埈埇﨏塚增墲夋奓奛奝奣妤妺孖寀甯寘寬尞岦岺峵崧嵓﨑嵂嵭嶸嶹巐弡弴彧德忞恝悅悊惞惕愠惲愑愷愰憘戓抦揵摠撝擎敎昀昕昻昉昮昞昤晥晗晙晴晳暙暠暲暿曺朎朗杦枻桒柀栁桄棏﨓楨﨔榘槢樰橫橆橳橾櫢櫤毖氿汜沆汯泚洄涇浯???????????????????????????????????????????????????????????????????涖涬淏淸淲淼渹湜渧渼溿澈澵濵瀅瀇瀨炅炫焏焄煜煆煇凞燁燾犱犾猤猪獷玽珉珖珣珒琇珵琦琪琩琮瑢璉璟甁畯皂皜皞皛皦益睆劯砡硎硤硺礰礼神?祥禔福禛竑竧靖竫箞精絈絜綷綠緖繒罇羡羽茁荢荿菇菶葈蒴蕓蕙蕫﨟薰蘒﨡蠇裵訒訷詹誧誾諟諸諶譓譿賰賴贒赶﨣軏﨤逸遧郞都鄕鄧釚釗釞釭釮釤釥鈆鈐鈊鈺鉀鈼鉎鉙鉑鈹鉧銧鉷鉸鋧鋗鋙鋐﨧鋕鋠鋓錥錡鋻﨨錞鋿錝錂鍰鍗鎤鏆鏞鏸鐱鑅鑈閒隆﨩隝隯霳霻靃靍靏靑靕顗顥飯飼餧館馞驎髙???????????????????????????????????????????????????????????????????髜魵魲鮏鮱鮻鰀鵰鵫鶴鸙黑???????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????? ???????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????󿢟󿢠󿢡󿢢󿢣󿢤󿢥󿢦󿢧󿢨󿢩󿢪󿢫󿢬󿢭󿢮󿢯󿢰󿢱󿢲󿢳󿢴󿢵󿢶󿢷󿢸󿢹󿢺󿢻󿢼󿢽󿢾󿢿󿣀󿣁󿣂󿣃󿣄󿣅󿣆󿣇󿣈󿣉󿣊󿣋󿣌󿣍󿣎󿣏󿣐󿣑󿣒󿣓󿣔󿣕󿣖󿣗󿣘󿣙󿣚󿣛󿣜󿣝󿣞󿣟󿣠󿣡󿣢󿣣󿣤󿣥󿣦󿣧󿣨󿣩󿣪󿣫󿣬󿣭󿣮󿣯󿣰󿣱󿣲󿣳󿣴󿣵󿣶󿣷󿣸󿣹󿣺󿣻󿣼???????????????????????????????????????????????????????????????????󿥀󿥁󿥂󿥃󿥄󿥅󿥆󿥇󿥈󿥉??????󿥐󿥑󿥒??󿥕󿥖󿥗???󿥛󿥜󿥝󿥞???????????????????󿥲󿥳󿥴󿥵󿥶󿥷󿥸󿥹󿥺󿥻󿥼󿥽󿥾?󿦀󿦁󿦂󿦃󿦄󿦅󿦆󿦇󿦈󿦉󿦊󿦋󿦌󿦍󿦎󿦏󿦐󿦑󿦒󿦓󿦔󿦕󿦖󿦗󿦘󿦙󿦚󿦛󿦜󿦝󿦞󿦟󿦠󿦡󿦢󿦣󿦤󿦥󿦦󿦧󿦨󿦩󿦪󿦫󿦬󿦭󿦮󿦯󿦰????????????????????????????????????????????????????????????????????????????????H???????????????{|?????????^??????~?????~?Ӂ?I??E???????????????wz??????}??????????E??????????R?s????????????t?G??@ ??10????????????????????????P??????H???????????????F?????????????????????????Ez{??UP??????@??????????????????????????????VS???????????????T|wc????????????j????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????`anAB???????????????????????????????????????????????w??????????????w?????????????w??????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????10111210cZxNEȎw`钴}őSn????????E???????????????F???????H??????????????????????????????????????????????????????????~???????????????????????????????????????????????????????????????????????????????????????????????????t????^???R?????w??????????????????????????????Q}?????????????????????????V???????????tďH~???????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????10??-!%./:;?@^_'"{=~z?????????NG???????????????????????????????????????????????????????????????????`abcdefghijklmnopqrstuvwxy‚?ĂłƂǂȂɂʂ˂̂͂΂ςЂт҂ӂԂՂւׂ؂قڂۂ܂݂ނ߂@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|}~?????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????G??????CD????I?????????????????????w??????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????@ABCDEFGHI??????PQR??UVW???[\]^???????????????????rstuvwxyz{|}~??????????Q???R???????????????NG??????֋󍇖?????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????sr??????????????????????????????VSQ??????????????????????????????????????????????????????????????????????????j????????????????P?~H?????????????????????????????????????????????????????????????????????????????????UP?L\???T|wc????I????????i??????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????t??????GH???????????????H?????}????????F??E??????????????????????????????????????????????????????????????????????????????????E???????`aABn????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????󿢟󿢠󿢡󿢢󿢣󿢤󿢥󿢦󿢧󿢨󿢩󿢪󿢫󿢬󿢭󿢮󿢯󿢰󿢱󿢲󿢳󿢴󿢵󿢶󿢷󿢸󿢹󿢺󿢻󿢼󿢽󿢾󿢿󿣀󿣁󿣂󿣃󿣄󿣅󿣆󿣇󿣈󿣉󿣊󿣋󿣌󿣍󿣎󿣏󿣐󿣑󿣒󿣓󿣔󿣕󿣖󿣗󿣘󿣙󿣚󿣛󿣜󿣝󿣞󿣟󿣠󿣡󿣢󿣣󿣤󿣥󿣦󿣧󿣨󿣩󿣪󿣫󿣬󿣭󿣮󿣯󿣰󿣱󿣲󿣳󿣴󿣵󿣶󿣷󿣸󿣹󿣺󿣻󿣼???????????????????????????????????????????????????????????????????󿥀󿥁󿥂󿥃󿥄󿥅󿥆󿥇󿥈󿥉??????󿥐󿥑󿥒??󿥕󿥖󿥗???󿥛󿥜󿥝󿥞???????????????????󿥲󿥳󿥴󿥵󿥶󿥷󿥸󿥹󿥺󿥻󿥼󿥽󿥾?󿦀󿦁󿦂󿦃󿦄󿦅󿦆󿦇󿦈󿦉󿦊󿦋󿦌󿦍󿦎󿦏󿦐󿦑󿦒󿦓󿦔󿦕󿦖󿦗󿦘󿦙󿦚󿦛󿦜󿦝󿦞󿦟󿦠󿦡󿦢󿦣󿦤󿦥󿦦󿦧󿦨󿦩󿦪󿦫󿦬󿦭󿦮󿦯󿦰󿦱󿦲󿦳󿦴󿦵󿦶󿦷󿦸󿦹󿦺󿦻󿦼󿦽󿦾󿦿󿧀󿧁󿧂󿧃󿧄󿧅󿧆󿧇󿧈󿧉󿧊󿧋󿧌󿧍󿧎󿧏󿧐󿧑󿧒󿧓󿧔󿧕󿧖󿧗󿧘󿧙󿧚󿧛󿧜󿧝󿧞󿧟󿧠󿧡󿧢󿧣󿧤󿧥󿧦󿧧󿧨󿧩󿧪󿧫󿧬󿧭󿧮󿧯󿧰󿧱󿧲󿧳󿧴󿧵󿧶󿧷󿧸󿧹󿧺󿧻󿧼????H?????????????ā{|?????????^???ׁ~???~?Ӂ?ρI?E????????????wz?????}?????????E??????????s??f?????????t?G??@ ??10??????????????????????P??????H????????F????????????????????Ez{??UP??????@?????????????????????????VS??????????????T|ގwc???????????j???????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????`anAB??????????????????????????????????????????????w??????????????w?????w??????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????10111210cZxNEȎw`ْ}őSn???????E???????????????F?????H???????????????????????????????????????????????~??????????????????????????????????????????????????????????????????????????????????????????????t???^??????w???????????????????????????}????????????????????????V??????????tďH~??????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????10??-!%./:;?@^_'"{=~z?????????ԓ???????????????????????????????????????????????????????????????????`abcdefghijklmnopqrstuvwxy‚?ĂłƂǂȂɂʂ˂̂͂΂ςЂт҂ӂԂՂւׂ؂قڂۂ܂݂ނ߂@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|}~?????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????G?????CD????I?????????????????????w??????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????@ABCDEFGHI??????PQR??UVW???[\]^???????????????????rstuvwxyz{|}~???????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????sr???????????????????????VS???????????????????????????????????????????????????????????????????????j???????????????P~H????????????????????????????????????????????????????????????????????????????UP?L\???T|ގwc????I??????i?????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????t??GH??????????????H??}???????F??E?????????????????????????????????????????????????????????????????????????????E???????`aABn?????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????󿬡󿬢󿬣󿬤󿬥󿬦󿬧󿬨󿬩󿬪󿬫󿬬󿬭󿬮󿬯󿬰󿬱󿬲󿬳󿬴󿬵󿬶󿬷󿬸󿬹󿬺󿬻󿬼󿬽󿬾󿬿󿭀󿭁󿭂󿭃󿭄󿭅󿭆󿭇󿭈󿭉󿭊󿭋󿭌󿭍󿭎󿭏󿭐󿭑󿭒󿭓󿭔󿭕󿭖󿭗󿭘󿭙󿭚󿭛󿭜󿭝󿭞󿭟󿭠󿭡󿭢󿭣󿭤󿭥󿭦󿭧󿭨󿭩󿭪󿭫󿭬󿭭󿭮󿭯󿭰󿭱󿭲󿭳󿭴󿭵󿭶󿭷󿭸󿭹󿭺??????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????󿰡󿰢󿰣󿰤󿰥󿰦󿰧󿰨󿰩󿰪󿰫󿰬󿰭󿰮󿰯󿰰󿰱󿰲󿰳󿰴󿰵󿰶󿰷󿰸󿰹󿰺󿰻󿰼󿰽󿰾󿰿󿱀󿱁󿱂󿱃󿱄󿱅󿱆󿱇󿱈󿱉󿱊󿱋󿱌󿱍󿱎󿱏󿱐󿱑󿱒󿱓󿱔󿱕󿱖󿱗󿱘󿱙󿱚󿱛󿱜󿱝󿱞󿱟󿱠󿱡󿱢󿱣󿱤󿱥󿱦󿱧󿱨󿱩󿱪󿱫󿱬󿱭󿱮󿱯󿱰󿱱󿱲󿱳󿱴󿱵󿱶󿱷󿱸󿱹󿱺??????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????󿴡󿴢󿴣󿴤󿴥󿴦󿴧󿴨󿴩󿴪󿴫󿴬󿴭󿴮󿴯󿴰󿴱󿴲󿴳󿴴󿴵󿴶󿴷󿴸󿴹󿴺󿴻󿴼󿴽󿴾󿴿󿵀󿵁󿵂󿵃󿵄󿵅󿵆󿵇󿵈󿵉󿵊󿵋󿵌󿵍󿵎󿵏󿵐󿵑󿵒󿵓󿵔󿵕󿵖󿵗󿵘󿵙󿵚󿵛󿵜󿵝󿵞󿵟󿵠󿵡󿵢󿵣󿵤󿵥󿵦󿵧󿵨󿵩󿵪󿵫󿵬󿵭󿵮󿵯󿵰󿵱󿵲󿵳󿵴󿵵󿵶󿵷󿵸󿵹󿵺??????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????$Fr$GA$G@p$F[$FZ$F]$F\???$Eb?$E]?????????{|$FR$FS?????????$FW$FX$Gj??$Gl??$G"$GB?$E0?~?????~?$FT$FU$Gg?$Gv$FV$FY$GU?$Gr??$E/??$G!$Fn$Fo$E>?$G)???$Eh?$Ge$G($Gk?$Eh?$En$Eh$Eh$Eh???$EE$Gi$E#$G]?$GV??$EI???$E4$G_$Eh$Eh??$Ez???$E!???$E8$Gr?????$FP$FQ$Eh?$E2?$Gc$Eh???$E#???$G)?????$G*????$G+?$G=$G<??$G>@ ??$F($F*$F)$F<$F=$F>$F?$F@$FA$FB$FC$FD10?$Gh?????????????$Et?$Eq$Eo$Ep$Ek?$Em$GZ??$Ey$G???$G5$G3$ER$ED?????$ES?$EP??$GS$GP$E;??$Gf??$G9??$E@$Gt?$G:$E)?$Go$Gu?$E+??$Gw$Gy$Gx?$E\$Gy$E($E%$GC$GB?$E=?$El$GB$G#$E,??$E:??$G-???$FF$E<$G.$EJ$G\?$G^$Ga?$G^?$E3?Ez?$EF??$F3$E[?$G4???????$F.$F-$F/??$G1$G2????$FE$Fm?$GB?$E(???$F2??$G,$EH?$GW?$G[$G^$Gn$Gp$Gq$Gs?$E&$E'$E($E*$E-$E.$E1$E6$E7$E9$E>$EA$EB$EM$EN$EQ???$EW$E_?$Ef?$Ej?$Es$Eu$Ew$Ex$F"$F'$F+$F4$FG$FH$FI$FJ$FK$FL$FM$FN$FO?$Fp$Fq???????j???????????$F,$GB$GB$GB$GB$GB?$G3???????????????????$Gx???????????$G^$Gv??????????????$Gb??????????????????????$Ex$Gm???????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????$EZ??$G9?$G9????????`anAB?????!?!!`???????????????$G7???????????????????????????$Gy????$E#??????????????$E#$F!??$GB??????????$E#?$G0$F0?????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????$FE$F<$F=$F>$F?$F@$FA$FB$FC$FD101112$F<$F=$F>$F?$F@$FA$FB$FC$FD10$FMZxNE$FLp`}Sn$Gs$Gp???$G:$E)?$Gr???????????????$Go?$Gt$G9$E*???$GS???$GP$E9???????$G$$G%??$G!$G"$EZ??$E,$Gn$E:$Ez$Ey$G>$F!$G?$G=$F"??$Gc$Ev$E@??$Gg?$Ge$Gc???$G\$Ex$Ex?$ED?$G]???$G[???$El$ES$EM$ET$EV$EU????$G5$G4$G3$G3?$Eo$GZ$Ep$Gc??$Eu$EA$EC$Em??$Ew$F(?$Gj$Gi$Gk$Gh$E]?$F[$FZ???$FQ$FP$FO$FN$G0$G1$G2$G#$E<$GB$GB$F,$F-???????????????????????????????????????????????????????????????????$F/$F.!!!??????$G^$E0???$G&??$G&?????$E^??????$E>???$GT$G*$G*$G)$G)?$G+$G,????$G($E/?$EJ$EH$G^?$EF$E-??$Eh$Eh???$Es??$E#$E4??$GV$GX$GW???????????????????$E3??????$E.$GU$EO$G_$Ed?$E6?????????$Ga?$Eb$EE$E2???$Gk????????$Gz??$Gf???????tH~?$Gw$Gx$Gy??????????????????????????????????????????????????????????????????????????????????????????????????????????????????????$E5$E5$E5$E5????????????????????$G:$G:$G:$G:$E/$E/$E/$E/$Gj$Gj$Gj$Gj$GC$GC$GC$GC?$Gw$Gw$Gw?????????????????????????????????????????????????????????$F0$FE??$FE$F<$F=$F>$F?$F@$FA$FB$FC$FD10??-!%./:;?@^_'"{=~?????????$FmNG$FF$FG???????????????????????????????????????????????????????????????????`abcdefghijklmnopqrstuvwxy?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|}~?????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????$G$$G%???$Ez$Ez?$G<$ER??$En???$Et$Eq$F*?????????$FV$FX$FW$FY???$F2$GA??$F)?$GB$F1??????????????$E#????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????$Gj$Gi$Gk$Gh$E]???$F_$F`$Fa$Fb$Fc$Fd$Fe$Ff$Fg$Fh$Fi$Fj??$G4$G5?$G3?$ER?$G>?$G?$Ez$Ez$Ey$F"$G=$GV$GX$Es$Eu$Em$Et$Ex$Ev$GZ$Eo$En$Eq$Gc$Ge?$Gg$E@$E^?$G\$G]$FV?$G^???$EE?$F($G($E>$Eh?$E2?$G)$G*$Eh$EJ?$EF$F,$F.$F-$F/??$G0$G1$G2$FX$FW???$F*????????????????????????????????????????????????????????????????????????$Gr$Go$G<$GS$FY??????????????????ON?????????????????????$E$$E#$G+$E#???$FI$G_???$E4$F2?$F1$F0p$F<$F=$F>$F?$F@$FA$FB$FC$FD$FE$GB$GB$GC$GB$Gw$Gy$Gx$Gx??$G^$EC?$G#?$E/$Gy$G-???$E\$GA!?!!?$E($E(?``$Fm??$G&???$G3??$EO$G,???$E.$GT??????$E($E($Gy?$E&$G.$E%?$Gw??$Gx?NG?$Fn?$E5?$Fo$Fr$FK$FJ?$Ew?$G[$E0?????$E8$GP?$Gf?????$Gu$G9??$G:$E+?$E'????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????$E!$E"$E#$E$$E%$E&$E'$E($E)$E*$E+$E,$E-$E.$E/$E0$E1$E2$E3$E4$E5$E6$E7$E8$E9$E:$E;$E<$E=$E>$E?$E@$EA$EB$EC$ED$EE$EF$EG$EH$EI$EJ$EK$EL$EM$EN$EO$EP$EQ$ER$ES$ET$EU$EV$EW$EX$EY$EZ$E[$E\$E]$E^$E_$E`$Ea$Eb$Ec$Ed$Ee$Ef$Eg$Eh$Ei$Ej$Ek$El$Em$En$Eo$Ep$Eq$Er$Es$Et$Eu$Ev$Ew$Ex$Ey$Ez??????????????????????????????????????????????$E`$G^??j????????$Eb???????????$E>??$G^$GB$GB$GB$GB$GB$GB$GB??$E(~$Gy$G@$GA?????????????????????????????????????????????????????????????????????????$F!$F"$F#$F$$F%$F&$F'$F($F)$F*$F+$F,$F-$F.$F/$F0$F1$F2$F3$F4$F5$F6$F7$F8$F9$F:$F;$F<$F=$F>$F?$F@$FA$FB$FC$FD$FE$FF$FG$FH$FI$FJ$FK$FL$FM$FN$FO$FP$FQ$FR$FS$FT$FU$FV$FW$FX$FY$FZ$F[$F\$F]$F^$F_$F`$Fa$Fb$Fc$Fd$Fe$Ff$Fg$Fh$Fi$Fj$Fk$Fl$Fm$Fn$Fo$Fp$Fq$Fr$Fs$Ft$Fu$Fv$Fw$Fx$Fy$Fz??????????????????????????????????????$E(?????$Gx????????????$Gv$Gw$Gy???????????????????????$Ez??????$G????????$GW?????????$E9?$Gm???????????????????????????????????????????????????????$G!$G"$G#$G$$G%$G&$G'$G($G)$G*$G+$G,$G-$G.$G/$G0$G1$G2$G3$G4$G5$G6$G7$G8$G9$G:$G;$G<$G=$G>$G?$G@$GA$GB$GC$GD$GE$GF$GG$GH$GI$GJ$GK$GL$GM$GN$GO$GP$GQ$GR$GS$GT$GU$GV$GW$GX$GY$GZ$G[$G\$G]$G^$G_$G`$Ga$Gb$Gc$Gd$Ge$Gf$Gg$Gh$Gi$Gj$Gk$Gl$Gm$Gn$Go$Gp$Gq$Gr$Gs$Gt$Gu$Gv$Gw$Gx$Gy$Gz????????????????????????????????????????????$G]??????????????????$EZ?????$G9?$G9?????$E)?$Gr???????`aABn???????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????󿮡󿮢󿮣󿮤󿮥󿮦󿮧󿮨󿮩󿮪󿮫󿮬󿮭󿮮󿮯󿮰󿮱󿮲󿮳󿮴󿮵󿮶󿮷󿮸󿮹󿮺󿮻󿮼󿮽󿮾󿮿󿯀󿯁󿯂󿯃󿯄󿯅󿯆󿯇󿯈󿯉󿯊󿯋󿯌󿯍󿯎󿯏󿯐󿯑󿯒󿯓󿯔󿯕󿯖󿯗󿯘󿯙󿯚󿯛󿯜󿯝󿯞󿯟󿯠󿯡󿯢󿯣󿯤󿯥󿯦󿯧󿯨󿯩󿯪󿯫󿯬󿯭???????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????󿲡󿲢󿲣󿲤󿲥󿲦󿲧󿲨󿲩󿲪󿲫󿲬󿲭󿲮󿲯󿲰󿲱󿲲󿲳󿲴󿲵󿲶󿲷󿲸󿲹󿲺󿲻󿲼󿲽󿲾󿲿󿳀󿳁󿳂󿳃󿳄󿳅󿳆󿳇󿳈󿳉󿳊󿳋󿳌󿳍󿳎󿳏󿳐󿳑󿳒󿳓󿳔󿳕󿳖󿳗󿳘󿳙󿳚󿳛󿳜󿳝󿳞󿳟󿳠󿳡󿳢󿳣󿳤󿳥󿳦󿳧󿳨󿳩󿳪󿳫󿳬????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????󿶡󿶢󿶣󿶤󿶥󿶦󿶧󿶨󿶩󿶪󿶫󿶬󿶭󿶮󿶯󿶰󿶱󿶲󿶳󿶴󿶵󿶶󿶷󿶸󿶹󿶺󿶻󿶼󿶽󿶾󿶿󿷀󿷁󿷂󿷃󿷄󿷅󿷆󿷇󿷈󿷉󿷊󿷋󿷌󿷍󿷎󿷏󿷐󿷑󿷒󿷓󿷔󿷕󿷖󿷗󿷘󿷙???????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????$Fr$GA$G@p$F[$FZ$F]$F\???$O7?$E]?????????{|$OO$FR$FS?????????$FW$FX$Gj??$Gl$OE?$G"$GB?$E0$QW~?????$OS?$FT$FU$Gg?$P4$OO$FV$FY$GU?$Gr$Pk?$E/$QC?$G!$Fn$Fo$OC?$G)??$Q,$Eh$O!$Ge$G($Gk$PK$Eh?$En$Eh$Eh$Eh?$O3?$EE$Gi$E#$G]?$GV$O$?$EI???$E4$G_$Eh$Eh?$O:$Ez???$E!???$E8$QJ?????$FP$FQ$Eh?$E2?$Gc$Eh$PO??$E#???$G)?????$G*????$G+?$G=$G<??$G>@ ?$O.$F($F*$F)$F<$F=$F>$F?$F@$FA$FB$FC$FD10$Pc$Gh?????????????$Et?$Eq$Eo$Ep$Ek?$Em$GZ??$Ey$G???$G5$G3$ER$ED??$OD?$Q)$ES?$EP??$GS$GP$E;$Q+$Oh$Gf??$G9$Og$Ob$E@$Gt$QL$G:$E)$QQ$Go$Gu?$E+$O'$O%$P5$P6$Gx?$E\$OT$E($E%$GC$GB$OO$O1$E=?$El$OI$G#$E,?$QV$E:?$O5?$G-$OP??$FF$E<$G.$EJ$G\?$G^$Ga?$O*$O<$E3$O>Ez?$EF$O9?$F3$E[?$G4$PJ????$O4$Ok$F.$F-$F/$P9$P;$G1$G2????$FE$Fm?$GB?$OQ??$O`$F2??$G,$EH?$GW$PT$G[$G^$Gn$Gp$Gq$Gs?$E&$E'$E($E*$E-$E.$E1$E6$E7$E9$E>$EA$EB$EM$EN$EQ?$Q1$Q2$EW$E_?$Ef?$Ej?$Es$Eu$Ew$Ex$F"$F'$F+$F4$FG$FH$FI$FJ$FK$FL$FM$FN$FO?$Fp$Fq$O!$O"$O#$O&$O($O+$O,$O-?$O0$O2?$O8$O;$O=$O?$O@$OA$OB$F,$OG$OJ$OK$OL$OM?$G3?$OX$OY$OZ$O[$O\$O]$O^$O_$Oa$Oc$Od$Oe$Of$Oi$Oj$Ol?$P"$P'?????$P/??$P.??$OF$Gv?$P8$P:$P<?$P?$P@$PA$P>???$PE$PI$Gb$PL$PM$PP$PQ$PR$PS$PV$PX??$P[$P\?$P_$P`$Pa$Pb?$Pf$Ph$Pk$Pl$Ex$Pi$Q#$Q$$Q%$Q&?$Q-???????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????$Q.$Q/$Q0$Q3$Q4$Q5$Q6$Q7??$Q:$Q;$Q<$Q@?$QB$QE$QF$QG$QK?$QA?$QP$QR$QS$QU$QT$QV????!?!!`???????????????$G7????????$OZ??????????????????$Gy????$E#??????????????$E#$F!??$OH$QC????$P^????$E#?$G0$F0?????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????$FE$F<$F=$F>$F?$F@$FA$FB$FC$FD101112$F<$F=$F>$F?$F@$FA$FB$FC$FD10$FMZxNE$FLp`$O5}Sn$Gs$Gp$QL?$QM$G:$E)$QN$Gr$QO??????????????$Go$QF$Gt$Q@$E*???$GS?$O$$O%$GP$E9$Of$Oe?$Og???$G$$G%??$G!$G"$Q:?$Ph$E,$Gn$E:$PN$Ey$G>$F!$G?$G=$F"??$Gc$Ev$E@$O`$O+$Gg?$Ge$Gc?$Od?$G\$Ex$Ex?$ED?$G]???$G[???$El$ES$EM$ET$EV$EU???$PJ$G5$G4$G3$G3?$Eo$GZ$Ep$Gc??$Eu$EA$EC$Em??$Ew$F($O.$Gj$Gi$Gk$Gh$E]?$F[$FZ???$FQ$FP$FO$FN$G0$G1$G2$G#$E<$GB$GB$F,$F-???????????????????????????????????????????????????????????????????$F/$F.!!!??????$G^$E0$QE$PY?$G&??$G&?????$E^?$O"?$Q#??$OC???$GT$G*$G*$G)$G)?$G+$G,????$G($E/?$EJ$EH$O*?$EF$E-??$Eh$Eh?$O3?$Es??$E#$E4??$GV$GX$GW$Q&??????????????????$E3$O1?????$E.$GU$EO$G_$Ed?$E6???$OZ?????$Ga?$O7$EE$E2$O<??$Gk??$O]?????$Gz??$Gf???$O,?$O2?tH~$P($P5$Gx$P6??????????????????????????????????????????????????????????????????????????????????????????????????????????????????????$E5$E5$E5$E5????????????????????$G:$G:$G:$G:$E/$E/$E/$E/$Gj$Gj$Gj$Gj$GC$GC$GC$GC?$Gw$Gw$Gw?????????????????????????????????????????????????????????$F0$FE??$FE$F<$F=$F>$F?$F@$FA$FB$FC$FD10??-!%./:;?@^_'"{=~$OR?????????$FmNG$FF$FG???????????????????????????????????????????????????????????????????`abcdefghijklmnopqrstuvwxy?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|}~??????????????????????????????????????????????????????????????????????????$QV$QV?????????????????????????????????????????????????????????$QQ???$G$$G%???$Ez$Ez?$G<$ER$Ob?$En???$Et$Eq$F*?$Pc$P\??$Pk???$FV$FX$FW$FY???$F2$OW??$F)?$GB$F1??????????????$E#?????????????$P;??????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????$Gj$Gi$Gk$Gh$E]$Pc?$P\$F_$F`$Fa$Fb$Fc$Fd$Fe$Ff$Fg$Fh$Fi$Fj??$G4$G5?$G3$PJ$ER?$G>?$G?$Ez$PN$Ey$F"$G=$GV$GX$Es$Eu$Em$Et$Ex$Ev$GZ$Eo$En$Eq$Gc$Ge?$Gg$E@$E^$O3$G\$G]$FV?$O*???$EE$O.$F($G($OC$Eh$O4$E2?$G)$G*$Eh$EJ?$EF$F,$F.$F-$F/$P9$P;$G0$G1$G2$FX$FW$QV??$F*????????????????????????????????????????????????????????????????????????$Gr$Go$G<$GS$FY??????$OD???????????ON?????????????????????$E$$E#$G+$E#???$FI$G_???$E4$F2?$F1$F0p$F<$F=$F>$F?$F@$FA$FB$FC$FD$FE$GB$GB$GC$GB$Gw$P6$Gx$P'??$G^$EC?$G#$ON$E/$OT$G-$O1??$E\$OW!?!!?$OQ$E($OP``$Fm??$G&?$O<?$G3$OE?$EO$G,???$E.$GT??$OX???$E($P!$Gy?$E&$G.$E%$P%$P5$P&?$Gx$P(NG?$Fn$QW$E5$O5?$Fo$Fr$FK$FJ?$Ew$P^$G[$E0?$O$?$Oe?$E8$GP$Ob$Gf$O+$O`$OY?$QC$Gu$G9??$G:$E+?$E'????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????$E!$E"$E#$E$$E%$E&$E'$E($E)$E*$E+$E,$E-$E.$E/$E0$E1$E2$E3$E4$E5$E6$E7$E8$E9$E:$E;$E<$E=$E>$E?$E@$EA$EB$EC$ED$EE$EF$EG$EH$EI$EJ$EK$EL$EM$EN$EO$EP$EQ$ER$ES$ET$EU$EV$EW$EX$EY$EZ$E[$E\$E]$E^$E_$E`$Ea$Eb$Ec$Ed$Ee$Ef$Eg$Eh$Ei$Ej$Ek$El$Em$En$Eo$Ep$Eq$Er$Es$Et$Eu$Ev$Ew$Ex$Ey$Ez??????????????????????????????????????$O!$O"$O#$O$$O%$O&$O'$O($O)$O*$O+$O,$O-$O.$O/$O0$O1$O2$O3$O4$O5$O6$O7$O8$O9$O:$O;$O<$O=$O>$O?$O@$OA$OB$OC$OD$OE$OF$OG$OH$OI$OJ$OK$OL$OM$ON$OO$OP$OQ$OR$OS$OT$OU$OV$OW$OX$OY$OZ$O[$O\$O]$O^$O_$O`$Oa$Ob$Oc$Od$Oe$Of$Og$Oh$Oi$Oj$Ok$Ol$Om???????????????????????????????????????????????????$F!$F"$F#$F$$F%$F&$F'$F($F)$F*$F+$F,$F-$F.$F/$F0$F1$F2$F3$F4$F5$F6$F7$F8$F9$F:$F;$F<$F=$F>$F?$F@$FA$FB$FC$FD$FE$FF$FG$FH$FI$FJ$FK$FL$FM$FN$FO$FP$FQ$FR$FS$FT$FU$FV$FW$FX$FY$FZ$F[$F\$F]$F^$F_$F`$Fa$Fb$Fc$Fd$Fe$Ff$Fg$Fh$Fi$Fj$Fk$Fl$Fm$Fn$Fo$Fp$Fq$Fr$Fs$Ft$Fu$Fv$Fw$Fx$Fy$Fz??????????????????????????????????????$P!$P"$P#$P$$P%$P&$P'$P($P)$P*$P+$P,$P-$P.$P/$P0$P1$P2$P3$P4$P5$P6$P7$P8$P9$P:$P;$P<$P=$P>$P?$P@$PA$PB$PC$PD$PE$PF$PG$PH$PI$PJ$PK$PL$PM$PN$PO$PP$PQ$PR$PS$PT$PU$PV$PW$PX$PY$PZ$P[$P\$P]$P^$P_$P`$Pa$Pb$Pc$Pd$Pe$Pf$Pg$Ph$Pi$Pj$Pk$Pl????????????????????????????????????????????????????$G!$G"$G#$G$$G%$G&$G'$G($G)$G*$G+$G,$G-$G.$G/$G0$G1$G2$G3$G4$G5$G6$G7$G8$G9$G:$G;$G<$G=$G>$G?$G@$GA$GB$GC$GD$GE$GF$GG$GH$GI$GJ$GK$GL$GM$GN$GO$GP$GQ$GR$GS$GT$GU$GV$GW$GX$GY$GZ$G[$G\$G]$G^$G_$G`$Ga$Gb$Gc$Gd$Ge$Gf$Gg$Gh$Gi$Gj$Gk$Gl$Gm$Gn$Go$Gp$Gq$Gr$Gs$Gt$Gu$Gv$Gw$Gx$Gy$Gz??????????????????????????????????????$Q!$Q"$Q#$Q$$Q%$Q&$Q'$Q($Q)$Q*$Q+$Q,$Q-$Q.$Q/$Q0$Q1$Q2$Q3$Q4$Q5$Q6$Q7$Q8$Q9$Q:$Q;$Q<$Q=$Q>$Q?$Q@$QA$QB$QC$QD$QE$QF$QG$QH$QI$QJ$QK$QL$QM$QN$QO$QP$QQ$QR$QS$QT$QU$QV$QW$QX$QY??????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????󿁀󿁁󿁂󿁃󿁄󿁅󿁆󿁇󿁈󿁉󿁊󿁋󿁌󿁍󿁎󿁏󿁐󿁑󿁒󿁓󿁔󿁕󿁖󿁗󿁘󿁙󿁚󿁛󿁜󿁝󿁞󿁟󿁠󿁡󿁢󿁣󿁤󿁥󿁦󿁧󿁨󿁩󿁪󿁫󿁬󿁭󿁮󿁯󿁰󿁱󿁲󿁳󿁴󿁵󿁶󿁷󿁸󿁹󿁺󿁻󿁼󿁽󿁾?󿂀󿂁󿂂󿂃󿂄󿂅󿂆󿂇󿂈󿂉󿂊󿂋󿂌󿂍󿂎󿂏󿂐󿂑󿂒󿂓󿂔󿂕󿂖󿂗󿂘󿂙󿂚󿂛󿂜󿂝󿂞󿂟󿂠󿂡󿂢󿂣󿂤󿂥󿂦󿂧󿂨󿂩󿂪󿂫󿂬󿂭󿂮󿂯󿂰󿂱󿂲󿂳󿂴󿂵󿂶󿂷󿂸󿂹󿂺󿂻󿂼󿂽󿂾󿂿󿃀󿃁󿃂󿃃󿃄󿃅󿃆󿃇󿃈󿃉󿃊󿃋󿃌󿃍󿃎󿃏󿃐󿃑󿃒󿃓󿃔󿃕󿃖󿃗󿃘󿃙󿃚󿃛󿃜󿃝󿃞󿃟󿃠󿃡󿃢󿃣󿃤󿃥󿃦󿃧󿃨󿃩󿃪󿃫󿃬󿃭󿃮󿃯󿃰󿃱󿃲󿃳󿃴󿃵󿃶󿃷󿃸󿃹󿃺󿃻󿃼???????????????????????????????????????????????????????????????????󿅀󿅁󿅂󿅃󿅄󿅅󿅆󿅇󿅈󿅉󿅊󿅋󿅌󿅍󿅎󿅏󿅐󿅑󿅒󿅓󿅔󿅕󿅖󿅗󿅘󿅙󿅚󿅛󿅜󿅝󿅞󿅟󿅠󿅡󿅢󿅣󿅤󿅥󿅦󿅧󿅨󿅩󿅪󿅫󿅬󿅭󿅮󿅯󿅰󿅱󿅲󿅳󿅴󿅵󿅶󿅷󿅸󿅹󿅺󿅻󿅼󿅽󿅾?󿆀󿆁󿆂󿆃󿆄󿆅󿆆󿆇󿆈󿆉󿆊󿆋󿆌󿆍󿆎󿆏󿆐󿆑󿆒󿆓󿆔󿆕󿆖󿆗󿆘󿆙󿆚󿆛󿆜󿆝󿆞󿆟󿆠󿆡󿆢󿆣󿆤󿆥󿆦󿆧󿆨󿆩󿆪󿆫󿆬󿆭󿆮󿆯󿆰󿆱󿆲󿆳󿆴󿆵󿆶󿆷󿆸󿆹󿆺󿆻󿆼󿆽󿆾󿆿󿇀󿇁󿇂󿇃󿇄󿇅󿇆󿇇󿇈󿇉󿇊󿇋󿇌󿇍󿇎󿇏󿇐󿇑󿇒󿇓󿇔󿇕󿇖?????????????????????????????????????????????????????????????????????????????????????????????????????????󿉀󿉁󿉂󿉃󿉄󿉅󿉆󿉇󿉈󿉉󿉊󿉋󿉌󿉍󿉎󿉏󿉐󿉑󿉒󿉓󿉔󿉕󿉖󿉗󿉘󿉙󿉚󿉛󿉜󿉝󿉞󿉟󿉠󿉡󿉢󿉣󿉤󿉥󿉦󿉧󿉨󿉩󿉪󿉫󿉬󿉭󿉮󿉯󿉰󿉱󿉲󿉳󿉴󿉵󿉶󿉷󿉸󿉹󿉺󿉻󿉼󿉽󿉾?󿊀󿊁󿊂󿊃󿊄󿊅󿊆󿊇󿊈󿊉󿊊󿊋󿊌󿊍󿊎󿊏󿊐󿊑󿊒󿊓󿊔󿊕󿊖󿊗󿊘󿊙󿊚󿊛󿊜󿊝󿊞󿊟󿊠󿊡󿊢󿊣󿊤󿊥󿊦󿊧󿊨󿊩󿊪󿊫????󿊰󿊱󿊲󿊳󿊴󿊵󿊶󿊷󿊸󿊹󿊺󿊻󿊼󿊽󿊾󿊿󿋀󿋁󿋂󿋃󿋄󿋅󿋆󿋇󿋈󿋉󿋊󿋋󿋌󿋍󿋎󿋏󿋐󿋑󿋒󿋓󿋔󿋕?????????󿋟󿋠󿋡󿋢󿋣󿋤󿋥󿋦󿋧󿋨󿋩󿋪󿋫󿋬󿋭󿋮󿋯󿋰󿋱󿋲󿋳󿋴󿋵󿋶󿋷󿋸󿋹󿋺󿋻󿋼???????????????????????????????????????????????????????????????????󿍀󿍁󿍂󿍃󿍄󿍅󿍆󿍇󿍈󿍉󿍊󿍋󿍌󿍍󿍎󿍏󿍐󿍑󿍒󿍓󿍔󿍕󿍖󿍗󿍘󿍙󿍚󿍛󿍜󿍝󿍞󿍟󿍠󿍡󿍢󿍣󿍤󿍥󿍦󿍧󿍨󿍩󿍪󿍫󿍬󿍭󿍮󿍯󿍰󿍱󿍲󿍳󿍴󿍵󿍶󿍷󿍸󿍹󿍺󿍻󿍼󿍽󿍾?󿎀󿎁󿎂󿎃󿎄󿎅󿎆󿎇󿎈󿎉󿎊󿎋󿎌󿎍󿎎󿎏󿎐󿎑󿎒󿎓󿎔󿎕󿎖󿎗󿎘󿎙󿎚󿎛󿎜󿎝󿎞󿎟󿎠󿎡󿎢󿎣󿎤󿎥󿎦󿎧󿎨󿎩󿎪󿎫󿎬󿎭󿎮󿎯󿎰󿎱󿎲󿎳󿎴󿎵󿎶󿎷󿎸󿎹󿎺󿎻󿎼󿎽󿎾󿎿󿏀󿏁󿏂󿏃󿏄󿏅󿏆󿏇󿏈󿏉󿏊󿏋󿏌󿏍󿏎󿏏󿏐󿏑󿏒󿏓󿏔󿏕󿏖󿏗󿏘󿏙󿏚󿏛󿏜󿏝󿏞󿏟󿏠󿏡󿏢󿏣󿏤󿏥󿏦󿏧󿏨󿏩󿏪󿏫󿏬󿏭󿏮󿏯󿏰󿏱󿏲󿏳󿏴󿏵󿏶󿏷󿏸󿏹󿏺?????????????????????????????????????????????????????????????????????󿑀󿑁󿑂󿑃󿑄󿑅󿑆󿑇󿑈󿑉󿑊󿑋󿑌󿑍󿑎󿑏????????????????????????????????????????????????󿒀???󿒄󿒅󿒆󿒇󿒈󿒉󿒊?󿒌󿒍󿒎?󿒐???󿒔󿒕󿒖?󿒘󿒙󿒚󿒛󿒜???󿒠󿒡󿒢󿒣󿒤???󿒨󿒩󿒪󿒫󿒬󿒭󿒮󿒯????󿒴󿒵??????󿒼󿒽󿒾?????󿓄󿓅??󿓈???󿓌????????????????????????????????????????????????????H_?????????????Ё|?????????m??J?????~Ӂ?s?o????^?e?񳁣?yyn?z?zzz|???`??yy???????sk???y}?z?w????e?{{?d???h???@ ?MNOPQRSTUVuvwxyz{|~}??????????p??????mpq??????????D?E?b?????q?I?s?Ez?u??UP????????A@????????????ir??Il?k???v?^?VS??????????~???TID^W????Y???ʏj?????????????????????????????????????I???????????????????????????????????[?????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????K??????`anABEV???CB`???????????n?????????????????????????????????????????????S???????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|}~????????????????????????????????????????????????????????????????????@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|}~??????????????????????????????????????????????????????????????????????????????????????????????????????????@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|}~?????????????????????????????????????????????????????????????????????????????????@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|}~??????????????????????????????????????????????????????????????????????@ABCDEFGHIJKLMNO??????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????uvwxyz{|~?g?~W|?s??n^z??edyqpuA@?EV`??????????????????????????????????????????????????????????????????????s????????w????????ON?m???????????????????ch???ID???_????I?o???CB????``??O?S?i?wb?????????????}??Lb?֋󍇖?J?????????p?????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????c???q?voJL???????uur?q??VS????????W?????z????~???????????????????????????????????????Y????sʏj??|?b???????????^??I???ԁ~ՁH????????????????????????????????????????????????????????????????????????A@UP?L?\???MNOPQRSTUTID^W?uvwxyz{|~}??????i????????????????????????????????????????????????????????????????????????????????????????????L??????????????????????????????????????????????????????????????????O?nedhi???pH???????????????b?I?????l?sk?????????????????????????????????????????[????????????????????????????K?q?s?mort?`aABnE?????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????󾀁󾀂󾀃󾀄󾀅󾀆󾀇󾀈󾀉󾀊󾀋󾀌󾀍󾀎󾀏󾀐󾀑󾀒󾀓󾀔󾀕󾀖󾀗󾀘󾀙󾀚󾀛󾀜󾀝󾀞󾀟󾀠󾀡󾀢󾀣󾀤󾀥󾀦󾀧󾀨󾀩󾀪󾀫󾀬󾀭󾀮󾀯󾀰󾀱󾀲󾀳󾀴󾀵󾀶󾀷󾀸󾀹󾀺󾀻󾀼󾀽󾀾󾀿󾁀󾁁󾁂󾁃󾁄󾁅󾁆󾁇󾁈󾁉󾁊󾁋󾁌󾁍󾁎󾁏󾁐󾁑󾁒󾁓󾁔󾁕󾁖󾁗󾁘󾁙󾁚󾁛󾁜󾁝󾁞󾁟󾁠󾁡󾁢󾁣󾁤󾁥󾁦󾁧󾁨󾁩󾁪󾁫󾁬󾁭󾁮󾁯󾁰󾁱󾁲󾁳󾁴󾁵󾁶󾁷󾁸󾁹󾁺󾁻󾁼󾁽󾁾󾁿󾂀󾂁󾂂󾂃󾂄󾂅󾂆󾂇󾂈󾂉󾂊󾂋󾂌󾂍󾂎󾂏󾂐󾂑󾂒󾂓󾂔󾂕󾂖󾂗󾂘󾂙󾂚󾂛󾂜󾂝󾂞󾂟󾂠󾂡󾂢󾂣󾂤󾂥󾂦󾂧󾂨󾂩󾂪󾂫󾂬󾂭󾂮󾂯󾂰󾂱󾂲󾂳󾂴󾂵󾂶󾂷󾂸󾂹󾂺󾂻󾂼󾂽󾂾󾂿󾃀󾃁󾃂󾃃󾃄󾃅󾃆󾃇󾃈󾃉󾃊󾃋󾃌󾃍󾃎󾃏󾃐󾃑󾃒󾃓󾃔󾃕󾃖󾃗󾃘󾃙󾃚󾃛󾃜󾃝󾃞󾃟󾃠󾃡󾃢󾃣󾃤󾃥󾃦󾃧󾃨󾃩󾃪󾃫󾃬󾃭󾃮󾃯󾃰󾃱󾃲󾃳󾃴󾃵󾃶󾃷󾃸󾃹󾃺󾃻󾃼󾃽󾃾󾃿󾄀󾄁󾄂󾄃󾄄󾄅󾄆󾄇󾄈󾄉󾄊󾄋󾄌󾄍󾄎󾄏󾄐󾄑󾄒󾄓󾄔󾄕󾄖󾄗󾄘󾄙󾄚󾄛󾄜󾄝󾄞󾄟󾄠󾄡󾄢󾄣󾄤󾄥󾄦󾄧󾄨󾄩󾄪󾄫󾄬󾄭󾄮󾄯󾄰󾄱󾄲󾄳󾄴󾄵󾄶󾄷󾄸󾄹󾄺󾄻󾄼󾄽󾄾󾄿󾅀󾅁󾅂󾅃󾅄󾅅󾅆󾅇󾅈󾅉󾅊 ? +  !"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|}~  +    !"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJ????????????#????? +??????L?S???VS??????????????????TIDwc????????????j???????????333333?????????????????????????????????#D???????????????????????????????????K????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????`anAB????!?!!`??????????????????????????????????????????????l??????????????l???3N?????????l???????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????E1112cZxNEȎw`}őSn?????J???????q???????????P2????}????A4]???!????n???????????-32?????????,k_???????@3 +3;???????????????????????????????????????????????????????????????????<:!!!?????#5????????????|??????S?t?HU????.^M ?&?,??[ah???lwC1p?????????????????????( ??????Hx??{???????$W j'??_?????????m????????tďH~???????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????MMMM,,,,    ???????????????????????????????????????????????????????????E??E??-!%./:;?@^_'"=7Bm?????????FNG???????????????????????????????????????????????????????????????????`abcdefghijklmnopqrstuvwxy‚?ĂłƂǂȂɂʂ˂̂͂΂ςЂт҂ӂԂՂւׂ؂قڂۂ܂݂ނ߂@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|}~???????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????}}??c???????K???F+*G?????H????????????g>l?????????????>??????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????,k_1??-2?3??}}p????c]4A|h!nF?&???j^Sa8?U[ ,3:;<=>?@+*?t???????????????????????????????????????????????????????????????????A????JG????????????????ON?.????????????????????l??m+IDx??Dw????E3H  +?G?#??M ??!?!!?J``F????'?0????H9???? +????NGQ6??R֋󍇖????5q???????N?? ?????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????? +????M5?(w??L? ?????j,,?s ???VS????????0|? ????a??c?????}?????????????????????????????????????????q??&??j?? ?h8? ?-|?'?)????S0#333333?EJ=E????????????????9????????????????????????????????????????????????????????????3;:??????????????3`??}?????????????????????????K?????????????????????????????????????????????????????P2????^U???@?2-?}3 ??????????????HHp????!n#x?$??]Ak,_/????J?D?????????????????????????????????????????????n??Z????????????????????N??????????`aABn6????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????󾀁󾀂󾀃󾀄󾀅󾀆󾀇󾀈󾀉󾀊󾀋󾀌󾀍󾀎󾀏󾀐󾀑󾀒󾀓󾀔󾀕󾀖󾀗󾀘󾀙󾀚󾀛󾀜󾀝󾀞󾀟󾀠󾀡󾀢󾀣󾀤󾀥󾀦󾀧󾀨󾀩󾀪󾀫󾀬󾀭󾀮󾀯󾀰󾀱󾀲󾀳󾀴󾀵󾀶󾀷󾀸󾀹󾀺󾀻󾀼󾀽󾀾󾀿󾁀󾁁󾁂󾁃󾁄󾁅󾁆󾁇󾁈󾁉󾁊󾁋󾁌󾁍󾁎󾁏󾁐󾁑󾁒󾁓󾁔󾁕󾁖󾁗󾁘󾁙󾁚󾁛󾁜󾁝󾁞󾁟󾁠󾁡󾁢󾁣󾁤󾁥󾁦󾁧󾁨󾁩󾁪󾁫󾁬󾁭󾁮󾁯󾁰󾁱󾁲󾁳󾁴󾁵󾁶󾁷󾁸󾁹󾁺󾁻󾁼󾁽󾁾󾁿󾂀󾂁󾂂󾂃󾂄󾂅󾂆󾂇󾂈󾂉󾂊󾂋󾂌󾂍󾂎󾂏󾂐󾂑󾂒󾂓󾂔󾂕󾂖󾂗󾂘󾂙󾂚󾂛󾂜󾂝󾂞󾂟󾂠󾂡󾂢󾂣󾂤󾂥󾂦󾂧󾂨󾂩󾂪󾂫󾂬󾂭󾂮󾂯󾂰󾂱󾂲󾂳󾂴󾂵󾂶󾂷󾂸󾂹󾂺󾂻󾂼󾂽󾂾󾂿󾃀󾃁󾃂󾃃󾃄󾃅󾃆󾃇󾃈󾃉󾃊󾃋󾃌󾃍󾃎󾃏󾃐󾃑󾃒󾃓󾃔󾃕󾃖󾃗󾃘󾃙󾃚󾃛󾃜󾃝󾃞󾃟󾃠󾃡󾃢󾃣󾃤󾃥󾃦󾃧󾃨󾃩󾃪󾃫󾃬󾃭󾃮󾃯󾃰󾃱󾃲󾃳󾃴󾃵󾃶󾃷󾃸󾃹󾃺󾃻󾃼󾃽󾃾󾃿󾄀󾄁󾄂󾄃󾄄󾄅󾄆󾄇󾄈󾄉󾄊󾄋󾄌󾄍󾄎󾄏󾄐󾄑󾄒󾄓󾄔󾄕󾄖󾄗󾄘󾄙󾄚󾄛󾄜󾄝󾄞󾄟󾄠󾄡󾄢󾄣󾄤󾄥󾄦󾄧󾄨󾄩󾄪󾄫󾄬󾄭󾄮󾄯󾄰󾄱󾄲󾄳󾄴󾄵󾄶󾄷󾄸󾄹󾄺󾄻󾄼󾄽󾄾󾄿󾅀󾅁󾅂󾅃󾅄󾅅󾅆󾅇󾅈󾅉󾅊󾅋󾅌󾅍󾅎󾅏󾅐󾅑󾅒󾅓󾅔󾅕󾅖󾅗󾅘󾅙󾅚󾅛󾅜󾅝󾅞󾅟󾅠󾅡󾅢󾅣󾅤󾅥󾅦󾅧󾅨󾅩󾅪󾅫󾅬󾅭󾅮󾅯󾅰󾅱󾅲󾅳󾅴󾅵󾅶󾅷󾅸󾅹󾅺󾅻󾅼󾅽󾅾󾅿󾆀󾆁󾆂󾆃󾆄󾆅󾆆󾆇󾆈󾆉󾆊󾆋󾆌󾆍󾆎󾆏󾆐󾆑󾆒󾆓󾆔󾆕󾆖󾆗󾆘󾆙󾆚󾆛󾆜󾆝󾆞󾆟󾆠󾆡󾆢󾆣󾆤󾆥󾆦󾆧󾆨󾆩󾆪󾆫󾆬󾆭󾆮󾆯󾆰󾆱󾆲󾆳󾆴󾆵󾆶󾆷󾆸󾆹󾆺󾆻󾆼󾆽󾆾󾆿󾇀󾇁󾇂󾇃󾇄󾇅󾇆󾇇󾇈󾇉󾇊󾇋󾇌󾇍󾇎󾇏󾇐󾇑󾇒󾇓󾇔󾇕󾇖󾇗󾇘󾇙󾇚󾇛󾇜󾇝󾇞󾇟󾇠󾇡󾇢󾇣󾇤󾇥󾇦󾇧󾇨󾇩󾇪󾇫󾇬󾇭󾇮󾇯󾇰󾇱󾇲󾇳󾇴󾇵󾇶󾇷󾇸󾇹󾇺󾇻󾇼󾇽󾇾󾇿󾈀󾈁󾈂󾈃󾈄󾈅󾈆?????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????󾊼󾊽󾊾󾊿󾋀󾋁󾋂󾋃󾋄󾋅󾋆󾋇󾋈󾋉󾋊󾋋󾋌󾋍󾋎󾋏󾋐󾋑󾋒󾋓󾋔󾋕󾋖󾋗󾋘󾋙󾋚󾋛󾋜󾋝󾋞󾋟󾋠󾋡󾋢󾋣󾋤󾋥󾋦󾋧󾋨󾋩󾋪󾋫󾋬󾋭󾋮󾋯󾋰󾋱󾋲󾋳󾋴󾋵󾋶󾋷󾋸󾋹󾋺󾋻󾋼󾋽󾋾󾋿󾌀󾌁󾌂󾌃󾌄󾌅󾌆󾌇󾌈󾌉󾌊󾌋󾌌󾌍󾌎󾌏󾌐󾌑󾌒󾌓󾌔󾌕󾌖󾌗󾌘󾌙󾌚󾌛󾌜󾌝󾌞󾌟󾌠󾌡󾌢󾌣󾌤󾌥󾌦󾌧󾌨󾌩󾌪󾌫󾌬󾌭󾌮󾌯󾌰󾌱󾌲󾌳󾌴󾌵󾌶 ? +  !"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|}~  +    !"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|}~?????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????  +    !"#$%&'()*+,-./0123456?????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????E1112ZxNE`}őSn[Y??J??`???qf????P2?X} {?MA4]??!z??n??V??j????-32?xh?v?y,k_?)?'1?@3 +3;???????????????????????????????????????????????????????????????????<:????W5???????%??|????S?t?HU?Q??.^M R&?,a?[ahw?&lwC1p?T??????????????????( ?????bHx?d{????$W j'?_????????m??????tďH~???????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????MMMM,,,,    ??????????????????????????????????????????????????????????2E??E??-!%./:;?@^_'"=7Bm?????????FNG???????????????????????????????????????????????????????????????????`abcdefghijklmnopqrstuvwxy‚?ĂłƂǂȂɂʂ˂̂͂΂ςЂт҂ӂԂՂւׂ؂قڂۂ܂݂ނ߂@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|}~???????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????}}??c??????K???F+*G(???N?H????????????g>l?????????????>??????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????,k_1?-23??}}{p?wxzc]4A|h!nF?&???j^Sa8?U[ ,3:;<=>1?@+*t???????????????????????????????????????????????????????????????????A????JG????????????????ON?.????????????????????l??m+x??DwN??2E3H  +GW??M ??J`F????'%0?Q&bH9??_ ?]????NGQ6?'R()y*V5q+M?N?. ^?????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????]^_`abM5c(w?def ??hi?j,,Rs ??jkl???p???0|q ??s?a?uc?wxyz}??????????????????????????????????????q&? h8? -|')S0#?EJ=EM9???????????????????????????????????????????????????? {????|}3;:<2?N/~L\???E?@F*+G??FQR?i??????????????????????????????????????????????????????????D?=>???????3`}U???T*???sK????????????????????????????????????????????????????P2????^UQ?1?@2-}3 ??????????????HHpT??V!nWx?$?]Ak,_/XYZJ[?????????????????????????????????????????n??Zno?????N?????6????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????󾁋󾂾󾁣󾃚󾁌󾃟󾃥󾃦󾃶󾄁󾄂󾄃󾄄󾄅󾁍󾄉󾄊󾄋󾄌󾄍󾀺󾂰󾂱󾂲󾂳󾀁󾀂󾀃󾁢󾂿󾀏󾀐󾀬󾀯󾀼󾁅󾁟󾁫󾂧󾃀󾃁󾃂󾃃󾃄󾃅󾃆󾃇󾃈󾃉󾃊󾃋󾃌󾁓󾁛󾁪󾁺󾂏󾂕󾂞󾃍󾃎󾃏󾃐?󾃑󾃒󾃓󾃔󾁰󾂒󾂜󾃗󾃘󾃙󾁽󾂔󾂨󾂩󾂬󾃛󾃜󾃝󾃞󾀭󾁠󾃠󾃡󾃢󾃣󾃤󾀌󾀴󾁁󾂠󾃧󾃨󾃩󾂪󾃪󾃫󾃬󾃭󾃮󾂅󾂐󾃯󾃰󾃱󾃲󾃳󾃴󾃵󾃷󾃸󾃹󾃺󾃻󾃼󾃽󾃾󾁊󾁎󾂆󾃿󾄀󾁱󾄆󾄇󾄈󾄎󾄏󾄐󾄑󾄒󾄓󾄔󾄕󾄖󾄗󾄘󾄙󾄚󾄛󾄜󾄝󾄞󾄟󾀲󾁄󾁐󾁖󾁴󾂌󾂍󾂣󾄠󾄡󾄢󾄣󾄤󾄥󾄦󾄧󾄨󾄩󾄬󾄭󾄮󾄯󾄰󾀍󾀰󾀵󾁈󾁞󾁨󾁮󾁷󾁸󾁼󾂁󾂊󾂑󾂛󾂥󾂦󾁬󾂴󾂵???????????????????????????????????????????????????????????????????󾂶󾂷󾂸󾂹󾂺󾂻󾂼󾂽󾀄󾀅󾀆󾀇󾀈󾀉󾀊󾀋󾀑󾀒󾀓󾀔󾀕󾀖󾀗󾀘󾀚󾀛󾀜󾀝󾀞󾀟󾀠󾀡󾀢󾀣󾀤󾀥󾀦󾀧󾀨󾀩󾀪󾀫󾀶󾀷󾀽󾀾󾀿󾁀󾁂󾁆󾁇󾁉󾁑󾁒󾁘󾁙󾁵󾁶󾂄󾂈󾀱󾀸󾀻?󾁃󾁜󾁡󾁤󾁥󾁦󾁧󾁩󾁹󾂃󾂉󾂎󾂓󾂝󾃕󾃖󾁚󾁿󾂀󾂟󾄪󾄫󾀎󾀙󾀹󾁗󾁭󾁯󾁲󾁳󾁻󾁾󾂂󾂇󾂋󾂖󾂘󾂡󾂢󾂤󾂫󾂭󾂮󾂯󾁏󾁔󾂗󾂙󾂚󾀮󾀳󾁕󾁝󾄱󾄲󾄳󾄴󾄵󾄶󾄷󾄸󾄹󾄺󾄻󾄼󾄽󾄾󾄿󾅀󾅁󾅂󾅃󾅄󾅅󾅆󾅇󾅈󾅉󾅊??????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????YZ[HIJKLMNO^_PQRSTUVWXYZ[\]^_`abcdefghi`a|jk}T~blmnopcqrs@DNtutvwud\Bvexywz{xyzfUVWX@ABCDEFGA]ghijklmnopqrs{|}~CEFGHIJKLMOPQRS?????????????????P??????D?t???VS??????????????????TIDwc????????????j???????????????????????????????????????????????????????????????????????????????@???????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????H?H????????`anAB????!?!!`??????????????????????????????????????????J?????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????@ABCDEFG1112@ABCDEFGcZxNEȎwH`ʒ}őSn??????ghijklmnso?pqr?HH?????????????????????|????????E???????F???????~???????VU`ed]_?IJ?????P???????????????????????????????????????????????????????????????????!!!???????????????????????t??????N???y?uzx???|?????????????????????R???????????????v??d?????????????????tďH~?IKJ??????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????NNNN````OOOO?III????????????????????????????????????????????????????????????@ABCDEFG??-!%./:;?@^_'"X=kp?????????NGЊ???????????????????????????????????????????????????????????????????`abcdefghijklmnopqrstuvwxy‚?ĂłƂǂȂɂʂ˂̂͂΂ςЂт҂ӂԂՂւׂ؂قڂۂ܂݂ނ߂@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|}~?????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????B???{}W?A???@???qihr????ZX?????????????m???????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????`ed]_A?ghijklmnopqr???????{?|~B}q????vUVt?uih?W???????????????????????????????????????????????????????????????????????r???????y?????????ON???????????????????????ID??????H@ABCDEFOPIJK????NR??MZ!?!!?́``????????y????J?P?I??K?NGxtj??uY֋󍇖???????????H????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????P????N???D?S?????Ev????VS?F???????M_?}??????B~}??{?|?????????????????????????????????????????????}??jU??R?????????t?c΁lc[Z???????????????????????????????????????????????????????????????????????????VXW?????L\???@ABCDEFЊTIDwc??[\noqhirJILK?ghijklmnopqrs?tu??Y?i??????????????????????????????????????????????????????????????IJ?????????????????????????????????????A???????@?????????????????????????????????????????????????????????????H[ZO?????????????????????]e`da?????HIKJ??????????????????????????????????????????????????????????????????H?H??????????볂`aABnj????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????󾁋󾂾󾁣󾃚󾁌󾃟󾃥󾃦󾃶󾄁󾄂󾄃󾄄󾄅󾁍󾄉󾄊󾄋󾄌󾄍󾀺󾂰󾂱󾂲󾂳󾀁󾀂󾀃󾁢󾂿󾀏󾀐󾀬󾀯󾀼󾁅󾁟󾁫󾂧󾃀󾃁󾃂󾃃󾃄󾃅󾃆󾃇󾃈󾃉󾃊󾃋󾃌󾁓󾁛󾁪󾁺󾂏󾂕󾂞󾃍󾃎󾃏󾃐?󾃑󾃒󾃓󾃔󾁰󾂒󾂜󾃗󾃘󾃙󾁽󾂔󾂨󾂩󾂬󾃛󾃜󾃝󾃞󾀭󾁠󾃠󾃡󾃢󾃣󾃤󾀌󾀴󾁁󾂠󾃧󾃨󾃩󾂪󾃪󾃫󾃬󾃭󾃮󾂅󾂐󾃯󾃰󾃱󾃲󾃳󾃴󾃵󾃷󾃸󾃹󾃺󾃻󾃼󾃽󾃾󾁊󾁎󾂆󾃿󾄀󾁱󾄆󾄇󾄈󾄎󾄏󾄐󾄑󾄒󾄓󾄔󾄕󾄖󾄗󾄘󾄙󾄚󾄛󾄜󾄝󾄞󾄟󾀲󾁄󾁐󾁖󾁴󾂌󾂍󾂣󾄠󾄡󾄢󾄣󾄤󾄥󾄦󾄧󾄨󾄩󾄬󾄭󾄮󾄯󾄰󾀍󾀰󾀵󾁈󾁞󾁨󾁮󾁷󾁸󾁼󾂁󾂊󾂑󾂛󾂥󾂦󾁬󾂴󾂵???????????????????????????????????????????????????????????????????󾂶󾂷󾂸󾂹󾂺󾂻󾂼󾂽󾀄󾀅󾀆󾀇󾀈󾀉󾀊󾀋󾀑󾀒󾀓󾀔󾀕󾀖󾀗󾀘󾀚󾀛󾀜󾀝󾀞󾀟󾀠󾀡󾀢󾀣󾀤󾀥󾀦󾀧󾀨󾀩󾀪󾀫󾀶󾀷󾀽󾀾󾀿󾁀󾁂󾁆󾁇󾁉󾁑󾁒󾁘󾁙󾁵󾁶󾂄󾂈󾀱󾀸󾀻?󾁃󾁜󾁡󾁤󾁥󾁦󾁧󾁩󾁹󾂃󾂉󾂎󾂓󾂝󾃕󾃖󾁚󾁿󾂀󾂟󾄪󾄫󾀎󾀙󾀹󾁗󾁭󾁯󾁲󾁳󾁻󾁾󾂂󾂇󾂋󾂖󾂘󾂡󾂢󾂤󾂫󾂭󾂮󾂯󾁏󾁔󾂗󾂙󾂚󾀮󾀳󾁕󾁝󾄱󾄲󾄳󾄴󾄵󾄶󾄷󾄸󾄹󾄺󾄻󾄼󾄽󾄾󾄿󾅀󾅁󾅂󾅃󾅄󾅅󾅆󾅇󾅈󾅉󾅊󾅋󾅌󾅍󾇴󾇵󾇶󾇷󾇸󾇹󾇺󾇻󾇼󾇽󾇾󾇿󾈀󾈁󾈂󾈃󾈄󾈅󾈆󾅎󾅏󾅐󾅑󾅒󾅓󾅔󾅕󾅖󾅗󾅘󾅙󾅚󾅛󾅜󾅝󾅞󾅟󾅠󾅡󾅢󾅣󾅤󾅥???????????????????????????????????????????????????????????????????󾅦󾅧󾅨󾅩󾅪󾅫󾅬󾅭󾅮󾅯󾅰󾅱󾅲󾅳󾅴󾅵󾅶󾅷󾅸󾅹󾅺󾅻󾅼󾅽󾅾󾅿󾆀󾆁󾆂󾆃󾆄󾆅󾆆󾆇󾆈󾆉󾆊󾆋󾆌󾆍󾆎󾆏󾆐󾆑󾆒󾆓󾆔󾆕󾆖󾆗󾆘󾆙󾆚󾆛󾆜󾆝󾆞󾆟󾆠󾆡󾆢󾆣󾆤?󾆥󾆦󾆧󾆨󾆩󾆪󾆫󾆬󾆭󾆮󾆯󾆰󾆱󾆲󾆳󾆴󾆵󾆶󾆷󾆸󾆹󾆺󾆻󾆼󾆽󾆾󾆿󾇀󾇁󾇂󾇃󾇄󾇅󾇆󾇇󾇈󾇉󾇊󾇋󾇌󾇍󾇎󾇏󾇐󾇑󾇒󾇓󾇔󾇕󾇖󾇗󾇘󾇙󾇚󾇛󾇜󾇝󾇞󾇟󾇠󾇡󾇢󾇣󾇤󾇥󾇦󾇧󾇨󾇩󾇪󾇫󾇬󾇭󾇮󾇯󾇰󾇱󾇲󾇳󾊼󾊽󾊾󾊿󾋀󾋁󾋂󾋃󾋄󾋅󾋆󾋇󾋈󾋉󾋊󾋋󾋌󾋍󾋎󾋏󾋐󾋑󾋒󾋓󾋔󾋕󾋖󾋗󾋘󾋙󾋚󾋛󾋜󾋝󾋞󾋟󾋠󾋡󾋢󾋣󾋤󾋥󾋦󾋧󾋨󾋩???????????????????????????????????????????????????????????????????󾋪󾋫󾋬󾋭󾋮󾋯󾋰󾋱󾋲󾋳󾋴󾋵󾋶󾋷󾋸󾋹󾋺󾋻󾋼󾋽󾋾󾋿󾌀󾌁󾌂󾌃󾌄󾌅󾌆󾌇󾌈󾌉󾌊󾌋󾌌󾌍󾌎󾌏󾌐󾌑󾌒󾌓󾌔󾌕󾌖󾌗󾌘󾌙󾌚󾌛󾌜󾌝󾌞󾌟󾌠󾌡󾌢󾌣󾌤󾌥󾌦󾌧󾌨?󾌩󾌪󾌫󾌬󾌭󾌮󾌯󾌰󾌱󾌲󾌳󾌴󾌵󾌶???????????????????????????????????????????????????????????????????????????????????????????????????????????????????YZ[HIJKLMNO^_PQRSTUVWXYZ[\]^_`abcdefghi`a|jk}T~blmnopcqrs@DNtutvwud\Bvexywz{xyzfUVWX@ABCDEFGA]ghijklmnopqrs{|}~CEFGHIJKLMOPQRS@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|}~?????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|}~?????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????@ABCDEFG1112@ABCDEFG_ZxNE^H`ʒ}őSnC???ghijklmnso?pqrH???M@?????vU?|j??T?E?????FD????q~?RB?P?SVU`ed]_?IJ?}a`P??????????????????????????????????????????????????????????????????????????????{???f???t?????N?y?uzxQ?||???????????????????R????????NQ?R?vm?d????????????k?o?tďH~?IKJ??????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????NNNN````OOOO?III???????????????????????????????????????????????????????????@ABCDEFG??-!%./:;?@^_'"X=kp?????????NGY???????????????????????????????????????????????????????????????????`abcdefghijklmnopqrstuvwxy‚?ĂłƂǂȂɂʂ˂̂͂΂ςЂт҂ӂԂՂւׂ؂قڂۂ܂݂ނ߂@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|}~?????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????B???{}W?A??@???qihr~???ZX?????????????m???????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????`ed]_Aghijklmnopqr???U?QR{T|~B}q????vUVt?uihW???????????????????????????????????????????????????????????????????????r???????y?????????ON???????????????????????[????H@ABCDEFOPIJK?M?NR?MZ?́`????{?|y??a??I??K?NGxtj?}uY]\~Sj?H??????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????N?@S??BC?Ev??DEFF???J???M_K}??M??OB~}?Q{R|ST??????????????????????????????????????efghi}jklU?nRo?qrstuvwtyyz{|}?c΁lc[Z????????????????????????????????????????????????????vU????VVXWW?XL\???@ABCDEFYZ[\]^_`a[\noqhirJILK?ghijklmnopqrs?tucdY?i??????????????????????????????????????????????????????????IJ???????????A???M@?????????????????????????????????????????????????????????EH[ZO??????????????????]e`daHIKJ???????????????????????????????????????????HI??????????j???????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????????? \ No newline at end of file diff -urN /non-existant-dir/bundle/enum.pm tiarra-20080510/bundle/enum.pm --- /non-existant-dir/bundle/enum.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/bundle/enum.pm 2008-05-11 00:25:24.000000000 +0900 @@ -0,0 +1,387 @@ +package enum; +use strict; +no strict 'refs'; # Let's just make this very clear right off + +use Carp; +use vars qw($VERSION); +$VERSION = do { my @r = (q$Revision: 1.16 $ =~ /\d+/g); sprintf '%d.%03d'.'%02d' x ($#r-1), @r}; + +my $Ident = '[^\W_0-9]\w*'; + +sub ENUM () { 1 } +sub BITMASK () { 2 } + +sub import { + my $class = shift; + @_ or return; # Ignore 'use enum;' + my $pkg = caller() . '::'; + my $prefix = ''; # default no prefix + my $index = 0; # default start index + my $mode = ENUM; # default to enum + + ## Pragmas should be as fast as they can be, so we inline some + ## pieces. + foreach (@_) { + ## Plain tag is most common case + if (/^$Ident$/o) { + my $n = $index; + + if ($mode == ENUM) { + $index++; + } + elsif ($mode == BITMASK) { + $index ||= 1; + $index *= 2; + if ( $index & ($index - 1) ) { + croak ( + "$index is not a valid single bitmask " + . " (Maybe you overflowed your system's max int value?)" + ); + } + } + else { + confess qq(Can't Happen: mode $mode invalid); + } + + *{"$pkg$prefix$_"} = sub () { $n }; + } + + ## Index change + elsif (/^($Ident)=(-?)(.+)$/o) { + my $name= $1; + my $neg = $2; + $index = $3; + + ## Convert non-decimal numerics to decimal + if ($index =~ /^0x[\da-f]+$/i) { ## Hex + $index = hex $index; + } + elsif ($index =~ /^0\d/) { ## Octal + $index = oct $index; + } + elsif ($index !~ /[^\d_]/) { ## 123_456 notation + $index =~ s/_//g; + } + + ## Force numeric context, but only in numeric context + if ($index =~ /\D/) { + $index = "$neg$index"; + } + else { + $index = "$neg$index"; + $index += 0; + } + + my $n = $index; + + if ($mode == BITMASK) { + ($index & ($index - 1)) + and croak "$index is not a valid single bitmask"; + $index *= 2; + } + elsif ($mode == ENUM) { + $index++; + } + else { + confess qq(Can't Happen: mode $mode invalid); + } + + *{"$pkg$prefix$name"} = sub () { $n }; + } + + ## Prefix/option change + elsif (/^([A-Z]*):($Ident)?(=?)(-?)(.*)/) { + ## Option change + if ($1) { + if ($1 eq 'ENUM') { $mode = ENUM; $index = 0 } + elsif ($1 eq 'BITMASK') { $mode = BITMASK; $index = 1 } + else { croak qq(Invalid enum option '$1') } + } + + my $neg = $4; + + ## Index change too? + if ($3) { + if (length $5) { + $index = $5; + + ## Convert non-decimal numerics to decimal + if ($index =~ /^0x[\da-f]+$/i) { ## Hex + $index = hex $index; + } + elsif ($index =~ /^0\d/) { ## Oct + $index = oct $index; + } + elsif ($index !~ /[^\d_]/) { ## 123_456 notation + $index =~ s/_//g; + } + + ## Force numeric context, but only in numeric context + if ($index =~ /\D/) { + $index = "$neg$index"; + } + else { + $index = "$neg$index"; + $index += 0; + } + + ## Bitmask mode must check index changes + if ($mode == BITMASK) { + ($index & ($index - 1)) + and croak "$index is not a valid single bitmask"; + } + } + else { + croak qq(No index value defined after "="); + } + } + + ## Incase it's a null prefix + $prefix = defined $2 ? $2 : ''; + } + + ## A..Z case magic lists + elsif (/^($Ident)\.\.($Ident)$/o) { + ## Almost never used, so check last + foreach my $name ("$1" .. "$2") { + my $n = $index; + + if ($mode == BITMASK) { + ($index & ($index - 1)) + and croak "$index is not a valid single bitmask"; + $index *= 2; + } + elsif ($mode == ENUM) { + $index++; + } + else { + confess qq(Can't Happen: mode $mode invalid); + } + + *{"$pkg$prefix$name"} = sub () { $n }; + } + } + + else { + croak qq(Can't define "$_" as enum type (name contains invalid characters)); + } + } +} + +1; + +__END__ + + +=head1 NAME + +enum - C style enumerated types and bitmask flags in Perl + +=head1 SYNOPSIS + + use enum qw(Sun Mon Tue Wed Thu Fri Sat); + # Sun == 0, Mon == 1, etc + + use enum qw(Forty=40 FortyOne Five=5 Six Seven); + # Yes, you can change the start indexs at any time as in C + + use enum qw(:Prefix_ One Two Three); + ## Creates Prefix_One, Prefix_Two, Prefix_Three + + use enum qw(:Letters_ A..Z); + ## Creates Letters_A, Letters_B, Letters_C, ... + + use enum qw( + :Months_=0 Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec + :Days_=0 Sun Mon Tue Wed Thu Fri Sat + :Letters_=20 A..Z + ); + ## Prefixes can be changed mid list and can have index changes too + + use enum qw(BITMASK:LOCK_ SH EX NB UN); + ## Creates bitmask constants for LOCK_SH == 1, LOCK_EX == 2, + ## LOCK_NB == 4, and LOCK_UN == 8. + ## NOTE: This example is only valid on FreeBSD-2.2.5 however, so don't + ## actually do this. Import from Fnctl instead. + +=head1 DESCRIPTION + +Defines a set of symbolic constants with ordered numeric values ala B B types. + +Now capable of creating creating ordered bitmask constants as well. See the B +section for details. + +What are they good for? Typical uses would be for giving mnemonic names to indexes of +arrays. Such arrays might be a list of months, days, or a return value index from +a function such as localtime(): + + use enum qw( + :Months_=0 Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec + :Days_=0 Sun Mon Tue Wed Thu Fri Sat + :LC_=0 Sec Min Hour MDay Mon Year WDay YDay Isdst + ); + + if ((localtime)[LC_Mon] == Months_Jan) { + print "It's January!\n"; + } + if ((localtime)[LC_WDay] == Days_Fri) { + print "It's Friday!\n"; + } + +This not only reads easier, but can also be typo-checked at compile time when +run under B. That is, if you misspell B as B, +you'll generate a compile error. + +=head1 BITMASKS, bitwise operations, and bitmask option values + +The B option allows the easy creation of bitmask constants such as +functions like flock() and sysopen() use. These are also very useful for your +own code as they allow you to efficiently store many true/false options within +a single integer. + + use enum qw(BITMASK: MY_ FOO BAR CAT DOG); + + my $foo = 0; + $foo |= MY_FOO; + $foo |= MY_DOG; + + if ($foo & MY_DOG) { + print "foo has the MY_DOG option set\n"; + } + if ($foo & (MY_BAR | MY_DOG)) { + print "foo has either the MY_BAR or MY_DOG option set\n" + } + + $foo ^= MY_DOG; ## Turn MY_DOG option off (set its bit to false) + +When using bitmasks, remember that you must use the bitwise operators, B<|>, B<&>, B<^>, +and B<~>. If you try to do an operation like C<$foo += MY_DOG;> and the B bit +has already been set, you'll end up setting other bits you probably didn't want to set. +You'll find the documentation for these operators in the B manpage. + +You can set a starting index for bitmasks just as you can for normal B values, +but if the given index isn't a power of 2 it won't resolve to a single bit and therefor +will generate a compile error. Because of this, whenever you set the B +directive, the index is automatically set to 1. If you wish to go back to normal B +mode, use the B directive. Similarly to the B directive, the B +directive resets the index to 0. Here's an example: + + use enum qw( + BITMASK:BITS_ FOO BAR CAT DOG + ENUM: FALSE TRUE + ENUM: NO YES + BITMASK: ONE TWO FOUR EIGHT SIX_TEEN + ); + +In this case, B equal 1, 2, 4 and +8 respectively. B equal 0 and 1. B also equal +0 and 1. And B equal, you guessed it, 1, +2, 4, 8, and 16. + +=head1 BUGS + +Enum names can not be the same as method, function, or constant names. This +is probably a Good Thing[tm]. + +No way (that I know of) to cause compile time errors when one of these enum names get +redefined. IMHO, there is absolutely no time when redefining a sub is a Good Thing[tm], +and should be taken out of the language, or at least have a pragma that can cause it +to be a compile time error. + +Enumerated types are package scoped just like constants, not block scoped as some +other pragma modules are. + +It supports A..Z nonsense. Can anyone give me a Real World[tm] reason why anyone would +ever use this feature...? + +=head1 HISTORY + + $Log: enum.pm,v $ + Revision 1.16 1999/05/27 16:00:35 byron + + + Fixed bug that caused bitwise operators to treat enum types as strings + instead of numbers. + + Revision 1.15 1999/05/27 15:51:27 byron + + + Add support for negative values. + + Added stricter hex value checks. + + Revision 1.14 1999/05/13 15:58:18 byron + + + Fixed bug in hex index code that broke on 0xA. + + Revision 1.13 1999/05/13 10:52:30 byron + + + Fixed auto-index bugs in new non-decimal numeric support. + + Revision 1.12 1999/05/13 10:00:45 byron + + + Added support for non-decimal numeric representations ala 0x123, 0644, and + 123_456. + + First version committed to CVS. + + + Revision 1.11 1998/07/18 17:53:05 byron + -Added BITMASK and ENUM directives. + -Revamped documentation. + + Revision 1.10 1998/06/12 20:12:50 byron + -Removed test code + -Released to CPAN + + Revision 1.9 1998/06/12 00:21:00 byron + -Fixed -w warning when a null tag is used + + Revision 1.8 1998/06/11 23:04:53 byron + -Fixed documentation bugs + -Moved A..Z case to last as it's not going to be used + as much as the other cases. + + Revision 1.7 1998/06/10 12:25:04 byron + -Changed interface to match original design by Tom Phoenix + as implemented in an early version of enum.pm by Benjamin Holzman. + -Changed tag syntax to not require the 'PREFIX' string of Tom's + interface. + -Allow multiple prefix tags to be used at any point. + -Allowed index value changes from tags. + + Revision 1.6 1998/06/10 03:37:57 byron + -Fixed superfulous -w warning + + Revision 1.4 1998/06/10 01:07:03 byron + -Changed behaver to closer resemble C enum types + -Changed docs to match new behaver + +=head1 AUTHOR + +Zenin + +aka Byron Brummer . + +Based off of the B module by Tom Phoenix. + +Original implementation of an interface of Tom Phoenix's +design by Benjamin Holzman, for which we borrow the basic +parse algorithm layout. + +=head1 COPYRIGHT + +Copyright 1998 (c) Byron Brummer. +Copyright 1998 (c) OMIX, Inc. + +Permission to use, modify, and redistribute this module granted under +the same terms as B. + +=head1 SEE ALSO + +constant(3), perl(1). + +=cut diff -urN /non-existant-dir/doc/default.css tiarra-20080510/doc/default.css --- /non-existant-dir/doc/default.css 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/doc/default.css 2008-05-11 00:25:26.000000000 +0900 @@ -0,0 +1,116 @@ +/* $Id: default.css,v 1.1 2003/08/04 09:29:21 admin Exp $ */ +@import url(http://www.clovery.jp/common/style/blue/base.css); + +/* toc-group */ +.toc-group +{ + font-size: x-large; + } + +.toc-group .group-description +{ + font-size: large; + } + +.toc-group .toc-individual +{ + font-size: large; + } + +.toc-group .toc-individual .module-description +{ + font-size: medium; + } + + +/* doc-element */ +div.module +{ + border-style: dotted; + border-width: 2px; + border-color: #66b3ff; + padding: 10px; + margin-left: 20px; + margin-bottom: 10px; + margin-right: 10px; + background: #d4e9ff; + } + +div.module h2 +{ + display: inline; + } + +div.module .description +{ + font-weight: bold; + margin-left: 2em; + } + +div.module .content +{ + padding-left: 1em; +/* + padding-top: 1em; + border-top-width: 1px; + border-top-style: dashed; + border-top-color: #66b3ff; + border-left-width: 1px; + border-left-style: dashed; + border-left-color: #66b3ff; + */ + } + +div.module .comment +{ + border-left-width: 1px; + border-left-style: solid; + border-left-color: #66b3ff; + border-bottom-width: 1px; + border-bottom-style: dashed; + border-bottom-color: #66b3ff; + padding-left: 0.3em; + } +div.module .comment:first-line +{ + font-weight: bolder; +} + +div.element.block +{ + } + +div.element .key +{ + font-weight: bolder; + } + +div.element .value +{ + margin-left: 0.5em; + } + +div.element.block +{ + margin-top: 0.7em; + border-width: 1px; + border-style: solid; + border-color: #66b3ff; + } + +div.element.block .block.key +{ + position: relative; + padding-left: 0.5em; + padding-right: 0.5em; + top: -0.6em; + left: 0.3em; + color: black; + background: #d4e9ff; + } + +div.block.content +{ + margin: 0.5em; + margin-top: 0em; + } diff -urN /non-existant-dir/doc/module/Auto.html tiarra-20080510/doc/module/Auto.html --- /non-existant-dir/doc/module/Auto.html 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/doc/module/Auto.html 2008-05-11 00:25:28.000000000 +0900 @@ -0,0 +1,842 @@ + + + + + + + Auto 関係のモジュール - Tiarra Documentation + + + +
+

Auto 関係のモジュール

+
+ +
+ +
+ +
+

Auto::Alias

+ ユーザエイリアス情報の管理を行ないます。
+
+

+エイリアスは基本的にname,userの二つのフィールドから成っており、
+それぞれユーザー名、ユーザーマスクを表します。
+

+

+ エイリアス定義ファイルのパスと、そのエンコーディング。
+ このファイルは次のようなフォーマットである。
+ 1. それぞれの行は「<キー>: <値>」の形式である。
+ 2. 空の行で、各ユーザーを区切る。
+ 3. <値>はカンマで区切られて複数の値とされる。
+
+ エイリアス定義ファイルの例:
+
+ name: sample
+ user: *!*sample@*.sample.net
+
+ name: sample2,[sample2]
+ user: *!sample2@*.sample.net,*!sample2@*.sample2.net
+
+

+
alias:alias.txt
+
alias-encoding:euc
+

+この発言をした人のエイリアスが登録されていれば、それをprivで送る。
+

+
confirm:エイリアス確認
+

+「<addで指定したキーワード> user *!*user@*.user.net」のようにして情報を追加。
+発言をした人のエイリアスが未登録だった場合は、userのみ受け付けて新規追加とする。
+

+
add:エイリアス追加
+

+「<removeで指定したキーワード> name ユーザー」のようにして情報を削除。
+userを全て削除されたエイリアスは他の情報(name等)も含めて消滅する。
+

+
remove:エイリアス削除
+

+メッセージが追加されたときの反応を指定します。
+ランダムなメッセージを発言する際のフォーマットを指定します。
+エイリアス置換が有効です。#(nick.now)、#(channel)は
+それぞれ相手のnick、チャンネル名に置換されます。
+#(key)、#(value)は、追加されたキーと値に置換されます。
+

+
added-format:#(name|nick.now): エイリアス #(key) に #(value) を追加しました。
+
add-failed-format:#(name|nick.now): エイリアス #(key) の追加に失敗しました。
+

+メッセージが削除されたときの反応を指定します。
+added-formatで指定できるものと同じです。
+

+
removed-format:#(name|nick.now): エイリアス #(key) から #(value) を削除しました。
+
remove-failed-format:#(name|nick.now): エイリアス #(key) からの削除に失敗しました。
+

+エイリアスの追加や削除が許されている人。省略された場合は「*!*@*」と見做される。
+

+
modifier:*!*@*
+ +
+
+ + +
+ + +
+

Auto::Answer

+ 特定の発言に反応して対応する発言をする。
+
+

+Auto::Aliasを有効にしていれば、エイリアス置換を行ないます。
+

+

+ 反応する発言と、それに対する返事を定義します。
+ エイリアス置換が有効です。#(nick.now)と$(channel)はそれぞれ
+ 相手の現在のnickとチャンネル名に置換されます。
+
+ コマンド: reply
+ 書式: <反応する発言のマスク> <それに対する返事>
+ 例:
+

+
reply:こんにちは* こんにちは、#(name|nick.now)さん。
+

+ この例では誰かが「こんにちは」で始まる発言をすると、
+ 発言した人のエイリアスを参照して「こんにちは、○○さん。」のように発言します。
+
+ コマンド: channel-reply
+ 書式: <反応するチャンネルのマスク> <反応する発言のマスク> <それに対する返事>
+ 例:
+

+
channel-reply:#あいさつ@ircnet こんにちは* こんにちは、#(name|nick.now)さん。
+

+ この例では#あいさつ@ircnetで誰かが「こんにちは」で始まる発言をすると、
+ 発言した人のエイリアスを参照して「こんにちは、○○さん。」のように発言します。
+
+ コマンド: answer-to-myself
+ 書式: <真偽値>
+ 例:
+

+
answer-to-myself:on
+

+自分の発言にも反応するようになります。
+デフォルトは off です。
+

+ +
+
+ + +
+ + +
+

Auto::Calc

+ Perlの式を計算させるモジュール。
+
+

+反応する発言を指定します。
+

+
request:計算
+

+使用を許可する人&チャンネルのマスク。
+例はTiarraモード時。 [default: なし]
+

+
mask:* +*!*@*
+

+[plum-mode] mask: +*!*@*
+

+

+結果が未定義だったときに置き換えられる文字列。省略されると undef 。
+

+
undef:(未定義)
+

+正常に計算できたときのフォーマット
+method: 計算式, result: 結果, error: エラー, signal: シグナル
+

+
reply-format:#(method): #(result)
+

+エラーが起きたときのフォーマット
+method: 計算式, result: 結果, error: エラー, signal: シグナル
+

+
error-format:#(method): エラーです。(#(error))
+

+シグナルが発生したときのフォーマット
+

+
signal-format:#(method): シグナルです。(#(signal))
+

+signal-$SIGNALNAME-format 形式。
+$SIGNALNAME には現状 alarm/sigfpe があります。
+該当がなければ signal-format にフォールバックします。
+

+

+いくつかの例を挙げます。
+

+
signal-alarm-format:#(method): 時間切れです。
+
signal-sigfpe-format:#(method): 浮動小数点計算例外です。
+

+タイムアウトする秒数を指定します。 alarm に渡されます。
+再帰を止めるのに使えますが、どうもメモリリークしていそうな雰囲気です。
+

+
timeout:1
+

+サブルーチン定義を許可するかどうかを指定する。
+再帰定義が可能なので、許可する場合はこのモジュール専用の
+Tiarra を動かすことをお勧めします。
+

+
permit-sub:0
+

+初期化する発言を指定します。
+このモジュールでは現状変数や関数定義などを行えます。
+このコマンドが発行されるとそれらをクリアします。
+

+
init:計算初期化
+

+初期化を許可する人&チャンネルのマスク。
+例はTiarraモード時。 [default: なし]
+

+
init-mask:* +*!*@*
+

+[plum-mode] mask: +*!*@*
+

+

+再初期化したときの発言を指定します。
+

+
init-format:初期化しました。
+ +
+
+ + +
+ + +
+

Auto::ChannelWithoutOper

+ チャンネルオペレータ権限がなくなってしまったときに発言する。
+
+

++で始まらない特定のチャンネルで、+aモードでも+rモードでもないのに
+誰もチャンネルオペレータ権限を持っていない状態になっている時、
+そこに誰かがJOINする度に特定のメッセージを発言するモジュールです。
+

+

+書式: <チャンネル名> <メッセージ>
+

+
channel:#IRC談話室@ircnet なると消失しました。
+ +
+
+ + +
+ + +
+

Auto::FetchTitle

+ 発言に含まれるURLからタイトルを取得.
+
+

+リクエストタイムアウトまでの時間(秒).
+

+
timeout:3
+

+ 有効にするチャンネルとオプションとURLの設定.
+ 書式: mask: <channel> [<&conf>...] <url>
+
+ mask: #test@ircnet &test http://*
+ mask: * http://*
+

+
mask:* http://*
+

+ &test と設定すると conf-test ブロックの中身が使われる.
+conf-test {
+  auth-test1 {
+    url: http://example.com/*
+    url: http://example.org/*
+    user: test
+    #pass: test
+    pass: {BASE64}dGVzdAo=
+  }
+  filter-xx {
+    url: http://example.com/*/xx/*
+    type: xx
+  }
+}
+

+

+お返事の前や後ろにつける字句.
+

+
reply-prefix:"(FetchTitle) "
+
reply-suffix:" [AR]"
+

+ デバッグフラグ.
+debug: 0
+debug-mask: #debug-chan your_nick!~you@example.com
+debug-dumpfile: fetchtitle.log
+

+

+NOTE:
+ 利用するにはcodereposから
+ module/Tools/HTTPClient.pm rev.8220
+ main/Tiarra/Socket/Buffered.pm rev.8219
+ 以降が必要です.
+

+ +
+
+ + +
+ + +
+

Auto::Im

+ 名前が呼ばれると、その発言をim.kayac.comに送信する
+
+

+反応する人のマスクを指定します。
+省略すると全員に反応します。
+

+
mask:* *!*@*
+

+反応するキーワードを正規表現で指定します。
+複数指定したい時は複数行指定してください。
+

+
regex-keyword:(?i:fugahoge)
+

+反応するキーワードを指定します。
+複数指定したい時は,(コンマ)で区切るか、複数行指定してください。
+

+
keyword:hoge
+

+im.kayac.com に送るメッセージのフォーマットを指定します。
+デフォルト値: [tiarra][#(channel):#(nick.now)] #(text)
+

+
format:[tiarra][#(channel):#(nick.now)] #(text)
+

+im.kayac.comで登録したユーザ名を入力します。
+im.kayac.comについては http://im.kayac.com/#docs を参考にしてください。
+

+
user:username
+

+im.kayac.comで秘密鍵認証を選択した場合は設定してください。
+省略すると認証なしになります。
+

+
secret:some secret
+

+im.kayac.comでパスワード認証を選択した場合は設定してください。
+省略すると認証なしになります。
+secret と両方指定した場合は secret が優先されています。
+

+
password:some password
+ +
+
+ + +
+ + +
+

Auto::Joined

+ 特定のチャンネルに誰かがJOINする度に特定のメッセージを発言する。
+
+

+Auto::Aliasを有効にしていれば、エイリアス置換を行ないます。
+

+

+ 発言を行なうチャンネルと、その内容を定義します。
+ #(nick.now)と$(channel)は、それぞれ相手の現在のnickとチャンネル名に置換されます。
+
+ 書式: <チャンネル名> <発言内容>
+

+
channel:#チャンネル@ircnet 「#ちゃんねる」に移転しました。
+ +
+
+ + +
+ + +
+

Auto::MesMail

+ 伝言をメールとして送信する。
+
+

+メールアドレスはエイリアスの mail を参照します。
+

+

+Fromアドレス。[default: OSのユーザ名]
+

+
from:example1@example.jp
+

+送信用のキーワード [default: mesmail_send]
+

+
send:速達伝言
+

+使用を許可する人&チャンネルのマスク。
+例はTiarraモード時。 [default: なし]
+

+
mask:* +*!*@*
+

+[plum-mode] mask: +*!*@*
+

+

+maskで拒否されたときのメッセージ [default: なし]
+

+
deny:伝言したくない。
+

+一度に送れる宛先の量 [default: 無制限]
+

+
max-send-address:5
+

+宛先を探すエイリアスエントリ [default: なし]
+

+
alias-key:name
+
alias-key:nick
+

+宛先の人を判別出来なかったときのメッセージ [default: なし]
+

+
unknown:#(who)さんと言うのは誰ですか?
+

+メールの日付形式
+

+
date:%H:%M:%S
+

+エイリアスは見付かったけれどメールアドレスが登録されていなかったときのメッセージ。 [default: なし]
+

+
none-address:#(who)さんはアドレスを登録していません。
+

+SMTPのホスト [default: localhost]
+

+
smtphost:localhost
+

+SMTPのポート [default: smtp(25)]
+

+
smtpport:25
+

+SMTPで自ホストのFQDN [default: localhost]
+

+
smtpfqdn:localhost
+

+SMTPのユーザ。指定されれば SMTP Auth を行う [default: なし]
+

+
smtpuser:example1
+

+SMTPのパスワード [default: 空パスワード('')]
+

+
smtppass:test-password
+

+送信するメールの既定件名(エイリアス使用不可) [default: Message from IRC]
+

+
subject:Message from IRC
+

+送信するメールの本文 [default: #(date) << #(from.name|from.nick|from.nick.now) >> #(message)]
+

+
format:#(date)に#(from.name|from.nick|from.nick.now)さんから#(message)という伝言です。
+

+送信したときのメッセージ。 [default: なし]
+

+
accept:#(who)さんに#(message)と伝言しておきました。
+

+---- POP before SMTP の指定 ----
+POP before SMTPを使う。 [default: no]
+

+
use-pop3:yes
+

+POP before SMTPのタイムアウト時間(分)。分からない場合は指定しなくて良い。 [default: 0]
+

+
pop3-expire:4
+

+POPのホスト。 [default: localhost]
+

+
pop3host:localhost
+

+POPのポート。 [default: pop(110)]
+

+
pop3port:110
+

+POPのユーザ [default: OSのユーザ名]
+

+
pop3user:example1
+

+POPのパスワード [default: 空パスワード('')]
+

+
pop3pass:test-password
+

+---- エラーメッセージの設定 ----
+

+

+一般エラー。
+error-[state] と言う形式で詳細エラーメッセージを指定できる。
+[state]は、
+   * mailfrom(メールの送信者を指定しようとしてエラー)
+   * rcptto(メールの送信先を指定しようとしてエラー)
+   * norcptto(メールの送信先が全部無くなった)
+   * data(メールの中身を送信しようとしてエラー)
+   * finish(メールの中身を送信したらエラー)
+がある。特に欲しくなければerror-[state]は指定しなくても構わない。
+メッセージを出したくないなら中身の無いエントリを指定すれば良い。
+error-[state]が指定されてない場合は代わりに error を使う。 [default: 未定義]
+

+
error-rcptto:
+
error-norcptto:#(who)さんには送れませんでした。送信できるメールアドレスがありません。
+
error-data:メールが送信できません。DATAコマンドに失敗しました。#(line;サーバ応答:%s|;)
+
error:メール送信エラーです。#(line;サーバ応答:%s|;)#(state; on %s|;)
+

+致命的なエラー。メールに個別なエラーではないので送信者(のprefix)毎に1メッセージ送られる。
+fatalerror-[state]
+[state]:
+   * first(接続エラー)
+   * helo(SMTPセッションを開始出来ない)
+がある。特に欲しくなければfatalerror-[state]は指定しなくても構わない。
+メッセージを出したくないなら中身の無いエントリを指定すれば良い。
+fatalerror-[state]が指定されてない場合は代わりに fatalerror を使う。 [default: 未定義]
+

+
fatalerror-first:SMTPサーバに接続できません。
+
fatalerror:SMTPセッションで致命的なエラーがありました。#(line; サーバ応答:%s|;)#(state; on %s|;)
+ +
+
+ + +
+ + +
+

Auto::Oper

+ 特定の文字列を発言した人を+oする。
+
+

+Auto::Aliasを有効にしていれば、エイリアス置換を行ないます。
+

+

++oを要求する文字列(マスク)を指定します。
+

+
request:なると寄越せ
+

+チャンネルオペレータ権限を要求した人と要求されたチャンネルが
+ここで指定したマスクに一致しなかった場合は
+denyで指定した文字列を発言し、+oをやめます。
+省略された場合は誰にも+oしません。
+書式は「チャンネル 発言者」です。
+マッチングのアルゴリズムは次の通りです。
+1. チャンネル名にマッチするmask定義を全て集める
+2. 集まった定義の発言者マスクを、定義された順にカンマで結合する
+3. そのようにして生成されたマスクで発言者のマッチングを行ない、結果を+o可能性とする。
+例1:
+mask: *@2ch* *!*@*
+mask: #*@ircnet* *!*@*.hoge.jp
+この例ではネットワーク 2ch の全てのチャンネルで誰にでも +o し、
+ネットワーク ircnet の # で始まる全てのチャンネルでホスト名 *.hoge.jp の人に+oします。
+#*@ircnetだと「#hoge@ircnet:*.jp」などにマッチしなくなります。
+例2:
+mask: #hoge@ircnet -*!*@*,+*!*@*.hoge.jp
+mask: * +*!*@*
+基本的に全てのチャンネルで誰にでも +o するが、例外的に#hoge@ircnetでは
+ホスト名 *.hoge.jp の人にしか +o しない。
+この順序を上下逆にすると、全てのチャンネルで全ての人を +o する事になります。
+何故なら最初の* +*!*@*が全ての人にマッチするからです。
+

+
mask:* *!*@*
+

++oを要求した人を実際に+oする時、ここで指定した発言をしてから+oします。
+#(name|nick)のようなエイリアス置換を行います。
+エイリアス以外でも、#(nick.now)を相手のnickに、#(channel)を
+そのチャンネル名にそれぞれ置換します。
+

+
message:了解
+

++oを要求されたが+oすべき相手ではなかった場合の発言。
+省略されたら何も喋りません。
+

+
deny:断わる
+

++oを要求されたが相手は既にチャンネルオペレータ権限を持っていた場合の発言。
+省略されたらdenyに設定されたものを使います。
+

+
oper:既に@を持っている
+

++oを要求されたが自分はチャンネルオペレータ権限を持っていなかった場合の発言。
+省略されたらdenyに設定されたものを使います。
+

+
not-oper:@が無い
+

+チャンネルに対してでなく自分に対して+oの要求を行なった場合の発言。
+省略されたらdenyに設定されたものを使います。
+

+
private:チャンネルで要求せよ
+

+チャンネルの外から+oを要求された場合の発言。+nチャンネルでは起こりません。
+省略されたらdenyに設定されたものを使います。
+

+
out:チャンネルに入っていない
+ +
+
+ + +
+ + +
+

Auto::Random

+ 特定の発言に反応してランダムな発言をします。
+
+

+Auto::Aliasを有効にしていれば、エイリアス置換を行ないます。
+

+

+使用するブロックの定義。
+

+
blocks:wimikuji
+
wimikuji +
+

+ランダムに発言するメッセージの書かれたファイルと、その文字コードを指定します。
+ファイルの中では一行に一つのメッセージを書いて下さい。
+

+
file:random.txt
+
file-encoding:euc
+

+反応する発言を表すマスクを指定します。
+

+
request:ゐみくじ
+

+メッセージの登録数を返答するキーワードを指定します。
+

+
count-query:ゐみくじ登録数
+

+メッセージの登録数を返答するときの反応を指定します。
+formatで指定できるものと同じです。#(count)は登録数になります。
+

+
count-format:ゐみくじは#(count)件登録されています。
+

+ランダムなメッセージを発言する際のフォーマットを指定します。
+エイリアス置換が有効です。#(message)、#(nick.now)、#(channel)は
+それぞれメッセージ内容、相手のnick、チャンネル名に置換されます。
+何も登録されていないときのために、#(message|;無登録)のように指定すると良いでしょう。
+

+
format:#(name|nick.now)の運命は#(message)
+

+反応する人のマスク。
+

+
mask:* *!*@*
+

+plum: mask: *!*@*
+

+

+メッセージが追加されたときの反応を指定します。
+formatで指定できるものと同じです。#(message)は追加されたメッセージになります。
+

+
added-format:#(name|nick.now): ゐみくじ #(message) を追加しました。
+

+メッセージが削除されたときの反応を指定します。
+formatで指定できるものと同じです。#(message)は削除されたメッセージになります。
+

+
removed-format:#(name|nick.now): ゐみくじ #(message) を削除しました。
+

+発言に反応する確率を指定します。百分率です。省略された場合は100と見做されます。
+

+
rate:100
+

+メッセージを追加するキーワードを指定します。
+ここで指定したキーワードを発言すると、新しいメッセージを追加します。
+実際の追加方法は「<addで指定したキーワード> <追加するメッセージ>」です。
+

+
add:ゐみくじ追加
+

+メッセージを削除するキーワードを指定します。
+実際の削除方法は「<removeで指定したキーワード> <削除するキーワード>」です。
+

+
remove:ゐみくじ削除
+

+addとremoveを許可する人。省略された場合は誰も変更できません。
+

+
modifier:* *!*@*
+

+plum: modifier: *!*@*
+

+
+ +
+
+ + +
+ + +
+

Auto::Reply

+ 特定の発言に反応して発言をします。
+
+

+Auto::Aliasを有効にしていれば、エイリアス置換を行ないます。
+

+

+使用するブロックの定義。
+

+
blocks:std
+
std +
+

+データファイルと文字コードを指定します。
+ファイルの中では一行に一つの"反応:メッセージ"を書いて下さい。
+

+
file:reply.txt
+
file-encoding:euc
+

+反応チェックを行うキーワードを指定します。
+実際の指定方法は、「<requestで指定したキーワード> <チェックしたい発言>」です。
+

+
request:反応チェック
+

+request に反応するときのフォーマットを指定します。
+#(key) がキーワード、 #(message) が発言に置換されます。
+

+
reply-format:「#(key)」という発言に「#(message)」と反応します。
+

+request に反応する最大個数を指定します。
+あまり大きな値を指定すると、アタックが可能になったり、ログが流れて邪魔なので注意してください。
+

+
max-reply:5
+

+メッセージの登録数を返答するキーワードを指定します。
+

+
count-query:反応登録数
+

+メッセージの登録数を返答するときの反応を指定します。
+formatで指定できるものと同じです。#(count)は登録数になります。
+

+
count-format:反応は#(count)件登録されています。
+

+反応する人のマスク。
+

+
mask:* *!*@*
+

+plum: mask: *!*@*
+

+

+反応が追加されたときの反応を指定します。
+formatで指定できるものと同じです。#(message)は追加されたメッセージになります。
+

+
added-format:#(name|nick.now): #(key) に対する反応 #(message) を追加しました。
+

+メッセージが削除されたときの反応を指定します。
+formatで指定できるものと同じです。#(message)は削除されたメッセージになります。
+

+
removed-format:#(name|nick.now): #(key) #(message;に対する反応 %s|;) を #(count) 件削除しました。
+

+発言に反応する確率を指定します。百分率です。省略された場合は100と見做されます。
+

+
rate:100
+

+メッセージを追加するキーワードを指定します。
+ここで指定したキーワードを発言すると、新しいメッセージを追加します。
+実際の追加方法は「<addで指定したキーワード> <追加するメッセージ>」です。
+

+
add:反応追加
+

+メッセージを削除するキーワードを指定します。
+実際の削除方法は「<removeで指定したキーワード> <削除するキーワード>」です。
+

+
remove:反応削除
+

+addとremoveを許可する人。省略された場合は「* *!*@*」と見做します。
+

+
modifier:* *!*@*
+

+正規表現拡張を許可するか。省略された場合は禁止します。
+

+
use-re:1
+
+ +
+
+ + +
+ + +
+

Auto::Response

+ データファイルの指定にしたがって反応する。
+
+

+大量の反応データを定義するのに向いています。
+

+

+データファイルのフォーマット
+| pattern: re:^(こん(に)?ちは)
+| rate: 90
+| mask: * *!*@*
+| #plum: mask: *!*@*
+| response: こんにちは。
+| response: いらっしゃいませ。
+|
+| pattern: おやすみ
+| rate: 20
+| response: おやすみなさい。
+patternは一行しか書けません。(手抜き
+maskもrateも省略できます。省略した場合はmaskは全員、rateは100となります。
+responseは複数書いておけばランダムに選択されます。
+

+

+データファイル
+

+
file:response.txt
+

+文字コード
+

+
charset:euc
+

+使用を許可する人&チャンネルのマスク。
+

+
mask:* *!*@*
+

+plum: mask: +*!*@*
+

+ +
+
+ + + +
+ +
+ +
+ + diff -urN /non-existant-dir/doc/module/CTCP.html tiarra-20080510/doc/module/CTCP.html --- /non-existant-dir/doc/module/CTCP.html 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/doc/module/CTCP.html 2008-05-11 00:25:28.000000000 +0900 @@ -0,0 +1,218 @@ + + + + + + + CTCP 関係のモジュール - Tiarra Documentation + + + +
+

CTCP 関係のモジュール

+
+ +
+ +
+ +
+

CTCP::ClientInfo

+ CTCP CLIENTINFOに応答する。
+
+

+CTCP::Versionのintervalと同じ。
+

+
interval:3
+ +
+
+ + +
+ + +
+

CTCP::DCC::RewriteAddress

+ クライアントが送信した CTCP DCC のアドレスを変換する。
+
+

+ CTCP DCC に指定されているアドレスを、 tiarra で取得したものに
+ 書き換えます。(EXPERIMENTAL)
+
+ IPv4 のみサポートしています。
+
+ このモジュールは一旦 CTCP DCC メッセージを破棄するので、
+ 別のクライアントには送信されません。
+

+

+変換する DCC タイプ。 [デフォルト値: CHAT SEND]
+

+
type:CHAT SEND
+

+変換用アドレスの取得方法を選択する。デフォルト値はありません。
+以下の取得方法(server-socket client-socket dns http)から
+必要なもの(複数可)を指定してください。
+

+
resolver:client-socket server-socket dns http
+

+取得方法と設定
+なにも設定がないときはブロック自体を省略することもできます。
+

+
server-socket +
+

+サーバソケットのローカルアドレスを取ります。
+client <-> tiarra[this address] <-> server
+

+
+
client-socket +
+

+クライアントソケットのリモートアドレスを取ります。
+client [this address]<-> tiarra <-> server
+

+
+
dns +
+

+DNS を引いて決定します。IPアドレスの指定も可能です。
+

+
host:example.com
+
+
http +
+

+現状では単純な GET しかサポートしていません。
+

+

+アクセス先 URL
+

+
url:http://checkip.dyndns.org/
+

+IP アドレス取得用 regex
+

+
regex:Current IP Address: (\d+\.\d+\.\d+\.\d+)
+
+

+ リゾルバの選び方
+
+  * tiarra を動作させているサーバとインターネットの間にルータ等があり、
+    グローバルアドレスがない場合
+      *-socket は役に立ちません。 http を利用してください。
+      適当な DDNS を持っていればdns も良いでしょう。
+
+  * tiarra がレンタルサーバなどLAN上にないサーバで動作している場合
+      server-socket, http は役に立ちません。
+      client-socket がお勧めです。
+
+  * tiarra がLAN上にあり、グローバルアドレスのついているホストで
+    動作している場合
+      client-socket は役に立ちません。
+      server-socket がお勧めです。
+

+ +
+
+ + +
+ + +
+

CTCP::Ping

+ CTCP PINGに応答する。
+
+

+CTCP::Versionのintervalと同じ。
+

+
interval:3
+ +
+
+ + +
+ + +
+

CTCP::Time

+ CTCP TIMEに応答する。
+
+

+CTCP::Versionのintervalと同じ。
+

+
interval:3
+ +
+
+ + +
+ + +
+

CTCP::UserInfo

+ CTCP USERINFOに応答する。
+
+

+CTCP::Versionのintervalと同じ。
+

+
interval:3
+

+USERINFOとして返すメッセージ。
+

+
message:テスト
+ +
+
+ + +
+ + +
+

CTCP::Version

+ CTCP VERSIONに応答する。
+
+

+ 連続したCTCPリクエストに対する応答の間隔。単位は秒。
+ 例えば3秒に設定した場合、一度応答してから3秒間は
+ CTCPに一切応答しなくなる。デフォルトは3。
+
+ なお、CTCP受信時刻の記録は、全てのCTCPモジュールで共有される。
+ 例えばCTCP VERSIONを送った直後にCTCP CLIENTINFOを送ったとしても、
+ CTCP::ClientInfoのintervalで設定された時間を過ぎていなければ
+ 後者は応答しない。
+

+
interval:3
+ +
+
+ + + +
+ +
+ +
+ + diff -urN /non-existant-dir/doc/module/Channel.html tiarra-20080510/doc/module/Channel.html --- /non-existant-dir/doc/module/Channel.html 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/doc/module/Channel.html 2008-05-11 00:25:28.000000000 +0900 @@ -0,0 +1,261 @@ + + + + + + + Channel 関係のモジュール - Tiarra Documentation + + + +
+

Channel 関係のモジュール

+
+ +
+ +
+ +
+

Channel::Freeze

+ 特定のチャンネルの発言を、一時的に受信するのをやめる。
+
+

+ログを取っているなら、ログには記録される。
+

+

+チャンネルの凍結に用いるコマンド名。
+省略時は freeze であり、/freeze #channel@network のように使う。
+チャンネル名を省略すると、現在フリーズされているチャンネルのリストを表示する。
+

+
freeze-command:freeze
+

+凍結解除に用いるコマンド名。
+省略時は defrost であり、/defrost #channel@network のように使う。
+

+
defrost-command:defrost
+

+凍結しているチャンネルが存在する時、一定時間毎にその旨を報告する事も可能。
+この機能は凍結した事を忘れないようにする為にある。
+単位は分、デフォルトはゼロ(報告しない)。
+

+
reminder-interval:30
+ +
+
+ + +
+ + +
+

Channel::Ignore

+ 指定されたチャンネルの存在を、様々なメッセージから消去する。
+
+

+対象となったチャンネルのJOIN、PART、INVITE、QUIT、NICK、NAMES、NJOINは消去される。
+

+

+注意点
+- この機能はまだ実装途中です。いろいろな不具合があるかもしれません。むしろきっとあります。
+- サーバがわとの通信に割り込みますのでログにもとられません。
+- この機能を使っている tiarra より上流に multi-server-mode な tiarra を置かないでください。
+

+

+チャンネルの定義。
+また、privの場合は「priv@ネットワーク名」という文字列をチャンネル名の代わりとしてマッチングを行なう。
+書式: mask: <チャンネルのマスク>
+

+
mask:#example@example
+ +
+
+ + +
+ + +
+

Channel::Join::Connect

+ サーバーに初めて接続した時、指定したチャンネルに入るモジュール。
+
+

+ 書式: <チャンネル1>[,<チャンネル2>,...] [<チャンネル1のキー>,...]
+     コンマの直後のスペースは無視されます。
+
+ 例:
+   「#aaaaa@ircnet」に「aaaaa」というキーで入る。
+

+
channel:#aaaaa@ircnet aaaaa
+

+
+   「#aaaaa@ircnet」、「#bbbbb@ircnet:*.jp」、「#ccccc@ircnet」、「#ddddd@ircnet」の4つのチャンネルに入る。
+

+
channel:#aaaaa@ircnet,#bbbbb@ircnet:*.jp, #ccccc@ircnet
+
channel:#ddddd@ircnet
+ +
+
+ + +
+ + +
+

Channel::Join::Invite

+ 招待されたらそのチャンネルに入る。
+
+

+許可するユーザ/チャンネルのマスク。
+

+
mask:* *!*@*
+

+plum: *!*@*
+

+

+招待されたチャンネルに流すメッセージのフォーマット。
+

+
message:こんばんわ〜。
+ +
+
+ + +
+ + +
+

Channel::Join::Kicked

+ 特定のチャンネルからkickされた時に、自動で入りなおす。
+
+

+対象となるチャンネル名のマスク
+

+
channel:*
+ +
+
+ + +
+ + +
+

Channel::Mode::Get

+ チャンネルにJOINした時、そのチャンネルのモードを取得します。
+
+

+Channel::Mode::Set等が正しく動くためには
+チャンネルのモードをTiarraが把握しておく必要があります。
+自動的にモードを取得するクライアントであれば必要ありませんが、
+そうでなければこのモジュールを使うべきです。
+

+

+設定項目は無し。
+

+ +
+
+ + +
+ + +
+

Channel::Mode::Oper::Grant

+ 特定のチャンネルに特定の人間がjoinした時に、自分がチャンネルオペレータ権限を持っていれば+oする。
+
+

+splitからの復帰などで+o対象の人が一度に大量に入って来ても+oは少しずつ実行します。
+Excess Floodにはならない筈ですが、本格的な防衛BOTに使える程の物ではありません。
+

+

+対象の人間がjoinしてから実際に+oするまで何秒待つか。
+省略されたら待ちません。
+5-10 のように指定されると、その値の中でランダムに待ちます。
+

+
wait:2-5
+

+チャンネルと人間のマスクを定義。Auto::Operと同様。
+

+
mask:* example!~example@*.example.ne.jp
+ +
+
+ + +
+ + +
+

Channel::Mode::Set

+ チャンネルを作成した時に自動的にモードを設定するモジュール。
+
+

+書式は<チャンネル名にマッチするマスク> <設定するモード>[,<設定するモード>,...]です。
+#IRC談話室@ircnetなら+t+nを、それ以外なら+nを設定する例。
+

+
channel:#IRC談話室@ircnet +t
+
channel:* +n
+

+LimeChat 標準設定を模倣する設定例。
+

+
channel:* +sn
+ +
+
+ + +
+ + +
+

Channel::Rejoin

+ チャンネルオペレータ権限を無くしたとき、一人ならjoinし直す。
+
+

++チャンネルや+aされているチャンネル以外でチャンネルオペレータ権限を持たずに
+一人きりになった時、そのチャンネルの@を復活させるために自動的にjoinし直すモジュール。
+トピック、モード、banリスト等のあらゆるチャンネル属性をも保存します。
+

+

++b,+I,+eリストの復旧を行なうかどうか。
+あまりに長いリストを取得するとMax Send-Q Exceedで落とされるかも知れません。
+

+
save-lists:1
+ +
+
+ + + +
+ +
+ +
+ + diff -urN /non-existant-dir/doc/module/Client.html tiarra-20080510/doc/module/Client.html --- /non-existant-dir/doc/module/Client.html 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/doc/module/Client.html 2008-05-11 00:25:28.000000000 +0900 @@ -0,0 +1,263 @@ + + + + + + + Client 関係のモジュール - Tiarra Documentation + + + +
+

Client 関係のモジュール

+
+ +
+ +
+ +
+

Client::Cache

+ データをキャッシュしてサーバに問い合わせないようにする
+
+

+キャッシュを使用しても、使われるのは接続後最初の一度だけです。
+二度目からは通常通りにサーバに問い合わせます。
+また、クライアントオプションの no-cache を指定すれば動きません。
+

+

+mode キャッシュを使用するか
+

+
use-mode-cache:1
+

+who キャッシュを使用するか
+

+
use-who-cache:1
+ +
+
+ + +
+ + +
+

Client::Conservative

+ サーバが送信するような IRC メッセージを作成するようにする
+
+

+サーバが実際に送信しているようなメッセージにあわせるようにします。
+多くのクライアントの設計ミスを回避でき(ると思われ)ます。
+

+ +
+
+ + +
+ + +
+

Client::Cotton

+ Cotton の行うおかしな動作のいくつかを無視する
+
+

+該当クライアントのオプション client-type に cotton や unknown と指定するか、
+Client::GetVersion を利用してクライアントのバージョンを取得するように
+してください。
+

+

+part shield (rejoin 時に自動で行われる part の無視)を使用するか
+

+
use-part-shield:1
+ +
+
+ + +
+ + +
+

Client::Eval

+ クライアントから Perl 式を実行できるようにする。
+
+

+eval を実行するコマンド名。省略されるとコマンドを追加しません。
+この時コマンドはTiarraが握り潰すので、IRCプロトコル上で定義された
+コマンド名を設定すべきではありません。
+

+
command:eval
+

+hex eval を実行するコマンド名。省略されるとコマンドを追加しません。
+この時コマンドはTiarraが握り潰すので、IRCプロトコル上で定義された
+コマンド名を設定すべきではありません。
+

+
hex-command:hexeval
+

+表示する最大行数を指定します。省略するとすべての行を表示します。
+

+
max-line:30
+ +
+
+ + +
+ + +
+

Client::GetVersion

+ クライアントに CTCP Version を発行してバージョン情報を得る
+
+

+オプションはいまのところありません。
+(開発者向け情報: 取得した情報は remark の client-version に設定され、
+                 Client::Guess から使用されます。)
+

+ +
+
+ + +
+ + +
+

Client::PatchworkMessage

+ IRC メッセージにちょっと変更を加えて、クライアントのバグを抑制する
+
+

+特に注意書きがない場合はデフォルトで有効です。
+また、 Client::GetVersion も同時に入れておくと便利です。
+とりあえず obsolete です。このモジュールで実装されていた機能は
+Client::Conservative によって実現できます。
+Client::Conservative で実装してはいけないようなものがあった場合のみ
+このモジュールで対処します。
+

+

+WoolChat:
+ 対応しているメッセージ:
+  NICK(コロンが必須)
+ 説明:
+  NICK は接続直後にも発行されるため、 Client::GetVersion での判別まで
+  待てません。該当クライアントのオプション client-type に woolchat と
+  指定してください。実名欄に $client-type=woolchat$ と書けば OK です。
+

+
enable-woolchat:1
+

+X-Chat:
+ 対応しているメッセージ:
+  RPL_WHOISUSER(コロンが必須)
+ 説明:
+  WHOIS の realname にスペースが入っていないと最初の一文字が削られます。
+

+
enable-xchat:1
+ +
+
+ + +
+ + +
+

Client::ProtectMyself

+ 意図せず自分のニックが変わってしまうのを防止する
+
+

+{nick,part,quit,join}-format: それぞれのメッセージのフォーマットを指定します。
+{nick,user,host,prefix}.now などはどこでも使えます。
+そのほかには
+ target : 表示するチャンネル(またはニック)。
+ nick.new : nick-format のみ。新しいニック。
+ message : part と quit 。メッセージ。
+

+
nick-format:Nick changed #(nick.now) -> #(nick.new)
+
part-format:Part #(nick.now) (#(message)) from #(target)
+
quit-format:Quit #(nick.now) (#(message))
+
join-format:Join #(nick.now) (#(prefix.now)) to #(target)
+ +
+
+ + +
+ + +
+

Client::Rehash

+ 全チャンネル分の names の内部キャッシュをクライアントに送信する。
+
+

+もともとはクライアントの再初期化目的に作ったのですが、 names を送信しても
+更新されないクライアントが多いので、主に multi-server-mode な Tiarra の
+下にさらに Tiarra をつないでいる人向けにします。
+

+

+names でニックリストを更新してくれるクライアント:
+  Tiarra
+してくれないクライアント: (括弧内は確認したバージョンまたは注釈)
+  LimeChat(1.18)
+

+

+nick rehash に使うコマンドを指定します。
+第二パラメータとして現在クライアントが認識している nick を指定してください。
+

+
command-nick:rehash-nick
+

+names rehash に使うコマンドを指定します。
+

+
command-names:rehash-names
+

+チャンネルとチャンネルの間のウェイトを指定します。
+

+
interval:2
+ +
+
+ + +
+ + +
+

Client::ShowNick

+ show network
+
+ +
+
+ + + +
+ +
+ +
+ + diff -urN /non-existant-dir/doc/module/Debug.html tiarra-20080510/doc/module/Debug.html --- /non-existant-dir/doc/module/Debug.html 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/doc/module/Debug.html 2008-05-11 00:25:28.000000000 +0900 @@ -0,0 +1,115 @@ + + + + + + + Debug 関係のモジュール - Tiarra Documentation + + + +
+

Debug 関係のモジュール

+
+ +
+ +
+ +
+

Debug::Core

+ Tiarra の内部構造の追跡.
+
+

+Tiarra の内部構造を出力します.
+

+

+トリガー用コマンド.
+デフォルトは debugcore
+

+
command:debugcore
+

+[top commands]
+help - show this usage.
+bbs - show BulletinBoard info.
+socket - show internal sockets.
+module - show module info.
+

+

+[sub commands]
+help:
+bbs:
+  keys - show keys in BulletinBoard.
+socket:
+  help - show this usage.
+  list - show installed socket.
+  get - show socket in detail.
+  uninstall - uninstall detached socket.
+module:
+  help - show this usage.
+  summary - show module summary.
+  list - show module list in detail.
+  dep - show module dependency.
+

+ +
+
+ + +
+ + +
+

Debug::RawLog

+ 標準出力にクライアントやサーバとの通信をダンプする。
+
+

+0 または省略で表示しない。 1 で表示する。
+クライアントオプションの logname によって、ダンプに使う名前を指定できます。
+

+

+サーバからの入力
+

+
enable-server-in:1
+

+サーバへの出力
+

+
enable-server-out:1
+

+クライアントからの入力
+

+
enable-client-in:0
+

+クライアントへの出力
+

+
enable-client-out:0
+

+PING/PONG を無視する
+

+
ignore-ping:1
+

+NumericReply の名前を解決して表示する(ちゃんとした dump では無くなります)
+

+
resolve-numeric:1
+ +
+
+ + + +
+ +
+ +
+ + diff -urN /non-existant-dir/doc/module/Log.html tiarra-20080510/doc/module/Log.html --- /non-existant-dir/doc/module/Log.html 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/doc/module/Log.html 2008-05-11 00:25:28.000000000 +0900 @@ -0,0 +1,299 @@ + + + + + + + Log 関係のモジュール - Tiarra Documentation + + + +
+

Log 関係のモジュール

+
+ +
+ +
+ +
+

Log::Channel

+ チャンネルやprivのログを取るモジュール。
+
+

+Log系のモジュールでは、以下のように日付や時刻の置換が行なわれる。
+%% : %
+%Y : 年(4桁)
+%m : 月(2桁)
+%d : 日(2桁)
+%H : 時間(2桁)
+%M : 分(2桁)
+%S : 秒(2桁)
+

+

+ログを保存するディレクトリ。Tiarraが起動した位置からの相対パス。~指定は使えない。
+

+
directory:log
+

+ログファイルの文字コード。省略されたらjis。
+

+
charset:utf8
+

+各行のヘッダのフォーマット。省略されたら'%H:%M'。
+

+
header:%H:%M:%S
+

+ファイル名のフォーマット。省略されたら'%Y.%m.%d.txt'
+

+
filename:%Y.%m.%d.txt
+

+ログファイルのモード(8進数)。省略されたら600
+

+
mode:600
+

+ログディレクトリのモード(8進数)。省略されたら700
+

+
dir-mode:700
+

+ログを取るコマンドを表すマスク。省略されたら記録出来るだけのコマンドを記録する。
+

+
command:privmsg,join,part,kick,invite,mode,nick,quit,kill,topic,notice
+

+PRIVMSGとNOTICEを記録する際に、自分の発言と他人の発言でフォーマットを変えるかどうか。1/0。デフォルトで1。
+

+
distinguish-myself:1
+

+各ログファイルを開きっぱなしにするかどうか。
+このオプションは多くの場合、ディスクアクセスを抑えて効率良くログを保存しますが
+ログを記録すべき全てのファイルを開いたままにするので、50や100のチャンネルを
+別々のファイルにログを取るような場合には使うべきではありません。
+万一 fd があふれた場合、クライアントから(またはサーバへ)接続できない・
+新たなモジュールをロードできない・ログが全然できないなどの症状が起こる可能性が
+あります。limit の詳細については OS 等のドキュメントを参照してください。
+

+
keep-file-open:1
+

+keep-file-open 時に各行ごとに flush するかどうか。
+open/close の負荷は気になるが、ログは失いたくない人向け。
+keep-file-open が有効でないなら無視され(1になり)ます。
+

+
always-flush:0
+

+keep-file-openを有効にした場合、発言の度にログファイルに追記するのではなく
+一定の分量が溜まってから書き込まれる。そのため、ファイルを開いても
+最近の発言はまだ書き込まれていない可能性がある。
+syncを設定すると、即座にログをディスクに書き込むためのコマンドが追加される。
+省略された場合はコマンドを追加しない。
+

+
sync:sync
+

+各チャンネルの設定。チャンネル名の部分はマスクである。
+個人宛てに送られたPRIVMSGやNOTICEはチャンネル名"priv"として検索される。
+記述された順序で検索されるので、全てのチャンネルにマッチする"*"などは最後に書かなければならない。
+指定されたディレクトリが存在しなかったら、Log::Channelはそれを勝手に作る。
+フォーマットは次の通り。
+channel: <ディレクトリ名> (<チャンネル名> / 'priv')
+例:
+filename: %Y.%m.%d.txt
+channel: IRCDanwasitu #IRC談話室@ircnet
+channel: others *
+この例では、#IRC談話室@ircnetのログはIRCDanwasitu/%Y.%m.%d.txtに、
+それ以外(privも含む)のログはothers/%Y.%m.%d.txtに保存される。
+

+
channel:priv priv
+
channel:others *
+ +
+
+ + +
+ + +
+

Log::ChannelList

+ チャンネルリストをテンプレートに沿って HTML 化します。
+
+

+list コマンドが実行された際に動作します。
+

+

+出力したいファイル名、ネットワーク名、使う設定のブロックを指定します。。
+

+
networks:ircnet.html ircnet ircnet
+
ircnet +
+

+テンプレートファイルを指定します。
+

+
template:channellist.html.tmpl
+

+出力とテンプレートファイルの文字コードを指定します。
+

+
charset:euc
+

+取得を開始/終了した時刻のフォーマットを指定します。
+

+
fetch-starttime:%Y年%m月%d日 %H時%M分(日本時間)
+
fetch-endtime:%Y年%m月%d日 %H時%M分(日本時間)
+

+表示するチャンネルの mask を指定します。
+

+
mask:*
+
mask:-re:^\&(AUTH|SERVICES|LOCAL|HASH|SERVERS|NUMERICS|CHANNEL|KILLS|NOTICES|ERRORS)
+

+出力するファイルのモードを指定します。
+

+
mode:644
+
+ +
+
+ + +
+ + +
+

Log::Raw

+ サーバとの生の通信を保存する
+
+

+Log系のモジュールでは、以下のように日付や時刻の置換が行なわれる。
+%% : %
+%Y : 年(4桁)
+%m : 月(2桁)
+%d : 日(2桁)
+%H : 時間(2桁)
+%M : 分(2桁)
+%S : 秒(2桁)
+

+

+ログを保存するディレクトリ。Tiarraが起動した位置からの相対パス。~指定は使えない。
+

+
directory:rawlog
+

+各行のヘッダのフォーマット。省略されたら'%H:%M'。
+

+
header:%H:%M:%S
+

+ファイル名のフォーマット。省略されたら'%Y.%m.%d.txt'
+

+
filename:%Y-%m-%d.txt
+

+ログファイルのモード(8進数)。省略されたら600
+

+
mode:600
+

+ログディレクトリのモード(8進数)。省略されたら700
+

+
dir-mode:700
+

+使っている文字コードがよくわからなかったときの文字コード。省略されたらutf8。
+たぶんこの指定が生きることはないと思いますが……。
+

+
charset:jis
+

+NumericReply の名前を解決して表示する(ちゃんとした dump では無くなります)
+

+
resolve-numeric:1
+

+ログを取るコマンドを表すマスク。省略されたら記録出来るだけのコマンドを記録する。
+

+
command:*,-ping,-pong
+

+各ログファイルを開きっぱなしにするかどうか。
+このオプションは多くの場合、ディスクアクセスを抑えて効率良くログを保存しますが
+ログを記録すべき全てのファイルを開いたままにするので、50や100のチャンネルを
+別々のファイルにログを取るような場合には使うべきではありません。
+万一 fd があふれた場合、クライアントから(またはサーバへ)接続できない・
+新たなモジュールをロードできない・ログが全然できないなどの症状が起こる可能性が
+あります。limit の詳細については OS 等のドキュメントを参照してください。
+

+
keep-file-open:1
+

+keep-file-open 時に各行ごとに flush するかどうか。
+open/close の負荷は気になるが、ログは失いたくない人向け。
+keep-file-open が有効でないなら無視され(1になり)ます。
+

+
always-flush:0
+

+keep-file-openを有効にした場合、発言の度にログファイルに追記するのではなく
+一定の分量が溜まってから書き込まれる。そのため、ファイルを開いても
+最近の発言はまだ書き込まれていない可能性がある。
+syncを設定すると、即座にログをディスクに書き込むためのコマンドが追加される。
+省略された場合はコマンドを追加しない。
+

+
sync:sync
+

+各サーバの設定。サーバ名の部分はマスクである。
+記述された順序で検索されるので、全てのサーバにマッチする"*"などは最後に書かなければならない。
+指定されたディレクトリが存在しなかったら、勝手に作られる。
+フォーマットは次の通り。
+channel: <ディレクトリ名> <サーバ名マスク>
+例:
+filename: %Y-%m-%d.txt
+server: ircnet ircnet
+server: others *
+この例では、ircnetのログはircnet/%Y.%m.%d.txtに、
+それ以外のログはothers/%Y.%m.%d.txtに保存される。
+

+
server:ircnet ircnet
+
server:others *
+ +
+
+ + +
+ + +
+

Log::Recent

+ クライアントを接続した時に、保存しておいた最近のメッセージを送る。
+
+

+クライアントオプションの no-recent-logs が指定されていれば送信しません。
+

+

+各行のヘッダのフォーマット。省略されたら'%H:%M'。
+

+
header:%H:%M:%S
+

+ログをチャンネル毎に何行まで保存するか。省略されたら10。
+

+
line:15
+

+PRIVMSGとNOTICEを記録する際に、自分の発言と他人の発言でフォーマットを変えるかどうか。1/0。デフォルトで1。
+

+
distinguish-myself:1
+

+どのメッセージを保存するか。省略されたら保存可能な全てのメッセージを保存する。
+

+
command:privmsg,notice,topic,join,part,quit,kill
+ +
+
+ + + +
+ +
+ +
+ + diff -urN /non-existant-dir/doc/module/System.html tiarra-20080510/doc/module/System.html --- /non-existant-dir/doc/module/System.html 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/doc/module/System.html 2008-05-11 00:25:28.000000000 +0900 @@ -0,0 +1,394 @@ + + + + + + + System 関係のモジュール - Tiarra Documentation + + + +
+

System 関係のモジュール

+
+ +
+ +
+ +
+

System::Error

+ サーバーからのERRORメッセージをNOTICEに埋め込む
+
+

+これをoffにするとクライアントにERRORメッセージがそのまま送られます。
+クライアントとの間ではERRORメッセージは主に切断警告に使われており、
+そのまま流してしまうとクライアントが混乱する可能性があります。
+  設定項目はありません。
+

+

+このモジュールを回避してERRORメッセージをクライアントに送りたい場合は、
+remarkのsend-error-as-is-to-clientを指定してください。
+

+ +
+
+ + +
+ + +
+

System::LivePatch

+ Live Patch.
+
+

+main/* に対する実行時パッチ
+起動/ロード時に確認は行われるが, 実際の適用は指示があるまで行われない.
+

+

+対応している箇所.
+ModuleManager / reload_modules_if_modified / r3004 => r8809
+

+

+/livepatch check で確認.
+/livepatch apply で適用.
+

+
command:livepatch
+ +
+
+ + +
+ + +
+

System::Macro

+ 新規にコマンドを追加し、そのコマンドが使われた時に特定の動作をまとめて実行します。
+
+

+書式: <コマンド> <動作>
+コマンド"switch"を追加して、それが使われると
+#a@ircnet,#b@ircnet,#c@ircnetにjoinして、
+#d@ircnet,#e@ircnet,#f@ircnetからpartする例。
+

+
macro:switch join #a@ircnet,#b@ircnet,#c@ircnet
+
macro:switch part #d@ircnet,#e@ircnet,#f@ircnet
+ +
+
+ + +
+ + +
+

System::NotifyIcon::Win32

+ タスクトレイにアイコンを表示する。
+
+

+タスクトレイにアイコンを表示します。
+クリックすると表示非表示を切り替えることができ、右クリックすると
+Reload と Exit ができるコンテキストメニューを表示します。
+多少反応が鈍いかもしれませんがちょっと待てば出てくると思います。
+

+

+Win32::GUI を必要とします。
+コンテキストメニューは表示している間処理をブロックしています。
+

+

+Win32 イベントループを処理する最大間隔を指定します。
+

+
interval:2
+

+通知領域に表示するアイコンを指定します。
+Win32::GUI の制限でちゃんとしたアイコンファイルしか指定できません。
+

+
iconfile:guiperl.ico
+

+モジュールが読み込まれたときにコンソールウィンドウを隠すかどうかを
+指定します。
+

+
hide-console-on-load:1
+ +
+
+ + +
+ + +
+

System::Pong

+ サーバーからのPINGメッセージに対し、自動的にPONGを返す。
+
+

+これをoffにするとクライアントが自らPINGに応答せざるを得なくなりますが、
+クライアントからのPONGメッセージはデフォルトのサーバーへ送られるので
+デフォルト以外のサーバーからはPing Timeoutで落とされるなど
+全く良い事がありません。
+  設定項目はありません。
+

+ +
+
+ + +
+ + +
+

System::PrivTranslator

+ クライアントからの個人的なprivが相手に届かなくなる現象を回避する。
+
+

+このモジュールは個人宛てのprivmsgの送信者のnickにネットワーク名を付加します。
+また、最後に声をかけられてから5分以内の nick 変更をクライアントに伝えます。
+設定項目はありませんが、 networks/channel-network-separator を ! や @ 以外に
+変更することをおすすめします。
+

+ +
+
+ + +
+ + +
+

System::Raw

+ マスクで指定したサーバーにIRCメッセージを加工せずに直接送る。
+
+

+例えばQUITを送る事で一時的な切断が可能。
+

+

+この機能を利用するためのコマンド名。デフォルトは「raw」。
+「/raw ircnet quit」のようにして使う。
+一つ目のパラメータは送り先のネットワーク名。ワイルドカード使用可能。
+CHOCOA の場合、 raw がクライアントで使われてしまうので、
+コマンド名を変えるか、 /raw raw ircnet quit のようにする必要がある。
+

+
command:raw
+ +
+
+ + +
+ + +
+

System::Reload

+ confファイルやモジュールの更新をリロードするコマンドを追加する。
+
+

+リロードを実行するコマンド名。省略されるとコマンドを追加しません。
+例えば"load"を設定すると、"/load"と発言しようとした時にリロードを実行します。
+この時コマンドはTiarraが握り潰すので、IRCプロトコル上で定義された
+コマンド名を設定すべきではありません。
+

+
command:load
+

+command と同じですが、サーバにもブロードキャストします。
+

+
broadcast-command:load-all
+

+confファイルをリロードしたときに通知します。
+モジュールの設定が変更されていた場合は、ここでの設定にかかわらず、
+モジュールごとに表示されます。1または省略された場合は通知します。
+

+
conf-reloaded-notify:1
+ +
+
+ + +
+ + +
+

System::RemoteControl

+ 特定の発言が送られてきたとき、それに反応してIRCコマンドを実行します。
+
+

+実行を許可する人間を表すマスク。
+

+
mask:*!*example@example.net
+

+ 構文: + <nick> <IRC Message>
+ <nick>は反応するbotのnickを表すマスク。
+ <Tiarra::IRC::Message>はサーバーに向けて発行するIRCメッセージ。
+
+ 例:
+ + hoge NICK [hoge]
+ hogeというBOTが[hoge]にnickを変更する。
+

+ +
+
+ + +
+ + +
+

System::Shutdown

+ Tiarraを終了させる。
+
+

+クライアントから特定のコマンドが実行された時や、
+誰かから個人的に(privで)特定の発言が送られた時に
+Tiarra を終了させます。
+

+

+追加するコマンド。省略された場合はコマンドでのシャットダウンは無効になります。
+

+
command:shutdown
+

+Tiarraをシャットダウンさせるprivの発言。
+省略された場合はprivでのシャットダウンは無効になります。
+パラメータとして shutdown メッセージを指定できます。
+

+
message:shutdown
+

+privでのシャットダウンを許可する人。
+省略された場合はprivでのシャットダウンは無効になります。
+複数のマスクを指定した場合は、一つでもマッチするものがあればシャットダウンします。
+

+
mask:example!example@*.example.jp
+ +
+
+ + +
+ + +
+

System::WebClient

+ ブラウザ上でログを見たり発言したりできます.
+
+

+WebClient を起動させる場所の指定.
+

+
bind-addr:127.0.0.1
+
bind-port:8668
+
path:/irc
+
css:/style/irc-style.css
+

+上の設定をapacheでReverseProxyさせる場合, httpd.conf には次のように設定.
+ ProxyPass /irc/ http://localhost:8667/irc/
+ ProxyPassReverse /irc/ http://localhost:8667/irc/
+ <Location /irc/>
+ ...
+ </Location>
+

+

+ReverseProxy 利用時の追加設定.
+接続元が全部プロキシサーバになっちゃうのでその対応.
+

+
extract-forwarded-for:127.0.0.1
+

+ 利用する接続設定の一覧.
+
+ 空白区切りで評価する順に記述.
+ 使われる設定は,
+ - 接続元 IP が一致する物.
+ - user/passが送られてきていない(認証前/anonymous):
+   - 認証不要の設定があればその設定を利用.
+   - 認証不要の設定がなければ 401 Unauthorized.
+ - user/passが送られてきている.
+   - 一致する設定を利用.
+   - 一致する設定がなければ 401 Unauthorized.
+

+
allow:private public
+

+許可する接続の設定.
+

+
allow-private +
+

+接続元IPアドレスの制限.
+

+
host:127.0.0.1
+

+認証設定.
+

+
auth:user pass
+

+公開するチャンネルの指定.
+

+
mask:#*@*
+
mask:*@*
+
+
allow-public +
+
host:*
+
auth:user2 pass2
+
mask:#公開チャンネル@ircnet
+
+

+デバッグフラグ.
+

+
debug:0
+

+保存する最大行数.
+

+
max-lines:100
+

+クライアントモード.
+owner か shared.
+

+
mode:owner
+

+ログの方向.
+asc (旧->新) か desc (新->旧).
+

+
sort-order:asc
+

+発言BOXで名前指定しなかったときのデフォルトの名前.
+mode: shared の時に使われる.
+

+
name-default:(noname)
+ +
+
+ + + +
+ +
+ +
+ + diff -urN /non-existant-dir/doc/module/UNCLASSIFIED.html tiarra-20080510/doc/module/UNCLASSIFIED.html --- /non-existant-dir/doc/module/UNCLASSIFIED.html 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/doc/module/UNCLASSIFIED.html 2008-05-11 00:25:28.000000000 +0900 @@ -0,0 +1,52 @@ + + + + + + + 関係のモジュール - Tiarra Documentation + + + +
+

関係のモジュール

+
+ +
+ +
+ +
+

Skelton

+ Skelton for tiarra-module.
+
+

+モジュールの説明をこのあたりに書く.
+詳細はこのソースみれば分かると思われ.
+書式は tiarra.conf にそのままコピーできる形式.
+

+

+もにゅもにゅ
+

+
mask:*!*@*
+
mask:...
+ +
+
+ + + +
+ +
+ +
+ + diff -urN /non-existant-dir/doc/module/User.html tiarra-20080510/doc/module/User.html --- /non-existant-dir/doc/module/User.html 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/doc/module/User.html 2008-05-11 00:25:28.000000000 +0900 @@ -0,0 +1,207 @@ + + + + + + + User 関係のモジュール - Tiarra Documentation + + + +
+

User 関係のモジュール

+
+ +
+ +
+ +
+

User::Away::Client

+ クライアントが一つも接続されていない時にAWAYを設定します。
+
+

+どのようなAWAYメッセージを設定するか。省略された場合はAWAYを設定しません。
+

+
away:居ない。
+ +
+
+ + +
+ + +
+

User::Away::Nick

+ ニックネーム変更に応じて AWAY を設定します。
+
+

+ニックネームを変更したときに、そのニックネームに対応するAWAYが
+設定されていれば、そのAWAYを設定します。そうでなければAWAYを取り消します。
+

+

+ 書式: <nickのマスク> <設定するAWAYメッセージ>
+
+ nickをhoge_zzzに変更すると、「寝ている」というAWAYを設定する。
+ hoge_workまたはhoge_zzzに変更した場合は、「仕事中」というAWAYを設定する。
+ それ以外のnickに変更した場合はAWAYを取り消す。
+ 後者は正規表現を利用して「away: re:hoge_(work|zzz) 仕事中」としても良い。
+

+
away:hoge_zzz 寝ている
+
away:hoge_work,hoge_zzz 仕事中
+ +
+
+ + +
+ + +
+

User::Filter

+ 指定された人物からのPRIVMSGやNOTICEを書き換える。
+
+

+人物のマスクと、置換パターンを定義。
+置換パターン中の#(message)は、発言内容に置換されます。
+人物が複数のマスクに一致する場合は、最初に一致したものが使われます。
+

+
pattern:*!*@* #(message)
+ +
+
+ + +
+ + +
+

User::Ignore

+ 指定された人間からのPRIVMSGやNOTICEを破棄してクライアントへ送らないようにするモジュール。
+
+

+対象となるコマンドのマスク。省略時には"privmsg,notice"が設定されている。
+ただしprivmsgとnotice以外を破棄してしまうと、(Tiarraは平気でも)クライアントが混乱する。
+

+
command:privmsg,notice
+

+maskは複数定義可能。定義された順番でマッチングが行なわれます。
+

+
mask:example!*@*.example.net
+ +
+
+ + +
+ + +
+

User::Nick::Detached

+ クライアントが接続されていない時に、特定のnickに変更します。
+
+

+クライアントが接続されていない時のnick。
+このnickが既に使われていたら、適当に変更が加えられて使用されます。
+クライアントが再び接続されると、切断前のローカルnickに戻ります。
+

+
detached:PHO_d
+ +
+
+ + +
+ + +
+

User::ServerOper

+ 特定のネットワークに接続した時、OPERコマンドを発行します。
+
+

+ 書式: <ネットワーク名> <オペレータ名> <オペレータパスワード>
+
+ ネットワーク"local"に接続した時、オペレータ名oper、
+ オペレータパスワードoper-passでOPERコマンドを発行する例。
+

+
oper:local oper oper-pass
+ +
+
+ + +
+ + +
+

User::Vanish

+ 指定された人物の存在を、様々なメッセージから消去する。
+
+

+対象となった人物の発行したJOIN、PART、INVITE、QUIT、NICKは消去され、NAMESの返すネームリストからも消える。
+また、対象となった人物のNJOINも消去される。
+

+

+Vanish対象が発行したMODEを消去するかどうか。デフォルトで0。
+消去するとは云え、本当にMODEそのものを消してしまうのではなく、
+そのユーザーの代わりに"HIDDEN!HIDDEN@HIDDEN.BY.USER.VANISH"がMODEを実行した事にする。
+

+
drop-mode-by-target:1
+

+Vanish対象を対象とするMODE +o/-o/+v/-vを消去するかどうか。デフォルトで1。
+

+
drop-mode-switch-for-target:1
+

+Vanish対象が発行したKICKを消去するかどうか。デフォルトで0。
+本当に消すのではなく、"HIDDEN!HIDDEN@HIDDEN.BY.USER.VANISH"がKICKを実行した事にする。
+

+
drop-kick-by-target:1
+

+Vanish対象を対象とするKICKを消去するかどうか。デフォルトで0。
+

+
drop-kick-for-target:0
+

+Vanish対象が発行したTOPICを消去するかどうか。デフォルトで0。
+本当に消すのでは無いが、他の設定と同じ。
+

+
drop-topic-by-target:1
+

+チャンネルとVanish対象の定義。
+特定のチャンネルでのみ対象とする、といった事が可能。
+また、privの場合は「#___priv___@ネットワーク名」という文字列をチャンネル名の代わりとしてマッチングを行なう。
+書式: mask: <チャンネルのマスク> <ユーザーのマスク>
+

+
mask:#example@example example!exapmle@example.com
+ +
+
+ + + +
+ +
+ +
+ + diff -urN /non-existant-dir/doc/module-toc.html tiarra-20080510/doc/module-toc.html --- /non-existant-dir/doc/module-toc.html 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/doc/module-toc.html 2008-05-11 00:25:28.000000000 +0900 @@ -0,0 +1,205 @@ + + + + + + + モジュール一覧 - Tiarra Documentation + + + + +

モジュール一覧

+ +
    + +
  • + UNCLASSIFIED 未分類のモジュール +
      + +
    • Skelton Skelton for tiarra-module.
      • + +
    +
    • + +
  • + Auto 自動反応 +
      + +
    • Auto::Alias ユーザエイリアス情報の管理を行ないます。
      • + +
    • Auto::Answer 特定の発言に反応して対応する発言をする。
      • + +
    • Auto::Calc Perlの式を計算させるモジュール。
      • + +
    • Auto::ChannelWithoutOper チャンネルオペレータ権限がなくなってしまったときに発言する。
      • + +
    • Auto::FetchTitle 発言に含まれるURLからタイトルを取得.
      • + +
    • Auto::Im 名前が呼ばれると、その発言をim.kayac.comに送信する
      • + +
    • Auto::Joined 特定のチャンネルに誰かがJOINする度に特定のメッセージを発言する。
      • + +
    • Auto::MesMail 伝言をメールとして送信する。
      • + +
    • Auto::Oper 特定の文字列を発言した人を+oする。
      • + +
    • Auto::Random 特定の発言に反応してランダムな発言をします。
      • + +
    • Auto::Reply 特定の発言に反応して発言をします。
      • + +
    • Auto::Response データファイルの指定にしたがって反応する。
      • + +
    +
    • + +
  • + CTCP CTCP 関連 + +
    • + +
  • + Channel チャンネルに対する操作 +
      + +
    • Channel::Freeze 特定のチャンネルの発言を、一時的に受信するのをやめる。
      • + +
    • Channel::Ignore 指定されたチャンネルの存在を、様々なメッセージから消去する。
      • + +
    • Channel::Join::Connect サーバーに初めて接続した時、指定したチャンネルに入るモジュール。
      • + +
    • Channel::Join::Invite 招待されたらそのチャンネルに入る。
      • + +
    • Channel::Join::Kicked 特定のチャンネルからkickされた時に、自動で入りなおす。
      • + +
    • Channel::Mode::Get チャンネルにJOINした時、そのチャンネルのモードを取得します。
      • + +
    • Channel::Mode::Oper::Grant 特定のチャンネルに特定の人間がjoinした時に、自分がチャンネルオペレータ権限を持っていれば+oする。
      • + +
    • Channel::Mode::Set チャンネルを作成した時に自動的にモードを設定するモジュール。
      • + +
    • Channel::Rejoin チャンネルオペレータ権限を無くしたとき、一人ならjoinし直す。
      • + +
    +
    • + +
  • + Client クライアントとの入出力 +
      + +
    • Client::Cache データをキャッシュしてサーバに問い合わせないようにする
      • + +
    • Client::Conservative サーバが送信するような IRC メッセージを作成するようにする
      • + +
    • Client::Cotton Cotton の行うおかしな動作のいくつかを無視する
      • + +
    • Client::Eval クライアントから Perl 式を実行できるようにする。
      • + +
    • Client::GetVersion クライアントに CTCP Version を発行してバージョン情報を得る
      • + +
    • Client::PatchworkMessage IRC メッセージにちょっと変更を加えて、クライアントのバグを抑制する
      • + +
    • Client::ProtectMyself 意図せず自分のニックが変わってしまうのを防止する
      • + +
    • Client::Rehash 全チャンネル分の names の内部キャッシュをクライアントに送信する。
      • + +
    • Client::ShowNick show network
      • + +
    +
    • + +
  • + Debug Tiarraや、Tiarraモジュールのデバッグ用 +
      + +
    • Debug::Core Tiarra の内部構造の追跡.
      • + +
    • Debug::RawLog 標準出力にクライアントやサーバとの通信をダンプする。
      • + +
    +
    • + +
  • + Log ログの記録 +
      + +
    • Log::Channel チャンネルやprivのログを取るモジュール。
      • + +
    • Log::ChannelList チャンネルリストをテンプレートに沿って HTML 化します。
      • + +
    • Log::Raw サーバとの生の通信を保存する
      • + +
    • Log::Recent クライアントを接続した時に、保存しておいた最近のメッセージを送る。
      • + +
    +
    • + +
  • + System Tiarra自身の動作に関するもの +
      + +
    • System::Error サーバーからのERRORメッセージをNOTICEに埋め込む
      • + +
    • System::LivePatch Live Patch.
      • + +
    • System::Macro 新規にコマンドを追加し、そのコマンドが使われた時に特定の動作をまとめて実行します。
      • + +
    • System::NotifyIcon::Win32 タスクトレイにアイコンを表示する。
      • + +
    • System::Pong サーバーからのPINGメッセージに対し、自動的にPONGを返す。
      • + +
    • System::PrivTranslator クライアントからの個人的なprivが相手に届かなくなる現象を回避する。
      • + +
    • System::Raw マスクで指定したサーバーにIRCメッセージを加工せずに直接送る。
      • + +
    • System::Reload confファイルやモジュールの更新をリロードするコマンドを追加する。
      • + +
    • System::RemoteControl 特定の発言が送られてきたとき、それに反応してIRCコマンドを実行します。
      • + +
    • System::Shutdown Tiarraを終了させる。
      • + +
    • System::WebClient ブラウザ上でログを見たり発言したりできます.
      • + +
    +
    • + +
  • + User 特定の人間に対する動作や自分自身についての動作 +
      + +
    • User::Away::Client クライアントが一つも接続されていない時にAWAYを設定します。
      • + +
    • User::Away::Nick ニックネーム変更に応じて AWAY を設定します。
      • + +
    • User::Filter 指定された人物からのPRIVMSGやNOTICEを書き換える。
      • + +
    • User::Ignore 指定された人間からのPRIVMSGやNOTICEを破棄してクライアントへ送らないようにするモジュール。
      • + +
    • User::Nick::Detached クライアントが接続されていない時に、特定のnickに変更します。
      • + +
    • User::ServerOper 特定のネットワークに接続した時、OPERコマンドを発行します。
      • + +
    • User::Vanish 指定された人物の存在を、様々なメッセージから消去する。
      • + +
    +
    • + +
+ + diff -urN /non-existant-dir/doc-src/README tiarra-20080510/doc-src/README --- /non-existant-dir/doc-src/README 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/doc-src/README 2008-05-11 00:25:26.000000000 +0900 @@ -0,0 +1,115 @@ +-*- mode: outline; mode: auto-fill; -*- + +* tdoc形式について + +次のような形式を持つ=podと=cutに囲まれた範囲が、TiarraDoc(tdoc)として +認識されます。 + +=pod +ヘッダのキー: ヘッダの値 +ヘッダのキー: ヘッダの値 +... + +内容 +=cut + +このように、"キー: 値"の行が一つ以上続き、その後に空行が来るような形を +していないpodはtdocパーサによって無視されます。 + +tdocデータはファイル内の何処にあっても構いませんが、そのtdocが説明する +パッケージ内の範囲に無ければなりません。つまり、複数のパッケージを持 +つ*.pmファイルの中では、パッケージFooについてのtdocはパッケージFoo内に +置く必要があります。 +tdocパーサはperlのpackage文を認識し、どのパッケージについての説明であ +るかを判断します。 + +tdocデータはsample.confの生成とhtmlドキュメントの生成の両方に使われま +す。また、将来これ以外の使い方がされる可能性もあります。 + +** ヘッダ + +ヘッダに記述すべき内容は、通常のモジュール(module下のもの)、内部モジュー +ル(main下のもの)、そしてドキュメント生成元データ(doc-src下の*.tdoc)そ +れぞれに於て異なります。 + +*** 通常のモジュールのヘッダ(module下のもの) + +通常のモジュールは、ヘッダとして"info"と"default"を持ちます。 +infoはモジュールの簡単な説明(一行)、defaultは値として"on"または"off"を +持つ真偽値で、それぞれsample.conf内でデフォルトで"+"になっているか"-" +になっているかを示します。 + +例(System::Reload): + +=pod +info: confファイルやモジュールの更新をリロードするコマンドを追加する。 +default: on + +# リロードを実行するコマンド名。省略されるとコマンドを追加しません。 +# 例えば"load"を設定すると、"/load"と発言しようとした時にリロードを実行します。 +# この時コマンドはTiarraが握り潰すので、IRCプロトコル上で定義された +# コマンド名を設定すべきではありません。 +command: load +=cut + +*** 内部モジュール(main下のもの) + +未定 + +*** ドキュメント生成元データ(doc-src下の*.tdoc) + +未定 + + +** 内容 + +ドキュメント内容もヘッダと同じように、通常モジュール、内部モジュール、 +ドキュメント生成元データのそれぞれに於て異ります。 + +*** 通常モジュール + +通常モジュールは、"#"で始まる行と"key: value"の形そしている行、そして +"-key: value"の形をしている行の三種類の形式で記述します。 +空の行やこれらの形を持たない行は、パーサによって無視されます。 + +"#"で始まる行は、後述する"key: value"の説明の為にあります。 +連続する"#"行はtdocパーサによって一つに纏められ、先頭の空白が削除され +た後にsample.conf、htmlの各形式に整形されます。 +纏められた"#"行の先頭に共通する空白は全て削除されますが、共通*しない* +空白は残されます。 + +例: +# foo +# bar +# baz + +以上の三行は纏められ、先頭の空白が削除される。sample.confでの整形結果 +は結果は次の通り。 + +# foo +# bar +# baz + +例: +# foo +# bar +# baz + +以上の三行は纏められ、全ての行に存在する空白が削除される。結果は次の通 +り。 + +# foo +# bar +# baz + +"key: value"形式の行は、そのモジュールの設定項目を表します。 +同様に、"-key: value"形式の行は、そのモジュールの設定項目ではあっても、 +sample.confではデフォルトでコメントアウトされている項目を表します。 + +*** 内部モジュール(main下のもの) + +未定 + +*** ドキュメント生成元データ(doc-src下の*.tdoc) + +未定 diff -urN /non-existant-dir/doc-src/all.conf.in tiarra-20080510/doc-src/all.conf.in --- /non-existant-dir/doc-src/all.conf.in 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/doc-src/all.conf.in 2008-05-11 00:25:26.000000000 +0900 @@ -0,0 +1,73 @@ +# -*- tiarra-conf -*- +# ----------------------------------------------------------------------------- +# $Id: all.conf.in 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +# tiarra.conf サンプル +# このファイルにはすべてのブロックの解説があります。 +# 必要なブロックがあればここからコピーしていってください。 +# ----------------------------------------------------------------------------- + +# ----------------------------------------------------------------------------- +# generalブロック +# +# tiarra.conf自身の文字コードやユーザー情報などを指定するブロックです。 +# ----------------------------------------------------------------------------- +<&general> + +# ----------------------------------------------------------------------------- +# networksブロック +# +# Tiarraから接続するIRCネットワークの名称です。 +# 一つも定義しなかった場合やこのブロックを省略した場合は、 +# "main"というネットワークが一つだけ指定されたものと見做します。 +# ----------------------------------------------------------------------------- +<&networks> + +# ----------------------------------------------------------------------------- +# 各ネットワークの設定 +# +# networksブロックで定義した全てのネットワークについて、 +# そのアドレス、ポート、(必要なら)パスワードを定義します。 +# ----------------------------------------------------------------------------- +<&ircnet> + +<&2ch> + +# ----------------------------------------------------------------------------- +# 必須の設定は以上です。以下はモジュール(プラグイン)の設定です。 +# ----------------------------------------------------------------------------- + +# +または-で始まる行はモジュール設定行と見做されます。 +# +で記述されたモジュールが使用され、-で記述されたモジュールは使用されません。 +# +や-の後の空白は幾つあっても無視されます。 + +# メッセージが各モジュールを通過する順番は、このconfファイルで記述された +# 順番の通りになります。ログを取るモジュールなどはconfでも後の方に +# 記述した方が良いということになります。 + +# モジュール名はperlのそれと同じようにディレクトリ区切り文字を「::」としたパスで表現されます。 +# 例えばモジュールChannel::Auto::Operの実体はファイルmodule/Channel/Auto/Oper.pm +# でなければならず、そのpackage宣言もChannel::Auto::Operでなければなりません。 +# Tiarraモジュールの名称は、perl標準モジュール群やmain/下の.pmファイルと重複しないように +# 気を付けて下さい。Tiarraはモジュールが本当にModuleのサブクラスかどうかをチェックするので +# 例えばIO::Socket::INETといったモジュールを置いても誤動作はしませんが、 +# そのようなモジュールはロード時にエラーを出して使用中止になります。 + +# 一つのモジュールを複数回定義して、何度も同じモジュールをメッセージが通過するようには出来ません。 + +# 幾つかのモジュールはパラメータとしてチャンネル名を必要とします。 +# ここで指定するチャンネル名は、ネットワーク名も含めた文字列でなければなりません。 +# 「#チャンネル」では駄目で「#チャンネル@ネットワーク」などとする必要があります。 + +# マスクの書式: +# ['+' / '-'] ( <マスク文字列> / "re:" 正規表現 ) +# これはカンマで幾つでも継ぐ事が出来ます。"\,"でカンマそのものを表します。 +# 先頭が+なら、それに続く部分にマッチするものが選ばれ、-なら除外されます。省略されたら+と見做されます。 +# マスク文字列とは"*"で0文字以上の任意の文字列を、"?"で1文字の任意の文字列を表す文字列です。 +# 例: +# tiarra* これはtiarraで始まる文字列を表す。 +# +*!*tiarra@*.jp,-re:\d これは*!*tiarra@*.jpにマッチして、かつ文字列中に数字を含まないものを表す。 + + +<&module> + diff -urN /non-existant-dir/doc-src/conf-main.tdoc tiarra-20080510/doc-src/conf-main.tdoc --- /non-existant-dir/doc-src/conf-main.tdoc 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/doc-src/conf-main.tdoc 2008-05-11 00:25:26.000000000 +0900 @@ -0,0 +1,261 @@ +-*- outline -*- +$Id: conf-main.tdoc 11365 2008-05-10 14:58:28Z topia $ + +perlのソースに使うpodパーサを流用しているので、package文と=pod〜=cutで書く必要があります。 +ヘッダのinfo-is-ommitedとno-switchはどちらも値を真に定義しなければなりません。 + +* general +package general; +=pod +info: conf自身の文字コードやユーザー情報などを指定する +info-is-omitted: 1 +no-switch: 1 + +# tiarra.conf自身の文字コード +# コード名はjis,sjis,euc,utf8,utf16,utf32等。(この値はUnicode::Japaneseにそのまま渡されます) +# autoが指定された、または省略された場合は自動判別します。 +conf-encoding: utf8 + +# ユーザー情報 +# 省略不能です。 +nick: tiarra +user: tiarra +name: Tiarra the "Aeon" + +# どのようなユーザーモードでログインするか。+iwや+iのように指定する。 +# 省略された場合はユーザーモードを特に設定しない。 +-user-mode: +i + +# Tiarraへの接続を許可するホスト名を表わすマスク。 +# 制限をしないのであれば"*"を指定するか省略する。 +client-allowed: * + +# Tiarraが開くポート。ここに指定したポートへクライアントに接続させる。 +# 省略されたらポートを開かない。 +tiarra-port: 6667 + +# Tiarraがポートtiarra-portを開く際、IPv6とIPv4のどちらでリスニングを行なうか。 +# 'v4'または'v6'で指定します。デフォルトは'v4'です。 +# IPv6を使うためにはSocket6.pmが利用可能である必要があります。 +-tiarra-ip-version: v4 + +# Tiarraがポートtiarra-portを開く際のローカルアドレス。 +# 意味が分からなければ省略して下さい。 +# デフォルトは、IPv4のはINADDR_ANY、IPv6のはin6addr_anyになります。 +-tiarra-ipv4-bind-addr: 0.0.0.0 +-tiarra-ipv6-bind-addr: ::0 + +# Tiarraにクライアントが接続する際に要求するパスワードをcryptした文字列。 +# 空の文字列が指定されたり省略された場合はパスワードを要求しない。 +# crypt は ./tiarra --make-password で行えます。 +tiarra-password: xl7cflIcH9AwE + +# 外部プログラムからtiarraをコントロールする為のUNIXドメインソケットの名前。 +# 例えば"foo"を指定した場合、ソケット/tmp/tiarra-control/fooが作られる。 +# 省略された場合はこの機能を無効とする。 +# また、非UNIX環境ではそもそもUNIXドメインソケットが利用可能でないため、 +# そのような場合にもこの機能は無効となる。 +-control-socket-name: test + +# IRCサーバーから送られる文字のコードと、IRCサーバーへ送る文字のコード +# どちらも省略された場合はjis。 +server-in-encoding: jis +server-out-encoding: jis + +# クライアントから受け取る文字のコードと、クライアントへ伝える文字のコード +# どちらも省略された場合はjis。 +client-in-encoding: jis +client-out-encoding: jis + +# Tiarraは標準出力に様々なメッセージを出力するが、その文字コードを指定する。省略時にはeucとなる。 +# ただしtiarra.confのパースが完了するまでは文字コードの変換は行なわれない(つまりこの設定が有効にならない)ことに注意して下さい。 +stdout-encoding: utf8 + +# Tiarraはエラーメッセージを標準出力に出力するが、その時に接続しているクライアントがあればクライアントにもNOTICEで送る事が出来る。 +# この値を1にすると、その機能が有効になる。省略するか0を指定するとこの機能は無効になる。 +notice-error-messages: 1 + +# Tiarraでチャンネルとユーザーのマスクを指定するときの形式。 +# plum形式とTiarra形式が選択できます。 +#----------------- +# plum形式: (channelには+や-は使えない。channelは省略すると*とみなす。) +# + syntax: user[ channel[ channel[ ...]]] +# +# mask: +*!*@*.example.com #{example}@ircnet +{example3}@ircnet +# mask: -*!*@*.example.com #{example2}@2ch,+{example4}@2ch +# mask: -*!*@* +#----------------- +# Tiarra形式: (channelにも+や-を使える。) +# + syntax: channel user +# +# mask: #{example}@ircnet,-#{example2}@2ch +*!*@*.example.com +# mask: ++{example3}@ircnet,-+{example4}@2ch +*!*@*.example.com # +で始まるチャンネル。 +# mask: * -*!*@* +#----------------- +# となります。 この二つはまったく同じマスクを表しています。 + +# この値をplumにすると、plum形式、省略するかtiarraを指定すると、Tiarra形式になります。 +chanmask-mode: tiarra + +# サーバーに接続する際、ローカル側のどのアドレスにバインドするか。 +# 意味が分からなければ省略して下さい。 +# デフォルトは、IPv4のはINADDR_ANY、IPv6のはin6addr_anyになります。 +-ipv4-bind-addr: 0.0.0.0 +-ipv6-bind-addr: ::0 + +# tiarra が、 001 や 002 や、 recent log を送信するときなどに使う prefix +# を指定します。 hostname や fqdn っぽいものを指定すると良いかもしれません。 +# デフォルトは tiarra です。普通変える必要はありません。 +-sysmsg-prefix: tiarra + +sysmsg-prefix-use-masks { + # sysmsg-prefix を使用する場所を指定する。 + + # システムメッセージ(NumericReply など)。デフォルトは * です。 + # ふつうこれを変更する必要はありません。 + system: * + + # 個人宛メッセージ(Notice,Privmsg の中で)。デフォルトはなし。 + -priv: + + # チャンネル宛メッセージ(Notice,Privmsg の中で)。デフォルトは * です。 + # Ziciz などのクライアントを接続する場合は、 + # -*::log を指定しておくといいかもしれません。 + channel: * +} + +# Tiarra が nick 変更時の衝突等を処理するモードを指定します。 +# 0: Tiarra が接続時と同様に自動処理します。 +# 1: クライアントにそのまま投げます。 +# 複数のクライアントが nick 重複を処理する場合は非常に危険です。 +# (設定不足の IRC クライアントが複数つながっている場合も含みます) +# 2: 対応するエラーメッセージ付きの NOTICE に変換して、 +# クライアントに投げます。 +# multi-server-mode 時のデフォルトは 0 、 single-server-mode 時のデフォルトは 1 です。 +-nick-fix-mode: 0 + +messages { + # Tiarra が使用する、いくつかのメッセージを指定する。 + + quit { + # ネットワーク設定が変更され、再接続する場合の切断メッセージ + netconf-changed-reconnect: Server Configuration changed; reconnect + + # ネットワーク設定が変更され、切断する場合の切断メッセージ + netconf-changed-disconnect: Server Configuration changed; disconnect + } +} +=cut + +* networks +package networks; +=pod +info: Tiarraから接続するネットワークの定義、その他 +info-is-omitted: 1 +no-switch: 1 + +# 複数のサーバーへの接続を可能にするかどうか。1(オン)と0(オフ)で指定。 +# これを1にすると、次のnameを複数個定義する事が可能になり、 +# 複数のサーバーに同時に接続出来るようになります。 +# その一方、これを1にしている時は、チャンネル名にネットワーク名が付加される等、 +# IRCの大部分のメッセージがTiarraによる改変を受けます。 +# これを0にしている間は、次のnameを複数個定義する事は出来なくなります。 +# マルチサーバーモードの設定を起動中に変えると、クライアントから見たチャンネル名が +# 変更になる為、全クライアントが一時的に全てのチャンネルからpartしたように見え、 +# その直後にjoinし直したように見えます。 +# デフォルトでは1です。 +multi-server-mode: 1 + +# 接続するIRCネットワークに名前を付けます。この名前は後で使用します。 +# 複数のネットワークに接続したい場合は多重定義して下さい。 +name: ircnet +name: 2ch + +# 通常Tiarraではチャンネル名を「#Tiarra@ircnet」のように表現します。 +# これはネットワークircnet内の#Tiarraというチャンネルを表わします。 +# @以降は省略可能ですが、省略された場合のデフォルトのネットワーク名をここで指定します。 +# 省略した場合は最も始めに定義されたnameがデフォルトになります。 +# (そしてnameが一つも無かった場合はmainがデフォルトになります) +-default: ircnet + +# 上に述べた通り、デフォルトではTiarraはチャンネル名とネットワーク名を@で区切ります。 +# この区切り文字は任意の文字に変更する事が出来ます。省略された場合は@になります。 +# +# System::PrivTranslator モジュールを利用している場合、 prefix の nick 部分にも +# 利用されます。そのため、 ! や @ を含む文字列を利用するとクライアントが誤作動する +# 場合がありますので注意してください。 +channel-network-separator: @ + +# 接続先のサーバーから切断された時に、joinしていたそのサーバーのチャンネルをどうするか。 +# 1. "part-and-join"の場合は、切断されるとクライアントにはチャンネルからpartしたように見せ掛け、 +# 再接続に成功すると再びjoinしたように見せ掛ける。最も負荷が高い。(これはplumに似た動作である) +# 2. "one-message"の場合は、切断されるとクライアントに宛ててTiarraがNOTICEでその旨を報告する。 +# 再接続に成功すると再びNOTICEで報告する。JOINやPARTはしないので、 +# クライアントからはまだそのチャンネルに残っているかのように見える。 +# 3. "message-for-each"の場合は、切断されるとクライアントに宛ててTiarraが +# 到達不能になった全てのチャンネルにNOTICEでその旨を報告する。 +# 再接続に成功すると再びNOTICEで報告する。JOINやPARTはしない。 +# デフォルトはpart-and-joinです。 +action-when-disconnected: message-for-each + +# NICKを変更する度に、変更したサーバーでの新しいNICKをNOTICEで常に通知するかどうか。 +# 1なら必ず通知し、0なら変更後のnickがローカルnick(クライアントが見る事の出来るnick)と違っている場合のみ通知する。 +# デフォルトは0です。 +always-notify-new-nick: 0 + +fixed-channels { + # Tiarra がクライアント接続時にチャンネル情報を送る順番を指定する。 + # マッチしなかったチャンネルについては最後にまとめて + # (順番がごちゃごちゃになって)送られてきます。 + channel: #てすとちゃんねる@ircnet + channel: #てすと@localserver + channel: *@localserver + channel: *@localserver:*.jp +} +=cut + + +* ircnet +package ircnet; +=pod +info: ネットワーク定義例 (IRCnet) +info-is-omitted: 1 +no-switch: 1 + +# サーバーのホストとポート。省略不可。 +host: irc.nara.wide.ad.jp +port: 6663 + +# general/userで設定したユーザ名を使わずに、各ネットワークで独自のユーザ名を使用する事も可能。 +# 省略されたら当然、general/userで設定したものが使われる。 +-user: hoge + +# general/nameで設定した本名(建前上)を使わずに、各ネットワークで独自の本名を使用可能。 +-name: hoge + +# このサーバーの要求するパスワード。省略可能。 +-password: hoge + +# general/setver-in/out-encodingで設定したエンコーディングを使わずに、 +# 各ネットワークで独自のエンコーディングを使用する事も可能。 +# 省略されたら当然、generalで設定したものが使われる。 +-in-encoding: jis +-out-encoding: jis + +# general/(ipv4|ipv6)bind-addrで設定したローカルアドレスを使わずに、 +# 各ネットワークで独自のbind_addrを使用する事も可能。 +# 省略されたらgeneralで設定したものが使われる。 +-ipv4-bind-addr: 0.0.0.0 +-ipv6-bind-addr: ::0 +=cut + +* 2ch +package 2ch; +=pod +info: ネットワーク定義例 (2ch) +info-is-omitted: 1 +no-switch: 1 + +host: irc.2ch.net +port: 6667 +=cut diff -urN /non-existant-dir/doc-src/contents.html tiarra-20080510/doc-src/contents.html --- /non-existant-dir/doc-src/contents.html 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/doc-src/contents.html 2008-05-11 00:25:26.000000000 +0900 @@ -0,0 +1,44 @@ + + + + + + + <&group-name> 関係のモジュール - Tiarra Documentation + + + +
+

<&group-name> 関係のモジュール

+
+ +
+ +
+ +
+

<&content-name>

+ <&description>
+
+ <&content> +
+
+ + +
+ + +
+ +
+ +
+ + diff -urN /non-existant-dir/doc-src/module-group.tdoc tiarra-20080510/doc-src/module-group.tdoc --- /non-existant-dir/doc-src/module-group.tdoc 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/doc-src/module-group.tdoc 2008-05-11 00:25:26.000000000 +0900 @@ -0,0 +1,62 @@ +-*- outline -*- +$Id: module-group.tdoc 11365 2008-05-10 14:58:28Z topia $ + +各モジュールの分類名(= グループ名)と、その説明。 +グループ名とは、モジュール名のm/^(.+?)::/で与えられる部分を指す。 + +この分類表で定義されていないモジュールは、グループ `UNCLASSIFIED' に属するものと見做される。 + +* Auto +package Auto; +=pod +description: 自動反応 +=cut + +* Channel +package Channel; +=pod +description: チャンネルに対する操作 +=cut + +* Client +package Client; +=pod +description: クライアントとの入出力 +=cut + +* CTCP +package CTCP; +=pod +description: CTCP 関連 +=cut + +* Debug +package Debug; +=pod +description: Tiarraや、Tiarraモジュールのデバッグ用 +=cut + +* Log +package Log; +=pod +description: ログの記録 +=cut + +* System +package System; +=pod +description: Tiarra自身の動作に関するもの +=cut + +* User +package User; +=pod +description: 特定の人間に対する動作や自分自身についての動作 +=cut + +* UNCLASSIFIED +package UNCLASSIFIED; +=pod +description: 未分類のモジュール +=cut + diff -urN /non-existant-dir/doc-src/module-toc.html tiarra-20080510/doc-src/module-toc.html --- /non-existant-dir/doc-src/module-toc.html 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/doc-src/module-toc.html 2008-05-11 00:25:26.000000000 +0900 @@ -0,0 +1,29 @@ + + + + + + + モジュール一覧 - Tiarra Documentation + + + + +

モジュール一覧

+ + + + diff -urN /non-existant-dir/doc-src/sample.conf.in tiarra-20080510/doc-src/sample.conf.in --- /non-existant-dir/doc-src/sample.conf.in 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/doc-src/sample.conf.in 2008-05-11 00:25:26.000000000 +0900 @@ -0,0 +1,114 @@ +# -*- tiarra-conf -*- +# ----------------------------------------------------------------------------- +# $Id: sample.conf.in 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +# tiarra.conf サンプル +# +# tiarraは起動時に全ての設定をこのファイルから取得します。 +# このファイルの文字コードは任意ですが、改行コードはLFもしくはCRLFでなければなりません。 +# +# 半角の#で始まる行はコメントとして無視されます。 +# 行の途中に#を置いた場合はコメントにはなりません。 +# +# 設定行は「設定名 : 値」の形式で指定されます。 +# 行の先頭及び末尾、コロンの前後の空白は無視されます。 +# +# 特に指定が無い場合、同じ設定を二度以上繰り返した時は最初に定義された設定が有効になります。 +# +# ブロックごと省略した場合は、そのブロックの全ての値が省略されたものとみなします。 +# ただし省略不可能な設定もありますので御注意下さい。 +# +# 「@include foo.conf」という行があると、foo.confがその場所に +# 挿入されたかのように処理します。 +# +# {}記号の位置には、それなりの自由度があります。 +# 次の例は全て有効です。 +# block { +# foo: bar +# } +# +# block {} +# +# block +# {} +# +# 次の例は全て無効です。 +# block {foo: bar} +# +# block +# {foo: bar} +# +# block { +# foo: bar} +# +# block +# {foo: bar +# } +# ----------------------------------------------------------------------------- + +# ----------------------------------------------------------------------------- +# generalブロック +# +# tiarra.conf自身の文字コードやユーザー情報などを指定するブロックです。 +# ----------------------------------------------------------------------------- +<&general> + +# ----------------------------------------------------------------------------- +# networksブロック +# +# Tiarraから接続するIRCネットワークの名称です。 +# 一つも定義しなかった場合やこのブロックを省略した場合は、 +# "main"というネットワークが一つだけ指定されたものと見做します。 +# ----------------------------------------------------------------------------- +<&networks> + +# ----------------------------------------------------------------------------- +# 各ネットワークの設定 +# +# networksブロックで定義した全てのネットワークについて、 +# そのアドレス、ポート、(必要なら)パスワードを定義します。 +# ----------------------------------------------------------------------------- +<&ircnet> + +<&2ch> + +# ----------------------------------------------------------------------------- +# 必須の設定は以上です。以下はモジュール(プラグイン)の設定です。 +# ----------------------------------------------------------------------------- + +# +または-で始まる行はモジュール設定行と見做されます。 +# +で記述されたモジュールが使用され、-で記述されたモジュールは使用されません。 +# +や-の後の空白は幾つあっても無視されます。 + +# メッセージが各モジュールを通過する順番は、このconfファイルで記述された +# 順番の通りになります。ログを取るモジュールなどはconfでも後の方に +# 記述した方が良いということになります。 + +# モジュール名はperlのそれと同じようにディレクトリ区切り文字を「::」としたパスで表現されます。 +# 例えばモジュールChannel::Auto::Operの実体はファイルmodule/Channel/Auto/Oper.pm +# でなければならず、そのpackage宣言もChannel::Auto::Operでなければなりません。 +# Tiarraモジュールの名称は、perl標準モジュール群やmain/下の.pmファイルと重複しないように +# 気を付けて下さい。Tiarraはモジュールが本当にModuleのサブクラスかどうかをチェックするので +# 例えばIO::Socket::INETといったモジュールを置いても誤動作はしませんが、 +# そのようなモジュールはロード時にエラーを出して使用中止になります。 + +# 一つのモジュールを複数回定義して、何度も同じモジュールをメッセージが通過するようには出来ません。 + +# 幾つかのモジュールはパラメータとしてチャンネル名を必要とします。 +# ここで指定するチャンネル名は、ネットワーク名も含めた文字列でなければなりません。 +# 「#チャンネル」では駄目で「#チャンネル@ネットワーク」などとする必要があります。 + +# マスクの書式: +# ['+' / '-'] ( <マスク文字列> / "re:" 正規表現 ) +# これはカンマで幾つでも継ぐ事が出来ます。"\,"でカンマそのものを表します。 +# 先頭が+なら、それに続く部分にマッチするものが選ばれ、-なら除外されます。省略されたら+と見做されます。 +# マスク文字列とは"*"で0文字以上の任意の文字列を、"?"で1文字の任意の文字列を表す文字列です。 +# 例: +# tiarra* これはtiarraで始まる文字列を表す。 +# +*!*tiarra@*.jp,-re:\d これは*!*tiarra@*.jpにマッチして、かつ文字列中に数字を含まないものを表す。 + +# このファイルには重要と思われるいくつかのモジュールしかありません。 +# そのほかのモジュールについては、 all.conf から設定をコピーしてきてください。 + +<&module> + diff -urN /non-existant-dir/main/BulletinBoard.pm tiarra-20080510/main/BulletinBoard.pm --- /non-existant-dir/main/BulletinBoard.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/main/BulletinBoard.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,55 @@ +# ----------------------------------------------------------------------------- +# $Id: BulletinBoard.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +# モジュール間の情報伝達に使われるクラス。 +# インスタンスは共有される。 +# ----------------------------------------------------------------------------- +package BulletinBoard; +use strict; +use warnings; +our $AUTOLOAD; +use Tiarra::SharedMixin; +our $_shared_instance; + +sub _new { + my $class = shift; + my $obj = { + table => {}, + }; + bless $obj,$class; +} + +sub set { + my ($class_or_this,$key,$value) = @_; + my $this = $class_or_this->_this; + $this->{table}->{$key} = $value; + $this; +} + +sub get { + my ($class_or_this,$key) = @_; + my $this = $class_or_this->_this; + $this->{table}->{$key}; +} + +sub keys { + keys %{shift->_this->{table}}; +} + +sub AUTOLOAD { + # $board->foo_bar => $board->get('foo-bar') + # $board->foo_bar('foo') => $board->set('foo-bar','foo'); + my ($class_or_this,$newvalue) = @_; + my $this = $class_or_this->_this; + (my $key = $AUTOLOAD) =~ s/.+?:://g; + $key =~ s/_/-/g; + + if (defined $newvalue) { + $this->set($key,$newvalue); + } + else { + $this->get($key); + } +} + +1; diff -urN /non-existant-dir/main/CTCP.pm tiarra-20080510/main/CTCP.pm --- /non-existant-dir/main/CTCP.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/main/CTCP.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,140 @@ +# ----------------------------------------------------------------------------- +# $Id: CTCP.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +# IRCMessage中からCTCPメッセージを取り出したり、CTCPメッセージを持つIRCMessageを作ったり。 +# ----------------------------------------------------------------------------- +package CTCP; +use strict; +use warnings; +use Carp; +use UNIVERSAL; +use base qw(Tiarra::IRC::NewMessageMixin); + +#use SelfLoader; +#SelfLoader->load_stubs; +#1; +#__DATA__ + +sub extract { + # PRIVMSGかNOTICEであるIRCMessageにCTCPメッセージが埋め込まれていたら、それを取り出して返す。 + # '\x01CTCP VERSION\x01\x01CTCP USERINFO\x01'のように一つのメッセージ中に複数のCTCPメッセージが含まれていた場合は、 + # スカラーコンテクストなら最初に見付かったものだけを返し、配列コンテクストなら見付かったもの全てを返す。 + # CTCPメッセージを取り出せなかった場合は、undef(スカラー)または空配列(配列)を返す。 + my $msg = shift; + + if (!defined $msg) { + croak "CTCP::extract, Arg[0] is undef.\n"; + } + if (!UNIVERSAL::isa($msg, __PACKAGE__->irc_message_class)) { + croak "CTCP::extract, Arg[0] is bad ref: ".ref($msg)."\n"; + } + + if ($msg->command eq 'PRIVMSG' || $msg->command eq 'NOTICE') { + __PACKAGE__->extract_from_text($msg->param(1)); + } +} + +sub make { + # CTCPメッセージを含むTiarra::IRC::Messageを作って返す。 + # + # $message: 含めるCTCPメッセージ + # $target : 作るTiarra::IRC::Messageの最初のパラメータ。nickやチャンネル名を入れる。 + # $command: PRIVMSGとNOTICEのうち、どちらのコマンドで作るか。省略された場合はNOTICEになる。 + my ($message,$target,$command) = @_; + + if (!defined $target) { + croak "CTCP::make, Arg[1] is undef.\n"; + } + if (!defined $command) { + $command = 'NOTICE'; + } + + my $result = __PACKAGE__->construct_irc_message( + Command => $command, + Params => [$target, + __PACKAGE__->make_text($message), + ]); + + $result; +} + +sub _low_level_dequote { + my ($symbol) = @_; + + if ($symbol eq '0') { + return "\x00"; + } elsif ($symbol eq 'n') { + return "\x0a"; + } elsif ($symbol eq 'r') { + return "\x0d"; + } elsif ($symbol eq "\x10") { + return "\x10"; + } else { + # error, but return. + return $symbol; + } +} + +sub _ctcp_level_dequote { + my ($symbol) = @_; + + if ($symbol eq 'a') { + return "\x01"; + } elsif ($symbol eq "\x5c") { + return "\x5c"; + } else { + # error, but return. + return $symbol; + } +} + +sub dequote { + shift; # drop + local $_ = shift; + + # 2nd Level + s/\x10(.)/_low_level_dequote($1)/eg; + + # 1st Level + s/\x5c(.)/_ctcp_level_dequote($1)/eg; + + $_; +} + +sub extract_from_text { + my $this = shift; + grep { + if (!wantarray) { + return $_; + } + 1; + } map { + $this->dequote($1); + } (shift =~ m/\x01(.*)\x01/g); +} + +sub quote { + shift; # drop + local $_ = shift; + # 1st Level + s/\x5c/\x5c\x5c/g; + s/\x01/\x5ca/g; + + # 2nd Level + s/\x10/\x10\x10/g; + s/\x00/\x100/g; + s/\x0a/\x10n/g; + s/\x0d/\x10r/g; + + $_; +} + +sub make_text { + my $this = shift; + my @ctcps = map { + "\x01" . $this->quote($_) . "\x01"; + } @_; + return wantarray ? @ctcps : join('', @ctcps); +} + +1; diff -urN /non-existant-dir/main/ChannelInfo.pm tiarra-20080510/main/ChannelInfo.pm --- /non-existant-dir/main/ChannelInfo.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/main/ChannelInfo.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,218 @@ +# ----------------------------------------------------------------------------- +# $Id: ChannelInfo.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +# チャンネル情報を保持 +# ----------------------------------------------------------------------------- +package ChannelInfo; +use strict; +use warnings; +use Carp; +use PersonInChannel; +use Multicast; +our $AUTOLOAD; + +sub new { + # nameに鯖名まで付けないように注意。#channel@ircnetはNG。 + my ($class,$name,$network_name) = @_; + my $obj = { + name => $name, + network_name => $network_name, + topic => '', + topic_who => undef, + topic_time => undef, + names => undef, # hash; nick => PersonInChannel + switches => undef, # hash; aやsなどのチャンネルモード。キーがaやsで、値は常に1。 + parameters => undef, # hash; lやkなどのチャンネルモード。 + banlist => undef, # array; +bリスト。知らなければ空。 + exceptionlist => undef, # array; +eリスト。知らなければ空。 + invitelist => undef, # array; +Iリスト。知らなければ空。 + remarks => undef, # hash; Tiarraが内部的に使用する備考。 + }; + + unless (defined $name) { + croak "ChannelInfo->new requires name parameter.\n"; + } + + bless $obj,$class; +} + +sub equals { + # チャンネル名とサーバーが同じなら真。 + my ($this,$ch) = @_; + defined $ch && $this->name eq $ch->name && + $this->network_name eq $ch->network_name; +} + +sub fullname { + # サーバー名を付けて返す。 + my $this = shift; + scalar Multicast::attach($this->name,$this->network_name); +} + +sub mode_string { + # RPL_CHANNELMODEIS の形式で返す。 + my $this = shift; + + my $str = '+'; + my @param; + my ($checker, %hash); + + # switches + $checker = sub { + my $key = shift; + if ($hash{$key}) { + $str .= $key; + delete $hash{$key} + } + }; + + %hash = %{$this->switches}; + map { + $checker->($_); + } split //, 'spmtinaqr'; + map { + $checker->($_); + } keys %hash; + + # parameters + %hash = %{$this->parameters}; + $checker = sub { + my $key = shift; + if ($hash{$key}) { + $str .= $key; + push(@param, $hash{$key}); + delete $hash{$key} + } + }; + map { + $checker->($_); + } split //, 'lk'; + map { + $checker->($_); + } keys %hash; + + return ($str, @param); +} + +my $types = { + topic => 'scalar', + topic_who => 'scalar', + topic_time => 'scalar', + names => 'hash', + switches => 'hash', + parameters => 'hash', + banlist => 'array', + exceptionlist => 'array', + invitelist => 'array', + remarks => 'hash', +}; +sub remarks; +*remark = \&remarks; # remarkはremarksのエイリアス。 +sub AUTOLOAD { + my ($this,@args) = @_; + (my $key = $AUTOLOAD) =~ s/^.+?:://g; + + if ($key eq 'DESTROY') { + return; + } + + if ($key eq 'name' || $key eq 'network_name') { + return $this->{$key}; + } + + my $type = $types->{$key}; + if (!defined($type)) { + croak "ChannelInfo doesn't have the parameter $key\n"; + } + + if ($type eq 'scalar') { + # $info->topic; + # $info->topic('NEW-TOPIC'); + if (defined $args[0]) { + $this->{$key} = $args[0]; + } + return $this->{$key}; + } + elsif ($type eq 'hash') { + # $info->names; + # $info->names('saitama'); + # $info->names('saitama',$person); + # $info->names('saitama',undef,'delete'); + # $info->names(undef,undef,'clear'); + # $info->names(undef,undef,'size'); + # $info->names(undef,undef,'keys'); + # $info->names(undef,undef,'values'); + my $hash = $this->{$key}; + + if (!defined $args[0] && !defined $args[2]) { + # HASH*を返す。 + $this->{$key} = $hash = {} if !$hash; + return $hash; + } + + if (defined $args[1]) { + $this->{$key} = $hash = {} if !$hash; + $hash->{$args[0]} = $args[1]; + } + if (defined $args[2]) { + if ($args[2] eq 'delete') { + delete $hash->{$args[0]} if $hash; + } + elsif ($args[2] eq 'clear') { + $this->{$key} = undef; + } + elsif ($args[2] eq 'size') { + return $hash ? scalar(keys %$hash) : 0; + } + elsif ($args[2] eq 'keys') { + return $hash ? keys %$hash : (); + } + elsif ($args[2] eq 'values') { + return $hash ? values %$hash : (); + } + else { + croak '[hash]->([key],[value],'.$args[2].") is invalid\n"; + } + } + return ($hash and $args[0]) ? $hash->{$args[0]} : undef; + } + elsif ($type eq 'array') { + # $info->banlist; + # $info->banlist('set','a!*@*','b!*@*','c!*@*'); + # $info->banlist('add','*!*@*.hoge.net'); + # $info->banlist('delete','*!*@*.hoge.net'); + my $array = $this->{$key}; + if (@args == 0) { + # ARRAY*を返す。 + $this->{$key} = $array = [] if !$array; + return $array; + } + + if ($args[0] eq 'set') { + $this->{$key} = $array = [] if !$array; + @$array = @args[1 .. $#args]; + } + elsif ($args[0] eq 'add') { + croak "'add' requires a value to add\n" unless defined $args[1]; + $this->{$key} = $array = [] if !$array; + push @$array,$args[1]; + } + elsif ($args[0] eq 'delete') { + croak "'delete' requires a value to remove\n" unless defined $args[1]; + if ($array) { + for (my $i = 0; $i < @$array; $i++) { + if ($array->[$i] eq $args[1]) { + splice @$array,$i,1; + $i--; + } + } + } + } + else { + croak "invalid command '".$args[0]."'\n"; + } + return $this; + } +} + +1; diff -urN /non-existant-dir/main/Configuration/Block.pm tiarra-20080510/main/Configuration/Block.pm --- /non-existant-dir/main/Configuration/Block.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/main/Configuration/Block.pm 2008-05-11 00:25:24.000000000 +0900 @@ -0,0 +1,262 @@ +# ----------------------------------------------------------------------------- +# $Id: Block.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +package Configuration::Block; +use strict; +use warnings; +use vars qw($AUTOLOAD); +use UNIVERSAL; +use Tiarra::Encoding; +use Tiarra::DefineEnumMixin qw(BLOCK_NAME TABLE); +use Tiarra::Utils; +# 値を取得するにはgetメソッドを用いる他、エントリ名をそのままメソッドとして呼ぶ事も出来ます。 +# +# $block->hoge; +# これでパラメータhogeの値を返す。hogeが未定義ならundef値を返す。 +# hogeの値が一つだけだったらそれを返すが、複数の値が存在したらその先頭の値だけを返す。 +# 値もブロックだったら、そのブロックを返す。 +# +# $block->hoge('all'); +# パラメータhogeの全ての値を配列で返す。hogeが未定義なら空の配列を返す。 +# 値が一つしか無ければ値が一つの配列を返す。 +# +# $block->foo_bar; +# $block->foo_bar('all'); +# パラメータ"foo-bar"の値を返す。"foo_bar"ではない！ +# +# $block->foo('random'); +# パラメータfooに複数の定義があれば、そのうちの一つをランダムに返す。 +# 一つも無ければundefを返す。 +# +# $block->foo_bar('block'); +# $block->get('foo-bar', 'block'); +# パラメータ"foo-bar"の値が未定義である場合、undef値の代わりに +# 空のConfiguration::Blockを返す。 +# 定義されている場合、その値がブロックであればそれを返すが、 +# そうでなければ "foo-bar: その値" の要素を持ったブロックを生成し、それを返す。 +# +# $block->get('foo_bar'); +# $block->get('foo_bar','all'); +# パラメータ"foo_bar"の値を返す。 +# +# 以上の事から、Configuration::Blockはnew,block_name,table,set,get, +# reinterpret-encoding,AUTOLOADといった属性はget()でしか読めない。 +# また、属性名にアンダースコアを持つ属性もget()でしか読めない。 + +sub new { + my ($class,$block_name) = @_; + my $obj = bless [] => $class; + $obj->[BLOCK_NAME] = $block_name; + $obj->[TABLE] = {}; # ラベル -> 値(配列リファもしくはスカラー) + $obj; +} + +Tiarra::Utils->define_array_attr_accessor(0, qw(block_name table)); + +sub equals { + # 二つのConfiguration::Blockが完全に等価なら1を返す。 + my ($this,$that) = @_; + # ブロック名 + if ($this->[BLOCK_NAME] ne $that->[BLOCK_NAME]) { + return undef; + } + # キーの数 + my @this_keys = keys %{$this->[TABLE]}; + my @that_keys = keys %{$that->[TABLE]}; + if (@this_keys != @that_keys) { + return undef; + } + # 各要素 + my $size = @this_keys; + for (my $i = 0; $i < $size; $i++) { + # キー + if ($this_keys[$i] ne $that_keys[$i]) { + return undef; + } + # 値の型 + my $this_value = $this->[TABLE]->{$this_keys[$i]}; + my $that_value = $that->[TABLE]->{$that_keys[$i]}; + if (ref($this_value) ne ref($that_value)) { + return undef; + } + # 値 + if (ref($this_value) eq 'ARRAY') { + # 配列なので要素数と全要素を比較。 + if (@$this_value != @$that_value) { + return undef; + } + my $valsize = @$this_value; + for (my $j = 0; $j < $valsize; $j++) { + if ($this_value->[$j] ne $that_value->[$j]) { + return undef; + } + } + } + elsif (UNIVERSAL::isa($this_value,'Configuration::Block')) { + # ブロックなので再帰的に比較。 + return $this_value->equals($that_value); + } + else { + if ($this_value ne $that_value) { + return undef; + } + } + } + return 1; +} + +sub eval_code { + # 渡された文字列中の、全ての%CODE{ ... }EDOC%を評価して返す。 + my ($this,$str) = @_; + + if (ref($str)) { + return $str; # 文字列でなかったらそのまま返す。 + } + + my $eval = sub { + my $script = shift; + no strict; no warnings; + my $result = eval "package Configuration::Implanted; $script"; + use warnings; use strict; + if ($@) { + die "\%CODE{ }EDOC\% interpretation error.\n". + "block: ".$this->[BLOCK_NAME]."\n". + "original: $str\n". + "$@\n"; + } + $result; + }; + (my $evaluated = $str) =~ s/\%CODE{(.*?)}EDOC\%/$eval->($1)/eg; + $evaluated; +} + +sub get { + my ($this,$key,$option) = @_; + + unless (exists $this->[TABLE]->{$key}) { + # そのような値は定義されていない。 + if ($option && $option eq 'all') { + return (); + } + elsif ($option and $option eq 'block') { + return Configuration::Block->new($key); + } + else { + return undef; + } + } + + my $value = $this->[TABLE]->{$key}; + if ($option && $option eq 'all') { + if (ref($value) eq 'ARRAY') { + return map { + $this->eval_code($_); + } @{$value}; # 配列リファなら逆参照して返す。 + } + else { + return $this->eval_code($value); + } + } + elsif ($option && $option eq 'random') { + if (ref($value) eq 'ARRAY') { + # 配列リファならランダムに選んで返す + return $this->eval_code( + $value->[int(rand(0xffffffff)) % @$value]); + } + else { + return $this->eval_code($value); + } + } + elsif ($option and $option eq 'block') { + if (ref($value) and UNIVERSAL::isa($value, 'Configuration::Block')) { + return $value; + } + else { + my $tmp_block = Configuration::Block->new($key); + $tmp_block->set($key, $value); + return $tmp_block; + } + } + else { + if (ref($value) eq 'ARRAY') { + return $this->eval_code($value->[0]); # 配列リファなら先頭の値を返す。 + } + else { + return $this->eval_code($value); + } + } +} + +sub set { + # 古い値があれば上書きする。 + my ($this,$key,$value) = @_; + $this->[TABLE]->{$key} = $value; + $this; +} + +sub add { + # 古い値があればそれに追加する。 + my ($this,$key,$value) = @_; + if (defined $this->[TABLE]->{$key}) { + # 定義済み。 + if (ref($this->[TABLE]->{$key}) eq 'ARRAY') { + # 既に複数の値を持っているのでただ追加する。 + push @{$this->[TABLE]->{$key}},$value; + } + else { + # 配列に変更する。 + $this->[TABLE]->{$key} = [$this->[TABLE]->{$key},$value]; + } + } + else { + # 定義済みでない。 + $this->[TABLE]->{$key} = $value; + } +} + +sub reinterpret_encoding { + # このブロックの全ての要素を指定された文字エンコーディングで再解釈する。 + # 再解釈後はUTF-8になる。 + my ($this,$encoding) = @_; + + my $unicode = Tiarra::Encoding->new; + my $newtable = {}; + while (my ($key,$value) = each %{$this->[TABLE]}) { + my $newkey = $unicode->set($key,$encoding)->utf8; + my $newvalue = do { + if (ref($value) eq 'ARRAY') { + # 配列なので中身を全てコード変換。 + my @newarray = map { + $unicode->set($_,$encoding)->utf8; + } @$value; + \@newarray; + } + elsif (UNIVERSAL::isa($value,'Configuration::Block')) { + # ブロックなので再帰的にコード変換。 + $value->reinterpret_encoding($encoding); + } + else { + $unicode->set($value,$encoding)->utf8; + } + }; + $newtable->{$newkey} = $newvalue; + } + + $this->[TABLE] = $newtable; + $this; +} + +sub AUTOLOAD { + my ($this,$option) = @_; + + if ($AUTOLOAD =~ /::DESTROY$/) { + # DESTROYは伝達させない。 + return; + } + + (my $key = $AUTOLOAD) =~ s/.+?:://g; + $key =~ s/_/-/g; + return $this->get($key,$option); +} + +1; diff -urN /non-existant-dir/main/Configuration/LexicalAnalyzer.pm tiarra-20080510/main/Configuration/LexicalAnalyzer.pm --- /non-existant-dir/main/Configuration/LexicalAnalyzer.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/main/Configuration/LexicalAnalyzer.pm 2008-05-11 00:25:24.000000000 +0900 @@ -0,0 +1,180 @@ +# ----------------------------------------------------------------------------- +# $Id: LexicalAnalyzer.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +# confファイルの字句解析器。 +# 文脈に応じてトークンを解析していく。 +# ----------------------------------------------------------------------------- +package Configuration::LexicalAnalyzer; +use strict; +use warnings; + +sub new { + # $body: 解析させる内容 + my ($class,$body) = @_; + my $this = { + body => $body, # トークンが解析される度に、解析されたトークンが消されていく。 + linecount => 0, # 現在どの行を解析しているか？この情報はエラー時にしか使われない。 + rollbackcount => 0, # 現在何行を読み過ぎているか？ + }; + bless $this; +} + +sub linecount { + shift->{linecount}; +} + +sub next { + # 次のトークンを得る。もう残っていなければundefを返す。 + # $context: 'outside' | 'block' + # + # outside: 今、ブロックの外側に居る事を示す。 + # block: 今、ブロック内に居る事を示す。 + # + # 戻り値: (トークン,タイプ) + # タイプとしては次のようなものがある。 + # 'label' => ブロックのラベル + # 'blockstart' => ブロックの始まり + # 'blockend' => ブロックの終わり + # 'pair' => キーと値のペア + my ($this,$context) = @_; + + my $method = "_context_$context"; + if ($this->can($method)) { + my ($token,$type) = eval { + $this->$method; + }; if ($@) { + die "Exception in analyzing token: line $this->{linecount}\n$@\n"; + } + ($token,$type); + } + else { + die "Illegal context: $context\n"; + } +} + +sub _context_outside { + my $this = shift; + + my $labelchar = qr{[^\s{}]}; # ブロック名として許される文字 + my $label = qr{^(?:(?:\+|\-)\s+)?$labelchar+}; # ブロックのラベル + + my $blockstart = qr|^{|; # ブロックの開始 + + my $line = $this->_nextline; + if (defined $line) { + my ($token,$type) = do { + if ($line =~ s/($label)//) { + ($1,'label'); + } + elsif ($line =~ s/($blockstart)//) { + ($1,'blockstart'); + } + else { + # 不正なトークン。 + die "Syntax error: $line\n"; + } + }; + # 必要なら残りの部分をロールバック + $this->rollback($line); + ($token,$type); + } + else { + undef; + } +} + +sub _context_block { + my $this = shift; + + my $keychar = qr{[^\s{}:]}; # キーとして許される文字 + my $pair = qr{^$keychar+\s*:.*$}; # キーと値のペア + + my $labelchar = qr{[^\s{}:]}; # ブロック内ブロックのラベルとして許される文字 + my $label = qr{^$labelchar+}; # ブロックのラベル + + my $blockstart = qr|^{|; # ブロックの開始 + my $blockend = qr|^}|; # ブロックの終了 + + my $line = $this->_nextline; + if (defined $line) { + my ($token,$type) = do { + if ($line =~ s/($pair)//) { + ($1,'pair'); + } + elsif ($line =~ s/($label)//) { + ($1,'label'); + } + elsif ($line =~ s/($blockstart)//) { + ($1,'blockstart'); + } + elsif ($line =~ s/($blockend)//) { + ($1,'blockend'); + } + else { + # 不正なトークン。 + die "Syntax error: $line\n"; + } + }; + # 必要なら残りの部分をロールバック + $this->rollback($line); + ($token,$type); + } + else { + undef; + } +} + +sub _nextline { + my $this = shift; + + while (1) { + if ($this->{body} eq '') { + # もう行が無い。 + return undef; + } + + # とりあえず先頭一行を取得。 + $this->{body} =~ s/^(.*?)(?:\n|$)//s; + my $line = $1; + + if (defined $line) { + # まだ行が残ってる。 + # 最初と最後の空白を除去。 + if ($this->{rollbackcount} > 0) { + # 読み過ぎているのでカウントしない。 + $this->{rollbackcount}--; + } + else { + $this->{linecount}++; + } + $line =~ s/^\s*|\s*$//g; + + # 空の行やコメント行なら飛ばして次へ。 + if ($line eq '' || $line =~ m/^#/) { + next; + } + else { + return $line; + } + } + else { + # もう行が無い。 + return undef; + } + } +} + +sub rollback { + my ($this,$line) = @_; + + # 最初と最後の空白を除去。 + $line =~ s/^\s*|\s*$//g; + + # まだ中身が残っていればカウンタごと書き戻す。 + if ($line ne '') { + $this->{body} = "$line\n$this->{body}"; + $this->{rollbackcount}++; + } +} + +1; diff -urN /non-existant-dir/main/Configuration/Parser.pm tiarra-20080510/main/Configuration/Parser.pm --- /non-existant-dir/main/Configuration/Parser.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/main/Configuration/Parser.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,126 @@ +# ----------------------------------------------------------------------------- +# $Id: Parser.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +# confファイルの構文解析を行なうクラス。 +# このクラスはConfiguration::LexicalAnalyzerを用いて字句解析を行ないます。 +# +# このクラスは文字コードを全く変換せずに結果を返します。 +# また、ブロック名については完全に無頓着です。 +# ----------------------------------------------------------------------------- +package Configuration::Parser; +use strict; +use warnings; +use Carp; +use Configuration::LexicalAnalyzer; +use Configuration::Block; + +sub new { + # $body: 解析する内容 + my ($class,$body) = @_; + my $this = { + lex => Configuration::LexicalAnalyzer->new($body), + + parsed => [], # Configuration::Block (現れた順番に並ぶ。) + }; + bless $this,$class; + + eval { + $this->_parse; + }; if ($@) { + die "(line ".$this->{lex}->linecount.") $@\n"; + } + $this; +} + +sub parsed { + shift->{parsed}; +} + +sub _parse { + my $this = shift; + + # block := LABEL BLOCKSTART blockcontent BLOCKEND + # blockcontent := pair | block + + while (1) { + my $block = $this->_parse_block('outside'); + if (defined $block) { + push @{$this->{parsed}},$block; + } + else { + last; + } + } + + $this; +} + +sub _parse_block { + my ($this,$context) = @_; + + my ($token,$type); + # block := LABEL BLOCKSTART blockcontent BLOCKEND + + ($token,$type) = $this->{lex}->next($context); + if (!defined $token) { + return undef; # もうブロックが無い。 + } + elsif ($type ne 'label') { + die "Semantics error: label of block is needed here.\n$token\n"; + } + my $block = Configuration::Block->new($token); + + ($token,$type) = $this->{lex}->next($context); + if (!defined $token || $type ne 'blockstart') { + $token = '' if !defined $token; + die "Semantics error: '{' is needed here.\n$token\n"; + } + + $this->_parse_blockcontent($block); + + ($token,$type) = $this->{lex}->next('block'); + if (!defined $token || $type ne 'blockend') { + $token = '' if !defined $token; + die "Semantics error: '}' is needed here.\n$token\n"; + } + + $block; +} + +sub _parse_blockcontent { + my ($this,$block) = @_; + + my ($token,$type); + # blockcontent := (pair | block)* + + while (1) { + ($token,$type) = $this->{lex}->next('block'); + if (!defined $token) { + die "Semantics error: pair, label or blockend is needed here.\n"; + } + elsif ($type eq 'pair') { + $token =~ m/^(.+?)\s*:\s*(.*)$/; + $block->add($1,$2); + } + elsif ($type eq 'label') { + # 読み過ぎたので戻す。 + $this->{lex}->rollback($token); + + # ブロックをパース。 + my $newblock = $this->_parse_block('block'); + $block->set($newblock->block_name,$newblock); + } + elsif ($type eq 'blockend') { + # 読み過ぎたので戻す。 + $this->{lex}->rollback($token); + + # ここで終わり。 + last; + } + else { + die "Semantics error: pair, label or blockend is needed here.\n$token\n"; + } + } +} + +1; diff -urN /non-existant-dir/main/Configuration/Preprocessor.pm tiarra-20080510/main/Configuration/Preprocessor.pm --- /non-existant-dir/main/Configuration/Preprocessor.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/main/Configuration/Preprocessor.pm 2008-05-11 00:25:24.000000000 +0900 @@ -0,0 +1,343 @@ +# ----------------------------------------------------------------------------- +# $Id: Preprocessor.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +# tiarraのconfファイルのプリプロセッサです。 +# このクラスは次のような機能を持ちます。 +# +# ・"%PRE{"と"}ERP%"に挟まれた部分をperlの文として評価し、結果をその場所に挿入する。 +# +# ・@include ファイル名 +# このような行を、そのファイルの中身と置き換える。 +# +# ・@define 文字列A 文字列B +# このような行の後からは、ファイル中の文字列Aを全て文字列Bに置き換える。 +# 置換される場所はどこであっても構わない。例えば次のような定義は有効である。 +# @define DEBUG 1 +# @if 'DEBUG' == '1' +# debug: a +# @endif +# 例外は@undef, @ifdef, @ifndef文。これらの文に対しては置換が行なわれない。 +# +# ・@undef 文字列A +# @defineで定義した置換を、次の行からキャンセルする。 +# +# ・@if 式 +# ・@elsif +# 式をperlの文として評価し、結果が真なら@elsif、@else、@endifまでを有効な行とみなす。 +# if-elsif-else-endif構文は幾らでも入れ子にする事が出来る。 +# +# ・@else +# ・@endif +# 説明は不要であろう。 +# +# ・@ifdef 文字列 +# ・@ifndef 文字列 +# その文字列が@defineされていたら、若しくはされていなかったら。 +# +# ・@message 文字列 +# 標準出力にその文字列を出す。但し文字コードの変換は一切行われないので +# ASCII文字以外を出すのはやめた方が良い。 +# +# ----------------------------------------------------------------------------- +# 先に%PRE{ }ERP%が評価され、次に@文が評価される。 +# %PRE{ }ERP%は複数の行に渡っても良い。 +# ----------------------------------------------------------------------------- +package Configuration::Preprocessor; +use strict; +use warnings; +use Carp; +use IO::File; +use UNIVERSAL; +our %initial_definition; + +sub preprocess { + # IO::Handleまたはファイル名を一つ取り、プリプロセスの結果を返す。 + my $handle = shift; + + Configuration::Preprocessor + ->new + ->execute($handle); +} + +sub new { + my ($class,$filename) = @_; + my $this = { + included => {}, # ファイルパス => 1 (多重includeのチェックに使われる。) + consts => {%initial_definition}, # @defineされたマクロ名 => 中身 + }; + bless $this,$class; +} + +sub included_files { + my ($this) = shift; + return keys(%{$this->{included}}); +} + +sub initial_define { + my ($key, $value) = @_; + $initial_definition{$key} = $value; +} + +sub defined_p { + my ($this, $key) = @_; + defined $this->{consts}{$key}; +} + +sub execute { + my ($this,$filename) = @_; + + my $result = eval { + $this->_execute($filename); + }; + if ($@) { + my $fname = do { + if (ref($filename) && UNIVERSAL::isa($filename,'IO::Handle')) { + "HANDLE(".$filename->fileno.")"; + } + else { + $filename; + } + }; + die "Exception in preprocessing $fname:\n$@\n"; + } + + $result; +} + +sub _execute { + my ($this,$filepath) = @_; + + my $handle = do { + if (!defined $filepath) { + croak "Configuration::Preprocessor->_execute, Arg[1] was undef.\n"; + } + elsif (ref($filepath) && UNIVERSAL::isa($filepath,'IO::Handle')) { + # IO::Handleだった。 + # 重複チェックは不可能。 + $filepath; + } + else { + if (exists $this->{included}->{$filepath}) { + die "$filepath has already loaded or included before.\n"; + } + else { + $this->{included}->{$filepath} = 1; + } + + my $fh = IO::File->new($filepath,'r'); + if (!defined $fh) { + die "Couldn't open $filepath to read.\n"; + } + $fh; + } + }; + + # ファイルを先頭から最後まで読む。 + my $body = ''; + foreach (<$handle>) { + tr/\r\n//d; + $body .= "$_\n"; + } + undef $handle; + + # %PRE{ }ERP% 置換 + $body = $this->_eval_pre($body); + + # 一行ずつ読んで@指令を処理。 + $body = $this->_eval_at($body); + + $body; +} + +sub _eval_pre { + my ($this,$body) = @_; + + my $evaluate = sub { + my $script = shift; + no strict; no warnings; + my $result = eval "package Configuration::Implanted; $script"; + use warnings; use strict; + if ($@) { + my $short = substr $script,0,50; + $short =~ tr/\n//d; + $short =~ s/^\s*|\s*$//g; + die "Exception in evaluating %PRE{ }ERP% block\nlike '$short'\n$@\n"; + } + defined $result ? $result : ''; + }; + $body =~ s/\%PRE{(.+?)}ERP\%/$evaluate->($1)/seg; + $body; +} + +sub _eval_at { + my ($this,$body) = @_; + + my @ifstack = (); # 次にif,elsif,else,endifが来るまでの動作(真なら残し、偽なら消す) + + my $result = ''; + foreach my $line (split /\n/,$body) { + # この行が@undef,@ifdef,@ifndef文でないなら、@defineされた全ての置換を実行。 + if ($line !~ m/^\s*\@\s*(?:undef|ifdef|ifndef)\s+/) { + while (my ($key,$value) = each %{$this->{consts}}) { + $line =~ s/\Q$key\E/$value/g; + } + } + + if (@ifstack > 0) { + # if文のブロック内である。 + my $action = $ifstack[@ifstack - 1]; + + if ($line =~ m/^\s*\@\s*(?:if|elsif|ifdef|ifndef|else|endif)/) { + # 状態が変わる可能性がある。 + # とりあえず何もしない。 + } + else { + # 状態は変わらない。 + # 捨てる必要があるなら捨てて次へ。 + if (!$action) { + next; + } + } + } + + if ($line =~ m/^\s*\@/) { + # @で始まっている。 + # とりあえず先頭の@を取って最初と最後の\sがあれば消す。 + $line =~ s/^\s*\@\s*|\s*$//g; + + # ifdefとifndefはif文に書換える + if ($line =~ m/^ifdef\s+(.+)$/) { + $line = q{if $this->defined_p(q@}.$1.q{@)}; + } + elsif ($line =~ m/^ifndef\s+(.+)$/) { + $line = q{if !$this->defined_p(q@}.$1.q{@)}; + } + + if ($line =~ m/^include\s+(.+)$/) { + $result .= $this->execute($1); + } + elsif ($line =~ m/^define\s+(.+?)(?:\s+(.+))?$/) { + my $key = $1; + my $value = (defined $2 ? $2 : ''); + + if (defined $this->{consts}->{$key}) { + die "$key has already been \@defined before.\n"; + } + $this->{consts}->{$key} = $value; + } + elsif ($line =~ m/^undef\s+(.+)$/) { + if (!defined $this->{consts}->{$1}) { + die "$1 has not been \@defined.\n"; + } + delete $this->{consts}->{$1}; + } + elsif ($line =~ m/^message\s+(.+)$/) { + print "$1\n"; + } + elsif ($line =~ m/^if\s+(.+)$/) { + if (@ifstack > 0 && !$ifstack[@ifstack - 2]) { + # 下のフレームが存在し、一つ下のフレームのアクションが'消す'なら、無条件に消す。 + push @ifstack,0; + } + else { + # 評価結果が真なら、次にif,elsif,else,endifが出てくるまで残す。偽ならそれらが出るまで消す。 + my $cond_evaluated = eval(defined $1 ? $1 : ''); + if ($@) { + die "Exception in evaluating: \@$line\n$@\n"; + } + push @ifstack,$cond_evaluated; + } + } + elsif ($line =~ m/^elsif\s+(.+)$/) { + # elsifは新たにifフレームを追加する事はせず、現在のフレームに上書きする。 + # + # 現在のフレームのアクションが'残す'だった場合... + # if,elsif,else,endifが出てくるまで無条件に消す。 + # + # '消す'だった場合... + # 真ならif,elsif,else,endifが出てくるまで残す。偽ならそれらが出るまで消す。 + # + # 但し、現在のフレームがトップレベルでなかった場合で、 + # その下のレベルのアクションが'消す'だった場合は、無条件に消す。 + if (@ifstack > 1 && !$ifstack[@ifstack - 2]) { + pop @ifstack; + push @ifstack,0; + } + else { + if (@ifstack > 0) { + if ($ifstack[@ifstack - 1]) { + pop @ifstack; + push @ifstack,0; + } + else { + my $cond_evaluated = eval(defined $1 ? $1 : ''); + if ($@) { + die "Exception in evaluating: \@$line\n$@\n"; + } + pop @ifstack; + push @ifstack,$cond_evaluated; + } + } + else { + die "\@elsif without \@if block.\n"; + } + } + } + elsif ($line =~ m/^else$/) { + # elseは新たにifフレームを追加することはせず、現在のフレームに上書きする。 + # + # 現在のフレームのアクションが'残す'だった場合... + # if,elsif,else,endifが出てくるまで無条件に消す。 + # + # '消す'だった場合... + # if,elsif,else,endifが出てくるまで無条件に残す。 + # + # 但し、現在のフレームがトップレベルでなかった場合で、 + # その下のレベルのアクションが'消す'だった場合は、無条件に消す。 + if (@ifstack > 1 && !$ifstack[@ifstack - 2]) { + pop @ifstack; + push @ifstack,0; + } + else { + if (@ifstack > 0) { + if ($ifstack[@ifstack - 1]) { + pop @ifstack; + push @ifstack,0; + } + else { + pop @ifstack; + push @ifstack,1; + } + } + else { + die "\@else without \@if block.\n"; + } + } + } + elsif ($line =~ m/^endif$/) { + if (@ifstack > 0) { + # このifブロックを終了する。 + pop @ifstack; + } + else { + die "\@endif without \@if block.\n"; + } + } + else { + die "Invalid @ command: \@$line\n"; + } + } + else { + $result .= "$line\n"; + } + } + + # 最終的に@ifstackが空になっていないという事は、@ifブロックが終わっていないという事。 + if (@ifstack > 0) { + die "There's \@if block which is not terminated.\n" + } + + $result; +} + +1; diff -urN /non-existant-dir/main/Configuration.pm tiarra-20080510/main/Configuration.pm --- /non-existant-dir/main/Configuration.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/main/Configuration.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,358 @@ +# ----------------------------------------------------------------------------- +# $Id: Configuration.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +# このクラスはフック`reloaded'を用意します。 +# フック`reloaded'は、設定ファイルがリロードされた時に呼ばれます。 +# ----------------------------------------------------------------------------- +package Configuration; +# Configuration及びConfiguration::BlockはUTF-8バイト列でデータを保持します。 +use strict; +use warnings; +use UNIVERSAL; +use Carp; +use Configuration::Preprocessor; +use Configuration::Parser; +use Configuration::Block; +use Hook; +our @ISA = 'HookTarget'; +our $AUTOLOAD; +use Tiarra::SharedMixin qw(shared shared_conf); +our $_shared_instance; +# 値を取得するにはgetメソッドを用いる他、エントリ名をそのままメソッドとして呼ぶ事も出来ます。 +# +# $conf->hoge; +# ブロックhogeを返す。hogeが未定義ならundef値を返す。 + +sub _new { + my ($class) = @_; + my $obj = { + conf_file => '', # confファイルへのパス + time_on_load => 0, # 最後にloadが実行された時刻。 + blocks => {}, # 汎用ブロック名 -> Configuration::Block ここにモジュール設定は入らない。 + modules => [], # +で指定されたモジュールのConfiguration::Block + included_files => [], # include されたすべてのファイル(面倒なので conf_file を含む) + }; + bless $obj,$class; + $obj; +} + +sub get { + my ($class_or_this,$block_name) = @_; + my $this = $class_or_this->_this; + # 汎用ブロックを検索 + + if (!defined $block_name) { + carp "Configuration->get, Arg[0] is undef.\n"; + } + + $this->{blocks}->{$block_name}; +} + +sub find_module_conf { + my ($class_or_this,$module_name,$option) = @_; + my $this = $class_or_this->_this; + # モジュールの設定を検索 + foreach my $conf (@{$this->{modules}}) { + return $conf if $conf->block_name eq $module_name; + } + if ($option eq 'block') { + Configuration::Block->new($module_name); + } else { + undef; + } +} + +sub get_list_of_modules { + # confで指定された順番で、+とされた全てのモジュールの + # Configuration::Blockを持つ配列を指すリファレンスを返す。 + shift->_this->{modules}; +} + +sub check_if_updated { + # 最後にloadを実行してからconfファイルが更新されたか。 + # 一度もloadしていなければ必ず1を返す。 + # ファイル名が保存されていなければ必ず0を返す。 + my $this = shift->_this; + if ($this->{time_on_load} == 0) { + 1; + } else { + if (defined $this->{conf_file}) { + #$this->{time_on_load} < (stat $this->{conf_file})[9]; + foreach (@{$this->{included_files}}) { + return 1 if ($this->{time_on_load} < (stat $_)[9]); + } + 0; + } else { + 0; + } + } +} + +sub load { + # confファイルを読む。ファイルへのパスを省略すると、 + # 前回のload時に指定されたパスからリロードする。 + # ファイル名の代わりにIO::Handleのオブジェクトを渡しても良い。 + # その場合はリロードは不可能になる。 + my ($class_or_this,$conf_file) = @_; + my $this = $class_or_this->_this; + my $this_is_reload = !defined $conf_file; + + if (defined $conf_file) { + if (ref($conf_file) && UNIVERSAL::isa($conf_file,'IO::Handle')) { + # IO::Handleだった場合は保存しておけない。 + $this->{conf_file} = undef; + } else { + # ファイル名なので保存しておく。 + $this->{conf_file} = $conf_file; + } + } else { + if (defined $this->{conf_file}) { + $conf_file = $this->{conf_file}; + } else { + croak "Configuration->load, Arg[1] was omitted or undef, but no file names were saved yet.\n"; + } + } + + $this->{time_on_load} = time; + + # プリプロセスしてからパース + my $preprocessor = Configuration::Preprocessor->new; + my $body = $preprocessor->execute($conf_file); + my $parser = Configuration::Parser->new($body); + my $parsed = $parser->parsed; + + # 定義されていない値はデフォルト値で埋める。 + $this->_complete_table_with_defaults($parsed); + + # general->conf-encodingを見て文字コードをUTF-8に変換 + my $conf_encoding = do { + my $result; + foreach my $block (@$parsed) { + if ($block->block_name eq 'general') { + $result = $block->conf_encoding; + last; + } + } + $result; + }; + foreach my $block (@$parsed) { + $block->reinterpret_encoding($conf_encoding); + } + + # とりあえずモジュールのブロックとそうでないものに分ける。 + my $blocks = {}; + my $modules = []; + foreach my $block (@$parsed) { + my $blockname = $block->block_name; + + if ($blockname =~ m/^-/) { + # -ブロックなので捨てる。 + next; + } elsif ($blockname =~ m/^\+/) { + # +ブロックなので+を消して登録 + $blockname =~ s/^\+\s*//; + $block->block_name($blockname); + + push @$modules,$block; + } else { + # 普通のブロック。 + $blocks->{$blockname} = $block; + } + } + + $this->_check_required_definitions($blocks); # 省略不可能な定義を調べ、もし有ればdieする。 + $this->_check_duplicated_modules($modules); # 同じモジュールが複数回定義されていたらdieする。 + + # ここまでdieせずに来れたという事は、何もエラーが出なかったという事。 + # $thisに登録する事で確定する。 + $this->{blocks} = $blocks; + $this->{modules} = $modules; + $this->{included_files} = [$preprocessor->included_files] + if (defined $this->{conf_file}); # リロード可能な場合は include_files を登録する。 + + # リロードした場合はフックを呼ぶ。 + if ($this_is_reload) { + $this->call_hooks('reloaded'); + } +} + + +# デフォルト値のテーブル。 +my $defaults = { + general => { + 'conf-encoding' => 'auto', + 'server-in-encoding' => 'jis', + 'server-out-encoding' => 'jis', + 'client-in-encoding' => 'jis', + 'client-out-encoding' => 'jis', + 'stdout-encoding' => 'utf8', + 'sysmsg-prefix' => 'tiarra', + 'sysmsg-prefix-use-masks' => { + 'system' => '*', + 'priv' => '', + 'channel' => '*', + }, + # nick-fix-mode のデフォルト値も後で別処理。 + 'messages' => { + 'quit' => { + 'netconf-changed-reconnect' => + 'Server Configuration changed; reconnect', + 'netconf-changed-disconnect' => + 'Server Configuration changed; disconnect', + } + }, + }, + networks => { + 'name' => 'main', + # defaultのデフォルト値は特殊なので後で別処理。 + 'multi-server-mode' => 1, + 'channel-network-separator' => '@', + 'action-when-disconnected' => 'part-and-join', + }, +}; +sub _complete_table_with_defaults { + my ($this, $blocks) = @_; + + my $root_block = Configuration::Block->new('ROOT'); + map { + $root_block->set($_->block_name, $_); + } @$blocks; + $this->_complete_block_with_defaults($root_block, $defaults); + + my $general = $root_block->general; + if (!defined $general->nick_fix_mode) { + $general->set('nick-fix-mode', do { + if ($general->multi_server_mode) { + 0; + } else { + 1; + } + }); + } + + # networksのdefaultだけは別処理。 + my $networks = $root_block->networks; + if (!defined $networks->default) { + $networks->set('default',$networks->name); + } + + @$blocks = values(%{$root_block->table}); + $blocks; +} + +sub _complete_block_with_defaults { + my ($this, $blocks, $defaults) = @_; + + while (my ($default_block_name,$default_block) = each %$defaults) { + # このブロックは存在しているか？ + unless (defined $blocks->get($default_block_name)) { + # ブロックごと省略されていたので空のブロックを定義。 + $blocks->set($default_block_name, + Configuration::Block->new($default_block_name)); + } + + my $block = $blocks->get($default_block_name); + my $must_check_child = {}; + while (my ($default_key,$default_value) = each %{$default_block}) { + if ((!ref($default_value)) || + (ref($default_value) eq 'ARRAY')) { + # この値は存在しているか？ + if (!defined $block->get($default_key)) { + # 値が省略されていたので値を定義。 + $block->set($default_key,$default_value); + } + } elsif (ref($default_value) eq 'HASH') { + $must_check_child->{$default_key} = $default_value; + } + } + if (values %$must_check_child) { + $this->_complete_block_with_defaults($block, $must_check_child); + } + } +} + +my $required = { + general => ['nick','user','name'], + # [ネットワーク名]のhost,portは別処理。 +}; +my $required_in_each_networks = ['host','port']; +sub _check_required_definitions { + my ($this,$blocks) = @_; + if (!defined $blocks) { + $blocks = $this->{blocks}; + } + + my $error = sub { + my ($block_name,$key) = @_; + die "Required definition '$key' in block '$block_name' was not found.\n"; + }; + + # $requiredで定義されているものに関してチェックを行なう。 + while (my ($required_block_name,$required_keys) = each %{$required}) { + foreach my $required_key (@{$required_keys}) { + unless ($blocks->{$required_block_name}->get($required_key)) { + # 必要だとされているのに定義が無かった。 + $error->($required_block_name,$required_key); + } + } + } + + # 各ネットワークのhostとportをチェック。 + my @network_names = $blocks->{networks}->name('all'); + foreach my $network_name (@network_names) { + foreach my $required_key (@{$required_in_each_networks}) { + my $block = $blocks->{$network_name}; + if (!defined $block) { + die "Block $network_name was not found. It was enumerated in networks/name.\n"; + } + if (!defined $blocks->{$network_name}->get($required_key)) { + # 必要だとされているのに定義が無かった。 + $error->($network_name,$required_key); + } + } + } +} + +sub _check_duplicated_modules { + my ($this,$modules) = @_; + if (!defined $modules) { + $modules = $this->{modules}; + } + + my $modnames = {}; + foreach my $block (@$modules) { + my $modname = $block->block_name; + if (defined $modnames->{$modname}) { + die "Module $modname has multiple definitions. Only one is allowed.\n"; + } + $modnames->{$modname} = 1; + } +} + +sub AUTOLOAD { + my $this = shift; + if ($AUTOLOAD =~ /::DESTROY$/) { + # DESTROYは伝達させない。 + return; + } + + (my $key = $AUTOLOAD) =~ s/.+?:://g; + return $this->get($key); +} + +# ----------------------------------------------------------------------------- +package Configuration::Hook; +use FunctionalVariable; +use base 'Hook'; + +our $HOOK_TARGET_NAME = 'Configuration'; +our @HOOK_NAME_CANDIDATES = 'reloaded'; +our $HOOK_TARGET_DEFAULT; +FunctionalVariable::tie( + \$HOOK_TARGET_DEFAULT, + FETCH => sub { + Configuration->shared; + }, + ); + +1; diff -urN /non-existant-dir/main/ControlPort.pm tiarra-20080510/main/ControlPort.pm --- /non-existant-dir/main/ControlPort.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/main/ControlPort.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,380 @@ +# ----------------------------------------------------------------------------- +# $Id: ControlPort.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +=pod + << NOTIFY Log::Channel TIARRACONTROL/1.0 + << Sender: LogManager + << ID: synchronize + + >> TIARRACONTROL/1.0 204 No Content + ---------------------------------------- + << GET :: TIARRACONTROL/1.0 + << Sender: Foo + << ID: get-realname + << Reference0: ircnet + << Charset: UTF-8 + + >> TIARRACONTROL/1.0 200 OK + >> Value: (ネットワークircnetでの本名) + >> Charset: UTF-8 +=cut +# ----------------------------------------------------------------------------- +package ControlPort; +use strict; +use warnings; +use Carp; +use IO::Dir; +use ExternalSocket; +use Tiarra::Encoding; +use RunLoop; +use Tiarra::TerminateManager; + +# 複数のパッケージを混在させてるとSelfLoaderが使えない…？ +#use SelfLoader; +#1; +#__DATA__ + +sub TIARRA_CONTROL_ROOT () { '/tmp/tiarra-control'; } + +sub new { + my ($class,$sockname) = @_; + + # IO::Socket::UNIXをuseする。失敗したらdie。 + eval q{ + use IO::Socket::UNIX; + }; if ($@) { + # 使えない。 + die "Tiarra control socket is not available for this environment.\n"; + } + + my $this = { + sockname => $sockname, + filename => TIARRA_CONTROL_ROOT.'/'.$sockname, + server_sock => undef, # ExternalSocket + clients => [], # ControlPort::Session + session_handle_hook => undef, # RunLoop::Hook + }; + bless $this,$class; + $this->open; + + $this; +} + +sub open { + my $this = shift; + my $filename = $this->{filename}; + + # ディレクトリ/tmp/tiarra-controlが無ければ作る。 + if (!-d TIARRA_CONTROL_ROOT) { + mkdir TIARRA_CONTROL_ROOT or die 'Couldn\'t make directory '.TIARRA_CONTROL_ROOT; + # 他のユーザーも作れるようにする。 + # 最初に作成したユーザーが全ファイルを消すことが出来るが、対処法なし。 + chmod 01777, TIARRA_CONTROL_ROOT; + } + + # ソケットが既に存在した場合は接続してみる。 + if (-e $filename) { + my $sock = IO::Socket::UNIX->new( + Peer => $filename, + ); + if (!defined $sock) { + # もう使われていない? + unlink $filename; + undef $sock; + } + } + + # リスニング用ソケットを開く。 + my $sock = IO::Socket::UNIX->new( + Type => &SOCK_STREAM, + Local => $filename, + Listen => 1); + if (!defined $sock) { + die "Couldn't make socket $filename: $!"; + } + # パーミッションを700に。 + chmod 0700, $filename; + $this->{server_sock} = + ExternalSocket->new( + Socket => $sock, + Read => sub { + my $server = shift->sock; + my $client = $server->accept; + if (defined $client) { + push @{$this->{clients}},ControlPort::Session->new($client); + } + }, + Write => sub{}, + WantToWrite => sub{undef})->install; + + # セッションハンドル用のフックをかける。 + $this->{session_handle_hook} = + RunLoop::Hook->new( + 'ControlPort Session Handler', + sub { + # セッション処理 + foreach my $client (@{$this->{clients}}) { + $client->main; + } + # 終了したセッションを削除 + @{$this->{clients}} = grep { + $_->is_alive; + } @{$this->{clients}}; + })->install; + + $this->{destructor} = Tiarra::TerminateManager::Hook->new( + sub { + $this->destruct; + })->install; + + $this; +} + +sub destruct { + my $this = shift; + + # 切断 + if (defined $this->{server_sock}) { + eval { + $this->{server_sock}->disconnect; + }; + } + + # このソケットファイルを削除 + unlink $this->{filename}; + + # ディレクトリにソケットが一つも無くなったら、このディレクトリも消える。 + rmdir TIARRA_CONTROL_ROOT; + + $this; +} + +package ControlPort::Session; +use strict; +use warnings; +use Tiarra::Socket::Lined; +use base qw(Tiarra::Socket::Lined); + +sub new { + # $sock: IO::Socket + my ($class,$sock) = @_; + my $this = $class->SUPER::new(name => 'ControlPort::Session'); + $this->{method} = undef; # GETまたはNOTIFY + $this->{module} = undef; # Log::Channelなど。'::'はメインプログラムを表す。 + $this->{header} = undef; # {key => value} + $this->{input_is_frost} = 0; # これ以上の入力を無視するか？ + bless $this,$class; + $this->attach($sock); + $this->install; +} + +sub main { + my $this = shift; + + while (defined($_ = $this->pop_queue)) { + s/^\s*|\s*$//g; + my $line = $_; + + if ($this->{input_is_frost}) { + last; + } + + if (defined $this->{header}) { + # $this->{header}が存在するということは、最初のリクエスト行はもう受け取った。 + if ($line eq '') { + # 空の行だ。リクエスト終わり。 + $this->respond; + } + else { + if ($line =~ m/^(.+?)\s*:\s*(.+)$/) { + $this->{header}{$1} = $2; + } + else { + $this->reply(401,'Bad Request'); + } + } + } + else { + if ($line =~ m|^(.+?)\s+(.+?)\s+TIARRACONTROL/(\d+)\.(\d+)$|) { + $this->{method} = $1; + $this->{module} = $2; + if (!{GET => 1,NOTIFY => 1}->{$this->{method}}) { + $this->reply(501,'Method Not Implemented'); + } + my $version = "$3.$4"; + if ($version > 1.0) { + $this->reply(401,'Bad Request'); + } + $this->{header} = {}; + } + else { + $this->reply(401,'Bad Request'); + } + } + } +} + +sub reply { + # $code: 204など + # $str: No Contentなど + # $header: {key => value} 省略可。文字コードはUTF-8。SenderとCharsetは不要。 + my ($this,$code,$str,$header) = @_; + + $this->append_line("TIARRACONTROL/1.0 $code $str"); + $this->append_line('Sender: Tiarra #'.&::version); + my $unijp = Tiarra::Encoding->new; + if (defined $header) { + while (my ($key,$value) = each %$header) { + $this->append_line($unijp->set("$key: $value")->conv($this->charset)); + } + } + $this->append_line('Charset: '.$this->long_charset); + $this->append_line(''); + $this->disconnect_after_writing; +} + +sub charset { + # リクエストで受け取ったCharsetから、Unicode::Japaneseエンコーディング名を返す。 + my $this = shift; + + if (!defined $this->{header}) { + return 'utf8'; + } + + my $charset = $this->{header}->{Charset}; + if (!defined $charset) { + return 'utf8'; + } + + my $charset_table = { + 'Shift_JIS' => 'sjis', + 'EUC-JP' => 'euc', + 'ISO-2022-JP' => 'jis', + 'UTF-8' => 'utf8', + }; + $charset_table->{$charset} || 'utf8'; +} + +sub long_charset { + my $this = shift; + + my $table = { + 'sjis' => 'Shift_JIS', + 'euc' => 'EUC-JP', + 'jis' => 'ISO-2022-JP', + 'utf8' => 'UTF-8', + }; + $table->{$this->charset} || 'UTF-8'; +} + +sub is_alive { + shift->connected; +} + +sub respond { + my $this = shift; + + my $req = ControlPort::Request->new($this->{method},$this->{module}); + my $charset = $this->charset; + my $unijp = Tiarra::Encoding->new; + while (my ($key,$value) = each %{$this->{header}}) { + next if $key eq 'Charset'; + $req->$key($unijp->set($value,$charset)->utf8); + } + + my $rep = eval { + if ($req->module eq '::') { + # モジュール"::"はメインプログラムを表す。 + # 後で。 + die qq{Controlling '::' is not supported yet.\n}; + } + else { + # このようなモジュールは存在するか？ + my $mod = ModuleManager->shared->get($req->module); + if (defined $mod) { + my $reply = $mod->control_requested($req); + if (!defined $reply) { + die $this->{module}."->control_requested returned undef.\n"; + } + elsif (!$reply->isa('ControlPort::Reply')) { + die $this->{module}."->control_requested returned bad ref: ".ref($reply)."\n"; + } + else { + $reply; + } + } + else { + die qq{Module $this->{module} doesn't exist.\n}; + } + } + }; + if ($@) { + (my $detail = $@) =~ s/\n//g; + $this->reply(500,'Internal Server Error',{Detail => $detail}); + } + else { + $this->reply($rep->code,$rep->status,$rep->table); + } +} + +package ControlPort::Packet; +use strict; +use warnings; +our $AUTOLOAD; +use Tiarra::Utils (); +Tiarra::Utils->define_attr_getter(0, qw(table)); + +sub new { + my $class = shift; + my $this = { + table => {}, # {key => value} + }; + bless $this,$class; +} + +sub AUTOLOAD { + my ($this,$value) = @_; + if ($AUTOLOAD =~ /::DESTROY$/) { + return; + } + + (my $key = $AUTOLOAD) =~ s/.+?:://g; + if (defined $value) { + $this->{table}{$key} = $value; + } + $this->{table}{$key}; +} + +package ControlPort::Request; +use strict; +use warnings; +use base qw(ControlPort::Packet); +use Tiarra::Utils (); +Tiarra::Utils->define_attr_getter(0, qw(method module)); + +sub new { + my ($class,$method,$module) = @_; + my $this = $class->SUPER::new; + $this->{method} = $method; + $this->{module} = $module; + $this; +} + +package ControlPort::Reply; +use strict; +use warnings; +use base qw(ControlPort::Packet); +use Tiarra::Utils (); +Tiarra::Utils->define_attr_getter(0, qw(code status)); + +sub new { + # $code: 204など + # $status: No Contentなど + my ($class,$code,$status) = @_; + my $this = $class->SUPER::new; + $this->{code} = $code; + $this->{status} = $status; + $this; +} + +1; diff -urN /non-existant-dir/main/Crypt.pm tiarra-20080510/main/Crypt.pm --- /non-existant-dir/main/Crypt.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/main/Crypt.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,50 @@ +# ----------------------------------------------------------------------------- +# $Id: Crypt.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +# 与えられた、またはランダムに決定されたsaltを用いて文字列をcryptする機能、 +# そして文字列をcryptして得られた文字列を、予めcryptされた文字列と +# 比較する機能を持つ。 +# ----------------------------------------------------------------------------- +package Crypt; +use strict; +use warnings; + +#use SelfLoader; +#1; +#__DATA__ + +sub encrypt { + # saltは省略可能。省略されるとランダムに作られる。 + my ($str,$salt) = @_; + $salt = gen_salt() unless defined $salt; + + return crypt($str,$salt); +} + +sub check { + # encryptedのsaltでrawをcrypt()してみて、一致したかどうかを真偽値で返す。 + my ($raw,$encrypted) = @_; + + return crypt($raw,substr($encrypted,0,2)) eq $encrypted; +} + +sub gen_salt { + my $salt = ''; + + srand; + for (0 .. 1) { + my $n = int(rand(63)); + if ($n < 12) { + $salt .= chr($n + 46); # ./0-9 + } + elsif ($n < 38) { + $salt .= chr($n + 65 - 12); # A-Z + } + elsif ($n < 64) { + $salt .= chr($n + 97 - 38); # a-z + } + } + $salt; +} + +1 diff -urN /non-existant-dir/main/Exception.pm tiarra-20080510/main/Exception.pm --- /non-existant-dir/main/Exception.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/main/Exception.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,36 @@ +# ----------------------------------------------------------------------------- +# $Id: Exception.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +package Exception; +use strict; +use warnings; +use overload + '""' => \&_ope_tostring; + +sub new { + my ($class,$msg) = @_; + my $this = { + msg => $msg, + stacktrace => undef, # 後で書く。caller辿るの面倒。 + }; + bless $this,$class; +} + +sub message { + shift->{msg}; +} + +sub throw { + die shift; +} + +sub _ope_tostring { + my ($this) = @_; + ref($this).(defined $this->{msg} ? " : $this->{msg}" : ''); +} + +# ----------------------------------------------------------------------------- +package QueueIsEmptyException; +use base qw(Exception); + +1; diff -urN /non-existant-dir/main/ExternalSocket.pm tiarra-20080510/main/ExternalSocket.pm --- /non-existant-dir/main/ExternalSocket.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/main/ExternalSocket.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,170 @@ +# ----------------------------------------------------------------------------- +# $Id: ExternalSocket.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +# RunLoopは任意のソケットを監視する事が出来るが、その登録の為にこのクラスを用いる。 +# ----------------------------------------------------------------------------- +# my $esock = ExternalSocket->new( +# Socket => IO::Socket::INET->new(...), # IO::Socket型のオブジェクト +# Read => sub { +# # ソケットが読み込み可能になった時に呼ばれるクロージャ。 +# # ExternalSocketのオブジェクト自身を一つだけ引数に呼ばれる。 +# my $sock = shift->sock; +# ... +# }, +# Write => sub { +# # ソケットが書き込み可能になった時に呼ばれるクロージャ。 +# my $sock = shift->sock; +# ... +# }, +# WantToWrite => sub { +# # ソケットに書き込む必要があるかどうかをRunLoopが知る為に呼ばれるクロージャ。 +# # 引数はReadやWriteと同じだが、真偽値を返さなければならない。 +# undef; +# }, +# Exception => sub { +# # ソケットに例外が発生したときに呼ばれるクロージャ。 +# # 省略可能。 +# my $this = shift; +# ::printmsg($this->errmsg('foo socket error')); +# $this->disconnect; +# }, +# )->install; +# +# $esock->uninstall; +# ----------------------------------------------------------------------------- +package ExternalSocket; +use strict; +use warnings; +use UNIVERSAL; +use Carp; +use Tiarra::Utils; +use Tiarra::Socket; +use base qw(Tiarra::Socket); +utils->define_attr_getter(0, qw(name)); + +#use SelfLoader; +#SelfLoader->load_stubs; +#1; +#__DATA__ + +sub socket { + shift->sock(@_); +} + +sub new { + my ($class,%opts) = @_; + + $class->_increment_caller('external-socket', \%opts); + my $this = $class->SUPER::new(%opts); + $this->{read} = undef; + $this->{write} = undef; + $this->{wanttowrite} = undef; + $this->{exception} = undef; + my $this_func = $class . '->new'; + + if (defined $opts{Socket}) { + if (ref $opts{Socket} && + UNIVERSAL::isa($opts{Socket},'IO::Socket')) { + $this->attach($opts{Socket}); + } + else { + croak "$this_func, Arg{Socket} was illegal object: ".ref($opts{Socket})."\n"; + } + } + else { + croak "$this_func, Arg{Socket} not exists\n"; + } + + foreach my $key (qw/Read Write WantToWrite Exception/) { + if (defined $opts{$key}) { + if (ref($opts{$key}) eq 'CODE') { + $this->{lc $key} = $opts{$key}; + } + else { + croak "$this_func, Arg{$key} was illegal reference: ".ref($opts{$key})."\n"; + } + } + elsif ($key ne 'Exception') { + # Exception is optional + croak "$this_func, Arg{$key} not exists\n"; + } + } + + if (defined $opts{Name}) { + $this->name($opts{Name}); + } + + $this; +} + +sub install { + # RunLoopにインストールする。 + # 引数を省略した場合はデフォルトのRunLoopにインストールする。 + my ($this,$runloop) = @_; + + if ($this->installed) { + croak "This " . ref($this) . + " has been already installed to RunLoop\n"; + } + + $runloop = RunLoop->shared unless defined $runloop; + $this->{runloop} = $runloop; + $this->SUPER::install; +} + +sub uninstall { + # インストールしたRunLoopから、このソケットをアンインストールする。 + my $this = shift; + + if (!$this->installed) { + # インストールされていない。 + croak "This " . ref($this) . " hasn't been installed yet\n"; + } + + $this->SUPER::uninstall; +} + +sub __check_caller { + my $this = shift; + my $caller_pkg = utils->get_package(1); + if (!$caller_pkg->isa('RunLoop')) { + croak "Only RunLoop may call method read/write/want_to_write of " . + ref($this) . "\n"; + } +} + +sub read { + # Readを実行する。RunLoopのみがこのメソッドを呼べる。 + my $this = shift; + + $this->__check_caller; + $this->{read}->($this); + $this; +} + +sub write { + # Writeを実行する。 + my $this = shift; + + $this->__check_caller; + $this->{write}->($this); + $this; +} + +sub want_to_write { + # WantToWriteを実行する。 + my $this = shift; + + $this->__check_caller; + $this->{wanttowrite}->($this); +} + +sub exception { + # Exceptionを実行する。 + my $this = shift; + + $this->__check_caller; + $this->{exception}->($this) if defined $this->{exception}; +} + +1; diff -urN /non-existant-dir/main/FunctionalVariable.pm tiarra-20080510/main/FunctionalVariable.pm --- /non-existant-dir/main/FunctionalVariable.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/main/FunctionalVariable.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,98 @@ +# ----------------------------------------------------------------------------- +# $Id: FunctionalVariable.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +# FunctionalVariableは、与えられた任意の関数リファレンスを呼ぶように +# 変数に処理関数をtieする事が出来ます。Tie::Scalarとの違いは、処理関数を +# コンパイル時ではなく、生成時に決められる事です。 +# ----------------------------------------------------------------------------- +# 使い方: +# +# スカラー変数に割り当てる場合: +# my $foo; +# FunctionalVariable::tie( +# \$foo, +# FETCH => sub { +# # FETCHは省略可能 +# return 500; +# }, +# STORE => sub { +# # STOREも省略可能 +# print shift; +# }, +# ); +# print "$foo\n"; # "500\n"を出力 +# $foo = 10; # "10"を出力 +# ----------------------------------------------------------------------------- +# 内部動作: +# +# FunctionalVariable::tieを実行すると、その変数にはFunctionalVariable型の +# オブジェクトがtieされる。FunctionalVariable::FETCHその他は、tie実行時に +# 指定された関数に実際の処理を委譲する。 +# ----------------------------------------------------------------------------- +package FunctionalVariable; +use strict; +use warnings; +use Carp; + +sub tie { + # $variable: tieする変数への参照 + # @functions: 関数群 + my ($variable, @functions) = @_; + + # @functionsの検査 + my $functions = eval { + my $funcs = {@functions}; + while (my ($key, $value) = each %$funcs) { + if (ref($value) ne 'CODE') { + die "FunctionalVariable->tie, Arg[1]{$key} is not a function ref.\n"; + } + } + $funcs; + }; if ($@) { + croak $@; + } + + my $this = { + variable => $variable, + type => ref($variable), + functions => $functions, + }; + + if ($this->{type} eq 'SCALAR') { + tie $$variable, 'FunctionalVariable', $this; + } + elsif ($this->{type} eq '') { + croak "FunctionalVariable->tie, Arg[0] was not a ref.\n"; + } + else { + croak "FunctionalVariable->tie, Arg[0] was bad ref: $this->{type}\n"; + } +} + +sub TIESCALAR { + my ($class, $this) = @_; + bless $this => $class; +} + +sub FETCH { + my ($this) = @_; + my $f = $this->{functions}{'FETCH'}; + if (defined $f) { + $f->(); + } + else { + # FETCHが定義されていないのなら、undefでも返す他無い。 + undef; + } +} + +sub STORE { + my ($this, $value) = @_; + my $f = $this->{functions}{'STORE'}; + if (defined $f) { + $f->($value); + } + # STOREが定義されていないのなら、何もしない。 +} + +1; diff -urN /non-existant-dir/main/Hook.pm tiarra-20080510/main/Hook.pm --- /non-existant-dir/main/Hook.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/main/Hook.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,244 @@ +# ----------------------------------------------------------------------------- +# $Id: Hook.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +# Hook: あらゆるフックのベースクラス +# HookTarget: あらゆるフック先のベースクラス +# ----------------------------------------------------------------------------- +# Hookの使い方: +# +# パッケージ変数 $HOOK_TARGET_NAME, @HOOK_NAME_CANDIDATES, +# $HOOK_NAME_DEFAULT, $HOOK_TARGET_DEFAULT を定義する +# 各変数の意味は次の通り +# +# $HOOK_TARGET_NAME: +# このフックをかける先のパッケージ名。 +# +# @HOOK_NAME_CANDIDATES: +# フック名として許される名前の候補。 +# +# $HOOK_NAME_DEFAULT: +# フック名が省略された場合のデフォルト値。 +# これは省略可能で、省略した場合はフック名の候補の個数が +# 2つ以上である場合に限り、フック名の省略が不可能になる。 +# +# $HOOK_TARGET_DEFAULT: +# フックを掛ける対象のオブジェクトが省略された場合のデフォルト値。 +# これは省略可能で、省略した場合はinstall時にターゲットの省略が出来なくなる。 +# +# これらの変数を定義し、Hookを@ISAに入れたパッケージを作る。 +# ----------------------------------------------------------------------------- +# HookTargetの使い方: +# +# HookTargetを@ISAに入れたクラスを作る。コンストラクタでの配慮は不要。 +# $obj->call_hooks($hook_name)で、インストールされた全てのフックを呼ぶ。 +# $obj->call_hooks($hook_name, $foo, $bar, $baz)のように任意の個数の引数を +# 渡す事が可能で、その場合はそれらを引数としてフック関数が呼ばれる。 +# +# 現在の実装では、HookTargetはオブジェクトをハッシュで持つクラスでのみ使用可能。 +# また、`installed-hooks'と云うキーを勝手に使う。 +# ----------------------------------------------------------------------------- +package Hook; +use strict; +use warnings; +use Carp; +use UNIVERSAL; +use Tiarra::Utils; +utils->define_attr_getter(0, qw(name)); + +sub new { + my $class = shift; + #my ($class, $code) = @_; + my $name = shift; + my $code = shift; + if (!defined $name) { + croak $class."->new, Arg[0] was undef.\n"; + } + if (ref($name) eq 'CODE' && !defined($code)) { + $code = $name; + $name = utils->simple_caller_formatter($class.' registered'); + } + + my $this = { + target => undef, + target_package_name => undef, + hook_name => undef, + + name => $name, + code => $code, + }; + + if (ref($code) ne 'CODE') { + croak $class."->new, Arg[0] was bad type.\n"; + } + + do { + no strict; + no warnings; + + local %symtable = %{$class.'::'}; + if (defined ${$symtable{HOOK_TARGET_NAME}}) { + $this->{target_package_name} = ${$symtable{HOOK_TARGET_NAME}}; + } + else { + croak "${class}->new, \$${class}::HOOK_TARGET_NAME undefined.\n"; + } + + if (@{$symtable{HOOK_NAME_CANDIDATES}} == 0) { + croak "${class}->new, \@${class}::HOOK_NAME_CANDIDATES undefined.\n"; + } + }; + + bless $this, $class; +} + +sub install { + my ($this, $hook_name, $target) = @_; + + if (defined $this->{target}) { + croak ref($this)."->install, this hook is already installed.\n"; + } + + do { + no strict; + + my %symtable = %{ref($this).'::'}; + if (!defined $hook_name) { + # @HOOK_NAME_CANDIDATESの個数は1つか？ + # それとも$HOOK_NAME_DEFAULTは定義されているか？ + if (@{$symtable{HOOK_NAME_CANDIDATES}} == 1) { + $hook_name = $symtable{HOOK_NAME_CANDIDATES}->[0]; + } + elsif (defined ${$symtable{HOOK_NAME_DEFAULT}}) { + $hook_name = ${$symtable{HOOK_NAME_DEFAULT}}; + } + else { + croak ref($this)."->install, you can't omit the hook name.\n"; + } + } + + # $hook_nameは本当にフック名として許されているか？ + if (!{map {$_ => 1} @{$symtable{HOOK_NAME_CANDIDATES}}}->{$hook_name}) { + croak ref($this)."->install, hook `$hook_name' is not available.\n"; + } + + if (!defined $target) { + # $HOOK_TARGET_DEFAULTは定義されているか？ + if (defined ${$symtable{HOOK_TARGET_DEFAULT}}) { + $target = ${$symtable{HOOK_TARGET_DEFAULT}}; + } + else { + croak ref($this)."->install, you can't omit the hook target.\n"; + } + } + }; + + # $targetは本当にHookTargetを継承したオブジェクトか？ + if (!UNIVERSAL::isa($target, 'HookTarget')) { + croak ref($this)."->install, target is not a subclass of HookTarget: ". + ref($target)."\n"; + } + + # $targetは本当に$HOOK_TARGET_NAMEのオブジェクトか？ + if (!UNIVERSAL::isa($target, $this->{target_package_name})) { + croak ref($this)."->install, target is not a subclass of $this->{target_package_name}: ". + ref($target)."\n"; + } + + $this->{target} = $target; + $this->{hook_name} = $hook_name; + $target->install_hook($hook_name, $this); + + $this; +} + +sub uninstall { + my $this = shift; + + $this->{target}->uninstall_hook($this->{hook_name}, $this); + $this->{target} = undef; + $this->{hook_name} = undef; + + $this; +} + +sub call { + my ($this, @args) = @_; + + my ($caller_pkg) = caller(2); + if ($caller_pkg->isa(ref $this->{target})) { + utils->do_with_errmsg("Hook: $this->{target}/$this->{hook_name}($this->{name})", + sub { + $this->{code}->($this, @args); + }); + } + else { + croak "Only ${\ref($this->{target})} can call ${\ref($this)}->call\n". + "$caller_pkg is not allowed to do so.\n"; + } +} + +# ----------------------------------------------------------------------------- +package HookTarget; + +sub _get_hooks_hash { + my $this = shift; + my $ih = $this->{'installed-hooks'}; + if (defined $ih) { + $ih; + } + else { + $this->{'installed-hooks'} = {}; + } +} + +sub _get_hooks_array { + my ($this, $hook_name) = @_; + my $installed_hooks = $this->_get_hooks_hash; + my $ar = $installed_hooks->{$hook_name}; + if (defined $ar) { + $ar; + } + else { + $installed_hooks->{$hook_name} = []; + } +} + +sub install_hook { + my ($this, $hook_name, $hook) = @_; + my $array = $this->_get_hooks_array($hook_name); + + push @$array, $hook; + $this; +} + +sub uninstall_hook { + my ($this, $hook_name, $hook) = @_; + my $array = $this->_get_hooks_array($hook_name); + + @$array = grep { + $_ != $hook; + } @$array; + $this; +} + +sub call_hooks { + my ($this, $hook_name, @args) = @_; + my $array = $this->_get_hooks_array($hook_name); + + foreach my $hook (@$array) { + eval { + $hook->call(@args); + }; if ($@) { + my $msg = ref($this)."->call_hooks, exception occured:\n". + " Hook: ".$hook->name."\n". + "$@"; + if (require RunLoop) { + RunLoop->notify_error($msg); + } else { + die $msg; + } + } + } +} + +1; diff -urN /non-existant-dir/main/IRCMessage.pm tiarra-20080510/main/IRCMessage.pm --- /non-existant-dir/main/IRCMessage.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/main/IRCMessage.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,37 @@ +# ----------------------------------------------------------------------------- +# $Id: IRCMessage.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +# IRCMessageはIRCのメッセージを表わすクラスです。実際のメッセージはUTF-8で保持します。 +# 生のメッセージのパース、シリアライズ、そしてメッセージの生成をサポートします。 +# パースとシリアライズには文字コードを指定して下さい。コードを変換します。 +# LineとEncoding以外の手段でインスタンスを生成する際は、 +# パラメータとしてUTF-8の値を渡して下さい。 +# インターフェースは同一です。 +# ----------------------------------------------------------------------------- +# 生成方法一覧 +# +# $msg = new IRCMessage(Line => ':foo!~foo@hogehoge.net PRIVMSG #hoge :hoge', +# Encoding => 'jis'); +# print $msg->command; # 'PRIVMSG'を表示 +# +# $msg = new IRCMessage(Server => 'irc.hogehoge.net', # ServerはPrefixでも良い。 +# Command => '366', +# Params => ['hoge','#hoge','End of /NAMES list.']); +# print $msg->serialize('jis'); # ":irc.hogehoge.net 366 hoge #hoge :End of /NAMES list."を表示 +# +# $msg = new IRCMessage(Nick => 'foo', +# User => '~bar', +# Host => 'hogehoge.net', # 以上３つのパラメータの代わりにPrefix => 'foo!~bar@hogehoge.net'でも良い。 +# Command => 'NICK', +# Params => 'huga', # Paramsは要素が一つだけならスカラー値でも良い。(この時、ParamsでなくParamでも良い。) +# Remarks => {'saitama' => 'SAITAMA'}, # 備考欄。シリアライズには影響しない。 +# print $msg->serialize('jis'); # ":foo!~bar@hogehoge.net NICK :huga"を表示 +# +# $msg = new IRCMessage(Command => 'NOTICE', +# Params => ['foo','hugahuga']); +# print $msg->serialize('jis'); # "NOTICE foo :hugahuga"を表示 +# +package IRCMessage; +use base qw(Tiarra::IRC::Message); + +1; diff -urN /non-existant-dir/main/InstantCapsule.pm tiarra-20080510/main/InstantCapsule.pm --- /non-existant-dir/main/InstantCapsule.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/main/InstantCapsule.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,140 @@ +# ----------------------------------------------------------------------------- +# $Id: InstantCapsule.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +# フィールドとメソッドを持つオブジェクトを一時的に生成するためのクラス。 +# 生成時にメソッドの実体をクロージャで渡します。 +# AUTOLOADやtieを使用しているため、動作速度は通常のクラスより遅い可能性があります。 +# +# my $capsule = InstantCapsule->new( +# Fields => { +# # 現時点ではハッシュ型オブジェクトのみ対応。 +# # 配列型やグロブ型のオブジェクトは非対応です。 +# foo => 10, +# bar => undef, +# baz => 'string', +# }, +# Methods => { +# # メソッド名newはInstantCapsuleが予約している。 +# +# printfoo => sub { +# # メソッドに渡される最初の引数はInstantCapsule自身。 +# my $this = shift; +# print $this->{foo},"\n"; +# }, +# +# setbar => sub { +# # 二つ目以降の引数は、このメソッド呼び出しに用いられたものがそのまま渡される。 +# my ($this,$value) = @_; +# $this->{bar} = $value; +# } +# +# DESTROY => sub { +# print "DESTROY called.\n"; +# } +# }); +# +# $capsule->printfoo; +# $capsule->setbar(5); +# undef $capsule; # ここでDESTROYが呼ばれる。 +# ----------------------------------------------------------------------------- +package InstantCapsule; +use strict; +use warnings; +use Carp; +use UNIVERSAL; +use vars qw($AUTOLOAD); + +sub new { + my ($class,%args) = @_; + my $this = { + fields => $args{Fields}, + methods => $args{Methods}, + }; + + if (!defined $this->{fields}) { + croak "InstantCapsule->new, Arg[Fields] not defined.\n"; + } + elsif (!ref($this->{fields}) || !UNIVERSAL::isa($this->{fields},'HASH')) { + croak "InstantCapsule->new, Arg[Fields] is bad type.\n"; + } + + if (!defined $this->{methods}) { + croak "InstantCapsule->new, Arg[Methods] not defined.\n"; + } + elsif (!ref($this->{methods}) || !UNIVERSAL::isa($this->{methods},'HASH')) { + croak "InstantCapsule->new, Arg[Methods] is bad type.\n"; + } + + # methods内をチェック。 + while (my ($name,$code) = each %{$this->{methods}}) { + if (eval qq{defined \&${class}::${name}}) { + croak "InstantCapsule->new, method $name is reserved for InstantCapsule itself.\n"; + } + if (!ref($code) || ref($code) ne 'CODE') { + croak "InstantCapsule->new, method $name is not a valid CODE value.\n"; + } + } + + my $obj = {}; + tie %$obj,$class,$this; # こうしておかないとフィールドが参照出来ない。 + bless $obj,$class; # こうしておかないとAUTOLOADが使えない。 +} + +sub TIEHASH { + my ($class,$tie) = @_; + bless $tie,$class; +} + +sub FETCH { + my ($this,$key) = @_; + $this->{fields}->{$key}; +} + +sub STORE { + my ($this,$key,$value) = @_; + $this->{fields}->{$key} = $value; +} + +sub DELETE { + my ($this,$key) = @_; + delete $this->{fields}->{$key}; +} + +sub EXISTS { + my ($this,$key) = @_; + exists $this->{fields}->{$key}; +} + +sub CLEAR { + my $this = shift; + %{$this->{fields}} = (); +} + +sub FIRSTKEY { + my $this = shift; + values %{$this->{fields}}; # reset iterator + each %{$this->{fields}}; +} + +sub NEXTKEY { + my $this = shift; + each %{$this->{fields}}; +} + +sub AUTOLOAD { + my ($obj,@args) = @_; + my $this = tied %$obj; + (my $method = $AUTOLOAD) =~ s/.+?:://g; + + if (defined $this->{methods}->{$method}) { + $this->{methods}->{$method}->($obj,@args); + } + else { + # DESTROYだけは無くても構わない。 + if ($method ne 'DESTROY') { + croak "InstantCapsule->AUTOLOAD, method $method is not defined.\n"; + } + } +} + +1; diff -urN /non-existant-dir/main/IrcIO/Client.pm tiarra-20080510/main/IrcIO/Client.pm --- /non-existant-dir/main/IrcIO/Client.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/main/IrcIO/Client.pm 2008-05-11 00:25:24.000000000 +0900 @@ -0,0 +1,644 @@ +# ----------------------------------------------------------------------------- +# $Id: Client.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +# IrcIO::Clientはクライアントからの接続を受け、 +# IRCメッセージをやり取りするクラスです。 +# ----------------------------------------------------------------------------- +package IrcIO::Client; +use strict; +use warnings; +use Carp; +use base qw(IrcIO); +use Crypt; +use Multicast; +use Mask; +use LocalChannelManager; +use NumericReply; +use Tiarra::Resolver; +use Tiarra::Socket; +use Tiarra::Utils; +utils->define_attr_getter(0, qw(logging_in username), + qw(client_host client_addr client_host_repr)); + + +# 複数のパッケージを混在させてるとSelfLoaderが使えない…？ +#use SelfLoader; +#SelfLoader->load_stubs; # このクラスには親クラスがあるから。(SelfLoaderのpodを参照) +#1; +#__DATA__ + +sub new { + my ($class,$runloop,$sock) = @_; + my $this = $class->SUPER::new($runloop); + $this->attach($sock); + $this->{pass_received} = ''; # クライアントから受け取ったパスワード + $this->{nick} = ''; # ログイン時にクライアントから受け取ったnick。変更されない。 + $this->{username} = ''; # 同username + $this->{logging_in} = 1; # ログイン中なら1 + $this->{options} = {}; # クライアントが接続時に$key=value$で指定したオプション。 + my $addr = $sock->peerhost; + $this->{client_host} = $this->{client_addr} = $addr; + ::printmsg("One client at ".$this->{client_addr}." connected to me. " . + "Please wait to get hostname of this address."); + Tiarra::Resolver->paranoid_check($addr, sub { + $this->accept(@_); + }); + $this; +} + +sub accept { + my ($this, $paranoid_ok, $host, $entry) = @_; + + $this->{client_host} = $paranoid_ok ? $host : $this->{client_addr}; + $this->{client_host_repr} = Tiarra::Socket->repr_destination( + host => $this->{client_host}, + addr => $this->{client_addr}); + + # このホストからの接続は許可されているか？ + my $allowed_host = $this->_conf_general->client_allowed; + if (defined $allowed_host) { + unless (Mask::match($allowed_host,$this->{client_host}) || + Mask::match($allowed_host,$this->{client_addr})) { + # マッチしないのでdie。 + die "Disconnect the client at ".$this->{client_host_repr}.". The host is not allowed.\n"; + } + } + ::printmsg("Accepted connection of the client at ".$this->{client_host_repr}."."); + $this->install; + $this; +} + +sub disconnect { + my ($this, $genre, $errno, @params) = @_; + + $this->SUPER::disconnect($genre, $errno, @params); + if (defined $errno) { + ::printmsg($this->sock_errno_to_msg( + $errno, + "Disconnected Client from ".$this->{client_host_repr}.": $genre error")); + } else { + ::printmsg("Disconnected Client from ".$this->{client_host_repr}."."); + } +} + +sub fullname { + # このクライアントをtiarraから見たnick!username@userhostの形式で表現する。 + my ($this,$type) = @_; + if (defined $type && $type eq 'error') { + $this->_runloop->current_nick.'['.$this->{username}.'@'.$this->{client_host}.']'; + } + else { + $this->_runloop->current_nick.'!'.$this->{username}.'@'.$this->{client_host}; + } +} + +sub fullname_from_client { + # このクライアントをクライアントから見たnick!username@userhostの形式で表現する。 + # この関数が返すnickは初めに受け取ったものである点に注意。 + my $this = shift; + $this->{nick}.'!'.$this->{username}.'@'.$this->{client_host}; +} + +sub parse_realname { + my ($this,$realname) = @_; + return if !defined $realname; + # $key=value;key=value;...$ + # + # 以下は全て有効で、同じ意味である。 + # $ foo = bar; key= value$ + # $ foo=bar;key=value $ + # $foo =bar;key= value $ + + my $key = qr{[^=:]+?}; # キーとして許されるパターン + my $value = qr{[^;]*?}; # 値として許されるパターン + my $sep = qr{[:=]}; + my $lastpair = qr{$key\s*$sep\s*$value}; + my $pair = qr{$lastpair\s*;}; + + my $line = qr{^\$(?:\s*($pair)\s*)*\s*($lastpair)\s*\$$}; + if (my @pairs = ($realname =~ m/$line/g)) { + %{$this->{options}} = map { + m/^\s*($key)\s*$sep\s*($value)\s*;?$/; + } grep { + defined; + } @pairs; + } +} + +sub option { + # ログイン時に$key=value$で指定されたオプションを取得する。 + # 指定されたキーに対する値が存在しなかった場合はundefを返す。 + my ($this,$key) = @_; + if (defined $key) { + $this->{options}->{$key}; + } + else { + croak "IrcIO::Client->option, Arg[1] was undef."; + } +} + +sub option_or_default { + my ($this, $base, $config_prefix, $option_prefix, $default) = @_; + my $value; + + utils->get_first_defined( + $this->option(utils->to_str($option_prefix).$base), + $this->_conf_general->get(utils->to_str($option_prefix).$base), + $default); +} + +sub option_or_default_multiple { + my ($this, $base, $types, $config_prefix) = @_; + + return utils->get_first_defined( + (map { + $this->option(join('',utils->to_str($_, $base))); + } @$types), + (map { + $this->_conf_general->get( + join('',utils->to_str($config_prefix, $_, $base))); + } @$types)); +} + +sub send_message { + my ($this,$msg) = @_; + + # 各モジュールに通知 + #$this->_runloop->notify_modules('notification_of_message_io',$msg,$this,'out'); + + $this->SUPER::send_message( + $msg, + $this->option_or_default_multiple('encoding', ['out-', ''], 'client-')); +} + +sub read { + my ($this) = shift; + $this->SUPER::read( + $this->option_or_default_multiple('encoding', ['in-', ''], 'client-')); + + # 接続が切れたら、各モジュールへ通知 + if (!$this->connected) { + $this->_runloop->notify_modules('client_detached',$this); + } +} + +sub pop_queue { + my $this = shift; + my $msg = $this->SUPER::pop_queue; + + # クライアントがログイン中なら、ログインを受け付ける。 + if (defined $msg) { + # 各モジュールに通知 + #$this->_runloop->notify_modules('notification_of_message_io',$msg,$this,'in'); + + # ログイン作業中か？ + if ($this->{logging_in}) { + return $this->_receive_while_logging_in($msg); + } + else { + return $this->_receive_after_logged_in($msg); + } + } + return $msg; +} + +sub _receive_while_logging_in { + my ($this,$msg) = @_; + + # NICK及びUSERを受け取った時点でそのログインの正当性を確認し、作業を終了する。 + my $command = $msg->command; + if ($command eq 'PASS') { + $this->{pass_received} = $msg->params->[0]; + } + elsif ($command eq 'NICK') { + $this->{nick} = $msg->params->[0]; + } + elsif ($command eq 'USER') { + $this->{username} = $msg->param(0); + $this->parse_realname($msg->param(3)); + } + elsif ($command eq 'PING') { + $this->send_message( + $this->construct_irc_message( + Command => 'PONG', + Param => $msg->param(0))); + } + elsif ($command eq 'QUIT') { + $this->send_message( + $this->construct_irc_message( + Command => 'ERROR', + Param => 'Closing Link: ['.$this->fullname_from_client.'] ()')); + $this->disconnect_after_writing; + } + + if ($this->{nick} ne '' && $this->{username} ne '') { + # general/tiarra-passwordを取得 + my $valid_password = $this->_conf_general->tiarra_password; + my $prefix = $this->_runloop->sysmsg_prefix('system'); + if (defined $valid_password && $valid_password ne '' && + ! Crypt::check($this->{pass_received},$valid_password)) { + # パスワードが正しくない。 + ::printmsg("Refused login of ".$this->fullname_from_client." because of bad password."); + + $this->send_message( + $this->construct_irc_message(Prefix => $prefix, + Command => ERR_PASSWDMISMATCH, + Params => [$this->{nick},'Password incorrect'])); + $this->send_message( + $this->construct_irc_message(Command => 'ERROR', + Param => 'Closing Link: ['.$this->fullname_from_client.'] (Bad Password)')); + $this->disconnect_after_writing; + } + else { + # パスワードが正しいか、指定されていない。 + ::printmsg('Accepted login of '.$this->fullname_from_client. + ', from '.$this->{client_host_repr}.'.'); + if ((my $n_options = keys %{$this->{options}}) > 0) { + # オプションが指定されていたら表示する。 + my $options = join ' ; ',map { + "$_ = $this->{options}->{$_}"; + } keys %{$this->{options}}; + ::printmsg('Given option'.($n_options == 1 ? '' : 's').': '.$options); + } + $this->{logging_in} = 0; + + # 実際にはループではない。 + while (1) { + $this->send_message( + $this->construct_irc_message(Prefix => $prefix, + Command => RPL_WELCOME, + Params => [$this->{nick},'Welcome to the Internet Relay Network '.$this->fullname_from_client])); + + my $current_nick = $this->_runloop->current_nick; + if ($this->{nick} ne $current_nick) { + # クライアントが送ってきたnickとローカルのnickが食い違っているので正しいnickを教える。 + $this->send_message( + $this->construct_irc_message(Prefix => $this->fullname_from_client, + Command => 'NICK', + Param => $current_nick)); + } + + my $send_message = sub { + my ($command, @params) = @_; + $this->send_message( + $this->construct_irc_message( + Prefix => $prefix, + Command => $command, + Params => [$current_nick, + @params], + )); + }; + + map { + # ローカルnickとグローバルnickが食い違っていたらその旨を伝える。 + my $network_name = $_->network_name; + my $global_nick = $_->current_nick; + if ($global_nick ne $current_nick) { + $this->send_message( + $this->construct_irc_message( + Prefix => $this->_runloop->sysmsg_prefix(qw(priv system)), + Command => 'NOTICE', + Params => [$current_nick, + "*** Your global nick in $network_name is currently '$global_nick'."])); + } + } values %{$this->_runloop->networks}; + + $send_message->(RPL_YOURHOST, "Your host is $prefix, running version ".::version()); + if (!$this->_runloop->multi_server_mode_p) { + # single server mode + my $network = ($this->_runloop->networks_list)[0]; + + if (defined $network) { + # send isupport + my $msg_tmpl = $this->construct_irc_message( + Prefix => $prefix, + Command => RPL_ISUPPORT, + Params => [$current_nick], + ); + # last param is reserved for 'are supported...' + # and first param for nick + my $max_params = $this->irc_message_class->MAX_PARAMS - 2; + my @params = (); + my $length = 0; + my $flush_msg = sub { + if (@params) { + my $msg = $msg_tmpl->clone; + $msg->push(@params); + $msg->push('are supported by this server'); + $this->send_message($msg); + } + @params = (); + $length = 0; + }; + foreach my $key (keys %{$network->isupport}) { + my $value = $network->isupport->{$key}; + my $str = length($value) ? ($key.'='.$value) : $key; + $length += length($str) + 1; # $str and space + # 余裕を見て400バイトを越えたら行を分ける。 + if ($length >= 400 || scalar(@params) >= $max_params) { + $flush_msg->(); + $length = length($str); + } + push(@params, $str); + } + $flush_msg->(); + } + } + $send_message->(RPL_MOTDSTART, "- $prefix Message of the Day -"); + foreach my $line (main::get_credit()) { + $send_message->(RPL_MOTD, "- ".$line); + } + $send_message->(RPL_ENDOFMOTD, "End of MOTD command."); + + # クライアントに出力。 + # その結果切断されたらループを抜ける。 + $this->flush; + last unless $this->connected; + + # joinしている全てのチャンネルの情報をクライアント送る。 + $this->inform_joinning_channels; + + # 切断されていたらループを抜ける。 + last unless $this->connected; + + # 各モジュールにクライアント追加の通知を出す。 + $this->_runloop->notify_modules('client_attached',$this); + + # 必ずループを抜ける。 + last; + } + } + } + # ログイン作業中にクライアントから受け取ったいかなるメッセージもサーバーには送らない。 + return undef; +} + +sub _receive_after_logged_in { + my ($this,$msg) = @_; + + # ログイン中でない。 + my $command = $msg->command; + + if ($command eq 'NICK') { + if (defined $msg->params) { + # 形式が正しい限りNICKには常に成功して、RunLoopのカレントnickが変更になる。 + # ただしネットワーク名が明示されていた場合はカレントを変更しない。 + my $rawnick = $msg->params->[0]; + my ($nick,undef,$specified) = Multicast::detach($rawnick); + if (Multicast::nick_p($nick)) { + unless ($specified) { + if ($this->_runloop->multi_server_mode_p && + $this->_runloop->current_nick ne $rawnick) { + $this->_runloop->broadcast_to_clients( + $this->construct_irc_message( + Command => 'NICK', + Param => $rawnick, + Remarks => {'fill-prefix-when-sending-to-client' => 1})); + + $this->_runloop->set_current_nick($rawnick); + } + } + } else { + $this->send_message( + $this->construct_irc_message( + Prefix => $this->_runloop->sysmsg_prefix('system'), + Command => ERR_ERRONEOUSNICKNAME, + Params => [$this->_runloop->current_nick, + $rawnick, + 'Erroneous nickname'])); + # これは鯖に送らない。 + $msg = undef; + } + } else { + $this->send_message( + $this->construct_irc_message( + Prefix => $this->_runloop->sysmsg_prefix('system'), + Command => ERR_NONICKNAMEGIVEN, + Params => [$this->_runloop->current_nick, + 'No nickname given'])); + # これは鯖に送らない。 + $msg = undef; + } + } + elsif ($command eq 'QUIT') { + my $quit_message = $msg->param(0); + $quit_message = '' unless defined $quit_message; + + $this->send_message( + $this->construct_irc_message(Command => 'ERROR', + Param => 'Closing Link: '.$this->fullname('error').' ('.$quit_message.')')); + $this->disconnect_after_writing; + + # 接続が切れた事にする。 + $this->_runloop->notify_modules('client_detached',$this); + + # これは鯖に送らない。 + $msg = undef; + } + else { + $msg = LocalChannelManager->shared + ->message_arrived($msg, $this); + } + return $msg; +} + +sub do_namreply { + my ($this, $ch, $network, $max_length, $flush_func) = @_; + + $max_length = 400 if !defined $max_length; + croak('$ch is not specified') if !defined $ch; + croak('$network is not specified') if !defined $network; + croak('$flush_func is not specified') if !defined $flush_func; + my $global_to_local = sub { + Multicast::global_to_local(shift, $network); + }; + my $ch_property_char = do { + if ($ch->switches('s')) { + '@'; + } + elsif ($ch->switches('p')) { + '*'; + } + else { + '='; + } + }; + # 余裕を見てnickの列挙部が $max_length(デフォルト:400) バイトを越えたら行を分ける。 + my $nick_enumeration = ''; + my $flush_enum_buffer = sub { + if ($nick_enumeration ne '') { + $flush_func->( + $this->construct_irc_message( + Prefix => $this->_runloop->sysmsg_prefix('system'), + Command => RPL_NAMREPLY, + Params => [$this->_runloop->current_nick, + $ch_property_char, + Multicast::attach_for_client($ch->name, $network->network_name), + $nick_enumeration])); + $nick_enumeration = ''; + } + }; + my $append_to_enum_buffer = sub { + my $nick_to_append = shift; + if ($nick_enumeration eq '') { + $nick_enumeration = $nick_to_append; + } + else { + $nick_enumeration .= ' '.$nick_to_append; + } + }; + map { + my $person = $_; + my $mode_char = do { + if ($person->has_o) { + '@'; + } + elsif ($person->has_v) { + '+'; + } + else { + ''; + } + }; + $append_to_enum_buffer->($mode_char . $global_to_local->($person->person->nick)); + if (length($nick_enumeration) > $max_length) { + $flush_enum_buffer->(); + } + } values %{$ch->names}; + $flush_enum_buffer->(); + + undef; +} + +sub inform_joinning_channels { + my $this = shift; + my $local_nick = $this->_runloop->current_nick; + + my $send_channelinfo = sub { + my ($network, $ch) = @_; + my $ch_name = Multicast::attach_for_client($ch->name, $network->network_name); + + # まずJOIN + $this->send_message( + $this->construct_irc_message( + Prefix => $this->fullname, + Command => 'JOIN', + Param => $ch_name)); + # 次にRPL_TOPIC(あれば) + if ($ch->topic ne '') { + $this->send_message( + $this->construct_irc_message( + Prefix => $this->_runloop->sysmsg_prefix('system'), + Command => RPL_TOPIC, + Params => [$local_nick,$ch_name,$ch->topic])); + } + # 次にRPL_TOPICWHOTIME(あれば) + if (defined($ch->topic_who)) { + $this->send_message( + $this->construct_irc_message( + Prefix => $this->_runloop->sysmsg_prefix('system'), + Command => RPL_TOPICWHOTIME, + Params => [$local_nick,$ch_name,$ch->topic_who,$ch->topic_time])); + } + # 次にRPL_NAMREPLY + my $flush_namreply = sub { + my $msg = shift; + $this->send_message($msg); + }; + $this->do_namreply($ch, $network, undef, $flush_namreply); + # 最後にRPL_ENDOFNAMES + $this->send_message( + $this->construct_irc_message( + Prefix => $this->_runloop->sysmsg_prefix('system'), + Command => RPL_ENDOFNAMES, + Params => [$local_nick,$ch_name,'End of NAMES list'])); + + # channel-infoフックの引数は (IrcIO::Client, 送信用チャンネル名, ネットワーク, ChannelInfo) + eval { + IrcIO::Client::HookTarget->shared->call( + 'channel-info', $this, $ch_name, $network, $ch); + }; if ($@) { + # エラーメッセージは表示するが、送信処理は続ける + $this->_runloop->notify_error(__PACKAGE__." hook call error: $@"); + } + + # クライアントに出力。 + # その結果切断されたら関数を抜ける。 + $this->flush; + last CONNECTING unless $this->connected; + }; + + my %channels = map { + my $network = $_; + map { + my $ch = $_; + (Multicast::attach($ch->name, $network->network_name) => + [$network, $ch]); + } values %{$network->channels}; + } values %{$this->_runloop->networks}; + + CONNECTING: + while (1) { + # Mask を使って、マッチしたものを出力 + foreach ($this->_conf_networks-> + fixed_channels('block')->channel('all')) { + my $mask = $_; + foreach (keys %channels) { + my $ch_name = $_; + if (Mask::match($mask, $ch_name)) { + $send_channelinfo->(@{$channels{$ch_name}}); + delete $channels{$ch_name}; + } + } + } + + # のこりを出力 + foreach (values %channels) { + $send_channelinfo->(@$_); + } + + last; + } +} + +# ----------------------------------------------------------------------------- +# クライアントにチャンネル情報(JOIN,TOPIC,NAMES等)を渡した直後に呼ばれるフック。 +# チャンネル名(multi server modeならネットワーク名付き)を引数として、 +# チャンネル一つにつき一度ずつ呼ばれる。 +# +# my $hook = IrcIO::Client::Hook->new(sub { +# my $hook_itself = shift; +# # 何らかの処理を行なう。 +# })->install('channel-info'); # チャンネル情報転送時にこのフックを呼ぶ。 +# ----------------------------------------------------------------------------- +package IrcIO::Client::Hook; +use FunctionalVariable; +use base 'Hook'; + +our $HOOK_TARGET_NAME = 'IrcIO::Client::HookTarget'; +our @HOOK_NAME_CANDIDATES = qw/channel-info/; +our $HOOK_NAME_DEFAULT = 'channel-info'; +our $HOOK_TARGET_DEFAULT; +FunctionalVariable::tie( + \$HOOK_TARGET_DEFAULT, + FETCH => sub { + IrcIO::Client::HookTarget->shared; + }, + ) unless defined $HOOK_TARGET_DEFAULT; + +# ----------------------------------------------------------------------------- +package IrcIO::Client::HookTarget; +use Hook; +our @ISA = 'HookTarget'; +use Tiarra::SharedMixin; + +sub _new { + return bless {} => shift; +} + +sub call { + my ($this, $name, @args) = @_; + $this->call_hooks($name, @args); +} + +1; diff -urN /non-existant-dir/main/IrcIO/Server.pm tiarra-20080510/main/IrcIO/Server.pm --- /non-existant-dir/main/IrcIO/Server.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/main/IrcIO/Server.pm 2008-05-11 00:25:24.000000000 +0900 @@ -0,0 +1,1373 @@ +# ----------------------------------------------------------------------------- +# $Id: Server.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +# IrcIO::ServerはIRCサーバーに接続し、IRCメッセージをやり取りするクラスです。 +# このクラスはサーバーからメッセージを受け取ってチャンネル情報や現在のnickなどを保持しますが、 +# 受け取ったメッセージをモジュールに通したり各クライアントに転送したりはしません。 +# それはRunLoopの役目です。 +# ----------------------------------------------------------------------------- +package IrcIO::Server; +use strict; +use warnings; +use base qw(IrcIO); +use Carp; +use ChannelInfo; +use PersonalInfo; +use PersonInChannel; +use UNIVERSAL; +use Multicast; +use NumericReply; +use Tiarra::Utils; +use Tiarra::Socket::Connect; +use Tiarra::Resolver; +utils->define_attr_getter(0, + qw(network_name current_nick logged_in), + qw(server_hostname isupport config), + [qw(host server_host)]); +utils->define_attr_accessor(0, qw(state finalizing)); +utils->define_attr_enum_accessor('state', 'eq', + qw(connecting finalizing terminating), + qw(terminated finalized connected), + qw(reconnecting)); + + +sub out_encoding { shift->config_local_or_general('out-encoding', 'server-') } +sub in_encoding { shift->config_local_or_general('in-encoding', 'server-') } + +sub new { + my ($class,$runloop,$network_name) = @_; + my $this = $class->SUPER::new( + $runloop, + name => "network/$network_name"); + $this->{network_name} = $network_name; + $this->{current_nick} = ''; # 現在使用中のnick。ログインしていなければ空。 + $this->{server_hostname} = ''; # サーバが主張している hostname。こちらもログインしてなければ空。 + + $this->{logged_in} = 0; # このサーバーへのログインに成功しているかどうか。 + $this->{new_connection} = 1; + + $this->{receiving_namreply} = {}; # RPL_NAMREPLYを受け取ると<チャンネル名,1>になり、RPL_ENDOFNAMESを受け取るとそのチャンネルの要素が消える。 + $this->{receiving_banlist} = {}; # 同上。RPL_BANLIST + $this->{receiving_exceptlist} = {}; # 同上。RPL_EXCEPTLIST + $this->{receiving_invitelist} = {}; # 同上、RPL_INVITELIST + + $this->{channels} = {}; # 小文字チャンネル名 => ChannelInfo + $this->{people} = {}; # nick => PersonalInfo + $this->{isupport} = {}; # isupport + + $this->{connecting} = undef; + $this->{finalizing} = undef; + $this->state('initializing'); + + $this->reconnect; +} + +sub connecting { defined shift->{connecting}; } + +sub _connect_interrupted { + my $this = shift; + $this->state_terminating || $this->state_finalizing || + $this->state_terminated || $this->state_finalized; +} + +sub _gen_msg { + my ($this, $msg) = @_; + + $this->name.': '.$msg; +} + +sub die { + my ($this, $msg) = @_; + CORE::die($this->_gen_msg($msg)); +} + +sub warn { + my ($this, $msg) = @_; + CORE::warn($this->_gen_msg($msg)); +} + +sub printmsg { + my ($this, $msg) = @_; + +# if (defined $this->{last_msg} && +# $this->{last_msg}->[0] eq $msg && +# $this->{last_msg}->[1] <= (time - 10)) { +# # repeated +# return +# } +# $this->{last_msg} = [$msg, time]; + ::printmsg($this->_gen_msg($msg)); +} + +sub nick_p { + my ($this, $nick) = @_; + + Multicast::nick_p($nick, $this->isupport->{NICKLEN}); +} + +sub channel_p { + my ($this, $name) = @_; + + Multicast::channel_p($name, $this->isupport->{CHANTYPES}); +} + +sub channels { + # {小文字チャンネル名 => ChannelInfo}のハッシュリファを返す。 + # @options(省略可能): + # 'even-if-kicked-out': 既に自分が蹴り出されてゐるチャンネルも返す。この動作は高速である。 + my ($this, @options) = @_; + if (defined $options[0] && $options[0] eq 'even-if-kicked-out') { + $this->{channels}; + } + else { + # kicked-outフラグが立つてゐないチャンネルのみ返す。 + my %result; + while (my ($name, $ch) = each %{$this->{channels}}) { + if (!$ch->remark('kicked-out')) { + $result{$name} = $ch; + } + } + \%result; + } +} + +sub channels_list { + # @options(省略可能): + # 'even-if-kicked-out': 既に自分が蹴り出されてゐるチャンネルも返す。この動作は高速である。 + my ($this, @options) = @_; + if (defined $options[0] && $options[0] eq 'even-if-kicked-out') { + values %{$this->{channels}}; + } + else { + # kicked-outフラグが立つてゐないチャンネルのみ返す。 + grep { + !$_->remarks('kicked-out'); + } values %{$this->{channels}}; + } +} + +sub person_list { + values %{shift->{people}}; +} + +sub fullname { + $_[0]->{current_nick}.'!'.$_[0]->{user_shortname}.'@'.$_[0]->{server_host}; +} + +sub config_local_or_general { + my ($this, $base, $general_prefix, $local_prefix, $default) = @_; + + foreach ([$this->config, $local_prefix], + [$this->_conf_general, $general_prefix]) { + my ($conf, $prefix) = @$_; + $prefix = '' unless defined $prefix; + my $value = $conf->get("$prefix$base"); + if (defined $value) { + return $value; + } + } + return $default; +} + +sub reload_config { + my $this = shift; + my $conf = $this->{config} = $this->_conf->get($this->{network_name}); + $this->{server_host} = $conf->host; + $this->{server_port} = $conf->port; + $this->{server_password} = $conf->password; + $this->{initial_nick} = $this->config_local_or_general('nick'); # ログイン時に設定するnick。 + $this->{user_shortname} = $this->config_local_or_general('user'); + $this->{user_realname} = $this->config_local_or_general('name'); + $this->{prefer_socket_types} = [qw(ipv6 ipv4)]; +} + +sub destination { + my $this = shift; + Tiarra::Socket->repr_destination( + host => $this->{server_host}, + addr => $this->{server_addr}, + port => $this->{server_port}, + type => $this->{proto}); +} + +sub person_if_exists { + my ($this, $nick) = @_; + $this->{people}{$nick}; +} + +sub person { + # nick以外は全て省略可能。 + # 未知のnickが指定された場合は新規に追加する。 + my ($this,$nick,$username,$userhost,$realname,$server) = @_; + return if !defined $nick; + + my $info = $this->{people}->{$nick}; + if (!defined($info)) { + $info = $this->{people}->{$nick} = + new PersonalInfo(Nick => $nick, + UserName => $username, + UserHost => $userhost, + RealName => $realname, + Server => $server); + } + else { + $info->username($username); + $info->userhost($userhost); + $info->realname($realname); + $info->server($server); + } + $info; +} + +sub channel { + my $this = $_[0]; + my $channel_name = Multicast::lc($_[1]); + $this->{channels}->{$channel_name}; +} + +sub _queue_retry { + my $this = shift; + + $this->state_reconnecting(1); + + $this->_cleanup if defined $this->{timer}; + $this->{connecting} = undef; + $this->{timer} = Timer->new( + Name => $this->_gen_msg('retry timer'), + After => 15, + Code => sub { + $this->{timer} = undef; + return if $this->finalizing; + $this->reconnect; + })->install; +} + +sub reconnect { + my $this = shift; + $this->reload_config; + $this->connect; +} + +# connect --(resolve)--> stage_1 --> (queueing) --> try_next --> +# each connect method +# ok -> attach +# err -> _connect_error + +sub connect { + my $this = shift; + #return if $this->connected; + croak 'connected!' if $this->connected; + croak 'connecting!' if $this->connecting; + $this->finalizing(undef); + + # 初期化すべきフィールドを初期化 + $this->{nick_retry} = 0; + $this->{logged_in} = undef; + $this->state_connecting(1); + my $conn_stat = $this->{connection_status} = { + start => time, + tried => [], + }; + + Tiarra::Resolver->resolve('addr', $this->{server_host}, sub { + $this->_connect_stage_1(@_); + }); + $this; +} + +sub _connect_stage_1 { + my ($this, $entry) = @_; + + my %addrs_by_types; + my $server_port = $this->{server_port}; + + return if $this->finalizing; + + if ($entry->answer_status eq $entry->ANSWER_OK) { + foreach my $addr (@{$entry->answer_data}) { + if ($addr =~ m/^(?:\d+\.){3}\d+$/) { + push (@{$addrs_by_types{ipv4}}, $addr); + } elsif ($addr =~ m/^[0-9a-fA-F:]+$/) { + push (@{$addrs_by_types{ipv6}}, $addr); + } else { + $this->die("unsupported addr type: $addr"); + } + } + } else { + $this->printmsg("Couldn't resolve hostname: $this->{server_host}"); + $this->_queue_retry; + return; + } + + foreach my $sock_type (@{$this->{prefer_socket_types}}) { + my $struct; + push (@{$this->{connection_queue}}, + map { + $struct = { + type => $sock_type, + addr => $_, + host => $entry->query_data, + port => $server_port, + }; + } @{$addrs_by_types{$sock_type}}); + } + $this->_connect_try_next; +} + +sub _connect_try_next { + my $this = shift; + + return if $this->finalizing; + my $trying = + $this->{connecting} = shift @{$this->{connection_queue}}; + if (defined $trying) { + my $methodname = '_try_connect_' . $this->{connecting}->{type}; + $this->$methodname($trying); + } else { + $this->printmsg("Couldn't connect to any host"); + $this->_queue_retry; + return; + } +} + +sub _try_connect_ipv4 { + my ($this, $conn_struct) = @_; + + my %additional; + my $ipv4_bind_addr = + $this->config_local_or_general('ipv4-bind-addr') || + $this->config_local_or_general('bind-addr'); # 下は過去互換性の為に残す。 + if (defined $ipv4_bind_addr) { + $additional{bind_addr} = $ipv4_bind_addr; + } + $this->_try_connect_socket($conn_struct, %additional); +} + +sub _try_connect_ipv6 { + my ($this, $conn_struct) = @_; + + my %additional; + my $ipv6_bind_addr = $this->config_local_or_general('ipv6-bind-addr'); + if (defined $ipv6_bind_addr) { + $additional{bind_addr} = $ipv6_bind_addr; + } + + $this->_try_connect_socket($conn_struct, %additional); +} + +sub _try_connect_socket { + my ($this, $conn_struct, %additional) = @_; + + $this->{connector} = Tiarra::Socket::Connect->new( + host => $conn_struct->{host}, + addr => $conn_struct->{addr}, + port => $conn_struct->{port}, + callback => sub { + my ($subject, $socket, $obj) = @_; + + if ($subject eq 'sock') { + $this->attach($socket); + } elsif ($subject eq 'error') { + $this->_connect_error($obj); + } elsif ($subject eq 'warn') { + $this->_connect_warn($obj); + } + }, + %additional); + $this; +} + +sub attach { + my ($this, $connector) = @_; + + $this->SUPER::attach($connector->sock); + $this->{connecting} = undef; + $this->{server_addr} = $connector->current_addr; + $this->{proto} = $connector->current_type; + $this->state_connected(1); + + $this->_send_connection_messages; + + $this->{connector} = undef; + $this->printmsg("Opened connection to ". $this->destination ."."); + $this->install; + $this; +} + +sub _connect_error { + my ($this, $msg) = @_; + + # avoid double error message (we don't use timeout) + #$this->printmsg("Couldn't connect to ".$this->destination.": $msg\n"); + $this->_connect_try_next; +} + +sub _connect_warn { + my ($this, $msg) = @_; + + $this->printmsg("$msg\n"); +} + +sub _send_connection_messages { + my $this = shift; + # (PASS) -> NICK -> USERの順に送信し、中に入る。 + # NICKが成功したかどうかは接続後のreceiveメソッドが判断する。 + my $server_password = $this->{server_password}; + if (defined $server_password && $server_password ne '') { + $this->send_message($this->construct_irc_message( + Command => 'PASS', + Param => $this->{server_password})); + } + if (!defined $this->{current_nick} || $this->{current_nick} eq '') { + $this->{current_nick} = $this->{initial_nick}; + } + $this->send_message($this->construct_irc_message( + Command => 'NICK', + Param => $this->{current_nick})); + + # +iなどの文字列からユーザーモード値を算出する。 + my $usermode = 0; + if (my $usermode_str = $this->_conf_general->user_mode) { + if ($usermode_str =~ /^\+/) { + foreach my $c (split //,substr($usermode_str,1)) { + if ($c eq 'w') { + $usermode |= (1 << 2); + } + elsif ($c eq 'i') { + $usermode |= (1 << 3); + } + } + } + } + $this->send_message($this->construct_irc_message( + Command => 'USER', + Params => [$this->{user_shortname}, + $usermode, + '*', + $this->{user_realname}])); +} + +sub terminate { + my ($this, $msg) = @_; + + $this->_interrupt($msg, 'terminating'); +} + +sub finalize { + my ($this, $msg) = @_; + + $this->_interrupt($msg, 'finalizing'); + $this->finalizing(1); +} + +sub _interrupt { + my ($this, $msg, $state) = @_; + + if ($this->logged_in) { + $this->state($state); + $this->quit($msg); + } elsif ($this->state_connecting || $this->state_reconnecting) { + $this->state($state); + $this->_cleanup; + } else { + if (!$this->state_connected) { + $this->warn('_interrupt/unexpected state: '.$this->state) + if &::debug_mode; + } + $this->state($state); + $this->disconnect; + } +} + +sub disconnect { + my ($this, $genre, $errno, @params) = @_; + + $this->_cleanup; + $this->SUPER::disconnect($genre, $errno, @params); + if (defined $errno) { + $this->printmsg($this->sock_errno_to_msg( + $errno, + "Disconnected from ".$this->destination.": $genre error")); + } else { + $this->printmsg("Disconnected from ".$this->destination."."); + } + if ($this->state_reconnecting || $this->state_connected) { + $this->state_reconnecting(1); + $this->reload_config; + $this->_queue_retry; + } + $this->{logged_in} = undef; +} + +sub _cleanup { + my ($this, $mode) = @_; + + $this->{connecting} = undef; + if (defined $this->{connector}) { + $this->{connector}->interrupt; + $this->{connector} = undef; + } + if (defined $this->{timer}) { + $this->{timer}->uninstall; + $this->{timer} = undef; + } + if ($this->state_terminating) { + $this->state_terminated(1); + } elsif ($this->state_finalizing) { + $this->state_finalized(1); + } + # remove pong drop counter + $this->remark('pong-drop-counter', undef, 'delete'); +} + +sub quit { + my ($this, $msg) = @_; + return $this->send_message( + $this->construct_irc_message( + Command => 'QUIT', + Param => $msg)); +} + +sub send_message { + my ($this,$msg) = @_; + + if (!defined $msg) { + croak "IrcIO::Server->send_message, Arg[1] was undef.\n"; + } + elsif (!ref($msg)) { + croak "IrcIO::Server->send_message, Arg[1] was not ref.\n"; + } + elsif (!UNIVERSAL::isa($msg, $this->irc_message_class)) { + croak "IrcIO::Server->send_message, Arg[1] was bad ref: ".ref($msg)."\n"; + } + + # 各モジュールへ通知 + #$this->_runloop->notify_modules('notification_of_message_io',$msg,$this,'out'); + + $this->SUPER::send_message( + $msg, + $this->out_encoding); +} + +sub read { + my $this = shift; + $this->SUPER::read($this->in_encoding); + + # 接続が切れたら、各モジュールとRunLoopへ通知 + if (!$this->connected) { + $this->_runloop->notify_modules('disconnected_from_server',$this); + $this->_runloop->disconnected_server($this); + } +} + +sub pop_queue { + my ($this) = shift; + my $msg = $this->SUPER::pop_queue; + + # このメソッドはログインしていなければログインするが、 + # パスワードが違うなどで何度やり直してもログイン出来る見込みが無ければ + # 接続を切ってからdieします。 + if (defined $msg) { + # ログイン作業中か？ + if ($this->logged_in) { + # ログイン作業中でない。 + return $this->_receive_after_logged_in($msg); + } + else { + return $this->_receive_while_logging_in($msg); + } + } + return $msg; +} + +sub _receive_while_logging_in { + my ($this,$first_msg) = @_; + + # まだログイン作業中であるのなら、ログインに成功したかどうかを + # 最初に受け取った行が001(成功)か433(nick重複)かそれ以外かで判断する。 + my $reply = $first_msg->command; + if ($reply eq RPL_WELCOME) { + # 成功した。 + $this->{current_nick} = $first_msg->param(0); + $this->{server_hostname} = $first_msg->prefix; + if (!$this->_runloop->multi_server_mode_p && + $this->_runloop->current_nick ne $this->{current_nick}) { + $this->_runloop->broadcast_to_clients( + $this->construct_irc_message( + Command => 'NICK', + Param => $first_msg->param(0), + Remarks => {'fill-prefix-when-sending-to-client' => 1 + })); + + $this->_runloop->set_current_nick($first_msg->param(0)); + } + $this->{logged_in} = 1; + $this->person($this->{current_nick}, + $this->{user_shortname}, + $this->{user_realname}); + + + $this->printmsg("Logged-in successfuly into ".$this->destination."."); + + # 各モジュールにサーバー追加の通知を行なう。 + $this->_runloop->notify_modules('connected_to_server',$this,$this->{new_connection}); + # 再接続だった場合の処理 + if (!$this->{new_connection}) { + $this->_runloop->reconnected_server($this); + } + $this->{new_connection} = undef; + return; + } + elsif ($reply eq ERR_NICKNAMEINUSE) { + # nick重複。 + $this->_set_to_next_nick($first_msg->param(1)); + return; # 何も返さない→クライアントにはこの結果を知らせない。 + } + elsif ($reply eq ERR_UNAVAILRESOURCE) { + # nick/channel is temporarily unavailable(この場合は nick) + $this->_set_to_next_nick($first_msg->param(1)); + return; # 何も返さない→クライアントにはこの結果を知らせない。 + } + elsif ($reply eq RPL_HELLO) { + # RPL_HELLO (irc2.11.x) + $this->printmsg("Server replied 020(RPL_HELLO). Please wait."); + return; # 何も返さない→クライアントにはこの結果を知らせない。 + } + elsif (grep { $_ eq $reply } qw(NOTICE PRIVMSG)) { + # NOTICE / PRIVMSG + return; # 何もしない + } + elsif ($reply eq 'PING') { + $this->send_message( + $this->construct_irc_message( + Command => 'PONG', + Param => $first_msg->param(0))); + } + else { + # それ以外。手の打ちようがないのでconnectionごと切断してしまう。 + # 但し、エラーニューメリックリプライでもERRORでもなければ無視する。 + if ($reply =~ /^[0-3]\d+/) { + $this->printmsg("Server replied $reply, ignored.\n".$first_msg->serialize."\n"); + return; + } elsif ($reply eq 'ERROR' or $reply !~ m/^\d+/) { + $this->disconnect; + $this->die("Server replied $reply.\n".$first_msg->serialize."\n"); + } + else { + $this->printmsg("Server replied $reply, ignored.\n".$first_msg->serialize."\n"); + return; + } + } + return $first_msg; +} + +sub _receive_after_logged_in { + my ($this,$msg) = @_; + + $this->person($msg->nick,$msg->name,$msg->host); # nameとhostを覚えておく。 + + if (defined $msg->nick && + $msg->nick ne $this->current_nick) { + $msg->remark('message-send-by-other', 1); + } + + if ($msg->command eq 'NICK') { + # nickを変えたのが自分なら、それをクライアントには伝えない。 + my $current_nick = $this->{current_nick}; + if ($msg->nick eq $current_nick) { + $this->{current_nick} = $msg->param(0); + + if ($this->_runloop->multi_server_mode_p) { + # ここで消してしまうとプラグインにすらNICKが行かなくなる。 + # 消す代わりに"do-not-send-to-clients => 1"という註釈を付ける。 + $msg->remark('do-not-send-to-clients',1); + + # ローカルnickと違っていれば、その旨を通知する。 + # 但し、networks/always-notify-new-nickが設定されていれば常に通知する。 + my $local_nick = $this->_runloop->current_nick; + if ($this->_conf_networks->always_notify_new_nick || + $this->{current_nick} ne $local_nick) { + + my $old_nick = $msg->nick; + $this->_runloop->broadcast_to_clients( + $this->construct_irc_message( + Prefix => $this->_runloop->sysmsg_prefix(qw(priv nick::system)), + Command => 'NOTICE', + Params => [$local_nick, + "*** Your global nick in ". + $this->{network_name}." changed ". + "$old_nick -> ". + $this->{current_nick}."."])); + } + } else { + $this->_runloop->set_current_nick($msg->param(0)); + } + } + $this->_NICK($msg); + } + elsif ($msg->command eq ERR_NICKNAMEINUSE) { + # nickが既に使用中 + return $this->_handle_fix_nick($msg); + } + elsif ($msg->command eq ERR_UNAVAILRESOURCE) { + # nick/channel temporary unavaliable + if (Multicast::nick_p($msg->param(1))) { + return $this->_handle_fix_nick($msg); + } + } + elsif ($msg->command eq 'JOIN') { + $this->_JOIN($msg); + } + elsif ($msg->command eq 'KICK') { + $this->_KICK($msg); + } + elsif ($msg->command eq 'MODE') { + $this->_MODE($msg); + } + elsif ($msg->command eq 'NJOIN') { + $this->_NJOIN($msg); + } + elsif ($msg->command eq 'PART') { + $this->_PART($msg); + } + elsif ($msg->command eq 'QUIT' || $msg->command eq 'KILL') { + # QUITとKILLは同じように扱う。 + $this->_QUIT($msg); + } + elsif ($msg->command eq 'TOPIC') { + $this->_TOPIC($msg); + } + else { + my $name = NumericReply::fetch_name($msg->command); + if (defined $name) { + foreach ( + map("RPL_$_", + qw(CHANNELMODEIS NOTOPIC TOPIC TOPICWHOTIME + CREATIONTIME WHOREPLY NAMREPLY ENDOFNAMES + WHOISUSER WHOISSERVER AWAY ENDOFWHOIS + ISUPPORT YOURID), + map({("${_}LIST", "ENDOF${_}LIST");} + qw(INVITE EXCEPT BAN)), + )) { + if ($name eq $_) { + no strict 'refs'; + my $funcname = "_$_"; + &$funcname($this, $msg); # $this->$funcname($msg) + last; + } + } + } + } + return $msg; +} + +sub _KICK { + my ($this,$msg) = @_; + my @ch_names = split(/,/,$msg->param(0)); + my @nicks = split(/,/,$msg->param(1)); + my $kick = sub { + my ($ch,$nick_to_kick) = @_; + if ($nick_to_kick eq $this->{current_nick}) { + # KICKされたのが自分だった + $ch->remarks('kicked-out','1'); + } + else { + $ch->names($nick_to_kick,undef,'delete'); + } + }; + if (@ch_names == @nicks) { + # チャンネル名とnickが1対1で対応 + map { + my ($ch_name,$nick) = ($ch_names[$_],$nicks[$_]); + my $ch = $this->channel($ch_name); + if (defined $ch) { + #$ch->names($nick,undef,'delete'); + $kick->($ch,$nick); + } + } 0 .. $#ch_names; + } + elsif (@ch_names == 1) { + # 一つのチャンネルから1人以上をkick + my $ch = $this->channel($ch_names[0]); + if (defined $ch) { + map { + #$ch->names($_,undef,'delete'); + $kick->($ch,$_); + } @nicks; + } + } +} + +sub _MODE { + my ($this,$msg) = @_; + if ($msg->param(0) eq $this->{current_nick}) { + # MODEの対象が自分なのでここでは無視。 + return; + } + + my $ch = $this->channel($msg->param(0)); + if (defined $ch) { + my $n_params = @{$msg->params}; + + my $plus = 0; # 現在評価中のモードが+なのか-なのか。 + my $mode_char_pos = 1; # 現在評価中のmode characterの位置。 + my $mode_param_offset = 0; # $mode_char_posから幾つの追加パラメタを拾ったか。 + + my $fetch_param = sub { + $mode_param_offset++; + return $msg->param($mode_char_pos + $mode_param_offset); + }; + + for (;$mode_char_pos < $n_params;$mode_char_pos += $mode_param_offset + 1) { + $mode_param_offset = 0; # これは毎回リセットする。 + foreach my $c (split //,$msg->param($mode_char_pos)) { + my $add_or_delete = ($plus ? 'add' : 'delete'); + my $undef_or_delete = ($plus ? undef : 'delete'); + if ($c eq '+') { + $plus = 1; + } + elsif ($c eq '-') { + $plus = 0; + } + elsif (index('aimnpqrst',$c) != -1) { + $ch->switches($c,1,$undef_or_delete); + } + elsif ($c eq 'b') { + $ch->banlist($add_or_delete,&$fetch_param); + } + elsif ($c eq 'e') { + $ch->exceptionlist($add_or_delete,&$fetch_param); + } + elsif ($c eq 'I') { + $ch->invitelist($add_or_delete,&$fetch_param); + } + elsif ($c eq 'k') { + $ch->parameters('k',&$fetch_param,$undef_or_delete); + } + elsif ($c eq 'l') { + $ch->parameters('l',($plus ? &$fetch_param : undef),$undef_or_delete); + } + elsif ($c eq 'o' || $c eq 'O') { + # oとOは同一視 + eval { + $ch->names(&$fetch_param)->has_o($plus); + }; + } + elsif ($c eq 'v') { + eval { + $ch->names(&$fetch_param)->has_v($plus); + }; + } + } + } + } +} + +sub _JOIN { + my ($this,$msg) = @_; + + map { + m/^([^\x07]+)(?:\x07(.*))?/; + my ($ch_name,$mode) = ($1,(defined $2 ? $2 : '')); + + my $ch = $this->channel($ch_name); + if (defined $ch) { + # 知っているチャンネル。もしkickedフラグが立っていたらクリア。 + $ch->remarks('kicked-out',undef,'delete'); + } + else { + # 知らないチャンネル。 + $ch = ChannelInfo->new($ch_name,$this->{network_name}); + $this->{channels}{Multicast::lc($ch_name)} = $ch; + } + $ch->names($msg->nick, + new PersonInChannel( + $this->person($msg->nick,$msg->name,$msg->host), + index($mode,"o") != -1 || index($mode,"O") != -1, # oもOも今は同一視 + index($mode,"v") != -1)); + } split(/,/,$msg->param(0)); +} + +sub _NJOIN { + my ($this,$msg) = @_; + my $ch_name = $msg->param(0); + my $ch = $this->channel($ch_name); + unless (defined $ch) { + # 知らないチャンネル。 + $ch = ChannelInfo->new($ch_name,$this->{network_name}); + $this->{channels}{Multicast::lc($ch_name)} = $ch; + } + map { + m/^([@+]*)(.+)$/; + my ($mode,$nick) = ($1,$2); + + $ch->names($nick, + new PersonInChannel( + $this->person($nick), + index($mode,"@") != -1, # 今は@と@@を同一視。 + index($mode,"+") != -1)); + } split(/,/,$msg->param(1)); +} + +sub _PART { + my ($this,$msg) = @_; + map { + my $ch_name = $_; + my $ch = $this->channel($ch_name); + if (defined $ch) { + if ($msg->nick eq $this->{current_nick}) { + # PARTしたのが自分だった + delete $this->{channels}->{Multicast::lc($ch_name)}; + } + else { + $ch->names($msg->nick,undef,'delete'); + } + } + } split(/,/,$msg->param(0)); + + # 全チャンネルを走査し、このnickを持つ人物が一人も居なくなつてゐたらpeopleからも消す。 + my $alive; + foreach my $ch (values %{$this->{channels}}) { + if (defined $ch->names($msg->nick)) { + $alive = 1; + } + } + if (!$alive) { + delete $this->{people}{$msg->nick}; + } +} + +sub _NICK { + my ($this,$msg) = @_; + # PersonalInfoとChannelInfoがnickを持っているので書き換える。 + my ($old,$new) = ($msg->nick,$msg->param(0)); + + if (!defined $this->{people}->{$old}) { + return; + } + + $this->{people}->{$old}->nick($new); + $this->{people}->{$new} = $this->{people}->{$old}; + delete $this->{people}->{$old}; + + my @channels = grep { + defined $_->names($old); + } values %{$this->{channels}}; + + # このNICKが影響を及ぼした全チャンネル名のリストを + # "affected-channels"として註釈を付ける。 + my @affected = map { + my $ch = $_; + $ch->names($new,$ch->names($old)); + $ch->names($old,undef,'delete'); + $ch->name; + } @channels; + $msg->remark('affected-channels',\@affected); +} + +sub _QUIT { + my ($this,$msg) = @_; + # people及びchannelsから削除する。 + delete $this->{people}->{$msg->nick}; + + my @channels = grep { + defined $_->names($msg->nick); + } values %{$this->{channels}}; + + # このNICKが影響を及ぼした全チャンネル名のリストを + # "affected-channels"として註釈を付ける。 + my @affected = map { + my $ch = $_; + $ch->names($msg->nick,undef,'delete'); + $ch->name; + } @channels; + $msg->remark('affected-channels',\@affected); +} + +sub _TOPIC { + my ($this,$msg) = @_; + my $ch = $this->channel($msg->param(0)); + if (defined $ch) { + # 古いトピックを"old-topic"として註釈を付ける。 + $msg->remark('old-topic', $ch->topic); + $ch->topic($msg->param(1)); + + # topic_who と topic_time を指定する + $ch->topic_who($msg->prefix); + $ch->topic_time(time); + } +} + +sub _RPL_NAMREPLY { + my ($this,$msg) = @_; + my $ch = $this->channel($msg->param(2)); + return unless defined $ch; + + my $receiving_namreply = $this->{receiving_namreply}->{$msg->param(2)}; + unless (defined $receiving_namreply && + $receiving_namreply == 1) { + # NAMESを初期化 + $ch->names(undef,undef,'clear'); + # NAMREPLY受信中フラグを立てる + $this->{receiving_namreply}->{$msg->param(2)} = 1; + } + + if (defined $ch) { + # @なら+s,*なら+p、=ならそのどちらでもない事が確定している。 + my $ch_property = $msg->param(1); + if ($ch_property eq '@') { + $ch->switches('s',1); + $ch->switches('p',undef,'delete'); + } + elsif ($ch_property eq '*') { + $ch->switches('s',undef,'delete'); + $ch->switches('p',1); + } + else { + $ch->switches('s',undef,'delete'); + $ch->switches('p',undef,'delete'); + } + + my @people = map { + m/^([@\+]{0,2})(.+)$/; + my ($mode,$nick) = ($1,$2); + + $ch->names($nick, + new PersonInChannel( + $this->person($nick), + index($mode,"@") != -1, + index($mode,"+") != -1)); + } split(/ /,$msg->param(3)); + } +} + +sub _RPL_ENDOFNAMES { + my ($this,$msg) = @_; + delete $this->{receiving_namreply}->{$msg->param(1)}; +} + +sub _RPL_WHOISUSER { + my ($this,$msg) = @_; + my $p = $this->{people}->{$msg->param(1)}; + if (defined $p) { + $p->username($msg->param(2)); + $p->userhost($msg->param(3)); + $p->realname($msg->param(5)); + $this->_START_WHOIS_REPLY($p); + } +} + +sub _START_WHOIS_REPLY { + my ($this,$p) = @_; + $p->remark('wait-rpl_away', 1); +} + +sub _RPL_ENDOFWHOIS { + my ($this,$msg) = @_; + my $p = $this->{people}->{$msg->param(1)}; + if (defined $p) { + if ($p->remark('wait-rpl_away')) { + $p->remark('wait-rpl_away', 0); + $p->away(''); + } + } +} + +sub _RPL_AWAY { + my ($this,$msg) = @_; + my $p = $this->{people}->{$msg->param(1)}; + if (defined $p) { + $p->remark('wait-rpl_away', 0); + $p->away($msg->param(2)); + } +} + +sub _RPL_WHOISSERVER { + my ($this,$msg) = @_; + my $p = $this->{people}->{$msg->param(1)}; + if (defined $p) { + $p->server($msg->param(2)); + } +} + +sub _RPL_NOTOPIC { + my ($this,$msg) = @_; + my $ch = $this->channel($msg->param(1)); + if (defined $ch) { + $ch->topic(''); + } +} + +sub _RPL_TOPIC { + my ($this,$msg) = @_; + my $ch = $this->channel($msg->param(1)); + if (defined $ch) { + $ch->topic($msg->param(2)); + } +} + +sub _RPL_TOPICWHOTIME { + my ($this,$msg) = @_; + my $ch = $this->channel($msg->param(1)); + if (defined $ch) { + $ch->topic_who($msg->param(2)); + $ch->topic_time($msg->param(3)); + } +} + +sub _RPL_CREATIONTIME { + my ($this,$msg) = @_; + my $ch = $this->channel($msg->param(1)); + if (defined $ch) { + $ch->remark('creation-time', $msg->param(2)); + } +} + +sub _RPL_INVITELIST { + my ($this,$msg) = @_; + my $ch = $this->channel($msg->param(1)); + + my $receiving_invitelist = $this->{receiving_invitelist}->{$msg->param(1)}; + if (defined $receiving_invitelist && + $receiving_invitelist == 1) { + # +Iリストを初期化 + $ch->invitelist(undef,undef,'clear'); + # INVITELIST受信中フラグを立てる + $this->{receiving_invitelist}->{$msg->param(1)} = 1; + } + + if (defined $ch) { + # 重複防止のため、一旦deleteしてからadd。 + $ch->invitelist('delete',$msg->param(2)); + $ch->invitelist('add',$msg->param(2)); + } +} + +sub _RPL_ENDOFINVITELIST { + my ($this,$msg) = @_; + delete $this->{receiving_invitelist}->{$msg->param(1)}; +} + +sub _RPL_EXCEPTLIST { + my ($this,$msg) = @_; + my $ch = $this->channel($msg->param(1)); + + my $receiving_exceptlist = $this->{receiving_exceptlist}->{$msg->param(1)}; + if (defined $receiving_exceptlist && + $receiving_exceptlist == 1) { + # +eリストを初期化 + $ch->exceptionlist(undef,undef,'clear'); + # EXCEPTLIST受信中フラグを立てる + $this->{receiving_exceptlist}->{$msg->param(1)} = 1; + } + + if (defined $ch) { + # 重複防止のため、一旦deleteしてからadd。 + $ch->exceptionlist('delete',$msg->param(2)); + $ch->exceptionlist('add',$msg->param(2)); + } +} + +sub _RPL_ENDOFEXCEPTLIST { + my ($this,$msg) = @_; + delete $this->{receiving_exceptlist}->{$msg->param(1)}; +} + +sub _RPL_BANLIST { + my ($this,$msg) = @_; + my $ch = $this->channel($msg->param(1)); + + my $receiving_banlist = $this->{receiving_banlist}->{$msg->param(1)}; + if (defined $receiving_banlist && + $receiving_banlist == 1) { + # +bリストを初期化 + $ch->banlist(undef,undef,'clear'); + # BANLIST受信中フラグを立てる + $this->{receiving_banlist}->{$msg->param(1)} = 1; + } + + if (defined $ch) { + # 重複防止のため、一旦deleteしてからadd。 + $ch->banlist('delete',$msg->param(2)); + $ch->banlist('add',$msg->param(2)); + } +} + +sub _RPL_ENDOFBANLIST { + my ($this,$msg) = @_; + delete $this->{receiving_banlist}->{$msg->param(1)}; +} + +sub _RPL_WHOREPLY { + my ($this,$msg) = @_; + my $p = $this->{people}->{$msg->param(5)}; + if (defined $p) { + $p->username($msg->param(2)); + $p->userhost($msg->param(3)); + $p->server($msg->param(4)); + $p->realname((split / /,$msg->param(7),2)[1]); + if ($msg->param(6) =~ /^G/) { + $p->away('Gone.'); + } else { + $p->away(''); + } + my $hops = $this->remark('server-hops') || {}; + $hops->{$p->server} = (split / /,$msg->param(7),2)[0]; + $this->remark('server-hops', $hops); + } + + #use Data::Dumper; + #open(LOG,"> log.txt"); + #print LOG "------- people --------\n"; + #print LOG Dumper($this->{people}),"\n"; + #print LOG "------- channels --------\n"; + #print LOG Dumper($this->{channels}),"\n"; + #close(LOG); +} + +sub _RPL_CHANNELMODEIS { + my ($this,$msg) = @_; + # 既知のチャンネルなら、そのチャンネルに + # switches-are-known => 1という備考を付ける。 + my $ch = $this->channel($msg->param(1)); + if (defined $ch) { + $ch->remarks('switches-are-known',1); + + # switches と parameters は必ず得られると仮定して、クリア処理を行う + $ch->switches(undef, undef, 'clear'); + $ch->parameters(undef, undef, 'clear'); + } + + # 鯖がMODEを実行したことにして、_MODEに処理を代行させる。 + my @args = @{$msg->params}; + @args = @args[1 .. $#args]; + + $this->_MODE( + $this->construct_irc_message( + Prefix => $msg->prefix, + Command => 'MODE', + Params => \@args)); +} + +sub _RPL_ISUPPORT { + # 歴史的な理由で、 RPL_ISUPPORT(005) は + # RPL_BOUNCE(005) として使われていることがある。 + my ($this,$msg) = @_; + if ($msg->n_params >= 2 && # nick + [params] + 'are supported by this server' + $msg->param($msg->n_params - 1) =~ /supported/i) { + foreach my $param ((@{$msg->params})[1...($msg->n_params - 2)]) { + my ($negate, $key, $value) = $param =~ /^(-)?([[:alnum:]]+)(?:=(.+))?$/; + if (!defined $negate) { + # empty value + $value = '' unless defined $value; + $this->{isupport}->{$key} = $value; + } elsif (!defined $value) { + # negate a previously specified parameter + delete $this->{isupport}->{$key}; + } else { + # inconsistency param + carp("inconsistency RPL_ISUPPORT param: $param"); + } + } + } +} + +sub _RPL_YOURID { + my ($this,$msg) = @_; + + $this->remark('uid', $msg->param(1)); +} + +sub _handle_fix_nick { + my ($this, $msg) = @_; + # 接続時以外のnick重複を処理します。 + my $mode = $this->config_local_or_general('nick-fix-mode'); + + if ($mode == 0) { + # 常に Tiarra が処理します。 + + $this->_set_to_next_nick($msg->param(1)); + return undef; + } elsif ($mode == 1) { + # クライアントにそのまま投げます。 + # 複数のクライアントが nick 重複を処理する場合は非常に危険です。 + # (設定不足の IRC クライアントが複数つながっている場合も含みます) + return $msg; + } elsif ($mode == 2) { + # 対応するエラーメッセージ付きの NOTICE に変換して、 + # クライアントに投げます。 + + my $new_msg = $this->construct_irc_message( + Prefix => $this->_runloop->sysmsg_prefix(qw(priv nick::system)), + Command => 'NOTICE', + Params => [$this->_runloop->current_nick, + ''], + ); + if ($msg->command eq ERR_NICKNAMEINUSE) { + $new_msg->param(1, 'Nickname is already in use: ' . + $msg->param(1)); + } elsif ($msg->command eq ERR_UNAVAILRESOURCE) { + $new_msg->param(1, 'Nick/channel is temporarily unavailable: ' . + $msg->param(1)); + } else { + return $msg; + } + return $new_msg; + } +} + +sub _set_to_next_nick { + my ($this,$failed_nick) = @_; + # failed_nickの次のnickを試します。nick重複でログインに失敗した時に使います。 + my $next_nick = modify_nick($failed_nick, $this->isupport->{NICKLEN}); + + my $msg_for_user = "Nick $failed_nick was already in use in the ".$this->network_name.". Trying ".$next_nick."..."; + $this->send_message( + $this->construct_irc_message( + Command => 'NICK', + Param => $next_nick)); + $this->_runloop->broadcast_to_clients( + $this->construct_irc_message( + Prefix => $this->_runloop->sysmsg_prefix(qw(priv nick::system)), + Command => 'NOTICE', + Params => [$this->_runloop->current_nick,$msg_for_user])); + $this->printmsg($msg_for_user); +} + +sub modify_nick { + my $nick = shift; + my $nicklen = shift || 9; + + if ($nick =~ /^(.*\D)?(\d+)$/) { + # 最後の数文字が数字だったら、それをインクリメント + my $base = $1; + my $next_num = $2 + 1; + if (($next_num - 1) eq $next_num) { + # 桁あふれしているので数字部分を全部消す。 + $nick = $base; + } elsif (length($base . $next_num) <= $nicklen) { + # $nicklen 文字以内に収まるのでこれで試す。 + $nick = $base . $next_num; + } + else { + # 収まらないので $nicklen 文字に縮める。 + $nick = substr($base,0,$nicklen - length($next_num)) . $next_num; + } + } + elsif ($nick =~ /_$/ && length($nick) >= $nicklen) { + # 最後の文字が_で、それ以上_を付けられない場合、それを0に。 + $nick =~ s/_$/0/; + } + else { + # 最後に_を付ける。 + if (length($nick) >= $nicklen) { + $nick =~ s/.$/_/; + } + else { + $nick .= '_'; + } + } + return $nick; +} + +1; diff -urN /non-existant-dir/main/IrcIO.pm tiarra-20080510/main/IrcIO.pm --- /non-existant-dir/main/IrcIO.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/main/IrcIO.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,153 @@ +# ----------------------------------------------------------------------------- +# $Id: IrcIO.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +# IrcIOはIRCサーバー又はクライアントと接続し、IRCメッセージをやり取りする抽象クラスです。 +# ----------------------------------------------------------------------------- +package IrcIO; +use strict; +use warnings; +use Carp; +use Configuration; +use Tiarra::IRC::Message; +use Exception; +use Tiarra::ShorthandConfMixin; +use Tiarra::Utils; +use Tiarra::Socket::Buffered; +use base qw(Tiarra::Socket::Buffered); +use base qw(Tiarra::IRC::NewMessageMixin); +utils->define_attr_getter(0, [qw(_runloop runloop)]); +utils->define_proxy('_runloop', 0, qw(irc_message_class)); + +sub new { + my ($class, $runloop, %opts) = @_; + carp 'runloop is not specified!' unless defined $runloop; + $class->_increment_caller('ircio', \%opts); + my $this = $class->SUPER::new(runloop => $runloop, %opts); + $this->{recv_queue} = []; + $this->{remarks} = {}; + $this; +} + +sub server_p { + shift->isa('IrcIO::Server'); +} + +sub client_p { + shift->isa('IrcIO::Client'); +} + +*remarks = \&remark; +sub remark { + my ($this,$key,$newvalue) = @_; + if (!defined $key) { + croak "IrcIO->remark, Arg[1] is undef.\n"; + } + elsif (defined $newvalue) { + $this->{remarks}->{$key} = $newvalue; + } + elsif (@_ >= 3) { + delete $this->{remarks}{$key}; + } + $this->{remarks}->{$key}; +} + +sub send_message { + my ($this,$msg,$encoding) = @_; + # データを送るように予約する。ソケットの送信の準備が整っていなくてもブロックしない。 + + # msgは生の文字列でも良いしTiarra::IRC::Messageのインスタンスでも良い。 + # 生の文字列を渡す時には、末尾にCRLFを付けてはならない。 + # また、生の文字列については文字コードの変換が行なわれない。 + my $data_to_send = ''; + if (ref($msg) eq '') { + # deprecated. + # FIXME: warnすべきだろうか。 + $data_to_send = "$msg\x0d\x0a"; + } + elsif ($msg->isa($this->irc_message_class)) { + # message_io_hook + my $filtered = $this->_runloop->apply_filters( + [$msg], 'message_io_hook', $this, 'out'); + + # message_encoding_hook + $filtered = $this->_runloop->apply_filters( + $filtered, 'message_encoding_hook', $this, 'out', $encoding); + + foreach (@$filtered) { + $data_to_send .= $_->serialize("remark,$encoding")."\x0d\x0a"; + } + + } + else { + die "IrcIO::send_message : parameter msg was invalid; $msg\n"; + } + + if ($this->connected) { + $this->append($data_to_send); + } + else { + die "IrcIO::send_message : socket is not connected.\n"; + } +} + +sub read { + my ($this,$encoding) = @_; + # このメソッドはIRCメッセージを一行ずつ受け取り、Tiarra::IRC::Messageのインスタンスをキューに溜めます。 + # ソケットに読めるデータが来ていなかった場合、このメソッドは読めるようになるまで + # 操作をブロックします。それがまずい場合は予めselectで読める事を確認しておいて下さい。 + # このメソッドを実行したことで始めてソケットが閉じられた事が分かった場合は、 + # メソッド実行後からはconnectedメソッドが偽を返すようになります。 + + $this->SUPER::read; + + while (1) { + # CRLFまたはLFが行の終わり。 + my $newline_pos = index($this->recvbuf,"\x0a"); + if ($newline_pos == -1) { + # 一行分のデータが届いていない。 + last; + } + + my $current_line = substr($this->recvbuf,0,$newline_pos); + $this->recvbuf(substr($this->recvbuf,$newline_pos+1)); + + # CRLFだった場合、末尾にCRが付いているので取る。 + $current_line =~ s/\x0d$//; + + if (CORE::length($current_line) == 0) { + # 空行はスキップ + next; + } + + my $msg = $this->construct_irc_message( + Line => $current_line, + Encoding => $encoding); + + # message_encoding_hook + my $filtered = $this->_runloop->apply_filters( + [$msg], 'message_encoding_hook', $this, 'in', $encoding); + + # message_io_hook + $filtered = $this->_runloop->apply_filters( + $filtered, 'message_io_hook', $this, 'in'); + + foreach (@$filtered) { + $_->purge_raw_params; + push @{$this->{recv_queue}}, $_; + } + } +} + +sub pop_queue { + # このメソッドは受信キュー内の最も古いものを取り出します。 + # キューが空ならQueueIsEmptyExceptionを投げます。 + my ($this) = @_; + if (@{$this->{recv_queue}} == 0) { + QueueIsEmptyException->new->throw; + } + else { + return shift @{$this->{recv_queue}}; + } +} + +1; diff -urN /non-existant-dir/main/Iterator/ArrayIterator.pm tiarra-20080510/main/Iterator/ArrayIterator.pm --- /non-existant-dir/main/Iterator/ArrayIterator.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/main/Iterator/ArrayIterator.pm 2008-05-11 00:25:24.000000000 +0900 @@ -0,0 +1,79 @@ +# ----------------------------------------------------------------------------- +# Iterator::ArrayIterator +# ----------------------------------------------------------------------------- +# $Id: ArrayIterator.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +# このクラスは配列の値を順番に指すイテレータです。 +# ランダムアクセス可能ですが、巡回は出来ません。 +# +# 情報源としての配列そのものは、このイテレータは保持しません。 +# その代わりに配列への参照を保持します。 +# つまり、このイテレータを使用中に情報源の配列が変化すると +# イテレータの状態も変化します。 +# ----------------------------------------------------------------------------- +package Iterator::ArrayIterator; +use strict; +use warnings; +use base qw(Iterator::RandomAccessIterator); + +sub new { + my ($class,$src_array) = @_; + my $obj = { + source => $src_array, + current_index => 0, # 作られた時にはイテレータは先頭の要素を指している。 + }; + bless $obj,$class; +} + +sub _increment { + my $this = shift; + if (exists $this->{source}->[$this->{current_index}]) { + # 今回はまだ要素が残っている。インクリメントしても要素があるか、または初めてundefになる。 + $this->{current_index}++; + } + else { + # 今回で既にundefを指している。これ以上進めない。 + die "Iterator::ArrayIterator::increment : operation ++ failed. no more elements in this iterator.\n"; + } + $this; +} + +sub _decrement { + my $this = shift; + if ($this->{current_index} > -1) { + $this->{current_index}--; + } + else { + die "Iterator::ArrayIterator::decrement : operation -- failed. iterator pointed at element indexed -1.\n"; + } + $this; +} + +sub _addition { + my ($this,$value) = @_; + my $result = ref($this)->new($this->{source}); + $result->{current_index} = $this->{current_index} + $value; + return $result; +} + +sub _subtract { + my ($this,$value) = @_; + return $this->_addition(-$value); +} + +sub _add_to { + my ($this,$value) = @_; + $this->{current_index} += $value; + return $this; +} + +sub _sub_from { + my ($this,$value) = @_; + return $this->_add_to(-$value); +} + +sub get { + $_[0]->{source}->[$_[0]->{current_index}]; +} + +1; diff -urN /non-existant-dir/main/Iterator/BackwardIterator.pm tiarra-20080510/main/Iterator/BackwardIterator.pm --- /non-existant-dir/main/Iterator/BackwardIterator.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/main/Iterator/BackwardIterator.pm 2008-05-11 00:25:24.000000000 +0900 @@ -0,0 +1,23 @@ +# ----------------------------------------------------------------------------- +# Iterator::BackwardIterator +# ----------------------------------------------------------------------------- +# $Id: BackwardIterator.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +# これらのクラスはそれぞれの操作が行なえる事を示すために用いられる抽象クラスです。 +# インスタンスを生成する事は出来ません。 +# ----------------------------------------------------------------------------- +package Iterator::BackwardIterator; +use strict; +use warnings; +use base qw(Iterator); +use overload + '--' => \&_ope_decrement; + +sub _ope_decrement { + $_[0]->_decrement; +} +sub _decrement { + die "BackwardIterator has to override decrement().\n"; +} + +1; diff -urN /non-existant-dir/main/Iterator/BidirectionalIterator.pm tiarra-20080510/main/Iterator/BidirectionalIterator.pm --- /non-existant-dir/main/Iterator/BidirectionalIterator.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/main/Iterator/BidirectionalIterator.pm 2008-05-11 00:25:24.000000000 +0900 @@ -0,0 +1,13 @@ +# ----------------------------------------------------------------------------- +# Iterator::BidirectionalIterator +# ----------------------------------------------------------------------------- +# $Id: BidirectionalIterator.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +# これらのクラスはそれぞれの操作が行なえる事を示すために用いられる抽象クラスです。 +# インスタンスを生成する事は出来ません。 +# ----------------------------------------------------------------------------- +package Iterator::BidirectionalIterator; +use strict; +use warnings; +use base qw(Iterator::ForwardIterator Iterator::BackwardIterator); +1; diff -urN /non-existant-dir/main/Iterator/ForwardIterator.pm tiarra-20080510/main/Iterator/ForwardIterator.pm --- /non-existant-dir/main/Iterator/ForwardIterator.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/main/Iterator/ForwardIterator.pm 2008-05-11 00:25:24.000000000 +0900 @@ -0,0 +1,23 @@ +# ----------------------------------------------------------------------------- +# Iterator::ForwardIterator +# ----------------------------------------------------------------------------- +# $Id: ForwardIterator.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +# これらのクラスはそれぞれの操作が行なえる事を示すために用いられる抽象クラスです。 +# インスタンスを生成する事は出来ません。 +# ----------------------------------------------------------------------------- +package Iterator::ForwardIterator; +use strict; +use warnings; +use base qw(Iterator); +use overload + '++' => \&_ope_increment; + +sub _ope_increment { + $_[0]->_increment; +} +sub _increment { + die "ForwardIterator has to override _increment().\n"; +} + +1; diff -urN /non-existant-dir/main/Iterator/RandomAccessIterator.pm tiarra-20080510/main/Iterator/RandomAccessIterator.pm --- /non-existant-dir/main/Iterator/RandomAccessIterator.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/main/Iterator/RandomAccessIterator.pm 2008-05-11 00:25:24.000000000 +0900 @@ -0,0 +1,58 @@ +# ----------------------------------------------------------------------------- +# Iterator::RandomAccessIterator +# ----------------------------------------------------------------------------- +# $Id: RandomAccessIterator.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +# これらのクラスはそれぞれの操作が行なえる事を示すために用いられる抽象クラスです。 +# インスタンスを生成する事は出来ません。 +# ----------------------------------------------------------------------------- +package Iterator::RandomAccessIterator; +use strict; +use warnings; +use base qw(Iterator::BidirectionalIterator); +use overload + '+' => \&_ope_addition, + '-' => \&_ope_subtract, + '+=' => \&_ope_add_to, + '-=' => \&_ope_sub_from; + +sub _ope_addition { + my ($this,$value) = @_; + $this->_addition($value); +} +sub _addition { + die "RandomAccessIterator has to implement addition().\n"; +} + +sub _ope_subtract { + my ($this,$value,$inverted) = @_; + if ($inverted) { + # $ite - 1はサポートされているが、1 - $iteはサポートされていない。 + die "Iterator::RandomAccessIterator : statement 'n - \$ite' is invalid.\n"; + } + else { + $this->_subtract($value); + } +} +sub subtract { + die "RandomAccessIterator has to implement subtract().\n"; +} + +sub _ope_add_to { + my ($this,$value) = @_; + $this->_add_to($value); +} +sub _add_to { + die "RandomAccessIterator has to implement add_to().\n"; +} + +sub _ope_sub_from { + my ($this,$value) = @_; + $this->_sub_from($value); +} +sub _sub_from { + die "RandomAccessIterator has to implement sub_from().\n"; +} + +1; + diff -urN /non-existant-dir/main/Iterator/RoundIterator.pm tiarra-20080510/main/Iterator/RoundIterator.pm --- /non-existant-dir/main/Iterator/RoundIterator.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/main/Iterator/RoundIterator.pm 2008-05-11 00:25:24.000000000 +0900 @@ -0,0 +1,11 @@ +# ----------------------------------------------------------------------------- +# Iterator::RoundIterator; +# ----------------------------------------------------------------------------- +# $Id: RoundIterator.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +# これらのクラスはそれぞれの操作が行なえる事を示すために用いられる抽象クラスです。 +# インスタンスを生成する事は出来ません。 +# ----------------------------------------------------------------------------- +package Iterator::RoundIterator; +1; + diff -urN /non-existant-dir/main/Iterator.pm tiarra-20080510/main/Iterator.pm --- /non-existant-dir/main/Iterator.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/main/Iterator.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,47 @@ +# ----------------------------------------------------------------------------- +# Iterator for the perl +# ----------------------------------------------------------------------------- +# $Id: Iterator.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +# STLに似せて作られたイテレータです。 +# イテレータは次の操作が可能です。 +# ----------------------------------------------------------------------------- +# $ite->get +# イテレータが現在指している値を返します。 +# 例えば$iteが現在IO::Fileのオブジェクトを指している場合、 +# $ite->get->close;のような操作が可能です。 +# +# この値取得メソッドは、そのイテレータが既に終端に達していた場合、 +# つまりもう返すべき値が無くなっている場合はundefを返します。 +# (ただし後述するようにイテレータがRoundIteratorだった場合は、 +# 要素が一つも無かった場合を除いて決してundefを返しません。 +# ----------------------------------------------------------------------------- +# $ite++ +# $ite-- +# それぞれイテレータに次と前の値を指させます。 +# ただし前者はForwardIterator、後者はBackwardIteratorを +# それぞれインプリメントしていなければ使えません。(無理に使おうとすると実行時エラーになります) +# 両方の操作が出来るイテレータはBidirectionalIteratorをインプリメントしています。 +# 既に先端または終端に来ており$ite->get()がundefを返すような状態のイテレータに対し +# これらの操作を行なって限界からさらに外れようとした場合、そのイテレータが +# RoundIteratorを実装していた場合は逆の位置へ行きますが、そうでない場合はdieします。 +# +# $ite + 1 +# $ite - 2 +# それぞれこのイテレータの次の値と前の前の値を指すイテレータを生成して返します。 +# ただしこれらはRandomAccessIteratorをインプリメントしていなければ使えません。 +# これらの操作によって限界を突破した場合は、RoundIteratorを実装していれば +# 反対側へ行きますが、そうでなければdieします。 +# ----------------------------------------------------------------------------- +# このクラスは全てのイテレータを表わす抽象クラスです。 +# インスタンスを生成する事は出来ません。 +# ----------------------------------------------------------------------------- +package Iterator; +use strict; +use warnings; + +sub get { + die "Iterator has to override get().\n"; +} + +1; diff -urN /non-existant-dir/main/L10N.pm tiarra-20080510/main/L10N.pm --- /non-existant-dir/main/L10N.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/main/L10N.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,121 @@ +# ----------------------------------------------------------------------------- +# $Id: L10N.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +# メッセージのローカライズを行う為のクラス。 +# このクラスはTiarraの他のクラスに依存しません。 +# ----------------------------------------------------------------------------- +# 使い方: +# +# ----------------------------------------------------------------------------- +package L10N; +use strict; +use warnings; +use Carp; +# 指定された言語が見付からない場合に、優先して選ばれる言語。 +our $secondary_language = 'en'; + +# {パッケージ名 => L10N} +our %instances; +sub _instance { + my $this = shift; + if (ref $this) { + # そのまま + $this; + } + else { + # 二つ前のcallerのパッケージに対してのインスタンスを返す。 + my ($pkg) = caller(1); + my $in = $instances{$pkg}; + if (!defined $in) { + $in = $instances{$pkg} = L10N->new($pkg); + } + $in; + } +} + +# 言語名省略時に選ばれる言語 +our $default_language = 'ja'; +sub default_language { + if (@_ == 0) { + $default_language; + } + elsif (@_ == 1) { + $default_language = $_[0]; + } + else { + $default_language = $_[1]; + } +} + +sub instance { + my $this = _instance(shift); +} + +*reg = \®ister; +sub register { + my ($this, %args) = @_; + $this = _instance($this); + + while (my ($key, $value) = each %args) { + $this->{messages}{$key} = $value; + } + $this; +} + +sub new { + my ($class, $pkg_name) = @_; + my $this = { + pkg_name => $pkg_name, + messages => {}, # {メッセージ名 => {言語名 => メッセージ}} + }; + bless $this => $class; +} + +sub get { + my ($this, $key, $lang) = @_; + $this = _instance($this); + if (!defined $key) { + return $this->_new_autoload; + } + + $lang = $default_language if !defined $lang; + + my $msg_langs = $this->{messages}{$key}; + if (defined $msg_langs) { + my $msg = $msg_langs->{$lang}; + if (defined $msg) { + $msg; + } + elsif (defined($_ = $msg_langs->{$secondary_language})) { + $_; + } + else { + (values %$msg_langs)[0]; + } + } + else { + undef; + } +} + +# ----------------------------------------------------------------------------- +package L10N::Autoload; +our $AUTOLOAD; + +sub AUTOLOAD { + my ($this, $lang) = @_; + if ($AUTOLOAD =~ /::DESTROY$/) { + return; + } + + (my $key = $AUTOLOAD) =~ s/.+?:://g; + $this->{l10n}->get($key, $lang); +} + +package L10N; +sub _new_autoload { + my $this = shift; + bless {l10n => $this} => 'L10N::Autoload'; +} + +1; diff -urN /non-existant-dir/main/LinedINETSocket.pm tiarra-20080510/main/LinedINETSocket.pm --- /non-existant-dir/main/LinedINETSocket.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/main/LinedINETSocket.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,93 @@ +# ----------------------------------------------------------------------------- +# $Id: LinedINETSocket.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +# Lined IO Socket +# ----------------------------------------------------------------------------- +# copyright (C) 2003-2004 Topia . all rights reserved. +# this module based IrcIO.pm, thanks phonohawk! +package LinedINETSocket; +use strict; +use warnings; +use IO::Socket::INET; +use Tiarra::Utils; +use Tiarra::Socket::Lined; +use base qw(Tiarra::Socket::Lined); + +#use SelfLoader; +#SelfLoader->load_stubs; +#1; +#__DATA__ + +# 行単位の入出力を行うINET-tcpソケットです。 +# read, writeはRunLoopによって自動的に行われる他、 +# pop_queueの実行前とflushによっても実行されます。 + +# newでeolを指定することによって、 +# CRLF,LF,CR,またはNULLなど、さまざまな行終端文字が使用できます。 +# 省略した場合はCRLFを使用します。 +# callback を指定すると disconnect 時に callback method が呼ばれます。 +# $callback->($genre, $errno), $genre は read, write, exception, eof, もしくは +# undef で、 eof や undef の時には errno はありません。 + +sub new { + my ($class, $eol, $callback) = @_; + + my $this = $class->SUPER::new( + _caller => 1, + _subject => 'lined-inet-socket', + eol => $eol, + ); + $this->{disconnect_callback} = $callback + if defined ref($callback) && + ref($callback) eq 'CODE'; + $this; +} + +sub disconnect { + my ($this, $errno, $genre, @params) = @_; + $this->SUPER::disconnect($errno, $genre, @params); + if (defined $this->{disconnect_callback}) { + $this->{disconnect_callback}->($errno, $genre); + } +} + +sub connect { + # 接続先ホストとポートを指定して接続を行なう。 + my ($this, $host, $port) = @_; + return if $this->connected; + + # ソケットを開く。開けなかったらundef。 + my $sock = new IO::Socket::INET(PeerAddr => $host, + PeerPort => $port, + Proto => 'tcp', + Timeout => 5); + if( $sock ) + { + $this->attach($sock); + }else + { + undef; + } +} + +sub attach { + my $this = shift; + $this->SUPER::attach(@_); + $this->install; +} + +sub length { shift->write_length; } + +sub send_reserve { + my ($this, $string) = @_; + # 文字列を送るように予約する。ソケットの送信の準備が整っていなくてもブロックしない。 + # CRLFはつけてはならない。 + + if ($this->sock) { + $this->append_line($string); + } else { + die "LinedINETSocket::send_reserve : socket is not connected."; + } +} + +1; diff -urN /non-existant-dir/main/LocalChannelManager.pm tiarra-20080510/main/LocalChannelManager.pm --- /non-existant-dir/main/LocalChannelManager.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/main/LocalChannelManager.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,148 @@ +# ----------------------------------------------------------------------------- +# $Id: LocalChannelManager.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +# このクラスはTiarraローカルなチャンネルを管理します。 +# 各クライアントに、そのクライアントが入っているTiarraローカルチャンネルを +# 註釈`tiarra-local-channels'として持たせます。 +# この註釈はチャンネル名の配列です。 +# ----------------------------------------------------------------------------- +# 使い方: +# +# ----------------------------------------------------------------------------- +package LocalChannelManager; +use strict; +use warnings; +use Carp; +use Tiarra::SharedMixin; +use NumericReply; +use base qw(Tiarra::IRC::NewMessageMixin); +our $_shared_instance; + +sub _new { + my $class = shift; + my $this = { + registered => {}, # {チャンネル名 => [トピック(文字列), ハンドラ(クロージャ)]} + }; + bless $this => $class; +} + +sub register { + # Name => チャンネル名 + # Topic => トピック + # Handler => ハンドラ; $handler->($client, $msg)のように呼ばれる。 + my ($class_or_this, %args) = @_; + my $this = $class_or_this->_this; + + foreach my $arg (qw/Name Topic Handler/) { + if (!defined $args{$arg}) { + croak "LocalChannelManager->register, Arg{Name} is undef.\n"; + } + } + if (ref($args{Handler}) ne 'CODE') { + croak "LocalChannelManager->register, Arg{Handler} is not a function.\n"; + } + + if (defined $this->{registered}{$args{Name}}) { + croak "LocalChannelManager->register, channel `$args{Name}' is already registered.\n"; + } + + $this->{registered}{$args{Name}} = [@args{'Topic', 'Handler'}]; + $this; +} + +sub unregister { + my ($class_or_this, $channel) = @_; + my $this = $class_or_this->_this; + + delete $this->{registered}{$channel}; + $this; +} + +sub registered_p { + my ($class_or_this, $channel) = @_; + my $this = $class_or_this->_this; + + defined $this->{registered}{$channel}; +} + +sub message_arrived { + # Tiarra::IRC::Messageまたはundefを返す。 + my ($class_or_this, $msg, $sender) = @_; + my $this = $class_or_this->_this; + + my $method = '_'.$msg->command; + if ($this->can($method)) { + $this->$method($msg, $sender); + } + else { + $msg; + } +} + +sub _JOIN { + my ($this, $msg, $sender) = @_; + + # チャンネル名のリストから、Tiarraローカルチャンネルを抜き取る。 + my @new_list; + foreach my $ch_name (split m/,/, $msg->param(0)) { + if ($this->registered_p($ch_name)) { + my ($topic, $handler) = @{$this->{registered}{$ch_name}}; + + # このクライアントの`tiarra-local-channels'に入っているか？ + my $list = $sender->remark('tiarra-local-channels'); + if (!defined $list) { + $list = []; + $sender->remark('tiarra-local-channels', $list); + } + if (!{map {$_ => 1} @$list}->{$ch_name}) { + # 入っていないのでJOIN処理を行う。 + push @$list, $ch_name; + + my $local_nick = RunLoop->shared->current_nick; + # まずJOIN + $sender->send_message( + $this->construct_irc_message( + Prefix => $sender->fullname, + Command => 'JOIN', + Param => $ch_name)); + # 次にRPL_TOPIC(あれば) + if ($topic ne '') { + $sender->send_message( + $this->construct_irc_message( + Prefix => 'Tiarra', + Command => RPL_TOPIC, + Params => [ + $local_nick, + $ch_name, + $topic, + ])); + } + # 次にRPL_NAMREPLY。この本人だけ。 + $sender->send_message( + $this->construct_irc_message( + Prefix => 'Tiarra', + Command => RPL_NAMREPLY, + Params => [$local_nick, + '=', + $ch_name, + $local_nick])); + # そしてRPL_ENDOFNAMES + $sender->send_message( + $this->construct_irc_message( + Prefix => 'Tiarra', + Command => RPL_ENDOFNAMES, + Params => [$local_nick, + $ch_name, + 'End of NAMES list'])); + } + } + else { + push @new_list, $ch_name; + } + } + $msg->param(0, join(',', @new_list)); + + $msg; +} + +1; diff -urN /non-existant-dir/main/Mask.pm tiarra-20080510/main/Mask.pm --- /non-existant-dir/main/Mask.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/main/Mask.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,371 @@ +# ----------------------------------------------------------------------------- +# $Id: Mask.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +package Mask; +use strict; +use warnings; +use Carp; +use Multicast; + + +# ----------------------------------------------------------------------------- +# $bool = match($masks, $str). +# $bool = match($masks, $str, $match_type, $use_re, $use_flag). +# どれにもマッチしなかった際はundef, つまり偽がかえる. +# 明示的に拒否された場合は 0, つまりdefinedな偽が返る. +# +sub match { + # matchはワイルドカードを使ったマッチングを行う関数です。 + # ワイルドカード以外にも、+や-を使った除外指定や、 + # re: を使った正規表現マッチングが行えます。 + + # $masksには','(コンマ)で区切ったマッチリストを渡してください。 + # 条件中に','(コンマ)を使いたい場合は'\,'と書けます。 + + # 引数名 : [既定値] - 説明 - + # $masks : [-] カンマ区切りのマッチリスト. + # $str : [-] マッチ対象の文字列. + # $match_type : [0] 0: 最後にマッチした値を返します。 1: 最初にマッチした値を返します。 + # $use_re : [1] 0: 正規表現マッチを使用しません。 1: 使用します。 + # $use_flag : [1] 0: +や-を使用しません。 1: 使用します。 + + # 返り値 : { 1 (true) => + にマッチ, + # 0 (false) => - にマッチ, + # (undef) => まったくマッチしなかった + my ($masks, $str, $match_type, $use_re, $use_flag) = @_; + if (!defined $masks || !defined $str) { + return undef; + } + + return match_array([_split($masks)], $str, $match_type, $use_re, $use_flag); +} + +# ----------------------------------------------------------------------------- +# $bool = match_deep(\@masks_list, $str). +# $bool = match_deep(\@masks_list, $str, $g_match_type, $match_type, $use_re, $use_flag); +# @masks の各要素に対して match() を行う. +# +sub match_deep { + # match_deepは次のようなマスクの解釈に使います。 + + # mask: +*!*@* + # mask: -example!* + + # 引数名 : [既定値] - 説明 - + # $masks_array : [無し] マスク配列の参照を渡します。 + # Mask::match_deep([Mask::mask_array_or_all($this->config->mask('all'))], $msg->prefix) + # : のように使います。 + # $global_match_type : [1] 0: 最後にマッチした行の値を返します。 1: 最初にマッチした行の値を返します。 + my ($masks_array, $str, $g_match_type, $match_type, $use_re, $use_flag) = @_; + if (!defined $masks_array) { + return undef; + } + + $g_match_type = 1 unless defined $g_match_type; + + my $g_matched = undef; + foreach my $masks (@$masks_array) { + my $matched = match_array([_split($masks)], $str, $match_type, $use_re, $use_flag); + if (defined $matched) { + $g_matched = $matched; + return $g_matched if $g_match_type == 1; + } + } + + return $g_matched; +} + +# ----------------------------------------------------------------------------- +# $bool = match_array(\@masks, $str). +# $bool = match_array(\@masks, $str, $match_type, $use_re, $use_flag). +# +sub match_array { + # match_arrayは、matchから呼ばれる内部関数ですが、普通に呼び出して使うこともできます。 + # match との違いは、マスクをマスク配列の参照として渡す点です。 + + # $match_type: 0: last matching rule, 1: first matching rule + # $use_re : use 're:' feature. + # $use_flag : use [+-] match flag. + + # : status { 1 (true) => +, matched, + # 0 (false) => -, matched, + # (undef) => no-match } + my ($mask_array, $str, $match_type, $use_re, $use_flag) = @_; + + if (!defined $mask_array || ref($mask_array) ne 'ARRAY' || !defined $str) { + return undef; + } + + $match_type = 0 unless defined $match_type; + $use_re = 1 unless defined $use_re; + $use_flag = 1 unless defined $use_flag; + + my $matched = undef; + foreach my $part (@$mask_array) { + my $work = $part; + my $first = substr($work, 0, 1); + my $include = 1; + if (!$use_flag) { + # noop + } elsif ($first eq '+') { + substr($work, 0, 1) = ''; + } elsif ($first eq '-') { + $include = 0; + substr($work, 0, 1) = ''; + } + + if ($use_re && substr($work, 0, 3) eq 're:') { + # 正規表現 + $work = substr($work,3); + # untaint + $work =~ /\A(.*)\z/s; + $work = eval { + qr/$1/; + }; if ($@) { + $work = ''; + carp "error in regex: $@"; + } + } else { + $work = make_regex($work); + } + + if ($str =~ m/$work/) { + # マッチした + $matched = $include; + return $matched if $match_type == 1; + } + } + return $matched; +} + + +# channel version +# Mask::match_chan($mask, $user_long, $ch_long). +# $mask = '#{example}@ircnet,-#{example2}@2ch +*!*@*.example.com' +# $user_long = 'nick!user@remote' +# $ch_long = '#chan@ircnet:*.jp' +# ユーザ名/チャンネル名のマッチング. +sub match_chan { + my ($masks, $str, $chan, $match_type, $use_re, $use_flag) = @_; + if (!defined $masks || !defined $str) { + return undef; + } + + return match_array_chan(_split_with_chan($masks), $str, $chan, $match_type, $use_re, $use_flag); +} + +sub match_deep_chan { + my ($masks_array, $str, $chan, $g_match_type, $match_type, $use_re, $use_flag) = @_; + if (!defined $masks_array) { + return undef; + } + + $g_match_type = 1 unless defined $g_match_type; + + my $g_matched = undef; + foreach my $masks (@$masks_array) { + my $matched = match_array_chan(_split_with_chan($masks), $str, $chan, $match_type, $use_re, $use_flag); + if (defined $matched) { + $g_matched = $matched; + return $g_matched if $g_match_type == 1; + } + } + + return $g_matched; +} + +my $chanmask_mode = undef; # undefined, +my $CHANMASK_TIARRA = 1; +my $CHANMASK_PLUM = 2; + +# tiarra Configuration check; +sub _check_chanmask_conf { + # configuration を読み、chanmask_mode を決定する。 + use Configuration; + + my $maskmode = Configuration::shared_conf->general->chanmask_mode; + if (defined $maskmode) { + if ($maskmode =~ /plum/i) { + $chanmask_mode = $CHANMASK_PLUM; + } elsif ($maskmode =~ /tiarra/i) { + $chanmask_mode = $CHANMASK_TIARRA; + } else { + ::printmsg('Configure_variable [maskmode] ' . $maskmode . ' is not known... use Tiarra mode.'); + $chanmask_mode = $CHANMASK_TIARRA; + } + } else { + # fallback + $chanmask_mode = $CHANMASK_TIARRA; + } +} + +sub match_array_chan { + # $match_type: 0: last matching rule, 1: first matching rule + # $use_re : use 're:' feature. + # $use_flag : use [+-] match flag. + + # : status { 1 (true) => +, matched, + # 0 (false) => -, matched, + # (undef) => no-match } + my ($usermask_array, $chanmask_array, $str, $chan, $match_type, $use_re, $use_flag) = @_; + + return undef if (!defined $str); + foreach my $var ($usermask_array, $chanmask_array) { + return undef if (!defined $var || ref($var) ne 'ARRAY'); + } + + _check_chanmask_conf() if (!defined($chanmask_mode)); + + my ($chanmask_use_flag); + if ($chanmask_mode == $CHANMASK_TIARRA) { + $chanmask_use_flag = $use_flag; + } elsif ($chanmask_mode == $CHANMASK_PLUM) { + $chanmask_use_flag = 0; + } else { + croak 'chanmask_mode is unsupported value!'; + } + + # channelマッチを行ってからuserマッチを行う。 + # channelマッチではflagは使わない。 + my $matched = undef; + if (Multicast::channel_p($chan)) { + # $chanがchannelの時は普通にマッチ。 + $matched = match_array($chanmask_array, $chan, $match_type, $use_re, $chanmask_use_flag); + } else { + # $chanがchannelでないときはpriv等なので * にマッチさせる。 + $matched = match_array($chanmask_array, '*', $match_type, $use_re, $chanmask_use_flag); + } + + $matched = undef unless $matched; # matchしなかったらundefを代入する + # channelでマッチしなかったらこの行は無視する。 + if (defined $matched) { + $matched = undef; + $matched = match_array($usermask_array, $str, $match_type, $use_re, $use_flag); + } + + return $matched; +} + +# support functions +my $cache_limit = 150; +my @cache_keys; +my %cache_table; +sub make_regex { + my $str = $_[0]; + + if (my $cached = $cache_table{$str}) { + $cached; + } + else { + # キャッシュされていない。 + if (@cache_keys >= $cache_limit) { + # キャッシュされている値をランダムに一つ消す。 + my $to_delete = scalar(splice @cache_keys, int(rand @cache_keys), 1); + delete $cache_table{$to_delete}; + } + + my $compiled = compile($str); + push @cache_keys, $str; + $cache_table{$str} = $compiled; + + $compiled; + } +} + +sub compile { + # $mask: マスク文字列 + # $consider_case: 真なら、大文字小文字を区別する。 + my ($mask, $consider_case) = @_; + + if (!defined $mask) { + return qr/(?!)/; # マッチしない正規表現 + } + + my $regex = quotemeta($mask); + $regex =~ s/\\\?/./g; + $regex =~ s/\\\*/.*/g; + #$regex =~ s/\\\#/\\d*/g; + $regex = "^$regex\$"; + if ($consider_case) { + qr/$regex/; + } + else { + qr/$regex/i; + } +} + +sub _split { + # ',' でわけられたマスクを配列にする。 + my $mask = shift; + return () if !defined $mask; + + return map { + s/\\,/,/g; + $_; + } split /(?__initialized) { + # ModuleManager が存在していれば、 ModuleManagerにuse先を登録。 + # 存在していなければ RunLoop 経由で起動されていないと思うので無視。 + my $mod_manager = ModuleManager->shared_manager; + foreach (@modules) { + $mod_manager->timestamp($_,time); + } + } +} + +1; diff -urN /non-existant-dir/main/Module.pm tiarra-20080510/main/Module.pm --- /non-existant-dir/main/Module.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/main/Module.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,178 @@ +# ----------------------------------------------------------------------------- +# $Id: Module.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +# Tiarraモジュール(プラグイン)を表わす抽象クラスです。 +# 全てのTiarraモジュールはこのクラスを継承し、 +# 必要なメソッドをオーバーライドしなければなりません。 +# ----------------------------------------------------------------------------- +package Module; +use strict; +use warnings; +use Carp; +use Tiarra::ShorthandConfMixin; +use Tiarra::Utils; +use base qw(Tiarra::Mixin::NewIRCMessage); +use base qw(Tiarra::Mixin::AttachPackage); +# our @USES = (); +Tiarra::Utils->define_attr_getter(0, [qw(_runloop runloop)]); + +sub new { + my ($class, $runloop) = @_; + if (!defined $runloop) { + carp 'please update module constructor; see Skelton.pm'; + $runloop = RunLoop->shared; + } + # モジュールが必要になった時に呼ばれる。 + # これはモジュールのコンストラクタである。 + # 引数は無し。 + bless { + runloop => $runloop, + },$class; +} + +sub destruct { + my $this = shift; + # モジュールが不要になった時に呼ばれる。 + # これはモジュールのデストラクタである。このメソッドが呼ばれた後はDESTROYを除いて + # いかなるメソッドも呼ばれる事が無い。タイマーを登録した場合は、このメソッドが + # 責任を持ってそれを解除しなければならない。 + # 引数は無し。 +} + +sub message_arrived { + my ($this,$message,$sender) = @_; + # サーバーまたはクライアントからメッセージが来た時に呼ばれる。 + # 戻り値はTiarra::IRC::Messageまたはその配列またはundef。 + # + # $message : + # 内容: Tiarra::IRC::Messageオブジェクト + # サーバーから、またはクライアントから送られてきたメッセージ。 + # モジュールはこのオブジェクトをそのまま返しても良いし、 + # 改変して返しても良いし何も返さなくても良いし二つ以上返しても良い。 + # $sender : + # 内容: IrcIOオブジェクト + # このメッセージを発したIrcIO。サーバーまたはクライアントである。 + # メッセージがサーバーから来たのかクライアントから来たのかは + # $sender->isa('IrcIO::Server')などとすれば判定出来る。 + # この引数は現在処理しているメッセージ群の根拠サーバで、実際に + # #message を作成したインスタンスは $message->generator に入る + # (モジュールが生成した場合等入ってない場合もあるし、また + # Multicast がメッセージを分けた場合でも generator は変化しない。) + # + # サーバー→クライアントの流れでも、Prefixを持たないメッセージを + # 流しても構わない。逆に言えば、そのようなメッセージが来ても + # 問題が起こらないようにモジュールを設計しなければならない。 + return $message; +} + +sub client_attached { + my ($this,$client) = @_; + # クライアントが新規に接続した時に呼ばれる。 + # 戻り値は無し。 + # + # $client : + # 内容: IrcIO::Clientオブジェクト + # 接続されたクライアント。 +} + +sub client_detached { + my ($this,$client) = @_; + # クライアントが切断した時に呼ばれる。 + # 戻り値は無し。 + # + # $client : + # 内容: IrcIO::Clientオブジェクト + # 切断したクライアント。 +} + +sub connected_to_server { + my ($this,$server,$new_connection) = @_; + # サーバーに接続した時に呼ばれる。 + # 戻り値は無し。 + # + # $server : + # 内容: IrcIO::Serverオブジェクト + # 接続したサーバー。 + # $new_connection : + # 内容: 真偽値 + # 新規の接続なら1。切断後の自動接続ではundef。 +} + +sub disconnected_from_server { + my ($this,$server) = @_; + # サーバーから切断した(或いはされた)時に呼ばれる。 + # 戻り値は無し。 + # + # $server : + # 内容: IrcIO::Serverオブジェクト + # 切断したサーバー。 +} + +sub message_io_hook { + my ($this,$message,$io,$type) = @_; + # サーバーから受け取ったメッセージ、サーバーに送ったメッセージ、 + # クライアントから受け取ったメッセージ、クライアントに送ったメッセージは + # このメソッドで各モジュールに通知される。メッセージの変更も可能で、 + # 戻り値のルールはmessage_arrivedと同じ。 + # + # 通常のモジュールはこのメソッドを実装する必要は無い。 + # + # $message : + # 内容: Tiarra::IRC::Messageオブジェクト + # 送受信されたメッセージ + # $io : + # 内容: IrcIO::Server又はIrcIO::Clientオブジェクト + # 送受信が行なわれたIrcIO + # $type : + # 内容: 文字列 + # 'in'なら受信、'out'なら送信 + return $message; +} + +sub message_encoding_hook { + my ($this,$message,$io,$type,$encoding) = @_; + # サーバーから受け取ったメッセージ、サーバーに送ったメッセージ、 + # クライアントから受け取ったメッセージ、クライアントに送ったメッセージは + # このメソッドで各モジュールに通知される。メッセージの変更も可能で、 + # 戻り値のルールはmessage_arrivedと同じ。このメソッドでメッセージの + # エンコーディングを制御することを意図している。 message_io_hook よりも I/O + # よりで呼び出される。送信時なら ->remark/encoding を、受信時は + # ->encoding_params を呼び出すことにより制御してください。 + # + # 通常のモジュールはこのメソッドを実装する必要は無い。 + # + # $message : + # 内容: Tiarra::IRC::Messageオブジェクト + # 送受信されたメッセージ + # $io : + # 内容: IrcIO::Server又はIrcIO::Clientオブジェクト + # 送受信が行なわれたIrcIO + # $type : + # 内容: 文字列 + # 'in'なら受信、'out'なら送信。知らないタイプがきたら無視しなければならない。 + # $encoding : + # 内容: 文字列 + # 送信を予定しているエンコーディング。 + return $message; +} + +sub control_requested { + my ($this,$request) = @_; + # 外部コントロールプログラムからのメッセージが来た。 + # 戻り値はControlPort::Reply。 + # + # $request: + # 内容 : ControlPort::Request + # 送られたリクエスト + die "This module doesn't support controlling.\n"; +} + +sub config { + my $this = shift; + # このモジュールの設定を取得する。 + # オーバーライドする必要は無い。 + # 戻り値はConfiguration::Block。 + $this->_conf->find_module_conf(ref($this),'block'); +} + +1; diff -urN /non-existant-dir/main/ModuleManager.pm tiarra-20080510/main/ModuleManager.pm --- /non-existant-dir/main/ModuleManager.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/main/ModuleManager.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,630 @@ +# ----------------------------------------------------------------------------- +# $Id: ModuleManager.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +# このクラスは全てのTiarraモジュールを管理します。 +# モジュールをロードし、リロードし、破棄するのはこのクラスです。 +# ----------------------------------------------------------------------------- +package ModuleManager; +use strict; +use Carp; +use warnings; +use UNIVERSAL; +use RunLoop; +use Tiarra::SharedMixin qw(shared shared_manager); +use Tiarra::ShorthandConfMixin; +use Tiarra::Utils; +our $_shared_instance; +utils->define_attr_getter(1, [qw(_runloop runloop)]); + +sub __initialized { + # internal public method for instance initialized + defined $_shared_instance; +} + +sub _new { + shift->new(shift || RunLoop->shared); +} + +sub new { + my ($class, $runloop) = @_; + croak 'runloop is not specified!' unless defined $runloop; + my $obj = { + runloop => $runloop, + modules => [], # 現在使用されている全てのモジュール + using_modules_cache => undef, # ブラックリストを除いた全てのモジュールのキャッシュ。 + mod_configs => {}, # 現在使用されている全モジュールのConfiguration::Block + mod_timestamps => {}, # 現在使用されている全モジュールおよびサブモジュールの初めてuseされた時刻 + mod_blacklist => {}, # 過去に正常動作しなかったモジュール。 + updated_once => 0, # 過去にupdate_modulesが実行された事があるか。 + }; + bless $obj,$class; +} + +sub _initialize { + my $this = shift; + $this->update_modules; +} + +sub add_to_blacklist { + my ($this,$modname) = @_; + $this->_set_blacklist($modname, 1); +} + +sub remove_from_blacklist { + my ($this,$modname) = @_; + $this->_set_blacklist($modname, 0); +} + +sub check_blacklist { + my ($class_or_this,$modname) = @_; + + exists $class_or_this->_this->{mod_blacklist}->{$modname}; +} + +sub _set_blacklist { + my ($class_or_this,$modname,$add_or_remove) = @_; + my $this = $class_or_this->_this; + + $this->_clear_module_cache; + if ($add_or_remove) { + # modname の存在テストはしない: && defined $this->get($modname) + $this->{mod_blacklist}->{$modname} = 1; + } elsif (!$add_or_remove && exists $this->{mod_blacklist}->{$modname}) { + delete $this->{mod_blacklist}->{$modname}; + } else { + return undef; + } + return 1; +} + +sub _clear_module_cache { + shift->{using_modules_cache} = undef; +} + +sub get_modules { + # @options(省略可能): + # 'even-if-blacklisted': ブラックリスト入りのものを含める。 + # モジュールの配列への参照を返すが、これを変更してはならない！ + my ($class_or_this,@options) = @_; + my $this = $class_or_this->_this; + if (defined $options[0] && $options[0] eq 'even-if-blacklisted') { + return $this->{modules}; + } else { + if (!defined $this->{using_modules_cache}) { + $this->{using_modules_cache} = [grep { + !$this->check_blacklist(ref($_)); + } @{$this->{modules}}]; + } + return $this->{using_modules_cache}; + } +} + +sub get { + my ($class_or_this,$modname) = @_; + my $this = $class_or_this->_this; + foreach (@{$this->{modules}}) { + return $_ if ref $_ eq $modname; + } + undef; +} + +sub terminate { + # Tiarra終了時に呼ぶ事。 + my $this = shift->_this; + foreach (@{$this->{modules}}) { + eval { + $_->destruct; + }; if ($@) { + print "$@\n"; + } + $this->_unload(ref($_)); + } + foreach (keys %{$this->{mod_timestamps}}) { + eval { + $_->destruct; + }; + $this->_unload($_); + } + @{$this->{modules}} = (); + $this->_clear_module_cache; + %{$this->{mod_configs}} = (); + %{$this->{mod_timestamps}} = (); +} + +sub timestamp { + my ($class_or_this,$module,$timestamp) = @_; + my $this = $class_or_this->_this; + if (defined $timestamp) { + $this->{mod_timestamps}->{$module} = $timestamp; + } + $this->{mod_timestamps}->{$module}; +} + +sub check_timestamp_update { + my ($class_or_this,$module,$timestamp) = @_; + my $this = $class_or_this->_this; + + $timestamp = $this->{mod_timestamps}->{$module} if !defined $timestamp; + if (defined $timestamp) { + (my $mod_filename = $module) =~ s|::|/|g; + my $mod_fpath = $INC{$mod_filename.'.pm'}; + return if (!defined($mod_fpath) || !-f $mod_fpath); + if ((stat($mod_fpath))[9] > $timestamp) { + return 1; + } else { + return 0; + } + } else { + return undef; + } +} + +sub update_modules { + # +で指定されたモジュール一覧を読み、modulesを再構成する。 + # 必要なモジュールがまだロードされていなければロードし、 + # もはや必要とされなくなったモジュールがあれば破棄する。 + # 二度目以降、つまり起動後にこれが実行された場合は + # モジュールのロードや破棄に関して成功時にもメッセージを出力する。 + my $this = shift->_this; + my $mod_configs = $this->_conf->get_list_of_modules; + my ($new,$deleted,$changed,$not_changed) = $this->_check_difference($mod_configs); + + my $show_msg = sub { + if ($this->{updated_once}) { + # 過去に一度以上、update_modulesが実行された事がある。 + return sub { + $this->_runloop->notify_msg( $_[0] ); + }; + } + else { + # 起動時なので何もしない無名関数を設定。 + return sub {}; + } + }->(); + + # $this->{modules}をモジュール名 => Moduleのテーブルに。 + my %loaded_mods = map { + ref($_) => $_; + } @{$this->{modules}}; + + # 新たに追加されたモジュール、作り直されたモジュール、変更されなかったモジュールを + # モジュール名 => Moduleの形式でテーブルにする。 + my %new_mods = map { + # 新たに追加されたモジュール。 + $show_msg->("Module ".$_->block_name." will be loaded newly."); + $this->remove_from_blacklist($_->block_name); + $_->block_name => $this->_load($_); + } @$new; + my %rebuilt_mods = map { + # 作り直すモジュール。 + # %loaded_modsに古い物が入っているので、破棄する。 + $show_msg->("Configuration of the module ".$_->block_name." has been changed. It will be restarted."); + eval { + $loaded_mods{$_->block_name}->destruct; + }; if ($@) { + $this->_runloop->notify_error($@); + } + $this->remove_from_blacklist($_->block_name); + $_->block_name => $this->_load($_); + } @$changed; + my %not_changed_mods = map { + # 設定変更されなかったモジュール。 + # %loaded_modsに実物が入っている。 + my $modname = $_->block_name; + if (!defined $loaded_mods{$modname} && + $this->check_timestamp_update($modname)) { + # ロードできてなくて、なおかつアップデートされていたらロードしてみる。 + $show_msg->("$modname has been modified. It will be reloaded."); + $this->remove_from_blacklist($modname); + $modname => $this->_load($_); + } else { + $modname => $loaded_mods{$modname}; + } + } @$not_changed; + + # $mod_configsに書かれた順序に従い、$this->{modules}を再構成。 + # 但しロードに失敗したモジュールはnullになっているので除外。 + @{$this->{modules}} = grep { defined $_ } map { + my $modname = $_->block_name; + $not_changed_mods{$modname} || $rebuilt_mods{$modname} || $new_mods{$modname}; + } @$mod_configs; + + my $deleted_any = @$deleted > 0; + foreach (@$deleted) { + # 削除されたモジュール。 + # %loaded_modsに古い物が入っている場合は破棄した上、アンロードする。 + $show_msg->("Module ".$_->block_name." will be unloaded."); + if (defined $loaded_mods{$_->block_name}) { + eval { + $loaded_mods{$_->block_name}->destruct; + }; if ($@) { + $this->_runloop->notify_error($@); + } + } + $this->_unload($_); + } + + # gc の前に一度キャッシュクリア + $this->_clear_module_cache; + + if ($deleted_any > 0) { + # 何か一つでもアンロードしたモジュールがあれば、最早参照されなくなったモジュールが + # あるかどうかを調べ、一つでもあればmark and sweepを実行。 + my $fixed = $this->fix_USED_fields; + if ($fixed) { + $this->gc; + } + } + + $this->_clear_module_cache; + + $this->{updated_once} = 1; + $this; +} + +sub _check_difference { + # 前回の_check_difference実行時から、現在のモジュール設定がどのように変化したか。 + # 戻り値は(<新規追加>,<削除>,<変更>,<無変更>) それぞれARRAYへの参照である。 + # 新規追加と変更はそれぞれ新しいConfiguration::Blockが、削除には(新しいものが無いので)古いConfiguration::Blockが返される。 + my ($this,$mod_configs) = @_; + # まずは新たに登場したモジュールと、設定を変更されたモジュールを探す。 + my @new; + my @changed; + my @not_changed; + foreach my $conf (@$mod_configs) { + my $old_conf = $this->{mod_configs}->{$conf->block_name}; + if (defined $old_conf) { + # このモジュールは既に定義されているが、変更を加えられてはいないか？ + if ($old_conf->equals($conf)) { + # 変わってない。 + push @not_changed,$conf; + } + else { + # 内容が変わった。 + push @changed,$conf; + } + } + else { + # 初めて見るモジュールだ。 + push @new,$conf; + } + } + # 削除されたモジュールを探す。 + # 上のループと纏める事も出来るが、コードが分かりにくくなる。 + my %names_of_old_modules + = map { $_ => 1 } keys %{$this->{mod_configs}}; + foreach my $conf (@$mod_configs) { + delete $names_of_old_modules{$conf->block_name}; + } + my @deleted = map { + $this->{mod_configs}->{$_}; + } keys %names_of_old_modules; + # $this->{mod_configs}に新たな値を設定。 + %{$this->{mod_configs}} = + map { $_->block_name => $_ } @$mod_configs; + # 完了 + return (\@new,\@deleted,\@changed,\@not_changed); +} + +sub reload_modules_if_modified { + # コード自体が更新されているモジュールがあれば、それを一旦アンロードしてロードし直す。 + # インスタンスも当然作り直す。 + my $this = shift; + + my $show_msg = sub { + $this->_runloop->notify_msg($_[0]); + }; + + my $mods_to_be_reloaded = {}; # モジュール名 => 1 + my $check = sub { + my ($modname,$timestamp) = @_; + # 既に更新されたものとしてマークされていれば抜ける。 + return if $mods_to_be_reloaded->{$modname}; + + if ($this->check_timestamp_update($modname, $timestamp)) { + # 更新されている。少なくともこのモジュールはリロードされる。 + $mods_to_be_reloaded->{$modname} = 1; + $show_msg->("$modname has been modified. It will be reloaded."); + + my $trace; + $trace = sub { + my ($modname, $depth) = @_; + ++$depth; + no strict 'refs'; + # このモジュールに%USEDは定義されているか？ + my $USED = \%{$modname.'::USED'}; + if (defined $USED) { + # USEDの全ての要素に対し再帰的にマークを付ける。 + foreach my $used_elem (keys %$USED) { + if (!defined $mods_to_be_reloaded->{$used_elem} || + $mods_to_be_reloaded->{$used_elem} < $depth) { + $mods_to_be_reloaded->{$used_elem} = $depth; + $show_msg->("$used_elem will be reloaded because of modification of $modname"); + $trace->($used_elem, $depth); + } + } + } + }; + + $trace->($modname, 1); + } + }; + + while (my ($modname,$timestamp) = each %{$this->{mod_timestamps}}) { + $check->($modname,$timestamp); + } + + # 一つでもマークされたモジュールがあれば、$this->{modules}内の何処に + # 目的のモジュールが在るのかを調べるために、モジュール名 => 位置のテーブルを作る。 + if (keys(%$mods_to_be_reloaded) > 0) { + my $mod2index = {}; + for (my $i = 0; $i < @{$this->{modules}}; $i++) { + $mod2index->{ref $this->{modules}->[$i]} = $i; + } + + my @mods_load_order = map { $_->[0] } + sort { $a->[1] <=> $b->[1] } + map { [$_, $mods_to_be_reloaded->{$_}]; } + keys %$mods_to_be_reloaded; + + # 先に destruct して回る + foreach my $modname (reverse @mods_load_order) { + my $idx = $mod2index->{$modname}; + if (defined $idx) { + eval { + $this->{modules}->[$idx]->destruct; + }; if ($@) { + $this->_runloop->notify_error($@); + } + } else { + eval { + $modname->destruct; + }; if ($@ && $modname->can('destruct')) { + $this->_runloop->notify_error($@); + } + } + } + + # マークされたモジュールをリロードするが、それが$mod2indexに登録されていたら + # インスタンスを作り直す。 + foreach my $modname (@mods_load_order) { + my $idx = $mod2index->{$modname}; + if (defined $idx) { + my $conf_block = $this->{mod_configs}->{$modname}; + # message_io_hook が定義されているモジュールが死ぬと怖いので + # とりあえず undef を入れて無視させる。 + $this->{modules}->[$idx] = undef; + $this->_unload($conf_block); + $this->{modules}->[$idx] = $this->_load($conf_block); # 失敗するとundefが入る。 + # _unload でブラックリストから消えるから大丈夫だと思うが、一応。 + $this->remove_from_blacklist($modname); + } + else { + # アンロード後、use。 + no strict 'refs'; + # その時、%USEDを保存する。@USEは保存しない。 + my %USED = %{$modname.'::USED'}; + $this->_unload($modname); + eval qq{ + use $modname; + }; if ($@) { + $this->_runloop->notify_error($@); + } + %{$modname.'::USED'} = %USED; + } + } + + # 全てのモジュールの%USEDを調べて、その%USEDが指しているモジュールが + # 本当にそのモジュールを参照しているのかどうかをチェック。 + # モジュールの更新で最早参照しなくなっていれば、%USEDから削除する。 + # このような事が起こるのはリロード時に%USEDを保存するためである。 + my $fixed = $this->fix_USED_fields; + + # %USEDの不整合性が見付かったら、もはや必要とされなくなった + # モジュールがあるかも知れない。gcを実行。 + if ($fixed) { + $this->gc; + } + + # $this->{modules}にはundefの要素が入っているかも知れないので、そのような要素は除外する。 + @{$this->{modules}} = grep { + defined $_; + } @{$this->{modules}}; + + $this->_clear_module_cache; + } +} + +sub _load { + # モジュールをuseしてインスタンスを生成して返す。 + # 失敗したらundefを返す。 + my ($this,$mod_conf) = @_; + my $mod_name = $mod_conf->block_name; + + # use + utils->do_with_errmsg("module load: $mod_name", sub { + eval "use $mod_name;"; + }); + if ($@) { + $this->_runloop->notify_error( + "Couldn't load module $mod_name because of exception.\n$@"); + return undef; + } + + # モジュール名をファイル名に変換して%INCを検査。 + # module/で始まっていなければエラー。 + #(my $mod_filename = $mod_name) =~ s|::|/|g; + #my $filepath = $INC{$mod_filename.'.pm'}; + #if ($filepath !~ m|^module/|) { + # $this->_runloop->notify_error( + # "Class $mod_name exists outside the module directory.\n$filepath\n"); + # next; + #} + + # このモジュールは本当にModuleのサブクラスか？ + # 何故かUNIVERSAL::isaは嘘を付く事があるので自力で@ISA内を検索する。 + # 5.6.0 for darwinではモジュールをリロードすると嘘を付く。 + no strict 'refs'; + my $is_inherit_ok = sub { + return 1 if UNIVERSAL::isa($mod_name,'Module'); + my @isa = @{$mod_name.'::ISA'}; + foreach (@isa) { + if ($_ eq 'Module') { + ::debug_printmsg('UNIVERSAL::isa tell a lie...'); + return 1; + } + } + undef; + }; + unless ($is_inherit_ok->()) { + $this->_runloop->notify_error( + "Class $mod_name doesn't inherit class Module."); + return undef; + } + + # インスタンス生成 + my $mod; + eval { + $mod = $mod_name->new($this->_runloop); + }; if ($@) { + $this->_runloop->notify_error( + "Couldn't instantiate module $mod_name because of exception.\n$@"); + return undef; + } + + # このインスタンスは本当に$mod_nameそのものか？ + if (ref($mod) ne $mod_name) { + $this->_runloop->notify_error( + "A thing ".$mod_name."->new returned was not a instance of $mod_name."); + return undef; + } + + # timestampに登録 + $this->timestamp($mod_name,time); + + return $mod; +} + +sub _unload { + # 指定されたモジュールを削除する。 + # モジュール名の代わりにConfiguration::Blockを渡しても良い。 + my ($this,$modname) = @_; + $modname = $modname->block_name if UNIVERSAL::isa($modname,'Configuration::Block'); + + # このモジュールのuse時刻を消去 + delete $this->{mod_timestamps}->{$modname}; + + # このモジュールのブラックリストを消去。 + $this->remove_from_blacklist($modname); + + # このモジュールのファイル名を求めておく。 + (my $mod_filename = $modname) =~ s|::|/|g; + $mod_filename .= '.pm'; + + # シンボルテーブルを削除してしまえば変数やサブルーチンにアクセス出来なくなる。 + use Symbol (); + # サブパッケージを消す挙動は危険かもしれないのでとりあえず退避。 + # (%INC のこともあるし) + # ただし、サブパッケージの性格上メインパッケージなしに動く保証はどこにもない。 + + no strict; + my(%stab) = %{$modname.'::'}; + my %shelter = map { + if (/::$/ && + !/^(SUPER)::$/ && !/^::(ISA|ISA::CACHE)::$/) { + ($_, $stab{$_}); + } else { + (); + } + } keys(%stab); + + Symbol::delete_package($modname); + + # 隔離しておいたものを戻す。 + %{$modname.'::'} = ( %shelter, %{$modname.'::'} ); + + # %INCからも削除 + delete $INC{$mod_filename}; +} + +sub fix_USED_fields { + my $this = shift; + my $result; + no strict 'refs'; + foreach my $modname (keys %{$this->{mod_timestamps}}) { + my $USED = \%{$modname.'::USED'}; + if (defined $USED) { + my @mods_refer_me = keys %$USED; + foreach my $mod_refs_me (@mods_refer_me) { + # このモジュールの@USEには本当に$modnameが入っているか？ + my $USE = \@{$mod_refs_me.'::USE'}; + my $refers_actually = sub { + if (defined $USE) { + foreach (@$USE) { + if ($_ eq $modname) { + return 1; + } + } + } + undef; + }->(); + unless ($refers_actually) { + # 実際には参照されていなかった。 + delete $USED->{$mod_refs_me}; + $result = 1; + } + } + } + } + $result; +} + +sub gc { + # $this->{modules}から到達可能でないサブモジュールを全てアンロードする。 + my $this = shift; + my %all_mods = %{$this->{mod_timestamps}}; # コピーする + # %all_modsの要素で値が空になっている部分が、マークされた個所。 + + my $trace; + no strict 'refs'; + $trace = sub { + my $modname = shift; + # 既にマークされているか、もしくはモジュールが存在しなければ抜ける。 + my $val = $all_mods{$modname}; + if (!defined($val) || $val eq '') { + return; + } + else { + # このモジュールをマークする + $all_mods{$modname} = ''; + # このモジュールに@USEが定義されていたら、 + # その全てのモジュールについて再帰的にトレース。 + my $USE = \@{$modname.'::USE'}; + if (defined $USE) { + foreach (@$USE) { + $trace->($_); + } + } + } + }; + + for my $mod (@{$this->{modules}}) { + my $modname = ref $mod; + $trace->($modname); + } + + # マークされなかったサブモジュールは到達不可能なのでアンロードする。 + while (my ($key,$value) = each %all_mods) { + if ($value ne '') { + eval { + $key->destruct; + }; + + $this->_runloop->notify_msg( + "Submodule $key is no longer required. It will be unloaded."); + $this->_unload($key); + } + } +} + +1; diff -urN /non-existant-dir/main/Multicast.pm tiarra-20080510/main/Multicast.pm --- /non-existant-dir/main/Multicast.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/main/Multicast.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,752 @@ +# ----------------------------------------------------------------------------- +# $Id: Multicast.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +# サーバーからクライアントにメッセージが流れるとき、このクラスはフィルタとして +# ネットワーク名を付加します。 +# クライアントからサーバーに流れるとき、このクラスはネットワーク名をパースして +# 送るべき各サーバーに送ります。 +# ローカル←→グローバルnickの変換もここで行います。 +# ----------------------------------------------------------------------------- +package Multicast; +use strict; +use warnings; +use Configuration; +use Carp; +use NumericReply; +use base qw(Tiarra::IRC::NewMessageMixin); +my $runloop = undef; # デフォルトのRunLoopのキャッシュ。 +my $separator = ''; # セパレータ記号のキャッシュ。これらはcast_messageが呼ばれる度に更新される。 + +sub _ISON_from_client { + # nickをネットワーク毎に分類する。 + my ($message, $sender) = @_; + my $networks = classify($message->params); + + while (my ($network_name,$params) = each %$networks) { + my $network = $runloop->networks->{$network_name}; + my $msg = $message->clone; + @{$msg->params} = map { local_to_global($_,$network) } @$params; + $msg->remark('real-generator', __PACKAGE__); + forward_to_server($msg, $network_name); + } +} + +sub _INVITE_from_server { + my ($message,$sender) = @_; + # nickはそのまま。チャンネルにはネットワーク名を付ける。 + $message->nick(global_to_local($message->nick,$sender)); + $message->params->[0] = global_to_local($message->params->[0],$sender); + $message->params->[1] = attach($message->params->[1],$sender->network_name); + return $message; +} +sub _INVITE_from_client { + my ($message,$sender) = @_; + # nickはパースするだけで捨てる。チャンネルのパース結果を見る。 + my $to = ''; + ($message->params->[0]) = detach($message->params->[0]); + ($message->params->[1],$to) = detach($message->params->[1]); + $message->params->[0] = local_to_global($message->params->[0],$to); # 自分をINVITEする事など無いので必要は無いが… + forward_to_server($message,$to); +} + +sub _JOIN_from_server { + my ($message,$sender) = @_; + # カンマで区切られ複数のチャンネルが指定されていたとしても + # それらの全てにネットワーク名を付加する。(まさか無いだろうが。) + $message->nick(global_to_local($message->nick,$sender)); + + my @channels = split(/,/,$message->params->[0]); + my $n_channels = @channels; + for (my $i = 0; $i < $n_channels; $i++) { + $channels[$i] = attach($channels[$i],$sender->network_name); + } + $message->params->[0] = join(',',@channels); + return $message; +} +sub _JOIN_from_client { + my ($message,$sender) = @_; + # パスワードの部分は弄らず、ネットワーク名をパースして取り除く。 + # 各チャンネルをネットワーク毎に分類する。 + if ($message->params->[0] eq '0') { + # 0は特殊。 + # 全てのサーバーにJOIN 0を送る。 + distribute_to_servers($message->clone); + } + else { + my @targets = split(/,/,$message->params->[0]); + my $networks = classify(\@targets); + while (my ($network_name,$channels) = each %$networks) { + $message->params->[0] = join(',',@$channels); + forward_to_server($message,$network_name); + } + } +} + +sub _KICK_from_server { + my ($message,$sender) = @_; + # チャンネル名にだけ、ネットワーク名を付加する。 + $message->nick(global_to_local($message->nick,$sender)); + $message->params->[0] = attach($message->params->[0],$sender->network_name); + $message->params->[1] = global_to_local($message->params->[1],$sender); + return $message; +} +sub _KICK_from_client { + my ($message,$sender) = @_; + my @channels = split(/,/,$message->params->[0]); + my @nicks = split(/,/,$message->params->[1]); + if (scalar(@channels) == scalar(@nicks)) { + # チャンネルとnickが一対一で対応する。 + # チャンネルのネットワーク名を使用し、nickのネットワーク名は捨てる。 + for (my $i = 0; $i < @channels; $i++) { + my ($raw_channel,$to) = detach($channels[$i]); + my ($raw_nick) = detach($nicks[$i]); + + $message->params->[0] = $raw_channel; + $message->params->[1] = local_to_global($raw_nick,$runloop->networks->{$to}); + forward_to_server($message,$to); + } + } + elsif (@channels == 1) { + # 一つのチャンネルから複数のnickを蹴り出す。 + # チャンネルのネットワーク名を使用し、nickのネットワーク名は捨てる。 + my ($raw_channel,$to) = detach($channels[0]); + my $network = $runloop->networks->{$to}; + $message->params->[0] = $raw_channel; + + foreach my $nick (@nicks) { + my ($raw_nick) = detach($nick); + $message->params->[1] = local_to_global($raw_nick,$network); + + forward_to_server($message,$to); + } + } +} + +sub _LIST_from_client { + my ($message,$sender) = @_; + # チャンネルのネットワーク名で分類。 + if (defined $message->params->[0]) { + my @targets = split(/,/,$message->params->[0]); + my $networks = classify(\@targets); + + while (my ($network_name,$channels) = each %$networks) { + $message->params->[0] = join(',',@$channels); + forward_to_server($message,$network_name); + } + } + else { + forward_to_server($message, $runloop->default_network); + } +} + +sub _MODE_from_server { + my ($message,$sender) = @_; + $message->nick(global_to_local($message->nick,$sender)); + @{$message->params} = map( global_to_local($_,$sender) ,@{$message->params}); + + my $target = $message->params->[0]; + if (channel_p($target)) { + # nick(つまり自分)の場合はそのままクライアントに配布。 + # この場合はチャンネルなので、ネットワーク名を付加。 + $message->params->[0] = attach($target,$sender->network_name); + } + return $message; +} + +sub _MODE_from_client { + my ($message,$sender) = @_; + my $to; + ($message->params->[0],$to) = detach($message->params->[0]); + + my $network = $runloop->networks->{$to}; + @{$message->params} = map( local_to_global($_,$network) ,@{$message->params}); + + forward_to_server($message,$to); +} + +sub _TOPIC_from_server { + my ($message,$sender) = @_; + $message->nick(global_to_local($message->nick,$sender)); + + my $target = $message->params->[0]; + if (channel_p($target)) { + # nick(つまり自分)の場合はそのままクライアントに配布。 + # この場合はチャンネルなので、ネットワーク名を付加。 + $message->params->[0] = attach($target,$sender->network_name); + } + return $message; +} + +sub _TOPIC_from_client { + my ($message,$sender) = @_; + my $to; + ($message->params->[0],$to) = detach($message->params->[0]); + + forward_to_server($message,$to); +} + +sub _NICK_from_client { + # ネットワーク名が指定されていたら、その鯖にのみNICKを送信。 + # そうでなければ全ての鯖に送る。 + my ($message,$sender) = @_; + my $to; + my $specified; + ($message->params->[0],$to,$specified) = detach($message->params->[0]); + + if ($specified) { + forward_to_server($message,$to); + } + else { + distribute_to_servers($message); + } +} + +sub _NJOIN_from_server { + my ($message,$sender) = @_; + $message->param(0,attach($message->param(0),$sender->network_name)); + $message->param(1, + join(',', + map{ s/^([\@+]*)(.+)$/$1.global_to_local($2,$sender)/e; $_; } split(/,/,$message->param(1)))); + $message; +} + +sub _NOTICE_from_server { + my ($message,$sender) = @_; + $message->nick(global_to_local($message->nick,$sender)); + + my $target = $message->params->[0]; + if (channel_p($target)) { + # この場合はチャンネルなので、ネットワーク名を付加。 + $message->params->[0] = attach($target,$sender->network_name); + } else { + # nick(つまり自分)の場合は global_to_local を行う。 + $message->param(0, global_to_local($message->param(0),$sender)); + } + return $message; +} + +sub _WHOIS_from_client { + my ($message,$sender) = @_; + my $to; + ($message->params->[0],$to) = detach($message->params->[0]); + + my $network = $runloop->networks->{$to}; + $message->params->[0] = local_to_global($message->params->[0],$runloop->networks->{$to}); + + # ローカルnickと送信先のグローバルnickが異なっていたら、その旨をクライアントに報告する。 + # ただしWHOISの対象が自分だった場合のみ。 + my $local_nick = $runloop->current_nick; + my $global_nick = $network->current_nick; + if (($message->command eq 'WHOIS' || $message->command eq 'WHO') && + $message->param(0) eq $global_nick && + $local_nick ne $global_nick) { + $sender->send_message( + __PACKAGE__->construct_irc_message( + Prefix => $runloop->sysmsg_prefix(qw(priv system)), + Command => 'NOTICE', + Params => [$local_nick, + "*** Your global nick in $to is currently '$global_nick'."])); + } + + forward_to_server($message,$to); +} + +sub _RPL_USERHOST { + my ($message,$sender) = @_; + $message->params->[1] =~ s/^([^*=]+)(.+)$/global_to_local($1,$sender).$2/e; + $message; +} + +sub _RPL_ISON { + my ($message,$sender) = @_; + $message->params->[1] = + join(' ', + map { + global_to_local($_,$sender); + } split / /,$message->params->[1]); + $message; +} + +sub _RPL_INVITING { + my ($message,$sender) = @_; + $message->param(1,attach($message->param(1),$sender->network_name)); + $message->param(2,global_to_local($message->param(2),$sender)); + $message; +} + +sub _RPL_WHOREPLY { + my ($message, $sender) = @_; + $message->param(1,attach($message->param(1),$sender->network_name)); + $message->param(5,global_to_local($message->param(5),$sender)); + $message; +} + +sub _RPL_NAMREPLY { + my ($message,$sender) = @_; + $message->param(2,attach($message->param(2),$sender->network_name)); + $message->params->[3] = + join(' ', + map { + s/^([\@+]*)(.+)$/$1.global_to_local($2,$sender)/e; $_; + } split / /,$message->params->[3]); + $message; +} + +sub _attach_RPL_WHOISCHANNELS { + my ($message,$sender) = @_; + $message->param(1,global_to_local($message->param(1),$sender)); + $message->params->[2] = + join(' ', + map { + s/^([\@+]*)(.+)$/$1.attach($2, $sender->network_name)/e; $_; + } split / /,$message->params->[2]); + $message; +} + +sub _detach_RPL_WHOISCHANNELS { + my ($message,$sender) = @_; + $message->params->[2] = + join(' ', + map { + s/^([\@+]*)(.+)$/$1.detach($2)/e; $_; + } split / /,$message->params->[2]); + $message; +} + +my $g2l_cache = {}; +sub _gen_g2l_translator { + my $index = shift; + + unless (exists $g2l_cache->{$index}) { + $g2l_cache->{$index} = sub { + my ($message,$sender) = @_; + $message->params->[$index] = global_to_local($message->params->[$index],$sender); + $message; + }; + } + $g2l_cache->{$index}; +} + +my $attach_cache = {}; +sub _gen_attach_translator { + my $index = shift; + + unless (exists $attach_cache->{$index}) { + $attach_cache->{$index} = sub { + my ($message,$sender) = @_; + $message->param($index,attach($message->param($index),$sender->network_name)); + $message; + }; + } + $attach_cache->{$index}; +} + +my $detach_cache = {}; +sub _gen_detach_translator { + my $index = shift; + + if (!exists $detach_cache->{$index}) { + $detach_cache->{$index} = sub { + my ($message, $sender) = @_; + $message->param( + $index, + detach($message->param($index))); + forward_to_server($message, $sender); + }; + } + $detach_cache->{$index}; +} + +my $server_sent = { + 'INVITE' => \&_INVITE_from_server, + 'JOIN' => \&_JOIN_from_server, + 'KICK' => \&_KICK_from_server, + 'MODE' => \&_MODE_from_server, + 'NICK' => undef, # 本体は鯖からのNICKを弄らない。これを見て情報を更新するのはIrcIO::Serverである。 + 'NOTICE' => \&_NOTICE_from_server, # Prefixを弄るとすれば、それはモジュールの役目。 + 'PART' => \&_JOIN_from_server, # JOINと同じ処理で良い。 + 'PING' => undef, + 'PRIVMSG' => \&_NOTICE_from_server, # NOTICEと同じ処理で良い。 + 'QUIT' => undef, # QUITしたのが自分だったら捨てる、といった処理はIrcIO::Serverが行なう。 + 'SQUERY' => \&_MODE_from_server, # 多分これは鯖からも来るだろうが、良く分からない。 + 'TOPIC' => \&_TOPIC_from_server, + 'NJOIN' => \&_NJOIN_from_server, + (RPL_UNIQOPIS) => \&_RPL_INVITING, # UNIQOPIS (INVITINGと同じ処理) + # TRACE系のリプライはTiarraは関知しない。少なくとも今のところは。 + do { + my $sub = _gen_g2l_translator(1); + map { + (NumericReply::fetch_number($_), $sub) + } (map {"RPL_$_"} + ((map {"WHOIS$_"} qw(USER SERVER OPERATOR IDLE)), + (map {"ENDOF$_"} qw(WHOIS WHOWAS)), + qw(WHOWASUSER AWAY)))}, + do { + my $sub = _gen_attach_translator(1); + map { + (NumericReply::fetch_number($_), $sub); + } ((map {"RPL_$_"} + ((map { ("$_", "ENDOF$_"); } map {$_.'LIST'} + qw(INVITE EXCEPT BAN REOP)), + (map {"ENDOF$_"} qw(WHO NAMES)), + qw(LIST CHANNELMODEIS NOTOPIC TOPIC TOPICWHOTIME), + qw(CREATIONTIME))), + ((map {"ERR_$_"} + (qw(TOOMANYCHANNELS NOTONCHANNEL NOSUCHCHANNEL UNAVAILRESOURCE)))))}, + do { + no strict 'refs'; + map { + my $funcname = "_$_"; + (NumericReply::fetch_number($_), \&$funcname) + } (map {"RPL_$_"} + qw(USERHOST ISON INVITING WHOREPLY NAMREPLY))}, + do { + no strict 'refs'; + map { + my $funcname = "_attach_$_"; + (NumericReply::fetch_number($_), \&$funcname) + } (map {"RPL_$_"} + qw(WHOISCHANNELS))}, +}; + +my $client_sent = { + 'ISON' => \&_ISON_from_client, + 'INVITE' => \&_INVITE_from_client, + 'JOIN' => \&_JOIN_from_client, + 'KICK' => \&_KICK_from_client, + 'LIST' => \&_LIST_from_client, + 'MODE' => \&_MODE_from_client, + 'NAMES' => \&_LIST_from_client, # LISTと同じ処理で良い。 + 'NICK' => \&_NICK_from_client, + 'NOTICE' => \&_LIST_from_client, # LISTと同じ処理で良い。 + #'MODE' => \&_MODE_from_client, # MODEと同じ処理で良い。 + #↑意図不明。 + 'PART' => \&_LIST_from_client, # LISTと同じ処理で良い。 + 'PASS' => \&_MODE_from_client, # これを真面目に処理しないとSERVICE出来ない。MODEと同じで良い。 + 'PONG' => undef, + 'PRIVMSG' => \&_LIST_from_client, # NOTICEと同じ処理で良い。 + 'QUIT' => undef, # QUITをトラップするのはIrcIO::Client。つまりここには決してQUITは流れて来ない。 + 'SERVICE' => \&_MODE_from_client, # 良く分からないが、とりあえずMODEと同じにする。 + 'SERVLIST' => \&_MODE_from_client, # これも良く分からない。MODEと同じに。 + 'SERVSET' => \&_MODE_from_client, # これも。 + 'SQUERY' => \&_MODE_from_client, # これも + 'STATS' => \&_MODE_from_client, # サーバ名はうしろにつくのでこれはよくないかも + 'SUMMON' => \&_MODE_from_client, + 'TIME' => \&_MODE_from_client, + 'TOPIC' => \&_TOPIC_from_client, + 'TRACE' => \&_MODE_from_client, + 'UMODE' => \&_MODE_from_client, + 'USER' => undef, + 'USERHOST' => \&_ISON_from_client, + 'USERS' => \&_MODE_from_client, + 'VERSION' => \&_MODE_from_client, + 'ADMIN' => \&_MODE_from_client, + 'WHO' => \&_WHOIS_from_client, + 'WHOIS' => \&_WHOIS_from_client, + 'WHOWAS' => \&_WHOIS_from_client, + 'CLOSE' => \&_MODE_from_client, + 'CONNECT' => \&_MODE_from_client, # 無理があるが… + 'DIE' => \&_MODE_from_client, + 'KILL' => \&_MODE_from_client, + 'REHASH' => \&_MODE_from_client, + 'RESTART' => \&_MODE_from_client, + 'SQUIT' => \&_MODE_from_client, + 'ERROR' => undef, + 'NJOIN' => undef, # クライアントからNJOINを発行するのは勿論無意味。 + 'RECONNECT' => undef, + 'SERVER' => undef, + 'WALLOPS' => \&_MODE_from_client, # クライアントからWALLOPSを発行出来るのかどうかは知らないが… + # 以下リプライ。これはdetach_network_nameの為だけにある。 + (RPL_NAMREPLY) => _gen_detach_translator(2), + do { + my $sub = _gen_detach_translator(1); + map { + (NumericReply::fetch_number($_), $sub) + } ((map {"RPL_$_"} + ((map { ("$_", "ENDOF$_"); } qw(INVITELIST EXCEPTLIST BANLIST)), + (map {"ENDOF$_"} qw(WHO NAMES)), + qw(LIST CHANNELMODEIS NOTOPIC TOPIC TOPICWHOTIME), + qw(CREATIONTIME INVITING UNIQOPIS WHOREPLY))), + (map {"ERR_$_"} + (qw(TOOMANYCHANNELS NOTONCHANNEL NOSUCHCHANNEL UNAVAILRESOURCE))))}, + do { + no strict 'refs'; + map { + my $funcname = "_detach_$_"; + (NumericReply::fetch_number($_), \&$funcname) + } (map {"RPL_$_"} + qw(WHOISCHANNELS))}, +}; + + +sub _update_cache { + $separator = Configuration->shared_conf-> + networks->channel_network_separator; + $runloop = RunLoop->shared_loop; +} + +sub from_server_to_client { + no warnings; + my ($message, $sender) = @_; + &_update_cache; + # server -> clientの流れでは、一つのメッセージが複数に分割される事は無い。 + # この関数は一つのTiarra::IRC::Messageを返す。 + + if ($message->command =~ /^\d+$/) { + # ニューメリックリプライの0番目のパラメタは全てnick。 + $message->params->[0] = global_to_local($message->params->[0],$sender); + } + + eval { + # フィルタが無かったり、フィルタの実行中に例外が起こったりした場合はそのまま返す。 + $message = $server_sent->{$message->command}->($message, $sender); + }; if ($@) { + $message->nick(global_to_local($message->nick,$sender)); + } + return $message; +} + +sub from_client_to_server { + no warnings; + my ($message, $sender) = @_; + &_update_cache; + # client -> serverの流れでは、一つのメッセージが複数に分割される事がある。 + # この関数はメッセージを鯖に直接送り、戻り値は返さない。 + eval { + $client_sent->{$message->command}->($message, $sender); + }; if ($@) { + forward_to_server($message,$runloop->default_network); + } +} + +sub detach_network_name { + no strict; + no warnings; + my ($message, $sender) = @_; + &_update_cache; + my $result; + local $hijack_forward_to_server = sub { + my ($msg, $network_name) = @_; + $result = $msg; + }; + local $hijack_local_to_global = 1; + eval { + $client_sent->{$message->command}->($message, $sender); + }; if ( !defined $result ) { + $hijack_forward_to_server->($message, $runloop->default_network); + } + $result; +} + +*detatch = \&detach; # 勘違いしていた。detachが正しい。 +sub detach { + # 戻り値: (セパレータ前の文字列,ネットワーク名,ネットワーク名が明示されたかどうか) + # ただしスカラーコンテクストではセパレータ前の文字列のみを返す。 + my $str = shift; + + if (!defined $str) { + croak "Arg[0] was undef.\n"; + } + elsif (ref($str) ne '') { + croak "Arg[0] was ref.\n"; + } + + my ($pkg_caller) = caller; + _update_cache() unless $pkg_caller->isa('Multicast'); + + my @result; + if ((my $sep_index = index($str,$separator)) != -1) { + my $before_sep = substr($str,0,$sep_index); + my $after_sep = substr($str,$sep_index+length($separator)); + if ((my $colon_pos = index($after_sep,':')) != -1) { + # #さいたま@taiyou:*.jp → #さいたま:*.jp + taiyou + @result = ($before_sep.substr($after_sep,$colon_pos), + substr($after_sep,0,$colon_pos), + 1); + } + else { + # #さいたま@taiyou → #さいたま + taiyou + @result = ($before_sep,$after_sep,1); + } + } + else { + @result = ($str,$runloop->default_network,undef); + } + return wantarray ? @result : $result[0]; +} + +sub detach_for_client { + my ($str) = @_; + + if (!$runloop->multi_server_mode_p) { + detach($str); + } else { + $str; + } +} + +sub attach { + # $strはChannelInfoのオブジェクトでも良い。 + # $network_nameは省略可能。IrcIO::Serverのオブジェクトでも良い。 + my ($str,$network_name) = @_; + if (ref($str) eq 'ChannelInfo') { + $str = $str->name; + } + if (ref($network_name) eq 'IrcIO::Server') { + $network_name = $network_name->network_name; + } + + if (!defined $str) { + croak "Arg[0] was undef.\n"; + } + elsif (ref($str) ne '') { + croak "Arg[0] was ref.\n"; + } + + my ($pkg_caller) = caller; + _update_cache() unless $pkg_caller->isa('Multicast'); + + $network_name = $runloop->default_network if $network_name eq ''; + if ((my $pos_colon = index($str,':')) != -1) { + # #さいたま:*.jp → #さいたま@taiyou:*.jp + $str =~ s/:/$separator.$network_name.':'/e; + } + else { + # #さいたま → #さいたま@taiyou + $str .= $separator.$network_name; + } + $str; +} + +sub attach_for_client { + my ($str, $network_name) = @_; + + if ($runloop->multi_server_mode_p) { + attach($str, $network_name); + } else { + $str; + } +} + +sub classify { + # array: 配列への参照 + # 戻り値: ネットワーク名→パース後の文字列を並べた配列への参照 + my $array = shift; + my $networks = {}; + foreach my $target (@$array) { + my ($str,$network_name) = detach($target); + if (defined $networks->{$network_name}) { + push @{$networks->{$network_name}},$str; + } + else { + # 初めて現われたネットワークである。 + $networks->{$network_name} = [$str]; + } + } + return $networks; +} + +sub forward_to_server { + # この関数は、動的スコープに置かれた変数 + # $hijack_forward_to_serverが定義されていたら、 + # それを関数リファと見做してサーバーに送る代わりに呼ぶ。 + no strict; + my ($msg, $network_name) = @_; + + if (defined $hijack_forward_to_server) { + #::printmsg("forward_to_server HIJACKED"); + $hijack_forward_to_server->($msg, $network_name); + } + else { + my $io = $runloop->network($network_name); + if (defined $io && $io->logged_in) { + $io->send_message($msg); + } + } +} + +sub distribute_to_servers { + no strict; + my $msg = shift; + foreach my $server ($runloop->networks_list) { + if (defined $hijack_forward_to_server) { + #::printmsg("forward_to_server HIJACKED"); + $hijack_forward_to_server->($msg, $server->network_name); + } + else { + $server->send_message($msg); + } + } +} + +sub nick_p { + # 文字列がnickとして許される形式であるかどうかを真偽値で返す。 + # これはクライアントで送るのを許されているか返すだけであって、 + # サーバから送られてくる nick の判定に使ってはいけない。 + my $str = detach(shift); + my $nicklen = shift; + return undef unless length($str) && + (!defined $nicklen || (length($str) <= $nicklen)); + + # and irc2.11 permits specially '0'. + my $first_char = '[a-zA-Z_\[\]\\\`\^\{\}\|]'; + my $remaining_char = '[0-9a-zA-Z_\-\[\]\\\`\^\{\}\|]'; + return ($str =~ /^${first_char}${remaining_char}*$/ || $str eq '0'); +} + +sub channel_p { + # 文字列がchannelとして許される形式であるかどうかを真偽値で返す。 + my $str = detach(shift); + return undef unless length($str); + my $chantypes = shift || '#&+!'; + + my $first_char = "[\Q$chantypes\E]"; + my $suffix_spec = '(?::[a-z*.]+)?'; + return $str =~ /^${first_char}.*${suffix_spec}$/ +} + +sub local_to_global { + # この関数は、動的スコープに置かれた変数 + # $hijack_local_to_globalが定義されていたら、 + # 何も変更せずに返す。 + no strict; + my ($str, $server) = @_; + if (defined $hijack_local_to_global) { + $str; + } + else { + if (defined($str) && $str eq $runloop->current_nick) { + $server->current_nick; + } + else { + $str; + } + } +} + +sub global_to_local { + my ($str,$server) = @_; + if (defined($str) && $str eq $server->current_nick) { + return $runloop->current_nick; + } + else { + return $str; + } +} + +sub lc { + # IRC方式で、大文字を小文字に変換する。 + my $str = shift; + # {}|は[]\の小文字である。気違いじみている! + $str =~ tr/A-Z[]\\/a-z{}|/; + $str; +} + +sub uc { + # IRC方式で、小文字を大文字に変換する。 + my $str = shift; + $str =~ tr/a-z{}|/A-Z[]\\/; + $str; +} + +1; diff -urN /non-existant-dir/main/NumericReply.pm tiarra-20080510/main/NumericReply.pm --- /non-existant-dir/main/NumericReply.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/main/NumericReply.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,280 @@ +# ----------------------------------------------------------------------------- +# $Id: NumericReply.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +# このファイルでは、各ニューメリックリプライに対するシンボルを定義し、exportします。 +# ----------------------------------------------------------------------------- +package NumericReply; +use strict; +use warnings; +require Exporter; +use base qw(Exporter); +our @EXPORT; +our %replies; +our %numbers; + +BEGIN { + my @replies = + split(/\n/, + q{ + --------------------- 通常メッセージ + RPL_WELCOME 001 + RPL_YOURHOST 002 + RPL_CREATED 003 + RPL_MYINFO 004 + RPL_ISUPPORT 005 + + # irc2.11.x or +hemp + RPL_BOUNCE 010 + RPL_REDIR 010 + + RPL_MAP 015 + RPL_MAPMORE 016 + RPL_MAPEND 017 + RPL_MAPSTART 018 + + # irc2.11.x + RPL_HELLO 020 + RPL_YOURID 042 + RPL_SAVENICK 043 + + + RPL_NONE 300 + RPL_AWAY 301 + RPL_USERHOST 302 + RPL_ISON 303 + RPL_TEXT 304 + RPL_UNAWAY 305 + RPL_NOWAWAY 306 + + RPL_WHOISUSER 311 + RPL_WHOISSERVER 312 + RPL_WHOISOPERATOR 313 + + RPL_WHOWASUSER 314 + # RPL_ENDOFWHO 315: below + RPL_ENDOFWHOWAS 369 + + RPL_WHOISCHANOP 316 # redundant and not needed but reserved + RPL_WHOISIDLE 317 + + RPL_ENDOFWHOIS 318 + RPL_WHOISCHANNELS 319 + + RPL_LISTSTART 321 + RPL_LIST 322 + RPL_LISTEND 323 + RPL_CHANNELMODEIS 324 + RPL_UNIQOPIS 325 + + RPL_CREATIONTIME 329 + + RPL_NOTOPIC 331 + RPL_TOPIC 332 + RPL_TOPICWHOTIME 333 + RPL_TOPIC_WHO_TIME 333 + + RPL_INVITING 341 + RPL_SUMMONING 342 + + # irc2.11 + RPL_REOPLIST 344 + RPL_ENDOFREOPLIST 345 + + RPL_INVITELIST 346 + RPL_ENDOFINVITELIST 347 + + RPL_EXCEPTLIST 348 + RPL_ENDOFEXCEPTLIST 349 + + RPL_VERSION 351 + + RPL_WHOREPLY 352 + RPL_ENDOFWHO 315 + RPL_NAMREPLY 353 + RPL_ENDOFNAMES 366 + + RPL_KILLDONE 361 + RPL_CLOSING 362 + RPL_CLOSEEND 362 + RPL_LINKS 364 + RPL_ENDOFLINKS 365 + # RPL_ENDOFNAMES 366: above + RPL_BANLIST 367 + RPL_ENDOFBANLIST 368 + # RPL_ENDOFWHOWAS 369: above + + RPL_INFO 371 + RPL_MOTD 372 + RPL_INFOSTART 373 + RPL_ENDOFINFO 374 + RPL_MOTDSTART 375 + RPL_ENDOFMOTD 376 + + RPL_YOUREOPER 381 + RPL_REHASHING 382 + RPL_YOURESERVICE 383 + RPL_MYPORTIS 384 + RPL_NOTOPERANYMORE 385 + + RPL_TIME 391 + RPL_USERSTART 392 + RPL_USERS 393 + RPL_ENDOFUSERS 394 + RPL_NOUSERS 395 + + + RPL_TRACELINK 200 + RPL_TRACECONNECTING 201 + RPL_TRACEHANDSHAKE 202 + RPL_TRACEUNKNOWN 203 + RPL_TRACEOPERATOR 204 + RPL_TRACEUSER 205 + RPL_TRACESERVER 206 + RPL_TRACESERVICE 207 + RPL_TRACENEWTYPE 208 + RPL_TRACECLASS 209 + RPL_TRACERECONNECT 210 + + RPL_STATSLINKINFO 211 + RPL_STATSCOMMANDS 212 + RPL_STATSCLINE 213 + RPL_STATSNLINE 214 + RPL_STATSILINE 215 + RPL_STATSKLINE 216 + RPL_STATSQLINE 217 + RPL_STATSYLINE 218 + RPL_ENDOFSTATS 219 + RPL_STATSPLINE 220 + RPL_UMODEIS 221 + + RPL_SERVICEINFO 231 + RPL_ENDOFSERVICE 232 + RPL_SERVICE 233 + RPL_SERVLIST 234 + RPL_SERVLISTEND 235 + + RPL_STATSIAUTH 239 + RPL_STATSVLINE 240 + RPL_STATSLLINE 241 + RPL_STATSUPTIME 242 + RPL_STATSOLINE 243 + RPL_STATSHLINE 244 + RPL_STATSSLINE 245 + RPL_STATSPING 246 + RPL_STATSBLINE 247 + RPL_STATSDEFINE 248 + RPL_STATSDEBUG 249 + RPL_STATSDLINE 250 + + RPL_LUSERCLIENT 251 + RPL_LUSEROP 252 + RPL_LUSERUNKNOWN 253 + RPL_LUSERCHANNELS 254 + RPL_LUSERME 255 + RPL_ADMINME 256 + RPL_ADMINLOC1 257 + RPL_ADMINLOC2 258 + RPL_ADMINEMAIL 259 + + RPL_TRACELOG 261 + RPL_TRACEEND 262 + RPL_TRYAGAIN 263 + + RPL_LOCALUSERS 265 + RPL_GLOBALUSERS 266 + + + --------------------- エラーメッセージ + ERR_NOSUCHNICK 401 + ERR_NOSUCHSERVER 402 + ERR_NOSUCHCHANNEL 403 + ERR_CANNOTSENDTOCHAN 404 + ERR_TOOMANYCHANNELS 405 + ERR_WASNOSUCHNICK 406 + ERR_TOOMANYTARGETS 407 + ERR_NOSUCHSERVICE 408 + ERR_NOORIGIN 409 + + ERR_NORECIPIENT 411 + ERR_NOTEXTTOSEND 412 + ERR_NOTOPLEVEL 413 + ERR_WILDTOPLEVEL 414 + ERR_BADMASK 415 + ERR_TOOMANYMATCHES 416 + + ERR_UNKNOWNCOMMAND 421 + ERR_NOMOTD 422 + ERR_NOADMININFO 423 + ERR_FILEERROR 424 + + ERR_NONICKNAMEGIVEN 431 + ERR_ERRONEOUSNICKNAME 432 + ERR_NICKNAMEINUSE 433 + ERR_SERVICENAMEINUSE 434 + ERR_SERVICECONFUSED 435 + ERR_NICKCOLLISION 436 + ERR_UNAVAILRESOURCE 437 + # ERR_DEAD 438: reserved for later use -krys + + ERR_USERNOTINCHANNEL 441 + ERR_NOTONCHANNEL 442 + ERR_USERONCHANNEL 443 + ERR_NOLOGIN 444 + ERR_SUMMONDISABLED 445 + ERR_USERSDISABLED 446 + + ERR_NOTREGISTERED 451 + + ERR_NEEDMOREPARAMS 461 + ERR_ALREADYREGISTRED 462 + ERR_NOPERMFORHOST 463 + ERR_PASSWDMISMATCH 464 + ERR_YOUREBANNEDCREEP 465 + ERR_YOUWILLBEBANNED 466 + ERR_KEYSET 467 + + ERR_CHANNELISFULL 471 + ERR_UNKNOWNMODE 472 + ERR_INVITEONLYCHAN 473 + ERR_BANNEDFROMCHAN 474 + ERR_BADCHANNELKEY 475 + ERR_BADCHANMASK 476 + ERR_NOCHANMODES 477 + ERR_BANLISTFULL 478 + + ERR_NOPRIVILEGES 481 + ERR_CHANOPRIVSNEEDED 482 + ERR_CANTKILLSERVER 483 + ERR_RESTRICTED 484 + ERR_UNIQOPRIVSNEEDED 485 + + ERR_NOOPERHOST 491 + ERR_NOSERVICEHOST 492 + + + ERR_UMODEUNKNOWNFLAG 501 + ERR_USERSDONTMATCH 502 + }); + foreach (@replies) { + s/^\s+//; + my ($key,$value,$comment) = split(/\s+/, $_, 3); + next unless defined $key; # キー名 + next if $key =~ /^-/; # コメント + next if $key =~ /^#/; # コメント + no strict 'refs'; + *$key = sub (){ $value; }; + $replies{$key} = $value; + $numbers{$value} = $key; + push @EXPORT, $key; + } +} + +sub fetch_number { + $replies{+shift}; +} + +sub fetch_name { + $numbers{+shift}; +} + +1; diff -urN /non-existant-dir/main/PersonInChannel.pm tiarra-20080510/main/PersonInChannel.pm --- /non-existant-dir/main/PersonInChannel.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/main/PersonInChannel.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,74 @@ +# -*- cperl -*- +# ----------------------------------------------------------------------------- +# $Id: PersonInChannel.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +# なるとや発言権を持っているかどうかの情報とPersonalInfoのセット。 +# ----------------------------------------------------------------------------- +package PersonInChannel; +use strict; +use warnings; +use Carp; +use PersonalInfo; +use Tiarra::DefineEnumMixin qw(PERSON HAS_O HAS_V REMARKS); +use Tiarra::Utils; +Tiarra::Utils->define_array_attr_getter(0, qw(person)); +Tiarra::Utils->define_array_attr_accessor(0, qw(has_o has_v)); + +sub new { + my ($class,$person,$has_o,$has_v) = @_; + croak "PersonInChannel->new requires 3 parameters.\n" if @_ != 4; + my $obj = bless [] => $class; + $obj->[PERSON] = $person; + $obj->[HAS_O] = $has_o; + $obj->[HAS_V] = $has_v; + $obj->[REMARKS] = undef; + $obj; +} + +sub info { + my ($this, $wantarray) = @_; + shift->[PERSON]->info($wantarray); +} + +sub priv_symbol { + my $this = shift; + + return '@' if ($this->has_o); + return '+' if ($this->has_v); + return ''; +} + +*remarks = \&remark; +sub remark { + my ($this,$key,$value) = @_; + my $remarks = $this->[REMARKS]; + + if (defined $value) { + if (!$remarks) { + $remarks = $this->[REMARKS] = {}; + } + + $remarks->{$key} = $value; + } + elsif (@_ >= 3) { + if ($remarks) { + delete $remarks->{$key}; + } + } + + if ($remarks) { + $remarks->{$key}; + } + else { + undef; + } +} + +sub delete_remark { + my ($this,$key) = @_; + if ($_ = $this->[REMARKS]) { + delete $_->{$key}; + } +} + +1; diff -urN /non-existant-dir/main/PersonalInfo.pm tiarra-20080510/main/PersonalInfo.pm --- /non-existant-dir/main/PersonalInfo.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/main/PersonalInfo.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,66 @@ +# ----------------------------------------------------------------------------- +# $Id: PersonalInfo.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +# nick,username,userhost等を持つ個人情報保持クラス。 +# このオブジェクトはIrcIO::Serverが管理する。 +# +# my $info = new PersonalInfo(Nick => 'saitama'); +# print $info->nick; +# $info->nick("taiyou"); +# ----------------------------------------------------------------------------- +package PersonalInfo; +use strict; +use warnings; +use Tiarra::IRC::Prefix; +use Tiarra::Utils; +use enum (qw(NICK USERNAME USERHOST REALNAME SERVER REMARK AWAY)); +use Carp; +our $AUTOLOAD; + +utils->define_array_attr_accessor(0, + qw(nick username userhost realname), + qw(server away)); + +sub new { + my ($class,%args) = @_; + + # 最低限Nickさえ指定されていれば良い。 + unless (defined $args{Nick}) { + croak "PersonalInfo must be created with Nick parameter.\n"; + } + + my $def_or_null = sub{ utils->get_first_defined(@_,''); }; + my $obj = bless [] => $class; + $obj->[NICK] = $def_or_null->($args{Nick}); + $obj->[USERNAME] = $def_or_null->($args{UserName}); + $obj->[USERHOST] = $def_or_null->($args{UserHost}); + $obj->[REALNAME] = $def_or_null->($args{RealName}); + $obj->[SERVER] = $def_or_null->($args{Server}); + $obj->[REMARK] = undef; # HASH + $obj->[AWAY] = $def_or_null->($args{Away}); + + $obj; +} + +sub info { + my ($this, $wantarray) = @_; + $wantarray ? + @$this[NICK, USERNAME, USERHOST] : + Tiarra::IRC::Prefix->new( + Nick => $this->nick, + User => $this->username, + Host => $this->userhost); +} + +sub remark { + my ($this, $key, $value) = @_; + if (defined($value) or @_ >= 3) { + $this->[REMARK] ||= {}; + $this->[REMARK]{$key} = $value; + } + + $this->[REMARK] ? + $this->[REMARK]{$key} : undef; +} + +1; diff -urN /non-existant-dir/main/ReloadTrigger.pm tiarra-20080510/main/ReloadTrigger.pm --- /non-existant-dir/main/ReloadTrigger.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/main/ReloadTrigger.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,41 @@ +# ----------------------------------------------------------------------------- +# $Id: ReloadTrigger.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +# confやモジュールのリロードの引き金。 +# ----------------------------------------------------------------------------- +package ReloadTrigger; +use strict; +use warnings; +use RunLoop; +use Configuration; +use ModuleManager; +use Timer; + +sub reload_conf_if_updated { + # confファイルが更新されていたらリロードし、 + # Tiarra内のそれぞれのクラスにconfの更新を通知する。 + # モジュール側で更新された場合になにかの処理をするには、 + # Configuration::Hook の reloaded を使ってください。 + if (Configuration->shared_conf->check_if_updated) { + Configuration->shared_conf->load; + RunLoop->shared_loop->update_networks; + ModuleManager->shared_manager->update_modules; + } +} + +sub reload_mods_if_updated { + ModuleManager->shared_manager->reload_modules_if_modified; +} + +sub _install_reload_timer { + Timer->new( + Name => __PACKAGE__.'/reload', + After => 0, + Code => sub { + reload_conf_if_updated; + reload_mods_if_updated; + } + )->install; +} + +1; diff -urN /non-existant-dir/main/RunLoop.pm tiarra-20080510/main/RunLoop.pm --- /non-existant-dir/main/RunLoop.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/main/RunLoop.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,1302 @@ +# ----------------------------------------------------------------------------- +# $Id: RunLoop.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +# このクラスはTiarraのメインループを実装します。 +# select()を実行し、サーバーやクライアントとのI/Oを行うのはこのクラスです。 +# ----------------------------------------------------------------------------- +# フック`before-select'及び`after-select'が使用可能です。 +# これらのフックは、それぞれselect()実行直前と直後に呼ばれます。 +# ----------------------------------------------------------------------------- +package RunLoop; +use strict; +use warnings; +use UNIVERSAL; +use Carp; +use IO::Socket::INET; +use IO::Select; +use Configuration; +use IrcIO::Server; +use IrcIO::Client; +use Mask; +use ModuleManager; +use Multicast; +use Timer; +use Hook; +use base qw(HookTarget); +use base qw(Tiarra::IRC::NewMessageMixin); +use Tiarra::OptionalModules; +use Tiarra::ShorthandConfMixin; +use Tiarra::SharedMixin qw(shared shared_loop); +use Tiarra::Utils; +use Tiarra::TerminateManager; +our $_shared_instance; +#use ControlPort; # lazy load + +BEGIN { + # Time::HiResは使えるか？ + eval q{ + use Time::HiRes qw(time); + }; if ($@) { + # 使えない。 + } +} + +sub _new { + shift->new(Configuration->shared); +} + +sub new { + my ($class, $conf) = @_; + carp 'conf is not specified!' unless defined $conf; + # early initialization + my $this = { + conf => $conf, + mod_manager => undef, + }; + bless $this, $class; + + # update + %$this = ( + %$this, + + # 受信用セレクタ。あらゆるソケットは常に受信の必要があるため、あらゆるソケットが登録されている。 + receive_selector => new IO::Select, + + # 送信用セレクタ。ソケットに対して送信すべきデータがある場合は限られていて、その場合にのみ登録されて終わり次第削除される。 + send_selector => new IO::Select, + + # Tiarraがリスニングしてクライアントを受け付けるためのソケット。IO::Socket。 + tiarra_server_socket => undef, + + # 現在のnick。全てのサーバーとクライアントの間で整合性を保ちつつnickを変更する手段を、RunLoopが用意する。 + current_nick => $this->_conf_general->nick, + + # 鯖から切断された時の動作。 + action_on_disconnected => do { + my $actions = { + 'part-and-join' => \&_action_part_and_join, + 'one-message' => \&_action_one_message, + 'message-for-each' => \&_action_message_for_each, + }; + my $action_name = $this->_conf_networks->action_when_disconnected; + unless (defined $action_name) { + $action_name = 'part-and-join'; + } + my $act = $actions->{$action_name}; + if (defined $act) { + $act; + } + else { + die "Unknown action specified as networks/action-when-disconnected: $action_name\n"; + } + }, + + multi_server_mode => 1, # マルチサーバーモードに入っているか否か + + default_network => undef, # デフォルトのネットワーク名 + networks => {}, # ネットワーク名 → IrcIO::Server + clients => [], # 接続されている全てのクライアント IrcIO::Client + + timers => [], # インストールされている全てのTimer + sockets => [], # インストールされている全てのTiarra::Socket + socks_to_cleanup => [], # クリーンアップ予定のSocket(not Tiarra::Socket) + + conf_reloaded_hook => undef, # この下でインストールするフック + + terminating => 0, # 正のときは終了処理中。 + ); + + $this->{conf_reloaded_hook} = Configuration::Hook->new( + sub { + $this->_config_changed(0); + }, + )->install(undef, $this->_conf); + + $this->{default_network} = $this->_conf_networks->default; + + $this; +} + +sub DESTROY { + my $this = shift; + if (defined $this->{conf_reloaded_hook}) { + $this->{conf_reloaded_hook}->uninstall; + } +} + +sub network { + my ($class_or_this,$network_name) = @_; + my $this = $class_or_this->_this; + return $this->{networks}->{$network_name}; +} + +sub networks { + my ($class_or_this,@options) = @_; + my $this = $class_or_this->_this; + + if (defined $options[0] && $options[0] eq 'even-if-not-connected') { + $this->{networks}; + } else { + my $hash = $this->{networks}; + $hash = { + map { $_ => $hash->{$_} } + grep { $hash->{$_}->connected } + keys %$hash}; + } +} + +utils->define_attr_getter(1, qw(default_network clients), + [qw(multi_server_mode_p multi_server_mode)], + [qw(_mod_manager mod_manager)]); + +# クライアントから見た、現在のnick。 +# このnickは実際に使われているnickとは異なっている場合がある。 +# すなわち、希望のnickが既に使われていた場合である。 +utils->define_attr_getter(1, qw(current_nick)); + +sub networks_list { values %{shift->networks(@_)}; } +sub clients_list { @{shift->clients}; } + +sub channel { + # $ch_long: ネットワーク名修飾付きチャンネル名 + # 見付かったらChannelInfo、見付からなければundefを返す。 + my ($class_or_this,$ch_long) = @_; + my $this = $class_or_this->_this; + + my ($ch_short,$net_name) = Multicast::detach($ch_long); + my $network = $this->{networks}->{$net_name}; + if (!defined $network) { + return undef; + } + + $network->channel($ch_short); +} + +sub set_current_nick { + my ($class_or_this,$new_nick) = @_; + my $this = $class_or_this->_this; + $this->{current_nick} = $new_nick; + $this->call_hooks('set-current-nick'); +} + +sub change_nick { + my ($class_or_this,$new_nick) = @_; + my $this = $class_or_this->_this; + + foreach my $io ($this->networks_list) { + $io->send_message( + $this->construct_irc_message( + Command => 'NICK', + Param => $new_nick)); + } +} + +sub _runloop { shift->_this; } + +sub sysmsg_prefix { + my ($class_or_this,$purpose,$category) = @_; + my $this = $class_or_this->_this; + $category = (caller)[0] . (defined $category ? "::$category" : ''); + # $purpose は、この関数で得た prefix を何に使うかを示す。 + # いまのところ system(NumericReply など)/priv/channel + # $category は、大まかなカテゴリ。 + # いまのところ log/system/notify があるが、 + # 明確な仕様はまだない。 + + if (Mask::match_array([ + $this->_conf_general->sysmsg_prefix_use_masks('block')-> + get($purpose, 'all')], $category)) { + $this->_conf_general->sysmsg_prefix; + } else { + undef + } +} + + +sub _config_changed { + my ($this, $init) = @_; + + my ($old, $new); + # マルチサーバーモードのOn/Offが変わったか？ + $old = $this->{multi_server_mode}; + $new = utils->cond_yesno($this->_conf_networks->multi_server_mode); + if ($old != $new) { + # 変わった + if ($init) { + $this->{multi_server_mode} = $new; + } else { + $this->_multi_server_mode_changed; + } + } +} + +sub _multi_server_mode_changed { + my $this = shift; + # 一旦全てのチャンネルについてPARTを発行した後、 + # モードを変え接続中ネットワークを更新し、NICKとJOINを発行する。 + my $new = !$this->{multi_server_mode}; + + foreach my $string ( + 'Multi server mode *'.($new ? 'enabled' : 'disabled').'*', + q{It looks as if you would part all channels, but it's just an illusion.}) { + $this->broadcast_to_clients( + $this->construct_irc_message( + Prefix => $this->sysmsg_prefix(qw(priv system)), + Command => 'NOTICE', + Params => [$this->current_nick, $string])); + } + + my $iterate = sub { + my $func = shift; + foreach my $network ($this->networks_list) { + foreach my $ch ($network->channels_list) { + foreach my $client ($this->clients_list) { + $func->($network, $ch, $client); + } + } + } + }; + + $iterate->( + sub { + my ($network, $ch, $client) = @_; + $client->send_message( + $this->construct_irc_message( + Prefix => $client->fullname, + Command => 'PART', + Params => [ + do { + if ($new) { + # これまではネットワーク名が付いていなかった。 + $ch->name; + } + else { + scalar Multicast::attach( + $ch->name, $network->network_name); + } + }, + '[Caused by Tiarra] Clients have to part all channels.', + ], + ) + ); + } + ); + $this->{multi_server_mode} = $new; + $this->update_networks; + my $global_nick = (($this->networks_list)[0])->current_nick; + if ($global_nick ne $this->current_nick) { + $this->broadcast_to_clients( + $this->construct_irc_message( + Command => 'NICK', + Param => $global_nick, + Remarks => {'fill-prefix-when-sending-to-client' => 1 + })); + + $this->set_current_nick($global_nick); + } + foreach my $client ($this->clients_list) { + $client->inform_joinning_channels; + } +} + +sub _update_send_selector { + my $this = shift; + # 送信する必要のあるTiarra::Socketだけを抜き出し、そのソケットを送信セレクタに登録する。 + + my $sel = $this->{send_selector} = IO::Select->new; + foreach my $socket (@{$this->{sockets}}) { + if ($socket->want_to_write) { + $sel->add($socket->sock); + } + } +} + +sub _cleanup_closed_link { + # networksとclientsの中から切断されたリンクを探し、 + # そのソケットをセレクタから外す。 + # networksならクライアントに然るべき通知をし、再接続するタイマーをインストールする。 + my $this = shift; + + my $do_update_networks_after = 0; + while (my ($network_name,$io) = each %{$this->networks('even-if-not-connected')}) { + next if $io->connected || $io->connecting; + if ($io->state_finalized) { + delete $this->{networks}->{$network_name}; + } elsif ($io->state_terminated) { + $do_update_networks_after = 1; + } + } + if ($do_update_networks_after) { + Timer->new( + After => $do_update_networks_after, + Code => sub { + $this->update_networks; + }, + )->install($this); + } + + for (my $i = 0; $i < @{$this->{clients}}; $i++) { + my $io = $this->{clients}->[$i]; + unless ($io->connected) { + #::printmsg("Connection with ".$io->fullname." has been closed."); + #$this->unregister_receive_socket($io->sock); + splice @{$this->{clients}},$i,1; + $i--; + } + } +} + +sub _action_part_and_join { + # $event: 'connected' 若しくは 'disconnected' + # 今のところ、このメソッドはconfからの削除による切断時にも流用されている。 + my ($this,$network,$event) = @_; + my $network_name = $network->network_name; + if ($event eq 'connected') { + $this->_rejoin_all_channels($network); + } + elsif ($event eq 'disconnected') { + foreach my $client (@{$this->clients}) { + foreach my $ch (values %{$network->channels}) { + $client->send_message( + $this->construct_irc_message( + Prefix => $client->fullname, + Command => 'PART', + Params => [Multicast::attach_for_client($ch->name,$network_name), + $network->host." closed the connection."])); + } + } + } +} +sub _action_one_message { + my ($this,$network,$event) = @_; + my $network_name = $network->network_name; + if ($event eq 'connected') { + $this->_rejoin_all_channels($network); + $this->broadcast_to_clients( + $this->construct_irc_message( + Prefix => $this->sysmsg_prefix(qw(priv system)), + Command => 'NOTICE', + Params => [$this->current_nick, + '*** The connection has been revived between '.$network->network_name.'.'])); + } + elsif ($event eq 'disconnected') { + $this->broadcast_to_clients( + $this->construct_irc_message( + Prefix => $this->sysmsg_prefix(qw(priv system)), + Command => 'NOTICE', + Params => [$this->current_nick, + '*** The connection has been broken between '.$network->network_name.'.'])); + } +} +sub _action_message_for_each { + my ($this,$network,$event) = @_; + my $network_name = $network->network_name; + if ($event eq 'connected') { + $this->_rejoin_all_channels($network); + + my $msg = $this->construct_irc_message( + Prefix => $this->sysmsg_prefix(qw(channel system)), + Command => 'NOTICE', + Params => ['', # チャンネル名は後で設定。 + '*** The connection has been revived between '.$network->network_name.'.']); + foreach my $ch (values %{$network->channels}) { + $msg->param(0,Multicast::attach_for_client($ch->name,$network_name)); + $this->broadcast_to_clients($msg); + } + } + elsif ($event eq 'disconnected') { + my $msg = $this->construct_irc_message( + Prefix => $this->sysmsg_prefix(qw(channel system)), + Command => 'NOTICE', + Params => ['', # チャンネル名は後で設定。 + '*** The connection has been broken between '.$network->network_name.'.']); + foreach my $ch (values %{$network->channels}) { + $msg->param(0,Multicast::attach_for_client($ch->name,$network_name)); + $this->broadcast_to_clients($msg); + } + } +} +sub _rejoin_all_channels { + my ($this,$network) = @_; + # networkが記憶している全てのチャンネルにJOINする。 + # そもそもJOINしていないチャンネルは通常IrcIO::Serverは記憶していないが、 + # サーバーから切断された時だけは例外である。 + # 尚、註釈kicked-outが付けられているチャンネルにはJOINしない。 + my @ch_with_key; # パスワードを持ったチャンネルの配列。要素は["チャンネル名","パスワード"] + my @ch_without_key; # パスワードを持たないチャンネルの配列。要素は"チャンネル名" + foreach my $ch (values %{$network->channels}) { + next if $ch->remarks('kicked-out'); + + my $password = $ch->parameters('k'); + if (defined $password && $password ne '') { + push @ch_with_key,[$ch->name,$password]; + } + else { + push @ch_without_key,$ch->name; + } + } + # JOIN実行 + my ($buf_ch,$buf_key) = ('',''); + my $buf_flush = sub { + return if ($buf_ch eq ''); + my $params = do { + if ($buf_key eq '') { + [$buf_ch]; + } + else { + [$buf_ch,$buf_key]; + } + }; + $network->send_message( + $this->construct_irc_message( + Command => 'JOIN', + Params => $params)); + $buf_ch = $buf_key = ''; + }; + my $buf_put = sub { + my ($ch,$key) = @_; + $buf_ch .= ($buf_ch eq '' ? $ch : ",$ch"); + $buf_key .= ($buf_key eq '' ? $key : ",$key") if defined $key; + if (length($buf_ch) + length($buf_key) > 400) { + # 400バイトを越えたら自動でフラッシュする。 + $buf_flush->(); + } + }; + # パスワード付きのチャンネルにJOIN + foreach (@ch_with_key) { + $buf_put->($_->[0],$_->[1]); + } + $buf_flush->(); + # パスワード無しのチャンネルにJOIN + foreach (@ch_without_key) { + $buf_put->($_); + } + $buf_flush->(); +} + +sub update_networks { + my $this = shift; + # networks/nameを読み、その中にまだ接続していないネットワークがあればそれを接続し、 + # 接続中のネットワークで既にnetworks/nameに列挙されていないものがあればそれを切断する。 + my @net_names = $this->_conf_networks->name('all'); + my $do_update_networks_after = 0; # 秒数 + my $do_cleanup_closed_links_after = 0; + my $host_tried = {}; # {接続を試みたホスト名 => 1} + + $this->{default_network} = $this->_conf_networks->default; + + # マルチサーバーモードでなければ、@net_namesの要素は一つに限られるべき。 + # そうでなければ警告を出し、先頭のものだけを残して後は捨てる。 + if (!$this->{multi_server_mode}) { + if (@net_names > 1) { + $this->notify_warn( + "In single server mode, Tiarra will connect to just a one network; `". + $net_names[0]."'"); + @net_names = $net_names[0]; + } + if (@net_names > 0) { + $this->{default_network} = $net_names[0]; + } + } + + my ($net_conf, $network, $genre); + foreach my $net_name (@net_names) { + $net_conf = $this->_conf->get($net_name); + + $network = $this->network($net_name); + eval { + if (!defined $network) { + # 新しいネットワーク + $network = IrcIO::Server->new($this, $net_name); + $this->{networks}->{$net_name} = $network; # networksに登録 + } + else { + if ($network->state_connected || $network->state_connecting) { + # 既に接続されている。 + # このサーバーについての設定が変わっていたら、一旦接続を切る。 + if (!$net_conf->equals($network->config)) { + $network->state_reconnecting(1); + $network->quit( + $this->_conf_messages->quit->netconf_changed_reconnect); + } + } elsif ($network->state_terminated) { + # 終了している + # このサーバーについての設定が変わっていたら、接続する。 + if (!$net_conf->equals($network->config)) { + $this->reconnect_server($net_name); + } + } + } + }; if ($@) { + if ($@ =~ /^[Cc]ouldn't connect to /i) { + ::printmsg($@); + } else { + $this->notify_error($@); + } + # タイマー作り直し。 + $do_update_networks_after = 3; + } + } + + if ($do_cleanup_closed_links_after) { + $this->_cleanup_closed_link; + } + + my @nets_to_disconnect; + my @nets_to_forget; + my $is_there_in_net_names = sub { + my $network_name = shift; + # このネットワークは@net_names内に列挙されているか？ + foreach my $enumerated_net (@net_names) { + return 1 if $network_name eq $enumerated_net; + } + return 0; + }; + # networksから不要なネットワークを削除 + while (my ($net_name,$server) = each %{$this->{networks}}) { + # 入っていなかったらselectorから外して切断する。 + unless ($is_there_in_net_names->($net_name)) { + push @nets_to_disconnect,$net_name; + } + } + foreach my $net_name (@nets_to_disconnect) { + my $server = $this->{networks}->{$net_name}; + $server->finalize( + $this->_conf_messages->quit->netconf_changed_disconnect); + } + + if ($do_update_networks_after) { + Timer->new( + After => $do_update_networks_after, + Code => sub { + $this->update_networks; + }, + )->install($this); + } +} + +sub terminate_server { + my ($class_or_this,$network, $msg) = @_; + my $this = $class_or_this->_this; + + $network->terminate($msg); +} + +sub reconnect_server { + # terminate/disconnect(サーバから)されたサーバへ接続しなおす。 + my ($class_or_this,$network_name) = @_; + my $this = $class_or_this->_this; + my $network = $this->network($network_name); + + $network->reconnect if defined $network; +} + +sub disconnect_server { + # 指定されたサーバーとの接続を切る。 + # fdの監視をやめてしまうので、この後IrcIO::Serverのreceiveはもう呼ばれない事に注意。 + # $server: IrcIO::Server + my ($class_or_this,$server) = @_; + my $this = $class_or_this; + $server->terminate(''); +} + +sub close_client { + # 指定したクライアントとの接続を切る。 + # $client: IrcIO::Client + my ($class_or_this, $client, $message) = @_; + my $this = $class_or_this->_this; + $client->send_message( + $this->construct_irc_message( + Command => 'ERROR', + Param => 'Closing Link: ['.$client->fullname_from_client. + '] ('.$message.')', + Remarks => {'send-error-as-is-to-client' => 1}, + )); + $client->disconnect_after_writing; +} + +sub reconnected_server { + my ($class_or_this,$network) = @_; + my $this = $class_or_this->_this; + # 再接続だった場合の処理 + $this->{action_on_disconnected}->($this,$network,'connected'); +} + +sub disconnected_server { + my ($class_or_this,$network) = @_; + my $this = $class_or_this->_this; + $this->{action_on_disconnected}->($this,$network,'disconnected'); +} + +sub install_socket { + my ($this,$socket) = @_; + if (!defined $socket) { + croak "RunLoop->install_socket, Arg[1] was undef.\n"; + } + + push @{$this->{sockets}},$socket; + $this->register_receive_socket($socket->sock); # 受信セレクタに登録 + undef; +} + +sub uninstall_socket { + my ($this,$socket) = @_; + if (!defined $socket) { + croak "RunLoop->uninstall_socket, Arg[1] was undef.\n"; + } + + for (my $i = 0; $i < @{$this->{sockets}}; $i++) { + if ($this->{sockets}->[$i] == $socket) { + splice @{$this->{sockets}},$i,1; + $this->unregister_receive_socket($socket->sock); # 受信セレクタから登録解除 + push @{$this->{socks_to_cleanup}},$socket->sock; + $i--; + } + } + $this; +} + +sub register_receive_socket { + # 内部 API です。外部から使うときは Tiarra::Socket または + # ExternalSocket を使用してください。 + shift->{receive_selector}->add(@_); +} + +sub unregister_receive_socket { + # 内部 API です。外部から使うときは Tiarra::Socket または + # ExternalSocket を使用してください。 + shift->{receive_selector}->remove(@_); +} + +sub find_socket_with_sock { + my ($this,$sock) = @_; + foreach my $socket (@{$this->{sockets}}) { + if (!defined $socket->sock) { + warn 'Socket '.$socket->name.': uninitialized sock!'; + } elsif ($socket->sock == $sock) { + return $socket; + } + } + undef; +} + +sub install_timer { + my ($this,$timer) = @_; + push @{$this->{timers}},$timer; + $this; +} + +sub uninstall_timer { + my ($this,$timer) = @_; + for (my $i = 0; $i < scalar(@{$this->{timers}}); $i++) { + if ($this->{timers}->[$i] == $timer) { + splice @{$this->{timers}},$i,1; + $i--; + } + } + $this; +} + +sub get_earliest_timer { + # 登録されている中で最も起動時間の早いタイマーを返す。 + # タイマーが一つも無ければundefを返す。 + my $this = shift; + return undef if (scalar(@{$this->{timers}}) == 0); + + my $eariest = $this->{timers}->[0]; + foreach my $timer (@{$this->{timers}}) { + if ($timer->time_to_fire < $eariest->time_to_fire) { + $eariest = $timer; + } + } + return $eariest; +} + +sub _execute_all_timers_to_fire { + my $this = shift; + + # executeすべきタイマーを集める + my @timers_to_execute = (); + foreach my $timer (@{$this->{timers}}) { + push @timers_to_execute,$timer if $timer->time_to_fire <= time; + } + + # 実行 + foreach my $timer (@timers_to_execute) { + $timer->execute; + } +} + +sub run { + my $this = shift->_this; + my $conf_general = $this->_conf_general; + + # config から初期化 + $this->_config_changed(1); + + # FIXME: only shared + $this->{mod_manager} = + ModuleManager->shared($this); + + # まずはtiarra-portをlistenするソケットを作る。 + # 省略されていたらlistenしない。 + # この値が数値でなかったらdie。 + my $tiarra_port = $conf_general->tiarra_port; + if (defined $tiarra_port) { + if ($tiarra_port !~ /^\d+/) { + die "general/tiarra-port must be integer. '$tiarra_port' is invalid.\n"; + } + + # v4とv6の何れを使うか？ + my @serversocket_args = ( + LocalPort => $tiarra_port, + Proto => 'tcp', + Reuse => 1, + Listen => 0); + my $ip_version = $conf_general->tiarra_ip_version || 'v4'; + my $tiarra_server_socket = do { + if ($ip_version eq 'v4') { + my $bind_addr = $conf_general->tiarra_ipv4_bind_addr; + my @args = do { + if (defined $bind_addr) { + @serversocket_args,LocalAddr => $bind_addr; + } + else { + @serversocket_args; + } + }; + IO::Socket::INET->new(@args); + } + elsif ($ip_version eq 'v6') { + if (!Tiarra::OptionalModules->ipv6) { + ::printmsg("*** IPv6 support is not enabled ***"); + ::printmsg("Set general/tiarra-ip-version to 'v4' or install Socket6.pm if possible.\n"); + die; + } + my $bind_addr = $conf_general->tiarra_ipv6_bind_addr; + my @args = do { + if (defined $bind_addr) { + @serversocket_args,LocalAddr => $bind_addr; + } + else { + @serversocket_args; + } + }; + IO::Socket::INET6->new(@args); + } + else { + die "Unknown ip-version '$ip_version' specified as general/tiarra-ip-version.\n"; + } + }; + if (defined $tiarra_server_socket) { + $tiarra_server_socket->autoflush(1); + $this->{tiarra_server_socket} = $tiarra_server_socket; + $this->register_receive_socket($tiarra_server_socket); # セレクタに登録。 + main::printmsg("Tiarra started listening ${tiarra_port}/tcp. (IP$ip_version)"); + } + else { + # ソケット作れなかった。 + die "Couldn't make server socket to listen ${tiarra_port}/tcp. (IP$ip_version)\n"; + } + } + + # 鯖に接続 + $this->update_networks; + + # 3分毎に全ての鯖とクライアントにPINGを送るタイマーをインストール。 + # これはtcp接続の切断に気付かない事があるため。 + # 応答のPONGは捨てる。このためにPONG破棄カウンタをインクリメントする。 + # PONG破棄カウンタはIrcIO::Serverのremarkで、キーは'pong-drop-counter' + Timer->new( + Interval => 3 * 60, + Code => sub { + foreach my $network ($this->networks_list) { + $network->send_message( + $this->construct_irc_message( + Command => 'PING', + Param => $network->server_hostname)); + + my $cntr = $network->remark('pong-drop-counter'); + $network->remark('pong-drop-counter', + utils->get_first_defined($cntr,0) + 1); + } + + my $prefix = $this->_runloop->sysmsg_prefix('system'); + foreach my $client ($this->clients_list) { + $client->send_message( + $this->construct_irc_message( + Command => 'PING', + Param => $prefix)); + + my $cntr = $client->remark('pong-drop-counter'); + $client->remark('pong-drop-counter', + utils->get_first_defined($cntr,0) + 1); + } + }, + Repeat => 1, + Name => __PACKAGE__ . '/send ping', + )->install; + + # control-socket-nameが指定されていたら、ControlPortを開く。 + if ($conf_general->control_socket_name) { + require ControlPort; + eval { + $this->{control_port} = ControlPort->new($conf_general->control_socket_name); + }; if ($@) { + ::printmsg($@); + } + } + + my $zerotime = { + limit => 300, + minimum_to_reset => 2, + interval => 10, + + count => 0, + last_warned => 0, + }; + my $zerotime_warn = sub { + my $elapsed = shift; + + if ($elapsed == 0) { + $zerotime->{count}++; + if ($zerotime->{count} >= $zerotime->{limit}) { + $zerotime->{count} = 0; + + if ($zerotime->{last_warned} + $zerotime->{interval} < CORE::time) { + $zerotime->{last_warned} = CORE::time; + + $this->notify_warn("Tiarra seems to be slowing down your system!"); + } + } + } + elsif ($elapsed > $zerotime->{minimum_to_reset}) { + $zerotime->{count} = 0; + } + }; + + while (1) { + # 処理の流れ + # + # 書きこみ可能なソケットを集めて、必要があれば書き込む。 + # 次に読み込み可能なソケットを集めて、(読む必要は常にあるので)読む。 + # 読んだ場合は通常Tiarra::IRC::Messageの配列が返ってくるので、 + # 必要な全てのプラグインに順番に通す。(プラグインはフィルターとして考える。) + # それがサーバーから読んだメッセージだったなら、プラグインを通した後、接続されている全てのクライアントにそれを転送する。 + # クライアントが一つも接続されていなければ、そのTiarra::IRC::Message群は捨てる。 + # クライアントから読んだメッセージだったなら、プラグインを通した後、渡すべきサーバーに転送する。 + # + # selectにおけるタイムアウトは次のようにする。 + # (普段は何かしら登録されていると思うが)タイマーが一つも登録されていなければ、タイムアウトは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) { + $timeout = $eariest_timer->time_to_fire - time; + } + if ($timeout < 0) { + $timeout = 0; + } + # Windowsだと, select()中にCtrl-Cが効かなくなるので, + # !defined($timeout) || $timeout > 閾値 and $timeout = 閾値. + # とかで時々ブロック解除した方がよいのかもしれない. + + # 書き込むべきデータがあるソケットだけをsend_selectorに登録する。そうでないソケットは除外。 + $this->_update_send_selector; + + # select実行 + my $time_before_select = CORE::time; + my ($readable_socks,$writable_socks,$has_exception_socks) = + IO::Select->select($this->{receive_selector},$this->{send_selector},$this->{receive_selector},$timeout); + $zerotime_warn->(CORE::time - $time_before_select); + # select後フックを呼ぶ + $this->call_hooks('after-select'); + + foreach my $sock ($this->{receive_selector}->can_read(0)) { + if (defined $this->{tiarra_server_socket} && + $sock == $this->{tiarra_server_socket}) { + + # クライアントからの新規の接続 + my $new_sock = $sock->accept; + if (defined $new_sock) { + if (!$this->{terminating}) { + eval { + my $client = new IrcIO::Client($this, $new_sock); + push @{$this->{clients}},$client; + }; if ($@) { + $this->notify_msg($@); + } + } else { + $new_sock->shutdown(2); + } + } else { + $this->notify_error('unknown readable on listen sock'); + } + } + elsif (my $socket = $this->find_socket_with_sock($sock)) { + eval { + $socket->read; + + if (UNIVERSAL::isa($socket, 'IrcIO')) { + while (1) { + my $msg = eval { + $socket->pop_queue; + }; if ($@) { + if (ref($@) && + UNIVERSAL::isa($@,'QueueIsEmptyException')) { + last; + } + else { + ::printmsg($@); + last; + } + } + + if (!defined $msg) { + next; + } + + # このメッセージがPONGであればpong-drop-counterを見る。 + if ($msg->command eq 'PONG') { + my $cntr = $socket->remark('pong-drop-counter'); + if (defined $cntr && $cntr > 0) { + # このPONGは捨てる。 + $cntr--; + $socket->remark('pong-drop-counter',$cntr); + next; + } + } + + if ($socket->isa("IrcIO::Server")) { + # メッセージをMulticastのフィルタに通す。 + my @received_messages = + Multicast::from_server_to_client($msg,$socket); + # モジュールを通す。 + my $filtered_messages = $this->_apply_filters(\@received_messages,$socket); + # シングルサーバーモードなら、ネットワーク名を取り外す。 + if (!$this->{multi_server_mode}) { + @$filtered_messages = map { + Multicast::detach_network_name($_, $socket); + } @$filtered_messages; + } + # 註釈do-not-send-to-clients => 1が付いていないメッセージを各クライアントに送る。 + $this->broadcast_to_clients( + grep { + !($_->remark('do-not-send-to-clients')); + } @$filtered_messages); + } + else { + # シングルサーバーモードなら、メッセージをMulticastのフィルタに通す。 + my @received_messages = + (!$this->{multi_server_mode}) ? Multicast::from_server_to_client($msg,$this->networks_list) : $msg; + + # モジュールを通す。 + my $filtered_messages = $this->_apply_filters(\@received_messages,$socket); + # 対象となる鯖に送る。 + # NOTICE及びPRIVMSGは返答が返ってこないので、同時にこれ以外のクライアントに転送する。 + # 註釈do-not-send-to-servers => 1が付いているメッセージはここで破棄する。 + foreach my $msg (@$filtered_messages) { + if ($msg->remark('do-not-send-to-servers')) { + next; + } + + my $cmd = $msg->command; + if (!$msg->remark('do-not-broadcast-to-clients') && + $cmd eq 'PRIVMSG' || $cmd eq 'NOTICE') { + my $new_msg = undef; # 本当に必要になったら作る。 + foreach my $client (@{$this->{clients}}) { + if ($client != $socket) { + unless (defined $new_msg) { + # まだ作ってなかった + $new_msg = $msg->clone; + $new_msg->prefix($socket->fullname); + # シングルサーバーモードなら、ネットワーク名を取り外す。 + if (!$this->{multi_server_mode}) { + Multicast::detach_network_name($new_msg,$this->networks_list); + } + + } + $client->send_message($new_msg); + } + } + } + + if (!$msg->remark('do-not-send-to-server')) { + Multicast::from_client_to_server($msg,$socket); + } + } + } + } + } + }; if ($@) { + $this->notify_error($@); + } + } elsif (grep { $sock == $_ } @{$this->{socks_to_cleanup}}) { + # cleanup socket; ignore + } else { + $this->notify_error('unknown readable socket: '.$sock); + } + } + + foreach my $sock ($this->{send_selector}->can_write(0)) { + if (my $socket = $this->find_socket_with_sock($sock)) { + next unless $socket->want_to_write; + + eval { + $socket->write; + }; if ($@) { + $this->notify_error($@); + } + } elsif (grep { $sock == $_ } @{$this->{socks_to_cleanup}}) { + # cleanup socket; ignore + } else { + $this->notify_error('unknown writable socket: '.$sock); + } + } + + foreach my $sock ($this->{receive_selector}->has_exception(0)) { + if (my $socket = $this->find_socket_with_sock($sock)) { + eval { + $socket->exception; + }; if ($@) { + $this->notify_error($@); + } + } elsif (grep { $sock == $_ } @{$this->{socks_to_cleanup}}) { + # cleanup socket; ignore + } else { + $this->notify_error('unknown has-exception socket: '.$sock); + } + } + + # 切断されたソケットを探して、然るべき処理を行なう。 + $this->_cleanup_closed_link; + + # 発動すべき全てのタイマーを発動させる + $this->_execute_all_timers_to_fire; + + # Tiarra::Socket のクリーンアップ + $this->{socks_to_cleanup} = []; + + # 終了処理中でサーバもクライアントもいなくなればループ終了。 + if ($this->{terminating}) { + if ((scalar $this->networks_list('even-if-not-connected') <= 0) && + (scalar $this->clients_list <= 0) + ) { + last; + } else { + ++$this->{terminating}; + if ($this->{terminating} >= 400) { + # quit loop でそんなに回るとは思えない。 + $this->notify_error( + "very long terminating loop!". + "(".$this->{terminating}." count(s))\n". + "maybe something is wrong; exit force..."); + $this->notify_error( + join ("\n", + map {$_->network_name.": ".$_->state } + $this->networks_list('even-if-not-connected'))); + last; + } + } + } + } + + # 終了処理 + if (defined $this->{tiarra_server_socket}) { + $this->{tiarra_server_socket}->close; + $this->unregister_receive_socket($this->{tiarra_server_socket}); # 受信セレクタから登録解除 + } + undef $this->{control_port}; + $this->_mod_manager->terminate; +} + +sub terminate { + my ($class_or_this, $message) = @_; + my $this = $class_or_this->_this; + + $this->{terminating} = 1; + map { $_->finalize($message) } $this->networks_list('even-if-not-connected'); + map { $this->close_client($_, $message) } $this->clients_list; + if (defined $this->{tiarra_server_socket}) { + #buggy, close on final + #$this->{tiarra_server_socket}->shutdown(2); + } +} + +sub broadcast_to_clients { + # Tiarra::IRC::Messageをログイン中でない全てのクライアントに送信する。 + # fill-prefix-when-sending-to-clientという註釈が付いていたら、 + # Prefixをそのクライアントのfullnameに設定する。 + my ($class_or_this,@messages) = @_; + my $this = $class_or_this->_this; + foreach my $client (@{$this->{clients}}) { + next if $client->logging_in; + next unless $client->connected; + + foreach my $msg (@messages) { + if ($msg->remark('fill-prefix-when-sending-to-client')) { + $msg = $msg->clone; + $msg->prefix($client->fullname); + } + $client->send_message($msg); + } + } +} + +sub broadcast_to_servers { + # IRCメッセージを全てのサーバーに送信する。 + my ($class_or_this,@messages) = @_; + my $this = $class_or_this->_this; + foreach my $network ($this->networks_list) { + foreach my $msg (@messages) { + $network->send_message($msg); + } + } +} + +sub notify_modules { + my ($class_or_this,$method,@args) = @_; + my $this = $class_or_this->_this; + foreach my $mod (@{$this->_mod_manager->get_modules}) { + eval { + $mod->$method(@args); + }; if ($@) { + $this->notify_error("Exception in ".ref($mod).".\n". + "when calling $method.\n". + " $@"); + } + } +} + +sub apply_filters { + # @extra_args: モジュールに送られる第二引数以降。第一引数は常にTiarra::IRC::Message。 + my ($this, $src_messages, $method, @extra_args) = @_; + + my $source = $src_messages; + my $filtered = []; + foreach my $mod (@{$this->_mod_manager->get_modules}) { + # (普通ないはずだが) $mod が undef だったらこのモジュールをとばす。 + next unless defined $mod; + # sourceが空だったらここで終わり。 + if (scalar(@$source) == 0) { + return $source; + } + + foreach my $src (@$source) { + my @reply = (); + # 実行 + eval { + @reply = $mod->$method($src, @extra_args); + }; if ($@) { + my $modname = ref($mod); + my $error = $@; + # ブラックリストに入れておく + $this->_mod_manager->add_to_blacklist($modname); + $this->notify_error( + "Exception in ".$modname.".\n". + "This module added to blacklist!\n". + "The message was '".$src->serialize."'.\n". + " $error"); + $this->_mod_manager->remove_from_blacklist($modname); + @reply = ($src); + } + + if (defined $reply[0]) { + # 値が一つ以上返ってきた。 + # 全てTiarra::IRC::Messageのオブジェクトなら良いが、そうでなければエラー。 + foreach my $msg_reply (@reply) { + unless (UNIVERSAL::isa($msg_reply,$this->irc_message_class)) { + $this->notify_error( + "Reply of ".ref($mod)."::${method} contains illegal value.\n". + "It is ".ref($msg_reply)."."); + return $source; + } + } + + # これをfilteredに追加。 + push @$filtered,@reply; + } + } + + # 次のsourceはfilteredに。filteredは空の配列に。 + $source = $filtered; + $filtered = []; + } + return $source; +} + +sub _apply_filters { + # src_messagesは変更しない。 + my ($this, $src_messages, $sender) = @_; + $this->apply_filters( + $src_messages, 'message_arrived', $sender); +} + +sub notify_error { + my ($class_or_this,$str) = @_; + $class_or_this->notify_msg("===== ERROR =====\n$str"); +} +sub notify_warn { + my ($class_or_this,$str) = @_; + $class_or_this->notify_msg(":: WARNING :: $str"); +} +sub notify_msg { + # 渡された文字列をSTDOUTに出力すると同時に全クライアントにNOTICEする。 + # 改行コードLFで行を分割する。 + # 文字コードはUTF-8でなければならない。 + my ($class_or_this,$str) = @_; + my $this = $class_or_this->_this; + $str =~ s/\n+$//s; # 末尾のLFは消去 + + # STDOUTへ + ::printmsg($str); + + # クライアントへ + my $needed_sending = $this->_conf_general->notice_error_messages; + if ($needed_sending) { + my $client_charset = $this->_conf_general->client_out_encoding; + if (@{$this->clients} > 0) { + $this->broadcast_to_clients( + map { + $this->construct_irc_message( + Prefix => $this->sysmsg_prefix(qw(priv notify)), + Command => 'NOTICE', + Params => [$this->current_nick, + "*** $_"]); + } split /\n/,$str + ); + } + } +} + +# ----------------------------------------------------------------------------- +# RunLoopが一回実行される度に呼ばれるフック。 +# +# my $hook = RunLoop::Hook->new(sub { +# my $hook_itself = shift; +# # 何らかの処理を行なう。 +# })->install('after-select'); # select実行直後にこのフックを呼ぶ。 +# ----------------------------------------------------------------------------- +package RunLoop::Hook; +use FunctionalVariable; +use base 'Hook'; + +our $HOOK_TARGET_NAME = 'RunLoop'; +our @HOOK_NAME_CANDIDATES = qw(before-select after-select set-current-nick); +our $HOOK_NAME_DEFAULT = 'after-select'; +our $HOOK_TARGET_DEFAULT; +FunctionalVariable::tie( + \$HOOK_TARGET_DEFAULT, + FETCH => sub { + $HOOK_TARGET_NAME->shared_loop; + }, + ) unless defined $HOOK_TARGET_DEFAULT; + +1; diff -urN /non-existant-dir/main/Template.pm tiarra-20080510/main/Template.pm --- /non-existant-dir/main/Template.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/main/Template.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,184 @@ +# ----------------------------------------------------------------------------- +# $Id: Template.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +package Template; +use strict; +use warnings; +use Symbol; +use Carp; +use UNIVERSAL; +our $AUTOLOAD; + +sub new { + # $fpath: テンプレートとして使用するファイル + # $strip_empty_line (省略可能): やの直後の改行を削除するかどうか。 + my ($class,$fpath,$strip_empty_line) = @_; + my $this = { + original => undef, # リーフをに置換した中身。 + current => undef, # <&foo>を置換した後のもの。 + leaves => {}, # {名前 => Template} + parent => undef, # これがトップレベルでなければ、親(Template)。 + leafname => undef, # これがトップレベルでなければ、リーフ名。 + }; + bless $this,$class; + + local $/ = undef; + my $fh = gensym; + open($fh,'<',$fpath) or croak "couldn't open file $fpath"; + my $source = <$fh>; + close($fh); + ungensym($fh); + + # やの直後が改行コードなら、それを消す。 + # その改行コードから始まるスペースまたはタブも、インデントと見做して消す。 + if ($strip_empty_line) { + $source =~ s/(|)\x0d?\x0a[ \t]*/$1/g; + } + + $this->_load($source); + $this; +} + +sub reset { + my $this = shift; + $this->{current} = $this->{original}; + $this; +} + +sub expand { + # $t->expand({foo => '---' , bar => '+++'}); + # もしくは + # $t->expand(foo => '---' , bar => '+++'); + + # このメソッドは、キー内に現われたアンダースコアを + # ハイフンにフォールバックする事が出来ます。 + # つまり、<&foo-bar>というタグを、キー名"foo_bar"で指定する事が出来ます。 + my $this = shift; + my $hash = do { + if (@_ == 1 && UNIVERSAL::isa($_[0],'HASH')) { + $_[0]; + } + elsif (@_ % 2 == 0) { + my %h = @_; + \%h; + } + else { + croak "Illegal argument for Template->expand"; + } + }; + while (my ($key,$value) = each %$hash) { + # $key,$value共にスカラー値でなければならない。 + # リファならエラー。 + if (!defined $value) { + croak "Values must not be undef; key: $key"; + } + if (ref($key) ne '') { + croak "Keys and values must be scalar values: $key"; + } + if (ref($value) ne '') { + croak "Keys and values must be scalar values: $value"; + } + + if ($this->{current} !~ s/<\&\Q$key\E>/$value/g) { + # 無い。アンダースコアをハイフンに変えてみる。 + (my $tred_key = $key) =~ tr/_/-/; + if ($this->{current} !~ s/<\&\Q$tred_key\E>/$value/g) { + # そのようなキーは存在しなかった。警告。 + carp "No <\&$key> are in template, or you have replaced it already."; + } + } + } + $this; +} + +sub add { + my $this = shift; + + # 引数があればexpandする。 + if (@_ > 0) { + eval { + $this->expand(@_); + }; if ($@) { + croak $@; + } + } + + # 親が存在しなければcroak。 + if (!defined $this->{parent}) { + croak "This template doesn't have its parent."; + } + + # 親のの直前に、このリーフを挿入。 + my $str = $this->str; + $this->{parent}{current} =~ s/({leafname}\E>)/$str$1/g; + + # リセット + $this->reset; + + $this; +} + +sub str { + my $this = shift; + my $result = $this->{current}; + + # 未置換の<&foo>があればそれを消してcarp。 + while ($result =~ s/<\&(.+?)>//) { + carp "Unexpanded tag: <\&$1>"; + } + + # を消す。 + $result =~ s///g; + + $result; +} + +sub leaf { + my ($this,$leafname) = @_; + $this->{leaves}{$leafname}; +} + +sub AUTOLOAD { + my $this = shift; + (my $leafname = $AUTOLOAD) =~ s/.+?:://g; + + # アンダースコアはハイフンに置換。 + $leafname =~ tr/_/-/; + $this->{leaves}{$leafname}; +} + +sub _new_leaf { + my ($class,$parent,$leafname,$source) = @_; + my $this = { + original => undef, + current => undef, + leaves => {}, + parent => $parent, + leafname => $leafname, + }; + bless $this,$class; + + $this->_load($source); +} + +sub _load { + my ($this,$source) = @_; + + # ... をに置換しつつ、そのリーフを保存。 + while ($source =~ s/(.+?)//s) { + my ($leafname,$source) = ($1,$2); + + if (defined $this->{leaves}{$leafname}) { + # 既にこのリーフが定義されていたらcroak。 + croak "duplicated leaves in template: $leafname"; + } + else { + $this->{leaves}{$leafname} = Template->_new_leaf($this,$leafname,$source); + } + } + $this->{original} = $this->{current} = $source; + + $this; +} + +1; diff -urN /non-existant-dir/main/Tiarra/DefineEnumMixin.pm tiarra-20080510/main/Tiarra/DefineEnumMixin.pm --- /non-existant-dir/main/Tiarra/DefineEnumMixin.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/main/Tiarra/DefineEnumMixin.pm 2008-05-11 00:25:24.000000000 +0900 @@ -0,0 +1,36 @@ +# ----------------------------------------------------------------------------- +# $Id: DefineEnumMixin.pm 3004 2007-12-10 12:45:39Z topia $ +# ----------------------------------------------------------------------------- +# Definition Enum Mixin +# ----------------------------------------------------------------------------- +# copyright (C) 2004 Topia . all rights reserved. +package Tiarra::DefineEnumMixin; +use strict; +use warnings; +use Tiarra::Utils::DefineHelper; +use base qw(Tiarra::Utils::DefineHelper); + + +# usage: +# use Tiarra::DefineEnumMixin qw(enum1 enum2 enum3...); + +# this import is equivalent as: +# BEGIN { +# use Tiarra::Utils; +# Tiarra::Utils->define_enum(qw(enum1 enum2 enum3...); +# } + +# this module is deprecated. +# please use enum.pm instead. + +sub import { + my $pkg = shift; + my @args = @_; + $pkg->do_with_define_exportlevel( + 0, + sub { + $pkg->define_enum(@args); + }); +} + +1; diff -urN /non-existant-dir/main/Tiarra/Encoding/Encode/CP932JIS.pm tiarra-20080510/main/Tiarra/Encoding/Encode/CP932JIS.pm --- /non-existant-dir/main/Tiarra/Encoding/Encode/CP932JIS.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/main/Tiarra/Encoding/Encode/CP932JIS.pm 2008-05-11 00:25:24.000000000 +0900 @@ -0,0 +1,122 @@ +package Tiarra::Encoding::Encode::CP932JIS; +use strict; +use warnings; +sub DEBUG () { 0 } + +our $VERSION = '1.0'; + +use Encode qw(:fallbacks); + +__PACKAGE__->Define(qw(cp932-jis)); + +use base qw(Encode::Encoding); + +# perlio not supported yet +sub perlio_ok { 0 } + +use Encode::CJKConstants qw(:all); + +# +# decode is identical for all 2022 variants +# +our $re_scan_jis = qr{ + (?:($RE{JIS_0212})|($RE{JIS_0208})|($RE{ISO_ASC})|($RE{JIS_KANA})) + ([^\e]*) +}x; + +sub decode($$;$) +{ + my ($obj, $str, $chk) = @_; + my $ret = ''; + Encode::_utf8_on($ret); + my $chr; + while (length($str)) { + if ($str =~ s/\A$re_scan_jis//s) { + my ($esc_0212, $esc_0208, $esc_asc, $esc_kana, $chunk) = + ($1, $2, $3, $4, $5); + # parse si/so + $chunk =~ s/\x0e(.+)\x0f/pack('C*', map $_ | 0x80, unpack('C*', $1))/eg; + + if ($esc_asc) { + $ret .= Encode::decode('cp932', $chunk, FB_PERLQQ); + } elsif ($esc_0212) { + # JIS X 0212-1990 + # FIXME + #$ret .= join '', '[JISX0212:', unpack('H*', $chunk), ']'; + $ret .= Encode::decode('jis0212-raw', $chunk, FB_PERLQQ); + } elsif ($esc_kana) { + # 0201 kana on G0 + $chunk =~ s/(.)/pack('C', unpack('C', $1) | 0x80)/eog; + $ret .= Encode::decode('cp932', $chunk, FB_PERLQQ); + } elsif ($esc_0208) { + # s1 = ((j1 - 1) >> 1) + ((j1 <= 0x5e) ? 0x71 : 0xb1); + # s2 = j2 + ((j1 & 1) ? ((j2 < 0x60) ? 0x1f : 0x20) : 0x7e); + my ($j1, $j2); + $chunk =~ s{(.{2})}{ + ($j1, $j2) = unpack('C*', $1); + pack('C*', + (($j1 - 1) >> 1) + (($j1 <= 0x5e) ? 0x71 : 0xb1), + $j2 + (($j1 & 1) ? (($j2 < 0x60) ? 0x1f : 0x20) : 0x7e)); + }exog; + $ret .= Encode::decode('cp932', $chunk, FB_PERLQQ); + } + } elsif ($str =~ s/\A\e[\$\(]?$//s) { + # skip unfinished escape seq. + } elsif ($str =~ s/\A(\e?[^\e]*)//s) { + my $str = $1; + $ret .= Encode::decode('cp932', $str, FB_PERLQQ); + } + } + return $ret; +} + +# +# encode is different +# + +sub encode($$;$) +{ + my ($obj, $utf8, $chk) = @_; + $utf8 =~ s/\x{301c}/\x{ff5e}/g; # reverse soldius + $utf8 =~ s/\x{2212}/\x{ff0d}/g; # + my $str = Encode::encode('cp932', $utf8, FB_PERLQQ) ; + my $ret = ''; + Encode::_utf8_off($ret); + my ($s1, $s2); + my $lastmode = 'ascii'; + my $startmode = sub { + my ($mode, $escape) = @_; + if ($lastmode ne $mode) { + $lastmode = $mode; + $ret .= $escape; + } + }; + while (length($str)) { + if ($str =~ s/\A((?:[\x81-\x9f\xe0-\xef].)+)//s) { + $startmode->('0208', $ESC{JIS_0208}); + # sjis 2byte + #j1 = (s1 << 1) - (s1 <= 0x9f ? 0xe0 : 0x160) - (s2 < 0x9f ? 1 : 0); + #j2 = s2 - 0x1f - (s2 >= 0x7f ? 1 : 0) - (s2 >= 0x9f ? 0x5e : 0); + foreach ($1 =~ /(..)/g) { + ($s1, $s2) = unpack('C*', $_); + $ret .= pack('C*', + ($s1 << 1) - ($s1 <= 0x9f ? 0xe0 : 0x160) - ($s2 < 0x9f ? 1 : 0), + $s2 - 0x1f - ($s2 >= 0x7f ? 1 : 0) - ($s2 >= 0x9f ? 0x5e : 0)); + } + } elsif ($str =~ s/\A([\xa1-\xdf]+)//s) { + $startmode->('0201-8bit', "\e\(J"); + foreach (split //, $1) { + #$ret .= unpack('H*', $_); + $ret .= $_; + } + } elsif ($str =~ s/\A(.)//s) { + $startmode->('ascii', $ESC{ASC}); + $ret .= $1; + } + } + $startmode->('ascii', $ESC{ASC}); + return $ret; +} + +1; +__END__ diff -urN /non-existant-dir/main/Tiarra/Encoding/Encode.pm tiarra-20080510/main/Tiarra/Encoding/Encode.pm --- /non-existant-dir/main/Tiarra/Encoding/Encode.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/main/Tiarra/Encoding/Encode.pm 2008-05-11 00:25:24.000000000 +0900 @@ -0,0 +1,245 @@ +# ----------------------------------------------------------------------------- +# $Id: Encode.pm 3004 2007-12-10 12:45:39Z topia $ +# ----------------------------------------------------------------------------- +# Encoding with Encode +# ----------------------------------------------------------------------------- +# copyright (C) 2005 Topia . all rights reserved. +package Tiarra::Encoding::Encode; +use strict; +use warnings; +use Carp; +use Encode qw/find_encoding/; +use Encode::Guess; # for getcode +use Encode::JP::H2Z; # for h2zKana, z2hKana +BEGIN { eval { require Tiarra::Encoding::Encode::CP932JIS } } +use Tiarra::OptionalModules; +use base qw(Tiarra::Encoding); + +# we can't support if Encode::Guess->renew is not defined. +die 'Please use latest Encode to use.' unless Encode::Guess->can('renew'); + +our %encoding_names = ( # please specify _Encode.pm's canonical_ name. + sjis => 'cp932', # compatible with unijp + ucs2 => 'UCS-2BE', + ucs4 => 'UTF-32BE', + utf8 => 'utf8', + utf16 => 'UTF-16', + jis => (find_encoding('cp932-jis') ? 'cp932-jis' : '7bit-jis'), + euc => 'euc-jp', +); + +our @default_probe_encodings = + __PACKAGE__->_find_canon_encs(qw(sjis euc utf8 jis)); + + +sub getu { + my $this = shift; + $this->{str}; +} + +sub _find_canon_encs { + my $this = shift; + my $temp; + grep { + return $_ unless wantarray; + 1; + } map { + if (exists $encoding_names{$_}) { + $encoding_names{$_}; + } else { + $temp = find_encoding($_); + if (defined $temp) { + $temp->name + } elsif ($_ ne 'auto') { + warn "Unknown encoding: $_"; + (); + } + } + } @_; +} + +sub decode { + my ($this, $str, $encoding) = @_; + + if (defined $str) { + if (ref($str) && !overload::Method($str,'""')) { + croak "string neither scalar nor stringifiable"; + } + # do stringify force to avoid bug on old Encode + $this->{str} = Encode::decode($this->_find_canon_encs($encoding), "$str"); + } + $this; +} + +sub encode { + my ($this, $encoding) = @_; + + if (defined $this->{str}) { + Encode::encode($this->_find_canon_encs($encoding), $this->{str}); + } else { + undef; + } +} + +sub getcode { + my $this = shift; + my $str = shift; + my @encodings = (@_ ? ($this->_find_canon_encs(@_)) : + @default_probe_encodings); + my $guess = find_encoding('Guess')->renew; + $guess->set_suspects(@encodings); + my ($enc, @other) = $guess->guess($str); + if (ref($enc)) { + return wantarray ? ($enc->name, $enc) : $enc->name; + } else { + if (defined $enc && $enc =~ /Encodings too ambiguous/i) { + my @probed = split / or /, shift(@other); + $enc = []; + foreach my $try_enc (@encodings) { + for (my $i = 0; $i < @probed; ++$i) { + if ($probed[$i] eq $try_enc) { + push @$enc, splice @probed, $i, 1; + last; + } + } + } + if (@$enc == 1) { + $enc = find_encoding(shift(@$enc)); + return wantarray ? ($enc->name, $enc) : $enc->name; + } + } + return wantarray ? ('unknown', $enc, @other) : 'unknown'; + } +} +sub h2z { + # only kana supported + my $this = shift; + $this->h2zKana; + $this; +} + +sub h2zKana { + my $this = shift; + my $eucjp = $this->encode($this->_find_canon_encs(qw(euc))); + Encode::JP::H2Z::h2z(\$eucjp); + $this->decode($eucjp, $this->_find_canon_encs(qw(euc))); + $this; +} + +sub z2h { + # only kana supported + my $this = shift; + $this->z2hKana; + $this; +} + +sub z2hKana { + my $this = shift; + my $eucjp = $this->encode($this->_find_canon_encs(qw(euc))); + Encode::JP::H2Z::z2h(\$eucjp); + $this->decode($eucjp, $this->_find_canon_encs(qw(euc))); + $this; +} + +foreach (qw(h2zNum h2zAlpha h2zSym z2hNum z2hAlpha z2hSym), + qw(kata2hira hira2kata), + (map { "sjis_$_" } qw(imode imode1 imode2 doti jsky jsky1 jsky2))) { + eval "sub $_ \{ shift->_not_supported_feature \}"; +} + +# common for non-unijp's + +do { + my %methods = ( + qw(get utf8), + ); + while (my ($key, $value) = each %methods) { + eval " + sub $key \{ + shift-\>conv('$value', \@_); + }"; + } + + my @methods = qw(jis euc sjis utf8 ucs2 ucs4 utf16); + foreach (@methods) { + eval " + sub $_ \{ + shift-\>conv('$_', \@_); + }"; + } +}; + +sub set { + my $this = shift; + my $str = shift; + my $code = shift; + my $encode = shift; + + if (defined $encode && defined $str) { + if ($encode eq 'base64') { + # if you have perl-bundled encode, also have mime-base64. + # (see Module::CoreList) + Tiarra::OptionalModules->check('base64') or + croak 'Couldn\'t load MIME::Base64.'; + $str = MIME::Base64::decode($str); + } + } + + if (!defined $code) { + $code = 'utf8'; + } elsif ($code eq 'auto' || $code =~ /,/) { + my @codes = (); + if ($code =~ /,/) { + # comma seperated guess-list + @codes = split(/\s*,\s*/, $code); + } + my ($enc, @enc_others) = $this->getcode($str, @codes); + if (defined $enc && $enc ne 'unknown') { + $code = $enc; + } else { + $enc = shift @enc_others; + if (ref($enc) eq 'ARRAY') { + # use first + $code = shift @$enc; + } else { + # so we can't probe encoding. + # use first of probe list. + $enc = $default_probe_encodings[0]; + } + } + } + + $this->decode($str, $code); +} + +sub conv { + my $this = shift; + my $code = shift; + my $encode = shift; + + my $str = $this->encode($code); + + if (defined $encode && defined $str) { + if ($encode eq 'base64') { + # if you have perl-bundled encode, also have mime-base64. + # (see Module::CoreList) + Tiarra::OptionalModules->check('base64') or + croak 'Couldn\'t load MIME::Base64.'; + $str = MIME::Base64::encode($str, ''); + } + } + return $str; +} + +sub _not_supported_feature { + my $this = shift; + (my $funcname = (caller(1))[3]) =~ s/^.*::(.+?)$/$1/; + die sprintf '%s is really not supported by %s', $funcname, (ref($this) || $this); +} + +sub join_csv { shift->_not_supported_feature } +sub split_csv { shift->_not_supported_feature } +sub strcut { shift->_not_supported_feature } +sub strlen { shift->_not_supported_feature } + +1; diff -urN /non-existant-dir/main/Tiarra/Encoding/UniJP.pm tiarra-20080510/main/Tiarra/Encoding/UniJP.pm --- /non-existant-dir/main/Tiarra/Encoding/UniJP.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/main/Tiarra/Encoding/UniJP.pm 2008-05-11 00:25:24.000000000 +0900 @@ -0,0 +1,75 @@ +# ----------------------------------------------------------------------------- +# $Id: UniJP.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +# Encoding with Unicode::Japanese +# ----------------------------------------------------------------------------- +# copyright (C) 2005 Topia . all rights reserved. +package Tiarra::Encoding::UniJP; +use strict; +use warnings; +use Carp; +use base qw(Tiarra::Encoding); +use Unicode::Japanese; + +our @default_probe_encodings = qw(sjis euc utf8 jis); + +sub getcode { + my $this = shift; + my $str = shift; + my @encodings = (@_ ? @_ : @default_probe_encodings); + my $guess = $this->{unijp}->getcode($str); + + # really unknown encoding. + return $guess if $guess eq 'unknown'; + + # getcodeで検出された文字コードでencodingsに指定されているものがあれば採用。 + # 無ければencodingsの一番最初を採用する。 (UTF-8をSJISと認識したりするため。) + $guess = ((grep {$guess eq $_} @encodings), @encodings)[0]; + $guess; +} + +sub set { + my $this = shift; + my $str = shift; + my $code = shift; + + if (defined $str) { + if ($code =~ /,/) { + # comma seperated guess-list + $code = $this->getcode($str, split(/\s*,\s*/, $code)); + $code = 'binary' if $code eq 'unknown'; + } + + if (ref($str) && !overload::Method($str,'""')) { + croak "string neither scalar nor stringifiable"; + } + # do stringify force to avoid bug on unijp <= 0.26 + $this->{unijp}->set("$str", $code, @_); + } + $this; +} + +sub _init { + my $this = shift; + $this->{unijp} = Unicode::Japanese->new; +} + +sub AUTOLOAD { + our $AUTOLOAD; + my $this = shift; + + if ($AUTOLOAD =~ /::DESTROY$/) { + # DESTROYは伝達させない。 + return; + } + + (my $method = $AUTOLOAD) =~ s/.+?:://g; + if ($method =~ /^(?:h2z|z2h).*$/) { + $this->{unijp}->$method(@_); + $this; + } else { + $this->{unijp}->$method(@_); + } +} + +1; diff -urN /non-existant-dir/main/Tiarra/Encoding.pm tiarra-20080510/main/Tiarra/Encoding.pm --- /non-existant-dir/main/Tiarra/Encoding.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/main/Tiarra/Encoding.pm 2008-05-11 00:25:24.000000000 +0900 @@ -0,0 +1,77 @@ +# ----------------------------------------------------------------------------- +# $Id: Encoding.pm 3004 2007-12-10 12:45:39Z topia $ +# ----------------------------------------------------------------------------- +# Tiarra Encoding Manager +# ----------------------------------------------------------------------------- +# copyright (C) 2005 Topia . all rights reserved. +package Tiarra::Encoding; +use strict; +use warnings; +use Carp; +our %modules = ( + qr/(uni-?jp|unicode(::|-)japanese)/i => 'UniJP', + qr/encode/i => 'Encode', + ); +our %tried_providers; + +sub new { + my ($class, $str, $icode, $encode, %options) = @_; + + if ($class eq __PACKAGE__) { + if (!defined $options{provider}) { + if ($class->_is_supported('encode')) { + $options{provider} = 'encode'; + } elsif ($class->_is_supported('unijp')) { + $options{provider} = 'unijp'; + } else { + die 'supported provider not found!'; + } + } + croak "encoding provider($options{provider}) isn't supported" + unless $class->_is_supported($options{provider}); + $class->_get_module_name($options{provider})->new( + $str, $icode, $encode, %options); + } else { + my $this = {}; + bless $this, $class; + $this->_init(%options) if $this->can('_init'); + $this->set($str, $icode, $encode, %options); + } +} + +sub from_to { + my $this = shift; + my $str = shift; + my $from_code = shift; + my $to_code = shift; + + if ((defined $from_code && $from_code eq 'binary') || + (defined $to_code && $to_code eq 'binary')) { + $str; + } else { + $this->set($str, $from_code); + $this->conv($to_code); + } +} + +sub _is_supported { + my $modname = shift->_get_module_name(@_); + return $tried_providers{$modname} if defined $tried_providers{$modname}; + my $retval = eval 'require ' . $modname; + warn $@ if $@; + $tried_providers{$modname} = $retval; + return $retval; +} + +sub _get_module_name { + my ($this, $charset) = @_; + foreach (keys %modules) { + if ($charset =~ /$_/) { + $charset = $modules{$_}; + last; + } + } + return __PACKAGE__ . '::' . $charset; +} + +1; diff -urN /non-existant-dir/main/Tiarra/IRC/Message.pm tiarra-20080510/main/Tiarra/IRC/Message.pm --- /non-existant-dir/main/Tiarra/IRC/Message.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/main/Tiarra/IRC/Message.pm 2008-05-11 00:25:24.000000000 +0900 @@ -0,0 +1,739 @@ +# ----------------------------------------------------------------------------- +# $Id: Message.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +# Tiarra::IRC::MessageはIRCのメッセージを表わすクラスです。実際のメッセージはUTF-8で保持します。 +# 生のメッセージのパース、シリアライズ、そしてメッセージの生成をサポートします。 +# パースとシリアライズには文字コードを指定して下さい。コードを変換します。 +# LineとEncoding以外の手段でインスタンスを生成する際は、 +# パラメータとしてUTF-8の値を渡して下さい。 +# ----------------------------------------------------------------------------- +# 生成方法一覧 +# +# $msg = new Tiarra::IRC::Message(Line => ':foo!~foo@hogehoge.net PRIVMSG #hoge :hoge', +# Encoding => 'jis'); +# print $msg->command; # 'PRIVMSG'を表示 +# +# $msg = new Tiarra::IRC::Message(Server => 'irc.hogehoge.net', # ServerはPrefixでも良い。 +# Command => '366', +# Params => ['hoge','#hoge','End of /NAMES list.']); +# print $msg->serialize('jis'); # ":irc.hogehoge.net 366 hoge #hoge :End of /NAMES list."を表示 +# +# $msg = new Tiarra::IRC::Message(Nick => 'foo', +# User => '~bar', +# Host => 'hogehoge.net', # 以上３つのパラメータの代わりにPrefix => 'foo!~bar@hogehoge.net'でも良い。 +# Command => 'NICK', +# Params => 'huga', # Paramsは要素が一つだけならスカラー値でも良い。(この時、ParamsでなくParamでも良い。) +# Remarks => {'saitama' => 'SAITAMA'}, # 備考欄。 +# print $msg->serialize('jis'); # ":foo!~bar@hogehoge.net NICK :huga"を表示 +# +# $msg = new Tiarra::IRC::Message(Command => 'NOTICE', +# Params => ['foo','hugahuga']); +# print $msg->serialize('jis'); # "NOTICE foo :hugahuga"を表示 +# +package Tiarra::IRC::Message; +use strict; +use warnings; +use Carp; +use Tiarra::OptionalModules; +use Tiarra::Utils; +use Tiarra::IRC::Prefix; +use Tiarra::Encoding; +use enum qw(PREFIX COMMAND PARAMS REMARKS TIME RAW_PARAMS GENERATOR); + +=head1 NAME + +Tiarra::IRC::Message - Tiarra IRC Message class + +=head1 SYNOPSIS + + use Tiarra::IRC::Message; + my $msg = Tiarra::IRC::Message->new( + Line => ':foo!bar@baz PRIVMSG qux :some text', + Encoding => 'UTF-8'); + $msg = Tiarra::IRC::Message->new( + Prefix => 'foo!bar@baz', + Command => 'PRIVMSG', + Params => ['qux', 'some text']); + $msg->serialize('jis'); + + package SomePackage; + use base qw(Tiarra::Mixin::NewIRCMessage); + my $msg = __PACKAGE__->construct_irc_message( + Server => 'irc.foo.example.com', + Command => 'ERROR', + Params => ['bar', 'Closing Link: [foo_user!foo@baz.example.org] (Bad Password)'], + Remarks => { + 'foo-remark' => 'bar', + }); + $msg->serialize('remark', 'jis'); + +=head1 DESCRIPTION + +Tiarra IRC Message class. + +=head1 CONSTANT METHODS + +=over 4 + +=cut + +=item MAX_MIDDLES + +max middles count. + +=item MAX_PARAMS + +max params count. + +=back + +=cut + +# constants +use constant MAX_MIDDLES => 14; +use constant MAX_PARAMS => MAX_MIDDLES + 1; +# max params = (middles[14] + trailing[1]) = 15 + +=head1 CONSTRUCTOR + +=over 4 + +=cut + +=item new + + # parse + my $msg = Tiarra::IRC::Message->new( + Line => ':foo BAR baz :qux quux', # required + Encoding => 'jis'); + # construct + $msg = Tiarra::IRC::Message->new( + Server => 'foo', + Command => 'BAR', + Params => ['baz', 'qux quux']); + +Construct IRC Message from line or parts. + +=over 4 + +=item * parse mode + +=over 4 + +=item * Line + +line to parse. + +=item * Encoding + +encoding of line. if omitted, use 'auto' (autodetect). + +=back + +=item * parts mode + +=over 4 + +=item * Prefix or Server + +prefix (on IRC), parsed by Tiarra::IRC::Prefix. optional. + +=item * Nick, User, Host + +nick, user, host. passed to Tiarra::IRC::Prefix. optional. + +=item * Command + +command. required. + +=item * Params + +if arrayref, copy and store as params. otherwise, store as single param. optional. + +=item * Param + +store as single param. optional. + +=back + +=item * common + +=over 4 + +=item * Remarks + +remarks. only permit hashref, copy and store. + +=item * Generator + +Some package name or instance. please be able to call UNIVERSAL method, +such as ->isa, ->can. + +=back + +=back + +=cut + +sub new { + my ($class,%args) = @_; + my $obj = bless [] => $class; + $obj->[PREFIX] = undef; + $obj->[COMMAND] = undef; + $obj->[PARAMS] = undef; + + $obj->[REMARKS] = undef; + + $obj->[TIME] = Tiarra::OptionalModules->time_hires ? + Time::HiRes::time() : CORE::time(); + + $obj->[RAW_PARAMS] = undef; + + $obj->[GENERATOR] = undef; + + if (exists $args{'Line'}) { + $args{'Line'} =~ s/\x0d\x0a$//s; # 行末のcrlfは消去。 + $obj->_parse($args{'Line'},$args{'Encoding'} || 'auto'); # Encodingが省略されたら自動判別 + } + else { + if (exists $args{'Prefix'}) { + $obj->prefix($args{'Prefix'}); # prefixが指定された + } + elsif (exists $args{'Server'}) { + $obj->prefix($args{'Server'}); # prefix決定 + } + else { + foreach (qw(Nick User Host)) { + if (exists $args{$_}) { + my $method = lc($_); + $obj->$method($args{$_}); + } + } + } + + # Commandは絶対に無ければならない。 + if (exists $args{'Command'}) { + $obj->command($args{'Command'}); + } + else { + die "You can't make ".__PACKAGE__." without a COMMAND."; + } + + if (exists $args{'Params'}) { + # Paramsがあった。型はスカラーもしくは配列リファ + my $params = $args{'Params'}; + my $type = ref($params); + if (defined $type && $type eq 'ARRAY') { + $obj->[PARAMS] = [@$params]; # コピーを格納 + } else { + $obj->[PARAMS] = [$params]; + } + } + elsif (exists $args{'Param'}) { + # Paramがあった。型はスカラーのみ + $obj->[PARAMS] = [$args{'Param'}]; + } + } + if (exists $args{'Remarks'}) { + $obj->[REMARKS] = {%{$args{'Remarks'}}}; + } + if (exists $args{'Generator'}) { + $obj->generator($args{'Generator'}); + } + $obj; +} + +=back + +=head1 METHODS + +=over 4 + +=item time + +accessor for message generate time. + +=item generate + +accessor for message generator. + +=item command + +accessor for message command. + +=item nick + +=item name + +=item host + +accessor for nick, name, host. passed to Tiarra::IRC::Prefix + +=cut + +utils->define_array_attr_accessor(0, qw(time generator)); +utils->define_array_attr_translate_accessor( + 0, sub { + my ($from, $to) = @_; + "($to = $from) =~ tr/a-z/A-Z/"; + }, qw(command)); +utils->define_proxy('prefix', 0, qw(nick name host)); + +=item clone + + $msg->remark('a', 'foo'); + $msg->remark('b', { + bar => 'baz', + }); + + # deep clone + $deep_clone = $msg->clone(deep => 1); + $deep_clone->remark('a', 'qux'); # still $msg->remark('a') is 'foo' + $deep_clone->remark('b')->{bar} = 'qux'; # still $msg->remark('b')->{bar} is 'baz' + # shallow clone + $shallow_clone = $msg->clone; + $shallow_clone->remark('a', 'qux'); # still $msg->remark('a') is 'foo' + $shallow_clone->remark('b')->{bar} = 'quux'; # now $msg->remark('b')->{bar} is 'quux' + +clone message. + +generator will NOT copy. + +even if shallow copy mode, prefix, params, remarks will clone themeselves. + +=cut + +sub clone { + my ($this, %args) = @_; + if ($args{deep}) { + # inhibits generator deep clone. + reuire Data::Dumper; + my $obj = $this->clone; + $obj->generator(undef); + $obj = eval(Data::Dumper->new([$obj])->Terse(1) + ->Deepcopy(1)->Purity(1)->Dump); + $obj->generator($this->generator); + $obj; + } else { + my @new = @$this; + # do not clone raw_params. this behavior is by design. + # (we want to handle _raw_params by outside. + # if you want, please re-constract or use deep => 1.) + $new[PREFIX] = $this->[PREFIX]->clone if defined $this->[PREFIX]; + $new[PARAMS] = [@{$this->[PARAMS]}] if defined $this->[PARAMS]; + $new[REMARKS] = {%{$this->[REMARKS]}} if defined $this->[REMARKS]; + bless \@new => ref($this); + } +} + +sub _parse { + my ($this,$line,$encoding) = @_; + delete $this->[PREFIX]; + delete $this->[COMMAND]; + delete $this->[PARAMS]; + delete $this->[RAW_PARAMS]; + my $param_count_warned = 0; + + my $pos = 0; + # prefix + if (substr($line,0,1) eq ':') { + # :で始まっていたら + my $pos_space = index($line,' '); + $this->prefix(substr($line,1,$pos_space - 1)); + $pos = $pos_space + 1; # スペースの次から解釈再開 + } + # command & params + my $add_command_or_param = sub { + my $value_raw = shift; + if ($this->command) { + # commandはもう設定済み。次はパラメータだ。 + $this->_raw_push($value_raw); + } + else { + # まだコマンドが設定されていない。 + $this->command($value_raw); + } + }; + while (1) { + my $param = ''; + + my $pos_space = index($line,' ',$pos); + if ($pos_space == -1) { + # 終了 + $param = substr($line,$pos); + } + else { + $param = substr($line,$pos,$pos_space - $pos); + } + + if ($param ne '') { + if ($this->n_params > MAX_PARAMS && !$param_count_warned) { + $param_count_warned = 1; + carp 'max param exceeded; please fix upstream server!'; + } + if (substr($param,0,1) eq ':') { + $param = substr($line, $pos); # これ以降は全て一つの引数。 + $param =~ s/^://; # :があった場合は外す。 + $add_command_or_param->($param); + last; # ここで終わり。 + } + else { + $add_command_or_param->($param); + } + } + + if ($pos_space == -1) { + last; + } + else { + $pos = $pos_space + 1; # スペースの次から解釈再開 + } + } + + $this->encoding_params($encoding); + + # 解釈結果の正当性をチェック。 + # commandが無かったらdie。 + unless ($this->COMMAND) { + croak __PACKAGE__." parsed invalid one, which doesn't have command.\n $line"; + } +} + +=item serialize + + $msg->serialize('jis'); + # remark + $msg->remark('encoding', 'utf8'); + $msg->serialize('remark,jis'); # serialize and encode to utf8 + +serialize with specified encoding. +probe encoding flow: + + specified 'remark' or 'remark,[some-fallback]' + - use remark/encoding. + - use [some-fallback] if specified. + - utf8 + + specified some encoding + - use this + + otherwise(not specified) + - use utf8 + +=cut + +sub serialize { + # encodingを省略するとutf8になる。 + # encodingをremarkで始めた場合は remark による設定を優先 + my ($this,$encoding) = @_; + + if (defined $encoding && $encoding =~ /^remark(?:,(.*))$/) { + local $_ = $this->remark('encoding'); + $encoding = (defined && length) ? $_ : $1; + } + $encoding = 'utf8' unless defined $encoding && length $encoding; + + my $result = ''; + + if ($this->prefix) { + $result .= ':'.$this->prefix.' '; + } + + $result .= $this->command.' '; + + if ($this->[PARAMS]) { + my $unicode = Tiarra::Encoding->new; + my $n_params = $this->n_params; + if ($n_params > MAX_PARAMS) { + # 表現不能なのだ + warn "this message exceeded maximum param numbers! params: @{$this->[PARAMS]}"; + } + for (my $i = 0;$i < $n_params;$i++) { + my $arg = $this->[PARAMS]->[$i]; + if ($i == $n_params - 1) { + # 最後のパラメタなら頭にコロンを付けて後にはスペースを置かない。 + # 但し半角スペースが一つも無く、且つコロンで始まっていなければコロンを付けない。 + # パラメタが空文字列であった場合は例外としてコロンを付ける。 + # また、 remark/always-use-colon-on-last-param が付いていた場合も + # コロンを付ける。 + $arg = $unicode->from_to($arg, 'utf8', $encoding); + if (CORE::length($arg) > 0 and + index($arg, ' ') == -1 and + index($arg, ':') != 0 and + !$this->remark('always-use-colon-on-last-param')) { + $result .= $arg; + } + else { + $result .= ":$arg"; + } + # 本当はCTCPメッセージを外してエンコードすべきかも知れない。 + } + else { + # 最後のパラメタでなければ後にスペースを置く。 + # do stringify force to avoid bug on unijp + $result .= $unicode->from_to($arg, 'utf8', $encoding).' '; + } + } + } + + return $result; +} + +=item length + + $msg->length('jis'); + +return serialized message length. + +=cut + +sub length { + my ($this) = shift; + CORE::length($this->serialize(@_)); +} + +=item params + + $msg->params->[0] = ...; + +access to params with hashref form. not recommended. + +=cut + +sub params { + croak "Parameter specified to params(). You must mistaked with param().\n" if (@_ > 1); + my $this = shift; + $this->[PARAMS] = [] unless defined $this->[PARAMS]; + $this->[PARAMS]; +} + +=item n_params + + my $param_count = $msg->n_params; + +return message counts (1 origin). + +=cut + +sub n_params { + scalar @{shift->params}; +} + +=item param + + # get + my $param = $msg->param($idx); + # set + $msg->param($idx, $param); + +access to param item (index is 0 origin). + +=cut + +sub param { + my ($this,$index,$new_value) = @_; + croak "Parameter index wasn't specified to param(). You must be mistaken with params().\n" if (@_ <= 1); + if (defined $new_value) { + $this->[PARAMS]->[$index] = $new_value; + } + $this->[PARAMS]->[$index]; +} + +=item push + + $msg->push($fooval); + +append value to tail of params. + +=cut + +sub push { + my $this = shift; + CORE::push(@{$this->params}, @_); +} + +=item pop + + $msg->pop; + +fetch and delete last params. + +=cut + +sub pop { + CORE::pop(@{shift->params}); +} + +sub _raw_params { + my $this = shift; + $this->[RAW_PARAMS] = [] unless defined $this->[RAW_PARAMS]; + $this->[RAW_PARAMS]; +} + +=item purge_raw_params + + $this->purge_raw_params; + +drop raw params from parsed line. + +=cut + +sub purge_raw_params { + shift->[RAW_PARAMS] = []; +} + +sub _raw_push { + my $this = shift; + CORE::push(@{$this->_raw_params}, @_); +} + +sub _raw_pop { + CORE::pop(@{shift->_raw_params}); +} + +sub _n_raw_params { + scalar @{shift->_raw_params}; +} + +=item have_raw_params + + if ($msg->have_raw_params) { + # maybe we can call ->encoding_params. + } + +we have raw params, return true. otherwise false. + +=cut + +sub have_raw_params { + shift->_n_raw_params > 0; +} + +=item remark + + # return remarks hash + my $remarks = $msg->remark; + # return remark item + my $foo_remark = $msg->remark('foo'); + # set remark item + $msg->remark('foo', $foo_remark); + +handle remark. + +=over 4 + +=item * no argument + +return remarks hashref. + +=item * one argument ($key) + +return hash item of $key. + +=item * two argument ($key, $value) + +set hash item of $key to $value. + +=item * three argument ($key, undef, 'delete') + +delete hash item. + +=back + +=cut + +sub remark { + my $this = shift; + # remark() -> HASH* + # remark('key') -> SCALAR + # remark('key','value') -> 'value' + $this->[REMARKS] = {} unless defined $this->[REMARKS]; + if (@_ <= 0) { + $this->[REMARKS]; + } else { + my $key = shift; + if (@_ > 1) { + # have 3rd argument 'delete' + delete $this->[REMARKS]->{$key}; + } elsif (@_ > 0) { + # have value + $this->[REMARKS]->{$key} = shift; + } else { + $this->[REMARKS]->{$key}; + } + } +} + +=item encoding_params + + $msg->encoding_params('utf8'); + +re-interpret encoding of params. + +=cut + +sub encoding_params { + my ($this, $encoding) = @_; + + if (!$this->have_raw_params) { + if ($this->n_params) { + croak "raw_params already purged; cannot re-encoding"; + } else { + # we don't have any params + return undef; + } + } + + my $unicode = Tiarra::Encoding->new; + + # clear + @{$this->params} = (); + + foreach my $value_raw (@{$this->_raw_params}) { + my $value = do { + if (CORE::length ($value_raw) == 0) { + ''; + } else { + $unicode->from_to($value_raw,$encoding,'utf8'); + } + }; + $this->push($value); + } +} + +=item prefix + +accessor of prefix. + +=cut + +sub prefix { + my $this = shift; + $this->[PREFIX] ||= Tiarra::IRC::Prefix->new; + $this->[PREFIX]->prefix(shift) if $#_ >= 0; + $this->[PREFIX]; +} + +1; + +__END__ +=back + +=head1 SEE ALSO + +L, +L + +=head1 AUTHOR + +originally developed by phonohawk Ephonohawk@ps.sakura.ne.jpE. + +now maintained by Topia Etopia@clovery.jpE. + +=head1 LICENSE + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself, either Perl version 5.8.6 or, +at your option, any later version of Perl 5 you may have available. + +=cut diff -urN /non-existant-dir/main/Tiarra/IRC/NewMessageMixin.pm tiarra-20080510/main/Tiarra/IRC/NewMessageMixin.pm --- /non-existant-dir/main/Tiarra/IRC/NewMessageMixin.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/main/Tiarra/IRC/NewMessageMixin.pm 2008-05-11 00:25:24.000000000 +0900 @@ -0,0 +1,40 @@ +# ----------------------------------------------------------------------------- +# $Id: NewMessageMixin.pm 3004 2007-12-10 12:45:39Z topia $ +# ----------------------------------------------------------------------------- +# copyright (C) 2005 Topia . all rights reserved. +package Tiarra::IRC::NewMessageMixin; +use base qw(Tiarra::Mixin::NewIRCMessage); + +=head1 NAME + +Tiarra::IRC::NewMessageMixin - deprecated by Tiarra::Mixin::NewIRCMessage + +=head1 DESCRIPTION + +Tiarra::IRC::NewMessageMixin is deprecated by L (renamed). +please see L. + +=cut + +1; + +__END__ +=back + +=head1 SEE ALSO + +L + +=head1 AUTHOR + +Topia Etopia@clovery.jpE + +=head1 COPYRIGHT AND LICENSE + +Copyright (C) 2005 by Topia. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself, either Perl version 5.8.6 or, +at your option, any later version of Perl 5 you may have available. + +=cut diff -urN /non-existant-dir/main/Tiarra/IRC/Prefix.pm tiarra-20080510/main/Tiarra/IRC/Prefix.pm --- /non-existant-dir/main/Tiarra/IRC/Prefix.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/main/Tiarra/IRC/Prefix.pm 2008-05-11 00:25:24.000000000 +0900 @@ -0,0 +1,94 @@ +# ----------------------------------------------------------------------------- +# $Id: Prefix.pm 3004 2007-12-10 12:45:39Z topia $ +# ----------------------------------------------------------------------------- +# copyright (C) 2005 Topia . all rights reserved. +package Tiarra::IRC::Prefix; +use strict; +use warnings; +use enum qw(PREFIX NICK NAME HOST); +use Tiarra::Utils; +use overload + '""' => sub { shift->prefix }; + +utils->define_array_attr_notify_accessor( + 0, '$this->_update_prefix', qw(nick name host)); +utils->define_array_attr_notify_accessor( + 0, '$this->_parse_prefix', qw(prefix)); + +*user = \&name; + +sub new { + my ($class,%args) = @_; + my $obj = bless [] => $class; + $obj->[PREFIX] = undef; + $obj->[NICK] = undef; + $obj->[NAME] = undef; + $obj->[HOST] = undef; + + foreach (qw(Prefix Nick User Name Host)) { + if (exists $args{$_}) { + my $method = lc($_); + $obj->$method($args{$_}); + } + } + $obj; +} + +sub clone { + my ($this, %args) = @_; + if ($args{deep}) { + # inhibits generator deep clone. + require Data::Dumper; + eval(Data::Dumper->new([$this])->Terse(1) + ->Deepcopy(1)->Purity(1)->Dump); + } else { + my @new = @$this; + bless \@new => ref($this); + } +} + +sub _parse_prefix { + my $this = shift; + delete $this->[NICK]; + delete $this->[NAME]; + delete $this->[HOST]; + if (defined $this->[PREFIX]) { + if ($this->[PREFIX] !~ /@/) { + $this->[NICK] = $this->[PREFIX]; + } elsif ($this->[PREFIX] =~ m/^(.+?)!(.+?)@(.+)$/) { + $this->[NICK] = $1; + $this->[NAME] = $2; + $this->[HOST] = $3; + } elsif ($this->[PREFIX] =~ m/^(.+?)@(.+)$/) { + $this->[NICK] = $1; + $this->[HOST] = $2; + } + } else { + delete $this->[PREFIX]; + } +} + +sub _update_prefix { + my $this = shift; + if (defined $this->[NICK]) { + $this->[PREFIX] = $this->[NICK]; + if (defined $this->[HOST]) { + if (defined $this->[NAME]) { + $this->[PREFIX] .= '!'.$this->[NAME]; + $this->[PREFIX] .= '@'.$this->[HOST]; + } else { + $this->[PREFIX] .= '@'.$this->[HOST]; + delete $this->[NAME]; + } + } else { + delete $this->[NAME]; + delete $this->[HOST]; + } + } else { + delete $this->[NICK]; + delete $this->[NAME]; + delete $this->[HOST]; + } +} + +1; diff -urN /non-existant-dir/main/Tiarra/Mixin/AttachPackage.pm tiarra-20080510/main/Tiarra/Mixin/AttachPackage.pm --- /non-existant-dir/main/Tiarra/Mixin/AttachPackage.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/main/Tiarra/Mixin/AttachPackage.pm 2008-05-11 00:25:24.000000000 +0900 @@ -0,0 +1,65 @@ +# ----------------------------------------------------------------------------- +# $Id: AttachPackage.pm 3004 2007-12-10 12:45:39Z topia $ +# ----------------------------------------------------------------------------- +# copyright (C) 2005 Topia . all rights reserved. +package Tiarra::Mixin::AttachPackage; +use strict; +use warnings; + +=head1 NAME + +Tiarra::Mixin::AttachPackage - generate package-attached name. + +=head1 SYNOPSIS + + package SomePackage; + use base qw(Tiarra::Mixin::AttachPackage); # define + __PACKAGE__->attach_package("foo"); # SomePackage/foo + $this->attach_package("bar", "baz"); # SomePackage/bar/baz + +=head1 DESCRIPTION + +generate package attached name. + +=head1 METHODS + +=over 4 + +=cut + +=item attach_package + + __PACKAGE__->attach_package("foo", "bar", "baz"); + $this->attach_package("foo", "bar", "baz"); + +generate package attached name. + +=cut + +sub attach_package { + my $this = shift; + if (ref($this)) { + # fetch package name + $this = ref($this); + } + join('/', $this, @_); +} + +1; + +__END__ +=back + +=head1 AUTHOR + +Topia Etopia@clovery.jpE + +=head1 COPYRIGHT AND LICENSE + +Copyright (C) 2005 by Topia. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself, either Perl version 5.8.6 or, +at your option, any later version of Perl 5 you may have available. + +=cut diff -urN /non-existant-dir/main/Tiarra/Mixin/NewIRCMessage.pm tiarra-20080510/main/Tiarra/Mixin/NewIRCMessage.pm --- /non-existant-dir/main/Tiarra/Mixin/NewIRCMessage.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/main/Tiarra/Mixin/NewIRCMessage.pm 2008-05-11 00:25:24.000000000 +0900 @@ -0,0 +1,79 @@ +# ----------------------------------------------------------------------------- +# $Id: NewIRCMessage.pm 3004 2007-12-10 12:45:39Z topia $ +# ----------------------------------------------------------------------------- +# copyright (C) 2005 Topia . all rights reserved. +package Tiarra::Mixin::NewIRCMessage; +use strict; +use warnings; +use Tiarra::IRC::Message; + +=head1 NAME + +Tiarra::Mixin::NewIRCMessage - Tiarra::IRC::Message Construction Interface Mixin +=head1 SYNOPSIS + + package foo::class; + use base qw(Tiarra::Mixin::NewIRCMessage); # use this + $this->irc_message_class->foo_class_method; + $this->construct_irc_message(Command => ...); + +=head1 DESCRIPTION + +Tiarra::Mixin::NewIRCMessage is define Tiarra::IRC::Message Construction Interface as Mixin. + +=head1 METHODS + +=over 4 + +=cut + +=item irc_message_class + + __PACKAGE__->irc_message_class; # return Tiarra::IRC::Message + $this->irc_message_class; # likewise. + +return Tiarra::IRC::Message class. you can change class to override this. + +=cut + +sub irc_message_class () { 'Tiarra::IRC::Message' } + +=item construct_irc_message + + __PACKAGE__->construct_irc_message(...); + $this->construct_irc_message(...); # likewise. + +constraction Tiarra::IRC::Message(or specified by ->irc_message_class). + +=cut + +sub construct_irc_message { + my $this = shift; + + $this->irc_message_class->new( + Generator => $this, + @_); +} + +1; + +__END__ +=back + +=head1 SEE ALSO + +L + +=head1 AUTHOR + +Topia Etopia@clovery.jpE + +=head1 COPYRIGHT AND LICENSE + +Copyright (C) 2005 by Topia. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself, either Perl version 5.8.6 or, +at your option, any later version of Perl 5 you may have available. + +=cut diff -urN /non-existant-dir/main/Tiarra/ModifiedFlagMixin.pm tiarra-20080510/main/Tiarra/ModifiedFlagMixin.pm --- /non-existant-dir/main/Tiarra/ModifiedFlagMixin.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/main/Tiarra/ModifiedFlagMixin.pm 2008-05-11 00:25:24.000000000 +0900 @@ -0,0 +1,23 @@ +# ----------------------------------------------------------------------------- +# $Id: ModifiedFlagMixin.pm 3004 2007-12-10 12:45:39Z topia $ +# ----------------------------------------------------------------------------- +# Modified Flag Mixin +# ----------------------------------------------------------------------------- +# copyright (C) 2004 Topia . all rights reserved. +package Tiarra::ModifiedFlagMixin; +use strict; +use warnings; +use Tiarra::Utils; +use Exporter; +use base qw(Exporter); +our @EXPORT = qw(set_modified clear_modified modified); + +# usage: +# use Tiarra::ModifiedFlagMixin; + +Tiarra::Utils->define_attr_accessor(0, qw(modified)); + +sub set_modified { shift->modified(1); } +sub clear_modified { shift->modified(0); } + +1; diff -urN /non-existant-dir/main/Tiarra/OptionalModules.pm tiarra-20080510/main/Tiarra/OptionalModules.pm --- /non-existant-dir/main/Tiarra/OptionalModules.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/main/Tiarra/OptionalModules.pm 2008-05-11 00:25:24.000000000 +0900 @@ -0,0 +1,78 @@ +# ----------------------------------------------------------------------------- +# $Id: OptionalModules.pm 11199 2008-05-06 07:35:55Z topia $ +# ----------------------------------------------------------------------------- +# Optional Modules Loader +# ----------------------------------------------------------------------------- +# copyright (C) 2004 Topia . all rights reserved. +package Tiarra::OptionalModules; +use strict; +use warnings; +use Tiarra::SharedMixin; +use Tiarra::Utils; +# failsafe to module-reload +our $status = {}; +our %modules = ( + 'threads' => [qw(threads threads::shared)], + 'ipv6' => [qw(IO::Socket::INET6 Socket6)], + 'time_hires' => [qw(Time::HiRes)], + 'unix_dom' => [qw(IO::Socket::UNIX)], + 'encode' => [qw(Encode)], + 'base64' => [qw(MIME::Base64)], + ); + +sub _new { + bless $status, shift; +} + +sub all_modules { + keys %modules; +} + +sub repr_modules { + my $this = shift->_this; + $this->check_all; + my @enabled = sort grep $this->check($_), keys %modules; + my @disabled = sort grep !$this->check($_), keys %modules; + + ((@enabled ? + ("enabled:", + map { + " - $_ (" . join(', ', map { + "$_ " . $_->VERSION; + } @{$modules{$_}}) . ")" + } @enabled) : ()), + (@disabled ? + ("disabled:", + map { + " - $_ (" . join(', ', @{$modules{$_}}) . ")" + } @disabled) : ())); +} + +sub check_all { + my $this = shift->_this; + map { ($_, $this->check($_)) } $this->all_modules; +} + +sub check { + my ($class_or_this, $name) = @_; + my $this = $class_or_this->_this; + + return $this->{$name} if defined $this->{$name}; + die "module $name spec. not found" unless defined $modules{$name}; + + $this->{$name} = eval join(' && ', map { "require $_" } @{$modules{$name}}) . ';'; +} + +sub AUTOLOAD { + my $this = shift; + our $AUTOLOAD; + if ($AUTOLOAD =~ /::DESTROY$/) { + # DESTROYは伝達させない。 + return; + } + + (my $key = $AUTOLOAD) =~ s/.+?:://g; + $this->check($key); +} + +1; diff -urN /non-existant-dir/main/Tiarra/Resolver.pm tiarra-20080510/main/Tiarra/Resolver.pm --- /non-existant-dir/main/Tiarra/Resolver.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/main/Tiarra/Resolver.pm 2008-05-11 00:25:24.000000000 +0900 @@ -0,0 +1,453 @@ +# ----------------------------------------------------------------------------- +# $Id: Resolver.pm 11202 2008-05-06 08:13:24Z topia $ +# ----------------------------------------------------------------------------- +# Simple Resolver with multi-thread or blocking. +# ----------------------------------------------------------------------------- +# copyright (C) 2004 Topia . all rights reserved. +package Tiarra::Resolver::QueueData; +use strict; +use warnings; +use Tiarra::DefineEnumMixin (qw(ID TIMEOUT), + qw(QUERY_TYPE QUERY_DATA ANSWER_STATUS ANSWER_DATA)); +use Tiarra::DefineEnumMixin (qw(ANSWER_OK ANSWER_NOT_FOUND ANSWER_TIMEOUT), + qw(ANSWER_NOT_SUPPORTED ANSWER_INTERNAL_ERROR)); +use Tiarra::Utils; +Tiarra::Utils->define_array_attr_accessor( + 0, qw(id timeout query_type query_data answer_status answer_data)); + +# attributes: +# timeout: not implemented yet +# query_type: resolver dependant data +# query_data: resolver dependant data +# answer_status: status +# * ANSWER_OK: resolved +# * ANSWER_NOT_FOUND: not found +# * ANSWER_TIMEOUT: timeout (not implemented yet) +# * ANSWER_NOT_SUPPORTED: not supported type (data: message) +# * ANSWER_INTERNAL_ERROR: internal error occurred (data: message) +# answer_data: data + +sub new { + my $class = shift; + + # FIXME: check type/value! + my $this = [@_]; + bless $this, $class; + $this; +} + +sub serialize { + my $this = shift; + + my @array : shared = @$this; + \@array; +} + +sub parse { + my $this = shift; + + ref($this)->new(@{+shift}); +} + +package Tiarra::Resolver; +use strict; +use warnings; +use Tiarra::OptionalModules; +use Tiarra::SharedMixin; +use Tiarra::WrapMainLoop; +use Tiarra::TerminateManager; +use Socket; +use Carp; +use Net::hostent; +use Tiarra::DefineEnumMixin qw(QUERY_HOST QUERY_ADDR QUERY_SADDR QUERY_NAMEINFO); +my $dataclass = 'Tiarra::Resolver::QueueData'; +our $use_threads; +our $use_ipv6; +our $use_threads_state_checking; +BEGIN { + $use_threads = Tiarra::OptionalModules->threads; + if ($use_threads) { + require Thread::Queue; + require threads; + require threads::shared; + ## threads 1.33 or earlier, not support $thr->is_running() + $use_threads_state_checking = threads->can('is_running'); + } + + $use_ipv6 = Tiarra::OptionalModules->ipv6; + if ($use_ipv6) { + eval 'use Socket6;'; + } else { + # dummy + *AI_NUMERICHOST = sub () { undef }; + *NI_NUMERICHOST = sub () { undef }; + *NI_NAMEREQD = sub () { undef }; + } +} + +if ($use_threads) { + # fast initialize(for minimal thread) + __PACKAGE__->shared; +} + +sub _new { + my $class = shift; + + my $this = {}; + bless $this, $class; + + if ($use_threads) { + $this->{ask_queue} = Thread::Queue->new; + $this->{reply_queue} = Thread::Queue->new; + $this->_create_thread(); + $this->{main_timer} = Tiarra::WrapMainLoop->new( + type => 'timer', + interval => 1, + closure => sub { + $this->mainloop; + }); + $this->{main_loop} = Tiarra::WrapMainLoop->new( + type => 'mainloop', + closure => sub { + $this->mainloop; + }); + $this->{destructor} = Tiarra::TerminateManager::Hook->new( + sub { + $this->destruct; + })->install; + } + $this->{id} = 0; + $this->{closures} = {}; + $this; +} + +sub _check_thread { + my $this = shift; + + if (!$use_threads_state_checking || + (defined $this->{thread} && + $this->{thread}->is_running())) { + return undef; + } + $this->_create_thread; +} + +sub _create_thread { + my $this = shift; + + $this->{thread} = threads->create("resolver_thread", + ref($this), + $this->{ask_queue}, + $this->{reply_queue}); +} + +sub destruct { + my $this = shift; + + $this->{ask_queue}->enqueue(undef); + $this->{thread}->join; + $this->mainloop; +} + +sub resolve { + my ($class_or_this, $type, $data, $closure, $my_use_threads) = @_; + my $this = $class_or_this->_this; + + $my_use_threads = $use_threads unless defined $my_use_threads; + croak 'data not defined; please specify this' unless defined $data; + croak 'closure not defined; please specify this' unless defined $closure; + my $entry = $dataclass->new; + my $do = undef; + if ($type eq 'addr') { + # addr: forward lookup + # query data: hostname + # callback data: [addr1, addr2, ...] + $entry->query_type(QUERY_ADDR); + $entry->query_data($data); + $do = 1; + } elsif ($type eq 'host') { + # host: reverse lookup + # query data: ip address + # callback data: hostname or [host1, host2, ...] + $entry->query_type(QUERY_HOST); + $entry->query_data($data); + $do = 1; + } elsif ($type eq 'saddr') { + # saddr: get socket addr + # query data: [host, port] + # callback data: sockaddr struct + $entry->query_type(QUERY_SADDR); + $entry->query_data($data); + $do = 1; + } elsif ($type eq 'nameinfo') { + # nameinfo: get address/port from socket addr + # query data: sockaddr struct + # callback data: [address, port] + $entry->query_type(QUERY_NAMEINFO); + $entry->query_data($data); + $do = 1; + $my_use_threads = 0; # thread is not required + } + local $use_threads = $my_use_threads; + if ($do) { + $entry->timeout(0); + $entry->id($this->{id}++); + $this->{closures}->{$entry->id} = $closure; + if ($use_threads) { + $this->_check_thread(); + $this->{ask_queue}->enqueue($entry->serialize); + $this->{main_timer}->lazy_install; + $this->{main_loop}->lazy_install; + undef; + } else { + $this->_call($this->_resolve($entry)); + } + } else { + $entry->answer_status($entry->ANSWER_NOT_SUPPORTED); + $entry->answer_data("typename '$type' not supported"); + $closure->($entry); + } +} + +sub paranoid_check { + # ip -> host -> ip check + # closure: sub { + # my ($status, $hostname, $final_result) = @_; + # if (!$status) { die "paranoid check failed!"; } + # warn "paranoid check successful with: $hostname"; + # if (defined $final_result) { /* maybe unnecessary */ } + # } + my ($class_or_this, $data, $closure, $my_use_threads) = @_; + my $this = $class_or_this->_this; + + # stage 1 + $this->resolve( + 'host', $data, sub { + eval { + $this->_paranoid_stage1($data, $closure, $my_use_threads, shift); + }; if ($@) { + $closure->(0, undef); + } + }, $my_use_threads); +} + +sub _paranoid_stage1 { + my ($this, $data, $closure, $my_use_threads, $entry) = @_; + + if ($entry->answer_status eq $entry->ANSWER_OK) { + my $host = $entry->answer_data; + if (ref($host) eq 'ARRAY') { + # FIXME: support multiple hostname resolved + $host = $host->[0]; + } + $this->resolve( + 'addr', $host, sub { + eval { + $this->_paranoid_stage2($data, $closure, $my_use_threads, shift); + }; if ($@) { + $closure->(0, undef, $entry); + } + }, $my_use_threads); + } else { + $closure->(0, undef, $entry); + } +} + +sub _paranoid_stage2 { + my ($this, $data, $closure, $my_use_threads, $entry) = @_; + + if ($entry->answer_status eq $entry->ANSWER_OK) { + if (grep { $data eq $_ } @{$entry->answer_data}) { + $closure->(1, $entry->query_data, $entry); + } + } else { + $closure->(0, undef, $entry); + } +} + +sub _call { + my ($this, $entry) = @_; + + my $id = $entry->id; + eval { $this->{closures}->{$id}->($entry); }; + if ($@) { ::printmsg($@); } + delete $this->{closures}->{$id}; + if (!%{$this->{closures}} && $use_threads) { + $this->{main_timer}->lazy_uninstall; + $this->{main_loop}->lazy_uninstall; + } + $entry; +} + +sub _resolve { + my ($class_or_this, $entry) = @_; + + my $resolved = undef; + my $ret = undef; + + if ($entry->query_type eq QUERY_ADDR) { + my @addrs; + threads::shared::share(@addrs) if $use_threads; + + if ( $^O =~ /^MSWin32/ && $entry->query_data eq 'localhost' ) { + # Win2kだとなぜか問い合わせに失敗するので固定応答. + @addrs = ('127.0.0.1'); + if ($use_ipv6) { + push(@addrs, '::1'); + } + $resolved = 1; + } + if ($use_ipv6 && !$resolved) { + my @res = getaddrinfo($entry->query_data, 0, AF_UNSPEC, SOCK_STREAM); + my ($saddr, $addr, %addrs); + while (scalar(@res) >= 5) { + # check proto,... etc + (undef, undef, undef, $saddr, undef, @res) = @res; + ($addr, undef) = getnameinfo($saddr, NI_NUMERICHOST); + if (defined $addr && !$addrs{$addr}) { + $addrs{$addr} = 1; + push(@addrs, $addr); + } + } + if (@addrs) { + $resolved = 1; + } + } + if (!$resolved) { + my $hostent = Net::hostent::gethost($entry->query_data); + if (defined $hostent) { + #$entry->answer_data($hostent->addr_list); + @addrs = map { + inet_ntoa($_); + } @{$hostent->addr_list}; + $resolved = 1; + } + } + + if ($resolved) { + $entry->answer_data(\@addrs); + } + } elsif ($entry->query_type eq QUERY_HOST) { + my @hosts; + threads::shared::share(@hosts) if $use_threads; + + if ( $^O =~ /^MSWin32/ && $entry->query_data eq '127.0.0.1' ) { + # Win2kだとなぜか問い合わせに失敗するので固定応答. + @hosts = ('localhost'); + $resolved = 1; + } + if ($use_ipv6 && !$resolved) { + my @res = getaddrinfo($entry->query_data, 0, AF_UNSPEC, SOCK_STREAM); + my ($saddr, $host, %hosts); + while (scalar(@res) >= 5) { + # check proto,... etc + (undef, undef, undef, $saddr, undef, @res) = @res; + ($host, undef) = getnameinfo($saddr, NI_NAMEREQD); + if (defined $host && !$hosts{$host}) { + $hosts{$host} = 1; + push(@hosts, $host); + } + } + if (@hosts) { + $resolved = 1; + } + } + if (!$resolved) { + my $hostent = Net::hostent::gethost($entry->query_data); + if (defined $hostent) { + @hosts = ($hostent->name); + $resolved = 1; + } + } + + if ($resolved) { + $entry->answer_data(@hosts == 1 ? $hosts[0] : \@hosts); + } + } elsif ($entry->query_type eq QUERY_SADDR) { + if ($use_ipv6 && !$resolved) { + my @res = getaddrinfo($entry->query_data->[0], + $entry->query_data->[1], + AF_UNSPEC, SOCK_STREAM); + my ($saddr); + (undef, undef, undef, $saddr, undef, @res) = @res; + if (defined $saddr) { + $entry->answer_data($saddr); + $resolved = 1; + } + } + if (!$resolved) { + my $addr = inet_aton($entry->query_data->[0]); + if (defined $addr) { + $entry->answer_data(pack_sockaddr_in($entry->query_data->[1], + $addr)); + $resolved = 1; + } + } + } elsif ($entry->query_type eq QUERY_NAMEINFO) { + my ($addr, $port); + if ($use_ipv6 && !$resolved) { + ($addr, $port) = getnameinfo($entry->query_data, NI_NUMERICHOST); + $resolved = 1; + } + if (!$resolved) { + ($port, $addr) = sockaddr_in($entry->query_data); + $resolved = 1; + } + if ($resolved) { + my @data; + threads::shared::share(@data) if $use_threads; + @data = ($addr, $port); + $entry->answer_data(\@data); + } + } else { + carp 'unsupported query type('.$entry->query_type.')'; + $entry->answer_status($entry->ANSWER_NOT_SUPPORTED); + $entry->answer_data('unsupported query type('.$entry->query_type.')'); + } + + if ($resolved) { + $entry->answer_status($entry->ANSWER_OK); + } else { + $entry->answer_status($entry->ANSWER_NOT_FOUND); + } + return $entry; +} + +sub resolver_thread { + my ($class, $ask_queue, $reply_queue) = @_; + + my ($data, $entry); + while (defined ($data = $ask_queue->dequeue)) { + $entry = $dataclass->new->parse($data); + eval { + $reply_queue->enqueue($class->_resolve($entry)->serialize); + }; if ($@) { + my $err = $@; + $entry->answer_status($entry->ANSWER_INTERNAL_ERROR); + eval { + require Data::Dumper; + my $answer_data = $entry->answer_data; + if (defined $answer_data) { + $err .= "(answer_data: " . + Data::Dumper->new([$entry->answer_data])->Terse(1)-> + Purity(1)->Dump . ")\n"; + } + }; + $entry->answer_data($err); + $reply_queue->enqueue($entry->serialize); + } + } + return 0; +} + +sub mainloop { + my $this = shift; + + my $entry; + while ($this->{reply_queue}->pending) { + $entry = $this->{reply_queue}->dequeue; + $this->_call($dataclass->new->parse($entry)); + } +} + +1; diff -urN /non-existant-dir/main/Tiarra/SessionMixin.pm tiarra-20080510/main/Tiarra/SessionMixin.pm --- /non-existant-dir/main/Tiarra/SessionMixin.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/main/Tiarra/SessionMixin.pm 2008-05-11 00:25:24.000000000 +0900 @@ -0,0 +1,113 @@ +# ----------------------------------------------------------------------------- +# $Id: SessionMixin.pm 3004 2007-12-10 12:45:39Z topia $ +# ----------------------------------------------------------------------------- +# Session Mixin +# ----------------------------------------------------------------------------- +# copyright (C) 2004 Topia . all rights reserved. +package Tiarra::SessionMixin; +use strict; +use warnings; +use Tiarra::OptionalModules; +use Tiarra::Utils; +use Carp; +use base qw(Tiarra::Utils); +our $use_threads = Tiarra::OptionalModules->threads; + +# usage: +# use Tiarra::SessionMixin; +# use base qw(SessionMixin); +# sub new { +# ... +# $this->_session_init; +# } + +__PACKAGE__->define_attr_accessor(0, qw(session_level)); +sub _session_init { + my $this = shift; + $this->session_level(0); + if ($use_threads) { + my $lock : shared; + $this->{lock} = \$lock; + } + $this->{session_name} = (caller)[0].' session'; +} + +sub session_name { + my $this = shift; + $this->get_first_defined( + eval { $this->name; }, + $this->{session_name}); +} + +sub __session_start { + my $this = shift; + if ($this->session_level == 1) { + carp 'this object already started...'; + } + eval { $this->_before_session_start; }; + ++$this->session_level; + eval { $this->_after_session_start; }; + 1; +} + +sub __session_finish { + my $this = shift; + if ($this->session_level == 0) { + carp 'this object already finished!'; + $this->session_level = 1; + } + eval { $this->_before_session_finish; }; + --$this->session_level; + eval { $this->_after_session_finish; }; + 1; +} + +sub with_session { + my ($this, $closure) = @_; + my $wantarray = wantarray; + my $level = $this->session_level; + $this->__session_start unless $level; + lock $this->{lock} if $use_threads; + $this->do_with_ensure( + sub { + $this->do_with_errmsg( + $this->session_name, + sub { + $this->call_with_wantarray($wantarray, $closure); + } + ); + }, + sub { $this->__session_finish unless $level; }); +} + +sub define_session_wrap { + my $pkg = shift; + my $class_method_p = shift; + foreach (@_) { + my ($funcname, $proxyname); + if (ref($_) eq 'ARRAY') { + $funcname = $_->[0]; + $proxyname = $_->[1]; + } else { + $funcname = $_; + $proxyname = "_$_"; + } + $pkg->define_function( + $pkg->get_package, + ($class_method_p ? sub { + my $class_or_this = shift; + my $this = $class_or_this->_this; + $this->with_session( + sub { $this->$proxyname(@_) } + ); + } : sub { + my $this = shift; + $this->with_session( + sub { $this->$proxyname(@_) } + ); + }), + $funcname); + } +} + +1; diff -urN /non-existant-dir/main/Tiarra/SharedMixin.pm tiarra-20080510/main/Tiarra/SharedMixin.pm --- /non-existant-dir/main/Tiarra/SharedMixin.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/main/Tiarra/SharedMixin.pm 2008-05-11 00:25:24.000000000 +0900 @@ -0,0 +1,71 @@ +# ----------------------------------------------------------------------------- +# $Id: SharedMixin.pm 3004 2007-12-10 12:45:39Z topia $ +# ----------------------------------------------------------------------------- +# Shared Instance(Singleton) Mixin +# ----------------------------------------------------------------------------- +# copyright (C) 2004 Topia . all rights reserved. +package Tiarra::SharedMixin; +use strict; +use warnings; +use base qw(Tiarra::Utils); +our $ExportLevel = 0; + +# usage: +# use Tiarra::SharedMixin qw(shared shared_module); +# our $_shared_instance; # optional, but useful for documentation. +# sub _new { +# my $class = shift; +# my ($this) = {@_}; +# bless $this, $class; +# #__PACKAGE__->shared->some_func; # can't use +# return $this; +# } +# sub _initialize { # optional +# my $this = shift; +# __PACKAGE__->shared->some_func; # OK +# } +# __PACKAGE__->_shared_init(args...); + +# use $_shared_instance variable. +# import shared and _shared_init and _this functions. + +sub import { + my $pkg = shift; + my $call_pkg = $pkg->get_package($ExportLevel); + my $instance_name = $call_pkg.'::_shared_instance'; + if ($#_ != 0) { + push(@_, 'shared'); + } + my @funcnames = @_; + + no strict 'refs'; + # fastest call + no warnings; + + $pkg->define_function( + $call_pkg, + sub { + my $class = shift; + if (!defined ${$instance_name}) { + ${$instance_name} = $call_pkg->_new(@_); + eval { + # safe initialize with ->shared. + ${$instance_name}->_initialize(@_); + }; + } + $pkg->define_function( + $call_pkg, + sub () { ${$instance_name} }, + @funcnames); + ${$instance_name}; + }, + @funcnames, + '_shared_init'); + + $pkg->define_function( + $call_pkg, + $pkg->can('_this'), + '_this'); +} + +1; diff -urN /non-existant-dir/main/Tiarra/ShorthandConfMixin.pm tiarra-20080510/main/Tiarra/ShorthandConfMixin.pm --- /non-existant-dir/main/Tiarra/ShorthandConfMixin.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/main/Tiarra/ShorthandConfMixin.pm 2008-05-11 00:25:24.000000000 +0900 @@ -0,0 +1,26 @@ +# ----------------------------------------------------------------------------- +# $Id: ShorthandConfMixin.pm 3004 2007-12-10 12:45:39Z topia $ +# ----------------------------------------------------------------------------- +# Shorthand writing conf Mixin +# ----------------------------------------------------------------------------- +# copyright (C) 2004 Topia . all rights reserved. +package Tiarra::ShorthandConfMixin; +use strict; +use warnings; +use Exporter; +use base qw(Exporter); +our @EXPORT = qw(_conf _conf_general _conf_networks _conf_messages); + +# usage: +# use Tiarra::ShorthandConfMixin; +# use base qw(Tiarra::ShorthandConfMixin) + +# use _runloop function. + +# shorthand for Configuration->shared->... +sub _conf { shift->_runloop->{conf}; } +sub _conf_general { shift->_conf->general; } +sub _conf_networks { shift->_conf->networks; } +sub _conf_messages { shift->_conf_general->messages; } + +1; diff -urN /non-existant-dir/main/Tiarra/Socket/Buffered.pm tiarra-20080510/main/Tiarra/Socket/Buffered.pm --- /non-existant-dir/main/Tiarra/Socket/Buffered.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/main/Tiarra/Socket/Buffered.pm 2008-05-11 00:25:24.000000000 +0900 @@ -0,0 +1,173 @@ +# ----------------------------------------------------------------------------- +# $Id: Buffered.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +# Buffered Socket +# ----------------------------------------------------------------------------- +# copyright (C) 2004 Topia . all rights reserved. +package Tiarra::Socket::Buffered; +use strict; +use warnings; +use Carp; +use Tiarra::Socket; +use base qw(Tiarra::Socket); +use Tiarra::Utils; +utils->define_attr_getter(0, qw(connected)); +utils->define_attr_accessor(0, qw(recvbuf sendbuf)); + +sub new { + my ($class, %opts) = @_; + + $class->_increment_caller('buffered-socket', \%opts); + my $this = $class->SUPER::new(%opts); + $this->{connected} = undef; + $this->{sendbuf} = ''; + $this->{recvbuf} = ''; + $this->{disconnect_after_writing} = 0; + $this; +} + +sub DESTROY { + my $this = shift; + + $this->disconnect if $this->connected; +} + +sub disconnect_after_writing { + shift->{disconnect_after_writing} = 1; +} + +sub disconnect { + my ($this, $errno, $genre, @params) = @_; + + $this->uninstall if $this->installed; + $this->close; +} + +sub attach { + my ($this, $sock) = @_; + return undef if $this->connected; + return undef unless defined $sock; + + $this->SUPER::attach($sock); + $this->{connected} = 1; + + return $this; +} + +sub detach { + my $this = shift; + + if (!defined $this->sock) { + croak "already detached; can't detach!"; + } + if ($this->installed) { + carp "installed; anyway detach..."; + $this->uninstall; + } + + $this->{connected} = 0; + $this->{sendbuf} = ''; + #$this->{recvbuf} = ''; + $this->SUPER::detach; +} + +sub write_length { length shift->sendbuf } +# 送るべきデータがあれば1、無ければ0を返します。 +sub want_to_write { shift->write_length > 0 } +sub read_length { length shift->recvbuf } +sub has_data { shift->read_length > 0 } + +sub append { + my ($this, $str) = @_; + + $this->sendbuf .= $str; +} + +sub write { + my ($this) = @_; + # このメソッドはソケットに送れるだけのメッセージを送ります。 + # 送信の準備が整っていなかった場合は、このメソッドは操作をブロックします。 + # それがまずいのなら予めselectで書き込める事を確認しておいて下さい。 + if (!$this->connected) { + die "write : socket is not connected.\n"; + } + + my $bytes_sent = $this->sock->syswrite($this->sendbuf, $this->write_length); + if (defined $bytes_sent) { + substr($this->sendbuf, 0, $bytes_sent) = ''; + + if ($this->{disconnect_after_writing} && + !$this->want_to_write) { + $this->disconnect; + } + } else { + # write error + $this->handle_io_error('write', $!); + } +} + +sub read { + my $this = shift; + # ソケットに読めるデータが来ていなかった場合、このメソッドは読めるようになるまで + # 操作をブロックします。それがまずい場合は予めselectで読める事を確認しておいて下さい。 + # このメソッドを実行したことで始めてソケットが閉じられた事が分かった場合は、 + # メソッド実行後からはconnectedメソッドが偽を返すようになります。 + if (!$this->connected) { + $this->disconnect; + return (); + } + + my $recvbuf = ''; + my $retval = $this->sock->sysread($recvbuf,4096); # とりあえず最大で4096バイトを読む + if (defined $retval) { + if ($retval == 0) { + # EOF + $this->disconnect('eof'); + } else { + $this->recvbuf .= $recvbuf; + } + } else { + # read error + $this->handle_io_error('read', $!); + } +} + +sub handle_io_error { + my ($this, $genre, $errno) = @_; + + local $! = $errno; + if ($!{EWOULDBLOCK} || $!{EINPROGRESS} || $!{EALREADY} || $!{ENOBUFS}) { + $this->runloop->notify_warn($this->sock_errno_to_msg($errno, "$genre error")); + } else { + # maybe couldn't continue + $this->disconnect($genre, $errno); + } +} + +sub exception { + my $this = shift; + + $this->handle_io_error('exception', $this->errno); +} + +sub flush { + my $this = shift; + + return undef unless $this->connected; + + my ($select) = IO::Select->new($this->sock); + + if ($this->want_to_write && $select->can_write(0)) { + $this->write; + } + + return undef unless $this->connected; + + if ($select->can_read(0)) { + $this->read; + } + + return 1; +} + +1; diff -urN /non-existant-dir/main/Tiarra/Socket/Connect.pm tiarra-20080510/main/Tiarra/Socket/Connect.pm --- /non-existant-dir/main/Tiarra/Socket/Connect.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/main/Tiarra/Socket/Connect.pm 2008-05-11 00:25:24.000000000 +0900 @@ -0,0 +1,442 @@ +# ----------------------------------------------------------------------------- +# $Id: Connect.pm 11203 2008-05-06 08:34:36Z topia $ +# ----------------------------------------------------------------------------- +# Socket Connector +# ----------------------------------------------------------------------------- +# copyright (C) 2004 Topia . all rights reserved. +package Tiarra::Socket::Connect; +use strict; +use warnings; +use Carp; +use Tiarra::Socket; +use base qw(Tiarra::Socket); +use Timer; +use Tiarra::OptionalModules; +use Tiarra::Utils; +utils->define_attr_accessor(0, qw(domain host addr port callback), + qw(bind_addr prefer timeout), + qw(retry_int retry_count try_count)); +utils->define_attr_enum_accessor('domain', 'eq', + qw(tcp unix)); + +# now supported tcp, unix + +# tcp: +# my $connector = connect->new( +# host => [hostname], +# port => [port], +# callback => sub { +# my ($genre, $connector, $msg_or_sock, $errno) = @_; +# if ($genre eq 'warn') { +# # $msg_or_sock: msg +# # maybe don't have $errno +# warn $msg_or_sock; +# } elsif ($genre eq 'error') { +# # $msg_or_sock: msg +# # maybe has $errno +# die $msg_or_sock; +# } elsif ($genre eq 'sock') { +# # $msg_or_sock: sock +# # maybe don't have $errno +# attach($connector->current_addr, $connector->current_port, +# $msg_or_sock); +# # optional genre +# } elsif ($genre eq 'interrupt') { +# # $msg_or_sock: undef +# # maybe don't have $errno +# die 'interrupted'; +# } elsif ($genre eq 'timeout') { +# # $msg_or_sock: undef +# # maybe don't have $errno +# die 'timeout'; +# } +# }, +# # optional params +# addr => [already resolved addr], +# bind_addr => [bind_addr (cannot specify host)], +# timeout => [timeout], # didn't test enough, please send report when bugs. +# retry_int => [retry interval], +# retry_count => [retry count], +# prefer => [prefer socket type(and order) (ipv4, ipv6) as string's +# array ref, default ipv6, ipv4], +# domain => 'tcp', # default +# ); +# $connector->interrupt; +# unix: +# my $connector = connect->new( +# addr => [path], +# callback => sub { +# # ... same as tcp domain's +# }, +# # optional params +# domain => 'unix', # please define this +# ); + +sub new { + my ($class, %opts) = @_; + + $class->_increment_caller('socket-connector', \%opts); + my $this = $class->SUPER::new(%opts); + map { + $this->$_($opts{$_}); + } qw(host addr port callback bind_addr timeout retry_int retry_count); + + if (!defined $this->callback) { + croak 'callback closure required'; + } + + $this->domain(utils->get_first_defined($opts{domain}, 'tcp')); + $this->prefer($opts{prefer}); + + if (!defined $this->prefer) { + if ($this->domain_tcp) { + my @prefer; + @prefer = ('ipv4'); + if (Tiarra::OptionalModules->ipv6) { + unshift(@prefer, 'ipv6') + } + $this->prefer(\@prefer); + } elsif ($this->domain_unix) { + $this->prefer(['unix']); + } else { + croak 'Unsupported domain: '. $this->domain; + } + } + + $this->{queue} = []; + $this->connect; +} + +sub connect { + my $this = shift; + + if (defined $this->timeout) { + $this->{timer} = Timer->new( + After => $this->timeout, + Code => sub { + $this->interrupt('timeout'); + }); + } + + if (defined $this->addr || $this->domain_unix) { + my $entry = Tiarra::Resolver::QueueData->new; + $entry->answer_status($entry->ANSWER_OK); + $entry->answer_data([$this->addr]); + $this->_connect_stage($entry); + } else { + Tiarra::Resolver->resolve( + 'addr', $this->host, sub { + eval { + $this->_connect_stage(@_); + }; if ($@) { + $this->_connect_error("internal error: $@"); + } + }); + } + $this; +} + +sub _connect_stage { + my ($this, $entry) = @_; + + my %addrs_by_types; + + if ($entry->answer_status ne $entry->ANSWER_OK) { + $this->_connect_error("Couldn't resolve hostname"); + return undef; # end + } + + foreach my $addr (@{$entry->answer_data}) { + push (@{$addrs_by_types{$this->probe_type_by_addr($addr)}}, + $addr); + } + + foreach my $sock_type (@{$this->prefer}) { + my $struct; + push (@{$this->{queue}}, + map { + $struct = { + type => $sock_type, + addr => $_, + port => $this->port, + }; + } @{$addrs_by_types{$sock_type}}); + } + $this->_connect_try_next; +} + +sub _connect_try_next { + my $this = shift; + + $this->{connecting} = shift @{$this->{queue}}; + if (defined $this->{connecting}) { + my $methodname = '_try_connect_' . $this->{connecting}->{type}; + $this->$methodname; + } else { + if ($this->retry_int && (++$this->try_count <= $this->retry_count)) { + $this->{timer} = Timer->new( + After => $this->retry_int, + Code => sub { + $this->cleanup; + $this->connect; + }); + $this->_connect_warn( + 'all dead, ' . + utils->to_ordinal_number($this->try_count) . ' retry'); + } else { + $this->_connect_error('all dead'); + } + } +} + +sub _try_connect_ipv4 { + my $this = shift; + + $this->_try_connect_tcp('IO::Socket::INET'); +} + +sub _try_connect_ipv6 { + my $this = shift; + + if (!Tiarra::OptionalModules->ipv6) { + $this->_error( + qq{Host $this->{host} seems to be an IPv6 address, }. + qq{but IPv6 support is not enabled. }. + qq{Use IPv4 or install Socket6 or IO::Socket::INET6 if possible.\n}); + } + + $this->_try_connect_tcp('IO::Socket::INET6'); +} + +sub _try_connect_tcp { + my ($this, $package, $addr, %additional) = @_; + + if (!eval("require $package")) { + $this->_connect_error("Couldn\'t require socket package: $package"); + return; + } + my $sock = $package->new( + %additional, + (defined $this->{bind_addr} ? + (LocalAddr => $this->{bind_addr}) : ()), + Timeout => undef, + Proto => 'tcp'); + if (!defined $sock) { + $this->_connect_error( + $this->sock_errno_to_msg($!, 'Couldn\'t prepare socket'), + $!); + return; + } + if (!defined $sock->blocking(0)) { + # effect only on connecting; comment out + #$this->_warn('cannot non-blocking') if ::debug_mode(); + + if ($this->_is_winsock) { + # winsock FIONBIO + my $FIONBIO = 0x8004667e; # from Winsock2.h + my $temp = chr(1); + my $retval = $sock->ioctl($FIONBIO, $temp); + if (!$retval) { + $this->_warn($this->sock_errno_to_msg( + $!, 'Couldn\'t set non-blocking mode (winsock2)'), $!); + } + } else { + $this->_warn($this->sock_errno_to_msg( + $!, 'Couldn\'t set non-blocking mode (general)'), $!); + } + } + my $saddr = Tiarra::Resolver->resolve( + 'saddr', [$this->current_addr, $this->current_port], + sub {}, 0); + $this->{connecting}->{saddr} = $saddr->answer_data; + if ($sock->connect($this->{connecting}->{saddr}) || + $!{EINPROGRESS} || $!{EWOULDBLOCK}) { + my $error = $!; + $this->attach($sock); + $! = $error; + if ($!{EINPROGRESS} || $!{EWOULDBLOCK}) { + $this->install; + } else { + $this->_call; + } + } else { + $this->_connect_warn_try_next($!, 'connect error'); + } +} + +sub _try_connect_unix { + my $this = shift; + + if (!Tiarra::OptionalModules->unix_dom) { + $this->_error( + qq{Address $this->{addr} seems to be an Unix Domain Socket address, }. + qq{but Unix Domain Socket support is not enabled. }. + qq{Use other protocol if possible.\n}); + } + + require IO::Socket::UNIX; + my $sock = IO::Socket::UNIX->new(Peer => $this->{connecting}->{addr}); + if (defined $sock) { + $this->attach($sock); + $this->_call; + } else { + $this->_connect_warn_try_next($!, 'Couldn\'t connect'); + } +} + +sub _connect_warn_try_next { + my ($this, $errno, $msg) = @_; + + $this->_connect_warn($this->sock_errno_to_msg($errno, $msg), $errno); + $this->_connect_try_next; +} + +sub _connect_error { shift->_connect_warn_or_error('error', @_); } +sub _connect_warn { shift->_connect_warn_or_error('warn', @_); } + +sub _connect_warn_or_error { + my $this = shift; + my $method = '_'.shift; + my $str = shift; + my $errno = shift; # but optional + if (defined $str) { + $str = ': ' . $str; + } else { + $str = ''; + } + + $this->$method("Couldn't connect to ".$this->destination.$str, $errno, @_); +} + +sub destination { + my $this = shift; + + $this->repr_destination( + host => $this->host, + addr => $this->current_addr, + port => $this->current_port, + type => $this->current_type); +} + +sub current_addr { + my $this = shift; + + utils->get_first_defined( + $this->{connecting}->{addr}, + $this->addr); +} + +sub current_port { + my $this = shift; + + utils->get_first_defined( + $this->{connecting}->{port}, + $this->port); +} + +sub current_type { + my $this = shift; + + $this->{connecting}->{type}; +} + +sub _error { + # connection error; and finish ->connect chain + my ($this, $msg, $errno) = @_; + + $this->callback->('error', $this, $msg, $errno); +} + +sub _warn { + # connection warning; but continue trying + my ($this, $msg, $errno) = @_; + + $this->callback->('warn', $this, $msg, $errno); +} + +sub _call { + # connection successful + my $this = shift; + + $this->callback->('sock', $this, $this->sock); +} + +sub cleanup { + my $this = shift; + + if ($this->installed) { + $this->uninstall; + } + if (defined $this->{timer}) { + $this->{timer}->uninstall; + $this->{timer} = undef; + } +} + +sub interrupt { + my ($this, $genre) = @_; + + $this->cleanup; + if (defined $this->sock) { + $this->close; + } + $genre = 'interrupt' unless defined $genre; + $this->callback->($genre, $this); +} + +sub want_to_write { + 1; +} + +sub write { shift->proc_sock('write') } +sub read { shift->proc_sock('read') } +sub exception { shift->_handle_sock_error } + +sub proc_sock { + my $this = shift; + my $state = shift; + + if ($state eq 'write') { + my $error = $this->errno; + $this->cleanup; + if ($error) { + $this->close; + $this->_connect_warn_try_next($error); + } else { + $this->_call; + } + } elsif (!$this->sock->connect($this->{connecting}->{saddr})) { + if ($!{EISCONN} || + ($this->_is_winsock && (($! == 10022) || $!{EWOULDBLOCK} || + $!{EALREADY}))) { + $this->cleanup; + $this->_call; + } else { + $this->_warn( + $this->sock_errno_to_msg($!, 'connection try error'), $!); + $this->_handle_sock_error; + } + } elsif (!IO::Select->new($this->sock)->can_write(0)) { + $this->_warn('cannot write socket error'); + my $error = $this->errno; + $this->cleanup; + $this->close; + $this->_connect_warn_try_next($error, "cant write on $state"); + } else { + # ignore first ready-to-read + if ($state ne 'read' || $this->{unexpected_want_to_read_count}++) { + $this->_warn("connect successful, why called this on $state?"); + } + } +} + +sub _handle_sock_error { + my $this = shift; + + my $error = $this->errno; + $this->cleanup; + $this->close; + $this->_connect_warn_try_next($error); +} + +1; diff -urN /non-existant-dir/main/Tiarra/Socket/Lined.pm tiarra-20080510/main/Tiarra/Socket/Lined.pm --- /non-existant-dir/main/Tiarra/Socket/Lined.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/main/Tiarra/Socket/Lined.pm 2008-05-11 00:25:24.000000000 +0900 @@ -0,0 +1,52 @@ +# ----------------------------------------------------------------------------- +# $Id: Lined.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +# Lined Socket +# ----------------------------------------------------------------------------- +# copyright (C) 2004 Topia . all rights reserved. +package Tiarra::Socket::Lined; +use strict; +use warnings; +use Carp; +use Tiarra::Socket::Buffered; +use base qw(Tiarra::Socket::Buffered); +use Tiarra::Utils; +utils->define_attr_accessor(0, qw(eol)); + +sub new { + my ($class, %opts) = @_; + + $class->_increment_caller('lined-socket', \%opts); + my $this = $class->SUPER::new(%opts); + $this->eol(utils->get_first_defined( + $opts{eol}, + "\x0d\x0a")); + $this; +} + +sub append_line { + my ($this, $line) = @_; + + $this->append($line . $this->eol); +} + +sub pop_queue { + # このメソッドは受信キュー内の最も古いものを取り出します。 + # キューが空ならundefを返します。 + # 行単位でないI/Oが必要ならrecvbufを直接操作してください。 + my ($this) = @_; + $this->flush; # 念のためflushをしてbufferを更新しておく。 + + my $eol_pos = index($this->recvbuf, $this->eol); + if ($eol_pos == -1) { + # 一行分のデータが届いていない。 + return undef; + } + + my $line = substr($this->recvbuf, 0, $eol_pos); + substr($this->recvbuf, 0, $eol_pos + CORE::length($this->eol)) = ''; + + return $line; +} + +1; diff -urN /non-existant-dir/main/Tiarra/Socket/Win32Errno.pm tiarra-20080510/main/Tiarra/Socket/Win32Errno.pm --- /non-existant-dir/main/Tiarra/Socket/Win32Errno.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/main/Tiarra/Socket/Win32Errno.pm 2008-05-11 00:25:24.000000000 +0900 @@ -0,0 +1,72 @@ +# ----------------------------------------------------------------------------- +# $Id: Win32Errno.pm 3004 2007-12-10 12:45:39Z topia $ +# ----------------------------------------------------------------------------- +# Win32 (Winsock2) Errno to message formatter +# why we cannot use 'local $@ = errno; "$@"' ? +# ----------------------------------------------------------------------------- +# copyright (C) 2004 Topia . all rights reserved. +package Tiarra::Socket::Win32Errno; +use strict; +use warnings; +use Tiarra::SharedMixin; +use Errno; +our %descriptions; + +sub _new { + return __PACKAGE__; +} + + +BEGIN { + my @data = split /\n/, <<__YAML__; +--- !tiarra.org/misc^win32-errno-messages +EWOULDBLOCK: Resource temporarily unavailable. +EINPROGRESS: Operation now in progress +EALREADY: Operation already in progress +ENOTSOCK: Socket operation on nonsocket +EDESTADDRREQ: Destination address required +EMSGSIZE: Message too long +EPROTOTYPE: Protocol wrong type for socket +ENOPROTOOPT: Bad protocol option +EPROTONOSUPPORT: Protocol not supported +EOPNOTSUPP: Operation not supported +EPFNOSUPPORT: Protocol family not supported +EAFNOSUPPORT: Address family not supported by protocol family +EADDRINUSE: Address already in use +EADDRNOTAVAIL: Cannot assign requested address +ENETDOWN: Network is down +ENETUNREACH: Network is unreachable +ENETRESET: Network dropped connection on reset +ECONNABORTED: Software caused connection abort +ECONNRESET: Connection reset by peer +ENOBUFS: No buffer space available +EISCONN: Socket is already connected +ENOTCONN: Socket is not connected +ESHUTDOWN: Cannot send after socket shutdown +ETIMEDOUT: Connection timed out +ECONNREFUSED: Connection refused +EHOSTDOWN: Host is down +EHOSTUNREACH: No route to host +EPROCLIM: Too many processes +__YAML__ + # strip yaml header + shift @data; + %descriptions = (); + my ($name, $description, $value); + map { + ($name, $description) = split(/: /, $_, 2); + if (defined $name && exists $!{$name}) { + $value = Errno->$name; + $descriptions{$value} = $description; + } + (); + } @data; +} + +sub fetch_description { + my ($class_or_this, $number) = @_; + + $descriptions{$number}; +} + +1; diff -urN /non-existant-dir/main/Tiarra/Socket.pm tiarra-20080510/main/Tiarra/Socket.pm --- /non-existant-dir/main/Tiarra/Socket.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/main/Tiarra/Socket.pm 2008-05-11 00:25:24.000000000 +0900 @@ -0,0 +1,482 @@ +# ----------------------------------------------------------------------------- +# $Id: Socket.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +# Socket Wrapper +# 注意: Win32 環境では Socket 以外のファイルハンドル等に select を使えません。 +# (see perlport) +# ----------------------------------------------------------------------------- +# copyright (C) 2004 Topia . all rights reserved. +package Tiarra::Socket; +use strict; +use warnings; +use Carp; +use Tiarra::Utils; +#use RunLoop; # lazy loading +use Socket; +our $is_winsock = $^O =~ /^MSWin32/; +utils->define_attr_getter(0, qw(sock installed)); +utils->define_attr_accessor(0, qw(name), + map { ["_$_", $_] } + qw(sock installed)); + +sub new { + my ($class, %opts) = @_; + + my $this = { + runloop => $opts{runloop}, + installed => 0, + sock => undef, + name => utils->get_first_defined( + $opts{name}, + utils->simple_caller_formatter( + utils->get_first_defined($opts{_subject}, 'socket').' registered', + ($opts{_caller} || 0))), + }; + if (!defined $this->{runloop}) { + require RunLoop; + } + bless $this, $class; +} + +sub runloop { + my $this = shift; + + utils->get_first_defined($this->{runloop}, RunLoop->shared); +} + +sub attach { + my ($this, $sock) = @_; + + if ($this->installed) { + croak "already installed; can't attach!"; + } + + return undef unless defined $sock; + $sock->autoflush(1); + $this->_sock($sock); + $this; +} + +sub detach { + my $this = shift; + + if (!defined $this->sock) { + croak "already detached; can't detach!"; + } + if ($this->installed) { + carp "installed; anyway detach..."; + $this->uninstall; + } + + $this->_sock(undef); + $this; +} + +sub close { + my $this = shift; + + if (!defined $this->sock) { + croak "already detached; can't close!"; + } + + $this->shutdown(2); + $this->detach; +} + +sub shutdown { + my ($this, $type) = @_; + + if (!defined $this->sock) { + croak "already detached; can't shutdown!"; + } + + $this->sock->shutdown($type); +} + +sub install { + my $this = shift; + + if ($this->installed) { + croak "already installed; module bug?"; + } + + $this->runloop->install_socket($this); + $this->_installed(1); + $this; +} + +sub uninstall { + my $this = shift; + + if (!$this->installed) { + croak "already uninstalled; module bug?"; + } + + $this->runloop->uninstall_socket($this); + $this->_installed(0); + $this; +} + +sub errno { + my $this = shift; + + if (!defined $this->sock) { + croak "already detached; can't fetch errno!"; + } + + my $errno = $this->sock->sockopt(SO_ERROR); + if ($errno == 0 || $errno == -1) { + $errno = undef; + } + return $errno; +} + +sub errmsg { + my $this = shift; + my $errno = $this->errno; + my $msg = undef; + + if (defined $errno) { + $msg = $this->sock_errno_to_msg($errno, @_); + } + if (wantarray) { + ($msg, $errno); + } else { + $msg; + } +} + +sub _should_define { + die 'method should define! ('.shift->name.')'; +} + +sub want_to_write { shift->_should_define } +sub write { shift->_should_define } +sub read { shift->_should_define } +sub exception { shift->_should_define } + +# class method + +sub repr_destination { + my ($class_or_this, %data) = @_; + + if (!defined $data{host} && defined $data{addr}) { + $data{host} = $data{addr}; + delete $data{addr}; + } + if (defined $data{host} && defined $data{addr} && + $data{host} eq $data{addr}) { + delete $data{addr}; + } + + my $str = ''; + my $append_as_delimiter = sub { + $str .= shift if length $str; + }; + $str .= utils->to_str($data{host}); + $str .= "($data{addr})" if defined $data{addr}; + if (defined $data{port}) { + $append_as_delimiter->('/'); + $str .= $data{port}; + } + if (defined $data{type}) { + $append_as_delimiter->(' ('); + $str .= $class_or_this->repr_type($data{type}) . + (length $str ? ')' : ''); + } + $str; +} + +sub repr_type { + my ($class_or_this, $type) = @_; + + if ($type =~ /^ipv(\d+)$/i) { + return "IPv$1"; + } elsif ($type =~ /^unix$/i) { + return "Unix"; + } else { + return "Unknown: $type"; + } +} + +sub probe_type_by_class { + my ($class_or_this, $obj) = @_; + + map { + if (!wantarray) { + return $_->[1]; + } else { + $_->[1]; + } + } grep { + UNIVERSAL::isa($obj, $_->[0]); + } map { + substr($_->[0],0,0) = 'IO::Socket::'; + $_; + } ([qw(INET ipv4)], [qw(INET6 ipv6)], [qw(UNIX unix)]); +} + +sub probe_type_by_addr { + my ($class_or_this, $addr) = @_; + + if ($addr =~ m/^(?:\d+\.){3}\d+$/) { + return 'ipv4'; + } elsif ($addr =~ m/^[0-9a-fA-F:]+$/) { + return 'ipv6'; + } else { + # maybe + return 'unix'; + } + +} + +sub sock_errno_to_msg { + my ($this, $errno, $msg) = @_; + + local $! = $errno; + $errno = ($!+0); + my $errstr = "$!"; + if ($! eq 'Unknown error' && $this->_is_winsock) { + # try probe (for my ActivePerl v5.8.4 build 810) + require Tiarra::Socket::Win32Errno; + my $new_errstr = Tiarra::Socket::Win32Errno->fetch_description($errno); + if (defined $new_errstr) { + $errstr = $new_errstr; + } + } + return ((defined $msg && length $msg) ? ($msg . ': ') : '' ) . + "$errno: $errstr"; +} + +sub _is_winsock { + return $is_winsock; +} + +sub _increment_caller { + my ($class_or_this, $subject, $opts) = @_; + + $opts->{_caller} = ($opts->{_caller} || 0) + 1; + $opts->{_subject} = utils->get_first_defined( + $opts->{_subject}, + $subject); + $opts; +} + +1; + +=pod + +=head1 NAME + +Tiarra::Socket - Tiarra RunLoop based Socket Handler Base Class + +=head1 SYNOPSIS + +=over + +=item use L + + use Tiarra::Socket; + $socket = Tiarra::Socket->new(name => 'sample socket'); + $socket->attach($sock); + $socket->install; + $socket->uninstall; + $socket->shutdown(2); + $socket->detach; + $socket->close; + $errno = $socket->errno; + $msg = $socket->errmsg( [$additional_msg] ); + $type = Tiarra::Socket->probe_type_by_class($sock); + $type = Tiarra::Socket->probe_type_by_addr($addr); + Tiarra::Socket->repr_type( $type ); + Tiarra::Socket->repr_destination( [datas] ); + $is_winsock = Tiarra::Socket->_is_winsock; + $msg = Tiarra::Socket->sock_errno_to_msg($errno[, $additional_msg]); + +=item make subclass of L + + package Tiarra::SomeSocket; + use Tiarra::Socket; + use base qw(Tiarra::Socket); + + sub new { + my ($class, %opts) = @_; + + $class->_increment_caller('some-socket', \%opts); + my $this = $class->SUPER::new(%opts); + $this; + } + # some overrides and implements... + +=back + +=head1 DESCRIPTION + +L provides RunLoop based event driven Socket I/O interface. + +=head1 CONSTRUCTOR + +=over + +=item C<< $socket = new( [OPTS] ) >> + +opts is options hash. +parametors: + + runloop Tiarra RunLoop + name Socket name for pretty-print + +=back + +=head1 METHODS + +=over + +=item C<< ->runloop >> + +return default runloop or specified runloop + +=item C<< ->attach >> + +attach sock to socket + +=item C<< ->detach >> + +detach sock from socket + +=item C<< ->close >> + +shutdown and detach socket + +=item C<< ->shutdown( HOW ) >> + +call shutdown for this socket. + +=item C<< ->install >> + +install socket to runloop + +=item C<< ->uninstall >> + +uninstall socket from runloop + +=item C<< ->sock >> + +return sock attached to socket + +=item C<< ->installed >> + +return true if socket installed to runloop + +=item C<< ->errno >> + +return socket errno with sockopt(and clear status). +if errno not set, return undef. + +=item C<< ->errmsg( [MESSAGE] ) >> + +return socket error message with msg. +on array context, return $errno as 2nd item, also. + +(implement likes +C<< $this->sock_errno_to_msg($this->errno, [MESSAGE] ) >>.) + +=back + +=head1 CLASS METHODS + +=over + +=item C<< ->repr_destination( [DATAS] ) >> + +representation destination with DATAS hash. +currently supported hash key: + +=over + +=item host + +hostname(maybe FQDN). + +=item addr + +Address(IPv[46] Address). + +=item port + +Port or UNIX Domain Socket path. + +=item type + +Socket type. try repr inside, you haven't necessary call C<< ->repr_type >>. + +=back + +=item C<< ->repr_type( TYPE ) >> + +Simple Pretty-printing type. such as: + + ipv4 -> IPv4 + ipv6 -> IPv6 + unix -> Unix + +=item C<< ->probe_type_by_class( CLASS_OR_OBJECT ) >> + +Probe type by class or object. + +=item C<< ->probe_type_by_addr( ADDRESS ) >> + +Probe type by address. + +=item C<< ->sock_errno_to_msg( ERRNO[, MESSAGE] ) >> + +representation sock errno and message. + +=back + +=head1 METHODS OF PLEASE OVERRIDE BY SUBCLASS + +=over + +=item C<< ->want_to_write >> + +return true(1) on want to write(write buffer has data) + +=item C<< ->write >> + +called when select notified this socket is writable. + +=item C<< ->read >> + +called when select notified this socket is readable. + +=item C<< ->exception >> + +called when select notified this socket has exception. + +=back + +=head1 SEE ALSO + +L: socket connector. + +L, L: reader/writer. + +L: Win32 errno database. + +=head1 COPYRIGHT AND DISCLAIMERS + +Copyright (c) 2004 Topia. All rights reserved. + +This library is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +This program is distributed in the hope that it will be useful, but +without any warranty; without even the implied warranty of +merchantability or fitness for a particular purpose. + +=head1 AUTHOR + +Topia, and originally developed by phonohawk. + +=cut diff -urN /non-existant-dir/main/Tiarra/TerminateManager.pm tiarra-20080510/main/Tiarra/TerminateManager.pm --- /non-existant-dir/main/Tiarra/TerminateManager.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/main/Tiarra/TerminateManager.pm 2008-05-11 00:25:24.000000000 +0900 @@ -0,0 +1,45 @@ +# ----------------------------------------------------------------------------- +# $Id: TerminateManager.pm 3004 2007-12-10 12:45:39Z topia $ +# ----------------------------------------------------------------------------- +# Terminate Hook for write Portable Module +# ----------------------------------------------------------------------------- +# copyright (C) 2004 Topia . all rights reserved. +package Tiarra::TerminateManager; +use strict; +use warnings; +use Carp; +use Hook; +use base qw(HookTarget); +use Tiarra::SharedMixin; + +sub _new { + my $class = shift; + + my $this = {}; + bless $this, $class; + $this; +} + +sub terminate { + my ($class_or_this, $name) = @_; + my $this = $class_or_this->_this; + + $this->call_hooks($name); +} + +package Tiarra::TerminateManager::Hook; +use FunctionalVariable; +use Hook; +use base qw(Hook); +our $HOOK_TARGET_NAME = 'Tiarra::TerminateManager'; +our @HOOK_NAME_CANDIDATES = qw(main); +our $HOOK_NAME_DEFAULT = 'main'; +our $HOOK_TARGET_DEFAULT; +FunctionalVariable::tie( + \$HOOK_TARGET_DEFAULT, + FETCH => sub { + $HOOK_TARGET_NAME->shared; + }, + ); + +1; diff -urN /non-existant-dir/main/Tiarra/Utils/CallWrapper.pm tiarra-20080510/main/Tiarra/Utils/CallWrapper.pm --- /non-existant-dir/main/Tiarra/Utils/CallWrapper.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/main/Tiarra/Utils/CallWrapper.pm 2008-05-11 00:25:24.000000000 +0900 @@ -0,0 +1,251 @@ +# ----------------------------------------------------------------------------- +# $Id: CallWrapper.pm 3004 2007-12-10 12:45:39Z topia $ +# ----------------------------------------------------------------------------- +# Call Wrapping Helper +# ----------------------------------------------------------------------------- +# copyright (C) 2004-2005 Topia . all rights reserved. +package Tiarra::Utils::CallWrapper; +use strict; +use warnings; +use Carp; +use base qw(Tiarra::Utils::Core); + +=head1 NAME + +Tiarra::Utils::CallWrapper - Tiarra misc Utility Functions: Call Wrappers + +=head1 SYNOPSIS + + use Tiarra::Utils; # import master + utils->do_with_ensure(..., ...); + +=head1 DESCRIPTION + +Tiarra::Utils is misc helper functions class. this class is implement call +wrapping helpers. + +class splitting is maintainer issue only. please require/use Tiarra::Utils. + +=head1 METHODS + +=over 4 + +=cut + +sub _wantarray_to_type { + shift; # drop + + grep { + if (!wantarray) { + return $_; + } else { + 1; + } + } map { + if (!defined $_) { + 'void'; + } elsif (!$_) { + 'scalar'; + } else { + 'list'; + } + } @_; +} + +=item call_with_wantarray + + utils->call_with_wantarray(wantarray, $closure, @args); + +call closure with wantarray value of you want. + +=over 4 + +=item * wantarray + +wantarray value at context. + +=item * $closure + +closure of want to call. + +=item * @args + +args to call closure. + +=back + +=cut + +sub call_with_wantarray { + my $pkg = shift; + my ($wantarray, $closure, @args) = @_; + my $type = $pkg->_wantarray_to_type($wantarray); + + if ($type eq 'void') { + # void context + $closure->(@args); + return undef; + } elsif ($type eq 'scalar') { + # scalar context + my $ret = $closure->(@args); + return $ret; + } elsif ($type eq 'list') { + # list context + my $ret = [$closure->(@args)]; + return @$ret; + } else { + croak "unsupported wantarray type: $type"; + } +} + +=item do_with_ensure + + utils->do_with_ensure($closure, $ensure, @args); + +call closure with ensure feature. + +=over 4 + +=item * $closure + +closure of want to call. + +=item * $ensure + +ensure closure (call on return/exit from this function). + +=item * @args + +args to call closure. + +=back + +=cut + +sub do_with_ensure { + my $pkg = shift; + my ($closure, $ensure, @args) = @_; + my $cleaner = Tiarra::Utils::CallWrapper::EnsureCleaner->new($ensure); + $closure->(@args); +} + +=item sighandler_or_default + + utils->sighandler_or_default($name[, $func]); + +return coderef of current signal handler. + +=cut + +sub sighandler_or_default { + my ($pkg, $name, $func) = @_; + + $name = "__\U$name\E__" if $name =~ /^(die|warn)$/i; + if (!defined $func) { + if ($name =~ /^__(DIE|WARN)__$/) { + no strict 'refs'; + $func = \&{"__real_\L$1\E"}; + } + } + + my $value = $SIG{$name}; + $value = $func if !defined $value || length($value) == 0 || + $value =~ /^DEFAULT$/i; + if (ref($value) ne 'CODE') { + no strict 'refs'; + $value = \&{$value}; + } + $value; +} + +sub __real_die { die @_ } +sub __real_warn { warn @_ } + +=item do_with_errmsg + + utils->do_with_errmsg($name, $closure, @args); + +call closure with adding "inside foo" annotation to error message. + +=over 4 + +=item * $name + +subject (such as "Timer: foo timer"). + +=item * $closure + +closure of want to call. + +=item * @args + +args to call closure. + +=back + +=cut + +sub do_with_errmsg { + my $pkg = shift; + my ($name, $closure, @args) = @_; + + my $str = " inside $name;\n"; + do { + no strict 'refs'; + local ($SIG{__WARN__}, $SIG{__DIE__}) = + (map { + my $signame = "__\U$_\E__"; + my $handler = $pkg->sighandler_or_default($_); + sub { + my $msg = shift; + if (!ref($msg)) { + $handler->(($msg).$str); + } else { + #FIXME... + $handler->($msg); + } + }; + } qw(warn die)); + + $closure->(@args); + }; +} + +package Tiarra::Utils::CallWrapper::EnsureCleaner; +use strict; +use warnings; +use base qw(Tiarra::Utils::CallWrapper); + +sub new { + my ($class, $closure) = @_; + bless $closure, $class; +} + +sub DESTROY { + my $this = shift; + local $@; # FIXME: we can't know ensure _die_... + $this->do_with_errmsg('ensure', $this); +} + +1; + +__END__ +=back + +=head1 SEE ALSO + +L + +=head1 AUTHOR + +Topia Etopia@clovery.jpE + +=head1 COPYRIGHT AND LICENSE + +Copyright (C) 2005 by Topia. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself, either Perl version 5.8.6 or, +at your option, any later version of Perl 5 you may have available. + +=cut diff -urN /non-existant-dir/main/Tiarra/Utils/Core.pm tiarra-20080510/main/Tiarra/Utils/Core.pm --- /non-existant-dir/main/Tiarra/Utils/Core.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/main/Tiarra/Utils/Core.pm 2008-05-11 00:25:24.000000000 +0900 @@ -0,0 +1,74 @@ +# ----------------------------------------------------------------------------- +# $Id: Core.pm 3004 2007-12-10 12:45:39Z topia $ +# ----------------------------------------------------------------------------- +# Tiarra::Utils Core feature +# ----------------------------------------------------------------------------- +# copyright (C) 2004 Topia . all rights reserved. +package Tiarra::Utils::Core; +use strict; +use warnings; + +=head1 NAME + +Tiarra::Utils::Core - Tiarra misc Utility Functions: Core + +=head1 SYNOPSIS + + use Tiarra::Utils; # import master + +=head1 DESCRIPTION + +Tiarra::Utils is misc helper functions class. this class is implement core. + +class splitting is maintainer issue only. please require/use Tiarra::Utils. + +=head1 METHODS + +=over 4 + +=cut + +=item _this + + foopkg->_this + +return shared object(singleton) if ->shared method defined and called as class method. +otherwise(called as object method, or non-singleton class) return $this self. + +=cut + +sub _this { + my $class_or_this = shift; + + if (!ref($class_or_this)) { + if ($class_or_this->can('shared')) { + # fetch shared + $class_or_this = $class_or_this->shared; + } + } + + return $class_or_this; +} + +1; + +__END__ +=back + +=head1 SEE ALSO + +L + +=head1 AUTHOR + +Topia Etopia@clovery.jpE + +=head1 COPYRIGHT AND LICENSE + +Copyright (C) 2005 by Topia. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself, either Perl version 5.8.6 or, +at your option, any later version of Perl 5 you may have available. + +=cut diff -urN /non-existant-dir/main/Tiarra/Utils/DefineHelper.pm tiarra-20080510/main/Tiarra/Utils/DefineHelper.pm --- /non-existant-dir/main/Tiarra/Utils/DefineHelper.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/main/Tiarra/Utils/DefineHelper.pm 2008-05-11 00:25:24.000000000 +0900 @@ -0,0 +1,474 @@ +# ----------------------------------------------------------------------------- +# $Id: DefineHelper.pm 11254 2008-05-07 15:25:16Z topia $ +# ----------------------------------------------------------------------------- +# Define Helper Utilities +# ----------------------------------------------------------------------------- +# copyright (C) 2004-2005 Topia . all rights reserved. +package Tiarra::Utils::DefineHelper; +use strict; +use warnings; +use base qw(Tiarra::Utils::Core); +our $ExportLevel = 0; + +# please do { +# Tiarra::Utils::DefineHelper->do_with_define_exportlevel( +# 0, +# sub { +# Tiarra::Utils::DefineHelper->define_enum(qw(...)); +# }); +# in define_*s' wrapper function. + + +=head1 NAME + +Tiarra::Utils::DefineHelper - Tiarra misc Utility Functions: Define Helper + +=head1 SYNOPSIS + + use Tiarra::Utils; # import master + +=head1 DESCRIPTION + +Tiarra::Utils is misc helper functions class. this class is implement define +helpers. (accessors, proxys, ...) + +class splitting is maintainer issue only. please require/use Tiarra::Utils. + +all function is class method; please use package->method(...); + +maybe all functions can use with utils->... + +=head1 METHODS + +=over 4 + +=cut + +=item define_function + + utils->define_function($package, $code, @funcnames) + +define function with some package, code, funcnames. + +=over 4 + +=item * $package + +package name. such as C<< utils->get_package($some_level) >>. + +=item * $code + +coderef(closure) of function. such as C<< sub { shift->foo_func('bar') } >>. + +=item * @funcnames + +function names to define. + +=back + +=cut + +sub define_function { + shift; #package + my $package = shift; + my $code = shift; + my $funcname; + no strict 'refs'; + no warnings qw(redefine prototype); + foreach (@_) { + $funcname = $package.'::'.$_; + #undef *{$funcname}; + *{$funcname} = $code; + } + undef; +} + +sub _parse_attr_define { + shift; # drop + shift; # drop + my $value = shift; + + if (ref($value) eq 'ARRAY') { + $value; + } else { + [$value, $value]; + } +} + +sub _define_attr_common { + my $pkg = shift; + my $type = shift; + my $class_method_p = shift; + my $call_pkg = $pkg->get_package(1); + foreach (@_) { + my ($funcname, $valname) = @{$pkg->_parse_attr_define($call_pkg, $_)}; + $pkg->define_function( + $call_pkg, + $pkg->_generate_attr_closure($class_method_p, $type, + "{$valname}", $funcname), + $funcname); + } + undef; +} + +=item define_attr_accessor + + utils->define_attr_accessor($class_method_p, @defines) + +define attribute accessor. + +=over 4 + +=item * $class_method_p + +these accessor is called as class method, pass true; otherwise false. + +=item * @defines + +accessor defines array. + +=over 4 + +=item * scalar value ($valname) + +define ->$valname for accessor of ->{$valname}. + +=item * array ref value ([$funcname, $valname]) + +define ->$funcname for accessor of ->{$valname}. + +=back + +=back + +=cut + +sub define_attr_accessor { + shift->_define_attr_common('accessor', @_); +} + +=item define_attr_getter + + utils->define_attr_getter($class_method_p, @defines) + +define attribute getter. + +all params is same as L, except s/accessor/getter/. + +=cut + +sub define_attr_getter { + shift->_define_attr_common('getter', @_); +} + +sub _define_attr_hook_common { + my $pkg = shift; + my $type = shift; + my $class_method_p = shift; + my $hook = shift; + my $call_pkg = $pkg->get_package(1); + foreach (@_) { + my ($funcname, $valname) = @{$pkg->_parse_attr_define($call_pkg, $_)}; + $pkg->define_function( + $call_pkg, + $pkg->_generate_attr_hooked_closure($class_method_p, $type, + "{$valname}", $hook, $funcname), + $funcname); + } + undef; +} + +sub _define_attr_translate_accessor { + shift->_define_attr_hook_common('translate', @_); +} + +sub _define_attr_notify_accessor { + shift->_define_attr_hook_common('notify', @_); +} + +sub _parse_array_attr_define { + shift; # drop + my $call_pkg = shift; + + my $value = shift; + if (ref($value) eq 'ARRAY') { + $value; + } else { + my $funcname = $value; + my $index = uc($funcname); + $index = $call_pkg->$index; + [$funcname, $index]; + } +} + +sub _define_array_attr_common { + my $pkg = shift; + my $type = shift; + my $class_method_p = shift; + my $call_pkg = $pkg->get_package(1); + foreach (@_) { + my ($funcname, $index) = + @{$pkg->_parse_array_attr_define($call_pkg, $_)}; + $pkg->define_function( + $call_pkg, + $pkg->_generate_attr_closure($class_method_p, $type, + "[$index]", $funcname), + $funcname); + } + undef; +} + +=item define_array_attr_accessor + + utils->define_attr_accessor($class_method_p, @defines) + +define attribute accessor for array type object. + +=over 4 + +=item * $class_method_p + +these accessor is called as class method, pass true; otherwise false. + +=item * @defines + +accessor defines array. + +=over 4 + +=item * scalar value (value) + +define ->value for accessor of ->[VALUE]. + +example: ->define_attr + +=item * array ref value ([$funcname, $valname]) + +define ->$funcname for accessor of ->{$valname}. + +=back + +=back + +=cut + +sub define_array_attr_accessor { + shift->_define_array_attr_common('accessor', @_); +} + +sub define_array_attr_getter { + shift->_define_array_attr_common('getter', @_); +} + +sub _define_array_attr_hook_common { + my $pkg = shift; + my $type = shift; + my $class_method_p = shift; + my $hook = shift; + my $call_pkg = $pkg->get_package(1); + foreach (@_) { + my ($funcname, $index) = + @{$pkg->_parse_array_attr_define($call_pkg, $_)}; + $pkg->define_function( + $call_pkg, + $pkg->_generate_attr_hooked_closure($class_method_p, $type, + "[$index]", $hook, $funcname), + $funcname); + } + undef; +} + +sub define_array_attr_translate_accessor { + shift->_define_array_attr_hook_common('translate', @_); +} + +sub define_array_attr_notify_accessor { + shift->_define_array_attr_hook_common('notify', @_); +} + +sub define_attr_enum_accessor { + my $pkg = shift; + my $attr_name = shift; + my $match_type = shift || 'eq'; + foreach (@_) { + my ($funcname, $value); + if (ref($_) eq 'ARRAY') { + $funcname = $_->[0]; + $value = $_->[1]; + } else { + $funcname = $attr_name . '_' . $_; + $value = $_; + } + $pkg->define_function( + $pkg->get_package, + eval '(sub { + my $this = shift; + $this->$attr_name($value) if defined shift; + $this->$attr_name '.$match_type.' $value; + })', + $funcname); + } +} + +sub define_proxy { + my $pkg = shift; + my $proxy_target_funcname = shift; + my $class_method_p = shift; + foreach (@_) { + my ($funcname, $proxyname); + if (ref($_) eq 'ARRAY') { + $funcname = $_->[0]; + $proxyname = $_->[1]; + } else { + $funcname = $proxyname = $_; + } + $pkg->define_function( + $pkg->get_package, + ($class_method_p ? sub { + shift->_this->$proxy_target_funcname->$proxyname(@_); + } : sub { + shift->$proxy_target_funcname->$proxyname(@_); + }), + $funcname); + } +} + +sub define_enum { + # this function is deprecated. + # please use enum.pm instead. + my $pkg = shift; + my $i = 0; + foreach (@_) { + my (@funcnames); + if (ref($_) eq 'ARRAY') { + @funcnames = @$_; + } else { + @funcnames = $_; + } + $pkg->define_function( + $pkg->get_package, + sub () { $i; }, + @funcnames); + ++$i; + } +} + +sub get_package { + my $pkg = shift; + my $caller_level = shift || 0; + ($pkg->get_caller($caller_level + 1))[0]; +} + +sub get_caller { + my $pkg = shift; + my $caller_level = shift || 0; + caller($caller_level + 1 + $ExportLevel); +} + +sub do_with_define_exportlevel { + my $pkg = shift; + my $level = shift || 0; + + local $ExportLevel; + $ExportLevel += 3 + $level; + shift->(@_); +} + + +# generator +sub _generate_attr_closure { + my $pkg = shift; + my $class_method_p = shift; + my $type = shift; + my $attr = shift; + my $funcname = shift; + # outside parentheses for context + my $str = join('', + "\n# line 1 \"", + (defined $funcname ? "->$funcname\: " : ''), + "attr $type\"\n", + '(sub', + ({ + accessor => ' : lvalue', + getter => '', + }->{$type}), + ' {', + ' die "too many args: @_" if $#_ >= ', + ({ + accessor => '2', + getter => '1', + }->{$type}), + ';', + ({ + accessor => ' my $this = shift', + getter => ' shift', + }->{$type}), + ($class_method_p ? '->_this' : ''), + ({ + accessor => "; \$this->$attr = shift if \$#_ >= 0; \$this", + getter => '', + }->{$type}), + "->$attr;", + ' })'); + no strict 'refs'; + no warnings; + eval $str || + (print STDERR __PACKAGE__."/generator error: \n$str\n$@", undef); +} + +sub _generate_attr_hooked_closure { + my $pkg = shift; + my $class_method_p = shift; + my $type = shift; + my $attr = shift; + my $update_hook = shift; + my $funcname = shift; + # outside parentheses for context + my $str = join('', + "\n# line 1 \"", + (defined $funcname ? "->$funcname\: " : ''), + "attr $type\"\n", + '(sub {', + ' die "too many args: @_" if $#_ >= 2;', + ' my $this = shift', + ($class_method_p ? '->_this' : ''), + ';', + ' if ($#_ >=0) {', + (sub { + if ($type eq 'translate') { + ' '.$update_hook->('shift', "\$this->$attr"); + } elsif ($type eq 'notify') { + " \$this->$attr = shift; $update_hook;"; + } + }->($type)), + ' }', + " \$this->$attr;", + ' })'); + no strict 'refs'; + no warnings; + eval $str || + (print STDERR __PACKAGE__."/generator error: \n$str\n$@", undef); +} + +1; + +__END__ +=back + +=head1 SEE ALSO + +L + +=head1 AUTHOR + +Topia Etopia@clovery.jpE + +=head1 COPYRIGHT AND LICENSE + +Copyright (C) 2005 by Topia. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself, either Perl version 5.8.6 or, +at your option, any later version of Perl 5 you may have available. + +=cut diff -urN /non-existant-dir/main/Tiarra/Utils.pm tiarra-20080510/main/Tiarra/Utils.pm --- /non-existant-dir/main/Tiarra/Utils.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/main/Tiarra/Utils.pm 2008-05-11 00:25:24.000000000 +0900 @@ -0,0 +1,196 @@ +# ----------------------------------------------------------------------------- +# $Id: Utils.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +# Misc Utilities +# ----------------------------------------------------------------------------- +# copyright (C) 2004-2005 Topia . all rights reserved. +package Tiarra::Utils; +use strict; +use warnings; +use Carp; +use List::Util qw(first); +use base qw(Tiarra::Utils::Core); +use base qw(Tiarra::Utils::DefineHelper); +use base qw(Tiarra::Utils::CallWrapper); +use base qw(Exporter); +our @EXPORT = qw(utils); + +=head1 NAME + +Tiarra::Utils - Tiarra misc Utility Functions + +=head1 SYNOPSIS + + use Tiarra::Utils; # import utils + utils->get_first_defined(..., ...); + +=head1 DESCRIPTION + +miscellaneous helper functions. + +this class inherited some classes'(L, +L, L) methods. +so please refer these classes' documents. + +=head1 METHODS + +=over 4 + +=cut + +=item utils + + use Tiarra::Utils; + utils->foo_method; + +default export function for shorthand use of Tiarra::Utils functions. + +=cut + +sub utils { + __PACKAGE__->_this; +} + +=item simple_caller_formatter + + utils->simple_caller_formatter([$msg[, $caller_level]]); + +format " at line " style caller information. + +=over 4 + +=item * $msg + +subject of caller information. default is 'called'. + +=item * $caller_level + +caller level to dig. default is 0(caller of your function). + +=back + +=cut + +sub simple_caller_formatter { + my $pkg = shift; + my $msg = $pkg->get_first_defined(shift, 'called'); + my $caller_level = shift || 0; + + sprintf('%s at %s line %s', $msg, + ($pkg->get_caller($caller_level + 1))[1,2]); +} + +=item cond_yesno + + utils->cond_yesno($value[, $default]); + +check yes-or-no style condition. + +return true on yes(or 1, true, and so on), +false on no(or 0, false, and so on). + +if $value is undefined, return $default. + +=cut + +sub cond_yesno { + shift; # drop + my ($value, $default) = @_; + + return $default unless defined $value; + return 0 if $value =~ /[fn]/i; # false/no + return 1 if $value =~ /[ty]/i; # true/yes + return 1 if $value; # 数値判定 + return 0; +} + +=item to_str + + utils->to_str(@strings); + +stringify without undefined warning. + +=cut + +sub to_str { + shift; # drop + # undef(and so on) to str without warning + no warnings 'uninitialized'; + grep { + if (!wantarray) { + return $_; + } else { + 1; + } + } map { + "$_" + } @_; +} + +=item get_first_defined + + utils->get_first_defined(@values); + +(deprecated): return first defined value. + +this function is deprecated; please use +C<< List::Util::first { defined } @values >> instead. + +=cut + +sub get_first_defined { + shift; # drop + first { defined } @_; +} + +=item to_ordinal_number + + utils->to_ordinal_number($int); + +format number to ordinal number. + +=cut + +sub to_ordinal_number { + shift; # drop + grep { + if (!wantarray) { + return $_; + } else { + 1; + } + } map { + if (/1$/) { + $_ . 'st'; + } elsif (/(?:[^1]|^)([23])$/) { + $_ . ($2 eq '2' ? 'nd' : 'rd'); + } else { + $_ . 'th'; + } + } @_; +} + +1; + +__END__ +=back + +=head1 SEE ALSO + +L, +L, +L + +=head1 AUTHOR + +Topia Etopia@clovery.jpE + +=head1 COPYRIGHT AND LICENSE + +Copyright (C) 2005 by Topia. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself, either Perl version 5.8.6 or, +at your option, any later version of Perl 5 you may have available. + +=cut diff -urN /non-existant-dir/main/Tiarra/WrapMainLoop.pm tiarra-20080510/main/Tiarra/WrapMainLoop.pm --- /non-existant-dir/main/Tiarra/WrapMainLoop.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/main/Tiarra/WrapMainLoop.pm 2008-05-11 00:25:24.000000000 +0900 @@ -0,0 +1,142 @@ +# ----------------------------------------------------------------------------- +# $Id: WrapMainLoop.pm 10975 2008-05-02 16:09:53Z topia $ +# ----------------------------------------------------------------------------- +# MainLoop wrapper for write Portable Module +# ----------------------------------------------------------------------------- +# copyright (C) 2004 Topia . all rights reserved. +package Tiarra::WrapMainLoop; +use strict; +use warnings; +use Carp; +use Tiarra::Utils; +utils->define_attr_accessor(0, + qw(installed name), + map { ["_$_", $_] } + qw(closure type interval object)); + +# lazy load +#use RunLoop; +#use Timer; + +sub new { + my ($class, %opt) = @_; + + my $this = { + installed => 0, + interval => 5, + }; + bless $this, $class; + $this->type(utils->get_first_defined($opt{type}, 'timer')); + $this->interval($opt{interval}); + $this->_closure(utils->get_first_defined($opt{closure}, undef)); + $this->name(utils->get_first_defined( + $opt{name}, + utils->simple_caller_formatter('wrapmainloop registered'))); + $this; +} + +sub _check_uninstalled { + my $this = shift; + + croak "hook/timer installed; before uninstall this." + if $this->installed; +} + +sub _check_installed { + my $this = shift; + + croak "hook/timer uninstalled; before install this." + unless $this->installed; +} + +sub type { + my ($this, $value) = @_; + + $this->_check_uninstalled; + if (defined $value) { + croak "unsupported mainloop type: $value." + if (!scalar(grep { $value eq $_; } qw(timer mainloop))); + $this->_type($value); + } + $this->_type; +} + +sub interval { + my ($this, $value, $option) = @_; + + if (defined $value) { + if ($this->_type eq 'timer') { + if ($value < 1 && + !(defined $option && $option eq 'permit_toofast')) { + croak "interval is too fast! if without program bug, ". + "pass 'permit_toofast' option."; + } + $this->_interval($value); + $this->_object->interval($value) if ($this->installed); + } elsif ($this->_type eq 'mainloop') { + croak "interval is not used in this type; fix code."; + } else { + die 'internal error! unknown type('.$this->_type.').'; + } + } + $this->_interval; +} + +sub install { + my $this = shift; + $this->_check_uninstalled; + $this->_install; +} + +sub uninstall { + my $this = shift; + $this->_check_installed; + $this->_uninstall; +} + +sub lazy_install { + my $this = shift; + $this->_install unless $this->installed; +} + +sub lazy_uninstall { + my $this = shift; + $this->_uninstall if $this->installed; +} + +sub _install { + my $this = shift; + croak "closure is not defined;" + unless defined $this->_closure; + if ($this->_type eq 'timer') { + if (require Timer) { + $this->_object(Timer->new( + Name => 'WrapMainLoop: '.$this->name, + Repeat => 1, + Interval => $this->_interval, + Code => $this->_closure)->install); + } else { + die 'Timer cannot load'; + } + } elsif ($this->_type eq 'mainloop') { + if (require RunLoop) { + $this->_object(RunLoop::Hook->new($this->_closure)->install('after-select')); + } else { + die 'RunLoop cannot load'; + } + } else { + die 'internal error! unknown type('.$this->_type.').'; + } + $this->installed(1); + $this; +} + +sub _uninstall { + my $this = shift; + $this->_object->uninstall; + $this->_object(undef); + $this->installed(0); + $this; +} + +1; diff -urN /non-existant-dir/main/TiarraDoc.pm tiarra-20080510/main/TiarraDoc.pm --- /non-existant-dir/main/TiarraDoc.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/main/TiarraDoc.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,449 @@ +# ------------------------------------------------------------------------ +# $Id: TiarraDoc.pm 11365 2008-05-10 14:58:28Z topia $ +# ------------------------------------------------------------------------ +# tiarra-docのパーサとトランスレータ群。 +# ------------------------------------------------------------------------ +use strict; +use warnings; +use Tiarra::Encoding; +use IO::File; + +package DocParser; +use Carp; + +sub new { + my ($class,$fpath) = @_; + my $this = { + fpath => $fpath, + + docs => undef, # {パッケージ名 => DocPod} + }; + bless $this,$class; +} + +sub makeconf { + # confのブロックを生成する。 + # 戻り値: ([ブロック名,info,ブロック(文字列)],...) + # スカラーコンテクストで呼ぶとcroak。 + croak "You can't call DocParser->makeconf directly."; +} + +sub makehtml { + croak "You can't call DocParser->makehtml directly."; +} + +sub getdoc { + # パッケージ名を省略すると、要素が一つであればそれを返し、 + # 複数あればcroakする。一つも無ければundefを返す。 + my ($this,$pkg_name) = @_; + + if (!defined $this->{docs}) { + $this->{docs} = {}; + my @dummy = $this->_parse_docpod; + } + + if (defined $pkg_name) { + $this->{docs}{$pkg_name}; + } + else { + my @keys = keys %{$this->{docs}}; + if (@keys == 0) { + undef; + } + elsif (@keys == 1) { + $this->{docs}{$keys[0]}; + } + else { + croak "You can't ommit \$pkg_name if there's multiple poddocs."; + } + } +} + +sub _parse_docpod { + # tiarraドキュメント形式のpodを探してヘッダをパースして返す。 + # 同一パッケージにドキュメントが二つ以上あったらdie。 + # スカラーコンテクストで呼ばれたらcroak。 + # 戻り値の形式: (DocPod,DocPod,...) + croak "Don't call DocParser->_parse_docpod in scalar context." if !wantarray; + my $this = shift; + my @pods = $this->_parse_pod; + my $header_re = qr/^\s*(.+?)\s*:\s*(.+)$/; + + my @result; + my $new_doc = sub { + my ($pkg_name,$header,$remaining) = @_; + # 既にこのパッケージのドキュメントが用意されていないか？ + foreach (@result) { + if ($_->pkg_name eq $pkg_name) { + die "$pkg_name has multiple documents.\n"; + } + } + + my $docpod = DocPod->new($pkg_name,$header,$remaining); + push @result,$docpod; + $this->{docs}{$pkg_name} = $docpod; + }; + + foreach my $pod (@pods) { + my @lines = split /\x0a/,$pod->[1]; + if (@lines == 0) { + next; # これはドキュメントでない。 + } + elsif ($lines[0] =~ m/$header_re/) { + # ヘッダの終わりまでをパースする。 + my $header = {}; + my $remaining_start = @lines; + foreach (my $i = 0; $i < @lines; $i++) { + if ($lines[$i] =~ m/$header_re/) { + $header->{$1} = $2; + } + else { + # ここでヘッダ終わり。 + $remaining_start = $i; + last; + } + } + + # 全ての行について、先頭と末尾の空白を消去する。 + (my $remaining = join "\n",map { + s/^\s*|\s*$//g; + $_; + } @lines[$remaining_start .. (@lines-1)]) =~ s/^\s*|\s*$//g; + $new_doc->($pod->[0],$header,$remaining); + } + # ヘッダがなければ tiarra-doc じゃないとみなしてskip. + } + + @result; +} + +sub _parse_pod { + # =podと=cutに囲まれた範囲を返す。 + # 戻り値: ([パッケージ名,pod範囲],[パッケージ名,pod範囲],...) + # スカラーコンテクストで呼ばれたらcroak。 + croak "Don't call DocParser->_parse_pod in scalar context." if !wantarray; + my $this = shift; + my @lines = split /\x0d?\x0a/,$this->_get_content; + + my @result; + my $search_start_pos = 0; + my $pkg_name; + while (1) { + # =podを探す + my $found_type; + my $found_pod_line; + for (my $i = $search_start_pos; $i < @lines; $i++) { + if ($lines[$i] =~ m/^=for\s+tiarra-doc(?:\s|$)/) { + $found_type = '=for'; + $found_pod_line = $i; + last; + } + if ($lines[$i] =~ m/^=begin\s+tiarra-doc(?:\s|$)/) { + $found_type = '=begin'; + while( $i+1 <= $#lines && $lines[$i+1] =~ /^\s*$/ ) + { + # 続く空白行は取り除いておく. + $i += 1; + } + $found_pod_line = $i; + last; + } + if ($lines[$i] =~ m/^\s*=pod\s*$/) { + $found_type = '=pod'; # old style. + $found_pod_line = $i; + last; + } + elsif ($lines[$i] =~ m/\s*package\s+(.+?);/) { + $pkg_name = $1; + } + } + + if( !$found_type ) + { + # 無い。ここで終わり。 + last; + } + + my $found_cut_line; + my $terminate_type; + if( $found_type eq '=for' ) + { + # 次の空行(若しくはコマンド行？)まで. + $terminate_type = 'blank line'; + for (my $i = $found_pod_line+1; $i < @lines; $i++) { + if ($lines[$i] =~ m/^(?:\s*|=)$/) { + $found_cut_line = $i; + last; + } + } + } + if( $found_type eq '=begin' ) + { + # 次の=endまで. + $terminate_type = '=end'; + for (my $i = $found_pod_line+1; $i < @lines; $i++) { + if ($lines[$i] =~ m/^=end\s+tiarra-doc(?:\s|$)/) { + $found_cut_line = $i; + last; + } + } + } + if( $found_type eq '=pod' ) + { + # =cutまで. + $terminate_type = '=cut'; + for (my $i = $found_pod_line+1; $i < @lines; $i++) { + if ($lines[$i] =~ m/^\s*=cut\s*$/) { + $found_cut_line = $i; + last; + } + } + } + if( !$found_cut_line ) + { + # 終端が無い。エラー。 + die "$this->{fpath} has unbalanced $found_type and $terminate_type\n"; + } + # あった。ここまでを切り出し。 + push @result,[ + $pkg_name, + join("\n",@lines[$found_pod_line+1 .. $found_cut_line-1]) + ]; + $search_start_pos = $found_cut_line+1; + } + + @result; +} + +sub _get_content { + # ファイルの中身をutf8で返す。 + my $this = shift; + + my $fh = IO::File->new($this->{fpath},'r'); + if (!defined $fh) { + die "Couldn't open file $this->{fpath}.\n"; + } + local $/ = undef; + my $content = <$fh>; + $fh->close; + + my $code = $this->_getcode($content); + if ($code eq 'unknown') { + die "Couldn't determine the charset of $this->{fpath}.\n"; + } + + Tiarra::Encoding->new($content,$code)->utf8; +} + +sub _getcode { + # 文字コードを判別する。 + my ($this,$content) = @_; + my $unijp = Tiarra::Encoding->new; + + if ((my $code = $unijp->getcode($content)) ne 'unknown') { + # 判別できたら、これを返す。 + $code; + } + else { + # それぞれの行についてgetcodeを実行し、多数決を取る。 + my $total_for_each = {}; + foreach (split /[\r\n]/,$content) { + if ((my $c = $unijp->getcode($_)) ne 'unknown') { + $total_for_each->{$c} = ($total_for_each->{$c} || 0) + 1; + } + } + + my @rank = map { + $_->[0]; + } sort { + $b->[1] <=> $a->[1]; + } map { + [$_, $total_for_each->{$_}]; + } keys %$total_for_each; + if (@rank == 0) { + # 全部unknownだった! + # 仕方無いのでunknownを返す。 + 'unknown'; + } + elsif (@rank == 1) { + # 候補が一つだけ。これを返す。 + $rank[0]; + } + else { + # 候補のトップがasciiだったら、二番目のものを返す。 + # そうでなければトップを返す。 + if ($rank[0] eq 'ascii') { + $rank[1]; + } + else { + $rank[0]; + } + } + } +} + +package DocParser::Module; +use base qw/DocParser/; +use Carp; + +sub new { + my $class = shift; + $class->SUPER::new(@_); +} + +sub makeconf { + my $this = shift; + my $indent_level = shift || 2; + croak "Don't call DocParser->makeconf in scalar context." if !wantarray; + + map { + my $pod = $_; + my $conf = eval { + $this->_makeconf($pod,$indent_level); + }; if ($@) { + die $pod->pkg_name.": $@"; + } + [$pod->pkg_name,$pod->header->{info},$conf,$pod]; + } $this->_parse_docpod; +} + +sub _makeconf { + my ($this,$pod,$indent_level) = @_; + my $result = ''; + + # defaultヘッダに応じて+か-かを設定する。 + # 但しno-switchが定義されていて真であれば、それをしない。 + if ($pod->header->{'no-switch'}) { + $result .= $pod->pkg_name." {\n"; + } + else { + my $enabled = $pod->header->{default}; + if (defined $enabled) { + my $switch = {on => '+' , off => '-'}->{$enabled}; + if (defined $switch) { + $result .= $switch; + } + else { + die "Its `default' header is invalid: $enabled\n"; + } + } + else { + die "It doesn't have `default' header.\n"; + } + $result .= ' '.$pod->pkg_name." {\n"; + } + + # infoヘッダの内容を出力。無ければエラー。 + # ただしinfo-is-omittedが定義されていて真であれば出力しない。 + my $indent = ' ' x $indent_level; + my $block_indent = ''; + my $info = $pod->header->{info}; + if (defined $info) { + if (!$pod->header->{'info-is-omitted'}) { + $result .= "$indent# $info\n\n"; + } + } + else { + die "It doesn't have `info' header.\n"; + } + + # ルール: + # '#'で始まる行はそのまま出力。 + # 空行もそのまま出力。 + # key:value形式になっている部分もそのまま出力するが、 + # そのkeyの頭に'-'が付いていたら、それをコメントアウト。 + my @lines = split /\n/,$pod->content; + for (my $i = 0; $i < @lines; $i++) { + my $line = $lines[$i]; + + my $error = sub { + my $errstr = shift; + + # 前後5行と共にエラー行を示す。 + my $region_lines = 5; + my $begin = $i - $region_lines; + if ($begin < 0) { + $begin = 0; + } + my $end = $i + $region_lines; + if ($end >= @lines) { + $end = @lines-1; + } + my $list = join '',map { + if ($_ == $i) { + "=> |$lines[$_]\n"; + } + else { + " |$lines[$_]\n"; + } + } ($begin .. $end); + + die "$errstr\n$list"; + }; + + $result .= do { + if ($line eq '') { + ''; + } + else { + $indent . do { + if ($line =~ m/^\s*#/) { + (my $stripped = $line) =~ s/^\s*//; + "$block_indent$stripped"; + } + elsif ($line =~ m/^(.+?)\s*:\s*(.*)$/) { + my ($key,$value) = ($1,$2); + if ($key =~ s/^-//) { + "$block_indent#$key: $value"; + } + else { + "$block_indent$key: $value"; + } + } + elsif ($line =~ m/^(.+?)\s*{\s*$/) { + $_ = "$block_indent$1 {"; + $block_indent .= ' ' x 2; + $_; + } + elsif ($line =~ m/^}\s*$/) { + substr($block_indent, 0, 2) = ''; + "$block_indent}"; + } + else { + $error->('illegal line'); + } + }; + } + } . "\n"; + } + + $result . '}'; +} + +package DocPod; +our $AUTOLOAD; + +sub new { + my ($class,$pkg_name,$header,$content) = @_; + my $this = { + pkg_name => $pkg_name, + header => $header, + content => $content, + }; + bless $this,$class; +} + +sub AUTOLOAD { + my ($this,$arg) = @_; + (my $key = $AUTOLOAD) =~ s/.+?:://g; + + my $val = $this->{$key}; + if (defined $arg && ref($val) eq 'HASH') { + $val->{$arg}; + } + else { + $val; + } +} + +1; diff -urN /non-existant-dir/main/Timer.pm tiarra-20080510/main/Timer.pm --- /non-existant-dir/main/Timer.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/main/Timer.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,180 @@ +# ----------------------------------------------------------------------------- +# $Id: Timer.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +# RunLoopに登録され、指定された時刻に起動するタイマーです。 +# 現在の実装では、精度は秒となっています。 +# タイマーの生成に必要なパラメータは、1)起動するサブルーチン、2)起動時刻又は起動までの秒数、 +# 3)起動までの秒数を指定した場合は起動後に再びタイマーをRunLoopに乗せるかどうか、です。 +# +# 起動するサブルーチンとしては、CODE型の値なら何でも構いません。 +# TimerはそのCODEに、引数として自分自身を渡してコールします。 +# +# 3秒後にHello, world!と表示する。 +# my $timer = Timer->new( +# After => 3, +# Code => sub { print "Hello, world!"; } +# )->install; +# +# 3秒毎にHello, world!と表示する。 +# my $timer = Timer->new( +# After => 3, # Intervalでも良い +# Code => sub { print "Hello, world!"; }, +# Repeat => 1 +# )->install; +# +# 3秒後にHello, world!と表示する。 +# my $timer = Timer->new( +# At => time + 3, +# Code => sub { print "Hello, world!"; } +# )->install; +# ----------------------------------------------------------------------------- +package Timer; +use strict; +use warnings; +use Carp; +#use RunLoop; # lazy loading +use Tiarra::Utils; +utils->define_attr_accessor(0, qw(interval name)); + +sub new { + my ($class,%args) = @_; + my $obj = { + fire_time => undef, # 発動する時刻のエポック秒。 + interval => undef, # repeatする場合は、その間隔。しなければ未定義。 + code => undef, # 走らせるコード + runloop => undef, # RunLoopに登録されている場合は、そのRunLoop。 + name => utils->simple_caller_formatter('timer registered'), + }; + bless $obj,$class; + + # AfterとIntervalは同義。 + $args{'After'} = $args{'Interval'} if exists($args{'Interval'}); + + # Atで指定するか、AfterまたはIntervalで指定するか、そのどちらかでなければならない。 + if (exists($args{'At'}) && exists($args{'After'})) { + croak "Timer cannot be made with both parameters At and After (or Interval).\n"; + } + + # Atか、AfterまたはIntervalか、そのどちらか一つは必要。 + if (!exists($args{'At'}) && !exists($args{'After'})) { + croak "Either parameter At or After (or Interval) is required to make Timer.\n"; + } + + # Codeは常に必要。 + if (!exists($args{'Code'})) { + croak "Code is always required to make Timer.\n"; + } + + # CodeがCODE型でなければdie。 + if (ref($args{'Code'}) ne 'CODE') { + croak "Parameter Code was not valid CODE ref.\n"; + } + + $obj->{code} = $args{'Code'}; + + if (defined $args{'At'}) { + # Atで起動時刻が与えられた場合は、Repeatは出来ない。 + if ($args{'Repeat'}) { + carp "Warning: It can't repeat that Timer made with At.\n"; + } + + $obj->{fire_time} = $args{'At'}; + } + elsif (defined $args{'After'}) { + # Repeatが真であれば、間隔をAfterまたはIntervalで与えられた数値とする。 + if ($args{'Repeat'}) { + $obj->{interval} = $args{'After'}; + } + + $obj->{fire_time} = time + $args{'After'}; + } + + if (defined $args{'Name'}) { + $obj->{name} = $args{'Name'}; + } + + $obj; +} + +sub time_to_fire { + my ($this, $time) = @_; + if ($time) { + $this->{fire_time} = $time; + } + $this->{fire_time}; +} + +sub install { + # RunLoopにインストールする。 + # 引数を省略した場合はデフォルトのRunLoopにインストールする。 + my ($this,$runloop) = @_; + + if (defined $this->{runloop}) { + # 既にインストール済みだった。 + croak "This Timer has been already installed to RunLoop.\n"; + } + + if (!defined $runloop) { + require RunLoop; + $runloop = RunLoop->shared_loop; + } + $runloop->install_timer($this); + + $this->{runloop} = $runloop; + $this; +} + +sub uninstall { + # インストールしたRunLoopから、このタイマーをアンインストールする。 + my $this = shift; + + unless (defined $this->{runloop}) { + # インストールされていない。 + croak "This Timer hasn't been installed yet\n"; + } + + $this->{runloop}->uninstall_timer($this); + $this->{runloop} = undef; + $this; +} + +sub execute { + my $this = shift; + # Codeを実行し、必要ならリピートする。 + # RunLoopのみがこのメソッドを呼べる。 + my ($package_of_caller,undef,undef) = caller; + unless ($package_of_caller->isa('RunLoop')) { + croak "Only RunLoop may call method execute of Timer.\n"; + } + + eval { + utils->do_with_errmsg("Timer: $this->{name}", sub { + $this->{code}->($this); + }); + }; if ($@) { + $this->{runloop}->notify_error("$@"); + } + + if (defined $this->{interval}) { + $this->{fire_time} += $this->{interval}; + } + else { + $this->uninstall; + } + + $this; +} + +sub reset { + # interval から fire_time を算出しなおす + my ($this) = shift; + + if (defined $this->{interval}) { + $this->{fire_time} = time + $this->{interval}; + } else { + croak "Only Interval(Repeat) Timer can reset.\n"; + } + $this; +} + +1; diff -urN /non-existant-dir/makedoc tiarra-20080510/makedoc --- /non-existant-dir/makedoc 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/makedoc 2008-05-11 00:25:24.000000000 +0900 @@ -0,0 +1,354 @@ +#!/usr/bin/perl +# ------------------------------------------------------------------------ +# $Id: makedoc 11365 2008-05-10 14:58:28Z topia $ +# ------------------------------------------------------------------------ +use strict; +use warnings; +use lib qw(main); +use Tiarra::Encoding; +use IO::File; +use File::Find; +use Template; +use TiarraDoc; +my $unijp_init = Tiarra::Encoding->new; + +my $conf_outputs = { + sample => { + output => 'sample.conf', + sections => qr/(^|,)important($|,)/, + include_defaults => 1, + }, + all => { + output => 'all.conf', + sections => qr/^/, # all + include_defaults => 1, + }, +}; + +my $stdout_charset = 'utf8'; +my $conf_charset = 'utf8'; +my $html_charset = 'utf8'; + +if (!-f 'tiarra' || !-d 'main' || !-d 'module') { + die "run this script on tiarra's directory.\n"; +} + +mkdir 'doc'; + +&makeconf; +&makehtml_mods_toc; +&makehtml_mods; +exit; + +sub makeconf { + + # module下の.pmを検索 + my @modules; + find(sub { + if (-f $_ && $_ =~ m/\.pm$/) { + push @modules, $File::Find::name; + } + },'module'); + + my $unijp = Tiarra::Encoding->new; + foreach my $genre (qw(sample all)) { + my $output = $conf_outputs->{$genre}; + my $sections = $output->{sections}; + + print "*** Generating $output->{output}... ***\n"; + + my $t = Template->new("doc-src/$genre.conf.in"); + + foreach my $conf (DocParser::Module->new('doc-src/conf-main.tdoc')->makeconf) { + print $conf->[0]." : ".$unijp->set($conf->[1])->$stdout_charset."\n"; + $t->expand($conf->[0] => $unijp->set($conf->[2])->$conf_charset); + } + + map { + my @confs = DocParser::Module->new($_)->makeconf; + foreach my $conf (@confs) { + unless ($output->{include_defaults} && + $conf->[3]->header->{default} eq 'on') { + next unless ($conf->[3]->header->{section} || '') =~ /$sections/; + } + print $conf->[0]." : ".$unijp->set($conf->[1])->$stdout_charset."\n"; + $t->modules->add(module => $unijp->set($conf->[2])->$conf_charset); + } + } sort @modules; + + my $fh = IO::File->new($output->{output}, 'w'); + $fh->print($t->str); + } +} + +our $classify_modules_CACHE; +sub classify_modules { + # 一度実行したら、その結果がキャッシュされる。 + if (defined($_ = $classify_modules_CACHE)) { + return $_; + } + + my $classified = {}; # {グループ名 => [それに含まれるモジュールのDocPod]} + my $classify = sub { + my $doc = shift; + + my $groupname = do { + if ($doc->pkg_name =~ m/^(.+?)::/) { + $1; + } + else { + ''; + } + }; + + my $vec = $classified->{$groupname}; + if (!defined $vec) { + $vec = $classified->{$groupname} = []; + } + push @$vec,$doc; + }; + + # module下の.pmを検索 + find(sub { + if (-f $_ && $_ =~ m/\.pm$/) { + my $parser = DocParser->new($_); + my $doc = eval { + $parser->getdoc; + }; if ($@) { + die "ERROR[$_]: $@\n"; + } + + # 分類 + $classify->($doc) if defined $doc; + } + },'module'); + + # ソート + foreach (keys %$classified) { + @{$classified->{$_}} = + map { $_->[1] } + sort { $a->[0] cmp $b->[0] } + map { [$_->pkg_name, $_]; } @{$classified->{$_}}; + } + + $classify_modules_CACHE = $classified; + $classified; +} + +sub makehtml_mods { + # ファイルはグループ毎に作られる点に注意。 + # すなわち、まず最初に全てのモジュールをグループに分類する必要がある。 + my $classified = &classify_modules; # {グループ名 => [それに含まれるモジュールのDocPod]} + + mkdir 'doc/module'; + + my $unijp = Tiarra::Encoding->new; + my $t = Template->new('doc-src/contents.html'); + + while (my ($groupname,$docpods) = each %$classified) { + my $group_path = + join('', + 'module/', + $groupname eq '' ? 'UNCLASSIFIED' : $groupname, + '.html'); + print "*** Generating doc/$group_path... ***\n"; + + $t->reset; + $t->expand( + group_name => _escapeHTML($groupname), + css_path => '../default.css', + ); + + my $last_docpod = $docpods->[-1]; + foreach my $docpod (@$docpods) { + print " parsing and translating ".$docpod->pkg_name."\n"; + # 空行はそのまま出力。 + # key: valueの行は、とで出力。 + # そのkeyの頭に'-'が付いていたら、単にその'-'を消す。 + # + # '#'で始まる行は、

で出力するが、以下の特殊なルールに従う。 + # 1. '#'の行が連続している場合、それらの行を一つのグループにまとめる。 + # 2. 各グループ内で'#'に後続する共通の数のスペースを取り除く。 + # 3. 取り除いた後、'#'後にスペースがまだ残っているなら、それを に置換する。 + # + # 例: + # # foo + # # bar { + # # baz + # # } + # ↓ + #

+ # foo
+ # bar {
+ #   baz
+ # }
+ #

+ my $html = ''; # 文字コードはUTF-8 + + my @lines = split /\n/,$docpod->content; + for (my $i = 0; $i < @lines; $i++) { + my $line = $lines[$i]; + + if ($line eq '') { + #$html .= "
\n"; + } + elsif ($line =~ m/^\s*#/) { + # グループ作成 + my @group; + for (; $i < @lines; $i++) { + if ($lines[$i] =~ m/^\s*#/) { + # これはブロックの続き。 + (my $stripped = $lines[$i]) =~ s/^\s*#//; + + # タブは4つのスペースに変換。この動作は後で修正するかも知れない。 + $stripped =~ s/\t/ /g; + + push @group,$stripped; + } + else { + $i--; + last; # ここで終わり + } + } + + # 共通する先頭のスペースを除去。すなわち各行について先頭のスペースの個数を数え、 + # その最小値を削るべきスペースの数とする。 + my $spaces_to_remove; + foreach (@group) { + m/^(\s*)/; + if (defined $1) { + my $n_spaces = length($1); + if (defined $spaces_to_remove) { + $spaces_to_remove = $n_spaces + if $spaces_to_remove > $n_spaces; + } + else { + $spaces_to_remove = $n_spaces; + } + } + } + if (defined $spaces_to_remove) { + @group = map { + s/^\s{$spaces_to_remove}//; $_; + } @group; + } + + # それでも残っている先頭のスペースを に置換。 + @group = map { + s{^(\s*)(.*)}{ + my $spc = ' ' x length($1); + my $txt = _escapeHTML($2); + $spc . $txt; + }e; + $_; + } @group; + + $html .= qq{

\n}; + $html .= join('', + map { + "$_
\n"; + } @group); + $html .= qq{

\n}; + } + elsif ($line =~ m/^-?(.+?)\s*:\s*(.*)$/) { + my ($key,$value) = ($1,$2); + $html .= qq{
$key:$value
\n}; + } elsif ($line =~ m/^(.+?)\s*{\s*$/) { + $html .= qq{
$1\n}; + $html .= qq{
\n}; + } elsif ($line =~ m/^}\s*$/) { + $html .= qq{
\n}; + } + } + + # テンプレを展開 + $t->module->expand( + content_name => _escapeHTML($docpod->pkg_name), + description => _escapeHTML($unijp->set($docpod->header('info'))->$html_charset), + content => $unijp->set($html)->$html_charset); + + $t->toc_individual->add( + mod_name => _escapeHTML($docpod->pkg_name), + description => _escapeHTML($unijp->set($docpod->header('info'))->$html_charset), + ); + + # これが最後の要素でなければ、hrを追加する。 + if ($docpod != $last_docpod) { + $t->module->hr->add; + } + + $t->module->add; + } + + # ファイルに出力 + my $fh = IO::File->new("doc/$group_path",'w'); + $fh->print($t->str); + } +} + +sub makehtml_mods_toc { + print "*** Generating doc/module-toc.html... ***\n"; + + my $t = Template->new('doc-src/module-toc.html'); + + my $classified = &classify_modules; # {グループ名 => [それに含まれるモジュールのDocPod]} + + # module-group.tdocを読んで、各グループの説明を取得する。 + my $groups = DocParser->new('doc-src/module-group.tdoc'); + + foreach my $groupname_key (sort {$a cmp $b} keys %$classified) { + my $groupname = $groupname_key ne '' ? $groupname_key : 'UNCLASSIFIED'; + my $description = do { + # このグループに対して、説明が定義されているか？ + my $groupdoc = $groups->getdoc($groupname); + if (defined $groupdoc) { + my $description = $groupdoc->header->{description}; + defined $description ? $description : ''; + } + else { + ''; + } + }; + if ($description eq '') { + warn "group $groupname don't have description."; + } + + my $unijp = Tiarra::Encoding->new; + + my $group_path = "module/$groupname.html"; + + $t->toc_group->expand( + map{ _escapeHTML($_) } + group_path => $unijp->set($group_path)->$html_charset, + group_name => $unijp->set($groupname)->$html_charset, + description => $unijp->set($description)->$html_charset, + ); + + # 各モジュール名とその説明を展開～ + foreach my $moddoc (@{$classified->{$groupname_key}}) { + print $moddoc->pkg_name." belongs to the group `".$groupname."'\n"; + $t->toc_group->toc_individual->add( + map{ _escapeHTML($_) } + group_path => $unijp->set($group_path)->$html_charset, + mod_name => $unijp->set($moddoc->pkg_name)->$html_charset, + description => $unijp->set($moddoc->header->{info} || '')->$html_charset, + ); + } + + $t->toc_group->add; + } + + my $fh = IO::File->new('doc/module-toc.html','w'); + $fh->print($t->str); +} + +sub _escapeHTML +{ + my $val = shift; + $val =~ s/&/&/g; + $val =~ s//>/g; + $val =~ s/"/"/g; + $val =~ s/'/'/g; + $val; +} diff -urN /non-existant-dir/module/Auto/Alias.pm tiarra-20080510/module/Auto/Alias.pm --- /non-existant-dir/module/Auto/Alias.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/Auto/Alias.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,132 @@ +# ----------------------------------------------------------------------------- +# $Id: Alias.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +package Auto::Alias; +use strict; +use warnings; +use base qw(Module); +use Module::Use qw(Auto::AliasDB Auto::Utils); +use Auto::AliasDB; +use Auto::Utils; +use Mask; + +sub new { + my $class = shift; + my $this = $class->SUPER::new(@_); + Auto::AliasDB::setfile($this->config->alias, + $this->config->alias_encoding); + $this; +} + +sub message_arrived { + my ($this,$msg,$sender) = @_; + my @result = ($msg); + + if ($msg->command eq 'PRIVMSG') { + + if (Mask::match($this->config->confirm,$msg->param(1))) { + # その人のエイリアスがあればprivで返す。 + my (undef,undef,$reply_as_priv,undef,undef) + = Auto::Utils::generate_reply_closures($msg,$sender,\@result, 0); # Alias conversion disable. + + my $alias = Auto::AliasDB->find_alias_prefix($msg->prefix); + if (defined $alias) { + while (my ($key,$values) = each %$alias) { + map { + $reply_as_priv->("$key: $_"); + } @$values; + } + } + } else { + my (undef,undef,undef,$reply_anywhere,undef) + = Auto::Utils::generate_reply_closures($msg,$sender,\@result, 1); + + my $msg_from_modifier_p = sub { + !defined $msg->prefix || + Mask::match_deep([Mask::array_or_all($this->config->modifier('all'))], + $msg->prefix); + }; + + my ($temp) = $msg->param(1); + $temp =~ s/^\s*(.+)\s*$/$1/; + my ($keyword,$key,$value) + = split(/\s+/, $temp, 3); + + if (Mask::match($this->config->get('add'),$keyword)) { + if ($msg_from_modifier_p->() && defined $key && defined $value) { + if (Auto::AliasDB->add_value_with_prefix($msg->prefix, $key, $value)) { + $reply_anywhere->([$this->config->added_format('all')], + 'key' => $key, 'value' => $value); + } else { + $reply_anywhere->([$this->config->add_failed_format('all')], + 'key' => $key, 'value' => $value); + } + } + } elsif (Mask::match($this->config->get('remove'),$keyword)) { + if ($msg_from_modifier_p->() && defined $key) { + my $count = Auto::AliasDB->del_value_with_prefix($msg->prefix, $key, $value); + if ($count) { + $reply_anywhere->([$this->config->removed_format('all')], 'key' => $key, 'value' => $value, 'count' => $count); + } else { + $reply_anywhere->([$this->config->remove_failed_format('all')], 'key' => $key, 'value' => $value); + } + } + } + } + } + return @result; +} + +1; + +=pod +info: ユーザエイリアス情報の管理を行ないます。 +default: off + +# エイリアスは基本的にname,userの二つのフィールドから成っており、 +# それぞれユーザー名、ユーザーマスクを表します。 + +# エイリアス定義ファイルのパスと、そのエンコーディング。 +# このファイルは次のようなフォーマットである。 +# 1. それぞれの行は「<キー>: <値>」の形式である。 +# 2. 空の行で、各ユーザーを区切る。 +# 3. <値>はカンマで区切られて複数の値とされる。 +# +# エイリアス定義ファイルの例: +# +# name: sample +# user: *!*sample@*.sample.net +# +# name: sample2,[sample2] +# user: *!sample2@*.sample.net,*!sample2@*.sample2.net +# +alias: alias.txt +alias-encoding: euc + +# この発言をした人のエイリアスが登録されていれば、それをprivで送る。 +confirm: エイリアス確認 + +# 「 user *!*user@*.user.net」のようにして情報を追加。 +# 発言をした人のエイリアスが未登録だった場合は、userのみ受け付けて新規追加とする。 +add: エイリアス追加 + +# 「 name ユーザー」のようにして情報を削除。 +# userを全て削除されたエイリアスは他の情報(name等)も含めて消滅する。 +remove: エイリアス削除 + +# メッセージが追加されたときの反応を指定します。 +# ランダムなメッセージを発言する際のフォーマットを指定します。 +# エイリアス置換が有効です。#(nick.now)、#(channel)は +# それぞれ相手のnick、チャンネル名に置換されます。 +# #(key)、#(value)は、追加されたキーと値に置換されます。 +added-format: #(name|nick.now): エイリアス #(key) に #(value) を追加しました。 +add-failed-format: #(name|nick.now): エイリアス #(key) の追加に失敗しました。 + +# メッセージが削除されたときの反応を指定します。 +# added-formatで指定できるものと同じです。 +removed-format: #(name|nick.now): エイリアス #(key) から #(value) を削除しました。 +remove-failed-format: #(name|nick.now): エイリアス #(key) からの削除に失敗しました。 + +# エイリアスの追加や削除が許されている人。省略された場合は「*!*@*」と見做される。 +modifier: *!*@* +=cut diff -urN /non-existant-dir/module/Auto/AliasDB/CallbackUtils.pm tiarra-20080510/module/Auto/AliasDB/CallbackUtils.pm --- /non-existant-dir/module/Auto/AliasDB/CallbackUtils.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/Auto/AliasDB/CallbackUtils.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,288 @@ +# ----------------------------------------------------------------------------- +# $Id: CallbackUtils.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +# copyright (C) 2003 Topia . all rights reserved. + +package Auto::AliasDB::CallbackUtils; +use Auto::AliasDB; +use strict; +use warnings; +use Carp; +use RunLoop; +use Multicast; +use Tiarra::SharedMixin; +use base qw(Tiarra::IRC::NewMessageMixin); +our $_shared_instance; + +sub _new { + my ($class) = @_; + my $obj = { + loaded_modules => {}, + }; + bless $obj,$class; +} + +sub _getmodule { + my ($this, $modulename) = @_; + + return $this->shared->{loaded_modules}->{$modulename}; +} + +sub _loadmodule { + my ($this, $modulename, $need_module_use) = @_; + my ($module) = $this->_getmodule($modulename); + if (defined $module) { + # module already 'tryed' load. + } else { + if ($need_module_use) { + eval "use Module::Use ('$modulename')"; + } + eval 'use ' . $modulename; + unless ($@) { + $module = $this->shared->{loaded_modules}->{$modulename} = 1; + + return $module; + } else { + $module = $this->shared->{loaded_modules}->{$modulename} = 0; + } + carp "can't load $modulename" if $module != 1; + } + return $module; +} + +sub register_callback { + my ($reg_callback, $callbacks) = @_; + + my ($callback_code) = sub { + if (ref($reg_callback) eq 'CODE') { + # code reference + return $reg_callback; + } elsif (!ref($reg_callback)) { + # scalar + my $code = eval('\&' . $reg_callback); + return $code unless ($@); + carp($reg_callback . ' is scalar, but function not defined.'); + return undef; + } else { + carp($reg_callback . ' is not code_reference or scalar.'); + return undef; + } + }->(); + + return $callbacks unless defined($callback_code); + + foreach my $callback (@$callbacks) { + return $callbacks if $callback == $callback_code; + } + push(@$callbacks, $callback_code); + return $callbacks; +} + +sub register_stdcallbacks { + my ($callbacks, $msg, $sender) = @_; + + register_callback(\&DateConvert, $callbacks); + register_callback(\&RandomConvert, $callbacks); + register_callback(\&RandomSelectConvert, $callbacks); + register_callback(\&RandomAliasConvert, $callbacks); + register_callback(\&JoinedListConvert, $callbacks); + if (defined $msg) { + if (defined $sender) { + register_RandomNickConvert($callbacks, $msg->param(0), $sender); + } + register_MessageReplace($callbacks, $msg->param(1)); + } + + return $callbacks; +} + +sub DateConvert { + my ($key) = @_; + my ($tag, $value) = split(/\:/, $key, 2); + + return undef unless ($tag eq 'date'); + return undef unless (Auto::AliasDB::CallbackUtils->shared->_loadmodule('Tools::DateConvert', 1)); + return Tools::DateConvert::replace($value); +} + +sub RandomConvert { + my ($key) = @_; + my ($tag, $value) = split(/\:/, $key, 2); + + return undef unless defined($tag) and defined ($value); + return undef unless ($tag eq 'random'); + return undef unless ($value =~ /^(\d+)-(\d+)$/); + return (int(rand($2 - $1 + 1)) + $1); +} + +sub RandomSelectConvert { + my ($key) = @_; + my ($tag, @values) = split(/\:/, $key); + + return undef unless ($tag eq 'randomselect'); + return @values[int(rand(scalar(@values)))]; +} + +sub RandomAliasConvert { + my ($key, $hashtables) = @_; + my ($tag, $name) = split(/\:/, $key, 2); + + return undef unless ($tag eq 'randomalias'); + return undef unless defined($name); + # search hashtable + foreach my $table (@$hashtables) { + my $value = Auto::AliasDB::get_value_random($table, $name); + return $value if defined($value); + } +} + +sub JoinedListConvert { + my ($key, $hashtables) = @_; + my ($tag, $name, $sep) = split(/\:/, $key, 3); + + return undef unless ($tag eq 'joined_list'); + return undef unless defined($name) && defined($sep); + # search hashtable + foreach my $table (@$hashtables) { + my @values = @{Auto::AliasDB::get_array($table, $name)}; + if (@values) { + # 発見 + return join($sep, @values); + } + } + return undef; +} + + +sub RandomNickConvert { + my ($ch, $key) = @_; + my $idx; + + return undef unless ($key eq 'randomnick'); + $idx = int(rand($ch->names(undef, undef, 'size'))); + return $ch->names((keys(%{$ch->names()}))[$idx])->person->nick; +} + +sub register_RandomNickConvert { + # using: + # Auto::AliasDB::CallbackUtils::register_RandomNickConvert($callbacks, $ch_name, $sender); + my ($callbacks, $ch_name, $sender) = @_; + return $callbacks unless $sender->isa('IrcIO::Server'); + my $ch = $sender->channel(Multicast::detatch($ch_name)); + + return $callbacks unless defined $ch; + register_callback( + sub { + return RandomNickConvert($ch, @_); + }, $callbacks); + + return $callbacks; +} + +sub MessageReplace { + my ($message, $key) = @_; + my ($tag, $split_char, $place) = split(/\:/, $key, 3); + my ($offsetlen); + + if ($tag eq 'message_replace') { + $offsetlen = 2; + } elsif ($tag eq 'message_replace_last') { + $offsetlen = 1; + } else { + return undef; + } + return undef unless (defined $split_char) && (defined $place); + return (split($split_char, $message, $place + $offsetlen))[$place]; +} + +sub register_MessageReplace { + # using: + # Auto::AliasDB::CallbackUtils::register_MessageReplace($callbacks, $message); + my ($callbacks, $message) = @_; + + return $callbacks unless defined $message; + register_callback( + sub { + MessageReplace($message, @_); + }, $callbacks); + + return $callbacks; +} + +# --- not secure --- + +sub register_extcallbacks { + my ($callbacks, $msg, $sender) = @_; + + Auto::AliasDB::CallbackUtils::register_Nick_setMode($callbacks, $msg, $sender); + Auto::AliasDB::CallbackUtils::register_callback(\&ReadFileConvert, $callbacks); + Auto::AliasDB::CallbackUtils::register_callback(\&FileLinesConvert, $callbacks); + + return $callbacks; +} + +sub ReadFileConvert { + my ($key) = @_; + my ($tag, $fpath, $mode, $charset) = split(/\:/, $key, 4); + + return undef unless $tag eq 'read_file'; + return undef unless (Auto::AliasDB::CallbackUtils->shared->_loadmodule('Tools::FileCache', 1)); + $mode = 'std' if (!defined($mode)); + my $file = Tools::FileCache->shared->find_file($fpath, $mode, $charset); + return undef unless defined($file); + return $file->get_value(); +} + +sub FileLinesConvert { + my ($key) = @_; + my ($tag, $fpath, $mode, $charset) = split(/\:/, $key, 4); + + return undef unless $tag eq 'file_lines'; + return undef unless (Auto::AliasDB::CallbackUtils->shared->_loadmodule('Tools::FileCache', 1)); + $mode = 'std' if (!defined($mode)); + my $file = Tools::FileCache->shared->find_file($fpath, $mode, $charset); + return undef unless defined($file); + return $file->length(); +} + +sub Nick_setMode { + my ($irc_message, $sender, $key) = @_; + my ($tag, $value) = split(/\:/, $key, 2); + + return undef unless ($tag eq 'set_chmode'); + return undef unless ($value =~ /^[+-][vo]$/); + return '' unless ($sender->isa('IrcIO::Server')); + $irc_message->param(1, $value); + Timer->new( + After => 0, + Repeat => 0, + Code => sub { + my $timer = shift; + $sender->send_message($irc_message); + })->install; + return ''; +} + +sub register_Nick_setMode { + # using: + # Auto::AliasDB::CallbackUtils::register_Nick_setMode($callbacks, $msg, $sender); + my ($callbacks, $msg, $sender) = @_; + my ($ch_name) = $msg->param(0); + return $callbacks if (Multicast::nick_p($ch_name)); #priv + $ch_name = scalar(Multicast::detatch($ch_name)); + my $irc_message = __PACKAGE__->shared->construct_irc_message( + Command => 'MODE', + Params => [$ch_name, + '', #set later + $msg->nick]); + + register_callback( + sub { + Nick_setMode($irc_message, $sender, @_); + }, $callbacks); + + return $callbacks; +} + + +1; diff -urN /non-existant-dir/module/Auto/AliasDB.pm tiarra-20080510/module/Auto/AliasDB.pm --- /non-existant-dir/module/Auto/AliasDB.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/Auto/AliasDB.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,204 @@ +# -*- cperl -*- +# ----------------------------------------------------------------------------- +# $Id: AliasDB.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +# エイリアスファイルの読み込みと生成、#(name|nick)といった文字列の置換を行なうクラス。 +# Tiarraモジュールではない。 +# このクラスは共通のインスタンスを一つだけ持つ。 +# ----------------------------------------------------------------------------- +package Auto::AliasDB; +use strict; +use warnings; +use IO::File; +use File::stat; +use Module::Use qw(Auto::AliasDB::CallbackUtils Tools::GroupDB Tools::Hash); +use Auto::AliasDB::CallbackUtils; +use Tools::GroupDB; +use Tools::Hash; +use Mask; +use Configuration; +use Configuration::Block; +use Tiarra::SharedMixin; +use Tiarra::Utils; +our $_shared_instance; + +Tiarra::Utils->define_attr_getter(1, qw(database config)); +Tiarra::Utils->define_proxy('database', 1, + [qw(add_alias add_group)], + map { [$_.'_prefix', $_.'_primary'] } + qw(add_value_with del_value_with)); + +sub setfile { + # クラス関数。 + my ($fpath,$charset) = @_; + # re-initialize + __PACKAGE__->_shared_init($fpath,$charset); +} + +sub _new { + # fpathを省略するか空の文字列を指定すると、空のAliasDBが作られます。 + my ($class,$fpath,$charset) = @_; + my $obj = { + database => Tools::GroupDB->new($fpath, 'user', $charset || undef, 0), + config => Configuration::shared_conf->get(__PACKAGE__) + || Configuration::Block->new(__PACKAGE__), + }; + bless $obj,$class; +} + +sub find_alias_prefix { + # userinfoはnick!user@hostの形式。 + # 見付からなければundefを返す。 + # flagに付いてはfind_alias参照。 + my ($class_or_this, $userinfo, $flag) = @_; + my $this = $class_or_this->_this; + + return $this->find_alias('user', $userinfo, $flag); +} + +sub find_alias { + # on not found return 'undef' + # $keys is ref[array or scalar] + # $values is ref[array or scalar] + # $flag is public_alias flag. true is 'public', default false. + my ($class_or_this, $keys, $values, $flag) = @_; + my $this = $class_or_this->_this; + + $flag = 0 unless defined($flag); + + my $person = $this->{database}->find_group($keys, $values); + + if (defined($person)) { + if ($flag) { + # public. remove private alias. + return $this->remove_private(dup_struct($person)); + } else { + # not public + return $person; + } + } + + return undef; +} + +sub add_value { + my ($class_or_this, $alias, $key, $value) = @_; + + return $alias->add_value($key, $value); +} + +sub del_value { + my ($class_or_this, $alias, $key, $value) = @_; + + return $alias->del_value($key, $value); +} + +# alias misc functions +sub find_alias_with_stdreplace { + my ($class_or_this, $nick, $name, $host, $prefix, $flag) = @_; + my $this = $class_or_this->_this; + + return add_stdreplace(dup_struct($this->find_alias_prefix($prefix, $flag)), + $nick, $name, $host, $prefix); +} + +sub add_stdreplace { + my ($alias, $nick, $name, $host, $prefix) = @_; + + $alias = Tools::Hash->new() unless defined($alias); + + $alias->{'nick.now'} = $nick; + $alias->{'user.now'} = $name; + $alias->{'host.now'} = $host; + $alias->{'prefix.now'} = $prefix; + + return $alias; +} + +sub remove_private { + my ($class_or_this, $alias, $prefix, $suffix) = @_; + my $this = $class_or_this->_this; + + $prefix = '' unless defined($prefix); + $suffix = '' unless defined($suffix); + + foreach my $remove_key ($this->config->private('all')) { + delete $alias->{$prefix . $remove_key . $suffix}; + } + + return $alias; +} + +sub check_readonly { + my ($class_or_this, $keys) = @_; + my $this = $class_or_this->_this; + + foreach my $check_key ($this->config->readonly('all')) { + @$keys = grep { + $_ ne $check_key; + } @$keys; + } + + return $keys; +} + +sub dup_struct { + my ($alias) = @_; + + return undef unless defined($alias); + return $alias->clone; +} + +sub concat_string_to_key { + return Tools::GroupDB::concat_string_to_key(@_); +} + +# first param should be Tool::Hash. +sub get_value_random { shift->get_value_random(@_); } +sub get_value { shift->get_value(@_) } +sub get_array { shift->get_array(@_) } + +# replace support functions +sub replace { + # エイリアスマクロの置換を行なう。%optionalは置換に追加するキーと値の組みで、省略可。 + # optionalの値はSCALARでもARRAYでも良い。 + # userinfoはnick!user@hostの形式。 + my ($class_or_this,$userinfo,$str,%optional) = @_; + my $this = $class_or_this->_this; + $this->replace_with_callbacks($userinfo,$str,undef,%optional); +} + +sub stdreplace { + my ($class_or_this, $userinfo, $str, $msg, $sender, %optional) = @_; + my $this = $class_or_this->_this; + my (@callbacks); + + return $this->stdreplace_add($userinfo, $str, \@callbacks, $msg, $sender, %optional); +} + +sub stdreplace_add { + my ($class_or_this, $userinfo, $str, $callbacks, $msg, $sender, %optional) = @_; + my $this = $class_or_this->_this; + + Auto::AliasDB::CallbackUtils::register_stdcallbacks($callbacks, $msg, $sender); + my ($add_alias) = add_stdreplace( + undef, + $msg->nick || RunLoop->shared->current_nick, + $msg->name, + $msg->host, + $msg->prefix); + + return $this->replace_with_callbacks($userinfo, $str, $callbacks, %optional, %$add_alias); +} + +sub replace_with_callbacks { + # エイリアスマクロの置換を行なう。%optionalは置換に追加するキーと値の組みで、省略可。 + # $callbacksはalias/optionalで置換できなかった際に呼び出されるコールバック関数のリファレンス。 + # optionalの値はSCALARでもARRAYでも良い。 + # userinfoはnick!user@hostの形式。 + my ($class_or_this,$userinfo,$str,$callbacks,%optional) = @_; + my $this = $class_or_this->_this; + return $this->{database}->replace_with_callbacks($userinfo, $str, $callbacks, %optional); +} + +1; diff -urN /non-existant-dir/module/Auto/Answer.pm tiarra-20080510/module/Auto/Answer.pm --- /non-existant-dir/module/Auto/Answer.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/Auto/Answer.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,120 @@ +# ----------------------------------------------------------------------------- +# $Id: Answer.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +package Auto::Answer; +use strict; +use warnings; +use base qw(Module); +use Module::Use qw(Auto::Utils); +use Auto::Utils; +use Mask; +use Multicast; + +sub as_boolean +{ + my $val = shift; + if( $val && $val =~ /^(off|no|false)/i ) + { + $val = 0; + } + $val; +} + +sub message_arrived { + my ($this,$msg,$sender) = @_; + my @result = ($msg); + + # PRIVMSG 以外は無視. + if( $msg->command ne 'PRIVMSG' ) + { + return @result; + } + + # サーバーから以外(自分の発言)は, + # 設定がなければ無視. + if( !$sender->isa('IrcIO::Server') ) + { + if( !as_boolean( $this->config->answer_to_myself() ) ) + { + return @result; + } + } + + my ($get_ch_name,undef,undef,$reply_anywhere) + = Auto::Utils::generate_reply_closures($msg,$sender,\@result); + my $msgval = $msg->param(1); + my $msg_ch_full = Auto::Utils::get_full_ch_name($msg, 0); + + # replyに設定されたものの中から、一致しているものがあれば発言。 + # 一致にはMask::matchを用いる。 + foreach ($this->config->reply('all')) { + my ($mask,$reply_msg) = m/^(.+?)\s+(.+)$/; + if (Mask::match($mask,$msgval)) { + # 一致していた。 + $reply_anywhere->($reply_msg); + } + } + + # channel-reply のチェック。 + foreach ($this->config->channel_reply('all')) { + my ($chan_mask, $msg_mask, $reply_msg) = split(' ', $_, 3); + $chan_mask =~ s/\[(.*)\]$//; + my @opts = split(/,/,$1||''); + + defined($reply_msg) or next; + if( !Mask::match($msg_mask,$msgval) ) + { + # メッセージがマッチしない. + next; + } + if( !Mask::match($chan_mask,$msg_ch_full)) { + # チャンネルがマッチしない. + next; + } + # マッチしたのでお返事. + $reply_anywhere->($reply_msg); + + # [last] 指定があればここでおしまい. + if( grep{$_ eq 'last'} @opts ) + { + last; + } + } + + return @result; +} + +1; + +=pod +info: 特定の発言に反応して対応する発言をする。 +default: off + +# Auto::Aliasを有効にしていれば、エイリアス置換を行ないます。 + +# 反応する発言と、それに対する返事を定義します。 +# エイリアス置換が有効です。#(nick.now)と$(channel)はそれぞれ +# 相手の現在のnickとチャンネル名に置換されます。 +# +# コマンド: reply +# 書式: <反応する発言のマスク> <それに対する返事> +# 例: +-reply: こんにちは* こんにちは、#(name|nick.now)さん。 +# この例では誰かが「こんにちは」で始まる発言をすると、 +# 発言した人のエイリアスを参照して「こんにちは、○○さん。」のように発言します。 +# +# コマンド: channel-reply +# 書式: <反応するチャンネルのマスク> <反応する発言のマスク> <それに対する返事> +# 例: +-channel-reply: #あいさつ@ircnet こんにちは* こんにちは、#(name|nick.now)さん。 +# この例では#あいさつ@ircnetで誰かが「こんにちは」で始まる発言をすると、 +# 発言した人のエイリアスを参照して「こんにちは、○○さん。」のように発言します。 +# +# コマンド: answer-to-myself +# 書式: <真偽値> +# 例: +-answer-to-myself: on +# 自分の発言にも反応するようになります。 +# デフォルトは off です。 + +=cut diff -urN /non-existant-dir/module/Auto/CacheManager.pm tiarra-20080510/module/Auto/CacheManager.pm --- /non-existant-dir/module/Auto/CacheManager.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/Auto/CacheManager.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,89 @@ +# ----------------------------------------------------------------------------- +# $Id: CacheManager.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +# このクラスは共通のインスタンスを持ちます。 +# キャッシュサイズや有効期限などの設定はAuto::Cacheが行ないます。 +# +# 実際のチャンネルの管理は面倒なので、キャッシュ本体は +# ChannelInfoのremarks/cache-of-auto-modulesに保存します。 +# +# cache-of-auto-modules: ARRAY +# 要素: [発言内容,発言時刻] +# ----------------------------------------------------------------------------- +package Auto::CacheManager; +use strict; +use warnings; +use Tiarra::SharedMixin; +our $_shared_instance; + +sub _new { + my ($class) = @_; + my $this = { + size => 0, # デフォルトのキャッシュサイズ。 + expire => 600, # デフォルトの有効期限。単位は秒。 + }; + bless $this,$class; +} + +sub cached_p { + # ch: ChannelInfo + # str: SCALAR + # キャッシュされていたら1を返します。 + my ($this,$ch,$str) = @_; + my $cache = $this->get_cache($ch); + $this->expire($cache); + + foreach (@$cache) { + if ($_->[0] eq $str) { + return 1; + } + } + undef; +} + +sub cache { + my ($this,$ch,$str) = @_; + my $cache = $this->get_cache($ch); + $this->expire($cache); + + # キャッシュに追加 + push @$cache,[$str,time]; + # キャッシュサイズから溢れた分は削除 + if (@$cache > $this->{size}) { + splice @$cache,(@$cache - $this->{size}); + } +} + +sub get_cache { + my ($this,$ch) = @_; + my $cache = $ch->remarks('cache-of-auto-modules'); + if (!defined $cache) { + $cache = []; + $ch->remarks('cache-of-auto-modules',$cache); + } + $cache; +} + +sub expire { + my ($this,$cache) = @_; + # まずはexpireされる項目が一つでもあるかどうかを調べる。 + my $limit = time - $this->{expire}; + + my $expired_some = sub { + foreach (@$cache) { + if ($_->[1] < $limit) { + return 1; + } + } + undef; + }->(); + + if ($expired_some) { + # キャッシュを再構成 + @$cache = grep { + $_->[1] >= $limit; + } @$cache; + } +} + +1; diff -urN /non-existant-dir/module/Auto/Calc.pm tiarra-20080510/module/Auto/Calc.pm --- /non-existant-dir/module/Auto/Calc.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/Auto/Calc.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,239 @@ +# -*- cperl -*- +# ----------------------------------------------------------------------------- +# $Id: Calc.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +# copyright (C) 2003-2004 Topia . all rights reserved. +package Auto::Calc::Share; +use strict; +our $__export = [qw(pi pie e frac)]; +sub export () { $__export } + +sub pi () { 3.141592653589793238 } +sub pie () { pi } +sub e () { exp(1) } +sub frac ($) { $_[0] - int($_[0]) } + +package Auto::Calc; +use strict; +use warnings; +use base qw(Module); +use Module::Use qw(Auto::Utils Auto::Calc::Share); +use Auto::Utils; +use Mask; + +use Symbol (); +use Safe; + +sub new { + my $class = shift; + my $this = $class->SUPER::new(@_); + $this->{safe} = Safe->new(__PACKAGE__.'::Root'); + $this->{safe}->erase; + $this->{safe}->permit_only(qw(:base_core :base_math :base_orig), + qw(pack unpack), + qw(atan2 sin cos exp log sqrt), + ); + if (!$this->config->permit_sub) { + $this->{safe}->deny(qw(leavesub)); + } + my $pkg = __PACKAGE__.'::Share'; + $this->{safe}->share_from($pkg, $pkg->export); + + return $this; +} + +sub destruct { + my ($this) = shift; + + Symbol::delete_package(__PACKAGE__.'::Root') +} + +sub message_arrived { + my ($this,$msg,$sender) = @_; + my @result = ($msg); + + my $return_value = sub { + return @result; + }; + + my (undef,undef,undef,$reply_anywhere,$get_full_ch_name) + = Auto::Utils::generate_reply_closures($msg,$sender,\@result); + + if ($msg->command eq 'PRIVMSG') { + my $method = $msg->param(1); + $method =~ s/^\s*(.*)\s*$/$1/; + + # init + if (Mask::match_deep([$this->config->init('all')], $method)) { + if (Mask::match_deep_chan([$this->config->init_mask('all')], + $msg->prefix, $get_full_ch_name->())) { + $this->{safe}->reinit; + $reply_anywhere->([$this->config->init_format('all')]); + return $return_value->(); + } + } + + my $keyword; + ($keyword, $method) = split(/\s+/, $method, 2); + + # request + if (Mask::match_deep([$this->config->request('all')], $keyword)) { + if (Mask::match_deep_chan([$this->config->mask('all')], + $msg->prefix, $get_full_ch_name->())) { + my ($ret, $err, $signal); + do { + # disable warning + local $SIG{__WARN__} = sub { }; + # + my $signal_handler = sub { + $signal = shift; + die "$signal called"; + }; + # floating point exceptions + local $SIG{FPE} = sub { $signal_handler->('SIGFPE'); } + if exists $SIG{FPE}; + # alarm + local $SIG{ALRM} = sub { $signal_handler->('ALARM'); } + if exists $SIG{ALRM}; + my $timeout = $this->config->timeout; + $timeout = 1 unless defined $timeout; + # die handler + local $SIG{__DIE__} = sub { + $err = shift; + die ''; + }; + + alarm $timeout if ($timeout); + no strict; + $ret = $this->{safe}->reval($method); + alarm 0 if ($timeout); + }; + + my $reply = sub { + my $array = shift; + + map { + if (defined($$_)) { + # 汚染の除去 + $$_ =~ tr/\t\x0a\x0d/ /; + $$_ =~ tr/\x00-\x19//d; + $$_ =~ s/^\s+//; + $$_ =~ s/\s+$//; + $$_ =~ s/\s{2,}/ /; + } else { + $$_ = $this->config->undef || 'undef'; + } + } (\$ret, \$err); + + if ($err) { + $err =~ s/ +at \(eval \d+\) line \d+//; + $err =~ s/, line \d+//; + } + + map { + $reply_anywhere->( + $_, + method => $method, + result => $ret, + error => $err, + signal => $signal, + ); + } @$array; + }; + + my @format_names; + if ($signal) { + push(@format_names, 'signal-'.lc($signal).'-format'); + push(@format_names, 'signal-format'); + } + if ($err) { + my $format = undef; + # format の個別化 + my $error_name = $err; + if ($this->config->error_name_formatter) { + + } + $error_name =~ s/'.+' (trapped by operation mask)/$1/; + $error_name =~ s/(Undefined subroutine) \&.+ (called)/$1 $2/; + $error_name =~ tr/ _/-/; + $error_name =~ tr/'`//d; + $error_name =~ s/\.$//; + $error_name =~ s/-+$//; + $error_name = lc($error_name); + #::debug_printmsg("error_name: $error_name"); + + push(@format_names, 'error-format'); + } else { + push(@format_names, 'reply-format'); + } + foreach my $format_name (@format_names) { + my @formats = $this->config->get($format_name, 'all'); + next if $#formats != 0; + $reply->(\@formats); + last; + } + } + } + } + + return $return_value->(); +} + +1; +=pod +info: Perlの式を計算させるモジュール。 +default: off + +# 反応する発言を指定します。 +request: 計算 + +# 使用を許可する人&チャンネルのマスク。 +# 例はTiarraモード時。 [default: なし] +mask: * +*!*@* +# [plum-mode] mask: +*!*@* + +# 結果が未定義だったときに置き換えられる文字列。省略されると undef 。 +-undef: (未定義) + +# 正常に計算できたときのフォーマット +# method: 計算式, result: 結果, error: エラー, signal: シグナル +reply-format: #(method): #(result) + +# エラーが起きたときのフォーマット +# method: 計算式, result: 結果, error: エラー, signal: シグナル +error-format: #(method): エラーです。(#(error)) + +# シグナルが発生したときのフォーマット +-signal-format: #(method): シグナルです。(#(signal)) + +# signal-$SIGNALNAME-format 形式。 +# $SIGNALNAME には現状 alarm/sigfpe があります。 +# 該当がなければ signal-format にフォールバックします。 + +# いくつかの例を挙げます。 +-signal-alarm-format: #(method): 時間切れです。 +-signal-sigfpe-format: #(method): 浮動小数点計算例外です。 + +# タイムアウトする秒数を指定します。 alarm に渡されます。 +# 再帰を止めるのに使えますが、どうもメモリリークしていそうな雰囲気です。 +timeout: 1 + +# サブルーチン定義を許可するかどうかを指定する。 +# 再帰定義が可能なので、許可する場合はこのモジュール専用の +# Tiarra を動かすことをお勧めします。 +permit-sub: 0 + +# 初期化する発言を指定します。 +# このモジュールでは現状変数や関数定義などを行えます。 +# このコマンドが発行されるとそれらをクリアします。 +init: 計算初期化 + +# 初期化を許可する人&チャンネルのマスク。 +# 例はTiarraモード時。 [default: なし] +init-mask: * +*!*@* +# [plum-mode] mask: +*!*@* + +# 再初期化したときの発言を指定します。 +init-format: 初期化しました。 + +=cut diff -urN /non-existant-dir/module/Auto/ChannelWithoutOper.pm tiarra-20080510/module/Auto/ChannelWithoutOper.pm --- /non-existant-dir/module/Auto/ChannelWithoutOper.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/Auto/ChannelWithoutOper.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,96 @@ +# ----------------------------------------------------------------------------- +# $Id: ChannelWithoutOper.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +package Auto::ChannelWithoutOper; +use strict; +use warnings; +use base qw(Module); +use Multicast; + +sub new { + my $class = shift; + my $this = $class->SUPER::new(@_); + $this->{last_message_time} = 0; # 最後にこのモジュールが発言した時刻。 + $this->{table} = do { + my %hash = map { + my ($ch_long,$msg) = m/^(.+?)\s+(.+)$/; + $ch_long => $msg; + } $this->config->channel('all'); + \%hash; + }; + $this; +} + +sub message_arrived { + my ($this,$msg,$sender) = @_; + my @result = ($msg); + + my $notify = sub { + my ($ch_long,$ch_short,$str) = @_; + my $msg_to_send = $this->construct_irc_message( + Command => 'NOTICE', + Params => ['',$str]); # チャンネル名は後で設定 + # 鯖にはネットワーク名を付けない。 + my $for_server = $msg_to_send->clone; + $for_server->param(0,$ch_short); + $sender->send_message($for_server); + + # クライアントには付ける。Prefixも自動設定する。 + my $for_client = $msg_to_send->clone; + $for_client->param(0,$ch_long); + $for_client->remark('fill-prefix-when-sending-to-client',1); + push @result,$for_client; + }; + + if ($sender->isa('IrcIO::Server') && + defined $msg->nick && + $msg->nick ne RunLoop->shared->current_nick && + $msg->command eq 'JOIN') { + + foreach (split /,/,$msg->param(0)) { + my ($ch_long) = m/^([^\x07]+)/; + # このチャンネルに割り当てられたメッセージはあるか？ + my $msg_for_ch = $this->{table}->{$ch_long}; + if (defined $msg_for_ch) { + my $ch_short = Multicast::detach($ch_long); + my $ch = $sender->channel($ch_short); + # このチャンネルは+チャンネルでもなく、+aや+rが設定されていないか？ + if (defined $ch && + $ch->name !~ m/^\+/ && + !$ch->switches('a') && + !$ch->switches('r')) { + + # なるとを誰か持っているか？ + my $oper_exists; + foreach my $person (values %{$ch->names}) { + if ($person->has_o) { + $oper_exists = 1; + } + } + if (!$oper_exists) { + # 発言してから1秒以上経っていれば、発言。 + if (time > $this->{last_message_time} + 1) { + $notify->($ch_long,$ch_short,$msg_for_ch); + $this->{last_message_time} = time; + } + } + } + } + } + } + @result; +} + +1; + +=pod +info: チャンネルオペレータ権限がなくなってしまったときに発言する。 +default: off + +# +で始まらない特定のチャンネルで、+aモードでも+rモードでもないのに +# 誰もチャンネルオペレータ権限を持っていない状態になっている時、 +# そこに誰かがJOINする度に特定のメッセージを発言するモジュールです。 + +# 書式: <チャンネル名> <メッセージ> +-channel: #IRC談話室@ircnet なると消失しました。 +=cut diff -urN /non-existant-dir/module/Auto/FetchTitle/Plugin/ExtractHeading.pm tiarra-20080510/module/Auto/FetchTitle/Plugin/ExtractHeading.pm --- /non-existant-dir/module/Auto/FetchTitle/Plugin/ExtractHeading.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/Auto/FetchTitle/Plugin/ExtractHeading.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,293 @@ +## ---------------------------------------------------------------------------- +# Auto::FetchTitle::Plugin::ExtractHeading. +# ----------------------------------------------------------------------------- +# Mastering programmed by YAMASHINA Hio +# +# Copyright 2008 YAMASHINA Hio +# ----------------------------------------------------------------------------- +# $Id: ExtractHeading.pm 10891 2008-05-01 12:18:10Z hio $ +# ----------------------------------------------------------------------------- +package Auto::FetchTitle::Plugin::ExtractHeading; +use strict; +use warnings; +use base 'Auto::FetchTitle::Plugin'; +use Mask; + +our $DEBUG; +*DEBUG = \$Auto::FetchTitle::DEBUG; + +1; + +# ----------------------------------------------------------------------------- +# $pkg->new(\%config). +# +sub new +{ + my $pkg = shift; + my $this = $pkg->SUPER::new(@_); + $this; +} + +# ----------------------------------------------------------------------------- +# $obj->register($context). +# +sub register +{ + my $this = shift; + my $context = shift; + + $context->register_hook($this, { + name => 'extract-heading', + 'filter.prereq' => \&filter_prereq, + 'filter.response' => \&filter_response, + }); +} + +# ----------------------------------------------------------------------------- +# $this->_config(). +# config for extract-heading. +# +sub _config +{ + my $config = [ + { + # 1. ぷりんと楽譜. + url => 'http://www.print-gakufu.com/*', + recv_limit => 8*1024, + extract => qr{(.*?)

}s, + #remove => qr/^ぷりんと楽譜 総合案内 ＞ /; + }, + { + # 2. zakzak. + url => 'http://www.zakzak.co.jp/*', + recv_limit => 10*1024, + extract => qr{(.*?)}s, + }, + { + # 3. nikkei. + url => 'http://www.nikkei.co.jp/*', + recv_limit => 16*1024, + extract => [ + qr{}s, + qr{

(.*?)

}s, + ], + remove => qr/^NIKKEI NET：/, + }, + { + # 4. nhkニュース. + url => 'http://www*.nhk.or.jp/news/*', + extract => qr{

(.*?)

}, + }, + { + # 5. creative (timeout). + url => 'http://*.creative.com/*', + timeout => 5, + }, + { + # 6. soundhouse news. + url => 'http://www.soundhouse.co.jp/shop/News.asp?NewsNo=*', + recv_limit => 50*1024, + extract => qr{(\s*.*?.*?)
}s, + }, + { + # 7. trac changeset. + url => '*/changeset/*', + extract => qr{

(.*?)

}s, + recv_limit => 8*1024, + }, + { + # 8a. amazon (page size). + url => 'http://www.amazon.co.jp/*', + recv_limit => 15*1024, + }, + { + # 8b. amazon (page size). + url => 'http://www.amazon.com/*', + recv_limit => 15*1024, + }, + { + # 9. ニコニコ動画 (メンテ画面). + status => 503, + url => 'http://www.nicovideo.jp/*', + extract => sub{ + if( m{
\s*

現在ニコニコ動画は(メンテナンス中)です。

\s*

(.*?)
}s ) + { + "$1: $2"; + }else + { + return; + } + }, + }, + { + # 10. sanspo. + url => 'http://www.sanspo.com/*', + recv_limit => 5*1024, + extract => qr{

(.*?)

}s, + }, + { + # 11. sakura. + url => 'http://www.sakura.ad.jp/news/archives/*', + recv_limit => 10*1024, + extract => qr{

(.*?)

}s, + }, + { + # 12. viewvc. + url => '*/viewcvs.cgi/*', + extract => qr{
(.*?)
}s, + }, + { + # 13. toshiba. + url => 'http://www.toshiba.co.jp/about/press/*', + extract => qr{(.*?)}s, + }, + { + # 14. tv-asahi. + url => 'http://www.tv-asahi.co.jp/ann/news/*', + extract => qr{(.*?)}s, + }, + ]; + $config; +} + +# ----------------------------------------------------------------------------- +# $this->filter_prereq($ctx, $arg). +# (impl:fetchtitle-filter) +# extract_heading/prereq. +# +sub filter_prereq +{ + my $this = shift; + my $ctx = shift; + my $arg = shift; + my $req = $arg->{req}; + + my $extract_list = $this->_config(); + + foreach my $conf (@$extract_list) + { + Mask::match($conf->{url}, $req->{url}) or next; + $DEBUG and $ctx->_debug($req, "debug: - $conf->{url}"); + if( my $new_recv_limit = $conf->{recv_limit} ) + { + $ctx->_apply_recv_limit($req, $new_recv_limit); + $DEBUG and $ctx->_debug($req, "debug: - recv_limit, $new_recv_limit"); + } + if( my $new_timeout = $conf->{timeout} ) + { + $ctx->_apply_timeout($req, $new_timeout); + $DEBUG and $ctx->_debug($req, "debug: - timeout, $new_timeout"); + } + } +} + +# ----------------------------------------------------------------------------- +# $this->filter_response($block, $req, $when, $type). +# (impl:fetchtitle-filter) +# extract_heading/response. +# +sub filter_response +{ + my $this = shift; + my $ctx = shift; + my $arg = shift; + my $req = $arg->{req}; + + my $response = $req->{response}; + if( !ref($response) ) + { + $DEBUG and $ctx->_debug($req, "debug: - - skip/not ref"); + return; + } + my $status = $req->{result}{status_code}; + + my $extract_list = $this->_config(); + + my $heading; + + foreach my $conf (@$extract_list) + { + Mask::match($conf->{url}, $req->{url}) or next; + $DEBUG and $ctx->_debug($req, "debug: - $conf->{url}"); + + my $extract_status = $conf->{status} || 200; + if( $status != $extract_status ) + { + $DEBUG and $ctx->_debug($req, "debug: - - status:$status not match with $extract_status"); + next; + } + + my $extract_list = $conf->{extract}; + if( ref($extract_list) ne 'ARRAY' ) + { + $extract_list = [$extract_list]; + } + foreach my $_extract (@$extract_list) + { + $DEBUG and $ctx->_debug($req, "debug: - $_extract"); + my $extract = $_extract; # sharrow-copy. + $extract = ref($extract) ? $extract : qr/\Q$extract/; + my @match; + if( ref($extract) eq 'CODE' ) + { + local($_) = $req->{result}{decoded_content}; + @match = $extract->($req); + }else + { + @match = $req->{result}{decoded_content} =~ $extract; + } + @match or next; + @match==1 && !defined($match[0]) and next; + $heading = $match[0]; + last; + } + defined($heading) or next; + $DEBUG and $ctx->_debug($req, "debug: - $heading"); + + $heading = $ctx->_fixup_title($heading); + + my $remove_list = $conf->{remove}; + if( ref($remove_list) ne 'ARRAY' ) + { + $remove_list = [$remove_list]; + } + foreach my $_remove (@$remove_list) + { + my $remove = $_remove; # sharrow-copy. + $remove = ref($remove) ? $remove : qr/\Q$remove/; + $heading =~ s/$remove//; + } + } + + if( defined($heading) && $heading =~ /\S/ ) + { + $heading =~ s/\s+/ /g; + $heading =~ s/^\s+//; + $heading =~ s/\s+$//; + + my $title = $req->{result}{result}; + $title = defined($title) && $title ne '' ? "$heading - $title" : $heading; + + $req->{result}{result} = $title; + } +} + + +# ----------------------------------------------------------------------------- +# End of Module. +# ----------------------------------------------------------------------------- +# ----------------------------------------------------------------------------- +# End of File. +# ----------------------------------------------------------------------------- +__END__ + +=encoding utf8 + +=for stopwords + YAMASHINA + Hio + ACKNOWLEDGEMENTS + AnnoCPAN + CPAN + RT + diff -urN /non-existant-dir/module/Auto/FetchTitle/Plugin/Mixi.pm tiarra-20080510/module/Auto/FetchTitle/Plugin/Mixi.pm --- /non-existant-dir/module/Auto/FetchTitle/Plugin/Mixi.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/Auto/FetchTitle/Plugin/Mixi.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,358 @@ +## ---------------------------------------------------------------------------- +# Auto::FetchTitle::Plugin::Mixi. +# ----------------------------------------------------------------------------- +# Mastering programmed by YAMASHINA Hio +# +# Copyright 2008 YAMASHINA Hio +# ----------------------------------------------------------------------------- +# $Id: Mixi.pm 10908 2008-05-01 16:57:24Z hio $ +# ----------------------------------------------------------------------------- +package Auto::FetchTitle::Plugin::Mixi; +use strict; +use warnings; +use base 'Auto::FetchTitle::Plugin'; + +# mixi のコンテンツの読み込み. +# 非公開な日記やコミュもあるので, +# 設定で許可した箇所のみの取得を基本とする. +# +# 現時点で取得できるページ: +# - ニュース +# - コミュニティ +# +# 未対応のページ: +# - マイミクページ +# - 日記 +# - アルバム, 動画, ミュージッック等. + +our $DEBUG; +*DEBUG = \$Auto::FetchTitle::DEBUG; + +1; + +# ----------------------------------------------------------------------------- +# $pkg->new(\%config). +# +sub new +{ + my $pkg = shift; + my $this = $pkg->SUPER::new(@_); + $this->{cookie_jar} = []; + $this; +} + +# ----------------------------------------------------------------------------- +# $obj->register($context). +# +sub register +{ + my $this = shift; + my $context = shift; + + $context->register_hook($this, { + name => 'mixi', + 'filter.prereq' => \&filter_prereq, + 'filter.response' => \&filter_response, + }); +} + +# ----------------------------------------------------------------------------- +# $this->detect_page($ctx, $req, $block). +# 取得できるページか確認. +# +sub detect_page +{ + my $this = shift; + my $ctx = shift; + my $req = shift; + my $block = shift; + + $DEBUG and $ctx->_debug(__PACKAGE__."#detect_page, $req->{url}."); + my @allow_pages = ( + { + name => 'login', + can_show => 0, + re => qr{^\Qhttp://mixi.jp/login.pl\E\z}, + }, + { + name => 'news-login', + can_show => 0, + re => qr{^\Qhttp://mixi.jp/issue_ticket.pl?}, + }, + { + name => 'login-check', + can_show => 0, + re => qr{^\Qhttp://mixi.jp/check.pl?}, + }, + { + name => 'news', + can_show => 1, + re => qr{^\Qhttp://news.mixi.jp/view_news.pl?}, + }, + { + name => 'news-list-media', + can_show => 1, + re => qr{^\Qhttp://news.mixi.jp/list_news_media.pl?}, + }, + { + name => 'news-list-category', + can_show => 1, + re => qr{^\Qhttp://news.mixi.jp/list_news_category.pl?}, + }, + { + name => 'community-top', + can_show => 1, + re => qr{^\Qhttp://mixi.jp/view_community.pl?id=\E(\d+)\z}, + keys => ['community'], + }, + { + name => 'community-bbs-list', + can_show => 1, + re => qr{^http://mixi\.jp/list_bbs\.pl\?id=(\d+)&type=(?:bbs|event|enquete)\z}, + keys => ['community'], + }, + { + name => 'community-bbs-show', + can_show => 1, + re => qr{^http://mixi\.jp/view_(bbs|event|enquete)\.pl\?(?:page=\d+&)?id=\d+&(?:comment_count=\d+&)?comm_id=(\d+)(?:&page=all)?\z}, + keys => ['','community'], + }, + { + name => 'friend', + can_show => 1, + re => qr{^http://mixi\.jp/show_friend.pl\?id=(\d+)\z}, + keys => ['friend'], + }, + { + name => 'friend-list-diary/album/review/comment', + can_show => 1, + re => qr{^http://mixi\.jp/list_(?:diary|album|review|comment)\.pl\?(?:page=\d+&)?id=(\d+)(?:&year=\d+&month=\d+(?:&day=\d+)?)?\z}, + keys => ['friend'], + }, + { + name => 'friend-list-video/music', + can_show => 1, + re => qr{^http://(video|music)\.mixi\.jp/list_\1\.pl\?id=(\d+)\z}, + keys => ['', 'friend'], + }, + { + name => 'friend-diary', + can_show => 1, + re => qr{^http://mixi\.jp/view_diary\.pl\?id=\d+&owner_id=(\d+)\z}, + keys => ['friend'], + }, + { + name => 'friend-video', + can_show => 1, + re => qr{^http://video\.mixi\.jp/view_video\.pl\?owner_id=(\d+)&video_id=\d+\z}, + keys => ['friend'], + }, + { + name => 'friend-review', + can_show => 1, + re => qr{^http://mixi\.jp/view_item\.pl?reviewer_id=(\d+)&id=\d+\z}, + keys => ['friend'], + }, + ); + + foreach my $page (@allow_pages) + { + $DEBUG and $ctx->_debug($req, "- check $page->{name}."); + my @values = $req->{url} =~ $page->{re}; + my $keys = $page->{keys} || ['']; + if( @values != @$keys) + { + $DEBUG and $ctx->_debug($req, "- - not match."); + next; + } + $page->{values} = \@values; + + foreach my $idx (0..$#$keys) + { + my $key = $keys->[$idx]; + $key or next; + my $val = $page->{values}[$idx]; + my $conf_key = "mixi_$key"; + my $allowed; + foreach my $conf_val ($block->$conf_key('all')) + { + $allowed ||= $conf_val && $conf_val == $val; + } + if( !$allowed ) + { + $DEBUG and $ctx->_debug($req, "- - not match / mixi-$key = $val"); + return; + } + } + $DEBUG and $ctx->_debug($req, "- - match."); + return $page; + } + return undef; +} + +# ----------------------------------------------------------------------------- +# $this->filter_prereq($ctx, $arg). +# (impl:fetchtitle-filter) +# mixi/prereq. +# +sub filter_prereq +{ + my $this = shift; + my $ctx = shift; + my $arg = shift; + + my $req = $arg->{req}; + my $block = $arg->{block}; + + $DEBUG and $ctx->_debug($req, "- mixi.check multiple login pages."); + my $seen = { login => 0, news_login => 0 }; + my $prev = $req; + while( $prev ) + { + if( $prev->{url} eq 'http://mixi.jp/login.pl' ) + { + ++$seen->{login}; + $DEBUG and $ctx->_debug($req, "- login-page: $prev->{url}"); + }elsif( $prev->{url} =~ m{^\Qhttp://mixi.jp/issue_ticket.pl?\E} ) + { + ++$seen->{news_login}; + $DEBUG and $ctx->_debug($req, "- news-login-page: $prev->{url}"); + }else + { + $DEBUG and $ctx->_debug($req, "- normal-page: $prev->{url}"); + } + $prev = $prev->{old}; + } + if( $seen->{login} >= 2 || $seen->{news_login} >= 2 ) + { + my $msg = "mixi multiple login pages (login=$seen->{login},news_login=$seen->{news_login})"; + $ctx->_debug($req, $msg); + #$req->{response} = "mixi multiple login pages (login=$seen->{login},news_login=$seen->{news_login})"; + #return; + } + + my $allowed = $this->detect_page($ctx, $req, $block); + if( !$allowed ) + { + $req->{response} = "requested page in mixi is not permitted"; + return; + } + + $ctx->_apply_recv_limit($req, 12*1024); + + $ctx->_add_cookie_header($req, $this->{cookie_jar}); +} + +# ----------------------------------------------------------------------------- +# $this->filter_response($ctx, $arg). +# (impl:fetchtitle-filter) +# mixi/response. +# +sub filter_response +{ + my $this = shift; + my $ctx = shift; + my $arg = shift; + + my $req = $arg->{req}; + my $block = $arg->{block}; + + if( $req->{parsed_cookies} ) + { + $ctx->_merge_cookies($this->{cookie_jar}, $req->{parsed_cookies}); + } + + if( !ref($req->{response}) ) + { + $DEBUG and $ctx->_debug($req, "debug: - - skip/not ref"); + return; + } + + my $result = $req->{result}; + if( $result->{decoded_content} =~ m{
(.*)
}s ) + { + my $path = $1; + my $form = $2; + $DEBUG and $ctx->_debug($req, __PACKAGE__."#_filter_mixi_response, login form found ($path)"); + $this->_do_login($ctx, $req, $block, $form, $path); + }else + { + my $page = $this->detect_page($ctx, $req, $block); + if( !$page ) + { + $req->{response} = "requested page in mixi is not permitted"; + return; + } + } +} + +sub _do_login +{ + my $this = shift; + my $ctx = shift; + my $req = shift; + my $block = shift; + my $form = shift; + my $path = shift; + + my @post; + my $redir_url = 'http://'.($req->{headers}{Host}||'mixi.jp').$path; + while( $form =~ m{}sg ) + { + my $attrs = $1; + my %attrs = $attrs =~ /(\w+)="(.*?)"/g; + my $name = $attrs{name} or next; + my $value = $attrs{value}; + $name = $ctx->_unescapeHTML($name); + $value &&= $ctx->_unescapeHTML($value); + if( $name eq 'email' ) + { + $value = $ctx->_decode_value($this->{config}->mixi_user); + if( !$value ) + { + $ctx->_debug($req, "no mixi-user"); + return; + } + } + if( $name eq 'password' ) + { + $value = $ctx->_decode_value($this->{config}->mixi_pass); + if( !$value ) + { + $ctx->_debug($req, "no mixi-pass"); + return; + } + } + defined($value) or next; + $value =~ s{([^\w./])}{sprintf('%%%02x',unpack("C",$1))}ge; + push(@post, "$name=$value"); + } + if( @post ) + { + $req->{result}{redirect} = { + url => $redir_url, + method => 'POST', + content => join('&', @post), + max_redirects => 7, + }; + } +} + +# ----------------------------------------------------------------------------- +# End of Module. +# ----------------------------------------------------------------------------- +# ----------------------------------------------------------------------------- +# End of File. +# ----------------------------------------------------------------------------- +__END__ + +=encoding utf8 + +=for stopwords + YAMASHINA + Hio + ACKNOWLEDGEMENTS + AnnoCPAN + CPAN + RT + diff -urN /non-existant-dir/module/Auto/FetchTitle/Plugin/TouhouReplay.pm tiarra-20080510/module/Auto/FetchTitle/Plugin/TouhouReplay.pm --- /non-existant-dir/module/Auto/FetchTitle/Plugin/TouhouReplay.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/Auto/FetchTitle/Plugin/TouhouReplay.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,143 @@ +## ---------------------------------------------------------------------------- +# Auto::FetchTitle::Plugin::TouhouReplay. +# ----------------------------------------------------------------------------- +# Mastering programmed by YAMASHINA Hio +# +# Copyright 2008 YAMASHINA Hio +# ----------------------------------------------------------------------------- +# $Id: TouhouReplay.pm 10891 2008-05-01 12:18:10Z hio $ +# ----------------------------------------------------------------------------- +package Auto::FetchTitle::Plugin::TouhouReplay; +use strict; +use warnings; +use base 'Auto::FetchTitle::Plugin'; + +# 弾幕形STG, 東方シリーズのリプレイファイルの表示. +# my $replay = Touhou::ReplayFile->parse($response->{Content}); +# my $reply = $replay->shortdesc(); +# ##==> "東方風神録 HIO. 215,663,790 [Easy/魔理沙(貫通)/Clear]"; + +our $HAS_TOUHOU_REPLAYFILE = do{ + eval{ local($SIG{__DIE__}) = 'DEFAULT'; require Touhou::ReplayFile }; + @$ or Module::Use->import(qw(Touhou::ReplayFile)); + !$@; +}; + +our $DEBUG; +*DEBUG = \$Auto::FetchTitle::DEBUG; + +1; + +# ----------------------------------------------------------------------------- +# $pkg->new(\%config). +# +sub new +{ + my $pkg = shift; + my $this = $pkg->SUPER::new(@_); + $this; +} + +# ----------------------------------------------------------------------------- +# $obj->register($context). +# +sub register +{ + my $this = shift; + my $context = shift; + + $context->register_hook($this, { + name => 'touhou-replay', + 'filter.prereq' => \&filter_prereq, + 'filter.response' => \&filter_response, + }); +} + +# ----------------------------------------------------------------------------- +# $this->filter_prereq($ctx, $arg); +# (impl:fetchtitle-filter) +# touhou-replay/prereq. +# +sub filter_prereq +{ + my $this = shift; + my $ctx = shift; + my $arg = shift; + + my $req =$arg->{req}; + + if( !$HAS_TOUHOU_REPLAYFILE ) + { + $DEBUG and $ctx->_debug($req, "debug: - - no Touhou::ReplayFile (private module)"); + return; + } + + $ctx->_apply_recv_limit($req, 100*1024); + + $this; +} + +# ----------------------------------------------------------------------------- +# $this->filter_response($ctx, $arg). +# (impl:fetchtitle-filter) +# touhou-replay/response. +# +sub filter_response +{ + my $this = shift; + my $ctx = shift; + my $arg = shift; + + my $req = $arg->{req}; + + $HAS_TOUHOU_REPLAYFILE or return; + + my $response = $req->{response}; + if( !ref($response) ) + { + $DEBUG and $ctx->_debug($req, "debug: - - skip/not ref"); + return; + } + if( $req->{result}{status_code}!=200 ) + { + $DEBUG and $ctx->_debug($req, "debug: - - skip/not success:$req->{result}{status_code}"); + return; + } + + my @opts; + + my $len = $req->{result}{content_length}; + if( defined($len) ) + { + $len =~ s/(?<=\d)(?=(\d\d\d)+(?!\d))/,/g; + $len = "$len bytes"; + push(@opts, $len); + } + + my $replay = Touhou::ReplayFile->parse($response->{Content}); + my $reply = $replay->shortdesc(); + if( @opts ) + { + $reply .= " (".join("; ",@opts).")"; + } + $req->{result}{result} = $reply; +} + +# ----------------------------------------------------------------------------- +# End of Module. +# ----------------------------------------------------------------------------- +# ----------------------------------------------------------------------------- +# End of File. +# ----------------------------------------------------------------------------- +__END__ + +=encoding utf8 + +=for stopwords + YAMASHINA + Hio + ACKNOWLEDGEMENTS + AnnoCPAN + CPAN + RT + diff -urN /non-existant-dir/module/Auto/FetchTitle/Plugin.pm tiarra-20080510/module/Auto/FetchTitle/Plugin.pm --- /non-existant-dir/module/Auto/FetchTitle/Plugin.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/Auto/FetchTitle/Plugin.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,66 @@ +## ---------------------------------------------------------------------------- +# Auto::FetchTitle::Plugin. +# ----------------------------------------------------------------------------- +# Mastering programmed by YAMASHINA Hio +# +# Copyright 2008 YAMASHINA Hio +# ----------------------------------------------------------------------------- +# $Id: Plugin.pm 10891 2008-05-01 12:18:10Z hio $ +# ----------------------------------------------------------------------------- +package Auto::FetchTitle::Plugin; +use strict; +use warnings; + +use Scalar::Util qw(weaken); + +1; + +# ----------------------------------------------------------------------------- +# $pkg->new(\%config). +# +sub new +{ + my $pkg = shift; + my $config = shift; + my $this = bless {}, $pkg; + $this->{config} = $config; + $this->{hook} = undef; + $this; +} + +# ----------------------------------------------------------------------------- +# $obj->register($context). +# +sub register +{ + my $this = shift; + my $context = shift; + + #$context->register_hook($this, { + # name => 'filter-name', + # 'plugin.initialize' => \&plugin_initialize, + # 'plugin.finalize' => \&plugin_finalize, + # 'filter.prereq' => \&filter_prereq, + # 'filter.response' => \&filter_response, + #}); +} + + +# ----------------------------------------------------------------------------- +# End of Module. +# ----------------------------------------------------------------------------- +# ----------------------------------------------------------------------------- +# End of File. +# ----------------------------------------------------------------------------- +__END__ + +=encoding utf8 + +=for stopwords + YAMASHINA + Hio + ACKNOWLEDGEMENTS + AnnoCPAN + CPAN + RT + diff -urN /non-existant-dir/module/Auto/FetchTitle.pm tiarra-20080510/module/Auto/FetchTitle.pm --- /non-existant-dir/module/Auto/FetchTitle.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/Auto/FetchTitle.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,2287 @@ +## ---------------------------------------------------------------------------- +# Auto::FetchTitle. +# ----------------------------------------------------------------------------- +# Mastering programmed by YAMASHINA Hio +# +# Copyright 2008 YAMASHINA Hio +# ----------------------------------------------------------------------------- +# $Id: FetchTitle.pm 11015 2008-05-03 06:42:38Z hio $ +# ----------------------------------------------------------------------------- +package Auto::FetchTitle; +use strict; +use warnings; +use base qw(Module); +use Module::Use qw(Auto::Utils Tools::HTTPClient); +use Module::Use qw(Auto::FetchTitle::Plugin); +use Auto::FetchTitle::Plugin; +use Auto::Utils; +use Configuration; # Configuration::Hook. +use Mask; +use Multicast; +use Scalar::Util qw(weaken); +use Tiarra::Encoding; +use Tools::HTTPClient; + +our $VERSION = '0.02'; + +# 全角空白. +our $U_IDEOGRAPHIC_SPACE = "\xe3\x80\x80"; +our $RE_WHITESPACES = qr/(?:\s|$U_IDEOGRAPHIC_SPACE)+/; + +# デバッグフラグ. +# configや$this->{debug}の値もlocal()内で反映される. +our $DEBUG = 0; + +our $ENCODER = 'Unicode::Japanese'; +use Unicode::Japanese; + +# LATIN-1 を JIS で通る物にマッピング. +# +our @LATIN1_MAP = qw( + 0 0 0 ∫ 0 … † ‡ ^ ‰ s < 0 OE Z 0 + 0 0 0 0 0 0 0 0 ~ TM S > 0 oe z y + 0 ! ¢ £ 0 \ 0 § ¨ (C) 0 《 ￢ 0 (R) ￣ + ゜ ± 0 0 ´ μ ¶ ・ 0 0 0 》 1/4 1/2 3/4 ? + A A A A A A AE C E E E E I I I I + D N O O O O O × O U U U U Y TH ss + a a a a a a ae c e e e e i i i i + th n o o o o o ÷ o u u u u y th y +); +$LATIN1_MAP[0x82-0x80] = ','; +$LATIN1_MAP[0xa0-0x80] = ' '; + +our $HAS_IMAGE_EXIFTOOL = do{ + eval{ local($SIG{__DIE__}) = 'DEFAULT'; require Image::ExifTool; }; + !$@; +}; + +our $MAX_ACTIVE_REQUESTS = 3; +our $MAX_URLS_IN_SINGLE_MESSAGE = 3; +our $DEFAULT_RECV_LIMIT = 4*1024; # 4K bytes. +our $DEFAULT_TIMEOUT = 3; # sec. +our $MAX_REDIRECTS = 5; +our $MAX_REDIRECTS_LIMIT = 20; +our $PROCESSING_LIMIT_TIME = 60; # secs. + +$|=1; +1; + +# ----------------------------------------------------------------------------- +# [処理の流れ] +# FLOW-1st: +# new(). +# +# message_arrived(). +# +# destruct(). +# +# FLOW-2nd: tiarra-module handler/$obj->message_arrived +# $obj->_dispatch(..). +# +# $obj->_process_command(..). +# return. +# +# $obj->extract_urls(..). +# $obj->_check_mask($url). +# $obj->_create_request(..). +# $obj->_add_request($req). +# (drop orphan requests/_close_request) +# $obj->_start_request($req). +# +# FLOW-3rd: _start_request() +# setup headers. +# apply prereq filter. +# check redirects on prereq. +# start HTTP client. +# finish Callback => $obj->_request_finished($req, @_). +# ProgressCallback => $obj->_request_progress($req, @_) => _request_finished(). +# +# FLOW-4th: _request_finished. +# $obj->_close_request($req). +# $obj->_reply(). +# +# FLOW-5th: _close_request(). +# $obj->_close_head_request(). +# $obj->_parse_response(). +# apply response filter. +# check redirects on response/_start_request(). + +# ----------------------------------------------------------------------------- +# my $obj = $pkg->new(). +# +sub new +{ + my $pkg = shift; + my $this = $pkg->SUPER::new(@_); + + $this->{loaded_at} = time; + $this->{debug} = $this->config->debug; + + $this->{request_queue} = {}; # { $ch_full => [] }. + $this->{reply_queue} = undef; + $this->{reply_timer} = undef; + + $this->{mask} = undef; + $this->{plugins} = undef; + $this->{hooks} = undef; + + $this->_reload_config(); + $this->_reload_plugins(); + + my $weaken_this = $this; + weaken($weaken_this); + $this->{conf_hook} = Configuration::Hook->new(sub{ + my $this = $weaken_this or return; + $this->_reload_config(); + $this->_reload_plugins(); + })->install('reloaded'); + + return $this; +} + +# ----------------------------------------------------------------------------- +# $obj->destruct(). +# +sub destruct +{ + my $this = shift; + if( $this->{reply_timer} ) + { + $this->{reply_timer}->uninstall(); + $this->{reply_timer} = undef; + } + if( $this->{conf_hook} ) + { + $this->{conf_hook}->uninstall(); + $this->{conf_hook} = undef; + } + + $this->run_hook('plugin.finalize', undef); +} + +# ----------------------------------------------------------------------------- +# $obj->_reload_config(). +# +sub _reload_config +{ + my $this = shift; + + $this->_runloop->notify_msg(__PACKAGE__.", reload config."); + $this->{debug} = $this->config->debug; + if( $this->{debug} && $this->{debug} =~ /^(off|no|false)/i ) + { + $this->{debug} = undef; + } + + $this->{mask} = []; + foreach my $line ($this->config->mask('all')) + { + my ($ch_mask, @opts) = split(' ', $line); + $ch_mask or next; + + # #Tiarra@ircnet:*.jp か $#Tiarra:*.jp@ircnet か + # 紛らわしいのでmaskがどっちでもマッチするように. + # (正しくは前者) + # マッチさせるチャンネル名はプログラム内の物なので必ず前者形式のはず. + my ($ch_mask_short, $ch_mask_net, $explicit) = Multicast::detach($ch_mask); + if( $explicit ) + { + $ch_mask = Multicast::attach($ch_mask_short, $ch_mask_net); + } + + my @conf; + while( @opts && $opts[0] =~ s/^&// ) + { + my $confkey = shift @opts; + push(@conf, $this->config->get("conf-$confkey", 'block')); + } + my $url_mask = shift @opts || '*'; + my $mask = { + _line => $line, + ch_mask => $ch_mask, + url_mask => $url_mask, + conf => \@conf, + }; + push(@{$this->{mask}}, $mask); + } +} + +# ----------------------------------------------------------------------------- +# @plugins = $obj->plugins(). +# +sub plugins +{ + my $this = shift; + + if( !$this->{plugins} ) + { + $this->_reload_plugins(); + } + + @{$this->{plugins}}; +} + +# ----------------------------------------------------------------------------- +# $obj->_reload_plugins(). +# reload plugins list. +# +sub _reload_plugins +{ + my $this = shift; + + my $loader; + my @plugins; + eval{ + local($SIG{__DIE__}) = 'DEFAULT'; + require Module::Pluggable; + Module::Pluggable->import(sub_name => '_load_plugins', require => 1); + @plugins = $this->_load_plugins; + @plugins = grep{ !/::SUPER$/ } @plugins; + $loader = 'Module::Pluggable'; + }; + if( $@ ) + { + RunLoop->shared_loop->notify_msg("Module::Pluggable failed: $@"); + $loader = 'local'; + @plugins = $this->_find_local_plugins; + } + + $this->{plugins} = []; + $this->{hooks} = {}; + + $this->register_hook(undef, { + name => 'basic', + 'filter.prereq' => \&_filter_basic_prereq, + old => 1, + }); + $this->register_hook(undef, { + name => 'cookie', + 'filter.prereq' => \&_filter_cookie_prereq, + old => 1, + }); + $this->register_hook(undef, { + name => 'uploader', + 'filter.prereq' => \&_filter_uploader_prereq, + 'filter.response' => \&_filter_uploader_response, + old => 1, + }); + + RunLoop->shared_loop->notify_msg(__PACKAGE__."#_reload_plugins, ($loader) plugins:"); + if( @plugins ) + { + Module::Use->import(@plugins); + my $plugins_conf = $this->config->plugins; + $plugins_conf = ref($plugins_conf) && UNIVERSAL::isa($plugins_conf, 'Configuration::Block') && $plugins_conf; + foreach my $pkgname (@plugins) + { + my $mininame = $pkgname; + $mininame =~ s/^Auto::FetchTitle::Plugin:://; + my $plugin = { + module => $pkgname, + object => undef, + }; + eval "require $pkgname; 1"; $@ and RunLoop->shared_loop->notify_msg("load $pkgname: $@"); + my $conf = $plugins_conf && $plugins_conf->get($mininame); + $conf = ref($conf) && UNIVERSAL::isa($conf, 'Configuration::Block') ? $conf : Configuration::Block->new(); + my $obj = eval{ $pkgname->new($conf); }; + if( !$obj ) + { + RunLoop->shared_loop->notify_msg("- $pkgname ".($@?"error $@":"ignore")); + next; + } + RunLoop->shared_loop->notify_msg("+ $pkgname $obj"); + $plugin->{object} = $obj; + push(@{$this->{plugins}}, $plugin); + $obj->register($this); + } + }else + { + RunLoop->shared_loop->notify_msg("- none"); + } + + $this->run_hook('plugin.initialize', undef); +} + +# ----------------------------------------------------------------------------- +# $obj->_find_local_plugins(). +# rollback of Module::Pluggable. +# +sub _find_local_plugins +{ + my $this = shift; + my $dir = 'module/Auto/FetchTitle/Plugin'; + my $modbase = 'Auto::FetchTitle::Plugin'; + if( opendir(my $dh, $dir) ) + { + my @files = readdir($dh); + closedir($dh); + my @plugins; + foreach my $file (@files) + { + $file =~ /^([a-zA-Z_]\w*)\.pm\z/ or next; + my $name = $1; # untaint. + my $modpath = "$dir/$name.pm"; + my $modname = $modbase.'::'.$name; + eval{ local($SIG{__DIE__}) = 'DEFAULT'; require $modpath; }; + if( $@ ) + { + RunLoop->shared_loop->notify_msg("_find_local_plugins, load $modpath failed: $@"); + next; + } + push(@plugins, $modname); + } + return @plugins; + }else + { + RunLoop->shared_loop->notify_msg("_find_local_plugins, opendir($dir): $!"); + return; + } +} + +sub register_hook +{ + my $this = shift; + my $plugin_obj = shift; + my $spec = shift; + my $name = $spec->{name} or die "no hook name for $plugin_obj"; + $this->{hooks}{$name} and die "hook $name is already registered"; + + $spec->{object} = $plugin_obj; + weaken($spec->{object}); + + $this->{hooks}{$name} = $spec; + $plugin_obj->{hook} = $spec; +} + +# ----------------------------------------------------------------------------- +# $obj->message_arrived($msg, $sender). +# (impl:tiarra-module) +# +sub message_arrived +{ + my $this = shift; + my $msg = shift; + my $sender = shift; + + my($RESULT) = [$msg]; + + # サーバーからのメッセージ以外無視. + # (=クライアントからのメッセージを無視) + #if( !$sender->isa('IrcIO::Server') ) + #{ + # return @$RESULT; + #} + + # PRIVMSG は無視. + if( $msg->command ne 'PRIVMSG' ) + { + return @$RESULT; + } + + eval{ + $this->_dispatch($msg, $sender, $RESULT); + }; + if( $@ ) + { + my $ch = Auto::Utils::get_full_ch_name($msg, 0); + $this->_reply($ch, "DIED: $@"); + } + + return @$RESULT; +} + +# ----------------------------------------------------------------------------- +# $obj->_dispatch($msg, $sender, $result). +# dispatcher. +# +sub _dispatch +{ + my $this = shift; + my $msg = shift; + my $sender = shift; + my $result = shift; + + my ($get_ch_name,$reply_in_ch,$reply_as_priv,$reply_anywhere, $get_full_ch_name) + = Auto::Utils::generate_reply_closures($msg,$sender,$result); + my $full_ch_name = $get_full_ch_name->(); + + local($DEBUG) = $DEBUG || $this->{debug}; + + my $msgval = $msg->param(1); + $DEBUG and $this->_debug($full_ch_name, "debug: msgval = [$msgval]"); + + # デバッグ用コマンド. + + my $debug_command = $this->config->debug_command || 'fetchtitle:'; + if( $msgval =~ s/^\Q$debug_command\E(?:$RE_WHITESPACES)*// ) + { + $DEBUG and $this->_debug($full_ch_name, "debug: goto process command"); + $this->_process_command($msg, $sender, $result, $msgval); + return; + } + + $DEBUG and $this->_debug($full_ch_name, "debug: goto extract urls"); + my @urls = $this->_extract_urls($msgval); + $DEBUG and $this->_debug($full_ch_name, "debug: ".@urls." url".(@urls==1?'':'s')." found"); + if( !@urls ) + { + return; + } + + my $count = 0; + foreach my $_url (@urls) + { + if( $count >= $MAX_URLS_IN_SINGLE_MESSAGE ) + { + $DEBUG and $this->_debug($full_ch_name, "debug: too many urls"); + last; + } + $DEBUG and $this->_debug($full_ch_name, "debug: check $_url"); + my $url = $_url; + $url =~ s{^ttp(s?)://}{http$1://}; + $url =~ m{^https?://} or next; + $url =~ s{^https?://[-\w.\x80-\xff]+\z}{$url/}; + $DEBUG && $url ne $_url and $this->_debug($full_ch_name, "debug: fixed url is $url"); + + # 処理対象か確認. + my $matched = $this->_check_mask($full_ch_name, $url); + if( !$matched ) + { + $DEBUG and $this->_debug($full_ch_name, "debug: no match"); + next; + } + + ++$count; + + # リクエストの生成. + my $req = $this->_create_request($full_ch_name, $url, $matched); + $req->{cookie_jar} = []; + #$this->_debug($req, "new-request: ".Data::Dumper->new([$req])->Indent(0)->Dump); + $this->_add_request($req); + } + + $DEBUG and $this->_debug($full_ch_name, "debug: dispatch done."); + return; +} + +# ----------------------------------------------------------------------------- +# $req = $this->_create_request($full_ch_name, $url, $mask_conf); +# (補足までにリクエストが生成されるのは_dispatch()と_redirect()の２箇所) +# +sub _create_request +{ + my $this = shift; + my $full_ch_name = shift; + my $url = shift; + my $mask_conf = shift; + + my $anchor; + ($url, $anchor) = split(/#/, $url, 2); + my $req = { + old => undef, # undef for first (non-redirect) request. + ini_req => undef, # undef for first (non-redirect) request. + redirected => undef, # nr of redirects (integer). + applied_filters => undef, # array-ref. + + url => $url, + anchor => $anchor, + full_ch_name => $full_ch_name, + mask => $mask_conf, + + requested_at => time, + started_at => undef, + active => undef, + timer => undef, + + httpclient => undef, + addr_checked => undef, + headers => {}, + cookies => [], # cookies for this request. + recv_limit => $DEFAULT_RECV_LIMIT, + max_redirects=> undef, # integer. + timeout => undef, + response => undef, + result => undef, + method => undef, + content => undef, + cookie_jar => undef, # session cookies, set at initial _create_request() call. + }; + $req; +} + +# ----------------------------------------------------------------------------- +# $matched_mask = $this->_check_mask($full_ch_name, $url); +# チャンネルとURLから, 利用する mask: 行を１つ抽出. +# マッチした許可マスク定義HASH-refを返す. +# { +# ch_mask => $ch_mask, # mask: のチャンネル指定部分(必須). +# url_mask => $url_mask, # mask: のURL指定部分(省略'*'). +# conf => \@conf, # mask: のconfに対応するブロックのリスト(Configuration::Block). +# }; +# +sub _check_mask +{ + my $this = shift; + my $full_ch_name = shift; + my $url = shift; + + foreach my $mask (@{$this->{mask}}) + { + my $chan_match = Mask::match($mask->{ch_mask}, $full_ch_name); + if( !$chan_match ) + { + defined($chan_match) or next; + $DEBUG and $this->_debug($full_ch_name, "debug: - channel denied: [$full_ch_name] [$mask->{ch_mask}]"); + return undef; + } + + my $url_match = Mask::match($mask->{url_mask}, $url); + if( !$url_match ) + { + defined($url_match) or next; + $DEBUG and $this->_debug($full_ch_name, "debug: - url denied: [$url] [$mask->{url_mask}]"); + return undef; + } + + return $mask; + } + undef; +} + +# ----------------------------------------------------------------------------- +# my @urls = $pkg->_extract_urls($text). +# extract all url like strings (include ftp://, ttp://). +# +sub _extract_urls +{ + my $this = shift; + my $msgval = shift; + + my $pars = { + '<' => '>', + '(' => ')', + '[' => ']', + }; + + my @tokens = split( $RE_WHITESPACES, $msgval ); + my @urls = map{ m{ (\S?\w+://\S+) }gx } @tokens; + foreach my $url (@urls) + { + my $par_begin = substr($url, 0, 1); + my $par_end = $pars->{$par_begin}; + $par_end or next; + $url =~ s/^\Q$par_begin\E//; + $url =~ s/\Q$par_end\E\z//; + } + + @urls; +} + +# ----------------------------------------------------------------------------- +# $obj->_process_command($msg, $sender, $result, $msgval). +# process "fetchtitle: " commands. +# +sub _process_command +{ + my $this = shift; + my $msg = shift; + my $sender = shift; + my $result = shift; + my $msgval = shift; + + my $ch_full = Auto::Utils::get_full_ch_name($msg, 0); + my $msg_prefix = $msg->prefix; + + $DEBUG and $this->_debug($ch_full, "debug: check debug-mask for $ch_full, $msg_prefix"); + my $accepted = Mask::match_deep_chan([$this->config->debug_mask('all')], $msg_prefix, $ch_full); + if( !$accepted ) + { + $this->_reply($ch_full, "(not acceptable)"); + return; + } + + my ($cmd, $rest) = split( $RE_WHITESPACES, $msgval, 2); + my $lc_cmd = lc($cmd); + if( $lc_cmd eq 'version' ) + { + $this->_reply($ch_full, "version: $VERSION"); + }elsif( $lc_cmd eq 'loaded-at' ) + { + $this->_reply($ch_full, "loaded-at: ".localtime($this->{loaded_at})); + }elsif( $lc_cmd eq 'debug' ) + { + if( $rest && $rest =~ /^on/ ) + { + $this->{debug} = 1; + $this->_reply($ch_full, "debug: turned on"); + }elsif( $rest && $rest =~ /^off/ ) + { + $this->{debug} = undef; + $this->_reply($ch_full, "debug: turned off"); + }else + { + $this->_reply($ch_full, "debug: current flag is ".($this->{debug} ? "on" : "off")); + } + }else + { + $this->_reply($ch_full, "unknown-command: $lc_cmd"); + } +} + + +# ----------------------------------------------------------------------------- +# $obj->_add_request($req). +# +sub _add_request +{ + my $this = shift; + my $req = shift; + + $req->{url} or die "no url"; + + my $full_ch_name = $req->{full_ch_name}; + my $queue = ($this->{request_queue}{$full_ch_name} ||= []); + push(@$queue, $req); + + + # drop orphan requests if exists. + $this->_close_request($full_ch_name); + + if( (grep{$_->{active}} @$queue) >= $MAX_ACTIVE_REQUESTS ) + { + return; + } + my $real_req = $this->_start_request($req); + if( $real_req != $req ) + { + # _start_request() で修正されていたら差し替え. + @$queue = map{ $_==$req ? $real_req : $_ } @$queue; + } +} + +# ----------------------------------------------------------------------------- +# $val = _decode_value($val). +# +sub _decode_value +{ + my $val = shift; + @_ and $val = shift; # for OO-style. + + if( $val && $val =~ s/^\{(.*?)\}// ) + { + my $type = $1; + if( $type =~ /^(B|B64|BASE64)\z/ ) + { + eval { require MIME::Base64; }; + if( $@ ) + { + die "no MIME::Base64"; + } + $val = MIME::Base64::decode($val); + }else + { + die "unsupported packed value, type=$type"; + } + } + $val; +} + +# ----------------------------------------------------------------------------- +# $new_req = $obj->_start_request($req). +# $new_req は処理前リダイレクトされて$reqとは変わっていることもある. +# +sub _start_request +{ + my $this = shift; + my $req = shift; + + $req->{started_at} = time; + $DEBUG and $this->_debug($req, "debug: start request $req->{full_ch_name} $req->{url}"); + + $this->_request_filter(prereq => $req); + while( $req->{redirect} && !$req->{response} ) + { + my $new_req = $this->_redirect($req->{redirect}, $req, $req); + if( !$new_req || $new_req->{response} ) + { + last; + } + $req = $new_req; + $req->{started_at} = time; + $this->_request_filter(prereq => $req); + } + + if( $req->{response} ) + { + $req->{active} = 1; + $req->{httpclient} = undef; + $DEBUG and $this->_debug($req, "debug: request has response before start connection"); + $this->_close_request($req->{full_ch_name}); + return $req; + } + + my $headers = $req->{headers}; + + my $agent_name = $headers->{'User-Agent'}; + if( !defined($agent_name) || $agent_name eq '' ) + { + $DEBUG and $this->_debug($req, "debug: drop User-Agent header"); + delete $headers->{'User-Agent'}; + } + + my $cookies = join('; ', map{ "$_->{name}=$_->{value}" } @{$req->{cookies}}); + if( $req->{headers}{Cookie} ) + { + $req->{headers}{Cookie} = "$cookies; $req->{headers}{Cookie}"; + }else + { + if( $cookies ) + { + $req->{headers}{Cookie} = $cookies; + }else + { + delete $req->{headers}{Cookie}; + } + } + $DEBUG and $this->_debug($req, "Cookie: ".($req->{headers}{Cookie} || '(none)')); + + my $timeout = $req->{timeout} || $this->config->timeout || $DEFAULT_TIMEOUT; + $DEBUG and $this->_debug($req, "debug: create http-client, timeout=$timeout"); + my $httpclient = Tools::HTTPClient->new( + Method => $req->{method} || 'GET', + Url => $req->{url}, + Header => $headers, + Timeout => $timeout, + Content => $req->{content}, + ); + $DEBUG and $this->_debug($req, "debug: start http-client: $req->{url}"); + + weaken(my $_this = $this); + eval{ + $httpclient->start( + Callback => sub{ + my $this = $_this; + $DEBUG and print "Callback.this = $this\n"; + $this or return RunLoop->shared_loop->notify_error(__PACKAGE__."#_start_request/httpclient.Callback, object was deleted."); + local($DEBUG) = $DEBUG || $this->{debug}; + $DEBUG and $this->_debug($req, "debug: http-client finished: @_"); + $this->_request_finished($req, @_); + }, + ProgressCallback => sub{ + my $this = $_this; + $this or return RunLoop->shared_loop->notify_error(__PACKAGE__."#_start_request/httpclient.Callback, object was deleted."); + local($DEBUG) = $DEBUG || $this->{debug}; + $DEBUG and $this->_debug($req, "debug: http-client progress @_"); + $this->_request_progress($req, @_); + }, + ); + }; + if( $@ ) + { + my $err = "$@"; + $err =~ s/$RE_WHITESPACES\z//; + if( $err =~ m{Failed to connect: (\S+):\d+, IO::Socket::INET: Bad hostname '\1' at } ) + { + $err = 'no host to connect'; + } + $err =~ s{Failed to connect: \S+:\d+, IO::Socket::INET: (?:connect: )?(.*) at .*}{$1}; + $req->{response} = $err; + $this->_request_finished($req, $err); + return $req; + } + + $req->{active} = 1; + $req->{httpclient} = $httpclient; + $DEBUG and $this->_debug($req, "debug: request has marked as active"); + + $req; +} + +# ----------------------------------------------------------------------------- +# $obj->_apply_recv_limit($req, $new_val). +# $req->{recv_limit} に現在値と新しい値の大きな方を設定. +# +sub _apply_recv_limit +{ + my $this = shift; + my $req = shift; + my $new_value = shift; + my $cur_value = $req->{recv_limit} || 0; + + $req->{recv_limit} = $new_value > $cur_value ? $new_value : $cur_value; +} + +# ----------------------------------------------------------------------------- +# $obj->_apply_timeout($req, $new_val). +# $req->{timeout} に現在値と新しい値の大きな方を設定. +# +sub _apply_timeout +{ + my $this = shift; + my $req = shift; + my $new_value = shift; + my $cur_value = $req->{timeout} || 0; + + $req->{timeout} = $new_value > $cur_value ? $new_value : $cur_value; +} + +# ----------------------------------------------------------------------------- +# $obj->_apply_max_redirects($req, $new_val). +# $req->{max_redirects} に現在値と新しい値の大きな方を設定. +# 但し MAX_REDIRECTS_LIMIT を上限. +# +sub _apply_max_redirects +{ + my $this = shift; + my $req = shift; + my $new_value = shift; + my $cur_value = $req->{max_redirects} || 0; + + $req->{max_redirects} = $new_value > $cur_value ? $new_value : $cur_value; + if( $req->{max_redirects} > $MAX_REDIRECTS_LIMIT ) + { + $req->{max_redirects} = $MAX_REDIRECTS_LIMIT; + } + $DEBUG and $this->_debug($req, "max-redirects: $req->{max_redirects}"); +} + +# ----------------------------------------------------------------------------- +# $this->run_hook($hook_name => $arg). +# フックの実行. +# +sub run_hook +{ + my $this = shift; + my $hook_name = shift; + my $arg = shift; + + foreach my $plugin ($this->plugins) + { + my $spec = $plugin->{object}{hook}; + my $sub = $spec && $spec->{$hook_name}; + $sub or next; + $plugin->$sub($this, $arg); + } +} + +# ----------------------------------------------------------------------------- +# $this->_request_filter(prereq => $req). +# $this->_request_filter(response => $req). +# リクエストのフィルタを適用. +# +sub _request_filter +{ + my $this = shift; + my $when = shift; + my $req = shift; + my $url = $req->{url}; + + if( $when eq 'prereq' ) + { + $req->{headers}{'User-Agent'} ||= "FetchTitle/$VERSION (tiarra)"; + if( $url =~ m{https?://\w+\.2ch\.net(?:/|$)} ) + { + $DEBUG and $this->_debug($req, "debug: change user-agent for 2ch"); + $req->{headers}{'User-Agent'} =~ s/libwww-perl/LWP/; + } + } + my $hook_name = "filter.$when"; + + my $has_extract_heading; + $DEBUG and $this->_debug($req, "debug: conf check start for $when"); + foreach my $conf (@{$req->{mask}{conf}}) + { + $DEBUG and $this->_debug($req, "debug: conf check"); + my $table = $conf->table; + foreach my $key (sort keys %$table) + { + $DEBUG and $this->_debug($req, "debug: - $key"); + my $block = $conf->get($key, 'block'); + my $url_masks = [$block->url('all')]; + #$DEBUG and $this->_debug($req, "debug: - - url: $_") for @$url_masks; + if( @$url_masks && !Mask::match_deep($url_masks, $url) ) + { + #$DEBUG and $this->_debug($req, "debug: - - not match"); + next; + } + + $DEBUG and $this->_debug($req, "debug: - - match"); + if( $when eq 'prereq' and my $timeout = $block->timeout ) + { + if( $timeout =~ /^\d+\z/ ) + { + my $prev = $req->{timeout} || '(noval)'; + $DEBUG and $this->_debug($req, "debug: - - timeout: $prev -> $timeout"); + $req->{timeout} = $timeout; + }else + { + $DEBUG and $this->_debug($req, "debug: - - timeout: invalid value: $timeout"); + } + } + + my @types = $block->type('all'); + if( $block->user && !grep {$_ eq 'basic'} @types ) + { + push(@types, 'basic'); + } + if( $block->cookie && !grep {$_ eq 'cookie'} @types) + { + push(@types, 'cookie'); + } + $has_extract_heading ||= grep {$_ eq 'extract-heading'} @types; + foreach my $type (@types) + { + my $spec = $this->{hooks}{$type}; + if( !$spec ) + { + $DEBUG && $type ne '' and $this->_debug($req, "debug: unsupported type: $type"); + next; + } + my $sub = $spec->{$hook_name}; + if( !$sub ) + { + $DEBUG && $type ne '' and $this->_debug($req, "debug: - no sub for $hook_name"); + next; + } + $DEBUG and $this->_debug($req, "debug: call $type/$hook_name"); + $req->{applied_filters} ||= []; + push(@{$req->{applied_filters}}, $type); + if( $spec->{old} ) + { + my $old_sub = $sub; + $sub = sub{ + my $obj = shift; + my $ctx = shift; + my $arg = shift; + $old_sub->($ctx, $arg->{block}, $arg->{req}, $arg->{when}, $arg->{type}); + }; + } + my $arg = { + block => $block, + req => $req, + when => $when, + type => $type, + }; + $spec->{object}->$sub($this, $arg); + if( $req->{redirect} || ($when eq 'prereq' && $req->{response}) ) + { + return; + } + } + } + } + + if( !$has_extract_heading ) + { + my $type = 'extract-heading'; + my $spec = $this->{hooks}{$type}; + my $sub = $spec->{$hook_name}; + if( $sub ) + { + my $block = undef;#Configuration::Block->new(); + $DEBUG and $this->_debug($req, "debug: call $type/$hook_name (extra)"); + $req->{applied_filters} ||= []; + push(@{$req->{applied_filters}}, $type); + + my $arg = { + block => $block, + req => $req, + when => $when, + type => $type, + }; + $spec->{object}->$sub($this, $arg); + } + } + +} + +# ----------------------------------------------------------------------------- +# $this->_filter_basic_prereq($block, $req, $when, $type). +# (impl:fetchtitle-filter) +# BASIC認証/prereq. +# +sub _filter_basic_prereq +{ + my $this = shift; + my $block = shift; + my $req = shift; + my $when = shift; + my $type = shift; + + eval { require MIME::Base64; }; + if( $@ ) + { + $DEBUG and $this->_debug($req, "debug: no MIME::Base64"); + next; + } + my $user = _decode_value($block->user); + my $pass = _decode_value($block->pass); + $req->{headers}{Authorization} = "Basic ".MIME::Base64::encode("$user:$pass", ""); + + $this; +} + +# ----------------------------------------------------------------------------- +# $this->_filter_cookie_prereq($block, $req, $when, $type). +# (impl:fetchtitle-filter) +# cookie/prereq. +# +sub _filter_cookie_prereq +{ + my $this = shift; + my $block = shift; + my $req = shift; + my $when = shift; + my $type = shift; + + foreach my $cookie ($block->cookie('all')) + { + if( $req->{headers}{Cookie} ) + { + $req->{headers}{Cookie} .= "; "; + }else + { + $req->{headers}{Cookie} = ""; + } + if( $cookie =~ /^(\S+?)=(\S+)\z/ ) + { + $req->{headers}{Cookie} .= "$cookie"; + }else + { + $DEBUG and $this->_debug($req, "debug: invalid cookie value: $cookie"); + } + } + + $this; +} + +# ----------------------------------------------------------------------------- +# $this->_filter_uploader_prereq($block, $req, $when, $type). +# (impl:fetchtitle-filter) +# uploader/prereq. +# uploader.jp. ダウンロードURLに情報がないので, +# トップページから情報を取得. +# +sub _filter_uploader_prereq +{ + my $this = shift; + my $block = shift; + my $req = shift; + my $when = shift; + my $type = shift; + + my $url = $req->{url}; + if( $url =~ s{/dl/(\w+)/[^/]+\.html}{/home/$1/} ) + { + $req->{redirect} = { + url => $url, + recv_limit => 20*1024, + }; + } + $this; +} + +# ----------------------------------------------------------------------------- +# $this->_filter_uploader_response($block, $req, $when, $type). +# (impl:fetchtitle-filter) +# uploader/response. +# +sub _filter_uploader_response +{ + my $this = shift; + my $block = shift; + my $req = shift; + my $when = shift; + my $type = shift; + + my $prev = $req->{old}{url} or return; + $DEBUG and $this->_debug($req, "debug: prev url is $prev"); + + my $regexp = qr{ + (?-x:No.(\d+) (.*?)) + (?-x:\s*(.*?)) # desc. + (?-x:\s*(.*?)) # size. + (?-x:\s*(.*?)) # date. + (?-x:\s*(.*?)) # filename. + }x; + if( !$req->{result}{decoded_content} || $req->{result}{decoded_content} !~ $regexp ) + { + $DEBUG and $this->_debug($req, "debug: - not match"); + return; + } + my $no = $1; + my $alias = $2; + my $desc = $3; + my $size = $4; + my $date = $5; + my $origname = $6; + $desc =~ s/^$RE_WHITESPACES//; + my $locked = $size =~ s{ \*}{}; + + my @opts; + push(@opts, "No.$no"); + push(@opts, $size); + push(@opts, $locked ? "locked" : "non-pass"); + push(@opts, $date); + + my $reply; + if( $desc ) + { + $reply = $desc; + push(@opts, $origname); + }else + { + $reply = $origname; + } + $reply .= " (".join("; ",@opts).")"; + $req->{result}{result} = $reply; +} + +# ----------------------------------------------------------------------------- +# $obj->_request_progress($req, $res). +# 大抵はタイトル取得に全部を落とす必要がないので +# ある程度取得したら切断しちゃう用. +# +sub _request_progress +{ + my $this = shift; + my $req = shift; + my $res = shift; # HTTPClient response. + + my $rlen = defined($res->{Content}) ? length($res->{Content}) : 0; + $DEBUG and $this->_debug($req, "debug: progress $rlen / $req->{recv_limit}"); + + if( my $addr = !$req->{addr_checked} && $req->{httpclient}->{addr} ) + { + my $desc = $this->_addr_check($addr); + if( !$desc ) + { + $req->{addr_checked} = 'not local'; + }else + { + my $allowed = $this->_is_allowed_local($req, $addr); + if( $allowed ) + { + $req->{addr_checked} = "$desc, allowed"; + }else + { + $req->{addr_checked} = "$desc, not allowed"; + $req->{httpclient}->stop(); + $this->_debug($req, "reserved address: $desc ($addr)"); + $this->_request_finished($req, "reserved address: $desc"); + } + } + } + + if( $rlen>=$req->{recv_limit} ) + { + $DEBUG and $this->_debug($req, "debug: stop request."); + $req->{httpclient}->stop(); + $this->_request_finished($req, $res); + } +} + +sub _addr_check +{ + my $this = shift; + my $addr = shift; + + $DEBUG and print __PACKAGE__."#_addr_check: $addr\n"; + + my $ipv4 = $this->_addr_check_ipv4($addr); + if( $ipv4 ) + { + return $ipv4; + } + + my $ipv6 = $this->_addr_check_ipv6($addr); + if( $ipv6 ) + { + return $ipv6; + } + + return undef; +} + +sub _addr_check_ipv4 +{ + my $this = shift; + my $addr = shift; + + my @digits = $addr =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)\z/; + @digits or return undef; + grep{ $_>255 || /^0./ } @digits and return undef; + my $addr_num = ($digits[0] << 24) | ($digits[1] << 16) | ($digits[2] << 8) | $digits[3]; + + my $cidrs = $this->_config_reserved_addresses(); + foreach my $cidr (@$cidrs) + { + my $a0 = $cidr->[0]; + my $mask = $cidr->[1]; + ($addr_num & $mask) == $a0 or next; + return $cidr->[3]; + } + return undef; +} + +sub _addr_check_ipv6 +{ + my $this = shift; + my $addr = shift; + + # not supported. + + return undef; +} + +sub _is_allowed_local +{ + my $this = shift; + my $req = shift; + my $addr = shift; + + my ($addr_num) = $this->_split_cidr($addr); + + foreach my $conf (@{$req->{mask}{conf}}) + { + my $table = $conf->table; + foreach my $key (sort keys %$table) + { + my $block = $conf->get($key, 'block'); + foreach my $cidr ($block->allow_local('all')) + { + my ($a0, $mask) = $this->_split_cidr($cidr); + if( !defined($a0) ) + { + $this->_error("invalid cidr: $cidr"); + next; + } + if( ($addr_num & $mask) != $a0 ) + { + next; + } + return $cidr; + } + } + } + + return undef; +} + +# ----------------------------------------------------------------------------- +# $obj->_request_finished($req, $res). +# +sub _request_finished +{ + my $this = shift; + my $req = shift; + my $res = shift; # HTTPClient response. + + $DEBUG and print __PACKAGE__."#_request_finished\n"; + $req->{response} = $res; + $req->{httpclient} = undef; + $DEBUG and $this->_debug($req, "debug: got response for $req->{full_ch_name} $req->{url}"); + + my $full_ch_name = $req->{full_ch_name}; + $this->_close_request($full_ch_name); +} + +# ----------------------------------------------------------------------------- +# $obj->_close_request($full_ch_name). +# 最初のリクエストが完了していたら返答を生成して送信. +# 最初のあるだけ複数個. +# +sub _close_request +{ + my $this = shift; + my $full_ch_name = shift; + $DEBUG and print __PACKAGE__."#_close_request\n"; + while( my $req = $this->_close_head_request($full_ch_name) ) + { + my $reply = $req->{result}{result}; + $DEBUG and print __PACKAGE__."#_close_head_request, reply = $reply\n"; + $this->_reply($full_ch_name => $reply); + #$this->_request_filter(closed => $req); + } + $DEBUG and print __PACKAGE__."#_close_request, done\n"; +} + +# ----------------------------------------------------------------------------- +# my $reply_text = $obj->_close_head_request($full_ch_name). +# 最初のリクエストが完了していたら返答を生成. +# 最初の１つだけ. +# +sub _close_head_request +{ + my $this = shift; + my $full_ch_name = shift; + $DEBUG and print __PACKAGE__."#_close_head_request\n"; + if( !$full_ch_name ) + { + $this->_error("_close_head_request: no ch name"); + return; + } + + my $req_queue = $this->{request_queue}{$full_ch_name}; + my $req = $req_queue && @$req_queue && $req_queue->[0]; + + if( !$req ) + { + # no request in queue. + return; + } + if( !$req->{response} ) + { + # first request is still in progress. + my $now = time; + if( $req->{requested_at} < $now - $PROCESSING_LIMIT_TIME ) + { + $req->{response} = "timeout(*)"; + my $el = $now - $req->{requested_at}; + $DEBUG and $this->_debug($req, "debug: request not finished, but expired: $req->{requested_at}+$el/$PROCESSING_LIMIT_TIME for $req->{full_ch_name} $req->{url}"); + }else + { + $DEBUG and $this->_debug($req, "debug: request not finished: for $req->{full_ch_name} $req->{url}"); + return; + } + } + + shift @$req_queue; + + my $result = $this->_parse_response($req->{response}, $req); + + $req->{result} = $result; + $this->_request_filter(response => $req); + + if( my $redir = $result->{redirect} ) + { + my $new_req = $this->_redirect($redir, $req, $result); + if( $new_req ) + { + if( !$new_req->{response} ) + { + # つめなおしてもう一度問い合わせ. + unshift @$req_queue, $new_req; + my $real_req = $this->_start_request($new_req); + $req_queue->[0] = $real_req; + return; + } + $req = $new_req; + $result = $this->_parse_response($req->{response}, $req); + $req->{result} = $result; + # これ以上はフィルタ処理しないでおく. + # してもいいのかもだけど, + # いまのとこ多段処理する予定もないので. + } + } + + if( $DEBUG ) + { + if( my $file = $this->config->debug_dumpfile ) + { + $this->_debug($req, "debug: dump result into $file"); + if( open(my$fh, '>', $file) ) + { + use Data::Dumper; + my $req = { %$req }; + my $res = $req->{response}; + $req->{response} = '(drop)'; + #ref($res) && length($res->{Content})>100 and substr($res->{Content}, 100, -1, '(drop)'); + print $fh Dumper($req, $res, $result); + close $fh; + }else + { + $this->_debug($req, "debug: open: $!"); + } + }else + { + $this->_debug($req, "debug: no dumpfile specified"); + } + } + + $req; +} + +# ----------------------------------------------------------------------------- +# $new_req = $this->_redirect($redir, $prev_res). +# リダイレクト処理. +# $redir はハッシュリファレンスかスカラー(URL). +# +sub _redirect +{ + my $this = shift; + my $redir = shift; + my $req = shift; + + if( !ref($redir) ) + { + $redir = { url => $redir }; + } + my $err; + my $count = ($req->{redirected}||0) + 1; + my $full_ch_name = $req->{full_ch_name}; + + $DEBUG and $this->_debug($req, "debug: _redirect: ($count) $redir->{url}"); + + if( $redir->{url} !~ m{/} ) + { + my $base = $req->{url}; + $base =~ s{[^/]+$}{}; + $redir->{url} = $base . $redir->{url}; + $DEBUG and $this->_debug($req, "debug: _redirect: rewrite basename, $redir->{url}"); + }elsif( $redir->{url} =~ m{^/} ) + { + my ($scheme, $domain, $path) = $this->_parse_url($req); + if( !$scheme ) + { + $this->_error("parsing url for redirect is failed: $req->{url}"); + return; + } + $redir->{url} = "$scheme://$domain$redir->{url}"; + $DEBUG and $this->_debug($req, "debug: _redirect: rewrite path-style, $redir->{url}"); + } + + my $matched = $this->_check_mask($full_ch_name, $redir->{url}); + if( !$matched ) + { + $DEBUG and $this->_debug($req, "debug: _redirect: not in mask, no redirect"); + return; + } + + # リダイレクトリクエストの生成. + my $new_req = $this->_create_request($req->{full_ch_name}, $redir->{url}, $matched); + my $ini_req = $req->{ini_req} || $req; + $new_req->{old} = $req; + $new_req->{ini_req} = $ini_req; + $new_req->{redirected} = $count; + $new_req->{requested_at} = $req->{requested_at}; + $new_req->{cookie_jar} = $ini_req->{cookie_jar}; + $this->_add_cookie_header($new_req, $ini_req->{cookie_jar}); + if( $redir->{recv_limit} ) + { + $this->_apply_recv_limit($new_req, $redir->{recv_limit}); + } + if( $req->{max_redirects} ) + { + $this->_apply_max_redirects($new_req, $req->{max_redirects}); + } + if( $redir->{max_redirects} ) + { + $this->_apply_max_redirects($new_req, $redir->{max_redirects}); + } + + $redir->{method} and $new_req->{method} = $redir->{method}; + if( my $h = $redir->{headers} ) + { + @{$new_req->{headers}}{keys %$h} = values %$h; + } + if( $redir->{content} ) + { + $new_req->{content} = $redir->{content}; + $new_req->{method} ||= 'POST'; + $new_req->{headers}{'Content-Length'} = length($new_req->{content}); + } + + $new_req->{response} = $redir->{response}; + if( $count > ($new_req->{max_redirects} || $MAX_REDIRECTS) ) + { + $new_req->{response} ||= "too many redirects: $req->{redirected}"; + } + + $new_req; +} + +# ----------------------------------------------------------------------------- +# $result = $this->_parse_response($res, $req). +# 関数名の通り. +# +sub _parse_response +{ + my $this = shift; + my $res = shift; + my $req = shift; + my $full_ch_name = $req->{full_ch_name}; + $DEBUG and $this->_debug($req, "_parse_response."); + + my $result = { + result => undef, + status_code => undef, + is_success => undef, + title => undef, + content_type => undef, + content_length => undef, + decoded_content => undef, + fetch_length => undef, + }; + + if( !ref($res) ) + { + my $DEFAULT_LANG = 'ja'; + my $lang = $this->config->lang || $DEFAULT_LANG; + my $msgmap = {}; + if( $lang eq 'ja' ) + { + $msgmap = { + error => 'エラー', + timeout => 'タイムアウト', + 'no host to connect' => 'サーバが見つかりません', + '接続を拒否されました' => 'サーバに接続できませんでした', + 'Connection refused' => 'サーバに接続できませんでした', + }; + }; + $result->{result} = "(".($msgmap->{error}||'error').") $req->{url} ".($msgmap->{$res}||$res); + return $result; + } + + my $protocol = $res->{Protocol}; + my $status_code = $res->{Code} || 0; + my $status_msg = $res->{Message}; + my $headers = $res->{Header}; # hash-ref. + my $content = $res->{Content}; + $result->{fetch_length} = defined($content) ? length($content) : undef; + defined($content) or $content = ''; + my @opts; + + $result->{status_code} = $status_code; + $result->{content_length} = $headers->{'Content-Length'}; + if( !defined($result->{content_length}) && $res->{StreamState} eq 'finished' ) + { + $result->{content_length} = length($content); + } + $DEBUG and $this->_debug($full_ch_name, "debug: fetch ".length($content)." bytes"); + + # extract Cookies; + if( $headers->{'Set-Cookie'} ) + { + $this->_extract_cookies($req); + } + + if( my $loc = $headers->{Location} ) + { + $DEBUG and $this->_debug($full_ch_name, "debug: has Location header: $loc"); + if( $loc =~ m{^\s*(\w+://[-.\w]+\S*)\s*$} ) + { + $result->{redirect} = substr($loc, 0, length($1)); # keep taintness. + }elsif( $loc =~ m{^\s*((/?).*?(?:[#?].*)?)\s*$} ) + { + my $path = substr($loc, 0, length($1)); # keep taintness. + my $is_abs = $2; + my $new_url = $req->{url}; + $new_url =~ s{[#?].*}{}; + if( $is_abs ) + { + $new_url =~ s{^(\w+://[^/]+)/.*}{$1} or die "invalid req url(abs): $new_url"; + }else + { + $new_url =~ s{^(\w+://[^/]+.*/).*}{$1} or die "invalid req url(rel): $new_url"; + } + $result->{redirect} = $new_url . $path; + }else + { + $DEBUG and $this->_debug($full_ch_name, "debug: broken location url: $loc"); + } + $DEBUG && $result->{redirect} and $this->_debug($full_ch_name, "debug: Location redirect: $result->{redirect}"); + } + if( int($status_code / 100) != 2 && !$result->{redirect} ) + { + $result->{title} = $status_msg; + push(@opts, "http status $status_code"); + } + + # detect refresh tag. + if( $content =~ m{}i ) + { + my $after = $1; + my $url = $2; + $DEBUG and $this->_debug($full_ch_name, "debug: meta.refresh found: $after; $url"); + $result->{redirect} = $url; + } + + # detect encoding. + my $enc = 'auto'; + if( $content =~ m{}i ) + { + my $e = lc($1); + $enc = $e =~ /s\w*jis/ ? 'sjis' + : $e =~ /euc/ ? 'euc' + : $e =~ /utf-?8/ ? 'utf8' + : $e =~ /iso-2022-jp/ ? 'jis' + : $e =~ /\bjis\b/ ? 'jis' + : $enc; + $DEBUG and $this->_debug($full_ch_name, "debug: charset $enc from meta ($e)"); + } + if( $enc eq 'auto' && $headers->{'Content-Type'} && $headers->{'Content-Type'} =~ /;\s*charset=(\S+)/ ) + { + my $e = lc($1); + $enc = $e =~ /s\w*jis/ ? 'sjis' + : $e =~ /euc/ ? 'euc' + : $e =~ /utf-?8/ ? 'utf8' + : $e =~ /iso-2022-jp/ ? 'jis' + : $e =~ /\bjis\b/ ? 'jis' + : $enc; + $DEBUG and $this->_debug($full_ch_name, "debug: charset $enc from http-header ($e)"); + } + if( $enc eq 'auto' ) + { + my $guessed = $ENCODER->new->getcode($content); + $enc = $guessed ne 'unknown' ? $guessed : 'sjis'; + $DEBUG and $this->_debug($full_ch_name, "debug: charset $enc from guess ($guessed)"); + } + + # drop broken utf-8 sequences. + if( $enc eq 'utf8' && $content =~ s{([\xe0-\xef][\x80-\xbf]?)(?=[\x00-\x7e])}{join('',map{sprintf("[%02x]",$_)}unpack("C*",$1))}eg ) + { + $DEBUG and $this->_debug($full_ch_name, "debug: broken utf-8 found and fixed"); + my $url = $req->{url}; + $this->_log("broken utf-8 on $url (enc=$enc)"); + } + + # decode. + $content = $ENCODER->new($content, $enc)->utf8; + $result->{decoded_content} = $content; + + my ($title) = $content =~ m{\s*(.*?)\s*}is; + $DEBUG && !$title and $this->_debug($full_ch_name, "debug: no title elements in document"); + + if( defined($title) ) + { + $title = $this->_fixup_title($title); + $result->{title} = $title; + }else + { + $title = $result->{title}; + } + + my ($ctype) = split(/[ ;]/, $headers->{'Content-Type'}, 2); + $ctype ||= 'unknown/unkown'; + $result->{content_type} = $ctype; + $DEBUG and $this->_debug($full_ch_name, "debug: content-type: $ctype"); + + my $reply = defined($title) ? $title : ''; + if( $reply eq '' ) + { + $DEBUG and $this->_debug($full_ch_name, "debug: check icecast"); + if( my $icy_name = $headers->{'icy-name'} ) + { + # Icecast. + my $desc = $headers->{'icy-description'}; + my $bitrate = $headers->{'icy-br'}; + $reply = $icy_name; + if( defined($bitrate) ) + { + $reply .= " [${bitrate}k]"; + } + if( defined($desc) && $desc ne $icy_name ) + { + $reply .= " - $desc"; + } + $reply = $ENCODER->new($reply,'auto')->utf8; + } + } + if( $ctype eq 'audio/x-mpegurl' && $res->{StreamState} eq 'finished' ) + { + if( $content =~ m{^(\w+://[-.\w]+\S*)\s*$}m ) + { + $result->{redirect} = substr($content, 0, length($1)); # keep taintness. + } + } + + if( $reply eq '' || $ctype !~ /html/ ) + { + push(@opts, $ctype); + } + if( $ctype =~ m{^(?:image|video)/} && $HAS_IMAGE_EXIFTOOL ) + { + $DEBUG and $this->_debug($full_ch_name, "debug: check image"); + my @tags = qw(Title ImageSize Headline); + my $info = Image::ExifTool::ImageInfo(\$res->{Content}, @tags); + my $x = sub{ my $x=shift;$x=~s/([^ -~])/sprintf('[%02x]',unpack("C",$1))/ge;$x}; + $DEBUG and $this->_debug($full_ch_name, "debug: - ".$x->(join(", ", %$info))); + if( $reply eq '' ) + { + my ($key) = grep{$info->{$_}} qw(Title Headline); + my $decoded_key = $info->{"$key (1)"} && "$key (1)"; + my $val = $info->{$decoded_key} || $info->{$key}; + my $guessed = $decoded_key ? 'decoded' : $ENCODER->getcode($val); + my $enc = $guessed eq 'unknown' ? 'sjis' : $guessed; + $DEBUG and $this->_debug($full_ch_name, "debug: - $key ($enc/$guessed) ".$x->($val)); + $reply ||= $decoded_key ? $info->{$decoded_key} : $ENCODER->new($val, $enc)->utf8; + } + if( $info->{ImageSize} ) + { + push(@opts, $info->{ImageSize}); + } + } + if( $reply eq '' || $ctype !~ /html/ ) + { + my $len = $result->{content_length}; + if( defined($len) ) + { + $len =~ s/(?<=\d)(?=(\d\d\d)+(?!\d))/,/g; + $len = "$len bytes"; + push(@opts, $len); + } + } + if( $req->{redirected} ) + { + my $redirs = $req->{redirected}==1 ? 'redir' : 'redirs'; + push(@opts, "$req->{redirected} $redirs"); + } + + if( $reply eq '' && $ctype =~ /text/ ) + { + $reply = '(untitled)'; + } + if( @opts ) + { + $reply eq '' or $reply .= ' '; + $reply .= "(".join("; ", @opts).")"; + } + + $result->{is_success} = 1; + $result->{result} = $reply; + $result; +} + +sub _parse_url +{ + my $this = shift; + my $url = shift; + ref($url) and $url = $url->{url}; + + my ($scheme, $domain, $path) = $url =~ m{^(http|https)://(?:[^/]+\@)?([^/]+)(.*)}; + if( !$scheme ) + { + return; + } + $path =~ s/[\?#].*//; + $path =~ s{[^/]$}{}; + ($scheme, $domain, $path); +} + +sub _add_cookie_header +{ + my $this = shift; + my $req = shift; + my $cookie_jar = shift; + + $DEBUG and print __PACKAGE__."#_add_cookie_header, $req->{url}\n"; + + my ($scheme, $domain, $path) = $this->_parse_url($req); + if( !$scheme ) + { + $this->_error("parsing url for cookie is failed: $req->{url}"); + return; + } + + my $ini_req = $req->{ini_req} || $req; + my @send_cookies; + foreach my $cookie (@$cookie_jar) + { + if( $cookie->{domain} ne $domain ) + { + next; + } + if( $cookie->{_scheme} ne $scheme ) + { + if( $cookie->{_scheme} eq 'https' && $cookie->{secure} ) + { + next; + } + } + if( $path !~ /^\Q$cookie->{path}/ ) + { + next; + } + push(@send_cookies, $cookie); + } + if( @send_cookies ) + { + $this->_merge_cookies($req->{cookies}, \@send_cookies); + } +} + +sub _extract_cookies +{ + my $this = shift; + my $req = shift; + $DEBUG and $this->_debug($req, __PACKAGE__."#_extract_cookies, $req->{url}"); + + my $res = $req->{response}; + my $new_cookies = $res->{ListedHeader}{'Set-Cookie'} || [$res->{Header}{'Set-Cookie'}]; + my $parsed_cookies = $this->_parse_cookies($req->{url}, $new_cookies); + + if( $parsed_cookies ) + { + $req->{parsed_cookies} = $parsed_cookies; + + my $ini_req = $req->{ini_req} || $req; + $this->_merge_cookies($ini_req->{cookie_jar}, $parsed_cookies); + } +} + +sub _parse_cookies +{ + my $this = shift; + my $url = shift; + my $new_cookies = shift; + + ref($url) and $url = $url->{url}; + + my ($scheme, $domain, $path) = $this->_parse_url($url); + if( !$scheme ) + { + $this->_error("parsing url for cookie is failed: $url"); + return; + } + + my $now = time; + my $now_cmp; + my @parsed_cookies; + + foreach my $cookie_str (@$new_cookies) + { + #print "cookie = $cookie_str\n"; + + my %attrs = ( + _url => $url, + _orig => $cookie_str, + _got_at => $now, + _scheme => undef, + domain => undef, + path => undef, + name => undef, + value => undef, + expires => undef, + _expires_cmp => undef, + _is_expired => undef, + #secure => undef, + #httponly => undef, + ); + my $is_first = 1; + foreach my $pair (split(/\s*;\s*/, $cookie_str)) + { + my ($key, $val) = split(/\s*=\s*/, $pair, 2); + if( $is_first ) + { + $attrs{name} = $key; # keep encoded. + $attrs{value} = $val; # keep encoded. + $is_first = undef; + }else + { + $attrs{lc $key} = defined($val) ? $val : 1; + } + } + if( $attrs{domain} && $attrs{domain} ne $domain ) + { + $this->_error("_parse_cookies, domain $attrs{domain} does not match with one in url $domain, ignore this cookie"); + next; + } + $attrs{_scheme} = $scheme; + $attrs{domain} ||= $domain; + $attrs{path} ||= $path; + $attrs{_ident} = join(';', @attrs{qw(_scheme domain path name)}); + + if( $attrs{expires} && $attrs{expires} =~ /^\w+, (\d+)-(\w+)-(\d+) (\d+):(\d+):(\d+) \S+$/ ) + { + my ($mday, $mon, $year, $hour, $min, $sec) = ($1, $2, $3, $4, $5, $6); + my %mon_map = map{lc($_)}qw(Jan 1 Feb 2 Mar 3 Apr 4 May 5 Jun 6 Jul 7 Aug 8 Sep 9 Oct 10 Nov 11 Dec 12); + $mon = $mon_map{lc$mon} || 99; + my $cmp = sprintf('%04d-%02d-%02d %02d:%02d:%02d', $year, $mon, $mday, $hour, $min, $sec); + $attrs{_expires_cmp} = $cmp; + $now_cmp ||= do{ + my @tm = localtime(); + $tm[5] += 1900, $tm[4] += 1; + sprintf('%04d-%02d-%02d %02d:%02d:%02d', reverse @tm[0..5]); + }; + $attrs{_is_expired} = $cmp lt $now_cmp; + } + push(@parsed_cookies, \%attrs); + #$DEBUG and print "new cookie: ".Dumper(\%attrs); + } + @parsed_cookies ? \@parsed_cookies : undef; +} + +sub _merge_cookies +{ + my $this = shift; + my $cookie_store = shift; + my $parsed_cookies = shift; + + foreach my $cookie (@$parsed_cookies) + { + @$cookie_store = grep{ $_->{_ident} ne $cookie->{_ident} } @$cookie_store; + if( !$cookie->{_is_expired} ) + { + push(@$cookie_store, $cookie); + } + } +} + +# ----------------------------------------------------------------------------- +# $title_text = $this->_fixup_title($title_html). +# htmlから切り出したhtmlパーツのtext化. +# +sub _fixup_title +{ + my $this = shift; + my $title = shift; + + $title =~ s/<.*?>//g; + + $title = $this->_unescapeHTML($title); + $title =~ s/[\r\n]+/ /g; + $title =~ s/^\s+|\s+$//g; + $title =~ s/\xc2([\x80-\xbf])/ $LATIN1_MAP[unpack("C",$1)-0x80] || $1 /ge; + $title =~ s/\xc3([\x80-\xbf])/ $LATIN1_MAP[unpack("C",$1)-0x80+0x40] || $1 /ge; + #$title =~ s/([^ -~])/sprintf('[%02x]',unpack("C",$1))/ge; + + $title; +} + +# ----------------------------------------------------------------------------- +# $txt = $this->_unescapeHTML($html). +# HTML中の実際参照をデリファレンス. (ってHTMLもそういうのかな？) +# +sub _unescapeHTML +{ + my $this = shift; + my $html = shift; + my $map = { + nbsp => ' ', + lt => '<', + gt => '>', + amp => '&', + quot => '"', + }; + $html =~ s{&#(\d+);|&#x([0-9a-fA-F]+);|&(\w+);}{ + if( defined($1) || defined($2) ) + { + my $ch = defined($1) ? $1 : hex($2); + $ch && $ch < 127 ? chr($ch) : "[$ch]"; + }else + { + $map->{$3} || "[$3]"; + } + }ge; + $html; +} + +# ----------------------------------------------------------------------------- +# $obj->_log($msg). +# print log in console. +# +sub _log +{ + my $this = shift; + my $msg = shift; + RunLoop->shared_loop->notify_msg($msg); +} + +# ----------------------------------------------------------------------------- +# $obj->_reply($full_ch_name, $reply). +# お返事を送信. +# +sub _reply +{ + my $this = shift; + my $full_ch_name = shift; + my $reply = shift; + + my $reply_prefix = $this->config_get('reply_prefix'); + my $reply_suffix = $this->config_get('reply_suffix'); + defined($reply_prefix) or $reply_prefix = ''; + defined($reply_suffix) or $reply_suffix = ''; + my $msg = $reply_prefix . $reply . $reply_suffix; + $msg =~ s/[\r\n]+/ /g; + + # メッセージが追い越しちゃわないように + # いったんキュー経由. + push(@{$this->{reply_queue}}, [$full_ch_name, $msg]); + if( !$this->{reply_timer} ) + { + $this->{reply_timer} = Timer->new( + After => -1, # immediately. + Code => sub{ $this->_reply_timer_handler() }, + )->install(); + } +} + +# ----------------------------------------------------------------------------- +# $this->config_get('reply-prefux'). +# $this->config_get('reply-suffix'). +# 設定の取得. +# $this->config->reply_prefix 等にダブルクオート処理を加えた物. +# +sub config_get +{ + my $this = shift; + my $key = shift; + my $val = $this->config->$key; + if( $val && $val =~ /^"((?:[^\"]+|\\.)*)"/ ) + { + $val = $1; + my %map = ( + t => "\t", + "\\" => "\\", + "\"" => "\"", + ); + $val =~ s{\\($1)}{$map{$1}||$1}eg; + } + $val; +} + +# ----------------------------------------------------------------------------- +# $obj->_reply_timer_handler(). +# キューにたまっているお返事を実際に送信. +# +sub _reply_timer_handler +{ + my $this = shift; + $this->{reply_timer} = undef; + while( my $pair = shift @{$this->{reply_queue}} ) + { + my $full_ch_name = $pair->[0]; + my $reply = $pair->[1]; + + my $msg_to_send = Auto::Utils->construct_irc_message( + Command => 'NOTICE', + Params => [ '', $reply ], + ); + + my ($ch_short,$net_name) = Multicast::detach($full_ch_name); + + # send to server. + # + my $sendto_server = RunLoop->shared_loop->network($net_name); + if( defined $sendto_server ) + { + my $for_server = $msg_to_send->clone; + $for_server->param(0, $ch_short); + $sendto_server->send_message($for_server); + } + + # send to clients. + # + my $ch_on_client = Multicast::attach_for_client($ch_short, $net_name); + my $for_client = $msg_to_send->clone; + $for_client->param(0, $ch_on_client); + $for_client->remark('fill-prefix-when-sending-to-client', 1); + RunLoop->shared_loop->broadcast_to_clients($for_client); + } +} + +# ----------------------------------------------------------------------------- +# $obj->_error($msg). +# エラーメッセージの送信. +# 回答用じゃなくてエラー記録用. +# +sub _error +{ + my $this = shift; + my $msg = shift; + + RunLoop->shared_loop->notify_error($msg); +} + +# ----------------------------------------------------------------------------- +# $obj->_debug($full_ch_name, $reply). +# $obj->_debug($req, $reply). +# デバッグメッセージの送信. +# +sub _debug +{ + my $this = shift; + @_==1 and unshift(@_, '***'); + my $full_ch_name = shift; + my $reply = shift; + + if( ref($full_ch_name) eq 'HASH' && $full_ch_name->{full_ch_name} ) + { + $full_ch_name = $full_ch_name->{full_ch_name}; + } + + $reply =~ s/^debug: ?//; + + my $reply_prefix = $this->config_get('reply_prefix'); + my $reply_suffix = $this->config_get('reply_suffix'); + defined($reply_prefix) or $reply_prefix = ''; + defined($reply_suffix) or $reply_suffix = ''; + my $msg_to_send = Auto::Utils->construct_irc_message( + Command => 'NOTICE', + Params => [ '', $reply_prefix."debug: $reply".$reply_suffix ], + ); + $DEBUG and print __PACKAGE__."#_debug, ".$msg_to_send->param(1)."\n"; + + #$this->_error("_debug: full_ch_name: ".Data::Dumper->new([$full_ch_name])->Indent(0)->Dump); + my ($ch_short,$net_name) = Multicast::detach($full_ch_name); + + # send to clients. + # + my $ch_on_client = Multicast::attach_for_client($ch_short, $net_name); + my $for_client = $msg_to_send->clone; + $for_client->param(0, $ch_on_client); + $for_client->remark('fill-prefix-when-sending-to-client', 1); + RunLoop->shared_loop->broadcast_to_clients($for_client); +} + +# ----------------------------------------------------------------------------- +# $list = $pkg->_config_reserved_addresses(). +# +sub _config_reserved_addresses +{ + my $this = shift || __PACKAGE__; + + our $RESERVED_ADDRESSES ||= [ + [ 0, 0, '0.0.0.0/8', 'Current network', 'RFC 1700', ], + [ 0, 0, '10.0.0.0/8', 'Private network', 'RFC 1918', ], + [ 0, 0, '14.0.0.0/8', 'Public data networks', 'RFC 1700', ], + [ 0, 0, '39.0.0.0/8', 'Reserved', 'RFC 1797', ], + [ 0, 0, '127.0.0.0/8', 'Loopback', 'RFC 3330', ], + [ 0, 0, '128.0.0.0/16', 'Reserved (IANA)', 'RFC 3330', ], + [ 0, 0, '169.254.0.0/16', 'Link-Local', 'RFC 3927', ], + [ 0, 0, '172.16.0.0/12', 'Private network', 'RFC 1918', ], + [ 0, 0, '191.255.0.0/16', 'Reserved (IANA)', 'RFC 3330', ], + [ 0, 0, '192.0.0.0/24', 'Reserved (IANA)', 'RFC 3330', ], + [ 0, 0, '192.0.2.0/24', 'Documentation and example code', 'RFC 3330', ], + [ 0, 0, '192.88.99.0/24', 'IPv6 to IPv4 relay', 'RFC 3068', ], + [ 0, 0, '192.168.0.0/16', 'Private network', 'RFC 1918', ], + [ 0, 0, '198.18.0.0/15', 'Network benchmark tests', 'RFC 2544', ], + [ 0, 0, '223.255.255.0/24', 'Reserved (IANA)', 'RFC 3330', ], + [ 0, 0, '255.255.255.255', 'Broadcast', '', ], + [ 0, 0, '224.0.0.0/4', 'Multicasts (former Class D network)', 'RFC 3171', ], + [ 0, 0, '240.0.0.0/4', 'Reserved (former Class E network)', 'RFC 1700', ], + ]; + if( !$RESERVED_ADDRESSES->[-1][0] ) + { + foreach my $info (@$RESERVED_ADDRESSES) + { + my $cidr = $info->[2]; + my ($addr, $mask) = $this->_split_cidr($cidr); + defined($addr) or die "invalid cidr: $cidr"; + $info->[0] = $addr; + $info->[1] = $mask; + } + } + $RESERVED_ADDRESSES; +} + +# ----------------------------------------------------------------------------- +# ($addr, $mask) = $pkg->_split_cidr($cidr). +# +sub _split_cidr +{ + my $this = shift; + my $cidr = shift; + + my @digits = split(/\D+/, $cidr); + my ($addr, $mask); + if( @digits == 5 ) + { + $addr = ($digits[0] << 24) | ($digits[1] << 16) | ($digits[2] << 8) | $digits[3]; + $mask = -1-((1<<(32-$digits[4]))-1); + }elsif( @digits == 4 ) + { + $addr = ($digits[0] << 24) | ($digits[1] << 16) | ($digits[2] << 8) | $digits[3]; + $mask = -1; + }else + { + return (); + } + + $mask &= 0xFFFF_FFFF; + $addr &= $mask; + + wantarray or die "_split_cidr should call with array-context"; + ($addr, $mask); +} + +# ----------------------------------------------------------------------------- +# End of Module. +# ----------------------------------------------------------------------------- + +=begin tiarra-doc + +info: 発言に含まれるURLからタイトルを取得. +default: off + +# リクエストタイムアウトまでの時間(秒). +timeout: 3 + +# 有効にするチャンネルとオプションとURLの設定. +# 書式: mask: [<&conf>...] +# +# mask: #test@ircnet &test http://* +# mask: * http://* +mask: * http://* + +# &test と設定すると conf-test ブロックの中身が使われる. +#conf-test { +# auth-test1 { +# url: http://example.com/* +# url: http://example.org/* +# user: test +# #pass: test +# pass: {BASE64}dGVzdAo= +# } +# filter-xx { +# url: http://example.com/*/xx/* +# type: xx +# } +#} + +# お返事の前や後ろにつける字句. +reply-prefix: "(FetchTitle) " +reply-suffix: " [AR]" + +# デバッグフラグ. +#debug: 0 +#debug-mask: #debug-chan your_nick!~you@example.com +#debug-dumpfile: fetchtitle.log + +# NOTE: +# 利用するにはcodereposから +# module/Tools/HTTPClient.pm rev.8220 +# main/Tiarra/Socket/Buffered.pm rev.8219 +# 以降が必要です. + +=end tiarra-doc + +=head1 NAME + +Auto::FetchTitle - tiarra-module: fetch title from url. + +=head1 VERSION + +Version 0.02 + +=head1 SYNOPSIS + + + Auto::FetchTitle { + reply-prefix: "(FetchTitle) " + reply-suffix: " [AR]" + + mask: * http://* + } + +See all.conf or sample in tiarra-doc. + +=head1 AUTHOR + +YAMASHINA Hio, C<< >> + +=head1 SEE ALSO + +L + +http://coderepos.org/share/wiki/Tiarra + +=head1 COPYRIGHT & LICENSE + +Copyright 2008 YAMASHINA Hio, all rights reserved. + +This program is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +=cut + diff -urN /non-existant-dir/module/Auto/Im.pm tiarra-20080510/module/Auto/Im.pm --- /non-existant-dir/module/Auto/Im.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/Auto/Im.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,117 @@ +# ----------------------------------------------------------------------------- +# $Id: Im.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +package Auto::Im; +use strict; +use warnings; +use base qw(Module); +use Module::Use qw(Auto::AliasDB Tools::HTTPClient); +use Auto::AliasDB; +use Tools::HTTPClient; # >= r11345 +use HTTP::Request::Common; + +sub new { + my ($class) = shift; + my $this = $class->SUPER::new(@_); + + if ($this->config->secret) { + # signature required + require Digest::SHA; + } + + my $regex = join '|', ( + (map { "(?:$_)" } $this->config->regex_keyword('all')), + (map { "(?i:\Q$_\E)" } map { split /,/ } $this->config->keyword('all')), + ); + eval { + $this->{regex} = qr/$regex/; + }; if ($@) { + $this->_runloop->notify_error($@); + } + + return $this; +} + +sub message_arrived { + my ($this,$msg,$sender) = @_; + my @result = ($msg); + + # サーバーからのメッセージか？ + if ($sender->isa('IrcIO::Server')) { + # PRIVMSGか？ + if ($msg->command eq 'PRIVMSG') { + my $text = $msg->param(1); + my $full_ch_name = $msg->param(0); + + if ($text =~ $this->{regex} && Mask::match_deep_chan( + [$this->config->mask('all')],$msg->prefix,$full_ch_name)) { + + my $url = "http://im.kayac.com/api/post/" . $this->config->user; + my $text = Auto::AliasDB->stdreplace( + $msg->prefix, + $this->config->format || '[tiarra][#(channel):#(nick.now)] #(text)', + $msg, $sender, + channel => $full_ch_name, + text => $text, + ); + my @data = (message => $text); + if ($this->config->secret) { + push(@data, sig => Digest::SHA->new(1) + ->add($text . $this->config->secret)->hexdigest); + } elsif ($this->config->password) { + push(@data, password => $this->config->password); + } + my $runloop = $this->_runloop; + Tools::HTTPClient->new( + Request => POST($url, \@data), + )->start( + Callback => sub { + my $stat = shift; + $runloop->notify_warn(__PACKAGE__." post failed: $stat") + unless ref($stat); + ## FIXME: check response (should check 'error') + }, + ); + } + } + } + + return @result; +} + +1; + +=pod +info: 名前が呼ばれると、その発言をim.kayac.comに送信する +default: off + +# 反応する人のマスクを指定します。 +# 省略すると全員に反応します。 +mask: * *!*@* + +# 反応するキーワードを正規表現で指定します。 +# 複数指定したい時は複数行指定してください。 +-regex-keyword: (?i:fugahoge) + +# 反応するキーワードを指定します。 +# 複数指定したい時は,(コンマ)で区切るか、複数行指定してください。 +keyword: hoge + +# im.kayac.com に送るメッセージのフォーマットを指定します。 +# デフォルト値: [tiarra][#(channel):#(nick.now)] #(text) +format: [tiarra][#(channel):#(nick.now)] #(text) + +# im.kayac.comで登録したユーザ名を入力します。 +# im.kayac.comについては http://im.kayac.com/#docs を参考にしてください。 +user: username + +# im.kayac.comで秘密鍵認証を選択した場合は設定してください。 +# 省略すると認証なしになります。 +-secret: some secret + +# im.kayac.comでパスワード認証を選択した場合は設定してください。 +# 省略すると認証なしになります。 +# secret と両方指定した場合は secret が優先されています。 +-password: some password + +=cut diff -urN /non-existant-dir/module/Auto/Joined.pm tiarra-20080510/module/Auto/Joined.pm --- /non-existant-dir/module/Auto/Joined.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/Auto/Joined.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,68 @@ +# ----------------------------------------------------------------------------- +# $Id: Joined.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +package Auto::Joined; +use strict; +use warnings; +use base qw(Module); +use Module::Use qw(Auto::Utils); +use Auto::Utils; +use Multicast; + +sub new { + my $class = shift; + my $this = $class->SUPER::new(@_); + $this->{last_message_time} = 0; # 最後にこのモジュールが発言した時刻。 + $this->{table} = do { + my %hash = map { + my ($ch_long,$msg) = m/^(.+?)\s+(.+)$/; + $ch_long => $msg; + } $this->config->channel('all'); + \%hash; + }; + $this; +} + +sub message_arrived { + my ($this,$msg,$sender) = @_; + my @result = ($msg); + + my ($get_ch_name,undef,undef,$reply_anywhere) + = Auto::Utils::generate_reply_closures($msg,$sender,\@result); + + if ($sender->isa('IrcIO::Server') && + defined $msg->nick && + $msg->nick ne RunLoop->shared->current_nick && + $msg->command eq 'JOIN') { + + foreach (split /,/,$msg->param(0)) { + my ($ch_long) = m/^([^\x07]+)/; + # このチャンネルに割り当てられたメッセージはあるか？ + my $msg_for_ch = $this->{table}->{$ch_long}; + if (defined $msg_for_ch) { + # 発言してから1秒以上経っていれば、発言。 + if (time > $this->{last_message_time} + 1) { + $reply_anywhere->($msg_for_ch); + $this->{last_message_time} = time; + } + } + } + } + + @result; +} + +1; + +=pod +info: 特定のチャンネルに誰かがJOINする度に特定のメッセージを発言する。 +default: off + +# Auto::Aliasを有効にしていれば、エイリアス置換を行ないます。 + +# 発言を行なうチャンネルと、その内容を定義します。 +# #(nick.now)と$(channel)は、それぞれ相手の現在のnickとチャンネル名に置換されます。 +# +# 書式: <チャンネル名> <発言内容> +-channel: #チャンネル@ircnet 「#ちゃんねる」に移転しました。 +=cut diff -urN /non-existant-dir/module/Auto/MesMail.pm tiarra-20080510/module/Auto/MesMail.pm --- /non-existant-dir/module/Auto/MesMail.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/Auto/MesMail.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,375 @@ +# ----------------------------------------------------------------------------- +# $Id: MesMail.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +# copyright (C) 2003 Topia . all rights reserved. +package Auto::MesMail; +use strict; +use warnings; +use base qw(Module); +use Module::Use qw(Auto::Utils Auto::AliasDB Tools::DateConvert Tools::MailSend); +use Auto::Utils; +use Auto::AliasDB; +use Tools::DateConvert; +use Tools::MailSend; +use Mask; + +# デフォルト設定 +my $DATE_FORMAT = '%H:%M'; +my $FORMAT = '#(date) << #(from.name|from.nick|from.nick.now) >> #(message)'; +my $SUBJECT = 'Message from IRC'; + +sub new { + my ($class) = shift; + my $this = $class->SUPER::new(@_); + + $this->{from_addr} = sub { + my ($user, $host) = split(/\@/, $_[0], 2); + $user = (getpwuid($>))[0] || '' unless $user; + if ($host) { + substr($host, 0, 0) = '@'; + } else { + $host = '' + } + return ($user . $host); + }->($this->config->from); + + my ($use_pop3) = $this->config->use_pop3; + $use_pop3 = 1 if ($use_pop3 =~ /yes/i) || ($use_pop3 !~ /0/); + $this->{use_pop3} = $use_pop3; + + return $this; +} + +sub message_arrived { + my ($this,$msg,$sender) = @_; + my @result = ($msg); + + # サーバーからのメッセージか？ + if ($sender->isa('IrcIO::Server')) { + # PRIVMSGか？ + if ($msg->command eq 'PRIVMSG') { + my ($get_ch_name,undef,undef,$reply_anywhere) + = Auto::Utils::generate_reply_closures($msg,$sender,\@result); + + my ($str, $who, $text) = split(/\s+/, $msg->param(1), 3); + + if (Mask::match_deep([$this->config->send('all')], $str)) { + # 一致していた。 + if (Mask::match_deep_chan([$this->config->mask('all')], $msg->prefix(), $get_ch_name->())) { + $this->_send($msg, $sender, $who, $text, $get_ch_name, $reply_anywhere); + } else { + foreach my $reply ($this->config->deny('all')) { + $reply_anywhere->($reply); + } + } + } + } + } + + return @result; +} + +sub _send { + my ($this, $msg, $sender, $who, $text, $get_ch_name, $reply_anywhere) = @_; + my (@sended_addr, @sended_who); + my ($max_send) = $this->config->max_send_addresses; + + foreach my $name (split(/\,/, $who)) { + next if grep{$_ eq $name;} @sended_who; + push(@sended_who, $name); + my ($to) = Auto::AliasDB->shared->find_alias([$this->config->alias_key('all')], [$name]); + my ($alias) = {}; + + $alias->{'who'} = $name; + if (!defined ($to)) { + foreach my $reply ($this->config->unknown('all')) { + $reply_anywhere->($reply, %$alias); + } + } elsif ($to->{'mail'}) { + next if grep{$_ == $to->{'mail'};} @sended_addr; + push(@sended_addr, $to->{'mail'}); + my ($time) = time(); + $alias->{'date'} = + Tools::DateConvert::replace(Auto::AliasDB::get_value($to, 'mail_date') || + $this->config->date || $DATE_FORMAT, $time); + $alias->{'message'} = $text; + $this->_mail_send_reserve($msg, $sender, $alias, $to, $get_ch_name, $reply_anywhere, $time); + if (defined($max_send)) { + last if scalar(@sended_addr) >= $max_send; + } + } else { + foreach my $reply ($this->config->none_address('all')) { + $reply_anywhere->($reply, %$alias); + } + } + } +} + +sub _mail_send_reserve { + my ($this, $msg, $sender, $alias, $to, $get_ch_name, $reply_anywhere, $time) = @_; + + my ($subject) = Auto::AliasDB::get_value($to, 'mail_subject'); + $subject = $this->config->subject || $SUBJECT unless $subject; + + return Tools::MailSend->shared-> + mail_send( + use_pop3 => $this->{use_pop3}, + pop3_host => $this->config->pop3host, + pop3_port => $this->config->pop3port, + pop3_user => $this->config->pop3user, + pop3_pass => $this->config->pop3pass, + pop3_expire => $this->config->pop3_expire, + smtp_host => $this->config->smtphost, + smtp_port => $this->config->smtpport, + smtp_user => $this->config->smtpuser, + smtp_pass => $this->config->smtppass, + smtp_fqdn => $this->config->smtp_fqdn, + sender => 'Auto::MesMail::' . $msg->prefix(), + priority => 0, + env_from => $this->{from_addr}, + env_to => [Tools::MailSend::parse_mailaddrs(@{Auto::AliasDB::get_array($to, 'mail')})], + from => $this->config->from_header || $this->config->from || $this->{from_addr}, + to => Auto::AliasDB::get_value($to, 'mail'), + subject => $subject, + data_type => Tools::MailSend::DATA_TYPES->{inner_iter}, + data => \&_data, + reply_ok => \&_reply_ok, + reply_error => \&_reply_error, + reply_fatal => \&_reply_fatal, + local => + { + this => $this, + alias => $alias, + from => + Auto::AliasDB::concat_string_to_key( + Auto::AliasDB->shared-> + find_alias_with_stdreplace($msg->nick, + $msg->name, + $msg->host, + $msg->prefix, + 1 # public + ), 'from.'), + to => + Auto::AliasDB->shared-> + remove_private( + Auto::AliasDB::concat_string_to_key($to, 'to.'), + 'to.'), + reply_anywhere => $reply_anywhere, + time => $time, + replacer => sub { + my ($str, %extra_replaces) = @_; + + Auto::AliasDB->shared-> + stdreplace( + $msg->prefix || $sender->fullname, + $str, + $msg, + $sender, + %extra_replaces, + 'channel' => $get_ch_name->()); + }, + }, + ); +} + +sub _data { + my ($struct, $socksend) = @_; + + my $this = $struct->{local}->{this}; + my $alias = $struct->{local}->{alias}; + my $from = $struct->{local}->{from}; + my $to = $struct->{local}->{to}; + my $replacer = $struct->{local}->{replacer}; + + my @format = @{Auto::AliasDB::get_array($to, 'mail_format') || []}; + @format = $this->config->format('all') unless @format; + @format = $FORMAT unless @format; + + foreach my $send_line (@format) { + $socksend->($replacer->($send_line, %$from, %$to, %$alias)); + } +} + +sub _reply_error { + my ($struct, $state, $line, $info) = @_; + # 使用者にerrorを返すメソッド。$infoには送信失敗のmail addressが含まれるはずだが、 + # channelに向かってmail addressを広報することになるので使用しないことを勧める。 + # なお、from/toにはprivate指定されたものは含まれない。 + + # stateには失敗したときの状態が渡され、'error-mail' や 'fatalerror-connect' のように + # 状態別詳細メッセージを定義することが出来る。 + + my $this = $struct->{local}->{this}; + my $alias = $struct->{local}->{alias}; + my $from = $struct->{local}->{from}; + my $to = $struct->{local}->{to}; + my $reply_anywhere = $struct->{local}->{reply_anywhere}; + + my @replys = $this->config->get('error-' . lc($state), 'all'); + @replys = $this->config->error('all') unless @replys; + foreach my $reply (@replys) { + $reply_anywhere->($reply, %$from, %$to, %$alias, + state => $state, + line => $line, + info => $info + ); + } +} + +sub _reply_fatal { + my ($struct, $state, $line, $info) = @_; + # 使用者にerrorを返すメソッド。$infoには送信失敗のmail addressが含まれるはずだが、 + # channelに向かってmail addressを広報することになるので使用しないことを勧める。 + # なお、from/toにはprivate指定されたものは含まれない。 + + # stateには失敗したときの状態が渡され、'error-mail' や 'fatalerror-connect' のように + # 状態別詳細メッセージを定義することが出来る。 + + # fatal は1送信者につき1つだけ返される(はず)。 + + my $this = $struct->{local}->{this}; + my $alias = $struct->{local}->{alias}; + my $from = $struct->{local}->{from}; + my $to = $struct->{local}->{to}; + my $reply_anywhere = $struct->{local}->{reply_anywhere}; + + # user notfound + my @replys = $this->config->get('fatalerror-' . lc($state), 'all'); + @replys = $this->config->fatalerror('all') unless @replys; + foreach my $reply (@replys) { + $reply_anywhere->($reply, %$from, %$to, %$alias, + state => $state, + line => $line, + info => $info + ); + } +} + +sub _reply_ok { + my ($struct) = @_; + # 使用者にacceptを返すメソッド。 + # from/toにはprivate指定されたものは含まれない。 + + my $this = $struct->{local}->{this}; + my $alias = $struct->{local}->{alias}; + my $from = $struct->{local}->{from}; + my $to = $struct->{local}->{to}; + my $reply_anywhere = $struct->{local}->{reply_anywhere}; + + foreach my $reply ($this->config->accept('all')) { + $reply_anywhere->($reply, %$from, %$alias, %$to); + } +} + +1; + +=pod +info: 伝言をメールとして送信する。 +default: off + +# メールアドレスはエイリアスの mail を参照します。 + +# Fromアドレス。[default: OSのユーザ名] +from: example1@example.jp + +# 送信用のキーワード [default: mesmail_send] +send: 速達伝言 + +# 使用を許可する人&チャンネルのマスク。 +# 例はTiarraモード時。 [default: なし] +mask: * +*!*@* +# [plum-mode] mask: +*!*@* + +# maskで拒否されたときのメッセージ [default: なし] +deny: 伝言したくない。 + +# 一度に送れる宛先の量 [default: 無制限] +max-send-address: 5 + +# 宛先を探すエイリアスエントリ [default: なし] +alias-key: name +alias-key: nick + +# 宛先の人を判別出来なかったときのメッセージ [default: なし] +unknown: #(who)さんと言うのは誰ですか? + +# メールの日付形式 +date: %H:%M:%S + +# エイリアスは見付かったけれどメールアドレスが登録されていなかったときのメッセージ。 [default: なし] +-none-address: #(who)さんはアドレスを登録していません。 + +# SMTPのホスト [default: localhost] +-smtphost: localhost + +# SMTPのポート [default: smtp(25)] +-smtpport: 25 + +# SMTPで自ホストのFQDN [default: localhost] +-smtpfqdn: localhost + +# SMTPのユーザ。指定されれば SMTP Auth を行う [default: なし] +-smtpuser: example1 + +# SMTPのパスワード [default: 空パスワード('')] +-smtppass: test-password + +# 送信するメールの既定件名(エイリアス使用不可) [default: Message from IRC] +-subject: Message from IRC + +# 送信するメールの本文 [default: #(date) << #(from.name|from.nick|from.nick.now) >> #(message)] +-format: #(date)に#(from.name|from.nick|from.nick.now)さんから#(message)という伝言です。 + +# 送信したときのメッセージ。 [default: なし] +accept: #(who)さんに#(message)と伝言しておきました。 + +# ---- POP before SMTP の指定 ---- +# POP before SMTPを使う。 [default: no] +-use-pop3: yes + +# POP before SMTPのタイムアウト時間(分)。分からない場合は指定しなくて良い。 [default: 0] +-pop3-expire: 4 + +# POPのホスト。 [default: localhost] +-pop3host: localhost + +# POPのポート。 [default: pop(110)] +-pop3port: 110 + +# POPのユーザ [default: OSのユーザ名] +-pop3user: example1 + +# POPのパスワード [default: 空パスワード('')] +-pop3pass: test-password + +# ---- エラーメッセージの設定 ---- + +# 一般エラー。 +# error-[state] と言う形式で詳細エラーメッセージを指定できる。 +# [state]は、 +# * mailfrom(メールの送信者を指定しようとしてエラー) +# * rcptto(メールの送信先を指定しようとしてエラー) +# * norcptto(メールの送信先が全部無くなった) +# * data(メールの中身を送信しようとしてエラー) +# * finish(メールの中身を送信したらエラー) +# がある。特に欲しくなければerror-[state]は指定しなくても構わない。 +# メッセージを出したくないなら中身の無いエントリを指定すれば良い。 +# error-[state]が指定されてない場合は代わりに error を使う。 [default: 未定義] + +-error-rcptto: +-error-norcptto: #(who)さんには送れませんでした。送信できるメールアドレスがありません。 +-error-data: メールが送信できません。DATAコマンドに失敗しました。#(line;サーバ応答:%s|;) +-error: メール送信エラーです。#(line;サーバ応答:%s|;)#(state; on %s|;) + +# 致命的なエラー。メールに個別なエラーではないので送信者(のprefix)毎に1メッセージ送られる。 +# fatalerror-[state] +# [state]: +# * first(接続エラー) +# * helo(SMTPセッションを開始出来ない) +# がある。特に欲しくなければfatalerror-[state]は指定しなくても構わない。 +# メッセージを出したくないなら中身の無いエントリを指定すれば良い。 +# fatalerror-[state]が指定されてない場合は代わりに fatalerror を使う。 [default: 未定義] + +-fatalerror-first: SMTPサーバに接続できません。 +-fatalerror: SMTPセッションで致命的なエラーがありました。#(line; サーバ応答:%s|;)#(state; on %s|;) +=cut diff -urN /non-existant-dir/module/Auto/Oper.pm tiarra-20080510/module/Auto/Oper.pm --- /non-existant-dir/module/Auto/Oper.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/Auto/Oper.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,133 @@ +# ----------------------------------------------------------------------------- +# $Id: Oper.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +package Auto::Oper; +use strict; +use warnings; +use base qw(Module); +use Module::Use qw(Auto::Utils); +use Auto::Utils; +use Mask; +use Multicast; + +sub new { + my $class = shift; + my $this = $class->SUPER::new(@_); + $this; +} + +sub message_arrived { + my ($this,$msg,$sender) = @_; + my @result = ($msg); + + my ($get_raw_ch_name,$reply,$reply_as_priv,$reply_anywhere,$get_full_ch_name) + = Auto::Utils::generate_reply_closures($msg,$sender,\@result); + + my $op = sub { + $sender->send_message($this->construct_irc_message( + Command => 'MODE', + Params => [$get_raw_ch_name->(),'+o',$msg->nick])); + }; + + # 鯖からクライアントへのPRIVMSGで、かつrequestにマッチしているか？ + if ($sender->isa('IrcIO::Server') && + $msg->command eq 'PRIVMSG' && + Mask::match_array([$this->config->request('all')],$msg->param(1), 1)) { + # 指定されたチャンネルは既知か？言い換えれば、privではないか？ + my $ch_name = $msg->param(0); + my ($ch_name_plain) = Multicast::detatch($ch_name); + my $ch = $sender->channel($ch_name_plain); + if (defined $ch) { + # 指定されたチャンネルに、要求者は入っているか？ + if (defined $ch->names($msg->nick)) { + # なるとを渡しても良いのなら渡す。 + if (Mask::match_deep_chan([$this->config->mask('all')],$msg->prefix,$get_full_ch_name->())) { + # 自分はなるとを持ってるか？ + my $myself = $ch->names($sender->current_nick); + if ($myself->has_o) { + # 相手はなるとを持っているか？ + my $target = $ch->names($msg->nick); + if ($target->has_o) { + $reply->($this->config->oper('random')); + } else { + $reply->($this->config->message('random')); + $op->(); + } + } else { + $reply->($this->config->not_oper('random')); + } + } else { + $reply->($this->config->deny('random')); + } + } else { + $reply_as_priv->($this->config->out('random')); + } + } else { + $reply_as_priv->($this->config->private('random')); + } + } + return @result; +} + +1; + +=pod +info: 特定の文字列を発言した人を+oする。 +default: off +section: important + +# Auto::Aliasを有効にしていれば、エイリアス置換を行ないます。 + +# +oを要求する文字列(マスク)を指定します。 +request: なると寄越せ + +# チャンネルオペレータ権限を要求した人と要求されたチャンネルが +# ここで指定したマスクに一致しなかった場合は +# denyで指定した文字列を発言し、+oをやめます。 +# 省略された場合は誰にも+oしません。 +# 書式は「チャンネル 発言者」です。 +# マッチングのアルゴリズムは次の通りです。 +# 1. チャンネル名にマッチするmask定義を全て集める +# 2. 集まった定義の発言者マスクを、定義された順にカンマで結合する +# 3. そのようにして生成されたマスクで発言者のマッチングを行ない、結果を+o可能性とする。 +# 例1: +# mask: *@2ch* *!*@* +# mask: #*@ircnet* *!*@*.hoge.jp +# この例ではネットワーク 2ch の全てのチャンネルで誰にでも +o し、 +# ネットワーク ircnet の # で始まる全てのチャンネルでホスト名 *.hoge.jp の人に+oします。 +# #*@ircnetだと「#hoge@ircnet:*.jp」などにマッチしなくなります。 +# 例2: +# mask: #hoge@ircnet -*!*@*,+*!*@*.hoge.jp +# mask: * +*!*@* +# 基本的に全てのチャンネルで誰にでも +o するが、例外的に#hoge@ircnetでは +# ホスト名 *.hoge.jp の人にしか +o しない。 +# この順序を上下逆にすると、全てのチャンネルで全ての人を +o する事になります。 +# 何故なら最初の* +*!*@*が全ての人にマッチするからです。 +mask: * *!*@* + +# +oを要求した人を実際に+oする時、ここで指定した発言をしてから+oします。 +# #(name|nick)のようなエイリアス置換を行います。 +# エイリアス以外でも、#(nick.now)を相手のnickに、#(channel)を +# そのチャンネル名にそれぞれ置換します。 +message: 了解 + +# +oを要求されたが+oすべき相手ではなかった場合の発言。 +# 省略されたら何も喋りません。 +deny: 断わる + +# +oを要求されたが相手は既にチャンネルオペレータ権限を持っていた場合の発言。 +# 省略されたらdenyに設定されたものを使います。 +oper: 既に@を持っている + +# +oを要求されたが自分はチャンネルオペレータ権限を持っていなかった場合の発言。 +# 省略されたらdenyに設定されたものを使います。 +not-oper: @が無い + +# チャンネルに対してでなく自分に対して+oの要求を行なった場合の発言。 +# 省略されたらdenyに設定されたものを使います。 +private: チャンネルで要求せよ + +# チャンネルの外から+oを要求された場合の発言。+nチャンネルでは起こりません。 +# 省略されたらdenyに設定されたものを使います。 +out: チャンネルに入っていない +=cut diff -urN /non-existant-dir/module/Auto/Random.pm tiarra-20080510/module/Auto/Random.pm --- /non-existant-dir/module/Auto/Random.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/Auto/Random.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,176 @@ +# ----------------------------------------------------------------------------- +# $Id: Random.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +package Auto::Random; +use strict; +use warnings; +use base qw(Module); +use Module::Use qw(Auto::Utils Tools::FileCache); +use Auto::Utils; +use Tools::FileCache; +use Mask; + +sub new { + my $class = shift; + my $this = $class->SUPER::new(@_); + $this->{config} = []; + + $this->_load(); + return $this; +} + +sub _load { + my ($this) = @_; + + my ($BLOCKS_NAME) = 'blocks'; + + foreach my $blockname ($this->config->get($BLOCKS_NAME, 'all')) { + die "$blockname block name is reserved!" if $blockname eq $BLOCKS_NAME; + my $block = $this->config->get($blockname); + die "$blockname isn't block!" unless UNIVERSAL::isa($block, 'Configuration::Block'); + push(@{$this->{config}}, + { + mask => [Mask::array_or_all_chan($block->mask('all'))], + request => [$block->request('all')], + rate => $block->rate, + format => [$block->format('all')], + count_query => [$block->count_query('all')], + count_format => [$block->count_format('all')], + add => [$block->get('add', 'all')], + added_format => [$block->added_format('all')], + remove => [$block->remove('all')], + removed_format => [$block->removed_format('all')], + modifier => [$block->modifier('all')], + database => Tools::FileCache->register($block->file, + 'std', + $block->file_encoding), + }); + } +} + +sub destruct { + my ($this) = @_; + + map { + $_->{database}->unregister(); + } @{$this->{config}}; + + return $this; +} + +sub message_arrived { + my ($this,$msg,$sender) = @_; + my @result = ($msg); + + my (undef,undef,undef,$reply_anywhere,$get_full_ch_name) + = Auto::Utils::generate_reply_closures($msg,$sender,\@result); + + if ($msg->command eq 'PRIVMSG') { + foreach my $block (@{$this->{config}}) { + if (Mask::match_deep($block->{request}, $msg->param(1))) { + if (Mask::match_deep_chan($block->{mask}, $msg->prefix, $get_full_ch_name->())) { + # ランダムな発言を行なう。 + my $rate_rand = int(rand() * hex('0xffffffff')) % 100; + if ($rate_rand < ($block->{rate} || 100)) { + my $reply_str = $block->{database}->get_value() || undef; + $reply_anywhere->($block->{format}, 'message' => $reply_str); + } + } + } elsif (Mask::match_deep($block->{count_query}, $msg->param(1))) { + if (Mask::match_deep_chan($block->{mask}, $msg->prefix, $get_full_ch_name->())) { + # 登録数を求める + my $count = $block->{database}->length(); + $reply_anywhere->($block->{count_format}, 'count' => $count); + } + } else { + my $msg_from_modifier_p = sub { + !defined $msg->prefix || + Mask::match_deep_chan($block->{modifier}, $msg->prefix, $get_full_ch_name->()); + }; + my ($keyword,$param) = $msg->param(1) =~ /^\s*(.+?)\s+(.+?)\s*$/; + if (defined $keyword && defined $param) { + if (Mask::match_deep($block->{add}, $keyword) && + $msg_from_modifier_p->()) { + # 発言の追加 + # この人は変更を許可されている。 + if ($param ne '') { + $block->{database}->add_value($param); + $reply_anywhere->($block->{added_format}, 'message' => $param); + } + } + } elsif (Mask::match_deep($block->{remove}, $keyword) && + $msg_from_modifier_p->()) { + # 発言の削除 + # この人は削除を許可されている。 + my $count = $block->{database}->del_value($param); + $reply_anywhere->($block->{removed_format}, 'message' => $param, 'count' => $count); + } + } + } + } + + return @result; +} + +1; + +=pod +info: 特定の発言に反応してランダムな発言をします。 +default: off + +# Auto::Aliasを有効にしていれば、エイリアス置換を行ないます。 + +# 使用するブロックの定義。 +blocks: wimikuji + +wimikuji { + # ランダムに発言するメッセージの書かれたファイルと、その文字コードを指定します。 + # ファイルの中では一行に一つのメッセージを書いて下さい。 + file: random.txt + file-encoding: euc + + # 反応する発言を表すマスクを指定します。 + request: ゐみくじ + + # メッセージの登録数を返答するキーワードを指定します。 + count-query: ゐみくじ登録数 + + # メッセージの登録数を返答するときの反応を指定します。 + # formatで指定できるものと同じです。#(count)は登録数になります。 + count-format: ゐみくじは#(count)件登録されています。 + + # ランダムなメッセージを発言する際のフォーマットを指定します。 + # エイリアス置換が有効です。#(message)、#(nick.now)、#(channel)は + # それぞれメッセージ内容、相手のnick、チャンネル名に置換されます。 + # 何も登録されていないときのために、#(message|;無登録)のように指定すると良いでしょう。 + format: #(name|nick.now)の運命は#(message) + + # 反応する人のマスク。 + mask: * *!*@* + # plum: mask: *!*@* + + # メッセージが追加されたときの反応を指定します。 + # formatで指定できるものと同じです。#(message)は追加されたメッセージになります。 + added-format: #(name|nick.now): ゐみくじ #(message) を追加しました。 + + # メッセージが削除されたときの反応を指定します。 + # formatで指定できるものと同じです。#(message)は削除されたメッセージになります。 + removed-format: #(name|nick.now): ゐみくじ #(message) を削除しました。 + + # 発言に反応する確率を指定します。百分率です。省略された場合は100と見做されます。 + rate: 100 + + # メッセージを追加するキーワードを指定します。 + # ここで指定したキーワードを発言すると、新しいメッセージを追加します。 + # 実際の追加方法は「 <追加するメッセージ>」です。 + add: ゐみくじ追加 + + # メッセージを削除するキーワードを指定します。 + # 実際の削除方法は「 <削除するキーワード>」です。 + remove: ゐみくじ削除 + + # addとremoveを許可する人。省略された場合は誰も変更できません。 + modifier: * *!*@* + # plum: modifier: *!*@* +} +=cut diff -urN /non-existant-dir/module/Auto/Reply.pm tiarra-20080510/module/Auto/Reply.pm --- /non-existant-dir/module/Auto/Reply.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/Auto/Reply.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,236 @@ +# -*- cperl -*- +# ----------------------------------------------------------------------------- +# $Id: Reply.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +# copyright (C) 2003 Topia . all rights reserved. +package Auto::Reply; +use strict; +use warnings; +use base qw(Module); +use Module::Use qw(Auto::Utils Auto::AliasDB::CallbackUtils Tools::HashDB); +use Auto::Utils; +use Auto::AliasDB::CallbackUtils; +use Tools::HashDB; +use Mask; + +sub new { + my $class = shift; + my $this = $class->SUPER::new(@_); + $this->{config} = []; + + $this->_load; + return $this; +} + +sub _load { + my $this = shift; + + my $BLOCKS_NAME = 'blocks'; + + foreach my $blockname ($this->config->get($BLOCKS_NAME, 'all')) { + die "$blockname block name is reserved!" if $blockname eq $BLOCKS_NAME; + my $block = $this->config->get($blockname); + die "$blockname isn't block!" unless UNIVERSAL::isa($block, 'Configuration::Block'); + push(@{$this->{config}}, { + mask => [Mask::array_or_all_chan($block->mask('all'))], + request => [$block->request('all')], + reply_format => [$block->reply_format('all')], + max_reply => $block->max_reply, + rate => $block->rate, + count_query => [$block->count_query('all')], + count_format => [$block->count_format('all')], + add => [$block->get('add', 'all')], + added_format => [$block->added_format('all')], + remove => [$block->remove('all')], + removed_format => [$block->removed_format('all')], + modifier => [$block->modifier('all')], + use_re => $block->use_re, + database => Tools::HashDB->new( + $block->file, + $block->file_encoding, + $block->use_re, + ($block->ignore_comment ? undef : sub {0;})), + }); + } +} + +sub message_arrived { + my ($this,$msg,$sender) = @_; + my @result = ($msg); + + my $return_value = sub { + return @result; + }; + + my (undef,undef,undef,$reply_anywhere,$get_full_ch_name) + = Auto::Utils::generate_reply_closures($msg,$sender,\@result); + + if ($msg->command eq 'PRIVMSG') { + foreach my $block (@{$this->{config}}) { + # count : 登録数の計算 + if (Mask::match_deep($block->{count_query}, $msg->param(1))) { + if (Mask::match_deep_chan($block->{mask}, $msg->prefix, $get_full_ch_name->())) { + # 登録数を求める + my $count = scalar $block->{database}->keys; + $reply_anywhere->($block->{count_format}, 'count' => $count); + } + return $return_value->(); + } + + my $msg_from_modifier_p = do { + !defined $msg->prefix || + Mask::match_deep_chan($block->{modifier}, $msg->prefix, $get_full_ch_name->()); + }; + + my $tail = $msg->param(1); + $tail =~ s/^\s*(.*)\s*$/$1/; + my $keyword; + ($keyword, $tail) = split(/\s+/, $tail, 2); + + if ($msg_from_modifier_p) { + # request + if (Mask::match_deep($block->{request}, $keyword)) { + # 一致する反応をリストする + foreach my $key (_search($block, $tail, $block->{max_reply})) { + foreach my $message (@{$block->{database}->get_array($key)}) { + $reply_anywhere->($block->{reply_format}, + 'key' => $key, + 'message' => $message); + } + } + return $return_value->(); + } + + # add and remove + if (defined $tail) { + my ($key, $param) = split(/\s+/, $tail, 2); + if (Mask::match_deep($block->{add}, $keyword)) { + # 発言の追加 + # この人は変更を許可されている。 + if (defined $key && defined $param) { + $block->{database}->add_value($key, $param); + $reply_anywhere->($block->{added_format}, 'key' => $key, 'message' => $param); + } + return $return_value->(); + } elsif (Mask::match_deep($block->{remove}, $keyword)) { + # 発言の削除 + # この人は削除を許可されている。 + if (defined $key) { + my $count = $block->{database}->del_value($key, $param); + $reply_anywhere->( + $block->{removed_format}, + 'key' => $key, + 'message' => $param, + 'count' => $count); + } + return $return_value->(); + } + } + } + + # match + if (Mask::match_deep_chan($block->{mask}, $msg->prefix, $get_full_ch_name->())) { + my $key = (_search($block, $msg->param(1), 1, $block->{rate}))[0]; + if (defined $key) { + $reply_anywhere->($block->{database}->get_value_random($key)); + } + } + } + } + + return @result; +} + +sub _search { + # key を検索する関数。 + + # $block : 検索対象のブロック + # $key : 検索するキー + # $count : 最大発見個数。省略すると全て。 + # $rate : 発見してもランダムに忘れる(笑)確率(パーセント)。省略すると100%。 + my ($block, $str, $count, $rate) = @_; + + my @masks; + foreach my $mask ($block->{database}->keys) { + if (Mask::match_array([$mask], $str, 1, $block->{use_re}, 0)) { + # match + if (!defined $rate || (int(rand() * hex('0xffffffff')) % 100) < $rate) { + push(@masks, $mask); + if (defined $count && $count <= scalar(@masks)) { + # $count 分発見したので終了。 + last; + } + } + } + } + + return @masks; +} + +1; + +=pod +info: 特定の発言に反応して発言をします。 +default: off + +# Auto::Aliasを有効にしていれば、エイリアス置換を行ないます。 + +# 使用するブロックの定義。 +blocks: std + +std { + # データファイルと文字コードを指定します。 + # ファイルの中では一行に一つの"反応:メッセージ"を書いて下さい。 + file: reply.txt + file-encoding: euc + + # 反応チェックを行うキーワードを指定します。 + # 実際の指定方法は、「 <チェックしたい発言>」です。 + request: 反応チェック + + # request に反応するときのフォーマットを指定します。 + # #(key) がキーワード、 #(message) が発言に置換されます。 + reply-format: 「#(key)」という発言に「#(message)」と反応します。 + + # request に反応する最大個数を指定します。 + # あまり大きな値を指定すると、アタックが可能になったり、ログが流れて邪魔なので注意してください。 + max-reply: 5 + + # メッセージの登録数を返答するキーワードを指定します。 + count-query: 反応登録数 + + # メッセージの登録数を返答するときの反応を指定します。 + # formatで指定できるものと同じです。#(count)は登録数になります。 + count-format: 反応は#(count)件登録されています。 + + # 反応する人のマスク。 + mask: * *!*@* + # plum: mask: *!*@* + + # 反応が追加されたときの反応を指定します。 + # formatで指定できるものと同じです。#(message)は追加されたメッセージになります。 + added-format: #(name|nick.now): #(key) に対する反応 #(message) を追加しました。 + + # メッセージが削除されたときの反応を指定します。 + # formatで指定できるものと同じです。#(message)は削除されたメッセージになります。 + removed-format: #(name|nick.now): #(key) #(message;に対する反応 %s|;) を #(count) 件削除しました。 + + # 発言に反応する確率を指定します。百分率です。省略された場合は100と見做されます。 + rate: 100 + + # メッセージを追加するキーワードを指定します。 + # ここで指定したキーワードを発言すると、新しいメッセージを追加します。 + # 実際の追加方法は「 <追加するメッセージ>」です。 + add: 反応追加 + + # メッセージを削除するキーワードを指定します。 + # 実際の削除方法は「 <削除するキーワード>」です。 + remove: 反応削除 + + # addとremoveを許可する人。省略された場合は「* *!*@*」と見做します。 + modifier: * *!*@* + + # 正規表現拡張を許可するか。省略された場合は禁止します。 + use-re: 1 +} +=cut diff -urN /non-existant-dir/module/Auto/Response.pm tiarra-20080510/module/Auto/Response.pm --- /non-existant-dir/module/Auto/Response.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/Auto/Response.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,91 @@ +# -*- cperl -*- +# ----------------------------------------------------------------------------- +# $Id: Response.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +# copyright (C) 2003 Topia . all rights reserved. +package Auto::Response; +use strict; +use warnings; +use base qw(Module); +use Module::Use qw(Auto::Utils Auto::AliasDB::CallbackUtils Tools::GroupDB); +use Auto::Utils; +use Auto::AliasDB::CallbackUtils; +use Tools::GroupDB; +use Mask; +use Multicast; + +sub new { + my $class = shift; + my $this = $class->SUPER::new(@_); + $this->{database} = Tools::GroupDB->new($this->config->file, 'pattern', $this->config->charset, 1, 1); + + return $this; +} + +sub message_arrived { + my ($this,$msg,$sender) = @_; + my @result = ($msg); + + # サーバーからのメッセージか？ + if ($sender->isa('IrcIO::Server')) { + # PRIVMSGか？ + if ($msg->command eq 'PRIVMSG') { + my @matches = $this->{database}->find_groups_with_primary($msg->param(1)); + if (@matches) { + my ($callbacks) = []; + Auto::AliasDB::CallbackUtils::register_extcallbacks($callbacks, $msg, $sender); + my (undef,undef,undef,$reply_anywhere,$get_full_ch_name) + = Auto::Utils::generate_reply_closures($msg, $sender, \@result, undef, $callbacks); + + if (Mask::match_deep_chan([$this->config->mask('all')],$msg->prefix, $get_full_ch_name->())) { + # 一致していた。 + foreach my $match (@matches) { + # maskが一致しなければ実行しない。飛ばす。 + my $mask = Tools::GroupDB::get_array($match, 'mask'); + next if ($mask && !Mask::match_deep_chan($mask, $msg->prefix, $get_full_ch_name->())); + # rate以下ならば実行しない。飛ばす。 + my $rate = Tools::GroupDB::get_value($match, 'rate'); + next unless !defined($rate) || (int(rand(100)) < $rate); + $reply_anywhere->(Tools::GroupDB::get_value_random($match, 'response')); + } + } + } + } + } + + return @result; +} + +1; + +=pod +info: データファイルの指定にしたがって反応する。 +default: off + +# 大量の反応データを定義するのに向いています。 + +# データファイルのフォーマット +# | pattern: re:^(こん(に)?ちは) +# | rate: 90 +# | mask: * *!*@* +# | #plum: mask: *!*@* +# | response: こんにちは。 +# | response: いらっしゃいませ。 +# | +# | pattern: おやすみ +# | rate: 20 +# | response: おやすみなさい。 +# patternは一行しか書けません。(手抜き +# maskもrateも省略できます。省略した場合はmaskは全員、rateは100となります。 +# responseは複数書いておけばランダムに選択されます。 + +# データファイル +file: response.txt + +# 文字コード +charset: euc + +# 使用を許可する人&チャンネルのマスク。 +mask: * *!*@* +# plum: mask: +*!*@* +=cut diff -urN /non-existant-dir/module/Auto/Utils.pm tiarra-20080510/module/Auto/Utils.pm --- /non-existant-dir/module/Auto/Utils.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/Auto/Utils.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,226 @@ +# ----------------------------------------------------------------------------- +# $Id: Utils.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +package Auto::Utils; +use strict; +use warnings; +use Module::Use qw(Auto::AliasDB); +use Auto::AliasDB; +use Multicast; +use RunLoop; +use base qw(Tiarra::IRC::NewMessageMixin); + +# get_ch_name は get_raw_ch_name のエイリアス(過去互換のため) +*get_ch_name = \&get_raw_ch_name; +sub get_raw_ch_name { + # ネットワーク名抜きの送信先(チャンネル/nick)名 or undef を得る + my ($msg, $ch_place) = @_; + + if (defined($msg->param($ch_place)) && $msg->param($ch_place) ne '') { + return(scalar(Multicast::detach($msg->param($ch_place)))); + } else { + return undef; + } +} + +sub get_full_ch_name { + # ネットワーク名付きの送信先(チャンネル/nick)名 or undef を得る + my ($msg, $ch_place) = @_; + + if (defined($msg->param($ch_place)) && $msg->param($ch_place) ne '') { + return($msg->param($ch_place)); + } else { + return undef; + } +} + +sub sendto_channel_closure { + # チャンネル等に PRIVMSG / NOTICE を送るクロージャを返します。 + + # - 引数 - + # $sendto : チャンネル名 or ニック。ネットワーク名を付けて下さい。 + # $command : 'PRIVMSG' or 'NOTICE'。その他のコマンドも制限はしませんが意味が無いでしょう。 + # $msg : message_arrivedに渡ってきた$msg。エイリアス置換に使用されます。よって、 + # 後述する $use_alias が false なら指定する必要はありません。 + # その場合は undef でも渡しておきましょう。 + # $sender : message_arrivedに渡ってきた$sender。送信に使います。ない場合は + # $result とともに undef を指定してください。 + # $result : message_arrivedの返り値にする配列の参照。詳細は例を見ましょう。 + # $use_alias : エイリアス置き換えを行うかどうか。省略可で省略した場合は + # 行うが、 $msg, $sender のどちらかが undef ならエイリアス + # 置き換えを呼び出せないので行わない。 + # $extra_callbacks + # : 追加のエイリアス置換コールバック。省略可。 + # + # エイリアス置換・コールバックに関しては Auto::AliasDB を参照してください。 + # + # - 返り値 - + # $send_message + # $send_message + # : クロージャ。第一引数にメッセージ、第二引数以降に追加のエイリアス(省略可能)を指定して呼び出す。 + # メッセージとしてundefが渡された場合は、何もせずに終了する。 + # + # - 使用例 - + # sub message_arrived { + # my ($this,$msg,$sender) = @_; + # my @result = ($msg); + # my $send_message = + # sendto_channel_closure('#test@ircnet', 'NOTICE', $msg, $sender, \@result); + # $send_message->('message', 'hoge' => 'moge'); + # return @result; + # } + # + + my ($sendto, $command, $msg, $sender, $result, $use_alias, $extra_callbacks) = @_; + + $use_alias = 1 if (!defined $use_alias && defined $msg && defined $sender); + $extra_callbacks = [] unless defined $extra_callbacks; + + return sub { + my ($line,%extra_replaces) = @_; + return if !defined $line; + foreach my $str ((ref($line) eq 'ARRAY') ? @$line : $line) { + my $msg_to_send = __PACKAGE__->construct_irc_message( + Command => $command, + Params => ['', # 後で設定 + ($use_alias ? Auto::AliasDB->shared->stdreplace_add( + $msg->prefix || $sender->fullname, + $str, + $extra_callbacks, + $msg, + $sender, + %extra_replaces) + : $str)]); + my ($rawname, $network_name, $specified_network) = + Multicast::detach($sendto); + my $get_network_name = sub { + $specified_network ? $network_name : + Configuration->shared_conf->networks->default; + }; + my $sendto_client = Multicast::attach_for_client($rawname, $network_name); + if (!defined $sender) { + # 鯖にはチャンネル名にネットワーク名を付けない。 + my $for_server = $msg_to_send->clone; + $sender = RunLoop->shared_loop->network($get_network_name->()); + if (defined $sender) { + $for_server->param(0, $rawname); + $sender->send_message($for_server); + } + + # クライアントにはチャンネル名にネットワーク名を付ける。 + # また、クライアントに送られる時にはPrefixがそのユーザーに設定されるよう註釈を付ける。 + my $for_client = $msg_to_send->clone; + $for_client->param(0, $sendto_client); + $for_client->remark('fill-prefix-when-sending-to-client',1); + RunLoop->shared_loop->broadcast_to_clients($for_client); + } elsif ($sender->isa('IrcIO::Server')) { + # 鯖にはチャンネル名にネットワーク名を付けない。 + my $for_server = $msg_to_send->clone; + $for_server->param(0, $rawname); + $sender->send_message($for_server); + + # クライアントにはチャンネル名にネットワーク名を付ける。 + # また、クライアントに送られる時にはPrefixがそのユーザーに設定されるよう註釈を付ける。 + my $for_client = $msg_to_send->clone; + $for_client->param(0, $sendto_client); + $for_client->remark('fill-prefix-when-sending-to-client',1); + push @$result,$for_client; + } elsif ($sender->isa('IrcIO::Client')) { + # チャンネル名にネットワーク名を付ける。 + my $for_server = $msg_to_send->clone; + $for_server->param(0, $sendto); + push @$result,$for_server; + + my $for_client = $msg_to_send->clone; + $for_client->prefix($sender->fullname); + $for_client->param(0, $sendto_client); + $sender->send_message($for_client); + } + } + }; +} + +sub generate_reply_closures { + # 送信者に NOTICE で返答するクロージャを返します。 + + # - 引数 - + # $msg : message_arrivedに渡ってきた$msg。 + # $sender : message_arrivedに渡ってきた$sender。 + # $result : message_arrivedの返り値にする配列の参照。詳細は例を見ましょう。 + # $use_alias : エイリアス置き換えを行うかどうか。省略可、省略した場合は行う。 + # $extra_callbacks + # : 追加のエイリアス置換コールバック。省略可。 + # $ch_place : チャンネル名が存在する $msg->param 内部の位置を指定します。省略時は0(先頭)です。 + # + # エイリアス置換・コールバックに関しては Auto::AliasDB を参照してください。 + # + # - 返り値 - + # ($get_raw_ch_name, $reply, $reply_as_priv, $reply_anywhere, $get_full_ch_name) + # $get_raw_ch_name : クロージャ。ネットワーク名無しのチャンネル名 or undef を返します。 + # $reply : クロージャ。チャンネルに返答します。 + # $reply_as_priv : クロージャ。送信者に直接 priv で返答します。 + # $reply_anywhere : クロージャ。チャンネルが有効であれば $reply が、そうでなければ $reply_as_priv です。 + # $get_full_ch_name : クロージャ。ネットワーク名付きのチャンネル名 or undef を返します。 + # + # $reply* は第一引数にメッセージ、第二引数以降に追加のエイリアス(省略可能)を指定して呼び出します。 + # 第一引数にundefが渡された場合は、何もせずに終了します。 + # + # - 使用例 - + # sub message_arrived { + # my ($this,$msg,$sender) = @_; + # my @result = ($msg); + # my ($get_ch_name, $reply, $reply_as_priv, $reply_anywhere) = + # generate_reply_closures($msg, $sender, \@result); + # $reply_anywhere->('message', 'hoge' => 'moge'); + # return @result; + # } + # + # - 備考 - + # $get_raw_ch_name がクロージャなのは過去との互換性のため、 + # $get_full_ch_name がクロージャーなのは共通性のためです。 + + my ($msg, $sender, $result, $use_alias, $extra_callbacks, $ch_place) = @_; + $use_alias = 1 unless defined $use_alias; + $extra_callbacks = [] unless defined $extra_callbacks; + $ch_place = 0 unless defined $ch_place; + + my $raw_ch_name = get_raw_ch_name($msg, $ch_place); + my $get_raw_ch_name = sub () { + $raw_ch_name; + }; + my $full_ch_name = get_full_ch_name($msg, $ch_place); + my $get_full_ch_name = sub () { + $full_ch_name; + }; + my $reply = sub { + sendto_channel_closure($msg->param($ch_place), 'NOTICE', $msg, $sender, $result, + $use_alias, $extra_callbacks)->(@_, 'channel' => $raw_ch_name); + }; + my $reply_as_priv = sub { + my ($line,%extra_replaces) = @_; + return if !defined $line; + foreach my $str ((ref($line) eq 'ARRAY') ? @$line : $line) { + $sender->send_message(__PACKAGE__->construct_irc_message( + Command => 'NOTICE', + Params => [$msg->nick, + ($use_alias ? Auto::AliasDB->shared->stdreplace_add( + $msg->prefix, + $str, + $extra_callbacks, + $msg, + $sender, + %extra_replaces) + : $str)])); + } + }; + my $reply_anywhere = sub { + if (defined($raw_ch_name) && Multicast::nick_p($raw_ch_name)) { + return $reply_as_priv; + } else { + return $reply; + } + }; + return ($get_raw_ch_name,$reply,$reply_as_priv,$reply_anywhere->(),$get_full_ch_name); +} + +1; diff -urN /non-existant-dir/module/CTCP/ClientInfo.pm tiarra-20080510/module/CTCP/ClientInfo.pm --- /non-existant-dir/module/CTCP/ClientInfo.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/CTCP/ClientInfo.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,61 @@ +# ----------------------------------------------------------------------------- +# $Id: ClientInfo.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +# BulletinBoardのctcp-clientinfo-で始まる値を探し、それをCLIENTINFOとして応答する。 +# ----------------------------------------------------------------------------- +package CTCP::ClientInfo; +use strict; +use warnings; +use base qw(Module); +use CTCP; +use Multicast; +use BulletinBoard; + +# CLIENTINFO設定 +BulletinBoard->shared->ctcp_clientinfo_clientinfo('CLIENTINFO'); + +sub message_arrived { + my ($this,$msg,$sender) = @_; + + if ($sender->isa('IrcIO::Server') && + $msg->command eq 'PRIVMSG' && + defined $msg->nick) { + + my $ctcp = CTCP::extract($msg); + if (defined $ctcp && $ctcp eq 'CLIENTINFO') { + + my $last = $sender->remark('last-ctcp-replied'); + if (!defined $last || time - $last > ($this->config->interval || 3)) { + # 前回のCTCP反応から一定時間以上経過している。 + + my $clientinfo = join( + ' ', + map { + BulletinBoard->shared->get($_); + } grep { + m/^ctcp-clientinfo-/; + } BulletinBoard->shared->keys); + + my $reply = CTCP::make( + "CLIENTINFO $clientinfo", + scalar Multicast::detach($msg->nick) + ); + $sender->send_message($reply); + $sender->remark('last-ctcp-replied',time); + } + } + } + + $msg; +} + +1; + +=pod +info: CTCP CLIENTINFOに応答する。 +default: off +section: important + +# CTCP::Versionのintervalと同じ。 +interval: 3 +=cut diff -urN /non-existant-dir/module/CTCP/DCC/RewriteAddress.pm tiarra-20080510/module/CTCP/DCC/RewriteAddress.pm --- /non-existant-dir/module/CTCP/DCC/RewriteAddress.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/CTCP/DCC/RewriteAddress.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,335 @@ +# ----------------------------------------------------------------------------- +# $Id: RewriteAddress.pm 11164 2008-05-05 08:59:02Z topia $ +# ----------------------------------------------------------------------------- +# Rewrite ip address of CTCP DCC issued by client +# ----------------------------------------------------------------------------- +package CTCP::DCC::RewriteAddress; +use strict; +use warnings; +use base qw(Module); +use Multicast; +use CTCP; +use Tiarra::Resolver; +use Module::Use qw(Tools::HTTPClient); +use Tools::HTTPClient; + + +sub new { + my $this = shift->SUPER::new(@_); + + $this->{permit_types} = [map uc, split /\s+/, + ($this->config->type || 'CHAT SEND')]; + $this->{resolvers} = [map lc, split /\s+/, $this->config->resolver]; + + return $this; +} + +sub message_arrived { + my ($this,$msg,$sender) = @_; + + if ($sender->isa('IrcIO::Client') && + $msg->command eq 'PRIVMSG' && + !defined $msg->nick) { + + my $text = $msg->param(1); + foreach my $ctcp (CTCP->extract_from_text("$text")) { + if ($ctcp =~ m|^DCC (\S*) (.*)$|) { + my ($type, $params) = (uc($1), $2); + next unless grep { $type eq $_ } @{$this->{permit_types}}; + my $result = $this->rewrite_dcc( + $msg->clone, $type, $params, $sender); + next unless $result; + my $encoded_ctcp = CTCP->make_text($ctcp); + $text =~ s/\Q$encoded_ctcp\E//; + } + } + if ($text) { + $msg->param(1, $text); + return $msg; + } else { + return undef; + } + } + + $msg; +} + +our %resolvers = ( + 'server-socket' => { + resolver => sub { + my ($this, $actions, $sender, $conf, $msg, $addr, $port) = @_; + my $sock = ($this->_runloop->networks_list)[0]->sock; + return undef unless defined $sock; + + $actions->{resolve}->( + nameinfo => $sock->sockname, + sub { + $actions->{callback}->(shift->answer_data->[0], + $port); + }); + }, + }, + 'client-socket' => { + resolver => sub { + my ($this, $actions, $sender, $conf, $msg, $addr, $port) = @_; + my $sock = $sender->sock; + return undef unless defined $sock; + + $actions->{resolve}->( + nameinfo => $sock->peername, + sub { + $actions->{callback}->(shift->answer_data->[0], + $port); + }); + 1; + }, + }, + 'dns' => { + resolver => sub { + my ($this, $actions, $sender, $conf, $msg, $addr, $port) = @_; + + $actions->{resolve}->( + addr => $conf->host, + sub { + $actions->{callback}->(shift->answer_data->[0], + $port); + }); + }, + }, + 'http' => { + resolver => sub{ + my ($this, $actions, $sender, $conf, $msg, $addr, $port) = @_; + + my $regex = "".$conf->regex; + Tools::HTTPClient->new( + Method => 'GET', + Url => $conf->url, + Debug => 1, + )->start( + sub { + my $resp = shift; + $actions->{step}->( + sub { + return undef unless ref($resp); + if ($resp->{Content} !~ /$regex/) { + ::printmsg("http: regex: $regex"); + ::printmsg("http: content: $resp->{Content}"); + return undef; + } + $actions->{callback}->($1, $port); + 1; + }); + }); + 1; + }, + }, + ); + +sub intaddr_to_octet { + my $intaddr = shift; + my $tail = $intaddr; + my @ret; + foreach (0..3) { + unshift(@ret, $tail % 256); + $tail /= 256; + } + join('.', @ret); +} + +sub octet_to_intaddr { + my $ret = 0; + foreach (split /\./, shift) { + $ret *= 256; + $ret += $_; + } + $ret; +} + +# $this->get_dcc_address_port($msg, $msg_sender, $dcc_addr, $dcc_port, +# $callback, @resolvers) +# callback: +# sub { +# my ($addr, $port) = @_; +# $addr = default_addr unless defined $addr; +# $port = default_port unless defined $port; +# ... +# } +sub get_dcc_address_port { + my ($this, $msg, $sender, $addr, $port, $callback, @resolvers) = @_; + my $resolver; + my $step; + my $next; + + # resolving step wrapper. + # $actions->{step}->(sub { ... }, @args_to_closure) + # closure return undef (or on error): try next method. + # otherwise wrapper return with closure return value. + $step = sub { + my $ret = eval { shift->(@_) }; + if (!defined $ret) { + if ($@) { + ::printmsg("$resolver: error occurred: $@"); + } + ::printmsg("$resolver: cannot resolved. try next method."); + $next->(); + } else { + $ret; + } + }; + + # Tiarra::Resolver->resolve wrapper. + # $actions->{resolve}->($type => $data, sub { ... }, @args_to_callback); + # 1. resolve answer status is not OK, try next method. + # 2. call callback with args: (@args_to_callback, $resolved). + # 3. callback return undef, try next method. + # 4. otherwise wrapper return with callback return value + my $resolve = sub { + my $type = shift; + my $data = shift; + my $callback = shift; + my @args = @_; + + Tiarra::Resolver->resolve( + $type => $data, + sub { + my $resolved = shift; + my $ret = eval { + if ($resolved->answer_status ne $resolved->ANSWER_OK) { + ::printmsg("resolver: $type/$data: return not OK"); + ::printmsg("resolver: ". $resolved->answer_data); + return undef; # next method + } + $callback->(@args, $resolved, @_); + }; + if (!defined $ret) { + if ($@) { + ::printmsg("$resolver: error occurred: $@"); + } + ::printmsg("$resolver: cannot resolved. try next method."); + $next->(); + } else { + $ret; + } + }); + 1; + }; + + my $actions = { + callback => $callback, + step => $step, + resolve => $resolve, + }; + + $next = sub { + if (!@resolvers) { + ## FIXME: on cannot resolve + ::printmsg(__PACKAGE__."/rewrite_dcc: cannot resolve address at all"); + $callback->(); + } + $resolver = shift(@resolvers); + $step->(sub { $resolvers{$resolver}->{resolver}->( + $this, $actions, $sender, + $this->config->get($resolver, 'block'), $msg, $addr, $port); }); + }; + + $next->(); +} + +sub rewrite_dcc { + my ($this, $msg, $type, $param, $sender) = @_; + if ($param !~ /^(\S+) ([\d.]+) (\S+)(.*)$/) { + return undef; + } + + my ($arg, $addr, $port, $trail) = ($1, $2, $3, $4); + + $addr = intaddr_to_octet($addr); + my $send_dcc = sub { + my ($addr, $port) = @_; + $addr = octet_to_intaddr($addr); + $msg->param(1, CTCP->make_text("DCC $type $arg $addr $port$trail")); + Multicast::from_client_to_server($msg, $sender); + 1; + }; + + my $callback = sub { + my ($newaddr, $newport) = @_; + $addr = $newaddr if $newaddr; + $port = $newport if $newport; + + $send_dcc->($addr, $port); + }; + $this->get_dcc_address_port( + $msg, $sender, $addr, $port, $callback, @{$this->{resolvers}}); + +} + +1; + +=pod +info: クライアントが送信した CTCP DCC のアドレスを変換する。 +default: off +section: important + +# CTCP DCC に指定されているアドレスを、 tiarra で取得したものに +# 書き換えます。(EXPERIMENTAL) +# +# IPv4 のみサポートしています。 +# +# このモジュールは一旦 CTCP DCC メッセージを破棄するので、 +# 別のクライアントには送信されません。 + +# 変換する DCC タイプ。 [デフォルト値: CHAT SEND] +type: CHAT SEND + +# 変換用アドレスの取得方法を選択する。デフォルト値はありません。 +# 以下の取得方法(server-socket client-socket dns http)から +# 必要なもの(複数可)を指定してください。 +resolver: client-socket server-socket dns http + + +# 取得方法と設定 +# なにも設定がないときはブロック自体を省略することもできます。 + +server-socket { + # サーバソケットのローカルアドレスを取ります。 + # client <-> tiarra[this address] <-> server +} + +client-socket { + # クライアントソケットのリモートアドレスを取ります。 + # client [this address]<-> tiarra <-> server +} + +dns { + # DNS を引いて決定します。IPアドレスの指定も可能です。 + host: example.com +} + +http { + # 現状では単純な GET しかサポートしていません。 + + # アクセス先 URL + url: http://checkip.dyndns.org/ + + # IP アドレス取得用 regex + regex: Current IP Address: (\d+\.\d+\.\d+\.\d+) +} + +# リゾルバの選び方 +# +# * tiarra を動作させているサーバとインターネットの間にルータ等があり、 +# グローバルアドレスがない場合 +# *-socket は役に立ちません。 http を利用してください。 +# 適当な DDNS を持っていればdns も良いでしょう。 +# +# * tiarra がレンタルサーバなどLAN上にないサーバで動作している場合 +# server-socket, http は役に立ちません。 +# client-socket がお勧めです。 +# +# * tiarra がLAN上にあり、グローバルアドレスのついているホストで +# 動作している場合 +# client-socket は役に立ちません。 +# server-socket がお勧めです。 + +=cut diff -urN /non-existant-dir/module/CTCP/Ping.pm tiarra-20080510/module/CTCP/Ping.pm --- /non-existant-dir/module/CTCP/Ping.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/CTCP/Ping.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,51 @@ +# ----------------------------------------------------------------------------- +# $Id: Ping.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +package CTCP::Ping; +use strict; +use warnings; +use base qw(Module); +use CTCP; +use Multicast; +use Config; +use BulletinBoard; + +# ctcp-clientinfo-pingを設定 +BulletinBoard->shared->ctcp_clientinfo_ping('PING'); + +sub message_arrived { + my ($this,$msg,$sender) = @_; + + if ($sender->isa('IrcIO::Server') && + $msg->command eq 'PRIVMSG' && + defined $msg->nick) { + + my $ctcp = CTCP::extract($msg); + if (defined $ctcp && $ctcp =~ m/^PING/) { + + my $last = $sender->remark('last-ctcp-replied'); + if (!defined $last || time - $last > ($this->config->interval || 3)) { + # 前回のCTCP反応から一定時間以上経過している。 + my $reply = CTCP::make( + $ctcp, + scalar Multicast::detach($msg->nick) + ); + $sender->send_message($reply); + $sender->remark('last-ctcp-replied',time); + } + } + } + + $msg; +} + +1; + +=pod +info: CTCP PINGに応答する。 +default: off +section: important + +# CTCP::Versionのintervalと同じ。 +interval: 3 +=cut diff -urN /non-existant-dir/module/CTCP/Time.pm tiarra-20080510/module/CTCP/Time.pm --- /non-existant-dir/module/CTCP/Time.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/CTCP/Time.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,53 @@ +# ----------------------------------------------------------------------------- +# $Id: Time.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +package CTCP::Time; +use strict; +use warnings; +use base qw(Module); +use Module::Use qw(Tools::DateConvert); +use Tools::DateConvert; +use CTCP; +use Multicast; +use Config; +use BulletinBoard; + +# ctcp-clientinfo-timeを設定 +BulletinBoard->shared->ctcp_clientinfo_time('TIME'); + +sub message_arrived { + my ($this,$msg,$sender) = @_; + + if ($sender->isa('IrcIO::Server') && + $msg->command eq 'PRIVMSG' && + defined $msg->nick) { + + my $ctcp = CTCP::extract($msg); + if (defined $ctcp && $ctcp eq 'TIME') { + + my $last = $sender->remark('last-ctcp-replied'); + if (!defined $last || time - $last > ($this->config->interval || 3)) { + # 前回のCTCP反応から一定時間以上経過している。 + my $reply = CTCP::make( + 'TIME :'.Tools::DateConvert::replace('%a, %Y/%m/%d %H:%M:%S %z'), + scalar Multicast::detach($msg->nick) + ); + $sender->send_message($reply); + $sender->remark('last-ctcp-replied',time); + } + } + } + + $msg; +} + +1; + +=pod +info: CTCP TIMEに応答する。 +default: off +section: important + +# CTCP::Versionのintervalと同じ。 +interval: 3 +=cut diff -urN /non-existant-dir/module/CTCP/UserInfo.pm tiarra-20080510/module/CTCP/UserInfo.pm --- /non-existant-dir/module/CTCP/UserInfo.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/CTCP/UserInfo.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,54 @@ +# ----------------------------------------------------------------------------- +# $Id: UserInfo.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +package CTCP::UserInfo; +use strict; +use warnings; +use base qw(Module); +use CTCP; +use Multicast; +use Config; +use BulletinBoard; + +# ctcp-clientinfo-userinfoを設定 +BulletinBoard->shared->ctcp_clientinfo_version('USERINFO'); + +sub message_arrived { + my ($this,$msg,$sender) = @_; + + if ($sender->isa('IrcIO::Server') && + $msg->command eq 'PRIVMSG' && + defined $msg->nick) { + + my $ctcp = CTCP::extract($msg); + if (defined $ctcp && $ctcp eq 'USERINFO') { + + my $last = $sender->remark('last-ctcp-replied'); + if (!defined $last || time - $last > ($this->config->interval || 3)) { + # 前回のCTCP反応から一定時間以上経過している。 + my $reply = CTCP::make( + 'USERINFO :'.($this->config->message || ''), + scalar Multicast::detach($msg->nick) + ); + $sender->send_message($reply); + $sender->remark('last-ctcp-replied',time); + } + } + } + + $msg; +} + +1; + +=pod +info: CTCP USERINFOに応答する。 +default: off +section: important + +# CTCP::Versionのintervalと同じ。 +interval: 3 + +# USERINFOとして返すメッセージ。 +message: テスト +=cut diff -urN /non-existant-dir/module/CTCP/Version.pm tiarra-20080510/module/CTCP/Version.pm --- /non-existant-dir/module/CTCP/Version.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/CTCP/Version.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,62 @@ +# ----------------------------------------------------------------------------- +# $Id: Version.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +# CTCP flood対策のため、VERSION、USERINFO等は一度反応する度に +# IrcIO::Serverに「last-ctcp-replied => 反応時刻」というremarkを付ける。 +# 前回の反応時から一定時間が経過していなければ、CTCPに応答しない。 +# ----------------------------------------------------------------------------- +package CTCP::Version; +use strict; +use warnings; +use base qw(Module); +use CTCP; +use Multicast; +use Config; +use BulletinBoard; + +# ctcp-clientinfo-versionを設定 +BulletinBoard->shared->ctcp_clientinfo_version('VERSION'); + +sub message_arrived { + my ($this,$msg,$sender) = @_; + + if ($sender->isa('IrcIO::Server') && + $msg->command eq 'PRIVMSG' && + defined $msg->nick) { + + my $ctcp = CTCP::extract($msg); + if (defined $ctcp && $ctcp eq 'VERSION') { + + my $last = $sender->remark('last-ctcp-replied'); + if (!defined $last || time - $last > ($this->config->interval || 3)) { + # 前回のCTCP反応から一定時間以上経過している。 + my $reply = CTCP::make( + 'VERSION Tiarra:'.::version().':perl '.$Config{version}.' on '.$Config{archname}, + scalar Multicast::detach($msg->nick) + ); + $sender->send_message($reply); + $sender->remark('last-ctcp-replied',time); + } + } + } + + $msg; +} + +1; + +=pod +info: CTCP VERSIONに応答する。 +default: on +section: important + +# 連続したCTCPリクエストに対する応答の間隔。単位は秒。 +# 例えば3秒に設定した場合、一度応答してから3秒間は +# CTCPに一切応答しなくなる。デフォルトは3。 +# +# なお、CTCP受信時刻の記録は、全てのCTCPモジュールで共有される。 +# 例えばCTCP VERSIONを送った直後にCTCP CLIENTINFOを送ったとしても、 +# CTCP::ClientInfoのintervalで設定された時間を過ぎていなければ +# 後者は応答しない。 +interval: 3 +=cut diff -urN /non-existant-dir/module/Channel/Freeze.pm tiarra-20080510/module/Channel/Freeze.pm --- /non-existant-dir/module/Channel/Freeze.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/Channel/Freeze.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,256 @@ +# ----------------------------------------------------------------------------- +# $Id: Freeze.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +# このモジュールは再起動しても凍結設定を失なわないようにする為、 +# 設定をBulletinBoardのfrost-channelsに保存します。 +# ----------------------------------------------------------------------------- +package Channel::Freeze; +use strict; +use warnings; +use base qw(Module); +use Multicast; +use Timer; +use BulletinBoard; +use Mask; + +sub new { + my $class = shift; + + my $this = $class->SUPER::new(@_); + $this->{reminder_timer} = undef; # Timer + $this->set_timer_if_required; + + $this; +} + +sub destruct { + my $this = shift; + if (defined $this->{reminder_timer}) { + $this->{reminder_timer}->uninstall; + $this->{reminder_timer} = undef; + } +} + +sub set_timer_if_required { + my $this = shift; + if (defined $this->{reminder_timer}) { + # 既にタイマーが入っている。 + return; + } + + if (!$this->config->reminder_interval) { + # 報告しないやうに設定されている。 + return; + } + + my $channels = BulletinBoard->shared->frost_channels; + if (defined $channels && keys(%$channels) > 0) { + # 掲示板に情報が有る。 + $this->{reminder_timer} = Timer->new( + Interval => 60 * $this->config->reminder_interval, + Repeat => 1, + Code => sub { + $this->notify_list_of_frost_channels; + })->install; + #::printmsg("Channel::Freeze - timer installed"); + } +} + +sub notify_list_of_frost_channels { + my ($this) = @_; + my $channels = BulletinBoard->shared->frost_channels; + if (defined $channels && keys(%$channels) > 0) { + # 報告内容を作る + my $msg = "These channels are frost: ".join(', ',keys %$channels); + if (length($msg) > 400) { + # 400バイトを越えたら切り詰める。 + $msg = substr($msg, 0, 400)."..."; + } + + # 報告 + RunLoop->shared->broadcast_to_clients( + $this->construct_irc_message( + Prefix => RunLoop->shared_loop->sysmsg_prefix(qw(priv system)), + Command => 'NOTICE', + Params => [ + RunLoop->shared->current_nick, + $msg] + ) + ); + } +} + +sub message_arrived { + my ($this, $msg, $sender) = @_; + + if ($sender->client_p) { + # コマンドの入力か？ + my $notify = sub { + my $notice = shift; + RunLoop->shared->broadcast_to_clients( + $this->construct_irc_message( + Prefix => RunLoop->shared_loop->sysmsg_prefix(qw(priv system)), + Command => 'NOTICE', + Params => [ + RunLoop->shared->current_nick, + $notice] + ) + ); + }; + + if ($msg->command eq uc($this->config->freeze_command || 'freeze')) { + # 凍結 + if (my @frost = $this->freeze($msg->param(0))) { + $notify->("Channel ".join(', ', @frost)." frost."); + } + $msg = undef; # 捨て + } + elsif ($msg->command eq uc($this->config->defrost_command || 'defrost')) { + # 解凍 + if (my @defrost = $this->defrost($msg->param(0))) { + $notify->("Channel ".join(', ', @defrost)." defrost."); + } + $msg = undef; # 捨て + } + } + else { + # PRIVMSGやNOTICEか？ + if ($msg->command eq 'PRIVMSG' || $msg->command eq 'NOTICE') { + # 凍結されてゐるチャンネルが存在するか？ + my $board = BulletinBoard->shared; + my $channels = $board->frost_channels; + if (defined $channels) { + # 凍結されてゐるチャンネルか？ + if ($channels->{$msg->param(0)}) { + # do-not-send-to-clientsを付ける。 + $msg->remark('do-not-send-to-clients', 1); + } + } + } + } + + $msg; +} + +sub normalize { + my ($ch_full) = @_; + my ($ch_short, $network_name) = Multicast::detach($ch_full); + if (Multicast::channel_p($ch_short)) { + # チャンネル名として許される。 + Multicast::attach($ch_short, $network_name); + } + else { + # 許されない。 + undef; + } +} + +sub freeze { + # 今囘のfreezeの呼出しでフリーズされたチャンネル名の配列を返す。 + my ($this, $ch_mask) = @_; + + if (!defined $ch_mask) { + # リスト表示 + $this->notify_list_of_frost_channels; + return (); + } + + if (defined $ch_mask) { + my $board = BulletinBoard->shared; + my $channels = $board->frost_channels; + + if (!defined $channels) { + # まだ掲示板に入つてゐない。 + $channels = {}; # {フルチャンネル名 => 1} + $board->frost_channels($channels); + } + + # 全てのサーバーの、全てのjoinしているチャンネルの中から、 + # このマスクに該当するチャンネル名を探し、全てfreezeする。 + my @ch_to_freeze; + foreach my $network (RunLoop->shared->networks_list) { + foreach my $ch ($network->channels_list) { + my $longname = Multicast::attach($ch, $network); + if (Mask::match($ch_mask, $longname)) { + if (!$channels->{$longname}) { + $channels->{$longname} = 1; + push @ch_to_freeze, $longname; + } + } + } + } + + # 必要ならタイマー起動。 + $this->set_timer_if_required; + + return @ch_to_freeze; + } + else { + return (); + } +} + +sub defrost { + my ($this, $ch_mask) = @_; + if (!defined $ch_mask) { + return (); + } + + my @result; + + if (defined $ch_mask) { + my $board = BulletinBoard->shared; + my $channels = $board->frost_channels; + + if (!defined $channels) { + return; # 何も凍結されていない。 + } + + %$channels = map { + $_ => 1; + } grep { + my $ch_full = $_; + if (Mask::match($ch_mask, $ch_full)) { + push @result, $ch_full; + 0; + } + else { + 1; + } + } keys %$channels; + + if (keys(%$channels) == 0) { + # 凍結されたチャンネルはもう無い。 + if (defined $this->{reminder_timer}) { + $this->{reminder_timer}->uninstall; + $this->{reminder_timer} = undef; + } + #::printmsg("Channel::Freeze - timer DELETED"); + } + } + + @result; +} + +1; + +=pod +info: 特定のチャンネルの発言を、一時的に受信するのをやめる。 +default: off + +# ログを取っているなら、ログには記録される。 + +# チャンネルの凍結に用いるコマンド名。 +# 省略時は freeze であり、/freeze #channel@network のように使う。 +# チャンネル名を省略すると、現在フリーズされているチャンネルのリストを表示する。 +freeze-command: freeze + +# 凍結解除に用いるコマンド名。 +# 省略時は defrost であり、/defrost #channel@network のように使う。 +defrost-command: defrost + +# 凍結しているチャンネルが存在する時、一定時間毎にその旨を報告する事も可能。 +# この機能は凍結した事を忘れないようにする為にある。 +# 単位は分、デフォルトはゼロ(報告しない)。 +reminder-interval: 30 +=cut diff -urN /non-existant-dir/module/Channel/Ignore.pm tiarra-20080510/module/Channel/Ignore.pm --- /non-existant-dir/module/Channel/Ignore.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/Channel/Ignore.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,161 @@ +# ----------------------------------------------------------------------------- +# $Id: Ignore.pm 3004 2007-12-10 12:45:39Z topia $ +# ----------------------------------------------------------------------------- +# copyright (C) 2005 Topia . all rights reserved. +package Channel::Ignore; +use strict; +use warnings; +use base qw(Module); +use Mask; +use Multicast; +use NumericReply; + +sub message_io_hook { + my ($this,$msg,$io,$type) = @_; + + if ($io->isa('IrcIO::Server')) { + if ($type eq 'in') { + my $numeric = NumericReply::fetch_name($msg->command); + my $method = 'cmd_'.($numeric || $msg->command); + if ($this->can($method)) { + return $this->$method($msg, $io); + } + } + } + + $msg; +} + +*cmd_NOTICE = \&cmd_PRIVMSG; +*cmd_PART = \&cmd_PRIVMSG; +*cmd_INVITE = \&cmd_PRIVMSG; +*cmd_TOPIC = \&cmd_PRIVMSG; +*cmd_MODE = \&cmd_PRIVMSG; +*cmd_KICK = \&cmd_PRIVMSG; +sub cmd_PRIVMSG { + my ($this,$msg,$io) = @_; + + my $ch_short = $msg->param(0); + my $ch_long = Multicast::attach($ch_short, $io->network_name); + if (!Multicast::channel_p($ch_short)) { + $ch_long = 'priv@'.$io->network_name; + } + + if ($this->ignore_channel_p($ch_long)) { + undef; + } + else { + $msg; + } +} + +sub cmd_JOIN { + my ($this,$msg,$io) = @_; + my @channels; # チャンネルリストを再構成する。 + foreach my $channel (split m/,/,$msg->param(0)) { + my ($ch_short,$mode) = ($channel =~ m/^([^\x07]+)(?:\x07(.*))?/); + my $ch_long = Multicast::attach($ch_short, $io->network_name); + if (!$this->ignore_channel_p($ch_long)) { + push @channels,$channel; + } + } + + if (@channels > 0) { + # 再構成の結果、チャンネルがまだ残ってた。 + $msg->param(0,join(',',@channels)); + } + else { + $msg = undef; + } + + $msg; +} + +sub cmd_NJOIN { + my ($this,$msg,$io) = @_; + my $ch_short = $msg->param(0); + my $ch_long = Multicast::attach($ch_short, $io->network_name); + if ($this->ignore_channel_p($ch_long)) { + $msg = undef; + } + + $msg; +} + +*cmd_QUIT = \&cmd_NICK; +sub cmd_NICK { + my ($this,$msg,$io) = @_; + + # 影響を及ぼした全チャンネル名のリストを得る。このリストにはネットワーク名が付いていない。 + my $no_ignore; + my $nick = $msg->nick; + + foreach (grep { defined $_->names($nick) } $io->channels_list) { + my $ch_long = Multicast::attach($_,$io->network_name); + if (!$this->ignore_channel_p($ch_long)) { + $no_ignore = 1; + last; + } + } + + if ($no_ignore) { + $msg; + } + else { + undef; + } +} + +sub cmd_RPL_NAMREPLY { + my ($this,$msg,$io) = @_; + + my $ch_short = $msg->param(2); + my $ch_long = Multicast::attach($ch_short, $io->network_name); + if ($this->ignore_channel_p($ch_long)) { + $msg = undef; + } + + $msg; +} + +*cmd_RPL_CHANNELMODEIS = \&cmd_RPL_ENDOFNAMES; +*cmd_RPL_TOPIC_WHO_TIME = \&cmd_RPL_ENDOFNAMES; +*cmd_RPL_TOPIC = \&cmd_RPL_ENDOFNAMES; +sub cmd_RPL_ENDOFNAMES { + my ($this,$msg,$io) = @_; + + my $ch_short = $msg->param(1); + my $ch_long = Multicast::attach($ch_short, $io->network_name); + if ($this->ignore_channel_p($ch_long)) { + $msg = undef; + } + + $msg; +} + +sub ignore_channel_p { + my ($this,$ch_long) = @_; + Mask::match_deep([$this->config->mask('all')],$ch_long); +} + +1; + +=pod +info: 指定されたチャンネルの存在を、様々なメッセージから消去する。 +default: off + +# 対象となったチャンネルのJOIN、PART、INVITE、QUIT、NICK、NAMES、NJOINは消去される。 + +# 注意点 +# - この機能はまだ実装途中です。いろいろな不具合があるかもしれません。むしろきっとあります。 +# - サーバがわとの通信に割り込みますのでログにもとられません。 +# - この機能を使っている tiarra より上流に multi-server-mode な tiarra を置かないでください。 + +# チャンネルの定義。 +# また、privの場合は「priv@ネットワーク名」という文字列をチャンネル名の代わりとしてマッチングを行なう。 +# 書式: mask: <チャンネルのマスク> +mask: #example@example +=cut + + +1; diff -urN /non-existant-dir/module/Channel/Join/Connect.pm tiarra-20080510/module/Channel/Join/Connect.pm --- /non-existant-dir/module/Channel/Join/Connect.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/Channel/Join/Connect.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,101 @@ +# ----------------------------------------------------------------------------- +# $Id: Connect.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +# copyright (C) 2002 Topia . all rights reserved. +package Channel::Join::Connect; +use strict; +use warnings; +use base qw(Module); +use Multicast; +use RunLoop; + +sub new { + my $class = shift; + my $this = $class->SUPER::new(@_); + $this->{servers} = {}; # servername => channellist + # channellist : HASH + # shortname => チャンネルショートネーム + # key => channel key + $this->_init; +} + +sub _init { + my $this = shift; + foreach ($this->config->channel('all')) { + s/(,)\s+/$1/g; # コンマの直後にスペースがあった場合、削除する + my ($fullname, $key) = split(/\s+/, $_, 2); + my @fullnames = split(/\,/, $fullname); + my @keys = split(/,/, $key || ''); + for (my $i = 0; $i < @fullnames; $i++) { + my $ch_fullname = $fullnames[$i]; + my $ch_key = $keys[$i]; + $ch_key = '' unless defined($ch_key); + if (!defined($ch_fullname) || $ch_fullname eq '') { + die "Illegal definition in Channel::Join::Connect/channel : $_\n"; + } + my ($ch_shortname, $server_name) = Multicast::detach($ch_fullname); + push @{$this->{servers}->{$server_name}},{ + shortname => $ch_shortname, + key => $ch_key + }; + } + } + + $this; +} + +sub connected_to_server { + my ($this,$server,$new_connection) = @_; + my ($session) = $this->{servers}->{$server->network_name}; + return if !$new_connection; + + if (defined($session)) { + Timer->new( + Interval => 1, + Repeat => 1, + Code => sub { + my $timer = shift; + if (@$session > 0) { + # 一度に五つずつ送り出す。 + my $msg_per_trigger = 5; + my (@param_chan, @param_key); + for (my $i = 0; $i < @$session && $i < $msg_per_trigger; $i++) { + if (!defined($session->[$i]->{key}) || $session->[$i]->{key} eq '') { + push (@param_chan, $session->[$i]->{shortname}); + push (@param_key, ''); + } else { + unshift (@param_chan, $session->[$i]->{shortname}); + unshift (@param_key, $session->[$i]->{key}); + } + } + splice @$session,0,$msg_per_trigger; + $server->send_message( + $this->construct_irc_message( + Command => 'JOIN', + Params => [join(',', @param_chan), join(',', @param_key)])); + } + if (@$session == 0) { + delete $this->{sessions}->{$server->network_name}; + $timer->uninstall; + } + })->install; + } +} + +1; +=pod +info: サーバーに初めて接続した時、指定したチャンネルに入るモジュール。 +default: off +section: important + +# 書式: <チャンネル1>[,<チャンネル2>,...] [<チャンネル1のキー>,...] +# コンマの直後のスペースは無視されます。 +# +# 例: +# 「#aaaaa@ircnet」に「aaaaa」というキーで入る。 +-channel: #aaaaa@ircnet aaaaa +# +# 「#aaaaa@ircnet」、「#bbbbb@ircnet:*.jp」、「#ccccc@ircnet」、「#ddddd@ircnet」の4つのチャンネルに入る。 +-channel: #aaaaa@ircnet,#bbbbb@ircnet:*.jp, #ccccc@ircnet +-channel: #ddddd@ircnet +=cut diff -urN /non-existant-dir/module/Channel/Join/Invite.pm tiarra-20080510/module/Channel/Join/Invite.pm --- /non-existant-dir/module/Channel/Join/Invite.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/Channel/Join/Invite.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,58 @@ +# -*- cperl -*- +# ----------------------------------------------------------------------------- +# $Id: Invite.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +# copyright (C) 2003 Topia . all rights reserved. +package Channel::Join::Invite; +use strict; +use warnings; +use base qw(Module); +use Module::Use qw(Auto::Utils); +use Auto::Utils; +use Multicast; +use Mask; + +sub message_arrived { + my ($this, $msg, $sender) = @_; + my @result = ($msg); + + if ($sender->isa('IrcIO::Server')) { + if ($msg->command eq 'INVITE') { + my ($callbacks) = []; + Auto::AliasDB::CallbackUtils::register_extcallbacks($callbacks, $msg, $sender); + my ($get_ch_name,undef,undef,$reply_anywhere) + = Auto::Utils::generate_reply_closures($msg, $sender, \@result, undef, $callbacks, 1); + if (Multicast::channel_p($get_ch_name->())) { + if (Mask::match_deep_chan([$this->config->mask('all')], $msg->prefix, $get_ch_name->())) { + # match. + $sender-> + send_message($this->construct_irc_message( + Command => 'JOIN', + Params => [$get_ch_name->()] + )); + foreach my $reply ($this->config->message('all')) { + $reply_anywhere->($reply); + } + } + } + } + } + + return @result; +}; + + +1; + +=pod +info: 招待されたらそのチャンネルに入る。 +default: off +section: important + +# 許可するユーザ/チャンネルのマスク。 +mask: * *!*@* +# plum: *!*@* + +# 招待されたチャンネルに流すメッセージのフォーマット。 +-message: こんばんわ〜。 +=cut diff -urN /non-existant-dir/module/Channel/Join/Kicked.pm tiarra-20080510/module/Channel/Join/Kicked.pm --- /non-existant-dir/module/Channel/Join/Kicked.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/Channel/Join/Kicked.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,44 @@ +# ----------------------------------------------------------------------------- +# $Id: Kicked.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +package Channel::Join::Kicked; +use strict; +use warnings; +use base qw(Module); +use Mask; + +sub message_arrived { + my ($this,$msg,$sender) = @_; + + if ($sender->server_p && $msg->command eq 'KICK' && + $msg->param(1) eq $sender->current_nick && + Mask::match_deep([$this->config->channel('all')],$msg->param(0))) { + # 自分が蹴られた。 + # +kされているチャンネルならキーワードを付ける。 + my $ch = RunLoop->shared->channel($msg->param(0)); + if (defined $ch) { + my @params = ($ch->name); + if ($ch->parameters('k')) { + push @params,$ch->parameters('k'); + } + + $sender->send_message( + $this->construct_irc_message( + Command => 'JOIN', + Params => \@params)); + } + } + + $msg; +} + +1; + +=pod +info: 特定のチャンネルからkickされた時に、自動で入りなおす。 +default: off +section: important + +# 対象となるチャンネル名のマスク +channel: * +=cut diff -urN /non-existant-dir/module/Channel/Mode/Get.pm tiarra-20080510/module/Channel/Mode/Get.pm --- /non-existant-dir/module/Channel/Mode/Get.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/Channel/Mode/Get.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,88 @@ +# ----------------------------------------------------------------------------- +# $Id: Get.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +package Channel::Mode::Get; +use strict; +use warnings; +use base qw(Module); +use Multicast; + +sub new { + my $class = shift; + my $this = $class->SUPER::new(@_); + $this->{buffer} = []; # [IrcIO::Server,Tiarra::IRC::Message] + $this->{timer} = undef; # Timer：必要な時だけ使われる。 + $this; +} + +sub destruct { + my $this = shift; + if (defined $this->{timer}) { + $this->{timer}->uninstall; + } +} + +sub message_arrived { + my ($this,$msg,$sender) = @_; + + if ($sender->isa('IrcIO::Server') && + $msg->command eq 'JOIN' && + defined $msg->nick && + $msg->nick eq RunLoop->shared->current_nick) { + # 自分のJOINなので、MODE #channelを発行 + foreach (split /,/,$msg->param(0)) { + my $ch_shortname = Multicast::detatch($_); + my $entry = [$sender, + $this->construct_irc_message( + Command => 'MODE', + Param => $ch_shortname)]; + push @{$this->{buffer}},$entry; + $this->setup_timer; + } + } + + $msg; +} + +sub setup_timer { + my ($this) = @_; + # 既にタイマーが作られていたら何もせずに戻る。 + if (!defined $this->{timer}) { + $this->{timer} = Timer->new( + Interval => 1, + Repeat => 1, + Code => sub { + my $timer = shift; + # 一度に二つずつ送り出す。 + my $msg_per_once = 2; + my $buffer = $this->{buffer}; + for (my $i = 0; + $i < @$buffer && $i < $msg_per_once; + $i++) { + my $entry = $buffer->[$i]; + $entry->[0]->send_message($entry->[1]); + } + splice @$buffer,0,2; + # バッファが空になったら終了。 + if (@$buffer == 0) { + $timer->uninstall; + $this->{timer} = undef; + } + })->install; + } +} + +1; + +=pod +info: チャンネルにJOINした時、そのチャンネルのモードを取得します。 +default: off +section: important + +# Channel::Mode::Set等が正しく動くためには +# チャンネルのモードをTiarraが把握しておく必要があります。 +# 自動的にモードを取得するクライアントであれば必要ありませんが、 +# そうでなければこのモジュールを使うべきです。 + +# 設定項目は無し。 +=cut diff -urN /non-existant-dir/module/Channel/Mode/Oper/Grant.pm tiarra-20080510/module/Channel/Mode/Oper/Grant.pm --- /non-existant-dir/module/Channel/Mode/Oper/Grant.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/Channel/Mode/Oper/Grant.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,145 @@ +# ----------------------------------------------------------------------------- +# $Id: Grant.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +package Channel::Mode::Oper::Grant; +use strict; +use warnings; +use base qw(Module); +use Mask; +use Multicast; +use Timer; + +sub new { + my $class = shift; + my $this = $class->SUPER::new(@_); + $this->{queue} = {}; # network name => [[channel(short),nick], ...] + $this->{timer} = undef; # queueが空でない時だけ必要になるTimer + $this; +} + +sub destruct { + my ($this) = @_; + if (defined $this->{timer}) { + $this->{timer}->uninstall; + } +} + +sub message_arrived { + my ($this,$msg,$sender) = @_; + # 先に進むための条件: + # 1. サーバーからのメッセージである + # 2. コマンドはJOINである + # 3. 自分のJOINではない + # 4. @付きのJOINではない + # 5. そのチャンネルで自分は@を持っている + # 6. 相手はmaskに一致する + if ($sender->isa('IrcIO::Server') && + $msg->command eq 'JOIN' && + defined $msg->nick && + $msg->nick ne RunLoop->shared->current_nick) { + foreach (split /,/,$msg->param(0)) { + my ($ch_full,$mode) = (m/^(.+?)(?:\x07(.*))?$/); + my $ch_short = Multicast::detatch($ch_full); + my $ch = $sender->channel($ch_short); + my $myself = $ch->names($sender->current_nick); + if (defined $myself && $myself->has_o && (!defined $mode || $mode !~ /o/)) { + if (Mask::match_deep_chan([$this->config->mask('all')],$msg->prefix,$ch_full)) { + # waitで指定された秒数の経過後に、キューに入れる。 + # 同時にキュー消化タイマーを準備する。 + $this->push_to_queue($sender,$ch_short,$msg->nick); + } + } + } + } + $msg; +} + +sub push_to_queue { + my ($this,$server,$ch_short,$nick) = @_; + my $wait = $this->config->wait || 0; + if ($wait =~ /^\s*(\d+)\s*-\s*(\d+)\s*$/) { + $wait = int(rand($2 - $1 + 1)) + $1; + } + Timer->new( + After => $wait, + Code => sub { + # 対象の人が既に+oされていたら中止。 + my $ch = $server->channel($ch_short); + return if !defined $ch; + my $target = $ch->names($nick); + return if !defined $target; + return if $target->has_o; + + my $queue = $this->{queue}->{$server->network_name}; + if (!defined $queue) { + $queue = $this->{queue}->{$server->network_name} = []; + } + push @$queue,[$ch_short,$nick]; + $this->prepare_timer; + })->install; +} + +sub prepare_timer { + my ($this) = @_; + # キュー消化タイマーが存在しなければ作る + if (!defined $this->{timer}) { + $this->{timer} = Timer->new( + Interval => 0, # 勿論、最初のtriggerで変更する。 + Repeat => 1, + Code => sub { + my ($timer) = @_; + $timer->interval(1); + + # 鯖毎に3つずつ消化する。 + # チャンネル毎に最大３つずつ纏める。 + foreach my $network_name (keys %{$this->{queue}}) { + my $queue = $this->{queue}->{$network_name}; + my $server = $this->_runloop->network($network_name); + my $channels = {}; # ch_shortname => [nick,nick,...] + for (my $i = 0; @$queue && $i < 3; $i++) { + my $elem = shift(@$queue); + my $nicks = $channels->{$elem->[0]}; + if (!defined $nicks) { + $nicks = $channels->{$elem->[0]} = []; + } + push @$nicks,$elem->[1]; + } + while (my ($ch_short,$nicks) = each %$channels) { + $server->send_message( + $this->construct_irc_message( + Command => 'MODE', + Params => [$ch_short, + '+'.('o' x @$nicks), + @$nicks])); + } + # キューが空になったらキーごと消す。 + delete $this->{queue}->{$network_name} unless @$queue; + } + + # 全てのキューが空になったら終了。 + if (!%{$this->{queue}}) { + $timer->uninstall; + $this->{timer} = undef; + } + })->install; + } +} + +1; + +=pod +info: 特定のチャンネルに特定の人間がjoinした時に、自分がチャンネルオペレータ権限を持っていれば+oする。 +default: off +section: important + +# splitからの復帰などで+o対象の人が一度に大量に入って来ても+oは少しずつ実行します。 +# Excess Floodにはならない筈ですが、本格的な防衛BOTに使える程の物ではありません。 + +# 対象の人間がjoinしてから実際に+oするまで何秒待つか。 +# 省略されたら待ちません。 +# 5-10 のように指定されると、その値の中でランダムに待ちます。 +wait: 2-5 + +# チャンネルと人間のマスクを定義。Auto::Operと同様。 +-mask: * example!~example@*.example.ne.jp +=cut diff -urN /non-existant-dir/module/Channel/Mode/Set.pm tiarra-20080510/module/Channel/Mode/Set.pm --- /non-existant-dir/module/Channel/Mode/Set.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/Channel/Mode/Set.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,83 @@ +# ----------------------------------------------------------------------------- +# $Id: Set.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +# 掲示板のdo-not-touch-mode-of-channels (HASH*)に記述されているチャンネルのモードは弄らない。 +# ----------------------------------------------------------------------------- +package Channel::Mode::Set; +use strict; +use warnings; +use base qw(Module); +use BulletinBoard; +use Mask; +use Multicast; + +sub message_arrived { + my ($this,$msg,$sender) = @_; + + if ($sender->isa('IrcIO::Server') && + $msg->command eq '366') { + my $ch_fullname = $msg->param(1); + my $ch_plainname = Multicast::detatch($ch_fullname); + my $ch = $sender->channel($ch_plainname); + if (defined $ch) { + my $myself = $ch->names($sender->current_nick); + # 自分は入っているか？(バグでもない限り常にdefined。) + if (defined $myself) { + # 自分は@を持っているか？ + my $i_have_o = $myself->has_o; + # チャンネル内に自分一人だけか？ + my $only_me = ($ch->names(undef,undef,'size') == 1); + # MODEの変更が許されているか？ + my $allowed_mode = + $this->is_allowed_changing_mode($ch_fullname); + if ($i_have_o && $only_me && $allowed_mode) { + $this->set_modes($ch_fullname,$ch_plainname,$sender); + } + } + } + } + $msg; +} + +sub is_allowed_changing_mode { + my ($this,$ch_name) = @_; + my $untouchables = BulletinBoard->shared + ->do_not_touch_mode_of_channels; + if (defined $untouchables) { + if ($untouchables->{$ch_name}) { + return undef; + } + } + 1; +} + +sub set_modes { + my ($this,$ch_fullname,$ch_plainname,$sender) = @_; + foreach ($this->config->channel('all')) { + my ($ch_mask,$modes) = (m/^(.+?)\s+(.+)$/); + # このチャンネルのマスクに$ch_nameはマッチするか？ + if (Mask::match($ch_mask,$ch_fullname)) { + foreach my $mode (split /,/,$modes) { + $sender->send_message( + $this->construct_irc_message( + Command => 'MODE', + Params => [$ch_plainname,$mode])); + } + } + } +} + +1; + +=pod +info: チャンネルを作成した時に自動的にモードを設定するモジュール。 +default: off +section: important + +# 書式は<チャンネル名にマッチするマスク> <設定するモード>[,<設定するモード>,...]です。 +# #IRC談話室@ircnetなら+t+nを、それ以外なら+nを設定する例。 +-channel: #IRC談話室@ircnet +t +-channel: * +n +# LimeChat 標準設定を模倣する設定例。 +-channel: * +sn +=cut diff -urN /non-existant-dir/module/Channel/Rejoin.pm tiarra-20080510/module/Channel/Rejoin.pm --- /non-existant-dir/module/Channel/Rejoin.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/Channel/Rejoin.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,326 @@ +# ----------------------------------------------------------------------------- +# $Id: Rejoin.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +# このモジュールは動作時に掲示板のdo-not-touch-mode-of-channelsを使います。 +# ----------------------------------------------------------------------------- +package Channel::Rejoin; +use strict; +use warnings; +use base qw(Module); +use BulletinBoard; +use Multicast; +use RunLoop; +use NumericReply; + +sub new { + my $class = shift; + my $this = $class->SUPER::new(@_); + $this->{sessions} = {}; # チャンネルフルネーム => セッション情報 + # セッション情報 : HASH + # ch_fullname => チャンネルフルネーム + # ch_shortname => チャンネルショートネーム + # ch => ChannelInfo + # server => IrcIO::Server + # got_mode => 既にMODEを取得しているかどうか。 + # got_blist => 既に+bリストを(略 + # got_elist => +e(略 + # got_Ilist => +I(略 + # got_oper => 既にPART->JOINしているかどうか。 + # cmd_buf => ARRAY + $this; +} + +sub message_arrived { + my ($this,$msg,$sender) = @_; + if ($sender->isa('IrcIO::Server')) { + # PART,KICK,QUIT,KILLが、それぞれ一人になる要因。 + my $cmd = $msg->command; + if ($cmd eq 'PART') { + foreach my $ch_fullname (split /,/,$msg->param(0)) { + $this->check_channel( + scalar Multicast::detatch($ch_fullname), + $sender); + } + } + elsif ($cmd eq 'KICK') { + # RFC2812によると、複数のチャンネルを持つKICKメッセージが + # クライアントに届く事は無い。 + $this->check_channel( + scalar Multicast::detatch($msg->param(0)), + $sender); + } + elsif ($cmd eq 'QUIT' || $cmd eq 'KILL') { + # 註釈affected-channelsに影響のあったチャンネルのリストが入っているはず。 + foreach (@{$msg->remark('affected-channels')}) { + $this->check_channel($_,$sender); + } + } + + $this->session_work($msg,$sender); + } + $msg; +} + +sub check_channel { + my ($this,$ch_name,$server) = @_; + if ($ch_name =~ m/^\+/) { + # +チャンネルに@は付かない。 + return; + } + my $ch = $server->channel($ch_name); + if (!defined $ch) { + # 自分が入っていない + return; + } + if ($ch->switches('a')) { + # +aチャンネルでは一人になったかどうかの判定が面倒である上に、 + # @を復活させる意味も無ければ復活させない方が望ましい。 + return; + } + if ($ch->names(undef,undef,'size') > 1) { + # 二人以上いる。 + return; + } + my $myself = $ch->names($server->current_nick); + if (defined $myself && $myself->has_o) { + # 自分が@を持っている。 + return; + } + $this->rejoin($ch_name,$server); +} + +sub rejoin { + my ($this,$ch_name,$server) = @_; + my $ch_fullname = Multicast::attach($ch_name,$server->network_name); + RunLoop->shared->notify_msg( + "Channel::Rejoin is going to rejoin to ${ch_fullname}."); + + ############### + # 処理の流れ + ### phase 1 ### + # セッション作成。 + # 掲示板に「このチャンネルのモードを変更するな」と書き込む。 + # TOPICを覚える。 + # 備考switches-are-knownが偽ならMODE #channel実行。 + # 必要ならMODE #channel +b,MODE #channel +e,MODE #channel +Iを実行。 + ### phase 2 ### + # 324(modeリプライ),368(+bリスト終わり), + # 349(+eリスト終わり),347(+Iリスト終わり)をそれぞれ必要なら待つ。 + ### phase 3 ### + # PART #channel実行。 + # JOIN #channel実行。 + # 自分のJOINを待つ。 + # 少しずつ命令バッファに溜まったコマンドを実行していく。Timer使用。 + # 命令バッファにはMODEやTOPICが入っている。 + # 掲示板から消す。 + # セッションを破棄。 + ############### + + # チャンネル取得 + my $ch = $server->channel($ch_name); + + # セッション登録 + my $session = $this->{sessions}->{$ch_fullname} = { + ch_fullname => $ch_fullname, + ch_shortname => $ch_name, + ch => $ch, + server => $server, + cmd_buf => [], + }; + + # do-not-touch-mode-of-channelsを取得 + my $untouchables = BulletinBoard->shared->do_not_touch_mode_of_channels; + if (!defined $untouchables) { + $untouchables = {}; + BulletinBoard->shared->set('do-not-touch-mode-of-channels',$untouchables); + } + # このチャンネルをフルネームで登録 + $untouchables->{$ch_fullname} = 1; + + # TOPICを覚える。 + if ($ch->topic ne '') { + push @{$session->{cmd_buf}},$this->construct_irc_message( + Command => 'TOPIC', + Params => [$ch_name,$ch->topic]); + } + + # 必要ならMODE #channel実行。 + #if ($ch->remarks('switches-are-known')) { + # $session->{got_mode} = 1; + # push @{$session->{cmd_buf}},$this->construct_irc_message( + # Command => 'MODE', + #} + # やっぱりやめ。面倒。防衛BOTとして使いたかったらこんなモジュール使わないこと。 + #else { + $server->send_message( + $this->construct_irc_message( + Command => 'MODE', + Param => $ch_name)); + #} + + # 必要なら+e,+b,+I実行。 + if ($this->config->save_lists) { + foreach (qw/+e +b +I/) { + $server->send_message( + $this->construct_irc_message( + Command => 'MODE', + Params => [$ch_name,$_])); + } + } + else { + $session->{got_elist} = + $session->{got_blist} = + $session->{got_Ilist} = 1; + } + + # 待たなければならないものはあるか？ + if ($this->{got_mode} && $this->{got_elist} && + $this->{got_blist} && $this->{got_Ilist}) { + # もう何も無い。 + $this->part_and_join($session); + } +} + +sub part_and_join { + my ($this,$session) = @_; + $session->{got_oper} = 1; + foreach (qw/PART JOIN/) { + $session->{server}->send_message( + $this->construct_irc_message( + Command => $_, + Param => $session->{ch_shortname})); + } +} + +sub session_work { + my ($this,$msg,$server) = @_; + my $session; + # ウォッチの対象になるのはJOIN,324,368,349,347。 + + my $got_reply = sub { + my $type = shift; + my ($flagname,$listname) = do { + if ($type eq 'b') { + ('got_blist','banlist'); + } + elsif ($type eq 'e') { + ('got_elist','exceptionlist'); + } + elsif ($type eq 'I') { + ('got_Ilist','invitelist'); + } + }; + + $session = $this->{sessions}->{$msg->param(1)}; + if (defined $session) { + $session->{$flagname} = 1; + + my $list = $session->{ch}->$listname(); + my $list_size = @$list; + # ３つずつまとめる。 + for (my $i = 0; $i < $list_size; $i+=3) { + my @masks = ($list->[$i]); + push @masks,$list->[$i+1] if $i+1 < $list_size; + push @masks,$list->[$i+2] if $i+2 < $list_size; + + push @{$session->{cmd_buf}},$this->construct_irc_message( + Command => 'MODE', + Params => [$session->{ch_shortname}, + '+'.($type x scalar(@masks)), + @masks]); + } + } + }; + + if ($msg->command eq RPL_CHANNELMODEIS) { + # MODEリプライ + $session = $this->{sessions}->{$msg->param(1)}; + if (defined $session) { + $session->{got_mode} = 1; + my $ch = $session->{ch}; + + my ($params, @params) = $ch->mode_string; + if (length($params) > 1) { + # 設定すべきモードがある。 + push @{$session->{cmd_buf}},$this->construct_irc_message( + Command => 'MODE', + Params => [$session->{ch_shortname}, + $params, + @params]); + } + } + } + elsif ($msg->command eq RPL_ENDOFBANLIST) { + # +bリスト終わり + $got_reply->('b'); + } + elsif ($msg->command eq RPL_ENDOFEXCEPTLIST) { + # +eリスト終わり + $got_reply->('e'); + } + elsif ($msg->command eq RPL_ENDOFINVITELIST) { + # +Iリスト終わり + $got_reply->('I'); + } + elsif ($msg->command eq 'JOIN') { + $session = $this->{sessions}->{$msg->param(0)}; + if (defined $session && defined $msg->nick && + $msg->nick eq RunLoop->shared->current_nick) { + # 入り直した。 + $session->{got_oper} = 1; # 既にセットされている筈だが念のため + $this->revive($session); + } + } + + # $sessionが空でなければ、必要な情報が全て揃った可能性がある。 + if (defined $session && !$session->{got_oper} && + $session->{got_mode} && $session->{got_blist} && + $session->{got_elist} && $session->{got_Ilist}) { + $this->part_and_join($session); + } +} + +sub revive { + my ($this,$session) = @_; + Timer->new( + Interval => 1, + Repeat => 1, + Code => sub { + my $timer = shift; + my $cmd_buf = $session->{cmd_buf}; + if (@$cmd_buf > 0) { + # 一度に二つずつ送り出す。 + my $msg_per_trigger = 2; + for (my $i = 0; $i < @$cmd_buf && $i < $msg_per_trigger; $i++) { + $session->{server}->send_message($cmd_buf->[$i]); + } + splice @$cmd_buf,0,$msg_per_trigger; + } + if (@$cmd_buf == 0) { + # cmd_bufが空だったら終了。 + # untouchablesから消去 + my $untouchables = BulletinBoard->shared->do_not_touch_mode_of_channels; + delete $untouchables->{$session->{ch_fullname}}; + # session消去 + delete $this->{sessions}->{$session->{ch_fullname}}; + # タイマーをアンインストール + $timer->uninstall; + } + })->install; +} + +1; + +=pod +info: チャンネルオペレータ権限を無くしたとき、一人ならjoinし直す。 +default: off +section: important + +# +チャンネルや+aされているチャンネル以外でチャンネルオペレータ権限を持たずに +# 一人きりになった時、そのチャンネルの@を復活させるために自動的にjoinし直すモジュール。 +# トピック、モード、banリスト等のあらゆるチャンネル属性をも保存します。 + +# +b,+I,+eリストの復旧を行なうかどうか。 +# あまりに長いリストを取得するとMax Send-Q Exceedで落とされるかも知れません。 +save-lists: 1 +=cut diff -urN /non-existant-dir/module/Client/Cache.pm tiarra-20080510/module/Client/Cache.pm --- /non-existant-dir/module/Client/Cache.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/Client/Cache.pm 2008-05-11 00:25:26.000000000 +0900 @@ -0,0 +1,307 @@ +# ----------------------------------------------------------------------------- +# $Id: Cache.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +# copyright (C) 2003-2004 Topia . all rights reserved. +package Client::Cache; +use strict; +use warnings; +use base qw(Module); +use Mask; +use Multicast; +use NumericReply; + +sub MODE_CACHE_FORCE_SENDED (){0;} +sub MODE_CACHE_SENDED (){1;} +sub MODE_CACHE_EXPIRE_TIME (){5 * 60;} +sub WHO_CACHE_EXPIRE_TIME (){5 * 60;} + +sub new { + my $class = shift; + my $this = $class->SUPER::new(@_); + $this->{hook} = IrcIO::Client::Hook->new( + sub { + my ($hook, $client, $ch_name, $network, $ch) = @_; + if ($ch->remark('switches-are-known') && + $this->_yesno($this->config->use_mode_cache)) { + # 送信できる場合は強制的に送信してみる + my $remark = $client->remark('mode-cache-state') || {}; + $this->_send_mode_cache($client,$ch_name,$ch); + $remark->{ + Multicast::attach($ch->name, $network) + }->[MODE_CACHE_FORCE_SENDED] = 1; + $client->remark('mode-cache-state', $remark); + } + })->install('channel-info'); + $this; +} + +sub destruct { + my ($this) = shift; + + # hook を解除 + $this->{hook} and $this->{hook}->uninstall; + + # チャンネルについている remark を削除。 + foreach my $network (RunLoop->shared_loop->networks_list) { + foreach my $ch ($network->channels_list) { + $ch->remark(__PACKAGE__."/fetching-switches", undef, 'delete'); + $ch->remark(__PACKAGE__."/fetching-switches-expire", undef, 'delete'); + $ch->remark(__PACKAGE__."/fetching-who", undef, 'delete'); + $ch->remark(__PACKAGE__."/fetching-who-expire", undef, 'delete'); + } + } + + # クライアントについてるのは削除しない。 +} + +sub _yesno { + my ($this, $value, $default) = @_; + + return $default || 0 if (!defined $value); + return 0 if ($value =~ /[fn]/); # false/no + return 1 if ($value =~ /[ty]/); # true/yes + return 1 if ($value); # 数値判定 + return 0; +} + +sub message_io_hook { + my ($this,$msg,$io,$type) = @_; + + if ($io->isa('IrcIO::Server')) { + if ($type eq 'out' && + $msg->command eq 'MODE' && + Multicast::channel_p($msg->param(0)) && + !defined $msg->param(1)) { + my $ch = $io->channel($msg->param(0)); + if (defined $ch) { + $ch->remark(__PACKAGE__."/fetching-switches", 1); + $ch->remark(__PACKAGE__."/fetching-switches-expire", + time() + MODE_CACHE_EXPIRE_TIME); + } + } elsif ($type eq 'in' && + $msg->command eq RPL_CHANNELMODEIS && + Multicast::channel_p($msg->param(1))) { + my $ch = $io->channel($msg->param(1)); + if (defined $ch) { + $ch->remark(__PACKAGE__."/fetching-switches", undef, 'delete'); + $ch->remark(__PACKAGE__."/fetching-switches-expire", undef, 'delete'); + } + } elsif ($type eq 'out' && + $msg->command eq 'WHO' && + Multicast::channel_p($msg->param(0))) { + my $ch = $io->channel($msg->param(0)); + if (defined $ch) { + $ch->remark(__PACKAGE__."/fetching-who", 1); + $ch->remark(__PACKAGE__."/fetching-who-expire", + time() + WHO_CACHE_EXPIRE_TIME); + } + } elsif ($type eq 'in' && + $msg->command eq RPL_WHOREPLY && + Multicast::channel_p($msg->param(1))) { + # 処理の都合上、一つでも帰ってきた時点で取り消し。 + my $ch = $io->channel($msg->param(1)); + if (defined $ch) { + $ch->remark(__PACKAGE__."/fetching-who", undef, 'delete'); + $ch->remark(__PACKAGE__."/fetching-who-expire", undef, 'delete'); + } + } elsif ($type eq 'in' && + $msg->command eq RPL_ENDOFWHO && + Multicast::channel_p($msg->param(1))) { + my $ch = $io->channel($msg->param(1)); + if (defined $ch) { + $ch->remark(__PACKAGE__."/fetching-who", undef, 'delete'); + $ch->remark(__PACKAGE__."/fetching-who-expire", undef, 'delete'); + } + } + } + return $msg; +} + +sub message_arrived { + my ($this,$msg,$sender) = @_; + + # 条件をはずれていたら last で抜ける + while (1) { + # クライアントからのメッセージか？ + last unless ($sender->isa('IrcIO::Client')); + # 動作は許可されているか? + last unless ((!defined $sender->option('no-cache')) || + !$this->_yesno($sender->option('no-cache'))); + my $fetch_channel_info = sub { + my %ret; + $ret{chan_long} = shift; + ($ret{chan_short}, $ret{network_name}) = + Multicast::detach($ret{chan_long}); + $ret{network} = RunLoop->shared_loop->network($ret{network_name}); + unless (defined $ret{network}) { + } else { + $ret{ch} = $ret{network}->channel($ret{chan_short}); + $ret{chan_send} = RunLoop->shared_loop->multi_server_mode_p ? + $ret{chan_long} : $ret{chan_short}; + } + return %ret; + }; + if ($msg->command eq 'MODE' && + $this->_yesno($this->config->use_mode_cache) && + Multicast::channel_p($msg->param(0)) && + !defined $msg->param(1)) { + my %info = $fetch_channel_info->($msg->param(0)); + unless (defined $info{network}){ + # network not found. maybe disconnected + last; + } + last if !defined $info{ch}; + if ($info{ch}->remark('switches-are-known')) { + my $remark = $sender->remark('mode-cache-state') || {}; + my $ch_remark = $remark->{$info{chan_long}}; + if (!$ch_remark->[MODE_CACHE_SENDED]) { + $this->_send_mode_cache($sender, + $info{chan_send}, + $info{ch}) + if (!$ch_remark->[MODE_CACHE_FORCE_SENDED]); + $ch_remark->[MODE_CACHE_SENDED] = 1; + $sender->remark('mode-cache-state', $remark); + return undef; + } + } else { + if ($info{ch}->remark(__PACKAGE__."/fetching-switches") && + ($info{ch}->remark(__PACKAGE__."/fetching-switches-expire") >= time())) { + # 取得しているクライアントがいて、期限が切れてないなら、 + # 今回は消して便乗。 + return undef; + } + # 取得しにいってもらう。 + } + } elsif ($msg->command eq 'WHO' && + $this->_yesno($this->config->use_who_cache) && + Multicast::channel_p($msg->param(0))) { + my %info = $fetch_channel_info->($msg->param(0)); + unless (defined $info{network}){ + # network not found. maybe disconnected + last; + } + last if !defined $info{ch}; + my $remark = $sender->remark('who-cache-used') || {}; + if (!exists $remark->{$info{chan_long}}) { + # cache がそろっているかわからないため、 + # とりあえず作ってみて、足りなかったらあきらめる。 + my $message_tmpl = $this->construct_irc_message( + Prefix => RunLoop->shared_loop->sysmsg_prefix('system'), + Command => RPL_WHOREPLY, + Params => [ + RunLoop->shared_loop->current_nick, + $info{chan_send}, + ], + ); + my @messages; + eval { + foreach (values %{$info{ch}->names}) { + my $p_ch = $_; + my $p = $p_ch->person; + + # たいして重要でない上、 + # 捏造が簡単なデータは捏造します。 + # 注意してください。 + if (!$p->username || !$p->userhost || + !$p->realname || !$p->server) { + # データ不足。あきらめる。 + die 'cache data not enough'; + } + + my $message = $message_tmpl->clone; + $message->param(2, $p->username); + $message->param(3, $p->userhost); + $message->param(4, $p->server); + $message->param(5, + Multicast::global_to_local($p->nick, + $info{network})); + $message->param(6, + (length($p->away) ? 'G' : 'H') . + $p_ch->priv_symbol); + $message->param(7, + $info{network}->remark('server-hops') + ->{$p->server}.' '. + $p->realname); + push(@messages, $message); + } + }; + if (!$@) { + my $message = $message_tmpl->clone; + $message->command(RPL_ENDOFWHO); + $message->param(2, 'End of WHO list.'); + push(@messages, $message); + map { + $sender->send_message($_); + } @messages; + $remark->{$info{chan_long}} = 1; + $sender->remark('who-cache-used', $remark); + return undef; + } else { + if ($info{ch}->remark(__PACKAGE__."/fetching-who") && + ($info{ch}->remark(__PACKAGE__."/fetching-who-expire") >= time())) { + # 取得しているクライアントがいて、期限が切れてないなら、 + # 今回は消して便乗。 + return undef; + } + # 取得しにいってもらう。 + } + } + } + last; + } + + return $msg; +} + + +sub _send_mode_cache { + my ($this,$sendto,$ch_name,$ch) = @_; + + $sendto->send_message( + $this->construct_irc_message( + Prefix => RunLoop->shared_loop->sysmsg_prefix('system'), + Command => RPL_CHANNELMODEIS, + Params => [ + RunLoop->shared_loop->current_nick, + $ch_name, + $ch->mode_string, + ], + Remarks => { + 'fill-prefix-when-sending-to-client' => 1, + }, + ) + ); + if (defined $ch->remark('creation-time')) { + $sendto->send_message( + $this->construct_irc_message( + Prefix => RunLoop->shared_loop->sysmsg_prefix('system'), + Command => RPL_CREATIONTIME, + Params => [ + RunLoop->shared_loop->current_nick, + $ch_name, + $ch->remark('creation-time'), + ], + Remarks => { + 'fill-prefix-when-sending-to-client' => 1, + }, + ) + ); + } +} + +1; +=pod +info: データをキャッシュしてサーバに問い合わせないようにする +default: off +section: important + +# キャッシュを使用しても、使われるのは接続後最初の一度だけです。 +# 二度目からは通常通りにサーバに問い合わせます。 +# また、クライアントオプションの no-cache を指定すれば動きません。 + +# mode キャッシュを使用するか +use-mode-cache: 1 + +# who キャッシュを使用するか +use-who-cache: 1 +=cut diff -urN /non-existant-dir/module/Client/Conservative.pm tiarra-20080510/module/Client/Conservative.pm --- /non-existant-dir/module/Client/Conservative.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/Client/Conservative.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,48 @@ +# ----------------------------------------------------------------------------- +# $Id: Conservative.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +# copyright (C) 2004 Topia . all rights reserved. +package Client::Conservative; +use strict; +use warnings; +use base qw(Module); +use Mask; +use Multicast; +use NumericReply; +use Tiarra::Utils; + +sub message_io_hook { + my ($this,$msg,$io,$type) = @_; + + if ($io->isa('IrcIO::Client') && + $type eq 'out') { + my $mark_as_need_colon = sub { + $msg->remark('always-use-colon-on-last-param', 1); + $msg; + }; + my $command = $msg->command; + + foreach (qw(PRIVMSG NOTICE NICK WALLOPS PART NJOIN KICK TOPIC INVITE + PING QUIT), + (map { NumericReply::fetch_number("RPL_$_") } + (qw(MAP MAPSTART HELLO SERVLIST AWAY USERHOST ISON), + qw(WHOISUSER WHOISSERVER WHOWASUSER WHOISCHANNELS), + qw(LIST TOPIC VERSION INFO YOUREOPER TIME))), + ) { + if ($command eq $_) { + return $mark_as_need_colon->(); + } + } + } + return $msg; +} + +1; +=pod +info: サーバが送信するような IRC メッセージを作成するようにする +default: on + +# サーバが実際に送信しているようなメッセージにあわせるようにします。 +# 多くのクライアントの設計ミスを回避でき(ると思われ)ます。 + +=cut diff -urN /non-existant-dir/module/Client/Cotton.pm tiarra-20080510/module/Client/Cotton.pm --- /non-existant-dir/module/Client/Cotton.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/Client/Cotton.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,87 @@ +# ----------------------------------------------------------------------------- +# $Id: Cotton.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +# copyright (C) 2004 Topia . all rights reserved. +package Client::Cotton; +use strict; +use warnings; +use base qw(Module); +use Mask; +use Multicast; +use Tiarra::Utils; + +sub PART_SHIELD_EXPIRE_TIME (){5 * 60;} + +sub new { + my $class = shift; + my $this = $class->SUPER::new(@_); + $this; +} + +sub message_io_hook { + my ($this,$msg,$io,$type) = @_; + + if ($io->isa('IrcIO::Client') && + $this->is_cotton($io)) { + if (utils->cond_yesno($this->config->use_part_shield) && + $type eq 'in' && + $msg->command eq 'PART' && + Multicast::channel_p($msg->param(0)) && + !defined $msg->param(1)) { + my ($chan_short, $network_name) = Multicast::detach($msg->param(0)); + my $network = $this->_runloop->network($network_name); + if (defined $network) { + my $expire = $network->remark(__PACKAGE__.'/part-shield/expire'); + my $remark = $io->remark(__PACKAGE__.'/part-shield/'.$network_name); + if (defined $expire && + $expire >= time()) { + if (!defined $remark || + (defined $remark->{channels} && + !defined $remark->{channels}->{$chan_short})) { + $remark->{channels}->{$chan_short} = 1; + return undef; + } + } else { + # remove expired network info + $network->remark(__PACKAGE__.'/part-shield/expire', undef, 'delete'); + $io->remark(__PACKAGE__.'/part-shield/'.$network_name, undef, 'delete'); + } + } + } + } + return $msg; +} + +sub connected_to_server { + my ($this,$server,$new_connection) = @_; + + if (!$new_connection) { + # reconnect + $server->remark(__PACKAGE__.'/part-shield/expire', time() + PART_SHIELD_EXPIRE_TIME); + } +} + +sub is_cotton { + my ($this, $client) = @_; + + return 1 if defined $client->remark('client-version') && + $client->remark('client-version') =~ /(Cotton|Unknown) Client/; + return 1 if defined $client->option('client-type') && + $client->option('client-type') =~ /(cotton|unknown)/; + return 0; +} + +1; +=pod +info: Cotton の行うおかしな動作のいくつかを無視する +default: off +section: important + +# 該当クライアントのオプション client-type に cotton や unknown と指定するか、 +# Client::GetVersion を利用してクライアントのバージョンを取得するように +# してください。 + +# part shield (rejoin 時に自動で行われる part の無視)を使用するか +use-part-shield: 1 + +=cut diff -urN /non-existant-dir/module/Client/Eval.pm tiarra-20080510/module/Client/Eval.pm --- /non-existant-dir/module/Client/Eval.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/Client/Eval.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,127 @@ +# ----------------------------------------------------------------------------- +# $Id: Eval.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +package Client::Eval; +use strict; +use warnings; +use base qw(Module); +use Mask; +use Timer; +use Data::Dumper; + +sub message_arrived { + my ($this,$msg,$sender) = @_; + + # クライアントからのメッセージか？ + if ($sender->isa('IrcIO::Client')) { + # 指定されたコマンドか? + my $cmd = Mask::match_deep([$this->config->command('all')], $msg->command); + my $hexcmd = Mask::match_deep([$this->config->hex_command('all')], $msg->command); + if ($cmd || $hexcmd) { + # メッセージ再構築 + my ($method) = join(' ', @{$msg->params}); + my ($ret, $err); + do { + # disable warning + local $SIG{__WARN__} = sub { }; + # die handler + #local $SIG{__DIE__} = sub { $err = $_[0]; }; + no strict; + # untaint + $method =~ /\A(.*)\z/s; + $err = ''; + $ret = eval($1); + }; + $err = $@; + + my $message = $this->construct_irc_message( + Prefix => RunLoop->shared_loop->sysmsg_prefix(qw(priv system)), + Command => 'NOTICE', + Params => [RunLoop->shared_loop->current_nick, + ''], + ); + my $process = sub { + if (defined $this->config->max_line && + @_ > $this->config->max_line) { + splice @_, $this->config->max_line; + } + map { + if ($hexcmd) { + s/([^\s,'[:print:]])/'\x'.unpack('H*', $1)/eg; + s/\$/\\\$/g; + } + $_; + } @_; + }; + do { + my $dumper = sub { + my $val = shift; + local $SIG{__WARN__} = sub {}; + Data::Dumper->new([$val])->Terse(1)->Purity(1) + ->Seen({ + ($this->_runloop ne $val) ? + (current_runloop => $this->_runloop) : + (), + })->Dump."\n"; + }; + map { + my $new = $message->clone; + $new->param(1, $_); + $sender->send_message($new); + } ( + $process->(split /\n/, 'method: '.$dumper->($method)), + $process->(split /\n/, 'result: '.$dumper->($ret)), + $process->(split /\n/, 'error: '.$err), + ); + return undef; + }; + } + } + + return $msg; +} + +# useful functions to call from eval +sub runloop { return RunLoop->shared; } +sub network { return runloop->network(shift); } +sub conf { return Configuration->shared; } +sub module_manager { return ModuleManager->shared_manager; } +sub module { return module_manager->get(shift); } +sub shutdown { return ::shutdown(); } +sub reload { + ReloadTrigger->_install_reload_timer; + return undef; +} + +sub reload_mod { + my $name = shift; + $name .= '.pm'; + $name =~ s|::|/|g; + reload_pm($name); +} + +sub reload_pm { + my $file = shift; + delete $INC{$file}; + require $file; +} + +1; +=pod +info: クライアントから Perl 式を実行できるようにする。 +default: off + +# eval を実行するコマンド名。省略されるとコマンドを追加しません。 +# この時コマンドはTiarraが握り潰すので、IRCプロトコル上で定義された +# コマンド名を設定すべきではありません。 +command: eval + +# hex eval を実行するコマンド名。省略されるとコマンドを追加しません。 +# この時コマンドはTiarraが握り潰すので、IRCプロトコル上で定義された +# コマンド名を設定すべきではありません。 +hex-command: hexeval + +# 表示する最大行数を指定します。省略するとすべての行を表示します。 +max-line: 30 + +=cut diff -urN /non-existant-dir/module/Client/GetVersion.pm tiarra-20080510/module/Client/GetVersion.pm --- /non-existant-dir/module/Client/GetVersion.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/Client/GetVersion.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,68 @@ +# ----------------------------------------------------------------------------- +# $Id: GetVersion.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +# copyright (C) 2004 Topia . all rights reserved. +package Client::GetVersion; +use strict; +use warnings; +use base qw(Module); +use CTCP; + +use constant ({ + EXPIRE_TIME => 5 * 60, + FETCH_EXPIRE_KEY => __PACKAGE__->attach_package('fetching-version-expire'), +}); + +sub client_attached { + my ($this,$client) = @_; + + $client->send_message( + $this->construct_irc_message( + Prefix => $this->_runloop->sysmsg_prefix(qw(system)), + Command => 'PRIVMSG', + Params => [ + $this->_runloop->current_nick, + CTCP->make_text('VERSION'), + ], + )); + $client->remark(FETCH_EXPIRE_KEY, time() + EXPIRE_TIME); +} + +sub message_io_hook { + my ($this,$msg,$io,$type) = @_; + + if ($io->isa('IrcIO::Client')) { + if ($type eq 'in' && $msg->command eq 'NOTICE' && + !Multicast::channel_p($msg->param(0)) && + defined $msg->param(1) && + defined $io->remark(FETCH_EXPIRE_KEY)) { + if ($io->remark(FETCH_EXPIRE_KEY) + >= time()) { + my $ctcp = CTCP->extract_from_text($msg->param(1)); + if (defined $ctcp) { + my ($command, $text) = split(/ /, $ctcp, 2); + if ($command eq 'VERSION') { + $io->remark('client-version', $text); + $io->remark(FETCH_EXPIRE_KEY, undef, 'delete'); + return undef; + } + } + } else { + $io->remark(FETCH_EXPIRE_KEY, undef, 'delete'); + } + } + } + + return $msg; +} + +1; +=pod +info: クライアントに CTCP Version を発行してバージョン情報を得る +default: on + +# オプションはいまのところありません。 +# (開発者向け情報: 取得した情報は remark の client-version に設定され、 +# Client::Guess から使用されます。) + +=cut diff -urN /non-existant-dir/module/Client/Guess.pm tiarra-20080510/module/Client/Guess.pm --- /non-existant-dir/module/Client/Guess.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/Client/Guess.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,217 @@ +# ----------------------------------------------------------------------------- +# $Id: Guess.pm 4404 2008-01-10 23:37:30Z drry $ +# ----------------------------------------------------------------------------- +# copyright (C) 2004 Topia . all rights reserved. +package Client::Guess; +use strict; +use warnings; +use RunLoop; +use SelfLoader; +use Tiarra::SharedMixin; + +# shorthand +our $re_ver = qr/[\d.][\d.a-zA-Z-+]+/; +our $re_tok = qr/\S+/; + +sub _new { + # don't need instance present + return shift; +} + +sub destruct { + map { + $_->remark('client-guess-cache', undef, 'delete'); + } RunLoop->shared_loop->clients_list; +} + +sub is_target { + my ($class_or_this, $type, $client) = @_; + my $this = $class_or_this->_this; + + my $guess = $this->guess($client)->{type}; + if (defined $guess) { + return $guess eq $type; + } else { + return undef; + } +} + +sub guess { + my ($class_or_this, $client, $rehash) = @_; + my $this = $class_or_this->_this; + my $struct = $client->remark('client-guess-cache'); + + if (!$rehash && defined $struct && $struct->{completed}) { + return $struct; + } else { + $struct = {}; + } + + if (defined $client->remark('client-version')) { + if ($this->guess_ctcp_version($struct, + $client->remark('client-version'))) { + $struct->{completed} = 1; + } + } + + if (defined $client->remark('client-type')) { + $struct->{type} = $client->remark('client-type'); + } + + if (scalar(keys(%{$struct}))) { + # cache + $client->remark('client-guess-cache', $struct); + } + return $struct; +} + +sub guess_ctcp_version { + my ($class_or_this, $struct, $str) = @_; + my $this = $class_or_this->_this; + + my $struct_set = sub { + my %stor; + # copy values + my $param; + $param = shift; + if (ref($param) eq 'ARRAY') { + $stor{keys} = [@$param]; + } else { + $stor{keys} = [$param]; + } + $stor{values} = [@_]; + + my ($key, $value); + while () { + ($key, $value) = map { + if (scalar @{$stor{$_}}) { + shift @{$stor{$_}}; + } else { + return $struct; + } + } qw(keys values); + $struct->{$key} = $value; + } + }; + + #$struct_set->('ctcp_version', $str); + my $func = 'version_guess_' . lc(substr($str,0,1)); + if ($this->can($func)) { + if ($this->$func($str, $struct_set)) { + return 1; + } + } + + if ($str =~ /^(Cotton|Unknown) Client/) { + $struct->{type} = 'cotton'; + $struct->{exact_type} = lc($1); + } else { + return undef; + } + return 1; +} + +no warnings 'redefine'; +SelfLoader->load_stubs; +1; +__DATA__ + +sub version_guess_c { + my ($this, $str, $struct_set) = @_; + + if ($str =~ /^CHOCOA ($re_ver) \(($re_tok)\)/) { + $struct_set->([qw(type ver plat)], + 'chocoa', $1, $2); + } elsif ($str =~ m[^Conversation ($re_ver) for (MacOS X|.+?) (http://$re_tok)]) { + $struct_set->([qw(type ver plat url)], + 'conversation', $1, $2, $3); + } else { + return undef; + } + return 1; +} + +sub version_guess_t { + my ($this, $str, $struct_set) = @_; + + if ($str =~ /^Tiarra:($re_tok):perl ($re_tok) on ($re_tok)/) { + $struct_set->([qw(type ver perl_ver perl_plat)], + 'tiarra', $1, $2, $3); + } else { + return undef; + } + return 1; +} + +sub version_guess_l { + my ($this, $str, $struct_set) = @_; + + if ($str =~ /^LimeChat ($re_ver) \((.+?)\)/) { + $struct_set->([qw(type ver plat)], 'limechat', $1, $2); + } elsif ($str =~ /^Loqui version ($re_tok)/) { + $struct_set->([qw(type ver)], 'loqui', $1); + } elsif ($str =~ m{^Liece/($re_ver) :}) { + $struct_set->([qw(type ver)], 'liece', $1); + } else { + return undef; + } + return 1; +} + +sub version_guess_m { + my ($this, $str, $struct_set) = @_; + + if ($str =~ /^madoka ($re_ver) in perl ($re_ver):/) { + $struct_set->([qw(type ver perl_ver)], 'madoka', $1, $2); + } elsif ($str =~ /^Misuzilla Ircv \(($re_ver) version\) on (.NET CLR-$re_tok)/) { + $struct_set->([qw(type ver plat)], 'ircv', $1, $2); + } else { + return undef; + } + return 1; +} + +sub version_guess_p { + my ($this, $str, $struct_set) = @_; + + if ($str =~ /^plum ($re_ver) perl ($re_ver)\s*:?/) { + $struct_set->([qw(type ver perl_ver)], 'plum', $1, $2); + } else { + return undef; + } + return 1; +} + +sub version_guess_r { + my ($this, $str, $struct_set) = @_; + + if ($str =~ m{^Riece/($re_ver) ($re_tok)/($re_ver)}) { + $struct_set->([qw(type ver emacs_flavor emacs_ver)], 'riece', $1, $2, $3); + } else { + return undef; + } + return 1; +} + +sub version_guess_w { + my ($this, $str, $struct_set) = @_; + + if ($str =~ /^WoolChat Ver ($re_ver)/) { + $struct_set->([qw(type ver)], 'woolchat', $1); + } else { + return undef; + } + return 1; +} + +sub version_guess_x { + my ($this, $str, $struct_set) = @_; + + if ($str =~ m{^xchat ($re_ver) ($re_tok) ($re_tok) \[($re_tok)/($re_tok)\]}) { + $struct_set->([qw(type ver plat plat_ver arch cpu_speed)], + 'xchat', $1, $2, $3, $4, $5); + } else { + return undef; + } + return 1; +} diff -urN /non-existant-dir/module/Client/PatchworkMessage.pm tiarra-20080510/module/Client/PatchworkMessage.pm --- /non-existant-dir/module/Client/PatchworkMessage.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/Client/PatchworkMessage.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,78 @@ +# ----------------------------------------------------------------------------- +# $Id: PatchworkMessage.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +# copyright (C) 2004 Topia . all rights reserved. +package Client::PatchworkMessage; +use strict; +use warnings; +use base qw(Module); +use Mask; +use Multicast; +use NumericReply; +use Module::Use qw(Client::Guess); +use Client::Guess; +use Tiarra::Utils; + +sub message_io_hook { + my ($this,$msg,$io,$type) = @_; + + my $mark_as_need_colon = sub { + $msg->remark('always-use-colon-on-last-param', 1); + }; + + if ($io->isa('IrcIO::Client')) { + if ($this->is_target('woolchat', $io)) { + if ($type eq 'out' && + $msg->command eq 'NICK') { + $mark_as_need_colon->(); + } + } elsif ($this->is_target('xchat', $io)) { + if ($type eq 'out' && + $msg->command eq RPL_WHOISUSER) { + $mark_as_need_colon->(); + } + } + } + return $msg; +} + +sub is_target { + my ($this, $target, $io, $default_disable) = @_; + + if (Client::Guess->shared->is_target($target, $io) && + utils->cond_yesno($this->config->get("enable-$target"), + !$default_disable)) { + return 1; + } + return 0; +} + +1; +=pod +info: IRC メッセージにちょっと変更を加えて、クライアントのバグを抑制する +default: off + +# 特に注意書きがない場合はデフォルトで有効です。 +# また、 Client::GetVersion も同時に入れておくと便利です。 +# とりあえず obsolete です。このモジュールで実装されていた機能は +# Client::Conservative によって実現できます。 +# Client::Conservative で実装してはいけないようなものがあった場合のみ +# このモジュールで対処します。 + +# WoolChat: +# 対応しているメッセージ: +# NICK(コロンが必須) +# 説明: +# NICK は接続直後にも発行されるため、 Client::GetVersion での判別まで +# 待てません。該当クライアントのオプション client-type に woolchat と +# 指定してください。実名欄に $client-type=woolchat$ と書けば OK です。 +enable-woolchat: 1 + +# X-Chat: +# 対応しているメッセージ: +# RPL_WHOISUSER(コロンが必須) +# 説明: +# WHOIS の realname にスペースが入っていないと最初の一文字が削られます。 +enable-xchat: 1 + +=cut diff -urN /non-existant-dir/module/Client/ProtectMyself.pm tiarra-20080510/module/Client/ProtectMyself.pm --- /non-existant-dir/module/Client/ProtectMyself.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/Client/ProtectMyself.pm 2008-05-11 00:25:26.000000000 +0900 @@ -0,0 +1,119 @@ +# ----------------------------------------------------------------------------- +# $Id: ProtectMyself.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +# copyright (C) 2004 Topia . all rights reserved. +package Client::ProtectMyself; +use strict; +use warnings; +use base qw(Module); +use Multicast; +use Auto::AliasDB; +use Tiarra::Utils; + +sub message_arrived { + my ($this,$msg,$sender) = @_; + my $runloop = $this->_runloop; + my $current_nick = $runloop->current_nick; + + if ($runloop->multi_server_mode_p && + $sender->isa('IrcIO::Server') && + defined $msg->nick && + $msg->nick eq $current_nick) { + if ($msg->command =~ /^(NICK|QUIT|PART)$/) { + $msg->remark(__PACKAGE__ . '/network-name', $sender->network_name); + } + } + return $msg; +} + +sub message_io_hook { + my ($this,$msg,$io,$type) = @_; + my $runloop = $this->_runloop; + my $current_nick = $runloop->current_nick; + + if ($runloop->multi_server_mode_p && + $io->client_p && + $type eq 'out' && + $msg->remark('message-send-by-other') && + defined $msg->nick && + $msg->nick eq $current_nick) { + my ($msg_tmpl, %additional_replaces, @affected); + my $attach_for_client = sub { + my $network_name = $msg->remark(__PACKAGE__ . '/network-name'); + $network_name = $runloop->default_network + unless defined $network_name; + return map { + Multicast::attach_for_client($_, $network_name); + } @_; + }; + my $set_affected_by_remark = sub { + if (defined $msg->remark('affected-channels')) { + @affected = $attach_for_client->( + @{$msg->remark('affected-channels')}); + } else { + @affected = $runloop->current_nick; + } + }; + if ($msg->command eq 'NICK') { + $msg_tmpl = utils->get_first_defined( + $this->config->nick_format, + 'Nick changed #(nick.now) -> #(nick.new)'); + $additional_replaces{'nick.new'} = $msg->param(0); + $set_affected_by_remark->(); + } elsif ($msg->command eq 'PART') { + $msg_tmpl = utils->get_first_defined( + $this->config->part_format, + 'Part #(nick.now) (#(message)) from #(target)'); + $additional_replaces{'message'} = $msg->param(1); + @affected = $msg->param(0); + } elsif ($msg->command eq 'QUIT') { + $msg_tmpl = utils->get_first_defined( + $this->config->quit_format, + 'Quit #(nick.now) (#(message))'); + $additional_replaces{'message'} = $msg->param(0); + $set_affected_by_remark->(); + } elsif ($msg->command eq 'JOIN') { + $msg_tmpl = utils->get_first_defined( + $this->config->join_format, + 'Join #(nick.now) (#(prefix.now)) to #(target)'); + @affected = $msg->param(0); + } + if (@affected) { + my $aliasdb = Auto::AliasDB->shared; + my $msg_skel = $this->construct_irc_message( + Prefix => $runloop->sysmsg_prefix(qw(system fake::system)), + Command => 'NOTICE', + Params => [undef, undef]); + return map { + my $new_msg = $msg_skel->clone; + $new_msg->param(0, $_); + $new_msg->param(1, $aliasdb->stdreplace( + $msg->prefix, $msg_tmpl, $msg, undef, + target => $_, + %additional_replaces, + )); + $new_msg; + } @affected; + } + } + return $msg; +} + +1; +=pod +info: 意図せず自分のニックが変わってしまうのを防止する +default: off + +# {nick,part,quit,join}-format: それぞれのメッセージのフォーマットを指定します。 +# {nick,user,host,prefix}.now などはどこでも使えます。 +# そのほかには +# target : 表示するチャンネル(またはニック)。 +# nick.new : nick-format のみ。新しいニック。 +# message : part と quit 。メッセージ。 + +nick-format: Nick changed #(nick.now) -> #(nick.new) +part-format: Part #(nick.now) (#(message)) from #(target) +quit-format: Quit #(nick.now) (#(message)) +join-format: Join #(nick.now) (#(prefix.now)) to #(target) + +=cut diff -urN /non-existant-dir/module/Client/Rehash.pm tiarra-20080510/module/Client/Rehash.pm --- /non-existant-dir/module/Client/Rehash.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/Client/Rehash.pm 2008-05-11 00:25:26.000000000 +0900 @@ -0,0 +1,131 @@ +# ----------------------------------------------------------------------------- +# $Id: Rehash.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +# copyright (C) 2004 Topia . all rights reserved. +package Client::Rehash; +use strict; +use warnings; +use base qw(Module); +use Mask; +use Multicast; +use NumericReply; +use Timer; + +my $timer_name = __PACKAGE__.'/timer'; + +sub new { + my $class = shift; + my $this = $class->SUPER::new(@_); +} + +sub destruct { + my ($this) = shift; + + # timer があれば解除 + foreach my $client (RunLoop->shared_loop->clients_list) { + my $timer = $client->remark($timer_name); + if (defined $timer) { + $client->remark($timer_name, undef, 'delete'); + $timer->uninstall; + } + } +} + +sub message_arrived { + my ($this,$msg,$sender) = @_; + + # クライアントからのメッセージか？ + if ($sender->isa('IrcIO::Client')) { + my $runloop = RunLoop->shared_loop; + # 指定されたコマンドか? + if (Mask::match_deep([$this->config->command_nick('all')], $msg->command)) { + if (!defined $msg->param(0)) { + } elsif ($msg->param(0) eq $runloop->current_nick) { + } else { + $sender->send_message( + $this->construct_irc_message( + Prefix => $msg->param(0).'!'.$sender->username.'@'. + $sender->client_host, + Command => 'NICK', + Param => $runloop->current_nick, + )); + + } + # ここで消す。 + return undef; + } elsif (Mask::match_deep([$this->config->command_names('all')], $msg->command)) { + my @channels = map { + my $network_name = $_->network_name; + map { + [$network_name, $_->name]; + } $_->channels_list; + } $runloop->networks_list; + $sender->remark($timer_name, Timer->new( + Interval => (defined $this->config->interval ? + $this->config->interval : 2), + Repeat => 1, + Code => sub { + my $timer = shift; + my $runloop = RunLoop->shared_loop; + while (1) { + my $entry = shift(@channels); + if (defined $entry && $sender->connected) { + my ($network_name, $ch_name) = @$entry; + my $network = $runloop->network($network_name); + my $flush_namreply = sub { + my $msg = shift; + $msg->param(0, $runloop->current_nick); + $sender->send_message($msg); + }; + if (!defined $network) { + # network disconnected. ignore + next; + } + my $ch = $network->channel($ch_name); + if (!defined $ch) { + # parted channel; ignore + next; + } + $sender->do_namreply($ch, $network, + undef, $flush_namreply); + } else { + $sender->remark($timer_name, undef, 'delete'); + $timer->uninstall; + } + last; + } + }, + )->install); + + # ここで消す。 + return undef; + } + } + + return $msg; +} + +1; +=pod +info: 全チャンネル分の names の内部キャッシュをクライアントに送信する。 +default: off + +# もともとはクライアントの再初期化目的に作ったのですが、 names を送信しても +# 更新されないクライアントが多いので、主に multi-server-mode な Tiarra の +# 下にさらに Tiarra をつないでいる人向けにします。 + +# names でニックリストを更新してくれるクライアント: +# Tiarra +# してくれないクライアント: (括弧内は確認したバージョンまたは注釈) +# LimeChat(1.18) + +# nick rehash に使うコマンドを指定します。 +# 第二パラメータとして現在クライアントが認識している nick を指定してください。 +command-nick: rehash-nick + +# names rehash に使うコマンドを指定します。 +command-names: rehash-names + +# チャンネルとチャンネルの間のウェイトを指定します。 +interval: 2 +=cut diff -urN /non-existant-dir/module/Client/ShowNick.pm tiarra-20080510/module/Client/ShowNick.pm --- /non-existant-dir/module/Client/ShowNick.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/Client/ShowNick.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,72 @@ +# ----------------------------------------------------------------------------- +# $Id: ShowNick.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +# copyright (C) 2004 Topia . all rights reserved. +package Client::ShowNick; +use strict; +use warnings; +use base qw(Module); + +sub message_io_hook { + my ($this,$msg,$io,$type) = @_; + + if ($io->isa('IrcIO::Client')) { + if ($type eq 'in' && + ($msg->command eq 'WHOIS' || $msg->command eq 'WHO') && + RunLoop->shared_loop->multi_server_mode_p) { + my $local_nick = RunLoop->shared_loop->current_nick; + if ($msg->param(0) eq $local_nick) { + my $prefix = RunLoop->shared_loop->sysmsg_prefix(qw(priv system)); + map { + # ローカルnickとグローバルnickが食い違っていたらその旨を伝える。 + # 接続しているネットワーク名を全部表示する + my $network_name = $_->network_name; + my $global_nick = $_->current_nick; + if ($global_nick ne $local_nick) { + $io->send_message( + $this->construct_irc_message(Prefix => $prefix, + Command => 'NOTICE', + Params => [$local_nick, + "*** Your global nick in $network_name is currently '$global_nick'."])); + } else { + $io->send_message( + $this->construct_irc_message(Prefix => $prefix, + Command => 'NOTICE', + Params => [$local_nick, + "*** Your global nick in $network_name is same as local nick."])); + } + } RunLoop->shared_loop->networks_list; + } + } + } + return $msg; +} + +sub client_attached { + my ($this,$client) = @_; + + if (RunLoop->shared_loop->multi_server_mode_p) { + my $current_nick = RunLoop->shared_loop->current_nick; + map { + # ローカルnickとグローバルnickが同じネットワークについてその旨を伝える。 + # (接続しているチャンネルを表示する、程度の用途) + my $network_name = $_->network_name; + my $global_nick = $_->current_nick; + if ($global_nick eq $current_nick) { + $client->send_message( + $this->construct_irc_message( + Prefix => RunLoop->shared_loop->sysmsg_prefix(qw(priv system)), + Command => 'NOTICE', + Params => [$current_nick, + "*** Your global nick in $network_name is same as local nick."])); + } + } RunLoop->shared_loop->networks_list; + } +} + + +1; +=pod +info: show network +default: off +=cut diff -urN /non-existant-dir/module/Debug/AliasTest.pm tiarra-20080510/module/Debug/AliasTest.pm --- /non-existant-dir/module/Debug/AliasTest.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/Debug/AliasTest.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,38 @@ +# -*- cperl -*- +# ----------------------------------------------------------------------------- +# $Id: AliasTest.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +# copyright (C) 2003 Topia . all rights reserved. +package Debug::AliasTest; +use strict; +use warnings; +use base qw(Module); +use Module::Use qw(Auto::Utils); +use Auto::Utils; +use Mask; + +sub message_arrived { + my ($this,$msg,$sender) = @_; + my @result = ($msg); + + # サーバーからのメッセージか？ + if ($sender->isa('IrcIO::Server')) { + # PRIVMSGか？ + if ($msg->command eq 'PRIVMSG') { + my ($get_ch_name,undef,undef,$reply_anywhere) + = Auto::Utils::generate_reply_closures($msg,$sender,\@result); + + my ($req, $str) = split(/\s+/, $msg->param(1), 2); + if (Mask::match_array([$this->config->request('all')], $req, 1)) { + # 一致していた。 + if (Mask::match_deep_chan([$this->config->mask('all')],$msg->prefix,$get_ch_name->())) { + $reply_anywhere->(join('', ($this->config->prefix||''), $str, ($this->config->suffix||''))); + } + } + } + } + + return @result; +} + +1; diff -urN /non-existant-dir/module/Debug/Core.pm tiarra-20080510/module/Debug/Core.pm --- /non-existant-dir/module/Debug/Core.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/Debug/Core.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,565 @@ +## ---------------------------------------------------------------------------- +# Debug::Core. +# ----------------------------------------------------------------------------- +# Mastering programmed by YAMASHINA Hio +# +# Copyright 2008 YAMASHINA Hio +# ----------------------------------------------------------------------------- +# $Id: Core.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +package Debug::Core; +use strict; +use warnings; +use base qw(Module); + +our $DEFAULT_COMMAND = 'debugcore'; + +1; + +# ----------------------------------------------------------------------------- +# $pkg->new(). +# +sub new +{ + my $class = shift; + my $this = $class->SUPER::new(@_); + + $this->{command} = uc($this->config->command || $DEFAULT_COMMAND); + + return $this; +} + +# ----------------------------------------------------------------------------- +# $obj->message_arrived($msg, $sender). +# +sub message_arrived +{ + my ($this, $msg, $sender) = @_; + + if( !$sender->isa('IrcIO::Client') ) + { + return $msg; + } + + if( $msg->command ne $this->{command} ) + { + return $msg; + } + + $msg->remark('do-not-send-to-servers', 1); + + my $params = $msg->params; + $params = [@$params]; # sharrow-copy. + my $param0 = shift @$params || 'help'; + eval + { + $this->_dispatch($params, $param0, $msg, $sender); + }; + if( $@ ) + { + RunLoop->shared_loop->notify_error(__PACKAGE__."#message_arrived: $@"); + } + + return $msg; +} + +# ----------------------------------------------------------------------------- +# $obj->_dispatch($params, $name, $msg, $sender). +# +sub _dispatch +{ + my ($this, $params, $name, $msg, $sender) = @_; + + my $subname = "_debugcore_".$name; + $subname =~ tr/-/_/; + + my $sub = $this->can($subname); + if( !$sub ) + { + $this->_runloop->notify_msg("unknown command: $name"); + return; + } + + $this->$sub($params, $name, $msg, $sender); +} + +# ----------------------------------------------------------------------------- +# $obj->_debugcore_help($params, $name, $msg, $sender). +# (impl:debugcore) +# +sub _debugcore_help +{ + my $this = shift; + my $params = shift; + + $this->_runloop->notify_msg("debugcore:"); + $this->_runloop->notify_msg(" help - show this usage."); + $this->_runloop->notify_msg(" bbs - show BulletinBoard info."); + $this->_runloop->notify_msg(" socket - show internal sockets."); + $this->_runloop->notify_msg(" module - show module info."); + $this->_runloop->notify_msg("(end of message)"); +} + +# ----------------------------------------------------------------------------- +# $obj->_debugcore_bbs($params, $name, $msg, $sender). +# (impl:debugcore) +# +sub _debugcore_bbs +{ + my $this = shift; + my $params = shift; + + my $runloop = $this->_runloop; + my $subcmd = shift @$params || 'keys'; + + if( !BulletinBoard->can("shared") && $subcmd ne 'help' ) + { + $runloop->notify_msg("bbs - not loaded"); + return; + } + + if( $subcmd eq 'help' ) + { + $this->_runloop->notify_msg("bbs:"); + $this->_runloop->notify_msg(" keys - show keys in BulletinBoard."); + $this->_runloop->notify_msg("(end of message)"); + }elsif( $subcmd eq 'keys' ) + { + my $keys = [BulletinBoard->shared->keys]; + @$keys = sort @$keys; + my $nr_keys = @$keys; + $runloop->notify_msg("bbs - $nr_keys ".($nr_keys==1 ? 'key exists' : 'keys exist')); + + my $base = shift @$params || 0; + my $limit = 5; + $base =~ /^0*\d+\z/ or $base = 0; + + if( $base >= @$keys ) + { + return; + } + my $last = $base + $limit - 1; + if( $last > $#$keys ) + { + $last = $#$keys; + } + foreach my $i ($base .. $last) + { + my $key = $keys->[$i]; + my $val = BulletinBoard->get($key); + + if( my $ref = ref($val) ) + { + if( UNIVERSAL::isa($val, 'ARRAY') ) + { + my $n = @$val; + my $elms = $n==1 ? 'elm' : 'elms'; + $val = "[ARRAY/$n $elms] $val"; + }elsif( UNIVERSAL::isa($val, 'HASH') ) + { + my $n = keys %$val; + my $keys = $n==1 ? 'key' : 'keys'; + $val = "[HASH/$n $keys] $val"; + }else + { + $val = "[REF] $val"; + } + }else + { + if( defined($val) ) + { + $val = "[SCALAR] $val"; + }else + { + $val = "[UNDEF]"; + } + } + if( length($val) > 40 ) + { + substr($val, 37) = '...'; + } + + $runloop->notify_msg("bbs - [$i] $key = $val"); + } + }else + { + $runloop->notify_msg("bbs - unknown subcommand: $subcmd"); + } +} + +# ----------------------------------------------------------------------------- +# $obj->_debugcore_socket($params, $name, $msg, $sender). +# (impl:debugcore) +# +sub _debugcore_socket +{ + my $this = shift; + my $params = shift; + + my $runloop = $this->_runloop; + my $subcmd = shift @$params || 'list'; + + my $get_socket = sub{ + my $i = shift; + if( !defined($i) ) + { + $runloop->notify_msg("socket - $subcmd: require param"); + return; + } + if( $i !~ /^\d+\z/ ) + { + $runloop->notify_msg("socket - $subcmd: invalid index: $i"); + return; + } + my $sockets = $this->_runloop->{sockets}; + if( $i > $#$sockets ) + { + $runloop->notify_msg("socket - $subcmd: $i is out of range, max=$#$sockets"); + return; + } + my $socket = $sockets->[$i]; + if( !$socket ) + { + $runloop->notify_msg("socket - [$i] ".(defined($socket)?"false:$socket":"undef")); + } + $socket; + }; + + if( $subcmd eq 'help' ) + { + $this->_runloop->notify_msg("socket:"); + $this->_runloop->notify_msg(" help - show this usage."); + $this->_runloop->notify_msg(" list - show installed socket."); + $this->_runloop->notify_msg(" get - show socket in detail."); + $this->_runloop->notify_msg(" uninstall - uninstall detached socket."); + $this->_runloop->notify_msg("(end of message)"); + }elsif( $subcmd eq 'list' ) + { + my $sockets = $this->_runloop->{sockets}; + $sockets = [@$sockets]; # sharrow-copy. + my $nr_sockets = @$sockets; + $runloop->notify_msg("socket - $nr_sockets ".($nr_sockets==1 ? 'sockets exists' : 'sockets exist')); + + my $base = shift @$params || 0; + my $limit = 5; + $base =~ /^0*\d+\z/ or $base = 0; + + if( $base >= @$sockets ) + { + return; + } + my $last = $base + $limit - 1; + if( $last > $#$sockets ) + { + $last = $#$sockets; + } + foreach my $i ($base .. $last) + { + my $socket = $sockets->[$i]; + my $sockref = ref($socket->sock) || '-'; + my $ref = ref($socket); + + foreach ($ref, $sockref) + { + s/^IrcIO::Server(?=::|$)/IrcIO::S/; + s/^IrcIO::Client(?=::|$)/IrcIO::C/; + s/^Tools::/T::/; + s/^IO::Socket::/IO::S::/; + } + my $val = "$ref ($sockref) ".$socket->name; + + if( length($val) > 40 ) + { + substr($val, 37) = '...'; + } + + $runloop->notify_msg("socket - [$i] $val"); + } + }elsif( $subcmd eq 'get' ) + { + my $i = shift @$params; + my $socket = $get_socket->($i); + $socket or return; + + my ($cls,$ptr) = split(/=/, $socket); + $ptr ||= '-'; + $runloop->notify_msg("socket - [$i] $cls"); + $runloop->notify_msg("socket - [$i] ptr: ($ptr)"); + + my $sock = $socket->sock; + my ($scls,$sptr) = split(/=/, $sock || '-'); + $sptr ||= '-'; + my $fd = $sock ? fileno($sock) : undef; + defined($fd) or $fd = '-'; + $runloop->notify_msg("socket - [$i] name: ".($socket->name||'-')); + $runloop->notify_msg("socket - [$i] sock: $scls"); + $runloop->notify_msg("socket - [$i] sock.ptr: $sptr"); + $runloop->notify_msg("socket - [$i] sock.fd: $fd"); + }elsif( $subcmd eq 'uninstall' ) + { + my $i = shift @$params; + my $socket = $get_socket->($i); + $socket or return; + + if( $socket->sock ) + { + $runloop->notify_msg("socket - uninstall [$i] socket is still attached, not uninstalled"); + return; + } + + my ($cls,$ptr) = split(/=/, $socket); + $ptr ||= '-'; + $runloop->notify_msg("socket - [$i] $cls"); + $runloop->notify_msg("socket - [$i] ptr: ($ptr)"); + + my $sock = $socket->sock; + my ($scls,$sptr) = split(/=/, $sock || '-'); + $sptr ||= '-'; + my $fd = $sock ? fileno($sock) : undef; + defined($fd) or $fd = '-'; + $runloop->notify_msg("socket - [$i] name: ".($socket->name||'-')); + $runloop->notify_msg("socket - [$i] sock: $scls"); + $runloop->notify_msg("socket - [$i] sock.ptr: $sptr"); + $runloop->notify_msg("socket - [$i] sock.fd: $fd"); + $runloop->notify_msg("socket - [$i] uninstall ..."); + eval{ $runloop->uninstall_socket($socket); }; + if( $@ ) + { + $runloop->notify_msg("socket - [$i] uninstall failed: $@"); + return; + } + $runloop->notify_msg("socket - [$i] uninstall success"); + }else + { + $runloop->notify_msg("socket - unknown subcommand: $subcmd"); + } +} + +# ----------------------------------------------------------------------------- +# $obj->_debugcore_module($params, $name, $msg, $sender). +# (impl:debugcore) +# +sub _debugcore_module +{ + my $this = shift; + my $params = shift; + + my $runloop = $this->_runloop; + my $subcmd = shift @$params || 'summary'; + + if( $subcmd eq 'help' ) + { + $this->_runloop->notify_msg("module:"); + $this->_runloop->notify_msg(" help - show this usage."); + $this->_runloop->notify_msg(" summary - show module summary."); + $this->_runloop->notify_msg(" list - show module list in detail."); + $this->_runloop->notify_msg(" dep - show module dependency."); + $this->_runloop->notify_msg("(end of message)"); + }elsif( $subcmd eq 'summary' ) + { + my $mman = $runloop->_mod_manager; + my $modlist = $mman->get_modules('even-if-blacklisted'); + my $nr_mods = @$modlist; + + $runloop->notify_msg($nr_mods.(@$modlist==1?' module is':' modules are').' loaded'); + my ($mlen) = sort{$b<=>$a} map{length(ref($_))} @$modlist; + foreach my $i (0 .. $nr_mods-1) + { + my $mod = $modlist->[$i]; + my ($mref,$mptr) = split(/=/, $mod); + my $black = $mman->check_blacklist($mref) ? '*' : '-'; + $mref = sprintf('%-*s', $mlen, $mref); + my $prefix = sprintf('module - [%02d] ', $i); + $runloop->notify_msg($prefix."$mref $black $mptr"); + } + my %coms = map{ ref($_)=>$_ } @$modlist;; + + my $submodlist = [sort grep{!$coms{$_}} keys %{$mman->{mod_timestamps}}]; + my $nr_submods = @$submodlist; + $runloop->notify_msg("$nr_submods sub".(@$modlist==1?' module is':' modules are').' loaded'); + foreach my $i (0 .. $#$submodlist) + { + my $mref = $submodlist->[$i]; + my $prefix = sprintf('module - [%02d] ', $i); + $runloop->notify_msg($prefix.$mref); + } + }elsif( $subcmd eq 'list' ) + { + my $mman = $runloop->_mod_manager; + my $modlist = $mman->get_modules('even-if-blacklisted'); + my $nr_mods = @$modlist; + + $runloop->notify_msg($nr_mods.(@$modlist==1?' module is':' modules are').' loaded'); + + my $base = shift @$params || 0; + my $limit = 5; + $base =~ /^0*\d+\z/ or $base = 0; + + if( $base >= @$modlist ) + { + return; + } + my $last = $base + $limit - 1; + if( $last > $#$modlist ) + { + $last = $#$modlist; + } + my ($mlen) = sort{$b<=>$a} map{length(ref($modlist->[$_]))} $base .. $last; + foreach my $i ($base .. $last) + { + my $mod = $modlist->[$i]; + my ($mref,$mptr) = split(/=/, $mod); + my $black = $mman->check_blacklist($mref); + $mptr ||= '-'; + my $prefix = sprintf('module - [%02d] ', $i); + $runloop->notify_msg($prefix."-"); + $runloop->notify_msg($prefix."$mref"); + $runloop->notify_msg($prefix."ptr: ".$mptr); + $runloop->notify_msg($prefix."black: ".($black?"YES":"-")); + } + }elsif( $subcmd eq 'dep' ) + { + my $mod = shift @$params; + if( !$mod ) + { + $runloop->notify_msg("usage: module dep {module-name}"); + return; + } + my %var_cache; + my $get_usevars = sub{ + my $mod = shift; + if( my $pair = $var_cache{$mod} ) + { + return @$pair; + } + if( $mod !~ /^([A-Z]\w*(?:::[A-Z]\w*)*)\z/ ) + { + $runloop->notify_msg("invalid module name: $mod"); + return; + } + $mod = $1; # untaint. + my $use_varname = $mod . '::' . 'USE'; + my $used_varname = $mod . '::' . 'USED'; + my ($use, $used); + { + no strict 'refs'; + $use = \@{$use_varname}; + $used = \%{$used_varname}; + } + $var_cache{$mod} = [$use, $used]; + ($use, $used); + }; + + my ($use, $used) = $get_usevars->($mod); + my $nr_use = @$use; + my $nr_used = keys %$used; + $runloop->notify_msg("$mod uses $nr_use".($nr_use==1?' module':' modules')); + $use = [sort @$use]; + foreach my $i (1..@$use) + { + $runloop->notify_msg(" USE[$i] = $use->[$i-1]"); + } + $runloop->notify_msg("$mod is used from $nr_used".($nr_used==1?' module':' modules')); + my $used_list = [sort keys %$used]; + foreach my $i (1..@$used_list) + { + $runloop->notify_msg(" USED[$i] = $used_list->[$i-1]"); + } + + my %deep_use; + my @deep_use = @$use; + while( @deep_use ) + { + my $m = shift @deep_use; + $deep_use{$m} and next; + $deep_use{$m} = 1; + my ($use, $used) = $get_usevars->($m); + push(@deep_use, @$use); + } + delete @deep_use{@$use}; + @deep_use = sort keys %deep_use; + my $nr_deep_use = @deep_use; + $runloop->notify_msg("$mod has $nr_deep_use deeply use ".($nr_deep_use==1?'module':'modules')); + foreach my $i (1..@deep_use) + { + $runloop->notify_msg(" DEEP_USE[$i] = $deep_use[$i-1]"); + } + + my %deep_used; + my @deep_used = keys %$used; + while( @deep_used ) + { + my $m = shift @deep_used; + $deep_used{$m} and next; + $deep_used{$m} = 1; + my ($use, $used) = $get_usevars->($m); + push(@deep_used, keys %$used); + } + delete @deep_used{@$used_list}; + @deep_used = sort keys %deep_used; + my $nr_deep_used = @deep_used; + $runloop->notify_msg("$mod has $nr_deep_used deeply used ".($nr_deep_used==1?'module':'modules')); + foreach my $i (1..@deep_used) + { + $runloop->notify_msg(" DEEP_USED[$i] = $deep_used[$i-1]"); + } + }else + { + $runloop->notify_msg("module - unknown subcommand: $subcmd"); + } +} + +# ----------------------------------------------------------------------------- +# End of Module. +# ----------------------------------------------------------------------------- +# ----------------------------------------------------------------------------- +# End of File. +# ----------------------------------------------------------------------------- +__END__ + +=encoding utf8 + +=for stopwords + YAMASHINA + Hio + ACKNOWLEDGEMENTS + AnnoCPAN + CPAN + RT + +=begin tiarra-doc + +info: Tiarra の内部構造の追跡. +default: off +#section: important + +# Tiarra の内部構造を出力します. + +# トリガー用コマンド. +# デフォルトは debugcore +command: debugcore + +# [top commands] +# help - show this usage. +# bbs - show BulletinBoard info. +# socket - show internal sockets. +# module - show module info. + +# [sub commands] +# help: +# bbs: +# keys - show keys in BulletinBoard. +# socket: +# help - show this usage. +# list - show installed socket. +# get - show socket in detail. +# uninstall - uninstall detached socket. +# module: +# help - show this usage. +# summary - show module summary. +# list - show module list in detail. +# dep - show module dependency. + +=end tiarra-doc + +=cut diff -urN /non-existant-dir/module/Debug/RawLog.pm tiarra-20080510/module/Debug/RawLog.pm --- /non-existant-dir/module/Debug/RawLog.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/Debug/RawLog.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,96 @@ +# -*- cperl -*- +# ----------------------------------------------------------------------------- +# $Id: RawLog.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +# copyright (C) 2003 Topia . all rights reserved. + +package Debug::RawLog; +use strict; +use warnings; +use base qw(Module); +use Module::Use qw(Tools::DateConvert); +use Tools::DateConvert; +use Mask; +use Multicast; + +sub message_io_hook { + my ($this,$message,$io,$type) = @_; + + my $prefix = 'RAWLOG: '; + my $conf_entry = 'enable-'; + + $prefix .= do { + if ($type eq 'in') { + '<<'; + } elsif ($type eq 'out') { + '>>'; + } else { + '--'; + } + }; + + $prefix .= do { + if ($io->server_p()) { + 'SERVER(' . $io->network_name() . ') '; + } elsif ($io->client_p()) { + 'CLIENT(' . ($io->option('logname') || $io->fullname()) . ') '; + } else { + '------ '; + } + }; + + $conf_entry .= do { + if ($io->server_p()) { + 'server' + } elsif ($io->client_p()) { + 'client'; + } + }; + + $conf_entry .= '-' . $type; + + # break with last + while (1) { + last if (($message->command =~ /^P[IO]NG$/) && + $this->config->ignore_ping); + last unless ($this->config->get($conf_entry)); + my $msg = $message->clone; + if ($this->config->resolve_numeric && $message->command =~ /^\d{3}$/) { + $msg->command( + (NumericReply::fetch_name($message->command)||'undef'). + '('.$message->command.')'); + } + ::printmsg($prefix . $msg->serialize()); + last; + } + + return $message; +} + +1; + +=pod +info: 標準出力にクライアントやサーバとの通信をダンプする。 +default: off + +# 0 または省略で表示しない。 1 で表示する。 +# クライアントオプションの logname によって、ダンプに使う名前を指定できます。 + +# サーバからの入力 +enable-server-in: 1 + +# サーバへの出力 +enable-server-out: 1 + +# クライアントからの入力 +enable-client-in: 0 + +# クライアントへの出力 +enable-client-out: 0 + +# PING/PONG を無視する +ignore-ping: 1 + +# NumericReply の名前を解決して表示する(ちゃんとした dump では無くなります) +resolve-numeric: 1 +=cut diff -urN /non-existant-dir/module/Log/Channel.pm tiarra-20080510/module/Log/Channel.pm --- /non-existant-dir/module/Log/Channel.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/Log/Channel.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,388 @@ +# ----------------------------------------------------------------------------- +# $Id: Channel.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +package Log::Channel; +use strict; +use warnings; +use IO::File; +use File::Spec; +use Tiarra::Encoding; +use base qw(Module); +use Module::Use qw(Tools::DateConvert Log::Logger Log::Writer); +use Tools::DateConvert; +use Log::Logger; +use Log::Writer; +use ControlPort; +use Mask; +use Multicast; + +sub new { + my $class = shift; + my $this = $class->SUPER::new(@_); + $this->{channels} = []; # 要素は[ディレクトリ名,マスク] + $this->{matching_cache} = {}; # <チャンネル名,ファイル名> + $this->{writer_cache} = {}; # <チャンネル名,Log::Writer> + $this->{sync_command} = do { + my $sync = $this->config->sync; + if (defined $sync) { + uc $sync; + } + else { + undef; + } + }; + $this->{distinguish_myself} = do { + my $conf_val = $this->config->distinguish_myself; + if (defined $conf_val) { + $conf_val; + } + else { + 1; + } + }; + $this->{logger} = + Log::Logger->new( + sub { + $this->_search_and_write(@_); + }, + $this, + 'S_PRIVMSG','C_PRIVMSG','S_NOTICE','C_NOTICE'); + + $this->_init; +} + +sub _init { + my $this = shift; + foreach ($this->config->channel('all')) { + my ($dirname,$mask) = split /\s+/; + if (!defined($dirname) || $dirname eq '' || + !defined($mask) || $mask eq '') { + die 'Illegal definition in '.__PACKAGE__."/channel : $_\n"; + } + push @{$this->{channels}},[$dirname,$mask]; + } + + $this; +} + +sub sync { + my $this = shift; + $this->flush_all_file_handles; + RunLoop->shared->notify_msg("Channel logs synchronized."); +} + +sub control_requested { + my ($this,$request) = @_; + if ($request->ID eq 'synchronize') { + $this->sync; + ControlPort::Reply->new(204,'No Content'); + } + else { + die "Log::Channel received control request of unsupported ID ".$request->ID."\n"; + } +} + +sub message_arrived { + my ($this,$message,$sender) = @_; + + # syncは有効で、クライアントから受け取ったメッセージであり、かつ今回のコマンドがsyncに一致しているか？ + if (defined $this->{sync_command} && + $sender->isa('IrcIO::Client') && + $message->command eq $this->{sync_command}) { + # 開いているファイルを全てflush。 + # 他のモジュールも同じコマンドでsyncするかも知れないので、 + # do-not-send-to-servers => 1は設定するが + # メッセージ自体は破棄してしまわない。 + $this->sync; + $message->remark('do-not-send-to-servers',1); + return $message; + } + + # __PACKAGE__/commandにマッチするか？ + if (Mask::match(lc($this->config->command || '*'),lc($message->command))) { + $this->{logger}->log($message,$sender); + } + + $message; +} + +*S_PRIVMSG = \&PRIVMSG_or_NOTICE; +*S_NOTICE = \&PRIVMSG_or_NOTICE; +*C_PRIVMSG = \&PRIVMSG_or_NOTICE; +*C_NOTICE = \&PRIVMSG_or_NOTICE; +sub PRIVMSG_or_NOTICE { + my ($this,$msg,$sender) = @_; + my $target = Multicast::detatch($msg->param(0)); + my $is_priv = Multicast::nick_p($target); + my $cmd = $msg->command; + + my $line = do { + if ($is_priv) { + # privの時は自分と相手を必ず区別する。 + if ($sender->isa('IrcIO::Client')) { + sprintf( + $cmd eq 'PRIVMSG' ? '>%s< %s' : ')%s( %s', + $msg->param(0), + $msg->param(1)); + } + else { + sprintf( + $cmd eq 'PRIVMSG' ? '-%s- %s' : '=%s= %s', + $msg->nick || $sender->current_nick, + $msg->param(1)); + } + } + else { + my $format = do { + if ($this->{distinguish_myself} && $sender->isa('IrcIO::Client')) { + $cmd eq 'PRIVMSG' ? '>%s:%s< %s' : ')%s:%s( %s'; + } + else { + $cmd eq 'PRIVMSG' ? '<%s:%s> %s' : '(%s:%s) %s'; + } + }; + my $nick = do { + if ($sender->isa('IrcIO::Client')) { + RunLoop->shared_loop->network( + (Multicast::detatch($msg->param(0)))[1]) + ->current_nick; + } + else { + $msg->nick || $sender->current_nick; + } + }; + sprintf $format,$msg->param(0),$nick,$msg->param(1); + } + }; + + [$is_priv ? 'priv' : $msg->param(0),$line]; +} + +sub _channel_match { + # 指定されたチャンネル名にマッチするログ保存ファイルのパターンを定義から探す。 + # 一つもマッチしなければundefを返す。 + # このメソッドは検索結果を$this->{matching_cache}に保存して、後に再利用する。 + my ($this,$channel) = @_; + + my $cached = $this->{matching_cache}->{$channel}; + if (defined $cached) { + if ($cached eq '') { + # マッチするエントリは存在しない、という結果がキャッシュされている。 + return undef; + } + else { + return $cached; + } + } + + foreach my $ch (@{$this->{channels}}) { + if (Mask::match($ch->[1],$channel)) { + # マッチした。 + my $fname_format = $this->config->filename || '%Y.%m.%d.txt'; + my $fpath_format = $ch->[0]."/$fname_format"; + + $this->{matching_cache}->{$channel} = $fpath_format; + return $fpath_format; + } + } + $this->{matching_cache}->{$channel} = ''; + undef; +} + +sub _search_and_write { + my ($this,$channel,$line) = @_; + my $dirname = $this->_channel_match($channel); + if (defined $dirname) { + $this->_write($channel,$dirname,$line); + } +} + +sub _write { + # 指定されたログファイルにヘッダ付きで追記する。 + # ディレクトリ名の日付のマクロは置換される。 + my ($this,$channel,$abstract_fpath,$line) = @_; + my $concrete_fpath = do { + my $basedir = $this->config->directory; + if (defined $basedir) { + Tools::DateConvert::replace("$basedir/$abstract_fpath"); + } + else { + Tools::DateConvert::replace($abstract_fpath); + } + }; + my $header = Tools::DateConvert::replace( + $this->config->header || '%H:%M' + ); + my $always_flush = do { + if ($this->config->keep_file_open) { + if ($this->config->always_flush) { + 1; + } else { + 0; + } + } else { + 1; + } + }; + # ファイルに追記 + my $make_writer = sub { + Log::Writer->shared_writer->find_object( + $concrete_fpath, + always_flush => $always_flush, + file_mode_oct => $this->config->mode, + dir_mode_oct => $this->config->dir_mode, + ); + }; + my $writer = sub { + # キャッシュは有効か？ + if ($this->config->keep_file_open) { + # このチャンネルはキャッシュされているか？ + my $cached_elem = $this->{writer_cache}->{$channel}; + if (defined $cached_elem) { + # キャッシュされたファイルパスは今回のファイルと一致するか？ + if ($cached_elem->uri eq $concrete_fpath) { + # このファイルハンドルを再利用して良い。 + #print "$concrete_fpath: RECYCLED\n"; + return $cached_elem; + } + else { + # ファイル名が違う。日付が変わった等の場合。 + # 古いファイルハンドルを閉じる。 + #print "$concrete_fpath: recached\n"; + eval { + $cached_elem->flush; + $cached_elem->unregister; + }; + # 新たなファイルハンドルを生成。 + $cached_elem = $make_writer->(); + if (defined $cached_elem) { + $cached_elem->register; + } + return $cached_elem; + } + } + else { + # キャッシュされていないので、ファイルハンドルを作ってキャッシュ。 + #print "$concrete_fpath: *cached*\n"; + my $cached_elem = + $this->{writer_cache}->{$channel} = + $make_writer->(); + if (defined $cached_elem) { + $cached_elem->register; + } + return $cached_elem; + } + } + else { + # キャッシュ無効。 + return $make_writer->(); + } + }->(); + if (defined $writer) { + $writer->reserve( + Tiarra::Encoding->new("$header $line\n",'utf8')->conv( + $this->config->charset || 'jis')); + } else { + # XXX: do warn with properly frequency + #RunLoop->shared_loop->notify_warn("can't write to $concrete_fpath: ". + # "$header $line"); + } +} + +sub flush_all_file_handles { + my $this = shift; + foreach my $cached_elem (values %{$this->{writer_cache}}) { + eval { + $cached_elem->flush; + }; + } +} + +sub destruct { + my $this = shift; + # 開いている全てのLog::Writerを閉じて、キャッシュを空にする。 + foreach my $cached_elem (values %{$this->{writer_cache}}) { + eval { + $cached_elem->flush; + $cached_elem->unregister; + }; + } + %{$this->{writer_cache}} = (); +} + +1; + +=pod +info: チャンネルやprivのログを取るモジュール。 +default: off +section: important + +# Log系のモジュールでは、以下のように日付や時刻の置換が行なわれる。 +# %% : % +# %Y : 年(4桁) +# %m : 月(2桁) +# %d : 日(2桁) +# %H : 時間(2桁) +# %M : 分(2桁) +# %S : 秒(2桁) + +# ログを保存するディレクトリ。Tiarraが起動した位置からの相対パス。~指定は使えない。 +directory: log + +# ログファイルの文字コード。省略されたらjis。 +charset: utf8 + +# 各行のヘッダのフォーマット。省略されたら'%H:%M'。 +header: %H:%M:%S + +# ファイル名のフォーマット。省略されたら'%Y.%m.%d.txt' +filename: %Y.%m.%d.txt + +# ログファイルのモード(8進数)。省略されたら600 +mode: 600 + +# ログディレクトリのモード(8進数)。省略されたら700 +dir-mode: 700 + +# ログを取るコマンドを表すマスク。省略されたら記録出来るだけのコマンドを記録する。 +command: privmsg,join,part,kick,invite,mode,nick,quit,kill,topic,notice + +# PRIVMSGとNOTICEを記録する際に、自分の発言と他人の発言でフォーマットを変えるかどうか。1/0。デフォルトで1。 +distinguish-myself: 1 + +# 各ログファイルを開きっぱなしにするかどうか。 +# このオプションは多くの場合、ディスクアクセスを抑えて効率良くログを保存しますが +# ログを記録すべき全てのファイルを開いたままにするので、50や100のチャンネルを +# 別々のファイルにログを取るような場合には使うべきではありません。 +# 万一 fd があふれた場合、クライアントから(またはサーバへ)接続できない・ +# 新たなモジュールをロードできない・ログが全然できないなどの症状が起こる可能性が +# あります。limit の詳細については OS 等のドキュメントを参照してください。 +-keep-file-open: 1 + +# keep-file-open 時に各行ごとに flush するかどうか。 +# open/close の負荷は気になるが、ログは失いたくない人向け。 +# keep-file-open が有効でないなら無視され(1になり)ます。 +-always-flush: 0 + +# keep-file-openを有効にした場合、発言の度にログファイルに追記するのではなく +# 一定の分量が溜まってから書き込まれる。そのため、ファイルを開いても +# 最近の発言はまだ書き込まれていない可能性がある。 +# syncを設定すると、即座にログをディスクに書き込むためのコマンドが追加される。 +# 省略された場合はコマンドを追加しない。 +sync: sync + +# 各チャンネルの設定。チャンネル名の部分はマスクである。 +# 個人宛てに送られたPRIVMSGやNOTICEはチャンネル名"priv"として検索される。 +# 記述された順序で検索されるので、全てのチャンネルにマッチする"*"などは最後に書かなければならない。 +# 指定されたディレクトリが存在しなかったら、Log::Channelはそれを勝手に作る。 +# フォーマットは次の通り。 +# channel: <ディレクトリ名> (<チャンネル名> / 'priv') +# 例: +# filename: %Y.%m.%d.txt +# channel: IRCDanwasitu #IRC談話室@ircnet +# channel: others * +# この例では、#IRC談話室@ircnetのログはIRCDanwasitu/%Y.%m.%d.txtに、 +# それ以外(privも含む)のログはothers/%Y.%m.%d.txtに保存される。 +channel: priv priv +channel: others * +=cut diff -urN /non-existant-dir/module/Log/ChannelList.pm tiarra-20080510/module/Log/ChannelList.pm --- /non-existant-dir/module/Log/ChannelList.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/Log/ChannelList.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,192 @@ +# ----------------------------------------------------------------------------- +# $Id: ChannelList.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +# copyright (C) 2004 Topia . all rights reserved. +package Log::ChannelList; +use strict; +use warnings; +use base qw(Module); +use Template; +use Mask; +use NumericReply; +use RunLoop; +use IO::File; +use Tiarra::Encoding; +use Tools::DateConvert; +use Module::Use qw(Tools::DateConvert); + +sub new { + my $class = shift; + my $this = $class->SUPER::new(@_); + $this->{networks} = []; + $this->{unijp} = Tiarra::Encoding->new; + + $this->_init; +} + +sub _init { + my $this = shift; + + foreach ($this->config->networks('all')) { + my ($filename,$mask,$block) = split /\s+/; + if (!defined($filename) || $filename eq '' || + !defined($mask) || $mask eq '' || + !defined($block) || $block eq '') { + die "Illegal definition in __PACKAGE__/networks : $_\n"; + } + push @{$this->{networks}},[$filename,$mask,$block]; + } + + return $this; +} + +sub message_io_hook { + my ($this,$msg,$io,$type) = @_; + + if ($io->isa('IrcIO::Server')) { + if ($type eq 'out' && + $msg->command eq 'LIST' && + !defined $msg->param(0)) { + $io->remark('fetching-list', 1); + my $network = $this->_search_network($io->network_name); + if (defined $network) { + my $config = $this->config->get($network->[2], 'block'); + if (defined $config && + defined $config->template && $config->template ne '') { + my $template = Template->new($config->template); + if (defined $template) { + $io->remark(__PACKAGE__."/template", $template); + $io->remark(__PACKAGE__."/config", $config); + } + } + } + } elsif ($type eq 'in' && + $msg->command eq RPL_LIST) { + my $template = $io->remark(__PACKAGE__."/template"); + my $config = $io->remark(__PACKAGE__."/config"); + if (defined $template) { + if (Mask::match_array([ + Mask::array_or_default( + '*', + $config->mask('all'), + )], $msg->param(1))) { + $template->channel->expand( + name => $this->_output_filter( + $config->charset, + $msg->param(1)), + users => $this->_output_filter( + $config->charset, + $msg->param(2)), + ); + if ($msg->param(2) ne '') { + $template->channel->topic->expand( + topic => $this->_output_filter( + $config->charset, + $msg->param(3)), + ); + $template->channel->topic->add; + } + $template->channel->add; + if (!defined $io->remark(__PACKAGE__."/starttime")) { + $io->remark(__PACKAGE__."/starttime", time()); + } + } + } + } elsif ($type eq 'in' && + $msg->command eq RPL_LISTEND) { + $io->remark('fetching-list', undef, 'delete'); + if ($io->remark(__PACKAGE__."/template")) { + my $network = $this->_search_network($io->network_name); + my $template = $io->remark(__PACKAGE__."/template"); + my $config = $io->remark(__PACKAGE__."/config"); + if (defined $network && defined $template) { + $template->expand( + fetch_starttime => + $this->_output_filter( + $config->charset, + Tools::DateConvert::replace( + $config->fetch_starttime || '', + $io->remark(__PACKAGE__."/starttime") || time, + )), + fetch_endtime => + $this->_output_filter( + $config->charset, + Tools::DateConvert::replace( + $config->fetch_endtime || '', + )), + ); + my $mode = do { + my $mode_conf = $config->mode; + if (defined $mode_conf) { + oct('0'.$mode_conf); + } + else { + 0600; + } + }; + my $fh = IO::File->new($network->[0], O_CREAT | O_WRONLY, $mode); + $fh->print($template->str); + $fh->truncate($fh->tell); + $fh->close; + } + $io->remark(__PACKAGE__."/template", undef, 'delete'); + $io->remark(__PACKAGE__."/config", undef, 'delete'); + $io->remark(__PACKAGE__."/starttime", undef, 'delete'); + } + } + } + return $msg; +} + +sub _output_filter { + my ($this, $charset, $str) = @_; + + $str =~ s/>/>/g; + $str =~ s/{unijp}->set($str)->$charset; +} + +sub _search_network { + my ($this, $network_name) = @_; + + foreach my $network (@{$this->{networks}}) { + if (Mask::match($network->[1], $network_name)) { + return $network; + } + } + return undef; +} + +1; + +=pod +info: チャンネルリストをテンプレートに沿って HTML 化します。 +default: off + +# list コマンドが実行された際に動作します。 + +# 出力したいファイル名、ネットワーク名、使う設定のブロックを指定します。。 +networks: ircnet.html ircnet ircnet + + +ircnet { + # テンプレートファイルを指定します。 + template: channellist.html.tmpl + + # 出力とテンプレートファイルの文字コードを指定します。 + charset: euc + + # 取得を開始/終了した時刻のフォーマットを指定します。 + fetch-starttime: %Y年%m月%d日 %H時%M分(日本時間) + fetch-endtime: %Y年%m月%d日 %H時%M分(日本時間) + + # 表示するチャンネルの mask を指定します。 + mask: * + mask: -re:^\&(AUTH|SERVICES|LOCAL|HASH|SERVERS|NUMERICS|CHANNEL|KILLS|NOTICES|ERRORS) + + # 出力するファイルのモードを指定します。 + mode: 644 +} +=cut diff -urN /non-existant-dir/module/Log/Logger.pm tiarra-20080510/module/Log/Logger.pm --- /non-existant-dir/module/Log/Logger.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/Log/Logger.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,268 @@ +# ----------------------------------------------------------------------------- +# $Id: Logger.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +package Log::Logger; +use strict; +use warnings; +use Multicast; + +our $MARKER = { + myself => { + PRIVMSG => ['>','<'], + NOTICE => [')','('], + }, + priv => { + PRIVMSG => ['-','-'], + NOTICE => ['=','='], + }, + channel => { + PRIVMSG => ['<','>'], + NOTICE => ['(',')'], + }, +}; + +sub new { + my ($class,$enstringed_callback,$exception_object,@exceptions) = @_; + # enstringed_callback: + # メッセージをログ文字列化した時に呼ばれる関数。CODE型。 + # 引数を二つ取り、一つ目はチャンネル名、二つ目はログ文字列。 + # exception_object: + # exceptionsで指定されたメソッドを呼ぶとき、どのオブジェクトで呼ぶか。 + # exceptions: + # 特定のメッセージのログ文字列化をオーバーライドする + # 'S_PRIVMSG'等。 + # 引数は(Tiarra::IRC::Message,IrcIO)、戻り値は[チャンネル名,ログ文字列]の配列 + my $this = { + enstringed => $enstringed_callback, + exception_object => $exception_object, + exceptions => do { + my %hash = map { $_ => 1 } @exceptions; + \%hash; + }, + }; + bless $this,$class; +} + +sub log { + my ($this,$msg,$sender) = @_; + my $prefix = do { + if ($sender->isa('IrcIO::Server')) { + 'S'; + } + elsif ($sender->isa('IrcIO::Client')) { + 'C'; + } + }; + my $method_name = "${prefix}_".$msg->command; + my @results; + # このメソッドはexceptionsで定義されているか？ + if (defined $this->{exceptions}->{$method_name}) { + eval { + @results = $this->{exception_object}->$method_name($msg,$sender); + }; if ($@) { + RunLoop->shared->notify_error($@); + } + } + else { + # このクラスにメソッドはあるか？ + if ($this->can($method_name)) { + eval { + @results = $this->$method_name($msg,$sender); + }; if ($@) { + RunLoop->shared->notify_error($@); + } + } + } + + foreach (@results) { + $this->{enstringed}->($_->[0],$_->[1]); + } +} + +sub S_JOIN { + my ($this,$msg,$sender) = @_; + + $msg->param(0) =~ m/^([^\x07]+)(?:\x07(.*))?/; + my ($ch_name,$mode) = ($1,(defined $2 ? $2 : '')); + $mode =~ tr/ov/@+/; + + [$msg->param(0), + sprintf('+ %s%s (%s) to %s', + $mode,$msg->nick,$msg->prefix,$msg->param(0))]; +} + +sub S_PART { + my ($this,$msg,$sender) = @_; + if (defined $msg->param(1)) { + [$msg->param(0), + sprintf('- %s from %s (%s)', + $msg->nick,$msg->param(0),$msg->param(1))]; + } else { + [$msg->param(0), + sprintf('- %s from %s', + $msg->nick,$msg->param(0))]; + } +} + +sub S_KICK { + my ($this,$msg,$sender) = @_; + # RFC2812には、「サーバはクライアントに複数のチャンネルやユーザのKICKメッセージを + # 送っては「いけません」。これは、古いクライアントソフトウェアとの下位互換のためです。」とある。 + [$msg->param(0), + sprintf('- %s by %s from %s (%s)', + $msg->param(1),$msg->nick,$msg->param(0),$msg->param(2))]; +} + +sub S_INVITE { + my ($this,$msg,$sender) = @_; + [$msg->param(1), + sprintf 'Invited by %s: %s',$msg->nick,$msg->param(1)]; +} + +sub S_MODE { + my ($this,$msg,$sender) = @_; + [$msg->param(0), + sprintf('Mode by %s: %s %s', + $msg->nick, + $msg->param(0), + join(' ',@{$msg->params}[1 .. ($msg->n_params - 1)]))]; +} + +sub S_NICK { + my ($this,$msg,$sender) = @_; + my $network_name = $sender->network_name; + my $line = do { + sprintf( + do { + if ($msg->param(0) eq $sender->current_nick) { + 'My nick is changed (%s -> %s)'; + } + else { + '%s -> %s'; + } + }, + $msg->nick, + $msg->param(0)); + }; + my @result; + if( my $ch_short_list = $msg->remark('affected-channels') ){ + foreach my $ch_name (@$ch_short_list) { + push @result,[Multicast::attach($ch_name,$network_name), + $line]; + } + } + @result; +} + +{ +no warnings 'once'; +*S_KILL = \&S_QUIT; +} + +sub S_QUIT { + my ($this,$msg,$sender) = @_; + my $network_name = $sender->network_name; + my @result; + if( my $ch_short_list = $msg->remark('affected-channels') ){ + foreach my $ch_name (@$ch_short_list) { + push @result,[Multicast::attach($ch_name,$network_name), + sprintf '! %s (%s)',$msg->nick,$msg->param(0)]; + } + } + @result; +} + +sub S_TOPIC { + my ($this,$msg,$sender) = @_; + [$msg->param(0), + sprintf('Topic of channel %s by %s: %s', + $msg->param(0), + $msg->nick, + $msg->param(1))]; +} + +{ +no warnings 'once'; +*S_PRIVMSG = \&PRIVMSG_or_NOTICE; +*S_NOTICE = \&PRIVMSG_or_NOTICE; +*C_PRIVMSG = \&PRIVMSG_or_NOTICE; +*C_NOTICE = \&PRIVMSG_or_NOTICE; +} + +sub PRIVMSG_or_NOTICE +{ + my ($this,$msg,$sender) = @_; + my $line = $this->_build_message($msg, $sender); + my $channel = $line->{is_priv} ? 'priv' : $line->{ch_long}; + [$channel, $line->{formatted}]; +} + +# ----------------------------------------------------------------------------- +# $hashref = $obj->_build_message($msg, $sender). +# Log/Channel から拝借. +# ただ +# - distinguish_myself が省かれている. +# - PRIVでも相手の名前がchannel名として使われる. +# - 好きにformat出来るように解析した情報をHASHREFで返している. +# という点で変更されている. +# +sub _build_message +{ + my ($this, $msg, $sender) = @_; + + my $raw_target = $msg->param(0); + my ($target,$netname,$_explicit) = Multicast::detatch( $raw_target ); + my $is_priv = Multicast::nick_p($target); + my $cmd = $msg->command; + + my $marker_id; + if( $sender->isa('IrcIO::Client') ) + { + $marker_id = 'myself'; + }elsif( $is_priv ) + { + $marker_id = 'priv'; + }else + { + $marker_id = 'channel'; + } + my $marker = $MARKER->{$marker_id}{$cmd}; + $marker or die "no marker for $marker_id/$cmd"; + + my ($speaker, $ch_short); + if( $sender->isa('IrcIO::Client') ) + { + # 自分の発言. + $speaker = RunLoop->shared_loop->network( $netname )->current_nick; + $ch_short = $target; + }else + { + # 相手の. + $speaker = $msg->nick || $sender->current_nick; + $ch_short = $is_priv ? $speaker : $target; + } + my $ch_long = Multicast::attach($ch_short, $netname); + + my $line = sprintf( + '%s%s:%s%s %s', + $marker->[0], + $ch_long, + $speaker, + $marker->[1], + $msg->param(1), + ); + + +{ + marker_id => $marker_id, # 'myself' / 'priv' / 'channel' + is_priv => $is_priv, + marker => $marker, # ['<', '>'], etc. + speaker => $speaker, + ch_long => $ch_long, + ch_short => $ch_short, + netname => $netname, + msg => $msg->param(1), + formatted => $line, + }; +} + +1; diff -urN /non-existant-dir/module/Log/Raw.pm tiarra-20080510/module/Log/Raw.pm --- /non-existant-dir/module/Log/Raw.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/Log/Raw.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,330 @@ +# ----------------------------------------------------------------------------- +# $Id: Raw.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +package Log::Raw; +use strict; +use warnings; +use IO::File; +use File::Spec; +use Tiarra::Encoding; +use base qw(Module); +use Module::Use qw(Tools::DateConvert Log::Writer); +use Tools::DateConvert; +use Log::Writer; +use ControlPort; +use Mask; + +sub new { + my $class = shift; + my $this = $class->SUPER::new(@_); + $this->{matching_cache} = {}; # + $this->{writer_cache} = {}; # + $this->{sync_command} = do { + my $sync = $this->config->sync; + if (defined $sync) { + uc $sync; + } + else { + undef; + } + }; + $this; +} + +sub sync { + my $this = shift; + $this->flush_all_file_handles; + RunLoop->shared->notify_msg("Raw logs synchronized."); +} + +sub control_requested { + my ($this,$request) = @_; + if ($request->ID eq 'synchronize') { + $this->sync; + ControlPort::Reply->new(204,'No Content'); + } + else { + die ref($this)." received control request of unsupported ID ".$request->ID."\n"; + } +} + +sub message_arrived { + my ($this,$message,$sender) = @_; + + # syncは有効で、クライアントから受け取ったメッセージであり、かつ今回のコマンドがsyncに一致しているか？ + if (defined $this->{sync_command} && + $sender->isa('IrcIO::Client') && + $message->command eq $this->{sync_command}) { + # 開いているファイルを全てflush。 + # 他のモジュールも同じコマンドでsyncするかも知れないので、 + # do-not-send-to-servers => 1は設定するが + # メッセージ自体は破棄してしまわない。 + $this->sync; + $message->remark('do-not-send-to-servers',1); + return $message; + } + $message; +} + +sub message_io_hook { + my ($this,$message,$io,$type) = @_; + + # break with last + while (1) { + last unless $io->server_p; + last unless Mask::match_deep([Mask::array_or_all( + $this->config->command('all'))], $message->command); + my $msg = $message->clone; + if ($this->config->resolve_numeric && $message->command =~ /^\d{3}$/) { + $msg->command( + (NumericReply::fetch_name($message->command)||'undef'). + '('.$message->command.')'); + } + my $server = $io->network_name; + my $dirname = $this->_server_match($server); + if (defined $dirname) { + my $prefix = sprintf '(%s/%s) ', $server, do { + if ($type eq 'in') { + 'recv'; + } elsif ($type eq 'out') { + 'send'; + } else { + '----'; + } + }; + + my $charset = do { + if ($msg->have_raw_params) { + $msg->encoding_params('binary'); + 'binary'; + } elsif ($io->can('out_encoding')) { + $io->out_encoding; + } else { + $this->config->charset; + } + }; + $this->_write($server, $dirname, $msg->time, $prefix . + $msg->serialize($charset)); + } + last; + } + + return $message; +} + +sub _server_match { + my ($this,$server) = @_; + + my $cached = $this->{matching_cache}->{$server}; + if (defined $cached) { + if ($cached eq '') { + # cache of not found + return undef; + } + else { + return $cached; + } + } + + foreach my $line ($this->config->server('all')) { + my ($name, $mask) = split /\s+/, $line, 2; + if (Mask::match($mask,$server)) { + # マッチした。 + my $fname_format = $this->config->filename || '%Y.%m.%d.txt'; + my $fpath_format = $name."/$fname_format"; + + $this->{matching_cache}->{$server} = $fpath_format; + return $fpath_format; + } + } + $this->{matching_cache}->{$server} = ''; + undef; +} + +sub _write { + # 指定されたログファイルにヘッダ付きで追記する。 + # ディレクトリ名の日付のマクロは置換される。 + my ($this,$channel,$abstract_fpath,$time,$line) = @_; + my $concrete_fpath = do { + my $basedir = $this->config->directory; + if (defined $basedir) { + Tools::DateConvert::replace("$basedir/$abstract_fpath", $time); + } + else { + Tools::DateConvert::replace($abstract_fpath, $time); + } + }; + my $header = Tools::DateConvert::replace( + $this->config->header || '%H:%M', + $time, + ); + my $always_flush = do { + if ($this->config->keep_file_open) { + if ($this->config->always_flush) { + 1; + } else { + 0; + } + } else { + 1; + } + }; + # ファイルに追記 + my $make_writer = sub { + Log::Writer->shared_writer->find_object( + $concrete_fpath, + always_flush => $always_flush, + file_mode_oct => $this->config->mode, + dir_mode_oct => $this->config->dir_mode, + ); + }; + my $writer = sub { + # キャッシュは有効か？ + if ($this->config->keep_file_open) { + # このチャンネルはキャッシュされているか？ + my $cached_elem = $this->{writer_cache}->{$channel}; + if (defined $cached_elem) { + # キャッシュされたファイルパスは今回のファイルと一致するか？ + if ($cached_elem->uri eq $concrete_fpath) { + # このファイルハンドルを再利用して良い。 + #print "$concrete_fpath: RECYCLED\n"; + return $cached_elem; + } + else { + # ファイル名が違う。日付が変わった等の場合。 + # 古いファイルハンドルを閉じる。 + #print "$concrete_fpath: recached\n"; + eval { + $cached_elem->flush; + $cached_elem->unregister; + }; + # 新たなファイルハンドルを生成。 + $cached_elem = $make_writer->(); + if (defined $cached_elem) { + $cached_elem->register; + } + return $cached_elem; + } + } + else { + # キャッシュされていないので、ファイルハンドルを作ってキャッシュ。 + #print "$concrete_fpath: *cached*\n"; + my $cached_elem = + $this->{writer_cache}->{$channel} = + $make_writer->(); + if (defined $cached_elem) { + $cached_elem->register; + } + return $cached_elem; + } + } + else { + # キャッシュ無効。 + return $make_writer->(); + } + }->(); + if (defined $writer) { + $writer->reserve("$header $line\n"); + } else { + # XXX: do warn with properly frequency + #RunLoop->shared_loop->notify_warn("can't write to $concrete_fpath: ". + # "$header $line"); + } +} + +sub flush_all_file_handles { + my $this = shift; + foreach my $cached_elem (values %{$this->{writer_cache}}) { + eval { + $cached_elem->flush; + }; + } +} + +sub destruct { + my $this = shift; + # 開いている全てのLog::Writerを閉じて、キャッシュを空にする。 + foreach my $cached_elem (values %{$this->{writer_cache}}) { + eval { + $cached_elem->flush; + $cached_elem->unregister; + }; + } + %{$this->{writer_cache}} = (); +} + +1; + +=pod +info: サーバとの生の通信を保存する +default: off + +# Log系のモジュールでは、以下のように日付や時刻の置換が行なわれる。 +# %% : % +# %Y : 年(4桁) +# %m : 月(2桁) +# %d : 日(2桁) +# %H : 時間(2桁) +# %M : 分(2桁) +# %S : 秒(2桁) + +# ログを保存するディレクトリ。Tiarraが起動した位置からの相対パス。~指定は使えない。 +directory: rawlog + +# 各行のヘッダのフォーマット。省略されたら'%H:%M'。 +header: %H:%M:%S + +# ファイル名のフォーマット。省略されたら'%Y.%m.%d.txt' +filename: %Y-%m-%d.txt + +# ログファイルのモード(8進数)。省略されたら600 +mode: 600 + +# ログディレクトリのモード(8進数)。省略されたら700 +dir-mode: 700 + +# 使っている文字コードがよくわからなかったときの文字コード。省略されたらutf8。 +# たぶんこの指定が生きることはないと思いますが……。 +charset: jis + +# NumericReply の名前を解決して表示する(ちゃんとした dump では無くなります) +resolve-numeric: 1 + +# ログを取るコマンドを表すマスク。省略されたら記録出来るだけのコマンドを記録する。 +command: *,-ping,-pong + +# 各ログファイルを開きっぱなしにするかどうか。 +# このオプションは多くの場合、ディスクアクセスを抑えて効率良くログを保存しますが +# ログを記録すべき全てのファイルを開いたままにするので、50や100のチャンネルを +# 別々のファイルにログを取るような場合には使うべきではありません。 +# 万一 fd があふれた場合、クライアントから(またはサーバへ)接続できない・ +# 新たなモジュールをロードできない・ログが全然できないなどの症状が起こる可能性が +# あります。limit の詳細については OS 等のドキュメントを参照してください。 +-keep-file-open: 1 + +# keep-file-open 時に各行ごとに flush するかどうか。 +# open/close の負荷は気になるが、ログは失いたくない人向け。 +# keep-file-open が有効でないなら無視され(1になり)ます。 +-always-flush: 0 + +# keep-file-openを有効にした場合、発言の度にログファイルに追記するのではなく +# 一定の分量が溜まってから書き込まれる。そのため、ファイルを開いても +# 最近の発言はまだ書き込まれていない可能性がある。 +# syncを設定すると、即座にログをディスクに書き込むためのコマンドが追加される。 +# 省略された場合はコマンドを追加しない。 +sync: sync + +# 各サーバの設定。サーバ名の部分はマスクである。 +# 記述された順序で検索されるので、全てのサーバにマッチする"*"などは最後に書かなければならない。 +# 指定されたディレクトリが存在しなかったら、勝手に作られる。 +# フォーマットは次の通り。 +# channel: <ディレクトリ名> <サーバ名マスク> +# 例: +# filename: %Y-%m-%d.txt +# server: ircnet ircnet +# server: others * +# この例では、ircnetのログはircnet/%Y.%m.%d.txtに、 +# それ以外のログはothers/%Y.%m.%d.txtに保存される。 +server: ircnet ircnet +server: others * +=cut diff -urN /non-existant-dir/module/Log/Recent.pm tiarra-20080510/module/Log/Recent.pm --- /non-existant-dir/module/Log/Recent.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/Log/Recent.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,209 @@ +# ----------------------------------------------------------------------------- +# $Id: Recent.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +package Log::Recent; +use strict; +use warnings; +use base qw(Module); +use Module::Use qw(Tools::DateConvert Log::Logger); +use Tools::DateConvert; +use Log::Logger; +use Mask; + +sub new { + my $class = shift; + my $this = $class->SUPER::new(@_); + # チャンネル管理の手間を省くため、チャンネルのログはChannelInfoのremarksに保存する。 + # privのログだけこのクラスで保持。 + $this->{priv_log} = []; # 中身は単なる文字列 + $this->{logger} = + Log::Logger->new( + sub { + $this->log(@_); + }, + $this, + 'S_PRIVMSG','C_PRIVMSG','S_NOTICE','C_NOTICE'); + $this->{hook} = IrcIO::Client::Hook->new( + sub { + my ($hook, $client, $ch_name, $network, $ch) = @_; + # no-recent-logs オプションが指定されていれば何もしない + return if defined $client->option('no-recent-logs'); + # ログはあるか？ + my $vec = $ch->remarks('recent-log'); + if (defined $vec) { + foreach my $elem (@$vec) { + $client->send_message( + $this->construct_irc_message( + Prefix => RunLoop->shared_loop->sysmsg_prefix(qw(channel log)), + Command => 'NOTICE', + Params => [$ch_name,$elem->[1]])); + } + } + })->install('channel-info'); + $this; +} + +sub destruct { + my $this = shift; + $this->{hook} and $this->{hook}->uninstall; +} + +sub message_arrived { + my ($this,$msg,$sender) = @_; + # Log::Recent/commandにマッチするか？ + if (Mask::match(lc($this->config->command) || '*', lc($msg->command))) { + $this->{logger}->log($msg,$sender); + } + $msg; +} + +sub client_attached { + my ($this,$client) = @_; + # no-recent-logs オプションが指定されていれば何もしない + return if defined $client->option('no-recent-logs'); + # まずはpriv + my $local_nick = RunLoop->shared->current_nick; + foreach my $elem (@{$this->{priv_log}}) { + $client->send_message( + $this->construct_irc_message( + Prefix => RunLoop->shared_loop->sysmsg_prefix(qw(priv log)), + Command => 'NOTICE', + Params => [$local_nick,$elem->[1]])); # $elem->[0]は常に'priv' + } + + # 次に各チャンネル +# foreach my $network (values %{RunLoop->shared->networks}) { +# foreach my $ch (values %{$network->channels}) { +# # ログはあるか？ +# my $vec = $ch->remarks('recent-log'); +# if (defined $vec) { +# my $ch_name; +# foreach my $elem (@$vec) { +# $ch_name = +# RunLoop->shared->multi_server_mode_p ? +# $elem->[0] : $ch->name; +# $client->send_message( +# $this->construct_irc_message( +# Prefix => RunLoop->shared_loop->sysmsg_prefix(qw(channel log)), +# Command => 'NOTICE', +# Params => [$ch_name,$elem->[1]])); +# } +# } +# } +# } +} + +*S_PRIVMSG = \&PRIVMSG_or_NOTICE; +*S_NOTICE = \&PRIVMSG_or_NOTICE; +*C_PRIVMSG = \&PRIVMSG_or_NOTICE; +*C_NOTICE = \&PRIVMSG_or_NOTICE; +sub PRIVMSG_or_NOTICE { + my ($this,$msg,$sender) = @_; + my $target = Multicast::detach($msg->param(0)); + my $is_priv = Multicast::nick_p($target); + my $cmd = $msg->command; + + my $line = do { + if ($is_priv) { + if ($sender->isa('IrcIO::Client')) { + sprintf( + $cmd eq 'PRIVMSG' ? '>%s< %s' : ')%s( %s', + $msg->param(0), + $msg->param(1)); + } + else { + sprintf( + $cmd eq 'PRIVMSG' ? '-%s- %s' : '=%s= %s', + $msg->nick || $sender->current_nick, + $msg->param(1)); + } + } + else { + my $format = do { + if ($this->config->distinguish_myself && $sender->isa('IrcIO::Client')) { + $cmd eq 'PRIVMSG' ? '>%s< %s' : ')%s( %s'; + } + else { + $cmd eq 'PRIVMSG' ? '<%s> %s' : '(%s) %s'; + } + }; + my $nick = do { + if ($sender->isa('IrcIO::Client')) { + RunLoop->shared_loop->network( + (Multicast::detatch($msg->param(0)))[1]) + ->current_nick; + } + else { + $msg->nick || $sender->current_nick; + } + }; + sprintf $format,$nick,$msg->param(1); + } + }; + + [$is_priv ? 'priv' : $msg->param(0),$line]; +} + +sub log { + my ($this,$ch_full,$log_line) = @_; + my $vec = do { + if ($ch_full eq 'priv') { + # privは自分で保存 + $this->{priv_log}; + } + else { + # privでなければChannelInfoに'recent-log'として保存。 + my ($ch_short,$network_name) = Multicast::detach($ch_full); + my $network = RunLoop->shared->network($network_name); + if (!defined $network) { + RunLoop->shared->notify_warn("errorness network name: $network_name"); + return; + } + my $ch = $network->channel($ch_short); + if (!defined $ch) { + return; + } + my $log_vec = $ch->remarks('recent-log'); + if (!defined $log_vec) { + $log_vec = []; + $ch->remarks('recent-log',$log_vec); + } + $log_vec; + } + }; + + my $header = Tools::DateConvert::replace( + $this->config->header || '%H:%M' + ); + + # ログに追加 + # 要素は[チャンネル名,ログ行] + push @$vec,[$ch_full,"$header $log_line"]; + + # 溢れた分を消す + if (@$vec > $this->config->line) { + splice @$vec,0,(@$vec - $this->config->line); + } +} + +1; + +=pod +info: クライアントを接続した時に、保存しておいた最近のメッセージを送る。 +default: off +section: important + +# クライアントオプションの no-recent-logs が指定されていれば送信しません。 + +# 各行のヘッダのフォーマット。省略されたら'%H:%M'。 +header: %H:%M:%S + +# ログをチャンネル毎に何行まで保存するか。省略されたら10。 +line: 15 + +# PRIVMSGとNOTICEを記録する際に、自分の発言と他人の発言でフォーマットを変えるかどうか。1/0。デフォルトで1。 +distinguish-myself: 1 + +# どのメッセージを保存するか。省略されたら保存可能な全てのメッセージを保存する。 +command: privmsg,notice,topic,join,part,quit,kill +=cut diff -urN /non-existant-dir/module/Log/Writer/Base.pm tiarra-20080510/module/Log/Writer/Base.pm --- /non-existant-dir/module/Log/Writer/Base.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/Log/Writer/Base.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,229 @@ +# ----------------------------------------------------------------------------- +# $Id: Base.pm 3004 2007-12-10 12:45:39Z topia $ +# ----------------------------------------------------------------------------- +# copyright (C) 2004 Topia . all rights reserved. +package Log::Writer::Base; +use strict; +use warnings; +use Carp; +use Tiarra::Utils; +use base qw(Tiarra::Utils); + +# pure virtual function helper +sub not_implemented_error { + my ($class_or_this) = shift; + + die $class_or_this->name . '/' . (caller(1))[3] . + ': Please Implement this!'; +} + +# need override +sub new { + my ($class, $parent, $uri, %options) = @_; + + carp 'Cannot use undef on class, parent, and uri.' + if (grep {(!defined $_) ? 1 : ()} ($class, $parent, $uri)); + + my $this = { + refcount => 0, + parent => $parent, + + buffer => '', + always_flush => $class->first_defined($options{always_flush}, 1), + uri => $uri, + notify_cache => {}, + }; + + bless $this, $class; + $this; +} + +sub capability { + my ($class, $type, @args) = @_; + + # $type: + # - fallback: protocol support fallback + return 0; +} + +sub scheme { + my $class_or_this = shift; + + # please return scheme string(such as 'file') + ''; +} + +sub name { + my $class_or_this = shift; + + # please return protocol name + 'base (cannot use this directly)'; +} + +sub supported_schemes { + my $class_or_this = shift; + + # please return supported schemes + (); +} + +sub real_flush { + my $this = shift; + + $this->not_implemented_error; + 0; # please return bool(1: successful, 0: failed) +} + +sub real_destruct { + my ($this, $force) = @_; + + $this->not_implemented_error; + # optionally, you can warning if losing data. + # probably $force is useless, because usually does NOT call this + # on (!$this->can_remove && !$force). + # when $force is true, we will destroy instance even if return failed. + 0; # please return bool(1: successful, 0: failed) +} + +# base definition +sub first_defined { + shift->get_first_defined(@_); +} + +sub define_accessor { + # backward compat + shift->define_attr_accessor(0, @_); +} + +__PACKAGE__->define_attr_accessor(0, qw(buffer always_flush uri)); +__PACKAGE__->define_attr_getter(0, qw(refcount parent)); + +sub add_ref { ++(shift->{refcount}); } +sub release { --(shift->{refcount}); } +sub length { CORE::length(shift->buffer); } +sub clear { shift->buffer(''); } +sub has_data { shift->length > 0; } + +sub path { + my $this = shift; + + if (!defined $this->{path}) { + return undef if (!defined $this->{uri}); + my $scheme = $this->scheme; + return undef if (!defined $scheme); + ($this->{path} = $this->{uri}) =~ s|^\Q$scheme\E://||; + } + $this->{path}; +} + +sub register { + my $this = shift; + + $this->add_ref; + $this; +} + +sub unregister { + my $this = shift; + + $this->release; + if ($this->can_remove) { + return $this->destruct; + } else { + return 1; + } +} + +sub can_remove { + my $this = shift; + + return ($this->refcount <= 0 && !$this->has_data); +} + +sub reserve { + my ($this, $str) = @_; + + $this->{buffer} .= $str; + $this->flush if ($this->always_flush); +} +*write = \&reserve; +*print = \&reserve; + +sub flush { + my $this = shift; + + return 1 if !$this->has_data; + if ($this->real_flush) { + $this->destruct if ($this->can_remove); + return 1; + } else { + return 0; + } +} + +sub destruct { + my ($this, $force) = @_; + + my $ret = $this->real_destruct($force); + $this->parent->object_release($this->uri) if ($ret || $force); + $ret; +} + + +# util + +sub _notify_warn { + my ($this, $str) = @_; + + if ($this->_check_notify_cache($str)) { + $this->parent->notify_warn($this->_notify_prefix(1).$str); + } +} + +sub _notify_error { + my ($this, $str) = @_; + + if ($this->_check_notify_cache($str)) { + $this->parent->notify_error($this->_notify_prefix(1).$str); + } +} + +sub _notify_msg { + my ($this, $str) = @_; + + if ($this->_check_notify_cache($str)) { + $this->parent->notify_msg($this->_notify_prefix(1).$str); + } +} + +sub _check_notify_cache { + # check cache and return true if can notify + my ($this, $str) = @_; + + if (%{$this->{notify_cache}}) { + grep { + if ($this->{notify_cache}->{$_} < time) { + # expire + delete $this->{notify_cache}; + } + 0; + } keys %{$this->{notify_cache}}; + } + if ($this->{notify_cache}->{$str}) { + return 0; + } else { + # ignore 15sec + $this->{notify_cache}->{$str} = time + 15; + return 1; + } +} + +sub _notify_prefix { + my ($this, $stack_level) = @_; + + $stack_level = 0 if !defined $stack_level; + $this->name.'/'.(caller(1 + $stack_level))[3].'(' + .$this->uri.'): '; +} + +1; diff -urN /non-existant-dir/module/Log/Writer/File.pm tiarra-20080510/module/Log/Writer/File.pm --- /non-existant-dir/module/Log/Writer/File.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/Log/Writer/File.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,122 @@ +# ----------------------------------------------------------------------------- +# $Id: File.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +# copyright (C) 2004 Topia . all rights reserved. +package Log::Writer::File; +use strict; +use warnings; +use IO::File; +use File::Spec; +use Module::Use qw(Log::Writer::Base); +use base qw(Log::Writer::Base); +use File::Path; + +sub new { + my ($class, $parent, $uri, %options) = @_; + my $this = $class->SUPER::new($parent, $uri, %options); + + $this->{file_mode} = $this->first_defined($options{file_mode}, + _oct($options{file_mode_oct}), + 0600); + $this->{dir_mode} = $this->first_defined($options{dir_mode}, + _oct($options{dir_mode_oct}), + 0700); + + $this; +} + +sub capability { + my ($class, $type, @args) = @_; + + my $supported = $class->SUPER::capability($type, @args); + return 1 if $supported; + if ($type eq 'fallback') { + return 1; + } + return 0; +} + +sub _file { + my $this = shift; + + if (!defined $this->{file}) { + $this->mkdirs($this->path); + $this->path =~ /^(.+)$/; # untaint + $this->{file} = IO::File->new($1, + O_CREAT | O_APPEND | O_WRONLY, + $this->file_mode); + } + $this->{file}; +} + +sub scheme { + 'file'; +} +*name = \&scheme; +*supported_schemes = \&scheme; + +__PACKAGE__->define_attr_accessor(0, qw(file_mode dir_mode)); + +sub real_flush { + my $this = shift; + + my $file = $this->_file; + if (!defined $file) { + $this->_notify_warn('can\'t open file'); + return 0; + } + + my $ret = 0; + my $size = 1; + while ($size && $this->has_data) { + # use buffer directly; perhaps reduce memory allocation + $size = $file->syswrite($this->{buffer}, $this->length); + if (defined $size) { + substr($this->{buffer}, 0, $size) = ''; + $ret = 1; + } else { + $this->_notify_warn($!); + } + } + return $ret; +} + +sub real_destruct { + my ($this, $force) = @_; + + # make useless efforts + $this->real_flush; + + if (!defined $this->has_data) { + $this->_notify_warn('has can\'t flush data; will lost!'); + } + if (defined $this->{file}) { + # not use ->file. we don't need new allocation. + $this->{file}->close; + } + return 1; +} + +sub _oct { + map { defined $_ ? oct("0$_") : undef } @_; +} + +sub mkdirs { + my ($this,$file) = @_; + my (undef,$directories,undef) = File::Spec->splitpath($file); + + # 直接の親が存在するか + if ($directories eq '' || -d $directories) { + # これ以上辿れないか、存在するので終了。 + return; + } + else { + # 存在しないので作成 + eval { mkpath($directories, 0, $this->dir_mode) }; + if ($@) { + $this->_notify_warn("mkpath failed; Couldn't create $directories: $@"); + } + } +} + +1; diff -urN /non-existant-dir/module/Log/Writer.pm tiarra-20080510/module/Log/Writer.pm --- /non-existant-dir/module/Log/Writer.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/Log/Writer.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,218 @@ +# ----------------------------------------------------------------------------- +# $Id: Writer.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +# copyright (C) 2004 Topia . all rights reserved. +package Log::Writer; +use strict; +use warnings; +use RunLoop; +use Carp; +use File::Spec; +use DirHandle; +use Tiarra::SharedMixin qw(shared shared_writer); +use Tiarra::WrapMainLoop; +use Tiarra::Utils; +our $_shared_instance; + +Tiarra::Utils->define_attr_getter(0, qw(mainloop)); +Tiarra::Utils->define_proxy('mainloop', 0, + map { ["_mainloop_$_", "lazy_$_"] } + qw(install uninstall)); + +# todo: +# - accept uri(maybe: ssh, syslog, ...) + +sub _new { + my $class = shift; + my ($this) = { + objects => {}, + schemes => {}, + protocols => {}, + fallbacks => [], + }; + bless $this, $class; + $this->{mainloop} = Tiarra::WrapMainLoop->new( + type => 'timer', + interval => 120, + closure => sub { $this->run; }); + + return $this; +} + +sub _initialize { + my $this = shift; + $this->load_all_protocols; +} + +sub find_object { + my ($this, $path, %options) = @_; + + my $object = $this->{objects}->{$path}; + if (defined($object)) { + # ファイルが存在したので返す。 + return $object; + } else { + # ファイルは存在しないので、登録して返す。 + return $this->_register_inner($path, %options); + } +} + +sub register { + my ($this, $path, %options) = @_; + + my $object = $this->find_object($path, %options); + if (defined $object) { + # ファイルを得られた。 + # 参照回数を増やして返す。 + $object->register; + return $object; + } else { + return undef; + } +} + +sub unregister { + my ($this, $path) = @_; + + my $object = $this->{objects}->{$path}; + if (defined $object) { + return $object->unregister; + } else { + croak('object "' . $path . '" has not registered yet!'); + } +} + +sub _register_inner { + my ($this, $path, %options) = @_; + + my $object; + my @classes; + if ($path =~ m|^([^:]+):|) { + if (defined $this->{schemes}->{$1}) { + push(@classes, @{$this->{schemes}->{$1}}); + } + } + push(@classes, @{$this->{fallbacks}}); + foreach my $class (@classes) { + $object = $class->new($this, $path, %options); + last if defined $object; + } + if (defined $object) { + $this->{objects}->{$path} = $object; + $this->_mainloop_install; + return $object; + } else { + return undef; + } +} + +sub run { + my ($this, $destruct) = @_; + + # do object + foreach my $key (keys %{$this->{objects}}) { + my $object = $this->{objects}->{$key}; + $object->flush; + $object->destruct(1) if $destruct; + } +} + +sub destruct { + shared_writer->run(1); + shared_writer->{mainloop} = undef; +} + +sub object_release { + my ($this, $path) = @_; + + delete $this->{objects}->{$path}; + + if (!(%{$this->{objects}})) { + $this->_mainloop_uninstall; + } +} + + +# protocol +sub load_all_protocols { + my $class_or_this = shift; + my $this = $class_or_this->_this; + + my $pkg_dir = File::Spec->catdir(split(/::/, ref($this))); + foreach (@INC) { + my $dir = File::Spec->catdir($_, $pkg_dir); + my $dh = DirHandle->new($dir); + if (defined $dh) { + my $path; + foreach my $file ($dh->read) { + $path = File::Spec->catdir($dir, $file); + next if !-r $path || -d $path; + next if $file !~ /^(.+)\.pm$/; + $this->load_protocol(ref($this).'::'.$1); + } + } + } +} + +sub load_protocol { + my ($class_or_this, $pkg) = @_; + my $this = $class_or_this->_this; + + return 1 if $this->{protocols}->{$pkg}; + eval 'use ' . $pkg; + if ($@) { + $this->notify_error("load protocol($pkg) failed: $@"); + return undef; + } + eval 'use Module::Use ($pkg);'; + if ($@) { + $this->notify_error("register protocol($pkg) to module manager failed: $@"); + return undef; + } + + foreach my $scheme ($pkg->supported_schemes) { + push(@{$this->{schemes}->{$scheme}}, $pkg); + } + if ($pkg->capability('fallback')) { + push(@{$this->{fallbacks}}, $pkg); + } + $this->{protocols}->{$pkg} = 1; + return 1; +} + +sub unload_protocol { + my ($class_or_this, $pkg) = @_; + my $this = $class_or_this->_this; + + return 0 if !$this->{protocols}->{$pkg}; + if ($pkg->capability('fallback')) { + @{$this->{fallbacks}} = grep $_ ne $pkg, @{$this->{fallbacks}}; + } + foreach my $scheme ($pkg->supported_schemes) { + @{$this->{schemes}->{$scheme}} = grep $_ ne $pkg, + @{$this->{schemes}->{$scheme}}; + } + delete $this->{protocols}->{$pkg}; + return 1; +} + +# util +sub notify_warn { + my ($this, $str) = @_; + + RunLoop->shared_loop->notify_warn($str); +} + +sub notify_error { + my ($this, $str) = @_; + + RunLoop->shared_loop->notify_error($str); +} + +sub notify_msg { + my ($this, $str) = @_; + + RunLoop->shared_loop->notify_msg($str); +} + +1; diff -urN /non-existant-dir/module/Skelton.pm tiarra-20080510/module/Skelton.pm --- /non-existant-dir/module/Skelton.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/Skelton.pm 2008-05-11 00:25:26.000000000 +0900 @@ -0,0 +1,166 @@ +# ----------------------------------------------------------------------------- +# $Id: Skelton.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +# モジュールのスケルトン。 +# ----------------------------------------------------------------------------- +package Skelton; +use strict; +use warnings; +use base qw(Module); + +sub new { + my $class = shift; + # モジュールが必要になった時に呼ばれる。 + # これはモジュールのコンストラクタである。 + # 引数は無し。 + my $this = $class->SUPER::new(@_); + + return $this; +} + +sub destruct { + my $this = shift; + # モジュールが不要になった時に呼ばれる。 + # これはモジュールのデストラクタである。このメソッドが呼ばれた後はDESTROYを除いて + # いかなるメソッドも呼ばれる事が無い。タイマーを登録した場合は、このメソッドが + # 責任を持ってそれを解除しなければならない。 + # 引数は無し。 +} + +sub message_arrived { + my ($this,$msg,$sender) = @_; + # サーバーまたはクライアントからメッセージが来た時に呼ばれる。 + # 戻り値はTiarra::IRC::Messageまたはその配列またはundef。 + # + # $msg : + # 内容: Tiarra::IRC::Messageオブジェクト + # サーバーから、またはクライアントから送られてきたメッセージ。 + # モジュールはこのオブジェクトをそのまま返しても良いし、 + # 改変して返しても良いし何も返さなくても良いし二つ以上返しても良い。 + # $sender : + # 内容: IrcIOオブジェクト + # このメッセージを発したIrcIO。サーバーまたはクライアントである。 + # メッセージがサーバーから来たのかクライアントから来たのかは + # $sender->isa('IrcIO::Server')などとすれば判定出来る。 + # + # サーバー→クライアントの流れでも、Prefixを持たないメッセージを + # 流しても構わない。逆に言えば、そのようなメッセージが来ても + # 問題が起こらないようにモジュールを設計しなければならない。 + return $msg; +} +## Auto::Utils::generate_reply_closures を使う場合。 +# sub message_arrived { +# my ($this,$msg,$sender) = @_; +# my @result = ($msg); +# +# if ($msg->command eq 'PRIVMSG') { +# my ($get_raw_ch_name, $reply, $reply_as_priv, $reply_anywhere, $get_full_ch_name) +# = Auto::Utils::generate_reply_closures($msg,$sender,\@result); +# +# $reply_anywhere->('Hello, #(name|default_name)', +# 'default_name' => '(your name)'); +# if ($get_raw_ch_name->() eq '#Tiarra_testing') { +# # なんらかの処理 +# } +# if ($get_full_ch_name->() eq '#Tiarra_testing@LocalServer') { +# # なんらかの処理 +# } +# } +# return @result; +# } +# + +sub client_attached { + my ($this,$client) = @_; + # クライアントが新規に接続した時に呼ばれる。 + # 戻り値は無し。 + # + # $client : + # 内容: IrcIO::Clientオブジェクト + # 接続されたクライアント。 +} + +sub client_detached { + my ($this,$client) = @_; + # クライアントが切断した時に呼ばれる。 + # 戻り値は無し。 + # + # $client : + # 内容: IrcIO::Clientオブジェクト + # 切断したクライアント。 +} + +sub connected_to_server { + my ($this,$server,$new_connection) = @_; + # サーバーに接続した時に呼ばれる。 + # 戻り値は無し。 + # + # $server : + # 内容: IrcIO::Serverオブジェクト + # 接続したサーバー。 + # $new_connection : + # 内容: 真偽値 + # 新規の接続なら1。切断後の自動接続ではundef。 +} + +sub disconnected_from_server { + my ($this,$server) = @_; + # サーバーから切断した(或いはされた)時に呼ばれる。 + # 戻り値は無し。 + # + # $server : + # 内容: IrcIO::Serverオブジェクト + # 切断したサーバー。 +} + +sub message_io_hook { + my ($this,$message,$io,$type) = @_; + # サーバーから受け取ったメッセージ、サーバーに送るメッセージ、 + # クライアントから受け取ったメッセージ、クライアントに送るメッセージは + # このメソッドで各モジュールに通知される。メッセージの変更も可能で、 + # 戻り値のルールはmessage_arrivedと同じ。 + # + # 通常のモジュールはこのメソッドを実装する必要は無い。 + # + # $message : + # 内容: Tiarra::IRC::Messageオブジェクト + # 送受信しているメッセージ + # $io : + # 内容: IrcIO::Server又はIrcIO::Clientオブジェクト + # 送受信を行っているIrcIO + # $type : + # 内容: 文字列 + # 'in'なら受信、'out'なら送信 + return $message; +} + +sub control_requested { + my ($this,$request) = @_; + # 外部コントロールプログラムからのメッセージが来た。 + # 戻り値はControlPort::Reply。 + # + # $request: + # 内容 : ControlPort::Request + # 送られたリクエスト + die "This module doesn't support controlling.\n"; +} + +1; + +=begin tiarra-doc + +info: Skelton for tiarra-module. +default: off +#section: important + +# モジュールの説明をこのあたりに書く. +# 詳細はこのソースみれば分かると思われ. +# 書式は tiarra.conf にそのままコピーできる形式. + +# もにゅもにゅ +mask: *!*@* +mask: ... + +=end tiarra-doc + +=cut diff -urN /non-existant-dir/module/System/Error.pm tiarra-20080510/module/System/Error.pm --- /non-existant-dir/module/System/Error.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/System/Error.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,38 @@ +# ----------------------------------------------------------------------------- +# $Id: Error.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +# copyright (C) 2004 Topia . all rights reserved. +package System::Error; +use strict; +use warnings; +use base qw(Module); + +sub message_io_hook { + my ($this,$message,$io,$type) = @_; + + if ($io->isa('IrcIO::Client') && + $type eq 'out' && + $message->command eq 'ERROR' && + !$message->remark('send-error-as-is-to-client')) { + $message->param(1, $message->serialize); + $message->param(0, RunLoop->shared_loop->current_nick); + $message->command('NOTICE'); + } + + return $message; +} + +1; + +=pod +info: サーバーからのERRORメッセージをNOTICEに埋め込む +default: on + +# これをoffにするとクライアントにERRORメッセージがそのまま送られます。 +# クライアントとの間ではERRORメッセージは主に切断警告に使われており、 +# そのまま流してしまうとクライアントが混乱する可能性があります。 +# 設定項目はありません。 + +# このモジュールを回避してERRORメッセージをクライアントに送りたい場合は、 +# remarkのsend-error-as-is-to-clientを指定してください。 +=cut diff -urN /non-existant-dir/module/System/Inflate/Gzip.pm tiarra-20080510/module/System/Inflate/Gzip.pm --- /non-existant-dir/module/System/Inflate/Gzip.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/System/Inflate/Gzip.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,76 @@ +# -*- cperl -*- +# ----------------------------------------------------------------------------- +# $Id: Gzip.pm 3004 2007-12-10 12:45:39Z topia $ +# ----------------------------------------------------------------------------- +# copyright (C) 2003 Topia . all rights reserved. +package System::Inflate::Gzip; +use strict; +use warnings; +use Carp; +use base qw(System::Inflate::Zlib); + +sub new { + my ($obj) = $_[0]->SUPER::new(@_); + + $obj->{accept} = 'gzip'; + + return $obj; +} + +sub setup { + my ($this, $parent) = @_; + + foreach my $compressor qw(gzip) { + $parent->{compressor}->{$compressor} = $this; + $this->{parent} = $parent; + } + + return $parent; +} + +sub init { + my ($this, $datas, $data_chunk) = @_; + my $ret = $this->SUPER::init($datas, $data_chunk); + + if ($ret == $this->parent->COMP_OK) { + $datas->{data} = + { + crc32 => undef, + len => undef, + data_len => 0, + data_crc32 => undef, + }; + $datas->{lasterr} = Compress::Zlib::_removeGzipHeader($data_chunk); + return undef if $datas->{lasterr} != $this->{Z_OK}; + return $this->parent->COMP_OK if $datas->{lasterr} == $this->{Z_OK}; + return $this->parent->COMP_OTHER_ERR; + } else { + return $ret; + } +} + +sub inflate { + my ($this, $datas, $data_chunk) = @_; + my ($ret, $err); + + ($ret, $err) = $this->SUPER::inflate($datas, $data_chunk); + + $datas->{data}->{data_len} += length($ret); + $datas->{data}->{data_crc32} = Compress::Zlib::crc32($ret, $datas->{data}->{data_crc32}); + if ($datas->{lasterr} == $this->{Z_STREAM_END}) { + ($datas->{data}->{crc32}, $datas->{data}->{len}) = unpack ("VV", substr($$data_chunk, 0, 8)); + substr($$data_chunk, 0, 8) = ''; + } + return ($ret, $err); +} + +sub check { + my ($this, $datas) = @_; + my ($compdata) = $datas->{data}; + + return undef unless defined($compdata->{len}) && defined($compdata->{crc32}); + return $this->parent->COMP_DATA_ERROR unless + ($compdata->{len} == $compdata->{data_len}) && ($compdata->{crc32} == $compdata->{data_crc32}); + return $this->parent->COMP_OK; +} +1; diff -urN /non-existant-dir/module/System/Inflate/Zlib.pm tiarra-20080510/module/System/Inflate/Zlib.pm --- /non-existant-dir/module/System/Inflate/Zlib.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/System/Inflate/Zlib.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,74 @@ +# -*- cperl -*- +# ----------------------------------------------------------------------------- +# $Id: Zlib.pm 3004 2007-12-10 12:45:39Z topia $ +# ----------------------------------------------------------------------------- +# copyright (C) 2003 Topia . all rights reserved. +package System::Inflate::Zlib; +use strict; +use warnings; +use Carp; +use Compress::Zlib; + +sub new { + my ($class) = @_; + my $obj = + { + Z_OK => Compress::Zlib::Z_OK(), + Z_STREAM_END => Compress::Zlib::Z_STREAM_END(), + Z_DATA_ERROR => Compress::Zlib::Z_DATA_ERROR(), + accept => 'inflate' + }; + bless $obj,$class; + return $obj; +} + +sub setup { + my ($this, $parent) = @_; + + foreach my $compressor qw(inflate) { + $parent->{compressor}->{$compressor} = $this; + $this->{parent} = $parent; + } + + return $parent; +} + +sub parent { + return shift->{parent}; +} + +sub init { + my ($this, $datas, $data_chunk) = @_; + + ($datas->{stream}, $datas->{lasterr}) = + Compress::Zlib::inflateInit(-WindowBits => - Compress::Zlib::MAX_WBITS()); + return undef if $datas->{lasterr} != $this->{Z_OK}; + return $this->parent->COMP_OK if $datas->{lasterr} == $this->{Z_OK}; + return $this->parent->COMP_OTHER_ERR; +} + +sub inflate { + my ($this, $datas, $data_chunk) = @_; + my ($ret); + + carp('not initialized!') if !defined $datas->{stream}; + ($ret, $datas->{lasterr}) = $datas->{stream}->inflate($data_chunk); + $datas->{stream} = undef if $datas->{lasterr} != $this->{Z_OK}; + return ($ret, $this->parent->COMP_OK) if $datas->{lasterr} == $this->{Z_OK}; + return ($ret, $this->parent->COMP_STREAM_END) if $datas->{lasterr} == $this->{Z_STREAM_END}; + return (undef, $this->parent->COMP_OTHER_ERR); +} + +sub check { + my ($this, $datas) = @_; + + return 1; +} + +sub final { + my ($this) = @_; + + return $this->parent->COMP_OK; +} + +1; diff -urN /non-existant-dir/module/System/Inflate.pm tiarra-20080510/module/System/Inflate.pm --- /non-existant-dir/module/System/Inflate.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/System/Inflate.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,132 @@ +# -*- cperl -*- +# ----------------------------------------------------------------------------- +# $Id: Inflate.pm 3009 2007-12-10 13:35:53Z topia $ +# ----------------------------------------------------------------------------- +# copyright (C) 2003 Topia . all rights reserved. +package System::Inflate; +use strict; +use warnings; +use Carp; + +use Tiarra::SharedMixin; +our $_shared_instance; + +sub _new { + my ($class) = @_; + my $obj = + { + datas => {}, # HASH; HASH key is [tag] + # compressor: stream compressor + # stream : stream object + # lasterr : last error information + # data : compressor dependent datas + compressor => {}, # HASH; compressor name => Process Classes + const => + { + COMP_OK => 0, + COMP_STREAM_END => 1, + COMP_DATA_ERR => -1, + COMP_OTHER_ERR => -2 + } + }; + bless $obj,$class; + + return $obj->_setup(); +} + +sub _setup { + my ($this) = @_; + + foreach my $classname (map {'System::Inflate::' . $_} qw(Zlib Gzip)) { + eval 'use ' . $classname; + unless ($@) { + eval $classname . '::setup(new ' . $classname . '(), $this)'; + if ($@) { + print "------can't load $classname\n$@------\n"; + } + } else { + print "------can't load $classname\n$@------\n"; + } + } + + return $this; +} + +sub get_compclass { + my ($this, $compressor) = @_; + my ($compclass) = $this->shared->{compressor}->{$compressor}; + + croak('compressor ' . $compressor . ' is not initialized!') unless defined $compclass; + + return $compclass +} + +sub get_data_struct { + my ($this, $tag) = @_; + my ($datas) = $this->shared->{datas}->{$tag}; + + croak('tag ' . $tag . ' is not initialized!') unless defined $datas; + + return $datas; +} + +sub get_lasterr { + my ($this, $tag) = @_; + return $this->get_data_struct($tag)->{lasterr}; +} + +sub COMP_OK { + return shift->{const}->{COMP_OK}; +} + +sub COMP_STREAM_END { + return shift->{const}->{COMP_STREAM_END}; +} + +sub COMP_OTHER_ERR { + return shift->{const}->{COMP_OTHER_ERR}; +} + +sub COMP_DATA_ERR { + return shift->{const}->{COMP_DATA_ERR}; +} + +sub init { + my ($this, $tag, $compressor, $data_chunk) = @_; + my ($datas) = $this->shared->{datas}->{$tag} = + { + stream => undef, + compressor => $compressor, + lasterr => undef, + data => {} + }; + + return $this->get_compclass($compressor)->init($datas, $data_chunk); +} + +sub inflate { + my ($this, $tag, $data_chunk) = @_; + my ($datas) = $this->get_data_struct($tag); + + return $this->get_compclass($datas->{compressor})->inflate($datas, $data_chunk); +} + +sub check { + my ($this, $tag) = @_; + my ($datas) = $this->get_data_struct($tag); + + return $this->get_compclass($datas->{compressor})->check($datas); +} + +sub final { + my ($this, $tag) = @_; + my ($datas) = $this->get_data_struct($tag); + + # ordinary void function + my $ret = $this->shared->{compressor}->{$datas->{compressor}}->final($datas); + return undef unless defined $ret; # return value is undef; maybe can't finalize.... + delete $this->shared->{datas}->{$tag}; + return $ret; +} + +1; diff -urN /non-existant-dir/module/System/LivePatch.pm tiarra-20080510/module/System/LivePatch.pm --- /non-existant-dir/module/System/LivePatch.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/System/LivePatch.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,760 @@ +## ---------------------------------------------------------------------------- +# System::LivePatch. +# ----------------------------------------------------------------------------- +# Mastering programmed by YAMASHINA Hio +# +# Copyright 2008 YAMASHINA Hio +# ----------------------------------------------------------------------------- +# $Id: LivePatch.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +# main/モジュールに対する動的パッチ. +# ----------------------------------------------------------------------------- +package System::LivePatch; +use strict; +use warnings; +use base qw(Module); +use BulletinBoard; + +our $VERSION = '0.02'; + +our $DEBUG = 0; + +1; + +# ----------------------------------------------------------------------------- +# $pkg->new(). +# +sub new +{ + my $pkg = shift; + my $this = $pkg->SUPER::new(@_); + + $this->{patches} = undef; + + $this->{bbs_val} = undef; + $this->_load_history(); + + eval{ + $this->{patches} = $pkg->_load_patches(); + my $on_load = $this->config->on_load || 'check'; + if( $on_load eq 'apply' ) + { + RunLoop->shared_loop->notify_msg("- apply by on-load config"); + $this->_apply(-apply => -all); + }else + { + RunLoop->shared_loop->notify_msg("- auto-check on load"); + $this->_apply(-check); + } + }; + if( $@ ) + { + RunLoop->shared_loop->notify_error("$@"); + } + + return $this; +} + +# ----------------------------------------------------------------------------- +# $obj->message_arrived($msg, $sender). +# +sub message_arrived +{ + my ($this, $msg, $sender) = @_; + + if( !$sender->isa('IrcIO::Client') ) + { + return $msg; + } + + my $cmd = uc($this->config->command || 'livepatch'); + + if( $msg->command ne $cmd ) + { + return $msg; + } + + $msg->remark('do-not-send-to-servers', 1); + + eval + { + my $params = $msg->params; + $params = [@$params]; # sharrow-copy. + my $param0 = shift @$params || 'help'; + if( $param0 eq 'check' ) + { + $this->_apply(-check); + }elsif( $param0 eq 'apply' ) + { + if( @$params==1 ) + { + $this->_apply(-apply => -all); + }else + { + RunLoop->shared_loop->notify_msg("too many params for $param0"); + } + }elsif( $param0 eq 'help' ) + { + $this->_show_usage(); + }elsif( $param0 eq 'history' ) + { + $this->_show_history($params); + }elsif( $param0 eq 'version' ) + { + $this->_show_version(); + }else + { + RunLoop->shared_loop->notify_msg("unknown subcommand: $param0"); + } + }; + if( $@ ) + { + RunLoop->shared_loop->notify_error(__PACKAGE__."#message_arrived, $@"); + } + + return $msg; +} + +# ----------------------------------------------------------------------------- +# $obj->_show_history($params). +# +sub _show_history +{ + my $this = shift; + my $params = shift; + my $history = $this->{bbs_val}{history}; + my $runloop = $this->_runloop; + + my $nr_history = @$history; + $runloop->notify_msg(__PACKAGE__.", $nr_history ".($nr_history==1?'entry':'entries')." in history"); + + my $base = shift @$params; + my $limit = 3; + if( !$base || $base !~ /^0*\d+\z/ ) + { + $base = @$history - $limit + 1; + } + $base < 1 and $base = 1; + + if( $base > @$history ) + { + return; + } + my $last = $base + $limit - 1; + if( $last > @$history ) + { + $last = @$history; + } + foreach my $i ($base .. $last) + { + my $entry = $history->[$i-1]; + my @tm = localtime($entry->{time}); + $tm[5] += 1900; + $tm[4] += 1; + my $time = sprintf('%04d/%02d/%02x %02d:%02d:%02d', reverse @tm[0..5]); + $runloop->notify_msg("[$i] -"); + $runloop->notify_msg("[$i] package $entry->{pkg}"); + $runloop->notify_msg("[$i] subname $entry->{subname}"); + $runloop->notify_msg("[$i] mode $entry->{mode}"); + $runloop->notify_msg("[$i] result $entry->{result}"); + $runloop->notify_msg("[$i] time ".$time); + } +} + +# ----------------------------------------------------------------------------- +# $obj->_show_usage(). +# +sub _show_usage +{ + my $this = shift; + my $runloop = $this->_runloop; + + $runloop->notify_msg("livepatch:"); + $runloop->notify_msg(" help - show this usage"); + $runloop->notify_msg(" history - show patching history"); + $runloop->notify_msg(" check - check only"); + $runloop->notify_msg(" apply - apply patches"); + $runloop->notify_msg(" version - show vesrion"); + $runloop->notify_msg("(end of message)"); +} + +# ----------------------------------------------------------------------------- +# $obj->_show_version(). +# +sub _show_version +{ + my $this = shift; + my $runloop = $this->_runloop; + + $runloop->notify_msg("livepatch VERSION $VERSION:"); +} + +# ----------------------------------------------------------------------------- +# $plans = $pkg->_apply(-check). +# $pkg->_apply(-apply => $plans). +# +sub _apply +{ + my $this = shift; + my $mode = shift || -check; + my $plans = shift || []; + + my $patches = $this->{patches} or die "patches are not loaded"; + + if( $mode eq -check ) + { + $plans = []; # for output. + foreach my $patch (@$patches) + { + push(@$plans, { + pkg => $patch->{pkg}, + subname => $patch->{subname}, + installed => undef, + install => undef, + }); + } + }elsif( $mode eq -apply ) + { + if( $plans eq -all ) + { + $plans = []; # for output. + foreach my $patch (@$patches) + { + push(@$plans, { + pkg => $patch->{pkg}, + subname => $patch->{subname}, + installed => undef, + install => (reverse sort keys %{$patch->{revs}})[0], + }); + } + } + if( ref($plans) eq 'HASH' ) + { + $plans = [$plans]; + } + }else + { + die "unvalid mode: $mode"; + } + + require B; + require B::Deparse; + require Digest::MD5; + my $deparse = B::Deparse->new(); + my $digest = sub{ + Digest::MD5::md5_hex($_[0]); + }; + + my $patches_hashref = {}; + foreach my $patch (@$patches) + { + my $pkg = $patch->{pkg}; + my $subname = $patch->{subname}; + $patches_hashref->{$pkg}{$subname} = $patch; + } + + $deparse->ambient_pragmas( + strict => 'all', + warnings => 'all', + ); + my $runloop = RunLoop->shared_loop; + my $nr_plans = @$plans; + my $idx = 0; + $runloop->notify_msg("- mode = $mode"); + foreach my $plan (@$plans) + { + ++$idx; + my $pkg = $plan->{pkg}; + my $subname = $plan->{subname}; + $runloop->notify_msg("- [$idx/$nr_plans]"); + $pkg or $runloop->notify_msg(" no pkg on plan."), next; + $subname or $runloop->notify_msg(" no subname on plan."), next; + + my $patch = $patches_hashref->{$pkg}{$subname}; + $patch or $runloop->notify_msg(" no such patch, [$pkg] [$subname]."), next; + my @revs = reverse sort keys %{$patch->{revs}}; + $runloop->notify_msg(" pkg => $pkg"); + $runloop->notify_msg(" sub => $subname"); + $runloop->notify_msg(" revs => ".join(", ", @revs)); + my $cursub = $pkg->can($patch->{subname}); + if( !defined(&$cursub) ) + { + $runloop->notify_msg(" current => not loaded."); + $this->_add_history($patch, $mode, 'not_loaded'); + next; + } + my $curtext = $deparse->coderef2text($cursub); + my $curmd5 = $digest->($curtext); + $runloop->notify_msg(" current => $curmd5"); + $DEBUG and print "<>\n$curtext\n"; + my $found; + my $lastest; + foreach my $rev (@revs) + { + my $eval = "p"."ackage $pkg; ".$patch->{revs}{$rev}; + my $sub = eval $eval; + if( $@ ) + { + $runloop->notify_msg(" $rev => load failed: $@"); + next; + } + my $dump = $deparse->coderef2text($sub); + $DEBUG and print "<<$rev>>\n$dump\n"; + my $md5 = $digest->($dump); + $lastest ||= {rev=>$rev,'sub'=>$sub,md5=>$md5}; + if( $dump ne $curtext ) + { + $runloop->notify_msg(" $rev => not match: $md5"); + next; + } + $found = $rev; + if( $rev eq $lastest->{rev} ) + { + $runloop->notify_msg(" $rev => match, lastest, no need to update."); + $this->_add_history($patch, $mode, "lastest:$rev"); + if( $mode eq -check ) + { + $plan->{installed} = $rev; + $plan->{install} = undef; + }else + { + $plan->{installed} = $rev; + $plan->{install} = undef; + } + }else + { + if( $mode eq -check ) + { + $runloop->notify_msg(" $rev => match, can update to $lastest->{rev} (not applied by mode$mode)"); + $this->_add_history($patch, $mode, "found:$rev"); + $plan->{installed} = $rev; + $plan->{install} = $lastest->{rev}; + }else + { + $runloop->notify_msg(" $rev => match, update to $lastest->{rev}, applied by mode$mode"); + my $lastest_sub = $lastest->{'sub'}; + my $ref = $pkg . '::' . $subname; + { + no strict 'refs'; + no warnings 'redefine'; + *$ref = $lastest_sub; + } + $this->_add_history($patch, $mode, "updated:$rev:$lastest->{rev}"); + } + } + last; + } + if( !$found ) + { + $runloop->notify_msg(" current => unsupported version."); + $this->_add_history($patch, $mode, 'not_found'); + } + } + + $plans; +} + +# ----------------------------------------------------------------------------- +# $pkg->_load_history(). +# +sub _load_history +{ + my $this = shift; + + my $BBS_KEY = __PACKAGE__.'/history'; + my $BBS_VAL = BulletinBoard->shared->get($BBS_KEY); + if( !$BBS_VAL ) + { + $this->_runloop->notify_msg(__PACKAGE__."#new, bbs[$BBS_KEY] initialize"); + $BBS_VAL = { + inited_at => time, + history => [], + }; + BulletinBoard->shared->set($BBS_KEY, $BBS_VAL); + } + + $this->{bbs_val} = $BBS_VAL; +} + +# ----------------------------------------------------------------------------- +# $pkg->_add_history($patch, $mode, $result). +# +sub _add_history +{ + my $this = shift; + my $patch = shift; + my $mode = shift; + my $result = shift; + + my $entry = { + pkg => $patch->{pkg}, + subname => $patch->{subname}, + mode => $mode, + result => $result, + 'time' => time(), + }; + + my $history = $this->{bbs_val}{history}; + my $last_hist; + foreach my $hist (@$history) + { + $hist->{pkg} eq $entry->{pkg} or next; + $hist->{subname} eq $entry->{subname} or next; + $last_hist = $hist; + } + if( !$last_hist || $last_hist->{result} ne $entry->{result} ) + { + push(@$history, $entry); + } +} + +# ----------------------------------------------------------------------------- +# $pkg->_load_patches(). +# +sub _load_patches +{ + [ + { + pkg => 'ModuleManager', + subname => 'reload_modules_if_modified', + revs => { + r3004 => <<'EOF', +# package ModuleManager. +# sub _reload_modules_if_modified_r8809. +sub { + # コード自体が更新されているモジュールがあれば、それを一旦アンロードしてロードし直す。 + # インスタンスも当然作り直す。 + my $this = shift; + + my $show_msg = sub { + $this->_runloop->notify_msg($_[0]); + }; + + my $mods_to_be_reloaded = {}; # モジュール名 => 1 + my $check = sub { + my ($modname,$timestamp) = @_; + # 既に更新されたものとしてマークされていれば抜ける。 + return if $mods_to_be_reloaded->{$modname}; + + if ($this->check_timestamp_update($modname, $timestamp)) { + # 更新されている。少なくともこのモジュールはリロードされる。 + $mods_to_be_reloaded->{$modname} = 1; + $show_msg->("$modname has been modified. It will be reloaded."); + + my $trace; + $trace = sub { + my ($modname, $depth) = @_; + ++$depth; + no strict 'refs'; + # このモジュールに%USEDは定義されているか？ + my $USED = \%{$modname.'::USED'}; + if (defined $USED) { + # USEDの全ての要素に対し再帰的にマークを付ける。 + foreach my $used_elem (keys %$USED) { + if (!defined $mods_to_be_reloaded->{$used_elem} || + $mods_to_be_reloaded->{$used_elem} < $depth) { + $mods_to_be_reloaded->{$used_elem} = $depth; + $show_msg->("$used_elem will be reloaded because of modification of $modname"); + $trace->($used_elem, $depth); + } + } + } + }; + + $trace->($modname, 1); + } + }; + + while (my ($modname,$timestamp) = each %{$this->{mod_timestamps}}) { + $check->($modname,$timestamp); + } + + # 一つでもマークされたモジュールがあれば、$this->{modules}内の何処に + # 目的のモジュールが在るのかを調べるために、モジュール名 => 位置のテーブルを作る。 + if (keys(%$mods_to_be_reloaded) > 0) { + my $mod2index = {}; + for (my $i = 0; $i < @{$this->{modules}}; $i++) { + $mod2index->{ref $this->{modules}->[$i]} = $i; + } + + # マークされたモジュールをリロードするが、それが$mod2indexに登録されていたら + # インスタンスを作り直す。 + foreach my $modname (map { $_->[0] } + sort { $a->[1] <=> $b->[1] } + map { [$_, $mods_to_be_reloaded->{$_}]; } + keys %$mods_to_be_reloaded) { + my $idx = $mod2index->{$modname}; + if (defined $idx) { + eval { + $this->{modules}->[$idx]->destruct; + }; if ($@) { + $this->_runloop->notify_error($@); + } + + my $conf_block = $this->{mod_configs}->{$modname}; + # message_io_hook が定義されているモジュールが死ぬと怖いので + # とりあえず undef を入れて無視させる。 + $this->{modules}->[$idx] = undef; + $this->_unload($conf_block); + $this->{modules}->[$idx] = $this->_load($conf_block); # 失敗するとundefが入る。 + # _unload でブラックリストから消えるから大丈夫だと思うが、一応。 + $this->remove_from_blacklist($modname); + } + else { + # アンロード後、use。 + no strict 'refs'; + # その時、%USEDを保存する。@USEは保存しない。 + my %USED = %{$modname.'::USED'}; + eval { + $modname->destruct; + }; + $this->_unload($modname); + eval qq{ + use $modname; + }; if ($@) { + $this->_runloop->notify_error($@); + } + %{$modname.'::USED'} = %USED; + } + } + + # 全てのモジュールの%USEDを調べて、その%USEDが指しているモジュールが + # 本当にそのモジュールを参照しているのかどうかをチェック。 + # モジュールの更新で最早参照しなくなっていれば、%USEDから削除する。 + # このような事が起こるのはリロード時に%USEDを保存するためである。 + my $fixed = $this->fix_USED_fields; + + # %USEDの不整合性が見付かったら、もはや必要とされなくなった + # モジュールがあるかも知れない。gcを実行。 + if ($fixed) { + $this->gc; + } + + # $this->{modules}にはundefの要素が入っているかも知れないので、そのような要素は除外する。 + @{$this->{modules}} = grep { + defined $_; + } @{$this->{modules}}; + + $this->_clear_module_cache; + } +} +EOF + r8809 => <<'EOF' +# package ModuleManager. +# sub _reload_modules_if_modified_r8809. +sub { + # コード自体が更新されているモジュールがあれば、それを一旦アンロードしてロードし直す。 + # インスタンスも当然作り直す。 + my $this = shift; + + my $show_msg = sub { + $this->_runloop->notify_msg($_[0]); + }; + + my $mods_to_be_reloaded = {}; # モジュール名 => 1 + my $check = sub { + my ($modname,$timestamp) = @_; + # 既に更新されたものとしてマークされていれば抜ける。 + return if $mods_to_be_reloaded->{$modname}; + + if ($this->check_timestamp_update($modname, $timestamp)) { + # 更新されている。少なくともこのモジュールはリロードされる。 + $mods_to_be_reloaded->{$modname} = 1; + $show_msg->("$modname has been modified. It will be reloaded."); + + my $trace; + $trace = sub { + my ($modname, $depth) = @_; + ++$depth; + no strict 'refs'; + # このモジュールに%USEDは定義されているか？ + my $USED = \%{$modname.'::USED'}; + if (defined $USED) { + # USEDの全ての要素に対し再帰的にマークを付ける。 + foreach my $used_elem (keys %$USED) { + if (!defined $mods_to_be_reloaded->{$used_elem} || + $mods_to_be_reloaded->{$used_elem} < $depth) { + $mods_to_be_reloaded->{$used_elem} = $depth; + $show_msg->("$used_elem will be reloaded because of modification of $modname"); + $trace->($used_elem, $depth); + } + } + } + }; + + $trace->($modname, 1); + } + }; + + while (my ($modname,$timestamp) = each %{$this->{mod_timestamps}}) { + $check->($modname,$timestamp); + } + + # 一つでもマークされたモジュールがあれば、$this->{modules}内の何処に + # 目的のモジュールが在るのかを調べるために、モジュール名 => 位置のテーブルを作る。 + if (keys(%$mods_to_be_reloaded) > 0) { + my $mod2index = {}; + for (my $i = 0; $i < @{$this->{modules}}; $i++) { + $mod2index->{ref $this->{modules}->[$i]} = $i; + } + + my @mods_load_order = map { $_->[0] } + sort { $a->[1] <=> $b->[1] } + map { [$_, $mods_to_be_reloaded->{$_}]; } + keys %$mods_to_be_reloaded; + + # 先に destruct して回る + foreach my $modname (reverse @mods_load_order) { + my $idx = $mod2index->{$modname}; + if (defined $idx) { + eval { + $this->{modules}->[$idx]->destruct; + }; if ($@) { + $this->_runloop->notify_error($@); + } + } else { + eval { + $modname->destruct; + }; if ($@ && $modname->can('destruct')) { + $this->_runloop->notify_error($@); + } + } + } + + # マークされたモジュールをリロードするが、それが$mod2indexに登録されていたら + # インスタンスを作り直す。 + foreach my $modname (@mods_load_order) { + my $idx = $mod2index->{$modname}; + if (defined $idx) { + my $conf_block = $this->{mod_configs}->{$modname}; + # message_io_hook が定義されているモジュールが死ぬと怖いので + # とりあえず undef を入れて無視させる。 + $this->{modules}->[$idx] = undef; + $this->_unload($conf_block); + $this->{modules}->[$idx] = $this->_load($conf_block); # 失敗するとundefが入る。 + # _unload でブラックリストから消えるから大丈夫だと思うが、一応。 + $this->remove_from_blacklist($modname); + } + else { + # アンロード後、use。 + no strict 'refs'; + # その時、%USEDを保存する。@USEは保存しない。 + my %USED = %{$modname.'::USED'}; + $this->_unload($modname); + eval qq{ + use $modname; + }; if ($@) { + $this->_runloop->notify_error($@); + } + %{$modname.'::USED'} = %USED; + } + } + + # 全てのモジュールの%USEDを調べて、その%USEDが指しているモジュールが + # 本当にそのモジュールを参照しているのかどうかをチェック。 + # モジュールの更新で最早参照しなくなっていれば、%USEDから削除する。 + # このような事が起こるのはリロード時に%USEDを保存するためである。 + my $fixed = $this->fix_USED_fields; + + # %USEDの不整合性が見付かったら、もはや必要とされなくなった + # モジュールがあるかも知れない。gcを実行。 + if ($fixed) { + $this->gc; + } + + # $this->{modules}にはundefの要素が入っているかも知れないので、そのような要素は除外する。 + @{$this->{modules}} = grep { + defined $_; + } @{$this->{modules}}; + + $this->_clear_module_cache; + } +} +EOF + }, + }, + { + pkg => 'LinedINETSocket', + subname => 'connect', + revs => { + r3004 => <<'EOF', +# package LinedINETSocket +# sub _connect_r3004 +no strict 'refs'; # by SelfLoader. +sub { + # 接続先ホストとポートを指定して接続を行なう。 + my ($this, $host, $port) = @_; + return if $this->connected; + + # ソケットを開く。開けなかったらundef。 + my $sock = new IO::Socket::INET(PeerAddr => $host, + PeerPort => $port, + Proto => 'tcp', + Timeout => 5); + $this->attach($sock); +} +EOF + r8930 => <<'EOF', +# package LinedINETSocket +# sub _connect_r8930 +no strict 'refs'; # by SelfLoader. +sub { + # 接続先ホストとポートを指定して接続を行なう。 + my ($this, $host, $port) = @_; + return if $this->connected; + + # ソケットを開く。開けなかったらundef。 + my $sock = new IO::Socket::INET(PeerAddr => $host, + PeerPort => $port, + Proto => 'tcp', + Timeout => 5); + if( $sock ) + { + $this->attach($sock); + }else + { + undef; + } +} +EOF + }, + }, + ]; +} + +# ----------------------------------------------------------------------------- +# End of Module. +# ----------------------------------------------------------------------------- +__END__ + +=encoding utf8 + +=for stopwords + YAMASHINA + Hio + ACKNOWLEDGEMENTS + AnnoCPAN + CPAN + RT + +package System::LivePatch; + +=begin tiarra-doc + +info: Live Patch. +default: off +#section: important + +# main/* に対する実行時パッチ +# 起動/ロード時に確認は行われるが, 実際の適用は指示があるまで行われない. + +# 対応している箇所. +# ModuleManager / reload_modules_if_modified / r3004 => r8809 + +# /livepatch check で確認. +# /livepatch apply で適用. +command: livepatch + +=end tiarra-doc + +=cut diff -urN /non-existant-dir/module/System/Macro.pm tiarra-20080510/module/System/Macro.pm --- /non-existant-dir/module/System/Macro.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/System/Macro.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,67 @@ +# ----------------------------------------------------------------------------- +# $Id: Macro.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +package System::Macro; +use strict; +use warnings; +use base qw(Module); +use Multicast; + +sub new { + my $class = shift; + my $this = $class->SUPER::new(@_); + $this->{macros} = $this->hash; # コマンド => ARRAY<動作(Tiarra::IRC::Message)> + $this; +} + +sub hash { + my $this = shift; + my $macros = {}; + foreach ($this->config->macro('all')) { + my ($command,$action) = (m/^(.+?)\s+(.+)$/); + $command = uc($command); + + my $action_msg = $this->construct_irc_message( + Line => $action, + Encoding => 'utf8'); + my $array = $macros->{$command}; + if (defined $array) { + push @$array,$action_msg; + } + else { + $macros->{$command} = [$action_msg]; + } + } + $macros; +} + +sub message_arrived { + my ($this,$msg,$sender) = @_; + + if ($sender->isa('IrcIO::Client')) { + my $actions = $this->{macros}->{$msg->command}; + if (defined $actions) { + foreach (@$actions) { + Multicast::from_client_to_server($_, $sender); + } + # このメッセージは鯖に送らない。 + $msg->remark('do-not-send-to-servers',1); + } + } + + $msg; +} + +1; + +=pod +info: 新規にコマンドを追加し、そのコマンドが使われた時に特定の動作をまとめて実行します。 +default: off + +# 書式: <コマンド> <動作> +# コマンド"switch"を追加して、それが使われると +# #a@ircnet,#b@ircnet,#c@ircnetにjoinして、 +# #d@ircnet,#e@ircnet,#f@ircnetからpartする例。 +-macro: switch join #a@ircnet,#b@ircnet,#c@ircnet +-macro: switch part #d@ircnet,#e@ircnet,#f@ircnet +=cut diff -urN /non-existant-dir/module/System/NotifyIcon/Win32.pm tiarra-20080510/module/System/NotifyIcon/Win32.pm --- /non-existant-dir/module/System/NotifyIcon/Win32.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/System/NotifyIcon/Win32.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,456 @@ +# ----------------------------------------------------------------------------- +# $Id: Win32.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +# use shell notify-icon +# based on win32::TaskTray.pm (超ベータVer) by Noboruhi +# ----------------------------------------------------------------------------- +package System::NotifyIcon::Win32; +use strict; +use warnings; +use base qw(Module); +use Win32::GUI (); # non-default +use RunLoop; +use Timer; +use Tiarra::Encoding; +our $AUTOLOAD; +my $can_use_win32api; +BEGIN { + eval q{ use Win32::API; }; + $can_use_win32api = ($@) ? 0 : 1; +} +my $tooltip_length = 64; + +my $event_handler_prefix = 'Win32Event_'; + +sub new { + my $class = shift; + my $this = $class->SUPER::new(@_); + + # 日本語等を使うためには文字コード変換しないといけないと思います。 + # 気をつけてください。 + + # メインウィンドウ(現時点ではダミー) + $this->_event_handler_init; + $this->{main_window} = Win32::GUI::Window->new( + -name => __PACKAGE__ . '::MainWindow', + -text => 'Tiarra GUI', + -width => 200, + -height => 200); + + # コンテキストメニュー + $this->event_handler_register('NotifyIcon_Popup_exit_Click'); + $this->event_handler_register('NotifyIcon_Popup_reload_Click'); + $this->{popup_menu} = Win32::GUI::Menu->new( + "" => __PACKAGE__ . '::NotifyIcon_Popup', + " > &Exit" => { -name => __PACKAGE__ . '::NotifyIcon_Popup_exit' }, + " > -" => 0, + " > Re&load" => { -name => __PACKAGE__ . '::NotifyIcon_Popup_reload', -default => 1 }, + ); + + $this->{window_stat} = 1; # start with show + $this->{console_window} = Win32::GUI::GetPerlWindow(); + + # タスクトレイ登録 + if (defined $this->config->iconfile) { + $this->{icon} = new Win32::GUI::Icon($this->config->iconfile); + } + $this->event_handler_register('NotifyIcon_Click'); + $this->event_handler_register('NotifyIcon_RightClick'); + $this->{notify_icon} = $this->{main_window}->AddNotifyIcon( + -name => __PACKAGE__ . '::NotifyIcon', + (defined $this->{icon} ? (-icon => $this->{icon}) : ())); + + if (defined $this->config->hide_console_on_load && + $this->config->hide_console_on_load) { + $this->Win32Event_NotifyIcon_Click(); + } + + if ($can_use_win32api) { + $this->{notifyicondata_version} = $this->init_win32_api(); + ::debug_printmsg(__PACKAGE__.": use notify_icondata version ". + $this->{notifyicondata_version}); + } + + $this->modify_notifyicon_tooltip(); + $this->{set_nick_hook} = RunLoop::Hook->new( + sub { + my ($hook) = shift; + + $this->modify_notifyicon_tooltip(); + })->install('set-current-nick'); + + return $this; +} + +sub modify_notifyicon_tooltip { + my ($this, $tooltip) = @_; + $tooltip = (defined $tooltip ? "$tooltip - " : ""); + $tooltip .= sprintf("Tiarra #%s\n%s@%d\n", + ::version(), + RunLoop->shared_loop->current_nick, + Configuration->shared_conf->get('general')->tiarra_port, + ); + if (defined RunLoop->shared_loop->sysmsg_prefix(qw(system))) { + $tooltip .= RunLoop->shared_loop->sysmsg_prefix(qw(system)); + } + if (length($tooltip) >= $tooltip_length) { + substr($tooltip,$tooltip_length - 1) = ''; + } + if (!$can_use_win32api || $this->{notifyicondata_version} <= 1) { + # This is internal API! + Win32::GUI::NotifyIcon::Modify($this->{notify_icon}->{-handle}, + -id => $this->{notify_icon}->{-id}, + -tip => $tooltip); + } else { + my ($struct,$ret); + + # setversion + $struct = Win32::API::Struct->new($this->{struct}->{NOTIFYICONDATA}); + $struct->{cbSize} = $struct->sizeof; + $struct->{hWnd} = $this->{notify_icon}->{-handle}; + $struct->{uID} = $this->{notify_icon}->{-id}; + $struct->{uTimeout_or_Version} = $this->{define}->{NOTIFYICON_VERSION}; + $ret = $this->{func}->{Shell_NotifyIcon}->Call( + $this->{define}->{NIM_SETVERSION}, + $struct); + if (!$ret) { + ::debug_printmsg('Shell_NotifyIcon setversion return error:'. + sprintf('%x',$ret)); + }; + + # modify + use Data::Dumper; + ::debug_printmsg(Dumper([$tooltip, substr($tooltip,0,64)])); + $struct = Win32::API::Struct->new($this->{struct}->{NOTIFYICONDATA}); + $struct->{cbSize} = $struct->sizeof; + $struct->{hWnd} = $this->{notify_icon}->{-handle}; + $struct->{uID} = $this->{notify_icon}->{-id}; + $struct->{uFlags} |= $this->{define}->{NIF_TIP}; + if ($this->{is_unicode}) { + $tooltip = Tiarra::Encoding->new($tooltip,'utf8')->utf16; + # reverse endian + $tooltip = pack('n*', unpack('v*', $tooltip)); + } + $struct->{szTip} = $tooltip; + $struct->{uFlags} |= $this->{define}->{NIF_STATE}; + $struct->{dwState} = $this->{define}->{NIS_SHAREDICON}; + $struct->{dwStateMask} = $this->{define}->{NIS_SHAREDICON}; + #$struct->{uFlags} |= $this->{define}->{NIF_ICON}; + #$struct->{hIcon} = $this->{icon}->{-handle}; + #::debug_printmsg(Data::Dumper->Dump([$struct->Pack], [qw(struct)])); + $ret = $this->{func}->{Shell_NotifyIcon}->Call( + $this->{define}->{NIM_MODIFY}, + $struct); + if (!$ret) { + ::debug_printmsg('Shell_NotifyIcon setversion return error:'. + sprintf('%x',$ret)); + }; + } +} + +sub destruct { + my $this = shift; + + $this->uninstall_hook('set_nick_hook'); + undef $this->{main_window}->{-notifyicons}{$this->{notify_icon}->{-id}}; + undef $this->{main_window}->{$this->{notify_icon}->{-name}}; + undef $this->{notify_icon}; + # This is internal API! but WIn32::GUI doesn't call this...(commented out) + eval { Win32::GUI::DestroyWindow($this->{main_window}->{-handle}) }; + undef $this->{main_window}; + undef $this->{popup_menu}; + undef $this->{icon}; + # 終了時にはかならず表示させる + Win32::GUI::Show($this->{console_window}); + undef $this->{shell_notifyicon_func}; + $this->_event_handler_destruct; +} + +sub _event_handler_init { + my $this = shift; + + # 先に定義を必要とするのか、うまく動かない + my $autoload = sub { + my (@args) = @_; + + if ($AUTOLOAD =~ /::DESTROY$/) { + # DESTROYは伝達させない。 + return; + } + + (my $method = $AUTOLOAD) =~ s/.+?:://g; + + # define method + $this->event_handler_register($method); + + no strict 'refs'; + goto &$AUTOLOAD; + }; + *AUTOLOAD = $autoload; + + $this->{timer} = Timer->new( + Repeat => 1, + After => ((defined $this->config->interval) ? $this->config->interval : 2), + Code => sub { + my $timer = shift; + # noop + })->install; + $this->{hook} = RunLoop::Hook->new( + sub { + my $hook = shift; + + no warnings; + Win32::GUI::DoEvents(); + $this->{timer}->reset(); + } + )->install('after-select'); + + return $this; +} + +# uninstall hook or timer +sub uninstall_hook { + my ($this, $name) = @_; + + if (defined $this->{$name}) { + $this->{$name}->uninstall; + delete $this->{$name}; + } +} + +sub event_handler_register { + my $this = shift; + + map { + my $method = $_; + if ($method =~ /^\Q$event_handler_prefix\E/) { + warn ("$method is already have $event_handler_prefix prefix."); + next; + } + $this->{registered_event_handlers}->{$method} = 1; + #::debug_printmsg(__PACKAGE__ . '/register_event_handler: ' . $method); + my $sub = sub { + no strict 'refs'; + unshift(@_, $this); + eval "$event_handler_prefix$method(\@_)"; + }; + eval "*$method = \$sub"; + } @_; + + return $this; +} + +sub event_handler_unregister { + my $this = shift; + + foreach my $name (@_) { + if (exists $this->{registered_event_handlers}->{$_}) { + eval "undef *$name"; + delete $this->{registered_event_handlers}->{$_}; + } + }; + + return $this; +} + +sub _event_handler_destruct { + my $this = shift; + + $this->event_handler_unregister(keys %{$this->{registered_event_handlers}}); + $this->{registered_event_handlers} = {}; + undef *AUTOLOAD; + + $this->uninstall_hook('timer'); + $this->uninstall_hook('hook'); +} + + +# NotifyIcon 用のイベントハンドラ +sub Win32Event_NotifyIcon_Click { + my $this = shift; + + $this->{window_stat} = $this->{window_stat} ? 0 : 1; + if ($this->{window_stat}) { + Win32::GUI::Show( $this->{console_window} ); #コンソールをを出す + } else { + Win32::GUI::Hide( $this->{console_window} ); #コンソールを隠す + } + return -1; +}; + +sub Win32Event_NotifyIcon_RightClick { + my $this = shift; + my($x, $y) = Win32::GUI::GetCursorPos(); + + $this->{main_window}->TrackPopupMenu( + $this->{popup_menu}->{__PACKAGE__ . '::NotifyIcon_Popup'}, + $x,$y); + + return -1; +} + +sub Win32Event_NotifyIcon_Popup_exit_Click { + ::shutdown; + return -1; +} + +sub Win32Event_NotifyIcon_Popup_reload_Click { + Timer->new( + After => 0, + Code => sub { + ReloadTrigger->reload_conf_if_updated; + ReloadTrigger->reload_mods_if_updated; + } + )->install; + + return -1; +} + +sub init_win32_api { + my ($this) = shift; + + # Shell 6.0 or above + Win32::API::Type->typedef(qw(HRESULT LONG)); + + $this->{is_unicode} = Win32::API::IsUnicode(); + $this->{is_unicode} = 1; #FIXME:DEBUG + Win32::API::Type->typedef('TCHAR', + $this->{is_unicode} ? 'WCHAR' : 'CHAR'); + my @base_v1 = qw{ + DWORD cbSize; + HWND hWnd; + UINT uID; + UINT uFlags; + UINT uCallbackMessage; + HICON hIcon; + }; + my @base_v2 = (@base_v1, qw{ + TCHAR szTip[128]; + DWORD dwState; + DWORD dwStateMask; + TCHAR szInfo[256]; + UINT uTimeout_or_Version; + TCHAR szInfoTitle[64]; + DWORD dwInfoFlags; + }); + Win32::API::Struct->typedef( + 'NOTIFYICONDATA_V1', + @base_v1, + qw{ + TCHAR szTip[64]; + }); + Win32::API::Struct->typedef( + 'NOTIFYICONDATA_V2', @base_v2); + Win32::API::Struct->typedef( + 'NOTIFYICONDATA_V3', + @base_v2, + qw{ + DWORD guidItem1; + DWORD guidItem2; + }); + + my $use_notifyicondata_version = 1; + do { + Win32::API::Struct->typedef( + 'DLLVERSIONINFO', + qw{ + DWORD cbSize; + DWORD dwMajorVersion; + DWORD dwMinorVersion; + DWORD dwBuildNumber; + DWORD dwPlatformID; + }); + # ULONGLONG(Quad Octet) is not portable; can't use DLLVERSIONINFO2. + my $dvi_func = Win32::API->new( + 'shell32', 'HRESULT DllGetVersion(LPDLLVERSIONINFO dvi)', + ); + if (defined $dvi_func) { + my $dvi = Win32::API::Struct->new('DLLVERSIONINFO'); + $dvi->{cbSize} = $dvi->sizeof; + my $ret = $dvi_func->Call($dvi); + if ($ret == 0) { # NOERROR + if ($dvi->{dwMajorVersion} >= 6) { + $use_notifyicondata_version = 3; + } elsif ($dvi->{dwMajorVersion} >= 5) { + $use_notifyicondata_version = 2; + } else { + $use_notifyicondata_version = 1; + } + } else { + ::debug_printmsg('DllGetVersion return error:' . sprintf('%x',$ret)); + } + } else { + ::debug_printmsg('cant load DllGetVersion'); + } + }; + if ($use_notifyicondata_version >= 2) { + $tooltip_length = 128; + } + # init + my $define = $this->{define} = {}; + my $struct = $this->{struct} = {}; + my $func = $this->{func} = {}; + $struct->{NOTIFYICONDATA} = + 'NOTIFYICONDATA_V'.$use_notifyicondata_version; + $func->{Shell_NotifyIcon} = Win32::API->new( + 'shell32', + join('', + 'BOOL Shell_NotifyIcon', + ($this->{is_unicode} ? 'W' : 'A'), + '(DWORD dwMessage, ', + ' LP'.$struct->{NOTIFYICONDATA}.' lpdata)'), + #'shell32', 'Shell_NotifyIcon', [qw(L S)], 'C' + ); + do { + my @temp = qw(ADD MODIFY DELETE SETFOCUS SETVERSION); + foreach (0 .. $#temp) { + $define->{'NIM_'.$temp[$_]} = $_; + } + }; + do { + my @temp = qw(MESSAGE ICON TIP STATE INFO GUID); + foreach (0 .. $#temp) { + $define->{'NIF_'.$temp[$_]} = 2 ** $_; + } + }; + do { + my @temp = qw(HIDDEN SHAREDICON); + foreach (0 .. $#temp) { + $define->{'NIS_'.$temp[$_]} = $_; + } + }; + $define->{NIIF_NONE} = 0x00; + $define->{NIIF_INFO} = 0x01; + $define->{NIIF_WARNING} = 0x02; + $define->{NIIF_ERROR} = 0x03; + $define->{NIIF_ICON_MASK} = 0x0F; + $define->{NIIF_NOSOUND} = 0x10; + $define->{NOTIFYICON_VERSION} = 3; + return $use_notifyicondata_version; +} + +1; +=pod +info: タスクトレイにアイコンを表示する。 +default: off +section: important + +# タスクトレイにアイコンを表示します。 +# クリックすると表示非表示を切り替えることができ、右クリックすると +# Reload と Exit ができるコンテキストメニューを表示します。 +# 多少反応が鈍いかもしれませんがちょっと待てば出てくると思います。 + +# Win32::GUI を必要とします。 +# コンテキストメニューは表示している間処理をブロックしています。 + +# Win32 イベントループを処理する最大間隔を指定します。 +-interval: 2 + +# 通知領域に表示するアイコンを指定します。 +# Win32::GUI の制限でちゃんとしたアイコンファイルしか指定できません。 +iconfile: guiperl.ico + +# モジュールが読み込まれたときにコンソールウィンドウを隠すかどうかを +# 指定します。 +hide-console-on-load: 1 +=cut diff -urN /non-existant-dir/module/System/Pong.pm tiarra-20080510/module/System/Pong.pm --- /non-existant-dir/module/System/Pong.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/System/Pong.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,81 @@ +# ----------------------------------------------------------------------------- +# $Id: Pong.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +package System::Pong; +use strict; +use warnings; +use NumericReply; +use base qw(Module); + +sub message_arrived { + my ($this,$message,$sender) = @_; + + if ($message->command eq 'PING') { + my ($prefix) = do { + if ($sender->isa('IrcIO::Server')) { + undef; + } else { + RunLoop->shared_loop->sysmsg_prefix(qw(system)); + } + }; + my ($nick) = do { + if ($sender->isa('IrcIO::Server')) { + $sender->current_nick; + } else { + RunLoop->shared_loop->current_nick; + } + }; + if ($message->n_params < 1) { + # これを送りつけてきたサーバー/クライアントにエラーを返す。 + $sender->send_message( + $this->construct_irc_message( + Prefix => $prefix, + Command => ERR_NOORIGIN, + Params => [ + $nick, + 'No origin specified', + ])); + } else { + my ($target); + if ($sender->isa('IrcIO::Server')) { + $nick = undef; + $target = $sender->server_hostname; + } else { + $target = RunLoop->shared_loop->sysmsg_prefix(qw(system)); + } + # これを送りつけてきたサーバー/クライアントにPONGを送り返す。 + $sender->send_message( + $this->construct_irc_message( + Prefix => $prefix, + Command => 'PONG', + Params => [ + $target, + (defined $nick ? $nick : ()), + ])); + } + # print "System::Pong ponged to ".$message->params->[0].".\n"; + + # PINGメッセージはこれ以上伝達させず、ここで消してしまう。 + return undef; + } + elsif ($message->command eq 'PONG') { + # PONGメッセージはこれ以上伝達させず、ここで消してしまう。 + return undef; + } + else { + return $message; + } +} + +1; + +=pod +info: サーバーからのPINGメッセージに対し、自動的にPONGを返す。 +default: on + +# これをoffにするとクライアントが自らPINGに応答せざるを得なくなりますが、 +# クライアントからのPONGメッセージはデフォルトのサーバーへ送られるので +# デフォルト以外のサーバーからはPing Timeoutで落とされるなど +# 全く良い事がありません。 +# 設定項目はありません。 +=cut diff -urN /non-existant-dir/module/System/PrivTranslator.pm tiarra-20080510/module/System/PrivTranslator.pm --- /non-existant-dir/module/System/PrivTranslator.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/System/PrivTranslator.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,78 @@ +# ----------------------------------------------------------------------------- +# $Id: PrivTranslator.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +package System::PrivTranslator; +use strict; +use warnings; +use base qw(Module); +use Multicast; + +sub NICK_CACHE_EXPIRE_TIME (){ 20 * 60 } +sub NICK_CACHE_EXPIRE_KEY (){ __PACKAGE__ . '/nick-avails' } +sub REMARK_NICK_ATTACHED_KEY (){ __PACKAGE__ . '/nick-attached' } + +sub message_arrived { + my ($this,$msg,$sender) = @_; + if ($this->_runloop->multi_server_mode_p && + $sender->isa('IrcIO::Server') && + defined $msg->nick) { + + my $cmd = $msg->command; + if (($cmd eq 'PRIVMSG' || $cmd eq 'NOTICE') && + !Multicast::channel_p($msg->param(0))) { + $msg->remark(REMARK_NICK_ATTACHED_KEY, [$msg->nick, + $sender->network_name]); + $msg->nick(Multicast::attach($msg->nick, $sender->network_name)); + } + } + $msg; +} + +sub message_io_hook { + my ($this,$msg,$io,$type) = @_; + + if ($this->_runloop->multi_server_mode_p && + $io->isa('IrcIO::Client') && + $type eq 'out') { + my $remark = $io->remark(NICK_CACHE_EXPIRE_KEY) || {}; + if (my $info = $msg->remark(REMARK_NICK_ATTACHED_KEY)) { + $remark->{$info->[1]}->{$info->[0]} = time() + NICK_CACHE_EXPIRE_TIME; + $io->remark(NICK_CACHE_EXPIRE_KEY, $remark); + } elsif ($msg->command eq 'NICK') { + if (defined $msg->generator) { + if ($msg->generator->can('network_name')) { + my $network_name = $msg->generator->network_name; + my $nick = $msg->nick; + my $time = delete $remark->{$network_name}->{$nick}; + if (defined $time && + $time >= time()) { + my $nick_to = $msg->param(0); + + # update expire place + $remark->{$network_name}->{$nick_to} = $time; + + # duplicate nick message + my $new_msg = $msg->clone; + $new_msg->nick(Multicast::attach($nick, $network_name)); + $new_msg->param(0, Multicast::attach($nick_to, $network_name)); + return ($msg, $new_msg); + } + } + } + } + } + return $msg; +} + + +1; +=pod +info: クライアントからの個人的なprivが相手に届かなくなる現象を回避する。 +default: on +section: important + +# このモジュールは個人宛てのprivmsgの送信者のnickにネットワーク名を付加します。 +# また、最後に声をかけられてから5分以内の nick 変更をクライアントに伝えます。 +# 設定項目はありませんが、 networks/channel-network-separator を ! や @ 以外に +# 変更することをおすすめします。 +=cut diff -urN /non-existant-dir/module/System/Raw.pm tiarra-20080510/module/System/Raw.pm --- /non-existant-dir/module/System/Raw.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/System/Raw.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,73 @@ +# ----------------------------------------------------------------------------- +# $Id: Raw.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +package System::Raw; +use strict; +use warnings; +use base qw(Module); +use Mask; +use NumericReply; + +sub message_arrived { + my ($this, $msg, $sender) = @_; + if ($sender->client_p and + $msg->command eq uc($this->config->command || 'raw')) { + # 最低限パラメタは二つ必要。 + if ($msg->n_params < 2) { + $sender->send_message( + $this->construct_irc_message( + Prefix => RunLoop->shared_loop->sysmsg_prefix(qw(system)), + Command => ERR_NEEDMOREPARAMS, + Params => [ + RunLoop->shared->current_nick, + "command `".$msg->command."' requires 2 or more parameters", + ])); + } + else { + # 送り先の鯖を知る。これはマスク。 + my $target = $msg->param(0); + + # メッセージ再構築 + my $raw_msg = $this->construct_irc_message( + Line => join(' ', @{$msg->params}[1 .. ($msg->n_params - 1)]), + Encoding => 'utf8', + ); + + # 送信先マスクにマッチするネットワーク全てにこれを送る。 + my $sent; + foreach my $network (RunLoop->shared->networks_list) { + if (Mask::match($target, $network->network_name)) { + $network->send_message($raw_msg); + $sent = 1; + } + } + if (!$sent) { + $sender->send_message( + $this->construct_irc_message( + Prefix => RunLoop->shared_loop->sysmsg_prefix(qw(priv system)), + Command => 'NOTICE', + Params => [ + RunLoop->shared->current_nick, + "*** no networks matches to `$target'", + ])); + } + } + $msg = undef; # 破棄 + } + $msg; +} + +1; +=pod +info: マスクで指定したサーバーにIRCメッセージを加工せずに直接送る。 +default: off + +# 例えばQUITを送る事で一時的な切断が可能。 + +# この機能を利用するためのコマンド名。デフォルトは「raw」。 +# 「/raw ircnet quit」のようにして使う。 +# 一つ目のパラメータは送り先のネットワーク名。ワイルドカード使用可能。 +# CHOCOA の場合、 raw がクライアントで使われてしまうので、 +# コマンド名を変えるか、 /raw raw ircnet quit のようにする必要がある。 +command: raw +=cut diff -urN /non-existant-dir/module/System/Reload.pm tiarra-20080510/module/System/Reload.pm --- /non-existant-dir/module/System/Reload.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/System/Reload.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,78 @@ +# ----------------------------------------------------------------------------- +# $Id: Reload.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +package System::Reload; +use strict; +use warnings; +use base qw(Module); +use ReloadTrigger; +use Timer; +use Configuration; +use Mask; +use RunLoop; + +sub new { + my $class = shift; + my $this = $class->SUPER::new(@_); + + if (!defined $this->config->conf_reloaded_notify || + $this->config->conf_reloaded_notify) { + $this->{conf_hook} = Configuration::Hook->new( + sub { + my ($hook) = shift; + RunLoop->shared_loop->notify_msg("Reloaded configuration file."); + })->install('reloaded'); + } + return $this; +} + +sub destruct { + my $this = shift; + + $this->{conf_hook}->uninstall if defined $this->{conf_hook}; + $this->{conf_hook} = undef; +} + +sub message_arrived { + my ($this,$msg,$sender) = @_; + my $do_reload = 0; + + # クライアントの発言か？ + if ($sender->isa('IrcIO::Client')) { + # コマンド名は一致してるか？ + if (Mask::match_deep([$this->config->broadcast_command('all')], + $msg->command)) { + RunLoop->shared_loop->broadcast_to_servers($msg->clone); + $do_reload = 1; + } elsif (Mask::match_deep([$this->config->command('all')], + $msg->command)) { + $do_reload = 1; + } + } + if ($do_reload) { + # 必要ならリロードを実行。 + ReloadTrigger->_install_reload_timer; + return undef; + } + return $msg; +} + +1; +=pod +info: confファイルやモジュールの更新をリロードするコマンドを追加する。 +default: on + +# リロードを実行するコマンド名。省略されるとコマンドを追加しません。 +# 例えば"load"を設定すると、"/load"と発言しようとした時にリロードを実行します。 +# この時コマンドはTiarraが握り潰すので、IRCプロトコル上で定義された +# コマンド名を設定すべきではありません。 +command: load + +# command と同じですが、サーバにもブロードキャストします。 +-broadcast-command: load-all + +# confファイルをリロードしたときに通知します。 +# モジュールの設定が変更されていた場合は、ここでの設定にかかわらず、 +# モジュールごとに表示されます。1または省略された場合は通知します。 +conf-reloaded-notify: 1 +=cut diff -urN /non-existant-dir/module/System/RemoteControl.pm tiarra-20080510/module/System/RemoteControl.pm --- /non-existant-dir/module/System/RemoteControl.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/System/RemoteControl.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,47 @@ +# ----------------------------------------------------------------------------- +# $Id: RemoteControl.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +package System::RemoteControl; +use strict; +use warnings; +use base qw(Module); +use Mask; + +sub message_arrived { + my ($this,$msg,$sender) = @_; + if ($sender->isa('IrcIO::Server') && + $msg->command eq 'PRIVMSG' && + Mask::match_deep([defined($this->config->mask) ? $this->config->mask('all') : '*!*@*'], + $msg->prefix)) { + + my ($nick,$cmd) = $msg->param(1) =~ m/^\+\s+(.+?)\s+(.+)$/; + # 指定されたnickに自分はマッチするか？ + if (Mask::match($nick,$sender->current_nick) && + defined $cmd) { + # 実行。 + $sender->send_message( + $this->construct_irc_message( + Line => $cmd, + Encoding => 'utf8')); + } + } + $msg; +} + +1; + +=pod +info: 特定の発言が送られてきたとき、それに反応してIRCコマンドを実行します。 +default: off + +# 実行を許可する人間を表すマスク。 +-mask: *!*example@example.net + +# 構文: + +# は反応するbotのnickを表すマスク。 +# はサーバーに向けて発行するIRCメッセージ。 +# +# 例: +# + hoge NICK [hoge] +# hogeというBOTが[hoge]にnickを変更する。 +=cut diff -urN /non-existant-dir/module/System/SendMessage.pm tiarra-20080510/module/System/SendMessage.pm --- /non-existant-dir/module/System/SendMessage.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/System/SendMessage.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,70 @@ +# ----------------------------------------------------------------------------- +# $Id: SendMessage.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +# SendMessage - メッセージを外部から送信するためのモジュール。 +# ----------------------------------------------------------------------------- +# Copyright (C) 2004 Yoichi Imai +package System::SendMessage; +use strict; +use warnings; +use base qw(Module); +use Mask; +use Multicast; +use ControlPort; +use Auto::Utils; +use Tiarra::Utils; + +sub control_requested { + my ($this,$request) = @_; + # 外部コントロールプログラムからのメッセージが来た。 + # 戻り値はControlPort::Reply。 + # + # $request: + # 内容 : ControlPort::Request + # 送られたリクエスト + + # << NOTIFY System::SendMessage TIARRACONTROL/1.0 + # << Channel: !????channel@network + # << Charset: UTF-8 + # << Text: message + + # >> TIARRACONTROL/1.0 200 OK + + my $mask = $request->table->{Channel}; + my $text = $request->table->{Text}; + my $command = utils->cond_yesno($request->table->{Notice}, 1) ? + 'NOTICE' : 'PRIVMSG'; + unless ($mask) { + return new ControlPort::Reply(403, "Channel is not set"); + } + unless ($text) { + return new ControlPort::Reply(403, "Doesn't have remark"); + } + + my ($channel_mask, $network_name) = Multicast::detach($mask); + + my $server = $this->_runloop->network($network_name); + unless (defined $server) { + return new ControlPort::Reply(404, "Server Not Found"); + } + + my $matched = 0; + + foreach my $chinfo ($server->channels_list) { + if (Mask::match_array([$channel_mask], $chinfo->name)) { + ++$matched; + Auto::Utils::sendto_channel_closure( + $chinfo->fullname, $command, undef, undef, undef, 0 + )->($text); + } + } + if ($matched) { + my $reply = ControlPort::Reply->new(200, 'OK'); + $reply->MatchedChannels($matched); + return $reply; + } else { + return new ControlPort::Reply(404, "Channel Not Found"); + } +} + +1; diff -urN /non-existant-dir/module/System/Shutdown.pm tiarra-20080510/module/System/Shutdown.pm --- /non-existant-dir/module/System/Shutdown.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/System/Shutdown.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,67 @@ +# ----------------------------------------------------------------------------- +# $Id: Shutdown.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +package System::Shutdown; +use strict; +use warnings; +use base qw(Module); +use Mask; + +sub message_arrived { + my ($this,$msg,$sender) = @_; + + if ($sender->isa('IrcIO::Client')) { + # クライアントからのコマンド + if ($msg->command eq uc($this->config->command)) { + # どうせクライアントへは送られないがメッセージ表示 + RunLoop->shared->notify_msg( + "System::Shutdown received shutdown command from client."); + ::shutdown(join(' ', @{$msg->params}));; + } + } + elsif ($sender->isa('IrcIO::Server')) { + # privか？ + if (defined $msg->nick && + $msg->param(0) eq RunLoop->shared->current_nick && + ($msg->command eq 'PRIVMSG' || $msg->command eq 'NOTICE')) { + my ($command, $message) = split(/\s+/, $msg->param(1)); + # 発言内容はmessageに完全一致しているか？ + if (Mask::match_deep([$this->config->message('all')], + $command)) { + # 発言者はmaskにマッチするか？ + if (Mask::match_deep([$this->config->mask('all')], + $msg->prefix)) { + # どうせクライアントには送られないがメッセージ表示 + RunLoop->shared->notify_msg( + "System::Shutdown received shutdown command from ".$msg->prefix."."); + ::shutdown($message); + } + } + } + } + $msg; +} + +1; + +=pod +info: Tiarraを終了させる。 +default: off + +# クライアントから特定のコマンドが実行された時や、 +# 誰かから個人的に(privで)特定の発言が送られた時に +# Tiarra を終了させます。 + +# 追加するコマンド。省略された場合はコマンドでのシャットダウンは無効になります。 +-command: shutdown + +# Tiarraをシャットダウンさせるprivの発言。 +# 省略された場合はprivでのシャットダウンは無効になります。 +# パラメータとして shutdown メッセージを指定できます。 +-message: shutdown + +# privでのシャットダウンを許可する人。 +# 省略された場合はprivでのシャットダウンは無効になります。 +# 複数のマスクを指定した場合は、一つでもマッチするものがあればシャットダウンします。 +-mask: example!example@*.example.jp +=cut diff -urN /non-existant-dir/module/System/WebClient.pm tiarra-20080510/module/System/WebClient.pm --- /non-existant-dir/module/System/WebClient.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/System/WebClient.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,1549 @@ +## ---------------------------------------------------------------------------- +# System::WebClient. +# ----------------------------------------------------------------------------- +# Mastering programmed by YAMASHINA Hio +# +# Copyright 2008 YAMASHINA Hio +# ----------------------------------------------------------------------------- +# $Id: WebClient.pm 11017 2008-05-03 06:45:50Z hio $ +# ----------------------------------------------------------------------------- +package System::WebClient; +use strict; +use warnings; +use Module; +use base 'Module'; +use Tools::HTTPServer; +use Tools::HTTPParser; +use Log::Logger; +use Auto::Utils; +use BulletinBoard; +use Module::Use qw(Tools::HTTPServer Tools::HTTPParser Log::Logger Auto::Utils); + +use IO::Socket::INET; +use Scalar::Util qw(weaken); + +our $DEBUG = 0; + +our $DEFAULT_MAX_LINES = 100; +our $DEFAULT_NAME = '???'; +our $DEFAULT_SHOW_LINES = 20; + +1; + +# ----------------------------------------------------------------------------- +# $pkg->new(). +# (impl:tiarra-module) +# +# +sub new +{ + my $pkg = shift; + my $this = $pkg->SUPER::new(@_); + + local($DEBUG) = $DEBUG || $this->config->debug; + $DEBUG and require Data::Dumper; + + my $has_lwp = $Tools::HTTPServer::Client::HAS_HTTP_PARSER; + $this->_runloop->notify_msg(__PACKAGE__.", Tools::HTTPServer uses HTTP::Parser: ".($has_lwp?"yes":"no")); + + $this->{last_sender} = undef; + $this->{last_msg} = undef; + $this->{last_line} = undef; + $this->{logger} = Log::Logger->new( + sub { $this->_log_writer(@_) }, + $this, + qw(S_PRIVMSG C_PRIVMSG S_NOTICE C_NOTICE), + ); + + # トップ何行かのキャッシュ. + $this->{bbs_val} = undef; + $this->{cache} = undef; + $this->_load_cache(); + + my $config = $this->config; + my $host = $config->bind_addr || '127.0.0.1'; + my $port = $config->bind_port || 8667; + my $path = $config->path || '/'; + $path =~ m{^/} or $path = "/$path"; + $path =~ m{/$} or $path = "$path/"; + + $this->{host} = $host; + $this->{port} = $port; + $this->{path} = $path; + + $this->{listener} = undef; + + $this->_start_listener(); + + $this; +} + +# ----------------------------------------------------------------------------- +# $this->destruct(). +# (impl:tiarra-module) +# +sub destruct +{ + my $this = shift; + + local($DEBUG) = $DEBUG || $this->config->debug; + + if( my $lsnr = $this->{listener} ) + { + if( $lsnr->installed ) + { + $lsnr->uninstall(); + } + $lsnr->close(); + $this->{listener} = undef; + } + + # 循環参照の切断. + $this->{logger} = undef; + + $this->{bbs_val}{unloaded_at} = time; + $this->_debug(__PACKAGE__."->destruct(), done."); +} + +# ----------------------------------------------------------------------------- +# $obj->_load_cache(). +# 有効にされる前のぶんとかをキャッシュに反映. +# +sub _load_cache +{ + my $this = shift; + + my $runloop = $this->_runloop; + my $BBS_KEY = __PACKAGE__.'/cache'; + my $BBS_VAL = BulletinBoard->shared->get($BBS_KEY); + if( !$BBS_VAL ) + { + $runloop->notify_msg(__PACKAGE__."#_load_cache, bbs[$BBS_KEY] initialize"); + $BBS_VAL = { + inited_at => time, + unloaded_at => 0, + cache => {}, + }; + BulletinBoard->shared->set($BBS_KEY, $BBS_VAL); + } + + $this->{bbs_val} = $BBS_VAL; + $this->{cache} = $BBS_VAL->{cache}; + + $runloop->notify_msg(__PACKAGE__."#_load_cache, bbs[$BBS_KEY].inited_at ".localtime($BBS_VAL->{inited_at})); + $runloop->notify_msg(__PACKAGE__."#_load_cache, bbs[$BBS_KEY].unloaded_at ".($BBS_VAL->{unloaded_at}?localtime($BBS_VAL->{unloaded_at}):'-')); + + my $networks = $runloop->networks('even-if-not-connected'); + + my %channels; + foreach my $network (values %$networks) + { + my $netname = $network->network_name; + my $channels = $network->channels('even-if-kicked-out'); + foreach my $channel (values %$channels) + { + my $channame = $channel->name; + $this->{cache}{$netname}{$channame} ||= $this->_new_cache_entry($netname, $channame); + } + } +} + + +sub _new_cache_entry +{ + my $this = shift; + my $netname = shift; + my $ch_short = shift; + +{ + recent => [], + }; +} + +# ----------------------------------------------------------------------------- +# $obj->message_io_hook($msg, $sender, $type). +# (impl:tiarra-module) +# +sub message_arrived +{ + my ($this,$msg,$sender) = @_; + + my $cmd = $msg->command; + if( $cmd ne 'PRIVMSG' && $cmd ne 'NOTICE' ) + { + $this->_trace_msg($msg, $sender, ''); + } + + $msg; +} + +sub message_io_hook +{ + my ($this,$msg,$sender,$type) = @_; + my @ret = ($msg); + + if( $sender->isa('IrcIO::Server') ) + { + # Serverとのio-hookのみ利用. + # なおかつPRIVMSG/NOTICE のみ. + my $cmd = $msg->command; + if( $cmd eq 'PRIVMSG' || $cmd eq 'NOTICE' ) + { + # PRIVMSG/NOTICE はserverゆきのメッセージを利用. + my $msg = $msg->clone; + + # サーバゆきのチャンネル名になっているので, ch_full に書き換え. + $msg->param(0, Multicast::attach($msg->param(0), $sender->network_name)); + + my $dummy; + if( $type eq 'out' ) + { + # 送信だったらclientからおくられたように偽装. + $dummy = bless \my$x, 'IrcIO::Client'; + $sender = $dummy; + } + + eval{ + $this->_trace_msg($msg, $sender, $type); + }; + if( $@ ) + { + $this->_runloop->notify_error(__PACKAGE__."#message_io_hook: _trace_msg: $@"); + } + + if( $dummy ) + { + # デストラクタが呼ばれないように差し替えて破棄. + bless $dummy, 'UNIVERSAL'; + } + } + } + + @ret; +} + +# ----------------------------------------------------------------------------- +# $this->_trace_msg($msg, $sender, ''). // from message_arrived. +# $this->_trace_msg($msg, $sender, $type). // from message_io_hook. +# +sub _trace_msg +{ + my $this = shift; + my $msg = shift; + my $sender = shift; + my $type = shift; + + local($DEBUG) = $DEBUG || $this->config->debug; + + ##RunLoop->shared_loop->notify_msg(__PACKAGE__."#_trace_msg, ".$msg->command." ($sender/$type)"); + + $this->{last_sender} = $sender; + $this->{last_msg} = $msg; + $this->{last_line} = undef; + eval{ + $this->{logger}->log($msg,$sender); + }; + $this->{last_sender} = undef; + $this->{last_msg} = undef; + $this->{last_line} = undef; + if( $@ ) + { + RunLoop->shared_loop->notify_error(__PACKAGE__."#_trace_msg, ".$@); + } +} + +# ----------------------------------------------------------------------------- +# $this->S_PRIVMSG(..) +# $this->C_PRIVMSG(..) +# $this->S_NOTICE(..) +# $this->C_NOTICE(..) +# (impl/log-formatter). +# デフォルトのだとprivが寂しいのでトラップ. +# +{ +no warnings 'once'; +*S_PRIVMSG = \&PRIVMSG_or_NOTICE; +*S_NOTICE = \&PRIVMSG_or_NOTICE; +*C_PRIVMSG = \&PRIVMSG_or_NOTICE; +*C_NOTICE = \&PRIVMSG_or_NOTICE; +} + +sub PRIVMSG_or_NOTICE +{ + my ($this,$msg,$sender) = @_; + my $line = $this->{logger}->_build_message($msg, $sender); + $this->{last_line} = $line; + [$line->{ch_long}, $line->{line}]; +} + +# ----------------------------------------------------------------------------- +# $this->_log_writer(). +# (impl/log-writer). +# +sub _log_writer +{ + my ($this, $channel, $line) = @_; + my $info = $this->{last_line}; + + #RunLoop->shared_loop->notify_msg(">> $channel $line"); + if( !$info ) + { + # PRIVMSG/NOTICE 以外. + my $sender = $this->{last_sender}; + + my ($ch_short, $netname, $explicit) = Multicast::detach($channel); + $explicit or $netname = $this->{last_sender}->network_name; + $info = { + netname => $netname, + ch_short => $ch_short, + msg => $line, + formatted => $line, + }; + }else + { + # チャンネル名なしに整形し直し. + $line = sprintf( + '%s%s%s %s', + $info->{marker}[0], + $info->{speaker}, + $info->{marker}[1], + $info->{msg}, + ); + }; + my $netname = $info->{netname}; + my $ch_short = $info->{ch_short}; + + my @tm = localtime(time()); + $tm[5] += 1900; + $tm[4] += 1; + my $time = sprintf('%02d:%02d:%02d', @tm[2,1,0]); + $info->{tm} = \@tm; + $info->{time} = $time; + $info->{ymd} = sprintf('%04d-%02d-%02d', @tm[5,4,3]); + $info->{formatted} = "$time $line"; + + #RunLoop->shared_loop->notify_msg(__PACKAGE__."#_log_writer, $netname, $ch_short, [$channel] $line"); + + my $cache = $this->{cache}{$netname}{$ch_short}; + if( !$cache ) + { + $cache = $this->{cache}{$netname}{$ch_short} = $this->_new_cache_entry($netname, $ch_short); + } + + my $recent = $cache->{recent}; + my $prev = @$recent && $recent->[-1]; + $info->{lineno} = $prev && $prev->{ymd} eq $info->{ymd} ? $prev->{lineno} + 1 : 1; + + push(@$recent, $info); + my $limit = $this->config->max_lines || 0; + $limit =~ s/^0+//; + if( !$limit || $limit !~ /^[1-9]\d*\z/ ) + { + $limit = $DEFAULT_MAX_LINES; + } + @$recent > $limit and @$recent = @$recent[-$limit..-1]; +} + +# ----------------------------------------------------------------------------- +# $this->_start_listener(). +# new()の時に呼ばれる. +# Tools::HTTPServer を起動. +# +sub _start_listener +{ + my $this = shift; + + my $host = $this->{host}; + my $port = $this->{port}; + my $path = $this->{path}; + + my $lsnr = Tools::HTTPServer->new(); + $lsnr->start( + Host => $host, + Port => $port, + Path => $path, + CallbackObject => $this, + ); + RunLoop->shared_loop->notify_msg(__PACKAGE__.", listen on ".$lsnr->where); + + $this->{listener} = $lsnr; + + $this; +} + +# ----------------------------------------------------------------------------- +# $this->_debug($msg). +# デバッグメッセージ送信用. +# +sub _debug +{ + my $this = shift; + my $msg = shift; + RunLoop->shared_loop->notify_msg($msg); +} + +# ----------------------------------------------------------------------------- +# $this->_on_request($cli, $req). +# (impl:HTTPServer-callback) +# +sub _on_request +{ + my $this = shift; + my $cli = shift; + my $req = shift; + + local($DEBUG) = $DEBUG || $this->config->debug; + + my $peer = $cli->sock->peerhost .':'. $cli->sock->peerport; + foreach my $eff ( $this->config->extract_forwarded_for('all') ) + { + local($Tools::HTTPParser::DEBUG) = $Tools::HTTPParser::DEBUG || $DEBUG; + my $allows = [ split( /\s+|\s*,\s*/, $eff ) ]; + if( @$allows && Tools::HTTPParser->extract_forwarded_for($req, $allows) ) + { + $peer = "$req->{RemoteAddr}($peer)"; + last; + } + } + $DEBUG and print __PACKAGE__."#_on_request, peer=$peer, ".Data::Dumper->new([$req])->Dump; + + my $conflist = $this->_find_conf($req); + $req = { + %$req, + client => $cli, + peer => $peer, + conflist => $conflist, + need_auth => 1, + ua_type => undef, + cgi_hash => undef, # generated on demand. + req_param => undef, # generated on demand. + }; + if( my $ua = $req->{Header}{'User-Agent'} ) + { + if( $ua =~ /(UP\.Browser|DoCoMo|J-PHONE|Vodafone|SoftBank)/i ) + { + $req->{ua_type} = 'mobile'; + }else + { + $req->{ua_type} = 'pc'; + } + }else + { + $req->{ua_type} = 'pc'; + } + + if( $req->{Method} !~ /^(GET|POST|HEAD)\z/ ) + { + $this->_debug("$peer: method not allowed: $req->{Method}"); + # 405 Method Not Allowed + $this->_response($req, 405); + return; + } + + if( !@$conflist ) + { + $this->_debug("$peer: Forbidden by no conf"); + # 403 Forbidden. + $this->_response($req, 403); + return; + } + + my ($user, $pass); + if( my $line = $req->{Header}{Authorization} ) + { + my ($type, $val) = split(' ', $line, 2); + if( $type eq 'Basic' ) + { + require MIME::Base64; + my $dec = MIME::Base64::decode($val); + ($user,$pass) = split(/:/, $dec, 2); + } + } + my $need_auth = 1; + if( !$user ) + { + @$conflist = grep{ !$_->{auth} } @$conflist; + }else + { + @$conflist = grep{ + my $auth = $_->{auth}; + my ($auth_user,$auth_pass) = split(' ', $auth); + $auth_pass = _decode_value($auth_pass); + $auth_user eq $user && $auth_pass eq $pass; + } @$conflist; + } + $need_auth = @$conflist==0; + + if( $req->{Path} =~ /\?auth(?:=|[&;]|$)/ ) + { + $need_auth = 1; + } + if( $need_auth ) + { + $this->_debug("$peer: response: Authenticate Required"); + my $realm = 'Authenticate Required'; + # 401 Unauthorized + my $res = { + Code => 401, + Header => { + 'WWW-Authenticate' => qq{Basic realm="$realm"}, + }, + }; + $this->_response($req, $res); + return; + } + + $this->_debug("$peer: accept."); + $this->_dispatch($req); +} + + +sub _dispatch +{ + my $this = shift; + my $req = shift; + + my $path = $req->{Path}; + if( $path !~ s{\Q$this->{path}}{/} ) + { + $this->_response($req, 404); + return; + } + $path =~ s/\?.*//; + + if( $path eq '/' ) + { + my $done = $req->{Method} eq 'POST' && $this->_post_list($req); + if( !$done ) + { + my $html = $this->_gen_list($req); + $this->_response($req, [html=>$html]); + } + }elsif( $path =~ m{^/log/} ) + { + my ($_blank, $_cmd, $netname, $ch_short, $param) = split('/', $path, 5); + if( !defined($param) ) + { + if( !$netname || !$ch_short ) + { + $this->_location($req, "/"); + }else + { + $this->_location($req, "/log/$netname/$ch_short/"); + } + return; + } + + $ch_short =~ s/%([0-9a-f]{2})/pack("H*",$1)/gie; + $ch_short =~ s/^=// or $ch_short = '#'.$ch_short; + if( !$this->{cache}{$netname}{$ch_short} ) + { + use Unicode::Japanese; + my $ch2 = Unicode::Japanese->new($ch_short,'sjis')->utf8; + if( $this->{cache}{$netname}{$ch2} ) + { + $ch_short = $ch2; + }else + { + RunLoop->shared_loop->notify_msg(__PACKAGE__."#_dispatch($path), not in cache ($netname/$ch_short)"); + $this->_response($req, 404); + return; + } + } + if( !$this->_can_show($req, $ch_short, $netname) ) + { + #RunLoop->shared_loop->notify_msg(__PACKAGE__."#_dispatch($path), could not show ($netname/$ch_short)"); + $this->_response($req, 404); + return; + } + #RunLoop->shared_loop->notify_msg(__PACKAGE__."#_dispatch($path), ok ($netname/$ch_short/$param)"); + if( $param eq '' ) + { + my $done = $req->{Method} eq 'POST' && $this->_post_log($req, $netname, $ch_short); + if( !$done ) + { + my $html = $this->_gen_log($req, $netname, $ch_short); + $this->_response($req, [html=>$html]); + } + }elsif( $param eq 'info' ) + { + my $done = $req->{Method} eq 'POST' && $this->_post_chan_info($req, $netname, $ch_short); + if( !$done ) + { + my $html = $this->_gen_chan_info($req, $netname, $ch_short); + $this->_response($req, [html=>$html]); + } + }else + { + $this->_response($req, 404); + } + }elsif( $path eq '/style/style.css' ) + { + $this->_response($req, [css=>'']); + }else + { + $this->_response($req, 404); + } +} + +sub _response +{ + my $this = shift; + my $req = shift; + my $res = shift; + if( ref($res) eq 'ARRAY' ) + { + my $spec = $res; + if( $spec->[0] eq 'html' ) + { + my $html = $spec->[1]; + $res = { + Code => 200, + Header => { + 'Content-Type' => 'text/html; charset=utf-8', + 'Content-Length' => length($html), + }, + Content => $html, + }; + }elsif( $spec->[0] eq 'css' ) + { + my $css = $spec->[1]; + $res = { + Code => 200, + Header => { + 'Content-Type' => 'text/css; charset=utf-8', + 'Content-Length' => length($css), + }, + Content => $css, + }; + }else + { + die "unkown response spec: $spec->[0]"; + } + } + + my $cli = $req->{client}; + $cli->response($res); + + # no Keep-Alive. + $req->{client}->disconnect_after_writing(); + + return; +} + +sub _location +{ + my $this = shift; + my $req = shift; + my $path = shift; + + $path = $this->{path} . $path; + $path =~ s{//+}{/}g; + my $res = { + Code => 302, + Header => { + 'Location' => $path, + }, + }; + $this->_response($req, $res); +} + +# ----------------------------------------------------------------------------- +# $conflist = $this->_find_conf($req). +# $conflist: この接続元に対して利用可能な allow 情報の一覧. +# この時点ではまだ接続元IPアドレスでのチェックのみ. +# +sub _find_conf +{ + my $this = shift; + my $req = shift; + my $peerhost = $req->{RemoteAddr}; + + my @conflist; + + my $config = $this->config; + foreach my $key (map{split(' ',$_)}$config->allow('all')) + { + my $name = "allow-$key"; + my $block = $config->$name('block') or next; + my $hosts = [$block->host('all')]; + my $match = Mask::match_deep($hosts, $peerhost); + defined($match) or next; + $match or last; + my $allow = { + name => $name, + block => $block, + masks => [$block->mask('all')], # 公開するチャンネルの一覧. + auth => $block->auth, + }; + push(@conflist, $allow); + } + + \@conflist; +} + +# ----------------------------------------------------------------------------- +# $val = _decode_value($val). +# "{B}xxx" とかのデコード. +# +sub _decode_value +{ + my $val = shift; + if( $val && $val =~ s/^\{(.*?)\}// ) + { + my $type = $1; + if( $type =~ /^(B|B64|BASE64)\z/ ) + { + eval { require MIME::Base64; }; + if( $@ ) + { + die "no MIME::Base64"; + } + $val = MIME::Base64::decode($val); + }else + { + die "unsupported packed value, type=$type"; + } + } + $val; +} + +# ----------------------------------------------------------------------------- +# $bool = $this->_can_show($req, $ch_short, $netname). +# 閲覧可能かの判定. +# 存在するかどうかは別途確認が必要. +# +sub _can_show +{ + my $this = shift; + my $req = shift; + my $ch_short = shift; + my $netname = shift; + my $conflist = $req->{conflist}; + + my $ch_full = Multicast::attach($ch_short, $netname); + foreach my $allow (@$conflist) + { + my $ok = Mask::match_deep($allow->{masks}, $ch_full); + $this->_debug("- $netname / $ch_short = ".($ok?"ok":"ng")." ".join(", ",@{$allow->{masks}})); + if( $ok ) + { + return $ok; + } + } + return; # false. +} + +# ----------------------------------------------------------------------------- +# $html = $this->_gen_list($req). +# +sub _gen_list +{ + my $this = shift; + my $req = shift; + + my $peerhost = $req->{peerhost}; + my $conflist = $req->{conflist}; + + my %channels; + foreach my $netname (keys %{$this->{cache}}) + { + foreach my $ch_short (keys %{$this->{cache}{$netname}}) + { + my $ok = $this->_can_show($req, $ch_short, $netname); + if( $ok ) + { + push(@{$channels{$netname}}, $ch_short); + } + } + } + + my $content = ""; + $content .= "
    \n"; + if( keys %channels ) + { + foreach my $netname (sort keys %channels) + { + $content .= "
  • $netname\n"; + $content .= "
      \n"; + my @channels = @{$channels{$netname}}; + @channels = sort @channels; + foreach my $channame (@channels) + { + my $link_ch = $channame; + $link_ch =~ s/^#// or $link_ch = "=$link_ch"; + my $link = "log\0$netname\0$link_ch\0"; + $link =~ s{/}{%2F}g; + $link =~ tr{\0}{/}; + $link = $this->_escapeHTML($link); + $content .= qq{
    • $channame
      • \n}; + } + $content .= "
    \n"; + $content .= "
    • \n"; + } + }else + { + $content = "
  • no channels
    • \n"; + } + $content .= "
\n"; + + my $tmpl = $this->_gen_list_html(); + $this->_expand($tmpl, { + CONTENT => $content, + UA_TYPE => $req->{ua_type}, + }); +} +sub _gen_list_html +{ + < + + + + + + + + channels + + +
+
+ +

channels

+ +<&CONTENT> + +
+ENTER: +
+
+ +

+[ +再表示[0] +] +

+ +
+
+ + +HTML +} + +sub _post_list +{ + my $this = shift; + my $req = shift; + + my $cgi = $this->_get_cgi_hash($req); + if( my $ch_long = $cgi->{enter} ) + { + my ($ch_short, $netname) = Multicast::detach($ch_long); + if( !$this->_can_show($req, $ch_short, $netname) ) + { + return; + } + my $network = $this->_runloop->network($netname); + if( $network ) + { + $this->{cache}{$netname}{$ch_short} ||= $this->_new_cache_entry($netname, $ch_short); + $this->_debug("enter: $netname/$ch_short"); + my $link_ch = $ch_short; + $link_ch =~ s/^#// or $link_ch = "=$link_ch"; + my $link = "log\0$netname\0$link_ch\0"; + $link =~ s{/}{%2F}g; + $link =~ tr{\0}{/}; + $this->_location($req, $link); + return 1; + } + } + return undef; +} + +sub _expand +{ + my $this = shift; + my $tmpl = shift; + my $vars = shift; + + my $top_path_esc = $this->_escapeHTML($this->{path}); + my $css_esc = $this->_escapeHTML($this->config->css || "$this->{path}style/style.css"); + my $common_vars = { + TOP_PATH => $top_path_esc, + CSS => $css_esc, + }; + + $tmpl =~ s{<&(.*?)>}{ + my $key = $1; + if( defined($vars->{$key}) ) + { + $vars->{$key}; + }elsif( defined($common_vars->{$key}) ) + { + $common_vars->{$key}; + }else + { + die "unexpanded key: $key"; + } + }ge; + + $tmpl; +} + +# ----------------------------------------------------------------------------- +# $html = $this->_gen_log($req, $netname, $ch_short). +# +sub _gen_log +{ + my $this = shift; + my $req = shift; + my $netname = shift; + my $ch_short = shift; + + # cacheにはいっているのと閲覧許可があるのは確認済. + + my $content = ""; + + if( my $net = $this->_runloop->network($netname) ) + { + if( my $chan = $net->channel($ch_short) ) + { + my $topic = $chan->topic || '(no-topic)'; + my $names = $chan->names || {}; + $names = [ values %$names ]; + @$names = map{ + my $pic = $_; # $pic :: PersonInChannel. + my $nick = $pic->person->nick; + my $sigil = $pic->priv_symbol; + "$sigil$nick"; + } @$names; + @$names = sort @$names; + my $topic_esc = $this->_escapeHTML($topic); + my $names_esc = $this->_escapeHTML(join(' ', @$names)); + $content .= "

\n"; + $content .= "TOPIC: $topic_esc
\n"; + #$content .= "member: $names_esc
\n"; + $content .= "

\n"; + } + }else + { + } + + my $cache = $this->{cache}{$netname}{$ch_short}; + my $recent = $cache->{recent}; + my $cgi = $this->_get_cgi_hash($req); + + # 表示位置の探索. + my $show_lines = $DEFAULT_SHOW_LINES; + my $rindex; + if( my $rtoken = $cgi->{r} ) + { + my $re = qr/\Q$rtoken\E\z/; + my $ymd = '-'; + foreach my $i (0..$#$recent) + { + my $info = $recent->[$i]; + if( $ymd ne $info->{ymd} ) + { + $ymd = $info->{ymd}; + my $anchor = "L.$ymd"; + if( $anchor =~ $re ) + { + $rindex = $i; + last; + } + } + my $anchor = "L.$ymd.$info->{lineno}"; + if( $anchor =~ $re ) + { + $rindex = $i; + last; + } + } + }else + { + if( @$recent > $show_lines ) + { + $rindex = @$recent - $show_lines; + } + } + $rindex ||= 0; + # $rindex も含めてindex系は [0..$#$recent] の範囲の値. + + my $last; + if( $rindex + $show_lines > @$recent ) + { + $last = $#$recent; + }else + { + $last = $rindex + $show_lines - 1; + } + + my $next_index = $last < $#$recent ? $last + 1 : $#$recent; + my $prev_index = $rindex < $show_lines ? 0 : ($rindex - $show_lines); + my ($next_rtoken, $prev_rtoken) = map { + my $i = $_; + my $info = $recent->[$i]; + my $anchor = "L.$info->{ymd}.$info->{lineno}"; + $anchor =~ s/.*-//; + $anchor; + } $next_index, $prev_index; + + my $nr_cached_lines = @$recent; + my $lines2 = $nr_cached_lines==1 ? 'line' : 'lines'; + $recent = [ @$recent [ $rindex .. $last ] ]; + + my $navi_raw = ''; + if( @$recent ) + { + my $sort_order = $this->_get_req_param($req, 'sort-order'); + $this->_debug("sort_order = $sort_order"); + if( $sort_order ne 'asc' ) + { + @$recent = reverse @$recent; + } + my $nr_recent = @$recent; + my $lines = $nr_recent==1 ? 'line' : 'lines'; + $navi_raw .= "

"; + $navi_raw .= "$nr_recent $lines / $nr_cached_lines $lines2.
"; + $navi_raw .= qq{[ <<[7] |}; + $navi_raw .= qq{ >>[9] ]\n}; + $navi_raw .= "

"; + + my $ymd = '-'; # first entry should be displayed. + $content .= "
";
+    foreach my $info (@$recent)
+    {
+      if( $ymd ne $info->{ymd} )
+      {
+        $ymd = $info->{ymd};
+        my $anchor = "L.$ymd";
+        my $rtoken = $ymd;
+        $content .= qq{[$ymd]\n};
+      }
+      my $line_html = $this->_escapeHTML($info->{formatted});
+      if( $req->{ua_type} ne 'pc' )
+      {
+        $line_html =~ s/^(\d\d:\d\d):\d\d /$1 /;
+      }
+      my $anchor = "L.$ymd.$info->{lineno}";
+      my $rtoken = $anchor;
+      $rtoken =~ s/.*-//;
+      $content .= qq{$info->{lineno}/$line_html\n};
+    }
+    $content .= "
\n"; + }else + { + $content .= "

\n"; + $content .= "no lines."; + $content .= "

\n"; + } + + my $ch_long = Multicast::attach($ch_short, $netname); + my $ch_long_esc = $this->_escapeHTML($ch_long); + my $name_esc = $this->_escapeHTML($cgi->{n} || ''); + + my $mode = $this->_get_req_param($req, 'mode'); + my $name_input_raw = ''; + if( $mode ne 'owner' ) + { + $name_input_raw = qq{name:
}; + } + + my $tmpl = $this->_gen_log_html(); + $this->_expand($tmpl, { + CONTENT_RAW => $content, + UA_TYPE => $req->{ua_type}, + NAVI_RAW => $navi_raw, + CH_LONG => $ch_long_esc, + NAME => $name_esc, + NAME_INPUT_RAW => $name_input_raw, + RTOKEN => $next_rtoken, + NEXT_RTOKEN => $next_rtoken, + PREV_RTOKEN => $prev_rtoken, + }); +} +sub _gen_log_html +{ + < + + + + + + + + <&CH_LONG> + + +
+
+ +

<&CH_LONG>

+ +<&CONTENT_RAW> + +
+

+talk: +
+<&NAME_INPUT_RAW> + +

+
+ +<&NAVI_RAW> + +

+[ +更新[*] | +List[0] | +info[#] +] +

+ +
+
+ + +HTML +} + +sub _get_req_param +{ + my $this = shift; + my $req = shift; + my $key = shift; + + if( !grep{ $key eq $_ } qw(mode sort-order) ) + { + die "invalid req-param [$key]"; + } + if( $req->{req_param}{$key} ) + { + return $req->{req_param}{$key}; + } + + my $val; + foreach my $allow (@{$req->{conflist}}) + { + $val = $allow->{block}->$key; + $val or next; + $DEBUG and $this->_debug(__PACKAGE__."#_gen_log, $key = $val (by $allow->{name})"); + last; + } + $val ||= $this->config->$key; + if( $key eq 'mode' ) + { + $val ||= 'owner'; + if( $val !~ /^(owner|shared)\z/ ) + { + $val = 'owner'; + } + } + if( $key eq 'sort-order' ) + { + $val ||= 'asc'; + $val = $val =~ /^(desc|rev)/ ? 'desc' : 'asc'; + } + + $req->{req_param}{$key} = $val; + $val; +} + +sub _get_cgi_hash +{ + my $this = shift; + my $req = shift; + + if( $req->{cgi_hash} ) + { + return $req->{cgi_hash}; + } + + my $cgi = {}; + + if( $req->{Method} eq 'GET' ) + { + if( $req->{Path} =~ m{\?} ) + { + (undef,my $query) = split(/\?/, $req->{Path}); + foreach my $pair (split(/[&;]/, $query)) + { + my ($key, $val) = split(/=/, $pair, 2); + $val =~ s/%([0-9a-f]{2})/pack("H*",$1)/gie; + $cgi->{$key} = $val; + } + } + } + + if( $req->{Method} eq 'POST' ) + { + foreach my $pair (split(/[&;]/, $req->{Content})) + { + my ($key, $val) = split(/=/, $pair, 2); + $val =~ s/%([0-9a-f]{2})/pack("H*",$1)/gie; + $cgi->{$key} = $val; + } + } + + $req->{cgi_hash} = $cgi; + $cgi; +} + +sub _post_log +{ + my $this = shift; + my $req = shift; + my $netname = shift; + my $ch_short = shift; + + my $mode = $this->_get_req_param($req, 'mode'); + + my $cgi = $this->_get_cgi_hash($req); + my $name = $cgi->{n} || ''; + if( my $m = $cgi->{m} ) + { + if( $mode ne 'owner' ) + { + $m = ($name || $this->config->name_default || $DEFAULT_NAME) . "> " . $m; + } + $m =~ s/[\r\n].*//s; + my $network = RunLoop->shared_loop->network($netname); + if( $network ) + { + my $channel = $network->channel($ch_short); + if( $channel || !Multicast::channel_p($ch_short) ) + { + my $msg_to_send = Auto::Utils->construct_irc_message( + Command => 'PRIVMSG', + Params => [ '', $m ], + ); + + # send to server. + # + { + my $for_server = $msg_to_send->clone; + $for_server->param(0, $ch_short); + $network->send_message($for_server); + } + + # send to clients. + # + my $ch_on_client = Multicast::attach_for_client($ch_short, $netname); + my $for_client = $msg_to_send->clone; + $for_client->param(0, $ch_on_client); + $for_client->remark('fill-prefix-when-sending-to-client', 1); + RunLoop->shared_loop->broadcast_to_clients($for_client); + }else + { + RunLoop->shared_loop->notify_error("no such channel [$ch_short] on network [$netname]"); + } + }else + { + RunLoop->shared_loop->notify_error("no network to talk: $netname"); + } + } + return undef; +} + +# ----------------------------------------------------------------------------- +# $html = $this->_gen_chan_info($req, $netname, $ch_short). +# +sub _gen_chan_info +{ + my $this = shift; + my $req = shift; + my $netname = shift; + my $ch_short = shift; + + my $content_raw = ""; + + my ($topic_esc, $names_esc); + if( my $net = $this->_runloop->network($netname) ) + { + if( my $chan = $net->channel($ch_short) ) + { + my $topic = $chan->topic || '(none)'; + my $names = $chan->names || {}; + $names = [ values %$names ]; + @$names = map{ + my $pic = $_; # $pic :: PersonInChannel. + my $nick = $pic->person->nick; + my $sigil = $pic->priv_symbol; + "$sigil$nick"; + } @$names; + @$names = sort @$names; + $topic_esc = $this->_escapeHTML($topic); + $names_esc = $this->_escapeHTML(join(' ', @$names)); + } + }else + { + } + $topic_esc ||= '-'; + $names_esc ||= '-'; + + my $in_topic_esc; + my $cgi = $this->_get_cgi_hash($req); + if( my $in_topic = $cgi->{topic} ) + { + $in_topic_esc = $this->_escapeHTML($in_topic); + }else + { + $in_topic_esc = $topic_esc; + } + + my $ch_long = Multicast::attach($ch_short, $netname); + my $ch_long_esc = $this->_escapeHTML($ch_long); + + my $tmpl = $this->_tmpl_chan_info(); + $this->_expand($tmpl, { + CONTENT_RAW => $content_raw, + UA_TYPE => $req->{ua_type}, + CH_LONG => $ch_long_esc, + TOPIC => $topic_esc, + IN_TOPIC => $in_topic_esc, + NAMES => $names_esc, + PART_MSG => 'Leaving...', + }); +} +sub _tmpl_chan_info +{ + < + + + + + + + + <&CH_LONG> + + +
+
+ +

<&CH_LONG>

+ +<&CONTENT_RAW> + +
+TOPIC: <&TOPIC>
+ +
+
+ +

+NAMES: <&NAMES>
+

+ +
+PART: +
+
+ +
+JOIN +
+
+ +
+DELETE +
+
+ +

+[ +戻る[*] | +List[0] | +再表示[#] +] +

+ +
+
+ + +HTML +} + +sub _post_chan_info +{ + my $this = shift; + my $req = shift; + my $netname = shift; + my $ch_short = shift; + + my $cgi = $this->_get_cgi_hash($req); + if( exists($cgi->{topic}) ) + { + my $msg_to_send = Auto::Utils->construct_irc_message( + Command => 'TOPIC', + Params => [ '', $cgi->{topic} ], + ); + + # send to server. + # + my $network = RunLoop->shared_loop->network($netname); + if( $network ) + { + my $for_server = $msg_to_send->clone; + $for_server->param(0, $ch_short); + $network->send_message($for_server); + } + } + + if( exists($cgi->{part}) ) + { + my $msg_to_send = Auto::Utils->construct_irc_message( + Command => 'PART', + Params => [ '', $cgi->{part} ], + ); + + # send to server. + # + my $network = RunLoop->shared_loop->network($netname); + if( $network ) + { + my $for_server = $msg_to_send->clone; + $for_server->param(0, $ch_short); + $network->send_message($for_server); + } + } + + if( exists($cgi->{join}) ) + { + my $msg_to_send = Auto::Utils->construct_irc_message( + Command => 'JOIN', + Params => [ '' ], + ); + + # send to server. + # + my $network = RunLoop->shared_loop->network($netname); + if( $network ) + { + my $for_server = $msg_to_send->clone; + $for_server->param(0, $ch_short); + $network->send_message($for_server); + } + } + + if( exists($cgi->{'delete'}) ) + { + delete $this->{cache}{$netname}{$ch_short}; + if( !keys %{$this->{cache}{$netname}} ) + { + delete $this->{cache}{$netname}; + } + $this->_location($req, "/"); + return 1; + } + + return undef; +} + +# ----------------------------------------------------------------------------- +# $txt = $this->_escapeHTML($html). +# +sub _escapeHTML +{ + my $this = shift; + Tools::HTTPParser->escapeHTML(@_); +} + +# ----------------------------------------------------------------------------- +# End of Module. +# ----------------------------------------------------------------------------- +# ----------------------------------------------------------------------------- +# End of File. +# ----------------------------------------------------------------------------- +__END__ + +=encoding utf8 + +=for stopwords + YAMASHINA + Hio + ACKNOWLEDGEMENTS + AnnoCPAN + CPAN + RT + +package System::WebClient; + +=begin tiarra-doc + +info: ブラウザ上でログを見たり発言したりできます. +default: off +#section: important + +# WebClient を起動させる場所の指定. +bind-addr: 127.0.0.1 +bind-port: 8668 +path: /irc +css: /style/irc-style.css +# 上の設定をapacheでReverseProxyさせる場合, httpd.conf には次のように設定. +# ProxyPass /irc/ http://localhost:8667/irc/ +# ProxyPassReverse /irc/ http://localhost:8667/irc/ +# +# ... +# + +# ReverseProxy 利用時の追加設定. +# 接続元が全部プロキシサーバになっちゃうのでその対応. +-extract-forwarded-for: 127.0.0.1 + +# 利用する接続設定の一覧. +# +# 空白区切りで評価する順に記述. +# 使われる設定は, +# - 接続元 IP が一致する物. +# - user/passが送られてきていない(認証前/anonymous): +# - 認証不要の設定があればその設定を利用. +# - 認証不要の設定がなければ 401 Unauthorized. +# - user/passが送られてきている. +# - 一致する設定を利用. +# - 一致する設定がなければ 401 Unauthorized. +allow: private public + +# 許可する接続の設定. +allow-private { + # 接続元IPアドレスの制限. + host: 127.0.0.1 + # 認証設定. + auth: user pass + # 公開するチャンネルの指定. + mask: #*@* + mask: *@* +} +allow-public { + host: * + auth: user2 pass2 + mask: #公開チャンネル@ircnet +} + +# デバッグフラグ. +-debug: 0 + +# 保存する最大行数. +-max-lines: 100 + +# クライアントモード. +# owner か shared. +- mode: owner + +# ログの方向. +# asc (旧->新) か desc (新->旧). +- sort-order: asc + +# 発言BOXで名前指定しなかったときのデフォルトの名前. +# mode: shared の時に使われる. +-name-default: (noname) + +=end tiarra-doc + +=cut diff -urN /non-existant-dir/module/Tools/DateConvert.pm tiarra-20080510/module/Tools/DateConvert.pm --- /non-existant-dir/module/Tools/DateConvert.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/Tools/DateConvert.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,281 @@ +# ----------------------------------------------------------------------------- +# $Id: DateConvert.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +# これはTiarraモジュールではありません。 +# %Yや%mなどを置換する機能を提供します。 +# ----------------------------------------------------------------------------- +# copyright (C) 2003 Topia . all rights reserved. + +# This module is supports POSIX strftime; based NetBSD libc strftime. +# On PurePerl, Locale, timezone, and '%V', '%G', '%g' is not supported. +# so use localized constants; +# ex. %z => '$TIMEZONE_NAME'. +package Tools::DateConvert; +use strict; +use warnings; +use Carp; + +our ($can_use_posix, $use_posix); + +eval 'use POSIX'; +unless ($@) { # successful loading POSIX; + $use_posix = $can_use_posix = 1; +} else { + $use_posix = $can_use_posix = 0; + print "------can't use POSIX...\n$@\n------\n"; +} + +#constants; +my ( + $TIME_SEC, # 0 + $TIME_MIN, # 1 + $TIME_HOUR, # 2 + $TIME_DAY, # 3 + $TIME_MON, # 4 + $TIME_YEAR, # 5 + $TIME_WDAY, # 6 + $TIME_YDAY, # 7 + $TIME_ISDST # 8 + ) = (0...8); +my ($DAYSPERWEEK) = 7; +my ($YEAROFFSET) = 1900; +my ($HOURSPERDAY) = 24; +my ($HALF_HOURSPERDAY) = $HOURSPERDAY / 2; +#localized constants; +my (@DAYS) = qw(Sun Mon Tues Wednes Thurs Fri Satur); +my (@MONTHS) = qw(January February March April May June July August September October November December); +my ($FORMAT) = '%a %b %e %H:%M:%S %Y'; +my ($TIME_FORMAT) = '%H:%M:%S'; +my ($DATE_FORMAT) = '%m/%d/%y'; +my ($TIMEZONE_NAME) = 'JST'; +my ($TIMEZONE_OFFSET) = '+0900'; +my (@AM_PM) = qw(AM PM); + +sub import { + my $pkg = shift; + foreach (@_) { + if ($_ eq 'PurePerl') { + $use_posix = 0; + } + } +} + +sub unimport { + my $pkg = shift; + foreach (@_) { + if ($_ eq 'PurePerl') { + $use_posix = $can_use_posix; + #carp 'can\'t use posix. no longer effective.' unless $use_posix; + } + } +} + +sub force { + my ($posix) = @_; + + carp 'this is old interface. use "use Tools::DateConvert qw(PurePerl);" instead.'; + + if (defined($posix)) { + if ($posix == 1) { # force use POSIX + $use_posix = 1; + } elsif ($posix == 0) { + $use_posix = 0; + } else { + croak 'force(posix) is only (0,1,undef) value.'; + } + } +} + +sub replace { + my ($str, $time, $pureperl) = @_; + $time = time() unless defined $time; + my (@times) = localtime($time); + my ($temp) = $time; + local $use_posix = $use_posix; + if ($pureperl) { $use_posix = 0; } + + $str =~ s/%([+-]\d+[Oo]|.)/_replace_real($1, $time, \$temp, \@times)/eg; + return $str; +} + +sub expand { + my ($str, %opts) = @_; + my $time = $opts{time}; + $time = time() unless defined $time; + my (@times) = localtime($time); + my $curtime = $time; + local $use_posix = $opts{pureperl} ? 0 : $use_posix; + my $to_locale = $opts{locale}; + my $from_locale; + + eval { + if (defined $to_locale && $use_posix) { + eval { + $from_locale = POSIX::setlocale(&POSIX::LC_TIME, $to_locale); + }; + } + $str =~ s/%([+-]\d+[Oo]|.)/_replace_real($1, $time, \$curtime, \@times)/eg; + }; + my $err = $@; + if (defined $from_locale) { + eval { + POSIX::setlocale(&POSIX::LC_TIME, $from_locale); + }; + } + if ($err) { + die $err; + } + return $str; +} + +sub _replace_real { + my ($tag, $origtime, $time, $times) = @_; + my ($fmt) = '%02d'; + my ($data) = ''; + + if ($tag eq '%') { + $fmt = ''; + $data = $tag; + } elsif ($tag =~ /([+-]\d)?([Oo])/) { + # change times array.... + my ($number, $each); + $number = $1; + $each = $2; + $number = 0 unless defined $number; + + if ($each eq 'O') { # each day + $$time = $origtime + $number * 24 * 3600; + } else { # 'o', each second + $$time = $origtime + $number; + } + + @$times = localtime($$time); + $fmt = ''; + $data = ''; + } elsif ($use_posix == 1) { + $fmt = ''; + $data = POSIX::strftime('%' . $tag, @$times); + } else { + if ($tag eq 'A') { + $fmt = ''; + $data = @DAYS[$$times[$TIME_WDAY]] . 'day'; + } elsif ($tag eq 'a') { + $fmt = ''; + $data = substr(@DAYS[$$times[$TIME_WDAY]], 0, 3); + } elsif ($tag eq 'B') { + $fmt = ''; + $data = @MONTHS[$$times[$TIME_MON]]; + } elsif ($tag eq 'b' || $tag eq 'h') { + $fmt = ''; + $data = substr(@MONTHS[$$times[$TIME_MON]], 0, 3); + } elsif ($tag eq 'C') { + $data = ($$times[$TIME_YEAR] + $YEAROFFSET) / 100; + } elsif ($tag eq 'c') { + $fmt = ''; + $data = replace($FORMAT, $$time); + } elsif ($tag eq 'D') { + $fmt = ''; + $data = replace('%m/%d/%y', $$time); + } elsif ($tag eq 'd') { + $data = $$times[$TIME_DAY]; + # C99 locale modifiers: 'Ox' and 'Ex' is ommited. + } elsif ($tag eq 'e') { + $fmt = '%2d'; + $data = $$times[$TIME_DAY]; + } elsif ($tag eq 'F') { + $fmt = ''; + $data = replace('%Y-%m-%d', $$time); + } elsif ($tag eq 'H') { + $data = $$times[$TIME_HOUR]; + } elsif ($tag eq 'I') { + $data = $$times[$TIME_HOUR] % $HALF_HOURSPERDAY; + $data = 12 if $data == 0; + } elsif ($tag eq 'j') { + $fmt = '%03d'; + $data = $$times[$TIME_YDAY] + 1; + } elsif ($tag eq 'k') { + $fmt = '%2d'; + $data = $$times[$TIME_HOUR]; + } elsif ($tag eq 'l') { + $fmt = '%2d'; + $data = $$times[$TIME_HOUR] % $HALF_HOURSPERDAY; + $data = $HALF_HOURSPERDAY if $data == 0; + } elsif ($tag eq 'M') { + $data = $$times[$TIME_MIN]; + } elsif ($tag eq 'm') { + $data = $$times[$TIME_MON] + 1; + } elsif ($tag eq 'n') { + $fmt = ''; + $data = "\n"; + } elsif ($tag eq 'p') { + $fmt = ''; + if ($$times[$TIME_HOUR] < $HALF_HOURSPERDAY) { + $data = $AM_PM[0]; + } else { + $data = $AM_PM[1]; + } + } elsif ($tag eq 'R') { + $fmt = ''; + $data = replace('%H:%M', $$time); + } elsif ($tag eq 'r') { + $fmt = ''; + $data = replace('%I:%M:%S %p', $$time); + } elsif ($tag eq 'S') { + $data = $$times[$TIME_SEC]; + } elsif ($tag eq 's') { + $fmt = '%d'; + $data = $$time; + } elsif ($tag eq 'T') { + $fmt = ''; + $data = replace('%H:%M:%S', $$time); + } elsif ($tag eq 't') { + $fmt = ''; + $data = "\t"; + } elsif ($tag eq 'U') { + $data = ($$times[$TIME_YDAY] + $DAYSPERWEEK - $$times[$TIME_WDAY]) / $DAYSPERWEEK; + } elsif ($tag eq 'u') { + $fmt = '%d'; + $data = $$times[$TIME_WDAY]; + $data = $DAYSPERWEEK if $data == 0; + } elsif ($tag eq 'V' || $tag eq 'G' || $tag eq 'g') { + # not supported + $fmt = ''; + $data = ''; + } elsif ($tag eq 'v') { + $fmt = ''; + $data = replace('%e-%b-%Y', $$time); + } elsif ($tag eq 'W') { + $data = $$times[$TIME_WDAY]; + $data = $DAYSPERWEEK if $data == 0; + $data = ($$times[$TIME_YDAY] + $DAYSPERWEEK - $data - 1) / $DAYSPERWEEK; + } elsif ($tag eq 'w') { + $fmt = '%d'; + $data = $$times[$TIME_WDAY]; + } elsif ($tag eq 'X') { + $fmt = ''; + $data = replace($TIME_FORMAT, $$time); + } elsif ($tag eq 'x') { + $fmt = ''; + $data = replace($DATE_FORMAT, $$time); + } elsif ($tag eq 'y') { + $data = $$times[$TIME_YEAR] % 100; + } elsif ($tag eq 'Y') { + $fmt = '%d'; + $data = $$times[$TIME_YEAR] + $YEAROFFSET; + } elsif ($tag eq 'Z') { + $fmt = ''; + $data = $TIMEZONE_NAME; + } elsif ($tag eq 'z') { + $fmt = ''; + $data = $TIMEZONE_OFFSET; + } else { + $fmt = ''; + $data = ''; + } + } + + return sprintf($fmt, $data) if $fmt ne ''; + return $data; +} + +1; diff -urN /non-existant-dir/module/Tools/FileCache/EachFile.pm tiarra-20080510/module/Tools/FileCache/EachFile.pm --- /non-existant-dir/module/Tools/FileCache/EachFile.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/Tools/FileCache/EachFile.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,110 @@ +# -*- cperl -*- +# ----------------------------------------------------------------------------- +# $Id: EachFile.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +# copyright (C) 2003 Topia . all rights reserved. +package Tools::FileCache::EachFile; +use strict; +use warnings; +use Carp; +use Module::Use qw(Tools::LinedDB); +use Tools::LinedDB; +use Tiarra::Utils; +our $AUTOLOAD; + +my $timeout = 2.5 * 60; + +sub new { + my ($class, $parent, $fpath, $mode, $charset) = @_; + + my ($this) = { + parent => $parent, + mode => undef, + database => undef, + refcount => 0, + expire => undef, + }; + + if ($mode =~ /raw/i) { + $this->{mode} = 'raw'; + $this->{database} = + Tools::LinedDB->new( + FilePath => $fpath, + Charset => $charset, + ); + } elsif ($mode =~ /std/i) { + $this->{mode} = 'std'; + $this->{database} = + Tools::LinedDB->new( + FilePath => $fpath, + Charset => $charset, + Parse => sub { + my ($line) = @_; + $line =~ s/^\s+//; + return () if $line =~ /^[\#\;]/; + $line =~ s/\s+$//; + return () if $line eq ''; + return $line; + }, + ); + } else { + croak 'can\'t understand type "' . $mode . '"'; + } + + bless $this, $class; + + return $this; +} + + +sub register { + my $this = shift; + + $this->add_ref; + $this; +} + +sub unregister { + my $this = shift; + + $this->release; + $this; +} + +Tiarra::Utils->define_attr_getter(0, qw(refcount expire)); + +sub add_ref { ++(shift->{refcount}); } +sub release { --(shift->{refcount}); } +sub can_remove { (shift->refcount <= 0); } + +sub set_expire { + my ($this) = @_; + + $this->{expire} = time() + $timeout; + return $this; +} + +sub clean { + my ($this) = @_; + + $this->{database} = undef; +} + +sub AUTOLOAD { + my ($this, @args) = @_; + + if ($AUTOLOAD =~ /::DESTROY$/) { + # DESTROYは伝達させない。 + return; + } + + (my $method = $AUTOLOAD) =~ s/.+?:://g; + + # define method + eval "sub $method { shift->{database}->$method(\@_); }"; + + no strict 'refs'; + goto &$AUTOLOAD; +} + +1; diff -urN /non-existant-dir/module/Tools/FileCache.pm tiarra-20080510/module/Tools/FileCache.pm --- /non-existant-dir/module/Tools/FileCache.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/Tools/FileCache.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,173 @@ +# -*- cperl -*- +# ----------------------------------------------------------------------------- +# Tools::FileCache, Data shared file cache service. +# ----------------------------------------------------------------------------- +# $Id: FileCache.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +# copyright (C) 2003 Topia . all rights reserved. +package Tools::FileCache; +use strict; +use warnings; +use RunLoop; +use Carp; +use Tiarra::SharedMixin; +use Module::Use qw(Tools::FileCache::EachFile); +use Tools::FileCache::EachFile; +our $_shared_instance; + +sub _new { + my $class = shift; + my ($this) = { + files => {}, + + timer => undef, + }; + bless $this, $class; + + return $this; +} + +sub find_file { + my ($class_or_this, $fpath, $mode, $charset) = @_; + my $this = $class_or_this->_this; + + my $file = $this->{files}->{$fpath}; + if (defined($file)) { + # とりあえずファイルは存在した。 + my $obj = $file->{$mode}; + if (defined($obj)) { + # そのモードも存在した。オブジェクトを返す。 + return $obj; + } else { + # そのモードは存在しなかった。登録して返す。 + return $this->_register_inner($fpath, $mode, $charset); + } + } else { + # ファイルは存在しない。登録して返す。 + return $this->_register_inner($fpath, $mode, $charset); + } +} + +sub register { + my ($class_or_this, $fpath, $mode, $charset) = @_; + my $this = $class_or_this->_this; + + my $file = $this->find_file($fpath, $mode, $charset); + if (defined $file) { + # ファイルがあった or ファイルを登録した。 + # 参照回数を増やして返す。 + $file->register(); + return $file; + } else { + # ファイルの登録が出来なかった。 + return undef; + } +} + +sub unregister { + my ($class_or_this, $fpath) = @_; + my $this = $class_or_this->_this; + + my $file = $this->{files}->{$fpath}; + if (defined($file)) { + $file->unregister(); + return 0; + } else { + croak('file "' . $fpath . '" has not registered yet!'); + } +} + +sub _register_inner { + my ($class_or_this, $fpath, $mode, $charset) = @_; + my $this = $class_or_this->_this; + + my $obj = Tools::FileCache::EachFile->new($this, $fpath, $mode, $charset); + if (defined $obj) { + $this->{files}->{$fpath} = {} unless (defined($this->{files}->{$fpath})); + $this->{files}->{$fpath}->{$mode} = $obj; + $this->_install_timer(); + return $obj; + } else { + return undef; + } +} + +sub main_loop { + my $this = shift; + + # check expire + foreach my $key (keys(%{$this->{files}})) { + my $file = $this->{files}->{$key}; + foreach my $mode (keys(%$file)) { + my $obj = $file->{$mode}; + if ($obj->can_remove() && ($obj->expire() < time())) { + # expired. + $obj->clean(); + delete $this->{files}->{$key}->{$mode}; + } + } + if (scalar(keys(%$file)) == 0) { + delete $this->{files}->{$key}; + } + } + + # check struct-size + if (scalar(keys(%{$this->{files}})) == 0) { + $this->_uninstall_timer(); + } +} + +sub destruct { + my $this = shared; + + # expire all + foreach my $key (keys(%{$this->{files}})) { + my $file = $this->{files}->{$key}; + foreach my $mode (keys(%$file)) { + my $obj = $file->{$mode}; + $obj->clean(); + delete $this->{files}->{$key}->{$mode}; + } + delete $this->{files}->{$key}; + } + + # re-run main_loop (for uninstall timer) + $this->main_loop(); +} + +# misc/timer +sub _check_timer { + my $this = shift; + + return defined($this->{timer}); +} + +sub _install_timer { + my $this = shift; + + unless ($this->_check_timer) { + $this->{timer} = Timer->new( + Interval => 30, + Repeat => 1, + Code => sub { + my $timer = shift; + $this->main_loop(); + }, + )->install(); + } + + return 0; +} + +sub _uninstall_timer { + my $this = shift; + + if ($this->_check_timer()) { + $this->{timer}->uninstall; + $this->{timer} = undef; + } + + return 0; +} + +1; diff -urN /non-existant-dir/module/Tools/GroupDB.pm tiarra-20080510/module/Tools/GroupDB.pm --- /non-existant-dir/module/Tools/GroupDB.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/Tools/GroupDB.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,583 @@ +# -*- cperl -*- +# ----------------------------------------------------------------------------- +# $Id: GroupDB.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +# エイリアスのように、HashをレコードとしたDBを管理する。 +# ----------------------------------------------------------------------------- +# copyright (C) 2003-2004 Topia . all rights reserved. + + +# - 情報(注意) - +# * キー名に半角スペースは含められません。 error が出ます。 +# * 値の先頭、最後にある空白文字(\s)は読み込み時に消失します。 +# * 機能不足です。 +# * コードが読みにくいです。 + +# technical information +# - datafile format +# | abc: def +# -> key 'abc', value 'def' +# | : abc : def +# -> key ':abc:', value 'def' +# LINE := KEY ANYSPACES [value] ANYSPACES が基本。 +# KEY := ANYSPACES [keyname] ANYSPACES ':' || ANYSPACES ':' [keyname] ':' +# ANYSPACES := REGEXP:\s* +# [keyname] にはコロンをスペースに変換したキー名が入る。 +# キー名の先頭または最後にスペースがある場合は、KEYの後者のフォーマットを使用する。 +# [value] はそのまま。つまり複数行になるデータは追加できない。エラーを出すべきか? + +package Tools::GroupDB; +use strict; +use warnings; +use IO::File; +use File::stat; +use Tiarra::Encoding; +use Mask; +use Carp; +use Module::Use qw(Tools::Hash Tools::HashTools); +use Tools::Hash; +use Tools::HashTools; +use Tiarra::Utils; +use Tiarra::ModifiedFlagMixin; +use Tiarra::SessionMixin; +use base qw(Tiarra::SessionMixin); +use base qw(Tiarra::Utils); + +sub new { + # コンストラクタ + + # - 引数 - + # $fpath : 保存するファイルのパス。空ファイル or undef でファイルに関連付けられないDBが作成されます。 + # $primary_key + # : 主キーを設定します。データベース的な利点はまったくありません(笑)が、適当に作って下さい。 + # $split_primaryが指定されていない場合は undef を渡すことが出来ます。 + # $charset : ファイルの文字セットを指定します。省略すれば UTF-8 になります。 + # $split_primary + # : true なら、データファイルからの読み込み時に、$primary_keyで区切ります。 + # そうでなければデータの無い行が区切りになります。省略されれば false です。 + # $use_re : 値の検索/一致判定に正規表現拡張を使うかどうか。省略されれば使いません。 + # $ignore_proc + # : 無視する行を指定するクロージャ。行を引数に呼び出され、 true が返ればその行を無視します。 + # ここで ignore された行は解析さえ行いませんので、 + # $split_primary=0でも区切りと認識されたりはしません。 + # 一般的な注意として、この状態のデータベースが保存された場合は ignore された行は全て消滅します。 + + my ($class,$fpath,$primary_key,$charset,$split_primary,$use_re,$ignore_proc) = @_; + + if (defined $primary_key) { + if ($primary_key =~ / /) { + croak('primary_key name "'.$primary_key.'" include space!') + } + } else { + croak('primary_key not defined, but split_primary is true!') if $split_primary; + } + + my $this = { + time => undef, # ファイルの最終読み込み時刻 + fpath => $fpath, + primary_key => $primary_key, + split_primary => $split_primary || 0, + charset => $charset || 'utf8', # ファイルの文字コード + use_re => $use_re || 0, + ignore_proc => $ignore_proc || sub { $_[0] =~ /^\s*#/; }, + cleanup_queued => undef, + + caller_name => $class->simple_caller_formatter('GroupDB registered'), + database => undef, # ARRAY + # <キー SCALAR,値の集合 ARRAY> + }; + + bless $this,$class; + $this->clear_modified; + $this->_session_init; + $this->_load; +} + +__PACKAGE__->define_attr_accessor(0, + qw(time fpath charset), + qw(primary_key split_primary), + qw(cleanup_queued)); +__PACKAGE__->define_session_wrap(0, + qw(checkupdate synchronize cleanup)); + +sub name { + my $this = shift; + join('/', $this->{caller_name}, + (defined $this->fpath ? $this->fpath : ())); +} + +sub _load { + my $this = shift; + my $database = []; + + if (defined $this->fpath && $this->fpath ne '') { + my $fh = IO::File->new($this->fpath,'r'); + if (defined $fh) { + my $current = {}; + my $flush = sub { + if ((!$this->split_primary && scalar(%$current)) || + (defined $this->primary_key && + defined $current->{$this->primary_key})) { + push @{$database}, Tools::Hash->new($this, $current); + $current = {}; + } + }; + my $unicode = Tiarra::Encoding->new; + foreach (<$fh>) { + my $line = $unicode->set($_, $this->charset)->get; + next if $this->{ignore_proc}->($line); + my ($key,$value) = grep {defined($_)} + ($line =~ /^\s*(?:([^:]+?)\s*|:([^:]+?)):\s*(.+?)\s*$/); + if (!defined $key || $key eq '' || + !defined $value || $value eq '') { + if (!$this->split_primary) { + $flush->(); + } + } else { + # can use colon(:) on key, but cannot use space( ). + $key =~ s/ /:/g; + if ($this->split_primary && + $key eq $this->primary_key) { + $flush->(); + } + push(@{$current->{$key}}, $value); + } + } + $flush->(); + $this->{database} = $database; + $this->set_time; + $this->clear_modified; + $this->dequeue_cleanup; + } + } + return $this; +} + +sub _match { + my ($this, $value, $str) = @_; + + Mask::match_array($value, $str, 1, $this->{use_re}, 0); +} + +sub _check_primary_key { + my $this = shift; + + croak "primary_key not defined; can't use this method." + unless defined $this->primary_key; +} + +sub _check_no_primary_key { + my $this = shift; + + croak "primary_key defined; can't use this method." + if defined $this->primary_key; +} + +sub _check_primary_key_dups { + my ($this, @values) = @_; + + $this->_check_primary_key; + defined $this->find_group_with_primary([@values]); +} + +sub _checkupdate { + my $this = shift; + + if (defined $this->fpath && $this->fpath ne '') { + my $stat = stat($this->fpath); + + if (defined $stat && defined $this->time && + $stat->mtime > $this->time) { + $this->_load; + return 1; + } + } + return 0; +} + +sub queue_cleanup { shift->cleanup_queued(1); } +sub dequeue_cleanup{ shift->cleanup_queued(0); } +sub set_time { shift->time(CORE::time); } + +sub _synchronize { + my $this = shift; + my $force = shift || 0; + + if (defined $this->fpath && $this->fpath ne '' && + ($this->modified || $force)) { + my $fh = IO::File->new($this->fpath,'w'); + if (defined $fh) { + my $unicode = Tiarra::Encoding->new; + foreach my $person (@{$this->{database}}) { + my @keys = keys %{$person->data}; + if (defined $this->primary_key) { + @keys = grep { $_ ne $this->primary_key } @keys; + unshift(@keys, $this->primary_key); + } + my ($key, $values); + foreach $key (@keys) { + $values = $person->data->{$key}; + # can use colon(:) on key, but cannot use space( ). + $key =~ s/:/ /g; + # \s が先頭/最後にあった場合読み込みで消え去るのでそれを防止。 + $key = ':' . $key if ($key =~ /^\s/ || $key =~ /\s$/); + map { + my $line = "$key: " . $_ . "\n"; + $fh->print($unicode->set($line)->conv($this->{charset})); + } @$values + } + $fh->print("\n"); + } + $this->set_time; + $this->clear_modified; + $this->dequeue_cleanup; + } + } + return $this; +} + +sub groups { + my ($this) = @_; + + return @{$this->with_session(sub{ $this->{database}; })}; +} + +sub find_group_with_primary { + # 見付からなければundefを返す。 + my ($this, $value) = @_; + + $this->_check_primary_key; + return $this->find_group($this->primary_key, $value); +} + +sub find_group { + my ($this, $keys, $values) = @_; + + return $this->find_groups($keys, $values, 1); +} + +sub find_groups_with_primary { + my ($this, $value, $count) = @_; + + $this->_check_primary_key; + return $this->find_groups([$this->primary_key], [$value], $count); +} + +sub find_groups { + # on not found return 'undef' + # $keys is ref[array or scalar] + # $values is ref[array or scalar] + # $count is num of max found group, optional. + my ($this, $keys, $values, $count) = @_; + my (@ret); + + ($keys, $values) = map { + if (!ref($_) || ref($_) ne 'ARRAY') { + [$_]; + } else { + $_; + } + } ($keys, $values); + + my ($return) = sub { + if (wantarray) { + return @ret; + } else { + return $ret[0] || undef; + } + }; + + $this->with_session( + sub { + group_loop: + foreach my $group (@{$this->{database}}) { + foreach my $key (@$keys) { + foreach my $value (@$values) { + if ($this->_match($group->get_array($key), $value)) { + #match. + push(@ret, $group); + if (defined($count) && ($count <= scalar(@ret))) { + return $return->(); + } + next group_loop; # next at $group loop. + } + } + } + } + return $return->(); + }); +} + +sub find_group_with_hash { + my ($this, $hash) = @_; + + return $this->find_groups_with_hash($hash, 1); +} + +sub find_groups_with_hash { + # on not found return 'undef' + # $keys is hashref(key => scalar, key => [scalar, scalar, ...]). + # $count is num of max found group, optional. + my ($this, $hash, $count) = @_; + my (@ret); + + my ($return) = sub { + if (wantarray) { + return @ret; + } else { + return $ret[0] || undef; + } + }; + + $this->with_session( + sub { + group_loop: + foreach my $group (@{$this->{database}}) { + foreach my $key (keys %$hash) { + my $values = $hash->{$key}; + $values = [$values] + unless defined ref($values) && ref($values) eq 'ARRAY'; + foreach my $value (@$values) { + next group_loop + unless $this->_match($group->get_array($key), + $value); + } + } + # ok all match! + push(@ret, $group); + if (defined($count) && ($count <= scalar(@ret))) { + return $return->(); + } + } + return $return->(); + }); +} + +sub new_group { + my $this = shift; + my (@primary_key_values) = @_; + + if (!@primary_key_values && defined $this->primary_key) { + croak 'primary_key_values not defined! please pass value'; + if ($this->_check_primary_key_dups(@primary_key_values)) { + return undef; + } + } elsif (@primary_key_values && !defined $this->primary_key) { + carp 'primary_key_values defined! ignore value...'; + @primary_key_values = (); + } + $this->with_session( + sub { + my $group; + if (@primary_key_values) { + $group = Tools::Hash->new($this, { + $this->primary_key => [@primary_key_values], + }); + } else { + $group = Tools::Hash->new($this); + $this->queue_cleanup; + } + push @{$this->{database}}, $group; + $this->set_modified; + $group; + }); +} + +sub add_group { + # データベースにグループを追加する。 + # 常に成功し 1(true) が返る。 + # sanity check が足りないので new_group を使うことを推奨します。 + + # key に space が含まれないかチェックすべきだが、とりあえずはしていない。 + my ($this, @groups) = @_; + $this->with_session( + sub { + push @{$this->{database}}, map { + if (ref($_) eq 'HASH') { + Tools::Hash->new($this, $_); + } else { + $_; + } + } @groups; + $this->set_modified; + }); + + return 1; +} + +sub del_group { + # データベースからグループを削除する。 + # グループを空にしてクリーンアップにまかせます。 + + my ($this, @groups) = @_; + $this->with_session( + sub { + foreach my $group (@groups) { + foreach ($group->keys) { + $group->del_key($_); + } + } + }); + + return 1; +} + +sub add_array_with_primary { + my ($this, $primary, $key, @values) = @_; + + $this->_check_primary_key; + $this->with_session( + sub { + # 追加。あるか？ + my $group = $this->find_group_with_primary($primary); + + # primary_key の値に重複ができないかチェック。 + if ($key eq $this->primary_key && + $this->_check_primary_key_dups(@values)) { + return 0; + } + + if (defined $group) { + # found. + return $group->add_array($key, @values); + } else { + # 1. 無かった場合、primary_keyだけは追加が許される。 + # 2. primary_key の値と @values が一致するかチェック。 + if ($key eq $this->primary_key && + $this->_match([@values], $primary)) { + $this->new_group(@values); + $this->set_modified; + # added + return 1; + } + } + # not added + return 0; + }); +} + +sub del_array_with_primary { + my ($this, $primary, $key, @values) = @_; + + $this->_check_primary_key; + $this->with_session( + sub { + # 削除。あるか？ + my $group = $this->find_group_with_primary($primary); + + if (defined $group) { + return $group->del_array($key, @values); + } + # not deleted + return 0; + }); +} + +*add_value_with_primary = \&add_array_with_primary; +*del_value_with_primary = \&del_array_with_primary; + +sub _cleanup { + my $this = shift; + my $force = shift || 0; + + if ($this->cleanup_queued || $force) { + my $count = scalar @{$this->{database}}; + if (defined $this->primary_key) { + # primary_keyが一つもないエイリアスを削除する。 + @{$this->{database}} = grep { + my $primary = $_->{$this->primary_key}; + defined $primary && @$primary > 0; + } @{$this->{database}}; + } else { + # 中身が空のエイリアスを削除する。 + @{$this->{database}} = grep { + $_->keys; + } @{$this->{database}}; + } + if ($count != (scalar @{$this->{database}})) { + $this->set_modified; + } + $this->dequeue_cleanup; + } +} + +sub _after_session_start { + my $this = shift; + $this->_checkupdate; +} + +sub _before_session_finish { + my $this = shift; + $this->_cleanup; + $this->_synchronize; +} + +# replace support functions +sub replace_with_callbacks { + # マクロの置換を行なう。%optionalは置換に追加するキーと値の組みで、省略可。 + # $callbacksはgroup/optionalで置換できなかった際に呼び出されるコールバック関数のリファレンス。 + # optionalの値はSCALARでもARRAYでも良い。 + my ($this,$primary,$str,$callbacks,%optional) = @_; + my $main_table = $this->find_group_with_primary($primary) || {}; + return Tools::HashTools::replace_recursive($str,[$main_table,\%optional],$callbacks); +} + +# deprecated interfaces +sub add_array { + my ($this, $group, $key, @values) = @_; + + $group->add_array($key, @values); +} + +sub del_array { + my ($this, $group, $key, @values) = @_; + + $group->del_array($key, @values); +} + +*add_value = \&add_array; +*del_value = \&del_array; + +sub dup_group { + # グループの複製を行います。 + + my ($group) = @_; + return undef unless defined($group); + + return $group->clone; +} + +# group misc functions +sub concat_string_to_key { + # prefix や suffix を group の key に付加します。 + + # - 引数 - + # $group : グループ。 + # $prefix : prefix 文字列 ('to.' とか 'from.' とか) + # $suffix : suffix 文字列 + my ($group, $prefix, $suffix) = @_; + return dup_group($group)->manipulate_keyname( + prefix => $prefix, + suffix => $suffix, + ); +} + +sub get_value_random { + my ($group, $key) = @_; + + return $group->get_value_random($key); +} + +sub get_value { + my ($group, $key) = @_; + + return $group->get_value($key); +} + +sub get_array { + my ($group, $key) = @_; + + return $group->get_array($key); +} + +1; diff -urN /non-existant-dir/module/Tools/HTTPClient/SSL.pm tiarra-20080510/module/Tools/HTTPClient/SSL.pm --- /non-existant-dir/module/Tools/HTTPClient/SSL.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/Tools/HTTPClient/SSL.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,278 @@ +## ---------------------------------------------------------------------------- +# Tools::HTTPClient::SSL. +# 適当ごしらえのHTTPClient用SSLサポート. +# before-select Hook で pop_queue() が呼ばれる動作のみを想定. +# +# LinedINETSocket の I/F を適当に実装. +# 但し基底クラスはなにもなし(IO::Socketでもない). +# Tiarra::Socket系で対処した方がいいのだろうけれど…. +# ----------------------------------------------------------------------------- +# Mastering programmed by YAMASHINA Hio +# +# Copyright 2008 YAMASHINA Hio +# ----------------------------------------------------------------------------- +# $Id: SSL.pm 10954 2008-05-02 13:24:15Z hio $ +# ----------------------------------------------------------------------------- +package Tools::HTTPClient::SSL; +use strict; +use warnings; + +our $HAS_SSL; +our $DEFAULT_EOL = "\r\n"; + +1; + +# ----------------------------------------------------------------------------- +# $pkg->new(). +# +sub new +{ + my $pkg = shift; + my $eol = shift || $DEFAULT_EOL; + + my $this = bless {}, $pkg; + $this->{eol} = $eol; + $this->{host} = undef; + $this->{port} = undef; + $this->{ssl} = undef; + $this->{queue} = []; + $this->{recvbuf} = ''; + $this->{eof} = undef; + $this->{timer} = undef; + + defined($HAS_SSL) or $this->_load_ssl(); + + $this; +} + +sub _load_ssl +{ + eval + { + local($SIG{__DIE__}) = 'DEFAULT'; + require IO::Socket::SSL; + 1; + }; + $HAS_SSL = $@ ? 0 : 1; + $HAS_SSL; +} + + +# ----------------------------------------------------------------------------- +# $obj->DESTROY(). +# +sub DESTROY +{ + my $this = shift; + if( my $timer = $this->{timer} ) + { + $timer->uninstall; + $this->{timer} = undef; + } +} + +# ----------------------------------------------------------------------------- +# $obj->connect($host, $port). +# +sub connect +{ + my $this = shift; + my $host = shift; + my $port = shift; + + $this->{host} = $host; + $this->{port} = $port; + $this->{ssl} = IO::Socket::SSL->new( + PeerHost => $host, + PeerPort => $port, + ($^O eq 'MSWin32' ? () : (Blocking => 0)), + ); + if( !$this->{ssl} ) + { + $@ = IO::Socket::SSL::errstr(); + } + + # select() を抜けるためだけのtimer. + # HTTPClient が before-select Hook で動作を起こすので, + # そのトリガ用. + $this->{timer} = Timer->new( + Interval => 1, + Code => sub{}, + Repeat => 1 + )->install; + + $this; +} + +# ----------------------------------------------------------------------------- +# $obj->sock(). +# +sub sock +{ + my $this = shift; + $this->{ssl}; +} + +# ----------------------------------------------------------------------------- +# $obj->connected(). +# +sub connected +{ + my $this = shift; + $this->{ssl} && !$this->{eof}; +} + +# ----------------------------------------------------------------------------- +# $obj->disconnect(). +# +sub disconnect +{ + my $this = shift; + $this->{ssl} = undef; +} + +# ----------------------------------------------------------------------------- +# $obj->send_reserve($line). +# +sub send_reserve +{ + my $this = shift; + my $line = shift; + print {$this->{ssl}} $line."\r\n"; +} + +# ----------------------------------------------------------------------------- +# $obj->sendbuf(). +# +sub sendbuf +{ + my $this = shift; + return ""; +} + +# ----------------------------------------------------------------------------- +# $obj->shutdown($SHUT_WR). +# +sub shutdown +{ + my $this = shift; + return; +} + +# ----------------------------------------------------------------------------- +# $line = $obj->pop_queue(). +# +sub pop_queue +{ + my $this = shift; + my $queue = $this->{queue}; + + if( !@$queue ) + { + # 通常なら自分で tiarra-socket/read() コールバックで + # 読み込んでおくけれど, 手抜き実装につきここでread. + $this->_recv(); + $this->_fill_queue(); + } + shift @$queue; +} + +# ----------------------------------------------------------------------------- +# $obj->recvbuf(). +# +sub recvbuf:lvalue +{ + my $this = shift; + $this->{recvbuf}; +} + +# ----------------------------------------------------------------------------- +# $obj->eol(). +# $obj->eol($eol). +# +sub eol +{ + my $this = shift; + @_ and $this->{eol} = shift; + $this->{eol}; +} + +# ----------------------------------------------------------------------------- +# $obj->_recv(). +# recvbuf にデータを読み込み. +# Tiarra::Socket::Buffered の read() に相当. +# +sub _recv +{ + my $this = shift; + my $ssl = $this->{ssl}; + + $this->{eof} and return; + + for(;;) + { + my $r = $ssl->read(my $buf, 1024); + if( !defined($r) ) + { + my $e = $ssl->errstr; + #print "read: $e\n"; + if( $e =~ /SSL wants a read first!/ ) + { + last; + } + if( $e eq 'SSL read errorerror:00000000:lib(0):func(0):reason(0)' ) + { + $this->{eof} = 1; + last; + } + die __PACKAGE__."#_recv, ".$e; + } + if( !$r ) + { + $this->{eof} = 1; + last; + } + #print "read: $r\n"; + $this->{recvbuf} .= $buf; + } + 1; +} + + +# ----------------------------------------------------------------------------- +# $obj->_fill_queue(). +# recvbuf にたまっているデータを行分割して queue に投入. +# Tiarra::Socket::Lined の read() に相当. +# +sub _fill_queue +{ + my $this = shift; + my $queue = $this->{queue}; + my $eol = $this->{eol} || $DEFAULT_EOL; + my $eol_len = length($eol); + while( $this->{recvbuf} =~ /^(.*?)\Q$eol/ ) + { + my $line_len = length($1); + push(@$queue, substr($this->{recvbuf}, 0, $line_len)); + substr($this->{recvbuf}, 0, $line_len+$eol_len, ''); + } +} + +# ----------------------------------------------------------------------------- +# End of Module. +# ----------------------------------------------------------------------------- +# ----------------------------------------------------------------------------- +# End of File. +# ----------------------------------------------------------------------------- +__END__ + +=encoding utf8 + +=for stopwords + YAMASHINA + Hio + ACKNOWLEDGEMENTS + AnnoCPAN + CPAN + RT + diff -urN /non-existant-dir/module/Tools/HTTPClient.pm tiarra-20080510/module/Tools/HTTPClient.pm --- /non-existant-dir/module/Tools/HTTPClient.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/Tools/HTTPClient.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,609 @@ +# -*- cperl -*- +# ----------------------------------------------------------------------------- +# $Id: HTTPClient.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +# HTTP/1.1非対応。 +# ----------------------------------------------------------------------------- +package Tools::HTTPClient; +use strict; +use warnings; +use LinedINETSocket; +use Carp; +use RunLoop; +use Timer; +use Tools::HTTPClient::SSL; +use Module::Use qw(Tools::HTTPClient::SSL); +use Tools::HTTPParser; +use Module::Use qw(Tools::HTTPParser); + +our $HAS_IPV6 = Tiarra::OptionalModules->ipv6; + +# 本当はHTTP::RequestとHTTP::Responseを使いたいが… +# HTTP::Request からの情報取得のみ対応。 + +our $DEBUG = 0; + +# ----------------------------------------------------------------------------- +# $pkg->new(%opts). +# +sub new { + my ($class, %args) = @_; + my $this = bless {} => $class; + + if ($args{Request}) { + my $req = $args{Request}; + if (!$req->isa('HTTP::Request')) { + croak "Argument `Request' must be HTTP::Request object."; + } + $args{Method} = $req->method; + $args{Url} = $req->uri->as_string; + $args{Content} = $req->content; + $args{Header} = {}; + # NON-CANONICALIZED FIELD NAMES と複数行・複数値は非サポート。 + $req->headers->scan(sub{ $args{Header}->{$_[0]} = $_[1]; }); + } + 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->{debug} = $args{Debug}; + + $this->{host} = undef; + $this->{port} = undef; + $this->{addr} = undef; + $this->{path} = undef; + + $this->{callback} = undef; + $this->{progress_callback} = undef; + $this->{socket} = undef; + $this->{hook} = undef; + $this->{timeout_timer} = undef; + $this->{shutdown_wr_after_writing} = undef; + $this->{stopped} = undef; + + $this->{expire_time} = undef; # タイムアウト時刻 + + $this->{parser} = Tools::HTTPParser->new( response => 1 ); + + $DEBUG and print __PACKAGE__."#new, $this, $this->{url}\n"; + $this; +} + +# ----------------------------------------------------------------------------- +# $obj->DESTROY(). +# +sub DESTROY +{ + my $this = shift; + $DEBUG and print __PACKAGE__."#DESTROY($this), $this->{url}.\n"; + $this->stop(); + $DEBUG and print __PACKAGE__."#DESTROY($this), $this->{url}, done.\n"; +} + +# ----------------------------------------------------------------------------- +# $obj->start(%opts). +# +sub start { + # $callback: セッション終了後に呼ばれる関数。省略不可。 + # この関数には次のようなハッシュが渡される。 + # { + # Protocol => 'HTTP/1.0', + # Code => 200, + # Message => 'OK', + # Header => { + # 'Content-Length' => 6, + # }, + # Content => 'foobar', + # } + # エラーが発生した場合はエラーメッセージ(文字列)が渡される。 + my ($this, $callback) = @_; + my %opts; + if( @_>=3 ) + { + ($this, %opts) = @_; + $callback = $opts{Callback}; + } + if ($this->{callback}) { + croak "This client is already started"; + } + $this->{callback} = $callback; + $this->{progress_callback} = $opts{ProgressCallback}; + + if (!$callback or ref($callback) ne 'CODE') { + croak "Callback function is required"; + } + + local($DEBUG) = $DEBUG || $this->{debug}; + + # URLを分解し、ホスト名とパスを得る。 + my ($host, $path); + $this->{url} =~ s/#.+//; + if ($this->{url} =~ m|^http(s?)://(.+)$|) { + my $with_ssl = $1; + my $hostpath = $2; + if ($hostpath =~ m|^(.+?)(/.*)|) { + $host = $1; + $path = $2; + } + else { + $host = $1; + $path = '/'; + } + $this->{with_ssl} = $with_ssl; + } + else { + croak "Unsupported scheme: $this->{url}"; + } + + # ヘッダにHostが含まれていなければ追加。 + if (!$this->{header}{Host}) { + $this->{header}{Host} = $host; + } + + #googleさん関係でいまいち動かない？ + #if (!$this->{header}{Connection}) { + # # HTTP/1.1 だと Keep-Alive がデフォルトだけど, + # # ひとまず気にしない…. + # $this->{header}{Connection} = 'close'; + #} + + # ホスト名にポートが含まれていたら分解。 + my $port = $this->{with_ssl} ? 443 : 80; + if ($host =~ s/:(\d+)$//) { + $port = $1; + } + + $this->{host} = $host; + $this->{port} = $port; + $this->{path} = $path; + + # Content-Length をもっていたらチェック. + if( my $clen = $this->{header}{'Content-Length'} ) + { + if( !defined($this->{content}) ) + { + $this->_delay(sub{ $this->_end("Content-Length: $clen, but no content."); }); + return $this; + } + my $alen = length($this->{content}); + if( $clen != $alen ) + { + $this->_delay(sub{ $this->_end_delay("Content-Length: $clen, but actual length is $alen"); }); + return $this; + } + } + + # 必要ならタイムアウト用のタイマーをインストール + if ($this->{timeout}) { + $this->{expire_time} = time + $this->{timeout}; + $this->{timeout_timer} = Timer->new( + After => $this->{timeout}, + Code => sub { + $this->{timeout_timer} = undef; + if( $this->{socket} ) + { + $this->_main; + }elsif( !$this->{addr} ) + { + $this->_end("dns timeout"); + }else + { + $this->_end("timeout"); + } + })->install; + } + + if( $this->is_valid_address($host) ) + { + $this->_delay( sub { $this->_resolved($host, 'literal'); } ); + }elsif( my $addr = $this->_resolve_locally($host) ) + { + $this->_delay( sub { $this->_resolved($addr, 'local-resolve'); } ); + }else + { + my $dns_reply = \&_dns_reply; + Tiarra::Resolver->resolve(addr => $host, sub{ $this->$dns_reply(@_) }); + } + $this; +} + +sub is_valid_address +{ + my $this = shift; + my $addr = shift; + + # ipv4. + my @ipv4 = $addr =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)\z/; + if( @ipv4 && !grep{ $_>255 || /^0./ }@ipv4 ) + { + return $addr; + } + + # ipv6 is not supported.. + + undef; +} + +sub _resolve_locally +{ + my $this = shift; + my $host = shift; + + my $addr; + my $timedout; + local($SIG{ALRM}) = sub{ die $timedout="ALRM" }; + eval{ + alarm(1); # can interrupt inet_[ap]ton? + if( $HAS_IPV6 ) + { + my $dns_reply = \&_dns_reply; + my $addr_bin = Socket6::inet_pton(Socket6::AF_INET6(), $host); + $addr = $addr_bin && Socket6::inet_ntop(Socket6::AF_INET6(), $addr_bin); + } + if( !$addr ) + { + my $addr_bin = Socket::inet_aton($host); + $addr = $addr_bin && Socket::inet_ntoa($addr_bin); + } + alarm(0); + }; + $@ && !$timedout and die; + + return $addr; +} + +sub _dns_reply +{ + my $this = shift; + if( !$this->can('new') ) + { + # this module is unloaded. + return; + } + my $resolved = shift; + my $addr_list = $resolved->answer_data; + my $addr = $addr_list->[0]; + if( !$addr ) + { + $this->_end("no address for ".$resolved->query_data); + return; + } + $this->_resolved($addr, 'dns'); +} + +sub _resolved +{ + my $this = shift; + my $addr = shift; + my $resolver = shift; + + $DEBUG and print __PACKAGE__."#_resolved, $resolver / $this->{host} => $addr\n"; + + $this->{addr} = $addr; + my $port = $this->{port}; + + if( !$this->is_valid_address($addr) ) + { + $this->_end("invalid address: $addr"); + return; + } + + if( $this->{progress_callback} ) + { + # 進展があったのでコールバック. + $this->{progress_callback}->($this->{parser}->object); + if( $this->{stopped} ) + { + return; + } + } + + # 接続 + if( $this->{with_ssl} ) + { + $this->{socket} = Tools::HTTPClient::SSL->new()->connect($addr, $port); + }else + { + $this->{socket} = LinedINETSocket->new()->connect($addr, $port); + } + if (!defined $this->{socket}) { + # 接続不可能 + $this->_end("Failure on connection: $this->{host}:$port ($addr)"); + return; + } + if (!defined $this->{socket}->sock) { + # 接続不可能 + $this->_end("Failure on connection (*): $this->{host}:$port ($addr)"); + return; + } + + # リクエストを発行し、フックをかけて終了。 + # 行単位処理はしないので, + # eol を送信時は '' で, 受信時はランダムでつぶして送信. + my $req = { + Type => 'request', + Method => $this->{method}, + Path => $this->{path}, + Protocol => 'HTTP/1.0', + Header => $this->{header}, + ($this->{content} ? (Content => $this->{content}) : ()), + }; + $this->{socket}->eol(""); + $this->{socket}->send_reserve( Tools::HTTPParser->to_string($req) ); + #$DEBUG and print Dumper($req);use Data::Dumper; + #$DEBUG and print "<>\n".$this->{socket}->sendbuf."<>\n";; + $this->{socket}->eol( pack("C*", map{rand(256)}1..32) ); + + #googleさん関係でいまいち動かない？ + #$this->{shutdown_wr_after_writing} = !$this->{header}{Connection} || $this->{header}{Connection} =~ /close/i || $this->{header}{Connection} !~ /Keep-Alive/i; + #if( $this->{host} =~ /google|gmail/ ) + #{ + # $this->{shutdown_wr_after_writing} = undef; + #} + + $this->{hook} = RunLoop::Hook->new( + sub { + $this->_main; + })->install('before-select'); + + $this; +} + +# ----------------------------------------------------------------------------- +# $obj->_main(). +# (private) +# +sub _main +{ + my $this = shift; + + #$DEBUG and print ">> ".__PACKAGE__."#_main($this) $this->{url} ...\n"; + #$DEBUG and print "<>\n".$this->{socket}->sendbuf."<>\n";; + + if( $this->{shutdown_wr_after_writing} && $this->{socket}->sendbuf eq '' ) + { + $this->{shutdown_wr_after_writing} = undef; + my $SHUT_WR = 1; + $DEBUG and print __PACKAGE__."#_main, shutdown SHUT_WR.\n"; + $this->{socket}->shutdown($SHUT_WR); + } + + my $progress = ''; + while( defined(my $line = $this->{socket}->pop_queue) ) + { + # そうそうこないと思うけれど運悪くマッチしたとき. + $progress .= $line . $this->{socket}->eol; + $DEBUG and $this->_runloop->notify_msg(__PACKAGE__."#_main, matches with ".unpack("H*",$this->{socket}->eol)); + } + $progress .= $this->{socket}->recvbuf; + $this->{socket}->recvbuf = ''; + + if( $progress ne '' ) + { + my $status = eval { $this->{parser}->add($progress); }; + if( $@ ) + { + # プロトコルエラー. + $this->_end($@); + return; + } + if( $status == 0 ) + { + # 正常終了. + $this->_end(); + return; + } + if( $this->{progress_callback} ) + { + # 進展があったのでコールバック. + $this->{progress_callback}->($this->{parser}->object); + if( $this->{stopped} ) + { + $DEBUG and print "<< (stopped) by progress_callback\n"; + return; + } + } + } + + # 切断されていたら、ここで終わり。 + if( $this->{socket} && !$this->{socket}->connected ) + { + $DEBUG and print "<< (disconnected)\n"; + my $success; + if( $this->{parser}->isa('Tools::HTTPParser') ) + { + my $st = $this->{parser}->object->{StreamState}; + $success = $st =~ /^(body|parsed)\z/ && $this->{parser}{rest} eq ''; + }else + { + $this->{parser}->object->content( $this->{parser}->data ); + $success = $this->{parser}->extra == 0; + } + if( $success ) + { + $this->_end(); + }else + { + $this->_end("unexpected disconnect by server"); + } + return; + } + + # タイムアウト判定 + if( $this->{expire_time} and time >= $this->{expire_time} ) + { + $this->_end("timeout"); + return; + } + #$DEBUG and print ">> ".__PACKAGE__."#_main leave.\n"; +} + +# ----------------------------------------------------------------------------- +# $obj->_end(). +# $obj->_end($errmsg). +# (private) +# +sub _end { + my ($this, $err) = @_; + + $this->stop; + + if ($err) { + $this->{callback}->($err); + } + else { + my $res = $this->{parser}->object; + if( UNIVERSAL::isa($res, 'HTTP::Message') ) + { + $DEBUG and print __PACKAGE__."#_end($this) .. convert from lwp\n"; + $res = Tools::HTTPParser->_from_lwp($res); + } + $DEBUG and print __PACKAGE__."#_end($this) .. callback with success\n"; + $this->{callback}->($res); + } +} + +sub _delay +{ + my $this = shift; + my $sub = shift; + + Timer->new( + After => -1, + Code => $sub, + )->install(); +} + +# ----------------------------------------------------------------------------- +# $obj->alive_p(). +# +sub alive_p { + my $this = shift; + defined $this->{socket}; +} + +# ----------------------------------------------------------------------------- +# $obj->stop(). +# +sub stop { + my $this = shift; + $DEBUG and print __PACKAGE__."#stop($this).\n"; + + $this->{socket}->disconnect if $this->{socket} && $this->{socket}->connected; + #$DEBUG and print __PACKAGE__."#stop($this) .. disconnect ok\n"; + $this->{hook}->uninstall if $this->{hook}; + #$DEBUG and print __PACKAGE__."#stop($this) .. hook.uninstall ok\n"; + $this->{timeout_timer}->uninstall if $this->{timeout_timer}; + #$DEBUG and print __PACKAGE__."#stop($this) .. timer.uninstall ok\n"; + + $this->{stopped} = 1; + + $this->{socket} = + $this->{hook} = + $this->{timeout_timer} = + undef; +} + +1; + +=encoding euc-jp + +=head1 NAME + +Tools::HTTPClient - HTTP Client + +=head1 SYNOPSIS + + use Tools::HTTPClient; + + my $http = Tools::HTTPClient->new( + Url => 'http://www.example.com', + Method => 'GET', + ); + $http->start(\&callback); + +=head1 DESCRIPTION + +HTTP Client for tiarra. + +ブロックしないように処理は非推奨なので, +ブロックしないように調整されている HTTP +クライアントモジュール. + +=head1 METHODS + +=head2 new + + my $http = Tools::HTTPClient->new( + Url => 'http://www.example.com', + Method => 'GET', + ); + +インスタンスの生成. +C 及び C 引数は必須. + +その他の省略可能な引数として, +C (POST内容), +C
(HASH-ref), +C (秒単位) +が利用可能. + +=head2 start + + $http->start(\&callback); + $http->start(%opts); + + $opts{Callback} = \&callback; + $opts{ProgressCallback} = \&progress_callback; + +C<\&callback> は処理完了時に呼ばれる関数. +C<\&progress_callback> は処理の進捗があったときに呼ばれる関数. + +C<\&callback> は, HTTPが正常に完了すればHASH-refを, +タイムアウトやエラー時にはエラー内容を含んだ文字列を +引数として呼び出される. + + sub my_callback { + my $response = shift; + if( !ref($response) ) + { + # error. + return; + } + # success. + my $protocol = $response->{Protocol}; + my $status_code = $response->{Code}; + my $status_msg = $response->{Message}; + my $headers = $response->{Header}; # hash-ref. + my $content = $response->{Content}; + } + +C<\&progress_callback> も同様, +ただしこちらはエラーの報告には呼ばれない. + +=head2 stop + + $http->stop(); + +リクエストの終了. +このときは L で指定した C<\&callback> がよばれないので注意. + +=head1 AUTHOR + +phonohawk + +=head1 SEE ALSO + +tiarra +http://coderepos.org/share/wiki/Tiarra +(Japanese) + +=cut diff -urN /non-existant-dir/module/Tools/HTTPParser.pm tiarra-20080510/module/Tools/HTTPParser.pm --- /non-existant-dir/module/Tools/HTTPParser.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/Tools/HTTPParser.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,597 @@ +## ---------------------------------------------------------------------------- +# Tools::HTTPParser. +# ----------------------------------------------------------------------------- +# Mastering programmed by YAMASHINA Hio +# +# Copyright 2008 YAMASHINA Hio +# ----------------------------------------------------------------------------- +# $Id: HTTPParser.pm 11016 2008-05-03 06:43:45Z hio $ +# ----------------------------------------------------------------------------- +package Tools::HTTPParser; +use strict; +use warnings; + +#our $HAS_HTTP_PARSER ||= do{ +# eval 'local($SIG{__DIE__})="DEFAULT";use HTTP::Parser; 1;'; +# $@ and RunLoop->shared_loop->notify_msg(__PACKAGE__.", HTTP::Parser: $@"); +# !$@; +#}; + +our $RE_REQUEST_GREETING = qr{ + ^ + (\w+) # method:GET/POST/tec. + (?:\s+) + (\S+?) # path:/ + (?: + (?:\s+) + (HTTP/.+?) # protocol:HTTP/1.0 + )? + [ \t]*\r?\n +}ix; + +our $RE_RESPONSE_GREETING = qr{ + ^ + (HTTP/\d+\.\d+) # protocol:HTTP/1.0 + (?:\s+) + (\d+) # status_code:200 + (?:\s+) + (.+?) # message:OK. + [ \t]*\r?\n +}ix; + +# constants. +our $RET_NEED_LINE_DATA = -2; +our $RET_NEED_MORE_DATA = -1; +our $RET_SUCCESS = 0; + +our %HTTP_STATUS_MESSAGE = ( + 200 => 'OK', + 302 => 'Found', + 401 => 'Unauthorized', + 403 => 'Forbidden', + 404 => 'Not Found', + 405 => 'Method Not Allowed', + 500 => 'Server Error', + 503 => 'Temporary Unavailable', +); + +our $DEBUG = 0; + +1; + +# ----------------------------------------------------------------------------- +# $pkg->new(). +# $pkg->new(request => 1). +# $pkg->new(response => 1). +# +sub new +{ + my $pkg = shift; + my %opts = @_; + + my $this = bless {}, $pkg; + $this->{parser} = undef; + $this->{recvbuf} = ''; + $this->{prevkey} = undef; + $this->{rest} = undef; + $this->{reply} = { + StreamState => 'greeting', # greeting/header/body/parsed. + }; + # [request] / [response] => [sample] + # Protocol / Protocol => "HTTP/1.0", + # Type / Type => request / response. + # StreamState / StreamState => greeting/header/body/parsed. + # Path / => "/path/to/?request", + # Method / => "GET", + # / Code => 200 + # / Message => "OK", + # Header / Header => {}, + # Content / Content => undef, + + $this; +} + +# ----------------------------------------------------------------------------- +# $status = $pkg->add($packet). +# +sub add +{ + my $this = shift; + my $packet = shift; + + $this->{recvbuf} .= $packet; + + $DEBUG and require Data::Dumper; + $DEBUG and print __PACKAGE__."#add, StreamState = $this->{reply}{StreamState}\n"; + + if( $this->{reply}{StreamState} eq 'greeting' ) + { + my $taintness = substr($this->{recvbuf}, 0, 0); + if( $this->{recvbuf} =~ s/$RE_REQUEST_GREETING// ) + { + my $method = $1 . $taintness; + my $path = $2 . $taintness; + my $proto = $3 . $taintness; + $this->{reply} = { + StreamState => 'header', # greeting/header/body/parsed. + Type => 'request', + Protocol => $proto, + Path => $path, + Method => $method, + Header => {}, + Content => undef, + }; + }elsif( $this->{recvbuf} =~ s/$RE_RESPONSE_GREETING// ) + { + my $proto = $1 . $taintness; + my $code = $2 . $taintness; + my $msg = $3 . $taintness; + $this->{reply} = { + StreamState => 'header', # greeting/header/body/parsed. + Type => 'response', + Protocol => $proto, + Code => $code, + Message => $msg, + Header => {}, + Content => undef, + }; + }else + { + my $offs = index($this->{recvbuf}, "\n"); + if( $offs >= 0 ) + { + my $line = substr($this->{recvbuf}, 0, $offs+1); + $line =~ s/\r?\n\z//; + die "invalid greeting: $line"; + } + return $RET_NEED_LINE_DATA; + } + $this->{prevkey} = undef; + $DEBUG and print __PACKAGE__."#add, got greeting, ".Data::Dumper->new([$this->{reply}],['reply'])->Indent(1)->Dump; + } + + my $reply = $this->{reply}; + + if( $reply->{StreamState} eq 'header' ) + { + for(;;) + { + my $offs = index($this->{recvbuf}, "\n"); + if( $offs < 0 ) + { + return $RET_NEED_LINE_DATA; + } + my $line = substr($this->{recvbuf}, 0, $offs+1, ''); + $line =~ s/\r?\n\z//; + $DEBUG and print __PACKAGE__."#add, line> $line\n"; + if( $line eq '' ) + { + last; + } + if( $line =~ s/^\s+/ / ) + { + my $prevkey= $this->{prevkey}; + if( !defined($prevkey) ) + { + die "invalid header(without previous key): $line"; + } + $reply->{Header}{$prevkey} .= $line; + if( $reply->{ListedHeader}{$prevkey} ) + { + $reply->{ListedHeader}{$prevkey}[-1] .= $line; + } + next; + } + my ($key, $val) = split(/:\s*/, $line, 2); + if( !defined($val) ) + { + die "invalid header(no splitter): $line"; + } + $key =~ s/(?:(?<=-)|^)([a-z])/\U$1/g; + if( exists($reply->{Header}{$key}) ) + { + $reply->{ListedHeader}{$key} ||= [ $reply->{Header}{$key} ]; + push(@{$reply->{ListedHeader}{$key}}, $val); + } + $reply->{Header}{$key} = $val; + $this->{prevkey} = $key; + } + + $this->{rest} = $reply->{Header}{'Content-Length'}; + my $read_body = 0; + if( defined($this->{rest}) ) + { + # Content-Length で本文サイズが指定されているとき. + $read_body = 1; + }elsif( !$reply->{Method} ) + { + # Response のとき. + $read_body = 1; + }elsif( $reply->{Method} eq 'POST' ) + { + # Request/POST のとき. + $read_body = 1; + }else + { + # Request/POST以外 のとき. + $read_body = 0; + } + if( !$read_body ) + { + $reply->{StreamState} = 'parsed'; + return $RET_SUCCESS; + } + $reply->{StreamState} = 'body'; + $DEBUG and print __PACKAGE__."#add, got header, ".Data::Dumper->new([$this->{reply}],['reply'])->Indent(1)->Dump; + } + + if( $reply->{StreamState} eq 'body' ) + { + if( !defined($reply->{Content}) && $this->{recvbuf} ne '' ) + { + $reply->{Content} = ''; + } + my $ret; + if( !defined($this->{rest}) ) + { + $reply->{Content} .= $this->{recvbuf}; + $this->{recvbuf} = ''; + $ret = $RET_NEED_MORE_DATA; + }elsif( length($this->{recvbuf}) < $this->{rest} ) + { + $this->{rest} -= length($this->{recvbuf}); + $reply->{Content} .= $this->{recvbuf}; + $this->{recvbuf} = ''; + $ret = $this->{rest}; + }else + { + $reply->{Content} .= substr($this->{recvbuf}, 0, $this->{rest}, ''); + $this->{rest} = undef; + $reply->{StreamState} = 'parsed'; + $ret = $RET_SUCCESS; + } + $DEBUG and print __PACKAGE__."#add, got body, rest=$ret, reply=".Data::Dumper->new([$this->{reply}])->Indent(1)->Terse(1)->Dump; + return $ret; + } + + die "NOT REACH HERE: StreamState=$reply->{StreamState}"; +} + +# ----------------------------------------------------------------------------- +# $obj->object(). +# +sub object +{ + my $this = shift; + $this->{reply}; +} + +# ----------------------------------------------------------------------------- +# $len = $obj->extra(). +# バッファに残っているデータサイズ(数値)を取得. +# +sub extra +{ + my $this = shift; + length($this->{recvbuf}); +} + +# ----------------------------------------------------------------------------- +# $str = $pkg->to_string($req). +# HTTPとして流せるテキストに変換. +# 要求行/ステータス行も含めた文字列を返します. +# +sub to_string +{ + my $pkg = shift; + my $res = shift; + + if( !ref($res) ) + { + $res = { + Code => $res, + }; + } + + my $type = $res->{Type} || ($res->{Method} ? 'request' : 'response'); + my $hdr = $res->{Header} || {}; + my $cref = defined($res->{Content}) && \$res->{Content}; + my $status_line; + + if( $type eq 'response' ) + { + my $code = $res->{Code} || 500; + my $proto = $res->{Protocol} || 'HTTP/1.0'; + my $message = $res->{Message}; + $message ||= $HTTP_STATUS_MESSAGE{$code} || "No message"; + $status_line = "$proto $code $message\r\n"; + + if( !$cref && !$res->{Header}{Location} ) + { + $cref = \"$code $message"; + } + if( !defined($hdr->{'Content-Length'}) && $cref ) + { + $hdr = {%$hdr}; # sharrow-copy. + $hdr->{'Content-Length'} = length($$cref); + } + }else + { + # request. + my $method = $res->{Method} || 'GET'; + my $path = $res->{Path} || '/'; + my $proto = $res->{Protocol} || 'HTTP/1.0'; + $status_line = "$method $path $proto\r\n"; + } + + my $str = ''; + $str .= $status_line; + + foreach my $key (sort keys %$hdr) + { + $str .= "$key: $hdr->{$key}\r\n"; + } + $str .= "\r\n"; + + if( $cref ) + { + $str .= $$cref; + } + + $str; +} + +# ----------------------------------------------------------------------------- +# $req = $pkg->from_lwp($lwp_http_request). +# $res = $pkg->from_lwp($lwp_http_response). +# LWPのHTTP::Request/HTTP::ResponseからTools::HTTPParser形式の +# オブジェクトを生成. +# +sub from_lwp +{ + my $pkg = shift; + my $htreq = shift; + + my $proto = $htreq->protocol; + if( my $ver = !$proto && $htreq->header('x-http-version') ) + { + $proto = "HTTP/$ver"; + } + my $type = $htreq->isa('HTTP::Request') ? 'request' : 'response'; + my $obj = { + StreamState => 'parsed', + Type => $type, + Protocol => $proto, + Header => { + map{ $_ => scalar($htreq->header($_)) } $htreq->headers->header_field_names + }, + Content => $htreq->content, + #_htreq => $htreq, + }; + if( $type eq 'request' ) + { + $obj->{Method} = $htreq->method; + $obj->{Path} = $htreq->uri->as_string; + }else + { + $obj->{Code} = $htreq->code; + $obj->{Message} = $htreq->message; + } + $obj; +} + +# ----------------------------------------------------------------------------- +# $bool = $pkg->extract_forwarded_for($req, \@allows). +# ReverseProxyによって生成されるX-Forwarded-Forヘッダを +# $req->{RemoteAddr}/$req->{Header}{Host} に展開. +# @allows: 展開を許可するIPアドレスの一覧(X-Forwarded-Forの逆順). +# 書き換えると真の値を, 書き換えなかった時はundefの値を返す. +# 途中までしか一致しなかった時は RemoteAddr="-$addr-" で書き換える. +# +sub extract_forwarded_for +{ + my $pkg = shift; + my $req = shift; + my $allows = shift; + + $DEBUG and $pkg->_debug(__PACKAGE__."#_extract_forwarded_for."); + $DEBUG and $pkg->_debug("- allow-chain has ".@$allows.(@$allows==1?" server":" servers")); + $DEBUG and map{ $pkg->_debug("- allow[$_] = $allows->[$_]") } 0..$#$allows; + + my $hdr = $req->{Header}; + + if( !$req->{RemoteAddr} ) + { + $DEBUG and $pkg->_debug("- no RemoteAddr field on request."); + return undef; + } + if( !$hdr->{'X-Forwarded-For'} ) + { + $DEBUG and $pkg->_debug("- no X-Forwarded-For header."); + return undef; + } + if( !defined($hdr->{'X-Forwarded-Host'}) ) + { + $DEBUG and $pkg->_debug("- no X-Forwarded-Host"); + return undef; + } + if( !defined($hdr->{'X-Forwarded-Server'}) ) + { + $DEBUG and $pkg->_debug("- no X-Forwarded-Server"); + return undef; + } + + my @copy_keys = qw(Host X-Forwarded-For X-Forwarded-Host X-Forwarded-Server); + my $orig = { + map{ exists($hdr->{$_}) ? ($_ => $hdr->{$_}) : () } @copy_keys + }; + exists($req->{RemoteAddr}) and $orig->{RemoteAddr} = $req->{RemoteAddr}; + $DEBUG and map{ $pkg->_debug("- + $_: ".(defined($orig->{$_}) ? $orig->{$_} : exists($orig->{$_}) ? "{undef}" : "{none}")) } sort keys %$orig; + + # https://192.168.0.3/irc/ + # ==> http://localhost:8668/irc/ + # X-Forwarded-Server: fwd.example.com + # X-Forwarded-Host: 192.168.0.3 + # X-Forwarded-For: 192.168.0.10 + + # https://192.168.0.3/irc/ + # ==> https://fwd.example.com/irc2/ (fwd.example.com=10.0.0.4) + # ==> http://localhost:8668/irc/ + # X-Forwarded-Server: fwd.example.com, fwd.example.com + # X-Forwarded-Host: 192.168.0.3, fwd.example.com + # X-Forwarded-For: 192.168.0.10, 10.0.0.4 + + my $cur = {%$orig}; + my $is_success = 1; + + while( @$allows ) + { + my $allow = shift @$allows; + $DEBUG and $pkg->_debug("- next allow: $allow"); + if( $cur->{RemoteAddr} ne $allow ) + { + $DEBUG and $pkg->_debug("- next forwarder $cur->{RemoteAddr} does not match with next allow $allow"); + $pkg->_debug(__PACKAGE__.", extract-forwarded-for is cancelled (not allowed, $cur->{RemoteAddr} for $allow)"); + $is_success = 0; + last; + } + my $next = $cur; + # 転送前情報を末尾から取り出し. + my @fwd_keys = qw(X-Forwarded-For X-Forwarded-Host X-Forwarded-Server); + my @vals = map{ + ($next->{$_} =~ s/(?:^|\s*,)\s*(\S+)\s*\z//) ? $1 : undef; + } @fwd_keys; + if( grep{ !defined($_) } @vals ) + { + my ($idx) = grep{ !defined($vals[$_]) } 0..$#vals; + my $key = $fwd_keys[$idx]; + $DEBUG and $pkg->_debug("- invalid next $key [$next->{$key}]"); + $pkg->_debug(__PACKAGE__.", extract-forwarded-for is cancelled (short $key)"); + $is_success = 0; + last; + } + my ($addr, $host, $svr) = @vals; + $next->{RemoteAddr} = $addr; + $next->{Host} = $host; + $DEBUG and $pkg->_debug("- extract: RemoteAddr=$addr, Host=$host"); + $cur = $next; + } + + # $req に結果を反映. + # 変更前のデータもついでに保持. + $req->{_extract_orig} = $orig; + $req->{RemoteAddr} = delete $cur->{RemoteAddr}; + %$hdr = ( %$hdr, %$cur ); + + if( !$is_success ) + { + $req->{RemoteAddr} = "-$req->{RemoteAddr}-"; + } + $DEBUG and $pkg->_debug("- extract: RemoteAddr=$req->{RemoteAddr}, Host=$req->{Header}{Host}"); + + 1; +} + +# ----------------------------------------------------------------------------- +# $txt = $pkg->escapeHTML($html). +# +sub escapeHTML +{ + my $pkg = shift; + my $html = shift; + $html =~ s/&/&/g; + $html =~ s//>/g; + $html =~ s/"/"/g; + $html =~ s/'/'/g; + $html; +} + +# ----------------------------------------------------------------------------- +# $pkg->_debug($msg). +# デバッグメッセージ送信用. +# +sub _debug +{ + my $this = shift; + my $msg = shift; + RunLoop->shared_loop->notify_msg($msg); +} + +# ----------------------------------------------------------------------------- +# End of Module. +# ----------------------------------------------------------------------------- +__END__ + +=encoding utf8 + +=for stopwords + YAMASHINA + Hio + ACKNOWLEDGEMENTS + AnnoCPAN + CPAN + RT + +=head1 NAME + +Tools::HTTPParser - HTTP/1.0 parser for tiarra-modules. + +=head1 VERSION + +Version 0.01 + +=head1 SYNOPSIS + + use Tools::HTTPParser; + use Module::Use qw(Tools::HTTPParser); + + my $parser = Tools::HTTPParser->new(); + + my $status = eval{ $parser->add($packet); } + $@ and die ...; + $status==0 or return; # in progress. + my $res = $parser->object(); + my $req = $parser->object(); + +=head1 DESCRIPTION + +HTTP::Parser と同様の HTTP パーサ. + +tiarra モジュール Tools::HTTPClient と互換の動作. + +結果の形式は以下の２種類. + + $request = { + StreamState => 'parsed', # greeting/header/body/parsed. + Type => 'request', + Protocol => 'HTTP/1.0', + Path => '/path/to?request', + Method => 'GET', + Header => {}, + Content => undef, + }; + + $response = { + StreamState => 'parsed', # greeting/header/body/parsed. + Type => 'request', + Protocol => 'HTTP/1.0', + Code => 200, + Message => 'OK', + Header => {}, + Content => undef, + }; + +=head1 AUTHOR + +YAMASHINA Hio, C<< >> + +=head1 COPYRIGHT & LICENSE + +Copyright 2008 YAMASHINA Hio, all rights reserved. + +This program is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +=cut + diff -urN /non-existant-dir/module/Tools/HTTPServer/Client.pm tiarra-20080510/module/Tools/HTTPServer/Client.pm --- /non-existant-dir/module/Tools/HTTPServer/Client.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/Tools/HTTPServer/Client.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,185 @@ +## ---------------------------------------------------------------------------- +# Tools::HTTPServer. +# ----------------------------------------------------------------------------- +# Mastering programmed by YAMASHINA Hio +# +# Copyright 2008 YAMASHINA Hio +# ----------------------------------------------------------------------------- +# $Id: Client.pm 9215 2008-04-09 14:37:50Z hio $ +# ----------------------------------------------------------------------------- +package Tools::HTTPServer::Client; +use strict; +use warnings; +use Tiarra::Socket::Buffered; +use base 'Tiarra::Socket::Buffered'; +use Tools::HTTPParser; +use Module::Use qw(Tools::HTTPParser); + +use Scalar::Util qw(weaken); + +our $HAS_HTTP_PARSER ||= do{ + eval { + local($SIG{__DIE__}) = "DEFAULT"; + require HTTP::Parser; + 1; + }; + $@ ? 0 : 1; +}; +print __PACKAGE__."#INIT, has HTTP::Parser: ".($HAS_HTTP_PARSER?"yes":"no")."\n"; + +1; + +# ----------------------------------------------------------------------------- +# $pkg->new(). +# +sub new +{ + my $pkg = shift; + my %opts = @_; + $pkg->_increment_caller(__PACKAGE__, \%opts); + my $this = $pkg->SUPER::new(%opts); + + $this->{callback_object} = undef; + $this->{remote_addr} = undef; + if( $HAS_HTTP_PARSER ) + { + $this->{parser} = HTTP::Parser->new(request=>1); + }else + { + $this->{parser} = Tools::HTTPParser->new(request=>1); + } + + $this; +} + +# ----------------------------------------------------------------------------- +# $obj->start(%opts). +# $opts{Socket} = $sock. # IO::Socket. +# $opts{CallbackObject} = $obj. # Tools::HTTPServer. +# +# callbacks: +# $cbo->_on_request($cli, $req); +# $cbo->_on_close_client($cli); +# +# on_request() には HTTPClient と似た形式のHASHREF が渡される. +# +# { +# Protocol => 'HTTP/1.x', +# Path => "/path/to/request", +# Method => 'GET' / 'POST', +# Header => {}. +# Content => $content, +# RemoteAddr => '127.0.0.1', +# }; +# +sub start +{ + my $this = shift; + my $opts = {@_}; + + $this->{remote_addr} = $opts->{Socket}->peerhost; + $this->attach($opts->{Socket}); + $this->install(); + + $this->{callback_object} = $opts->{CallbackObject}; + if( !$opts->{CallbackObjectNoWeaken} ) + { + weaken($this->{callback_object}); + } + + $this; +} + +# ----------------------------------------------------------------------------- +# (impl:tiarra-socket) +# +sub read +{ + my $this = shift; + my $par = $this->{callback_object}; + if( !$par ) + { + RunLoop->shared_loop->notify_error(__PACKAGE__."->read(), no callback_object"); + $this->close(); + return; + } + $this->SUPER::read(@_); + my $recv = $this->recvbuf; + $this->recvbuf = ''; + my $status = eval{ $this->{parser}->add($recv) }; + if( $@ ) + { + RunLoop->shared_loop->notify_error(__PACKAGE__."->read(), $@"); + $this->close(); + return; + } + if( $status == 0 ) + { + my $req = $this->{parser}->object(); + #print Dumper($req);use Data::Dumper; + if( UNIVERSAL::isa($req, 'HTTP::Message') ) + { + $req = Tools::HTTPParser->from_lwp($req); + } + $req->{RemoteAddr} = $this->{remote_addr}; + $par->_on_request($this, $req); + }elsif( $status == -2 ) + { + #print "need line data\n"; + }elsif( $status == -1 ) + { + #print "need more data\n"; + }else + { + # $status > 0 + #print "need $status byte(s)\n"; + } +} + +# ----------------------------------------------------------------------------- +# (impl:tiarra-socket) +# +sub close +{ + my $this = shift; + my $par = $this->{callback_object}; + $this->SUPER::close(@_); + if( !$par ) + { + RunLoop->shared_loop->notify_error(__PACKAGE__."->close(), no callback_object"); + return; + } + $par->_on_close_client($this); +} + +# ----------------------------------------------------------------------------- +# $obj->response($res). +# +sub response +{ + my $this = shift; + my $res = shift; + + $this->append( Tools::HTTPParser->to_string($res) ); + + $this; +} + +# ----------------------------------------------------------------------------- +# End of Module. +# ----------------------------------------------------------------------------- +# ----------------------------------------------------------------------------- +# End of File. +# ----------------------------------------------------------------------------- +__END__ + +=encoding utf8 + +=for stopwords + YAMASHINA + Hio + ACKNOWLEDGEMENTS + AnnoCPAN + CPAN + RT + diff -urN /non-existant-dir/module/Tools/HTTPServer.pm tiarra-20080510/module/Tools/HTTPServer.pm --- /non-existant-dir/module/Tools/HTTPServer.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/Tools/HTTPServer.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,269 @@ +## ---------------------------------------------------------------------------- +# Tools::HTTPServer. +# ----------------------------------------------------------------------------- +# Mastering programmed by YAMASHINA Hio +# +# Copyright 2008 YAMASHINA Hio +# ----------------------------------------------------------------------------- +# $Id: HTTPServer.pm 9215 2008-04-09 14:37:50Z hio $ +# ----------------------------------------------------------------------------- +package Tools::HTTPServer; +use strict; +use warnings; +use Tiarra::Socket; +use base 'Tiarra::Socket'; + +use Tools::HTTPServer::Client; +use Module::Use qw(Tools::HTTPServer::Client); + +use Scalar::Util qw(weaken); + +our $DEBUG = 0; + +1; + +# ----------------------------------------------------------------------------- +# $pkg->new(). +# +sub new +{ + my $pkg = shift; + my %opts = @_; + $pkg->_increment_caller(__PACKAGE__, \%opts); + my $this = $pkg->SUPER::new(%opts); + + $this->{host} = undef; + $this->{port} = undef; + $this->{listen} = undef; + $this->{path} = undef; + + $this->{clients} = []; + $this->{callback_object} = undef; + + $this; +} + +# ----------------------------------------------------------------------------- +# (destructor). +# +sub DESTROY +{ + my $this = shift; + if( $this->sock ) + { + $this->detach(); + } +} + +# ----------------------------------------------------------------------------- +# $obj->start(%opts). +# Host: $host. +# Port: $port. +# Listen: $backlog. +# +sub start +{ + my $this = shift; + my $opts = {@_}; + + $this->{host} = $opts->{Host} || '127.0.0.1'; + $this->{port} = $opts->{Port} || 8080; + $this->{listen} = $opts->{Listen} || 5; + + # 処理するパス. + # /path/to/process/ の最初も最後も / がついている形に正規化. + my $path = $opts->{Path} || '/'; + $path =~ m{^/} or $path = "/$path"; + $path =~ m{/$} or $path = "$path/"; + $this->{path} = $path; + + $this->{callback_object} = $opts->{CallbackObject}; + if( !$opts->{CallbackObjectNoWeaken} ) + { + weaken($this->{callback_object}); + } + + my $sock = IO::Socket::INET->new( + LocalHost => $this->{host}, + LocalPort => $this->{port}, + Listen => $this->{listen}, + ReuseAddr => 1, + ); + + if( $sock ) + { + $this->attach($sock); + $this->install(); + + my $pkg = ref($this); + my $name = $this->name; + my $where = $this->where; + $name =~ s/^(?:\Q$pkg\E)?/$pkg ($where)/; + $this->name($name); + } + + $this; +} + +# ----------------------------------------------------------------------------- +# $loc = $obj->where(). +# $loc = 'http://host:port/path/'. +# +sub where +{ + my $this = shift; + if( $this->sock ) + { + my $host = $this->{host}; + my $port = $this->{port}; + my $path = $this->{path}; + "http://$host:$port$path"; + }else + { + undef; + } +} + +# ----------------------------------------------------------------------------- +# (impl:tiarra-socket) +# +sub want_to_write { 0 } +#sub write {} # never used. +#sub exception {} # never used. +sub read +{ + my $this = shift; + + my $sock = $this->sock->accept(); + if( !$sock ) + { + RunLoop->shared_loop->notify_error(__PACKAGE__.", accept failed: $!/$@"); + return; + } + + $this->_on_accept($sock); +} + +sub close +{ + my $this = shift; + $this->SUPER::close(@_); + + my $list = $this->{clients}; + foreach my $cli (@$list) + { + $cli and $cli->close(); + } + @$list = (); +} + +# ----------------------------------------------------------------------------- +# $this->_on_accept($sock). +# (private). +# +sub _on_accept +{ + my $this = shift; + my $sock = shift; + + # 接続元制限とかいれたければこのあたりでいれてもいいのかも？ + + $this->_start_client($sock); +} + +# ----------------------------------------------------------------------------- +# $this->_start_client($sock). +# +sub _start_client +{ + my $this = shift; + my $sock = shift; + + my $peer = $sock->peerhost.':'.$sock->peerport; + $DEBUG and $this->_debug("start client $peer"); + + my $cli = Tools::HTTPServer::Client->new(); + push(@{$this->{clients}}, $cli); + + $cli->start( + Socket => $sock, + CallbackObject => $this, + ); + + $this; +} + +# ----------------------------------------------------------------------------- +# (impl:callback-from-Tools::HTTPServer::Client). +# +sub _on_request +{ + my $this = shift; + my $cli = shift; + my $req = shift; + + # このオブジェクトからのコールバックを起動. + my $par = $this->{callback_object}; + if( !$par ) + { + RunLoop->shared_loop->notify_error(__PACKAGE__."->_on_request(), no callback_object"); + return; + } + $par->_on_request($cli, $req); +} + +# ----------------------------------------------------------------------------- +# (impl:callback-from-Tools::HTTPServer::Client). +# +sub _on_close_client +{ + my $this = shift; + my $cli = shift; + + # 保持しているクライアント一覧から除去. + my $list = $this->{clients}; + @$list = grep { $_ && $_ ne $cli } @$list; + + # このオブジェクトからのコールバックを起動. + my $par = $this->{callback_object}; + if( !$par ) + { + RunLoop->shared_loop->notify_error(__PACKAGE__."->_on_close_client(), no callback_object"); + return; + } + my $sub = $par->can('_on_close_client'); + if( $sub ) + { + $par->$sub($cli); + } +} + +# ----------------------------------------------------------------------------- +# $this->_debug($msg). +# +sub _debug +{ + my $this = shift; + my $msg = shift; + RunLoop->shared_loop->notify_msg($msg); +} + + +# ----------------------------------------------------------------------------- +# End of Module. +# ----------------------------------------------------------------------------- +# ----------------------------------------------------------------------------- +# End of File. +# ----------------------------------------------------------------------------- +__END__ + +=encoding utf8 + +=for stopwords + YAMASHINA + Hio + ACKNOWLEDGEMENTS + AnnoCPAN + CPAN + RT + diff -urN /non-existant-dir/module/Tools/Hash.pm tiarra-20080510/module/Tools/Hash.pm --- /non-existant-dir/module/Tools/Hash.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/Tools/Hash.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,235 @@ +# ----------------------------------------------------------------------------- +# $Id: Hash.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +# Hash をデータストレージとして便利に使えるようにするクラス。 +# ----------------------------------------------------------------------------- +# copyright (C) 2004 Topia . all rights reserved. +package Tools::Hash; +use strict; +use warnings; +use enum qw(PARENT DATA); +use Tiarra::Utils; +use overload + '%{}' => sub { shift->data }, + 'bool' => sub { %{shift->data} }; + +utils->define_array_attr_accessor(0, 'parent'); +utils->define_array_attr_getter(0, 'data'); + +sub new { + my ($class, $parent, $data) = @_; + + my $this = []; + $this->[PARENT] = $parent; + $this->[DATA] = utils->get_first_defined($data, {}); + bless $this, $class; + $this; +} + +sub drop_parent { shift->parent(undef); } +sub set_parent { shift->parent(shift); } +sub keys { CORE::keys(%{shift->data}); } +sub values { CORE::values(%{shift->data}); } + +sub clone { + my ($this, %args) = @_; + if ($args{deep}) { + ref($this)->new(undef, + eval(Data::Dumper->new([$this->data]) + ->Terse(1)->Deepcopy(1)->Purity(1)->Dump)); + } else { + # shallow copy + ref($this)->new(undef, {%{$this->data}}); + } +} + +sub manipulate_keyname { + # this method update myself, please clone before. + my ($this, %opts) = @_; + + $this->with_session( + sub { + my ($new_data) = {}; + my $new_key; + foreach my $key ($this->keys) { + $new_key = $key; + $new_key = $opts{prefix} . $new_key if defined $opts{prefix}; + $new_key .= $opts{suffix} if defined $opts{suffix}; + $new_key = $opts{code}->($new_key) if defined $opts{code}; + $new_data->{$new_key} = $this->{$key}; + } + $this->[DATA] = $new_data; + $this->set_modified; + }); + + $this; +} + +sub equals { + my ($this, $target) = @_; + + $this->with_session( + sub { + $target->with_session( + sub { + map { + return 0 if $this->$_ != $target->$_; + } qw(keys values); + my ($key, $value); + my ($values, $target_values); + while (($key, $values) = each %$this) { + $target_values = $target->get_array($key); + return 0 unless defined $target_values; + return 0 unless @$values != @$target_values; + $target_values = [@$target_values]; # clone + foreach $value (sort @$values) { + if ($value ne shift(@$target_values)) { + return 0; + } + } + } + })}); + return 1; +} + +sub with_session { + my $this = shift; + if (defined $this->parent) { + $this->parent->with_session(@_); + } else { + shift->(); + } +} + +foreach (qw(set_modified queue_cleanup)) { + eval " + sub $_ \{ + my \$this = shift; + if (defined \$this->parent) { + \$this->parent->$_(\@_); + } + }"; +} + +sub get_value_random { + my ($this, $key) = @_; + + my $values = $this->get_array($key); + if ($values) { + # 発見. どれか一つ選ぶ。 + my $idx = int(rand() * hex('0xffffffff')) % @$values; + return $values->[$idx]; + } + return undef; +} + +sub get_value { + my ($this, $key) = @_; + + my $values = $this->get_array($key); + if ($values) { + # 発見. + return $values->[0]; + } + return undef; +} + +sub get_array { + my ($this, $key) = @_; + + $this->with_session( + sub { + my $value = $this->data->{$key}; + if (defined $value) { + # 発見 + if (ref($value) eq 'ARRAY') { + return $value; + } else { + return [$value]; + } + } + return undef; + }); +} + +sub add_hash { + my ($this, %hash) = @_; + my $retval = 1; + + $this->with_session( + sub { + map { + my $value = $hash{$_}; + if (ref($value) ne 'ARRAY') { + $value = [$value]; + } + $retval &= $this->add_array($_, @$value) ? 1 : 0; + } CORE::keys %hash; + }); + return $retval; +} + +sub add_array { + # 成功すれば 1(true) が返る。 + # 不正なキーのため失敗した場合は 0(false) が返る。 + + my ($this, $key, @values) = @_; + + return 0 if $key =~ / /; + + $this->with_session( + sub { + my $data = $this->data->{$key}; + if (!defined $data) { + $data = []; + $this->data->{$key} = $data; + } + push @$data,@values; + $this->set_modified; + }); + + return 1; +} + +sub del_array { + my ($this, $key, @values) = @_; + + $this->with_session( + sub { + my $data = $this->data->{$key}; + if (defined $data) { + my ($count) = scalar @$data; + if (@values) { + my $item; + @$data = grep { + $item = $_; + !(utils->get_first_defined( + map { + $item eq $_ ? 1 : undef; + } @values)) + } @$data; + $count -= scalar(@$data); + # この項目が空になったら項目自体を削除 + if (@$data == 0) { + delete $this->data->{$key}; + } + } else { + # @values が指定されていない場合は項目削除 + delete $this->data->{$key}; + } + $this->set_modified; + $this->queue_cleanup; + # deleted + return $count; + } + + # not deleted + return 0; + }); +} + +*add_value = \&add_array; +*del_value = \&del_array; +*del_key = \&del_array; + +1; diff -urN /non-existant-dir/module/Tools/HashDB.pm tiarra-20080510/module/Tools/HashDB.pm --- /non-existant-dir/module/Tools/HashDB.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/Tools/HashDB.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,220 @@ +# -*- cperl -*- +# ----------------------------------------------------------------------------- +# $Id: HashDB.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +# copyright (C) 2003-2004 Topia . all rights reserved. + +# GroupDB の1レコード分のデータを保持する。 + +# - 情報(注意) - +# * キー名に半角スペースは含められません。 error が出ます。 +# * 値の先頭、最後にある空白文字(\s)は読み込み時に消失します。 +# * 機能不足です。 +# * コードが読みにくいです。 + +# technical information +# - datafile format +# | abc: def +# -> key 'abc', value 'def' +# | : abc : def +# -> key ':abc:', value 'def' +# LINE := KEY ANYSPACES [value] ANYSPACES が基本。 +# KEY := ANYSPACES [keyname] ANYSPACES ':' || ANYSPACES ':' [keyname] ':' +# ANYSPACES := REGEXP:\s* +# [keyname] にはコロンをスペースに変換したキー名が入る。 +# キー名の先頭または最後にスペースがある場合は、KEYの後者のフォーマットを使用する。 +# [value] はそのまま。つまり複数行になるデータは追加できない。エラーを出すべきか? + +package Tools::HashDB; +use strict; +use warnings; +use IO::File; +use File::stat; +use Tiarra::Encoding; +use Mask; +use Carp; +use Module::Use qw(Tools::Hash Tools::HashTools); +use Tools::Hash; +use Tools::HashTools; +use Tiarra::Utils; +use Tiarra::ModifiedFlagMixin; +use Tiarra::SessionMixin; +use base qw(Tiarra::SessionMixin); + +sub new { + # コンストラクタ + + # - 引数 - + # $fpath : 保存するファイルのパス。空ファイル or undef でファイルに関連付けられないDBが作成されます。 + # $charset : ファイルの文字セットを指定します。省略すれば UTF-8 になります。 + # $use_re : 値の検索/一致判定に正規表現拡張を使うかどうか。省略されれば使いません。 + # $ignore_proc + # : 無視する行を指定するクロージャ。行を引数に呼び出され、 true が返ればその行を無視します。 + # ここで ignore された行は解析さえ行いませんので、 + # $split_primary=0でも区切りと認識されたりはしません。 + # 一般的な注意として、この状態のデータベースが保存された場合は ignore された行は全て消滅します。 + + my ($class,$fpath,$charset,$use_re,$ignore_proc) = @_; + + my $this = { + time => undef, # ファイルの最終読み込み時刻 + fpath => $fpath, + charset => $charset || 'utf8', # ファイルの文字コード + use_re => $use_re || 0, + ignore_proc => $ignore_proc || sub { $_[0] =~ /^\s*#/; }, + + database => undef, # HASH + }; + + bless $this,$class; + $this->clear_modified; + $this->_session_init; + $this->_load; +} + +__PACKAGE__->define_attr_accessor(0, + qw(time fpath charset), + qw(use_re)); +__PACKAGE__->define_proxy('database', 0, + qw(keys values), + qw(add_value add_array del_value del_array), + qw(get_array get_value get_value_random)); +__PACKAGE__->define_session_wrap(0, + qw(checkupdate synchronize cleanup)); + +sub _load { + my $this = shift; + + my $database = Tools::Hash->new; + + if (defined $this->fpath && $this->fpath ne '') { + my $fh = IO::File->new($this->fpath,'r'); + if (defined $fh) { + my $unicode = Tiarra::Encoding->new; + foreach (<$fh>) { + my $line = $unicode->set($_, $this->charset)->get; + next if $this->{ignore_proc}->($line); + my ($key,$value) = grep {defined($_)} + ($line =~ /^\s*(?:([^:]+?)\s*|:([^:]+?)):\s*(.+?)\s*$/); + if (!defined $key || $key eq '' || + !defined $value || $value eq '') { + # ignore + } else { + # can use colon(:) on key, but cannot use space( ). + $key =~ s/ /:/g; + $database->add_value($key, $value); + } + } + $this->{database} = $database; + $this->set_time; + $this->clear_modified; + } + } + return $this; +} + +sub _checkupdate { + my $this = shift; + + if (defined $this->fpath && $this->fpath ne '') { + my $stat = stat($this->fpath); + + if (defined $stat && defined $this->time && + $stat->mtime > $this->time) { + $this->_load(); + return 1; + } + } + return 0; +} + +sub _synchronize { + my $this = shift; + my $force = shift || 0; + + if (defined $this->fpath && $this->fpath ne '' && + ($this->modified || $force)) { + my $fh = IO::File->new($this->fpath,'w'); + if (defined $fh) { + my $unicode = Tiarra::Encoding->new; + while (my ($key,$values) = each %{$this->{database}}) { + $key =~ s/:/ /g; # can use colon(:) on key, but cannot use space( ). + # \s が先頭/最後にあった場合読み込みで消え去るのでそれを防止。 + $key = ':' . $key if ($key =~ /^\s/ || $key =~ /\s$/); + map { + my $line = "$key: " . $_ . "\n"; + $fh->print($unicode->set($line)->conv($this->{charset})); + } @$values + } + $this->set_time; + $this->clear_modified; + } + } + return $this; +} + +sub set_time { shift->time(CORE::time); } + +sub database { + my $this = shift; + return $this->with_session(sub{$this->{database};}); +} +*to_hashref = \&database; + +sub _before_session_start { + my $this = shift; + $this->_checkupdate; +} + +sub _after_session_finish { + my $this = shift; + $this->_synchronize; +} + +# group misc functions +sub dup_group { + # グループの複製を行います。 + + my ($group) = @_; + my ($new_group) = {}; + + return undef unless defined($group); + + map { + $new_group->{$_} = $group->{$_}; + } CORE::keys(%$group); + + return $new_group; +} + +sub concat_string_to_key { + # prefix や suffix を group の key に付加します。 + + # - 引数 - + # $group : グループ。 + # $prefix : prefix 文字列 ('to.' とか 'from.' とか) + # $suffix : suffix 文字列 + my ($group, $prefix, $suffix) = @_; + my ($new_group) = {}; + + $prefix = '' unless defined($prefix); + $suffix = '' unless defined($suffix); + + map { + $new_group->{$prefix . $_ . $suffix} = $group->{$_}; + } CORE::keys(%$group); + + return $new_group; +} + +# replace support functions +sub replace_with_callbacks { + # マクロの置換を行なう。%optionalは置換に追加するキーと値の組みで、省略可。 + # $callbacksはgroup/optionalで置換できなかった際に呼び出されるコールバック関数のリファレンス。 + # optionalの値はSCALARでもARRAYでも良い。 + my ($this,$str,$callbacks,%optional) = @_; + my $main_table = %{$this->to_hashref}; + return Tools::HashTools::replace_recursive($str,[$main_table,\%optional],$callbacks); +} + +1; diff -urN /non-existant-dir/module/Tools/HashTools.pm tiarra-20080510/module/Tools/HashTools.pm --- /non-existant-dir/module/Tools/HashTools.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/Tools/HashTools.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,161 @@ +# -*- cperl -*- +# ----------------------------------------------------------------------------- +# $Id: HashTools.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +# copyright (C) 2003 Topia . all rights reserved. + +# ハッシュをフォーマットする関数群。 + +package Tools::HashTools; + +sub get_value_random { + my ($hash, $key) = @_; + + my $values = get_array($hash, $key); + if ($values) { + # 発見. どれか一つ選ぶ。 + my $idx = int(rand() * hex('0xffffffff')) % @$values; + return $values->[$idx]; + } + return undef; +} + +sub get_value { + my ($hash, $key) = @_; + + my $values = get_array($hash, $key); + if ($values) { + # 発見. + return $values->[0]; + } + return undef; +} + +sub get_array { + my ($hash, $key) = @_; + + my $value = $hash->{$key}; + if (defined $value) { + # 発見 + if (ref($value) eq 'ARRAY') { + return $value; + } else { + return [$value]; + } + last; + } + return undef; +} + +sub replace_recursive { + # ()がネスト可能な_replace. + + # ていうか ad hoc 過ぎる気がするなあ。良い解析方法無いかな。 + + my ($str,$hashtables,$callbacks) = @_; + + return '' if !defined($str) || ($str eq ''); + + my $start = 0; + my $end; + my $pos; + while (($pos = $start = index($str, '#(', $start)) != -1) { + # 検索開始。 + my $level = 1; + do { + # こっかを探す。 + $end = index($str, ')', $pos + 1); + if ($end == -1) { + # こっかが無い。困ったことになったが、終わった後にこっかがあったことにして誤魔化そう。 + $str .= ')'; + $end = length($str); + last; + } + + # かっこを探す。 + my $next = index($str, '(', $pos + 2); + if ($next == -1 || $next > $end) { + # かっこが無かったか、こっかより後。階層レベルを減らして検索位置を次のこっかに移す。 + $pos = $end; + $level--; + } else { + # こっかより前にかっこがあった。階層レベルを増やして繰り返す。 + $pos = $next; + $level++; + } + } while ($level > 0); # 階層レベルが0になるまで繰り返し。 + # こっかの前までを抽出範囲とする。 + $end--; + #proc $start to $end + my $work = substr($str, $start + 2, $end - $start - 1); + $work = _replace($work,$hashtables,$callbacks); + substr($str, $start, $end - $start + 2) = $work; + $start = $start + length($work); + } + + return $str; +} + +sub _replace { + my ($str,$hashtables,$callbacks) = @_; + + # variables := variable ( '|' variable )* + # variable := key ( ';' format )? + foreach my $variable (split /\|/,$str) { + my ($key, $format) = split(/;/,$variable,2); + my ($ret) = undef; + if (defined($key) && $key ne '') { + foreach my $table (@$hashtables) { + $ret = get_value($table, $key); + last if (defined $ret); + } + if (!defined $ret) { + # not found. + foreach my $callback (@$callbacks) { + if (defined $callback) { + # callback function definition: func($key, [hashtables], [callbacks]); + my $value = $callback->($key, $hashtables, $callbacks); + if (defined $value) { + $ret = $value; + last; + } + } + } + } + } else { + # callback等がエラーを吐くので強制的に''を入れる。 + $ret = ''; + } + if (defined $ret) { + if (defined $format) { + return _format($format,$ret,$hashtables,$callbacks); + } else { + return $ret; + } + } + } + # 最終的に見付からなければ$strそのものを返す。 + return $str; +} + +sub _format { + # %s形式の値をフォーマットする。 + # replace_recursiveを呼び出して再帰変換も行う。 + my ($str,$value,$hashtables,$callbacks) = @_; + + $str = replace_recursive($str,$hashtables,$callbacks); + $str =~ s/%(.)/_format_percent($1, $value)/eg; + return $str; +} + +sub _format_percent { + $char = shift; + + if ($char eq 's') { + return $_[0]; + } else { + return $char; + } +} + +1; diff -urN /non-existant-dir/module/Tools/LinedDB.pm tiarra-20080510/module/Tools/LinedDB.pm --- /non-existant-dir/module/Tools/LinedDB.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/Tools/LinedDB.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,303 @@ +# -*- cperl -*- +# ----------------------------------------------------------------------------- +# $Id: LinedDB.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +# copyright (C) 2003 Topia . all rights reserved. +package Tools::LinedDB; +use strict; +use warnings; +use IO::File; +use File::stat; +use Tiarra::Encoding; +use Mask; +use Carp; + +sub new { + my ($class, %arg) = @_; + + foreach my $key qw(Parse Build Compare Update Hash) { + croak($key . ' should be undef or code reference!') + unless !defined($arg{$key}) || (ref($arg{$key}) eq 'CODE'); + } + + # Compare も Hash も既定を使う場合は、 Hash には _do_nothing を使う。 + $arg{'Hash'} = \&_do_nothing if !defined($arg{'Compare'}) && !defined($arg{'Hash'}); + + my $this = + { + database => [], + fpath => $arg{'FilePath'}, + charset => $arg{'Charset'} || 'utf8', + parse_func => $arg{'Parse'} || \&_do_nothing, + build_func => $arg{'Build'} || \&_do_nothing, + compare_func => $arg{'Compare'} || \&_do_compare_default, + update_callback => $arg{'Update'} || \&_do_nothing, + hash_func => $arg{'Hash'}, + time => undef, # ファイルの最終読み込み時刻 + }; + + # Build が指定されているのに Compare が既定のときは build してから compare する。 + if (defined($arg{'Build'}) && !defined($arg{'Compare'})) { + $this->{compare_func} = sub { + return _do_compare_default(map { + $this->{build_func}->($_); + } @_); + }; + } + + bless $this, $class; + + return $this->_load; +} + +sub _load { + my ($this) = @_; + if (defined $this->{fpath} && $this->{fpath} ne '') { + $this->{database} = []; + my $fh = IO::File->new($this->{fpath},'r'); + if (defined $fh) { + my $unicode = Tiarra::Encoding->new; + foreach my $line (<$fh>) { + chomp $line; + map { + push @{$this->{database}}, $_; + } $this->{parse_func}->($unicode->set($line,$this->{charset})->get); + } + $this->{time} = time(); + } + } + + $this->{update_callback}->(); + return $this; +} + +sub synchronize { + my ($this) = @_; + if (defined $this->{fpath} && $this->{fpath} ne '') { + my $fh = IO::File->new($this->{fpath},'w'); + if (defined $fh) { + my $unicode = Tiarra::Encoding->new; + foreach my $line (@{$this->{database}}) { + map { + $fh->print($unicode->set($_ . "\n")->conv($this->{charset})); + } $this->{build_func}->($line); + } + $this->{time} = time(); + } + } + + $this->{update_callback}->(); + return $this; +} + +sub checkupdate { + my ($this) = @_; + + if (defined $this->{fpath} && $this->{fpath} ne '') { + my $stat = stat($this->{fpath}); + + if (defined($stat) && ($stat->mtime > $this->{time})) { + $this->_load(); + } + } +} + +sub length { + my ($this) = @_; + + $this->checkupdate(); + return scalar(@{$this->{database}}); +} + +sub index { + my ($this, $index) = @_; + + return $this->indexes($index); +} + +sub indexes { + my ($this, @indexes) = @_; + + $this->checkupdate(); + if (wantarray) { + return map { + $this->{database}->[$_]; + } @indexes; + } else { + return undef unless @indexes; + return $this->{database}->[$indexes[0]]; + } +} + +sub get_value { + my ($this) = @_; + + $this->checkupdate(); + if (@{$this->{database}} == 0) { + return undef; + } else { + my $idx = int(rand() * hex('0xffffffff')) % @{$this->{database}}; + return $this->index($idx); + } +} + +sub get_array { + my ($this) = @_; + + $this->checkupdate(); + return @{$this->{database}}; +} + +sub set_value { + my ($this, $index, $value) = @_; + + $this->checkupdate(); + $this->{database}->[$index] = $value; + $this->synchronize(); + return $this; +} + +sub set_array { + my ($this, @array) = @_; + + $this->checkupdate(); + @{$this->{database}} = @array; + $this->synchronize(); + return 0; +} + +sub find_index { + my ($this, $value) = @_; + + return $this->find_indexes($value, 1); +} + +sub find_indexes { + my ($this, $value, $count) = @_; + my (@indexes) = (); + + my ($return) = sub { + if (wantarray) { + return @indexes; + } else { + return $indexes[0] || undef; + } + }; + + my $raw_value = $value; + $this->checkupdate(); + for ( my $i = (@{$this->{database}} - 1) ; $i >= 0 ; --$i ) { + if ($this->{compare_func}->($this->{database}->[$i], $raw_value) == 0) { + push(@indexes, $i); + if (defined($count) && @indexes >= $count) { + return $return->(); + } + } + } + + return $return->(); +} + +sub find_value { + my ($this, $value) = @_; + + return $this->find_values($value, 1); +} + +sub find_values { + my ($this, $value, $count) = @_; + + return $this->indexes($this->find_indexes($value, $count)); +} + +sub add_value { + my ($this, $value) = @_; + + $this->checkupdate(); + push(@{$this->{database}}, $value); + $this->synchronize(); + + return 1; +} + +sub add_value_unique { + my ($this, $value) = @_; + + if (!defined($this->find_value($value))) { + return $this->add_value($value); + } + + return 0; +} + +sub del_value { + my ($this, $value, $count) = @_; + + my $raw_value = $value; + $this->checkupdate(); + my ($deleted_count) = 0; + for ( my $i = (@{$this->{database}} - 1) ; $i >= 0 ; --$i ) { + if ($this->{compare_func}->($this->{database}->[$i], $raw_value) == 0) { + # equal. delete. + splice(@{$this->{database}}, $i, 1); + ++$deleted_count; + if (defined($count) && $deleted_count >= $count) { + $this->synchronize(); + return $deleted_count; + } + } + } + + $this->synchronize(); + return $deleted_count; +} + +sub del_value_single { + my ($this, $value) = @_; + + return $this->del_value($value, 1); +} + +sub simplify { + my ($this) = @_; + + $this->checkupdate(); + if (defined($this->{hash_func})) { + # hash mode. + my (%buf); + @{$this->{database}} = grep { + if (defined($buf{$this->{hash_func}->($_)})) { + # not found past. + $buf{$this->{hash_func}->($_)} = 1; + 1; + } else { + 0; + } + } @{$this->{database}}; + } else { + # compare mode. + + # hash_func が登録されてない場合、hash を使った整理は compare_func の定義に依るので不可。 + # 単純に比較することになるため、非常に重くなるであろう。 + + # 未実装。 + croak('not specified hash function. this mode hasn\'t implemented yet.'); + } + + $this->synchronize(); + return $this; +} + +sub _do_nothing { + # なにもせずただ値を返す + return wantarray ? @_ : $_[0]; +} + +sub _do_compare_default { + # デフォルトの比較関数。 + my ($a, $b) = @_; + + return ($a cmp $b); +} + +1; diff -urN /non-existant-dir/module/Tools/MailSend/EachServer.pm tiarra-20080510/module/Tools/MailSend/EachServer.pm --- /non-existant-dir/module/Tools/MailSend/EachServer.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/Tools/MailSend/EachServer.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,748 @@ +# -*- cperl -*- +# ----------------------------------------------------------------------------- +# $Id: EachServer.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +# copyright (C) 2003 Topia . all rights reserved. +package Tools::MailSend::EachServer; +use strict; +use warnings; +use Module::Use qw(Tools::DateConvert); +use Tools::DateConvert; +use RunLoop; +use LinedINETSocket; +use Tiarra::Encoding; + +my $E_MAIL_EOL = "\x0d\x0a"; + +# constant +my $STATE_NONE = 0; +my $STATE_POP3 = 1; +my $STATE_SMTP = 2; + +my $DATA_TYPE_ARRAY = 0; +my $DATA_TYPE_INNER_ITER = 1; + +sub new { + my ($class, %data) = @_; + + return undef unless defined($data{'cleaner'}); + + my $this = { + use_pop3 => 0, + pop3_host => 'localhost', + pop3_port => getservbyname('pop3', 'tcp') || 110, + pop3_user => eval { (getpwuid($>))[0] } || '', + pop3_pass => '', + pop3_expire => 0, + + smtp_host => 'localhost', + smtp_port => getservbyname('smtp', 'tcp') || 25, + smtp_fqdn => 'localhost', + smtp_user => '', + smtp_pass => '', + + # cleaner is destruction function. + cleaner => undef, + + # parent local datas + local => undef, + + expire_time => undef, + state => undef, + # undef: not found + # other: $STATE_* + + local_state => undef, + # undef: not found + # other: unknown. + + queue => [], + + sock => undef, + + esmtp_capable => [], + + hook => undef, + + timer => undef, + + }; + + # failsafe timer + $this->{timer} = + Timer->new( + Interval => 5, + Repeat => 1, + Code => sub { + my ($timer) = @_; + $this->main_loop(); + } + )->install; + + bless $this, $class; + + foreach my $key (keys %data) { + $this->_set_data($key, $data{$key}); + } + + return $this; +} + +#--- constant --- +sub DATA_TYPES { + return { + array => $DATA_TYPE_ARRAY, # data に送信行の raw data を渡す。 + inner_iter => $DATA_TYPE_INNER_ITER, # data にコールバック関数を渡す。 + }; +} + +#--- server info --- +sub get_data { + my ($this, $name) = @_; + + return undef unless + grep {$name eq $_} + (qw(local cleaner use_pop3), + (map { 'pop3_' . $_ } qw(host port user pass expire)), + (map { 'smtp_' . $_ } qw(host port fqdn user pass))); + return $this->{$name}; +} + +sub _set_data { + my ($this, $name, $value) = @_; + + return undef unless + grep {$name eq $_} + (qw(local cleaner use_pop3), + (map { 'pop3_' . $_ } qw(host port user pass expire)), + (map { 'smtp_' . $_ } qw(host port fqdn user pass))); + + $this->{$name} = $value; + return 1; +} + +sub mail_send_reserve { + my ($this, %arg) = @_; + + return 1 unless $arg{'env_from'}; + return 1 unless $arg{'env_to'}; + return 1 unless $arg{'data'}; + + push(@{$this->{queue}}, { + # local + local => $arg{'local'}, + + # sender + sender => $arg{'sender'} || undef, + + # queue priority + priority => $arg{'priority'} || 0, + + # envelope from + env_from => $arg{'env_from'}, + + # envelope to [array] + env_to => $arg{'env_to'}, + + # header from + from => $arg{'from'}, + + # header to + to => $arg{'to'} || undef, + + # header subject + subject => $arg{'subject'} || undef, + + # data type [0=array, 1=inner_iter] + data_type => $arg{'data_type'}, + + # data + data => $arg{'data'}, + + # reply ok + reply_ok => $arg{'reply_ok'} || \&_do_nothing, + + # reply error + reply_error => $arg{'reply_error'} || \&_do_nothing, + + # reply fatal + reply_fatal => $arg{'reply_fatal'} || \&_do_nothing, + }); + # if state is undef (not processing), start. + $this->{state} = $STATE_NONE unless defined($this->{state}); + # continue_loop + $this->main_loop(); + + return 0; +} + +sub _do_nothing { + # noop func +} + +sub clean { + my ($this) = @_; + + $this->{cleaner}->($this); + undef $this->{cleaner}; + $this->{hook}->uninstall if defined($this->{hook}); + $this->{hook} = undef; + $this->{timer}->uninstall if defined($this->{timer}); + $this->{timer} = undef; +} + +sub main_loop { + my ($this) = @_; + my ($state) = $this->{state}; + + if (!defined($state)) { + # if undef, nothing to process + if (!defined($this->{expire_time}) || $this->{expire_time} < time()) { + return $this->clean(); + } + return; + } + # activate hook + if (!defined($this->{hook})) { + $this->{hook} = RunLoop::Hook->new( + sub { + my ($hook) = @_; + $this->main_loop(); + })->install('before-select'); + } + + if ($state == $STATE_NONE) { + $state = $STATE_SMTP; # fallback + if ($this->{use_pop3} && !defined($this->{expire_time})) { + $state = $STATE_POP3; + } + } + + $this->{state} = $state; + + if ($state == $STATE_POP3) { + $this->_state_pop3(); + } elsif ($state == $STATE_SMTP) { + $this->_state_smtp(); + } +} + + +# --- pop3 --- +sub _state_pop3 { + my ($this) = @_; + + if (!defined($this->{sock})) { + $this->{sock} = $this->_open_pop3(); + if (!defined($this->{sock})) { + RunLoop->shared->notify_warn('mesmail: cannot connect pop3, but start smtp.'); + $this->{state} = $STATE_SMTP; + return; + } else { + $this->{local_state} = 'FIRST'; + } + } + while ($this->_do_pop3()) { + # noop + }; +} + + +sub _open_pop3 { + my ($this) = @_; + my ($host, $port, $sock); + + $host = $this->{pop3_host}; + $port = $this->{pop3_port}; + + $sock = LinedINETSocket->new($E_MAIL_EOL)->connect($host, $port); + + return undef unless (defined $sock); + return $sock; +} + +sub _do_pop3 { + my ($this) = @_; + my ($local_state) = $this->{local_state}; + my ($sock) = $this->{sock}; + + # wait +OK + my ($line) = $sock->pop_queue(); + return 0 unless defined($line); # none data received + if (substr($line, 0, 3) ne '+OK') { + # error + RunLoop->shared->notify_warn('mesmail: pop3 send command "'.$local_state.'" reply is not OK...'); + RunLoop->shared->notify_warn('mesmail: message is ' . $line); + RunLoop->shared->notify_warn('mesmail: but start smtp.'); + $this->_close_pop3(); + return undef; + } else { + if ($local_state eq 'FIRST') { + # send USER + $this->{local_state} = 'USER'; + $sock->send_reserve('USER ' . $this->{pop3_user}); + } elsif ($local_state eq 'USER') { + # send PASS + $this->{local_state} = 'PASS'; + $sock->send_reserve('PASS ' . $this->{pop3_pass}); + } elsif ($local_state eq 'PASS') { + # send STAT + $this->{local_state} = 'STAT'; + $sock->send_reserve("STAT"); + } elsif ($local_state eq 'STAT') { + # close pop3 + $this->{expire_time} = time() + ($this->{pop3_expire} * 60); + $this->_close_pop3(); + return 0; + } + return 1; + } + return 0; # this return is not used +} + +sub _close_pop3 { + my ($this) = @_; + my ($sock) = $this->{sock}; + + $sock->send_reserve('QUIT'); + $sock->disconnect_after_writing(); + $sock->flush(); # flush + $this->{sock} = undef; + $this->{local_state} = undef; + $this->{state} = $STATE_SMTP; + + $this->main_loop(); + + return undef; +} + + +# --- smtp --- +sub _state_smtp { + my ($this) = @_; + + if (!defined($this->{sock})) { + $this->{sock} = $this->_open_smtp(); + if (!defined($this->{sock})) { + $this->_reply_smtp_error(undef, 'CONNECT'); # undef is all + $this->{state} = undef; + return; + } else { + $this->{local_state} = 'FIRST'; + } + } + while ($this->_do_smtp()) { + # noop + } +} + +sub _open_smtp { + my ($this) = @_; + my ($host, $port, $sock); + + $host = $this->{smtp_host}; + $port = $this->{smtp_port}; + + $sock = LinedINETSocket->new($E_MAIL_EOL)->connect($host, $port); + + return undef unless (defined $sock); + return $sock; +} + +sub _do_smtp { + my ($this, $input) = @_; + my ($local_state) = $this->{local_state}; + my ($sock) = $this->{sock}; + my $line; + + if (defined($input)) { + $line = $input; + } else { + $line = $sock->pop_queue(); + } + return 1 unless defined($line); # queue is empty + my ($reply) = substr($line, 0, 4); + if ($local_state eq 'FIRST') { + # first reply: server info. + if ($reply eq '220 ') { + # message end + $this->{local_state} = 'EHLO'; + $sock->send_reserve('EHLO ' . $this->{smtp_fqdn}); + } else { + # error + $this->_reply_smtp_error(undef, $local_state, $line); # all stack + $this->_close_smtp(); + $this->clean(); + } + } elsif ($local_state eq 'EHLO') { + if ($reply eq '250-') { + push(@{$this->{esmtp_capable}}, substr($line, 4)); + } elsif ($reply eq '250 ') { + # end of esmtp capable + push(@{$this->{esmtp_capable}}, substr($line, 4)); + if (length($this->{smtp_user})) { + $this->{local_state} = 'AUTH_START'; + return $this->_do_smtp('RECURSIVE'); + } else { + # ここでHELOと処理を一本化するためにSTART_MAILとしてrecursive. + $this->{local_state} = 'START_MAIL'; + return $this->_do_smtp('RECURSIVE'); + } + } else { + # error. use HELO instead of EHLO + $this->{local_state} = 'HELO'; + $sock->send_reserve('HELO ' . $this->{smtp_fqdn}); + } + } elsif ($local_state eq 'HELO') { + if ($reply eq '250 ') { + # ここでEHLOと処理を一本化するためにSTART_MAILとしてrecursive. + $this->{local_state} = 'START_MAIL'; + return $this->_do_smtp('RECURSIVE'); + } else { + # error + $this->_reply_smtp_error(undef, $local_state, $line); # all stack + $this->_close_smtp(); + $this->clean(); + } + } elsif ($local_state eq 'AUTH_START_LOGIN') { + local $@; + eval { require MIME::Base64; }; + if ($@) { + $this->{local_state} = 'AUTH_FAILED'; + return $this->_do_smtp('RECURSIVE'); + } else { + $this->{local_state} = 'AUTH_LOGIN_USER'; + $sock->send_reserve( + 'AUTH LOGIN ' . + MIME::Base64::encode($this->{smtp_user}, '')); + } + } elsif ($local_state eq 'AUTH_LOGIN_USER') { + if ($reply eq '334 ') { + $this->{local_state} = 'AUTH_CHECK'; + $sock->send_reserve(MIME::Base64::encode($this->{smtp_pass}, + '')); + } else { + $this->{local_state} = 'AUTH_FAILED'; + return $this->_do_smtp('RECURSIVE'); + } + } elsif ($local_state eq 'AUTH_START_PLAIN') { + local $@; + eval { require MIME::Base64; }; + if ($@) { + $this->{local_state} = 'AUTH_FAILED'; + return $this->_do_smtp('RECURSIVE'); + } else { + $this->{local_state} = 'AUTH_CHECK'; + $sock->send_reserve( + 'AUTH PLAIN ' . MIME::Base64::encode( + join('', + "\0", $this->{smtp_user}, + "\0", $this->{smtp_pass}), + '')); + } + } elsif ($local_state eq 'AUTH_CHECK') { + if (($reply eq '235 ') || ($reply eq '503 ')) { + # success or alreay authed. + $this->{local_state} = 'START_MAIL'; + return $this->_do_smtp('RECURSIVE'); + } else { + my $mech = $this->{smtp_mech_trying}; + RunLoop->shared->notify_warn("smtp auth $mech failed with some reason: $line"); + $this->{local_state} = 'AUTH_FAILED'; + return $this->_do_smtp('RECURSIVE'); + } + } elsif ($local_state =~ /^AUTH_/) { + # fallback + if ($local_state eq 'AUTH_START') { + my ($type, @meths); + foreach my $capa (@{$this->{esmtp_capable}}) { + ($type, @meths) = split(/ /, $capa); + last if $type eq 'AUTH'; + } + $this->{smtp_meths} = [@meths]; + $this->{smtp_meths_trail} = [@meths]; + } + my $new_mech = pop(@{$this->{smtp_meths_trail}}); + if (defined $new_mech) { + $this->{local_state} = 'AUTH_START_' . $new_mech; + $this->{smtp_mech_trying} = $new_mech; + return $this->_do_smtp('RECURSIVE'); + } else { + # auth failed. + RunLoop->shared->notify_warn( + 'mesmail: smtp auth failed: '. + join(', ', @{$this->{smtp_meths}}).'.'); + RunLoop->shared->notify_warn('mesmail: but try to send mail.'); + $this->{local_state} = 'START_MAIL'; + return $this->_do_smtp('RECURSIVE'); + } + } elsif ($local_state eq 'START_MAIL') { + # initialize mail + + $this->{queue}->[0]->{rcpt_ok_addrs} = 0; + $this->{queue}->[0]->{to_seps} = [@{$this->{queue}->[0]->{env_to}}]; # duplicate + + $this->{local_state} = 'MAILFROM'; + $sock->send_reserve('MAIL FROM:<' . $this->{queue}->[0]->{env_from} . '>'); + } elsif ($local_state eq 'MAILFROM') { + if ($reply eq '250 ') { + # initialize rcpt + my ($newaddr) = shift(@{$this->{queue}->[0]->{to_seps}}); + $this->{local_state} = 'RCPTTO'; + $sock->send_reserve('RCPT TO:<' . $newaddr . '>'); + } else { + #error + $this->_reply_smtp_error(0, $local_state, $line); + return $this->_smtp_send_final(); # smtp mail send が終了したものとみなす。 + } + } elsif ($local_state eq 'RCPTTO') { + my ($newaddr); + if ($reply eq '551 ') { + # more simple + $line =~ /\<([^\<\>]*)\>/; + $newaddr = $1; + } elsif ($reply =~ /25[01] /) { + $this->{queue}->[0]->{rcpt_ok_addrs}++; + $newaddr = shift(@{$this->{queue}->[0]->{to_seps}}); + } else { + # error + $line =~ /\<([^\<\>]*)\>/; # use mail_address entry for error msg. + $this->_reply_smtp_error(0, $local_state, $line, $1); + # 無視して次へ。 + $newaddr = shift(@{$this->{queue}->[0]->{to_seps}}); + } + if (defined($newaddr)) { + $sock->send_reserve('RCPT TO:<' . $newaddr . '>'); + } else { + if ($this->{queue}->[0]->{rcpt_ok_addrs}) { + # ok. + $this->{local_state} = 'DATA'; + $sock->send_reserve('DATA'); + } else { + # no rcpt addrs. + # error は既にメッセージを返している。 + $this->_reply_smtp_error(0, 'NORCPTTO'); + return $this->_smtp_send_final(); # smtp mail send が終了したものとみなす。 + } + } + } elsif ($local_state eq 'DATA') { + if ($reply eq '354 ') { + # go ahead + my ($struct) = $this->{queue}->[0]; + + $sock->send_reserve('To: ' . $struct->{to}); + foreach my $send_line + (&mime_unstructured_header_array( + "Subject: " . Tiarra::Encoding->new($struct->{subject})->euc)) { + $sock->send_reserve($send_line); + } + $sock->send_reserve('MIME-Version: 1.0'); + $sock->send_reserve('Content-Type: text/plain; charset=iso-2022-jp'); + $sock->send_reserve('Content-Transfer-Encoding: 7bit'); + $sock->send_reserve('Message-Id: ' . do { + # message-id := '<' time(epoc) rand-value '.' pid '.' envelope-from '>' + # time := epoc time (now) + # rand-value := [0-9]{,6} + # pid := [1-9][0-9]* + # envelope-from := email-addr + # example: Message-Id: <1046695839413024.2151.topia@clovery.jp> + '<' . time().int(rand()*1000000).".$$.".$struct->{env_from}.'>'; + }); + $sock->send_reserve('Date: ' . do { + # example: Tue, 04 Mar 2003 11:10:24 +0900 + Tools::DateConvert::expand('%a, %d %b %Y %H:%M:%S %z', + locale => "C"); + }); + $sock->send_reserve('From: ' . $struct->{from}) if defined($struct->{from}); + $sock->send_reserve(''); + + my ($socksend) = sub { + foreach my $send_line (@_) { + $send_line =~ s/[\x0d\x0a]+//; + $send_line = '..=' if $send_line eq '.'; + $sock->send_reserve(Tiarra::Encoding->new($send_line)->h2zKana->jis); + } + $sock->flush(); + }; + + if ($struct->{data_type} == $DATA_TYPE_ARRAY) { + $socksend->(@$struct->{data}); + } elsif ($struct->{data_type} == $DATA_TYPE_INNER_ITER) { + $struct->{data}->($struct, $socksend); + } + + $sock->send_reserve('.'); + $this->{local_state} = 'FINISH'; + } else { + $this->_reply_smtp_error(0, $local_state, $line); + } + } elsif ($local_state eq 'FINISH') { + if ($reply eq '250 ') { + # finalize + $this->_reply_smtp_ok(0); + return $this->_smtp_send_final(); + } else { + # error + $this->_reply_smtp_error(0, $local_state, $line); + return $this->_smtp_send_final(); + } + } else { + die 'unknown LOCAL_STATE "' . $local_state . '".'; + } + + return 1; +} + +sub _smtp_send_final { + my ($this) = @_; + + shift(@{$this->{queue}}); + if (@{$this->{queue}}) { + # more queue. + if (scalar(@{$this->{queue}}) != 1 && (grep {$_->{priority} != 0} @{$this->{queue}})) { + # have key having priority. and queue isn't single. + @{$this->{queue}} = sort { $a->{priority} <=> $b->{priority}} @{$this->{queue}}; + } + # START_MAILにしてrecursive. + $this->{local_state} = 'START_MAIL'; + return $this->_do_smtp('RECURSIVE'); + } else { + # close smtp + $this->_close_smtp(); + $this->{hook}->uninstall; + $this->{hook} = undef; + } +} + +sub _close_smtp { + my ($this) = @_; + my ($sock) = $this->{sock}; + + $sock->send_reserve('QUIT'); + $sock->disconnect_after_writing(); + $sock->flush(); # flush + $this->{sock} = undef; + $this->{local_state} = undef; + $this->{state} = undef; + $this->{esmtp_capable} = []; + + return undef; +} + +sub _reply_smtp_error { + my ($this, $session, $state, $line, $info) = @_; + # 使用者にerrorを返すメソッド。$infoには送信失敗のmail addressが含まれるはずだが、 + # channelに向かってmail addressを広報することになるので使用しないことを勧める。 + # なお、from/toにはprivate指定されたものは含まれない。 + + # stateには失敗したときの状態が渡され、'error-mail' や 'fatalerror-connect' のように + # 状態別詳細メッセージを定義することが出来る。 + + # fatalerror は1送信者につき1つだけ返される(はず)。 + + if (defined($session)) { + my $struct = $this->{queue}->[$session]; + $struct->{reply_error}->($struct, $state, $line, $info); + } else { + my (@sended_from); + foreach my $struct (@{$this->{queue}}) { + next if grep{$_ == $struct->{sender};} @sended_from; + push(@sended_from, $struct->{sender}); + + $struct->{reply_fatal}->($struct, $state, $line, $info); + } + } +} + +sub _reply_smtp_ok { + my ($this, $session) = @_; + # 使用者にacceptを返すメソッド。 + # from/toにはprivate指定されたものは含まれない。 + + my $struct = $this->{queue}->[$session]; + + $struct->{reply_ok}->($struct); +} + +sub mime_unstructured_header_array { + return split(/\n/, mime_unstructured_header(@_)); +} + +# contrib +no strict; # i don't want fix these functions. + +# $str を encoded-word に変換し $line に追加する + +$ascii = '[\x00-\x7F]'; +$twoBytes = '[\x8E\xA1-\xFE][\xA1-\xFE]'; +$threeBytes = '\x8F[\xA1-\xFE][\xA1-\xFE]'; + +sub add_encoded_word { + my($str, $line) = @_; + my $result = ''; + + while (length($str)) { + my $target = $str; + $str = ''; + if (length($line) + 22 + + ($target =~ /^(?:$twoBytes|$threeBytes)/o) * 8 > 76) { + $line =~ s/[ \t\n\r]*$/\n/; + $result .= $line; + $line = ' '; + } + while (1) { + my $encoded = '=?ISO-2022-JP?B?' . + Tiarra::Encoding->new($target, 'euc')->h2zKana->conv('jis', 'base64') . '?='; + if (length($encoded) + length($line) > 76) { + $target =~ s/($threeBytes|$twoBytes|$ascii)$//o; + $str = $1 . $str; + } else { + $line .= $encoded; + last; + } + } + } + $result . $line; +} + +# unstructured header $header を MIMEエンコードする +# add_encoded_word() については上のスクリプトを参照 + +sub mime_unstructured_header { + my $oldheader = shift; + my($header, @words, @wordstmp, $i) = (''); + my $crlf = $oldheader =~ /\n$/; + $oldheader =~ s/\s+$//; + @wordstmp = split /\s+/, $oldheader; + for ($i = 0; $i < $#wordstmp; $i++) { + if ($wordstmp[$i] !~ /^[\x21-\x7E]+$/ and + $wordstmp[$i + 1] !~ /^[\x21-\x7E]+$/) { + $wordstmp[$i + 1] = "$wordstmp[$i] $wordstmp[$i + 1]"; + } else { + push(@words, $wordstmp[$i]); + } + } + push(@words, $wordstmp[-1]); + foreach $word (@words) { + if ($word =~ /^[\x21-\x7E]+$/) { + $header =~ /(?:.*\n)*(.*)/; + if (length($1) + length($word) > 76) { + $header .= "\n $word"; + } else { + $header .= $word; + } + } else { + $header = add_encoded_word($word, $header); + } + $header =~ /(?:.*\n)*(.*)/; + if (length($1) == 76) { + $header .= "\n "; + } else { + $header .= ' '; + } + } + $header =~ s/\n? $//mg; + $crlf ? "$header\n" : $header; +} + +1; diff -urN /non-existant-dir/module/Tools/MailSend.pm tiarra-20080510/module/Tools/MailSend.pm --- /non-existant-dir/module/Tools/MailSend.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/Tools/MailSend.pm 2008-05-11 00:25:25.000000000 +0900 @@ -0,0 +1,151 @@ +# -*- cperl -*- +# ----------------------------------------------------------------------------- +# $Id: MailSend.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +# copyright (C) 2003 Topia . all rights reserved. + +# メール送信ラッパ。複数のサーバに非同期で送信する。 +# 実体は Tools::MailSend::EachServer に記述してあり、これはコントロールクラスである。 + +package Tools::MailSend; +use strict; +use warnings; +use Tiarra::SharedMixin; +use Module::Use qw(Tools::MailSend::EachServer); +use Tools::MailSend::EachServer; +our $_shared_instance; + +sub _new { + my ($class) = @_; + my $this = + { + # servers + servers => [], + # structure: + # server + + }; + bless $this, $class; + + return $this; +} + +sub mail_send { + # メール送信を行う。 + # 既存のサーバを探し(なければ作る)、それに丸投げします。 + + my ($this, %arg) = @_; + my ($server) = $this->_get_server(%arg); + + return $server->mail_send_reserve(%arg); +} + +sub _get_server { + my ($this, %args) = @_; + + return $this->{servers}->[$this->_get_server_index(%args)]; +} + +sub _get_server_index { + my ($this, %arg) = @_; + my (%data); + + # default value and convert struct + $data{'use_pop3'} = $arg{'use_pop3'} || 0; + $data{'pop3_host'} = $arg{'pop3_host'} || 'localhost'; + $data{'pop3_port'} = $arg{'pop3_port'} || getservbyname('pop3', 'tcp') || 110; + $data{'pop3_user'} = $arg{'pop3_user'} || eval { (getpwuid($>))[0]} || ''; + $data{'pop3_pass'} = $arg{'pop3_pass'} || ''; + $data{'pop3_expire'} = $arg{'pop3_expire'} || 0; + $data{'smtp_host'} = $arg{'smtp_host'} || 'localhost'; + $data{'smtp_port'} = $arg{'smtp_port'} || getservbyname('smtp', 'tcp') || 25; + $data{'smtp_fqdn'} = $arg{'smtp_fqdn'} || 'localhost'; + $data{'smtp_user'} = $arg{'smtp_user'} || ''; + $data{'smtp_pass'} = $arg{'smtp_pass'} || ''; + $data{'local'} = + { + parent => $this, + }; + $data{'cleaner'} = \&_server_cleaner; + + # find. + my $i; + server: + for ($i = scalar(@{$this->{servers}}) - 1 ; $i >= 0 ; --$i) { + my $server = $this->{servers}->[$i]; + foreach my $key (keys %data) { + if ($key ne 'local') { + next server unless $data{$key} eq $server->get_data($key); + } else { + next server unless $data{$key}->{parent} eq $server->get_data($key)->{parent}; + } + } + # match. + return $i; + } + + # make. + my $idx = scalar(@{$this->{servers}}); # new entry! + $data{'local'}->{parent_index} = $idx; + my $server = Tools::MailSend::EachServer->new(%data); + push(@{$this->{servers}}, $server); + return $idx; +} + +sub _server_cleaner { + my ($server) = @_; + + my $this = $server->get_data('local')->{parent}; + my $idx = $server->get_data('local')->{parent_index}; + + splice(@{$this->{servers}}, $idx, 1); # remove server + return 0; +} + +sub _do_nothing { + # noop func +} + +#--- class method --- +sub DATA_TYPES { + return Tools::MailSend::EachServer::DATA_TYPES(); +} + +sub parse_mailaddrs { + my $sub = sub { + my ($temp) = @_; + $temp =~ s/,/\\,/; + $temp; + }; + + my (@addrs) = @_; + @addrs = map { + my ($temp) = $_; + $temp =~ s/\\,/,/g; + $temp; + } map { + split /\s*(?($1)/eg; + $temp; + } @addrs; + + if (wantarray) { + return map { + if ($_ =~ />$/) { + /<([^<]+)>$/; + $1; + } elsif ($_ =~ /"$/) { + ''; + } else { + $_; + } + } @addrs; + } else { + return [@addrs]; + } +} + +1; diff -urN /non-existant-dir/module/User/Away/Client.pm tiarra-20080510/module/User/Away/Client.pm --- /non-existant-dir/module/User/Away/Client.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/User/Away/Client.pm 2008-05-11 00:25:26.000000000 +0900 @@ -0,0 +1,54 @@ +# ----------------------------------------------------------------------------- +# $Id: Client.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +package User::Away::Client; +use strict; +use warnings; +use base qw(Module); +use RunLoop; + +sub client_attached { + my ($this,$client) = @_; + # クライアントが接続されたという事は、 + # 少なくとも一つ以上のクライアントが存在するに決まっている。 + RunLoop->shared->broadcast_to_servers( + $this->construct_irc_message( + Command => 'AWAY')); +} + +sub client_detached { + my ($this,$client) = @_; + # クライアントの数が1(このメソッドから戻った後に0になる)ならAWAYを実行。 + if (@{RunLoop->shared->clients} == 1 && + defined $this->config->away) { + + RunLoop->shared->broadcast_to_servers( + $this->construct_irc_message( + Command => 'AWAY', + Param => $this->config->away)); + } +} + +sub connected_to_server { + my ($this,$server,$new_connection) = @_; + # クライアントの数が0ならAWAYを実行。 + if (@{RunLoop->shared->clients} == 0 && + defined $this->config->away) { + + $server->send_message( + $this->construct_irc_message( + Command => 'AWAY', + Param => $this->config->away)); + } +} + +1; + +=pod +info: クライアントが一つも接続されていない時にAWAYを設定します。 +default: off +section: important + +# どのようなAWAYメッセージを設定するか。省略された場合はAWAYを設定しません。 +-away: 居ない。 +=cut diff -urN /non-existant-dir/module/User/Away/Nick.pm tiarra-20080510/module/User/Away/Nick.pm --- /non-existant-dir/module/User/Away/Nick.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/User/Away/Nick.pm 2008-05-11 00:25:26.000000000 +0900 @@ -0,0 +1,87 @@ +# ----------------------------------------------------------------------------- +# $Id: Nick.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +package User::Away::Nick; +use strict; +use warnings; +use base qw(Module); +use Mask; +use Multicast; + +sub message_arrived { + my ($this,$msg,$sender) = @_; + + # クライアントから受け取ったNICKにのみ反応する。 + if ($sender->isa('IrcIO::Client') && + $msg->command eq 'NICK') { + + my $set_away; + foreach ($this->config->away('all')) { + my ($mask,$away_str) = m/^(.+?)\s+(.+)$/; + if (Mask::match($mask,$msg->param(0))) { + $this->set_away($msg,$away_str); + $set_away = 1; + last; + } + } + if (!$set_away) { + $this->unset_away($msg); + } + } + $msg; +} + +sub set_away { + my ($this,$msg,$away_str) = @_; + $this->away($msg, + $this->construct_irc_message( + Command => 'AWAY', + Param => $away_str)); +} + +sub unset_away { + my ($this,$msg) = @_; + $this->away($msg, + $this->construct_irc_message( + Command => 'AWAY')); +} + +sub away { + my ($this,$msg,$away_msg) = @_; + # NICK hoge@ircnetのようにネットワーク名が明示されていた場合は、 + # 全てのサーバーに対してAWAYを発行する。 + # そうでなければ明示されたネットワークにのみAWAYを発行する。 + + my (undef,$network_name,$specified) = Multicast::detach($msg->param(0)); + if ($specified) { + # 明示された + my $network = RunLoop->shared->network($network_name); + if (defined $network) { + $network->send_message($away_msg); + } + } + else { + # 明示されなかった + RunLoop->shared->broadcast_to_servers($away_msg); + } +} + +1; + +=pod +info: ニックネーム変更に応じて AWAY を設定します。 +default: off +section: important + +# ニックネームを変更したときに、そのニックネームに対応するAWAYが +# 設定されていれば、そのAWAYを設定します。そうでなければAWAYを取り消します。 + +# 書式: <設定するAWAYメッセージ> +# +# nickをhoge_zzzに変更すると、「寝ている」というAWAYを設定する。 +# hoge_workまたはhoge_zzzに変更した場合は、「仕事中」というAWAYを設定する。 +# それ以外のnickに変更した場合はAWAYを取り消す。 +# 後者は正規表現を利用して「away: re:hoge_(work|zzz) 仕事中」としても良い。 +-away: hoge_zzz 寝ている +-away: hoge_work,hoge_zzz 仕事中 +=cut diff -urN /non-existant-dir/module/User/Filter.pm tiarra-20080510/module/User/Filter.pm --- /non-existant-dir/module/User/Filter.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/User/Filter.pm 2008-05-11 00:25:26.000000000 +0900 @@ -0,0 +1,40 @@ +# ----------------------------------------------------------------------------- +# $Id: Filter.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +package User::Filter; +use strict; +use warnings; +use base qw(Module); +use Mask; + +sub message_arrived { + my ($this,$msg,$sender) = @_; + + if ($sender->isa('IrcIO::Server') && + ($msg->command eq 'PRIVMSG' || $msg->command eq 'NOTICE')) { + # マッチするパターンを探す + foreach ($this->config->pattern('all')) { + my ($user,$replace) = m/^(.+?)\s+(.+)$/; + if (Mask::match($user,$msg->prefix)) { + # 一致した。 + $replace =~ s/#\(message\)/$msg->param(1)/eg; + $msg->param(1,$replace); + last; + } + } + } + + $msg; +} + +1; + +=pod +info: 指定された人物からのPRIVMSGやNOTICEを書き換える。 +default: off + +# 人物のマスクと、置換パターンを定義。 +# 置換パターン中の#(message)は、発言内容に置換されます。 +# 人物が複数のマスクに一致する場合は、最初に一致したものが使われます。 +pattern: *!*@* #(message) +=cut diff -urN /non-existant-dir/module/User/Ignore.pm tiarra-20080510/module/User/Ignore.pm --- /non-existant-dir/module/User/Ignore.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/User/Ignore.pm 2008-05-11 00:25:26.000000000 +0900 @@ -0,0 +1,42 @@ +# ----------------------------------------------------------------------------- +# $Id: Ignore.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +package User::Ignore; +use strict; +use warnings; +use base qw(Module); +use Mask; + +sub message_arrived { + my ($this,$msg,$sender) = @_; + + # 鯖からクライアントへ向かうメッセージか？ + if ($sender->isa('IrcIO::Server')) { + # 対象となるコマンドか？ + if (Mask::match( + $this->config->command, + $msg->command)) { + # 全てのmaskをカンマで繋げてマッチングを行なう。 + if (Mask::match( + join(',',$this->config->mask('all')), + $msg->prefix || '')) { + # 最終的にマッチしたので、このメッセージは捨てる。 + return undef; + } + } + } + return $msg; +} + +1; +=pod +info: 指定された人間からのPRIVMSGやNOTICEを破棄してクライアントへ送らないようにするモジュール。 +default: off + +# 対象となるコマンドのマスク。省略時には"privmsg,notice"が設定されている。 +# ただしprivmsgとnotice以外を破棄してしまうと、(Tiarraは平気でも)クライアントが混乱する。 +command: privmsg,notice + +# maskは複数定義可能。定義された順番でマッチングが行なわれます。 +mask: example!*@*.example.net +=cut diff -urN /non-existant-dir/module/User/Kick.pm tiarra-20080510/module/User/Kick.pm --- /non-existant-dir/module/User/Kick.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/User/Kick.pm 2008-05-11 00:25:26.000000000 +0900 @@ -0,0 +1,96 @@ +# ----------------------------------------------------------------------------- +# $Id: Kick.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +package User::Kick; +use strict; +use warnings; +use base qw(Module); +use Mask; +use Multicast; +use Timer; + +sub new { + my $class = shift; + my $this = $class->SUPER::new(@_); + $this->{queue} = {}; # network name => [IRCmessage,...] + $this->{timer} = undef; # queueが空でない時だけ必要になるTimer + $this; +} + +sub destruct { + my ($this) = @_; + if (defined $this->{timer}) { + $this->{timer}->uninstall; + $this->{timer} = undef; + } +} + +sub message_arrived { + my ($this, $msg, $sender) = @_; + + if ($sender->server_p && $msg->command eq 'JOIN' && defined $msg->nick) { + foreach (split m/,/,$msg->param(0)) { + my ($ch_full,$mode) = (m/^(.+?)(?:\x07(.*))?$/); + my $ch_short = Multicast::detatch($ch_full); + my $ch = $sender->channel($ch_short); + my $myself = $ch->names($sender->current_nick); + if ($myself->has_o && + Mask::match_deep_chan([$this->config->mask('all')],$msg->prefix,$ch_full)) { + # kickキューに入れる。 + $this->enqueue( + $sender->network_name, $this->construct_irc_message( + Command => 'KICK', + Params => [$ch_short, + $msg->nick, + $this->config->message || 'User::Kick'])); + } + } + } + + $msg; +} + +sub enqueue { + my ($this, $network_name, $command) = @_; + + my $queue = $this->{queue}->{$network_name}; + if (!defined $queue) { + $queue = $this->{queue}->{$network_name} = []; + } + push @$queue, $command; + $this->prepare_timer; +} + +sub prepare_timer { + my $this = shift; + # キュー消化タイマーが存在しなければ作る。 + if (!defined $this->{timer}) { + $this->{timer} = Timer->new( + Interval => 0, # 後で變へる + Repeat => 1, + Code => sub { + my $timer = shift; + $timer->interval(1); + + # 鯖毎に1つづつ消化する。 + my $queue_has_elem; + while (my ($network_name, $queue) = each %{$this->{queue}}) { + my $server = RunLoop->shared->network($network_name); + my $msg = shift @$queue; + $server->send_message($msg) if defined $server; + + if (@$queue > 0) { + $queue_has_elem = 1; + } + } + + # 全てのキューが空になつたら終了。 + if (!$queue_has_elem) { + $timer->uninstall; + $this->{timer} = undef; + } + })->install; + } +} + +1; diff -urN /non-existant-dir/module/User/Nick/Detached.pm tiarra-20080510/module/User/Nick/Detached.pm --- /non-existant-dir/module/User/Nick/Detached.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/User/Nick/Detached.pm 2008-05-11 00:25:26.000000000 +0900 @@ -0,0 +1,59 @@ +# ----------------------------------------------------------------------------- +# $Id: Detached.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +# このモジュールはRunLoopのcurrent_nick、すなわちローカルnickを変更しない。 +# ----------------------------------------------------------------------------- +package User::Nick::Detached; +use strict; +use warnings; +use base qw(Module); +use RunLoop; + +sub client_attached { + my ($this,$client) = @_; + # クライアントが接続されたという事は、 + # 少なくとも一つ以上のクライアントが存在するに決まっている。 + RunLoop->shared->broadcast_to_servers( + $this->construct_irc_message( + Command => 'NICK', + Param => RunLoop->shared->current_nick)); +} + +sub client_detached { + my ($this,$client) = @_; + # クライアントの数が1(このメソッドから戻った後に0になる)ならNICKを実行。 + if (@{RunLoop->shared->clients} == 1 && + defined $this->config->detached) { + + RunLoop->shared->broadcast_to_servers( + $this->construct_irc_message( + Command => 'NICK', + Param => $this->config->detached)); + } +} + +sub connected_to_server { + my ($this,$server,$new_connection) = @_; + # クライアントの数が0ならNICKを実行。 + if (@{RunLoop->shared->clients} == 0 && + defined $this->config->detached) { + + $server->send_message( + $this->construct_irc_message( + Command => 'NICK', + Param => $this->config->detached)); + } +} + +1; + +=pod +info: クライアントが接続されていない時に、特定のnickに変更します。 +default: off +section: important + +# クライアントが接続されていない時のnick。 +# このnickが既に使われていたら、適当に変更が加えられて使用されます。 +# クライアントが再び接続されると、切断前のローカルnickに戻ります。 +detached: PHO_d +=cut diff -urN /non-existant-dir/module/User/ServerOper.pm tiarra-20080510/module/User/ServerOper.pm --- /non-existant-dir/module/User/ServerOper.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/User/ServerOper.pm 2008-05-11 00:25:26.000000000 +0900 @@ -0,0 +1,45 @@ +# ----------------------------------------------------------------------------- +# $Id: ServerOper.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +package User::ServerOper; +use strict; +use warnings; +use base qw(Module); + +sub new { + my $class = shift; + my $this = $class->SUPER::new(@_); + $this->{table} = do { + # ネットワーク名 => [オペレータ名,オペレータパスワード] + my %hash = map { + my ($network,$id,$pass) = m/^(.+?)\s+(.+?)\s+(.+)$/; + $network => [$id,$pass]; + } $this->config->oper('all'); + \%hash; + }; + $this; +} + +sub connected_to_server { + my ($this,$server,$new_connection) = @_; + my $oper = $this->{table}->{$server->network_name}; + if (defined $oper) { + $server->send_message( + $this->construct_irc_message( + Command => 'OPER', + Params => [$oper->[0],$oper->[1]])); + } +} + +1; + +=pod +info: 特定のネットワークに接続した時、OPERコマンドを発行します。 +default: off + +# 書式: <ネットワーク名> <オペレータ名> <オペレータパスワード> +# +# ネットワーク"local"に接続した時、オペレータ名oper、 +# オペレータパスワードoper-passでOPERコマンドを発行する例。 +-oper: local oper oper-pass +=cut diff -urN /non-existant-dir/module/User/Vanish.pm tiarra-20080510/module/User/Vanish.pm --- /non-existant-dir/module/User/Vanish.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/module/User/Vanish.pm 2008-05-11 00:25:26.000000000 +0900 @@ -0,0 +1,334 @@ +# ----------------------------------------------------------------------------- +# $Id: Vanish.pm 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +package User::Vanish; +use strict; +use warnings; +use base qw(Module); +use Mask; +use Multicast; +our $DEBUG = 0; + +sub message_arrived { + my ($this,$msg,$sender) = @_; + + my $result = $msg; + if ($sender->server_p) { + my $method = 'cmd_'.$msg->command; + if ($this->can($method)) { + if ($DEBUG) { + my $original = $msg->serialize; + $result = $this->$method($msg, $sender); + my $filtered = (defined $result ? $result->serialize : ''); + if ($original ne $filtered) { + # 内容が書換へられた。 + my $debug_msg = "'$original' -> '$filtered'"; + eval { + substr($debug_msg, 400) = '...'; + }; + RunLoop->shared->notify_msg($debug_msg); + } + } + else { + $result = $this->$method($msg, $sender); + } + } + } + elsif ($sender->client_p) { + if ($msg->command eq 'VANISHDEBUG') { + $DEBUG = $msg->param(0); + RunLoop->shared->notify_msg("User::Vanish - debug-mode ".($DEBUG?'enabled':'disabled')); + $result = undef; + } + } + + $result; +} + +*cmd_NOTICE = \&cmd_PRIVMSG; +sub cmd_PRIVMSG { + my ($this,$msg,$sender) = @_; + + # 発行元がVanish対象か？ + my $ch_long = $msg->param(0); + my $ch_short = Multicast::detach($ch_long); + if (Multicast::nick_p($ch_short)) { + $ch_long = '#___priv___@'.$sender->network_name; + } + + if ($this->target_of_vanish_p($msg->prefix,$ch_long)) { + undef; + } + else { + $msg; + } +} + +sub cmd_JOIN { + my ($this,$msg,$sender) = @_; + my @channels; # チャンネルリストを再構成する。 + foreach my $channel (split m/,/,$msg->param(0)) { + my ($ch_full,$mode) = ($channel =~ m/^([^\x07]+)(?:\x07(.*))?/); + if (!$this->target_of_vanish_p($msg->prefix,$ch_full)) { + push @channels,$channel; + } + } + + if (@channels > 0) { + # 再構成の結果、チャンネルがまだ残ってた。 + $msg->param(0,join(',',@channels)); + } + else { + $msg = undef; + } + + $msg; +} + +sub cmd_NJOIN { + my ($this,$msg,$sender) = @_; + my $ch_long = $msg->param(0); + my $ch_short = Multicast::detach($ch_long); + my $ch = $sender->channel($ch_short); + if (defined $ch) { + my @nicks; + foreach my $mode_and_nick (split m/,/,$msg->param(1)) { + my ($mode,$nick) = ($mode_and_nick =~ m/^([@+]*)(.+)$/); + my $person = $ch->names($nick); + if (!defined $person || !$this->target_of_vanish_p) { + push @nicks,$mode_and_nick; + } + } + + if (@nicks > 0) { + # 再構成の結果、nickがまだ残ってた。 + $msg->param(1,join(',',@nicks)); + } + else { + $msg = undef; + } + } + + $msg; +} + +sub cmd_PART { + my ($this,$msg,$sender) = @_; + if ($this->target_of_vanish_p($msg->prefix,$msg->param(0))) { + undef; + } + else { + $msg; + } +} + +sub cmd_INVITE { + my ($this,$msg,$sender) = @_; + if ($this->target_of_vanish_p($msg->prefix,$msg->param(1))) { + undef; + } + else { + $msg; + } +} + +*cmd_QUIT = \&cmd_NICK; +sub cmd_NICK { + my ($this,$msg,$sender) = @_; + + # 影響を及ぼした全チャンネル名のリストを得る。このリストにはネットワーク名が付いていない。 + my $affected = $msg->remark('affected-channels'); + # 一つでもVanish対象でないチャンネルとnickの組みがあれば、このNICKは破棄しない。 + my $no_vanish; + foreach (@$affected) { + my $ch_long = Multicast::attach($_,$sender->network_name); + if (!$this->target_of_vanish_p($msg->prefix,$ch_long)) { + $no_vanish = 1; + last; + } + } + + if ($no_vanish) { + $msg; + } + else { + undef; + } +} + +sub cmd_TOPIC { + my ($this,$msg,$sender) = @_; + if ($this->target_of_vanish_p($msg->prefix,$msg->param(0))) { + if ($this->config->drop_topic_by_target) { + $msg->prefix('HIDDEN!HIDDEN@HIDDEN.BY.USER.VANISH'); + } + } + $msg; +} + +sub cmd_353 { + # RPL_NAMREPLY + my ($this,$msg,$sender) = @_; + + my $ch_long = $msg->param(2); + my $ch_short = Multicast::detach($ch_long); + my $ch = $sender->channel($ch_short); + if (defined $ch) { + my @nicks; + foreach my $mode_and_nick (split / /,$msg->param(3)) { + my ($mode,$nick) = ($mode_and_nick =~ m/^([@\+]{0,2})(.+)$/); + my $person = $ch->names($nick); + if (!defined $person || !$this->target_of_vanish_p($person->info,$ch_long)) { + push @nicks,$mode_and_nick; + } + } + $msg->param(3,join(' ',@nicks)); + } + + $msg; +} + +sub cmd_MODE { + my ($this,$msg,$sender) = @_; + + # 発行元がVanish対象か？ + if ($this->target_of_vanish_p($msg->prefix,$msg->param(0))) { + if ($this->config->drop_mode_by_target) { + # prefix改竄 + $msg->prefix('HIDDEN!HIDDEN@HIDDEN.BY.USER.VANISH'); + } + } + + # +o/-o/+v/-vの対象がVanishの対象か？ + my $ch_long = $msg->param(0); + my $ch_short = Multicast::detach($ch_long); + my $ch = $sender->channel($ch_short); + if (defined $ch && (sub{defined$_[0]?$_[0]:1}->($this->config->drop_mode_switch_for_target))) { + my $n_params = @{$msg->params}; + my $plus = 0; # 現在評価中のモードが+なのか-なのか。 + my $mode_char_pos = 1; # 現在評価中のmode characterの位置。 + my $mode_param_offset = 0; # $mode_char_posから幾つの追加パラメタを拾ったか。 + + my $fetch_param = sub { + $mode_param_offset++; + return $msg->param($mode_char_pos + $mode_param_offset); + }; + + my @params = ($ch_long); # パラメータを再構築する。 + my $add = sub { + my ($char,$option) = @_; + push @params,($plus ? '+' : '-').$char; + if (defined $option) { + push @params,$option; + } + }; + + for (;$mode_char_pos < $n_params;$mode_char_pos += $mode_param_offset + 1) { + $mode_param_offset = 0; # これは毎回リセットする。 + foreach my $c (split //,$msg->param($mode_char_pos)) { + if ($c eq '+') { + $plus = 1; + } + elsif ($c eq '-') { + $plus = 0; + } + elsif (index('bIk',$c) != -1) { + $add->($c,$fetch_param->()); + } + elsif (index('Oov',$c) != -1) { + my $target = $fetch_param->(); + my $person = $ch->names($target); + if (!defined $person || !$this->target_of_vanish_p($person->info,$ch_long)) { + $add->($c,$target); + } + } + elsif ($c eq 'l') { + if ($plus) { + $add->($c,$fetch_param->()); # 追加パラメタを捨てる + } + else { + $add->($c); + } + } + else { + $add->($c); + } + } + } + + # パラメタ再構成の結果、一つも無くなったら、このメッセージは破棄。 + if (@params > 1) { + $msg = $this->construct_irc_message( + Prefix => $msg->prefix, + Command => $msg->command, + Params => \@params); + } + else { + $msg = undef; + } + } + $msg; +} + +sub cmd_KICK { + my ($this,$msg,$sender) = @_; + + if ($this->target_of_vanish_p($msg->prefix,$msg->param(0))) { + if ($this->config->drop_kick_by_target) { + $msg->prefix('HIDDEN!HIDDEN@HIDDEN.BY.USER.VANISH'); + } + } + + my $kicked_nick = $msg->param(1); + my $ch = $sender->channel(Multicast::detach($msg->param(0))); + if (defined $ch) { + if ($this->config->drop_kick_for_target) { + $msg = undef; + } + } + + $msg; +} + +sub target_of_vanish_p { + # $userinfo: nick!name@host形式のユーザー情報 + # $ch_long : ネットワーク名付きのチャンネル名 + # 戻り値: 真偽値 + my ($this,$userinfo,$ch_long) = @_; + Mask::match_deep_chan([$this->config->mask('all')],$userinfo,$ch_long); +} + +1; + +=pod +info: 指定された人物の存在を、様々なメッセージから消去する。 +default: off + +# 対象となった人物の発行したJOIN、PART、INVITE、QUIT、NICKは消去され、NAMESの返すネームリストからも消える。 +# また、対象となった人物のNJOINも消去される。 + +# Vanish対象が発行したMODEを消去するかどうか。デフォルトで0。 +# 消去するとは云え、本当にMODEそのものを消してしまうのではなく、 +# そのユーザーの代わりに"HIDDEN!HIDDEN@HIDDEN.BY.USER.VANISH"がMODEを実行した事にする。 +drop-mode-by-target: 1 + +# Vanish対象を対象とするMODE +o/-o/+v/-vを消去するかどうか。デフォルトで1。 +drop-mode-switch-for-target: 1 + +# Vanish対象が発行したKICKを消去するかどうか。デフォルトで0。 +# 本当に消すのではなく、"HIDDEN!HIDDEN@HIDDEN.BY.USER.VANISH"がKICKを実行した事にする。 +drop-kick-by-target: 1 + +# Vanish対象を対象とするKICKを消去するかどうか。デフォルトで0。 +drop-kick-for-target: 0 + +# Vanish対象が発行したTOPICを消去するかどうか。デフォルトで0。 +# 本当に消すのでは無いが、他の設定と同じ。 +drop-topic-by-target: 1 + +# チャンネルとVanish対象の定義。 +# 特定のチャンネルでのみ対象とする、といった事が可能。 +# また、privの場合は「#___priv___@ネットワーク名」という文字列をチャンネル名の代わりとしてマッチングを行なう。 +# 書式: mask: <チャンネルのマスク> <ユーザーのマスク> +mask: #example@example example!exapmle@example.com +=cut diff -urN /non-existant-dir/run tiarra-20080510/run --- /non-existant-dir/run 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/run 2008-05-11 00:25:24.000000000 +0900 @@ -0,0 +1,29 @@ +#!/bin/sh +# $Id: run 3010 2007-12-10 13:36:55Z topia $ +# copyright (C) 2004 Topia . all rights reserved. + +THISDIR="${THISDIR-$(dirname $0)}" +[ "0${DEBUG}" -ge 1 ] && echo "${THISDIR}/run: start" + +# override +WORKDIR="${WORKDIR:-${THISDIR}}" +if [ -z "${TOPDIR}" ]; then + TOPDIR=. +else + TOPDIR="${TOPDIR}/.." +fi +TOPDIR="${TOPDIR#./}" + +[ "0${DEBUG}" -ge 2 ] && echo "${THISDIR}/run: read tiarrarc" +[ -f "${THISDIR}/.tiarrarc" ] && . "${THISDIR}/.tiarrarc" +if [ -f "${THISDIR}/.tiarrarc-once" ]; then + . "${THISDIR}/.tiarrarc-once" + rm -f "${THISDIR}/.tiarrarc-once" +fi + +if [ -f "${THISDIR}/run-main" ]; then + . "${THISDIR}/run-main" +else + THISDIR="${THISDIR}/.." + . "${THISDIR}/run" +fi diff -urN /non-existant-dir/run-main tiarra-20080510/run-main --- /non-existant-dir/run-main 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/run-main 2008-05-11 00:25:24.000000000 +0900 @@ -0,0 +1,58 @@ +#!/bin/sh +# $Id: run-main 3010 2007-12-10 13:36:55Z topia $ +# copyright (C) 2004 Topia . all rights reserved. + +if [ -z "${THISDIR}" ]; then + echo "$0 couldn't use directly. please use ./run." 1>&2 + exit 2; +fi +[ "0${DEBUG}" -ge 1 ] && echo "${THISDIR}/run-main: start" + +PERL=${PERL:-/usr/bin/perl} +PERLARG=${PERLARG:--w} +TIARRA=${TIARRA:-${TOPDIR}/tiarra} +CONF=${CONF:-tiarra.conf} +REDIR_STDOUT=${REDIR_STDOUT:->errlog.stdout} +REDIR_STDERR=${REDIR_STDERR:->errlog.stderr} +REDIR_STDIN=${REDIR_STDIN:-&-} +DAEMON_MODE=${DAEMON_MODE:-yes} + +eval "${LAZY_EXECUTE}" + +cmd_line='${PERL} ${PERLARG}' +cmd_line="${cmd_line} "'${TIARRA}' +cmd_line="${cmd_line} "'--config="${CONF}"' +cmd_line="${cmd_line} ${TIARRAARG}" +cmd_line="${cmd_line} "'"$@"' +[ "X${REDIR_STDOUT}" = "X-" ] || cmd_line="${cmd_line} >${REDIR_STDOUT}" +[ "X${REDIR_STDERR}" = "X-" ] || cmd_line="${cmd_line} 2>${REDIR_STDERR}" +[ "X${REDIR_STDIN}" = "X-" ] || cmd_line="${cmd_line} <${REDIR_STDIN}" + +if [ "X${DAEMON_MODE}" = "Xyes" ]; then + cmd_line="${cmd_line} &" +else + cmd_line="exec ${cmd_line}" +fi + + +if [ \! -z "${DEBUG}" ]; then + echo " configuration" + echo "workdir : ${WORKDIR}" + echo "perl : ${PERL}" + echo "perl arg : ${PERLARG}" + echo "tiarra : ${TIARRA}" + echo "config : ${CONF}" + echo "tiarra arg: ${TIARRAARG}" + echo "extra : $@" + echo "stdout : ${REDIR_STDOUT}" + echo "stderr : ${REDIR_STDERR}" + echo "stdin : ${REDIR_STDIN}" + echo "daemon : ${DAEMON_MODE}" + echo "lazy exec : " + echo "${LAZY_EXECUTE}" | while read line ; do echo " $line" ; done + echo "cmdline :" + echo " ${cmd_line}" +else + cd "${WORKDIR}" + eval "${cmd_line}" +fi diff -urN /non-existant-dir/sample.conf tiarra-20080510/sample.conf --- /non-existant-dir/sample.conf 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/sample.conf 2008-05-11 00:25:26.000000000 +0900 @@ -0,0 +1,821 @@ +# -*- tiarra-conf -*- +# ----------------------------------------------------------------------------- +# $Id: sample.conf.in 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +# tiarra.conf サンプル +# +# tiarraは起動時に全ての設定をこのファイルから取得します。 +# このファイルの文字コードは任意ですが、改行コードはLFもしくはCRLFでなければなりません。 +# +# 半角の#で始まる行はコメントとして無視されます。 +# 行の途中に#を置いた場合はコメントにはなりません。 +# +# 設定行は「設定名 : 値」の形式で指定されます。 +# 行の先頭及び末尾、コロンの前後の空白は無視されます。 +# +# 特に指定が無い場合、同じ設定を二度以上繰り返した時は最初に定義された設定が有効になります。 +# +# ブロックごと省略した場合は、そのブロックの全ての値が省略されたものとみなします。 +# ただし省略不可能な設定もありますので御注意下さい。 +# +# 「@include foo.conf」という行があると、foo.confがその場所に +# 挿入されたかのように処理します。 +# +# {}記号の位置には、それなりの自由度があります。 +# 次の例は全て有効です。 +# block { +# foo: bar +# } +# +# block {} +# +# block +# {} +# +# 次の例は全て無効です。 +# block {foo: bar} +# +# block +# {foo: bar} +# +# block { +# foo: bar} +# +# block +# {foo: bar +# } +# ----------------------------------------------------------------------------- + +# ----------------------------------------------------------------------------- +# generalブロック +# +# tiarra.conf自身の文字コードやユーザー情報などを指定するブロックです。 +# ----------------------------------------------------------------------------- +general { + # tiarra.conf自身の文字コード + # コード名はjis,sjis,euc,utf8,utf16,utf32等。(この値はUnicode::Japaneseにそのまま渡されます) + # autoが指定された、または省略された場合は自動判別します。 + conf-encoding: utf8 + + # ユーザー情報 + # 省略不能です。 + nick: tiarra + user: tiarra + name: Tiarra the "Aeon" + + # どのようなユーザーモードでログインするか。+iwや+iのように指定する。 + # 省略された場合はユーザーモードを特に設定しない。 + #user-mode: +i + + # Tiarraへの接続を許可するホスト名を表わすマスク。 + # 制限をしないのであれば"*"を指定するか省略する。 + client-allowed: * + + # Tiarraが開くポート。ここに指定したポートへクライアントに接続させる。 + # 省略されたらポートを開かない。 + tiarra-port: 6667 + + # Tiarraがポートtiarra-portを開く際、IPv6とIPv4のどちらでリスニングを行なうか。 + # 'v4'または'v6'で指定します。デフォルトは'v4'です。 + # IPv6を使うためにはSocket6.pmが利用可能である必要があります。 + #tiarra-ip-version: v4 + + # Tiarraがポートtiarra-portを開く際のローカルアドレス。 + # 意味が分からなければ省略して下さい。 + # デフォルトは、IPv4のはINADDR_ANY、IPv6のはin6addr_anyになります。 + #tiarra-ipv4-bind-addr: 0.0.0.0 + #tiarra-ipv6-bind-addr: ::0 + + # Tiarraにクライアントが接続する際に要求するパスワードをcryptした文字列。 + # 空の文字列が指定されたり省略された場合はパスワードを要求しない。 + # crypt は ./tiarra --make-password で行えます。 + tiarra-password: xl7cflIcH9AwE + + # 外部プログラムからtiarraをコントロールする為のUNIXドメインソケットの名前。 + # 例えば"foo"を指定した場合、ソケット/tmp/tiarra-control/fooが作られる。 + # 省略された場合はこの機能を無効とする。 + # また、非UNIX環境ではそもそもUNIXドメインソケットが利用可能でないため、 + # そのような場合にもこの機能は無効となる。 + #control-socket-name: test + + # IRCサーバーから送られる文字のコードと、IRCサーバーへ送る文字のコード + # どちらも省略された場合はjis。 + server-in-encoding: jis + server-out-encoding: jis + + # クライアントから受け取る文字のコードと、クライアントへ伝える文字のコード + # どちらも省略された場合はjis。 + client-in-encoding: jis + client-out-encoding: jis + + # Tiarraは標準出力に様々なメッセージを出力するが、その文字コードを指定する。省略時にはeucとなる。 + # ただしtiarra.confのパースが完了するまでは文字コードの変換は行なわれない(つまりこの設定が有効にならない)ことに注意して下さい。 + stdout-encoding: utf8 + + # Tiarraはエラーメッセージを標準出力に出力するが、その時に接続しているクライアントがあればクライアントにもNOTICEで送る事が出来る。 + # この値を1にすると、その機能が有効になる。省略するか0を指定するとこの機能は無効になる。 + notice-error-messages: 1 + + # Tiarraでチャンネルとユーザーのマスクを指定するときの形式。 + # plum形式とTiarra形式が選択できます。 + #----------------- + # plum形式: (channelには+や-は使えない。channelは省略すると*とみなす。) + # + syntax: user[ channel[ channel[ ...]]] + # + # mask: +*!*@*.example.com #{example}@ircnet +{example3}@ircnet + # mask: -*!*@*.example.com #{example2}@2ch,+{example4}@2ch + # mask: -*!*@* + #----------------- + # Tiarra形式: (channelにも+や-を使える。) + # + syntax: channel user + # + # mask: #{example}@ircnet,-#{example2}@2ch +*!*@*.example.com + # mask: ++{example3}@ircnet,-+{example4}@2ch +*!*@*.example.com # +で始まるチャンネル。 + # mask: * -*!*@* + #----------------- + # となります。 この二つはまったく同じマスクを表しています。 + + # この値をplumにすると、plum形式、省略するかtiarraを指定すると、Tiarra形式になります。 + chanmask-mode: tiarra + + # サーバーに接続する際、ローカル側のどのアドレスにバインドするか。 + # 意味が分からなければ省略して下さい。 + # デフォルトは、IPv4のはINADDR_ANY、IPv6のはin6addr_anyになります。 + #ipv4-bind-addr: 0.0.0.0 + #ipv6-bind-addr: ::0 + + # tiarra が、 001 や 002 や、 recent log を送信するときなどに使う prefix + # を指定します。 hostname や fqdn っぽいものを指定すると良いかもしれません。 + # デフォルトは tiarra です。普通変える必要はありません。 + #sysmsg-prefix: tiarra + + sysmsg-prefix-use-masks { + # sysmsg-prefix を使用する場所を指定する。 + + # システムメッセージ(NumericReply など)。デフォルトは * です。 + # ふつうこれを変更する必要はありません。 + system: * + + # 個人宛メッセージ(Notice,Privmsg の中で)。デフォルトはなし。 + #priv: + + # チャンネル宛メッセージ(Notice,Privmsg の中で)。デフォルトは * です。 + # Ziciz などのクライアントを接続する場合は、 + # -*::log を指定しておくといいかもしれません。 + channel: * + } + + # Tiarra が nick 変更時の衝突等を処理するモードを指定します。 + # 0: Tiarra が接続時と同様に自動処理します。 + # 1: クライアントにそのまま投げます。 + # 複数のクライアントが nick 重複を処理する場合は非常に危険です。 + # (設定不足の IRC クライアントが複数つながっている場合も含みます) + # 2: 対応するエラーメッセージ付きの NOTICE に変換して、 + # クライアントに投げます。 + # multi-server-mode 時のデフォルトは 0 、 single-server-mode 時のデフォルトは 1 です。 + #nick-fix-mode: 0 + + messages { + # Tiarra が使用する、いくつかのメッセージを指定する。 + + quit { + # ネットワーク設定が変更され、再接続する場合の切断メッセージ + netconf-changed-reconnect: Server Configuration changed; reconnect + + # ネットワーク設定が変更され、切断する場合の切断メッセージ + netconf-changed-disconnect: Server Configuration changed; disconnect + } + } +} + +# ----------------------------------------------------------------------------- +# networksブロック +# +# Tiarraから接続するIRCネットワークの名称です。 +# 一つも定義しなかった場合やこのブロックを省略した場合は、 +# "main"というネットワークが一つだけ指定されたものと見做します。 +# ----------------------------------------------------------------------------- +networks { + # 複数のサーバーへの接続を可能にするかどうか。1(オン)と0(オフ)で指定。 + # これを1にすると、次のnameを複数個定義する事が可能になり、 + # 複数のサーバーに同時に接続出来るようになります。 + # その一方、これを1にしている時は、チャンネル名にネットワーク名が付加される等、 + # IRCの大部分のメッセージがTiarraによる改変を受けます。 + # これを0にしている間は、次のnameを複数個定義する事は出来なくなります。 + # マルチサーバーモードの設定を起動中に変えると、クライアントから見たチャンネル名が + # 変更になる為、全クライアントが一時的に全てのチャンネルからpartしたように見え、 + # その直後にjoinし直したように見えます。 + # デフォルトでは1です。 + multi-server-mode: 1 + + # 接続するIRCネットワークに名前を付けます。この名前は後で使用します。 + # 複数のネットワークに接続したい場合は多重定義して下さい。 + name: ircnet + name: 2ch + + # 通常Tiarraではチャンネル名を「#Tiarra@ircnet」のように表現します。 + # これはネットワークircnet内の#Tiarraというチャンネルを表わします。 + # @以降は省略可能ですが、省略された場合のデフォルトのネットワーク名をここで指定します。 + # 省略した場合は最も始めに定義されたnameがデフォルトになります。 + # (そしてnameが一つも無かった場合はmainがデフォルトになります) + #default: ircnet + + # 上に述べた通り、デフォルトではTiarraはチャンネル名とネットワーク名を@で区切ります。 + # この区切り文字は任意の文字に変更する事が出来ます。省略された場合は@になります。 + # + # System::PrivTranslator モジュールを利用している場合、 prefix の nick 部分にも + # 利用されます。そのため、 ! や @ を含む文字列を利用するとクライアントが誤作動する + # 場合がありますので注意してください。 + channel-network-separator: @ + + # 接続先のサーバーから切断された時に、joinしていたそのサーバーのチャンネルをどうするか。 + # 1. "part-and-join"の場合は、切断されるとクライアントにはチャンネルからpartしたように見せ掛け、 + # 再接続に成功すると再びjoinしたように見せ掛ける。最も負荷が高い。(これはplumに似た動作である) + # 2. "one-message"の場合は、切断されるとクライアントに宛ててTiarraがNOTICEでその旨を報告する。 + # 再接続に成功すると再びNOTICEで報告する。JOINやPARTはしないので、 + # クライアントからはまだそのチャンネルに残っているかのように見える。 + # 3. "message-for-each"の場合は、切断されるとクライアントに宛ててTiarraが + # 到達不能になった全てのチャンネルにNOTICEでその旨を報告する。 + # 再接続に成功すると再びNOTICEで報告する。JOINやPARTはしない。 + # デフォルトはpart-and-joinです。 + action-when-disconnected: message-for-each + + # NICKを変更する度に、変更したサーバーでの新しいNICKをNOTICEで常に通知するかどうか。 + # 1なら必ず通知し、0なら変更後のnickがローカルnick(クライアントが見る事の出来るnick)と違っている場合のみ通知する。 + # デフォルトは0です。 + always-notify-new-nick: 0 + + fixed-channels { + # Tiarra がクライアント接続時にチャンネル情報を送る順番を指定する。 + # マッチしなかったチャンネルについては最後にまとめて + # (順番がごちゃごちゃになって)送られてきます。 + channel: #てすとちゃんねる@ircnet + channel: #てすと@localserver + channel: *@localserver + channel: *@localserver:*.jp + } +} + +# ----------------------------------------------------------------------------- +# 各ネットワークの設定 +# +# networksブロックで定義した全てのネットワークについて、 +# そのアドレス、ポート、(必要なら)パスワードを定義します。 +# ----------------------------------------------------------------------------- +ircnet { + # サーバーのホストとポート。省略不可。 + host: irc.nara.wide.ad.jp + port: 6663 + + # general/userで設定したユーザ名を使わずに、各ネットワークで独自のユーザ名を使用する事も可能。 + # 省略されたら当然、general/userで設定したものが使われる。 + #user: hoge + + # general/nameで設定した本名(建前上)を使わずに、各ネットワークで独自の本名を使用可能。 + #name: hoge + + # このサーバーの要求するパスワード。省略可能。 + #password: hoge + + # general/setver-in/out-encodingで設定したエンコーディングを使わずに、 + # 各ネットワークで独自のエンコーディングを使用する事も可能。 + # 省略されたら当然、generalで設定したものが使われる。 + #in-encoding: jis + #out-encoding: jis + + # general/(ipv4|ipv6)bind-addrで設定したローカルアドレスを使わずに、 + # 各ネットワークで独自のbind_addrを使用する事も可能。 + # 省略されたらgeneralで設定したものが使われる。 + #ipv4-bind-addr: 0.0.0.0 + #ipv6-bind-addr: ::0 +} + +2ch { + host: irc.2ch.net + port: 6667 +} + +# ----------------------------------------------------------------------------- +# 必須の設定は以上です。以下はモジュール(プラグイン)の設定です。 +# ----------------------------------------------------------------------------- + +# +または-で始まる行はモジュール設定行と見做されます。 +# +で記述されたモジュールが使用され、-で記述されたモジュールは使用されません。 +# +や-の後の空白は幾つあっても無視されます。 + +# メッセージが各モジュールを通過する順番は、このconfファイルで記述された +# 順番の通りになります。ログを取るモジュールなどはconfでも後の方に +# 記述した方が良いということになります。 + +# モジュール名はperlのそれと同じようにディレクトリ区切り文字を「::」としたパスで表現されます。 +# 例えばモジュールChannel::Auto::Operの実体はファイルmodule/Channel/Auto/Oper.pm +# でなければならず、そのpackage宣言もChannel::Auto::Operでなければなりません。 +# Tiarraモジュールの名称は、perl標準モジュール群やmain/下の.pmファイルと重複しないように +# 気を付けて下さい。Tiarraはモジュールが本当にModuleのサブクラスかどうかをチェックするので +# 例えばIO::Socket::INETといったモジュールを置いても誤動作はしませんが、 +# そのようなモジュールはロード時にエラーを出して使用中止になります。 + +# 一つのモジュールを複数回定義して、何度も同じモジュールをメッセージが通過するようには出来ません。 + +# 幾つかのモジュールはパラメータとしてチャンネル名を必要とします。 +# ここで指定するチャンネル名は、ネットワーク名も含めた文字列でなければなりません。 +# 「#チャンネル」では駄目で「#チャンネル@ネットワーク」などとする必要があります。 + +# マスクの書式: +# ['+' / '-'] ( <マスク文字列> / "re:" 正規表現 ) +# これはカンマで幾つでも継ぐ事が出来ます。"\,"でカンマそのものを表します。 +# 先頭が+なら、それに続く部分にマッチするものが選ばれ、-なら除外されます。省略されたら+と見做されます。 +# マスク文字列とは"*"で0文字以上の任意の文字列を、"?"で1文字の任意の文字列を表す文字列です。 +# 例: +# tiarra* これはtiarraで始まる文字列を表す。 +# +*!*tiarra@*.jp,-re:\d これは*!*tiarra@*.jpにマッチして、かつ文字列中に数字を含まないものを表す。 + +# このファイルには重要と思われるいくつかのモジュールしかありません。 +# そのほかのモジュールについては、 all.conf から設定をコピーしてきてください。 + +- Auto::Oper { + # 特定の文字列を発言した人を+oする。 + + # Auto::Aliasを有効にしていれば、エイリアス置換を行ないます。 + + # +oを要求する文字列(マスク)を指定します。 + request: なると寄越せ + + # チャンネルオペレータ権限を要求した人と要求されたチャンネルが + # ここで指定したマスクに一致しなかった場合は + # denyで指定した文字列を発言し、+oをやめます。 + # 省略された場合は誰にも+oしません。 + # 書式は「チャンネル 発言者」です。 + # マッチングのアルゴリズムは次の通りです。 + # 1. チャンネル名にマッチするmask定義を全て集める + # 2. 集まった定義の発言者マスクを、定義された順にカンマで結合する + # 3. そのようにして生成されたマスクで発言者のマッチングを行ない、結果を+o可能性とする。 + # 例1: + # mask: *@2ch* *!*@* + # mask: #*@ircnet* *!*@*.hoge.jp + # この例ではネットワーク 2ch の全てのチャンネルで誰にでも +o し、 + # ネットワーク ircnet の # で始まる全てのチャンネルでホスト名 *.hoge.jp の人に+oします。 + # #*@ircnetだと「#hoge@ircnet:*.jp」などにマッチしなくなります。 + # 例2: + # mask: #hoge@ircnet -*!*@*,+*!*@*.hoge.jp + # mask: * +*!*@* + # 基本的に全てのチャンネルで誰にでも +o するが、例外的に#hoge@ircnetでは + # ホスト名 *.hoge.jp の人にしか +o しない。 + # この順序を上下逆にすると、全てのチャンネルで全ての人を +o する事になります。 + # 何故なら最初の* +*!*@*が全ての人にマッチするからです。 + mask: * *!*@* + + # +oを要求した人を実際に+oする時、ここで指定した発言をしてから+oします。 + # #(name|nick)のようなエイリアス置換を行います。 + # エイリアス以外でも、#(nick.now)を相手のnickに、#(channel)を + # そのチャンネル名にそれぞれ置換します。 + message: 了解 + + # +oを要求されたが+oすべき相手ではなかった場合の発言。 + # 省略されたら何も喋りません。 + deny: 断わる + + # +oを要求されたが相手は既にチャンネルオペレータ権限を持っていた場合の発言。 + # 省略されたらdenyに設定されたものを使います。 + oper: 既に@を持っている + + # +oを要求されたが自分はチャンネルオペレータ権限を持っていなかった場合の発言。 + # 省略されたらdenyに設定されたものを使います。 + not-oper: @が無い + + # チャンネルに対してでなく自分に対して+oの要求を行なった場合の発言。 + # 省略されたらdenyに設定されたものを使います。 + private: チャンネルで要求せよ + + # チャンネルの外から+oを要求された場合の発言。+nチャンネルでは起こりません。 + # 省略されたらdenyに設定されたものを使います。 + out: チャンネルに入っていない +} + +- CTCP::ClientInfo { + # CTCP CLIENTINFOに応答する。 + + # CTCP::Versionのintervalと同じ。 + interval: 3 +} + +- CTCP::DCC::RewriteAddress { + # クライアントが送信した CTCP DCC のアドレスを変換する。 + + # CTCP DCC に指定されているアドレスを、 tiarra で取得したものに + # 書き換えます。(EXPERIMENTAL) + # + # IPv4 のみサポートしています。 + # + # このモジュールは一旦 CTCP DCC メッセージを破棄するので、 + # 別のクライアントには送信されません。 + + # 変換する DCC タイプ。 [デフォルト値: CHAT SEND] + type: CHAT SEND + + # 変換用アドレスの取得方法を選択する。デフォルト値はありません。 + # 以下の取得方法(server-socket client-socket dns http)から + # 必要なもの(複数可)を指定してください。 + resolver: client-socket server-socket dns http + + + # 取得方法と設定 + # なにも設定がないときはブロック自体を省略することもできます。 + + server-socket { + # サーバソケットのローカルアドレスを取ります。 + # client <-> tiarra[this address] <-> server + } + + client-socket { + # クライアントソケットのリモートアドレスを取ります。 + # client [this address]<-> tiarra <-> server + } + + dns { + # DNS を引いて決定します。IPアドレスの指定も可能です。 + host: example.com + } + + http { + # 現状では単純な GET しかサポートしていません。 + + # アクセス先 URL + url: http://checkip.dyndns.org/ + + # IP アドレス取得用 regex + regex: Current IP Address: (\d+\.\d+\.\d+\.\d+) + } + + # リゾルバの選び方 + # + # * tiarra を動作させているサーバとインターネットの間にルータ等があり、 + # グローバルアドレスがない場合 + # *-socket は役に立ちません。 http を利用してください。 + # 適当な DDNS を持っていればdns も良いでしょう。 + # + # * tiarra がレンタルサーバなどLAN上にないサーバで動作している場合 + # server-socket, http は役に立ちません。 + # client-socket がお勧めです。 + # + # * tiarra がLAN上にあり、グローバルアドレスのついているホストで + # 動作している場合 + # client-socket は役に立ちません。 + # server-socket がお勧めです。 +} + +- CTCP::Ping { + # CTCP PINGに応答する。 + + # CTCP::Versionのintervalと同じ。 + interval: 3 +} + +- CTCP::Time { + # CTCP TIMEに応答する。 + + # CTCP::Versionのintervalと同じ。 + interval: 3 +} + +- CTCP::UserInfo { + # CTCP USERINFOに応答する。 + + # CTCP::Versionのintervalと同じ。 + interval: 3 + + # USERINFOとして返すメッセージ。 + message: テスト +} + ++ CTCP::Version { + # CTCP VERSIONに応答する。 + + # 連続したCTCPリクエストに対する応答の間隔。単位は秒。 + # 例えば3秒に設定した場合、一度応答してから3秒間は + # CTCPに一切応答しなくなる。デフォルトは3。 + # + # なお、CTCP受信時刻の記録は、全てのCTCPモジュールで共有される。 + # 例えばCTCP VERSIONを送った直後にCTCP CLIENTINFOを送ったとしても、 + # CTCP::ClientInfoのintervalで設定された時間を過ぎていなければ + # 後者は応答しない。 + interval: 3 +} + +- Channel::Join::Connect { + # サーバーに初めて接続した時、指定したチャンネルに入るモジュール。 + + # 書式: <チャンネル1>[,<チャンネル2>,...] [<チャンネル1のキー>,...] + # コンマの直後のスペースは無視されます。 + # + # 例: + # 「#aaaaa@ircnet」に「aaaaa」というキーで入る。 + #channel: #aaaaa@ircnet aaaaa + # + # 「#aaaaa@ircnet」、「#bbbbb@ircnet:*.jp」、「#ccccc@ircnet」、「#ddddd@ircnet」の4つのチャンネルに入る。 + #channel: #aaaaa@ircnet,#bbbbb@ircnet:*.jp, #ccccc@ircnet + #channel: #ddddd@ircnet +} + +- Channel::Join::Invite { + # 招待されたらそのチャンネルに入る。 + + # 許可するユーザ/チャンネルのマスク。 + mask: * *!*@* + # plum: *!*@* + + # 招待されたチャンネルに流すメッセージのフォーマット。 + #message: こんばんわ〜。 +} + +- Channel::Join::Kicked { + # 特定のチャンネルからkickされた時に、自動で入りなおす。 + + # 対象となるチャンネル名のマスク + channel: * +} + +- Channel::Mode::Get { + # チャンネルにJOINした時、そのチャンネルのモードを取得します。 + + # Channel::Mode::Set等が正しく動くためには + # チャンネルのモードをTiarraが把握しておく必要があります。 + # 自動的にモードを取得するクライアントであれば必要ありませんが、 + # そうでなければこのモジュールを使うべきです。 + + # 設定項目は無し。 +} + +- Channel::Mode::Oper::Grant { + # 特定のチャンネルに特定の人間がjoinした時に、自分がチャンネルオペレータ権限を持っていれば+oする。 + + # splitからの復帰などで+o対象の人が一度に大量に入って来ても+oは少しずつ実行します。 + # Excess Floodにはならない筈ですが、本格的な防衛BOTに使える程の物ではありません。 + + # 対象の人間がjoinしてから実際に+oするまで何秒待つか。 + # 省略されたら待ちません。 + # 5-10 のように指定されると、その値の中でランダムに待ちます。 + wait: 2-5 + + # チャンネルと人間のマスクを定義。Auto::Operと同様。 + #mask: * example!~example@*.example.ne.jp +} + +- Channel::Mode::Set { + # チャンネルを作成した時に自動的にモードを設定するモジュール。 + + # 書式は<チャンネル名にマッチするマスク> <設定するモード>[,<設定するモード>,...]です。 + # #IRC談話室@ircnetなら+t+nを、それ以外なら+nを設定する例。 + #channel: #IRC談話室@ircnet +t + #channel: * +n + # LimeChat 標準設定を模倣する設定例。 + #channel: * +sn +} + +- Channel::Rejoin { + # チャンネルオペレータ権限を無くしたとき、一人ならjoinし直す。 + + # +チャンネルや+aされているチャンネル以外でチャンネルオペレータ権限を持たずに + # 一人きりになった時、そのチャンネルの@を復活させるために自動的にjoinし直すモジュール。 + # トピック、モード、banリスト等のあらゆるチャンネル属性をも保存します。 + + # +b,+I,+eリストの復旧を行なうかどうか。 + # あまりに長いリストを取得するとMax Send-Q Exceedで落とされるかも知れません。 + save-lists: 1 +} + +- Client::Cache { + # データをキャッシュしてサーバに問い合わせないようにする + + # キャッシュを使用しても、使われるのは接続後最初の一度だけです。 + # 二度目からは通常通りにサーバに問い合わせます。 + # また、クライアントオプションの no-cache を指定すれば動きません。 + + # mode キャッシュを使用するか + use-mode-cache: 1 + + # who キャッシュを使用するか + use-who-cache: 1 +} + ++ Client::Conservative { + # サーバが送信するような IRC メッセージを作成するようにする + + # サーバが実際に送信しているようなメッセージにあわせるようにします。 + # 多くのクライアントの設計ミスを回避でき(ると思われ)ます。 +} + +- Client::Cotton { + # Cotton の行うおかしな動作のいくつかを無視する + + # 該当クライアントのオプション client-type に cotton や unknown と指定するか、 + # Client::GetVersion を利用してクライアントのバージョンを取得するように + # してください。 + + # part shield (rejoin 時に自動で行われる part の無視)を使用するか + use-part-shield: 1 +} + ++ Client::GetVersion { + # クライアントに CTCP Version を発行してバージョン情報を得る + + # オプションはいまのところありません。 + # (開発者向け情報: 取得した情報は remark の client-version に設定され、 + # Client::Guess から使用されます。) +} + +- Log::Channel { + # チャンネルやprivのログを取るモジュール。 + + # Log系のモジュールでは、以下のように日付や時刻の置換が行なわれる。 + # %% : % + # %Y : 年(4桁) + # %m : 月(2桁) + # %d : 日(2桁) + # %H : 時間(2桁) + # %M : 分(2桁) + # %S : 秒(2桁) + + # ログを保存するディレクトリ。Tiarraが起動した位置からの相対パス。~指定は使えない。 + directory: log + + # ログファイルの文字コード。省略されたらjis。 + charset: utf8 + + # 各行のヘッダのフォーマット。省略されたら'%H:%M'。 + header: %H:%M:%S + + # ファイル名のフォーマット。省略されたら'%Y.%m.%d.txt' + filename: %Y.%m.%d.txt + + # ログファイルのモード(8進数)。省略されたら600 + mode: 600 + + # ログディレクトリのモード(8進数)。省略されたら700 + dir-mode: 700 + + # ログを取るコマンドを表すマスク。省略されたら記録出来るだけのコマンドを記録する。 + command: privmsg,join,part,kick,invite,mode,nick,quit,kill,topic,notice + + # PRIVMSGとNOTICEを記録する際に、自分の発言と他人の発言でフォーマットを変えるかどうか。1/0。デフォルトで1。 + distinguish-myself: 1 + + # 各ログファイルを開きっぱなしにするかどうか。 + # このオプションは多くの場合、ディスクアクセスを抑えて効率良くログを保存しますが + # ログを記録すべき全てのファイルを開いたままにするので、50や100のチャンネルを + # 別々のファイルにログを取るような場合には使うべきではありません。 + # 万一 fd があふれた場合、クライアントから(またはサーバへ)接続できない・ + # 新たなモジュールをロードできない・ログが全然できないなどの症状が起こる可能性が + # あります。limit の詳細については OS 等のドキュメントを参照してください。 + #keep-file-open: 1 + + # keep-file-open 時に各行ごとに flush するかどうか。 + # open/close の負荷は気になるが、ログは失いたくない人向け。 + # keep-file-open が有効でないなら無視され(1になり)ます。 + #always-flush: 0 + + # keep-file-openを有効にした場合、発言の度にログファイルに追記するのではなく + # 一定の分量が溜まってから書き込まれる。そのため、ファイルを開いても + # 最近の発言はまだ書き込まれていない可能性がある。 + # syncを設定すると、即座にログをディスクに書き込むためのコマンドが追加される。 + # 省略された場合はコマンドを追加しない。 + sync: sync + + # 各チャンネルの設定。チャンネル名の部分はマスクである。 + # 個人宛てに送られたPRIVMSGやNOTICEはチャンネル名"priv"として検索される。 + # 記述された順序で検索されるので、全てのチャンネルにマッチする"*"などは最後に書かなければならない。 + # 指定されたディレクトリが存在しなかったら、Log::Channelはそれを勝手に作る。 + # フォーマットは次の通り。 + # channel: <ディレクトリ名> (<チャンネル名> / 'priv') + # 例: + # filename: %Y.%m.%d.txt + # channel: IRCDanwasitu #IRC談話室@ircnet + # channel: others * + # この例では、#IRC談話室@ircnetのログはIRCDanwasitu/%Y.%m.%d.txtに、 + # それ以外(privも含む)のログはothers/%Y.%m.%d.txtに保存される。 + channel: priv priv + channel: others * +} + +- Log::Recent { + # クライアントを接続した時に、保存しておいた最近のメッセージを送る。 + + # クライアントオプションの no-recent-logs が指定されていれば送信しません。 + + # 各行のヘッダのフォーマット。省略されたら'%H:%M'。 + header: %H:%M:%S + + # ログをチャンネル毎に何行まで保存するか。省略されたら10。 + line: 15 + + # PRIVMSGとNOTICEを記録する際に、自分の発言と他人の発言でフォーマットを変えるかどうか。1/0。デフォルトで1。 + distinguish-myself: 1 + + # どのメッセージを保存するか。省略されたら保存可能な全てのメッセージを保存する。 + command: privmsg,notice,topic,join,part,quit,kill +} + ++ System::Error { + # サーバーからのERRORメッセージをNOTICEに埋め込む + + # これをoffにするとクライアントにERRORメッセージがそのまま送られます。 + # クライアントとの間ではERRORメッセージは主に切断警告に使われており、 + # そのまま流してしまうとクライアントが混乱する可能性があります。 + # 設定項目はありません。 + + # このモジュールを回避してERRORメッセージをクライアントに送りたい場合は、 + # remarkのsend-error-as-is-to-clientを指定してください。 +} + +- System::NotifyIcon::Win32 { + # タスクトレイにアイコンを表示する。 + + # タスクトレイにアイコンを表示します。 + # クリックすると表示非表示を切り替えることができ、右クリックすると + # Reload と Exit ができるコンテキストメニューを表示します。 + # 多少反応が鈍いかもしれませんがちょっと待てば出てくると思います。 + + # Win32::GUI を必要とします。 + # コンテキストメニューは表示している間処理をブロックしています。 + + # Win32 イベントループを処理する最大間隔を指定します。 + #interval: 2 + + # 通知領域に表示するアイコンを指定します。 + # Win32::GUI の制限でちゃんとしたアイコンファイルしか指定できません。 + iconfile: guiperl.ico + + # モジュールが読み込まれたときにコンソールウィンドウを隠すかどうかを + # 指定します。 + hide-console-on-load: 1 +} + ++ System::Pong { + # サーバーからのPINGメッセージに対し、自動的にPONGを返す。 + + # これをoffにするとクライアントが自らPINGに応答せざるを得なくなりますが、 + # クライアントからのPONGメッセージはデフォルトのサーバーへ送られるので + # デフォルト以外のサーバーからはPing Timeoutで落とされるなど + # 全く良い事がありません。 + # 設定項目はありません。 +} + ++ System::PrivTranslator { + # クライアントからの個人的なprivが相手に届かなくなる現象を回避する。 + + # このモジュールは個人宛てのprivmsgの送信者のnickにネットワーク名を付加します。 + # また、最後に声をかけられてから5分以内の nick 変更をクライアントに伝えます。 + # 設定項目はありませんが、 networks/channel-network-separator を ! や @ 以外に + # 変更することをおすすめします。 +} + ++ System::Reload { + # confファイルやモジュールの更新をリロードするコマンドを追加する。 + + # リロードを実行するコマンド名。省略されるとコマンドを追加しません。 + # 例えば"load"を設定すると、"/load"と発言しようとした時にリロードを実行します。 + # この時コマンドはTiarraが握り潰すので、IRCプロトコル上で定義された + # コマンド名を設定すべきではありません。 + command: load + + # command と同じですが、サーバにもブロードキャストします。 + #broadcast-command: load-all + + # confファイルをリロードしたときに通知します。 + # モジュールの設定が変更されていた場合は、ここでの設定にかかわらず、 + # モジュールごとに表示されます。1または省略された場合は通知します。 + conf-reloaded-notify: 1 +} + +- User::Away::Client { + # クライアントが一つも接続されていない時にAWAYを設定します。 + + # どのようなAWAYメッセージを設定するか。省略された場合はAWAYを設定しません。 + #away: 居ない。 +} + +- User::Away::Nick { + # ニックネーム変更に応じて AWAY を設定します。 + + # ニックネームを変更したときに、そのニックネームに対応するAWAYが + # 設定されていれば、そのAWAYを設定します。そうでなければAWAYを取り消します。 + + # 書式: <設定するAWAYメッセージ> + # + # nickをhoge_zzzに変更すると、「寝ている」というAWAYを設定する。 + # hoge_workまたはhoge_zzzに変更した場合は、「仕事中」というAWAYを設定する。 + # それ以外のnickに変更した場合はAWAYを取り消す。 + # 後者は正規表現を利用して「away: re:hoge_(work|zzz) 仕事中」としても良い。 + #away: hoge_zzz 寝ている + #away: hoge_work,hoge_zzz 仕事中 +} + +- User::Nick::Detached { + # クライアントが接続されていない時に、特定のnickに変更します。 + + # クライアントが接続されていない時のnick。 + # このnickが既に使われていたら、適当に変更が加えられて使用されます。 + # クライアントが再び接続されると、切断前のローカルnickに戻ります。 + detached: PHO_d +} + diff -urN /non-existant-dir/tiarra tiarra-20080510/tiarra --- /non-existant-dir/tiarra 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/tiarra 2008-05-11 00:25:24.000000000 +0900 @@ -0,0 +1,423 @@ +#!/usr/bin/perl +# ----------------------------------------------------------------------------- +# - T i a r r a - :::bootstrap::: +# Copyright (c) 2008 Tiarra Development Team. All rights reserved. +# This is free software; you can redistribute it and/or modify it +# under the same terms as Perl itself. +# ----------------------------------------------------------------------------- +# $Id: tiarra 11365 2008-05-10 14:58:28Z topia $ +# ----------------------------------------------------------------------------- +require 5.006; +use strict; +use warnings; +use File::Basename; +use File::Spec; +use Carp; + +sub follow_link { + my ($file, $max_count, $die_on_max) = @_; + + $max_count = 40 unless defined $max_count; + my ($count, @path) = 0, (); + push(@path, $file); + while (-l $file) { + $file = File::Spec->rel2abs(readlink($file), dirname($file)); + push(@path, $file); + if (++$count >= $max_count) { + if ($die_on_max) { + carp 'Too many levels of symbolic links'; + } else { + last; + } + } + } + return @path; +} + +BEGIN { + # untaint + $0 =~ /^(.+)$/; + my $self = $1; + my @add_inc; + + foreach my $path (map dirname($_), reverse follow_link($1)) { + unshift(@INC, + map{ File::Spec->catdir($path, $_); } qw(main module)); + unshift(@add_inc, File::Spec->catdir($path, 'bundle')); + } + push(@INC, @add_inc); +} + +# optional modules +use Tiarra::OptionalModules; +# 外部から呼べるオプションモジュールの存在チェック。 +# (過去互換) +sub ipv6_enabled { Tiarra::OptionalModules->ipv6; } + +use Tiarra::Resolver; # early initialization +use Tiarra::Encoding; +use Configuration; +use RunLoop; +use ModuleManager; +use ReloadTrigger; +use IO::Handle; +our $terminated = 0; + +# version はバージョン番号 +our $version = '0.1'; + +# based はベースにしている Tiarra のバージョン(パッケージまたは fork 時用) +our $based_version = ''; + +# short は短いバージョン番号。(CTCP-Version の返答に使われる) +our $short_version = ''; + + +# オリジナル(based_version が未定義)ならば svnversion をチェックする。 +&check_svnversion unless $based_version; +# short_version が未定義なら version の値を使う。 +$short_version ||= $version; + +&install_signal_handlers; + +sub check_svnversion { + use IO::File; + my $svnversion = '.svnversion'; + my $svnrevision; + + foreach my $file (follow_link($0)) { + my $dir = dirname($file); + my $path = File::Spec->catfile($dir, $svnversion); + my $fh = IO::File->new($path, 'r'); + if (defined $fh) { + $svnrevision = <$fh>; + chomp $svnrevision; + } elsif (-e File::Spec->catdir($dir, '.svn')) { + (my $svndir = $dir) =~ s/'/'\''/; + do { + # special cleanup for taint check + $ENV{PATH} =~ /^(.*)$/; + local $ENV{PATH} = $1; + $svndir =~ /^(.*)$/; + $svnrevision = (`svnversion --no-newline --committed $1` =~ /(\d+[MS]{0,2})$/)[0]; + }; + } + $version .= '+svn-' . $svnrevision if defined $svnrevision && length $svnrevision; + return; + } +} + +sub help { + print "\n"; + print "Usage: tiarra [--config=config-file] [options]\n"; + print "\n"; + print "options:\n"; + print " --help print this message\n"; + print " --version print version information\n"; + print " --dumpversion print version\n"; + print " --show-env print environment information\n"; + print " --config= tiarra configuration file; default is 'tiarra.conf'\n"; + print " --quiet don't output any messages to stdout and stderr\n"; + print " --no-fork don't move to background when started in quiet mode\n"; + print " --debug show debug information\n"; + print " --make-password prompt you a password to encrypt.\n"; + print " *Tiarra doesn't do its normal work with this option*\n"; + print " -D[=]\n"; + print " treat as `\@define ' is in the conf\n"; + print "\n"; + print "If you specify --config=- parameter,\n"; + print "Tiarra will read configuration from stdin(pipe).\n"; + print " example:\n"; + print " cat tiarra.conf | sed -e 's/Tiarra/arraiT/g' | ./tiarra --config=- --quiet\n"; + print " gunzip -c tiarra.conf.gz | ./tiarra --config=-\n"; + print "\n"; +} + +sub make_password { + eval 'use Crypt;'; + print "Tiarra encrypts your raw password to use it for config file.\n"; + print "\n"; + + my $password = &find_option('make-password'); + if ($password eq "1") { + eval 'use Term::ReadLine;'; + my $term = Term::ReadLine->new('tiarra'); + $password = $term->readline("Please enter raw password: "); + print "\n"; + } + print Crypt::encrypt($password)." is your encoded password.\n"; + print "Use this for the general/tiarra-password entry.\n"; +} + +sub find_option { + my $option = shift; + foreach my $arg (@ARGV) { + if ($arg eq "--$option") { + return 1; + } elsif ($arg =~ m/^--$option=(.+)$/) { + return $1; + } + } + undef; +} + +sub find_options { + # $opt_regex: オプション名の正規表現。後方参照を一つだけ作る事。 + # 戻り値: ([$1, 値], ...) + my $opt_regex = shift; + grep { + defined; + } map { + if (m/^--?$opt_regex=(.+)/) { + [$1, $2]; + } + elsif (m/^--?$opt_regex$/) { + [$1, 1]; + } + else { + undef; + } + } @ARGV; +} + +sub main { + if (&find_option('debug')) { + eval q(sub debug_printmsg{printmsg('debug: '.shift)}); + eval q(sub debug_mode{1;}); + $SIG{__WARN__} = sub { + ::printmsg(Carp::longmess(@_)); + }; + $SIG{__DIE__} = sub { + die @_ if $_[0] =~ /^[Cc]ouldn't connect/; + die @_ if $_[0] =~ /^network\/.+:\s*Server replied/; + die(Carp::longmess(@_)); + } + } else { + eval q(sub debug_printmsg{}); + eval q(sub debug_mode{0;}); + } + + if (&find_option('help')) { + &help; + return 0; + } elsif (&find_option('version')) { + map { print "$_\n" } get_credit(); + return 0; + } elsif (&find_option('dumpversion')) { + print $version . "\n"; + return 0; + } elsif (&find_option('show-env')) { + map { print "$_\n" } get_env(); + return 0; + } elsif (&find_option('make-password')) { + &make_password; + return 0; + } + + foreach my $pp_define (&find_options(qr/D(.+?)/)) { + &Configuration::Preprocessor::initial_define(@$pp_define); + } + + my $conf_file = &find_option('config'); + if (!defined $conf_file) { + if (-f 'tiarra.conf') { + $conf_file = 'tiarra.conf'; + } else { + &help; + return 2; + } + } + + my $quiet = &find_option('quiet'); + my $no_fork = &find_option('no-fork'); + + my $boot = sub { + eval { + RunLoop->shared_loop->run; + }; if ($@) { + die "Tiarra aborted: $@\n"; + } else { + print "Tiarra successfully finished.\n"; + } + }; + + my $print = $quiet ? sub {} : sub { print @_ }; + + if (!$quiet) { + foreach my $line (get_credit()) { + $print->($line,"\n"); + } + $print->("\n"); + } + + do { + local($|) = 1; + + if ($conf_file ne '-') { + $print->("Reading configuration from ${conf_file}... "); + } else { + $conf_file = IO::Handle->new->fdopen(fileno(STDIN),'r'); + $print->("Reading configuration from stdin... "); + } + + if (!$quiet) { + Configuration->shared_conf->load($conf_file); + } else { + eval { + Configuration->shared_conf->load($conf_file); + }; if ($@) { + die "an error occoured on config read: $@"; + } + } + $print->("ok\n"); + }; + + # quietモードならSTDIN, STDOUT, STDERRを閉じる。 + if ($quiet) { + close STDIN; + close STDOUT; + close STDERR; + } + + # quietモードであり、且つno-forkオプションが指定されなかったらfork。 + if ($quiet && !$no_fork) { + my $child_pid = fork; + if ($child_pid == 0) { + # 子プロセス + $boot->(); + } elsif (!defined $child_pid) { + print "Tiarra: fork() failed.\n"; + } + } else { + $boot->(); + } + return 0; +} + +sub printmsg { + # 文字コードはUTF-8でなければならない。 + my $msg = shift; + local($|) = 1; + if (!defined $msg) { + $msg = ''; + } + $msg =~ s/\n*$//s; + + # Configurationが読み込まれていない時に文字コード変換するとdie。 + eval { + local $SIG{__DIE__} = 'IGNORE'; + local $SIG{__WARN__} = 'IGNORE'; + $msg = Tiarra::Encoding->new($msg,'utf8')->conv( + Configuration->shared_conf->get('general')->stdout_encoding); + }; + + my ($sec,$min,$hour,$day,$mon,$year) = localtime(time); + $mon++; + $year += 1900; + + #printf("[%02d/%02d/%04d %02d:%02d:%02d] %s\n",$mon,$day,$year,$hour,$min,$sec,$msg); + #printf("[%02d/%02d %02d:%02d:%02d] %s\n",$mon,$day,$hour,$min,$sec,$msg); + printf("[pid:$$ %04d/%02d/%02d %02d:%02d:%02d] %s\n",$year,$mon,$day,$hour,$min,$sec,$msg); +} + +sub version { + $short_version; +} + +sub get_credit { + return ( + (!$based_version ? + "- T i a r r a - :::version #${version}:::" : + ("- T i a r r a - :::version ${version}:::", + " based #${based_version}") + ), + "Copyright (c) 2008 Tiarra Development Team. All rights reserved.", + "This is free software; you can redistribute it and/or modify it", + " under the same terms as Perl itself."); +} + +sub get_env { + use Config; + my @lines; + if (!$based_version) { + push @lines, "- T i a r r a - :::version #${version}:::"; + } else { + push @lines, "- T i a r r a - :::version ${version}:::"; + push @lines, " based #${based_version}"; + } + push @lines, "Environment Information:"; + push @lines, " - Perl $Config{version} built for $Config{archname}"; + push @lines, "Optional Modules:"; + push @lines, map " $_", Tiarra::OptionalModules->repr_modules; + push @lines, "Bundle Modules:"; + foreach my $mod (qw(Unicode::Japanese enum)) { + my $modfile = $mod . '.pm'; + $modfile =~ s|::|/|g; + eval "require $mod;"; + push @lines, " - $mod " . + ($INC{$modfile} ? + ($mod->VERSION . " (" . + ($INC{$modfile} =~ m|bundle/| ? "bundle" : "system") . ")") : + "(unknown; not loaded)"); + } + push @lines, "Default Encoding Driver: " . ref(Tiarra::Encoding->new); + @lines; +} + +sub install_signal_handlers { + local $SIG{__WARN__} = sub {}; + foreach (qw(INT QUIT ABRT TERM)) { + $SIG{$_} = \&handle_exit; + } + $SIG{HUP} = \&handle_reload; + $SIG{USR1} = \&handle_conf_reload; +} + +sub handle_exit { + my $signame = shift; + printmsg("SIG$signame received."); + &shutdown('Tiarra '.::version.": SIG$signame received; exit"); +} + +sub handle_reload { + my $signame = shift; + printmsg("SIG$signame received."); + ReloadTrigger->reload_conf_if_updated; + ReloadTrigger->reload_mods_if_updated; +} + +sub handle_conf_reload { + my $signame = shift; + printmsg("SIG$signame received."); + ReloadTrigger->reload_conf_if_updated; +} + +sub shutdown { + my $msg = shift; + $msg = 'Tiarra '.::version.': shutting down...' if !defined $msg; + ++$terminated; + if ($terminated == 1) { + printmsg("Shutting down... [$msg]"); + RunLoop->shared_loop->terminate($msg); + } elsif ($terminated == 2) { + printmsg("Second Terminate Request; Force Exit! [$msg]"); + # force + print "cleanup ModuleManager..."; + ModuleManager->shared_manager->terminate; + print "done.\n"; + print "cleanup TerminateManager..."; + Tiarra::TerminateManager->terminate('main'); + print "done.\n"; + exit; + } else { + printmsg("Third Terminate Request; Fatal Exit! [$msg]"); + # fatal + exit; + } +} + +my $exitval = main; +&debug_mode && print "cleanup TerminateManager..."; +Tiarra::TerminateManager->terminate('main'); +&debug_mode && print "done.\n"; +exit $exitval; diff -urN /non-existant-dir/tiarra-conf.el tiarra-20080510/tiarra-conf.el --- /non-existant-dir/tiarra-conf.el 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/tiarra-conf.el 2008-05-11 00:25:24.000000000 +0900 @@ -0,0 +1,266 @@ +;; -*- emacs-lisp -*- +;; ---------------------------------------------------------------------------- +;; $Id: tiarra-conf.el 11365 2008-05-10 14:58:28Z topia $ +;; ---------------------------------------------------------------------------- +;; tiarra.conf編集用モード。 +;; ---------------------------------------------------------------------------- + +;; キーマップ +(defvar tiarra-conf-mode-map + (let ((map (make-keymap))) + (define-key map "\M-n" 'tiarra-conf-next-block) + (define-key map "\M-p" 'tiarra-conf-prev-block) + (define-key map [?\C-c?\C-.] 'tiarra-conf-jump-to-block) + (define-key map "\C-c." 'tiarra-conf-jump-to-block) + map) + "Keymap for tiarra conf mode.") + +;; 構文定義 +(defvar tiarra-conf-mode-syntax-table nil + "Syntax table used while in tiarra conf mode.") +(if tiarra-conf-mode-syntax-table + () ; 構文テーブルが既存ならば變更しない + (setq tiarra-conf-mode-syntax-table (make-syntax-table)) + (modify-syntax-entry ?{ "(}") + (modify-syntax-entry ?} "){")) + +;; 略語定義 +(defvar tiarra-conf-mode-abbrev-table nil + "Abbrev table used while in tiarra conf mode.") +(define-abbrev-table 'tiarra-conf-mode-abbrev-table ()) + +;; フック +(defvar tiarra-conf-mode-hook nil + "Normal hook runs when entering tiarra-conf-mode.") + +(defun tiarra-conf-mode () + "Major mode for editing tiarra conf file. +\\{tiarra-conf-mode-map} +Turning on tiarra-conf-mode runs the normal hook `tiarra-conf-mode-hook'." + (interactive) + (kill-all-local-variables) + (use-local-map tiarra-conf-mode-map) + (set-syntax-table tiarra-conf-mode-syntax-table) + (setq local-abbrev-table tiarra-conf-mode-abbrev-table) + (setq mode-name "Tiarra-Conf") + (setq major-mode 'tiarra-conf-mode) + + ;; フォントロックの設定 + (make-local-variable 'font-lock-defaults) + (setq tiarra-conf-font-lock-keywords + (list '("^[\t ]*#.*$" + . font-lock-comment-face) ; コメント + '("^[\t ]*@.*$" + . font-lock-warning-face) ; @文 + '("^[\t ]*\\+[\t ]+.+$" + . font-lock-type-face) ; + モジュール + '("^[\t ]*-[\t ]+.+$" + . font-lock-constant-face) ; - モジュール + '("^[\t ]*\\([^:\n]+\\)\\(:\\).*$" + (1 font-lock-variable-name-face) ; key + (2 font-lock-string-face)) ; ':' + '("^[\t ]*[^{}\n]+" + . font-lock-function-name-face))) ; ブロック名 + (setq font-lock-defaults '(tiarra-conf-font-lock-keywords t)) + + ;; mmm-modeの設定 + (if (featurep 'mmm-auto) + (progn + (mmm-add-group + 'embedding-in-tconf + '((pre-in-tconf + :submode perl + :front "%PRE{" + :back "}ERP%") + (code-in-tconf + :submode perl + :front "%CODE{" + :back "}EDOC%"))) + (setq mmm-classes 'embedding-in-tconf) + (mmm-mode-on))) + + (run-hooks 'tiarra-conf-mode-hook)) + +(defun tiarra-conf-next-token () + "カレントバッファの現在のカーソル位置から次のトークンを探して返す。 +カーソルはそのトークンの終はりの位置へ移動する。 + +返されるのは次のやうなリストである。 +\(\"トークン\" '種類) +種類: + pair -> キーと値のペア + label -> ブロックのラベル + blockstart -> ブロックの開始記號 + blockend -> ブロックの終了記號 + +トークンが無ければnilを返す。" + (catch 'tiarra-conf-next-token + ;; まずは空白とコメントを飛ばす。 + ;; @文も%PREも%CODEも飛ばす。 + ;; ……しかし「最小一致」の使へないElisp-Regexで + ;; どうやつて%PREに一致させたものだか分からない。 + ;; 助けて。 + (or (re-search-forward "^\\([\n\t ]\\|#.*\\|@.*\\)*" nil t 1) + (throw 'tiarra-conf-next-token nil)) + + ;; "キー: 値"の形式であれば、行の終はりまでがトークン。 + (let* ((keychar "[^{}:\n\t ]") ; キーとして許される文字 + (pair (concat keychar "+[\t ]*:.*")) ; キーと値のペア + + ;; 連續する二つのコロンは、特例としてラベル名に許す。 + (labelchar "\\([^-{}\n\t ]\\|::\\)") ; ブロック名として許される文字 + (label (concat "\\(\\(\\+\\|-\\)[\t ]+\\)?" labelchar "+")) ;; ブロックのラベル + + (blockstart "{") ;; ブロックの開始 + (blockend "}") ;; ブロックの終了 + + type) + (setq type + (cond ((looking-at pair) 'pair) + ((looking-at label) 'label) + ((looking-at blockstart) 'blockstart) + ((looking-at blockend) 'blockend))) + (if (null type) + nil + (prog1 (list (buffer-substring (point) (match-end 0)) + type) + (goto-char (match-end 0))))))) + +(defun tiarra-conf-next-block (&optional n) + "次からn番目のブロックの位置へカーソルを移動する。 +nは省略可能で、省略された場合は`1'。 +ブロックが見付かつた場合は、そのラベルの開始位置を返す。" + (interactive "p") + (catch 'tiarra-conf-next-block + (setq n (if (numberp n) n 1)) + + (if (< n 0) + (throw 'tiarra-conf-next-block (tiarra-conf-prev-block (* -1 n)))) + (if (= n 0) + (throw 'tiarra-conf-next-block nil)) + + ;; カーソルを行の先頭へ移動。 + (beginning-of-line) + + (let (result token) + ;; labelが來るまでトークンを探す。 + (while (progn + (setq token (tiarra-conf-next-token)) + ;; tokenがnilまたはlabelなら終了。 + (if (or (null token) + (eq (cadr token) 'label)) + nil + ;; label以外のトークンなので、再度檢索。 + t))) + (if (null token) + ;; トークンが無い。ここで終はり。 + nil + (setq result (point)) + ;; "{"の次の非空白文字へ移動。 + (re-search-forward "{" nil t 1) + (re-search-forward "[^\n\t ]" nil t 1) + (backward-char) + + ;; nが2以上だったらもう一度。 + (if (> n 1) + (tiarra-conf-next-block (1- n)) + result))))) + +(defun tiarra-conf-prev-block (&optional n) + "前からn番目のブロックの位置へカーソルを移動する。 +nは省略可能で、省略された場合は`1'。 +ブロックが見付かつた場合は、そのラベルの開始位置を返す。" + (interactive "p") + (catch 'tiarra-conf-prev-block + (setq n (if (numberp n) n 1)) + (setq n (1+ n)) + + (if (< n 0) + (throw 'tiarra-conf-prev-block (tiarra-conf-next-block (* -1 n)))) + + ;; まづ次のブロックを探して、その位置を記録する。nilならnilで良い。 + (let ((next-block-pos + (save-excursion (tiarra-conf-next-block))) + current-block-pos) + ;; 一行づつカーソルを前に戻しつつ、「次の」ブロックを探してみる。 + ;; next-block-posよりも前に存在するブロックを見付けたら、そこで止める。 + (while (progn + (beginning-of-line) + (if (= (point) (point-min)) + ;; これ以上前には戻れない。 + nil + ;; まだ戻れる。 + (previous-line) + (setq current-block-pos + (save-excursion (tiarra-conf-next-block))) + ;; 最初に見付けた「次の」ブロックがnilだつたり、 + ;; 今囘見付けた「次の」ブロックと最初のそれが異つてゐたりすれば + ;; これを返して終了する。でなければ同じ事を繰返す。 + (eq current-block-pos next-block-pos)))) + + ;; nが2以上だつたらもう一度。 + (if (> n 1) + ;; カーソル位置を先頭へ戻す + (progn (beginning-of-line) + (tiarra-conf-prev-block (- n 2))) + ;; カーソルを適切な位置へ移動させる爲だけに + ;; tiarra-conf-next-blockを呼ぶ。 + (tiarra-conf-next-block) + current-block-pos)))) + +(defun tiarra-conf-join (delimitor sequence) + "perlのjoin(delimitor, sequence)と同じ。" + (let (result join) + (setq join (lambda (elem) + (setq result (if (null result) + elem + (concat result delimitor elem))))) + (mapcar join sequence) + result)) + +(defun tiarra-conf-jump-to-block () + "そのconf中にあるブロックの名前を入力し、その場所にジャンプするコマンド。" + (interactive) + (let (comp-list ;; competing-readで使ふalist ("ブロック名" . labelトークンの直後の位置) + parsing-block-stack ;; ("ブロック名" ...) + blockname-to-jump + point-to-jump) + (save-excursion + ;; カーソルをファイルの先頭へ + (goto-char (point-min)) + ;; 一つづつトークンを見て行く。labelを見たら記録する。 + (while (let (token type blockname) + (setq token (tiarra-conf-next-token)) + (if (null token) + ;; もうトークンが無い。 + nil + (setq type (cadr token)) + (cond ((eq type 'label) + ;; ﾌﾞﾛｯｸ(･∀･)ｶｲｼ + (setq blockname (car token)) + (if (string-match "^[-+][\t ]+" blockname) ; +や-は取る。 + (setq blockname (replace-match "" nil nil blockname))) + (push blockname parsing-block-stack) + (setq comp-list + (append comp-list + (list (cons + (tiarra-conf-join " - " (reverse parsing-block-stack)) + (point)))))) + ((eq type 'blockend) + ;; ﾌﾞﾛｯｸ(･Ａ･)ｼｭｳﾘｮｳ + (pop parsing-block-stack))) + t))) + ;; ブロック名を聞く。 + (let ((completion-ignore-case t)) ; 一時的にこの變數をtに。動的スコープは便利だね…。 + (setq blockname-to-jump (completing-read + "ジャンプするブロック: " + comp-list nil t))) + (setq point-to-jump (cdr (assoc blockname-to-jump comp-list)))) + (if point-to-jump + ;; 適切な位置へカーソルを移動 + (progn + (goto-char point-to-jump) + (beginning-of-line) + (tiarra-conf-next-block))))) + + diff -urN /non-existant-dir/tiarra-conf.l tiarra-20080510/tiarra-conf.l --- /non-existant-dir/tiarra-conf.l 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20080510/tiarra-conf.l 2008-05-11 00:25:24.000000000 +0900 @@ -0,0 +1,112 @@ +;;; -*- Mode: Lisp; Package: EDITOR -*- + +;; $Id: tiarra-conf.l 8435 2008-03-27 03:20:36Z elim $ + +;;tiarra-conf.l (tiarra-conf.el̈ڐA) +;;Copyright (C) 2003 Noboruhi + +;;Author: Noboruhi +;;Version: 0.0.0.1 + +;; g: + +;; 1. tiarra-conf.l(̃t@C)(xyzzyCXg[fBNg)/site-lisp/ ɃRs[ +;; 2. KvoCgRpC +;; 3. W[o^B +;; [.xyzzy ̏ꍇ] +;; (export 'ed::tiarra-conf-mode "ed") +;; (autoload 'tiarra-conf-mode "tiarra-conf" t) +;; [siteinit.l̏ꍇ] +;; (in-package "editor") +;; (export 'tiarra-conf-mode) +;; (autoload 'tiarra-conf-mode "tiarra-conf" t) +;; (in-package "user") +;; 4.xyzzyċN + +;; JX^}CY: + +;; F̕ύX +;; (setq ed::*tiarra-conf-font-lock-comment-face* '(:comment)) +;; (setq ed::*tiarra-conf-font-lock-warning-face* '((:keyword :comment :bold))) +;; (setq ed::*tiarra-conf-font-lock-type-face* '((:keyword 0))) +;; (setq ed::*tiarra-conf-font-lock-constant-face* '((:keyword 2))) +;; (setq ed::*tiarra-conf-font-lock-variable-face* '(:color 11 0)) +;; (setq ed::*tiarra-conf-font-lock-string-face* ':string) +;; (setq ed::*tiarra-conf-font-lock-function-name-face* '((:keyword 1))) + +;; Changes: +;; [Version 0.0.0.1] +;; EŁBȂAȂB +;; + +(provide "tiarra-conf-mode") +(in-package "editor") + +;; L[}bv +(defvar *tiarra-conf-mode-map* nil + "Keymap for tiarra conf mode.") + + +(unless *tiarra-conf-mode-map* + (setq *tiarra-conf-mode-map* (make-sparse-keymap))) + +;; \` +(defvar *tiarra-conf-mode-syntax-table* nil + "Syntax table used while in tiarra conf mode.") +(unless *tiarra-conf-mode-syntax-table* + (setq *tiarra-conf-mode-syntax-table* (make-syntax-table)) + (set-syntax-match *tiarra-conf-mode-syntax-table* #\{ #\})) + + +;; ` +(defvar *tiarra-conf-mode-abbrev-table* nil + "Abbrev table used while in tiarra conf mode.") +(unless *tiarra-conf-mode-abbrev-table* + (define-abbrev-table '*tiarra-conf-mode-abbrev-table*)) + + +;; tbN +(defvar *tiarra-conf-mode-hook* nil + "Normal hook runs when entering tiarra-conf-mode.") + +;; tHgbN̐ݒ +(defvar *tiarra-conf-font-lock-comment-face* '(:comment)) +(defvar *tiarra-conf-font-lock-warning-face* '((:keyword :comment :bold))) +(defvar *tiarra-conf-font-lock-type-face* '((:keyword 0))) +(defvar *tiarra-conf-font-lock-constant-face* '((:keyword 2))) +(defvar *tiarra-conf-font-lock-variable-face* '(:color 11 0)) +(defvar *tiarra-conf-font-lock-string-face* ':string) +(defvar *tiarra-conf-font-lock-function-name-face* '((:keyword 1))) + +(defvar *tiarra-conf-regexp-keyword-list* + (compile-regexp-keyword-list + `( + ("^[\t ]*#.*$" nil . ,*tiarra-conf-font-lock-comment-face*) + ("^[\t ]*@.*$" nil . ,*tiarra-conf-font-lock-warning-face*) + ("^[\t ]*\\+[\t ]+.+$" nil . ,*tiarra-conf-font-lock-type-face*) + ("^[\t ]*-[\t ]+.+$" nil . ,*tiarra-conf-font-lock-constant-face*) + ("^[\t ]*\\([^:\n]+\\)\\(:\\).*$" nil ((1 . ,*tiarra-conf-font-lock-variable-face*) + (2 . ,*tiarra-conf-font-lock-string-face*))) + ("^[\t ]*[^{}\n]+" nil . ,*tiarra-conf-font-lock-function-name-face*) + ))) + + + + +;; +(defun tiarra-conf-mode () + "Major mode for editing tiarra conf file. +\\{*tiarra-conf-mode-map*} +Turning on tiarra-conf-mode runs the normal hook `tiarra-conf-mode-hook'." + (interactive) + (kill-all-local-variables) + (setq mode-name "tiarra-conf") + (setq buffer-mode 'tiarra-conf-mode) + (use-keymap *tiarra-conf-mode-map*) + (use-syntax-table *tiarra-conf-mode-syntax-table*) + (setq *local-abbrev-table* *tiarra-conf-mode-abbrev-table*) + (make-local-variable 'regexp-keyword-list) + (setq regexp-keyword-list *tiarra-conf-regexp-keyword-list*) + (run-hooks '*tiarra-conf-mode-hook*)) + +