File Coverage

blib/lib/Convert/TNEF.pm
Criterion Covered Total %
statement 166 237 70.0
branch 64 136 47.1
condition 24 58 41.4
subroutine 20 25 80.0
pod 0 6 0.0
total 274 462 59.3


line stmt bran cond sub pod time code
1             # Convert::TNEF.pm
2             #
3             # Copyright (c) 1999 Douglas Wilson <dougw@cpan.org>. All rights reserved.
4             # This program is free software; you can redistribute it and/or
5             # modify it under the same terms as Perl itself.
6              
7             package Convert::TNEF;
8              
9 1     1   17 use strict;
  1         15  
  1         15  
10 1     1   707 use integer;
  1         11  
  1         19  
11 1         15 use vars qw(
12             $VERSION
13             $TNEF_SIGNATURE
14             $TNEF_PURE
15             $LVL_MESSAGE
16             $LVL_ATTACHMENT
17             $errstr
18             $g_file_cnt
19             %dflts
20             %atp
21             %att
22             %att_name
23 1     1   17 );
  1         9  
24              
25 1     1   17 use Carp;
  1         9  
  1         19  
26 1     1   44 use IO::Wrap;
  1         10  
  1         27  
27 1     1   17 use File::Spec;
  1         9  
  1         24  
28 1     1   37 use MIME::Body;
  1         10  
  1         21  
29              
30             $VERSION = '0.17';
31              
32             # Set some TNEF constants. Everything turned
33             # out to be in little endian order, so I just added
34             # 'reverse' everywhere that I needed to
35             # instead of reversing the hex codes.
36             $TNEF_SIGNATURE = reverse pack( 'H*', '223E9F78' );
37             $TNEF_PURE      = reverse pack( 'H*', '00010000' );
38              
39             $LVL_MESSAGE    = pack( 'H*', '01' );
40             $LVL_ATTACHMENT = pack( 'H*', '02' );
41              
42             %atp = (
43               Triples => pack( 'H*', '0000' ),
44               String => pack( 'H*', '0001' ),
45               Text => pack( 'H*', '0002' ),
46               Date => pack( 'H*', '0003' ),
47               Short => pack( 'H*', '0004' ),
48               Long => pack( 'H*', '0005' ),
49               Byte => pack( 'H*', '0006' ),
50               Word => pack( 'H*', '0007' ),
51               Dword => pack( 'H*', '0008' ),
52               Max => pack( 'H*', '0009' ),
53             );
54              
55             for ( keys %atp ) {
56               $atp{$_} = reverse $atp{$_};
57             }
58              
59             sub _ATT {
60 33     33   306   my ( $att, $id ) = @_;
61 33         679   return reverse($id) . $att;
62             }
63              
64             # The side comments are 'MAPI' equivalents
65             %att = (
66               Null => _ATT( pack( 'H*', '0000' ), pack( 'H4', '0000' ) ),
67             # PR_ORIGINATOR_RETURN_ADDRESS
68               From => _ATT( $atp{Triples}, pack( 'H*', '8000' ) ),
69             # PR_SUBJECT
70               Subject => _ATT( $atp{String}, pack( 'H*', '8004' ) ),
71             # PR_CLIENT_SUBMIT_TIME
72               DateSent => _ATT( $atp{Date}, pack( 'H*', '8005' ) ),
73             # PR_MESSAGE_DELIVERY_TIME
74               DateRecd => _ATT( $atp{Date}, pack( 'H*', '8006' ) ),
75             # PR_MESSAGE_FLAGS
76               MessageStatus => _ATT( $atp{Byte}, pack( 'H*', '8007' ) ),
77             # PR_MESSAGE_CLASS
78               MessageClass => _ATT( $atp{Word}, pack( 'H*', '8008' ) ),
79             # PR_MESSAGE_ID
80               MessageID => _ATT( $atp{String}, pack( 'H*', '8009' ) ),
81             # PR_PARENT_ID
82               ParentID => _ATT( $atp{String}, pack( 'H*', '800A' ) ),
83             # PR_CONVERSATION_ID
84               ConversationID => _ATT( $atp{String}, pack( 'H*', '800B' ) ),
85               Body => _ATT( $atp{Text}, pack( 'H*', '800C' ) ), # PR_BODY
86             # PR_IMPORTANCE
87               Priority => _ATT( $atp{Short}, pack( 'H*', '800D' ) ),
88             # PR_ATTACH_DATA_xxx
89               AttachData => _ATT( $atp{Byte}, pack( 'H*', '800F' ) ),
90             # PR_ATTACH_FILENAME
91               AttachTitle => _ATT( $atp{String}, pack( 'H*', '8010' ) ),
92             # PR_ATTACH_RENDERING
93               AttachMetaFile => _ATT( $atp{Byte}, pack( 'H*', '8011' ) ),
94             # PR_CREATION_TIME
95               AttachCreateDate => _ATT( $atp{Date}, pack( 'H*', '8012' ) ),
96             # PR_LAST_MODIFICATION_TIME
97               AttachModifyDate => _ATT( $atp{Date}, pack( 'H*', '8013' ) ),
98             # PR_LAST_MODIFICATION_TIME
99               DateModified => _ATT( $atp{Date}, pack( 'H*', '8020' ) ),
100             #PR_ATTACH_TRANSPORT_NAME
101               AttachTransportFilename => _ATT( $atp{Byte}, pack( 'H*', '9001' ) ),
102               AttachRenddata => _ATT( $atp{Byte}, pack( 'H*', '9002' ) ),
103               MAPIProps => _ATT( $atp{Byte}, pack( 'H*', '9003' ) ),
104             # PR_MESSAGE_RECIPIENTS
105               RecipTable => _ATT( $atp{Byte}, pack( 'H*', '9004' ) ),
106               Attachment => _ATT( $atp{Byte}, pack( 'H*', '9005' ) ),
107               TnefVersion => _ATT( $atp{Dword}, pack( 'H*', '9006' ) ),
108               OemCodepage => _ATT( $atp{Byte}, pack( 'H*', '9007' ) ),
109             # PR_ORIG_MESSAGE_CLASS
110               OriginalMessageClass => _ATT( $atp{Word}, pack( 'H*', '0006' ) ),
111              
112             # PR_RCVD_REPRESENTING_xxx or PR_SENT_REPRESENTING_xxx
113               Owner => _ATT( $atp{Byte}, pack( 'H*', '0000' ) ),
114             # PR_SENT_REPRESENTING_xxx
115               SentFor => _ATT( $atp{Byte}, pack( 'H*', '0001' ) ),
116             # PR_RCVD_REPRESENTING_xxx
117               Delegate => _ATT( $atp{Byte}, pack( 'H*', '0002' ) ),
118             # PR_DATE_START
119               DateStart => _ATT( $atp{Date}, pack( 'H*', '0006' ) ),
120               DateEnd => _ATT( $atp{Date}, pack( 'H*', '0007' ) ), # PR_DATE_END
121             # PR_OWNER_APPT_ID
122               AidOwner => _ATT( $atp{Long}, pack( 'H*', '0008' ) ),
123             # PR_RESPONSE_REQUESTED
124               RequestRes => _ATT( $atp{Short}, pack( 'H*', '0009' ) ),
125             );
126              
127             # Create reverse lookup table
128             %att_name = reverse %att;
129              
130             # Global counter for creating file names
131             $g_file_cnt = 0;
132              
133             # Set some package global defaults for new objects
134             # which can be overridden for any individual object.
135             %dflts = (
136               debug => 0,
137               debug_max_display => 1024,
138               debug_max_line_size => 64,
139               ignore_checksum => 0,
140               display_after_err => 32,
141               output_to_core => 4096,
142               output_dir => File::Spec->curdir,
143               output_prefix => "tnef",
144               buffer_size => 1024,
145             );
146              
147             # Make a file name
148             sub _mk_fname {
149 0     0   0   my $parms = shift;
150 0         0   File::Spec->catfile( $parms->{output_dir},
151                 $parms->{output_prefix} . "-" . $$ . "-"
152                   . ++$g_file_cnt . ".doc" );
153             }
154              
155             sub _rtn_err {
156 1     1   11   my ( $errmsg, $fh, $parms ) = @_;
157 1         10   $errstr = $errmsg;
158 1 50       74   if ( $parms->{debug} ) {
159 0   0     0     my $read_size = $parms->{display_after_err} || 32;
160 0         0     my $data;
161 0         0     $fh->read( $data, $read_size );
162 0         0     print "Error: $errstr\n";
163 0         0     print "Data:\n";
164 0         0     print $1, "\n" while $data =~
165                   /([^\r\n]{0,$parms->{debug_max_line_size}})\r?\n?/g;
166 0         0     print "HData:\n";
167 0         0     my $hdata = unpack( "H*", $data );
168 0         0     print $1, "\n"
169                   while $hdata =~ /(.{0,$parms->{debug_max_line_size}})/g;
170               }
171 1         31   return undef;
172             }
173              
174             sub _read_err {
175 0     0   0   my ( $bytes, $fh, $errmsg ) = @_;
176 0 0       0   $errstr =
177                 ( defined $bytes ) ? "Premature EOF" : "Read Error:" . $errmsg;
178 0         0   return undef;
179             }
180              
181             sub read_ent {
182 0 0 0 0 0 0   croak "Usage: Convert::TNEF->read_ent(entity, parameters) "
183                 unless @_ == 2 or @_ == 3;
184 0         0   my $self = shift;
185 0         0   my ( $ent, $parms ) = @_;
186 0 0       0   my $io = $ent->open("r") or do {
187 0         0     $errstr = "Can't open entity: $!";
188 0         0     return undef;
189               };
190 0         0   my $tnef = $self->read( $io, $parms );
191 0 0       0   $io->close or do {
192 0         0     $errstr = "Error closing handle: $!";
193 0         0     return undef;
194               };
195 0         0   return $tnef;
196             }
197              
198             sub read_in {
199 2 50 66 2 0 55   croak "Usage: Convert::TNEF->read_in(filename, parameters) "
200                 unless @_ == 2 or @_ == 3;
201 2         57   my $self = shift;
202 2         22   my ( $fname, $parms ) = @_;
203 2 50       242   open( INFILE, "<$fname" ) or do {
204 0         0     $errstr = "Can't open $fname: $!";
205 0         0     return undef;
206               };
207 2         25   binmode INFILE;
208 2         30   my $tnef = $self->read( \*INFILE, $parms );
209 2 50       71   close INFILE or do {
210 0         0     $errstr = "Error closing $fname: $!";
211 0         0     return undef;
212               };
213 2         25   return $tnef;
214             }
215              
216             sub read {
217 2 50 33 2 0 38   croak "Usage: Convert::TNEF->read(fh, parameters) "
218                 unless @_ == 2 or @_ == 3;
219 2         20   my $self = shift;
220 2   33     30   my $class = ref($self) || $self;
221 2         21   $self = {};
222 2         34   bless $self, $class;
223 2         20   my ( $fd, $parms ) = @_;
224 2         26   $fd = wraphandle($fd);
225              
226 2         206   my %parms = %dflts;
227 2 100       33   @parms{ keys %$parms } = values %$parms if defined $parms;
228 2         19   $parms = \%parms;
229 2         20   my $debug = $parms{debug};
230 2         19   my $ignore_checksum = $parms{ignore_checksum};
231              
232             # Start of TNEF stream
233 2         18   my $data;
234 2         27   my $num_bytes = $fd->read( $data, 4 );
235 2 50       2118   return _read_err( $num_bytes, $fd, $! ) unless $num_bytes == 4;
236 2 50       34   print "TNEF start: ", unpack( "H*", $data ), "\n" if $debug;
237 2 50       30   return _rtn_err( "Not TNEF-encapsulated", $fd, $parms )
238                 unless $data eq $TNEF_SIGNATURE;
239              
240             # Key
241 2         31   $num_bytes = $fd->read( $data, 2 );
242 2 50       63   return _read_err( $num_bytes, $fd, $! ) unless $num_bytes == 2;
243 2 50       22   print "TNEF key: ", unpack( "H*", $data ), "\n" if $debug;
244              
245             # Start of First Object
246 2         24   $num_bytes = $fd->read( $data, 1 );
247 2 50       41   return _read_err( $num_bytes, $fd, $! ) unless $num_bytes == 1;
248              
249 2         19   my $msg_att = "";
250              
251 2         21   my $is_msg = ( $data eq $LVL_MESSAGE );
252 2         20   my $is_att = ( $data eq $LVL_ATTACHMENT );
253 2 50       21   print "TNEF object start: ", unpack( "H*", $data ), "\n" if $debug;
254 2 50 33     23   return _rtn_err( "Neither a message nor an attachment", $fd,
255                 $parms )
256                 unless $is_msg or $is_att;
257              
258 2         34   my $msg = Convert::TNEF::Data->new;
259 2         18   my @atts;
260              
261             # Current message or attachment in loop
262 2         18   my $ent = $msg;
263              
264             # Read message and attachments
265 24 100       432   LOOP: {
266 2         78     my $type = $is_msg ? 'message' : 'attachment';
267 24 50       215     print "Reading $type attribute\n" if $debug;
268 24         258     $num_bytes = $fd->read( $data, 4 );
269 24 50       458     return _read_err( $num_bytes, $fd, $! ) unless $num_bytes == 4;
270 24         203     my $att_id = $data;
271 24         226     my $att_name = $att_name{$att_id};
272              
273 24 50       214     print "TNEF $type attribute: ", unpack( "H*", $data ), "\n"
274                   if $debug;
275 24 50       225     return _rtn_err( "Bad Attribute found in $type", $fd, $parms )
276                   unless $att_name{$att_id};
277 24 100       297     if ( $att_id eq $att{TnefVersion} ) {
    100          
    100          
278 2 50       49       return _rtn_err( "Version attribute found in attachment", $fd,
279                     $parms )
280                     if $is_att;
281                 } elsif ( $att_id eq $att{MessageClass} ) {
282 2 50       21       return _rtn_err( "MessageClass attribute found in attachment",
283                     $fd, $parms )
284                     if $is_att;
285                 } elsif ( $att_id eq $att{AttachRenddata} ) {
286 1 50       48       return _rtn_err( "AttachRenddata attribute found in message",
287                     $fd, $parms )
288                     if $is_msg;
289 1         18       push @atts, ( $ent = Convert::TNEF::Data->new );
290                 } else {
291 19 50 66     221       return _rtn_err( "AttachRenddata must be first attribute", $fd,
      33        
292                     $parms )
293