File Coverage

blib/lib/Net/IMAP/Simple.pm
Criterion Covered Total %
statement 46 672 6.8
branch 2 324 0.6
condition 3 74 4.0
subroutine 11 169 6.5
pod 77 77 100.0
total 139 1316 10.5


line stmt bran cond sub pod time code
1             package Net::IMAP::Simple;
2              
3 20     20   80347 use strict;
  20         140  
  20         512  
4 20     20   91 use warnings;
  20         29  
  20         453  
5              
6 20     20   93 use Carp;
  20         35  
  20         888  
7 20     20   8456 use IO::File;
  20         143879  
  20         2066  
8 20     20   9145 use IO::Socket;
  20         276752  
  20         81  
9 20     20   15324 use IO::Select;
  20         28736  
  20         814  
10 20     20   8072 use Net::IMAP::Simple::PipeSocket;
  20         55  
  20         768  
11              
12             our $VERSION = "1.2212";
13              
14             BEGIN {
15             # I'd really rather the pause/cpan indexers miss this "package"
16             eval ## no critic
17 20     20   1709 q( package Net::IMAP::Simple::_message;
  20     20   18087  
  20     0   14905  
  20     0   228  
  0         0  
  0         0  
  0         0  
  0         0  
18             use overload fallback=>1, '""' => sub { local $"=""; "@{$_[0]}" };
19             sub new { bless $_[1] })
20             }
21              
22             our $uidm;
23              
24             sub new {
25 0     0 1 0 my ( $class, $server, %opts ) = @_;
26              
27             ## warn "use of Net::IMAP::Simple::SSL is depricated, pass use_ssl to new() instead\n"
28             ## if $class =~ m/::SSL/;
29              
30 0         0 my $self = bless { count => -1 } => $class;
31              
32 0 0       0 $self->{use_v6} = ( $opts{use_v6} ? 1 : 0 );
33 0 0       0 $self->{use_ssl} = ( $opts{use_ssl} ? 1 : 0 );
34              
35 0 0       0 unless( $opts{shutup_about_v6ssl} ) {
36             carp "use_ssl with IPv6 is not yet supported"
37 0 0 0     0 if $opts{use_v6} and $opts{use_ssl};
38             }
39              
40 0 0       0 if( $opts{ssl_version} ) {
41 0         0 $self->{ssl_version} = $opts{ssl_version};
42 0         0 $opts{use_ssl} = 1;
43             }
44              
45 0 0       0 $opts{use_ssl} = 1 if $opts{find_ssl_defaults};
46              
47 0 0       0 if( $opts{use_ssl} ) {
48 0 0       0 eval {
49 0         0 require IO::Socket::SSL;
50 0         0 import IO::Socket::SSL;
51 0         0 "true";
52              
53             } or croak "IO::Socket::SSL must be installed in order to use_ssl";
54              
55 0         0 $self->{ssl_options} = [ eval {@{ $opts{ssl_options} }} ];
  0         0  
  0         0  
56 0 0 0     0 carp "ignoring ssl_options: $@" if $opts{ssl_options} and not @{ $self->{ssl_options} };
  0         0  
57              
58 0 0       0 unless( @{ $self->{ssl_options} } ) {
  0         0  
59 0 0       0 if( $opts{find_ssl_defaults} ) {
60 0         0 my $nothing = 1;
61              
62 0         0 for(qw(
63             /etc/ssl/certs/ca-certificates.crt
64             /etc/pki/tls/certs/ca-bundle.crt
65             /etc/ssl/ca-bundle.pem
66             /etc/ssl/certs/
67             )) {
68              
69 0 0       0 if( -f $_ ) {
    0          
70 0         0 @{ $self->{ssl_options} } = (SSL_ca_file=>$_, SSL_verify_mode => IO::Socket::SSL::SSL_VERIFY_PEER());
  0         0  
71 0         0 $nothing = 0;
72 0         0 last;
73              
74             } elsif( -d $_ ) {
75 0         0 @{ $self->{ssl_options} } = (SSL_ca_path=>$_, SSL_verify_mode => IO::Socket::SSL::SSL_VERIFY_PEER());
  0         0  
76 0         0 $nothing = 0;
77 0         0 last;
78             }
79             }
80              
81 0 0       0 if( $nothing ) {
82 0         0 carp "couldn't find rational defaults for ssl verify. Choosing to not verify.";
83 0         0 @{ $self->{ssl_options} } = (SSL_verify_mode => IO::Socket::SSL::SSL_VERIFY_NONE());
  0         0  
84             }
85              
86             } else {
87 0         0 @{ $self->{ssl_options} } = (SSL_verify_mode => IO::Socket::SSL::SSL_VERIFY_NONE());
  0         0  
88             }
89             }
90             }
91              
92 0 0       0 if ( $opts{use_v6} ) {
93 0 0       0 eval {
94 0         0 require IO::Socket::INET6;
95 0         0 import IO::Socket::INET6;
96 0         0 "true";
97              
98             } or croak "IO::Socket::INET6 must be installed in order to use_v6";
99             }
100              
101 0 0       0 if( $server =~ m/cmd:(.+)/ ) {
102 0         0 $self->{cmd} = $1;
103              
104             } else {
105 0 0       0 if( ($self->{server}, $self->{port}) = $server =~ m/^(\d{1,3}(?:\.\d{1,3}){3})(?::(\d+))?\z/ ) {
    0          
    0          
    0          
106              
107             } elsif( ($self->{server}, $self->{port}) = $server =~ m/^\[([a-fA-F0-9:]+)\]:(\d+)\z/ ) {
108              
109             } elsif( ($self->{server}, $self->{port}) = $server =~ m/^([a-fA-F0-9:]+)\z/ ) {
110              
111             } elsif( ($self->{server}, $self->{port}) = $server =~ m/^([^:]+):(\d+)\z/ ) {
112              
113             } else {
114 0         0 $self->{server} = $server;
115 0         0 $self->{port} = $opts{port};
116             }
117              
118 0 0       0 $self->{port} = $self->_port unless defined $self->{port};
119             }
120              
121 0 0       0 $self->{timeout} = ( $opts{timeout} ? $opts{timeout} : $self->_timeout );
122 0 0       0 $self->{retry} = ( defined($opts{retry}) ? $opts{retry} : $self->_retry );
123 0 0       0 $self->{retry_delay} = ( defined($opts{retry_delay}) ? $opts{retry_delay} : $self->_retry_delay );
124 0         0 $self->{bindaddr} = $opts{bindaddr};
125 0         0 $self->{use_select_cache} = $opts{use_select_cache};
126 0         0 $self->{select_cache_ttl} = $opts{select_cache_ttl};
127 0         0 $self->{debug} = $opts{debug};
128 0         0 $self->{readline_callback} = $opts{readline_callback};
129              
130 0         0 my $sock;
131             my $c;
132 0         0 for ( my $i = 0 ; $i <= $self->{retry} ; $i++ ) {
133 0 0       0 if ( $sock = $self->{sock} = $self->_connect ) {
    0          
134 0         0 $c = 1;
135 0         0 last;
136              
137             } elsif ( $i < $self->{retry} ) {
138 0         0 sleep $self->{retry_delay};
139              
140             # Critic NOTE: I'm not sure why this was done, but it was removed
141             # beucase the critic said it was bad and sleep makes more sense.
142             # select( undef, undef, undef, $self->{retry_delay} );
143             }
144             }
145              
146 0 0       0 if ( !$c ) {
147 0         0 $@ =~ s/IO::Socket::INET6?: //g;
148 0         0 $Net::IMAP::Simple::errstr = "connection failed $@";
149 0         0 return;
150             }
151              
152 0 0       0 return unless $sock;
153              
154 0         0 my $select = $self->{sel} = IO::Select->new($sock);
155              
156 0 0       0 $self->_debug( caller, __LINE__, 'new', "waiting for socket ready" ) if $self->{debug};
157              
158 0         0 my $greeting_ok = 0;
159 0 0       0 if( $select->can_read($self->{timeout}) ) {
160 0 0       0 $self->_debug( caller, __LINE__, 'new', "looking for greeting" ) if $self->{debug};
161 0 0       0 if( my $line = $sock->getline ) {
162             # Cool, we got a line, check to see if it's a
163             # greeting.
164              
165 0 0       0 $self->_debug( caller, __LINE__, 'new', "got a greeting: $line" ) if $self->{debug};
166 0 0       0 $greeting_ok = 1 if $line =~ m/^\*\s+(?:OK|PREAUTH)/i;
167              
168             # Also, check to see if we failed before we sent any
169             # commands.
170 0 0       0 return if $line =~ /^\*\s+(?:NO|BAD)(?:\s+(.+))?/i;
171              
172             } else {
173 0 0       0 $self->_debug( caller, __LINE__, 'new', "server hung up during connect" ) if $self->{debug};
174              
175             # The server hung up on us, otherwise we'd get a line
176             # after can_read.
177 0         0 return;
178             }
179              
180             } else {
181 0 0       0 $self->_debug( caller, __LINE__, 'new', "no greeting found before timeout" ) if $self->{debug};
182             }
183              
184 0 0       0 return unless $greeting_ok;
185 0         0 return $self;
186             }
187              
188             sub _connect {
189 0     0   0 my ($self) = @_;
190 0         0 my $sock;
191              
192 0 0       0 if( $self->{cmd} ) {
193 0 0       0 $self->_debug( caller, __LINE__, '_connect', "popping open a pipesocket for command: $self->{cmd}" ) if $self->{debug};
194 0         0 $sock = Net::IMAP::Simple::PipeSocket->new(cmd=>$self->{cmd});
195              
196             } else {
197 0 0       0 $self->_debug( caller, __LINE__, '_connect', "connecting to $self->{server}:$self->{port}" ) if $self->{debug};
198             $sock = $self->_sock_from->new(
199             PeerAddr => $self->{server},
200             PeerPort => $self->{port},
201             Timeout => $self->{timeout},
202             Proto => 'tcp',
203             ( $self->{bindaddr} ? ( LocalAddr => $self->{bindaddr} ) : () ),
204             ( $_[0]->{ssl_version} ? ( SSL_version => $self->{ssl_version} ) : () ),
205 0 0       0 ( $_[0]->{use_ssl} ? (@{ $self->{ssl_options} }) : () ),
  0 0       0  
    0          
206             );
207             }
208              
209 0 0       0 $self->_debug( caller, __LINE__, '_connect', "connected, returning socket" ) if $self->{debug};
210 0         0 return $sock;
211             }
212              
213 0 0   0   0 sub _port { return $_[0]->{use_ssl} ? 993 : 143 }
214 0     0   0 sub _sock { return $_[0]->{sock} }
215 0     0   0 sub _count { return $_[0]->{count} }
216 0 0 0 0   0 sub _last { $_[0]->select unless exists $_[0]->{last}; return $_[0]->{last}||0 }
  0         0  
217 0     0   0 sub _timeout { return 90 }
218 0     0   0 sub _retry { return 1 }
219 0     0   0 sub _retry_delay { return 5 }
220 0 0   0   0 sub _sock_from { return $_[0]->{use_v6} ? 'IO::Socket::INET6' : $_[0]->{use_ssl} ? 'IO::Socket::SSL' : 'IO::Socket::INET' }
    0          
221              
222             sub starttls {
223 0     0 1 0 my ($self) = @_;
224              
225 0         0 require IO::Socket::SSL; import IO::Socket::SSL;
  0         0  
226 0         0 require Net::SSLeay; import Net::SSLeay;
  0         0  
227              
228             # $self->{debug} = 1;
229             # warn "Processing STARTTLS command";
230              
231             return $self->_process_cmd(
232             cmd => ['STARTTLS'],
233             final => sub {
234 0     0   0 Net::SSLeay::load_error_strings();
235 0         0 Net::SSLeay::SSLeay_add_ssl_algorithms();
236 0         0 Net::SSLeay::randomize();
237              
238             my $startres = IO::Socket::SSL->start_SSL(
239             $self->{sock},
240 0   0     0 SSL_version => $self->{ssl_version} || "SSLv3 TLSv1",
241             SSL_startHandshake => 0,
242             );
243              
244 0 0       0 unless ( $startres ) {
245 0         0 croak "Couldn't start TLS: " . IO::Socket::SSL::errstr() . "\n";
246             }
247              
248 0 0       0 $self->_debug( caller, __LINE__, 'starttls', "TLS initialization done" ) if $self->{debug};
249 0         0 1;
250             },
251              
252             # process => sub { push @lines, $_[0] if $_[0] =~ /^(?: \s+\S+ | [^:]+: )/x },
253 0         0 );
254             }
255              
256             sub login {
257 0     0 1 0 my ( $self, $user, $pass ) = @_;
258              
259 0         0 $pass = _escape($pass);
260              
261             return $self->_process_cmd(
262             cmd => [ LOGIN => qq[$user $pass] ],
263 0     0   0 final => sub { 1 },
264       0     process => sub { },
265 0         0 );
266             }
267              
268             sub separator {
269 0     0 1 0 my ( $self, ) = @_;
270 0         0 my $sep;
271              
272             return $self->_process_cmd (
273             cmd => [ LIST => qq["" ""] ],
274 0     0   0 final => sub { $sep },
275 0     0   0 process => sub { (undef,undef,undef,$sep,undef) = split /\s/smx , $_[0];
276 0         0 $sep =~ s/["]//g; },
277 0         0 );
278             }
279              
280             sub _clear_cache {
281 0     0   0 my $self = shift;
282 0         0 my $cb = $self->current_box;
283              
284 0 0 0     0 push @_, $cb if $cb and not @_;
285 0 0       0 return unless @_;
286              
287 0         0 for my $box (@_) {
288 0         0 delete $self->{BOXES}{$box};
289             }
290              
291 0         0 delete $self->{last};
292              
293 0         0 return 1;
294             }
295              
296             sub uidnext {
297 0     0 1 0 my $self = shift;
298 0   0     0 my $mbox = shift || $self->current_box || "INBOX";
299              
300 0         0 return $self->status($mbox => 'uidnext');
301             }
302              
303             sub uidvalidity {
304 0     0 1 0 my $self = shift;
305 0   0     0 my $mbox = shift || $self->current_box || "INBOX";
306              
307 0         0 return $self->status($mbox => 'uidvalidity');
308             }
309              
310             sub uidsearch {
311 0     0 1 0 my $self = shift;
312              
313 0         0 local $uidm = 1;
314              
315 0         0 return $self->search(@_);
316             }
317              
318             sub uid {
319 0     0 1 0 my $self = shift;
320 0         0 $self->_be_on_a_box; # does a select if we're not on a mailbox
321              
322 0   0     0 return $self->uidsearch( shift || "1:*" );
323             }
324              
325             sub seq {
326 0     0 1 0 my $self = shift;
327 0   0     0 my $msgno = shift || "1:*";
328              
329 0         0 $self->_be_on_a_box; # does a select if we're not on a mailbox
330              
331 0         0 return $self->search("uid $msgno");
332             }
333              
334             sub status {
335 0     0 1 0 my $self = shift;
336 0   0     0 my $mbox = shift || $self->current_box || "INBOX";
337 0 0       0 my @fields = @_ ? @_ : qw(unseen recent messages);
338              
339             # Example: C: A042 STATUS blurdybloop (UIDNEXT MESSAGES)
340             # S: * STATUS blurdybloop (MESSAGES 231 UIDNEXT 44292)
341             # S: A042 OK STATUS completed
342              
343 0         0 @fields = map{uc$_} @fields;
  0         0  
344 0         0 my %fields;
345              
346             return $self->_process_cmd(
347             cmd => [ STATUS => _escape($mbox) . " (@fields)" ],
348 0     0   0 final => sub { (@fields{@fields}) },
349             process => sub {
350 0 0   0   0 if( my ($status) = $_[0] =~ m/\* STATUS.+?$mbox.+?\((.+?)\)/i ) {
351              
352 0         0 for( @fields ) {
353 0 0       0 $fields{$_} = _unescape($1)
354             if $status =~ m/$_\s+(\S+|"[^"]+"|'[^']+')/i
355             # NOTE: this regex isn't perfect, but should almost always work
356             # for status values returned by a well meaning IMAP server
357             }
358              
359             }
360             },
361 0         0 );
362             }
363              
364             sub select { ## no critic -- too late to choose a different name now...
365 0     0 1 0 my ( $self, $mbox, $examine_mode ) = @_;
366 0 0       0 $examine_mode = $examine_mode ? 1:0;
367 0 0       0 $self->{examine_mode} = 0 unless exists $self->{examine_mode};
368              
369 0 0       0 $mbox = $self->current_box unless $mbox;
370              
371 0 0       0 if( $examine_mode == $self->{examine_mode} ) {
372 0 0 0     0 if ( $self->{use_select_cache} && ( time - $self->{BOXES}{$mbox}{proc_time} ) <= $self->{select_cache_ttl} ) {
373 0         0 return $self->{BOXES}{$mbox}{messages};
374             }
375             }
376              
377 0         0 $self->{BOXES}{$mbox}{proc_time} = time;
378              
379 0 0       0 my $cmd = $examine_mode ? 'EXAMINE' : 'SELECT';
380              
381             return $self->_process_cmd(
382             cmd => [ $cmd => _escape($mbox) ],
383             final => sub {
384 0     0   0 my $nm = $self->{last} = $self->{BOXES}{$mbox}{messages};
385              
386 0         0 $self->{working_box} = $mbox;
387 0         0 $self->{examine_mode} = $examine_mode;
388              
389 0 0       0 $nm ? $nm : "0E0";
390             },
391             process => sub {
392 0 0   0   0 if ( $_[0] =~ /^\*\s+(\d+)\s+EXISTS/i ) {
    0          
    0          
    0          
393 0         0 $self->{BOXES}{$mbox}{messages} = $1;
394              
395             } elsif ( $_[0] =~ /^\*\s+FLAGS\s+\((.*?)\)/i ) {
396 0         0 $self->{BOXES}{$mbox}{flags} = [ split( /\s+/, $1 ) ];
397              
398             } elsif ( $_[0] =~ /^\*\s+(\d+)\s+RECENT/i ) {
399 0         0 $self->{BOXES}{$mbox}{recent} = $1;
400              
401             } elsif ( $_[0] =~ /^\*\s+OK\s+\[(.*?)\s+(.*?)\]/i ) {
402 0         0 my ( $flag, $value ) = ( $1, $2 );
403              
404 0 0       0 if ( $value =~ /\((.*?)\)/ ) {
405             # NOTE: the sflags really aren't used anywhere, should they be?
406 0         0 $self->{BOXES}{$mbox}{sflags}{$flag} = [ split( /\s+/, $1 ) ];
407              
408             } else {
409 0         0 $self->{BOXES}{$mbox}{oflags}{$flag} = $value;
410             }
411             }
412             },
413 0         0 );
414             }
415              
416             sub examine {
417 0     0 1 0 my $self = shift;
418              
419 0         0 return $self->select($_[0], 1);
420             }
421              
422             sub messages {
423 0     0 1 0 my ( $self, $folder ) = @_;
424              
425 0         0 return $self->select($folder);
426             }
427              
428             sub flags {
429 0     0 1 0 my ( $self, $folder ) = @_;
430              
431 0         0 $self->select($folder);
432              
433 0 0       0 return @{ $self->{BOXES}{ $self->current_box }{flags} || [] };
  0         0  
434             }
435              
436             sub recent {
437 0     0 1 0 my ( $self, $folder ) = @_;
438              
439 0         0 $self->select($folder);
440              
441 0         0 return $self->{BOXES}{ $self->current_box }{recent};
442             }
443              
444             sub unseen {
445 0     0 1 0 my ( $self, $folder ) = @_;
446              
447 0         0 my $oflags = $self->{BOXES}{ $self->current_box }{oflags};
448              
449 0 0       0 if( exists $oflags->{UNSEEN} ) {
450 0         0 $self->select($folder);
451              
452 0         0 return $self->{BOXES}{ $self->current_box }{oflags}{UNSEEN};
453             }
454              
455 0         0 my ($unseen) = $self->status;
456              
457 0         0 return $unseen;
458             }
459              
460             sub current_box {
461 0     0 1 0 my ($self) = @_;
462              
463 0 0       0 return ( $self->{working_box} ? $self->{working_box} : 'INBOX' );
464             }
465              
466             sub close { ## no critic -- we already have tons of methods with built in names
467              
468 0     0 1 0 my $self = shift;
469 0         0 $self->{working_box} = undef;
470 0         0 return $self->_process_cmd(
471             cmd => [ "CLOSE" ],
472             );
473             }
474              
475             sub noop {
476 0     0 1 0 my $self = shift;
477 0         0 return $self->_process_cmd(
478             cmd => [ "NOOP" ],
479             );
480             }
481              
482             sub top {
483 0     0 1 0 my ( $self, $number ) = @_;
484 0   0     0 my $messages = $number || '1:' . $self->_last;
485              
486 0         0 my @lines;
487              
488             ## rfc2822 ## 2.2. Header Fields
489              
490             ## rfc2822 ## Header fields are lines composed of a field name, followed by a colon
491             ## rfc2822 ## (":"), followed by a field body, and terminated by CRLF. A field
492             ## rfc2822 ## name MUST be composed of printable US-ASCII characters (i.e.,
493             ## rfc2822 ## characters that have values between 33 and 126, inclusive), except
494             ## rfc2822 ## colon. A field body may be composed of any US-ASCII characters,
495             ## rfc2822 ## except for CR and LF. However, a field body may contain CRLF when
496             ## rfc2822 ## used in header "folding" and "unfolding" as described in section
497             ## rfc2822 ## 2.2.3. All field bodies MUST conform to the syntax described in
498             ## rfc2822 ## sections 3 and 4 of this standard.
499              
500             return $self->_process_cmd(
501             cmd => [ FETCH => qq[$messages RFC822.HEADER] ],
502             final => sub {
503 0 0   0   0 $lines[-1] =~ s/\)\x0d\x0a\z// # sometimes we get this and I don't think we should
504             # I really hoping I'm not breaking someting by doing this.
505             if @lines;
506              
507 0 0       0 return wantarray ? @lines : \@lines
508             },
509             process => sub {
510 0 0   0   0 return if $_[0] =~ m/\*\s+\d+\s+FETCH/i; # should this really be case insensitive?
511              
512 0 0 0     0 if( not @lines or $_[0] =~ m/^[!-9;-~]+:/ ) {
513 0         0 push @lines, $_[0];
514              
515             } else {
516 0         0 $lines[-1] .= $_[0];
517             }
518             },
519 0         0 );
520             }
521              
522             sub seen {
523 0     0 1 0 my ( $self, $number ) = @_;
524              
525 0         0 my @flags = $self->msg_flags($number);
526 0 0       0 return if $self->waserr;
527 0 0       0 return 1 if grep {$_ eq '\Seen'} @flags;
  0         0  
528 0         0 return 0;
529             }
530              
531             sub deleted {
532 0     0 1 0 my ( $self, $number ) = @_;
533              
534 0         0 my @flags = $self->msg_flags($number);
535 0 0       0 return if $self->waserr;
536 0 0       0 return 1 if grep {$_ eq '\Deleted'} @flags;
  0         0  
537 0         0 return 0;
538             }
539              
540             sub range2list {
541 1     1 1 3 my $self_or_class = shift;
542 1         2 my %h;
543 1 50       8 my @items = grep {!$h{$_}++} map { m/(\d+):(\d+)/ ? ($1 .. $2) : ($_) } split(m/[,\s]+/, shift);
  71         195  
  3         21  
544              
545 1         48 return @items;
546             }
547              
548             sub list2range {
549 1     1 1 594 my $self_or_class = shift;
550 1         2 my %h;
551 1         4 my @a = sort { $a<=>$b } grep {!$h{$_}++} grep {m/^\d+/} grep {defined $_} @_;
  345         378  
  79         146  
  79         139  
  79         102  
552 1         3 my @b;
553              
554 1         4 while(@a) {
555 3         4 my $e = 0;
556              
557 3   100     102 $e++ while $e+1 < @a and $a[$e]+1 == $a[$e+1];
558              
559 3 50       10 push @b, ($e>0 ? [$a[0], $a[$e]] : [$a[0]]);
560 3         10 splice @a, 0, $e+1;
561             }
562              
563 1         3 return join(",", map {join(":", @$_)} @b);
  3         20  
564             }
565              
566             sub list {
567 0     0 1   my ( $self, $number ) = @_;
568              
569             # NOTE: this entire function is horrible:
570             # 1. it should be called message_size() or something similar
571             # 2. what if $number is a range? none of this works right
572              
573 0   0       my $messages = $number || '1:' . $self->_last;
574 0           my %list;
575              
576 0 0         return {} if $messages eq "1:0";
577              
578             return $self->_process_cmd(
579             cmd => [ FETCH => qq[$messages RFC822.SIZE] ],
580 0 0   0     final => sub { $number ? $list{$number} : \%list },
581             process => sub {
582 0 0   0     if ( $_[0] =~ /^\*\s+(\d+).*RFC822.SIZE\s+(\d+)/i ) {
583 0           $list{$1} = $2;
584             }
585             },
586 0           );
587             }
588              
589             sub search {
590 0     0 1   my ($self, $search, $sort, $charset) = @_;
591              
592 0   0       $search ||= "ALL";
593 0   0       $charset ||= 'UTF-8';
594              
595 0 0         my $cmd = $uidm ? 'UID SEARCH' : 'SEARCH';
596              
597 0           $self->_be_on_a_box; # does a select if we're not on a mailbox
598              
599             # add rfc5256 sort, requires charset :(
600 0 0         if ($sort) {
601 0           $sort = uc $sort;
602 0 0         $cmd = ($uidm ? "UID ": "") . "SORT ($sort) \"$charset\"";
603             }
604              
605 0           my @seq;
606              
607             return $self->_process_cmd(
608             cmd => [ $cmd => $search ],
609 0 0   0     final => sub { wantarray ? @seq : int @seq },
610 0 0   0     process => sub { if ( my ($msgs) = $_[0] =~ /^\*\s+(?:SEARCH|SORT)\s+(.*)/i ) {
611              
612 0           @seq = $self->range2list($msgs);
613              
614             }},
615 0           );
616             }
617              
618 0     0 1   sub search_seen { my $self = shift; return $self->search("SEEN"); }
  0            
619 0     0 1   sub search_recent { my $self = shift; return $self->search("RECENT"); }
  0            
620 0     0 1   sub search_answered { my $self = shift; return $self->search("ANSWERED"); }
  0            
621 0     0 1   sub search_deleted { my $self = shift; return $self->search("DELETED"); }
  0            
622 0     0 1   sub search_flagged { my $self = shift; return $self->search("FLAGGED"); }
  0            
623 0     0 1   sub search_draft { my $self = shift; return $self->search("FLAGGED"); }
  0            
624              
625 0     0 1   sub search_unseen { my $self = shift; return $self->search("UNSEEN"); }
  0            
626 0     0 1   sub search_old { my $self = shift; return $self->search("OLD"); }
  0            
627 0     0 1   sub search_unanswered { my $self = shift; return $self->search("UNANSWERED"); }
  0            
628 0     0 1   sub search_undeleted { my $self = shift; return $self->search("UNDELETED"); }
  0            
629 0     0 1   sub search_unflagged { my $self = shift; return $self->search("UNFLAGGED"); }
  0            
630              
631 0     0 1   sub search_smaller { my $self = shift; my $octets = int shift; return $self->search("SMALLER $octets"); }
  0            
  0            
632 0     0 1   sub search_larger { my $self = shift; my $octets = int shift; return $self->search("LARGER $octets"); }
  0            
  0            
633              
634             sub _process_date {
635 0     0     my $d = shift;
636              
637 0 0         if( eval 'use Date::Manip (); 1' ) { ## no critic
638 0 0         if( my $pd = Date::Manip::ParseDate($d) ) {
639              
640             # NOTE: RFC 3501 wants this poorly-internationalized date format
641             # for SEARCH. Not my fault.
642              
643 0           return Date::Manip::UnixDate($pd, '%d-%b-%Y');
644             }
645              
646             } else {
647             # TODO: complain if the date isn't %d-%m-%Y
648              
649             # I'm not sure there's anything to be gained by doing so ... They'll
650             # just get an imap error they can choose to handle.
651             }
652              
653 0           return $d;
654             }
655              
656             sub _process_qstring {
657 0     0     my $t = shift;
658 0           $t =~ s/\\/\\\\/g;
659 0           $t =~ s/"/\\"/g;
660              
661 0           return "\"$t\"";
662             }
663              
664 0     0 1   sub search_before { my $self = shift; my $d = _process_date(shift); return $self->search("BEFORE $d"); }
  0            
  0            
665 0     0 1   sub search_since { my $self = shift; my $d = _process_date(shift); return $self->search("SINCE $d"); }
  0            
  0            
666 0     0 1   sub search_sent_before { my $self = shift; my $d = _process_date(shift); return $self->search("SENTBEFORE $d"); }
  0            
  0            
667 0     0 1   sub search_sent_since { my $self = shift; my $d = _process_date(shift); return $self->search("SENTSINCE $d"); }
  0            
  0            
668              
669 0     0 1   sub search_from { my $self = shift; my $t = _process_qstring(shift); return $self->search("FROM $t"); }
  0            
  0            
670 0     0 1   sub search_to { my $self = shift; my $t = _process_qstring(shift); return $self->search("TO $t"); }
  0            
  0            
671 0     0 1   sub search_cc { my $self = shift; my $t = _process_qstring(shift); return $self->search("CC $t"); }
  0            
  0            
672 0     0 1   sub search_bcc { my $self = shift; my $t = _process_qstring(shift); return $self->search("BCC $t"); }
  0            
  0            
673 0     0 1   sub search_subject { my $self = shift; my $t = _process_qstring(shift); return $self->search("SUBJECT $t"); }
  0            
  0            
674 0     0 1   sub search_body { my $self = shift; my $t = _process_qstring(shift); return $self->search("BODY $t"); }
  0            
  0            
675              
676             sub get {
677 0     0 1   my ( $self, $number, $part ) = @_;
678 0 0         my $arg = $part ? "BODY[$part]" : 'RFC822';
679              
680 0           return $self->fetch( $number, $arg );
681             }
682              
683             sub fetch {
684 0     0 1   my ( $self, $number, $part ) = @_;
685 0   0       my $arg = $part || 'RFC822';
686              
687 0           my @lines;
688             my $fetching;
689              
690             return $self->_process_cmd(
691             cmd => [ FETCH => qq[$number $arg] ],
692             final => sub {
693 0 0   0     if( $fetching ) {
694 0 0         if( $fetching > 0 ) {
695             # XXX: this is just about the least efficient way in the
696             # world to do this; I should appologize, but really,
697             # nothing in this module is done particularly well. I
698             # doubt anyone will notice this.
699              
700 0           local $"="";
701 0           my $message = "@lines";
702 0 0         @lines = split m/(?<=\x0d\x0a)/, substr($message, 0, $fetching)
703             if( length $message > $fetching );
704             }
705 0 0         return wantarray ? @lines : Net::IMAP::Simple::_message->new(\@lines)
706             }
707              
708 0 0 0       if( defined $fetching and $fetching == 0 ) {
709 0           return "\n"; # XXX: Your 0 byte message is incorrectly returned as a newline. Meh.
710             }
711              
712             # NOTE: There is not supposed to be an error if you ask for a
713             # message that's not there, but this is a rather confusing
714             # notion … so we generate an error here.
715              
716 0           $self->{_errstr} = "message not found";
717 0           return;
718             },
719             process => sub {
720 0 0   0     if ( $_[0] =~ /^\*\s+\d+\s+FETCH\s+\(.+?\{(\d+)\}/ ) {
    0          
    0          
721 0           $fetching = $1;
722              
723             } elsif( $_[0] =~ /^\*\s+\d+\s+FETCH\s+\(.+?\"(.*)\"\s*\)/ ) {
724             # XXX: this is not tested because Net::IMAP::Server doesn't do
725             # this type of string result (that I know of) for this it might
726             # work, ... frog knows. Not likely to come up very often, if
727             # ever; although you do sometimes see the occasional 0byte
728             # message. Valid really.
729              
730 0           $fetching = -1;
731 0           @lines = ($1);
732              
733             } elsif( $fetching ) {
734 0           push @lines, join( ' ', @_ );
735             }
736             },
737 0           );
738              
739             }
740              
741             sub _process_flags {
742 0     0     my $self = shift;
743 0           my @ret = map { split m/\s+/, $_ } grep { $_ } @_;
  0            
  0            
744              
745 0           return @ret;
746             }
747              
748             sub put {
749 0     0 1   my ( $self, $mailbox_name, $msg, @flags ) = @_;
750              
751 0 0 0       croak "usage: \$imap->put(mailbox, message, \@flags)" unless defined $msg and defined $mailbox_name;
752              
753 0           my $size = length $msg;
754 0 0         if ( ref $msg eq "ARRAY" ) {
755 0           $size = 0;
756 0           $size += length $_ for @$msg;
757             }
758              
759 0           @flags = $self->_process_flags(@flags);
760              
761             return $self->_process_cmd(
762             cmd => [ APPEND => _escape($mailbox_name) ." (@flags) {$size}" ],
763 0     0     final => sub { $self->_clear_cache; 1 },
  0            
764             process => sub {
765 0 0   0     if( $_[0] =~ m/^\+\s+/ ) { # + continue (or go ahead, or whatever)
766 0 0         if ($size) {
767 0           my $sock = $self->_sock;
768 0 0         if ( ref $msg eq "ARRAY" ) {
769 0           print $sock $_ for @$msg;
770              
771             } else {
772 0           print $sock $msg;
773             }
774 0           $size = undef;
775 0           print $sock "\r\n";
776             }
777             }
778             },
779              
780 0           );
781             }
782              
783             # This supports supplying a date per IMAP RFC 3501
784             # APPEND Command - Section 6.3.11
785             # Implemented here as a new method so when calling the put above
786             # older code will not break
787             sub put_with_date {
788 0     0 1   my ( $self, $mailbox_name, $msg, $date, @flags ) = @_;
789              
790 0 0 0       croak "usage: \$imap->put_with_date(mailbox, message, date, \@flags)" unless defined $msg and defined $mailbox_name;
791              
792 0           my $size = length $msg;
793 0 0         if ( ref $msg eq "ARRAY" ) {
794 0           $size = 0;
795 0           $size += length $_ for @$msg;
796             }
797              
798 0           @flags = $self->_process_flags(@flags);
799              
800 0           my $cmd_str = _escape($mailbox_name) . " (@flags)";
801 0 0         $cmd_str .= " " . _escape($date) if $date ne "";
802 0           $cmd_str .= " {$size}";
803              
804             return $self->_process_cmd(
805             cmd => [ APPEND => $cmd_str ],
806 0     0     final => sub { $self->_clear_cache; 1 },
  0            
807             process => sub {
808 0 0   0     if( $_[0] =~ m/^\+\s+/ ) { # + continue (or go ahead, or whatever)
809 0 0         if ($size) {
810 0           my $sock = $self->_sock;
811 0 0         if ( ref $msg eq "ARRAY" ) {
812 0           print $sock $_ for @$msg;
813              
814             } else {
815 0           print $sock $msg;
816             }
817 0           $size = undef;
818 0           print $sock "\r\n";
819             }
820             }
821             },
822              
823 0           );
824             }
825              
826             sub msg_flags {
827 0     0 1   my ( $self, $number ) = @_;
828              
829 0           my @flags;
830 0           $self->{_waserr} = 1; # assume something went wrong.
831 0           $self->{_errstr} = "flags not found during fetch";
832              
833             # _send_cmd] 15 FETCH 12 (FLAGS)\r\n
834             # _process_cmd] * 12 FETCH (FLAGS (\Seen))\r\n
835             # _cmd_ok] * 12 FETCH (FLAGS (\Seen))\r\n
836             # _seterrstr] warning unknown return string (id=15): * 12 FETCH (FLAGS (\Seen))\r\n
837             # _process_cmd] 15 OK Success\r\n
838              
839             return $self->_process_cmd(
840             cmd => [ FETCH => qq[$number (FLAGS)] ],
841             final => sub {
842 0 0   0     return if $self->{_waserr};
843 0 0         wantarray ? @flags : "@flags";
844             },
845             process => sub {
846 0 0   0     if( $_[0] =~ m/\* $number FETCH \(FLAGS \(([^()]*?)\)\)/i ) {
847 0           @flags = $self->_process_flags($1);
848 0           delete $self->{_waserr};
849             }
850             },
851 0           );
852             }
853              
854             sub getfh {
855 0     0 1   my ( $self, $number ) = @_;
856              
857 0           my $file = IO::File->new_tmpfile;
858 0           my $buffer;
859              
860             return $self->_process_cmd(
861             cmd => [ FETCH => qq[$number RFC822] ],
862 0     0     final => sub { seek $file, 0, 0; $file },
  0            
863             process => sub {
864 0 0   0     if ( $_[0] !~ /^\* \d+ FETCH/ ) {
865 0 0         defined($buffer) and print $file $buffer;
866 0           $buffer = $_[0];
867             }
868             },
869 0           );
870             }
871              
872             sub logout {
873 0     0 1   my $self = shift;
874              
875 0     0     return $self->_process_cmd( cmd => ['LOGOUT'], final => sub { $self->_sock->close; 1 }, process => sub { } );
  0            
  0            
876             }
877              
878             sub quit {
879 0     0 1   my ( $self, $hq ) = @_;
880 0           $self->_send_cmd('EXPUNGE'); # XXX: $self->expunge_mailbox?
881              
882 0 0         if ( !$hq ) {
883             # XXX: $self->logout?
884 0     0     $self->_process_cmd( cmd => ['LOGOUT'], final => sub { 1 }, process => sub { } );
  0            
885              
886             } else {
887             # XXX: do people use the $hq?
888 0           $self->_send_cmd('LOGOUT');
889             }
890              
891 0           $self->_sock->close;
892              
893 0           return 1;
894             }
895              
896             sub _be_on_a_box {
897 0     0     my $self = shift;
898 0 0         return if $self->{working_box};
899 0           $self->select; # sit on something
900 0           return;
901             }
902              
903             sub last { ## no critic -- too late to choose a different name now...
904 0     0 1   my $self = shift;
905 0           my $last = $self->_last;
906              
907 0 0         if( not defined $last ) {
908 0 0         $self->select or return;
909 0           $last = $self->_last;
910             }
911              
912 0           return $last;
913             }
914              
915             sub add_flags {
916 0     0 1   my ( $self, $number, @flags ) = @_;
917              
918 0           @flags = $self->_process_flags(@flags);
919 0 0         return unless @flags;
920              
921             return $self->_process_cmd(
922             cmd => [ STORE => qq[$number +FLAGS (@flags)] ],
923 0     0     final => sub { $self->_clear_cache },
924       0     process => sub { },
925 0           );
926             }
927              
928             sub sub_flags {
929 0     0 1   my ( $self, $number, @flags ) = @_;
930              
931 0           @flags = $self->_process_flags(@flags);
932 0 0         return unless @flags;
933              
934             return $self->_process_cmd(
935             cmd => [ STORE => qq[$number -FLAGS (@flags)] ],
936 0     0     final => sub { $self->_clear_cache },
937       0     process => sub { },
938 0           );
939             }
940              
941             sub delete { ## no critic -- too late to choose a different name now...
942 0     0 1   my ( $self, $number ) = @_;
943              
944 0           return $self->add_flags( $number, '\Deleted' );
945             }
946              
947             sub undelete {
948 0     0 1   my ( $self, $number ) = @_;
949              
950 0           return $self->sub_flags( $number, '\Deleted' );
951             }
952              
953             sub see {
954 0     0 1   my ( $self, $number ) = @_;
955              
956 0           return $self->add_flags( $number, '\Seen' );
957             }
958              
959             sub unsee {
960 0     0 1   my ( $self, $number ) = @_;
961              
962 0           return $self->sub_flags( $number, '\Seen' );
963             }
964              
965             sub _process_list {
966 0     0     my ( $self, $line ) = @_;
967 0 0         $self->_debug( caller, __LINE__, '_process_list', $line ) if $self->{debug};
968              
969 0           my @list;
970 0 0 0       if ( $line =~ /^\*\s+(LIST|LSUB).*\s+\{\d+\}\s*$/i ) {
    0          
971 0           chomp( my $res = $self->_sock->getline );
972              
973 0           $res =~ s/\r//;
974              
975 0           push @list, _escape($res);
976              
977 0 0         $self->_debug( caller, __LINE__, '_process_list', $res ) if $self->{debug};
978              
979             } elsif ( $line =~ /^\*\s+(LIST|LSUB).*\s+(\".*?\")\s*$/i || $line =~ /^\*\s+(LIST|LSUB).*\s+(\S+)\s*$/i ) {
980 0           push @list, $2;
981             }
982              
983 0           return @list;
984             }
985              
986             sub mailboxes {
987 0     0 1   my ( $self, $box, $ref ) = @_;
988              
989 0   0       $ref ||= '""';
990 0           my @list;
991 0 0         if ( !defined $box ) {
992              
993             # recurse, should probably follow
994             # RFC 2683: 3.2.1.1. Listing Mailboxes
995             return $self->_process_cmd(
996             cmd => [ LIST => qq[$ref *] ],
997 0     0     final => sub { map { _unescape($_) } @list },
  0            
998 0     0     process => sub { push @list, $self->_process_list( $_[0] ); },
999 0           );
1000              
1001             }
1002              
1003             return $self->_process_cmd(
1004             cmd => [ LIST => qq[$ref $box] ],
1005 0     0     final => sub { map { _unescape($_) } @list },
  0            
1006 0     0     process => sub { push @list, $self->_process_list( $_[0] ) },
1007 0           );
1008             }
1009              
1010             sub mailboxes_subscribed {
1011 0     0 1   my ( $self, $box, $ref ) = @_;
1012              
1013 0   0       $ref ||= '""';
1014              
1015 0           my @list;
1016 0 0         if ( !defined $box ) {
1017              
1018             # recurse, should probably follow
1019             # RFC 2683: 3.2.2. Subscriptions
1020             return $self->_process_cmd(
1021             cmd => [ LSUB => qq[$ref *] ],
1022 0     0     final => sub { map { _unescape($_) } @list },
  0            
1023 0     0     process => sub { push @list, $self->_process_list( $_[0] ) },
1024 0           );
1025              
1026             }
1027              
1028             return $self->_process_cmd(
1029             cmd => [ LSUB => qq[$ref $box] ],
1030 0     0     final => sub { map { _unescape($_) } @list },
  0            
1031 0     0     process => sub { push @list, $self->_process_list( $_[0] ) },
1032 0           );
1033             }
1034              
1035             sub create_mailbox {
1036 0     0 1   my ( $self, $box ) = @_;
1037              
1038             return $self->_process_cmd(
1039             cmd => [ CREATE => _escape($box) ],
1040 0     0     final => sub { 1 },
1041       0     process => sub { },
1042 0           );
1043             }
1044              
1045             sub expunge_mailbox {
1046 0     0 1   my ( $self, $box ) = @_;
1047              
1048 0 0         return if !$self->select($box);
1049              
1050             # C: A202 EXPUNGE
1051             # S: * 3 EXPUNGE
1052             # S: * 3 EXPUNGE
1053             # S: * 5 EXPUNGE
1054             # S: * 8 EXPUNGE
1055             # S: A202 OK EXPUNGE completed
1056              
1057 0           my @expunged;
1058             return $self->_process_cmd(
1059             cmd => ['EXPUNGE'],
1060             final => sub {
1061 0     0     $self->_clear_cache;
1062 0 0         return @expunged if wantarray; # don't return 0E0 if want array and we're empty
1063 0 0         return "0E0" unless @expunged;
1064 0           return @expunged;
1065             },
1066             process => sub {
1067 0 0   0     if( $_[0] =~ m/^\s*\*\s+(\d+)\s+EXPUNGE[\r\n]*$/i ) {
1068 0           push @expunged, $1;
1069             }
1070             },
1071 0           );
1072             }
1073              
1074             sub delete_mailbox {
1075 0     0 1   my ( $self, $box ) = @_;
1076              
1077             return $self->_process_cmd(
1078             cmd => [ DELETE => _escape($box) ],
1079 0     0     final => sub { 1 },
1080       0     process => sub { },
1081 0           );
1082             }
1083              
1084             sub rename_mailbox {
1085 0     0 1   my ( $self, $old_box, $new_box ) = @_;
1086 0           my $o = _escape($old_box);
1087 0           my $n = _escape($new_box);
1088              
1089             return $self->_process_cmd(
1090             cmd => [ RENAME => qq[$o $n] ],
1091 0     0     final => sub { 1 },
1092       0     process => sub { },
1093 0           );
1094             }
1095              
1096             sub folder_subscribe {
1097 0     0 1   my ( $self, $box ) = @_;
1098 0           $self->select($box);
1099              
1100             return $self->_process_cmd(
1101             cmd => [ SUBSCRIBE => _escape($box) ],
1102 0     0     final => sub { 1 },
1103       0     process => sub { },
1104 0           );
1105             }
1106              
1107             sub folder_unsubscribe {
1108 0     0 1   my ( $self, $box ) = @_;
1109 0           $self->select($box);
1110              
1111             return $self->_process_cmd(
1112             cmd => [ UNSUBSCRIBE => _escape($box) ],
1113 0     0     final => sub { 1 },
1114       0     process => sub { },
1115 0           );
1116             }
1117              
1118             sub copy {
1119 0     0 1   my ( $self, $number, $box ) = @_;
1120 0           my $b = _escape($box);
1121              
1122             return $self->_process_cmd(
1123             cmd => [ COPY => qq[$number $b] ],
1124 0     0     final => sub { 1 },
1125       0     process => sub { },
1126 0           );
1127             }
1128              
1129             sub uidcopy {
1130 0     0 1   my ( $self, $number, $box ) = @_;
1131 0           my $b = _escape($box);
1132              
1133             return $self->_process_cmd(
1134             cmd => [ 'UID COPY' => qq[$number $b] ],
1135 0     0     final => sub { 1 },
1136       0     process => sub { },
1137 0           );
1138             }
1139              
1140             sub waserr {
1141 0     0 1   return $_[0]->{_waserr};
1142             }
1143              
1144             sub errstr {
1145 0     0 1   return $_[0]->{_errstr};
1146             }
1147              
1148 0     0     sub _nextid { return ++$_[0]->{count} }
1149              
1150             sub _escape {
1151 0     0     my $val = shift;
1152 0           $val =~ s/\\/\\\\/g;
1153 0           $val =~ s/\"/\\\"/g;
1154 0           $val = "\"$val\"";
1155              
1156 0           return $val;
1157             }
1158              
1159             sub _unescape {
1160 0     0     my $val = shift;
1161 0           $val =~ s/^"//g;
1162 0           $val =~ s/"$//g;
1163 0           $val =~ s/\\\"/\"/g;
1164 0           $val =~ s/\\\\/\\/g;
1165              
1166 0           return $val;
1167             }
1168              
1169             sub _send_cmd {
1170 0     0     my ( $self, $name, $value ) = @_;
1171 0           my $sock = $self->_sock;
1172 0           my $id = $self->_nextid;
1173 0 0         my $cmd = "$id $name" . ( $value ? " $value" : "" ) . "\r\n";
1174              
1175 0 0         $self->_debug( caller, __LINE__, '_send_cmd', $cmd ) if $self->{debug};
1176              
1177 0           { local $\; print $sock $cmd; }
  0            
  0            
1178              
1179 0           return ( $sock => $id );
1180             }
1181              
1182             sub _cmd_ok {
1183 0     0     my ( $self, $res ) = @_;
1184 0           my $id = $self->_count;
1185              
1186 0 0         $self->_debug( caller, __LINE__, '_cmd_ok', $res ) if $self->{debug};
1187              
1188 0 0         if ( $res =~ /^$id\s+OK/i ) {
    0          
    0          
1189 0           return 1;
1190              
1191             } elsif ( $res =~ /^$id\s+(?:NO|BAD)(?:\s+(.+))?/i ) {
1192 0   0       $self->_seterrstr( $1 || 'unknown error' );
1193 0           return 0;
1194              
1195             } elsif ( $res =~ m/^\*\s+/ ) {
1196              
1197             } else {
1198 0           $self->_seterrstr("warning unknown return string (id=$id): $res");
1199             }
1200              
1201 0           return;
1202             }
1203              
1204             sub _read_multiline {
1205 0     0     my ( $self, $sock, $list, $count ) = @_;
1206              
1207 0           my @lines;
1208 0           my $read_so_far = 0;
1209              
1210 0           while ( $read_so_far < $count ) {
1211 0 0         if( defined( my $line = $sock->getline ) ) {
1212 0           $read_so_far += length( $line );
1213 0           push @lines, $line;
1214              
1215             } else {
1216 0           $self->_seterrstr( "error reading $count bytes from socket" );
1217 0           last;
1218             }
1219             }
1220              
1221 0 0 0       if( $list and $lines[-1] !~ m/\)[\x0d\x0a\s]*$/ ) {
1222 0 0         $self->_debug( caller, __LINE__, '_read_multiline', "Looking for ending parenthesis match..." ) if $self->{debug};
1223              
1224 0           my $unmatched = 1;
1225 0           while( $unmatched ) {
1226              
1227 0 0         if( defined( my $line = $sock->getline ) ) {
1228 0           push @lines, $line;
1229 0 0         $unmatched = 0 if $line =~ m/\)[\x0d\x0a\s]*$/;
1230              
1231             } else {
1232 0           $self->_seterrstr( "error reading $count bytes from socket" );
1233 0           last;
1234             }
1235              
1236             }
1237             }
1238              
1239 0 0         if ( $self->{debug} ) {
1240 0           my $count=0;
1241 0           for ( my $i = 0 ; $i < @lines ; $i++ ) {
1242 0           $count += length($lines[$i]);
1243 0           $self->_debug( caller, __LINE__, '_read_multiline', "[$i] ($count) $lines[$i]" );
1244             }
1245             }
1246              
1247 0           return @lines;
1248             }
1249              
1250             sub _process_cmd {
1251 0     0     my ( $self, %args ) = @_;
1252 0           my ( $sock, $id ) = $self->_send_cmd( @{ $args{cmd} } );
  0            
1253              
1254 0 0   0     $args{process} = sub {} unless ref($args{process}) eq "CODE";
1255 0 0   0     $args{final} = sub {} unless ref($args{final}) eq "CODE";
1256              
1257 0           my $cb = $self->{readline_callback};
1258              
1259 0           my $res;
1260 0           while ( $res = $sock->getline ) {
1261 0 0         $cb->($res) if $cb;
1262 0 0         $self->_debug( caller, __LINE__, '_process_cmd', $res ) if $self->{debug};
1263              
1264 0 0         if ( $res =~ /^\*.*\{(\d+)\}[\r\n]*$/ ) {
1265 0           my $count = $1;
1266 0           my $list;
1267              
1268 0 0         $list = 1 if($res =~ /\(/);
1269              
1270 0           $args{process}->($res);
1271 0           foreach( $self->_read_multiline( $sock, $list, $count ) ) {
1272 0 0         $cb->($_) if $cb;
1273 0           $args{process}->($_)
1274             }
1275              
1276             } else {
1277 0           my $ok = $self->_cmd_ok($res);
1278 0 0 0       if ( defined($ok) && $ok == 1 ) {
    0 0        
1279 0           return $args{final}->($res);
1280              
1281             } elsif ( defined($ok) && !$ok ) {
1282 0           return;
1283              
1284             } else {
1285 0           $args{process}->($res);
1286             }
1287             }
1288             }
1289              
1290 0           return;
1291             }
1292              
1293             sub _seterrstr {
1294 0     0     my ( $self, $err ) = @_;
1295              
1296 0           $self->{_errstr} = $err;
1297 0 0         $self->_debug( caller, __LINE__, '_seterrstr', $err ) if $self->{debug};
1298              
1299 0           return;
1300             }
1301              
1302             sub debug {
1303 0     0 1   my $this = shift;
1304 0 0         if( @_ ) {
1305 0           $this->{debug} = shift;
1306             }
1307              
1308 0           return $this->{debug};
1309             }
1310              
1311             sub _debug {
1312 0     0     my ( $self, $package, $filename, $line, $dline, $routine, $str ) = @_;
1313              
1314 0           $str =~ s/\n/\\n/g;
1315 0           $str =~ s/\r/\\r/g;
1316 0           $str =~ s/\cM/^M/g;
1317              
1318 0           my $shortness = 30;
1319 0           my $elipsissn = $shortness-3;
1320 0           my $flen = length $filename;
1321              
1322 0 0         my $short_fname = ($flen > $shortness ? "..." . substr($filename, $flen - $elipsissn) : $filename);
1323              
1324 0           $line = "[$short_fname line $line in sub $routine] $str\n";
1325              
1326 0 0 0       if( exists $self->{debug} and defined $self->{debug} ) {
1327              
1328 0 0         if ( ref( $self->{debug} ) eq 'GLOB' ) {
    0          
    0          
1329 0           print { $self->{debug} } $line;
  0            
1330              
1331             } elsif( $self->{debug} eq "warn" ) {
1332 0           warn $line;
1333              
1334             } elsif( $self->{debug} =~ m/^file:(.+)/ ) {
1335 0 0         open my $out, ">>", $1 or warn "[log io fail: $@] $line";
1336 0           print $out $line;
1337 0           CORE::close($out);
1338              
1339             } else {
1340 0           print STDOUT $line;
1341             }
1342              
1343             }
1344              
1345 0           return;
1346             }
1347              
1348             1;