lib/WWW/Mechanize/Script/Util.pm

   1 package WWW::Mechanize::Script::Util;
   2
   3 use strict;
   4 use warnings;
   5
   6 use base qw/Exporter/;
   7 use vars qw/$VERSION @EXPORT @EXPORT_OK %EXPORT_TAGS/;
   8
   9 use Config::Any;
  10 use File::Basename qw(fileparse);
  11 use File::ConfigDir qw(config_dirs);
  12 use File::Find::Rule;
  13 use Hash::Merge ();
  14 # use Hash::MoreUtils;
  15 use Params::Util qw(_HASH _ARRAY _STRING);
  16 use Pod::Usage;
  17
  18 $VERSION = '0.001_002';
  19
  20 @EXPORT      = ();
  21 @EXPORT_OK   = qw(opt_required_all opt_required_one opt_exclusive load_config find_scripts);
  22 %EXPORT_TAGS = ( ALL => \@EXPORT_OK );
  23
  24 sub opt_required_one
  25 {
  26     my ( $opt_hash, @opt_names ) = @_;
  27
  28     my @have = grep { defined( $opt_hash->{$_} ) } @opt_names;
  29     @have and return;
  30
  31     pod2usage( -exitval => 1,
  32                -message => "Missing at least one of " . join( ", ", map { "--$_" } @opt_names ) );
  33 }
  34
  35 sub opt_required_all
  36 {
  37     my ( $opt_hash, @opt_names ) = @_;
  38
  39     my @missing = grep { !defined( $opt_hash->{$_} ) } @opt_names;
  40     @missing or return;
  41
  42     pod2usage(
  43                -exitval => 1,
  44                -message => "Missing "
  45                  . join( ", ", map { "--$_" } @missing )
  46                  . " argument"
  47                  . ( @missing > 1 ? "s" : "" )
  48              );
  49 }
  50
  51 sub opt_exclusive
  52 {
  53     my ( $opt_hash, @opt_names ) = @_;
  54
  55     my @missing = grep { defined( $opt_hash->{$_} ) } @opt_names;
  56     @missing < 2 and return;
  57
  58     @missing = map { "--" . $_ } @missing;
  59     my $final_m = pop @missing;
  60     pod2usage(
  61                -exitval => 1,
  62                -message => "Options "
  63                  . join( " and ", join( ", ", @missing ), $final_m )
  64                  . " are mutual exclusive"
  65              );
  66 }
  67
  68 sub load_config
  69 {
  70     my %opts;
  71     _HASH( $_[0] ) and %opts = %{ $_[0] };
  72     my %cfg = (
  73         defaults => {
  74             terse       => 'failed_only',
  75             save_output => 'yes',           # report ...
  76             show_html   => 'yes',           # report ...
  77             check => {
  78                        ignore_case => 'yes',
  79                        text_forbid => [
  80                                         'Premature end of script headers',
  81                                         'Error processing directive',
  82                                         'XML Parsing partner document',
  83                                         'sun.io.MalformedInputException',
  84                                         'an error occurred while processing this directive'
  85                                       ],
  86                      },
  87                     },
  88         request => {
  89             agent => {
  90                 agent => (
  91                           ( defined( $opts{file} ) and $opts{file} =~ m/(?:_w$|^wap\/)/ )
  92                           ? "Nokia6210/1.0 (03.01) UP.Link/5.0.0.4 VZDE-check_wap $VERSION"
  93                           : "Mozilla/5.0 (Windows; U; WinNT4.0; en-US; rv: VZDE-check_web $VERSION)"
  94                          ),
  95                 accept_cookies => 'yes',    # check LWP::UA param
  96                 show_cookie    => 'yes',    # check LWP::UA param
  97                 show_headers   => 'yes',    # check LWP::UA param
  98                 send_cookie    => 'yes',    # check LWP::UA param
  99                      },
 100                    },
 101               );
 102
 103     # find config file
 104     my @cfg_dirs    = config_dirs();
 105     my $progname    = fileparse( $0, qr/\.[^.]*$/ );
 106     my @cfg_pattern = map { $progname . "." . $_ } Config::Any->extensions();
 107     my @cfg_files   = File::Find::Rule->file()->name(@cfg_pattern)->maxdepth(1)->in(@cfg_dirs);
 108     if (@cfg_files)
 109     {
 110         my $merger = Hash::Merge->new('LEFT_PRECEDENT');
 111         # read config file(s)
 112         my $all_cfg = Config::Any->load_files(
 113                                                {
 114                                                  files           => [@cfg_files],
 115                                                  use_ext         => 1,
 116                                                  flatten_to_hash => 1,
 117                                                }
 118                                              );
 119
 120         foreach my $filename (@cfg_files)
 121         {
 122             defined( $all_cfg->{$filename} )
 123               or next;    # file not found or not parsable ...
 124                           # merge into default and previous loaded config ...
 125             %cfg = %{ $merger->merge( \%cfg, $all_cfg->{$filename} ) };
 126         }
 127     }
 128
 129     return %cfg;
 130 }
 131
 132 sub find_scripts
 133 {
 134     my ( $cfg, @patterns ) = @_;
 135     my @script_filenames;
 136
 137     my @cfg_dirs =
 138       defined( $cfg->{script_dirs} )
 139       ? (
 140           _ARRAY( $cfg->{script_dirs} )
 141           ? @{ $cfg->{script_dirs} }
 142           : (
 143               _STRING( $cfg->{script_dirs} )
 144               ? ( $cfg->{script_dirs} )
 145               : ( config_dirs("check_web") )
 146             )
 147         )
 148       : ( config_dirs("check_web") );
 149     @cfg_dirs =
 150       grep { -d $_ } map { File::Spec->file_name_is_absolute($_) ? $_ : config_dirs($_) } @cfg_dirs;
 151     # grep { -d $_ }
 152     # map { File::Spec->catdir( $_, $directories ) }
 153     # config_dirs( $cfg{script_dir} // "check_web" );    # XXX basename $0
 154     foreach my $pattern (@patterns)
 155     {
 156         if ( -f $pattern and -r $pattern )
 157         {
 158             push( @script_filenames, $pattern );
 159         }
 160         else
 161         {
 162             my ( $volume, $directories, $fn ) = File::Spec->splitpath($pattern);
 163             my @script_pattern = map  { $fn . "." . $_ } Config::Any->extensions();
 164             my @script_dirs    = grep { -d $_ }
 165               map { File::Spec->catdir( $_, $directories ) } @cfg_dirs;
 166             push( @script_filenames,
 167                   File::Find::Rule->file()->name(@script_pattern)->maxdepth(1)->in(@script_dirs) );
 168         }
 169     }
 170     return @script_filenames;
 171 }
 172
 173 1;