File Coverage

blib/lib/Mail/POP3/Folder/webscrape.pm

Criterion	Covered	Total	%
statement	175	188	93.0
branch	28	44	63.6
condition	3	6	50.0
subroutine	25	30	83.3
pod	19	19	100.0
total	250	287	87.1

package Mail::POP3::Folder::webscrape;

our @ISA = qw(Mail::POP3::Folder);

=head1 CONCEPTS

=over

=item a "listpage" is returned by the initial get_fill_submit which is parsed into:

=item a "listpage" is parsed into:

  { items => \@items, pageno => $pageno, num_pages => $num_pages,
    nextlink => $nextlink, }

=item an "item" is

  +{ id => $id, url => $url, }

=item the item url points to a "page" which is parsed into

=back

=head1 ADDITIONAL METHODS

=head2 list_parse

  ($text, $pageurl, $listre)

=head2 one_parse

Function:

  ($text, $scrapespec, $scrapepostpro)

=head2 parse_fill_submit

Function:

  ($cjar, $html, $real_url, $vars, $varnamechange)

=head2 parse_refresh

Parses out redirects done with C<< Refresh >> header.

=head2 redirect_cookie_loop

Gets web content, iterating through redirects while capturing cookies.

=cut

use strict;
use HTML::Entities;
use HTML::Form;
use HTTP::Cookies;
use HTTP::Request::Common;
use URI::URL;

my $formno = 0; # form_fill
# this is at top so $DEBUG in L::UA::RNOk is correct one!
our $DEBUG = 0; # form_fill, redirect_cookie_loop et al
my $req_count = 0; # redirect_cookie_loop et al
require Data::Dumper if $DEBUG; # form_fill
my $CRLF = "\015\012";

{
    # redirect_cookie_loop et al
    package LWP::UserAgent::RedirectNotOk;
    use base qw(LWP::UserAgent);
    sub redirect_ok { print "Redirecting...\n" if $DEBUG; 0 }
}

sub new {
    my (
        $class,
        $user_name,
        $password,
        $starturl, # from the config file
	$userfieldnames, # listref same order as values supplied in USER
        $otherfields, # hash fieldname => value
	$listre, # field => RE; fields: pageno, num_pages, nextlink, itemurls
	$itemre, # hash extractfield => RE to get it from "page"
	$itempostpro, # extractfield => sub returns pairS of field/value
	$itemurl2id, # sub taking URL, returns unique, persistent item ID
	$itemformat, # takes item hash, returns email message
	$messagesize,
    ) = @_;
    my $self = {};
    bless $self, $class;
    $user_name =~ s#\+# #g; # no spaces allowed in POP3, so "+" instead
    my @userfieldvalues = split /:/, $user_name;
    $self->{STARTURL} = $starturl;
    $self->{FIELDS} = { %$otherfields }; # copy just in case
    map {
	$self->{FIELDS}->{$userfieldnames->[$_]} = $userfieldvalues[$_];
    } 0..$#{$userfieldnames};
    $self->{LISTRE} = $listre;
    $self->{ITEMRE} = $itemre;
    $self->{ITEMPOSTPRO} = $itempostpro;
    $self->{ITEMURL2ID} = $itemurl2id;
    $self->{ITEMFORMAT} = $itemformat;
    $self->{MESSAGESIZE} = $messagesize;
    $self->{MESSAGECNT} = 0;
    $self->{MSG2OCTETS} = {};
    $self->{MSG2UIDL} = {};
    $self->{MSG2URL} = {};
    $self->{MSG2ITEMDATA} = {};
    $self->{TOTALOCTETS} = 0;
    $self->{DELETE} = {};
    $self->{DELMESSAGECNT} = 0;
    $self->{DELTOTALOCTETS} = 0;
    $self->{CJAR} = HTTP::Cookies->new;
    $self->{LIST_LOADED} = 0;
    $self;
}

sub lock_acquire {
    my $self = shift;
    1;
}

sub is_valid {
    my ($self, $msg) = @_;
    $self->_list_messages unless $self->{LIST_LOADED};
    $msg > 0 and $msg <= $self->{MESSAGECNT} and !$self->is_deleted($msg);
}

sub lock_release {
    my $self = shift;
    1;
}

sub uidl_list {
    my ($self, $output_fh) = @_;
    $self->_list_messages unless $self->{LIST_LOADED};
    for (1..$self->{MESSAGECNT}) {
        if (!$self->is_deleted($_)) {
            $output_fh->print("$_ $self->{MSG2UIDL}->{$_}$CRLF");
        }
    }
    $output_fh->print(".$CRLF");
}

# find relevant info about available messages
sub _list_messages {
    my $self = shift;
    my ($list_html, $list_url) = get_fill_submit(
        $self->{CJAR},
        $self->{STARTURL},
        $self->{FIELDS},
    );
    my $list_data = list_parse($list_html, $list_url, $self->{LISTRE});
    my @items;
    while (1) {
	my @theseitems = @{ $list_data->{itemurls} };
        push @items, @theseitems;
        last if $list_data->{pageno} >= $list_data->{num_pages};
#last if $list_data->{pageno} >= 1;
        ($list_html, $list_url) = redirect_cookie_loop(
            $self->{CJAR}, GET($list_data->{nextlink}),
        );
	$list_data = list_parse($list_html, $list_url, $self->{LISTRE});
    }
    my $cnt = 0;
    for my $item (@items) {
        $cnt++;
        my $octets = $self->{MESSAGESIZE};
	my $id = $self->{ITEMURL2ID}->($item);
        $self->{MSG2OCTETS}->{$cnt} = $octets;
        $self->{MSG2UIDL}->{$cnt} = $id;
        $self->{MSG2URL}->{$cnt} = $item;
        $self->{TOTALOCTETS} += $octets;
    }
    $self->{MESSAGECNT} = $cnt;
    $self->{LIST_LOADED} = 1;
}

sub _get_itemlines {
    my ($self, $message) = @_;
    my $data = $self->{MSG2ITEMDATA}->{$message} ||
	($self->{MSG2ITEMDATA}->{$message} = $self->_get_itemdata(
	    $self->{MSG2URL}->{$message},
	));
    my $text = $self->{ITEMFORMAT}->(
	$data,
	$self->{MSG2UIDL}->{$message},
    );
    # in case formatter wrongly adds \r - EMAIL::STUFFER I'M LOOKING AT YOU
    $text =~ s#\r$##gm;
    # should truncate it below message size if bigger
    $text .= (' ' x ($self->{MESSAGESIZE} - length($text) - 2)) . "\n";
    split /\r*\n/, $text;
}

sub _get_itemdata {
    my ($self, $url) = @_;
    my $request = GET($url);
#    $request->header('referer', $url);
    my ($one_html, $one_url) = redirect_cookie_loop($self->{CJAR}, $request);
    one_parse(
	$one_html,
	$self->{ITEMRE},
	$self->{ITEMPOSTPRO},
    );
}

# $message starts at 1
sub retrieve {
    my ($self, $message, $output_fh, $mbox_destined) = @_;
    $self->_list_messages unless $self->{LIST_LOADED};
    for ($self->_get_itemlines($message)) {
        # byte-stuff lines starting with .
        s/^\./\.\./o unless $mbox_destined;
        my $line = $mbox_destined ? "$_\n" : "$_$CRLF";
        $output_fh->print($line);
    }
}

# $message starts at 1
# returns number of bytes
sub top {
    my ($self, $message, $output_fh, $body_lines) = @_;
    $self->_list_messages unless $self->{LIST_LOADED};
    my $top_bytes = 0;
    my @lines = $self->_get_itemlines($message);
    my $linecount = 0;
    # print the headers
    while ($linecount < @lines) {
        $_ = $lines[$linecount++];
        my $out = "$_$CRLF";
        $output_fh->print($out);
        $top_bytes += length($out);
        last if /^\s*$/;
    }
    my $cnt = 0;
    # print the TOP arg number of body lines
    while ($linecount < @lines) {
        $_ = $lines[$linecount++];
        ++$cnt;
        last if $cnt > $body_lines;
        # byte-stuff lines starting with .
        s/^\./\.\./o;
        my $out = "$_$CRLF";
        $output_fh->print($out);
        $top_bytes += length($out);
    }
    $output_fh->print(".$CRLF");
    $top_bytes;
}

sub is_deleted {
    my ($self, $message) = @_;
    return $self->{DELETE}->{$message};
}

sub delete {
    my ($self, $message) = @_;
    $self->{DELETE}->{$message} = 1;
    $self->{DELMESSAGECNT} += 1;
    $self->{DELTOTALOCTETS} += $self->{MSG2OCTETS}->{$message};
}

sub flush_delete { }

sub reset {
    my $self = shift;
    $self->{DELETE} = {};
    $self->{DELMESSAGECNT} = 0;
    $self->{DELTOTALOCTETS} = 0;
}

sub octets {
    my ($self, $message) = @_;
    $self->_list_messages unless $self->{LIST_LOADED};
    if (defined $message) {
        $self->{MSG2OCTETS}->{$message};
    } else {
        $self->{TOTALOCTETS} - $self->{DELTOTALOCTETS};
    }
}

sub messages {
    my ($self) = @_;
    $self->_list_messages unless $self->{LIST_LOADED};
    $self->{MESSAGECNT} - $self->{DELMESSAGECNT};
}

sub uidl {
    my ($self, $message) = @_;
    $self->_list_messages unless $self->{LIST_LOADED};
    $self->{MSG2UIDL}->{$message};
}

sub get_fill_submit {
    my ($cjar, $url, $vars, $varnamechange) = @_;
    my ($html, $real_url) = redirect_cookie_loop($cjar, GET($url));
    parse_fill_submit($cjar, $html, $real_url, $vars, $varnamechange);
}

sub parse_fill_submit {
    my ($cjar, $html, $real_url, $vars, $varnamechange) = @_;
    my $form = HTML::Form->parse($html, $real_url);
    map {
	$form->value($_, $vars->{$_});
    } keys %$vars;
    $formno++;
    to_file("f$formno.wri", Data::Dumper::Dumper($varnamechange, $form)) if $DEBUG;
    map {
        my $input = $form->find_input(undef, undef, $_);
        $input->name($varnamechange->{$_});
        local $^W = 0; # don't want to hear about "readonly"
        $input->value('') unless defined $input->value;
    } keys %$varnamechange
        if $varnamechange;
    to_file("f$formno-after.wri", Data::Dumper::Dumper($varnamechange, $form)) if $DEBUG;
    my $form_html;
    ($form_html, $real_url) = redirect_cookie_loop(
        $cjar,
        $form->click,
    );
    ($form_html, $real_url);
}

# special case - nextlink value will be absolutised
# special case - itemurls value will be listref of absolutised values
sub list_parse {
    my ($text, $pageurl, $listre) = @_;
    my %list;
    for my $key (keys %$listre) {
        if ($key eq 'itemurls') {
            my @hits = map {
                URI::URL->new($_, $pageurl)->abs->as_string;
            } $text =~ m#$listre->{$key}#gsi;
            $list{$key} = \@hits;
        } else {
            my ($match) = $text =~ m#$listre->{$key}#si;
            $list{$key} = decode_entities($match);
        }
    }
    $list{nextlink} = URI::URL->new($list{nextlink}, $pageurl)->abs->as_string;
    \%list;
}

sub one_parse {
    my ($text, $scrapespec, $scrapepostpro) = @_;
    my %item;
    for my $key (keys %$scrapespec) {
        my ($match) = $text =~ m#$scrapespec->{$key}#si;
        $match = '' unless defined $match;
        $item{$key} = decode_entities($match);
    }
    # postpro - sub that returns list of key => value
    #   might be more than one pair
    for my $key (keys %$scrapepostpro) {
        my %ret = $scrapepostpro->{$key}->($key, $item{$key});
        map { $item{$_} = $ret{$_} } keys %ret;
    }
    \%item;
}

# modify input $cjar, return also a $response
sub redirect_cookie_loop {
    my ($cjar, $request) = @_;
    # otherwise cookies set during redirects get lost...
    my $ua = LWP::UserAgent::RedirectNotOk->new;
    $ua->agent('Mozilla/4.0 (compatible; MSIE 5.5; Windows NT 5.0)');
    my $response;
    while (1) {
        $req_count++;
        $cjar->add_cookie_header($request);
        print "req $req_count: ", $request->uri, "\n" if $DEBUG;
        to_file("r${req_count}req.wri", $request->as_string) if $DEBUG;
        $response = $ua->request($request);
        to_file("r${req_count}resp.wri", $response->as_string) if $DEBUG;
        unless ($response->is_success or $response->is_redirect) {
            my $text = $response->error_as_HTML;
            $text =~ s/\s+$//;
            die "Request: ".$request->as_string."\nFailed: $text\n";
        }
        $cjar->extract_cookies($response);
        my $new_loc;
        if ($response->is_redirect) {
#print "302\n";
            $new_loc = $response->header('location');
        } elsif ($response->header('refresh')) {
#print "refresh\n";
            $new_loc = parse_refresh($response->header('refresh'));
        } else {
            last;
        }
#use Data::Dumper; print Dumper($response);
        $request = GET(URI::URL->new($new_loc, $request->uri)->abs->as_string);
    }
    ($response->content, $response->request->uri->as_string);
}

sub parse_refresh {
    my $header_val = shift;
    my ($url) = $header_val =~ m#url=['"]?([^'"\s]*)#i;
    $url;
}

1;

__END__