File Coverage

blib/lib/Mail/IMAPClient/BodyStructure.pm
Criterion Covered Total %
statement 97 118 82.2
branch 27 54 50.0
condition 19 43 44.1
subroutine 20 25 80.0
pod 2 4 50.0
total 165 244 67.6


line stmt bran cond sub pod time code
1 1     1   69647 use warnings;
  1         9  
  1         33  
2 1     1   5 use strict;
  1         2  
  1         46  
3              
4             package Mail::IMAPClient::BodyStructure;
5 1     1   3322 use Mail::IMAPClient::BodyStructure::Parse;
  1         3  
  1         549  
6              
7             # BUG?: old code used name "HEAD" instead of "HEADER", change?
8             my $HEAD = "HEAD";
9              
10             # my has file scope, not limited to package!
11             my $parser = Mail::IMAPClient::BodyStructure::Parse->new
12             or die "Cannot parse rules: $@\n"
13             . "Try remaking Mail::IMAPClient::BodyStructure::Parse.\n";
14              
15             sub new {
16 10     10 1 1008 my $class = shift;
17 10         18 my $bodystructure = shift;
18              
19 10 50       98 my $self = $parser->start($bodystructure)
20             or return undef;
21              
22 10         207 $self->{_prefix} = "";
23 10 100       48 $self->{_id} = exists $self->{bodystructure} ? $HEAD : 1;
24 10         25 $self->{_top} = 1;
25              
26 10   33     74 bless $self, ref($class) || $class;
27             }
28              
29             sub _get_thingy {
30 91     91   133 my $thingy = shift;
31 91   33     173 my $object = shift || ( ref $thingy ? $thingy : undef );
32              
33 91 50 33     338 unless ( $object && ref $object ) {
34 0         0 warn $@ = "No argument passed to $thingy method.";
35 0         0 return undef;
36             }
37              
38 91 50 33     355 unless ( UNIVERSAL::isa( $object, 'HASH' ) && exists $object->{$thingy} ) {
39 0 0       0 my $a = $thingy =~ /^[aeiou]/i ? 'an' : 'a';
40 0 0       0 my $has = ref $object eq 'HASH' ? join( ", ", keys %$object ) : '';
41 0 0       0 warn $@ =
42             ref($object)
43             . " $object does not have $a $thingy. "
44             . ( $has ? "It has $has" : '' );
45 0         0 return undef;
46             }
47              
48 91         186 my $value = $object->{$thingy};
49 91         156 $value =~ s/\\ ( [\\\(\)"\x0d\x0a] )/$1/gx;
50 91         157 $value =~ s/^"(.*)"$/$1/;
51 91         258 $value;
52             }
53              
54             BEGIN {
55 1     1   14 no strict 'refs';
  1         2  
  1         92  
56 1     1   5 foreach my $datum (
57             qw/ bodytype bodysubtype bodyparms bodydisp bodyid bodydesc bodyenc
58             bodysize bodylang envelopestruct textlines /
59             )
60             {
61 11     91   1148 *$datum = sub { _get_thingy( $datum, @_ ) };
  91         1203  
62             }
63             }
64              
65             sub parts {
66 7     7 0 3634 my $self = shift;
67 0         0 return wantarray ? @{ $self->{PartsList} } : $self->{PartsList}
68 7 0       32 if exists $self->{PartsList};
    50          
69              
70 7         16 my @parts;
71 7         24 $self->{PartsList} = \@parts;
72              
73             # BUG?: should this default to ($HEAD, TEXT)
74 7 50       30 unless ( exists $self->{bodystructure} ) {
75 0         0 $self->{PartsIndex}{1} = $self;
76 0         0 @parts = ( $HEAD, 1 );
77 0 0       0 return wantarray ? @parts : \@parts;
78             }
79              
80 7         26 foreach my $p ( $self->bodystructure ) {
81 87         164 my $id = $p->id;
82 87         159 push @parts, $id;
83 87         234 $self->{PartsIndex}{$id} = $p;
84 87   50     158 my $type = uc $p->bodytype || '';
85              
86 87 100       231 push @parts, "$id.$HEAD"
87             if $type eq 'MESSAGE';
88             }
89              
90 7 50       91 wantarray ? @parts : \@parts;
91             }
92              
93             sub bodystructure {
94 58     58 1 93 my $self = shift;
95 58         85 my $partno = 0;
96 58         84 my @parts;
97              
98 58 100       129 if ( $self->{_top} ) {
99 7   33     28 $self->{_id} ||= $HEAD;
100 7   33     45 $self->{_prefix} ||= $HEAD;
101 7         12 $partno = 0;
102 7         13 foreach my $b ( @{ $self->{bodystructure} } ) {
  7         24  
103 26         51 $b->{_id} = ++$partno;
104 26         68 $b->{_prefix} = $partno;
105 26         60 push @parts, $b, $b->bodystructure;
106             }
107 7 50       43 return wantarray ? @parts : \@parts;
108             }
109              
110 51   50     107 my $prefix = $self->{_prefix} || "";
111 51         207 $prefix =~ s/\.?$/./;
112              
113 51         90 foreach my $p ( @{ $self->{bodystructure} } ) {
  51         118  
114 61         90 $partno++;
115              
116             # BUG?: old code didn't add .TEXT sections, should we skip these?
117             # - This code needs to be generalised (maybe it belongs in parts()?)
118             # - Should every message should have HEAD (actually MIME) and TEXT?
119             # at least dovecot and iplanet appear to allow this even for
120             # non-multipart sections
121 61         98 my $pno = $partno;
122 61   50     119 my $stype = $self->{bodytype} || "";
123 61   50     168 my $ptype = $p->{bodytype} || "";
124              
125             # a message and the multipart inside of it "collapse together"
126 61 100 100     205 if ( $partno == 1 and $stype eq 'MESSAGE' and $ptype eq 'MULTIPART' ) {
      100        
127 15         25 $pno = "TEXT";
128 15         34 $p->{_prefix} = "$prefix";
129             }
130             else {
131 46         100 $p->{_prefix} = "$prefix$partno";
132             }
133 61   33     255 $p->{_id} ||= "$prefix$pno";
134              
135 61 100       157 push @parts, $p, $p->{bodystructure} ? $p->bodystructure : ();
136             }
137              
138 51 50       171 wantarray ? @parts : \@parts;
139             }
140              
141             sub id {
142 87     87 0 132 my $self = shift;
143             return $self->{_id}
144 87 50       210 if exists $self->{_id};
145              
146             return $HEAD
147 0 0       0 if $self->{_top};
148              
149             # BUG?: can this be removed? ... seems wrong
150 0 0       0 if ( $self->{bodytype} eq 'MULTIPART' ) {
151 0   0     0 my $p = $self->{_id} || $self->{_prefix};
152 0         0 $p =~ s/\.$//;
153 0         0 return $p;
154             }
155             else {
156 0   0     0 return $self->{_id} ||= 1;
157             }
158             }
159              
160             package Mail::IMAPClient::BodyStructure::Part;
161             our @ISA = qw/Mail::IMAPClient::BodyStructure/;
162              
163             package Mail::IMAPClient::BodyStructure::Envelope;
164             our @ISA = qw/Mail::IMAPClient::BodyStructure/;
165              
166             sub new {
167 1     1   3 my ( $class, $envelope ) = @_;
168 1         18 $parser->envelope($envelope);
169             }
170              
171             sub parse_string {
172 3     3   1750 my ( $class, $envelope ) = @_;
173 3 100       23 $envelope = "(" . $envelope . ")" unless ( $envelope =~ /^\(/ );
174 3         31 $parser->envelopestruct($envelope);
175             }
176              
177 0     0   0 sub from_addresses { shift->_addresses( from => 1 ) }
178 0     0   0 sub sender_addresses { shift->_addresses( sender => 1 ) }
179 0     0   0 sub replyto_addresses { shift->_addresses( replyto => 1 ) }
180 4     4   17 sub to_addresses { shift->_addresses( to => 0 ) }
181 0     0   0 sub cc_addresses { shift->_addresses( cc => 0 ) }
182 0     0   0 sub bcc_addresses { shift->_addresses( bcc => 0 ) }
183              
184             sub _addresses($$$) {
185 4     4   13 my ( $self, $name, $isSender ) = @_;
186 4 50       21 ref $self->{$name} eq 'ARRAY'
187             or return ();
188              
189 4         10 my @list;
190 4         8 foreach ( @{ $self->{$name} } ) {
  4         15  
191 4         16 my $pn = $_->personalname;
192 4 100 66     30 my $name = $pn && $pn ne 'NIL' ? "$pn " : '';
193 4         50 push @list, $name . '<' . $_->mailboxname . '@' . $_->hostname . '>';
194             }
195              
196             wantarray ? @list
197 4 50       23 : $isSender ? $list[0]
    50          
198             : \@list;
199             }
200              
201             BEGIN {
202 1     1   9 no strict 'refs';
  1         1  
  1         100  
203 1     1   5 for my $datum (
204             qw(subject inreplyto from messageid bcc date
205             replyto to sender cc)
206             )
207             {
208 24 50   24   630 *$datum = sub { @_ > 1 ? $_[0]->{$datum} = $_[1] : $_[0]->{$datum} }
209 10         122 }
210             }
211              
212             package Mail::IMAPClient::BodyStructure::Address;
213             our @ISA = qw/Mail::IMAPClient::BodyStructure/;
214              
215             for my $datum (qw(personalname mailboxname hostname sourcename)) {
216 1     1   8 no strict 'refs';
  1         2  
  1         83  
217 12     12   55 *$datum = sub { shift->{$datum}; };
218             }
219              
220             1;
221              
222             __END__