File Coverage

blib/lib/Email/Simple/Header.pm

Criterion	Covered	Total	%
statement	141	145	97.2
branch	61	72	84.7
condition	12	21	57.1
subroutine	21	21	100.0
pod	11	11	100.0
total	246	270	91.1

use strict;
use warnings;
package Email::Simple::Header;
# ABSTRACT: the header of an Email::Simple message
$Email::Simple::Header::VERSION = '2.217'; # TRIAL
use Carp ();

our @CARP_NOT = qw(Email::Simple);

require Email::Simple;

#pod =head1 SYNOPSIS
#pod
#pod   my $email = Email::Simple->new($text);
#pod
#pod   my $header = $email->header_obj;
#pod   print $header->as_string;
#pod
#pod =head1 DESCRIPTION
#pod
#pod This method implements the headers of an Email::Simple object.  It is a very
#pod minimal interface, and is mostly for private consumption at the moment.
#pod
#pod =method new
#pod
#pod   my $header = Email::Simple::Header->new($head, \%arg);
#pod
#pod C<$head> is a string containing a valid email header, or a reference to such a
#pod string.  If a reference is passed in, don't expect that it won't be altered.
#pod
#pod Valid arguments are:
#pod
#pod   crlf - the header's newline; defaults to CRLF
#pod
#pod =cut

# We need to be able to:
#   * get all values by lc name
#   * produce all pairs, with case intact

sub new {
  my ($class, $head, $arg) = @_;

  my $head_ref = ref $head ? $head : \$head;

  my $self = { mycrlf => $arg->{crlf} || "\x0d\x0a", };

  my $headers = $class->_header_to_list($head_ref, $self->{mycrlf});

  #  for my $header (@$headers) {
  #    push @{ $self->{order} }, $header->[0];
  #    push @{ $self->{head}{ $header->[0] } }, $header->[1];
  #  }
  #
  #  $self->{header_names} = { map { lc $_ => $_ } keys %{ $self->{head} } };
  $self->{headers} = $headers;

  bless $self => $class;
}

sub _header_to_list {
  my ($self, $head, $mycrlf) = @_;

  Carp::carp 'Header with wide characters' if ${$head} =~ /[^\x00-\xFF]/;

  my @headers;

  my $crlf = Email::Simple->__crlf_re;

  while ($$head =~ m/\G(.+?)$crlf/go) {
    local $_ = $1;

    if (/^\s+/ or not /^([^:]+):\s*(.*)/) {
      # This is a continuation line. We fold it onto the end of
      # the previous header.
      next if !@headers;  # Well, that sucks.  We're continuing nothing?

      (my $trimmed = $_) =~ s/^\s+//;
      $headers[-1][0] .= $headers[-1][0] =~ /\S/ ? " $trimmed" : $trimmed;
      $headers[-1][1] .= "$mycrlf$_";
    } else {
      push @headers, $1, [ $2, $_ ];
    }
  }

  return \@headers;
}

#pod =method as_string
#pod
#pod   my $string = $header->as_string(\%arg);
#pod
#pod This returns a stringified version of the header.
#pod
#pod =cut

# RFC 2822, 3.6:
# ...for the purposes of this standard, header fields SHOULD NOT be reordered
# when a message is transported or transformed.  More importantly, the trace
# header fields and resent header fields MUST NOT be reordered, and SHOULD be
# kept in blocks prepended to the message.

sub as_string {
  my ($self, $arg) = @_;
  $arg ||= {};

  my $header_str = '';

  my $headers = $self->{headers};

  my $fold_arg = {
    # at     => (exists $arg->{fold_at} ? $arg->{fold_at} : $self->default_fold_at),
    # indent => (exists $arg->{fold_indent} ? $arg->{fold_indent} : $self->default_fold_indent),
    at     => $self->_default_fold_at,
    indent => $self->_default_fold_indent,
  };

  for (my $i = 0; $i < @$headers; $i += 2) {
    if (ref $headers->[ $i + 1 ]) {
      $header_str .= $headers->[ $i + 1 ][1] . $self->crlf;
    } else {
      my $header = "$headers->[$i]: $headers->[$i + 1]";

      $header_str .= $self->_fold($header, $fold_arg);
    }
  }

  return $header_str;
}

#pod =method header_names
#pod
#pod This method returns a list of the unique header names found in this header, in
#pod no particular order.
#pod
#pod =cut

sub header_names {
  my $headers = $_[0]->{headers};

  my %seen;
  grep  { !$seen{ lc $_ }++ }
    map { $headers->[ $_ * 2 ] } 0 .. @$headers / 2 - 1;
}

#pod =method header_raw_pairs
#pod
#pod   my @pairs = $header->header_raw_pairs;
#pod   my $first_name  = $pairs[0];
#pod   my $first_value = $pairs[1];
#pod
#pod This method returns a list of all the field/value pairs in the header, in the
#pod order that they appear in the header.  (Remember: don't try assigning that to a
#pod hash.  Some fields may appear more than once!)
#pod
#pod =method header_pairs
#pod
#pod L is another name for L, which was the original
#pod name for the method and which you'll see most often.  In general, though, it's
#pod better to be explicit and use L.  (In Email::MIME,
#pod L exists for letting the library do the header decoding for
#pod you.)
#pod
#pod =cut

sub header_raw_pairs {
  my ($self) = @_;

  my @pairs = map {; _str_value($_) } @{ $self->{headers} };

  return @pairs;
}

sub header_pairs {
  my ($self) = @_;
  $self->header_raw_pairs;
}

#pod =method header_raw
#pod
#pod   my $first_value = $header->header_raw($field);
#pod   my $nth_value   = $header->header_raw($field, $index);
#pod   my @all_values  = $header->header_raw($field);
#pod
#pod This method returns the value or values of the given header field.  If the
#pod named field does not appear in the header, this method returns false.
#pod
#pod =method header
#pod
#pod This method just calls C.  It's the older name for C,
#pod but it can be a problem because L, a subclass of Email::Simple,
#pod makes C return the header's decoded value.
#pod
#pod =cut

sub _str_value { return ref $_[0] ? $_[0][0] : $_[0] }

sub header_raw {
  my ($self, $field, $index) = @_;

  my $headers  = $self->{headers};
  my $lc_field = lc $field;

  if (wantarray and not defined $index) {
    return map { _str_value($headers->[ $_ * 2 + 1 ]) }
      grep { lc $headers->[ $_ * 2 ] eq $lc_field } 0 .. @$headers / 2 - 1;
  } else {
    $index = 0 unless defined $index;
    my $max = @$headers / 2 - 1;
    my @indexes = $index >= 0 ? (0 .. $max) : reverse(0 .. $max);
    $index = -1-$index if $index < 0;
    for (@indexes) {
      next unless lc $headers->[ $_ * 2 ] eq $lc_field;
      return _str_value($headers->[ $_ * 2 + 1 ]) if $index-- == 0;
    }
    return undef;
  }
}

*header = \&header_raw;

#pod =method header_raw_set
#pod
#pod   $header->header_raw_set($field => @values);
#pod
#pod This method updates the value of the given header.  Existing headers have their
#pod values set in place.  Additional headers are added at the end.  If no values
#pod are given to set, the header will be removed from to the message entirely.
#pod
#pod =method header_set
#pod
#pod L is another name for L, which was the original
#pod name for the method and which you'll see most often.  In general, though, it's
#pod better to be explicit and use L.  (In Email::MIME,
#pod L exists for letting the library do the header encoding for
#pod you.)
#pod
#pod =cut

# Header fields are lines composed of a field name, followed by a colon (":"),
# followed by a field body, and terminated by CRLF.  A field name MUST be
# composed of printable US-ASCII characters (i.e., characters that have values
# between 33 and 126, inclusive), except colon.  A field body may be composed
# of any US-ASCII characters, except for CR and LF.

# However, a field body may contain CRLF when used in header "folding" and
# "unfolding" as described in section 2.2.3.

sub header_raw_set {
  my ($self, $field, @data) = @_;

  Carp::carp "Header name '$field' with wide characters" if $field =~ /[^\x00-\xFF]/;
  Carp::carp "Value for '$field' header with wide characters" if grep /[^\x00-\xFF]/, @data;

  # I hate this block. -- rjbs, 2006-10-06
  if ($Email::Simple::GROUCHY) {
    Carp::croak "field name contains illegal characters"
      unless $field =~ /^[\x21-\x39\x3b-\x7e]+$/;
    Carp::carp "field name is not limited to hyphens and alphanumerics"
      unless $field =~ /^[\w-]+$/;
  }

  my $headers = $self->{headers};

  my $lc_field = lc $field;
  my @indices = grep { lc $headers->[$_] eq $lc_field }
    map { $_ * 2 } 0 .. @$headers / 2 - 1;

  if (@indices > @data) {
    my $overage = @indices - @data;
    splice @{$headers}, $_, 2 for reverse @indices[ -$overage .. -1 ];
    pop @indices for (1 .. $overage);
  } elsif (@data > @indices) {
    my $underage = @data - @indices;
    for (1 .. $underage) {
      push @$headers, $field, undef;  # temporary value
      push @indices, $#$headers - 1;
    }
  }

  for (0 .. $#indices) {
    $headers->[ $indices[$_] + 1 ] = $data[$_];
  }

  return wantarray ? @data : $data[0];
}

sub header_set {
  my ($self, $field, @data) = @_;
  $self->header_raw_set($field, @data);
}

#pod =method header_raw_prepend
#pod
#pod   $header->header_raw_prepend($field => $value);
#pod
#pod This method adds a new instance of the name field as the first field in the
#pod header.
#pod
#pod =cut

sub header_raw_prepend {
  my ($self, $field, $value) = @_;

  Carp::confess("tried to prepend raw header with undefined field name")
    unless defined $field;

  Carp::confess(qq{tried to prepend raw header "$field" with undefined value})
    unless defined $value;

  unshift @{ $self->{headers} }, $field => $value;

  return;
}

#pod =method header_rename
#pod
#pod   $header->header_rename($field, $new_name, $nth);
#pod
#pod This renames the named field to the new name.  If C<$nth> is given, only the
#pod Ith instance of the field will be renamed.  It is fatal to rename an
#pod instance that does not exist.  The first instance of a header is the 0th.
#pod
#pod If C<$nth> is omitted, all instances of the header are renamed.
#pod
#pod When picking headers to rename, C<$field> is matched case insensitively.  So,
#pod given this header:
#pod
#pod     happythoughts: yes
#pod     HappyThoughts: so many
#pod     hapPyThouGhts: forever
#pod
#pod Then this code...
#pod
#pod     $header->rename_header('happythoughts', 'Delights');
#pod
#pod ...will result in this:
#pod
#pod     Delights: yes
#pod     Delights: so many
#pod     Delights: forever
#pod
#pod Headers may be rewrapped as a result of renaming.
#pod
#pod =cut

sub header_rename {
  my ($self, $field, $new_name, $n) = @_;

  my $headers = $self->{headers};
  my $lc_field = lc $field;

  my @indices = grep { lc $headers->[$_] eq $lc_field }
    map { $_ * 2 } 0 .. @$headers / 2 - 1;

  if (defined $n) {
    if ($n < 0) { Carp::confess("negative header index makes no sense") }
    if ($n > $#indices) { Carp::confess("$n exceeds count of $field headers") }

    @indices = $indices[$n];
  }

  for my $i (@indices) {
    $headers->[$i] = $new_name;
    if (ref $headers->[$i + 1]) {
      $headers->[$i + 1] = $headers->[ $i + 1 ][0];
    }
  }

  return;
}

#pod =method crlf
#pod
#pod This method returns the newline string used in the header.
#pod
#pod =cut

sub crlf { $_[0]->{mycrlf} }

# =method fold
#
#   my $folded = $header->fold($line, \%arg);
#
# Given a header string, this method returns a folded version, if the string is
# long enough to warrant folding.  This method is used internally.
#
# Valid arguments are:
#
#   at      - fold lines to be no longer than this length, if possible
#             if given and false, never fold headers
#   indent  - indent lines with this string

# =cut

sub _fold {
  my ($self, $line, $arg) = @_;
  $arg ||= {};

  $arg->{at} = $self->_default_fold_at unless exists $arg->{at};

  $arg->{indent} = $self->_default_fold_indent unless exists $arg->{indent};

  my $indent = $arg->{indent} || $self->_default_fold_indent;

  # We will not folder headers if...
  # * the header has vertical whitespace
  # * all vertical whitespace is followed by horizontal whitespace or END
  if ($line =~ /\n/) {
    if ($line =~ s/\n([^\s\t])/\n$indent$1/g) {
      Carp::carp("bad space in header: newline followed by non-space: $line");
    } else {
      $line .= $self->crlf unless $line =~ /\n$/;
      return $line;
    }
  }

  return $line . $self->crlf unless $arg->{at} and $arg->{at} > 0;

  my $limit  = ($arg->{at} || $self->_default_fold_at) - 1;

  return $line . $self->crlf if length $line <= $limit;

  return $self->__fold_objless($line, $limit, $indent, $self->crlf);

}

sub __fold_objless {
  my ($self, $line, $limit, $indent, $crlf) = @_;

  # We know it will not contain any new lines at present
  my $folded = "";
  while (length $line) {
    if ($line =~ s/^(.{0,$limit})(\s|\z)//) {
      $folded .= $1 . $crlf;
      $folded .= $indent if length $line;
    } else {
      # Basically nothing we can do. :(
      $folded .= $line . $crlf;
      last;
    }
  }

  return $folded;
}

# =method default_fold_at
#
# This method (provided for subclassing) returns the default length at which to
# try to fold header lines.  The default default is 78.
#
# =cut

sub _default_fold_at { 78 }

# =method default_fold_indent
#
# This method (provided for subclassing) returns the default string used to
# indent folded headers.  The default default is a single space.
#
# =cut

sub _default_fold_indent { " " }

1;

__END__