← Index
NYTProf Performance Profile   « block view • line view • sub view »
For /usr/share/koha/opac/cgi-bin/opac/opac-search.pl
  Run on Tue Oct 15 11:58:52 2013
Reported on Tue Oct 15 12:01:33 2013

Filename/usr/share/perl5/MIME/Lite.pm
StatementsExecuted 84 statements in 9.36ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
44123µs23µsMIME::Lite::::CORE:fteexec MIME::Lite::CORE:fteexec (opcode)
11121µs25µsMIME::Lite::::BEGIN@2 MIME::Lite::BEGIN@2
11121µs26µsMIME::Lite::SMTP::::BEGIN@3094 MIME::Lite::SMTP::BEGIN@3094
11119µs575µsMIME::Lite::::BEGIN@331 MIME::Lite::BEGIN@331
11118µs33µsMIME::Lite::IO_Handle::::BEGIN@3139 MIME::Lite::IO_Handle::BEGIN@3139
11115µs15µsMIME::Lite::::BEGIN@492 MIME::Lite::BEGIN@492
11115µs37µsMIME::Lite::::BEGIN@2276 MIME::Lite::BEGIN@2276
11113µs51µsMIME::Lite::SMTP::::BEGIN@3095 MIME::Lite::SMTP::BEGIN@3095
11110µs132µsMIME::Lite::::BEGIN@333 MIME::Lite::BEGIN@333
1116µs6µsMIME::Lite::::BEGIN@330 MIME::Lite::BEGIN@330
1116µs6µsMIME::Lite::::CORE:match MIME::Lite::CORE:match (opcode)
0000s0sMIME::Lite::IO_Handle::::print MIME::Lite::IO_Handle::print
0000s0sMIME::Lite::IO_Handle::::wrap MIME::Lite::IO_Handle::wrap
0000s0sMIME::Lite::IO_Scalar::::print MIME::Lite::IO_Scalar::print
0000s0sMIME::Lite::IO_Scalar::::wrap MIME::Lite::IO_Scalar::wrap
0000s0sMIME::Lite::IO_ScalarArray::::printMIME::Lite::IO_ScalarArray::print
0000s0sMIME::Lite::IO_ScalarArray::::wrapMIME::Lite::IO_ScalarArray::wrap
0000s0sMIME::Lite::SMTP::::_hexify MIME::Lite::SMTP::_hexify
0000s0sMIME::Lite::SMTP::::print MIME::Lite::SMTP::print
0000s0sMIME::Lite::::__opts MIME::Lite::__opts
0000s0sMIME::Lite::::_safe_attr MIME::Lite::_safe_attr
0000s0sMIME::Lite::::_unfold_stupid_params MIME::Lite::_unfold_stupid_params
0000s0sMIME::Lite::::add MIME::Lite::add
0000s0sMIME::Lite::::as_string MIME::Lite::as_string
0000s0sMIME::Lite::::attach MIME::Lite::attach
0000s0sMIME::Lite::::attr MIME::Lite::attr
0000s0sMIME::Lite::::binmode MIME::Lite::binmode
0000s0sMIME::Lite::::body_as_string MIME::Lite::body_as_string
0000s0sMIME::Lite::::build MIME::Lite::build
0000s0sMIME::Lite::::data MIME::Lite::data
0000s0sMIME::Lite::::delete MIME::Lite::delete
0000s0sMIME::Lite::::encode_7bit MIME::Lite::encode_7bit
0000s0sMIME::Lite::::encode_8bit MIME::Lite::encode_8bit
0000s0sMIME::Lite::::fh MIME::Lite::fh
0000s0sMIME::Lite::::field_order MIME::Lite::field_order
0000s0sMIME::Lite::::fields MIME::Lite::fields
0000s0sMIME::Lite::::fields_as_string MIME::Lite::fields_as_string
0000s0sMIME::Lite::::filename MIME::Lite::filename
0000s0sMIME::Lite::::fold MIME::Lite::fold
0000s0sMIME::Lite::::gen_boundary MIME::Lite::gen_boundary
0000s0sMIME::Lite::::get MIME::Lite::get
0000s0sMIME::Lite::::get_length MIME::Lite::get_length
0000s0sMIME::Lite::::header_as_string MIME::Lite::header_as_string
0000s0sMIME::Lite::::is_mime_field MIME::Lite::is_mime_field
0000s0sMIME::Lite::::last_send_successful MIME::Lite::last_send_successful
0000s0sMIME::Lite::::my_extract_full_addrs MIME::Lite::my_extract_full_addrs
0000s0sMIME::Lite::::my_extract_only_addrs MIME::Lite::my_extract_only_addrs
0000s0sMIME::Lite::::new MIME::Lite::new
0000s0sMIME::Lite::::parts MIME::Lite::parts
0000s0sMIME::Lite::::parts_DFS MIME::Lite::parts_DFS
0000s0sMIME::Lite::::path MIME::Lite::path
0000s0sMIME::Lite::::preamble MIME::Lite::preamble
0000s0sMIME::Lite::::print MIME::Lite::print
0000s0sMIME::Lite::::print_body MIME::Lite::print_body
0000s0sMIME::Lite::::print_for_smtp MIME::Lite::print_for_smtp
0000s0sMIME::Lite::::print_header MIME::Lite::print_header
0000s0sMIME::Lite::::print_simple_body MIME::Lite::print_simple_body
0000s0sMIME::Lite::::quiet MIME::Lite::quiet
0000s0sMIME::Lite::::read_now MIME::Lite::read_now
0000s0sMIME::Lite::::replace MIME::Lite::replace
0000s0sMIME::Lite::::resetfh MIME::Lite::resetfh
0000s0sMIME::Lite::::scrub MIME::Lite::scrub
0000s0sMIME::Lite::::send MIME::Lite::send
0000s0sMIME::Lite::::send_by_sendmail MIME::Lite::send_by_sendmail
0000s0sMIME::Lite::::send_by_smtp MIME::Lite::send_by_smtp
0000s0sMIME::Lite::::send_by_smtp_simple MIME::Lite::send_by_smtp_simple
0000s0sMIME::Lite::::send_by_sub MIME::Lite::send_by_sub
0000s0sMIME::Lite::::send_by_testfile MIME::Lite::send_by_testfile
0000s0sMIME::Lite::::sendmail MIME::Lite::sendmail
0000s0sMIME::Lite::::sign MIME::Lite::sign
0000s0sMIME::Lite::::suggest_encoding MIME::Lite::suggest_encoding
0000s0sMIME::Lite::::suggest_type MIME::Lite::suggest_type
0000s0sMIME::Lite::::top_level MIME::Lite::top_level
0000s0sMIME::Lite::::verify_data MIME::Lite::verify_data
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments		 Time
on line		 Calls Time
in subs		 Code
1package MIME::Lite;
2387µs229µs
# spent 25µs (21+4) within MIME::Lite::BEGIN@2 which was called: # once (21µs+4µs) by C4::Letters::BEGIN@23 at line 2
use strict;
# spent 25µs making 1 call to MIME::Lite::BEGIN@2 # spent 4µs making 1 call to strict::import
3130µsrequire 5.004; ### for /c modifier in m/\G.../gc modifier
4
5=head1 NAME
6
- -
330324µs16µs
# spent 6µs within MIME::Lite::BEGIN@330 which was called: # once (6µs+0s) by C4::Letters::BEGIN@23 at line 330
use Carp ();
# spent 6µs making 1 call to MIME::Lite::BEGIN@330
331350µs21.13ms
# spent 575µs (19+556) within MIME::Lite::BEGIN@331 which was called: # once (19µs+556µs) by C4::Letters::BEGIN@23 at line 331
use FileHandle;
# spent 575µs making 1 call to MIME::Lite::BEGIN@331 # spent 556µs making 1 call to FileHandle::import
332
3331122µs
# spent 132µs (10+122) within MIME::Lite::BEGIN@333 which was called: # once (10µs+122µs) by C4::Letters::BEGIN@23 at line 343
use vars qw(
# spent 122µs making 1 call to vars::import
334 $AUTO_CC
335 $AUTO_CONTENT_TYPE
336 $AUTO_ENCODE
337 $AUTO_VERIFY
338 $PARANOID
339 $QUIET
340 $VANILLA
341 $VERSION
342 $DEBUG
3433813µs1132µs);
# spent 132µs making 1 call to MIME::Lite::BEGIN@333
344
345
346# GLOBALS, EXTERNAL/CONFIGURATION...
3471600ns$VERSION = '3.027';
348
349### Automatically interpret CC/BCC for SMTP:
3501200ns$AUTO_CC = 1;
351
352### Automatically choose content type from file name:
3531200ns$AUTO_CONTENT_TYPE = 0;
354
355### Automatically choose encoding from content type:
3561200ns$AUTO_ENCODE = 1;
357
358### Check paths right before printing:
3591200ns$AUTO_VERIFY = 1;
360
361### Set this true if you don't want to use MIME::Base64/QuotedPrint/Types:
3621200ns$PARANOID = 0;
363
364### Don't warn me about dangerous activities:
3651400ns$QUIET = undef;
366
367### Unsupported (for tester use): don't qualify boundary with time/pid:
3681300ns$VANILLA = 0;
369
3701200ns$MIME::Lite::DEBUG = 0;
371
372#==============================
373#==============================
374#
375# GLOBALS, INTERNAL...
376
3771500nsmy $Sender = "";
3781400nsmy $SENDMAIL = "";
379
380754µs16µsif ( $^O =~ /win32|cygwin/i ) {
# spent 6µs making 1 call to MIME::Lite::CORE:match
381 $Sender = "smtp";
382} else {
383 ### Find sendmail:
384 $Sender = "sendmail";
385 $SENDMAIL = "/usr/lib/sendmail";
386116µs ( -x $SENDMAIL ) or ( $SENDMAIL = "/usr/sbin/sendmail" );
# spent 16µs making 1 call to MIME::Lite::CORE:fteexec
38712µs ( -x $SENDMAIL ) or ( $SENDMAIL = "sendmail" );
# spent 2µs making 1 call to MIME::Lite::CORE:fteexec
38812µs unless (-x $SENDMAIL) {
# spent 2µs making 1 call to MIME::Lite::CORE:fteexec
389 require File::Spec;
390 for my $dir (File::Spec->path) {
391 if ( -x "$dir/sendmail" ) {
392 $SENDMAIL = "$dir/sendmail";
393 last;
394 }
395 }
396 }
39712µs unless (-x $SENDMAIL) {
# spent 2µs making 1 call to MIME::Lite::CORE:fteexec
398 undef $SENDMAIL;
399 }
400}
401
402### Our sending facilities:
40314µsmy %SenderArgs = (
404 sendmail => [$SENDMAIL ? "$SENDMAIL -t -oi -oem" : undef],
405 smtp => [],
406 sub => [],
407);
408
409### Boundary counter:
4101300nsmy $BCount = 0;
411
412### Known Mail/MIME fields... these, plus some general forms like
413### "x-*", are recognized by build():
414120µsmy %KnownField = map { $_ => 1 }
415 qw(
416 bcc cc comments date encrypted
417 from keywords message-id mime-version organization
418 received references reply-to return-path sender
419 subject to
420
421 approved
422);
423
424### What external packages do we use for encoding?
4251300nsmy @Uses;
426
427### Header order:
4281200nsmy @FieldOrder;
429
430### See if we have File::Basename
4311300nsmy $HaveFileBasename = 0;
432333µsif ( eval "require File::Basename" ) { # not affected by $PARANOID, core Perl
# spent 6µs executing statements in string eval
433 $HaveFileBasename = 1;
434 push @Uses, "F$File::Basename::VERSION";
435}
436
437### See if we have/want MIME::Types
4381400nsmy $HaveMimeTypes = 0;
439326µsif ( !$PARANOID and eval "require MIME::Types; MIME::Types->VERSION(1.28);" ) {
# spent 156µs executing statements in string eval
440 $HaveMimeTypes = 1;
441 push @Uses, "T$MIME::Types::VERSION";
442}
443
444#==============================
445#==============================
446#
447# PRIVATE UTILITY FUNCTIONS...
448
449#------------------------------
450#
451# fold STRING
452#
453# Make STRING safe as a field value. Remove leading/trailing whitespace,
454# and make sure newlines are represented as newline+space
455
456sub fold {
457 my $str = shift;
458 $str =~ s/^\s*|\s*$//g; ### trim
459 $str =~ s/\n/\n /g;
460 $str;
461}
462
463#------------------------------
464#
465# gen_boundary
466#
467# Generate a new boundary to use.
468# The unsupported $VANILLA is for test purposes only.
469
470sub gen_boundary {
471 return ( "_----------=_" . ( $VANILLA ? '' : int(time) . $$ ) . $BCount++ );
472}
473
474#------------------------------
475#
476# is_mime_field FIELDNAME
477#
478# Is this a field I manage?
479
480sub is_mime_field {
481 $_[0] =~ /^(mime\-|content\-)/i;
482}
483
484#------------------------------
485#
486# extract_full_addrs STRING
487# extract_only_addrs STRING
488#
489# Split STRING into an array of email addresses: somewhat of a KLUDGE.
490#
491# Unless paranoid, we try to load the real code before supplying our own.
492
# spent 15µs within MIME::Lite::BEGIN@492 which was called: # once (15µs+0s) by C4::Letters::BEGIN@23 at line 527
BEGIN {
493816µs my $ATOM = '[^ \000-\037()<>@,;:\134"\056\133\135]+';
494 my $QSTR = '".*?"';
495 my $WORD = '(?:' . $QSTR . '|' . $ATOM . ')';
496 my $DOMAIN = '(?:' . $ATOM . '(?:' . '\\.' . $ATOM . ')*' . ')';
497 my $LOCALPART = '(?:' . $WORD . '(?:' . '\\.' . $WORD . ')*' . ')';
498 my $ADDR = '(?:' . $LOCALPART . '@' . $DOMAIN . ')';
499 my $PHRASE = '(?:' . $WORD . ')+';
500 my $SEP = "(?:^\\s*|\\s*,\\s*)"; ### before elems in a list
501
502 sub my_extract_full_addrs {
503 my $str = shift;
504 return unless $str;
505 my @addrs;
506 $str =~ s/\s/ /g; ### collapse whitespace
507
508 pos($str) = 0;
509 while ( $str !~ m{\G\s*\Z}gco ) {
510 ### print STDERR "TACKLING: ".substr($str, pos($str))."\n";
511 if ( $str =~ m{\G$SEP($PHRASE)\s*<\s*($ADDR)\s*>}gco ) {
512 push @addrs, "$1 <$2>";
513 } elsif ( $str =~ m{\G$SEP($ADDR)}gco or $str =~ m{\G$SEP($ATOM)}gco ) {
514 push @addrs, $1;
515 } else {
516 my $problem = substr( $str, pos($str) );
517 die "can't extract address at <$problem> in <$str>\n";
518 }
519 }
520 return wantarray ? @addrs : $addrs[0];
521 }
522
523 sub my_extract_only_addrs {
524 my @ret = map { /<([^>]+)>/ ? $1 : $_ } my_extract_full_addrs(@_);
525 return wantarray ? @ret : $ret[0];
526 }
52714.57ms115µs}
# spent 15µs making 1 call to MIME::Lite::BEGIN@492
528#------------------------------
529
530
531248µsif ( !$PARANOID and eval "require Mail::Address" ) {
# spent 57µs executing statements in string eval
532 push @Uses, "A$Mail::Address::VERSION";
533 eval q{
534 sub extract_full_addrs {
535 my @ret=map { $_->format } Mail::Address->parse($_[0]);
536 return wantarray ? @ret : $ret[0]
537 }
538 sub extract_only_addrs {
539 my @ret=map { $_->address } Mail::Address->parse($_[0]);
540 return wantarray ? @ret : $ret[0]
541 }
542 }; ### q
543} else {
544 eval q{
# spent 5µs executing statements in string eval
545 *extract_full_addrs=*my_extract_full_addrs;
546 *extract_only_addrs=*my_extract_only_addrs;
547 }; ### q
548} ### if
549
550#==============================
551#==============================
552#
553# PRIVATE ENCODING FUNCTIONS...
554
555#------------------------------
556#
557# encode_base64 STRING
558#
559# Encode the given string using BASE64.
560# Unless paranoid, we try to load the real code before supplying our own.
561
562324µsif ( !$PARANOID and eval "require MIME::Base64" ) {
# spent 81µs executing statements in string eval
563146µs import MIME::Base64 qw(encode_base64);
# spent 46µs making 1 call to Exporter::import
564 push @Uses, "B$MIME::Base64::VERSION";
565} else {
566 eval q{
567 sub encode_base64 {
568 my $res = "";
569 my $eol = "\n";
570
571 pos($_[0]) = 0; ### thanks, Andreas!
572 while ($_[0] =~ /(.{1,45})/gs) {
573 $res .= substr(pack('u', $1), 1);
574 chop($res);
575 }
576 $res =~ tr|` -_|AA-Za-z0-9+/|;
577
578 ### Fix padding at the end:
579 my $padding = (3 - length($_[0]) % 3) % 3;
580 $res =~ s/.{$padding}$/'=' x $padding/e if $padding;
581
582 ### Break encoded string into lines of no more than 76 characters each:
583 $res =~ s/(.{1,76})/$1$eol/g if (length $eol);
584 return $res;
585 } ### sub
586 } ### q
587} ### if
588
589#------------------------------
590#
591# encode_qp STRING
592#
593# Encode the given string, LINE BY LINE, using QUOTED-PRINTABLE.
594# Stolen from MIME::QuotedPrint by Gisle Aas, with a slight bug fix: we
595# break lines earlier. Notice that this seems not to work unless
596# encoding line by line.
597#
598# Unless paranoid, we try to load the real code before supplying our own.
599
600332µsif ( !$PARANOID and eval "require MIME::QuotedPrint" ) {
# spent 132µs executing statements in string eval
601141µs import MIME::QuotedPrint qw(encode_qp);
# spent 41µs making 1 call to Exporter::import
602 push @Uses, "Q$MIME::QuotedPrint::VERSION";
603} else {
604 eval q{
605 sub encode_qp {
606 my $res = shift;
607 local($_);
608 $res =~ s/([^ \t\n!-<>-~])/sprintf("=%02X", ord($1))/eg; ### rule #2,#3
609 $res =~ s/([ \t]+)$/
610 join('', map { sprintf("=%02X", ord($_)) }
611 split('', $1)
612 )/egm; ### rule #3 (encode whitespace at eol)
613
614 ### rule #5 (lines shorter than 76 chars, but can't break =XX escapes:
615 my $brokenlines = "";
616 $brokenlines .= "$1=\n" while $res =~ s/^(.{70}([^=]{2})?)//; ### 70 was 74
617 $brokenlines =~ s/=\n$// unless length $res;
618 "$brokenlines$res";
619 } ### sub
620 } ### q
621} ### if
622
623
624#------------------------------
625#
626# encode_8bit STRING
627#
628# Encode the given string using 8BIT.
629# This breaks long lines into shorter ones.
630
631sub encode_8bit {
632 my $str = shift;
633 $str =~ s/^(.{990})/$1\n/mg;
634 $str;
635}
636
637#------------------------------
638#
639# encode_7bit STRING
640#
641# Encode the given string using 7BIT.
642# This NO LONGER protects people through encoding.
643
644sub encode_7bit {
645 my $str = shift;
646 $str =~ s/[\x80-\xFF]//g;
647 $str =~ s/^(.{990})/$1\n/mg;
648 $str;
649}
650
651#==============================
652#==============================
653
654=head2 Construction
655
- -
661#------------------------------
662
663=item new [PARAMHASH]
664
- -
674sub new {
675 my $class = shift;
676
677 ### Create basic object:
678 my $self = { Attrs => {}, ### MIME attributes
679 SubAttrs => {}, ### MIME sub-attributes
680 Header => [], ### explicit message headers
681 Parts => [], ### array of parts
682 };
683 bless $self, $class;
684
685 ### Build, if needed:
686 return ( @_ ? $self->build(@_) : $self );
687}
688
689
690#------------------------------
691
692=item attach PART
693
- -
737sub attach {
738 my $self = shift;
739 my $attrs = $self->{Attrs};
740 my $sub_attrs = $self->{SubAttrs};
741
742 ### Create new part, if necessary:
743 my $part1 = ( ( @_ == 1 ) ? shift: ref($self)->new( Top => 0, @_ ) );
744
745 ### Do the "attach-to-singlepart" hack:
746 if ( $attrs->{'content-type'} !~ m{^(multipart|message)/}i ) {
747
748 ### Create part zero:
749 my $part0 = ref($self)->new;
750
751 ### Cut MIME stuff from self, and paste into part zero:
752 foreach (qw(SubAttrs Attrs Data Path FH)) {
753 $part0->{$_} = $self->{$_};
754 delete( $self->{$_} );
755 }
756 $part0->top_level(0); ### clear top-level attributes
757
758 ### Make self a top-level multipart:
759 $attrs = $self->{Attrs} ||= {}; ### reset (sam: bug? this doesn't reset anything since Attrs is already a hash-ref)
760 $sub_attrs = $self->{SubAttrs} ||= {}; ### reset
761 $attrs->{'content-type'} = 'multipart/mixed';
762 $sub_attrs->{'content-type'}{'boundary'} = gen_boundary();
763 $attrs->{'content-transfer-encoding'} = '7bit';
764 $self->top_level(1); ### activate top-level attributes
765
766 ### Add part 0:
767 push @{ $self->{Parts} }, $part0;
768 }
769
770 ### Add the new part:
771 push @{ $self->{Parts} }, $part1;
772 $part1;
773}
774
775#------------------------------
776
777=item build [PARAMHASH]
778
- -
974sub build {
975 my $self = shift;
976 my %params = @_;
977 my @params = @_;
978 my $key;
979
980 ### Miko's note: reorganized to check for exactly one of Data, Path, or FH
981 ( defined( $params{Data} ) + defined( $params{Path} ) + defined( $params{FH} ) <= 1 )
982 or Carp::croak "supply exactly zero or one of (Data|Path|FH).\n";
983
984 ### Create new instance, if necessary:
985 ref($self) or $self = $self->new;
986
987
988 ### CONTENT-TYPE....
989 ###
990
991 ### Get content-type or content-type-macro:
992 my $type = ( $params{Type} || ( $AUTO_CONTENT_TYPE ? 'AUTO' : 'TEXT' ) );
993
994 ### Interpret content-type-macros:
995 if ( $type eq 'TEXT' ) { $type = 'text/plain'; }
996 elsif ( $type eq 'HTML' ) { $type = 'text/html'; }
997 elsif ( $type eq 'BINARY' ) { $type = 'application/octet-stream' }
998 elsif ( $type eq 'AUTO' ) { $type = $self->suggest_type( $params{Path} ); }
999
1000 ### We now have a content-type; set it:
1001 $type = lc($type);
1002 my $attrs = $self->{Attrs};
1003 my $sub_attrs = $self->{SubAttrs};
1004 $attrs->{'content-type'} = $type;
1005
1006 ### Get some basic attributes from the content type:
1007 my $is_multipart = ( $type =~ m{^(multipart)/}i );
1008
1009 ### Add in the multipart boundary:
1010 if ($is_multipart) {
1011 my $boundary = gen_boundary();
1012 $sub_attrs->{'content-type'}{'boundary'} = $boundary;
1013 }
1014
1015
1016 ### CONTENT-ID...
1017 ###
1018 if ( defined $params{Id} ) {
1019 my $id = $params{Id};
1020 $id = "<$id>" unless $id =~ /\A\s*<.*>\s*\z/;
1021 $attrs->{'content-id'} = $id;
1022 }
1023
1024
1025 ### DATA OR PATH...
1026 ### Note that we must do this *after* we get the content type,
1027 ### in case read_now() is invoked, since it needs the binmode().
1028
1029 ### Get data, as...
1030 ### ...either literal data:
1031 if ( defined( $params{Data} ) ) {
1032 $self->data( $params{Data} );
1033 }
1034 ### ...or a path to data:
1035 elsif ( defined( $params{Path} ) ) {
1036 $self->path( $params{Path} ); ### also sets filename
1037 $self->read_now if $params{ReadNow};
1038 }
1039 ### ...or a filehandle to data:
1040 ### Miko's note: this part works much like the path routine just above,
1041 elsif ( defined( $params{FH} ) ) {
1042 $self->fh( $params{FH} );
1043 $self->read_now if $params{ReadNow}; ### implement later
1044 }
1045
1046
1047 ### FILENAME... (added by Ian Smith <ian@safeway.dircon.co.uk> on 8/4/97)
1048 ### Need this to make sure the filename is added. The Filename
1049 ### attribute is ignored, otherwise.
1050 if ( defined( $params{Filename} ) ) {
1051 $self->filename( $params{Filename} );
1052 }
1053
1054
1055 ### CONTENT-TRANSFER-ENCODING...
1056 ###
1057
1058 ### Get it:
1059 my $enc =
1060 ( $params{Encoding} || ( $AUTO_ENCODE and $self->suggest_encoding($type) ) || 'binary' );
1061 $attrs->{'content-transfer-encoding'} = lc($enc);
1062
1063 ### Sanity check:
1064 if ( $type =~ m{^(multipart|message)/} ) {
1065 ( $enc =~ m{^(7bit|8bit|binary)\Z} )
1066 or Carp::croak( "illegal MIME: " . "can't have encoding $enc with type $type\n" );
1067 }
1068
1069 ### CONTENT-DISPOSITION...
1070 ### Default is inline for single, none for multis:
1071 ###
1072 my $disp = ( $params{Disposition} or ( $is_multipart ? undef: 'inline' ) );
1073 $attrs->{'content-disposition'} = $disp;
1074
1075 ### CONTENT-LENGTH...
1076 ###
1077 my $length;
1078 if ( exists( $params{Length} ) ) { ### given by caller:
1079 $attrs->{'content-length'} = $params{Length};
1080 } else { ### compute it ourselves
1081 $self->get_length;
1082 }
1083
1084 ### Init the top-level fields:
1085 my $is_top = defined( $params{Top} ) ? $params{Top} : 1;
1086 $self->top_level($is_top);
1087
1088 ### Datestamp if desired:
1089 my $ds_wanted = $params{Datestamp};
1090 my $ds_defaulted = ( $is_top and !exists( $params{Datestamp} ) );
1091 if ( ( $ds_wanted or $ds_defaulted ) and !exists( $params{Date} ) ) {
1092 require Email::Date::Format;
1093 $self->add( "date", Email::Date::Format::email_date() );
1094 }
1095
1096 ### Set message headers:
1097 my @paramz = @params;
1098 my $field;
1099 while (@paramz) {
1100 my ( $tag, $value ) = ( shift(@paramz), shift(@paramz) );
1101 my $lc_tag = lc($tag);
1102
1103 ### Get tag, if a tag:
1104 if ( $lc_tag =~ /^-(.*)/ ) { ### old style, backwards-compatibility
1105 $field = $1;
1106 } elsif ( $lc_tag =~ /^(.*):$/ ) { ### new style
1107 $field = $1;
1108 } elsif ( $KnownField{$lc_tag} or
1109 $lc_tag =~ m{^(content|resent|x)-.} ){
1110 $field = $lc_tag;
1111 } else { ### not a field:
1112 next;
1113 }
1114
1115 ### Add it:
1116 $self->add( $field, $value );
1117 }
1118
1119 ### Done!
1120 $self;
1121}
1122
1123=back
1124
- -
1128#==============================
1129#==============================
1130
1131=head2 Setting/getting headers and attributes
1132
- -
1138#------------------------------
1139#
1140# top_level ONOFF
1141#
1142# Set/unset the top-level attributes and headers.
1143# This affects "MIME-Version" and "X-Mailer".
1144
1145sub top_level {
1146 my ( $self, $onoff ) = @_;
1147 my $attrs = $self->{Attrs};
1148 if ($onoff) {
1149 $attrs->{'MIME-Version'} = '1.0';
1150 my $uses = ( @Uses ? ( "(" . join( "; ", @Uses ) . ")" ) : '' );
1151 $self->replace( 'X-Mailer' => "MIME::Lite $VERSION $uses" )
1152 unless $VANILLA;
1153 } else {
1154 delete $attrs->{'MIME-Version'};
1155 $self->delete('X-Mailer');
1156 }
1157}
1158
1159#------------------------------
1160
1161=item add TAG,VALUE
1162
- -
1195sub add {
1196 my $self = shift;
1197 my $tag = lc(shift);
1198 my $value = shift;
1199
1200 ### If a dangerous option, warn them:
1201 Carp::carp "Explicitly setting a MIME header field ($tag) is dangerous:\n"
1202 . "use the attr() method instead.\n"
1203 if ( is_mime_field($tag) && !$QUIET );
1204
1205 ### Get array of clean values:
1206 my @vals = ( ( ref($value) and ( ref($value) eq 'ARRAY' ) )
1207 ? @{$value}
1208 : ( $value . '' )
1209 );
1210 map { s/\n/\n /g } @vals;
1211
1212 ### Add them:
1213 foreach (@vals) {
1214 push @{ $self->{Header} }, [ $tag, $_ ];
1215 }
1216}
1217
1218#------------------------------
1219
1220=item attr ATTR,[VALUE]
1221
- -
1249sub attr {
1250 my ( $self, $attr, $value ) = @_;
1251 my $attrs = $self->{Attrs};
1252
1253 $attr = lc($attr);
1254
1255 ### Break attribute name up:
1256 my ( $tag, $subtag ) = split /\./, $attr;
1257 if (defined($subtag)) {
1258 $attrs = $self->{SubAttrs}{$tag} ||= {};
1259 $tag = $subtag;
1260 }
1261
1262 ### Set or get?
1263 if ( @_ > 2 ) { ### set:
1264 if ( defined($value) ) {
1265 $attrs->{$tag} = $value;
1266 } else {
1267 delete $attrs->{$tag};
1268 }
1269 }
1270
1271 ### Return current value:
1272 $attrs->{$tag};
1273}
1274
1275sub _safe_attr {
1276 my ( $self, $attr ) = @_;
1277 return defined $self->{Attrs}{$attr} ? $self->{Attrs}{$attr} : '';
1278}
1279
1280#------------------------------
1281
1282=item delete TAG
1283
- -
1295sub delete {
1296 my $self = shift;
1297 my $tag = lc(shift);
1298
1299 ### Delete from the header:
1300 my $hdr = [];
1301 my $field;
1302 foreach $field ( @{ $self->{Header} } ) {
1303 push @$hdr, $field if ( $field->[0] ne $tag );
1304 }
1305 $self->{Header} = $hdr;
1306 $self;
1307}
1308
1309
1310#------------------------------
1311
1312=item field_order FIELD,...FIELD
1313
- -
1330sub field_order {
1331 my $self = shift;
1332 if ( ref($self) ) {
1333 $self->{FieldOrder} = [ map { lc($_) } @_ ];
1334 } else {
1335 @FieldOrder = map { lc($_) } @_;
1336 }
1337}
1338
1339#------------------------------
1340
1341=item fields
1342
- -
1366sub fields {
1367 my $self = shift;
1368 my @fields;
1369 my $attrs = $self->{Attrs};
1370 my $sub_attrs = $self->{SubAttrs};
1371
1372 ### Get a lookup-hash of all *explicitly-given* fields:
1373 my %explicit = map { $_->[0] => 1 } @{ $self->{Header} };
1374
1375 ### Start with any MIME attributes not given explicitly:
1376 my $tag;
1377 foreach $tag ( sort keys %{ $self->{Attrs} } ) {
1378
1379 ### Skip if explicit:
1380 next if ( $explicit{$tag} );
1381
1382 # get base attr value or skip if not available
1383 my $value = $attrs->{$tag};
1384 defined $value or next;
1385
1386 ### handle sub-attrs if available
1387 if (my $subs = $sub_attrs->{$tag}) {
1388 $value .= '; ' .
1389 join('; ', map { qq{$_="$subs->{$_}"} } sort keys %$subs);
1390 }
1391
1392 # handle stripping \r\n now since we're not doing it in attr()
1393 # anymore
1394 $value =~ tr/\r\n//;
1395
1396 ### Add to running fields;
1397 push @fields, [ $tag, $value ];
1398 }
1399
1400 ### Add remaining fields (note that we duplicate the array for safety):
1401 foreach ( @{ $self->{Header} } ) {
1402 push @fields, [ @{$_} ];
1403 }
1404
1405 ### Final step:
1406 ### If a suggested ordering was given, we "sort" by that ordering.
1407 ### The idea is that we give each field a numeric rank, which is
1408 ### (1000 * order(field)) + origposition.
1409 my @order = @{ $self->{FieldOrder} || [] }; ### object-specific
1410 @order or @order = @FieldOrder; ### no? maybe generic
1411 if (@order) { ### either?
1412
1413 ### Create hash mapping field names to 1-based rank:
1414 my %rank = map { $order[$_] => ( 1 + $_ ) } ( 0 .. $#order );
1415
1416 ### Create parallel array to @fields, called @ranked.
1417 ### It contains fields tagged with numbers like 2003, where the
1418 ### 3 is the original 0-based position, and 2000 indicates that
1419 ### we wanted ths type of field to go second.
1420 my @ranked = map {
1421 [ ( $_ + 1000 * ( $rank{ lc( $fields[$_][0] ) } || ( 2 + $#order ) ) ), $fields[$_] ]
1422 } ( 0 .. $#fields );
1423
1424 # foreach (@ranked) {
1425 # print STDERR "RANKED: $_->[0] $_->[1][0] $_->[1][1]\n";
1426 # }
1427
1428 ### That was half the Schwartzian transform. Here's the rest:
1429 @fields = map { $_->[1] }
1430 sort { $a->[0] <=> $b->[0] } @ranked;
1431 }
1432
1433 ### Done!
1434 return \@fields;
1435}
1436
1437
1438#------------------------------
1439
1440=item filename [FILENAME]
1441
- -
1452sub filename {
1453 my ( $self, $filename ) = @_;
1454 my $sub_attrs = $self->{SubAttrs};
1455
1456 if ( @_ > 1 ) {
1457 $sub_attrs->{'content-type'}{'name'} = $filename;
1458 $sub_attrs->{'content-disposition'}{'filename'} = $filename;
1459 }
1460 return $sub_attrs->{'content-disposition'}{'filename'};
1461}
1462
1463#------------------------------
1464
1465=item get TAG,[INDEX]
1466
- -
1484sub get {
1485 my ( $self, $tag, $index ) = @_;
1486 $tag = lc($tag);
1487 Carp::croak "get: can't be used with MIME fields\n" if is_mime_field($tag);
1488
1489 my @all = map { ( $_->[0] eq $tag ) ? $_->[1] : () } @{ $self->{Header} };
1490 ( defined($index) ? $all[$index] : ( wantarray ? @all : $all[0] ) );
1491}
1492
1493#------------------------------
1494
1495=item get_length
1496
- -
1521#----
1522# Miko's note: I wasn't quite sure how to handle this, so I waited to hear
1523# what you think. Given that the content-length isn't always required,
1524# and given the performance cost of calculating it from a file handle,
1525# I thought it might make more sense to add some some sort of computelength
1526# property. If computelength is false, then the length simply isn't
1527# computed. What do you think?
1528#
1529# Eryq's reply: I agree; for now, we can silently leave out the content-type.
1530
1531sub get_length {
1532 my $self = shift;
1533 my $attrs = $self->{Attrs};
1534
1535 my $is_multipart = ( $attrs->{'content-type'} =~ m{^multipart/}i );
1536 my $enc = lc( $attrs->{'content-transfer-encoding'} || 'binary' );
1537 my $length;
1538 if ( !$is_multipart && ( $enc eq "binary" ) ) { ### might figure it out cheap:
1539 if ( defined( $self->{Data} ) ) { ### it's in core
1540 $length = length( $self->{Data} );
1541 } elsif ( defined( $self->{FH} ) ) { ### it's in a filehandle
1542 ### no-op: it's expensive, so don't bother
1543 } elsif ( defined( $self->{Path} ) ) { ### it's a simple file!
1544 $length = ( -s $self->{Path} ) if ( -e $self->{Path} );
1545 }
1546 }
1547 $attrs->{'content-length'} = $length;
1548 return $length;
1549}
1550
1551#------------------------------
1552
1553=item parts
1554
- -
1565sub parts {
1566 my $self = shift;
1567 @{ $self->{Parts} || [] };
1568}
1569
1570#------------------------------
1571
1572=item parts_DFS
1573
- -
1582sub parts_DFS {
1583 my $self = shift;
1584 return ( $self, map { $_->parts_DFS } $self->parts );
1585}
1586
1587#------------------------------
1588
1589=item preamble [TEXT]
1590
- -
1598sub preamble {
1599 my $self = shift;
1600 $self->{Preamble} = shift if @_;
1601 $self->{Preamble};
1602}
1603
1604#------------------------------
1605
1606=item replace TAG,VALUE
1607
- -
1634sub replace {
1635 my ( $self, $tag, $value ) = @_;
1636 $self->delete($tag);
1637 $self->add( $tag, $value ) if defined($value);
1638}
1639
1640
1641#------------------------------
1642
1643=item scrub
1644
- -
1661sub scrub {
1662 my ( $self, @a ) = @_;
1663 my ($expl) = @a;
1664 local $QUIET = 1;
1665
1666 ### Scrub me:
1667 if ( !@a ) { ### guess
1668
1669 ### Scrub length always:
1670 $self->replace( 'content-length', '' );
1671
1672 ### Scrub disposition if no filename, or if content-type has same info:
1673 if ( !$self->_safe_attr('content-disposition.filename')
1674 || $self->_safe_attr('content-type.name') )
1675 {
1676 $self->replace( 'content-disposition', '' );
1677 }
1678
1679 ### Scrub encoding if effectively unencoded:
1680 if ( $self->_safe_attr('content-transfer-encoding') =~ /^(7bit|8bit|binary)$/i ) {
1681 $self->replace( 'content-transfer-encoding', '' );
1682 }
1683
1684 ### Scrub charset if US-ASCII:
1685 if ( $self->_safe_attr('content-type.charset') =~ /^(us-ascii)/i ) {
1686 $self->attr( 'content-type.charset' => undef );
1687 }
1688
1689 ### TBD: this is not really right for message/digest:
1690 if ( ( keys %{ $self->{Attrs}{'content-type'} } == 1 )
1691 and ( $self->_safe_attr('content-type') eq 'text/plain' ) )
1692 {
1693 $self->replace( 'content-type', '' );
1694 }
1695 } elsif ( $expl and ( ref($expl) eq 'ARRAY' ) ) {
1696 foreach ( @{$expl} ) { $self->replace( $_, '' ); }
1697 }
1698
1699 ### Scrub my kids:
1700 foreach ( @{ $self->{Parts} } ) { $_->scrub(@a); }
1701}
1702
1703=back
1704
- -
1708#==============================
1709#==============================
1710
1711=head2 Setting/getting message data
1712
- -
1718#------------------------------
1719
1720=item binmode [OVERRIDE]
1721
- -
1737sub binmode {
1738 my $self = shift;
1739 $self->{Binmode} = shift if (@_); ### argument? set override
1740 return ( defined( $self->{Binmode} )
1741 ? $self->{Binmode}
1742 : ( $self->{Attrs}{"content-type"} !~ m{^(text|message)/}i )
1743 );
1744}
1745
1746#------------------------------
1747
1748=item data [DATA]
1749
- -
1761sub data {
1762 my $self = shift;
1763 if (@_) {
1764 $self->{Data} = ( ( ref( $_[0] ) eq 'ARRAY' ) ? join( '', @{ $_[0] } ) : $_[0] );
1765 $self->get_length;
1766 }
1767 $self->{Data};
1768}
1769
1770#------------------------------
1771
1772=item fh [FILEHANDLE]
1773
- -
1784sub fh {
1785 my $self = shift;
1786 $self->{FH} = shift if @_;
1787 $self->{FH};
1788}
1789
1790#------------------------------
1791
1792=item path [PATH]
1793
- -
1804sub path {
1805 my $self = shift;
1806 if (@_) {
1807
1808 ### Set the path, and invalidate the content length:
1809 $self->{Path} = shift;
1810
1811 ### Re-set filename, extracting it from path if possible:
1812 my $filename;
1813 if ( $self->{Path} and ( $self->{Path} !~ /\|$/ ) ) { ### non-shell path:
1814 ( $filename = $self->{Path} ) =~ s/^<//;
1815
1816 ### Consult File::Basename, maybe:
1817 if ($HaveFileBasename) {
1818 $filename = File::Basename::basename($filename);
1819 } else {
1820 ($filename) = ( $filename =~ m{([^\/]+)\Z} );
1821 }
1822 }
1823 $self->filename($filename);
1824
1825 ### Reset the length:
1826 $self->get_length;
1827 }
1828 $self->{Path};
1829}
1830
1831#------------------------------
1832
1833=item resetfh [FILEHANDLE]
1834
- -
1845#----
1846# Miko's note: With the Data and Path, the same data could theoretically
1847# be reused. However, file handles need to be reset to be reused,
1848# so I added this routine.
1849#
1850# Eryq reply: beware... not all filehandles are seekable (think about STDIN)!
1851
1852sub resetfh {
1853 my $self = shift;
1854 seek( $self->{FH}, 0, 0 );
1855}
1856
1857#------------------------------
1858
1859=item read_now
1860
- -
1876sub read_now {
1877 my $self = shift;
1878 local $/ = undef;
1879
1880 if ( $self->{FH} ) { ### data from a filehandle:
1881 my $chunk;
1882 my @chunks;
1883 CORE::binmode( $self->{FH} ) if $self->binmode;
1884 while ( read( $self->{FH}, $chunk, 1024 ) ) {
1885 push @chunks, $chunk;
1886 }
1887 $self->{Data} = join '', @chunks;
1888 } elsif ( $self->{Path} ) { ### data from a path:
1889 open SLURP, $self->{Path} or Carp::croak "open $self->{Path}: $!\n";
1890 CORE::binmode(SLURP) if $self->binmode;
1891 $self->{Data} = <SLURP>; ### sssssssssssssslurp...
1892 close SLURP; ### ...aaaaaaaaahhh!
1893 }
1894}
1895
1896#------------------------------
1897
1898=item sign PARAMHASH
1899
- -
1926sub sign {
1927 my $self = shift;
1928 my %params = @_;
1929
1930 ### Default:
1931 @_ or $params{Path} = "$ENV{HOME}/.signature";
1932
1933 ### Force message in-core:
1934 defined( $self->{Data} ) or $self->read_now;
1935
1936 ### Load signature:
1937 my $sig;
1938 if ( !defined( $sig = $params{Data} ) ) { ### not given explicitly:
1939 local $/ = undef;
1940 open SIG, $params{Path} or Carp::croak "open sig $params{Path}: $!\n";
1941 $sig = <SIG>; ### sssssssssssssslurp...
1942 close SIG; ### ...aaaaaaaaahhh!
1943 }
1944 $sig = join( '', @$sig ) if ( ref($sig) and ( ref($sig) eq 'ARRAY' ) );
1945
1946 ### Append, following Internet conventions:
1947 $self->{Data} .= "\n-- \n$sig";
1948
1949 ### Re-compute length:
1950 $self->get_length;
1951 1;
1952}
1953
1954#------------------------------
1955#
1956# =item suggest_encoding CONTENTTYPE
1957#
1958# I<Class/instance method.>
1959# Based on the CONTENTTYPE, return a good suggested encoding.
1960# C<text> and C<message> types have their bodies scanned line-by-line
1961# for 8-bit characters and long lines; lack of either means that the
1962# message is 7bit-ok. Other types are chosen independent of their body:
1963#
1964# Major type: 7bit ok? Suggested encoding:
1965# ------------------------------------------------------------
1966# text yes 7bit
1967# no quoted-printable
1968# unknown binary
1969#
1970# message yes 7bit
1971# no binary
1972# unknown binary
1973#
1974# multipart n/a binary (in case some parts are not ok)
1975#
1976# (other) n/a base64
1977#
1978#=cut
1979
1980sub suggest_encoding {
1981 my ( $self, $ctype ) = @_;
1982 $ctype = lc($ctype);
1983
1984 ### Consult MIME::Types, maybe:
1985 if ($HaveMimeTypes) {
1986
1987 ### Mappings contain [suffix,mimetype,encoding]
1988 my @mappings = MIME::Types::by_mediatype($ctype);
1989 if ( scalar(@mappings) ) {
1990 ### Just pick the first one:
1991 my ( $suffix, $mimetype, $encoding ) = @{ $mappings[0] };
1992 if ( $encoding
1993 && $encoding =~ /^(base64|binary|[78]bit|quoted-printable)$/i )
1994 {
1995 return lc($encoding); ### sanity check
1996 }
1997 }
1998 }
1999
2000 ### If we got here, then MIME::Types was no help.
2001 ### Extract major type:
2002 my ($type) = split '/', $ctype;
2003 if ( ( $type eq 'text' ) || ( $type eq 'message' ) ) { ### scan message body?
2004 return 'binary';
2005 } else {
2006 return ( $type eq 'multipart' ) ? 'binary' : 'base64';
2007 }
2008}
2009
2010#------------------------------
2011#
2012# =item suggest_type PATH
2013#
2014# I<Class/instance method.>
2015# Suggest the content-type for this attached path.
2016# We always fall back to "application/octet-stream" if no good guess
2017# can be made, so don't use this if you don't mean it!
2018#
2019sub suggest_type {
2020 my ( $self, $path ) = @_;
2021
2022 ### If there's no path, bail:
2023 $path or return 'application/octet-stream';
2024
2025 ### Consult MIME::Types, maybe:
2026 if ($HaveMimeTypes) {
2027
2028 # Mappings contain [mimetype,encoding]:
2029 my ( $mimetype, $encoding ) = MIME::Types::by_suffix($path);
2030 return $mimetype if ( $mimetype && $mimetype =~ /^\S+\/\S+$/ ); ### sanity check
2031 }
2032 ### If we got here, then MIME::Types was no help.
2033 ### The correct thing to fall back to is the most-generic content type:
2034 return 'application/octet-stream';
2035}
2036
2037#------------------------------
2038
2039=item verify_data
2040
- -
2050sub verify_data {
2051 my $self = shift;
2052
2053 ### Verify self:
2054 my $path = $self->{Path};
2055 if ( $path and ( $path !~ /\|$/ ) ) { ### non-shell path:
2056 $path =~ s/^<//;
2057 ( -r $path ) or die "$path: not readable\n";
2058 }
2059
2060 ### Verify parts:
2061 foreach my $part ( @{ $self->{Parts} } ) { $part->verify_data }
2062 1;
2063}
2064
2065=back
2066
- -
2070#==============================
2071#==============================
2072
2073=head2 Output
2074
- -
2080#------------------------------
2081
2082=item print [OUTHANDLE]
2083
- -
2094sub print {
2095 my ( $self, $out ) = @_;
2096
2097 ### Coerce into a printable output handle:
2098 $out = MIME::Lite::IO_Handle->wrap($out);
2099
2100 ### Output head, separator, and body:
2101 $self->verify_data if $AUTO_VERIFY; ### prevents missing parts!
2102 $out->print( $self->header_as_string, "\n" );
2103 $self->print_body($out);
2104}
2105
2106#------------------------------
2107#
2108# print_for_smtp
2109#
2110# Instance method, private.
2111# Print, but filter out the topmost "Bcc" field.
2112# This is because qmail apparently doesn't do this for us!
2113#
2114sub print_for_smtp {
2115 my ( $self, $out ) = @_;
2116
2117 ### Coerce into a printable output handle:
2118 $out = MIME::Lite::IO_Handle->wrap($out);
2119
2120 ### Create a safe head:
2121 my @fields = grep { $_->[0] ne 'bcc' } @{ $self->fields };
2122 my $header = $self->fields_as_string( \@fields );
2123
2124 ### Output head, separator, and body:
2125 $out->print( $header, "\n" );
2126 $self->print_body( $out, '1' );
2127}
2128
2129#------------------------------
2130
2131=item print_body [OUTHANDLE] [IS_SMTP]
2132
- -
2153sub print_body {
2154 my ( $self, $out, $is_smtp ) = @_;
2155 my $attrs = $self->{Attrs};
2156 my $sub_attrs = $self->{SubAttrs};
2157
2158 ### Coerce into a printable output handle:
2159 $out = MIME::Lite::IO_Handle->wrap($out);
2160
2161 ### Output either the body or the parts.
2162 ### Notice that we key off of the content-type! We expect fewer
2163 ### accidents that way, since the syntax will always match the MIME type.
2164 my $type = $attrs->{'content-type'};
2165 if ( $type =~ m{^multipart/}i ) {
2166 my $boundary = $sub_attrs->{'content-type'}{'boundary'};
2167
2168 ### Preamble:
2169 $out->print( defined( $self->{Preamble} )
2170 ? $self->{Preamble}
2171 : "This is a multi-part message in MIME format.\n"
2172 );
2173
2174 ### Parts:
2175 my $part;
2176 foreach $part ( @{ $self->{Parts} } ) {
2177 $out->print("\n--$boundary\n");
2178 $part->print($out);
2179 }
2180
2181 ### Epilogue:
2182 $out->print("\n--$boundary--\n\n");
2183 } elsif ( $type =~ m{^message/} ) {
2184 my @parts = @{ $self->{Parts} };
2185
2186 ### It's a toss-up; try both data and parts:
2187 if ( @parts == 0 ) { $self->print_simple_body( $out, $is_smtp ) }
2188 elsif ( @parts == 1 ) { $parts[0]->print($out) }
2189 else { Carp::croak "can't handle message with >1 part\n"; }
2190 } else {
2191 $self->print_simple_body( $out, $is_smtp );
2192 }
2193 1;
2194}
2195
2196#------------------------------
2197#
2198# print_simple_body [OUTHANDLE]
2199#
2200# I<Instance method, private.>
2201# Print the body of a simple singlepart message to the given
2202# output handle, or to the currently-selected filehandle if none
2203# was given.
2204#
2205# Note that if you want to print "the portion after
2206# the header", you don't want this method: you want
2207# L<print_body()|/print_body>.
2208#
2209# All OUTHANDLE has to be is a filehandle (possibly a glob ref), or
2210# any object that responds to a print() message.
2211#
2212# B<Fatal exception> raised if unable to open any of the input files,
2213# or if a part contains no data, or if an unsupported encoding is
2214# encountered.
2215#
2216sub print_simple_body {
2217 my ( $self, $out, $is_smtp ) = @_;
2218 my $attrs = $self->{Attrs};
2219
2220 ### Coerce into a printable output handle:
2221 $out = MIME::Lite::IO_Handle->wrap($out);
2222
2223 ### Get content-transfer-encoding:
2224 my $encoding = uc( $attrs->{'content-transfer-encoding'} );
2225 warn "M::L >>> Encoding using $encoding, is_smtp=" . ( $is_smtp || 0 ) . "\n"
2226 if $MIME::Lite::DEBUG;
2227
2228 ### Notice that we don't just attempt to slurp the data in from a file:
2229 ### by processing files piecemeal, we still enable ourselves to prepare
2230 ### very large MIME messages...
2231
2232 ### Is the data in-core? If so, blit it out...
2233 if ( defined( $self->{Data} ) ) {
2234 DATA:
2235 {
2236 local $_ = $encoding;
2237
2238 /^BINARY$/ and do {
2239 $is_smtp and $self->{Data} =~ s/(?!\r)\n\z/\r/;
2240 $out->print( $self->{Data} );
2241 last DATA;
2242 };
2243 /^8BIT$/ and do {
2244 $out->print( encode_8bit( $self->{Data} ) );
2245 last DATA;
2246 };
2247 /^7BIT$/ and do {
2248 $out->print( encode_7bit( $self->{Data} ) );
2249 last DATA;
2250 };
2251 /^QUOTED-PRINTABLE$/ and do {
2252 ### UNTAINT since m//mg on tainted data loops forever:
2253 my ($untainted) = ( $self->{Data} =~ m/\A(.*)\Z/s );
2254
2255 ### Encode it line by line:
2256 while ( $untainted =~ m{^(.*[\r\n]*)}smg ) {
2257 ### have to do it line by line...
2258 my $line = $1; # copy to avoid weird bug; rt 39334
2259 $out->print( encode_qp($line) );
2260 }
2261 last DATA;
2262 };
2263 /^BASE64/ and do {
2264 $out->print( encode_base64( $self->{Data} ) );
2265 last DATA;
2266 };
2267 Carp::croak "unsupported encoding: `$_'\n";
2268 }
2269 }
2270
2271 ### Else, is the data in a file? If so, output piecemeal...
2272 ### Miko's note: this routine pretty much works the same with a path
2273 ### or a filehandle. the only difference in behaviour is that it does
2274 ### not attempt to open anything if it already has a filehandle
2275 elsif ( defined( $self->{Path} ) || defined( $self->{FH} ) ) {
227632.76ms260µs
# spent 37µs (15+23) within MIME::Lite::BEGIN@2276 which was called: # once (15µs+23µs) by C4::Letters::BEGIN@23 at line 2276
no strict 'refs'; ### in case FH is not an object
# spent 37µs making 1 call to MIME::Lite::BEGIN@2276 # spent 23µs making 1 call to strict::unimport
2277 my $DATA;
2278
2279 ### Open file if necessary:
2280 if ( defined( $self->{Path} ) ) {
2281 $DATA = new FileHandle || Carp::croak "can't get new filehandle\n";
2282 $DATA->open("$self->{Path}")
2283 or Carp::croak "open $self->{Path}: $!\n";
2284 } else {
2285 $DATA = $self->{FH};
2286 }
2287 CORE::binmode($DATA) if $self->binmode;
2288
2289 ### Encode piece by piece:
2290 PATH:
2291 {
2292 local $_ = $encoding;
2293
2294 /^BINARY$/ and do {
2295 my $last = "";
2296 while ( read( $DATA, $_, 2048 ) ) {
2297 $out->print($last) if length $last;
2298 $last = $_;
2299 }
2300 if ( length $last ) {
2301 $is_smtp and $last =~ s/(?!\r)\n\z/\r/;
2302 $out->print($last);
2303 }
2304 last PATH;
2305 };
2306 /^8BIT$/ and do {
2307 $out->print( encode_8bit($_) ) while (<$DATA>);
2308 last PATH;
2309 };
2310 /^7BIT$/ and do {
2311 $out->print( encode_7bit($_) ) while (<$DATA>);
2312 last PATH;
2313 };
2314 /^QUOTED-PRINTABLE$/ and do {
2315 $out->print( encode_qp($_) ) while (<$DATA>);
2316 last PATH;
2317 };
2318 /^BASE64$/ and do {
2319 $out->print( encode_base64($_) ) while ( read( $DATA, $_, 45 ) );
2320 last PATH;
2321 };
2322 Carp::croak "unsupported encoding: `$_'\n";
2323 }
2324
2325 ### Close file:
2326 close $DATA if defined( $self->{Path} );
2327 }
2328
2329 else {
2330 Carp::croak "no data in this part\n";
2331 }
2332 1;
2333}
2334
2335#------------------------------
2336
2337=item print_header [OUTHANDLE]
2338
- -
2349sub print_header {
2350 my ( $self, $out ) = @_;
2351
2352 ### Coerce into a printable output handle:
2353 $out = MIME::Lite::IO_Handle->wrap($out);
2354
2355 ### Output the header:
2356 $out->print( $self->header_as_string );
2357 1;
2358}
2359
2360#------------------------------
2361
2362=item as_string
2363
- -
2370sub as_string {
2371 my $self = shift;
2372 my $buf = "";
2373 my $io = ( wrap MIME::Lite::IO_Scalar \$buf);
2374 $self->print($io);
2375 return $buf;
2376}
237711µs*stringify = \&as_string; ### backwards compatibility
23781500ns*stringify = \&as_string; ### ...twice to avoid warnings :)
2379
2380#------------------------------
2381
2382=item body_as_string
2383
- -
2395sub body_as_string {
2396 my $self = shift;
2397 my $buf = "";
2398 my $io = ( wrap MIME::Lite::IO_Scalar \$buf);
2399 $self->print_body($io);
2400 return $buf;
2401}
24021900ns*stringify_body = \&body_as_string; ### backwards compatibility
24031400ns*stringify_body = \&body_as_string; ### ...twice to avoid warnings :)
2404
2405#------------------------------
2406#
2407# fields_as_string FIELDS
2408#
2409# PRIVATE! Return a stringified version of the given header
2410# fields, where FIELDS is an arrayref like that returned by fields().
2411#
2412sub fields_as_string {
2413 my ( $self, $fields ) = @_;
2414 my $out = "";
2415 foreach (@$fields) {
2416 my ( $tag, $value ) = @$_;
2417 next if ( $value eq '' ); ### skip empties
2418 $tag =~ s/\b([a-z])/uc($1)/ge; ### make pretty
2419 $tag =~ s/^mime-/MIME-/i; ### even prettier
2420 $out .= "$tag: $value\n";
2421 }
2422 return $out;
2423}
2424
2425#------------------------------
2426
2427=item header_as_string
2428
- -
2435sub header_as_string {
2436 my $self = shift;
2437 $self->fields_as_string( $self->fields );
2438}
24391800ns*stringify_header = \&header_as_string; ### backwards compatibility
24401500ns*stringify_header = \&header_as_string; ### ...twice to avoid warnings :)
2441
2442=back
2443
- -
2447#==============================
2448#==============================
2449
2450=head2 Sending
2451
- -
2457#------------------------------
2458
2459=item send
2460
- -
2559sub send {
2560 my $self = shift;
2561 my $meth = shift;
2562
2563 if ( ref($self) ) { ### instance method:
2564 my ( $method, @args );
2565 if (@_) { ### args; use them just this once
2566 $method = 'send_by_' . $meth;
2567 @args = @_;
2568 } else { ### no args; use defaults
2569 $method = "send_by_$Sender";
2570 @args = @{ $SenderArgs{$Sender} || [] };
2571 }
2572 $self->verify_data if $AUTO_VERIFY; ### prevents missing parts!
2573 Carp::croak "Unknown send method '$meth'" unless $self->can($method);
2574 return $self->$method(@args);
2575 } else { ### class method:
2576 if (@_) {
2577 my @old = ( $Sender, @{ $SenderArgs{$Sender} } );
2578 $Sender = $meth;
2579 $SenderArgs{$Sender} = [@_]; ### remaining args
2580 return @old;
2581 } else {
2582 Carp::croak "class method send must have HOW... arguments\n";
2583 }
2584 }
2585}
2586
2587
2588#------------------------------
2589
2590=item send_by_sendmail SENDMAILCMD
2591
- -
2659sub _unfold_stupid_params {
2660 my $self = shift;
2661
2662 my %p;
2663 STUPID_PARAM: for (my $i = 0; $i < @_; $i++) { ## no critic Loop
2664 my $item = $_[$i];
2665 if (not ref $item) {
2666 $p{ $item } = $_[ ++$i ];
2667 } elsif (UNIVERSAL::isa($item, 'HASH')) {
2668 $p{ $_ } = $item->{ $_ } for keys %$item;
2669 } elsif (UNIVERSAL::isa($item, 'ARRAY')) {
2670 for (my $j = 0; $j < @$item; $j += 2) {
2671 $p{ $item->[ $j ] } = $item->[ $j + 1 ];
2672 }
2673 }
2674 }
2675
2676 return %p;
2677}
2678
2679sub send_by_sendmail {
2680 my $self = shift;
2681 my $return;
2682 if ( @_ == 1 and !ref $_[0] ) {
2683 ### Use the given command...
2684 my $sendmailcmd = shift @_;
2685 Carp::croak "No sendmail command available" unless $sendmailcmd;
2686
2687 ### Do it:
2688 local *SENDMAIL;
2689 open SENDMAIL, "|$sendmailcmd" or Carp::croak "open |$sendmailcmd: $!\n";
2690 $self->print( \*SENDMAIL );
2691 close SENDMAIL;
2692 $return = ( ( $? >> 8 ) ? undef: 1 );
2693 } else { ### Build the command...
2694 my %p = $self->_unfold_stupid_params(@_);
2695
2696 $p{Sendmail} = $SENDMAIL unless defined $p{Sendmail};
2697
2698 ### Start with the command and basic args:
2699 my @cmd = ( $p{Sendmail}, @{ $p{BaseArgs} || [ '-t', '-oi', '-oem' ] } );
2700
2701 ### See if we are forcibly setting the sender:
2702 $p{SetSender} ||= defined( $p{FromSender} );
2703
2704 ### Add the -f argument, unless we're explicitly told NOT to:
2705 if ( $p{SetSender} ) {
2706 my $from = $p{FromSender} || ( $self->get('From') )[0];
2707 if ($from) {
2708 my ($from_addr) = extract_full_addrs($from);
2709 push @cmd, "-f$from_addr" if $from_addr;
2710 }
2711 }
2712
2713 ### Open the command in a taint-safe fashion:
2714 my $pid = open SENDMAIL, "|-";
2715 defined($pid) or die "open of pipe failed: $!\n";
2716 if ( !$pid ) { ### child
2717 exec(@cmd) or die "can't exec $p{Sendmail}: $!\n";
2718 ### NOTREACHED
2719 } else { ### parent
2720 $self->print( \*SENDMAIL );
2721 close SENDMAIL || die "error closing $p{Sendmail}: $! (exit $?)\n";
2722 $return = 1;
2723 }
2724 }
2725 return $self->{last_send_successful} = $return;
2726}
2727
2728#------------------------------
2729
2730=item send_by_smtp HOST, ARGS...
2731
- -
2824# Derived from work by Andrew McRae. Version 0.2 anm 09Sep97
2825# Copyright 1997 Optimation New Zealand Ltd.
2826# May be modified/redistributed under the same terms as Perl.
2827
2828# external opts
282912µsmy @_mail_opts = qw( Size Return Bits Transaction Envelope );
28301500nsmy @_recip_opts = qw( SkipBad );
283112µsmy @_net_smtp_opts = qw( Hello LocalAddr LocalPort Timeout
2832 Port ExactAddresses Debug );
2833# internal: qw( NoAuth AuthUser AuthPass To From Host);
2834
2835sub __opts {
2836 my $args=shift;
2837 return map { exists $args->{$_} ? ( $_ => $args->{$_} ) : () } @_;
2838}
2839
2840sub send_by_smtp {
2841 require Net::SMTP;
2842 my ($self,$hostname,%args) = @_;
2843 # We may need the "From:" and "To:" headers to pass to the
2844 # SMTP mailer also.
2845 $self->{last_send_successful}=0;
2846
2847 my @hdr_to = extract_only_addrs( scalar $self->get('To') );
2848 if ($AUTO_CC) {
2849 foreach my $field (qw(Cc Bcc)) {
2850 push @hdr_to, extract_only_addrs($_) for $self->get($field);
2851 }
2852 }
2853 Carp::croak "send_by_smtp: nobody to send to for host '$hostname'?!\n"
2854 unless @hdr_to;
2855
2856 $args{To} ||= \@hdr_to;
2857 $args{From} ||= extract_only_addrs( scalar $self->get('Return-Path') );
2858 $args{From} ||= extract_only_addrs( scalar $self->get('From') ) ;
2859
2860 # Create SMTP client.
2861 # MIME::Lite::SMTP is just a wrapper giving a print method
2862 # to the SMTP object.
2863
2864 my %opts = __opts(\%args, @_net_smtp_opts);
2865 my $smtp = MIME::Lite::SMTP->new( $hostname, %opts )
2866 or Carp::croak "SMTP Failed to connect to mail server: $!\n";
2867
2868 # Possibly authenticate
2869 if ( defined $args{AuthUser} and defined $args{AuthPass}
2870 and !$args{NoAuth} )
2871 {
2872 if ($smtp->supports('AUTH',500,["Command unknown: 'AUTH'"])) {
2873 $smtp->auth( $args{AuthUser}, $args{AuthPass} )
2874 or die "SMTP auth() command failed: $!\n"
2875 . $smtp->message . "\n";
2876 } else {
2877 die "SMTP auth() command not supported on $hostname\n";
2878 }
2879 }
2880
2881 # Send the mail command
2882 %opts = __opts( \%args, @_mail_opts);
2883 $smtp->mail( $args{From}, %opts ? \%opts : () )
2884 or die "SMTP mail() command failed: $!\n"
2885 . $smtp->message . "\n";
2886
2887 # Send the recipients command
2888 %opts = __opts( \%args, @_recip_opts);
2889 $smtp->recipient( @{ $args{To} }, %opts ? \%opts : () )
2890 or die "SMTP recipient() command failed: $!\n"
2891 . $smtp->message . "\n";
2892
2893 # Send the data
2894 $smtp->data()
2895 or die "SMTP data() command failed: $!\n"
2896 . $smtp->message . "\n";
2897 $self->print_for_smtp($smtp);
2898
2899 # Finish the mail
2900 $smtp->dataend()
2901 or Carp::croak "Net::CMD (Net::SMTP) DATAEND command failed.\n"
2902 . "Last server message was:"
2903 . $smtp->message
2904 . "This probably represents a problem with newline encoding ";
2905
2906 # terminate the session
2907 $smtp->quit;
2908
2909 return $self->{last_send_successful} = 1;
2910}
2911
2912=item send_by_testfile FILENAME
2913
- -
2921sub send_by_testfile {
2922 my $self = shift;
2923
2924 ### Use the default filename...
2925 my $filename = 'mailer.testfile';
2926
2927 if ( @_ == 1 and !ref $_[0] ) {
2928 ### Use the given filename if given...
2929 $filename = shift @_;
2930 Carp::croak "no filename given to send_by_testfile" unless $filename;
2931 }
2932
2933 ### Do it:
2934 local *FILE;
2935 open FILE, ">> $filename" or Carp::croak "open $filename: $!\n";
2936 $self->print( \*FILE );
2937 close FILE;
2938 my $return = ( ( $? >> 8 ) ? undef: 1 );
2939
2940 return $self->{last_send_successful} = $return;
2941}
2942
2943=item last_send_successful
2944
- -
2952sub last_send_successful {
2953 my $self = shift;
2954 return $self->{last_send_successful};
2955}
2956
2957
2958### Provided by Andrew McRae. Version 0.2 anm 09Sep97
2959### Copyright 1997 Optimation New Zealand Ltd.
2960### May be modified/redistributed under the same terms as Perl.
2961### Aditional changes by Yves.
2962### Until 3.01_03 this was send_by_smtp()
2963sub send_by_smtp_simple {
2964 my ( $self, @args ) = @_;
2965 $self->{last_send_successful} = 0;
2966 ### We need the "From:" and "To:" headers to pass to the SMTP mailer:
2967 my $hdr = $self->fields();
2968
2969 my $from_header = $self->get('From');
2970 my ($from) = extract_only_addrs($from_header);
2971
2972 warn "M::L>>> $from_header => $from" if $MIME::Lite::DEBUG;
2973
2974
2975 my $to = $self->get('To');
2976
2977 ### Sanity check:
2978 defined($to)
2979 or Carp::croak "send_by_smtp: missing 'To:' address\n";
2980
2981 ### Get the destinations as a simple array of addresses:
2982 my @to_all = extract_only_addrs($to);
2983 if ($AUTO_CC) {
2984 foreach my $field (qw(Cc Bcc)) {
2985 my $value = $self->get($field);
2986 push @to_all, extract_only_addrs($value)
2987 if defined($value);
2988 }
2989 }
2990
2991 ### Create SMTP client:
2992 require Net::SMTP;
2993 my $smtp = MIME::Lite::SMTP->new(@args)
2994 or Carp::croak("Failed to connect to mail server: $!\n");
2995 $smtp->mail($from)
2996 or Carp::croak( "SMTP MAIL command failed: $!\n" . $smtp->message . "\n" );
2997 $smtp->to(@to_all)
2998 or Carp::croak( "SMTP RCPT command failed: $!\n" . $smtp->message . "\n" );
2999 $smtp->data()
3000 or Carp::croak( "SMTP DATA command failed: $!\n" . $smtp->message . "\n" );
3001
3002 ### MIME::Lite can print() to anything with a print() method:
3003 $self->print_for_smtp($smtp);
3004
3005 $smtp->dataend()
3006 or Carp::croak( "Net::CMD (Net::SMTP) DATAEND command failed.\n"
3007 . "Last server message was:"
3008 . $smtp->message
3009 . "This probably represents a problem with newline encoding " );
3010 $smtp->quit;
3011 $self->{last_send_successful} = 1;
3012 1;
3013}
3014
3015#------------------------------
3016#
3017# send_by_sub [\&SUBREF, [ARGS...]]
3018#
3019# I<Instance method, private.>
3020# Send the message via an anonymous subroutine.
3021#
3022sub send_by_sub {
3023 my ( $self, $subref, @args ) = @_;
3024 $self->{last_send_successful} = &$subref( $self, @args );
3025
3026}
3027
3028#------------------------------
3029
3030=item sendmail COMMAND...
3031
- -
3039sub sendmail {
3040 my $self = shift;
3041 $self->send( 'sendmail', join( ' ', @_ ) );
3042}
3043
3044=back
3045
- -
3049#==============================
3050#==============================
3051
3052=head2 Miscellaneous
3053
- -
3059#------------------------------
3060
3061=item quiet ONOFF
3062
- -
3075sub quiet {
3076 my $class = shift;
3077 $QUIET = shift if @_;
3078 $QUIET;
3079}
3080
3081=back
3082
- -
3086#============================================================
3087
3088package MIME::Lite::SMTP;
3089
3090#============================================================
3091# This class just adds a print() method to Net::SMTP.
3092# Notice that we don't use/require it until it's needed!
3093
3094334µs231µs
# spent 26µs (21+5) within MIME::Lite::SMTP::BEGIN@3094 which was called: # once (21µs+5µs) by C4::Letters::BEGIN@23 at line 3094
use strict;
# spent 26µs making 1 call to MIME::Lite::SMTP::BEGIN@3094 # spent 5µs making 1 call to strict::import
30953286µs290µs
# spent 51µs (13+39) within MIME::Lite::SMTP::BEGIN@3095 which was called: # once (13µs+39µs) by C4::Letters::BEGIN@23 at line 3095
use vars qw( @ISA );
# spent 51µs making 1 call to MIME::Lite::SMTP::BEGIN@3095 # spent 38µs making 1 call to vars::import
309619µs@ISA = qw(Net::SMTP);
3097
3098# some of the below is borrowed from Data::Dumper
309916µsmy %esc = ( "\a" => "\\a",
3100 "\b" => "\\b",
3101 "\t" => "\\t",
3102 "\n" => "\\n",
3103 "\f" => "\\f",
3104 "\r" => "\\r",
3105 "\e" => "\\e",
3106);
3107
3108sub _hexify {
3109 local $_ = shift;
3110 my @split = m/(.{1,16})/gs;
3111 foreach my $split (@split) {
3112 ( my $txt = $split ) =~ s/([\a\b\t\n\f\r\e])/$esc{$1}/sg;
3113 $split =~ s/(.)/sprintf("%02X ",ord($1))/sge;
3114 print STDERR "M::L >>> $split : $txt\n";
3115 }
3116}
3117
3118sub print {
3119 my $smtp = shift;
3120 $MIME::Lite::DEBUG and _hexify( join( "", @_ ) );
3121 $smtp->datasend(@_)
3122 or Carp::croak( "Net::CMD (Net::SMTP) DATASEND command failed.\n"
3123 . "Last server message was:"
3124 . $smtp->message
3125 . "This probably represents a problem with newline encoding " );
3126}
3127
3128
3129#============================================================
3130
3131package MIME::Lite::IO_Handle;
3132
3133#============================================================
3134
3135### Wrap a non-object filehandle inside a blessed, printable interface:
3136### Does nothing if the given $fh is already a blessed object.
3137sub wrap {
3138 my ( $class, $fh ) = @_;
31393376µs248µs
# spent 33µs (18+15) within MIME::Lite::IO_Handle::BEGIN@3139 which was called: # once (18µs+15µs) by C4::Letters::BEGIN@23 at line 3139
no strict 'refs';
# spent 33µs making 1 call to MIME::Lite::IO_Handle::BEGIN@3139 # spent 15µs making 1 call to strict::unimport
3140
3141 ### Get default, if necessary:
3142 $fh or $fh = select; ### no filehandle means selected one
3143 ref($fh) or $fh = \*$fh; ### scalar becomes a globref
3144
3145 ### Stop right away if already a printable object:
3146 return $fh if ( ref($fh) and ( ref($fh) ne 'GLOB' ) );
3147
3148 ### Get and return a printable interface:
3149 bless \$fh, $class; ### wrap it in a printable interface
3150}
3151
3152### Print:
3153sub print {
3154 my $self = shift;
3155 print {$$self} @_;
3156}
3157
3158
3159#============================================================
3160
3161package MIME::Lite::IO_Scalar;
3162
3163#============================================================
3164
3165### Wrap a scalar inside a blessed, printable interface:
3166sub wrap {
3167 my ( $class, $scalarref ) = @_;
3168 defined($scalarref) or $scalarref = \"";
3169 bless $scalarref, $class;
3170}
3171
3172### Print:
3173sub print {
3174 ${$_[0]} .= join( '', @_[1..$#_] );
3175 1;
3176}
3177
3178
3179#============================================================
3180
3181package MIME::Lite::IO_ScalarArray;
3182
3183#============================================================
3184
3185### Wrap an array inside a blessed, printable interface:
3186sub wrap {
3187 my ( $class, $arrayref ) = @_;
3188 defined($arrayref) or $arrayref = [];
3189 bless $arrayref, $class;
3190}
3191
3192### Print:
3193sub print {
3194 my $self = shift;
3195 push @$self, @_;
3196 1;
3197}
3198
3199143µs1;
3200__END__
 
# spent 23µs within MIME::Lite::CORE:fteexec which was called 4 times, avg 6µs/call: # once (16µs+0s) by C4::Letters::BEGIN@23 at line 386 # once (2µs+0s) by C4::Letters::BEGIN@23 at line 387 # once (2µs+0s) by C4::Letters::BEGIN@23 at line 397 # once (2µs+0s) by C4::Letters::BEGIN@23 at line 388
sub MIME::Lite::CORE:fteexec; # opcode
# spent 6µs within MIME::Lite::CORE:match which was called: # once (6µs+0s) by C4::Letters::BEGIN@23 at line 380
sub MIME::Lite::CORE:match; # opcode
Report produced by the NYTProf 4.04 Perl profiler, developed by Tim Bunce and Adam Kaplan.