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