File Coverage

blib/lib/WWW/Mechanize/Shell.pm
Criterion Covered Total %
statement 534 676 78.9
branch 164 262 62.6
condition 35 66 53.0
subroutine 89 99 89.9
pod 13 72 18.0
total 835 1175 71.0


line stmt bran cond sub pod time code
1             package WWW::Mechanize::Shell;
2              
3 33     32   923119 use strict;
  32         111  
  32         873  
4 32     32   186 use Carp;
  32         64  
  32         1747  
5 32     32   21946 use WWW::Mechanize;
  33         4708274  
  32         1304  
6 32     32   14679 use WWW::Mechanize::FormFiller;
  33         43757  
  33         1019  
7 32     32   13555 use HTTP::Cookies;
  33         212776  
  33         1091  
8 33     32   683 use parent qw( Term::Shell );
  33         77  
  33         1361  
9 33     32   589357 use Exporter 'import';
  33         220  
  32         1036  
10 32     32   9659 use FindBin;
  32         27005  
  32         1424  
11 32     32   10471 use File::Temp qw(tempfile);
  32         165488  
  32         1696  
12 32     32   9291 use URI::URL;
  32         69472  
  32         1494  
13 32     32   12197 use Hook::LexWrap;
  32         39673  
  32         158  
14 32     32   12103 use HTML::Display qw();
  32         24847  
  32         761  
15 32     32   13574 use HTML::TokeParser::Simple;
  32         254870  
  32         979  
16 32     32   229 use B::Deparse;
  32         61  
  32         19622  
17              
18             our $VERSION = '0.62';
19             our @EXPORT = qw( &shell );
20              
21             =head1 NAME
22              
23             WWW::Mechanize::Shell - An interactive shell for WWW::Mechanize
24              
25             =head1 SYNOPSIS
26              
27             From the command line as
28              
29             perl -MWWW::Mechanize::Shell -eshell
30              
31             or alternatively as a custom shell program via :
32              
33             =for example begin
34              
35             #!/usr/bin/perl -w
36             use strict;
37             use WWW::Mechanize::Shell;
38              
39             my $shell = WWW::Mechanize::Shell->new("shell");
40              
41             if (@ARGV) {
42             $shell->source_file( @ARGV );
43             } else {
44             $shell->cmdloop;
45             };
46              
47             =for example end
48              
49             =for example_testing
50             BEGIN {
51             require WWW::Mechanize::Shell;
52             $ENV{PERL_RL} = 0;
53             $ENV{COLUMNS} = '80';
54             $ENV{LINES} = '24';
55             };
56             BEGIN {
57             no warnings 'once';
58             no warnings 'redefine';
59             *WWW::Mechanize::Shell::cmdloop = sub {};
60             *WWW::Mechanize::Shell::display_user_warning = sub {};
61             *WWW::Mechanize::Shell::source_file = sub {};
62             };
63             isa_ok( $shell, "WWW::Mechanize::Shell" );
64              
65             =head1 DESCRIPTION
66              
67             This module implements a www-like shell above WWW::Mechanize
68             and also has the capability to output crude Perl code that recreates
69             the recorded session. Its main use is as an interactive starting point
70             for automating a session through WWW::Mechanize.
71              
72             The cookie support is there, but no cookies are read from your existing
73             browser sessions. See L on how to implement reading/writing
74             your current browsers cookies.
75              
76             =head2 Cnew %ARGS>
77              
78             This is the constructor for a new shell instance. Some of the options
79             can be passed to the constructor as parameters.
80              
81             By default, a file C<.mechanizerc> (respectively C under Windows)
82             in the users home directory is executed before the interactive shell loop is
83             entered. This can be used to set some defaults. If you want to supply a different
84             filename for the rcfile, the C parameter can be passed to the constructor :
85              
86             rcfile => '.myapprc',
87              
88             =over 4
89              
90             =item B
91              
92             my $shell = WWW::Mechanize::Shell->new(
93             agent => WWW::Mechanize::Chrome->new(),
94             );
95              
96             Pass in a premade custom user agent. This object must be compatible to
97             L. Use this feature from the command line as
98              
99             perl -Ilib -MWWW::Mechanize::Chrome \
100             -MWWW::Mechanize::Shell \
101             -e"shell(agent => WWW::Mechanize::Chrome->new())"
102              
103             =back
104              
105             =cut
106              
107             sub init {
108 84     84 0 13715 my ($self) = @_;
109 84         271 my ($name,%args) = @{$self->{API}{args}};
  84         918  
110              
111 84         544 $self->{agent} = $args{ agent };
112 84 50       669 if( ! $self->agent ) {
113 84   50     1056 my $class = $args{ agent_class } || 'WWW::Mechanize';
114 84   50     687 my $args = $args{ agent_args } || [];
115 84         1640 $self->{agent} = $class->new( @$args );
116             };
117              
118 84         324790 $self->{formfiller} = WWW::Mechanize::FormFiller->new(default => [ Ask => $self ]);
119              
120 84         912 $self->{history} = [];
121              
122             $self->{options} = {
123             autosync => 0,
124             warnings => (exists $args{warnings} ? $args{warnings} : 1),
125             autorestart => 0,
126 84 100       1344 watchfiles => (exists $args{watchfiles} ? $args{watchfiles} : 1),
    50          
127             cookiefile => 'cookies.txt',
128             dumprequests => 0,
129             dumpresponses => 0,
130             verbose => 0,
131             };
132             # Install the request dumper :
133             $self->{request_wrapper} = wrap 'LWP::UserAgent::request',
134             #pre => sub { printf STDERR "Dumping? %s\n",$self->option("dumprequests"); $self->request_dumper($_[1]) if $self->option("dumprequests"); },
135 146 100   146   155752 pre => sub { $self->request_dumper($_[1]) if $self->option("dumprequests"); },
136             post => sub {
137 145 100   145   1180516 $self->response_dumper($_[-1]) if $self->option("dumpresponses");
138 84         1928 };
139              
140             $self->{redirect_ok_wrapper} = wrap 'WWW::Mechanize::redirect_ok',
141             post => sub {
142 2 50   2   6694 return unless $_[1];
143 1         5 $self->status( "\nRedirecting to ".$_[1]->uri."\n" );
144 1         1 $_[-1]
145 84         13537 };
146              
147             # Load the proxy settings from the environment
148 84 50       4624 $self->agent->env_proxy()
149             if $self->agent->can('env_proxy');
150              
151             # Read our .rc file :
152             # I could use File::Homedir, but the docs claim it dosen't work on Win32. Maybe
153             # I should just release a patch for File::Homedir then... Not now.
154 83         25214 my $sourcefile;
155 83 100       328 if (exists $args{rcfile}) {
156 80         275 $sourcefile = delete $args{rcfile};
157             } else {
158 3 50 0     2360 my $userhome = $^O =~ /win32/i ? $ENV{'USERPROFILE'} || $ENV{'HOME'} : ((getpwuid($<))[7]);
159 3 50       88 $sourcefile = "$userhome/.mechanizerc"
160             if -f "$userhome/.mechanizerc";
161             };
162 83 100       422 $self->option('cookiefile', $args{cookiefile}) if (exists $args{cookiefile});
163 83 100       335 $self->source_file($sourcefile) if defined $sourcefile;
164 83         259 $self->{browser} = undef;
165              
166             # Keep track of the files we consist of, to enable automatic reloading
167 83         257 $self->{files} = undef;
168 83 50       441 if ($self->option('watchfiles')) {
169 83         193 eval {
170 83 50 33     2936 my @files = grep { -f && -r && $_ ne '-e' } values %INC;
  18245         497839  
171 83         523 local $, = ",";
172 83         12183 require File::Modified;
173 0         0 $self->{files} = File::Modified->new(files=>[@files]);
174             };
175 83 50       1612 $self->display_user_warning( "Module File::Modified not found. Automatic reloading disabled.\n" )
176             if ($@);
177             };
178             };
179              
180             =head2 C<$shell-Erelease_agent>
181              
182             Since the shell stores a reference back to itself within the
183             WWW::Mechanize instance, it is necessary to break this
184             circular reference. This method does this.
185              
186             =cut
187              
188             sub release_agent {
189 44     45 1 2133 my ($self) = @_;
190 32     32   260 use Data::Dumper;
  32         76  
  32         213861  
191 44         581 warn Dumper $self;
192 44         102396 undef $self->{request_wrapper};
193 44         247 undef $self->{redirect_ok_wrapper};
194 44         2495 $self->{agent} = undef;
195             };
196              
197             =head2 C<$shell-Esource_file FILENAME>
198              
199             The C method executes the lines of FILENAME
200             as if they were typed in.
201              
202             $shell->source_file( $filename );
203              
204             =cut
205              
206             sub source_file {
207 3     4 1 7 my ($self,$filename) = @_;
208 3         5 local $_; # just to be on the safe side that we don't clobber outside users of $_
209 3         11 local *F;
210 3 100       166 open F, "< $filename"
211             or die "Couldn't open '$filename' : $!\n";
212 1         40 while () {
213 2         10 $self->cmd($_);
214             warn "cmd: $_"
215 2 50       52 if $self->{options}->{verbose};
216             };
217 1         13 close F;
218             };
219              
220             sub add_history {
221 277     278 0 827 my ($self,@code) = @_;
222 277         446 push @{$self->{history}},[$self->line,join "",@code];
  277         1099  
223             };
224              
225             =head2 C<$shell-Edisplay_user_warning>
226              
227             All user warnings are routed through this routine
228             so they can be rerouted / disabled easily.
229              
230             =cut
231              
232             sub display_user_warning {
233 86     87 1 369 my ($self,@message) = @_;
234              
235 86 100       317 warn @message
236             if $self->option('warnings');
237             };
238              
239             =head2 C<$shell-Eprint_paged LIST>
240              
241             Prints the text in LIST using C<$ENV{PAGER}>. If C<$ENV{PAGER}>
242             is empty, prints directly to C. Most of this routine
243             comes from the C utility.
244              
245             =cut
246              
247             sub print_paged {
248 32     32 1 109 my $self = shift;
249              
250 32 50 33     350 if ($ENV{PAGER} and -t STDOUT) {
251 0         0 my ($fh,$filename) = tempfile();
252 0         0 print $fh $_ for @_;
253 0         0 close $fh;
254              
255 0         0 my @pagers = ($ENV{PAGER},qq{"$^X" -p});
256 0         0 foreach my $pager (@pagers) {
257 0 0       0 if ($^O eq 'VMS') {
258 0 0       0 last if system("$pager $filename") == 0; # quoting prevents logical expansion
259             } else {
260 0 0       0 last if system(qq{$pager "$filename"}) == 0;
261             }
262             };
263 0 0       0 unlink $filename
264             or $self->display_user_warning("Couldn't unlink tempfile $filename : $!\n");
265             } else {
266 32         536 print $_ for @_;
267             };
268             };
269              
270 976     976 1 142022 sub agent { $_[0]->{agent}; };
271              
272             sub option {
273 670     670 0 12834 my ($self,$option,$value) = @_;
274 670 100       2033 if (exists $self->{options}->{$option}) {
275 667         1229 my $result = $self->{options}->{$option};
276 667 100       1686 if (scalar @_ == 3) {
277 73         196 $self->{options}->{$option} = $value;
278             };
279 667         2779 $result;
280             } else {
281 3         17 Carp::carp "Unknown option '$option'";
282 3         14 undef;
283             };
284             };
285              
286             sub restart_shell {
287 0 0   0 0 0 if ($0 ne '-e') {
288 0         0 print "Restarting $0\n";
289 0         0 exec $^X, $0, @ARGV;
290             };
291             };
292              
293             sub precmd {
294 338     338 0 937376 my $self = shift @_;
295             # We want to restart when any module was changed
296 338 50 33     1264 if ($self->{files} and $self->{files}->changed()) {
297 0         0 print "One or more of the base files were changed\n";
298 0 0       0 $self->restart_shell if ($self->option('autorestart'));
299             };
300              
301 338         1233 $self->SUPER::precmd(@_);
302             };
303              
304             sub browser {
305 1     1 0 980 my ($self) = @_;
306 1   33     38 $self->{browser} ||= HTML::Display->new();
307 1         3338 $self->{browser};
308             };
309              
310             sub sync_browser {
311 2     2 0 10 my ($self) = @_;
312              
313             # We only can display html if we have any :
314 2 50       8 return unless $self->agent->res;
315              
316             # Prepare the HTML for local display :
317 0         0 my $unclean = $self->agent->content;
318 0         0 my $html = '';
319              
320             # ugly fix:
321             # strip all target='_blank' attributes from the HTML:
322 0         0 my $p = HTML::TokeParser::Simple->new(\$unclean);
323 0         0 while (my $token = $p->get_token) {
324 0 0       0 $token->delete_attr('target')
325             if $token->is_start_tag;
326 0         0 $html .= $token->as_is;
327             };
328              
329 0         0 my $location = $self->agent->{uri};
330 0         0 my $browser = $self->browser;
331 0         0 $browser->display( html => $html, location => $location );
332             };
333              
334             sub prompt_str {
335 1     1 0 24 my $self = shift;
336 1 50       2 if ($self->agent->response) {
337 0   0     0 return ($self->agent->uri || "") . ">"
338             } else {
339 1         13 return "(no url)>"
340             };
341             };
342              
343 0     0 0 0 sub request_dumper { print $_[1]->as_string };
344             sub response_dumper {
345 1 50   1 0 6 if (ref $_[1] eq 'ARRAY') {
346 1         11 print $_[1]->[0]->as_string;
347             } else {
348 0         0 print $_[1]->as_string;
349             }
350             };
351              
352             sub re_or_string {
353 62     62 0 233 my ($self,$arg) = @_;
354 62 100       441 if ($arg =~ m!^/(.*)/([imsx]*)$!) {
355 11         92 my ($re,$mode) = ($1,$2);
356 11         96 $re =~ s!([^\\])/!$1\\/!g;
357 11         980 $arg = eval "qr/$re/$mode";
358             };
359 62         202 $arg;
360             };
361              
362             =head2 C<< $shell->link_text LINK >>
363              
364             Returns a meaningful text from a WWW::Mechanize::Link object. This is (in order of
365             precedence) :
366              
367             $link->text
368             $link->name
369             $link->url
370              
371             =cut
372              
373             sub link_text {
374 2     2 1 6 my ($self,$link) = @_;
375 2         7 my $result;
376 2         9 for (qw( text name url )) {
377 2 50       8 $result = $link->$_ and last;
378             };
379 2         46 $result;
380             };
381              
382             =head2 C<$shell-Ehistory>
383              
384             Returns the (relevant) shell history, that is, all commands
385             that were not solely for the information of the user. The
386             lines are returned as a list.
387              
388             print join "\n", $shell->history;
389              
390             =cut
391              
392             sub history {
393 3     3 1 25 my ($self) = @_;
394 3         5 map { $_->[0] } @{$self->{history}}
  2         20  
  3         9  
395             };
396              
397             =head2 C<$shell-Escript>
398              
399             Returns the shell history as a Perl program. The
400             lines are returned as a list. The lines do not have
401             a one-by-one correspondence to the lines in the history.
402              
403             print join "\n", $shell->script;
404              
405             =cut
406              
407             sub script {
408 48     48 1 401502 my ($self,$prefix) = @_;
409 48   100     658 $prefix ||= "";
410              
411 48         421 my @result = sprintf <<'HEADER', $^X;
412             #!%s -w
413             use strict;
414             use WWW::Mechanize;
415             use WWW::Mechanize::FormFiller;
416             use URI::URL;
417              
418             my $agent = WWW::Mechanize->new( autocheck => 1 );
419             my $formfiller = WWW::Mechanize::FormFiller->new();
420             $agent->env_proxy();
421             HEADER
422              
423 48         128 push @result, map { my $x = $_->[1]; $x =~ s/^/$prefix/mg; $x } @{$self->{history}};
  247         514  
  247         923  
  247         663  
  48         251  
424 48         483 @result;
425             };
426              
427             =head2 C<$shell-Estatus>
428              
429             C is called for status updates.
430              
431             =cut
432              
433             sub status {
434 22     22 1 95 my $self = shift;
435 22         170 print join "", @_;
436             };
437              
438             =head2 C<$shell-Edisplay FILENAME LINES>
439              
440             C is called to output listings, currently from the
441             C and C