diff -urN tiarra-20090206/.svnversion tiarra-20091019/.svnversion --- tiarra-20090206/.svnversion 2009-02-09 22:30:09.000000000 +0900 +++ tiarra-20091019/.svnversion 2009-10-19 01:19:33.000000000 +0900 @@ -1 +1 @@ -29652 \ No newline at end of file +35634 \ No newline at end of file diff -urN tiarra-20090206/ChangeLog.svn tiarra-20091019/ChangeLog.svn --- tiarra-20090206/ChangeLog.svn 2009-02-09 22:30:19.000000000 +0900 +++ tiarra-20091019/ChangeLog.svn 2009-10-19 01:19:44.000000000 +0900 @@ -1,4 +1,292 @@ ------------------------------------------------------------------------ +r35634 | topia | 2009-10-19 01:17:48 +0900 (Mon, 19 Oct 2009) | 1 line +Changed paths: + M /lang/perl/tiarra/trunk/NEWS + +write NEWS to release archive. +------------------------------------------------------------------------ +r35621 | topia | 2009-10-16 20:28:45 +0900 (Fri, 16 Oct 2009) | 2 lines +Changed paths: + M /lang/perl/tiarra/trunk/module/Auto/Im.pm + M /lang/perl/tiarra/trunk/module/Auto/Notify.pm + +Auto::Notify (send_im_kayac): accept more-relaxed result. +Auto::Im: implement post result check. +------------------------------------------------------------------------ +r35566 | topia | 2009-10-09 23:53:58 +0900 (Fri, 09 Oct 2009) | 1 line +Changed paths: + M /lang/perl/tiarra/trunk/main/Tiarra/Resolver.pm + M /lang/perl/tiarra/trunk/main/Tiarra/TerminateManager.pm + M /lang/perl/tiarra/trunk/tiarra + +forking with running threads is totally bad idea; hack to shutdown threads before fork. +------------------------------------------------------------------------ +r35459 | topia | 2009-09-23 23:23:50 +0900 (Wed, 23 Sep 2009) | 1 line +Changed paths: + M /lang/perl/tiarra/trunk/module/Auto/Notify.pm + +check API response after posting notify. +------------------------------------------------------------------------ +r34672 | drry | 2009-07-29 12:18:07 +0900 (Wed, 29 Jul 2009) | 3 lines +Changed paths: + M /lang/perl/tiarra/trunk + M /lang/perl/tiarra/trunk/all.conf + M /lang/perl/tiarra/trunk/doc/module/Auto.html + M /lang/perl/tiarra/trunk/doc/module-toc.html + M /lang/perl/tiarra/trunk/doc-src/conf-main.tdoc + M /lang/perl/tiarra/trunk/main/Template.pm + M /lang/perl/tiarra/trunk/sample.conf + + * added `svn:ignore` property. + * documentation. + +------------------------------------------------------------------------ +r34388 | topia | 2009-07-11 12:54:44 +0900 (Sat, 11 Jul 2009) | 2 lines +Changed paths: + M /lang/perl/tiarra/trunk/module/Auto/Notify.pm + +fix mirc text-formatting remove code. + +------------------------------------------------------------------------ +r34369 | topia | 2009-07-09 02:58:50 +0900 (Thu, 09 Jul 2009) | 2 lines +Changed paths: + M /lang/perl/tiarra/trunk/module/Auto/Notify.pm + +oops. add /g option. + +------------------------------------------------------------------------ +r34368 | topia | 2009-07-09 02:29:18 +0900 (Thu, 09 Jul 2009) | 3 lines +Changed paths: + M /lang/perl/tiarra/trunk/module/Auto/Notify.pm + +strip mirc text formatting before send to im.kayac.com / prowl.weks.net. +and fix small error on tiarradoc. + +------------------------------------------------------------------------ +r34367 | topia | 2009-07-09 01:53:49 +0900 (Thu, 09 Jul 2009) | 2 lines +Changed paths: + M /lang/perl/tiarra/trunk/module/Auto/Notify.pm + +add some example. + +------------------------------------------------------------------------ +r34366 | topia | 2009-07-09 01:41:15 +0900 (Thu, 09 Jul 2009) | 2 lines +Changed paths: + M /lang/perl/tiarra/trunk/module/Auto/Notify.pm + +fix bug and support global format (and local override). + +------------------------------------------------------------------------ +r34365 | topia | 2009-07-09 01:33:28 +0900 (Thu, 09 Jul 2009) | 2 lines +Changed paths: + M /lang/perl/tiarra/trunk/module/Auto/Notify.pm + +support multiple 'blocks' entry. + +------------------------------------------------------------------------ +r34364 | topia | 2009-07-09 00:57:36 +0900 (Thu, 09 Jul 2009) | 7 lines +Changed paths: + A /lang/perl/tiarra/trunk/module/Auto/Notify.pm + +initial add to Auto::Notify, supports im.kayac.com (same as +Auto::Im) and prowl.weks.net. + +Known problem: + * prowl: verify implemented, but not tested. + * response is not checked at all. + +------------------------------------------------------------------------ +r33938 | topia | 2009-06-13 17:20:02 +0900 (Sat, 13 Jun 2009) | 4 lines +Changed paths: + M /lang/perl/tiarra/trunk/main/Tiarra/Socket/Connect.pm + +implements randomization of connection order (aka. DNS Round-robin) for Tiarra::Socket::Connect. + +see also: http://d.hatena.ne.jp/JULY/20090612/p1 + +------------------------------------------------------------------------ +r33908 | topia | 2009-06-12 00:22:07 +0900 (Fri, 12 Jun 2009) | 2 lines +Changed paths: + M /lang/perl/tiarra/trunk/tiarra + +fix help string of --quiet for clarification. + +------------------------------------------------------------------------ +r33535 | topia | 2009-05-24 02:28:58 +0900 (Sun, 24 May 2009) | 3 lines +Changed paths: + M /lang/perl/tiarra/trunk/module/Channel/Rejoin.pm + +Support rejoin with a channel can't get +b/+e/+I list without operator +privilege, but requires r33534's change. + +------------------------------------------------------------------------ +r33534 | topia | 2009-05-24 01:28:57 +0900 (Sun, 24 May 2009) | 2 lines +Changed paths: + M /lang/perl/tiarra/trunk/main/Multicast.pm + +handle multicast on more error replies. + +------------------------------------------------------------------------ +r33290 | topia | 2009-05-14 03:10:09 +0900 (Thu, 14 May 2009) | 3 lines +Changed paths: + M /lang/perl/tiarra/trunk/module/Channel/Rejoin.pm + +re-check channel status before send part-and-join. +(but test is not done...) + +------------------------------------------------------------------------ +r33115 | topia | 2009-05-07 02:55:44 +0900 (Thu, 07 May 2009) | 2 lines +Changed paths: + M /lang/perl/tiarra/trunk/main/Configuration/Preprocessor.pm + +fix to discard undefined warning. + +------------------------------------------------------------------------ +r32571 | hio | 2009-04-18 13:59:26 +0900 (Sat, 18 Apr 2009) | 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/Calc.pm + +Auto::Calc, 全角空白での区切りに対応. + +------------------------------------------------------------------------ +r32570 | hio | 2009-04-18 13:57:59 +0900 (Sat, 18 Apr 2009) | 2 lines +Changed paths: + M /lang/perl/tiarra/trunk/module/Auto/FetchTitle/Plugin/ExtractHeading.pm + +見出し取得更新. + +------------------------------------------------------------------------ +r32465 | hio | 2009-04-16 00:51:00 +0900 (Thu, 16 Apr 2009) | 2 lines +Changed paths: + M /lang/perl/tiarra/trunk/module/System/WebClient.pm + +LWPなかったときにAUで認証できないのに対応. + +------------------------------------------------------------------------ +r32463 | hio | 2009-04-16 00:08:31 +0900 (Thu, 16 Apr 2009) | 2 lines +Changed paths: + M /lang/perl/tiarra/trunk/module/System/WebClient.pm + +バグ修正. + +------------------------------------------------------------------------ +r31673 | hio | 2009-03-29 21:24:29 +0900 (Sun, 29 Mar 2009) | 2 lines +Changed paths: + M /lang/perl/tiarra/trunk/module/Log/Logger.pm + M /lang/perl/tiarra/trunk/module/System/WebClient.pm + +WebClient, NOTICE対応. + +------------------------------------------------------------------------ +r31645 | hio | 2009-03-28 23:40:50 +0900 (Sat, 28 Mar 2009) | 2 lines +Changed paths: + M /lang/perl/tiarra/trunk/module/Auto/FetchTitle/Plugin/Mixi.pm + +DEBUG消し忘れ. + +------------------------------------------------------------------------ +r31644 | hio | 2009-03-28 23:37:52 +0900 (Sat, 28 Mar 2009) | 2 lines +Changed paths: + M /lang/perl/tiarra/trunk/module/Auto/FetchTitle/Plugin/Mixi.pm + +Mixiのアルバム情報をとれなかったのを修正. + +------------------------------------------------------------------------ +r31557 | topia | 2009-03-25 22:32:21 +0900 (Wed, 25 Mar 2009) | 1 line +Changed paths: + M /lang/perl/tiarra/trunk/main/Tiarra/OptionalModules.pm + +permit to disable some optional feature from environment variables. +------------------------------------------------------------------------ +r31269 | topia | 2009-03-16 02:39:02 +0900 (Mon, 16 Mar 2009) | 2 lines +Changed paths: + M /lang/perl/tiarra/trunk/all.conf + M /lang/perl/tiarra/trunk/doc/module/Client.html + M /lang/perl/tiarra/trunk/doc/module-toc.html + +regen documentation. +Client::SingleServer は Multicast の実装状況から考えると無理すぎると分かったのでなかったことに。 +------------------------------------------------------------------------ +r31268 | topia | 2009-03-16 02:38:14 +0900 (Mon, 16 Mar 2009) | 2 lines +Changed paths: + M /lang/perl/tiarra/trunk/main/Multicast.pm + +fix some detach handler. + +------------------------------------------------------------------------ +r31267 | topia | 2009-03-16 02:08:00 +0900 (Mon, 16 Mar 2009) | 1 line +Changed paths: + D /lang/perl/tiarra/trunk/module/Client/SingleServer.pm + +全然動いてないのでとりあえず削除 +------------------------------------------------------------------------ +r31259 | topia | 2009-03-15 21:58:35 +0900 (Sun, 15 Mar 2009) | 1 line +Changed paths: + M /lang/perl/tiarra/trunk/all.conf + M /lang/perl/tiarra/trunk/doc/module/Client.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-toc.html + M /lang/perl/tiarra/trunk/sample.conf + +update documentation. +------------------------------------------------------------------------ +r31258 | topia | 2009-03-15 21:58:10 +0900 (Sun, 15 Mar 2009) | 1 line +Changed paths: + M /lang/perl/tiarra/trunk/HACKING + M /lang/perl/tiarra/trunk/main/Module.pm + A /lang/perl/tiarra/trunk/module/Skeleton.pm (from /lang/perl/tiarra/trunk/module/Skelton.pm:31257) + D /lang/perl/tiarra/trunk/module/Skelton.pm + +fix typo Skelton -> Skeleton. +------------------------------------------------------------------------ +r31257 | topia | 2009-03-15 21:53:34 +0900 (Sun, 15 Mar 2009) | 2 lines +Changed paths: + A /lang/perl/tiarra/trunk/module/Client/SingleServer.pm + +add initial version of Client::SingleServer. + +------------------------------------------------------------------------ +r31256 | hio | 2009-03-15 20:49:11 +0900 (Sun, 15 Mar 2009) | 2 lines +Changed paths: + M /lang/perl/tiarra/trunk/module/System/WebClient.pm + +WebClient, URLエスケープがなくなっていたのを修正. + +------------------------------------------------------------------------ +r31242 | hio | 2009-03-15 18:01:19 +0900 (Sun, 15 Mar 2009) | 2 lines +Changed paths: + M /lang/perl/tiarra/trunk/module/System/WebClient.pm + +WebClient, version 0.07. + +------------------------------------------------------------------------ +r31241 | hio | 2009-03-15 17:59:02 +0900 (Sun, 15 Mar 2009) | 2 lines +Changed paths: + M /lang/perl/tiarra/trunk/module/System/WebClient.pm + +WebClient, shared-modeでもJOINは可能に. 退室状態での表示を改善. + +------------------------------------------------------------------------ +r31238 | hio | 2009-03-15 14:57:24 +0900 (Sun, 15 Mar 2009) | 3 lines +Changed paths: + M /lang/perl/tiarra/trunk/module/System/WebClient.pm + +WebClient, shared-mode時はpart/join/deleteを使えないように修正. +topicが変わってないときは何もしないように修正. + +------------------------------------------------------------------------ +r30026 | topia | 2009-02-14 03:32:10 +0900 (Sat, 14 Feb 2009) | 4 lines +Changed paths: + M /lang/perl/tiarra/trunk/doc-src/conf-main.tdoc + +networks/action-when-disconnected の説明を微修正。 +* 推奨値とデフォルト値が別々になっているだけなのだが、 + わかりにくいので「省略時の」を足した。 + +------------------------------------------------------------------------ r29652 | topia | 2009-02-06 22:55:13 +0900 (Fri, 06 Feb 2009) | 2 lines Changed paths: M /lang/perl/tiarra/trunk/main/Configuration.pm diff -urN tiarra-20090206/HACKING tiarra-20091019/HACKING --- tiarra-20090206/HACKING 2009-02-09 22:30:09.000000000 +0900 +++ tiarra-20091019/HACKING 2009-10-19 01:19:33.000000000 +0900 @@ -1,7 +1,7 @@ モジュールについて * モジュールの新規作成 -module/Skelton.pm にモジュールのスケルトンがありますので、 +module/Skeleton.pm にモジュールのスケルトンがありますので、 これをコピーして不要な関数を削除すれば、作ることが出来ます。 * 注意すべき事項 @@ -120,7 +120,7 @@ 一般的な自動反応をするのに有用なクロージャを生成する。 + sendto_channel_closure(...) チャンネル等に PRIVMSG / NOTICE を送るクロージャを生成する。 - 一般的な使い方は Skelton.pm に書いておきました。 + 一般的な使い方は Skeleton.pm に書いておきました。 * remark のあるオブジェクト remark とは、オブジェクトに関連づけられた、自由に使える key/value pair です。 diff -urN tiarra-20090206/NEWS tiarra-20091019/NEWS --- tiarra-20090206/NEWS 2009-02-09 22:30:09.000000000 +0900 +++ tiarra-20091019/NEWS 2009-10-19 01:19:33.000000000 +0900 @@ -1,3 +1,24 @@ +2009-10-19 Topia + + * Auto::Im + - 結果チェックを改善 + * tiarra, Tiarra::Resolver, Tiarra::Terminatemanager + - スレッドが有効で --quiet を利用した時(fork した時)に + 動作しないバグを修正 + * Auto::Notify + - 追加。 im.kayac.com と Prowl の両方をサポート + * Tiarra::Socket::Connect + - DNS round-robin サポート + * Channel::Rejoin + - +b/+e/+I が取れない場合にもきちんと rejoin できるようにした + * Auto::Calc + - 全角空白対応 + * Auto::FetchTitle::Plugin::* + - 細かくは ChangeLog.svn を参照ください。 + * System::WebClient, Log::Logger + - NOTICE 対応 + * 2004-08-22 から2009-02-06 の間の NEWS は書いていません + 2004-08-22 Topia * Client::Rehash diff -urN tiarra-20090206/all.conf tiarra-20091019/all.conf --- tiarra-20090206/all.conf 2009-02-09 22:30:12.000000000 +0900 +++ tiarra-20091019/all.conf 2009-10-19 01:19:35.000000000 +0900 @@ -14,7 +14,7 @@ # ----------------------------------------------------------------------------- general { # tiarra.conf自身の文字コード - # コード名はjis,sjis,euc,utf8,utf16,utf32等。(この値はUnicode::Japaneseにそのまま渡されます) + # コード名はjis,sjis,euc,utf8,utf16,utf32等。(この値はEncodeまたはUnicode::Japaneseにそのまま渡されます) # autoが指定された、または省略された場合は自動判別します。 conf-encoding: utf8 @@ -59,13 +59,13 @@ # そのような場合にもこの機能は無効となる。 #control-socket-name: test - # IRCサーバーから送られる文字のコードと、IRCサーバーへ送る文字のコード - # どちらも省略された場合はjis。 + # IRCサーバーから送られる文字のコードと、IRCサーバーへ送る文字のコード。 + # それぞれ省略された場合はjis。 server-in-encoding: jis server-out-encoding: jis - # クライアントから受け取る文字のコードと、クライアントへ伝える文字のコード - # どちらも省略された場合はjis。 + # クライアントから受け取る文字のコードと、クライアントへ伝える文字のコード。 + # それぞれ省略された場合はjis。 client-in-encoding: jis client-out-encoding: jis @@ -94,7 +94,7 @@ # mask: ++{example3}@ircnet,-+{example4}@2ch +*!*@*.example.com # +で始まるチャンネル。 # mask: * -*!*@* #----------------- - # となります。 この二つはまったく同じマスクを表しています。 + # となります。この二つはまったく同じマスクを表しています。 # この値をplumにすると、plum形式、省略するかtiarraを指定すると、Tiarra形式になります。 chanmask-mode: tiarra @@ -198,7 +198,7 @@ # 3. "message-for-each"の場合は、切断されるとクライアントに宛ててTiarraが # 到達不能になった全てのチャンネルにNOTICEでその旨を報告する。 # 再接続に成功すると再びNOTICEで報告する。JOINやPARTはしない。 - # デフォルトはpart-and-joinです。 + # 省略時のデフォルトはpart-and-joinです。 action-when-disconnected: message-for-each # NICKを変更する度に、変更したサーバーでの新しいNICKをNOTICEで常に通知するかどうか。 @@ -434,6 +434,11 @@ # 再初期化したときの発言を指定します。 init-format: 初期化しました。 + + # 別の shared-mode な System::WebClient からの発言に対応(yes/no). + # 自分自身の発言は未対応. + # [default: no] + #support-shared-webclient: no } - Auto::ChannelWithoutOper { @@ -454,7 +459,7 @@ timeout: 3 # 有効にするチャンネルとオプションとURLの設定. - # 書式: mask: [...] + # 書式: mask: [<&conf>...] # # mask: #test@ircnet &test http://* # mask: * http://* @@ -708,6 +713,70 @@ #fatalerror: SMTPセッションで致命的なエラーがありました。#(line; サーバ応答:%s|;)#(state; on %s|;) } +- Auto::Notify { + # 名前が呼ばれると、その発言をim.kayac.comに送信する + + # 反応する人のマスクを指定します。 + # 省略すると全員に反応します。 + mask: * *!*@* + + # 反応するキーワードを正規表現で指定します。 + # 複数指定したい時は複数行指定してください。 + #regex-keyword: (?i:fugahoge) + + # 反応するキーワードを指定します。 + # 複数指定したい時は,(コンマ)で区切るか、複数行指定してください。 + keyword: hoge + + # メッセージのフォーマットを指定します。 + # デフォルト値: [tiarra][#(channel):#(nick.now)] #(text) + # #(channel) のかわりに #(raw_channel) を利用するとネットワーク名がつきません。 + format: [tiarra][#(channel):#(nick.now)] #(text) + + # 使用するブロックを指定します + #blocks: im prowl + + im { + + # 通知先のタイプを指定します。 + type: im_kayac + + # 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 + + } + + prowl { + + # 通知先のタイプを指定します。 + type: prowl + + # 通知先ごとにフォーマットを指定できます。 + # この例では先頭に時刻を追加しています。 + #format: #(date:%H:%M:%S) [#(channel):#(nick.now)] #(text) + + # Prowl で表示された apikey を入力します。 + # Prowl については http://prowl.weks.net/ を参考にしてください。 + #apikey: XXXXXX + + # http://forums.cocoaforge.com/viewtopic.php?f=45&t=20339 + priority: 0 + application: tiarra + event: keyword + + } +} + - Auto::Oper { # 特定の文字列を発言した人を+oする。 @@ -1626,7 +1695,7 @@ command: privmsg,notice,topic,join,part,quit,kill } -- Skelton { +- Skeleton { # Skeleton for tiarra-module. # モジュールの説明をこのあたりに書く. @@ -1838,7 +1907,7 @@ } allow-public { host: * - auth: user2 pass2 + auth: :basic user2 pass2 mask: #公開チャンネル@ircnet } diff -urN tiarra-20090206/doc/module/Auto.html tiarra-20091019/doc/module/Auto.html --- tiarra-20090206/doc/module/Auto.html 2009-02-09 22:30:12.000000000 +0900 +++ tiarra-20091019/doc/module/Auto.html 2009-10-19 01:19:35.000000000 +0900 @@ -205,6 +205,12 @@ 再初期化したときの発言を指定します。

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

+別の shared-mode な System::WebClient からの発言に対応(yes/no).
+自分自身の発言は未対応.
+[default: no]
+

+
support-shared-webclient:no
@@ -587,6 +593,89 @@
+
+

Auto::Notify

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

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

+
mask:* *!*@*
+

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

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

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

+
keyword:hoge
+

+メッセージのフォーマットを指定します。
+デフォルト値: [tiarra][#(channel):#(nick.now)] #(text)
+#(channel) のかわりに #(raw_channel) を利用するとネットワーク名がつきません。
+

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

+使用するブロックを指定します
+

+
blocks:im prowl
+
im +
+

+通知先のタイプを指定します。
+

+
type:im_kayac
+

+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
+
+
prowl +
+

+通知先のタイプを指定します。
+

+
type:prowl
+

+通知先ごとにフォーマットを指定できます。
+この例では先頭に時刻を追加しています。
+

+
format:#(date:%H:%M:%S) [#(channel):#(nick.now)] #(text)
+

+Prowl で表示された apikey を入力します。
+Prowl については http://prowl.weks.net/ を参考にしてください。
+

+
apikey:XXXXXX
+

+http://forums.cocoaforge.com/viewtopic.php?f=45&t=20339
+

+
priority:0
+
application:tiarra
+
event:keyword
+
+ +
+
+ + +
+ +

Auto::Oper

特定の文字列を発言した人を+oする。
@@ -1002,6 +1091,8 @@
  • Auto::MesMail
    • +
  • Auto::Notify
    • +
  • Auto::Oper
  • Auto::Outputz
    • diff -urN tiarra-20090206/doc/module/System.html tiarra-20091019/doc/module/System.html --- tiarra-20090206/doc/module/System.html 2009-02-09 22:30:12.000000000 +0900 +++ tiarra-20091019/doc/module/System.html 2009-10-19 01:19:35.000000000 +0900 @@ -338,7 +338,7 @@
    allow-public
    host:*
    -
    auth:user2 pass2
    +
    auth::basic user2 pass2
    mask:#公開チャンネル@ircnet

    diff -urN tiarra-20090206/doc/module/UNCLASSIFIED.html tiarra-20091019/doc/module/UNCLASSIFIED.html --- tiarra-20090206/doc/module/UNCLASSIFIED.html 2009-02-09 22:30:12.000000000 +0900 +++ tiarra-20091019/doc/module/UNCLASSIFIED.html 2009-10-19 01:19:35.000000000 +0900 @@ -18,8 +18,8 @@

    -
    -

    Skelton

    +
    +

    Skeleton

    Skeleton for tiarra-module.

    @@ -43,7 +43,7 @@

    diff -urN tiarra-20090206/doc/module-toc.html tiarra-20091019/doc/module-toc.html --- tiarra-20090206/doc/module-toc.html 2009-02-09 22:30:12.000000000 +0900 +++ tiarra-20091019/doc/module-toc.html 2009-10-19 01:19:35.000000000 +0900 @@ -19,7 +19,7 @@ UNCLASSIFIED 未分類のモジュール
      -
    • Skelton Skeleton for tiarra-module.
      • +
    • Skeleton Skeleton for tiarra-module.
    @@ -48,6 +48,8 @@
  • Auto::MesMail 伝言をメールとして送信する。
    • +
  • Auto::Notify 名前が呼ばれると、その発言をim.kayac.comに送信する
    • +
  • Auto::Oper 特定の文字列を発言した人を+oする。
  • Auto::Outputz チャンネルの発言文字数を outputz に送信する
    • diff -urN tiarra-20090206/doc-src/conf-main.tdoc tiarra-20091019/doc-src/conf-main.tdoc --- tiarra-20090206/doc-src/conf-main.tdoc 2009-02-09 22:30:11.000000000 +0900 +++ tiarra-20091019/doc-src/conf-main.tdoc 2009-10-19 01:19:34.000000000 +0900 @@ -1,5 +1,5 @@ -*- outline -*- -$Id: conf-main.tdoc 15771 2008-07-13 23:55:21Z drry $ +$Id: conf-main.tdoc 34672 2009-07-29 03:18:07Z drry $ perlのソースに使うpodパーサを流用しているので、package文と=pod〜=cutで書く必要があります。 ヘッダのinfo-is-ommitedとno-switchはどちらも値を真に定義しなければなりません。 @@ -12,7 +12,7 @@ no-switch: 1 # tiarra.conf自身の文字コード -# コード名はjis,sjis,euc,utf8,utf16,utf32等。(この値はUnicode::Japaneseにそのまま渡されます) +# コード名はjis,sjis,euc,utf8,utf16,utf32等。(この値はEncodeまたはUnicode::Japaneseにそのまま渡されます) # autoが指定された、または省略された場合は自動判別します。 conf-encoding: utf8 @@ -57,13 +57,13 @@ # そのような場合にもこの機能は無効となる。 -control-socket-name: test -# IRCサーバーから送られる文字のコードと、IRCサーバーへ送る文字のコード -# どちらも省略された場合はjis。 +# IRCサーバーから送られる文字のコードと、IRCサーバーへ送る文字のコード。 +# それぞれ省略された場合はjis。 server-in-encoding: jis server-out-encoding: jis -# クライアントから受け取る文字のコードと、クライアントへ伝える文字のコード -# どちらも省略された場合はjis。 +# クライアントから受け取る文字のコードと、クライアントへ伝える文字のコード。 +# それぞれ省略された場合はjis。 client-in-encoding: jis client-out-encoding: jis @@ -92,7 +92,7 @@ # mask: ++{example3}@ircnet,-+{example4}@2ch +*!*@*.example.com # +で始まるチャンネル。 # mask: * -*!*@* #----------------- -# となります。 この二つはまったく同じマスクを表しています。 +# となります。この二つはまったく同じマスクを表しています。 # この値をplumにすると、plum形式、省略するかtiarraを指定すると、Tiarra形式になります。 chanmask-mode: tiarra @@ -195,7 +195,7 @@ # 3. "message-for-each"の場合は、切断されるとクライアントに宛ててTiarraが # 到達不能になった全てのチャンネルにNOTICEでその旨を報告する。 # 再接続に成功すると再びNOTICEで報告する。JOINやPARTはしない。 -# デフォルトはpart-and-joinです。 +# 省略時のデフォルトはpart-and-joinです。 action-when-disconnected: message-for-each # NICKを変更する度に、変更したサーバーでの新しいNICKをNOTICEで常に通知するかどうか。 diff -urN tiarra-20090206/main/Configuration/Preprocessor.pm tiarra-20091019/main/Configuration/Preprocessor.pm --- tiarra-20090206/main/Configuration/Preprocessor.pm 2009-02-09 22:30:09.000000000 +0900 +++ tiarra-20091019/main/Configuration/Preprocessor.pm 2009-10-19 01:19:33.000000000 +0900 @@ -1,5 +1,5 @@ # ----------------------------------------------------------------------------- -# $Id: Preprocessor.pm 24347 2008-11-19 14:45:12Z topia $ +# $Id: Preprocessor.pm 33115 2009-05-06 17:55:44Z topia $ # ----------------------------------------------------------------------------- # tiarraのconfファイルのプリプロセッサです。 # このクラスは次のような機能を持ちます。 @@ -206,11 +206,8 @@ $line =~ s/^\s*\@\s*|\s*$//g; # ifdefとifndefはif文に書換える - if ($line =~ m/^(els)?ifdef\s+(.+)$/) { - $line = $1.q{if $this->defined_p(q@}.$2.q{@)}; - } - elsif ($line =~ m/^(els)?ifndef\s+(.+)$/) { - $line = $1.q{if !$this->defined_p(q@}.$2.q{@)}; + if ($line =~ m/^(els|)if(n)?def\s+(.+)$/) { + $line = $1.q{if }.($2?'!':'').q{$this->defined_p(q@}.$3.q{@)}; } if ($line =~ m/^include\s+(.+)$/) { diff -urN tiarra-20090206/main/Module.pm tiarra-20091019/main/Module.pm --- tiarra-20090206/main/Module.pm 2009-02-09 22:30:10.000000000 +0900 +++ tiarra-20091019/main/Module.pm 2009-10-19 01:19:33.000000000 +0900 @@ -1,5 +1,5 @@ # ----------------------------------------------------------------------------- -# $Id: Module.pm 13831 2008-06-13 14:01:33Z topia $ +# $Id: Module.pm 31258 2009-03-15 12:58:10Z topia $ # ----------------------------------------------------------------------------- # Tiarraモジュール(プラグイン)を表わす抽象クラスです。 # 全てのTiarraモジュールはこのクラスを継承し、 @@ -19,7 +19,7 @@ sub new { my ($class, $runloop) = @_; if (!defined $runloop) { - carp 'please update module constructor; see Skelton.pm'; + carp 'please update module constructor; see Skeleton.pm'; $runloop = RunLoop->shared; } # モジュールが必要になった時に呼ばれる。 diff -urN tiarra-20090206/main/Multicast.pm tiarra-20091019/main/Multicast.pm --- tiarra-20090206/main/Multicast.pm 2009-02-09 22:30:10.000000000 +0900 +++ tiarra-20091019/main/Multicast.pm 2009-10-19 01:19:33.000000000 +0900 @@ -1,5 +1,5 @@ # ----------------------------------------------------------------------------- -# $Id: Multicast.pm 13084 2008-06-02 13:56:48Z hio $ +# $Id: Multicast.pm 33534 2009-05-23 16:28:57Z topia $ # ----------------------------------------------------------------------------- # サーバーからクライアントにメッセージが流れるとき、このクラスはフィルタとして # ネットワーク名を付加します。 @@ -305,12 +305,18 @@ sub _detach_RPL_WHOISCHANNELS { my ($message,$sender) = @_; + my $to; + my $detach = sub { + my ($ret,$net) = detach(shift); + $to = $net; + return $ret; + }; $message->params->[2] = join(' ', map { - s/^([\@+]*)(.+)$/$1.detach($2)/e; $_; + s/^([\@+]*)(.+)$/$1.$detach->($2)/e; $_; } split / /,$message->params->[2]); - $message; + forward_to_server($message,$to); } my $g2l_cache = {}; @@ -348,10 +354,11 @@ if (!exists $detach_cache->{$index}) { $detach_cache->{$index} = sub { my ($message, $sender) = @_; + my ($new,$to) = detach($message->param($index)); $message->param( $index, - detach($message->param($index))); - forward_to_server($message, $sender); + $new); + forward_to_server($message, $to); }; } $detach_cache->{$index}; @@ -392,7 +399,10 @@ qw(LIST CHANNELMODEIS NOTOPIC TOPIC TOPICWHOTIME), qw(CREATIONTIME))), ((map {"ERR_$_"} - (qw(TOOMANYCHANNELS NOTONCHANNEL NOSUCHCHANNEL UNAVAILRESOURCE)))))}, + (qw(TOOMANYCHANNELS NOTONCHANNEL NOSUCHCHANNEL UNAVAILRESOURCE), + qw(CHANOPRIVSNEEDED BANLISTFULL NOCHANMODES BADCHANMASK), + qw(BADCHANNELKEY BANNEDFROMCHAN INVITEONLYCHAN CHANNELISFULL), + qw(CANNOTSENDTOCHAN)))))}, do { no strict 'refs'; map { @@ -468,7 +478,10 @@ qw(LIST CHANNELMODEIS NOTOPIC TOPIC TOPICWHOTIME), qw(CREATIONTIME INVITING UNIQOPIS WHOREPLY))), (map {"ERR_$_"} - (qw(TOOMANYCHANNELS NOTONCHANNEL NOSUCHCHANNEL UNAVAILRESOURCE))))}, + (qw(TOOMANYCHANNELS NOTONCHANNEL NOSUCHCHANNEL UNAVAILRESOURCE), + qw(CHANOPRIVSNEEDED BANLISTFULL NOCHANMODES BADCHANMASK), + qw(BADCHANNELKEY BANNEDFROMCHAN INVITEONLYCHAN CHANNELISFULL), + qw(CANNOTSENDTOCHAN))))}, do { no strict 'refs'; map { diff -urN tiarra-20090206/main/Template.pm tiarra-20091019/main/Template.pm --- tiarra-20090206/main/Template.pm 2009-02-09 22:30:10.000000000 +0900 +++ tiarra-20091019/main/Template.pm 2009-10-19 01:19:33.000000000 +0900 @@ -1,5 +1,5 @@ # ----------------------------------------------------------------------------- -# $Id: Template.pm 11365 2008-05-10 14:58:28Z topia $ +# $Id: Template.pm 34672 2009-07-29 03:18:07Z drry $ # ----------------------------------------------------------------------------- package Template; use strict; @@ -123,9 +123,9 @@ my $result = $this->{current}; # 未置換の<&foo>があればそれを消してcarp。 - while ($result =~ s/<\&(.+?)>//) { - carp "Unexpanded tag: <\&$1>"; - } + #while ($result =~ s/<\&(.+?)>//) { + # carp "Unexpanded tag: <\&$1>"; + #} # を消す。 $result =~ s///g; diff -urN tiarra-20090206/main/Tiarra/OptionalModules.pm tiarra-20091019/main/Tiarra/OptionalModules.pm --- tiarra-20090206/main/Tiarra/OptionalModules.pm 2009-02-09 22:30:09.000000000 +0900 +++ tiarra-20091019/main/Tiarra/OptionalModules.pm 2009-10-19 01:19:33.000000000 +0900 @@ -1,5 +1,5 @@ # ----------------------------------------------------------------------------- -# $Id: OptionalModules.pm 13829 2008-06-13 13:43:03Z topia $ +# $Id: OptionalModules.pm 31557 2009-03-25 13:32:21Z topia $ # ----------------------------------------------------------------------------- # Optional Modules Loader # ----------------------------------------------------------------------------- @@ -108,6 +108,10 @@ return $this->{$name}->{status} if defined $this->{$name}; die "module $name spec. not found" unless defined $modules{$name}; + if ($ENV{"TIARRA_DISABLE_\U$name\E"}) { + $this->{$name}->{status} = !1; + return !1; + } my $failed; for my $mod (@{$modules{$name}->{requires}}) { diff -urN tiarra-20090206/main/Tiarra/Resolver.pm tiarra-20091019/main/Tiarra/Resolver.pm --- tiarra-20090206/main/Tiarra/Resolver.pm 2009-02-09 22:30:09.000000000 +0900 +++ tiarra-20091019/main/Tiarra/Resolver.pm 2009-10-19 01:19:33.000000000 +0900 @@ -1,5 +1,5 @@ # ----------------------------------------------------------------------------- -# $Id: Resolver.pm 12926 2008-05-31 14:42:57Z hio $ +# $Id: Resolver.pm 35566 2009-10-09 14:53:58Z topia $ # ----------------------------------------------------------------------------- # Simple Resolver with multi-thread or blocking. # ----------------------------------------------------------------------------- @@ -90,11 +90,8 @@ __PACKAGE__->shared; } -sub _new { - my $class = shift; - - my $this = {}; - bless $this, $class; +sub init { + my $this = shift; if ($use_threads) { $this->{ask_queue} = Thread::Queue->new; @@ -121,6 +118,14 @@ $this; } +sub _new { + my $class = shift; + + my $this = {}; + bless $this, $class; + $this->init; +} + sub _check_thread { my $this = shift; @@ -143,7 +148,12 @@ sub destruct { my $this = shift; + my $before_fork = shift; + if (!$before_fork && defined $this->{destructor}) { + $this->{destructor}->uninstall; + $this->{destructor} = undef; + } $this->{ask_queue}->enqueue(undef); $this->{thread}->join; $this->mainloop; diff -urN tiarra-20090206/main/Tiarra/Socket/Connect.pm tiarra-20091019/main/Tiarra/Socket/Connect.pm --- tiarra-20090206/main/Tiarra/Socket/Connect.pm 2009-02-09 22:30:09.000000000 +0900 +++ tiarra-20091019/main/Tiarra/Socket/Connect.pm 2009-10-19 01:19:33.000000000 +0900 @@ -1,5 +1,5 @@ # ----------------------------------------------------------------------------- -# $Id: Connect.pm 11479 2008-05-12 17:41:48Z topia $ +# $Id: Connect.pm 33938 2009-06-13 08:20:02Z topia $ # ----------------------------------------------------------------------------- # Socket Connector # ----------------------------------------------------------------------------- @@ -8,6 +8,7 @@ use strict; use warnings; use Carp; +use List::Util qw(shuffle); use Tiarra::Socket; use base qw(Tiarra::Socket); use Timer; @@ -196,7 +197,7 @@ return undef; # end } - foreach my $addr (@{$entry->answer_data}) { + foreach my $addr (shuffle @{$entry->answer_data}) { push (@{$addrs_by_types{$this->probe_type_by_addr($addr)}}, $addr); } diff -urN tiarra-20090206/main/Tiarra/TerminateManager.pm tiarra-20091019/main/Tiarra/TerminateManager.pm --- tiarra-20090206/main/Tiarra/TerminateManager.pm 2009-02-09 22:30:09.000000000 +0900 +++ tiarra-20091019/main/Tiarra/TerminateManager.pm 2009-10-19 01:19:33.000000000 +0900 @@ -1,5 +1,5 @@ # ----------------------------------------------------------------------------- -# $Id: TerminateManager.pm 3004 2007-12-10 12:45:39Z topia $ +# $Id: TerminateManager.pm 35566 2009-10-09 14:53:58Z topia $ # ----------------------------------------------------------------------------- # Terminate Hook for write Portable Module # ----------------------------------------------------------------------------- @@ -32,7 +32,7 @@ use Hook; use base qw(Hook); our $HOOK_TARGET_NAME = 'Tiarra::TerminateManager'; -our @HOOK_NAME_CANDIDATES = qw(main); +our @HOOK_NAME_CANDIDATES = qw(main forked); our $HOOK_NAME_DEFAULT = 'main'; our $HOOK_TARGET_DEFAULT; FunctionalVariable::tie( diff -urN tiarra-20090206/module/Auto/Calc.pm tiarra-20091019/module/Auto/Calc.pm --- tiarra-20090206/module/Auto/Calc.pm 2009-02-09 22:30:10.000000000 +0900 +++ tiarra-20091019/module/Auto/Calc.pm 2009-10-19 01:19:33.000000000 +0900 @@ -1,6 +1,6 @@ # -*- cperl -*- # ----------------------------------------------------------------------------- -# $Id: Calc.pm 11365 2008-05-10 14:58:28Z topia $ +# $Id: Calc.pm 32571 2009-04-18 04:59:26Z hio $ # ----------------------------------------------------------------------------- # copyright (C) 2003-2004 Topia . all rights reserved. package Auto::Calc::Share; @@ -24,6 +24,9 @@ use Symbol (); use Safe; +# 全角空白. +our $U_IDEOGRAPHIC_SPACE = "\xe3\x80\x80"; + sub new { my $class = shift; my $this = $class->SUPER::new(@_); @@ -48,8 +51,32 @@ Symbol::delete_package(__PACKAGE__.'::Root') } +sub __message_io_hook +{ + my ($this,$msg,$io,$type) = @_; + # 自分のWebClient からも使いたいけれど, どうもうまくいかない模様. + + # print "io_hook: $io $type ",$msg->command," ", $msg->param(1)," $msg\n"; + if( $type eq 'out' && $io->isa('IrcIO::Server') ) + { + # print ">> action\n"; + my @ret = $this->_action($msg, $io); + # print "ret: ".join(", ", @ret)."\n"; + return @ret; + } + return $msg; +} + sub message_arrived { my ($this,$msg,$sender) = @_; + # print "arrived: $sender - ",$msg->command," ", $msg->param(1),"\n"; + # print ">> action\n"; + $this->_action($msg, $sender); +} + +sub _action +{ + my ($this, $msg, $sender) = @_; my @result = ($msg); my $return_value = sub { @@ -63,6 +90,15 @@ my $method = $msg->param(1); $method =~ s/^\s*(.*)\s*$/$1/; + if( my $val = $this->config->support_shared_webclient ) + { + # no や false は除外的. + if( $val !~ /^[nf]/i ) + { + $method =~ s/^[^\s>]+>\s*//; + } + } + # init if (Mask::match_deep([$this->config->init('all')], $method)) { if (Mask::match_deep_chan([$this->config->init_mask('all')], @@ -74,12 +110,13 @@ } my $keyword; - ($keyword, $method) = split(/\s+/, $method, 2); + ($keyword, $method) = split(/(?:\s|$U_IDEOGRAPHIC_SPACE)+/o, $method, 2); # request if (Mask::match_deep([$this->config->request('all')], $keyword)) { + my $prefix = $msg->prefix->clone->prefix || '*!*@*'; if (Mask::match_deep_chan([$this->config->mask('all')], - $msg->prefix, $get_full_ch_name->())) { + $prefix, $get_full_ch_name->())) { my ($ret, $err, $signal); do { # disable warning @@ -106,6 +143,7 @@ alarm $timeout if ($timeout); no strict; $ret = $this->{safe}->reval($method); + $err ||= $@; alarm 0 if ($timeout); }; @@ -180,6 +218,7 @@ } 1; + =pod info: Perlの式を計算させるモジュール。 default: off @@ -236,4 +275,9 @@ # 再初期化したときの発言を指定します。 init-format: 初期化しました。 +# 別の shared-mode な System::WebClient からの発言に対応(yes/no). +# 自分自身の発言は未対応. +# [default: no] +-support-shared-webclient: no + =cut diff -urN tiarra-20090206/module/Auto/FetchTitle/Plugin/ExtractHeading.pm tiarra-20091019/module/Auto/FetchTitle/Plugin/ExtractHeading.pm --- tiarra-20090206/module/Auto/FetchTitle/Plugin/ExtractHeading.pm 2009-02-09 22:30:10.000000000 +0900 +++ tiarra-20091019/module/Auto/FetchTitle/Plugin/ExtractHeading.pm 2009-10-19 01:19:33.000000000 +0900 @@ -5,7 +5,7 @@ # # Copyright 2008 YAMASHINA Hio # ----------------------------------------------------------------------------- -# $Id: ExtractHeading.pm 22785 2008-11-05 13:45:32Z hio $ +# $Id: ExtractHeading.pm 32570 2009-04-18 04:57:59Z hio $ # ----------------------------------------------------------------------------- package Auto::FetchTitle::Plugin::ExtractHeading; use strict; @@ -165,21 +165,22 @@ }, { # 3a. nikkei. - url => 'http://www.nikkei.co.jp/*', + url => 'http://release.nikkei.co.jp/*', + recv_limit => 18*1024, + extract => qr{

    (.*)

    }s, + }, + { + # 3b. nikkei. + url => 'http://*.nikkei.co.jp/*', recv_limit => 16*1024, extract => [ - qr{}s, - qr{

    (.*?)

    }s, + qr{}is, + qr{

    (.*?)

    }is, + qr{

    (.*?)

    }is, ], remove => qr/^NIKKEI NET：/, }, { - # 3b. nikkei. - url => 'http://release.nikkei.co.jp/*', - recv_limit => 18*1024, - extract => qr{

    (.*)

    }s, - }, - { # 4a. nhkニュース. url => 'http://www*.nhk.or.jp/news/*', extract => qr{

    (.*?)

    }, @@ -476,6 +477,13 @@ "$point, $compat"; }, }, + { + # 31. candyfruit. + url => 'http://www.wisecart.ne.jp/candyfruit/*', + extract => qr{(.*?)}s, + recv_limit => 50*1024, + timeout => 10, + }, ]; $config; } diff -urN tiarra-20090206/module/Auto/FetchTitle/Plugin/Mixi.pm tiarra-20091019/module/Auto/FetchTitle/Plugin/Mixi.pm --- tiarra-20090206/module/Auto/FetchTitle/Plugin/Mixi.pm 2009-02-09 22:30:10.000000000 +0900 +++ tiarra-20091019/module/Auto/FetchTitle/Plugin/Mixi.pm 2009-10-19 01:19:33.000000000 +0900 @@ -5,7 +5,7 @@ # # Copyright 2008 YAMASHINA Hio # ----------------------------------------------------------------------------- -# $Id: Mixi.pm 24729 2008-11-24 07:01:17Z hio $ +# $Id: Mixi.pm 31645 2009-03-28 14:40:50Z hio $ # ----------------------------------------------------------------------------- package Auto::FetchTitle::Plugin::Mixi; use strict; @@ -202,6 +202,28 @@ re => qr{^http://mixi\.jp/show_friend.pl\?id=(\d+)\z}, keys => ['friend'], }, + + # album. + { + name => 'friend-album-list', + can_show => 1, + re => qr{^http://mixi.jp/list_album.pl\?id=(\d+)(?:&from=navi)?\z}, + keys => ['friend'], + }, + { + name => 'friend-album-photolist', + can_show => 1, + re => qr{^http://mixi.jp/view_album.pl\?id=(\d+)&owner_id=(\d+)&mode=(?:photo|comment)\z}, + keys => ['-albumid', 'friend'], + }, + { + name => 'friend-album-photo', + can_show => 1, + re => qr{^http://mixi.jp/view_album_photo.pl\?album_id=(\d+)&owner_id=(\d+)&number=(\d+)(?:&page=(\d+))?\z}, + keys => ['-albumid', 'friend', '-photoid', '-page'], + }, + + # obsolete? { name => 'friend-list-diary/album/review/comment', can_show => 1, @@ -249,6 +271,7 @@ { my $key = $keys->[$idx]; $key or next; + $key =~ /^\w/ or next; my $val = $values->[$idx]; my $conf_key = "mixi_$key"; my $allowed; diff -urN tiarra-20090206/module/Auto/Im.pm tiarra-20091019/module/Auto/Im.pm --- tiarra-20090206/module/Auto/Im.pm 2009-02-09 22:30:10.000000000 +0900 +++ tiarra-20091019/module/Auto/Im.pm 2009-10-19 01:19:33.000000000 +0900 @@ -1,5 +1,5 @@ # ----------------------------------------------------------------------------- -# $Id: Im.pm 28633 2009-01-18 19:49:53Z takano32 $ +# $Id: Im.pm 35621 2009-10-16 11:28:45Z topia $ # ----------------------------------------------------------------------------- package Auto::Im; use strict; @@ -78,9 +78,14 @@ )->start( Callback => sub { my $stat = shift; - $runloop->notify_warn(__PACKAGE__." post failed: $stat") - unless ref($stat); - ## FIXME: check response (should check 'error') + if (!ref($stat)) { + $runloop->notify_warn(__PACKAGE__." post failed: $stat"); + } elsif ($stat->{Content} !~ /"result":\s*"(ok|posted)"/) { + # http://im.kayac.com/#docs + # (but actually responce is '"result": "ok"') + (my $content = $stat->{Content}) =~ s/[\n\r\s]+/ /; + $runloop->notify_warn(__PACKAGE__." post failed: $content"); + } }, ); } diff -urN tiarra-20090206/module/Auto/Notify.pm tiarra-20091019/module/Auto/Notify.pm --- tiarra-20090206/module/Auto/Notify.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20091019/module/Auto/Notify.pm 2009-10-19 01:19:33.000000000 +0900 @@ -0,0 +1,267 @@ +# ----------------------------------------------------------------------------- +# $Id: Notify.pm 35621 2009-10-16 11:28:45Z topia $ +# ----------------------------------------------------------------------------- +package Auto::Notify; +use strict; +use warnings; +use base qw(Module); +use Module::Use qw(Auto::AliasDB Tools::HTTPClient Auto::Utils); +use Auto::AliasDB; +use Tools::HTTPClient; # >= r11345 +use Auto::Utils; +use HTTP::Request::Common; + +sub new { + my ($class) = shift; + my $this = $class->SUPER::new(@_); + + $this->config_reload(undef); + + return $this; +} + +sub config_reload { + my ($this, $old_config) = @_; + + 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($@); + } + + $this->{blocks} = []; + foreach my $blockname (map {split /\s+/} $this->config->blocks('all')) { + my $block = $this->config->get($blockname, 'block'); + if (!defined $block) { + die "not found block: $blockname"; + } + my $type = $block->type; + if (!defined $type) { + die "type definition not found in block"; + } + my $meth = $this->can('config_'.$type); + if (!defined $meth) { + die "unknown type: $type"; + } + $this->$meth($block); + push(@{$this->{blocks}}, $block); + } + + 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( + [Mask::array_or_all_chan($this->config->mask('all'))], + $msg->prefix,$full_ch_name)) { + + foreach my $block (@{$this->{blocks}}) { + my $type = $block->type; + my $meth = $this->can('send_'.$type); + eval { + $this->$meth($block, $text, $msg, $sender, $full_ch_name); + }; if ($@) { + $this->_runloop->notify_warn(__PACKAGE__." send failed: $@"); + } + } + + } + } + } + + return @result; +} + +sub strip_mirc_formatting { + my ($this, $text) = @_; + $text =~ s/(\x03\d\d?(,\d\d?)?|[\x0f\x02\x1f\x16])//g; + $text; +} + +sub config_im_kayac { + my ($this, $config) = @_; + + if ($config->secret) { + # signature required + require Digest::SHA; + } + + 1; +} + +sub send_im_kayac { + my ($this, $config, $text, $msg, $sender, $full_ch_name) = @_; + + my $url = "http://im.kayac.com/api/post/" . $config->user; + $text = Auto::AliasDB->stdreplace( + $msg->prefix, + $config->format || $this->config->format || '[tiarra][#(channel):#(nick.now)] #(text)', + $msg, $sender, + channel => $full_ch_name, + raw_channel => Auto::Utils::get_raw_ch_name($msg, 0), + text => $this->strip_mirc_formatting($text), + ); + my @data = (message => $text); + if ($config->secret) { + push(@data, sig => Digest::SHA->new(1) + ->add($text . $config->secret)->hexdigest); + } elsif ($config->password) { + push(@data, password => $config->password); + } + my $runloop = $this->_runloop; + Tools::HTTPClient->new( + Request => POST($url, \@data), + )->start( + Callback => sub { + my $stat = shift; + if (!ref($stat)) { + $runloop->notify_warn(__PACKAGE__." im.kayac.com: post failed: $stat"); + } elsif ($stat->{Content} !~ /"result":\s*"(ok|posted)"/) { + # http://im.kayac.com/#docs + # (but actually responce is '"result": "ok"') + (my $content = $stat->{Content}) =~ s/[\n\r\s]+/ /; + $runloop->notify_warn(__PACKAGE__." im.kayac.com: post failed: $content"); + } + }, + ); +} + + +sub config_prowl { + my ($this, $config) = @_; + + require Crypt::SSLeay; # https support + require URI; + + my $url = URI->new("https://prowl.weks.net/publicapi/verify"); + $url->query_form(apikey => $config->apikey); + my $runloop = $this->_runloop; + Tools::HTTPClient->new( + Request => GET($url->as_string()), + )->start( + Callback => sub { + my $stat = shift; + $runloop->notify_warn(__PACKAGE__." verify failed: $stat") + unless ref($stat); + ## FIXME: check response (should check 'error') + }, + ); +} + +sub send_prowl { + my ($this, $config, $text, $msg, $sender, $full_ch_name) = @_; + + my $url = URI->new("https://prowl.weks.net/publicapi/add"); + $text = Auto::AliasDB->stdreplace( + $msg->prefix, + $config->format || $this->config->format || '[tiarra][#(channel):#(nick.now)] #(text)', + $msg, $sender, + channel => $full_ch_name, + raw_channel => Auto::Utils::get_raw_ch_name($msg, 0), + text => $this->strip_mirc_formatting($text), + ); + my @data = (apikey => $config->apikey, + priority => $config->priority || 0, + application => $config->application || 'tiarra', + event => $config->event || 'keyword', + description => $text); + $url->query_form(@data); + + my $runloop = $this->_runloop; + Tools::HTTPClient->new( + Request => GET($url->as_string()), + )->start( + Callback => sub { + my $stat = shift; + if (!ref($stat)) { + $runloop->notify_warn(__PACKAGE__." prowl: post failed: $stat"); + } elsif ($stat->{Content} !~ /{Content}) =~ s/[\n\r\s]+/ /; + $runloop->notify_warn(__PACKAGE__." prowl: post failed: $content"); + } + }, + ); +} + +1; + +=pod +info: 名前が呼ばれると、その発言をim.kayac.comに送信する +default: off + +# 反応する人のマスクを指定します。 +# 省略すると全員に反応します。 +mask: * *!*@* + +# 反応するキーワードを正規表現で指定します。 +# 複数指定したい時は複数行指定してください。 +-regex-keyword: (?i:fugahoge) + +# 反応するキーワードを指定します。 +# 複数指定したい時は,(コンマ)で区切るか、複数行指定してください。 +keyword: hoge + +# メッセージのフォーマットを指定します。 +# デフォルト値: [tiarra][#(channel):#(nick.now)] #(text) +# #(channel) のかわりに #(raw_channel) を利用するとネットワーク名がつきません。 +format: [tiarra][#(channel):#(nick.now)] #(text) + +# 使用するブロックを指定します +-blocks: im prowl + +im { + +# 通知先のタイプを指定します。 +type: im_kayac + +# 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 + +} + +prowl { + +# 通知先のタイプを指定します。 +type: prowl + +# 通知先ごとにフォーマットを指定できます。 +# この例では先頭に時刻を追加しています。 +-format: #(date:%H:%M:%S) [#(channel):#(nick.now)] #(text) + +# Prowl で表示された apikey を入力します。 +# Prowl については http://prowl.weks.net/ を参考にしてください。 +-apikey: XXXXXX + +# http://forums.cocoaforge.com/viewtopic.php?f=45&t=20339 +priority: 0 +application: tiarra +event: keyword + +} + + +=cut diff -urN tiarra-20090206/module/Channel/Rejoin.pm tiarra-20091019/module/Channel/Rejoin.pm --- tiarra-20090206/module/Channel/Rejoin.pm 2009-02-09 22:30:10.000000000 +0900 +++ tiarra-20091019/module/Channel/Rejoin.pm 2009-10-19 01:19:34.000000000 +0900 @@ -1,5 +1,5 @@ # ----------------------------------------------------------------------------- -# $Id: Rejoin.pm 11365 2008-05-10 14:58:28Z topia $ +# $Id: Rejoin.pm 33535 2009-05-23 17:28:58Z topia $ # ----------------------------------------------------------------------------- # このモジュールは動作時に掲示板のdo-not-touch-mode-of-channelsを使います。 # ----------------------------------------------------------------------------- @@ -27,6 +27,7 @@ # got_Ilist => +I(略 # got_oper => 既にPART->JOINしているかどうか。 # cmd_buf => ARRAY + # num_got_errors => このチャンネルのエラーをみた回数 $this; } @@ -37,7 +38,7 @@ my $cmd = $msg->command; if ($cmd eq 'PART') { foreach my $ch_fullname (split /,/,$msg->param(0)) { - $this->check_channel( + $this->check_and_rejoin_channel( scalar Multicast::detatch($ch_fullname), $sender); } @@ -45,14 +46,14 @@ elsif ($cmd eq 'KICK') { # RFC2812によると、複数のチャンネルを持つKICKメッセージが # クライアントに届く事は無い。 - $this->check_channel( + $this->check_and_rejoin_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->check_and_rejoin_channel($_,$sender); } } @@ -61,6 +62,13 @@ $msg; } +sub check_and_rejoin_channel { + my ($this,$ch_name,$server) = @_; + if ($this->check_channel($ch_name,$server)) { + $this->rejoin($ch_name,$server); + } +} + sub check_channel { my ($this,$ch_name,$server) = @_; if ($ch_name =~ m/^\+/) { @@ -86,7 +94,7 @@ # 自分が@を持っている。 return; } - $this->rejoin($ch_name,$server); + return 1; } sub rejoin { @@ -126,6 +134,7 @@ ch => $ch, server => $server, cmd_buf => [], + num_got_errors => 0, }; # do-not-touch-mode-of-channelsを取得 @@ -166,6 +175,9 @@ Command => 'MODE', Params => [$ch_name,$_])); } + $session->{got_elist} = + $session->{got_blist} = + $session->{got_Ilist} = 0; } else { $session->{got_elist} = @@ -184,6 +196,16 @@ sub part_and_join { my ($this,$session) = @_; $session->{got_oper} = 1; + if (!$this->check_channel($session->{ch_shortname}, $session->{server})) { + # 情報を取得している間に状況が変化した + RunLoop->shared->notify_msg( + "Channel::Rejoin is cancelled to rejoin to $session->{ch_fullname}."); + # part/join をやめたので発行すべきコマンドはない。 + $session->{cmd_buf} = []; + # フラグ類のクリーンアップを行う + $this->revive($session); + return; + } foreach (qw/PART JOIN/) { $session->{server}->send_message( $this->construct_irc_message( @@ -231,7 +253,7 @@ } } }; - + if ($msg->command eq RPL_CHANNELMODEIS) { # MODEリプライ $session = $this->{sessions}->{$msg->param(1)}; @@ -271,11 +293,18 @@ $this->revive($session); } } + elsif ($msg->command eq ERR_CHANOPRIVSNEEDED) { + $session = $this->{sessions}->{$msg->param(1)}; + if (defined $session) { + $session->{num_got_errors}++; + } + } # $sessionが空でなければ、必要な情報が全て揃った可能性がある。 if (defined $session && !$session->{got_oper} && - $session->{got_mode} && $session->{got_blist} && - $session->{got_elist} && $session->{got_Ilist}) { + $session->{got_mode} && ($session->{got_blist} + + $session->{got_elist} + $session->{got_Ilist} + + $session->{num_got_errors}) >= 3) { $this->part_and_join($session); } } diff -urN tiarra-20090206/module/Log/Logger.pm tiarra-20091019/module/Log/Logger.pm --- tiarra-20090206/module/Log/Logger.pm 2009-02-09 22:30:10.000000000 +0900 +++ tiarra-20091019/module/Log/Logger.pm 2009-10-19 01:19:34.000000000 +0900 @@ -1,5 +1,5 @@ # ----------------------------------------------------------------------------- -# $Id: Logger.pm 11365 2008-05-10 14:58:28Z topia $ +# $Id: Logger.pm 31673 2009-03-29 12:24:29Z hio $ # ----------------------------------------------------------------------------- package Log::Logger; use strict; @@ -261,6 +261,9 @@ ch_short => $ch_short, netname => $netname, msg => $msg->param(1), + command => $msg->command(), + time => $msg->time(), + #msg_orig => $msg, formatted => $line, }; } diff -urN tiarra-20090206/module/Skeleton.pm tiarra-20091019/module/Skeleton.pm --- tiarra-20090206/module/Skeleton.pm 1970-01-01 09:00:00.000000000 +0900 +++ tiarra-20091019/module/Skeleton.pm 2009-10-19 01:19:34.000000000 +0900 @@ -0,0 +1,182 @@ +# ----------------------------------------------------------------------------- +# $Id: Skeleton.pm 31258 2009-03-15 12:58:10Z topia $ +# ----------------------------------------------------------------------------- +# モジュールのスケルトン。 +# ----------------------------------------------------------------------------- +package Skeleton; +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 config_reload { + my ($this, $old_config) = @_; + # モジュールの設定が変更された時に呼ばれる。 + # 新しい config は $this->config で取得できます。 + + # 定義されていない場合は destruct と new をそれぞれ呼ぶ。 + eval { + $this->destruct; + }; if ($@) { + $this->_runloop->notify_error( + "Couldn't destruct module on reload config of " . ref($this) + . ".\n$@"); + } + return ref($this)->new($this->_runloop); +} + +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: Skeleton for tiarra-module. +default: off +#section: important + +# モジュールの説明をこのあたりに書く. +# 詳細はこのソースみれば分かると思われ. +# 書式は tiarra.conf にそのままコピーできる形式. + +# もにゅもにゅ +mask: *!*@* +mask: ... + +=end tiarra-doc + +=cut diff -urN tiarra-20090206/module/Skelton.pm tiarra-20091019/module/Skelton.pm --- tiarra-20090206/module/Skelton.pm 2009-02-09 22:30:11.000000000 +0900 +++ tiarra-20091019/module/Skelton.pm 1970-01-01 09:00:00.000000000 +0900 @@ -1,182 +0,0 @@ -# ----------------------------------------------------------------------------- -# $Id: Skelton.pm 29425 2009-02-02 06:17:32Z drry $ -# ----------------------------------------------------------------------------- -# モジュールのスケルトン。 -# ----------------------------------------------------------------------------- -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 config_reload { - my ($this, $old_config) = @_; - # モジュールの設定が変更された時に呼ばれる。 - # 新しい config は $this->config で取得できます。 - - # 定義されていない場合は destruct と new をそれぞれ呼ぶ。 - eval { - $this->destruct; - }; if ($@) { - $this->_runloop->notify_error( - "Couldn't destruct module on reload config of " . ref($this) - . ".\n$@"); - } - return ref($this)->new($this->_runloop); -} - -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: Skeleton for tiarra-module. -default: off -#section: important - -# モジュールの説明をこのあたりに書く. -# 詳細はこのソースみれば分かると思われ. -# 書式は tiarra.conf にそのままコピーできる形式. - -# もにゅもにゅ -mask: *!*@* -mask: ... - -=end tiarra-doc - -=cut diff -urN tiarra-20090206/module/System/WebClient.pm tiarra-20091019/module/System/WebClient.pm --- tiarra-20090206/module/System/WebClient.pm 2009-02-09 22:30:10.000000000 +0900 +++ tiarra-20091019/module/System/WebClient.pm 2009-10-19 01:19:34.000000000 +0900 @@ -5,7 +5,7 @@ # # Copyright 2008 YAMASHINA Hio # ----------------------------------------------------------------------------- -# $Id: WebClient.pm 20009 2008-09-27 02:20:10Z hio $ +# $Id: WebClient.pm 32465 2009-04-15 15:51:00Z hio $ # ----------------------------------------------------------------------------- package System::WebClient; use strict; @@ -23,7 +23,7 @@ use IO::Socket::INET; use Scalar::Util qw(weaken); -our $VERSION = '0.06'; +our $VERSION = '0.07'; our $DEBUG = 0; @@ -31,6 +31,7 @@ our $DEFAULT_SHOW_LINES = 20; our $DEFAULT_SITE_NAME = "Tiarra::WebClient"; our $DEFAULT_SESSION_EXPIRE = 7 * 24 * 60*60; +our $NO_TOPIC = '(no-topic)'; =begin COMMENT @@ -348,6 +349,7 @@ my $info = $this->{last_line}; #RunLoop->shared_loop->notify_msg(">> $channel $line"); + my $line_html; if( !$info ) { # PRIVMSG/NOTICE 以外. @@ -359,8 +361,11 @@ netname => $netname, ch_short => $ch_short, msg => $line, + command => $this->{last_msg}->command(), + time => $this->{last_msg}->time(), formatted => $line, }; + $line_html = $this->_escapeHTML($line); }else { # チャンネル名なしに整形し直し. @@ -371,11 +376,23 @@ $info->{marker}[1], $info->{msg}, ); + my $msg_html = $this->_escapeHTML($info->{msg}); + if( $info->{command} ? $info->{command} eq 'NOTICE' : $info->{marker}[0] eq '(' ) + { + $msg_html = qq{$msg_html}; + } + $line_html = sprintf( + '%s%s%s %s', + $this->_escapeHTML($info->{marker}[0]), + $this->_escapeHTML($info->{speaker}), + $this->_escapeHTML($info->{marker}[1]), + $msg_html, + ); }; my $netname = $info->{netname}; my $ch_short = $info->{ch_short}; - my @tm = localtime(time()); + my @tm = localtime($info->{time} || time()); $tm[5] += 1900; $tm[4] += 1; my $time = sprintf('%02d:%02d:%02d', @tm[2,1,0]); @@ -383,6 +400,7 @@ $info->{time} = $time; $info->{ymd} = sprintf('%04d-%02d-%02d', @tm[5,4,3]); $info->{formatted} = "$time $line"; + $info->{formatted_html} = "$time $line_html"; #RunLoop->shared_loop->notify_msg(__PACKAGE__."#_log_writer, $netname, $ch_short, [$channel] $line"); @@ -634,7 +652,22 @@ $this->_dispatch($req); }; } - $@ and $this->_debug("$peer: error: $@"); + if( my $err = $@ ) + { + eval{ + $this->_debug("$peer: error on _dispatch/_login: $err"); + my $cli = $req->{client}; + $cli->response(500); + #$DEBUG and $this->_debug( Tools::HTTPParser->to_string($res) ); + + # no Keep-Alive. + $cli->disconnect_after_writing(); + }; + if( $@ ) + { + $this->_debug("error on response: $@"); + } + } $DEBUG and $this->_debug("$peer: done"); } @@ -897,14 +930,14 @@ #TODO: carrier ip-addresses range. # http://www.au.kddi.com/ezfactory/tec/spec/ezsava_ip.html - my $subno = $req->{Header}{'X-UP-SUBNO'}; + my $subno = $req->{Header}{'X-UP-SUBNO'} || $req->{Header}{'X-Up-Subno'}; if( !_verify_value($param->[1], $subno) ) { defined($subno) or $subno = ''; $DEBUG and ::printmsg("$req->{peer}: $param->[0] pass $param->[1] does not match with '$subno' (subno)"); return; } - my $id = return "au:$subno"; + my $id = "au:$subno"; return +{ id => $id, atoken => $id, @@ -1092,6 +1125,22 @@ my $req = shift; my $path = $req->{path}; + my $mode = $this->_get_req_param($req, 'mode'); + if( $mode ne 'owner' ) + { + my $cgi = $this->_get_cgi_hash($req); + my $cgi_dump = join('&', map{ + my $key = $_; + my $val = $cgi->{$key}; + for($key, $val) + { + $_ =~ s/([%=\x00-\x1f])/'%'.pack("H*", $1)/ge; + } + "$key=$val"; + } sort keys %$cgi); + $this->_debug("$req->{peer}: _dispatch: mode=$mode, path=[$path], cgi=[$cgi_dump], method=$req->{Method}"); + } + if( $path eq '/' ) { my $done = $req->{Method} eq 'POST' && $this->_post_list($req); @@ -1273,6 +1322,11 @@ return undef; } +# $this->_response($req, [html => $html]). +# $this->_response($req, [error => $text]). +# $this->_response($req, [css => $css_text]). +# $this->_response($req, \%res). +# $this->_response($req, $retcode). sub _response { my $this = shift; @@ -1293,6 +1347,17 @@ }, Content => $html, }; + }elsif( $spec->[0] eq 'error' ) + { + my $text = "error: ".$spec->[1]; + $res = { + Code => 200, + Header => { + 'Content-Type' => 'text/plain; charset=utf-8', + 'Content-Length' => length($text), + }, + Content => $text, + }; }elsif( $spec->[0] eq 'css' ) { my $css = $spec->[1]; @@ -1349,7 +1414,7 @@ #$DEBUG and $this->_debug( Tools::HTTPParser->to_string($res) ); # no Keep-Alive. - $req->{client}->disconnect_after_writing(); + $cli->disconnect_after_writing(); return; } @@ -1401,6 +1466,8 @@ my $sid_enc = $this->_escapeHTML($req->{session}{_sid}); + if( defined($res->{Content}) ) + { $res->{Content} =~ s{(<.*?>)}{ my $tag = $1; if( $tag =~ /^{Header}{'Content-Length'} = length($res->{Content}); + } $res; } @@ -1592,11 +1660,17 @@ if( my $show = $this->_get_cgi_hash($req)->{show} ) { $show_all = $show eq 'all'; + }else + { + # default: owner=updated, shared=all + my $mode = $this->_get_req_param($req, 'mode'); + $show_all = $mode eq 'owner' ? undef : 1; } # 表示できるネットワーク＆チャンネルを抽出. # my %channels; + my $nr_channles_all = 0; foreach my $netname (keys %{$this->{cache}}) { foreach my $ch_short (keys %{$this->{cache}{$netname}}) @@ -1604,18 +1678,19 @@ my $ok = $this->_can_show($req, $ch_short, $netname); if( $ok ) { + ++ $nr_channles_all; my $cache = $this->{cache}{$netname}{$ch_short}; my $pack = { disp_netname => $netname, disp_ch_short => $ch_short, anchor => undef, - unseen => undef, - unseen_plus => undef, + unseen => undef, # nr lines. + unseen_plus => undef, # bool. }; my $recent = $cache->{recent} || []; my $seen = $req->{session}{seen}{$netname}{$ch_short} || 0; - my $nr_unseen = 0; + my $nr_unseen = 0; # lines. foreach my $r (reverse @$recent) { $r == $seen and last; @@ -1641,6 +1716,8 @@ } } # 別のTiarraさんのネットワークを解凍(設定があったとき). + # %channels に取り出したもの(表示チェック済み)から抽出. + # 抽出した分は%channelsからは除去(重複回避のために). my %new_channels; foreach my $extract_line ( $this->config->extract_network('all') ) { @@ -1692,23 +1769,7 @@ { my $channame = $pack->{disp_ch_short}; ++$seqno; - my $link_ch = $channame; - if( $link_ch =~ s/^#// ) - { - # normal channels. - }elsif( $link_ch =~ s/^![0-9A-Z]{5}/!/ ) - { - # channel = ( "#" / "+" / ( "!" channelid ) / "&" ) chanstring [ ":" chanstring ] - # channelid = 5( %x41-5A / digit ) ; 5( A-Z / 0-9 ) - # (RFC2812) - }else - { - $link_ch = "=$link_ch"; - } - my $link = "log\0$netname\0$link_ch\0"; - $link =~ s{/}{%252F}g; - $link =~ tr{\0}{/}; - $link = $this->_escapeHTML($link); + my $link = $this->_path_channel($req, $netname, $channame); my $unseen; if( !$pack->{unseen} ) @@ -1740,7 +1801,8 @@ } }else { - $content = $is_pc ? "
  • no channels
    • \n" : "no channels\n"; + my $msg = $nr_channles_all == 0 ? '表示できるチャンネルがありません' : '全て既読です'; + $content .= $is_pc ? "
  • $msg
    • \n" : "$msg\n"; } $content .= $is_pc ? "\n" : ""; @@ -1758,7 +1820,7 @@ my $tmpl = $this->_gen_list_html(); $this->_expand($req, $tmpl, { CONTENT => $content, - SHOW_TOGGLE_LABEL => $show_all ? 'MiniList' : 'ShowAll', + SHOW_TOGGLE_LABEL => $show_all ? '未読表示' : '全て表示', SHOW_TOGGLE_VALUE => $show_all ? 'updated' : 'all', SHARED_BOX => $shared_box, }); @@ -1785,8 +1847,8 @@ <&CONTENT>
    -ENTER: -
    +チャンネル: +

    @@ -1804,6 +1866,35 @@ HTML } +sub _path_channel +{ + my $this = shift; + my $req = shift; + my $netname = shift; + my $ch_short = shift; + + my $link_ch = $ch_short; + if( $link_ch =~ s/^#// ) + { + # normal channels. + }elsif( $link_ch =~ s/^![0-9A-Z]{5}/!/ ) + { + # channel = ( "#" / "+" / ( "!" channelid ) / "&" ) chanstring [ ":" chanstring ] + # channelid = 5( %x41-5A / digit ) ; 5( A-Z / 0-9 ) + # (RFC2812) + }else + { + $link_ch = "=$link_ch"; + } + + my $link = "log\0$netname\0$link_ch\0"; + $link =~ s{%}{%25}g; + $link =~ s{/}{%252F}g; + $link =~ s{([^\0\x20-\x7e])}{'%'.unpack('H*', $1)}ges; + $link =~ tr{\0}{/}; + $link; +} + sub _post_list { my $this = shift; @@ -1815,20 +1906,19 @@ my ($ch_short, $netname) = Multicast::detach($ch_long); if( !$this->_can_show($req, $ch_short, $netname) ) { + $this->_debug("$req->{peer} enter[$netname/$ch_short] not in allowed channels"); return; } my $network = $this->_runloop->network($netname); if( $network ) { $this->{cache}{$netname}{$ch_short} ||= $this->_new_cache_entry($netname, $ch_short); - $DEBUG and $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->_debug("$req->{peer}: enter[$netname/$ch_short]"); + my $link = '/' . $this->_path_channel($req, $netname, $ch_short); $this->_location($req, $link); - return 1; + }else + { + $this->_debug("$req->{peer} enter[$netname/$ch_short] no network"); } } return undef; @@ -1892,7 +1982,7 @@ { if( my $chan = $net->channel($ch_short) ) { - my $topic = $chan->topic || '(no-topic)'; + my $topic = $chan->topic || $NO_TOPIC; my $topic_esc = $this->_escapeHTML($topic); $content .= "

    \n"; $content .= "TOPIC: $topic_esc
    \n"; @@ -2032,7 +2122,7 @@ my $rtoken = $ymd; $content .= qq{[$ymd]\n}; } - my $line_html = $this->_escapeHTML($info->{formatted}); + my $line_html = $info->{formatted_html} || $this->_escapeHTML($info->{formatted}); if( $req->{ua_type} ne 'pc' ) { $line_html =~ s/^(\d\d:\d\d):\d\d /$1 /; @@ -2059,6 +2149,8 @@ my $ch_long = Multicast::attach($ch_short, $netname); $ch_long =~ s/^![0-9A-Z]{5}/!/; my $ch_long_esc = $this->_escapeHTML($ch_long); + my $join_mark = $this->_joined($req, $netname, $ch_short) ? '' : ' (退室)'; + my $name_esc = $this->_escapeHTML($req->{session}{name} || ''); my $mode = $this->_get_req_param($req, 'mode'); @@ -2068,20 +2160,26 @@ $name_marker_raw = qq{$name_esc> }; } + # channel name. my $h1_ch_long_raw; if( $req->{ua_type} eq 'pc' ) { - $h1_ch_long_raw = "

    $ch_long_esc

    "; + $h1_ch_long_raw = "

    $ch_long_esc$join_mark

    "; }else { - $h1_ch_long_raw = "$ch_long_esc"; + $h1_ch_long_raw = "$ch_long_esc$join_mark"; } my $tmpl = $this->_gen_log_html(); + my $joined_mark = $this->_joined($req, $netname, $ch_short) ? 'if_joined' : 'if_not_joined'; + $tmpl =~ s{\s*(.*?)\s*}{ + $1 eq $joined_mark ? $2 : ''; + }ges; $this->_expand($req, $tmpl, { CONTENT_RAW => $content, NAVI_RAW => $navi_raw, CH_LONG => $ch_long_esc, + JOIN_MARK => $join_mark, H1_CH_LONG_RAW => $h1_ch_long_raw, NAME => $name_esc, NAME_MARKER_RAW => $name_marker_raw, @@ -2102,7 +2200,7 @@ - <&CH_LONG> + <&CH_LONG><&JOIN_MARK>
    @@ -2112,13 +2210,25 @@ <&CONTENT_RAW> +

    talk:<&NAME_MARKER_RAW>
    - +
    +

    + + +
    +

    + +
    + +

    +
    + <&NAVI_RAW> @@ -2137,6 +2247,26 @@ HTML } +# $bool = $this->_joined($req, $netname, $ch_short). +sub _joined +{ + my $this = shift; + my $req = shift; + my $netname = shift; + my $ch_short = shift; + + my $network = RunLoop->shared_loop->network($netname); + if( $network ) + { + my $channel = $network->channel($ch_short); + if( $channel ) + { + return 1; + } + } + return undef; +} + sub _get_req_param { my $this = shift; @@ -2245,8 +2375,9 @@ my $channel = $network->channel($ch_short); if( $channel || !Multicast::channel_p($ch_short) ) { + my $as_notice = $cgi->{nt} ? 1 : 0; my $msg_to_send = Auto::Utils->construct_irc_message( - Command => 'PRIVMSG', + Command => $as_notice ? 'NOTICE' : 'PRIVMSG', Params => [ '', $m ], ); @@ -2268,12 +2399,75 @@ }else { RunLoop->shared_loop->notify_error("no such channel [$ch_short] on network [$netname]"); + my $text = "not joined: [$ch_short\@netname]"; + my $res = { + Code => 200, + Header => { + 'Content-Type' => 'text/plain; charset=utf-8', + 'Content-Length' => length($text), + }, + Content => $text, + }; + $this->_response($req, $res); + return 1; } }else { RunLoop->shared_loop->notify_error("no network to talk: $netname"); } } + if( my $ch_long = $cgi->{join} ) + { + my ($ch_short, $netname) = Multicast::detach($ch_long); + if( $this->_can_show($req, $ch_short, $netname) ) + { + $this->_do_join($netname, $ch_short); + my $link = '/' . $this->_path_channel($req, $netname, $ch_short); + if( $cgi->{x} ) + { + $link .= "?x=$cgi->{x}"; + } + my $count = 0; + my $code = sub{ + my $timer = shift; + if( $this->_joined($req, $netname, $ch_short) ) + { + $DEBUG and $this->_debug("$req->{peer}: join check: ok"); + }else + { + ++ $count; + if( $count < 10 ) + { + $DEBUG and $this->_debug("$req->{peer}: join check: not yet"); + return; + } + $DEBUG and $this->_debug("$req->{peer}: join check: timeout"); + } + eval{ + $this->_location($req, $link); + }; + if( $@ ) + { + print "$req->{peer}: join: error on location: $@"; + } + if( $timer ) + { + $timer->{interval} = undef; # uninstall. + } + }; + my $timer = Timer->new( + Module => __PACKAGE__, + Interval => 0.3, + Repeat => 1, + Code => $code, + )->install; + }else + { + $this->_debug("$req->{peer} _post_log[$netname/$ch_short] not in allowed channels"); + $this->_response($req, [error => "not in allowed channel"]); + } + return 1; + } return undef; } @@ -2289,12 +2483,15 @@ my $content_raw = ""; - my ($topic_esc, $names_esc); + my ($topic_disp_esc, $topic_esc, $names_esc); if( my $net = $this->_runloop->network($netname) ) { if( my $chan = $net->channel($ch_short) ) { - my $topic = $chan->topic || '(none)'; + my $topic = $chan->topic; + defined($topic) or $topic = ''; + my $topic_disp = $topic eq '' ? $NO_TOPIC : $topic; + my $names = $chan->names || {}; $names = [ values %$names ]; @$names = map{ @@ -2304,18 +2501,25 @@ "$sigil$nick"; } @$names; @$names = sort @$names; + $topic_disp_esc = $this->_escapeHTML($topic_disp); $topic_esc = $this->_escapeHTML($topic); $names_esc = $this->_escapeHTML(join(' ', @$names)); + }else + { + $topic_disp_esc = $NO_TOPIC; + $topic_esc = ''; + $names_esc = ''; } }else { + $topic_disp_esc = $NO_TOPIC; + $topic_esc = ''; + $names_esc = ''; } - $topic_esc ||= '-'; - $names_esc ||= '-'; my $in_topic_esc; my $cgi = $this->_get_cgi_hash($req); - if( my $in_topic = $cgi->{topic} ) + if( defined(my $in_topic = $cgi->{topic}) ) { $in_topic_esc = $this->_escapeHTML($in_topic); }else @@ -2328,10 +2532,14 @@ my $ch_long_esc = $this->_escapeHTML($ch_long); my $tmpl = $this->_tmpl_chan_info(); + $tmpl =~ s{\s*(.*?)\s*}{ + my $mode = $this->_get_req_param($req, 'mode'); + $mode eq 'owner' ? $1 : ''; + }ges; $this->_expand($req, $tmpl, { CONTENT_RAW => $content_raw, CH_LONG => $ch_long_esc, - TOPIC => $topic_esc, + TOPIC => $topic_disp_esc, IN_TOPIC => $in_topic_esc, NAMES => $names_esc, PART_MSG => 'Leaving...', @@ -2365,23 +2573,27 @@

    -NAMES: <&NAMES>
    +参加者: <&NAMES>

    +
    PART:
    +
    JOIN
    +
    DELETE
    +

    [ @@ -2418,14 +2630,26 @@ 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); + my $chan = $network->channel($ch_short); + my $cur_topic = $chan ? $chan->topic : undef; + if( !defined($cur_topic) || $cgi->{topic} ne $cur_topic ) + { + my $for_server = $msg_to_send->clone; + $for_server->param(0, $ch_short); + $network->send_message($for_server); + }else + { + $this->_debug("$req->{peer}: topic not changed cur=[$cur_topic] new=[$cgi->{topic}]"); + } } } if( exists($cgi->{part}) ) { + my $mode = $this->_get_req_param($req, 'mode'); + if( $mode eq 'owner' ) + { + my $msg_to_send = Auto::Utils->construct_irc_message( Command => 'PART', Params => [ '', $cgi->{part} ], @@ -2440,28 +2664,24 @@ $for_server->param(0, $ch_short); $network->send_message($for_server); } + + }else + { + $this->_debug("$req->{peer}: part is not allowed when mode is not 'owner'"); + } } 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); - } + $this->_do_join($netname, $ch_short); } if( exists($cgi->{'delete'}) ) { + my $mode = $this->_get_req_param($req, 'mode'); + if( $mode eq 'owner' ) + { + delete $this->{cache}{$netname}{$ch_short}; if( !keys %{$this->{cache}{$netname}} ) { @@ -2469,11 +2689,40 @@ } $this->_location($req, "/"); return 1; + + }else + { + $this->_debug("$req->{peer}: delete is not allowed when mode is not 'owner'"); + } } return undef; } +sub _do_join +{ + my $this = shift; + my $netname = shift; + my $ch_short = shift; + + 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); + } + + return 1; +} + # ----------------------------------------------------------------------------- # $html = $this->_gen_config($req). # @@ -2702,7 +2951,7 @@ } allow-public { host: * - auth: user2 pass2 + auth: :basic user2 pass2 mask: #公開チャンネル@ircnet } diff -urN tiarra-20090206/sample.conf tiarra-20091019/sample.conf --- tiarra-20090206/sample.conf 2009-02-09 22:30:12.000000000 +0900 +++ tiarra-20091019/sample.conf 2009-10-19 01:19:35.000000000 +0900 @@ -53,7 +53,7 @@ # ----------------------------------------------------------------------------- general { # tiarra.conf自身の文字コード - # コード名はjis,sjis,euc,utf8,utf16,utf32等。(この値はUnicode::Japaneseにそのまま渡されます) + # コード名はjis,sjis,euc,utf8,utf16,utf32等。(この値はEncodeまたはUnicode::Japaneseにそのまま渡されます) # autoが指定された、または省略された場合は自動判別します。 conf-encoding: utf8 @@ -98,13 +98,13 @@ # そのような場合にもこの機能は無効となる。 #control-socket-name: test - # IRCサーバーから送られる文字のコードと、IRCサーバーへ送る文字のコード - # どちらも省略された場合はjis。 + # IRCサーバーから送られる文字のコードと、IRCサーバーへ送る文字のコード。 + # それぞれ省略された場合はjis。 server-in-encoding: jis server-out-encoding: jis - # クライアントから受け取る文字のコードと、クライアントへ伝える文字のコード - # どちらも省略された場合はjis。 + # クライアントから受け取る文字のコードと、クライアントへ伝える文字のコード。 + # それぞれ省略された場合はjis。 client-in-encoding: jis client-out-encoding: jis @@ -133,7 +133,7 @@ # mask: ++{example3}@ircnet,-+{example4}@2ch +*!*@*.example.com # +で始まるチャンネル。 # mask: * -*!*@* #----------------- - # となります。 この二つはまったく同じマスクを表しています。 + # となります。この二つはまったく同じマスクを表しています。 # この値をplumにすると、plum形式、省略するかtiarraを指定すると、Tiarra形式になります。 chanmask-mode: tiarra @@ -237,7 +237,7 @@ # 3. "message-for-each"の場合は、切断されるとクライアントに宛ててTiarraが # 到達不能になった全てのチャンネルにNOTICEでその旨を報告する。 # 再接続に成功すると再びNOTICEで報告する。JOINやPARTはしない。 - # デフォルトはpart-and-joinです。 + # 省略時のデフォルトはpart-and-joinです。 action-when-disconnected: message-for-each # NICKを変更する度に、変更したサーバーでの新しいNICKをNOTICEで常に通知するかどうか。 diff -urN tiarra-20090206/tiarra tiarra-20091019/tiarra --- tiarra-20090206/tiarra 2009-02-09 22:30:09.000000000 +0900 +++ tiarra-20091019/tiarra 2009-10-19 01:19:33.000000000 +0900 @@ -5,7 +5,7 @@ # This is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # ----------------------------------------------------------------------------- -# $Id: tiarra 28572 2009-01-17 18:00:30Z topia $ +# $Id: tiarra 35566 2009-10-09 14:53:58Z topia $ # ----------------------------------------------------------------------------- require 5.008; use strict; @@ -117,8 +117,10 @@ 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 " --quiet don't output any messages to stdout and stderr,\n"; + print " and move to background (runs as daemon)\n"; print " --no-fork don't move to background when started in quiet mode\n"; + print " --force-fork (debugging option) force fork without quiet\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"; @@ -230,6 +232,7 @@ my $quiet = &find_option('quiet'); my $no_fork = &find_option('no-fork'); + my $force_fork = &find_option('force-fork'); my $boot = sub { eval { @@ -281,13 +284,22 @@ } # quietモードであり、且つno-forkオプションが指定されなかったらfork。 - if ($quiet && !$no_fork) { + if ($force_fork || ($quiet && !$no_fork)) { + ## HACK + if ($Tiarra::Resolver::use_threads) { + Tiarra::Resolver->shared->destruct(1); + } my $child_pid = fork; if ($child_pid == 0) { - # 子プロセス + ## HACK + if ($Tiarra::Resolver::use_threads) { + Tiarra::Resolver->shared->init; + } return $boot->(); } elsif (!defined $child_pid) { print "Tiarra: fork() failed.\n"; + } else { + return 'FORKED'; } } else { return $boot->(); @@ -420,6 +432,11 @@ my $exitval = main; &debug_mode && print "cleanup TerminateManager..."; -Tiarra::TerminateManager->terminate('main'); +if ($exitval eq 'FORKED') { + $exitval = 0; + Tiarra::TerminateManager->terminate('forked'); +} else { + Tiarra::TerminateManager->terminate('main'); +} &debug_mode && print "done.\n"; exit $exitval;