# triggers for officebot -*-CPerl-*-
#
# Waider, May 2004
use Storable;
use WWW::Mechanize;

# Message database
sub MESSAGES () { PRIVDIR() . "/irc.messages.db" }

# new factoid brane. silly waider, don't tie.
sub FACTS () { PRIVDIR() . "/facts.db" }

# check if something is in the ticket database
sub check_ticket {
    my $reply = "";
    my $s = shift;
    my $q = shift;

    # fixme: cache this lad
    my $agent = WWW::Mechanize->new( env_proxy => 1, autocheck => 1 );
    $agent->agent_alias( 'Windows IE 6' );

    # fixme: from configuration
    $agent->get( $config{ticketing}->{$s}->{site} );

    # identify the ticketing system
    my $content = $agent->content;

    if ( $content =~ /welcome to otrs/is ) {
        $agent->set_visible( $config{ticketing}->{$s}->{username},
                             $config{ticketing}->{$s}->{password} );
        $agent->click_button( number => 1 );

        $content = $agent->content;

        if ( $content =~ /home/is ) {
            $agent->follow_link( text_regex => qr /utilities/i );
            $content = $agent->content;

            if ( $q =~ /^\d+$/ ) {
                $agent->set_visible( $q );
                $agent->click_button( number => 1 );
            } else {
                $agent->form( 2 );
                $agent->set_visible( $q );
                $agent->click_button( number => 1 );
            }

            $content = $agent->content;

            if ( $content =~ /<b>Subject:.*?td> (.*?)<\/td>/is ) {
                my $sub = $1;
                $sub =~ s/<.*?>//g;
                $reply = "$q is $sub; (more at ";
                $reply .= $agent->uri;
                $reply .= ")";
            } else {
                $reply = "I didn't find anything matching '$q' in $s";
            }
        } else {
            $reply = "I can't seem to log into $s!";
        }
    } elsif ( $content =~ /bugzilla/ ) {
        $agent->follow_link( text_regex => qr/log in to/i );
        $content = $agent->content;
        if ( $content !~ /legitimate/is ) {
            $reply = "I can't get to the login page for $s!";
        } else {
            if ( defined( $config{ticketing}->{$s}->{username} )) {
                $agent->set_visible( $config{ticketing}->{$s}->{username},
                                     $config{ticketing}->{$s}->{password} );
                $agent->click_button( number => 1 );
                $content = $agent->content;
            }

            # fixme this is a bad string to search for. should check
            # for the "enter a bug #" form.
            if ( $content !~ /search for bugs/is ) {
                $reply = "I can't seem to log into $s. Try " .
                  $config{ticketing}->{$s}->{site} .
                    "show_bug.cgi?id=" . $q;
            } else {
                if ( $q =~ /^\d+$/ ) {
                    my @forms = $agent->forms;
                    $agent->form( scalar( @forms )); # last form
                    $agent->field( "id", $q );
                    $agent->click_button( number => 1 );
                } else {
                    $reply = "harrass waider to do full-text searches on bugzilla!";
                }

                $content = $agent->content;

                if ( $q =~ /^\d+$/ ) {
                    my ( $sub ) =
                      $content =~ /input.*?short_desc.*?value="([^"]+)"/is;
                    $reply = "$q is $sub; (more at ";
                    $reply .= $agent->uri;
                    $reply .= ")";
                }
            }
        }
    } else {
        $reply = "I don't know how to log into $s!";
    }

    $reply;
}

sub remember {
    my ( $subject, $negate, $fact, $teller, $hearsay ) = @_;

    # don't learn non-subjects!
    return if $subject =~ /^\s*$/;

    print STDERR "Learning from $teller that $subject is$negate $fact\n"
      if $config{debug};

    $subject = lc( $subject );

    my %facts;
    $heap->{facts} = retrieve( FACTS ) if -e FACTS;
    $heap->{facts} = {} if ! -e FACTS;
    if ( defined( $heap->{facts}->{$subject})) {
        %facts = %{$heap->{facts}->{$subject}};
    }

    if ( $negate ) {
        delete $facts{$fact};
    } else {
        if ( %facts ) {
            if ( exists( $facts{$fact} )) {
                return $facts{$fact}->[1] . " already told me that!"
                  if $hearsay;
            }
        }

        $facts{$fact} = [ 1, $teller, $hearsay ? "" : "hearsay" ];
    }

    if ( %facts ) {
        $heap->{facts}->{$subject} = \%facts;
    } else {
        delete $heap->{facts}->{$subject};
    }

    if ( store $heap->{facts}, FACTS ) {
        return "noted." if $hearsay;
    } else {
        return "errr. I can't remember that. ($!)" if $hearsay;
    }

    "";
}

$config{'triggers'} =
  [
   [ '^%b:\s*8ball',
     # see http://8ball.ofb.net/answers.html
     [
      'Signs point to yes.',
      'Yes.',
      'Reply hazy, try again.',
      'Without a doubt.',
      'My sources say no.',
      'As I see it, yes.',
      'You may rely on it.',
      'Concentrate and ask again.',
      'Outlook not so good.',
      'It is decidedly so.',
      'Better not tell you now.',
      'Very doubtful.',
      'Yes - definitely.',
      'It is certain.',
      'Cannot predict now.',
      'Most likely.',
      'Ask again later.',
      'My reply is no.',
      'Outlook good.',
      'Don\'t count on it.',
     ],
   ],

   [ '(.*) (thwaps|hits|slaps|kicks|bites) %b',
     [ 'ow!', 'neener! didn\'t hurt!' ],
   ],

   [ '^(%b: thanks|thanks[, ]+%b|(.*)\s+thanks (the\s+)?%b)',
     [ 'you\'re welcome!', 'no problem!', 'np', 'no problemo', 'any time' ], ],

   [ '^(%b:\s*(hi|hello|hey( there))|(hi|hello|hey( there))[, ]+%b)',
     [ 'hi, %n', 'hi', 'hello', 'yo' ], ],

   [ '^(.*)\s+gives (the\s+)?%b a cookie', '/me thanks %1 and eats the cookie.' ],
   [ '^(.*)\s+gives (the\s+)?%b ((some|a (\w+) of) )?coffee', '/me quaffs it and buzzes alarmingly.' ],
   [ '^(.*)\s+gives (the\s+)?%b', '/me thanks %1 and looks puzzled.' ],
   [ '^(.*)\s+fixes a bug' => '/me cheers for %1!' ],
   [ '^(.*)\s+hi(gh)?\-?5\'?s (the )?%b', '%1: word!' ],
   [ '^(.*)\s+pats (the )?%b on the head', '/me beeps happily.' ],

   [ '^%b: give (.*)\s+to\s+(.*)$', '/me gives %2 %1' ],

   # slightly more complex version - tries to recognise "give foo a bar"
   [ '^%b: give\s+(.*)$',
     sub {
         my ( $msg, $nick, $where, @dollar ) = @_;
         my $session = $poe_kernel->get_active_session();
         my $heap = $session->get_heap();
         my %channels = %{$heap->{channel_data}};
         my @names;

         if ( defined( $channels{$where->[0]}->{names})) {
             @names = @{$channels{$where->[0]}->{names}};
         }

         # simple case
         if ( $dollar[0] =~ /^me\b/i ) {
             $dollar[0] =~ s/^me//i;
             return "/me gives $nick$dollar[0]";
         }

         for my $n ( @names ) {
             if ( $dollar[0] =~ /^$n\b/i ) {
                 $dollar[0] =~ s/^$n\b//i;
                 return "/me gives $n$dollar[0]";
             }
         }
     },
   ],

   [ '^(.*)\s+(hugs|kisses|smoochi?es) (the )?%b', '/me blushes' ],

   # we're doomed (1 in 5 chance of reacting)
   [ 'doomed', [ "aie! doomed!", "", "", "", "", "" ]],

   # the classics
   [ '^%b: slap\s+me\b', '/me slaps %n with a fish.' ],
   [ '^%b: slap\s+(.+)', '/me slaps %1 with a fish.' ],
   [ '^%b: mock\s+me\b', '/me points at %n and laughs.' ],
   [ '^%b: mock\s+(.+)', '/me points at %1 and laughs' ],

   # not a classic at all.
   [ '^%b: fondle\s+me\b', '/me glares at %n disapprovingly' ],
   [ '^%b: fondle\s+(.+)', "/me melts %1's cheese" ],

   # respond to "help"
   [ '%b: help',
     [ '%n: RTFS', '%n: do I *look* like a helpdesk?',
       '%n: how about you submit a ticket for that?', ], ],


   # more complex stuff
   [ '^%b: rot13\s+(.+)',
     sub {
         my ( $msg, $nick, $where, @dollar ) = @_;
         my $inp = $dollar[0];
         my $rot13 = $inp;
         $rot13 =~ tr[a-zA-Z][n-za-mN-ZA-M];
         "I rot13'd $inp and got $rot13";
     },
   ],

   # Dime bar! yay!
   [ "\^%b:\\s*you're a bit thick, aren't you?", "I loikes armadillos!" ],

   [ '^(go %b!|%b: go you!)$', 'yay! go me!' ],

   [ '^%b(!\s*$|: abuse\s+(me\b|.+))',
     sub {
         my ( $msg, $nick, $where, @dollar ) = @_;
         my $session = $poe_kernel->get_active_session();
         my $heap = $session->get_heap();
         my $target = $dollar[1];
         if ( !defined( $target )) {
             $target = "kevin";
         }
         if ( $target eq "me" ) {
             $target = $nick;
         }
         my $req = new HTTP::Request GET => 'http://www.pangloss.com/seidel/Shaker/';
         my @queue;
         @queue = @{$heap->{abuseme}} if defined( $heap->{abuseme} );
         push @queue, [ $target, $where ];
         $heap->{abuseme} = \@queue;
         $poe_kernel->post( 'ua', 'request', 'abuse', $req );
         return "/me requests some abuse for $target." if $config{'debug'};
         "";
     },
   ],

   # talk like ye pirates
   [ '^%b:\s+pirate\s+(.+)$',
     sub {
         my ( $msg, $nick, $where, @dollar ) = @_;
         my $kernel = $poe_kernel;
         my $session = $kernel->get_active_session();
         my $heap = $session->get_heap();
         # this is busted.
         my $req = new HTTP::Request GET => 'http://www.fissio.com/pirate.pl?text=' . uri_escape( $dollar[0] );
         my @queue;
         @queue = @{$heap->{pirate}} if defined( $heap->{pirate});
         push @queue, [ $where ];
         $heap->{pirate} = \@queue;
         $kernel->post( 'ua', 'request', 'pirate', $req );
         return "/me requests a piratical translation." if $config{'debug'};
         "";
     },
   ],

   # respond to questions about lunch
   [ 'is it (lunch(\s*time)?|time (to go to|(to go )?for) lunch)(\s*yet)?',
     sub {
         my $sdlt = (12 * 60) + 20; # sdlt = Stella-Designated Lunch Time.
         my $sdlt_window = 20;
         my $sdlt_leeway = 60;
         my @too_early = ( "back to work, slacker.",
                           "I'll say when it's lunch time, %n.",
                           "yeah, maybe in Tokyo or something." );
         my @early_lunch = ( "you must be hungry today",
                             "it's a little early for me, I'll go later",
                             "lunch?  It's only breakfast time for me!" );
         my @lunch = ( "soon!",
                       "almost!",
                       "mmm, lunch!",
                       "nearly!",
                       "close enough, who's driving?" );
         my @late_lunch = ( "yeah ... ToGo will have run out of curry though",
                            "didn't realise it was so late.  Better run." );
         my @too_late = ( 'sorry, %n, you missed it!',
                          'ooh, look at the time.',
                          'sure. tomorrow.' );

         # XXX get time from channel we're connected to
         my ($min, $hour) = (gmtime( time + 3600 ))[1,2];
         my $now = ($hour * 60) + $min;

         if ( $now < ($sdlt - $sdlt_leeway) ) {
             return $too_early[ int(rand(scalar(@too_early)))];
         } elsif ( $now <= ($sdlt - $sdlt_window) ) {
             return $early_lunch[ int(rand(scalar(@early_lunch)))];
         } elsif ( ($now >= ($sdlt - $sdlt_window)) &&
                   ($now <= ($sdlt + $sdlt_window)) ) {
             return $lunch[ int(rand(scalar(@lunch)))];
         } elsif ( $now <= ($sdlt + $sdlt_leeway) ) {
             return $late_lunch[ int(rand(scalar(@late_lunch)))];
         } elsif ( $now > ($sdlt + $sdlt_leeway) ) {
             return $too_late[ int(rand(scalar(@too_late)))];
         }
         return "Urk!  I'm broken!  You go off to lunch, I've to debug myself";
     },
   ],

   [ '^%b:\s*ticket\s+(\w+)\s+(.+)\s*$',
     sub {
         my ( $msg, $nick, $where, @dollar ) = @_;
         my $reply = "";

         my $sys = $dollar[0];
         my $what = $dollar[1];

         if ( !defined( $config{'ticketing'})) {
             $reply = "I'm not set up for ticketing\n";
         } else {
             if ( !defined( $config{'ticketing'}->{$sys})) {
                 $reply = "I don't know anything about the $sys ticketing system\n";
             } else {
                 $reply = check_ticket( $sys, $what );
             }
         }

         return $reply;
     }
   ],

   # factoids!
   [ '^%b:\s*(what\'s|what\s+is|tell\s+me\s+about)\s+(.+?)$',
     sub {
         my ( $msg, $nick, $where, @dollar ) = @_;

         # don't care what triggered it
         shift @dollar;

         $dollar[0] =~ s/\s*$//;
         $dollar[0] =~ s/\s+/ /g;

         $dollar[0] = lc( $dollar[0]);

         my %facts;
         $heap->{facts} = retrieve( FACTS ) if -e FACTS;
         if ( defined( $heap->{facts}->{$dollar[0]})) {
             %facts = %{$heap->{facts}->{$dollar[0]}};
         }

         if ( !%facts ) {
             $dollar[0] =~ s/\?*$//;
             %facts = %{$heap->{facts}->{$dollar[0]}};
         }

         if ( %facts ) {
             my $reply = "";
             for my $f ( keys %facts ) {
                 if ( $facts{$f}->[2] || "" ) {
                     next;      # SKIP HEARSAY FOR NOW
                     $reply .= "I hear that ";
                 }
                 $reply .= $dollar[0] . " is " . $f . "\n";
             }
             $reply =~ s/\n$//s;
             return $reply if $reply;
         }

         return "I know nothing about " . $dollar[0];
     },
   ],

   [ '^%b:\s*who\s*(told\s*you|said)\s*(that)?\s*(\w+)\s*is\s*(.*)$',
     sub {
         my ( $msg, $nick, $where, @dollar ) = @_;

         # lose the optional bits
         shift @dollar;
         shift @dollar;

         $dollar[0] =~ s/\s*$//;
         $dollar[0] =~ s/\s+/ /g;

         my %facts;
         $heap->{facts} = retrieve( FACTS ) if -e FACTS;
         if ( defined( $heap->{facts}->{$dollar[0]})) {
             %facts = %{$heap->{facts}->{$dollar[0]}};
         }

         if ( !%facts ) {
             $dollar[0] =~ s/\?*$//;
             %facts = %{$heap->{facts}->{$dollar[0]}};
         }

         if ( %facts ) {
             my $reply = "";
             for my $f ( keys %facts ) {
                 next if $f ne $dollar[1];
                 if ( $facts{$f}->[2] || "" ) {
                     $reply = "I heard " . $facts{$f}->[1] . " say that.";
                 } else {
                     $reply = $facts{$f}->[1] . " told me that";
                 }
             }
             return $reply if $reply;
         }

         return "I know nothing about " . $dollar[0];
     },
   ],

   [ '^(%b:)?\s*(.*?)\s+is(n\'t|\s+not)?\s+(.*?)$',
     sub {
         my ( $msg, $nick, $where, @dollar ) = @_;
         my $negate;

         my $told = shift @dollar; # hearsay hook
         # we can't trim $dollar[2] because it'll break URLs

         $dollar[0] =~ s/\s*$//;
         $dollar[0] =~ s/\s+/ /g;

         remember( $dollar[0], $dollar[1], $dollar[2], $nick, $told );
     } ],

   [ '^%b:\s*memdump',
     sub {
         my ( $msg, $nick, $where, @dollar ) = @_;

         my %facts;
         $heap->{facts} = retrieve( FACTS ) if -e FACTS;

         my $reply = "=================== memdump\n";
         use Data::Dumper;
         $reply .= Dumper( $heap->{facts} );
         $reply . "=================== end\n";
     },
   ],

   [ '^%b:\s*forget\s+about\s+(.*?)$',
     sub {
         my ( $msg, $nick, $where, @dollar ) = @_;

         $dollar[0] =~ s/\s*$//;
         $dollar[0] =~ s/\s+/ /g;

         $heap->{facts} = retrieve( FACTS ) if -e FACTS;
         $heap->{facts} = {} if ! -e FACTS;
         if ( defined( $heap->{facts}->{$dollar[0]})) {
             delete $heap->{facts}->{$dollar[0]};
             if ( store $heap->{facts}, FACTS ) {
                 return "ok!";
             } else {
                 return "like an elephant, I can't forget ($!)";
             }
         } else {
             return "I know nothing about '" . $dollar[0] . "'";
         }
     },
   ],

   # reload the bot's brane from IRC logs
   [ '^%b:\s*learn from (.*)$',
     sub {
         my ( $msg, $nick, $where, @dollar ) = @_;
         my $channel = $dollar[0];
         my $negate = 0;

         if ( open( LLOG, "<" . PRIVDIR . "/#$channel\.log" )) {
             print STDERR "Learning from $channel\n";
             my $count = 0;
             while (<LLOG>) {
                 $count ++;
                 s/^\[.*?\] //; # remove datestamping

                 next unless
                   m/^<(.*?)> ($config{botnick}:)?\s*(.*?)\s+is(n\'t|\s+not)?\s+(.*?)$/;

                 next if lc($3) eq "what";

                 ( $nick, @dollar ) = ( $1, $3, $4, $5, $2 );

                 $dollar[0] =~ s/\s*$//;
                 $dollar[0] =~ s/\s+/ /g;

                 remember( $dollar[0], $dollar[1], $dollar[2], $nick, $dollar[3] );
             }
             close( LLOG );
             return "Read $count lines from #$channel.log";
         } else {
             return "I don't appear to have a log for #$channel!";
         }
     }
   ],

   # messages
   [ '^%b:\s*tell\s+(\w+)\s+(.*)$',
     sub {
         my ( $msg, $nick, $where, @dollar ) = @_;
         my $kernel = $poe_kernel;
         my $session = $kernel->get_active_session();
         my $heap = $session->get_heap();
         my $reply = "";
         my ( $recip, $tell) = ( $dollar[0], $dollar[1] );

         if ( $recip =~ /\sme\s/i ) {
             $recip = $nick;
         }

         # fixme: if the user is logged in (and not 'me') then we
         # should just hand off the message directly.

         my @messages;
         my $ts = localtime( time );
         $heap->{messages} = retrieve( MESSAGES ) if -e MESSAGES;
         if (defined( $heap->{messages}->{$recip})) {
             @messages = @{$heap->{messages}->{$recip}};
         }
         if ( $tell ) {
             push @messages, "At $ts, $nick asked me to tell you $tell\n";
             $heap->{messages}->{$recip} = \@messages;
             if ( store $heap->{messages}, MESSAGES ) {
                 $reply = "/me makes a note of it.";
             } else {
                 $reply = "Hmm. You'd better tell 'em yourself, because I can't seem to remember anything. ". $!;
             }
         } else {
             $reply = "tell 'em what?";
         }
         $reply;
     },
   ],

   [ '^%b:\s*any messages\??',
     sub {
         my ( $msg, $nick, $where, @dollar ) = @_;
         my $kernel = $poe_kernel;
         my $session = $kernel->get_active_session();
         my $heap = $session->get_heap();
         my $reply = "Nope!";
         $heap->{messages} = retrieve( MESSAGES ) if -e MESSAGES;
         if ( defined( $heap->{messages}->{$nick})) {
             $reply = "Messages for you!\n" .
               join( "\n", @{$heap->{messages}->{$nick}}) . "\nAnd that's it.";
             delete $heap->{messages}->{$nick};
             store $heap->{messages}, MESSAGES;
         }

         "/msg $nick $reply";
     }
   ],

   # puppet on a string
   [ '%b:\s*puppet\s+(.+)\s+on\s(.+)',
     sub {
         my ( $msg, $nick, $where, @dollar ) = @_;
         my $kernel = $poe_kernel;
         my $session = $kernel->get_active_session();
         my $heap = $session->get_heap();

         my $action = $dollar[0];
         my $channel = $dollar[1];

         if ( !defined( $heap->{channel_data}->{$channel})) {
             return "/msg $nick I'm not on $channel!";
         }

         # direct results to a specific channel
         if ( $action =~ /\s*says,?\s*/i ) {
             $action =~ s/\s*says,?\s*//i;
             return [ $action, $channel ];
         }

         return [ "/me $action", $channel ];
     }
   ],

   [ '%b:\s*quote(\s+(.*))?$',
     sub {
         my ( $msg, $nick, $where, @dollar ) = @_;

         my $about = $dollar[1];

         # uck
         my $quotes = `wget -O - -q http://www.waider.ie/misc/quotes.txt`;

         # ditch the header
         $quotes =~ s/^.*----\n//s;

         # split into individual quotes
         my @quotes = split( "\n\n", $quotes );

         if ( defined( $about )) {
             @quotes = grep /${about}/is, @quotes;
         }

         if ( !@quotes ) {
             if ( defined( $about )) {
                 push @quotes,
                   "I have nothing to say on the subject of '$about'";
             } else {
                 push @quotes,
                   "I have nothing to say about anything";
             }
         }

         # now pick one
         my $point = int( rand( $#quotes ));
         my $q = $quotes[$point];

         "$q";
     },
   ],

   # weighted against saying nothing 3:2
   [ '\w+.*\b%b\b', [ "/me twitches.", "/me's ears burn", "", "", "" ], ],

   # stupid internet memes! yay!
   [ "(%b:\s*)?(badgers?\s*)+",
     [ "mushroom mushroom", "mushroom mushroom", "mushroom mushroom",
       "argh snake argh snake snake oooooh it's a snake" ],
   ],
  ];

1;