File Coverage

blib/lib/MIME/Parser/Filer.pm
Criterion Covered Total %
statement 149 162 91.9
branch 47 68 69.1
condition 12 29 41.3
subroutine 30 32 93.7
pod 15 18 83.3
total 253 309 81.8


line stmt bran cond sub pod time code
1             package MIME::Parser::Filer;
2              
3             =head1 NAME
4              
5             MIME::Parser::Filer - manage file-output of the parser
6              
7              
8             =head1 SYNOPSIS
9              
10             Before reading further, you should see L to make sure that
11             you understand where this module fits into the grand scheme of things.
12             Go on, do it now. I'll wait.
13              
14             Ready? Ok... now read L<"DESCRIPTION"> below, and everything else
15             should make sense.
16              
17              
18             =head2 Public interface
19              
20             ### Create a "filer" of the desired class:
21             my $filer = MIME::Parser::FileInto->new($dir);
22             my $filer = MIME::Parser::FileUnder->new($basedir);
23             ...
24              
25             ### Want added security? Don't let outsiders name your files:
26             $filer->ignore_filename(1);
27              
28             ### Prepare for the parsing of a new top-level message:
29             $filer->init_parse;
30              
31             ### Return the path where this message's data should be placed:
32             $path = $filer->output_path($head);
33              
34              
35             =head2 Semi-public interface
36              
37             These methods might be overridden or ignored in some subclasses,
38             so they don't all make sense in all circumstances:
39              
40             ### Tweak the mapping from content-type to extension:
41             $emap = $filer->output_extension_map;
42             $emap->{"text/html"} = ".htm";
43              
44              
45              
46              
47             =head1 DESCRIPTION
48              
49              
50             =head2 How this class is used when parsing
51              
52             When a MIME::Parser decides that it wants to output a file to disk,
53             it uses its "Filer" object -- an instance of a MIME::Parser::Filer
54             subclass -- to determine where to put the file.
55              
56             Every parser has a single Filer object, which it uses for all
57             parsing. You can get the Filer for a given $parser like this:
58              
59             $filer = $parser->filer;
60              
61             At the beginning of each C, the filer's internal state
62             is reset by the parser:
63              
64             $parser->filer->init_parse;
65              
66             The parser can then get a path for each entity in the message
67             by handing that entity's header (a MIME::Head) to the filer
68             and having it do the work, like this:
69              
70             $new_file = $parser->filer->output_path($head);
71              
72             Since it's nice to be able to clean up after a parse (especially
73             a failed parse), the parser tells the filer when it has actually
74             used a path:
75              
76             $parser->filer->purgeable($new_file);
77              
78             Then, if you want to clean up the files which were created for a
79             particular parse (and also any directories that the Filer created),
80             you would do this:
81              
82             $parser->filer->purge;
83              
84              
85              
86             =head2 Writing your own subclasses
87              
88             There are two standard "Filer" subclasses (see below):
89             B, which throws all files from all parses
90             into the same directory, and B (preferred), which
91             creates a subdirectory for each message. Hopefully, these will be
92             sufficient for most uses, but just in case...
93              
94             The only method you have to override is L:
95              
96             $filer->output_path($head);
97              
98             This method is invoked by MIME::Parser when it wants to put a
99             decoded message body in an output file. The method should return a
100             path to the file to create. Failure is indicated by throwing an
101             exception.
102              
103             The path returned by C should be "ready for open()":
104             any necessary parent directories need to exist at that point.
105             These directories can be created by the Filer, if course, and they
106             should be marked as B if a purge should delete them.
107              
108             Actually, if your issue is more I the files go than
109             what they're named, you can use the default L
110             method and just override one of its components:
111              
112             $dir = $filer->output_dir($head);
113             $name = $filer->output_filename($head);
114             ...
115              
116              
117              
118             =head1 PUBLIC INTERFACE
119              
120              
121             =head2 MIME::Parser::Filer
122              
123             This is the abstract superclass of all "filer" objects.
124              
125             =over 4
126              
127             =cut
128              
129 18     18   55218 use strict;
  18         28  
  18         508  
130              
131             ### Kit modules:
132 18     18   424 use MIME::Tools qw(:msgtypes);
  18         27  
  18         2235  
133 18     18   87 use File::Spec;
  18         65  
  18         393  
134 18     18   65 use File::Path qw(rmtree);
  18         23  
  18         771  
135 18     18   466 use MIME::WordDecoder;
  18         34  
  18         29154  
136              
137             ### Output path uniquifiers:
138             my $GFileNo = 0;
139             my $GSubdirNo = 0;
140              
141             ### Map content-type to extension.
142             ### If we can't map "major/minor", we try "major/*", then use "*/*".
143             my %DefaultTypeToExt =
144             qw(
145              
146             application/andrew-inset .ez
147             application/octet-stream .bin
148             application/oda .oda
149             application/pdf .pdf
150             application/pgp .pgp
151             application/postscript .ps
152             application/rtf .rtf
153             application/x-bcpio .bcpio
154             application/x-chess-pgn .pgn
155             application/x-cpio .cpio
156             application/x-csh .csh
157             application/x-dvi .dvi
158             application/x-gtar .gtar
159             application/x-gunzip .gz
160             application/x-hdf .hdf
161             application/x-latex .latex
162             application/x-mif .mif
163             application/x-netcdf .cdf
164             application/x-netcdf .nc
165             application/x-sh .sh
166             application/x-shar .shar
167             application/x-sv4cpio .sv4cpio
168             application/x-sv4crc .sv4crc
169             application/x-tar .tar
170             application/x-tcl .tcl
171             application/x-tex .tex
172             application/x-texinfo .texi
173             application/x-troff .roff
174             application/x-troff .tr
175             application/x-troff-man .man
176             application/x-troff-me .me
177             application/x-troff-ms .ms
178             application/x-ustar .ustar
179             application/x-wais-source .src
180             application/zip .zip
181              
182             audio/basic .snd
183             audio/ulaw .au
184             audio/x-aiff .aiff
185             audio/x-wav .wav
186              
187             image/gif .gif
188             image/ief .ief
189             image/jpeg .jpg
190             image/png .png
191             image/xbm .xbm
192             image/tiff .tif
193             image/x-cmu-raster .ras
194             image/x-portable-anymap .pnm
195             image/x-portable-bitmap .pbm
196             image/x-portable-graymap .pgm
197             image/x-portable-pixmap .ppm
198             image/x-rgb .rgb
199             image/x-xbitmap .xbm
200             image/x-xpixmap .xpm
201             image/x-xwindowdump .xwd
202              
203             text/* .txt
204             text/html .html
205             text/plain .txt
206             text/richtext .rtx
207             text/tab-separated-values .tsv
208             text/x-setext .etx
209             text/x-vcard .vcf
210              
211             video/mpeg .mpg
212             video/quicktime .mov
213             video/x-msvideo .avi
214             video/x-sgi-movie .movie
215              
216             message/* .msg
217              
218             */* .dat
219              
220             );
221              
222             #------------------------------
223              
224             =item new INITARGS...
225              
226             I
227             Create a new outputter for the given parser.
228             Any subsequent arguments are given to init(), which subclasses should
229             override for their own use (the default init does nothing).
230              
231             =cut
232              
233             sub new {
234 77     77 1 1656 my ($class, @initargs) = @_;
235 77         2697 my $self = bless {
236             MPF_Prefix => "msg",
237             MPF_Dir => ".",
238             MPF_Ext => { %DefaultTypeToExt },
239             MPF_Purgeable => [], ### files created by the last parse
240              
241             MPF_MaxName => 80, ### max filename before treated as evil
242             MPF_TrimRoot => 14, ### trim root to this length
243             MPF_TrimExt => 3, ### trim extension to this length
244             }, $class;
245 77         360 $self->init(@initargs);
246 77         240 $self;
247             }
248              
249       1 1   sub init {
250             ### no-op
251             }
252              
253             #------------------------------
254             #
255             # cleanup_dir
256             #
257             # Instance method, private.
258             # Cleanup a directory, defaulting empty to "."
259             #
260             sub cleanup_dir {
261 76     76 0 84 my ($self, $dir) = @_;
262 76 50 33     404 $dir = '.' if (!defined($dir) || ($dir eq '')); # coerce empty to "."
263 76 50       145 $dir = '/.' if ($dir eq '/'); # coerce "/" so "$dir/$filename" works
264 76         131 $dir =~ s|/$||; # be nice: get rid of any trailing "/"
265 76         243 $dir;
266             }
267              
268             #------------------------------
269              
270             =item results RESULTS
271              
272             I
273             Link this filer to a MIME::Parser::Results object which will
274             tally the messages. Notice that we avoid linking it to the
275             parser to avoid circular reference!
276              
277             =cut
278              
279             sub results {
280 130     130 1 149 my ($self, $results) = @_;
281 130 50       320 $self->{MPF_Results} = $results if (@_ > 1);
282 130         274 $self->{MPF_Results};
283             }
284              
285             ### Log debug messages:
286             sub debug {
287 296     296 0 249 my $self = shift;
288 296 50       611 if (MIME::Tools->debugging()) {
289 0 0       0 if ($self->{MPF_Results}) {
290 0         0 unshift @_, $self->{MPF_Results}->indent;
291 0         0 $self->{MPF_Results}->msg($M_DEBUG, @_);
292             }
293 0         0 MIME::Tools::debug(@_);
294             }
295             }
296              
297             ### Log warning messages:
298             sub whine {
299 10     10 0 12 my $self = shift;
300 10 50       26 if ($self->{MPF_Results}) {
301 10         37 unshift @_, $self->{MPF_Results}->indent;
302 10         37 $self->{MPF_Results}->msg($M_WARNING, @_);
303             }
304 10         35 MIME::Tools::whine(@_);
305             }
306              
307             #------------------------------
308              
309             =item init_parse
310              
311             I
312             Prepare to start parsing a new message.
313             Subclasses should always be sure to invoke the inherited method.
314              
315             =cut
316              
317             sub init_parse {
318 54     54 1 80 my $self = shift;
319 54         101 $self->{MPF_Purgeable} = [];
320             }
321              
322             #------------------------------
323              
324             =item evil_filename FILENAME
325              
326             I
327             Is this an evil filename; i.e., one which should not be used
328             in generating a disk file name? It is if any of these are true:
329              
330             * it is empty or entirely whitespace
331             * it contains leading or trailing whitespace
332             * it is a string of dots: ".", "..", etc.
333             * it contains characters not in the set: "A" - "Z", "a" - "z",
334             "0" - "9", "-", "_", "+", "=", ".", ",", "@", "#",
335             "$", and " ".
336             * it is too long
337              
338             If you just want to change this behavior, you should override
339             this method in the subclass of MIME::Parser::Filer that you use.
340              
341             B at the time this method is invoked, the FILENAME has
342             already been unmime'd into the local character set.
343             If you're using any character set other than ASCII, ISO-8859-*,
344             or UTF-8, the interpretation of the "path" characters might be
345             very different, and you will probably need to override this method.
346             See L for more details.
347              
348             B subclasses of MIME::Parser::Filer which override
349             output_path() might not consult this method; note, however, that
350             the built-in subclasses do consult it.
351              
352             I
353             version. Thanks to Nickolay Saukh for noting that evil is in the
354             eye of the beholder.>
355              
356             =cut
357              
358             sub evil_filename {
359 79     79 1 1650 my ($self, $name) = @_;
360              
361 79         210 $self->debug("is this evil? '$name'");
362              
363 79 50 33     340 return 1 if (!defined($name) or ($name eq '')); ### empty
364 79 100       447 return 1 if ($name =~ m{(^\s)|(\s+\Z)}); ### leading/trailing whitespace
365 69 100       189 return 1 if ($name =~ m{^\.+\Z}); ### dots
366 65 100       247 return 1 if ($name =~ /[^-A-Z0-9_+=.,@\#\$\% ]/i); # Only allow good chars
367             return 1 if ($self->{MPF_MaxName} and
368 52 50 33     255 (length($name) > $self->{MPF_MaxName}));
369 52         86 $self->debug("it's ok");
370 52         118 0;
371             }
372              
373             #------------------------------
374              
375             =item exorcise_filename FILENAME
376              
377             I
378             If a given filename is evil (see L) we try to
379             rescue it by performing some basic operations: shortening it,
380             removing bad characters, etc., and checking each against
381             evil_filename().
382              
383             Returns the exorcised filename (which is guaranteed to not
384             be evil), or undef if it could not be salvaged.
385              
386             B at the time this method is invoked, the FILENAME has
387             already been unmime'd into the local character set.
388             If you're using anything character set other than ASCII, ISO-8859-*,
389             or UTF-8, the interpretation of the "path" characters might be very
390             very different, and you will probably need to override this method.
391             See L for more details.
392              
393             =cut
394              
395             sub exorcise_filename {
396 13     13 1 2539 my ($self, $fname) = @_;
397              
398             ### Isolate to last path element:
399 13         13 my $last = $fname;
400              
401             ### Path separators are / or \
402 13         50 $last =~ s{^.*[/\\]}{};
403              
404             ### Convert semi-evil characters to underscores
405 13         28 $last =~ s/[\/\\\[\]:]/_/g;
406 13 100 66     51 if ($last and !$self->evil_filename($last)) {
407 3         7 $self->debug("looks like I can use the last path element");
408 3         8 return $last;
409             }
410              
411             ### Break last element into root and extension, and truncate:
412 10 100       53 my ($root, $ext) = (($last =~ /^(.*)\.([^\.]+)\Z/)
413             ? ($1, $2)
414             : ($last, ''));
415             ### Delete leading and trailing whitespace
416 10         51 $root =~ s/^\s+//;
417 10         21 $ext =~ s/\s+$//;
418 10   50     40 $root = substr($root, 0, ($self->{MPF_TrimRoot} || 14));
419 10   50     25 $ext = substr($ext, 0, ($self->{MPF_TrimExt} || 3));
420 10 100       26 $ext =~ /^\w+$/ or $ext = "dat";
421 10 50       39 my $trunc = $root . ($ext ? ".$ext" : '');
422 10 100       19 if (!$self->evil_filename($trunc)) {
423 6         9 $self->debug("looks like I can use the truncated last path element");
424 6         19 return $trunc;
425             }
426              
427             ### Remove all bad characters
428 4         21 $trunc =~ s/([^-A-Z0-9_+=.,@\#\$ ])/sprintf("%%%02X", unpack("C", $1))/ige;
  9         66  
429 4 50       10 if (!$self->evil_filename($trunc)) {
430 4         9 $self->debug("looks like I can use a munged version of the truncated last path element");
431 4         14 return $trunc;
432             }
433              
434             ### Hope that works:
435 0         0 undef;
436             }
437              
438             #------------------------------
439              
440             =item find_unused_path DIR, FILENAME
441              
442             I
443             We have decided on an output directory and tentative filename,
444             but there is a chance that it might already exist. Keep
445             adding a numeric suffix "-1", "-2", etc. to the filename
446             until an unused path is found, and then return that path.
447              
448             The suffix is actually added before the first "." in the filename
449             is there is one; for example:
450              
451             picture.gif archive.tar.gz readme
452             picture-1.gif archive-1.tar.gz readme-1
453             picture-2.gif archive-2.tar.gz readme-2
454             ... ... ...
455             picture-10.gif
456             ...
457              
458             This can be a costly operation, and risky if you don't want files
459             renamed, so it is in your best interest to minimize situations
460             where these kinds of collisions occur. Unfortunately, if
461             a multipart message gives all of its parts the same recommended
462             filename, and you are placing them all in the same directory,
463             this method might be unavoidable.
464              
465             =cut
466              
467             sub find_unused_path {
468 90     90 1 104 my ($self, $dir, $fname) = @_;
469 90         102 my $i = 0;
470 90         80 while (1) {
471              
472             ### Create suffixed name (from filename), and see if we can use it:
473 96 100       159 my $suffix = ($i ? "-$i" : "");
474 96         89 my $sname = $fname; $sname =~ s/^(.*?)(\.|\Z)/$1$suffix$2/;
  96         705  
475 96         922 my $path = File::Spec->catfile($dir, $sname);
476 96 100       1978 if (! -e $path) { ### it's good!
477 90 100       197 $i and $self->whine("collision with $fname in $dir: using $path");
478 90         383 return $path;
479             }
480 6         18 $self->debug("$path already taken");
481 6         8 } continue { ++$i; }
482             }
483              
484             #------------------------------
485              
486             =item ignore_filename [YESNO]
487              
488             I
489             Return true if we should always ignore recommended filenames in
490             messages, choosing instead to always generate our own filenames.
491             With argument, sets this value.
492              
493             B subclasses of MIME::Parser::Filer which override
494             output_path() might not honor this setting; note, however, that
495             the built-in subclasses honor it.
496              
497             =cut
498              
499             sub ignore_filename {
500 37     37 1 45 my $self = shift;
501 37 50       82 $self->{MPF_IgnoreFilename} = $_[0] if @_;
502 37         147 $self->{MPF_IgnoreFilename};
503             }
504              
505             #------------------------------
506              
507             =item output_dir HEAD
508              
509             I
510             Return the output directory for the given header.
511             The default method returns ".".
512              
513             =cut
514              
515             sub output_dir {
516 0     0 1 0 my ($self, $head) = @_;
517 0         0 return ".";
518             }
519              
520             #------------------------------
521              
522             =item output_filename HEAD
523              
524             I
525             A given recommended filename was either not given, or it was judged
526             to be evil. Return a fake name, possibly using information in the
527             message HEADer. Note that this is just the filename, not the full path.
528              
529             Used by L.
530             If you're using the default C, you probably don't
531             need to worry about avoiding collisions with existing files;
532             we take care of that in L.
533              
534             =cut
535              
536             sub output_filename {
537 53     53 1 59 my ($self, $head) = @_;
538              
539             ### Get the recommended name:
540 53         119 my $recommended = $head->recommended_filename;
541              
542             ### Get content type:
543 53   100     125 my ($type, $subtype) = split m{/}, $head->mime_type; $subtype ||= '';
  53         114  
544              
545             ### Get recommended extension, being quite conservative:
546 53 50 33     141 my $recommended_ext = (($recommended and ($recommended =~ m{(\.\w+)\Z}))
547             ? $1
548             : undef);
549              
550             ### Try and get an extension, honoring a given one first:
551             my $ext = ($recommended_ext ||
552             $self->{MPF_Ext}{"$type/$subtype"} ||
553             $self->{MPF_Ext}{"$type/*"} ||
554 53   0     351 $self->{MPF_Ext}{"*/*"} ||
555             ".dat");
556              
557             ### Get a prefix:
558 53         72 ++$GFileNo;
559 53         126 return ($self->output_prefix . "-$$-$GFileNo$ext");
560             }
561              
562             #------------------------------
563              
564             =item output_prefix [PREFIX]
565              
566             I
567             Get the short string that all filenames for extracted body-parts
568             will begin with (assuming that there is no better "recommended filename").
569             The default is F<"msg">.
570              
571             If PREFIX I given, the current output prefix is returned.
572             If PREFIX I given, the output prefix is set to the new value,
573             and the previous value is returned.
574              
575             Used by L.
576              
577             B subclasses of MIME::Parser::Filer which override
578             output_path() or output_filename() might not honor this setting;
579             note, however, that the built-in subclasses honor it.
580              
581             =cut
582              
583             sub output_prefix {
584 53     53 1 67 my ($self, $prefix) = @_;
585 53 50       109 $self->{MPF_Prefix} = $prefix if (@_ > 1);
586 53         251 $self->{MPF_Prefix};
587             }
588              
589             #------------------------------
590              
591             =item output_type_ext
592              
593             I
594             Return a reference to the hash used by the default
595             L for mapping from content-types
596             to extensions when there is no default extension to use.
597              
598             $emap = $filer->output_typemap;
599             $emap->{'text/plain'} = '.txt';
600             $emap->{'text/html'} = '.html';
601             $emap->{'text/*'} = '.txt';
602             $emap->{'*/*'} = '.dat';
603              
604             B subclasses of MIME::Parser::Filer which override
605             output_path() or output_filename() might not consult this hash;
606             note, however, that the built-in subclasses consult it.
607              
608             =cut
609              
610             sub output_type_ext {
611 0     0 1 0 my $self = shift;
612 0         0 return $self->{MPF_Ext};
613             }
614              
615             #------------------------------
616              
617             =item output_path HEAD
618              
619             I
620             Given a MIME head for a file to be extracted, come up with a good
621             output pathname for the extracted file. This is the only method
622             you need to worry about if you are building a custom filer.
623              
624             The default implementation does a lot of work; subclass
625             implementers I should try to just override its components
626             instead of the whole thing. It works basically as follows:
627              
628             $directory = $self->output_dir($head);
629              
630             $filename = $head->recommended_filename();
631             if (!$filename or
632             $self->ignore_filename() or
633             $self->evil_filename($filename)) {
634             $filename = $self->output_filename($head);
635             }
636              
637             return $self->find_unused_path($directory, $filename);
638              
639             B There are many, many, many ways you might want to control
640             the naming of files, based on your application. If you don't like
641             the behavior of this function, you can easily define your own subclass
642             of MIME::Parser::Filer and override it there.
643              
644             B Nickolay Saukh pointed out that, given the subjective nature of
645             what is "evil", this function really shouldn't I about an evil
646             filename, but maybe just issue a I message. I considered that,
647             but then I thought: if debugging were off, people wouldn't know why
648             (or even if) a given filename had been ignored. In mail robots
649             that depend on externally-provided filenames, this could cause
650             hard-to-diagnose problems. So, the message is still a warning.
651              
652             I
653             implementation, and for making some good suggestions. Thanks also to
654             Achim Bohnet for pointing out that there should be a hookless, OO way of
655             overriding the output path.>
656              
657             =cut
658              
659             sub output_path {
660 90     90 1 92 my ($self, $head) = @_;
661              
662             ### Get the output directory:
663 90         226 my $dir = $self->output_dir($head);
664              
665             ### Get the output filename as UTF-8
666 90         204 my $fname = $head->recommended_filename;
667              
668             ### Can we use it:
669 90 100       260 if (!defined($fname)) {
    50          
    100          
670 53         131 $self->debug("no filename recommended: synthesizing our own");
671 53         149 $fname = $self->output_filename($head);
672             }
673             elsif ($self->ignore_filename) {
674 0         0 $self->debug("ignoring all external filenames: synthesizing our own");
675 0         0 $fname = $self->output_filename($head);
676             }
677             elsif ($self->evil_filename($fname)) {
678              
679             ### Can we save it by just taking the last element?
680 5         28 my $ex = $self->exorcise_filename($fname);
681 5 50 33     29 if (defined($ex) and !$self->evil_filename($ex)) {
682 5         28 $self->whine("Provided filename '$fname' is regarded as evil, ",
683             "but I was able to exorcise it and get something ",
684             "usable.");
685 5         7 $fname = $ex;
686             }
687             else {
688 0         0 $self->whine("Provided filename '$fname' is regarded as evil; ",
689             "I'm ignoring it and supplying my own.");
690 0         0 $fname = $self->output_filename($head);
691             }
692             }
693 90         276 $self->debug("planning to use '$fname'");
694              
695             ### Resolve collisions and return final path:
696 90         223 return $self->find_unused_path($dir, $fname);
697             }
698              
699             #------------------------------
700              
701             =item purge
702              
703             I
704             Purge all files/directories created by the last parse.
705             This method simply goes through the purgeable list in reverse order
706             (see L) and removes all existing files/directories in it.
707             You should not need to override this method.
708              
709             =cut
710              
711             sub purge {
712 26     26 1 33 my ($self) = @_;
713 26         35 foreach my $path (reverse @{$self->{MPF_Purgeable}}) {
  26         64  
714 73 50       670 (-e $path) or next; ### must check: might delete DIR before DIR/FILE
715 73         10374 rmtree($path, 0, 1);
716 73 50       940 (-e $path) and $self->whine("unable to purge: $path");
717             }
718 26         121 1;
719             }
720              
721             #------------------------------
722              
723             =item purgeable [FILE]
724              
725             I
726             Add FILE to the list of "purgeable" files/directories (those which
727             will be removed if you do a C).
728             You should not need to override this method.
729              
730             If FILE is not given, the "purgeable" list is returned.
731             This may be used for more-sophisticated purging.
732              
733             As a special case, invoking this method with a FILE that is an
734             arrayref will replace the purgeable list with a copy of the
735             array's contents, so [] may be used to clear the list.
736              
737             Note that the "purgeable" list is cleared when a parser begins a
738             new parse; therefore, if you want to use purge() to do cleanup,
739             you I do so I starting a new parse!
740              
741             =cut
742              
743             sub purgeable {
744 178     178 1 185 my ($self, $path) = @_;
745 178 100       330 return @{$self->{MPF_Purgeable}} if (@_ == 1);
  25         89  
746              
747 153 100       268 if (ref($path)) { $self->{MPF_Purgeable} = [ @$path ]; }
  54         98  
748 99         82 else { push @{$self->{MPF_Purgeable}}, $path; }
  99         195  
749 153         224 1;
750             }
751              
752             =back
753              
754             =cut
755              
756              
757             #------------------------------------------------------------
758             #------------------------------------------------------------
759              
760             =head2 MIME::Parser::FileInto
761              
762             This concrete subclass of MIME::Parser::Filer supports filing
763             into a given directory.
764              
765             =over 4
766              
767             =cut
768              
769             package MIME::Parser::FileInto;
770              
771 18     18   100 use strict;
  18         28  
  18         391  
772 18     18   70 use vars qw(@ISA);
  18         24  
  18         2305  
773             @ISA = qw(MIME::Parser::Filer);
774              
775             #------------------------------
776              
777             =item init DIRECTORY
778              
779             I
780             Set the directory where all files will go.
781              
782             =cut
783              
784             sub init {
785 73     73   97 my ($self, $dir) = @_;
786 73         176 $self->{MPFI_Dir} = $self->cleanup_dir($dir);
787             }
788              
789             #------------------------------
790             #
791             # output_dir HEAD
792             #
793             # I
794             # Return the output directory where the files go.
795             #
796             sub output_dir {
797 92     92   145 shift->{MPFI_Dir};
798             }
799              
800             =back
801              
802             =cut
803              
804              
805              
806              
807             #------------------------------------------------------------
808             #------------------------------------------------------------
809              
810             =head2 MIME::Parser::FileUnder
811              
812             This concrete subclass of MIME::Parser::Filer supports filing under
813             a given directory, using one subdirectory per message, but with
814             all message parts in the same directory.
815              
816             =over 4
817              
818             =cut
819              
820             package MIME::Parser::FileUnder;
821              
822 18     18   82 use strict;
  18         26  
  18         380  
823 18     18   65 use vars qw(@ISA);
  18         28  
  18         4521  
824             @ISA = qw(MIME::Parser::Filer);
825              
826             #------------------------------
827              
828             =item init BASEDIR, OPTSHASH...
829              
830             I
831             Set the base directory which will contain the message directories.
832             If used, then each parse of begins by creating a new subdirectory
833             of BASEDIR where the actual parts of the message are placed.
834             OPTSHASH can contain the following:
835              
836             =over 4
837              
838             =item DirName
839              
840             Explicitly set the name of the subdirectory which is created.
841             The default is to use the time, process id, and a sequence number,
842             but you might want a predictable directory.
843              
844             =item Purge
845              
846             Automatically purge the contents of the directory (including all
847             subdirectories) before each parse. This is really only needed if
848             using an explicit DirName, and is provided as a convenience only.
849             Currently we use the 1-arg form of File::Path::rmtree; you should
850             familiarize yourself with the caveats therein.
851              
852             =back
853              
854             The output_dir() will return the path to this message-specific directory
855             until the next parse is begun, so you can do this:
856              
857             use File::Path;
858              
859             $parser->output_under("/tmp");
860             $ent = eval { $parser->parse_open($msg); }; ### parse
861             if (!$ent) { ### parse failed
862             rmtree($parser->output_dir);
863             die "parse failed: $@";
864             }
865             else { ### parse succeeded
866             ...do stuff...
867             }
868              
869             =cut
870              
871             sub init {
872 3     3   10 my ($self, $basedir, %opts) = @_;
873              
874 3         12 $self->{MPFU_Base} = $self->cleanup_dir($basedir);
875 3         8 $self->{MPFU_DirName} = $opts{DirName};
876 3         8 $self->{MPFU_Purge} = $opts{Purge};
877             }
878              
879             #------------------------------
880             #
881             # init_parse
882             #
883             # I
884             # Prepare to start parsing a new message.
885             #
886             sub init_parse {
887 3     3   5 my $self = shift;
888              
889             ### Invoke inherited method first!
890 3         13 $self->SUPER::init_parse;
891              
892             ### Determine the subdirectory of their base to use:
893             my $subdir = (defined($self->{MPFU_DirName})
894             ? $self->{MPFU_DirName}
895 3 50       49 : ("msg-".scalar(time)."-$$-".$GSubdirNo++));
896 3         17 $self->debug("subdir = $subdir");
897              
898             ### Determine full path to the per-message output directory:
899 3         54 $self->{MPFU_Dir} = File::Spec->catfile($self->{MPFU_Base}, $subdir);
900              
901             ### Remove and re-create the per-message output directory:
902 3 50       10 rmtree $self->output_dir if $self->{MPFU_Purge};
903 3 50 33     10 (-d $self->output_dir) or
904             mkdir $self->output_dir, 0700 or
905             die "mkdir ".$self->output_dir.": $!\n";
906              
907             ### Add the per-message output directory to the puregables:
908 3         10 $self->purgeable($self->output_dir);
909 3         6 1;
910             }
911              
912             #------------------------------
913             #
914             # output_dir HEAD
915             #
916             # I
917             # Return the output directory that we used for the last parse.
918             #
919             sub output_dir {
920 13     13   368 shift->{MPFU_Dir};
921             }
922              
923             =back
924              
925             =cut
926              
927             1;
928             __END__