645 lines
13 KiB
Perl
645 lines
13 KiB
Perl
package CelBot::Commands;
|
|
|
|
use strict;
|
|
|
|
use CelBot::CommandContext;
|
|
|
|
use Carp;
|
|
|
|
sub new
|
|
{
|
|
my $class = shift;
|
|
my ( $core ) = @_;
|
|
|
|
my $self = bless {
|
|
core => $core,
|
|
irc => $core->get_plugin( "irc" ),
|
|
}, $class;
|
|
|
|
return $self;
|
|
}
|
|
|
|
sub reconfigure
|
|
{
|
|
my $self = shift;
|
|
|
|
# First clear out all the existing ones
|
|
$self->{commands} = {};
|
|
|
|
my $core = $self->{core};
|
|
$core->run_plugins( "register_commands", $self );
|
|
}
|
|
|
|
sub _check_cmdstruct
|
|
{
|
|
my $self = shift;
|
|
my ( $cmdstruct, $parent, $cmdname, $funcname ) = @_;
|
|
|
|
$funcname = $cmdstruct->{funcname} if exists $cmdstruct->{funcname};
|
|
$funcname = "command_$cmdname" if !defined $funcname;
|
|
|
|
my $plugin = $cmdstruct->{plugin} ||
|
|
$parent && ( $cmdstruct->{plugin} = $parent->{plugin} )
|
|
or croak "Need a 'plugin' for $cmdname";
|
|
|
|
$cmdstruct->{scope}
|
|
or $parent and $cmdstruct->{scope} = $parent->{scope}
|
|
or $cmdstruct->{scope} = "privmsg";
|
|
|
|
$cmdstruct->{perm}
|
|
or $parent and $cmdstruct->{perm} = $parent->{perm}
|
|
or $cmdstruct->{perm} = "recognised";
|
|
|
|
if( $cmdstruct->{args} and $cmdstruct->{subcmds} ) {
|
|
$cmdstruct->{subcmds} and croak "Cannot have both 'args' and 'subcmds' for $cmdname";
|
|
}
|
|
|
|
elsif( my $args = $cmdstruct->{args} ) {
|
|
ref $args eq "ARRAY" or croak "Expected 'args' to be ARRAY ref for $cmdname";
|
|
if( not $cmdstruct->{function} ) {
|
|
$plugin->can( $funcname ) or croak "Plugin $plugin cannot ->$funcname()";
|
|
$cmdstruct->{function} = sub { $plugin->$funcname( @_ ) };
|
|
}
|
|
}
|
|
|
|
elsif( my $subs = $cmdstruct->{subcmds} ) {
|
|
ref $subs eq "HASH" or croak "Expected 'subcmds' to be HASH ref for $cmdname";
|
|
foreach my $subcmd ( keys %$subs ) {
|
|
$self->_check_cmdstruct( $subs->{$subcmd}, $cmdstruct, "${cmdname} ${subcmd}", "${funcname}_${subcmd}" );
|
|
}
|
|
if( defined $cmdstruct->{default} ) {
|
|
exists $subs->{$cmdstruct->{default}} or croak "Default command for $cmdname does not exist";
|
|
}
|
|
}
|
|
|
|
else {
|
|
croak "Need either 'args' or 'subcmds' for $cmdname";
|
|
}
|
|
}
|
|
|
|
sub register
|
|
{
|
|
my $self = shift;
|
|
my %args = @_;
|
|
|
|
my $command = delete $args{command} or croak "Need a 'command'";
|
|
|
|
exists $self->{commands}->{$command} and croak "Command '$command' already registered";
|
|
|
|
$self->_check_cmdstruct( \%args, undef, $command );
|
|
|
|
$self->{commands}->{$command} = \%args;
|
|
}
|
|
|
|
sub _parse_args
|
|
{
|
|
my $self = shift;
|
|
my ( $argspecs, $context ) = @_;
|
|
|
|
return [] unless defined $argspecs and @$argspecs;
|
|
|
|
my @args;
|
|
|
|
foreach my $arg ( @$argspecs ) {
|
|
last if $arg->trailing;
|
|
|
|
if( $arg->eatall ) {
|
|
push @args, $context->text;
|
|
last;
|
|
}
|
|
else {
|
|
eval { push @args, $arg->pull( $context ); };
|
|
if( $@ ) {
|
|
$context->respond_noise( $@ );
|
|
return;
|
|
}
|
|
}
|
|
}
|
|
|
|
if( !$argspecs->[-1]->trailing and !$argspecs->[-1]->eatall ) {
|
|
if( length $context->text ) {
|
|
$context->respond_noise( "Extra arguments found: '" . $context->text . "'" );
|
|
return;
|
|
}
|
|
}
|
|
|
|
return \@args;
|
|
}
|
|
|
|
sub run_command
|
|
{
|
|
my $self = shift;
|
|
my ( $context ) = @_;
|
|
|
|
my $cmdname = $context->pull_token;
|
|
|
|
if( !exists $self->{commands}->{$cmdname} ) {
|
|
my $response = "No such command '$cmdname'";
|
|
|
|
$response .= ", and please don't shout" if( $cmdname eq uc $cmdname );
|
|
|
|
$context->respond_noise( $response ) if $context->allows_nonpublic;
|
|
return;
|
|
}
|
|
|
|
my $cmdstruct = $self->{commands}->{$cmdname};
|
|
|
|
$self->run_cmdstruct( $cmdstruct, $context, $cmdname );
|
|
}
|
|
|
|
sub run_cmdstruct
|
|
{
|
|
my $self = shift;
|
|
my ( $cmdstruct, $context, $cmdname ) = @_;
|
|
|
|
# Disallow non-recoginised users from running any command that isn't public
|
|
return if( !$context->allows_nonpublic and $cmdstruct->{perm} ne "public" );
|
|
|
|
my $core = $self->{core};
|
|
|
|
unless( $context->allows_scope( $cmdstruct->{scope} ) ) {
|
|
$context->respond_noise( "Not allowed in this scope" );
|
|
return;
|
|
}
|
|
|
|
unless( $context->allows_perm( $cmdstruct->{perm} ) ) {
|
|
$context->respond_noise( "$cmdname: You are not allowed" );
|
|
return;
|
|
}
|
|
|
|
if( my $subs = $cmdstruct->{subcmds} ) {
|
|
my $subcmd = $context->pull_token;
|
|
$subcmd ||= $cmdstruct->{default};
|
|
|
|
if( !defined $subcmd ) {
|
|
$context->respond_noise( "$cmdname: Need a subcommand name" );
|
|
return;
|
|
}
|
|
|
|
if( !exists $subs->{$subcmd} ) {
|
|
$context->respond_noise( "$cmdname: Has no subcommand '$subcmd'" );
|
|
return;
|
|
}
|
|
|
|
my $substruct = $subs->{$subcmd};
|
|
|
|
if( my $checkfunc = $cmdstruct->{checkfunc} ) {
|
|
return unless $checkfunc->( $context, $cmdstruct, $substruct );
|
|
}
|
|
|
|
$self->run_cmdstruct( $substruct, $context, "${cmdname} ${subcmd}" );
|
|
return;
|
|
}
|
|
|
|
my ( $argsref ) = $self->_parse_args( $cmdstruct->{args}, $context );
|
|
return unless $argsref;
|
|
|
|
if( my $checkfunc = $cmdstruct->{checkfunc} ) {
|
|
return unless $checkfunc->( $context, $cmdstruct, $argsref );
|
|
}
|
|
|
|
my $function = $cmdstruct->{function};
|
|
my @response = $function->( $context, @$argsref );
|
|
|
|
$context->respond( @response );
|
|
}
|
|
|
|
sub on_channel_privmsg
|
|
{
|
|
my $self = shift;
|
|
my ( $channel, $user, $text ) = @_;
|
|
|
|
my $irc = $self->{irc};
|
|
|
|
return 0 unless $text =~ m/^(\S+):\s+(.*)$/;
|
|
return 0 unless $irc->is_me( $1 );
|
|
$text = $2;
|
|
|
|
my $nick = $user->nick;
|
|
|
|
my $context = CelBot::CommandContext->new(
|
|
core => $self->{core},
|
|
|
|
scope => "channel",
|
|
cmduser => $user,
|
|
text => $text,
|
|
|
|
max_spam => 3, # TODO: Per-channel lookup?
|
|
|
|
channel => $channel,
|
|
|
|
responder => sub {
|
|
$channel->privmsg( "$nick: $_[0]" );
|
|
},
|
|
);
|
|
|
|
$self->run_command( $context );
|
|
|
|
return 1;
|
|
}
|
|
|
|
sub on_user_privmsg
|
|
{
|
|
my $self = shift;
|
|
my ( $user, $text ) = @_;
|
|
|
|
my $context = CelBot::CommandContext->new(
|
|
core => $self->{core},
|
|
|
|
scope => "privmsg",
|
|
cmduser => $user,
|
|
text => $text,
|
|
|
|
max_spam => 10, # TODO: Per-user lookup?
|
|
allows_noise => 1,
|
|
|
|
responder => sub {
|
|
$user->privmsg( $_[0] );
|
|
},
|
|
);
|
|
|
|
$self->run_command( $context );
|
|
|
|
return 1;
|
|
}
|
|
|
|
sub on_console_line
|
|
{
|
|
my $self = shift;
|
|
my ( $tab, $text ) = @_;
|
|
|
|
my $core = $self->{core};
|
|
|
|
# Cheat
|
|
my $cmdname = (split ' ', $text)[0];
|
|
|
|
my $context = CelBot::CommandContext->new(
|
|
core => $self->{core},
|
|
|
|
scope => "console",
|
|
text => $text,
|
|
|
|
max_spam => undef,
|
|
allows_noise => 1,
|
|
|
|
list_responder => sub {
|
|
my @lines = @_;
|
|
$tab->add_line( "$cmdname: $lines[0]" ); shift @lines;
|
|
$tab->add_line( " $_" ) for @lines;
|
|
}
|
|
);
|
|
|
|
$self->run_command( $context );
|
|
|
|
return 1;
|
|
}
|
|
|
|
sub permit_command_scope
|
|
{
|
|
my $self = shift;
|
|
my ( $scope, $context ) = @_;
|
|
|
|
return 1 if $scope eq 'any';
|
|
return 1 if grep { $context->scope eq $_ } split( m{\|}, $scope );
|
|
|
|
return undef;
|
|
}
|
|
|
|
sub permit_command_perm
|
|
{
|
|
my $self = shift;
|
|
my ( $perm, $context ) = @_;
|
|
|
|
return 1 if grep { $_ eq 'public' } split( m{\|}, $perm );
|
|
|
|
return undef;
|
|
}
|
|
|
|
###
|
|
# Internal Commands
|
|
###
|
|
|
|
sub register_commands
|
|
{
|
|
my $self = shift;
|
|
my ( $commands_plugin ) = @_;
|
|
|
|
$commands_plugin->register(
|
|
plugin => $self,
|
|
command => "help",
|
|
perm => 'public',
|
|
|
|
args => [
|
|
CelBot::Commands::ArgSpec::Command->new( 'command', optional => 1, commands => $self->{commands} ),
|
|
CelBot::Commands::ArgSpec->new( 'args', trailing => 1 ),
|
|
],
|
|
|
|
summary => "Obtain help on available commands",
|
|
);
|
|
}
|
|
|
|
sub command_help
|
|
{
|
|
my $self = shift;
|
|
my ( $context, $helpcmd ) = @_;
|
|
|
|
if( !defined $helpcmd ) {
|
|
my @ret;
|
|
|
|
if( keys %{ $self->{commands} } ) {
|
|
push @ret, "Commands (* denotes public):";
|
|
|
|
my @commands;
|
|
foreach my $command ( sort keys %{ $self->{commands} } ) {
|
|
my $cmdstruct = $self->{commands}->{$command};
|
|
|
|
next unless $context->allows_perm( $cmdstruct->{perm} );
|
|
|
|
push @commands, ( $cmdstruct->{perm} eq "public" ? "*$command" : $command );
|
|
}
|
|
|
|
push @ret, join( " ", @commands );
|
|
}
|
|
|
|
return @ret;
|
|
}
|
|
|
|
my $cmdstruct = $self->{commands}->{$helpcmd};
|
|
$self->_do_help_cmdstruct( $cmdstruct, $context, $helpcmd );
|
|
}
|
|
|
|
sub _do_help_cmdstruct
|
|
{
|
|
my $self = shift;
|
|
my ( $cmdstruct, $context, $helpcmd ) = @_;
|
|
|
|
if( !length $context->text ) {
|
|
my @ret;
|
|
|
|
push @ret, "Summary: $cmdstruct->{summary}" if defined $cmdstruct->{summary};
|
|
|
|
if( $cmdstruct->{args} ) {
|
|
push @ret, "Usage : $helpcmd " . join( " ", map { $_->usage } @{ $cmdstruct->{args} } );
|
|
}
|
|
elsif( my $subs = $cmdstruct->{subcmds} ) {
|
|
push @ret, "Subcommands: " . join( " ", sort keys %$subs );
|
|
}
|
|
|
|
if( $cmdstruct->{helpargs} ) {
|
|
push @ret, " : help $helpcmd " . join( " ", map { $_->usage } @{ $cmdstruct->{helpargs} } );
|
|
}
|
|
|
|
return @ret;
|
|
}
|
|
elsif( defined $cmdstruct->{helpargs} ) {
|
|
my ( $helpargsref ) = $self->_parse_args( $cmdstruct->{helpargs}, $context );
|
|
return unless $helpargsref;
|
|
|
|
my $cmdplugin = $cmdstruct->{plugin};
|
|
my $helpcmdmethod = "commandhelp_$helpcmd";
|
|
my @response = $cmdplugin->$helpcmdmethod( $context, @$helpargsref );
|
|
|
|
foreach my $line ( @response ) {
|
|
# Protect against linefeeds in the line itself
|
|
$context->respond( $_ ) foreach split( m/\n/, $line );
|
|
}
|
|
}
|
|
elsif( my $subs = $cmdstruct->{subcmds} ) {
|
|
my $subcmd = $context->pull_token;
|
|
if( !defined $subcmd ) {
|
|
return( "help $helpcmd: Need a subcommand name" );
|
|
}
|
|
|
|
if( !exists $subs->{$subcmd} ) {
|
|
return( "'$helpcmd' has no subcommand '$subcmd'" );
|
|
}
|
|
|
|
$self->_do_help_cmdstruct( $subs->{$subcmd}, $context, "$helpcmd $subcmd" );
|
|
}
|
|
else {
|
|
return ( "'$helpcmd' has no additional help" );
|
|
}
|
|
}
|
|
|
|
# Keep perl happy, keep Britain tidy
|
|
1;
|
|
|
|
|
|
package CelBot::Commands::ArgSpec;
|
|
|
|
use strict;
|
|
|
|
sub new
|
|
{
|
|
my $class = shift;
|
|
my ( $name, %args ) = @_;
|
|
|
|
$args{name} = $name;
|
|
|
|
return bless \%args, $class;
|
|
}
|
|
|
|
sub name
|
|
{
|
|
my $self = shift;
|
|
return $self->{name};
|
|
}
|
|
|
|
sub optional
|
|
{
|
|
my $self = shift;
|
|
return $self->{optional};
|
|
}
|
|
|
|
sub trailing
|
|
{
|
|
my $self = shift;
|
|
return $self->{trailing};
|
|
}
|
|
|
|
sub eatall
|
|
{
|
|
my $self = shift;
|
|
return $self->{eatall};
|
|
}
|
|
|
|
sub usage
|
|
{
|
|
my $self = shift;
|
|
|
|
my $trailing = $self->trailing || $self->eatall ? "..." : "";
|
|
|
|
if( $self->optional ) {
|
|
return '[$' . $self->name . $trailing . "]";
|
|
}
|
|
else {
|
|
return '$' . $self->name . $trailing;
|
|
}
|
|
}
|
|
|
|
sub pull
|
|
{
|
|
my $self = shift;
|
|
die "ABSTRACT";
|
|
}
|
|
|
|
sub validate
|
|
{
|
|
my $self = shift;
|
|
my ( $val ) = @_;
|
|
|
|
if( $self->{match} ) {
|
|
die "Unrecognised value for '$self->{name}': $val\n" unless $val =~ $self->{match};
|
|
}
|
|
|
|
return $val;
|
|
}
|
|
|
|
1;
|
|
|
|
package CelBot::Commands::ArgSpec::Bareword;
|
|
|
|
use strict;
|
|
use base qw( CelBot::Commands::ArgSpec );
|
|
|
|
sub pull
|
|
{
|
|
my $self = shift;
|
|
my ( $context ) = @_;
|
|
|
|
my $word = $context->pull_token;
|
|
|
|
return undef if !defined $word and $self->{optional};
|
|
|
|
die "Need to supply '$self->{name}'\n" if !defined $word;
|
|
|
|
return $self->validate( $word );
|
|
}
|
|
|
|
1;
|
|
|
|
package CelBot::Commands::ArgSpec::Sugar;
|
|
|
|
use strict;
|
|
use base qw( CelBot::Commands::ArgSpec::Bareword );
|
|
|
|
sub usage
|
|
{
|
|
my $self = shift;
|
|
return $self->{name};
|
|
}
|
|
|
|
sub validate
|
|
{
|
|
my $self = shift;
|
|
my ( $word ) = @_;
|
|
|
|
die "Expected '$self->{name}'" unless $word eq $self->{name};
|
|
|
|
return (); # Empty list
|
|
}
|
|
|
|
1;
|
|
|
|
package CelBot::Commands::ArgSpec::HashKey;
|
|
|
|
use strict;
|
|
use base qw( CelBot::Commands::ArgSpec::Bareword );
|
|
|
|
sub validate
|
|
{
|
|
my $self = shift;
|
|
my ( $word ) = @_;
|
|
|
|
die "'$word' is not a valid value of $self->{name}\n" unless exists $self->{hash}->{$word};
|
|
|
|
return $word;
|
|
}
|
|
|
|
1;
|
|
|
|
package CelBot::Commands::ArgSpec::HashValue;
|
|
|
|
use strict;
|
|
use base qw( CelBot::Commands::ArgSpec::Bareword );
|
|
|
|
sub validate
|
|
{
|
|
my $self = shift;
|
|
my ( $word ) = @_;
|
|
|
|
die "'$word' is not a valid value of $self->{name}\n" unless exists $self->{hash}->{$word};
|
|
|
|
return $self->{hash}->{$word};
|
|
}
|
|
|
|
1;
|
|
|
|
package CelBot::Commands::ArgSpec::Options;
|
|
|
|
use strict;
|
|
use base qw( CelBot::Commands::ArgSpec );
|
|
|
|
sub new
|
|
{
|
|
my $class = shift;
|
|
my ( $opts, %args ) = @_;
|
|
|
|
# Name doesn't matter since we override 'usage' not to print it
|
|
return $class->SUPER::new( 'options', options => $opts, %args );
|
|
}
|
|
|
|
sub usage
|
|
{
|
|
my $self = shift;
|
|
|
|
my $options = $self->{options};
|
|
|
|
return "[" . join( "|", map { "$_ " . $options->{$_}->usage } sort keys %$options ) . "]";
|
|
}
|
|
|
|
sub pull
|
|
{
|
|
my $self = shift;
|
|
my ( $context ) = @_;
|
|
|
|
my $opts = $self->{options};
|
|
my %optvalues;
|
|
|
|
while(1) {
|
|
my $optname = $context->peek_token;
|
|
last unless defined $optname;
|
|
|
|
last unless exists $opts->{$optname};
|
|
|
|
die "Cannot supply '$optname' option more than once\n" if exists $optvalues{$optname};
|
|
|
|
$context->pull_token; # Eat the optname token we peeked at
|
|
|
|
my $opt = $opts->{$optname};
|
|
|
|
$optvalues{$optname} = $opt->pull( $context );
|
|
}
|
|
|
|
return \%optvalues;
|
|
}
|
|
|
|
1;
|
|
|
|
|
|
package CelBot::Commands::ArgSpec::Command;
|
|
|
|
use strict;
|
|
use base qw( CelBot::Commands::ArgSpec::Bareword );
|
|
|
|
sub validate
|
|
{
|
|
my $self = shift;
|
|
my ( $cmdname ) = @_;
|
|
|
|
die "No such command '$cmdname'\n" unless exists $self->{commands}->{$cmdname};
|
|
|
|
return $cmdname;
|
|
}
|
|
|
|
1;
|