summaryrefslogtreecommitdiffstats
path: root/lib
diff options
context:
space:
mode:
Diffstat (limited to 'lib')
-rw-r--r--lib/ASM/Classes.pm514
-rw-r--r--lib/ASM/Commander.pm61
-rw-r--r--lib/ASM/DB.pm323
-rw-r--r--lib/ASM/Event.pm887
-rw-r--r--lib/ASM/Inspect.pm101
-rw-r--r--lib/ASM/Log.pm112
-rw-r--r--lib/ASM/Services.pm69
-rw-r--r--lib/ASM/Util.pm297
-rw-r--r--lib/ASM/XML.pm69
-rw-r--r--lib/Net/IRC.pm759
-rw-r--r--lib/Net/IRC/Connection.pm1691
-rw-r--r--lib/Net/IRC/DCC.pm808
-rw-r--r--lib/Net/IRC/Event.pm873
-rw-r--r--lib/Net/IRC/EventQueue.pm73
-rw-r--r--lib/Net/IRC/EventQueue/Entry.pm40
15 files changed, 6677 insertions, 0 deletions
diff --git a/lib/ASM/Classes.pm b/lib/ASM/Classes.pm
new file mode 100644
index 0000000..1054f63
--- /dev/null
+++ b/lib/ASM/Classes.pm
@@ -0,0 +1,514 @@
+package ASM::Classes;
+
+use strict;
+use warnings;
+use Text::LevenshteinXS qw(distance);
+use Data::Dumper;
+use Regexp::Wildcards;
+use Carp qw(cluck);
+
+my %sf = ();
+
+sub new
+{
+ my $module = shift;
+ my $self = {};
+ my $tbl = {
+ "strbl" => \&strbl,
+ "strblnew" => \&strblnew,
+ "dnsbl" => \&dnsbl,
+ "floodqueue" => \&floodqueue,
+ "floodqueue2" => \&floodqueue2,
+ "nickspam" => \&nickspam,
+ "splitflood" => \&splitflood,
+ "advsplitflood" => \&advsplitflood,
+ "re" => \&re,
+ "nick" => \&nick,
+ "ident" => \&ident,
+ "host" => \&host,
+ "gecos" => \&gecos,
+ "nuhg" => \&nuhg,
+ "levenflood" => \&levenflood,
+ "proxy" => \&proxy,
+ "nickbl" => \&nickbl,
+ "nickfuzzy" => \&nickfuzzy,
+ "asciiflood" => \&asciiflood,
+ "joinmsgquit" => \&joinmsgquit,
+ "garbagemeter" => \&garbagemeter,
+ "cyclebotnet" => \&cyclebotnet,
+ "banevade" => \&banevade,
+ "urlcrunch" => \&urlcrunch
+ };
+ $self->{ftbl} = $tbl;
+ bless($self);
+ return $self;
+}
+
+sub garbagemeter {
+ my ($chk, $id, $event, $chan, $rev) = @_;
+ my @cut = split(/:/, $chk->{content});
+ my $limit = int($cut[0]);
+ my $timeout = int($cut[1]);
+ my $threshold = int($cut[2]);
+ my $threshold2 = int($cut[3]);
+ my $wordcount = 0;
+ my $line = $event->{args}->[0];
+ return 0 unless ($line =~ /^[A-Za-z: ]+$/);
+ my @words = split(/ /, $line);
+ return 0 unless ((scalar @words) >= $threshold2);
+ foreach my $word (@words) {
+ if (defined($::wordlist{lc $word})) {
+ $wordcount += 1;
+ }
+ return 0 if ($wordcount >= $threshold);
+ }
+ return 1 if ( flood_add( $chan, $id, 0, $timeout ) == $limit );
+ return 0;
+}
+
+sub joinmsgquit
+{
+ my ($chk, $id, $event, $chan, $rev) = @_;
+ my $time = $chk->{content};
+##STATE
+ $chan = lc $chan; #don't know if this is necessary but I'm trying to track down some mysterious state tracking corruption
+ return 0 unless defined($::sc{$chan}{users}{lc $event->{nick}}{jointime});
+ return 0 unless defined($::sc{$chan}{users}{lc $event->{nick}}{msgtime});
+ return 0 if ((time - $::sc{$chan}{users}{lc $event->{nick}}{jointime}) > $time);
+ return 0 if ((time - $::sc{$chan}{users}{lc $event->{nick}}{msgtime}) > $time);
+ return 1;
+}
+
+sub urlcrunch
+{
+ my ($chk, $id, $event, $chan, $response) = @_;
+ return 0 unless defined($response);
+ return 0 unless ref($response);
+ return 0 unless defined($response->{_previous});
+ return 0 unless defined($response->{_previous}->{_headers});
+ return 0 unless defined($response->{_previous}->{_headers}->{location});
+ if ($response->{_previous}->{_headers}->{location} =~ /$chk->{content}/i) {
+ return 1;
+ }
+ return 0;
+}
+
+sub check
+{
+ my $self = shift;
+ my $item = shift;
+ return $self->{ftbl}->{$item}->(@_);
+}
+
+sub nickbl
+{
+ my ($chk, $id, $event, $chan, $rev) = @_;
+ my $match = lc $event->{nick};
+ foreach my $line (@::nick_blacklist) {
+ if ($line eq $match) {
+ return 1;
+ }
+ }
+ return 0;
+}
+
+sub banevade
+{
+ my ($chk, $id, $event, $chan, $rev) = @_;
+ my $ip = ASM::Util->getNickIP($event->{nick});
+ return 0 unless defined($ip);
+ if (defined($::sc{lc $chan}{ipbans}{$ip})) {
+ return 1;
+ }
+ return 0;
+}
+
+sub proxy
+{
+ my ($chk, $id, $event, $chan, $rev) = @_;
+ if (defined($rev) and ($rev =~ /(\d+)\.(\d+)\.(\d+)\.(\d+)\./)) {
+ if (defined($::proxies{"$4.$3.$2.$1"})) {
+ return 1;
+ }
+ }
+ return 0;
+}
+
+my %ls = ();
+sub levenflood
+{
+ my ($chk, $id, $event, $chan) = @_;
+ my $text;
+ if ($event->{type} =~ /^(public|notice|part|caction)$/) {
+ $text = $event->{args}->[0];
+ }
+ return 0 unless ( defined($text) && (length($text) >= 30) );
+ if ( ! defined($ls{$chan}) ) {
+ $ls{$chan} = [ $text ];
+ return 0;
+ }
+ my @leven = @{$ls{$chan}};
+ my $ret = 0;
+ if ( $#leven >= 5 ) {
+ my $mx = 0;
+ foreach my $item ( @leven ) {
+ next unless length($text) eq length($item);
+ my $tld = distance($text, $item);
+ if ($tld <= 4) {
+ $mx = $mx + 1;
+ }
+ }
+ if ($mx >= 5) {
+ $ret = 1;
+ }
+ }
+ push(@leven, $text);
+ shift @leven if $#leven > 10;
+ $ls{$chan} = \@leven;
+ return $ret;
+}
+
+sub nickfuzzy
+{
+ my ($chk, $id, $event, $chan) = @_;
+ my $nick = $event->{nick};
+ $nick = $event->{args}->[0] if ($event->{type} eq 'nick');
+ my ($fuzzy, $match) = split(/:/, $chk->{content});
+ my @nicks = split(/,/, $match);
+ foreach my $item (@nicks) {
+ if (distance(lc $nick, lc $item) <= $fuzzy) {
+ return 1;
+ }
+ }
+ return 0;
+}
+
+sub dnsbl
+{
+ my ($chk, $id, $event, $chan, $rev) = @_;
+# return unless index($event->{host}, '/') == -1;
+# hopefully getting rid of this won't cause shit to assplode
+# but I'm getting rid of it so it can detect cgi:irc shit
+# return 0;
+ if (defined $rev) {
+ ASM::Util->dprint("Querying $rev$chk->{content}", "dnsbl");
+ #cluck "Calling gethostbyname in dnsbl";
+ my $iaddr = gethostbyname( "$rev$chk->{content}" );
+ my @dnsbl = unpack( 'C4', $iaddr ) if defined $iaddr;
+ my $strip;
+ if (@dnsbl) {
+ $strip = sprintf("%s.%s.%s.%s", @dnsbl);
+ ASM::Util->dprint("found host (rev $rev) in $chk->{content} - $strip", 'dnsbl');
+ }
+ if ((@dnsbl) && (defined($::dnsbl->{query}->{$chk->{content}}->{response}->{$strip}))) {
+ $::lastlookup=$::dnsbl->{query}->{$chk->{content}}->{response}->{$strip}->{content};
+ ASM::Util->dprint("chk->content: $chk->{content}", 'dnsbl');
+ ASM::Util->dprint("strip: $strip", 'dnsbl');
+ ASM::Util->dprint("result: " . $::dnsbl->{query}->{$chk->{content}}->{response}->{$strip}->{content}, 'dnsbl');
+ $::sn{lc $event->{nick}}->{dnsbl} = 1;
+ # lol really icky hax
+ return $::dnsbl->{query}->{$chk->{content}}->{response}->{$strip}->{content};
+ }
+ }
+ return 0;
+}
+
+sub floodqueue2 {
+ my ($chk, $id, $event, $chan, $rev) = @_;
+ my @cut = split(/:/, $chk->{content});
+
+ my $cvt = Regexp::Wildcards->new(type => 'jokers');
+ my $hit = 0;
+ foreach my $mask ( keys %{$::sc{lc $chan}{quiets}}) {
+ if ($mask !~ /^\$/) {
+ my @div = split(/\$/, $mask);
+ my $regex = $cvt->convert($div[0]);
+ if (lc $event->{from} =~ lc $regex) {
+ $hit = 1;
+ }
+ } elsif ( (defined($::sn{lc $event->{nick}}{account})) && ($mask =~ /^\$a:(.*)/)) {
+ my @div = split(/\$/, $mask);
+ my $regex = $cvt->convert($div[0]);
+ if (lc ($::sn{lc $event->{nick}}{account}) =~ lc $regex) {
+ $hit = 1;
+ }
+ }
+ }
+ return 0 unless $hit;
+
+ return 1 if ( flood_add( $chan, $id, $event->{host}, int($cut[1]) ) == int($cut[0]) );
+ return 0;
+}
+
+sub floodqueue {
+ my ($chk, $id, $event, $chan, $rev) = @_;
+ my @cut = split(/:/, $chk->{content});
+ return 1 if ( flood_add( $chan, $id, $event->{host}, int($cut[1]) ) == int($cut[0]) );
+ return 0;
+}
+
+sub asciiflood {
+ my ($chk, $id, $event, $chan, $rev) = @_;
+ my @cut = split(/:/, $chk->{content});
+ return 0 if (length($event->{args}->[0]) < $cut[0]);
+ return 0 if ($event->{args}->[0] =~ /[A-Za-z0-9]/);
+ return 1 if ( flood_add( $chan, $id, $event->{host}, int($cut[2]) ) == int($cut[1]) );
+ return 0;
+}
+
+sub cyclebotnet
+{
+ my ($chk, $id, $event, $chan, $rev) = @_;
+ my ($cycletime, $queueamt, $queuetime) = split(/:/, $chk->{content});
+ $chan = lc $chan; #don't know if this is necessary but I'm trying to track down some mysterious state tracking corruption
+ return 0 unless defined($::sc{$chan}{users}{lc $event->{nick}}{jointime});
+ return 0 if ((time - $::sc{$chan}{users}{lc $event->{nick}}{jointime}) > int($cycletime));
+ return 1 if ( flood_add( $chan, $id, "cycle", int($queuetime)) == int($queueamt) );
+ return 0;
+}
+
+sub nickspam {
+ my ($chk, $id, $event, $chan) = @_;
+ my @cut = split(/:/, $chk->{content});
+ if ( length $event->{args}->[0] >= int($cut[0]) ) {
+ my %users = %{$::sc{lc $chan}->{users}};
+ my %x = map { $_=>$_ } keys %users;
+ my @uniq = grep( $x{$_}, split( /[^a-zA-Z0-9_\\|`[\]{}^-]+/ , lc $event->{args}->[0]) );
+ return 1 if ( @uniq >= int($cut[1]) );
+ }
+ return 0;
+}
+
+my %cf=();
+my %bs=();
+my $cfc = 0;
+sub process_cf
+{
+ foreach my $nid ( keys %cf ) {
+ foreach my $xchan ( keys %{$cf{$nid}} ) {
+ next if $xchan eq 'timeout';
+ foreach my $host ( keys %{$cf{$nid}{$xchan}} ) {
+ next unless defined $cf{$nid}{$xchan}{$host}[0];
+ while ( time >= $cf{$nid}{$xchan}{$host}[0] + $cf{$nid}{'timeout'} ) {
+ shift ( @{$cf{$nid}{$xchan}{$host}} );
+ if ( (scalar @{$cf{$nid}{$xchan}{$host}}) == 0 ) {
+ delete $cf{$nid}{$xchan}{$host};
+ last;
+ }
+# last if ( $#{ $cf{$nid}{$xchan}{$host} } == 0 );
+# shift ( @{$cf{$nid}{$xchan}{$host}} );
+ }
+ }
+ }
+ }
+}
+
+sub splitflood {
+ my ($chk, $id, $event, $chan) = @_;
+ my $text;
+ my @cut = split(/:/, $chk->{content});
+ $cf{$id}{timeout}=int($cut[1]);
+ if ($event->{type} =~ /^(public|notice|part|caction)$/) {
+ $text=$event->{args}->[0];
+ }
+ return unless defined($text);
+ # a bit ugly but this should avoid alerting on spammy bot commands
+ # give them the benefit of the doubt if they talked before ... but not too recently
+ # if we didn't see them join, assume they did talk at some point
+ my $msgtime = $::sc{$chan}{users}{lc $event->{nick}}{msgtime} // 0;
+ $msgtime ||= 1 if !$::sc{$chan}{users}{lc $event->{nick}}{jointime};
+ return if $text =~ /^[^\w\s]+\w+\s*$/ && $msgtime && ($msgtime + 2 * $cf{$id}{timeout}) < time;
+# return unless length($text) >= 10;
+ if (defined($bs{$id}{$text}) && (time <= $bs{$id}{$text} + 600)) {
+ return 1;
+ }
+ push( @{$cf{$id}{$chan}{$text}}, time );
+ while ( time >= $cf{$id}{$chan}{$text}[0] + $cf{$id}{'timeout'} ) {
+ last if ( $#{$cf{$id}{$chan}{$text}} == 0 );
+ shift ( @{$cf{$id}{$chan}{$text}} );
+ }
+ $cfc = $cfc + 1;
+ if ( $cfc >= 100 ) {
+ $cfc = 0;
+ process_cf();
+ }
+ if ( scalar @{$cf{$id}{$chan}{$text}} == int($cut[0]) ) {
+ $bs{$id}{$text} = time unless length($text) < 10;
+ return 1;
+ }
+ return 0;
+}
+
+sub advsplitflood {
+ my ($chk, $id, $event, $chan) = @_;
+ my $text;
+ my @cut = split(/:/, $chk->{content});
+ $cf{$id}{timeout}=int($cut[1]);
+ if ($event->{type} =~ /^(public|notice|part|caction)$/) {
+ $text=$event->{args}->[0];
+ }
+ return unless defined($text);
+ $text=~s/^\d*(.*)\d*$/$1/;
+ return unless length($text) >= 10;
+ if (defined($bs{$id}{$text}) && (time <= $bs{$id}{$text} + 600)) {
+ return 1;
+ }
+ push( @{$cf{$id}{$chan}{$text}}, time );
+ while ( time >= $cf{$id}{$chan}{$text}[0] + $cf{$id}{'timeout'} ) {
+ last if ( $#{$cf{$id}{$chan}{$text}} == 0 );
+ shift ( @{$cf{$id}{$chan}{$text}} );
+ }
+ $cfc = $cfc + 1;
+ if ( $cfc >= 100 ) {
+ $cfc = 0;
+ process_cf();
+ }
+ if ( scalar @{$cf{$id}{$chan}{$text}} == int($cut[0]) ) {
+ $bs{$id}{$text} = time;
+ return 1;
+ }
+ return 0;
+}
+
+sub re {
+ my ($chk, $id, $event, $chan) = @_;
+ my $match = $event->{args}->[0];
+ $match = $event->{nick} if ($event->{type} eq 'join');
+ return 1 if ($match =~ /$chk->{content}/);
+ return 0;
+}
+
+sub strbl {
+ my ($chk, $id, $event, $chan) = @_;
+ my $match = lc $event->{args}->[0];
+ foreach my $line (@::string_blacklist) {
+ my $xline = lc $line;
+ my $idx = index $match, $xline;
+ if ( $idx != -1 ) {
+ return 1;
+ }
+ }
+ return 0;
+}
+
+sub strblnew {
+ my ($chk, $xid, $event, $chan) = @_;
+ my $match = lc $event->{args}->[0];
+ foreach my $id (keys %{$::blacklist->{string}}) {
+ my $line = lc $::blacklist->{string}->{$id}->{content};
+ my $idx = index $match, $line;
+ if ( $idx != -1 ) {
+ my $setby = $::blacklist->{string}->{$id}->{setby};
+ $setby = substr($setby, 0, 1) . "\x02\x02" . substr($setby, 1);
+ return defined($::blacklist->{string}->{$id}->{reason}) ?
+ "id $id added by $setby because $::blacklist->{string}->{$id}->{reason}" :
+ "id $id added by $setby for no reason";
+ }
+ }
+ return 0;
+}
+
+sub nick {
+ my ($chk, $id, $event, $chan) = @_;
+ if ( lc $event->{nick} eq lc $chk->{content} ) {
+ return 1;
+ }
+ return 0;
+}
+
+sub ident {
+ my ( $chk, $id, $event, $chan) = @_;
+ if ( lc $event->{user} eq lc $chk->{content} ) {
+ return 1;
+ }
+ return 0;
+}
+
+sub host {
+ my ( $chk, $id, $event, $chan) = @_;
+ if ( lc $event->{host} eq lc $chk->{content} ) {
+ return 1;
+ }
+ return 0;
+}
+
+sub gecos {
+ my ( $chk, $id, $event, $chan) = @_;
+ if ( lc $::sn{lc $event->{nick}}->{gecos} eq lc $chk->{content} ) {
+ return 1;
+ }
+ return 0;
+}
+
+sub nuhg {
+ my ( $chk, $id, $event, $chan) = @_;
+ return 0 unless defined($::sn{lc $event->{nick}}->{gecos});
+ my $match = $event->{from} . '!' . $::sn{lc $event->{nick}}->{gecos};
+ return 1 if ($match =~ /$chk->{content}/);
+ return 0;
+}
+
+sub invite {
+ my ( $chk, $id, $event, $chan) = @_;
+ return 1;
+}
+
+my $sfc = 0;
+
+sub flood_add
+{
+ my ( $chan, $id, $host, $to ) = @_;
+ push( @{$sf{$id}{$chan}{$host}}, time );
+ while ( time >= $sf{$id}{$chan}{$host}[0] + $to ) {
+ last if ( $#{ $sf{$id}{$chan}{$host} } == 0 );
+ shift( @{$sf{$id}{$chan}{$host}} );
+ }
+ $sf{$id}{'timeout'} = $to;
+ $sfc = $sfc + 1;
+ if ($sfc > 100) {
+ $sfc = 0;
+ flood_process();
+ }
+# return $#{ @{$sf{$id}{$chan}{$host}}}+1;
+ return scalar @{$sf{$id}{$chan}{$host}};
+}
+
+sub flood_process
+{
+ for my $id ( keys %sf ) {
+ for my $chan ( keys %{$sf{$id}} ) {
+ next if $chan eq 'timeout';
+ for my $host ( keys %{$sf{$id}{$chan}} ) {
+ next unless defined $sf{$id}{$chan}{$host}[0];
+ while ( time >= $sf{$id}{$chan}{$host}[0] + $sf{$id}{'timeout'} ) {
+ shift ( @{$sf{$id}{$chan}{$host}} );
+ if ( (scalar @{$sf{$id}{$chan}{$host}}) == 0 ) {
+ delete $sf{$id}{$chan}{$host};
+ last;
+ }
+# last if ( $#{ $sf{$id}{$chan}{$host} } == 0 );
+# shift ( @{$sf{$id}{$chan}{$host}} );
+ }
+ }
+ }
+ }
+}
+
+sub dump
+{
+ #%sf, %ls, %cf, %bs
+ open(FH, ">", "sf.txt");
+ print FH Dumper(\%sf);
+ close(FH);
+ open(FH, ">", "ls.txt");
+ print FH Dumper(\%ls);
+ close(FH);
+ open(FH, ">", "cf.txt");
+ print FH Dumper(\%cf);
+ close(FH);
+ open(FH, ">", "bs.txt");
+ print FH Dumper(\%bs);
+ close(FH);
+}
+
+1;
diff --git a/lib/ASM/Commander.pm b/lib/ASM/Commander.pm
new file mode 100644
index 0000000..aa79f4d
--- /dev/null
+++ b/lib/ASM/Commander.pm
@@ -0,0 +1,61 @@
+package ASM::Commander;
+
+use warnings;
+use strict;
+use IO::All;
+use POSIX qw(strftime);
+use Data::Dumper;
+use URI::Escape;
+
+sub new
+{
+ my $module = shift;
+ my $self = {};
+ bless($self);
+ return $self;
+}
+
+sub command
+{
+ my ($self, $conn, $event) = @_;
+ my $args = $event->{args}->[0];
+ my $from = $event->{from};
+ my $cmd = $args;
+ my $d1;
+ my $nick = lc $event->{nick};
+ my $acct = lc $::sn{$nick}->{account};
+# return 0 unless (ASM::Util->speak($event->{to}->[0]));
+ foreach my $command ( @{$::commands->{command}} )
+ {
+ my $fail = 0;
+ unless ( (ASM::Util->speak($event->{to}->[0])) ) {
+ next unless (defined($command->{nohush}) && ($command->{nohush} eq "nohush"));
+ }
+ if (defined($command->{flag})) { #If the command is restricted,
+ if (!defined($::users->{person}->{$acct})) { #make sure the requester has an account
+ $fail = 1;
+ }
+ elsif (!defined($::users->{person}->{$acct}->{flags})) { #make sure the requester has flags defined
+ $fail = 1;
+ }
+ elsif (!(grep {$_ eq $command->{flag}} split('', $::users->{person}->{$acct}->{flags}))) { #make sure the requester has the needed flags
+ $fail = 1;
+ }
+ }
+ if ($cmd=~/$command->{cmd}/) {
+ ASM::Util->dprint("$event->{from} told me: $cmd", "commander");
+ if (!ASM::Util->notRestricted($nick, "nocommands")) {
+ $fail = 1;
+ }
+ if ($fail == 1) {
+ $conn->privmsg($nick, "You don't have permission to use that command, or you're not signed into nickserv.");
+ } else {
+ eval $command->{content};
+ warn $@ if $@;
+ }
+ last;
+ }
+ }
+}
+
+1;
diff --git a/lib/ASM/DB.pm b/lib/ASM/DB.pm
new file mode 100644
index 0000000..86a1c78
--- /dev/null
+++ b/lib/ASM/DB.pm
@@ -0,0 +1,323 @@
+package ASM::DB;
+
+use warnings;
+use strict;
+use DBI;
+use Data::Dumper;
+
+sub new {
+ my $module = shift;
+ my ($db, $host, $port, $user, $pass, $table, $actiontable, $dblog) = @_;
+ my $self = {};
+ $self->{DBH} = DBI->connect("DBI:mysql:database=$db;host=$host;port=$port", $user, $pass);
+ $self->{DBH_LOG} = DBI->connect("DBI:mysql:database=$dblog;host=$host;port=$port", $user, $pass);
+ $self->{DBH}->{mysql_auto_reconnect} = 1;
+ $self->{DBH_LOG}->{mysql_auto_reconnect} = 1;
+ $self->{TABLE} = $table;
+ $self->{ACTIONTABLE} = $actiontable;
+ bless($self);
+ return $self;
+}
+
+#sub sql_connect
+#{
+# $::dbh = DBI->connect("DBI:mysql:database=$::mysql->{db};host=$::mysql->{host};port=$::mysql->{port}",
+# $::mysql->{user}, $::mysql->{pass});
+# $::dbh->{mysql_auto_reconnect} = 1;
+#}
+
+sub raw
+{
+ my $self = shift;
+ my ($conn, $tgt, $dbh, $qry) = @_;
+ my $sth = $dbh->prepare($qry);
+ $sth->execute;
+ my $names = $sth->{'NAME'};
+ my $numFields = $sth->{'NUM_OF_FIELDS'};
+ my $string = "";
+ for (my $i = 0; $i < $numFields; $i++) {
+ $string = $string . sprintf("%s%s", $i ? "," : "", $$names[$i]);
+ }
+ $conn->privmsg($tgt, $string);
+ while (my $ref = $sth->fetchrow_arrayref) {
+ $string = "";
+ for (my $i = 0; $i < $numFields; $i++) {
+ $string = $string . sprintf("%s%s", $i ? "," : "", $$ref[$i]);
+ }
+ $conn->privmsg($tgt, $string);
+ }
+}
+
+sub record
+{
+ my $self = shift;
+ my ($channel, $nick, $user, $host, $gecos, $level, $id, $reason) = @_;
+ $gecos //= "NOT_DEFINED";
+
+ my $dbh = $self->{DBH};
+ $dbh->do("INSERT INTO $self->{TABLE} (channel, nick, user, host, gecos, level, id, reason) VALUES (" .
+ $dbh->quote($channel) . ", " . $dbh->quote($nick) . ", " . $dbh->quote($user) .
+ ", " . $dbh->quote($host) . ", " . $dbh->quote($gecos) . ", " . $dbh->quote($level) . ", " .
+ $dbh->quote($id) . ", " . $dbh->quote($reason) . ");");
+}
+
+sub actionlog
+{
+ my ($self, $event, $modedata1, $modedata2) = @_;
+ my $dbh = $self->{DBH};
+ my ($action, $reason, $channel,
+ $nick, $user, $host, $gecos, $account, $ip,
+ $bynick, $byuser, $byhost, $bygecos, $byaccount);
+
+ if ($event->{type} eq 'mode') {
+ $action = $modedata1;
+ $nick = $modedata2;
+ $channel = lc $event->{to}->[0];
+ $bynick = $event->{nick};
+ $byuser = $event->{user};
+ $byhost = $event->{host};
+ } elsif ($event->{type} eq 'quit') {
+ my $quitmsg = $event->{args}->[0];
+ if ($quitmsg =~ /^Killed \((\S+) \((.*)\)\)$/) {
+ $bynick = $1;
+ $reason = $2 unless ($2 eq '<No reason given>');
+ return if ($reason =~ /Nickname regained by services/);
+ $action = 'kill';
+ } elsif ($quitmsg =~ /^K-Lined$/) {
+ $action = 'k-line';
+ } else {
+ return; #quit not forced/tracked
+ }
+ $nick = $event->{nick};
+ $user = $event->{user};
+ $host = $event->{host};
+ } elsif (($event->{type} eq 'part') && ($event->{args}->[0] =~ /^requested by (\S+) \((.*)\)/)) {
+ $bynick = $1;
+ $reason = $2 unless (lc $reason eq lc $event->{nick});
+ $action = 'remove';
+ $nick = $event->{nick};
+ $user = $event->{user};
+ $host = $event->{host};
+ $channel = $event->{to}->[0];
+ } elsif ($event->{type} eq 'kick') {
+ $action = 'kick';
+ $bynick = $event->{nick};
+ $byuser = $event->{user};
+ $byhost = $event->{host};
+ $reason = $event->{args}->[1] unless ($event->{args}->[1] eq $event->{to}->[0]);
+ $nick = $event->{to}->[0];
+ $channel = $event->{args}->[0];
+ }
+ return unless defined($action);
+# $bynick = lc $bynick if defined $bynick; #we will lowercase the NUHGA info later.
+ if ( (defined($bynick)) && (defined($::sn{lc $bynick})) ) { #we have the nick taking the action available, fill in missing NUHGA info
+ $byuser //= $::sn{lc $bynick}{user};
+ $byhost //= $::sn{lc $bynick}{host};
+ $bygecos //= $::sn{lc $bynick}{gecos};
+ $byaccount //= $::sn{lc $bynick}{account};
+ if (($byaccount eq '0') or ($byaccount eq '*')) {
+ $byaccount = undef;
+ }
+ }
+# $nick = lc $nick if defined $nick;
+ if ( (defined($nick)) && (defined($::sn{lc $nick})) ) { #this should always be true, else something has gone FUBAR
+ $user //= $::sn{lc $nick}{user};
+ $host //= $::sn{lc $nick}{host};
+ $gecos //= $::sn{lc $nick}{gecos};
+ $account //= $::sn{lc $nick}{account};
+ if (($account eq '0') or ($account eq '*')) {
+ $account = undef;
+ }
+ $ip = ASM::Util->getNickIP(lc $nick);
+ }
+# my ($action, $reason, $channel,
+# $nick, $user, $host, $gecos, $account, $ip
+# $bynick, $byuser, $byhost, $bygecos, $byaccount);
+#Now, time to escape/NULLify everything
+ $action = $dbh->quote($action);
+ if (defined($reason)) { $reason = $dbh->quote($reason); } else { $reason = 'NULL'; }
+## removed lc's from everything except IP
+ if (defined($channel)) { $channel = $dbh->quote($channel); } else { $channel = 'NULL'; }
+
+ if (defined($nick)) { $nick = $dbh->quote($nick); } else { $nick = 'NULL'; }
+ if (defined($user)) { $user = $dbh->quote($user); } else { $user = 'NULL'; }
+ if (defined($host)) { $host = $dbh->quote($host); } else { $host = 'NULL'; }
+ if (defined($gecos)) { $gecos = $dbh->quote($gecos); } else { $gecos = 'NULL'; }
+ if (defined($account)) { $account = $dbh->quote($account); } else { $account = 'NULL'; }
+ if (defined($ip)) { $ip = $dbh->quote($ip); } else { $ip = 'NULL'; }
+
+ if (defined($bynick)) { $bynick = $dbh->quote($bynick); } else { $bynick = 'NULL'; }
+ if (defined($byuser)) { $byuser = $dbh->quote($byuser); } else { $byuser = 'NULL'; }
+ if (defined($byhost)) { $byhost = $dbh->quote($byhost); } else { $byhost = 'NULL'; }
+ if (defined($bygecos)) { $bygecos = $dbh->quote($bygecos); } else { $bygecos = 'NULL'; }
+ if (defined($byaccount)) { $byaccount = $dbh->quote($byaccount); } else { $byaccount = 'NULL'; }
+ my $sqlstr = "INSERT INTO $self->{ACTIONTABLE} " .
+ "(action, reason, channel, " .
+ "nick, user, host, gecos, account, ip, " .
+ "bynick, byuser, byhost, bygecos, byaccount)" .
+ " VALUES " .
+ "($action, $reason, $channel, " .
+ "$nick, $user, $host, $gecos, $account, $ip, " .
+ "$bynick, $byuser, $byhost, $bygecos, $byaccount);";
+ ASM::Util->dprint( $sqlstr, 'mysql' );
+ $dbh->do( $sqlstr );
+ return $dbh->last_insert_id(undef, undef, $self->{ACTIONTABLE}, undef);
+# $::sn{ow} looks like:
+#$VAR1 = {
+# "account" => "afterdeath",
+# "gecos" => "William Athanasius Heimbigner",
+# "user" => "icxcnika",
+# "mship" => [
+# "#baadf00d",
+# "#antispammeta-debug",
+# "#antispammeta"
+# ],
+# "host" => "freenode/weird-exception/network-troll/afterdeath"
+# };
+
+}
+
+#FIXME: This function is shit. Also, it doesn't work like I want it to with mode.
+sub logg
+{
+ my $self = shift;
+ my ($event) = @_;
+ my $dbh = $self->{DBH_LOG};
+ my $table = $event->{type};
+ $table = 'action' if ($table eq 'caction');
+ $table = 'privmsg' if ($table eq 'public');
+ return if (($table eq 'action') or ($table eq 'privmsg')); #Disabling logging of privmsg stuffs to mysql. no point.
+ my $realtable = $table;
+ $realtable = 'joins' if $realtable eq 'join'; #mysql doesn't like a table named join
+ my $string = 'INSERT INTO `' . $realtable . '` (';
+## begin saner code for this function
+ if ($table eq 'quit') {
+ $string = 'INSERT INTO `quit` (nick, user, host, geco, ip, account, content1) VALUES (' .
+ $dbh->quote($event->{nick}) . ',' . $dbh->quote($event->{user}) . ',' .
+ $dbh->quote($event->{host}) . ',' . $dbh->quote($::sn{lc $event->{nick}}->{gecos}) . ',';
+ my $ip = ASM::Util->getNickIP(lc $event->{nick}, $event->{host});
+ if (defined($ip)) { $ip = $dbh->quote($ip); } else { $ip = 'NULL'; }
+ my $account = $::sn{lc $event->{nick}}->{account};
+ if (!defined($account) or ($account eq '0') or ($account eq '*')) {
+ $account = 'NULL';
+ } else {
+ $account = $dbh->quote($account);
+ }
+ $string = $string . $ip . ',' . $account . ',' . $dbh->quote($event->{args}->[0]) . ');';
+ $dbh->do($string);
+ ASM::Util->dprint($string, 'mysql');
+ return;
+ } elsif ($table eq 'part') {
+ $string = 'INSERT INTO `part` (channel, nick, user, host, geco, ip, account, content1) VALUES (' .
+ $dbh->quote($event->{to}->[0]) . ',' .
+ $dbh->quote($event->{nick}) . ',' . $dbh->quote($event->{user}) . ',' .
+ $dbh->quote($event->{host}) . ',' . $dbh->quote($::sn{lc $event->{nick}}->{gecos}) . ',';
+ my $ip = ASM::Util->getNickIP(lc $event->{nick}, $event->{host});
+ if (defined($ip)) { $ip = $dbh->quote($ip); } else { $ip = 'NULL'; }
+ my $account = $::sn{lc $event->{nick}}->{account};
+ if (!defined($account) or ($account eq '0') or ($account eq '*')) {
+ $account = 'NULL';
+ } else {
+ $account = $dbh->quote($account);
+ }
+ $string = $string . $ip . ',' . $account . ',' . $dbh->quote($event->{args}->[0]) . ');';
+ $dbh->do($string);
+ ASM::Util->dprint($string, 'mysql');
+ return;
+ } elsif ($table eq 'kick') {
+ $string = 'INSERT INTO `kick` (channel, nick, user, host, geco, ip, account, ' .
+ 'victim_nick, victim_user, victim_host, victim_geco, victim_ip, victim_account, content1) VALUES (' .
+ $dbh->quote($event->{args}->[0]) . ',' .
+ $dbh->quote($event->{nick}) . ',' . $dbh->quote($event->{user}) . ',' .
+ $dbh->quote($event->{host}) . ',' . $dbh->quote($::sn{lc $event->{nick}}->{gecos}) . ',';
+ my $ip = ASM::Util->getNickIP(lc $event->{nick});
+ if (defined($ip)) { $ip = $dbh->quote($ip); } else { $ip = 'NULL'; }
+ my $account = $::sn{lc $event->{nick}}->{account};
+ if (($account eq '0') or ($account eq '*')) { $account = 'NULL'; } else { $account = $dbh->quote($account); }
+ $string = $string . $ip . ',' . $account;
+ $string = $string . ', ' . $dbh->quote($event->{to}->[0]);
+ $string = $string . ', ' . $dbh->quote($::sn{lc $event->{to}->[0]}->{user});
+ $string = $string . ', ' . $dbh->quote($::sn{lc $event->{to}->[0]}->{host});
+ $string = $string . ', ' . $dbh->quote($::sn{lc $event->{to}->[0]}->{gecos});
+ my $vic_ip = ASM::Util->getNickIP(lc $event->{to}->[0]);
+ if (defined($vic_ip)) { $vic_ip = $dbh->quote($vic_ip); } else { $vic_ip = 'NULL'; }
+ my $vic_account = $::sn{lc $event->{to}->[0]}->{account};
+ if (($vic_account eq '0') or ($vic_account eq '*')) { $vic_account = 'NULL'; } else { $vic_account = $dbh->quote($vic_account); }
+ $string = $string . ', ' . $vic_ip . ',' . $vic_account . ',' . $dbh->quote($event->{args}->[1]) . ');';
+ $dbh->do($string);
+ ASM::Util->dprint($string, 'mysql');
+ return;
+ }
+## end saner code for this function
+ if (($table ne 'nick') && ($table ne 'quit')) {
+ $string = $string . 'channel, ';
+ }
+ $string = $string . 'nick, user, host, geco';
+ if (($table ne 'join') && ($table ne 'kick')) {
+ $string = $string . ', content1';
+ }
+ if ($table eq 'mode') {
+ $string = $string . ', content2';
+ }
+ if ($table eq 'kick') {
+ $string = $string . ', victim_nick, victim_user, victim_host, victim_geco, content1';
+ }
+ $string = $string . ') VALUES (';
+ if (($table ne 'nick') && ($table ne 'quit') && ($table ne 'kick')) {
+ $string = $string . $dbh->quote($event->{to}->[0]) . ", ";
+ }
+ if ($table eq 'kick') {
+ $string = $string . $dbh->quote($event->{args}->[0]) . ", ";
+ }
+ my $geco = $::sn{lc $event->{nick}}->{gecos};
+ $string = $string . $dbh->quote($event->{nick}) . ", " . $dbh->quote($event->{user}) . ", " .
+ $dbh->quote($event->{host}) . ", " . $dbh->quote($geco);
+ if (($table ne 'join') && ($table ne 'kick')) {
+ $string = $string. ', ' . $dbh->quote($event->{args}->[0]);
+ }
+ if ($table eq 'kick') {
+ $string = $string . ', ' . $dbh->quote($event->{to}->[0]);
+ $string = $string . ', ' . $dbh->quote($::sn{lc $event->{to}->[0]}->{user});
+ $string = $string . ', ' . $dbh->quote($::sn{lc $event->{to}->[0]}->{host});
+ $string = $string . ', ' . $dbh->quote($::sn{lc $event->{to}->[0]}->{gecos});
+ $string = $string . ', ' . $dbh->quote($event->{args}->[1]);
+ }
+ if ($table eq 'mode') {
+ $string = $string . ', ' . $dbh->quote($event->{args}->[1]);
+ }
+ $string = $string . ');';
+# ASM::Util->dprint($string, "mysql");
+ $dbh->do($string);
+}
+
+sub query
+{
+ my $self = shift;
+ my ($channel, $nick, $user, $host) = @_;
+ my $dbh = $self->{DBH};
+ $channel = $dbh->quote($channel);
+ $nick = $dbh->quote($nick);
+ $user = $dbh->quote($user);
+ $host = $dbh->quote($host);
+
+ $nick =~ s/\*/%/g;
+ $nick =~ s/_/\\_/g;
+ $nick =~ s/\?/_/g;
+
+ $user =~ s/\*/%/g;
+ $user =~ s/_/\\_/g;
+ $user =~ s/\?/_/g;
+
+ $host =~ s/\*/%/g;
+ $host =~ s/_/\\_/g;
+ $host =~ s/\?/_/g;
+ my $sth = $dbh->prepare("SELECT * from $self->{TABLE} WHERE channel like $channel and nick like $nick and user like $user and host like $host;");
+ $sth->execute;
+ my $i = 0;
+ while (my $ref = $sth->fetchrow_arrayref) {
+ $i++;
+ }
+ return $i;
+}
+
+1;
diff --git a/lib/ASM/Event.pm b/lib/ASM/Event.pm
new file mode 100644
index 0000000..e6f4c23
--- /dev/null
+++ b/lib/ASM/Event.pm
@@ -0,0 +1,887 @@
+package ASM::Event;
+use warnings;
+use strict;
+
+use Data::Dumper;
+use Text::LevenshteinXS qw(distance);
+use IO::All;
+use POSIX qw(strftime);
+use Regexp::Wildcards;
+use HTTP::Request;
+
+sub cs {
+ my ($chan) = @_;
+ $chan = lc $chan;
+ $chan =~ s/^[@+]//;
+ return $::channels->{channel}->{$chan} if ( defined($::channels->{channel}->{$chan}) );
+ return $::channels->{channel}->{default};
+}
+
+sub maxlen {
+ my ($a, $b) = @_;
+ my ($la, $lb) = (length($a), length($b));
+ return $la if ($la > $lb);
+ return $lb;
+}
+
+sub new
+{
+ my $module = shift;
+ my ($conn, $inspector) = @_;
+ my $self = {};
+ $self->{CONN} = $conn;
+ $self->{INSPECTOR} = $inspector;
+ ASM::Util->dprint('Installing handler routines...', 'startup');
+ $conn->add_default_handler(\&blah);
+ $conn->add_handler('bannedfromchan', \&on_bannedfromchan);
+ $conn->add_handler('mode', \&on_mode);
+ $conn->add_handler('join', \&on_join);
+ $conn->add_handler('part', \&on_part);
+ $conn->add_handler('quit', \&on_quit);
+ $conn->add_handler('nick', \&on_nick);
+ $conn->add_handler('notice', \&on_notice);
+ $conn->add_handler('caction', \&on_public);
+ $conn->add_handler('msg', \&on_msg);
+ $conn->add_handler('namreply', \&on_names);
+ $conn->add_handler('endofnames', \&on_names);
+ $conn->add_handler('public', \&on_public);
+ $conn->add_handler('376', \&on_connect);
+ $conn->add_handler('topic', \&irc_topic);
+ $conn->add_handler('topicinfo', \&irc_topic);
+ $conn->add_handler('nicknameinuse', \&on_errnickinuse);
+ $conn->add_handler('bannickchange', \&on_bannickchange);
+ $conn->add_handler('kick', \&on_kick);
+ $conn->add_handler('cping', \&on_ctcp);
+ $conn->add_handler('cversion', \&on_ctcp);
+ $conn->add_handler('csource', \&on_ctcp_source);
+ $conn->add_handler('ctime', \&on_ctcp);
+ $conn->add_handler('cdcc', \&on_ctcp);
+ $conn->add_handler('cuserinfo', \&on_ctcp);
+ $conn->add_handler('cclientinfo', \&on_ctcp);
+ $conn->add_handler('cfinger', \&on_ctcp);
+ $conn->add_handler('354', \&on_whoxreply);
+ $conn->add_handler('315', \&on_whoxover);
+ $conn->add_handler('263', \&on_whofuckedup);
+ $conn->add_handler('account', \&on_account);
+ $conn->add_handler('ping', \&on_ping);
+ $conn->add_handler('banlist', \&on_banlist);
+ $conn->add_handler('dcc_open', \&dcc_open);
+ $conn->add_handler('chat', \&on_dchat);
+ $conn->add_handler('channelmodeis', \&on_channelmodeis);
+ $conn->add_handler('quietlist', \&on_quietlist);
+ $conn->add_handler('pong', \&on_pong);
+ $conn->add_handler('statsdebug', \&on_statsdebug);
+ $conn->add_handler('endofstats', \&on_endofstats);
+ $conn->add_handler('channelurlis', \&on_channelurlis);
+ $conn->add_handler('480', \&on_jointhrottled);
+ $conn->add_handler('invite', \&blah); # This doesn't need to be fancy; I just need it to go through inspect
+ bless($self);
+ return $self;
+}
+
+my $clearstatsp = 1;
+my %statsp = ();
+my %oldstatsp = ();
+
+sub on_jointhrottled
+{
+ my ($conn, $event) = @_;
+ my $chan = $event->{args}->[1];
+ ASM::Util->dprint("$event->{nick}: $chan: $event->{args}->[2]", 'snotice');
+ if ($event->{args}->[2] =~ /throttle exceeded, try again later/) {
+ $conn->schedule(5, sub { $conn->join($chan); });
+ }
+}
+
+sub on_statsdebug
+{
+ my ($conn, $event) = @_;
+ my ($char, $line) = ($event->{args}->[1], $event->{args}->[2]);
+ if ($char eq 'p') {
+ if ($clearstatsp) {
+ $clearstatsp = 0;
+ %oldstatsp = %statsp;
+ %statsp = ();
+ }
+ if ($line =~ /^(\d+) staff members$/) {
+ #this is the end of the report
+ } else {
+ my ($nick, $userhost) = split(" ", $line);
+ $userhost =~ s/\((.*)\)/$1/;
+ my ($user, $host) = split("@", $userhost);
+ $statsp{$nick}= [$user, $host];
+ }
+ }
+}
+
+sub on_endofstats
+{
+ my ($conn, $event) = @_;
+ if ($event->{args}->[1] eq 'p') {
+ $clearstatsp=1;
+ my $tmp = Dumper(\%statsp); chomp $tmp;
+ if ( join(',', sort(keys %oldstatsp)) ne join(',', sort(keys %statsp)) ) {
+ open(FH, '>>', 'statsplog.txt');
+ say FH strftime('%F %T ', gmtime) . join(',', sort(keys %statsp));
+ close(FH);
+ ASM::Util->dprint(join(",", keys %statsp), 'statsp');
+ }
+ # $event->{args}->[2] == "End of /STATS report"
+ #end of /stats p
+ }
+}
+
+my $lagcycles = 0;
+my $pongcount = 0;
+
+sub on_pong
+{
+ my ($conn, $event) = @_;
+ alarm 120;
+ $conn->schedule( 30, sub { $conn->sl("PING :" . time); } );
+ ASM::Util->dprint('Pong? ... Ping!', 'pingpong');
+ my $lag = time - $event->{args}->[0];
+ my @changes = $::fm->scan();
+ if (@changes) {
+ if ($::settingschanged) {
+ $::settingschanged = 0;
+ } else {
+ $conn->privmsg($::settings->{masterchan}, "Config files changed, auto rehash triggered. Check console for possible errors.");
+ ASM::XML->readXML();
+ my @strbl = io('string_blacklist.txt')->getlines;
+ chomp @strbl;
+ @::string_blacklist = @strbl;
+ }
+ }
+ if ($lag > 1) {
+ ASM::Util->dprint("Latency: $lag", 'latency');
+ }
+ if (($pongcount % 3) == 0) { #easiest way to do something roughly every 90 seconds
+ $conn->sl('STATS p');
+ }
+ if ((time - $::starttime) < 240 ) {
+ return; #we don't worry about lag if we've just started up and are still syncing etc.
+ }
+ if (($lag > 2) && ($lag < 5)) {
+ $conn->privmsg( $::settings->{masterchan}, "Warning: I'm currently lagging by $lag seconds.");
+ }
+ if ($lag >= 5) {
+ $lagcycles++;
+ if ($lagcycles >= 3) {
+ $conn->quit("Automatic restart triggered due to persistent lag. Freenode staff: If this is happening too frequently, please " .
+ "set a nickserv freeze on my account, and once my connection is stable, unfreeze the account and /kill me to tri" .
+ "gger a reconnect.");
+ } else {
+ $conn->privmsg( $::settings->{masterchan}, "Warning: I'm currently lagging by $lag seconds. This marks heavy lag cycle " .
+ "$lagcycles - automatic restart will be triggered after 3 lag cycles." );
+ }
+ }
+ if (($lag <= 5) && ($lagcycles > 0)) {
+ $lagcycles--;
+# $conn->privmsg( $::settings->{masterchan}, "Warning: Heavy lag cycle count has been reduced to $lagcycles" );
+ ASM::Util->dprint('$lag = ' . $lag . '; $lagcycles = ' . $lagcycles, 'latency');
+ }
+}
+
+sub on_dchat
+{
+ my ($conn, $event) = @_;
+ ASM::Util->dprint(Dumper($event), 'dcc');
+ if ( #(lc $event->{nick} eq 'afterdeath') &&
+ ($event->{args}->[0] ne '')) {
+ my $msg = $event->{args}->[0];
+ if ($msg =~ /^SPY (.*)/) {
+ my $chan = $1;
+ $::spy{lc $chan} = $event->{to}[0];
+ } elsif ($msg =~ /^STOPSPY (.*)/) {
+ delete $::spy{lc $1};
+ } elsif ($msg =~ /^RETRIEVE (\S+)/) {
+ my $chan = lc $1;
+ my $out = $event->{to}[0];
+ my @time = ($::settings->{log}->{zone} eq 'local') ? localtime : gmtime;
+ say $out 'Retrieving ' . "$::settings->{log}->{dir}${chan}/${chan}" . strftime($::settings->{log}->{filefmt}, @time);
+ open(FHX, "$::settings->{log}->{dir}${chan}/${chan}" . strftime($::settings->{log}->{filefmt}, @time));
+ while (<FHX>) {
+ print $out $_;
+ }
+ close FHX;
+ }
+ #lols we gots a chat message! :D
+ }
+}
+
+sub on_ping
+{
+ my ($conn, $event) = @_;
+ $conn->sl("PONG " . $event->{args}->[0]);
+# alarm 200;
+ ASM::Util->dprint('Ping? Pong!', 'pingpong');
+# ASM::Util->dprint(Dumper($event), 'pingpong');
+}
+
+sub on_account
+{
+ my ($conn, $event) = @_;
+ $::sn{lc $event->{nick}}{account} = lc $event->{args}->[0];
+}
+
+sub on_connect {
+ my ($conn, $event) = @_; # need to check for no services
+ $conn->sl("MODE $event->{args}->[0] +Q");
+ if (lc $event->{args}->[0] ne lc $::settings->{nick}) {
+ ASM::Util->dprint('Attempting to regain my main nick', 'startup');
+ $conn->privmsg( 'NickServ@services.', "regain $::settings->{nick} $::settings->{pass}" );
+ }
+ $conn->sl('CAP REQ :extended-join multi-prefix account-notify'); #god help you if you try to use this bot off freenode
+}
+
+sub on_join {
+ my ($conn, $event) = @_;
+ my $nick = lc $event->{nick};
+ my $chan = lc $event->{to}->[0];
+ my $rate;
+# alarm 200;
+ if ( lc $conn->{_nick} eq lc $nick) {
+ $::sc{$chan} = {};
+ mkdir($::settings->{log}->{dir} . $chan);
+ $::synced{$chan} = 0;
+ unless ( @::syncqueue ) {
+ $conn->sl('who ' . $chan . ' %tcnuhra,314');
+ $conn->sl('mode ' . $chan);
+ $conn->sl('mode ' . $chan . ' bq');
+ }
+ push @::syncqueue, $chan;
+ }
+ $::sc{$chan}{users}{$nick} = {};
+ $::sc{$chan}{users}{$nick}{hostmask} = $event->{userhost};
+ $::sc{$chan}{users}{$nick}{op} = 0;
+ $::sc{$chan}{users}{$nick}{voice} = 0;
+ $::sc{$chan}{users}{$nick}{jointime} = time;
+ $::sc{$chan}{users}{$nick}{msgtime} = 0;
+ if (defined($::sn{$nick})) {
+ my @mship = ();
+ if (defined($::sn{$nick}->{mship})) {
+ @mship = @{$::sn{$nick}->{mship}};
+ }
+ @mship = (@mship, $chan);
+ $::sn{$nick}->{mship} = \@mship;
+ } else {
+ $::sn{$nick} = {};
+ $::sn{$nick}->{mship} = [ $chan ];
+ }
+ $::sn{$nick}->{dnsbl} = 0;
+ $::sn{$nick}->{netsplit} = 0;
+ $::sn{$nick}->{gecos} = $event->{args}->[1];
+ $::sn{$nick}->{user} = $event->{user};
+ $::sn{$nick}->{host} = $event->{host};
+ $::sn{$nick}->{account} = lc $event->{args}->[0];
+ $::db->logg($event) if defined $::db;
+ $::log->logg( $event );
+ $::inspector->inspect( $conn, $event ) unless $::netsplit;
+}
+
+sub on_part
+{
+ my ($conn, $event) = @_;
+ my $nick = lc $event->{nick};
+ my $chan = lc $event->{to}->[0];
+ $::log->logg( $event );
+ $::db->logg( $event ) if defined $::db;
+ if (defined $::db and $event->{args}->[0] =~ /^requested by/) {
+ my $idx = $::db->actionlog( $event);
+ $::log->sqlIncident($chan, $idx) if $idx;
+ }
+# "to" => [ "#antispammeta" ],
+# "args" => [ "requested by ow (test)" ],
+# "nick" => "aoregcdu",
+ $::inspector->inspect( $conn, $event );
+ if (defined($::sn{$nick}) && defined($::sn{$nick}->{mship})) {
+ my @mship = @{$::sn{$nick}->{mship}};
+ @mship = grep { lc $_ ne $chan } @mship;
+ if ( @mship ) {
+ $::sn{$nick}->{mship} = \@mship;
+ } else {
+ delete($::sn{$nick});
+ }
+ }
+ if ( lc $conn->{_nick} eq $nick )
+ {
+ delete( $::sc{$chan} );
+ on_byechan($chan);
+ }
+ else
+ {
+ delete( $::sc{$chan}{users}{$nick} );
+ }
+}
+
+sub on_msg
+{
+ my ($conn, $event) = @_;
+ $::commander->command($conn, $event);
+ ASM::Util->dprint($event->{from} . " - " . $event->{args}->[0], 'msg');
+ if ((ASM::Util->notRestricted($event->{nick}, "nomsgs")) && ($event->{args}->[0] !~ /^;;/)) {
+# disabled by DL 130513 due to spammer abuse
+# $conn->privmsg($::settings->{masterchan}, $event->{from} . ' told me: ' . $event->{args}->[0]);
+ }
+}
+
+sub on_public
+{
+ my ($conn, $event) = @_;
+# alarm 200;
+ my $chan = lc $event->{to}[0];
+ $chan =~ s/^[+@]//;
+ $::log->logg( $event );
+ $::db->logg( $event ) if defined $::db;
+ if ($event->{args}->[0] =~ /(https?:\/\/bitly.com\/\w+|https?:\/\/bit.ly\/\w+|https?:\/\/j.mp\/\w+|https?:\/\/tinyurl.com\/\w+)/i) {
+ my $reqid = $::async->add( HTTP::Request->new( GET => $1 ) );
+ $::httpRequests{$reqid} = $event;
+ my ($response, $id) = $::async->wait_for_next_response( 1 );
+ if (defined($response)) {
+ on_httpResponse($conn, $id, $response);
+ }
+ else { $conn->schedule( 1, sub { checkHTTP($conn); } ); }
+ }
+ $::inspector->inspect( $conn, $event );
+ $::commander->command( $conn, $event );
+ $::sc{$chan}{users}{lc $event->{nick}}{msgtime} = time;
+}
+
+sub checkHTTP
+{
+ my ($conn) = @_;
+ my ($response, $id) = $::async->next_response();
+ if (defined ($response)) {
+ on_httpResponse($conn, $id, $response);
+ }
+ $conn->schedule( 1, sub { checkHTTP($conn); } );
+}
+
+sub on_httpResponse
+{
+ my ($conn, $id, $response) = @_;
+ my $event = $::httpRequests{$id};
+ delete $::httpRequests{$id};
+ $::inspector->inspect( $conn, $event, $response );
+}
+# if ($response->{_previous}->{_headers}->{location} =~ /^https?:\/\/bitly.com\/a\/warning/)
+
+sub on_notice
+{
+ my ($conn, $event) = @_;
+ return if ( $event->{to}->[0] eq '$*' ); # if this is a global notice FUCK THAT SHIT
+ $::log->logg( $event );
+ $::db->logg( $event ) if defined $::db;
+ $::inspector->inspect( $conn, $event );
+ $::services->doServices($conn, $event);
+}
+
+sub on_errnickinuse
+{
+ my ($conn, $event) = @_;
+ $_ = ${$::settings->{altnicks}}[rand @{$::settings->{altnicks}}];
+ ASM::Util->dprint("Nick is in use, trying $_", 'startup');
+ $conn->nick($_);
+}
+
+sub on_bannickchange
+{
+ my ($conn, $event) = @_;
+ $_ = ${$::settings->{altnicks}}[rand @{$::settings->{altnicks}}];
+ ASM::Util->dprint("Nick is in use, trying $_", 'startup');
+ $conn->nick($_);
+}
+
+sub on_quit
+{
+ my ($conn, $event) = @_;
+ my @channels=();
+ for ( keys %::sc ) {
+ push ( @channels, lc $_ ) if delete $::sc{lc $_}{users}{lc $event->{nick}};
+ }
+ $event->{to} = \@channels;
+ if (defined $::db) {
+ my $idx = $::db->actionlog($event);
+ $::log->sqlIncident( join(',', @channels), $idx ) if $idx;
+ $::db->logg( $event );
+ }
+ $::log->logg( $event );
+
+ if (($::netsplit == 0) && ($event->{args}->[0] eq "*.net *.split") && (lc $event->{nick} ne 'chanserv')) { #special, netsplit situation
+ $conn->privmsg($::settings->{masterchan}, "Entering netsplit mode - JOIN and QUIT inspection will be disabled for 60 minutes");
+ $::netsplit = 1;
+ $conn->schedule(60*60, sub { $::netsplit = 0; $conn->privmsg($::settings->{masterchan}, 'Returning to regular operation'); });
+ }
+ $::inspector->inspect( $conn, $event ) unless $::netsplit;
+ #ugh. Repurge some shit, hopefully this will fix some stuff where things are going wrong
+ foreach my $chan ( keys %::sc ) {
+ delete $::sc{$chan}{users}{lc $event->{nick}};
+ }
+ delete($::sn{lc $event->{nick}});
+}
+
+sub blah
+{
+ my ($self, $event) = @_;
+ ASM::Util->dprint(Dumper($event), 'misc');
+ $::inspector->inspect($self, $event);
+}
+
+sub irc_users
+{
+ my ( $channel, @users ) = @_;
+ for (@users)
+ {
+ my ( $op, $voice );
+ $op = 0; $voice = 0;
+ $op = 1 if s/^\@//;
+ $voice = 1 if s/^\+//;
+ $::sc{lc $channel}{users}{lc $_} = {};
+ $::sc{lc $channel}{users}{lc $_}{op} = $op;
+ $::sc{lc $channel}{users}{lc $_}{voice} = $voice;
+ $::sc{lc $channel}{users}{lc $_}{jointime} = 0;
+ }
+}
+
+sub on_names {
+ my ($conn, $event) = @_;
+ irc_users( $event->{args}->[2], split(/ /, $event->{args}->[3]) ) if ($event->{type} eq 'namreply');
+}
+
+sub irc_topic {
+ my ($conn, $event) = @_;
+ if ($event->{format} eq 'server')
+ {
+ my $chan = lc $event->{args}->[1];
+ if ($event->{type} eq 'topic')
+ {
+ $::sc{$chan}{topic}{text} = $event->{args}->[2];
+ }
+ elsif ($event->{type} eq 'topicinfo')
+ {
+ $::sc{$chan}{topic}{time} = $event->{args}->[3];
+ $::sc{$chan}{topic}{by} = $event->{args}->[2];
+ }
+ }
+ else
+ {
+ if ($event->{type} eq 'topic')
+ {
+ my $chan = lc $event->{to}->[0];
+ $::sc{$chan}{topic}{text} = $event->{args}->[0];
+ $::sc{$chan}{topic}{time} = time;
+ $::sc{$chan}{topic}{by} = $event->{from};
+ }
+ $::log->logg($event);
+ $::db->logg( $event ) if defined $::db;
+ $::inspector->inspect($conn, $event);
+ }
+}
+
+sub on_nick {
+ my ($conn, $event) = @_;
+ my @channels=();
+ my $oldnick = lc $event->{nick};
+ my $newnick = lc $event->{args}->[0];
+ foreach my $chan ( keys %::sc )
+ {
+ $chan = lc $chan;
+ if ( defined $::sc{$chan}{users}{$oldnick} )
+ {
+ if ($oldnick ne $newnick) { #otherwise a nick change where they're only
+ #changing the case of their nick means that
+ #ASM forgets about them.
+ $::sc{$chan}{users}{$newnick} = $::sc{$chan}{users}{$oldnick};
+ delete( $::sc{$chan}{users}{$oldnick} );
+ }
+ push ( @channels, $chan );
+ }
+ }
+
+ # unfortunately Net::IRC sucks at IRC so we have to implement this ourselves
+ if ($oldnick eq lc $conn->{_nick}) {
+ $conn->{_nick} = $event->{args}[0];
+ }
+
+ $::sn{$newnick} = $::sn{$oldnick} if ($oldnick ne $newnick);
+ $::db->logg( $event ) if defined $::db;
+ delete( $::sn{$oldnick}) if ($oldnick ne $newnick);
+ $event->{to} = \@channels;
+ $::log->logg($event);
+ # Well, the nick change actually was done from the old nick ... but
+ # by the time we process it, they already changed nicks. Therefore
+ # we'll pretend it's the *new* nick that generated the event.
+ $event->{nick} = $event->{args}[0];
+ $::inspector->inspect($conn, $event);
+}
+
+sub on_kick {
+ my ($conn, $event) = @_;
+ if (lc $event->{to}->[0] eq lc $::settings->{nick}) {
+ $conn->privmsg($::settings->{masterchan}, "I've been kicked from " . $event->{args}->[0] . ": " . $event->{args}->[1]);
+# $conn->join($event->{args}->[0]);
+ }
+ my $nick = lc $event->{to}->[0];
+ my $chan = lc $event->{args}->[0];
+ $::log->logg( $event );
+ if (defined $::db) {
+ $::db->logg( $event );
+ my $idx = $::db->actionlog($event);
+ $::log->sqlIncident($chan, $idx) if $idx;
+ }
+ if (defined($::sn{$nick}) && defined($::sn{$nick}->{mship})) {
+ my @mship = @{$::sn{$nick}->{mship}};
+ @mship = grep { lc $_ ne $chan } @mship;
+ if ( @mship ) {
+ $::sn{$nick}->{mship} = \@mship;
+ } else {
+ delete($::sn{$nick});
+ }
+ }
+ if ( lc $conn->{_nick} eq $nick )
+ {
+ delete( $::sc{lc $event->{args}->[0]} );
+ on_byechan(lc $event->{to}->[0]);
+ }
+ else
+ {
+ delete( $::sc{lc $event->{args}->[0]}{users}{$nick} );
+ }
+}
+
+sub parse_modes
+{
+ my ( $n ) = @_;
+ my @args = @{$n};
+ my @modes = split '', shift @args;
+ my @new_modes=();
+ my $t;
+ foreach my $c ( @modes ) {
+ if (($c eq '-') || ($c eq '+')) {
+ $t=$c;
+ }
+ else { #eIbq,k,flj,CFLMPQcgimnprstz
+ if ($t eq '+') {
+ if ( grep( /[eIbqkfljov]/,($c) ) ) { #modes that take args WHEN BEING ADDED
+ push (@new_modes, [$t.$c, shift @args]);
+ }
+ elsif ( grep( /[CFLMPQcgimnprstz]/, ($c) ) ) {
+ push (@new_modes, [$t.$c]);
+ }
+ else {
+ die "Unknown mode $c !\n";
+ }
+ } else {
+ if ( grep( /[eIbqov]/,($c) ) ) { #modes that take args WHEN BEING REMOVED
+ push (@new_modes, [$t.$c, shift @args]);
+ }
+ elsif ( grep( /[CFLMPQcgimnprstzkflj]/, ($c) ) ) {
+ push (@new_modes, [$t.$c]);
+ }
+ else {
+ die "Unknown mode $c !\n";
+ }
+ }
+ }
+ }
+ return \@new_modes;
+}
+
+sub on_channelmodeis
+{
+ my ($conn, $event) = @_;
+ my $chan = lc $event->{args}->[1];
+ my @temp = @{$event->{args}};
+ shift @temp; shift @temp;
+ my @modes = @{parse_modes(\@temp)};
+ foreach my $line ( @modes ) {
+ my @ex = @{$line};
+ my ($what, $mode) = split (//, $ex[0]);
+ if ($what eq '+') {
+ if (defined($ex[1])) {
+ push @{$::sc{$chan}{modes}}, $mode . ' ' . $ex[1];
+ } else {
+ push @{$::sc{$chan}{modes}}, $mode;
+ }
+ } else {
+ my @modes = grep {!/^$mode/} @{$::sc{$chan}{modes}};
+ $::sc{$chan}{modes} = \@modes;
+ }
+ }
+}
+
+sub whoGotHit
+{
+ my ($chan, $mask) = @_;
+ my $cvt = Regexp::Wildcards->new(type => 'jokers');
+ my @affected = ();
+ if ($mask !~ /^\$/) {
+ my @div = split(/\$/, $mask);
+ my $regex = $cvt->convert($div[0]);
+ foreach my $nick (keys %::sn) {
+ next unless defined($::sn{$nick}{user});
+ if (lc ($nick.'!'.$::sn{$nick}{user}.'@'.$::sn{$nick}{host}) =~ /^$regex$/i) {
+ push @affected, $nick if defined($::sc{$chan}{users}{$nick});
+ }
+ }
+ } elsif ($mask =~ /^\$a:(.*)/) {
+ my @div = split(/\$/, $1);
+ my $regex = $cvt->convert($div[0]);
+ foreach my $nick (keys %::sn) {
+ next unless defined($::sn{$nick}{account});
+ if (lc ($::sn{$nick}{account}) =~ /^$regex$/i) {
+ push @affected, $nick if defined($::sc{$chan}{users}{$nick});
+ }
+ }
+ }
+ return @affected;
+}
+
+sub on_mode
+{
+ my ($conn, $event) = @_;
+ my $chan = lc $event->{to}->[0];
+# holy shit, I feel so bad doing this
+# I have no idea how or why Net::IRC fucks up modes if they've got a ':' in one of the args
+# but you do what you must...
+ my @splitted = split(/ /, $::lastline); shift @splitted; shift @splitted; shift @splitted;
+ $event->{args}=\@splitted;
+ if ($chan =~ /^#/) {
+ my @modes = @{parse_modes($event->{args})};
+ ASM::Util->dprint(Dumper(\@modes), 'misc');
+ foreach my $line ( @modes ) {
+ my @ex = @{$line};
+
+ if ( $ex[0] eq '+o' ) { $::sc{$chan}{users}{lc $ex[1]}{op} = 1; }
+ elsif ( $ex[0] eq '-o' ) { $::sc{$chan}{users}{lc $ex[1]}{op} = 0; }
+ elsif ( $ex[0] eq '+v' ) { $::sc{$chan}{users}{lc $ex[1]}{voice} = 1; }
+ elsif ( $ex[0] eq '-v' ) { $::sc{$chan}{users}{lc $ex[1]}{voice} = 0; }
+
+ elsif ( $ex[0] eq '+b' ) {
+ $::sc{$chan}{bans}{$ex[1]} = { bannedBy => $event->{from}, bannedOn => time };
+ if (lc $event->{nick} !~ /^(floodbot)/) { #ignore the ubuntu floodbots 'cause they quiet people a lot
+ my @affected = whoGotHit($chan, $ex[1]);
+ if ( defined($::db) && (@affected) && (scalar @affected <= 4) ) {
+ foreach my $victim (@affected) {
+ my $idx = $::db->actionlog($event, 'ban', $victim);
+ $::log->sqlIncident( $chan, $idx ) if $idx;
+ }
+ }
+ if ($ex[1] =~ /^\*\!\*\@(.*)$/) {
+ my $ip = ASM::Util->getHostIP($1);
+ $::sc{$chan}{ipbans}{$ip} = { bannedBy => $event->{from}, bannedOn => time } if defined($ip);
+ }
+ }
+ }
+ elsif ( $ex[0] eq '-b' ) {
+ delete $::sc{$chan}{bans}{$ex[1]};
+ if ($ex[1] =~ /^\*\!\*\@(.*)$/) {
+ my $ip = ASM::Util->getHostIP($1);
+ delete $::sc{$chan}{ipbans}{$ip} if defined($ip);
+ }
+ }
+
+ elsif ( $ex[0] eq '+q' ) {
+ $::sc{$chan}{quiets}{$ex[1]} = { bannedBy => $event->{from}, bannedOn => time };
+ if (lc $event->{nick} !~ /^(floodbot)/) {
+ my @affected = whoGotHit($chan, $ex[1]);
+ if ( defined($::db) && (@affected) && (scalar @affected <= 4) ) {
+ foreach my $victim (@affected) {
+ my $idx = $::db->actionlog($event, 'quiet', $victim);
+ $::log->sqlIncident( $chan, $idx ) if $idx;
+ }
+ }
+ if ($ex[1] =~ /^\*\!\*\@(.*)$/) {
+ my $ip = ASM::Util->getHostIP($1);
+ $::sc{$chan}{ipquiets}{$ip} = { bannedBy => $event->{from}, bannedOn => time } if defined($ip);
+ }
+ }
+ }
+ elsif ( $ex[0] eq '-q' ) {
+ delete $::sc{$chan}{quiets}{$ex[1]};
+ if ($ex[1] =~ /^\*\!\*\@(.*)$/) {
+ my $ip = ASM::Util->getHostIP($1);
+ delete $::sc{$chan}{ipquiets}{$ip} if defined($ip);
+ }
+ }
+
+ else {
+ my ($what, $mode) = split (//, $ex[0]);
+ if ($what eq '+') {
+ if (defined($ex[1])) { push @{$::sc{$chan}{modes}}, $mode . ' ' . $ex[1]; }
+ else { push @{$::sc{$chan}{modes}}, $mode; }
+ } else {
+ my @modes = grep {!/^$mode/} @{$::sc{$chan}{modes}};
+ $::sc{$chan}{modes} = \@modes;
+ }
+ if ( ($ex[0] eq '+r') && (! defined($::watchRegged{$chan})) ) {
+ $::watchRegged{$chan} = 1;
+ $conn->schedule(60*45, sub { checkRegged($conn, $chan); });
+ }
+ }
+ }
+ $::log->logg($event);
+ }
+}
+
+sub checkRegged
+{
+ my ($conn, $chan) = @_;
+ if (grep {/^r/} @{$::sc{$chan}{modes}}
+ and not ((defined($::channels->{channel}{$chan}{monitor})) and ($::channels->{channel}{$chan}{monitor} eq "no")) )
+ {
+ my $tgt = $chan;
+ my $risk = "debug";
+ my $hilite=ASM::Util->commaAndify(ASM::Util->getAlert($tgt, $risk, 'hilights'));
+ my $txtz ="\x03" . $::RCOLOR{$::RISKS{$risk}} . "\u$risk\x03 risk threat [\x02$chan\x02] - channel appears to still be +r after 45 minutes; ping $hilite !att-$chan-$risk";
+ my @tgts = ASM::Util->getAlert($tgt, $risk, 'msgs');
+ ASM::Util->sendLongMsg($conn, \@tgts, $txtz)
+ }
+ delete $::watchRegged{$chan};
+}
+
+sub on_banlist
+{
+ my ($conn, $event) = @_;
+ my ($me, $chan, $ban, $banner, $bantime) = @{$event->{args}};
+ $::sc{lc $chan}{bans}{$ban} = { bannedBy => $banner, bannedOn => $bantime };
+ if ($ban =~ /^\*\!\*\@((([a-zA-Z0-9]|[a-zA-Z0-9][a-zA-Z0-9\-]*[a-zA-Z0-9])\.)*([A-Za-z0-9]|[A-Za-z0-9][A-Za-z0-9\-]*[A-Za-z0-9]))$/) {
+ # ASM::Util->dprint("banlist hostname $ban $1", 'sync');
+ my $ip = ASM::Util->getHostIP($1);
+ $::sc{lc $chan}{ipbans}{$ip} = { bannedBy => $banner, bannedOn => $bantime } if defined($ip);
+ }
+}
+
+sub on_quietlist
+{
+ my ($conn, $event) = @_;
+ my ($me, $chan, $mode, $ban, $banner, $bantime) = @{$event->{args}};
+ $::sc{lc $chan}{quiets}{$ban} = { bannedBy => $banner, bannedOn => $bantime };
+ if ($ban =~ /^\*\!\*\@((([a-zA-Z0-9]|[a-zA-Z0-9][a-zA-Z0-9\-]*[a-zA-Z0-9])\.)*([A-Za-z0-9]|[A-Za-z0-9][A-Za-z0-9\-]*[A-Za-z0-9]))$/) {
+ # ASM::Util->dprint("quietlist hostname $ban $1", 'sync');
+ my $ip = ASM::Util->getHostIP($1);
+ $::sc{lc $chan}{ipquiets}{$ip} = { bannedBy => $banner, bannedOn => $bantime } if defined($ip);
+ }
+}
+
+sub on_channelurlis
+{
+ my ($conn, $event) = @_;
+ $::sc{lc $event->{args}->[1]}{url} = $event->{args}->[2];
+}
+
+sub on_ctcp
+{
+ my ($conn, $event) = @_;
+ my $acct = lc $::sn{lc $event->{nick}}->{account};
+ ASM::Util->dprint(Dumper($event), 'ctcp');
+ if (($event->{type} eq 'cdcc') &&
+ (defined($::users->{person}->{$acct})) &&
+ (defined($::users->{person}->{$acct}->{flags})) &&
+ (grep {$_ eq 'c'} split('', $::users->{person}->{$acct}->{flags}))) {
+ ASM::Util->dprint(Dumper($event), 'dcc');
+ my @spit = split(/ /, $event->{args}->[0]);
+ if (($spit[0] eq 'CHAT') && ($spit[1] eq 'CHAT')) {
+ $::chat = Net::IRC::DCC::CHAT->new($conn, 0, lc $event->{nick}, $spit[2], $spit[3]);
+ }
+ } else {
+ $::inspector->inspect($conn, $event);
+ }
+}
+
+sub dcc_open
+{
+ my ($conn, $event) = @_;
+ $::dsock{lc $event->{nick}} = $event->{args}->[1];
+}
+
+sub on_ctcp_source
+{
+ my ($conn, $event) = @_;
+ $conn->ctcp_reply($event->{nick}, 'SOURCE https://gitlab.devlabs.linuxassist.net/asm/antispammeta/');
+}
+
+sub on_whoxreply
+{
+ my ($conn, $event) = @_;
+ return unless $event->{args}->[1] eq '314';
+ my ($tgt, $magic, $chan, $user, $host, $nick, $account, $gecos) = @{$event->{args}};
+ $nick = lc $nick; $chan = lc $chan;
+ if (!defined $::sn{lc $nick}) {
+ $::sn{$nick} = {};
+ $::sn{$nick}->{mship} = [$chan];
+ } else {
+ $::sn{$nick}->{mship} = [grep { lc $_ ne $chan } @{$::sn{$nick}->{mship}}];
+ push @{$::sn{$nick}->{mship}}, $chan;
+ }
+ $::sn{$nick}->{gecos} = $gecos;
+ $::sn{$nick}->{user} = $user;
+ $::sn{$nick}->{host} = $host;
+ $::sn{$nick}->{account} = lc $account;
+}
+
+sub on_whoxover
+{
+ my ($conn, $event) = @_;
+ my $chan = pop @::syncqueue;
+ $::synced{lc $event->{args}->[1]} = 1;
+ if (defined($chan) ){
+ $conn->sl('who ' . $chan . ' %tcnuhra,314');
+ $conn->sl('mode ' . $chan);
+ $conn->sl('mode ' . $chan . ' bq');
+ } else {
+ my $size = `ps -p $$ h -o size`;
+ my $cputime = `ps -p $$ h -o time`;
+ chomp $size; chomp $cputime;
+ my ($tx, $rx);
+ if ($conn->{_tx}/1024 > 1024) {
+ $tx = sprintf("%.2fMB", $conn->{_tx}/(1024*1024));
+ } else {
+ $tx = sprintf("%.2fKB", $conn->{_tx}/1024);
+ }
+ if ($conn->{_rx}/1024 > 1024) {
+ $rx = sprintf("%.2fMB", $conn->{_rx}/(1024*1024));
+ } else {
+ $rx = sprintf("%.2fKB", $conn->{_rx}/1024);
+ }
+ $conn->privmsg($::settings->{masterchan}, "Finished syncing after " . (time - $::starttime) . " seconds. " .
+ "I'm tracking " . (scalar (keys %::sn)) . " nicks" .
+ " across " . (scalar (keys %::sc)) . " tracked channels." .
+ " I'm using " . $size . "KB of RAM" .
+ ", have used " . $cputime . " of CPU time" .
+ ", have sent $tx of data, and received $rx of data.");
+ my %x = ();
+ foreach my $c (@{$::settings->{autojoins}}) { $x{$c} = 1; }
+ foreach my $cx (keys %::sc) { delete $x{$cx}; }
+ if (scalar (keys %x)) {
+ $conn->privmsg($::settings->{masterchan}, "Syncing appears to have failed for " . ASM::Util->commaAndify(keys %x));
+ }
+ }
+}
+
+sub on_whofuckedup
+{
+ my ($conn, $event) = @_;
+ ASM::Util->dprint('on_whofuckedup called!', 'sync');
+ if ($event->{args}->[1] eq "STATS") {
+#most likely this is getting called because we did stats p too often.
+#unfortunately the server doesn't let us know what exactly we called stats for.
+#anyways, we don't need to do anything for this
+ } else { #dunno why it got called, print the data and I'll add a handler for it.
+ ASM::Util->dprint(Dumper($event), 'sync');
+ }
+}
+
+sub on_bannedfromchan {
+ my ($conn, $event) = @_;
+ ASM::Util->dprint("I'm banned from " . $event->{args}->[1] . "... attempting to unban myself", 'startup');
+ $conn->privmsg('ChanServ', "unban $event->{args}->[1]");
+}
+
+sub on_byechan {
+ my ($chan) = @_;
+ #TODO do del event stuff
+}
+
+return 1;
diff --git a/lib/ASM/Inspect.pm b/lib/ASM/Inspect.pm
new file mode 100644
index 0000000..df515dc
--- /dev/null
+++ b/lib/ASM/Inspect.pm
@@ -0,0 +1,101 @@
+package ASM::Inspect;
+use warnings;
+use strict;
+use feature qw(say);
+
+use Data::Dumper;
+#use List::Util qw(first);
+use String::Interpolate qw(interpolate);
+use Carp qw(cluck);
+
+%::ignored = ();
+sub new
+{
+ my $module = shift;
+ my $self = {};
+ bless($self);
+ return $self;
+}
+
+sub inspect {
+ our ($self, $conn, $event, $response) = @_;
+ my (%aonx, %dct, $rev, $chan, $id);
+ %aonx=(); %dct=(); $chan=""; $id="";
+ my (@dnsbl, @uniq);
+ my ($match, $txtz, $iaddr);
+ my @override = [];
+ my $nick = lc $event->{nick};
+ my $xresult;
+ return if (index($nick, ".") != -1);
+ if ( $event->{host} =~ /gateway\/web\// ) {
+ if ( $event->{user} =~ /([0-9a-f]{2})([0-9a-f]{2})([0-9a-f]{2})([0-9a-f]{2})/ ) {
+ $rev = sprintf("%d.%d.%d.%d.", hex($4), hex($3), hex($2), hex($1));
+ }
+ }
+ if ( (!defined($rev)) && ($event->{type} eq 'join') ) {
+# Only doing DNS lookups for join events will mean that DNSBL will break if we try to do it on something other than joins,
+# But it also means we cut back on the DNS lookups by a metric shitton
+ $iaddr = gethostbyname($event->{host}) if ($event->{host} !~ /\//);
+ $rev = join('.', reverse(unpack('C4', $iaddr))).'.' if (defined $iaddr);
+ }
+ ## NB: isn't there a better way to do this with grep, somehow?
+ %aonx = %{$::rules->{event}};
+ foreach $chan ( @{$event->{to}} ) {
+ # don't do anything for channels we haven't synced yet
+ # because we can't yet respect stuff like notrigger for these
+ next unless $::synced{lc $chan};
+ next unless $chan =~ /^#/;
+ next if ((defined($::channels->{channel}->{$chan}->{monitor})) and ($::channels->{channel}->{$chan}->{monitor} eq "no"));
+ foreach $id (keys %aonx) {
+ next unless ( grep { $event->{type} eq $_ } split(/[,:; ]+/, $aonx{$id}{type}) );
+ if (defined($response)) {
+ if ($aonx{$id}{class} ne 'urlcrunch') { next; } #don't run our regular checks if this is being called from a URL checking function
+ else { $xresult = $::classes->check($aonx{$id}{class}, $aonx{$id}, $id, $event, $chan, $response); }
+ }
+ else {
+ $xresult = $::classes->check($aonx{$id}{class}, $aonx{$id}, $id, $event, $chan, $rev); # this is another bad hack done for dnsbl-related stuff
+ }
+ next unless (defined($xresult)) && ($xresult ne 0);
+ ASM::Util->dprint(Dumper($xresult), 'inspector');
+ $dct{$id} = $aonx{$id};
+ $dct{$id}{xresult} = $xresult;
+ }
+ }
+ foreach ( keys %dct ) {
+ if ( defined $dct{$_}{override} ) {
+ push( @override, split( /[ ,;]+/, $dct{$_}{override} ) );
+ }
+ }
+ delete $dct{$_} foreach @override;
+ my $evcontent = $event->{args}->[0];
+ my $evhost = $event->{host};
+ foreach $chan (@{$event->{to}}) {
+ foreach $id ( keys %dct ) {
+ return unless (ASM::Util->notRestricted($nick, "notrigger") && ASM::Util->notRestricted($nick, "no$id"));
+ $xresult = $dct{$id}{xresult};
+ my $nicereason = interpolate($dct{$id}{reason});
+ if (defined $::db) {
+ $::db->record($chan, $event->{nick}, $event->{user}, $event->{host}, $::sn{lc $event->{nick}}->{gecos}, $dct{$id}{risk}, $id, $nicereason);
+ }
+ $txtz = "\x03" . $::RCOLOR{$::RISKS{$dct{$id}{risk}}} . "\u$dct{$id}{risk}\x03 risk threat [\x02$chan\x02] - ".
+ "\x02$event->{nick}\x02 - ${nicereason}; ping ";
+ $txtz = $txtz . ASM::Util->commaAndify(ASM::Util->getAlert(lc $chan, $dct{$id}{risk}, 'hilights')) if (ASM::Util->getAlert(lc $chan, $dct{$id}{risk}, 'hilights'));
+ $txtz = $txtz . ' !att-' . $chan . '-' . $dct{$id}{risk};
+ if ($id eq 'last_measure_regex') { #TODO: Note that this is another example of things that shouldn't be hardcoded, but are.
+
+ }
+ if (
+ (!(defined($::ignored{$chan}) && ($::ignored{$chan} >= $::RISKS{$dct{$id}{risk}}))) ||
+ (($::pacealerts == 0) && ($dct{$id}{risk} eq 'info'))
+ ) {
+ my @tgts = ASM::Util->getAlert($chan, $dct{$id}{risk}, 'msgs');
+ ASM::Util->sendLongMsg($conn, \@tgts, $txtz);
+ $conn->schedule(45, sub { delete($::ignored{$chan}) if $::ignored{$chan} == $::RISKS{$dct{$id}{risk}} });
+ $::ignored{$chan} = $::RISKS{$dct{$id}{risk}};
+ }
+ $::log->incident($chan, "$chan: $dct{$id}{risk} risk: $event->{nick} - $nicereason\n");
+ }
+ }
+}
+
+1;
diff --git a/lib/ASM/Log.pm b/lib/ASM/Log.pm
new file mode 100644
index 0000000..c2a2b72
--- /dev/null
+++ b/lib/ASM/Log.pm
@@ -0,0 +1,112 @@
+package ASM::Log;
+
+use warnings;
+use strict;
+
+#use IO::All;
+use POSIX qw(strftime);
+
+sub new
+{
+ my $module = shift;
+ my $config = shift;
+ my $self = {};
+ $self->{CONFIG} = $config;
+ $self->{backlog} = {};
+ bless($self);
+ return $self;
+}
+
+sub incident
+{
+ my $self = shift;
+ my ($chan, $header) = @_;
+ $chan = lc $chan;
+ open(FH, '>>', 'dctlog.txt');
+ print FH $header;
+ if (defined($self->{backlog}->{$chan})) {
+ print FH join('', @{$self->{backlog}->{$chan}});
+ }
+ print FH "\n\n";
+ close(FH);
+}
+
+#writes out the backlog to a file which correlates to ASM's SQL actionlog table
+sub sqlIncident
+{
+ my $self = shift;
+ my ($channel, $index) = @_;
+ $channel = lc $channel;
+ my @chans = split(/,/, $channel);
+ open(FH, '>', $self->{CONFIG}->{actiondir} . $index . '.txt');
+ foreach my $chan (@chans) {
+ if (defined($self->{backlog}->{$chan})) {
+ say FH "$chan";
+ say FH join('', @{$self->{backlog}->{$chan}});
+ }
+ }
+ close(FH);
+}
+
+sub logg
+{
+ my $self = shift;
+ my ($event) = @_;
+ my $cfg = $self->{CONFIG};
+ my @chans = @{$event->{to}};
+ @chans = ( $event->{args}->[0] ) if ($event->{type} eq 'kick');
+ my @time = ($cfg->{zone} eq 'local') ? localtime : gmtime;
+ foreach my $chan ( @chans )
+ {
+ $chan = lc $chan;
+ next if ($chan eq '$$*');
+ $chan =~ s/^[@+]//;
+ if ($chan eq '*') {
+ ASM::Util->dprint("$event->{nick}: $event->{args}->[0]", 'snotice');
+ next;
+ }
+ my $path = ">>$cfg->{dir}${chan}/${chan}" . strftime($cfg->{filefmt}, @time);
+ $_ = '';
+ $_ = "<$event->{nick}> $event->{args}->[0]" if $event->{type} eq 'public';
+ $_ = "*** $event->{nick} has joined $chan" if $event->{type} eq 'join';
+ $_ = "*** $event->{nick} has left $chan ($event->{args}->[0])" if $event->{type} eq 'part';
+ $_ = "* $event->{nick} $event->{args}->[0]" if $event->{type} eq 'caction';
+ $_ = "*** $event->{nick} is now known as $event->{args}->[0]" if $event->{type} eq 'nick';
+ $_ = "*** $event->{nick} has quit ($event->{args}->[0])" if $event->{type} eq 'quit';
+ $_ = "*** $event->{to}->[0] was kicked by $event->{nick}" if $event->{type} eq 'kick';
+ $_ = "-$event->{nick}- $event->{args}->[0]" if $event->{type} eq 'notice';
+ $_ = "*** $event->{nick} sets mode: " . join(" ",@{$event->{args}}) if $event->{type} eq 'mode';
+ $_ = "*** $event->{nick} changes topic to \"$event->{args}->[0]\"" if $event->{type} eq 'topic';
+ my $nostamp = $_;
+ $_ = strftime($cfg->{timefmt}, @time) . $_ . "\n";
+ my $line = $_;
+ my @backlog = ();
+ if (defined($self->{backlog}->{$chan})) {
+ @backlog = @{$self->{backlog}->{$chan}};
+ if (scalar @backlog >= 30) {
+ shift @backlog;
+ }
+ }
+ push @backlog, $line;
+ $self->{backlog}->{$chan} = \@backlog;
+ if (open(FH, $path)) { # or die "Can't open $path: $!";
+ print FH $line;
+ ASM::Util->dprint($line, 'logger');
+ close(FH);
+ } else {
+ print "COULDN'T PRINT TO $path - $line";
+ }
+ my $spy;
+ if (defined($::spy{$chan})) {
+ $spy = $::spy{$chan};
+ } elsif (defined($::spy{lc $event->{nick}})) {
+ $spy = $::spy{lc $event->{nick}};
+ }
+ if (defined($spy)) {
+ say $spy "$chan: $nostamp";
+ }
+# $_ >> io($path);
+ }
+}
+
+1;
diff --git a/lib/ASM/Services.pm b/lib/ASM/Services.pm
new file mode 100644
index 0000000..528901d
--- /dev/null
+++ b/lib/ASM/Services.pm
@@ -0,0 +1,69 @@
+package ASM::Services;
+use warnings;
+use strict;
+
+use Data::Dumper;
+$Data::Dumper::Useqq=1;
+
+sub new
+{
+ my $self = {};
+ bless($self);
+ return $self;
+}
+
+sub doServices {
+ my ($self, $conn, $event) = @_;
+ my $i = 1;
+ if ($event->{from} eq 'NickServ!NickServ@services.')
+ {
+ ASM::Util->dprint("NickServ: $event->{args}->[0]", 'snotice');
+ if ( $event->{args}->[0] =~ /^This nickname is registered/ )
+ {
+ $conn->privmsg( 'NickServ@services.', "identify $::settings->{nick} $::settings->{pass}" );
+ }
+ elsif ( $event->{args}->[0] =~ /^You are now identified/ )
+ {
+ my @autojoins = @{$::settings->{autojoins}};
+ if (defined($autojoins[30])) {
+ $conn->join(join(',', @autojoins[0..30]));
+ if (defined($autojoins[60])) {
+ $conn->join(join(',', @autojoins[30..60]));
+ $conn->join(join(',', @autojoins[60..$#autojoins]));
+ } else {
+ $conn->join(join(',', @autojoins[30..$#autojoins]));
+ }
+ } else {
+ $conn->join(join(',', @autojoins));
+ }
+ $conn->sl("PING :" . time);
+ $conn->schedule(2, sub { $conn->privmsg($::settings->{masterchan}, 'Now joined to all channels in '. (time - $::starttime) . " seconds."); });
+ }
+ elsif ($event->{args}->[0] =~ /has been (killed|released)/ )
+ {
+# ASM::Util->dprint('Got kill/release successful from NickServ!', 'snotice');
+ $conn->nick( $::settings->{nick} );
+ }
+ elsif ($event->{args}->[0] =~ /has been regained/ )
+ {
+# ASM::Util->dprint('Got regain successful from nickserv!', 'snotice');
+ }
+ elsif ($event->{args}->[0] =~ /Password Incorrect/ )
+ {
+ die("NickServ password invalid.")
+ }
+ }
+ elsif ($event->{from} eq 'ChanServ!ChanServ@services.')
+ {
+ if ( $event->{args}->[0] =~ /^\[#/ ) {
+ return;
+ }
+ ASM::Util->dprint("ChanServ: $event->{args}->[0]", 'snotice');
+ if ( $event->{args}->[0] =~ /^All.*bans matching.*have been cleared on(.*)/)
+ {
+ $conn->join($1);
+ }
+ }
+}
+
+return 1;
diff --git a/lib/ASM/Util.pm b/lib/ASM/Util.pm
new file mode 100644
index 0000000..f9895a0
--- /dev/null
+++ b/lib/ASM/Util.pm
@@ -0,0 +1,297 @@
+package ASM::Util;
+use Array::Utils qw(:all);
+use POSIX qw(strftime);
+use warnings;
+use strict;
+use Term::ANSIColor qw (:constants);
+use Socket qw( inet_aton inet_ntoa );
+use Data::Dumper;
+use Carp qw(cluck);
+
+%::RISKS =
+(
+ 'disable'=> -1, #this isn't really an alert
+ 'debug' => 10,
+ 'info' => 20,
+ 'low' => 30,
+ 'medium' => 40,
+ 'high' => 50,
+ 'opalert'=> 9001 #OVER NINE THOUSAND!!!
+);
+
+#leaves room for more levels if for some reason we end up needing more
+#theoretically, you should be able to change those numbers without any damage
+
+%::COLORS =
+(
+ 'white' => '00',
+ 'black' => '01',
+ 'blue' => '02',
+ 'green' => '03',
+ 'red' => '04',
+ 'brown' => '05',
+ 'purple' => '06',
+ 'orange' => '07',
+ 'yellow' => '08',
+ 'ltgreen' => '09',
+ 'teal' => '10',
+ 'ltcyan' => '11',
+ 'ltblue' => '12',
+ 'pink' => '13',
+ 'grey' => '14',
+ 'ltgrey' => '15',
+);
+
+%::RCOLOR =
+(
+ $::RISKS{debug} => $::COLORS{purple},
+ $::RISKS{info} => $::COLORS{blue},
+ $::RISKS{low} => $::COLORS{green},
+ $::RISKS{medium} => $::COLORS{orange},
+ $::RISKS{high} => $::COLORS{red},
+);
+
+sub new
+{
+ my $module = shift;
+ my $self = {};
+ bless ($self);
+ return $self;
+}
+
+sub maxlen {
+ my ($a, $b) = @_;
+ my ($la, $lb) = (length($a), length($b));
+ return $la if ($la > $lb);
+ return $lb;
+}
+
+#cs: returns the xml settings for the specified chan, or default if there aren't any settings for that chan
+sub cs {
+ my ($module, $chan) = @_;
+ $chan = lc $chan;
+ $chan =~ s/^[@+]//;
+ return $::channels->{channel}->{default} unless defined($::channels->{channel}->{$chan});
+ if ( defined($::channels->{channel}->{$chan}->{link}) ) {
+ return $::channels->{channel}->{ $::channels->{channel}->{$chan}->{link} };
+ }
+ return $::channels->{channel}->{$chan};
+}
+
+sub getLink
+{
+ my ($module, $chan) = @_;
+ $chan = lc $chan;
+ $chan =~ s/^[@+]//;
+ my $link = $::channels->{channel}->{$chan}->{link};
+ if ( defined($link) ) {
+ return $link;
+ }
+ return $chan;
+}
+
+sub speak
+{
+ my ($module, $chan) = @_;
+ $chan = lc $chan;
+ $chan =~ s/^[@+]//;
+ if ( defined($::channels->{channel}->{$chan}->{silence}) ) {
+ if ($::channels->{channel}->{$chan}->{silence} eq "no") {
+ return 1;
+ }
+ elsif ($::channels->{channel}->{$chan}->{silence} eq "yes") {
+ return 0;
+ }
+ }
+ if ( defined($::channels->{channel}->{default}->{silence}) ) {
+ if ( $::channels->{channel}->{default}->{silence} eq "no" ) {
+ return 1;
+ }
+ elsif ( $::channels->{channel}->{default}->{silence} eq "yes" ) {
+ return 0;
+ }
+ }
+ return 1;
+}
+
+#this item is a stub, dur
+sub hostip {
+ #cluck "Calling gethostbyname in hostip";
+ return gethostbyname($_[0]);
+}
+
+# If $tgts="#antispammeta" that's fine, and if $tgts = ["#antispammeta", "##linux-ops"] that's cool too
+sub sendLongMsg {
+ my ($module, $conn, $tgts, $txtz) = @_;
+ if (length($txtz) <= 380) {
+ $conn->privmsg($tgts, $txtz);
+ } else {
+ my $splitpart = rindex($txtz, " ", 380);
+ $conn->privmsg($tgts, substr($txtz, 0, $splitpart));
+ $conn->privmsg($tgts, substr($txtz, $splitpart));
+ }
+}
+
+sub getAlert {
+ my ($module, $c, $risk, $t) = @_;
+ my @disable = ();
+ my @x = ();
+ $c = lc $c;
+ $c =~ s/^[@+]//;
+ foreach my $prisk ( keys %::RISKS) {
+ if ( $::RISKS{$risk} >= $::RISKS{$prisk} ) {
+ push( @x, @{$::channels->{channel}->{master}->{$t}->{$prisk}} ) if defined $::channels->{channel}->{master}->{$t}->{$prisk};
+ push( @x, @{cs($module, $c)->{$t}->{$prisk}} ) if defined cs($module, $c)->{$t}->{$prisk};
+ }
+ }
+ push( @disable, @{$::channels->{channel}->{master}->{$t}->{disable}} ) if defined $::channels->{channel}->{master}->{$t}->{disable};
+ push( @disable, @{cs($module, $c)->{$t}->{disable}} ) if defined cs($module, $c)->{$t}->{disable};
+ @x = unique(@x);
+ @x = array_diff(@x, @disable);
+ return @x;
+}
+
+sub commaAndify {
+ my $module = shift;
+ my @seq = @_;
+ my $len = ($#seq);
+ my $last = $seq[$len];
+ return '' if $len eq -1;
+ return $seq[0] if $len eq 0;
+ return join( ' and ', $seq[0], $seq[1] ) if $len eq 1;
+ return join( ', ', splice(@seq,0,$len) ) . ', and ' . $last;
+}
+
+sub leq {
+ my ($s1, $s2) = @_;
+ return (lc $s1 eq lc $s2);
+}
+
+sub seq {
+ my ($n1, $n2) = @_;
+ return 0 unless defined($n1);
+ return 0 unless defined($n2);
+ return ($n1 eq $n2);
+}
+
+#I last worked on this function while having way too many pain meds, if it's fucked up, that's why.
+sub dprint {
+ my ($module, $text, $type) = @_;
+ if (!defined($type)) {
+ die "old method for dprint called!\n";
+ }
+ if (!defined($::debugx{$type})) {
+ die "dprint called with invalid type!\n";
+ }
+ if ($::debugx{$type} eq 0) {
+ return;
+ }
+ say STDERR strftime("%F %T ", gmtime),
+ GREEN, 'DEBUG', RESET, '(', $::debugx{$type}, $type, RESET, ') ', $text;
+}
+
+
+sub intToDottedQuad {
+ my ($module, $num) = @_;
+ return inet_ntoa(pack('N', $num));
+}
+
+sub dottedQuadToInt
+{
+ my ($module, $dottedquad) = @_;
+# my $ip_number = 0;
+# my @octets = split(/\./, $dottedquad);
+# foreach my $octet (@octets) {
+# $ip_number <<= 8;
+# $ip_number |= $octet;
+# }
+# return $ip_number;
+ return unpack('N', inet_aton($dottedquad));
+}
+
+sub getHostIP
+{
+ my ($module, $host) = @_;
+ if ( ($host =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)$/) or
+ ($host =~ /^gateway\/web\/.*\/ip\.(\d+)\.(\d+)\.(\d+)\.(\d+)$/) ) {
+ #yay, easy IP!
+ return dottedQuadToInt(undef, "$1.$2.$3.$4");
+ } elsif (index($host, '/') != -1) {
+ return;
+ } elsif ($host =~ /^2001:0:/) {
+ my @splitip = split(/:/, $host);
+ return unless defined($splitip[6]) && defined($splitip[7]);
+ #I think I can just do (hex($splitip[6] . $splitip[7]) ^ hex('ffffffff')) here but meh
+ my $host = join('.', unpack('C4', pack('N', (hex($splitip[6] . $splitip[7])^hex('ffffffff')))));
+ return dottedQuadToInt(undef, $host);
+ }
+ #cluck "Calling gethostbyname in getHostIP";
+ my @resolve = gethostbyname($host);
+ return unless @resolve;
+ return dottedQuadToInt(undef, join('.', unpack('C4', $resolve[4])));
+}
+
+sub getNickIP
+{
+ my ($module, $nick, $host) = @_;
+ $nick = lc $nick;
+ return unless defined($::sn{$nick});
+ if (defined($::sn{$nick}{ip})) {
+ return $::sn{$nick}{ip};
+ }
+ $host //= $::sn{$nick}{host};
+ my $ip = getHostIP(undef, $host);
+ if (defined($ip)) {
+ $::sn{$nick}{ip} = $ip;
+ return $ip;
+ }
+ return;
+# if ( ($host =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)$/) or
+# ($host =~ /^gateway\/web\/freenode\/ip\.(\d+)\.(\d+)\.(\d+)\.(\d+)$/) ) {
+# #yay, easy IP!
+# $::sn{$nick}{ip} = dottedQuadToInt(undef, "$1.$2.$3.$4");
+# return $::sn{$nick}{ip};
+# } elsif (index($host, '/') != -1) {
+# return;
+# } elsif ($host =~ /^2001:0:/) {
+# my @splitip = split(/:/, $host);
+# #I think I can just do (hex($splitip[6] . $splitip[7]) ^ hex('ffffffff')) here but meh
+# my $host = join('.', unpack('C4', pack('N', (hex($splitip[6] . $splitip[7])^hex('ffffffff')))));
+# $::sn{$nick}{ip} = dottedQuadToInt(undef, $host);
+# return $::sn{$nick}{ip};
+# }
+# my @resolve = gethostbyname($::sn{$nick}{host});
+# return unless @resolve;
+# $::sn{$nick}{ip} = dottedQuadToInt(undef, join('.', unpack('C4', $resolve[4])));
+# return $::sn{$nick}{ip};
+}
+
+sub notRestricted {
+ my ($module, $nick, $restriction) = @_;
+ $nick = lc $nick;
+ my $host = lc $::sn{$nick}{host};
+ my $account = lc $::sn{$nick}{account};
+ foreach my $regex (keys %{$::restrictions->{nicks}->{nick}}) {
+ if ($nick =~ /^$regex$/i && defined($::restrictions->{nicks}->{nick}->{$regex}->{$restriction})) {
+ dprint("blah", "Restriction $restriction found for $nick (nick $regex)", "restrictions");
+ return 0;
+ }
+ }
+ if ((defined($host)) && (defined($account))) {
+ foreach my $regex (keys %{$::restrictions->{accounts}->{account}}) {
+ if ($account =~ /^$regex$/i && defined($::restrictions->{accounts}->{account}->{$regex}->{$restriction})) {
+ dprint("blah", "Restriction $restriction found for $nick (account $regex)", "restrictions");
+ return 0;
+ }
+ }
+ foreach my $regex (keys %{$::restrictions->{hosts}->{host}}) {
+ if ($host =~ /^$regex$/i && defined($::restrictions->{hosts}->{host}->{$regex}->{$restriction})) {
+ dprint("blah", "Restriction $restriction found for $nick (host $regex)", "restrictions");
+ return 0;
+ }
+ }
+ }
+ return 1;
+}
+
+return 1;
diff --git a/lib/ASM/XML.pm b/lib/ASM/XML.pm
new file mode 100644
index 0000000..1128dda
--- /dev/null
+++ b/lib/ASM/XML.pm
@@ -0,0 +1,69 @@
+package ASM::XML;
+use warnings;
+use strict;
+
+use XML::Simple qw(:strict);
+use IO::All;
+
+$::xs1 = XML::Simple->new( KeyAttr => ['id'], Cache => [ qw/memcopy/ ]);
+
+sub readXML {
+ my ( $p ) = $::cset;
+ my @fchan = ( 'event', keys %::RISKS );
+ $::settings = $::xs1->XMLin( "$p/settings.xml", ForceArray => ['host'],
+ 'GroupTags' => { altnicks => 'altnick', server => 'host',
+ autojoins => 'autojoin' });
+ $::channels = $::xs1->XMLin( "$p/channels.xml", ForceArray => \@fchan );
+ $::users = $::xs1->XMLin( "$p/users.xml", ForceArray => 'person');
+ $::commands = $::xs1->XMLin( "$p/commands.xml", ForceArray => [qw/command/]);
+ $::mysql = $::xs1->XMLin( "$p/mysql.xml", ForceArray => ['ident', 'geco'],
+ 'GroupTags' => { ignoredidents => 'ident', ignoredgecos => 'geco' });
+ $::dnsbl = $::xs1->XMLin( "$p/dnsbl.xml", ForceArray => []);
+ $::rules = $::xs1->XMLin( "$p/rules.xml", ForceArray => []);
+ $::restrictions = $::xs1->XMLin( "$p/restrictions.xml", ForceArray => ['host', 'nick', 'account']);
+ $::blacklist = $::xs1->XMLin( "$p/blacklist.xml", ForceArray => 'string');
+}
+
+sub writeXML {
+ writeSettings();
+ writeChannels();
+ writeUsers();
+ writeRestrictions();
+ writeBlacklist();
+ writeMysql();
+# $::xs1->XMLout($::commands, RootName => 'commands', KeyAttr => ['id']) > io("$::cset/commands.xml");
+}
+
+sub writeMysql {
+ $::settingschanged=1;
+ $::xs1->XMLout($::mysql, RootName => 'mysql', KeyAttr => ['id']) > io("$::cset/mysql.xml");
+}
+
+sub writeChannels {
+ $::settingschanged=1;
+ $::xs1->XMLout($::channels, RootName => 'channels', KeyAttr => ['id'], NumericEscape => 2) > io("$::cset/channels.xml");
+}
+
+sub writeUsers {
+ $::settingschanged=1;
+ $::xs1->XMLout($::users, RootName => 'people', KeyAttr => ['id']) > io("$::cset/users.xml");
+}
+
+sub writeSettings {
+ $::settingschanged=1;
+ $::xs1->XMLout($::settings, RootName => 'settings',
+ GroupTags => { altnicks => 'altnick', server => 'host', autojoins => 'autojoin' }, NoAttr => 1) > io("$::cset/settings.xml");
+}
+
+sub writeRestrictions {
+ $::settingschanged=1;
+ $::xs1->XMLout($::restrictions, RootName => 'restrictions', KeyAttr => ['id'],
+ GroupTags => { hosts => "host", nicks => "nick", accounts => "account"}) > io("$::cset/restrictions.xml");
+}
+
+sub writeBlacklist {
+ $::settingschanged=1;
+ $::xs1->XMLout($::blacklist, RootName => 'blacklist', KeyAttr => ['id'], NumericEscape => 2) > io("$::cset/blacklist.xml");
+}
+
+return 1;
diff --git a/lib/Net/IRC.pm b/lib/Net/IRC.pm
new file mode 100644
index 0000000..9e39458
--- /dev/null
+++ b/lib/Net/IRC.pm
@@ -0,0 +1,759 @@
+#####################################################################
+# #
+# Net::IRC -- Object-oriented Perl interface to an IRC server #
+# #
+# IRC.pm: A nifty little wrapper that makes your life easier. #
+# #
+# Copyright (c) 1997 Greg Bacon & Dennis Taylor. #
+# All rights reserved. #
+# #
+# This module is free software; you can redistribute or #
+# modify it under the terms of Perl's Artistic License. #
+# #
+#####################################################################
+# $Id: IRC.pm,v 1.10 2004/04/30 18:02:51 jmuhlich Exp $
+
+
+package Net::IRC;
+
+BEGIN { require 5.004; } # needs IO::* and $coderef->(@args) syntax
+
+use Net::IRC::Connection;
+use Net::IRC::EventQueue;
+use IO::Select;
+use Carp;
+
+
+# grab the drop-in replacement for time() from Time::HiRes, if it's available
+BEGIN {
+ Time::HiRes->import('time') if eval "require Time::HiRes";
+}
+
+
+use strict;
+use vars qw($VERSION);
+
+$VERSION = "0.80";
+
+sub new {
+ my $proto = shift;
+
+ my $self = {
+ '_conn' => [],
+ '_connhash' => {},
+ '_error' => IO::Select->new(),
+ '_debug' => 0,
+ '_schedulequeue' => new Net::IRC::EventQueue(),
+ '_outputqueue' => new Net::IRC::EventQueue(),
+ '_read' => IO::Select->new(),
+ '_timeout' => 1,
+ '_write' => IO::Select->new(),
+ };
+
+ bless $self, $proto;
+
+ return $self;
+}
+
+sub outputqueue {
+ my $self = shift;
+ return $self->{_outputqueue};
+}
+
+sub schedulequeue {
+ my $self = shift;
+ return $self->{_schedulequeue};
+}
+
+# Front end to addfh(), below. Sets it to read by default.
+# Takes at least 1 arg: an object to add to the select loop.
+# (optional) a flag string to pass to addfh() (see below)
+sub addconn {
+ my ($self, $conn) = @_;
+
+ $self->addfh( $conn->socket, $conn->can('parse'), ($_[2] || 'r'), $conn);
+}
+
+# Adds a filehandle to the select loop. Tasty and flavorful.
+# Takes 3 args: a filehandle or socket to add
+# a coderef (can be undef) to pass the ready filehandle to for
+# user-specified reading/writing/error handling.
+# (optional) a string with r/w/e flags, similar to C's fopen() syntax,
+# except that you can combine flags (i.e., "rw").
+# (optional) an object that the coderef is a method of
+sub addfh {
+ my ($self, $fh, $code, $flag, $obj) = @_;
+ my ($letter);
+
+ die "Not enough arguments to IRC->addfh()" unless defined $code;
+
+ if ($flag) {
+ foreach $letter (split(//, lc $flag)) {
+ if ($letter eq 'r') {
+ $self->{_read}->add( $fh );
+ } elsif ($letter eq 'w') {
+ $self->{_write}->add( $fh );
+ } elsif ($letter eq 'e') {
+ $self->{_error}->add( $fh );
+ }
+ }
+ } else {
+ $self->{_read}->add( $fh );
+ }
+
+ $self->{_connhash}->{$fh} = [ $code, $obj ];
+}
+
+# Sets or returns the debugging flag for this object.
+# Takes 1 optional arg: a new boolean value for the flag.
+sub debug {
+ my $self = shift;
+
+ if (@_) {
+ $self->{_debug} = $_[0];
+ }
+ return $self->{_debug};
+}
+
+# Goes through one iteration of the main event loop. Useful for integrating
+# other event-based systems (Tk, etc.) with Net::IRC.
+# Takes no args.
+sub do_one_loop {
+ my $self = shift;
+ my ($ev, $sock, $time, $nexttimer, $timeout);
+ my (undef, undef, undef, $caller) = caller(1);
+
+ $time = time(); # no use calling time() all the time.
+
+ if(!$self->outputqueue->is_empty) {
+ my $outputevent = undef;
+ while(defined($outputevent = $self->outputqueue->head)
+ && $outputevent->time <= $time) {
+ $outputevent = $self->outputqueue->dequeue();
+ $outputevent->content->{coderef}->(@{$outputevent->content->{args}});
+ }
+ $nexttimer = $self->outputqueue->head->time if !$self->outputqueue->is_empty();
+ }
+
+ # we don't want to bother waiting on input or running
+ # scheduled events if we're just flushing the output queue
+ # so we bail out here
+ return if $caller eq 'Net::IRC::flush_output_queue';
+
+ # Check the queue for scheduled events to run.
+ if(!$self->schedulequeue->is_empty) {
+ my $scheduledevent = undef;
+ while(defined($scheduledevent = $self->schedulequeue->head) && $scheduledevent->time <= $time) {
+ $scheduledevent = $self->schedulequeue->dequeue();
+ $scheduledevent->content->{coderef}->(@{$scheduledevent->content->{args}});
+ }
+ if(!$self->schedulequeue->is_empty()
+ && $nexttimer
+ && $self->schedulequeue->head->time < $nexttimer) {
+ $nexttimer = $self->schedulequeue->head->time;
+ }
+ }
+
+ # Block until input arrives, then hand the filehandle over to the
+ # user-supplied coderef. Look! It's a freezer full of government cheese!
+
+ if ($nexttimer) {
+ $timeout = $nexttimer - $time < $self->{_timeout}
+ ? $nexttimer - $time : $self->{_timeout};
+ } else {
+ $timeout = $self->{_timeout};
+ }
+ foreach $ev (IO::Select->select($self->{_read},
+ $self->{_write},
+ $self->{_error},
+ $timeout)) {
+ foreach $sock (@{$ev}) {
+ my $conn = $self->{_connhash}->{$sock};
+ $conn or next;
+
+ # $conn->[0] is a code reference to a handler sub.
+ # $conn->[1] is optionally an object which the
+ # handler sub may be a method of.
+
+ $conn->[0]->($conn->[1] ? ($conn->[1], $sock) : $sock);
+ }
+ }
+}
+
+sub flush_output_queue {
+ my $self = shift;
+
+ while(!$self->outputqueue->is_empty()) {
+ $self->do_one_loop();
+ }
+}
+
+# Creates and returns a new Connection object.
+# Any args here get passed to Connection->connect().
+sub newconn {
+ my $self = shift;
+ my $conn = Net::IRC::Connection->new($self, @_);
+
+ return if $conn->error;
+ return $conn;
+}
+
+# Takes the args passed to it by Connection->schedule()... see it for details.
+sub enqueue_scheduled_event {
+ my $self = shift;
+ my $time = shift;
+ my $coderef = shift;
+ my @args = @_;
+
+ return $self->schedulequeue->enqueue($time, { coderef => $coderef, args => \@args });
+}
+
+# Takes a scheduled event ID to remove from the queue.
+# Returns the deleted coderef, if you actually care.
+sub dequeue_scheduled_event {
+ my ($self, $id) = @_;
+ $self->schedulequeue->dequeue($id);
+}
+
+# Takes the args passed to it by Connection->schedule()... see it for details.
+sub enqueue_output_event {
+ my $self = shift;
+ my $time = shift;
+ my $coderef = shift;
+ my @args = @_;
+
+ return $self->outputqueue->enqueue($time, { coderef => $coderef, args => \@args });
+}
+
+# Takes a scheduled event ID to remove from the queue.
+# Returns the deleted coderef, if you actually care.
+sub dequeue_output_event {
+ my ($self, $id) = @_;
+ $self->outputqueue->dequeue($id);
+}
+
+# Front-end for removefh(), below.
+# Takes 1 arg: a Connection (or DCC or whatever) to remove.
+sub removeconn {
+ my ($self, $conn) = @_;
+
+ $self->removefh( $conn->socket );
+}
+
+# Given a filehandle, removes it from all select lists. You get the picture.
+sub removefh {
+ my ($self, $fh) = @_;
+
+ $self->{_read}->remove( $fh );
+ $self->{_write}->remove( $fh );
+ $self->{_error}->remove( $fh );
+ delete $self->{_connhash}->{$fh};
+}
+
+# Begin the main loop. Wheee. Hope you remembered to set up your handlers
+# first... (takes no args, of course)
+sub start {
+ my $self = shift;
+
+ while (1) {
+ $self->do_one_loop();
+ }
+}
+
+# Sets or returns the current timeout, in seconds, for the select loop.
+# Takes 1 optional arg: the new value for the timeout, in seconds.
+# Fractional timeout values are just fine, as per the core select().
+sub timeout {
+ my $self = shift;
+
+ if (@_) { $self->{_timeout} = $_[0] }
+ return $self->{_timeout};
+}
+
+1;
+
+
+__END__
+
+
+=head1 NAME
+
+Net::IRC - DEAD SINCE 2004 Perl interface to the Internet Relay Chat protocol
+
+=head1 USE THESE INSTEAD
+
+This module has been abandoned and is no longer developed. This release serves
+only to warn current and future users about this and to direct them to supported
+and actively-developed libraries for connecting Perl to IRC. Most new users will
+want to use L<Bot::BasicBot>, whereas more advanced users will appreciate the
+flexibility offered by L<POE::Component::IRC>. We understand that porting code
+to a new framework can be difficult. Please stop by #perl on irc.freenode.net
+and we'll be happy to help you out with bringing your bots into the modern era.
+
+=head1 SYNOPSIS
+
+ use Net::IRC;
+
+ $irc = new Net::IRC;
+ $conn = $irc->newconn(Nick => 'some_nick',
+ Server => 'some.irc.server.com',
+ Port => 6667,
+ Ircname => 'Some witty comment.');
+ $irc->start;
+
+=head1 DESCRIPTION
+
+This module has been abandoned and deprecated since 2004. The original authors
+have moved onto L<POE::Component::IRC> and more modern techniques. This
+distribution is not maintained and only uploaded to present successively louder
+"don't use this" warnings to those unaware.
+
+Welcome to Net::IRC, a work in progress. First intended to be a quick tool
+for writing an IRC script in Perl, Net::IRC has grown into a comprehensive
+Perl implementation of the IRC protocol (RFC 1459), developed by several
+members of the EFnet IRC channel #perl, and maintained in channel #net-irc.
+
+There are 4 component modules which make up Net::IRC:
+
+=over
+
+=item *
+
+Net::IRC
+
+The wrapper for everything else, containing methods to generate
+Connection objects (see below) and a connection manager which does an event
+loop on all available filehandles. Sockets or files which are readable (or
+writable, or whatever you want it to select() for) get passed to user-supplied
+handler subroutines in other packages or in user code.
+
+=item *
+
+Net::IRC::Connection
+
+The big time sink on this project. Each Connection instance is a
+single connection to an IRC server. The module itself contains methods for
+every single IRC command available to users (Net::IRC isn't designed for
+writing servers, for obvious reasons), methods to set, retrieve, and call
+handler functions which the user can set (more on this later), and too many
+cute comments. Hey, what can I say, we were bored.
+
+=item *
+
+Net::IRC::Event
+
+Kind of a struct-like object for storing info about things that the
+IRC server tells you (server responses, channel talk, joins and parts, et
+cetera). It records who initiated the event, who it affects, the event
+type, and any other arguments provided for that event. Incidentally, the
+only argument passed to a handler function.
+
+=item *
+
+Net::IRC::DCC
+
+The analogous object to Connection.pm for connecting, sending and
+retrieving with the DCC protocol. Instances of DCC.pm are invoked from
+C<Connection-E<gt>new_{send,get,chat}> in the same way that
+C<IRC-E<gt>newconn> invokes C<Connection-E<gt>new>. This will make more
+sense later, we promise.
+
+=back
+
+The central concept that Net::IRC is built around is that of handlers
+(or hooks, or callbacks, or whatever the heck you feel like calling them).
+We tried to make it a completely event-driven model, a la Tk -- for every
+conceivable type of event that your client might see on IRC, you can give
+your program a custom subroutine to call. But wait, there's more! There are
+3 levels of handler precedence:
+
+=over
+
+=item *
+
+Default handlers
+
+Considering that they're hardwired into Net::IRC, these won't do
+much more than the bare minimum needed to keep the client listening on the
+server, with an option to print (nicely formatted, of course) what it hears
+to whatever filehandles you specify (STDOUT by default). These get called
+only when the user hasn't defined any of his own handlers for this event.
+
+=item *
+
+User-definable global handlers
+
+The user can set up his own subroutines to replace the default
+actions for I<every> IRC connection managed by your program. These only get
+invoked if the user hasn't set up a per-connection handler for the same
+event.
+
+=item *
+
+User-definable per-connection handlers
+
+Simple: this tells a single connection what to do if it gets an event of
+this type. Supersedes global handlers if any are defined for this event.
+
+=back
+
+And even better, you can choose to call your custom handlers before
+or after the default handlers instead of replacing them, if you wish. In
+short, it's not perfect, but it's about as good as you can get and still be
+documentable, given the sometimes horrendous complexity of the IRC protocol.
+
+
+=head1 GETTING STARTED
+
+=head2 Initialization
+
+To start a Net::IRC script, you need two things: a Net::IRC object, and a
+Net::IRC::Connection object. The Connection object does the dirty work of
+connecting to the server; the IRC object handles the input and output for it.
+To that end, say something like this:
+
+ use Net::IRC;
+
+ $irc = new Net::IRC;
+
+ $conn = $irc->newconn(Nick => 'some_nick',
+ Server => 'some.irc.server.com');
+
+...or something similar. Acceptable parameters to newconn() are:
+
+=over
+
+=item *
+
+Nick
+
+The nickname you'll be known by on IRC, often limited to a maximum of 9
+letters. Acceptable characters for a nickname are C<[\w{}[]\`^|-]>. If
+you don't specify a nick, it defaults to your username.
+
+=item *
+
+Server
+
+The IRC server to connect to. There are dozens of them across several
+widely-used IRC networks, but the oldest and most popular is EFNet (Eris
+Free Net), home to #perl. See http://www.irchelp.org/ for lists of
+popular servers, or ask a friend.
+
+=item *
+
+Port
+
+The port to connect to this server on. By custom, the default is 6667.
+
+=item *
+
+Username
+
+On systems not running identd, you can set the username for your user@host
+to anything you wish. Note that some IRC servers won't allow connections from
+clients which don't run identd.
+
+=item *
+
+Ircname
+
+A short (maybe 60 or so chars) piece of text, originally intended to display
+your real name, which people often use for pithy quotes and URLs. Defaults to
+the contents of your GECOS field.
+
+=item *
+
+Password
+
+If the IRC server you're trying to write a bot for is
+password-protected, no problem. Just say "C<Password => 'foo'>" and
+you're set.
+
+=item *
+
+SSL
+
+If you wish to connect to an irc server which is using SSL, set this to a
+true value. Ie: "C<SSL => 1>".
+
+=back
+
+=head2 Handlers
+
+Once that's over and done with, you need to set up some handlers if you want
+your bot to do anything more than sit on a connection and waste resources.
+Handlers are references to subroutines which get called when a specific event
+occurs. Here's a sample handler sub:
+
+ # What to do when the bot successfully connects.
+ sub on_connect {
+ my $self = shift;
+
+ print "Joining #IRC.pm...";
+ $self->join("#IRC.pm");
+ $self->privmsg("#IRC.pm", "Hi there.");
+ }
+
+The arguments to a handler function are always the same:
+
+=over
+
+=item $_[0]:
+
+The Connection object that's calling it.
+
+=item $_[1]:
+
+An Event object (see below) that describes what the handler is responding to.
+
+=back
+
+Got it? If not, see the examples in the irctest script that came with this
+distribution. Anyhow, once you've defined your handler subroutines, you need
+to add them to the list of handlers as either a global handler (affects all
+Connection objects) or a local handler (affects only a single Connection). To
+do so, say something along these lines:
+
+ $self->add_global_handler('376', \&on_connect); # global
+ $self->add_handler('msg', \&on_msg); # local
+
+376, incidentally, is the server number for "end of MOTD", which is an event
+that the server sends to you after you're connected. See Event.pm for a list
+of all possible numeric codes. The 'msg' event gets called whenever someone
+else on IRC sends your client a private message. For a big list of possible
+events, see the B<Event List> section in the documentation for
+Net::IRC::Event.
+
+=head2 Getting Connected
+
+When you've set up all your handlers, the following command will put your
+program in an infinite loop, grabbing input from all open connections and
+passing it off to the proper handlers:
+
+ $irc->start;
+
+Note that new connections can be added and old ones dropped from within your
+handlers even after you call this. Just don't expect any code below the call
+to C<start()> to ever get executed.
+
+If you're tying Net::IRC into another event-based module, such as perl/Tk,
+there's a nifty C<do_one_loop()> method provided for your convenience. Calling
+C<$irc-E<gt>do_one_loop()> runs through the IRC.pm event loop once, hands
+all ready filehandles over to the appropriate handler subs, then returns
+control to your program.
+
+=head1 METHOD DESCRIPTIONS
+
+This section contains only the methods in IRC.pm itself. Lists of the
+methods in Net::IRC::Connection, Net::IRC::Event, or Net::IRC::DCC are in
+their respective modules' documentation; just C<perldoc Net::IRC::Connection>
+(or Event or DCC or whatever) to read them. Functions take no arguments
+unless otherwise specified in their description.
+
+By the way, expect Net::IRC to use AutoLoader sometime in the future, once
+it becomes a little more stable.
+
+=over
+
+=item *
+
+addconn()
+
+Adds the specified object's socket to the select loop in C<do_one_loop()>.
+This is mostly for the use of Connection and DCC objects (and for pre-0.5
+compatibility)... for most (read: all) purposes, you can just use C<addfh()>,
+described below.
+
+Takes at least 1 arg:
+
+=over
+
+=item 0.
+
+An object whose socket needs to be added to the select loop
+
+=item 1.
+
+B<Optional:> A string consisting of one or more of the letters r, w, and e.
+Passed directly to C<addfh()>... see the description below for more info.
+
+=back
+
+=item *
+
+addfh()
+
+This sub takes a user's socket or filehandle and a sub to handle it with and
+merges it into C<do_one_loop()>'s list of select()able filehandles. This makes
+integration with other event-based systems (Tk, for instance) a good deal
+easier than in previous releases.
+
+Takes at least 2 args:
+
+=over
+
+=item 0.
+
+A socket or filehandle to monitor
+
+=item 1.
+
+A reference to a subroutine. When C<select()> determines that the filehandle
+is ready, it passes the filehandle to this (presumably user-supplied) sub,
+where you can read from it, write to it, etc. as your script sees fit.
+
+=item 2.
+
+B<Optional:> A string containing any combination of the letters r, w or e
+(standing for read, write, and error, respectively) which determines what
+conditions you're expecting on that filehandle. For example, this line
+select()s $fh (a filehandle, of course) for both reading and writing:
+
+ $irc->addfh( $fh, \&callback, "rw" );
+
+=back
+
+=item *
+
+do_one_loop()
+
+C<select()>s on all open filehandles and passes any ready ones to the
+appropriate handler subroutines. Also responsible for executing scheduled
+events from C<Net::IRC::Connection-E<gt>schedule()> on time.
+
+=item *
+
+new()
+
+A fairly vanilla constructor which creates and returns a new Net::IRC object.
+
+=item *
+
+newconn()
+
+Creates and returns a new Connection object. All arguments are passed straight
+to C<Net::IRC::Connection-E<gt>new()>; examples of common arguments can be
+found in the B<Synopsis> or B<Getting Started> sections.
+
+=item *
+
+removeconn()
+
+Removes the specified object's socket from C<do_one_loop()>'s list of
+select()able filehandles. This is mostly for the use of Connection and DCC
+objects (and for pre-0.5 compatibility)... for most (read: all) purposes,
+you can just use C<removefh()>, described below.
+
+Takes 1 arg:
+
+=over
+
+=item 0.
+
+An object whose socket or filehandle needs to be removed from the select loop
+
+=back
+
+=item *
+
+removefh()
+
+This method removes a given filehandle from C<do_one_loop()>'s list of
+selectable filehandles.
+
+Takes 1 arg:
+
+=over
+
+=item 0.
+
+A socket or filehandle to remove
+
+=back
+
+=item *
+
+start()
+
+Starts an infinite event loop which repeatedly calls C<do_one_loop()> to
+read new events from all open connections and pass them off to any
+applicable handlers.
+
+=item *
+
+timeout()
+
+Sets or returns the current C<select()> timeout for the main event loop, in
+seconds (fractional amounts allowed). See the documentation for the
+C<select()> function for more info.
+
+Takes 1 optional arg:
+
+=over
+
+=item 0.
+
+B<Optional:> A new value for the C<select()> timeout for this IRC object.
+
+=back
+
+=item *
+
+flush_output_queue()
+
+Flushes any waiting messages in the output queue if pacing is enabled. This
+method will not return until the output queue is empty.
+
+=over
+
+=back
+
+=head1 AUTHORS
+
+=over
+
+=item *
+
+Conceived and initially developed by Greg Bacon E<lt>gbacon@adtran.comE<gt>
+and Dennis Taylor E<lt>dennis@funkplanet.comE<gt>.
+
+=item *
+
+Ideas and large amounts of code donated by Nat "King" Torkington
+E<lt>gnat@frii.comE<gt>.
+
+=item *
+
+Currently being hacked on, hacked up, and worked over by the members of the
+Net::IRC developers mailing list. For details, see
+http://www.execpc.com/~corbeau/irc/list.html .
+
+=back
+
+=head1 URL
+
+Up-to-date source and information about the Net::IRC project can be found at
+http://www.sourceforge.net/projects/net-irc/ .
+
+=head1 SEE ALSO
+
+=over
+
+=item *
+
+perl(1).
+
+=item *
+
+RFC 1459: The Internet Relay Chat Protocol
+
+=item *
+
+http://www.irchelp.org/, home of fine IRC resources.
+
+=back
+
+=cut
+
+
diff --git a/lib/Net/IRC/Connection.pm b/lib/Net/IRC/Connection.pm
new file mode 100644
index 0000000..6918bda
--- /dev/null
+++ b/lib/Net/IRC/Connection.pm
@@ -0,0 +1,1691 @@
+#####################################################################
+# #
+# Net::IRC -- Object-oriented Perl interface to an IRC server #
+# #
+# Connection.pm: The basic functions for a simple IRC connection #
+# #
+# #
+# Copyright (c) 2001 Pete Sergeant, Greg Bacon & Dennis Taylor. #
+# All rights reserved. #
+# #
+# This module is free software; you can redistribute or #
+# modify it under the terms of Perl's Artistic License. #
+# #
+#####################################################################
+
+package Net::IRC::Connection;
+
+use Net::IRC::Event;
+use Net::IRC::DCC;
+use IO::Socket;
+use IO::Socket::INET;
+use Symbol;
+use Carp;
+use Data::Dumper;
+
+# all this junk below just to conditionally load a module
+# sometimes even perl is braindead...
+
+eval 'use Time::HiRes qw(time)';
+if(!$@) {
+ sub time ();
+ use subs 'time';
+ require Time::HiRes;
+ Time::HiRes->import('time');
+}
+
+use strict;
+
+use vars (
+ '$AUTOLOAD',
+);
+
+
+# The names of the methods to be handled by &AUTOLOAD.
+my %autoloaded = ( 'ircname' => undef,
+ 'port' => undef,
+ 'username' => undef,
+ 'socket' => undef,
+ 'verbose' => undef,
+ 'parent' => undef,
+ 'hostname' => undef,
+ 'pacing' => undef,
+ 'ssl' => undef,
+ );
+
+# This hash will contain any global default handlers that the user specifies.
+
+my %_udef = ();
+
+# Creates a new IRC object and assigns some default attributes.
+sub new {
+ my $proto = shift;
+
+ my $self = { # obvious defaults go here, rest are user-set
+ _debug => $_[0]->{_debug},
+ _port => 6667,
+ # Evals are for non-UNIX machines, just to make sure.
+ _username => eval { scalar getpwuid($>) } || $ENV{USER} || $ENV{LOGNAME} || "japh",
+ _ircname => $ENV{IRCNAME} || eval { (getpwuid($>))[6] } || "Just Another Perl Hacker",
+ _nick => $ENV{IRCNICK} || eval { scalar getpwuid($>) } || $ENV{USER} || $ENV{LOGNAME} || "WankerBot",
+ _ignore => {},
+ _handler => {},
+ _verbose => 0, # Is this an OK default?
+ _parent => shift,
+ _frag => '',
+ _connected => 0,
+ _maxlinelen => 510, # The RFC says we shouldn't exceed this.
+ _lastsl => 0,
+ _pacing => 0, # no pacing by default
+ _ssl => 0, # no ssl by default
+ _format => { 'default' => "[%f:%t] %m <%d>", },
+ _rx => 0,
+ _tx => 0,
+ };
+
+ bless $self, $proto;
+ # do any necessary initialization here
+ $self->connect(@_) if @_;
+
+ return $self;
+}
+
+# Takes care of the methods in %autoloaded
+# Sets specified attribute, or returns its value if called without args.
+sub AUTOLOAD {
+ my $self = @_; ## can't modify @_ for goto &name
+ my $class = ref $self; ## die here if !ref($self) ?
+ my $meth;
+
+ # -- #perl was here! --
+ # <Teratogen> absolute power corrupts absolutely, but it's a helluva lot
+ # of fun.
+ # <Teratogen> =)
+
+ ($meth = $AUTOLOAD) =~ s/^.*:://; ## strip fully qualified portion
+
+ unless (exists $autoloaded{$meth}) {
+ croak "No method called \"$meth\" for $class object.";
+ }
+
+ eval <<EOSub;
+sub $meth {
+ my \$self = shift;
+
+ if (\@_) {
+ my \$old = \$self->{"_$meth"};
+
+ \$self->{"_$meth"} = shift;
+
+ return \$old;
+ }
+ else {
+ return \$self->{"_$meth"};
+ }
+}
+EOSub
+
+ # no reason to play this game every time
+ goto &$meth;
+}
+
+# This sub is the common backend to add_handler and add_global_handler
+#
+sub _add_generic_handler {
+ my ($self, $event, $ref, $rp, $hash_ref, $real_name) = @_;
+ my $ev;
+ my %define = ( "replace" => 0, "before" => 1, "after" => 2 );
+
+ unless (@_ >= 3) {
+ croak "Not enough arguments to $real_name()";
+ }
+ unless (ref($ref) eq 'CODE') {
+ croak "Second argument of $real_name isn't a coderef";
+ }
+
+ # Translate REPLACE, BEFORE and AFTER.
+ if (not defined $rp) {
+ $rp = 0;
+ } elsif ($rp =~ /^\D/) {
+ $rp = $define{lc $rp} || 0;
+ }
+
+ foreach $ev (ref $event eq "ARRAY" ? @{$event} : $event) {
+ # Translate numerics to names
+ if ($ev =~ /^\d/) {
+ $ev = Net::IRC::Event->trans($ev);
+ unless ($ev) {
+ carp "Unknown event type in $real_name: $ev";
+ return;
+ }
+ }
+
+ $hash_ref->{lc $ev} = [ $ref, $rp ];
+ }
+ return 1;
+}
+
+# This sub will assign a user's custom function to a particular event which
+# might be received by any Connection object.
+# Takes 3 args: the event to modify, as either a string or numeric code
+# If passed an arrayref, the array is assumed to contain
+# all event names which you want to set this handler for.
+# a reference to the code to be executed for the event
+# (optional) A value indicating whether the user's code should replace
+# the built-in handler, or be called with it. Possible values:
+# 0 - Replace the built-in handlers entirely. (the default)
+# 1 - Call this handler right before the default handler.
+# 2 - Call this handler right after the default handler.
+# These can also be referred to by the #define-like strings in %define.
+sub add_global_handler {
+ my ($self, $event, $ref, $rp) = @_;
+ return $self->_add_generic_handler($event, $ref, $rp, \%_udef, 'add_global_handler');
+}
+
+# This sub will assign a user's custom function to a particular event which
+# this connection might receive. Same args as above.
+sub add_handler {
+ my ($self, $event, $ref, $rp) = @_;
+ return $self->_add_generic_handler($event, $ref, $rp, $self->{_handler}, 'add_handler');
+}
+
+# Hooks every event we know about...
+sub add_default_handler {
+ my ($self, $ref, $rp) = @_;
+ foreach my $eventtype (keys(%Net::IRC::Event::_names)) {
+ $self->_add_generic_handler($eventtype, $ref, $rp, $self->{_handler}, 'add_default_handler');
+ }
+ return 1;
+}
+
+# Why do I even bother writing subs this simple? Sends an ADMIN command.
+# Takes 1 optional arg: the name of the server you want to query.
+sub admin {
+ my $self = shift; # Thank goodness for AutoLoader, huh?
+ # Perhaps we'll finally use it soon.
+
+ $self->sl("ADMIN" . ($_[0] ? " $_[0]" : ""));
+}
+
+# Toggles away-ness with the server. Optionally takes an away message.
+sub away {
+ my $self = shift;
+ $self->sl("AWAY" . ($_[0] ? " :$_[0]" : ""));
+}
+
+# Attempts to connect to the specified IRC (server, port) with the specified
+# (nick, username, ircname). Will close current connection if already open.
+sub connect {
+ my $self = shift;
+ my ($password, $sock);
+
+ if (@_) {
+ my (%arg) = @_;
+
+ $self->hostname($arg{'LocalAddr'}) if exists $arg{'LocalAddr'};
+ $password = $arg{'Password'} if exists $arg{'Password'};
+ $self->nick($arg{'Nick'}) if exists $arg{'Nick'};
+ $self->port($arg{'Port'}) if exists $arg{'Port'};
+ $self->server($arg{'Server'}) if exists $arg{'Server'};
+ $self->ircname($arg{'Ircname'}) if exists $arg{'Ircname'};
+ $self->username($arg{'Username'}) if exists $arg{'Username'};
+ $self->pacing($arg{'Pacing'}) if exists $arg{'Pacing'};
+ $self->ssl($arg{'SSL'}) if exists $arg{'SSL'};
+ }
+
+ # Lots of error-checking claptrap first...
+ unless ($self->server) {
+ unless ($ENV{IRCSERVER}) {
+ croak "No server address specified in connect()";
+ }
+ $self->server( $ENV{IRCSERVER} );
+ }
+ unless ($self->nick) {
+ $self->nick($ENV{IRCNICK} || eval { scalar getpwuid($>) }
+ || $ENV{USER} || $ENV{LOGNAME} || "WankerBot");
+ }
+ unless ($self->port) {
+ $self->port($ENV{IRCPORT} || 6667);
+ }
+ unless ($self->ircname) {
+ $self->ircname($ENV{IRCNAME} || eval { (getpwuid($>))[6] }
+ || "Just Another Perl Hacker");
+ }
+ unless ($self->username) {
+ $self->username(eval { scalar getpwuid($>) } || $ENV{USER}
+ || $ENV{LOGNAME} || "japh");
+ }
+
+ # Now for the socket stuff...
+ if ($self->connected) {
+ $self->quit("Changing servers");
+ }
+
+ if($self->ssl) {
+ require IO::Socket::SSL;
+
+ $self->socket(IO::Socket::SSL->new(PeerAddr => $self->server,
+ PeerPort => $self->port,
+ Proto => "tcp",
+ LocalAddr => $self->hostname,
+ ));
+ } else {
+
+ $self->socket(IO::Socket::INET->new(PeerAddr => $self->server,
+ PeerPort => $self->port,
+ Proto => "tcp",
+ LocalAddr => $self->hostname,
+ ));
+ }
+
+ if(!$self->socket) {
+ carp (sprintf "Can't connect to %s:%s!",
+ $self->server, $self->port);
+ $self->error(1);
+ return;
+ }
+
+ # Send a PASS command if they specified a password. According to
+ # the RFC, we should do this as soon as we connect.
+ if (defined $password) {
+ $self->sl("PASS $password");
+ }
+
+ # Now, log in to the server...
+ unless ($self->sl('NICK ' . $self->nick()) and
+ $self->sl(sprintf("USER %s %s %s :%s",
+ $self->username(),
+ "foo.bar.com",
+ $self->server(),
+ $self->ircname()))) {
+ carp "Couldn't send introduction to server: $!";
+ $self->error(1);
+ $! = "Couldn't send NICK/USER introduction to " . $self->server;
+ return;
+ }
+
+ $self->{_connected} = 1;
+ $self->parent->addconn($self);
+}
+
+# Returns a boolean value based on the state of the object's socket.
+sub connected {
+ my $self = shift;
+
+ return ( $self->{_connected} and $self->socket() );
+}
+
+# Sends a CTCP request to some hapless victim(s).
+# Takes at least two args: the type of CTCP request (case insensitive)
+# the nick or channel of the intended recipient(s)
+# Any further args are arguments to CLIENTINFO, ERRMSG, or ACTION.
+sub ctcp {
+ my ($self, $type, $target) = splice @_, 0, 3;
+ $type = uc $type;
+
+ unless ($target) {
+ croak "Not enough arguments to ctcp()";
+ }
+
+ if ($type eq "PING") {
+ unless ($self->sl("PRIVMSG $target :\001PING " . int(time) . "\001")) {
+ carp "Socket error sending $type request in ctcp()";
+ return;
+ }
+ } elsif (($type eq "CLIENTINFO" or $type eq "ACTION") and @_) {
+ unless ($self->sl("PRIVMSG $target :\001$type " .
+ CORE::join(" ", @_) . "\001")) {
+ carp "Socket error sending $type request in ctcp()";
+ return;
+ }
+ } elsif ($type eq "ERRMSG") {
+ unless (@_) {
+ carp "Not enough arguments to $type in ctcp()";
+ return;
+ }
+ unless ($self->sl("PRIVMSG $target :\001ERRMSG " .
+ CORE::join(" ", @_) . "\001")) {
+ carp "Socket error sending $type request in ctcp()";
+ return;
+ }
+ } else {
+ unless ($self->sl("PRIVMSG $target :\001$type " .
+ CORE::join(" ",@_) . "\001")) {
+ carp "Socket error sending $type request in ctcp()";
+ return;
+ }
+ }
+}
+
+# Sends replies to CTCP queries. Simple enough, right?
+# Takes 2 args: the target person or channel to send a reply to
+# the text of the reply
+sub ctcp_reply {
+ my $self = shift;
+
+ $self->notice($_[0], "\001" . $_[1] . "\001");
+}
+
+
+# Sets or returns the debugging flag for this object.
+# Takes 1 optional arg: a new boolean value for the flag.
+sub debug {
+ my $self = shift;
+ if (@_) {
+ $self->{_debug} = $_[0];
+ }
+ return $self->{_debug};
+}
+
+
+# Dequotes CTCP messages according to ctcp.spec. Nothing special.
+# Then it breaks them into their component parts in a flexible, ircII-
+# compatible manner. This is not quite as trivial. Oh, well.
+# Takes 1 arg: the line to be dequoted.
+sub dequote {
+ my $line = shift;
+ my ($order, @chunks) = (0, ()); # CHUNG! CHUNG! CHUNG!
+
+ # Filter misplaced \001s before processing... (Thanks, Tom!)
+ substr($line, rindex($line, "\001"), 1) = '\\a'
+ unless ($line =~ tr/\001//) % 2 == 0;
+
+ # Thanks to Abigail (abigail@fnx.com) for this clever bit.
+ if (index($line, "\cP") >= 0) { # dequote low-level \n, \r, ^P, and \0.
+ my (%h) = (n => "\012", r => "\015", 0 => "\0", "\cP" => "\cP");
+ $line =~ s/\cP([nr0\cP])/$h{$1}/g;
+ }
+ $line =~ s/\\([^\\a])/$1/g; # dequote unnecessarily quoted characters.
+
+ # If true, it's in odd order... ctcp commands start with first chunk.
+ $order = 1 if index($line, "\001") == 0;
+ @chunks = map { s/\\\\/\\/g; $_ } (split /\cA/, $line);
+
+ return ($order, @chunks);
+}
+
+# Standard destructor method for the GC routines. (HAHAHAH! DIE! DIE! DIE!)
+sub DESTROY {
+ my $self = shift;
+ $self->handler("destroy", "nobody will ever use this");
+ $self->quit();
+ # anything else?
+}
+
+
+# Disconnects this Connection object cleanly from the server.
+# Takes at least 1 arg: the format and args parameters to Event->new().
+sub disconnect {
+ my $self = shift;
+
+ $self->{_connected} = 0;
+ $self->parent->removeconn($self);
+ $self->socket( undef );
+ $self->handler(Net::IRC::Event->new( "disconnect",
+ $self->server,
+ '',
+ @_ ));
+}
+
+
+# Tells IRC.pm if there was an error opening this connection. It's just
+# for sane error passing.
+# Takes 1 optional arg: the new value for $self->{'iserror'}
+sub error {
+ my $self = shift;
+
+ $self->{'iserror'} = $_[0] if @_;
+ return $self->{'iserror'};
+}
+
+# Lets the user set or retrieve a format for a message of any sort.
+# Takes at least 1 arg: the event whose format you're inquiring about
+# (optional) the new format to use for this event
+sub format {
+ my ($self, $ev) = splice @_, 0, 2;
+
+ unless ($ev) {
+ croak "Not enough arguments to format()";
+ }
+
+ if (@_) {
+ $self->{'_format'}->{$ev} = $_[0];
+ } else {
+ return ($self->{'_format'}->{$ev} ||
+ $self->{'_format'}->{'default'});
+ }
+}
+
+# Calls the appropriate handler function for a specified event.
+# Takes 2 args: the name of the event to handle
+# the arguments to the handler function
+sub handler {
+ my ($self, $event) = splice @_, 0, 2;
+
+ unless (defined $event) {
+ croak 'Too few arguments to Connection->handler()';
+ }
+
+ # Get name of event.
+ my $ev;
+ if (ref $event) {
+ $ev = $event->type;
+ } elsif (defined $event) {
+ $ev = $event;
+ $event = Net::IRC::Event->new($event, '', '', '');
+ } else {
+ croak "Not enough arguments to handler()";
+ }
+
+ print STDERR "Trying to handle event '$ev'.\n" if $self->{_debug};
+
+ my $handler = undef;
+ if (exists $self->{_handler}->{$ev}) {
+ $handler = $self->{_handler}->{$ev};
+ } elsif (exists $_udef{$ev}) {
+ $handler = $_udef{$ev};
+ } else {
+ return $self->_default($event, @_);
+ }
+
+ my ($code, $rp) = @{$handler};
+
+ # If we have args left, try to call the handler.
+ if ($rp == 0) { # REPLACE
+ &$code($self, $event, @_);
+ } elsif ($rp == 1) { # BEFORE
+ &$code($self, $event, @_);
+ $self->_default($event, @_);
+ } elsif ($rp == 2) { # AFTER
+ $self->_default($event, @_);
+ &$code($self, $event, @_);
+ } else {
+ confess "Bad parameter passed to handler(): rp=$rp";
+ }
+
+ warn "Handler for '$ev' called.\n" if $self->{_debug};
+
+ return 1;
+}
+
+# Lets a user set hostmasks to discard certain messages from, or (if called
+# with only 1 arg), show a list of currently ignored hostmasks of that type.
+# Takes 2 args: type of ignore (public, msg, ctcp, etc)
+# (optional) [mask(s) to be added to list of specified type]
+sub ignore {
+ my $self = shift;
+
+ unless (@_) {
+ croak "Not enough arguments to ignore()";
+ }
+
+ if (@_ == 1) {
+ if (exists $self->{_ignore}->{$_[0]}) {
+ return @{ $self->{_ignore}->{$_[0]} };
+ } else {
+ return ();
+ }
+ } elsif (@_ > 1) { # code defensively, remember...
+ my $type = shift;
+
+ # I moved this part further down as an Obsessive Efficiency
+ # Initiative. It shouldn't be a problem if I do _parse right...
+ # ... but those are famous last words, eh?
+ unless (grep {$_ eq $type}
+ qw(public msg ctcp notice channel nick other all)) {
+ carp "$type isn't a valid type to ignore()";
+ return;
+ }
+
+ if ( exists $self->{_ignore}->{$type} ) {
+ push @{$self->{_ignore}->{$type}}, @_;
+ } else {
+ $self->{_ignore}->{$type} = [ @_ ];
+ }
+ }
+}
+
+
+# Yet Another Ridiculously Simple Sub. Sends an INFO command.
+# Takes 1 optional arg: the name of the server to query.
+sub info {
+ my $self = shift;
+
+ $self->sl("INFO" . ($_[0] ? " $_[0]" : ""));
+}
+
+
+# Invites someone to an invite-only channel. Whoop.
+# Takes 2 args: the nick of the person to invite
+# the channel to invite them to.
+# I hate the syntax of this command... always seemed like a protocol flaw.
+sub invite {
+ my $self = shift;
+
+ unless (@_ > 1) {
+ croak "Not enough arguments to invite()";
+ }
+
+ $self->sl("INVITE $_[0] $_[1]");
+}
+
+# Checks if a particular nickname is in use.
+# Takes at least 1 arg: nickname(s) to look up.
+sub ison {
+ my $self = shift;
+
+ unless (@_) {
+ croak 'Not enough args to ison().';
+ }
+
+ $self->sl("ISON " . CORE::join(" ", @_));
+}
+
+# Joins a channel on the current server if connected, eh?.
+# Corresponds to /JOIN command.
+# Takes 2 args: name of channel to join
+# optional channel password, for +k channels
+sub join {
+ my $self = shift;
+
+ unless ( $self->connected ) {
+ carp "Can't join() -- not connected to a server";
+ return;
+ }
+
+ unless (@_) {
+ croak "Not enough arguments to join()";
+ }
+
+ return $self->sl("JOIN $_[0]" . ($_[1] ? " $_[1]" : ""));
+
+}
+
+# Takes at least 2 args: the channel to kick the bastard from
+# the nick of the bastard in question
+# (optional) a parting comment to the departing bastard
+sub kick {
+ my $self = shift;
+
+ unless (@_ > 1) {
+ croak "Not enough arguments to kick()";
+ }
+ return $self->sl("KICK $_[0] $_[1]" . ($_[2] ? " :$_[2]" : ""));
+}
+
+# Gets a list of all the servers that are linked to another visible server.
+# Takes 2 optional args: it's a bitch to describe, and I'm too tired right
+# now, so read the RFC.
+sub links {
+ my ($self) = (shift, undef);
+
+ $self->sl("LINKS" . (scalar(@_) ? " " . CORE::join(" ", @_[0,1]) : ""));
+}
+
+
+# Requests a list of channels on the server, or a quick snapshot of the current
+# channel (the server returns channel name, # of users, and topic for each).
+sub list {
+ my $self = shift;
+
+ $self->sl("LIST " . CORE::join(",", @_));
+}
+
+# Sends a request for some server/user stats.
+# Takes 1 optional arg: the name of a server to request the info from.
+sub lusers {
+ my $self = shift;
+
+ $self->sl("LUSERS" . ($_[0] ? " $_[0]" : ""));
+}
+
+# Gets and/or sets the max line length. The value previous to the sub
+# call will be returned.
+# Takes 1 (optional) arg: the maximum line length (in bytes)
+sub maxlinelen {
+ my $self = shift;
+
+ my $ret = $self->{_maxlinelen};
+
+ $self->{_maxlinelen} = shift if @_;
+
+ return $ret;
+}
+
+# Sends an action to the channel/nick you specify. It's truly amazing how
+# many IRCers have no idea that /me's are actually sent via CTCP.
+# Takes 2 args: the channel or nick to bother with your witticism
+# the action to send (e.g., "weed-whacks billn's hand off.")
+sub me {
+ my $self = shift;
+
+ $self->ctcp("ACTION", $_[0], $_[1]);
+}
+
+# Change channel and user modes (this one is easy... the handler is a bitch.)
+# Takes at least 1 arg: the target of the command (channel or nick)
+# (optional) the mode string (i.e., "-boo+i")
+# (optional) operands of the mode string (nicks, hostmasks, etc.)
+sub mode {
+ my $self = shift;
+
+ unless (@_ >= 1) {
+ croak "Not enough arguments to mode()";
+ }
+ $self->sl("MODE $_[0] " . CORE::join(" ", @_[1..$#_]));
+}
+
+# Sends a MOTD command to a server.
+# Takes 1 optional arg: the server to query (defaults to current server)
+sub motd {
+ my $self = shift;
+
+ $self->sl("MOTD" . ($_[0] ? " $_[0]" : ""));
+}
+
+# Requests the list of users for a particular channel (or the entire net, if
+# you're a masochist).
+# Takes 1 or more optional args: name(s) of channel(s) to list the users from.
+sub names {
+ my $self = shift;
+
+ $self->sl("NAMES " . CORE::join(",", @_));
+
+} # Was this the easiest sub in the world, or what?
+
+# Creates and returns a DCC CHAT object, analogous to IRC.pm's newconn().
+# Takes at least 1 arg: An Event object for the DCC CHAT request.
+# OR A list or listref of args to be passed to new(),
+# consisting of:
+# - A boolean value indicating whether or not
+# you're initiating the CHAT connection.
+# - The nick of the chattee
+# - The address to connect to
+# - The port to connect on
+sub new_chat {
+ my $self = shift;
+ my ($init, $nick, $address, $port);
+
+ if (ref($_[0]) =~ /Event/) {
+ # If it's from an Event object, we can't be initiating, right?
+ ($init, undef, undef, undef, $address, $port) = (0, $_[0]->args);
+ $nick = $_[0]->nick;
+
+ } elsif (ref($_[0]) eq "ARRAY") {
+ ($init, $nick, $address, $port) = @{$_[0]};
+ } else {
+ ($init, $nick, $address, $port) = @_;
+ }
+
+ Net::IRC::DCC::CHAT->new($self, $init, $nick, $address, $port);
+}
+
+# Creates and returns a DCC GET object, analogous to IRC.pm's newconn().
+# Takes at least 1 arg: An Event object for the DCC SEND request.
+# OR A list or listref of args to be passed to new(),
+# consisting of:
+# - The nick of the file's sender
+# - The name of the file to receive
+# - The address to connect to
+# - The port to connect on
+# - The size of the incoming file
+# For all of the above, an extra argument should be added at the end:
+# An open filehandle to save the incoming file into,
+# in globref, FileHandle, or IO::* form.
+# If you wish to do a DCC RESUME, specify the offset in bytes that you
+# want to start downloading from as the last argument.
+sub new_get {
+ my $self = shift;
+ my ($nick, $name, $address, $port, $size, $offset, $handle);
+
+ if (ref($_[0]) =~ /Event/) {
+ (undef, undef, $name, $address, $port, $size) = $_[0]->args;
+ $nick = $_[0]->nick;
+ $handle = $_[1] if defined $_[1];
+ } elsif (ref($_[0]) eq "ARRAY") {
+ ($nick, $name, $address, $port, $size) = @{$_[0]};
+ $handle = $_[1] if defined $_[1];
+ } else {
+ ($nick, $name, $address, $port, $size, $handle) = @_;
+ }
+
+ unless (defined $handle and ref $handle and
+ (ref $handle eq "GLOB" or $handle->can('print')))
+ {
+ carp ("Filehandle argument to Connection->new_get() must be ".
+ "a glob reference or object");
+ return; # is this behavior OK?
+ }
+
+ my $dcc = Net::IRC::DCC::GET->new( $self, $nick, $address, $port, $size,
+ $name, $handle, $offset );
+
+ $self->parent->addconn($dcc) if $dcc;
+ return $dcc;
+}
+
+# Creates and returns a DCC SEND object, analogous to IRC.pm's newconn().
+# Takes at least 2 args: The nickname of the person to send to
+# The name of the file to send
+# (optional) The blocksize for the connection (default 1k)
+sub new_send {
+ my $self = shift;
+ my ($nick, $filename, $blocksize);
+
+ if (ref($_[0]) eq "ARRAY") {
+ ($nick, $filename, $blocksize) = @{$_[0]};
+ } else {
+ ($nick, $filename, $blocksize) = @_;
+ }
+
+ Net::IRC::DCC::SEND->new($self, $nick, $filename, $blocksize);
+}
+
+# Selects nick for this object or returns currently set nick.
+# No default; must be set by user.
+# If changed while the object is already connected to a server, it will
+# automatically try to change nicks.
+# Takes 1 arg: the nick. (I bet you could have figured that out...)
+sub nick {
+ my $self = shift;
+
+ if (@_) {
+ $self->{'_nick'} = shift;
+ if ($self->connected) {
+ return $self->sl("NICK " . $self->{'_nick'});
+ }
+ } else {
+ return $self->{'_nick'};
+ }
+}
+
+# Sends a notice to a channel or person.
+# Takes 2 args: the target of the message (channel or nick)
+# the text of the message to send
+# The message will be chunked if it is longer than the _maxlinelen
+# attribute, but it doesn't try to protect against flooding. If you
+# give it too much info, the IRC server will kick you off!
+sub notice {
+ my ($self, $to) = splice @_, 0, 2;
+
+ unless (@_) {
+ croak "Not enough arguments to notice()";
+ }
+
+ my ($buf, $length, $line) = (CORE::join("", @_), $self->{_maxlinelen});
+
+ while(length($buf) > 0) {
+ ($line, $buf) = unpack("a$length a*", $buf);
+ $self->sl("NOTICE $to :$line");
+ }
+}
+
+# Makes you an IRCop, if you supply the right username and password.
+# Takes 2 args: Operator's username
+# Operator's password
+sub oper {
+ my $self = shift;
+
+ unless (@_ > 1) {
+ croak "Not enough arguments to oper()";
+ }
+
+ $self->sl("OPER $_[0] $_[1]");
+}
+
+# This function splits apart a raw server line into its component parts
+# (message, target, message type, CTCP data, etc...) and passes it to the
+# appropriate handler. Takes no args, really.
+sub parse {
+ my ($self) = shift;
+ my ($from, $type, $message, @stuff, $itype, $ev, @lines, $line);
+
+ if (defined ($self->ssl ?
+ $self->socket->read($line, 10240) :
+ $self->socket->recv($line, 10240, 0))
+ and
+ (length($self->{_frag}) + length($line)) > 0) {
+ # grab any remnant from the last go and split into lines
+ $self->{_rx} += length($line);
+ my $chunk = $self->{_frag} . $line;
+ @lines = split /\012/, $chunk;
+
+ # if the last line was incomplete, pop it off the chunk and
+ # stick it back into the frag holder.
+ $self->{_frag} = (substr($chunk, -1) ne "\012" ? pop @lines : '');
+
+ } else {
+ # um, if we can read, i say we should read more than 0
+ # besides, recv isn't returning undef on closed
+ # sockets. getting rid of this connection...
+ $self->disconnect('error', 'Connection reset by peer');
+ return;
+ }
+
+ PARSELOOP: foreach $line (@lines) {
+
+ # Clean the lint filter every 2 weeks...
+ $line =~ s/[\012\015]+$//;
+ next unless $line;
+
+ print STDERR "<<< $line\n" if $self->{_debug};
+
+ $::lastline = $line; #this is so __WARN__ can print the last line received on IRC.
+ # Like the RFC says: "respond as quickly as possible..."
+ if ($line =~ /^PING/) {
+ $ev = (Net::IRC::Event->new( "ping",
+ $self->server,
+ $self->nick,
+ "serverping", # FIXME?
+ substr($line, 5)
+ ));
+
+ # Had to move this up front to avoid a particularly pernicious bug.
+ } elsif ($line =~ /^NOTICE/) {
+ $ev = Net::IRC::Event->new( "snotice",
+ $self->server,
+ '',
+ 'server',
+ (split /:/, $line, 2)[1] );
+
+
+ # Spurious backslashes are for the benefit of cperl-mode.
+ # Assumption: all non-numeric message types begin with a letter
+ } elsif ($line =~ /^:?
+ (?:[][}{\w\\\`^|\-]+? # The nick (valid nickname chars)
+ ! # The nick-username separator
+ .+? # The username
+ \@)? # Umm, duh...
+ \S+ # The hostname
+ \s+ # Space between mask and message type
+ [A-Za-z] # First char of message type
+ [^\s:]+? # The rest of the message type
+ /x) # That ought to do it for now...
+ {
+ $line = substr $line, 1 if $line =~ /^:/;
+
+ # Patch submitted for v.0.72
+ # Fixes problems with IPv6 hostnames.
+ # ($from, $line) = split ":", $line, 2;
+ ($from, $line) = $line =~ /^(?:|)(\S+\s+[^:]+):?(.*)/;
+
+ ($from, $type, @stuff) = split /\s+/, $from;
+ $type = lc $type;
+ # This should be fairly intuitive... (cperl-mode sucks, though)
+
+ # The order of this was changed by AfterDeath because a \x01 in a geco fucked shit up
+ if ($type eq "join" or $type eq "part" or
+ $type eq "mode" or $type eq "topic" or
+ $type eq "kick") {
+ $itype = "channel";
+ } elsif (defined $line and index($line, "\001") == 0) { #originally >=0. Hopefully this will fuck less shit up.
+# print Dumper($from, $type, \@stuff, $line);
+ $itype = "ctcp";
+ unless ($type eq "notice") {
+ $type = (($stuff[0] =~ tr/\#\&//) ? "public" : "msg");
+ }
+ } elsif ($type eq "privmsg") {
+ $itype = $type = (($stuff[0] =~ tr/\#\&//) ? "public" : "msg");
+ } elsif ($type eq "notice") {
+ $itype = "notice";
+ } elsif ($type eq "nick") {
+ $itype = "nick";
+ } else {
+ $itype = "other";
+ }
+
+ # This goes through the list of ignored addresses for this message
+ # type and drops out of the sub if it's from an ignored hostmask.
+
+ study $from;
+ foreach ( $self->ignore($itype), $self->ignore("all") ) {
+ $_ = quotemeta; s/\\\*/.*/g;
+ next PARSELOOP if $from =~ /$_/i;
+ }
+
+ # It used to look a lot worse. Here was the original version...
+ # the optimization above was proposed by Silmaril, for which I am
+ # eternally grateful. (Mine still looks cooler, though. :)
+
+ # return if grep { $_ = join('.*', split(/\\\*/,
+ # quotemeta($_))); /$from/ }
+ # ($self->ignore($type), $self->ignore("all"));
+
+ # Add $line to @stuff for the handlers
+ push @stuff, $line if defined $line;
+
+ # Now ship it off to the appropriate handler and forget about it.
+ if ( $itype eq "ctcp" ) { # it's got CTCP in it!
+ $self->parse_ctcp($type, $from, $stuff[0], $line);
+ next;
+
+ } elsif ($type eq "public" or $type eq "msg" or
+ $type eq "notice" or $type eq "mode" or
+ $type eq "join" or $type eq "part" or
+ $type eq "topic" or $type eq "invite" ) {
+
+ $ev = Net::IRC::Event->new( $type,
+ $from,
+ shift(@stuff),
+ $type,
+ @stuff,
+ );
+ } elsif ($type eq "quit" or $type eq "nick") {
+
+ $ev = Net::IRC::Event->new( $type,
+ $from,
+ $from,
+ $type,
+ @stuff,
+ );
+ } elsif ($type eq "kick") {
+
+ $ev = Net::IRC::Event->new( $type,
+ $from,
+ $stuff[1],
+ $type,
+ @stuff[0,2..$#stuff],
+ );
+
+ } elsif ($type eq "kill") {
+ $ev = Net::IRC::Event->new($type,
+ $from,
+ '',
+ $type,
+ $line); # Ahh, what the hell.
+ } elsif ($type eq "wallops") {
+ $ev = Net::IRC::Event->new($type,
+ $from,
+ '',
+ $type,
+ $line);
+ } elsif ($type eq "account") { #these next 3 event hooks added by AfterDeath
+ $ev = Net::IRC::Event->new($type,
+ $from,
+ '',
+ $type,
+ @stuff);
+ } elsif ($type eq "cap") {
+ $ev = Net::IRC::Event->new($type,
+ $from,
+ '',
+ $type,
+ @stuff);
+ } elsif ($type eq "pong") {
+ $ev = Net::IRC::Event->new($type,
+ $from,
+ $self->{nick},
+ 'server',
+ $stuff[1]);
+ } else {
+ carp "Unknown event type: $type";
+ }
+ }
+ elsif ($line =~ /^:? # Here's Ye Olde Numeric Handler!
+ \S+? # the servername (can't assume RFC hostname)
+ \s+? # Some spaces here...
+ \d+? # The actual number
+ \b/x # Some other crap, whatever...
+ ) {
+ $ev = $self->parse_num($line);
+
+ } elsif ($line =~ /^:(\w+) MODE \1 /) {
+ $ev = Net::IRC::Event->new( 'umode',
+ $self->server,
+ $self->nick,
+ 'server',
+ substr($line, index($line, ':', 1) + 1));
+
+ } elsif ($line =~ /^:? # Here's Ye Olde Server Notice handler!
+ .+? # the servername (can't assume RFC hostname)
+ \s+? # Some spaces here...
+ NOTICE # The server notice
+ \b/x # Some other crap, whatever...
+ ) {
+ $ev = Net::IRC::Event->new( 'snotice',
+ $self->server,
+ '',
+ 'server',
+ (split /\s+/, $line, 3)[2] );
+
+
+ } elsif ($line =~ /^ERROR/) {
+ if ($line =~ /^ERROR :Closing [Ll]ink/) { # is this compatible?
+
+ $ev = 'done';
+ $self->disconnect( 'error', ($line =~ /(.*)/) );
+
+ } else {
+ $ev = Net::IRC::Event->new( "error",
+ $self->server,
+ '',
+ 'error',
+ (split /:/, $line, 2)[1]);
+ }
+ } elsif ($line =~ /^Closing [Ll]ink/) {
+ $ev = 'done';
+ $self->disconnect( 'error', ($line =~ /(.*)/) );
+
+ }
+
+ if ($ev) {
+
+ # We need to be able to fall through if the handler has
+ # already been called (i.e., from within disconnect()).
+
+ $self->handler($ev) unless $ev eq 'done';
+
+ } else {
+ # If it gets down to here, it's some exception I forgot about.
+ carp "Funky parse case: $line\n";
+ }
+ }
+}
+
+# The backend that parse() sends CTCP requests off to. Pay no attention
+# to the camel behind the curtain.
+# Takes 4 arguments: the type of message
+# who it's from
+# the first bit of stuff
+# the line from the server.
+sub parse_ctcp {
+ my ($self, $type, $from, $stuff, $line) = @_;
+
+ my ($one, $two);
+ my ($odd, @foo) = (&dequote($line));
+
+ while (($one, $two) = (splice @foo, 0, 2)) {
+
+ ($one, $two) = ($two, $one) if $odd;
+
+ my ($ctype) = $one =~ /^(\w+)\b/;
+ my $prefix = undef;
+ if ($type eq 'notice') {
+ $prefix = 'cr';
+ } elsif ($type eq 'public' or
+ $type eq 'msg' ) {
+ $prefix = 'c';
+ } else {
+ carp "Unknown CTCP type: $type";
+ return;
+ }
+
+ if ($prefix) {
+ my $handler = $prefix . lc $ctype; # unit. value prob with $ctype
+
+ $one =~ s/^$ctype //i; # strip the CTCP type off the args
+ $self->handler(Net::IRC::Event->new( $handler, $from, $stuff,
+ $handler, $one ));
+ }
+
+ $self->handler(Net::IRC::Event->new($type, $from, $stuff, $type, $two))
+ if $two;
+ }
+ return 1;
+}
+
+# Does special-case parsing for numeric events. Separate from the rest of
+# parse() for clarity reasons (I can hear Tkil gasping in shock now. :-).
+# Takes 1 arg: the raw server line
+sub parse_num {
+ my ($self, $line) = @_;
+
+ # Figlet protection? This seems to be a bit closer to the RFC than
+ # the original version, which doesn't seem to handle :trailers quite
+ # correctly.
+
+ my ($from, $type, $stuff) = split(/\s+/, $line, 3);
+ my ($blip, $space, $other, @stuff);
+ while ($stuff) {
+ ($blip, $space, $other) = split(/(\s+)/, $stuff, 2);
+ $space = "" unless $space;
+ $other = "" unless $other; # Thanks to jack velte...
+ if ($blip =~ /^:/) {
+ push @stuff, $blip . $space . $other;
+ last;
+ } else {
+ push @stuff, $blip;
+ $stuff = $other;
+ }
+ }
+
+ $from = substr $from, 1 if $from =~ /^:/;
+
+ return Net::IRC::Event->new( $type,
+ $from,
+ '',
+ 'server',
+ @stuff );
+}
+
+# Helps you flee those hard-to-stand channels.
+# Takes at least one arg: name(s) of channel(s) to leave.
+sub part {
+ my $self = shift;
+
+ unless (@_) {
+ croak "No arguments provided to part()";
+ }
+ $self->sl("PART " . CORE::join(",", @_)); # "A must!"
+}
+
+
+# Tells what's on the other end of a connection. Returns a 2-element list
+# consisting of the name on the other end and the type of connection.
+# Takes no args.
+sub peer {
+ my $self = shift;
+
+ return ($self->server(), "IRC connection");
+}
+
+
+# Prints a message to the defined error filehandle(s).
+# No further description should be necessary.
+sub printerr {
+ shift;
+ print STDERR @_, "\n";
+}
+
+# Prints a message to the defined output filehandle(s).
+sub print {
+ shift;
+ print STDOUT @_, "\n";
+}
+
+# Sends a message to a channel or person.
+# Takes 2 args: the target of the message (channel or nick)
+# the text of the message to send
+# Don't use this for sending CTCPs... that's what the ctcp() function is for.
+# The message will be chunked if it is longer than the _maxlinelen
+# attribute, but it doesn't try to protect against flooding. If you
+# give it too much info, the IRC server will kick you off!
+sub privmsg {
+ my ($self, $to) = splice @_, 0, 2;
+
+ unless (@_) {
+ croak 'Not enough arguments to privmsg()';
+ }
+
+ my $buf = CORE::join '', @_;
+ my $length = $self->{_maxlinelen} - 80 - length($to);
+ my $line;
+
+ if (ref($to) =~ /^(GLOB|IO::Socket)/) {
+ while(length($buf) > 0) {
+ ($line, $buf) = unpack("a$length a*", $buf);
+ send($to, $line . "\012", 0);
+ }
+ } else {
+ while(length($buf) > 0) {
+ ($line, $buf) = unpack("a$length a*", $buf);
+ if (ref $to eq 'ARRAY') {
+ $self->sl("PRIVMSG ", CORE::join(',', @$to), " :$line");
+ } else {
+ $self->sl("PRIVMSG $to :$line");
+ }
+ }
+ }
+}
+
+
+# Closes connection to IRC server. (Corresponding function for /QUIT)
+# Takes 1 optional arg: parting message, defaults to "Leaving" by custom.
+sub quit {
+ my $self = shift;
+
+ # Do any user-defined stuff before leaving
+ $self->handler("leaving");
+
+ unless ( $self->connected ) { return (1) }
+
+ # Why bother checking for sl() errors now, after all? :)
+ # We just send the QUIT command and leave. The server will respond with
+ # a "Closing link" message, and parse() will catch it, close the
+ # connection, and throw a "disconnect" event. Neat, huh? :-)
+
+ $self->sl("QUIT :" . (defined $_[0] ? $_[0] : "Leaving"));
+
+ # since the quit sends a line to the server, we need to flush the
+ # output queue to make sure it gets there so the disconnect
+ $self->parent->flush_output_queue();
+
+ return 1;
+}
+
+# As per the RFC, ask the server to "re-read and process its configuration
+# file." Your server may or may not take additional arguments. Generally
+# requires IRCop status.
+sub rehash {
+ my $self = shift;
+ $self->sl("REHASH" . CORE::join(" ", @_));
+}
+
+
+# As per the RFC, "force a server restart itself." (Love that RFC.)
+# Takes no arguments. If it succeeds, you will likely be disconnected,
+# but I assume you already knew that. This sub is too simple...
+sub restart {
+ my $self = shift;
+ $self->sl("RESTART");
+}
+
+# Schedules an event to be executed after some length of time.
+# Takes at least 2 args: the number of seconds to wait until it's executed
+# a coderef to execute when time's up
+# Any extra args are passed as arguments to the user's coderef.
+sub schedule {
+ my $self = shift;
+ my $time = shift;
+ my $coderef = shift;
+
+ unless($coderef) {
+ croak 'Not enough arguments to Connection->schedule()';
+ }
+ unless(ref($coderef) eq 'CODE') {
+ croak 'Second argument to schedule() isn\'t a coderef';
+ }
+
+ $time += time;
+ $self->parent->enqueue_scheduled_event($time, $coderef, $self, @_);
+}
+
+sub schedule_output_event {
+ my $self = shift;
+ my $time = shift;
+ my $coderef = shift;
+
+ unless($coderef) {
+ croak 'Not enough arguments to Connection->schedule()';
+ }
+ unless(ref($coderef) eq 'CODE') {
+ croak 'Second argument to schedule() isn\'t a coderef';
+ }
+
+ $time += time;
+ $self->parent->enqueue_output_event($time, $coderef, $self, @_);
+}
+
+# Lets J. Random IRCop connect one IRC server to another. How uninteresting.
+# Takes at least 1 arg: the name of the server to connect your server with
+# (optional) the port to connect them on (default 6667)
+# (optional) the server to connect to arg #1. Used mainly by
+# servers to communicate with each other.
+sub sconnect {
+ my $self = shift;
+
+ unless (@_) {
+ croak "Not enough arguments to sconnect()";
+ }
+ $self->sl("CONNECT " . CORE::join(" ", @_));
+}
+
+# Sets/changes the IRC server which this instance should connect to.
+# Takes 1 arg: the name of the server (see below for possible syntaxes)
+# ((syntaxen? syntaxi? syntaces?))
+sub server {
+ my ($self) = shift;
+
+ if (@_) {
+ # cases like "irc.server.com:6668"
+ if (index($_[0], ':') > 0) {
+ my ($serv, $port) = split /:/, $_[0];
+ if ($port =~ /\D/) {
+ carp "$port is not a valid port number in server()";
+ return;
+ }
+ $self->{_server} = $serv;
+ $self->port($port);
+
+ # cases like ":6668" (buried treasure!)
+ } elsif (index($_[0], ':') == 0 and $_[0] =~ /^:(\d+)/) {
+ $self->port($1);
+
+ # cases like "irc.server.com"
+ } else {
+ $self->{_server} = shift;
+ }
+ return (1);
+
+ } else {
+ return $self->{_server};
+ }
+}
+
+
+# sends a raw IRC line to the server, possibly with pacing
+sub sl {
+ my $self = shift;
+ my $line = CORE::join '', @_;
+
+ unless (@_) {
+ croak "Not enough arguments to sl()";
+ }
+
+ if (! $self->pacing) {
+ return $self->sl_real($line);
+ }
+
+ # calculate how long to wait before sending this line
+ my $time = time;
+ if ($time - $self->{_lastsl} > $self->pacing) {
+ $self->{_lastsl} = $time;
+ } else {
+ $self->{_lastsl} += $self->pacing;
+ }
+ my $seconds = $self->{_lastsl} - $time;
+
+ ### DEBUG DEBUG DEBUG
+ if ($self->{_debug}) {
+ print "S-> $seconds $line\n";
+ }
+
+ $self->schedule_output_event($seconds, \&sl_real, $line);
+}
+
+
+# Sends a raw IRC line to the server.
+# Corresponds to the internal sirc function of the same name.
+# Takes 1 arg: string to send to server. (duh. :)
+sub sl_real {
+ my $self = shift;
+ my $line = shift;
+
+ unless ($line) {
+ croak "Not enough arguments to sl_real()";
+ }
+
+ ### DEBUG DEBUG DEBUG
+ if ($self->{_debug}) {
+ print ">>> $line\n";
+ }
+
+ # RFC compliance can be kinda nice...
+ my $rv = $self->ssl ?
+ $self->socket->print("$line\015\012") :
+ $self->socket->send("$line\015\012", 0);
+ unless ($rv) {
+ $self->handler("sockerror");
+ return;
+ }
+ $self->{_tx} += (length($line) + 2);
+ return $rv;
+}
+
+# Tells any server that you're an oper on to disconnect from the IRC network.
+# Takes at least 1 arg: the name of the server to disconnect
+# (optional) a comment about why it was disconnected
+sub squit {
+ my $self = shift;
+
+ unless (@_) {
+ croak "Not enough arguments to squit()";
+ }
+
+ $self->sl("SQUIT $_[0]" . ($_[1] ? " :$_[1]" : ""));
+}
+
+# Gets various server statistics for the specified host.
+# Takes at least 2 arg: the type of stats to request [chiklmouy]
+# (optional) the server to request from (default is current server)
+sub stats {
+ my $self = shift;
+
+ unless (@_) {
+ croak "Not enough arguments passed to stats()";
+ }
+
+ $self->sl("STATS $_[0]" . ($_[1] ? " $_[1]" : ""));
+}
+
+# If anyone still has SUMMON enabled, this will implement it for you.
+# If not, well...heh. Sorry. First arg mandatory: user to summon.
+# Second arg optional: a server name.
+sub summon {
+ my $self = shift;
+
+ unless (@_) {
+ croak "Not enough arguments passed to summon()";
+ }
+
+ $self->sl("SUMMON $_[0]" . ($_[1] ? " $_[1]" : ""));
+}
+
+# Requests timestamp from specified server. Easy enough, right?
+# Takes 1 optional arg: a server name/mask to query
+# renamed to not collide with things... -- aburke
+sub timestamp {
+ my ($self, $serv) = (shift, undef);
+
+ $self->sl("TIME" . ($_[0] ? " $_[0]" : ""));
+}
+
+# Sends request for current topic, or changes it to something else lame.
+# Takes at least 1 arg: the channel whose topic you want to screw around with
+# (optional) the new topic you want to impress everyone with
+sub topic {
+ my $self = shift;
+
+ unless (@_) {
+ croak "Not enough arguments to topic()";
+ }
+
+ # Can you tell I've been reading the Nethack source too much? :)
+ $self->sl("TOPIC $_[0]" . ($_[1] ? " :$_[1]" : ""));
+}
+
+# Sends a trace request to the server. Whoop.
+# Take 1 optional arg: the server or nickname to trace.
+sub trace {
+ my $self = shift;
+
+ $self->sl("TRACE" . ($_[0] ? " $_[0]" : ""));
+}
+
+# This method submitted by Dave Schmitt <dschmi1@umbc.edu>. Thanks, Dave!
+sub unignore {
+ my $self = shift;
+
+ croak "Not enough arguments to unignore()" unless @_;
+
+ if (@_ == 1) {
+ if (exists $self->{_ignore}->{$_[0]}) {
+ return @{ $self->{_ignore}->{$_[0]} };
+ } else {
+ return ();
+ }
+ } elsif (@_ > 1) { # code defensively, remember...
+ my $type = shift;
+
+ # I moved this part further down as an Obsessive Efficiency
+ # Initiative. It shouldn't be a problem if I do _parse right...
+ # ... but those are famous last words, eh?
+ unless (grep {$_ eq $type}
+ qw(public msg ctcp notice channel nick other all)) {
+ carp "$type isn't a valid type to unignore()";
+ return;
+ }
+
+ if ( exists $self->{_ignore}->{$type} ) {
+ # removes all specifed entries ala _Perl_Cookbook_ recipe 4.7
+ my @temp = @{$self->{_ignore}->{$type}};
+ @{$self->{_ignore}->{$type}}= ();
+ my %seen = ();
+ foreach my $item (@_) { $seen{$item}=1 }
+ foreach my $item (@temp) {
+ push(@{$self->{_ignore}->{$type}}, $item)
+ unless ($seen{$item});
+ }
+ } else {
+ carp "no ignore entry for $type to remove";
+ }
+ }
+}
+
+
+# Requests userhost info from the server.
+# Takes at least 1 arg: nickname(s) to look up.
+sub userhost {
+ my $self = shift;
+
+ unless (@_) {
+ croak 'Not enough args to userhost().';
+ }
+
+ $self->sl("USERHOST " . CORE::join (" ", @_));
+}
+
+# Sends a users request to the server, which may or may not listen to you.
+# Take 1 optional arg: the server to query.
+sub users {
+ my $self = shift;
+
+ $self->sl("USERS" . ($_[0] ? " $_[0]" : ""));
+}
+
+# Asks the IRC server what version and revision of ircd it's running. Whoop.
+# Takes 1 optional arg: the server name/glob. (default is current server)
+sub version {
+ my $self = shift;
+
+ $self->sl("VERSION" . ($_[0] ? " $_[0]" : ""));
+}
+
+# Sends a message to all opers on the network. Hypothetically.
+# Takes 1 arg: the text to send.
+sub wallops {
+ my $self = shift;
+
+ unless ($_[0]) {
+ croak 'No arguments passed to wallops()';
+ }
+
+ $self->sl("WALLOPS :" . CORE::join("", @_));
+}
+
+# Asks the server about stuff, you know. Whatever. Pass the Fritos, dude.
+# Takes 2 optional args: the bit of stuff to ask about
+# an "o" (nobody ever uses this...)
+sub who {
+ my $self = shift;
+
+ # Obfuscation!
+ $self->sl("WHO" . (@_ ? " @_" : ""));
+}
+
+# If you've gotten this far, you probably already know what this does.
+# Takes at least 1 arg: nickmasks or channels to /whois
+sub whois {
+ my $self = shift;
+
+ unless (@_) {
+ croak "Not enough arguments to whois()";
+ }
+ return $self->sl("WHOIS " . CORE::join(",", @_));
+}
+
+# Same as above, in the past tense.
+# Takes at least 1 arg: nick to do the /whowas on
+# (optional) max number of hits to display
+# (optional) server or servermask to query
+sub whowas {
+ my $self = shift;
+
+ unless (@_) {
+ croak "Not enough arguments to whowas()";
+ }
+ return $self->sl("WHOWAS $_[0]" . ($_[1] ? " $_[1]" : "") .
+ (($_[1] && $_[2]) ? " $_[2]" : ""));
+}
+
+# This sub executes the default action for an event with no user-defined
+# handlers. It's all in one sub so that we don't have to make a bunch of
+# separate anonymous subs stuffed in a hash.
+sub _default {
+ my ($self, $event) = @_;
+ my $verbose = $self->verbose;
+
+ # Users should only see this if the programmer (me) fucked up.
+ unless ($event) {
+ croak "You EEEEEDIOT!!! Not enough args to _default()!";
+ }
+
+ # Reply to PING from server as quickly as possible.
+ if ($event->type eq "ping") {
+ $self->sl("PONG " . (CORE::join ' ', $event->args));
+
+ } elsif ($event->type eq "disconnect") {
+
+ # I violate OO tenets. (It's consensual, of course.)
+ unless (keys %{$self->parent->{_connhash}} > 0) {
+ die "No active connections left, exiting...\n";
+ }
+ }
+
+ return 1;
+}
+
+1;
+
+
+__END__
+
+=head1 NAME
+
+Net::IRC::Connection - Object-oriented interface to a single IRC connection
+
+=head1 SYNOPSIS
+
+Hard hat area: This section under construction.
+
+=head1 DESCRIPTION
+
+This documentation is a subset of the main Net::IRC documentation. If
+you haven't already, please "perldoc Net::IRC" before continuing.
+
+Net::IRC::Connection defines a class whose instances are individual
+connections to a single IRC server. Several Net::IRC::Connection objects may
+be handled simultaneously by one Net::IRC object.
+
+=head1 METHOD DESCRIPTIONS
+
+This section is under construction, but hopefully will be finally written up
+by the next release. Please see the C<irctest> script and the source for
+details about this module.
+
+=head1 AUTHORS
+
+Conceived and initially developed by Greg Bacon E<lt>gbacon@adtran.comE<gt> and
+Dennis Taylor E<lt>dennis@funkplanet.comE<gt>.
+
+Ideas and large amounts of code donated by Nat "King" Torkington E<lt>gnat@frii.comE<gt>.
+
+Currently being hacked on, hacked up, and worked over by the members of the
+Net::IRC developers mailing list. For details, see
+http://www.execpc.com/~corbeau/irc/list.html .
+
+=head1 URL
+
+Up-to-date source and information about the Net::IRC project can be found at
+http://netirc.betterbox.net/ .
+
+=head1 SEE ALSO
+
+=over
+
+=item *
+
+perl(1).
+
+=item *
+
+RFC 1459: The Internet Relay Chat Protocol
+
+=item *
+
+http://www.irchelp.org/, home of fine IRC resources.
+
+=back
+
+=cut
+
diff --git a/lib/Net/IRC/DCC.pm b/lib/Net/IRC/DCC.pm
new file mode 100644
index 0000000..eccbba3
--- /dev/null
+++ b/lib/Net/IRC/DCC.pm
@@ -0,0 +1,808 @@
+#####################################################################
+# #
+# Net::IRC -- Object-oriented Perl interface to an IRC server #
+# #
+# DCC.pm: An object for Direct Client-to-Client connections. #
+# #
+# Copyright (c) 1997 Greg Bacon & Dennis Taylor. #
+# All rights reserved. #
+# #
+# This module is free software; you can redistribute or #
+# modify it under the terms of Perl's Artistic License. #
+# #
+#####################################################################
+# $Id: DCC.pm,v 1.1.1.1 2002/11/14 17:32:15 jmuhlich Exp $
+
+package Net::IRC::DCC;
+
+use strict;
+
+
+
+# --- #perl was here! ---
+#
+# The comments scattered throughout this module are excerpts from a
+# log saved from one particularly surreal night on #perl. Ahh, the
+# trials of being young, single, and drunk...
+#
+# ---------------------
+# \merlyn has offered the shower to a randon guy he met in a bar.
+# fimmtiu: Shower?
+# \petey raises an eyebrow at \merlyn
+# \merlyn: but he seems like a nice trucker guy...
+# archon: you offered to shower with a random guy?
+
+
+# Methods that can be shared between the various DCC classes.
+package Net::IRC::DCC::Connection;
+
+use Carp;
+use Socket; # need inet_ntoa...
+use strict;
+
+sub fixaddr {
+ my ($address) = @_;
+
+ chomp $address; # just in case, sigh.
+ if ($address =~ /^\d+$/) {
+ return inet_ntoa(pack "N", $address);
+ } elsif ($address =~ /^[12]?\d{1,2}\.[12]?\d{1,2}\.[12]?\d{1,2}\.[12]?\d{1,2}$/) {
+ return $address;
+ } elsif ($address =~ tr/a-zA-Z//) { # Whee! Obfuscation!
+ return inet_ntoa(((gethostbyname($address))[4])[0]);
+ } else {
+ return;
+ }
+}
+
+sub bytes_in {
+ return shift->{_bin};
+}
+
+sub bytes_out {
+ return shift->{_bout};
+}
+
+sub nick {
+ return shift->{_nick};
+}
+
+sub socket {
+ return shift->{_socket};
+}
+
+sub time {
+ return time - shift->{_time};
+}
+
+sub debug {
+ return shift->{_debug};
+}
+
+# Changes here 1998-04-01 by MJD
+# Optional third argument `$block'.
+# If true, don't break the input into lines... just process it in blocks.
+sub _getline {
+ my ($self, $sock, $block) = @_;
+ my ($input, $line);
+ my $frag = $self->{_frag};
+
+ if (defined $sock->recv($input, 10240)) {
+ $frag .= $input;
+ if (length($frag) > 0) {
+
+ warn "Got ". length($frag) ." bytes from $sock\n"
+ if $self->{_debug};
+
+ if ($block) { # Block mode (GET)
+ return $input;
+
+ } else { # Line mode (CHAT)
+ # We're returning \n's 'cause DCC's need 'em
+ my @lines = split /\012/, $frag, -1;
+ $lines[-1] .= "\012";
+ $self->{_frag} = ($frag !~ /\012$/) ? pop @lines : '';
+ return (@lines);
+ }
+ }
+ else {
+ # um, if we can read, i say we should read more than 0
+ # besides, recv isn't returning undef on closed
+ # sockets. getting rid of this connection...
+
+ warn "recv() received 0 bytes in _getline, closing connection.\n"
+ if $self->{_debug};
+
+ $self->{_parent}->handler(Net::IRC::Event->new('dcc_close',
+ $self->{_nick},
+ $self->{_socket},
+ $self->{_type}));
+ $self->{_parent}->parent->removefh($sock);
+ $self->{_socket}->close;
+ $self->{_fh}->close if $self->{_fh};
+ return;
+ }
+ } else {
+ # Error, lets scrap this connection
+
+ warn "recv() returned undef, socket error in _getline()\n"
+ if $self->{_debug};
+
+ $self->{_parent}->handler(Net::IRC::Event->new('dcc_close',
+ $self->{_nick},
+ $self->{_socket},
+ $self->{_type}));
+ $self->{_parent}->parent->removefh($sock);
+ $self->{_socket}->close;
+ $self->{_fh}->close if $self->{_fh};
+ return;
+ }
+}
+
+sub DESTROY {
+ my $self = shift;
+
+ # Only do the Disconnection Dance of Death if the socket is still
+ # live. Duplicate dcc_close events would be a Bad Thing.
+
+ if ($self->{_socket}->opened) {
+ $self->{_parent}->handler(Net::IRC::Event->new('dcc_close',
+ $self->{_nick},
+ $self->{_socket},
+ $self->{_type}));
+ $self->{_socket}->close;
+ close $self->{_fh} if $self->{_fh};
+ $self->{_parent}->{_parent}->parent->removeconn($self);
+ }
+
+}
+
+sub peer {
+ return ( $_[0]->{_nick}, "DCC " . $_[0]->{_type} );
+}
+
+# -- #perl was here! --
+# orev: hehe...
+# Silmaril: to, not with.
+# archon: heheh
+# tmtowtdi: \merlyn will be hacked to death by a psycho
+# archon: yeah, but with is much more amusing
+
+
+# Connection handling GETs
+package Net::IRC::DCC::GET;
+
+use IO::Socket;
+use Carp;
+use strict;
+
+@Net::IRC::DCC::GET::ISA = qw(Net::IRC::DCC::Connection);
+
+sub new {
+
+ my ($class, $container, $nick, $address,
+ $port, $size, $filename, $handle, $offset) = @_;
+ my ($sock, $fh);
+
+ # get the address into a dotted quad
+ $address = &Net::IRC::DCC::Connection::fixaddr($address);
+ return if $port < 1024 or not defined $address or $size < 1;
+
+ $fh = defined $handle ? $handle : IO::File->new(">$filename");
+
+ unless(defined $fh) {
+ carp "Can't open $filename for writing: $!";
+ $sock = new IO::Socket::INET( Proto => "tcp",
+ PeerAddr => "$address:$port" ) and
+ $sock->close();
+ return;
+ }
+
+ binmode $fh; # I love this next line. :-)
+ ref $fh eq 'GLOB' ? select((select($fh), $|++)[0]) : $fh->autoflush(1);
+
+ $sock = new IO::Socket::INET( Proto => "tcp",
+ PeerAddr => "$address:$port" );
+
+ if (defined $sock) {
+ $container->handler(Net::IRC::Event->new('dcc_open',
+ $nick,
+ $sock,
+ 'get',
+ 'get', $sock));
+
+ } else {
+ carp "Can't connect to $address: $!";
+ close $fh;
+ return;
+ }
+
+ $sock->autoflush(1);
+
+ my $self = {
+ _bin => defined $offset ? $offset : 0, # bytes recieved so far
+ _bout => 0, # Bytes we've sent
+ _connected => 1,
+ _debug => $container->debug,
+ _fh => $fh, # FileHandle we will be writing to.
+ _filename => $filename,
+ _frag => '',
+ _nick => $nick, # Nick of person on other end
+ _parent => $container,
+ _size => $size, # Expected size of file
+ _socket => $sock, # Socket we're reading from
+ _time => time,
+ _type => 'GET',
+ };
+
+ bless $self, $class;
+
+ return $self;
+}
+
+# -- #perl was here! --
+# \merlyn: we were both ogling a bartender named arley
+# \merlyn: I mean carle
+# \merlyn: carly
+# Silmaril: man merlyn
+# Silmaril: you should have offered HER the shower.
+# \petey: all three of them?
+
+sub parse {
+ my ($self) = shift;
+
+ my $line = $self->_getline($_[0], 'BLOCKS');
+
+ next unless defined $line;
+ unless(print {$self->{_fh}} $line) {
+ carp ("Error writing to " . $self->{_filename} . ": $!");
+ close $self->{_fh};
+ $self->{_parent}->parent->removeconn($self);
+ $self->{_parent}->handler(Net::IRC::Event->new('dcc_close',
+ $self->{_nick},
+ $self->{_socket},
+ $self->{_type}));
+ $self->{_socket}->close;
+ return;
+ }
+
+ $self->{_bin} += length($line);
+
+
+ # confirm the packet we've just recieved
+ unless ( $self->{_socket}->send( pack("N", $self->{_bin}) ) ) {
+ carp "Error writing to DCC GET socket: $!";
+ close $self->{_fh};
+ $self->{_parent}->parent->removeconn($self);
+ $self->{_parent}->handler(Net::IRC::Event->new('dcc_close',
+ $self->{_nick},
+ $self->{_socket},
+ $self->{_type}));
+ $self->{_socket}->close;
+ return;
+ }
+
+ $self->{_bout} += 4;
+
+ # The file is done.
+ # If we close the socket, the select loop gets screwy because
+ # it won't remove its reference to the socket.
+ if ( $self->{_size} and $self->{_size} <= $self->{_bin} ) {
+ close $self->{_fh};
+ $self->{_parent}->parent->removeconn($self);
+ $self->{_parent}->handler(Net::IRC::Event->new('dcc_close',
+ $self->{_nick},
+ $self->{_socket},
+ $self->{_type}));
+ $self->{_socket}->close;
+ return;
+ }
+
+ $self->{_parent}->handler(Net::IRC::Event->new('dcc_update',
+ $self->{_nick},
+ $self,
+ $self->{_type},
+ $self ));
+}
+
+sub filename {
+ return shift->{_filename};
+}
+
+sub size {
+ return shift->{_size};
+}
+
+sub close {
+ my ($self, $sock) = @_;
+ $self->{_fh}->close;
+ $self->{_parent}->parent->removeconn($self);
+ $self->{_parent}->handler(Net::IRC::Event->new('dcc_close',
+ $self->{_nick},
+ $self->{_socket},
+ $self->{_type}));
+ $self->{_socket}->close;
+ return;
+}
+
+# -- #perl was here! --
+# \merlyn: I can't type... she created a numbner of very good drinks
+# \merlyn: She's still at work
+# \petey resists mentioning that there's "No manual entry
+# for merlyn."
+# Silmaril: Haven't you ever seen swingers?
+# \merlyn: she's off tomorrow... will meet me at the bar at 9:30
+# Silmaril: AWWWWwwww yeeeaAAHH.
+# archon: waka chica waka chica
+
+
+# Connection handling SENDs
+package Net::IRC::DCC::SEND;
+@Net::IRC::DCC::SEND::ISA = qw(Net::IRC::DCC::Connection);
+
+use IO::File;
+use IO::Socket;
+use Carp;
+use strict;
+
+sub new {
+
+ my ($class, $container, $nick, $filename, $blocksize) = @_;
+ my ($size, $port, $fh, $sock, $select);
+
+ $blocksize ||= 1024;
+
+ # Shell-safe DCC filename stuff. Trying to prank-proof this
+ # module is rather difficult.
+ $filename =~ tr/a-zA-Z.+0-9=&()[]%\-\\\/:,/_/c;
+ $fh = new IO::File $filename;
+
+ unless (defined $fh) {
+ carp "Couldn't open $filename for reading: $!";
+ return;
+ }
+
+ binmode $fh;
+ $fh->seek(0, SEEK_END);
+ $size = $fh->tell;
+ $fh->seek(0, SEEK_SET);
+
+ $sock = new IO::Socket::INET( Proto => "tcp",
+ Listen => 1);
+
+ unless (defined $sock) {
+ carp "Couldn't open DCC SEND socket: $!";
+ $fh->close;
+ return;
+ }
+
+ $container->ctcp('DCC SEND', $nick, $filename,
+ unpack("N",inet_aton($container->hostname())),
+ $sock->sockport(), $size);
+
+ $sock->autoflush(1);
+
+ my $self = {
+ _bin => 0, # Bytes we've recieved thus far
+ _blocksize => $blocksize,
+ _bout => 0, # Bytes we've sent
+ _debug => $container->debug,
+ _fh => $fh, # FileHandle we will be reading from.
+ _filename => $filename,
+ _frag => '',
+ _nick => $nick,
+ _parent => $container,
+ _size => $size, # Size of file
+ _socket => $sock, # Socket we're writing to
+ _time => 0, # This gets set by Accept->parse()
+ _type => 'SEND',
+ };
+
+ bless $self, $class;
+
+ $sock = Net::IRC::DCC::Accept->new($sock, $self);
+
+ unless (defined $sock) {
+ carp "Error in accept: $!";
+ $fh->close;
+ return;
+ }
+
+ return $self;
+}
+
+# -- #perl was here! --
+# fimmtiu: So a total stranger is using your shower?
+# \merlyn: yes... a total stranger is using my hotel shower
+# Stupid coulda sworn \merlyn was married...
+# \petey: and you have a date.
+# fimmtiu: merlyn isn't married.
+# \petey: not a bad combo......
+# \merlyn: perhaps a adate
+# \merlyn: not maerried
+# \merlyn: not even sober. --)
+
+sub parse {
+ my ($self, $sock) = @_;
+ my $size = ($self->_getline($sock, 1))[0];
+ my $buf;
+
+ # i don't know how useful this is, but let's stay consistent
+ $self->{_bin} += 4;
+
+ unless (defined $size) {
+ # Dang! The other end unexpectedly canceled.
+ carp (($self->peer)[1] . " connection to " .
+ ($self->peer)[0] . " lost");
+ $self->{_fh}->close;
+ $self->{_parent}->parent->removefh($sock);
+ $self->{_parent}->handler(Net::IRC::Event->new('dcc_close',
+ $self->{_nick},
+ $self->{_socket},
+ $self->{_type}));
+ $self->{_socket}->close;
+ return;
+ }
+
+ $size = unpack("N", $size);
+
+ if ($size >= $self->{_size}) {
+
+ if ($self->{_debug}) {
+ warn "Other end acknowledged entire file ($size >= ",
+ $self->{_size}, ")";
+ }
+ # they've acknowledged the whole file, we outtie
+ $self->{_fh}->close;
+ $self->{_parent}->parent->removeconn($self);
+ $self->{_parent}->handler(Net::IRC::Event->new('dcc_close',
+ $self->{_nick},
+ $self->{_socket},
+ $self->{_type}));
+ $self->{_socket}->close;
+ return;
+ }
+
+ # we're still waiting for acknowledgement,
+ # better not send any more
+ return if $size < $self->{_bout};
+
+ unless (defined $self->{_fh}->read($buf,$self->{_blocksize})) {
+
+ if ($self->{_debug}) {
+ warn "Failed to read from source file in DCC SEND!";
+ }
+ $self->{_fh}->close;
+ $self->{_parent}->parent->removeconn($self);
+ $self->{_parent}->handler(Net::IRC::Event->new('dcc_close',
+ $self->{_nick},
+ $self->{_socket},
+ $self->{_type}));
+ $self->{_socket}->close;
+ return;
+ }
+
+ unless($self->{_socket}->send($buf)) {
+
+ if ($self->{_debug}) {
+ warn "send() failed horribly in DCC SEND"
+ }
+ $self->{_fh}->close;
+ $self->{_parent}->parent->removeconn($self);
+ $self->{_parent}->handler(Net::IRC::Event->new('dcc_close',
+ $self->{_nick},
+ $self->{_socket},
+ $self->{_type}));
+ $self->{_socket}->close;
+ return;
+ }
+
+ $self->{_bout} += length($buf);
+
+ $self->{_parent}->handler(Net::IRC::Event->new('dcc_update',
+ $self->{_nick},
+ $self,
+ $self->{_type},
+ $self ));
+
+ return 1;
+}
+
+# -- #perl was here! --
+# fimmtiu: Man, merlyn, you must be drunk to type like that. :)
+# \merlyn: too many longislands.
+# \merlyn: she made them strong
+# archon: it's a plot
+# \merlyn: not even a good amoun tof coke
+# archon: she's in league with the guy in your shower
+# archon: she gets you drunk and he takes your wallet!
+
+
+# handles CHAT connections
+package Net::IRC::DCC::CHAT;
+@Net::IRC::DCC::CHAT::ISA = qw(Net::IRC::DCC::Connection);
+
+use IO::Socket;
+use Carp;
+use strict;
+
+sub new {
+
+ my ($class, $container, $type, $nick, $address, $port) = @_;
+ my ($sock, $self);
+
+ if ($type) {
+ # we're initiating
+
+ $sock = new IO::Socket::INET( Proto => "tcp",
+ Listen => 1);
+
+ unless (defined $sock) {
+ carp "Couldn't open DCC CHAT socket: $!";
+ return;
+ }
+
+ $sock->autoflush(1);
+ $container->ctcp('DCC CHAT', $nick, 'chat',
+ unpack("N",inet_aton($container->hostname)),
+ $sock->sockport());
+
+ $self = {
+ _bin => 0, # Bytes we've recieved thus far
+ _bout => 0, # Bytes we've sent
+ _connected => 1,
+ _debug => $container->debug,
+ _frag => '',
+ _nick => $nick, # Nick of the client on the other end
+ _parent => $container,
+ _socket => $sock, # Socket we're reading from
+ _time => 0, # This gets set by Accept->parse()
+ _type => 'CHAT',
+ };
+
+ bless $self, $class;
+
+ $sock = Net::IRC::DCC::Accept->new($sock, $self);
+
+ unless (defined $sock) {
+ carp "Error in DCC CHAT connect: $!";
+ return;
+ }
+
+ } else { # we're connecting
+
+ $address = &Net::IRC::DCC::Connection::fixaddr($address);
+ return if $port < 1024 or not defined $address;
+
+ $sock = new IO::Socket::INET( Proto => "tcp",
+ PeerAddr => "$address:$port");
+
+ if (defined $sock) {
+ $container->handler(Net::IRC::Event->new('dcc_open',
+ $nick,
+ $sock,
+ 'chat',
+ 'chat', $sock));
+ } else {
+ carp "Error in DCC CHAT connect: $!";
+ return;
+ }
+
+ $sock->autoflush(1);
+
+ $self = {
+ _bin => 0, # Bytes we've recieved thus far
+ _bout => 0, # Bytes we've sent
+ _connected => 1,
+ _nick => $nick, # Nick of the client on the other end
+ _parent => $container,
+ _socket => $sock, # Socket we're reading from
+ _time => time,
+ _type => 'CHAT',
+ };
+
+ bless $self, $class;
+
+ $self->{_parent}->parent->addfh($self->socket,
+ $self->can('parse'), 'r', $self);
+ }
+
+ return $self;
+}
+
+# -- #perl was here! --
+# \merlyn: tahtd be coole
+# KTurner bought the camel today, so somebody can afford one
+# more drink... ;)
+# tmtowtdi: I've heard of things like this...
+# \merlyn: as an experience. that is.
+# archon: i can think of cooler things (;
+# \merlyn: I don't realiy have that mch in my wallet.
+
+sub parse {
+ my ($self, $sock) = @_;
+
+ foreach my $line ($self->_getline($sock)) {
+ return unless defined $line;
+
+ $self->{_bin} += length($line);
+
+ return undef if $line eq "\012";
+ $self->{_bout} += length($line);
+
+ $self->{_parent}->handler(Net::IRC::Event->new('chat',
+ $self->{_nick},
+ $self->{_socket},
+ 'chat',
+ $line));
+
+ $self->{_parent}->handler(Net::IRC::Event->new('dcc_update',
+ $self->{_nick},
+ $self,
+ $self->{_type},
+ $self ));
+ }
+}
+
+# Sends a message to a channel or person.
+# Takes 2 args: the target of the message (channel or nick)
+# the text of the message to send
+sub privmsg {
+ my ($self) = shift;
+
+ unless (@_) {
+ croak 'Not enough arguments to privmsg()';
+ }
+
+ # Don't send a CR over DCC CHAT -- it's not wanted.
+ $self->socket->send(join('', @_) . "\012");
+}
+
+
+# -- #perl was here! --
+# \merlyn: this girl carly at the bar is aBABE
+# archon: are you sure? you don't sound like you're in a condition to
+# judge such things (;
+# *** Stupid has set the topic on channel #perl to \merlyn is shit-faced
+# with a trucker in the shower.
+# tmtowtdi: uh, yeah...
+# \merlyn: good topic
+
+
+# Sockets waiting for accept() use this to shoehorn into the select loop.
+package Net::IRC::DCC::Accept;
+
+@Net::IRC::DCC::Accept::ISA = qw(Net::IRC::DCC::Connection);
+use Carp;
+use Socket; # we use a lot of Socket functions in parse()
+use strict;
+
+
+sub new {
+ my ($class, $sock, $parent) = @_;
+ my ($self);
+
+ $self = { _debug => $parent->debug,
+ _nonblock => 1,
+ _socket => $sock,
+ _parent => $parent,
+ _type => 'accept',
+ };
+
+ bless $self, $class;
+
+ # Tkil's gonna love this one. :-) But what the hell... it's safe to
+ # assume that the only thing initiating DCCs will be Connections, right?
+ # Boy, we're not built for extensibility, I guess. Someday, I'll clean
+ # all of the things like this up.
+ $self->{_parent}->{_parent}->parent->addconn($self);
+ return $self;
+}
+
+sub parse {
+ my ($self) = shift;
+ my ($sock);
+
+ $sock = $self->{_socket}->accept;
+ $self->{_parent}->{_socket} = $sock;
+ $self->{_parent}->{_time} = time;
+
+ if ($self->{_parent}->{_type} eq 'SEND') {
+ # ok, to get the ball rolling, we send them the first packet.
+ my $buf;
+ unless (defined $self->{_parent}->{_fh}->
+ read($buf, $self->{_parent}->{_blocksize})) {
+ return;
+ }
+ unless (defined $sock->send($buf)) {
+ $sock->close;
+ $self->{_parent}->{_fh}->close;
+ $self->{_parent}->{_parent}->parent->removefh($sock);
+ $self->{_parent}->handler(Net::IRC::Event->new('dcc_close',
+ $self->{_nick},
+ $self->{_socket},
+ $self->{_type}));
+ $self->{_socket}->close;
+ return;
+ }
+ }
+
+ $self->{_parent}->{_parent}->parent->addconn($self->{_parent});
+ $self->{_parent}->{_parent}->parent->removeconn($self);
+
+ $self->{_parent}->{_parent}->handler(Net::IRC::Event->
+ new('dcc_open',
+ $self->{_parent}->{_nick},
+ $self->{_parent}->{_socket},
+ $self->{_parent}->{_type},
+ $self->{_parent}->{_type},
+ $self->{_parent}->{_socket})
+ );
+}
+
+
+
+1;
+
+
+__END__
+
+=head1 NAME
+
+Net::IRC::DCC - Object-oriented interface to a single DCC connection
+
+=head1 SYNOPSIS
+
+Hard hat area: This section under construction.
+
+=head1 DESCRIPTION
+
+This documentation is a subset of the main Net::IRC documentation. If
+you haven't already, please "perldoc Net::IRC" before continuing.
+
+Net::IRC::DCC defines a few subclasses that handle DCC CHAT, GET, and SEND
+requests for inter-client communication. DCC objects are created by
+C<Connection-E<gt>new_{chat,get,send}()> in much the same way that
+C<IRC-E<gt>newconn()> creates a new connection object.
+
+=head1 METHOD DESCRIPTIONS
+
+This section is under construction, but hopefully will be finally written up
+by the next release. Please see the C<irctest> script and the source for
+details about this module.
+
+=head1 AUTHORS
+
+Conceived and initially developed by Greg Bacon E<lt>gbacon@adtran.comE<gt> and
+Dennis Taylor E<lt>dennis@funkplanet.comE<gt>.
+
+Ideas and large amounts of code donated by Nat "King" Torkington E<lt>gnat@frii.comE<gt>.
+
+Currently being hacked on, hacked up, and worked over by the members of the
+Net::IRC developers mailing list. For details, see
+http://www.execpc.com/~corbeau/irc/list.html .
+
+=head1 URL
+
+Up-to-date source and information about the Net::IRC project can be found at
+http://netirc.betterbox.net/ .
+
+=head1 SEE ALSO
+
+=over
+
+=item *
+
+perl(1).
+
+=item *
+
+RFC 1459: The Internet Relay Chat Protocol
+
+=item *
+
+http://www.irchelp.org/, home of fine IRC resources.
+
+=back
+
+=cut
diff --git a/lib/Net/IRC/Event.pm b/lib/Net/IRC/Event.pm
new file mode 100644
index 0000000..3359a2f
--- /dev/null
+++ b/lib/Net/IRC/Event.pm
@@ -0,0 +1,873 @@
+#####################################################################
+# #
+# Net::IRC -- Object-oriented Perl interface to an IRC server #
+# #
+# Event.pm: The basic data type for any IRC occurrence. #
+# #
+# Copyright (c) 2001 Pete Sergeant, Greg Bacon & Dennis Taylor. #
+# All rights reserved. #
+# #
+# This module is free software; you can redistribute or #
+# modify it under the terms of Perl's Artistic License. #
+# #
+#####################################################################
+
+# there used to be lots of cute little log quotes from #perl in here
+#
+# they're gone now because they made working on this already crappy
+# code even more annoying... 'HI!!! I'm from #perl and so I don't
+# write understandable, maintainable code!!! You see, i'm a perl
+# badass, so I try to be as obscure as possible in everything I do!'
+#
+# Well, welcome to the real world, guys, where code needs to be
+# maintainable and sane.
+
+package Net::IRC::Event;
+
+use strict;
+our %_names;
+
+# Constructor method for Net::IRC::Event objects.
+# Takes at least 4 args: the type of event
+# the person or server that initiated the event
+# the recipient(s) of the event, as arrayref or scalar
+# the name of the format string for the event
+# (optional) any number of arguments provided by the event
+sub new {
+ my $class = shift;
+ my $type = shift;
+ my $from = shift;
+ my $to = shift;
+ my $format = shift;
+ my $args = \@_;
+
+ my $self = {
+ 'type' => $type,
+ 'from' => undef,
+ 'to' => ref($to) eq 'ARRAY' ? $to : [ $to ],
+ 'format' => $format,
+ 'args' => [],
+ };
+
+ bless $self, $class;
+
+ if ($self->type !~ /\D/) {
+ $self->type($self->trans($self->type));
+ } else {
+ $self->type(lc($self->type));
+ }
+
+ $self->from($from); # sets nick, user, and host
+ $self->args($args); # strips colons from args
+
+ return $self;
+}
+
+# Sets or returns an argument list for this event.
+# Takes any number of args: the arguments for the event.
+sub args {
+ my $self = shift;
+ my $args = shift;
+
+ if($args) {
+ my (@q, $i, $ct) = @{$args}; # This line is solemnly dedicated to \mjd.
+
+ $self->{'args'} = [ ];
+ while (@q) {
+ $i = shift @q;
+ next unless defined $i;
+
+ if ($i =~ /^:/ and $ct) { # Concatenate :-args.
+ $i = join ' ', (substr($i, 1), @q);
+ push @{$self->{'args'}}, $i;
+ last;
+ }
+ push @{$self->{'args'}}, $i;
+ $ct++;
+ }
+ }
+
+ return @{$self->{'args'}};
+}
+
+# Dumps the contents of an event to STDERR so you can see what's inside.
+# Takes no args.
+sub dump {
+ my ($self, $arg, $counter) = (shift, undef, 0); # heh heh!
+
+ printf STDERR "TYPE: %-30s FORMAT: %-30s\n", $self->type, $self->format;
+ print STDERR "FROM: ", $self->from, "\n";
+ print STDERR "TO: ", join(", ", @{$self->to}), "\n";
+ foreach $arg ($self->args) {
+ print "Arg ", $counter++, ": ", $arg, "\n";
+ }
+}
+
+# Sets or returns the format string for this event.
+# Takes 1 optional arg: the new value for this event's "format" field.
+sub format {
+ my $self = shift;
+
+ $self->{'format'} = $_[0] if @_;
+ return $self->{'format'};
+}
+
+# Sets or returns the originator of this event
+# Takes 1 optional arg: the new value for this event's "from" field.
+sub from {
+ my $self = shift;
+ my @part;
+
+ if (@_) {
+ # avoid certain irritating and spurious warnings from this line...
+ { local $^W;
+ @part = split /[\@!]/, $_[0], 3;
+ }
+
+ $self->nick(defined $part[0] ? $part[0] : '');
+ $self->user(defined $part[1] ? $part[1] : '');
+ $self->host(defined $part[2] ? $part[2] : '');
+ defined $self->user ?
+ $self->userhost($self->user . '@' . $self->host) :
+ $self->userhost($self->host);
+ $self->{'from'} = $_[0];
+ }
+
+ return $self->{'from'};
+}
+
+# Sets or returns the hostname of this event's initiator
+# Takes 1 optional arg: the new value for this event's "host" field.
+sub host {
+ my $self = shift;
+
+ $self->{'host'} = $_[0] if @_;
+ return $self->{'host'};
+}
+
+# Sets or returns the nick of this event's initiator
+# Takes 1 optional arg: the new value for this event's "nick" field.
+sub nick {
+ my $self = shift;
+
+ $self->{'nick'} = $_[0] if @_;
+ return $self->{'nick'};
+}
+
+# Sets or returns the recipient list for this event
+# Takes any number of args: this event's list of recipients.
+sub to {
+ my $self = shift;
+
+ $self->{'to'} = [ @_ ] if @_;
+ return wantarray ? @{$self->{'to'}} : $self->{'to'};
+}
+
+# Sets or returns the type of this event
+# Takes 1 optional arg: the new value for this event's "type" field.
+sub type {
+ my $self = shift;
+
+ $self->{'type'} = $_[0] if @_;
+ return $self->{'type'};
+}
+
+# Sets or returns the username of this event's initiator
+# Takes 1 optional arg: the new value for this event's "user" field.
+sub user {
+ my $self = shift;
+
+ $self->{'user'} = $_[0] if @_;
+ return $self->{'user'};
+}
+
+# Just $self->user plus '@' plus $self->host, for convenience.
+sub userhost {
+ my $self = shift;
+
+ $self->{'userhost'} = $_[0] if @_;
+ return $self->{'userhost'};
+}
+
+#added by AfterDeath. Use this to reply to channel messages in channel, but private messages to the nick that sent it.
+sub replyto {
+ my $self = shift;
+ if ($self->{to}->[0] =~ /^[+@#&%]/) {
+ return $self->{to}->[0];
+ } else {
+ return $self->{nick};
+ }
+}
+
+# Simple sub for translating server numerics to their appropriate names.
+# Takes one arg: the number to be translated.
+sub trans {
+ shift if (ref($_[0]) || $_[0]) =~ /^Net::IRC/;
+ my $ev = shift;
+
+ return (exists $_names{$ev} ? $_names{$ev} : undef);
+}
+
+%_names = (
+ # suck! these aren't treated as strings --
+ # 001 ne 1 for the purpose of hash keying, apparently.
+ '001' => "welcome",
+ '002' => "yourhost",
+ '003' => "created",
+ '004' => "myinfo",
+ '005' => "map", # Undernet Extension, Kajetan@Hinner.com, 17/11/98
+ '006' => "mapmore", # Undernet Extension, Kajetan@Hinner.com, 17/11/98
+ '007' => "mapend", # Undernet Extension, Kajetan@Hinner.com, 17/11/98
+ '008' => "snomask", # Undernet Extension, Kajetan@Hinner.com, 17/11/98
+ '009' => "statmemtot", # Undernet Extension, Kajetan@Hinner.com, 17/11/98
+ '010' => "statmem", # Undernet Extension, Kajetan@Hinner.com, 17/11/98
+
+ 200 => "tracelink",
+ 201 => "traceconnecting",
+ 202 => "tracehandshake",
+ 203 => "traceunknown",
+ 204 => "traceoperator",
+ 205 => "traceuser",
+ 206 => "traceserver",
+ 208 => "tracenewtype",
+ 209 => "traceclass",
+ 211 => "statslinkinfo",
+ 212 => "statscommands",
+ 213 => "statscline",
+ 214 => "statsnline",
+ 215 => "statsiline",
+ 216 => "statskline",
+ 217 => "statsqline",
+ 218 => "statsyline",
+ 219 => "endofstats",
+ 220 => "statsbline", # UnrealIrcd, Hendrik Frenzel
+ 221 => "umodeis",
+ 222 => "sqline_nick", # UnrealIrcd, Hendrik Frenzel
+ 223 => "statsgline", # UnrealIrcd, Hendrik Frenzel
+ 224 => "statstline", # UnrealIrcd, Hendrik Frenzel
+ 225 => "statseline", # UnrealIrcd, Hendrik Frenzel
+ 226 => "statsnline", # UnrealIrcd, Hendrik Frenzel
+ 227 => "statsvline", # UnrealIrcd, Hendrik Frenzel
+ 231 => "serviceinfo",
+ 232 => "endofservices",
+ 233 => "service",
+ 234 => "servlist",
+ 235 => "servlistend",
+ 241 => "statslline",
+ 242 => "statsuptime",
+ 243 => "statsoline",
+ 244 => "statshline",
+ 245 => "statssline", # Reserved, Kajetan@Hinner.com, 17/10/98
+ 246 => "statstline", # Undernet Extension, Kajetan@Hinner.com, 17/10/98
+ 247 => "statsgline", # Undernet Extension, Kajetan@Hinner.com, 17/10/98
+### TODO: need numerics to be able to map to multiple strings
+### 247 => "statsxline", # UnrealIrcd, Hendrik Frenzel
+ 248 => "statsuline", # Undernet Extension, Kajetan@Hinner.com, 17/10/98
+ 249 => "statsdebug", # Unspecific Extension, Kajetan@Hinner.com, 17/10/98
+ 250 => "luserconns", # 1998-03-15 -- tkil
+ 251 => "luserclient",
+ 252 => "luserop",
+ 253 => "luserunknown",
+ 254 => "luserchannels",
+ 255 => "luserme",
+ 256 => "adminme",
+ 257 => "adminloc1",
+ 258 => "adminloc2",
+ 259 => "adminemail",
+ 261 => "tracelog",
+ 262 => "endoftrace", # 1997-11-24 -- archon
+ 263 => "rpl_tryagain",
+ 265 => "n_local", # 1997-10-16 -- tkil
+ 266 => "n_global", # 1997-10-16 -- tkil
+ 271 => "silelist", # Undernet Extension, Kajetan@Hinner.com, 17/10/98
+ 272 => "endofsilelist", # Undernet Extension, Kajetan@Hinner.com, 17/10/98
+ 275 => "statsdline", # Undernet Extension, Kajetan@Hinner.com, 17/10/98
+ 280 => "glist", # Undernet Extension, Kajetan@Hinner.com, 17/10/98
+ 281 => "endofglist", # Undernet Extension, Kajetan@Hinner.com, 17/10/98
+ 290 => "helphdr", # UnrealIrcd, Hendrik Frenzel
+ 291 => "helpop", # UnrealIrcd, Hendrik Frenzel
+ 292 => "helptlr", # UnrealIrcd, Hendrik Frenzel
+ 293 => "helphlp", # UnrealIrcd, Hendrik Frenzel
+ 294 => "helpfwd", # UnrealIrcd, Hendrik Frenzel
+ 295 => "helpign", # UnrealIrcd, Hendrik Frenzel
+
+ 300 => "none",
+ 301 => "away",
+ 302 => "userhost",
+ 303 => "ison",
+ 304 => "rpl_text", # Bahamut IRCD
+ 305 => "unaway",
+ 306 => "nowaway",
+ 307 => "userip", # Undernet Extension, Kajetan@Hinner.com, 17/10/98
+ 308 => "rulesstart", # UnrealIrcd, Hendrik Frenzel
+ 309 => "endofrules", # UnrealIrcd, Hendrik Frenzel
+ 310 => "whoishelp", # (July01-01)Austnet Extension, found by Andypoo <andypoo@secret.com.au>
+ 311 => "whoisuser",
+ 312 => "whoisserver",
+ 313 => "whoisoperator",
+ 314 => "whowasuser",
+ 315 => "endofwho",
+ 316 => "whoischanop",
+ 317 => "whoisidle",
+ 318 => "endofwhois",
+ 319 => "whoischannels",
+ 320 => "whoisvworld", # (July01-01)Austnet Extension, found by Andypoo <andypoo@secret.com.au>
+ 321 => "liststart",
+ 322 => "list",
+ 323 => "listend",
+ 324 => "channelmodeis",
+ 328 => "channelurlis",
+ 329 => "channelcreate", # 1997-11-24 -- archon
+ 331 => "notopic",
+ 332 => "topic",
+ 333 => "topicinfo", # 1997-11-24 -- archon
+ 334 => "listusage", # Undernet Extension, Kajetan@Hinner.com, 17/10/98
+ 335 => "whoisbot", # UnrealIrcd, Hendrik Frenzel
+ 341 => "inviting",
+ 342 => "summoning",
+ 346 => "invitelist", # UnrealIrcd, Hendrik Frenzel
+ 347 => "endofinvitelist", # UnrealIrcd, Hendrik Frenzel
+ 348 => "exlist", # UnrealIrcd, Hendrik Frenzel
+ 349 => "endofexlist", # UnrealIrcd, Hendrik Frenzel
+ 351 => "version",
+ 352 => "whoreply",
+ 353 => "namreply",
+ 354 => "whospcrpl", # Undernet Extension, Kajetan@Hinner.com, 17/10/98
+ 361 => "killdone",
+ 362 => "closing",
+ 363 => "closeend",
+ 364 => "links",
+ 365 => "endoflinks",
+ 366 => "endofnames",
+ 367 => "banlist",
+ 368 => "endofbanlist",
+ 369 => "endofwhowas",
+ 371 => "info",
+ 372 => "motd",
+ 373 => "infostart",
+ 374 => "endofinfo",
+ 375 => "motdstart",
+ 376 => "endofmotd",
+ 377 => "motd2", # 1997-10-16 -- tkil
+ 378 => "austmotd", # (July01-01)Austnet Extension, found by Andypoo <andypoo@secret.com.au>
+ 379 => "whoismodes", # UnrealIrcd, Hendrik Frenzel
+ 381 => "youreoper",
+ 382 => "rehashing",
+ 383 => "youreservice", # UnrealIrcd, Hendrik Frenzel
+ 384 => "myportis",
+ 385 => "notoperanymore", # Unspecific Extension, Kajetan@Hinner.com, 17/10/98
+ 386 => "qlist", # UnrealIrcd, Hendrik Frenzel
+ 387 => "endofqlist", # UnrealIrcd, Hendrik Frenzel
+ 388 => "alist", # UnrealIrcd, Hendrik Frenzel
+ 389 => "endofalist", # UnrealIrcd, Hendrik Frenzel
+ 391 => "time",
+ 392 => "usersstart",
+ 393 => "users",
+ 394 => "endofusers",
+ 395 => "nousers",
+ 396 => "hosthidden",
+
+ 401 => "nosuchnick",
+ 402 => "nosuchserver",
+ 403 => "nosuchchannel",
+ 404 => "cannotsendtochan",
+ 405 => "toomanychannels",
+ 406 => "wasnosuchnick",
+ 407 => "toomanytargets",
+ 408 => "nosuchservice", # UnrealIrcd, Hendrik Frenzel
+ 409 => "noorigin",
+ 411 => "norecipient",
+ 412 => "notexttosend",
+ 413 => "notoplevel",
+ 414 => "wildtoplevel",
+ 416 => "querytoolong", # Undernet Extension, Kajetan@Hinner.com, 17/10/98
+ 421 => "unknowncommand",
+ 422 => "nomotd",
+ 423 => "noadmininfo",
+ 424 => "fileerror",
+ 425 => "noopermotd", # UnrealIrcd, Hendrik Frenzel
+ 431 => "nonicknamegiven",
+ 432 => "erroneusnickname", # This iz how its speld in thee RFC.
+ 433 => "nicknameinuse",
+ 434 => "norules", # UnrealIrcd, Hendrik Frenzel
+ 435 => "serviceconfused", # UnrealIrcd, Hendrik Frenzel
+ 436 => "nickcollision",
+ 437 => "bannickchange", # Undernet Extension, Kajetan@Hinner.com, 17/10/98
+ 438 => "nicktoofast", # Undernet Extension, Kajetan@Hinner.com, 17/10/98
+ 439 => "targettoofast", # Undernet Extension, Kajetan@Hinner.com, 17/10/98
+ 440 => "servicesdown", # Bahamut IRCD
+ 441 => "usernotinchannel",
+ 442 => "notonchannel",
+ 443 => "useronchannel",
+ 444 => "nologin",
+ 445 => "summondisabled",
+ 446 => "usersdisabled",
+ 447 => "nonickchange", # UnrealIrcd, Hendrik Frenzel
+ 451 => "notregistered",
+ 455 => "hostilename", # UnrealIrcd, Hendrik Frenzel
+ 459 => "nohiding", # UnrealIrcd, Hendrik Frenzel
+ 460 => "notforhalfops", # UnrealIrcd, Hendrik Frenzel
+ 461 => "needmoreparams",
+ 462 => "alreadyregistered",
+ 463 => "nopermforhost",
+ 464 => "passwdmismatch",
+ 465 => "yourebannedcreep", # I love this one...
+ 466 => "youwillbebanned",
+ 467 => "keyset",
+ 468 => "invalidusername", # Undernet Extension, Kajetan@Hinner.com, 17/10/98
+ 469 => "linkset", # UnrealIrcd, Hendrik Frenzel
+ 470 => "linkchannel", # UnrealIrcd, Hendrik Frenzel
+ 471 => "channelisfull",
+ 472 => "unknownmode",
+ 473 => "inviteonlychan",
+ 474 => "bannedfromchan",
+ 475 => "badchannelkey",
+ 476 => "badchanmask",
+ 477 => "needreggednick", # Bahamut IRCD
+ 478 => "banlistfull", # Undernet Extension, Kajetan@Hinner.com, 17/10/98
+ 479 => "secureonlychannel", # pircd
+### TODO: see above todo
+### 479 => "linkfail", # UnrealIrcd, Hendrik Frenzel
+ 480 => "cannotknock", # UnrealIrcd, Hendrik Frenzel
+ 481 => "noprivileges",
+ 482 => "chanoprivsneeded",
+ 483 => "cantkillserver",
+ 484 => "ischanservice", # Undernet Extension, Kajetan@Hinner.com, 17/10/98
+ 485 => "killdeny", # UnrealIrcd, Hendrik Frenzel
+ 486 => "htmdisabled", # UnrealIrcd, Hendrik Frenzel
+ 489 => "secureonlychan", # UnrealIrcd, Hendrik Frenzel
+ 491 => "nooperhost",
+ 492 => "noservicehost",
+
+ 501 => "umodeunknownflag",
+ 502 => "usersdontmatch",
+
+ 511 => "silelistfull", # Undernet Extension, Kajetan@Hinner.com, 17/10/98
+ 513 => "nosuchgline", # Undernet Extension, Kajetan@Hinner.com, 17/10/98
+ 513 => "badping", # Undernet Extension, Kajetan@Hinner.com, 17/10/98
+ 518 => "noinvite", # UnrealIrcd, Hendrik Frenzel
+ 519 => "admonly", # UnrealIrcd, Hendrik Frenzel
+ 520 => "operonly", # UnrealIrcd, Hendrik Frenzel
+ 521 => "listsyntax", # UnrealIrcd, Hendrik Frenzel
+ 524 => "operspverify", # UnrealIrcd, Hendrik Frenzel
+
+ 600 => "rpl_logon", # Bahamut IRCD
+ 601 => "rpl_logoff", # Bahamut IRCD
+ 602 => "rpl_watchoff", # UnrealIrcd, Hendrik Frenzel
+ 603 => "rpl_watchstat", # UnrealIrcd, Hendrik Frenzel
+ 604 => "rpl_nowon", # Bahamut IRCD
+ 605 => "rpl_nowoff", # Bahamut IRCD
+ 606 => "rpl_watchlist", # UnrealIrcd, Hendrik Frenzel
+ 607 => "rpl_endofwatchlist", # UnrealIrcd, Hendrik Frenzel
+ 610 => "mapmore", # UnrealIrcd, Hendrik Frenzel
+ 640 => "rpl_dumping", # UnrealIrcd, Hendrik Frenzel
+ 641 => "rpl_dumprpl", # UnrealIrcd, Hendrik Frenzel
+ 642 => "rpl_eodump", # UnrealIrcd, Hendrik Frenzel
+
+ 716 => "rpl_ignored",
+
+ 728 => "quietlist",
+ 729 => "quietlistend",
+ 999 => "numericerror", # Bahamut IRCD
+ 'pong' => "pong",
+ );
+
+
+1;
+
+
+__END__
+
+=head1 NAME
+
+Net::IRC::Event - A class for passing event data between subroutines
+
+=head1 SYNOPSIS
+
+None yet. These docs are under construction.
+
+=head1 DESCRIPTION
+
+This documentation is a subset of the main Net::IRC documentation. If
+you haven't already, please "perldoc Net::IRC" before continuing.
+
+Net::IRC::Event defines a standard interface to the salient information for
+just about any event your client may witness on IRC. It's about as close as
+we can get in Perl to a struct, with a few extra nifty features thrown in.
+
+=head1 METHOD DESCRIPTIONS
+
+This section is under construction, but hopefully will be finally written up
+by the next release. Please see the C<irctest> script and the source for
+details about this module.
+
+=head1 LIST OF EVENTS
+
+Net::IRC is an entirely event-based system, which takes some getting used to
+at first. To interact with the IRC server, you tell Net::IRC's server
+connection to listen for certain events and activate your own subroutines when
+they occur. Problem is, this doesn't help you much if you don't know what to
+tell it to look for. Below is a list of the possible events you can pass to
+Net::IRC, along with brief descriptions of each... hope this helps.
+
+=head2 Common events
+
+=over
+
+=item *
+
+nick
+
+The "nick" event is triggered when the client receives a NICK message, meaning
+that someone on a channel with the client has changed eir nickname.
+
+=item *
+
+quit
+
+The "quit" event is triggered upon receipt of a QUIT message, which means that
+someone on a channel with the client has disconnected.
+
+=item *
+
+join
+
+The "join" event is triggered upon receipt of a JOIN message, which means that
+someone has entered a channel that the client is on.
+
+=item *
+
+part
+
+The "part" event is triggered upon receipt of a PART message, which means that
+someone has left a channel that the client is on.
+
+=item *
+
+mode
+
+The "mode" event is triggered upon receipt of a MODE message, which means that
+someone on a channel with the client has changed the channel's parameters.
+
+=item *
+
+topic
+
+The "topic" event is triggered upon receipt of a TOPIC message, which means
+that someone on a channel with the client has changed the channel's topic.
+
+=item *
+
+kick
+
+The "kick" event is triggered upon receipt of a KICK message, which means that
+someone on a channel with the client (or possibly the client itself!) has been
+forcibly ejected.
+
+=item *
+
+public
+
+The "public" event is triggered upon receipt of a PRIVMSG message to an entire
+channel, which means that someone on a channel with the client has said
+something aloud.
+
+=item *
+
+msg
+
+The "msg" event is triggered upon receipt of a PRIVMSG message which is
+addressed to one or more clients, which means that someone is sending the
+client a private message. (Duh. :-)
+
+=item *
+
+notice
+
+The "notice" event is triggered upon receipt of a NOTICE message, which means
+that someone has sent the client a public or private notice. (Is that
+sufficiently vague?)
+
+=item *
+
+ping
+
+The "ping" event is triggered upon receipt of a PING message, which means that
+the IRC server is querying the client to see if it's alive. Don't confuse this
+with CTCP PINGs, explained later.
+
+=item *
+
+other
+
+The "other" event is triggered upon receipt of any number of unclassifiable
+miscellaneous messages, but you're not likely to see it often.
+
+=item *
+
+invite
+
+The "invite" event is triggered upon receipt of an INVITE message, which means
+that someone is permitting the client's entry into a +i channel.
+
+=item *
+
+kill
+
+The "kill" event is triggered upon receipt of a KILL message, which means that
+an IRC operator has just booted your sorry arse offline. Seeya!
+
+=item *
+
+disconnect
+
+The "disconnect" event is triggered when the client loses its
+connection to the IRC server it's talking to. Don't confuse it with
+the "leaving" event. (See below.)
+
+=item *
+
+leaving
+
+The "leaving" event is triggered just before the client deliberately
+closes a connection to an IRC server, in case you want to do anything
+special before you sign off.
+
+=item *
+
+umode
+
+The "umode" event is triggered when the client changes its personal mode flags.
+
+=item *
+
+error
+
+The "error" event is triggered when the IRC server complains to you about
+anything. Sort of the evil twin to the "other" event, actually.
+
+=back
+
+=head2 CTCP Requests
+
+=over
+
+=item *
+
+cping
+
+The "cping" event is triggered when the client receives a CTCP PING request
+from another user. See the irctest script for an example of how to properly
+respond to this common request.
+
+=item *
+
+cversion
+
+The "cversion" event is triggered when the client receives a CTCP VERSION
+request from another client, asking for version info about its IRC client
+program.
+
+=item *
+
+csource
+
+The "csource" event is triggered when the client receives a CTCP SOURCE
+request from another client, asking where it can find the source to its
+IRC client program.
+
+=item *
+
+ctime
+
+The "ctime" event is triggered when the client receives a CTCP TIME
+request from another client, asking for the local time at its end.
+
+=item *
+
+cdcc
+
+The "cdcc" event is triggered when the client receives a DCC request of any
+sort from another client, attempting to establish a DCC connection.
+
+=item *
+
+cuserinfo
+
+The "cuserinfo" event is triggered when the client receives a CTCP USERINFO
+request from another client, asking for personal information from the client's
+user.
+
+=item *
+
+cclientinfo
+
+The "cclientinfo" event is triggered when the client receives a CTCP CLIENTINFO
+request from another client, asking for whatever the hell "clientinfo" means.
+
+=item *
+
+cerrmsg
+
+The "cerrmsg" event is triggered when the client receives a CTCP ERRMSG
+request from another client, notifying it of a protocol error in a preceding
+CTCP communication.
+
+=item *
+
+cfinger
+
+The "cfinger" event is triggered when the client receives a CTCP FINGER
+request from another client. How to respond to this should best be left up
+to your own moral stance.
+
+=item *
+
+caction
+
+The "caction" event is triggered when the client receives a CTCP ACTION
+message from another client. I should hope you're getting the hang of how
+Net::IRC handles CTCP requests by now...
+
+=back
+
+=head2 CTCP Responses
+
+=over
+
+=item *
+
+crping
+
+The "crping" event is triggered when the client receives a CTCP PING response
+from another user. See the irctest script for an example of how to properly
+respond to this common event.
+
+=item *
+
+crversion
+
+The "crversion" event is triggered when the client receives a CTCP VERSION
+response from another client.
+
+=item *
+
+crsource
+
+The "crsource" event is triggered when the client receives a CTCP SOURCE
+response from another client.
+
+=item *
+
+crtime
+
+The "crtime" event is triggered when the client receives a CTCP TIME
+response from another client.
+
+=item *
+
+cruserinfo
+
+The "cruserinfo" event is triggered when the client receives a CTCP USERINFO
+response from another client.
+
+=item *
+
+crclientinfo
+
+The "crclientinfo" event is triggered when the client receives a CTCP
+CLIENTINFO response from another client.
+
+=item *
+
+crfinger
+
+The "crfinger" event is triggered when the client receives a CTCP FINGER
+response from another client. I'm not even going to consider making a joke
+about this one.
+
+=back
+
+=head2 DCC Events
+
+=over
+
+=item *
+
+dcc_open
+
+The "dcc_open" event is triggered when a DCC connection is established between
+the client and another client.
+
+=item *
+
+dcc_update
+
+The "dcc_update" event is triggered when any data flows over a DCC connection.
+Useful for doing things like monitoring file transfer progress, for instance.
+
+=item *
+
+dcc_close
+
+The "dcc_close" event is triggered when a DCC connection closes, whether from
+an error or from natural causes.
+
+=item *
+
+chat
+
+The "chat" event is triggered when the person on the other end of a DCC CHAT
+connection sends you a message. Think of it as the private equivalent of "msg",
+if you will.
+
+=back
+
+=head2 Numeric Events
+
+=over
+
+=item *
+
+There's a whole lot of them, and they're well-described elsewhere. Please see
+the IRC RFC (1495, at http://cs-ftp.bu.edu/pub/irc/support/IRC_RFC ) for a
+detailed description, or the Net::IRC::Event.pm source code for a quick list.
+
+=back
+
+=head1 AUTHORS
+
+Conceived and initially developed by Greg Bacon E<lt>gbacon@adtran.comE<gt> and
+Dennis Taylor E<lt>dennis@funkplanet.comE<gt>.
+
+Ideas and large amounts of code donated by Nat "King" Torkington E<lt>gnat@frii.comE<gt>.
+
+Currently being hacked on, hacked up, and worked over by the members of the
+Net::IRC developers mailing list. For details, see
+http://www.execpc.com/~corbeau/irc/list.html .
+
+=head1 URL
+
+Up-to-date source and information about the Net::IRC project can be found at
+http://netirc.betterbox.net/ .
+
+=head1 SEE ALSO
+
+=over
+
+=item *
+
+perl(1).
+
+=item *
+
+RFC 1459: The Internet Relay Chat Protocol
+
+=item *
+
+http://www.irchelp.org/, home of fine IRC resources.
+
+=back
+
+=cut
+
diff --git a/lib/Net/IRC/EventQueue.pm b/lib/Net/IRC/EventQueue.pm
new file mode 100644
index 0000000..fdb7b44
--- /dev/null
+++ b/lib/Net/IRC/EventQueue.pm
@@ -0,0 +1,73 @@
+package Net::IRC::EventQueue;
+
+use Net::IRC::EventQueue::Entry;
+
+use strict;
+
+sub new {
+ my $class = shift;
+
+ my $self = {
+ 'queue' => {},
+ };
+
+ bless $self, $class;
+}
+
+sub queue {
+ my $self = shift;
+ return $self->{'queue'};
+}
+
+sub enqueue {
+ my $self = shift;
+ my $time = shift;
+ my $content = shift;
+
+ my $entry = new Net::IRC::EventQueue::Entry($time, $content);
+ $self->queue->{$entry->id} = $entry;
+ return $entry->id;
+}
+
+sub dequeue {
+ my $self = shift;
+ my $event = shift;
+ my $result;
+
+ if(!$event) { # we got passed nothing, so return the first event
+ $event = $self->head();
+ delete $self->queue->{$event->id};
+ $result = $event;
+ } elsif(!ref($event)) { # we got passed an id
+ $result = $self->queue->{$event};
+ delete $self->queue->{$event};
+ } else { # we got passed an actual event object
+ ref($event) eq 'Net::IRC::EventQueue::Entry'
+ or die "Cannot delete event type of " . ref($event) . "!";
+
+ $result = $self->queue->{$event->id};
+ delete $self->queue->{$event->id};
+ }
+
+ return $result;
+}
+
+sub head {
+ my $self = shift;
+
+ return undef if $self->is_empty;
+
+ no warnings; # because we want to numerically sort strings...
+ my $headkey = (sort {$a <=> $b} (keys(%{$self->queue})))[0];
+ use warnings;
+
+ return $self->queue->{$headkey};
+}
+
+sub is_empty {
+ my $self = shift;
+
+ return keys(%{$self->queue}) ? 0 : 1;
+}
+
+1;
diff --git a/lib/Net/IRC/EventQueue/Entry.pm b/lib/Net/IRC/EventQueue/Entry.pm
new file mode 100644
index 0000000..94a3802
--- /dev/null
+++ b/lib/Net/IRC/EventQueue/Entry.pm
@@ -0,0 +1,40 @@
+package Net::IRC::EventQueue::Entry;
+
+use strict;
+
+my $id = 0;
+
+sub new {
+ my $class = shift;
+ my $time = shift;
+ my $content = shift;
+
+ my $self = {
+ 'time' => $time,
+ 'content' => $content,
+ 'id' => "$time:" . $id++,
+ };
+
+ bless $self, $class;
+ return $self;
+}
+
+sub id {
+ my $self = shift;
+ return $self->{'id'};
+}
+
+sub time {
+ my $self = shift;
+ $self->{'time'} = $_[0] if @_;
+ return $self->{'time'};
+}
+
+sub content {
+ my $self = shift;
+ $self->{'content'} = $_[0] if @_;
+ return $self->{'content'};
+}
+
+1;
+
generated by cgit v1.2.3 (git 2.46.0) at 2026-01-26 23:33:19 +0000