File Coverage

blib/lib/Data/Transpose/EmailValid.pm

Criterion	Covered	Total	%
statement	47	48	97.9
branch	6	8	75.0
condition			n/a
subroutine	11	12	91.6
pod	5	5	100.0
total	69	73	94.5

package Data::Transpose::EmailValid;

use strict;
use warnings;
use Email::Valid;
use Moo;
extends 'Data::Transpose::Validator::Base';
use MooX::Types::MooseLike::Base qw(:all);
use namespace::clean;

=head1 NAME

Data::Transpose::EmailValid - Perl extension to check if a mail is valid (with some autocorrection)

=head1 SYNOPSIS

  use Data::Transpose::EmailValid;

  my $email = Data::Transpose::EmailValid->new;

  ok($email->is_valid("[e-mail]"), "Mail is valid");

  ok(!$email->is_valid("user_e;@domain.tld"), "Mail is not valid");

  warn $email->reason; # output the reason of the failure

=head1 DESCRIPTION

This module check if the mail is valid, using the L
module. It also provides some additional methods.

=head2 AUTO CORRECTION

This validator corrects common mistakes automatically:

=over 4

=item

C<.ocm> instead of C<.com> as top level domain for C,
C, C and C, e.g. C.

=item

Double dots before top level domain, e.g. C.

=back

Please suggest further auto correction examples to us.

=head1 METHODS

=head2 new

Constructor. It doesn't accept any arguments.

=cut

has _email_valid => (is => 'ro',
                     isa => Object,
                     default => sub {
                         return Email::Valid->new(
                                                  -fudge   => 1,
                                                  -mxcheck => 1,
                                                 );
                     });

has input => (is => 'rwp',
              isa => Maybe[Str]);

has output => (is => 'rwp',
               isa => Maybe[Str]);


=head2 input

Accessor to the input email string.

=head2 output

Accessor to the output email string.

=head2 reset_all

Clear all the internal data

=cut


sub reset_all {
    my $self = shift;
    $self->reset_errors;
    $self->_set_input(undef);
    $self->_set_output(undef);
}

=head2 $obj->is_valid($emailstring);

Returns the email passed if valid, false underwise.

=cut


sub is_valid {
    return if @_ == 1;

    my ($self, $email) = @_;

    # overwrite old data
    $self->reset_all;

    $self->_set_input($email);

    # correct common typos # Maybe add an option for this?
    $email = $self->_autocorrect;

    # do validation
    $email = $self->_email_valid->address($email);
    unless ($email) {
        $self->error($self->_email_valid->details);
        return;
    }

    $self->_set_output($email);
    return $email;
}

=head2 $obj->email

Returns the last checked email.

=cut

sub email  { shift->output }

=head2 $obj->reason

Returns the reason of the failure of the last check, false if it was
successful.

=cut


sub reason { shift->error }

=head2 $obj->suggestion

This module implements some basic autocorrection. Calling ->suggestion
after a successfull test, will return the suggested value if the input
was different from the output, false otherwise.

=cut

sub suggestion {
    my ($self) = @_;
    return if $self->error;

    if ($self->input ne $self->output) {
        return $self->output;
    }

    return;
}


sub _autocorrect {
    my $self = shift;
    my $email = $self->input;
    # trim
    $email =~ s/^\s+//;
    $email =~ s/\s+$//;
    # .ocm -> .com
    foreach (qw/aol gmail hotmail yahoo/) {
        $email =~ s/\b$_\.ocm$/$_.com/;
    }
    # double dots in domain part
    $email =~ s/\.\.(\w+)$/.$1/;

    # setting the error breaks the retrocompatibility
    # $self->error("typo?");
    return $email;
}

=head1 AUTHOR

Uwe Voelker

=head1 LICENSE AND COPYRIGHT

Copyright 2012-2016 Uwe Voelker .

This program is free software; you can redistribute it and/or modify it
under the terms of either: the GNU General Public License as published
by the Free Software Foundation; or the Artistic License.

See http://dev.perl.org/licenses/ for more information.

=cut


1;