view release on metacpan or  search on metacpan

lib/Razor2/String.pm  view on Meta::CPAN

    my ( $mailref, $ver, $recursive, $debug ) = @_;

    return unless ref($mailref);

    # mime-bodies must have header or initial blank lines.
    #
    my ( $hdr, $body ) = split /\n\r*\n/, $$mailref, 2;
    my $no_valid_mime_hdr = 0;

    unless ($body) {

        # no blank lines, definately no header, so no nested mimes

        print "split_mime: no blank lines\n" if $debug > 1;
        $no_valid_mime_hdr = 1;
    }

    # fixme - handle attachments?  i.e. if header has this
    # Content-Disposition: attachment
    # than body is mail,  we could recursively call ourselves
    # again with body (check body for hdrs first?)

    # Make sure $hdr is really a hdr
    #
    # Details: If mime part is not RFC compliant, it could just
    # be a body with blank lines.  hdr could have just matched part
    # of the body.
    #
    # valid mime header is determined by existance of 'Content-Type'
    # If we're not recursive, we don't check orig_headers, we assume its ok.
    # not sure if this is the best way ...
    #

    if ( $recursive && ( $hdr !~ /^Content-Type:/i ) ) {
        $no_valid_mime_hdr = 1;
        print "uh-oh, bad mime-body len=" . length($$mailref) . ":\n$$mailref\n" if $debug;

        #print "split_mime: recur=($recursive)\n";
    }

    if ($no_valid_mime_hdr) {
        #
        # create dummy header and return it
        #
        # $ver should be '1' or client name + version
        my $mimepart = "X-Razor2-Agent: $ver\n";
        my $hdrlen   = length($mimepart);

        # if it has initial blank line, hurray for rfc compliance
        if ( $$mailref =~ /^\n/ ) {
            $mimepart .= $$mailref;
        }
        else {
            $mimepart .= "\n" . $$mailref;
        }
        print "split_mime: returning total_len=" . length($mimepart) . "; hdrs=" . $hdrlen . ", body=" . length($$mailref) . "\n" if $debug;
        return ( \$mimepart );
    }

    #
    # Now we split mailref into hdr and body
    # check hdr for nested mime (boundary)
    #

    my $orig_hdr = $hdr;
    $hdr =~ s/\n\s+//sg;    # merge multi-line headers
                            # nuke everything but X-Razor2 and Content-* headers
    my $trimmed_hdr = "";
    foreach ( split '\n', $hdr ) {
        /^Content-/i and $trimmed_hdr .= "$_\n";
        /^X-Razor2/i and $trimmed_hdr .= "$_\n";
    }

    my $boundary = "";

    if ( $trimmed_hdr =~ /Content-Type: multipart.+boundary=("[^"]+"|\S+)/ig ) {
        $boundary = $1;
    }

    if ( $boundary eq "" ) {
        #
        # valid mime hdr, but no nested mime.
        # add razor hdr and return.
        #
        print "split_mime: valid_mime_hdr [len=" . length($orig_hdr) . "], but no nested mime\n$orig_hdr\n" if $debug > 1;
        $trimmed_hdr = "X-Razor2-Agent: $ver\n" . $trimmed_hdr;
        my $mimepart = "$trimmed_hdr\n$body";
        print "split_mime: returning total=" . length($mimepart) . "; hdrs=" . length($trimmed_hdr) . ", body=" . length($body) . "\n" if $debug;
        return ( \$mimepart );
    }
    $boundary = $1 if $boundary =~ /^"(.*)"$/;

    # At this point,  we know body has mime parts.
    #
    my @mimeparts;

    #
    # According to RFC 1341
    # http://www.w3.org/Protocols/rfc1341/7_2_Multipart.html
    #
    # mimes are separated by \n--boundary\n
    # and are followed immediately by  header, blank line, body;
    # or blank line and body.
    #
    # if no header in mime part, default content type for mime body is
    # based on header where 'Content-Type: multipart*' was defined, where
    #   multipart/digest --> message/rfc822
    #   multipart/*      --> text/plain
    # perhaps we should add a header if none present?
    #
    # if a body contains mimes, the 'preable', or stuff before
    # the first boundary, and the 'epilogue', the stuff after the
    # last boudary, are to be ignored.
    #
    # NOTE: We split up multiparts, but content-type's can also be
    #       nested.  i.e, a header of 'Content-Type: message' can have a body
    #       of 'Content-Type: image'
    #
    $body =~ s/\n\Q--$boundary--\E.*$//sg;    # trash last boundary and epilogue
    if ( $body =~ /^\Q--$boundary\E\r*\n/ ) {