diff options
Diffstat (limited to 'lib/Net')
| -rw-r--r-- | lib/Net/IMAP/InterIMAP.pm | 109 |
1 files changed, 72 insertions, 37 deletions
diff --git a/lib/Net/IMAP/InterIMAP.pm b/lib/Net/IMAP/InterIMAP.pm index 19895c4..bb27009 100644 --- a/lib/Net/IMAP/InterIMAP.pm +++ b/lib/Net/IMAP/InterIMAP.pm @@ -1,6 +1,6 @@ #---------------------------------------------------------------------- # A minimal IMAP4 client for QRESYNC-capable servers -# Copyright © 2015-2018 Guilhem Moulin <guilhem@fripost.org> +# Copyright © 2015-2019 Guilhem Moulin <guilhem@fripost.org> # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by @@ -17,10 +17,11 @@ #---------------------------------------------------------------------- package Net::IMAP::InterIMAP v0.0.5; +use v5.10.0; use warnings; use strict; -use Compress::Raw::Zlib qw/Z_OK Z_FULL_FLUSH Z_SYNC_FLUSH MAX_WBITS/; +use Compress::Raw::Zlib qw/Z_OK Z_STREAM_END Z_FULL_FLUSH Z_SYNC_FLUSH MAX_WBITS/; use Config::Tiny (); use Errno qw/EEXIST EINTR/; use Net::SSLeay 1.73 (); @@ -92,11 +93,9 @@ sub xdg_basedir($$$$) { return $path if $path =~ /\A\//; my $basedir = $ENV{$xdg_variable}; - unless (defined $basedir) { - my @getent = getpwuid($>); - $basedir = $getent[7] ."/". $default; - } + $basedir = ($ENV{HOME} // "") ."/". $default unless defined $basedir; die "No such directory: ", $basedir unless -d $basedir; + $basedir .= "/".$subdir; $basedir =~ /\A(\/\p{Print}+)\z/ or die "Insecure $basedir"; $basedir = $1; @@ -282,7 +281,8 @@ our $IMAP_text; # # - 'name': An optional instance name to include in log messages. # -# - 'logger-fd': An optional filehandle to use for debug output. +# - 'logger-fd': An optional filehandle to use for debug output +# (default: STDERR). # # - 'keepalive': Whether to enable sending of keep-alive messages. # (type=imap or type=imaps). @@ -291,6 +291,7 @@ sub new($%) { my $class = shift; my $self = { @_ }; bless $self, $class; + require 'Time/HiRes.pm' if defined $self->{'logger-fd'}; # the IMAP state: one of 'UNAUTH', 'AUTH', 'SELECTED' or 'LOGOUT' # (cf RFC 3501 section 3) @@ -380,11 +381,6 @@ sub new($%) { # are considered. $self->{_MODIFIED} = {}; - if (defined $self->{'logger-fd'} and defined $self->{'logger-fd'}->fileno - and $self->{'logger-fd'}->fileno != fileno STDERR) { - require 'Time/HiRes.pm'; - } - # wait for the greeting my $x = $self->_getline(); $x =~ s/\A\* (OK|PREAUTH) // or $self->panic($x); @@ -409,8 +405,8 @@ sub new($%) { @caps = $self->capabilities(); } - my @mechs = ('LOGIN', grep defined, map { /^AUTH=(.+)/i ? $1 : undef } @caps); - my $mech = (grep defined, map {my $m = $_; (grep {$m eq $_} @mechs) ? $m : undef} + my @mechs = ('LOGIN', grep defined, map { /^AUTH=(.+)/i ? uc($1) : undef } @caps); + my $mech = (grep defined, map {my $m = uc($_); (grep {$m eq $_} @mechs) ? $m : undef} split(/ /, $self->{auth}))[0]; $self->fail("Failed to choose an authentication mechanism") unless defined $mech; $self->fail("Logins are disabled.") if ($mech eq 'LOGIN' or $mech eq 'PLAIN') and @@ -438,8 +434,21 @@ sub new($%) { $self->fail("Unsupported authentication mechanism: $mech"); } + my $dbg; delete $self->{password}; # no need to remember passwords + if (($self->{debug} // 0) == 1) { + $dbg = $self->{debug}--; + my $cmd = $command =~ /\A(LOGIN) / ? $1 + : $command =~ /\A(AUTHENTICATE \S+)(?: .*)?\z/ ? $1 + : $self->panic(); + $self->logger('C: xxx ', $cmd, ' [REDACTED]'); + } $self->_send($command, $callback); + if (defined $dbg) { + $self->logger('S: xxx ', $IMAP_text); + $self->{debug} = $dbg; + } + unless ($IMAP_text =~ /\A\Q$IMAP_cond\E \[CAPABILITY /) { # refresh the CAPABILITY list since the previous one had only pre-login capabilities delete $self->{_CAPABILITIES}; @@ -509,6 +518,7 @@ sub stats($) { # Destroy a Net::IMAP::InterIMAP object. sub DESTROY($) { + local($., $@, $!, $^E, $?); my $self = shift; $self->{_STATE} = 'LOGOUT'; @@ -527,32 +537,55 @@ sub DESTROY($) { # $self->log($message, [...]) # $self->logger($message, [...]) -# Log a $message. The latter method is used to log in the 'logger-fd', and -# add timestamps. +# Log a $message. The latter method is used to log in the 'logger-fd' +# (and adds timestamps). sub log($@) { my $self = shift; return unless @_; - $self->logger(@_) if defined $self->{'logger-fd'} and defined $self->{'logger-fd'}->fileno - and $self->{'logger-fd'}->fileno != fileno STDERR; - my $prefix = $self->{name} // ''; - $prefix .= "($self->{_SELECTED})" if $self->{_STATE} eq 'SELECTED'; - $prefix .= ': ' unless $prefix eq ''; - print STDERR $prefix, @_, "\n"; + my $prefix = _logger_prefix($self); + if (defined (my $fd = $self->{'logger-fd'})) { + say $fd _date(), " ", $prefix, @_; + } + say STDERR $prefix, @_; } sub logger($@) { my $self = shift; - return unless @_ and defined $self->{'logger-fd'}; - my $prefix = ''; - if (defined $self->{'logger-fd'}->fileno and defined $self->{'logger-fd'}->fileno - and $self->{'logger-fd'}->fileno != fileno STDERR) { - my ($s, $us) = Time::HiRes::gettimeofday(); - $prefix = POSIX::strftime("%b %e %H:%M:%S", localtime($s)).".$us"; - $prefix .= ' ' if defined $self->{name} or $self->{_STATE} eq 'SELECTED'; + return unless @_; + my $prefix = _logger_prefix($self); + if (defined (my $fd = $self->{'logger-fd'})) { + say $fd _date(), " ", $prefix, @_; + } else { + say STDERR $prefix, @_; } - $prefix .= $self->{name} if defined $self->{name}; - $prefix .= "($self->{_SELECTED})" if $self->{_STATE} eq 'SELECTED'; - $prefix .= ': ' unless $prefix eq ''; - $self->{'logger-fd'}->say($prefix, @_); +} +sub _date() { + my ($s, $us) = Time::HiRes::gettimeofday(); + my $t = POSIX::strftime("%b %e %H:%M:%S", localtime($s)); + return "$t.$us"; # millisecond precision +} + +# $self->_logger_prefix() +# Format a prefix for logging with printf(3)-like sequences: +# %n: the object name +# %m: mailbox, either explicit named or selected +sub _logger_prefix($) { + my $self = shift; + my $format = $self->{'logger-prefix'} // return ""; + + my %seq = ( "%" => "%", m => $self->{mailbox}, n => $self->{name} ); + $seq{m} //= $self->{_SELECTED} // die + if defined $self->{_STATE} and $self->{_STATE} eq 'SELECTED'; + + do {} while + # rewrite conditionals (loop because of nesting) + $format =~ s#%\? ([[:alpha:]]) \? + ( (?: (?> (?: [^%&?\\] | %[^?] | \\[&?\\] )+ ) | (?R) )* ) + (?: \& ( (?: (?> (?: [^%&?\\] | %[^?] | \\[&?\\] )+ ) | (?R) )*) )? + \?# ($seq{$1} // "") ne "" ? $2 : ($3 // "") #agex; + + $format =~ s#\\([&?\\])#$1#g; # unescape remaining '&', '?' and '\' + $format =~ s#%([%mn])# $seq{$1} #ge; + return $format; } @@ -1678,6 +1711,7 @@ sub _start_ssl($$) { } @$self{qw/_SSL _SSL_CTX/} = ($ssl, $ctx); + undef $self; # the verify callback has reference to $self, free it now } @@ -1710,8 +1744,9 @@ sub _getline($;$) { $self->{_OUTRAWCOUNT} += $n; if (defined (my $i = $self->{_Z_INFLATE})) { - $i->inflate($buf, $self->{_OUTBUF}) == Z_OK or - $self->panic("Inflation failed: ", $i->msg()); + my $r = $i->inflate($buf, $self->{_OUTBUF}); + $self->panic("Inflation failed: $r ", $i->msg()) + unless $r == Z_OK or $r == Z_STREAM_END; } else { $self->{_OUTBUF} = $buf; @@ -1828,8 +1863,8 @@ sub _cmd_extend($$) { $self->_cmd_extend_($args); } else { - # server supports LITERAL+: flush the command before each - # literal + # server doesn't supports LITERAL+: flush the command before + # each literal my ($offset, $litlen) = (0, 0); while ( (my $idx = index($$args, "\n", $offset+$litlen)) >= 0 ) { my $line = substr($$args, $offset, $idx+1-$offset); |