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