diff -Naur MIME-Lite-3.01_04.orig/changes.pod MIME-Lite-3.01_04/changes.pod --- MIME-Lite-3.01_04.orig/changes.pod 2004-05-05 18:13:34.000000000 -0400 +++ MIME-Lite-3.01_04/changes.pod 2005-12-03 15:49:16.007409680 -0500 @@ -2,6 +2,12 @@ =over 4 +=item Version 3.01_05 + +Optimized code for a 50% speedup on creation of two-part messages. +The internal structure of the object has changes, but that won't +matter if you were using the published interface. (Sam Tregar) + =item Version 3.01_04 (2004/05/05) Reworked the new send_by_smtp stuff. Documentation modifications. diff -Naur MIME-Lite-3.01_04.orig/lib/MIME/Lite.pm MIME-Lite-3.01_04/lib/MIME/Lite.pm --- MIME-Lite-3.01_04.orig/lib/MIME/Lite.pm 2004-05-07 13:43:11.000000000 -0400 +++ MIME-Lite-3.01_04/lib/MIME/Lite.pm 2005-12-03 15:53:50.991605728 -0500 @@ -344,7 +344,7 @@ #============================== # # GLOBALS, EXTERNAL/CONFIGURATION... -$VERSION = "3.01_04"; +$VERSION = "3.01_05"; $VERSION = eval $VERSION; ### Automatically interpret CC/BCC for SMTP: @@ -458,17 +458,6 @@ #------------------------------ # -# known_field FIELDNAME -# -# Is this a recognized Mail/MIME field? - -sub known_field { - my $field = lc(shift); - $KnownField{$field} or ( $field =~ m{^(content|resent|x)-.} ); -} - -#------------------------------ -# # is_mime_field FIELDNAME # # Is this a field I manage? @@ -670,9 +659,10 @@ my $class = shift; ### Create basic object: - my $self = { Attrs => {}, ### MIME attributes - Header => [], ### explicit message headers - Parts => [], ### array of parts + my $self = { Attrs => {}, ### MIME attributes + SubAttrs => {}, ### MIME sub-attributes + Header => [], ### explicit message headers + Parts => [], ### array of parts }; bless $self, $class; @@ -730,28 +720,31 @@ sub attach { my $self = shift; + my $attrs = $self->{Attrs}; + my $sub_attrs = $self->{SubAttrs}; ### Create new part, if necessary: my $part1 = ( ( @_ == 1 ) ? shift: ref($self)->new( Top => 0, @_ ) ); ### Do the "attach-to-singlepart" hack: - if ( $self->attr('content-type') !~ m{^(multipart|message)/}i ) { + if ( $attrs->{'content-type'} !~ m{^(multipart|message)/}i ) { ### Create part zero: my $part0 = ref($self)->new; ### Cut MIME stuff from self, and paste into part zero: - foreach (qw(Attrs Data Path FH)) { + foreach (qw(SubAttrs Attrs Data Path FH)) { $part0->{$_} = $self->{$_}; delete( $self->{$_} ); } $part0->top_level(0); ### clear top-level attributes ### Make self a top-level multipart: - $self->{Attrs} ||= {}; ### reset - $self->attr( 'content-type' => 'multipart/mixed' ); - $self->attr( 'content-type.boundary' => gen_boundary() ); - $self->attr( 'content-transfer-encoding' => '7bit' ); + $attrs = $self->{Attrs} ||= {}; ### reset (sam: bug? this doesn't reset anything since Attrs is already a hash-ref) + $sub_attrs = $self->{SubAttrs} ||= {}; ### reset + $attrs->{'content-type'} = 'multipart/mixed'; + $sub_attrs->{'content-type'}{'boundary'} = gen_boundary(); + $attrs->{'content-transfer-encoding'} = '7bit'; $self->top_level(1); ### activate top-level attributes ### Add part 0: @@ -990,7 +983,9 @@ ### We now have a content-type; set it: $type = lc($type); - $self->attr( 'content-type' => $type ); + my $attrs = $self->{Attrs}; + my $sub_attrs = $self->{SubAttrs}; + $attrs->{'content-type'} = $type; ### Get some basic attributes from the content type: my $is_multipart = ( $type =~ m{^(multipart)/}i ); @@ -998,7 +993,7 @@ ### Add in the multipart boundary: if ($is_multipart) { my $boundary = gen_boundary(); - $self->attr( 'content-type.boundary' => $boundary ); + $sub_attrs->{'content-type'}{'boundary'} = $boundary; } @@ -1007,7 +1002,7 @@ if ( defined $params{Id} ) { my $id = $params{Id}; $id = "<$id>" unless $id =~ /\A\s*<.*>\s*\z/; - $self->attr( 'content-id' => $id ); + $attrs->{'content-id'} = $id; } @@ -1047,7 +1042,7 @@ ### Get it: my $enc = ( $params{Encoding} || ( $AUTO_ENCODE and $self->suggest_encoding($type) ) || 'binary' ); - $self->attr( 'content-transfer-encoding' => lc($enc) ); + $attrs->{'content-transfer-encoding'} = lc($enc); ### Sanity check: if ( $type =~ m{^(multipart|message)/} ) { @@ -1059,13 +1054,13 @@ ### Default is inline for single, none for multis: ### my $disp = ( $params{Disposition} or ( $is_multipart ? undef: 'inline' ) ); - $self->attr( 'content-disposition' => $disp ); + $attrs->{'content-disposition'} = $disp; ### CONTENT-LENGTH... ### my $length; if ( exists( $params{Length} ) ) { ### given by caller: - $self->attr( 'content-length' => $params{Length} ); + $attrs->{'content-length'} = $params{Length}; } else { ### compute it ourselves $self->get_length; } @@ -1098,14 +1093,16 @@ my $field; while (@paramz) { my ( $tag, $value ) = ( shift(@paramz), shift(@paramz) ); + my $lc_tag = lc($tag); ### Get tag, if a tag: - if ( $tag =~ /^-(.*)/ ) { ### old style, backwards-compatibility - $field = lc($1); - } elsif ( $tag =~ /^(.*):$/ ) { ### new style - $field = lc($1); - } elsif ( known_field( $field = lc($tag) ) ) { ### known field - ### no-op + if ( $lc_tag =~ /^-(.*)/ ) { ### old style, backwards-compatibility + $field = $1; + } elsif ( $lc_tag =~ /^(.*):$/ ) { ### new style + $field = $1; + } elsif ( $KnownField{$lc_tag} or + $lc_tag =~ m{^(content|resent|x)-.} ){ + $field = $lc_tag; } else { ### not a field: next; } @@ -1142,13 +1139,14 @@ sub top_level { my ( $self, $onoff ) = @_; + my $attrs = $self->{Attrs}; if ($onoff) { - $self->attr( 'MIME-Version' => '1.0' ); + $attrs->{'MIME-Version'} = '1.0'; my $uses = ( @Uses ? ( "(" . join( "; ", @Uses ) . ")" ) : '' ); $self->replace( 'X-Mailer' => "MIME::Lite $VERSION $uses" ) unless $VANILLA; } else { - $self->attr( 'MIME-Version' => undef ); + delete $attrs->{'MIME-Version'}; $self->delete('X-Mailer'); } } @@ -1245,30 +1243,33 @@ sub attr { my ( $self, $attr, $value ) = @_; + my $attrs = $self->{Attrs}; + $attr = lc($attr); ### Break attribute name up: my ( $tag, $subtag ) = split /\./, $attr; - defined($subtag) or $subtag = ''; + if (defined($subtag)) { + $attrs = $self->{SubAttrs}{$tag} ||= {}; + $tag = $subtag; + } ### Set or get? if ( @_ > 2 ) { ### set: - $self->{Attrs}{$tag} ||= {}; ### force hash - delete $self->{Attrs}{$tag}{$subtag}; ### delete first - if ( defined($value) ) { ### set... - $value =~ s/[\r\n]//g; ### make clean - $self->{Attrs}{$tag}{$subtag} = $value; + if ( defined($value) ) { + $attrs->{$tag} = $value; + } else { + delete $attrs->{$tag}; } } ### Return current value: - $self->{Attrs}{$tag}{$subtag}; + $attrs->{$tag}; } sub _safe_attr { my ( $self, $attr ) = @_; - my $v = $self->attr($attr); - defined($v) ? $v : ''; + return defined $self->{Attrs}{$attr} ? $self->{Attrs}{$attr} : ''; } #------------------------------ @@ -1360,6 +1361,8 @@ sub fields { my $self = shift; my @fields; + my $attrs = $self->{Attrs}; + my $sub_attrs = $self->{SubAttrs}; ### Get a lookup-hash of all *explicitly-given* fields: my %explicit = map { $_->[0] => 1 } @{ $self->{Header} }; @@ -1371,18 +1374,20 @@ ### Skip if explicit: next if ( $explicit{$tag} ); - ### Skip if no subtags: - my @subtags = keys %{ $self->{Attrs}{$tag} }; - @subtags or next; - - ### Create string: - my $value; - defined( $value = $self->{Attrs}{$tag}{''} ) or next; ### need default - foreach ( sort @subtags ) { - next if ( $_ eq '' ); - $value .= qq{; $_="$self->{Attrs}{$tag}{$_}"}; + # get base attr value or skip if not available + my $value = $attrs->{$tag}; + defined $value or next; + + ### handle sub-attrs if available + if (my $subs = $sub_attrs->{$tag}) { + $value .= '; ' . + join('; ', map { qq{$_="$subs->{$_}"} } sort keys %$subs); } + # handle stripping \r\n now since we're not doing it in attr() + # anymore + $value =~ tr/\r\n//; + ### Add to running fields; push @fields, [ $tag, $value ]; } @@ -1441,11 +1446,13 @@ sub filename { my ( $self, $filename ) = @_; + my $sub_attrs = $self->{SubAttrs}; + if ( @_ > 1 ) { - $self->attr( 'content-type.name' => $filename ); - $self->attr( 'content-disposition.filename' => $filename ); + $sub_attrs->{'content-type'}{'name'} = $filename; + $sub_attrs->{'content-disposition'}{'filename'} = $filename; } - $self->attr('content-disposition.filename'); + return $sub_attrs->{'content-disposition'}{'filename'}; } #------------------------------ @@ -1518,9 +1525,10 @@ sub get_length { my $self = shift; + my $attrs = $self->{Attrs}; - my $is_multipart = ( $self->attr('content-type') =~ m{^multipart/}i ); - my $enc = lc( $self->attr('content-transfer-encoding') || 'binary' ); + my $is_multipart = ( $attrs->{'content-type'} =~ m{^multipart/}i ); + my $enc = lc( $attrs->{'content-transfer-encoding'} || 'binary' ); my $length; if ( !$is_multipart && ( $enc eq "binary" ) ) { ### might figure it out cheap: if ( defined( $self->{Data} ) ) { ### it's in core @@ -1531,7 +1539,7 @@ $length = ( -s $self->{Path} ) if ( -e $self->{Path} ); } } - $self->attr( 'content-length' => $length ); + $attrs->{'content-length'} = $length; return $length; } @@ -1726,7 +1734,7 @@ $self->{Binmode} = shift if (@_); ### argument? set override return ( defined( $self->{Binmode} ) ? $self->{Binmode} - : ( $self->attr("content-type") !~ m{^(text|message)/}i ) + : ( $self->{Attrs}{"content-type"} !~ m{^(text|message)/}i ) ); } @@ -2138,6 +2146,8 @@ sub print_body { my ( $self, $out, $is_smtp ) = @_; + my $attrs = $self->{Attrs}; + my $sub_attrs = $self->{SubAttrs}; ### Coerce into a printable output handle: $out = MIME::Lite::IO_Handle->wrap($out); @@ -2145,9 +2155,9 @@ ### Output either the body or the parts. ### Notice that we key off of the content-type! We expect fewer ### accidents that way, since the syntax will always match the MIME type. - my $type = $self->attr('content-type'); + my $type = $attrs->{'content-type'}; if ( $type =~ m{^multipart/}i ) { - my $boundary = $self->attr('content-type.boundary'); + my $boundary = $sub_attrs->{'content-type'}{'boundary'}; ### Preamble: $out->print( defined( $self->{Preamble} ) @@ -2199,12 +2209,13 @@ # sub print_simple_body { my ( $self, $out, $is_smtp ) = @_; - + my $attrs = $self->{Attrs}; + ### Coerce into a printable output handle: $out = MIME::Lite::IO_Handle->wrap($out); ### Get content-transfer-encoding: - my $encoding = uc( $self->attr('content-transfer-encoding') ); + my $encoding = uc( $attrs->{'content-transfer-encoding'} ); warn "M::L >>> Encoding using $encoding, is_smtp=" . ( $is_smtp || 0 ) . "\n" if $MIME::Lite::DEBUG; @@ -2350,10 +2361,10 @@ sub as_string { my $self = shift; - my $buf = []; - my $io = ( wrap MIME::Lite::IO_ScalarArray $buf); + my $buf = ""; + my $io = ( wrap MIME::Lite::IO_Scalar \$buf); $self->print($io); - join '', @$buf; + return $buf; } *stringify = \&as_string; ### backwards compatibility *stringify = \&as_string; ### ...twice to avoid warnings :) @@ -2375,10 +2386,10 @@ sub body_as_string { my $self = shift; - my $buf = []; - my $io = ( wrap MIME::Lite::IO_ScalarArray $buf); + my $buf = ""; + my $io = ( wrap MIME::Lite::IO_Scalar \$buf); $self->print_body($io); - join '', @$buf; + return $buf; } *stringify_body = \&body_as_string; ### backwards compatibility *stringify_body = \&body_as_string; ### ...twice to avoid warnings :) @@ -2392,15 +2403,15 @@ # sub fields_as_string { my ( $self, $fields ) = @_; - my @lines; + my $out = ""; foreach (@$fields) { my ( $tag, $value ) = @$_; - next if ( $value eq '' ); ### skip empties + next if ( $value eq '' ); ### skip empties $tag =~ s/\b([a-z])/uc($1)/ge; ### make pretty - $tag =~ s/^mime-/MIME-/ig; ### even prettier - push @lines, "$tag: $value\n"; + $tag =~ s/^mime-/MIME-/i; ### even prettier + $out .= "$tag: $value\n"; } - join '', @lines; + return $out; } #------------------------------ @@ -3168,8 +3179,7 @@ ### Print: sub print { - my $self = shift; - $$self .= join( '', @_ ); + ${$_[0]} .= join( '', @_[1..$#_] ); 1; } diff -Naur MIME-Lite-3.01_04.orig/t/data.t MIME-Lite-3.01_04/t/data.t --- MIME-Lite-3.01_04.orig/t/data.t 2003-08-27 07:04:04.000000000 -0400 +++ MIME-Lite-3.01_04/t/data.t 2005-12-03 13:14:12.690728792 -0500 @@ -42,7 +42,7 @@ $me = MIME::Lite->build(Type => 'text/plain', Path => "./testin/hello"); $str = $me->as_string; -$T->ok(($str =~ m{Hello\nWorld\n}), +$T->ok(($str =~ m{Hello\r?\nWorld\r?\n}), $from, "Data file"); diff -Naur MIME-Lite-3.01_04.orig/t/head.t MIME-Lite-3.01_04/t/head.t --- MIME-Lite-3.01_04.orig/t/head.t 2003-08-27 07:16:40.000000000 -0400 +++ MIME-Lite-3.01_04/t/head.t 2005-12-03 14:53:54.931289992 -0500 @@ -74,6 +74,7 @@ "attr: replace of charset worked"); # my ($ct) = map {($_->[0] eq 'content-type') ? $_->[1] : ()} @{$me->fields}; + $T->ok_eq($ct, 'text/plain; charset="US-ASCII"', "attr: replace of charset worked on whole line"); diff -Naur MIME-Lite-3.01_04.orig/t/types.t MIME-Lite-3.01_04/t/types.t --- MIME-Lite-3.01_04.orig/t/types.t 2003-08-27 07:16:40.000000000 -0400 +++ MIME-Lite-3.01_04/t/types.t 2005-12-03 15:51:03.167118928 -0500 @@ -26,6 +26,15 @@ Data =>"How's it goin', eh?" ); + # this test requires output in a particular order, so specify it + $msg->field_order(qw(Content-Transfer-Encoding + Content-Type + MIME-Version + From + To + Cc + Subject)); + $msg->attach( Type => 'AUTO', Path => "./testin/test.html",