1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
|
# -----------------------------------------------------------------------------
# $Id: GetVersion.pm 11365 2008-05-10 14:58:28Z topia $
# -----------------------------------------------------------------------------
# copyright (C) 2004 Topia <topia@clovery.jp>. 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
|
