view release on metacpan or  search on metacpan

lib/Email/Simple/Header.pm  view on Meta::CPAN

use v5.12.0;
use warnings;
package Email::Simple::Header 2.218;
# ABSTRACT: the header of an Email::Simple message

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) {