File Coverage

blib/lib/Mail/Verp.pm

Criterion	Covered	Total	%
statement	44	56	78.5
branch	11	18	61.1
condition	3	9	33.3
subroutine	8	8	100.0
pod	4	4	100.0
total	70	95	73.6

package Mail::Verp;

use 5.000;
use strict;

use Carp;

use vars qw($VERSION @ENCODE_MAP @DECODE_MAP $DEFAULT_SEPARATOR $SEPARATOR);
$VERSION = '0.06';

my @chars =  qw(@ : % ! - [ ]);

@ENCODE_MAP = map { quotemeta($_), sprintf '%.2X', ord($_) } ('+', @chars);
@DECODE_MAP = map { sprintf('%.2X', ord($_)), $_ } (@chars, '+');


$DEFAULT_SEPARATOR = '-'; #used as a constant
$SEPARATOR = $DEFAULT_SEPARATOR; #used by class methods. Can be changed.

sub separator {
  my $self = shift;

  #called as class or instance object?
  my $var = ref($self) ? \$self->{separator} : \$SEPARATOR;

  my $value = $$var;

  if (@_){
    $$var = shift;
  }

  return $value;
}

sub new
{
    my $self = shift;
    $self = bless { separator => $DEFAULT_SEPARATOR, @_ }, ref($self) || $self;
    $self->separator($self->{separator});
    return $self;
}

sub encode
{
    my $self = shift;
    my $sender = shift;
    my $recipient = shift;

    unless ($sender){
        carp "Missing sender address";
        return;
    }

    unless ($recipient){
        carp "Missing recipient address";
        return;
    }

    my ($slocal, $sdomain) = $sender  =~ m/(.+)\@([^\@]+)$/;

    unless ($slocal && $sdomain){
        carp "Cannot parse sender address [$sender]";
        return;
    }

    my ($rlocal, $rdomain) = $recipient =~ m/(.+)\@([^\@]+)$/;

    unless ($rlocal && $rdomain){
        carp "Cannot parse recipient address [$recipient]";
        return;
    }

    for (my $i = 0; $i < @ENCODE_MAP; $i += 2) {
        for my $t ($rlocal, $rdomain){
            $t  =~ s/$ENCODE_MAP[$i]/+$ENCODE_MAP[$i + 1]/g;
        }
    }

    return join('', $slocal, $self->separator, $rlocal, '=', $rdomain, '@', $sdomain);
}

sub decode
{
    my $self = shift;
    my $address = shift;

    unless ($address){
        carp "Missing encoded address";
        return;
    }

    my $separator = $self->separator;

    if (my ($slocal, $rlocal, $rdomain, $sdomain) =
        $address =~ m/^(.+?)\Q${separator}\E(.+)=([^=\@]+)\@(.+)/){

#        warn "$address $slocal $rlocal $rdomain $sdomain\n";

        for (my $i = 0; $i < @DECODE_MAP; $i += 2) {
            for my $t ($rlocal, $rdomain){
                $t  =~ s/\+$DECODE_MAP[$i]/$DECODE_MAP[$i + 1]/ig;
            }
        }

        return (qq[$slocal\@$sdomain], qq[$rlocal\@$rdomain]) if wantarray;
        return qq[$rlocal\@$rdomain];
    }
    else {
        return $address;
    }
}


1;
__END__