1package Getopt::EX::Loader; 2 3use strict; 4use warnings; 5use Carp; 6 7use Exporter 'import'; 8our @EXPORT = qw(); 9our %EXPORT_TAGS = ( ); 10our @EXPORT_OK = qw(); 11 12use Data::Dumper; 13use Getopt::EX::Module; 14use Getopt::EX::Func qw(parse_func); 15 16our $debug = 0; 17 18sub new { 19 my $class = shift; 20 21 my $obj = bless { 22 BUCKETS => [], 23 BASECLASS => undef, 24 MODULE_OPT => '-M', 25 DEFAULT => 'default', 26 }, $class; 27 28 configure $obj @_ if @_; 29 30 $obj; 31} 32 33sub configure { 34 my $obj = shift; 35 my %opt = @_; 36 37 for my $opt (qw(BASECLASS MODULE_OPT DEFAULT)) { 38 if (my $value = delete $opt{$opt}) { 39 $obj->{$opt} = $value; 40 } 41 } 42 43 if (my $rc = delete $opt{RCFILE}) { 44 my @rc = ref $rc eq 'ARRAY' ? @$rc : $rc; 45 for (@rc) { 46 $obj->load(FILE => $_); 47 } 48 } 49 50 warn "Unknown option: ", Dumper \%opt if %opt; 51 52 $obj; 53} 54 55sub baseclass { 56 my $obj = shift; 57 @_ ? $obj->{BASECLASS} = shift 58 : $obj->{BASECLASS}; 59} 60 61sub buckets { 62 my $obj = shift; 63 @{ $obj->{BUCKETS} }; 64} 65 66sub append { 67 my $obj = shift; 68 push @{ $obj->{BUCKETS} }, @_; 69} 70 71sub load { 72 my $obj = shift; 73 my $bucket = 74 new Getopt::EX::Module @_, BASECLASS => $obj->baseclass; 75 $obj->append($bucket); 76 $bucket; 77} 78 79sub load_file { 80 my $obj = shift; 81 $obj->load(FILE => shift); 82} 83 84sub load_module { 85 my $obj = shift; 86 $obj->load(MODULE => shift); 87} 88 89sub defaults { 90 my $obj = shift; 91 map { $_->default } $obj->buckets; 92} 93 94sub calls { 95 my $obj = shift; 96 map { $_->call } $obj->buckets; 97} 98 99sub builtins { 100 my $obj = shift; 101 map { $_->builtin } $obj->buckets; 102} 103 104sub deal_with { 105 my $obj = shift; 106 my $argv = shift; 107 108 if (my $default = $obj->{DEFAULT}) { 109 if (my $bucket = eval { $obj->load_module($default) }) { 110 $bucket->run_inits($argv); 111 } else { 112 die $@ unless $! =~ /^No such file or directory/; 113 } 114 } 115 $obj->modopt($argv); 116 $obj->expand($argv); 117 $obj; 118} 119 120sub modopt { 121 my $obj = shift; 122 my $argv = shift; 123 124 my $start = $obj->{MODULE_OPT} // return (); 125 $start eq '' and return (); 126 my $start_re = qr/\Q$start\E/; 127 my @modules; 128 while (@$argv) { 129 if ($argv->[0] =~ s/^$start_re(.+)/$1/) { 130 if (my $mod = $obj->parseopt($argv)) { 131 push @modules, $mod; 132 } 133 next; 134 } 135 last; 136 } 137 @modules; 138} 139 140sub parseopt { 141 my $obj = shift; 142 my $argv = shift; 143 my $base = $obj->baseclass; 144 my $call; 145 146 ## 147 ## Check -Mmod::func(arg) or -Mmod::func=arg 148 ## 149 if ($argv->[0] =~ s{ 150 ^ (?<name> \w+ ) 151 (?: 152 :: 153 (?<call> 154 \w+ 155 (?: (?<P>[(]) | = ) ## start with '(' or '=' 156 (?<arg> [^)]* ) ## optional arg list 157 (?(<P>) [)] | ) ## close ')' or none 158 ) 159 )? 160 $ 161 }{$+{name}}x) { 162 $call = $+{call}; 163 } 164 165 my $mod = shift @$argv; 166 my $bucket = eval { $obj->load_module($mod) } or die $@; 167 168 if ($call) { 169 $bucket->call(join '::', $bucket->module, $call); 170 } 171 172 ## 173 ## If &getopt is defined in module, call it and replace @ARGV. 174 ## 175 $bucket->run_inits($argv); 176 177 $bucket; 178} 179 180sub expand { 181 my $obj = shift; 182 my $argv = shift; 183 184 ## 185 ## Insert module defaults. 186 ## 187 unshift @$argv, map { 188 if (my @s = $_->default()) { 189 my @modules = $obj->modopt(\@s); 190 @s, map { $_->default } @modules; 191 } else { 192 (); 193 } 194 } $obj->buckets; 195 196 ## 197 ## Expand user defined option. 198 ## 199 ARGV: 200 for (my $i = 0; $i < @$argv; $i++) { 201 last if $argv->[$i] eq '--'; 202 my($opt, $value) = split /=/, $argv->[$i], 2; 203 for my $bucket ($obj->buckets) { 204 if (my @s = $bucket->getopt($opt)) { 205 206 splice @$argv, $i, 1, ($opt, $value) if defined $value; 207 208 ## 209 ## Convert $<n> and $<shift> 210 ## 211 my @follow = splice @$argv, $i; 212 s/\$<(\d+)>/$follow[$1]/ge foreach @s; 213 shift @follow; 214 s/\$<shift>/shift @follow/ge foreach @s; 215 216 printf(STDERR "\@ARGV = %s\n", 217 join(' ', @$argv, @s, @follow)) if $debug; 218 219 my @module = $obj->modopt(\@s); 220 221 my @default = map { $_->default } @module; 222 push @$argv, @default, @s, @follow; 223 redo ARGV; 224 } 225 } 226 } 227} 228 229sub modules { 230 my $obj = shift; 231 my $base = $obj->baseclass or return (); 232 $base =~ s/::/\//g; 233 234 grep { /^[a-z]/ } 235 map { /(\w+)\.pm$/ } 236 map { glob "$_/$base/*.pm" } 237 @INC; 238} 239 2401; 241 242=head1 NAME 243 244Getopt::EX::Loader - RC/Module loader 245 246=head1 SYNOPSIS 247 248 use Getopt::EX::Loader; 249 250 my $loader = new Getopt::EX::Loader 251 BASECLASS => 'App::example'; 252 253 $loader->load_file("$ENV{HOME}/.examplerc"); 254 255 $loader->deal_with(\@ARGV); 256 257 my $parser = new Getopt::Long::Parser; 258 $parser->getoptions( ... , $loader->builtins ) 259 260=head1 DESCRIPTION 261 262This is the main interface to use L<Getopt::EX> modules. You can 263create loader object, load user defined rc file, load modules 264specified by command arguments, substitute user defined option and 265insert default options defined in rc file or modules, get module 266defined built-in option definition for option parser. 267 268Most of work is done in C<deal_with> method. It parses command 269arguments and load modules specified by B<-M> option by default. Then 270it scans options and substitute them according to the definitions in 271rc file or modules. If RC and modules defines default options, they 272are inserted to the arguments. 273 274Module can define built-in options which should be handled option 275parser. They can be taken by C<builtins> method, so you should give 276them to option parser. 277 278If C<App::example> is given as a C<BASECLASS> of the loader object, it 279is prepended to all module names. So command line 280 281 % example -Mfoo 282 283will load C<App::example::foo> module. 284 285In this case, if module C<App::example::default> exists, it is loaded 286automatically without explicit indication. Default module can be used 287just like a startup RC file. 288 289 290=head1 METHODS 291 292=over 4 293 294=item B<configure> I<name> => I<value>, ... 295 296=over 4 297 298=item BASECLASS 299 300Define base class for user defined module. 301 302=item MODULE_OPT 303 304Define module option string. String B<-M> is set by default. 305 306=item DEFAULT 307 308Define default module name. String B<default> is set by default. Set 309C<undef> if you don't want load any default module. 310 311=back 312 313=item B<buckets> 314 315Return loaded L<Getopt::EX::Module> object list. 316 317=item B<load_file> 318 319Load specified file. 320 321=item B<load_module> 322 323Load specified module. 324 325=back 326