Line # Revision Author
1 58 dpavlin #!/usr/bin/perl -w
2
3 60 dpavlin # poor man's ICQ group chat implementation
4 #
5 # Dobrica Pavlinusic <dpavlin@rot13.org> 2005-03-14
6 # released under GPL v2 or perl artistic licence
7
8 58 dpavlin use strict;
9 use Net::OSCAR qw(:standard);
10 62 dpavlin use YAML qw(LoadFile DumpFile Dump);
11 66 dpavlin use Text::Iconv;
12 58 dpavlin
13 66 dpavlin # local encoding
14 my $encoding = 'ISO-8859-2';
15
16 67 dpavlin my $motd = <<_MOTD_;
17 Welcome to group ICQ chat.
18 Change your name with: !nick [your_name]
19 For help type: !help
20 _MOTD_
21
22 73 dpavlin my $help = <<_HELP_;
23 Confused?
24 Change your name with !nick [nickname]
25 Exit group chat !leave or !exit
26 List group members !members or !list
27 Invite new member with !invite [uin] [name]
28 Turn echo to sender with !echo
29 See last messages with !last
30 _HELP_
31
32 63 dpavlin my $config_file = shift @ARGV || $ENV{'HOME'}.'/.icq-chat';
33 66 dpavlin
34 # name of buddy group
35 62 dpavlin my $buddy_group = 'chat';
36 66 dpavlin my $echo = 0;
37 71 dpavlin # default DSN for log
38 my $dsn = 'dbi:Pg:dbname=test';
39 66 dpavlin
40 62 dpavlin my $my_uin;
41 66 dpavlin my $config;
42 70 dpavlin my $oscar;
43 105 dpavlin my $signon_done = 0;
44 70 dpavlin
45 68 dpavlin my $iconv_utf8 = Text::Iconv->new("UTF-8", $encoding);
46 my $iconv_utf16 = Text::Iconv->new("UTF-16BE", $encoding);
47 58 dpavlin
48 62 dpavlin $|=1;
49
50 58 dpavlin sub readln {
51 my $msg = shift || return;
52 print "$msg ";
53 my $in = <STDIN>;
54 chomp($in);
55 return $in;
56 }
57
58 sub read_config {
59 if (-e $config_file) {
60 $config = LoadFile($config_file) || die "can't open $config_file: $!";
61 68 dpavlin $config->{'uin'} ||= readln("group uin:");
62 $config->{'passwd'} ||= readln($config->{'uin'}." password:");
63 58 dpavlin die "configuration file $config_file is corrupt. Erase it to recover.\n" unless ($config->{'uin'} && $config->{'passwd'});
64 } else {
65 $config->{'uin'} = readln("group uin:");
66 $config->{'passwd'} = readln("password:");
67 $config->{'members'} = {};
68 67 dpavlin $config->{'motd'} = $motd;
69 71 dpavlin }
70 $config->{'dsn'} ||= readln("log dns [$dsn]:");
71 $config->{'dsn'} ||= $dsn;
72 58 dpavlin
73 71 dpavlin save_config();
74 62 dpavlin $my_uin = $config->{'uin'};
75 58 dpavlin }
76
77 sub save_config {
78 62 dpavlin DumpFile($config_file, $config) || die "can't open $config_file: $!";
79 71 dpavlin xlog('config', $my_uin, "$config_file updated");
80 58 dpavlin }
81
82 62 dpavlin sub uin2name {
83 my $uin = shift || return "uin2name: missing uin";
84 68 dpavlin return "bot" if ($uin eq $my_uin);
85 67 dpavlin return $config->{'members'}->{$uin} || "anonymous $uin";
86 62 dpavlin }
87 58 dpavlin
88 sub im_in {
89 my($oscar, $sender, $message, $is_away) = @_;
90 66 dpavlin
91 68 dpavlin $message =
92 $iconv_utf16->convert($message) ||
93 $iconv_utf8->convert($message) ||
94 $message || return;
95 67 dpavlin
96 71 dpavlin if ($is_away) {
97 xlog('away', $sender, $message);
98 return;
99 } else {
100 73 dpavlin xlog('im_in', $sender, $message);
101 71 dpavlin }
102 66 dpavlin
103 # strip html from message
104 $message =~ s#</*(?:html|body|font|b|p)[^>]*?/*>##gsi;
105
106 105 dpavlin $config->{'last_sender_t'}->{$sender} = time();
107 $config->{'last_t'} = time();
108
109 if ($message =~ m#^!ping\s*(.*)$#) {
110 my $stamp = $1;
111
112 $config->{'ping'}->{$sender}->{'rcv'}++;
113 $config->{'ping'}->{$sender}->{'rcv_stamp'} = $stamp if ($stamp);
114 $config->{'nack_cnt'} = 0;
115
116 $stamp ||= '';
117 $stamp .= " -> ".int(time());
118 xsend_im($sender, "!pong $stamp") if ($sender ne $my_uin);
119 xlog('ping', $sender, $stamp);
120 return;
121 }
122
123
124 62 dpavlin # make user online and count it's messages
125 $config->{'online'}->{$sender}++;
126
127 70 dpavlin if ($sender ne $my_uin && # not me (bot)
128 62 dpavlin ! $config->{'members'}->{$sender} # not member
129 ) {
130 58 dpavlin $config->{'members'}->{$sender} = $sender;
131 62 dpavlin $config->{'online'}->{$sender}++;
132 58 dpavlin }
133
134 70 dpavlin # seen first time?
135 if ($config->{'online'}->{$sender} == 1) {
136 # send motd
137 72 dpavlin xsend_im($sender, $config->{'motd'}) if ($config->{'motd'});
138 70 dpavlin add_member($sender);
139 71 dpavlin xlog('add_member', $sender);
140 70 dpavlin }
141
142 58 dpavlin if ($message =~ m#^!nick\s+(.+)\s*$#) {
143 $config->{'members'}->{$sender} = $1;
144 72 dpavlin xsend_im($sender, "Your name will be: $1");
145 71 dpavlin xlog('nick', $sender, $1);
146 58 dpavlin save_config();
147 return;
148 }
149 59 dpavlin
150 63 dpavlin if ($message =~ m#^!invite\s+(\S+)\s+(.+)*\s*$#) {
151 70 dpavlin my ($uin, $nick) = ($1, $2);
152 72 dpavlin xsend_im($uin, "Your are joined to chat by ".uin2name($sender).". You screen name is: $nick");
153 xsend_im($sender, "You invited $nick [$uin] to join this chat.");
154 70 dpavlin add_member($uin, $nick);
155 71 dpavlin xlog('invite', $uin, $nick);
156 59 dpavlin return;
157 }
158 58 dpavlin
159 61 dpavlin if ($message =~ m#^!(?:skip|kick|leave|exit)\s*(\S*)\s*$#) {
160 58 dpavlin my $uin = $1 || $sender;
161 if ($config->{'members'}->{$uin}) {
162 61 dpavlin if ($uin == $sender) {
163 72 dpavlin xsend_im($sender, "You left group chat.");
164 71 dpavlin xlog('leave', $sender);
165 61 dpavlin } else {
166 72 dpavlin xsend_im($sender, "You kicked ".uin2name($uin)." out of this group.");
167 71 dpavlin xlog('leave', $uin, "kicked by $sender [".uin2name($sender)."]");
168 61 dpavlin }
169 70 dpavlin remove_member($uin);
170 58 dpavlin } else {
171 72 dpavlin xsend_im($sender, "UIN $uin is not member of group");
172 58 dpavlin }
173 return;
174 }
175
176 if ($message =~ m#^!config#) {
177 read_config();
178 72 dpavlin xsend_im($sender, "Configuration reloaded.");
179 71 dpavlin xlog('config', $sender, 'reloaded');
180 58 dpavlin return;
181 }
182 59 dpavlin
183 if ($message =~ m#^!(?:members*|list)#) {
184 71 dpavlin my $members = join(", ",
185 68 dpavlin map { uin2name($_) } keys %{ $config->{'online'} }
186 71 dpavlin );
187 72 dpavlin xsend_im($sender, "Group members: $members");
188 71 dpavlin xlog('members', $sender, $members);
189 59 dpavlin return;
190 }
191 58 dpavlin
192 if ($message =~ m#^!help#) {
193 73 dpavlin xsend_im($sender, $help);
194 71 dpavlin xlog('help', $sender);
195 58 dpavlin return;
196 }
197
198 60 dpavlin if ($message =~ m#^!fortune#) {
199 my $text = `fortune` || "Can't guess your fortune.";
200 chomp($text);
201 72 dpavlin xsend_im($sender, $text);
202 71 dpavlin xlog('fortune', $sender, $text);
203 60 dpavlin return;
204 }
205 58 dpavlin
206 62 dpavlin if ($message =~ m#^!debug#) {
207 68 dpavlin my $debug = Dump($config);
208 $debug =~ s/^passwd:.*$/passwd removed/m;
209 72 dpavlin xsend_im($sender, $debug);
210 71 dpavlin xlog('debug', $sender, $debug);
211 62 dpavlin return;
212 }
213 66 dpavlin
214 62 dpavlin if ($message =~ m#^!info\s+(\S+)\s*$#) {
215 63 dpavlin my $uin = $1;
216 89 dpavlin my $info = Dump($oscar->buddy($uin)) || "Can't get info for $uin [".uin2name($uin)."]";
217 72 dpavlin xsend_im($sender, $info);
218 71 dpavlin xlog('info', $sender, $info);
219 62 dpavlin return;
220 }
221
222 63 dpavlin if ($message =~ m#^!on-*line\s*(\S*)\s*$#) {
223 my $uin = $1;
224 71 dpavlin xlog('online', $sender, $uin);
225 63 dpavlin if ($uin && $config->{'members'}->{$uin}) {
226 $config->{'online'}->{$uin}++;
227 72 dpavlin xsend_im($sender, "Changed status of $uin to on-line.");
228 63 dpavlin } elsif ($uin) {
229 72 dpavlin xsend_im($sender, "UIN $uin is not member. Try !invite $uin [name] first");
230 63 dpavlin } else {
231 # check and list on-line members
232 72 dpavlin xsend_im($sender, "on-line members: ".
233 63 dpavlin join(", ", map { uin2name($_) } online_uins($oscar) ));
234 }
235 62 dpavlin return;
236 }
237
238 if ($message =~ m#^!(?:broadcast|all)#) {
239 foreach my $uin (keys %{$config->{'members'}}) {
240 $config->{'online'}->{$uin} = 1 unless ($config->{'online'}->{$uin});
241 }
242 72 dpavlin xsend_im($sender, "Your next message will be broadcasted to all members without regard to on-line flag.");
243 71 dpavlin xlog('broadcast', $sender);
244 62 dpavlin }
245
246 66 dpavlin if ($message =~ m#^!echo#) {
247 my $own;
248 75 dpavlin my $echo = $config->{'echo'}->{$sender};
249 66 dpavlin if ($echo) {
250 75 dpavlin $own = "not sent back";
251 delete($config->{'echo'}->{$sender});
252 66 dpavlin } else {
253 75 dpavlin $own = "sent back to sender";
254 $config->{'echo'}->{$sender}++;
255 66 dpavlin }
256 72 dpavlin xsend_im($sender, "own messages are $own");
257 73 dpavlin xlog('echo', $sender, $echo);
258 75 dpavlin save_config();
259 66 dpavlin return;
260 }
261
262 74 dpavlin if ($message =~ m#^!last\s*?(\d*)$#) {
263 my $nr = $1;
264 xsend_im($sender, "\n".xlast($nr));
265 xlog('last', $sender);
266 return;
267 }
268
269 104 dpavlin if ($message =~ m#^!rmskip\s+(\S+)\s*$#) {
270 my $uin = $1;
271 my $who = uin2name($uin)." [$uin]";
272
273 if ($config->{'skip_buddy'}->{$uin}) {
274 delete $config->{'skip_buddy'}->{$uin};
275 xsend_im($sender, "removed $who from skip list");
276 xlog('rmskip', $sender, $uin);
277 } else {
278 xsend_im($sender, "can't remove $who from skip list, not a member");
279 }
280 return;
281 }
282 105 dpavlin
283 74 dpavlin $message =~ s#&lt;br&gt;#\n#gis;
284
285 105 dpavlin if ($message =~ m#^!motd\s*?(.*)#s) {
286 67 dpavlin $config->{'motd'} = $1 || $motd;
287 72 dpavlin xsend_im($sender, "New MOTD is:\n".$config->{'motd'});
288 67 dpavlin save_config();
289 73 dpavlin xlog('motd', $sender);
290 67 dpavlin return;
291 }
292
293 73 dpavlin xlog('msg', $sender, $message);
294
295 105 dpavlin if ($message =~ m#^(!.*)#) {
296 xsend_im($sender, "Unknown command: $1");
297 xlog("unkown", $sender, $1);
298 return;
299 }
300
301 62 dpavlin # prefix with name
302 if ($sender ne $my_uin) {
303 63 dpavlin my $m = $message || return;
304 $message = "[".uin2name($sender)."] $m";
305 62 dpavlin }
306
307 foreach my $uin (keys %{$config->{'online'}}) {
308 75 dpavlin next if (! $config->{'echo'}->{$sender} && $uin eq $sender || $uin eq $my_uin);
309 72 dpavlin xsend_im($uin, $message);
310 58 dpavlin }
311 print "\n";
312 }
313
314 105 dpavlin sub xsend_all_except {
315 my $sender = shift || return;
316 my $message = shift || return;
317 foreach my $uin (keys %{$config->{'online'}}) {
318 # don't send to sender or bot
319 next if ($uin eq $sender or $uin eq $my_uin);
320 xsend_im($uin, $message);
321 }
322 }
323
324 62 dpavlin sub buddy_in {
325 my ($oscar, $uin) = @_;
326 warn "buddy in got empty uin\n" and return unless ($uin);
327 return if ($uin eq $my_uin);
328 $config->{'online'}->{$uin}++;
329 105 dpavlin xsend_all_except($uin, uin2name($uin)." joined chat.") if ($config->{'online'}->{$uin} == 1);
330 71 dpavlin xlog('buddy_in', $uin);
331 62 dpavlin save_config();
332 }
333
334 sub buddy_out {
335 my ($oscar, $uin) = @_;
336 return if ($uin eq $my_uin); # me?
337 delete($config->{'online'}->{$uin});
338 105 dpavlin xsend_all_except($uin, uin2name($uin)." left chat.");
339 71 dpavlin xlog('buddy_out', $uin);
340 62 dpavlin save_config();
341 }
342
343 70 dpavlin my $buddylist_commit_active = 0;
344
345 sub remove_member($) {
346 my $uin = shift || return;
347 delete ($config->{'online'}->{$uin});
348 $oscar->remove_buddy($buddy_group, $uin);
349 $oscar->commit_buddylist() if ($buddylist_commit_active == 0);
350 $buddylist_commit_active++;
351 71 dpavlin xlog('remove_member', $uin);
352 70 dpavlin }
353
354 sub add_member($$) {
355 my ($uin, $nick) = @_;
356 return unless ($uin && $nick);
357 $config->{'members'}->{$uin} = $nick;
358 $oscar->add_buddy($buddy_group, $uin);
359 71 dpavlin $oscar->add_permit($uin);
360 70 dpavlin $oscar->commit_buddylist() if ($buddylist_commit_active == 0);
361 $buddylist_commit_active++;
362 71 dpavlin xlog('add_member', $uin);
363 70 dpavlin }
364
365 62 dpavlin sub buddylist_ok {
366 my $oscar = shift;
367 70 dpavlin print "Buddy list commited with $buddylist_commit_active changes commited.\n";
368 $buddylist_commit_active = 0;
369 62 dpavlin save_config();
370 71 dpavlin xlog('buddylist_ok', $my_uin);
371 62 dpavlin }
372
373 sub buddylist_error {
374 my ($oscar, $error, $what) = @_;
375 if ($error = 14 && $what =~ m/(\d+)/) {
376 my $uin = $1;
377 104 dpavlin print "ERROR: $what [$error], adding $uin [",uin2name($uin),"] to skip buddy list\n";
378 62 dpavlin $config->{'skip_buddy'}->{$uin}++;
379 70 dpavlin remove_member($uin);
380 62 dpavlin } else {
381 print "ERROR: Buddy list commit failed [$error]: $what\n";
382 }
383 71 dpavlin xlog('buddylist_error', $my_uin, $what);
384 62 dpavlin }
385
386 sub online_uins($) {
387 my $oscar = shift || return;
388 my @online;
389 $config->{'online'} = {};
390 foreach my $uin (keys %{$config->{'members'}}) {
391 63 dpavlin next if ($uin eq $my_uin);
392 62 dpavlin my $info = $oscar->buddy($uin);
393 if ($info->{'online'}) {
394 $config->{'online'}->{$uin}++;
395 push @online, $uin;
396 }
397 }
398 71 dpavlin xlog('online_uins', $my_uin, join(", ", @online));
399 62 dpavlin save_config();
400 return @online;
401 }
402
403 sub signon_done {
404 my $oscar = shift;
405 my @buddies = $oscar->buddies();
406 print "adding buddies:\n";
407 foreach my $uin (keys %{$config->{'members'}}) {
408 my $status = 'old';
409 unless (grep(/^$uin$/, @buddies)) {
410 if ($config->{'skip_buddy'}->{$uin}) {
411 $status = 'SKIPPED';
412 } else {
413 $oscar->add_buddy($buddy_group, $uin);
414 67 dpavlin $oscar->set_buddy_alias($buddy_group, $uin, uin2name($uin));
415 62 dpavlin $status = 'NEW';
416 }
417 }
418 printf("%-10d : %s - %s buddy\n",
419 $uin,
420 uin2name($uin),
421 $status,
422 );
423 71 dpavlin xlog('signon_done', $uin, $status);
424 62 dpavlin }
425
426 # fixup (just in case) -- remove own uin from members and buddies
427 my $me = $my_uin;
428 $oscar->remove_buddy($buddy_group, $config->{$me});
429 delete($config->{'members'}->{$me});
430
431 $oscar->commit_buddylist();
432
433 print "on-line buddies:\n";
434 $config->{'online'} = {};
435 foreach my $uin (online_uins($oscar)) {
436 printf("%-10d : %s online\n", $uin, uin2name($uin));
437 }
438 save_config();
439 105 dpavlin
440 $signon_done++;
441 62 dpavlin }
442
443 105 dpavlin sub rate_alert {
444 my ($oscar, $level, $clear, $window, $worrisome) = @_;
445
446 my $msg = "$window messages max in $clear ms limit reached";
447
448 xlog('rate_alter', $my_uin, $level . " " . $msg);
449
450 print "# $msg - sleeping $clear ms\n";
451 select(undef, undef, undef, ($clear/100));
452
453 # if ($worrisome) {
454 # xsend_im($my_uin, $msg);
455 # }
456 }
457
458 sub error {
459 my ($oscar, $connection, $error, $description, $fatal) = @_;
460
461 xlog('error', $my_uin, $description);
462 print "ERROR [$error]: $description\n";
463
464 if ($fatal) {
465 $signon_done = 0;
466 print "# repeating sign-on\n";
467 $oscar->signon($my_uin, $config->{'passwd'}) || die "can't sign on as $my_uin";
468 }
469
470 }
471
472 71 dpavlin ## DSN logging support
473
474 73 dpavlin my ($dbh,$sth_log, $sth_sent, $sth_sent_ok, $sth_last);
475 71 dpavlin
476 sub create_log_table {
477 $dbh ||= connect_db();
478 return unless ($dbh);
479
480 # exit if table exists
481 return if ($dbh->do("select * from log limit 1"));
482
483 print "# creating log table in $dsn\n";
484 72 dpavlin $dbh->do(q{
485 71 dpavlin create table log (
486 id serial,
487 date timestamp default now(),
488 bot text not null,
489 type text not null,
490 uin text not null,
491 name text not null,
492 message text,
493 primary key(id)
494 )
495 72 dpavlin }) || die $dbh->errstr();
496 71 dpavlin $dbh->do(qq{ create index log_date on log(date) }) or die $dbh->errstr();
497 $dbh->do(qq{ create index log_bot on log(bot) }) or die $dbh->errstr();
498 $dbh->do(qq{ create index log_type on log(type) }) or die $dbh->errstr();
499 $dbh->do(qq{ create index log_uin on log(uin) }) or die $dbh->errstr();
500 $dbh->do(qq{ create index log_name on log(name) }) or die $dbh->errstr();
501 72 dpavlin $dbh->do(qq{
502 create table sent (
503 date timestamp default now(),
504 bot text not null,
505 uin text not null,
506 name text not null,
507 r_id text not null,
508 message text,
509 sent boolean default false,
510 primary key(r_id)
511 )
512 });
513 71 dpavlin }
514
515 72 dpavlin sub connect_db {
516 return unless ($config->{'dsn'});
517 return if ($dbh);
518
519 require DBI;
520 print "# using $dsn for log\n";
521 $dbh = DBI->connect($config->{'dsn'},"","") || die $DBI::errstr;
522
523 return $dbh;
524 }
525
526 71 dpavlin sub xlog {
527 my ($type,$uin, $message) = @_;
528
529 my $name = uin2name($uin);
530
531 print localtime()." $type: $uin [$name] ", ( $message || '' ),"\n";
532
533 72 dpavlin return unless ($dbh);
534 71 dpavlin
535 72 dpavlin $sth_log ||= $dbh->prepare(qq{
536 insert into log (bot,type,uin,name,message) values (?,?,?,?,?)
537 }) || die $dbh->errstr();
538
539 $sth_log->execute($my_uin, $type, $uin, $name, $message) || print "$type: [$uin] $message";
540 71 dpavlin }
541
542 72 dpavlin sub xsend_im {
543 my ($who, $message, $away) = @_;
544 71 dpavlin
545 72 dpavlin my $r_id = $oscar->send_im($who, $message, $away);
546 print "# sent $who $r_id\n";
547
548 return unless ($dbh);
549
550 105 dpavlin if (! $r_id) {
551