aboutsummaryrefslogtreecommitdiffstats
path: root/lib/Net/IMAP/InterIMAP.pm
diff options
context:
space:
mode:
Diffstat (limited to 'lib/Net/IMAP/InterIMAP.pm')
-rw-r--r--lib/Net/IMAP/InterIMAP.pm109
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);
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-03 22:06:33 +0000