view release on metacpan or  search on metacpan

lib/Mail/Header.pm  view on Meta::CPAN

      Precedence
      Status
    };

sub _fold_line
{   my($ln,$maxlen) = @_;

    $maxlen = 20
       if $maxlen < 20;

    my $max = int($maxlen - 5);         # 4 for leading spcs + 1 for [\,\;]
    my $min = int($maxlen * 4 / 5) - 4;

    $_[0] =~ s/[\r\n]+//og;        # Remove new-lines
    $_[0] =~ s/\s*\Z/\n/so;        # End line with an EOLN

    return if $_[0] =~ /^From\s/io;

    if(length($_[0]) > $maxlen)
    {   if($_[0] =~ /^([-\w]+)/ && exists $STRUCTURE{ lc $1 } )
        {   #Split the line up
            # first bias towards splitting at a , or a ; >4/5 along the line
            # next split a whitespace
            # else we are looking at a single word and probably don't want to split
            my $x = "";
            $x .= "$1\n " while $_[0] =~
                s/^\s*
                   ( [^"]{$min,$max} [,;]
                   | [^"]{1,$max}    [,;\s]
                   | [^\s"]*(?:"[^"]*"[ \t]?[^\s"]*)+\s
                   ) //x;

            $x .= $_[0];
            $_[0] = $x;
            $_[0] =~ s/(\A\s+|[\t ]+\Z)//sog;
            $_[0] =~ s/\s+\n/\n/sog;
        }
        else
        {   $_[0] =~ s/(.{$min,$max})(\s)/$1\n$2/g;
            $_[0] =~ s/\s*$/\n/s;
        }
    }

    $_[0] =~ s/\A(\S+)\n\s*(?=\S)/$1 /so; 
}

# Tags are case-insensitive, but there is a (slightly) preferred construction
# being all characters are lowercase except the first of each word. Also
# if the word is an `acronym' then all characters are uppercase. We decide
# a word is an acronym if it does not contain a vowel.
# In general, this change of capitalization is a bad idea, but it is in
# the code for ages, and therefore probably crucial for existing
# applications.

sub _tag_case
{   my $tag = shift;
    $tag =~ s/\:$//;
    join '-'
      , map { /^[b-df-hj-np-tv-z]+$|^(?:MIME|SWE|SOAP|LDAP|ID)$/i
              ? uc($_) : ucfirst(lc($_))
            } split m/\-/, $tag, -1;
}

# format a complete line
#  ensure line starts with the given tag
#  ensure tag is correct case
#  change the 'From ' tag as required
#  fold the line

sub _fmt_line
{   my ($self, $tag, $line, $modify) = @_;
    $modify ||= $self->{mail_hdr_modify};
    my $ctag = undef;

    ($tag) = $line =~ /^($FIELD_NAME|From )/oi
        unless defined $tag;

    if(defined $tag && $tag =~ /^From /io && $self->{mail_hdr_mail_from} ne 'KEEP')
    {   if($self->{mail_hdr_mail_from} eq 'COERCE')
        {   $line =~ s/^From /Mail-From: /o;
            $tag = "Mail-From:";
        }
        elsif($self->{mail_hdr_mail_from} eq 'IGNORE')
        {   return ();
        }
        elsif($self->{mail_hdr_mail_from} eq 'ERROR')
        {    return _error "unadorned 'From ' ignored: <$line>";
        }
    }

    if(defined $tag)
    {   $tag  = _tag_case($ctag = $tag);
        $ctag = $tag if $modify;
        $ctag =~ s/([^ :])$/$1:/o if defined $ctag;
    }

    defined $ctag && $ctag =~ /^($FIELD_NAME|From )/oi
        or croak "Bad RFC822 field name '$tag'\n";

    # Ensure the line starts with tag
    if(defined $ctag && ($modify || $line !~ /^\Q$ctag\E/i))
    {   (my $xtag = $ctag) =~ s/\s*\Z//o;
        $line =~ s/^(\Q$ctag\E)?\s*/$xtag /i;
    }

    my $maxlen = $self->{mail_hdr_lengths}{$tag}
              || $HDR_LENGTHS{$tag}
              || $self->fold_length;

    if ($modify && defined $maxlen)
    {   # folding will fix bad header continuations for us
        _fold_line $line, $maxlen;
    }
    elsif($line =~ /\r?\n\S/)
    {   return _error "Bad header continuation, skipping '$tag': ",
                      "no space after newline in '$line'\n";
    }


    $line =~ s/\n*$/\n/so;
    ($tag, $line);