eleksir/aleesa-jabber-bot
1
Fork 0
Code Activity

Use more critic! Also for vendored libs too

Browse Source
This commit is contained in:
eleksir
2022-04-03 21:13:21 +03:00
parent f18544a798
commit 7ef4c0e28a
32 changed files with 334 additions and 263 deletions
Download Patch File Download Diff File Expand all files Collapse all files

44
lib/Authen/SASL.pm
View File

@@ -1,14 +1,19 @@
## no critic (Variables::ProhibitPunctuationVars)
# Copyright (c) 2004-2006 Graham Barr <gbarr@pobox.com>. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
package Authen::SASL;
use 5.018; ## no critic (ProhibitImplicitImport)
use strict;
use vars qw($VERSION @Plugins);
use Carp;
use warnings;
use utf8;
$VERSION = "2.16";
use vars qw($VERSION @Plugins); ## no critic (Variables::ProhibitPackageVars)
use Carp qw (croak);
$VERSION = '2.16';
@Plugins = qw(
Authen::SASL::XS
@@ -21,9 +26,10 @@ sub import {
shift;
return unless @_;
local $SIG{__DIE__};
@Plugins = grep { /^[:\w]+$/ and eval "require $_" } map { /::/ ? $_ : "Authen::SASL::$_" } @_
or croak "no valid Authen::SASL plugins found";
local $SIG{__DIE__}; ## no critic (Variables::RequireInitializationForLocalVars)
@Plugins = grep { /^[:\w]+$/ and eval "require $_" } map { /::/ ? $_ : "Authen::SASL::$_" } @_ ## no critic (BuiltinFunctions::ProhibitStringyEval)
or croak 'no valid Authen::SASL plugins found';
return;
}
@@ -44,13 +50,13 @@ sub new {
$self->callback(pass => $opt{password}) if exists $opt{password};
$self->callback(pass => $opt{response}) if exists $opt{response};
$self;
return $self;
}
sub mechanism {
my $self = shift;
@_ ? $self->{mechanism} = shift
return @_ ? $self->{mechanism} = shift
: $self->{mechanism};
}
@@ -62,7 +68,7 @@ sub callback {
my %new = @_;
@{$self->{callback}}{keys %new} = values %new;
$self->{callback};
return $self->{callback};
}
# The list of packages should not really be hardcoded here
@@ -73,7 +79,7 @@ sub client_new { # $self, $service, $host, $secflags
my $err;
foreach my $pkg (@Plugins) {
if (eval "require $pkg" and $pkg->can("client_new")) {
if (eval "require $pkg" and $pkg->can('client_new')) { ## no critic (BuiltinFunctions::ProhibitStringyEval)
if ($self->{conn} = eval { $pkg->client_new($self, @_) }) {
return $self->{conn};
}
@@ -81,7 +87,7 @@ sub client_new { # $self, $service, $host, $secflags
}
}
croak $err || "Cannot find a SASL Connection library";
croak $err || 'Cannot find a SASL Connection library';
}
sub server_new { # $self, $service, $host, $secflags
@@ -89,19 +95,19 @@ sub server_new { # $self, $service, $host, $secflags
my $err;
foreach my $pkg (@Plugins) {
if (eval "require $pkg" and $pkg->can("server_new")) {
if (eval "require $pkg" and $pkg->can('server_new')) { ## no critic (BuiltinFunctions::ProhibitStringyEval)
if ($self->{conn} = eval { $pkg->server_new($self, @_) } ) {
return $self->{conn};
}
$err = $@;
$err = $@; ## no critic (Variables::ProhibitPunctuationVars)
}
}
croak $err || "Cannot find a SASL Connection library for server-side authentication";
croak $err || 'Cannot find a SASL Connection library for server-side authentication';
}
sub error {
my $self = shift;
$self->{conn} && $self->{conn}->error;
return $self->{conn} && $self->{conn}->error;
}
# Compat.
@@ -109,22 +115,22 @@ sub user {
my $self = shift;
my $user = $self->{callback}{user};
$self->{callback}{user} = shift if @_;
$user;
return $user;
}
sub challenge {
my $self = shift;
$self->{conn}->client_step(@_);
return $self->{conn}->client_step(@_);
}
sub initial {
my $self = shift;
$self->client_new($self)->client_start;
return $self->client_new($self)->client_start;
}
sub name {
my $self = shift;
$self->{conn} ? $self->{conn}->mechanism : ($self->{mechanism} =~ /(\S+)/)[0];
return $self->{conn} ? $self->{conn}->mechanism : ($self->{mechanism} =~ /(\S+)/)[0];
}
1;

10
lib/Authen/SASL/CRAM_MD5.pm
View File

@@ -4,14 +4,20 @@
package Authen::SASL::CRAM_MD5;
use 5.018; ## no critic (ProhibitImplicitImport)
use warnings;
use strict;
use utf8;
use vars qw($VERSION);
$VERSION = "2.14";
$VERSION = '2.14';
use Authen::SASL ();
sub new {
shift;
Authen::SASL->new(@_, mechanism => 'CRAM-MD5');
return Authen::SASL->new(@_, mechanism => 'CRAM-MD5');
}
1;

9
lib/Authen/SASL/EXTERNAL.pm
View File

@@ -4,14 +4,19 @@
package Authen::SASL::EXTERNAL;
use 5.018; ## no critic (ProhibitImplicitImport)
use strict;
use warnings;
use utf8;
use vars qw($VERSION);
$VERSION = "2.14";
$VERSION = '2.14';
use Authen::SASL ();
sub new {
shift;
Authen::SASL->new(@_, mechanism => 'EXTERNAL');
return Authen::SASL->new(@_, mechanism => 'EXTERNAL');
}
1;

17
lib/Authen/SASL/Perl/ANONYMOUS.pm
View File

@@ -1,33 +1,38 @@
## no critic (ClassHierarchies::ProhibitExplicitISA, Documentation::RequirePODUseEncodingUTF8, Documentation::RequirePodSections)
# Copyright (c) 2002 Graham Barr <gbarr@pobox.com>. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
package Authen::SASL::Perl::ANONYMOUS;
use 5.018; ## no critic (ProhibitImplicitImport)
use strict;
use warnings;
use utf8;
use vars qw($VERSION @ISA);
$VERSION = "2.14";
$VERSION = '2.14';
@ISA = qw(Authen::SASL::Perl);
my %secflags = (
noplaintext => 1,
);
sub _order { 0 }
sub _order { return 0 }
sub _secflags {
shift;
grep { $secflags{$_} } @_;
return grep { $secflags{$_} } @_;
}
sub mechanism { 'ANONYMOUS' }
sub mechanism { return 'ANONYMOUS' }
sub client_start {
shift->_call('authname')
return shift->_call('authname');
}
sub client_step {
shift->_call('authname')
return shift->_call('authname');
}
1;

17
lib/Authen/SASL/Perl/CRAM_MD5.pm
View File

@@ -1,14 +1,19 @@
## no critic (ClassHierarchies::ProhibitExplicitISA, Documentation::RequirePodSections, Documentation::RequirePODUseEncodingUTF8)
# Copyright (c) 2002 Graham Barr <gbarr@pobox.com>. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
package Authen::SASL::Perl::CRAM_MD5;
use 5.018; ## no critic (ProhibitImplicitImport)
use strict;
use warnings;
use utf8;
use vars qw($VERSION @ISA);
use Digest::HMAC_MD5 qw(hmac_md5_hex);
$VERSION = "2.14";
$VERSION = '2.14';
@ISA = qw(Authen::SASL::Perl);
my %secflags = (
@@ -16,16 +21,16 @@ my %secflags = (
noanonymous => 1,
);
sub _order { 2 }
sub _order { return 2 }
sub _secflags {
shift;
scalar grep { $secflags{$_} } @_;
return scalar grep { $secflags{$_} } @_;
}
sub mechanism { 'CRAM-MD5' }
sub mechanism { return 'CRAM-MD5' }
sub client_start {
'';
return '';
}
sub client_step {
@@ -35,7 +40,7 @@ sub client_step {
defined($v) ? $v : ''
} qw(user pass);
$user . " " . hmac_md5_hex($string,$pass);
return $user . ' ' . hmac_md5_hex($string,$pass);
}
1;

143
lib/Authen/SASL/Perl/DIGEST_MD5.pm
View File

@@ -1,3 +1,4 @@
## no critic (Documentation::RequirePodSections, Documentation::RequirePODUseEncodingUTF8)
# Copyright (c) 2003-2009 Graham Barr, Djamel Boudjerda, Paul Connolly, Julian
# Onions, Nexor and Yann Kerherve.
# All rights reserved. This program is free software; you can redistribute
@@ -7,15 +8,20 @@
package Authen::SASL::Perl::DIGEST_MD5;
use 5.018; ## no critic (ProhibitImplicitImport)
use strict;
use warnings;
use utf8;
use vars qw($VERSION @ISA $CNONCE $NONCE);
use Digest::MD5 qw(md5_hex md5);
use Digest::HMAC_MD5 qw(hmac_md5);
use Crypt::RC4 ();
# TODO: complete qop support in server, should be configurable
$VERSION = "2.14";
@ISA = qw(Authen::SASL::Perl);
$VERSION = '2.14';
@ISA = qw(Authen::SASL::Perl); ## no critic (ClassHierarchies::ProhibitExplicitISA)
my %secflags = (
noplaintext => 1,
@@ -56,7 +62,7 @@ my @ourciphers = (
sub { goto &Crypt::RC4::RC4; };
*Crypt::RC4::keysize = sub {128};
*Crypt::RC4::blocksize = sub {1};
}
},
},
{
name => '3des',
@@ -99,7 +105,7 @@ my @ourciphers = (
sub { goto &Crypt::RC4::RC4; };
*Crypt::RC4::keysize = sub {56};
*Crypt::RC4::blocksize = sub {1};
}
},
},
{
name => 'rc4-40',
@@ -114,27 +120,27 @@ my @ourciphers = (
sub { goto &Crypt::RC4::RC4; };
*Crypt::RC4::keysize = sub {40};
*Crypt::RC4::blocksize = sub {1};
}
},
},
);
## The system we are on, might not be able to crypt the stream
our $NO_CRYPT_AVAILABLE = 1;
for (@ourciphers) {
eval "require $_->{pkg}";
unless ($@) {
eval "require $_->{pkg}"; ## no critic (BuiltinFunctions::ProhibitStringyEval)
unless ($@) { ## no critic (Variables::ProhibitPunctuationVars)
$NO_CRYPT_AVAILABLE = 0;
last;
}
}
sub _order { 3 }
sub _order { return 3 }
sub _secflags {
shift;
scalar grep { $secflags{$_} } @_;
return scalar grep { $secflags{$_} } @_;
}
sub mechanism { 'DIGEST-MD5' }
sub mechanism { return 'DIGEST-MD5' }
sub _init {
my ($pkg, $self) = @_;
@@ -146,14 +152,14 @@ sub _init {
$self->property('maxbuf', 0xFFFFFF); # maximum supported by GSSAPI mech
$self->property('externalssf', 0);
$self;
return $self;
}
sub _init_server {
my $server = shift;
my $options = shift || {};
if (!ref $options or ref $options ne 'HASH') {
warn "options for DIGEST_MD5 should be a hashref";
if (!ref $options || ref $options ne 'HASH') {
warn 'options for DIGEST_MD5 should be a hashref'; ## no critic (ErrorHandling::RequireCarping)
$options = {};
}
@@ -167,7 +173,7 @@ sub _init_server {
or $options->{no_confidentiality}
or $NO_CRYPT_AVAILABLE;
$server->{supported_qop} = { map { $_ => 1 } @qop };
return $server->{supported_qop} = { map { $_ => 1 } @qop };
}
sub init_sec_layer {
@@ -181,6 +187,7 @@ sub init_sec_layer {
# reset properties for new session
$self->property(maxout => undef);
$self->property(ssf => undef);
return;
}
# no initial value passed to the server
@@ -191,7 +198,7 @@ sub client_start {
$self->{error} = undef;
$self->{state} = 0;
$self->init_sec_layer;
'';
return '';
}
sub server_start {
@@ -201,7 +208,7 @@ sub server_start {
$self->{need_step} = 1;
$self->{error} = undef;
$self->{nonce} = md5_hex($NONCE || join (":", $$, time, rand));
$self->{nonce} = md5_hex($NONCE || join (':', $$, time, rand)); ## no critic (Variables::ProhibitPunctuationVars)
$self->init_sec_layer;
@@ -243,9 +250,9 @@ sub client_step { # $self, $server_sasl_credentials
if ($self->{state} == 1) {
# check server's `rspauth' response
return $self->set_error("Server did not send rspauth in step 2")
return $self->set_error('Server did not send rspauth in step 2')
unless ($sparams{rspauth});
return $self->set_error("Invalid rspauth in step 2")
return $self->set_error('Invalid rspauth in step 2')
unless ($self->{rspauth} eq $sparams{rspauth});
# all is well
@@ -255,15 +262,15 @@ sub client_step { # $self, $server_sasl_credentials
# check required fields in server challenge
if (my @missing = grep { !exists $sparams{$_} } @server_required) {
return $self->set_error("Server did not provide required field(s): @missing")
return $self->set_error("Server did not provide required field(s): @missing");
}
my %response = (
nonce => $sparams{'nonce'},
cnonce => md5_hex($CNONCE || join (":", $$, time, rand)),
cnonce => md5_hex($CNONCE || join (':', $$, time, rand)), ## no critic (Variables::ProhibitPunctuationVars)
'digest-uri' => $self->service . '/' . $self->host,
# calc how often the server nonce has been seen; server expects "00000001"
nc => sprintf("%08d", ++$self->{nonce_counts}{$sparams{'nonce'}}),
nc => sprintf('%08d', ++$self->{nonce_counts}{$sparams{'nonce'}}),
charset => $sparams{'charset'},
);
@@ -273,7 +280,7 @@ sub client_step { # $self, $server_sasl_credentials
# let caller-provided fields override defaults: authorization ID, service name, realm
my $s_realm = $sparams{realm} || [];
my $realm = $self->_call('realm', @$s_realm);
my $realm = $self->_call('realm', @{$s_realm});
unless (defined $realm) {
# If the user does not pick a realm, use the first from the server
$realm = $s_realm->[0];
@@ -293,12 +300,12 @@ sub client_step { # $self, $server_sasl_credentials
}
my $user = $self->_call('user');
return $self->set_error("Username is required")
return $self->set_error('Username is required')
unless defined $user;
$response{username} = $user;
my $password = $self->_call('pass');
return $self->set_error("Password is required")
return $self->set_error('Password is required')
unless defined $password;
$self->property('maxout', $sparams{maxbuf} || 65536);
@@ -313,7 +320,7 @@ sub client_step { # $self, $server_sasl_credentials
$self->{rspauth} = $rspauth;
# finally, return our response token
return _response(\%response, "is_client");
return _response(\%response, 'is_client');
}
sub _compute_digests_and_set_keys {
@@ -326,18 +333,18 @@ sub _compute_digests_and_set_keys {
}
my $realm = $params->{realm};
$realm = "" unless defined $realm;
$realm = '' unless defined $realm;
my $A1 = join (":",
md5(join (":", $params->{username}, $realm, $password)),
@$params{defined($params->{authzid})
my $A1 = join (':',
md5(join (':', $params->{username}, $realm, $password)),
@{$params{defined($params->{authzid})
? qw(nonce cnonce authzid)
: qw(nonce cnonce)
}
}},
);
# pre-compute MD5(A1) and HEX(MD5(A1)); these are used multiple times below
my $hdA1 = unpack("H*", (my $dA1 = md5($A1)) );
my $hdA1 = unpack('H*', (my $dA1 = md5($A1)) );
# derive keys for layer encryption / integrity
$self->{kic} = md5($dA1,
@@ -365,21 +372,21 @@ sub _compute_digests_and_set_keys {
$self->{ivs} = $cipher->{iv}->($self->{kcs});
}
my $A2 = "AUTHENTICATE:" . $params->{'digest-uri'};
$A2 .= ":00000000000000000000000000000000" if ($params->{qop} ne 'auth');
my $A2 = 'AUTHENTICATE:' . $params->{'digest-uri'};
$A2 .= ':00000000000000000000000000000000' if ($params->{qop} ne 'auth');
my $response = md5_hex(
join (":", $hdA1, @$params{qw(nonce nc cnonce qop)}, md5_hex($A2))
join (':', $hdA1, @{$params{qw(nonce nc cnonce qop)}}, md5_hex($A2)),
);
# calculate server `rspauth' response, so we can check in step 2
# the only difference here is in the A2 string which from which
# `AUTHENTICATE' is omitted in the calculation of `rspauth'
$A2 = ":" . $params->{'digest-uri'};
$A2 .= ":00000000000000000000000000000000" if ($params->{qop} ne 'auth');
$A2 = ':' . $params->{'digest-uri'};
$A2 .= ':00000000000000000000000000000000' if ($params->{qop} ne 'auth');
my $rspauth = md5_hex(
join (":", $hdA1, @$params{qw(nonce nc cnonce qop)}, md5_hex($A2))
join (':', $hdA1, @{$params{qw(nonce nc cnonce qop)}}, md5_hex($A2)),
);
return ($response, $rspauth);
@@ -408,7 +415,7 @@ sub server_step {
return $cb->();
}
my $qop = $cparams{'qop'} || "auth";
my $qop = $cparams{'qop'} || 'auth';
unless ($self->is_qop_supported($qop)) {
$self->set_error("Client qop not supported (qop = '$qop')");
return $cb->();
@@ -416,13 +423,13 @@ sub server_step {
my $username = $cparams{'username'};
unless ($username) {
$self->set_error("Client didn't provide a username");
$self->set_error('Client didn\'t provide a username');
return $cb->();
}
# "The authzid MUST NOT be an empty string."
if (exists $cparams{authzid} && $cparams{authzid} eq '') {
$self->set_error("authzid cannot be empty");
$self->set_error('authzid cannot be empty');
return $cb->();
}
my $authzid = $cparams{authzid};
@@ -431,15 +438,15 @@ sub server_step {
# This will detect accidental connection to the incorrect server, as well as
# some redirection attacks"
my $digest_uri = $cparams{'digest-uri'};
my ($cservice, $chost, $cservname) = split '/', $digest_uri, 3;
my ($cservice, $chost, $cservname) = split /\//, $digest_uri, 3;
if ($cservice ne $self->service or $chost ne $self->host) {
# XXX deal with serv_name
$self->set_error("Incorrect digest-uri");
return $cb->();
$self->set_error('Incorrect digest-uri');
return $cb->();
}
unless (defined $self->callback('getsecret')) {
$self->set_error("a getsecret callback MUST be defined");
$self->set_error('a getsecret callback MUST be defined');
$cb->();
return;
}
@@ -447,31 +454,31 @@ sub server_step {
my $realm = $self->{client_params}->{'realm'};
my $response_check = sub {
my $password = shift;
return $self->set_error("Cannot get the passord for $username")
return $self->set_error("Cannot get the passord for $username")
unless defined $password;
## configure the security layer
$self->_server_layer($qop)
or return $self->set_error("Cannot negociate the security layer");
or return $self->set_error('Cannot negociate the security layer');
my ($expected, $rspauth)
= $self->_compute_digests_and_set_keys($password, $self->{client_params});
return $self->set_error("Incorrect response $self->{client_params}->{response} <> $expected")
unless $expected eq $self->{client_params}->{response};
my %response = (
rspauth => $rspauth,
);
# I'm not entirely sure of what I am doing
$self->{answer}{$_} = $self->{client_params}->{$_} for qw/username authzid realm serv/;
$self->set_success;
return _response(\%response);
};
$self->callback('getsecret')->(
return $self->callback('getsecret')->(
$self,
{ user => $username, realm => $realm, authzid => $authzid },
sub { $cb->( $response_check->( shift ) ) },
@@ -489,7 +496,7 @@ sub _response {
my $is_client = shift;
my @out;
for my $k (sort keys %$response) {
for my $k (sort keys %{$response}) {
my $is_array = ref $response->{$k} && ref $response->{$k} eq 'ARRAY';
my @values = $is_array ? @{$response->{$k}} : ($response->{$k});
# Per spec, one way of doing it: multiple k=v
@@ -497,7 +504,7 @@ sub _response {
# other way: comma separated list
push @out, [$k, join (',', @values)];
}
return join (",", map { _qdval($_->[0], $_->[1], $is_client) } @out);
return join (',', map { _qdval($_->[0], $_->[1], $is_client) } @out);
}
sub _parse_challenge {
@@ -506,13 +513,13 @@ sub _parse_challenge {
my $type = shift;
my $params = shift;
while($$challenge_ref =~
s/^(?:\s*,)*\s* # remaining or crap
while(${$challenge_ref} =~
s{^(?:\s*,)*\s* # remaining or crap
([\w-]+) # key, eg: qop
=
("([^\\"]+|\\.)*"|[^,]+) # value, eg: auth-conf or "NoNcE"
\s*(?:,\s*)* # remaining
//x) {
}{}x) {
my ($k, $v) = ($1,$2);
if ($v =~ /^"(.*)"$/s) {
@@ -520,7 +527,7 @@ sub _parse_challenge {
}
if (exists $multi{$type}{$k}) {
my $aref = $params->{$k} ||= [];
push @$aref, $v;
push @{$aref}, $v;
}
elsif (defined $params->{$k}) {
return $self->set_error("Bad challenge: '$$challenge_ref'");
@@ -529,7 +536,7 @@ sub _parse_challenge {
$params->{$k} = $v;
}
}
return length $$challenge_ref ? 0 : 1;
return length ${$challenge_ref} ? 0 : 1;
}
sub _qdval {
@@ -585,9 +592,9 @@ sub _client_layer {
# qop in server challenge is optional: if not there "auth" is assumed
my $smask = 0;
map {
m/^auth$/ and $smask |= 1;
m/^auth-int$/ and $smask |= 2;
m/^auth-conf$/ and $smask |= 4;
m/^auth$/ and $smask |= 1; ## no critic (RegularExpressions::ProhibitFixedStringMatches)
m/^auth-int$/ and $smask |= 2; ## no critic (RegularExpressions::ProhibitFixedStringMatches)
m/^auth-conf$/ and $smask |= 4; ## no critic (RegularExpressions::ProhibitFixedStringMatches)
} split(/,/, $sparams->{qop}||'auth'); # XXX I think we might have a bug here bc. of LWS
# construct our qop mask
@@ -639,13 +646,13 @@ sub _select_cipher {
# compose a subset of candidate ciphers based on ssf and peer list
my @a = map {
my $c = $_;
(grep { $c->{name} eq $_ } @$ciphers and
(grep { $c->{name} eq $_ } @{$ciphers} and
$c->{ssf} >= $minssf and $c->{ssf} <= $maxssf) ? $_ : ()
} @ourciphers;
# from these, select the first one we can create an instance of
for (@a) {
next unless eval "require $_->{pkg}";
next unless eval {require $_->{pkg}};
$self->{cipher} = $_;
return 1;
}
@@ -718,14 +725,14 @@ sub _crypt { # input: op(decrypting=1/encrypting=0)), buffer
if ($bs <= 1) {
# stream cipher
return $d ? $self->{khs}->decrypt($_[0]) : $self->{khc}->encrypt($_[0])
return $d ? $self->{khs}->decrypt($_[0]) : $self->{khc}->encrypt($_[0]);
}
# the remainder of this sub is for block ciphers
# get current IV
my $piv = \$self->{$d ? 'ivs' : 'ivc'};
my $iv = $$piv;
my $iv = ${$piv};
my $result = join '', map {
my $x = $d
@@ -736,7 +743,7 @@ sub _crypt { # input: op(decrypting=1/encrypting=0)), buffer
} unpack("a$bs "x(int(length($_[0])/$bs)), $_[0]);
# store current IV
$$piv = $iv;
${$piv} = $iv;
return $result;
}

15
lib/Authen/SASL/Perl/EXTERNAL.pm
View File

@@ -1,3 +1,4 @@
## no critic (ClassHierarchies::ProhibitExplicitISA, Documentation::RequirePodSections, Documentation::RequirePODUseEncodingUTF8)
# Copyright (c) 1998-2002 Graham Barr <gbarr@pobox.com> and 2001 Chris Ridd
# <chris.ridd@isode.com>. All rights reserved. This program
# is free software; you can redistribute it and/or modify it under the
@@ -5,10 +6,14 @@
package Authen::SASL::Perl::EXTERNAL;
use 5.018; ## no critic (ProhibitImplicitImport)
use strict;
use warnings;
use utf8;
use vars qw($VERSION @ISA);
$VERSION = "2.14";
$VERSION = '2.14';
@ISA = qw(Authen::SASL::Perl);
my %secflags = (
@@ -17,18 +22,18 @@ my %secflags = (
noanonymous => 1,
);
sub _order { 2 }
sub _order { return 2 }
sub _secflags {
shift;
grep { $secflags{$_} } @_;
return grep { $secflags{$_} } @_;
}
sub mechanism { 'EXTERNAL' }
sub mechanism { return 'EXTERNAL' }
sub client_start {
my $self = shift;
my $v = $self->_call('user');
defined($v) ? $v : ''
return defined($v) ? $v : '';
}
#sub client_step {

18
lib/Authen/SASL/Perl/GSSAPI.pm
View File

@@ -1,15 +1,21 @@
## no critic (ClassHierarchies::ProhibitExplicitISA, Documentation::RequirePodSections, Documentation::RequirePODUseEncodingUTF8)
# Copyright (c) 2006 Simon Wilkinson
# All rights reserved. This program is free software; you can redistribute
# it and/or modify it under the same terms as Perl itself.
package Authen::SASL::Perl::GSSAPI;
use 5.018; ## no critic (ProhibitImplicitImport)
use strict;
use warnings;
use utf8;
use vars qw($VERSION @ISA);
use GSSAPI;
use GSSAPI ();
use GSSAPI::Name ();
use GSSAPI::Context ();
$VERSION= "0.05";
$VERSION= '0.05';
@ISA = qw(Authen::SASL::Perl);
my %secflags = (
@@ -17,13 +23,13 @@ my %secflags = (
noanonymous => 1,
);
sub _order { 4 }
sub _order { return 4 }
sub _secflags {
shift;
scalar grep { $secflags{$_} } @_;
return scalar grep { $secflags{$_} } @_;
}
sub mechanism { 'GSSAPI' }
sub mechanism { return 'GSSAPI' }
sub _init {
my ($pkg, $self) = @_;
@@ -38,7 +44,7 @@ sub _init {
# layer selection mask in the client reply, we default to
# compatibility with that bug
$self->property('COMPAT_CYRUSLIB_REPLY_MASK_BUG', 1);
$self;
return $self;
}
sub client_start {

29
lib/Authen/SASL/Perl/LOGIN.pm
View File

@@ -1,31 +1,36 @@
## no critic (ClassHierarchies::ProhibitExplicitISA, Documentation::RequirePODUseEncodingUTF8, Documentation::RequirePodSections)
# Copyright (c) 2002 Graham Barr <gbarr@pobox.com>. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
package Authen::SASL::Perl::LOGIN;
use 5.018; ## no critic (ProhibitImplicitImport)
use strict;
use warnings;
use utf8;
use vars qw($VERSION @ISA);
$VERSION = "2.14";
$VERSION = '2.14';
@ISA = qw(Authen::SASL::Perl);
my %secflags = (
noanonymous => 1,
);
sub _order { 1 }
sub _order { return 1 }
sub _secflags {
shift;
scalar grep { $secflags{$_} } @_;
return scalar grep { $secflags{$_} } @_;
}
sub mechanism { 'LOGIN' }
sub mechanism { return 'LOGIN' }
sub client_start {
my $self = shift;
$self->{stage} = 0;
'';
return '';
}
sub client_step {
@@ -47,7 +52,7 @@ sub client_step {
return;
}
else {
return $self->set_error("Invalid sequence");
return $self->set_error('Invalid sequence');
}
}
@@ -73,24 +78,24 @@ sub server_step {
if ($stage == 1) {
unless (defined $response) {
$self->set_error("Invalid sequence (empty username)");
$self->set_error('Invalid sequence (empty username)');
return $user_cb->();
}
$self->{answer}{user} = $response;
return $user_cb->("Password:");
return $user_cb->('Password:');
}
elsif ($stage == 2) {
unless (defined $response) {
$self->set_error("Invalid sequence (empty pass)");
$self->set_error('Invalid sequence (empty pass)');
return $user_cb->();
}
$self->{answer}{pass} = $response;
}
else {
$self->set_error("Invalid sequence (end)");
$self->set_error('Invalid sequence (end)');
return $user_cb->();
}
my $error = "Credentials don't match";
my $error = 'Credentials don\'t match';
my $answers = { user => $self->{answer}{user}, pass => $self->{answer}{pass} };
if (my $checkpass = $self->{callback}{checkpass}) {
my $cb = sub {
@@ -109,7 +114,7 @@ sub server_step {
elsif (my $getsecret = $self->{callback}{getsecret}) {
my $cb = sub {
my $good_pass = shift;
if ($good_pass && $good_pass eq ($self->{answer}{pass} || "")) {
if ($good_pass && $good_pass eq ($self->{answer}{pass} || '')) {
$self->set_success;
}
else {

27
lib/Authen/SASL/Perl/PLAIN.pm
View File

@@ -1,14 +1,19 @@
## no critic (Documentation::RequirePODUseEncodingUTF8, Documentation::RequirePodSections)
# Copyright (c) 2002 Graham Barr <gbarr@pobox.com>. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
package Authen::SASL::Perl::PLAIN;
use 5.018; ## no critic (ProhibitImplicitImport)
use strict;
use warnings;
use utf8;
use vars qw($VERSION @ISA);
$VERSION = "2.14";
@ISA = qw(Authen::SASL::Perl);
$VERSION = '2.14';
@ISA = qw(Authen::SASL::Perl); ## no critic (ClassHierarchies::ProhibitExplicitISA)
my %secflags = (
noanonymous => 1,
@@ -16,13 +21,13 @@ my %secflags = (
my @tokens = qw(authname user pass);
sub _order { 1 }
sub _order { return 1 }
sub _secflags {
shift;
grep { $secflags{$_} } @_;
return grep { $secflags{$_} } @_;
}
sub mechanism { 'PLAIN' }
sub mechanism { return 'PLAIN' }
sub client_start {
my $self = shift;
@@ -35,7 +40,7 @@ sub client_start {
defined($v) ? $v : ''
} @tokens;
join("\0", @parts);
return join("\0", @parts);
}
sub server_start {
@@ -44,16 +49,16 @@ sub server_start {
my $user_cb = shift || sub {};
$self->{error} = undef;
return $self->set_error("No response: Credentials don't match")
return $self->set_error('No response: Credentials don\'t match')
unless defined $response;
my %parts;
@parts{@tokens} = split "\0", $response, scalar @tokens;
@parts{@tokens} = split "\0", $response, scalar @tokens; ## no critic (BuiltinFunctions::ProhibitStringySplit)
# I'm not entirely sure of what I am doing
$self->{answer}{$_} = $parts{$_} for qw/authname user/;
my $error = "Credentials don't match";
my $error = 'Credentials don\'t match';
## checkpass
if (my $checkpass = $self->callback('checkpass')) {
@@ -75,7 +80,7 @@ sub server_start {
elsif (my $getsecret = $self->callback('getsecret')) {
my $cb = sub {
my $good_pass = shift;
if ($good_pass && $good_pass eq ($parts{pass} || "")) {
if ($good_pass && $good_pass eq ($parts{pass} || '')) {
$self->set_success;
}
else {
@@ -92,6 +97,8 @@ sub server_start {
$self->set_error($error);
$user_cb->();
}
return;
}
1;

2
lib/BotLib.pm
View File

@@ -1,6 +1,6 @@
package BotLib;
use 5.018;
use 5.018; ## no critic (ProhibitImplicitImport)
use strict;
use warnings;
use utf8;

8
lib/BotLib/Anek.pm
View File

@@ -1,15 +1,15 @@
package BotLib::Anek;
use 5.018;
use 5.018; ## no critic (ProhibitImplicitImport)
use strict;
use warnings;
use utf8;
use open qw (:std :utf8);
use English qw ( -no_match_vars );
use Encode qw (decode);
use HTML::TokeParser;
use HTTP::Tiny;
use JSON::XS;
use HTML::TokeParser ();
use HTTP::Tiny ();
use JSON::XS ();
use Log::Any qw ($log);
use version; our $VERSION = qw (1.0);

2
lib/BotLib/Archeologist.pm
View File

@@ -1,6 +1,6 @@
package BotLib::Archeologist;
use 5.018;
use 5.018; ## no critic (ProhibitImplicitImport)
use strict;
use warnings;
use utf8;

6
lib/BotLib/Buni.pm
View File

@@ -1,13 +1,13 @@
package BotLib::Buni;
use 5.018;
use 5.018; ## no critic (ProhibitImplicitImport)
use strict;
use warnings;
use utf8;
use open qw (:std :utf8);
use English qw ( -no_match_vars );
use HTTP::Tiny;
use HTML::TokeParser;
use HTTP::Tiny ();
use HTML::TokeParser ();
use Log::Any qw ($log);
use version; our $VERSION = qw (1.0);

4
lib/BotLib/Conf.pm
View File

@@ -1,13 +1,13 @@
package BotLib::Conf;
# loads config
use 5.018;
use 5.018; ## no critic (ProhibitImplicitImport)
use strict;
use warnings;
use utf8;
use open qw (:std :utf8);
use English qw ( -no_match_vars );
use JSON::XS;
use JSON::XS ();
use Log::Any qw ($log);
use version; our $VERSION = qw (1.0);

12
lib/BotLib/Drink.pm
View File

@@ -1,17 +1,17 @@
package BotLib::Drink;
use 5.018;
use 5.018; ## no critic (ProhibitImplicitImport)
use strict;
use warnings;
use utf8;
use open qw (:std :utf8);
use English qw ( -no_match_vars );
use Encode qw (decode);
use CHI;
use CHI::Driver::BerkeleyDB;
use DateTime;
use HTTP::Tiny;
use HTML::TokeParser;
use CHI ();
use CHI::Driver::BerkeleyDB ();
use DateTime ();
use HTTP::Tiny ();
use HTML::TokeParser ();
use Log::Any qw ($log);
use POSIX qw (strftime);
use BotLib::Conf qw (LoadConf);

2
lib/BotLib/Fisher.pm
View File

@@ -1,6 +1,6 @@
package BotLib::Fisher;
use 5.018;
use 5.018; ## no critic (ProhibitImplicitImport)
use strict;
use warnings;
use utf8;

4
lib/BotLib/Fortune.pm
View File

@@ -1,7 +1,7 @@
package BotLib::Fortune;
# Any fortune_mod sources are suitable. Text file with "\n%\n" sentence delimiters.
use 5.018;
use 5.018; ## no critic (ProhibitImplicitImport)
use strict;
use warnings;
use utf8;
@@ -11,7 +11,7 @@ use Carp qw (croak);
use File::Path qw (make_path);
use Log::Any qw ($log);
use Math::Random::Secure qw (irand);
use SQLite_File;
use SQLite_File ();
use BotLib::Conf qw (LoadConf);
use version; our $VERSION = qw (1.0);

4
lib/BotLib/Fox.pm
View File

@@ -1,13 +1,13 @@
package BotLib::Fox;
use 5.018;
use 5.018; ## no critic (ProhibitImplicitImport)
use strict;
use warnings;
use utf8;
use open qw (:std :utf8);
use English qw ( -no_match_vars );
use JSON::XS qw (decode_json);
use HTTP::Tiny;
use HTTP::Tiny ();
use Log::Any qw ($log);
use version; our $VERSION = qw (1.0);

4
lib/BotLib/Friday.pm
View File

@@ -1,7 +1,7 @@
package BotLib::Friday;
# for friday data stolen from https://raw.githubusercontent.com/isida/vi/master/data/friday.txt
use 5.018;
use 5.018; ## no critic (ProhibitImplicitImport)
use strict;
use warnings;
use utf8;
@@ -11,7 +11,7 @@ use Carp qw (croak);
use File::Path qw (make_path);
use Log::Any qw ($log);
use Math::Random::Secure qw (irand);
use SQLite_File;
use SQLite_File ();
use BotLib::Conf qw (LoadConf);
use version; our $VERSION = qw (1.0);

2
lib/BotLib/Image.pm
View File

@@ -1,6 +1,6 @@
package BotLib::Image;
use 5.018;
use 5.018; ## no critic (ProhibitImplicitImport)
use strict;
use warnings;
use utf8;

8
lib/BotLib/Image/Flickr.pm
View File

@@ -1,6 +1,6 @@
package BotLib::Image::Flickr;
use 5.018;
use 5.018; ## no critic (ProhibitImplicitImport)
use strict;
use warnings;
use utf8;
@@ -8,12 +8,12 @@ use open qw (:std :utf8);
use English qw ( -no_match_vars );
use Digest::HMAC_SHA1 ();
use File::Path qw (make_path);
use JSON::XS;
use HTTP::Tiny;
use JSON::XS ();
use HTTP::Tiny ();
use Log::Any qw ($log);
use Math::Random::Secure qw (irand);
use MIME::Base64 qw (encode_base64);
use SQLite_File;
use SQLite_File ();
use URI::Encode::XS qw (uri_encode);
use BotLib::Conf qw (LoadConf);

4
lib/BotLib/Karma.pm
View File

@@ -1,12 +1,12 @@
package BotLib::Karma;
use 5.018;
use 5.018; ## no critic (ProhibitImplicitImport)
use strict;
use warnings;
use utf8;
use open qw (:std :utf8);
use English qw ( -no_match_vars );
use DB_File;
use DB_File ();
use File::Path qw (make_path);
use Log::Any qw ($log);
use BotLib::Conf qw (LoadConf);

4
lib/BotLib/Kitty.pm
View File

@@ -1,13 +1,13 @@
package BotLib::Kitty;
use 5.018;
use 5.018; ## no critic (ProhibitImplicitImport)
use strict;
use warnings;
use utf8;
use open qw (:std :utf8);
use English qw ( -no_match_vars );
use JSON::XS qw (decode_json);
use HTTP::Tiny;
use HTTP::Tiny ();
use Log::Any qw ($log);
use version; our $VERSION = qw (1.0);

4
lib/BotLib/Lat.pm
View File

@@ -1,7 +1,7 @@
package BotLib::Lat;
# famous latin phases taken from https://ru.wikipedia.org/wiki/Список_крылатых_латинских_выражений
use 5.018;
use 5.018; ## no critic (ProhibitImplicitImport)
use strict;
use warnings;
use utf8;
@@ -10,7 +10,7 @@ use English qw ( -no_match_vars );
use Carp qw (carp);
use File::Basename qw (dirname);
use File::Path qw (make_path);
use Hailo;
use Hailo ();
use Log::Any qw ($log);
use BotLib::Conf qw (LoadConf);

6
lib/BotLib/Monkeyuser.pm
View File

@@ -1,13 +1,13 @@
package BotLib::Monkeyuser;
use 5.018;
use 5.018; ## no critic (ProhibitImplicitImport)
use strict;
use warnings;
use utf8;
use open qw (:std :utf8);
use English qw ( -no_match_vars );
use HTTP::Tiny;
use HTML::TokeParser;
use HTTP::Tiny ();
use HTML::TokeParser ();
use Log::Any qw ($log);
use Math::Random::Secure qw (irand);

4
lib/BotLib/Proverb.pm
View File

@@ -1,7 +1,7 @@
package BotLib::Proverb;
# Any fortune_mod sources are suitable. Text file with "\n%\n" sentence delimeter.
use 5.018;
use 5.018; ## no critic (ProhibitImplicitImport)
use strict;
use warnings;
use utf8;
@@ -11,7 +11,7 @@ use Carp qw (croak);
use File::Path qw (make_path);
use Log::Any qw ($log);
use Math::Random::Secure qw (irand);
use SQLite_File;
use SQLite_File ();
use BotLib::Conf qw (LoadConf);
use BotLib::Util qw (trim);

2
lib/BotLib/Util.pm
View File

@@ -1,6 +1,6 @@
package BotLib::Util;
use 5.018;
use 5.018; ## no critic (ProhibitImplicitImport)
use strict;
use warnings;
use utf8;

8
lib/BotLib/Weather.pm
View File

@@ -1,14 +1,14 @@
package BotLib::Weather;
use 5.018;
use 5.018; ## no critic (ProhibitImplicitImport)
use strict;
use warnings;
use utf8;
use open qw (:std :utf8);
use English qw ( -no_match_vars );
use CHI;
use CHI::Driver::BerkeleyDB;
use HTTP::Tiny;
use CHI ();
use CHI::Driver::BerkeleyDB ();
use HTTP::Tiny ();
use JSON::XS qw (decode_json);
use Log::Any qw ($log);
use BotLib::Conf qw (LoadConf);

4
lib/BotLib/Xkcd.pm
View File

@@ -1,11 +1,11 @@
package BotLib::Xkcd;
use 5.018;
use 5.018; ## no critic (ProhibitImplicitImport)
use strict;
use warnings;
use utf8;
use open qw (:std :utf8);
use HTTP::Tiny;
use HTTP::Tiny ();
use version; our $VERSION = qw (1.0);
use Exporter qw (import);

6
lib/JabberBot.pm
View File

@@ -3,7 +3,7 @@
# в vendor_perl/5.24.3/Authen/SASL/Perl/DIGEST_MD5.pm
package JabberBot;
use 5.018;
use 5.018; ## no critic (ProhibitImplicitImport)
use strict;
use warnings;
use utf8;
@@ -93,9 +93,9 @@ sub __new_bot_message {
$reply = 'Чего тебе?';
} elsif (($text =~ /^$qname[\,|\:]? (.+)/u) && ($hash{type} eq 'groupchat')) {
$reply = $hailo->{$chatid}->learn_reply ($1);
} elsif ($text =~ /^=\($/u || $text =~ /^\:\($/u || $text eq /^\)\:$/u) {
} elsif ($text =~ /^\=\($/u || $text =~ /^\:\($/u || $text eq /^\)\:$/u) {
$reply = ':)';
} elsif ($text =~ /^=\)$/u || $text =~ /^\:\)$/u || $text =~ /^\(\:$/u) {
} elsif ($text =~ /^\=\)$/u || $text =~ /^\:\)$/u || $text =~ /^\(\:$/u) {
$reply = ':D';
# karma adjustment
} elsif ($text =~ /(\+\+|\-\-)$/) {

168
lib/Net/Jabber/Bot.pm
View File

@@ -1,5 +1,11 @@
## no critic (Subroutines::ProhibitCallsToUndeclaredSubs, RegularExpressions::ProhibitUselessTopic, Documentation::RequirePODUseEncodingUTF8, Variables::ProhibitPunctuationVars, Documentation::RequirePodSections, Documentation::RequirePodAtEnd, ErrorHandling::RequireCarping, RegularExpressions::ProhibitUnusedCapture)
package Net::Jabber::Bot;
use 5.018; ## no critic (ProhibitImplicitImport)
use warnings;
use utf8;
use Moose;
use MooseX::Types
-declare => [qw( JabberClientObject PosInt PosNum HundredInt )];
@@ -8,11 +14,12 @@ use MooseX::Types
use MooseX::Types::Moose qw/Int HashRef Str Maybe ArrayRef Bool CodeRef Object Num/;
use version;
use Net::Jabber;
use Time::HiRes;
use Sys::Hostname;
use Net::Jabber ();
use Time::HiRes ();
use Sys::Hostname qw(hostname);
use Log::Log4perl qw(:easy);
use Mozilla::CA;
use Mozilla::CA ();
use Net::Jabber::Client ();
coerce Bool, from Str,
via {($_ =~ m/(^on$)|(^true$)/i) + 0}; # True if it's on or true. Otherwise false.
@@ -25,7 +32,7 @@ subtype HundredInt, as Num, where { $_ > 100 };
has jabber_client => (isa => Maybe[JabberClientObject],
is => 'rw',
default => sub {Net::Jabber::Client->new});
default => sub {Net::Jabber::Client->new},);
#my %connection_hash : ATTR; # Keep track of connection options fed to client.
has 'client_session_id' => (isa => Str, is => 'rw');
@@ -43,7 +50,7 @@ has 'username' => (isa => Str, is => 'rw');
has 'password' => (isa => Str, is => 'rw');
has 'alias' => (isa => Str, lazy => 1, is => 'rw', default => 'net_jabber_bot');
# Resource defaults to alias_hostname_pid
has 'resource' => (isa => Str, lazy => 1, is => 'rw', default => sub{shift->alias . "_" . hostname . "_" . $$});
has 'resource' => (isa => Str, lazy => 1, is => 'rw', default => sub{shift->alias . '_' . hostname() . '_' . $$});
has 'message_function' => (isa => Maybe[CodeRef], is => 'rw', default => sub{undef});
has 'background_function' => (isa => Maybe[CodeRef], is => 'rw', default => sub{undef});
has 'loop_sleep_time' => (isa => PosNum, is => 'rw', default => 5);
@@ -53,7 +60,7 @@ has 'from_full' => (isa => Str, lazy => 1, is => 'rw', default => sub{
'@' .
$self->server || '' .
'/' .
$self->alias || '' });
$self->alias || '' },);
has 'safety_mode' => (isa => Bool, is => 'rw', default => 1, coerce => 1);
has 'ignore_server_messages' => (isa => Bool, is => 'rw', default => 1, coerce => 1);
@@ -315,13 +322,13 @@ sub BUILD {
# Deal with legacy bug
if($params->{background_activity} || $params->{message_callback}) {
my $warn_message = "\n\n"
. "*" x 70 . "\n"
my $warn_message = "\n\n"
. '*' x 70 . "\n"
. "WARNING!!! You're using old parameters for your bot initialization\n"
. "'message_callback' should be changed to 'message_function'\n"
. "'background_activity' should be changed to 'background_function'\n"
. "I'm correcting this, but you should fix your code\n"
. "*" x 70 . "\n"
. '*' x 70 . "\n"
. "\n\n";
warn($warn_message);
WARN($warn_message);
@@ -331,8 +338,8 @@ sub BUILD {
$self->message_function($params->{message_callback})
if(!$self->message_function && $params->{message_callback});
sleep 30;
}
}
# Message delay is inverse of out_messages_per_second
$self->message_delay(1/$self->out_messages_per_second);
@@ -352,7 +359,7 @@ sub BUILD {
}
#Initialize the connection.
$self->_init_jabber;
return $self->_init_jabber;
}
# Return a code reference that will pass self in addition to arguements passed to callback code ref.
@@ -371,15 +378,15 @@ sub _init_jabber {
# Autocreate the jabber object (see has jabber_client)
my $connection = $self->jabber_client;
DEBUG("Set the call backs.");
DEBUG('Set the call backs.');
$connection->PresenceDB(); # Init presence DB.
$connection->RosterDB(); # Init Roster DB.
$connection->SetCallBacks( 'message' => $self->_callback_maker(\&_process_jabber_message)
,'presence' => $self->_callback_maker(\&_jabber_presence_message)
,'iq' => $self->_callback_maker(\&_jabber_in_iq_message)
,'iq' => $self->_callback_maker(\&_jabber_in_iq_message),
);
DEBUG("Connect. hostname => " . $self->server . ", port => " . $self->port);
DEBUG('Connect. hostname => ' . $self->server . ', port => ' . $self->port);
my %client_connect_hash = (
hostname => $self->server,
port => $self->port,
@@ -397,8 +404,8 @@ sub _init_jabber {
die("Jabber server is down or connection was not allowed: $!");
}
DEBUG("Logging in... as user " . $self->username . " / " . $self->resource);
DEBUG("PW: " . $self->password);
DEBUG('Logging in... as user ' . $self->username . ' / ' . $self->resource);
DEBUG('PW: ' . $self->password);
# Moved into connect hash via 'componentname'
# my $sid = $connection->{SESSION}->{id};
@@ -410,23 +417,23 @@ sub _init_jabber {
resource => $self->resource,
);
if(!defined $auth_result[0] || $auth_result[0] ne "ok") {
ERROR("Authorization failed: for " . $self->username . " / " . $self->resource);
if(!defined $auth_result[0] || $auth_result[0] ne 'ok') {
ERROR('Authorization failed: for ' . $self->username . ' / ' . $self->resource);
foreach my $result (@auth_result) {
ERROR("$result");
}
die("Failed to re-connect: " . join("\n", @auth_result));
die('Failed to re-connect: ' . join("\n", @auth_result));
}
$connection->RosterRequest();
$self->client_session_id($connection->{SESSION}->{id});
DEBUG("Sending presence to tell world that we are logged in");
DEBUG('Sending presence to tell world that we are logged in');
$connection->PresenceSend();
$self->Process(5);
DEBUG("Getting Roster to tell server to send presence info");
DEBUG('Getting Roster to tell server to send presence info');
$connection->RosterGet();
$self->Process(5);
@@ -434,7 +441,7 @@ sub _init_jabber {
$self->JoinForum($forum);
}
INFO("Connected to server '" . $self->server . "' successfully");
INFO('Connected to server \'' . $self->server . '\' successfully');
$self->connect_time(time); # Track when we came online.
return 1;
}
@@ -453,7 +460,7 @@ sub JoinForum {
my $self = shift;
my $forum_name = shift;
DEBUG("Joining $forum_name on " . $self->conference_server . " as " . $self->alias);
DEBUG("Joining $forum_name on " . $self->conference_server . ' as ' . $self->alias);
$self->jabber_client->MUCJoin(room => $forum_name,
server => $self->conference_server,
@@ -461,8 +468,9 @@ sub JoinForum {
);
$self->forum_join_time->{$forum_name} = time;
DEBUG("Sleeping " . $self->message_delay . " seconds");
DEBUG('Sleeping ' . $self->message_delay . ' seconds');
Time::HiRes::sleep $self->message_delay;
return;
}
=item B<Process>
@@ -521,8 +529,8 @@ sub Start {
if($@) { #Assume the connection is down...
ERROR("Server error: $@");
my $message = "Disconnected from " . $self->server . ":" . $self->port
. " as " . $self->username;
my $message = 'Disconnected from ' . $self->server . ':' . $self->port
. ' as ' . $self->username;
ERROR("$message Reconnecting...");
sleep 5; # TODO: Make re-connect time flexible somehow
@@ -531,11 +539,12 @@ sub Start {
# Call background function
if(defined $background_subroutine && $last_background + $time_between_background_routines < time) {
&$background_subroutine($self, ++$counter);
&$background_subroutine($self, ++$counter); ## no critic (References::ProhibitDoubleSigils)
$last_background = time;
}
Time::HiRes::sleep $message_delay;
}
return;
}
=item B<ReconnectToServer>
@@ -562,9 +571,10 @@ sub ReconnectToServer {
sleep $sleep_time;
$sleep_time *= 2 if($sleep_time < 300);
$self->InitJabber();
INFO("Running background routine.");
&$background_subroutine($self, 0); # call background proc so we can check for errors while down.
INFO('Running background routine.');
&$background_subroutine($self, 0); ## no critic (References::ProhibitDoubleSigils) # call background proc so we can check for errors while down.
}
return;
}
=item B<Disconnect>
@@ -579,14 +589,14 @@ sub Disconnect {
$self->connect_time('9' x 10); # Way in the future
INFO("Disconnecting from server");
INFO('Disconnecting from server');
return if(!defined $self->jabber_client); # do not proceed, no object.
$self->jabber_client->Disconnect();
my $old_client = $self->jabber_client;
$self->jabber_client(undef);
DEBUG("Disconnected.");
DEBUG('Disconnected.');
return 1;
}
@@ -599,7 +609,7 @@ Reports connect state (true/false) based on the status of client_start_time.
sub IsConnected {
my $self = shift;
DEBUG("REF = " . ref($self->jabber_client));
DEBUG('REF = ' . ref($self->jabber_client));
return $self->connect_time;
}
@@ -612,13 +622,13 @@ Handles incoming messages.
sub _process_jabber_message {
my $self = shift;
DEBUG("_process_jabber_message called");
DEBUG('_process_jabber_message called');
my $session_id = shift;
my $message = shift;
my $type = $message->GetType();
my $fromJID = $message->GetFrom("jid");
my $fromJID = $message->GetFrom('jid');
my $from_full = $message->GetFrom();
my $from = $fromJID->GetUserID();
@@ -660,7 +670,6 @@ sub _process_jabber_message {
# Are these my own messages?
if($self->ignore_self_messages ) { # TODO: || $self->safety_mode (this breaks tests in 06?)
if(defined $resource && $resource eq $self->resource) { # Ignore my own messages.
DEBUG("Ignoring message from self...\n");
return;
@@ -676,11 +685,11 @@ sub _process_jabber_message {
foreach my $address_type (@aliases_to_respond_to) {
my $qm_address_type = quotemeta($address_type);
next if($body !~ m/^\s*$qm_address_type\s*(\S.*)$/ms);
$request = $1;
$request = $1; ## no critic (RegularExpressions::ProhibitCaptureWithoutTest)
$bot_address_from = $address_type;
last; # do not need to loop any more.
}
DEBUG("Message not relevant to bot");
DEBUG('Message not relevant to bot');
return if(!defined $request);
$body = $request;
}
@@ -693,13 +702,14 @@ sub _process_jabber_message {
type => $type,
reply_to => $reply_to,
bot_address_from => $bot_address_from,
message => $message
message => $message,
);
return;
} else {
WARN("No handler for messages!");
WARN('No handler for messages!');
INFO("New Message: $type from $from ($resource). sub=$subject -- $body");
}
return;
}
=item B<get_responses>
@@ -716,7 +726,7 @@ sub get_responses {
my $forum = shift;
if(!defined $forum) {
WARN("No forum supplied for get_responses()");
WARN('No forum supplied for get_responses()');
return;
}
@@ -741,13 +751,13 @@ sub _jabber_in_iq_message {
my $session_id = shift;
my $iq = shift;
DEBUG("IQ Message:" . $iq->GetXML());
DEBUG('IQ Message:' . $iq->GetXML());
my $from = $iq->GetFrom();
# my $type = $iq->GetType();DEBUG("Type=$type");
my $query = $iq->GetQuery();#DEBUG("query=" . Dumper($query));
if (!$query) {
DEBUG("iq->GetQuery() returned undef.");
DEBUG('iq->GetQuery() returned undef.');
return;
}
@@ -755,12 +765,12 @@ sub _jabber_in_iq_message {
my $iqReply;
# Respond to version requests with information about myself.
if($xmlns eq "jabber:iq:version") {
if($xmlns eq 'jabber:iq:version') {
# convert 5.010000 to 5.10.0
my $perl_version = $];
$perl_version =~ s/(\d{3})(?=\d)/$1./g;
$perl_version =~ s/(\d{3})(?=\d)/$1./g;
$perl_version =~ s/\.0+(\d)/.$1/;
$self->jabber_client
->VersionSend(to=> $from,
name=>__PACKAGE__,
@@ -771,11 +781,12 @@ sub _jabber_in_iq_message {
}
if($iqReply) {
DEBUG("Reply: ", $iqReply->GetXML());
DEBUG('Reply: ', $iqReply->GetXML());
$self->jabber_client->Send($iqReply);
}
# INFO("IQ from $from ($type). XMLNS: $xmlns");
return;
}
=item B<_jabber_presence_message> - DO NOT CALL
@@ -794,19 +805,19 @@ sub _jabber_presence_message {
my $type = $presence->GetType();
if($type eq 'subscribe') { # Always allow people to subscribe to us. Why wouldn't we?
my $from = $presence->GetFrom();
$self->jabber_client->Subscription(type=>"subscribe",
$self->jabber_client->Subscription(type=>'subscribe',
to=>$from);
$self->jabber_client->Subscription(type=>"subscribed",to=>$from);
$self->jabber_client->Subscription(type=>'subscribed',to=>$from);
INFO("Processed subscription request from $from");
return;
} elsif($type eq 'unsubscribe') { # Always allow people to subscribe to us. Why wouldn't we?
my $from = $presence->GetFrom();
$self->jabber_client->Subscription(type=>"unsubscribed",
$self->jabber_client->Subscription(type=>'unsubscribed',
to=>$from);
INFO("Processed unsubscribe request from $from");
return;
}
# Without explicitly setting a priority, XMPP::Protocol will store all JIDs with an empty
# priority under the same key rather than in an array.
$presence->SetPriority(0) unless $presence->GetPriority();
@@ -814,13 +825,14 @@ sub _jabber_presence_message {
$self->jabber_client->PresenceDBParse($presence); # Since we are always an object just throw it into the db.
my $from = $presence->GetFrom();
$from = "." if(!defined $from);
$from = '.' if(!defined $from);
my $status = $presence->GetStatus();
$status = "." if(!defined $status);
$status = '.' if(!defined $status);
DEBUG("Presence From $from t=$type s=$status");
DEBUG("Presence XML: " . $presence->GetXML());
DEBUG('Presence XML: ' . $presence->GetXML());
return;
}
=item B<respond_to_self_messages>
@@ -876,7 +888,7 @@ sub get_safety_mode {
&& $self->max_messages_per_hour <= 166
&& $self->ignore_self_messages
;
return $mode || 0;
}
@@ -971,12 +983,12 @@ sub _send_individual_message {
my $subject = shift;
if(!defined $message_type) {
ERROR("Undefined \$message_type");
ERROR('Undefined $message_type'); ## no critic (ValuesAndExpressions::RequireInterpolationOfMetachars)
return "No message type!\n";
}
if(!defined $recipient) {
ERROR('$recipient not defined!');
ERROR('$recipient not defined!'); ## no critic (ValuesAndExpressions::RequireInterpolationOfMetachars)
return "No recipient!\n";
}
@@ -985,15 +997,15 @@ sub _send_individual_message {
my $messages_this_hour = $self->messages_sent_today->{$yday}->{$hour} += 1;
if($messages_this_hour > $self->max_messages_per_hour) {
$subject = "" if(!defined $subject); # Keep warning messages quiet.
$message_chunk = "" if(!defined $message_chunk); # Keep warning messages quiet.
$subject = '' if(!defined $subject); # Keep warning messages quiet.
$message_chunk = '' if(!defined $message_chunk); # Keep warning messages quiet.
ERROR("Can't Send message because we've already tried to send $messages_this_hour of $self->max_messages_per_hour messages this hour.\n"
. "To: $recipient\n"
. "Subject: $subject\n"
. "Type: $message_type\n"
. "Message sent:\n"
. "$message_chunk"
. "$message_chunk",
);
# Send 1 panic message out to jabber if this is our last message before quieting down.
@@ -1001,15 +1013,15 @@ sub _send_individual_message {
}
if(!$self->IsConnected) {
$subject = "" if(!defined $subject); # Keep warning messages quiet.
$message_chunk = "" if(!defined $message_chunk); # Keep warning messages quiet.
$subject = '' if(!defined $subject); # Keep warning messages quiet.
$message_chunk = '' if(!defined $message_chunk); # Keep warning messages quiet.
ERROR("Can't Jabber server is down. Tried to send: \n"
. "To: $recipient\n"
. "Subject: $subject\n"
. "Type: $message_type\n"
. "Message sent:\n"
. "$message_chunk"
. "$message_chunk",
);
# Send 1 panic message out to jabber if this is our last message before quieting down.
@@ -1026,17 +1038,17 @@ sub _send_individual_message {
, body => $message_chunk
, type => $message_type
# , from => $connection_hash{$obj_ID}{'from_full'}
, subject => $subject
, subject => $subject,
);
DEBUG("Sleeping " . $self->message_delay . " after sending message.");
DEBUG('Sleeping ' . $self->message_delay . ' after sending message.');
Time::HiRes::sleep $self->message_delay; #Throttle messages.
if($messages_this_hour == $self->max_messages_per_hour) {
$self->jabber_client->MessageSend(to => $recipient
, body => "Cannot send more messages this hour. "
. "$messages_this_hour of " . $self->max_messages_per_hour . " already sent."
, type => $message_type
, body => 'Cannot send more messages this hour. '
. "$messages_this_hour of " . $self->max_messages_per_hour . ' already sent.'
, type => $message_type,
);
}
return; # Means we succeeded!
@@ -1059,9 +1071,9 @@ sub SetForumSubject {
if(length $subject > $self->max_message_size) {
my $subject_len = length($subject);
ERROR("Someone tried to send a subject message $subject_len bytes long!");
my $subject = substr($subject, 0, $self->max_message_size);
my $subject = substr($subject, 0, $self->max_message_size); ## no critic (Variables::ProhibitReusedNames)
DEBUG("Truncated subject: $subject");
return "Subject is too long!";
return 'Subject is too long!';
}
$self->_send_individual_message($recipient, "Setting subject to $subject", 'groupchat', $subject);
@@ -1123,7 +1135,7 @@ sub GetStatus {
if (!(defined($Pres))) {
return "unavailable" ;
return 'unavailable' ;
}
my $show = $Pres->GetShow();
@@ -1132,7 +1144,7 @@ sub GetStatus {
return $show;
}
return "available";
return 'available';
}
@@ -1146,8 +1158,9 @@ sub AddUser {
my $self = shift;
my $user = shift;
$self->jabber_client->Subscription(type=>"subscribe", to=>$user);
$self->jabber_client->Subscription(type=>"subscribed",to=>$user);
$self->jabber_client->Subscription(type=>'subscribe', to=>$user);
$self->jabber_client->Subscription(type=>'subscribed',to=>$user);
return;
}
=item B<RmUser>
@@ -1160,8 +1173,9 @@ sub RmUser {
my $self = shift;
my $user = shift;
$self->jabber_client->Subscription(type=>"unsubscribe", to=>$user);
$self->jabber_client->Subscription(type=>"unsubscribed",to=>$user);
$self->jabber_client->Subscription(type=>'unsubscribe', to=>$user);
$self->jabber_client->Subscription(type=>'unsubscribed',to=>$user);
return;
}
=back