Dispatcher.pm

   1 #**************************************************************************
   2 #   Copyright (C) 2009 by Michael Andreen <harvATruinDOTnu>               *
   3 #                                                                         *
   4 #   This program is free software; you can redistribute it and/or modify  *
   5 #   it under the terms of the GNU General Public License as published by  *
   6 #   the Free Software Foundation; either version 2 of the License, or     *
   7 #   (at your option) any later version.                                   *
   8 #                                                                         *
   9 #   This program is distributed in the hope that it will be useful,       *
  10 #   but WITHOUT ANY WARRANTY; without even the implied warranty of        *
  11 #   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the         *
  12 #   GNU General Public License for more details.                          *
  13 #                                                                         *
  14 #   You should have received a copy of the GNU General Public License     *
  15 #   along with this program; if not, write to the                         *
  16 #   Free Software Foundation, Inc.,                                       *
  17 #   51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.         *
  18 #**************************************************************************/
  19
  20 package NDIRC::Dispatcher;
  21 use strict;
  22 use warnings;
  23 use feature ':5.10';
  24
  25 use Moose;
  26 use Symbol;
  27 use Set::Object ();
  28
  29 use NDIRC::Command;
  30
  31
  32 has commands => (
  33         is => 'ro',
  34         isa => 'HashRef[Object]',
  35         default => sub{ {} },
  36 );
  37
  38 has channels => (
  39         is => 'ro',
  40         isa => 'HashRef[ArrayRef[Str]]',
  41         default => sub{ {} },
  42 );
  43
  44 has targets => (
  45         is => 'ro',
  46         isa => 'HashRef[Str]',
  47         default => sub{ {} },
  48 );
  49
  50 sub load {
  51         my $self = shift;
  52
  53         for (@_){
  54                 my $class = "NDIRC::Commands::$_";
  55                 my $file = "NDIRC/Commands/$_.pm";
  56                 Symbol::delete_package($class);
  57
  58                 unless (my $return = do $file){
  59                         warn "couldn't parse $file: $@" if $@;
  60                         warn "couldn't do $file: $!"    if $!;
  61                         warn "couldn't run $file"       unless $return;
  62                 }else {
  63                         say "\nLoading $class";
  64                         $self->load_class($class);
  65
  66                 }
  67         }
  68 }
  69
  70 sub load_class {
  71         my ($self,$class) = @_;
  72
  73         my @subs = eval "$class->meta->get_method_list";
  74         for my $c (@subs){
  75                 my $attr = eval "$class->meta->get_method('$c')->attributes";
  76                 if (@$attr){
  77                         print "Command: $c ";
  78                         my %c = (channels => ['all']);
  79                         my @aliases;
  80                         for (@{$attr}){
  81                                 #Parse attributes, from Attribute::Handlers
  82                                 my ($attr, $data) = /^([a-z_]\w*)(?:[(](.*)[)])?$/is or next;
  83                                 my $evaled = eval("package Temp; no warnings;
  84                 local \$SIG{__WARN__}=sub{die}; [$data]");
  85                                 $evaled = ($evaled && $data =~ /^\s*\[/)  ? [$evaled]
  86                                         : ($evaled) ? $evaled : [$data];
  87
  88                                 given ($attr){
  89                                         when ('Alias'){
  90                                                 @aliases = @$evaled;
  91                                         }
  92                                         default {
  93                                                 $c{lc $attr} = $evaled;
  94                                         }
  95                                 }
  96                         }
  97                         push @aliases, $c;
  98                         my $f = eval "\\&${class}::$c";
  99                         $c{func} = $f;
 100                         for my $a (@aliases){
 101                                 $c{name} = $a;
 102                                 my $co = NDIRC::Command->new(\%c);
 103                                 $self->commands->{$a} = $co;
 104                         }
 105                 }
 106         }
 107 }
 108
 109 sub add_channel {
 110         my ($self,$channel,$types) = @_;
 111
 112         $self->channels->{lc $channel} = $types;
 113 }
 114
 115 sub has_command {
 116         my ($self,$command,$channel) = @_;
 117         $channel = lc $channel;
 118
 119         return 0 unless defined $command && exists $self->commands->{$command};
 120
 121         my $types = Set::Object->new(@{$self->commands->{$command}->type});
 122         my @types = qw/pub/;
 123         @types = @{$self->channels->{$channel}} if exists $self->channels->{$channel};
 124
 125         for (@types){
 126                 return 1 if $types->element($_);
 127         }
 128         return 0;
 129 }
 130
 131 sub set_target {
 132         my ($self,$label,$target) = @_;
 133         $self->targets->{$label} = $target;
 134 }
 135
 136 sub run_command {
 137         my ($self,$c,$command,$args) = @_;
 138
 139         return 0 unless exists $self->commands->{$command};
 140         my $acl = $self->commands->{$command}->acl;
 141         return 0 if $acl && !$c->check_user_roles(@$acl);
 142
 143         $args //= '';
 144
 145         eval {
 146                 $self->commands->{$command}->execute($c,$args)
 147         };
 148         if ($@){
 149                 given ($@){
 150                         when(/^ARGS/){
 151                                 for (@{$c->disp->commands->{$command}->help}){
 152                                         $c->reply($_);
 153                                 }
 154                         }
 155                         default {
 156                                 $c->reply("Something went wrong. If it is not temporary, please report it. '$_'");
 157                         }
 158                 }
 159         }
 160         return 1;
 161 }
 162
 163 1;