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_004';
  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 test specification is enriched by the configuration in
 377 C<< config->defaults >> using L<Hash::Merge> with the I<LEFT_PRECEDENT>
 378 ruleset. Please care about the ruleset especially when merging arrays
 379 is to expect.
 380
 381 The code to accumulate the return codes from each test is taken
 382 from C<< test->check >> as described in L</_gen_code_compute>.
 383
 384 Returns the accumulated return codes from all checks in the given tests.
 385
 386 =cut
 387
 388 sub run_test
 389 {
 390     my ( $self, $test ) = @_;
 391
 392     my $merger = Hash::Merge->new('LEFT_PRECEDENT');
 393     my $full_test = $merger->merge( $test, $self->{cfg}->{defaults} );
 394
 395     my $mech = WWW::Mechanize::Timed->new();
 396     foreach my $akey ( keys %{ $full_test->{request}->{agent} } )
 397     {
 398         # XXX clone and delete array args before
 399         $mech->$akey( $full_test->{request}->{agent}->{$akey} );
 400     }
 401
 402     my $method = $full_test->{request}->{method};
 403     defined( $test->{request}->{http_headers} )
 404       ? $mech->$method( $full_test->{request}->{uri}, %{ $full_test->{request}->{http_headers} } )
 405       : $mech->$method( $full_test->{request}->{uri} );
 406
 407     $full_test->{compute_code} = _gen_code_compute( $full_test->{check} );
 408
 409     my $code = 0;
 410     my @msgs;
 411     foreach my $tp ( $self->test_plugins($full_test) )
 412     {
 413         my ( $plug_code, @plug_msgs ) = $tp->check_response( $full_test, $mech );
 414         $code = &{ $full_test->{compute_code} }( $code, $plug_code );
 415         push( @msgs, @plug_msgs );
 416     }
 417
 418     if ( $self->{cfg}->{report} )
 419     {
 420         $self->gen_report( $full_test, $mech, $code, @msgs );
 421     }
 422
 423     return ( $code, @msgs );
 424 }
 425
 426 1;