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) {
    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<header_pairs> is another name for L<header_raw_pairs>, 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<header_raw_pairs>.  (In Email::MIME,
#pod L<header_str_pairs> 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<header_raw>.  It's the older name for C<header_raw>,
#pod but it can be a problem because L<Email::MIME>, a subclass of Email::Simple,
#pod makes C<header> 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<header_set> is another name for L<header_raw_set>, 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<header_raw_set>.  (In Email::MIME,
#pod L<header_str_set> 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 I<n>th 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__

=pod

=encoding UTF-8

=head1 NAME

Email::Simple::Header - the header of an Email::Simple message

=head1 VERSION

version 2.218

=head1 SYNOPSIS

  my $email = Email::Simple->new($text);

  my $header = $email->header_obj;
  print $header->as_string;

=head1 DESCRIPTION

This method implements the headers of an Email::Simple object.  It is a very
minimal interface, and is mostly for private consumption at the moment.

=head1 PERL VERSION

This library should run on perls released even a long time ago.  It should work
on any version of perl released in the last five years.

Although it may work on older versions of perl, no guarantee is made that the
minimum required version will not be increased.  The version may be increased
for any reason, and there is no promise that patches will be accepted to lower
the minimum required perl.

=head1 METHODS

=head2 new

  my $header = Email::Simple::Header->new($head, \%arg);

C<$head> is a string containing a valid email header, or a reference to such a
string.  If a reference is passed in, don't expect that it won't be altered.

Valid arguments are:

  crlf - the header's newline; defaults to CRLF

=head2 as_string

  my $string = $header->as_string(\%arg);

This returns a stringified version of the header.

=head2 header_names

This method returns a list of the unique header names found in this header, in
no particular order.

=head2 header_raw_pairs

  my @pairs = $header->header_raw_pairs;
  my $first_name  = $pairs[0];
  my $first_value = $pairs[1];

This method returns a list of all the field/value pairs in the header, in the
order that they appear in the header.  (Remember: don't try assigning that to a
hash.  Some fields may appear more than once!)

=head2 header_pairs

L<header_pairs> is another name for L<header_raw_pairs>, which was the original
name for the method and which you'll see most often.  In general, though, it's
better to be explicit and use L<header_raw_pairs>.  (In Email::MIME,
L<header_str_pairs> exists for letting the library do the header decoding for
you.)

=head2 header_raw

  my $first_value = $header->header_raw($field);
  my $nth_value   = $header->header_raw($field, $index);
  my @all_values  = $header->header_raw($field);

This method returns the value or values of the given header field.  If the
named field does not appear in the header, this method returns false.

=head2 header

This method just calls C<header_raw>.  It's the older name for C<header_raw>,
but it can be a problem because L<Email::MIME>, a subclass of Email::Simple,
makes C<header> return the header's decoded value.

=head2 header_raw_set

  $header->header_raw_set($field => @values);

This method updates the value of the given header.  Existing headers have their
values set in place.  Additional headers are added at the end.  If no values
are given to set, the header will be removed from to the message entirely.

=head2 header_set

L<header_set> is another name for L<header_raw_set>, which was the original
name for the method and which you'll see most often.  In general, though, it's
better to be explicit and use L<header_raw_set>.  (In Email::MIME,
L<header_str_set> exists for letting the library do the header encoding for
you.)

=head2 header_raw_prepend

  $header->header_raw_prepend($field => $value);

This method adds a new instance of the name field as the first field in the
header.

=head2 header_rename

  $header->header_rename($field, $new_name, $nth);

This renames the named field to the new name.  If C<$nth> is given, only the
I<n>th instance of the field will be renamed.  It is fatal to rename an
instance that does not exist.  The first instance of a header is the 0th.

If C<$nth> is omitted, all instances of the header are renamed.

When picking headers to rename, C<$field> is matched case insensitively.  So,
given this header:

    happythoughts: yes
    HappyThoughts: so many
    hapPyThouGhts: forever

Then this code...

    $header->rename_header('happythoughts', 'Delights');

...will result in this:

    Delights: yes
    Delights: so many
    Delights: forever

Headers may be rewrapped as a result of renaming.

=head2 crlf

This method returns the newline string used in the header.

=head1 AUTHORS

=over 4

=item *

Simon Cozens

=item *

Casey West

=item *

Ricardo SIGNES <cpan@semiotic.systems>

=back

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2003 by Simon Cozens.

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=cut