#!/usr/bin/perl die "I need Perl 5.x or better. Sorry.\n" unless ($] >= 5); use Socket; use Fcntl; # This is modified from tinbot.pl for undernet's #gothic. # But since tingoth has gained popularity while tinbot has not... tingoth it is! # This particular version of the tinbot is actually muay crippled to serve # only as a channel babysitter, as per Darius' request. # Default values follow. $debug = 1; # If you want some sort of log to be sent to STDOUT. $mynick = 'TinCheap'; $mychan = '#DarkHaven'; $IRCpassword = ''; # the password the IRC server(s) require to log in @IRCserver = ('balimore.md.us.undernet.org', 'sandiego.ca.us.undernet.org'); @IRCport = ('6666','6668','6669','6667'); # "nick!user@host" => userlevel %userlist = ( 'Darius!~?darius@*.hom.net' => 3, 'Amber!~?navybean@*.netcom.com' => 2, 'Spleef!~?rgatliff@*.bellsouth.net' => 2, 'Bari!~?thirteen@*.hom.net' => 2 ); $help0 = "Email: Mozai about CheapTin. " ."HELLO; TIME; LEVEL "; # $help1 = ""; $help2 = "MODELOCK , TOPICLOCK , TOPIC ," ."LEVEL <#>, KICK , GREET "; $help3 = "QUIT,NICK ,JOIN/PART , SAY/ME "; $stubborn = 1; # Set to nonzero if bot will continue to attempt to reconnect. $stubborn_pause = 5; # How many times will it try before resting? $pidfile = "cheap.pid"; # filename where the bot's pid is stored. # Undocumented level 3 command: RAW # ----------------------- If you customize below this line, caveat emptor. #sub lc { # Perl4 version of Perl5's "lc". # local($waldo); $waldo = $_[0]; # $waldo =~ tr/[A-Z]/[a-z]/; # return $waldo; # } # But since I'm using other Perl5 specific functions... # This part is so bloody cool. -Moses %parse= ('PING', Pong ,'PRIVMSG', Privmsg ,'NOTICE', Notice ,'MODE', Mode ,'INVITE', Invite ,'NICK', Nick ,'QUIT', Quit ,'JOIN', Join ,'KICK', Kick ,'PART', Part ,'TOPIC', Topic ,'ERROR', Error ,'001', NoOp # Welcome to server ,'002', NoOp # Youre host is ,'003', NoOp # Host compile date ,'004', NoOp # Info ,'251', NoOp # Users response ,'252', NoOp # Operators onlin ,'253', NoOp # Unknown connections ,'254', NoOp # nubmer of channels ,'255', NoOp # connections to server ,'301', NoOp # Away # ,'332', TopicCurrent ,'333', NoOp # Who and when set the topic ,'353', Names ,'366', NoOp # End of Names ,'372', Motd ,'376', EndOfMotd ,'401', NoOp # No such nick/chan. # ,'421', Unknown ,'433', NickInUse ,'482', NoOp # You're not chanop error ); sub Pong { if ($from eq $nick) {&Send("PONG $text\n");} } # Does not reply to non-server PINGs, as it is a popular flood method. sub NoOp { } sub NickInUse { $mynick .= "_"; &Send("NICK $mynick\n"); } sub Motd { print "[MOTD] $text\n"; } sub EndOfMotd { &Bot_Join($mychan) if ($mychan); } sub Invite { print "-$nick invites $param[0] to join $text-\n"; } sub Notice { print "-$nick:$param[0]- $text\n"; } sub Quit { $param[0] = "IRC ($text)"; &Part(); } sub Error { print "*** Error: $text\n"; close (IRC_SOCKET); } sub Unknown { print "-$from doesn't understand the command $param[1]-\n"; } sub Kick { print "[$nick has kicked $param[1] off of $param[0]"; print " ($text)" if $text; print "]\n"; if ( (lc($param[1])) eq (lc($mynick)) ) { &Send("JOIN $param[0]\n"); #rejoin on kick } # note that it will only try once per kick. This is so K-Bans will not # put Tinbot into an endless loop. } sub Topic { print "-$nick topic for $param[0]- $text\n" if ($debug >1); return if ($nick eq $mynick); if ($topichold{$param[0]}) { &Send("TOPIC $param[0] :$topic{$param[0]}\n"); &Send("PRIVMSG $nick :I've been told by $topichold{$param[0]} to ". "preserve this topic\n"); } else { $topic{$param[0]} = $text; } } sub Nick { print "[$nick is now known as $text]\n" if ($debug > 2); $lastseen{(lc($text))} = time; undef $lastseen{(lc($nick))}; $last_toy_nick = $text if ($last_toy_nick eq $nick); $last_sing_nick = $text if ($last_sing_nick eq $nick); if ($nick eq $mynick) { $mynick = $text; #return; #experimental: Tinbot doesn't keep track of it's own timejoin. } #$timejoin{(lc($text))} = $timejoin{(lc($nick))}; #experimental #undef $timejoin{(lc($nick))}; #experimental } sub Join { my $lcnick = lc($nick); next if ($nick eq $mynick); #ignoring done to avoid loops #$timejoin{$lcnick} = time; #experimental print "[$nick has joined $text]\n" if ($debug > 1); $lastseen{$lcnick} = time; if ($greet{$text} && ($cmd ne '353')) { foreach (split("\n",$greet{$text},3)) { s/\%n/$nick/g; &Send("NOTICE $nick :$_\n"); } } $_ = &User_Level(); if ($_ > 1) { &Send("MODE $text +o $nick\n"); } elsif ($_ < 0) { &Send("MODE $text -o $nick\nMODE $text +b $from\n". "KICK $text $nick :You've been blackballed.\n"); } } sub Part { print "[$nick has left $param[0]]\n" if ($debug > 1); $lastseen{(lc($nick))} = time; #$timecount{(lc($nick))} += (time - $timejoin{(lc($nick))}); #experimental } sub Privmsg { $lastseen{(lc($nick))} = time; $userlevel = &User_Level(); $text =~ s/^B/\*/og; # I think ^B chars surround emphisized words. if ($text =~ /^\x01/o) { # This is the CTCP part? ($ctcp,$waldo) = ($text =~ /\x01(\S+) ?(.*)\x01/o); $text =~ s/\x01.*\x01//o; if ($ctcp eq "ACTION") { print "<$nick:$param[0] $waldo>\n" if ($debug > 2); } elsif ($ctcp eq "PING") { &Send("NOTICE $nick :\x01PING $waldo\x01\n"); } elsif ($ctcp eq "DCC") { &Send("PRIVMSG $nick :I don't support DCC yet -- TinGoth might someday.\n");} elsif ($ctcp eq "VERSION") { &Send ("NOTICE $nick :\x01VERSION Tinbot :0.4c :'CheapTin' version.\n"); } elsif ($ctcp eq "CLIENTINFO") { # This should reply a space-separated list of accepted ctcp's. &Send("NOTICE $nick :\x01ACTION CLIENTINFO PING ". "SOURCE TIME USERINFO VERSION\x01\n"); } elsif ($ctcp eq "SOURCE") { &Send("NOTICE $nick :\x01SOURCE Ask Mozai at moses\@goth.org.\x01\n"); } elsif ($ctcp eq "TIME") {&Send("NOTICE $nick :\x01TIME ". &TimeStamp(time) ."\x01\n");} elsif ($ctcp eq "USERINFO") {&Send("NOTICE $nick :\x01USERINFO $mynick is a bot. " ."Ask Mozai (moses\@goth.org) formore info.\x01\n");} else {print "[$nick $ctcp $waldo]\n" if ($debug); } } return unless $text; print "<$nick:$param[0]> $text\n" if ($debug > 2); # --- Here is where the bot's private commands reside. if (($param[0] !~ /^$mynick$/i)) { if ($text =~ /$mynick(\W.*)?$/i) { # Someone mentioned the bot's name. } } else { #sent to the bot privately print "<$nick:$param[0]> $text\n" if $debug; if ($userlevel >= 0) { if ($text =~ /^LEVEL/io) { &Send("PRIVMSG $nick :Your level is $userlevel\n"); } elsif ($text =~ /^TIME/io) { &Send("PRIVMSG $nick :The time is ".&TimeStamp(time)."\n"); } elsif (($text =~ /^HEL\w/io) || ($text =~ /^HI(\W.*)?$/io)) { &Send("PRIVMSG $nick :$help0\n"); } } # end userlevel >= 0 # No commands for userlevel 1. if ($userlevel > 1) { if ($text =~ /^HEL/io) { &Send("PRIVMSG $nick :$help2\n"); } elsif ($text =~ /^TOPIC ([#&]\S+)( .+)/io) { $topic{$1} = $2; &Send("TOPIC $1 :$2\n"); } elsif ($text =~ /^TOPICLOCK ([#&]\S+)/io) { $topichold{$1} = ($topichold{$1} ? 0 : $nick); $waldo = ($topichold{$1} ? '' : 'un'); &Send("PRIVMSG $nick :Topic on $1 now $waldo"."locked\n"); } elsif ($text =~ /^MODELOCK ([#&]\S+)/io) { $modehold{$1} = ($modehold{$1} ? 0 : $nick); $waldo = ($modehold{$1} ? '' : 'un'); &Send("PRIVMSG $nick :Mode on $1 now $waldo"."locked\n"); } elsif ($text =~ /^KICK ([#&]\S+) (.+)/io) { &Send("KICK $1 $2 :Asked by $nick\n"); } elsif ($text =~ /^GREET ([#&]\S+)( (.*))?/io) { my $waldo; # enough of this 'modify read-only value' bullshit $waldo = $3; $waldo =~ s/\\n/\n/g; if ($waldo) { $greet{$1} = $waldo; } else { undef $greet{$1}; } $waldo =~ s/\n/*n/g; &Send("PRIVMSG $nick :Greeting set on $1: $waldo\n"); } elsif ($text =~ /^LEVEL (\S+!\S+\@\S+) (-?\d+)/io) { if ($2 > $userlevel) { &Send("PRIVMSG $nick :Not even you have level $2.\n"); } else { $userlist{$1} = $2; &Send("PRIVMSG $nick :$1 now at level $2.\n"); } } } # end userlevel >= 2 if ($userlevel > 2) { if ($text =~ /^QUIT/io) { &Bot_Quit("Told to quit by $nick."); } elsif ($text =~ /^NICK (\S+)/io) { &Send("NICK $1\n"); } elsif ($text =~ /^JOIN ([#&]\S+)/io) { &Bot_Join ($1); } elsif ($text =~ /^(LEAVE|PART) (\S+)/io) { &Send("PART $2\n"); } elsif ($text =~ /^HEL/io) { &Send("PRIVMSG $nick :$help3\n"); } elsif ($text =~ /^(SAY|MSG) (\S+) (.*)/io) # I know it's superfluous, but it looks nice. { &Send("PRIVMSG $2 :$3\n") unless ($2 =~ /$mynick/io);} elsif ($text =~/^(ME|ACTION|EMOTE) (\S+) (.*)/io) { &Send("PRIVMSG $2 :\x01ACTION $3\x01\n"); } elsif ($text =~ /^RAW (.*)/io) { &Send("$1\n"); } # Using RAW is powerful and potentially dangerous. } # end $userlevel 3 and above } # end private commands } sub Names { my $list = $text; $text = $param[2]; foreach (split(/\s+/,$list)) { # if /^\@/ { remember this nick has ops } s/^\@//o; #get rid of ops sign $nick = $_; &Join(); } } sub Mode { if (($nick !~ /($mynick|X|W)/) && ($modehold{$param[0]})) { $params =~ tr/+-/-+/; &Send("MODE $params\n"); &Send("PRIVMSG $nick :Mode on $param[0] locked by $modehold{$param[0]}\n"); return; } unless ( $param[1] =~/^[+-][bots+ -]+$/) { print "[$nick sets mode $text " .join(' ',@param)."]\n"; return; } if ($param[1] =~ /^\+/) { if ($param[1] =~ /b/i) { print "[$nick bans $param[2] from $param[0]]\n"; } if ($param[1] =~ /o/i) { print "[$nick gives ops to $param[2] on $param[0]]\n"; } if ($param[1] =~ /t/i) { print "[$nick locks the topic on $param[2]]\n"; } if ($param[1] =~ /s/i) { &Send("MODE $mynick -s\n"); print "*** Enough of this server message crap.\n"; } } elsif ($param[1] =~ /^\-/) { if ($param[1] =~ /b/i) { print "[$nick unbans $param[2] from $param[0]]\n";} if ($param[1] =~ /o/i) { print "[$nick removes ops from $param[2] on $param[0]]\n"; } if ($param[1] =~ /t/i) { print "[$nick allows the topic on $param[2] to be changed]\n"; } } } sub Open_Socket { # Expects something like ("irc.groovy.org",6667,\*SOCKET); # Thank you Michael S. Muegel for letting me # crib your notes, but I'm gonna use Socket.pm anyways. my ($server, $port, $socket) = @_; my ($iaddr,$paddr,$proto); if ($debug > 4) { $socket=\*STDIN; return;} if ($port =~ /\D/) {$port = getservbyname($port,'tcp');} $iaddr = inet_aton($server) or return "inet_aton:$!"; $paddr = sockaddr_in($port,$iaddr); $proto = getprotobyname('tcp'); socket($socket, PF_INET, SOCK_STREAM, $proto) or return "socket:$!"; connect($socket,$paddr) or return "connect:$!"; return; } sub Bot_Join { foreach (split(/,/,$_[0])) { &Send("JOIN $_\n"); } # &Send("NAMES $_\n"); # To make sure we get a NAMES list. if ($topichold{$_}) {&Send("TOPIC $_ :$topic{$_}\n"); } unless ($mychan =~ /$_[0]/i) { $mychan .= ",$_[0]"; } } $SIG{'TERM'} = 'SigKill'; $SIG{'INT'} = 'SigInt'; sub SigKill { $nick = "SYSTEM"; &Bot_Quit("Process terminated."); } sub SigInt { &Send("QUIT :Emergency shutdown; Ctrl-C received.\n"); print "Emergency Shutdown at ".scalar(time)."\n"; close(IRC_SOCKET); exit; } sub Bot_Quit { $stubborn = 0; &Send("QUIT :$_[0]\n"); print "Quitting (".&TimeStamp(time).":$_[0])...\n"; sleep(1); close(IRC_SOCKET); } sub Send { # make sure you don't send more than 1kb per second. return unless ($_[0] =~ /\w/o); #no more empty messages if (time > $lastsenttime) { $lastsenttime = time; $sentbytes = 0; } if ($debug > 3) { print "$_[0]"; return; } if (($sentbytes + length($_[0])) < 1024) { send (IRC_SOCKET,$_[0],0); print $_[0] if ($debug > 1); # quack } # This strategy means the bot won't always send -- a passive strategy. # An active strategy might be to ignore requests from # repeated messages (from same domain?) that are floodlike. # -Moses July 18/96 } sub User_Level { foreach $waldo (keys(%userlist)) { $_ = $waldo; s/\./\\\./go; s/\*/\.\*/go; if ($from =~ /^$_$/i) { return $userlist{$waldo}; } } return 0; } $waldo = (gethostbyname($waldo))[4]; foreach (split('',$waldo)) { $myhost.= ord() ."."; } srand; chop($myhost); open (FILE,">$pidfile"); print FILE $$; close(FILE); $myname = $mynick; $myname =~ s/\W//go; unless ($debug) { open(NULL,"/dev/null") || die "I can't open /dev/null??!!"; select(NULL); } $|++; # flush quickly $IRCserverq=0; $IRCportq = 0; while ($stubborn) { $IRCportq = ($IRCportq + 1) % (scalar(@IRCport)); sleep(1); if (! ($stubborn % $stubborn_pause)) { sleep(10); $IRCserverq = ($IRCserverq + 1) % (scalar(@IRCserver)); print "Attempting $IRCserver[$IRCserverq]\n" if ($debug); } if ($stubborn > 1) { print "Attempt #$stubborn...\n"; } print "Attempting $IRCserver[$IRCserverq],$IRCport[$IRCportq]\n" if $debug; $waldo = &Open_Socket($IRCserver[$IRCserverq],$IRCport[$IRCportq],IRC_SOCKET); # die($waldo) if $waldo; if ($waldo) { print "$waldo\n"; $stubborn++; } next if ($waldo && $stubborn); &Send("PASS $IRCpassword\n",0) if $IRCpassword; &Send("USER $myname $myhost $IRCserver[$IRCserverq] Tinbot v0.4b\n"); &Send("NICK $mynick\n"); # Hello, and welcome to the main loop. MAIN: while () { s/[\x0D\x0A]+$//o; # get rid of the CR/LF pair. next unless $_; # damned annoying to respond to empty lines $raw = $_; # used by other debugging statements, labeled "quack" #print "$raw\n" if ($debug > 2); #quack ($waldo,$from,$cmd,$params,$waldo,$text) = /^(:([^ ]+) )?(\S+) ([^:]+)*(:(.*))?/o; # $1 just in case there's no origin, and $5 is in case someone fucked up. # $2 is source, $3 is command, $4 is space-separated params, $6 is data. $user = ''; # to get perl -w to SHUT UP! ($nick,$user,$host) = ($from =~ /([^!]+)!([^@]+)\@(.+)/io); if ($nick && ($last_domain{$host} >= (time+1))) { # parse only one message per 2 seconds from a particular host. print "*** Flood! from $from\n" if ($debug && $params[0]=~/^$mynick/i); } else { $last_domain{$host} = time ; @param = split (' ',$params); # $param[0] is usually the intended target of the command in $cmd. $waldo = $parse{$cmd}; if (($debug > 3) && ($raw =~ /^EVAL\s+(.+)/io)) { eval $1; } # Very fucking dangerous if ($waldo) { &{$waldo}(); } # Perl5's version of "do $waldo();" else { print "$raw\n" if ($debug); } #quack - the bot ignores nonparsed. print "$raw\n" if (/$mynick/i); #quack - record poss. error messages? } } close(IRC_SOCKET); # force a &Part for each nick that was joined at the time? #foreach (keys(%timejoin)) { #experimental #if ($timejoin{$_}) { #$timecount{$_} += ($timejoin{$_} - time) ; #undef $timecount{$_}; #} #} $stubborn++ if $stubborn; } unlink ($pidfile); sleep 1; # because I need some sleep. -Moses Feb 29/96