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   69197 use warnings;
  1         12  
  1         35  
2 1     1   6 use strict;
  1         2  
  1         52  
3              
4             package Mail::IMAPClient::BodyStructure;
5 1     1   3251 use Mail::IMAPClient::BodyStructure::Parse;
  1         4  
  1         542  
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 9     9 1 1387 my $class = shift;
17 9         25 my $bodystructure = shift;
18              
19 9 50       102 my $self = $parser->start($bodystructure)
20             or return undef;
21              
22 9         201 $self->{_prefix} = "";
23 9 100       50 $self->{_id} = exists $self->{bodystructure} ? $HEAD : 1;
24 9         27 $self->{_top} = 1;
25              
26 9   33     77 bless $self, ref($class) || $class;
27             }
28              
29             sub _get_thingy {
30 89     89   134 my $thingy = shift;
31 89   33     176 my $object = shift || ( ref $thingy ? $thingy : undef );
32              
33 89 50 33     270 unless ( $object && ref $object ) {
34 0         0 warn $@ = "No argument passed to $thingy method.";
35 0         0 return undef;
36             }
37              
38 89 50 33     325 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 89         149 my $value = $object->{$thingy};
49 89         150 $value =~ s/\\ ( [\\\(\)"\x0d\x0a] )/$1/gx;
50 89         137 $value =~ s/^"(.*)"$/$1/;
51 89         232 $value;
52             }
53              
54             BEGIN {
55 1     1   11 no strict 'refs';
  1         2  
  1         88  
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     89   1075 *$datum = sub { _get_thingy( $datum, @_ ) };
  89         1305  
62             }
63             }
64              
65             sub parts {
66 6     6 0 3246 my $self = shift;
67 0         0 return wantarray ? @{ $self->{PartsList} } : $self->{PartsList}
68 6 0       29 if exists $self->{PartsList};
    50          
69              
70 6         14 my @parts;
71 6         27 $self->{PartsList} = \@parts;
72              
73             # BUG?: should this default to ($HEAD, TEXT)
74 6 50       28 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 6         25 foreach my $p ( $self->bodystructure ) {
81 85         158 my $id = $p->id;
82 85         154 push @parts, $id;
83 85         191 $self->{PartsIndex}{$id} = $p;
84 85   50     162 my $type = uc $p->bodytype || '';
85              
86 85 100       221 push @parts, "$id.$HEAD"
87             if $type eq 'MESSAGE';
88             }
89              
90 6 50       80 wantarray ? @parts : \@parts;
91             }
92              
93             sub bodystructure {
94 55     55 1 85 my $self = shift;
95 55         87 my $partno = 0;
96 55         83 my @parts;
97              
98 55 100       111 if ( $self->{_top} ) {
99 6   33     25 $self->{_id} ||= $HEAD;
100 6   33     44 $self->{_prefix} ||= $HEAD;
101 6         12 $partno = 0;
102 6         12 foreach my $b ( @{ $self->{bodystructure} } ) {
  6         24  
103 24         54 $b->{_id} = ++$partno;
104 24         71 $b->{_prefix} = $partno;
105 24         59 push @parts, $b, $b->bodystructure;
106             }
107 6 50       37 return wantarray ? @parts : \@parts;
108             }
109              
110 49   50     109 my $prefix = $self->{_prefix} || "";
111 49         202 $prefix =~ s/\.?$/./;
112              
113 49         85 foreach my $p ( @{ $self->{bodystructure} } ) {
  49         148  
114 61         91 $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         91 my $pno = $partno;
122 61   50     132 my $stype = $self->{bodytype} || "";
123 61   50     173 my $ptype = $p->{bodytype} || "";
124              
125             # a message and the multipart inside of it "collapse together"
126 61 100 100     247 if ( $partno == 1 and $stype eq 'MESSAGE' and $ptype eq 'MULTIPART' ) {
      100        
127 15         28 $pno = "TEXT";
128 15         41 $p->{_prefix} = "$prefix";
129             }
130             else {
131 46         112 $p->{_prefix} = "$prefix$partno";
132             }
133 61   33     258 $p->{_id} ||= "$prefix$pno";
134              
135 61 100       169 push @parts, $p, $p->{bodystructure} ? $p->bodystructure : ();
136             }
137              
138 49 50       172 wantarray ? @parts : \@parts;
139             }
140              
141             sub id {
142 85     85 0 123 my $self = shift;
143             return $self->{_id}
144 85 50       204 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   4 my ( $class, $envelope ) = @_;
168 1         19 $parser->envelope($envelope);
169             }
170              
171             sub parse_string {
172 3     3   1719 my ( $class, $envelope ) = @_;
173 3 100       21 $envelope = "(" . $envelope . ")" unless ( $envelope =~ /^\(/ );
174 3         34 $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   19 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   11 my ( $self, $name, $isSender ) = @_;
186 4 50       19 ref $self->{$name} eq 'ARRAY'
187             or return ();
188              
189 4         7 my @list;
190 4         9 foreach ( @{ $self->{$name} } ) {
  4         14  
191 4         15 my $pn = $_->personalname;
192 4 100 66     24 my $name = $pn && $pn ne 'NIL' ? "$pn " : '';
193 4         17 push @list, $name . '<' . $_->mailboxname . '@' . $_->hostname . '>';
194             }
195              
196             wantarray ? @list
197 4 50       21 : $isSender ? $list[0]
    50          
198             : \@list;
199             }
200              
201             BEGIN {
202 1     1   8 no strict 'refs';
  1         3  
  1         86  
203 1     1   4 for my $datum (
204             qw(subject inreplyto from messageid bcc date
205             replyto to sender cc)
206             )
207             {
208 24 50   24   613 *$datum = sub { @_ > 1 ? $_[0]->{$datum} = $_[1] : $_[0]->{$datum} }
209 10         196 }
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   10 no strict 'refs';
  1         2  
  1         82  
217 12     12   51 *$datum = sub { shift->{$datum}; };
218             }
219              
220             1;
221              
222             __END__