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