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.100';
  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 =head1 EXPORTS
  28
  29 This module doesn't export anything by default, but any of the following on request:
  30
  31 =over 4
  32
  33 =item *
  34
  35 opt_required_all
  36
  37 =item *
  38
  39 opt_required_one
  40
  41 =item *
  42
  43 opt_exclusive
  44
  45 =item *
  46
  47 load_config
  48
  49 =item *
  50
  51 find_scripts
  52
  53 =back
  54
  55 =head1 FUNCTIONS
  56
  57 =head2 opt_required_one(\%opt_hash, @opt_names)
  58
  59 Fails by invoking pod2usage when none of the options in @opt_names are
  60 given in %opt_hash.
  61
  62 =cut
  63
  64 sub opt_required_one
  65 {
  66     my ( $opt_hash, @opt_names ) = @_;
  67
  68     my @have = grep { defined( $opt_hash->{$_} ) } @opt_names;
  69     @have and return;
  70
  71     pod2usage( -exitval => 1,
  72                -message => "Missing at least one of " . join( ", ", map { "--$_" } @opt_names ) );
  73 }
  74
  75 =head2 opt_required_all(\%opt_hash, @opt_names)
  76
  77 Fails by invoking pod2usage when any of the options in @opt_names are
  78 missing in %opt_hash.
  79
  80 =cut
  81
  82 sub opt_required_all
  83 {
  84     my ( $opt_hash, @opt_names ) = @_;
  85
  86     my @missing = grep { !defined( $opt_hash->{$_} ) } @opt_names;
  87     @missing or return;
  88
  89     pod2usage(
  90                -exitval => 1,
  91                -message => "Missing "
  92                  . join( ", ", map { "--$_" } @missing )
  93                  . " argument"
  94                  . ( @missing > 1 ? "s" : "" )
  95              );
  96 }
  97
  98 =head2 opt_exclusive(\%opt_hash, @opt_names)
  99
 100 Fails by invoking pod2usage when more than one of the options in @opt_names
 101 are given in %opt_hash.
 102
 103 =cut
 104
 105 sub opt_exclusive
 106 {
 107     my ( $opt_hash, @opt_names ) = @_;
 108
 109     my @missing = grep { defined( $opt_hash->{$_} ) } @opt_names;
 110     @missing < 2 and return;
 111
 112     @missing = map { "--" . $_ } @missing;
 113     my $final_m = pop @missing;
 114     pod2usage(
 115                -exitval => 1,
 116                -message => "Options "
 117                  . join( " and ", join( ", ", @missing ), $final_m )
 118                  . " are mutual exclusive"
 119              );
 120 }
 121
 122 =head2 load_config(;\%opt_hash)
 123
 124 Tries to load the primary configuration. It looks in any directory returned
 125 by L<File::ConfigDir/config_dirs> for files named either I<check_web> or
 126 like the basename of the invoking script (C<$0>) with any extension
 127 supported by L<Config::Any>. The found configuration files are merged into
 128 a single configuration hash using L<Hash::Merge> with the I<LEFT_PRECEDENT>
 129 ruleset.
 130
 131 When an option hash is given, the default agent is computed based on
 132 the value of I<$opt_hash{file}>.
 133
 134 =cut
 135
 136 sub load_config
 137 {
 138     my %opts;
 139     _HASH( $_[0] ) and %opts = %{ $_[0] };
 140     my %cfg = (
 141         defaults => {
 142                       terse       => 'failed_only',
 143                       save_output => 'yes',           # report ...
 144                       show_html   => 'yes',           # report ...
 145                     },
 146         request => {
 147             agent => {
 148                 agent => (
 149                           ( defined( $opts{file} ) and $opts{file} =~ m/(?:_w$|^wap\/)/ )
 150                           ? "Nokia6210/1.0 (03.01) UP.Link/5.0.0.4 VZDE-check_wap $VERSION"
 151                           : "Mozilla/5.0 (Windows; U; WinNT4.0; en-US; rv: VZDE-check_web $VERSION)"
 152                          ),
 153                 accept_cookies => 'yes',    # check LWP::UA param
 154                 show_cookie    => 'yes',    # check LWP::UA param
 155                 show_headers   => 'yes',    # check LWP::UA param
 156                 send_cookie    => 'yes',    # check LWP::UA param
 157                      },
 158                    },
 159               );
 160
 161     # find config file
 162     my @cfg_dirs = uniq map { realpath($_) } config_dirs();
 163     my $progname = fileparse( $0, qr/\.[^.]*$/ );
 164     my @cfg_pattern = map { ( "check_web." . $_, $progname . "." . $_ ) } Config::Any->extensions();
 165     my @cfg_files = File::Find::Rule->file()->name(@cfg_pattern)->maxdepth(1)->in(@cfg_dirs);
 166     if (@cfg_files)
 167     {
 168         my $merger = Hash::Merge->new('LEFT_PRECEDENT');
 169         # read config file(s)
 170         my $all_cfg = Config::Any->load_files(
 171                                                {
 172                                                  files           => [@cfg_files],
 173                                                  use_ext         => 1,
 174                                                  flatten_to_hash => 1,
 175                                                }
 176                                              );
 177
 178         foreach my $filename (@cfg_files)
 179         {
 180             defined( $all_cfg->{$filename} )
 181               or next;    # file not found or not parsable ...
 182                           # merge into default and previous loaded config ...
 183             %cfg = %{ $merger->merge( \%cfg, $all_cfg->{$filename} ) };
 184         }
 185     }
 186
 187     return %cfg;
 188 }
 189
 190 =head2 find_scripts(\%cfg,@patterns)
 191
 192 Finds scripts based on configuration and given patterns.
 193
 194 =over 4
 195
 196 =item *
 197
 198 When C<%cfg> contains an array with full qualified path names below the
 199 I<script_dirs>, those directories are scanned. When the directories are
 200 relative, the are concatenated using L<File::ConfigDir/config_dirs> (each
 201 entry in the I<script_dirs> is evaluated separately).
 202
 203 When C<%cfg> contains a string below the key I<script_dirs>, the
 204 I<config_dirs($cfg{script_dirs})> is used to find the scripts.
 205
 206 In any other case, I<config_dirs("check_web")> is used.
 207
 208 =item *
 209
 210 The C<@patterns> list must contain one or more file names or expandable
 211 shell patterns with or without directory parts and/or extensions.
 212
 213 Valid entries are for example:
 214
 215 =over 8
 216
 217 =item -
 218
 219 qw(check_host_app_one)
 220
 221 =item -
 222
 223 qw(check_host/app_one)
 224
 225 =item -
 226
 227 qw(check_host_app_one.json)
 228
 229 =item -
 230
 231 qw(check_host/app_one.yml)
 232
 233 =item -
 234
 235 qw(check_splunk_[1-5])
 236
 237 =item -
 238
 239 qw(splunk/test*)
 240
 241 =back
 242
 243 =back
 244
 245 Returns the list of found script file names.
 246
 247 =cut
 248
 249 sub find_scripts
 250 {
 251     my ( $cfg, @patterns ) = @_;
 252     my @script_filenames;
 253
 254     my @cfg_dirs =
 255       defined( $cfg->{script_dirs} )
 256       ? (
 257           _ARRAY( $cfg->{script_dirs} )
 258           ? @{ $cfg->{script_dirs} }
 259           : (
 260               _STRING( $cfg->{script_dirs} )
 261               ? ( $cfg->{script_dirs} )
 262               : ( config_dirs("check_web") )
 263             )
 264         )
 265       : ( config_dirs("check_web") );
 266     @cfg_dirs =
 267       grep { -d $_ } map { File::Spec->file_name_is_absolute($_) ? $_ : config_dirs($_) } @cfg_dirs;
 268     # grep { -d $_ }
 269     # map { File::Spec->catdir( $_, $directories ) }
 270     # config_dirs( $cfg{script_dir} // "check_web" );    # XXX basename $0
 271     foreach my $pattern (@patterns)
 272     {
 273         if ( -f $pattern and -r $pattern )
 274         {
 275             push( @script_filenames, $pattern );
 276         }
 277         else
 278         {
 279             my ( $volume, $directories, $fn ) = File::Spec->splitpath($pattern);
 280             my @script_pattern =
 281               $fn =~ m/\.[^.]*$/ ? ($fn) : map { $fn . "." . $_ } Config::Any->extensions();
 282             my @script_dirs = grep { -d $_ }
 283               map { File::Spec->catdir( $_, $directories ) } @cfg_dirs;
 284             push( @script_filenames,
 285                   File::Find::Rule->file()->name(@script_pattern)->maxdepth(1)->in(@script_dirs) );
 286         }
 287     }
 288     return @script_filenames;
 289 }
 290
 291 1;