view release on metacpan or  search on metacpan

lib/E/Mail/Acme.pm  view on Meta::CPAN

    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 %{*{$_[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;

lib/E/Mail/Acme.pm  view on Meta::CPAN

        }

        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",