File Coverage

blib/lib/Email/Simple.pm
Criterion Covered Total %
statement 81 81 100.0
branch 14 14 100.0
condition 10 13 76.9
subroutine 21 21 100.0
pod 9 9 100.0
total 135 138 97.8


line stmt bran cond sub pod time code
1 20     20   200109 use 5.008;
  20         91  
2 20     20   76 use strict;
  20         27  
  20         302  
3 20     20   71 use warnings;
  20         26  
  20         685  
4             package Email::Simple;
5             # ABSTRACT: simple parsing of RFC2822 message format and headers
6             $Email::Simple::VERSION = '2.216';
7 20     20   94 use Carp ();
  20         26  
  20         294  
8              
9 20     20   5834 use Email::Simple::Creator;
  20         36  
  20         416  
10 20     20   6052 use Email::Simple::Header;
  20         37  
  20         9891  
11              
12             our $GROUCHY = 0;
13              
14             # We are liberal in what we accept.
15 60     60   157 sub __crlf_re { qr/\x0a\x0d|\x0d\x0a|\x0a|\x0d/; }
16              
17             #pod =head1 SYNOPSIS
18             #pod
19             #pod use Email::Simple;
20             #pod my $email = Email::Simple->new($text);
21             #pod
22             #pod my $from_header = $email->header("From");
23             #pod my @received = $email->header("Received");
24             #pod
25             #pod $email->header_set("From", 'Simon Cozens ');
26             #pod
27             #pod my $old_body = $email->body;
28             #pod $email->body_set("Hello world\nSimon");
29             #pod
30             #pod print $email->as_string;
31             #pod
32             #pod ...or, to create a message from scratch...
33             #pod
34             #pod my $email = Email::Simple->create(
35             #pod header => [
36             #pod From => 'casey@geeknest.com',
37             #pod To => 'drain@example.com',
38             #pod Subject => 'Message in a bottle',
39             #pod ],
40             #pod body => '...',
41             #pod );
42             #pod
43             #pod $email->header_set( 'X-Content-Container' => 'bottle/glass' );
44             #pod
45             #pod print $email->as_string;
46             #pod
47             #pod =head1 DESCRIPTION
48             #pod
49             #pod The Email:: namespace was begun as a reaction against the increasing complexity
50             #pod and bugginess of Perl's existing email modules. C modules are meant
51             #pod to be simple to use and to maintain, pared to the bone, fast, minimal in their
52             #pod external dependencies, and correct.
53             #pod
54             #pod =method new
55             #pod
56             #pod my $email = Email::Simple->new($message, \%arg);
57             #pod
58             #pod This method parses an email from a scalar containing an RFC2822 formatted
59             #pod message and returns an object. C<$message> may be a reference to a message
60             #pod string, in which case the string will be altered in place. This can result in
61             #pod significant memory savings.
62             #pod
63             #pod If you want to create a message from scratch, you should use the C>
64             #pod method.
65             #pod
66             #pod Valid arguments are:
67             #pod
68             #pod header_class - the class used to create new header objects
69             #pod The named module is not 'require'-ed by Email::Simple!
70             #pod
71             #pod =cut
72              
73             sub new {
74 49     49 1 11547 my ($class, $text, $arg) = @_;
75 49   50     240 $arg ||= {};
76              
77 49 100       260 Carp::croak 'Unable to parse undefined message' if ! defined $text;
78              
79 48 100 100     163 my $text_ref = (ref $text || '' eq 'SCALAR') ? $text : \$text;
80              
81 48         104 my ($pos, $mycrlf) = $class->_split_head_from_body($text_ref);
82              
83 48         138 my $self = bless { mycrlf => $mycrlf } => $class;
84              
85 48         66 my $head;
86 48 100       83 if (defined $pos) {
87 39         130 $head = substr $$text_ref, 0, $pos, '';
88 39         71 substr($head, -(length $mycrlf)) = '';
89             } else {
90 9         16 $head = $$text_ref;
91 9         14 $text_ref = \'';
92             }
93              
94 48   33     169 my $header_class = $arg->{header_class} || $self->default_header_class;
95              
96 48         125 $self->header_obj_set(
97             $header_class->new(\$head, { crlf => $self->crlf })
98             );
99              
100 48         139 $self->body_set($text_ref);
101              
102 48         152 return $self;
103             }
104              
105             # Given the text of an email, return ($pos, $crlf) where $pos is the position
106             # at which the body text begins and $crlf is the type of newline used in the
107             # message.
108             sub _split_head_from_body {
109 54     54   2341 my ($self, $text_ref) = @_;
110              
111             # For body/header division, see RFC 2822, section 2.1
112             #
113             # Honestly, are we *ever* going to have LFCR messages?? -- rjbs, 2015-10-11
114 54         160 my $re = qr{\x0a\x0d\x0a\x0d|\x0d\x0a\x0d\x0a|\x0d\x0d|\x0a\x0a};
115              
116 54 100       839 if ($$text_ref =~ /($re)/gsm) {
117 44         163 my $crlf = substr $1, 0, length($1)/2;
118 44         180 return (pos($$text_ref), $crlf);
119             } else {
120              
121             # The body is, of course, optional.
122 10         29 my $re = $self->__crlf_re;
123 10         149 $$text_ref =~ /($re)/gsm;
124 10   100     75 return (undef, ($1 || "\n"));
125             }
126             }
127              
128             #pod =method create
129             #pod
130             #pod my $email = Email::Simple->create(header => [ @headers ], body => '...');
131             #pod
132             #pod This method is a constructor that creates an Email::Simple object
133             #pod from a set of named parameters. The C
parameter's value is a
134             #pod list reference containing a set of headers to be created. The C
135             #pod parameter's value is a scalar value holding the contents of the message
136             #pod body. Line endings in the body will normalized to CRLF.
137             #pod
138             #pod If no C header is specified, one will be provided for you based on the
139             #pod C of the local machine. This is because the C field is a required
140             #pod header and is a pain in the neck to create manually for every message. The
141             #pod C field is also a required header, but it is I provided for you.
142             #pod
143             #pod =cut
144              
145             our $CREATOR = 'Email::Simple::Creator';
146              
147             sub create {
148 9     9 1 3273 my ($class, %args) = @_;
149              
150             # We default it in here as well as below because by having it here, then we
151             # know that if there are no other headers, we'll get the proper CRLF.
152             # Otherwise, we get a message with incorrect CRLF. -- rjbs, 2007-07-13
153 9   100     25 my $headers = $args{header} || [ Date => $CREATOR->_date_header ];
154 9   100     100 my $body = $args{body} || '';
155              
156 9         10 my $empty = q{};
157 9         11 my $header = \$empty;
158              
159 9         26 for my $idx (map { $_ * 2 } 0 .. @$headers / 2 - 1) {
  21         34  
160 21         35 my ($key, $value) = @$headers[ $idx, $idx + 1 ];
161 21         51 $CREATOR->_add_to_header($header, $key, $value);
162             }
163              
164 9         24 $CREATOR->_finalize_header($header);
165              
166 9         19 my $email = $class->new($header);
167              
168 9 100       16 $email->header_raw_set(Date => $CREATOR->_date_header)
169             unless defined $email->header_raw('Date');
170              
171 9         22 $body = (join $CREATOR->_crlf, split /\x0d\x0a|\x0a\x0d|\x0a|\x0d/, $body)
172             . $CREATOR->_crlf;
173              
174 9         25 $email->body_set($body);
175              
176 9         21 return $email;
177             }
178              
179              
180             #pod =method header_obj
181             #pod
182             #pod my $header = $email->header_obj;
183             #pod
184             #pod This method returns the object representing the email's header. For the
185             #pod interface for this object, see L.
186             #pod
187             #pod =cut
188              
189             sub header_obj {
190 135     135 1 195 my ($self) = @_;
191 135         361 return $self->{header};
192             }
193              
194             # Probably needs to exist in perpetuity for modules released during the "__head
195             # is tentative" phase, until we have a way to force modules below us on the
196             # dependency tree to upgrade. i.e., never and/or in Perl 6 -- rjbs, 2006-11-28
197 20     20   1341 BEGIN { *__head = \&header_obj }
198              
199             #pod =method header_obj_set
200             #pod
201             #pod $email->header_obj_set($new_header_obj);
202             #pod
203             #pod This method substitutes the given new header object for the email's existing
204             #pod header object.
205             #pod
206             #pod =cut
207              
208             sub header_obj_set {
209 48     48 1 89 my ($self, $obj) = @_;
210 48         74 $self->{header} = $obj;
211             }
212              
213             #pod =method header
214             #pod
215             #pod my @values = $email->header($header_name);
216             #pod my $first = $email->header($header_name);
217             #pod my $value = $email->header($header_name, $index);
218             #pod
219             #pod In list context, this returns every value for the named header. In scalar
220             #pod context, it returns the I value for the named header. If second
221             #pod parameter is specified then instead I value it returns value at
222             #pod position C<$index> (negative C<$index> is from the end).
223             #pod
224             #pod =method header_set
225             #pod
226             #pod $email->header_set($field, $line1, $line2, ...);
227             #pod
228             #pod Sets the header to contain the given data. If you pass multiple lines
229             #pod in, you get multiple headers, and order is retained. If no values are given to
230             #pod set, the header will be removed from to the message entirely.
231             #pod
232             #pod =method header_raw
233             #pod
234             #pod This is another name (and the preferred one) for C
.
235             #pod
236             #pod =method header_raw_set
237             #pod
238             #pod This is another name (and the preferred one) for C.
239             #pod
240             #pod =method header_raw_prepend
241             #pod
242             #pod $email->header_raw_prepend($field => $value);
243             #pod
244             #pod This method adds a new instance of the name field as the first field in the
245             #pod header.
246             #pod
247             #pod =method header_names
248             #pod
249             #pod my @header_names = $email->header_names;
250             #pod
251             #pod This method returns the list of header names currently in the email object.
252             #pod These names can be passed to the C
method one-at-a-time to get header
253             #pod values. You are guaranteed to get a set of headers that are unique. You are not
254             #pod guaranteed to get the headers in any order at all.
255             #pod
256             #pod For backwards compatibility, this method can also be called as B.
257             #pod
258             #pod =method header_pairs
259             #pod
260             #pod my @headers = $email->header_pairs;
261             #pod
262             #pod This method returns a list of pairs describing the contents of the header.
263             #pod Every other value, starting with and including zeroth, is a header name and the
264             #pod value following it is the header value.
265             #pod
266             #pod =method header_raw_pairs
267             #pod
268             #pod This is another name (and the preferred one) for C.
269             #pod
270             #pod =cut
271              
272             BEGIN {
273 20     20   118 no strict 'refs';
  20         32  
  20         1517  
274 20     20   59 for my $method (qw(
275             header_raw header
276             header_raw_set header_set
277             header_raw_prepend
278             header_raw_pairs header_pairs
279             header_names
280             )) {
281 160     86   528 *$method = sub { (shift)->header_obj->$method(@_) };
  86         6575  
282             }
283 20         3469 *headers = \&header_names;
284             }
285              
286             #pod =method body
287             #pod
288             #pod Returns the body text of the mail.
289             #pod
290             #pod =cut
291              
292             sub body {
293 60     60 1 372 my ($self) = @_;
294 60 100       59 return (defined ${ $self->{body} }) ? ${ $self->{body} } : '';
  60         119  
  58         339  
295             }
296              
297             #pod =method body_set
298             #pod
299             #pod Sets the body text of the mail.
300             #pod
301             #pod =cut
302              
303             sub body_set {
304 68     68 1 105 my ($self, $text) = @_;
305 68 100       132 my $text_ref = ref $text ? $text : \$text;
306 68         103 $self->{body} = $text_ref;
307 68         90 return;
308             }
309              
310             #pod =method as_string
311             #pod
312             #pod Returns the mail as a string, reconstructing the headers.
313             #pod
314             #pod =cut
315              
316             sub as_string {
317 49     49 1 7736 my $self = shift;
318 49         83 return $self->header_obj->as_string . $self->crlf . $self->body;
319             }
320              
321             #pod =method crlf
322             #pod
323             #pod This method returns the type of newline used in the email. It is an accessor
324             #pod only.
325             #pod
326             #pod =cut
327              
328 105     105 1 413 sub crlf { $_[0]->{mycrlf} }
329              
330             #pod =method default_header_class
331             #pod
332             #pod This returns the class used, by default, for header objects, and is provided
333             #pod for subclassing. The default default is Email::Simple::Header.
334             #pod
335             #pod =cut
336              
337 48     48 1 139 sub default_header_class { 'Email::Simple::Header' }
338              
339             1;
340              
341             =pod
342              
343             =encoding UTF-8
344              
345             =head1 NAME
346              
347             Email::Simple - simple parsing of RFC2822 message format and headers
348              
349             =head1 VERSION
350              
351             version 2.216
352              
353             =head1 SYNOPSIS
354              
355             use Email::Simple;
356             my $email = Email::Simple->new($text);
357              
358             my $from_header = $email->header("From");
359             my @received = $email->header("Received");
360              
361             $email->header_set("From", 'Simon Cozens ');
362              
363             my $old_body = $email->body;
364             $email->body_set("Hello world\nSimon");
365              
366             print $email->as_string;
367              
368             ...or, to create a message from scratch...
369              
370             my $email = Email::Simple->create(
371             header => [
372             From => 'casey@geeknest.com',
373             To => 'drain@example.com',
374             Subject => 'Message in a bottle',
375             ],
376             body => '...',
377             );
378              
379             $email->header_set( 'X-Content-Container' => 'bottle/glass' );
380              
381             print $email->as_string;
382              
383             =head1 DESCRIPTION
384              
385             The Email:: namespace was begun as a reaction against the increasing complexity
386             and bugginess of Perl's existing email modules. C modules are meant
387             to be simple to use and to maintain, pared to the bone, fast, minimal in their
388             external dependencies, and correct.
389              
390             =head1 METHODS
391              
392             =head2 new
393              
394             my $email = Email::Simple->new($message, \%arg);
395              
396             This method parses an email from a scalar containing an RFC2822 formatted
397             message and returns an object. C<$message> may be a reference to a message
398             string, in which case the string will be altered in place. This can result in
399             significant memory savings.
400              
401             If you want to create a message from scratch, you should use the C>
402             method.
403              
404             Valid arguments are:
405              
406             header_class - the class used to create new header objects
407             The named module is not 'require'-ed by Email::Simple!
408              
409             =head2 create
410              
411             my $email = Email::Simple->create(header => [ @headers ], body => '...');
412              
413             This method is a constructor that creates an Email::Simple object
414             from a set of named parameters. The C
parameter's value is a
415             list reference containing a set of headers to be created. The C
416             parameter's value is a scalar value holding the contents of the message
417             body. Line endings in the body will normalized to CRLF.
418              
419             If no C header is specified, one will be provided for you based on the
420             C of the local machine. This is because the C field is a required
421             header and is a pain in the neck to create manually for every message. The
422             C field is also a required header, but it is I provided for you.
423              
424             =head2 header_obj
425              
426             my $header = $email->header_obj;
427              
428             This method returns the object representing the email's header. For the
429             interface for this object, see L.
430              
431             =head2 header_obj_set
432              
433             $email->header_obj_set($new_header_obj);
434              
435             This method substitutes the given new header object for the email's existing
436             header object.
437              
438             =head2 header
439              
440             my @values = $email->header($header_name);
441             my $first = $email->header($header_name);
442             my $value = $email->header($header_name, $index);
443              
444             In list context, this returns every value for the named header. In scalar
445             context, it returns the I value for the named header. If second
446             parameter is specified then instead I value it returns value at
447             position C<$index> (negative C<$index> is from the end).
448              
449             =head2 header_set
450              
451             $email->header_set($field, $line1, $line2, ...);
452              
453             Sets the header to contain the given data. If you pass multiple lines
454             in, you get multiple headers, and order is retained. If no values are given to
455             set, the header will be removed from to the message entirely.
456              
457             =head2 header_raw
458              
459             This is another name (and the preferred one) for C
.
460              
461             =head2 header_raw_set
462              
463             This is another name (and the preferred one) for C.
464              
465             =head2 header_raw_prepend
466              
467             $email->header_raw_prepend($field => $value);
468              
469             This method adds a new instance of the name field as the first field in the
470             header.
471              
472             =head2 header_names
473              
474             my @header_names = $email->header_names;
475              
476             This method returns the list of header names currently in the email object.
477             These names can be passed to the C
method one-at-a-time to get header
478             values. You are guaranteed to get a set of headers that are unique. You are not
479             guaranteed to get the headers in any order at all.
480              
481             For backwards compatibility, this method can also be called as B.
482              
483             =head2 header_pairs
484              
485             my @headers = $email->header_pairs;
486              
487             This method returns a list of pairs describing the contents of the header.
488             Every other value, starting with and including zeroth, is a header name and the
489             value following it is the header value.
490              
491             =head2 header_raw_pairs
492              
493             This is another name (and the preferred one) for C.
494              
495             =head2 body
496              
497             Returns the body text of the mail.
498              
499             =head2 body_set
500              
501             Sets the body text of the mail.
502              
503             =head2 as_string
504              
505             Returns the mail as a string, reconstructing the headers.
506              
507             =head2 crlf
508              
509             This method returns the type of newline used in the email. It is an accessor
510             only.
511              
512             =head2 default_header_class
513              
514             This returns the class used, by default, for header objects, and is provided
515             for subclassing. The default default is Email::Simple::Header.
516              
517             =head1 CAVEATS
518              
519             Email::Simple handles only RFC2822 formatted messages. This means you cannot
520             expect it to cope well as the only parser between you and the outside world,
521             say for example when writing a mail filter for invocation from a .forward file
522             (for this we recommend you use L anyway).
523              
524             =head1 AUTHORS
525              
526             =over 4
527              
528             =item *
529              
530             Simon Cozens
531              
532             =item *
533              
534             Casey West
535              
536             =item *
537              
538             Ricardo SIGNES
539              
540             =back
541              
542             =head1 CONTRIBUTORS
543              
544             =for stopwords Brian Cassidy Christian Walde Marc Bradshaw Michael Stevens Pali Ricardo SIGNES Ronald F. Guilmette William Yardley
545              
546             =over 4
547              
548             =item *
549              
550             Brian Cassidy
551              
552             =item *
553              
554             Christian Walde
555              
556             =item *
557              
558             Marc Bradshaw
559              
560             =item *
561              
562             Michael Stevens
563              
564             =item *
565              
566             Pali
567              
568             =item *
569              
570             Ricardo SIGNES
571              
572             =item *
573              
574             Ronald F. Guilmette
575              
576             =item *
577              
578             William Yardley
579              
580             =back
581              
582             =head1 COPYRIGHT AND LICENSE
583              
584             This software is copyright (c) 2003 by Simon Cozens.
585              
586             This is free software; you can redistribute it and/or modify it under
587             the same terms as the Perl 5 programming language system itself.
588              
589             =cut
590              
591             __END__