home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2004 December / PCpro_2004_12.ISO / files / webserver / xampp / xampp-perl-addon-1.4.9-installer.exe / IMAPClient.pm < prev    next >
Encoding:
Perl POD Document  |  2003-07-02  |  109.3 KB  |  3,768 lines
  1. package Mail::IMAPClient;
  2.  
  3. # $Id: IMAPClient.pm,v 20001010.20 2003/06/13 18:30:55 dkernen Exp $
  4.  
  5. $Mail::IMAPClient::VERSION = '2.2.9';
  6. $Mail::IMAPClient::VERSION = '2.2.9';      # do it twice to make sure it takes
  7.  
  8. use Fcntl qw(F_GETFL F_SETFL O_NONBLOCK);
  9. use Socket();
  10. use IO::Socket();
  11. use IO::Select();
  12. use IO::File();
  13. use Carp qw(carp);
  14. #use Data::Dumper;
  15. use Errno qw/EAGAIN/;
  16.  
  17. #print "Found Fcntl in $INC{'Fcntl.pm'}\n";
  18. #Fcntl->import;
  19.  
  20. use constant Unconnected => 0;
  21.  
  22. use constant Connected         => 1;             # connected; not logged in
  23.  
  24. use constant Authenticated => 2;              # logged in; no mailbox selected
  25.  
  26. use constant Selected => 3;                   # mailbox selected
  27.  
  28. use constant INDEX => 0;                      # Array index for output line number
  29.  
  30. use constant TYPE => 1;                       # Array index for line type 
  31.                         #    (either OUTPUT, INPUT, or LITERAL)
  32.  
  33. use constant DATA => 2;                           # Array index for output line data
  34.  
  35. use constant NonFolderArg => 1;            # Value to pass to Massage to 
  36.                         # indicate non-folder argument
  37.  
  38.  
  39.  
  40. my %SEARCH_KEYS = map { ( $_ => 1 ) } qw/
  41.     ALL ANSWERED BCC BEFORE BODY CC DELETED DRAFT FLAGGED
  42.     FROM HEADER KEYWORD LARGER NEW NOT OLD ON OR RECENT
  43.     SEEN SENTBEFORE SENTON SENTSINCE SINCE SMALLER SUBJECT
  44.     TEXT TO UID UNANSWERED UNDELETED UNDRAFT UNFLAGGED 
  45.     UNKEYWORD UNSEEN
  46. /;
  47.  
  48. sub _debug {
  49.     my $self = shift;
  50.     return unless $self->Debug;
  51.     my $fh = $self->{Debug_fh} || \*STDERR; 
  52.     print $fh @_;
  53. }
  54.  
  55. sub MaxTempErrors {
  56.     my $self = shift;
  57.     $_[0]->{Maxtemperrors} = $_[1] if defined($_[1]);
  58.     return $_[0]->{Maxtemperrors};
  59. }
  60.  
  61. # This function is used by the accessor methods
  62. #
  63. sub _do_accessor {
  64.   my $datum = shift;
  65.  
  66.   if ( defined($_[1]) and $datum eq 'Fast_io' and ref($_[0]->{Socket})) {
  67.     if ($_[1]) {                      # Passed the "True" flag
  68.       my $fcntl = 0;
  69.       eval { $fcntl=fcntl($_[0]->{Socket}, F_GETFL, 0) } ;
  70.       if ($@) {
  71.       $_[0]->{Fast_io} = 0;
  72.       carp ref($_[0]) . " not using Fast_IO; not available on this platform"
  73.         if ( ( $^W or $_[0]->Debug) and not $_[0]->{_fastio_warning_}++);
  74.       } else {
  75.       $_[0]->{Fast_io} = 1;
  76.       $_[0]->{_fcntl} = $fcntl;
  77.       my $newflags = $fcntl;
  78.       $newflags |= O_NONBLOCK;
  79.       fcntl($_[0]->{Socket}, F_SETFL, $newflags) ;
  80.       
  81.       }
  82.     } else {
  83.       eval { fcntl($_[0]->{Socket}, F_SETFL, $_[0]->{_fcntl}) } 
  84.         if exists $_[0]->{_fcntl};
  85.       $_[0]->{Fast_io} = 0;
  86.       delete $_[0]->{_fcntl} if exists $_[0]->{_fcntl};
  87.     }
  88.   } elsif ( defined($_[1]) and $datum eq 'Socket' ) {
  89.     
  90.     # Get rid of fcntl settings for obsolete socket handles:
  91.     delete $_[0]->{_fcntl} ;
  92.     # Register this handle in a select vector:
  93.     $_[0]->{_select} = IO::Select->new($_[1]) ;
  94.   }
  95.   
  96.   if (scalar(@_) > 1) {
  97.     $@ = $_[1] if $datum eq 'LastError';
  98.     chomp $@ if $datum eq 'LastError';
  99.     return $_[0]->{$datum} = $_[1] ;
  100.   } else {
  101.     return $_[0]->{$datum};
  102.   }
  103. }
  104.  
  105. # the following for loop sets up eponymous accessor methods for 
  106. # the object's parameters:
  107.  
  108. BEGIN {
  109.  for my $datum (
  110.         qw(     State Port Server Folder Fast_io Peek
  111.             User Password Socket Timeout Buffer
  112.             Debug LastError Count Uid Debug_fh Maxtemperrors
  113.             EnableServerResponseInLiteral
  114.             Authmechanism Authcallback Ranges
  115.             Readmethod Showcredentials
  116.             Prewritemethod
  117.         )
  118.  ) {
  119.         no strict 'refs';
  120.         *$datum = sub { _do_accessor($datum, @_); };
  121.  }
  122.  
  123.  eval {
  124.    require Digest::HMAC_MD5;
  125.    require MIME::Base64;
  126.  };
  127.  if ($@) {
  128.    $Mail::IMAPClient::_CRAM_MD5_ERR =
  129.      "Internal CRAM-MD5 implementation not available: $@";
  130.    $Mail::IMAPClient::_CRAM_MD5_ERR =~ s/\n+$/\n/;
  131.  }
  132. }
  133.  
  134. sub Wrap {     shift->Clear(@_);     }
  135.  
  136. # The following class method is for creating valid dates in appended msgs:
  137.  
  138. sub Rfc822_date {
  139. my $class=      shift;
  140. #Date: Fri, 09 Jul 1999 13:10:55 -0000#
  141. my $date =      $class =~ /^\d+$/ ? $class : shift ;
  142. my @date =      gmtime($date);
  143. my @dow  =      qw{ Sun Mon Tue Wed Thu Fri Sat };
  144. my @mnt  =      qw{ Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec};
  145. #
  146. return          sprintf(
  147.                         "%s, %2.2d %s %4.4s %2.2d:%2.2d:%2.2d -%4.4d",
  148.                         $dow[$date[6]],
  149.                         $date[3],
  150.                         $mnt[$date[4]],
  151.                         $date[5]+=1900,
  152.                         $date[2],
  153.                         $date[1],
  154.                         $date[0],
  155.                         $date[8]) ;
  156. }
  157.  
  158. # The following class method is for creating valid dates for use in IMAP search strings:
  159.  
  160. sub Rfc2060_date {
  161. my $class=      shift;
  162. # 11-Jan-2000
  163. my $date =      $class =~ /^\d+$/ ? $class : shift ;
  164. my @date =      gmtime($date);
  165. my @mnt  =      qw{ Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec};
  166. #
  167. return          sprintf(
  168.                         "%2.2d-%s-%4.4s",
  169.                         $date[3],
  170.                         $mnt[$date[4]],
  171.                         $date[5]+=1900
  172.         ) ;
  173. }
  174.  
  175. # The following class method strips out <CR>'s so lines end with <LF> 
  176. #    instead of <CR><LF>:
  177.  
  178. sub Strip_cr {
  179.     my $class = shift;
  180.     unless ( ref($_[0]) or scalar(@_) > 1 ) {
  181.         (my $string = $_[0]) =~ s/\x0d\x0a/\x0a/gm;
  182.         return $string;
  183.     }
  184.     return wantarray ?         map { s/\x0d\x0a/\0a/gm ; $_ }  
  185.                 (ref($_[0]) ? @{$_[0]}  : @_)          : 
  186.                 [ map { s/\x0d\x0a/\x0a/gm ; $_ } 
  187.                   ref($_[0]) ? @{$_[0]} : @_ 
  188.                 ] ;
  189. }
  190.  
  191. # The following defines a special method to deal with the Clear parameter:
  192.  
  193. sub Clear {
  194.     my $self = shift;
  195.     defined(my $clear = shift) or return $self->{Clear}; 
  196.     
  197.     my $oldclear   = $self->{Clear};
  198.     $self->{Clear} = $clear;
  199.  
  200.     my (@keys) = sort { $b <=> $a } keys %{$self->{"History"}}  ;
  201.  
  202.     for ( my $i = $clear; $i < @keys ; $i++ ) 
  203.         { delete $self->{'History'}{$keys[$i]} }
  204.  
  205.     return $oldclear;
  206. }
  207.  
  208. # read-only access to the transaction number:
  209. sub Transaction { shift->Count };
  210.  
  211. # the constructor:
  212. sub new {
  213.     my $class     = shift;
  214.     my $self      =     {
  215.         LastError    => "", 
  216.         Uid         => 1, 
  217.         Count         => 0,
  218.         Fast_io     => 1,
  219.         "Clear"        => 5, 
  220.     };
  221.     while (scalar(@_)) {
  222.         $self->{ucfirst(lc($_[0]))} = $_[1]; shift, shift;
  223.     }
  224.     bless $self, ref($class)||$class;
  225.  
  226.     $self->State(Unconnected);
  227.  
  228.     $self->{Debug_fh} ||= \*STDERR;
  229.     select((select($self->{Debug_fh}),$|++)[0]) ;
  230.      $self->_debug("Using Mail::IMAPClient version $Mail::IMAPClient::VERSION " .
  231.         "and perl version " . (defined $^V ? join(".",unpack("CCC",$^V)) : "") . 
  232.         " ($])\n") if $self->Debug;
  233.     $self->LastError(0);
  234.     $self->Maxtemperrors or $self->Maxtemperrors("unlimited") ;
  235.     return $self->connect if $self->Server and !$self->Socket;
  236.     return $self;
  237. }
  238.  
  239.  
  240. sub connect {
  241.     my $self = shift;
  242.     
  243.     $self->Port(143) 
  244.         if     defined ($IO::Socket::INET::VERSION) 
  245.         and     $IO::Socket::INET::VERSION eq '1.25' 
  246.         and     !$self->Port;
  247.     %$self = (%$self, @_);
  248.     my $sock = IO::Socket::INET->new(
  249.         PeerAddr => $self->Server        ,
  250.                 PeerPort => $self->Port||'imap(143)'    ,
  251.                 Proto    => 'tcp'             ,
  252.                 Timeout  => $self->Timeout||0        ,
  253.         Debug    => $self->Debug         ,
  254.     )                        ;
  255.  
  256.     unless ( defined($sock) ) {
  257.         
  258.         $self->LastError( "Unable to connect to $self->{Server}: $!\n");    
  259.         $@         = "Unable to connect to $self->{Server}: $!";    
  260.         carp           "Unable to connect to $self->{Server}: $!" 
  261.                 unless defined wantarray;    
  262.         return undef;
  263.     }
  264.     $self->Socket($sock);
  265.     $self->State(Connected);
  266.  
  267.     $sock->autoflush(1)                ;
  268.     
  269.     my ($code, $output);
  270.         $output = "";
  271.  
  272.         until ( $code ) {
  273.  
  274.                 $output = $self->_read_line or return undef;
  275.                 for my $o (@$output) {
  276.             $self->_debug("Connect: Received this from readline: " . 
  277.                     join("/",@$o) . "\n");
  278.                         $self->_record($self->Count,$o);    # $o is a ref
  279.                       next unless $o->[TYPE] eq "OUTPUT";
  280.                       ($code) = $o->[DATA] =~ /^\*\s+(OK|BAD|NO)/i  ;
  281.                 }
  282.  
  283.         }
  284.  
  285.     if ($code =~ /BYE|NO /) {
  286.         $self->State(Unconnected);
  287.         return undef ;
  288.     }
  289.  
  290.     if ($self->User and $self->Password) {
  291.         return $self->login ;
  292.     } else {
  293.         return $self;    
  294.     }
  295. }
  296.     
  297.  
  298. sub login {
  299.     my $self = shift;
  300.     return $self->authenticate($self->Authmechanism,$self->Authcallback) 
  301.         if $self->{Authmechanism};
  302.  
  303.     my $id   = $self->User;
  304.     my $has_quotes = $id =~ /^".*"$/ ? 1 : 0;
  305.     my $string =     "Login " . ( $has_quotes ? $id : qq("$id") ) . " " . 
  306.             "{" . length($self->Password) . 
  307.             "}\r\n".$self->Password."\r\n";
  308.     $self->_imap_command($string) 
  309.         and $self->State(Authenticated);
  310.     # $self->folders and $self->separator unless $self->NoAutoList;
  311.     unless ( $self->IsAuthenticated) {
  312.         my($carp)     =  $self->LastError;
  313.         $carp         =~ s/^[\S]+ ([^\x0d\x0a]*)\x0d?\x0a/$1/;
  314.          carp $carp unless defined wantarray;
  315.         return undef;
  316.     }
  317.     return $self;
  318. }
  319.  
  320. sub separator {
  321.     my $self = shift;
  322.     my $target = shift ; 
  323.  
  324.     unless ( defined($target) ) {
  325.         my $sep = "";
  326.         #     separator is namespace's 1st thing's 1st thing's 2nd thing:
  327.         eval {     $sep = $self->namespace->[0][0][1] }     ;
  328.         return $sep if $sep;
  329.     }    
  330.         
  331.     defined($target) or $target = "";
  332.     $target ||= '""' ;
  333.     
  334.     
  335.  
  336.     # The fact that the response might end with {123} doesn't really matter here:
  337.  
  338.     unless (exists $self->{"$target${;}SEPARATOR"}) {
  339.         my $list = (grep(/^\*\s+LIST\s+/,($self->list(undef,$target)||("NO")) ))[0] || 
  340.                 qq("/");
  341.         my $s = (split(/\s+/,$list))[3];
  342.         defined($s) and $self->{"$target${;}SEPARATOR"} = 
  343.                 ( $s eq 'NIL' ? 'NIL' : substr($s, 1,length($s)-2) );
  344.     }
  345.     return $self->{$target,'SEPARATOR'};
  346. }
  347.  
  348. sub sort {
  349.     my $self = shift;
  350.     my @hits;
  351.     my @a = @_;
  352.     $@ = "";
  353.     $a[0] = "($a[0])" unless $a[0] =~ /^\(.*\)$/;      # wrap criteria in parens
  354.     $self->_imap_command( ( $self->Uid ? "UID " : "" ) . "SORT ". join(' ',@a))
  355.          or return wantarray ? @hits : \@hits ;
  356.     my @results =  $self->History($self->Count);
  357.  
  358.     for my $r (@results) {
  359.         chomp $r;
  360.         $r =~ s/\r$//;
  361.         $r =~ s/^\*\s+SORT\s+// or next;   
  362.         push @hits, grep(/\d/,(split(/\s+/,$r)));
  363.     }
  364.     return wantarray ? @hits : \@hits;     
  365. }
  366.  
  367. sub list {
  368.     my $self = shift;
  369.     my ($reference, $target) = (shift, shift);
  370.     $reference = "" unless defined($reference);
  371.     $target = '*' unless defined($target);
  372.     $target = '""' if $target eq "";
  373.     $target       = $self->Massage($target) unless $target eq '*' or $target eq '""';
  374.     my $string     =  qq(LIST "$reference" $target);
  375.     $self->_imap_command($string)  or return undef;
  376.     return wantarray ?     
  377.             $self->History($self->Count)                   : 
  378.                            [ map { $_->[DATA] } @{$self->{'History'}{$self->Count}}] ;
  379. }
  380.  
  381. sub lsub {
  382.     my $self = shift;
  383.     my ($reference, $target) = (shift, shift);
  384.     $reference = "" unless defined($reference);
  385.     $target = '*' unless defined($target);
  386.     $target           = $self->Massage($target);
  387.     my $string      =  qq(LSUB "$reference" $target);
  388.     $self->_imap_command($string)  or return undef;
  389.     return wantarray ?      $self->History($self->Count)            : 
  390.                               [ map { $_->[DATA] } @{$self->{'History'}{$self->Count}}        ] ;
  391. }
  392.  
  393. sub subscribed {
  394.         my $self = shift;
  395.     my $what = shift ;
  396.  
  397.         my @folders ;  
  398.  
  399.     my @list = $self->lsub(undef,( $what? "$what" . 
  400.         $self->separator($what) . "*" : undef ) );
  401.     push @list, $self->lsub(undef, $what) if $what and $self->exists($what) ;
  402.  
  403.           # my @list = map { $self->_debug("Pushing $_->[${\(DATA)}] \n"); $_->[DATA] } 
  404.     #    @$output;
  405.  
  406.     my $m;
  407.  
  408.     for ($m = 0; $m < scalar(@list); $m++ ) {
  409.         if ($list[$m] && $list[$m]  !~ /\x0d\x0a$/ ) {
  410.             $list[$m] .= $list[$m+1] ;
  411.             $list[$m+1] = "";    
  412.         }
  413.             
  414.         
  415.         # $self->_debug("Subscribed: examining $list[$m]\n");
  416.  
  417.         push @folders, $1||$2 
  418.             if $list[$m] =~
  419.                         /       ^\*\s+LSUB               # * LSUB
  420.                                 \s+\([^\)]*\)\s+         # (Flags)
  421.                                 (?:"[^"]*"|NIL)\s+     # "delimiter" or NIL
  422.                                 (?:"([^"]*)"|(.*))\x0d\x0a$  # Name or "Folder name"
  423.                         /ix;
  424.  
  425.         } 
  426.  
  427.         # for my $f (@folders) { $f =~ s/^\\FOLDER LITERAL:://;}
  428.     my @clean = () ; my %memory = (); 
  429.     foreach my $f (@folders) { push @clean, $f unless $memory{$f}++ }
  430.         return wantarray ? @clean : \@clean ;
  431. }
  432.  
  433.  
  434. sub deleteacl {
  435.     my $self = shift;
  436.     my ($target, $user ) = @_;
  437.     $target       = $self->Massage($target);
  438.     $user          =~ s/^"(.*)"$/$1/;
  439.     $user             =~ s/"/\\"/g;
  440.     my $string     =  qq(DELETEACL $target "$user");
  441.     $self->_imap_command($string)  or return undef;
  442.  
  443.     return wantarray ?     $self->History($self->Count)                 : 
  444.                               [ map {$_->[DATA] } @{$self->{'History'}{$self->Count}}] ;
  445. }
  446.  
  447. sub setacl {
  448.         my $self = shift;
  449.         my ($target, $user, $acl) = @_;
  450.         $user = $self->User unless length($user);
  451.         $target = $self->Folder unless length($target);
  452.         $target           = $self->Massage($target);
  453.         $user             =~ s/^"(.*)"$/$1/;
  454.         $user             =~ s/"/\\"/g;
  455.         $acl              =~ s/^"(.*)"$/$1/;
  456.         $acl              =~ s/"/\\"/g;
  457.         my $string      =  qq(SETACL $target "$user" "$acl");
  458.         $self->_imap_command($string)  or return undef;
  459.         return wantarray            ?
  460.         $self->History($self->Count)    :
  461.         [map{$_->[DATA]}@{$self->{'History'}{$self->Count}}]
  462.     ;
  463. }
  464.  
  465.  
  466. sub getacl {
  467.         my $self = shift;
  468.         my ($target) = @_;
  469.         $target = $self->Folder unless defined($target);
  470.         my $mtarget           = $self->Massage($target);
  471.         my $string      =  qq(GETACL $mtarget);
  472.         $self->_imap_command($string)  or return undef;
  473.     my @history = $self->History($self->Count);
  474.     #$self->_debug("Getacl history: ".join("|",@history).">>>End of History<<<" ) ;
  475.     my $perm = ""; 
  476.     my $hash = {};
  477.     for ( my $x = 0; $x < scalar(@history) ; $x++ ) {
  478.             if ( $history[$x] =~ /^\* ACL/ ) {
  479.             
  480.             $perm = $history[$x]=~ /^\* ACL $/    ? 
  481.                 $history[++$x].$history[++$x]     : 
  482.                 $history[$x];        
  483.  
  484.             $perm =~ s/\s?\x0d\x0a$//;
  485.             piece:  until ( $perm =~ /\Q$target\E"?$/ or !$perm) {
  486.                 #$self->_debug(qq(Piece: permline=$perm and " 
  487.                 #    "pattern = /\Q$target\E"? \$/));
  488.                 $perm =~ s/\s([^\s]+)\s?$// or last piece;
  489.                 my($p) = $1;
  490.                 $perm =~ s/\s([^\s]+)\s?$// or last piece;
  491.                 my($u) = $1;
  492.                 $hash->{$u} = $p;
  493.                 $self->_debug("Permissions: $u => $p \n");
  494.             }
  495.         
  496.         }
  497.     }
  498.         return $hash;
  499. }
  500.  
  501. sub listrights {
  502.     my $self = shift;
  503.     my ($target, $user) = @_;
  504.     $user = $self->User unless defined($user);
  505.     $target = $self->Folder unless defined($target);
  506.     $target       = $self->Massage($target);
  507.     $user          =~ s/^"(.*)"$/$1/;
  508.     $user             =~ s/"/\\"/g;
  509.     my $string     =  qq(LISTRIGHTS $target "$user");
  510.     $self->_imap_command($string)  or return undef;
  511.     my $resp = ( grep(/^\* LISTRIGHTS/, $self->History($self->Count) ) )[0];
  512.     my @rights = split(/\s/,$resp);    
  513.     shift @rights, shift @rights, shift @rights, shift @rights;
  514.     my $rights = join("",@rights);
  515.     $rights =~ s/"//g;    
  516.     return wantarray ? split(//,$rights) : $rights ;
  517. }
  518.  
  519. sub select {
  520.     my $self = shift;
  521.     my $target = shift ;  
  522.     return undef unless defined($target);
  523.  
  524.     my $qqtarget = $self->Massage($target);
  525.  
  526.     my $string     =  qq/SELECT $qqtarget/;
  527.  
  528.     my $old = $self->Folder;
  529.  
  530.     if ($self->_imap_command($string) and $self->State(Selected)) {
  531.         $self->Folder($target);
  532.         return $old||$self;
  533.     } else { 
  534.         return undef;
  535.     }
  536. }
  537.  
  538. sub message_string {
  539.     my $self = shift;
  540.     my $msg  = shift;
  541.     my $expected_size = $self->size($msg);
  542.     return undef unless(defined $expected_size);    # unable to get size
  543.     my $cmd  =      $self->has_capability('IMAP4REV1')                 ? 
  544.                 "BODY" . ( $self->Peek ? '.PEEK[]' : '[]' )         : 
  545.                 "RFC822" .  ( $self->Peek ? '.PEEK' : ''  )        ;
  546.  
  547.     $self->fetch($msg,$cmd) or return undef;
  548.     
  549.     my $string = "";
  550.  
  551.     foreach my $result  (@{$self->{"History"}{$self->Transaction}}) { 
  552.               $string .= $result->[DATA] 
  553.         if defined($result) and $self->_is_literal($result) ;
  554.     }      
  555.     # BUG? should probably return undef if length != expected
  556.     if ( length($string) != $expected_size ) { 
  557.         carp "${self}::message_string: " .
  558.             "expected $expected_size bytes but received " . 
  559.             length($string) 
  560.             if $self->Debug or $^W; 
  561.     }
  562.     if ( length($string) > $expected_size ) 
  563.     { $string = substr($string,0,$expected_size) }
  564.     if ( length($string) < $expected_size ) {
  565.         $self->LastError("${self}::message_string: expected ".
  566.             "$expected_size bytes but received " . 
  567.             length($string)."\n");
  568.         return undef;
  569.     }
  570.     return $string;
  571. }
  572.  
  573. sub bodypart_string {
  574.     my($self, $msg, $partno, $bytes, $offset) = @_;
  575.  
  576.     unless ( $self->has_capability('IMAP4REV1') ) {
  577.         $self->LastError(
  578.                 "Unable to get body part; server " . 
  579.                 $self->Server . 
  580.                 " does not support IMAP4REV1"
  581.         );
  582.         return undef;
  583.     }
  584.     my $cmd = "BODY" . ( $self->Peek ? ".PEEK[$partno]" : "[$partno]" )     ;
  585.     $offset ||= 0 ;
  586.     $cmd .= "<$offset.$bytes>" if $bytes;
  587.  
  588.     $self->fetch($msg,$cmd) or return undef;
  589.     
  590.     my $string = "";
  591.  
  592.     foreach my $result  (@{$self->{"History"}{$self->Transaction}}) { 
  593.               $string .= $result->[DATA] 
  594.         if defined($result) and $self->_is_literal($result) ;
  595.     }      
  596.     return $string;
  597. }
  598.  
  599. sub message_to_file {
  600.     my $self = shift;
  601.     my $fh   = shift;
  602.     my @msgs = @_;
  603.     my $handle;
  604.  
  605.     if ( ref($fh) ) {
  606.         $handle = $fh;
  607.     } else { 
  608.         $handle = IO::File->new(">>$fh");
  609.         unless ( defined($handle)) {
  610.             $@ = "Unable to open $fh: $!";
  611.             $self->LastError("Unable to open $fh: $!\n");
  612.             carp $@ if $^W;
  613.             return undef;
  614.         }
  615.         binmode $handle;    # For those of you who need something like this...
  616.     } 
  617.  
  618.         my $clear = $self->Clear;
  619.     my $cmd = $self->Peek ? 'BODY.PEEK[]' : 'BODY[]';
  620.     $cmd = $self->Peek ? 'RFC822.PEEK' : 'RFC822' unless $self->imap4rev1;
  621.     
  622.     my $string = ( $self->Uid ? "UID " : "" ) . "FETCH " . join(",",@msgs) . " $cmd";
  623.  
  624.         $self->Clear($clear)
  625.                 if $self->Count >= $clear and $clear > 0;
  626.  
  627.         my $trans       = $self->Count($self->Count+1);
  628.  
  629.         $string         = "$trans $string" ;
  630.  
  631.         $self->_record($trans,[ 0, "INPUT", "$string\x0d\x0a"] );
  632.  
  633.         my $feedback = $self->_send_line("$string");
  634.  
  635.         unless ($feedback) {
  636.                 $self->LastError( "Error sending '$string' to IMAP: $!\n");
  637.                 $@ = "Error sending '$string' to IMAP: $!";
  638.                 return undef;
  639.         }
  640.  
  641.         my ($code, $output);
  642.         $output = "";
  643.  
  644.         READ: until ( $code)  {
  645.                 $output = $self->_read_line($handle) or return undef; # avoid possible infinite loop
  646.                 for my $o (@$output) {
  647.                         $self->_record($trans,$o);    # $o is a ref
  648.                         # $self->_debug("Received from readline: ${\($o->[DATA])}<<END OF RESULT>>\n");
  649.                         next unless $self->_is_output($o);
  650.                         ($code) = $o->[DATA] =~ /^$trans (OK|BAD|NO)/mi ;
  651.                         if ($o->[DATA] =~ /^\*\s+BYE/im) {
  652.                                 $self->State(Unconnected);
  653.                                 return undef ;
  654.                         }
  655.                 }
  656.         }
  657.  
  658.         # $self->_debug("Command $string: returned $code\n");
  659.     close $handle unless ref($fh);
  660.         return $code =~ /^OK/im ? $self : undef ;
  661.  
  662. }
  663.  
  664. sub message_uid {
  665.     my $self = shift;
  666.     my $msg  = shift;
  667.     my @uid = $self->fetch($msg,"UID");
  668.     my $uid;
  669.     while ( my $u = shift @uid and !$uid) {
  670.         ($uid) = $u =~ /\(UID\s+(\d+)\s*\)\r?$/;
  671.     }
  672.     return $uid;
  673. }
  674.  
  675. sub original_migrate {
  676.     my($self,$peer,$msgs,$folder) = @_;
  677.     unless ( eval { $peer->IsConnected } ) {
  678.         $self->LastError("Invalid or unconnected " .  ref($self). 
  679.                  " object used as target for migrate." );
  680.         return undef;
  681.     }
  682.     unless ($folder) {
  683.         $folder = $self->Folder;
  684.         $peer->exists($folder)         or 
  685.             $peer->create($folder)     or 
  686.             (
  687.                 $self->LastError("Unable to created folder $folder on target mailbox: ".
  688.                     "$peer->LastError") and 
  689.                 return undef 
  690.             ) ;
  691.     }            
  692.     if ( $msgs =~ /^all$/i ) { $msgs = $self->search("ALL") }
  693.     foreach my $mid ( ref($msgs) ? @$msgs : $msgs ) {
  694.         my $uid = $peer->append($folder,$self->message_string($mid));
  695.         $self->LastError("Trouble appending to peer: " . $peer->LastError . "\n");
  696.     }
  697. }
  698.  
  699.  
  700. sub migrate {
  701.  
  702.     my($self,$peer,$msgs,$folder)     = @_;
  703.     my($toSock,$fromSock)         = ( $peer->Socket, $self->Socket);
  704.     my $bufferSize             = $self->Buffer || 4096;
  705.     my $fromBuffer             = "";
  706.     my $clear             = $self->Clear;
  707.  
  708.     unless ( eval { $peer->IsConnected } ) {
  709.         $self->LastError("Invalid or unconnected " . 
  710.             ref($self) . " object used as target for migrate. $@");
  711.         return undef;
  712.     }
  713.  
  714.     unless ($folder) {
  715.         $folder = $self->Folder     or
  716.             $self->LastError( "No folder selected on source mailbox.") 
  717.             and return undef;
  718.  
  719.         $peer->exists($folder)        or 
  720.             $peer->create($folder)    or 
  721.             (
  722.                 $self->LastError(
  723.                   "Unable to create folder $folder on target mailbox: ".
  724.                   $peer->LastError . "\n"
  725.                 ) and return undef 
  726.             ) ;
  727.     }
  728.     $msgs or $msgs eq "0" or $msgs = "all";    
  729.     if ( $msgs =~ /^all$/i ) { $msgs = $self->search("ALL") }
  730.     my $range = $self->Range($msgs) ;
  731.     $self->_debug("Migrating the following msgs from $folder: " . 
  732.         " $range\n");
  733.         # ( ref($msgs) ? join(", ",@$msgs) : $msgs) );
  734.  
  735.     #MIGMSG:    foreach my $mid ( ref($msgs) ? @$msgs : (split(/,\s*/,$msgs)) ) {#}
  736.     MIGMSG:    foreach my $mid ( $range->unfold ) {
  737.         # Set up counters for size of msg and portion of msg remaining to
  738.         # process:
  739.         $self->_debug("Migrating message $mid in folder $folder\n") 
  740.             if $self->Debug;
  741.         my $leftSoFar = my $size = $self->size($mid);
  742.  
  743.         # fetch internaldate and flags of original message:
  744.         my $intDate = '"' . $self->internaldate($mid) . '"' ;
  745.         my $flags   = "(" . join(" ",grep(!/\\Recent/i,$self->flags($mid)) ) . ")" ;
  746.         $flags = "" if  $flags eq "()" ;
  747.  
  748.         # set up transaction numbers for from and to connections:
  749.         my $trans       = $self->Count($self->Count+1);
  750.         my $ptrans      = $peer->Count($peer->Count+1);
  751.  
  752.         # If msg size is less than buffersize then do whole msg in one 
  753.         # transaction:
  754.         if ( $size <= $bufferSize ) {
  755.             my $new_mid = $peer->append_string($peer->Massage($folder),
  756.                     $self->message_string($mid) ,$flags,
  757.                     $intDate) ;
  758.                 $self->_debug("Copied message $mid in folder $folder to " . 
  759.                     $peer->User .
  760.                     '@' . $peer->Server . 
  761.                     ". New Message UID is $new_mid.\n" 
  762.                 ) if $self->Debug;
  763.  
  764.                 $peer->_debug("Copied message $mid in folder $folder from " . 
  765.                 $self->User .
  766.                 '@' . $self->Server . ". New Message UID is $new_mid.\n" 
  767.                 ) if $peer->Debug;
  768.  
  769.  
  770.             next MIGMSG;
  771.         }
  772.  
  773.         # otherwise break it up into digestible pieces:
  774.         my ($cmd, $pattern);
  775.         if ( $self->imap4rev1 ) {
  776.             # imap4rev1 supports FETCH BODY 
  777.             $cmd = $self->Peek ? 'BODY.PEEK[]' : 'BODY[]';
  778.             $pattern = sub {
  779.                                 #$self->_debug("Data fed to pattern: $_[0]<END>\n");
  780.                                 my($one) = $_[0] =~ /\(.*BODY\[\]<\d+> \{(\d+)\}/i ; # ;-)
  781.                     # or $self->_debug("Didn't match pattern\n") ; 
  782.                                 #$self->_debug("Returning from pattern: $1\n") if defined($1);
  783.                 return $one ;
  784.                         } ;
  785.         } else {
  786.             # older imaps use (deprecated) FETCH RFC822:
  787.             $cmd = $self->Peek ? 'RFC822.PEEK' : 'RFC822' ;
  788.             $pattern = sub {
  789.                 my($one) = shift =~ /\(RFC822\[\]<\d+> \{(\d+)\}/i; 
  790.                 return $one ;
  791.             };
  792.         }
  793.  
  794.  
  795.         # Now let's warn the peer that there's a message coming:
  796.  
  797.         my $pstring =     "$ptrans APPEND " . 
  798.                 $self->Massage($folder). 
  799.                 " " . 
  800.                 ( $flags ? "$flags " : () ) . 
  801.                 ( $intDate ? "$intDate " : () ) . 
  802.                 "{" . $size . "}"  ;
  803.  
  804.         $self->_debug("About to issue APPEND command to peer " .
  805.             "for msg $mid\n")         if $self->Debug;
  806.  
  807.         my $feedback2 = $peer->_send_line( $pstring ) ;
  808.  
  809.         $peer->_record($ptrans,[ 
  810.             0, 
  811.             "INPUT", 
  812.             "$pstring" ,
  813.         ] ) ;
  814.         unless ($feedback2) {
  815.            $self->LastError("Error sending '$pstring' to target IMAP: $!\n");
  816.            return undef;
  817.         }
  818.         # Get the "+ Go ahead" response:
  819.         my $code = 0;
  820.         until ($code eq '+' or $code =~ /NO|BAD|OK/ ) {
  821.             my $readSoFar = 0 ;
  822.           $readSoFar += sysread($toSock,$fromBuffer,1,$readSoFar)||0
  823.             until $fromBuffer =~ /\x0d\x0a/;
  824.  
  825.           #$peer->_debug("migrate: response from target server: " .
  826.           #    "$fromBuffer<END>\n")     if $peer->Debug;
  827.  
  828.           ($code)= $fromBuffer =~ /^(\+)|^(?:\d+\s(?:BAD|NO))/ ;
  829.           $code ||=0;
  830.  
  831.           $peer->_debug( "$folder: received $fromBuffer from server\n") 
  832.           if $peer->Debug;
  833.  
  834.             # ... and log it in the history buffers
  835.           $self->_record($trans,[ 
  836.             0, 
  837.             "OUTPUT", 
  838.             "Mail::IMAPClient migrating message $mid to $peer->User\@$peer->Server"
  839.           ] ) ;
  840.           $peer->_record($ptrans,[ 
  841.             0, 
  842.             "OUTPUT", 
  843.             $fromBuffer
  844.           ] ) ;
  845.  
  846.  
  847.         }
  848.         unless ( $code eq '+'  ) {
  849.             $^W and warn "$@\n";
  850.             $self->Debug and $self->_debug("Error writing to target host: $@\n");
  851.             next MIGMSG;    
  852.         }
  853.         # Here is where we start sticking in UID if that parameter
  854.         # is turned on:    
  855.         my $string = ( $self->Uid ? "UID " : "" ) . "FETCH $mid $cmd";
  856.  
  857.         # Clean up history buffer if necessary:
  858.         $self->Clear($clear)
  859.             if $self->Count >= $clear and $clear > 0;
  860.  
  861.  
  862.        # position will tell us how far from beginning of msg the
  863.        # next IMAP FETCH should start (1st time start at offet zero):
  864.        my $position = 0;
  865.        #$self->_debug("There are $leftSoFar bytes left versus a buffer of $bufferSize bytes.\n");
  866.        my $chunkCount = 0;
  867.        while ( $leftSoFar > 0 ) {
  868.         $self->_debug("Starting chunk " . ++$chunkCount . "\n");
  869.  
  870.         my $newstring         ="$trans $string<$position."  .
  871.                     ( $leftSoFar > $bufferSize ? $bufferSize : $leftSoFar ) . 
  872.                     ">" ;
  873.  
  874.         $self->_record($trans,[ 0, "INPUT", "$newstring\x0d\x0a"] );
  875.         $self->_debug("Issuing migration command: $newstring\n" )
  876.             if $self->Debug;;
  877.  
  878.         my $feedback = $self->_send_line("$newstring");
  879.  
  880.         unless ($feedback) {
  881.            $self->LastError("Error sending '$newstring' to source IMAP: $!\n");
  882.            return undef;
  883.         }
  884.         my $chunk = "";
  885.         until ($chunk = $pattern->($fromBuffer) ) {
  886.            $fromBuffer = "" ;
  887.                until ( $fromBuffer=~/\x0d\x0a$/ ) {
  888.                    sysread($fromSock,$fromBuffer,1,length($fromBuffer)) ; 
  889.             #$self->_debug("migrate chunk $chunkCount:" . 
  890.             #    "Read from source: $fromBuffer<END>\n");
  891.            }
  892.            
  893.            $self->_record($trans,[ 0, "OUTPUT", "$fromBuffer"] ) ;
  894.  
  895.            if ( $fromBuffer =~ /^$trans (?:NO|BAD)/ ) {
  896.             $self->LastError($fromBuffer) ;
  897.             next MIGMSG;
  898.            }
  899.  
  900.            if ( $fromBuffer =~ /^$trans (?:OK)/ ) {
  901.             $self->LastError("Unexpected good return code " .
  902.                 "from source host: " . $fromBuffer) ;
  903.             next MIGMSG;
  904.            }
  905.  
  906.         }
  907.         $fromBuffer = "";
  908.         my $readSoFar = 0 ;
  909.         $readSoFar += sysread($fromSock,$fromBuffer,$chunk-$readSoFar,$readSoFar)||0
  910.             until $readSoFar >= $chunk;
  911.         #$self->_debug("migrateRead: chunk=$chunk readSoFar=$readSoFar " .
  912.         #    "Buffer=$fromBuffer<END_OF_BUFFER\n") if $self->Debug;
  913.  
  914.         my $wroteSoFar     = 0;
  915.         my $temperrs     = 0;
  916.         my $optimize     = 0;
  917.  
  918.         until ( $wroteSoFar >= $chunk ) {
  919.          #$peer->_debug("Chunk $chunkCount: Next write will attempt to write " .
  920.          #    "this substring:\n" .
  921.          #    substr($fromBuffer,$wroteSoFar,$chunk-$wroteSoFar) .
  922.          #    "<END_OF_SUBSTRING>\n"
  923.          #);
  924.  
  925.          until ( $wroteSoFar >= $readSoFar ) {
  926.             $!=0;
  927.             my $ret = syswrite(
  928.                 $toSock,
  929.                 $fromBuffer,
  930.                 $chunk - $wroteSoFar, 
  931.                 $wroteSoFar )||0 ;
  932.  
  933.             $wroteSoFar += $ret;
  934.  
  935.             if ($! == &EAGAIN ) {
  936.             if (     $self->{Maxtemperrors} !~ /^unlimited/i
  937.                     and $temperrs++ > ($self->{Maxtemperrors}||10) 
  938.             ) {
  939.                 $self->LastError("Persistent '${!}' errors\n");
  940.                 $self->_debug("Persistent '${!}' errors\n");
  941.                 return undef;
  942.             }
  943.             $optimize = 1;
  944.             } else {
  945.             # avoid infinite loops on syswrite error
  946.             return undef unless(defined $ret);     
  947.             }
  948.             # Optimization of wait time between syswrite calls
  949.             # only runs if syscalls run too fast and fill the 
  950.             # buffer causing "EAGAIN: Resource Temp. Unavail" errors. The
  951.             # premise is that $maxwrite will be approx. the same as 
  952.             # the smallest buffer between the sending and receiving side. 
  953.             # Waiting time between syscalls should ideally be exactly as 
  954.             # long as it takes the receiving side to empty that buffer, 
  955.             # minus a little bit to prevent it from
  956.             # emptying completely and wasting time in the select call.
  957.             if ($optimize) {
  958.                 my $waittime = .02; 
  959.                 $maxwrite = $ret if $maxwrite < $ret;
  960.                 push( @last5writes, $ret );
  961.                 shift( @last5writes ) if $#last5writes > 5;
  962.                 my $bufferavail = 0;
  963.                 $bufferavail += $_ for ( @last5writes );
  964.                 $bufferavail /= ($#last5writes||1);
  965.                 # Buffer is staying pretty full; 
  966.                 # we should increase the wait period
  967.                 # to reduce transmission overhead/number of packets sent
  968.                 if ( $bufferavail < .4 * $maxwrite ) {
  969.                 $waittime *= 1.3;
  970.  
  971.                 # Buffer is nearly or totally empty; 
  972.                 # we're wasting time in select
  973.                 # call that could be used to send data, 
  974.                 # so reduce the wait period
  975.                 } elsif ( $bufferavail > .9 * $maxwrite ) {
  976.                 $waittime *= .5;
  977.                 }
  978.                 CORE::select(undef, undef, undef, $waittime);
  979.             }
  980.             if ( defined($ret) ) {
  981.             $temperrs = 0  ;
  982.             }
  983.             $peer->_debug("Chunk $chunkCount: " .
  984.             "Wrote $wroteSoFar bytes (out of $chunk)\n");
  985.            }
  986.         }
  987.         $position += $readSoFar ;
  988.         $leftSoFar -= $readSoFar;
  989.         $fromBuffer = "";
  990.         # Finish up reading the server response from the fetch cmd
  991.         #     on the source system:
  992.         {
  993.         my $code = 0;
  994.         until ( $code)  {
  995.  
  996.             # escape infinite loop if read_line never returns any data:
  997.  
  998.             $self->_debug("Reading from source server; expecting " .
  999.                 "') OK' type response\n") if $self->Debug;
  1000.  
  1001.             $output = $self->_read_line or return undef; 
  1002.             for my $o (@$output) {
  1003.  
  1004.                 $self->_record($trans,$o);      # $o is a ref
  1005.  
  1006.                 # $self->_debug("Received from readline: " .
  1007.                 # "${\($o->[DATA])}<<END OF RESULT>>\n");
  1008.  
  1009.                 next unless $self->_is_output($o);
  1010.  
  1011.                 ($code) = $o->[DATA] =~ /^$trans (OK|BAD|NO)/mi ;
  1012.  
  1013.                 if ($o->[DATA] =~ /^\*\s+BYE/im) {
  1014.                     $self->State(Unconnected);
  1015.                     return undef ;
  1016.                 }
  1017.                }
  1018.            }
  1019.            } # end scope for my $code
  1020.        }
  1021.        # Now let's send a <CR><LF> to the peer to signal end of APPEND cmd:
  1022.        {
  1023.         my $wroteSoFar = 0;
  1024.         $fromBuffer = "\x0d\x0a";
  1025.         $!=0;
  1026.         $wroteSoFar += syswrite($toSock,$fromBuffer,2-$wroteSoFar,$wroteSoFar)||0 
  1027.                 until $wroteSoFar >= 2;
  1028.  
  1029.        }
  1030.        # Finally, let's get the new message's UID from the peer:
  1031.        my $new_mid = "";
  1032.            {
  1033.                 my $code = 0;
  1034.                 until ( $code)  {
  1035.                         # escape infinite loop if read_line never returns any data:
  1036.             $peer->_debug("Reading from target: " .
  1037.                 "expecting new uid in response\n") if $peer->Debug;
  1038.  
  1039.                         $output = $peer->_read_line or next MIGMSG;
  1040.  
  1041.                         for my $o (@$output) {
  1042.  
  1043.                                 $peer->_record($ptrans,$o);      # $o is a ref
  1044.  
  1045.                                 # $peer->_debug("Received from readline: " .
  1046.                                 # "${\($o->[DATA])}<<END OF RESULT>>\n");
  1047.  
  1048.                                 next unless $peer->_is_output($o);
  1049.  
  1050.                                 ($code) = $o->[DATA] =~ /^$ptrans (OK|BAD|NO)/mi ;
  1051.                 ($new_mid)= $o->[DATA] =~ /APPENDUID \d+ (\d+)/ if $code;
  1052.                 #$peer->_debug("Code line: " . $o->[DATA] . 
  1053.                 #    "\nCode=$code mid=$new_mid\n" ) if $code;
  1054.  
  1055.                                 if ($o->[DATA] =~ /^\*\s+BYE/im) {
  1056.                                         $peer->State(Unconnected);
  1057.                                         return undef ;
  1058.                                 }
  1059.                         }
  1060.             $new_mid||="unknown" ;
  1061.                 }
  1062.              } # end scope for my $code
  1063.  
  1064.          $self->_debug("Copied message $mid in folder $folder to " . $peer->User .
  1065.                 '@' . $peer->Server . ". New Message UID is $new_mid.\n" 
  1066.          ) if $self->Debug;
  1067.  
  1068.          $peer->_debug("Copied message $mid in folder $folder from " . $self->User .
  1069.                 '@' . $self->Server . ". New Message UID is $new_mid.\n" 
  1070.          ) if $peer->Debug;
  1071.  
  1072.  
  1073.       # ... and finish up reading the server response from the fetch cmd
  1074.       #     on the source system:
  1075.           # {
  1076.     #    my $code = 0;
  1077.     #    until ( $code)  {
  1078.     #        # escape infinite loop if read_line never returns any data:
  1079.         #              unless ($output = $self->_read_line ) {
  1080.     #            $self->_debug($self->LastError) ;
  1081.     #            next MIGMSG;
  1082.     #        }
  1083.     #        for my $o (@$output) {
  1084. #
  1085. #                $self->_record($trans,$o);      # $o is a ref
  1086. #
  1087. #                # $self->_debug("Received from readline: " .
  1088. #                # "${\($o->[DATA])}<<END OF RESULT>>\n");
  1089. #
  1090. #                next unless $self->_is_output($o);
  1091. #
  1092. #                 ($code) = $o->[DATA] =~ /^$trans (OK|BAD|NO)/mi ;
  1093. #
  1094. #                      if ($o->[DATA] =~ /^\*\s+BYE/im) {
  1095. #                    $self->State(Unconnected);
  1096. #                    return undef ;
  1097. #                }
  1098. #            }
  1099. #        }
  1100. #        }
  1101.         
  1102.              # and clean up the I/O buffer:
  1103.              $fromBuffer = "";
  1104.          }
  1105.     return $self;    
  1106. }
  1107.  
  1108.  
  1109. sub body_string {
  1110.     my $self = shift;
  1111.     my $msg  = shift;
  1112.     my $ref = $self->fetch($msg,"BODY" . ( $self->Peek ? ".PEEK" : "" ) . "[TEXT]");
  1113.  
  1114.         my $string = "";
  1115.         foreach my $result  (@{$ref})     { 
  1116.                 $string .= $result->[DATA] if defined($result) and $self->_is_literal($result) ;
  1117.         }
  1118.     return $string if $string;
  1119.  
  1120.         my $head = shift @$ref;
  1121.         $self->_debug("body_string: first shift = '$head'\n");
  1122.  
  1123.         until ( (! $head)  or $head =~ /(?:.*FETCH .*\(.*BODY\[TEXT\])|(?:^\d+ BAD )|(?:^\d NO )/i ) {
  1124.                 $self->_debug("body_string: shifted '$head'\n");
  1125.                 $head = shift(@$ref) ;
  1126.         }
  1127.     unless ( scalar(@$ref) ) {
  1128.             $self->LastError("Unable to parse server response from " . $self->LastIMAPCommand );
  1129.             return undef ;
  1130.     }
  1131.     my $popped ; $popped = pop @$ref until     
  1132.             ( 
  1133.                 (     defined($popped) and 
  1134.                     # (-:    Smile!
  1135.                     $popped =~ /\)\x0d\x0a$/ 
  1136.                 )     or
  1137.                     not grep(
  1138.                         # (-:    Smile again!
  1139.                         /\)\x0d\x0a$/,
  1140.                         @$ref
  1141.                     )
  1142.             );
  1143.  
  1144.         if      ($head =~ /BODY\[TEXT\]\s*$/i )     {       # Next line is a literal
  1145.                         $string .= shift @$ref while scalar(@$ref);
  1146.                         $self->_debug("String is now $string\n") if $self->Debug;
  1147.         }
  1148.  
  1149.         return $string||undef;
  1150. }
  1151.  
  1152.  
  1153. sub examine {
  1154.     my $self = shift;
  1155.     my $target = shift ; return undef unless defined($target);
  1156.     $target = $self->Massage($target);
  1157.     my $string     =  qq/EXAMINE $target/;
  1158.  
  1159.     my $old = $self->Folder;
  1160.  
  1161.     if ($self->_imap_command($string) and $self->State(Selected)) {
  1162.         $self->Folder($target);
  1163.         return $old||$self;
  1164.     } else { 
  1165.         return undef;
  1166.     }
  1167. }
  1168.  
  1169. sub idle {
  1170.     my $self = shift;
  1171.     my $good = '+';
  1172.     my $count = $self->Count +1;
  1173.     return $self->_imap_command("IDLE",$good) ? $count : undef;
  1174. }
  1175.  
  1176. sub done {
  1177.     my $self     = shift;
  1178.  
  1179.     my $count     = shift||$self->Count;
  1180.  
  1181.     my $clear = "";
  1182.     $clear = $self->Clear;
  1183.  
  1184.     $self->Clear($clear) 
  1185.         if $self->Count >= $clear and $clear > 0;
  1186.  
  1187.     my $string = "DONE\x0d\x0a";
  1188.     $self->_record($count,[ $self->_next_index($count), "INPUT", "$string\x0d\x0a"] );
  1189.  
  1190.     my $feedback = $self->_send_line("$string",1);
  1191.  
  1192.     unless ($feedback) {
  1193.         $self->LastError( "Error sending '$string' to IMAP: $!\n");
  1194.         return undef;
  1195.     }
  1196.  
  1197.     my ($code, $output);    
  1198.     $output = "";
  1199.  
  1200.     until ( $code and $code =~ /(OK|BAD|NO)/m ) {
  1201.  
  1202.         $output = $self->_read_line or return undef;    
  1203.         for my $o (@$output) { 
  1204.             $self->_record($count,$o);    # $o is a ref
  1205.             next unless $self->_is_output($o);
  1206.                           ($code) = $o->[DATA] =~ /^(?:$count) (OK|BAD|NO)/m  ;
  1207.                       if ($o->[DATA] =~ /^\*\s+BYE/) {
  1208.                 $self->State(Unconnected);
  1209.             }
  1210.         }
  1211.     }    
  1212.     return $code =~ /^OK/ ? @{$self->Results} : undef ;
  1213.  
  1214. }
  1215.  
  1216. sub tag_and_run {
  1217.     my $self = shift;
  1218.     my $string = shift;
  1219.     my $good = shift;
  1220.     $self->_imap_command($string,$good);
  1221.     return @{$self->Results};
  1222. }
  1223. # _{name} methods are undocumented and meant to be private.
  1224.  
  1225. # _imap_command runs a command, inserting the correct tag
  1226. # and <CR><LF> and whatnot.
  1227. # When updating _imap_command, remember to examine the run method, too, since it is very similar.
  1228. #
  1229.  
  1230. sub _imap_command {
  1231.     
  1232.     my $self     = shift;
  1233.     my $string     = shift     or return undef;
  1234.     my $good     = shift     || 'GOOD';
  1235.  
  1236.     my $qgood = quotemeta($good);
  1237.  
  1238.     my $clear = "";
  1239.     $clear = $self->Clear;
  1240.  
  1241.     $self->Clear($clear) 
  1242.         if $self->Count >= $clear and $clear > 0;
  1243.  
  1244.     my $count     = $self->Count($self->Count+1);
  1245.  
  1246.     $string     = "$count $string" ;
  1247.  
  1248.     $self->_record($count,[ 0, "INPUT", "$string\x0d\x0a"] );
  1249.  
  1250.     my $feedback = $self->_send_line("$string");
  1251.  
  1252.     unless ($feedback) {
  1253.         $self->LastError( "Error sending '$string' to IMAP: $!\n");
  1254.         $@ = "Error sending '$string' to IMAP: $!";
  1255.         carp "Error sending '$string' to IMAP: $!" if $^W;
  1256.         return undef;
  1257.     }
  1258.  
  1259.     my ($code, $output);    
  1260.     $output = "";
  1261.  
  1262.     READ: until ( $code)  {
  1263.             # escape infinite loop if read_line never returns any data:
  1264.                   $output = $self->_read_line or return undef; 
  1265.  
  1266.         for my $o (@$output) { 
  1267.             $self->_record($count,$o);    # $o is a ref
  1268.                       # $self->_debug("Received from readline: ${\($o->[DATA])}<<END OF RESULT>>\n");
  1269.             next unless $self->_is_output($o);
  1270.             if ( $good eq '+' ) {
  1271.                               $o->[DATA] =~ /^$count (OK|BAD|NO|$qgood)|^($qgood)/mi ;
  1272.                 $code = $1||$2 ;
  1273.             } else {
  1274.                               ($code) = $o->[DATA] =~ /^$count (OK|BAD|NO|$qgood)/mi ;
  1275.             }
  1276.                       if ($o->[DATA] =~ /^\*\s+BYE/im) {
  1277.                 $self->State(Unconnected);
  1278.                 return undef ;
  1279.             }
  1280.         }
  1281.     }    
  1282.     
  1283.     # $self->_debug("Command $string: returned $code\n");
  1284.     return $code =~ /^OK|$qgood/im ? $self : undef ;
  1285.  
  1286. }
  1287.  
  1288. sub run {
  1289.     my $self     = shift;
  1290.     my $string     = shift     or return undef;
  1291.     my $good     = shift     || 'GOOD';
  1292.     my $count     = $self->Count($self->Count+1);
  1293.     my($tag)    = $string =~ /^(\S+) /  ;
  1294.  
  1295.     unless ($tag) {
  1296.         $self->LastError("Invalid string passed to run method; no tag found.\n");
  1297.     }
  1298.  
  1299.     my $qgood = quotemeta($good);
  1300.  
  1301.     my $clear = "";
  1302.     $clear = $self->Clear;
  1303.  
  1304.     $self->Clear($clear) 
  1305.         if $self->Count >= $clear and $clear > 0;
  1306.  
  1307.     $self->_record($count,[ $self->_next_index($count), "INPUT", "$string"] );
  1308.  
  1309.     my $feedback = $self->_send_line("$string",1);
  1310.  
  1311.     unless ($feedback) {
  1312.         $self->LastError( "Error sending '$string' to IMAP: $!\n");
  1313.         return undef;
  1314.     }
  1315.  
  1316.     my ($code, $output);    
  1317.     $output = "";
  1318.  
  1319.     until ( $code =~ /(OK|BAD|NO|$qgood)/m ) {
  1320.  
  1321.         $output = $self->_read_line or return undef;    
  1322.         for my $o (@$output) { 
  1323.             $self->_record($count,$o);    # $o is a ref
  1324.             next unless $self->_is_output($o);
  1325.             if ( $good eq '+' ) {
  1326.                $o->[DATA] =~ /^(?:$tag|\*) (OK|BAD|NO|$qgood)|(^$qgood)/m  ;
  1327.                $code = $1||$2;
  1328.             } else {
  1329.                               ($code) = 
  1330.                    $o->[DATA] =~ /^(?:$tag|\*) (OK|BAD|NO|$qgood)/m  ;
  1331.             }
  1332.                       if ($o->[DATA] =~ /^\*\s+BYE/) {
  1333.                 $self->State(Unconnected);
  1334.             }
  1335.         }
  1336.     }    
  1337.     $self->{'History'}{$tag} = $self->{"History"}{$count} unless $tag eq $count;
  1338.     return $code =~ /^OK|$qgood/ ? @{$self->Results} : undef ;
  1339.  
  1340. }
  1341. #sub bodystruct {    # return bodystruct 
  1342. #}
  1343.  
  1344. # _record saves the conversation into the History structure:
  1345. sub _record {
  1346.  
  1347.     my ($self,$count,$array) = ( shift, shift, shift);
  1348.     local($^W)= undef;
  1349.  
  1350.     #$self->_debug(sprintf("in _record: count is $count, values are %s/%s/%s and caller is " . 
  1351.     #    join(":",caller()) . "\n",@$array));
  1352.     
  1353.       if (    #       $array->[DATA] and 
  1354.               $array->[DATA] =~ /^\d+ LOGIN/i and
  1355.         ! $self->Showcredentials
  1356.       ) { 
  1357.  
  1358.               $array->[DATA] =~ s/LOGIN.*/LOGIN XXXXXXXX XXXXXXXX/i ;
  1359.     }
  1360.  
  1361.     push @{$self->{"History"}{$count}}, $array;
  1362.  
  1363.       if ( $array->[DATA] =~ /^\d+\s+(BAD|NO)\s/im ) {
  1364.               $self->LastError("$array->[DATA]") ;
  1365.               $@ = $array->[DATA];
  1366.               carp "$array->[DATA]" if $^W ;
  1367.     }
  1368.     return $self;
  1369. }
  1370.  
  1371. #_send_line writes to the socket:
  1372. sub _send_line {
  1373.     my($self,$string,$suppress) = (shift, shift, shift);
  1374.  
  1375.     #$self->_debug("_send_line: Connection state = " . 
  1376.     #        $self->State . " and socket fh = " . 
  1377.     #        ($self->Socket||"undef") . "\n")
  1378.     #if $self->Debug;
  1379.  
  1380.     unless ($self->IsConnected and $self->Socket) {
  1381.         $self->LastError("NO Not connected.\n");
  1382.         carp "Not connected" if $^W;
  1383.         return undef;
  1384.     }
  1385.  
  1386.     unless ($string =~ /\x0d\x0a$/ or $suppress ) {
  1387.  
  1388.         chomp $string;
  1389.         $string .= "\x0d" unless $string =~ /\x0d$/;    
  1390.         $string .= "\x0a" ;
  1391.     }
  1392.     if ( 
  1393.         $string =~ /^[^\x0a{]*\{(\d+)\}\x0d\x0a/        # ;-}
  1394.     )     {
  1395.         my($p1,$p2,$len) ;
  1396.         if ( ($p1,$len)   = 
  1397.             $string =~ /^([^\x0a{]*\{(\d+)\}\x0d\x0a)/ # } for vi
  1398.             and  (
  1399.                 $len < 32766 ? 
  1400.                 ( ($p2) = $string =~ /
  1401.                     ^[^\x0a{]*
  1402.                     \{\d+\}
  1403.                     \x0d\x0a
  1404.                     (
  1405.                         .{$len}
  1406.                         .*\x0d\x0a
  1407.                     )
  1408.                 /x ) :
  1409.  
  1410.                 ( ($p2) = $string =~ /    ^[^\x0a{]*
  1411.                             \{\d+\}
  1412.                             \x0d\x0a
  1413.                             (.*\x0d\x0a)
  1414.                             /x     
  1415.                    and length($p2) == $len  ) # }} for vi
  1416.              )
  1417.         ) {
  1418.             $self->_debug("Sending literal string " .
  1419.                 "in two parts: $p1\n\tthen: $p2\n");
  1420.             $self->_send_line($p1) or return undef;
  1421.             $output = $self->_read_line or return undef;
  1422.             foreach my $o (@$output) {
  1423.                 # $o is already an array ref:
  1424.                 $self->_record($self->Count,$o);              
  1425.                               ($code) = $o->[DATA] =~ /(^\+|NO|BAD)/i;
  1426.                               if ($o->[DATA] =~ /^\*\s+BYE/) {
  1427.                     $self->State(Unconnected);
  1428.                     close $fh;
  1429.                     return undef ;
  1430.                               } elsif ( $o->[DATA]=~ /^\d+\s+(NO|BAD)/i ) {
  1431.                     close $fh;
  1432.                     return undef;
  1433.                 }
  1434.             }
  1435.             if ( $code eq '+' )     { $string = $p2; } 
  1436.             else             { return undef ; }
  1437.         }
  1438.         
  1439.     }
  1440.     if ($self->Debug) {
  1441.         my $dstring = $string;
  1442.         if ( $dstring =~ m[\d+\s+Login\s+]i) {
  1443.             $dstring =~ 
  1444.               s(\b(?:\Q$self->{Password}\E|\Q$self->{User}\E)\b)
  1445.             ('X' x length($self->{Password}))eg;
  1446.         }
  1447.         _debug $self, "Sending: $dstring\n" if $self->Debug;
  1448.     }
  1449.     my $total = 0;
  1450.     my $temperrs = 0;
  1451.     my $optimize = 0;
  1452.          my $maxwrite = 0;
  1453.          my $waittime = .02;
  1454.          my @last5writes = (1);
  1455.     $string = $self->Prewritemethod->($self,$string) if $self->Prewritemethod;
  1456.     _debug $self, "Sending: $string\n" if $self->Debug and $self->Prewritemethod;
  1457.  
  1458.     until ($total >= length($string)) {
  1459.         my $ret = 0;
  1460.             $!=0;
  1461.         $ret =    syswrite(    
  1462.                     $self->Socket, 
  1463.                     $string, 
  1464.                     length($string)-$total, 
  1465.                     $total
  1466.                     );
  1467.         $ret||=0;
  1468.         if ($! == &EAGAIN ) {
  1469.             if (     $self->{Maxtemperrors} !~ /^unlimited/i
  1470.                     and $temperrs++ > ($self->{Maxtemperrors}||10) 
  1471.             ) {
  1472.                 $self->LastError("Persistent '${!}' errors\n");
  1473.                 $self->_debug("Persistent '${!}' errors\n");
  1474.                 return undef;
  1475.             }
  1476.             $optimize = 1;
  1477.         } else {
  1478.             # avoid infinite loops on syswrite error
  1479.             return undef unless(defined $ret);     
  1480.         }
  1481.         # Optimization of wait time between syswrite calls
  1482.         # only runs if syscalls run too fast and fill the 
  1483.         # buffer causing "EAGAIN: Resource Temp. Unavail" errors. The
  1484.         # premise is that $maxwrite will be approx. the same as 
  1485.         # the smallest buffer between the sending and receiving side. 
  1486.         # Waiting time between syscalls should ideally be exactly as 
  1487.         # long as it takes the receiving side to empty that buffer, 
  1488.         # minus a little bit to prevent it from
  1489.         # emptying completely and wasting time in the select call.
  1490.         if ($optimize) {
  1491.             $maxwrite = $ret if $maxwrite < $ret;
  1492.             push( @last5writes, $ret );
  1493.             shift( @last5writes ) if $#last5writes > 5;
  1494.             my $bufferavail = 0;
  1495.             $bufferavail += $_ for ( @last5writes );
  1496.             $bufferavail /= $#last5writes;
  1497.             # Buffer is staying pretty full; 
  1498.             # we should increase the wait period
  1499.             # to reduce transmission overhead/number of packets sent
  1500.             if ( $bufferavail < .4 * $maxwrite ) {
  1501.             $waittime *= 1.3;
  1502.  
  1503.             # Buffer is nearly or totally empty; 
  1504.             # we're wasting time in select
  1505.             # call that could be used to send data, 
  1506.             # so reduce the wait period
  1507.             } elsif ( $bufferavail > .9 * $maxwrite ) {
  1508.             $waittime *= .5;
  1509.             }
  1510.             $self->_debug("Output buffer full; waiting $waittime seconds for relief\n");
  1511.             CORE::select(undef, undef, undef, $waittime);
  1512.         }
  1513.         if ( defined($ret) ) {
  1514.             $temperrs = 0  ;
  1515.             $total += $ret ;
  1516.         }
  1517.     }
  1518.     _debug $self,"Sent $total bytes\n" if $self->Debug;
  1519.     return $total;
  1520. }
  1521.  
  1522. # _read_line reads from the socket. It is called by:
  1523. #     append    append_file    authenticate    connect        _imap_command
  1524. #
  1525. # It is also re-implemented in:
  1526. #    message_to_file
  1527. #
  1528. # syntax: $output = $self->_readline( ( $literal_callback|undef ) , ( $output_callback|undef ) ) ;
  1529. #       Both input argument are optional, but if supplied must either be a filehandle, coderef, or undef.
  1530. #
  1531. #    Returned argument is a reference to an array of arrays, ie: 
  1532. #    $output = [ 
  1533. #            [ $index, 'OUTPUT'|'LITERAL', $output_line ] ,
  1534. #            [ $index, 'OUTPUT'|'LITERAL', $output_line ] ,
  1535. #            ...     # etc,
  1536. #    ];
  1537.  
  1538. sub _read_line {
  1539.     my $self     = shift;    
  1540.     my $sh        = $self->Socket;
  1541.     my $literal_callback    = shift;
  1542.     my $output_callback = shift;
  1543.     
  1544.     unless ($self->IsConnected and $self->Socket) {
  1545.         $self->LastError("NO Not connected.\n");
  1546.         carp "Not connected" if $^W;
  1547.         return undef;
  1548.     }
  1549.  
  1550.     my $iBuffer    = ""; 
  1551.     my $oBuffer    = [];
  1552.     my $count    = 0;
  1553.     my $index    = $self->_next_index($self->Transaction);
  1554.     my $rvec     = my $ready = my $errors = 0; 
  1555.     my $timeout    = $self->Timeout;
  1556.  
  1557.     my $readlen     = 1;
  1558.     my $fast_io    = $self->Fast_io;    # Remember setting to reduce future method calls
  1559.  
  1560.     if ( $fast_io ) {
  1561.         
  1562.         # set fcntl if necessary:
  1563.         exists $self->{_fcntl} or $self->Fast_io($fast_io);
  1564.         $readlen = $self->{Buffer}||4096;
  1565.     }
  1566.     until (    
  1567.         # there's stuff in output buffer:
  1568.         scalar(@$oBuffer)    and             
  1569.  
  1570.         # the last thing there has cr-lf:
  1571.                 $oBuffer->[-1][DATA] =~ /\x0d\x0a$/  and     
  1572.  
  1573.         # that thing is an output line:
  1574.                 $oBuffer->[-1][TYPE]    eq "OUTPUT"  and     
  1575.  
  1576.         # and the input buffer has been MT'ed:
  1577.         $iBuffer        eq ""         
  1578.  
  1579.     ) {
  1580.               my $transno = $self->Transaction;  # used below in several places
  1581.         if ($timeout) {
  1582.             vec($rvec, fileno($self->Socket), 1) = 1;
  1583.             my @ready = $self->{_select}->can_read($timeout) ;
  1584.             unless ( @ready ) {
  1585.                 $self->LastError("Tag $transno: " .
  1586.                     "Timeout after $timeout seconds " .
  1587.                     "waiting for data from server\n");    
  1588.                 $self->_record($transno,
  1589.                     [    $self->_next_index($transno),
  1590.                         "ERROR",
  1591.                         "$transno * NO Timeout after ".
  1592.                         "$timeout seconds " .
  1593.                         "during read from " .
  1594.                         "server\x0d\x0a"
  1595.                     ]
  1596.                 );
  1597.                 $self->LastError(
  1598.                     "Timeout after $timeout seconds " .
  1599.                     "during read from server\x0d\x0a"
  1600.                 );
  1601.                 return undef;
  1602.             }
  1603.         }
  1604.         
  1605.         local($^W) = undef;    # Now quiet down warnings
  1606.  
  1607.         # read "$readlen" bytes (or less):
  1608.               # need to check return code from $self->_sysread 
  1609.             #    in case other end has shut down!!!
  1610.               my $ret = $self->_sysread( $sh, \$iBuffer, $readlen, length($iBuffer)) ;
  1611.           # $self->_debug("Read so far: $iBuffer<<END>>\n");
  1612.               if($timeout and ! defined($ret)) { # Blocking read error...
  1613.                   my $msg = "Error while reading data from server: $!\x0d\x0a";
  1614.                   $self->_record($transno,
  1615.                                  [ $self->_next_index($transno),
  1616.                                    "ERROR", "$transno * NO $msg "
  1617.                                    ]);
  1618.                   $@ = "$msg";
  1619.                   return undef;
  1620.               }
  1621.               elsif(defined($ret) and $ret == 0) {    # Caught EOF...
  1622.                   my $msg="Socket closed while reading data from server.\x0d\x0a";
  1623.                   $self->_record($transno,
  1624.                                  [ $self->_next_index($transno),
  1625.                                    "ERROR", "$transno * NO $msg "
  1626.                                    ]);
  1627.                   $@ = "$msg";
  1628.                   return undef;
  1629.               }
  1630.               # successfully wrote to other end, keep going...
  1631.               $count += $ret;
  1632.         LINES: while ( $iBuffer =~ s/^(.*?\x0d?\x0a)// ) {
  1633.            my $current_line = $1;
  1634.  
  1635.            # $self->_debug("BUFFER: pulled from buffer: <BEGIN>${current_line}<END>\n" .
  1636.            #     "and left with buffer contents of: <BEGIN>${iBuffer}<END>\n");
  1637.  
  1638.            LITERAL: if ($current_line =~ s/\{(\d+)\}\x0d\x0a$//) {
  1639.             # This part handles IMAP "Literals", 
  1640.             # which according to rfc2060 look something like this:
  1641.             # [tag]|* BLAH BLAH {nnn}\r\n
  1642.             # [nnn bytes of literally transmitted stuff]
  1643.             # [part of line that follows literal data]\r\n
  1644.  
  1645.             # Set $len to be length of impending literal:
  1646.             my $len = $1 ;
  1647.             
  1648.             $self->_debug("LITERAL: received literal in line ".
  1649.                 "$current_line of length $len; ".
  1650.                 "attempting to ".
  1651.                 "retrieve from the " . length($iBuffer) . 
  1652.                 " bytes in: $iBuffer<END_OF_iBuffer>\n");
  1653.  
  1654.             # Xfer up to $len bytes from front of $iBuffer to $litstring: 
  1655.             my $litstring = substr($iBuffer, 0, $len);
  1656.             $iBuffer = substr($iBuffer, length($litstring), 
  1657.                     length($iBuffer) - length($litstring) ) ;
  1658.  
  1659.             # Figure out what's left to read (i.e. what part of 
  1660.             # literal wasn't in buffer):
  1661.             my $remainder_count = $len - length($litstring);
  1662.             my $callback_value = "";
  1663.  
  1664.             if ( defined($literal_callback) )     {    
  1665.                 if     ( $literal_callback =~ /GLOB/)     {    
  1666.                     print $literal_callback $litstring ;
  1667.                     $litstring = "";
  1668.                 } elsif ($literal_callback =~ /CODE/ ) {
  1669.                     # Don't do a thing
  1670.  
  1671.                 } else     {
  1672.                     $self->LastError(
  1673.                         ref($literal_callback) . 
  1674.                         " is an invalid callback type; " .
  1675.                         "must be a filehandle or coderef\n"
  1676.                     ); 
  1677.                 }
  1678.  
  1679.         
  1680.             }
  1681.             if ($remainder_count > 0 and $timeout) {
  1682.                 # If we're doing timeouts then here we set up select 
  1683.                 # and wait for data from the the IMAP socket.
  1684.                 vec($rvec, fileno($self->Socket), 1) = 1;
  1685.                 unless ( CORE::select( $ready = $rvec, 
  1686.                             undef, 
  1687.                             $errors = $rvec, 
  1688.                             $timeout) 
  1689.                 ) {    
  1690.                     # Select failed; that means bad news. 
  1691.                     # Better tell someone.
  1692.                     $self->LastError("Tag " . $transno . 
  1693.                         ": Timeout waiting for literal data " .
  1694.                         "from server\n");    
  1695.                     carp "Tag " . $transno . 
  1696.                         ": Timeout waiting for literal data " .
  1697.                         "from server\n"
  1698.                         if $self->Debug or $^W;    
  1699.                     return undef;
  1700.                 }    
  1701.             } 
  1702.             
  1703.             fcntl($sh, F_SETFL, $self->{_fcntl}) 
  1704.                 if $fast_io and defined($self->{_fcntl});
  1705.             while ( $remainder_count > 0 ) {       # As long as not done,
  1706.                 $self->_debug("Still need $remainder_count to " .
  1707.                     "complete literal string\n");
  1708.                 my $ret    = $self->_sysread(          # bytes read
  1709.                         $sh,            # IMAP handle 
  1710.                         \$litstring,       # place to read into
  1711.                         $remainder_count,  # bytes left to read
  1712.                         length($litstring) # offset to read into
  1713.                 ) ;
  1714.                 $self->_debug("Received ret=$ret and buffer = " .
  1715.                 "\n$litstring<END>\nwhile processing LITERAL\n");
  1716.                 if ( $timeout and !defined($ret)) { # possible timeout
  1717.                     $self->_record($transno, [ 
  1718.                         $self->_next_index($transno),
  1719.                         "ERROR",
  1720.                         "$transno * NO Error reading data " .
  1721.                         "from server: $!\n"
  1722.                         ]
  1723.                     );
  1724.                     return undef;
  1725.                 } elsif ( $ret == 0 and eof($sh) ) {
  1726.                     $self->_record($transno, [ 
  1727.                         $self->_next_index($transno),
  1728.                         "ERROR",
  1729.                         "$transno * ".
  1730.                         "BYE Server unexpectedly " .
  1731.                         "closed connection: $!\n"    
  1732.                         ]
  1733.                     );
  1734.                     $self->State(Unconnected);
  1735.                     return undef;
  1736.                 }
  1737.                 # decrement remaining bytes by amt read:
  1738.                 $remainder_count -= $ret;       
  1739.  
  1740.                 if ( length($litstring) > $len ) {
  1741.                                     # copy the extra struff into the iBuffer:
  1742.                                     $iBuffer = substr(
  1743.                                         $litstring,   
  1744.                                         $len, 
  1745.                                         length($litstring) - $len 
  1746.                                     );
  1747.                                     $litstring = substr($litstring, 0, $len) ;
  1748.                                 }
  1749.  
  1750.                 if ( defined($literal_callback) ) {
  1751.                     if ( $literal_callback =~ /GLOB/ ) {
  1752.                         print $literal_callback $litstring;
  1753.                         $litstring = "";
  1754.                     } 
  1755.                 }
  1756.  
  1757.             }
  1758.             $literal_callback->($litstring) 
  1759.                 if defined($litstring) and 
  1760.                 $literal_callback =~ /CODE/;
  1761.  
  1762.             $self->Fast_io($fast_io) if $fast_io;
  1763.  
  1764.         # Now let's make sure there are no IMAP server output lines 
  1765.         # (i.e. [tag|*] BAD|NO|OK Text) embedded in the literal string
  1766.         # (There shouldn't be but I've seen it done!), but only if
  1767.         # EnableServerResponseInLiteral is set to true
  1768.  
  1769.             my $embedded_output = 0;
  1770.             my $lastline = ( split(/\x0d?\x0a/,$litstring))[-1] 
  1771.                 if $litstring;
  1772.  
  1773.             if (     $self->EnableServerResponseInLiteral and
  1774.                 $lastline and 
  1775.                 $lastline =~ /^(?:\*|(\d+))\s(BAD|NO|OK)/i 
  1776.             ) {
  1777.               $litstring =~ s/\Q$lastline\E\x0d?\x0a//;
  1778.               $embedded_output++;
  1779.  
  1780.               $self->_debug("Got server output mixed in " .
  1781.                     "with literal: $lastline\n"
  1782.               )     if $self->Debug;
  1783.  
  1784.             }
  1785.               # Finally, we need to stuff the literal onto the 
  1786.             # end of the oBuffer:
  1787.             push @$oBuffer, [ $index++, "OUTPUT" , $current_line],
  1788.                     [ $index++, "LITERAL", $litstring   ];
  1789.             push @$oBuffer,    [ $index++, "OUTPUT",  $lastline    ] 
  1790.                     if $embedded_output;
  1791.  
  1792.           } else { 
  1793.             push @$oBuffer, [ $index++, "OUTPUT" , $current_line ]; 
  1794.           }
  1795.         
  1796.         }
  1797.         #$self->_debug("iBuffer is now: $iBuffer<<END OF BUFFER>>\n");
  1798.     }
  1799.     #    _debug $self, "Buffer is now $buffer\n";
  1800.       _debug $self, "Read: " . join("",map {$_->[DATA]} @$oBuffer) ."\n" 
  1801.         if $self->Debug;
  1802.     return scalar(@$oBuffer) ? $oBuffer : undef ;
  1803. }
  1804.  
  1805. sub _sysread {
  1806.     my $self = shift @_;
  1807.     if ( exists $self->{Readmethod} )  {
  1808.         return $self->Readmethod->($self,@_) ;
  1809.     } else {
  1810.         my($handle,$buffer,$count,$offset) = @_;
  1811.         return sysread( $handle, $$buffer, $count, $offset);
  1812.     }
  1813. }
  1814.  
  1815. =begin obsolete
  1816.  
  1817. sub old_read_line {
  1818.     my $self     = shift;    
  1819.     my $sh        = $self->Socket;
  1820.     my $literal_callback    = shift;
  1821.     my $output_callback = shift;
  1822.     
  1823.     unless ($self->IsConnected and $self->Socket) {
  1824.         $self->LastError("NO Not connected.\n");
  1825.         carp "Not connected" if $^W;
  1826.         return undef;
  1827.     }
  1828.  
  1829.     my $iBuffer    = ""; 
  1830.     my $oBuffer    = [];
  1831.     my $count    = 0;
  1832.     my $index    = $self->_next_index($self->Transaction);
  1833.     my $rvec     = my $ready = my $errors = 0; 
  1834.     my $timeout    = $self->Timeout;
  1835.  
  1836.     my $readlen     = 1;
  1837.     my $fast_io    = $self->Fast_io;    # Remember setting to reduce future method calls
  1838.  
  1839.     if ( $fast_io ) {
  1840.         
  1841.         # set fcntl if necessary:
  1842.         exists $self->{_fcntl} or $self->Fast_io($fast_io);
  1843.         $readlen = $self->{Buffer}||4096;
  1844.     }
  1845.     until (    
  1846.         # there's stuff in output buffer:
  1847.         scalar(@$oBuffer)    and             
  1848.  
  1849.         # the last thing there has cr-lf:
  1850.                 $oBuffer->[-1][DATA] =~ /\x0d\x0a$/  and     
  1851.  
  1852.         # that thing is an output line:
  1853.                 $oBuffer->[-1][TYPE]    eq "OUTPUT"  and     
  1854.  
  1855.         # and the input buffer has been MT'ed:
  1856.         $iBuffer        eq ""         
  1857.  
  1858.     ) {
  1859.               my $transno = $self->Transaction;  # used below in several places
  1860.         if ($timeout) {
  1861.             vec($rvec, fileno($self->Socket), 1) = 1;
  1862.             my @ready = $self->{_select}->can_read($timeout) ;
  1863.             unless ( @ready ) {
  1864.                 $self->LastError("Tag $transno: " .
  1865.                     "Timeout after $timeout seconds " .
  1866.                     "waiting for data from server\n");    
  1867.                 $self->_record($transno,
  1868.                     [    $self->_next_index($transno),
  1869.                         "ERROR",
  1870.                         "$transno * NO Timeout after ".
  1871.                         "$timeout seconds " .
  1872.                         "during read from " .
  1873.                         "server\x0d\x0a"
  1874.                     ]
  1875.                 );
  1876.                 $self->LastError(
  1877.                     "Timeout after $timeout seconds " .
  1878.                     "during read from server\x0d\x0a"
  1879.                 );
  1880.                 return undef;
  1881.             }
  1882.         }
  1883.         
  1884.         local($^W) = undef;    # Now quiet down warnings
  1885.  
  1886.         # read "$readlen" bytes (or less):
  1887.               # need to check return code from sysread in case other end has shut down!!!
  1888.               my $ret = sysread( $sh, $iBuffer, $readlen, length($iBuffer)) ;
  1889.         # $self->_debug("Read so far: $iBuffer<<END>>\n");
  1890.               if($timeout and ! defined($ret)) { # Blocking read error...
  1891.                   my $msg = "Error while reading data from server: $!\x0d\x0a";
  1892.                   $self->_record($transno,
  1893.                                  [ $self->_next_index($transno),
  1894.                                    "ERROR", "$transno * NO $msg "
  1895.                                    ]);
  1896.                   $@ = "$msg";
  1897.                   return undef;
  1898.               }
  1899.               elsif(defined($ret) and $ret == 0) {    # Caught EOF...
  1900.                   my $msg="Socket closed while reading data from server.\x0d\x0a";
  1901.                   $self->_record($transno,
  1902.                                  [ $self->_next_index($transno),
  1903.                                    "ERROR", "$transno * NO $msg "
  1904.                                    ]);
  1905.                   $@ = "$msg";
  1906.                   return undef;
  1907.               }
  1908.               # successfully wrote to other end, keep going...
  1909.               $count += $ret;
  1910.         LINES: while ( $iBuffer =~ s/^(.*?\x0d?\x0a)// ) {
  1911.            my $current_line = $1;
  1912.  
  1913.            # $self->_debug("BUFFER: pulled from buffer: <BEGIN>${current_line}<END>\n" .
  1914.            #     "and left with buffer contents of: <BEGIN>${iBuffer}<END>\n");
  1915.  
  1916.            LITERAL: if ($current_line =~ s/\{(\d+)\}\x0d\x0a$//) {
  1917.             # This part handles IMAP "Literals", which according to rfc2060 look something like this:
  1918.             # [tag]|* BLAH BLAH {nnn}\r\n
  1919.             # [nnn bytes of literally transmitted stuff]
  1920.             # [part of line that follows literal data]\r\n
  1921.  
  1922.             # Set $len to be length of impending literal:
  1923.             my $len = $1 ;
  1924.             
  1925.             $self->_debug("LITERAL: received literal in line $current_line of length $len; ".
  1926.             "attempting to ".
  1927.             "retrieve from the " . length($iBuffer) . " bytes in: $iBuffer<END_OF_iBuffer>\n");
  1928.  
  1929.             # Transfer up to $len bytes from front of $iBuffer to $litstring: 
  1930.             my $litstring = substr($iBuffer, 0, $len);
  1931.             $iBuffer = substr($iBuffer, length($litstring), length($iBuffer) - length($litstring) ) ;
  1932.  
  1933.             # Figure out what's left to read (i.e. what part of literal wasn't in buffer):
  1934.             my $remainder_count = $len - length($litstring);
  1935.             my $callback_value = "";
  1936.  
  1937.             if ( defined($literal_callback) )     {    
  1938.                 if     ( $literal_callback =~ /GLOB/)     {    
  1939.                     print $literal_callback $litstring ;
  1940.                     $litstring = "";
  1941.                 } elsif ($literal_callback =~ /CODE/ ) {
  1942.                     # Don't do a thing
  1943.  
  1944.                 } else     {
  1945.                     $self->LastError(
  1946.                         ref($literal_callback) . 
  1947.                         " is an invalid callback type; must be a filehandle or coderef"
  1948.                     ); 
  1949.                 }
  1950.  
  1951.         
  1952.             }
  1953.             if ($remainder_count > 0 and $timeout) {
  1954.                 # If we're doing timeouts then here we set up select and wait for data from the
  1955.                 # the IMAP socket.
  1956.                 vec($rvec, fileno($self->Socket), 1) = 1;
  1957.                 unless ( CORE::select( $ready = $rvec, 
  1958.                             undef, 
  1959.                             $errors = $rvec, 
  1960.                             $timeout) 
  1961.                 ) {    
  1962.                     # Select failed; that means bad news. 
  1963.                     # Better tell someone.
  1964.                     $self->LastError("Tag " . $transno . 
  1965.                         ": Timeout waiting for literal data " .
  1966.                         "from server\n");    
  1967.                     carp "Tag " . $transno . 
  1968.                         ": Timeout waiting for literal data " .
  1969.                         "from server\n"
  1970.                         if $self->Debug or $^W;    
  1971.                     return undef;
  1972.                 }    
  1973.             } 
  1974.             
  1975.             fcntl($sh, F_SETFL, $self->{_fcntl}) 
  1976.                 if $fast_io and defined($self->{_fcntl});
  1977.             while ( $remainder_count > 0 ) {       # As long as not done,
  1978.  
  1979.                 my $ret    = sysread(              # bytes read
  1980.                         $sh,            # IMAP handle 
  1981.                         $litstring,       # place to read into
  1982.                         $remainder_count,  # bytes left to read
  1983.                         length($litstring) # offset to read into
  1984.                 ) ;
  1985.                 if ( $timeout and !defined($ret)) { # possible timeout
  1986.                     $self->_record($transno, [ 
  1987.                         $self->_next_index($transno),
  1988.                         "ERROR",
  1989.                         "$transno * NO Error reading data " .
  1990.                         "from server: $!\n"
  1991.                         ]
  1992.                     );
  1993.                     return undef;
  1994.                 } elsif ( $ret == 0 and eof($sh) ) {
  1995.                     $self->_record($transno, [ 
  1996.                         $self->_next_index($transno),
  1997.                         "ERROR",
  1998.                         "$transno * ".
  1999.                         "BYE Server unexpectedly " .
  2000.                         "closed connection: $!\n"    
  2001.                         ]
  2002.                     );
  2003.                     $self->State(Unconnected);
  2004.                     return undef;
  2005.                 }
  2006.                 # decrement remaining bytes by amt read:
  2007.                 $remainder_count -= $ret;       
  2008.  
  2009.                 if ( defined($literal_callback) ) {
  2010.                     if ( $literal_callback =~ /GLOB/ ) {
  2011.                         print $literal_callback $litstring;
  2012.                         $litstring = "";
  2013.                     } 
  2014.                 }
  2015.  
  2016.             }
  2017.             $literal_callback->($litstring) 
  2018.                 if defined($litstring) and 
  2019.                 $literal_callback =~ /CODE/;
  2020.  
  2021.             $self->Fast_io($fast_io) if $fast_io;
  2022.  
  2023.         # Now let's make sure there are no IMAP server output lines 
  2024.         # (i.e. [tag|*] BAD|NO|OK Text) embedded in the literal string
  2025.         # (There shouldn't be but I've seen it done!), but only if
  2026.         # EnableServerResponseInLiteral is set to true
  2027.  
  2028.             my $embedded_output = 0;
  2029.             my $lastline = ( split(/\x0d?\x0a/,$litstring))[-1] 
  2030.                 if $litstring;
  2031.  
  2032.             if (     $self->EnableServerResponseInLiteral and
  2033.                 $lastline and 
  2034.                 $lastline =~ /^(?:\*|(\d+))\s(BAD|NO|OK)/i 
  2035.             ) {
  2036.               $litstring =~ s/\Q$lastline\E\x0d?\x0a//;
  2037.               $embedded_output++;
  2038.  
  2039.               $self->_debug("Got server output mixed in " .
  2040.                     "with literal: $lastline\n"
  2041.               )     if $self->Debug;
  2042.  
  2043.             }
  2044.               # Finally, we need to stuff the literal onto the 
  2045.             # end of the oBuffer:
  2046.             push @$oBuffer, [ $index++, "OUTPUT" , $current_line],
  2047.                     [ $index++, "LITERAL", $litstring   ];
  2048.             push @$oBuffer,    [ $index++, "OUTPUT",  $lastline    ] 
  2049.                     if $embedded_output;
  2050.  
  2051.           } else { 
  2052.             push @$oBuffer, [ $index++, "OUTPUT" , $current_line ]; 
  2053.           }
  2054.         
  2055.         }
  2056.         #$self->_debug("iBuffer is now: $iBuffer<<END OF BUFFER>>\n");
  2057.     }
  2058.     #    _debug $self, "Buffer is now $buffer\n";
  2059.       _debug $self, "Read: " . join("",map {$_->[DATA]} @$oBuffer) ."\n" 
  2060.         if $self->Debug;
  2061.     return scalar(@$oBuffer) ? $oBuffer : undef ;
  2062. }
  2063.  
  2064. =end obsolete
  2065.  
  2066. =cut
  2067.  
  2068.  
  2069. sub Report {
  2070.     my $self = shift;
  2071. #    $self->_debug( "Dumper: " . Data::Dumper::Dumper($self) . 
  2072. #            "\nReporting on following keys: " . join(", ",keys %{$self->{'History'}}). "\n");
  2073.     return     map { 
  2074.                       map { $_->[DATA] } @{$self->{"History"}{$_}} 
  2075.     }        sort { $a <=> $b } keys %{$self->{"History"}}
  2076.     ;
  2077. }
  2078.  
  2079.  
  2080. sub Results {
  2081.     my $self     = shift    ;
  2082.     my $transaction = shift||$self->Count;
  2083.     
  2084.     return wantarray                             ? 
  2085.               map {$_->[DATA] }       @{$self->{"History"}{$transaction}}     : 
  2086.               [ map {$_->[DATA] }     @{$self->{"History"}{$transaction}} ]   ;
  2087. }
  2088.  
  2089.  
  2090. sub LastIMAPCommand {
  2091.       my @a = map { $_->[DATA] } @{$_[0]->{"History"}{$_[1]||$_[0]->Transaction}};
  2092.     return shift @a;
  2093. }
  2094.  
  2095.  
  2096. sub History {
  2097.       my @a = map { $_->[DATA] } @{$_[0]->{"History"}{$_[1]||$_[0]->Transaction}};
  2098.     shift @a;
  2099.     return wantarray ? @a : \@a ;
  2100.  
  2101. }
  2102.  
  2103. sub Escaped_results {
  2104.     my @a;
  2105.     foreach  my $line (@{$_[0]->{"History"}{$_[1]||$_[0]->Transaction}} ) {
  2106.         if (  defined($line) and $_[0]->_is_literal($line) ) { 
  2107.             $line->[DATA] =~ s/([\\\(\)"\x0d\x0a])/\\$1/g ;
  2108.             push @a, qq("$line->[DATA]");
  2109.         } else {
  2110.                   push @a, $line->[DATA] ;
  2111.         }
  2112.     }
  2113.     # $a[0] is the ALWAYS the command ; I make sure of that in _imap_command
  2114.     shift @a;    
  2115.     return wantarray ? @a : \@a ;
  2116. }
  2117.  
  2118. sub Unescape {
  2119.     shift @_ if $_[1];
  2120.     my $whatever = shift;
  2121.     $whatever =~ s/\\([\\\(\)"\x0d\x0a])/$1/g if defined $whatever;
  2122.     return $whatever;
  2123. }
  2124.  
  2125. sub logout {
  2126.     my $self = shift;
  2127.     my $string = "LOGOUT";
  2128.     $self->_imap_command($string) ; 
  2129.     $self->{Folders} = undef;
  2130.     $self->{_IMAP4REV1} = undef;
  2131.     eval {$self->Socket->close if defined($self->Socket)} ; 
  2132.     $self->{Socket} = undef;
  2133.     $self->State(Unconnected);
  2134.     return $self;
  2135. }
  2136.  
  2137. sub folders {
  2138.         my $self = shift;
  2139.     my $what = shift ;
  2140.         return wantarray ?      @{$self->{Folders}} :
  2141.                                 $self->{Folders} 
  2142.                 if ref($self->{Folders}) and !$what;
  2143.     
  2144.         my @folders ;  
  2145.     my @list = $self->list(undef,( $what? "$what" . $self->separator($what) . "*" : undef ) );
  2146.     push @list, $self->list(undef, $what) if $what and $self->exists($what) ;
  2147.     # my @list = 
  2148.     # foreach (@list) { $self->_debug("Pushing $_\n"); }
  2149.     my $m;
  2150.  
  2151.     for ($m = 0; $m < scalar(@list); $m++ ) {
  2152.         # $self->_debug("Folders: examining $list[$m]\n");
  2153.  
  2154.         if ($list[$m] && $list[$m]  !~ /\x0d\x0a$/ ) {
  2155.             $self->_debug("folders: concatenating $list[$m] and " . $list[$m+1] . "\n") ;
  2156.             $list[$m] .= $list[$m+1] ;
  2157.             $list[$m+1] = "";    
  2158.             $list[$m] .= "\x0d\x0a" unless $list[$m] =~ /\x0d\x0a$/;
  2159.         }
  2160.             
  2161.         
  2162.  
  2163.         push @folders, $1||$2 
  2164.             if $list[$m] =~
  2165.                         /       ^\*\s+LIST               # * LIST
  2166.                                 \s+\([^\)]*\)\s+         # (Flags)
  2167.                                 (?:"[^"]*"|NIL)\s+     # "delimiter" or NIL
  2168.                                 (?:"([^"]*)"|(.*))\x0d\x0a$  # Name or "Folder name"
  2169.                         /ix;
  2170.         $folders[-1] = '"' . $folders[-1] . '"' 
  2171.             if $1 and !$self->exists($folders[-1]) ;
  2172.         # $self->_debug("folders: line $list[$m]: 1=$1 and 2=$2\n");
  2173.         } 
  2174.  
  2175.         # for my $f (@folders) { $f =~ s/^\\FOLDER LITERAL:://;}
  2176.     my @clean = (); my %memory = ();
  2177.     foreach my $f (@folders) { push @clean, $f unless $memory{$f}++ }
  2178.         $self->{Folders} = \@clean unless $what;
  2179.  
  2180.         return wantarray ? @clean : \@clean ;
  2181. }
  2182.  
  2183.  
  2184. sub exists {
  2185.     my ($self,$what) = (shift,shift);
  2186.     return $self if $self->STATUS($self->Massage($what),"(MESSAGES)");
  2187.     return undef;
  2188. }
  2189.  
  2190. # Updated to handle embedded literal strings
  2191. sub get_bodystructure {
  2192.     my($self,$msg) = @_;
  2193.     unless ( eval {require Mail::IMAPClient::BodyStructure ; 1 } ) {
  2194.         $self->LastError("Unable to use get_bodystructure: $@\n");
  2195.         return undef;
  2196.     }
  2197.     my @out = $self->fetch($msg,"BODYSTRUCTURE");
  2198.     my $bs = "";
  2199.     my $output = grep(    
  2200.         /BODYSTRUCTURE \(/i,  @out     # Wee! ;-)
  2201.     ); 
  2202.     if ( $output =~ /\r\n$/ ) {
  2203.         eval { $bs = Mail::IMAPClient::BodyStructure->new( $output )};  
  2204.     } else {
  2205.         $self->_debug("get_bodystructure: reassembling original response\n");
  2206.         my $start = 0;
  2207.         foreach my $o (@{$self->{"History"}{$self->Transaction}}) {
  2208.             next unless $self->_is_output_or_literal($o);
  2209.             $self->_debug("o->[DATA] is ".$o->[DATA]."\n");
  2210.             next unless $start or 
  2211.                 $o->[DATA] =~ /BODYSTRUCTURE \(/i and ++$start;      # Hi, vi! ;-)
  2212.             if ( length($output) and $self->_is_literal($o) ) {
  2213.                 my $data = $o->[DATA];
  2214.                 $data =~ s/"/\\"/g;
  2215.                 $data =~ s/\(/\\\(/g;
  2216.                 $data =~ s/\)/\\\)/g;
  2217.                 $output .= '"'.$data.'"';
  2218.             } else {
  2219.                 $output .= $o->[DATA] ;
  2220.             }
  2221.             $self->_debug("get_bodystructure: reassembled output=$output<END>\n");
  2222.         }
  2223.         eval { $bs = Mail::IMAPClient::BodyStructure->new( $output )};  
  2224.     }
  2225.     $self->_debug("get_bodystructure: msg $msg returns this ref: ". 
  2226.         ( $bs ? " $bs" : " UNDEF" ) 
  2227.         ."\n");
  2228.     return $bs;
  2229. }
  2230.  
  2231. # Updated to handle embedded literal strings 
  2232. sub get_envelope {
  2233.     my($self,$msg) = @_;
  2234.     unless ( eval {require Mail::IMAPClient::BodyStructure ; 1 } ) {
  2235.         $self->LastError("Unable to use get_envelope: $@\n");
  2236.         return undef;
  2237.     }
  2238.     my @out = $self->fetch($msg,"ENVELOPE");
  2239.     my $bs = "";
  2240.     my $output = grep(    
  2241.         /ENVELOPE \(/i,  @out     # Wee! ;-)
  2242.     ); 
  2243.     if ( $output =~ /\r\n$/ ) {
  2244.         eval { 
  2245.          $bs = Mail::IMAPClient::BodyStructure::Envelope->new($output)
  2246.         };
  2247.     } else {
  2248.         $self->_debug("get_envelope: " .
  2249.             "reassembling original response\n");
  2250.         my $start = 0;
  2251.         foreach my $o (@{$self->{"History"}{$self->Transaction}}) {
  2252.             next unless $self->_is_output_or_literal($o);
  2253.             $self->_debug("o->[DATA] is ".$o->[DATA]."\n");
  2254.             next unless $start or 
  2255.                 $o->[DATA] =~ /ENVELOPE \(/i and ++$start;
  2256.                 # Hi, vi! ;-)
  2257.             if ( length($output) and $self->_is_literal($o) ) {
  2258.                 my $data = $o->[DATA];
  2259.                 $data =~ s/"/\\"/g;
  2260.                 $data =~ s/\(/\\\(/g;
  2261.                 $data =~ s/\)/\\\)/g;
  2262.                 $output .= '"'.$data.'"';
  2263.             } else {
  2264.                 $output .= $o->[DATA] ;
  2265.             }
  2266.             $self->_debug("get_envelope: " .
  2267.                 "reassembled output=$output<END>\n");
  2268.         }
  2269.         eval { 
  2270.           $bs=Mail::IMAPClient::BodyStructure::Envelope->new($output)
  2271.         };  
  2272.     }
  2273.     $self->_debug("get_envelope: msg $msg returns this ref: ". 
  2274.         ( $bs ? " $bs" : " UNDEF" ) 
  2275.         ."\n");
  2276.     return $bs;
  2277. }
  2278.  
  2279. =begin obsolete
  2280.  
  2281. sub old_get_envelope {
  2282.     my($self,$msg) = @_;
  2283.     unless ( eval {require Mail::IMAPClient::BodyStructure ; 1 } ) {
  2284.         $self->LastError("Unable to use get_envelope: $@\n");
  2285.         return undef;
  2286.     }
  2287.     my $bs = "";
  2288.     my @out = $self->fetch($msg,"ENVELOPE");
  2289.     my $output = grep(    
  2290.         /ENVELOPE \(/i,  @out     # Wee! ;-)
  2291.     ); 
  2292.     if ( $output =~ /\r\n$/ ) {
  2293.         eval { $bs = Mail::IMAPClient::BodyStructure::Envelope->new( $output )};  
  2294.     } else {
  2295.         $self->_debug("get_envelope: reassembling original response\n");
  2296.         my $start = 0;
  2297.         foreach my $o (@{$self->{"History"}{$self->Transaction}}) {
  2298.             next unless $self->_is_output_or_literal($o);
  2299.             $self->_debug("o->[DATA] is ".$o->[DATA]."\n");
  2300.             next unless $start or 
  2301.                 $o->[DATA] =~ /ENVELOPE \(/i and ++$start;      # Hi, vi! ;-)
  2302.             if ( length($output) and $self->_is_literal($o) ) {
  2303.                 my $data = $o->[DATA];
  2304.                 $data =~ s/"/\\"/g;
  2305.                 $data =~ s/\(/\\\(/g;
  2306.                 $data =~ s/\)/\\\)/g;
  2307.                 $output .= '"'.$data.'"';
  2308.             } else {
  2309.                 $output .= $o->[DATA] ;
  2310.             }
  2311.         }
  2312.         $self->_debug("get_envelope: reassembled output=$output<END>\n");
  2313.         eval { $bs = Mail::IMAPClient::BodyStructure->new( $output )};  
  2314.     }
  2315.     $self->_debug("get_envelope: msg $msg returns this ref: ". 
  2316.         ( $bs ? " $bs" : " UNDEF" ) 
  2317.         ."\n");
  2318.     return $bs;
  2319. }
  2320.  
  2321. =end obsolete
  2322.  
  2323. =cut
  2324.  
  2325.  
  2326. sub fetch {
  2327.  
  2328.     my $self = shift;
  2329.     my $what = shift||"ALL";
  2330.     #ref($what) and $what = join(",",@$what);    
  2331.     if ( $what eq 'ALL' ) {
  2332.         $what = $self->Range($self->messages );
  2333.     } elsif (ref($what) or $what =~ /^[,:\d]+\w*$/)  {
  2334.         $what = $self->Range($what);    
  2335.     }
  2336.     $self->_imap_command( ( $self->Uid ? "UID " : "" ) .
  2337.                 "FETCH $what" . ( @_ ? " " . join(" ",@_) : '' )
  2338.     )                          or return undef;
  2339.     return wantarray ?     $self->History($self->Count)     : 
  2340.                               [ map { $_->[DATA] } @{$self->{'History'}{$self->Count}} ];
  2341.  
  2342. }
  2343.  
  2344.  
  2345. sub fetch_hash {
  2346.     my $self = shift;
  2347.     my $hash = ref($_[-1]) ? pop @_ : {};
  2348.     my @words = @_;
  2349.     for (@words) { 
  2350.         s/([\( ])FAST([\) ])/${1}FLAGS INTERNALDATE RFC822\.SIZE$2/i  ;
  2351.         s/([\( ])FULL([\) ])/${1}FLAGS INTERNALDATE RFC822\.SIZE ENVELOPE BODY$2/i  ;
  2352.     }
  2353.     my $msgref = scalar($self->messages);
  2354.     my $output = scalar($self->fetch($msgref,"(" . join(" ",@_) . ")")) 
  2355.     ; #    unless grep(/\b(?:FAST|FULL)\b/i,@words);
  2356.     my $x;
  2357.     for ($x = 0;  $x <= $#$output ; $x++) {
  2358.         my $entry = {};
  2359.         my $l = $output->[$x];
  2360.         if ($self->Uid) {    
  2361.             my($uid) = $l =~ /\((?:.* )?UID (\d+).*\)/i;
  2362.             next unless $uid;
  2363.             if ( exists $hash->{$uid} ) {
  2364.                 $entry = $hash->{$uid} ;
  2365.             } else {
  2366.                 $hash->{$uid} ||= $entry;
  2367.             }
  2368.         } else {
  2369.             my($mid) = $l =~ /^\* (\d+) FETCH/i;
  2370.             next unless $mid;
  2371.             if ( exists $hash->{$mid} ) {
  2372.                 $entry = $hash->{$mid} ;
  2373.             } else {
  2374.                 $hash->{$mid} ||= $entry;
  2375.             }
  2376.         }
  2377.             
  2378.         foreach my $w (@words) {
  2379.            if ( $l =~ /\Q$w\E\s*$/i ) {
  2380.             $entry->{$w} = $output->[$x+1];
  2381.             $entry->{$w} =~ s/(?:\x0a?\x0d)+$//g;
  2382.             chomp $entry->{$w};
  2383.            } else {
  2384.             $l =~ /\(         # open paren followed by ... 
  2385.                 (?:.*\s)?   # ...optional stuff and a space
  2386.                 \Q$w\E\s    # escaped fetch field<sp>
  2387.                 (?:"        # then: a dbl-quote
  2388.                   (\\.|   # then bslashed anychar(s) or ...
  2389.                    [^"]+)   # ... nonquote char(s)
  2390.                 "|        # then closing quote; or ...
  2391.                 \(        # ...an open paren
  2392.                   (\\.|     # then bslashed anychar or ...
  2393.                    [^\)]+)  # ... non-close-paren char
  2394.                 \)|        # then closing paren; or ...
  2395.                 (\S+))        # unquoted string
  2396.                 (?:\s.*)?   # possibly followed by space-stuff
  2397.                 \)        # close paren
  2398.             /xi;
  2399.             $entry->{$w}=defined($1)?$1:defined($2)?$2:$3;
  2400.            }
  2401.         }
  2402.     }
  2403.     return wantarray ? %$hash : $hash;
  2404. }
  2405. sub AUTOLOAD {
  2406.  
  2407.     my $self = shift;
  2408.     return undef if $Mail::IMAPClient::AUTOLOAD =~ /DESTROY$/;
  2409.     delete $self->{Folders}  ;
  2410.     my $autoload = $Mail::IMAPClient::AUTOLOAD;
  2411.     $autoload =~ s/.*:://;
  2412.     if (    
  2413.             $^W
  2414.         and    $autoload =~ /^[a-z]+$/
  2415.         and    $autoload !~ 
  2416.                 /^    (?:
  2417.                         store     |
  2418.                         copy     |
  2419.                         subscribe|
  2420.                         create     |
  2421.                         delete     |
  2422.                         close     |
  2423.                         expunge
  2424.                     )$
  2425.                 /x 
  2426.     ) {
  2427.         carp     "$autoload is all lower-case. " .
  2428.             "May conflict with future methods. " .
  2429.             "Change method name to be mixed case or all upper case to ensure " .
  2430.             "upward compatability"
  2431.     }
  2432.     if (scalar(@_)) {
  2433.         my @a = @_;
  2434.         if (    
  2435.             $autoload =~ 
  2436.                 /^(?:subscribe|delete|myrights)$/i
  2437.         ) {
  2438.             $a[-1] = $self->Massage($a[-1]) ;
  2439.         } elsif (    
  2440.             $autoload =~ 
  2441.                 /^(?:create)$/i
  2442.         ) {
  2443.             $a[0] = $self->Massage($a[0]) ;
  2444.         } elsif (
  2445.             $autoload =~ /^(?:store|copy)$/i
  2446.         ) {
  2447.             $autoload = "UID $autoload"
  2448.                 if $self->Uid;
  2449.         } elsif (
  2450.             $autoload =~ /^(?:expunge)$/i and defined($_[0])
  2451.         ) {
  2452.             my $old;
  2453.             if ( $_[0] ne $self->Folder ) {
  2454.                 $old = $self->Folder; $self->select($_[0]); 
  2455.             }     
  2456.             my $succ = $self->_imap_command(qq/$autoload/) ;
  2457.             $self->select($old);
  2458.             return undef unless $succ;
  2459.             return wantarray ?     $self->History($self->Count)     : 
  2460.                                               map {$_->[DATA]}@{$self->{'History'}{$self->Count}}     ;
  2461.             
  2462.         }
  2463.         $self->_debug("Autoloading: $autoload " . ( @a ? join(" ",@a):"" ) ."\n" )
  2464.             if $self->Debug;
  2465.         return undef 
  2466.             unless $self->_imap_command(
  2467.                  qq/$autoload/ .  ( @a ? " " . join(" ",@a) : "" )
  2468.             )  ;
  2469.     } else {
  2470.         $self->Folder(undef) if $autoload =~ /^(?:close)/i ; 
  2471.         $self->_imap_command(qq/$autoload/) or return undef;
  2472.     }
  2473.     return wantarray ?     $self->History($self->Count)     : 
  2474.                               [map {$_->[DATA] } @{$self->{'History'}{$self->Count}}] ;
  2475.  
  2476. }
  2477.  
  2478. sub rename {
  2479.     my $self = shift;
  2480.     my ($from, $to) = @_;
  2481.     local($_);
  2482.     if ($from =~ /^"(.*)"$/) {
  2483.     $from = $1 unless $self->exists($from);
  2484.         $from =~ s/"/\\"/g;
  2485.     }
  2486.     if ($to =~ /^"(.*)"$/) {
  2487.     $to = $1 unless $self->exists($from) and $from =~ /^".*"$/;
  2488.         $to =~ s/"/\\"/g;
  2489.     }
  2490.     $self->_imap_command(qq(RENAME "$from" "$to")) or return undef;
  2491.     return $self;
  2492. }
  2493.  
  2494. sub status {
  2495.  
  2496.     my $self = shift;
  2497.     my $box = shift ;  
  2498.     return undef unless defined($box);
  2499.     $box = $self->Massage($box);
  2500.     my @pieces = @_;
  2501.     $self->_imap_command("STATUS $box (". (join(" ",@_)||'MESSAGES'). ")") or return undef;
  2502.     return wantarray ?     $self->History($self->Count)     : 
  2503.                               [map{$_->[DATA]}@{$self->{'History'}{$self->Count}}];
  2504.  
  2505. }
  2506.  
  2507.  
  2508. # Can take a list of messages now.
  2509. # If a single message, returns array or ref to array of flags
  2510. # If a ref to array of messages, returns a ref to hash of msgid => flag arr
  2511. # See parse_headers for more information
  2512. # 2000-03-22 Adrian Smith (adrian.smith@ucpag.com)
  2513.  
  2514. sub flags {
  2515.     my $self = shift;
  2516.     my $msgspec = shift;
  2517.     my $flagset = {};
  2518.     my $msg;
  2519.     my $u_f = $self->Uid;
  2520.  
  2521.     # Determine if set of messages or just one
  2522.     if (ref($msgspec) eq 'ARRAY' ) {
  2523.         $msg = $self->Range($msgspec) ;
  2524.     } elsif ( !ref($msgspec) )     {
  2525.         $msg = $msgspec;
  2526.         if ( scalar(@_) ) {
  2527.             $msgspec = $self->Range($msg) ;
  2528.             $msgspec += $_ for (@_);
  2529.             $msg = $msgspec;
  2530.         }
  2531.     } elsif ( ref($msgspec) =~ /MessageSet/ ) {
  2532.         if ( scalar(@_) ) {
  2533.             $msgspec += $_ for @_;
  2534.         }
  2535.     } else {
  2536.         $self->LastError("Invalid argument passed to fetch.\n");
  2537.         return undef;
  2538.     }
  2539.  
  2540.     # Send command
  2541.     unless ( $self->fetch($msg,"FLAGS") ) {
  2542.         return undef;
  2543.     }
  2544.  
  2545.     # Parse results, setting entry in result hash for each line
  2546.      foreach my $resultline ($self->Results) {
  2547.         $self->_debug("flags: line = '$resultline'\n") ;
  2548.         if (    $resultline =~ 
  2549.             /\*\s+(\d+)\s+FETCH\s+    # * nnn FETCH 
  2550.              \(            # open-paren
  2551.              (?:\s?UID\s(\d+)\s?)?    # optional: UID nnn <space>
  2552.              FLAGS\s?\((.*)\)\s?    # FLAGS (\Flag1 \Flag2) <space>
  2553.              (?:\s?UID\s(\d+))?    # optional: UID nnn
  2554.              \)             # close-paren
  2555.             /x
  2556.         ) {
  2557.             { local($^W=0);
  2558.              $self->_debug("flags: line = '$resultline' " .
  2559.                "and 1,2,3,4 = $1,$2,$3,$4\n") 
  2560.              if $self->Debug;
  2561.             }
  2562.             my $mailid = $u_f ? ( $2||$4) : $1;
  2563.             my $flagsString = $3 ;
  2564.             my @flags = map { s/\s+$//; $_ } split(/\s+/, $flagsString);
  2565.             $flagset->{$mailid} = \@flags;
  2566.         }
  2567.     }
  2568.  
  2569.     # Did the guy want just one response? Return it if so
  2570.     unless (ref($msgspec) ) {
  2571.         my $flagsref = $flagset->{$msgspec};
  2572.         return wantarray ? @$flagsref : $flagsref;
  2573.     }
  2574.  
  2575.     # Or did he want a hash from msgid to flag array?
  2576.     return $flagset;
  2577. }
  2578.  
  2579. # parse_headers modified to allow second param to also be a
  2580. # reference to a list of numbers. If this is a case, the headers
  2581. # are read from all the specified messages, and a reference to
  2582. # an hash of mail numbers to references to hashes, are returned.
  2583. # I found, with a mailbox of 300 messages, this was
  2584. # *significantly* faster against our mailserver (< 1 second
  2585. # vs. 20 seconds)
  2586. #
  2587. # 2000-03-22 Adrian Smith (adrian.smith@ucpag.com)
  2588.  
  2589. sub parse_headers {
  2590.     my($self,$msgspec,@fields) = @_;
  2591.     my(%fieldmap) = map { ( lc($_),$_ )  } @fields;
  2592.     my $msg; my $string; my $field;
  2593.  
  2594.     # Make $msg a comma separated list, of messages we want
  2595.         if (ref($msgspec) eq 'ARRAY') {
  2596.         #$msg = join(',', @$msgspec);
  2597.         $msg = $self->Range($msgspec);
  2598.     } else {
  2599.         $msg = $msgspec;
  2600.     }
  2601.  
  2602.     if ($fields[0]     =~     /^[Aa][Ll]{2}$/     ) { 
  2603.  
  2604.         $string =     "$msg body" . 
  2605.         # use ".peek" if Peek parameter is a) defined and true, 
  2606.         #     or b) undefined, but not if it's defined and untrue:
  2607.  
  2608.         (     defined($self->Peek)         ? 
  2609.             ( $self->Peek ? ".peek" : "" )     : 
  2610.             ".peek" 
  2611.         ) .  "[header]"             ; 
  2612.  
  2613.     } else {
  2614.         $string    =     "$msg body" .
  2615.         # use ".peek" if Peek parameter is a) defined and true, or 
  2616.         # b) undefined, but not if it's defined and untrue:
  2617.  
  2618.         ( defined($self->Peek)             ? 
  2619.             ( $self->Peek ? ".peek" : "" )     : 
  2620.             ".peek" 
  2621.         ) .  "[header.fields ("    . join(" ",@fields)     . ')]' ;
  2622.     }
  2623.  
  2624.     my @raw=$self->fetch(    $string    ) or return undef;
  2625.  
  2626.     my $headers = {};    # hash from message ids to header hash
  2627.     my $h = 0;        # reference to hash of current msgid, or 0 between msgs
  2628.     
  2629.         for my $header (map { split(/(?:\x0d\x0a)/,$_) } @raw) {
  2630.                 local($^W) = undef;
  2631.                 if ( $header =~ /^\*\s+\d+\s+FETCH\s+\(.*BODY\[HEADER(?:\]|\.FIELDS)/i) {
  2632.                         if ($self->Uid) {
  2633.                                 if ( my($msgid) = $header =~ /UID\s+(\d+)/ ) {
  2634.                                         $h = {};
  2635.                                         $headers->{$msgid} = $h;
  2636.                                 } else {
  2637.                                         $h = {};
  2638.                                 }
  2639.                         } else {
  2640.                                 if ( my($msgid) = $header =~ /^\*\s+(\d+)/ ) {
  2641.                                         #start of new message header:
  2642.                                         $h = {};
  2643.                                         $headers->{$msgid} = $h;
  2644.                                 }
  2645.                         }
  2646.                 }
  2647.                 next if $header =~ /^\s+$/;
  2648.  
  2649.                 # ( for vi
  2650.                 if ($header =~ /^\)/) {           # end of this message
  2651.                         $h = 0;                   # set to be between messages
  2652.                         next;
  2653.                 }
  2654.                 # check for '<optional_white_space>UID<white_space><UID_number><optional_white_space>)'
  2655.                 # when parsing headers by UID.
  2656.                 if ($self->Uid and my($msgid) = $header =~ /^\s*UID\s+(\d+)\s*\)/) {
  2657.                         $headers->{$msgid} = $h;        # store in results against this message
  2658.                         $h = 0;                     # set to be between messages
  2659.                         next;
  2660.                 }
  2661.  
  2662.         if ($h != 0) {              # do we expect this to be a header?
  2663.                        my $hdr = $header;
  2664.                        chomp $hdr;
  2665.                        $hdr =~ s/\r$//;   
  2666.                        if ($hdr =~ s/^(\S+):\s*//) { 
  2667.                                $field = exists $fieldmap{lc($1)} ? $fieldmap{lc($1)} : $1 ;
  2668.                                push @{$h->{$field}} , $hdr ;
  2669.                        } elsif ($hdr =~ s/^.*FETCH\s\(.*BODY\[HEADER\.FIELDS.*\)\]\s(\S+):\s*//) { 
  2670.                                $field = exists $fieldmap{lc($1)} ? $fieldmap{lc($1)} : $1 ;
  2671.                                push @{$h->{$field}} , $hdr ;
  2672.                        } elsif ( ref($h->{$field}) eq 'ARRAY') {
  2673.                     
  2674.                     $hdr =~ s/^\s+/ /;
  2675.                                    $h->{$field}[-1] .= $hdr ;
  2676.                        }
  2677.         }
  2678.     }
  2679.     my $candump = 0;
  2680.     if ($self->Debug) {
  2681.         eval {
  2682.             require Data::Dumper;
  2683.             Data::Dumper->import;
  2684.         };
  2685.         $candump++ unless $@;
  2686.     }
  2687.     # if we asked for one message, just return its hash,
  2688.     # otherwise, return hash of numbers => header hash
  2689.     # if (ref($msgspec) eq 'ARRAY') {
  2690.     if (ref($msgspec) ) {
  2691.         #_debug $self,"Structure from parse_headers:\n", 
  2692.         #    Dumper($headers) 
  2693.         #    if $self->Debug;
  2694.         return $headers;
  2695.     } else {
  2696.         #_debug $self, "Structure from parse_headers:\n", 
  2697.         #    Dumper($headers->{$msgspec}) 
  2698.         #    if $self->Debug;
  2699.         return $headers->{$msgspec};
  2700.     }
  2701. }
  2702.  
  2703. sub subject { return $_[0]->get_header($_[1],"Subject") }
  2704. sub date { return $_[0]->get_header($_[1],"Date") }
  2705. sub rfc822_header { get_header(@_) }
  2706.  
  2707. sub get_header {
  2708.     my($self , $msg, $header ) = @_;
  2709.     my $val = 0;
  2710.     eval { $val = $self->parse_headers($msg,$header)->{$header}[0] };
  2711.     return defined($val)? $val : undef;
  2712. }
  2713.  
  2714. sub recent_count {
  2715.     my ($self, $folder) = (shift, shift);
  2716.  
  2717.     $self->status($folder, 'RECENT') or return undef;
  2718.  
  2719.     chomp(my $r = ( grep { s/\*\s+STATUS\s+.*\(RECENT\s+(\d+)\s*\)/$1/ }
  2720.             $self->History($self->Transaction)
  2721.     )[0]);
  2722.  
  2723.     $r =~ s/\D//g;
  2724.  
  2725.     return $r;
  2726. }
  2727.  
  2728. sub message_count {
  2729.     
  2730.     my ($self, $folder) = (shift, shift);
  2731.     $folder ||= $self->Folder;
  2732.     
  2733.     $self->status($folder, 'MESSAGES') or return undef;
  2734.         foreach my $result  (@{$self->{"History"}{$self->Transaction}}) {
  2735.               return $1 if $result->[DATA] =~ /\(MESSAGES\s+(\d+)\s*\)/ ;
  2736.         }
  2737.  
  2738.     return undef;
  2739.  
  2740. }
  2741.  
  2742. {
  2743. for my $datum (
  2744.                 qw(     recent seen
  2745.                         unseen messages
  2746.                  )
  2747. ) {
  2748.         no strict 'refs';
  2749.         *$datum = sub {
  2750.         my $self = shift;
  2751.         #my @hits;
  2752.  
  2753.         #my $hits = $self->search($datum eq "messages" ? "ALL" : "$datum")
  2754.         #     or return undef;
  2755.         #print "Received $hits from search and array context flag is ",
  2756.         #    wantarry,"\n";
  2757.         #if ( scalar(@$hits) ) {
  2758.         #    return wantarray ? @$hits : $hits ;
  2759.         #}
  2760.         return $self->search($datum eq "messages" ? "ALL" : "$datum") ;
  2761.  
  2762.  
  2763.         };
  2764. }
  2765. }
  2766. {
  2767. for my $datum (
  2768.                 qw(     sentbefore     sentsince     senton
  2769.             since         before         on
  2770.                  )
  2771. ) {
  2772.     no strict 'refs';
  2773.     *$datum = sub {
  2774.  
  2775.         my($self,$time) = (shift,shift);
  2776.  
  2777.         my @hits; my $imapdate;
  2778.         my @mnt  =      qw{ Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec};
  2779.  
  2780.         if ( $time =~ /\d\d-\D\D\D-\d\d\d\d/ ) {
  2781.             $imapdate = $time;
  2782.         } elsif ( $time =~ /^\d+$/ ) {
  2783.             my @ltime = localtime($time);
  2784.             $imapdate = sprintf(    "%2.2d-%s-%4.4d", 
  2785.                         $ltime[3], $mnt[$ltime[4]], $ltime[5] + 1900);
  2786.         } else {
  2787.             $self->LastError("Invalid date format supplied to '$datum' method.");
  2788.             return undef;
  2789.         }
  2790.         $self->_imap_command( ($self->Uid ? "UID " : "") . "SEARCH $datum $imapdate")
  2791.             or return undef;
  2792.         my @results =  $self->History($self->Count)     ;
  2793.  
  2794.         for my $r (@results) {
  2795.  
  2796.                chomp $r;
  2797.                $r =~ s/\r$//;
  2798.                $r =~ s/^\*\s+SEARCH\s+//i or next;
  2799.                push @hits, grep(/\d/,(split(/\s+/,$r)));
  2800.             _debug $self, "Hits are now: ",join(',',@hits),"\n" if $self->Debug;
  2801.         }
  2802.  
  2803.         return wantarray ? @hits : \@hits;
  2804.     }
  2805. }
  2806. }
  2807.  
  2808. sub or {
  2809.  
  2810.     my $self = shift ;
  2811.     my @what = @_; 
  2812.     my @hits;
  2813.  
  2814.     if ( scalar(@what) < 2 ) {
  2815.         $self->LastError("Invalid number of arguments passed to or method.\n");
  2816.         return undef;
  2817.     }
  2818.  
  2819.     my $or = "OR " . $self->Massage(shift @what);
  2820.     $or .= " " . $self->Massage(shift @what);
  2821.         
  2822.  
  2823.     for my $w ( @what ) {
  2824.         my $w = $self->Massage($w) ;
  2825.         $or = "OR " . $or . " " . $w ;
  2826.     }
  2827.  
  2828.     $self->_imap_command( ($self->Uid ? "UID " : "") . "SEARCH $or")
  2829.         or return undef;
  2830.     my @results =  $self->History($self->Count)     ;
  2831.  
  2832.     for my $r (@results) {
  2833.  
  2834.            chomp $r;
  2835.            $r =~ s/\r$//;
  2836.            $r =~ s/^\*\s+SEARCH\s+//i or next;
  2837.            push @hits, grep(/\d/,(split(/\s+/,$r)));
  2838.         _debug $self, "Hits are now: ",join(',',@hits),"\n" 
  2839.                 if $self->Debug;
  2840.     }
  2841.  
  2842.     return wantarray ? @hits : \@hits;
  2843. }
  2844.  
  2845. #sub Strip_cr {
  2846. #    my $self = shift;
  2847.  
  2848. #    my $in = $_[0]||$self ;
  2849.  
  2850. #    $in =~ s/\r//g  ;
  2851.  
  2852. #    return $in;
  2853. #}
  2854.  
  2855.  
  2856. sub disconnect { $_[0]->logout }
  2857.  
  2858.  
  2859. sub search {
  2860.  
  2861.     my $self = shift;
  2862.     my @hits;
  2863.     my @a = @_;
  2864.     $@ = "";
  2865.     # massage?
  2866.     $a[-1] = $self->Massage($a[-1],1) 
  2867.         if scalar(@a) > 1 and !exists($SEARCH_KEYS{uc($a[-1])}); 
  2868.     $self->_imap_command( ( $self->Uid ? "UID " : "" ) . "SEARCH ". join(' ',@a)) 
  2869.              or return undef;
  2870.     my $results =  $self->History($self->Count) ;
  2871.  
  2872.  
  2873.     for my $r (@$results) {
  2874.     #$self->_debug("Considering the search result line: $r");            
  2875.                chomp $r;
  2876.                $r =~ s/\r\n?/ /g;
  2877.                $r =~ s/^\*\s+SEARCH\s+(?=.*\d.*)// or next;
  2878.                my @h = grep(/^\d+$/,(split(/\s+/,$r)));
  2879.            push @hits, @h if scalar(@h) ; # and grep(/\d/,@h) );
  2880.  
  2881.     }
  2882.  
  2883.     $self->{LastError}="Search completed successfully but found no matching messages\n"
  2884.         unless scalar(@hits);
  2885.  
  2886.     if ( wantarray ) {
  2887.         return @hits;
  2888.     } else {
  2889.         if ($self->Ranges) {
  2890.             #print STDERR "Fetch: Returning range\n";
  2891.             return scalar(@hits) ? $self->Range(\@hits) : undef;
  2892.         } else {
  2893.             #print STDERR "Fetch: Returning ref\n";
  2894.             return scalar(@hits) ? \@hits : undef;
  2895.         }
  2896.     }
  2897. }
  2898.  
  2899. sub thread {
  2900.     # returns a Thread data structure
  2901.     #
  2902.     # $imap->thread($algorythm, $charset, @search_args);
  2903.     my $self = shift;
  2904.  
  2905.     my $algorythm     = shift;
  2906.        $algorythm   ||= $self->has_capability("THREAD=REFERENCES") ? "REFERENCES" : "ORDEREDSUBJECT";
  2907.     my $charset       = shift;
  2908.        $charset     ||= "UTF-8";
  2909.  
  2910.     my @a = @_;
  2911.  
  2912.     $a[0]||="ALL" ;
  2913.     my @hits;
  2914.     # massage?
  2915.  
  2916.     $a[-1] = $self->Massage($a[-1],1) 
  2917.         if scalar(@a) > 1 and !exists($SEARCH_KEYS{uc($a[-1])}); 
  2918.     $self->_imap_command( ( $self->Uid ? "UID " : "" ) . 
  2919.                 "THREAD $algorythm $charset " . 
  2920.                 join(' ',@a)
  2921.     ) or return undef;
  2922.     my $results =  $self->History($self->Count) ;
  2923.  
  2924.     my $thread = "";
  2925.     for my $r (@$results) {
  2926.         #$self->_debug("Considering the search result line: $r");            
  2927.                    chomp $r;
  2928.                    $r =~ s/\r\n?/ /g;
  2929.                    if ( $r =~ /^\*\s+THREAD\s+/ ) {
  2930.             eval { require "Mail/IMAPClient/Thread.pm" }
  2931.                 or ( $self->LastError($@), return undef);
  2932.             my $parser = Mail::IMAPClient::Thread->new();
  2933.             $thread = $parser->start($r) ;
  2934.         } else {
  2935.             next;
  2936.         }
  2937.                #while ( $r =~ /(\([^\)]*\))/ ) { 
  2938.         #    push @hits, [ split(/ /,$1) ] ;
  2939.         #}
  2940.     }
  2941.  
  2942.     $self->{LastError}="Thread search completed successfully but found no matching messages\n"
  2943.         unless ref($thread);
  2944.     return $thread ||undef;
  2945.  
  2946.     if ( wantarray ) {
  2947.  
  2948.         return @hits;
  2949.     } else {
  2950.         return scalar(@hits) ? \@hits : undef;
  2951.     }
  2952. }
  2953.  
  2954.  
  2955.  
  2956.  
  2957. sub delete_message {
  2958.  
  2959.     my $self = shift;
  2960.     my $count = 0;
  2961.     my @msgs = ();
  2962.     for my $arg (@_) {
  2963.         if (ref($arg) eq 'ARRAY') {
  2964.             push @msgs, @{$arg};
  2965.         } else {
  2966.             push @msgs, split(/\,/,$arg);
  2967.         }
  2968.     }
  2969.     
  2970.  
  2971.     $self->store(join(',',@msgs),'+FLAGS.SILENT','(\Deleted)') and $count = scalar(@msgs);
  2972.  
  2973.     return $count;
  2974. }
  2975.  
  2976. sub restore_message {
  2977.  
  2978.     my $self = shift;
  2979.     my @msgs = ();
  2980.     for my $arg (@_) {
  2981.         if (ref($arg) eq 'ARRAY') {
  2982.             push @msgs, @{$arg};
  2983.         } else {
  2984.             push @msgs, split(/\,/,$arg);
  2985.         }
  2986.     }
  2987.     
  2988.  
  2989.     $self->store(join(',',@msgs),'-FLAGS','(\Deleted)') ;
  2990.     my $count = grep(
  2991.             /
  2992.                 ^\*            # Start with an asterisk
  2993.                 \s\d+            # then a space then a number
  2994.                 \sFETCH            # then a space then the string 'FETCH'
  2995.                 \s\(            # then a space then an open paren :-) 
  2996.                 .*            # plus optional anything
  2997.                 FLAGS            # then the string "FLAGS"
  2998.                 .*            # plus anything else
  2999.                 (?!\\Deleted)        # but never "\Deleted"
  3000.             /x,
  3001.             $self->Results
  3002.     );
  3003.     
  3004.  
  3005.     return $count;
  3006. }
  3007.  
  3008.  
  3009. sub uidvalidity {
  3010.  
  3011.     my $self = shift; my $folder = shift;
  3012.  
  3013.     my $vline = (grep(/UIDVALIDITY/i, $self->status($folder, "UIDVALIDITY")))[0];
  3014.  
  3015.     my($validity) = $vline =~ /\(UIDVALIDITY\s+([^\)]+)/;
  3016.  
  3017.     return $validity;
  3018. }
  3019.  
  3020. # 3 status folder (uidnext)
  3021. # * STATUS folder (UIDNEXT 290)
  3022.  
  3023. sub uidnext {
  3024.  
  3025.     my $self = shift; my $folder = $self->Massage(shift);
  3026.  
  3027.     my $line = (grep(/UIDNEXT/i, $self->status($folder, "UIDNEXT")))[0];
  3028.  
  3029.     my($uidnext) = $line =~ /\(UIDNEXT\s+([^\)]+)/;
  3030.  
  3031.     return $uidnext;
  3032. }
  3033.  
  3034. sub capability {
  3035.  
  3036.     my $self = shift;
  3037.  
  3038.     $self->_imap_command('CAPABILITY') or return undef;
  3039.  
  3040.     my @caps = ref($self->{CAPABILITY})         ? 
  3041.             keys %{$self->{CAPABILITY}}     : 
  3042.             map { split } 
  3043.                 grep (s/^\*\s+CAPABILITY\s+//, 
  3044.                 $self->History($self->Count));
  3045.  
  3046.     unless ( exists $self->{CAPABILITY} ) { 
  3047.         for (@caps) { 
  3048.             $self->{CAPABILITY}{uc($_)}++ ;
  3049.             if (/=/) {
  3050.                 my($k,$v)=split(/=/,$_) ;
  3051.                 $self->{uc($k)} = uc($v) ;
  3052.             }
  3053.         } 
  3054.     }
  3055.     
  3056.  
  3057.     return wantarray ? @caps : \@caps;
  3058. }
  3059.  
  3060. sub has_capability {
  3061.     my $self = shift;
  3062.     $self->capability;
  3063.     local($^W)=0;
  3064.     return $self->{CAPABILITY}{uc($_[0])};
  3065. }
  3066.  
  3067. sub imap4rev1 {
  3068.     my $self = shift;
  3069.     return exists($self->{_IMAP4REV1}) ?  
  3070.         $self->{_IMAP4REV1} : 
  3071.         $self->{_IMAP4REV1} = $self->has_capability(IMAP4REV1) ;
  3072. }
  3073.  
  3074. sub namespace {
  3075.     # Returns a (reference to a?) nested list as follows:
  3076.     # [ 
  3077.     #  [
  3078.     #   [ $user_prefix,  $user_delim  ] (,[$user_prefix2  ,$user_delim  ], [etc,etc] ),
  3079.     #  ],
  3080.     #  [
  3081.     #   [ $shared_prefix,$shared_delim] (,[$shared_prefix2,$shared_delim], [etc,etc] ),
  3082.     #  ],
  3083.     #  [
  3084.     #   [$public_prefix, $public_delim] (,[$public_prefix2,$public_delim], [etc,etc] ),
  3085.     #  ],
  3086.     # ] ;
  3087.         
  3088.     my $self = shift;
  3089.     unless ( $self->has_capability("NAMESPACE") ) {
  3090.             my $error = $self->Count . " NO NAMESPACE not supported by " . $self->Server ;
  3091.             $self->LastError("$error\n") ;
  3092.             $self->_debug("$error\n") ;
  3093.             $@ = $error;
  3094.             carp "$@" if $^W;
  3095.             return undef;
  3096.     }
  3097.     my $namespace = (map({ /^\* NAMESPACE (.*)/ ? $1 : () } @{$self->_imap_command("NAMESPACE")->Results}))[0] ;
  3098.     $namespace =~ s/\x0d?\x0a$//;
  3099.     my($personal,$shared,$public) = $namespace =~ m#
  3100.         (NIL|\((?:\([^\)]+\)\s*)+\))\s
  3101.         (NIL|\((?:\([^\)]+\)\s*)+\))\s
  3102.         (NIL|\((?:\([^\)]+\)\s*)+\))
  3103.     #xi;
  3104.     
  3105.     my @ns = ();
  3106.     $self->_debug("NAMESPACE: pers=$personal, shared=$shared, pub=$public\n");
  3107.     push @ns, map {
  3108.         $_ =~ s/^\((.*)\)$/$1/;
  3109.         my @pieces = m#\(([^\)]*)\)#g;
  3110.         $self->_debug("NAMESPACE pieces: " . join(", ",@pieces) . "\n");
  3111.         my $ref = [];
  3112.         foreach my $atom (@pieces) {
  3113.             push @$ref, [ $atom =~ m#"([^"]*)"\s*#g ] ;
  3114.         }
  3115.         $_ =~ /^NIL$/i ? undef : $ref;
  3116.     } ( $personal, $shared, $public) ;
  3117.     return wantarray ? @ns : \@ns;
  3118. }
  3119.  
  3120. # Contributed by jwm3
  3121. sub internaldate {
  3122.         my $self = shift;
  3123.         my $msg  = shift;
  3124.         $self->_imap_command( ( $self->Uid ? "UID " : "" ) . "FETCH $msg INTERNALDATE") or return undef;
  3125.         my $internalDate = join("", $self->History($self->Count));
  3126.         $internalDate =~ s/^.*INTERNALDATE "//si;
  3127.         $internalDate =~ s/\".*$//s;
  3128.         return $internalDate;
  3129. }
  3130.  
  3131. sub is_parent {
  3132.     my ($self, $folder) = (shift, shift);
  3133.     # $self->_debug("Checking parentage ".( $folder ? "for folder $folder" : "" )."\n");
  3134.         my $list = $self->list(undef, $folder)||"NO NO BAD BAD";
  3135.     my $line = '';
  3136.  
  3137.         for (my $m = 0; $m < scalar(@$list); $m++ ) {
  3138.         #$self->_debug("Judging whether or not $list->[$m] is fit for parenthood\n");
  3139.         return undef 
  3140.           if $list->[$m] =~ /NoInferior/i;       # let's not beat around the bush!
  3141.  
  3142.                 if ($list->[$m]  =~ s/(\{\d+\})\x0d\x0a$// ) {
  3143.                         $list->[$m] .= $list->[$m+1];
  3144.                         $list->[$m+1] = "";
  3145.                 }
  3146.  
  3147.             $line = $list->[$m]
  3148.                         if $list->[$m] =~
  3149.                         /       ^\*\s+LIST              # * LIST
  3150.                                 \s+\([^\)]*\)\s+            # (Flags)
  3151.                                 "[^"]*"\s+              # "delimiter"
  3152.                                 (?:"([^"]*)"|(.*))\x0d\x0a$  # Name or "Folder name"
  3153.                         /x;
  3154.     }    
  3155.     if ( $line eq "" ) {
  3156.         $self->_debug("Warning: separator method found no correct o/p in:\n\t" .
  3157.             join("\t",@list)."\n");
  3158.     }
  3159.     my($f) = $line =~ /^\*\s+LIST\s+\(([^\)]*)\s*\)/ if $line;
  3160.     return  1 if $f =~ /HasChildren/i ;
  3161.     return 0 if $f =~ /HasNoChildren/i ;
  3162.     unless ( $f =~ /\\/) {        # no flags at all unless there's a backslash
  3163.         my $sep = $self->separator($folder);
  3164.         return 1 if scalar(grep /^${folder}${sep}/, $self->folders);
  3165.         return 0;
  3166.     }
  3167. }
  3168.  
  3169. sub selectable {my($s,$f)=@_;return grep(/NoSelect/i,$s->list("",$f))?0:1;}
  3170.  
  3171. sub append_string {
  3172.  
  3173.         my $self = shift;
  3174.         my $folder = $self->Massage(shift);
  3175.  
  3176.     my $text = shift;
  3177.     $text =~ s/\x0d?\x0a/\x0d\x0a/g;
  3178.  
  3179.     my($flags,$date) = (shift,shift);
  3180.  
  3181.     if (defined($flags)) {
  3182.         $flags =~ s/^\s+//g;
  3183.         $flags =~ s/\s+$//g;
  3184.     }
  3185.  
  3186.     if (defined($date)) {
  3187.         $date =~ s/^\s+//g;
  3188.         $date =~ s/\s+$//g;
  3189.     }
  3190.  
  3191.     $flags = "($flags)"  if $flags and $flags !~ /^\(.*\)$/ ;
  3192.     $date  = qq/"$date"/ if $date  and $date  !~ /^"/     ;
  3193.  
  3194.         my $clear = $self->Clear;
  3195.  
  3196.         $self->Clear($clear)
  3197.                 if $self->Count >= $clear and $clear > 0;
  3198.  
  3199.     my $count     = $self->Count($self->Count+1);
  3200.  
  3201.         my $string =       "$count APPEND $folder "        . 
  3202.             ( $flags ? "$flags " : ""     ) . 
  3203.             ( $date ? "$date " : ""     ) . 
  3204.             "{" . length($text)  . "}\x0d\x0a" ;
  3205.  
  3206.         $self->_record($count,[ $self->_next_index($count), "INPUT", "$string\x0d\x0a" ] );
  3207.  
  3208.     # Step 1: Send the append command.
  3209.  
  3210.     my $feedback = $self->_send_line("$string");
  3211.  
  3212.     unless ($feedback) {
  3213.         $self->LastError("Error sending '$string' to IMAP: $!\n");
  3214.         return undef;
  3215.     }
  3216.  
  3217.     my ($code, $output) = ("","");    
  3218.     
  3219.     # Step 2: Get the "+ go ahead" response
  3220.     until ( $code ) {
  3221.         $output = $self->_read_line or return undef;    
  3222.         foreach my $o (@$output) { 
  3223.  
  3224.             $self->_record($count,$o);    # $o is already an array ref
  3225.             next unless $self->_is_output($o);
  3226.  
  3227.                       ($code) = $o->[DATA] =~ /(^\+|^\d*\s*NO|^\d*\s*BAD)/i ;
  3228.  
  3229.                       if ($o->[DATA] =~ /^\*\s+BYE/i) {
  3230.                               $self->LastError("Error trying to append string: " . 
  3231.                         $o->[DATA]. "; Disconnected.\n");
  3232.                               $self->_debug("Error trying to append string: " . $o->[DATA]. 
  3233.                     "; Disconnected.\n");
  3234.                               carp("Error trying to append string: " . $o->[DATA] ."; Disconnected") if $^W;
  3235.                 $self->State(Unconnected);
  3236.  
  3237.                       } elsif ( $o->[DATA] =~ /^\d*\s*(NO|BAD)/i ) { # i and / transposed!!!
  3238.                               $self->LastError("Error trying to append string: " . $o->[DATA]  . "\n");
  3239.                               $self->_debug("Error trying to append string: " . $o->[DATA] . "\n");
  3240.                               carp("Error trying to append string: " . $o->[DATA]) if $^W;
  3241.                 return undef;
  3242.             }
  3243.         }
  3244.     }    
  3245.     
  3246.     $self->_record($count,[ $self->_next_index($count), "INPUT", "$text\x0d\x0a" ] );
  3247.  
  3248.     # Step 3: Send the actual text of the message:
  3249.         $feedback = $self->_send_line("$text\x0d\x0a");
  3250.  
  3251.         unless ($feedback) {
  3252.                 $self->LastError("Error sending append msg text to IMAP: $!\n");
  3253.                 return undef;
  3254.         }
  3255.     $code = undef;            # clear out code
  3256.  
  3257.     # Step 4: Figure out the results:
  3258.         until ($code) {
  3259.                 $output = $self->_read_line or return undef;
  3260.               $self->_debug("Append results: " . map({ $_->[DATA] } @$output) . "\n" )
  3261.             if $self->Debug;
  3262.                 foreach my $o (@$output) {
  3263.             $self->_record($count,$o); # $o is already an array ref
  3264.  
  3265.                       ($code) = $o->[DATA] =~ /^(?:$count|\*) (OK|NO|BAD)/im  ;
  3266.             
  3267.                       if ($o->[DATA] =~ /^\*\s+BYE/im) {
  3268.                 $self->State(Unconnected);
  3269.                               $self->LastError("Error trying to append: " . $o->[DATA] . "\n");
  3270.                               $self->_debug("Error trying to append: " . $o->[DATA] . "\n");
  3271.                               carp("Error trying to append: " . $o->[DATA] ) if $^W;
  3272.             }
  3273.             if ($code and $code !~ /^OK/im) {
  3274.                               $self->LastError("Error trying to append: " . $o->[DATA] . "\n");
  3275.                               $self->_debug("Error trying to append: " . $o->[DATA] . "\n");
  3276.                               carp("Error trying to append: " . $o->[DATA] ) if $^W;
  3277.                 return undef;
  3278.             }
  3279.             }
  3280.     }
  3281.  
  3282.       my($uid) = join("",map { $_->[TYPE] eq "OUTPUT" ? $_->[DATA] : () } @$output ) =~ m#\s+(\d+)\]#;
  3283.  
  3284.         return defined($uid) ? $uid : $self;
  3285. }
  3286. sub append {
  3287.  
  3288.         my $self = shift;
  3289.     # now that we're passing thru to append_string we won't massage here
  3290.         # my $folder = $self->Massage(shift); 
  3291.         my $folder = shift;
  3292.  
  3293.     my $text = join("\x0d\x0a",@_);
  3294.     $text =~ s/\x0d?\x0a/\x0d\x0a/g;
  3295.     return $self->append_string($folder,$text);
  3296. }
  3297.  
  3298. sub append_file {
  3299.  
  3300.         my $self     = shift;
  3301.         my $folder     = $self->Massage(shift);
  3302.     my $file     = shift; 
  3303.     my $control     = shift || undef;
  3304.     my $count     = $self->Count($self->Count+1);
  3305.  
  3306.  
  3307.     unless ( -f $file ) {
  3308.         $self->LastError("File $file not found.\n");
  3309.         return undef;
  3310.     }
  3311.  
  3312.     my $fh = IO::File->new($file) ;
  3313.  
  3314.     unless ($fh) {
  3315.         $self->LastError("Unable to open $file: $!\n");
  3316.         $@ = "Unable to open $file: $!" ;
  3317.         carp "unable to open $file: $!" if $^W;
  3318.         return undef;
  3319.     }
  3320.  
  3321.     my $bare_nl_count = scalar grep { /^\x0a$|[^\x0d]\x0a$/} <$fh>;
  3322.  
  3323.     seek($fh,0,0);
  3324.     
  3325.         my $clear = $self->Clear;
  3326.  
  3327.         $self->Clear($clear)
  3328.                 if $self->Count >= $clear and $clear > 0;
  3329.  
  3330.     my $length = ( -s $file ) + $bare_nl_count;
  3331.  
  3332.         my $string = "$count APPEND $folder {" . $length  . "}\x0d\x0a" ;
  3333.  
  3334.         $self->_record($count,[ $self->_next_index($count), "INPUT", "$string" ] );
  3335.  
  3336.     my $feedback = $self->_send_line("$string");
  3337.  
  3338.     unless ($feedback) {
  3339.         $self->LastError("Error sending '$string' to IMAP: $!\n");
  3340.         close $fh;
  3341.         return undef;
  3342.     }
  3343.  
  3344.     my ($code, $output) = ("","");    
  3345.     
  3346.     until ( $code ) {
  3347.         $output = $self->_read_line or close $fh, return undef;    
  3348.         foreach my $o (@$output) {
  3349.             $self->_record($count,$o);        # $o is already an array ref
  3350.                       ($code) = $o->[DATA] =~ /(^\+|^\d+\sNO|^\d+\sBAD)/i; 
  3351.                       if ($o->[DATA] =~ /^\*\s+BYE/) {
  3352.                               carp $o->[DATA] if $^W;
  3353.                 $self->State(Unconnected);
  3354.                 close $fh;
  3355.                 return undef ;
  3356.                       } elsif ( $o->[DATA]=~ /^\d+\s+(NO|BAD)/i ) {
  3357.                               carp $o->[DATA] if $^W;
  3358.                 close $fh;
  3359.                 return undef;
  3360.             }
  3361.         }
  3362.     }    
  3363.     
  3364.     {     # Narrow scope
  3365.         # Slurp up headers: later we'll make this more efficient I guess
  3366.         local $/ = "\x0d\x0a\x0d\x0a"; 
  3367.         my $text = <$fh>;
  3368.         $text =~ s/\x0d?\x0a/\x0d\x0a/g;
  3369.         $self->_record($count,[ $self->_next_index($count), "INPUT", "{From file $file}" ] ) ;
  3370.         $feedback = $self->_send_line($text);
  3371.  
  3372.         unless ($feedback) {
  3373.             $self->LastError("Error sending append msg text to IMAP: $!\n");
  3374.             close $fh;
  3375.             return undef;
  3376.         }
  3377.         _debug $self, "control points to $$control\n" if ref($control) and $self->Debug;
  3378.         $/ =     ref($control) ?  "\x0a" : $control ? $control :     "\x0a";    
  3379.         while (defined($text = <$fh>)) {
  3380.             $text =~ s/\x0d?\x0a/\x0d\x0a/g;
  3381.             $self->_record(    $count,
  3382.                     [ $self->_next_index($count), "INPUT", "{from $file}\x0d\x0a" ] 
  3383.             );
  3384.             $feedback = $self->_send_line($text,1);
  3385.  
  3386.             unless ($feedback) {
  3387.                 $self->LastError("Error sending append msg text to IMAP: $!\n");
  3388.                 close $fh;
  3389.                 return undef;
  3390.             }
  3391.         }
  3392.         $feedback = $self->_send_line("\x0d\x0a");
  3393.  
  3394.         unless ($feedback) {
  3395.             $self->LastError("Error sending append msg text to IMAP: $!\n");
  3396.             close $fh;
  3397.             return undef;
  3398.         }
  3399.     } 
  3400.  
  3401.     # Now for the crucial test: Did the append work or not?
  3402.     ($code, $output) = ("","");    
  3403.  
  3404.     my $uid = undef;    
  3405.     until ( $code ) {
  3406.         $output = $self->_read_line or return undef;    
  3407.         foreach my $o (@$output) {
  3408.             $self->_record($count,$o);        # $o is already an array ref
  3409.                       $self->_debug("append_file: Deciding if " . $o->[DATA] . " has the code.\n") 
  3410.                 if $self->Debug;
  3411.                       ($code) = $o->[DATA]  =~ /^\d+\s(NO|BAD|OK)/i; 
  3412.             # try to grab new msg's uid from o/p
  3413.                       $o->[DATA]  =~ m#UID\s+\d+\s+(\d+)\]# and $uid = $1; 
  3414.                       if ($o->[DATA] =~ /^\*\s+BYE/) {
  3415.                               carp $o->[DATA] if $^W;
  3416.                 $self->State(Unconnected);
  3417.                 close $fh;
  3418.                 return undef ;
  3419.                       } elsif ( $o->[DATA]=~ /^\d+\s+(NO|BAD)/i ) {
  3420.                               carp $o->[DATA] if $^W;
  3421.                 close $fh;
  3422.                 return undef;
  3423.             }
  3424.         }
  3425.     }    
  3426.     close $fh;
  3427.  
  3428.     if ($code !~ /^OK/i) {
  3429.         return undef;
  3430.     }
  3431.  
  3432.  
  3433.         return defined($uid) ? $uid : $self;
  3434. }
  3435.  
  3436.  
  3437. sub authenticate {
  3438.  
  3439.         my $self     = shift;
  3440.         my $scheme     = shift;
  3441.         my $response     = shift;
  3442.     
  3443.     $scheme   ||= $self->Authmechanism;
  3444.     $response ||= $self->Authcallback;
  3445.         my $clear = $self->Clear;
  3446.  
  3447.         $self->Clear($clear)
  3448.                 if $self->Count >= $clear and $clear > 0;
  3449.  
  3450.     my $count     = $self->Count($self->Count+1);
  3451.  
  3452.  
  3453.         my $string = "$count AUTHENTICATE $scheme";
  3454.  
  3455.         $self->_record($count,[ $self->_next_index($self->Transaction), 
  3456.                 "INPUT", "$string\x0d\x0a"] );
  3457.  
  3458.     my $feedback = $self->_send_line("$string");
  3459.  
  3460.     unless ($feedback) {
  3461.         $self->LastError("Error sending '$string' to IMAP: $!\n");
  3462.         return undef;
  3463.     }
  3464.  
  3465.     my ($code, $output);    
  3466.     
  3467.     until ($code) {
  3468.         $output = $self->_read_line or return undef;    
  3469.         foreach my $o (@$output) {
  3470.             $self->_record($count,$o);    # $o is a ref
  3471.             ($code) = $o->[DATA] =~ /^\+(.*)$/ ;
  3472.             if ($o->[DATA] =~ /^\*\s+BYE/) {
  3473.                 $self->State(Unconnected);
  3474.                 return undef ;
  3475.             }
  3476.         }
  3477.     }    
  3478.     
  3479.         return undef if $code =~ /^BAD|^NO/ ;
  3480.  
  3481.         if ('CRAM-MD5' eq $scheme && ! $response) {
  3482.           if ($Mail::IMAPClient::_CRAM_MD5_ERR) {
  3483.             $self->LastError($Mail::IMAPClient::_CRAM_MD5_ERR);
  3484.             carp $Mail::IMAPClient::_CRAM_MD5_ERR if $^W;
  3485.           } else {
  3486.             $response = \&_cram_md5;
  3487.           }
  3488.         }
  3489.  
  3490.         $feedback = $self->_send_line($response->($code, $self));
  3491.  
  3492.         unless ($feedback) {
  3493.                 $self->LastError("Error sending append msg text to IMAP: $!\n");
  3494.                 return undef;
  3495.         }
  3496.  
  3497.     $code = "";     # clear code
  3498.         until ($code) {
  3499.                 $output = $self->_read_line or return undef;
  3500.         foreach my $o (@$output) {
  3501.                     $self->_record($count,$o);    # $o is a ref
  3502.             if ( ($code) = $o->[DATA] =~ /^\+ (.*)$/ ) {
  3503.                 $feedback = $self->_send_line($response->($code,$self));
  3504.                 unless ($feedback) {
  3505.                     $self->LastError("Error sending append msg text to IMAP: $!\n");
  3506.                     return undef;
  3507.                 }
  3508.                 $code = "" ;        # Clear code; we're still not finished
  3509.             } else {
  3510.                 $o->[DATA] =~ /^$count (OK|NO|BAD)/ and $code = $1;
  3511.                 if ($o->[DATA] =~ /^\*\s+BYE/) {
  3512.                     $self->State(Unconnected);
  3513.                     return undef ;
  3514.                 }
  3515.             }
  3516.         }
  3517.         }
  3518.  
  3519.         $code =~ /^OK/ and $self->State(Authenticated) ;
  3520.         return $code =~ /^OK/ ? $self : undef ;
  3521.  
  3522. }
  3523.  
  3524. # UIDPLUS response from a copy: [COPYUID (uidvalidity) (origuid) (newuid)]
  3525. sub copy {
  3526.  
  3527.     my($self, $target, @msgs) = @_;
  3528.  
  3529.     $target = $self->Massage($target);
  3530.     if ( $self->Ranges ) {
  3531.         @msgs = ($self->Range(@msgs));
  3532.     } else {
  3533.         @msgs   = sort { $a <=> $b } map { ref($_)? @$_ : split(',',$_) } @msgs;
  3534.     }
  3535.  
  3536.     $self->_imap_command( 
  3537.       (     $self->Uid ? "UID " : "" ) . 
  3538.         "COPY " . 
  3539.         ( $self->Ranges ? $self->Range(@msgs) : 
  3540.         join(',',map { ref($_)? @$_ : $_ } @msgs)) . 
  3541.         " $target"
  3542.     )             or return undef        ;
  3543.     my @results =  $self->History($self->Count)     ;
  3544.     
  3545.     my @uids;
  3546.  
  3547.     for my $r (@results) {
  3548.             
  3549.                chomp $r;
  3550.                $r =~ s/\r$//;
  3551.                $r =~ s/^.*\[COPYUID\s+\d+\s+[\d:,]+\s+([\d:,]+)\].*/$1/ or next;
  3552.                push @uids, ( $r =~ /(\d+):(\d+)/ ? $1 ... $2 : split(/,/,$r) ) ;
  3553.  
  3554.     }
  3555.  
  3556.     return scalar(@uids) ? join(",",@uids) : $self;
  3557. }
  3558.  
  3559. sub move {
  3560.  
  3561.     my($self, $target, @msgs) = @_;
  3562.  
  3563.     $self->create($target) and $self->subscribe($target) 
  3564.         unless $self->exists($target);
  3565.     
  3566.     my $uids = $self->copy($target, map { ref($_) =~ /ARRAY/ ? @{$_} : $_ } @msgs) 
  3567.         or return undef;
  3568.  
  3569.     $self->delete_message(@msgs) or carp $self->LastError;
  3570.     
  3571.     return $uids;
  3572. }
  3573.  
  3574. sub set_flag {
  3575.     my($self, $flag, @msgs) = @_;
  3576.     if ( ref($msgs[0]) =~ /ARRAY/ ) { @msgs = @{$msgs[0]} };
  3577.     $flag =~ /^\\/ or $flag = "\\" . $flag 
  3578.         if $flag =~ /^(Answered|Flagged|Deleted|Seen|Draft)$/i;
  3579.     if ( $self->Ranges ) {
  3580.         $self->store( $self->Range(@msgs), "+FLAGS.SILENT (" . $flag . ")" );
  3581.     } else {
  3582.         $self->store( join(",",@msgs), "+FLAGS.SILENT (" . $flag . ")" );
  3583.     }
  3584. }
  3585.  
  3586. sub see {
  3587.     my($self, @msgs) = @_;
  3588.     if ( ref($msgs[0]) =~ /ARRAY/ ) { @msgs = @{$msgs[0]} };
  3589.     $self->set_flag('\\Seen', @msgs);
  3590. }
  3591.  
  3592. sub mark {
  3593.     my($self, @msgs) = @_;
  3594.     if ( ref($msgs[0]) =~ /ARRAY/ ) { @msgs = @{$msgs[0]} };
  3595.     $self->set_flag('\\Flagged', @msgs);
  3596. }
  3597.  
  3598. sub unmark {
  3599.     my($self, @msgs) = @_;
  3600.     if ( ref($msgs[0]) =~ /ARRAY/ ) { @msgs = @{$msgs[0]} };
  3601.     $self->unset_flag('\\Flagged', @msgs);
  3602. }
  3603.  
  3604. sub unset_flag {
  3605.     my($self, $flag, @msgs) = @_;
  3606.     if ( ref($msgs[0]) =~ /ARRAY/ ) { @msgs = @{$msgs[0]} };
  3607.     $flag =~ /^\\/ or $flag = "\\" . $flag 
  3608.         if $flag =~ /^(Answered|Flagged|Deleted|Seen|Draft)$/i;
  3609.     $self->store( join(",",@msgs), "-FLAGS.SILENT (" . $flag . ")" );
  3610. }
  3611.  
  3612. sub deny_seeing {
  3613.     my($self, @msgs) = @_;
  3614.     if ( ref($msgs[0]) =~ /ARRAY/ ) { @msgs = @{$msgs[0]} };
  3615.     $self->unset_flag('\\Seen', @msgs);
  3616. }
  3617.  
  3618. sub size {
  3619.  
  3620.     my ($self,$msg) = @_;
  3621.     # return undef unless fetch is successful
  3622.     my @data = $self->fetch($msg,"(RFC822.SIZE)");
  3623.     return undef unless defined($data[0]);
  3624.     my($size) = grep(/RFC822\.SIZE/,@data);
  3625.  
  3626.     $size =~ /RFC822\.SIZE\s+(\d+)/;
  3627.     
  3628.     return $1;
  3629. }
  3630.  
  3631. sub getquotaroot {
  3632.     my $self = shift;
  3633.     my $what = shift;
  3634.     $what = ( $what ? $self->Massage($what) : "INBOX" ) ;
  3635.     $self->_imap_command("getquotaroot $what") or return undef;
  3636.     return $self->Results;
  3637. }
  3638.  
  3639. sub getquota {
  3640.     my $self = shift;
  3641.     my $what = shift;
  3642.     $what = ( $what ? $self->Massage($what) : "user/$self->{User}" ) ;
  3643.     $self->_imap_command("getquota $what") or return undef;
  3644.     return $self->Results;
  3645. }
  3646.  
  3647. sub quota     {
  3648.     my $self = shift;
  3649.     my ($what) = shift||"INBOX";
  3650.     $self->_imap_command("getquota $what")||$self->getquotaroot("$what");
  3651.     return (    map { s/.*STORAGE\s+\d+\s+(\d+).*\n$/$1/ ? $_ : () } $self->Results
  3652.     )[0] ;
  3653. }
  3654.  
  3655. sub quota_usage     {
  3656.     my $self = shift;
  3657.     my ($what) = shift||"INBOX";
  3658.     $self->_imap_command("getquota $what")||$self->getquotaroot("$what");
  3659.     return (    map { s/.*STORAGE\s+(\d+)\s+\d+.*\n$/$1/ ? $_ : () } $self->Results
  3660.     )[0] ;
  3661. }
  3662. sub Quote {
  3663.     my($class,$arg) = @_;
  3664.     return $class->Massage($arg,NonFolderArg);
  3665. }
  3666.  
  3667. sub Massage {
  3668.     my $self= shift;
  3669.     my $arg = shift;
  3670.     my $notFolder = shift;
  3671.     return unless $arg;
  3672.     my $escaped_arg = $arg; $escaped_arg =~ s/"/\\"/g;
  3673.     $arg     = substr($arg,1,length($arg)-2) if $arg =~ /^".*"$/
  3674.                 and ! ( $notFolder or $self->STATUS(qq("$escaped_arg"),"(MESSAGES)"));
  3675.  
  3676.     if ($arg =~ /["\\]/) {
  3677.         $arg = "{" . length($arg) . "}\x0d\x0a$arg" ;
  3678.     } elsif ($arg =~ /\s|[{}()]/) {
  3679.         $arg = qq("${arg}") unless $arg =~ /^"/;
  3680.     } 
  3681.  
  3682.     return $arg;
  3683. }
  3684.  
  3685. sub unseen_count {
  3686.  
  3687.     my ($self, $folder) = (shift, shift);
  3688.     $folder ||= $self->Folder;
  3689.     $self->status($folder, 'UNSEEN') or return undef;
  3690.  
  3691.     chomp(    my $r = ( grep 
  3692.               { s/\*\s+STATUS\s+.*\(UNSEEN\s+(\d+)\s*\)/$1/ }
  3693.               $self->History($self->Transaction)
  3694.             )[0]
  3695.     );
  3696.  
  3697.     $r =~ s/\D//g;
  3698.     return $r;
  3699. }
  3700.  
  3701.  
  3702.  
  3703. # Status Routines:
  3704.  
  3705.  
  3706. sub Status            { $_[0]->State                           ;       }
  3707. sub IsUnconnected     { ($_[0]->State == Unconnected)  ? 1 : 0 ;       }
  3708. sub IsConnected       { ($_[0]->State >= Connected)    ? 1 : 0 ;       }
  3709. sub IsAuthenticated   { ($_[0]->State >= Authenticated)? 1 : 0 ;       }
  3710. sub IsSelected        { ($_[0]->State == Selected)     ? 1 : 0 ;       }               
  3711.  
  3712.  
  3713. # The following private methods all work on an output line array.
  3714. # _data returns the data portion of an output array:
  3715. sub _data {   defined $_[1] and ref $_[1] and defined $_[1]->[TYPE] or return undef; $_[1]->[DATA]; }
  3716.  
  3717. # _index returns the index portion of an output array:
  3718. sub _index {  defined $_[1] and ref $_[1] and defined $_[1]->[TYPE] or return undef; $_[1]->[INDEX]; }
  3719.  
  3720. # _type returns the type portion of an output array:
  3721. sub _type {  defined $_[1] and ref $_[1] and defined $_[1]->[TYPE] or return undef; $_[1]->[TYPE]; }
  3722.  
  3723. # _is_literal returns true if this is a literal:
  3724. sub _is_literal { defined $_[1] and ref $_[1] and defined $_[1]->[TYPE] and $_[1]->[TYPE] eq "LITERAL" };
  3725.  
  3726. # _is_output_or_literal returns true if this is an 
  3727. #      output line (or the literal part of one):
  3728. sub _is_output_or_literal { 
  3729.               defined $_[1] and ref $_[1] and defined $_[1]->[TYPE] and 
  3730.             ($_[1]->[TYPE] eq "OUTPUT" || $_[1]->[TYPE] eq "LITERAL") 
  3731. };
  3732.  
  3733. # _is_output returns true if this is an output line:
  3734. sub _is_output { defined $_[1] and ref $_[1] and defined $_[1]->[TYPE] and $_[1]->[TYPE] eq "OUTPUT" };
  3735.  
  3736. # _is_input returns true if this is an input line:
  3737. sub _is_input { defined $_[1] and ref $_[1] and defined $_[1]->[TYPE] and $_[1]->[TYPE] eq "INPUT" };
  3738.  
  3739. # _next_index returns next_index for a transaction; may legitimately return 0 when successful.
  3740. sub _next_index { 
  3741.       defined(scalar(@{$_[0]->{'History'}{$_[1]||$_[0]->Transaction}}))       ? 
  3742.         scalar(@{$_[0]->{'History'}{$_[1]||$_[0]->Transaction}})         : 0 
  3743. };
  3744.  
  3745. sub _cram_md5 {
  3746.   my ($code, $client) = @_;
  3747.   my $hmac = Digest::HMAC_MD5::hmac_md5_hex(MIME::Base64::decode($code),
  3748.                                             $client->Password());
  3749.   return MIME::Base64::encode($client->User() . " $hmac");
  3750. }
  3751.  
  3752.  
  3753.  
  3754. sub Range {
  3755.     require "Mail/IMAPClient/MessageSet.pm";
  3756.     my $self = shift;
  3757.     my $targ = $_[0];
  3758.     #print "Arg is ",ref($targ),"\n";
  3759.     if (@_ == 1 and ref($targ) =~ /Mail::IMAPClient::MessageSet/ ) {
  3760.         return $targ;
  3761.     }
  3762.     my $range = Mail::IMAPClient::MessageSet->new(@_);
  3763.     #print "Returning $range :",ref($range)," == $range\n";
  3764.     return $range;
  3765. }
  3766.  
  3767. my $not_void = 1;
  3768.