An early version of Toastr.pm

toaster.pl

#!/usr/bin/env perl

package Toastr;
use Mojo::Base 'Mojo::IRC';

BEGIN { $ENV{ANY_MOOSE} = 'Moose' }
use Hailo;
use Mojo::UserAgent;
use Mojo::Collection 'c';
use DBM::Deep ();
use IRC::Utils ();

has brain => 'toastr.db';
has hal => sub { Hailo->new( brain => shift->brain ) };
has karma => sub { DBM::Deep->new( shift->karma_file ) };
has karma_file => 'karma.db';
has nick_ptn => sub { qr/\b([a-z_\-\[\]\\^{}|`]+)\b/i };
has toast_images => sub { c() };
has toast_messages => sub { c(
    'mmmmmm toast.',
    'A toast!',
    'Somebody wants toast?',
    'Toast here!',
    q[What's all this about toast?],
)};
has toast_sites => sub {[
  'http://memebase.cheezburger.com/tag/toast/page/1',
  'http://memebase.cheezburger.com/tag/toast/page/2',
  'http://memebase.cheezburger.com/tag/toast/page/3',
]};
has ua => sub { Mojo::UserAgent->new };

sub get_toast_images {
  my ($irc, $site) = @_;
  $site ||= shift @{ $irc->toast_sites };
  unless ($site) {
    $irc->toast_images( $irc->toast_images->compact->uniq );
    return;
  }
  my $c = $irc->toast_images;
  $irc->ua->get( $site => sub {
    my ($ua, $tx) = @_;
    my $images = $tx->res->dom('.event-item-lol-image')->pluck(attr => 'src');
    push @$c, @$images;
    $irc->get_toast_images;
  });
}

sub msg { shift->write( privmsg => shift, ":@_" ) }

sub parse_user { IRC::Utils::parse_user($_[1]->{prefix}) }

sub start {
  my ($irc, $chans) = @_;
  $irc->register_default_event_handlers;

  $irc->on( irc_privmsg => \&_privmsg );

  $irc->on( toastr_direct_message => sub {
    my ($irc, $text, $chan, $msg) = @_;
    if ($text =~ /\?/) {
      my $reply = $irc->hal->reply($text);
      $irc->msg( $chan => $reply ) if $reply;
    } elsif ($text =~ s/^\+//) {
      $irc->hal->learn($text);
    }
  }) if $irc->hal;

  if ( $irc->karma ) {
    $irc->on( toastr_karma_up => sub {
      my ($irc, $user, $chan, $msg) = @_;
      $irc->karma->{$user}++;
    });

    $irc->on( toastr_karma_down => sub {
      my ($irc, $user, $chan, $msg) = @_;
      $irc->karma->{$user}--;
    });

    $irc->on( toastr_karma_query => sub {
      my ($irc, $user, $chan, $msg) = @_;
      if ($user eq '__leaders__' && $chan !~ /^#/) { # no __leaders__ in room
        my $leaders = $irc->_leaderboard;
        $irc->msg( $chan, $leaders );
        return;
      }
      my $karma = $irc->karma->{$user} || 'no';
      $irc->msg( $chan, "$user has $karma karma" );
    });
  }

  if ( $irc->toast_messages ) {
    $irc->on( toastr_toast => sub {
      my ($irc, $text, $chan, $msg) = @_;
      $irc->_toast($chan);
    });
    $irc->get_toast_images; # populate (once the iolooop starts)
  }

  $irc->on( irc_error => sub { warn $_[1] });

  $irc->connect(sub{
    my ($irc, $err) = @_;
    return warn $err if $err;
    $irc->write( join => $_ ) for @$chans;
  });

  $irc->ioloop->start;
}

sub _privmsg {
  my ($irc, $msg) = @_;
  my ($chan, $text) = @{ $msg->{params} };

  my $nick_ptn = $irc->nick_ptn;
  my $nick = $irc->nick;
  my $is_pm = 0;

  if ($chan eq $nick) {
    $chan = $irc->parse_user($msg);
    $is_pm = 1;
  }

  if ($text =~ /$nick_ptn\+\+/) {
    $irc->emit( toastr_karma_up => $1, $chan, $msg );
  }

  if ($text =~ /$nick_ptn\-\-/) {
    $irc->emit( toastr_karma_down => $1, $chan, $msg );
  }

  if ($text =~ s/^\Q$nick\E\S*\s*// or $is_pm) {
    if ($text =~ /karma\s+$nick_ptn/) {
      $irc->emit( toastr_karma_query => $1, $chan, $msg );
      return; # karma queries do not trigger direct message event
    }
    $irc->emit( toastr_direct_message => $text, $chan, $msg );
  }

  if ($text =~ /toast/) {
    $irc->emit( toastr_toast => $text, $chan, $msg );
  }

}

sub _leaderboard {
  my ($self) = @_;
  my $karma = $self->karma;
  my $leaders = join ', ', 
    map  { "$_->[0]: $_->[1]" }
    sort { $b->[1] <=> $a->[1] }
    map  { [ $_ => $karma->{$_} ] }
    keys %$karma;
  return $leaders;
}

sub _toast {
  my ($irc, $chan) = @_;
  my $prefix = $irc->toast_messages->shuffle->[0];
  my $image  = $irc->toast_images->shuffle->[0];
  $irc->msg( $chan => "$prefix $image" );
}

package main;
my $toastr = Toastr->new(
  nick   => 'toastr',
  user   => 'toastr bot',
  server => 'irc.perl.org:6667', 
);

$toastr->start(['#mojo', '#galileo']);