lib/WWW/Mechanize/Script.pm

   1 package WWW::Mechanize::Script;
   2
   3 use strict;
   4 use warnings;
   5
   6 use File::Basename qw(fileparse);
   7 use File::Path qw(make_path);
   8 use Hash::Merge ();
   9 use IO::File;
  10 use Module::Pluggable::Object ();
  11 use Params::Util qw(_HASH);
  12 use Template              ();
  13 use WWW::Mechanize        ();
  14 use WWW::Mechanize::Timed ();
  15
  16 # ABSTRACT: fetch websites and executes tests on the results
  17
  18 =head1 SYNOPSIS
  19
  20   use WWW::Mechanize::Script;
  21
  22   my $wms = WWW::Mechanize::Script->new();
  23   $wms->run_script(@script);
  24
  25   foreach my $test (@script) {
  26     $wms->run_test(%{$test});
  27   }
  28
  29 =cut
  30
  31 our $VERSION = '0.001_003';
  32
  33 =method new(\%cfg)
  34
  35 Instantiates new WWW::Mechanize::Script object.
  36
  37 Configuration hash looks like:
  38
  39     defaults => {
  40         check => { # check defaults
  41             "code_cmp" : ">",
  42             "XXX_code" : 2,
  43             "ignore_case" : true,
  44         },
  45         request => { # request defaults
  46             agent => { # LWP::UserAgent defaults
  47                 agent => "Agent Adderly",
  48                 accept_cookies => 'yes',    # check LWP::UA param
  49                 show_cookie    => 'yes',    # check LWP::UA param
  50                 show_headers   => 'yes',    # check LWP::UA param
  51                 send_cookie    => 'yes',    # check LWP::UA param
  52             },
  53         },
  54     },
  55     script_dirs => [qw(/old/wtscripts /new/json_scripts)],
  56     summary => {
  57         template => "[% CODE_NAME; IF MESSAGES.size > 0 %] - [% MESSAGES.join(', '); END %]\n",
  58         target => "-"
  59     },
  60     report => {
  61         template => "[% USE Dumper; Dumper.dump(RESPONSE) %]",
  62         target => "/tmp/@OPTS_FILE@.log",
  63         append => true
  64     }
  65
  66 =cut
  67
  68 sub new
  69 {
  70     my ( $class, $cfg ) = @_;
  71
  72     my $self = bless( { cfg => { %{$cfg} } }, $class );
  73
  74     return $self;
  75 }
  76
  77 =method _gen_code_compute
  78
  79 Interpretes one of following config hash parameters
  80
  81     defaults => {
  82         check => { # check defaults
  83             code_cmp => ">",
  84             code_func => 'my ($cur,$new) = @_; return $cur > $new ? $cur : $new;'
  85         }
  86     }
  87
  88 When none of them are there, the sample in defaults->check->code_func is used.
  89
  90 =cut
  91
  92 sub _gen_code_compute
  93 {
  94     my $check_cfg = $_[0];
  95     my $compute_code;
  96
  97     if ( defined( $check_cfg->{code_func} ) )
  98     {
  99         my $compute_str = "sub { " . $check_cfg->{code_func} . " };";
 100         $compute_code = eval $compute_str;
 101         $@ and die $@;
 102     }
 103
 104     if ( !defined($compute_code) and defined( $check_cfg->{code_cmp} ) )
 105     {
 106         my $compute_str =
 107             "sub { my (\$cur,\$new) = \@_; \$cur "
 108           . $check_cfg->{code_cmp}
 109           . " \$new ? \$cur : \$new; };";
 110         $compute_code = eval $compute_str;
 111         $@ and die $@;
 112     }
 113
 114     if ( !defined($compute_code) )
 115     {
 116         my $compute_str = "sub { my (\$cur,\$new) = \@_; \$cur > \$new ? \$cur : \$new; };";
 117         $compute_code = eval $compute_str;
 118         $@ and die $@;
 119     }
 120
 121     return $compute_code;
 122 }
 123
 124 =method test_plugins( )
 125
 126 The C<plugins()> classmethod returns the names of configuration loading plugins as
 127 found by L<Module::Pluggable::Object|Module::Pluggable::Object>.
 128
 129 =cut
 130
 131 sub test_plugins
 132 {
 133     my ( $self, $test ) = @_;
 134
 135     unless ( defined( $self->{all_plugins} ) )
 136     {
 137         my $plugin_base = join( "::", __PACKAGE__, "Plugin" );
 138         my $finder =
 139           Module::Pluggable::Object->new(
 140                                           require     => 1,
 141                                           search_path => [$plugin_base],
 142                                           except      => [$plugin_base],
 143                                           inner       => 0,
 144                                           only        => qr/^${plugin_base}::\p{Word}+$/,
 145                                         );
 146
 147         # filter out things that don't look like our plugins
 148         my @ap =
 149           map  { $_->new( $self->{cfg}->{defaults} ) }
 150           grep { $_->isa($plugin_base) } $finder->plugins();
 151         $self->{all_plugins} = \@ap;
 152     }
 153
 154     my @tp = grep { $_->can_check($test) } @{ $self->{all_plugins} };
 155     return @tp;
 156 }
 157
 158 =method get_request_value($request,$value_name)
 159
 160 Returns the value for creating the request - either from current script
 161 or from defaults (C<< defaults->request->$value_name >>).
 162
 163 =cut
 164
 165 sub get_request_value
 166 {
 167     my ( $self, $request, $value_name ) = @_;
 168
 169     $value_name or return;
 170
 171     return $request->{$value_name} // $self->{cfg}->{default}->{request}->{$value_name};
 172 }
 173
 174 sub _get_target
 175 {
 176     my $def = shift;
 177
 178     my $target = $def->{target};
 179     $target //= "-";
 180
 181     if ( $target ne "-" and $def->{append} )
 182     {
 183         my ( $name, $path, $suffix ) = fileparse($target);
 184         -d $path or make_path($path);
 185         my $fh = IO::File->new( $target, ">>" );
 186         $fh->seek( 0, SEEK_END );
 187         $target = $fh;
 188     }
 189
 190     return $target;
 191 }
 192
 193 =method summarize($code,@msgs)
 194
 195 Generates the summary passing the template in the configuration of
 196 C<< config->summary >> into L<Template::Toolkit>.
 197
 198 Following variables are provided for the template processing:
 199
 200 =over 4
 201
 202 =item CODE
 203
 204 The accumulated return code of all executed checks computed via
 205 L</_gen_code_compute>.
 206
 207 =item MESSAGES
 208
 209 Collected messages returned of all executed checks.
 210
 211 =back
 212
 213 Plus all constants named in the C<< config->templating->vars >> hash and
 214 those in C<< config->summary->vars >> hash.
 215
 216 The output target is guessed from C<< config->summary->target >> whereby
 217 the special target I<-> is interpreted as C<stdout>.
 218
 219 =cut
 220
 221 sub summarize
 222 {
 223     my ( $self, $code, @msgs ) = @_;
 224
 225     my %vars = (
 226                  %{ _HASH( $self->{cfg}->{templating}->{vars} ) // {} },
 227                  %{ _HASH( $self->{cfg}->{report}->{vars} )     // {} },
 228                  CODE     => $code,
 229                  MESSAGES => [@msgs]
 230                );
 231
 232     my $input    = $self->{cfg}->{summary}->{source} // \$self->{cfg}->{summary}->{template};
 233     my $output   = _get_target( $self->{cfg}->{summary} );
 234     my $template = Template->new();
 235     $template->process( $input, \%vars, $output )
 236       or die $template->error();
 237
 238     return;
 239 }
 240
 241 =method gen_report($full_test, $mech, $code, @msgs)
 242
 243 Generates a report for a test within a script by passing the template
 244 in the configuration of C<< config->report >> into L<Template::Toolkit>.
 245
 246 Following variables are provided for the template processing:
 247
 248 =over 4
 249
 250 =item CODE
 251
 252 The accumulated return code of all executed checks computed via
 253 L</_gen_code_compute>.
 254
 255 =item MESSAGES
 256
 257 Collected messages returned of all executed checks.
 258
 259 =item RESPONSE
 260
 261 Hash containing the following L<HTTP::Response|response> items:
 262
 263 =over 8
 264
 265 =item CODE
 266
 267 HTTP response code
 268
 269 =item CONTENT
 270
 271 Content of the response
 272
 273 =item BASE
 274
 275 The base URI for this response
 276
 277 =item HEADER
 278
 279 Header keys/values as perl hash
 280
 281 =back
 282
 283 =back
 284
 285 Plus all constants named in the C<< config->templating->vars >> hash and
 286 those in C<< config->report->vars >> hash.
 287
 288 The output target is guessed from C<< config->summary->target >> whereby
 289 the special target I<-> is interpreted as C<stdout>.
 290
 291 When the C<< config->summary->append >> flag is set and contains a true
 292 value, the output is appended to an existing target.
 293
 294 =cut
 295
 296 sub gen_report
 297 {
 298     my ( $self, $full_test, $mech, $code, @msgs ) = @_;
 299     my $response = $mech->response();
 300     my %vars = (
 301                  %{ _HASH( $self->{cfg}->{templating}->{vars} ) // {} },
 302                  %{ _HASH( $self->{cfg}->{report}->{vars} )     // {} },
 303                  CODE     => $code,
 304                  MESSAGES => [@msgs],
 305                  RESPONSE => {
 306                                CODE    => $response->code(),
 307                                CONTENT => $response->content(),
 308                                BASE    => $response->base(),
 309                                HEADER  => {
 310                                            map { $_ => $response->headers()->header($_) }
 311                                              $response->headers()->header_field_names()
 312                                          },
 313                              }
 314                );
 315
 316     my $input    = $self->{cfg}->{report}->{source} // \$self->{cfg}->{report}->{template};
 317     my $output   = _get_target( $self->{cfg}->{report} );
 318     my $template = Template->new();
 319     $template->process( $input, \%vars, $output )
 320       or die $template->error();
 321
 322     return;
 323 }
 324
 325 =method run_script(@script)
 326
 327 Runs a script consisting of at least one test and generates a summary if
 328 configured. The code to accumulate the return codes from each test is taken
 329 from C<< config->defaults->check >> as described in L</_gen_code_compute>.
 330
 331 Returns the accumulated return codes from all tests in the given script.
 332
 333 =cut
 334
 335 sub run_script
 336 {
 337     my ( $self, @script ) = @_;
 338     my $code = 0;    # XXX
 339     my @msgs;
 340     my $compute_code = _gen_code_compute( $self->{cfg}->{defaults}->{check} );
 341
 342     foreach my $test (@script)
 343     {
 344         my ( $test_code, @test_msgs ) = $self->run_test($test);
 345         $code = &{$compute_code}( $code, $test_code );
 346         push( @msgs, @test_msgs );
 347     }
 348
 349     if ( $self->{cfg}->{summary} )
 350     {
 351         my $summary = $self->summarize( $code, @msgs );
 352     }
 353
 354     return ( $code, @msgs );
 355 }
 356
 357 =method run_test(\%test)
 358
 359 Runs one test and generates a report if configured (C<< config->report >>).
 360
 361 The request is constructed from C<< test->request >> whereby the part
 362 below C<< test->request->agent >> is used to parametrize a new instance
 363 of L<WWW::Mechanize::Timed>.
 364
 365 All keys defined below C<< test->request->agent >> are taken as
 366 setter of WWW::Mechanize::Timed or a inherited class.
 367
 368 If there is a hash defined at C<< test->request->http_headers >>, those
 369 headers are passed along with the URI specified at C<< test->request->uri >>
 370 to GET/POST or whatever you want to do (C<< test->request->method >>).
 371
 372 Which checks are executed is defined below C<< test->check >>. Each valid
 373 plugin below the I<WWW::Mechanize::Script::Plugin> namespace is approved
 374 for relevance for the test (see L<WWW::Mechanize::Script::Plugin/can_check>).
 375
 376 The code to accumulate the return codes from each test is taken
 377 from C<< test->check >> as described in L</_gen_code_compute>.
 378
 379 Returns the accumulated return codes from all checks in the given tests.
 380
 381 =cut
 382
 383 sub run_test
 384 {
 385     my ( $self, $test ) = @_;
 386
 387     my $merger = Hash::Merge->new('LEFT_PRECEDENT');
 388     my $full_test = $merger->merge( $test, $self->{cfg}->{defaults} );
 389
 390     my $mech = WWW::Mechanize::Timed->new();
 391     foreach my $akey ( keys %{ $full_test->{request}->{agent} } )
 392     {
 393         # XXX clone and delete array args before
 394         $mech->$akey( $full_test->{request}->{agent}->{$akey} );
 395     }
 396
 397     my $method = $full_test->{request}->{method};
 398     defined( $test->{request}->{http_headers} )
 399       ? $mech->$method( $full_test->{request}->{uri}, %{ $full_test->{request}->{http_headers} } )
 400       : $mech->$method( $full_test->{request}->{uri} );
 401
 402     $full_test->{compute_code} = _gen_code_compute( $full_test->{check} );
 403
 404     my $code = 0;
 405     my @msgs;
 406     foreach my $tp ( $self->test_plugins($full_test) )
 407     {
 408         my ( $plug_code, @plug_msgs ) = $tp->check_response( $full_test, $mech );
 409         $code = &{ $full_test->{compute_code} }( $code, $plug_code );
 410         push( @msgs, @plug_msgs );
 411     }
 412
 413     if ( $self->{cfg}->{report} )
 414     {
 415         $self->gen_report( $full_test, $mech, $code, @msgs );
 416     }
 417
 418     return ( $code, @msgs );
 419 }
 420
 421 1;