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   971509 use strict;
  32         117  
  32         995  
4 32     32   168 use Carp;
  32         87  
  32         2142  
5 32     32   23258 use WWW::Mechanize;
  33         4722045  
  32         1512  
6 32     32   16049 use WWW::Mechanize::FormFiller;
  33         47753  
  33         1100  
7 32     32   15223 use HTTP::Cookies;
  33         235282  
  33         1175  
8 33     32   825 use parent qw( Term::Shell );
  33         99  
  33         288  
9 33     32   647734 use Exporter 'import';
  33         419  
  32         2319  
10 32     32   11077 use FindBin;
  32         29600  
  32         1565  
11 32     32   11448 use File::Temp qw(tempfile);
  32         181842  
  32         1927  
12 32     32   10227 use URI::URL;
  32         75090  
  32         1633  
13 32     32   14088 use Hook::LexWrap;
  32         43284  
  32         162  
14 32     32   13524 use HTML::Display qw();
  32         26702  
  32         778  
15 32     32   14863 use HTML::TokeParser::Simple;
  32         273068  
  32         1155  
16 32     32   248 use B::Deparse;
  32         120  
  32         21911  
17              
18             our $VERSION = '0.59';
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 12580 my ($self) = @_;
109 84         318 my ($name,%args) = @{$self->{API}{args}};
  84         1331  
110              
111 84         536 $self->{agent} = $args{ agent };
112 84 50       813 if( ! $self->agent ) {
113 84   50     1653 my $class = $args{ agent_class } || 'WWW::Mechanize';
114 84   50     1025 my $args = $args{ agent_args } || [];
115 84         2265 $self->{agent} = $class->new( @$args );
116             };
117              
118 84         333741 $self->{formfiller} = WWW::Mechanize::FormFiller->new(default => [ Ask => $self ]);
119              
120 84         1053 $self->{history} = [];
121              
122             $self->{options} = {
123             autosync => 0,
124             warnings => (exists $args{warnings} ? $args{warnings} : 1),
125             autorestart => 0,
126 84 100       1782 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   2153791 pre => sub { $self->request_dumper($_[1]) if $self->option("dumprequests"); },
136             post => sub {
137 145 100   145   91135224 $self->response_dumper($_[-1]) if $self->option("dumpresponses");
138 84         2671 };
139              
140             $self->{redirect_ok_wrapper} = wrap 'WWW::Mechanize::redirect_ok',
141             post => sub {
142 2 50   2   1982540 return unless $_[1];
143 1         6 $self->status( "\nRedirecting to ".$_[1]->uri."\n" );
144 1         2 $_[-1]
145 84         11914 };
146              
147             # Load the proxy settings from the environment
148 84 50       5591 $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         14067 my $sourcefile;
155 83 100       368 if (exists $args{rcfile}) {
156 80         258 $sourcefile = delete $args{rcfile};
157             } else {
158 3 50 0     2486 my $userhome = $^O =~ /win32/i ? $ENV{'USERPROFILE'} || $ENV{'HOME'} : ((getpwuid($<))[7]);
159 3 50       152 $sourcefile = "$userhome/.mechanizerc"
160             if -f "$userhome/.mechanizerc";
161             };
162 83 100       460 $self->option('cookiefile', $args{cookiefile}) if (exists $args{cookiefile});
163 83 100       423 $self->source_file($sourcefile) if defined $sourcefile;
164 83         247 $self->{browser} = undef;
165              
166             # Keep track of the files we consist of, to enable automatic reloading
167 83         666 $self->{files} = undef;
168 83 50       503 if ($self->option('watchfiles')) {
169 83         244 eval {
170 83 50 33     2908 my @files = grep { -f && -r && $_ ne '-e' } values %INC;
  17249         568190  
171 83         664 local $, = ",";
172 83         14433 require File::Modified;
173 0         0 $self->{files} = File::Modified->new(files=>[@files]);
174             };
175 83 50       1574 $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 4335 my ($self) = @_;
190 32     32   290 use Data::Dumper;
  32         68  
  32         237680  
191 44         1095 warn Dumper $self;
192 44         154104 undef $self->{request_wrapper};
193 44         326 undef $self->{redirect_ok_wrapper};
194 44         3687 $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 9 my ($self,$filename) = @_;
208 3         10 local $_; # just to be on the safe side that we don't clobber outside users of $_
209 3         12 local *F;
210 3 100       181 open F, "< $filename"
211             or die "Couldn't open '$filename' : $!\n";
212 1         45 while () {
213 2         21 $self->cmd($_);
214             warn "cmd: $_"
215 2 50       63 if $self->{options}->{verbose};
216             };
217 1         14 close F;
218             };
219              
220             sub add_history {
221 277     278 0 1477 my ($self,@code) = @_;
222 277         635 push @{$self->{history}},[$self->line,join "",@code];
  277         1680  
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 383 my ($self,@message) = @_;
234              
235 86 100       436 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 152 my $self = shift;
249              
250 32 50 33     407 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         792 print $_ for @_;
267             };
268             };
269              
270 976     976 1 174867 sub agent { $_[0]->{agent}; };
271              
272             sub option {
273 670     670 0 13624 my ($self,$option,$value) = @_;
274 670 100       3184 if (exists $self->{options}->{$option}) {
275 667         1724 my $result = $self->{options}->{$option};
276 667 100       2084 if (scalar @_ == 3) {
277 73         196 $self->{options}->{$option} = $value;
278             };
279 667         3991 $result;
280             } else {
281 3         21 Carp::carp "Unknown option '$option'";
282 3         16 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 1057098 my $self = shift @_;
295             # We want to restart when any module was changed
296 338 50 33     1561 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         1602 $self->SUPER::precmd(@_);
302             };
303              
304             sub browser {
305 1     1 0 1140 my ($self) = @_;
306 1   33     29 $self->{browser} ||= HTML::Display->new();
307 1         3492 $self->{browser};
308             };
309              
310             sub sync_browser {
311 2     2 0 6 my ($self) = @_;
312              
313             # We only can display html if we have any :
314 2 50       7 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 42 my $self = shift;
336 1 50       5 if ($self->agent->response) {
337 0   0     0 return ($self->agent->uri || "") . ">"
338             } else {
339 1         33 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 9 if (ref $_[1] eq 'ARRAY') {
346 1         15 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 235 my ($self,$arg) = @_;
354 62 100       554 if ($arg =~ m!^/(.*)/([imsx]*)$!) {
355 11         137 my ($re,$mode) = ($1,$2);
356 11         136 $re =~ s!([^\\])/!$1\\/!g;
357 11         1384 $arg = eval "qr/$re/$mode";
358             };
359 62         213 $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         3 my $result;
376 2         5 for (qw( text name url )) {
377 2 50       13 $result = $link->$_ and last;
378             };
379 2         20 $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 35 my ($self) = @_;
394 3         5 map { $_->[0] } @{$self->{history}}
  2         21  
  3         12  
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 44607933 my ($self,$prefix) = @_;
409 48   100     1264 $prefix ||= "";
410              
411 48         582 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         195 push @result, map { my $x = $_->[1]; $x =~ s/^/$prefix/mg; $x } @{$self->{history}};
  247         942  
  247         1763  
  247         933  
  48         408  
424 48         661 @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 127 my $self = shift;
435 22         224 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