view release on metacpan or  search on metacpan

lib/Alice/Role/Commands.pm  view on Meta::CPAN

package Alice::Role::Commands;

use Any::Moose 'Role';

use List::MoreUtils qw/none/;
use Try::Tiny;
use Class::Throwable qw/NetworkRequired InvalidNetwork ChannelRequired
                        InvalidArguments UnknownCommand/;

our %COMMANDS;
my $SRVOPT = qr/\-(\S+)\s*/;

sub commands {
  return grep {$_->{eg}} values %COMMANDS;
}

sub irc_command {
  my ($self, $req) = @_;

  try {
    my ($command, $args) = $self->match_irc_command($req->line);
    if ($command) {
      $self->run_irc_command($command, $req, $args);
    }
    else {
      throw UnknownCommand $req->line ." does not match any known commands. Try /help";
    }
  }
  catch {
    $req->reply("$_");
  }
}

sub match_irc_command {
  my ($self, $line) = @_;

  $line = "/say $line" unless substr($line, 0, 1) eq "/";

  for my $name (keys %COMMANDS) {

    if ($line =~ m{^/$name\b\s*(.*)}) {
      my $args = $1;
      return ($name, $args);
    }
  }
}

sub run_irc_command {
  my ($self, $name, $req, $args) = @_;
  my $command = $COMMANDS{$name};
  my $opts = [];

  # must be in a channel
  my $type = $req->window->type;
  if ($command->{window_type} and none {$_ eq $type} @{$command->{window_type}}) {
    my $types = join " or ", @{$command->{window_type}};
    throw ChannelRequired "Must be in a $types for /$command->{name}.";
  }

  my $network = $req->window->network;

  # determine the network can be overridden
  if ($command->{network} and $args =~ s/^$SRVOPT//) {
    $network = $1;
  }

  # command requires a connected network
  if ($command->{connection}) {
    throw NetworkRequired $command->{eg} unless $network; 

    my $irc = $self->get_irc($network);

    throw InvalidNetwork "The $network network does not exist."
      unless $irc;

    throw InvalidNetwork "The $network network is not connected"
      unless $irc->is_connected;

    $req->irc($irc);
  }

  # gather any options
  if (my $opt_re = $command->{opts}) {
    if (my (@opts) = ($args =~ /$opt_re/)) {
      $opts = \@opts;
    }
    else {
      throw InvalidArguments $command->{eg};
    }
  }

  $command->{cb}->($self, $req, $opts);
}

sub command {
  my ($name, $opts) = @_;

  if ($opts) {
    $COMMANDS{$name} = $opts;
  }

  return $COMMANDS{$name};
}

command say => {
  name => "say",
  window_type => [qw/channel privmsg/],
  connection => 1,
  eg => "/SAY <msg>",
  opts => qr{(.+)},
  cb => sub {
    my ($self, $req, $opts) = @_;

    my $msg = $opts->[0];
    $self->send_message($req->window, $req->irc->nick, $msg);
    $req->irc->send_long_line(PRIVMSG => $req->window->title, $msg);
  },
};

command msg => {
  name => "msg",
  opts => qr{(\S+)\s*(.*)},
  eg => "/MSG [-<network>] <nick> [<msg>]",
  desc => "Sends a message to a nick.",
  connection => 1,
  network => 1,
  cb => sub  {
    my ($self, $req, $opts) = @_;

    my ($nick, $msg) = @$opts;

    my $new_window = $self->find_or_create_window($nick, $req->irc);
    $self->broadcast($new_window->join_action);

    if ($msg) {
      $self->send_message($new_window, $req->nick, $msg);
      $req->send_srv(PRIVMSG => $nick, $msg);
    }
  }
};

command nick => {
  name => "nick",
  opts => qr{(\S+)},
  connection => 1,
  network => 1,
  eg => "/NICK [-<network>] <new nick>",
  desc => "Changes your nick.",