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   2438388 use strict;
  32         91  
  32         798  
4 32     32   145 use Carp;
  32         48  
  32         1762  
5 32     32   20021 use WWW::Mechanize;
  33         4230295  
  32         1307  
6 32     32   13623 use WWW::Mechanize::FormFiller;
  33         41238  
  33         1216  
7 32     32   13358 use HTTP::Cookies;
  33         194584  
  33         960  
8 33     32   814 use parent qw( Term::Shell );
  33         70  
  33         714  
9 33     32   525794 use Exporter 'import';
  33         1506  
  32         1884  
10 32     32   9580 use FindBin;
  32         27428  
  32         1235  
11 32     32   8938 use File::Temp qw(tempfile);
  32         146647  
  32         1541  
12 32     32   8327 use URI::URL;
  32         66101  
  32         1370  
13 32     32   11250 use Hook::LexWrap;
  32         35003  
  32         126  
14 32     32   10900 use HTML::Display qw();
  32         22133  
  32         653  
15 32     32   12067 use HTML::TokeParser::Simple;
  32         225254  
  32         967  
16 32     32   206 use B::Deparse;
  32         56  
  32         17929  
17              
18             our $VERSION = '0.58';
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 12853 my ($self) = @_;
109 84         256 my ($name,%args) = @{$self->{API}{args}};
  84         1139  
110              
111 84         410 $self->{agent} = $args{ agent };
112 84 50       933 if( ! $self->agent ) {
113 84   50     1269 my $class = $args{ agent_class } || 'WWW::Mechanize';
114 84   50     645 my $args = $args{ agent_args } || [];
115 84         2665 $self->{agent} = $class->new( @$args );
116             };
117              
118 84         282478 $self->{formfiller} = WWW::Mechanize::FormFiller->new(default => [ Ask => $self ]);
119              
120 84         848 $self->{history} = [];
121              
122             $self->{options} = {
123             autosync => 0,
124             warnings => (exists $args{warnings} ? $args{warnings} : 1),
125             autorestart => 0,
126 84 100       1482 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   2200691 pre => sub { $self->request_dumper($_[1]) if $self->option("dumprequests"); },
136             post => sub {
137 145 100   145   98155042 $self->response_dumper($_[-1]) if $self->option("dumpresponses");
138 84         2406 };
139              
140             $self->{redirect_ok_wrapper} = wrap 'WWW::Mechanize::redirect_ok',
141             post => sub {
142 2 50   2   1986126 return unless $_[1];
143 1         4 $self->status( "\nRedirecting to ".$_[1]->uri."\n" );
144 1         1 $_[-1]
145 84         9530 };
146              
147             # Load the proxy settings from the environment
148 84 50       4290 $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         13044 my $sourcefile;
155 83 100       245 if (exists $args{rcfile}) {
156 80         204 $sourcefile = delete $args{rcfile};
157             } else {
158 3 50 0     1913 my $userhome = $^O =~ /win32/i ? $ENV{'USERPROFILE'} || $ENV{'HOME'} : ((getpwuid($<))[7]);
159 3 50       63 $sourcefile = "$userhome/.mechanizerc"
160             if -f "$userhome/.mechanizerc";
161             };
162 83 100       449 $self->option('cookiefile', $args{cookiefile}) if (exists $args{cookiefile});
163 83 100       331 $self->source_file($sourcefile) if defined $sourcefile;
164 83         190 $self->{browser} = undef;
165              
166             # Keep track of the files we consist of, to enable automatic reloading
167 83         483 $self->{files} = undef;
168 83 50       416 if ($self->option('watchfiles')) {
169 83         176 eval {
170 83 50 33     2813 my @files = grep { -f && -r && $_ ne '-e' } values %INC;
  17054         538181  
171 83         10389 local $, = ",";
172 83         13074 require File::Modified;
173 0         0 $self->{files} = File::Modified->new(files=>[@files]);
174             };
175 83 50       1325 $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 2925 my ($self) = @_;
190 32     32   240 use Data::Dumper;
  32         75  
  32         189653  
191 44         464 warn Dumper $self;
192 44         115820 undef $self->{request_wrapper};
193 44         256 undef $self->{redirect_ok_wrapper};
194 44         2322 $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 6 my ($self,$filename) = @_;
208 3         6 local $_; # just to be on the safe side that we don't clobber outside users of $_
209 3         8 local *F;
210 3 100       143 open F, "< $filename"
211             or die "Couldn't open '$filename' : $!\n";
212 1         33 while () {
213 2         16 $self->cmd($_);
214             warn "cmd: $_"
215 2 50       50 if $self->{options}->{verbose};
216             };
217 1         11 close F;
218             };
219              
220             sub add_history {
221 277     278 0 815 my ($self,@code) = @_;
222 277         466 push @{$self->{history}},[$self->line,join "",@code];
  277         1344  
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 538 my ($self,@message) = @_;
234              
235 86 100       531 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 262 my $self = shift;
249              
250 32 50 33     384 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         600 print $_ for @_;
267             };
268             };
269              
270 980     980 1 199242 sub agent { $_[0]->{agent}; };
271              
272             sub option {
273 670     670 0 11336 my ($self,$option,$value) = @_;
274 670 100       2424 if (exists $self->{options}->{$option}) {
275 667         1202 my $result = $self->{options}->{$option};
276 667 100       1674 if (scalar @_ == 3) {
277 73         166 $self->{options}->{$option} = $value;
278             };
279 667         2796 $result;
280             } else {
281 3         15 Carp::carp "Unknown option '$option'";
282 3         12 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 2147759 my $self = shift @_;
295             # We want to restart when any module was changed
296 338 50 33     1319 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         1464 $self->SUPER::precmd(@_);
302             };
303              
304             sub browser {
305 1     1 0 825 my ($self) = @_;
306 1   33     20 $self->{browser} ||= HTML::Display->new();
307 1         2674 $self->{browser};
308             };
309              
310             sub sync_browser {
311 2     2 0 5 my ($self) = @_;
312              
313             # We only can display html if we have any :
314 2 50       11 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       8 if ($self->agent->response) {
337 0   0     0 return ($self->agent->uri || "") . ">"
338             } else {
339 1         18 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         12 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 245 my ($self,$arg) = @_;
354 62 100       390 if ($arg =~ m!^/(.*)/([imsx]*)$!) {
355 11         190 my ($re,$mode) = ($1,$2);
356 11         84 $re =~ s!([^\\])/!$1\\/!g;
357 11         1034 $arg = eval "qr/$re/$mode";
358             };
359 62         221 $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         2 my $result;
376 2         4 for (qw( text name url )) {
377 2 50       12 $result = $link->$_ and last;
378             };
379 2         23 $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 29 my ($self) = @_;
394 3         7 map { $_->[0] } @{$self->{history}}
  2         29  
  3         11  
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 44733688 my ($self,$prefix) = @_;
409 48   100     629 $prefix ||= "";
410              
411 48         308 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         127 push @result, map { my $x = $_->[1]; $x =~ s/^/$prefix/mg; $x } @{$self->{history}};
  247         612  
  247         1018  
  247         644  
  48         220  
424 48         386 @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 89 my $self = shift;
435 22         178 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