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


line stmt bran cond sub pod time code
1             package Mail::POP3::Folder::webscrape;
2              
3             our @ISA = qw(Mail::POP3::Folder);
4              
5             =head1 CONCEPTS
6              
7             =over
8              
9             =item a "listpage" is returned by the initial get_fill_submit which is parsed into:
10              
11             =item a "listpage" is parsed into:
12              
13             { items => \@items, pageno => $pageno, num_pages => $num_pages,
14             nextlink => $nextlink, }
15              
16             =item an "item" is
17              
18             +{ id => $id, url => $url, }
19              
20             =item the item url points to a "page" which is parsed into
21              
22             =back
23              
24             =head1 ADDITIONAL METHODS
25              
26             =head2 list_parse
27              
28             ($text, $pageurl, $listre)
29              
30             =head2 one_parse
31              
32             Function:
33              
34             ($text, $scrapespec, $scrapepostpro)
35              
36             =head2 parse_fill_submit
37              
38             Function:
39              
40             ($cjar, $html, $real_url, $vars, $varnamechange)
41              
42             =head2 parse_refresh
43              
44             Parses out redirects done with C<< Refresh >> header.
45              
46             =head2 redirect_cookie_loop
47              
48             Gets web content, iterating through redirects while capturing cookies.
49              
50             =cut
51              
52 1     1   1068 use strict;
  1         2  
  1         26  
53 1     1   290 use HTML::Entities;
  1         4442  
  1         83  
54 1     1   380 use HTML::Form;
  1         8347  
  1         35  
55 1     1   401 use HTTP::Cookies;
  1         7778  
  1         32  
56 1     1   300 use HTTP::Request::Common;
  1         14414  
  1         73  
57 1     1   330 use URI::URL;
  1         2138  
  1         93  
58              
59             my $formno = 0; # form_fill
60             # this is at top so $DEBUG in L::UA::RNOk is correct one!
61             our $DEBUG = 0; # form_fill, redirect_cookie_loop et al
62             my $req_count = 0; # redirect_cookie_loop et al
63             require Data::Dumper if $DEBUG; # form_fill
64             my $CRLF = "\015\012";
65              
66             {
67             # redirect_cookie_loop et al
68             package LWP::UserAgent::RedirectNotOk;
69 1     1   7 use base qw(LWP::UserAgent);
  1         2  
  1         523  
70 0 0   0   0 sub redirect_ok { print "Redirecting...\n" if $DEBUG; 0 }
  0         0  
71             }
72              
73             sub new {
74             my (
75 1     1 1 876 $class,
76             $user_name,
77             $password,
78             $starturl, # from the config file
79             $userfieldnames, # listref same order as values supplied in USER
80             $otherfields, # hash fieldname => value
81             $listre, # field => RE; fields: pageno, num_pages, nextlink, itemurls
82             $itemre, # hash extractfield => RE to get it from "page"
83             $itempostpro, # extractfield => sub returns pairS of field/value
84             $itemurl2id, # sub taking URL, returns unique, persistent item ID
85             $itemformat, # takes item hash, returns email message
86             $messagesize,
87             ) = @_;
88 1         6 my $self = {};
89 1         4 bless $self, $class;
90 1         5 $user_name =~ s#\+# #g; # no spaces allowed in POP3, so "+" instead
91 1         7 my @userfieldvalues = split /:/, $user_name;
92 1         9 $self->{STARTURL} = $starturl;
93 1         9 $self->{FIELDS} = { %$otherfields }; # copy just in case
94             map {
95 3         16 $self->{FIELDS}->{$userfieldnames->[$_]} = $userfieldvalues[$_];
96 1         5 } 0..$#{$userfieldnames};
  1         6  
97 1         5 $self->{LISTRE} = $listre;
98 1         5 $self->{ITEMRE} = $itemre;
99 1         4 $self->{ITEMPOSTPRO} = $itempostpro;
100 1         3 $self->{ITEMURL2ID} = $itemurl2id;
101 1         5 $self->{ITEMFORMAT} = $itemformat;
102 1         4 $self->{MESSAGESIZE} = $messagesize;
103 1         4 $self->{MESSAGECNT} = 0;
104 1         4 $self->{MSG2OCTETS} = {};
105 1         4 $self->{MSG2UIDL} = {};
106 1         4 $self->{MSG2URL} = {};
107 1         5 $self->{MSG2ITEMDATA} = {};
108 1         3 $self->{TOTALOCTETS} = 0;
109 1         6 $self->{DELETE} = {};
110 1         4 $self->{DELMESSAGECNT} = 0;
111 1         6 $self->{DELTOTALOCTETS} = 0;
112 1         10 $self->{CJAR} = HTTP::Cookies->new;
113 1         36 $self->{LIST_LOADED} = 0;
114 1         75 $self;
115             }
116              
117             sub lock_acquire {
118 0     0 1 0 my $self = shift;
119 0         0 1;
120             }
121              
122             sub is_valid {
123 4     4 1 23 my ($self, $msg) = @_;
124 4 50       14 $self->_list_messages unless $self->{LIST_LOADED};
125 4 50 33     28 $msg > 0 and $msg <= $self->{MESSAGECNT} and !$self->is_deleted($msg);
126             }
127              
128             sub lock_release {
129 0     0 1 0 my $self = shift;
130 0         0 1;
131             }
132              
133             sub uidl_list {
134 2     2 1 2514 my ($self, $output_fh) = @_;
135 2 100       20 $self->_list_messages unless $self->{LIST_LOADED};
136 2         11 for (1..$self->{MESSAGECNT}) {
137 6 100       66 if (!$self->is_deleted($_)) {
138 5         47 $output_fh->print("$_ $self->{MSG2UIDL}->{$_}$CRLF");
139             }
140             }
141 2         26 $output_fh->print(".$CRLF");
142             }
143              
144             # find relevant info about available messages
145             sub _list_messages {
146 1     1   4 my $self = shift;
147             my ($list_html, $list_url) = get_fill_submit(
148             $self->{CJAR},
149             $self->{STARTURL},
150             $self->{FIELDS},
151 1         11 );
152 1         10 my $list_data = list_parse($list_html, $list_url, $self->{LISTRE});
153 1         34 my @items;
154 1         3 while (1) {
155 2         38 my @theseitems = @{ $list_data->{itemurls} };
  2         10  
156 2         7 push @items, @theseitems;
157 2 100       12 last if $list_data->{pageno} >= $list_data->{num_pages};
158             #last if $list_data->{pageno} >= 1;
159             ($list_html, $list_url) = redirect_cookie_loop(
160 1         8 $self->{CJAR}, GET($list_data->{nextlink}),
161             );
162 1         232 $list_data = list_parse($list_html, $list_url, $self->{LISTRE});
163             }
164 1         5 my $cnt = 0;
165 1         5 for my $item (@items) {
166 3         9 $cnt++;
167 3         9 my $octets = $self->{MESSAGESIZE};
168 3         13 my $id = $self->{ITEMURL2ID}->($item);
169 3         66 $self->{MSG2OCTETS}->{$cnt} = $octets;
170 3         10 $self->{MSG2UIDL}->{$cnt} = $id;
171 3         12 $self->{MSG2URL}->{$cnt} = $item;
172 3         9 $self->{TOTALOCTETS} += $octets;
173             }
174 1         4 $self->{MESSAGECNT} = $cnt;
175 1         7 $self->{LIST_LOADED} = 1;
176             }
177              
178             sub _get_itemlines {
179 2     2   9 my ($self, $message) = @_;
180             my $data = $self->{MSG2ITEMDATA}->{$message} ||
181             ($self->{MSG2ITEMDATA}->{$message} = $self->_get_itemdata(
182 2   66     19 $self->{MSG2URL}->{$message},
183             ));
184             my $text = $self->{ITEMFORMAT}->(
185             $data,
186 2         14 $self->{MSG2UIDL}->{$message},
187             );
188             # in case formatter wrongly adds \r - EMAIL::STUFFER I'M LOOKING AT YOU
189 2         5984 $text =~ s#\r$##gm;
190             # should truncate it below message size if bigger
191 2         23 $text .= (' ' x ($self->{MESSAGESIZE} - length($text) - 2)) . "\n";
192 2         66 split /\r*\n/, $text;
193             }
194              
195             sub _get_itemdata {
196 1     1   5 my ($self, $url) = @_;
197 1         7 my $request = GET($url);
198             # $request->header('referer', $url);
199 1         229 my ($one_html, $one_url) = redirect_cookie_loop($self->{CJAR}, $request);
200             one_parse(
201             $one_html,
202             $self->{ITEMRE},
203             $self->{ITEMPOSTPRO},
204 1         38 );
205             }
206              
207             # $message starts at 1
208             sub retrieve {
209 1     1 1 1935 my ($self, $message, $output_fh, $mbox_destined) = @_;
210 1 50       8 $self->_list_messages unless $self->{LIST_LOADED};
211 1         7 for ($self->_get_itemlines($message)) {
212             # byte-stuff lines starting with .
213 27 50       186 s/^\./\.\./o unless $mbox_destined;
214 27 50       66 my $line = $mbox_destined ? "$_\n" : "$_$CRLF";
215 27         67 $output_fh->print($line);
216             }
217             }
218              
219             # $message starts at 1
220             # returns number of bytes
221             sub top {
222 1     1 1 688 my ($self, $message, $output_fh, $body_lines) = @_;
223 1 50       8 $self->_list_messages unless $self->{LIST_LOADED};
224 1         5 my $top_bytes = 0;
225 1         6 my @lines = $self->_get_itemlines($message);
226 1         4 my $linecount = 0;
227             # print the headers
228 1         7 while ($linecount < @lines) {
229 9         29 $_ = $lines[$linecount++];
230 9         28 my $out = "$_$CRLF";
231 9         41 $output_fh->print($out);
232 9         87 $top_bytes += length($out);
233 9 100       50 last if /^\s*$/;
234             }
235 1         5 my $cnt = 0;
236             # print the TOP arg number of body lines
237 1         6 while ($linecount < @lines) {
238 6         18 $_ = $lines[$linecount++];
239 6         13 ++$cnt;
240 6 100       18 last if $cnt > $body_lines;
241             # byte-stuff lines starting with .
242 5         10 s/^\./\.\./o;
243 5         20 my $out = "$_$CRLF";
244 5         22 $output_fh->print($out);
245 5         46 $top_bytes += length($out);
246             }
247 1         8 $output_fh->print(".$CRLF");
248 1         12 $top_bytes;
249             }
250              
251             sub is_deleted {
252 12     12 1 35 my ($self, $message) = @_;
253 12         58 return $self->{DELETE}->{$message};
254             }
255              
256             sub delete {
257 2     2 1 8 my ($self, $message) = @_;
258 2         8 $self->{DELETE}->{$message} = 1;
259 2         7 $self->{DELMESSAGECNT} += 1;
260 2         8 $self->{DELTOTALOCTETS} += $self->{MSG2OCTETS}->{$message};
261             }
262              
263       0 1   sub flush_delete { }
264              
265             sub reset {
266 1     1 1 4 my $self = shift;
267 1         7 $self->{DELETE} = {};
268 1         5 $self->{DELMESSAGECNT} = 0;
269 1         4 $self->{DELTOTALOCTETS} = 0;
270             }
271              
272             sub octets {
273 3     3 1 1052 my ($self, $message) = @_;
274 3 50       11 $self->_list_messages unless $self->{LIST_LOADED};
275 3 100       12 if (defined $message) {
276 1         11 $self->{MSG2OCTETS}->{$message};
277             } else {
278 2         20 $self->{TOTALOCTETS} - $self->{DELTOTALOCTETS};
279             }
280             }
281              
282             sub messages {
283 2     2 1 230 my ($self) = @_;
284 2 50       10 $self->_list_messages unless $self->{LIST_LOADED};
285 2         9 $self->{MESSAGECNT} - $self->{DELMESSAGECNT};
286             }
287              
288             sub uidl {
289 1     1 1 5 my ($self, $message) = @_;
290 1 50       7 $self->_list_messages unless $self->{LIST_LOADED};
291 1         9 $self->{MSG2UIDL}->{$message};
292             }
293              
294             sub get_fill_submit {
295 1     1 1 6 my ($cjar, $url, $vars, $varnamechange) = @_;
296 1         8 my ($html, $real_url) = redirect_cookie_loop($cjar, GET($url));
297 1         8902 parse_fill_submit($cjar, $html, $real_url, $vars, $varnamechange);
298             }
299              
300             sub parse_fill_submit {
301 1     1 1 6 my ($cjar, $html, $real_url, $vars, $varnamechange) = @_;
302 1         18 my $form = HTML::Form->parse($html, $real_url);
303             map {
304 1         7539 $form->value($_, $vars->{$_});
  7         899  
305             } keys %$vars;
306 1         184 $formno++;
307 1 50       7 to_file("f$formno.wri", Data::Dumper::Dumper($varnamechange, $form)) if $DEBUG;
308             map {
309 1 50       6 my $input = $form->find_input(undef, undef, $_);
  0         0  
310 0         0 $input->name($varnamechange->{$_});
311 0         0 local $^W = 0; # don't want to hear about "readonly"
312 0 0       0 $input->value('') unless defined $input->value;
313             } keys %$varnamechange
314             if $varnamechange;
315 1 50       5 to_file("f$formno-after.wri", Data::Dumper::Dumper($varnamechange, $form)) if $DEBUG;
316 1         4 my $form_html;
317 1         8 ($form_html, $real_url) = redirect_cookie_loop(
318             $cjar,
319             $form->click,
320             );
321 1         2700 ($form_html, $real_url);
322             }
323              
324             # special case - nextlink value will be absolutised
325             # special case - itemurls value will be listref of absolutised values
326             sub list_parse {
327 2     2 1 7 my ($text, $pageurl, $listre) = @_;
328 2         5 my %list;
329 2         12 for my $key (keys %$listre) {
330 8 100       31 if ($key eq 'itemurls') {
331             my @hits = map {
332 2         66 URI::URL->new($_, $pageurl)->abs->as_string;
  3         1108  
333             } $text =~ m#$listre->{$key}#gsi;
334 2         1854 $list{$key} = \@hits;
335             } else {
336 6         234 my ($match) = $text =~ m#$listre->{$key}#si;
337 6         70 $list{$key} = decode_entities($match);
338             }
339             }
340 2         14 $list{nextlink} = URI::URL->new($list{nextlink}, $pageurl)->abs->as_string;
341 2         1904 \%list;
342             }
343              
344             sub one_parse {
345 1     1 1 5 my ($text, $scrapespec, $scrapepostpro) = @_;
346 1         3 my %item;
347 1         12 for my $key (keys %$scrapespec) {
348 15         700 my ($match) = $text =~ m#$scrapespec->{$key}#si;
349 15 100       83 $match = '' unless defined $match;
350 15         107 $item{$key} = decode_entities($match);
351             }
352             # postpro - sub that returns list of key => value
353             # might be more than one pair
354 1         10 for my $key (keys %$scrapepostpro) {
355 4         20 my %ret = $scrapepostpro->{$key}->($key, $item{$key});
356 4         51 map { $item{$_} = $ret{$_} } keys %ret;
  4         18  
357             }
358 1         15 \%item;
359             }
360              
361             # modify input $cjar, return also a $response
362             sub redirect_cookie_loop {
363             my ($cjar, $request) = @_;
364             # otherwise cookies set during redirects get lost...
365             my $ua = LWP::UserAgent::RedirectNotOk->new;
366             $ua->agent('Mozilla/4.0 (compatible; MSIE 5.5; Windows NT 5.0)');
367             my $response;
368             while (1) {
369             $req_count++;
370             $cjar->add_cookie_header($request);
371             print "req $req_count: ", $request->uri, "\n" if $DEBUG;
372             to_file("r${req_count}req.wri", $request->as_string) if $DEBUG;
373             $response = $ua->request($request);
374             to_file("r${req_count}resp.wri", $response->as_string) if $DEBUG;
375             unless ($response->is_success or $response->is_redirect) {
376             my $text = $response->error_as_HTML;
377             $text =~ s/\s+$//;
378             die "Request: ".$request->as_string."\nFailed: $text\n";
379             }
380             $cjar->extract_cookies($response);
381             my $new_loc;
382             if ($response->is_redirect) {
383             #print "302\n";
384             $new_loc = $response->header('location');
385             } elsif ($response->header('refresh')) {
386             #print "refresh\n";
387             $new_loc = parse_refresh($response->header('refresh'));
388             } else {
389             last;
390             }
391             #use Data::Dumper; print Dumper($response);
392             $request = GET(URI::URL->new($new_loc, $request->uri)->abs->as_string);
393             }
394             ($response->content, $response->request->uri->as_string);
395             }
396              
397             sub parse_refresh {
398 0     0 1   my $header_val = shift;
399 0           my ($url) = $header_val =~ m#url=['"]?([^'"\s]*)#i;
400 0           $url;
401             }
402              
403             1;
404              
405             __END__