2010-03-17 07:36:54 +01:00
# File: Interpreter.pm
2010-03-22 08:33:44 +01:00
# Author: pragma_
2010-03-17 07:36:54 +01:00
#
2010-03-22 08:33:44 +01:00
# Purpose:
2010-03-17 07:36:54 +01:00
2017-03-05 22:33:31 +01:00
# This Source Code Form is subject to the terms of the Mozilla Public
# License, v. 2.0. If a copy of the MPL was not distributed with this
# file, You can obtain one at http://mozilla.org/MPL/2.0/.
2010-03-17 07:36:54 +01:00
package PBot::Interpreter ;
use warnings ;
use strict ;
2010-03-22 08:33:44 +01:00
use base 'PBot::Registerable' ;
2015-03-29 01:50:43 +01:00
use Time::HiRes qw/gettimeofday/ ;
2015-03-31 00:04:08 +02:00
use Time::Duration ;
2010-03-22 08:33:44 +01:00
use Carp ( ) ;
2017-09-05 09:27:28 +02:00
use PBot::Utils::ValidateString ;
2010-03-22 08:33:44 +01:00
sub new {
2019-05-28 18:19:42 +02:00
if ( ref ( $ _ [ 1 ] ) eq 'HASH' ) {
2014-05-19 23:34:24 +02:00
Carp:: croak ( "Options to " . __FILE__ . " should be key/value pairs, not hash reference" ) ;
2010-03-22 08:33:44 +01:00
}
my ( $ class , % conf ) = @ _ ;
my $ self = bless { } , $ class ;
$ self - > initialize ( % conf ) ;
return $ self ;
2010-03-17 07:36:54 +01:00
}
2010-03-22 08:33:44 +01:00
sub initialize {
my ( $ self , % conf ) = @ _ ;
$ self - > SUPER:: initialize ( % conf ) ;
2010-03-17 07:36:54 +01:00
2014-05-19 23:34:24 +02:00
$ self - > { pbot } = delete $ conf { pbot } // Carp:: croak ( "Missing pbot reference to " . __FILE__ ) ;
2010-04-13 06:17:54 +02:00
2014-10-14 04:30:57 +02:00
$ self - > { pbot } - > { registry } - > add_default ( 'text' , 'general' , 'compile_blocks' , $ conf { compile_blocks } // 1 ) ;
$ self - > { pbot } - > { registry } - > add_default ( 'array' , 'general' , 'compile_blocks_channels' , $ conf { compile_blocks_channels } // '.*' ) ;
2014-05-19 23:34:24 +02:00
$ self - > { pbot } - > { registry } - > add_default ( 'array' , 'general' , 'compile_blocks_ignore_channels' , $ conf { compile_blocks_ignore_channels } // 'none' ) ;
2014-05-31 03:05:47 +02:00
$ self - > { pbot } - > { registry } - > add_default ( 'text' , 'interpreter' , 'max_recursion' , 10 ) ;
2015-03-29 01:50:43 +01:00
2016-07-01 22:00:20 +02:00
$ self - > { output_queue } = { } ;
$ self - > { command_queue } = { } ;
2015-03-29 01:50:43 +01:00
2016-07-01 22:00:20 +02:00
$ self - > { pbot } - > { timer } - > register ( sub { $ self - > process_output_queue } , 1 ) ;
$ self - > { pbot } - > { timer } - > register ( sub { $ self - > process_command_queue } , 1 ) ;
2012-07-22 21:22:30 +02:00
}
2010-04-13 06:17:54 +02:00
2010-03-17 07:36:54 +01:00
sub process_line {
2010-03-22 08:33:44 +01:00
my $ self = shift ;
2010-03-17 07:36:54 +01:00
my ( $ from , $ nick , $ user , $ host , $ text ) = @ _ ;
$ from = lc $ from if defined $ from ;
2017-11-16 18:23:58 +01:00
my $ stuff = { from = > $ from , nick = > $ nick , user = > $ user , host = > $ host , text = > $ text } ;
2014-05-19 23:34:24 +02:00
my $ pbot = $ self - > { pbot } ;
2010-03-22 08:33:44 +01:00
2014-05-13 12:15:52 +02:00
my $ message_account = $ pbot - > { messagehistory } - > get_message_account ( $ nick , $ user , $ host ) ;
$ pbot - > { messagehistory } - > add_message ( $ message_account , "$nick!$user\@$host" , $ from , $ text , $ pbot - > { messagehistory } - > { MSG_CHAT } ) ;
2017-11-16 18:23:58 +01:00
$ stuff - > { message_account } = $ message_account ;
2015-07-08 23:05:55 +02:00
my $ flood_threshold = $ pbot - > { registry } - > get_value ( $ from , 'chat_flood_threshold' ) ;
my $ flood_time_threshold = $ pbot - > { registry } - > get_value ( $ from , 'chat_flood_time_threshold' ) ;
$ flood_threshold = $ pbot - > { registry } - > get_value ( 'antiflood' , 'chat_flood_threshold' ) if not defined $ flood_threshold ;
$ flood_time_threshold = $ pbot - > { registry } - > get_value ( 'antiflood' , 'chat_flood_time_threshold' ) if not defined $ flood_time_threshold ;
2018-08-06 07:48:24 +02:00
if ( defined $ from and $ from =~ m/^#/ ) {
my $ chanmodes = $ self - > { pbot } - > { channels } - > get_meta ( $ from , 'MODE' ) ;
if ( defined $ chanmodes and $ chanmodes =~ m/z/ ) {
2018-08-13 23:25:35 +02:00
$ stuff - > { 'chan-z' } = 1 ;
if ( exists $ self - > { pbot } - > { bantracker } - > { banlist } - > { $ from } - > { '+q' } - > { '$~a' } ) {
my $ nickserv = $ self - > { pbot } - > { messagehistory } - > { database } - > get_current_nickserv_account ( $ message_account ) ;
if ( not defined $ nickserv or not length $ nickserv ) {
$ stuff - > { unidentified } = 1 ;
}
}
2018-08-06 07:48:24 +02:00
if ( $ self - > { pbot } - > { bantracker } - > is_banned ( $ nick , $ user , $ host , $ from ) ) {
2018-08-13 23:25:35 +02:00
$ stuff - > { banned } = 1 ;
2018-08-06 07:48:24 +02:00
}
}
}
2018-08-13 23:25:35 +02:00
$ pbot - > { antiflood } - > check_flood ( $ from , $ nick , $ user , $ host , $ text ,
$ flood_threshold , $ flood_time_threshold ,
$ pbot - > { messagehistory } - > { MSG_CHAT } , $ stuff ) if defined $ from ;
2018-08-14 05:06:07 +02:00
if ( $ stuff - > { banned } or $ stuff - > { unidentified } ) {
$ self - > { pbot } - > { logger } - > log ( "Disregarding banned/unidentified user message (channel $from is +z).\n" ) ;
2018-08-13 23:25:35 +02:00
return 1 ;
}
2017-12-09 04:28:08 +01:00
my $ botnick = $ self - > { pbot } - > { registry } - > get_value ( 'irc' , 'botnick' ) ;
# get channel-specific trigger if available
my $ bot_trigger = $ pbot - > { registry } - > get_value ( $ from , 'trigger' ) ;
# otherwise get general trigger
if ( not defined $ bot_trigger ) {
$ bot_trigger = $ pbot - > { registry } - > get_value ( 'general' , 'trigger' ) ;
}
my $ nick_regex = qr/[^%!,:\(\)\+\*\/ ] + / ;
my $ nick_override ;
my $ processed = 0 ;
2015-09-08 10:37:34 +02:00
my $ preserve_whitespace = 0 ;
2013-07-24 14:33:19 +02:00
$ text =~ s/^\s+// ;
$ text =~ s/\s+$// ;
2017-09-05 09:27:28 +02:00
$ text = validate_string ( $ text , 0 ) ;
2012-07-22 21:22:30 +02:00
2013-07-24 14:33:19 +02:00
my $ cmd_text = $ text ;
$ cmd_text =~ s/^\/me\s+// ;
2017-12-09 04:28:08 +01:00
# check for bot command invocation
my @ commands ;
my $ command ;
my $ embedded = 0 ;
2017-11-15 00:27:30 +01:00
2017-12-09 04:28:08 +01:00
if ( $ cmd_text =~ m/^\s*($nick_regex)[,:]?\s+$bot_trigger\{\s*(.+?)\s*\}\s*$/ ) {
goto CHECK_EMBEDDED_CMD ;
} elsif ( $ cmd_text =~ m/^\s*$bot_trigger\{\s*(.+?)\s*\}\s*$/ ) {
goto CHECK_EMBEDDED_CMD ;
} elsif ( $ cmd_text =~ m/^\s*($nick_regex)[,:]\s+$bot_trigger\s*(.+)$/ ) {
2017-12-09 22:25:11 +01:00
my $ possible_nick_override = $ 1 ;
2017-12-09 04:28:08 +01:00
$ command = $ 2 ;
2017-11-15 00:27:30 +01:00
2017-12-09 22:25:11 +01:00
my $ similar = $ self - > { pbot } - > { nicklist } - > is_present_similar ( $ from , $ possible_nick_override ) ;
2017-12-09 04:28:08 +01:00
if ( $ similar ) {
$ nick_override = $ similar ;
} else {
2017-12-09 22:25:11 +01:00
$ self - > { pbot } - > { logger } - > log ( "No similar nick for $possible_nick_override\n" ) ;
2017-12-09 04:28:08 +01:00
return 0 ;
}
} elsif ( $ cmd_text =~ m/^$bot_trigger\s*(.+)$/ ) {
$ command = $ 1 ;
} elsif ( $ cmd_text =~ m/^.?$botnick.?\s*(.+)$/i ) {
$ command = $ 1 ;
} elsif ( $ cmd_text =~ m/^(.+?),?\s*$botnick[?!.]*$/i ) {
$ command = $ 1 ;
}
2016-10-14 14:56:54 +02:00
2017-12-09 04:28:08 +01:00
# check for embedded commands
CHECK_EMBEDDED_CMD:
if ( not defined $ command or $ command =~ m/^\{.*\}/ ) {
if ( $ cmd_text =~ s/^\s*($nick_regex)[,:]\s+// ) {
2017-12-09 22:25:11 +01:00
my $ possible_nick_override = $ 1 ;
my $ similar = $ self - > { pbot } - > { nicklist } - > is_present_similar ( $ from , $ possible_nick_override ) ;
2016-10-23 12:51:59 +02:00
if ( $ similar ) {
$ nick_override = $ similar ;
2016-10-14 14:56:54 +02:00
}
2015-09-04 05:56:44 +02:00
}
2017-12-09 04:28:08 +01:00
for ( my $ count = 0 ; $ count < 3 ; $ count + + ) {
2019-05-30 09:27:52 +02:00
my ( $ extracted , $ rest ) = $ self - > extract_bracketed ( $ cmd_text , '{' , '}' , $ bot_trigger ) ;
last if not length $ extracted ;
$ cmd_text = $ rest ;
$ extracted =~ s/^\s+|\s+$//g ;
2017-12-09 04:28:08 +01:00
push @ commands , $ extracted ;
$ embedded = 1 ;
}
} else {
push @ commands , $ command ;
}
2010-03-17 07:36:54 +01:00
2017-12-09 04:28:08 +01:00
foreach $ command ( @ commands ) {
# check if user is ignored (and command isn't `login`)
if ( $ command !~ /^login / && defined $ from && $ pbot - > { ignorelist } - > check_ignore ( $ nick , $ user , $ host , $ from ) ) {
2015-09-07 14:04:54 +02:00
my $ admin = $ pbot - > { admins } - > loggedin ( $ from , "$nick!$user\@$host" ) ;
if ( ! defined $ admin || $ admin - > { level } < 10 ) {
2017-12-09 04:28:08 +01:00
# hostmask ignored
2015-09-08 10:37:34 +02:00
return 1 ;
2010-03-17 07:36:54 +01:00
}
2015-09-07 14:04:54 +02:00
}
2010-03-17 07:36:54 +01:00
2017-12-09 04:28:08 +01:00
$ stuff - > { text } = $ text ;
$ stuff - > { command } = $ command ;
$ stuff - > { nickoverride } = $ nick_override if $ nick_override ;
2018-01-23 22:58:03 +01:00
$ stuff - > { force_nickoverride } = 1 if $ nick_override ;
2017-12-09 04:28:08 +01:00
$ stuff - > { referenced } = $ embedded ;
$ stuff - > { interpret_depth } = 1 ;
$ stuff - > { preserve_whitespace } = $ preserve_whitespace ;
$ stuff - > { result } = $ self - > interpret ( $ stuff ) ;
2017-12-09 22:26:20 +01:00
$ self - > handle_result ( $ stuff ) ;
$ processed + + ;
2014-03-14 11:05:11 +01:00
}
2015-09-08 10:37:34 +02:00
return $ processed ;
2014-03-14 11:05:11 +01:00
}
2010-03-17 07:36:54 +01:00
2015-03-31 00:04:08 +02:00
sub interpret {
2017-11-16 18:23:58 +01:00
my ( $ self , $ stuff ) = @ _ ;
2015-03-31 00:04:08 +02:00
my ( $ keyword , $ arguments ) = ( "" , "" ) ;
my $ text ;
my $ pbot = $ self - > { pbot } ;
2017-11-16 18:23:58 +01:00
$ pbot - > { logger } - > log ( "=== Enter interpret_command: [" . ( defined $ stuff - > { from } ? $ stuff - > { from } : "(undef)" ) . "][$stuff->{nick}!$stuff->{user}\@$stuff->{host}][$stuff->{interpret_depth}][$stuff->{command}]\n" ) ;
2015-03-31 00:04:08 +02:00
2019-05-10 06:04:28 +02:00
$ stuff - > { special } = "" unless exists $ self - > { special } ;
2017-11-29 03:30:35 +01:00
2017-11-21 01:10:48 +01:00
if ( $ self - > { pbot } - > { registry } - > get_value ( 'general' , 'debugcontext' ) ) {
use Data::Dumper ;
$ Data:: Dumper:: Sortkeys = 1 ;
$ self - > { pbot } - > { logger } - > log ( "Interpreter::interpret\n" ) ;
$ self - > { pbot } - > { logger } - > log ( Dumper $ stuff ) ;
}
2015-03-31 00:04:08 +02:00
2019-05-28 18:19:42 +02:00
return "Too many levels of recursion, aborted." if ( + + $ stuff - > { interpret_depth } > $ self - > { pbot } - > { registry } - > get_value ( 'interpreter' , 'max_recursion' ) ) ;
2017-11-16 18:23:58 +01:00
if ( not defined $ stuff - > { nick } || not defined $ stuff - > { user } || not defined $ stuff - > { host } || not defined $ stuff - > { command } ) {
2015-03-31 00:04:08 +02:00
$ pbot - > { logger } - > log ( "Error 1, bad parameters to interpret_command\n" ) ;
return undef ;
}
2019-06-26 03:23:21 +02:00
# check for splitted commands
if ( $ stuff - > { command } =~ m/^(.*?)\s*(?<!\\);;\s*(.*)/ ) {
$ stuff - > { command } = $ 1 ;
$ stuff - > { command_split } = $ 2 ;
}
2018-08-09 02:38:57 +02:00
my $ cmdlist = $ self - > make_args ( $ stuff - > { command } ) ;
2019-05-20 22:10:08 +02:00
if ( $ self - > arglist_size ( $ cmdlist ) >= 4 and lc $ cmdlist - > [ 0 ] eq 'tell' and ( lc $ cmdlist - > [ 2 ] eq 'about' or lc $ cmdlist - > [ 2 ] eq 'the' ) ) {
2018-08-10 07:44:28 +02:00
# tell nick about cmd [args]
2018-08-09 02:38:57 +02:00
$ stuff - > { nickoverride } = $ cmdlist - > [ 1 ] ;
( $ keyword , $ arguments ) = $ self - > split_args ( $ cmdlist , 2 , 3 ) ;
$ arguments = '' if not defined $ arguments ;
2017-11-16 18:23:58 +01:00
my $ similar = $ self - > { pbot } - > { nicklist } - > is_present_similar ( $ stuff - > { from } , $ stuff - > { nickoverride } ) ;
if ( $ similar ) {
$ stuff - > { nickoverride } = $ similar ;
2017-11-30 22:11:39 +01:00
$ stuff - > { force_nickoverride } = 1 ;
2017-11-16 18:23:58 +01:00
} else {
2017-11-30 22:11:39 +01:00
delete $ stuff - > { nickoverride } ;
2017-12-09 22:25:11 +01:00
delete $ stuff - > { force_nickoverride } ;
2017-11-16 18:23:58 +01:00
}
2015-03-31 00:04:08 +02:00
} else {
2018-08-10 07:44:28 +02:00
# normal command
2018-08-09 02:38:57 +02:00
( $ keyword , $ arguments ) = $ self - > split_args ( $ cmdlist , 2 ) ;
$ arguments = "" if not defined $ arguments ;
2015-03-31 00:04:08 +02:00
}
2018-08-09 02:38:57 +02:00
# FIXME: make this a registry item
if ( length $ keyword > 128 ) {
$ keyword = substr ( $ keyword , 0 , 128 ) ;
$ self - > { pbot } - > { logger } - > log ( "Truncating keyword to 128 chars: $keyword\n" ) ;
2017-11-13 21:00:34 +01:00
}
2017-12-05 03:34:34 +01:00
# parse out a substituted command
2019-05-30 09:27:52 +02:00
if ( defined $ arguments && $ arguments =~ m/(?<!\\)&\s*\{/ ) {
my ( $ command ) = $ self - > extract_bracketed ( $ arguments , '{' , '}' , '&' , 1 ) ;
2017-12-09 05:26:08 +01:00
2019-05-30 09:27:52 +02:00
if ( length $ command ) {
$ arguments =~ s/&\s*\{\Q$command\E\}/&{subcmd}/ ;
2017-12-09 05:26:08 +01:00
push @ { $ stuff - > { subcmd } } , "$keyword $arguments" ;
2019-05-30 09:27:52 +02:00
$ command =~ s/^\s+|\s+$//g ;
2017-12-09 05:26:08 +01:00
$ stuff - > { command } = $ command ;
$ stuff - > { result } = $ self - > interpret ( $ stuff ) ;
return $ stuff - > { result } ;
}
2017-12-05 03:34:34 +01:00
}
2017-12-09 05:26:08 +01:00
# parse out a pipe
2017-11-26 05:01:34 +01:00
if ( defined $ arguments && $ arguments =~ m/(?<!\\)\|\s*\{\s*[^}]+\}\s*$/ ) {
2019-05-30 09:27:52 +02:00
my ( $ pipe , $ rest ) = $ self - > extract_bracketed ( $ arguments , '{' , '}' , '|' , 1 ) ;
2017-11-17 22:53:23 +01:00
2019-05-30 09:27:52 +02:00
$ arguments =~ s/\s*(?<!\\)\|\s*{(\Q$pipe\E)}.*$// ;
$ pipe =~ s/^\s+|\s+$//g ;
2017-11-29 04:07:01 +01:00
if ( exists $ stuff - > { pipe } ) {
$ stuff - > { pipe_rest } = "$rest | { $stuff->{pipe} }$stuff->{pipe_rest}" ;
} else {
$ stuff - > { pipe_rest } = $ rest ;
}
2017-11-29 04:10:22 +01:00
$ stuff - > { pipe } = $ pipe ;
2017-11-17 22:53:23 +01:00
}
2017-11-26 05:00:55 +01:00
$ stuff - > { nickoverride } = $ stuff - > { nick } if defined $ stuff - > { nickoverride } and lc $ stuff - > { nickoverride } eq 'me' ;
2017-08-02 06:34:57 +02:00
2019-05-20 22:10:08 +02:00
if ( $ keyword !~ /^(?:factrem|forget|set|factdel|factadd|add|factfind|find|factshow|show|forget|factdel|factset|factchange|change|msg|cc|eval|u|udict|ud|actiontrigger|urban|perl|ban|mute|spinach|choose|c|lie|l|adminadd|unmute|unban)$/i ) {
2015-03-31 00:04:08 +02:00
$ keyword =~ s/(\w+)([?!.]+)$/$1/ ;
2018-02-10 04:09:11 +01:00
$ arguments =~ s/(?<![\w\/\-\\])i am\b/$stuff->{nick} is/gi if defined $ arguments && $ stuff - > { interpret_depth } <= 2 ;
2017-11-16 18:23:58 +01:00
$ arguments =~ s/(?<![\w\/\-\\])me\b/$stuff->{nick}/gi if defined $ arguments && $ stuff - > { interpret_depth } <= 2 ;
$ arguments =~ s/(?<![\w\/\-\\])my\b/$stuff->{nick}'s/gi if defined $ arguments && $ stuff - > { interpret_depth } <= 2 ;
$ arguments =~ s/\\my\b/my/gi if defined $ arguments && $ stuff - > { interpret_depth } <= 2 ;
$ arguments =~ s/\\me\b/me/gi if defined $ arguments && $ stuff - > { interpret_depth } <= 2 ;
2018-02-10 04:09:11 +01:00
$ arguments =~ s/\\i am\b/i am/gi if defined $ arguments && $ stuff - > { interpret_depth } <= 2 ;
2015-09-20 05:02:11 +02:00
2017-08-26 13:06:36 +02:00
my $ botnick = $ self - > { pbot } - > { registry } - > get_value ( 'irc' , 'botnick' ) ;
if ( defined $ arguments && ( $ arguments =~ m/^(your|him|her|its|it|them|their)(self|selves)$/i || $ arguments =~ m/^$botnick$/i ) ) {
2019-06-02 03:55:08 +02:00
my $ delay = rand ( 10 ) + 5 ;
2017-08-26 13:06:36 +02:00
my $ message = {
2017-11-16 18:23:58 +01:00
nick = > $ stuff - > { nick } , user = > $ stuff - > { user } , host = > $ stuff - > { host } , command = > $ stuff - > { command } , checkflood = > 1 ,
message = > "$stuff->{nick}: Why would I want to do that to myself?"
2017-08-26 13:06:36 +02:00
} ;
2017-11-16 18:23:58 +01:00
$ self - > add_message_to_output_queue ( $ stuff - > { from } , $ message , $ delay ) ;
2017-08-26 13:06:36 +02:00
$ delay = duration ( $ delay ) ;
$ self - > { pbot } - > { logger } - > log ( "Final result ($delay delay) [$message->{message}]\n" ) ;
return undef ;
}
2015-03-31 00:04:08 +02:00
}
2019-05-28 18:19:42 +02:00
if ( not defined $ keyword ) {
2015-03-31 00:04:08 +02:00
$ pbot - > { logger } - > log ( "Error 2, no keyword\n" ) ;
return undef ;
}
2017-11-16 18:23:58 +01:00
if ( not exists $ stuff - > { root_keyword } ) {
$ stuff - > { root_keyword } = $ keyword ;
}
2017-11-15 00:27:30 +01:00
2017-11-27 11:14:34 +01:00
$ stuff - > { keyword } = $ keyword ;
2018-05-22 04:27:57 +02:00
2019-06-26 03:23:21 +02:00
# unescape any escaped command splits
$ arguments =~ s/\\;;/;;/g if defined $ arguments ;
2018-05-22 04:27:57 +02:00
# unescape any escaped substituted commands
2019-05-30 09:27:52 +02:00
$ arguments =~ s/\\&\s*\{/&{/g if defined $ arguments ;
2018-05-22 04:27:57 +02:00
# unescape any escaped pipes
$ arguments =~ s/\\\|\s*\{/| {/g if defined $ arguments ;
2018-08-09 02:38:57 +02:00
$ arguments = validate_string ( $ arguments ) ;
2018-08-07 05:23:35 +02:00
# set arguments as a plain string
2017-11-27 11:14:34 +01:00
$ stuff - > { arguments } = $ arguments ;
2019-06-03 04:30:35 +02:00
$ stuff - > { original_arguments } = $ arguments ;
2017-11-15 00:27:30 +01:00
2018-08-09 02:38:57 +02:00
# set arguments as an array
$ stuff - > { arglist } = $ self - > make_args ( $ arguments ) ;
2019-06-03 04:30:35 +02:00
# execute all registered interpreters
my $ result ;
foreach my $ func ( @ { $ self - > { handlers } } ) {
$ result = & { $ func - > { subref } } ( $ stuff ) ;
last if defined $ result ;
# reset any manipulated arguments
$ stuff - > { arguments } = $ stuff - > { original_arguments } ;
}
return $ result ;
2018-08-09 02:38:57 +02:00
}
2019-05-30 09:27:52 +02:00
# extracts a bracketed substring, gracefully handling unbalanced quotes
# or brackets. opening and closing brackets may each be more than one character.
# optional prefix may be or begin with a character group.
sub extract_bracketed {
my ( $ self , $ string , $ open_bracket , $ close_bracket , $ optional_prefix , $ allow_whitespace ) = @ _ ;
$ open_bracket = '{' if not defined $ open_bracket ;
$ close_bracket = '}' if not defined $ close_bracket ;
$ optional_prefix = '' if not defined $ optional_prefix ;
$ allow_whitespace = 0 if not defined $ allow_whitespace ;
my @ prefix_group ;
if ( $ optional_prefix =~ s/^\[(.*?)\]// ) {
@ prefix_group = split // , $ 1 ;
}
my @ prefixes = split // , $ optional_prefix ;
my @ opens = split // , $ open_bracket ;
my @ closes = split // , $ close_bracket ;
my $ prefix_index = 0 ;
my $ open_index = 0 ;
my $ close_index = 0 ;
my $ result = '' ;
my $ rest = '' ;
my $ extracting = 0 ;
my $ extracted = 0 ;
my $ escaped = 0 ;
my $ quote ;
my $ token = '' ;
my $ ch = ' ' ;
my $ last_ch ;
my $ i = 0 ;
my $ quote_pos ;
my $ bracket_pos ;
my $ bracket_level = 0 ;
my $ ignore_quote = 0 ;
2019-05-30 18:25:31 +02:00
my $ prefix_group_match = @ prefix_group ? 0 : 1 ;
my $ prefix_match = @ prefixes ? 0 : 1 ;
my $ match = 0 ;
2019-05-30 09:27:52 +02:00
2019-05-30 18:25:31 +02:00
my @ chars = split // , $ string ;
2019-05-30 09:27:52 +02:00
2019-05-30 18:25:31 +02:00
my $ state = 'prefixgroup' ;
while ( 1 ) {
$ last_ch = $ ch ;
if ( $ i >= @ chars ) {
if ( defined $ quote ) {
# reached end, but unbalanced quote... reset to beginning of quote and ignore it
$ i = $ quote_pos ;
$ ignore_quote = 1 ;
$ quote = undef ;
$ last_ch = ' ' ;
$ token = '' ;
} elsif ( $ extracting ) {
# reached end, but unbalanced brackets... reset to beginning and ignore them
$ i = $ bracket_pos ;
$ bracket_level = 0 ;
$ state = 'prefixgroup' ;
$ extracting = 0 ;
$ last_ch = ' ' ;
$ token = '' ;
$ result = '' ;
} else {
# add final token and exit
$ rest . = $ token if $ extracted ;
last ;
2019-05-30 09:27:52 +02:00
}
2019-05-30 18:25:31 +02:00
}
2019-05-30 09:27:52 +02:00
2019-05-30 18:25:31 +02:00
$ ch = $ chars [ $ i + + ] ;
if ( $ escaped ) {
$ token . = "\\$ch" if $ extracting or $ extracted ;
$ escaped = 0 ;
next ;
}
if ( $ ch eq '\\' ) {
$ escaped = 1 ;
next ;
}
if ( defined $ quote ) {
if ( $ ch eq $ quote ) {
# closing quote
$ token . = $ ch if $ extracting or $ extracted ;
$ result . = $ token if $ extracting ;
$ rest . = $ token if $ extracted ;
$ quote = undef ;
$ token = '' ;
} else {
# still within quoted argument
$ token . = $ ch if $ extracting or $ extracted ;
2019-05-30 09:27:52 +02:00
}
2019-05-30 18:25:31 +02:00
next ;
}
2019-05-30 09:27:52 +02:00
2019-05-30 18:25:31 +02:00
if ( $ last_ch eq ' ' and not defined $ quote and ( $ ch eq "'" or $ ch eq '"' ) ) {
if ( $ ignore_quote ) {
# treat unbalanced quote as part of this argument
$ token . = $ ch if $ extracting or $ extracted ;
$ ignore_quote = 0 ;
} else {
# begin potential quoted argument
$ quote_pos = $ i - 1 ;
$ quote = $ ch ;
$ token . = $ ch if $ extracting or $ extracted ;
2019-05-30 09:27:52 +02:00
}
2019-05-30 18:25:31 +02:00
next ;
}
2019-05-30 09:27:52 +02:00
2019-05-30 18:25:31 +02:00
if ( not $ extracted ) {
if ( $ state eq 'prefixgroup' and @ prefix_group and not $ extracting ) {
foreach my $ prefix_ch ( @ prefix_group ) {
if ( $ ch eq $ prefix_ch ) {
$ prefix_group_match = 1 ;
$ state = 'prefixes' ;
last ;
} else {
$ prefix_group_match = 0 ;
}
2019-05-30 09:27:52 +02:00
}
2019-05-30 18:25:31 +02:00
next if $ prefix_group_match ;
} elsif ( $ state eq 'prefixgroup' and not @ prefix_group ) {
$ state = 'prefixes' ;
$ prefix_index = 0 ;
2019-05-30 09:27:52 +02:00
}
2019-05-30 18:25:31 +02:00
if ( $ state eq 'prefixes' ) {
if ( @ prefixes and $ ch eq $ prefixes [ $ prefix_index ] ) {
$ token . = $ ch if $ extracting ;
$ prefix_match = 1 ;
$ prefix_index + + ;
$ state = 'openbracket' ;
next ;
} elsif ( $ state eq 'prefixes' and not @ prefixes ) {
$ state = 'openbracket' ;
2019-05-30 09:27:52 +02:00
}
2019-05-30 18:25:31 +02:00
}
2019-05-30 09:27:52 +02:00
2019-05-30 18:25:31 +02:00
if ( $ extracting or ( $ state eq 'openbracket' and $ prefix_group_match and $ prefix_match ) ) {
$ prefix_index = 0 ;
if ( $ ch eq $ opens [ $ open_index ] ) {
$ match = 1 ;
$ open_index + + ;
} else {
if ( $ allow_whitespace and $ ch eq ' ' and not $ extracting ) {
next ;
} elsif ( not $ extracting ) {
$ state = 'prefixgroup' ;
2019-05-30 09:27:52 +02:00
next ;
}
}
2019-05-30 18:25:31 +02:00
}
2019-05-30 09:27:52 +02:00
2019-05-30 18:25:31 +02:00
if ( $ match ) {
$ state = 'prefixgroup' ;
$ prefix_group_match = 0 unless not @ prefix_group ;
$ prefix_match = 0 unless not @ prefixes ;
$ match = 0 ;
$ bracket_pos = $ i if not $ extracting ;
if ( $ open_index == @ opens ) {
$ extracting = 1 ;
$ token . = $ ch if $ bracket_level > 0 ;
$ bracket_level + + ;
$ open_index = 0 ;
2019-05-30 09:27:52 +02:00
}
next ;
} else {
$ open_index = 0 ;
}
if ( $ ch eq $ closes [ $ close_index ] ) {
if ( $ extracting or $ extracted ) {
$ close_index + + ;
if ( $ close_index == @ closes ) {
$ close_index = 0 ;
if ( - - $ bracket_level == 0 ) {
$ extracting = 0 ;
$ extracted = 1 ;
$ result . = $ token ;
$ token = '' ;
} else {
$ token . = $ ch ;
}
}
}
next ;
} else {
$ close_index = 0 ;
}
}
if ( $ extracting or $ extracted ) {
$ token . = $ ch ;
}
}
return ( $ result , $ rest ) ;
}
2019-06-26 08:19:57 +02:00
# splits line into quoted arguments while preserving quotes.
# a string is considered quoted only if they are surrounded by
# whitespace or json separators.
# handles unbalanced quotes gracefully by treating them as
# part of the argument they were found within.
2019-05-28 20:11:32 +02:00
sub split_line {
2019-06-09 22:57:08 +02:00
my ( $ self , $ line , % opts ) = @ _ ;
2019-05-28 20:11:32 +02:00
2019-06-10 20:51:48 +02:00
my % default_opts = (
strip_quotes = > 0 ,
2019-06-25 01:47:31 +02:00
keep_spaces = > 0 ,
preserve_escapes = > 1 ,
2019-06-10 20:51:48 +02:00
) ;
% opts = ( % default_opts , % opts ) ;
2019-05-28 20:11:32 +02:00
my @ chars = split // , $ line ;
my @ args ;
my $ escaped = 0 ;
my $ quote ;
my $ token = '' ;
my $ ch = ' ' ;
my $ last_ch ;
2019-06-26 08:19:57 +02:00
my $ next_ch ;
2019-05-28 20:11:32 +02:00
my $ i = 0 ;
my $ pos ;
my $ ignore_quote = 0 ;
2019-06-09 22:57:08 +02:00
my $ spaces = 0 ;
2019-05-28 20:11:32 +02:00
while ( 1 ) {
$ last_ch = $ ch ;
if ( $ i >= @ chars ) {
if ( defined $ quote ) {
# reached end, but unbalanced quote... reset to beginning of quote and ignore it
$ i = $ pos ;
$ ignore_quote = 1 ;
$ quote = undef ;
2019-05-28 20:56:06 +02:00
$ last_ch = ' ' ;
2019-05-28 20:11:32 +02:00
$ token = '' ;
} else {
# add final token and exit
push @ args , $ token if length $ token ;
last ;
}
}
$ ch = $ chars [ $ i + + ] ;
2019-06-26 08:19:57 +02:00
$ next_ch = $ chars [ $ i ] ;
2019-05-28 20:11:32 +02:00
2019-06-09 22:57:08 +02:00
$ spaces = 0 if $ ch ne ' ' ;
2019-05-28 20:11:32 +02:00
if ( $ escaped ) {
2019-06-25 01:47:31 +02:00
if ( $ opts { preserve_escapes } ) {
$ token . = "\\$ch" ;
} else {
$ token . = $ ch ;
}
2019-05-28 20:11:32 +02:00
$ escaped = 0 ;
next ;
}
if ( $ ch eq '\\' ) {
$ escaped = 1 ;
next ;
}
if ( defined $ quote ) {
2019-06-26 08:19:57 +02:00
if ( $ ch eq $ quote and ( not defined $ next_ch or $ next_ch =~ /[\s,:;})\].+=]/ ) ) {
2019-05-28 20:11:32 +02:00
# closing quote
2019-06-09 22:57:08 +02:00
$ token . = $ ch unless $ opts { strip_quotes } ;
2019-05-28 20:11:32 +02:00
push @ args , $ token ;
$ quote = undef ;
$ token = '' ;
} else {
# still within quoted argument
$ token . = $ ch ;
}
next ;
}
2019-06-26 08:19:57 +02:00
if ( ( $ last_ch =~ /[\s:{(\[.+=]/ ) and not defined $ quote and ( $ ch eq "'" or $ ch eq '"' ) ) {
2019-05-28 20:11:32 +02:00
if ( $ ignore_quote ) {
# treat unbalanced quote as part of this argument
$ token . = $ ch ;
$ ignore_quote = 0 ;
} else {
# begin potential quoted argument
$ pos = $ i - 1 ;
$ quote = $ ch ;
2019-06-09 22:57:08 +02:00
$ token . = $ ch unless $ opts { strip_quotes } ;
2019-05-28 20:11:32 +02:00
}
next ;
}
if ( $ ch eq ' ' ) {
2019-06-09 22:57:08 +02:00
if ( + + $ spaces > 1 and $ opts { keep_spaces } ) {
$ token . = $ ch ;
next ;
} else {
push @ args , $ token if length $ token ;
$ token = '' ;
next ;
}
2019-05-28 20:11:32 +02:00
}
$ token . = $ ch ;
}
return @ args ;
}
2018-08-09 02:38:57 +02:00
# creates an array of arguments from a string
sub make_args {
my ( $ self , $ string ) = @ _ ;
2019-06-09 22:57:08 +02:00
my @ args = $ self - > split_line ( $ string , keep_spaces = > 1 ) ;
2019-05-28 20:11:32 +02:00
2018-08-09 02:38:57 +02:00
my @ arglist ;
2019-06-09 22:57:08 +02:00
my @ arglist_unstripped ;
2018-08-07 05:23:35 +02:00
while ( @ args ) {
my $ arg = shift @ args ;
2019-06-09 22:57:08 +02:00
# add argument with quotes and spaces preserved
push @ arglist_unstripped , $ arg ;
2019-05-28 20:11:32 +02:00
# strip quotes from argument
2019-06-03 07:34:17 +02:00
if ( $ arg =~ m/^'.*'$/ ) {
2019-05-28 20:11:32 +02:00
$ arg =~ s/^'// ;
$ arg =~ s/'$// ;
2019-06-03 07:34:17 +02:00
} elsif ( $ arg =~ m/^".*"$/ ) {
2019-05-28 20:11:32 +02:00
$ arg =~ s/^"// ;
$ arg =~ s/"$// ;
2018-08-07 05:23:35 +02:00
}
2019-05-28 20:11:32 +02:00
2019-06-09 22:57:08 +02:00
# strip leading spaces from argument
$ arg =~ s/^\s+// ;
# add stripped argument
2019-05-28 20:11:32 +02:00
push @ arglist , $ arg ;
2018-08-07 05:23:35 +02:00
}
2019-06-09 22:57:08 +02:00
# copy unstripped arguments to end of arglist
push @ arglist , @ arglist_unstripped ;
2018-08-09 02:38:57 +02:00
return \ @ arglist ;
}
2018-08-07 05:23:35 +02:00
2018-08-09 02:38:57 +02:00
# returns size of array of arguments
sub arglist_size {
my ( $ self , $ args ) = @ _ ;
return @$ args / 2 ;
}
# shifts first argument off array of arguments
sub shift_arg {
my ( $ self , $ args ) = @ _ ;
2019-06-09 22:57:08 +02:00
return undef if not @$ args ;
2018-08-09 02:38:57 +02:00
splice @$ args , @$ args / 2 , 1 ; # remove original quoted argument
return shift @$ args ;
2015-03-31 00:04:08 +02:00
}
2018-08-07 05:23:35 +02:00
# splits array of arguments into array with overflow arguments filling up last position
# split_args(qw/dog cat bird hamster/, 3) => ("dog", "cat", "bird hamster")
sub split_args {
2018-08-09 02:38:57 +02:00
my ( $ self , $ args , $ count , $ offset ) = @ _ ;
2018-08-07 05:23:35 +02:00
my @ result ;
2018-08-09 02:38:57 +02:00
my $ max = $ self - > arglist_size ( $ args ) ;
my $ i = $ offset // 0 ;
2019-06-03 07:34:17 +02:00
unless ( $ count == 1 ) {
do {
my $ arg = $ args - > [ $ i + + ] ;
push @ result , $ arg ;
} while ( - - $ count > 1 and $ i < $ max ) ;
}
2018-08-07 05:23:35 +02:00
2019-06-09 22:57:08 +02:00
# get rest from 2nd half of arglist, which contains original quotes and spaces
2018-08-09 02:38:57 +02:00
my $ rest = join ' ' , @$ args [ @$ args / 2 + $ i .. @$ args - 1 ] ;
push @ result , $ rest if length $ rest ;
2018-08-07 05:23:35 +02:00
return @ result ;
}
2018-08-09 02:38:57 +02:00
# lowercases array of arguments
sub lc_args {
my ( $ self , $ args ) = @ _ ;
for ( my $ i = 0 ; $ i < @$ args ; $ i + + ) {
$ args - > [ $ i ] = lc $ args - > [ $ i ] ;
}
}
2014-03-15 02:53:33 +01:00
sub truncate_result {
my ( $ self , $ from , $ nick , $ text , $ original_result , $ result , $ paste ) = @ _ ;
2014-05-17 22:08:19 +02:00
my $ max_msg_len = $ self - > { pbot } - > { registry } - > get_value ( 'irc' , 'max_msg_len' ) ;
2014-03-15 02:53:33 +01:00
2019-05-28 18:19:42 +02:00
if ( length $ result > $ max_msg_len ) {
2014-03-15 02:53:33 +01:00
my $ link ;
2019-05-28 18:19:42 +02:00
if ( $ paste ) {
2017-08-25 00:16:42 +02:00
$ original_result = substr $ original_result , 0 , 8000 ;
2017-12-06 06:05:44 +01:00
$ link = $ self - > { pbot } - > { webpaste } - > paste ( "[" . ( defined $ from ? $ from : "stdin" ) . "] <$nick> $text\n\n$original_result" ) ;
2014-03-15 02:53:33 +01:00
} else {
$ link = 'undef' ;
}
2015-05-07 06:15:25 +02:00
my $ trunc = "... [truncated; " ;
if ( $ link =~ m/^http/ ) {
$ trunc . = "see $link for full text.]" ;
} else {
$ trunc . = "$link]" ;
}
2014-05-18 22:09:05 +02:00
$ self - > { pbot } - > { logger } - > log ( "Message truncated -- pasted to $link\n" ) if $ paste ;
2014-03-15 02:53:33 +01:00
2014-05-17 22:08:19 +02:00
my $ trunc_len = length $ result < $ max_msg_len ? length $ result : $ max_msg_len ;
2014-03-15 02:53:33 +01:00
$ result = substr ( $ result , 0 , $ trunc_len ) ;
substr ( $ result , $ trunc_len - length $ trunc ) = $ trunc ;
}
return $ result ;
}
2014-03-14 11:05:11 +01:00
sub handle_result {
2017-11-16 18:23:58 +01:00
my ( $ self , $ stuff , $ result ) = @ _ ;
2017-12-09 04:28:08 +01:00
$ result = $ stuff - > { result } if not defined $ result ;
2017-11-16 18:23:58 +01:00
$ stuff - > { preserve_whitespace } = 0 if not defined $ stuff - > { preserve_whitespace } ;
2017-12-03 00:04:36 +01:00
if ( $ self - > { pbot } - > { registry } - > get_value ( 'general' , 'debugcontext' ) and length $ stuff - > { result } ) {
2017-11-21 01:10:48 +01:00
use Data::Dumper ;
$ Data:: Dumper:: Sortkeys = 1 ;
$ self - > { pbot } - > { logger } - > log ( "Interpreter::handle_result [$result]\n" ) ;
$ self - > { pbot } - > { logger } - > log ( Dumper $ stuff ) ;
}
2012-07-22 21:22:30 +02:00
2015-03-29 01:50:43 +01:00
if ( not defined $ result or length $ result == 0 ) {
2015-09-08 10:37:34 +02:00
return 0 ;
2014-03-14 11:05:11 +01:00
}
2012-07-22 21:22:30 +02:00
2017-12-05 06:22:19 +01:00
if ( $ result =~ s #^(/say|/me) ##) {
$ stuff - > { prepend } = $ 1 ;
} elsif ( $ result =~ s #^(/msg \S+) ##) {
$ stuff - > { prepend } = $ 1 ;
}
2017-12-05 03:34:34 +01:00
if ( exists $ stuff - > { subcmd } ) {
my $ command = pop @ { $ stuff - > { subcmd } } ;
2019-06-03 04:30:35 +02:00
if ( @ { $ stuff - > { subcmd } } == 0 or $ stuff - > { alldone } ) {
2017-12-05 03:34:34 +01:00
delete $ stuff - > { subcmd } ;
}
$ command =~ s/&\{subcmd\}/$result/ ;
2019-06-03 04:30:35 +02:00
if ( not $ stuff - > { alldone } ) {
$ stuff - > { command } = $ command ;
$ result = $ self - > interpret ( $ stuff ) ;
$ stuff - > { result } = $ result ;
$ self - > { pbot } - > { logger } - > log ( "subcmd result [$result]\n" ) ;
}
2017-12-05 03:34:34 +01:00
$ self - > handle_result ( $ stuff ) ;
return 0 ;
}
2017-11-23 23:12:23 +01:00
if ( $ stuff - > { pipe } and not $ stuff - > { authorized } ) {
2017-12-05 06:22:19 +01:00
my ( $ pipe , $ pipe_rest ) = ( delete $ stuff - > { pipe } , delete $ stuff - > { pipe_rest } ) ;
2017-11-16 18:23:58 +01:00
$ self - > { pbot } - > { logger } - > log ( "Handling pipe [$result][$pipe][$pipe_rest]\n" ) ;
2019-06-03 04:30:35 +02:00
$ stuff - > { pipe_result } = $ result ;
if ( not $ stuff - > { alldone } ) {
$ stuff - > { command } = "$pipe$pipe_rest" ;
$ result = $ self - > interpret ( $ stuff ) ;
$ stuff - > { result } = $ result ;
}
2017-11-16 18:23:58 +01:00
$ self - > handle_result ( $ stuff , $ result ) ;
return 0 ;
}
if ( $ stuff - > { prepend } ) {
2017-12-05 06:22:19 +01:00
$ result = "$stuff->{prepend} $result" ;
2017-11-16 18:23:58 +01:00
}
2019-06-26 03:23:21 +02:00
if ( $ stuff - > { command_split } ) {
my $ botnick = $ self - > { pbot } - > { registry } - > get_value ( 'irc' , 'botnick' ) ;
$ stuff - > { command } = delete $ stuff - > { command_split } ;
$ self - > { pbot } - > { logger } - > log ( "Handling split [$result][$stuff->{command}]\n" ) ;
$ result =~ s #^/say #\n#i;
$ result =~ s #^/me #\n* $botnick #i;
if ( not length $ stuff - > { split_result } ) {
$ result =~ s/^\n// ;
$ stuff - > { split_result } = $ result ;
} else {
$ stuff - > { split_result } . = $ result ;
}
$ result = $ self - > interpret ( $ stuff ) ;
$ self - > handle_result ( $ stuff , $ result ) ;
return 0 ;
}
if ( $ stuff - > { split_result } ) {
my $ botnick = $ self - > { pbot } - > { registry } - > get_value ( 'irc' , 'botnick' ) ;
$ result =~ s #^/say #\n#i;
$ result =~ s #^/me #\n* $botnick #i;
$ result = $ stuff - > { split_result } . $ result ;
}
2014-03-14 11:05:11 +01:00
my $ original_result = $ result ;
2010-03-17 07:36:54 +01:00
2015-03-29 01:50:43 +01:00
my $ use_output_queue = 0 ;
2017-11-16 18:23:58 +01:00
if ( defined $ stuff - > { command } ) {
2018-08-10 07:44:28 +02:00
my $ cmdlist = $ self - > make_args ( $ stuff - > { command } ) ;
my ( $ cmd , $ args ) = $ self - > split_args ( $ cmdlist , 2 ) ;
2015-04-04 00:33:19 +02:00
if ( not $ self - > { pbot } - > { commands } - > exists ( $ cmd ) ) {
2019-06-10 01:33:27 +02:00
my ( $ chan , $ trigger ) = $ self - > { pbot } - > { factoids } - > find_factoid ( $ stuff - > { from } , $ cmd , arguments = > $ args , exact_channel = > 1 , exact_trigger = > 0 , find_alias = > 1 ) ;
2019-05-28 18:19:42 +02:00
if ( defined $ trigger ) {
2017-11-16 18:23:58 +01:00
if ( $ stuff - > { preserve_whitespace } == 0 ) {
$ stuff - > { preserve_whitespace } = $ self - > { pbot } - > { factoids } - > { factoids } - > hash - > { $ chan } - > { $ trigger } - > { preserve_whitespace } ;
$ stuff - > { preserve_whitespace } = 0 if not defined $ stuff - > { preserve_whitespace } ;
2015-04-04 00:33:19 +02:00
}
$ use_output_queue = $ self - > { pbot } - > { factoids } - > { factoids } - > hash - > { $ chan } - > { $ trigger } - > { use_output_queue } ;
$ use_output_queue = 0 if not defined $ use_output_queue ;
2015-03-29 01:50:43 +01:00
}
2010-03-17 07:36:54 +01:00
}
2014-03-14 11:05:11 +01:00
}
2013-10-22 20:57:08 +02:00
2017-11-16 18:23:58 +01:00
my $ preserve_newlines = $ self - > { pbot } - > { registry } - > get_value ( $ stuff - > { from } , 'preserve_newlines' ) ;
2014-08-05 00:48:32 +02:00
$ result =~ s/[\n\r]/ /g unless $ preserve_newlines ;
2018-05-22 03:02:16 +02:00
$ result =~ s/[ \t]+/ /g unless $ stuff - > { preserve_whitespace } ;
2014-08-05 00:48:32 +02:00
2017-11-16 18:23:58 +01:00
my $ max_lines = $ self - > { pbot } - > { registry } - > get_value ( $ stuff - > { from } , 'max_newlines' ) ;
2014-08-06 01:15:11 +02:00
$ max_lines = 4 if not defined $ max_lines ;
2014-08-05 00:48:32 +02:00
my $ lines = 0 ;
2014-08-06 01:15:11 +02:00
2014-08-11 09:32:24 +02:00
my $ stripped_line ;
foreach my $ line ( split /[\n\r]+/ , $ result ) {
$ stripped_line = $ line ;
$ stripped_line =~ s/^\s+// ;
$ stripped_line =~ s/\s+$// ;
next if not length $ stripped_line ;
2014-08-06 01:15:11 +02:00
if ( + + $ lines >= $ max_lines ) {
2017-12-06 06:05:44 +01:00
my $ link = $ self - > { pbot } - > { webpaste } - > paste ( "[" . ( defined $ stuff - > { from } ? $ stuff - > { from } : "stdin" ) . "] <$stuff->{nick}> $stuff->{text}\n\n$original_result" ) ;
2015-03-29 01:50:43 +01:00
if ( $ use_output_queue ) {
my $ message = {
2017-11-16 18:23:58 +01:00
nick = > $ stuff - > { nick } , user = > $ stuff - > { user } , host = > $ stuff - > { host } , command = > $ stuff - > { command } ,
2015-03-29 01:50:43 +01:00
message = > "And that's all I have to say about that. See $link for full text." ,
2018-02-16 20:12:41 +01:00
checkflood = > 1
2015-03-29 01:50:43 +01:00
} ;
2017-11-16 18:23:58 +01:00
$ self - > add_message_to_output_queue ( $ stuff - > { from } , $ message , 0 ) ;
2015-03-29 01:50:43 +01:00
} else {
2017-11-16 18:23:58 +01:00
$ self - > { pbot } - > { conn } - > privmsg ( $ stuff - > { from } , "And that's all I have to say about that. See $link for full text." ) ;
2015-03-29 01:50:43 +01:00
}
2014-08-05 00:48:32 +02:00
last ;
2014-03-14 11:05:11 +01:00
}
2014-08-05 00:48:32 +02:00
if ( $ preserve_newlines ) {
2017-11-16 18:23:58 +01:00
$ line = $ self - > truncate_result ( $ stuff - > { from } , $ stuff - > { nick } , $ stuff - > { text } , $ line , $ line , 1 ) ;
2014-08-05 00:48:32 +02:00
} else {
2017-11-16 18:23:58 +01:00
$ line = $ self - > truncate_result ( $ stuff - > { from } , $ stuff - > { nick } , $ stuff - > { text } , $ original_result , $ line , 1 ) ;
2014-03-14 11:05:11 +01:00
}
2014-08-05 00:48:32 +02:00
2015-03-29 01:50:43 +01:00
if ( $ use_output_queue ) {
2019-06-02 03:55:08 +02:00
my $ delay = rand ( 10 ) + 5 ;
2015-03-29 01:50:43 +01:00
my $ message = {
2017-11-16 18:23:58 +01:00
nick = > $ stuff - > { nick } , user = > $ stuff - > { user } , host = > $ stuff - > { host } , command = > $ stuff - > { command } ,
2018-02-16 20:12:41 +01:00
message = > $ line , checkflood = > 1
2015-03-29 01:50:43 +01:00
} ;
2017-11-16 18:23:58 +01:00
$ self - > add_message_to_output_queue ( $ stuff - > { from } , $ message , $ delay ) ;
2015-03-31 00:04:08 +02:00
$ delay = duration ( $ delay ) ;
$ self - > { pbot } - > { logger } - > log ( "Final result ($delay delay) [$line]\n" ) ;
2014-03-14 11:05:11 +01:00
} else {
2017-11-16 18:23:58 +01:00
$ stuff - > { line } = $ line ;
$ self - > output_result ( $ stuff ) ;
2015-03-31 00:04:08 +02:00
$ self - > { pbot } - > { logger } - > log ( "Final result: [$line]\n" ) ;
2010-03-22 08:33:44 +01:00
}
2010-03-17 07:36:54 +01:00
}
2015-03-29 01:50:43 +01:00
$ self - > { pbot } - > { logger } - > log ( "---------------------------------------------\n" ) ;
2015-09-08 10:37:34 +02:00
return 1 ;
2015-03-29 01:50:43 +01:00
}
sub output_result {
2017-11-16 18:23:58 +01:00
my ( $ self , $ stuff ) = @ _ ;
2015-04-19 10:55:52 +02:00
my ( $ pbot , $ botnick ) = ( $ self - > { pbot } , $ self - > { pbot } - > { registry } - > get_value ( 'irc' , 'botnick' ) ) ;
2015-03-29 01:50:43 +01:00
2017-11-21 01:10:48 +01:00
if ( $ self - > { pbot } - > { registry } - > get_value ( 'general' , 'debugcontext' ) ) {
use Data::Dumper ;
$ Data:: Dumper:: Sortkeys = 1 ;
$ self - > { pbot } - > { logger } - > log ( "Interpreter::output_result\n" ) ;
$ self - > { pbot } - > { logger } - > log ( Dumper $ stuff ) ;
}
2017-11-16 18:23:58 +01:00
my $ line = $ stuff - > { line } ;
return if not defined $ line or not length $ line ;
if ( $ line =~ s/^\/say\s+//i ) {
2018-01-23 22:58:03 +01:00
if ( defined $ stuff - > { nickoverride } and ( $ stuff - > { no_nickoverride } == 0 or $ stuff - > { force_nickoverride } == 1 ) ) {
2017-11-26 05:00:55 +01:00
$ line = "$stuff->{nickoverride}: $line" ;
}
2017-11-16 18:23:58 +01:00
$ pbot - > { conn } - > privmsg ( $ stuff - > { from } , $ line ) if defined $ stuff - > { from } && $ stuff - > { from } !~ /\Q$botnick\E/i ;
$ pbot - > { antiflood } - > check_flood ( $ stuff - > { from } , $ botnick , $ pbot - > { registry } - > get_value ( 'irc' , 'username' ) , 'localhost' , $ line , 0 , 0 , 0 ) if $ stuff - > { checkflood } ;
} elsif ( $ line =~ s/^\/me\s+//i ) {
2018-05-22 03:06:32 +02:00
= cut
2017-11-26 05:00:55 +01:00
if ( defined $ stuff - > { nickoverride } ) {
$ line = "$line (for $stuff->{nickoverride})" ;
}
2018-05-22 03:06:32 +02:00
= cut
2017-11-16 18:23:58 +01:00
$ pbot - > { conn } - > me ( $ stuff - > { from } , $ line ) if defined $ stuff - > { from } && $ stuff - > { from } !~ /\Q$botnick\E/i ;
$ pbot - > { antiflood } - > check_flood ( $ stuff - > { from } , $ botnick , $ pbot - > { registry } - > get_value ( 'irc' , 'username' ) , 'localhost' , '/me ' . $ line , 0 , 0 , 0 ) if $ stuff - > { checkflood } ;
} elsif ( $ line =~ s/^\/msg\s+([^\s]+)\s+//i ) {
2015-03-29 01:50:43 +01:00
my $ to = $ 1 ;
2017-11-16 18:23:58 +01:00
if ( $ to =~ /,/ ) {
$ pbot - > { logger } - > log ( "[HACK] Possible HACK ATTEMPT /msg multiple users: [$stuff->{nick}!$stuff->{user}\@$stuff->{host}] [$stuff->{command}] [$line]\n" ) ;
2017-12-04 04:09:34 +01:00
} elsif ( $ to =~ /.*serv(?:@.*)?$/i ) {
2017-11-16 18:23:58 +01:00
$ pbot - > { logger } - > log ( "[HACK] Possible HACK ATTEMPT /msg *serv: [$stuff->{nick}!$stuff->{user}\@$stuff->{host}] [$stuff->{command}] [$line]\n" ) ;
} elsif ( $ line =~ s/^\/me\s+//i ) {
2018-05-22 03:06:32 +02:00
= cut
2017-11-26 05:00:55 +01:00
if ( defined $ stuff - > { nickoverride } ) {
$ line = "$line (for $stuff->{nickoverride})" ;
}
2018-05-22 03:06:32 +02:00
= cut
2015-04-19 10:55:52 +02:00
$ pbot - > { conn } - > me ( $ to , $ line ) if $ to !~ /\Q$botnick\E/i ;
2017-11-16 18:23:58 +01:00
$ pbot - > { antiflood } - > check_flood ( $ to , $ botnick , $ pbot - > { registry } - > get_value ( 'irc' , 'username' ) , 'localhost' , '/me ' . $ line , 0 , 0 , 0 ) if $ stuff - > { checkflood } ;
2015-03-29 01:50:43 +01:00
} else {
$ line =~ s/^\/say\s+//i ;
2018-01-23 22:58:03 +01:00
if ( defined $ stuff - > { nickoverride } and ( $ stuff - > { no_nickoverride } == 0 or $ stuff - > { force_nickoverride } == 1 ) ) {
2017-11-26 05:00:55 +01:00
$ line = "$stuff->{nickoverride}: $line" ;
}
2015-04-19 10:55:52 +02:00
$ pbot - > { conn } - > privmsg ( $ to , $ line ) if $ to !~ /\Q$botnick\E/i ;
2017-11-16 18:23:58 +01:00
$ pbot - > { antiflood } - > check_flood ( $ to , $ botnick , $ pbot - > { registry } - > get_value ( 'irc' , 'username' ) , 'localhost' , $ line , 0 , 0 , 0 ) if $ stuff - > { checkflood } ;
2015-03-29 01:50:43 +01:00
}
2017-11-18 06:37:54 +01:00
} elsif ( $ stuff - > { authorized } && $ line =~ s/^\/kick\s+// ) {
2017-11-16 18:23:58 +01:00
$ pbot - > { antiflood } - > check_flood ( $ stuff - > { from } , $ botnick , $ pbot - > { registry } - > get_value ( 'irc' , 'username' ) , 'localhost' , '/kick ' . $ line , 0 , 0 , 0 ) if $ stuff - > { checkflood } ;
2017-09-02 09:39:29 +02:00
my ( $ victim , $ reason ) = split /\s+/ , $ line , 2 ;
2016-11-17 04:07:01 +01:00
if ( not defined $ reason ) {
if ( open my $ fh , '<' , $ self - > { pbot } - > { registry } - > get_value ( 'general' , 'module_dir' ) . '/insults.txt' ) {
my @ insults = <$fh> ;
close $ fh ;
$ reason = $ insults [ rand @ insults ] ;
chomp $ reason ;
} else {
$ reason = 'Bye!' ;
}
}
2017-11-16 18:23:58 +01:00
if ( $ self - > { pbot } - > { chanops } - > can_gain_ops ( $ stuff - > { from } ) ) {
$ self - > { pbot } - > { chanops } - > add_op_command ( $ stuff - > { from } , "kick $stuff->{from} $victim $reason" ) ;
$ self - > { pbot } - > { chanops } - > gain_ops ( $ stuff - > { from } ) ;
2016-11-17 04:07:01 +01:00
} else {
2017-11-16 18:23:58 +01:00
$ pbot - > { conn } - > privmsg ( $ stuff - > { from } , "$victim: $reason" ) if defined $ stuff - > { from } && $ stuff - > { from } !~ /\Q$botnick\E/i ;
2016-11-17 04:07:01 +01:00
}
2015-03-29 01:50:43 +01:00
} else {
2018-01-23 22:58:03 +01:00
if ( defined $ stuff - > { nickoverride } and ( $ stuff - > { no_nickoverride } == 0 or $ stuff - > { force_nickoverride } == 1 ) ) {
2017-11-26 05:00:55 +01:00
$ line = "$stuff->{nickoverride}: $line" ;
}
2017-11-16 18:23:58 +01:00
$ pbot - > { conn } - > privmsg ( $ stuff - > { from } , $ line ) if defined $ stuff - > { from } && $ stuff - > { from } !~ /\Q$botnick\E/i ;
$ pbot - > { antiflood } - > check_flood ( $ stuff - > { from } , $ botnick , $ pbot - > { registry } - > get_value ( 'irc' , 'username' ) , 'localhost' , $ line , 0 , 0 , 0 ) if $ stuff - > { checkflood } ;
2015-03-29 01:50:43 +01:00
}
2010-03-17 07:36:54 +01:00
}
2015-03-29 01:50:43 +01:00
sub add_message_to_output_queue {
2015-03-30 05:24:36 +02:00
my ( $ self , $ channel , $ message , $ delay ) = @ _ ;
2018-02-19 01:39:26 +01:00
if ( $ delay > 0 and exists $ self - > { output_queue } - > { $ channel } ) {
2015-03-30 05:24:36 +02:00
my $ last_when = $ self - > { output_queue } - > { $ channel } - > [ - 1 ] - > { when } ;
$ message - > { when } = $ last_when + $ delay ;
} else {
$ message - > { when } = gettimeofday + $ delay ;
}
push @ { $ self - > { output_queue } - > { $ channel } } , $ message ;
2018-02-19 01:39:26 +01:00
$ self - > process_output_queue if $ delay <= 0 ;
2015-03-29 01:50:43 +01:00
}
sub process_output_queue {
my $ self = shift ;
2015-03-30 05:24:36 +02:00
foreach my $ channel ( keys % { $ self - > { output_queue } } ) {
for ( my $ i = 0 ; $ i < @ { $ self - > { output_queue } - > { $ channel } } ; $ i + + ) {
my $ message = $ self - > { output_queue } - > { $ channel } - > [ $ i ] ;
if ( gettimeofday >= $ message - > { when } ) {
2017-11-16 18:23:58 +01:00
my $ stuff = {
from = > $ channel ,
nick = > $ message - > { nick } ,
user = > $ message - > { user } ,
host = > $ message - > { host } ,
line = > $ message - > { message } ,
command = > $ message - > { command } ,
checkflood = > $ message - > { checkflood }
} ;
$ self - > output_result ( $ stuff ) ;
2015-03-30 05:24:36 +02:00
splice @ { $ self - > { output_queue } - > { $ channel } } , $ i - - , 1 ;
}
}
if ( not @ { $ self - > { output_queue } - > { $ channel } } ) {
delete $ self - > { output_queue } - > { $ channel } ;
2015-03-29 01:50:43 +01:00
}
}
}
2016-07-01 22:00:20 +02:00
sub add_to_command_queue {
my ( $ self , $ channel , $ command , $ delay ) = @ _ ;
2016-07-01 22:29:26 +02:00
$ command - > { when } = gettimeofday + $ delay ;
2016-07-01 22:00:20 +02:00
push @ { $ self - > { command_queue } - > { $ channel } } , $ command ;
}
sub add_botcmd_to_command_queue {
my ( $ self , $ channel , $ command , $ delay ) = @ _ ;
my $ botcmd = {
nick = > $ self - > { pbot } - > { registry } - > get_value ( 'irc' , 'botnick' ) ,
user = > 'stdin' ,
host = > 'localhost' ,
command = > $ command
} ;
$ self - > add_to_command_queue ( $ channel , $ botcmd , $ delay ) ;
}
sub process_command_queue {
my $ self = shift ;
foreach my $ channel ( keys % { $ self - > { command_queue } } ) {
for ( my $ i = 0 ; $ i < @ { $ self - > { command_queue } - > { $ channel } } ; $ i + + ) {
my $ command = $ self - > { command_queue } - > { $ channel } - > [ $ i ] ;
if ( gettimeofday >= $ command - > { when } ) {
2017-11-16 18:23:58 +01:00
my $ stuff = {
from = > $ channel ,
nick = > $ command - > { nick } ,
user = > $ command - > { user } ,
host = > $ command - > { host } ,
command = > $ command - > { command } ,
interpret_depth = > 0 ,
checkflood = > 0 ,
preserve_whitespace = > 0
} ;
2017-12-11 21:44:19 +01:00
if ( exists $ command - > { level } ) {
$ self - > { pbot } - > { logger } - > log ( "Override command effective-level to $command->{level}\n" ) ;
$ stuff - > { 'effective-level' } = $ command - > { level } ;
}
2017-11-16 18:23:58 +01:00
my $ result = $ self - > interpret ( $ stuff ) ;
$ stuff - > { result } = $ result ;
$ self - > handle_result ( $ stuff , $ result ) ;
2016-07-01 22:00:20 +02:00
splice @ { $ self - > { command_queue } - > { $ channel } } , $ i - - , 1 ;
}
}
if ( not @ { $ self - > { command_queue } - > { $ channel } } ) {
delete $ self - > { command_queue } - > { $ channel } ;
}
}
}
2010-03-17 07:36:54 +01:00
1 ;