File Coverage

blib/lib/E/Mail/Acme.pm

Criterion	Covered	Total	%
statement	205	257	79.7
branch	49	92	53.2
condition	6	13	46.1
subroutine	44	50	88.0
pod			n/a
total	304	412	73.7

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

package E'Mail::Acme;

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

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 unless @{*{$_[0]}};#'
  return \@{*{$_[0]}};
};

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

use overload '%{}' => sub {
  tie %{*{$_[0]}}, q unless %{*{$_[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__