3
0
mirror of https://github.com/pragma-/pbot.git synced 2024-12-23 19:22:40 +01:00

Progress on refactoring and polishing everything

More to come!
This commit is contained in:
Pragmatic Software 2021-06-06 19:12:14 -07:00
parent 6443c96f09
commit 613890707a
48 changed files with 391 additions and 112 deletions

View File

@ -16,6 +16,7 @@ use parent 'PBot::Class';
use warnings; use strict; use warnings; use strict;
use feature 'unicode_strings'; use feature 'unicode_strings';
use utf8;
use feature 'switch'; use feature 'switch';
no if $] >= 5.018, warnings => "experimental::smartmatch"; no if $] >= 5.018, warnings => "experimental::smartmatch";

View File

@ -12,6 +12,7 @@ use parent 'PBot::Class';
use warnings; use strict; use warnings; use strict;
use feature 'unicode_strings'; use feature 'unicode_strings';
use utf8;
use feature 'switch'; use feature 'switch';
no if $] >= 5.018, warnings => "experimental::smartmatch"; no if $] >= 5.018, warnings => "experimental::smartmatch";

View File

@ -15,6 +15,7 @@ use parent 'PBot::Class';
use warnings; use strict; use warnings; use strict;
use feature 'unicode_strings'; use feature 'unicode_strings';
use utf8;
use Time::HiRes qw/gettimeofday/; use Time::HiRes qw/gettimeofday/;
use Time::Duration; use Time::Duration;

View File

@ -12,6 +12,7 @@ use parent 'PBot::Class';
use warnings; use strict; use warnings; use strict;
use feature 'unicode_strings'; use feature 'unicode_strings';
use utf8;
use feature 'switch'; use feature 'switch';
no if $] >= 5.018, warnings => "experimental::smartmatch"; no if $] >= 5.018, warnings => "experimental::smartmatch";

View File

@ -11,6 +11,7 @@ use parent 'PBot::Class';
use warnings; use strict; use warnings; use strict;
use feature 'unicode_strings'; use feature 'unicode_strings';
use utf8;
use feature 'switch'; use feature 'switch';
no if $] >= 5.018, warnings => "experimental::smartmatch"; no if $] >= 5.018, warnings => "experimental::smartmatch";

View File

@ -13,6 +13,7 @@ use parent 'PBot::Class';
use warnings; use strict; use warnings; use strict;
use feature 'unicode_strings'; use feature 'unicode_strings';
use utf8;
use Time::Duration; use Time::Duration;
use Time::HiRes qw/gettimeofday/; use Time::HiRes qw/gettimeofday/;

View File

@ -13,6 +13,7 @@ use parent 'PBot::Class';
use warnings; use strict; use warnings; use strict;
use feature 'unicode_strings'; use feature 'unicode_strings';
use utf8;
use PBot::ChanOpCommands; use PBot::ChanOpCommands;
use Time::HiRes qw(gettimeofday); use Time::HiRes qw(gettimeofday);

View File

@ -12,6 +12,7 @@ use parent 'PBot::Class';
use warnings; use strict; use warnings; use strict;
use feature 'unicode_strings'; use feature 'unicode_strings';
use utf8;
sub initialize { sub initialize {
my ($self, %conf) = @_; my ($self, %conf) = @_;

View File

@ -14,6 +14,7 @@ use parent 'PBot::Class', 'PBot::Registerable';
use warnings; use strict; use warnings; use strict;
use feature 'unicode_strings'; use feature 'unicode_strings';
use utf8;
use Time::Duration qw/duration/; use Time::Duration qw/duration/;

View File

@ -18,6 +18,7 @@ package PBot::DualIndexHashObject;
use warnings; use strict; use warnings; use strict;
use feature 'unicode_strings'; use feature 'unicode_strings';
use utf8;
use Text::Levenshtein qw(fastdistance); use Text::Levenshtein qw(fastdistance);
use JSON; use JSON;

View File

@ -13,6 +13,7 @@ package PBot::DualIndexSQLiteObject;
use warnings; use strict; use warnings; use strict;
use feature 'unicode_strings'; use feature 'unicode_strings';
use utf8;
use DBI; use DBI;
use Text::Levenshtein qw(fastdistance); use Text::Levenshtein qw(fastdistance);

View File

@ -7,6 +7,7 @@ use parent 'PBot::Class';
use warnings; use strict; use warnings; use strict;
use feature 'unicode_strings'; use feature 'unicode_strings';
use utf8;
use IO::Select; use IO::Select;

View File

@ -13,6 +13,7 @@ use parent 'PBot::Class';
use warnings; use strict; use warnings; use strict;
use feature 'unicode_strings'; use feature 'unicode_strings';
use utf8;
use Time::Duration; use Time::Duration;
use Time::HiRes qw(gettimeofday); use Time::HiRes qw(gettimeofday);

View File

@ -12,6 +12,7 @@ use parent 'PBot::Class';
use warnings; use strict; use warnings; use strict;
use feature 'unicode_strings'; use feature 'unicode_strings';
use utf8;
use feature 'switch'; use feature 'switch';
no if $] >= 5.018, warnings => "experimental::smartmatch"; no if $] >= 5.018, warnings => "experimental::smartmatch";

View File

@ -24,6 +24,7 @@ use parent 'PBot::Class';
use warnings; use strict; use warnings; use strict;
use feature 'unicode_strings'; use feature 'unicode_strings';
use utf8;
sub initialize { sub initialize {
my ($self, %conf) = @_; my ($self, %conf) = @_;

View File

@ -14,6 +14,7 @@ package PBot::HashObject;
use warnings; use strict; use warnings; use strict;
use feature 'unicode_strings'; use feature 'unicode_strings';
use utf8;
use Text::Levenshtein qw(fastdistance); use Text::Levenshtein qw(fastdistance);
use JSON; use JSON;

View File

@ -23,6 +23,7 @@ use IO::Select;
use Carp; use Carp;
use feature 'unicode_strings'; use feature 'unicode_strings';
use utf8;
# grab the drop-in replacement for time() from Time::HiRes, if it's available # grab the drop-in replacement for time() from Time::HiRes, if it's available
BEGIN { Time::HiRes->import('time') if eval "require Time::HiRes"; } BEGIN { Time::HiRes->import('time') if eval "require Time::HiRes"; }

View File

@ -16,6 +16,7 @@
package PBot::IRC::Connection; # pragma_ 2011/21/01 package PBot::IRC::Connection; # pragma_ 2011/21/01
use feature 'unicode_strings'; use feature 'unicode_strings';
use utf8;
use PBot::IRC::Event; # pragma_ 2011/21/01 use PBot::IRC::Event; # pragma_ 2011/21/01
use PBot::IRC::DCC; # pragma_ 2011/21/01 use PBot::IRC::DCC; # pragma_ 2011/21/01

View File

@ -18,6 +18,7 @@ package PBot::IRC::DCC; # pragma_ 2011/21/01
use strict; use strict;
use feature 'unicode_strings'; use feature 'unicode_strings';
use utf8;
# --- #perl was here! --- # --- #perl was here! ---
# #

View File

@ -25,6 +25,7 @@
package PBot::IRC::Event; # pragma_ 2011/21/01 package PBot::IRC::Event; # pragma_ 2011/21/01
use feature 'unicode_strings'; use feature 'unicode_strings';
use utf8;
use strict; use strict;
our %_names; our %_names;

View File

@ -1,6 +1,7 @@
package PBot::IRC::EventQueue; # pragma_ 2011/21/01 package PBot::IRC::EventQueue; # pragma_ 2011/21/01
use feature 'unicode_strings'; use feature 'unicode_strings';
use utf8;
use PBot::IRC::EventQueue::Entry; # pragma_ 2011/21/01 use PBot::IRC::EventQueue::Entry; # pragma_ 2011/21/01

View File

@ -3,6 +3,7 @@ package PBot::IRC::EventQueue::Entry; # pragma_ 2011/21/01
use strict; use strict;
use feature 'unicode_strings'; use feature 'unicode_strings';
use utf8;
my $id = 0; my $id = 0;

View File

@ -13,6 +13,7 @@ use parent 'PBot::Class';
use warnings; use strict; use warnings; use strict;
use feature 'unicode_strings'; use feature 'unicode_strings';
use utf8;
use Time::HiRes qw(gettimeofday); use Time::HiRes qw(gettimeofday);
use Data::Dumper; use Data::Dumper;

View File

@ -12,6 +12,7 @@ use parent 'PBot::Class';
use warnings; use strict; use warnings; use strict;
use feature 'unicode_strings'; use feature 'unicode_strings';
use utf8;
use Time::Duration qw/concise duration/; use Time::Duration qw/concise duration/;

View File

@ -13,6 +13,7 @@ use parent 'PBot::Class', 'PBot::Registerable';
use warnings; use strict; use warnings; use strict;
use feature 'unicode_strings'; use feature 'unicode_strings';
use utf8;
use Time::HiRes qw/gettimeofday/; use Time::HiRes qw/gettimeofday/;
use Time::Duration; use Time::Duration;
@ -30,8 +31,8 @@ sub initialize {
} }
sub process_line { sub process_line {
my $self = shift; my ($self, $from, $nick, $user, $host, $text) = @_;
my ($from, $nick, $user, $host, $text) = @_;
$from = lc $from if defined $from; $from = lc $from if defined $from;
my $context = {from => $from, nick => $nick, user => $user, host => $host, hostmask => "$nick!$user\@$host", text => $text}; my $context = {from => $from, nick => $nick, user => $user, host => $host, hostmask => "$nick!$user\@$host", text => $text};
@ -737,37 +738,58 @@ sub lc_args {
} }
sub truncate_result { sub truncate_result {
my ($self, $from, $nick, $text, $original_result, $result, $paste) = @_; my ($self, $from, $nick, $command, $paste_text, $text, $paste) = @_;
my $max_msg_len = $self->{pbot}->{registry}->get_value('irc', 'max_msg_len'); my $max_msg_len = $self->{pbot}->{registry}->get_value('irc', 'max_msg_len');
$max_msg_len -= length "PRIVMSG $from :" if defined $from; $max_msg_len -= length "PRIVMSG $from :" if defined $from;
utf8::encode $result; utf8::encode $paste_text;
utf8::encode $original_result; utf8::encode $text;
use bytes; if (length $text > $max_msg_len) {
my $paste_result;
if (length $result > $max_msg_len) {
my $link;
if ($paste) { if ($paste) {
# limit pastes to 32k by default, overridable via paste.max_length
my $max_paste_len = $self->{pbot}->{registry}->get_value('paste', 'max_length') // 1024 * 32; my $max_paste_len = $self->{pbot}->{registry}->get_value('paste', 'max_length') // 1024 * 32;
$original_result = substr $original_result, 0, $max_paste_len;
$link = $self->{pbot}->{webpaste}->paste("[" . (defined $from ? $from : "stdin") . "] <$nick> $text\n\n$original_result"); # truncate paste to max paste length
# FIXME: this potentially chops unicode characters in wrong places
$paste_text = substr $paste_text, 0, $max_paste_len;
utf8::decode $paste_text;
# send text to paste site
$paste_result = $self->{pbot}->{webpaste}->paste("($from) $nick: $command\n\n$paste_text");
}
my $trunc = "... [truncated";
if (not defined $paste_result) {
# no paste
$trunc .= "]";
} elsif ($paste_result =~ m/^http/) {
# a link
$trunc .= "; see $paste_result for full text.]";
} else { } else {
$link = 'undef'; # an error or something else
$trunc .= "$paste_result]";
} }
my $trunc = "... [truncated; "; if ($paste) {
if ($link =~ m/^http/) { $trunc .= "see $link for full text.]"; } $paste_result //= 'not pasted';
else { $trunc .= "$link]"; } $self->{pbot}->{logger}->log("Message truncated -- $paste_result\n");
$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;
} }
utf8::decode $result; my $trunc_len = length $text < $max_msg_len ? length $text : $max_msg_len;
return $result; # FIXME: this potentially chops unicode characters in wrong places
$text = substr($text, 0, $trunc_len);
substr($text, $trunc_len - length $trunc) = $trunc;
}
utf8::decode $text;
return $text;
} }
sub handle_result { sub handle_result {
@ -839,8 +861,6 @@ sub handle_result {
$result = $context->{split_result} . $result; $result = $context->{split_result} . $result;
} }
my $original_result = $result;
my $use_output_queue = 0; my $use_output_queue = 0;
if (defined $context->{command}) { if (defined $context->{command}) {
@ -854,26 +874,25 @@ sub handle_result {
$context->{preserve_whitespace} = $self->{pbot}->{factoids}->{factoids}->get_data($chan, $trigger, 'preserve_whitespace') // 0; $context->{preserve_whitespace} = $self->{pbot}->{factoids}->{factoids}->get_data($chan, $trigger, 'preserve_whitespace') // 0;
} }
$use_output_queue = $self->{pbot}->{factoids}->{factoids}->get_data($chan, $trigger, 'use_output_queue'); $use_output_queue = $self->{pbot}->{factoids}->{factoids}->get_data($chan, $trigger, 'use_output_queue') // 0;
$use_output_queue = 0 if not defined $use_output_queue;
} }
} }
} }
my $preserve_newlines = $self->{pbot}->{registry}->get_value($context->{from}, 'preserve_newlines'); my $preserve_newlines = $self->{pbot}->{registry}->get_value($context->{from}, 'preserve_newlines');
my $original_result = $result;
$result =~ s/[\n\r]/ /g unless $preserve_newlines; $result =~ s/[\n\r]/ /g unless $preserve_newlines;
$result =~ s/[ \t]+/ /g unless $context->{preserve_whitespace}; $result =~ s/[ \t]+/ /g unless $context->{preserve_whitespace};
my $max_lines = $self->{pbot}->{registry}->get_value($context->{from}, 'max_newlines'); my $max_lines = $self->{pbot}->{registry}->get_value($context->{from}, 'max_newlines') // 4;
$max_lines = 4 if not defined $max_lines;
my $lines = 0; my $lines = 0;
my $stripped_line; my $stripped_line;
foreach my $line (split /[\n\r]+/, $result) { foreach my $line (split /[\n\r]+/, $result) {
$stripped_line = $line; $stripped_line = $line;
$stripped_line =~ s/^\s+//; $stripped_line =~ s/^\s+|\s+$//g;
$stripped_line =~ s/\s+$//;
next if not length $stripped_line; next if not length $stripped_line;
if (++$lines >= $max_lines) { if (++$lines >= $max_lines) {
@ -891,8 +910,11 @@ sub handle_result {
last; last;
} }
if ($preserve_newlines) { $line = $self->truncate_result($context->{from}, $context->{nick}, $context->{text}, $line, $line, 1); } if ($preserve_newlines) {
else { $line = $self->truncate_result($context->{from}, $context->{nick}, $context->{text}, $original_result, $line, 1); } $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);
}
if ($use_output_queue) { if ($use_output_queue) {
my $delay = rand(10) + 5; my $delay = rand(10) + 5;

View File

@ -14,6 +14,7 @@ use parent 'PBot::Class';
use warnings; use strict; use warnings; use strict;
use feature 'unicode_strings'; use feature 'unicode_strings';
use utf8;
use Time::HiRes qw(gettimeofday tv_interval); use Time::HiRes qw(gettimeofday tv_interval);
use Time::Duration; use Time::Duration;

View File

@ -6,6 +6,7 @@ package PBot::Logger;
use warnings; use strict; use warnings; use strict;
use feature 'unicode_strings'; use feature 'unicode_strings';
use utf8;
use Scalar::Util qw/openhandle/; use Scalar::Util qw/openhandle/;
use File::Basename; use File::Basename;
@ -24,36 +25,61 @@ sub new {
sub initialize { sub initialize {
my ($self, %conf) = @_; my ($self, %conf) = @_;
# ensure logfile path was provided
$self->{logfile} = $conf{filename} // Carp::croak "Missing logfile parameter in " . __FILE__; $self->{logfile} = $conf{filename} // Carp::croak "Missing logfile parameter in " . __FILE__;
# record start time for later logfile rename in rotation
$self->{start} = time; $self->{start} = time;
# get directories leading to logfile
my $path = dirname $self->{logfile}; my $path = dirname $self->{logfile};
# create log file path
if (not -d $path) { if (not -d $path) {
print "Creating new logfile path: $path\n" unless $self->{pbot}->{overrides}->{'general.daemon'}; print "Creating new logfile path: $path\n" unless $self->{pbot}->{overrides}->{'general.daemon'};
mkdir $path or Carp::croak "Couldn't create logfile path: $!\n"; mkdir $path or Carp::croak "Couldn't create logfile path: $!\n";
} }
open LOGFILE, ">>$self->{logfile}" or Carp::croak "Couldn't open logfile $self->{logfile}: $!\n"; # open log file with utf8 encoding
open LOGFILE, ">> :encoding(UTF-8)", $self->{logfile} or Carp::croak "Couldn't open logfile $self->{logfile}: $!\n";
LOGFILE->autoflush(1); LOGFILE->autoflush(1);
# rename logfile to start-time at exit
$self->{pbot}->{atexit}->register(sub { $self->rotate_log; return; }); $self->{pbot}->{atexit}->register(sub { $self->rotate_log; return; });
return $self;
} }
sub log { sub log {
my ($self, $text) = @_; my ($self, $text) = @_;
# get current time
my $time = localtime; my $time = localtime;
# replace potentially log-corrupting characters (colors, gibberish, etc)
$text =~ s/(\P{PosixGraph})/my $ch = $1; if ($ch =~ m{[\s]}) { $ch } else { sprintf "\\x%02X", ord $ch }/ge; $text =~ s/(\P{PosixGraph})/my $ch = $1; if ($ch =~ m{[\s]}) { $ch } else { sprintf "\\x%02X", ord $ch }/ge;
# log to file
print LOGFILE "$time :: $text" if openhandle * LOGFILE; print LOGFILE "$time :: $text" if openhandle * LOGFILE;
print "$time :: $text" unless $self->{pbot}->{overrides}->{'general.daemon'};
# and print to stdout unless daemonized
print STDOUT "$time :: $text" unless $self->{pbot}->{overrides}->{'general.daemon'};
} }
sub rotate_log { sub rotate_log {
my ($self) = @_; my ($self) = @_;
# get start time
my $time = localtime $self->{start}; my $time = localtime $self->{start};
$time =~ s/\s+/_/g; $time =~ s/\s+/_/g; # replace spaces with underscores
$self->log("Rotating log to $self->{logfile}-$time\n"); $self->log("Rotating log to $self->{logfile}-$time\n");
# rename log to start time
move($self->{logfile}, $self->{logfile} . '-' . $time); move($self->{logfile}, $self->{logfile} . '-' . $time);
# set new start time for next rotation
$self->{start} = time;
} }
1; 1;

View File

@ -17,6 +17,7 @@ use parent 'PBot::Class';
use warnings; use strict; use warnings; use strict;
use feature 'unicode_strings'; use feature 'unicode_strings';
use utf8;
use Getopt::Long qw(GetOptionsFromArray); use Getopt::Long qw(GetOptionsFromArray);
use Time::HiRes qw(gettimeofday tv_interval); use Time::HiRes qw(gettimeofday tv_interval);

View File

@ -13,6 +13,7 @@ use parent 'PBot::Class';
use warnings; use strict; use warnings; use strict;
use feature 'unicode_strings'; use feature 'unicode_strings';
use utf8;
use DBI; use DBI;
use Carp qw(shortmess); use Carp qw(shortmess);

View File

@ -13,6 +13,7 @@ use parent 'PBot::Class';
use warnings; use strict; use warnings; use strict;
use feature 'unicode_strings'; use feature 'unicode_strings';
use utf8;
use Time::Duration qw/duration/; use Time::Duration qw/duration/;

View File

@ -1,6 +1,12 @@
# File: Modules.pm # File: Modules.pm
# Author: pragma_ # Author: pragma_
# Purpose: Modules are command-line programs and scripts that can be loaded
# via PBot factoids. Command arguments are passed as command-line arguments.
# The standard output from the script is returned as the bot command result.
# The standard error output is stored in a file named <module>-stderr in the
# modules/ directory.
# This Source Code Form is subject to the terms of the Mozilla Public # 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 # 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/. # file, You can obtain one at http://mozilla.org/MPL/2.0/.
@ -11,43 +17,65 @@ use parent 'PBot::Class';
use warnings; use strict; use warnings; use strict;
use feature 'unicode_strings'; use feature 'unicode_strings';
use utf8;
use IPC::Run qw/run timeout/; use IPC::Run qw/run timeout/;
use Encode; use Encode;
sub initialize { sub initialize {
my ($self, %conf) = @_; my ($self, %conf) = @_;
# bot commands to load and unload modules
$self->{pbot}->{commands}->register(sub { $self->cmd_load(@_) }, "load", 1); $self->{pbot}->{commands}->register(sub { $self->cmd_load(@_) }, "load", 1);
$self->{pbot}->{commands}->register(sub { $self->cmd_unload(@_) }, "unload", 1); $self->{pbot}->{commands}->register(sub { $self->cmd_unload(@_) }, "unload", 1);
} }
sub cmd_load { sub cmd_load {
my ($self, $context) = @_; my ($self, $context) = @_;
my $factoids = $self->{pbot}->{factoids}->{factoids};
my ($keyword, $module) = $self->{pbot}->{interpreter}->split_args($context->{arglist}, 2); my ($keyword, $module) = $self->{pbot}->{interpreter}->split_args($context->{arglist}, 2);
return "Usage: load <keyword> <module>" if not defined $module; return "Usage: load <keyword> <module>" if not defined $module;
if ($factoids->exists('.*', $keyword)) { return 'There is already a keyword named ' . $factoids->get_data('.*', $keyword, '_name') . '.'; } my $factoids = $self->{pbot}->{factoids}->{factoids};
if ($factoids->exists('.*', $keyword)) {
return 'There is already a keyword named ' . $factoids->get_data('.*', $keyword, '_name') . '.';
}
$self->{pbot}->{factoids}->add_factoid('module', '.*', $context->{hostmask}, $keyword, $module, 1); $self->{pbot}->{factoids}->add_factoid('module', '.*', $context->{hostmask}, $keyword, $module, 1);
$factoids->set('.*', $keyword, 'add_nick', 1, 1); $factoids->set('.*', $keyword, 'add_nick', 1, 1);
$factoids->set('.*', $keyword, 'nooverride', 1); $factoids->set('.*', $keyword, 'nooverride', 1);
$self->{pbot}->{logger}->log("$context->{hostmask} loaded module $keyword => $module\n"); $self->{pbot}->{logger}->log("$context->{hostmask} loaded module $keyword => $module\n");
return "Loaded module $keyword => $module"; return "Loaded module $keyword => $module";
} }
sub cmd_unload { sub cmd_unload {
my ($self, $context) = @_; my ($self, $context) = @_;
my $module = $self->{pbot}->{interpreter}->shift_arg($context->{arglist});
return "Usage: unload <keyword>" if not defined $module;
my $factoids = $self->{pbot}->{factoids}->{factoids};
return "/say $module not found." if not $factoids->exists('.*', $module);
if ($factoids->get_data('.*', $module, 'type') ne 'module') { return "/say " . $factoids->get_data('.*', $module, '_name') . ' is not a module.'; } my $module = $self->{pbot}->{interpreter}->shift_arg($context->{arglist});
return "Usage: unload <keyword>" if not defined $module;
my $factoids = $self->{pbot}->{factoids}->{factoids};
if (not $factoids->exists('.*', $module)) {
return "/say $module not found.";
}
if ($factoids->get_data('.*', $module, 'type') ne 'module') {
return "/say " . $factoids->get_data('.*', $module, '_name') . ' is not a module.';
}
my $name = $factoids->get_data('.*', $module, '_name'); my $name = $factoids->get_data('.*', $module, '_name');
$factoids->remove('.*', $module); $factoids->remove('.*', $module);
$self->{pbot}->{logger}->log("$context->{hostmask} unloaded module $module\n"); $self->{pbot}->{logger}->log("$context->{hostmask} unloaded module $module\n");
return "/say $name unloaded."; return "/say $name unloaded.";
} }
@ -67,8 +95,11 @@ sub execute_module {
sub launch_module { sub launch_module {
my ($self, $context) = @_; my ($self, $context) = @_;
$context->{arguments} = "" if not defined $context->{arguments};
$context->{arguments} //= '';
my @factoids = $self->{pbot}->{factoids}->find_factoid($context->{from}, $context->{keyword}, exact_channel => 2, exact_trigger => 2); my @factoids = $self->{pbot}->{factoids}->find_factoid($context->{from}, $context->{keyword}, exact_channel => 2, exact_trigger => 2);
if (not @factoids or not $factoids[0]) { if (not @factoids or not $factoids[0]) {
$context->{checkflood} = 1; $context->{checkflood} = 1;
$self->{pbot}->{interpreter}->handle_result($context, "/msg $context->{nick} Failed to find module for '$context->{keyword}' in channel $context->{from}\n"); $self->{pbot}->{interpreter}->handle_result($context, "/msg $context->{nick} Failed to find module for '$context->{keyword}' in channel $context->{from}\n");
@ -76,19 +107,22 @@ sub launch_module {
} }
my ($channel, $trigger) = ($factoids[0]->[0], $factoids[0]->[1]); my ($channel, $trigger) = ($factoids[0]->[0], $factoids[0]->[1]);
$context->{channel} = $channel; $context->{channel} = $channel;
$context->{keyword} = $trigger; $context->{keyword} = $trigger;
$context->{trigger} = $trigger; $context->{trigger} = $trigger;
my $module = $self->{pbot}->{factoids}->{factoids}->get_data($channel, $trigger, 'action'); my $module = $self->{pbot}->{factoids}->{factoids}->get_data($channel, $trigger, 'action');
$self->{pbot}->{logger}->log( $self->{pbot}->{logger}->log(
"(" . (defined $context->{from} ? $context->{from} : "(undef)") '(' . (defined $context->{from} ? $context->{from} : "(undef)") . '): '
. "): $context->{nick}!$context->{user}\@$context->{host}: Executing module [$context->{command}] $module $context->{arguments}\n" . "$context->{hostmask}: Executing module [$context->{command}] $module $context->{arguments}\n"
); );
$context->{arguments} = $self->{pbot}->{factoids}->expand_factoid_vars($context, $context->{arguments}); $context->{arguments} = $self->{pbot}->{factoids}->expand_factoid_vars($context, $context->{arguments});
my $module_dir = $self->{pbot}->{registry}->get_value('general', 'module_dir'); my $module_dir = $self->{pbot}->{registry}->get_value('general', 'module_dir');
if (not chdir $module_dir) { if (not chdir $module_dir) {
$self->{pbot}->{logger}->log("Could not chdir to '$module_dir': $!\n"); $self->{pbot}->{logger}->log("Could not chdir to '$module_dir': $!\n");
Carp::croak("Could not chdir to '$module_dir': $!"); Carp::croak("Could not chdir to '$module_dir': $!");
@ -99,16 +133,29 @@ sub launch_module {
} }
# FIXME -- add check to ensure $module exists # FIXME -- add check to ensure $module exists
my ($exitval, $stdout, $stderr) = eval { my ($exitval, $stdout, $stderr) = eval {
my $args = $context->{arguments}; my $args = $context->{arguments};
if (not $context->{args_utf8}) { $args = encode('UTF-8', $args); }
if (not $context->{args_utf8}) {
$args = encode('UTF-8', $args);
}
my @cmdline = ("./$module", $self->{pbot}->{interpreter}->split_line($args)); my @cmdline = ("./$module", $self->{pbot}->{interpreter}->split_line($args));
my $timeout = $self->{pbot}->{registry}->get_value('general', 'module_timeout') // 30; my $timeout = $self->{pbot}->{registry}->get_value('general', 'module_timeout') // 30;
my ($stdin, $stdout, $stderr); my ($stdin, $stdout, $stderr);
run \@cmdline, \$stdin, \$stdout, \$stderr, timeout($timeout); run \@cmdline, \$stdin, \$stdout, \$stderr, timeout($timeout);
my $exitval = $? >> 8; my $exitval = $? >> 8;
utf8::decode($stdout);
utf8::decode($stderr); $self->{pbot}->{logger}->log("stdout before: $stdout\n");
utf8::decode $stdout;
utf8::decode $stderr;
return ($exitval, $stdout, $stderr); return ($exitval, $stdout, $stderr);
}; };
@ -118,6 +165,7 @@ sub launch_module {
($exitval, $stdout, $stderr) = (-1, "$context->{trigger}: timed-out", ''); ($exitval, $stdout, $stderr) = (-1, "$context->{trigger}: timed-out", '');
} else { } else {
($exitval, $stdout, $stderr) = (-1, '', $error); ($exitval, $stdout, $stderr) = (-1, '', $error);
$self->{pbot}->{logger}->log("$context->{trigger}: error executing module: $error\n");
} }
} }

View File

@ -15,6 +15,7 @@ use parent 'PBot::Class';
use warnings; use strict; use warnings; use strict;
use feature 'unicode_strings'; use feature 'unicode_strings';
use utf8;
use Text::Levenshtein qw/fastdistance/; use Text::Levenshtein qw/fastdistance/;
use Data::Dumper; use Data::Dumper;

View File

@ -13,9 +13,6 @@ use strict; use warnings;
use feature 'unicode_strings'; use feature 'unicode_strings';
use utf8; use utf8;
# unbuffer stdout
STDOUT->autoflush(1);
use Carp (); use Carp ();
use PBot::Logger; use PBot::Logger;
use PBot::VERSION; use PBot::VERSION;
@ -54,6 +51,17 @@ use PBot::Users;
use PBot::Utils::ParseDate; use PBot::Utils::ParseDate;
use PBot::WebPaste; use PBot::WebPaste;
# unbuffer stdout stream
STDOUT->autoflush(1);
# set standard output streams to encode as utf8
binmode(STDOUT, ":utf8");
binmode(STDERR, ":utf8");
# decode command-line arguments from utf8
use Encode;
@ARGV = map { decode('UTF-8', $_, 1) } @ARGV;
sub new { sub new {
my ($proto, %conf) = @_; my ($proto, %conf) = @_;
my $class = ref($proto) || $proto; my $class = ref($proto) || $proto;

View File

@ -12,6 +12,7 @@ use parent 'PBot::Class';
use warnings; use strict; use warnings; use strict;
use feature 'unicode_strings'; use feature 'unicode_strings';
use utf8;
use File::Basename; use File::Basename;

View File

@ -13,6 +13,7 @@ use parent 'PBot::Class';
use warnings; use strict; use warnings; use strict;
use feature 'unicode_strings'; use feature 'unicode_strings';
use utf8;
use Time::Duration qw/concise duration/; use Time::Duration qw/concise duration/;
use Time::HiRes qw/gettimeofday/; use Time::HiRes qw/gettimeofday/;
@ -22,9 +23,15 @@ use JSON;
sub initialize { sub initialize {
my ($self, %conf) = @_; my ($self, %conf) = @_;
# process manager bot commands
$self->{pbot}->{commands}->register(sub { $self->cmd_ps(@_) }, 'ps', 0); $self->{pbot}->{commands}->register(sub { $self->cmd_ps(@_) }, 'ps', 0);
$self->{pbot}->{commands}->register(sub { $self->cmd_kill(@_) }, 'kill', 1); $self->{pbot}->{commands}->register(sub { $self->cmd_kill(@_) }, 'kill', 1);
# give admin capability group the can-kill capability
$self->{pbot}->{capabilities}->add('admin', 'can-kill', 1); $self->{pbot}->{capabilities}->add('admin', 'can-kill', 1);
# hash of currently running bot-invoked processes
$self->{processes} = {}; $self->{processes} = {};
# automatically reap children processes in background # automatically reap children processes in background
@ -35,6 +42,7 @@ sub initialize {
sub cmd_ps { sub cmd_ps {
my ($self, $context) = @_; my ($self, $context) = @_;
my $usage = 'Usage: ps [-atu]; -a show all information; -t show running time; -u show user/channel'; my $usage = 'Usage: ps [-atu]; -a show all information; -t show running time; -u show user/channel';
my $getopt_error; my $getopt_error;
@ -46,44 +54,55 @@ sub cmd_ps {
Getopt::Long::Configure("bundling"); Getopt::Long::Configure("bundling");
my ($show_all, $show_user, $show_running_time); my ($show_all, $show_user, $show_running_time);
my @opt_args = $self->{pbot}->{interpreter}->split_line($context->{arguments}, strip_quotes => 1); my @opt_args = $self->{pbot}->{interpreter}->split_line($context->{arguments}, strip_quotes => 1);
GetOptionsFromArray( GetOptionsFromArray(
\@opt_args, \@opt_args,
'all|a' => \$show_all, 'all|a' => \$show_all,
'user|u' => \$show_user, 'user|u' => \$show_user,
'time|t' => \$show_running_time 'time|t' => \$show_running_time
); );
return "$getopt_error; $usage" if defined $getopt_error; return "$getopt_error; $usage" if defined $getopt_error;
my @processes; my @processes;
foreach my $pid (sort keys %{$self->{processes}}) { push @processes, $self->{processes}->{$pid}; }
if (not @processes) { return "No running processes."; }
my $result; foreach my $pid (sort keys %{$self->{processes}}) {
if (@processes == 1) { $result = 'One process: '; } else { $result = @processes . ' processes: '; } push @processes, $self->{processes}->{$pid};
}
if (not @processes) {
return "No running processes.";
}
my $result = @processes == 1 ? 'One process: ' : @processes . ' processes: ';
my @entries;
my $sep = '';
foreach my $process (@processes) { foreach my $process (@processes) {
$result .= $sep; my $entry = "$process->{pid}: $process->{commands}->[0]";
$result .= "$process->{pid}: $process->{commands}->[0]";
if ($show_running_time or $show_all) { if ($show_running_time or $show_all) {
my $duration = concise duration (gettimeofday - $process->{process_start}); my $duration = concise duration (gettimeofday - $process->{process_start});
$result .= " [$duration]"; $entry .= " [$duration]";
} }
if ($show_user or $show_all) { if ($show_user or $show_all) {
$result .= " ($process->{nick} in $process->{from})"; $entry .= " ($process->{nick} in $process->{from})";
} }
$sep = '; '; push @entries, $entry;
} }
$result .= join '; ', @entries;
return $result; return $result;
} }
sub cmd_kill { sub cmd_kill {
my ($self, $context) = @_; my ($self, $context) = @_;
my $usage = 'Usage: kill [-a] [-t <seconds>] [-s <signal>] [pids...]; -a kill all processes; -t <seconds> kill processes running longer than <seconds>; -s send <signal> to processes'; my $usage = 'Usage: kill [-a] [-t <seconds>] [-s <signal>] [pids...]; -a kill all processes; -t <seconds> kill processes running longer than <seconds>; -s send <signal> to processes';
my $getopt_error; my $getopt_error;
@ -95,15 +114,21 @@ sub cmd_kill {
Getopt::Long::Configure("bundling"); Getopt::Long::Configure("bundling");
my ($kill_all, $kill_time, $signal); my ($kill_all, $kill_time, $signal);
my @opt_args = $self->{pbot}->{interpreter}->split_line($context->{arguments}, preserve_escapes => 1, strip_quotes => 1); my @opt_args = $self->{pbot}->{interpreter}->split_line($context->{arguments}, preserve_escapes => 1, strip_quotes => 1);
GetOptionsFromArray( GetOptionsFromArray(
\@opt_args, \@opt_args,
'all|a' => \$kill_all, 'all|a' => \$kill_all,
'time|t=i' => \$kill_time, 'time|t=i' => \$kill_time,
'signal|s=s' => \$signal, 'signal|s=s' => \$signal,
); );
return "$getopt_error; $usage" if defined $getopt_error; return "$getopt_error; $usage" if defined $getopt_error;
return "Must specify PIDs to kill unless options -a or -t are provided." if not $kill_all and not $kill_time and not @opt_args;
if (not $kill_all and not $kill_time and not @opt_args) {
return "Must specify PIDs to kill unless options -a or -t are provided.";
}
if (defined $signal) { if (defined $signal) {
$signal = uc $signal; $signal = uc $signal;
@ -112,8 +137,10 @@ sub cmd_kill {
} }
my @pids; my @pids;
if (defined $kill_all or defined $kill_time) { if (defined $kill_all or defined $kill_time) {
my $now = time; my $now = time;
foreach my $pid (sort keys %{$self->{processes}}) { foreach my $pid (sort keys %{$self->{processes}}) {
my $process = $self->{processes}->{$pid}; my $process = $self->{processes}->{$pid};
next if defined $kill_time and $now - $process->{process_start} < $kill_time; next if defined $kill_time and $now - $process->{process_start} < $kill_time;
@ -125,27 +152,41 @@ sub cmd_kill {
push @pids, $pid; push @pids, $pid;
} }
} }
return "No matching process." if not @pids; return "No matching process." if not @pids;
my $ret = eval { kill $signal, @pids }; my $ret = eval { kill $signal, @pids };
if ($@) { my $error = $@; $error =~ s/ at PBot.*//; return $error; }
if ($@) {
my $error = $@;
$error =~ s/ at PBot.*//;
return $error;
}
return "[$ret] Sent signal " . $signal . ' to ' . join ', ', @pids; return "[$ret] Sent signal " . $signal . ' to ' . join ', ', @pids;
} }
sub add_process { sub add_process {
my ($self, $pid, $context) = @_; my ($self, $pid, $context) = @_;
$context->{process_start} = gettimeofday; $context->{process_start} = gettimeofday;
$self->{processes}->{$pid} = $context; $self->{processes}->{$pid} = $context;
$self->{pbot}->{logger}->log("Starting process $pid: $context->{commands}->[0]\n"); $self->{pbot}->{logger}->log("Starting process $pid: $context->{commands}->[0]\n");
} }
sub remove_process { sub remove_process {
my ($self, $pid) = @_; my ($self, $pid) = @_;
if (exists $self->{processes}->{$pid}) { if (exists $self->{processes}->{$pid}) {
my $command = $self->{processes}->{$pid}->{commands}->[0]; my $command = $self->{processes}->{$pid}->{commands}->[0];
my $duration = gettimeofday - $self->{processes}->{$pid}->{process_start}; my $duration = gettimeofday - $self->{processes}->{$pid}->{process_start};
$duration = sprintf "%0.3f", $duration; $duration = sprintf "%0.3f", $duration;
$self->{pbot}->{logger}->log("Finished process $pid ($command): duration $duration seconds\n"); $self->{pbot}->{logger}->log("Finished process $pid ($command): duration $duration seconds\n");
delete $self->{processes}->{$pid}; delete $self->{processes}->{$pid};
} else { } else {
$self->{pbot}->{logger}->log("Finished process $pid\n"); $self->{pbot}->{logger}->log("Finished process $pid\n");
@ -154,32 +195,46 @@ sub remove_process {
sub execute_process { sub execute_process {
my ($self, $context, $subref, $timeout) = @_; my ($self, $context, $subref, $timeout) = @_;
$timeout //= 30;
if (not exists $context->{commands}) { $context->{commands} = [$context->{command}]; } $timeout //= 30; # default timeout 30 seconds
if (not exists $context->{commands}) {
$context->{commands} = [$context->{command}];
}
# don't fork again if we're already a forked process # don't fork again if we're already a forked process
if (exists $context->{pid}) { if (defined $context->{pid} and $context->{pid} == 0) {
$subref->($context); $subref->($context);
return $context->{result}; return $context->{result};
} }
pipe(my $reader, my $writer); pipe(my $reader, my $writer);
# fork new process
$context->{pid} = fork; $context->{pid} = fork;
if (not defined $context->{pid}) { if (not defined $context->{pid}) {
# fork failed
$self->{pbot}->{logger}->log("Could not fork process: $!\n"); $self->{pbot}->{logger}->log("Could not fork process: $!\n");
close $reader; close $reader;
close $writer; close $writer;
delete $context->{pid};
# groan to let the users know something went wrong
$context->{checkflood} = 1; $context->{checkflood} = 1;
$self->{pbot}->{interpreter}->handle_result($context, "/me groans loudly.\n"); $self->{pbot}->{interpreter}->handle_result($context, "/me groans loudly.\n");
return; return;
} }
if ($context->{pid} == 0) { if ($context->{pid} == 0) {
# child # child
close $reader; close $reader;
# flag this instance as child
$self->{pbot}->{child} = 1; $self->{pbot}->{child} = 1;
# don't quit the IRC client when the child dies # don't quit the IRC client when the child dies
@ -190,23 +245,31 @@ sub execute_process {
# remove atexit handlers # remove atexit handlers
$self->{pbot}->{atexit}->unregister_all; $self->{pbot}->{atexit}->unregister_all;
# FIXME: close databases and files too? Or just set everything to check for $self->{pbot}->{child} == 1 or $context->{pid} == 0?
# execute the provided subroutine, results are stored in $context # execute the provided subroutine, results are stored in $context
eval { eval {
local $SIG{ALRM} = sub { die "Process `$context->{commands}->[0]` timed-out" }; local $SIG{ALRM} = sub { die "Process `$context->{commands}->[0]` timed-out" };
alarm $timeout; alarm $timeout;
$subref->($context); $subref->($context);
}; };
alarm 0;
# check for errors # check for errors
if ($@) { if ($@) {
$context->{result} = $@; $context->{result} = $@;
$context->{'timed-out'} = 1 if $context->{result} =~ /^Process .* timed-out at PBot\/ProcessManager/; $context->{'timed-out'} = 1 if $context->{result} =~ /^Process .* timed-out at PBot\/ProcessManager/;
$self->{pbot}->{logger}->log("Error executing process: $context->{result}\n"); $self->{pbot}->{logger}->log("Error executing process: $context->{result}\n");
# strip internal PBot source data for IRC output
$context->{result} =~ s/ at PBot.*$//ms; $context->{result} =~ s/ at PBot.*$//ms;
$context->{result} =~ s/\s+...propagated at .*$//ms; $context->{result} =~ s/\s+...propagated at .*$//ms;
} }
# turn alarm back on for PBot::Timer
alarm 1;
# print $context to pipe # print $context to pipe
my $json = encode_json $context; my $json = encode_json $context;
print $writer "$json\n"; print $writer "$json\n";
@ -216,46 +279,62 @@ sub execute_process {
exit 0; exit 0;
} else { } else {
# parent # parent
# nothing to write to child
close $writer; close $writer;
# add process
$self->add_process($context->{pid}, $context); $self->add_process($context->{pid}, $context);
# add reader handler
$self->{pbot}->{select_handler}->add_reader($reader, sub { $self->process_pipe_reader($context->{pid}, @_) }); $self->{pbot}->{select_handler}->add_reader($reader, sub { $self->process_pipe_reader($context->{pid}, @_) });
# return empty string since reader will handle the output when child is finished # return empty string since reader will handle the output when child is finished
return ""; return '';
} }
} }
sub process_pipe_reader { sub process_pipe_reader {
my ($self, $pid, $buf) = @_; my ($self, $pid, $buf) = @_;
# retrieve context object from child
my $context = decode_json $buf or do { my $context = decode_json $buf or do {
$self->{pbot}->{logger}->log("Failed to decode bad json: [$buf]\n"); $self->{pbot}->{logger}->log("Failed to decode bad json: [$buf]\n");
return; return;
}; };
# context is no longer forked
delete $context->{pid}; delete $context->{pid};
# check for output
if (not defined $context->{result} or not length $context->{result}) { if (not defined $context->{result} or not length $context->{result}) {
$self->{pbot}->{logger}->log("No result from process.\n"); $self->{pbot}->{logger}->log("No result from process.\n");
return if $context->{suppress_no_output}; return if $context->{suppress_no_output};
$context->{result} = "No output."; $context->{result} = "No output.";
} }
if ($context->{referenced}) { return if $context->{result} =~ m/(?:no results)/i; } # don't output unnecessary result if command was referenced within a message
if ($context->{referenced}) {
return if $context->{result} =~ m/(?:no results)/i;
}
# handle code factoid result
if (exists $context->{special} and $context->{special} eq 'code-factoid') { if (exists $context->{special} and $context->{special} eq 'code-factoid') {
$context->{result} =~ s/\s+$//g; $context->{result} =~ s/\s+$//g;
$self->{pbot}->{logger}->log("No text result from code-factoid.\n") and return if not length $context->{result};
if (not length $context->{result}) {
$self->{pbot}->{logger}->log("No text result from code-factoid.\n");
return;
}
$context->{original_keyword} = $context->{root_keyword}; $context->{original_keyword} = $context->{root_keyword};
$context->{result} = $self->{pbot}->{factoids}->handle_action($context, $context->{result}); $context->{result} = $self->{pbot}->{factoids}->handle_action($context, $context->{result});
} }
$context->{checkflood} = 0; # if nick isn't overridden yet, check for a potential nick prefix
if (not defined $context->{nickoverride}) {
if (defined $context->{nickoverride}) { $self->{pbot}->{interpreter}->handle_result($context, $context->{result}); } # if add_nick is set on the factoid, set the nick override to the caller's nick
else { if (exists $context->{special} and $context->{special} ne 'code-factoid'
# don't override nick if already set
if ( exists $context->{special}
and $context->{special} ne 'code-factoid'
and $self->{pbot}->{factoids}->{factoids}->exists($context->{channel}, $context->{trigger}, 'add_nick') and $self->{pbot}->{factoids}->{factoids}->exists($context->{channel}, $context->{trigger}, 'add_nick')
and $self->{pbot}->{factoids}->{factoids}->get_data($context->{channel}, $context->{trigger}, 'add_nick') != 0) and $self->{pbot}->{factoids}->{factoids}->get_data($context->{channel}, $context->{trigger}, 'add_nick') != 0)
{ {
@ -263,14 +342,16 @@ sub process_pipe_reader {
$context->{no_nickoverride} = 0; $context->{no_nickoverride} = 0;
$context->{force_nickoverride} = 1; $context->{force_nickoverride} = 1;
} else { } else {
# extract nick-like thing from module result # extract nick-like thing from process result
if ($context->{result} =~ s/^(\S+): //) { if ($context->{result} =~ s/^(\S+): //) {
my $nick = $1; my $nick = $1;
if (lc $nick eq "usage") { if (lc $nick eq "usage") {
# put it back on result if it's a usage message # put it back on result if it's a usage message
$context->{result} = "$nick: $context->{result}"; $context->{result} = "$nick: $context->{result}";
} else { } else {
my $present = $self->{pbot}->{nicklist}->is_present($context->{channel}, $nick); my $present = $self->{pbot}->{nicklist}->is_present($context->{channel}, $nick);
if ($present) { if ($present) {
# nick is present in channel # nick is present in channel
$context->{nickoverride} = $present; $context->{nickoverride} = $present;
@ -281,13 +362,11 @@ sub process_pipe_reader {
} }
} }
} }
}
# send the result off to the bot to be handled
$context->{checkflood} = 1;
$self->{pbot}->{interpreter}->handle_result($context, $context->{result}); $self->{pbot}->{interpreter}->handle_result($context, $context->{result});
} }
my $text = $self->{pbot}->{interpreter}
->truncate_result($context->{channel}, $self->{pbot}->{registry}->get_value('irc', 'botnick'), 'undef', $context->{result}, $context->{result}, 0);
$self->{pbot}->{antiflood}
->check_flood($context->{from}, $self->{pbot}->{registry}->get_value('irc', 'botnick'), $self->{pbot}->{registry}->get_value('irc', 'username'), 'pbot', $text, 0, 0, 0);
}
1; 1;

View File

@ -14,6 +14,7 @@ use parent 'PBot::Class';
use warnings; use strict; use warnings; use strict;
use feature 'unicode_strings'; use feature 'unicode_strings';
use utf8;
use Module::Refresh; use Module::Refresh;
use File::Basename; use File::Basename;

View File

@ -11,6 +11,7 @@ package PBot::Registerable;
use warnings; use strict; use warnings; use strict;
use feature 'unicode_strings'; use feature 'unicode_strings';
use utf8;
sub new { sub new {
my ($proto, %conf) = @_; my ($proto, %conf) = @_;

View File

@ -14,6 +14,7 @@ use parent 'PBot::Class';
use warnings; use strict; use warnings; use strict;
use feature 'unicode_strings'; use feature 'unicode_strings';
use utf8;
use Time::HiRes qw(gettimeofday); use Time::HiRes qw(gettimeofday);
use PBot::RegistryCommands; use PBot::RegistryCommands;

View File

@ -12,6 +12,7 @@ use parent 'PBot::Class';
use warnings; use strict; use warnings; use strict;
use feature 'unicode_strings'; use feature 'unicode_strings';
use utf8;
sub initialize { sub initialize {
my ($self, %conf) = @_; my ($self, %conf) = @_;

View File

@ -12,6 +12,7 @@ package PBot::SQLiteLogger;
use strict; use warnings; use strict; use warnings;
use feature 'unicode_strings'; use feature 'unicode_strings';
use utf8;
use Time::HiRes qw(gettimeofday); use Time::HiRes qw(gettimeofday);

View File

@ -13,6 +13,7 @@ use strict;
use warnings; use warnings;
use feature 'unicode_strings'; use feature 'unicode_strings';
use utf8;
sub PUSHED { sub PUSHED {
my ($class, $mode, $fh) = @_; my ($class, $mode, $fh) = @_;

View File

@ -7,6 +7,7 @@ use parent 'PBot::Class';
use warnings; use strict; use warnings; use strict;
use feature 'unicode_strings'; use feature 'unicode_strings';
use utf8;
use IO::Select; use IO::Select;
@ -18,10 +19,10 @@ sub initialize {
} }
sub add_reader { sub add_reader {
my ($self, $handle, $sub) = @_; my ($self, $handle, $subref) = @_;
$self->{select}->add($handle); $self->{select}->add($handle);
$self->{readers}->{$handle} = $sub; $self->{readers}->{$handle} = $subref;
$self->{buffers}->{$handle} = ""; $self->{buffers}->{$handle} = '';
} }
sub remove_reader { sub remove_reader {
@ -33,32 +34,61 @@ sub remove_reader {
sub do_select { sub do_select {
my ($self) = @_; my ($self) = @_;
# maximum read length
my $length = 8192; my $length = 8192;
# check if any readers can read
my @ready = $self->{select}->can_read(.1); my @ready = $self->{select}->can_read(.1);
foreach my $fh (@ready) { foreach my $fh (@ready) {
# read from handle
my $ret = sysread($fh, my $buf, $length); my $ret = sysread($fh, my $buf, $length);
# error reading
if (not defined $ret) { if (not defined $ret) {
$self->{pbot}->{logger}->log("Error with $fh: $!\n"); $self->{pbot}->{logger}->log("SelectHandler: Error reading $fh: $!\n");
$self->remove_reader($fh); $self->remove_reader($fh);
next; next;
} }
# reader closed
if ($ret == 0) { if ($ret == 0) {
if (length $self->{buffers}->{$fh}) { $self->{readers}->{$fh}->($self->{buffers}->{$fh}); } # is there anything in reader's buffer?
if (length $self->{buffers}->{$fh}) {
# send buffer to reader subref
$self->{readers}->{$fh}->($self->{buffers}->{$fh});
}
# remove reader
$self->remove_reader($fh); $self->remove_reader($fh);
# skip to next reader
next; next;
} }
# sanity check for missing reader
if (not exists $self->{readers}->{$fh}) {
$self->{pbot}->{logger}->log("Error: no reader for $fh\n");
# skip to next reader
next;
}
# accumulate input into reader's buffer
$self->{buffers}->{$fh} .= $buf; $self->{buffers}->{$fh} .= $buf;
if (not exists $self->{readers}->{$fh}) { $self->{pbot}->{logger}->log("Error: no reader for $fh\n"); } # if we read less than max length bytes then this is probably
else { # a complete message so send it to reader now, otherwise we'll
# continue to accumulate input into reader's buffer and then send
# the buffer when reader closes.
if ($ret < $length) { if ($ret < $length) {
# send reader's buffer to reader subref
$self->{readers}->{$fh}->($self->{buffers}->{$fh}); $self->{readers}->{$fh}->($self->{buffers}->{$fh});
$self->{buffers}->{$fh} = "";
} # clear out reader's buffer
$self->{buffers}->{$fh} = '';
} }
} }
} }

View File

@ -7,14 +7,18 @@ use parent 'PBot::Class';
use warnings; use strict; use warnings; use strict;
use feature 'unicode_strings'; use feature 'unicode_strings';
use utf8;
use POSIX qw(tcgetpgrp getpgrp); # to check whether process is in background or foreground use POSIX qw(tcgetpgrp getpgrp); # to check whether process is in background or foreground
use Encode;
sub initialize { sub initialize {
my ($self, %conf) = @_; my ($self, %conf) = @_;
# create implicit bot-admin account for bot # create stdin bot-admin account for bot
my $user = $self->{pbot}->{users}->find_user('.*', '*!stdin@pbot'); my $user = $self->{pbot}->{users}->find_user('.*', '*!stdin@pbot');
if (not defined $user or not $self->{pbot}->{capabilities}->userhas($user, 'botowner')) { if (not defined $user or not $self->{pbot}->{capabilities}->userhas($user, 'botowner')) {
my $botnick = $self->{pbot}->{registry}->get_value('irc', 'botnick'); my $botnick = $self->{pbot}->{registry}->get_value('irc', 'botnick');
$self->{pbot}->{logger}->log("Adding stdin botowner *!stdin\@pbot...\n"); $self->{pbot}->{logger}->log("Adding stdin botowner *!stdin\@pbot...\n");
@ -23,18 +27,25 @@ sub initialize {
$self->{pbot}->{users}->save; $self->{pbot}->{users}->save;
} }
# used to check whether process is in background or foreground, for stdin reading
if (not $self->{pbot}->{registry}->get_value('general', 'daemon')) { if (not $self->{pbot}->{registry}->get_value('general', 'daemon')) {
# TTY is used to check whether process is in background or foreground
open TTY, "</dev/tty" or die $!; open TTY, "</dev/tty" or die $!;
$self->{tty_fd} = fileno(TTY); $self->{tty_fd} = fileno(TTY);
# add STDIN to select handler
$self->{pbot}->{select_handler}->add_reader(\*STDIN, sub { $self->stdin_reader(@_) }); $self->{pbot}->{select_handler}->add_reader(\*STDIN, sub { $self->stdin_reader(@_) });
} else { } else {
$self->{pbot}->{logger}->log("Starting in daemon mode.\n"); $self->{pbot}->{logger}->log("Starting in daemon mode.\n");
# TODO: close STDIN, etc?
} }
} }
sub stdin_reader { sub stdin_reader {
my ($self, $input) = @_; my ($self, $input) = @_;
# decode STDIN input from utf8
$input = decode('UTF-8', $input);
chomp $input; chomp $input;
# make sure we're in the foreground first # make sure we're in the foreground first
@ -46,14 +57,17 @@ sub stdin_reader {
my ($from, $text); my ($from, $text);
my $botnick = $self->{pbot}->{registry}->get_value('irc', 'botnick');
if ($input =~ m/^~([^ ]+)\s+(.*)/) { if ($input =~ m/^~([^ ]+)\s+(.*)/) {
$from = $1; $from = $1;
$text = $self->{pbot}->{registry}->get_value('irc', 'botnick') . " $2"; $text = "$botnick $2";
} else { } else {
$from = 'stdin@pbot'; $from = 'stdin@pbot';
$text = $self->{pbot}->{registry}->get_value('irc', 'botnick') . " $input"; $text = "$botnick $input";
} }
return $self->{pbot}->{interpreter}->process_line($from, $self->{pbot}->{registry}->get_value('irc', 'botnick'), "stdin", "pbot", $text);
return $self->{pbot}->{interpreter}->process_line($from, $botnick, "stdin", "pbot", $text);
} }
1; 1;

View File

@ -21,6 +21,7 @@ use parent 'PBot::Class';
use warnings; use strict; use warnings; use strict;
use feature 'unicode_strings'; use feature 'unicode_strings';
use utf8;
use Time::Duration qw/concise duration/; use Time::Duration qw/concise duration/;

View File

@ -14,6 +14,7 @@ use parent 'PBot::Class';
use warnings; use strict; use warnings; use strict;
use feature 'unicode_strings'; use feature 'unicode_strings';
use utf8;
use File::Basename; use File::Basename;

View File

@ -12,6 +12,7 @@ use parent 'PBot::Class';
use warnings; use strict; use warnings; use strict;
use feature 'unicode_strings'; use feature 'unicode_strings';
use utf8;
sub initialize { sub initialize {
my ($self, %conf) = @_; my ($self, %conf) = @_;

View File

@ -13,6 +13,7 @@ use parent 'PBot::Class';
use strict; use warnings; use strict; use warnings;
use feature 'unicode_strings'; use feature 'unicode_strings';
use utf8;
use LWP::UserAgent; use LWP::UserAgent;

View File

@ -13,6 +13,7 @@ use parent 'PBot::Class';
use warnings; use strict; use warnings; use strict;
use feature 'unicode_strings'; use feature 'unicode_strings';
use utf8;
use Time::HiRes qw/gettimeofday/; use Time::HiRes qw/gettimeofday/;
use Time::Duration; use Time::Duration;
@ -36,8 +37,10 @@ sub initialize {
sub get_paste_site { sub get_paste_site {
my ($self) = @_; my ($self) = @_;
# get the next paste site's subroutine reference
my $subref = $self->{paste_sites}->[$self->{current_site}]; my $subref = $self->{paste_sites}->[$self->{current_site}];
# rotate current_site
if (++$self->{current_site} >= @{$self->{paste_sites}}) { if (++$self->{current_site} >= @{$self->{paste_sites}}) {
$self->{current_site} = 0; $self->{current_site} = 0;
} }
@ -54,22 +57,31 @@ sub paste {
%opts = (%default_opts, %opts); %opts = (%default_opts, %opts);
# word-wrap text unless no_split is set
$text =~ s/(.{120})\s/$1\n/g unless $opts{no_split}; $text =~ s/(.{120})\s/$1\n/g unless $opts{no_split};
# encode paste to utf8
$text = encode('UTF-8', $text);
my $response; my $response;
for (my $tries = 3; $tries > 0; $tries--) { for (my $tries = 3; $tries > 0; $tries--) {
# get the next paste site
my $paste_site = $self->get_paste_site; my $paste_site = $self->get_paste_site;
# attempt to paste text
$response = $paste_site->($text); $response = $paste_site->($text);
# exit loop if paste succeeded
last if $response->is_success; last if $response->is_success;
} }
# all tries failed
if (not $response->is_success) { if (not $response->is_success) {
return "error pasting: " . $response->status_line; return "error pasting: " . $response->status_line;
} }
# success, return URL
my $result = $response->decoded_content; my $result = $response->decoded_content;
$result =~ s/^\s+|\s+$//g; $result =~ s/^\s+|\s+$//g;