Сегодня нашел скрипт на perl:
<!--shcode--><pre><code class='perl'>#!/usr/bin/perl -w
# poor man's ICQ group chat implementation
#
# Dobrica Pavlinusic <dpavlin@rot13.org> 2005-03-14
# released under GPL v2 or perl artistic licence
use strict;
use Net::OSCAR qw
standard);
use YAML qw(LoadFile DumpFile Dump);
use Text::Iconv;
# local encoding
my $encoding = 'ISO-8859-2';
my $motd = <<_MOTD_;
Welcome to group ICQ chat.
Change your name with: !nick [your_name]
For help type: !help
_MOTD_
my $help = <<_HELP_;
Confused?
Change your name with !nick [nickname]
Exit group chat !leave or !exit
List group members !members or !list
Invite new member with !invite [uin] [name]
Turn echo to sender with !echo
See last messages with !last
_HELP_
my $config_file = shift @ARGV || $ENV{'HOME'}.'/.icq-chat';
# name of buddy group
my $buddy_group = 'chat';
my $echo = 0;
# default DSN for log
my $dsn = 'dbig:dbname=test';
my $my_uin;
my $config;
my $oscar;
my $signon_done = 0;
my $iconv_utf8 = Text::Iconv->new("UTF-8", $encoding);
my $iconv_utf16 = Text::Iconv->new("UTF-16BE", $encoding);
$|=1;
sub readln {
my $msg = shift || return;
print "$msg ";
my $in = <STDIN>;
chomp($in);
return $in;
}
sub read_config {
if (-e $config_file) {
$config = LoadFile($config_file) || die "can't open $config_file: $!";
$config->{'uin'} ||= readln("group uin:");
$config->{'passwd'} ||= readln($config->{'uin'}." password:");
die "configuration file $config_file is corrupt. Erase it to recover.\n" unless ($config->{'uin'} && $config->{'passwd'});
} else {
$config->{'uin'} = readln("group uin:");
$config->{'passwd'} = readln("password:");
$config->{'members'} = {};
$config->{'motd'} = $motd;
}
$config->{'dsn'} ||= readln("log dns [$dsn]:");
$config->{'dsn'} ||= $dsn;
save_config();
$my_uin = $config->{'uin'};
}
sub save_config {
DumpFile($config_file, $config) || die "can't open $config_file: $!";
xlog('config', $my_uin, "$config_file updated");
}
sub uin2name {
my $uin = shift || return "uin2name: missing uin";
return "bot" if ($uin eq $my_uin);
return $config->{'members'}->{$uin} || "anonymous $uin";
}
sub im_in {
my($oscar, $sender, $message, $is_away) = @_;
$message =
$iconv_utf16->convert($message) ||
$iconv_utf8->convert($message) ||
$message || return;
if ($is_away) {
xlog('away', $sender, $message);
return;
} else {
xlog('im_in', $sender, $message);
}
# strip html from message
$message =~ s#</*(?:html|body|font|b|p)[^>]*?/*>##gsi;
$config->{'last_sender_t'}->{$sender} = time();
$config->{'last_t'} = time();
if ($message =~ m#^!ping\s*(.*)$#) {
my $stamp = $1;
$config->{'ping'}->{$sender}->{'rcv'}++;
$config->{'ping'}->{$sender}->{'rcv_stamp'} = $stamp if ($stamp);
$config->{'nack_cnt'} = 0;
$stamp ||= '';
$stamp .= " -> ".int(time());
xsend_im($sender, "!pong $stamp") if ($sender ne $my_uin);
xlog('ping', $sender, $stamp);
return;
}
# make user online and count it's messages
$config->{'online'}->{$sender}++;
if ($sender ne $my_uin && # not me (bot)
! $config->{'members'}->{$sender} # not member
) {
$config->{'members'}->{$sender} = $sender;
$config->{'online'}->{$sender}++;
}
# seen first time?
if ($config->{'online'}->{$sender} == 1) {
# send motd
xsend_im($sender, $config->{'motd'}) if ($config->{'motd'});
add_member($sender);
xlog('add_member', $sender);
}
if ($message =~ m#^!nick\s+(.+)\s*$#) {
$config->{'members'}->{$sender} = $1;
xsend_im($sender, "Your name will be: $1");
xlog('nick', $sender, $1);
save_config();
return;
}
if ($message =~ m#^!invite\s+(\S+)\s+(.+)*\s*$#) {
my ($uin, $nick) = ($1, $2);
xsend_im($uin, "Your are joined to chat by ".uin2name($sender).". You screen name is: $nick");
xsend_im($sender, "You invited $nick [$uin] to join this chat.");
add_member($uin, $nick);
xlog('invite', $uin, $nick);
return;
}
if ($message =~ m#^!(?:skip|kick|leave|exit)\s*(\S*)\s*$#) {
my $uin = $1 || $sender;
if ($config->{'members'}->{$uin}) {
if ($uin == $sender) {
xsend_im($sender, "You left group chat.");
xlog('leave', $sender);
} else {
xsend_im($sender, "You kicked ".uin2name($uin)." out of this group.");
xlog('leave', $uin, "kicked by $sender [".uin2name($sender)."]");
}
remove_member($uin);
} else {
xsend_im($sender, "UIN $uin is not member of group");
}
return;
}
if ($message =~ m#^!config#) {
read_config();
xsend_im($sender, "Configuration reloaded.");
xlog('config', $sender, 'reloaded');
return;
}
if ($message =~ m#^!(?:members*|list)#) {
my $members = join(", ",
map { uin2name($_) } keys %{ $config->{'online'} }
);
xsend_im($sender, "Group members: $members");
xlog('members', $sender, $members);
return;
}
if ($message =~ m#^!help#) {
xsend_im($sender, $help);
xlog('help', $sender);
return;
}
if ($message =~ m#^!fortune#) {
my $text = `fortune` || "Can't guess your fortune.";
chomp($text);
xsend_im($sender, $text);
xlog('fortune', $sender, $text);
return;
}
if ($message =~ m#^!debug#) {
my $debug = Dump($config);
$debug =~ s/^passwd:.*$/passwd removed/m;
xsend_im($sender, $debug);
xlog('debug', $sender, $debug);
return;
}
if ($message =~ m#^!info\s+(\S+)\s*$#) {
my $uin = $1;
my $info = Dump($oscar->buddy($uin)) || "Can't get info for $uin [".uin2name($uin)."]";
xsend_im($sender, $info);
xlog('info', $sender, $info);
return;
}
if ($message =~ m#^!on-*line\s*(\S*)\s*$#) {
my $uin = $1;
xlog('online', $sender, $uin);
if ($uin && $config->{'members'}->{$uin}) {
$config->{'online'}->{$uin}++;
xsend_im($sender, "Changed status of $uin to on-line.");
} elsif ($uin) {
xsend_im($sender, "UIN $uin is not member. Try !invite $uin [name] first");
} else {
# check and list on-line members
xsend_im($sender, "on-line members: ".
join(", ", map { uin2name($_) } online_uins($oscar) ));
}
return;
}
if ($message =~ m#^!(?:broadcast|all)#) {
foreach my $uin (keys %{$config->{'members'}}) {
$config->{'online'}->{$uin} = 1 unless ($config->{'online'}->{$uin});
}
xsend_im($sender, "Your next message will be broadcasted to all members without regard to on-line flag.");
xlog('broadcast', $sender);
}
if ($message =~ m#^!echo#) {
my $own;
my $echo = $config->{'echo'}->{$sender};
if ($echo) {
$own = "not sent back";
delete($config->{'echo'}->{$sender});
} else {
$own = "sent back to sender";
$config->{'echo'}->{$sender}++;
}
xsend_im($sender, "own messages are $own");
xlog('echo', $sender, $echo);
save_config();
return;
}
if ($message =~ m#^!last\s*?(\d*)$#) {
my $nr = $1;
xsend_im($sender, "\n".xlast($nr));
xlog('last', $sender);
return;
}
if ($message =~ m#^!rmskip\s+(\S+)\s*$#) {
my $uin = $1;
my $who = uin2name($uin)." [$uin]";
if ($config->{'skip_buddy'}->{$uin}) {
delete $config->{'skip_buddy'}->{$uin};
xsend_im($sender, "removed $who from skip list");
xlog('rmskip', $sender, $uin);
} else {
xsend_im($sender, "can't remove $who from skip list, not a member");
}
return;
}
$message =~ s#<br>#\n#gis;
if ($message =~ m#^!motd\s*?(.*)#s) {
$config->{'motd'} = $1 || $motd;
xsend_im($sender, "New MOTD is:\n".$config->{'motd'});
save_config();
xlog('motd', $sender);
return;
}
xlog('msg', $sender, $message);
if ($message =~ m#^(!.*)#) {
xsend_im($sender, "Unknown command: $1");
xlog("unkown", $sender, $1);
return;
}
# prefix with name
if ($sender ne $my_uin) {
my $m = $message || return;
$message = "[".uin2name($sender)."] $m";
}
foreach my $uin (keys %{$config->{'online'}}) {
next if (! $config->{'echo'}->{$sender} && $uin eq $sender || $uin eq $my_uin);
xsend_im($uin, $message);
}
print "\n";
}
sub xsend_all_except {
my $sender = shift || return;
my $message = shift || return;
foreach my $uin (keys %{$config->{'online'}}) {
# don't send to sender or bot
next if ($uin eq $sender or $uin eq $my_uin);
xsend_im($uin, $message);
}
}
sub buddy_in {
my ($oscar, $uin) = @_;
warn "buddy in got empty uin\n" and return unless ($uin);
return if ($uin eq $my_uin);
$config->{'online'}->{$uin}++;
xsend_all_except($uin, uin2name($uin)." joined chat.") if ($config->{'online'}->{$uin} == 1);
xlog('buddy_in', $uin);
save_config();
}
sub buddy_out {
my ($oscar, $uin) = @_;
return if ($uin eq $my_uin); # me?
delete($config->{'online'}->{$uin});
xsend_all_except($uin, uin2name($uin)." left chat.");
xlog('buddy_out', $uin);
save_config();
}
my $buddylist_commit_active = 0;
sub remove_member($) {
my $uin = shift || return;
delete ($config->{'online'}->{$uin});
$oscar->remove_buddy($buddy_group, $uin);
$oscar->commit_buddylist() if ($buddylist_commit_active == 0);
$buddylist_commit_active++;
xlog('remove_member', $uin);
}
sub add_member($$) {
my ($uin, $nick) = @_;
return unless ($uin && $nick);
$config->{'members'}->{$uin} = $nick;
$oscar->add_buddy($buddy_group, $uin);
$oscar->add_permit($uin);
$oscar->commit_buddylist() if ($buddylist_commit_active == 0);
$buddylist_commit_active++;
xlog('add_member', $uin);
}
sub buddylist_ok {
my $oscar = shift;
print "Buddy list commited with $buddylist_commit_active changes commited.\n";
$buddylist_commit_active = 0;
save_config();
xlog('buddylist_ok', $my_uin);
}
sub buddylist_error {
my ($oscar, $error, $what) = @_;
if ($error = 14 && $what =~ m/(\d+)/) {
my $uin = $1;
print "ERROR: $what [$error], adding $uin [",uin2name($uin),"] to skip buddy list\n";
$config->{'skip_buddy'}->{$uin}++;
remove_member($uin);
} else {
print "ERROR: Buddy list commit failed [$error]: $what\n";
}
xlog('buddylist_error', $my_uin, $what);
}
sub online_uins($) {
my $oscar = shift || return;
my @online;
$config->{'online'} = {};
foreach my $uin (keys %{$config->{'members'}}) {
next if ($uin eq $my_uin);
my $info = $oscar->buddy($uin);
if ($info->{'online'}) {
$config->{'online'}->{$uin}++;
push @online, $uin;
}
}
xlog('online_uins', $my_uin, join(", ", @online));
save_config();
return @online;
}
sub signon_done {
my $oscar = shift;
my @buddies = $oscar->buddies();
print "adding buddies:\n";
foreach my $uin (keys %{$config->{'members'}}) {
my $status = 'old';
unless (grep(/^$uin$/, @buddies)) {
if ($config->{'skip_buddy'}->{$uin}) {
$status = 'SKIPPED';
} else {
$oscar->add_buddy($buddy_group, $uin);
$oscar->set_buddy_alias($buddy_group, $uin, uin2name($uin));
$status = 'NEW';
}
}
printf("%-10d : %s - %s buddy\n",
$uin,
uin2name($uin),
$status,
);
xlog('signon_done', $uin, $status);
}
# fixup (just in case) -- remove own uin from members and buddies
my $me = $my_uin;
$oscar->remove_buddy($buddy_group, $config->{$me});
delete($config->{'members'}->{$me});
$oscar->commit_buddylist();
print "on-line buddies:\n";
$config->{'online'} = {};
foreach my $uin (online_uins($oscar)) {
printf("%-10d : %s online\n", $uin, uin2name($uin));
}
save_config();
$signon_done++;
}
sub rate_alert {
my ($oscar, $level, $clear, $window, $worrisome) = @_;
my $msg = "$window messages max in $clear ms limit reached";
xlog('rate_alter', $my_uin, $level . " " . $msg);
print "# $msg - sleeping $clear ms\n";
select(undef, undef, undef, ($clear/100));
# if ($worrisome) {
# xsend_im($my_uin, $msg);
# }
}
sub error {
my ($oscar, $connection, $error, $description, $fatal) = @_;
xlog('error', $my_uin, $description);
print "ERROR [$error]: $description\n";
if ($fatal) {
$signon_done = 0;
print "# repeating sign-on\n";
$oscar->signon($my_uin, $config->{'passwd'}) || die "can't sign on as $my_uin";
}
}
## DSN logging support
my ($dbh,$sth_log, $sth_sent, $sth_sent_ok, $sth_last);
sub create_log_table {
$dbh ||= connect_db();
return unless ($dbh);
# exit if table exists
return if ($dbh->do("select * from log limit 1"));
print "# creating log table in $dsn\n";
$dbh->do(q{
create table log (
id serial,
date timestamp default now(),
bot text not null,
type text not null,
uin text not null,
name text not null,
message text,
primary key(id)
)
}) || die $dbh->errstr();
$dbh->do(qq{ create index log_date on log(date) }) or die $dbh->errstr();
$dbh->do(qq{ create index log_bot on log(bot) }) or die $dbh->errstr();
$dbh->do(qq{ create index log_type on log(type) }) or die $dbh->errstr();
$dbh->do(qq{ create index log_uin on log(uin) }) or die $dbh->errstr();
$dbh->do(qq{ create index log_name on log(name) }) or die $dbh->errstr();
$dbh->do(qq{
create table sent (
date timestamp default now(),
bot text not null,
uin text not null,
name text not null,
r_id text not null,
message text,
sent boolean default false,
primary key(r_id)
)
});
}
sub connect_db {
return unless ($config->{'dsn'});
return if ($dbh);
require DBI;
print "# using $dsn for log\n";
$dbh = DBI->connect($config->{'dsn'},"","") || die $DBI::errstr;
return $dbh;
}
sub xlog {
my ($type,$uin, $message) = @_;
my $name = uin2name($uin);
print localtime()." $type: $uin [$name] ", ( $message || '' ),"\n";
return unless ($dbh);
$sth_log ||= $dbh->prepare(qq{
insert into log (bot,type,uin,name,message) values (?,?,?,?,?)
}) || die $dbh->errstr();
$sth_log->execute($my_uin, $type, $uin, $name, $message) || print "$type: [$uin] $message";
}
sub xsend_im {
my ($who, $message, $away) = @_;
my $r_id = $oscar->send_im($who, $message, $away);
print "# sent $who $r_id\n";
return unless ($dbh);
if (! $r_id) {
xlog('error', $my_uin, "failed send_im to $who: $message");
return;
}
$sth_sent ||= $dbh->prepare(qq{
insert into sent (bot,uin,name,r_id,message) values (?,?,?,?,?)
}) || die $dbh->errstr();
$sth_sent->execute($my_uin, $who, uin2name($who), $r_id, $message) ||
xlog('error', $my_uin, "insert of sent $who $r_id failed");
}
sub im_ok {
my ($oscar, $to, $r_id) = @_;
print "# im_ok $to $r_id\n";
return unless ($dbh);
# oh, there seem to be bug in Net::OSCAR. It returns totally off-sync
# request_id, so I just ack last send messages.
$sth_sent_ok ||= $dbh->prepare(qq{
update sent set sent = true where
bot = ? and uin = ? and r_id =
(select r_id from sent as s2 where s2.uin = sent.uin and s2.sent = false order by s2.date desc limit 1)
}) || die $dbh->errstr();
$sth_sent_ok->execute($my_uin, $to) ||
xlog('error', $my_uin, "insert of im_ok $to $r_id failed");
}
sub xlast {
my $nr = shift;
$nr ||= 10; # default: show last 10 messages
return 'last not supported without database support' unless ($dbh);
$sth_last ||= $dbh->prepare(qq{
select date,name,message from log where type = 'msg' and bot = ? order by date desc limit ?
}) || die $dbh->errstr();
$sth_last->execute($my_uin, $nr) ||
xlog('error', $my_uin, "last failed") && return 'last failed';
my @last;
my $last_date = '';
while (my $row = $sth_last->fetchrow_hashref() ) {
my ($date, $time);
if( $row->{'date'} =~ m#^(\d+-\d+-\d+)\s(\d+:\d+:\d+)# ) {
($date,$time) = ($1,$2);
if ($date ne $last_date) {
unshift @last, "date: $date";
$last_date = $date;
}
}
$time ||= "unknown";
unshift @last, "($time) [".$row->{'name'}."] ".$row->{'message'};
}
return join("\n", @last);
}
$oscar = Net::OSCAR->new(capabilities => [qw(extended_status typing_status)]) || die;
$oscar->loglevel(3);
read_config();
create_log_table();
$oscar->set_callback_im_in(\&im_in);
$oscar->set_callback_im_ok(\&im_ok);
$oscar->set_callback_buddy_in(\&buddy_in);
$oscar->set_callback_buddy_out(\&buddy_out);
$oscar->set_callback_buddylist_ok(\&buddylist_ok);
$oscar->set_callback_buddylist_error(\&buddylist_error);
$oscar->set_callback_signon_done(\&signon_done);
$oscar->set_callback_rate_alert(\&rate_alert);
$oscar->signon($my_uin, $config->{'passwd'}) || die "can't sign on as $my_uin";
my $interval = 3600;
my $signoff_i = 5;
$config->{'last_t'} = time();
$config->{'nack_cnt'} = 0;
while(1) {
$oscar->do_one_loop();
next unless ($signon_done);
my $last_t = $config->{'last_t'} || die "no last_t?";
my $dt = time() - $last_t;
if ($dt >= $interval) {
my $nack_cnt = $config->{'nack_cnt'}++;
print "# dt[$nack_cnt]: $dt\n";
if ($nack_cnt < $signoff_i) {
print "# ping keep-alive timeout: $dt s - sending ping, count: $nack_cnt\n";
xsend_im($my_uin, "!ping ".int(time()) );
$config->{'last_t'} = time();
} else {
print "# serious problems!\n";
$config->{'nack_cnt'} = 0;
# $oscar->signoff;
# $signon_done = 0;
# $oscar->signon($my_uin, $config->{'passwd'}) || die "can't sign on as $my_uin";
}
}
}
# make strict happy
$DBI::errstr++;[/CODE]
- это icq чат бот, т.е. позволяет в icq общатся не 2, а более человекам, но я не могу настроить в нем кодировку, ставлю <!--shcode--><pre><code class='perl'>my $encoding = cp1251[/CODE], а он абра-кодабру выводит.
Помогите кто понял.
З.Ы.: И еще один вопрос, он выводит последние сообщения по команде !last, а как сделать что бы он выводил каждое сообщение сразу, т.е. если кто то отправит сообщение, оно сразу приходило другим.
<!--shcode--><pre><code class='perl'>#!/usr/bin/perl -w
# poor man's ICQ group chat implementation
#
# Dobrica Pavlinusic <dpavlin@rot13.org> 2005-03-14
# released under GPL v2 or perl artistic licence
use strict;
use Net::OSCAR qw
standard);use YAML qw(LoadFile DumpFile Dump);
use Text::Iconv;
# local encoding
my $encoding = 'ISO-8859-2';
my $motd = <<_MOTD_;
Welcome to group ICQ chat.
Change your name with: !nick [your_name]
For help type: !help
_MOTD_
my $help = <<_HELP_;
Confused?
Change your name with !nick [nickname]
Exit group chat !leave or !exit
List group members !members or !list
Invite new member with !invite [uin] [name]
Turn echo to sender with !echo
See last messages with !last
_HELP_
my $config_file = shift @ARGV || $ENV{'HOME'}.'/.icq-chat';
# name of buddy group
my $buddy_group = 'chat';
my $echo = 0;
# default DSN for log
my $dsn = 'dbi
g:dbname=test';my $my_uin;
my $config;
my $oscar;
my $signon_done = 0;
my $iconv_utf8 = Text::Iconv->new("UTF-8", $encoding);
my $iconv_utf16 = Text::Iconv->new("UTF-16BE", $encoding);
$|=1;
sub readln {
my $msg = shift || return;
print "$msg ";
my $in = <STDIN>;
chomp($in);
return $in;
}
sub read_config {
if (-e $config_file) {
$config = LoadFile($config_file) || die "can't open $config_file: $!";
$config->{'uin'} ||= readln("group uin:");
$config->{'passwd'} ||= readln($config->{'uin'}." password:");
die "configuration file $config_file is corrupt. Erase it to recover.\n" unless ($config->{'uin'} && $config->{'passwd'});
} else {
$config->{'uin'} = readln("group uin:");
$config->{'passwd'} = readln("password:");
$config->{'members'} = {};
$config->{'motd'} = $motd;
}
$config->{'dsn'} ||= readln("log dns [$dsn]:");
$config->{'dsn'} ||= $dsn;
save_config();
$my_uin = $config->{'uin'};
}
sub save_config {
DumpFile($config_file, $config) || die "can't open $config_file: $!";
xlog('config', $my_uin, "$config_file updated");
}
sub uin2name {
my $uin = shift || return "uin2name: missing uin";
return "bot" if ($uin eq $my_uin);
return $config->{'members'}->{$uin} || "anonymous $uin";
}
sub im_in {
my($oscar, $sender, $message, $is_away) = @_;
$message =
$iconv_utf16->convert($message) ||
$iconv_utf8->convert($message) ||
$message || return;
if ($is_away) {
xlog('away', $sender, $message);
return;
} else {
xlog('im_in', $sender, $message);
}
# strip html from message
$message =~ s#</*(?:html|body|font|b|p)[^>]*?/*>##gsi;
$config->{'last_sender_t'}->{$sender} = time();
$config->{'last_t'} = time();
if ($message =~ m#^!ping\s*(.*)$#) {
my $stamp = $1;
$config->{'ping'}->{$sender}->{'rcv'}++;
$config->{'ping'}->{$sender}->{'rcv_stamp'} = $stamp if ($stamp);
$config->{'nack_cnt'} = 0;
$stamp ||= '';
$stamp .= " -> ".int(time());
xsend_im($sender, "!pong $stamp") if ($sender ne $my_uin);
xlog('ping', $sender, $stamp);
return;
}
# make user online and count it's messages
$config->{'online'}->{$sender}++;
if ($sender ne $my_uin && # not me (bot)
! $config->{'members'}->{$sender} # not member
) {
$config->{'members'}->{$sender} = $sender;
$config->{'online'}->{$sender}++;
}
# seen first time?
if ($config->{'online'}->{$sender} == 1) {
# send motd
xsend_im($sender, $config->{'motd'}) if ($config->{'motd'});
add_member($sender);
xlog('add_member', $sender);
}
if ($message =~ m#^!nick\s+(.+)\s*$#) {
$config->{'members'}->{$sender} = $1;
xsend_im($sender, "Your name will be: $1");
xlog('nick', $sender, $1);
save_config();
return;
}
if ($message =~ m#^!invite\s+(\S+)\s+(.+)*\s*$#) {
my ($uin, $nick) = ($1, $2);
xsend_im($uin, "Your are joined to chat by ".uin2name($sender).". You screen name is: $nick");
xsend_im($sender, "You invited $nick [$uin] to join this chat.");
add_member($uin, $nick);
xlog('invite', $uin, $nick);
return;
}
if ($message =~ m#^!(?:skip|kick|leave|exit)\s*(\S*)\s*$#) {
my $uin = $1 || $sender;
if ($config->{'members'}->{$uin}) {
if ($uin == $sender) {
xsend_im($sender, "You left group chat.");
xlog('leave', $sender);
} else {
xsend_im($sender, "You kicked ".uin2name($uin)." out of this group.");
xlog('leave', $uin, "kicked by $sender [".uin2name($sender)."]");
}
remove_member($uin);
} else {
xsend_im($sender, "UIN $uin is not member of group");
}
return;
}
if ($message =~ m#^!config#) {
read_config();
xsend_im($sender, "Configuration reloaded.");
xlog('config', $sender, 'reloaded');
return;
}
if ($message =~ m#^!(?:members*|list)#) {
my $members = join(", ",
map { uin2name($_) } keys %{ $config->{'online'} }
);
xsend_im($sender, "Group members: $members");
xlog('members', $sender, $members);
return;
}
if ($message =~ m#^!help#) {
xsend_im($sender, $help);
xlog('help', $sender);
return;
}
if ($message =~ m#^!fortune#) {
my $text = `fortune` || "Can't guess your fortune.";
chomp($text);
xsend_im($sender, $text);
xlog('fortune', $sender, $text);
return;
}
if ($message =~ m#^!debug#) {
my $debug = Dump($config);
$debug =~ s/^passwd:.*$/passwd removed/m;
xsend_im($sender, $debug);
xlog('debug', $sender, $debug);
return;
}
if ($message =~ m#^!info\s+(\S+)\s*$#) {
my $uin = $1;
my $info = Dump($oscar->buddy($uin)) || "Can't get info for $uin [".uin2name($uin)."]";
xsend_im($sender, $info);
xlog('info', $sender, $info);
return;
}
if ($message =~ m#^!on-*line\s*(\S*)\s*$#) {
my $uin = $1;
xlog('online', $sender, $uin);
if ($uin && $config->{'members'}->{$uin}) {
$config->{'online'}->{$uin}++;
xsend_im($sender, "Changed status of $uin to on-line.");
} elsif ($uin) {
xsend_im($sender, "UIN $uin is not member. Try !invite $uin [name] first");
} else {
# check and list on-line members
xsend_im($sender, "on-line members: ".
join(", ", map { uin2name($_) } online_uins($oscar) ));
}
return;
}
if ($message =~ m#^!(?:broadcast|all)#) {
foreach my $uin (keys %{$config->{'members'}}) {
$config->{'online'}->{$uin} = 1 unless ($config->{'online'}->{$uin});
}
xsend_im($sender, "Your next message will be broadcasted to all members without regard to on-line flag.");
xlog('broadcast', $sender);
}
if ($message =~ m#^!echo#) {
my $own;
my $echo = $config->{'echo'}->{$sender};
if ($echo) {
$own = "not sent back";
delete($config->{'echo'}->{$sender});
} else {
$own = "sent back to sender";
$config->{'echo'}->{$sender}++;
}
xsend_im($sender, "own messages are $own");
xlog('echo', $sender, $echo);
save_config();
return;
}
if ($message =~ m#^!last\s*?(\d*)$#) {
my $nr = $1;
xsend_im($sender, "\n".xlast($nr));
xlog('last', $sender);
return;
}
if ($message =~ m#^!rmskip\s+(\S+)\s*$#) {
my $uin = $1;
my $who = uin2name($uin)." [$uin]";
if ($config->{'skip_buddy'}->{$uin}) {
delete $config->{'skip_buddy'}->{$uin};
xsend_im($sender, "removed $who from skip list");
xlog('rmskip', $sender, $uin);
} else {
xsend_im($sender, "can't remove $who from skip list, not a member");
}
return;
}
$message =~ s#<br>#\n#gis;
if ($message =~ m#^!motd\s*?(.*)#s) {
$config->{'motd'} = $1 || $motd;
xsend_im($sender, "New MOTD is:\n".$config->{'motd'});
save_config();
xlog('motd', $sender);
return;
}
xlog('msg', $sender, $message);
if ($message =~ m#^(!.*)#) {
xsend_im($sender, "Unknown command: $1");
xlog("unkown", $sender, $1);
return;
}
# prefix with name
if ($sender ne $my_uin) {
my $m = $message || return;
$message = "[".uin2name($sender)."] $m";
}
foreach my $uin (keys %{$config->{'online'}}) {
next if (! $config->{'echo'}->{$sender} && $uin eq $sender || $uin eq $my_uin);
xsend_im($uin, $message);
}
print "\n";
}
sub xsend_all_except {
my $sender = shift || return;
my $message = shift || return;
foreach my $uin (keys %{$config->{'online'}}) {
# don't send to sender or bot
next if ($uin eq $sender or $uin eq $my_uin);
xsend_im($uin, $message);
}
}
sub buddy_in {
my ($oscar, $uin) = @_;
warn "buddy in got empty uin\n" and return unless ($uin);
return if ($uin eq $my_uin);
$config->{'online'}->{$uin}++;
xsend_all_except($uin, uin2name($uin)." joined chat.") if ($config->{'online'}->{$uin} == 1);
xlog('buddy_in', $uin);
save_config();
}
sub buddy_out {
my ($oscar, $uin) = @_;
return if ($uin eq $my_uin); # me?
delete($config->{'online'}->{$uin});
xsend_all_except($uin, uin2name($uin)." left chat.");
xlog('buddy_out', $uin);
save_config();
}
my $buddylist_commit_active = 0;
sub remove_member($) {
my $uin = shift || return;
delete ($config->{'online'}->{$uin});
$oscar->remove_buddy($buddy_group, $uin);
$oscar->commit_buddylist() if ($buddylist_commit_active == 0);
$buddylist_commit_active++;
xlog('remove_member', $uin);
}
sub add_member($$) {
my ($uin, $nick) = @_;
return unless ($uin && $nick);
$config->{'members'}->{$uin} = $nick;
$oscar->add_buddy($buddy_group, $uin);
$oscar->add_permit($uin);
$oscar->commit_buddylist() if ($buddylist_commit_active == 0);
$buddylist_commit_active++;
xlog('add_member', $uin);
}
sub buddylist_ok {
my $oscar = shift;
print "Buddy list commited with $buddylist_commit_active changes commited.\n";
$buddylist_commit_active = 0;
save_config();
xlog('buddylist_ok', $my_uin);
}
sub buddylist_error {
my ($oscar, $error, $what) = @_;
if ($error = 14 && $what =~ m/(\d+)/) {
my $uin = $1;
print "ERROR: $what [$error], adding $uin [",uin2name($uin),"] to skip buddy list\n";
$config->{'skip_buddy'}->{$uin}++;
remove_member($uin);
} else {
print "ERROR: Buddy list commit failed [$error]: $what\n";
}
xlog('buddylist_error', $my_uin, $what);
}
sub online_uins($) {
my $oscar = shift || return;
my @online;
$config->{'online'} = {};
foreach my $uin (keys %{$config->{'members'}}) {
next if ($uin eq $my_uin);
my $info = $oscar->buddy($uin);
if ($info->{'online'}) {
$config->{'online'}->{$uin}++;
push @online, $uin;
}
}
xlog('online_uins', $my_uin, join(", ", @online));
save_config();
return @online;
}
sub signon_done {
my $oscar = shift;
my @buddies = $oscar->buddies();
print "adding buddies:\n";
foreach my $uin (keys %{$config->{'members'}}) {
my $status = 'old';
unless (grep(/^$uin$/, @buddies)) {
if ($config->{'skip_buddy'}->{$uin}) {
$status = 'SKIPPED';
} else {
$oscar->add_buddy($buddy_group, $uin);
$oscar->set_buddy_alias($buddy_group, $uin, uin2name($uin));
$status = 'NEW';
}
}
printf("%-10d : %s - %s buddy\n",
$uin,
uin2name($uin),
$status,
);
xlog('signon_done', $uin, $status);
}
# fixup (just in case) -- remove own uin from members and buddies
my $me = $my_uin;
$oscar->remove_buddy($buddy_group, $config->{$me});
delete($config->{'members'}->{$me});
$oscar->commit_buddylist();
print "on-line buddies:\n";
$config->{'online'} = {};
foreach my $uin (online_uins($oscar)) {
printf("%-10d : %s online\n", $uin, uin2name($uin));
}
save_config();
$signon_done++;
}
sub rate_alert {
my ($oscar, $level, $clear, $window, $worrisome) = @_;
my $msg = "$window messages max in $clear ms limit reached";
xlog('rate_alter', $my_uin, $level . " " . $msg);
print "# $msg - sleeping $clear ms\n";
select(undef, undef, undef, ($clear/100));
# if ($worrisome) {
# xsend_im($my_uin, $msg);
# }
}
sub error {
my ($oscar, $connection, $error, $description, $fatal) = @_;
xlog('error', $my_uin, $description);
print "ERROR [$error]: $description\n";
if ($fatal) {
$signon_done = 0;
print "# repeating sign-on\n";
$oscar->signon($my_uin, $config->{'passwd'}) || die "can't sign on as $my_uin";
}
}
## DSN logging support
my ($dbh,$sth_log, $sth_sent, $sth_sent_ok, $sth_last);
sub create_log_table {
$dbh ||= connect_db();
return unless ($dbh);
# exit if table exists
return if ($dbh->do("select * from log limit 1"));
print "# creating log table in $dsn\n";
$dbh->do(q{
create table log (
id serial,
date timestamp default now(),
bot text not null,
type text not null,
uin text not null,
name text not null,
message text,
primary key(id)
)
}) || die $dbh->errstr();
$dbh->do(qq{ create index log_date on log(date) }) or die $dbh->errstr();
$dbh->do(qq{ create index log_bot on log(bot) }) or die $dbh->errstr();
$dbh->do(qq{ create index log_type on log(type) }) or die $dbh->errstr();
$dbh->do(qq{ create index log_uin on log(uin) }) or die $dbh->errstr();
$dbh->do(qq{ create index log_name on log(name) }) or die $dbh->errstr();
$dbh->do(qq{
create table sent (
date timestamp default now(),
bot text not null,
uin text not null,
name text not null,
r_id text not null,
message text,
sent boolean default false,
primary key(r_id)
)
});
}
sub connect_db {
return unless ($config->{'dsn'});
return if ($dbh);
require DBI;
print "# using $dsn for log\n";
$dbh = DBI->connect($config->{'dsn'},"","") || die $DBI::errstr;
return $dbh;
}
sub xlog {
my ($type,$uin, $message) = @_;
my $name = uin2name($uin);
print localtime()." $type: $uin [$name] ", ( $message || '' ),"\n";
return unless ($dbh);
$sth_log ||= $dbh->prepare(qq{
insert into log (bot,type,uin,name,message) values (?,?,?,?,?)
}) || die $dbh->errstr();
$sth_log->execute($my_uin, $type, $uin, $name, $message) || print "$type: [$uin] $message";
}
sub xsend_im {
my ($who, $message, $away) = @_;
my $r_id = $oscar->send_im($who, $message, $away);
print "# sent $who $r_id\n";
return unless ($dbh);
if (! $r_id) {
xlog('error', $my_uin, "failed send_im to $who: $message");
return;
}
$sth_sent ||= $dbh->prepare(qq{
insert into sent (bot,uin,name,r_id,message) values (?,?,?,?,?)
}) || die $dbh->errstr();
$sth_sent->execute($my_uin, $who, uin2name($who), $r_id, $message) ||
xlog('error', $my_uin, "insert of sent $who $r_id failed");
}
sub im_ok {
my ($oscar, $to, $r_id) = @_;
print "# im_ok $to $r_id\n";
return unless ($dbh);
# oh, there seem to be bug in Net::OSCAR. It returns totally off-sync
# request_id, so I just ack last send messages.
$sth_sent_ok ||= $dbh->prepare(qq{
update sent set sent = true where
bot = ? and uin = ? and r_id =
(select r_id from sent as s2 where s2.uin = sent.uin and s2.sent = false order by s2.date desc limit 1)
}) || die $dbh->errstr();
$sth_sent_ok->execute($my_uin, $to) ||
xlog('error', $my_uin, "insert of im_ok $to $r_id failed");
}
sub xlast {
my $nr = shift;
$nr ||= 10; # default: show last 10 messages
return 'last not supported without database support' unless ($dbh);
$sth_last ||= $dbh->prepare(qq{
select date,name,message from log where type = 'msg' and bot = ? order by date desc limit ?
}) || die $dbh->errstr();
$sth_last->execute($my_uin, $nr) ||
xlog('error', $my_uin, "last failed") && return 'last failed';
my @last;
my $last_date = '';
while (my $row = $sth_last->fetchrow_hashref() ) {
my ($date, $time);
if( $row->{'date'} =~ m#^(\d+-\d+-\d+)\s(\d+:\d+:\d+)# ) {
($date,$time) = ($1,$2);
if ($date ne $last_date) {
unshift @last, "date: $date";
$last_date = $date;
}
}
$time ||= "unknown";
unshift @last, "($time) [".$row->{'name'}."] ".$row->{'message'};
}
return join("\n", @last);
}
$oscar = Net::OSCAR->new(capabilities => [qw(extended_status typing_status)]) || die;
$oscar->loglevel(3);
read_config();
create_log_table();
$oscar->set_callback_im_in(\&im_in);
$oscar->set_callback_im_ok(\&im_ok);
$oscar->set_callback_buddy_in(\&buddy_in);
$oscar->set_callback_buddy_out(\&buddy_out);
$oscar->set_callback_buddylist_ok(\&buddylist_ok);
$oscar->set_callback_buddylist_error(\&buddylist_error);
$oscar->set_callback_signon_done(\&signon_done);
$oscar->set_callback_rate_alert(\&rate_alert);
$oscar->signon($my_uin, $config->{'passwd'}) || die "can't sign on as $my_uin";
my $interval = 3600;
my $signoff_i = 5;
$config->{'last_t'} = time();
$config->{'nack_cnt'} = 0;
while(1) {
$oscar->do_one_loop();
next unless ($signon_done);
my $last_t = $config->{'last_t'} || die "no last_t?";
my $dt = time() - $last_t;
if ($dt >= $interval) {
my $nack_cnt = $config->{'nack_cnt'}++;
print "# dt[$nack_cnt]: $dt\n";
if ($nack_cnt < $signoff_i) {
print "# ping keep-alive timeout: $dt s - sending ping, count: $nack_cnt\n";
xsend_im($my_uin, "!ping ".int(time()) );
$config->{'last_t'} = time();
} else {
print "# serious problems!\n";
$config->{'nack_cnt'} = 0;
# $oscar->signoff;
# $signon_done = 0;
# $oscar->signon($my_uin, $config->{'passwd'}) || die "can't sign on as $my_uin";
}
}
}
# make strict happy
$DBI::errstr++;[/CODE]
- это icq чат бот, т.е. позволяет в icq общатся не 2, а более человекам, но я не могу настроить в нем кодировку, ставлю <!--shcode--><pre><code class='perl'>my $encoding = cp1251[/CODE], а он абра-кодабру выводит.
Помогите кто понял.
З.Ы.: И еще один вопрос, он выводит последние сообщения по команде !last, а как сделать что бы он выводил каждое сообщение сразу, т.е. если кто то отправит сообщение, оно сразу приходило другим.