File Coverage

blib/lib/Email/Extractor/Utils.pm

Criterion	Covered	Total	%
statement	102	106	96.2
branch	25	30	83.3
condition	4	6	66.6
subroutine	26	26	100.0
pod	13	13	100.0
total	170	181	93.9

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


package Email::Extractor::Utils;
$Email::Extractor::Utils::VERSION = '0.01';
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 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
);
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'
];


sub load_addr_to_str {
    my $addr = shift;

    eval {

        if ( looks_like_url($addr) ) {

            say "$addr: is url" if ($Verbose);
            my $ua   = LWP::UserAgent->new;
            my $resp = $ua->get($addr);       # HTTP::Response
            return $resp->content;

        }
        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 ) {

        # warn "$1 $2 $3 $4 $5 $6 $7 $8";
        return $7 if defined $7;
        return $1 if defined $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 ) = @_;
    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;
}

1;

__END__