diff --git a/BUG_IMAPClient_3.xx b/BUG_IMAPClient_3.xx index 95c316c..1f5e1ec 100644 --- a/BUG_IMAPClient_3.xx +++ b/BUG_IMAPClient_3.xx @@ -6,8 +6,16 @@ BUGS found with Mail-IMAPClient-3.05/ 30 timeout. - 2) --expunge2 does not expunge anything. Fixed in Mail-IMAPClient-3.10/ +3) Mail-IMAPClient-3.13/ + + 30 timeout on connection. + +4) Mail-IMAPClient-3.14/ + +Wrong. Lacks isUnconnected() method. + + diff --git a/CREDITS b/CREDITS index ee824db..d634b5a 100644 --- a/CREDITS +++ b/CREDITS @@ -1,5 +1,5 @@ #!/bin/cat -# $Id: CREDITS,v 1.115 2008/08/27 11:56:52 gilles Exp gilles $ +# $Id: CREDITS,v 1.122 2009/05/04 01:08:32 gilles Exp gilles $ If you want to make a donation to the author, Gilles LAMIRAL: @@ -12,7 +12,7 @@ b) If you can read french, please use the following wishlist : http://amazon.fr/gp/registry/wishlist/37RZF7PPCD7YL (books will be send with free postal cost) -c) its paypal account gilles.lamiral@laposte.net +c) its paypal account : gilles.lamiral@laposte.net Here are the persons who helped me to develop imapsync. Feel free to tell me if a name is missing or if you want @@ -20,6 +20,104 @@ to remove one. I thank very much all of these people. +Edward Blackburne +Contributed by giving the book +26.95 "Mathematics and Plausible Reasoning (vol 1)" + + + +Xavier Gattuso +Contributed by giving the book +21.86 "Wicked Cool Perl Scripts: Useful Perl Scripts That Solve Difficult Problems" + + +Richard Madison +Contributed by giving the books +69.95 "Topologie générale: Chapitres 1-4 (French Edition)" +69.95 "Topologie générale: Chapitres 5-10 (French Edition)" + + +Bill Raines +Contributed by giving the book +31.49 "Designing Web Navigation: Optimizing the User Experience" + + +Bataille Vincent +Contributed by giving the books +"Les techniques narratives du cinéma" +"Entretien avec Fabienne Verdier" + +Sann GmbH +Contributed by giving the book +12.21 "Uncommon Therapy (Haley, Jay)" + +Frank Justin Woodman +Contributed by giving the book +75.60 "The Art of Electronics" + +Yohann Lucas +Sent a bug report about "+FLAGS" behavior. + +Reuben Thomas +Corrected my bad english in the README imapsync(1). + +Michal Kubski +Wrote TLS support patches/imapsync-1.217_tls_support.patch + +Jari Salmela +Had success with Sun Java(tm) System Messaging Server 6.2-7.05 +Gave patches/imapsync_1.267_jari +Not applied, this patch is too server specific but +can be useful to specific users. + +Alexander Skwar +From Google Apps domain to Googlemail account. +Had a problem "NO Invalid folder: Sent (Failure)" with +another folder. Solved by --folder (see FAQ) + +Cassio Brodbeck Caporal +Had Microsoft Exchange 2000 6.0.6487.0 success. + +Tomasz Kaczmarski +Found the nice trick + --skipheader '^(?!Message-ID)' +for buggy servers sending the whole header instead of +just one line when --useheader 'Message-ID' is used. + +Benjamin Shapiro +Contributed by giving $5,00 USD (finally 3,38 EUR ) + +Gustavo Lozano +Contributed by giving the book +19.77 "Wicked Cool Shell Scripts" + +Stefan Schmidt +Wrote "speed problem for large mails" FAQ entry. +Fixed INBOX/INBOX bug. + +Janina Banach +Contributed by giving the books +19.77 "Hardware Hacking Projects for Geeks" +23.09 "The Best of MAKE" + +Ricardo David Consolo +Contributed by giving the book +16.49 "More Joel on Software: Further Thoughts on Diverse and ..." + +Quirin Scheitle and Florian Kessler +Contributed by giving the books +32.97 "Designing interfaces: Patterns for Effective Interaction Design" +26.39 "Learning Perl, 5th edition" + + +Robert Sanders +Contributed by giving the book +40.00 "Processing : A Programming Handbook for Visual Designers and Artists" + +Patrick C.F. Ernzer +Contributed by giving the book +19.77 "Funkifying the Clave: Bass and Drums, Goines Ameen" + Daniel Skinner Made me write the FAQ entry about offlineimap and read its documentation. @@ -37,20 +135,20 @@ the authuser method with uw-imap. FAQ entry. Scott Pedigo Contributed by giving the book -"Smart and Gets Things Done" +11.55 "Smart and Gets Things Done" Don Jackson Contributed by giving the book -"The Back of the Napkin" +15.64 "The Back of the Napkin" Joschua Penix Contributed by giving the book -"Programming Collective Intelligence" +26.39 "Programming Collective Intelligence" Bertram N Shure Contributed by giving the book -"Hackers and Painters". +15.61 "Hackers and Painters". Simon Heimlicher Gave a patch to avoid non-selectable folders. @@ -61,7 +159,7 @@ to Cyrus IMAP4 v2.3.7 server ready Drew McLellan Contributed by giving the book -"Peopleware: Productive Projects and Teams" +30.55 "Peopleware: Productive Projects and Teams" Nirdosh Shah Contributed by giving the books @@ -603,6 +701,23 @@ Eric Yung Total amount of book prices : c \ +26.95+\ +21.86+\ +\ +69.95+\ +69.95+\ +31.49+\ +12.21+\ +\ +75.60+\ +19.77+\ +\ +19.77+\ +23.09+\ +16.49+\ +32.97+\ +26.39+\ +\ 16.47+\ 26.39+\ 29.95+\ @@ -632,7 +747,6 @@ c \ 40.00+\ 18.21+\ 24.95+\ -31.49+\ 64.50+\ 32.70+\ 50.40+\ @@ -650,4 +764,4 @@ c \ 31.20+\ 40.00 -=1253.02 +=1668.02 diff --git a/ChangeLog b/ChangeLog index 7684596..7b4d0cb 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,15 +1,102 @@ RCS file: RCS/imapsync,v Working file: imapsync -head: 1.267 +head: 1.284 branch: locks: strict + gilles: 1.284 access list: symbolic names: keyword substitution: kv -total revisions: 267; selected revisions: 267 +total revisions: 284; selected revisions: 284 description: ---------------------------- +revision 1.284 locked by: gilles; +date: 2009/06/30 03:14:24; author: gilles; state: Exp; lines: +15 -19 +allow Mail::IMAPClient 3.0.xx by default +Removed Mail::IMAPClient::Ssl since 3.0.19 has it now. +---------------------------- +revision 1.283 +date: 2009/06/30 02:54:57; author: gilles; state: Exp; lines: +123 -94 +Applied Phil Lobbes patch as is : ./patches/imapsync.1.282.patch +---------------------------- +revision 1.282 +date: 2009/05/11 00:05:39; author: gilles; state: Exp; lines: +15 -10 +Added option --justlogin +---------------------------- +revision 1.281 +date: 2009/04/24 13:58:15; author: gilles; state: Exp; lines: +29 -6 +Added tests_flags_regex() regression tests. +---------------------------- +revision 1.280 +date: 2009/04/02 11:32:10; author: gilles; state: Exp; lines: +103 -47 +Applied Phil patch with many IsUnconnected() calls. +---------------------------- +revision 1.279 +date: 2009/03/22 00:12:15; author: gilles; state: Exp; lines: +9 -7 +isUnconnected BAD IsUnconnected GOOD! +---------------------------- +revision 1.278 +date: 2009/02/23 00:40:25; author: gilles; state: Exp; lines: +14 -12 +Less imap output with +FLAGS.SILENT +Changed unsubscribe subscribe order in documentation. +Typos. +---------------------------- +revision 1.277 +date: 2009/02/21 12:10:50; author: gilles; state: Exp; lines: +8 -6 +Better example explanation. +---------------------------- +revision 1.276 +date: 2009/02/21 04:04:08; author: gilles; state: Exp; lines: +15 -22 +Removed mailto: in MAILING-LIST section. +---------------------------- +revision 1.275 +date: 2009/02/21 02:04:26; author: gilles; state: Exp; lines: +25 -14 +Change real password to "MASKED" in command line output. +---------------------------- +revision 1.274 +date: 2009/02/21 01:10:02; author: gilles; state: Exp; lines: +14 -8 +--delete 2 is now a fatal error. +---------------------------- +revision 1.273 +date: 2009/02/21 00:48:40; author: gilles; state: Exp; lines: +36 -37 +Print a warning and return error code each time a disconnection occurs. +---------------------------- +revision 1.272 +date: 2009/02/20 23:41:09; author: gilles; state: Exp; lines: +78 -78 +Fixed many English errors (thanks to Reuben Thomas) +---------------------------- +revision 1.271 +date: 2009/02/19 23:38:32; author: gilles; state: Exp; lines: +28 -35 +Bug fix about $t_prefix and INBOX '.' was hardcoded. +Small change on documentation. +---------------------------- +revision 1.270 +date: 2009/02/14 22:21:35; author: gilles; state: Exp; lines: +16 -11 +Another Phil Lobbes patch. +Exit with error code and warning when a server disconnect +during the folder loop. +---------------------------- +revision 1.269 +date: 2009/02/14 22:08:18; author: gilles; state: Exp; lines: +65 -38 +Applied Phil Lobbes patches. +- catch (what should be) fatal eval errors for regextrans2, + $regexflag, $regexmess, instead of silently ignoring them + and letting the user think they are working/OK +- fix login_imap() Died at .../imapsync line 780 when IsUnconnected() + and log some more useful into to stderr than just 'Died at...' +- check_lib_version() contains a bad use of unset match/capture variables +- added and now use new function myconnect() and myconnect_v2() + does not require hack/override of Mail::IMAPClient::connect + and is backwards compatible with Mail::IMAPClient v2.x +- redo $Mail::IMAPClient::Authuser hack since only + Mail::IMAPClient v2 does not have Authuser() +Many thanks to Phil. +---------------------------- +revision 1.268 +date: 2009/02/14 03:27:51; author: gilles; state: Exp; lines: +22 -21 +Fixed bad VERSION_IMAPClient output +---------------------------- revision 1.267 date: 2008/10/07 11:36:02; author: gilles; state: Exp; lines: +14 -10 Better test to check non existing folders on destination diff --git a/FAQ b/FAQ index aa1642b..6ae0a6a 100644 --- a/FAQ +++ b/FAQ @@ -1,3 +1,5 @@ +#!/bin/cat +# $Id: FAQ,v 1.59 2009/04/30 02:09:09 gilles Exp gilles $ +------------------+ | FAQ for imapsync | @@ -18,10 +20,35 @@ Q. Can you give some configuration examples ? R. http://www.linux-france.org/prj/imapsync/FAQ +======================================================================= +Q. How can I have support ? + +R. Use the mailing-list + +To write on the mailing-list, the address is: + + +To subscribe, send a message to: + + +To unsubscribe, send a message to: + + +To contact the person in charge for the list: + + +The list archives may be available at: +http://www.linux-france.org/prj/imapsync_list/ +So consider that the list is public, anyone +can see your post. Use a pseudonym or do not +post to this list if you want to stay private. + +Thank you for your participation. + ======================================================================= Q. Where I can read IMAP RFCs ? -R. +R. Here: RFC 3501 - INTERNET MESSAGE ACCESS PROTOCOL - VERSION 4rev1 http://www.faqs.org/rfcs/rfc3501.html @@ -45,7 +72,22 @@ Q. Where I can find old imapsync releases ? R. ftp://www.linux-france.org/pub/prj/imapsync/ ======================================================================= -Q. imapsync does not work with Mail::IMAPClient 3.0.x +Q. How can I try imapsync with Mail::IMAPClient 3.xx perl library? + +R. - Download latest Mail::IMAPClient 3.xx at + http://search.cpan.org/dist/Mail-IMAPClient/ + - untar it anywhere: + tar xzvf Mail-IMAPClient-3.xx.tar.gz + + - Download latest imapsync at + http://lamiral.info/~gilles/imapsync/imapsync + + - run imapsync with perl and -I option tailing to use Mail-IMAPClient-3.xx + and add also option --allow3xx: + perl -I./Mail-IMAPClient-3.16/lib imapsync ... --allow3xx + +======================================================================= +Q. imapsync does not work with Mail::IMAPClient 3.xx How can I downgrade to 2.2.9 release? R. - Download Mail::IMAPClient 2.2.9 at @@ -278,14 +320,33 @@ To skip several headers you can use --skipheader one time imapsync ... --skipheader '^X-|^Status|^Bcc' -or several times (same result) - - imapsync ... --skipheader '^X-' --skipheader '^Status' --skipheader '^Bcc' - If you think you have too many header to avoid just use imapsync ... --useheader 'Message-ID' --skipsize +Remark. (Trick found by Tomasz Kaczmarski) +Option --useheader 'Message-ID' asks the server +to send only header lines begining with 'Message-ID'. +Some (buggy) servers send the whole header (all lines) +instead of the 'Message-ID' line. In that case, a trick +to keep the --useheader filtering behavior is to use +--skipheader with a negative lookahead pattern : + + imapsync ... --skipheader '^(?!Message-ID)' --skipsize + + Read it as "skip every header except Message-ID". + +====================================================================== +Q. I am transferring mails from one IMAP server to another. I am using + an SSL connection. Transferring huge mails (>10MB) takes ages. + +R. try to transfer the mails without SSL connection. SSL code outside + imapsync uses a memory buffer, which gets increased upon reading of + mails by 4096 bytes. This creates a huge load on the host imapsync + runs on by copying the memory buffers for every 4096 byte step. + This does not occur without SSL. + +(Written by Stefan Schmidt) ====================================================================== Q. I want to exclude a folder hierarchy like "public" @@ -471,6 +532,31 @@ Also, you must take imapsync 1.159 at least since I tested what I just wrote above and found 2 bugs about --mindate --maxdate options behavior. +======================================================================= +Q. I want to play with headers line and --regexmess but I want to leave + the body as is + +R. The header/body separation is a blank line so an example: + --regexmess 's{\A(.*?(?! ^$))^Date:(.*?)$}{$1Date:$2\nX-Date:$2}gxms' + +Will replace + +HeaderBegin +Message-ID: <499EF800.4030002@blabla.fr> +Date: Fri, 20 Feb 2009 19:35:44 +0100 +From: Gilles LAMIRAL +HeaderEnd + +by + +HeaderBegin +Message-ID: <499EF800.4030002@blabla.fr> +Date: Fri, 20 Feb 2009 19:35:44 +0100 +X-Date: Fri, 20 Feb 2009 19:35:44 +0100 +From: Gilles LAMIRAL +HeaderEnd + +This example just add an header line "X-Date:" based on "Date:" line. ======================================================================= Q. My imap server does not accept a message and warns @@ -531,6 +617,7 @@ imapsync --syncinternaldates \ --host2 imap.gmail.com --port2 993 --ssl2 \ --user2 my_email@gmail.com \ --password2 password \ + --useheader 'Message-Id' --skipsize \ --prefix2 '[Gmail]/' \ --folder 'INBOX.Sent' \ --regextrans2 's/Sent/Sent Mail/' @@ -556,6 +643,41 @@ option: --regextrans2 's/\[Gmail\]/Gmail/' +======================================================================= +Q. migrate email from gmail to google apps + +R. Take a look at: +http://biasecurities.com/2009/migrate-email-from-gmail-to-google-apps/ +http://www.thamtech.com/blog/2008/03/29/gmail-to-google-apps-email-migration/ + +======================================================================= +Q. from Microsoft's Exchange 2007 to Google Apps for your Domain + (GAFYD) + +R. Take a look at: +http://mark.ossdl.de/2009/02/migrating-from-exchange-2007-to-google-apps-mail/ + +======================================================================= +Q. Syncing from Google Apps domain to Googlemail account + +A known bug encountered with this output (Alexander is a folder name): +++++ Verifying [Alexander] -> [Alexander] ++++ ++ NO msg #16 [A96Dh4AwlLVphOAW5MS/eQ:779824] in Alexander ++ Copying msg #16:779824 to folder Alexander +flags from : [\Seen]["04-Jul-2007 14:32:22 +0100"] +Couldn't append msg #16 (Subject:[Rieter-Event (please accept with +comments)]) to folder Alexander: 46 NO Invalid folder: Sent (Failure) + +In fact folder "Sent" is just the last folder listed previously +as a: +... +To Folder [Sent] does not exist yet +To Folder [Sonja] Size: 1024546 Messages: 96 +... + +R. Just run imapsync a time like this : +imapsync ... --folder Alexander + ======================================================================= Q. I'm migrating from WU to Cyrus, and the mail folders are under /home/user/mail but the tool copies everything in @@ -729,6 +851,11 @@ R. http://www.archiveopteryx.org/migration/imapsync Use: --useheader Message-Id --skipsize +====================================================================== +Q. To Sun Java(tm) System Messaging Server 6.2-7.05 +Q. To Communigate Pro - Solaris version + +R. See and run patches/imapsync_1.267_jari ====================================================================== Q. From any to Exchange2007 @@ -749,6 +876,12 @@ R2. Other solution Two users succeded by using "MS Transporter Suite" (which is closed expensive nonfree software). +====================================================================== +Q. From Microsoft Exchange 2000 IMAP4rev1 server version 6.0.6487.0. + +R. imapsync ... \ + --prefix1 INBOX. --prefix2 INBOX. --syncinternaldates --subscribe \ + --maxsize 10485760 ====================================================================== Q: How can I write an .rpm with imapsync diff --git a/INSTALL b/INSTALL index bf26e8c..b55de20 100644 --- a/INSTALL +++ b/INSTALL @@ -1,4 +1,4 @@ -# $Id: INSTALL,v 1.14 2008/08/16 17:18:58 gilles Exp gilles $ +# $Id: INSTALL,v 1.15 2009/06/30 03:21:17 gilles Exp gilles $ # # INSTALL file for imapsync # imapsync : IMAP sync or copy tool. @@ -58,12 +58,13 @@ Here is some individual module help: http://search.cpan.org/~djkernen/ http://search.cpan.org/~djkernen/Mail-IMAPClient-2.2.9/ - In fact I use Mail-IMAPClient-2.2.9 (debian package) + In fact I use Mail-IMAPClient-2.2.9 To know the version you have on your system try : perl -mMail::IMAPClient -e 'print $Mail::IMAPClient::VERSION, "\n"' - New Mail-IMAPClient-3.xx doesn't work with imapsync for the moment. + New Mail-IMAPClient-3.xx works now with imapsync, + at least with Mail-IMAPClient-3.19 (previous may bug) - Perl Digest::MD5 module. http://search.cpan.org/ @@ -111,9 +112,10 @@ TESTING ------- The test will break as they are home specific. -You need a running imap server on localhost with two accounts -toto@est.belle with a password located in the file /var/tmp/secret1 -titi@est.belle with a password located in the file /var/tmp/secret2 +You need a running imap server on localhost with several accounts +toto with a password located in the file $HOME/var/pass/secret.toto +titi with a password located in the file $HOME/var/pass/secret.titi +tata with a password located in the file $HOME/var/pass/secret.tata Of course, you can change the file tests.sh and run the tests with : diff --git a/Mail-IMAPClient-2.2.9/Artistic b/Mail-IMAPClient-2.2.9/Artistic new file mode 100644 index 0000000..5f22124 --- /dev/null +++ b/Mail-IMAPClient-2.2.9/Artistic @@ -0,0 +1,131 @@ + + + + + The "Artistic License" + + Preamble + +The intent of this document is to state the conditions under which a +Package may be copied, such that the Copyright Holder maintains some +semblance of artistic control over the development of the package, +while giving the users of the package the right to use and distribute +the Package in a more-or-less customary fashion, plus the right to make +reasonable modifications. + +Definitions: + + "Package" refers to the collection of files distributed by the + Copyright Holder, and derivatives of that collection of files + created through textual modification. + + "Standard Version" refers to such a Package if it has not been + modified, or has been modified in accordance with the wishes + of the Copyright Holder as specified below. + + "Copyright Holder" is whoever is named in the copyright or + copyrights for the package. + + "You" is you, if you're thinking about copying or distributing + this Package. + + "Reasonable copying fee" is whatever you can justify on the + basis of media cost, duplication charges, time of people involved, + and so on. (You will not be required to justify it to the + Copyright Holder, but only to the computing community at large + as a market that must bear the fee.) + + "Freely Available" means that no fee is charged for the item + itself, though there may be fees involved in handling the item. + It also means that recipients of the item may redistribute it + under the same conditions they received it. + +1. You may make and give away verbatim copies of the source form of the +Standard Version of this Package without restriction, provided that you +duplicate all of the original copyright notices and associated disclaimers. + +2. You may apply bug fixes, portability fixes and other modifications +derived from the Public Domain or from the Copyright Holder. A Package +modified in such a way shall still be considered the Standard Version. + +3. You may otherwise modify your copy of this Package in any way, provided +that you insert a prominent notice in each changed file stating how and +when you changed that file, and provided that you do at least ONE of the +following: + + a) place your modifications in the Public Domain or otherwise make them + Freely Available, such as by posting said modifications to Usenet or + an equivalent medium, or placing the modifications on a major archive + site such as uunet.uu.net, or by allowing the Copyright Holder to include + your modifications in the Standard Version of the Package. + + b) use the modified Package only within your corporation or organization. + + c) rename any non-standard executables so the names do not conflict + with standard executables, which must also be provided, and provide + a separate manual page for each non-standard executable that clearly + documents how it differs from the Standard Version. + + d) make other distribution arrangements with the Copyright Holder. + +4. You may distribute the programs of this Package in object code or +executable form, provided that you do at least ONE of the following: + + a) distribute a Standard Version of the executables and library files, + together with instructions (in the manual page or equivalent) on where + to get the Standard Version. + + b) accompany the distribution with the machine-readable source of + the Package with your modifications. + + c) give non-standard executables non-standard names, and clearly + document the differences in manual pages (or equivalent), together + with instructions on where to get the Standard Version. + + d) make other distribution arrangements with the Copyright Holder. + +5. You may charge a reasonable copying fee for any distribution of this +Package. You may charge any fee you choose for support of this +Package. You may not charge a fee for this Package itself. However, +you may distribute this Package in aggregate with other (possibly +commercial) programs as part of a larger (possibly commercial) software +distribution provided that you do not advertise this Package as a +product of your own. You may embed this Package's interpreter within +an executable of yours (by linking); this shall be construed as a mere +form of aggregation, provided that the complete Standard Version of the +interpreter is so embedded. + +6. The scripts and library files supplied as input to or produced as +output from the programs of this Package do not automatically fall +under the copyright of this Package, but belong to whoever generated +them, and may be sold commercially, and may be aggregated with this +Package. If such scripts or library files are aggregated with this +Package via the so-called "undump" or "unexec" methods of producing a +binary executable image, then distribution of such an image shall +neither be construed as a distribution of this Package nor shall it +fall under the restrictions of Paragraphs 3 and 4, provided that you do +not represent such an executable image as a Standard Version of this +Package. + +7. C subroutines (or comparably compiled subroutines in other +languages) supplied by you and linked into this Package in order to +emulate subroutines and variables of the language defined by this +Package shall not be considered part of this Package, but are the +equivalent of input as in Paragraph 6, provided these subroutines do +not change the language in any way that would cause it to fail the +regression tests for the language. + +8. Aggregation of this Package with a commercial distribution is always +permitted provided that the use of this Package is embedded; that is, +when no overt attempt is made to make this Package's interfaces visible +to the end user of the commercial distribution. Such use shall not be +construed as a distribution of this Package. + +9. The name of the Copyright Holder may not be used to endorse or promote +products derived from this software without specific prior written permission. + +10. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED +WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. + + The End diff --git a/Mail-IMAPClient-2.2.9/BUG_REPORTS b/Mail-IMAPClient-2.2.9/BUG_REPORTS new file mode 100644 index 0000000..5fff255 --- /dev/null +++ b/Mail-IMAPClient-2.2.9/BUG_REPORTS @@ -0,0 +1,9 @@ +REPORING BUGS + +See the section on "REPORTING BUGS" in the module's documentation if you are +having problems. + +YOU MUST FOLLOW THE INSTRUCTIONS IN THE DOCUMENTATION AND PROVIDE ALL OF THE NECESSARY +INFORMATION if you expect a response from your bug report. You should also look at +the data you gather before you send it, since doing so will often solve your problem. + diff --git a/Mail-IMAPClient-2.2.9/BodyStructure/BodyStructure.pm b/Mail-IMAPClient-2.2.9/BodyStructure/BodyStructure.pm new file mode 100755 index 0000000..99eccab --- /dev/null +++ b/Mail-IMAPClient-2.2.9/BodyStructure/BodyStructure.pm @@ -0,0 +1,725 @@ +package Mail::IMAPClient::BodyStructure; +#$Id: BodyStructure.pm,v 1.3 2003/06/12 21:41:37 dkernen Exp $ +#use Parse::RecDescent; +use Mail::IMAPClient; +use Mail::IMAPClient::BodyStructure::Parse; +use vars qw/$parser/; +use Exporter; +push @ISA, "Exporter"; +push @EXPORT_OK , '$parser'; + +$Mail::IMAPClient::BodyStructure::VERSION = '0.0.2'; +# Do it once more to show we mean it! +$Mail::IMAPClient::BodyStructure::VERSION = '0.0.2'; + +$parser = Mail::IMAPClient::BodyStructure::Parse->new() + + or die "Cannot parse rules: $@\n" . + "Try remaking Mail::IMAPClient::BodyStructure::Parse.\n" + and return undef; + + +sub new { + my $class = shift; + my $bodystructure = shift; + my $self = $parser->start($bodystructure) or return undef; + $self->{_prefix} = ""; + + if ( exists $self->{bodystructure} ) { + $self->{_id} = 'HEAD' ; + } else { + $self->{_id} = 1; + } + + $self->{_top} = 1; + + return bless($self ,ref($class)||$class); +} + +sub _get_thingy { + my $thingy = shift; + my $object = shift||(ref($thingy)?$thingy:undef); + unless ( defined($object) and ref($object) ) { + $@ = "No argument passed to $thingy method." ; + $^W and print STDERR "$@\n" ; + return undef; + } + unless ( "$object" =~ /HASH/ + and exists($object->{$thingy}) + ) { + $@ = ref($object) . + " $object does not have " . + ( $thingy =~ /^[aeiou]/i ? "an " : "a " ) . + "${thingy}. " . + ( ref($object) =~ /HASH/ ? "It has " . join(", ",keys(%$object)) : "") ; + $^W and print STDERR "$@\n" ; + return undef; + } + return Unwrapped($object->{$thingy}); +} + +BEGIN { + foreach my $datum (qw/ bodytype bodysubtype bodyparms bodydisp bodyid + bodydesc bodyenc bodysize bodylang + envelopestruct textlines + / + ) { + no strict 'refs'; + *$datum = sub { _get_thingy($datum, @_); }; + } + +} + +sub parts { + my $self = shift; + + + if ( exists $self->{PartsList} ) { + return wantarray ? @{$self->{PartsList}} : $self->{PartsList} ; + } + + my @parts = (); + $self->{PartsList} = \@parts; + + unless ( exists($self->{bodystructure}) ) { + $self->{PartsIndex}{1} = $self ; + @parts = ("HEAD",1); + return wantarray ? @parts : \@parts; + } + #@parts = ( 1 ); + #} else { + + foreach my $p ($self->bodystructure()) { + push @parts, $p->id(); + $self->{PartsIndex}{$p->id()} = $p ; + if ( uc($p->bodytype()||"") eq "MESSAGE" ) { + #print "Part $parts[-1] is a ",$p->bodytype,"\n"; + push @parts,$parts[-1] . ".HEAD"; + #} else { + # print "Part $parts[-1] is a ",$p->bodytype,"\n"; + } + } + + #} + + return wantarray ? @parts : \@parts; +} + +sub oldbodystructure { + my $self = shift; + if ( exists $self->{_bodyparts} ) { + return wantarray ? @{$self->{_bodyparts}} : $self->{_bodyparts} ; + } + my @bodyparts = ( $self ); + $self->{_id} ||= "HEAD"; # aka "0" + my $count = 0; + #print STDERR "Analyzing a ",$self->bodytype, " part which I think is part number ", + # $self->{_id},"\n"; + my $dump = Data::Dumper->new( [ $self ] , [ 'bodystructure' ] ); + $dump->Indent(1); + + foreach my $struct (@{$self->{bodystructure}}) { + $struct->{_prefix} ||= $self->{_prefix} . +$count . "." unless $struct->{_top}; + $struct->{_id} ||= $self->{_prefix} . $count unless $struct->{_top}; + #if ( + # uc($struct->bodytype) eq 'MULTIPART' or + # uc($struct->bodytype) eq 'MESSAGE' + #) { + #} else { + #} + push @bodyparts, $struct, + ref($struct->{bodystructure}) ? $struct->bodystructure : () ; + } + $self->{_bodyparts} = \@bodyparts ; + return wantarray ? @bodyparts : $self->bodyparts ; +} + +sub bodystructure { + my $self = shift; + my @parts = (); + my $partno = 0; + + my $prefix = $self->{_prefix} || ""; + + #print STDERR "Analyzing a ",($self->bodytype||"unknown ") , + # " part which I think is part number ", + # $self->{_id},"\n"; + + my $bs = $self; + $prefix = "$prefix." if ( $prefix and $prefix !~ /\.$/); + + if ( $self->{_top} ) { + $self->{_id} ||= "HEAD"; + $self->{_prefix} ||= "HEAD"; + $partno = 0; + for (my $x = 0; $x < scalar(@{$self->{bodystructure}}) ; $x++) { + $self->{bodystructure}[$x]{_id} = ++$partno ; + $self->{bodystructure}[$x]{_prefix} = $partno ; + push @parts, $self->{bodystructure}[$x] , + $self->{bodystructure}[$x]->bodystructure; + } + + + } else { + $partno = 0; + foreach my $p ( @{$self->{bodystructure}} ) { + $partno++; + if ( + ! exists $p->{_prefix} + ) { + $p->{_prefix} = "$prefix$partno"; + } + $p->{_prefix} = "$prefix$partno"; + $p->{_id} ||= "$prefix$partno"; + #my $bt = $p->bodytype; + #if ($bt eq 'MESSAGE') { + #$p->{_id} = $prefix . + #$partno = 0; + #} + push @parts, $p, $p->{bodystructure} ? $p->bodystructure : (); + } + } + + return wantarray ? @parts : \@parts; +} + +sub id { + my $self = shift; + + return $self->{_id} if exists $self->{_id}; + return "HEAD" if $self->{_top}; + #if ($self->bodytype eq 'MESSAGE') { + # return + #} + + if ($self->{bodytype} eq 'MULTIPART') { + my $p = $self->{_id}||$self->{_prefix} ; + $p =~ s/\.$//; + return $p; + } else { + return $self->{_id} ||= 1; + } +} + +sub Unwrapped { + my $unescape = Mail::IMAPClient::Unescape(@_); + $unescape =~ s/^"(.*)"$/$1/ if defined($unescape); + return $unescape; +} + +package Mail::IMAPClient::BodyStructure::Part; +@ISA = qw/Mail::IMAPClient::BodyStructure/; + + +package Mail::IMAPClient::BodyStructure::Envelope; +@ISA = qw/Mail::IMAPClient::BodyStructure/; + +sub new { + my $class = shift; + my $envelope = shift; + my $self = $Mail::IMAPClient::BodyStructure::parser->envelope($envelope); + return $self; +} + + +sub _do_accessor { + my $datum = shift; + if (scalar(@_) > 1) { + return $_[0]->{$datum} = $_[1] ; + } else { + return $_[0]->{$datum}; + } +} + +# the following for loop sets up accessor methods for +# the object's address attributes: + +sub _mk_address_method { + my $datum = shift; + my $method1 = $datum . "_addresses" ; + no strict 'refs'; + *$method1 = sub { + my $self = shift; + return undef unless ref($self->{$datum}) eq 'ARRAY'; + my @list = map { + my $pn = $_->personalname ; + $pn = "" if $pn eq 'NIL' ; + ( $pn ? "$pn " : "" ) . + "<" . + $_->mailboxname . + '@' . + $_->hostname . + ">" + } @{$self->{$datum}} ; + if ( $senderFields{$datum} ) { + return wantarray ? @list : $list[0] ; + } else { + return wantarray ? @list : \@list ; + } + }; +} + +BEGIN { + + for my $datum ( + qw( subject inreplyto from messageid bcc date replyto to sender cc ) + ) { + no strict 'refs'; + *$datum = sub { _do_accessor($datum, @_); }; + } + my %senderFields = map { ($_ => 1) } qw/from sender replyto/ ; + for my $datum ( + qw( from bcc replyto to sender cc ) + ) { + _mk_address_method($datum); + } +} + + +package Mail::IMAPClient::BodyStructure::Address; +@ISA = qw/Mail::IMAPClient::BodyStructure/; + +for my $datum ( + qw( personalname mailboxname hostname sourcename ) + ) { + no strict 'refs'; + *$datum = sub { return $_[0]->{$datum}; }; +} + +1; +__END__ + +=head1 NAME + +Mail::IMAPClient::BodyStructure - Perl extension to Mail::IMAPClient to facilitate +the parsing of server responses to the FETCH BODYSTRUCTURE and FETCH ENVELOPE +IMAP client commands. + +=head1 SYNOPSIS + + use Mail::IMAPClient::BodyStructure; + use Mail::IMAPClient; + + my $imap = Mail::IMAPClient->new(Server=>$serv,User=>$usr,Password=>$pwd); + $imap->select("INBOX") or die "cannot select the inbox for $usr: $@\n"; + + my @recent = $imap->search("recent"); + + foreach my $new (@recent) { + + my $struct = Mail::IMAPClient::BodyStructure->new( + $imap->fetch($new,"bodystructure") + ); + + print "Msg $new (Content-type: ",$struct->bodytype,"/",$struct->bodysubtype, + ") contains these parts:\n\t",join("\n\t",$struct->parts),"\n\n"; + + + } + + + + +=head1 DESCRIPTION + +This extension will parse the result of an IMAP FETCH BODYSTRUCTURE command into a perl +data structure. It also provides helper methods that will help you pull information out +of the data structure. + +Use of this extension requires Parse::RecDescent. If you don't have Parse::RecDescent +then you must either get it or refrain from using this module. + +=head2 EXPORT + +Nothing is exported by default. C<$parser> is exported upon request. C<$parser> +is the BodyStucture object's Parse::RecDescent object, which you'll probably +only need for debugging purposes. + +=head1 Class Methods + +The following class method is available: + +=head2 new + +This class method is the constructor method for instantiating new +Mail::IMAPClient::BodyStructure objects. The B method accepts one argument, +a string containing a server response to a FETCH BODYSTRUCTURE directive. +Only one message's body structure should be described in this +string, although that message may contain an arbitrary number of parts. + +If you know the messages sequence number or unique ID (UID) but haven't got its +body structure, and you want to get the body structure and parse it into a +B object, then you might as well save yourself +some work and use B's B method, which +accepts a message sequence number (or UID if I is true) and returns a +B object. It's functionally equivalent to issuing the +FETCH BODYSTRUCTURE IMAP client command and then passing the results to +B's B method but it does those things in one +simple method call. + +=head1 Object Methods + +The following object methods are available: + +=head2 bodytype + +The B object method requires no arguments. +It returns the bodytype for the message whose structure is described by the calling +B object. + +=cut + +=head2 bodysubtype + +The B object method requires no arguments. +It returns the bodysubtype for the message whose structure is described by the calling +B object. + +=cut + + + +=head2 bodyparms + +The B object method requires no arguments. +It returns the bodyparms for the message whose structure is described by the calling +B object. + +=cut + + + +=head2 bodydisp + +The B object method requires no arguments. +It returns the bodydisp for the message whose structure is described by the calling +B object. + +=cut + + + +=head2 bodyid + +The B object method requires no arguments. +It returns the bodyid for the message whose structure is described by the calling +B object. + +=cut + + + +=head2 bodydesc + +The B object method requires no arguments. +It returns the bodydesc for the message whose structure is described by the calling +B object. + +=cut + + + +=head2 bodyenc + +The B object method requires no arguments. +It returns the bodyenc for the message whose structure is described by the calling +B object. + +=cut + + + +=head2 bodysize + +The B object method requires no arguments. +It returns the bodysize for the message whose structure is described by the calling +B object. + +=cut + + + +=head2 bodylang + +The B object method requires no arguments. +It returns the bodylang for the message whose structure is described by the calling +B object. + +=cut + +=head2 bodystructure + +The B object method requires no arguments. +It returns the bodystructure for the message whose structure is described by the calling +B object. + +=cut + + + +=head2 envelopestruct + +The B object method requires no arguments. +It returns the envelopestruct for the message whose structure is described by the +calling B object. This envelope structure is blessed +into the B subclass, which is explained more +fully below. + +=cut + + +=head2 textlines + +The B object method requires no arguments. +It returns the textlines for the message whose structure is described by the calling +B object. + +=cut + +=head1 Envelopes and the Mail::IMAPClient::BodyStructure::Envelope Subclass + +The IMAP standard specifies that output from the IMAP B command +will be an RFC2060 envelope structure. It further specifies that output from the +B command may also contain embedded envelope structures (if, +for example, a message's subparts contain one or more included messages). Objects +belonging to B are Perl representations +of these envelope structures, which is to say the nested parenthetical lists of +RFC2060 translated into a Perl datastructure. + +Note that all of the fields relate to the specific part to which they belong. In other +words, output from a FETCH nnnn ENVELOPE command (or, in B, +C<$imap->fetch($msgid,"ENVELOPE")> or Cget_envelope($msgid)>) are for +the message, but fields from within a bodystructure relate to the message subpart and +not the parent message. + +An envelope structure's B representation +is a hash of thingies that looks like this: + +{ + subject => "subject", + inreplyto => "reference_message_id", + from => [ addressStruct1 ], + messageid => "message_id", + bcc => [ addressStruct1, addressStruct2 ], + date => "Tue, 09 Jul 2002 14:15:53 -0400", + replyto => [ adressStruct1, addressStruct2 ], + to => [ adressStruct1, addressStruct2 ], + sender => [ adressStruct1 ], + cc => [ adressStruct1, addressStruct2 ], +} + +The B<...::Envelope> object also has methods for accessing data in the structure. They +are: + +=over 4 + +=item date + +Returns the date of the message. + +=item inreplyto + +Returns the message id of the message to which this message is a reply. + +=item subject + +Returns the subject of the message. + +=item messageid + +Returns the message id of the message. + +=back + +You can also use the following methods to get addressing information. Each of these methods +returns an array of B objects, which are perl +data structures representing RFC2060 address structures. Some of these arrays would naturally +contain one element (such as B, which normally contains a single "From:" address); others +will often contain more than one address. However, because RFC2060 defines all of these as "lists +of address structures", they are all translated into arrays of B<...::Address> objects. + +See the section on B", below, for alternate (and +preferred) ways of accessing these data. + +The methods available are: + +=over 4 + +=item bcc + +Returns an array of blind cc'ed recipients' address structures. (Don't expect much in here +unless the message was sent from the mailbox you're poking around in, by the way.) + +=item cc + +Returns an array of cc'ed recipients' address structures. + +=item from + +Returns an array of "From:" address structures--usually just one. + +=item replyto + +Returns an array of "Reply-to:" address structures. Once again there is usually +just one address in the list. + +=item sender + +Returns an array of senders' address structures--usually just one and usually the same +as B. + +=item to + +Returns an array of recipients' address structures. + +=back + +Each of the methods that returns a list of address structures (i.e. a list of +B arrays) also has an analagous method +that will return a list of E-Mail addresses instead. The addresses are in the +format Cmailboxname@hostnameE> (see the section on +B, below) However, if the personal name +is 'NIL' then it is omitted from the address. + +These methods are: + +=over 4 + +=item bcc_addresses + +Returns a list (or an array reference if called in scalar context) of blind cc'ed +recipients' email addresses. (Don't expect much in here unless the message was sent +from the mailbox you're poking around in, by the way.) + +=item cc_addresses + +Returns a list of cc'ed recipients' email addresses. If called in a scalar +context it returns a reference to an array of email addresses. + +=item from_addresses + +Returns a list of "From:" email addresses. If called in a scalar context +it returns the first email address in the list. (It's usually a list of just +one anyway.) + +=item replyto_addresses + +Returns a list of "Reply-to:" email addresses. If called in a scalar context +it returns the first email address in the list. + +=item sender_addresses + +Returns a list of senders' email addresses. If called in a scalar context +it returns the first email address in the list. + +=item to_addresses + +Returns a list of recipients' email addresses. If called in a scalar context +it returns a reference to an array of email addresses. + +=back + +Note that context affects the behavior of all of the above methods. + +Those fields that will commonly contain multiple entries (i.e. they are +recipients) will return an array reference when called in scalar context. +You can use this behavior to optimize performance. + +Those fields that will commonly contain just one address (the sender's) will +return the first (and usually only) address. You can use this behavior to +optimize your development time. + +=head1 Addresses and the Mail::IMAPClient::BodyStructure::Address + +Several components of an envelope structure are address structures. They are each +parsed into their own object, B, which +looks like this: + + { + mailboxname => 'somebody.special', + hostname => 'somplace.weird.com', + personalname => 'Somebody Special + sourceroute => 'NIL' + } + +RFC2060 specifies that each address component of a bodystructure is a list of +address structures, so B parses each of these into +an array of B objects. + +Each of these objects has the following methods available to it: + +=over 4 + +=item mailboxname + +Returns the "mailboxname" portion of the address, which is the part to the left +of the '@' sign. + +=item hostname + +Returns the "hostname" portion of the address, which is the part to the right of the +'@' sign. + +=item personalname + +Returns the "personalname" portion of the address, which is the part of +the address that's treated like a comment. + +=item sourceroute + +Returns the "sourceroute" portion of the address, which is typically "NIL". + +=back + +Taken together, the parts of an address structure form an address that will +look something like this: + +Cmailboxname@hostnameE> + +Note that because the B objects come in +arrays, it's generally easier to use the methods available to +B to obtain all of the addresses in a +particular array in one operation. These methods are provided, however, in case +you'd rather do things the hard way. (And also because the aforementioned methods +from B need them anyway.) + +=cut + +=head1 AUTHOR + +David J. Kernen + +=head1 SEE ALSO + +perl(1), Mail::IMAPClient, and RFC2060. See also Parse::RecDescent if you want +to understand the internals of this module. + +=cut + + +# History: +# $Log: BodyStructure.pm,v $ +# Revision 1.3 2003/06/12 21:41:37 dkernen +# Cleaning up cvs repository +# +# Revision 1.1 2003/06/12 21:37:03 dkernen +# +# Preparing 2.2.8 +# Added Files: COPYRIGHT +# Modified Files: Parse.grammar +# Added Files: Makefile.old +# Makefile.PL Todo sample.perldb +# BodyStructure.pm +# +# Revision 1.2 2002/09/26 17:56:14 dkernen +# +# Modified Files: +# BUG_REPORTS Changes IMAPClient.pm INSTALL_perl5.80 MANIFEST +# Makefile.PL for version 2.2.3. See the Changes file for details. +# Modified Files: BodyStructure.pm -- cosmetic changes to pod doc +# +# Revision 1.1 2002/08/30 20:58:51 dkernen +# +# In Mail::IMAPClient/IMAPClient, added files: BUG_REPORTS getGrammer runtest sample.perldb +# In Mail::IMAPClient/IMAPClient/BodyStructure, added files: BodyStructure.pm Makefile.PL debug.ksh runtest +# diff --git a/Mail-IMAPClient-2.2.9/BodyStructure/COPYRIGHT b/Mail-IMAPClient-2.2.9/BodyStructure/COPYRIGHT new file mode 100644 index 0000000..d5cdcf8 --- /dev/null +++ b/Mail-IMAPClient-2.2.9/BodyStructure/COPYRIGHT @@ -0,0 +1,21 @@ +COPYRIGHT + + Copyright 1999, 2000, 2001, 2002 , 2003 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 version 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. All your +base are belong to us. + diff --git a/Mail-IMAPClient-2.2.9/BodyStructure/Makefile.PL b/Mail-IMAPClient-2.2.9/BodyStructure/Makefile.PL new file mode 100755 index 0000000..8fc4004 --- /dev/null +++ b/Mail-IMAPClient-2.2.9/BodyStructure/Makefile.PL @@ -0,0 +1,12 @@ +use ExtUtils::MakeMaker; +# See lib/ExtUtils/MakeMaker.pm for details of how to influence +# the contents of the Makefile that is written. +WriteMakefile( + 'DIR' => [ 'Parse' ] , + 'NAME' => 'Mail::IMAPClient::BodyStructure', + 'VERSION_FROM' => '../IMAPClient.pm', # finds $VERSION + 'PREREQ_PM' => { + "Parse::RecDescent" => '1.94', + "Exporter" => 0, + }, +); diff --git a/Mail-IMAPClient-2.2.9/BodyStructure/Parse/Makefile.PL b/Mail-IMAPClient-2.2.9/BodyStructure/Parse/Makefile.PL new file mode 100755 index 0000000..a375142 --- /dev/null +++ b/Mail-IMAPClient-2.2.9/BodyStructure/Parse/Makefile.PL @@ -0,0 +1,46 @@ +use ExtUtils::MakeMaker; +use Parse::RecDescent; + +unlink "./Parse.pm" if -f "./Parse.pm"; +sub MY::top_targets { + package MY; + + my $inherit = shift->SUPER::top_targets(@_); + my @inherit = split("\n",$inherit); + for (@inherit) { + if ( /^\s*all\s*:{1,2}/ ) { + s/(all\s*:{1,2}\s*)/$1Parse\.pm /; + } + } + return join("\n",@inherit); +} + +sub MY::clean { + package MY; + + my $inherit = shift->SUPER::clean(@_); + return join("\n",$inherit," rm Parse.pm") ; +} + +sub MY::postamble { + my $string = + '@$(PERL) "-MParse::RecDescent" "-" ' . + '"Parse.grammar" '. + '"Mail::IMAPClient::BodyStructure::Parse"' ; + return "Parse.pm: Parse.grammar\n\t$string\n\n"; +} + +# See lib/ExtUtils/MakeMaker.pm for details of how to influence +# the contents of the Makefile that is written. +#print "",MY->top_target; + +WriteMakefile( + 'NAME' => 'Mail::IMAPClient::Parse', + 'VERSION_FROM' => '../../IMAPClient.pm', + 'PREREQ_PM' => {"Parse::RecDescent" => 0 }, + 'PM' => { + 'Parse.pm' => + '$(INST_LIBDIR)/BodyStructure/Parse.pm' + }, +); + diff --git a/Mail-IMAPClient-2.2.9/BodyStructure/Parse/Parse.grammar_new b/Mail-IMAPClient-2.2.9/BodyStructure/Parse/Parse.grammar_new new file mode 100755 index 0000000..e418422 --- /dev/null +++ b/Mail-IMAPClient-2.2.9/BodyStructure/Parse/Parse.grammar_new @@ -0,0 +1,288 @@ +# Directives +# ( none) +# Start-up Actions + +{ + my $subpartCount = 0; + my $partCount = 0; +} + +# +# Atoms +TEXT: /^"TEXT"|^TEXT/i { $return = "TEXT" } +PLAIN: /^"PLAIN"|^PLAIN/i { $return = "PLAIN" } +HTML: /"HTML"|HTML/i { $return = "HTML" } +MESSAGE: /^"MESSAGE"|^MESSAGE/i { $return = "MESSAGE" } +RFC822: /^"RFC822"|^RFC822/i { $return = "RFC822" } +NIL: /^NIL/i { $return = "NIL" } +NUMBER: /^(\d+)/ { $return = $item[1]; $return||defined($return);} + +# Strings: + +SINGLE_QUOTED_STRING: "'" /(?:\\'|[^'])*/ "'" { + + $return = $item{__PATTERN1__} ; + $return||defined($return); +} + +DOUBLE_QUOTED_STRING: '"' /(?:\\"|[^"])*/ '"' { + + $return = $item{__PATTERN1__} ; + $return||defined($return); +} + +QUOTED_STRING: DOUBLE_QUOTED_STRING | SINGLE_QUOTED_STRING { + + $return = $item{DOUBLE_QUOTED_STRING}||$item{SINGLE_QUOTED_STRING} ; + $return||defined($return); +} + +BARESTRING: ...!/^[)('"]/ /^(?!\(|\))(?:\\ |\S)+/ { + $return = $item{__PATTERN1__} ; $return||defined($return); +} + +STRING: QUOTED_STRING | BARESTRING { + $return = $item{QUOTED_STRING}||$item{BARESTRING} ; + $return||defined($return); +} + +OLDSTRING: /^"((?:[^"\\]|\\.)*)"/ | /^([^ \(\)]+)/ + { $item{__PATTERN1__} =~ s/^"(.*)"$/$1/; + $return = $item{__PATTERN1__} || $item{__PATTERN2__} ; + $return||defined($return); + } + +#BARESTRING: /^[^(]+\s+(?=\()/ +# { $return = $item[1] ; $return||defined($return);} + +textlines: NIL | NUMBER { $return = $item[1] || $item[2]; $return||defined($return); } +rfc822message: MESSAGE RFC822 { $return = "MESSAGE RFC822" } +key: STRING { $return = $item{STRING} ; $return||defined($return);} +value: NIL | '(' kvpair(s) ')'| NUMBER | STRING + { $return = $item{NIL} || + $item{NUMBER} || + $item{STRING} || + { map { (%$_) } @{$item{'kvpair(s)'}} } ; + $return||defined($return); + } +kvpair: ...!")" key value + { $return = { $item{key} => $item{value} }; $return||defined($return);} +bodytype: STRING + { $return = $item{STRING} ; $return||defined($return);} +bodysubtype: PLAIN | HTML | NIL | STRING + { $return = $item{PLAIN}||$item{HTML}||$item{NIL}||$item{STRING} ; + $return||defined($return); + } +bodyparms: NIL | '(' kvpair(s) ')' + { + $return = $item{NIL} || + { map { (%$_) } @{$item{'kvpair(s)'}} }; + $return || defined($return); + } +bodydisp: NIL | '(' kvpair(s) ')' + { + $return = $item{NIL} || + { map { (%$_) } @{$item{'kvpair(s)'}} }; + $return || defined($return); + } +bodyid: ...!/[()]/ NIL | STRING + { $return = $item{NIL} || $item{STRING} ; $return||defined($return);} +bodydesc: ...!/[()]/ NIL | STRING + { $return = $item{NIL} || $item{STRING} ; $return||defined($return);} +bodyenc: NIL | STRING | '(' kvpair(s) ')' + { + $return = $item{NIL} || + $item{STRING} || + { map { (%$_) } @{$item{'kvpair(s)'}} }; + $return||defined($return); + } +bodysize: ...!/[()]/ NIL | NUMBER + { $return = $item{NIL} || $item{NUMBER} ;$return||defined($return);} + +bodyMD5: NIL | STRING + { $return = $item{NIL} || $item{STRING} ;$return||defined($return);} +bodylang: NIL | STRING | "(" STRING(s) ")" + { $return = $item{NIL} || $item{'STRING(s)'} ;$return||defined($return);} +personalname: NIL | STRING + { $return = $item{NIL} || $item{STRING} ;$return||defined($return);} +sourceroute: NIL | STRING + { $return = $item{NIL} || $item{STRING} ;$return||defined($return);} +mailboxname: NIL | STRING + { $return = $item{NIL} || $item{STRING} ;$return||defined($return);} +hostname: NIL | STRING + { $return = $item{NIL} || $item{STRING} ;$return||defined($return);} +addressstruct: "(" personalname sourceroute mailboxname hostname ")" + { $return = { + personalname => $item{personalname} , + sourceroute => $item{sourceroute} , + mailboxname => $item{mailboxname} , + hostname => $item{hostname} , + } ; + bless($return, "Mail::IMAPClient::BodyStructure::Address"); + } +subject: NIL | STRING + { + $return = $item{NIL} || $item{STRING} ; + $return||defined($return); + } +inreplyto: NIL | STRING + { $return = $item{NIL} || $item{STRING} ;$return||defined($return);} + +messageid: NIL | STRING + { $return = $item{NIL} || $item{STRING} ;$return||defined($return);} + +date: NIL | STRING + { $return = $item{NIL} || $item{STRING} ;$return||defined($return);} + +cc: NIL | "(" addressstruct(s) ")" + { $return = $item{NIL} || $item{'addressstruct(s)'} } + +bcc: NIL | "(" addressstruct(s) ")" + { $return = $item{NIL} || $item{'addressstruct(s)'} } + +from: NIL | "(" addressstruct(s) ")" + { $return = $item{NIL} || $item{'addressstruct(s)'} } + +replyto: NIL | "(" addressstruct(s) ")" + { $return = $item{NIL} || $item{'addressstruct(s)'} } + +sender: NIL | "(" addressstruct(s) ")" + { $return = $item{NIL} || $item{'addressstruct(s)'} } + +to: NIL | "(" addressstruct(s) ")" + { $return = $item{NIL} || $item{'addressstruct(s)'} } + +envelopestruct: "(" date subject from sender replyto to cc bcc inreplyto messageid ")" + { $return = {}; + foreach my $what (qw/date subject from sender replyto to cc bcc inreplyto messageid/) { + $return->{$what} = $item{$what}; + } + bless $return, "Mail::IMAPClient::BodyStructure::Envelope"; + $return||defined($return); + } + +basicfields: bodysubtype bodyparms bodyid(?) + bodydesc(?) bodyenc(?) + bodysize(?) { + + $return = { + bodysubtype => $item{bodysubtype} , + + bodyparms => $item{bodyparms} , + + bodyid => (ref $item{'bodyid(?)'} ? + $item{'bodyid(?)'}[0] : + $item{'bodyid(?)'} ), + + 'bodydesc' => (ref $item{'bodydesc(?)'} ? + $item{'bodydesc(?)'}[0] : + $item{'bodydesc(?)'} ), + + 'bodyenc' => (ref $item{'bodyenc(?)'} ? + $item{'bodyenc(?)'}[0] : + $item{'bodyenc(?)'} ), + + 'bodysize' => (ref $item{'bodysize(?)'} ? + $item{'bodysize(?)'}[0] : + $item{'bodysize(?)'} ), + }; + $return; +} + +textmessage: TEXT basicfields textlines(?) bodyMD5(?) bodydisp(?) bodylang(?) + { + $return = $item{basicfields}||{}; + $return->{bodytype} = 'TEXT'; + foreach my $what (qw/textlines(?) bodyMD5(?) bodydisp(?) bodylang(?)/) { + my $k = $what; $k =~ s/\(\?\)$//; + ref($item{$what}) and $return->{$k} = $item{$what}[0]; + } + $return||defined($return); + } + +othertypemessage: bodytype basicfields bodyparms(?) bodydisp(?) bodylang(?) + { $return = {}; + foreach my $what (qw/bodytype bodyparms(?) bodydisp(?) bodylang(?)/) { + my $k = $what; $k =~ s/\(\?\)$//; + $return->{$k} = ref($item{$what})? $item{$what}[0] : $item{$what} ; + } + while ( my($k,$v) = each %{$item{basicfields}} ) { $return->{$k} = $v } + $return||defined($return); + } + +messagerfc822message: + rfc822message bodyparms bodyid bodydesc bodyenc bodysize + envelopestruct bodystructure textlines + bodyMD5(?) bodydisp(?) bodylang(?) + { + $return = {}; + foreach my $what (qw/ bodyparms bodyid bodydesc bodyenc bodysize + envelopestruct bodystructure textlines + bodyMD5(?) bodydisp(?) bodylang(?) + / + ) { + my $k = $what; $k =~ s/\(\?\)$//; + $return->{$k} = ref $item{$what} =~ 'ARRAY'? + $item{$what}[0] : $item{$what}; + } + while ( my($k,$v) = each %{$item{bodystructure}[0]} ) { $return->{$k} = $v } + while ( my($k,$v) = each %{$item{basicfields}} ) { $return->{$k} = $v } + $return->{bodytype} = "MESSAGE" ; + $return->{bodysubtype}= "RFC822" ; + $return||defined($return); + } + +subpart: "(" part ")" + { + $return = $item{part} ; + $return||defined($return); + } + + +part: subpart(s) basicfields + bodyparms(?) bodydisp(?) bodylang(?) + + { + $return = bless($item{basicfields}, + "Mail::IMAPClient::BodyStructure"); + $return->{bodytype} = "MULTIPART"; + $return->{bodystructure} = $item{'subpart(s)'}; + foreach my $b (qw/bodyparms(?) bodydisp(?) bodylang(?)/) { + my $k = $b; $k =~ s/\(\?\)$//; + $return->{$k} = ref($item{$b}) ? $item{$b}[0] : $item{$b}; + } + $return||defined($return) ; + } + | textmessage + { + $return = bless $item{textmessage}, "Mail::IMAPClient::BodyStructure"; + $return||defined($return); + } + | messagerfc822message + { + $return = bless $item{messagerfc822message}, "Mail::IMAPClient::BodyStructure"; + $return||defined($return); + } + | othertypemessage + { + $return = bless $item{othertypemessage}, "Mail::IMAPClient::BodyStructure"; + $return||defined($return); + } + +bodystructure: "(" part(s) ")" + { + $return = $item{'part(s)'} ; + $return||defined($return); + } + +start: /.*\(.*BODYSTRUCTURE \(/i part(1) /\).*\)\r?\n?/ + { + #print STDERR "item = ",Data::Dumper->Dump([\%item],['$item']); + $return = $item{'part(1)'}[0]; + $return||defined($return); + } + +envelope: /.*\(.*ENVELOPE/ envelopestruct /.*\)/ { + $return = $item{envelopestruct} ; + $return||defined($return) ; + } diff --git a/Mail-IMAPClient-2.2.9/BodyStructure/Parse/Parse.grammar_old b/Mail-IMAPClient-2.2.9/BodyStructure/Parse/Parse.grammar_old new file mode 100755 index 0000000..4f6c518 --- /dev/null +++ b/Mail-IMAPClient-2.2.9/BodyStructure/Parse/Parse.grammar_old @@ -0,0 +1,281 @@ +# Directives +# ( none) +# Start-up Actions +{ + my $subpartCount = 0; + my $partCount = 0; +} + +# +# Atoms +TEXT: /^"TEXT"|^TEXT/i { $return = "TEXT" } +PLAIN: /^"PLAIN"|^PLAIN/i { $return = "PLAIN" } +HTML: /"HTML"|HTML/i { $return = "HTML" } +MESSAGE: /^"MESSAGE"|^MESSAGE/i { $return = "MESSAGE" } +RFC822: /^"RFC822"|^RFC822/i { $return = "RFC822" } +NIL: /^NIL/i { $return = "NIL" } +NUMBER: /^(\d+)/ { $return = $item[1]; $return||defined($return);} + +# Strings: + +SINGLE_QUOTED_STRING: "'" /(?:\\'|[^'])*/ "'" { + + $return = $item{__PATTERN1__} ; + $return||defined($return); +} + +DOUBLE_QUOTED_STRING: '"' /(?:\\"|[^"])*/ '"' { + + $return = $item{__PATTERN1__} ; + $return||defined($return); +} + +QUOTED_STRING: DOUBLE_QUOTED_STRING | SINGLE_QUOTED_STRING { + + $return = $item{DOUBLE_QUOTED_STRING}||$item{SINGLE_QUOTED_STRING} ; + $return||defined($return); +} + +BARESTRING: ...!/^[)('"]/ /^(?!\(|\))(?:\\ |\S)+/ { + $return = $item{__PATTERN1__} ; $return||defined($return); +} + +STRING: QUOTED_STRING | BARESTRING { + $return = $item{QUOTED_STRING}||$item{BARESTRING} ; + $return||defined($return); +} + +OLDSTRING: /^"((?:[^"\\]|\\.)*)"/ | /^([^ \(\)]+)/ + { $item{__PATTERN1__} =~ s/^"(.*)"$/$1/; + $return = $item{__PATTERN1__} || $item{__PATTERN2__} ; + $return||defined($return); + } + +#BARESTRING: /^[^(]+\s+(?=\()/ +# { $return = $item[1] ; $return||defined($return);} + +textlines: NIL | NUMBER { $return = $item[1] || $item[2]; $return||defined($return); } +rfc822message: MESSAGE RFC822 { $return = "MESSAGE RFC822" } +key: STRING { $return = $item{STRING} ; $return||defined($return);} +value: NIL | '(' kvpair(s) ')'| NUMBER | STRING + { $return = $item{NIL} || + $item{NUMBER} || + $item{STRING} || + { map { (%$_) } @{$item{kvpair}} } ; + $return||defined($return); + } +kvpair: ...!")" key value + { $return = { $item{key} => $item{value} }; $return||defined($return);} +bodytype: STRING + { $return = $item{STRING} ; $return||defined($return);} +bodysubtype: PLAIN | HTML | NIL | STRING + { $return = $item{PLAIN}||$item{HTML}||$item{NIL}||$item{STRING} ; + $return||defined($return); + } +bodyparms: NIL | '(' kvpair(s) ')' + { + $return = $item{NIL} || + { map { (%$_) } @{$item{kvpair}} }; + $return || defined($return); + } +bodydisp: NIL | '(' kvpair(s) ')' + { + $return = $item{NIL} || + { map { (%$_) } @{$item{kvpair}} }; + $return || defined($return); + } +bodyid: ...!/[()]/ NIL | STRING + { $return = $item{NIL} || $item{STRING} ; $return||defined($return);} +bodydesc: ...!/[()]/ NIL | STRING + { $return = $item{NIL} || $item{STRING} ; $return||defined($return);} +bodyenc: NIL | STRING | '(' kvpair(s) ')' + { + $return = $item{NIL} || + $item{STRING} || + { map { (%$_) } @{$item{kvpair}} }; + $return||defined($return); + } +bodysize: ...!/[()]/ NIL | NUMBER + { $return = $item{NIL} || $item{NUMBER} ;$return||defined($return);} + +bodyMD5: NIL | STRING + { $return = $item{NIL} || $item{STRING} ;$return||defined($return);} +bodylang: NIL | STRING | "(" STRING(s) ")" + { $return = $item{NIL} || $item{STRING} ;$return||defined($return);} +personalname: NIL | STRING + { $return = $item{NIL} || $item{STRING} ;$return||defined($return);} +sourceroute: NIL | STRING + { $return = $item{NIL} || $item{STRING} ;$return||defined($return);} +mailboxname: NIL | STRING + { $return = $item{NIL} || $item{STRING} ;$return||defined($return);} +hostname: NIL | STRING + { $return = $item{NIL} || $item{STRING} ;$return||defined($return);} +addressstruct: "(" personalname sourceroute mailboxname hostname ")" + { $return = { + personalname => $item{personalname} , + sourceroute => $item{sourceroute} , + mailboxname => $item{mailboxname} , + hostname => $item{hostname} , + } ; + bless($return, "Mail::IMAPClient::BodyStructure::Address"); + } +subject: NIL | STRING + { + $return = $item{NIL} || $item{STRING} ; + $return||defined($return); + } +inreplyto: NIL | STRING + { $return = $item{NIL} || $item{STRING} ;$return||defined($return);} + +messageid: NIL | STRING + { $return = $item{NIL} || $item{STRING} ;$return||defined($return);} + +date: NIL | STRING + { $return = $item{NIL} || $item{STRING} ;$return||defined($return);} + +cc: NIL | "(" addressstruct(s) ")" + { $return = $item{NIL} || $item{addressstruct} } + +bcc: NIL | "(" addressstruct(s) ")" + { $return = $item{NIL} || $item{addressstruct} } + +from: NIL | "(" addressstruct(s) ")" + { $return = $item{NIL} || $item{addressstruct} } + +replyto: NIL | "(" addressstruct(s) ")" + { $return = $item{NIL} || $item{addressstruct} } + +sender: NIL | "(" addressstruct(s) ")" + { $return = $item{NIL} || $item{addressstruct} } + +to: NIL | "(" addressstruct(s) ")" + { $return = $item{NIL} || $item{addressstruct} } + +envelopestruct: "(" date subject from sender replyto to cc bcc inreplyto messageid ")" + { $return = {}; + foreach my $what (qw/date subject from sender replyto to cc bcc inreplyto messageid/) { + $return->{$what} = $item{$what}; + } + bless $return, "Mail::IMAPClient::BodyStructure::Envelope"; + $return||defined($return); + } + +basicfields: bodysubtype bodyparms bodyid(?) + bodydesc(?) bodyenc(?) + bodysize(?) { + + $return = { + bodysubtype => $item{bodysubtype} , + + bodyparms => $item{bodyparms} , + + bodyid => (ref $item{bodyid} ? + $item{bodyid}[0] : + $item{bodyid} ), + + bodydesc => (ref $item{bodydesc} ? + $item{bodydesc}[0] : + $item{bodydesc} ), + + bodyenc => (ref $item{bodyenc} ? + $item{bodyenc}[0] : + $item{bodyenc} ), + + bodysize => (ref $item{bodysize} ? + $item{bodysize}[0] : + $item{bodysize} ), + }; + $return; +} + +textmessage: TEXT basicfields textlines(?) bodyMD5(?) bodydisp(?) bodylang(?) + { + $return = $item{basicfields}||{}; + $return->{bodytype} = 'TEXT'; + foreach my $what (qw/textlines bodyMD5 bodydisp bodylang/) { + ref($item{$what}) and $return->{$what} = $item{$what}[0]; + } + $return||defined($return); + } + +othertypemessage: bodytype basicfields bodyparms(?) bodydisp(?) bodylang(?) + { $return = {}; + foreach my $what (qw/bodytype bodyparms bodydisp bodylang/) { + $return->{$what} = ref($item{$what})? $item{$what}[0] : $item{$what} ; + } + while ( my($k,$v) = each %{$item{basicfields}} ) { $return->{$k} = $v } + $return||defined($return); + } + +messagerfc822message: + rfc822message bodyparms bodyid bodydesc bodyenc bodysize + envelopestruct bodystructure textlines + bodyMD5(?) bodydisp(?) bodylang(?) + { + $return = {}; + foreach my $what (qw/ bodyparms bodyid bodydesc bodyenc bodysize + envelopestruct bodystructure textlines + bodyMD5 bodydisp bodylang + / + ) { + $return->{$what} = ref $item{$what} =~ 'ARRAY'? + $item{$what}[0] : $item{$what}; + } + while ( my($k,$v) = each %{$item{bodystructure}[0]} ) { $return->{$k} = $v } + while ( my($k,$v) = each %{$item{basicfields}} ) { $return->{$k} = $v } + $return->{bodytype} = "MESSAGE" ; + $return->{bodysubtype}= "RFC822" ; + $return||defined($return); + } + +subpart: "(" part ")" + { + $return = $item{part} ; + $return||defined($return); + } + + +part: subpart(s) basicfields + bodyparms(?) bodydisp(?) bodylang(?) + + { + $return = bless($item{basicfields}, "Mail::IMAPClient::BodyStructure"); + $return->{bodytype} = "MULTIPART"; + $return->{bodystructure} = $item{subpart}; + foreach my $b (qw/bodyparms bodydisp bodylang/) { + $return->{$b} = ref($item{$b}) ? $item{$b}[0] : $item{$b}; + } + $return||defined($return) ; + } + | textmessage + { + $return = bless $item{textmessage}, "Mail::IMAPClient::BodyStructure"; + $return||defined($return); + } + | messagerfc822message + { + $return = bless $item{messagerfc822message}, "Mail::IMAPClient::BodyStructure"; + $return||defined($return); + } + | othertypemessage + { + $return = bless $item{othertypemessage}, "Mail::IMAPClient::BodyStructure"; + $return||defined($return); + } + +bodystructure: "(" part(s) ")" + { + $return = $item{part} ; + $return||defined($return); + } + +start: /.*\(.*BODYSTRUCTURE \(/i part(1) /\).*\)\r?\n?/ + { + $return = $item{part}[0] ; + $return||defined($return); + } + +envelope: /.*\(.*ENVELOPE/ envelopestruct /.*\)/ { + $return = $item{envelopestruct} ; + $return||defined($return) ; + } diff --git a/Mail-IMAPClient-2.2.9/BodyStructure/Parse/Parse.pod b/Mail-IMAPClient-2.2.9/BodyStructure/Parse/Parse.pod new file mode 100755 index 0000000..16813ef --- /dev/null +++ b/Mail-IMAPClient-2.2.9/BodyStructure/Parse/Parse.pod @@ -0,0 +1,21 @@ +package Mail::IMAPClient::BodyStructure::Parse; +$Mail::IMAPClient::BodyStructure::Parse::VERSION = "0.0.1"; +$Mail::IMAPClient::BodyStructure::Parse::VERSION = "0.0.1"; + +=head1 NAME + +Mail::IMAPClient::BodyStructure::Parse -- used internally by Mail::IMAPClient::BodyStructure + +=head1 DESCRIPTION + +This module is used internally by L and is +generated using L. It is not meant to be used directly by +other scripts nor is there much point in debugging it. + +=head1 SYNOPSIS + +This module is used internally by L and is not meant to +be used or called directly from applications. So don't do that. + +=cut + diff --git a/Mail-IMAPClient-2.2.9/BodyStructure/Parse/t/parse.t b/Mail-IMAPClient-2.2.9/BodyStructure/Parse/t/parse.t new file mode 100755 index 0000000..33042b9 --- /dev/null +++ b/Mail-IMAPClient-2.2.9/BodyStructure/Parse/t/parse.t @@ -0,0 +1,39 @@ +# Before `make install' is performed this script should be runnable with +# `make test'. After `make install' it should work as `perl test.pl' +# $Id: parse.t,v 1.2 2002/08/30 20:48:34 dkernen Exp $ +######################### We start with some black magic to print on failure. + +# Change 1..1 below to 1..last_test_to_print . + +use Mail::IMAPClient::BodyStructure::Parse; + +BEGIN { + print "1..1\n"; + $main::loaded = 1; + $| = 1; + print "ok 1\n"; +} +END {print "not ok 1\n" unless $main::loaded;} + + +# History: +# $Log: parse.t,v $ +# Revision 1.2 2002/08/30 20:48:34 dkernen +# +# # +# Modified Files: +# Changes IMAPClient.pm MANIFEST Makefile Makefile.PL README +# Todo test.txt +# BodyStructure/Parse/Makefile +# BodyStructure/Parse/Parse.pm +# BodyStructure/Parse/Parse.pod +# BodyStructure/Parse/t/parse.t +# for version 2.2.1 +# # +# +# Revision 1.1 2002/08/23 14:34:29 dkernen +# +# Modified Files: Changes IMAPClient.pm Makefile Makefile.PL test.txt for version 2.2.0 +# Added Files: Makefile Makefile.PL Parse.grammar Parse.pm Parse.pod version 2.2.0 +# Added Files: parse.t for version 2.2.0 +# diff --git a/Mail-IMAPClient-2.2.9/BodyStructure/t/bodystructure.t b/Mail-IMAPClient-2.2.9/BodyStructure/t/bodystructure.t new file mode 100755 index 0000000..ed57256 --- /dev/null +++ b/Mail-IMAPClient-2.2.9/BodyStructure/t/bodystructure.t @@ -0,0 +1,55 @@ +# Before `make install' is performed this script should be runnable with +# `make test'. After `make install' it should work as `perl test.pl' +# $Id: bodystructure.t,v 1.1 2002/08/23 14:34:40 dkernen Exp $ +######################### We start with some black magic to print on failure. + +# Change 1..1 below to 1..last_test_to_print . + +use Mail::IMAPClient::BodyStructure; +use warnings; + +BEGIN { + print "1..8\n"; + $main::loaded = 1; + $| = 1; + print "ok 1\n"; +} +my $bs=<<"END_OF_BS"; +(BODYSTRUCTURE ("TEXT" "PLAIN" ("CHARSET" "us-ascii") NIL NIL "7BIT" 511 20 NIL NIL NIL))^M +END_OF_BS +my $bsobj = Mail::IMAPClient::BodyStructure->new($bs) ; +if ($bsobj) { print "ok 2\n" } else { + print "not ok 2\n"; + exit; +} +if ($bsobj->bodytype eq 'TEXT') { print "ok 3\n" } +else {print "not ok 3 (expected 'TEXT' ; got '" . $bsobj->bodytype . "')\n"} +if ($bsobj->bodysubtype eq 'PLAIN') { print "ok 4\n" } +else {print "not ok 4 (expected 'PLAIN' ; got '" . $bsobj->bodytype . "')\n"} + +my $bs2 = <<'END_OF_BS2'; +(BODYSTRUCTURE (("TEXT" "PLAIN" ("CHARSET" "us-ascii") NIL NIL "7BIT" 2 1 NIL NIL NIL)("MESSAGE" "RFC822" NIL NIL NIL "7BIT" 3930 ("Tue, 16 Jul 2002 15:29:17 -0400" "Re: [Fwd: Here is the the list of uids]" (("Michael Etcetera" NIL "michael.etcetera" "generic.com")) (("Michael Etcetera" NIL "michael.etcetera" "generic.com")) (("Michael Etcetera" NIL "michael.etcetera" "generic.com")) (("Michael Etcetera" NIL "michael.etcetera" "generic.com")) (("David J Kavid" NIL "david.kavid" "generic.com")) NIL NIL "<72f9a217.a21772f9@generic.com>") (("TEXT" "PLAIN" ("CHARSET" "us-ascii") NIL NIL "7BIT" 369 11 NIL NIL NIL)("MESSAGE" "RFC822" NIL NIL NIL "7BIT" 2599 ("Tue, 9 Jul 2002 13:42:04 -0400" "Here is the the list of uids" (("Nicholas Kringle" NIL "nicholas.kringle" "generic.com")) (("Nicholas Kringle" NIL "nicholas.kringle" "generic.com")) (("Nicholas Kringle" NIL "nicholas.kringle" "generic.com")) (("Michael Etcetera" NIL "michael.etcetera" "generic.com")) (("Richard W Continued" NIL "richard.continued" "generic.com")) NIL NIL "<015401c2276f$f09b7c10$59cab08c@one.two.generic.com>") ((("TEXT" "PLAIN" ("CHARSET" "iso-8859-1") NIL NIL "QUOTED-PRINTABLE" 256 10 NIL NIL NIL)("TEXT" "HTML" ("CHARSET" "iso-8859-1") NIL NIL "QUOTED-PRINTABLE" 791 22 NIL NIL NIL) "ALTERNATIVE" ("BOUNDARY" "----=_NextPart_001_0151_01C2274E.6969D0F0") NIL NIL) "MIXED" ("BOUNDARY" "----=_NextPart_000_0150_01C2274E.6969D0F0") NIL NIL) 75 NIL NIL NIL) "MIXED" ("BOUNDARY" "--1f34eac2082b02") NIL ("EN")) 118 NIL NIL NIL) "MIXED" ("BOUNDARY" "------------F600BD8FDDD648ABA72A09E0") NIL NIL)) +END_OF_BS2 + +$bsobj = Mail::IMAPClient::BodyStructure->new($bs2) ; +if ($bsobj) { print "ok 5\n" } else {print "not ok 5\n"} +if ($bsobj->bodytype eq 'MULTIPART') { print "ok 6\n" } +else {print "not ok 6 (expected 'MULTIPART' ; got '" . $bsobj->bodytype . "')\n"} +if ($bsobj->bodysubtype eq 'MIXED') { print "ok 7\n" } +else {print "not ok 7 (expected 'MIXED' ; got '" . $bsobj->bodytype . "')\n"} +if (join("#",$bsobj->parts) eq "1#2#2.HEAD#2.1#2.2#2.2.HEAD#2.2.1#2.2.1.1#2.2.1.2") { +print "ok 8\n"; +} else {print "not ok 8\n"} + +END {print "not ok 1\n" unless $main::loaded;} + + +# History: +# $Log: bodystructure.t,v $ +# Revision 1.1 2002/08/23 14:34:40 dkernen +# +# Modified Files: Changes IMAPClient.pm Makefile Makefile.PL test.txt for version 2.2.0 +# Added Files: Makefile Makefile.PL Parse.grammar Parse.pm Parse.pod version 2.2.0 +# Added Files: parse.t for version 2.2.0 +# Added Files: bodystructure.t for 2.2.0 +# diff --git a/Mail-IMAPClient-2.2.9/COPYRIGHT b/Mail-IMAPClient-2.2.9/COPYRIGHT new file mode 100644 index 0000000..d5cdcf8 --- /dev/null +++ b/Mail-IMAPClient-2.2.9/COPYRIGHT @@ -0,0 +1,21 @@ +COPYRIGHT + + Copyright 1999, 2000, 2001, 2002 , 2003 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 version 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. All your +base are belong to us. + diff --git a/Mail-IMAPClient-3.05/Changes b/Mail-IMAPClient-2.2.9/Changes similarity index 79% rename from Mail-IMAPClient-3.05/Changes rename to Mail-IMAPClient-2.2.9/Changes index 5a89171..359084e 100644 --- a/Mail-IMAPClient-3.05/Changes +++ b/Mail-IMAPClient-2.2.9/Changes @@ -1,366 +1,45 @@ - -== Revision History for Mail::IMAPClient -All changes from 2.99_01 upward are made by Mark Overmeer. The changes -before that are applied by David Kernen - -version 3.05: Wed Feb 20 08:59:37 CET 2008 - - Fixes: - - - match ENVELOPE and BODYSTRUCTURE more strict in the - grammar, to avoid confusion. [Zach Levow] - - - get_envelope and get_bodystructure failed for servers which - did not return the whole answer in one piece. [Zach Levow] - - - do not produce parser errors when get_envelope does not - return an envelope. [Zach Levow] - - - PLAIN login response possibly solely a '+' [Zach] and [Nick] - -version 3.04: Fri Jan 25 09:25:51 CET 2008 - - Fixes: - - - read_header fix for UID on Windows Server 2003. - rt.cpan.org#32398 [Michiel Stelman] - - Improvements: - - - doc update on authentication, by [Thomas Jarosch] - -version 3.03: Wed Jan 9 22:11:36 CET 2008 - - Fixes: - - - LIST (f.i. used by folders()) did not return anything when the - passed argument had a trailing separator. [Gunther Heintze] - - - Rfc2060_datetime() must include a zone. - rt.cpan.org#31971 [David Golden] - - - folders() uses LIST, and then calls a STATUS on each of the - names found. This is superfluous, and will cause problems when - the STATUS fails... for instance because of ACL limitations - on the sub-folder. - rt.cpan.org#31962 [Thomas Jarosch] - - - fixed a zillion of problems in the BodyStructure parser. The - original author did not understand parsing, nor Perl. - - - part numbering wrong when nested messages contained multiparts - - Improvements: - - - implementation of DIGEST-MD5 authentication [Thomas Jarosch] - - - removed call for status() in Massage(), which hopefully speeds-up - things without destroying anything. It removed a possible deep - recursion, which no-one reported (so should be ok to remove it) - - - simplified folders() algorithm. - - - merged folder commands, like subscribe into one. - - - added unsubscribe() - rt.cpan.org#31268 [G Miller] - - - lazy-load Digest::HMAC_MD5 - -version 3.02: Wed Dec 5 21:33:17 CET 2007 - - Fixes: - - - Another attempt to get get FETCH UID right. Patch by [David Golden] - -version 3.01: Wed Dec 5 09:55:43 CET 2007 - - Changes: - - - removed version number from ::BodyStructure - - Fixes: - - - quote password at login. - rt.cpan.org#31035 [Andy Harriston] - - - empty return of flags command should be empty list, not undef. - rt.cpan.org#31195 [David Golden] - - - UID command does not work with folder management commands - rt.cpan.org#31182 [Robbert Norris] - - - _read_line simplifications avoids timeouts. - rt.cpan.org#31221 [Robbert Norris] - - - FETCH did not detect the UID of a message anymore. - [David Golden] - - Improvements: - - - proxyauth for SUN/iPlanet/NetScape IMAP servers. - patch by rt.cpan.org#31152 [Robbert Norris] - - - use grep in stead of map in one occasion in MessageSet.pm - [Yves Orton] - -version 3.00: Wed Nov 28 09:56:54 CET 2007 - - Fixes: - - - "${peek}[]" should be "$peek\[]" for perl 5.6.1 - rt.cpan.org#30900 [Gerald Richter] - -version 2.99_07: Wed Nov 14 09:54:46 CET 2007 - - Fixes: - - - forgot to update the translate grammar. - -version 2.99_06: Mon Nov 12 23:21:58 CET 2007 - - Fixes: - - - body structure can have any number of optional parameters. - Patch by [Gerald Richter]. - - - get_bodystructure did not take the output correctly [Gerald Richter] - - - parser of body-structure did not handle optional body parameters - Patch by [Gerald Richter], rt.cpan.org#4479 [Geoffrey D. Bennet] - -version 2.99_05: Mon Nov 12 00:17:42 CET 2007 - - Fixes: - - - pod error in MessageSet.pm - - - folders() without argument failed. [Gerald Richter] - - Improvements: - - - better use of format syntax in date formatting. - - - Rfc2060_datetime also contains the time. - - - append_file() now has options to pass flags and time of file - in one go. [Thomas Jarosch] - -version 2.99_04: Sat Nov 10 20:55:18 CET 2007 - - Changes: - - - Simplified initiation of IMAP object with own Socket with a new - option: RawSocket [Flavio Poletti] - - Fixes: - - - fixed read_line [Flavio Poletti] - - - fixed test-run in t/basic.t [Flavio Poletti] - -version 2.99_03: Thu Nov 1 12:36:44 CET 2007 - - Fixes: - - - Remove note about optional Parse::RecDescent by Makefile.PL; - it is not optional anymore - - Improvements: - - - When syswrite() returns 0, that might be caused by an error - as well. Take the timeout/maxtemperrors track. - rt.cpan.org#4701 [C Meyer] - - - add NTLM support for logging-in, cleanly intergrated. Requires - the user to install Authen::NTLM. - -version 2.99_02: Fri Oct 26 11:47:35 CEST 2007 - - The whole Mail::IMAPClient was rewritten, hopefully without - breaking the interface. Nearly no line was untouched. - - The following things happened: - - use warnings, use strict everywhere - - removed many lines which were commented out, over the years - - $self->_debug if $self->Debug checked debug flag twice - - $self->LogError calls where quite inconsequent wrt $@ and carp - - consequent layout, changed sporadic tabs in blanks - - consequent calling convensions - - \0x0d\0x0a is always \r\n - - zillions of minor syntactical improvements - - a few major algorithmic rewrites to simplify the code, still - many oppotunities for improvements. - - expanded "smart" accessor methods, search abbreviations, - and autoloaded methods into separate subs. In total much - shorter, and certainly better understandable! - - fixed many potential bugs. - - labeled some weird things with #???? - Over 1000 lines (30%!) and 25kB smaller in size - Needs to be tested!!!! Volunteers? - - Fixes: - - - Exchange 2007 only works with new parameter: IgnoreSizeErrors - rt.cpan.org#28933 [Dregan], #5297 [Kevin P. Fleming] - - - Passed socket did not get selected. - debian bug #401144, rt.cpan.org# [Alexander Zanger], - #8480 [Karl Gaissmaier], #8481 [Karl Gaissmaier], - #7298 [Herbert Engelmann] - http://bugs.debian.org/cgi-bin/bugreport.cgi?bug=401144 - - - Seperator not correctly extracted from list command. - rt.cpan.org#9236 [Eugene Koontz], #4662 [Rasjid] - - - migrate() Massage'd foldername twice - rt.cpan.org#20703 [Peter J. Holzer] - - - migrate() could loop because error in regexp. - rt.cpan.org#20703 [Peter J. Holzer] - - - migrate() append_string result not tested. - rt.cpan.org#8577 [guest] - - - Failing fetch() returned undef, not empty list. - rt.cpan.org#18361 [Robert Terzi] - - - Fix "use of uninitialised" warning when expunge is called - rt.cpan.org#15002 [Matt Jackson] - - - Fix count subfolders in is_parent, regexp did not take care - of regex special characters in foldername and seperator. - rt.cpan.org#12883 [Mike Porter] - - - In fetch_hash(), the capturing of UID was too complicated - (and simply wrong) - rt.cpan.org#9341 [Gilles Lamiral] - - - overload in MessageSet treated the 3rd arg (reverse) as - message-set. - - - do not send the password on a different line as the username - in LOGIN. Suggested by many people, amongst them - rt.cpan.org#4449 [Lars Uffmann] - - - select() with $timeout==0 (no timeout) returns immediately. - Should be 'undef' as 4th select parameter. - rt.cpan.org#5962 [Colin Robertson] and [Jules Agee] - - - examine() remembers Massage()d folder name, not the unescaped - version. rt.cpan.org#7859 [guest] - - Improvements: - - - PREAUTH support by rt.cpan.org#17693 [Danny Siu] - - - Option "SupportedFlags", useful when the source supports - different flags than the peer in migrate(). - Requested by rt.cpan.org#12961 [Don Christensen] - - - Fast_io did not clear $@ on unimportant errors. - rt.cpan.org#9835 [guest] and #11220 [Brian Helterline] - - - Digest::HMAC_MD5 and MIME::Base64 are now prerequisits. - rt.cpan.org#6391 [David Greaves] - - - PLAIN (SASL) authentication added, option Proxy - rt.cpan.org#5706 [Carl Provencher] - - - removed Bodystructure.grammar and IMAPClient.cleanup from dist. - - - reworked Bodystructure and MessageSet as well. - - - EnableServerResponseInLiteral now autodetect (hence ignored) - -version 2.99_01: - - After 4 years of silence, Mark Overmeer took maintenance. David - Kernen could not be reached. Please let him contact the new - maintainer. - - A considerable clean-up took place, fixing bug and adapting the - distribution to current best practices. - - - use "prompt" in Makefile.PL, to please CPAN-testers - - - removed old Parse::RecDescent grammars - - - include Artistic and Copying (GPL) into COPYRIGHT file - - - remove INSTALL_perl5.80 - - - removed all the seperate Makefile.PLs and test directories - - - removed the hard-copy of all involved RFCs: there are better - sources for those. - - - converted tests to use "Test::More" - - - Authmechanism eq 'LOGIN' understood. - - - test for CRAM-MD5 removed, because conflicts with test params - from Makefile.PL - - - test for fast-io removed, it is Perl core functionality - - - require IO::Socket::INET 1.26 to avoid Port number work-around. - - - Parse::RecDescent is required, and the grammars are pre-parsed - in the distribution. This makes the whole installation process - a lot easier. - - - Update Todo, and many other texts. - - - added pod tester in t/pod.t - - - cleaned-up the rt.cpan.org bug-list from spam. The next - release will contain fixes for the real reports. - +Revision History for Perl extension Mail::IMAPClient. Changes in version 2.2.9 ------------------------ -Fixed problem in migrate that caused problems in versions of perl earlier -than 5.6. Thanks go to Steven Roberts for reporting the problem and -identifying its cause. +Fixed problem in migrate that caused problems in versions of perl earlier than +5.6. Thanks go to Steven Roberts for reporting the problem and identifying its +cause. -Fixed problem in the make process that caused tests for BodyStructure -subclass to fail if the grammer had been compiled under a different -version of Parse::RecDescent. This problem was detected by the dedicated -people at testers@cpan.org. +Fixed problem in the make process that caused tests for BodyStructure subclass +to fail if the grammer had been compiled under a different version of +Parse::RecDescent. This problem was detected by the dedicated people at +testers@cpan.org. Fixed a compatibility problem using Parse::RecDescent version 1.94. -This caused BodyStructure and Thread to fail for 5.8.x users. A number of -people reported this bug to CPAN but it took me a while to realize what -was going on. Really it took me a while to realize my Parse::RecDescent -was out of date. ;-) Now this module is delivered with two versions of -each of the affected grammars and Makefile.PL determines which version -to use. Upgrading to Parse::RecDescent 1.94 will require you to re-run -Makefile.PL and reinstall Mail::IMAPClient. +This caused BodyStructure and Thread to fail for 5.8.x users. A number +of people reported this bug to CPAN but it took me a while to realize what +was going on. Really it took me a while to realize my Parse::RecDescent was +out of date. ;-) Now this module is delivered with two versions of each of +the affected grammars and Makefile.PL determines which version to use. +Upgrading to Parse::RecDescent 1.94 will require you to re-run Makefile.PL +and reinstall Mail::IMAPClient. Changes in version 2.2.8 ------------------------ -Change the login method so that it always send password as a literal -to get around problem 2544 reported by Phil Tracy which caused -passwords containing asterisks to fail on some systems (but not any of -mine...). Good catch, Phil. +Change the login method so that it always send password as a literal to get around +problem 2544 reported by Phil Tracy which caused passwords containing asterisks to +fail on some systems (but not any of mine...). Good catch, Phil. -Added a new example that demonstrates the use of imtest (a utility -that comes with Cyrus IMAP) and Mail::IMAPClient together. The -example uses imtest to do secure authentication and then "passes" the -connection over to Mail::IMAPClient (but imtest is still brokering -the encryption/decryption). This example comes from an idea of -Tara L. Andrews', whose brainstorm it was to use imtest to broker -secure connections. (But I still want to get encryption working with -Mail::IMAPClient some day!) +Added a new example that demonstrates the use of imtest (a utility that comes with +Cyrus IMAP) and Mail::IMAPClient together. The example uses imtest to do secure +authentication and then "passes" the connection over to Mail::IMAPClient (but +imtest is still brokering the encryption/decryption). This example comes from +an idea of Tara L. Andrews', whose brainstorm it was to use imtest to broker secure +connections. (But I still want to get encryption working with Mail::IMAPClient some +day!) -Fixed an error in which a "+" was used as a conncatenation error instead -of a ".". Thanks to Andrew Bramble for reporting this, even though he -mistakenly identified it as a "typo". It is not a typo; a plus sign is the -correct concatenation operator, as any decent Java book will tell you ;-) +Fixed an error in which a "+" was used as a conncatenation error instead of a ".". +Thanks to Andrew Bramble for reporting this, even though he mistakenly identified +it as a "typo". It is not a typo; a plus sign is the correct concatenation operator, +as any decent Java book will tell you ;-) -Fixed an error in the login method when the password contains a special -character (such as an asterisk.) Thanks to Phil Tracey for reporting -this bug. +Fixed an error in the login method when the password contains a special character +(such as an asterisk.) Thanks to Phil Tracey for reporting this bug. Fixed some bugs in _send_line (the "O" side of the I/O engine) that were reported by Danny Smith. @@ -582,109 +261,94 @@ module will allow you to use NTML authentication with Mail::IMAPClient connectio Also changed the authenticate method so that it will work with Authen::NTML without the update mentioned in NTLM::Authen's README. -Added a second example on using the new migrate method, -migrate_mail2.pl. This example demonstrates more advanced techniques -then the first, such as using the separator method to massage folder -names and stuff like that. +Added a second example on using the new migrate method, migrate_mail2.pl. This example +demonstrates more advanced techniques then the first, such as using the separator method +to massage folder names and stuff like that. -Added support for the IMAP THREAD extension. Added -Mail::IMAPClient::Thread.pm to support this. (This pm file is generated -during make from Thread/Thread.grammar.) This new function should be -considered experimental. Note also that this extension has nothing to do -with threaded perl or anything like that. This is still on the TODO list. +Added support for the IMAP THREAD extension. Added Mail::IMAPClient::Thread.pm to support +this. (This pm file is generated during make from Thread/Thread.grammar.) This new +function should be considered experimental. Note also that this extension has nothing +to do with threaded perl or anything like that. This is still on the TODO list. -Updated the search, sort, and thread methods to set $@ to "" before -attempting their respective operations so that text in $@ won't be left -over from some other error and therefore always indicative of an error -in search, sort, or thread, respectively. +Updated the search, sort, and thread methods to set $@ to "" before attempting their +respective operations so that text in $@ won't be left over from some other error and +therefore always indicative of an error in search, sort, or thread, respectively. -Made many many tweaks to the documentation, including adding more examples -(albeit simple ones) and fixing some errors. +Made many many tweaks to the documentation, including adding more examples (albeit +simple ones) and fixing some errors. Changes in version 2.2.0 ------------------------ -Fixed some tests so that they are less likely to give false negatives. For -example, test 41 would fail if the test account happened to have an -empty inbox. +Fixed some tests so that they are less likely to give false negatives. For example, test +41 would fail if the test account happened to have an empty inbox. -Made improvements to Mail::IMAPClient::BodyStructure and renamed -Mail::IMAPClient::Parse to Mail::IMAPClient::BodyStructure::Parse. (This -should be transparent to apps since the ...Parse helper module is -used by BodyStructure.pm only.) I also resumed my earlier practice of -using ...Parse.pm from within BodyStructure.pm to avoid the overhead of -compiling the grammar every time you use BodyStructure.pm. (Parse.pm is -just the output from saving the compiled Parse::RecDescent grammar.) In a -related change, I've moved the grammar into its own file (Parse.grammar) -and taught Makefile.PL how to write a Makefile that converts the .grammar -file into a .pm file. This work includes a number of fixes to how a body -structure gets parsed and the parts list returned by the parts method, -among other things. I was able to successfully parse every bodystructure -I could get my hands on, and that's a lot. +Made improvements to Mail::IMAPClient::BodyStructure and renamed Mail::IMAPClient::Parse +to Mail::IMAPClient::BodyStructure::Parse. (This should be transparent to apps since the +...Parse helper module is used by BodyStructure.pm only.) I also resumed my earlier practice +of using ...Parse.pm from within BodyStructure.pm to avoid the overhead of compiling the +grammar every time you use BodyStructure.pm. (Parse.pm is just the output from saving +the compiled Parse::RecDescent grammar.) In a related change, I've moved the grammar into +its own file (Parse.grammar) and taught Makefile.PL how to write a Makefile that converts +the .grammar file into a .pm file. This work includes a number of fixes to how a body structure +gets parsed and the parts list returned by the parts method, among other things. I was able +to successfully parse every bodystructure I could get my hands on, and that's a lot. -Also added a bunch of new methods to Mail::IMAPClient::BodyStructure -and its child classes. The child classes don't even have files of their -own yet; they still live with their parent class! Notable amoung these -changes is support for the FETCH ENVELOPE IMAP command (which was easy -to build in once the BODYSTRUCTURE stuff was working) and some helper -modules to get at the envelope info (as well as envelope information -for MESSAGE/RFC822 attachments from the BODYSTRUCTURE output). Have a -look at the documentation for Mail::IMAPClient::BodyStructure for more -information. +Also added a bunch of new methods to Mail::IMAPClient::BodyStructure and its child classes. +The child classes don't even have files of their own yet; they still live with +their parent class! Notable amoung these changes is support for the FETCH ENVELOPE IMAP +command (which was easy to build in once the BODYSTRUCTURE stuff was working) and some +helper modules to get at the envelope info (as well as envelope information for +MESSAGE/RFC822 attachments from the BODYSTRUCTURE output). Have a look at the +documentation for Mail::IMAPClient::BodyStructure for more information. -Fixed a bug in the folders method regarding quotes and folders with -spaces in the names. The bug must have been around for a while but -rarely manifested itself because of the way methods that take folder -name arguments always try to get the quoting right anyway but it was -still there. Noticing it was the hard part (none of you guys reported -it to me!). +Fixed a bug in the folders method regarding quotes and folders with spaces in the names. The +bug must have been around for a while but rarely manifested itself because of the way +methods that take folder name arguments always try to get the quoting right anyway but +it was still there. Noticing it was the hard part (none of you guys reported it to me!). -Fixed a bug reported by Jeremy Hinton regarding how the search method -handles dates. It was screwing it all up but it should be much better now. +Fixed a bug reported by Jeremy Hinton regarding how the search method handles dates. It was +screwing it all up but it should be much better now. -Added the get_envelope method which is like the get_bodystructure method -except for in ways in which it's different. +Added the get_envelope method which is like the get_bodystructure method except for in ways +in which it's different. -Added the messages method (a suggestion from Danny Carroll), which is -functionally equivalent to $imap->search("ALL") but easier to type. +Added the messages method (a suggestion from Danny Carroll), which is functionally +equivalent to $imap->search("ALL") but easier to type. -Added new arguments to the bodypart_string method so that you can get -just a part of a part (or a part of a subpart for that matter...) I did -this so I could verify BodyStructure's parts method by fetching the first -few bytes of a part (just to prove that the part has a valid part number). +Added new arguments to the bodypart_string method so that you can get just a part of a part +(or a part of a subpart for that matter...) I did this so I could verify BodyStructure's +parts method by fetching the first few bytes of a part (just to prove that the part has a +valid part number). -Added new tests to test the migrate function and to do more thorough -testing of the BodyStructure stuff. Also added a test to make sure that -searches that come up empty handed return an undef instead of an empty -array (reference), regardless of context. Which reminds me... +Added new tests to test the migrate function and to do more thorough testing of the +BodyStructure stuff. Also added a test to make sure that searches that come up empty handed +return an undef instead of an empty array (reference), regardless of context. Which reminds +me... -Fixed a bug in which searches that don't find any hits would return a -reference to an empty array instead of undef when called in a scalar -context. This bug sounds awfully familiar, which is why I added the test -mentioned above... +Fixed a bug in which searches that don't find any hits would return a reference to an empty +array instead of undef when called in a scalar context. This bug sounds awfully familiar, +which is why I added the test mentioned above... Changes in version 2.1.5 ------------------------ -Fixed the migrate method so now it not only works, but also works -as originally planned (i.e. without requiring source messages to -be read entirely into memory). If the message is smaller than -the value in the Buffer parameter (default is 4096) then a normal -$imap2->append($folder,$imap1->message_string) is done. However, if -the message is over the buffer size then it is retrieved and written a -bufferful at a time until the whole message has been read and sent. (The -receiving server still expects the entire message at once, but it -will have to wait because the message is being read from the source in -smaller chunks and then written to the destination a chunk at a time.) -This needs extensive testing before I'd be willing to trust it (or at -least extensive logging so you know when something has gone terribly -wrong) and I consider this method to be in BETA in this release. (Numerous -people wrote complaining that migrate didn't work, and some even included -patches to make it work, but the real bug in the last release wasn't -that migrate was broken but that I had inadvertently included the pod for -the method which I knew perfectly well was not ready to be released. My -apologies to anyone who was affected by this.) The migrate method does -seem to work okay on iPlanet (i.e. Netscape) Messenger Server 4.x. Please -let me know if you have any issues on this or any other platform. +Fixed the migrate method so now it not only works, but also works as originally +planned (i.e. without requiring source messages to be read entirely into memory). +If the message is smaller than the value in the Buffer parameter (default is 4096) then +a normal $imap2->append($folder,$imap1->message_string) is done. However, if the message +is over the buffer size then it is retrieved and written a bufferful at a time until the +whole message has been read and sent. (The receiving server still expects the entire +message at once, but it will have to wait because the message is being read from the +source in smaller chunks and then written to the destination a chunk at a time.) +This needs extensive testing before I'd be willing to trust it (or at least extensive +logging so you know when something has gone terribly wrong) and I consider this method +to be in BETA in this release. (Numerous people wrote complaining that migrate didn't +work, and some even included patches to make it work, but the real bug in the last +release wasn't that migrate was broken but that I had inadvertently included the pod +for the method which I knew perfectly well was not ready to be released. My apologies +to anyone who was affected by this.) The migrate method does seem to work okay on +iPlanet (i.e. Netscape) Messenger Server 4.x. Please let me know if you have any +issues on this or any other platform. Added a new example, migrate_mbox.pl, which will demonstrate the migrate method. diff --git a/Mail-IMAPClient-3.10/COPYRIGHT b/Mail-IMAPClient-2.2.9/Copying similarity index 64% rename from Mail-IMAPClient-3.10/COPYRIGHT rename to Mail-IMAPClient-2.2.9/Copying index ebc36eb..43cd72c 100644 --- a/Mail-IMAPClient-3.10/COPYRIGHT +++ b/Mail-IMAPClient-2.2.9/Copying @@ -1,156 +1,3 @@ -COPYRIGHT - - Copyright 1999, 2000, 2001, 2002 , 2003 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 version 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. All your -base are belong to us. - -============= - - The "Artistic License" - - Preamble - -The intent of this document is to state the conditions under which a -Package may be copied, such that the Copyright Holder maintains some -semblance of artistic control over the development of the package, -while giving the users of the package the right to use and distribute -the Package in a more-or-less customary fashion, plus the right to make -reasonable modifications. - -Definitions: - - "Package" refers to the collection of files distributed by the - Copyright Holder, and derivatives of that collection of files - created through textual modification. - - "Standard Version" refers to such a Package if it has not been - modified, or has been modified in accordance with the wishes - of the Copyright Holder as specified below. - - "Copyright Holder" is whoever is named in the copyright or - copyrights for the package. - - "You" is you, if you're thinking about copying or distributing - this Package. - - "Reasonable copying fee" is whatever you can justify on the - basis of media cost, duplication charges, time of people involved, - and so on. (You will not be required to justify it to the - Copyright Holder, but only to the computing community at large - as a market that must bear the fee.) - - "Freely Available" means that no fee is charged for the item - itself, though there may be fees involved in handling the item. - It also means that recipients of the item may redistribute it - under the same conditions they received it. - -1. You may make and give away verbatim copies of the source form of the -Standard Version of this Package without restriction, provided that you -duplicate all of the original copyright notices and associated disclaimers. - -2. You may apply bug fixes, portability fixes and other modifications -derived from the Public Domain or from the Copyright Holder. A Package -modified in such a way shall still be considered the Standard Version. - -3. You may otherwise modify your copy of this Package in any way, provided -that you insert a prominent notice in each changed file stating how and -when you changed that file, and provided that you do at least ONE of the -following: - - a) place your modifications in the Public Domain or otherwise make them - Freely Available, such as by posting said modifications to Usenet or - an equivalent medium, or placing the modifications on a major archive - site such as uunet.uu.net, or by allowing the Copyright Holder to include - your modifications in the Standard Version of the Package. - - b) use the modified Package only within your corporation or organization. - - c) rename any non-standard executables so the names do not conflict - with standard executables, which must also be provided, and provide - a separate manual page for each non-standard executable that clearly - documents how it differs from the Standard Version. - - d) make other distribution arrangements with the Copyright Holder. - -4. You may distribute the programs of this Package in object code or -executable form, provided that you do at least ONE of the following: - - a) distribute a Standard Version of the executables and library files, - together with instructions (in the manual page or equivalent) on where - to get the Standard Version. - - b) accompany the distribution with the machine-readable source of - the Package with your modifications. - - c) give non-standard executables non-standard names, and clearly - document the differences in manual pages (or equivalent), together - with instructions on where to get the Standard Version. - - d) make other distribution arrangements with the Copyright Holder. - -5. You may charge a reasonable copying fee for any distribution of this -Package. You may charge any fee you choose for support of this -Package. You may not charge a fee for this Package itself. However, -you may distribute this Package in aggregate with other (possibly -commercial) programs as part of a larger (possibly commercial) software -distribution provided that you do not advertise this Package as a -product of your own. You may embed this Package's interpreter within -an executable of yours (by linking); this shall be construed as a mere -form of aggregation, provided that the complete Standard Version of the -interpreter is so embedded. - -6. The scripts and library files supplied as input to or produced as -output from the programs of this Package do not automatically fall -under the copyright of this Package, but belong to whoever generated -them, and may be sold commercially, and may be aggregated with this -Package. If such scripts or library files are aggregated with this -Package via the so-called "undump" or "unexec" methods of producing a -binary executable image, then distribution of such an image shall -neither be construed as a distribution of this Package nor shall it -fall under the restrictions of Paragraphs 3 and 4, provided that you do -not represent such an executable image as a Standard Version of this -Package. - -7. C subroutines (or comparably compiled subroutines in other -languages) supplied by you and linked into this Package in order to -emulate subroutines and variables of the language defined by this -Package shall not be considered part of this Package, but are the -equivalent of input as in Paragraph 6, provided these subroutines do -not change the language in any way that would cause it to fail the -regression tests for the language. - -8. Aggregation of this Package with a commercial distribution is always -permitted provided that the use of this Package is embedded; that is, -when no overt attempt is made to make this Package's interfaces visible -to the end user of the commercial distribution. Such use shall not be -construed as a distribution of this Package. - -9. The name of the Copyright Holder may not be used to endorse or promote -products derived from this software without specific prior written permission. - -10. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR -IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED -WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. - - The End - -============= - GNU GENERAL PUBLIC LICENSE Version 1, February 1989 diff --git a/Mail-IMAPClient-2.2.9/IMAPClient b/Mail-IMAPClient-2.2.9/IMAPClient new file mode 120000 index 0000000..945c9b4 --- /dev/null +++ b/Mail-IMAPClient-2.2.9/IMAPClient @@ -0,0 +1 @@ +. \ No newline at end of file diff --git a/Mail-IMAPClient-2.2.9/IMAPClient.pm b/Mail-IMAPClient-2.2.9/IMAPClient.pm new file mode 100644 index 0000000..653dfdf --- /dev/null +++ b/Mail-IMAPClient-2.2.9/IMAPClient.pm @@ -0,0 +1,3767 @@ +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::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 + ) + ) { + 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 = IO::Socket::INET->new( + PeerAddr => $self->Server , + PeerPort => $self->Port||'imap(143)' , + 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"; + $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; + 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; + 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; diff --git a/Mail-IMAPClient-3.05/lib/Mail/IMAPClient.pod b/Mail-IMAPClient-2.2.9/IMAPClient.pod similarity index 90% rename from Mail-IMAPClient-3.05/lib/Mail/IMAPClient.pod rename to Mail-IMAPClient-2.2.9/IMAPClient.pod index 4b75c9d..3abe92f 100644 --- a/Mail-IMAPClient-3.05/lib/Mail/IMAPClient.pod +++ b/Mail-IMAPClient-2.2.9/IMAPClient.pod @@ -1,3 +1,10 @@ +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 @@ -38,176 +45,126 @@ 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 -DIGEST-MD5, CRAM-MD5, LOGIN, PLAIN (SASL), and NTLM authentication. +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. -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. -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. -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. -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. -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. -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. -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. -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: +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. +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 and RawSocket Parameters +=item Socket Parameter -Both parameters hold 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. This is also useful if you want to use -L alternatives, like L. +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. -The I parameter simply records the socket to use for future -operations, without attempting any interaction on it. In this case, you -have to be sure to handle all the preliminar operations and to manually -set the B object in sync with its actual status with -respect to this socket (see below for additional parameters regarding -this, especially the I parameter). +=item State, Server, Password, and User Parameters -The I parameter, instead, also attempts to carry on preliminar -phases if the conditions apply. If both parameters are present, this -takes the precedence over I. It is primarily used to -provide an alternative socket for communications, e.g. to use -L instead of L used by L -by default. - -B -As of version 2.99_04 of this module, the I parameter has -changed semantics to make it more "DWIM". The I parameter was -introduced as a replacement for the I parameter in older version. - -=item State, Server, Proxy, 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. - -I is required for PLAIN (SASL) authentication. +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 Authuser - -Normally you authenticate and log in with the username specified in -the User parameter. When you are using DIGEST-MD5 as I, -you can optionally specify a different username for the final log in. -This can be useful to mark messages as seen for the I -if you don't know the password of the user as the seen state -is often a per-user state. +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. All supported authentication mechanisms have a default callback; -in every other case not supplying the callback results in an error. +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: +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. +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: +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 { @@ -217,39 +174,18 @@ would set your I like this: } ); -Note particularly the double dollar signs in C<$$buffer> in the B -call; this is not a typo! +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. - -=item Ignoresizeerrors - -Certain (caching) servers, like Exchange 2007, often report the wrong -message size. Instead of chopping the message into a size that it -fits the specified size, the reported size will be simply ignored -when this parameter is set to C<1>. - -=item Supportedflags - -Especially when C is used, the receiving peer may need to -be configured explicitly with the list of supported flags; that may -be different from the source IMAP server. - -The names are to be specified as an ARRAY. Black-slashes and casing -will be ignored. - -You may also specify a CODE reference, which will be called for each of -the flags seperately. In this case, the flags are not (yet) normalized. -The returned lists of the CODE calls are shape the resulting flag list. +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 @@ -526,21 +462,6 @@ 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 Rfc2060_datetime - -Example: - - $date = $imap->Rfc2060_datetime($seconds); - # or: - $date = Mail::IMAPClient->Rfc2060_datetime($seconds); - -The B method accepts one or two arguments: a obligatory -timestamp and an optional zone. The zone shall be formatted as -C<< [+-]\d{4} >>, and defaults to C<< +0000 >>. The timestamp follows the -definition of the output of the platforms specific C