← Index
NYTProf Performance Profile   « line view »
For /usr/local/libexec/sympa/task_manager-debug.pl
  Run on Tue Jun 1 22:32:51 2021
Reported on Tue Jun 1 22:35:13 2021

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