File Coverage

blib/lib/Net/IMAP/SimpleX.pm
Criterion Covered Total %
statement 49 119 41.1
branch 0 40 0.0
condition 0 4 0.0
subroutine 16 37 43.2
pod 4 4 100.0
total 69 204 33.8


line stmt bran cond sub pod time code
1             package Net::IMAP::SimpleX::NIL;
2              
3 1     1   4417 use strict;
  1         7  
  1         24  
4 1     1   4 use warnings;
  1         1  
  1         34  
5 1     1   1038 use overload fallback=>1, '""' => sub { "" };
  1     0   900  
  1         7  
  0         0  
6 0     0     sub new { return bless {}, "Net::IMAP::SimpleX::NIL" }
7              
8             package Net::IMAP::SimpleX::Body;
9              
10 1     1   81 use strict;
  1         9  
  1         22  
11 1     1   4 use warnings;
  1         2  
  1         23  
12 1     1   4 no warnings 'once'; ## no critic
  1         1  
  1         71  
13              
14             our $uidm;
15              
16             BEGIN {
17 1     1   4 our @fields = qw/content_description encoded_size charset content_type format part_number id name encoding/;
18 1         2 for my $attr (@fields) {
19 1     1   5 no strict;
  1         2  
  1         52  
20 9     0   27 *{"Net::IMAP::SimpleX::Body::$attr"} = sub { shift->{$attr}; };
  9         116  
  0         0  
21             }
22             }
23              
24 0     0     sub hasparts { return 0; } *has_parts = \&hasparts;
25 0     0     sub parts { return }
26 0     0     sub type { return }
27 0     0     sub body { return shift; }
28              
29             package Net::IMAP::SimpleX::BodySummary;
30              
31 1     1   5 use strict;
  1         1  
  1         39  
32 1     1   9 use warnings;
  1         3  
  1         27  
33 1     1   4 no warnings 'once'; ## no critic
  1         2  
  1         262  
34              
35             sub new {
36 0     0     my ($class, $data) = @_;
37 0           my $self;
38              
39 0           Net::IMAP::SimpleX::_id_parts($data);
40              
41 0 0         if ($data->{parts}) {
42 0           $self = $data;
43             } else {
44 0           $self = { body => $data };
45             }
46              
47 0           return bless $self, $class;
48             }
49              
50 0 0   0     sub hasparts { return shift->{parts} ? 1 : 0; } *has_parts = \&hasparts;
51 0 0   0     sub parts { my $self = shift; return wantarray ? @{$self->{parts}} : $self->{parts}; }
  0            
  0            
52 0   0 0     sub type { return shift->{type} || undef; }
53 0     0     sub body { return shift->{body}; }
54              
55              
56             package Net::IMAP::SimpleX;
57              
58 1     1   7 use strict;
  1         1  
  1         17  
59 1     1   4 use warnings;
  1         1  
  1         25  
60 1     1   5 use Carp;
  1         2  
  1         51  
61 1     1   1053 use Parse::RecDescent;
  1         40354  
  1         7  
62 1     1   41 use base 'Net::IMAP::Simple';
  1         2  
  1         521  
63              
64             our $VERSION = "1.1000";
65              
66             # directly from http://tools.ietf.org/html/rfc3501#section-9
67             # try and flatten, format as best we can
68             our $body_grammar = q {
69             body: body_type_mpart | body_type_1part
70             { $return = bless $item[1], 'Net::IMAP::SimpleX::Body'; }
71             body_type_mpart: '('body(s) subtype')'
72             { $return = bless {
73             parts => $item[2],
74             type => $item{subtype}
75             }, 'Net::IMAP::SimpleX::BodySummary';
76             }
77             body_type_1part: body_type_basic | body_type_text
78             { $return = bless $item[1], 'Net::IMAP::SimpleX::BodySummary'; }
79             body_type_basic: '('media_type body_fields')'
80             { $return = {
81             content_type => $item{media_type},
82             %{$item{body_fields}}
83             };
84             }
85             body_type_text: '('media_type body_fields number')'
86             { $return = {
87             content_type => $item{media_type},
88             %{$item{body_fields}},
89             }}
90             body_fields: body_field_param body_field_id body_field_desc body_field_enc body_field_octets
91             { $return = {
92             id => $item{body_field_id},
93             content_description => $item{body_field_desc},
94             encoding => $item{body_field_enc},
95             encoded_size => $item{body_field_octets},
96             $item{body_field_param} ? %{$item{body_field_param}} : ()
97             };
98             }
99             body_field_id: nil | word
100             body_field_desc: nil | word
101             body_field_enc: word
102             body_field_octets: number
103             body_field_param: body_field_param_simple | body_field_param_ext | nil
104             body_field_param_ext: '('word word word word')'
105             { $return = { $item[2] => $item[3], $item[4] => $item[5] }; }
106             body_field_param_simple: '('word word')'
107             { $return = { $item[2] => $item[3] }; }
108             body_field_param: nil
109             media_type: type subtype
110             { $return = "$item{type}/$item{subtype}"; }
111             type: word
112             subtype: word
113             nil: 'NIL'
114             {$return = '';}
115             number: /\d+/
116             key: word
117             value: word
118             word: /[^\s\)\(]+/
119             { $item[1] =~ s/\"//g; $return = $item[1];}
120             };
121              
122             our $fetch_grammar = q&
123             fetch: fetch_item(s) {$return={ map {(@$_)} reverse @{$item[1]} }}
124              
125             fetch_item: cmd_start 'FETCH' '(' value_pair(s?) ')' {$return=[$item[1], {map {(@$_)} @{$item[4]}}]}
126              
127             cmd_start: '*' /\d+/ {$return=$item[2]}
128              
129             value_pair: tag value {$return=[$item[1], $item[2]]}
130              
131             tag: /BODY\b(?:\.PEEK)?(?:\[[^\]]*\])?(?:<[\d\.]*>)?/i | atom
132              
133             value: atom | string | parenthized_list
134              
135             atom: /[^"()\s{}[\]]+/ {
136             # strictly speaking, the NIL atom should be undef, but P::RD isn't going to allow that.
137             # returning a null character instead
138             $return=($item[1] eq "NIL" ? Net::IMAP::SimpleX::NIL->new : $item[1])
139             }
140              
141             string: '"' /[^\x0d\x0a"]*/ '"' {$return=$item[2]} | '{' /\d+/ "}\x0d\x0a" {
142             $return = length($text) >= $item[2]
143             ? substr($text,0,$item[2],"") # if the production is accepted, we alter the input stream
144             : undef;
145             }
146              
147             parenthized_list: '(' value(s?) ')' {$return=$item[2]}
148             &;
149              
150             sub new {
151 0     0 1   my $class = shift;
152 0 0         if (my $self = $class->SUPER::new(@_)) {
153              
154 0           $self->{parser}{body_summary} = Parse::RecDescent->new($body_grammar);
155 0           $self->{parser}{fetch} = Parse::RecDescent->new($fetch_grammar);
156              
157 0           return $self;
158             }
159             }
160              
161             sub _id_parts {
162 0     0     my $data = shift;
163 0           my $pre = shift;
164 0 0         $pre = $pre ? "$pre." : '';
165              
166 0           my $id = 1;
167 0 0         if (my $parts = $data->{parts}) {
168 0           for my $sub (@$parts){
169 0 0         _id_parts($sub,"$pre$id") if $sub->{parts};
170 0           $sub->{part_number} = "$pre$id";
171 0           $id++;
172             }
173              
174             } else {
175 0           $data->{part_number} = $id;
176             }
177              
178 0           return;
179             }
180              
181             sub body_summary {
182 0     0 1   my ($self, $number) = @_;
183              
184 0           my $bodysummary;
185              
186             return $self->_process_cmd(
187             cmd => [ 'FETCH' => qq[$number BODY] ],
188              
189 0     0     final => sub { return $bodysummary; },
190              
191             process => sub {
192 0 0   0     if ($_[0] =~ m/\(BODY\s+(.*?)\)\s*$/i) {
193 0           my $body_parts = $self->{parser}{body_summary}->body($1);
194 0           $bodysummary = Net::IMAP::SimpleX::BodySummary->new($body_parts);
195             }
196             },
197              
198 0           );
199             }
200              
201             sub uidfetch {
202 0     0 1   my $self = shift;
203              
204 0           local $uidm = 1; # auto-pop this after the fetch
205              
206 0           return $self->fetch(@_);
207             }
208              
209             sub fetch {
210 0     0 1   my $self = shift;
211 0 0         my $msg = shift; $msg =~ s/[^\*\d:,-]//g; croak "which message?" unless $msg;
  0            
  0            
212 0   0       my $spec = "@_" || 'FULL';
213              
214 0 0         $spec = "BODY[$spec]" if $spec =~ m/^[\d\.]+\z/;
215              
216 0           $self->_be_on_a_box;
217              
218             # cut and pasted from ::Server
219 0 0         $spec = [qw/FLAGS INTERNALDATE RFC822.SIZE ENVELOPE/] if uc $spec eq "ALL";
220 0 0         $spec = [qw/FLAGS INTERNALDATE RFC822.SIZE/] if uc $spec eq "FAST";
221 0 0         $spec = [qw/FLAGS INTERNALDATE RFC822.SIZE ENVELOPE BODY/] if uc $spec eq "FULL";
222 0 0         $spec = [ $spec ] unless ref $spec;
223              
224 0           my $stxt = join(" ", map {s/[^()[\]\s<>\da-zA-Z.-]//g; uc($_)} @$spec); ## no critic: really? don't modify $_? pfft
  0            
  0            
225              
226 0 0         $self->_debug( caller, __LINE__, parsed_fetch=> "$msg ($stxt)" ) if $self->{debug};
227              
228 0           my $entire_response = "";
229              
230             return $self->_process_cmd(
231             cmd => [ ($uidm ? "UID FETCH" : "FETCH")=> qq[$msg ($stxt)] ],
232              
233             final => sub {
234             #open my $fh, ">", "entire_response.dat";
235             #print $fh $entire_response;
236              
237 0 0   0     if( my $res = $self->{parser}{fetch}->fetch($entire_response) ) {
238 0 0         $self->_debug( caller, __LINE__, parsed_fetch=> "PARSED") if $self->{debug};
239 0 0         return wantarray ? %$res : $res;
240             }
241              
242 0 0         $self->_debug( caller, __LINE__, parsed_fetch=> "PARSE FAIL") if $self->{debug};
243 0           return;
244             },
245              
246             process => sub {
247 0     0     $entire_response .= $_[0];
248 0           return 1;
249             },
250              
251 0 0         );
252             }
253              
254             1;