Help language development. Donate to The Perl Foundation
use Email::Simple; use Email::MIME::AttributeHeaderParsing; use Email::MIME::Header; use Email::MIME::Exceptions; use MIME::QuotedPrint; use Email::MIME::Encoder::Base64; use Email::MIME::Encoder::Base64Native; unit class Email::MIME is Email::Simple; has $!ct; has @!parts; has $!body-raw; method new (Str $text){ my $self = callwith($text, header-class => Email::MIME::Header); $self._finish_new(); return $self; } method _finish_new(){ $!ct = Email::MIME::AttributeHeaderParsing::parse-content-type(self.content-type); self.fill-parts; } method create(:$header is copy, :$header-str is copy, :$attributes is copy, :$parts is copy, :$body, :$body-str, :$body-raw) { my $self = callwith(header => Array.new(), body => '', header-class => Email::MIME::Header); $self.header-set('Content-Type', 'text/plain'); $self.header-set('MIME-Version', '1.0'); if $header { for $header.list -> $item { if $item ~~ Pair { $self.header-set($item.key, $item.value); } else { $self.header-set($item[0], $item[1]); } } } if $header-str { for $header-str.list -> $item { if $item ~~ Pair { $self.header-str-set($item.key, $item.value); } else { $self.header-str-set($item[0], $item[1]); } } } # TODO: this is messy if $attributes { for $attributes.list -> $item { my $key; my $value; if $item ~~ Pair { $key = $item.key; $value = $item.value; } else { $key = $item[0]; $value = $item[1]; } if lc($key) eq 'content-type' { $self.content-type-set($value); } if lc($key) eq 'charset' { $self.charset-set($value); } if lc($key) eq 'name' { $self.name-set($value); } if lc($key) eq 'format' { $self.format-set($value); } if lc($key) eq 'boundary' { $self.boundary-set($value); } if lc($key) eq 'encoding' { $self.encoding-set($value); } if lc($key) eq 'disposition' { $self.disposition-set($value); } if lc($key) eq 'filename' { $self.filename-set($value); } } } ## if $parts { for $parts.list -> $part is rw { unless $part ~~ Email::MIME { $part = Email::MIME.create(attributes => {content-type => 'text/plain'}, body => $part); } } $self.parts-set($parts.list); } elsif $body { $self.body-set($body); } elsif $body-str { $self.body-str-set($body-str); } elsif $body-raw { $self.body-raw-set($body-raw); } return $self; } method body-raw { return $!body-raw // self.body(True); } method body-raw-set($body) { $!body-raw = $body; self.body-set($body, True); } method parts { if [email protected]!parts { return @!parts; } else { return self; } } method debug-structure($level = 0) { my $rv = ' ' x (5 * $level); $rv ~= '+ ' ~ self.content-type ~ "\n"; if self.parts ~~ Array && +self.parts > 1 { for self.parts -> $part { $rv ~= $part.debug-structure($level + 1); } } return $rv; } method filename($force = False) { my $dis = self.header('Content-Disposition') // ''; my $dis-parsed = Email::MIME::AttributeHeaderParsing::parse-content-disposition($dis); my $name = $dis-parsed<attributes><filename> || $!ct<attributes><name>; if $name || !$force { return $name; } my $invented = self.invent-filename($!ct<type> ~ '/' ~ $!ct<subtype>); self.filename-set($invented); return $invented; } my $gname = 0; method invent-filename($ct?) { # TODO use content type to find a more correct extension return 'attachment-' ~ $*PID ~ '-' ~ $gname++ ~ '.dat'; } method filename-set($filename) { # parse existing header my $dis = self.header('Content-Disposition'); my $disposition; my %params; if $dis { my $dis-parsed = Email::MIME::AttributeHeaderParsing::parse-content-disposition($dis); $disposition = $dis-parsed<type>; %params = $dis-parsed<attributes>; } else { $disposition = 'inline'; %params = Hash.new; } # update filename if $filename { %params<filename> = $filename; } else { %params<filename>:delete; } # rewrite header $dis = Email::MIME::AttributeHeaderParsing::compose-content-disposition($disposition, %params); self.header-set('Content-Disposition', $dis); } method subparts { return @!parts; } method fill-parts { if $!ct<type> eq "multipart" || $!ct<type> eq "message" { self.parts-multipart; } else { self.parts-single-part; } return self; } method parts-single-part { @!parts = (); } method parts-multipart { my $boundary = $!ct<attributes><boundary>; $!body-raw //= self.body(True); my @bits = split(/\-\-$boundary/, self.body-raw); my $x = 0; for @bits { if $x { unless $_ ~~ /^\-\-/ { $_ ~~ s/^\n//; $_ ~~ s/\n$//; @!parts.push(self.new($_)); } } else { $x++; self.body-set($_, True); } } return @!parts; } method parts-set(@parts) { my $body = ''; my $ct = Email::MIME::AttributeHeaderParsing::parse-content-type(self.content-type); if [email protected] > 1 || $!ct<type> eq 'multipart' { $ct<attributes><boundary> //= self!create-boundary; my $boundary = $ct<attributes><boundary>; for @parts -> $part { $body ~= self.crlf ~ "--" ~ $boundary ~ self.crlf; $body ~= ~$part; } $body ~= self.crlf ~ "--" ~ $boundary ~ "--" ~ self.crlf; unless $ct<type> eq 'multipart' || $ct<type> eq 'message' { $ct<type> = 'multipart'; $ct<subtype> = 'mixed'; } } elsif [email protected] == 1 { my $part = @parts[0]; $body = $part.body; my $thispart_ct = Email::MIME::AttributeHeaderParsing::parse-content-type($part.content-type); $ct<type> = $thispart_ct<type>; $ct<subtype> = $thispart_ct<subtype>; self.encoding-set($part.header('Content-Transfer-Encoding')); $ct<attributes><boundary>:delete; } self!compose-content-type($ct); self.body-raw-set($body); self.fill-parts; self!reset-cids; } method parts-add(@parts) { my @allparts = self.parts, @parts; self.parts-set(@allparts); } method walk-parts($callback) { $callback(self); for self.subparts { $_.walk-parts($callback); } return self; } method boundary-set($data) { my $ct-hash = Email::MIME::AttributeHeaderParsing::parse-content-type(self.content-type); if $data { $ct-hash<attributes><boundary> = $data; } else { $ct-hash<attributes><boundary>:delete; } self!compose-content-type($ct-hash); if +self.parts > 1 { self.parts-set(self.parts) } } method content-type(){ return ~$_ with self.header("Content-type"); return ''; } method content-type-set($ct) { my $ct-hash = Email::MIME::AttributeHeaderParsing::parse-content-type($ct); $ct-hash<attributes> = $!ct<attributes> if $!ct && $!ct<attributes> && !$ct-hash<attributes>; self!compose-content-type($ct-hash); self!reset-cids; return $ct; } # TODO: make the next three methods into a macro call method charset-set($data) { my $ct-hash = Email::MIME::AttributeHeaderParsing::parse-content-type(self.content-type); if $data { $ct-hash<attributes><charset> = $data; } else { $ct-hash<attributes><charset>:delete; } self!compose-content-type($ct-hash); return $data; } method name-set($data) { my $ct-hash = Email::MIME::AttributeHeaderParsing::parse-content-type(self.content-type); if $data { $ct-hash<attributes><name> = $data; } else { $ct-hash<attributes><name>:delete; } self!compose-content-type($ct-hash); return $data; } method format-set($data) { my $ct-hash = Email::MIME::AttributeHeaderParsing::parse-content-type(self.content-type); if $data { $ct-hash<attributes><format> = $data; } else { $ct-hash<attributes><format>:delete; } self!compose-content-type($ct-hash); return $data; } method disposition-set($data) { $data //= 'inline'; my $current = self.header('Content-Disposition'); if $current { $current ~~ s/^<-[;]>+/$data/; } else { $current = $data; } self.header-set('Content-Disposition', $current); } method as-string { return self.header-obj.as-string ~ self.crlf ~ self.body-raw; } method !compose-content-type($ct-hash) { self.header-set: 'Content-Type', Email::MIME::AttributeHeaderParsing::compose-content-type( $ct-hash<type>, $ct-hash<subtype>, $ct-hash<attributes>); $!ct = $ct-hash; } method !get-cid { return '<' ~ self!create-cid ~ '>'; } method !reset-cids { my $ct-hash = Email::MIME::AttributeHeaderParsing::parse-content-type(self.content-type); if self.parts ~~ Array && +self.parts > 1 { if $ct-hash<subtype> eq 'alternative' { my $cids; for self.parts -> $part { my $cid = $part.header('Content-ID') // ''; $cids{$cid}++; } if +$cids.keys == 1 { return; } my $cid = self!get-cid; for self.parts -> $part { $part.header-set('Content-ID', $cid); } } else { for self.parts -> $part { my $cid = self!get-cid; unless $part.header('Content-ID') { $part.header-set('Content-ID', $cid); } } } } } ### # content transfer encoding stuff here ### my %cte-coders = ('quoted-printable' => MIME::QuotedPrint); if (try require Base64::Native) !=== Nil { %cte-coders<base64> = Email::MIME::Encoder::Base64Native.new; } else { %cte-coders<base64> = Email::MIME::Encoder::Base64.new; } method set-encoding-handler($cte, $coder) { %cte-coders{$cte} = $coder; Email::MIME::Header.set-encoding-handler($cte, $coder); } method body($callsame_only?) { my $body = callwith(); if $callsame_only { return $body; } my $cte = ~(self.header('Content-Transfer-Encoding') // ''); $cte ~~ s/\;.*$//; $cte ~~ s:g/\s//; if $cte && %cte-coders{$cte}.can('decode') { return %cte-coders{$cte}.decode($body); } else { return $body.encode('ascii'); } } method body-set($body, $super?) { if $super { nextwith($body); } my $cte = ~(self.header('Content-Transfer-Encoding') // ''); $cte ~~ s/\;.*$//; $cte ~~ s:g/\s//; my $body-encoded; if $cte && %cte-coders{$cte}.can('encode') { $body-encoded = %cte-coders{$cte}.encode($body); } else { if $body ~~ Str { # ensure everything is ascii like it should be $body-encoded = $body.encode('ascii').decode('ascii'); } else { $body-encoded = $body.decode('ascii'); } } $!body-raw = $body-encoded; callwith($body-encoded); } method encoding-set($enc) { my $body = self.body; self.header-set('Content-Transfer-Encoding', $enc); self.body-set($body); } ### # charset stuff here ### method body-str { my $body = self.body; if $body ~~ Str { # if body is a Str, we assume it's already been decoded return $body; } if $body ~~ Blob { my $charset = $!ct<attributes><charset>; if $charset ~~ m:i/^us\-ascii$/ { $charset = 'ascii'; } unless $charset { if $!ct<type> eq 'text' && ($!ct<subtype> eq 'plain' || $!ct<subtype> eq 'html') { return $body.decode('ascii'); } # I have a Buf with no charset. Can't really do anything... die X::Email::MIME::CharsetNeeded.new(); } return $body.decode($charset); } die X::Email::MIME::InvalidBody.new(); } method body-str-set(Str $body) { my $charset = $!ct<attributes><charset>; unless $charset { # well, we can't really do anything with this die X::Email::MIME::CharsetNeeded.new(); } if $charset ~~ m:i/^us\-ascii$/ { $charset = 'ascii'; } self.body-set($body.encode($charset)); } method header-str-pairs { self.header-obj.header-str-pairs; } method header-str($header, :$multi) { self.header-obj.header-str($header, :$multi); } method header-str-set($header, *@lines) { self.header-obj.header-str-set($header, |@lines); } ### # methods to replace Email::MessageID # TODO pull these into a new Email::MessageID module ### my @chars = ('A'..'F','a'..'f',0..9).flat; method !create-boundary { return now.Num ~ '.' ~ (@chars.roll((4..8).pick)).join ~ '.' ~ $*PID; } method !create-cid { return self!create-boundary ~ '@' ~ $*KERNEL.hostname(); }