File Coverage

blib/lib/Email/Extractor/Utils.pm

Criterion	Covered	Total	%
statement	124	128	96.8
branch	30	40	75.0
condition	6	12	50.0
subroutine	31	31	100.0
pod	14	14	100.0
total	205	225	91.1

#ABSTRACT: Set of functions that can be useful when building web crawlers


package Email::Extractor::Utils;
$Email::Extractor::Utils::VERSION = '0.03';
use strict;
use warnings;
use feature 'say';

use Cwd;
use Carp;
use URI::URL;
use File::Spec;
use File::Slurp qw(read_file);
use File::Basename;    # fileparse
use Regexp::Common qw /URI/;
use LWP::UserAgent;
use LWPx::TimedHTTP qw(:autoinstall);
use Mojo::DOM;

require Exporter;

our @ISA       = qw(Exporter);
our @EXPORT_OK = qw(
  looks_like_url
  looks_like_rel_link
  looks_like_file
  get_file_uri
  load_addr_to_str
  absolutize_links_array
  find_all_links
  find_links_by_text
  drop_asset_links
  drop_anchor_links
  remove_query_params
  remove_external_links
  isin
);
our %EXPORT_TAGS = ( 'ALL' => [@EXPORT_OK] );

our $Verbose = 0 unless defined $Verbose;


our $Assets = [
    'css', 'less', 'js',  'jpg',  'JPG', 'jpeg', 'JPEG', 'png',
    'PNG', 'svg',  'doc', 'docx', 'ppt', 'odt',  'rtf',  'ppt'
];

# Loads url and measure timings

sub _load_url_verbose {
    my $addr = shift;
    my $ua   = LWP::UserAgent->new;
    my $resp = $ua->get($addr);       # HTTP::Response

    my @headers = qw/
      Client-Request-Dns-Time
      Client-Request-Connect-Time
      Client-Request-Transmit-Time
      Client-Response-Server-Time
      Client-Response-Receive-Time
      /;

    my $msg;
    for my $h (@headers) {
        my $prm = ( split( '-', $h ) )[2];
        $msg .= ' ' . $prm . ' : ' . $resp->header($h) . "\n"
          if defined $resp->header($h);
    }

    say $msg if $Verbose;
    say $resp->status_line if ( $resp->is_error && $Verbose );
    return $resp->content;
}


sub load_addr_to_str {
    my $addr = shift;

    eval {

        if ( looks_like_url($addr) ) {

            say "$addr: is url" if $Verbose;
            _load_url_verbose($addr);

        }
        else {

            say "$addr: is file" if $Verbose;
            my $file_uri = get_file_uri($addr);

            if ( looks_like_file($file_uri) ) {
                return read_file( get_abs_path($addr) );

            }
            else {
                die "No such file: " . $addr . " or it is not file or http uri";
            }

        }

    };
}


sub get_abs_path {
    my $filename = shift;
    return File::Spec->catfile( getcwd(), $filename );
}


sub get_file_uri {
    my $filename = shift;
    return 'file://' . File::Spec->catfile( getcwd(), $filename );
}


sub looks_like_url {
    my $string = shift;
    my $regexp = qr($RE{URI}{HTTP}{-scheme=>qr/https?/}{-keep});

    if ( $string =~ $regexp ) {

        # return $7 if defined $7;
        return $1;
    }
    else {
        return 0;
    }
}


sub looks_like_rel_link {
    my $link = shift;
    return 0 if ( looks_like_url($link) );
    return 1;
}


sub looks_like_file {
    my $string = shift;
    if ( $string =~ qr($RE{URI}{file}) ) {
        return 1;
    }
    else {
        return 0;
    }
}


sub absolutize_links_array {
    my ( $links_arr, $dname ) = @_;

    confess 'No valid dname in absolutize_links_array()'
      unless defined $dname && length $dname;

    my @res;

    for my $l (@$links_arr) {
        if ( looks_like_rel_link($l) ) {
            $l = url( $l, $dname )->abs->as_string;
        }
        push @res, $l;
    }

    return \@res;
}


sub remove_external_links {
    my ( $links_arr, $only_dname ) = @_;

    confess 'No valid dname in remove_external_links()'
      unless defined $only_dname && length $only_dname;

    my @res =
      grep { ( $_ =~ /^$only_dname/ ) || looks_like_file( 'file://' . $_ ) }
      @$links_arr;

    # looks_like_file('file://'.$_) = looks_like_relative_link
    return \@res;
}


sub drop_asset_links {
    my $links = shift;

    $links = remove_query_params($links);

    my @res;

    for my $link (@$links) {
        my ( $filename, $dirs, $suffix ) = fileparse( $link, @$Assets );
        push( @res, $link ) if ( $suffix eq '' );
    }

    return \@res;
}


sub drop_anchor_links {
    my $links_arr = shift;
    my @res = grep { $_ !~ /^#/ } @$links_arr;
    return \@res;
}


sub remove_query_params {
    my $links = shift;

    my @res;

    for my $link (@$links) {
        my $uri = URI->new($link);
        if ( $uri->query ) {
            my $l = length($link) - length( $uri->query ) - 1;
            my $new_str = substr $link, 0, $l;
            push( @res, $new_str );
        }
        else {
            push( @res, $link );
        }
    }

    return \@res;
}


sub find_all_links {
    my $html = shift;
    my $dom  = Mojo::DOM->new($html);
    return $dom->find('a')->map( attr => 'href' )->to_array;
}


sub find_links_by_text {
    my ( $html, $a_text, $upper_lower_case_flag ) = @_;
    my $dom = Mojo::DOM->new($html);    # Mojo::Collection of Mojo::DOM

# return $dom->find('a')->grep('text' => $a_text)->map(attr => 'href')->to_array;
    return $dom->find('a')->grep( sub { $_->text eq $a_text } )
      ->map( attr => 'href' )->to_array
      if !defined $upper_lower_case_flag;

    # TO-DO: fix lc/uc issue is case of non-ascii characters

# warn Dumper $crawler->extract_contact_links('Контакты');
# warn Dumper $crawler->extract_contact_links('контакты');
# warn Dumper $crawler->extract_contact_links('КОНТАКТЫ');

# https://stackoverflow.com/questions/3399129/compare-two-strings-regardless-of-case-size-in-perl
    use utf8;
    if ($upper_lower_case_flag) {
        return $dom->find('a')->grep(
            sub {
                lc $_->text eq lc $a_text;
            }
        )->map( attr => 'href' )->to_array;
    }

}


sub isin($$) {
    my ( $val, $array_ref ) = @_;

    return 0 unless $array_ref && defined $val;
    for my $v (@$array_ref) {
        return 1 if $v eq $val;
    }

    return 0;
}

1;

__END__