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