File Coverage

blib/lib/Email/Extractor.pm

Criterion	Covered	Total	%
statement	86	96	89.5
branch	20	32	62.5
condition	6	12	50.0
subroutine	16	17	94.1
pod	6	6	100.0
total	134	163	82.2

package Email::Extractor;
$Email::Extractor::VERSION = '0.03';

# ABSTRACT: Fast email crawler


use HTML::Encoding 'encoding_from_html_document';
use List::Compare;
use List::Util qw(uniq);
use Email::Find;
use Email::Valid;
use Mojo::DOM;

use Email::Extractor::Utils qw[:ALL];


sub new {
    my ( $class, %param ) = @_;
    $param{ua} = LWP::UserAgent->new;
    $param{timeout} = 20 if !defined $param{timeout};
    $param{ua}->timeout( $param{timeout} );
    $param{only_lang} = 'ru' if !defined $param{only_lang};
    $Email::Extractor::Utils::Verbose = 1 if $param{verbose};
    bless {%param}, $class;
}


sub search_until_attempts {
    my ( $self, $uri, $attempts ) = @_;

    $attempts = 10 if !defined $attempts;
    my $emails = $self->get_emails_from_uri($uri);

    my $links_checked = 1;
    print "No emails found on specified url\n"
      if ( !@$emails && $self->{verbose} );
    return $emails if @$emails;

    my $urls = $self->extract_contact_links;

    print "Contact links found: " . scalar @$urls . "\n"
      if ( @$urls && $self->{verbose} );
    print "No contact links found\n" if ( !@$urls && $self->{verbose} );
    return if !@$urls;

    for my $u (@$urls) {

        $emails = $self->get_emails_from_uri($u);
        $links_checked++;
        $self->{last_attempts} = $links_checked;
        return $emails if @$emails;
        return $emails if ( $links_checked >= $attempts );
    }

    return $emails;    # can be empty array

}


sub get_emails_from_uri {
    my ( $self, $addr ) = @_;
    @emails = ();
    $self->{last_uri} = $addr;
    my $text = load_addr_to_str($addr);
    $self->{last_text} =
      $text;    # store html in memory to speed up further search
    return $self->_get_emails_from_text($text);
}

sub _get_emails_from_text {
    my ( $self, $text ) = @_;
    my $finder = Email::Find->new(
        sub {
            my ( $email, $orig_email ) = @_;
            push @emails, $orig_email;
        }
    );
    $finder->find( \$text );
    @emails = uniq @emails;

    # remove values that passes email validation but in fact are not emails
    # L
    @emails = grep { !isin( $_, $self->get_exceptions ) } @emails;

    # MX record checking
    @emails =
      grep { defined Email::Valid->address( -address => $_, -mxcheck => 1 ) }
      @emails;

    return \@emails;
}


sub extract_contact_links {
    my ( $self, $text ) = @_;

    $text = $self->{last_text} if !defined $text;
    return if !defined $text;

    my $all_links = find_all_links($text);
    return if ( !@$all_links );

    $self->{last_all_links} = $all_links;

    # TO-DO: do not remove links on social networks since there can be email too
    if ( $self->{last_uri} ) {
        $all_links = remove_external_links( $all_links, $self->{last_uri} );
        $all_links = absolutize_links_array( $all_links, $self->{last_uri} );
    }

    $all_links = remove_query_params($all_links);
    $all_links = drop_asset_links($all_links);
    $all_links = drop_anchor_links($all_links);

    my @potential_contact_links;

    if ( $self->{only_lang} ) {
        my $contacts_loc = $self->contacts->{ $self->{only_lang} };
        push @potential_contact_links,
          @{ find_links_by_text( $text, $contacts_loc, 1 ) };
    }
    else {
        for my $c ( @{ $self->contacts } ) {
            my $res = find_links_by_text( $text, $c, 1 );
            push @potential_contact_links, @$res;
        }
    }

    my $grep_url_expr = join( '|', $self->url_with_contacts );
    my @potential_contact_links_by_url =
      grep { $_ =~ /$grep_url_expr/ } @$all_links;

    my @contact_links =
      ( @potential_contact_links_by_url, @potential_contact_links );
    @contact_links = uniq @contact_links;

    $self->{non_contact_links} =
      List::Compare->new( $all_links, \@contact_links )->get_symdiff;

    return \@contact_links;

}


sub contacts {
    return {
        'en' => 'Contacts',
        'ru' => 'Контакты',
    };
}


sub url_with_contacts {
    return qw/
      contact
      contacts
      kontaktyi
      kontakty
      kontakti
      about
      /;
}


sub get_exceptions {
    return [ '![e-mail]' ];
}


sub get_encoding {
    my ( $self, $html ) = @_;
    my $html_to_check = $html || $self->{last_text};
    return encoding_from_html_document($html_to_check);
}


sub contacts {
    return {
        'en' => 'Contacts',
        'ru' => 'Контакты',
    };
}


sub get_encoding {
    my ( $self, $html ) = @_;
    my $html_to_check = $html || $self->{last_text};
    return encoding_from_html_document($html_to_check);
}

1;

__END__