root/lang/perl/plum/plum @ 30290

Revision 3664, 61.2 kB (checked in by knu, 5 years ago)

lang/perl/plum: Introduce &'abspath() and handle relative paths properly.

  • Property svn:executable set to *
Line 
1#!/usr/bin/perl -w
2# $Id: plum 103 2007-12-14 09:48:32Z knu $
3# Copyright (c)1997-2000 Yoshinori Hasegawa <hasegawa@madoka.org>
4
5package plum;
6
7$NAME = 'plum';
8$VERSION = '3.1.0b18';
9
10$NIL = "\r";
11$NOTRAILING = &'list('004', '215', '221', '324', '341', '367', 'MODE');
12
13$ALIAS = '*.jp';
14$EOL = "\r\n";
15
16$INTERVAL = 30;
17$PORT = 6667;
18$BUFFER = 2048;
19$LISTEN = 16;
20
21$SOCKADDR = 'S n a4 x8';
22
23$PROTO = (getprotobyname('tcp'))[2];
24
25if ($] < 5) {
26  foreach $inc (@INC) {
27    if (-r "$inc/sys/socket.ph") {
28      eval 'require "sys/socket.ph"';
29      $SOCKET = "$inc/sys/socket.ph" unless $@;
30      last;
31    }
32    if (-r "$inc/socket.ph") {
33      eval 'require "socket.ph"';
34      $SOCKET = "$inc/socket.ph" unless $@;
35      last;
36    }
37  }
38} else {
39  eval 'use Socket';
40  $SOCKET = 'Socket.pm' unless $@;
41  eval 'use Socket6';
42  $SOCKET = 'Socket6.pm' unless $@;
43}
44
45$PF_INET = eval '&PF_INET';
46$AF_INET = eval '&AF_INET';
47$PF_INET6 = eval '&PF_INET6';
48$AF_INET6 = eval '&AF_INET6';
49$SOCK_STREAM = eval '&SOCK_STREAM';
50$INADDR_ANY = eval '&INADDR_ANY';
51$IN6ADDR_ANY = eval '&in6addr_any';
52$SOMAXCONN = eval '&SOMAXCONN';
53$SOL_SOCKET = eval '&SOL_SOCKET';
54$SO_REUSEADDR = eval '&SO_REUSEADDR';
55
56$SIG{'HUP'} = 'IGNORE' if &'exist(&'list(keys(%SIG)), 'HUP');
57$SIG{'PIPE'} = 'IGNORE' if &'exist(&'list(keys(%SIG)), 'PIPE');
58
59if ($0 =~ /^(.*)[\\\/][^\\\/]*$/) {
60  unshift(@INC, "$1/module");
61} else {
62  unshift(@INC, './module');
63}
64
65select((select(STDOUT), $| = 1)[0]);
66select((select(STDERR), $| = 1)[0]);
67
68$'rin = '';
69$'win = '';
70$'rout = '';
71$'wout = '';
72
73$sockethandle = '*';
74
75@alarm = ();
76$alarm = 0;
77
78srand();
79
80&init(@ARGV);
81
82exit unless @'username > 1;
83
84print $NAME, ' ', $VERSION, "\n";
85
86&main;
87
88sub main {
89  local($i, $time, $next, $timeout, $nfound, $timeleft);
90  &'alarm(-1);
91  while (1) {
92    if (@alarm && $alarm) {
93      if ($alarm[0] < $alarm) {
94        $next = $alarm[0];
95      } else {
96        $next = $alarm;
97      }
98    } elsif (@alarm) {
99      $next = $alarm[0];
100    } elsif ($alarm) {
101      $next = $alarm;
102    } else {
103      $next = 0;
104    }
105    $time = time();
106    if (!$next) {
107      $timeout = undef;
108    } elsif ($time < $next) {
109      $timeout = $next - $time;
110    } else {
111      $timeout = 0;
112    }
113    ($nfound, $timeleft) = select($'rout = $'rin, $'wout = $'win, undef, $timeout);
114    $time = time();
115    $alarm = 0;
116    while (@alarm && $alarm[0] < $time) {
117      shift(@alarm);
118    }
119    for ($i = 1; $i < length($sockethandle); $i++) {
120      next if substr($sockethandle, $i, 1) eq ' ';
121      $'access[$i] = $time if vec($'rout, $'fileno[$i], 1);
122    }
123    for ($i = 1; $i < @'username; $i++) {
124      &loop_event($i, 'main_loop', $i);
125    }
126    foreach $cno (&'array($'clientlist)) {
127      &c_write($cno) if vec($'wout, $'fileno[$cno], 1);
128      &c_read($cno) if vec($'rout, $'fileno[$cno], 1);
129    }
130    foreach $sno (&'array($'serverlist)) {
131      &s_write($sno) if vec($'wout, $'fileno[$sno], 1);
132      &s_read($sno) if vec($'rout, $'fileno[$sno], 1);
133    }
134  }
135}
136
137sub 'alarm {
138  local($wait) = @_;
139  local($time, $i);
140  if (!$wait) {
141    $time = 0;
142  } elsif ($wait > 0) {
143    $time = time() + $wait;
144    for ($i = 0; $i < @alarm; $i++) {
145      last if $alarm[$i] > $time;
146    }
147    splice(@alarm, $i, 0, $time);
148  } else {
149    $time = time() - $wait;
150    if (!$alarm || $alarm > $time) {
151      $alarm = $time;
152    }
153  }
154  return $time;
155}
156
157sub init {
158  local(@args) = @_;
159  local($line, $i, $userno, @key, $user, @lib);
160  if (fileno('\'DATA')) {
161    while (defined($line = <'DATA>)) {
162      $line =~ tr/\r\n//d;
163      if ($line =~ /^\@(\w+)\s+\d+\-\d+\s+(\S+)$/) {
164        $builtin{$2} = $1;
165      }
166    }
167  }
168  @'username = ('*');
169  if (-r "$NAME.conf") {
170    push(@'username, '');
171    &'load('', "$NAME.conf");
172  }
173  for ($i = 0; $i < @args; $i++) {
174    if (index($args[$i], '+') == 0) {
175      @lib = split(/\+/, substr($args[$i], 1));
176      foreach $lib (@lib) {
177        if (-r "$NAME-$lib.conf") {
178          for ($userno = 1; $userno < @'username; $userno++) {
179            $'userlist[$userno] = &'add($'userlist[$userno], $lib);
180            &'merge($userno, "$NAME-$lib.conf");
181          }
182        }
183      }
184    } elsif (substr($args[$i], 0, 1) eq '-') {
185    } else {
186      ($user, @lib) = split(/\+/, $args[$i]);
187      if (-r "$NAME-$user.conf") {
188        if (!&userno($user)) {
189          push(@'username, $user);
190          &'load($user, "$NAME-$user.conf");
191          $userno = @'username - 1;
192          foreach $lib (@lib) {
193            $'userlist[$userno] = &'add($'userlist[$userno], $lib);
194            &'merge($userno, "$NAME-$lib.conf") if -r "$NAME-$lib.conf";
195          }
196        }
197      }
198    }
199  }
200  for ($userno = 1; $userno < @'username; $userno++) {
201    &enable($userno, &'list($NAME), $'modulelist[$userno]);
202  }
203}
204
205sub 'reload {
206  local($userno) = @_;
207  local($old, $file, $list, $new);
208  $old = $'modulelist[$userno];
209  ($file, $list) = &'shift($'filename[$userno]);
210  &'load($'username[$userno], $file);
211  foreach $file (&'array($list)) {
212    &'merge($userno, $file);
213  }
214  $new = $'modulelist[$userno];
215  &enable($userno, $old, $new);
216  &disable($userno, $old, $new);
217}
218
219sub 'load {
220  local($user, $file) = @_;
221  local($userno, $no);
222  $userno = &userno($user);
223  $no = $userno . $;;
224  foreach $key (keys(%property)) {
225    next unless index($key, $no) == 0;
226    delete $property{$key};
227  }
228  $'filename[$userno] = '';
229  $'modulelist[$userno] = &'list($NAME);
230  &'merge($userno, $file);
231}
232
233sub 'merge {
234  local($userno, $file) = @_;
235  local($line, $pkg, $dir, $name, $sub, $var, $arg, @key, *CONF, $conf);
236  if (open(CONF, $file)) {
237    $'filename[$userno] = &'add($'filename[$userno], $file);
238    while (defined($line = <CONF>)) {
239      $line =~ s/^\s+//;
240      next if $line =~ /^[\#\;]/;
241      $line =~ s/\s+$//;
242      next unless $line;
243      if ($line =~ /^\+\s*(.+)/) {
244        if (!($pkg = $'package{$1})) {
245          $pkg = &'import($1);
246        }
247        $'modulelist[$userno] = &'add($'modulelist[$userno], $pkg);
248      } elsif ($line =~ /^\-\s*(.+)/) {
249        if ($pkg = $'package{$1}) {
250          $'modulelist[$userno] = &'remove($'modulelist[$userno], $pkg);
251        }
252      } elsif ($line =~ /^\.\s+(.+)/) {
253        $conf = &'abspath($userno, $1);
254        &'merge($userno, $conf) if -f $conf;
255      } elsif ((($var, $arg) = split(/\s*\:\s*/, $line, 2)) == 2) {
256        $arg = &kanji_utf8($userno, $arg);
257        @key = split(/\./, $var);
258        $property{$userno, @key} = &'add($property{$userno, @key}, $arg);
259      }
260    }
261    close(CONF);
262  }
263}
264
265sub 'import {
266  local($name) = @_;
267  local($pkg, $path, $sub);
268  if ($pkg = $'package{$name}) {
269    if ($path = $'filename{$pkg}) {
270      delete $INC{$path};
271    }
272  }
273  ($pkg, $path) = &require($name);
274  $'package{$name} = $pkg;
275  $'filename{$pkg} = $path;
276  $sub = $pkg . '\'initialize';
277  &$sub;
278  return $pkg;
279}
280
281sub require {
282  local($name) = @_;
283  local($pkg, $file);
284  if ($builtin{$name}) {
285    return ($builtin{$name}, '');
286  }
287  foreach $dir (&'property($userno, 'directory'), @INC) {
288    $file = &'expand("$dir/$name");
289    next unless -f $file;
290    $_ = $NAME;
291    require $file;
292    return ($_, $file);
293  }
294  $file = &'expand($name);
295  $_ = $NAME;
296  require $file;
297  return ($_, $file);
298}
299
300sub 'property {
301  local($userno, $name) = @_;
302  local(@pkg, $list);
303  @pkg = split(/_/, (caller())[0]);
304  $list = $property{$userno, @pkg, $name};
305  if (defined($list)) {
306    if (wantarray) {
307      return &'array($list);
308    } else {
309      return (&'array($list))[0];
310    }
311  } else {
312    if (wantarray) {
313      return ();
314    } else {
315      return undef;
316    }
317  }
318}
319
320sub 'abspath {
321  local($userno, @paths) = @_;
322
323  my $dir = &'property($userno, 'directory');
324  unshift(@paths, $dir) if $dir ne '';
325
326  use Cwd;
327  unshift(@paths, cwd);
328
329  my $abspath;
330
331  while (@paths) {
332      my $path = pop(@paths);
333
334      next if $path eq '';
335
336      if ($abspath eq '') {
337          $abspath = &'expand($path);
338      } else {
339          $abspath = &'expand($path) . '/' . $abspath;
340      }
341
342      return $abspath if $abspath =~ /^\//;
343  }
344
345  # NOTREACHED
346  return '.';
347}
348
349sub userno {
350  local($user) = @_;
351  local($i);
352  for ($i= 1; $i < @'username; $i++) {
353    if ($user eq $'username[$i]) {
354      return $i;
355    }
356  }
357  return 0;
358}
359
360sub kanji_utf8 {
361  local($userno, $line) = @_;
362  local($code);
363
364  use Encode;
365
366  $code = (reverse(&'property($userno, 'kanji')))[0] || '';
367  if ($code eq 'euc') {
368    $line = &'euc_utf8($line);
369  } elsif ($code eq 'jis') {
370    $line = &'jis_utf8($line);
371  } elsif ($code eq 'sjis') {
372    $line = &'sjis_utf8($line);
373  } elsif ($code eq 'utf8') {
374    $line = &'utf8_utf8($line);
375  }
376  return $line;
377}
378
379sub enable {
380  local($userno, $old, $new) = @_;
381  local(@list, $event, $sub);
382  foreach $module (&'array($new)) {
383    if (!&'exist($old, $module)) {
384      $sub = $module . '\'module_enable';
385      if ($] < 5) {
386        &$sub($userno) if eval "defined(&$sub)";
387      } else {
388        &$sub($userno) if defined(&$sub);
389      }
390    } else {
391      $sub = $module . '\'property_change';
392      if ($] < 5) {
393        &$sub($userno) if eval "defined(&$sub)";
394      } else {
395        &$sub($userno) if defined(&$sub);
396      }
397    }
398  }
399}
400
401sub disable {
402  local($userno, $old, $new) = @_;
403  local($sub);
404  foreach $module (&'array($old)) {
405    if (!&'exist($new, $module)) {
406      $sub = $module . '\'module_disable';
407      if ($] < 5) {
408        &$sub($userno) if eval "defined(&$sub)";
409      } else {
410        &$sub($userno) if defined(&$sub);
411      }
412    }
413  }
414}
415
416sub c_read {
417  local($cno) = @_;
418  local($tmp);
419  $tmp = '';
420  if (sysread($'socket[$cno], $tmp, $BUFFER)) {
421    &c_parse($cno, $tmp);
422  } else {
423    &'c_close($cno);
424  }
425}
426
427sub c_parse {
428  local($cno, $tmp) = @_;
429  local($next, $rest, $prefix, $cmd, @params);
430  $rbuf[$cno] .= $tmp;
431  while ((($next, $rest) = split(/[\r\n]+/, $rbuf[$cno], 2)) == 2) {
432    $rbuf[$cno] = $rest || '';
433    next unless $next;
434    $next = &read_event($'userno[$cno], 'client_read', $cno, $next);
435    next unless $next;
436    ($prefix, $cmd, @params) = &'parse($next);
437    ($prefix, $cmd, @params) = &scan_event($'userno[$cno], "cs_\L$cmd\E", $cno, $prefix, $cmd, @params);
438    next unless $cmd;
439    &'s_print($'server[$cno], $prefix, $cmd, @params) if $'server[$cno];
440  }
441}
442
443sub c_write {
444  local($cno) = @_;
445  local($socket, $next);
446  $socket = $'socket[$cno];
447  while ($wbuf{$cno}) {
448    ($next, $wbuf{$cno}) = &'shift($wbuf{$cno});
449    next unless $next;
450    $next = &write_event($'userno[$cno], 'client_write', $cno, $next);
451    next unless $next;
452    print $socket $next, $EOL if fileno($socket);
453  }
454  vec($'win, $'fileno[$cno], 1) = 0;
455}
456
457sub 'c_print {
458  local($cno, $prefix, $cmd, @params) = @_;
459  ($prefix, $cmd, @params) = &print_event($'userno[$cno], "cp_\L$cmd\E", $cno, $prefix, $cmd, @params);
460  return unless $cmd;
461  $wbuf{$cno} = &'append($wbuf{$cno}, &'build($prefix, $cmd, @params));
462  vec($'win, $'fileno[$cno], 1) = 1;
463}
464
465sub 'c_flush {
466  local($cno) = @_;
467  while (vec($'win, $'fileno[$cno], 1)) {
468    &c_write($cno);
469  }
470}
471
472sub 'c_open {
473  local($cno, $userno, $prefix, $sno, $buf) = @_;
474  ($'nick[$cno], $'user[$cno], $'address[$cno]) = &'prefix($prefix);
475  $'server[$cno] = $sno;
476  $'userno[$cno] = $userno;
477  $rbuf[$cno] = '';
478  $'clientlist = &'add($'clientlist, $cno);
479  vec($'rout, $'fileno[$cno], 1) = 0;
480  if (&'exist($'serverlist, $sno)) {
481    $'servername[$cno] = $'servername[$sno];
482  } else {
483    $'servername[$cno] = $NAME;
484  }
485  &open_event($userno, 'client_open', $cno);
486  &c_parse($cno, $buf || '');
487}
488
489sub 'c_close {
490  local($cno) = @_;
491  local($buf);
492  $sequence[$cno] = '';
493  delete $wbuf{$cno};
494  $'clientlist = &'remove($'clientlist, $cno);
495  &close_event($'userno[$cno], 'client_close', $cno);
496  $'nick[$cno] = '';
497  $'user[$cno] = '';
498  $'address[$cno] = '';
499  $'server[$cno] = 0;
500  $buf = $rbuf[$cno];
501  $rbuf[$cno] = '';
502  return $buf;
503}
504
505sub s_read {
506  local($sno) = @_;
507  local($tmp);
508  $tmp = '';
509  if (sysread($'socket[$sno], $tmp, $BUFFER)) {
510    &s_parse($sno, $tmp);
511  } else {
512    &'s_close($sno);
513  }
514}
515
516sub s_parse {
517  local($sno, $tmp) = @_;
518  local($next, $rest, $prefix, $cmd, @params);
519  $rbuf[$sno] .= $tmp;
520  while ((($next, $rest) = split(/[\r\n]+/, $rbuf[$sno], 2)) == 2) {
521    $rbuf[$sno] = $rest || '';
522    next unless $next;
523    $next = &read_event($'userno[$sno], 'server_read', $sno, $next);
524    next unless $next;
525    ($prefix, $cmd, @params) = &'parse($next);
526    ($prefix, $cmd, @params) = &scan_event($'userno[$sno], "ss_\L$cmd\E", $sno, $prefix, $cmd, @params);
527    next unless $cmd;
528    foreach $cno (&'array($'clientlist)) {
529      next unless $'server[$cno] == $sno;
530      &'c_print($cno, $prefix, $cmd, @params);
531    }
532  }
533}
534
535sub s_write {
536  local($sno) = @_;
537  local($socket, $time, $cmd, $key, $next);
538  $socket = $'socket[$sno];
539  $time = time();
540  $timer[$sno] = $time if ($timer[$sno] || 0) < $time;
541  while ($sequence[$sno]) {
542    if ($timer[$sno] > $time + 10) {
543      return;
544    } else {
545      ($cmd, $sequence[$sno]) = &'shift($sequence[$sno]);
546      $key = "$sno$;$cmd";
547      ($next, $wbuf{$key}) = &'shift($wbuf{$key});
548      $sequence[$sno] = &'add($sequence[$sno], $cmd) if $wbuf{$key};
549      next unless $next;
550      $next = &write_event($'userno[$sno], 'server_write', $sno, $next);
551      next unless $next;
552      print $socket $next, $EOL if fileno($socket);
553      $timer[$sno] += 2;
554    }
555  }
556  $sequence[$sno] = '';
557  vec($'win, $'fileno[$sno], 1) = 0;
558}
559
560sub 's_print {
561  local($sno, $prefix, $cmd, @params) = @_;
562  local($key);
563  return unless &'exist($'serverlist, $sno);
564  ($prefix, $cmd, @params) = &print_event($'userno[$sno], "sp_\L$cmd\E", $sno, $prefix, $cmd, @params);
565  return unless $cmd;
566  $key = "$sno$;\U$cmd\E";
567  $wbuf{$key} = &'append($wbuf{$key}, &'build($prefix, $cmd, @params));
568  $sequence[$sno] = &'add($sequence[$sno], "\U$cmd\E");
569  vec($'win, $'fileno[$sno], 1) = 1;
570}
571
572sub 's_flush {
573  local($sno) = @_;
574  while (vec($'win, $'fileno[$sno], 1)) {
575    &s_write($sno);
576  }
577}
578
579sub 's_open {
580  local($sno, $userno, $prefix, $name, $buf) = @_;
581  ($'nick[$sno], $'user[$sno], $'address[$sno]) = &'prefix($prefix);
582  $'userno[$sno] = $userno;
583  $'servername[$sno] = $name;
584  $rbuf[$sno] = '';
585  $'serverlist = &'add($'serverlist, $sno);
586  vec($'rout, $'fileno[$sno], 1) = 0;
587  &open_event($userno, 'server_open', $sno);
588  &s_parse($sno, $buf || '');
589}
590
591sub 's_close {
592  local($sno) = @_;
593  local($no, $buf);
594  $sequence[$sno] = '';
595  $no = $sno . $;;
596  foreach $key (keys(%wbuf)) {
597    next unless index($key, $no) == 0;
598    delete $wbuf{$key};
599  }
600  $'serverlist = &'remove($'serverlist, $sno);
601  &close_event($'userno[$sno], 'server_close', $sno);
602  $'nick[$sno] = '';
603  $'user[$sno] = '';
604  $'address[$sno] = '';
605  $'servername[$sno] = '';
606  $buf = $rbuf[$sno];
607  $rbuf[$sno] = '';
608  return $buf;
609}
610
611sub open_event {
612  local($userno, $event, $no) = @_;
613  foreach $sub (&sub_list($userno, $event)) {
614    &$sub($no);
615  }
616}
617
618sub close_event {
619  local($userno, $event, $no) = @_;
620  foreach $sub (reverse(&sub_list($userno, $event))) {
621    &$sub($no);
622  }
623}
624
625sub read_event {
626  local($userno, $event, $no, $msg) = @_;
627  foreach $sub (&sub_list($userno, $event)) {
628    $msg = &$sub($no, $msg);
629    return '' unless $msg;
630  }
631  return $msg;
632}
633
634sub write_event {
635  local($userno, $event, $no, $msg) = @_;
636  foreach $sub (reverse(&sub_list($userno, $event))) {
637    $msg = &$sub($no, $msg);
638    return '' unless $msg;
639  }
640  return $msg;
641}
642
643sub scan_event {
644  local($userno, $event, $no, $prefix, $cmd, @params) = @_;
645  foreach $sub (&sub_list($userno, $event)) {
646    ($prefix, $cmd, @params) = &$sub($no, $prefix, $cmd, @params);
647    return () unless $cmd;
648  }
649  return ($prefix, $cmd, @params);
650}
651
652sub print_event {
653  local($userno, $event, $no, $prefix, $cmd, @params) = @_;
654  foreach $sub (reverse(&sub_list($userno, $event))) {
655    ($prefix, $cmd, @params) = &$sub($no, $prefix, $cmd, @params);
656    return () unless $cmd;
657  }
658  return ($prefix, $cmd, @params);
659}
660
661sub loop_event {
662  local($userno, $event, $no) = @_;
663  foreach $sub (&sub_list($userno, $event)) {
664    &$sub($no);
665  }
666}
667
668sub sub_list {
669  local($userno, $event) = @_;
670  local(@list, $name, $sub);
671  @list = ();
672  $name = '\'' . $event;
673  if ($] < 5) {
674    foreach $module (&'array($'modulelist[$userno])) {
675      $sub = $module . $name;
676      push(@list, $sub) if eval "defined(&$sub)";
677    }
678  } else {
679    foreach $module (&'array($'modulelist[$userno])) {
680      $sub = $module . $name;
681      push(@list, $sub) if defined(&$sub);
682    }
683  }
684  return @list;
685}
686
687sub 'socket {
688  local($prefix) = @_;
689  local($no);
690  $no = index($sockethandle . ' ', ' ');
691  substr($sockethandle, $no, 1) = $prefix;
692  $'socket[$no] = '\'' . $prefix . $no;
693  $'fileno[$no] = 0;
694  return $no;
695}
696
697sub 'connect {
698  local($no, $host, $port) = @_;
699  local($addr, $family, $sin);
700  $addr = &'address($host) || return 0;
701  if (length($addr) == 4) {
702    $family = $PF_INET || $AF_INET || 2;
703    if (defined(&pack_sockaddr_in)) {
704      $sin = &pack_sockaddr_in($port, $addr);
705    } else {
706      $sin = pack($SOCKADDR, $AF_INET || $PF_INET || 2, $port, $addr);
707    }
708  } elsif (length($addr) == 16) {
709    $family = $PF_INET6 || $AF_INET6 || return 0;
710    if (defined(&pack_sockaddr_in6)) {
711      $sin = &pack_sockaddr_in6($port, $addr);
712    } else {
713      return 0;
714    }
715  } else {
716    return 0;
717  }
718  socket($'socket[$no], $family, $SOCK_STREAM || 1, $PROTO || 6) || return 0;
719  connect($'socket[$no], $sin) || return 0;
720  &setup($no);
721  return 1;
722}
723
724sub 'listen {
725  local($no, $port, $count) = @_;
726  local($addr, $sin);
727  socket($'socket[$no], $PF_INET || $AF_INET || 2, $SOCK_STREAM || 1, $PROTO || 6) || return 0;
728  if (defined($SOL_SOCKET) && defined($SO_REUSEADDR)) {
729    setsockopt($'socket[$no], $SOL_SOCKET, $SO_REUSEADDR, pack('l', 1));
730  }
731  $addr = $INADDR_ANY || "\0" x 4;
732  if (defined(&pack_sockaddr_in)) {
733    $sin = &pack_sockaddr_in($port, $addr);
734  } else {
735    $sin = pack($SOCKADDR, $AF_INET || $PF_INET || 2, $port, $addr);
736  }
737  if (!bind($'socket[$no], $sin)) {
738    close($'socket[$no]);
739    return 0;
740  }
741  listen($'socket[$no], $count || $SOMAXCONN || $LISTEN) || return 0;
742  &setup($no);
743  return 1;
744}
745
746sub 'listen6 {
747  local($no, $port, $count) = @_;
748  local($addr, $sin);
749  return 0 unless ($PF_INET6 || $AF_INET6);
750  socket($'socket[$no], $PF_INET6 || $AF_INET6, $SOCK_STREAM || 1, $PROTO || 6) || return 0;
751  if (defined($SOL_SOCKET) && defined($SO_REUSEADDR)) {
752    setsockopt($'socket[$no], $SOL_SOCKET, $SO_REUSEADDR, pack('l', 1));
753  }
754  $addr = $IN6ADDR_ANY || "\0" x 16;
755  if (defined(&pack_sockaddr_in6)) {
756    $sin = &pack_sockaddr_in6($port, $addr);
757  } else {
758    close($'socket[$no]);
759    return 0;
760  }
761  if (!bind($'socket[$no], $sin)) {
762    close($'socket[$no]);
763    return 0;
764  }
765  listen($'socket[$no], $count || $SOMAXCONN || $LISTEN) || return 0;
766  &setup($no);
767  return 1;
768}
769
770sub 'accept {
771  local($no, $lno) = @_;
772  accept($'socket[$no], $'socket[$lno]) || return 0;
773  &setup($no);
774  return 1;
775}
776
777sub 'close {
778  local($no, $flag) = @_;
779  close($'socket[$no]) if fileno($'socket[$no]);
780  vec($'rin, $'fileno[$no], 1) = 0;
781  $'fileno[$no] = 0;
782  if (!$flag) {
783    $'socket[$no] = '';
784    $'access[$no] = 0;
785    substr($sockethandle, $no, 1) = ' ';
786  }
787}
788
789sub 'sockname {
790  local($no) = @_;
791  return &addrinfo(getsockname($'socket[$no]));
792}
793
794sub 'peername {
795  local($no) = @_;
796  return &addrinfo(getpeername($'socket[$no]));
797}
798
799sub 'address {
800  local($host) = @_;
801  local($sin, $addr);
802  if (defined(&getaddrinfo)) {
803    $sin = (&getaddrinfo($host, ''))[3];
804    $addr = (&addrinfo($sin))[1];
805    return $addr if $addr;
806  }
807  if (defined(&inet_pton)) {
808    if (defined($AF_INET6) || defined($PF_INET6)) {
809      $addr = &inet_pton($AF_INET6 || $PF_INET6, $host);
810      return $addr if $addr;
811    }
812    $addr = &inet_pton($AF_INET || $PF_INET || 2, $host);
813    return $addr if $addr;
814  }
815  if (defined(&inet_aton)) {
816    $addr = &inet_aton($host);
817    return $addr if $addr;
818  }
819  if ($host =~ /^\d+$/) {
820    $addr = pack('N', $host);
821  } elsif ($host =~ /^(\d*)(\.(\d*)(\.(\d*))?)?\.(\d*)$/) {
822    $addr = pack('C4', $1 || 0, $3 || 0, $5 || 0, $6 || 0);
823  } else {
824    $addr = (gethostbyname($host))[4];
825  }
826  return $addr;
827}
828
829sub addrinfo {
830  local($sin) = @_;
831  local($port, $addr, $host);
832  if (!defined($sin) || length($sin) < 16) {
833    return ();
834  } elsif (length($sin) == 16) {
835    if (defined(&unpack_sockaddr_in)) {
836      ($port, $addr) = &unpack_sockaddr_in($sin);
837    } else {
838      ($port, $addr) = (unpack($SOCKADDR, $sin))[1, 2];
839    }
840    if ($addr ne "\0" x length($addr)) {
841      $host = (gethostbyaddr($addr, $AF_INET || $PF_INET || 2))[0];
842    }
843  } elsif (defined(&unpack_sockaddr_in6)) {
844    ($port, $addr) = &unpack_sockaddr_in6($sin);
845    if (($AF_INET6 || $PF_INET6) && $addr ne "\0" x length($addr)) {
846      $host = (gethostbyaddr($addr, $AF_INET6 || $PF_INET6))[0];
847    }
848  } else {
849    return ();
850  }
851  return ($port, $addr, $host);
852}
853
854sub setup {
855  local($no) = @_;
856  binmode($'socket[$no]);
857  $'fileno[$no] = fileno($'socket[$no]);
858  vec($'rin, $'fileno[$no], 1) = 1;
859  select((select($'socket[$no]), $| = 1)[0]);
860  $'access[$no] = time();
861}
862
863sub 'match {
864  local($no, @list) = @_;
865  local($port, $addr, $host, $net, $len, $bit, $src, $str);
866  ($port, $addr, $host) = &'peername($no);
867  if ($addr) {
868    foreach $item (@list) {
869      ($net, $len) = split(/\//, $item);
870      if ($len) {
871        $bit = unpack('B*', $addr);
872        $src = unpack('B*', &'address($net));
873        return 1 if substr($bit, 0, $len) eq substr($src, 0, $len);
874      } else {
875        $str = &'regex($net);
876        if ($host) {
877          return 1 if $host =~ /$str/i;
878        }
879        if (length($addr) == 4) {
880          $host = join('.', unpack('C4', $addr));
881        } elsif (length($addr) == 16) {
882          $host = join(':', unpack('H4' x 8, $addr));
883        }
884        return 1 if $host =~ /$str/i;
885      }
886    }
887  }
888  return 0;
889}
890
891sub 'user {
892  local($no, $nick, $user, $host) = @_;
893  local($userno, $unick, $uuser, $uhost, $addr, @addr);
894  return 'unknown' unless $no;
895  $userno = $'userno[$no];
896  $unick = $nick || $'nick[$no] || '';
897  $uuser = $user || $'user[$no] || '';
898  $uhost = $host || $'address[$no] || '';
899  if (!$uhost) {
900    if ($no && $'socket[$no] && fileno($'socket[$no])) {
901      ($addr, $uhost) = (&'peername($no))[1, 2];
902      if (!$uhost) {
903        if ($addr && length($addr) == 4) {
904          $uhost = join('.', unpack('C4', $addr));
905        } elsif ($addr && length($addr) == 16) {
906          $uhost = join(':', unpack('H4' x 8, $addr));
907        } else {
908          $uhost = 'unknown';
909        }
910      }
911    } else {
912      $uhost = 'unknown';
913    }
914  }
915  return "$unick\!$uuser\@$uhost";
916}
917
918sub 'parse {
919  local($line) = @_;
920  local($arg, $rest, @params);
921  @params = ();
922  $line =~ s/^\s*//;
923  if ($line =~ /^\:(.*)$/) {
924    ($arg, $rest) = (split(/\s+/, $1, 2), '');
925  } else {
926    ($arg, $rest) = ('', $line);
927  }
928  while ($line) {
929    push(@params, $arg);
930    if ($rest =~ /^\:(.*)$/) {
931      push(@params, $1);
932      last;
933    }
934    $line = $rest;
935    ($arg, $rest) = (split(/\s+/, $line, 2), '');
936  }
937  return @params;
938}
939
940sub 'build {
941  local($prefix, $cmd, @params) = @_;
942  local($trailing);
943  return '' unless $cmd;
944  if (@params) {
945    $trailing = pop(@params) || '';
946    if (&'exist($NOTRAILING, "\U$cmd\E")) {
947      push(@params, $trailing . ' ');
948    } else {
949      push(@params, ':' . $trailing);
950    }
951  } else {
952    @params = ();
953  }
954  unshift(@params, $cmd);
955  unshift(@params, ':' . $prefix) if $prefix;
956  return join(' ', @params);
957}
958
959sub 'prefix {
960  local($prefix) = @_;
961  local($idx, $rest, $nick, $user, $host);
962  if (wantarray) {
963    if (($idx = index($prefix, '@')) != -1) {
964      $host = substr($prefix, $idx + 1);
965      $rest = substr($prefix, 0, $idx);
966    } else {
967      $host = '';
968      $rest = $prefix;
969    }
970    if (($idx = index($rest, '!')) != -1) {
971      $nick = substr($rest, 0, $idx);
972      $user = substr($rest, $idx + 1);
973    } else {
974      $nick = $rest;
975      $user = '';
976    }
977    return ($nick, $user, $host);
978  } else {
979    if (($idx = index($prefix, '!')) != -1) {
980      return substr($prefix, 0, $idx);
981    } else {
982      return $prefix;
983    }
984  }
985}
986
987sub 'euc_euc {
988  local($euc) = @_;
989  return $euc;
990}
991
992sub 'euc_jis {
993  local($euc) = @_;
994  local($jis, $kanji, $c, $n, $i);
995  $kanji = 0;
996  $jis = '';
997  $euc = &'euc_euc($euc);
998  for ($i = 0; $i < length($euc); $i++) {
999    $c = substr($euc, $i, 1);
1000    $n = ord($c);
1001    if ($n >= 0241) {
1002      if ($kanji != 1) {
1003        $jis .= "\e\$B";
1004        $kanji = 1;
1005      }
1006      $jis .= pack('C', $n & 0177);
1007      $i++;
1008      $jis .= pack('C', ord(substr($euc, $i, 1)) & 0177);
1009    } elsif ($n == 0216) {
1010      if ($kanji != 2) {
1011        $jis .= "\e(I";
1012        $kanji = 2;
1013      }
1014      $i++;
1015      $jis .= pack('C', ord(substr($euc, $i, 1)) & 0177);
1016    } elsif ($n == 0217) {
1017      if ($kanji != 3) {
1018        $jis .= "\e\$(D";
1019        $kanji = 3;
1020      }
1021      $i++;
1022      $jis .= pack('C', ord(substr($euc, $i, 1)) & 0177);
1023      $i++;
1024      $jis .= pack('C', ord(substr($euc, $i, 1)) & 0177);
1025    } else {
1026      if ($kanji) {
1027        $jis .= "\e\(B";
1028        $kanji = 0;
1029      }
1030      $jis .= $c;
1031    }
1032  }
1033  $jis .= "\e\(B" if $kanji;
1034  return $jis;
1035}
1036
1037sub 'euc_sjis {
1038  local($str) = @_;
1039
1040  use Encode;
1041  Encode::from_to($str, 'EUC-JP', 'Shift_JIS');
1042
1043  return $str;
1044}
1045
1046sub 'euc_utf8 {
1047  local($str) = @_;
1048
1049  use Encode;
1050  Encode::from_to($str, 'EUC-JP', 'utf8');
1051
1052  return $str;
1053}
1054
1055sub 'jis_euc {
1056  local($jis) = @_;
1057  local($euc, $kanji, $i);
1058  $kanji = 0;
1059  $euc = '';
1060  $jis = &'jis_jis($jis);
1061  for ($i = 0; $i < length($jis); $i++) {
1062    if (substr($jis, $i, 3) eq "\e\(B") {
1063      $kanji = 0;
1064      $i += 2;
1065      next;
1066    } elsif (substr($jis, $i, 3) eq "\e\$B") {
1067      $kanji = 1;
1068      $i += 2;
1069      next;
1070    } elsif (substr($jis, $i, 3) eq "\e\(I") {
1071      $kanji = 2;
1072      $i += 2;
1073      next;
1074    } elsif (substr($jis, $i, 4) eq "\e\$(D") {
1075      $kanji = 3;
1076      $i += 3;
1077      next;
1078    }
1079    if ($kanji == 0) {
1080      $euc .= substr($jis, $i, 1);
1081    } elsif ($kanji == 1) {
1082      $euc .= pack('C', ord(substr($jis, $i, 1)) | 0200);
1083      $i++;
1084      $euc .= pack('C', ord(substr($jis, $i, 1)) | 0200);
1085    } elsif ($kanji == 2) {
1086      $euc .= "\216" . pack('C', ord(substr($jis, $i, 1)) | 0200);
1087    } elsif ($kanji == 3) {
1088      $euc .= "\217" . pack('C', ord(substr($jis, $i, 1)) | 0200);
1089      $i++;
1090      $euc .= pack('C', ord(substr($jis, $i, 1)) | 0200);
1091    }
1092  }
1093  return $euc;
1094}
1095
1096sub 'jis_jis {
1097  local($jis) = @_;
1098  local($ret, $kanji, $last, $seq, $c, $i);
1099  $kanji = 0;
1100  $last = 0;
1101  $ret = '';
1102  for ($i = 0; $i < length($jis); $i++) {
1103    $c = substr($jis, $i, 1);
1104    $seq = substr($jis, $i, 3);
1105    if ($seq eq "\e\$\@" || $seq eq "\e\$B") {
1106      $ret .= "\e\$B";
1107      $kanji = 1;
1108      $i += 2;
1109      next;
1110    } elsif ($seq eq "\e(J" || $seq eq "\e(B") {
1111      $ret .= "\e(B";
1112      $kanji = 0;
1113      $i += 2;
1114      next;
1115    } elsif ($seq eq "\e(I") {
1116      $ret .= "\e(I";
1117      $kanji = 2;
1118      $i += 2;
1119      next;
1120    } elsif ($c eq "\cN") {
1121      if ($kanji != 2) {
1122        $last = $kanji;
1123        $ret .= "\e(I";
1124        $kanji = 2;
1125      }
1126      next;
1127    } elsif ($c eq "\cO") {
1128      if ($kanji != 2) {
1129        if ($last) {
1130          $ret .= "\e\$B";
1131        } else {
1132          $ret .= "\e(B";
1133        }
1134        $kanji = $last;
1135      }
1136      next;
1137    } elsif (substr($jis, $i, 6) eq "\e&\@\e\$B") {
1138      $ret .= "\e\$B";
1139      $kanji = 1;
1140      $i += 5;
1141      next;
1142    } elsif (substr($jis, $i, 4) eq "\e\$(D") {
1143      $ret .= "\e\$(D";
1144      $kanji = 3;
1145      $i += 3;
1146      next;
1147    }
1148    if ($kanji == 0) {
1149      $ret .= $c;
1150    } elsif ($kanji == 1) {
1151      $ret .= substr($jis, $i, 2);
1152      $i++;
1153    } elsif ($kanji == 2) {
1154      $ret .= $c;
1155    } elsif ($kanji == 3) {
1156      $ret .= substr($jis, $i, 2);
1157      $i++;
1158    }
1159  }
1160  $ret .= "\e(B" if $kanji;
1161  return $ret;
1162}
1163
1164sub 'jis_sjis {
1165  local($jis) = @_;
1166  local($sjis, $kanji, $n1, $n2, $i);
1167  $kanji = 0;
1168  $sjis = '';
1169  $jis = &'jis_jis($jis);
1170  for ($i = 0; $i < length($jis); $i++) {
1171    if (substr($jis, $i, 3) eq "\e\(B") {
1172      $kanji = 0;
1173      $i += 2;
1174      next;
1175    } elsif (substr($jis, $i, 3) eq "\e\$B") {
1176      $kanji = 1;
1177      $i += 2;
1178      next;
1179    } elsif (substr($jis, $i, 3) eq "\e\(I") {
1180      $kanji = 2;
1181      $i += 2;
1182      next;
1183    } elsif (substr($jis, $i, 4) eq "\e\$(D") {
1184      $kanji = 3;
1185      $i += 3;
1186      next;
1187    }
1188    if ($kanji == 0) {
1189      $sjis .= substr($jis, $i, 1);
1190    } elsif ($kanji == 1) {
1191      $n1 = ord(substr($jis, $i, 1));
1192      $i++;
1193      $n2 = ord(substr($jis, $i, 1));
1194      if (($n1 & 01) == 0) {
1195        $n2 += 0175;
1196      } else {
1197        $n2 += 037;
1198      }
1199      $n2++ if $n2 >= 0177;
1200      $n1 = ((($n1 - 041) >> 1) + 0241) ^ 040;
1201      $sjis .= pack('CC', $n1, $n2);
1202    } elsif ($kanji == 2) {
1203      $sjis .= pack('C', ord(substr($jis, $i, 1)) | 0200);
1204    } elsif ($kanji == 3) {
1205      $i++;
1206      $sjis .= "\201\254";
1207    }
1208  }
1209  return $sjis;
1210}
1211
1212sub 'jis_utf8 {
1213  local($str) = @_;
1214
1215  $str = &'jis_euc($str);
1216
1217  use Encode;
1218  Encode::from_to($str, 'EUC-JP', 'utf8');
1219
1220  return $str;
1221}
1222
1223sub 'sjis_euc {
1224  local($str) = @_;
1225
1226  use Encode;
1227  Encode::from_to($str, 'Shift_JIS', 'EUC-JP');
1228
1229  return $str;
1230}
1231
1232sub 'sjis_jis {
1233  local($sjis) = @_;
1234  local($jis, $kanji, $c, $n1, $n2, $i);
1235  $kanji = 0;
1236  $jis = '';
1237  $sjis = &'sjis_sjis($sjis);
1238  for ($i = 0; $i < length($sjis); $i++) {
1239    $c = substr($sjis, $i, 1);
1240    $n1 = ord($c);
1241    if ($n1 >= 0240 && $n1 <= 0337) {
1242      if ($kanji != 2) {
1243        $jis .= "\e(I";
1244        $kanji = 2;
1245      }
1246      $jis .= pack('C', $n1 & 0177);
1247    } elsif ($n1 >= 0201) {
1248      if ($kanji != 1) {
1249        $jis .= "\e\$B";
1250        $kanji = 1;
1251      }
1252      $i++;
1253      $n2 = ord(substr($sjis, $i, 1));
1254      $n2-- if $n2 > 0177;
1255      if ($n2 >= 0236) {
1256        $n1 = ((($n1 ^ 040) - 0241) << 1) + 042;
1257        $n2 -= 0175;
1258      } else {
1259        $n1 = ((($n1 ^ 040) - 0241) << 1) + 041;
1260        $n2 -= 037;
1261      }
1262      $jis .= pack('CC', $n1, $n2);
1263    } else {
1264      if ($kanji) {
1265        $jis .= "\e\(B";
1266        $kanji = 0;
1267      }
1268      $jis .= $c;
1269    }
1270  }
1271  $jis .= "\e\(B" if $kanji;
1272  return $jis;
1273}
1274
1275sub 'sjis_sjis {
1276  local($sjis) = @_;
1277  return $sjis;
1278}
1279
1280sub 'sjis_utf8 {
1281  local($str) = @_;
1282
1283  use Encode;
1284  Encode::from_to($str, 'Shift_JIS', 'utf8');
1285
1286  return $str;
1287}
1288
1289sub 'utf8_utf8 {
1290  local($str) = @_;
1291
1292  return $str;
1293}
1294
1295sub 'utf8_euc {
1296  local($str) = @_;
1297
1298  use Encode;
1299  Encode::from_to($str, 'utf8', 'EUC-JP');
1300
1301  return $str;
1302}
1303
1304sub 'utf8_jis {
1305  local($str) = @_;
1306
1307  $str = &'utf8_euc($str);
1308  $str = &'euc_jis($str);
1309
1310  return $str;
1311}
1312
1313sub 'utf8_sjis {
1314  local($str) = @_;
1315
1316  use Encode;
1317  Encode::from_to($str, 'utf8', 'Shift_JIS');
1318
1319  return $str;
1320}
1321
1322sub 'code_utf8 {
1323  local($line, $list) = @_;
1324  foreach $code (split(/,/, lc($list))) {
1325    if ($code eq 'euc') {
1326      $line = &'euc_utf8($line);
1327    } elsif ($code eq 'jis') {
1328      $line = &'jis_utf8($line);
1329    } elsif ($code eq 'sjis') {
1330      $line = &'sjis_utf8($line);
1331    } elsif ($code eq 'utf8') {
1332      $line = &'utf8_utf8($line);
1333    }
1334  }
1335  return $line;
1336}
1337
1338sub 'utf8_code {
1339  local($line, $list) = @_;
1340  local($code);
1341  $code = (split(/,/, lc($list)))[0];
1342  if ($code eq 'euc') {
1343    $line = &'utf8_euc($line);
1344  } elsif ($code eq 'jis') {
1345    $line = &'utf8_jis($line);
1346  } elsif ($code eq 'sjis') {
1347    $line = &'utf8_sjis($line);
1348  } elsif ($code eq 'utf8') {
1349    $line = &'utf8_utf8($line);
1350  }
1351  return $line;
1352}
1353
1354sub 'add {
1355  local($list, @items) = @_;
1356  $list = '' unless $list;
1357  foreach $item (@items) {
1358    next if &'exist($list, $item);
1359    $list .= $NIL . $item;
1360  }
1361  return $list;
1362}
1363
1364sub 'append {
1365  local($list, @items) = @_;
1366  $list = '' unless $list;
1367  foreach $item (@items) {
1368    $list .= $NIL . $item;
1369  }
1370  return $list;
1371}
1372
1373sub 'remove {
1374  local($list, @items) = @_;
1375  local($idx);
1376  $list = '' unless $list;
1377  $list .= $NIL;
1378  foreach $item (@items) {
1379    $idx = index("\L$list\E", "$NIL\L$item\E$NIL");
1380    next if $idx == -1;
1381    substr($list, $idx, length("$NIL$item$NIL")) = $NIL;
1382  }
1383  return substr($list, 0, length($list) - 1);
1384}
1385
1386sub 'change {
1387  local($list, @items) = @_;
1388  local($old, $new, $idx);
1389  return '' unless $list;
1390  $list .= $NIL;
1391  while (@items > 1) {
1392    $old = shift(@items);
1393    $new = shift(@items);
1394    $idx = index("\L$list\E", "$NIL\L$old\E$NIL");
1395    next if $idx == -1;
1396    substr($list, $idx, length("$NIL$old$NIL")) = "$NIL$new$NIL";
1397  }
1398  return substr($list, 0, length($list) - 1);
1399}
1400
1401sub 'exist {
1402  local($list, @items) = @_;
1403  return 0 unless $list;
1404  $list .= $NIL;
1405  foreach $item (@items) {
1406    return 1 if index("\L$list\E", "$NIL\L$item\E$NIL") != -1;
1407  }
1408  return 0;
1409}
1410
1411sub 'list {
1412  local(@array) = @_;
1413  return join($NIL, '', @array);
1414}
1415
1416sub 'array {
1417  local($list) = @_;
1418  return () unless $list;
1419  $list = substr($list, 1);
1420  return split(/$NIL/, $list, -1);
1421}
1422
1423sub 'shift {
1424  local($list) = @_;
1425  local($idx);
1426  return ('', '') unless $list;
1427  $idx = index($list, $NIL, 1);
1428  if ($idx == -1) {
1429    return (substr($list, 1), '');
1430  } else {
1431    return (substr($list, 1, $idx - 1), substr($list, $idx));
1432  }
1433}
1434
1435sub 'real {
1436  local($name) = @_;
1437  if ($name =~ /^\%(.*)$/) {
1438    return "\#$1\:$ALIAS";
1439  } else {
1440    return $name;
1441  }
1442}
1443
1444sub 'alias {
1445  local($name) = @_;
1446  if ($name =~ /^\#(.*)\:(.*)$/ && "\L$2\E" eq "\L$ALIAS\E") {
1447    return '%' . $1;
1448  } else {
1449    return $name;
1450  }
1451}
1452
1453sub 'channel {
1454  local($name) = @_;
1455  if ($name && $name =~ /^[\#\&\+\!]/) {
1456    return 1;
1457  } else {
1458    return 0;
1459  }
1460}
1461
1462sub 'regex {
1463  local($mask) = @_;
1464  $mask =~ s/(\W)/\\$1/g;
1465  $mask =~ s/\\\?/\./g;
1466  $mask =~ s/\\\*/\.\*/g;
1467  return "\^$mask\$";
1468}
1469
1470sub 'expand {
1471  local($name) = @_;
1472  local($user, $rest, $home);
1473  if ($name =~ /^\~([^\/]*)\/(.*)$/) {
1474    ($user, $rest) = ($1, $2);
1475    if ($user) {
1476      $home = eval '(getpwnam($user))[7]' || '.';
1477    } else {
1478      $home = $ENV{'HOME'} || eval '(getpwuid($<))[7]' || '.';
1479    }
1480    return "$home/$rest";
1481  } else {
1482    return $name;
1483  }
1484}
1485
1486sub 'timelocal {
1487  local(@local) = @_;
1488  local($now, @base, $year, $day, $time);
1489  $now = time();
1490  @base = localtime($now);
1491  $day = ($local[5] - $base[5]) * 365;
1492  $year = $local[5] + 1900;
1493  $day += int($year / 4) - int($year / 100) + int($year / 400) + &days($local[3], $local[4], $local[5]);
1494  $year = $base[5] + 1900;
1495  $day -= int($year / 4) - int($year / 100) + int($year / 400) + &days($base[3], $base[4], $base[5]);
1496  $time = $now + $day * 86400 + ($local[2] - $base[2]) * 3600 + ($local[1] - $base[1]) * 60 + $local[0] - $base[0];
1497  return $time;
1498}
1499
1500sub days {
1501  local(@time) = @_;
1502  local($day, $year);
1503  $day = (0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334)[$time[1]];
1504  $day += $time[0] - 1;
1505  $year = $time[2] + 1900;
1506  if ($time[1] < 2 && $year % 4 == 0 && ($year % 100 != 0 || $year % 400 == 0)) {
1507    $day -= 1;
1508  }
1509  return $day;
1510}
1511
1512sub 'date {
1513  local($format, $time) = @_;
1514  local(@time, $char, $str, $i, $number);
1515  $time = time() unless defined($time);
1516  @time = localtime($time);
1517  $str = '';
1518  for ($i = 0; $i < length($format); $i++) {
1519    $char = substr($format, $i, 1);
1520    if ($char eq '%') {
1521      $i++;
1522      if ($i < length($format)) {
1523        $char = substr($format, $i, 1);
1524        if ($char eq '+' || $char eq '-') {
1525          $i++;
1526          $number = $char;
1527          while ($i < length($format)) {
1528            $char = substr($format, $i, 1);
1529            last if index('0123456789.', $char) == -1;
1530            $number .= $char;
1531            $i++;
1532          }
1533        } else {
1534          $number = 0;
1535        }
1536        if ($char eq '%') {
1537          $str .= $char;
1538        } elsif ($char eq 'a') {
1539          $str .= ('Sun', 'Mon', 'Tue', 'Wed', 'Thu', 'Fri', 'Sat')[$time[6]];
1540        } elsif ($char eq 'b') {
1541          $str .= ('Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', 'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec')[$time[4]];
1542        } elsif ($char eq 'd') {
1543          $str .= sprintf('%02d', $time[3]);
1544        } elsif ($char eq 'H') {
1545          $str .= sprintf('%02d', $time[2]);
1546        } elsif ($char eq 'I') {
1547          $str .= sprintf('%02d', $time[2] % 12 + 1);
1548        } elsif ($char eq 'j') {
1549          $str .= sprintf('%3d', $time[7]);
1550        } elsif ($char eq 'k') {
1551          $str .= sprintf('%2d', $time[2]);
1552        } elsif ($char eq 'l') {
1553          $str .= sprintf('%2d', $time[2] % 12 + 1);
1554        } elsif ($char eq 'M') {
1555          $str .= sprintf('%02d', $time[1]);
1556        } elsif ($char eq 'm') {
1557          $str .= sprintf('%02d', $time[4] + 1);
1558        } elsif ($char eq 'O') {
1559          @time = localtime($time + $number * 3600);
1560        } elsif ($char eq 'o') {
1561          @time = localtime($time + $number);
1562        } elsif ($char eq 'p') {
1563          if ($time[2] < 12) {
1564            $str .= 'AM';
1565          } else {
1566            $str .= 'PM';
1567          }
1568        } elsif ($char eq 'S') {
1569          $str .= sprintf('%02d', $time[0]);
1570        } elsif ($char eq 'w') {
1571          $str .= sprintf('%d', $time[6]);
1572        } elsif ($char eq 'Y') {
1573          $str .= sprintf('%d', $time[5] + 1900);
1574        } elsif ($char eq 'y') {
1575          $str .= sprintf('%02d', $time[5] % 100);
1576        }
1577      } else {
1578        $str .= $char;
1579      }
1580    } else {
1581      $str .= $char;
1582    }
1583  }
1584  return $str;
1585}
1586
1587sub 'format {
1588  local($text, %data) = @_;
1589  local($ret, $idx, $end, $ret, $str);
1590  $ret = '';
1591  while (($idx = index($text, '#(')) != -1) {
1592    $end = index($text, ')', $idx + 2);
1593    last if $end == -1;
1594    $ret .= substr($text, 0, $idx);
1595    foreach $item (split(/\|/, substr($text, $idx + 2, $end - $idx - 2))) {
1596      $str = &replace($item, %data);
1597      next unless defined($str);
1598      $ret .= $str;
1599      last;
1600    }
1601    $text = substr($text, $end + 1);
1602  }
1603  $ret .= $text;
1604  return $ret;
1605}
1606
1607sub replace {
1608  local($item, %data) = @_;
1609  local($list, $text, @data);
1610  ($list, $text) = split(/\;/, $item, 2);
1611  if ($list) {
1612    foreach $key (split(/\,/, $list)) {
1613      if (!defined($data{$key})) {
1614        return undef;
1615      }
1616      push(@data, $data{$key});
1617    }
1618    if ($text) {
1619      return sprintf($text, @data);
1620    } else {
1621      return join('', @data);
1622    }
1623  } else {
1624    return $text;
1625  }
1626}
1627
1628sub property_change {
1629  local($userno) = @_;
1630  local($sno, $i, $mask, $pass, $host, $port, $lno);
1631  if (!$default[$userno]) {
1632    $sno = &'socket('S');
1633    $default[$userno] = $sno;
1634    $status[$userno] = 0;
1635    &s_clear($userno);
1636  }
1637  $serverlist[$userno] = &'list(&'property($userno, 'server'));
1638  $serverindex[$userno] = 0;
1639  $nicklist[$userno] = '';
1640  foreach $nick (&'property($userno, 'nick')) {
1641    $nicklist[$userno] = &'add($nicklist[$userno], split(/\,/, $nick));
1642  }
1643  $nickindex[$userno] = 0;
1644  undef %auth;
1645  for ($i = 1; $i < @'username; $i++) {
1646    foreach $client (&'property($i, 'client')) {
1647      ($mask, $pass) = split(/\s+/, $client);
1648      ($host, $port) = split(/\;/, $mask);
1649      $port = $PORT unless $port;
1650      $auth{$port} = &'add($auth{$port}, join(';', $host, $i, $pass || ''));
1651    }
1652  }
1653  foreach $lno (&'array($listenlist)) {
1654    next unless defined($auth{$port[$lno]});
1655    &'close($lno);
1656    $listenlist = &'remove($listenlist, $lno);
1657  }
1658  foreach $lno (&'array($listenwaitlist)) {
1659    next unless defined($auth{$port[$lno]});
1660    &'close($lno);
1661    $listenwaitlist = &'remove($listenwaitlist, $lno);
1662  }
1663  $list = '';
1664  foreach $lno (&'array($listenlist), &'array($listenwaitlist)) {
1665    $list = &'add($list, $port[$lno]);
1666  }
1667  foreach $port (keys(%auth)) {
1668    next if &'exist($list, $port);
1669    $lno = &'socket('L');
1670    $port[$lno] = $port;
1671    $listenwaitlist = &'add($listenwaitlist, $lno);
1672  }
1673}
1674
1675sub main_loop {
1676  local($userno) = @_;
1677  local($tmp, $next, $rest);
1678  foreach $cno (&'array($clientlist)) {
1679    &c_proc($cno) if vec($'rout, $'fileno[$cno], 1);
1680  }
1681  foreach $lno (&'array($listenlist)) {
1682    &l_proc($lno) if vec($'rout, $'fileno[$lno], 1);
1683  }
1684  foreach $lno (&'array($listenwaitlist)) {
1685    &l_init($lno);
1686  }
1687  if ($status[$userno] == 0) {
1688    &s_init($userno);
1689  } elsif ($status[$userno] == 1) {
1690    &s_proc($userno) if vec($'rout, $'fileno[$default[$userno]], 1);
1691  }
1692}
1693
1694sub c_proc {
1695  local($cno) = @_;
1696  local($socket, $tmp, $next, $rest, $prefix, $cmd, @params);
1697  $socket = $'socket[$cno];
1698  $tmp = '';
1699  if (sysread($socket, $tmp, $BUFFER)) {
1700    $bufr[$cno] .= $tmp;
1701    while ((($next, $rest) = split(/[\r\n]+/, $bufr[$cno], 2)) == 2) {
1702      $bufr[$cno] = $rest || '';
1703      next unless $next;
1704      $next = &read_event($'userno[$cno], 'client_read', $cno, $next) if $'userno[$cno];
1705      next unless $next;
1706      ($prefix, $cmd, @params) = &'parse($next);
1707      next unless $cmd;
1708      $cmd = "\U$cmd\E";
1709      if ($cmd eq 'NICK') {
1710        $nick[$cno] = $params[0];
1711        &c_check($cno) if $user[$cno];
1712      } elsif ($cmd eq 'USER') {
1713        if (defined(@params) && @params >= 4) {
1714          $user[$cno] = $params[0];
1715          &c_check($cno) if $nick[$cno];
1716        } else {
1717          &c_out($cno, $NAME, '461', 'Not enough parameters');
1718        }
1719      } elsif ($cmd eq 'PASS') {
1720        $pass[$cno] = $params[0];
1721      } elsif ($cmd eq 'QUIT') {
1722        $params[0] = 'I Quit' unless $params[0];
1723        &c_out($cno, '', 'ERROR', 'Closing Link: ' . &'user($cno, $nick[$cno], $user[$cno]) . " ($params[0])");
1724        $clientlist = &'remove($clientlist, $cno);
1725        &c_clear($cno);
1726        &'close($cno);
1727      } else {
1728        &c_out($cno, $NAME, '451', '*', 'You have not registered');
1729      }
1730    }
1731  } else {
1732    $clientlist = &'remove($clientlist, $cno);
1733    &c_clear($cno);
1734    &'close($cno);
1735  }
1736}
1737
1738sub c_out {
1739  local($cno, $prefix, $cmd, @params) = @_;
1740  local($line, $socket);
1741  $line = &'build($prefix, $cmd, @params);
1742  return unless $line;
1743  $line = &write_event($'userno[$cno], 'client_write', $cno, $line) if $'userno[$cno];
1744  return unless $line;
1745  $socket = $'socket[$cno];
1746  print $socket $line, $EOL if fileno($socket);
1747}
1748
1749sub c_check {
1750  local($cno) = @_;
1751  local($socket, $userno, $pass, $sno);
1752  $socket = $'socket[$cno];
1753  foreach $auth (&'array($auth[$cno])) {
1754    ($userno, $pass) = split(/\;/, $auth, 2);
1755    next if ($pass && $pass ne $pass[$cno]);
1756    if ($default[$userno]) {
1757      $sno = $default[$userno];
1758    } else {
1759      $sno = 0;
1760    }
1761    &c_out($cno, $'servername[$sno] || $NAME, '001', $nick[$cno], 'Welcome to the Internet Relay Network ' . &'user($cno, $nick[$cno], $user[$cno]));
1762    &'c_open($cno, $userno, &'user($cno, $nick[$cno], $user[$cno]), $sno, $bufr[$cno]);
1763    $clientlist = &'remove($clientlist, $cno);
1764    &c_clear($cno);
1765    return;
1766  }
1767  &c_out($cno, $NAME, '464', $nick[$cno], 'Password incorrect');
1768  &c_out($cno, '', 'ERROR', 'Closing Link: ' . &'user($cno, $nick[$cno], $user[$cno]) . ' (Bad Password)');
1769  $clientlist = &'remove($clientlist, $cno);
1770  &c_clear($cno);
1771  &'close($cno);
1772}
1773
1774sub c_clear {
1775  local($cno) = @_;
1776  $nick[$cno] = '';
1777  $user[$cno] = '';
1778  $pass[$cno] = '';
1779  $auth[$cno] = '';
1780  $bufr[$cno] = '';
1781}
1782
1783sub l_proc {
1784  local($lno) = @_;
1785  local($cno, $mask, $rest);
1786  $cno = &'socket('C');
1787  vec($'rout, $'fileno[$lno], 1) = 0;
1788  if (&'accept($cno, $lno)) {
1789    &c_clear($cno);
1790    $'userno[$cno] = 0;
1791    $port[$cno] = (&'sockname($cno))[0];
1792    foreach $auth (&'array($auth{$port[$cno]})) {
1793      ($mask, $rest) = split(/\;/, $auth, 2);
1794      next unless &'match($cno, $mask);
1795      $clientlist = &'add($clientlist, $cno);
1796      $auth[$cno] = &'add($auth[$cno], $rest);
1797    }
1798    return if $auth[$cno];
1799  }
1800  &'close($cno);
1801}
1802
1803sub l_init {
1804  local($lno) = @_;
1805  if ($port[$lno] > 0) {
1806    if (!&'listen($lno, $port[$lno])) {
1807      &'alarm(-$INTERVAL);
1808      return;
1809    }
1810  } else {
1811    if (!&'listen6($lno, -$port[$lno])) {
1812      &'alarm(-$INTERVAL);
1813      return;
1814    }
1815  }
1816  $listenwaitlist = &'remove($listenwaitlist, $lno);
1817  $listenlist = &'add($listenlist, $lno);
1818}
1819
1820sub s_init {
1821  local($userno) = @_;
1822  local($server, $host, $pass, $addr, $list, @port, $sno, $socket, $nick, $user, $uname, $mode, $name);
1823  return unless $serverlist[$userno];
1824  $server = (&'array($serverlist[$userno]))[$serverindex[$userno]];
1825  ($host, $pass) = split(/\s+/, $server);
1826  ($addr, $list) = split(/\;/, $host);
1827  return unless $host;
1828  @port = split(/\,/, $list || '');
1829  $sno = $default[$userno];
1830  if (&'connect($sno, $addr, $port[rand(@port)] || $PORT)) {
1831    $'userno[$sno] = $userno;
1832    $status[$userno] = 1;
1833    $bufr[$sno] = '';
1834    $socket = $'socket[$sno];
1835    &s_out($sno, '', 'PASS', $pass) if $pass;
1836    $nick = $lastnick[$userno] || (&'array($nicklist[$userno]))[$nickindex[$userno]] || eval 'getlogin()' || eval '(getpwuid($<))[0]';
1837    $lastnick[$userno] = '';
1838    &s_out($sno, '', 'NICK', $nick);
1839    $user = &'property($userno, 'user') || eval 'getlogin()' || eval '(getpwuid($<))[0]' || $nick;
1840    ($uname, $mode) = split(/\;/, $user);
1841    $name = &'property($userno, 'name') || eval '((split(/\,/, (getpwuid($<))[6]))[0])' || $user;
1842    &s_out($sno, '', 'USER', $uname, $mode || '0', '*', $name);
1843  } else {
1844    &'alarm(-$INTERVAL);
1845    $serverindex[$userno] = ($serverindex[$userno] + 1) % &'array($serverlist[$userno]);
1846  }
1847}
1848
1849sub s_proc {
1850  local($userno) = @_;
1851  local($sno, $socket, $tmp, $next, $rest, $prefix, $cmd, @params, $nick, $user, $host, $no);
1852  $sno = $default[$userno];
1853  $socket = $'socket[$sno];
1854  $tmp = '';
1855  if (sysread($socket, $tmp, $BUFFER)) {
1856    $bufr[$sno] .= $tmp;
1857    while ((($next, $rest) = split(/[\r\n]+/, $bufr[$sno], 2)) == 2) {
1858      $bufr[$sno] = $rest || '';
1859      next unless $next;
1860      $next = &read_event($'userno[$sno], 'server_read', $sno, $next);
1861      next unless $next;
1862      ($prefix, $cmd, @params) = &'parse($next);
1863      next unless $cmd;
1864      $cmd = "\U$cmd\E";
1865      if ($cmd eq 'PING') {
1866        &s_out($sno, '', 'PONG', @params);
1867      } elsif ($cmd eq 'ERROR') {
1868        $serverindex[$userno] = ($serverindex[$userno] + 1) % &'array($serverlist[$userno]);
1869      } elsif ($cmd eq '001') {
1870        ($nick, $user, $host) = &'prefix(substr($params[1], rindex($params[1], ' ') + 1));
1871        &'s_open($sno, $userno, &'user($sno, $nick, $user, $host), $prefix, $bufr[$sno]);
1872        $status[$userno] = 2;
1873        $serverindex[$userno] = 0;
1874        $nickindex[$userno] = 0;
1875        &s_clear($userno);
1876      } elsif ($cmd eq '432' || $cmd eq '433' || $cmd eq '437') {
1877        $nickindex[$userno]++;
1878        if ($nickindex[$userno] < &'array($nicklist[$userno])) {
1879          $nick = (&'array($nicklist[$userno]))[$nickindex[$userno]];
1880        } elsif ($nickindex[$userno] == &'array($nicklist[$userno])) {
1881          if ($nicklist[$userno]) {
1882            $nick = (&'array($nicklist[$userno]))[0];
1883          } else {
1884            $nick = $params[1];
1885          }
1886          $nick = substr($nick, 0, 8) . '0';
1887        } else {
1888          $nick = $params[1];
1889          $nick++;
1890        }
1891        &s_out($sno, '', 'NICK', $nick);
1892      }
1893    }
1894  } else {
1895    $status[$userno] = 0;
1896    &'close($sno, 1);
1897    &s_clear($userno);
1898    &'alarm(-$INTERVAL);
1899  }
1900}
1901
1902sub s_out {
1903  local($sno, $prefix, $cmd, @params) = @_;
1904  local($line, $socket);
1905  $line = &'build($prefix, $cmd, @params);
1906  return unless $line;
1907  $line = &write_event($'userno[$sno], 'server_write', $sno, $line);
1908  return unless $line;
1909  $socket = $'socket[$sno];
1910  print $socket $line, $EOL if fileno($socket);
1911}
1912
1913sub s_clear {
1914  local($userno) = @_;
1915  $bufr[$default[$userno]] = '';
1916}
1917
1918sub client_open {
1919  local($cno) = @_;
1920  local($sno);
1921  $sno = $'server[$cno];
1922  if (&'exist($'serverlist, $sno)) {
1923    &'c_print($cno, &'user($cno), 'NICK', $'nick[$sno]) if $'nick[$cno] ne $'nick[$sno];
1924    foreach $chan (&'array($'channellist[$sno])) {
1925      &'c_print($cno, &'user($cno), 'JOIN', $chan);
1926      &'c_print($cno, $'servername[$cno], '332', $'nick[$cno], $chan, $'topic{$sno, $chan}) if $'topic{$sno, $chan};
1927      &'c_print($cno, $'servername[$cno], '353', $'nick[$cno], '=', $chan, join(' ', reverse(&'array($'nameslist{$sno, $chan}))));
1928      &'c_print($cno, $'servername[$cno], '366', $'nick[$cno], $chan, 'End of /NAMES list.');
1929    }
1930  }
1931}
1932
1933sub client_close {
1934  local($cno) = @_;
1935  &clear_variable($cno);
1936  &'close($cno);
1937}
1938
1939sub server_open {
1940  local($sno) = @_;
1941  foreach $cno (&'array($'clientlist)) {
1942    next unless $'server[$cno] == $sno;
1943    next unless $'nick[$cno] ne $'nick[$sno];
1944    &'c_print($cno, &'user($cno), 'NICK', $'nick[$sno]);
1945  }
1946}
1947
1948sub server_close {
1949  local($sno) = @_;
1950  foreach $cno (&'array($'clientlist)) {
1951    next unless $'server[$cno] == $sno;
1952    &'c_print($cno, '', 'NOTICE', $'nick[$cno], "*** Server $'servername[$sno] closed the connection");
1953    foreach $chan (&'array($'channellist[$sno])) {
1954      &'c_print($cno, &'user($cno), 'PART', $chan);
1955    }
1956  }
1957  &clear_variable($sno);
1958  if ($default[$'userno[$sno]] == $sno) {
1959    $status[$'userno[$sno]] = 0;
1960    $lastnick[$'userno[$sno]] = $'nick[$'userno[$sno]];
1961    &'close($sno, 1);
1962  }
1963  &'alarm(-$INTERVAL);
1964}
1965
1966sub clear_variable {
1967  local($num) = @_;
1968  local($no, $var);
1969  $'channellist[$num] = '';
1970  foreach $key (keys(%'nameslist)) {
1971    ($no, $var) = split(/$;/, $key, 2);
1972    next unless $no == $num;
1973    delete $'nameslist{$key};
1974  }
1975  foreach $key (keys(%'channelmode)) {
1976    ($no, $var) = split(/$;/, $key, 2);
1977    next unless $no == $num;
1978    delete $'channelmode{$key};
1979  }
1980  foreach $key (keys(%'usermode)) {
1981    ($no, $var) = split(/$;/, $key, 2);
1982    next unless $no == $num;
1983    delete $'usermode{$key};
1984  }
1985  foreach $key (keys(%'topic)) {
1986    ($no, $var) = split(/$;/, $key, 2);
1987    next unless $no == $num;
1988    delete $'topic{$key};
1989  }
1990}
1991
1992sub cs_exit {
1993  local($cno, $prefix, $cmd, @params) = @_;
1994  local($i, @list);
1995  for ($i = 1; $i < @'username; $i++) {
1996    @list = &sub_list($i, 'module_disable');
1997    $'modulelist[$i] = '';
1998    foreach $sub (@list) {
1999      &$sub($i);
2000    }
2001  }
2002  foreach $sno (&'array($'serverlist)) {
2003    &'s_flush($sno);
2004    &'s_print($sno, '', 'QUIT', $params[0] || $NAME);
2005    &'s_flush($sno);
2006    &'s_close($sno);
2007    &'close($sno);
2008  }
2009  $params[0] = 'I Quit' unless $params[0];
2010  foreach $cno (&'array($'clientlist)) {
2011    &'c_print($cno, '', 'ERROR', 'Closing Link: ' . &'user($cno) . " ($params[0])");
2012    &'c_flush($cno);
2013    &'c_close($cno);
2014    &'close($cno);
2015  }
2016  foreach $lno (&'array($listenlist)) {
2017    &'close($lno);
2018  }
2019  exit(0);
2020}
2021
2022sub cp_join {
2023  local($cno, $prefix, $cmd, @params) = @_;
2024  &proc_join($cno, $prefix, $cmd, @params);
2025  return ($prefix, $cmd, @params);
2026}
2027
2028sub ss_join {
2029  local($sno, $prefix, $cmd, @params) = @_;
2030  &proc_join($sno, $prefix, @params);
2031  return ($prefix, $cmd, @params);
2032}
2033
2034sub proc_join {
2035  local($no, $prefix, @params) = @_;
2036  local($name, $mode);
2037  $nick = &'prefix($prefix);
2038  ($name, $mode) = (split(/\cG/, $params[0]), '');
2039  if ($nick eq $'nick[$no]) {
2040    $'channellist[$no] = &'add($'channellist[$no], $name);
2041    $'nameslist{$no, $name} = '';
2042  } else {
2043    if (index($mode, 'o') != -1) {
2044      $'nameslist{$no, $name} = &'add($'nameslist{$no, $name}, "\@$nick");
2045    } elsif (index($mode, 'v') != -1) {
2046      $'nameslist{$no, $name} = &'add($'nameslist{$no, $name}, "+$nick");
2047    } else {
2048      $'nameslist{$no, $name} = &'add($'nameslist{$no, $name}, $nick);
2049    }
2050  }
2051}
2052
2053sub cp_kick {
2054  local($cno, $prefix, $cmd, @params) = @_;
2055  &proc_kick($cno, @params);
2056  return ($prefix, $cmd, @params);
2057}
2058
2059sub ss_kick {
2060  local($sno, $prefix, $cmd, @params) = @_;
2061  &proc_kick($sno, @params);
2062  return ($prefix, $cmd, @params);
2063}
2064
2065sub proc_kick {
2066  local($no, @params) = @_;
2067  if ($params[1] eq $'nick[$no]) {
2068    $'channellist[$no] = &'remove($'channellist[$no], $params[0]);
2069    delete $'nameslist{$no, $params[0]};
2070  } else {
2071    $'nameslist{$no, $params[0]} = &'remove($'nameslist{$no, $params[0]}, $params[1], "+$params[1]", "\@$params[1]");
2072  }
2073}
2074
2075sub cp_mode {
2076  local($cno, $prefix, $cmd, @params) = @_;
2077  &proc_mode($cno, @params);
2078  return ($prefix, $cmd, @params);
2079}
2080
2081sub ss_mode {
2082  local($sno, $prefix, $cmd, @params) = @_;
2083  &proc_mode($sno, @params);
2084  return ($prefix, $cmd, @params);
2085}
2086
2087sub proc_mode {
2088  local($no, @params) = @_;
2089  local($chan, $mode, @modes, $char, $flag, $name, $i);
2090  ($chan, $mode, @modes) = @params;
2091  if (&'channel($chan)) {
2092    for ($i = 0; $i < length($mode); $i++) {
2093      $char = substr($mode, $i, 1);
2094      if ($char eq '+' || $char eq '-') {
2095        $flag = $char;
2096      } elsif ($char eq 'b') {
2097        shift(@modes);
2098      } elsif ($char eq 'e') {
2099        shift(@modes);
2100      } elsif ($char eq 'I') {
2101        shift(@modes);
2102      } elsif ($char eq 'k') {
2103        if ($flag eq '+') {
2104          $'channelmode{$no, $chan, $char} = shift(@modes);
2105        } else {
2106          shift(@modes);
2107          delete $'channelmode{$no, $chan, $char};
2108        }
2109      } elsif ($char eq 'l') {
2110        if ($flag eq '+') {
2111          $'channelmode{$no, $chan, $char} = shift(@modes);
2112        } else {
2113          delete $'channelmode{$no, $chan, $char};
2114        }
2115      } elsif ($char eq 'O') {
2116        shift(@modes);
2117      } elsif ($char eq 'o') {
2118        $name = shift(@modes);
2119        if ($flag eq '+') {
2120          $'nameslist{$no, $chan} = &'change($'nameslist{$no, $chan}, $name, "\@$name", "+$name", "\@$name");
2121        } elsif ($flag eq '-') {
2122          $'nameslist{$no, $chan} = &'change($'nameslist{$no, $chan}, "\@$name", $name);
2123        }
2124      } elsif ($char eq 'v') {
2125        $name = shift(@modes);
2126        if ($flag eq '+') {
2127          $'nameslist{$no, $chan} = &'change($'nameslist{$no, $chan}, $name, "+$name");
2128        } elsif ($flag eq '-') {
2129          $'nameslist{$no, $chan} = &'change($'nameslist{$no, $chan}, "+$name", $name);
2130        }
2131      } else {
2132        if ($flag eq '+') {
2133          $'channelmode{$no, $chan, $char} = 1;
2134        } else {
2135          delete $'channelmode{$no, $chan, $char};
2136        }       
2137      }
2138    }
2139  } else {
2140    for ($i = 0; $i < length($mode); $i++) {
2141      $char = substr($mode, $i, 1);
2142      if ($char eq '+' || $char eq '-') {
2143        $flag = $char;
2144      } else {
2145        if ($flag eq '+') {
2146          $'usermode{$no, $char} = 1;
2147        } else {
2148          delete $'usermode{$no, $char};
2149        }
2150      }
2151    }
2152  }
2153}
2154
2155sub cs_nick {
2156  local($cno, $prefix, $cmd, @params) = @_;
2157  if (&'exist($'serverlist, $'server[$cno])) {
2158    return ($prefix, $cmd, @params);
2159  } elsif ($'nick[$cno] ne $params[0]) {
2160    if ($params[0] =~ /[\w\[\]\\\{\}\|]+/) {
2161      &'c_print($cno, &'user($cno), 'NICK', $params[0]);
2162    }
2163  }
2164  return ();
2165}
2166
2167sub cp_nick {
2168  local($cno, $prefix, $cmd, @params) = @_;
2169  &proc_nick($cno, $prefix, @params);
2170  return ($prefix, $cmd, @params);
2171}
2172
2173sub ss_nick {
2174  local($sno, $prefix, $cmd, @params) = @_;
2175  &proc_nick($sno, $prefix, @params);
2176  return ($prefix, $cmd, @params);
2177}
2178
2179sub proc_nick {
2180  local($no, $prefix, @params) = @_;
2181  local($nick);
2182  $nick = &'prefix($prefix);
2183  if ($nick eq $'nick[$no]) {
2184    $'nick[$no] = $params[0];
2185  }
2186  foreach $chan (&'array($'channellist[$no])) {
2187    $'nameslist{$no, $chan} = &'change($'nameslist{$no, $chan}, $nick, $params[0], "+$nick", "+$params[0]", "\@$nick", "\@$params[0]");
2188  }
2189}
2190
2191sub cp_part {
2192  local($cno, $prefix, $cmd, @params) = @_;
2193  &proc_part($no, $prefix, @params);
2194  return ($prefix, $cmd, @params);
2195}
2196
2197sub ss_part {
2198  local($sno, $prefix, $cmd, @params) = @_;
2199  &proc_part($no, $prefix, @params);
2200  return ($prefix, $cmd, @params);
2201}
2202
2203sub proc_part {
2204  local($no, $prefix, @params) = @_;
2205  local($nick);
2206  $nick = &'prefix($prefix);
2207  if ($nick eq $'nick[$no]) {
2208    $'channellist[$no] = &'remove($'channellist[$no], $params[0]);
2209    delete $'nameslist{$no, $params[0]};
2210  } else {
2211    $'nameslist{$no, $params[0]} = &'remove($'nameslist{$no, $params[0]}, $nick, "+$nick", "\@$nick");
2212  }
2213}
2214
2215sub cs_pong {
2216  local($cno, $prefix, $cmd, @params) = @_;
2217  return ();
2218}
2219
2220sub ss_ping {
2221  local($sno, $prefix, $cmd, @params) = @_;
2222  &'s_print($sno, '', 'PONG', @params);
2223  return ($prefix, $cmd, @params);
2224}
2225
2226sub cp_quit {
2227  local($cno, $prefix, $cmd, @params) = @_;
2228  local($nick);
2229  $nick = &'prefix($prefix);
2230  foreach $chan (&'array($'channellist[$cno])) {
2231    $'nameslist{$cno, $chan} = &'remove($'nameslist{$cno, $chan}, $nick, "+$nick", "\@$nick");
2232  }
2233  return ($prefix, $cmd, @params);
2234}
2235
2236sub cs_quit {
2237  local($cno, $prefix, $cmd, @params) = @_;
2238  $params[0] = 'I Quit' unless $params[0];
2239  &'c_print($cno, '', 'ERROR', 'Closing Link: ' . &'user($cno) . " ($params[0])");
2240  &'c_flush($cno);
2241  &'c_close($cno);
2242  &'close($cno);
2243  return ();
2244}
2245
2246sub ss_quit {
2247  local($sno, $prefix, $cmd, @params) = @_;
2248  local($nick);
2249  $nick = &'prefix($prefix);
2250  foreach $chan (&'array($'channellist[$sno])) {
2251    $'nameslist{$sno, $chan} = &'remove($'nameslist{$sno, $chan}, $nick, "+$nick", "\@$nick");
2252  }
2253  return ($prefix, $cmd, @params);
2254}
2255
2256sub cp_topic {
2257  local($cno, $prefix, $cmd, @params) = @_;
2258  $'topic{$cno, $params[0]} = $params[1];
2259  return ($prefix, $cmd, @params);
2260}
2261
2262sub ss_topic {
2263  local($sno, $prefix, $cmd, @params) = @_;
2264  $'topic{$sno, $params[0]} = $params[1];
2265  return ($prefix, $cmd, @params);
2266}
2267
2268sub cp_324 {
2269  local($cno, $prefix, $cmd, @params) = @_;
2270  &proc_324($cno, @params);
2271  return ($prefix, $cmd, @params);
2272}
2273
2274sub ss_324 {
2275  local($sno, $prefix, $cmd, @params) = @_;
2276  &proc_324($sno, @params);
2277  return ($prefix, $cmd, @params);
2278}
2279
2280sub proc_324 {
2281  local($no, @params) = @_;
2282  local($nick, $chan, $mode, @modes, $char, $flag, $i);
2283  ($nick, $chan, $mode, @modes) = @params;
2284  for ($i = 0; $i < length($mode); $i++) {
2285    $char = substr($mode, $i, 1);
2286    if ($char eq '+' || $char eq '-') {
2287      $flag = $char;
2288    } elsif ($char eq 'k') {
2289      if ($flag eq '+') {
2290        $'channelmode{$no, $chan, $char} = shift(@modes);
2291      } else {
2292        shift(@modes);
2293        delete $'channelmode{$no, $chan, $char};
2294      }
2295    } elsif ($char eq 'l') {
2296      if ($flag eq '+') {
2297        $'channelmode{$no, $chan, $char} = shift(@modes);
2298      } else {
2299        delete $'channelmode{$no, $chan, $char};
2300      }
2301    } else {
2302      if ($flag eq '+') {
2303        $'channelmode{$no, $chan, $char} = 1;
2304      } else {
2305        delete $'channelmode{$no, $chan, $char};
2306      }       
2307    }
2308  }
2309}
2310
2311sub cp_332 {
2312  local($cno, $prefix, $cmd, @params) = @_;
2313  if (&'exist($'channellist[$cno], $params[1])) {
2314    $'topic{$cno, $params[1]} = $params[2];
2315  }
2316  return ($prefix, $cmd, @params);
2317}
2318
2319sub ss_332 {
2320  local($sno, $prefix, $cmd, @params) = @_;
2321  if (&'exist($'channellist[$sno], $params[1])) {
2322    $'topic{$sno, $params[1]} = $params[2];
2323  }
2324  return ($prefix, $cmd, @params);
2325}
2326
2327sub cp_353 {
2328  local($cno, $prefix, $cmd, @params) = @_;
2329  &proc_353($cno, @params);
2330  return ($prefix, $cmd, @params);
2331}
2332
2333sub ss_353 {
2334  local($sno, $prefix, $cmd, @params) = @_;
2335  &proc_353($sno, @params);
2336  return ($prefix, $cmd, @params);
2337}
2338
2339sub proc_353 {
2340  local($no, @params) = @_;
2341  local($key);
2342  $key = "$no$;$params[2]";
2343  if (&'exist($'channellist[$no], $params[2])) {
2344    $'nameslist{$key} = &'add($'nameslist{$key}, reverse(split(/\s+/, $params[3])));
2345    if ($params[1] eq '@') {
2346      $'channelmode{$key, 's'} = 1;
2347    } elsif ($params[1] eq '*') {
2348      $'channelmode{$key, 'p'} = 1;
2349    }
2350  }
2351}
2352
2353sub cs_privmsg {
2354  local($cno, $prefix, $cmd, @params) = @_;
2355  local($text, $ctcp);
2356  if ($params[1]) {
2357    ($text, $ctcp) = &ctcp_event($cno, 'scan_event', 'cpcs', $prefix, $cmd, @params);
2358    return () unless ($tmp || $ctcp);
2359    $params[1] = $text;
2360    foreach $no (&'array($'clientlist)) {
2361      next unless $cno != $no;
2362      next unless $'server[$cno] == $'server[$no];
2363      &'c_print($no, &'user($no), $cmd, @params);
2364    }
2365    $params[1] = $text . $ctcp;
2366  }
2367  return ($prefix, $cmd, @params);
2368}
2369
2370sub cp_privmsg {
2371  local($cno, $prefix, $cmd, @params) = @_;
2372  local($text, $ctcp);
2373  if ($params[1]) {
2374    ($text, $ctcp) = &ctcp_event($cno, 'print_event', 'cpcp', $prefix, $cmd, @params);
2375    return () unless ($text || $ctcp);
2376    $params[1] = $text . $ctcp;
2377  }
2378  return ($prefix, $cmd, @params);
2379}
2380
2381sub ss_privmsg {
2382  local($sno, $prefix, $cmd, @params) = @_;
2383  local($text, $ctcp);
2384  if ($params[1]) {
2385    ($text, $ctcp) = &ctcp_event($sno, 'scan_event', 'cpss', $prefix, $cmd, @params);
2386    return () unless ($text || $ctcp);
2387    $params[1] = $text . $ctcp;
2388  }
2389  return ($prefix, $cmd, @params);
2390}
2391
2392sub sp_privmsg {
2393  local($sno, $prefix, $cmd, @params) = @_;
2394  local($text, $ctcp);
2395  if ($params[1]) {
2396    ($text, $ctcp) = &ctcp_event($sno, 'print_event', 'cpsp', $prefix, $cmd, @params);
2397    return () unless ($text || $ctcp);
2398    $params[1] = $text . $ctcp;
2399  }
2400  return ($prefix, $cmd, @params);
2401}
2402
2403sub cs_notice {
2404  local($cno, $prefix, $cmd, @params) = @_;
2405  local($text, $ctcp);
2406  if ($params[1]) {
2407    ($text, $ctcp) = &ctcp_event($cno, 'scan_event', 'cncs', $prefix, $cmd, @params);
2408    return () unless ($tmp || $ctcp);
2409    $params[1] = $text;
2410    foreach $no (&'array($'clientlist)) {
2411      next unless $cno != $no;
2412      next unless $'server[$cno] == $'server[$no];
2413      &'c_print($no, &'user($no), $cmd, @params);
2414    }
2415    $params[1] = $text . $ctcp;
2416  }
2417  return ($prefix, $cmd, @params);
2418}
2419
2420sub cp_notice {
2421  local($cno, $prefix, $cmd, @params) = @_;
2422  local($text, $ctcp);
2423  if ($params[1]) {
2424    ($text, $ctcp) = &ctcp_event($cno, 'print_event', 'cncp', $prefix, $cmd, @params);
2425    return () unless ($text || $ctcp);
2426    $params[1] = $text . $ctcp;
2427  }
2428  return ($prefix, $cmd, @params);
2429}
2430
2431sub ss_notice {
2432  local($sno, $prefix, $cmd, @params) = @_;
2433  local($text, $ctcp);
2434  if ($params[1]) {
2435    ($text, $ctcp) = &ctcp_event($sno, 'scan_event', 'cnss', $prefix, $cmd, @params);
2436     return () unless ($text || $ctcp);
2437     $params[1] = $text . $ctcp;
2438  }
2439  return ($prefix, $cmd, @params);
2440}
2441
2442sub sp_notice {
2443  local($sno, $prefix, $cmd, @params) = @_;
2444  local($text, $ctcp);
2445  if ($params[1]) {
2446    ($text, $ctcp) = &ctcp_event($sno, 'print_event', 'cnsp', $prefix, $cmd, @params);
2447    return () unless ($text || $ctcp);
2448    $params[1] = $text . $ctcp;
2449  }
2450  return ($prefix, $cmd, @params);
2451}
2452
2453sub ctcp_event {
2454  local($no, $sub, $event, $prefix, $cmd, @params) = @_;
2455  local($chan, $rest, $tmp, $ctmp, $list, $ctcp, $ccmd, $param);
2456  $chan = $params[0];
2457  $rest = $params[1];
2458  $tmp = '';
2459  $ctmp = '';
2460  $list = '';
2461  while ($rest =~ /^([^\cA]*)\cA([^\cA]*)\cA(.*)$/) {
2462    $tmp .= $1;
2463    $ctcp = $2;
2464    $rest = $3;
2465    next if &'exist($list, $ctcp);
2466    $list = &'add($list, $ctcp);
2467    ($ccmd, $param) = split(/\s+/, $ctcp, 2);
2468    next unless $ccmd;
2469    ($prefix, $ccmd, $chan, $param) = &$sub($'userno[$no], $event . "_\L$ccmd\E", $no, $prefix, $ccmd, $chan, $param);
2470    next unless $ccmd;
2471    if ($param) {
2472      $ctmp .= "\cA$ccmd $param\cA";
2473    } else {
2474      $ctmp .= "\cA$ccmd\cA";
2475    }
2476  }
2477  $tmp .= $rest || '';
2478  return ($tmp, $ctmp);
2479}
Note: See TracBrowser for help on using the browser.