1 package Message::2822; |
1 package Message::2822; |
2 |
2 |
3 use 5.010; |
3 use 5.010; |
4 use strict; |
4 use strict; |
5 use warnings; |
5 use warnings; |
|
6 use Hash::Util qw(lock_keys); |
6 use IO::File; |
7 use IO::File; |
7 use if $ENV{DEBUG} => "Smart::Comments"; |
8 use if $ENV{DEBUG} => "Smart::Comments"; |
8 |
9 |
9 my %DATA; |
10 my %DATA = ( |
|
11 fn => {}, |
|
12 fh => {}, |
|
13 header => {}, |
|
14 body_pos => {}, |
|
15 ); |
|
16 |
|
17 lock_keys %DATA; |
|
18 |
10 |
19 |
11 sub new { |
20 sub new { |
12 my $class = ref $_[0] ? ref shift : shift; |
21 my $class = ref $_[0] ? ref shift : shift; |
13 my $this = bless \(my $x) => $class; |
22 my $self = bless \(my $x) => $class; |
14 my %arg = @_; |
23 my %arg = @_; |
15 |
24 |
16 $DATA{$this}{file} = $arg{file}; |
25 $DATA{fn}{$self} = $arg{file}; |
17 $DATA{$this}{fh} = IO::File->new($DATA{$this}{file}) |
26 $DATA{fh}{$self} = my $fh = IO::File->new($DATA{fn}{$self}) |
18 or die "Can't open $DATA{$this}{file}: $!\n"; |
27 or die "Can't open $DATA{fn}{$self}: $!\n"; |
19 |
28 |
20 local $/ = ""; |
29 local $/ = ""; |
21 my $_ = $DATA{$this}{fh}->getline(); |
30 $DATA{header}{$self} = <$fh>; |
|
31 $DATA{body_pos}{$self} = tell($fh); |
22 |
32 |
23 foreach (split /\n(?=\S)/, $_) { |
33 return $self; |
24 my (undef, $k, $v) = split /(^(?:\S+:|(?i:from )))/, $_; |
|
25 push @{$DATA{$this}{header_fields}}, $k; |
|
26 $DATA{$this}{header}{$k} = $v; |
|
27 } |
|
28 |
|
29 return $this; |
|
30 } |
34 } |
31 |
35 |
32 sub header_fields { |
36 sub __header_fields { |
33 my $this = shift; |
37 my $self = shift; |
34 return @{$DATA{$this}{header_fields}}; |
38 my %h; |
|
39 @h{$DATA{header}{$self} |
|
40 =~ /^(\S+?[: ])/mg} = (); |
|
41 return keys %h; |
35 } |
42 } |
36 |
43 |
37 sub header_content { |
44 sub header_content { |
38 my $this = shift; |
45 my $self = shift; |
39 my $field = shift; |
46 my $field = shift; |
40 |
47 |
41 my $_ = $DATA{$this}{header}{$field}; |
48 ### assert: $field =~ /[: ]$/ |
42 |
49 |
43 if (not defined) { |
50 # FIXME: not sure if the space following the header field name |
44 ($field) = grep /^$field$/i => $this->header_fields(); |
51 # is optional or required |
45 $_ = $DATA{$this}{header}{$field} |
52 return $DATA{header}{$self} |
46 } |
53 =~ /^$field\s+(.*?)(?=^\S)/imsg; |
|
54 } |
47 |
55 |
48 /^\s*(.*?)\s*$/m; |
56 sub orig_header { |
49 return $1; |
57 my $self = shift; |
|
58 my $fh = $DATA{fh}{$self}; |
|
59 seek($fh, 0, 0); |
|
60 local $/ = ""; |
|
61 return <$fh>; |
|
62 } |
|
63 |
|
64 sub orig_body { |
|
65 my $self = shift; |
|
66 my $fh = $DATA{fh}{$self}; |
|
67 seek($fh, $DATA{body_pos}{$self}, 0); |
|
68 local $/ = undef; |
|
69 return <$fh>; |
50 } |
70 } |
51 |
71 |
52 sub DESTROY { |
72 sub DESTROY { |
53 my $this = shift; |
73 my $self = shift; |
54 delete $DATA{$this}; |
74 foreach (keys %DATA) { |
|
75 delete $DATA{$_}{$self} |
|
76 } |
55 } |
77 } |
56 |
78 |
|
79 1; |
57 |
80 |
58 1; |
81 __END__ |
|
82 |
|
83 =head1 NAME |
|
84 |
|
85 Message::2822 - simple parser for 2822 messages |
|
86 |
|
87 =head1 SYNOPSIS |
|
88 |
|
89 use Message::2822; |
|
90 |
|
91 my $msg = Message::2822->new(file => "mail.eml"); |
|
92 |
|
93 my @received = $msg->header_content("received:"); |
|
94 my @from_ = $msg->header_content("from "); |
|
95 my @from = $msg->header_content("from:"); |
|
96 |
|
97 =head1 DESCRIPTION |
|
98 |
|
99 This is a simple parser for RFC2822 messages. I'm sure, such parsers |
|
100 exists already about one million times. Here is yet another one. |
|
101 |
|
102 =head1 METHODS |
|
103 |
|
104 =over |
|
105 |
|
106 =item B<new>(file => I<file>) |
|
107 |
|
108 The construcor. The file is opened r/o and read. The file will not be |
|
109 closed until the object disappears. |
|
110 |
|
111 =item @list = B<header_content>(I<field>) |
|
112 |
|
113 Returns a list (*always* a list) with the contents of the specified |
|
114 header field. The I<field> has to include the colon ":" or space " ", |
|
115 since it is considered a part of the field name. I<field> is case |
|
116 insensitive! |
|
117 |
|
118 =item $scalar = $B<orig_header>() |
|
119 |
|
120 Returns the original header as it is. |
|
121 |
|
122 =item $body = B<orig_body>() |
|
123 |
|
124 Returns the original body as it is. |
|
125 |
|
126 =back |
|
127 |
|
128 =head1 AUTHOR |
|
129 |
|
130 Heiko Schlittermann L<hs@schlittermann.de> |