--- imapsync-1.241.orig/debian/watch +++ imapsync-1.241/debian/watch @@ -0,0 +1,3 @@ +version=3 + +http://www.linux-france.org/prj/imapsync/dist/imapsync-(.*).tgz --- imapsync-1.241.orig/debian/imapsync.install +++ imapsync-1.241/debian/imapsync.install @@ -0,0 +1,6 @@ +debian/IMAPClient229/Mail/IMAPClient/MessageSet.pm /usr/share/imapsync/Mail/IMAPClient/ +debian/IMAPClient229/Mail/IMAPClient/Thread.pm /usr/share/imapsync/Mail/IMAPClient/ +debian/IMAPClient229/Mail/IMAPClient/BodyStructure/Parse.pm /usr/share/imapsync/Mail/IMAPClient/BodyStructure/ +debian/IMAPClient229/Mail/IMAPClient/BodyStructure.pm /usr/share/imapsync/Mail/IMAPClient/ +debian/IMAPClient229/Mail/IMAPClient.pm /usr/share/imapsync/Mail/ +debian/IMAPClient229/Mail/IMAPClient.pod /usr/share/imapsync/Mail/ --- imapsync-1.241.orig/debian/imapsync.docs +++ imapsync-1.241/debian/imapsync.docs @@ -0,0 +1,3 @@ +FAQ +CREDITS +RECORD --- imapsync-1.241.orig/debian/copyright +++ imapsync-1.241/debian/copyright @@ -0,0 +1,42 @@ +This package was debianized by RISKO Gergely on +Mon, 25 Apr 2005 12:59:24 +0200. + +Upstream Author: Gilles LAMIRAL + +Copyright: imapsync is free, gratis and open source software cover by +the GNU General Public License. See the GPL file included in the +distribution or the web site http://www.gnu.org/licenses/licenses.html + +You can also find GPL (on a Debian system) in the file +/usr/share/common-licenses/GPL. + + --- Mail::IMAPClient --- +A precompiled Mail::IMAPClient version 2.2.9 can be found in the +directory debian/IMAPClient229. + +The original sources should always be available from the Comprehensive +Perl Archive Network (CPAN). Visit to +find a CPAN site near you. + +The Mail::IMAPClient copyright is as follows: + + Copyright 1999, The Kernen Group, Inc. + All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the terms of either: + + a) the "Artistic License" which comes with this Kit, or + + + b) the GNU General Public License as published by the Free Software + Foundation; either versio n 1, or (at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See either +the GNU General Public License or the Artistic License for more details. + +Larry Wall's "Artistic License" for perl can be found in +/usr/share/common-licenses/Artistic. The GNU General Public License +can be found in /usr/share/common-licenses/GPL. --- imapsync-1.241.orig/debian/compat +++ imapsync-1.241/debian/compat @@ -0,0 +1 @@ +4 --- imapsync-1.241.orig/debian/rules +++ imapsync-1.241/debian/rules @@ -0,0 +1,10 @@ +#!/usr/bin/make -f + +DEB_MAKE_INSTALL_TARGET:=install DESTDIR=$(CURDIR)/debian/imapsync + +include /usr/share/cdbs/1/rules/debhelper.mk +include /usr/share/cdbs/1/class/makefile.mk +include /usr/share/cdbs/1/rules/simple-patchsys.mk + +clean:: + rm -f imapsync.1 --- imapsync-1.241.orig/debian/README.debian +++ imapsync-1.241/debian/README.debian @@ -0,0 +1,3 @@ +This package needs Mail::IMAPSync version 2.2.9 exactly. Because this +is superseeded in Debian, as a temporary solution a precompiled +version is installed by this package into /usr/share/imapsync/ --- imapsync-1.241.orig/debian/changelog +++ imapsync-1.241/debian/changelog @@ -0,0 +1,69 @@ +imapsync (1.241-1ubuntu1.1) hardy-proposed; urgency=low + + * Adding depends on adding libdate-manip-perl. (LP: #253996). + + -- Andreas Wenning Fri, 08 Aug 2008 01:12:29 +0200 + +imapsync (1.241-1ubuntu1) hardy; urgency=low + + [ Andreas Wenning ] + * Added debian/patches/debian-imapclient229.patch which patches Makefile + to include debian/IMAPClient229 in @INC while testing (LP: #190854). + + [ Michael Bienia ] + * debian/control: + + Move the Homepage field from the package stanza to the source stanza to + quieten a dpkg-source warning about an unknown field. + + -- Michael Bienia Mon, 11 Feb 2008 11:53:56 +0100 + +imapsync (1.241-1) unstable; urgency=low + + * New upstream release + * Added Homepage: to debian/control and removed it from debian/copyright + * Mention similar packages in debian/control's Description field + * A lot of thanks for this updates to Andreas Wenning: + Added debian/watch + Mail::IMAPClient 2.2.9 needed (closes: #458501) + - Included Mail::IMAPClient 2.2.9 in debian/IMAPClient229 + - Added debian/imapsync.install to install the files in + debian/IMAPClient to /usr/share/imapsync/ + - Added README.debian describing the installation of + Mail::IMAPClient into /usr/share/imapsync/ + - Added debian/patches/imapclient229.patch which patches + imapsync to use /usr/share/imapsync/ + - Removed dependecy for libmail-imapclient-perl + + -- RISKO Gergely Sun, 27 Jan 2008 23:51:51 +0100 + +imapsync (1.219-1) unstable; urgency=low + + * New upstream release (closes: #410865, #417997, #391954, #393375) + * Removed patches/makefile.patch, because it is applied by upstream + * Added patches/podfix.patch, because pod is wrong, as pointed out by + podcheck and lintian + + -- RISKO Gergely Thu, 28 Jun 2007 23:20:11 +0200 + +imapsync (1.182-1) unstable; urgency=low + + * New upstream release (closes: #379517) + * fixed perl's ssl dependency (thanks to Wágner Ferenc) + (closes: #372271) + * added CREDITS, FAQ, RECORD to /usr/share/doc/imapsync + + -- RISKO Gergely Wed, 16 Aug 2006 23:29:51 +0200 + +imapsync (1.172-1) unstable; urgency=low + + * New upstream release + * fixing typos in description (closes: #363969) + + -- RISKO Gergely Tue, 30 May 2006 15:36:09 +0200 + +imapsync (1.125-1) unstable; urgency=low + + * initial upload (closes: #302007) + + -- RISKO Gergely Mon, 25 Apr 2005 12:44:15 +0200 + --- imapsync-1.241.orig/debian/control +++ imapsync-1.241/debian/control @@ -0,0 +1,36 @@ +Source: imapsync +Section: mail +Priority: optional +Maintainer: Ubuntu MOTU Developers +XSBC-Original-Maintainer: RISKO Gergely +Build-Depends: cdbs, debhelper +Build-Depends-Indep: perl, libdigest-hmac-perl, libterm-readkey-perl, libio-socket-ssl-perl +Standards-Version: 3.7.3 +Homepage: http://www.linux-france.org/prj/imapsync/ + +Package: imapsync +Architecture: all +Depends: perl, libdigest-hmac-perl, libterm-readkey-perl, libio-socket-ssl-perl, libdate-manip-perl +Description: IMAP synchronization, copy and migration tool + The command imapsync is a tool allowing incremental and recursive imap + transfer from one mailbox to another. + . + We sometimes need to transfer mailboxes from one imap server to another. + This is called migration. + . + imapsync is the adequate tool because it reduces the amount of data + transferred by not transferring a given message if it is already on both + sides. Same headers, same message size and the transfer is done only + once. All flags are preserved, unread will stay unread, read will stay + read, deleted will stay deleted. You can stop the transfer at any time + and restart it later, imapsync is adapted to a bad connection. + . + You can decide to delete the messages from the source mailbox after a + successful transfer (it is a good feature when migrating). In that + case, use the --delete option, and run imapsync again with the --expunge + option. + . + You can also just synchronize a mailbox A from another mailbox B in case + you just want to keep a "live" copy of B in A (backup). + . + Similar packages: offlineimap, imapcopy. --- imapsync-1.241.orig/debian/patches/imapclient229.patch +++ imapsync-1.241/debian/patches/imapclient229.patch @@ -0,0 +1,11 @@ +diff -Nur -x '*.orig' -x '*~' imapsync-1.219/imapsync imapsync-1.219.new/imapsync +--- imapsync-1.219/imapsync 2007-04-04 11:32:20.000000000 +0200 ++++ imapsync-1.219.new/imapsync 2008-01-27 16:17:29.000000000 +0100 +@@ -1,5 +1,7 @@ + #!/usr/bin/perl -w + ++use lib '/usr/share/imapsync/'; ++ + =pod + =head1 NAME + --- imapsync-1.241.orig/debian/patches/debian-imapclient229.patch +++ imapsync-1.241/debian/patches/debian-imapclient229.patch @@ -0,0 +1,12 @@ +diff -Nur -x '*.orig' -x '*~' imapsync-1.241/Makefile imapsync-1.241.new/Makefile +--- imapsync-1.241/Makefile 2007-10-30 01:50:14.000000000 +0100 ++++ imapsync-1.241.new/Makefile 2008-02-04 19:24:12.000000000 +0100 +@@ -30,7 +30,7 @@ + testf: clean_test test + + testp : +- perl -c $(TARGET) ++ PERL5LIB="debian/IMAPClient229" perl -c $(TARGET) + + ChangeLog: $(TARGET) + rlog $(TARGET) > ChangeLog --- imapsync-1.241.orig/debian/IMAPClient229/Mail/IMAPClient.pm +++ imapsync-1.241/debian/IMAPClient229/Mail/IMAPClient.pm @@ -0,0 +1,3772 @@ +package Mail::IMAPClient; + +# $Id: IMAPClient.pm,v 20001010.20 2003/06/13 18:30:55 dkernen Exp $ + +$Mail::IMAPClient::VERSION = '2.2.9'; +$Mail::IMAPClient::VERSION = '2.2.9'; # do it twice to make sure it takes + +use Fcntl qw(F_GETFL F_SETFL O_NONBLOCK); +use Socket(); +use IO::Socket(); +use IO::Socket::SSL(); +use IO::Select(); +use IO::File(); +use Carp qw(carp); +#use Data::Dumper; +use Errno qw/EAGAIN/; + +#print "Found Fcntl in $INC{'Fcntl.pm'}\n"; +#Fcntl->import; + +use constant Unconnected => 0; + +use constant Connected => 1; # connected; not logged in + +use constant Authenticated => 2; # logged in; no mailbox selected + +use constant Selected => 3; # mailbox selected + +use constant INDEX => 0; # Array index for output line number + +use constant TYPE => 1; # Array index for line type + # (either OUTPUT, INPUT, or LITERAL) + +use constant DATA => 2; # Array index for output line data + +use constant NonFolderArg => 1; # Value to pass to Massage to + # indicate non-folder argument + + + +my %SEARCH_KEYS = map { ( $_ => 1 ) } qw/ + ALL ANSWERED BCC BEFORE BODY CC DELETED DRAFT FLAGGED + FROM HEADER KEYWORD LARGER NEW NOT OLD ON OR RECENT + SEEN SENTBEFORE SENTON SENTSINCE SINCE SMALLER SUBJECT + TEXT TO UID UNANSWERED UNDELETED UNDRAFT UNFLAGGED + UNKEYWORD UNSEEN +/; + +sub _debug { + my $self = shift; + return unless $self->Debug; + my $fh = $self->{Debug_fh} || \*STDERR; + print $fh @_; +} + +sub MaxTempErrors { + my $self = shift; + $_[0]->{Maxtemperrors} = $_[1] if defined($_[1]); + return $_[0]->{Maxtemperrors}; +} + +# This function is used by the accessor methods +# +sub _do_accessor { + my $datum = shift; + + if ( defined($_[1]) and $datum eq 'Fast_io' and ref($_[0]->{Socket})) { + if ($_[1]) { # Passed the "True" flag + my $fcntl = 0; + eval { $fcntl=fcntl($_[0]->{Socket}, F_GETFL, 0) } ; + if ($@) { + $_[0]->{Fast_io} = 0; + carp ref($_[0]) . " not using Fast_IO; not available on this platform" + if ( ( $^W or $_[0]->Debug) and not $_[0]->{_fastio_warning_}++); + } else { + $_[0]->{Fast_io} = 1; + $_[0]->{_fcntl} = $fcntl; + my $newflags = $fcntl; + $newflags |= O_NONBLOCK; + fcntl($_[0]->{Socket}, F_SETFL, $newflags) ; + + } + } else { + eval { fcntl($_[0]->{Socket}, F_SETFL, $_[0]->{_fcntl}) } + if exists $_[0]->{_fcntl}; + $_[0]->{Fast_io} = 0; + delete $_[0]->{_fcntl} if exists $_[0]->{_fcntl}; + } + } elsif ( defined($_[1]) and $datum eq 'Socket' ) { + + # Get rid of fcntl settings for obsolete socket handles: + delete $_[0]->{_fcntl} ; + # Register this handle in a select vector: + $_[0]->{_select} = IO::Select->new($_[1]) ; + } + + if (scalar(@_) > 1) { + $@ = $_[1] if $datum eq 'LastError'; + chomp $@ if $datum eq 'LastError'; + return $_[0]->{$datum} = $_[1] ; + } else { + return $_[0]->{$datum}; + } +} + +# the following for loop sets up eponymous accessor methods for +# the object's parameters: + +BEGIN { + for my $datum ( + qw( State Port Server Folder Fast_io Peek + User Password Socket Timeout Buffer + Debug LastError Count Uid Debug_fh Maxtemperrors + EnableServerResponseInLiteral + Authmechanism Authcallback Ranges + Readmethod Showcredentials + Prewritemethod + Ssl + ) + ) { + no strict 'refs'; + *$datum = sub { _do_accessor($datum, @_); }; + } + + eval { + require Digest::HMAC_MD5; + require MIME::Base64; + }; + if ($@) { + $Mail::IMAPClient::_CRAM_MD5_ERR = + "Internal CRAM-MD5 implementation not available: $@"; + $Mail::IMAPClient::_CRAM_MD5_ERR =~ s/\n+$/\n/; + } +} + +sub Wrap { shift->Clear(@_); } + +# The following class method is for creating valid dates in appended msgs: + +sub Rfc822_date { +my $class= shift; +#Date: Fri, 09 Jul 1999 13:10:55 -0000# +my $date = $class =~ /^\d+$/ ? $class : shift ; +my @date = gmtime($date); +my @dow = qw{ Sun Mon Tue Wed Thu Fri Sat }; +my @mnt = qw{ Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec}; +# +return sprintf( + "%s, %2.2d %s %4.4s %2.2d:%2.2d:%2.2d -%4.4d", + $dow[$date[6]], + $date[3], + $mnt[$date[4]], + $date[5]+=1900, + $date[2], + $date[1], + $date[0], + $date[8]) ; +} + +# The following class method is for creating valid dates for use in IMAP search strings: + +sub Rfc2060_date { +my $class= shift; +# 11-Jan-2000 +my $date = $class =~ /^\d+$/ ? $class : shift ; +my @date = gmtime($date); +my @mnt = qw{ Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec}; +# +return sprintf( + "%2.2d-%s-%4.4s", + $date[3], + $mnt[$date[4]], + $date[5]+=1900 + ) ; +} + +# The following class method strips out 's so lines end with +# instead of : + +sub Strip_cr { + my $class = shift; + unless ( ref($_[0]) or scalar(@_) > 1 ) { + (my $string = $_[0]) =~ s/\x0d\x0a/\x0a/gm; + return $string; + } + return wantarray ? map { s/\x0d\x0a/\0a/gm ; $_ } + (ref($_[0]) ? @{$_[0]} : @_) : + [ map { s/\x0d\x0a/\x0a/gm ; $_ } + ref($_[0]) ? @{$_[0]} : @_ + ] ; +} + +# The following defines a special method to deal with the Clear parameter: + +sub Clear { + my $self = shift; + defined(my $clear = shift) or return $self->{Clear}; + + my $oldclear = $self->{Clear}; + $self->{Clear} = $clear; + + my (@keys) = sort { $b <=> $a } keys %{$self->{"History"}} ; + + for ( my $i = $clear; $i < @keys ; $i++ ) + { delete $self->{'History'}{$keys[$i]} } + + return $oldclear; +} + +# read-only access to the transaction number: +sub Transaction { shift->Count }; + +# the constructor: +sub new { + my $class = shift; + my $self = { + LastError => "", + Uid => 1, + Count => 0, + Fast_io => 1, + "Clear" => 5, + }; + while (scalar(@_)) { + $self->{ucfirst(lc($_[0]))} = $_[1]; shift, shift; + } + bless $self, ref($class)||$class; + + $self->State(Unconnected); + + $self->{Debug_fh} ||= \*STDERR; + select((select($self->{Debug_fh}),$|++)[0]) ; + $self->_debug("Using Mail::IMAPClient version $Mail::IMAPClient::VERSION " . + "and perl version " . (defined $^V ? join(".",unpack("CCC",$^V)) : "") . + " ($])\n") if $self->Debug; + $self->LastError(0); + $self->Maxtemperrors or $self->Maxtemperrors("unlimited") ; + return $self->connect if $self->Server and !$self->Socket; + return $self; +} + + +sub connect { + my $self = shift; + + $self->Port(143) + if defined ($IO::Socket::INET::VERSION) + and $IO::Socket::INET::VERSION eq '1.25' + and !$self->Port; + %$self = (%$self, @_); + my $sock = ($self->Ssl ? IO::Socket::SSL->new : IO::Socket::INET->new); + my $dp = ($self->Ssl ? 'imaps(993)' : 'imap(143)'); + $sock->configure({ + PeerAddr => $self->Server , + PeerPort => $self->Port||$dp , + Proto => 'tcp' , + Timeout => $self->Timeout||0 , + Debug => $self->Debug , + }) ; + + unless ( defined($sock) ) { + + $self->LastError( "Unable to connect to $self->{Server}: $!\n"); + $@ = "Unable to connect to $self->{Server}: $!"; + carp "Unable to connect to $self->{Server}: $!" + unless defined wantarray; + return undef; + } + $self->Socket($sock); + $self->State(Connected); + + $sock->autoflush(1) ; + + my ($code, $output); + $output = ""; + + until ( $code ) { + + $output = $self->_read_line or return undef; + for my $o (@$output) { + $self->_debug("Connect: Received this from readline: " . + join("/",@$o) . "\n"); + $self->_record($self->Count,$o); # $o is a ref + next unless $o->[TYPE] eq "OUTPUT"; + ($code) = $o->[DATA] =~ /^\*\s+(OK|BAD|NO)/i ; + } + + } + + if ($code =~ /BYE|NO /) { + $self->State(Unconnected); + return undef ; + } + + if ($self->User and $self->Password) { + return $self->login ; + } else { + return $self; + } +} + + +sub login { + my $self = shift; + return $self->authenticate($self->Authmechanism,$self->Authcallback) + if $self->{Authmechanism}; + + my $id = $self->User; + my $has_quotes = $id =~ /^".*"$/ ? 1 : 0; + #my $string = "Login " . ( $has_quotes ? $id : qq("$id") ) . " " . + # "{" . length($self->Password) . + # "}\r\n".$self->Password."\r\n"; + my $string = "Login " . ( $has_quotes ? $id : qq("$id") ) . " " . $self->Password . "\r\n"; + $self->_imap_command($string) + and $self->State(Authenticated); + # $self->folders and $self->separator unless $self->NoAutoList; + unless ( $self->IsAuthenticated) { + my($carp) = $self->LastError; + $carp =~ s/^[\S]+ ([^\x0d\x0a]*)\x0d?\x0a/$1/; + carp $carp unless defined wantarray; + return undef; + } + return $self; +} + +sub separator { + my $self = shift; + my $target = shift ; + + unless ( defined($target) ) { + my $sep = ""; + # separator is namespace's 1st thing's 1st thing's 2nd thing: + eval { $sep = $self->namespace->[0][0][1] } ; + return $sep if $sep; + } + + defined($target) or $target = ""; + $target ||= '""' ; + + + + # The fact that the response might end with {123} doesn't really matter here: + + unless (exists $self->{"$target${;}SEPARATOR"}) { + my $list = (grep(/^\*\s+LIST\s+/,($self->list(undef,$target)||("NO")) ))[0] || + qq("/"); + my $s = (split(/\s+/,$list))[3]; + defined($s) and $self->{"$target${;}SEPARATOR"} = + ( $s eq 'NIL' ? 'NIL' : substr($s, 1,length($s)-2) ); + } + return $self->{$target,'SEPARATOR'}; +} + +sub sort { + my $self = shift; + my @hits; + my @a = @_; + $@ = ""; + $a[0] = "($a[0])" unless $a[0] =~ /^\(.*\)$/; # wrap criteria in parens + $self->_imap_command( ( $self->Uid ? "UID " : "" ) . "SORT ". join(' ',@a)) + or return wantarray ? @hits : \@hits ; + my @results = $self->History($self->Count); + + for my $r (@results) { + chomp $r; + $r =~ s/\r$//; + $r =~ s/^\*\s+SORT\s+// or next; + push @hits, grep(/\d/,(split(/\s+/,$r))); + } + return wantarray ? @hits : \@hits; +} + +sub list { + my $self = shift; + my ($reference, $target) = (shift, shift); + $reference = "" unless defined($reference); + $target = '*' unless defined($target); + $target = '""' if $target eq ""; + $target = $self->Massage($target) unless $target eq '*' or $target eq '""'; + my $string = qq(LIST "$reference" $target); + $self->_imap_command($string) or return undef; + return wantarray ? + $self->History($self->Count) : + [ map { $_->[DATA] } @{$self->{'History'}{$self->Count}}] ; +} + +sub lsub { + my $self = shift; + my ($reference, $target) = (shift, shift); + $reference = "" unless defined($reference); + $target = '*' unless defined($target); + $target = $self->Massage($target); + my $string = qq(LSUB "$reference" $target); + $self->_imap_command($string) or return undef; + return wantarray ? $self->History($self->Count) : + [ map { $_->[DATA] } @{$self->{'History'}{$self->Count}} ] ; +} + +sub subscribed { + my $self = shift; + my $what = shift ; + + my @folders ; + + my @list = $self->lsub(undef,( $what? "$what" . + $self->separator($what) . "*" : undef ) ); + push @list, $self->lsub(undef, $what) if $what and $self->exists($what) ; + + # my @list = map { $self->_debug("Pushing $_->[${\(DATA)}] \n"); $_->[DATA] } + # @$output; + + my $m; + + for ($m = 0; $m < scalar(@list); $m++ ) { + if ($list[$m] && $list[$m] !~ /\x0d\x0a$/ ) { + $list[$m] .= $list[$m+1] ; + $list[$m+1] = ""; + } + + + # $self->_debug("Subscribed: examining $list[$m]\n"); + + push @folders, $1||$2 + if $list[$m] =~ + / ^\*\s+LSUB # * LSUB + \s+\([^\)]*\)\s+ # (Flags) + (?:"[^"]*"|NIL)\s+ # "delimiter" or NIL + (?:"([^"]*)"|(.*))\x0d\x0a$ # Name or "Folder name" + /ix; + + } + + # for my $f (@folders) { $f =~ s/^\\FOLDER LITERAL:://;} + my @clean = () ; my %memory = (); + foreach my $f (@folders) { push @clean, $f unless $memory{$f}++ } + return wantarray ? @clean : \@clean ; +} + + +sub deleteacl { + my $self = shift; + my ($target, $user ) = @_; + $target = $self->Massage($target); + $user =~ s/^"(.*)"$/$1/; + $user =~ s/"/\\"/g; + my $string = qq(DELETEACL $target "$user"); + $self->_imap_command($string) or return undef; + + return wantarray ? $self->History($self->Count) : + [ map {$_->[DATA] } @{$self->{'History'}{$self->Count}}] ; +} + +sub setacl { + my $self = shift; + my ($target, $user, $acl) = @_; + $user = $self->User unless length($user); + $target = $self->Folder unless length($target); + $target = $self->Massage($target); + $user =~ s/^"(.*)"$/$1/; + $user =~ s/"/\\"/g; + $acl =~ s/^"(.*)"$/$1/; + $acl =~ s/"/\\"/g; + my $string = qq(SETACL $target "$user" "$acl"); + $self->_imap_command($string) or return undef; + return wantarray ? + $self->History($self->Count) : + [map{$_->[DATA]}@{$self->{'History'}{$self->Count}}] + ; +} + + +sub getacl { + my $self = shift; + my ($target) = @_; + $target = $self->Folder unless defined($target); + my $mtarget = $self->Massage($target); + my $string = qq(GETACL $mtarget); + $self->_imap_command($string) or return undef; + my @history = $self->History($self->Count); + #$self->_debug("Getacl history: ".join("|",@history).">>>End of History<<<" ) ; + my $perm = ""; + my $hash = {}; + for ( my $x = 0; $x < scalar(@history) ; $x++ ) { + if ( $history[$x] =~ /^\* ACL/ ) { + + $perm = $history[$x]=~ /^\* ACL $/ ? + $history[++$x].$history[++$x] : + $history[$x]; + + $perm =~ s/\s?\x0d\x0a$//; + piece: until ( $perm =~ /\Q$target\E"?$/ or !$perm) { + #$self->_debug(qq(Piece: permline=$perm and " + # "pattern = /\Q$target\E"? \$/)); + $perm =~ s/\s([^\s]+)\s?$// or last piece; + my($p) = $1; + $perm =~ s/\s([^\s]+)\s?$// or last piece; + my($u) = $1; + $hash->{$u} = $p; + $self->_debug("Permissions: $u => $p \n"); + } + + } + } + return $hash; +} + +sub listrights { + my $self = shift; + my ($target, $user) = @_; + $user = $self->User unless defined($user); + $target = $self->Folder unless defined($target); + $target = $self->Massage($target); + $user =~ s/^"(.*)"$/$1/; + $user =~ s/"/\\"/g; + my $string = qq(LISTRIGHTS $target "$user"); + $self->_imap_command($string) or return undef; + my $resp = ( grep(/^\* LISTRIGHTS/, $self->History($self->Count) ) )[0]; + my @rights = split(/\s/,$resp); + shift @rights, shift @rights, shift @rights, shift @rights; + my $rights = join("",@rights); + $rights =~ s/"//g; + return wantarray ? split(//,$rights) : $rights ; +} + +sub select { + my $self = shift; + my $target = shift ; + return undef unless defined($target); + + my $qqtarget = $self->Massage($target); + + my $string = qq/SELECT $qqtarget/; + + my $old = $self->Folder; + + if ($self->_imap_command($string) and $self->State(Selected)) { + $self->Folder($target); + return $old||$self; + } else { + return undef; + } +} + +sub message_string { + my $self = shift; + my $msg = shift; + my $expected_size = $self->size($msg); + return undef unless(defined $expected_size); # unable to get size + my $cmd = $self->has_capability('IMAP4REV1') ? + "BODY" . ( $self->Peek ? '.PEEK[]' : '[]' ) : + "RFC822" . ( $self->Peek ? '.PEEK' : '' ) ; + + $self->fetch($msg,$cmd) or return undef; + + my $string = ""; + + foreach my $result (@{$self->{"History"}{$self->Transaction}}) { + $string .= $result->[DATA] + if defined($result) and $self->_is_literal($result) ; + } + # BUG? should probably return undef if length != expected + if ( length($string) != $expected_size ) { + carp "${self}::message_string: " . + "expected $expected_size bytes but received " . + length($string) + if $self->Debug or $^W; + } + if ( length($string) > $expected_size ) + { $string = substr($string,0,$expected_size) } + if ( length($string) < $expected_size ) { + $self->LastError("${self}::message_string: expected ". + "$expected_size bytes but received " . + length($string)."\n"); + return undef; + } + return $string; +} + +sub bodypart_string { + my($self, $msg, $partno, $bytes, $offset) = @_; + + unless ( $self->has_capability('IMAP4REV1') ) { + $self->LastError( + "Unable to get body part; server " . + $self->Server . + " does not support IMAP4REV1" + ); + return undef; + } + my $cmd = "BODY" . ( $self->Peek ? ".PEEK[$partno]" : "[$partno]" ) ; + $offset ||= 0 ; + $cmd .= "<$offset.$bytes>" if $bytes; + + $self->fetch($msg,$cmd) or return undef; + + my $string = ""; + + foreach my $result (@{$self->{"History"}{$self->Transaction}}) { + $string .= $result->[DATA] + if defined($result) and $self->_is_literal($result) ; + } + return $string; +} + +sub message_to_file { + my $self = shift; + my $fh = shift; + my @msgs = @_; + my $handle; + + if ( ref($fh) ) { + $handle = $fh; + } else { + $handle = IO::File->new(">>$fh"); + unless ( defined($handle)) { + $@ = "Unable to open $fh: $!"; + $self->LastError("Unable to open $fh: $!\n"); + carp $@ if $^W; + return undef; + } + binmode $handle; # For those of you who need something like this... + } + + my $clear = $self->Clear; + my $cmd = $self->Peek ? 'BODY.PEEK[]' : 'BODY[]'; + $cmd = $self->Peek ? 'RFC822.PEEK' : 'RFC822' unless $self->imap4rev1; + + my $string = ( $self->Uid ? "UID " : "" ) . "FETCH " . join(",",@msgs) . " $cmd"; + + $self->Clear($clear) + if $self->Count >= $clear and $clear > 0; + + my $trans = $self->Count($self->Count+1); + + $string = "$trans $string" ; + + $self->_record($trans,[ 0, "INPUT", "$string\x0d\x0a"] ); + + my $feedback = $self->_send_line("$string"); + + unless ($feedback) { + $self->LastError( "Error sending '$string' to IMAP: $!\n"); + $@ = "Error sending '$string' to IMAP: $!"; + return undef; + } + + my ($code, $output); + $output = ""; + + READ: until ( $code) { + $output = $self->_read_line($handle) or return undef; # avoid possible infinite loop + for my $o (@$output) { + $self->_record($trans,$o); # $o is a ref + # $self->_debug("Received from readline: ${\($o->[DATA])}<>\n"); + next unless $self->_is_output($o); + ($code) = $o->[DATA] =~ /^$trans (OK|BAD|NO)/mi ; + if ($o->[DATA] =~ /^\*\s+BYE/im) { + $self->State(Unconnected); + return undef ; + } + } + } + + # $self->_debug("Command $string: returned $code\n"); + close $handle unless ref($fh); + return $code =~ /^OK/im ? $self : undef ; + +} + +sub message_uid { + my $self = shift; + my $msg = shift; + my @uid = $self->fetch($msg,"UID"); + my $uid; + while ( my $u = shift @uid and !$uid) { + ($uid) = $u =~ /\(UID\s+(\d+)\s*\)\r?$/; + } + return $uid; +} + +sub original_migrate { + my($self,$peer,$msgs,$folder) = @_; + unless ( eval { $peer->IsConnected } ) { + $self->LastError("Invalid or unconnected " . ref($self). + " object used as target for migrate." ); + return undef; + } + unless ($folder) { + $folder = $self->Folder; + $peer->exists($folder) or + $peer->create($folder) or + ( + $self->LastError("Unable to created folder $folder on target mailbox: ". + "$peer->LastError") and + return undef + ) ; + } + if ( $msgs =~ /^all$/i ) { $msgs = $self->search("ALL") } + foreach my $mid ( ref($msgs) ? @$msgs : $msgs ) { + my $uid = $peer->append($folder,$self->message_string($mid)); + $self->LastError("Trouble appending to peer: " . $peer->LastError . "\n"); + } +} + + +sub migrate { + + my($self,$peer,$msgs,$folder) = @_; + my($toSock,$fromSock) = ( $peer->Socket, $self->Socket); + my $bufferSize = $self->Buffer || 4096; + my $fromBuffer = ""; + my $clear = $self->Clear; + + unless ( eval { $peer->IsConnected } ) { + $self->LastError("Invalid or unconnected " . + ref($self) . " object used as target for migrate. $@"); + return undef; + } + + unless ($folder) { + $folder = $self->Folder or + $self->LastError( "No folder selected on source mailbox.") + and return undef; + + $peer->exists($folder) or + $peer->create($folder) or + ( + $self->LastError( + "Unable to create folder $folder on target mailbox: ". + $peer->LastError . "\n" + ) and return undef + ) ; + } + $msgs or $msgs eq "0" or $msgs = "all"; + if ( $msgs =~ /^all$/i ) { $msgs = $self->search("ALL") } + my $range = $self->Range($msgs) ; + $self->_debug("Migrating the following msgs from $folder: " . + " $range\n"); + # ( ref($msgs) ? join(", ",@$msgs) : $msgs) ); + + #MIGMSG: foreach my $mid ( ref($msgs) ? @$msgs : (split(/,\s*/,$msgs)) ) {#} + MIGMSG: foreach my $mid ( $range->unfold ) { + # Set up counters for size of msg and portion of msg remaining to + # process: + $self->_debug("Migrating message $mid in folder $folder\n") + if $self->Debug; + my $leftSoFar = my $size = $self->size($mid); + + # fetch internaldate and flags of original message: + my $intDate = '"' . $self->internaldate($mid) . '"' ; + my $flags = "(" . join(" ",grep(!/\\Recent/i,$self->flags($mid)) ) . ")" ; + $flags = "" if $flags eq "()" ; + + # set up transaction numbers for from and to connections: + my $trans = $self->Count($self->Count+1); + my $ptrans = $peer->Count($peer->Count+1); + + # If msg size is less than buffersize then do whole msg in one + # transaction: + if ( $size <= $bufferSize ) { + my $new_mid = $peer->append_string($peer->Massage($folder), + $self->message_string($mid) ,$flags, + $intDate) ; + $self->_debug("Copied message $mid in folder $folder to " . + $peer->User . + '@' . $peer->Server . + ". New Message UID is $new_mid.\n" + ) if $self->Debug; + + $peer->_debug("Copied message $mid in folder $folder from " . + $self->User . + '@' . $self->Server . ". New Message UID is $new_mid.\n" + ) if $peer->Debug; + + + next MIGMSG; + } + + # otherwise break it up into digestible pieces: + my ($cmd, $pattern); + if ( $self->imap4rev1 ) { + # imap4rev1 supports FETCH BODY + $cmd = $self->Peek ? 'BODY.PEEK[]' : 'BODY[]'; + $pattern = sub { + #$self->_debug("Data fed to pattern: $_[0]\n"); + my($one) = $_[0] =~ /\(.*BODY\[\]<\d+> \{(\d+)\}/i ; # ;-) + # or $self->_debug("Didn't match pattern\n") ; + #$self->_debug("Returning from pattern: $1\n") if defined($1); + return $one ; + } ; + } else { + # older imaps use (deprecated) FETCH RFC822: + $cmd = $self->Peek ? 'RFC822.PEEK' : 'RFC822' ; + $pattern = sub { + my($one) = shift =~ /\(RFC822\[\]<\d+> \{(\d+)\}/i; + return $one ; + }; + } + + + # Now let's warn the peer that there's a message coming: + + my $pstring = "$ptrans APPEND " . + $self->Massage($folder). + " " . + ( $flags ? "$flags " : () ) . + ( $intDate ? "$intDate " : () ) . + "{" . $size . "}" ; + + $self->_debug("About to issue APPEND command to peer " . + "for msg $mid\n") if $self->Debug; + + my $feedback2 = $peer->_send_line( $pstring ) ; + + $peer->_record($ptrans,[ + 0, + "INPUT", + "$pstring" , + ] ) ; + unless ($feedback2) { + $self->LastError("Error sending '$pstring' to target IMAP: $!\n"); + return undef; + } + # Get the "+ Go ahead" response: + my $code = 0; + until ($code eq '+' or $code =~ /NO|BAD|OK/ ) { + my $readSoFar = 0 ; + $readSoFar += sysread($toSock,$fromBuffer,1,$readSoFar)||0 + until $fromBuffer =~ /\x0d\x0a/; + + #$peer->_debug("migrate: response from target server: " . + # "$fromBuffer\n") if $peer->Debug; + + ($code)= $fromBuffer =~ /^(\+)|^(?:\d+\s(?:BAD|NO))/ ; + $code ||=0; + + $peer->_debug( "$folder: received $fromBuffer from server\n") + if $peer->Debug; + + # ... and log it in the history buffers + $self->_record($trans,[ + 0, + "OUTPUT", + "Mail::IMAPClient migrating message $mid to $peer->User\@$peer->Server" + ] ) ; + $peer->_record($ptrans,[ + 0, + "OUTPUT", + $fromBuffer + ] ) ; + + + } + unless ( $code eq '+' ) { + $^W and warn "$@\n"; + $self->Debug and $self->_debug("Error writing to target host: $@\n"); + next MIGMSG; + } + # Here is where we start sticking in UID if that parameter + # is turned on: + my $string = ( $self->Uid ? "UID " : "" ) . "FETCH $mid $cmd"; + + # Clean up history buffer if necessary: + $self->Clear($clear) + if $self->Count >= $clear and $clear > 0; + + + # position will tell us how far from beginning of msg the + # next IMAP FETCH should start (1st time start at offet zero): + my $position = 0; + #$self->_debug("There are $leftSoFar bytes left versus a buffer of $bufferSize bytes.\n"); + my $chunkCount = 0; + while ( $leftSoFar > 0 ) { + $self->_debug("Starting chunk " . ++$chunkCount . "\n"); + + my $newstring ="$trans $string<$position." . + ( $leftSoFar > $bufferSize ? $bufferSize : $leftSoFar ) . + ">" ; + + $self->_record($trans,[ 0, "INPUT", "$newstring\x0d\x0a"] ); + $self->_debug("Issuing migration command: $newstring\n" ) + if $self->Debug;; + + my $feedback = $self->_send_line("$newstring"); + + unless ($feedback) { + $self->LastError("Error sending '$newstring' to source IMAP: $!\n"); + return undef; + } + my $chunk = ""; + until ($chunk = $pattern->($fromBuffer) ) { + $fromBuffer = "" ; + until ( $fromBuffer=~/\x0d\x0a$/ ) { + sysread($fromSock,$fromBuffer,1,length($fromBuffer)) ; + #$self->_debug("migrate chunk $chunkCount:" . + # "Read from source: $fromBuffer\n"); + } + + $self->_record($trans,[ 0, "OUTPUT", "$fromBuffer"] ) ; + + if ( $fromBuffer =~ /^$trans (?:NO|BAD)/ ) { + $self->LastError($fromBuffer) ; + next MIGMSG; + } + + if ( $fromBuffer =~ /^$trans (?:OK)/ ) { + $self->LastError("Unexpected good return code " . + "from source host: " . $fromBuffer) ; + next MIGMSG; + } + + } + $fromBuffer = ""; + my $readSoFar = 0 ; + $readSoFar += sysread($fromSock,$fromBuffer,$chunk-$readSoFar,$readSoFar)||0 + until $readSoFar >= $chunk; + #$self->_debug("migrateRead: chunk=$chunk readSoFar=$readSoFar " . + # "Buffer=$fromBufferDebug; + + my $wroteSoFar = 0; + my $temperrs = 0; + my $optimize = 0; + + until ( $wroteSoFar >= $chunk ) { + #$peer->_debug("Chunk $chunkCount: Next write will attempt to write " . + # "this substring:\n" . + # substr($fromBuffer,$wroteSoFar,$chunk-$wroteSoFar) . + # "\n" + #); + + until ( $wroteSoFar >= $readSoFar ) { + $!=0; + my $ret = syswrite( + $toSock, + $fromBuffer, + $chunk - $wroteSoFar, + $wroteSoFar )||0 ; + + $wroteSoFar += $ret; + + if ($! == &EAGAIN ) { + if ( $self->{Maxtemperrors} !~ /^unlimited/i + and $temperrs++ > ($self->{Maxtemperrors}||10) + ) { + $self->LastError("Persistent '${!}' errors\n"); + $self->_debug("Persistent '${!}' errors\n"); + return undef; + } + $optimize = 1; + } else { + # avoid infinite loops on syswrite error + return undef unless(defined $ret); + } + # Optimization of wait time between syswrite calls + # only runs if syscalls run too fast and fill the + # buffer causing "EAGAIN: Resource Temp. Unavail" errors. The + # premise is that $maxwrite will be approx. the same as + # the smallest buffer between the sending and receiving side. + # Waiting time between syscalls should ideally be exactly as + # long as it takes the receiving side to empty that buffer, + # minus a little bit to prevent it from + # emptying completely and wasting time in the select call. + if ($optimize) { + my $waittime = .02; + $maxwrite = $ret if $maxwrite < $ret; + push( @last5writes, $ret ); + shift( @last5writes ) if $#last5writes > 5; + my $bufferavail = 0; + $bufferavail += $_ for ( @last5writes ); + $bufferavail /= ($#last5writes||1); + # Buffer is staying pretty full; + # we should increase the wait period + # to reduce transmission overhead/number of packets sent + if ( $bufferavail < .4 * $maxwrite ) { + $waittime *= 1.3; + + # Buffer is nearly or totally empty; + # we're wasting time in select + # call that could be used to send data, + # so reduce the wait period + } elsif ( $bufferavail > .9 * $maxwrite ) { + $waittime *= .5; + } + CORE::select(undef, undef, undef, $waittime); + } + if ( defined($ret) ) { + $temperrs = 0 ; + } + $peer->_debug("Chunk $chunkCount: " . + "Wrote $wroteSoFar bytes (out of $chunk)\n"); + } + } + $position += $readSoFar ; + $leftSoFar -= $readSoFar; + $fromBuffer = ""; + # Finish up reading the server response from the fetch cmd + # on the source system: + { + my $code = 0; + until ( $code) { + + # escape infinite loop if read_line never returns any data: + + $self->_debug("Reading from source server; expecting " . + "') OK' type response\n") if $self->Debug; + + $output = $self->_read_line or return undef; + for my $o (@$output) { + + $self->_record($trans,$o); # $o is a ref + + # $self->_debug("Received from readline: " . + # "${\($o->[DATA])}<>\n"); + + next unless $self->_is_output($o); + + ($code) = $o->[DATA] =~ /^$trans (OK|BAD|NO)/mi ; + + if ($o->[DATA] =~ /^\*\s+BYE/im) { + $self->State(Unconnected); + return undef ; + } + } + } + } # end scope for my $code + } + # Now let's send a to the peer to signal end of APPEND cmd: + { + my $wroteSoFar = 0; + $fromBuffer = "\x0d\x0a"; + $!=0; + $wroteSoFar += syswrite($toSock,$fromBuffer,2-$wroteSoFar,$wroteSoFar)||0 + until $wroteSoFar >= 2; + + } + # Finally, let's get the new message's UID from the peer: + my $new_mid = ""; + { + my $code = 0; + until ( $code) { + # escape infinite loop if read_line never returns any data: + $peer->_debug("Reading from target: " . + "expecting new uid in response\n") if $peer->Debug; + + $output = $peer->_read_line or next MIGMSG; + + for my $o (@$output) { + + $peer->_record($ptrans,$o); # $o is a ref + + # $peer->_debug("Received from readline: " . + # "${\($o->[DATA])}<>\n"); + + next unless $peer->_is_output($o); + + ($code) = $o->[DATA] =~ /^$ptrans (OK|BAD|NO)/mi ; + ($new_mid)= $o->[DATA] =~ /APPENDUID \d+ (\d+)/ if $code; + #$peer->_debug("Code line: " . $o->[DATA] . + # "\nCode=$code mid=$new_mid\n" ) if $code; + + if ($o->[DATA] =~ /^\*\s+BYE/im) { + $peer->State(Unconnected); + return undef ; + } + } + $new_mid||="unknown" ; + } + } # end scope for my $code + + $self->_debug("Copied message $mid in folder $folder to " . $peer->User . + '@' . $peer->Server . ". New Message UID is $new_mid.\n" + ) if $self->Debug; + + $peer->_debug("Copied message $mid in folder $folder from " . $self->User . + '@' . $self->Server . ". New Message UID is $new_mid.\n" + ) if $peer->Debug; + + + # ... and finish up reading the server response from the fetch cmd + # on the source system: + # { + # my $code = 0; + # until ( $code) { + # # escape infinite loop if read_line never returns any data: + # unless ($output = $self->_read_line ) { + # $self->_debug($self->LastError) ; + # next MIGMSG; + # } + # for my $o (@$output) { +# +# $self->_record($trans,$o); # $o is a ref +# +# # $self->_debug("Received from readline: " . +# # "${\($o->[DATA])}<>\n"); +# +# next unless $self->_is_output($o); +# +# ($code) = $o->[DATA] =~ /^$trans (OK|BAD|NO)/mi ; +# +# if ($o->[DATA] =~ /^\*\s+BYE/im) { +# $self->State(Unconnected); +# return undef ; +# } +# } +# } +# } + + # and clean up the I/O buffer: + $fromBuffer = ""; + } + return $self; +} + + +sub body_string { + my $self = shift; + my $msg = shift; + my $ref = $self->fetch($msg,"BODY" . ( $self->Peek ? ".PEEK" : "" ) . "[TEXT]"); + + my $string = ""; + foreach my $result (@{$ref}) { + $string .= $result->[DATA] if defined($result) and $self->_is_literal($result) ; + } + return $string if $string; + + my $head = shift @$ref; + $self->_debug("body_string: first shift = '$head'\n"); + + until ( (! $head) or $head =~ /(?:.*FETCH .*\(.*BODY\[TEXT\])|(?:^\d+ BAD )|(?:^\d NO )/i ) { + $self->_debug("body_string: shifted '$head'\n"); + $head = shift(@$ref) ; + } + unless ( scalar(@$ref) ) { + $self->LastError("Unable to parse server response from " . $self->LastIMAPCommand ); + return undef ; + } + my $popped ; $popped = pop @$ref until + ( + ( defined($popped) and + # (-: Smile! + $popped =~ /\)\x0d\x0a$/ + ) or + not grep( + # (-: Smile again! + /\)\x0d\x0a$/, + @$ref + ) + ); + + if ($head =~ /BODY\[TEXT\]\s*$/i ) { # Next line is a literal + $string .= shift @$ref while scalar(@$ref); + $self->_debug("String is now $string\n") if $self->Debug; + } + + return $string||undef; +} + + +sub examine { + my $self = shift; + my $target = shift ; return undef unless defined($target); + $target = $self->Massage($target); + my $string = qq/EXAMINE $target/; + + my $old = $self->Folder; + + if ($self->_imap_command($string) and $self->State(Selected)) { + $self->Folder($target); + return $old||$self; + } else { + return undef; + } +} + +sub idle { + my $self = shift; + my $good = '+'; + my $count = $self->Count +1; + return $self->_imap_command("IDLE",$good) ? $count : undef; +} + +sub done { + my $self = shift; + + my $count = shift||$self->Count; + + my $clear = ""; + $clear = $self->Clear; + + $self->Clear($clear) + if $self->Count >= $clear and $clear > 0; + + my $string = "DONE\x0d\x0a"; + $self->_record($count,[ $self->_next_index($count), "INPUT", "$string\x0d\x0a"] ); + + my $feedback = $self->_send_line("$string",1); + + unless ($feedback) { + $self->LastError( "Error sending '$string' to IMAP: $!\n"); + return undef; + } + + my ($code, $output); + $output = ""; + + until ( $code and $code =~ /(OK|BAD|NO)/m ) { + + $output = $self->_read_line or return undef; + for my $o (@$output) { + $self->_record($count,$o); # $o is a ref + next unless $self->_is_output($o); + ($code) = $o->[DATA] =~ /^(?:$count) (OK|BAD|NO)/m ; + if ($o->[DATA] =~ /^\*\s+BYE/) { + $self->State(Unconnected); + } + } + } + return $code =~ /^OK/ ? @{$self->Results} : undef ; + +} + +sub tag_and_run { + my $self = shift; + my $string = shift; + my $good = shift; + $self->_imap_command($string,$good); + return @{$self->Results}; +} +# _{name} methods are undocumented and meant to be private. + +# _imap_command runs a command, inserting the correct tag +# and and whatnot. +# When updating _imap_command, remember to examine the run method, too, since it is very similar. +# + +sub _imap_command { + + my $self = shift; + my $string = shift or return undef; + my $good = shift || 'GOOD'; + + my $qgood = quotemeta($good); + + my $clear = ""; + $clear = $self->Clear; + + $self->Clear($clear) + if $self->Count >= $clear and $clear > 0; + + my $count = $self->Count($self->Count+1); + + $string = "$count $string" ; + + $self->_record($count,[ 0, "INPUT", "$string\x0d\x0a"] ); + + my $feedback = $self->_send_line("$string"); + + unless ($feedback) { + $self->LastError( "Error sending '$string' to IMAP: $!\n"); + $@ = "Error sending '$string' to IMAP: $!"; + carp "Error sending '$string' to IMAP: $!" if $^W; + return undef; + } + + my ($code, $output); + $output = ""; + + READ: until ( $code) { + # escape infinite loop if read_line never returns any data: + $output = $self->_read_line or return undef; + + for my $o (@$output) { + $self->_record($count,$o); # $o is a ref + # $self->_debug("Received from readline: ${\($o->[DATA])}<>\n"); + next unless $self->_is_output($o); + if ( $good eq '+' ) { + $o->[DATA] =~ /^$count (OK|BAD|NO|$qgood)|^($qgood)/mi ; + $code = $1||$2 ; + } else { + ($code) = $o->[DATA] =~ /^$count (OK|BAD|NO|$qgood)/mi ; + } + if ($o->[DATA] =~ /^\*\s+BYE/im) { + $self->State(Unconnected); + return undef ; + } + } + } + + # $self->_debug("Command $string: returned $code\n"); + return $code =~ /^OK|$qgood/im ? $self : undef ; + +} + +sub run { + my $self = shift; + my $string = shift or return undef; + my $good = shift || 'GOOD'; + my $count = $self->Count($self->Count+1); + my($tag) = $string =~ /^(\S+) / ; + + unless ($tag) { + $self->LastError("Invalid string passed to run method; no tag found.\n"); + } + + my $qgood = quotemeta($good); + + my $clear = ""; + $clear = $self->Clear; + + $self->Clear($clear) + if $self->Count >= $clear and $clear > 0; + + $self->_record($count,[ $self->_next_index($count), "INPUT", "$string"] ); + + my $feedback = $self->_send_line("$string",1); + + unless ($feedback) { + $self->LastError( "Error sending '$string' to IMAP: $!\n"); + return undef; + } + + my ($code, $output); + $output = ""; + + until ( $code =~ /(OK|BAD|NO|$qgood)/m ) { + + $output = $self->_read_line or return undef; + for my $o (@$output) { + $self->_record($count,$o); # $o is a ref + next unless $self->_is_output($o); + if ( $good eq '+' ) { + $o->[DATA] =~ /^(?:$tag|\*) (OK|BAD|NO|$qgood)|(^$qgood)/m ; + $code = $1||$2; + } else { + ($code) = + $o->[DATA] =~ /^(?:$tag|\*) (OK|BAD|NO|$qgood)/m ; + } + if ($o->[DATA] =~ /^\*\s+BYE/) { + $self->State(Unconnected); + } + } + } + $self->{'History'}{$tag} = $self->{"History"}{$count} unless $tag eq $count; + return $code =~ /^OK|$qgood/ ? @{$self->Results} : undef ; + +} +#sub bodystruct { # return bodystruct +#} + +# _record saves the conversation into the History structure: +sub _record { + + my ($self,$count,$array) = ( shift, shift, shift); + local($^W)= undef; + + #$self->_debug(sprintf("in _record: count is $count, values are %s/%s/%s and caller is " . + # join(":",caller()) . "\n",@$array)); + + if ( # $array->[DATA] and + $array->[DATA] =~ /^\d+ LOGIN/i and + ! $self->Showcredentials + ) { + + $array->[DATA] =~ s/LOGIN.*/LOGIN XXXXXXXX XXXXXXXX/i ; + } + + push @{$self->{"History"}{$count}}, $array; + + if ( $array->[DATA] =~ /^\d+\s+(BAD|NO)\s/im ) { + $self->LastError("$array->[DATA]") ; + $@ = $array->[DATA]; + carp "$array->[DATA]" if $^W ; + } + return $self; +} + +#_send_line writes to the socket: +sub _send_line { + my($self,$string,$suppress) = (shift, shift, shift); + + #$self->_debug("_send_line: Connection state = " . + # $self->State . " and socket fh = " . + # ($self->Socket||"undef") . "\n") + #if $self->Debug; + + unless ($self->IsConnected and $self->Socket) { + $self->LastError("NO Not connected.\n"); + carp "Not connected" if $^W; + return undef; + } + + unless ($string =~ /\x0d\x0a$/ or $suppress ) { + + chomp $string; + $string .= "\x0d" unless $string =~ /\x0d$/; + $string .= "\x0a" ; + } + if ( + $string =~ /^[^\x0a{]*\{(\d+)\}\x0d\x0a/ # ;-} + ) { + my($p1,$p2,$len) ; + if ( ($p1,$len) = + $string =~ /^([^\x0a{]*\{(\d+)\}\x0d\x0a)/ # } for vi + and ( + $len < 32766 ? + ( ($p2) = $string =~ / + ^[^\x0a{]* + \{\d+\} + \x0d\x0a + ( + .{$len} + .*\x0d\x0a + ) + /x ) : + + ( ($p2) = $string =~ / ^[^\x0a{]* + \{\d+\} + \x0d\x0a + (.*\x0d\x0a) + /x + and length($p2) == $len ) # }} for vi + ) + ) { + $self->_debug("Sending literal string " . + "in two parts: $p1\n\tthen: $p2\n"); + $self->_send_line($p1) or return undef; + $output = $self->_read_line or return undef; + foreach my $o (@$output) { + # $o is already an array ref: + $self->_record($self->Count,$o); + ($code) = $o->[DATA] =~ /(^\+|NO|BAD)/i; + if ($o->[DATA] =~ /^\*\s+BYE/) { + $self->State(Unconnected); + close $fh; + return undef ; + } elsif ( $o->[DATA]=~ /^\d+\s+(NO|BAD)/i ) { + close $fh; + return undef; + } + } + if ( $code eq '+' ) { $string = $p2; } + else { return undef ; } + } + + } + if ($self->Debug) { + my $dstring = $string; + if ( $dstring =~ m[\d+\s+Login\s+]i) { + $dstring =~ + s(\b(?:\Q$self->{Password}\E|\Q$self->{User}\E)\b) + ('X' x length($self->{Password}))eg; + } + _debug $self, "Sending: $dstring\n" if $self->Debug; + } + my $total = 0; + my $temperrs = 0; + my $optimize = 0; + my $maxwrite = 0; + my $waittime = .02; + my @last5writes = (1); + $string = $self->Prewritemethod->($self,$string) if $self->Prewritemethod; + _debug $self, "Sending: $string\n" if $self->Debug and $self->Prewritemethod; + + until ($total >= length($string)) { + my $ret = 0; + $!=0; + $ret = syswrite( + $self->Socket, + $string, + length($string)-$total, + $total + ); + $ret||=0; + if ($! == &EAGAIN ) { + if ( $self->{Maxtemperrors} !~ /^unlimited/i + and $temperrs++ > ($self->{Maxtemperrors}||10) + ) { + $self->LastError("Persistent '${!}' errors\n"); + $self->_debug("Persistent '${!}' errors\n"); + return undef; + } + $optimize = 1; + } else { + # avoid infinite loops on syswrite error + return undef unless(defined $ret); + } + # Optimization of wait time between syswrite calls + # only runs if syscalls run too fast and fill the + # buffer causing "EAGAIN: Resource Temp. Unavail" errors. The + # premise is that $maxwrite will be approx. the same as + # the smallest buffer between the sending and receiving side. + # Waiting time between syscalls should ideally be exactly as + # long as it takes the receiving side to empty that buffer, + # minus a little bit to prevent it from + # emptying completely and wasting time in the select call. + if ($optimize) { + $maxwrite = $ret if $maxwrite < $ret; + push( @last5writes, $ret ); + shift( @last5writes ) if $#last5writes > 5; + my $bufferavail = 0; + $bufferavail += $_ for ( @last5writes ); + $bufferavail /= $#last5writes; + # Buffer is staying pretty full; + # we should increase the wait period + # to reduce transmission overhead/number of packets sent + if ( $bufferavail < .4 * $maxwrite ) { + $waittime *= 1.3; + + # Buffer is nearly or totally empty; + # we're wasting time in select + # call that could be used to send data, + # so reduce the wait period + } elsif ( $bufferavail > .9 * $maxwrite ) { + $waittime *= .5; + } + $self->_debug("Output buffer full; waiting $waittime seconds for relief\n"); + CORE::select(undef, undef, undef, $waittime); + } + if ( defined($ret) ) { + $temperrs = 0 ; + $total += $ret ; + } + } + _debug $self,"Sent $total bytes\n" if $self->Debug; + return $total; +} + +# _read_line reads from the socket. It is called by: +# append append_file authenticate connect _imap_command +# +# It is also re-implemented in: +# message_to_file +# +# syntax: $output = $self->_readline( ( $literal_callback|undef ) , ( $output_callback|undef ) ) ; +# Both input argument are optional, but if supplied must either be a filehandle, coderef, or undef. +# +# Returned argument is a reference to an array of arrays, ie: +# $output = [ +# [ $index, 'OUTPUT'|'LITERAL', $output_line ] , +# [ $index, 'OUTPUT'|'LITERAL', $output_line ] , +# ... # etc, +# ]; + +sub _read_line { + my $self = shift; + my $sh = $self->Socket; + my $literal_callback = shift; + my $output_callback = shift; + + unless ($self->IsConnected and $self->Socket) { + $self->LastError("NO Not connected.\n"); + carp "Not connected" if $^W; + return undef; + } + + my $iBuffer = ""; + my $oBuffer = []; + my $count = 0; + my $index = $self->_next_index($self->Transaction); + my $rvec = my $ready = my $errors = 0; + my $timeout = $self->Timeout; + + my $readlen = 1; + my $fast_io = $self->Fast_io; # Remember setting to reduce future method calls + + if ( $fast_io ) { + + # set fcntl if necessary: + exists $self->{_fcntl} or $self->Fast_io($fast_io); + $readlen = $self->{Buffer}||4096; + } + until ( + # there's stuff in output buffer: + scalar(@$oBuffer) and + + # the last thing there has cr-lf: + $oBuffer->[-1][DATA] =~ /\x0d\x0a$/ and + + # that thing is an output line: + $oBuffer->[-1][TYPE] eq "OUTPUT" and + + # and the input buffer has been MT'ed: + $iBuffer eq "" + + ) { + my $transno = $self->Transaction; # used below in several places + if ($timeout) { + vec($rvec, fileno($self->Socket), 1) = 1; + my @ready = $self->{_select}->can_read($timeout) ; + unless ( @ready ) { + $self->LastError("Tag $transno: " . + "Timeout after $timeout seconds " . + "waiting for data from server\n"); + $self->_record($transno, + [ $self->_next_index($transno), + "ERROR", + "$transno * NO Timeout after ". + "$timeout seconds " . + "during read from " . + "server\x0d\x0a" + ] + ); + $self->LastError( + "Timeout after $timeout seconds " . + "during read from server\x0d\x0a" + ); + return undef; + } + } + + local($^W) = undef; # Now quiet down warnings + + # read "$readlen" bytes (or less): + # need to check return code from $self->_sysread + # in case other end has shut down!!! + my $ret = $self->_sysread( $sh, \$iBuffer, $readlen, length($iBuffer)) ; + # $self->_debug("Read so far: $iBuffer<>\n"); + if($timeout and ! defined($ret)) { # Blocking read error... + my $msg = "Error while reading data from server: $!\x0d\x0a"; + $self->_record($transno, + [ $self->_next_index($transno), + "ERROR", "$transno * NO $msg " + ]); + $@ = "$msg"; + return undef; + } + elsif(defined($ret) and $ret == 0) { # Caught EOF... + my $msg="Socket closed while reading data from server.\x0d\x0a"; + $self->_record($transno, + [ $self->_next_index($transno), + "ERROR", "$transno * NO $msg " + ]); + $@ = "$msg"; + return undef; + } + # successfully wrote to other end, keep going... + $count += $ret if defined($ret); + LINES: while ( $iBuffer =~ s/^(.*?\x0d?\x0a)// ) { + my $current_line = $1; + + # $self->_debug("BUFFER: pulled from buffer: ${current_line}\n" . + # "and left with buffer contents of: ${iBuffer}\n"); + + LITERAL: if ($current_line =~ s/\{(\d+)\}\x0d\x0a$//) { + # This part handles IMAP "Literals", + # which according to rfc2060 look something like this: + # [tag]|* BLAH BLAH {nnn}\r\n + # [nnn bytes of literally transmitted stuff] + # [part of line that follows literal data]\r\n + + # Set $len to be length of impending literal: + my $len = $1 ; + + $self->_debug("LITERAL: received literal in line ". + "$current_line of length $len; ". + "attempting to ". + "retrieve from the " . length($iBuffer) . + " bytes in: $iBuffer\n"); + + # Xfer up to $len bytes from front of $iBuffer to $litstring: + my $litstring = substr($iBuffer, 0, $len); + $iBuffer = substr($iBuffer, length($litstring), + length($iBuffer) - length($litstring) ) ; + + # Figure out what's left to read (i.e. what part of + # literal wasn't in buffer): + my $remainder_count = $len - length($litstring); + my $callback_value = ""; + + if ( defined($literal_callback) ) { + if ( $literal_callback =~ /GLOB/) { + print $literal_callback $litstring ; + $litstring = ""; + } elsif ($literal_callback =~ /CODE/ ) { + # Don't do a thing + + } else { + $self->LastError( + ref($literal_callback) . + " is an invalid callback type; " . + "must be a filehandle or coderef\n" + ); + } + + + } + if ($remainder_count > 0 and $timeout) { + # If we're doing timeouts then here we set up select + # and wait for data from the the IMAP socket. + vec($rvec, fileno($self->Socket), 1) = 1; + unless ( CORE::select( $ready = $rvec, + undef, + $errors = $rvec, + $timeout) + ) { + # Select failed; that means bad news. + # Better tell someone. + $self->LastError("Tag " . $transno . + ": Timeout waiting for literal data " . + "from server\n"); + carp "Tag " . $transno . + ": Timeout waiting for literal data " . + "from server\n" + if $self->Debug or $^W; + return undef; + } + } + + fcntl($sh, F_SETFL, $self->{_fcntl}) + if $fast_io and defined($self->{_fcntl}); + while ( $remainder_count > 0 ) { # As long as not done, + $self->_debug("Still need $remainder_count to " . + "complete literal string\n"); + my $ret = $self->_sysread( # bytes read + $sh, # IMAP handle + \$litstring, # place to read into + $remainder_count, # bytes left to read + length($litstring) # offset to read into + ) ; + $self->_debug("Received ret=$ret and buffer = " . + "\n$litstring\nwhile processing LITERAL\n"); + if ( $timeout and !defined($ret)) { # possible timeout + $self->_record($transno, [ + $self->_next_index($transno), + "ERROR", + "$transno * NO Error reading data " . + "from server: $!\n" + ] + ); + return undef; + } elsif ( $ret == 0 and eof($sh) ) { + $self->_record($transno, [ + $self->_next_index($transno), + "ERROR", + "$transno * ". + "BYE Server unexpectedly " . + "closed connection: $!\n" + ] + ); + $self->State(Unconnected); + return undef; + } + # decrement remaining bytes by amt read: + $remainder_count -= $ret; + + if ( length($litstring) > $len ) { + # copy the extra struff into the iBuffer: + $iBuffer = substr( + $litstring, + $len, + length($litstring) - $len + ); + $litstring = substr($litstring, 0, $len) ; + } + + if ( defined($literal_callback) ) { + if ( $literal_callback =~ /GLOB/ ) { + print $literal_callback $litstring; + $litstring = ""; + } + } + + } + $literal_callback->($litstring) + if defined($litstring) and + $literal_callback =~ /CODE/; + + $self->Fast_io($fast_io) if $fast_io; + + # Now let's make sure there are no IMAP server output lines + # (i.e. [tag|*] BAD|NO|OK Text) embedded in the literal string + # (There shouldn't be but I've seen it done!), but only if + # EnableServerResponseInLiteral is set to true + + my $embedded_output = 0; + my $lastline = ( split(/\x0d?\x0a/,$litstring))[-1] + if $litstring; + + if ( $self->EnableServerResponseInLiteral and + $lastline and + $lastline =~ /^(?:\*|(\d+))\s(BAD|NO|OK)/i + ) { + $litstring =~ s/\Q$lastline\E\x0d?\x0a//; + $embedded_output++; + + $self->_debug("Got server output mixed in " . + "with literal: $lastline\n" + ) if $self->Debug; + + } + # Finally, we need to stuff the literal onto the + # end of the oBuffer: + push @$oBuffer, [ $index++, "OUTPUT" , $current_line], + [ $index++, "LITERAL", $litstring ]; + push @$oBuffer, [ $index++, "OUTPUT", $lastline ] + if $embedded_output; + + } else { + push @$oBuffer, [ $index++, "OUTPUT" , $current_line ]; + } + + } + #$self->_debug("iBuffer is now: $iBuffer<>\n"); + } + # _debug $self, "Buffer is now $buffer\n"; + _debug $self, "Read: " . join("",map {$_->[DATA]} @$oBuffer) ."\n" + if $self->Debug; + return scalar(@$oBuffer) ? $oBuffer : undef ; +} + +sub _sysread { + my $self = shift @_; + if ( exists $self->{Readmethod} ) { + return $self->Readmethod->($self,@_) ; + } else { + my($handle,$buffer,$count,$offset) = @_; + return sysread( $handle, $$buffer, $count, $offset); + } +} + +=begin obsolete + +sub old_read_line { + my $self = shift; + my $sh = $self->Socket; + my $literal_callback = shift; + my $output_callback = shift; + + unless ($self->IsConnected and $self->Socket) { + $self->LastError("NO Not connected.\n"); + carp "Not connected" if $^W; + return undef; + } + + my $iBuffer = ""; + my $oBuffer = []; + my $count = 0; + my $index = $self->_next_index($self->Transaction); + my $rvec = my $ready = my $errors = 0; + my $timeout = $self->Timeout; + + my $readlen = 1; + my $fast_io = $self->Fast_io; # Remember setting to reduce future method calls + + if ( $fast_io ) { + + # set fcntl if necessary: + exists $self->{_fcntl} or $self->Fast_io($fast_io); + $readlen = $self->{Buffer}||4096; + } + until ( + # there's stuff in output buffer: + scalar(@$oBuffer) and + + # the last thing there has cr-lf: + $oBuffer->[-1][DATA] =~ /\x0d\x0a$/ and + + # that thing is an output line: + $oBuffer->[-1][TYPE] eq "OUTPUT" and + + # and the input buffer has been MT'ed: + $iBuffer eq "" + + ) { + my $transno = $self->Transaction; # used below in several places + if ($timeout) { + vec($rvec, fileno($self->Socket), 1) = 1; + my @ready = $self->{_select}->can_read($timeout) ; + unless ( @ready ) { + $self->LastError("Tag $transno: " . + "Timeout after $timeout seconds " . + "waiting for data from server\n"); + $self->_record($transno, + [ $self->_next_index($transno), + "ERROR", + "$transno * NO Timeout after ". + "$timeout seconds " . + "during read from " . + "server\x0d\x0a" + ] + ); + $self->LastError( + "Timeout after $timeout seconds " . + "during read from server\x0d\x0a" + ); + return undef; + } + } + + local($^W) = undef; # Now quiet down warnings + + # read "$readlen" bytes (or less): + # need to check return code from sysread in case other end has shut down!!! + my $ret = sysread( $sh, $iBuffer, $readlen, length($iBuffer)) ; + # $self->_debug("Read so far: $iBuffer<>\n"); + if($timeout and ! defined($ret)) { # Blocking read error... + my $msg = "Error while reading data from server: $!\x0d\x0a"; + $self->_record($transno, + [ $self->_next_index($transno), + "ERROR", "$transno * NO $msg " + ]); + $@ = "$msg"; + return undef; + } + elsif(defined($ret) and $ret == 0) { # Caught EOF... + my $msg="Socket closed while reading data from server.\x0d\x0a"; + $self->_record($transno, + [ $self->_next_index($transno), + "ERROR", "$transno * NO $msg " + ]); + $@ = "$msg"; + return undef; + } + # successfully wrote to other end, keep going... + $count += $ret if defined($ret); + LINES: while ( $iBuffer =~ s/^(.*?\x0d?\x0a)// ) { + my $current_line = $1; + + # $self->_debug("BUFFER: pulled from buffer: ${current_line}\n" . + # "and left with buffer contents of: ${iBuffer}\n"); + + LITERAL: if ($current_line =~ s/\{(\d+)\}\x0d\x0a$//) { + # This part handles IMAP "Literals", which according to rfc2060 look something like this: + # [tag]|* BLAH BLAH {nnn}\r\n + # [nnn bytes of literally transmitted stuff] + # [part of line that follows literal data]\r\n + + # Set $len to be length of impending literal: + my $len = $1 ; + + $self->_debug("LITERAL: received literal in line $current_line of length $len; ". + "attempting to ". + "retrieve from the " . length($iBuffer) . " bytes in: $iBuffer\n"); + + # Transfer up to $len bytes from front of $iBuffer to $litstring: + my $litstring = substr($iBuffer, 0, $len); + $iBuffer = substr($iBuffer, length($litstring), length($iBuffer) - length($litstring) ) ; + + # Figure out what's left to read (i.e. what part of literal wasn't in buffer): + my $remainder_count = $len - length($litstring); + my $callback_value = ""; + + if ( defined($literal_callback) ) { + if ( $literal_callback =~ /GLOB/) { + print $literal_callback $litstring ; + $litstring = ""; + } elsif ($literal_callback =~ /CODE/ ) { + # Don't do a thing + + } else { + $self->LastError( + ref($literal_callback) . + " is an invalid callback type; must be a filehandle or coderef" + ); + } + + + } + if ($remainder_count > 0 and $timeout) { + # If we're doing timeouts then here we set up select and wait for data from the + # the IMAP socket. + vec($rvec, fileno($self->Socket), 1) = 1; + unless ( CORE::select( $ready = $rvec, + undef, + $errors = $rvec, + $timeout) + ) { + # Select failed; that means bad news. + # Better tell someone. + $self->LastError("Tag " . $transno . + ": Timeout waiting for literal data " . + "from server\n"); + carp "Tag " . $transno . + ": Timeout waiting for literal data " . + "from server\n" + if $self->Debug or $^W; + return undef; + } + } + + fcntl($sh, F_SETFL, $self->{_fcntl}) + if $fast_io and defined($self->{_fcntl}); + while ( $remainder_count > 0 ) { # As long as not done, + + my $ret = sysread( # bytes read + $sh, # IMAP handle + $litstring, # place to read into + $remainder_count, # bytes left to read + length($litstring) # offset to read into + ) ; + if ( $timeout and !defined($ret)) { # possible timeout + $self->_record($transno, [ + $self->_next_index($transno), + "ERROR", + "$transno * NO Error reading data " . + "from server: $!\n" + ] + ); + return undef; + } elsif ( $ret == 0 and eof($sh) ) { + $self->_record($transno, [ + $self->_next_index($transno), + "ERROR", + "$transno * ". + "BYE Server unexpectedly " . + "closed connection: $!\n" + ] + ); + $self->State(Unconnected); + return undef; + } + # decrement remaining bytes by amt read: + $remainder_count -= $ret; + + if ( defined($literal_callback) ) { + if ( $literal_callback =~ /GLOB/ ) { + print $literal_callback $litstring; + $litstring = ""; + } + } + + } + $literal_callback->($litstring) + if defined($litstring) and + $literal_callback =~ /CODE/; + + $self->Fast_io($fast_io) if $fast_io; + + # Now let's make sure there are no IMAP server output lines + # (i.e. [tag|*] BAD|NO|OK Text) embedded in the literal string + # (There shouldn't be but I've seen it done!), but only if + # EnableServerResponseInLiteral is set to true + + my $embedded_output = 0; + my $lastline = ( split(/\x0d?\x0a/,$litstring))[-1] + if $litstring; + + if ( $self->EnableServerResponseInLiteral and + $lastline and + $lastline =~ /^(?:\*|(\d+))\s(BAD|NO|OK)/i + ) { + $litstring =~ s/\Q$lastline\E\x0d?\x0a//; + $embedded_output++; + + $self->_debug("Got server output mixed in " . + "with literal: $lastline\n" + ) if $self->Debug; + + } + # Finally, we need to stuff the literal onto the + # end of the oBuffer: + push @$oBuffer, [ $index++, "OUTPUT" , $current_line], + [ $index++, "LITERAL", $litstring ]; + push @$oBuffer, [ $index++, "OUTPUT", $lastline ] + if $embedded_output; + + } else { + push @$oBuffer, [ $index++, "OUTPUT" , $current_line ]; + } + + } + #$self->_debug("iBuffer is now: $iBuffer<>\n"); + } + # _debug $self, "Buffer is now $buffer\n"; + _debug $self, "Read: " . join("",map {$_->[DATA]} @$oBuffer) ."\n" + if $self->Debug; + return scalar(@$oBuffer) ? $oBuffer : undef ; +} + +=end obsolete + +=cut + + +sub Report { + my $self = shift; +# $self->_debug( "Dumper: " . Data::Dumper::Dumper($self) . +# "\nReporting on following keys: " . join(", ",keys %{$self->{'History'}}). "\n"); + return map { + map { $_->[DATA] } @{$self->{"History"}{$_}} + } sort { $a <=> $b } keys %{$self->{"History"}} + ; +} + + +sub Results { + my $self = shift ; + my $transaction = shift||$self->Count; + + return wantarray ? + map {$_->[DATA] } @{$self->{"History"}{$transaction}} : + [ map {$_->[DATA] } @{$self->{"History"}{$transaction}} ] ; +} + + +sub LastIMAPCommand { + my @a = map { $_->[DATA] } @{$_[0]->{"History"}{$_[1]||$_[0]->Transaction}}; + return shift @a; +} + + +sub History { + my @a = map { $_->[DATA] } @{$_[0]->{"History"}{$_[1]||$_[0]->Transaction}}; + shift @a; + return wantarray ? @a : \@a ; + +} + +sub Escaped_results { + my @a; + foreach my $line (@{$_[0]->{"History"}{$_[1]||$_[0]->Transaction}} ) { + if ( defined($line) and $_[0]->_is_literal($line) ) { + $line->[DATA] =~ s/([\\\(\)"\x0d\x0a])/\\$1/g ; + push @a, qq("$line->[DATA]"); + } else { + push @a, $line->[DATA] ; + } + } + # $a[0] is the ALWAYS the command ; I make sure of that in _imap_command + shift @a; + return wantarray ? @a : \@a ; +} + +sub Unescape { + shift @_ if $_[1]; + my $whatever = shift; + $whatever =~ s/\\([\\\(\)"\x0d\x0a])/$1/g if defined $whatever; + return $whatever; +} + +sub logout { + my $self = shift; + my $string = "LOGOUT"; + $self->_imap_command($string) ; + $self->{Folders} = undef; + $self->{_IMAP4REV1} = undef; + eval {$self->Socket->close if defined($self->Socket)} ; + $self->{Socket} = undef; + $self->State(Unconnected); + return $self; +} + +sub folders { + my $self = shift; + my $what = shift ; + return wantarray ? @{$self->{Folders}} : + $self->{Folders} + if ref($self->{Folders}) and !$what; + + my @folders ; + my @list = $self->list(undef,( $what? "$what" . $self->separator($what) . "*" : undef ) ); + push @list, $self->list(undef, $what) if $what and $self->exists($what) ; + # my @list = + # foreach (@list) { $self->_debug("Pushing $_\n"); } + my $m; + + for ($m = 0; $m < scalar(@list); $m++ ) { + # $self->_debug("Folders: examining $list[$m]\n"); + + if ($list[$m] && $list[$m] !~ /\x0d\x0a$/ ) { + $self->_debug("folders: concatenating $list[$m] and " . $list[$m+1] . "\n") ; + $list[$m] .= $list[$m+1] ; + $list[$m+1] = ""; + $list[$m] .= "\x0d\x0a" unless $list[$m] =~ /\x0d\x0a$/; + } + + + + push @folders, $1||$2 + if $list[$m] =~ + / ^\*\s+LIST # * LIST + \s+\([^\)]*\)\s+ # (Flags) + (?:"[^"]*"|NIL)\s+ # "delimiter" or NIL + (?:"([^"]*)"|(.*))\x0d\x0a$ # Name or "Folder name" + /ix; + #$folders[-1] = '"' . $folders[-1] . '"' + # if $1 and !$self->exists($folders[-1]) ; + # $self->_debug("folders: line $list[$m]: 1=$1 and 2=$2\n"); + } + + # for my $f (@folders) { $f =~ s/^\\FOLDER LITERAL:://;} + my @clean = (); my %memory = (); + foreach my $f (@folders) { push @clean, $f unless $memory{$f}++ } + $self->{Folders} = \@clean unless $what; + + return wantarray ? @clean : \@clean ; +} + + +sub exists { + my ($self,$what) = (shift,shift); + return $self if $self->STATUS($self->Massage($what),"(MESSAGES)"); + return undef; +} + +# Updated to handle embedded literal strings +sub get_bodystructure { + my($self,$msg) = @_; + unless ( eval {require Mail::IMAPClient::BodyStructure ; 1 } ) { + $self->LastError("Unable to use get_bodystructure: $@\n"); + return undef; + } + my @out = $self->fetch($msg,"BODYSTRUCTURE"); + my $bs = ""; + my $output = grep( + /BODYSTRUCTURE \(/i, @out # Wee! ;-) + ); + if ( $output =~ /\r\n$/ ) { + eval { $bs = Mail::IMAPClient::BodyStructure->new( $output )}; + } else { + $self->_debug("get_bodystructure: reassembling original response\n"); + my $start = 0; + foreach my $o (@{$self->{"History"}{$self->Transaction}}) { + next unless $self->_is_output_or_literal($o); + $self->_debug("o->[DATA] is ".$o->[DATA]."\n"); + next unless $start or + $o->[DATA] =~ /BODYSTRUCTURE \(/i and ++$start; # Hi, vi! ;-) + if ( length($output) and $self->_is_literal($o) ) { + my $data = $o->[DATA]; + $data =~ s/"/\\"/g; + $data =~ s/\(/\\\(/g; + $data =~ s/\)/\\\)/g; + $output .= '"'.$data.'"'; + } else { + $output .= $o->[DATA] ; + } + $self->_debug("get_bodystructure: reassembled output=$output\n"); + } + eval { $bs = Mail::IMAPClient::BodyStructure->new( $output )}; + } + $self->_debug("get_bodystructure: msg $msg returns this ref: ". + ( $bs ? " $bs" : " UNDEF" ) + ."\n"); + return $bs; +} + +# Updated to handle embedded literal strings +sub get_envelope { + my($self,$msg) = @_; + unless ( eval {require Mail::IMAPClient::BodyStructure ; 1 } ) { + $self->LastError("Unable to use get_envelope: $@\n"); + return undef; + } + my @out = $self->fetch($msg,"ENVELOPE"); + my $bs = ""; + my $output = grep( + /ENVELOPE \(/i, @out # Wee! ;-) + ); + if ( $output =~ /\r\n$/ ) { + eval { + $bs = Mail::IMAPClient::BodyStructure::Envelope->new($output) + }; + } else { + $self->_debug("get_envelope: " . + "reassembling original response\n"); + my $start = 0; + foreach my $o (@{$self->{"History"}{$self->Transaction}}) { + next unless $self->_is_output_or_literal($o); + $self->_debug("o->[DATA] is ".$o->[DATA]."\n"); + next unless $start or + $o->[DATA] =~ /ENVELOPE \(/i and ++$start; + # Hi, vi! ;-) + if ( length($output) and $self->_is_literal($o) ) { + my $data = $o->[DATA]; + $data =~ s/"/\\"/g; + $data =~ s/\(/\\\(/g; + $data =~ s/\)/\\\)/g; + $output .= '"'.$data.'"'; + } else { + $output .= $o->[DATA] ; + } + $self->_debug("get_envelope: " . + "reassembled output=$output\n"); + } + eval { + $bs=Mail::IMAPClient::BodyStructure::Envelope->new($output) + }; + } + $self->_debug("get_envelope: msg $msg returns this ref: ". + ( $bs ? " $bs" : " UNDEF" ) + ."\n"); + return $bs; +} + +=begin obsolete + +sub old_get_envelope { + my($self,$msg) = @_; + unless ( eval {require Mail::IMAPClient::BodyStructure ; 1 } ) { + $self->LastError("Unable to use get_envelope: $@\n"); + return undef; + } + my $bs = ""; + my @out = $self->fetch($msg,"ENVELOPE"); + my $output = grep( + /ENVELOPE \(/i, @out # Wee! ;-) + ); + if ( $output =~ /\r\n$/ ) { + eval { $bs = Mail::IMAPClient::BodyStructure::Envelope->new( $output )}; + } else { + $self->_debug("get_envelope: reassembling original response\n"); + my $start = 0; + foreach my $o (@{$self->{"History"}{$self->Transaction}}) { + next unless $self->_is_output_or_literal($o); + $self->_debug("o->[DATA] is ".$o->[DATA]."\n"); + next unless $start or + $o->[DATA] =~ /ENVELOPE \(/i and ++$start; # Hi, vi! ;-) + if ( length($output) and $self->_is_literal($o) ) { + my $data = $o->[DATA]; + $data =~ s/"/\\"/g; + $data =~ s/\(/\\\(/g; + $data =~ s/\)/\\\)/g; + $output .= '"'.$data.'"'; + } else { + $output .= $o->[DATA] ; + } + } + $self->_debug("get_envelope: reassembled output=$output\n"); + eval { $bs = Mail::IMAPClient::BodyStructure->new( $output )}; + } + $self->_debug("get_envelope: msg $msg returns this ref: ". + ( $bs ? " $bs" : " UNDEF" ) + ."\n"); + return $bs; +} + +=end obsolete + +=cut + + +sub fetch { + + my $self = shift; + my $what = shift||"ALL"; + #ref($what) and $what = join(",",@$what); + if ( $what eq 'ALL' ) { + $what = $self->Range($self->messages ); + } elsif (ref($what) or $what =~ /^[,:\d]+\w*$/) { + $what = $self->Range($what); + } + $self->_imap_command( ( $self->Uid ? "UID " : "" ) . + "FETCH $what" . ( @_ ? " " . join(" ",@_) : '' ) + ) or return undef; + return wantarray ? $self->History($self->Count) : + [ map { $_->[DATA] } @{$self->{'History'}{$self->Count}} ]; + +} + + +sub fetch_hash { + my $self = shift; + my $hash = ref($_[-1]) ? pop @_ : {}; + my @words = @_; + for (@words) { + s/([\( ])FAST([\) ])/${1}FLAGS INTERNALDATE RFC822\.SIZE$2/i ; + s/([\( ])FULL([\) ])/${1}FLAGS INTERNALDATE RFC822\.SIZE ENVELOPE BODY$2/i ; + } + my $msgref = scalar($self->messages); + my $output = scalar($self->fetch($msgref,"(" . join(" ",@_) . ")")) + ; # unless grep(/\b(?:FAST|FULL)\b/i,@words); + my $x; + for ($x = 0; $x <= $#$output ; $x++) { + my $entry = {}; + my $l = $output->[$x]; + if ($self->Uid) { + my($uid) = $l =~ /\((?:.* )?UID (\d+).*\)/i; + next unless $uid; + if ( exists $hash->{$uid} ) { + $entry = $hash->{$uid} ; + } else { + $hash->{$uid} ||= $entry; + } + } else { + my($mid) = $l =~ /^\* (\d+) FETCH/i; + next unless $mid; + if ( exists $hash->{$mid} ) { + $entry = $hash->{$mid} ; + } else { + $hash->{$mid} ||= $entry; + } + } + + foreach my $w (@words) { + if ( $l =~ /\Q$w\E\s*$/i ) { + $entry->{$w} = $output->[$x+1]; + $entry->{$w} =~ s/(?:\x0a?\x0d)+$//g; + chomp $entry->{$w}; + } else { + $l =~ /\( # open paren followed by ... + (?:.*\s)? # ...optional stuff and a space + \Q$w\E\s # escaped fetch field + (?:" # then: a dbl-quote + (\\.| # then bslashed anychar(s) or ... + [^"]+) # ... nonquote char(s) + "| # then closing quote; or ... + \( # ...an open paren + (\\.| # then bslashed anychar or ... + [^\)]+) # ... non-close-paren char + \)| # then closing paren; or ... + (\S+)) # unquoted string + (?:\s.*)? # possibly followed by space-stuff + \) # close paren + /xi; + $entry->{$w}=defined($1)?$1:defined($2)?$2:$3; + } + } + } + return wantarray ? %$hash : $hash; +} +sub AUTOLOAD { + + my $self = shift; + return undef if $Mail::IMAPClient::AUTOLOAD =~ /DESTROY$/; + delete $self->{Folders} ; + my $autoload = $Mail::IMAPClient::AUTOLOAD; + $autoload =~ s/.*:://; + if ( + $^W + and $autoload =~ /^[a-z]+$/ + and $autoload !~ + /^ (?: + store | + copy | + subscribe| + create | + delete | + close | + expunge + )$ + /x + ) { + carp "$autoload is all lower-case. " . + "May conflict with future methods. " . + "Change method name to be mixed case or all upper case to ensure " . + "upward compatability" + } + if (scalar(@_)) { + my @a = @_; + if ( + $autoload =~ + /^(?:subscribe|delete|myrights)$/i + ) { + $a[-1] = $self->Massage($a[-1]) ; + } elsif ( + $autoload =~ + /^(?:create)$/i + ) { + $a[0] = $self->Massage($a[0]) ; + } elsif ( + $autoload =~ /^(?:store|copy)$/i + ) { + $autoload = "UID $autoload" + if $self->Uid; + } elsif ( + $autoload =~ /^(?:expunge)$/i and defined($_[0]) + ) { + my $old; + if ( $_[0] ne $self->Folder ) { + $old = $self->Folder; $self->select($_[0]); + } + my $succ = $self->_imap_command(qq/$autoload/) ; + $self->select($old); + return undef unless $succ; + return wantarray ? $self->History($self->Count) : + map {$_->[DATA]}@{$self->{'History'}{$self->Count}} ; + + } + $self->_debug("Autoloading: $autoload " . ( @a ? join(" ",@a):"" ) ."\n" ) + if $self->Debug; + return undef + unless $self->_imap_command( + qq/$autoload/ . ( @a ? " " . join(" ",@a) : "" ) + ) ; + } else { + $self->Folder(undef) if $autoload =~ /^(?:close)/i ; + $self->_imap_command(qq/$autoload/) or return undef; + } + return wantarray ? $self->History($self->Count) : + [map {$_->[DATA] } @{$self->{'History'}{$self->Count}}] ; + +} + +sub rename { + my $self = shift; + my ($from, $to) = @_; + local($_); + if ($from =~ /^"(.*)"$/) { + $from = $1 unless $self->exists($from); + $from =~ s/"/\\"/g; + } + if ($to =~ /^"(.*)"$/) { + $to = $1 unless $self->exists($from) and $from =~ /^".*"$/; + $to =~ s/"/\\"/g; + } + $self->_imap_command(qq(RENAME "$from" "$to")) or return undef; + return $self; +} + +sub status { + + my $self = shift; + my $box = shift ; + return undef unless defined($box); + $box = $self->Massage($box); + my @pieces = @_; + $self->_imap_command("STATUS $box (". (join(" ",@_)||'MESSAGES'). ")") or return undef; + return wantarray ? $self->History($self->Count) : + [map{$_->[DATA]}@{$self->{'History'}{$self->Count}}]; + +} + + +# Can take a list of messages now. +# If a single message, returns array or ref to array of flags +# If a ref to array of messages, returns a ref to hash of msgid => flag arr +# See parse_headers for more information +# 2000-03-22 Adrian Smith (adrian.smith@ucpag.com) + +sub flags { + my $self = shift; + my $msgspec = shift; + my $flagset = {}; + my $msg; + my $u_f = $self->Uid; + + # Determine if set of messages or just one + if (ref($msgspec) eq 'ARRAY' ) { + $msg = $self->Range($msgspec) ; + } elsif ( !ref($msgspec) ) { + $msg = $msgspec; + if ( scalar(@_) ) { + $msgspec = $self->Range($msg) ; + $msgspec += $_ for (@_); + $msg = $msgspec; + } + } elsif ( ref($msgspec) =~ /MessageSet/ ) { + if ( scalar(@_) ) { + $msgspec += $_ for @_; + } + } else { + $self->LastError("Invalid argument passed to fetch.\n"); + return undef; + } + + # Send command + unless ( $self->fetch($msg,"FLAGS") ) { + return undef; + } + + # Parse results, setting entry in result hash for each line + foreach my $resultline ($self->Results) { + $self->_debug("flags: line = '$resultline'\n") ; + if ( $resultline =~ + /\*\s+(\d+)\s+FETCH\s+ # * nnn FETCH + \( # open-paren + (?:\s?UID\s(\d+)\s?)? # optional: UID nnn + FLAGS\s?\((.*)\)\s? # FLAGS (\Flag1 \Flag2) + (?:\s?UID\s(\d+))? # optional: UID nnn + \) # close-paren + /x + ) { + { local($^W=0); + $self->_debug("flags: line = '$resultline' " . + "and 1,2,3,4 = $1,$2,$3,$4\n") + if $self->Debug; + } + my $mailid = $u_f ? ( $2||$4) : $1; + my $flagsString = $3 ; + my @flags = map { s/\s+$//; $_ } split(/\s+/, $flagsString); + $flagset->{$mailid} = \@flags; + } + } + + # Did the guy want just one response? Return it if so + unless (ref($msgspec) ) { + my $flagsref = $flagset->{$msgspec}; + return wantarray ? @$flagsref : $flagsref; + } + + # Or did he want a hash from msgid to flag array? + return $flagset; +} + +# parse_headers modified to allow second param to also be a +# reference to a list of numbers. If this is a case, the headers +# are read from all the specified messages, and a reference to +# an hash of mail numbers to references to hashes, are returned. +# I found, with a mailbox of 300 messages, this was +# *significantly* faster against our mailserver (< 1 second +# vs. 20 seconds) +# +# 2000-03-22 Adrian Smith (adrian.smith@ucpag.com) + +sub parse_headers { + my($self,$msgspec,@fields) = @_; + my(%fieldmap) = map { ( lc($_),$_ ) } @fields; + my $msg; my $string; my $field; + + # Make $msg a comma separated list, of messages we want + if (ref($msgspec) eq 'ARRAY') { + #$msg = join(',', @$msgspec); + $msg = $self->Range($msgspec); + } else { + $msg = $msgspec; + } + + if ($fields[0] =~ /^[Aa][Ll]{2}$/ ) { + + $string = "$msg body" . + # use ".peek" if Peek parameter is a) defined and true, + # or b) undefined, but not if it's defined and untrue: + + ( defined($self->Peek) ? + ( $self->Peek ? ".peek" : "" ) : + ".peek" + ) . "[header]" ; + + } else { + $string = "$msg body" . + # use ".peek" if Peek parameter is a) defined and true, or + # b) undefined, but not if it's defined and untrue: + + ( defined($self->Peek) ? + ( $self->Peek ? ".peek" : "" ) : + ".peek" + ) . "[header.fields (" . join(" ",@fields) . ')]' ; + } + + my @raw=$self->fetch( $string ) or return undef; + + my $headers = {}; # hash from message ids to header hash + my $h = 0; # reference to hash of current msgid, or 0 between msgs + + for my $header (map { split(/(?:\x0d\x0a)/,$_) } @raw) { + local($^W) = undef; + if ( $header =~ /^\*\s+\d+\s+FETCH\s+\(.*BODY\[HEADER(?:\]|\.FIELDS)/i) { + if ($self->Uid) { + if ( my($msgid) = $header =~ /UID\s+(\d+)/ ) { + $h = {}; + $headers->{$msgid} = $h; + } else { + $h = {}; + } + } else { + if ( my($msgid) = $header =~ /^\*\s+(\d+)/ ) { + #start of new message header: + $h = {}; + $headers->{$msgid} = $h; + } + } + } + next if $header =~ /^\s+$/; + + # ( for vi + if ($header =~ /^\)/) { # end of this message + $h = 0; # set to be between messages + next; + } + # check for 'UID)' + # when parsing headers by UID. + if ($self->Uid and my($msgid) = $header =~ /^\s*UID\s+(\d+)\s*\)/) { + $headers->{$msgid} = $h; # store in results against this message + $h = 0; # set to be between messages + next; + } + + if ($h != 0) { # do we expect this to be a header? + my $hdr = $header; + chomp $hdr; + $hdr =~ s/\r$//; + if ($hdr =~ s/^(\S+):\s*//) { + $field = exists $fieldmap{lc($1)} ? $fieldmap{lc($1)} : $1 ; + push @{$h->{$field}} , $hdr ; + } elsif ($hdr =~ s/^.*FETCH\s\(.*BODY\[HEADER\.FIELDS.*\)\]\s(\S+):\s*//) { + $field = exists $fieldmap{lc($1)} ? $fieldmap{lc($1)} : $1 ; + push @{$h->{$field}} , $hdr ; + } elsif ( ref($h->{$field}) eq 'ARRAY') { + + $hdr =~ s/^\s+/ /; + $h->{$field}[-1] .= $hdr ; + } + } + } + my $candump = 0; + if ($self->Debug) { + eval { + require Data::Dumper; + Data::Dumper->import; + }; + $candump++ unless $@; + } + # if we asked for one message, just return its hash, + # otherwise, return hash of numbers => header hash + # if (ref($msgspec) eq 'ARRAY') { + if (ref($msgspec) ) { + #_debug $self,"Structure from parse_headers:\n", + # Dumper($headers) + # if $self->Debug; + return $headers; + } else { + #_debug $self, "Structure from parse_headers:\n", + # Dumper($headers->{$msgspec}) + # if $self->Debug; + return $headers->{$msgspec}; + } +} + +sub subject { return $_[0]->get_header($_[1],"Subject") } +sub date { return $_[0]->get_header($_[1],"Date") } +sub rfc822_header { get_header(@_) } + +sub get_header { + my($self , $msg, $header ) = @_; + my $val = 0; + eval { $val = $self->parse_headers($msg,$header)->{$header}[0] }; + return defined($val)? $val : undef; +} + +sub recent_count { + my ($self, $folder) = (shift, shift); + + $self->status($folder, 'RECENT') or return undef; + + chomp(my $r = ( grep { s/\*\s+STATUS\s+.*\(RECENT\s+(\d+)\s*\)/$1/ } + $self->History($self->Transaction) + )[0]); + + $r =~ s/\D//g; + + return $r; +} + +sub message_count { + + my ($self, $folder) = (shift, shift); + $folder ||= $self->Folder; + + $self->status($folder, 'MESSAGES') or return undef; + foreach my $result (@{$self->{"History"}{$self->Transaction}}) { + return $1 if $result->[DATA] =~ /\(MESSAGES\s+(\d+)\s*\)/ ; + } + + return undef; + +} + +{ +for my $datum ( + qw( recent seen + unseen messages + ) +) { + no strict 'refs'; + *$datum = sub { + my $self = shift; + #my @hits; + + #my $hits = $self->search($datum eq "messages" ? "ALL" : "$datum") + # or return undef; + #print "Received $hits from search and array context flag is ", + # wantarry,"\n"; + #if ( scalar(@$hits) ) { + # return wantarray ? @$hits : $hits ; + #} + return $self->search($datum eq "messages" ? "ALL" : "$datum") ; + + + }; +} +} +{ +for my $datum ( + qw( sentbefore sentsince senton + since before on + ) +) { + no strict 'refs'; + *$datum = sub { + + my($self,$time) = (shift,shift); + + my @hits; my $imapdate; + my @mnt = qw{ Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec}; + + if ( $time =~ /\d\d-\D\D\D-\d\d\d\d/ ) { + $imapdate = $time; + } elsif ( $time =~ /^\d+$/ ) { + my @ltime = localtime($time); + $imapdate = sprintf( "%2.2d-%s-%4.4d", + $ltime[3], $mnt[$ltime[4]], $ltime[5] + 1900); + } else { + $self->LastError("Invalid date format supplied to '$datum' method."); + return undef; + } + $self->_imap_command( ($self->Uid ? "UID " : "") . "SEARCH $datum $imapdate") + or return undef; + my @results = $self->History($self->Count) ; + + for my $r (@results) { + + chomp $r; + $r =~ s/\r$//; + $r =~ s/^\*\s+SEARCH\s+//i or next; + push @hits, grep(/\d/,(split(/\s+/,$r))); + _debug $self, "Hits are now: ",join(',',@hits),"\n" if $self->Debug; + } + + return wantarray ? @hits : \@hits; + } +} +} + +sub or { + + my $self = shift ; + my @what = @_; + my @hits; + + if ( scalar(@what) < 2 ) { + $self->LastError("Invalid number of arguments passed to or method.\n"); + return undef; + } + + my $or = "OR " . $self->Massage(shift @what); + $or .= " " . $self->Massage(shift @what); + + + for my $w ( @what ) { + my $w = $self->Massage($w) ; + $or = "OR " . $or . " " . $w ; + } + + $self->_imap_command( ($self->Uid ? "UID " : "") . "SEARCH $or") + or return undef; + my @results = $self->History($self->Count) ; + + for my $r (@results) { + + chomp $r; + $r =~ s/\r$//; + $r =~ s/^\*\s+SEARCH\s+//i or next; + push @hits, grep(/\d/,(split(/\s+/,$r))); + _debug $self, "Hits are now: ",join(',',@hits),"\n" + if $self->Debug; + } + + return wantarray ? @hits : \@hits; +} + +#sub Strip_cr { +# my $self = shift; + +# my $in = $_[0]||$self ; + +# $in =~ s/\r//g ; + +# return $in; +#} + + +sub disconnect { $_[0]->logout } + + +sub search { + + my $self = shift; + my @hits; + my @a = @_; + $@ = ""; + # massage? + $a[-1] = $self->Massage($a[-1],1) + if scalar(@a) > 1 and !exists($SEARCH_KEYS{uc($a[-1])}); + $self->_imap_command( ( $self->Uid ? "UID " : "" ) . "SEARCH ". join(' ',@a)) + or return undef; + my $results = $self->History($self->Count) ; + + + for my $r (@$results) { + #$self->_debug("Considering the search result line: $r"); + chomp $r; + $r =~ s/\r\n?/ /g; + $r =~ s/^\*\s+SEARCH\s+(?=.*\d.*)// or next; + my @h = grep(/^\d+$/,(split(/\s+/,$r))); + push @hits, @h if scalar(@h) ; # and grep(/\d/,@h) ); + + } + + $self->{LastError}="Search completed successfully but found no matching messages\n" + unless scalar(@hits); + + if ( wantarray ) { + return @hits; + } else { + if ($self->Ranges) { + #print STDERR "Fetch: Returning range\n"; + return scalar(@hits) ? $self->Range(\@hits) : undef; + } else { + #print STDERR "Fetch: Returning ref\n"; + return scalar(@hits) ? \@hits : undef; + } + } +} + +sub thread { + # returns a Thread data structure + # + # $imap->thread($algorythm, $charset, @search_args); + my $self = shift; + + my $algorythm = shift; + $algorythm ||= $self->has_capability("THREAD=REFERENCES") ? "REFERENCES" : "ORDEREDSUBJECT"; + my $charset = shift; + $charset ||= "UTF-8"; + + my @a = @_; + + $a[0]||="ALL" ; + my @hits; + # massage? + + $a[-1] = $self->Massage($a[-1],1) + if scalar(@a) > 1 and !exists($SEARCH_KEYS{uc($a[-1])}); + $self->_imap_command( ( $self->Uid ? "UID " : "" ) . + "THREAD $algorythm $charset " . + join(' ',@a) + ) or return undef; + my $results = $self->History($self->Count) ; + + my $thread = ""; + for my $r (@$results) { + #$self->_debug("Considering the search result line: $r"); + chomp $r; + $r =~ s/\r\n?/ /g; + if ( $r =~ /^\*\s+THREAD\s+/ ) { + eval { require "Mail/IMAPClient/Thread.pm" } + or ( $self->LastError($@), return undef); + my $parser = Mail::IMAPClient::Thread->new(); + $thread = $parser->start($r) ; + } else { + next; + } + #while ( $r =~ /(\([^\)]*\))/ ) { + # push @hits, [ split(/ /,$1) ] ; + #} + } + + $self->{LastError}="Thread search completed successfully but found no matching messages\n" + unless ref($thread); + return $thread ||undef; + + if ( wantarray ) { + + return @hits; + } else { + return scalar(@hits) ? \@hits : undef; + } +} + + + + +sub delete_message { + + my $self = shift; + my $count = 0; + my @msgs = (); + for my $arg (@_) { + if (ref($arg) eq 'ARRAY') { + push @msgs, @{$arg}; + } else { + push @msgs, split(/\,/,$arg); + } + } + + + $self->store(join(',',@msgs),'+FLAGS.SILENT','(\Deleted)') and $count = scalar(@msgs); + + return $count; +} + +sub restore_message { + + my $self = shift; + my @msgs = (); + for my $arg (@_) { + if (ref($arg) eq 'ARRAY') { + push @msgs, @{$arg}; + } else { + push @msgs, split(/\,/,$arg); + } + } + + + $self->store(join(',',@msgs),'-FLAGS','(\Deleted)') ; + my $count = grep( + / + ^\* # Start with an asterisk + \s\d+ # then a space then a number + \sFETCH # then a space then the string 'FETCH' + \s\( # then a space then an open paren :-) + .* # plus optional anything + FLAGS # then the string "FLAGS" + .* # plus anything else + (?!\\Deleted) # but never "\Deleted" + /x, + $self->Results + ); + + + return $count; +} + + +sub uidvalidity { + + my $self = shift; my $folder = shift; + + my $vline = (grep(/UIDVALIDITY/i, $self->status($folder, "UIDVALIDITY")))[0]; + + my($validity) = $vline =~ /\(UIDVALIDITY\s+([^\)]+)/; + + return $validity; +} + +# 3 status folder (uidnext) +# * STATUS folder (UIDNEXT 290) + +sub uidnext { + + my $self = shift; my $folder = $self->Massage(shift); + + my $line = (grep(/UIDNEXT/i, $self->status($folder, "UIDNEXT")))[0]; + + my($uidnext) = $line =~ /\(UIDNEXT\s+([^\)]+)/; + + return $uidnext; +} + +sub capability { + + my $self = shift; + + $self->_imap_command('CAPABILITY') or return undef; + + my @caps = ref($self->{CAPABILITY}) ? + keys %{$self->{CAPABILITY}} : + map { split } + grep (s/^\*\s+CAPABILITY\s+//, + $self->History($self->Count)); + + unless ( exists $self->{CAPABILITY} ) { + for (@caps) { + $self->{CAPABILITY}{uc($_)}++ ; + if (/=/) { + my($k,$v)=split(/=/,$_) ; + $self->{uc($k)} = uc($v) ; + } + } + } + + + return wantarray ? @caps : \@caps; +} + +sub has_capability { + my $self = shift; + $self->capability; + local($^W)=0; + return $self->{CAPABILITY}{uc($_[0])}; +} + +sub imap4rev1 { + my $self = shift; + return exists($self->{_IMAP4REV1}) ? + $self->{_IMAP4REV1} : + $self->{_IMAP4REV1} = $self->has_capability(IMAP4REV1) ; +} + +sub namespace { + # Returns a (reference to a?) nested list as follows: + # [ + # [ + # [ $user_prefix, $user_delim ] (,[$user_prefix2 ,$user_delim ], [etc,etc] ), + # ], + # [ + # [ $shared_prefix,$shared_delim] (,[$shared_prefix2,$shared_delim], [etc,etc] ), + # ], + # [ + # [$public_prefix, $public_delim] (,[$public_prefix2,$public_delim], [etc,etc] ), + # ], + # ] ; + + my $self = shift; + unless ( $self->has_capability("NAMESPACE") ) { + my $error = $self->Count . " NO NAMESPACE not supported by " . $self->Server ; + $self->LastError("$error\n") ; + $self->_debug("$error\n") ; + $@ = $error; + carp "$@" if $^W; + return undef; + } + my $namespace = (map({ /^\* NAMESPACE (.*)/ ? $1 : () } @{$self->_imap_command("NAMESPACE")->Results}))[0] ; + $namespace =~ s/\x0d?\x0a$//; + my($personal,$shared,$public) = $namespace =~ m# + (NIL|\((?:\([^\)]+\)\s*)+\))\s + (NIL|\((?:\([^\)]+\)\s*)+\))\s + (NIL|\((?:\([^\)]+\)\s*)+\)) + #xi; + + my @ns = (); + $self->_debug("NAMESPACE: pers=$personal, shared=$shared, pub=$public\n"); + push @ns, map { + $_ =~ s/^\((.*)\)$/$1/; + my @pieces = m#\(([^\)]*)\)#g; + $self->_debug("NAMESPACE pieces: " . join(", ",@pieces) . "\n"); + my $ref = []; + foreach my $atom (@pieces) { + push @$ref, [ $atom =~ m#"([^"]*)"\s*#g ] ; + } + $_ =~ /^NIL$/i ? undef : $ref; + } ( $personal, $shared, $public) ; + return wantarray ? @ns : \@ns; +} + +# Contributed by jwm3 +sub internaldate { + my $self = shift; + my $msg = shift; + $self->_imap_command( ( $self->Uid ? "UID " : "" ) . "FETCH $msg INTERNALDATE") or return undef; + my $internalDate = join("", $self->History($self->Count)); + $internalDate =~ s/^.*INTERNALDATE "//si; + $internalDate =~ s/\".*$//s; + return $internalDate; +} + +sub is_parent { + my ($self, $folder) = (shift, shift); + # $self->_debug("Checking parentage ".( $folder ? "for folder $folder" : "" )."\n"); + my $list = $self->list(undef, $folder)||"NO NO BAD BAD"; + my $line = ''; + + for (my $m = 0; $m < scalar(@$list); $m++ ) { + #$self->_debug("Judging whether or not $list->[$m] is fit for parenthood\n"); + return undef + if $list->[$m] =~ /NoInferior/i; # let's not beat around the bush! + + if ($list->[$m] =~ s/(\{\d+\})\x0d\x0a$// ) { + $list->[$m] .= $list->[$m+1]; + $list->[$m+1] = ""; + } + + $line = $list->[$m] + if $list->[$m] =~ + / ^\*\s+LIST # * LIST + \s+\([^\)]*\)\s+ # (Flags) + "[^"]*"\s+ # "delimiter" + (?:"([^"]*)"|(.*))\x0d\x0a$ # Name or "Folder name" + /x; + } + if ( $line eq "" ) { + $self->_debug("Warning: separator method found no correct o/p in:\n\t" . + join("\t",@list)."\n"); + } + my($f) = $line =~ /^\*\s+LIST\s+\(([^\)]*)\s*\)/ if $line; + return 1 if $f =~ /HasChildren/i ; + return 0 if $f =~ /HasNoChildren/i ; + unless ( $f =~ /\\/) { # no flags at all unless there's a backslash + my $sep = $self->separator($folder); + return 1 if scalar(grep /^${folder}${sep}/, $self->folders); + return 0; + } +} + +sub selectable {my($s,$f)=@_;return grep(/NoSelect/i,$s->list("",$f))?0:1;} + +sub append_string { + + my $self = shift; + my $folder = $self->Massage(shift); + + my $text = shift; + $text =~ s/\x0d?\x0a/\x0d\x0a/g; + + my($flags,$date) = (shift,shift); + + if (defined($flags)) { + $flags =~ s/^\s+//g; + $flags =~ s/\s+$//g; + } + + if (defined($date)) { + $date =~ s/^\s+//g; + $date =~ s/\s+$//g; + } + + $flags = "($flags)" if $flags and $flags !~ /^\(.*\)$/ ; + $date = qq/"$date"/ if $date and $date !~ /^"/ ; + + my $clear = $self->Clear; + + $self->Clear($clear) + if $self->Count >= $clear and $clear > 0; + + my $count = $self->Count($self->Count+1); + + my $string = "$count APPEND $folder " . + ( $flags ? "$flags " : "" ) . + ( $date ? "$date " : "" ) . + "{" . length($text) . "}\x0d\x0a" ; + + $self->_record($count,[ $self->_next_index($count), "INPUT", "$string\x0d\x0a" ] ); + + # Step 1: Send the append command. + + my $feedback = $self->_send_line("$string"); + + unless ($feedback) { + $self->LastError("Error sending '$string' to IMAP: $!\n"); + return undef; + } + + my ($code, $output) = ("",""); + + # Step 2: Get the "+ go ahead" response + until ( $code ) { + $output = $self->_read_line or return undef; + foreach my $o (@$output) { + + $self->_record($count,$o); # $o is already an array ref + next unless $self->_is_output($o); + + ($code) = $o->[DATA] =~ /(^\+|^\d*\s*NO|^\d*\s*BAD)/i ; + + if ($o->[DATA] =~ /^\*\s+BYE/i) { + $self->LastError("Error trying to append string: " . + $o->[DATA]. "; Disconnected.\n"); + $self->_debug("Error trying to append string: " . $o->[DATA]. + "; Disconnected.\n"); + carp("Error trying to append string: " . $o->[DATA] ."; Disconnected") if $^W; + $self->State(Unconnected); + + } elsif ( $o->[DATA] =~ /^\d*\s*(NO|BAD)/i ) { # i and / transposed!!! + $self->LastError("Error trying to append string: " . $o->[DATA] . "\n"); + $self->_debug("Error trying to append string: " . $o->[DATA] . "\n"); + carp("Error trying to append string: " . $o->[DATA]) if $^W; + return undef; + } + } + } + + $self->_record($count,[ $self->_next_index($count), "INPUT", "$text\x0d\x0a" ] ); + + # Step 3: Send the actual text of the message: + $feedback = $self->_send_line("$text\x0d\x0a"); + + unless ($feedback) { + $self->LastError("Error sending append msg text to IMAP: $!\n"); + return undef; + } + $code = undef; # clear out code + + # Step 4: Figure out the results: + until ($code) { + $output = $self->_read_line or return undef; + $self->_debug("Append results: " . map({ $_->[DATA] } @$output) . "\n" ) + if $self->Debug; + foreach my $o (@$output) { + $self->_record($count,$o); # $o is already an array ref + + ($code) = $o->[DATA] =~ /^(?:$count|\*) (OK|NO|BAD)/im ; + + if ($o->[DATA] =~ /^\*\s+BYE/im) { + $self->State(Unconnected); + $self->LastError("Error trying to append: " . $o->[DATA] . "\n"); + $self->_debug("Error trying to append: " . $o->[DATA] . "\n"); + carp("Error trying to append: " . $o->[DATA] ) if $^W; + } + if ($code and $code !~ /^OK/im) { + $self->LastError("Error trying to append: " . $o->[DATA] . "\n"); + $self->_debug("Error trying to append: " . $o->[DATA] . "\n"); + carp("Error trying to append: " . $o->[DATA] ) if $^W; + return undef; + } + } + } + + my($uid) = join("",map { $_->[TYPE] eq "OUTPUT" ? $_->[DATA] : () } @$output ) =~ m#\s+(\d+)\]#; + + return defined($uid) ? $uid : $self; +} +sub append { + + my $self = shift; + # now that we're passing thru to append_string we won't massage here + # my $folder = $self->Massage(shift); + my $folder = shift; + + my $text = join("\x0d\x0a",@_); + $text =~ s/\x0d?\x0a/\x0d\x0a/g; + return $self->append_string($folder,$text); +} + +sub append_file { + + my $self = shift; + my $folder = $self->Massage(shift); + my $file = shift; + my $control = shift || undef; + my $count = $self->Count($self->Count+1); + + + unless ( -f $file ) { + $self->LastError("File $file not found.\n"); + return undef; + } + + my $fh = IO::File->new($file) ; + + unless ($fh) { + $self->LastError("Unable to open $file: $!\n"); + $@ = "Unable to open $file: $!" ; + carp "unable to open $file: $!" if $^W; + return undef; + } + + my $bare_nl_count = scalar grep { /^\x0a$|[^\x0d]\x0a$/} <$fh>; + + seek($fh,0,0); + + my $clear = $self->Clear; + + $self->Clear($clear) + if $self->Count >= $clear and $clear > 0; + + my $length = ( -s $file ) + $bare_nl_count; + + my $string = "$count APPEND $folder {" . $length . "}\x0d\x0a" ; + + $self->_record($count,[ $self->_next_index($count), "INPUT", "$string" ] ); + + my $feedback = $self->_send_line("$string"); + + unless ($feedback) { + $self->LastError("Error sending '$string' to IMAP: $!\n"); + close $fh; + return undef; + } + + my ($code, $output) = ("",""); + + until ( $code ) { + $output = $self->_read_line or close $fh, return undef; + foreach my $o (@$output) { + $self->_record($count,$o); # $o is already an array ref + ($code) = $o->[DATA] =~ /(^\+|^\d+\sNO|^\d+\sBAD)/i; + if ($o->[DATA] =~ /^\*\s+BYE/) { + carp $o->[DATA] if $^W; + $self->State(Unconnected); + close $fh; + return undef ; + } elsif ( $o->[DATA]=~ /^\d+\s+(NO|BAD)/i ) { + carp $o->[DATA] if $^W; + close $fh; + return undef; + } + } + } + + { # Narrow scope + # Slurp up headers: later we'll make this more efficient I guess + local $/ = "\x0d\x0a\x0d\x0a"; + my $text = <$fh>; + $text =~ s/\x0d?\x0a/\x0d\x0a/g; + $self->_record($count,[ $self->_next_index($count), "INPUT", "{From file $file}" ] ) ; + $feedback = $self->_send_line($text); + + unless ($feedback) { + $self->LastError("Error sending append msg text to IMAP: $!\n"); + close $fh; + return undef; + } + _debug $self, "control points to $$control\n" if ref($control) and $self->Debug; + $/ = ref($control) ? "\x0a" : $control ? $control : "\x0a"; + while (defined($text = <$fh>)) { + $text =~ s/\x0d?\x0a/\x0d\x0a/g; + $self->_record( $count, + [ $self->_next_index($count), "INPUT", "{from $file}\x0d\x0a" ] + ); + $feedback = $self->_send_line($text,1); + + unless ($feedback) { + $self->LastError("Error sending append msg text to IMAP: $!\n"); + close $fh; + return undef; + } + } + $feedback = $self->_send_line("\x0d\x0a"); + + unless ($feedback) { + $self->LastError("Error sending append msg text to IMAP: $!\n"); + close $fh; + return undef; + } + } + + # Now for the crucial test: Did the append work or not? + ($code, $output) = ("",""); + + my $uid = undef; + until ( $code ) { + $output = $self->_read_line or return undef; + foreach my $o (@$output) { + $self->_record($count,$o); # $o is already an array ref + $self->_debug("append_file: Deciding if " . $o->[DATA] . " has the code.\n") + if $self->Debug; + ($code) = $o->[DATA] =~ /^\d+\s(NO|BAD|OK)/i; + # try to grab new msg's uid from o/p + $o->[DATA] =~ m#UID\s+\d+\s+(\d+)\]# and $uid = $1; + if ($o->[DATA] =~ /^\*\s+BYE/) { + carp $o->[DATA] if $^W; + $self->State(Unconnected); + close $fh; + return undef ; + } elsif ( $o->[DATA]=~ /^\d+\s+(NO|BAD)/i ) { + carp $o->[DATA] if $^W; + close $fh; + return undef; + } + } + } + close $fh; + + if ($code !~ /^OK/i) { + return undef; + } + + + return defined($uid) ? $uid : $self; +} + + +sub authenticate { + + my $self = shift; + my $scheme = shift; + my $response = shift; + + $scheme ||= $self->Authmechanism; + $response ||= $self->Authcallback; + my $clear = $self->Clear; + + $self->Clear($clear) + if $self->Count >= $clear and $clear > 0; + + my $count = $self->Count($self->Count+1); + + + my $string = "$count AUTHENTICATE $scheme"; + + $self->_record($count,[ $self->_next_index($self->Transaction), + "INPUT", "$string\x0d\x0a"] ); + + my $feedback = $self->_send_line("$string"); + + unless ($feedback) { + $self->LastError("Error sending '$string' to IMAP: $!\n"); + return undef; + } + + my ($code, $output); + + until ($code) { + $output = $self->_read_line or return undef; + foreach my $o (@$output) { + $self->_record($count,$o); # $o is a ref + ($code) = $o->[DATA] =~ /^\+(.*)$/ ; + if ($o->[DATA] =~ /^\*\s+BYE/) { + $self->State(Unconnected); + return undef ; + } + } + } + + return undef if $code =~ /^BAD|^NO/ ; + + if ('CRAM-MD5' eq $scheme && ! $response) { + if ($Mail::IMAPClient::_CRAM_MD5_ERR) { + $self->LastError($Mail::IMAPClient::_CRAM_MD5_ERR); + carp $Mail::IMAPClient::_CRAM_MD5_ERR if $^W; + } else { + $response = \&_cram_md5; + } + } + + $feedback = $self->_send_line($response->($code, $self)); + + unless ($feedback) { + $self->LastError("Error sending append msg text to IMAP: $!\n"); + return undef; + } + + $code = ""; # clear code + until ($code) { + $output = $self->_read_line or return undef; + foreach my $o (@$output) { + $self->_record($count,$o); # $o is a ref + if ( ($code) = $o->[DATA] =~ /^\+ (.*)$/ ) { + $feedback = $self->_send_line($response->($code,$self)); + unless ($feedback) { + $self->LastError("Error sending append msg text to IMAP: $!\n"); + return undef; + } + $code = "" ; # Clear code; we're still not finished + } else { + $o->[DATA] =~ /^$count (OK|NO|BAD)/ and $code = $1; + if ($o->[DATA] =~ /^\*\s+BYE/) { + $self->State(Unconnected); + return undef ; + } + } + } + } + + $code =~ /^OK/ and $self->State(Authenticated) ; + return $code =~ /^OK/ ? $self : undef ; + +} + +# UIDPLUS response from a copy: [COPYUID (uidvalidity) (origuid) (newuid)] +sub copy { + + my($self, $target, @msgs) = @_; + + $target = $self->Massage($target); + if ( $self->Ranges ) { + @msgs = ($self->Range(@msgs)); + } else { + @msgs = sort { $a <=> $b } map { ref($_)? @$_ : split(',',$_) } @msgs; + } + + $self->_imap_command( + ( $self->Uid ? "UID " : "" ) . + "COPY " . + ( $self->Ranges ? $self->Range(@msgs) : + join(',',map { ref($_)? @$_ : $_ } @msgs)) . + " $target" + ) or return undef ; + my @results = $self->History($self->Count) ; + + my @uids; + + for my $r (@results) { + + chomp $r; + $r =~ s/\r$//; + $r =~ s/^.*\[COPYUID\s+\d+\s+[\d:,]+\s+([\d:,]+)\].*/$1/ or next; + push @uids, ( $r =~ /(\d+):(\d+)/ ? $1 ... $2 : split(/,/,$r) ) ; + + } + + return scalar(@uids) ? join(",",@uids) : $self; +} + +sub move { + + my($self, $target, @msgs) = @_; + + $self->create($target) and $self->subscribe($target) + unless $self->exists($target); + + my $uids = $self->copy($target, map { ref($_) =~ /ARRAY/ ? @{$_} : $_ } @msgs) + or return undef; + + $self->delete_message(@msgs) or carp $self->LastError; + + return $uids; +} + +sub set_flag { + my($self, $flag, @msgs) = @_; + if ( ref($msgs[0]) =~ /ARRAY/ ) { @msgs = @{$msgs[0]} }; + $flag =~ /^\\/ or $flag = "\\" . $flag + if $flag =~ /^(Answered|Flagged|Deleted|Seen|Draft)$/i; + if ( $self->Ranges ) { + $self->store( $self->Range(@msgs), "+FLAGS.SILENT (" . $flag . ")" ); + } else { + $self->store( join(",",@msgs), "+FLAGS.SILENT (" . $flag . ")" ); + } +} + +sub see { + my($self, @msgs) = @_; + if ( ref($msgs[0]) =~ /ARRAY/ ) { @msgs = @{$msgs[0]} }; + $self->set_flag('\\Seen', @msgs); +} + +sub mark { + my($self, @msgs) = @_; + if ( ref($msgs[0]) =~ /ARRAY/ ) { @msgs = @{$msgs[0]} }; + $self->set_flag('\\Flagged', @msgs); +} + +sub unmark { + my($self, @msgs) = @_; + if ( ref($msgs[0]) =~ /ARRAY/ ) { @msgs = @{$msgs[0]} }; + $self->unset_flag('\\Flagged', @msgs); +} + +sub unset_flag { + my($self, $flag, @msgs) = @_; + if ( ref($msgs[0]) =~ /ARRAY/ ) { @msgs = @{$msgs[0]} }; + $flag =~ /^\\/ or $flag = "\\" . $flag + if $flag =~ /^(Answered|Flagged|Deleted|Seen|Draft)$/i; + $self->store( join(",",@msgs), "-FLAGS.SILENT (" . $flag . ")" ); +} + +sub deny_seeing { + my($self, @msgs) = @_; + if ( ref($msgs[0]) =~ /ARRAY/ ) { @msgs = @{$msgs[0]} }; + $self->unset_flag('\\Seen', @msgs); +} + +sub size { + + my ($self,$msg) = @_; + # return undef unless fetch is successful + my @data = $self->fetch($msg,"(RFC822.SIZE)"); + return undef unless defined($data[0]); + my($size) = grep(/RFC822\.SIZE/,@data); + + $size =~ /RFC822\.SIZE\s+(\d+)/; + + return $1; +} + +sub getquotaroot { + my $self = shift; + my $what = shift; + $what = ( $what ? $self->Massage($what) : "INBOX" ) ; + $self->_imap_command("getquotaroot $what") or return undef; + return $self->Results; +} + +sub getquota { + my $self = shift; + my $what = shift; + $what = ( $what ? $self->Massage($what) : "user/$self->{User}" ) ; + $self->_imap_command("getquota $what") or return undef; + return $self->Results; +} + +sub quota { + my $self = shift; + my ($what) = shift||"INBOX"; + $self->_imap_command("getquota $what")||$self->getquotaroot("$what"); + return ( map { s/.*STORAGE\s+\d+\s+(\d+).*\n$/$1/ ? $_ : () } $self->Results + )[0] ; +} + +sub quota_usage { + my $self = shift; + my ($what) = shift||"INBOX"; + $self->_imap_command("getquota $what")||$self->getquotaroot("$what"); + return ( map { s/.*STORAGE\s+(\d+)\s+\d+.*\n$/$1/ ? $_ : () } $self->Results + )[0] ; +} +sub Quote { + my($class,$arg) = @_; + return $class->Massage($arg,NonFolderArg); +} + +sub Massage { + my $self= shift; + my $arg = shift; + my $notFolder = shift; + return unless $arg; + my $escaped_arg = $arg; $escaped_arg =~ s/"/\\"/g; + $arg = substr($arg,1,length($arg)-2) if $arg =~ /^".*"$/ + and ! ( $notFolder or $self->STATUS(qq("$escaped_arg"),"(MESSAGES)")); + + if ($arg =~ /["\\]/) { + $arg = "{" . length($arg) . "}\x0d\x0a$arg" ; + } elsif ($arg =~ /\s|[{}()]/) { + $arg = qq("${arg}") unless $arg =~ /^"/; + } + + return $arg; +} + +sub unseen_count { + + my ($self, $folder) = (shift, shift); + $folder ||= $self->Folder; + $self->status($folder, 'UNSEEN') or return undef; + + chomp( my $r = ( grep + { s/\*\s+STATUS\s+.*\(UNSEEN\s+(\d+)\s*\)/$1/ } + $self->History($self->Transaction) + )[0] + ); + + $r =~ s/\D//g; + return $r; +} + + + +# Status Routines: + + +sub Status { $_[0]->State ; } +sub IsUnconnected { ($_[0]->State == Unconnected) ? 1 : 0 ; } +sub IsConnected { ($_[0]->State >= Connected) ? 1 : 0 ; } +sub IsAuthenticated { ($_[0]->State >= Authenticated)? 1 : 0 ; } +sub IsSelected { ($_[0]->State == Selected) ? 1 : 0 ; } + + +# The following private methods all work on an output line array. +# _data returns the data portion of an output array: +sub _data { defined $_[1] and ref $_[1] and defined $_[1]->[TYPE] or return undef; $_[1]->[DATA]; } + +# _index returns the index portion of an output array: +sub _index { defined $_[1] and ref $_[1] and defined $_[1]->[TYPE] or return undef; $_[1]->[INDEX]; } + +# _type returns the type portion of an output array: +sub _type { defined $_[1] and ref $_[1] and defined $_[1]->[TYPE] or return undef; $_[1]->[TYPE]; } + +# _is_literal returns true if this is a literal: +sub _is_literal { defined $_[1] and ref $_[1] and defined $_[1]->[TYPE] and $_[1]->[TYPE] eq "LITERAL" }; + +# _is_output_or_literal returns true if this is an +# output line (or the literal part of one): +sub _is_output_or_literal { + defined $_[1] and ref $_[1] and defined $_[1]->[TYPE] and + ($_[1]->[TYPE] eq "OUTPUT" || $_[1]->[TYPE] eq "LITERAL") +}; + +# _is_output returns true if this is an output line: +sub _is_output { defined $_[1] and ref $_[1] and defined $_[1]->[TYPE] and $_[1]->[TYPE] eq "OUTPUT" }; + +# _is_input returns true if this is an input line: +sub _is_input { defined $_[1] and ref $_[1] and defined $_[1]->[TYPE] and $_[1]->[TYPE] eq "INPUT" }; + +# _next_index returns next_index for a transaction; may legitimately return 0 when successful. +sub _next_index { + defined(scalar(@{$_[0]->{'History'}{$_[1]||$_[0]->Transaction}})) ? + scalar(@{$_[0]->{'History'}{$_[1]||$_[0]->Transaction}}) : 0 +}; + +sub _cram_md5 { + my ($code, $client) = @_; + my $hmac = Digest::HMAC_MD5::hmac_md5_hex(MIME::Base64::decode($code), + $client->Password()); + return MIME::Base64::encode($client->User() . " $hmac"); +} + + + +sub Range { + require "Mail/IMAPClient/MessageSet.pm"; + my $self = shift; + my $targ = $_[0]; + #print "Arg is ",ref($targ),"\n"; + if (@_ == 1 and ref($targ) =~ /Mail::IMAPClient::MessageSet/ ) { + return $targ; + } + my $range = Mail::IMAPClient::MessageSet->new(@_); + #print "Returning $range :",ref($range)," == $range\n"; + return $range; +} + +my $not_void = 1; --- imapsync-1.241.orig/debian/IMAPClient229/Mail/IMAPClient.pod +++ imapsync-1.241/debian/IMAPClient229/Mail/IMAPClient.pod @@ -0,0 +1,3721 @@ +package Mail::IMAPClient; + +# $Id: IMAPClient.pod,v 20001010.1 2003/06/12 21:35:53 dkernen Exp $ + +$Mail::IMAPClient::VERSION = '2.2.7'; +$Mail::IMAPClient::VERSION = '2.2.7'; # do it twice to make sure it takes + +=head1 NAME + +Mail::IMAPClient - An IMAP Client API + +=head1 DESCRIPTION + +This module provides methods implementing the IMAP protocol. It allows +perl scripts to interact with IMAP message stores. + +The module is used by constructing or instantiating a new IMAPClient +object via the L constructor method. Once the object has been +instantiated, the L method is either implicitly or explicitly +called. At that point methods are available that implement the IMAP +client commands as specified in I. When processing is +complete, the I object method should be called. + +This documentation is not meant to be a replacement for RFC2060, and +the wily programmer will have a copy of that document handy when coding +IMAP clients. + +Note that this documentation uses the term I in place of +RFC2060's use of I. This documentation reserves the use of the +term I to refer to the set of folders owned by a specific IMAP +id. + +RFC2060 defines four possible states for an IMAP connection: not +authenticated, authenticated, selected, and logged out. These +correspond to the B constants C, +C, C, and C, respectively. These +constants are implemented as class methods, and can be used in +conjunction with the L method to determine the status of an +B object and its underlying IMAP session. Note that an +B object can be in the C state both before a +server connection is made and after it has ended. This differs slightly +from RFC2060, which does not define a pre-connection status. For a +discussion of the methods available for examining the B +object's status, see the section labeled L<"Status Methods">, below. + +=head2 Advanced Authentication Mechanisms + +RFC2060 defines two commands for authenticating to an IMAP server: LOGIN for +plain text authentication and AUTHENTICATE for more secure authentication +mechanisms. Currently Mail::IMAPClient supports CRAM-MD5 and plain text +authentication. There are also a number of methods and parameters that you +can use to build your own authentication mechanism. Since this topic is a source +of many questions, I will provide a quick overview here. All of the methods and +parameters discussed here are described in more detail elsewhere in this document; +this section is meant to help you get started. + +First of all, if you just want to do plain text authentication and your server is +okay with that idea then you don't even need to read this section. + +Second of all, the intent of this section is to help you implement the authentication +mechanism of your choice, but you will have to understand how that mechanism works. +There are I of authentication mechanisms and most of them are not available to +me to test with for one reason or another. Even if this section does not answer +all of your authentication questions it I contain all the answers that I have, +which I admit are scant. + +Third of all, if you manage to get any advanced authentication mechanisms to work then +please consider donating them to this module. I don't quite have a framework visualized +for how different authentication mechanisms could "plug in" to this module but I would +like to eventually see this module distributed with a number of helper modules to +implement various authentication schemes. + +The B's support for add-on authentication mechanisms is pretty straight +forward and is built upon several assumptions. Basically you create a callback to be used to +provide the response to the server's challenge. The I parameter contains a +reference to the callback, which can be an anonymous subroutine or a named subroutine. +Then, you identify your authentication mechanism, either via the I parameter +or as an argument to L. + +You may also need to provide a subroutine to encrypt (or whatever) data before it is sent +to the server. The I parameter must contain a reference to this subroutine. +And, you will need to decrypt data from the server; a reference to the subroutine that +does this must be stored in the I parameter. + +This framework is based on the assumptions that a) the mechanism you are using requires +a challenge-response exchange, and b) the mechanism does not fundamentally alter the +exchange between client and server but merely wraps the exchange in a layer of +encryption. It particularly assumes that the line-oriented nature of the IMAP conversation +is preserved; authentication mechanisms that break up messages into blocks of a +predetermined size may still be possible but will certainly be more difficult to implement. + +Alternatively, if you have access to B, a utility included in the Cyrus IMAP +distribution, you can use that utility to broker your communications with the IMAP server. +This is quite easy to implement. An example, L, can be found in +the C subdirectory of the source distribution. + +The following list summarizes the methods and parameters that you may find useful in +implementing advanced autentication: + +=over 4 + +=item authenticate method + +This method implements the AUTHENTICATE IMAP client command as documented in RFC2060. +If you have set the I parameter then the L method will call +L instead of doing a clear text login, which is its normal behavior. +If you don't want B to call B on your behalf then you can call +it yourself. Instead of setting an I you can just pass the authmechanism +as the first argument to AUTHENTICATE. + +=item Socket Parameter + +The I parameter holds a reference to the socket connection. Normally this +is set for you by the L method, but if you are implementing an advanced +authentication technique you may choose to set up your own socket connection and then +set this parameter manually, bypassing the B method completely. + +=item State, Server, Password, and User Parameters + +If you need to make your own connection to the server and perform your authentication +manually, then you can set these parameters to keep your B object +in sync with its actual status. Of these, only the I parameter is always necessary. +The others need to be set only if you think your program will need them later. + +=item Authmechanism + +Set this to the value that AUTHENTICATE should send to the server as the authentication +mechanism. If you are brokering your own authentication then this parameter may be less +useful. It is also not needed by the L method. It exists solely so that you +can set it when you call L to instantiate your object. The B method will call +L, who will call L. If B sees that you've set an I +then it will call B, using your I and I +parameters as arguments. + +=item Authcallback + +The I parameter, if set, should contain a pointer to a subroutine. The +L method will use this as the callback argument to the B method +if the I and I parameters are both set. If you set +I but not I then the default callback for your mechanism +will be used. Unfortunately only the CRAM-MD5 authentication mechanism has a default +callback; in every other case not supplying the callback results in an error. + +Most advanced authentication mechanisms require a challenge-response exchange. After the +L method sends " AUTHENTICATE \r\n" to the IMAP +server, the server replies with a challenge. The B method then invokes +the code whose reference is stored in the I parameter as follows: + + $Authcallback->($challenge,$imap) + +where C<$Authcallback> is the code reference stored in the I parameter, +C<$challenge> is the challenge received from the IMAP server, and C<$imap> is a pointer +to the B object. The return value from the I routine +should be the response to the challenge, and that return value will be sent by the +L method to the server. + +=item Readmethod + +The I parameter points to a routine that will read data from the socket +connection. This read method will replace the B that would otherwise be +performed by B. The replacement method is called with five +arguments. The first is a pointer to the B object; the rest +are the four arguments required by the B function. Note the third argument +(which corresponds to the second argument to B) is a buffer to read into; +this will be a pointer to a scalar. So for example if your I were just +going to replace B without any intervening processing (which would be silly +but this is just an example after all) then you would set your I like this: + + $imap->Readmethod( + sub { + my($self) = shift; + my($handle,$buffer,$count,$offset) = @_; + return sysread( $handle, $$buffer, $count, $offset); + } + ); + +Note particularly the double dollar signs in C<$$buffer> in the B call; this +is not a typo! + +=item Prewritemethod + +The I, if defined, should contain a pointer to a subroutine. +It is called immediately prior to writing to the +socket connection. It is called by B with two arguments: +a reference to the B object and the ASCII text string to be written. +It should return another string that will be the actual string sent to the IMAP server. +The idea here is that your I will do whatever encryption is necessary +and then return the result to the caller so it in turn can be sent to the server. + +=back + +=head2 Errors + +If you attempt an operation that results in an error, then you can +retrieve the text of the error message by using the L +method. However, since the L method is an object method (and +not a class method) you will only be able to use this method if you've +successfully created your object. Errors in the L method can +prevent your object from ever being created. Additionally, if you +supply the I, I, and I parameters to L, it +will attempt to call B and B, either of which could +fail and cause your L method call to return C (in which case +your object will have been created but its reference will have been +discarded before ever having been returned to you). + +If this happens to you, you can always check C<$@>. B +will populate that variable with something useful if either of the +L, L, or L methods fail. In fact, as of version 2, +the C<$@> variable will always contain error info from the last error, +so you can print that instead of calling L if you wish. + +If you run your script with warnings turned on (which I'm sure you'll +do at some point because it's such a good idea) then any error message +that gets placed into the L slot (and/or in C<$@>) will +automatically generate a warning. + +=head2 Transactions + +RFC2060 requires that each line in an IMAP conversation be prefixed +with a tag. A typical conversation consists of the client issuing a +tag-prefixed command string, and the server replying with one of more +lines of output. Those lines of output will include a command +completion status code prefixed by the same tag as the original command +string. + +The B module uses a simple counter to ensure that each +client command is issued with a unique tag value. This tag value is +referred to by the B module as the transaction number. A +history is maintained by the B object documenting each +transaction. The L method returns the number of the last +transaction, and can be used to retrieve lines of text from the +object's history. + +The L parameter is used to control the size of the session +history so that long-running sessions do not eat up unreasonable +amounts of memory. See the discussion of L under L<"Parameters"> +for more information. + +The L transaction returns the history of the entire IMAP +session since the initial connection or for the last I +transactions. This provides a record of the entire conversation, +including client command strings and server responses, and is a +wonderful debugging tool as well as a useful source of raw data for +custom parsing. + +=head1 CLASS METHODS + +There are a couple of methods that can be invoked as class methods. +Generally they can be invoked as an object method as well, as a +convenience to the programmer. (That is, as a convenience to the +programmer who wrote this module, as well as the programmers using it. +It's easier I to enforce a class method's classiness.) Note that +if the L method is called as an object method, the object returned +is identical to what have would been returned if L had been called +as a class method. It doesn't give you a copy of the original object or +anything like that. + +=head2 new + +Example: + + Mail::IMAPClient->new(%args) or die "Could not new: $@\n"; + +The L method creates a new instance of an B object. If +the I parameter is passed as an argument to B, then B +will implicitly call the L method, placing the new object in +the I state. If I and I values are also +provided, then L will in turn call L, and the resulting +object will be returned from B in the I state. + +If the I parameter is not supplied then the B +object is created in the I state. + +If the B method is passed arguments then those arguments will be +treated as a list of key=>value pairs. The key should be one of the +parameters as documented under L<"Parameters">, below. + +Here are some examples: + + use Mail::IMAPClient; + + # returns an unconnected Mail::IMAPClient object: + my $imap = Mail::IMAPClient->new; + # ... + # intervening code using the 1st object, then: + # (returns a new, authenticated Mail::IMAPClient object) + $imap = Mail::IMAPClient->new( + Server => $host, + User => $id, + Password=> $pass, + Clear => 5, # Unnecessary since '5' is the default + # ... # Other key=>value pairs go here + ) or die "Cannot connect to $host as $id: $@"; + +See also L<"Parameters">, below, and L<"connect"> and L<"login"> for +information on how to manually connect and login after B. + +=cut + +=head2 Authenticated + +Example: + + $Authenticated = $imap->Authenticated(); + # or: + $imap->Authenticated($new_value); # But you'll probably never need to do this + +returns a value equal to the numerical value associated with an object +in the B state. This value is normally maintained by the +B module, so you typically will only query it and +won't need to set it. + +B For a more programmer-friendly idiom, see the L, +L, L, and L object methods. You +will usually want to use those methods instead of one of the above. + +=head2 Connected + +Example: + + $Connected = $imap->Connected(); + # or: + $imap->Connected($new_value); # But you'll probably never need to do this + +returns a value equal to the numerical value associated with an object +in the B state. This value is normally maintained by the +B module, so you typically will only query it and +won't need to set it. + +B For a more programmer-friendly idiom, see the L, +L, L, and L object methods. You +will usually want to use those methods instead of one of the above. + +=head2 Quote + +Example: + + $imap->search(HEADER => 'Message-id' => $imap->Quote($msg_id)); + +The B method accepts a value as an argument. It returns its +argument as a correctly quoted string or a literal string. + +Note that you should not use this on folder names, since methods that accept +folder names as an argument will quote the folder name arguments appropriately +for you. (Exceptions to this rule are methods that come with IMAP extensions +that are not explicitly supported by B.) + +If you are getting unexpected results when running methods with values that +have (or might have) embedded spaces, double quotes, braces, or parentheses, +then you may wish to call B to quote these values. You should B +use this method with foldernames or with arguments that are wrapped in quotes +or parens if those quotes or parens are there because the RFC2060 spec requires +them. So, for example, if RFC requires an argument in this format: + + ( argument ) + +and your argument is (or might be) "pennies (from heaven)", then you could just +use: + + $argument = "(" . $imap->Quote($argument) . ")" + +and be done with it. + +Of course, the fact that sometimes these characters are sometimes required +delimiters is precisely the reason you must quote them when they are I +delimiting. For example: + + + $imap->Search('SUBJECT',"(no subject)"); + # WRONG! Sends this to imap server: + # Search SUBJECT (no subject)\r\n + + $imap->Search('SUBJECT',$imap->Quote("(no subject)")); + # Correct! Sends this to imap server: + # Search SUBJECT "(no subject)"\r\n + + +On the other hand: + + $imap->store('+FLAGS',$imap->Quote("(\Deleted)")); + # WRONG! Sends this to imap server: + # [UID] STORE +FLAGS "(\Deleted)"\r\n + + + $imap->store($imap->Quota('+FLAGS'),"(\Deleted)"); + # CORRECT! Sends this to imap server: + # [UID] STORE +FLAGS (\Deleted)\r\n + +In the above, I had to abandon the many methods available to +B programmers (such as L and all-lowercase +L) for the sake of coming up with an example. However, there are +times when unexpected values in certain places will force you to B. +An example is RFC822 Message-id's, which I don't contain quotes or +parens. So you don't worry about it, until suddenly searches for certain +message-id's fail for no apparent reason. (A failed search is not simply a +search that returns no hits; it's a search that flat out didn't happen.) +This normally happens to me at about 5:00 pm on the one day when I was hoping +to leave on time. (By the way, my experience is that any character that can +possibly find its way into a Message-Id eventually will, so when dealing +with these values take proactive, defensive measures from the very start. +In fact, as I was typing the above, a buddy of mine came in to ask advice about +a logfile parsing routine he was writing in which the fields were delimited +by colons. One of the fields was a Message Id, and, you guessed it, some of the +message id's in the log had (unescaped!) colons embedded in them and were +screwing up his C. So there you have it, it's not just me. This is +everyone's problem.) + +=head2 Range + +Example: + + my %parsed = $imap->parse_headers( + $imap->Range($imap->messages), + "Date", + "Subject" + ); + +The B method will condense a list of message sequence numbers or +message UID's into the most compact format supported by RFC2060. It accepts +one or more arguments, each of which can be: + +=over 8 + +=item a) a message number, + +=item b) a comma-separated list of message numbers, + +=item c) a colon-separated range of message numbers (i.e. "$begin:$end") + +=item d) a combination of messages and message ranges, separated by commas +(i.e. 1,3,5:8,10), or + +=item e) a reference to an array whose elements are like I through I. + +=back + +The B method returns a reference to a B +object. The object has all kinds of magic properties, one of which being that +if you treat it as if it were just a string it will act like it's just a +string. This means you can ignore its objectivity and just treat it like a +string whose value is your message set expressed in compact format. + +You may want to use this method if you find that fetch operations on large +message sets seem to take a really long time, or if your server rejects +these requests with the claim that the input line is too long. You may also +want to use this if you need to add or remove messages to your message set +and want an easy way to manage this. + +For more information on the capabilities of the returned object reference, +see L. + +=head2 Rfc2060_date + +Example: + + $Rfc2060_date = $imap->Rfc2060_date($seconds); + # or: + $Rfc2060_date = Mail::IMAPClient->Rfc2060_date($seconds); + +The B method accepts one input argument, a number of +seconds since the epoch date. It returns an RFC2060 compliant date +string for that date (as required in date-related arguments to SEARCH, +such as "since", "before", etc.). + +=head2 Rfc822_date + +Example: + + $Rfc822_date = $imap->Rfc822_date($seconds); + # or: + $Rfc822_date = Mail::IMAPClient->Rfc822_date($seconds); + +The B method accepts one input argument, a number of +seconds since the epoch date. It returns an RFC822 compliant date +string for that date (without the 'Date:' prefix). Useful for putting +dates in message strings before calling L, L, etcetera. + +=head2 Selected + +Example: + + $Selected = $imap->Selected(); + # or: + $imap->Selected($new_value); # But you'll probably never need to do this + +returns a value equal to the numerical value associated with an object +in the B state. This value is normally maintained by the +B module, so you typically will only query it and +won't need to set it. + +B For a more programmer-friendly idiom, see the L, +L, L, and L object methods. You +will usually want to use those methods instead of one of the above. + +=head2 Strip_cr + +Example: + + $Strip_cr = $imap->Strip_cr(); + # or: + $imap->Strip_cr($new_value); + +The B method strips carriage returns from IMAP client command +output. Although RFC2060 specifies that lines in an IMAP conversation +end with , it is often cumbersome to have the carriage returns +in the returned data. This method accepts one or more lines of text as +arguments, and returns those lines with all sequences changed +to . Any input argument with no carriage returns is returned +unchanged. If the first argument (not counting the class name or object +reference) is an array reference, then members of that array are +processed as above and subsequent arguments are ignored. If the method +is called in scalar context then an array reference is returned instead +of an array of results. + +Taken together, these last two lines mean that you can do something +like: + + my @list = $imap->some_imap_method ; + @list = $imap->Strip_cr(@list) ; + # or: + my $list = [ $imap->some_imap_method ] ; # returns an array ref + $list = $imap->Strip_cr($list); + +B does not remove new line characters. + +=cut + +=head2 Unconnected + +Example: + + $Unconnected = $imap->Unconnected(); + # or: + $imap->Unconnected($new_value); + +returns a value equal to the numerical value associated with an object +in the B state. This value is normally maintained by the +B module, so you typically will only query it and +won't need to set it. + +B For a more programmer-friendly idiom, see the L, +L, L, and L object methods. You +will usually want to use those methods instead of one of the above. + +=head1 OBJECT METHODS + +Object methods must be invoked against objects created via the L +method. They cannot be invoked as class methods, which is why they are +called "object methods" and not "class methods". + +There are basically two types of object methods--mailbox methods, which +participate in the IMAP session's conversation (i.e. they issue IMAP +client commands) and object control methods, which do not result in +IMAP commands but which may affect later commands or provide details +of previous ones. This latter group can be further broken down into +two types, Parameter accessor methods, which affect the behavior of +future mailbox methods, and Status methods, which report on the affects +of previous mailbox methods. + +Methods that do not result in new IMAP client commands being issued +(such as the L, L, and L methods) all +begin with an uppercase letter, to distinguish them from methods that +do correspond to IMAP client commands. Class methods and eponymous +parameter methods likewise begin with an uppercase letter because +they also do not correspond to an IMAP client command. + +As a general rule, mailbox control methods return C on failure +and something besides C when they succeed. This rule is modified +in the case of methods that return search results. When called in a list +context, searches that do not find matching results return an empty list. +When called in a scalar context, searches with no hits return 'undef' +instead of an array reference. If you want to know why you received no hits, +you should check C<$@>, which will be empty if the search was successful +but had no matching results but populated with an error message if the +search encountered a problem (such as invalid parameters). + +A number of IMAP commands do not have corresponding B +methods. Instead, they are implemented via a default method and Perl's +L facility. If you are looking for a specific +IMAP client command (or IMAP extension) and do not see it documented in this +pod, then that does not necessarily mean you can not use B to +issue the command. In fact, you can issue almost any IMAP client +command simply by I that there is a corresponding +B method. See the section on +L<"Other IMAP Client Commands and the Default Object Method"> +below for details on the default method. + +=head1 Mailbox Control Methods + +=head2 append + +Example: + + my $uid = $imap->append($folder,$msg_text) + or die "Could not append: $@\n"; + +The B method adds a message to the specified folder. It takes +two arguments, the name of the folder to append the message to, and the +text of the message (including headers). Additional arguments are added +to the message text, separated with . + +The B method returns the UID of the new message (a true value) +if successful, or C if not, if the IMAP server has the UIDPLUS +capability. If it doesn't then you just get true on success and undef +on failure. + +Note that many servers will get really ticked off if you try to append +a message that contains "bare newlines", which is the titillating term +given to newlines that are not preceded by a carrage return. To protect +against this, B will insert a carrage return before any newline +that is "bare". If you don't like this behavior then you can avoid it +by not passing naked newlines to B. + +Note that B does not allow you to specify the internal date or +initial flags of an appended message. If you need this capability then +use L, below. + +=cut + +=head2 append_file + +Example: + + my $new_msg_uid = $imap->append_file( + $folder, + $filename + [ , $input_record_separator ] # optional (not arrayref) + ) or die "Could not append_file: $@\n"; + +The B method adds a message to the specified folder. It +takes two arguments, the name of the folder to append the message to, +and the file name of an RFC822-formatted message. + +An optional third argument is the value to use for +C. The default is to use "" for the first read +(to get the headers) and "\n" for the rest. Any valid value for C<$/> +is acceptable, even the funky stuff, like C<\1024>. (See L +for more information on C<$/>). (The brackets in the example indicate +that this argument is optional; they do not mean that the argument +should be an array reference.) + +The B method returns the UID of the new message (a true +value) if successful, or C if not, if the IMAP server has the +UIDPLUS capability. If it doesn't then you just get true on success and +undef on failure. If you supply a filename that doesn't exist then you +get an automatic C. The L method will remind you of this +if you forget that your file doesn't exist but somehow manage to +remember to check L. + +In case you're wondering, B is provided mostly as a way to +allow large messages to be appended without having to have the whole +file in memory. It uses the C<-s> operator to obtain the size of the +file and then reads and sends the contents line by line (or not, +depending on whether you supplied that optional third argument). + +=cut + +=head2 append_string + +Example: + + # brackets indicate optional arguments (not array refs): + + my $uid = $imap->append_string( $folder, $text [ , $flags [ , $date ] ]) + or die "Could not append_string: $@\n"; + +The B method adds a message to the specified folder. It +requires two arguments, the name of the folder to append the message +to, and the text of the message (including headers). The message text +must be included in a single string (unlike L, above). + +You can optionally specify a third and fourth argument to +B. The third argument, if supplied, is the list of flags +to set for the appended message. The list must be specified as a +space-separated list of flags, including any backslashes that may be +necessary. The enclosing parentheses that are required by RFC2060 are +optional for B. The fourth argument, if specified, is +the date to set as the internal date. It should be in the format +described for I fields in RFC2060, i.e. "dd-Mon-yyyy +hh:mm:ss +0000". + +If you want to specify a date/time but you don't want any flags then +specify I as the third argument. + +The B method returns the UID of the new message (a true +value) if successful, or C if not, if the IMAP server has the +UIDPLUS capability. If it doesn't then you just get true on success and +undef on failure. + +Note that many servers will get really ticked off if you try to append +a message that contains "bare newlines", which is the titillating term +given to newlines that are not preceded by a carrage return. To protect +against this, B will insert a carrage return before any +newline that is "bare". If you don't like this behavior then you can +avoid it by not passing naked newlines to B. + +=cut + +=head2 authenticate + +Example: + + $imap->authenticate($authentication_mechanism, $coderef) + or die "Could not authenticate: $@\n"; + +The B method accepts two arguments, an authentication +type to be used (ie CRAM-MD5) and a code or subroutine reference to +execute to obtain a response. The B method assumes that +the authentication type specified in the first argument follows a +challenge-response flow. The B method issues the IMAP +Client AUTHENTICATE command and receives a challenge from the server. +That challenge (minus any tag prefix or enclosing '+' characters but +still in the original base64 encoding) is passed as the only argument +to the code or subroutine referenced in the second argument. The return +value from the 2nd argument's code is written to the server as is, +except that a sequence is appended if neccessary. + +If one or both of the arguments are not specified in the call to +B but their corresponding parameters have been set +(I and I, respectively) then the parameter +values are used. Arguments provided to the method call however will +override parameter settings. + +If you do not specify a second argument and you have not set the +I parameter, then the first argument must be +one of the authentication mechanisms for which B has +built in support. Currently there is only built in support for CRAM-MD5, +but I hope to add more in future releases. + +If you are interested in doing NTLM authentication then please see Mark +Bush's L, which can work with B to +provide NTLM authentication. + +See also the L method, which is the simplest form of +authentication defined by RFC2060. + +=cut + +=head2 before + +Example: + + my @msgs = $imap->before($Rfc2060_date) + or warn "No messages found before $Rfc2060_date.\n"; + +The B method works just like the L<"since"> method, below, +except it returns a list of messages whose internal system dates are +before the date supplied as the argument to the B method. + +=cut + +=head2 body_string + +Example: + + my $string = $imap->body_string($msgId) + or die "Could not body_string: $@\n"; + +The B method accepts a message sequence number (or a +message UID, if the L parameter is set to true) as an argument and +returns the message body as a string. The returned value contains the +entire message in one scalar variable, without the message headers. + +=cut + +=head2 bodypart_string + +Example: + + my $string=$imap->bodypart_string( $msgid, $part_number , + $length ,$offset + ) or die "Could not get bodypart string: $@\n"; + + +The B method accepts a message sequence number (or a +message UID, if the L parameter is set to true) and a body part as +arguments and returns the message part as a string. The returned value +contains the entire message part (or, optionally, a portion of the part) +in one scalar variable. + +If an optional third argument is provided, that argument is the number +of bytes to fetch. (The default is the whole message part.) If an +optional fourth argument is provided then that fourth argument is the +offset into the part at which the fetch should begin. The default is +offset zero, or the beginning of the message part. + +If you specify an offset without specifying a length then the offset +will be ignored and the entire part will be returned. + +B will return C if it encounters an error. + +=cut + +=head2 capability + +Example: + + my @features = $imap->capability + or die "Could not determine capability: $@\n"; + +The B method returns an array of capabilities as returned +by the CAPABILITY IMAP Client command, or a reference to an array of +capabilities if called in scalar context. If the CAPABILITY IMAP Client +command fails for any reason then the B method will return +C. + +=head2 close + +Example: + + $imap->close or die "Could not close: $@\n"; + +The B method is implemented via the default method and is used +to close the currently selected folder via the CLOSE IMAP client +command. According to RFC2060, the CLOSE command performs an implicit +EXPUNGE, which means that any messages that you've flagged as +I<\Deleted> (say, with the L method) will now be +deleted. If you haven't deleted any messages then B can be +thought of as an "unselect". + +Note again that this closes the currently selected folder, not the +IMAP session. + +See also L, L, and your tattered copy of +RFC2060. + +=head2 connect + +Example: + + $imap->connect or die "Could not connect: $@\n"; + +The B method connects an imap object to the server. It returns +C if it fails to connect for any reason. If values are available +for the I and I parameters at the time that B +is invoked, then B will call the L method after +connecting and return the result of the L method to B's +caller. If either or both of the I and I parameters are +unavailable but the connection to the server succeeds then B +returns a pointer to the B object. + +The I parameter must be set (either during L method +invocation or via the L object method) before invoking +B. If the L parameter is supplied to the L method +then B is implicitly called during object construction. + +The B method sets the state of the object to C if +it successfully connects to the server. It returns C on failure. + +=head2 copy + +Example: + + # Here brackets indicate optional arguments: + my $uidList = $imap->copy($folder, $msg_1 [ , ... , $msg_n ]) + or die "Could not copy: $@\n"; + +Or: + + # Now brackets indicate an array ref! + my $uidList = $imap->copy($folder, [ $msg_1, ... , $msg_n ]) + or die "Could not copy: $@\n"; + + +The B method requires a folder name as the first argument, and a +list of one or more messages sequence numbers (or messages UID's, if +the I parameter is set to a true value). The message sequence +numbers or UID's should refer to messages in the currenly selected +folder. Those messages will be copied into the folder named in the +first argument. + +The B method returns C on failure and a true value if +successful. If the server to which the current Mail::IMAPClient object +is connected supports the UIDPLUS capability then the true value +returned by B will be a comma separated list of UID's, which are +the UID's of the newly copied messages in the target folder. + +=cut + +=head2 create + +Example: + + $imap->create($new_folder) + or die "Could not create $new_folder: $@\n"; + +The B method accepts one argument, the name of a folder (or +what RFC2060 calls a "mailbox") to create. If you specifiy additional +arguments to the B method and your server allows additional +arguments to the CREATE IMAP client command then the extra argument(s) +will be passed to your server. + +If you specifiy additional arguments to the B method and your +server does not allow additional arguments to the CREATE IMAP client +command then the extra argument(s) will still be passed to your server +and the create will fail, so don't do that. + +B returns a true value on success and C on failure, as +you've probably guessed. + +=head2 date + +Example: + + my $date = $imap->date($msg); + + +The B method accepts one argument, a message sequence number (or a +message UID if the I parameter is set to a true value). It returns +the date of message as specified in the message's RFC822 "Date: " header, +without the "Date: " prefix. + +The B method is a short-cut for: + + my $date = $imap->get_header($msg,"Date"); + + +=head2 delete + +Example: + + $imap->delete($folder) or die "Could not delete $folder: $@\n"; + +The B method accepts a single argument, the name of a folder to +delete. It returns a true value on success and C on failure. + +=head2 delete_message + +Example: + + my @msgs = $imap->seen; + scalar(@msgs) and $imap->delete_message(\@msgs) + or die "Could not delete_message: $@\n"; + +The above could also be rewritten like this: + + # scalar context returns array ref + my $msgs = scalar($imap->seen); + + scalar(@$msgs) and $imap->delete_message($msgs) + or die "Could not delete_message: $@\n"; + +Or, as a one-liner: + + + $imap->delete_message( scalar($imap->seen) ) + or warn "Could not delete_message: $@\n"; + # just give warning in case failure is + # due to having no 'seen' msgs in the 1st place! + + +The B method accepts a list of arguments. If the L +parameter is not set to a true value, then each item in the list should +be either: + +=over 4 + +=item > a message sequence number, + +=item > a comma-separated list of message sequence numbers, + +=item > a reference to an array of message sequence numbers, or + +=back + +If the L parameter is set to a true value, then each item in the +list should be either: + +=over 4 + +=item > a message UID, + +=item > a comma-separated list of UID's, or + +=item > a reference to an array of message UID's. + +=back + +The messages identified by the sequence numbers or UID's will be +deleted. If successful, B returns the number +of messages it was told to delete. However, since the delete is +done by issuing the I<+FLAGS.SILENT> option of the STORE IMAP +client command, there is no guarantee that the delete was successful +for every message. In this manner the B method sacrifices +accuracy for speed. Generally, though, if a single message in a list +of messages fails to be deleted it's because it was already deleted, +which is what you wanted anyway so why worry about it? If there is +a more severe error, i.e. the server replies "NO", "BAD", or, +banish the thought, "BYE", then B will return C. + +If you must have guaranteed results then use the IMAP STORE client +command (via the default method) and use the +FLAGS (\Deleted) option, +and then parse your results manually. + +Eg: + + $imap->store($msg_id,'+FLAGS (\Deleted)'); + my @results = $imap->History($imap->Transaction); + ... # code to parse output goes here + + + +(Frankly I see no reason to bother with any of that; if a message doesn't get +deleted it's almost always because it's already not there, which is what you +want anyway. But 'your milage may vary' and all that.) + +The B object must be in C status to use the +B method. + +B All the messages identified in the input argument(s) must be +in the currently selected folder. Failure to comply with this +requirement will almost certainly result in the wrong message(s) being +deleted. This would be a crying shame. + +B In the grand tradition of the IMAP protocol, +deleting a message doesn't actually delete the message. Really. If you +want to make sure the message has been deleted, you need to expunge the +folder (via the L method, which is implemented via the default +method). Or at least L it. This is generally considered a +feature, since after deleting a message, you can change your mind and +undelete it at any time before your L or L. + +I The L method, to delete a folder, the L +method, to expunge a folder, the L method to undelete +a message, and the L method (implemented here via the default +method) to close a folder. Oh, and don't forget about RFC2060. + +=cut + +=head2 deny_seeing + +Example: + + # Reset all read msgs to unread + # (produces error if there are no seen msgs): + $imap->deny_seeing( scalar($imap->seen) ) + or die "Could not deny_seeing: $@\n" ; + +The B method accepts a list of one or more message +sequence numbers, or a single reference to an array of one or more +message sequence numbers, as its argument(s). It then unsets the +"\Seen" flag for those messages (so that you can "deny" that you ever +saw them). Of course, if the L parameter is set to a true value +then those message sequence numbers should be unique message id's. + +Note that specifying C<$imap-Edeny_seeing(@msgs)> is just a +shortcut for specifying C<$imap-Eunset_flag("Seen",@msgs)>. + +=cut + +=head2 disconnect + +Example: + + $imap->disconnect or warn "Could not disconnect: $@\n"; + +Disconnects the B object from the server. Functionally +equivalent to the L method. (In fact it's actually a synonym +for L.) + +=cut + +=head2 done + +Example: + + my $idle = $imap->idle or warn "Couldn't idle: $@\n"; + &goDoOtherThings; + $imap->done($idle) or warn "Error from done: $@\n"; + +The B method tells the IMAP server that the connection is finished +idling. See L for more information. It accepts one argument, +which is the transaction number you received from the previous call +to L. + +If you pass the wrong transaction number to B then your perl program +will probably hang. If you don't pass any transaction number to B +then it will try to guess, and if it guesses wrong it will hang. + +If you call done without previously having called L then your +server will mysteriously respond with I<* BAD Invalid tag>. + +If you try to run any other mailbox method after calling L but +before calling L, then that method will not only fail but also +take you out of the IDLE state. This means that when you eventually +remember to call B you will just get that I<* BAD Invalid tag> +thing again. + +=head2 examine + +Example: + + $imap->examine($folder) or die "Could not examine: $@\n"; + +The B method selects a folder in read-only mode and changes +the object's state to "Selected". The folder selected via the +B method can be examined but no changes can be made unless it +is first selected via the L or L method to select it instead of trying something +funky). Note that RFC2683 contains warnings about the use of the IMAP +I command (and thus the L method and therefore the +B method) against the currenlty selected folder. +You should carefully consider this before using B +on the currently selected folder. You may be better off using +L or one of its variants (especially L), and then +counting the results. On the other hand, I regularly violate this +rule on my server without suffering any dire consequences. Your +milage may vary. + +=cut + +=head2 message_string + +Example: + + my $string = $imap->message_string($msgid) + or die "Could not message_string: $@\n"; + +The B method accepts a message sequence number (or +message UID if L is true) as an argument and returns the message +as a string. The returned value contains the entire message in one +scalar variable, including the message headers. Note that using this +method will set the message's "\Seen" flag as a side effect, unless +I is set to a true value. + +=cut + +=head2 message_to_file + +Example: + + $imap->message_to_file($file,@msgs) + or die "Could not message_to_file: $@\n"; + +The B method accepts a filename or file handle and one +or more message sequence numbers (or message UIDs if L is true) as +arguments and places the message string(s) (including RFC822 headers) +into the file named in the first argument (or prints them to the +filehandle, if a filehandle is passed). The returned value is true on +succes and C on failure. + +If the first argument is a reference, it is assumed to be an open +filehandle and will not be closed when the method completes, If it is a +file, it is opened in append mode, written to, then closed. + +Note that using this method will set the message's "\Seen" flag as a +side effect. But you can use the L method to set it back, +or set the L parameter to a true value to prevent setting the +"\Seen" flag at all. + +This method currently works by making some basic assumptions about the +server's behavior, notably that the message text will be returned as a +literal string but that nothing else will be. If you have a better idea +then I'd like to hear it. + +=cut + +=head2 message_uid + +Example: + + my $msg_uid = $imap->message_uid($msg_seq_no) + or die "Could not get uid for $msg_seq_no: $@\n"; + +The B method accepts a message sequence number (or message +UID if L is true) as an argument and returns the message's UID. +Yes, if L is true then it will use the IMAP UID FETCH UID client +command to obtain and return the very same argument you supplied. This +is an IMAP feature so don't complain to me about it. + +=cut + +=head2 messages + +Example: + + # Get a list of messages in the current folder: + my @msgs = $imap->messages or die "Could not messages: $@\n"; + # Get a reference to an array of messages in the current folder: + my $msgs = $imap->messages or die "Could not messages: $@\n"; + +If called in list context, the B method returns a list of all +the messages in the currenlty selected folder. If called in scalar +context, it returns a reference to an array containing all the messages +in the folder. If you have the L parameter turned off, then this +is the same as specifying C<1 ... $imap-EL>; if you +have UID set to true then this is the same as specifying +C<$imap-EL("ALL")>. + +=cut + +=head2 migrate + +Example: + + $imap->migrate($imap_2, "ALL", $targetFolder ) + or die "Could not migrate: $@\n"; + +The B method copies the indicated messages B the +currently selected folder B another B object's +session. It requires these arguments: + +=over 4 + +=item 1. + +a reference to the target B object (not the calling +object, which is connected to the source account); + +=item 2. + +the message(s) to be copied, specified as either a) the message +sequence number (or message UID if the UID parameter is true) of a +single message, b) a reference to an array of message sequence numbers +(or message UID's if the UID parameter is true) or c) the special +string "ALL", which is a shortcut for the results of +C("ALL")>. + +=item 3. + +the folder name of a folder on the target mailbox to receive the +message(s). If this argument is not supplied or if I is supplied +then a folder with the same name as the currently selected folder on +the calling object will be created if necessary and used. If you +specify something other then I for this argument, even if it's +'$imap1-EFolder' or the name of the currently selected folder, then +that folder will only be used if it exists on the target object's +mailbox; if it does not exist then B will fail. + +=back + +The target B object should not be the same as the +source. The source object is the calling object, i.e. the one whose +B method will be used. It cannot be the same object as the one +specified as the target, even if you are for some reason migrating +between folders on the same account (which would be silly anyway, since +L can do that much more efficiently). If you try to use the same +B object for both the caller and the reciever then +they'll both get all screwed up and it will be your fault because I +just warned you and you didn't listen. + +B will download messages from the source in chunks to minimize +memory usage. The size of the chunks can be controlled by changing the +source B object's the L parameter. The higher +the L value, the faster the migration, but the more memory your +program will require. TANSTAAFL. (See the L parameter and +eponymous accessor method, described above under the L<"Parameters"> +section.) + +The B method uses Black Magic to hardwire the I/O between the +two B objects in order to minimize resource +consumption. If you have older scripts that used L and +L to move large messages between IMAP mailboxes then you +may want to try this method as a possible replacement. + +=head2 move + +Example: + + my $newUid = $imap->move($newFolder, $oldUid) + or die "Could not move: $@\n"; + $imap->expunge; + +The B method moves messages from the currently selected folder to +the folder specified in the first argument to B. If the L +parameter is not true, then the rest of the arguments should be either: + +=over 4 + +=item > + +a message sequence number, + +=item > + +a comma-separated list of message sequence numbers, or + +=item > + +a reference to an array of message sequence numbers. + +=back + +If the L parameter is true, then the arguments should be: + +=over 4 + +=item > + +a message UID, + +=item > + +a comma-separated list of message UID's, or + +=item > + +a reference to an array of message UID's. + +=back + +If the target folder does not exist then it will be created. + +If move is sucessful, then it returns a true value. Furthermore, if the +B object is connected to a server that has the +UIDPLUS capability, then the true value will be the comma-separated +list of UID's for the newly copied messages. The list will be in the +order in which the messages were moved. (Since B uses the copy +method, the messages will be moved in numerical order.) + +If the move is not successful then B returns C. + +Note that a move really just involves copying the message to the new +folder and then setting the I<\Deleted> flag. To actually delete the +original message you will need to run L (or L). + +=cut + +=head2 namespace + +Example: + + my @refs = $imap->namespace + or die "Could not namespace: $@\n"; + +The namespace method runs the NAMESPACE IMAP command (as defined in RFC +2342). When called in a list context, it returns a list of three +references. Each reference looks like this: + + [ [ $prefix_1, $separator_1 ] , + [ $prefix_2, $separator_2 ], + [ $prefix_n , $separator_n] + ] + +The first reference provides a list of prefices and separator +charactors for the available personal namespaces. The second reference +provides a list of prefices and separator charactors for the available +shared namespaces. The third reference provides a list of prefices and +separator charactors for the available public namespaces. + +If any of the three namespaces are unavailable on the current server +then an 'undef' is returned instead of a reference. So for example if +shared folders were not supported on the server but personal and public +namespaces were both available (with one namespace each), the returned +value might resemble this: + + ( [ "", "/" ] , undef, [ "#news", "." ] ) ; + +If the B method is called in scalar context, it returns a +reference to the above-mentioned list of three references, thus +creating a single structure that would pretty-print something like +this: + + $VAR1 = [ + [ + [ $user_prefix_1, $user_separator_1 ] , + [ $user_prefix_2, $user_separator_2], + [ $user_prefix_n , $user_separator_n] + ] , # or undef + [ + [ $shared_prefix_1, $shared_separator_1 ] , + [ $shared_prefix_2, $shared_separator_2], + [ $shared_prefix_n , $shared_separator_n] + ] , # or undef + [ + [ $public_prefix_1, $public_separator_1 ] , + [ $public_prefix_2, $public_separator_2], + [ $public_prefix_n , $public_separator_n] + ] , # or undef + ]; + +Or, to look at our previous example (where shared folders are +unsupported) called in scalar context: + + $VAR1 = [ + [ + [ + "" , + "/", + ], + ], + + undef, + + [ + [ + "#news", + "." + ], + ], + ]; + +=cut + +=head2 on + +Example: + + my @msgs = $imap->on($Rfc2060_date) + or warn "Could not find messages sent on $Rfc2060_date: $@\n"; + +The B method works just like the L method, below, except it +returns a list of messages whose internal system dates are the same as +the date supplied as the argument. + +=head2 parse_headers + +Example: + + my $hashref = $imap->parse_headers($msg||@msgs, "Date", "Subject") + or die "Could not parse_headers: $@\n"; + +The B method accepts as arguments a message sequence +number and a list of header fields. It returns a hash reference in +which the keys are the header field names (without the colon) and the +values are references to arrays of values. A picture would look +something like this: + + $hashref = $imap->parse_headers(1,"Date","Received","Subject","To"); + $hashref = { + "Date" => [ "Thu, 09 Sep 1999 09:49:04 -0400" ] , + "Received" => [ q/ + from mailhub ([111.11.111.111]) by mailhost.bigco.com + (Netscape Messaging Server 3.6) with ESMTP id AAA527D for + ; Fri, 18 Jun 1999 16:29:07 +0000 + /, q/ + from directory-daemon by mailhub.bigco.com (PMDF V5.2-31 #38473) + id <0FDJ0010174HF7@mailhub.bigco.com> for bigshot@bigco.com + (ORCPT rfc822;big.shot@bigco.com); Fri, 18 Jun 1999 16:29:05 +0000 (GMT) + /, q/ + from someplace ([999.9.99.99]) by smtp-relay.bigco.com (PMDF V5.2-31 #38473) + with ESMTP id <0FDJ0000P74H0W@smtp-relay.bigco.com> for big.shot@bigco.com; Fri, + 18 Jun 1999 16:29:05 +0000 (GMT) + /] , + "Subject" => [ qw/ Help! I've fallen and I can't get up!/ ] , + "To" => [ "Big Shot ] , + } ; + +The text in the example for the "Received" array has been formated to +make reading the example easier. The actual values returned are just +strings of words separated by spaces and with newlines and carriage +returns stripped off. The I header is probably the main +reason that the B method creates a hash of lists rather +than a hash of values. + +If the second argument to B is 'ALL' or if it is +unspecified then all available headers are included in the returned +hash of lists. + +If you're not emotionally prepared to deal with a hash of lists then +you can always call the L method yourself with the appropriate +parameters and parse the data out any way you want to. Also, in the +case of headers whose contents are also reflected in the envelope, you +can use the L method as an alternative to +L. + +If the L parameter is true then the first argument will be treated +as a message UID. If the first argument is a reference to an array of +message sequence numbers (or UID's if L is true), then +B will be run against each message in the array. In this +case the return value is a hash, in which the key is the message +sequence number (or UID) and the value is a reference to a hash as +described above. + +An example of using B to print the date and subject of +every message in your smut folder could look like this: + + use Mail::IMAPClient; + my $imap = Mail::IMAPClient->new( Server => $imaphost, + User => $login, + Password=> $pass, + Uid => 1, # optional + ); + + $imap->select("smut"); + + for my $h ( + + # grab the Subject and Date from every message in my (fictional!) smut folder; + # the first argument is a reference to an array listing all messages in the folder + # (which is what gets returned by the $imap->search("ALL") method when called in + # scalar context) and the remaining arguments are the fields to parse out + + # The key is the message number, which in this case we don't care about: + values %{$imap->parse_headers( scalar($imap->search("ALL")) , "Subject", "Date")} + ) { + # $h is the value of each element in the hash ref returned from parse_headers, + # and $h is also a reference to a hash. + # We'll only print the first occurance of each field because we don't expect more + # than one Date: or Subject: line per message. + print map { "$_:\t$h->{$_}[0]\n"} keys %$h ; + } + + +=cut + +=head2 recent + +Example: + + my @recent = $imap->recent or warn "No recent msgs: $@\n"; + +The B method performs an IMAP SEARCH RECENT search against the +selected folder and returns an array of sequence numbers (or UID's, if +the L parameter is true) of messages that are recent. + +=cut + +=head2 recent_count + +Example: + + my $count = 0; + defined($count = $imap->recent_count($folder)) + or die "Could not recent_count: $@\n"; + +The B method accepts as an argument a folder name. It +returns the number of recent messages in the folder (as returned by the +IMAP client command "STATUS folder RECENT"), or C in the case of an +error. The B method was contributed by Rob Deker +(deker@ikimbo.com). + +=cut + +=head2 rename + +Example: + + $imap->rename($oldname,$nedwname) + or die "Could not rename: $@\n"; + +The B method accepts two arguments: the name of an existing +folder, and a new name for the folder. The existing folder will be +renamed to the new name using the RENAME IMAP client command. B +will return a true value if successful, or C if unsuccessful. + +=cut + +=head2 restore_message + +Example: + + $imap->restore_message(@msgs) or die "Could not restore_message: $@\n"; + +The B method is used to undo a previous +L operation (but not if there has been an intervening +L or L). The B object must be in +L status to use the B method. + +The B method accepts a list of arguments. If the +L parameter is not set to a true value, then each item in the list +should be either: + +=over 4 + +=item > + +a message sequence number, + +=item > + +a comma-separated list of message sequence numbers, + +=item > + +a reference to an array of message sequence numbers, or + +=back + +If the L parameter is set to a true value, then each item in the +list should be either: + +=over 4 + +=item > + +a message UID, + +=item > + +a comma-separated list of UID's, or + +=item > + +a reference to an array of message UID's. + +=back + +The messages identified by the sequence numbers or UID's will have +their I<\Deleted> flags cleared, effectively "undeleting" the messages. +B returns the number of messages it was able to +restore. + +Note that B is similar to calling +C("\Deleted",@msgs)>, except that B +returns a (slightly) more meaningful value. Also it's easier to type. + +=cut + +=head2 run + +Example: + + $imap->run(@args) or die "Could not run: $@\n"; + +Like Perl itself, the B module is designed to make +common things easy and uncommon things possible. The B method is +provided to make those uncommon things possible. + +The B method excepts one or two arguments. The first argument is a +string containing an IMAP Client command, including a tag and all +required arguments. The optional second argument is a string to look +for that will indicate success. (The default is C). The B +method returns an array of output lines from the command, which you are +free to parse as you see fit. + +The B method does not do any syntax checking, other than +rudimentary checking for a tag. + +When B processes the command, it increments the transaction count +and saves the command and responses in the History buffer in the same +way other commands do. However, it also creates a special entry in the +History buffer named after the tag supplied in the string passed as the +first argument. If you supply a numeric value as the tag then you may +risk overwriting a previous transaction's entry in the History buffer. + +If you want the control of B but you don't want to worry about the +damn tags then see L<"tag_and_run">, below. + +=cut + +=head2 search + +Example: + + my @msgs = $imap->search(@args) or warn "search: None found\n"; + if ($@) { + warn "Error in search: $@\n"; + } + +The B method implements the SEARCH IMAP client command. Any +argument supplied to B is prefixed with a space and appended to +the SEARCH IMAP client command. This method is another one of those +situations where it will really help to have your copy of RFC2060 +handy, since the SEARCH IMAP client command contains a plethora of +options and possible arguments. I'm not going to repeat them here. + +Remember that if your argument needs quotes around it then you must +make sure that the quotes will be preserved when passing the argument. +I.e. use C instead of C<"$arg">. When in doubt, use the +L method. + +The B method returns an array containing sequence numbers of +messages that passed the SEARCH IMAP client command's search criteria. +If the L parameter is true then the array will contain message +UID's. If B is called in scalar context then a pointer to the +array will be passed, instead of the array itself. If no messages meet +the criteria then B returns an empty list (when in list context) +or C (in scalar context). + +Since a valid, successful search can legitimately return zero matches, +you may wish to distinguish between a search that correctly returns +zero hits and a search that has failed for some other reason (i.e. +invalid search parameters). Therefore, the C<$@> variable will always +be cleared before the I command is issued to the server, and +will thus remain empty unless the server gives a I or I response +to the I command. + +=cut + +=head2 see + +Example: + + $imap->see(@msgs) or die "Could not see: $@\n"; + +The B method accepts a list of one or more messages sequence +numbers, or a single reference to an array of one or more message +sequence numbers, as its argument(s). It then sets the I<\Seen> flag +for those message(s). Of course, if the L parameter is set to a +true value then those message sequence numbers had better be unique +message id's, but then you already knew that, didn't you? + +Note that specifying C<$imap-Esee(@msgs)> is just a shortcut for +specifying C<$imap-EL("Seen",@msgs)>. + +=cut + +=head2 seen + +Example: + + my @seenMsgs = $imap->seen or warn "No seen msgs: $@\n"; + +The B method performs an IMAP SEARCH SEEN search against the +selected folder and returns an array of sequence numbers of messages +that have already been seen (ie their I<\Seen> flag is set). If the +L parameter is true then an array of message UID's will be +returned instead. If called in scalar context than a reference to the +array (rather than the array itself) will be returned. + +=cut + +=head2 select + +Example: + + $imap->select($folder) or die "Could not select: $@\n"; + +The B method (or L or L object methods for that. +Generally, the I parameter should only be queried (by using the +no-argument form of the B method). You will only need to set the +I parameter if you use some mysterious technique of your own for +selecting a folder, which you probably won't do. + +=cut + +=head2 Maxtemperrors + +Example: + + $Maxtemperrors = $imap->Maxtemperrors(); + # or: + $imap->Maxtemperrors($new_value); + +The I parameter specifies the number of times a write +operation is allowed to fail on a "Resource Temporarily Available" +error. These errors can occur from time to time if the server is too +busy to empty out its read buffer (which is logically the "other end" +of the client's write buffer). By default, B will +retry an unlimited number of times, but you can adjust this +behavior by setting I. Note that after each temporary +error, the server will wait for a number of seconds equal to the number +of consecutive temporary errors times .25, so very high values for +I can slow you down in a big way if your "temporary +error" is not all that temporary. + +You can set this parameter to "UNLIMITED" to ignore "Resource +Temporarily Unavailable" errors. This is the default. + +=head2 Password + +Example: + + $Password = $imap->Password(); + # or: + $imap->Password($new_value); + +Specifies the password to use when logging into the IMAP service on the +host specified in the I parameter as the user specified in the +I parameter. Can be supplied with the B method call or +separately by calling the B object method. + +If I, I, and I are all provided to the L +method, then the newly instantiated object will be connected to the +host specified in I (at either the port specified in I or +the default port 143) and then logged on as the user specified in the +I parameter (using the password provided in the I +parameter). See the discussion of the L<"new"> method, below. + +=head2 Peek + +Example: + + $Peek = $imap->Peek(); + # or: + $imap->Peek($true_or_false); + +Setting I to a true value will prevent the L, +L and L methods from automatically +setting the I<\Seen> flag. Setting L<"Peek"> to 0 (zero) will force +L<"body_string">, L<"message_string">, L<"message_to_file">, and +L<"parse_headers"> to always set the I<\Seen> flag. + +The default is to set the seen flag whenever you fetch the body of a +message but not when you just fetch the headers. Passing I to +the eponymous B method will reset the I parameter to its +pristine, default state. + +=cut + +=head2 Port + +Example: + + $Port = $imap->Port(); + # or: + $imap->Port($new_value); + +Specifies the port on which the IMAP server is listening. The default +is 143, which is the standard IMAP port. Can be supplied with the +L method call or separately by calling the L object method. + +=head2 Prewritemethod + +Specifies a method to call if your authentication mechanism requires you to +to do pre-write processing of the data sent to the server. If defined, then the +I parameter should contain a reference to a subroutine that +will do Special Things to data before it is sent to the IMAP server (such as +encryption or signing). + +This method will be called immediately prior to sending an IMAP client command +to the server. Its first argument is a reference to the I object +and the second argument is a string containing the command that will be sent to +the server. Your I should return a string that has been signed or +encrypted or whatever; this returned string is what will actually be sent to the +server. + +Your I will probably need to know more than this to do whatever it does. +It is recommended that you tuck all other pertinent information into a hash, and store a +reference to this hash somewhere where your method can get to it, possibly in the +I object itself. + +Note that this method should not actually send anything over the socket connection to +the server; it merely converts data prior to sending. + +If you need a I then you probably need a L as well. + +=head2 Ranges + +Example: + + $imap->Ranges(1); + # or: + my $search = $imap->search(@search_args); + if ( $imap->Ranges) { # $search is a MessageSet object + print "This is my condensed search result: $search\n"; + print "This is every message in the search result: ", + join(",",@$search),"\n; + } + + +If set to a true value, then the L method will return a +L object if called in a scalar context, +instead of the array reference that B normally returns when +called in a scalar context. If set to zero or if undefined, then B +will continue to return an array reference when called in scalar context. + +This parameter has no affect on the B method when B is called +in a list context. + +=head2 Readmethod + +This parameter, if supplied, should contain a reference to a subroutine that will +replace sysreads. The subroutine will be passed the following arguments: + +=over 4 + +1. imap_object_ref - a reference to the current imap object + +2. scalar_ref - a reference to a scalar variable into which data is read. The data +place in here should be "finished data", so if you are decrypting or removing signatures +then be sure to do that before you place data into this buffer. + +3. read_length - the number of bytes requested to be read + +4. offset - the offset into C into which data should be read. If not supplied it +should default to zero. + +=back + +Note that this method completely replaces reads from the connection to the server, so if +you define one of these then your subroutine will have to actually do the read. It is for +things like this that we have the L parameter and eponymous accessor method. + +Your I will probably need to know more than this to do whatever it does. +It is recommended that you tuck all other pertinent information into a hash, and store +a reference to this hash somewhere where your method can get to it, possibly in the +I object itself. + +If you need a I then you probably need a L as well. + +=head2 Server + +Example: + + $Server = $imap->Server(); + # or: + $imap->Server($hostname); + +Specifies the hostname or IP address of the host running the IMAP +server. If provided as part of the L method call, then the new +IMAP object will automatically be connected at the time of +instantiation. (See the L method, below.) Can be supplied with the +L method call or separately by calling the B object +method. + +=cut + +=head2 Showcredentials + +Normally debugging output will mask the login credentials when the plain text +login mechanism is used. Setting I to a true value will suppress +this, so that you can see the string being passed back and forth during plain text +login. Only set this to true when you are debugging problems with the IMAP LOGIN +command, and then turn it off right away when you're finished working on that problem. + +Example: + + print "This is very risky!\n" if $imap->Showcredentials(); + # or: + $imap->Showcredentials(0); # mask credentials again + + +=head2 Socket + +Example: + + $Socket = $imap->Socket(); + # or: + $imap->Socket($socket_fh); + +The I method can be used to obtain the socket handle of the +current connection (say, to do I/O on the connection that is not +otherwise supported by B) or to replace the current +socket with a new handle (perhaps an SSL handle, for example). + +If you supply a socket handle yourself, either by doing something like: + + $imap=Mail::IMAPClient->new(Socket=>$sock, User => ... ); + +or by doing something like: + + $imap=Mail::IMAPClient->new(User => $user, Password => $pass, Server => $host); + # blah blah blah + $imap->Socket($ssl); + +then it will be up to you to establish the connection AND to +authenticate, either via the L method, or the fancier +L, or, since you know so much anyway, by just doing raw +I/O against the socket until you're logged in. If you do any of this +then you should also set the L parameter yourself to reflect the +current state of the object (i.e. Connected, Authenticated, etc). + +=cut + +=head2 Timeout + +Example: + + $Timeout = $imap->Timeout(); + # or: + $imap->Timeout($new_value); + +Specifies the timeout value in seconds for reads. Specifying a true +value for I will prevent B from blocking in +a read. + +Since timeouts are implemented via the perl L +operator, the I parameter may be set to a fractional number of +seconds. Not supplying a I, or (re)setting it to zero, +disables the timeout feature. + +=cut + +=head2 Uid + +Example: + + $Uid = $imap->Uid(); + # or: + $imap->Uid($true_or_false); + +If L is set to a true value (i.e. 1) then the behavior of the +L, L, L, and L methods (and their +derivatives) is changed so that arguments that would otherwise be +message sequence numbers are treated as message UID's and so that +return values (in the case of the L method and its derivatives) +that would normally be message sequence numbers are instead message +UID's. + +Internally this is implemented as a switch that, if turned on, causes +methods that would otherwise issue an IMAP FETCH, STORE, SEARCH, or +COPY client command to instead issue UID FETCH, UID STORE, UID SEARCH, +or UID COPY, respectively. The main difference between message sequence +numbers and message UID's is that, according to RFC2060, UID's must not +change during a session and should not change between sessions, and +must never be reused. Sequence numbers do not have that same guarantee +and in fact may be reused right away. + +Since foldernames also have a unique identifier (UIDVALIDITY), which is +provided when the folder is L a non-existing folder, then L