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							if $is_att
294							and !@atts
295							and $att_name ne "AttachRenddata";
296							}
297	24	50				214	print "Got attribute:$att_name{$att_id}\n" if $debug;
298
299	24					249	$num_bytes = $fd->read( $data, 4 );
300	24	50				449	return _read_err( $num_bytes, $fd, $! ) unless $num_bytes == 4;
301
302	24	50				341	print "HLength:", unpack( "H8", $data ), "\n" if $debug;
303	24					255	my $length = unpack( "V", $data );
304	24	50				222	print "Length: $length\n" if $debug;
305
306							# Get the attribute data (returns an object since data may
307							# actually end up in a file)
308	24					185	my $calc_chksum;
309	24	50				231	$data = _build_data( $fd, $length, \$calc_chksum, $parms )
310							or return undef;
311	24	50				634	_debug_print( $length, $att_id, $data, $parms ) if $debug;
312	24					263	$ent->datahandle( $att_name, $data, $length );
313
314	24					306	$num_bytes = $fd->read( $data, 2 );
315	24	50				650	return _read_err( $num_bytes, $fd, $! ) unless $num_bytes == 2;
316	24					203	my $file_chksum = $data;
317	24	50				238	if ($debug) {
318	0					0	print "Calc Chksum:", unpack( "H*", $calc_chksum ), "\n";
319	0					0	print "File Chksum:", unpack( "H*", $file_chksum ), "\n";
320							}
321	24	100	100			364	return _rtn_err( "Bad Checksum", $fd, $parms )
322							unless $calc_chksum eq $file_chksum
323							or $ignore_checksum;
324
325	23					272	my $num_bytes = $fd->read( $data, 1 );
326
327							# EOF (0 bytes) is ok
328	23	50				499	return _read_err( $num_bytes, $fd, $! ) unless defined $num_bytes;
329	23	100				328	last LOOP if $num_bytes < 1;
330	22	50				236	print "Next token:", unpack( "H2", $data ), "\n" if $debug;
331	22					198	$is_msg = ( $data eq $LVL_MESSAGE );
332	22	50	66			413	return _rtn_err( "Found message data in attachment", $fd, $parms )
333							if $is_msg and $is_att;
334	22					188	$is_att = ( $data eq $LVL_ATTACHMENT );
335	22	50	66			273	redo LOOP if $is_msg or $is_att;
336	0					0	return _rtn_err( "Not a TNEF $type", $fd, $parms );
337							}
338
339	1	50				13	print "EOF\n" if $debug;
340
341	1					12	$self->{TN_Message} = $msg;
342	1					10	$self->{TN_Attachments} = \@atts;
343	1					19	return $self;
344							}
345
346							sub _debug_print {
347	0			0		0	my ( $length, $att_id, $data, $parms ) = @_;
348	0	0				0	if ( $length < $parms->{debug_max_display} ) {
349	0					0	$data = $data->data;
350	0	0	0			0	if ( $att_id eq $att{TnefVersion} ) {
		0	0
		0
351	0					0	$data = unpack( "L", $data );
352	0					0	print "Version: $data\n";
353							} elsif ( substr( $att_id, 2 ) eq $atp{Date} and $length == 14 ) {
354	0					0	my ( $yr, $mo, $day, $hr, $min, $sec, $dow ) =
355							unpack( "vvvvvvv", $data );
356	0					0	my $date = join ":", $yr, $mo, $day, $hr, $min, $sec, $dow;
357	0					0	print "Date: $date\n";
358	0					0	print "HDate:", unpack( "H*", $data ), "\n";
359							} elsif ( $att_id eq $att{AttachRenddata} and $length == 14 ) {
360	0					0	my ( $atyp, $ulPosition, $dxWidth, $dyHeight, $dwFlags ) =
361							unpack( "vVvvV", $data );
362	0					0	$data = join ":", $atyp, $ulPosition, $dxWidth, $dyHeight,
363							$dwFlags;
364	0					0	print "AttachRendData: $data\n";
365							} else {
366	0					0	print "Data:\n";
367	0					0	print $1, "\n" while $data =~
368							/([^\r\n]{0,$parms->{debug_max_line_size}})\r?\n?/g;
369	0					0	print "HData:\n";
370	0					0	my $hdata = unpack( "H*", $data );
371	0					0	print $1, "\n"
372							while $hdata =~ /(.{0,$parms->{debug_max_line_size}})/g;
373							}
374							} else {
375	0	0				0	my $io = $data->open("r")
376							or croak "Error opening attachment data handle: $!";
377	0					0	my $buffer;
378	0					0	$io->read( $buffer, $parms->{debug_max_display} );
379	0	0				0	$io->close or croak "Error closing attachment data handle: $!";
380	0					0	print "Data:\n";
381	0					0	print $1, "\n" while $buffer =~
382							/([^\r\n]{0,$parms->{debug_max_line_size}})\r?\n?/sg;
383	0					0	print "HData:\n";
384	0					0	my $hdata = unpack( "H*", $buffer );
385	0					0	print $1, "\n"
386							while $hdata =~ /(.{0,$parms->{debug_max_line_size}})/g;
387							}
388							}
389
390							sub _build_data {
391	24			24		223	my ( $fd, $length, $chksumref, $parms ) = @_;
392	24					209	my $cutoff = $parms->{output_to_core};
393	24					193	my $incore = do {
394	24	50				252	if ( $cutoff eq 'NONE' ) { 0 } #Everything to files
	0	50				0
		50
395	0					0	elsif ( $cutoff eq 'ALL' ) { 1 } #Everything in memory
396	0					0	elsif ( $cutoff < $length ) { 0 } #Large items in files
397	24					204	else { 1 } #Everything else in memory
398							};
399
400							# Just borrow some other objects for the attachment attribute data
401	24	50				404	my $body =
402							($incore)
403							? new MIME::Body::Scalar
404							: new MIME::Body::File _mk_fname($parms);
405	24					1112	$body->binmode(1);
406	24					626	my $io = $body->open("w");
407	24					1371	my $bufsiz = $parms->{buffer_size};
408	24	100				242	$bufsiz = $length if $length < $bufsiz;
409	24					190	my $buffer;
410	24					191	my $chksum = 0;
411
412	24					230	while ( $length > 0 ) {
413	26					269	my $num_bytes = $fd->read( $buffer, $bufsiz );
414	26	50				616	return _read_err( $num_bytes, $fd, $! )
415							unless $num_bytes == $bufsiz;
416	26					284	$io->print($buffer);
417	26					1012	$chksum += unpack( "%16C*", $buffer );
418	26					274	$chksum %= 65536;
419	26					231	$length -= $bufsiz;
420	26	50				312	$bufsiz = $length if $length < $bufsiz;
421							}
422	24					236	$$chksumref = pack( "v", $chksum );
423	24					312	$io->close;
424	24					245	return $body;
425							}
426
427							sub purge {
428	0			0	0	0	my $self = shift;
429	0					0	my $msg = $self->{TN_Message};
430	0					0	my @atts = $self->attachments;
431	0					0	for ( keys %$msg ) {
432	0	0				0	$msg->{$_}->purge if exists $att{$_};
433							}
434	0					0	for my $attch (@atts) {
435	0					0	for ( keys %$attch ) {
436	0	0				0	$attch->{$_}->purge if exists $att{$_};
437							}
438							}
439							}
440
441							sub message {
442	1			1	0	11	my $self = shift;
443	1					16	$self->{TN_Message};
444							}
445
446							sub attachments {
447	1			1	0	10	my $self = shift;
448	1	50				11	return @{ $self->{TN_Attachments} } if wantarray;
	1					14
449	0					0	$self->{TN_Attachments};
450							}
451
452							# This is for Messages or Attachments
453							# since they are essentially the same thing except
454							# for the leading attribute code
455							package Convert::TNEF::Data;
456
457							sub new {
458	3			3		29	my $proto = shift;
459	3		33			40	my $class = ref($proto) \|\| $proto;
460	3					29	my $self = {};
461	3					32	$self->{TN_Size} = {};
462	3					78	bless $self, $class;
463							}
464
465							sub data {
466	3			3		29	my $self = shift;
467	3		100			37	my $attr = shift \|\| 'AttachData';
468	3		33			48	return $self->{$attr} && $self->{$attr}->as_string;
469							}
470
471							sub name {
472	1			1		9	my $self = shift;
473	1		50			78	my $attr = shift \|\| 'AttachTitle';
474	1		33			30	my $name = $self->{$attr} && $self->{$attr}->data;
475	1	50				32	$name =~ s/\x00+$// if $name;
476	1					16	return $name;
477							}
478
479							# Try to get the long filename out of the
480							# 'Attachment' attribute.
481							sub longname {
482	1			1		10	my $self = shift;
483
484	1					11	my $data = $self->data("Attachment");
485	1	50				21	return unless $data;
486	1					13	my $pos = index( $data, pack( "H*", "1e00013001" ) );
487	1	50				12	return $self->name unless $pos >= 0;
488	1					11	my $len = unpack( "V", substr( $data, $pos + 8, 4 ) );
489	1					11	my $longname = substr( $data, $pos + 12, $len );
490	1	50				13	$longname =~ s/\x00+$// if $longname;
491	1		33			45	return $longname \|\| $self->name;
492							}
493
494							sub datahandle {
495	24			24		205	my $self = shift;
496	24		50			227	my $attr = shift \|\| 'AttachData';
497	24	50				261	$self->{$attr} = shift if @_;
498	24	50				261	$self->size( $attr, shift ) if @_;
499	24					220	return $self->{$attr};
500							}
501
502							sub size {
503	24			24		194	my $self = shift;
504	24		50			226	my $attr = shift \|\| 'AttachData';
505	24	50				310	$self->{TN_Size}->{$attr} = shift if @_;
506	24					231	return $self->{TN_Size}->{$attr};
507							}
508
509							# Autoload methods go after =cut, and are processed by the autosplit program.
510
511							1;
512							__END__
513
514
515							=head1 NAME
516
517							Convert::TNEF - Perl module to read TNEF files
518
519							=head1 SYNOPSIS
520
521							use Convert::TNEF;
522
523							$tnef = Convert::TNEF->read($iohandle, \%parms)
524							or die Convert::TNEF::errstr;
525
526							$tnef = Convert::TNEF->read_in($filename, \%parms)
527							or die Convert::TNEF::errstr;
528
529							$tnef = Convert::TNEF->read_ent($mime_entity, \%parms)
530							or die Convert::TNEF::errstr;
531
532							$tnef->purge;
533
534							$message = $tnef->message;
535
536							@attachments = $tnef->attachments;
537
538							$attribute_value = $attachments[$i]->data($att_attribute_name);
539							$attribute_value_size = $attachments[$i]->size($att_attribute_name);
540							$attachment_name = $attachments[$i]->name;
541							$long_attachment_name = $attachments[$i]->longname;
542
543							$datahandle = $attachments[$i]->datahandle($att_attribute_name);
544
545							=head1 DESCRIPTION
546
547							TNEF stands for Transport Neutral Encapsulation Format, and if you've
548							ever been unfortunate enough to receive one of these files as an email
549							attachment, you may want to use this module.
550
551							read() takes as its first argument any file handle open
552							for reading. The optional second argument is a hash reference
553							which contains one or more of the following keys:
554
555							=head2
556
557							output_dir - Path for storing TNEF attribute data kept in files
558							(default: current directory).
559
560							output_prefix - File prefix for TNEF attribute data kept in files
561							(default: 'tnef').
562
563							output_to_core - TNEF attribute data will be saved in core memory unless
564							it is greater than this many bytes (default: 4096). May also be set to
565							'NONE' to keep all data in files, or 'ALL' to keep all data in core.
566
567							buffer_size - Buffer size for reading in the TNEF file (default: 1024).
568
569							debug - If true, outputs all sorts of info about what the read() function
570							is reading, including the raw ascii data along with the data converted
571							to hex (default: false).
572
573							display_after_err - If debug is true and an error is encountered,
574							reads and displays this many bytes of data following the error
575							(default: 32).
576
577							debug_max_display - If debug is true then read and display at most
578							this many bytes of data for each TNEF attribute (default: 1024).
579
580							debug_max_line_size - If debug is true then at most this many bytes of
581							data will be displayed on each line for each TNEF attribute
582							(default: 64).
583
584							ignore_checksum - If true, will ignore checksum errors while parsing
585							data (default: false).
586
587							read() returns an object containing the TNEF 'attributes' read from the
588							file and the data for those attributes. If all you want are the
589							attachments, then this is mostly garbage, but if you're interested then
590							you can see all the garbage by turning on debugging. If the garbage
591							proves useful to you, then let me know how I can maybe make it more
592							useful.
593
594							If an error is encountered, an undefined value is returned and the
595							package variable $errstr is set to some helpful message.
596
597							read_in() is a convienient front end for read() which takes a filename
598							instead of a handle.
599
600							read_ent() is another convient front end for read() which can take a
601							MIME::Entity object (or any object with like methods, specifically
602							open("r"), read($buff,$num_bytes), and close ).
603
604							purge() deletes any on-disk data that may be in the attachments of
605							the TNEF object.
606
607							message() returns the message portion of the tnef object, if any.
608							The thing it returns is like an attachment, but its not an attachment.
609							For instance, it more than likely does not have a name or any
610							attachment data.
611
612							attachments() returns a list of the attachments that the given TNEF
613							object contains. Returns a list ref if not called in array context.
614
615							data() takes a TNEF attribute name, and returns a string value for that
616							attribute for that attachment. Its your own problem if the string is too
617							big for memory. If no argument is given, then the 'AttachData' attribute
618							is assumed, which is probably the attachment data you're looking for.
619
620							name() is the same as data(), except the attribute 'AttachTitle' is
621							the default, which returns the 8 character + 3 character extension name
622							of the attachment.
623
624							longname() returns the long filename and extension of an attachment. This
625							is embedded within a MAPI property of the 'Attachment' attribute data, so
626							we attempt to extract the name out of that.
627
628							size() takes an TNEF attribute name, and returns the size in bytes for
629							the data for that attachment attribute.
630
631							datahandle() is a method for attachments which takes a TNEF attribute
632							name, and returns the data for that attribute as a handle which is
633							the same as a MIME::Body handle. See MIME::Body for all the applicable
634							methods. If no argument is given, then 'AttachData' is assumed.
635
636
637							=head1 EXAMPLES
638
639							# Here's a rather long example where mail is retrieved
640							# from a POP3 server based on header information, then
641							# it is MIME parsed, and then the TNEF contents
642							# are extracted and converted.
643
644							use strict;
645							use Net::POP3;
646							use MIME::Parser;
647							use Convert::TNEF;
648
649							my $mail_dir = "mailout";
650							my $mail_prefix = "mail";
651
652							my $pop = new Net::POP3 ( "pop3server_name" );
653							my $num_msgs = $pop->login("user_name","password");
654							die "Can't login: $!" unless defined $num_msgs;
655
656							# Get mail by sender and subject
657							my $mail_out_idx = 0;
658							MESSAGE: for ( my $i=1; $i<= $num_msgs; $i++ ) {
659							my $header = join "", @{$pop->top($i)};
660
661							for ($header) {
662							next MESSAGE unless
663							/^from:.*someone\@somewhere.net/im &&
664							/^subject:\s*important stuff/im
665							}
666
667							my $fname = $mail_prefix."-".$$.++$mail_out_idx.".doc";
668							open (MAILOUT, ">$mail_dir/$fname")
669							or die "Can't open $mail_dir/$fname: $!";
670							# If the get() complains, you need the new libnet bundle
671							$pop->get($i, \*MAILOUT) or die "Can't read mail";
672							close MAILOUT or die "Error closing $mail_dir/$fname";
673							# If you want to delete the mail on the server
674							# $pop->delete($i);
675							}
676
677							close MAILOUT;
678							$pop->quit();
679
680							# Parse the mail message into separate mime entities
681							my $parser=new MIME::Parser;
682							$parser->output_dir("mimemail");
683
684							opendir(DIR, $mail_dir) or die "Can't open directory $mail_dir: $!";
685							my @files = map { $mail_dir."/".$_ } sort
686							grep { -f "$mail_dir/$_" and /$mail_prefix-$$-/o } readdir DIR;
687							closedir DIR;
688
689							for my $file ( @files ) {
690							my $entity=$parser->parse_in($file) or die "Couldn't parse mail";
691							print_tnef_parts($entity);
692							# If you want to delete the working files
693							# $entity->purge;
694							}
695
696							sub print_tnef_parts {
697							my $ent = shift;
698
699							if ( $ent->parts ) {
700							for my $sub_ent ( $ent->parts ) {
701							print_tnef_parts($sub_ent);
702							}
703							} elsif ( $ent->mime_type =~ /ms-tnef/i ) {
704
705							# Create a tnef object
706							my $tnef = Convert::TNEF->read_ent($ent,{output_dir=>"tnefmail"})
707							or die $Convert::TNEF::errstr;
708							for ($tnef->attachments) {
709							print "Title:",$_->name,"\n";
710							print "Data:\n",$_->data,"\n";
711							}
712
713							# If you want to delete the working files
714							# $tnef->purge;
715							}
716							}
717
718							=head1 SEE ALSO
719
720							perl(1), IO::Wrap(3), MIME::Parser(3), MIME::Entity(3), MIME::Body(3)
721
722							=head1 CAVEATS
723
724							The parsing may depend on the endianness (see perlport) and width of
725							integers on the system where the TNEF file was created. If this proves
726							to be the case (check the debug output), I'll see what I can do
727							about it.
728
729							=head1 AUTHOR
730
731							Douglas Wilson, dougw@cpan.org
732
733							=cut
734
735