use strict;
## no critic warnings # let's be 5.00x compatible

package E'Mail::Acme;

$E'Mail::Acme::VERSION = 1505;

my $CRLF = "\x0d\x0a";

use overload '""' => sub {
  my ($self) = @_;

  if (@{$self->[ @$self ]}) {
    unless (($self->{'content-type'}->[0]||'') =~ qr{^multipart/}) {
      warn "content-type set, but not multipart on multipart message"
        if $self->{'content-type'};
      delete $self->{'content-type'};
      $self->{'content-type'} = qq{multipart/mixed};
    }

    unless ($self->{'content-type'}->[0] =~ qr{boundary="(?:[^"]+)"}) {
      $self->{'content-type'}->[0] .= qq{; boundary="$self->[@$self+1]"};
    }
  }

  join(
    $CRLF,
    $self->{''},
    join($CRLF, @{ $_[0] }, '')
    . (
      @{ $_[0]->[ @{ $_[0] } ] }
      ? "$CRLF--$_[0]->[ @{ $_[0] } + 1 ]$CRLF"
        . join("--$_[0]->[ @{ $_[0] } + 1 ]$CRLF", @{ $_[0]->[ @{ $_[0] } ] })
        . "--$_[0]->[ @{ $_[0] } + 1 ]--$CRLF"
      : ''
    )
  );
};

use overload '&{}' => sub {
  my ($self) = @_;
  sub {
    my ($program) =  @_;
    $program = 'sendmail' unless defined $program and length $program;

    if ($program !~ m{[/\\]}) {
      path: for my $dir (split /:/, $ENV{PATH}) {
        if ( -x "$dir/program" ) {
          $program = "$dir/program";
          last path;
        }
      }
    }

    open  $self, "| $program -t -oi -f $self->{from}->[0]" or die;
    print $self $self or die;
    close $self  or die;
  }
};

use overload '@{}' => sub {
  tie @{*{$_[0]}}, q<E'Mail::Acme::Body> unless @{*{$_[0]}};#'
  return \@{*{$_[0]}};
};

use Scalar::Util qw(refaddr); # XXX

use overload '%{}' => sub {
  tie %{*{$_[0]}}, q<E'Mail::Acme::Header> unless defined %{*{$_[0]}};#'
  return \%{*{$_[0]}};
};

use overload fallback => 1;

{
  package E'Mail::Acme::HeaderFieldValues;
  our @ISA = qw(E'Mail::Acme::Base);

  sub TIEARRAY {
    my ($class, $name, $gutter) = @_;
    bless [ $name, $gutter ] => $class;
  }

  sub FETCHSIZE {
    my ($self) = @_;
  
    my $gut = $self->[1]->();

    my $hits = 0;
    i: for (my $i = 0; $i < $#$gut; $i += 2) {
      lc $gut->[ $i ] eq lc $self->_idx(0) and $hits++;
    }

    return $hits;
  }

  sub EXISTS {
    my ($self, $idx) = @_;
    return $idx <= $self->FETCHSIZE;
  }

  sub FETCH {
    my ($self, $idx) = @_;

    my $gut = $self->_idx(1)->();

    i: for (my $i = 0; $i < $#$gut; $i += 2) {
      lc $gut->[ $i ] eq lc $self->_idx(0) or next i;
      return $gut->[ $i + 1 ] if $idx == 0;
      $idx--;
    }

    return;
  }

  sub DELETE {
    my ($self, $idx) = @_;
    $self->SPLICE($idx, 1);
  }

  sub CLEAR {
    my ($self) = @_;
    $self->SPLICE(0, $self->FETCHSIZE);
  }

  sub EXTEND { }

  sub SPLICE {
    my ($self, $idx, $length, @new) = @_;

    if ($idx >= $self->FETCHSIZE) {
      return $self->PUSH(@new);
    }

    my $gut = $self->_idx(1)->();

    i: for (my $i = 0; $i < $#$gut; $i += 2) {
      lc $gut->[ $i ] eq lc $self->_idx(0) or next;
      if ($idx == 0) {
        if ($length == 0) {
          splice @$gut, $i, 0, map { $self->_idx(0), $_ } @new;
          return;
        }

        if (@new) {
          $gut->[ $i ] = $self->_idx(0);
          $gut->[ $i + 1 ] = shift @new;
        } else {
          splice @$gut, $i, 2;
          $i -= 2;
        }
        $length--;
      } else {
        $idx--;
      }
    }

    $self->PUSH(@new);
  }

  sub PUSH {
    my ($self, @new) = @_;

    my $gut = $self->_idx(1)->();
    push @$gut, $self->_idx(0), $_ for @new;
  }

  sub STORE {
    my ($self, $idx, $value) = @_;

    my $gut = $self->_idx(1)->();

    if ($idx >= $self->FETCHSIZE) {
      push @$gut, $self->_idx(0), $value;
      return $value;
    }

    i: for (my $i = 0; $i < $#$gut; $i += 2) {
      lc $gut->[ $i ] eq lc $self->_idx(0) or next;
      if ($idx == 0) {
        $gut->[ $i ] = $self->_idx(0);
        $gut->[ $i + 1 ] = $value;
        return $value;
      }
      $idx--;
    }
  }
}

{
  package E'Mail::Acme::Body;
  our @ISA = qw(E'Mail::Acme::Base);

  my $i = 0;
  sub TIEARRAY {
    my ($class) = @_;

    my $self = {
      lines => [],
      parts => [],
      bound => time . '-' . $$ . '-' . $i++ . $^T,
    };
    bless $self => $class;
  }

  sub CLEAR {
    my ($self) = @_;
    $self->{lines} = [];
    $self->{parts} = [];
  }

  sub EXTEND { }

  sub FETCHSIZE {
    my ($self) = @_;
    warn "calling FETCHSIZE\n" if $::foo;
    my $size = scalar @{ $self->{lines} };
    return $size;
  }

  sub FETCH {
    my ($self, $idx) = @_;

    warn "calling FETCH $idx\n" if $::foo;
    my $size = $self->FETCHSIZE;
    if ($idx == $size) {
      return $self->{parts};
    } elsif ($idx == $size + 1) {
      return $self->{bound};
    }

    $self->{lines}[$idx];
  }

  sub _values {
    my ($self, $value) = @_;
    return $value if ref $value;
    my @values = split /\x0d\x0a|\x0a\x0d|\x0a|\x0d/, $value;
  }

  sub STORE {
    my ($self, $idx, @values) = @_;
    $self->SPLICE($idx, 1, 
      map { my @v = $self->_values($_); @v ? @v : '' } @values
    );
  }

  sub SPLICE {
    my ($self, $idx, $length, @values) = @_;

    my @to_splice;
    my @parts;

    for my $v (map { my @v = $self->_values($_); @v ? @v : '' } @values) {
      # The E:: is a concession to v5.6.x
      if (eval { $v->isa("E'Mail::Acme") or $v->isa("E::Mail::Acme") }) {
        push @parts, $v;
      } elsif (ref $v eq 'ARRAY' or eval { overload::Method($v, '@{}') }) {
        push @to_splice, map { my @v = $self->_values($_); @v ? @v : '' } @$v;
      } else {
        push @to_splice, $v;
      }
    }

    push @{ $self->{parts} }, @parts;
    splice @{ $self->{lines} }, $idx, $length, @to_splice;
  }

  sub PUSH {
    my ($self, @values) = @_;

    $self->SPLICE(
      $self->FETCHSIZE,
      0,
      map { my @v = $self->_values($_); @v ? @v : '' } @values
    );
  }
}

{
  package E'Mail::Acme::HeaderField;
  our @ISA = qw(E'Mail::Acme::Base);

  sub TIESCALAR {
    my ($class, $name, $gutter) = @_;
    bless [ $name, $gutter ] => $class;
  }

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

    my $gut = $self->_idx(1)->();
 
    i: for (my $i = 0; $i < $#$gut; $i += 2) {
      lc $gut->[ $i ] eq lc $self->_idx(0) and return $gut->[ $i + 1 ];
    }
  }

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

    my $string = '';

    my $gut = $self->_idx(1)->();
    i: for (my $i = 0; $i < $#$gut; $i += 2) {
      lc $gut->[ $i ] eq lc $self->_idx(0) and
        $string .= $gut->[$i] . ': ' . $gut->[$i + 1] . $CRLF;
    }
    return $string;
  }

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

    tie my @values, "E'Mail::Acme::HeaderFieldValues",
      $self->_idx(0),
      $self->_idx(1),
    ;

    \@values;
  }

  use overload
    '""'     => '_str_all',
    '@{}'    => '_values_obj',
    fallback => 1;
}

{ # package E'Mail::Acme::Header
  package E'Mail::Acme::Header;
  @E'Mail::Acme::Header::ISA = qw(E'Mail::Acme::Base);

  sub TIEHASH {
    my ($class, $e_mail) = @_;
    bless {
      obj => $e_mail,
      hdr => []
    } => $class;
  }

  sub FETCH {
    my ($self, $key) = @_;

    return $self->_str_all if $key eq '';

    return tie my $field, "E'Mail::Acme::HeaderField",
      $key,
      sub { $self->{hdr} }
    ;
  }

  sub EXISTS {
    my ($self, $key) = @_;

    i: for (my $i = 0; $i < $#{$self->{hdr}}; $i += 2) {
      return 1 if lc $self->{hdr}[$i] eq lc $key;
    }
    return;
  }

  sub STORE {
    my ($self, $key, $value) = @_;

    return $self->DELETE($key) if ! defined $value;

    if (
      ref $value eq 'ARRAY'
      or
      eval { overload::Method($value, '@{}') }
    ) {
      $self->DELETE($key), return $self->FETCH($key) unless @$value;
      $self->STORE($key, $_) for @$value;
      return $self->FETCH($key);
    }

    push @{ $self->_attr('hdr') }, $key, $value;

    return $self->FETCH($key);
  }

  sub DELETE {
    my ($self, $key) = @_;

    return unless $#{ $self->{hdr} } >= 1;

    i: for (my $i = $#{$self->{hdr}} - 1; $i >= 0; $i -= 2) {
      lc $self->{hdr}[$i] eq lc $key or next i;
      splice @{ $self->{hdr} }, $i, 2;
    }
  }

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

    delete $self->{iter};
    $self->{iter} = { };

    i: for (my $i = 0; $i < $#{$self->{hdr}}; $i += 2) {
      my $v = $self->{iter}{ lc $self->{hdr}[$i] } ||= [];
      push @$v, $self->{hdr}[ $i + 1 ];
    }

    return each %{ $self->{iter} };
  }

  sub NEXTKEY {
    my ($self, $prev) = @_;

    die "error during e'mail header transnaviation" unless $self->{iter};
    return each %{ $self->{iter} };
  }

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

    my $string = '';
    i: for (my $i = 0; $i < $#{$self->{hdr}}; $i += 2) {
      $string .= $self->{hdr}[$i] . ': ' . $self->{hdr}[$i + 1] . $CRLF;
    }
    return $string;
  }

  use overload
    fallback => 1,
    '""'     => '_str_all',
  ;
}

{ # Utility constructor class
  package E'Mail;
  sub Acme {
    my $guts = {};

    use Symbol;
    my $self = Symbol::gensym;
    bless $self => "E'Mail::Acme";
  };
}

{
  package E'Mail::Acme::Base;
  sub _idx {
    my ($self, $idx) = @_;
    my $orig_class = ref $self;
    bless $self => "E'Mail::Acme::HoldingPattern";
    my $value = $self->[$idx];
    bless $self => $orig_class;
    return $value;
  }

  sub _attr {
    my ($self, $key) = @_;
    my $orig_class = ref $self;
    bless $self => "E'Mail::Acme::HoldingPattern";
    my $value = $self->{$key};
    bless $self => $orig_class;
    return $value;
  }
}

E'Mail::Acme;#'

__END__

=head1 NAME

E'Mail::Acme - the epitome of simple e-mail handling

=head1 VERSION

version 1123

=head1 SYNOPSIS

  my $e_mail = E'Mail::Acme;

  $e_mail->{From} = q<Ricardo SIGNES <rjbs@acme.example.biz>>;
  $e_mail->{To  } = q<Alvin Theodore <monk@chip.shoulder.dw>>;

  $e_mail->{Subject} = 'Finally, a simple e-mail module!';

  push @$e_mail,
    'Alvin,',
    '',
    'I agree!  What the world needs is a module that makes e-mail more',
    'accessible to the common man -- or at least the common Perl programmer.',
    '',
    'I have attached a modest example.',
  ;

  $e_mail->('sendmail');

=head1 DESCRIPTION

Good grief, everywhere you turn there's yet another e-mail module!  This one
says that the message is an object.  That one says that every I<field> is an
object.  Then there's the one that says the darn B<body> is an object!

How many methods do I need to learn, anyway?  Look, an e-mail is simple.  It's
a set of name/value pairs forming a header and a list of lines.  That's it!
Anybody who tells you otherwise is just being a nervous Nelly.

E'Mail::Acme is the epitome of simple e-mail handling.  It does use an object,
but only to help produce a synergistic, cohesive unity of purpose.  It uses
I<just> the familiar, existing Perl data system so that you only need use the
Perl you already know -- none of this overwrought API that we've all gotten so
sick of.

=head1 METHODS

None.

=head1 CONSTRUCTION

Making a new e-mail is easy:

  my $e_mail = E'Mail::Acme;

=head1 HEADERS

Setting headers is easy:

  $e_mail->{header} = "First Value";
  $e_mail->{HeadEr} = "Second Value";

  print $e_mail->{header};
  # header: First Value
  # HeadeR: Second Value

You can also assign multiple values at once:

  $e_mail->{XForce} = [ qw(Lethal Aggressive) ];

  print $e_mail->{XForce};
  # X-Force: Lethal
  # X-Force: Aggressive

To clear all of those headers, you can just:

  delete $e_mail->{xforce};

Or, to delete just the first, either of these will work:

  delete $e_mail->{XForce}[0];

  splice @{ $e_mail->{XForce} }, 0, 1;

Alternately, more values could be added in a similar fashion:

  push @{ $e_mail->{XForce} }, 'except on Sundays';
  
  splice @{ $e_mail->{XForce} }, 1, 0, 'and';

Of course, individual header values can be passed around and used to affect the
original message:

  my $recipients = $e_mail->{to};

  munge_values($recipients); # the $e_mail is altered

This frees you from passing around a large clunky message "object" when you
only need to deal with part of it.

=head1 THE BODY

The body is just a sequence of lines, and you can treat it as such:

  @$e_mail = "Friends, Romans, Countrymen:"
          , ''
          , 'Lend me your ears!';

You can always easily add your sig to a message:

  my $sig = "-- \nrjbs\n";

  push @$e_mail, $sig;

E'Mail::Acme will take care of all the conversion of newlines, breaking up text
on all likely newlines and normalizing to CRLF.

=head1 MULTIPART

Multipart messages are easy:  just push more e-mails onto the body.

  my $e_mail = E'Mail::Acme; # top part;
  my $part_1 = E'Mail::Acme; # attachment
  my $part_2 = E'Mail::Acme; # attachment

  push @$e_mail, $part_1, $part_2;

Any lines in a multi-part e-mail message form the preamble, and an arrayref of
subparts is always available at the end of the e-mail -- that is, like this:

  my $subparts = $e_mail->[ scalar @$e_mail ];

Nested multipart messages are handled just fine.  A multipart content-type will
be added, if none has been supplied.  If a multipart content-type is set, but
the boundary is not, it will be added.  Do not set your own boundary unless you
know what you are doing!  You will probably produce a corrupt message!

=head1 SENDING MAIL

A mail exists to be sent, not hoarded!  Once you've composed your e-mail
message, you can send it just how you'd expect:

  $e_mail->();

If your F<sendmail> program is not installed in your path, you can specify
which program to use by passing it as an argument:

  $e_mail->(q(c:/program files/sendmail/sendmail.exe));

=cut

=head1 THANKS

Thanks to Simon, Simon, Casey, Richard, Dave, Dieter, Meng, Mark, Graham, Tim,
Yves, David, Eryq and everyone else who has helped form my understanding of how
e-mail should be handled.

=head1 AUTHOR

Ricardo SIGNES wrote this module on Friday, July 13, 2007.

=head1 COPYRIGHT AND LICENSE

This code is copyright (c) 2007, Ricardo SIGNES.  It is free software,
available under the same terms as Perl itself.

=cut