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
#
2019-06-26 18:34:19 +02: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 ;
2020-02-15 23:38:32 +01:00
2020-02-08 20:04:13 +01:00
use parent 'PBot::Class' , 'PBot::Registerable' ;
2010-03-17 07:36:54 +01:00
2020-02-08 20:04:13 +01:00
use warnings ; use strict ;
2019-07-11 03:40:53 +02:00
use feature 'unicode_strings' ;
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
2017-09-05 09:27:28 +02:00
use PBot::Utils::ValidateString ;
2010-03-22 08:33:44 +01:00
sub initialize {
2020-02-15 23:38:32 +01:00
my ( $ self , % conf ) = @ _ ;
$ self - > PBot::Registerable:: initialize ( % conf ) ;
2010-04-13 06:17:54 +02:00
2020-02-15 23:38:32 +01: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 } // '.*' ) ;
$ self - > { pbot } - > { registry } - > add_default ( 'array' , 'general' , 'compile_blocks_ignore_channels' , $ conf { compile_blocks_ignore_channels } // 'none' ) ;
$ self - > { pbot } - > { registry } - > add_default ( 'text' , 'interpreter' , 'max_recursion' , 10 ) ;
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 {
2020-02-15 23:38:32 +01:00
my $ self = shift ;
my ( $ from , $ nick , $ user , $ host , $ text ) = @ _ ;
$ from = lc $ from if defined $ from ;
2020-05-02 05:59:51 +02:00
my $ context = { from = > $ from , nick = > $ nick , user = > $ user , host = > $ host , text = > $ text } ;
2020-02-15 23:38:32 +01:00
my $ pbot = $ self - > { pbot } ;
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 } ) ;
2020-05-02 05:59:51 +02:00
$ context - > { message_account } = $ message_account ;
2020-02-15 23:38:32 +01: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 ;
if ( defined $ from and $ from =~ m/^#/ ) {
my $ chanmodes = $ self - > { pbot } - > { channels } - > get_meta ( $ from , 'MODE' ) ;
if ( defined $ chanmodes and $ chanmodes =~ m/z/ ) {
2020-05-02 05:59:51 +02:00
$ context - > { 'chan-z' } = 1 ;
2020-04-29 06:33:49 +02:00
if ( $ self - > { pbot } - > { banlist } - > { quietlist } - > exists ( $ from , '$~a' ) ) {
2020-02-15 23:38:32 +01:00
my $ nickserv = $ self - > { pbot } - > { messagehistory } - > { database } - > get_current_nickserv_account ( $ message_account ) ;
2020-05-02 05:59:51 +02:00
if ( not defined $ nickserv or not length $ nickserv ) { $ context - > { unidentified } = 1 ; }
2020-02-15 23:38:32 +01:00
}
2018-08-13 23:25:35 +02:00
2020-05-02 05:59:51 +02:00
$ context - > { banned } = 1 if $ self - > { pbot } - > { banlist } - > is_banned ( $ nick , $ user , $ host , $ from ) ;
2020-02-15 23:38:32 +01:00
}
2018-08-06 07:48:24 +02:00
}
2020-02-15 23:38:32 +01:00
$ pbot - > { antiflood } - > check_flood (
$ from , $ nick , $ user , $ host , $ text ,
$ flood_threshold , $ flood_time_threshold ,
2020-05-02 05:59:51 +02:00
$ pbot - > { messagehistory } - > { MSG_CHAT } , $ context
2020-02-15 23:38:32 +01:00
) if defined $ from ;
2018-08-13 23:25:35 +02:00
2020-05-02 05:59:51 +02:00
if ( $ context - > { banned } or $ context - > { unidentified } ) {
2020-02-15 23:38:32 +01:00
$ self - > { pbot } - > { logger } - > log ( "Disregarding banned/unidentified user message (channel $from is +z).\n" ) ;
return 1 ;
}
2018-08-13 23:25:35 +02:00
2020-02-15 23:38:32 +01:00
my $ botnick = $ self - > { pbot } - > { registry } - > get_value ( 'irc' , 'botnick' ) ;
2017-12-09 04:28:08 +01:00
2020-02-15 23:38:32 +01:00
# get channel-specific trigger if available
my $ bot_trigger = $ pbot - > { registry } - > get_value ( $ from , 'trigger' ) ;
2017-12-09 04:28:08 +01:00
2020-02-15 23:38:32 +01:00
# otherwise get general trigger
if ( not defined $ bot_trigger ) { $ bot_trigger = $ pbot - > { registry } - > get_value ( 'general' , 'trigger' ) ; }
2017-12-09 04:28:08 +01:00
2020-02-15 23:38:32 +01:00
my $ nick_regex = qr/[^%!,:\(\)\+\*\/ ] + / ;
2017-12-09 04:28:08 +01:00
2020-02-15 23:38:32 +01:00
my $ nick_override ;
my $ processed = 0 ;
my $ preserve_whitespace = 0 ;
2015-09-08 10:37:34 +02:00
2020-02-15 23:38:32 +01:00
$ text =~ s/^\s+// ;
$ text =~ s/\s+$// ;
$ text = validate_string ( $ text , 0 ) ;
2012-07-22 21:22:30 +02:00
2020-02-15 23:38:32 +01:00
my $ cmd_text = $ text ;
$ cmd_text =~ s/^\/me\s+// ;
2013-07-24 14:33:19 +02:00
2020-02-15 23:38:32 +01:00
# check for bot command invocation
my @ commands ;
my $ command ;
my $ embedded = 0 ;
2017-11-15 00:27:30 +01:00
2020-02-15 23:38:32 +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*(.+)$/ ) {
my $ possible_nick_override = $ 1 ;
$ command = $ 2 ;
2017-11-15 00:27:30 +01:00
2020-02-15 23:38:32 +01:00
my $ similar = $ self - > { pbot } - > { nicklist } - > is_present_similar ( $ from , $ possible_nick_override ) ;
if ( $ similar ) { $ nick_override = $ similar ; }
else {
$ self - > { pbot } - > { logger } - > log ( "No similar nick for $possible_nick_override\n" ) ;
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 ;
2017-12-09 04:28:08 +01:00
}
2020-02-15 23:38:32 +01:00
# check for embedded commands
2017-12-09 04:28:08 +01:00
CHECK_EMBEDDED_CMD:
2020-02-15 23:38:32 +01:00
if ( not defined $ command or $ command =~ m/^\{.*\}/ ) {
if ( $ cmd_text =~ s/^\s*($nick_regex)[,:]\s+// ) {
my $ possible_nick_override = $ 1 ;
my $ similar = $ self - > { pbot } - > { nicklist } - > is_present_similar ( $ from , $ possible_nick_override ) ;
if ( $ similar ) { $ nick_override = $ similar ; }
}
2015-09-04 05:56:44 +02:00
2020-02-15 23:38:32 +01:00
for ( my $ count = 0 ; $ count < 3 ; $ count + + ) {
my ( $ extracted , $ rest ) = $ self - > extract_bracketed ( $ cmd_text , '{' , '}' , $ bot_trigger ) ;
last if not length $ extracted ;
$ cmd_text = $ rest ;
$ extracted =~ s/^\s+|\s+$//g ;
push @ commands , $ extracted ;
$ embedded = 1 ;
}
} else {
push @ commands , $ command ;
2015-09-07 14:04:54 +02:00
}
2010-03-17 07:36:54 +01:00
2020-02-15 23:38:32 +01:00
foreach $ command ( @ commands ) {
# check if user is ignored (and command isn't `login`)
2020-03-04 22:24:40 +01:00
if ( $ command !~ /^login / && defined $ from && $ pbot - > { ignorelist } - > is_ignored ( $ from , "$nick!$user\@$host" ) ) {
$ self - > { pbot } - > { logger } - > log ( "Disregarding command from ignored user $nick!$user\@$host in $from.\n" ) ;
return 1 ;
2020-02-15 23:38:32 +01:00
}
2020-05-02 05:59:51 +02:00
$ context - > { text } = $ text ;
$ context - > { command } = $ command ;
2019-08-06 19:38:46 +02:00
2020-02-15 23:38:32 +01:00
if ( $ nick_override ) {
2020-05-02 05:59:51 +02:00
$ context - > { nickoverride } = $ nick_override ;
$ context - > { force_nickoverride } = 1 ;
2020-02-15 23:38:32 +01:00
}
2017-12-09 04:28:08 +01:00
2020-05-02 05:59:51 +02:00
$ context - > { referenced } = $ embedded ;
2020-05-03 08:49:29 +02:00
$ context - > { interpret_depth } = 0 ;
2020-05-02 05:59:51 +02:00
$ context - > { preserve_whitespace } = $ preserve_whitespace ;
2020-02-15 23:38:32 +01:00
2020-05-02 05:59:51 +02:00
$ context - > { result } = $ self - > interpret ( $ context ) ;
$ self - > handle_result ( $ context ) ;
2020-02-15 23:38:32 +01:00
$ processed + + ;
}
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 {
2020-05-02 05:59:51 +02:00
my ( $ self , $ context ) = @ _ ;
2020-02-16 19:46:26 +01:00
my ( $ keyword , $ arguments ) = ( '' , '' ) ;
2020-02-15 23:38:32 +01:00
my $ text ;
my $ pbot = $ self - > { pbot } ;
2020-05-03 08:49:29 +02:00
$ context - > { interpret_depth } + + ;
2020-05-02 05:59:51 +02:00
$ pbot - > { logger } - > log ( "=== [$context->{interpret_depth}] Got command: ("
. ( defined $ context - > { from } ? $ context - > { from } : "undef" )
. ") $context->{nick}!$context->{user}\@$context->{host}: $context->{command}\n" ) ;
2020-02-15 23:38:32 +01:00
2020-05-02 05:59:51 +02:00
$ context - > { special } = "" unless exists $ self - > { special } ;
2020-02-15 23:38:32 +01:00
if ( $ self - > { pbot } - > { registry } - > get_value ( 'general' , 'debugcontext' ) ) {
use Data::Dumper ;
$ Data:: Dumper:: Sortkeys = 1 ;
$ self - > { pbot } - > { logger } - > log ( "Interpreter::interpret\n" ) ;
2020-05-02 05:59:51 +02:00
$ self - > { pbot } - > { logger } - > log ( Dumper $ context ) ;
2017-11-16 18:23:58 +01:00
}
2017-12-05 03:34:34 +01:00
2020-05-03 08:49:29 +02:00
return "Too many levels of recursion, aborted." if ( $ context - > { interpret_depth } > $ self - > { pbot } - > { registry } - > get_value ( 'interpreter' , 'max_recursion' ) ) ;
2020-02-15 23:38:32 +01:00
2020-05-02 05:59:51 +02:00
if ( not defined $ context - > { nick } || not defined $ context - > { user } || not defined $ context - > { host } || not defined $ context - > { command } ) {
2020-02-15 23:38:32 +01:00
$ pbot - > { logger } - > log ( "Error 1, bad parameters to interpret_command\n" ) ;
return undef ;
}
2017-11-17 22:53:23 +01:00
2020-02-15 23:38:32 +01:00
# check for splitted commands
2020-05-02 05:59:51 +02:00
if ( $ context - > { command } =~ m/^(.*?)\s*(?<!\\);;;\s*(.*)/ms ) {
$ context - > { command } = $ 1 ;
$ context - > { command_split } = $ 2 ;
2020-02-15 23:38:32 +01:00
}
2017-11-29 04:07:01 +01:00
2020-05-02 05:59:51 +02:00
my $ cmdlist = $ self - > make_args ( $ context - > { command } ) ;
$ context - > { commands } = [] unless exists $ context - > { commands } ;
push @ { $ context - > { commands } } , $ context - > { command } ;
2020-02-15 23:38:32 +01: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' ) ) {
# tell nick about/the cmd [args]
2020-05-02 05:59:51 +02:00
$ context - > { nickoverride } = $ cmdlist - > [ 1 ] ;
2020-02-15 23:38:32 +01:00
( $ keyword , $ arguments ) = $ self - > split_args ( $ cmdlist , 2 , 3 , 1 ) ;
$ arguments = '' if not defined $ arguments ;
2020-05-02 05:59:51 +02:00
my $ similar = $ self - > { pbot } - > { nicklist } - > is_present_similar ( $ context - > { from } , $ context - > { nickoverride } ) ;
2020-02-15 23:38:32 +01:00
if ( $ similar ) {
2020-05-02 05:59:51 +02:00
$ context - > { nickoverride } = $ similar ;
$ context - > { force_nickoverride } = 1 ;
2020-02-15 23:38:32 +01:00
} else {
2020-05-02 05:59:51 +02:00
delete $ context - > { nickoverride } ;
delete $ context - > { force_nickoverride } ;
2020-02-15 23:38:32 +01:00
}
2017-11-29 04:07:01 +01:00
} else {
2020-02-15 23:38:32 +01:00
# normal command
( $ keyword , $ arguments ) = $ self - > split_args ( $ cmdlist , 2 , 0 , 1 ) ;
2020-02-16 19:46:26 +01:00
$ arguments = '' if not defined $ arguments ;
2017-11-29 04:07:01 +01:00
}
2020-02-15 23:38:32 +01: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" ) ;
}
# parse out a substituted command
if ( defined $ arguments && $ arguments =~ m/(?<!\\)&\s*\{/ ) {
my ( $ command ) = $ self - > extract_bracketed ( $ arguments , '{' , '}' , '&' , 1 ) ;
if ( length $ command ) {
$ arguments =~ s/&\s*\{\Q$command\E\}/&{subcmd}/ ;
2020-05-02 05:59:51 +02:00
push @ { $ context - > { subcmd } } , "$keyword $arguments" ;
2020-02-15 23:38:32 +01:00
$ command =~ s/^\s+|\s+$//g ;
2020-05-02 05:59:51 +02:00
$ context - > { command } = $ command ;
$ context - > { commands } = [] ;
push @ { $ context - > { commands } } , $ command ;
$ context - > { result } = $ self - > interpret ( $ context ) ;
return $ context - > { result } ;
2020-02-15 23:38:32 +01:00
}
2017-08-26 13:06:36 +02:00
}
2015-03-31 00:04:08 +02:00
2020-02-15 23:38:32 +01:00
# parse out a pipe
if ( defined $ arguments && $ arguments =~ m/(?<!\\)\|\s*\{\s*[^}]+\}\s*$/ ) {
my ( $ pipe , $ rest ) = $ self - > extract_bracketed ( $ arguments , '{' , '}' , '|' , 1 ) ;
$ arguments =~ s/\s*(?<!\\)\|\s*{(\Q$pipe\E)}.*$//s ;
$ pipe =~ s/^\s+|\s+$//g ;
2015-03-31 00:04:08 +02:00
2020-05-02 05:59:51 +02:00
if ( exists $ context - > { pipe } ) { $ context - > { pipe_rest } = "$rest | { $context->{pipe} }$context->{pipe_rest}" ; }
else { $ context - > { pipe_rest } = $ rest ; }
$ context - > { pipe } = $ pipe ;
2020-02-15 23:38:32 +01:00
}
if ( not $ self - > { pbot } - > { commands } - > get_meta ( $ keyword , 'dont-replace-pronouns' )
2020-05-02 05:59:51 +02:00
and not $ self - > { pbot } - > { factoids } - > get_meta ( $ context - > { from } , $ keyword , 'dont-replace-pronouns' ) )
2020-02-15 23:38:32 +01:00
{
2020-05-02 05:59:51 +02:00
$ context - > { nickoverride } = $ context - > { nick } if defined $ context - > { nickoverride } and lc $ context - > { nickoverride } eq 'me' ;
2020-02-15 23:38:32 +01:00
$ keyword =~ s/(\w+)([?!.]+)$/$1/ ;
2020-05-02 05:59:51 +02:00
$ arguments =~ s/(?<![\w\/\-\\])i am\b/$context->{nick} is/gi if defined $ arguments && $ context - > { interpret_depth } <= 2 ;
$ arguments =~ s/(?<![\w\/\-\\])me\b/$context->{nick}/gi if defined $ arguments && $ context - > { interpret_depth } <= 2 ;
$ arguments =~ s/(?<![\w\/\-\\])my\b/$context->{nick}'s/gi if defined $ arguments && $ context - > { interpret_depth } <= 2 ;
$ arguments =~ s/\\my\b/my/gi if defined $ arguments && $ context - > { interpret_depth } <= 2 ;
$ arguments =~ s/\\me\b/me/gi if defined $ arguments && $ context - > { interpret_depth } <= 2 ;
$ arguments =~ s/\\i am\b/i am/gi if defined $ arguments && $ context - > { interpret_depth } <= 2 ;
2020-02-15 23:38:32 +01:00
}
2020-05-02 05:59:51 +02:00
if ( not $ self - > { pbot } - > { commands } - > get_meta ( $ keyword , 'dont-protect-self' ) and not $ self - > { pbot } - > { factoids } - > get_meta ( $ context - > { from } , $ keyword , 'dont-protect-self' ) ) {
2020-02-15 23:38:32 +01: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 ) ) {
my $ delay = rand ( 10 ) + 5 ;
my $ message = {
2020-05-02 05:59:51 +02:00
nick = > $ context - > { nick } , user = > $ context - > { user } , host = > $ context - > { host } , command = > $ context - > { command } , checkflood = > 1 ,
message = > "$context->{nick}: Why would I want to do that to myself?"
2020-02-15 23:38:32 +01:00
} ;
2020-05-02 05:59:51 +02:00
$ self - > add_message_to_output_queue ( $ context - > { from } , $ message , $ delay ) ;
2020-02-15 23:38:32 +01:00
$ delay = duration ( $ delay ) ;
$ self - > { pbot } - > { logger } - > log ( "($delay delay) $message->{message}\n" ) ;
return undef ;
}
}
2017-11-15 00:27:30 +01:00
2020-02-15 23:38:32 +01:00
if ( not defined $ keyword ) {
$ pbot - > { logger } - > log ( "Error 2, no keyword\n" ) ;
return undef ;
}
2019-08-06 19:44:10 +02:00
2020-05-02 05:59:51 +02:00
if ( not exists $ context - > { root_keyword } ) { $ context - > { root_keyword } = $ keyword ; }
2019-06-26 03:23:21 +02:00
2020-05-02 05:59:51 +02:00
$ context - > { keyword } = $ keyword ;
$ context - > { original_arguments } = $ arguments ;
2018-05-22 04:27:57 +02:00
2020-02-15 23:38:32 +01:00
# unescape any escaped command splits
$ arguments =~ s/\\;;;/;;;/g if defined $ arguments ;
2018-05-22 04:27:57 +02:00
2020-02-15 23:38:32 +01:00
# unescape any escaped substituted commands
$ arguments =~ s/\\&\s*\{/&{/g if defined $ arguments ;
2018-08-09 02:38:57 +02:00
2020-02-15 23:38:32 +01:00
# unescape any escaped pipes
$ arguments =~ s/\\\|\s*\{/| {/g if defined $ arguments ;
2017-11-15 00:27:30 +01:00
2020-02-15 23:38:32 +01:00
$ arguments = validate_string ( $ arguments ) ;
2018-08-09 02:38:57 +02:00
2020-02-15 23:38:32 +01:00
# set arguments as a plain string
2020-05-02 05:59:51 +02:00
$ context - > { arguments } = $ arguments ;
delete $ context - > { args_utf8 } ;
2020-02-15 23:38:32 +01:00
# set arguments as an array
2020-05-02 05:59:51 +02:00
$ context - > { arglist } = $ self - > make_args ( $ arguments ) ;
2020-02-15 23:38:32 +01:00
# execute all registered interpreters
my $ result ;
foreach my $ func ( @ { $ self - > { handlers } } ) {
2020-05-02 05:59:51 +02:00
$ result = & { $ func - > { subref } } ( $ context ) ;
2020-02-15 23:38:32 +01:00
last if defined $ result ;
# reset any manipulated arguments
2020-05-02 05:59:51 +02:00
$ context - > { arguments } = $ context - > { original_arguments } ;
delete $ context - > { args_utf8 } ;
2020-02-15 23:38:32 +01:00
}
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 {
2020-02-15 23:38:32 +01:00
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 $ token = '' ;
my $ ch = ' ' ;
my $ last_ch ;
my $ i = 0 ;
my $ bracket_pos ;
my $ bracket_level = 0 ;
my $ prefix_group_match = @ prefix_group ? 0 : 1 ;
my $ prefix_match = @ prefixes ? 0 : 1 ;
my $ match = 0 ;
my @ chars = split // , $ string ;
my $ state = 'prefixgroup' ;
while ( 1 ) {
$ last_ch = $ ch ;
if ( $ i >= @ chars ) {
if ( $ 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
}
2020-02-15 23:38:32 +01:00
$ ch = $ chars [ $ i + + ] ;
2019-05-30 09:27:52 +02:00
2020-02-15 23:38:32 +01:00
if ( $ escaped ) {
$ token . = "\\$ch" if $ extracting or $ extracted ;
$ escaped = 0 ;
2019-05-30 09:27:52 +02:00
next ;
}
2020-02-15 23:38:32 +01:00
if ( $ ch eq '\\' ) {
$ escaped = 1 ;
next ;
2019-05-30 09:27:52 +02:00
}
2020-02-15 23:38:32 +01: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 ;
}
}
next if $ prefix_group_match ;
} elsif ( $ state eq 'prefixgroup' and not @ prefix_group ) {
$ state = 'prefixes' ;
$ prefix_index = 0 ;
}
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' ;
}
}
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' ;
next ;
}
}
}
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 ;
}
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 ;
2019-05-30 09:27:52 +02:00
} else {
2020-02-15 23:38:32 +01:00
$ close_index = 0 ;
2019-05-30 09:27:52 +02:00
}
}
2020-02-15 23:38:32 +01:00
if ( $ extracting or $ extracted ) { $ token . = $ ch ; }
2019-05-30 09:27:52 +02:00
}
2020-02-15 23:38:32 +01:00
return ( $ result , $ rest ) ;
2019-05-30 09:27:52 +02:00
}
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 {
2020-02-15 23:38:32 +01:00
my ( $ self , $ line , % opts ) = @ _ ;
my % default_opts = (
strip_quotes = > 0 ,
keep_spaces = > 0 ,
preserve_escapes = > 1 ,
) ;
% opts = ( % default_opts , % opts ) ;
my @ chars = split // , $ line ;
my @ args ;
my $ escaped = 0 ;
my $ quote ;
my $ token = '' ;
my $ last_token = '' ;
my $ ch = ' ' ;
my $ last_ch ;
my $ next_ch ;
my $ i = 0 ;
my $ pos ;
my $ ignore_quote = 0 ;
my $ spaces = 0 ;
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 ;
$ last_ch = ' ' ;
$ token = $ last_token ;
} else {
# add final token and exit
push @ args , $ token if length $ token ;
last ;
}
}
2019-05-28 20:11:32 +02:00
2020-02-15 23:38:32 +01:00
$ ch = $ chars [ $ i + + ] ;
$ next_ch = $ chars [ $ i ] ;
2019-06-09 22:57:08 +02:00
2020-02-15 23:38:32 +01:00
$ spaces = 0 if $ ch ne ' ' ;
2019-05-28 20:11:32 +02:00
2020-02-15 23:38:32 +01:00
if ( $ escaped ) {
if ( $ opts { preserve_escapes } ) { $ token . = "\\$ch" ; }
else { $ token . = $ ch ; }
$ escaped = 0 ;
next ;
}
2019-05-28 20:11:32 +02:00
2020-02-15 23:38:32 +01:00
if ( $ ch eq '\\' ) {
$ escaped = 1 ;
next ;
}
2019-05-28 20:11:32 +02:00
2020-02-15 23:38:32 +01:00
if ( defined $ quote ) {
if ( $ ch eq $ quote and ( not defined $ next_ch or $ next_ch =~ /[\s,:;})\].+=]/ ) ) {
# closing quote
$ token . = $ ch unless $ opts { strip_quotes } ;
push @ args , $ token ;
$ quote = undef ;
$ token = '' ;
} else {
# still within quoted argument
$ token . = $ ch ;
}
next ;
}
if ( ( $ last_ch =~ /[\s:{(\[.+=]/ ) and not defined $ quote and ( $ ch eq "'" or $ ch eq '"' ) ) {
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 ;
$ last_token = $ token ;
$ token . = $ ch unless $ opts { strip_quotes } ;
}
next ;
}
if ( $ ch eq ' ' or $ ch eq "\n" or $ ch eq "\t" ) {
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
2019-06-09 22:57:08 +02:00
$ token . = $ ch ;
2019-05-28 20:11:32 +02:00
}
2020-02-15 23:38:32 +01:00
return @ args ;
2019-05-28 20:11:32 +02:00
}
2018-08-09 02:38:57 +02:00
# creates an array of arguments from a string
sub make_args {
2020-02-15 23:38:32 +01:00
my ( $ self , $ string ) = @ _ ;
2018-08-09 02:38:57 +02:00
2020-02-15 23:38:32 +01:00
my @ args = $ self - > split_line ( $ string , keep_spaces = > 1 ) ;
2019-05-28 20:11:32 +02:00
2020-02-15 23:38:32 +01:00
my @ arglist ;
my @ arglist_unstripped ;
2018-08-07 05:23:35 +02:00
2020-02-15 23:38:32 +01:00
while ( @ args ) {
my $ arg = shift @ args ;
2018-08-07 05:23:35 +02:00
2020-02-15 23:38:32 +01:00
# add argument with quotes and spaces preserved
push @ arglist_unstripped , $ arg ;
2019-05-28 20:11:32 +02:00
2020-02-15 23:38:32 +01:00
# strip quotes from argument
if ( $ arg =~ m/^'.*'$/ ) {
$ arg =~ s/^'// ;
$ arg =~ s/'$// ;
} elsif ( $ arg =~ m/^".*"$/ ) {
$ arg =~ s/^"// ;
$ arg =~ s/"$// ;
}
2019-05-28 20:11:32 +02:00
2020-02-15 23:38:32 +01:00
# strip leading spaces from argument
$ arg =~ s/^\s+// ;
2019-06-09 22:57:08 +02:00
2020-02-15 23:38:32 +01:00
# add stripped argument
push @ arglist , $ arg ;
}
2018-08-07 05:23:35 +02:00
2020-02-15 23:38:32 +01:00
# copy unstripped arguments to end of arglist
push @ arglist , @ arglist_unstripped ;
return \ @ arglist ;
2018-08-09 02:38:57 +02:00
}
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 {
2020-02-15 23:38:32 +01:00
my ( $ self , $ args ) = @ _ ;
return @$ args / 2 ;
2018-08-09 02:38:57 +02:00
}
2020-01-12 02:46:44 +01:00
# unshifts new argument to front
sub unshift_arg {
2020-02-15 23:38:32 +01:00
my ( $ self , $ args , $ arg ) = @ _ ;
splice @$ args , @$ args / 2 , 0 , $ arg ; # add quoted argument
unshift @$ args , $ arg ; # add first argument
return @$ args ;
2020-01-12 02:46:44 +01:00
}
2018-08-09 02:38:57 +02:00
# shifts first argument off array of arguments
sub shift_arg {
2020-02-15 23:38:32 +01:00
my ( $ self , $ args ) = @ _ ;
return undef if not @$ args ;
splice @$ args , @$ args / 2 , 1 ; # remove original quoted argument
return shift @$ args ;
2015-03-31 00:04:08 +02:00
}
2020-01-12 02:46:44 +01:00
# returns list of unquoted arguments
sub unquoted_args {
2020-02-15 23:38:32 +01:00
my ( $ self , $ args ) = @ _ ;
return undef if not @$ args ;
return @$ args [ 0 .. @$ args / 2 - 1 ] ;
2020-01-12 02:46:44 +01: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 {
2020-02-15 23:38:32 +01:00
my ( $ self , $ args , $ count , $ offset , $ preserve_quotes ) = @ _ ;
my @ result ;
my $ max = $ self - > arglist_size ( $ args ) ;
$ preserve_quotes // = 0 ;
my $ i = $ offset // 0 ;
unless ( $ count == 1 ) {
do {
my $ arg = $ args - > [ $ i + + ] ;
push @ result , $ arg ;
} while ( - - $ count > 1 and $ i < $ max ) ;
}
# join the get rest as a string
my $ rest ;
if ( $ preserve_quotes ) {
# get from second half of args, which contains quotes
$ rest = join ' ' , @$ args [ @$ args / 2 + $ i .. @$ args - 1 ] ;
} else {
$ rest = join ' ' , @$ args [ $ i .. $ max - 1 ] ;
}
push @ result , $ rest if length $ rest ;
return @ result ;
2018-08-07 05:23:35 +02:00
}
2018-08-09 02:38:57 +02:00
# lowercases array of arguments
sub lc_args {
2020-02-15 23:38:32 +01:00
my ( $ self , $ args ) = @ _ ;
for ( my $ i = 0 ; $ i < @$ args ; $ i + + ) { $ args - > [ $ i ] = lc $ args - > [ $ i ] ; }
2018-08-09 02:38:57 +02:00
}
2014-03-15 02:53:33 +01:00
sub truncate_result {
2020-02-15 23:38:32 +01:00
my ( $ self , $ from , $ nick , $ text , $ original_result , $ result , $ paste ) = @ _ ;
my $ max_msg_len = $ self - > { pbot } - > { registry } - > get_value ( 'irc' , 'max_msg_len' ) ;
2020-02-26 11:30:26 +01:00
$ max_msg_len -= length "PRIVMSG $from :" if defined $ from ;
2020-02-15 23:38:32 +01:00
2020-02-19 05:05:47 +01:00
utf8:: encode $ result ;
utf8:: encode $ original_result ;
use bytes ;
2020-02-15 23:38:32 +01:00
if ( length $ result > $ max_msg_len ) {
my $ link ;
if ( $ paste ) {
2020-02-19 05:05:47 +01:00
my $ max_paste_len = $ self - > { pbot } - > { registry } - > get_value ( 'paste' , 'max_length' ) // 1024 * 32 ;
$ original_result = substr $ original_result , 0 , $ max_paste_len ;
2020-02-15 23:38:32 +01:00
$ link = $ self - > { pbot } - > { webpaste } - > paste ( "[" . ( defined $ from ? $ from : "stdin" ) . "] <$nick> $text\n\n$original_result" ) ;
} else {
$ link = 'undef' ;
}
2014-03-15 02:53:33 +01:00
2020-02-15 23:38:32 +01:00
my $ trunc = "... [truncated; " ;
if ( $ link =~ m/^http/ ) { $ trunc . = "see $link for full text.]" ; }
else { $ trunc . = "$link]" ; }
2015-05-07 06:15:25 +02:00
2020-02-15 23:38:32 +01:00
$ self - > { pbot } - > { logger } - > log ( "Message truncated -- pasted to $link\n" ) if $ paste ;
my $ trunc_len = length $ result < $ max_msg_len ? length $ result : $ max_msg_len ;
$ result = substr ( $ result , 0 , $ trunc_len ) ;
substr ( $ result , $ trunc_len - length $ trunc ) = $ trunc ;
}
2014-03-15 02:53:33 +01:00
2020-02-19 05:05:47 +01:00
utf8:: decode $ result ;
2020-02-15 23:38:32 +01:00
return $ result ;
2014-03-15 02:53:33 +01:00
}
2014-03-14 11:05:11 +01:00
sub handle_result {
2020-05-02 05:59:51 +02:00
my ( $ self , $ context , $ result ) = @ _ ;
$ result = $ context - > { result } if not defined $ result ;
$ context - > { preserve_whitespace } = 0 if not defined $ context - > { preserve_whitespace } ;
2020-02-15 23:38:32 +01:00
2020-05-02 05:59:51 +02:00
if ( $ self - > { pbot } - > { registry } - > get_value ( 'general' , 'debugcontext' ) and length $ context - > { result } ) {
2020-02-15 23:38:32 +01:00
use Data::Dumper ;
$ Data:: Dumper:: Sortkeys = 1 ;
$ self - > { pbot } - > { logger } - > log ( "Interpreter::handle_result [$result]\n" ) ;
2020-05-02 05:59:51 +02:00
$ self - > { pbot } - > { logger } - > log ( Dumper $ context ) ;
2019-09-05 05:18:32 +02:00
}
2020-02-15 23:38:32 +01:00
return 0 if not defined $ result or length $ result == 0 ;
2020-05-02 05:59:51 +02:00
if ( $ result =~ s #^(/say|/me) ##) { $context->{prepend} = $1; }
elsif ( $ result =~ s #^(/msg \S+) ##) { $context->{prepend} = $1; }
2017-12-05 03:34:34 +01:00
2020-05-02 05:59:51 +02:00
if ( $ context - > { pipe } ) {
my ( $ pipe , $ pipe_rest ) = ( delete $ context - > { pipe } , delete $ context - > { pipe_rest } ) ;
if ( not $ context - > { alldone } ) {
$ context - > { command } = "$pipe $result $pipe_rest" ;
$ result = $ self - > interpret ( $ context ) ;
$ context - > { result } = $ result ;
2020-02-15 23:38:32 +01:00
}
2020-05-02 05:59:51 +02:00
$ self - > handle_result ( $ context , $ result ) ;
2020-02-15 23:38:32 +01:00
return 0 ;
2017-12-05 03:34:34 +01:00
}
2020-05-02 05:59:51 +02:00
if ( exists $ context - > { subcmd } ) {
my $ command = pop @ { $ context - > { subcmd } } ;
2020-02-15 23:38:32 +01:00
2020-05-02 05:59:51 +02:00
if ( @ { $ context - > { subcmd } } == 0 or $ context - > { alldone } ) { delete $ context - > { subcmd } ; }
2020-02-15 23:38:32 +01:00
$ command =~ s/&\{subcmd\}/$result/ ;
2017-12-05 03:34:34 +01:00
2020-05-02 05:59:51 +02:00
if ( not $ context - > { alldone } ) {
$ context - > { command } = $ command ;
$ result = $ self - > interpret ( $ context ) ;
$ context - > { result } = $ result ;
2020-02-15 23:38:32 +01:00
}
2020-05-02 05:59:51 +02:00
$ self - > handle_result ( $ context ) ;
2020-02-15 23:38:32 +01:00
return 0 ;
2019-06-03 04:30:35 +02:00
}
2017-12-05 03:34:34 +01:00
2020-05-02 05:59:51 +02:00
if ( $ context - > { prepend } ) { $ result = "$context->{prepend} $result" ; }
2017-11-16 18:23:58 +01:00
2020-05-02 05:59:51 +02:00
if ( $ context - > { command_split } ) {
2020-02-15 23:38:32 +01:00
my $ botnick = $ self - > { pbot } - > { registry } - > get_value ( 'irc' , 'botnick' ) ;
2020-05-02 05:59:51 +02:00
$ context - > { command } = delete $ context - > { command_split } ;
2020-02-15 23:38:32 +01:00
$ result =~ s #^/say #\n#i;
$ result =~ s #^/me #\n* $botnick #i;
2020-05-02 05:59:51 +02:00
if ( not length $ context - > { split_result } ) {
2020-02-15 23:38:32 +01:00
$ result =~ s/^\n// ;
2020-05-02 05:59:51 +02:00
$ context - > { split_result } = $ result ;
2020-02-15 23:38:32 +01:00
} else {
2020-05-02 05:59:51 +02:00
$ context - > { split_result } . = $ result ;
2020-02-15 23:38:32 +01:00
}
2020-05-02 05:59:51 +02:00
$ result = $ self - > interpret ( $ context ) ;
$ self - > handle_result ( $ context , $ result ) ;
2020-02-15 23:38:32 +01:00
return 0 ;
2019-06-26 03:23:21 +02:00
}
2020-05-02 05:59:51 +02:00
if ( $ context - > { split_result } ) {
2020-02-15 23:38:32 +01:00
my $ botnick = $ self - > { pbot } - > { registry } - > get_value ( 'irc' , 'botnick' ) ;
$ result =~ s #^/say #\n#i;
$ result =~ s #^/me #\n* $botnick #i;
2020-05-02 05:59:51 +02:00
$ result = $ context - > { split_result } . $ result ;
2020-02-15 23:38:32 +01:00
}
2019-06-26 03:23:21 +02:00
2020-02-15 23:38:32 +01:00
my $ original_result = $ result ;
2010-03-17 07:36:54 +01:00
2020-02-15 23:38:32 +01:00
my $ use_output_queue = 0 ;
2015-03-29 01:50:43 +01:00
2020-05-02 05:59:51 +02:00
if ( defined $ context - > { command } ) {
my $ cmdlist = $ self - > make_args ( $ context - > { command } ) ;
2020-02-15 23:38:32 +01:00
my ( $ cmd , $ args ) = $ self - > split_args ( $ cmdlist , 2 , 0 , 1 ) ;
if ( not $ self - > { pbot } - > { commands } - > exists ( $ cmd ) ) {
2020-05-02 05:59:51 +02:00
my ( $ chan , $ trigger ) = $ self - > { pbot } - > { factoids } - > find_factoid ( $ context - > { from } , $ cmd , arguments = > $ args , exact_channel = > 1 , exact_trigger = > 0 , find_alias = > 1 ) ;
2020-02-15 23:38:32 +01:00
if ( defined $ trigger ) {
2020-05-02 05:59:51 +02:00
if ( $ context - > { preserve_whitespace } == 0 ) {
$ context - > { preserve_whitespace } = $ self - > { pbot } - > { factoids } - > { factoids } - > get_data ( $ chan , $ trigger , 'preserve_whitespace' ) // 0 ;
2020-02-15 23:38:32 +01:00
}
2015-04-04 00:33:19 +02:00
2020-02-15 23:38:32 +01:00
$ use_output_queue = $ self - > { pbot } - > { factoids } - > { factoids } - > get_data ( $ chan , $ trigger , 'use_output_queue' ) ;
$ use_output_queue = 0 if not defined $ use_output_queue ;
}
}
2014-03-14 11:05:11 +01:00
}
2014-08-05 00:48:32 +02:00
2020-05-02 05:59:51 +02:00
my $ preserve_newlines = $ self - > { pbot } - > { registry } - > get_value ( $ context - > { from } , 'preserve_newlines' ) ;
2020-02-15 23:38:32 +01:00
$ result =~ s/[\n\r]/ /g unless $ preserve_newlines ;
2020-05-02 05:59:51 +02:00
$ result =~ s/[ \t]+/ /g unless $ context - > { preserve_whitespace } ;
2020-02-15 23:38:32 +01:00
2020-05-02 05:59:51 +02:00
my $ max_lines = $ self - > { pbot } - > { registry } - > get_value ( $ context - > { from } , 'max_newlines' ) ;
2020-02-15 23:38:32 +01:00
$ max_lines = 4 if not defined $ max_lines ;
my $ lines = 0 ;
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 ;
if ( + + $ lines >= $ max_lines ) {
2020-05-02 05:59:51 +02:00
my $ link = $ self - > { pbot } - > { webpaste } - > paste ( "[" . ( defined $ context - > { from } ? $ context - > { from } : "stdin" ) . "] <$context->{nick}> $context->{text}\n\n$original_result" ) ;
2020-02-15 23:38:32 +01:00
if ( $ use_output_queue ) {
my $ message = {
2020-05-02 05:59:51 +02:00
nick = > $ context - > { nick } , user = > $ context - > { user } , host = > $ context - > { host } , command = > $ context - > { command } ,
2020-02-15 23:38:32 +01:00
message = > "And that's all I have to say about that. See $link for full text." ,
checkflood = > 1
} ;
2020-05-02 05:59:51 +02:00
$ self - > add_message_to_output_queue ( $ context - > { from } , $ message , 0 ) ;
2020-02-15 23:38:32 +01:00
} else {
2020-05-02 05:59:51 +02:00
$ self - > { pbot } - > { conn } - > privmsg ( $ context - > { from } , "And that's all I have to say about that. See $link for full text." ) unless $ context - > { from } eq 'stdin@pbot' ;
2020-02-15 23:38:32 +01:00
}
last ;
}
2014-08-05 00:48:32 +02:00
2020-05-02 05:59:51 +02:00
if ( $ preserve_newlines ) { $ line = $ self - > truncate_result ( $ context - > { from } , $ context - > { nick } , $ context - > { text } , $ line , $ line , 1 ) ; }
else { $ line = $ self - > truncate_result ( $ context - > { from } , $ context - > { nick } , $ context - > { text } , $ original_result , $ line , 1 ) ; }
2020-02-15 23:38:32 +01:00
if ( $ use_output_queue ) {
my $ delay = rand ( 10 ) + 5 ;
my $ message = {
2020-05-02 05:59:51 +02:00
nick = > $ context - > { nick } , user = > $ context - > { user } , host = > $ context - > { host } , command = > $ context - > { command } ,
2020-02-15 23:38:32 +01:00
message = > $ line , checkflood = > 1
} ;
2020-05-02 05:59:51 +02:00
$ self - > add_message_to_output_queue ( $ context - > { from } , $ message , $ delay ) ;
2020-02-15 23:38:32 +01:00
$ delay = duration ( $ delay ) ;
$ self - > { pbot } - > { logger } - > log ( "($delay delay) $line\n" ) ;
} else {
2020-05-02 05:59:51 +02:00
$ context - > { line } = $ line ;
$ self - > output_result ( $ context ) ;
2020-02-15 23:38:32 +01:00
$ self - > { pbot } - > { logger } - > log ( "$line\n" ) ;
}
2010-03-22 08:33:44 +01:00
}
2020-02-15 23:38:32 +01:00
$ self - > { pbot } - > { logger } - > log ( "---------------------------------------------\n" ) ;
return 1 ;
2015-03-29 01:50:43 +01:00
}
2020-02-06 12:14:14 +01:00
sub dehighlight_nicks {
2020-02-15 23:38:32 +01:00
my ( $ self , $ line , $ channel ) = @ _ ;
return $ line if $ self - > { pbot } - > { registry } - > get_value ( 'general' , 'no_dehighlight_nicks' ) ;
2020-03-24 23:17:33 +01:00
my @ tokens = split / / , $ line ;
foreach my $ token ( @ tokens ) {
my $ potential_nick = $ token ;
2020-03-25 08:51:53 +01:00
$ potential_nick =~ s/^[^\w\[\]\-\\\^\{\}]+// ;
$ potential_nick =~ s/[^\w\[\]\-\\\^\{\}]+$// ;
2020-03-24 23:17:33 +01:00
next if length $ potential_nick == 1 ;
2020-03-24 23:53:21 +01:00
next if not $ self - > { pbot } - > { nicklist } - > is_present ( $ channel , $ potential_nick ) ;
2020-03-24 23:17:33 +01:00
my $ dehighlighted_nick = $ potential_nick ;
$ dehighlighted_nick =~ s/(.)/$1\x{200b}/ ;
$ token =~ s/\Q$potential_nick\E(?!:)/$dehighlighted_nick/ ;
2020-02-06 12:49:33 +01:00
}
2020-03-24 23:17:33 +01:00
return join ' ' , @ tokens ;
2020-02-06 12:14:14 +01:00
}
2015-03-29 01:50:43 +01:00
sub output_result {
2020-05-02 05:59:51 +02:00
my ( $ self , $ context ) = @ _ ;
2020-02-15 23:38:32 +01:00
my ( $ pbot , $ botnick ) = ( $ self - > { pbot } , $ self - > { pbot } - > { registry } - > get_value ( 'irc' , 'botnick' ) ) ;
if ( $ self - > { pbot } - > { registry } - > get_value ( 'general' , 'debugcontext' ) ) {
use Data::Dumper ;
$ Data:: Dumper:: Sortkeys = 1 ;
$ self - > { pbot } - > { logger } - > log ( "Interpreter::output_result\n" ) ;
2020-05-02 05:59:51 +02:00
$ self - > { pbot } - > { logger } - > log ( Dumper $ context ) ;
2020-02-15 23:38:32 +01:00
}
2015-03-29 01:50:43 +01:00
2020-05-02 05:59:51 +02:00
my $ line = $ context - > { line } ;
2017-11-16 18:23:58 +01:00
2020-02-15 23:38:32 +01:00
return if not defined $ line or not length $ line ;
2020-05-02 05:59:51 +02:00
return 0 if $ context - > { from } eq 'stdin@pbot' ;
2017-11-16 18:23:58 +01:00
2020-05-02 05:59:51 +02:00
$ line = $ self - > dehighlight_nicks ( $ line , $ context - > { from } ) if $ context - > { from } =~ /^#/ and $ line !~ /^\/msg\s+/i ;
2017-11-16 18:23:58 +01:00
2020-02-15 23:38:32 +01:00
if ( $ line =~ s/^\/say\s+//i ) {
2020-05-02 05:59:51 +02:00
if ( defined $ context - > { nickoverride } and ( $ context - > { no_nickoverride } == 0 or $ context - > { force_nickoverride } == 1 ) ) { $ line = "$context->{nickoverride}: $line" ; }
$ pbot - > { conn } - > privmsg ( $ context - > { from } , $ line ) if defined $ context - > { from } && $ context - > { from } ne $ botnick ;
$ pbot - > { antiflood } - > check_flood ( $ context - > { from } , $ botnick , $ pbot - > { registry } - > get_value ( 'irc' , 'username' ) , 'pbot' , $ line , 0 , 0 , 0 ) if $ context - > { checkflood } ;
2020-02-15 23:38:32 +01:00
} elsif ( $ line =~ s/^\/me\s+//i ) {
2020-05-02 05:59:51 +02:00
$ pbot - > { conn } - > me ( $ context - > { from } , $ line ) if defined $ context - > { from } && $ context - > { from } ne $ botnick ;
$ pbot - > { antiflood } - > check_flood ( $ context - > { from } , $ botnick , $ pbot - > { registry } - > get_value ( 'irc' , 'username' ) , 'pbot' , '/me ' . $ line , 0 , 0 , 0 ) if $ context - > { checkflood } ;
2020-02-15 23:38:32 +01:00
} elsif ( $ line =~ s/^\/msg\s+([^\s]+)\s+//i ) {
my $ to = $ 1 ;
if ( $ to =~ /,/ ) {
2020-05-02 05:59:51 +02:00
$ pbot - > { logger } - > log ( "[HACK] Possible HACK ATTEMPT /msg multiple users: [$context->{nick}!$context->{user}\@$context->{host}] [$context->{command}] [$line]\n" ) ;
2020-02-15 23:38:32 +01:00
} elsif ( $ to =~ /.*serv(?:@.*)?$/i ) {
2020-05-02 05:59:51 +02:00
$ pbot - > { logger } - > log ( "[HACK] Possible HACK ATTEMPT /msg *serv: [$context->{nick}!$context->{user}\@$context->{host}] [$context->{command}] [$line]\n" ) ;
2020-02-15 23:38:32 +01:00
} elsif ( $ line =~ s/^\/me\s+//i ) {
$ pbot - > { conn } - > me ( $ to , $ line ) if $ to ne $ botnick ;
2020-05-02 05:59:51 +02:00
$ pbot - > { antiflood } - > check_flood ( $ to , $ botnick , $ pbot - > { registry } - > get_value ( 'irc' , 'username' ) , 'pbot' , '/me ' . $ line , 0 , 0 , 0 ) if $ context - > { checkflood } ;
2020-02-15 23:38:32 +01:00
} else {
$ line =~ s/^\/say\s+//i ;
2020-05-02 05:59:51 +02:00
if ( defined $ context - > { nickoverride } and ( $ context - > { no_nickoverride } == 0 or $ context - > { force_nickoverride } == 1 ) ) { $ line = "$context->{nickoverride}: $line" ; }
2020-02-15 23:38:32 +01:00
$ pbot - > { conn } - > privmsg ( $ to , $ line ) if $ to ne $ botnick ;
2020-05-02 05:59:51 +02:00
$ pbot - > { antiflood } - > check_flood ( $ to , $ botnick , $ pbot - > { registry } - > get_value ( 'irc' , 'username' ) , 'pbot' , $ line , 0 , 0 , 0 ) if $ context - > { checkflood } ;
2020-02-15 23:38:32 +01:00
}
2015-03-29 01:50:43 +01:00
} else {
2020-05-02 05:59:51 +02:00
if ( defined $ context - > { nickoverride } and ( $ context - > { no_nickoverride } == 0 or $ context - > { force_nickoverride } == 1 ) ) { $ line = "$context->{nickoverride}: $line" ; }
$ pbot - > { conn } - > privmsg ( $ context - > { from } , $ line ) if defined $ context - > { from } && $ context - > { from } ne $ botnick ;
$ pbot - > { antiflood } - > check_flood ( $ context - > { from } , $ botnick , $ pbot - > { registry } - > get_value ( 'irc' , 'username' ) , 'pbot' , $ line , 0 , 0 , 0 ) if $ context - > { checkflood } ;
2017-11-26 05:00:55 +01:00
}
2010-03-17 07:36:54 +01:00
}
2015-03-29 01:50:43 +01:00
sub add_message_to_output_queue {
2020-02-15 23:38:32 +01:00
my ( $ self , $ channel , $ message , $ delay ) = @ _ ;
2015-03-30 05:24:36 +02:00
2020-03-06 22:30:09 +01:00
$ self - > { pbot } - > { timer } - > enqueue_event (
sub {
2020-05-02 05:59:51 +02:00
my $ context = {
2020-03-06 22:30:09 +01:00
from = > $ channel ,
nick = > $ message - > { nick } ,
user = > $ message - > { user } ,
host = > $ message - > { host } ,
line = > $ message - > { message } ,
command = > $ message - > { command } ,
checkflood = > $ message - > { checkflood }
} ;
2015-03-30 05:24:36 +02:00
2020-05-02 05:59:51 +02:00
$ self - > output_result ( $ context ) ;
2020-03-06 22:30:09 +01:00
} ,
$ delay , "output $channel $message->{message}"
) ;
2015-03-29 01:50:43 +01:00
}
2016-07-01 22:00:20 +02:00
sub add_to_command_queue {
2020-03-09 23:24:47 +01:00
my ( $ self , $ channel , $ command , $ delay , $ repeating ) = @ _ ;
2016-07-01 22:00:20 +02:00
2020-03-06 22:30:09 +01:00
$ self - > { pbot } - > { timer } - > enqueue_event (
sub {
2020-05-02 05:59:51 +02:00
my $ context = {
2020-03-06 22:30:09 +01:00
from = > $ channel ,
nick = > $ command - > { nick } ,
user = > $ command - > { user } ,
host = > $ command - > { host } ,
command = > $ command - > { command } ,
interpret_depth = > 0 ,
checkflood = > 0 ,
preserve_whitespace = > 0
} ;
if ( exists $ command - > { 'cap-override' } ) {
$ self - > { pbot } - > { logger } - > log ( "[command queue] Override command capability with $command->{'cap-override'}\n" ) ;
2020-05-02 05:59:51 +02:00
$ context - > { 'cap-override' } = $ command - > { 'cap-override' } ;
2020-03-06 22:30:09 +01:00
}
2016-07-01 22:00:20 +02:00
2020-05-02 05:59:51 +02:00
my $ result = $ self - > interpret ( $ context ) ;
$ context - > { result } = $ result ;
$ self - > handle_result ( $ context , $ result ) ;
2020-03-06 22:30:09 +01:00
} ,
2020-03-09 23:24:47 +01:00
$ delay , "command $channel $command->{command}" , $ repeating
2020-03-06 22:30:09 +01:00
) ;
2016-07-01 22:00:20 +02:00
}
sub add_botcmd_to_command_queue {
2020-02-15 23:38:32 +01:00
my ( $ self , $ channel , $ command , $ delay ) = @ _ ;
2016-07-01 22:00:20 +02:00
2020-02-15 23:38:32 +01:00
my $ botcmd = {
nick = > $ self - > { pbot } - > { registry } - > get_value ( 'irc' , 'botnick' ) ,
user = > 'stdin' ,
host = > 'pbot' ,
command = > $ command
} ;
2016-07-01 22:00:20 +02:00
2020-02-15 23:38:32 +01:00
$ self - > add_to_command_queue ( $ channel , $ botcmd , $ delay ) ;
2016-07-01 22:00:20 +02:00
}
2010-03-17 07:36:54 +01:00
1 ;