view release on metacpan or  search on metacpan

lib/readmail.pl  view on Meta::CPAN

                while (($pos = index($$body, $boundary, $start_pos)) > -1) {
                    # have to check for case when boundary is a substring
                    #	of another boundary, yuck!
                    $bchkstr = substr($$body, $pos + $blen, 2);
                    unless ($bchkstr =~ /\A\r?\n/ || $bchkstr =~ /\A--/) {
                        # incomplete match, continue search
                        $start_pos = $pos + $blen;
                        next;
                    }
                    $found = 1;
                    push(@parts, substr($$body, 0, $pos));
                    $parts[$#parts] =~ s/^\r//;

                    # prune out part data just grabbed
                    substr($$body, 0, $pos + $blen) = "";

                    # check if hit end
                    if ($$body =~ /\A--/) {
                        $have_end = 1;
                        last;
                    }

                    # remove EOL at the beginning
                    $$body =~ s/\A\r?\n//;
                    $start_pos = 0;
                }
                if ($found) {
                    if (!$have_end) {
                        warn qq/Warning: No end boundary delimiter found in /,
                            qq/message body\n/;
                        push(@parts, $$body);
                        $parts[$#parts] =~ s/^\r//;
                        $$body = "";
                    } else {
                        # discard front-matter
                        shift(@parts);
                    }
                } else {
                    # no boundary separators in message!
                    warn qq/Warning: No boundary delimiters found in /,
                        qq/multipart body\n/;
                    if ($$body =~ m/\A\n[\w\-]+:\s/) {
                        # remove \n added above if part looks like it has
                        # headers.  we keep if it does not to avoid body
                        # data being parsed as a header below.
                        substr($$body, 0, 1) = "";
                    }
                    push(@parts, $$body);
                }

                ## Else treat body as one part
            } else {
                @parts = ($$body);
            }

            ## Process parts
            my (@entity) = ();
            my ($cid, $href, $pctype);
            my %alt_exc        = ();
            my $have_alt_prefs = $isalt && scalar(@_MIMEAltPrefs);
            my $partno         = 0;
            @parts = \(@parts);
            while (defined($part = shift(@parts))) {
                $href = {};
                $partfields = $href->{'fields'} = (MAILread_header($part))[0];
                $href->{'body'}                    = $part;
                $href->{'filtered'}                = 0;
                $partfields->{'x-mha-part-number'} = ++$partno;
                $pctype =
                    extract_ctype($partfields->{'content-type'}, $ctype);

                ## check alternative preferences
                if ($have_alt_prefs) {
                    next if ($alt_exc{$pctype});
                    my $pos = $_MIMEAltPrefs{$pctype};
                    if (defined($pos)) {
                        for (++$pos; $pos <= $#_MIMEAltPrefs; ++$pos) {
                            $alt_exc{$_MIMEAltPrefs[$pos]} = 1;
                        }
                    }
                }

                ## only add to %Cid if not excluded
                if (!&MAILis_excluded($pctype)) {
                    if ($isalt) {
                        unshift(@entity, $href);
                    } else {
                        push(@entity, $href);
                    }
                    $cid = $partfields->{'content-id'}[0]
                        || $partfields->{'message-id'}[0];
                    if (defined($cid)) {
                        $cid =~ s/[\s<>]//g;
                        $Cid{"cid:$cid"} = $href if $cid =~ /\S/;
                    }
                    $cid = undef;
                    if (defined($partfields->{'content-location'})
                        && ($cid = $partfields->{'content-location'}[0])) {
                        my $partbase = $uribase;
                        $cid =~ s/['"\s]//g;
                        if (defined($partfields->{'content-base'})) {
                            $partbase = $partfields->{'content-base'}[0];
                        }
                        $cid = apply_base_url($partbase, $cid);
                        if ($cid =~ /\S/ && !$Cid{$cid}) {
                            $Cid{$cid} = $href;
                        }
                    }
                    if ($cid) {
                        $partfields->{'content-location'} = [$cid];
                    } elsif (!defined($partfields->{'content-base'})) {
                        $partfields->{'content-base'} = [$uribase];
                    }

                    $partfields->{'x-mha-parent-header'} = $fields;
                }
            }

            my ($entity);
        ENTITY: foreach $entity (@entity) {
                if ($entity->{'filtered'}) {
                    next ENTITY;
                }

                ## If content-type not defined for part, then determine
                ## content-type based upon multipart subtype.
                $partfields = $entity->{'fields'};
                if (!defined($partfields->{'content-type'})) {
                    $partfields->{'content-type'} = [
                        ($subtype =~ /digest/)
                        ? 'message/rfc822'
                        : 'text/plain'
                    ];

lib/readmail.pl  view on Meta::CPAN

    my $str     = shift;    # Input string
    my $hasmain = shift;    # Flag if there is a main value to extract

    require MHonArc::RFC822;

    my $parm = {};
    my @toks = MHonArc::RFC822::uncomment($str);
    my ($tok, $name, $value, $charset, $lang, $isPart);

    $parm->{'x-main'} = shift @toks if $hasmain;

    ## Loop thru token list
    while ($tok = shift @toks) {
        next if $tok eq ";";
        ($name, $value) = split(/=/, $tok, 2);
        ## Check if charset/lang specified
        if ($name =~ s/\*$//) {
            if ($value =~ s/^([^']*)'([^']*)'//) {
                ($charset, $lang) = ($1, $2);
            } else {
                ($charset, $lang) = (undef, undef);
            }
        }
        ## Check if parameter is only part
        if ($name =~ s/\*(\d+)$//) {
            $isPart = 1;
        } else {
            $isPart = 0;
        }
        ## Set values for parameter
        $name = lc $name;
        $parm->{$name} = {} unless defined($parm->{$name});
        $parm->{$name}{'charset'} = $charset;
        $parm->{$name}{'lang'}    = $lang;
        ## Check if value is next token
        if ($value eq "") {
            ## If value next token, than it must be quoted
            $value = shift @toks;
            $value =~ s/^"//;
            $value =~ s/"$//;
            $value =~ s/\\//g;
        }
        if ($isPart && defined($parm->{$name}{'vlist'})) {
            push(@{$parm->{$name}{'vlist'}}, $value);
        } else {
            $parm->{$name}{'vlist'} = [$value];
        }
    }

    ## Now we loop thru each parameter and define the final values from
    ## the parts
    foreach $name (keys %$parm) {
        next if $name eq 'x-main';
        $parm->{$name}{'value'} = join("", @{$parm->{$name}{'vlist'}});
    }

    $parm;
}

##---------------------------------------------------------------------------##
##	MAILset_alternative_prefs() is used to set content-type
##	preferences for multipart/alternative entities.  The list
##	specified will supercede the prefered format as denoted by
##	the ording of parts in the entity.
##
##	A content-type listed earlier in the array will be prefered
##	over one later.  For example:
##
##	  MAILset_alternative_prefs('text/plain', 'text/html');
##
##	States that if a multipart/alternative entity contains a
##	text/plain part and a text/html part, the text/plain part will
##	be prefered over the text/html part.
##
sub MAILset_alternative_prefs {
    @_MIMEAltPrefs = map {lc} @_;
    %_MIMEAltPrefs = ();
    my $i = 0;
    my $ctype;
    foreach $ctype (@_MIMEAltPrefs) {
        $_MIMEAltPrefs{$ctype} = $i++;
    }
}

##---------------------------------------------------------------------------##
##	MAILset_charset_aliases() is used to define name aliases for
##	charset names.
##
##	Example usage:
##	  MAILset_charset_aliases( {
##	    'iso-8859-1' =>  [ 'latin1', 'iso_8859_1', '8859-1' ],
##	    'iso-8859-15' => [ 'latin9', 'iso_8859_15', '8859-15' ],
##	  }, $override );
##
sub MAILset_charset_aliases {
    my $map      = shift;
    my $override = shift;

    %MIMECharsetAliases = () if $override;
    my ($charset, $aliases, $alias);
    while (($charset, $aliases) = each(%$map)) {
        $charset = lc $charset;
        foreach $alias (@$aliases) {
            $MIMECharsetAliases{lc $alias} = $charset;
        }
    }
}

##---------------------------------------------------------------------------##
##	MAILload_charset_converter() loads the charset converter function
##	associated with given charset name.
##
##	Example usage:
##	  ($func, $real_charset) = MAILload_charset_converter($charset);
##
##	$func is the reference to the converter function, which may be
##	undef.  $real_charset is the real charset name that should be
##	used when invoking the function.
##
sub MAILload_charset_converter {
    my $charset = lc shift;
    $charset = $MIMECharsetAliases{$charset} if $MIMECharsetAliases{$charset};
    my $func = load_charset($charset);
    if (!defined($func) || !defined(&$func)) {
        $func = load_charset('default');
    }
    ($func, $charset);
}

###############################################################################
##	Private Routines
###############################################################################

##---------------------------------------------------------------------------##
##	Default function for unable to process a part of a multipart