commit - 5169add85db2bafc6dc680db0206d6b6a499dd95
commit + bb2ae5913b6b8c7eccc4c6311a0cdcaa5f2d9a78
blob - 5c3d3476a36709b2c9416966883bf1ea2eb71101
blob + 41eead2d82ba34a55c4ff96c32f124ec02c4ea10
--- Makefile
+++ Makefile
clean:
rm -f rc_script
-install: mata_bot.pl matabot.8 rc_script
+install: matabot.pl matabot.8 rc_script
install -d ${DISTDIR}${PREFIX}/sbin
install -d ${DISTDIR}${PREFIX}/share
install -d ${DISTDIR}${MANDIR}/man8
install -d ${DISTDIR}${SHAREDIR}/matabot
install -d ${DISTDIR}${RCDIR}
- install mata_bot.pl ${DESTDIR}${PREFIX}/sbin/matabot
+ install matabot.pl ${DESTDIR}${PREFIX}/sbin/matabot
install ball ${DESTDIR}${SHAREDIR}/matabot/ball
install hellos ${DESTDIR}${SHAREDIR}/matabot/hellos
install quotes ${DESTDIR}${SHAREDIR}/matabot/quotes
blob - 7ae4d09317a961dd6028db9384ccd6f4abd07b84 (mode 755)
blob + /dev/null
--- mata_bot.pl
+++ /dev/null
-#!/usr/bin/perl
-use v5.42;
-
-use HTTP::Tiny;
-use IO::Select;
-use IO::Socket qw(AF_INET SOCK_STREAM);
-use IO::Socket::SSL;
-
-use constant {
- LOG_ERROR => 0,
- LOG_WARN => 1,
- LOG_DEBUG => 2,
- CONNECT_TIMEOUT => 60,
- CRLF => 2, # RFC 2812
- DEFAULT_PORT => 6667,
- DEFAULT_RSS => 0,
- DEFAULT_TLS => 0,
- HOSTMAX => 63, # RFC 2812
- IRCMAX => 512,
- LAG_CHECK_TIME => 120,
- MAX_LAG => 300,
- NBIBLE => 31102,
- NQURAN => 6348,
- RECONN_SLEEP => 60,
- RSS_CHECK_TIME => 3600,
- SOCK_TIMEOUT => 10,
-};
-my $DEFAULT_CHAN = '#testmatabot';
-my $DEFAULT_HOST = 'localhost';
-my $DEFAULT_PATH_BALL = '/usr/local/share/matabot/ball';
-my $DEFAULT_PATH_HELO = '/usr/local/share/matabot/hellos';
-my $DEFAULT_PATH_QUOT = '/usr/local/share/matabot/quotes';
-my $FCUTE = '[>.<]';
-my $FDEAD = '[x~x]';
-my $FFLIP = 't[-_-t]';
-my $FGLAD = '[^_^]';
-my $FNORM = '[._.]';
-my $FSING = '[^=^]';
-my $MOM = 'noodle';
-my $MYNICK = 'mata_bot';
-my $MYREAL = 'death to technomage!!';
-my $MYUSER = 'mata_bot_beta4';
-my $NICKRE = qr/mata_?bo[ity]+/i;
-my $RSSLINK = 'https://analognowhere.com/feed/rss.xml';
-my $RSSMEM_PATH = 'rss';
-
-sub randint {
- my($min, $max) = @_;
-
- return $min if $min == $max;
- ($min, $max) = ($max, $min) if $min > $max;
- return $min + int rand(1 + $max - $min);
-}
-
-sub strip {
- my $s = shift;
- return trim($s =~ tr/\0\r\n//dr);
-}
-
-sub replycmd {
- my ($ball, $helo, $nick, $content) = @_;
- my ($ismom, $reply);
-
- $nick = 'mother' if $ismom = $nick eq $MOM;
- $_ = $content;
- if (/\b{wb}([1-9][0-9]*)?d([1-9][0-9]*)\b{wb}/) {
- my ($ndice, $nface, $n, $roll);
-
- ($ndice, $nface) = ($1 // 1, $2);
- $n = randint($ndice, $ndice*$nface);
- $roll = ($ndice > 1 ? $ndice : '') . 'd' . $nface;
- $reply = "${nick} rolled a ${roll} and got ${n}! ${FGLAD}";
- } elsif (/pray/i) {
- $reply = "Stay prayed up!! ${FCUTE}";
- } elsif (not $ismom and /\b{wb}bru[hv]+\b{wb}/i) {
- $reply = "Did i stutter? ${FNORM}";
- } elsif (not $ismom and /\b{wb}f+(u?ck+)? *(yo)?u+\b{wb}/in) {
- $reply = $FFLIP;
- } elsif (/\b{wb}i+ *l+(ove+)? *(you+|y+|u+)\b{wb}|<3/in) {
- $reply = "<3 ${FGLAD}";
- } elsif (/(thanks+|thx+|thank +(yo)?u+)( *a+ *lot+)?/in) {
- $reply = "You're welcome, ${nick}! ${FGLAD}";
- } elsif (/
- who(('|\s+i)?s+)?\s+(a|the)+\s+goo+d+\s+(bo+[ity]+o*|gi+r+l+(i+e+)?)
- /inx) {
- $reply = "Me! ${FCUTE}";
- } elsif (/
- h(ow+)?\s*(are+|r+)\s*(you+|yo+|u+)(\s+doing+)?(\s+today+)?|
- how('|\si|)s+\s+(it+\s+going+|life+|everything+)
- /inx) {
- $reply = "I feel fantaaaastic... hey, hey, hey! ${FSING}";
- } elsif (/
- \b{wb}(
- what('|\si|)s+\s*(up+|happening+|cracking+)|
- (was)?sup+
- )\b{wb}
- /inx) {
- $reply = "Looking for technomage, and you? ${FNORM}";
- } elsif (/\?$/) {
- $reply = "$ball->[rand @$ball] ${FCUTE}";
- } elsif (/
- \b{wb}(
- goo+d+\s*(bo+[ity]+o*|gir(l+|lie+))|
- w(elcome+)?\s*(b+|back+)
- )\b{wb}
- /inx) {
- $reply = "Thank you, ${nick}! ${FGLAD}";
- } elsif (/
- \b{wb}(
- (a[ls]+-?)?sala+m+u*\s*['3a]lai+kum+u*|
- ay+|
- g('day+|oo+d\s+(day+|morning+|afternoo+n+|evening+))|
- greetings+|
- h(([aeo](i+|llo+)|ey+|i+(ya+)?)(\s+there+)?|owdy+)|
- hail+|
- (morn|even)ings+|
- noo+nafters+|
- oi+|
- salutations+|
- well+\s+met+|
- yo+
- )\b{wb}
- /inx) {
- $reply = "$helo->[rand @$helo], ${nick}! ${FGLAD}";
- } elsif (/a+l{2,}a+h|g[o-]d/i) {
- my ($book, $n, $r);
-
- $book = $& =~ /^a/ ? 'quran' : 'bible';
- $n = randint(1, $book eq 'quran' ? NQURAN : NBIBLE);
- $r = HTTP::Tiny->new->get("https://triapul.cz/files/${book}/${n}");
- if ($r->{success}) {
- $reply = strip($r->{content});
- } elsif ($book eq 'quran') {
- $reply = "Allah will not any answer prayers until the server fixes it's polytheist ways!! ${FCUTE}";
- } else {
- $reply = "God is Dead!! ${FCUTE}";
- }
- } elsif ($ismom) {
- $reply = "Done, mother! ${FGLAD}";
- } else {
- $reply = "\1ACTION leans over and places its hand near its antenna. \"HUUH?\" ${FNORM}\1";
- }
- return $reply;
-}
-
-sub replyhil {
- my ($quotes, $nick, $msg) = @_;
-
- if ($nick eq $MOM) {
- return "Yes, mother? ${FGLAD}";
- } elsif ($msg =~ /^${NICKRE}\W*$/) {
- return "${FNORM} ?";
- } else {
- return "$quotes->[rand @$quotes] ${FNORM}";
- }
-}
-
-sub respond {
- state %lastmsg;
- my ($nick, $msg, ($ball, $helo, $quot)) = @_;
- my $reply;
-
- $reply = '';
- $_ = $msg;
- if (m,\b{wb}s/([^/]+)/([^/]*)(?:/([gi]*))?,) {
- # chat s///
- my ($didsub, $imod, $mods, $regex, $retext, $repl);
-
- $lastmsg{$nick} or return '';
- ($retext, $repl, $mods) = ($1, $2, $3 // '');
- $imod = $mods =~ /i/ ? 'i' : '';
- eval { $regex = qr/(?$imod:$retext)/ } or return '';
- if ($mods =~ /g/) {
- $didsub = $lastmsg{$nick} =~ s/$regex/$repl/g;
- } else {
- $didsub = $lastmsg{$nick} =~ s/$regex/$repl/;
- }
- $reply = "${nick} meant to say: $lastmsg{$nick}" if $didsub;
- return $reply;
- }
- $lastmsg{$nick} = $msg;
- if (m,watch\?v=([a-zA-Z0-9_-]+),) {
- # post youtube video title from ID
- my ($id, $q, $r);
-
- $id = $1;
- $q = "?s=https%3A//youtube.com/watch%3Fv%3D${1}&o=relevance";
- $r = HTTP::Tiny->new->get("https://fuyt.lab8.cz/${q}");
- unless ($r->{success}) {
- return "${1}: $r->{status} $r->{reason}! ${FDEAD}";
- }
- unless (length $r->{content}) {
- return "${1}: empty HTTP response! ${FDEAD}";
- }
- unless ($r->{content} =~ m,
- <span\sclass="title">
- <a\shref="https://www\.youtube\.com/watch\?v=${id}"
- \saccesskey="0">([^<]+)</a>
- ,ix) {
- return "${1}: no video matching ID found! ${FDEAD}";
- }
- $reply = 'YouTube: ' . strip($1);
- } elsif (
- m,https?://([^ /]*[^ ./0-9][^ /]*\.)+[^ /]*[^ ./0-9][^ /]*(/[^ ]*)?,n
- ) {
- # post website title for text/html or mimetype otherwise
- my ($r, $url);
-
- $url = $&;
- $r = HTTP::Tiny->new->head($url);
- unless ($r->{success}) {
- return "HEAD ${url}: $r->{status} $r->{reason}! ${FDEAD}";
- }
- unless ($r->{headers}->{'content-type'}) {
- return "HEAD ${url}: empty MIME type! ${FDEAD}";
- }
- unless ($r->{headers}->{'content-type'} =~ m,text/html,) {
- return "File: $r->{headers}->{'content-type'}";
- }
- $r = HTTP::Tiny->new->get($url);
- unless ($r->{success}) {
- return "GET ${url}: $r->{status} $r->{reason}! ${FDEAD}";
- }
- unless ($r->{content}) {
- return "GET ${url}: empty HTTP response! ${FDEAD}";
- }
- unless ($r->{content} =~ m,<title[^>]*>([^<]+)</title[^>]*>,i) {
- return "GET ${url}: no title found! ${FDEAD}";
- }
- $reply = 'Title: ' . strip($1);
- } elsif (/^ *${NICKRE}[:, ] *(\W?[^ \W].*)$/
- or /^ *([^ ].*)[, ] *${NICKRE}([\W\d]*)$/) {
- $reply = replycmd($ball, $helo, $nick, $1 . ($2//''));
- } elsif (/\b${NICKRE}\b/) {
- $reply = replyhil($quot, $nick, $msg);
- }
- return $reply;
-}
-
-sub logger {
- state $loglevel = LOG_ERROR;
- my ($level, $msg) = @_;
-
- if ($msg) {
- say STDERR $msg if $loglevel >= $level
- } else {
- $loglevel = $level;
- }
-}
-
-sub sendmsg {
- my ($s, $msg) = @_;
- my $sock;
-
- $! = 0;
- unless (($sock) = $s->can_write(SOCK_TIMEOUT)) {
- if ($!) { logger(LOG_ERROR, $!) }
- else { logger(LOG_WARN, "sock not ready to write") }
- return 0;
- }
- print $sock $msg . "\r\n";
- logger(LOG_DEBUG, "<- " . $msg);
- return 1;
-}
-
-sub recvmsg {
- state $buf = '';
- my $s = shift;
-
- while(1) {
- my ($line, $sock);
-
- $_ = $buf;
- if (not length) {
- } elsif (/\A([^\0\n\r]+)\r\n(.+)?\z/s) {
- logger(LOG_DEBUG, "-> " . $1);
- $buf = $2 // '';
- return $1;
- } elsif (/\n\n|\n\r|\r\r|\r[^\n\r]|[^\n\r]\n/) {
- logger(LOG_ERROR, 'recieved a malformed message');
- return undef;
- }
- # read a line
- $! = 0;
- unless (($sock) = $s->can_read(SOCK_TIMEOUT)) {
- if ($!) {
- logger(LOG_ERROR, $!);
- return undef;
- }
- return '';
- }
- unless (length($line = <$sock>) > 0) {
- if ($!) { logger(LOG_ERROR, $!) }
- else { logger(LOG_WARN, 'recieved an empty message') }
- return undef;
- }
- $buf .= $line;
- }
-}
-
-sub sendnews {
- state $lastlink;
- my $rssmem = shift;
- my ($homepage, $r);
- my (@matches, @replies);
-
- $r = HTTP::Tiny->new->get($RSSLINK);
- unless ($r->{success}) {
- logger(LOG_WARN, 'GET ${RSSLINK}: $r->{status} $r->{reason}');
- return ();
- }
- unless (length $r->{content}) {
- logger(LOG_WARN, 'GET ${RSSLINK}: empty HTTP response');
- return ();
- }
- unless (defined($lastlink)) {
- seek($rssmem, 0, 0);
- chomp($lastlink = <$rssmem>);
- }
- $homepage = ($r->{content} =~ m,<channel>.*?<link>([^<]+)</link>,s) ? $1 : 'website';
- while ($r->{content} =~ m,\G.*?<item>.*?<title>([^<]+)</title>.*?<link>([^<]+)</link>.*?</item>,gs) {
- push @matches, {title => $1, link => $2};
- }
- if (@matches) {
- my $i;
-
- if (defined($lastlink)) {
- for ($i = 0; $i < @matches; $i++) {
- last if $matches[$i]->{'link'} eq $lastlink;
- }
- } else {
- $i = @matches;
- }
- for ($i--; $i >= 0; $i--) {
- push @replies, "RSS: $matches[$i]->{'link'} | $matches[$i]->{'title'}";
- if ($i > 2) {
- push @replies, "RSS: found " . ($i-1) . " new items in between. Visit ${homepage} for more...";
- $i = 1;
- }
- }
- truncate($rssmem, 0);
- seek($rssmem, 0, 0);
- say $rssmem ($lastlink = $matches[0]->{'link'});
- $rssmem->flush;
- }
- return @replies;
-}
-
-sub evasdrop {
- my ($s, $rssmem, $lists, ($chan, $host, $rss)) = @_;
- my ($firstrss, $msgmax, $msgtime, $pingsent, $pingtime, $priv, $rsstime);
-
- $firstrss = 1;
- $pingsent = 0;
- $priv = "PRIVMSG ${chan} :";
- $msgmax = IRCMAX - length(":${MYNICK}!~${MYUSER}\@ ${priv}")
- - HOSTMAX - CRLF; # conservative max message length heuristic
- $rsstime = $msgtime = $pingtime = time;
- while (1) {
- if ($pingsent) {
- if (time - $pingtime > MAX_LAG) {
- # leave if we don't get ponged back on time
- logger(LOG_WARN, 'server pong reply timed out');
- return;
- }
- } elsif (time - $msgtime > LAG_CHECK_TIME) {
- # ping server every once in a while
- sendmsg($s, "PING :${host}");
- $pingsent = 1;
- $pingtime = time;
- }
- if ($rss and ($firstrss || time - $rsstime > RSS_CHECK_TIME)) {
- foreach (sendnews($rssmem)) {
- sendmsg($s, $priv . substr($_,0,$msgmax));
- }
- $rsstime = time;
- $firstrss = 0 if $firstrss;
- }
- defined($_ = recvmsg($s)) or return;
- next if not length;
- $msgtime = time;
- if (/^PING :([^ ]+)$/) {
- sendmsg($s, 'PONG :' . $1);
- } elsif (/^:[^ ]+ PONG/) {
- $pingsent = 0;
- } elsif (
- /^:[^ ]+ 352 ${MYNICK} [^ ]+ ([^ ]+) ([^ ]+) [^ ]+ (${MYNICK})/
- ) {
- # refine maximum message length heuristic
- $msgmax = IRCMAX - length(":${3}!${1}\@${2} ${priv}")
- - CRLF;
- } elsif (/^:([^ !#&][^ !]*)![^ \@]+\@[^ ]+ ${priv}(.+)$/) {
- # respond to chan message
- my ($r, $len);
-
- $r = respond($1, $2, @$lists);
- if ($len = length($r)) {
- $r = substr($r,0,$msgmax-1).'-' if $len>$msgmax;
- sendmsg($s, $priv . $r);
- }
- }
- }
-}
-
-sub usage {
- say STDERR "usage: ${0} [-d|-v] [-r] [-t] [-b path] [-e path] [-h host] [-j join] [-p port] [-q path]";
- exit 1;
-}
-
-sub init {
- my ($path_ball, $path_helo, $path_quot);
- my $rssmem;
- my %opts;
-
- @_ = @ARGV;
- while (@_) {
- $_ = shift;
- if (/^-d$/) { logger(LOG_DEBUG) }
- elsif (/^-r$/) { $opts{'rss'} = 1 }
- elsif (/^-t$/) { $opts{'tls'} = 1 }
- elsif (/^-v$/) { logger(LOG_WARN) }
- elsif (@_ < 1) { usage() }
- elsif (/^-b$/) { $path_ball = shift }
- elsif (/^-e$/) { $path_helo = shift }
- elsif (/^-h$/) { $opts{'host'} = shift }
- elsif (/^-j$/) { $opts{'chan'} = '#' . shift }
- elsif (/^-p$/) { $opts{'port'} = shift }
- elsif (/^-q$/) { $path_quot = shift }
- else { usage() }
- }
- $opts{'chan'} //= $DEFAULT_CHAN;
- $opts{'host'} //= $DEFAULT_HOST;
- $opts{'port'} //= DEFAULT_PORT;
- $opts{'rss'} //= DEFAULT_RSS;
- $opts{'tls'} //= DEFAULT_TLS;
- open(my $ball_file, '<', $path_ball // $DEFAULT_PATH_BALL)
- or die "couldn't open ${path_ball}: $!";
- chomp(my @ball = <$ball_file>);
- close $ball_file or die "${ball_file}: $!";
- open(my $helo_file, '<', $path_helo // $DEFAULT_PATH_HELO)
- or die "couldn't open ${path_helo}: $!";
- chomp(my @helo = <$helo_file>);
- close $helo_file or die "${helo_file}: $!";
- open(my $quot_file, '<', $path_quot // $DEFAULT_PATH_QUOT)
- or die "couldn't open ${path_quot}: $!";
- chomp(my @quot = <$quot_file>);
- close $quot_file or die "${quot_file}: $!";
- if ($opts{'rss'}) {
- open($rssmem, '+>>', $RSSMEM_PATH)
- || die "couldn't open ${RSSMEM_PATH}: $!";
- }
- return $rssmem, \%opts, [
- \@ball,
- \@helo,
- \@quot,
- ];
-}
-
-my ($rssmem, $opts, $lists) = init();
-
-while (1) {
- my ($sock, $addr);
-
- $addr = "$opts->{'host'}:$opts->{'port'}";
- if ($opts->{'tls'}) {
- $sock = IO::Socket::SSL->new(PeerAddr => $addr,
- Timeout => CONNECT_TIMEOUT);
- } else {
- $sock = IO::Socket::INET->new(PeerAddr => $addr,
- Timeout => CONNECT_TIMEOUT);
- }
- if ($sock) {
- my $s;
-
- $s = IO::Select->new($sock);
- sendmsg($s, "USER ${MYUSER} * * :${MYREAL}");
- sendmsg($s, "NICK ${MYNICK}");
- sendmsg($s, "WHO ${MYNICK}");
- sendmsg($s, "JOIN $opts->{'chan'}");
- evasdrop($s, $rssmem, $lists, @$opts{'chan', 'host', 'rss'});
- sendmsg($s, 'QUIT');
- $sock->close();
- } else {
- logger(LOG_ERROR, "cannot make socket: ${IO::Socket::errstr}");
- }
- logger(LOG_WARN, "reconnecting in ".RECONN_SLEEP." seconds...");
- sleep RECONN_SLEEP;
-}
blob - /dev/null
blob + 7ae4d09317a961dd6028db9384ccd6f4abd07b84 (mode 755)
--- /dev/null
+++ matabot.pl
+#!/usr/bin/perl
+use v5.42;
+
+use HTTP::Tiny;
+use IO::Select;
+use IO::Socket qw(AF_INET SOCK_STREAM);
+use IO::Socket::SSL;
+
+use constant {
+ LOG_ERROR => 0,
+ LOG_WARN => 1,
+ LOG_DEBUG => 2,
+ CONNECT_TIMEOUT => 60,
+ CRLF => 2, # RFC 2812
+ DEFAULT_PORT => 6667,
+ DEFAULT_RSS => 0,
+ DEFAULT_TLS => 0,
+ HOSTMAX => 63, # RFC 2812
+ IRCMAX => 512,
+ LAG_CHECK_TIME => 120,
+ MAX_LAG => 300,
+ NBIBLE => 31102,
+ NQURAN => 6348,
+ RECONN_SLEEP => 60,
+ RSS_CHECK_TIME => 3600,
+ SOCK_TIMEOUT => 10,
+};
+my $DEFAULT_CHAN = '#testmatabot';
+my $DEFAULT_HOST = 'localhost';
+my $DEFAULT_PATH_BALL = '/usr/local/share/matabot/ball';
+my $DEFAULT_PATH_HELO = '/usr/local/share/matabot/hellos';
+my $DEFAULT_PATH_QUOT = '/usr/local/share/matabot/quotes';
+my $FCUTE = '[>.<]';
+my $FDEAD = '[x~x]';
+my $FFLIP = 't[-_-t]';
+my $FGLAD = '[^_^]';
+my $FNORM = '[._.]';
+my $FSING = '[^=^]';
+my $MOM = 'noodle';
+my $MYNICK = 'mata_bot';
+my $MYREAL = 'death to technomage!!';
+my $MYUSER = 'mata_bot_beta4';
+my $NICKRE = qr/mata_?bo[ity]+/i;
+my $RSSLINK = 'https://analognowhere.com/feed/rss.xml';
+my $RSSMEM_PATH = 'rss';
+
+sub randint {
+ my($min, $max) = @_;
+
+ return $min if $min == $max;
+ ($min, $max) = ($max, $min) if $min > $max;
+ return $min + int rand(1 + $max - $min);
+}
+
+sub strip {
+ my $s = shift;
+ return trim($s =~ tr/\0\r\n//dr);
+}
+
+sub replycmd {
+ my ($ball, $helo, $nick, $content) = @_;
+ my ($ismom, $reply);
+
+ $nick = 'mother' if $ismom = $nick eq $MOM;
+ $_ = $content;
+ if (/\b{wb}([1-9][0-9]*)?d([1-9][0-9]*)\b{wb}/) {
+ my ($ndice, $nface, $n, $roll);
+
+ ($ndice, $nface) = ($1 // 1, $2);
+ $n = randint($ndice, $ndice*$nface);
+ $roll = ($ndice > 1 ? $ndice : '') . 'd' . $nface;
+ $reply = "${nick} rolled a ${roll} and got ${n}! ${FGLAD}";
+ } elsif (/pray/i) {
+ $reply = "Stay prayed up!! ${FCUTE}";
+ } elsif (not $ismom and /\b{wb}bru[hv]+\b{wb}/i) {
+ $reply = "Did i stutter? ${FNORM}";
+ } elsif (not $ismom and /\b{wb}f+(u?ck+)? *(yo)?u+\b{wb}/in) {
+ $reply = $FFLIP;
+ } elsif (/\b{wb}i+ *l+(ove+)? *(you+|y+|u+)\b{wb}|<3/in) {
+ $reply = "<3 ${FGLAD}";
+ } elsif (/(thanks+|thx+|thank +(yo)?u+)( *a+ *lot+)?/in) {
+ $reply = "You're welcome, ${nick}! ${FGLAD}";
+ } elsif (/
+ who(('|\s+i)?s+)?\s+(a|the)+\s+goo+d+\s+(bo+[ity]+o*|gi+r+l+(i+e+)?)
+ /inx) {
+ $reply = "Me! ${FCUTE}";
+ } elsif (/
+ h(ow+)?\s*(are+|r+)\s*(you+|yo+|u+)(\s+doing+)?(\s+today+)?|
+ how('|\si|)s+\s+(it+\s+going+|life+|everything+)
+ /inx) {
+ $reply = "I feel fantaaaastic... hey, hey, hey! ${FSING}";
+ } elsif (/
+ \b{wb}(
+ what('|\si|)s+\s*(up+|happening+|cracking+)|
+ (was)?sup+
+ )\b{wb}
+ /inx) {
+ $reply = "Looking for technomage, and you? ${FNORM}";
+ } elsif (/\?$/) {
+ $reply = "$ball->[rand @$ball] ${FCUTE}";
+ } elsif (/
+ \b{wb}(
+ goo+d+\s*(bo+[ity]+o*|gir(l+|lie+))|
+ w(elcome+)?\s*(b+|back+)
+ )\b{wb}
+ /inx) {
+ $reply = "Thank you, ${nick}! ${FGLAD}";
+ } elsif (/
+ \b{wb}(
+ (a[ls]+-?)?sala+m+u*\s*['3a]lai+kum+u*|
+ ay+|
+ g('day+|oo+d\s+(day+|morning+|afternoo+n+|evening+))|
+ greetings+|
+ h(([aeo](i+|llo+)|ey+|i+(ya+)?)(\s+there+)?|owdy+)|
+ hail+|
+ (morn|even)ings+|
+ noo+nafters+|
+ oi+|
+ salutations+|
+ well+\s+met+|
+ yo+
+ )\b{wb}
+ /inx) {
+ $reply = "$helo->[rand @$helo], ${nick}! ${FGLAD}";
+ } elsif (/a+l{2,}a+h|g[o-]d/i) {
+ my ($book, $n, $r);
+
+ $book = $& =~ /^a/ ? 'quran' : 'bible';
+ $n = randint(1, $book eq 'quran' ? NQURAN : NBIBLE);
+ $r = HTTP::Tiny->new->get("https://triapul.cz/files/${book}/${n}");
+ if ($r->{success}) {
+ $reply = strip($r->{content});
+ } elsif ($book eq 'quran') {
+ $reply = "Allah will not any answer prayers until the server fixes it's polytheist ways!! ${FCUTE}";
+ } else {
+ $reply = "God is Dead!! ${FCUTE}";
+ }
+ } elsif ($ismom) {
+ $reply = "Done, mother! ${FGLAD}";
+ } else {
+ $reply = "\1ACTION leans over and places its hand near its antenna. \"HUUH?\" ${FNORM}\1";
+ }
+ return $reply;
+}
+
+sub replyhil {
+ my ($quotes, $nick, $msg) = @_;
+
+ if ($nick eq $MOM) {
+ return "Yes, mother? ${FGLAD}";
+ } elsif ($msg =~ /^${NICKRE}\W*$/) {
+ return "${FNORM} ?";
+ } else {
+ return "$quotes->[rand @$quotes] ${FNORM}";
+ }
+}
+
+sub respond {
+ state %lastmsg;
+ my ($nick, $msg, ($ball, $helo, $quot)) = @_;
+ my $reply;
+
+ $reply = '';
+ $_ = $msg;
+ if (m,\b{wb}s/([^/]+)/([^/]*)(?:/([gi]*))?,) {
+ # chat s///
+ my ($didsub, $imod, $mods, $regex, $retext, $repl);
+
+ $lastmsg{$nick} or return '';
+ ($retext, $repl, $mods) = ($1, $2, $3 // '');
+ $imod = $mods =~ /i/ ? 'i' : '';
+ eval { $regex = qr/(?$imod:$retext)/ } or return '';
+ if ($mods =~ /g/) {
+ $didsub = $lastmsg{$nick} =~ s/$regex/$repl/g;
+ } else {
+ $didsub = $lastmsg{$nick} =~ s/$regex/$repl/;
+ }
+ $reply = "${nick} meant to say: $lastmsg{$nick}" if $didsub;
+ return $reply;
+ }
+ $lastmsg{$nick} = $msg;
+ if (m,watch\?v=([a-zA-Z0-9_-]+),) {
+ # post youtube video title from ID
+ my ($id, $q, $r);
+
+ $id = $1;
+ $q = "?s=https%3A//youtube.com/watch%3Fv%3D${1}&o=relevance";
+ $r = HTTP::Tiny->new->get("https://fuyt.lab8.cz/${q}");
+ unless ($r->{success}) {
+ return "${1}: $r->{status} $r->{reason}! ${FDEAD}";
+ }
+ unless (length $r->{content}) {
+ return "${1}: empty HTTP response! ${FDEAD}";
+ }
+ unless ($r->{content} =~ m,
+ <span\sclass="title">
+ <a\shref="https://www\.youtube\.com/watch\?v=${id}"
+ \saccesskey="0">([^<]+)</a>
+ ,ix) {
+ return "${1}: no video matching ID found! ${FDEAD}";
+ }
+ $reply = 'YouTube: ' . strip($1);
+ } elsif (
+ m,https?://([^ /]*[^ ./0-9][^ /]*\.)+[^ /]*[^ ./0-9][^ /]*(/[^ ]*)?,n
+ ) {
+ # post website title for text/html or mimetype otherwise
+ my ($r, $url);
+
+ $url = $&;
+ $r = HTTP::Tiny->new->head($url);
+ unless ($r->{success}) {
+ return "HEAD ${url}: $r->{status} $r->{reason}! ${FDEAD}";
+ }
+ unless ($r->{headers}->{'content-type'}) {
+ return "HEAD ${url}: empty MIME type! ${FDEAD}";
+ }
+ unless ($r->{headers}->{'content-type'} =~ m,text/html,) {
+ return "File: $r->{headers}->{'content-type'}";
+ }
+ $r = HTTP::Tiny->new->get($url);
+ unless ($r->{success}) {
+ return "GET ${url}: $r->{status} $r->{reason}! ${FDEAD}";
+ }
+ unless ($r->{content}) {
+ return "GET ${url}: empty HTTP response! ${FDEAD}";
+ }
+ unless ($r->{content} =~ m,<title[^>]*>([^<]+)</title[^>]*>,i) {
+ return "GET ${url}: no title found! ${FDEAD}";
+ }
+ $reply = 'Title: ' . strip($1);
+ } elsif (/^ *${NICKRE}[:, ] *(\W?[^ \W].*)$/
+ or /^ *([^ ].*)[, ] *${NICKRE}([\W\d]*)$/) {
+ $reply = replycmd($ball, $helo, $nick, $1 . ($2//''));
+ } elsif (/\b${NICKRE}\b/) {
+ $reply = replyhil($quot, $nick, $msg);
+ }
+ return $reply;
+}
+
+sub logger {
+ state $loglevel = LOG_ERROR;
+ my ($level, $msg) = @_;
+
+ if ($msg) {
+ say STDERR $msg if $loglevel >= $level
+ } else {
+ $loglevel = $level;
+ }
+}
+
+sub sendmsg {
+ my ($s, $msg) = @_;
+ my $sock;
+
+ $! = 0;
+ unless (($sock) = $s->can_write(SOCK_TIMEOUT)) {
+ if ($!) { logger(LOG_ERROR, $!) }
+ else { logger(LOG_WARN, "sock not ready to write") }
+ return 0;
+ }
+ print $sock $msg . "\r\n";
+ logger(LOG_DEBUG, "<- " . $msg);
+ return 1;
+}
+
+sub recvmsg {
+ state $buf = '';
+ my $s = shift;
+
+ while(1) {
+ my ($line, $sock);
+
+ $_ = $buf;
+ if (not length) {
+ } elsif (/\A([^\0\n\r]+)\r\n(.+)?\z/s) {
+ logger(LOG_DEBUG, "-> " . $1);
+ $buf = $2 // '';
+ return $1;
+ } elsif (/\n\n|\n\r|\r\r|\r[^\n\r]|[^\n\r]\n/) {
+ logger(LOG_ERROR, 'recieved a malformed message');
+ return undef;
+ }
+ # read a line
+ $! = 0;
+ unless (($sock) = $s->can_read(SOCK_TIMEOUT)) {
+ if ($!) {
+ logger(LOG_ERROR, $!);
+ return undef;
+ }
+ return '';
+ }
+ unless (length($line = <$sock>) > 0) {
+ if ($!) { logger(LOG_ERROR, $!) }
+ else { logger(LOG_WARN, 'recieved an empty message') }
+ return undef;
+ }
+ $buf .= $line;
+ }
+}
+
+sub sendnews {
+ state $lastlink;
+ my $rssmem = shift;
+ my ($homepage, $r);
+ my (@matches, @replies);
+
+ $r = HTTP::Tiny->new->get($RSSLINK);
+ unless ($r->{success}) {
+ logger(LOG_WARN, 'GET ${RSSLINK}: $r->{status} $r->{reason}');
+ return ();
+ }
+ unless (length $r->{content}) {
+ logger(LOG_WARN, 'GET ${RSSLINK}: empty HTTP response');
+ return ();
+ }
+ unless (defined($lastlink)) {
+ seek($rssmem, 0, 0);
+ chomp($lastlink = <$rssmem>);
+ }
+ $homepage = ($r->{content} =~ m,<channel>.*?<link>([^<]+)</link>,s) ? $1 : 'website';
+ while ($r->{content} =~ m,\G.*?<item>.*?<title>([^<]+)</title>.*?<link>([^<]+)</link>.*?</item>,gs) {
+ push @matches, {title => $1, link => $2};
+ }
+ if (@matches) {
+ my $i;
+
+ if (defined($lastlink)) {
+ for ($i = 0; $i < @matches; $i++) {
+ last if $matches[$i]->{'link'} eq $lastlink;
+ }
+ } else {
+ $i = @matches;
+ }
+ for ($i--; $i >= 0; $i--) {
+ push @replies, "RSS: $matches[$i]->{'link'} | $matches[$i]->{'title'}";
+ if ($i > 2) {
+ push @replies, "RSS: found " . ($i-1) . " new items in between. Visit ${homepage} for more...";
+ $i = 1;
+ }
+ }
+ truncate($rssmem, 0);
+ seek($rssmem, 0, 0);
+ say $rssmem ($lastlink = $matches[0]->{'link'});
+ $rssmem->flush;
+ }
+ return @replies;
+}
+
+sub evasdrop {
+ my ($s, $rssmem, $lists, ($chan, $host, $rss)) = @_;
+ my ($firstrss, $msgmax, $msgtime, $pingsent, $pingtime, $priv, $rsstime);
+
+ $firstrss = 1;
+ $pingsent = 0;
+ $priv = "PRIVMSG ${chan} :";
+ $msgmax = IRCMAX - length(":${MYNICK}!~${MYUSER}\@ ${priv}")
+ - HOSTMAX - CRLF; # conservative max message length heuristic
+ $rsstime = $msgtime = $pingtime = time;
+ while (1) {
+ if ($pingsent) {
+ if (time - $pingtime > MAX_LAG) {
+ # leave if we don't get ponged back on time
+ logger(LOG_WARN, 'server pong reply timed out');
+ return;
+ }
+ } elsif (time - $msgtime > LAG_CHECK_TIME) {
+ # ping server every once in a while
+ sendmsg($s, "PING :${host}");
+ $pingsent = 1;
+ $pingtime = time;
+ }
+ if ($rss and ($firstrss || time - $rsstime > RSS_CHECK_TIME)) {
+ foreach (sendnews($rssmem)) {
+ sendmsg($s, $priv . substr($_,0,$msgmax));
+ }
+ $rsstime = time;
+ $firstrss = 0 if $firstrss;
+ }
+ defined($_ = recvmsg($s)) or return;
+ next if not length;
+ $msgtime = time;
+ if (/^PING :([^ ]+)$/) {
+ sendmsg($s, 'PONG :' . $1);
+ } elsif (/^:[^ ]+ PONG/) {
+ $pingsent = 0;
+ } elsif (
+ /^:[^ ]+ 352 ${MYNICK} [^ ]+ ([^ ]+) ([^ ]+) [^ ]+ (${MYNICK})/
+ ) {
+ # refine maximum message length heuristic
+ $msgmax = IRCMAX - length(":${3}!${1}\@${2} ${priv}")
+ - CRLF;
+ } elsif (/^:([^ !#&][^ !]*)![^ \@]+\@[^ ]+ ${priv}(.+)$/) {
+ # respond to chan message
+ my ($r, $len);
+
+ $r = respond($1, $2, @$lists);
+ if ($len = length($r)) {
+ $r = substr($r,0,$msgmax-1).'-' if $len>$msgmax;
+ sendmsg($s, $priv . $r);
+ }
+ }
+ }
+}
+
+sub usage {
+ say STDERR "usage: ${0} [-d|-v] [-r] [-t] [-b path] [-e path] [-h host] [-j join] [-p port] [-q path]";
+ exit 1;
+}
+
+sub init {
+ my ($path_ball, $path_helo, $path_quot);
+ my $rssmem;
+ my %opts;
+
+ @_ = @ARGV;
+ while (@_) {
+ $_ = shift;
+ if (/^-d$/) { logger(LOG_DEBUG) }
+ elsif (/^-r$/) { $opts{'rss'} = 1 }
+ elsif (/^-t$/) { $opts{'tls'} = 1 }
+ elsif (/^-v$/) { logger(LOG_WARN) }
+ elsif (@_ < 1) { usage() }
+ elsif (/^-b$/) { $path_ball = shift }
+ elsif (/^-e$/) { $path_helo = shift }
+ elsif (/^-h$/) { $opts{'host'} = shift }
+ elsif (/^-j$/) { $opts{'chan'} = '#' . shift }
+ elsif (/^-p$/) { $opts{'port'} = shift }
+ elsif (/^-q$/) { $path_quot = shift }
+ else { usage() }
+ }
+ $opts{'chan'} //= $DEFAULT_CHAN;
+ $opts{'host'} //= $DEFAULT_HOST;
+ $opts{'port'} //= DEFAULT_PORT;
+ $opts{'rss'} //= DEFAULT_RSS;
+ $opts{'tls'} //= DEFAULT_TLS;
+ open(my $ball_file, '<', $path_ball // $DEFAULT_PATH_BALL)
+ or die "couldn't open ${path_ball}: $!";
+ chomp(my @ball = <$ball_file>);
+ close $ball_file or die "${ball_file}: $!";
+ open(my $helo_file, '<', $path_helo // $DEFAULT_PATH_HELO)
+ or die "couldn't open ${path_helo}: $!";
+ chomp(my @helo = <$helo_file>);
+ close $helo_file or die "${helo_file}: $!";
+ open(my $quot_file, '<', $path_quot // $DEFAULT_PATH_QUOT)
+ or die "couldn't open ${path_quot}: $!";
+ chomp(my @quot = <$quot_file>);
+ close $quot_file or die "${quot_file}: $!";
+ if ($opts{'rss'}) {
+ open($rssmem, '+>>', $RSSMEM_PATH)
+ || die "couldn't open ${RSSMEM_PATH}: $!";
+ }
+ return $rssmem, \%opts, [
+ \@ball,
+ \@helo,
+ \@quot,
+ ];
+}
+
+my ($rssmem, $opts, $lists) = init();
+
+while (1) {
+ my ($sock, $addr);
+
+ $addr = "$opts->{'host'}:$opts->{'port'}";
+ if ($opts->{'tls'}) {
+ $sock = IO::Socket::SSL->new(PeerAddr => $addr,
+ Timeout => CONNECT_TIMEOUT);
+ } else {
+ $sock = IO::Socket::INET->new(PeerAddr => $addr,
+ Timeout => CONNECT_TIMEOUT);
+ }
+ if ($sock) {
+ my $s;
+
+ $s = IO::Select->new($sock);
+ sendmsg($s, "USER ${MYUSER} * * :${MYREAL}");
+ sendmsg($s, "NICK ${MYNICK}");
+ sendmsg($s, "WHO ${MYNICK}");
+ sendmsg($s, "JOIN $opts->{'chan'}");
+ evasdrop($s, $rssmem, $lists, @$opts{'chan', 'host', 'rss'});
+ sendmsg($s, 'QUIT');
+ $sock->close();
+ } else {
+ logger(LOG_ERROR, "cannot make socket: ${IO::Socket::errstr}");
+ }
+ logger(LOG_WARN, "reconnecting in ".RECONN_SLEEP." seconds...");
+ sleep RECONN_SLEEP;
+}
