diff --git a/lib/Authen/SASL.pm b/lib/Authen/SASL.pm index b00cac1..80af85a 100644 --- a/lib/Authen/SASL.pm +++ b/lib/Authen/SASL.pm @@ -1,14 +1,19 @@ +## no critic (Variables::ProhibitPunctuationVars) # Copyright (c) 2004-2006 Graham Barr . 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; diff --git a/lib/Authen/SASL/CRAM_MD5.pm b/lib/Authen/SASL/CRAM_MD5.pm index 2f88542..480c14c 100644 --- a/lib/Authen/SASL/CRAM_MD5.pm +++ b/lib/Authen/SASL/CRAM_MD5.pm @@ -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; diff --git a/lib/Authen/SASL/EXTERNAL.pm b/lib/Authen/SASL/EXTERNAL.pm index ed0541e..5377bc0 100644 --- a/lib/Authen/SASL/EXTERNAL.pm +++ b/lib/Authen/SASL/EXTERNAL.pm @@ -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; diff --git a/lib/Authen/SASL/Perl/ANONYMOUS.pm b/lib/Authen/SASL/Perl/ANONYMOUS.pm index 7bb8c00..ad57c2c 100644 --- a/lib/Authen/SASL/Perl/ANONYMOUS.pm +++ b/lib/Authen/SASL/Perl/ANONYMOUS.pm @@ -1,33 +1,38 @@ +## no critic (ClassHierarchies::ProhibitExplicitISA, Documentation::RequirePODUseEncodingUTF8, Documentation::RequirePodSections) # Copyright (c) 2002 Graham Barr . 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; diff --git a/lib/Authen/SASL/Perl/CRAM_MD5.pm b/lib/Authen/SASL/Perl/CRAM_MD5.pm index 84db3a0..f86abbf 100644 --- a/lib/Authen/SASL/Perl/CRAM_MD5.pm +++ b/lib/Authen/SASL/Perl/CRAM_MD5.pm @@ -1,14 +1,19 @@ +## no critic (ClassHierarchies::ProhibitExplicitISA, Documentation::RequirePodSections, Documentation::RequirePODUseEncodingUTF8) # Copyright (c) 2002 Graham Barr . 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; diff --git a/lib/Authen/SASL/Perl/DIGEST_MD5.pm b/lib/Authen/SASL/Perl/DIGEST_MD5.pm index aff3161..d7a2883 100644 --- a/lib/Authen/SASL/Perl/DIGEST_MD5.pm +++ b/lib/Authen/SASL/Perl/DIGEST_MD5.pm @@ -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; } diff --git a/lib/Authen/SASL/Perl/EXTERNAL.pm b/lib/Authen/SASL/Perl/EXTERNAL.pm index 1eeafbe..7c8b431 100644 --- a/lib/Authen/SASL/Perl/EXTERNAL.pm +++ b/lib/Authen/SASL/Perl/EXTERNAL.pm @@ -1,3 +1,4 @@ +## no critic (ClassHierarchies::ProhibitExplicitISA, Documentation::RequirePodSections, Documentation::RequirePODUseEncodingUTF8) # Copyright (c) 1998-2002 Graham Barr and 2001 Chris Ridd # . 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 { diff --git a/lib/Authen/SASL/Perl/GSSAPI.pm b/lib/Authen/SASL/Perl/GSSAPI.pm index d2670fc..94c34a8 100644 --- a/lib/Authen/SASL/Perl/GSSAPI.pm +++ b/lib/Authen/SASL/Perl/GSSAPI.pm @@ -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 { diff --git a/lib/Authen/SASL/Perl/LOGIN.pm b/lib/Authen/SASL/Perl/LOGIN.pm index f248b29..38e6005 100644 --- a/lib/Authen/SASL/Perl/LOGIN.pm +++ b/lib/Authen/SASL/Perl/LOGIN.pm @@ -1,31 +1,36 @@ +## no critic (ClassHierarchies::ProhibitExplicitISA, Documentation::RequirePODUseEncodingUTF8, Documentation::RequirePodSections) # Copyright (c) 2002 Graham Barr . 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 { diff --git a/lib/Authen/SASL/Perl/PLAIN.pm b/lib/Authen/SASL/Perl/PLAIN.pm index 31fed89..ebd50ec 100644 --- a/lib/Authen/SASL/Perl/PLAIN.pm +++ b/lib/Authen/SASL/Perl/PLAIN.pm @@ -1,14 +1,19 @@ +## no critic (Documentation::RequirePODUseEncodingUTF8, Documentation::RequirePodSections) # Copyright (c) 2002 Graham Barr . 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; diff --git a/lib/BotLib.pm b/lib/BotLib.pm index dc7a367..4173788 100644 --- a/lib/BotLib.pm +++ b/lib/BotLib.pm @@ -1,6 +1,6 @@ package BotLib; -use 5.018; +use 5.018; ## no critic (ProhibitImplicitImport) use strict; use warnings; use utf8; diff --git a/lib/BotLib/Anek.pm b/lib/BotLib/Anek.pm index bbf60fa..d9c3296 100644 --- a/lib/BotLib/Anek.pm +++ b/lib/BotLib/Anek.pm @@ -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); diff --git a/lib/BotLib/Archeologist.pm b/lib/BotLib/Archeologist.pm index 4a3a8be..1c9a018 100644 --- a/lib/BotLib/Archeologist.pm +++ b/lib/BotLib/Archeologist.pm @@ -1,6 +1,6 @@ package BotLib::Archeologist; -use 5.018; +use 5.018; ## no critic (ProhibitImplicitImport) use strict; use warnings; use utf8; diff --git a/lib/BotLib/Buni.pm b/lib/BotLib/Buni.pm index 4c5ab41..d131c7d 100644 --- a/lib/BotLib/Buni.pm +++ b/lib/BotLib/Buni.pm @@ -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); diff --git a/lib/BotLib/Conf.pm b/lib/BotLib/Conf.pm index 2df70cd..24daace 100644 --- a/lib/BotLib/Conf.pm +++ b/lib/BotLib/Conf.pm @@ -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); diff --git a/lib/BotLib/Drink.pm b/lib/BotLib/Drink.pm index 6d04c54..5064d99 100644 --- a/lib/BotLib/Drink.pm +++ b/lib/BotLib/Drink.pm @@ -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); diff --git a/lib/BotLib/Fisher.pm b/lib/BotLib/Fisher.pm index 1d6a9d8..f5b06ae 100644 --- a/lib/BotLib/Fisher.pm +++ b/lib/BotLib/Fisher.pm @@ -1,6 +1,6 @@ package BotLib::Fisher; -use 5.018; +use 5.018; ## no critic (ProhibitImplicitImport) use strict; use warnings; use utf8; diff --git a/lib/BotLib/Fortune.pm b/lib/BotLib/Fortune.pm index dc0660e..19869c2 100644 --- a/lib/BotLib/Fortune.pm +++ b/lib/BotLib/Fortune.pm @@ -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); diff --git a/lib/BotLib/Fox.pm b/lib/BotLib/Fox.pm index eba05b0..822f023 100644 --- a/lib/BotLib/Fox.pm +++ b/lib/BotLib/Fox.pm @@ -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); diff --git a/lib/BotLib/Friday.pm b/lib/BotLib/Friday.pm index 6a7eea2..a7bf9ae 100644 --- a/lib/BotLib/Friday.pm +++ b/lib/BotLib/Friday.pm @@ -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); diff --git a/lib/BotLib/Image.pm b/lib/BotLib/Image.pm index 2c5af44..c8255d6 100644 --- a/lib/BotLib/Image.pm +++ b/lib/BotLib/Image.pm @@ -1,6 +1,6 @@ package BotLib::Image; -use 5.018; +use 5.018; ## no critic (ProhibitImplicitImport) use strict; use warnings; use utf8; diff --git a/lib/BotLib/Image/Flickr.pm b/lib/BotLib/Image/Flickr.pm index ee06290..78181fd 100644 --- a/lib/BotLib/Image/Flickr.pm +++ b/lib/BotLib/Image/Flickr.pm @@ -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); diff --git a/lib/BotLib/Karma.pm b/lib/BotLib/Karma.pm index 8f2790b..eedff4c 100644 --- a/lib/BotLib/Karma.pm +++ b/lib/BotLib/Karma.pm @@ -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); diff --git a/lib/BotLib/Kitty.pm b/lib/BotLib/Kitty.pm index 3bc636b..1afbec0 100644 --- a/lib/BotLib/Kitty.pm +++ b/lib/BotLib/Kitty.pm @@ -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); diff --git a/lib/BotLib/Lat.pm b/lib/BotLib/Lat.pm index d9af9a8..f7d072a 100644 --- a/lib/BotLib/Lat.pm +++ b/lib/BotLib/Lat.pm @@ -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); diff --git a/lib/BotLib/Monkeyuser.pm b/lib/BotLib/Monkeyuser.pm index 1ec70ac..6779e53 100644 --- a/lib/BotLib/Monkeyuser.pm +++ b/lib/BotLib/Monkeyuser.pm @@ -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); diff --git a/lib/BotLib/Proverb.pm b/lib/BotLib/Proverb.pm index d2ebdfd..f286572 100644 --- a/lib/BotLib/Proverb.pm +++ b/lib/BotLib/Proverb.pm @@ -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); diff --git a/lib/BotLib/Util.pm b/lib/BotLib/Util.pm index 6fac680..b3353e7 100644 --- a/lib/BotLib/Util.pm +++ b/lib/BotLib/Util.pm @@ -1,6 +1,6 @@ package BotLib::Util; -use 5.018; +use 5.018; ## no critic (ProhibitImplicitImport) use strict; use warnings; use utf8; diff --git a/lib/BotLib/Weather.pm b/lib/BotLib/Weather.pm index 5e43cda..be0d926 100644 --- a/lib/BotLib/Weather.pm +++ b/lib/BotLib/Weather.pm @@ -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); diff --git a/lib/BotLib/Xkcd.pm b/lib/BotLib/Xkcd.pm index f6cf51d..ade871a 100644 --- a/lib/BotLib/Xkcd.pm +++ b/lib/BotLib/Xkcd.pm @@ -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); diff --git a/lib/JabberBot.pm b/lib/JabberBot.pm index c4ec5e5..8012192 100644 --- a/lib/JabberBot.pm +++ b/lib/JabberBot.pm @@ -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 =~ /(\+\+|\-\-)$/) { diff --git a/lib/Net/Jabber/Bot.pm b/lib/Net/Jabber/Bot.pm index f5f0177..d37d004 100644 --- a/lib/Net/Jabber/Bot.pm +++ b/lib/Net/Jabber/Bot.pm @@ -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 @@ -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 @@ -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 @@ -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 @@ -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 @@ -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 @@ -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