File Coverage

blib/lib/Config/Param.pm
Criterion Covered Total %
statement 907 1127 80.4
branch 489 778 62.8
condition 127 216 58.8
subroutine 53 56 94.6
pod 22 43 51.1
total 1598 2220 71.9


line stmt bran cond sub pod time code
1             # This has been a simple routine for command line and config file parsing.
2             # Now it deals with differing styles (grades of laziness) of command line parameters,
3             # has funky operators on them, and is a tool box to work with other program's config files.
4              
5             # It also carries a badge with the inscript "NIH syndrome".
6             # On the backside, you can read "But still better than anything that came before!".
7              
8             # current modus operandi:
9             # 1. parse command line args into temporary storage
10             # 2. parse config files (that may have been set on command line)
11             # 3. merge settings (overwrite config file settings)
12             # 4. finalize with help/error message
13              
14             # TODO: I got sections now. A next step could be sub-commands, presented as sections
15             # in help output and also defined like/with those. Needs some namespacing, though.
16             # Maybe just sub-instances of Config::Param.
17              
18             # TODO: I should restructure the the internal data. It's too many hashes now
19             # with the same key. Nested hash or better array with named indices (to avoid typos and
20             # less wasteful storage)?
21              
22             # TODO: --config with append mode, by config option
23              
24             package Config::Param;
25              
26 11     11   691952 use strict;
  11         106  
  11         319  
27 11     11   55 use warnings;
  11         21  
  11         251  
28              
29 11     11   52 use Carp;
  11         19  
  11         542  
30 11     11   280 use 5.008;
  11         37  
31             # major.minor.bugfix, the latter two with 3 digits each
32             # or major.minor_alpha
33             our $VERSION = '4.000005';
34             $VERSION = eval $VERSION;
35             our %features = qw(array 1 hash 1);
36              
37             our $verbose = 0; # overriding config
38              
39             # parameter flags
40             our $count = 1;
41             our $arg = 2;
42             our $switch = 4;
43             our $append = 8;
44             our $nonempty = 16;
45              
46             # using exit values from sysexists.h which make sense
47             # for configuration parsing
48             my $ex_usage = 64;
49             my $ex_config = 78;
50             my $ex_software = 70;
51              
52 11     11   5172 use Sys::Hostname;
  11         11671  
  11         638  
53 11     11   5200 use FindBin qw($Bin);
  11         12241  
  11         1471  
54 11     11   80 use File::Spec;
  11         21  
  11         189  
55 11     11   52 use File::Basename;
  11         26  
  11         63477  
56              
57             # The official API for simple use:
58              
59             # This is the procedural interface: Just call get() with your setup and get the pars.
60             sub get #(config, params)
61             {
62             # Handling of the differing API variants
63             # 1. just plain list of parameter definitions
64             # 2. config hash first, then parameter definitions
65             # 3. config hash, then array ref for definitions
66             # ... in that case, optional ref to argument array to parse
67 67 100   67 1 48954 my $config = ref $_[0] eq 'HASH' ? shift : {};
68 67         114 my $pardef;
69 67         127 my $args = \@ARGV;
70 67         113 my $give_error;
71 67 100       163 if(ref $_[0] eq 'ARRAY')
72             {
73 66         103 $pardef = shift;
74 66 100       174 if(ref $_[0] eq 'ARRAY')
75             {
76 64         92 $args = shift;
77 64         102 $give_error = 1;
78             }
79             }
80 1         2 else{ $pardef = \@_; }
81              
82 67         402 my $pars = Config::Param->new($config, $pardef);
83             # Aborting on bad specification. Not sensible to continue.
84             # Match this with documentation in POD.
85 67   100     154 my $bad = not (
86             $pars->good()
87             and $pars->parse_args($args)
88             and $pars->use_config_files()
89             and $pars->apply_args()
90             and $pars->INT_value_check()
91             );
92 67         222 $pars->final_action($bad);
93              
94 67 100       232 $_[0] = $pars->{errors} if $give_error;
95 67         219 return $pars->{param};
96             }
97              
98             # Now the meat.
99              
100             # Codes for types of parameters. It's deliberate that simple scalars are false and others are true.
101             my $scalar = 0; # Undefined also counts as scalar.
102             my $array = 1;
103             my $hash = 2;
104             my @initval = (undef, [], {});
105             #This needs to be changed. Also for a hash, --hash is equivalent to --hash=1, which
106             #results in 1=>undef, not truth=>1
107             my @trueval = (1, [1], {truth=>1});
108             my @falseval = (0, [0], {truth=>0});
109             my @typename = ('scalar', 'array', 'hash');
110             my %typemap = (''=>$scalar, scalar=>$scalar, array=>$array, hash=>$hash);
111              
112             # A name is allowed to contain just about everything but "=", but shall not end with something that will be mistaken for an operator.
113             # The checks for valid names besides the generic regexes are stricter and should be employed in addition.
114              
115             # Parser regex elements.
116             # Generally, it's optinal operators before "=" or just operators for short parameters.
117             # The addition with /./ is for choosing an arbitrary array separator for the value.
118             # Since long names are not allowed to end with an operator, using "/" that way is
119             # no additional restriction.
120             # Context is needed to decide for /,/ and // with special function for arrays and hashes.
121             # The grammar is not context-free anymore. Meh.
122             # Well, treating it this way: // is a special operator for long names,
123             # // is parsed as /=/, then interpreted accordingly for arrays as //.
124             my $ops = '.+\-*\/';
125             my $sopex = '['.$ops.']?=|['.$ops.']=?';
126             my $lopex = '\/.\/['.$ops.']?=|['.$ops.']?=|\/\/|\/.\/';
127             my $noop = '[^+\-=.*\/\s]'; # a non-whitespace character that is unspecial
128             my $parname = $noop.'[^\s=\/]*'.$noop;
129              
130             # Regular expressions for parameter parsing.
131             # The two variants are crafted to yield matching back-references.
132             # -x -x=bla -xyz -xyz=bla
133             our $shortex_strict = qr/^(([-+])($noop+|($noop+)($sopex)(.*)))$/;
134             # -x -x=bla -xyz x x=bla xyz
135             our $shortex_lazy = qr/^(([-+]?)($noop+|($noop)($sopex)(.*)))$/;
136             # -xbla with x possibly arg-requiring option and bla an argument
137             our $shortarg = qr/^[-+]($noop)($sopex|)(.+)$/;
138             # --long --long=bla
139             our $longex_strict = qr/^(([-+]{2})($parname)(($lopex)(.*)|))$/;
140             # --long --long=bla -long=bla long=bla
141             our $longex_lazy = qr/^(([-+]{0,2})($parname)()($lopex)(.*)|(--|\+\+)($parname))$/;
142              
143             my %example =
144             (
145             'lazy' => '[-]s [-]xyz [-]s=value --long [-[-]]long=value - [files/stuff]'
146             ,'normal' => '-s -xyz -s=value --long --long=value [--] [files/stuff]'
147             );
148             my $lazyinfo = "The [ ] notation means that the enclosed - is optional, saving typing time for really lazy people. Note that \"xyz\" as well as \"-xyz\" mention three short options, opposed to the long option \"--long\". In trade for the shortage of \"-\", the separator for additional unnamed parameters is mandatory (supply as many \"-\" grouped together as you like;-).";
149              
150             my @morehelp =
151             (
152             'You mention the options to change parameters in any order or even multiple times.'
153             , ' They are processed in the oder given, later operations overriding/extending earlier settings.'
154             , ' Using the separator "--" stops option parsing'."\n"
155             ,'An only mentioned short/long name (no "=value") means setting to 1, which is true in the logical sense. Also, prepending + instead of the usual - negates this, setting the value to 0 (false).'."\n"
156             ,'Specifying "-s" and "--long" is the same as "-s=1" and "--long=1", while "+s" and "++long" is the sames as "-s=0" and "--long=0".'."\n"
157             ,"\n"
158             ,'There are also different operators than just "=" available, notably ".=", "+=", "-=", "*=" and "/=" for concatenation / appending array/hash elements and scalar arithmetic operations on the value. Arrays are appended to via "array.=element", hash elements are set via "hash.=name=value". You can also set more array/hash elements by specifying a separator after the long parameter line like this for comma separation:'."\n\n"
159             ,"\t--array/,/=1,2,3 --hash/,/=name=val,name2=val2"
160             );
161              
162             # check if long/short name is valid before use
163             sub valid_name
164             {
165 657     657 1 1330 my ($long, $short) = @_;
166             return
167             (
168 657   66     11405 (not defined $short or $short eq '' or $short =~ /^$noop$/o)
169             and defined $long
170             and $long =~ /^$parname/o
171             );
172             }
173              
174             sub valid_type
175             {
176 657     657 1 1245 my $type = lc(ref $_[0]);
177 657         1514 return $typemap{$type}; # undefined if invalid
178             }
179              
180             # A valid definition also means that the default value type
181             # must match a possibly specified type.
182             sub valid_def
183             {
184 657     657 1 901 my $def = shift;
185             $_[0] = (defined $def->{type} and not defined $def->{value})
186             ? $def->{type}
187 657 50 33     1719 : valid_type($def->{value});
188             return
189             (
190             valid_name($def->{long}, $def->{short}) and defined $_[0]
191             and ( not defined $def->{type} or ($def->{type} ne $_[0]) )
192             and ( not defined $def->{regex} or ref $def->{regex} eq 'Regexp')
193 657   33     1205 and ( not defined $def->{call} or ref $def->{call} eq 'CODE' )
194             );
195             }
196              
197             sub hashdef
198             {
199 234     234 1 1190 my %h = ( long=>shift, value=>shift, short=>shift
200             , help=>shift, arg=>shift, flags=>shift
201             , addflags=>shift, level=>shift
202             , regex=>shift, call=>shift );
203 234 50       513 $h{short} = '' unless defined $h{short};
204 234 100       450 $h{flags} = 0 unless defined $h{flags};
205 234         398 return \%h;
206             }
207              
208             sub builtins
209             {
210 79     79 1 355 my $config = shift;
211 79         248 my %bldi = (help=>1, h=>1, I=>1, config=>1);
212 79 50 33     304 $bldi{version} = 1 if(defined $config and defined $config->{version});
213 79         196 return \%bldi;
214             }
215              
216             # helper for below
217             sub INT_defchecker
218             {
219 259     259 0 360 my $def = shift;
220 259         359 my $name_there = shift;
221 259 100       534 my $short = defined $def->{short} ? $def->{short} : '';
222              
223             return ''
224 259 50       515 if defined $def->{section};
225 259 50       424 return "'".(defined $def->{long} ? $def->{long} : '')."' definition is not good"
    100          
226             unless valid_def($def);
227             return "'$def->{long}' ".(defined $def->{short} ? "/ $def->{short}" : '')." name already taken"
228 258 50 66     1055 if($name_there->{$def->{long}} or $name_there->{$short});
    100          
229             $name_there->{$def->{long}} = 1
230 257 50       678 if defined $def->{long};
231 257 100       596 $name_there->{$short} = 1 if $short ne '';
232              
233 257         471 return ''; # no problem
234             }
235              
236             # check if whole definition array is proper,
237             # modifying the argument to sanitize to canonical form
238             # That form is an array of definition hashes.
239             sub sane_pardef
240             {
241 70     70 1 106 my $config = shift;
242 70         147 my $name_there = builtins($config);
243 70         113 my $indef = $_[0];
244 70         125 $_[0] = []; # If an error comes, nothing is sane.
245 70 100       96 if(@{$indef})
  70         181  
246             {
247 69 100       197 if(ref $indef->[0] ne '')
248             {
249             # each element is a ref, check them all
250 33         46 for my $d (@{$indef})
  33         68  
251             {
252 86         146 my $t = ref $d;
253 86 50       167 return 'mix of array/hash and other stuff'
254             if($t eq '');
255 86 50 66     204 return 'strange refs, neither hash nor array'
256             if($t ne 'ARRAY' and $t ne 'HASH');
257              
258 86 100       156 my $def = $t eq 'ARRAY' ? hashdef(@{$d}) : $d;
  61         122  
259 86         158 my $problem = INT_defchecker($def, $name_there);
260 86         126 $d = $def;
261 86 50       205 return $problem if $problem;
262             }
263             }
264             else
265             {
266 36 50       50 return 'plain member count not multiple of 4' if(@{$indef} % 4);
  36         99  
267              
268 36         66 my @spars = ();
269 36         57 while(@{$indef})
  207         399  
270             {
271 173         223 my $sdef;
272 173         218 my $def = hashdef(splice(@{$indef}, 0, 4));
  173         332  
273 173         347 my $problem = INT_defchecker($def, $name_there);
274 173 100       362 return $problem if $problem;
275 171         296 push(@spars, $def);
276             }
277 34         65 $indef = \@spars;
278             }
279             }
280 68         132 $_[0] = $indef; # only after full success
281 68         217 return '';
282             }
283              
284             sub escape_pod
285             {
286 143 100   143 1 299 return undef unless defined $_[0];
287 141         283 my @text = split("\n", shift, -1);
288 141         215 for(@text)
289             {
290 173 100       416 next if m/^\s/; # indented stuff is verbatim
291 157         209 s/^=(\w)/=Z<>$1/;
292 157         259 s/([A-Z])
293             }
294 141         496 return join("\n", @text);
295             }
296              
297             # Following: The OO API for detailed work.
298              
299             sub new # strictly (\%config, \@pardef)
300             {
301 70     70 1 1410 my $class = shift;
302 70         120 my $self = {};
303 70         172 bless $self, $class;
304              
305 70         185 $self->{config} = shift;
306 70 100       170 $self->{config} = {} unless defined $self->{config};
307 70         118 my $pars = shift;
308 70 100       145 $pars = [] unless defined $pars;
309 70         142 $self->{files} = [];
310 70         129 $self->{errors} = [];
311              
312 70 100       1499 $self->{config}{program} = basename($0) unless defined $self->{config}{program};
313 70 100       240 $self->{config}{shortdefaults} = 1 unless exists $self->{config}{shortdefaults};
314 70         131 $self->{printconfig} = 0;
315 70         135 my $hh = 'Show the help message. Value 1..9: help level, par:'
316             . ' help for paramter par (long name) only.';
317 70         145 $self->{extrahelp} = 'Additional fun with negative values, optionally'
318             . ' followed by comma-separated list of parameter names:'."\n"
319             . '-1: list par names, -2: list one line per name,'
320             . ' -3: -2 without builtins, -10: dump values (Perl style),'
321             . ' -11: dump values (lines), -100: print POD.';
322 70         127 my $ih = 'Which configfile(s) to use (overriding automatic search'
323             . ' in likely paths);'."\n"
324             . 'special: just -I or --config causes printing a current config'
325             . ' file to STDOUT';
326              
327 70 50 66     211 if($self->{config}{lazy} and $self->{config}{posixhelp})
328             {
329 0         0 $self->INT_error("POSIX-style help texts and lazy parameter syntax are incompatible.");
330 0         0 $self->{config}{posixhelp} = 0;
331             }
332             # Put -- in front of long names in communication, in POSIX mode.
333 70 50       186 $self->{longprefix} = $self->{config}{posixhelp} ? '--' : '';
334             # Same for - and short names.
335 70 50       156 $self->{shortprefix} = $self->{config}{posixhelp} ? '-' : '';
336             # An array of sections, with {name=>foo, member=>[$long1, $long2, ...]}.
337             # If I opted for
338 70         185 $self->{section} = [];
339             # Start the default, nameless section. Maybe a name should be generated if there
340             # are other sections.
341             $self->define({ section=>'', level=>1, flags=>$self->{config}{flags}
342 70         419 , regex=>$self->{config}{regex}, call=>$self->{config}{call} });
343              
344             # Choosing kindof distributed storage of parmeter properties, for direct
345             # access. With more and more properties, the count of global hashes
346             # increases uncomfortably.
347 70         298 $self->{param} = {}; # parameter values
348 70         131 $self->{help} = {}; # help texts
349 70         129 $self->{long} = {}; # map short to long names
350 70         123 $self->{short} = {}; # map long to short names
351 70         125 $self->{arg} = {}; # argument name
352 70         134 $self->{type} = {}; # type code
353             # store default values, for even more detailed documentation
354 70         121 $self->{default} = {}; # default value
355 70         201 $self->{level} = {}; # parameter level for help output
356 70         118 $self->{length} = 0; # max length of long names
357 70         119 $self->{arglength} = 0; # max length of name=arg or name[=arg]
358             # Chain of config files being parsed, to be able to check for inclusion loops.
359 70         121 $self->{parse_chain} = [];
360             # TODO set from config hash
361 70 100       578 $self->define({ long=>'help', short=>$self->{config}{shortdefaults} ? 'h' : '', value=>0
362             , help=>\$hh, flags=>0, regex=>qr/./ });
363             $self->define(
364             {
365             long=>'config', short=>$self->{config}{shortdefaults} ? 'I' : '', value=>[]
366             , help=>\$ih, flags=>0, regex=>qr/./
367             , call=> sub
368             { # --config increments printconfig and does not add a config file.
369 1 50   1   3 unless(defined $_[2])
370             {
371 1         2 $self->{printconfig} += 1;
372 1         2 undef $_[0]; # Skip this operation.
373             }
374 1         2 return 0;
375             }
376 70 100       847 });
377             $self->define({ long=>'version', value=>0, short=>''
378             , help=>\'print out the program version', arg=>''
379             , flags=>0, regex=>qr/./ })
380 70 50       263 if(defined $self->{config}{version});
381              
382             # deprecated v2 API
383             $self->INT_error("Update your program: ignorehelp is gone in favour of nofinals!")
384 70 50       175 if exists $self->{config}{ignorehelp};
385             $self->INT_error("Update your program: eval option not supported anymore.")
386 70 50       170 if exists $self->{config}{eval};
387              
388 70         202 my $problem = sane_pardef($self->{config}, $pars);
389 70 100       151 if($problem)
390             {
391 2         9 $self->INT_error("bad parameter specification: $problem");
392             } else
393             {
394 68         105 my $di = 0;
395 68         97 for my $def (@{$pars})
  68         182  
396             {
397 252         347 ++$di;
398             # definition failure here is an error in the module
399 252 50       459 $self->INT_error("Very unexpected failure to evaluate parameter definition $di.")
400             unless($self->define($def));
401             }
402 68         170 $self->find_config_files();
403             }
404 70         377 return $self;
405             }
406              
407             sub good
408             {
409 67     67 1 93 my $self = shift;
410 67         93 return @{$self->{errors}} == 0;
  67         301  
411             }
412              
413             # name[=arg] and variants
414             sub INT_namearg
415             {
416 398     398 0 565 my $self = shift;
417 398         543 my $name = shift;
418 398         670 my $flags = $self->{flags}{$name};
419 398         756 my $val= $self->{arg}{$name};
420 398 100       811 $val = 'val' unless defined $val;
421 398 50       1410 return $flags & $arg
    100          
422             ? $name.'='.$val # mandatory argument
423             : ( $val eq ''
424             ? $name # silent optional argument
425             : $name.'[='.$val.']' ) # named optional argument
426             }
427              
428             sub define
429             {
430 468     468 1 711 my $self = shift;
431 468         630 my $pd = shift;
432              
433             my $helpref = defined $pd->{help}
434             ? ( ref $pd->{help} ? $pd->{help} : \$pd->{help} )
435 468 100       1274 : \"";
    100          
436             # The section keyword defines a section instead of a parameter.
437 468 100       1068 if(exists $pd->{section})
438             {
439             # Silence runs with perl -W. Actually, I'm annoyed that 0+undef isn't
440             # doing this already. Still doing 0+ to catch idle strings, which are
441             # evildoing by the user program.
442 70 50       154 my $flags = defined $pd->{flags} ? 0+$pd->{flags} : 0;
443 70 50       169 my $level = defined $pd->{level} ? 0+$pd->{level} : 0;
444             # The first section is the default one, any further sections mean
445             # that you care about parameter order.
446             $self->{config}{ordered} = 1
447 70 50       96 if @{$self->{section}};
  70         200  
448 70         353 push(@{$self->{section}}, { section=>$pd->{section}
449             , help=>$helpref, level=>$level
450             , minlevel=>10 # will be lowered when parameters are added to it
451 70         113 , flags=>$flags, regex=>$pd->{regex}, call=>$pd->{call} });
452 70         165 return 1;
453             }
454              
455 398 50       523 unless(@{$self->{section}})
  398         828  
456             {
457 0         0 $self->INT_error("Define the default section first!");
458 0         0 return 1;
459             }
460              
461 398         613 my $section = $self->{section}[$#{$self->{section}}];
  398         715  
462 398         675 my $name = $pd->{long};
463              
464 398 100       771 $pd->{help} = \'' unless defined $pd->{help};
465 398 100       766 $pd->{short} = '' unless defined $pd->{short};
466 398         513 my $type; # valid_def sets that
467 398 50       711 unless(valid_def($pd, $type))
468             {
469 0         0 $self->INT_error("Invalid definition for $name / $pd->{short}");
470 0         0 return 0;
471             }
472             my $flags = defined $pd->{flags}
473             ? $pd->{flags}
474 398 100       1073 : $section->{flags};
475             $flags |= $pd->{addflags}
476 398 50       773 if defined $pd->{addflags};
477             my $regex = defined $pd->{regex}
478             ? $pd->{regex}
479 398 100       744 : $section->{regex};
480             my $call = defined $pd->{call}
481             ? $pd->{call}
482 398 100       724 : $section->{call};
483 398 50 33     846 if($flags & $switch and $flags & $arg)
484             {
485 0         0 $self->INT_error("Invalid flags (switch requiring argument) for $name / $pd->{short}");
486 0         0 return 0;
487             }
488 398 50 33     1451 unless(defined $self->{param}{$name} or defined $self->{long}{$pd->{short}})
489             {
490 398         860 $self->{type}{$name} = $type;
491             # If the definition value is a reference, make a deep copy of it
492             # instead of copying the reference. This keeps the definition
493             # and default value unchanged, for reproducible multiple runs of
494             # the parser.
495 398 100       731 if(ref $pd->{value})
496             {
497 212         2511 require Storable; # Only require it if there is really the need.
498 212         12771 $self->{param}{$name} = Storable::dclone($pd->{value});
499 212         2518 $self->{default}{$name} = Storable::dclone($pd->{value});
500             }
501             else
502             {
503 186         349 $self->{param}{$name} = $pd->{value};
504 186         359 $self->{default}{$name} = $pd->{value};
505             }
506             $self->{long}{$pd->{short}} = $name
507 398 100       1338 if $pd->{short} ne '';
508 398         769 $self->{short}{$name} = $pd->{short};
509 398         643 $self->{help}{$name} = $helpref;
510 398         703 $self->{arg}{$name} = $pd->{arg};
511             my $lev = $self->{level}{$name} = 0+( defined $pd->{level}
512             ? $pd->{level}
513 398 50       983 : $section->{level} );
514             # Store the minimum level needed to display at least one section member.
515             $section->{minlevel} = $lev
516 398 100       866 if $lev < $section->{minlevel};
517 398         696 $self->{flags}{$name} = $flags;
518             $self->{arg}{$name} = ''
519 398 50       863 if $self->{flags}{$name} & $switch;
520 398         543 push(@{$section->{member}}, $name);
  398         979  
521 398         2111 $self->INT_verb_msg("define $name / $pd->{short} of type $typename[$type] flags $self->{flags}{$name}\n");
522             # Call INT_namearg after settling flags!
523             $self->{length} = length($name)
524 398 100       972 if length($name) > $self->{length};
525 398         911 my $arglen = length($self->INT_namearg($name));
526             $self->{arglength} = $arglen
527 398 100       953 if $arglen > $self->{arglength};
528 398 100       831 $self->{regex}{$name} = $regex
529             if defined $regex;
530 398 100       881 $self->{call}{$name} = $call
531             if defined $call;
532             }
533             else
534             {
535 0         0 $self->INT_error("Tried to redefine an option ($pd->{long} / $pd->{short}! Programmer: please check this!");
536 0         0 return 0;
537             }
538 398         953 return 1;
539             }
540              
541             sub find_config_files
542             {
543 68     68 1 110 my $self = shift;
544              
545 68 50       166 if(defined $self->{config}{file})
546             {
547 0         0 @{$self->{param}{config}} = ref $self->{config}{file} eq 'ARRAY'
548 0         0 ? @{$self->{config}{file}}
549 0 0       0 : ($self->{config}{file});
550             }
551             #means: nofile[false,true], file[string], info, verbose[bool],
552             #config confusion
553             # as long as I was told not to use a config file or it has been already given
554 68 100 66     197 unless($self->{config}{nofile} or @{$self->{param}{config}})
  42         137  
555             {
556             # Default to reading program.conf and/or program.host.conf if found.
557 42         149 my $pconf = $self->INT_find_config($self->{config}{program}.'.conf');
558 42         192 my $hconf = $self->INT_find_config($self->{config}{program}.'.'.hostname().'.conf');
559 42         79 my @l;
560 42 100       108 push(@l, $pconf) if defined $pconf;
561 42 50       94 push(@l, $hconf) if defined $hconf;
562             # That list can be empty if none existing.
563 42         189 $self->INT_verb_msg("possible config files: @l\n");
564             # The last entry in the list has precedence.
565 42 50       110 unless($self->{config}{multi})
566             {
567 42 100       110 @l = ($l[$#l]) if @l; # Only the last element, if any, prevails.
568             }
569 42         69 @{$self->{param}{config}} = @l;
  42         131  
570             }
571             }
572              
573             # Parse abcd to the list of corresponding long names.
574             sub INT_long_names
575             {
576 65     65 0 98 my $self = shift;
577 65         98 my $sname = shift;
578 65         95 my @names;
579 65         243 for my $s (split(//,$sname))
580             {
581 69 50       181 if(defined (my $name = $self->{long}{$s}))
582             {
583 69         169 push(@names, $name);
584             }
585             else
586             {
587 0 0       0 if($self->{config}{fuzzy})
588             {
589 0         0 $self->INT_verb_msg("Unknown short option $s, assuming that this is data instead.\n");
590 0         0 @names = ();
591 0         0 last;
592             }
593             else
594             {
595 0 0 0     0 unless($self->{config}{ignore_unknown} and $self->{config}{ignore_unknown} > 1)
596             {
597             #$self->{param}{help} = 1;
598 0         0 $self->INT_error("unknown short parameter \"$s\" not in (".join('', sort keys %{$self->{long}}).")");
  0         0  
599             }
600             }
601             }
602             }
603 65         156 return \@names;
604             }
605              
606             # Works directly on last arguments to avoid passing things back and forth.
607             sub INT_settle_op # (lastoption, sign, name, op, val, args)
608             {
609 206     206 0 281 my $self = shift;
610 206         280 my $lastoption = shift;
611 206         291 my $sign = shift;
612 206         267 my $name = shift;
613             # op:$_[0] val:$_[1] args:$_[2]
614 206         364 my $flags = $self->{flags}{$name};
615             my $arrhash = defined $self->{type}{$name}
616 206 100       578 and grep {$_==$self->{type}{$name}} ($array, $hash);
  410         933  
617              
618             # First settle a possibly enforced argument that has to follow.
619             # Then call the custom callback that could change things
620              
621 206 100 100     823 if(defined $_[0] and $arrhash)
    100 100        
622             {
623             # -a/,/=bla and -a/,/bla are equivalent, as is -a/,/ bla
624 158 100 100     439 if($_[0] eq '/' and $_[1] =~ m:(./)(=?)(.*):)
625             {
626 16         44 $_[0] .= $1.$2;
627 16 100 66     62 $_[1] = ($3 eq '' and $2 eq '') ? undef : $3;
628 16 100 100     55 $_[0] .= '='
629             if($2 eq '' and defined $_[1]);
630             }
631 158 100 66     379 if($_[0] =~ m:^/./$: and $flags & $arg)
632             {
633 8 50       14 unless(@{$_[2]})
  8         22  
634             {
635             $self->INT_error( "Array/hash missing explicit argument: $self->{longprefix}$name"
636 0 0       0 . ($self->{short}{$name} ne '' ? " ($self->{shortprefix}$self->{short}{$name})" : '') );
637 0         0 return;
638             }
639 8         16 $_[0] .= '=';
640 8         14 $_[1] = shift @{$_[2]};
  8         20  
641             }
642             } elsif(not defined $_[0] and $flags & $arg)
643             {
644 16 50 33     39 unless($lastoption and @{$_[2]})
  16         47  
645             {
646             $self->INT_error( "Parameter missing explicit argument: $self->{longprefix}$name"
647 0 0       0 . ($self->{short}{$name} ne '' ? " ($self->{shortprefix}$self->{short}{$name})" : '') );
648 0         0 return;
649             }
650 16         31 $_[0] = '=';
651 16         21 $_[1] = shift @{$_[2]};
  16         48  
652             }
653              
654             # Defined empty value with undefined operator is just confusing to the callback.
655 206 100       404 undef $_[1]
656             unless defined $_[0];
657              
658             # The callback that could modify things.
659              
660 206 100       442 if(defined $self->{call}{$name})
661             {
662 6         8 my $nname = $name;
663 6         25 my $ret = $self->{call}{$name}->($nname, $sign, $_[0], $_[1]);
664 6 100 66     47 if($ret or (not defined $nname or $nname ne $name))
      33        
665             {
666 1 50       4 $self->INT_error("Callback for $name returned an error: $ret")
667             if $ret; # otherwise intentional drop
668 1         2 undef $_[0];
669 1         2 return;
670             }
671             }
672              
673             # Final translation of operator.
674              
675 205 100       387 unless(defined $_[0])
676             {
677 30 50       57 if($flags & $count)
678             {
679 0 0       0 ($_[0], $_[1]) = $sign =~ /^-/ ? ('+=', 1) : ('=', 0);
680             }
681             else
682             {
683 30         45 $_[0] = '=';
684 30 50       108 $_[1] = $sign =~ /^-/ ? 1 : 0;
685             }
686             }
687 205 100       381 if($arrhash)
688             {
689             $_[0] =~ s:(^|[^\.])=$:$1.=:
690 204 100       758 if $self->{flags}{$name} & $append;
691             }
692             }
693              
694             # Record a operator and operand for given parameter.
695             # It is not checked if the operation makes sense.
696             sub INT_add_op
697             {
698 206     206 0 293 my $self = shift;
699 206         466 my ($name, $op, $val) = (shift, shift, shift);
700             $self->{ops}{$name} = []
701 206 100       562 unless defined $self->{ops}{$name};
702             return # undefined ops are intentionally dropped
703 206 100       409 unless defined $op;
704 205         654 $self->INT_verb_msg("name: $name op: $op (val: $val)\n");
705 205 100       1013 push(@{$self->{ops}{$name}}, ($op =~ /=$/ ? $op : $op.'='), $val);
  205         1094  
706             }
707              
708             # Step 1: parse command line
709             sub parse_args
710             {
711 66     66 1 112 my $self = shift;
712 66         100 my $args = shift;
713              
714 66         88 my $olderrs = @{$self->{errors}};
  66         119  
715 66         147 $self->{ops} = {};
716 66         112 $self->{printconfig} = 0;
717              
718 66 50 33     172 $self->{param}{help} = 1 if($self->{config}{gimme} and not @{$args}); #giving help when no arguments
  0         0  
719              
720             #regexes for option parsing
721 66         102 my $shorts = $shortex_strict;
722 66         94 my $longex = $longex_strict;
723 66         101 my $separator = '^--$'; #exactly this string means "Stop the parsing!"
724              
725 66 100       201 if($self->{config}{lazy})
726             {
727 15         24 $shorts = $shortex_lazy;
728 15         19 $longex = $longex_lazy;
729 15         25 $separator = '^-+$'; # Lazy about separators, too ... Any number of consecutive "-".
730             }
731              
732             # The argument parser, long/short parameter evaluation is similar, but separate.
733 66         106 while(@{$args})
  273         597  
734             {
735 208         658 $self->INT_verb_msg("parsing $args->[0]\n");
736 208         474 my $e = index($args->[0], "\n");
737 208         275 my $begin;
738 208         288 my $end = "";
739 208         262 my $name;
740 208 50       390 if($e >=0)
741             {
742 0         0 $begin = substr($args->[0],0,$e);
743 0         0 $end = substr($args->[0],$e);
744             }
745             else
746             {
747 208         322 $begin = $args->[0];
748             }
749 208 50 66     2710 if($begin =~ /$separator/o)
    100 100        
    100          
    100          
750             {
751 0         0 $self->INT_verb_msg("separator\n");
752 0         0 shift(@{$args});
  0         0  
753 0         0 last;
754             }
755             elsif( $begin =~ $shortarg
756             and defined ($name = $self->{long}{$1})
757             and $self->{flags}{$name} & $arg )
758             {
759 46         137 $self->INT_verb_msg("short with value\n");
760 46 100       135 my $op = $2 ne '' ? $2 : '=';
761 46         89 my $val = $3.$end;
762 46         64 shift @{$args};
  46         76  
763 46         125 $self->INT_settle_op(1, '-', $name, $op, $val, $args);
764 46         109 $self->INT_add_op($name, $op, $val);
765             }
766             elsif($begin =~ /$shorts/o)
767             {
768 65         176 my $sign = $2;
769 65 100       151 $sign = '-' if $sign eq '';
770 65         110 my $op = $5;
771 65 100       168 my $sname = defined $op ? $4 : $3;
772 65 100       170 my $val = (defined $6 ? $6 : '').$end;
773 65         158 $self->INT_verb_msg("a (set of) short one(s)\n");
774             # First settle which parameters are mentioned.
775             # This returns an empty list if one invalid option is present.
776             # Also, the case of a single argument-requiring short option leading
777             # a value is handled by redefining the value and operator
778 65         188 my $names = $self->INT_long_names($sname, $op, $val);
779 65 50       90 last unless @{$names};
  65         137  
780 65         135 shift @{$args}; # It is settled now that this is options.
  65         100  
781              
782 65         99 while(@{$names})
  134         324  
783             {
784 69         104 my $olderr = @{$self->{errors}};
  69         113  
785 69         102 my $name = shift @{$names};
  69         151  
786 69         89 my $lastoption = not @{$names};
  69         156  
787             # Only the last one gets the specified operation.
788 69 100       132 my $kop = $lastoption ? $op : undef;
789 69 100       132 my $kval = $lastoption ? $val : undef;
790 69         176 $self->INT_settle_op($lastoption, $sign, $name, $kop, $kval, $args);
791             $self->INT_add_op($name, $kop, $kval)
792 69 50       97 if(@{$self->{errors}} == $olderr);
  69         214  
793             }
794             }
795             elsif($begin =~ $longex)
796             {
797             #yeah, long option
798 96         212 my $olderr = @{$self->{errors}};
  96         195  
799 96 50       288 my $sign = defined $7 ? $7 : $2;
800 96 100       214 $sign = '--' if $sign eq '';
801 96 50       226 my $name = defined $8 ? $8 : $3;
802 96         338 $self->INT_verb_msg("param $name\n");
803 96         209 my $op = $5;
804 96 100       265 my $val = (defined $6 ? $6 : '').$end;
805 96 50 66     243 unless(exists $self->{param}{$name} or $self->{config}{accept_unknown})
806             {
807 6 50       14 if($self->{config}{fuzzy})
808             {
809 0         0 $self->INT_verb_msg("Stopping option parsing at unkown one: $name");
810 0         0 last;
811             }
812             else
813             {
814 6 100 100     24 unless($self->{config}{ignore_unknown} and $self->{config}{ignore_unknown} > 1)
815             {
816 5         18 $self->INT_error("Unknown parameter (long option): $name");
817             }
818             }
819             }
820 96         128 shift @{$args};
  96         154  
821             # hack for operators, regex may swallow the . in .=
822 96 50       504 unless($name =~ /$noop$/o)
823             {
824 0         0 $op = substr($name,-1,1).$op;
825 0         0 $name = substr($name,0,length($name)-1);
826             }
827             # On any error, keep parsing for giving the user a full list of errors,
828             # but do not process anything erroneous.
829             $self->INT_settle_op(1, $sign, $name, $op, $val, $args)
830 96 100       138 if(@{$self->{errors}} == $olderr);
  96         353  
831             $self->INT_add_op($name, $op, $val)
832 96 100       145 if(@{$self->{errors}} == $olderr);
  96         281  
833             }
834             else
835             {
836 1         5 $self->INT_verb_msg("No parameter, end.\n");
837 1         2 last;
838             } #was no option... consider the switch part over
839             }
840 66         179 $self->{bad_command_line} = not (@{$self->{errors}} == $olderrs)
841 66 50       163 unless $self->{bad_command_line};
842 66         318 return not $self->{bad_command_line};
843             }
844              
845             # Step 2: Read in configuration files.
846             sub use_config_files
847             {
848 63     63 1 105 my $self = shift;
849 63         80 my $olderr = @{$self->{errors}};
  63         108  
850             # Do operations on config file parameter first.
851 63         184 $self->INT_apply_ops('config');
852 63         93 my $newerr = @{$self->{errors}};
  63         104  
853 63 50       139 if($olderr != $newerr)
854             {
855 0         0 $self->{bad_command_line} = 1;
856 0         0 return 0;
857             }
858             # Now parse config file(s).
859 63         165 return $self->INT_parse_files();
860             }
861              
862             # Step 3: Apply command line parameters.
863             # This is complicated by accept_unknown > 2.
864             # I need to wait until config files had the chance to define something properly.
865             sub apply_args
866             {
867 62     62 1 105 my $self = shift;
868 62         80 my $olderrs = @{$self->{errors}};
  62         109  
869 62         86 for my $key (keys %{$self->{ops}})
  62         238  
870             {
871 144 50 66     397 if( not exists $self->{param}{$key}
      33        
872             and defined $self->{config}{accept_unknown}
873             and $self->{config}{accept_unknown} > 1 )
874             {
875 0         0 $self->define({long=>$key});
876             }
877 144 100       261 if(exists $self->{param}{$key})
    50          
878             {
879 143         310 $self->INT_apply_ops($key);
880             }
881             elsif(not $self->{config}{ignore_unknown})
882             {
883 0         0 $self->INT_error("Unknown long parameter \"$self->{longprefix}$key\"");
884             }
885             }
886 62         139 $self->{bad_command_line} = not (@{$self->{errors}} == $olderrs)
887 62 50       162 unless $self->{bad_command_line};
888 62         323 return not $self->{bad_command_line};
889             }
890              
891             # Step 4: Take final action.
892             sub final_action
893             {
894 67     67 1 159 my $self = shift;
895 67         91 my $end = shift;
896 67 100       178 return if($self->{config}{nofinals});
897              
898 27         48 my $handle = $self->{config}{output};
899 27 100       73 $handle = \*STDOUT
900             unless defined $handle;
901 27         119 my $exitcode = @{$self->{errors}}
902             ? ( $self->{bad_command_line}
903             ? $ex_usage
904 27 0       36 : ($self->{bad_config_file} ? $ex_config : $ex_software)
    0          
    50          
905             )
906             : 0;
907              
908 27 50       70 if($end)
909             {
910 0 0       0 if(@{$self->{errors}})
  0         0  
911             {
912 0         0 $self->INT_error("There have been errors in parameter parsing. You should seek --help.");
913             }
914             exit($exitcode)
915 0 0       0 unless $self->{config}{noexit};
916 0         0 return;
917             }
918              
919             #give the help (info text + option help) and exit when -h or --help was given
920 27 100 33     101 if($self->{param}{help})
    50          
    100          
921             {
922 15         40 $self->help();
923             exit($exitcode)
924 15 50       43 unless $self->{config}{noexit};
925             }
926             elsif(defined $self->{config}{version} and $self->{param}{version})
927             {
928 0         0 print $handle "$self->{config}{program} $self->{config}{version}\n";
929             exit($exitcode)
930 0 0       0 unless $self->{config}{noexit};
931             }
932             elsif($self->{printconfig})
933             {
934 1         6 $self->print_file($handle, ($self->{printconfig} > 1));
935             exit($exitcode)
936 1 50       11 unless $self->{config}{noexit};
937             }
938             }
939              
940             # Helper functions...
941              
942             # Produce a string showing the value of a parameter, for the help.
943             sub par_content
944             {
945 71     71 1 103 my $self = shift;
946 71         137 my $k = shift; # The parameter name.
947 71         94 my $format = shift; # formatting choice
948 71         94 my $indent = shift; # indent value for dumper
949 71         89 my $mk = shift; # value selector: 'param' or 'default', usually
950 71 50       137 $mk = 'param'
951             unless defined $mk;
952 71 100 66     236 if(not defined $format or $format eq 'dump')
    50          
953             {
954 68 50       99 if(eval { require Data::Dumper })
  68         1005  
955             {
956 11     11   100 no warnings 'once'; # triggers when embedding the module
  11         24  
  11         98859  
957 68         7167 local $Data::Dumper::Terse = 1;
958 68         92 local $Data::Dumper::Deepcopy = 1;
959 68         91 local $Data::Dumper::Indent = $indent;
960 68 50       131 $Data::Dumper::Indent = 0 unless defined $Data::Dumper::Indent;
961 68         85 local $Data::Dumper::Sortkeys = 1;
962 68         80 local $Data::Dumper::Quotekeys = 0;
963 68         259 return Data::Dumper->Dump([$self->{$mk}{$k}]);
964             }
965 0         0 else{ return "$self->{$mk}{$k}"; }
966             }
967             elsif($format eq 'lines')
968             {
969 3 50       15 return "\n" unless(defined $self->{$mk}{$k});
970 3 100       26 if($self->{type}{$k} == $array)
    100          
971             {
972 1 50       3 return "" unless @{$self->{$mk}{$k}};
  1         5  
973 1         2 return join("\n", @{$self->{$mk}{$k}})."\n";
  1         8  
974             }
975             elsif($self->{type}{$k} == $hash)
976             {
977 1         7 my $ret = '';
978 1         4 for my $sk (sort keys %{$self->{$mk}{$k}})
  1         5  
979             {
980 2         17 $ret .= "$sk=$self->{$mk}{$k}{$sk}\n";
981             }
982 1         8 return $ret;
983             }
984 1         5 else{ return "$self->{$mk}{$k}\n"; }
985 0         0 } else{ $self->INT_error("unknown par_content format: $format"); }
986             }
987              
988             # Fill up with given symbol for pretty indent.
989             sub INT_indent_string
990             {
991 48     48 0 91 my ($indent, $prefill, $filler) = @_;
992 48 50       97 $filler = '.'
993             unless defined $filler;
994 48 100 66     251 return ($indent > $prefill)
    100          
995             ? ( ($prefill and ($indent-$prefill>2)) ? $filler : ' ')
996             x ($indent - $prefill - 1) . ' '
997             : '';
998             }
999              
1000             # simple formatting of some lines (breaking up with initial and subsequent indendation)
1001             sub INT_wrap_print
1002             {
1003 87     87 0 187 my ($handle, $itab, $stab, $length) = (shift, shift, shift, shift);
1004 87 50       165 return unless @_;
1005             # Wrap if given line length can possibly hold the input.
1006              
1007             # Probably I will make this more efficient in future, probably also
1008             # dropping Text::Wrap instead of fighting it. Or use some POD formatting?
1009 87         238 my @paragraphs = split("\n", join("", @_), -1);
1010             # Drop trailing empty lines. We do not wrap what.
1011 87   66     345 while(@paragraphs and $paragraphs[$#paragraphs] eq '')
1012             {
1013 6         21 pop @paragraphs;
1014             }
1015 87         135 my $first = 1;
1016 87         173 print $handle $itab;
1017 87 50       152 print $handle "\n"
1018             unless @paragraphs;
1019 87         116 my $line = undef;
1020 87         117 my $llen = length($itab);
1021 87         107 my $slen = length($stab);
1022 87   33     225 my $can_wrap = $length > $llen && $length > $slen;
1023 87         164 while(@paragraphs)
1024             {
1025 131         204 my $p = shift(@paragraphs);
1026             # Try to handle command line/code blocks by not messing with them.
1027 131 100       334 if($p =~ /^\t/)
    100          
    50          
1028             {
1029 3 50       8 print $handle $line."\n"
1030             if $llen;
1031 3         9 print $handle $stab.$p."\n";
1032 3         4 $line = '';
1033 3         9 $llen = 0;
1034             }
1035             elsif($p eq '')
1036             {
1037 33 100       64 $line = '' # Just for the warnings.
1038             unless defined $line;
1039 33         61 print $handle $line."\n";
1040 33         44 $line = '';
1041 33         61 $llen = 0;
1042             }
1043             elsif($can_wrap)
1044             {
1045 95         698 my @words = split(/\s+/, $p);
1046 95   100     301 while($llen>$slen or @words)
1047             {
1048 1326         1885 my $w = shift(@words);
1049 1326         1633 my $l = length($w);
1050 1326 100 100     3181 if(not $l or $l+$llen >= $length)
1051             {
1052 220         417 print $handle $line."\n";
1053 220         278 $llen = 0;
1054 220         263 $line = '';
1055 220         253 $first = 0;
1056             }
1057 1326 100       2182 if($l)
1058             {
1059 1231 100       2153 unless(defined $line)
    100          
1060             {
1061 60         84 $line = '';
1062             }
1063 0         0 elsif($llen)
1064             {
1065 1011         1264 $line .= ' ';
1066 1011         1182 $llen += 1;
1067             }
1068             else
1069             {
1070 160         219 $line = $stab;
1071 160         177 $llen = $slen;
1072             }
1073 1231         1523 $line .= $w;
1074 1231         2177 $llen += $l;
1075             }
1076             }
1077 95         134 $line = '';
1078 95         334 $llen = 0;
1079             }
1080             else # wrapping makes no sense
1081             {
1082 0 0       0 print $handle (defined $line ? $line : '').$p."\n";
1083 0         0 $line = '';
1084 0         0 $llen = 0;
1085             }
1086             }
1087             }
1088              
1089             # Produce wrapped text from POD.
1090             sub INT_pod_print
1091             {
1092 0     0 0 0 my ($handle, $length) = (shift, shift);
1093 0         0 require Pod::Text;
1094 0         0 my $pod = Pod::Text->new(width=>$length);
1095 0         0 $pod->output_fh($handle);
1096 0         0 $pod->parse_string_document($_[0]);
1097             }
1098              
1099             # Produce POD output from text.
1100             sub print_pod
1101             {
1102 4     4 1 9 my $self = shift;
1103 4         6 my $handle = $self->{config}{output};
1104 4 50       9 $handle = \*STDOUT unless defined $handle;
1105              
1106 4         9 my $prog = escape_pod($self->{config}{program});
1107 4         14 my $tagline = escape_pod($self->{config}{tagline});
1108             # usage line is unescaped
1109 4         8 my $usage = $self->{config}{usage};
1110 4         10 my @desc = (); # usage might come from here
1111             @desc = split("\n", $self->{config}{info}, -1)
1112 4 100       14 if(defined $self->{config}{info});
1113              
1114 4 100 66     18 $tagline = escape_pod(shift @desc)
1115             unless(defined $tagline or not defined $prog);
1116              
1117 4   100     20 while(@desc and $desc[0] =~ /^\s*$/){ shift @desc; }
  1         7  
1118              
1119 4 100 100     18 unless(defined $usage or not @desc)
1120             {
1121 1 50       10 if(lc($desc[0]) =~ /^\s*usage:\s*(.*\S?)\s*$/)
1122             {
1123 1 50       5 $usage = $1 if $1 ne '';
1124 1         3 shift(@desc);
1125 1   33     12 while(@desc and $desc[0] =~ /^\s*$/){ shift @desc; }
  0         0  
1126              
1127             # if the real deal follows on a later line
1128 1 50 33     8 if(not defined $usage and @desc)
1129             {
1130 1         2 $usage = shift @desc;
1131 1         6 $usage =~ s/^\s*//;
1132 1         8 $usage =~ s/\s*$//;
1133 1   66     7 while(@desc and $desc[0] =~ /^\s*$/){ shift @desc; }
  1         8  
1134             }
1135             }
1136             }
1137 4 50       10 if(defined $prog)
1138             {
1139 4         14 print $handle "\n=head1 NAME\n\n$prog";
1140 4 50       13 print $handle " - $tagline" if defined $tagline;
1141 4         7 print $handle "\n";
1142             }
1143 4 100       9 if(defined $usage)
1144             {
1145 2         11 print $handle "\n=head1 SYNOPSIS\n\n";
1146 2         14 print $handle "\t$_\n" for(split("\n", $usage));
1147             }
1148 4 100 66     17 if(@desc or defined $self->{config}{infopod})
1149             {
1150 1         6 print $handle "\n=head1 DESCRIPTION\n\n";
1151 1 50       4 if(defined $self->{config}{infopod})
1152             {
1153 0         0 print $handle $self->{config}{infopod};
1154             } else
1155             {
1156 1         2 for(@desc){ print $handle escape_pod($_), "\n"; }
  1         3  
1157             }
1158             }
1159 4 50       9 my $nprog = defined $prog ? $prog : 'some_program';
1160              
1161 4         9 print $handle "\n=head1 PARAMETERS\n\n";
1162 4         6 print $handle "These are the general rules for specifying parameters to this program:\n";
1163 4         8 print $handle "\n\t$nprog ";
1164 4 50       9 if($self->{config}{lazy})
1165             {
1166 4         11 print $handle escape_pod($example{lazy}),"\n\n";
1167 4         10 print $handle escape_pod($lazyinfo),"\n";
1168             }
1169             else
1170             {
1171 0         0 print $handle escape_pod($example{normal}),"\n";
1172             }
1173 4         10 print $handle "\n";
1174 4         6 for(@morehelp)
1175             {
1176 32         54 print $handle escape_pod($_);
1177             }
1178 4         9 print $handle "\n\nThe available parameters are these, default values (in Perl-compatible syntax) at the time of generating this document following the long/short names:\n";
1179 4         6 print $handle "\n=over 2\n";
1180 4         9 for my $k (sort keys %{$self->{param}})
  4         24  
1181             {
1182             print $handle "\n=item B<".escape_pod($k).">".
1183 28 100       56 ($self->{short}{$k} ne '' ? ', B<'.escape_pod($self->{short}{$k}).'>' : '').
1184             " ($typename[$self->{type}{$k}])".
1185             "\n\n";
1186 28 100       76 my @content = $k eq 'help'
1187             ? 0
1188             : split("\n", $self->par_content($k, 'dump', 1));
1189 28         1152 print $handle "\t$_\n" for(@content);
1190 28         51 print $handle "\n".escape_pod(${$self->{help}{$k}})."\n";
  28         62  
1191 28 100       126 print $handle "\n".$self->{extrahelp}."\n" if($k eq 'help');
1192             }
1193 4         10 print $handle "\n=back\n";
1194              
1195             # closing with some simple sections
1196 4         47 my @podsections;
1197             # user-provided
1198 4         11 push(@podsections, @{$self->{config}{extrapod}})
1199 4 50       17 if(defined $self->{config}{extrapod});
1200              
1201             # standard
1202 4         15 for( ['BUGS','bugs'], ['AUTHOR', 'author'], ['LICENSE AND COPYRIGHT', 'copyright'] )
1203             {
1204             push(@podsections, {head=>$_->[0], body=>$self->{config}{$_->[1]}})
1205 12 100       43 if(defined $self->{config}{$_->[1]});
1206             }
1207              
1208 4         11 for my $ps (@podsections)
1209             {
1210 16         31 print $handle "\n=head1 $ps->{head}\n";
1211 16 100       43 print $handle "\n",$ps->{verbatim} ? $ps->{body} : escape_pod($ps->{body}),"\n";
1212             }
1213              
1214 4         17 print $handle "\n=cut\n";
1215             }
1216              
1217             sub _pm
1218             {
1219 0     0   0 my $self = shift;
1220 0         0 my $k = shift;
1221             return ( ($self->{type}{$k} == $scalar
1222             and ( $self->{flags}{$k} & $switch
1223             or (defined $self->{arg}{$k} and $self->{arg}{$k} eq '') ))
1224 0 0 0     0 and ($self->{default}{$k}) ) ? '+' : '-';
1225             }
1226              
1227             # Well, _the_ help.
1228             sub help
1229             {
1230 15     15 1 19 my $self = shift;
1231 15         30 my $handle = $self->{config}{output};
1232 15 50       25 $handle = \*STDOUT unless defined $handle;
1233             my $indent = $self->{config}{posixhelp}
1234             ? $self->{arglength} + 7 # -s, --name[=arg]
1235 15 50       53 : $self->{length} + 4; # longest long name + ", s " (s being the short name)
1236              
1237             # Trying to format it fitting the screen to ease eye navigation in large parameter lists.
1238 15         24 my $linewidth = 0;
1239 15 50       33 if(defined $self->{config}{linewidth})
    0          
    0          
1240             {
1241 15         27 $linewidth = $self->{config}{linewidth};
1242             }
1243 0         0 elsif(eval { require Term::ReadKey })
1244             {
1245             # This can die on me! So run it in eval.
1246 0         0 my @s = eval { Term::ReadKey::GetTerminalSize(); };
  0         0  
1247 0 0       0 $linewidth = $s[0] if @s;
1248             }
1249 0         0 elsif(eval { require IPC::Run })
1250             {
1251 0         0 my ($in, $err);
1252 0 0       0 if(eval { IPC::Run::run([qw(tput cols)], \$in, \$linewidth, \$err) })
  0         0  
1253             {
1254 0         0 chomp($linewidth);
1255 0         0 $linewidth += 0; # ensure a number;
1256             }
1257             }
1258 15 50       27 my $prosewidth = $linewidth > 80 ? 80 : $linewidth;
1259              
1260 15 100       60 if($self->{param}{help} =~ /^(-\d+),?(.*)$/)
1261             {
1262 9         25 my $code = $1;
1263 9         26 my @keys = split(',', $2);
1264 9         19 my $badkeys;
1265 9         20 for(@keys)
1266             {
1267 5 50       13 unless(exists $self->{param}{$_})
1268             {
1269 0         0 ++$badkeys;
1270 0         0 $self->INT_error("Parameter $_ is not defined!");
1271             }
1272             }
1273             return
1274 9 50       18 if $badkeys;
1275              
1276 9 100       57 if($code == -1)
    100          
    100          
    100          
    100          
    50          
1277             { # param list, wrapped to screen
1278             INT_wrap_print( $handle, '', "\t", $linewidth, "List of parameters: "
1279 1         4 , join(' ', sort keys %{$self->{param}}) );
  1         10  
1280             }
1281             elsif($code == -2)
1282             { # param list, one one each line
1283 1         3 print $handle join("\n", sort keys %{$self->{param}})."\n";
  1         11  
1284             }
1285             elsif($code == -3)
1286             { # param list, one one each line, without builtins
1287 1         4 my $builtin = builtins($self->{config});
1288 1         8 my @pars = sort grep {not $builtin->{$_}} keys %{$self->{param}};
  7         21  
  1         5  
1289 1 50       12 print $handle join("\n", @pars)."\n" if @pars;
1290             }
1291             elsif($code == -10)
1292             { # dump values, suitable to eval to a big array
1293 1         2 my $first = 1;
1294 1         4 for(@keys)
1295             {
1296 2 100       65 if($first){ $first=0; }
  1         2  
1297 1         3 else{ print $handle ", "; }
1298 2         7 print $handle $self->par_content($_, 'dump', 1);
1299             }
1300             }
1301             elsif($code == -11)
1302             { # line values
1303 1         4 for(@keys){ print $handle $self->par_content($_, 'lines'); }
  3         7  
1304             }
1305             elsif($code == -100)
1306             {
1307 4         11 $self->print_pod();
1308             }
1309             else
1310             {
1311 0         0 $self->INT_error("bogus help code $code");
1312 0         0 INT_wrap_print(\*STDERR, '', '', $linewidth, "\nHelp for help:\n", ${$self->{help}{help}});
  0         0  
1313 0         0 INT_wrap_print(\*STDERR, '','', $linewidth, $self->{extrahelp});
1314             }
1315 9         58 return;
1316             }
1317              
1318             # Anything with at least two characters could be a parameter name.
1319 6 50       15 if($self->{param}{help} =~ /../)
1320             {
1321 0         0 my $k = $self->{param}{help};
1322 0 0       0 if(exists $self->{param}{$k})
1323             {
1324 0         0 my $val = $self->{arg}{$k};
1325 0         0 my $s = $self->{short}{$k};
1326 0         0 my $type = $self->{type}{$k};
1327 0         0 my $flags = $self->{flags}{$k};
1328 0         0 my $pm = $self->_pm($k);
1329 0 0       0 $val = 'val' unless defined $val;
1330             print $handle $self->{config}{posixhelp}
1331 0 0       0 ? "Option:\n\t"
    0          
    0          
1332             . ($s ne '' ? "$pm$s, " : '')
1333             . $pm.$pm.$k."\n"
1334             : "Parameter:\n\t$k".($s ne '' ? ", $s" : '')."\n";
1335 0         0 my $c = $self->par_content($k, 'dump', 1);
1336 0         0 $c =~ s/\n$//;
1337 0         0 $c =~s/\n/\n\t/g;
1338 0         0 print $handle "\nValue:\n\t$c\n";
1339 0         0 my $dc = $self->par_content($k, 'dump', 1, 'default');
1340 0         0 $dc =~ s/\n$//;
1341 0         0 $dc =~s/\n/\n\t/g;
1342 0 0       0 print $handle "\nDefault value: "
1343             . ($c eq $dc ? "same" : "\n\t$dc")
1344             . "\n";
1345 0         0 print $handle "\nSyntax notes:\n";
1346 0         0 my $notes = '';
1347 0 0       0 if($type eq $scalar)
    0          
1348             {
1349 0         0 my @switchcount;
1350 0 0 0     0 push(@switchcount, "switch")
1351             if($flags & $switch or not $flags & $count);
1352 0 0 0     0 push(@switchcount, "counter")
1353             if($flags & $count or not $flags & $switch);
1354 0 0       0 $notes .= $flags & $arg
    0          
    0          
1355             ? "This is a scalar parameter that requires an explicit"
1356             . " argument value."
1357             . " You can choose the canonical form --$k=$val or let"
1358             . " the value follow like --$k $val"
1359             . ( $s ne ''
1360             ? " (short option only: both -$s $val and -$s$val are valid)"
1361             : '' )
1362             . '.'
1363             : $val ne ''
1364             ? "This is a scalar parameter with an optional argument"
1365             . " value than can only be provided by attaching it"
1366             . " with an equal sign or another operator,"
1367             . " e.g. --$k=$val."
1368             : "This is a parameter intended as a ".join(" or ", @switchcount)
1369             . ", providing an argument value is not required.";
1370 0 0       0 $notes .= " The value can be built"
1371             . " in multiple steps via operators for appending (--$k.=) or"
1372             . " arithmetic (--$k+= for addition, --$k-=, --$k*=, and --$k/= for"
1373             . " subtraction, multiplication, and division)."
1374             unless $flags & $switch;
1375 0 0 0     0 $notes .= "\n\nThe above applies to the short -$s, too, with the"
1376             . " addition that the equal sign can be dropped for"
1377             . " two-character operators, like -$s+3."
1378             if(not $flags & $switch and $s ne '');
1379 0 0       0 $notes .= $flags & $count
    0          
    0          
    0          
    0          
    0          
1380             ? "\n\nEach appearance of --$k "
1381             . ($s ne '' ? "and -$s " : '')
1382             . "increments the value by 1, while ++$k "
1383             . ($s ne '' ? "and +$s " : '')
1384             . "set it to zero (false)."
1385             : "\n\nJust --$k"
1386             . ($s ne '' ? " or -$s " : '')
1387             . "sets the value to 1 (engages the switch), while ++$k"
1388             . ($s ne '' ? " or +$s " : '')
1389             . "sets the value to 0 (disengages the switch)."
1390             unless($flags & $arg);
1391 0         0 } elsif(grep {$_ == $type} ($array, $hash))
1392             {
1393 0 0       0 $notes .= $type == $hash
1394             ? 'This is a hash (name-value store) parameter. An option argument'
1395             . ' consists of = to'
1396             . ' store the actual value with for given key.'
1397             : 'This is an array parameter.';
1398 0 0       0 $notes .= ' Assigned values are appended even if the append operator .='
1399             . ' is not used explicitly.'
1400             if $flags & $append;
1401 0 0       0 $notes .= $flags & $arg
1402             ? ' An explicit argument to the option is required.'
1403             . " It is equivalent to specify --$k=$val or --$k $val."
1404             . " A value is explcitly appended to the "
1405             . "$typename[$type] via --$k.=$val."
1406             : " An option argument can be given via --$k=$val or --$k.=$val to "
1407             . " explicitly append to the $typename[$self->{type}{$k}].";
1408 0 0       0 $notes .= ' For this parameter, the appending operator .= is implicit.'
1409             if $flags & $append;
1410 0 0       0 $notes .= "\n\nThe above applies also to the short option -$s"
    0          
1411             . ($flags & $arg
1412             ? ", with added possibility of directly attaching the argument via -$s$val."
1413             : ".")
1414             if $s ne '';
1415 0         0 $notes .= "\n\n";
1416 0         0 $notes .= "Multiple values can be provided with a single separator character"
1417             . " that is specified between slashes, like --$k/,/=a,b,c.";
1418             } else
1419             {
1420 0         0 $notes .= 'I do not know what kind of parameter that is.'
1421             }
1422             $notes .= "\n\n"
1423             . 'Lazy option syntax is active: you can drop one or both of the'
1424             . ' leading \'--\', also the \'-\' of the short form. Beware: just'
1425             . ' -'.$k.' is a group of short options, while -'.$k.'=foo would be'
1426             . ' an assignment to '.$k.'.'
1427 0 0       0 if $self->{config}{lazy};
1428 0         0 INT_wrap_print( $handle, "\t", "\t", $prosewidth, $notes);
1429 0         0 print $handle "\nHelp:";
1430 0 0       0 if(${$self->{help}{$k}} ne '')
  0         0  
1431             {
1432 0         0 print $handle "\n";
1433 0         0 INT_wrap_print($handle, "\t","\t", $prosewidth, ${$self->{help}{$k}});
  0         0  
1434             } else
1435             {
1436 0         0 print $handle " none";
1437             }
1438             INT_wrap_print($handle, "\t","\t", $prosewidth, $self->{extrahelp})
1439 0 0       0 if $k eq 'help';
1440 0         0 print "\n";
1441             } else
1442             {
1443 0         0 $self->INT_error("Parameter $k is not defined!");
1444             }
1445 0         0 return;
1446             }
1447              
1448 6 50       18 if($self->{param}{help} =~ /\D/)
1449             {
1450 0         0 $self->INT_error("You specified an invalid help level (parameter name needs two characters minimum).");
1451 0         0 return;
1452             }
1453              
1454 6 50       16 my $vst = (defined $self->{config}{version} ? "v$self->{config}{version} " : '');
1455 6 100       13 if(defined $self->{config}{tagline})
1456             {
1457 3         17 INT_wrap_print($handle, '', '', $prosewidth, "\n$self->{config}{program} ${vst}- ",$self->{config}{tagline});
1458 3 100       10 if(defined $self->{config}{usage})
1459             {
1460 1         3 print $handle "\nUsage:\n";
1461 1         3 INT_wrap_print($handle, "\t","\t", $prosewidth, $self->{config}{usage});
1462             }
1463 3 100       10 if(defined $self->{config}{info})
    50          
1464             {
1465 1         8 INT_wrap_print($handle, '', '', $prosewidth, "\n".$self->{config}{info});
1466             } elsif(defined $self->{config}{infopod})
1467             {
1468 0         0 print {$handle} "\n";
  0         0  
1469 0         0 INT_pod_print($handle, $prosewidth, $self->{config}{infopod});
1470             }
1471             INT_wrap_print($handle, '', '', $prosewidth, "\n$self->{config}{copyright}")
1472 3 50       12 if defined $self->{config}{copyright};
1473             }
1474             else
1475             {
1476 3 50       8 if(defined $self->{config}{info})
    0          
1477             {
1478             INT_wrap_print($handle, '', '', $prosewidth, "\n$self->{config}{program} ${vst}- ".$self->{config}{info})
1479 3         16 } elsif(defined $self->{config}{infopod})
1480             {
1481 0         0 print {$handle} "\n$self->{config}{program} ${vst}\n";
  0         0  
1482 0         0 INT_pod_print($handle, $prosewidth, $self->{config}{infopod});
1483             }
1484              
1485             INT_wrap_print($handle, '', '', $prosewidth, "\n$self->{config}{copyright}")
1486 3 50       17 if defined $self->{config}{copyright};
1487             }
1488              
1489 6         18 my $level = 0+$self->{param}{help};
1490 6         9 my $tablehead = '';
1491              
1492 6 50       13 if($self->{config}{posixhelp})
1493             {
1494 0         0 INT_wrap_print( $handle, '', '', $prosewidth
1495             , "\nShort options can be grouped and non-optional arguments"
1496             . " can follow without equal sign. Force options end with '--'."
1497             . " Switches on with -, off with +."
1498             . " See --help=par for details on possible advanced syntax with option"
1499             . " --par." );
1500             } else
1501             {
1502 6         11 my $preprint = "NAME, SHORT ";
1503 6 50       11 $indent = length($preprint)
1504             if length($preprint) > $indent;
1505 6         14 $tablehead = $preprint
1506             . INT_indent_string($indent, length($preprint))."VALUE [# DESCRIPTION]\n";
1507 6         15 INT_wrap_print( $handle, '', '', $prosewidth
1508             , "\nGeneric parameter example (list of real parameters follows):\n" );
1509 6         10 print $handle "\n";
1510 6 50       23 if($self->{config}{lazy})
1511             {
1512 6         25 print $handle "\t$self->{config}{program} $example{lazy}\n";
1513 6 100       19 if($level > 1)
1514             {
1515 2         6 INT_wrap_print($handle, '', '', $prosewidth, "\n", $lazyinfo);
1516             }
1517             }
1518             else
1519             {
1520 0         0 print $handle "\t$self->{config}{program} $example{normal}\n";
1521             }
1522 6         13 print $handle "\n";
1523 6 100       13 if($level > 1)
1524             {
1525 2         6 INT_wrap_print($handle, '', '', $prosewidth, @morehelp)
1526             } else
1527             { # Don't waste so many lines by default.
1528 4         11 INT_wrap_print($handle, '', '', $prosewidth
1529             , "Just mentioning -s equals -s=1 (true), while +s equals -s=0 (false)."
1530             , " The separator \"--\" stops option parsing."
1531             )
1532             }
1533 6         17 INT_wrap_print($handle, '', '', $prosewidth, "\nRecognized parameters:");
1534             }
1535 6         20 my @hidden_nonshort;
1536             my @hidden_level;
1537 6 50       20 if($self->{config}{ordered})
1538             {
1539 0         0 foreach my $s (@{$self->{section}})
  0         0  
1540             {
1541 0 0       0 if($level >= $s->{minlevel})
1542             {
1543             INT_wrap_print( $handle, '', '', $prosewidth, "\n".$s->{section} )
1544 0 0       0 if($s->{section} ne '');
1545 0         0 INT_wrap_print( $handle, '', '', $prosewidth, ${$s->{help}} )
1546 0 0       0 if(${$s->{help}} ne '');
  0         0  
1547 0         0 print $handle "\n".$tablehead;
1548             }
1549             # Go through the parameters at least to count the hidden ones.
1550 0         0 for my $k (@{$s->{member}})
  0         0  
1551             {
1552 0         0 $self->INT_param_help( $handle, $k, $level, $prosewidth, $indent
1553             , \@hidden_nonshort, \@hidden_level );
1554             }
1555             }
1556             } else
1557             {
1558 6         19 print $handle "\n".$tablehead;
1559 6         9 for my $k ( sort keys %{$self->{param}} )
  6         49  
1560             {
1561 42         123 $self->INT_param_help( $handle, $k, $level, $prosewidth, $indent
1562             , \@hidden_nonshort, \@hidden_level );
1563             }
1564             }
1565 6 50       16 if(@hidden_nonshort)
1566             {
1567 0         0 print $handle "\n";
1568 0 0       0 if($level> 1)
1569             {
1570 0         0 INT_wrap_print( $handle, '', '', $prosewidth,
1571             "Hidden parameters intended primarily for config files:" );
1572 0         0 INT_wrap_print( $handle, "\t", "\t", $prosewidth, "@hidden_nonshort" );
1573             } else
1574             {
1575 0 0       0 INT_wrap_print( $handle, '', '', $prosewidth, 'There'
1576             . ( @hidden_nonshort == 1
1577             ? 'is one hidden config file parameter'
1578             : 'are '.(0+@hidden_nonshort).' hidden config file parameters' ) );
1579             }
1580             }
1581 6 50       14 if(@hidden_level)
1582             {
1583 0         0 print $handle "\n";
1584 0 0       0 if($level > 1)
1585             {
1586 0         0 INT_wrap_print( $handle, '', "\t", $prosewidth
1587             , "Parameters explained at higher help levels: @hidden_level" );
1588             } else
1589             {
1590 0 0       0 INT_wrap_print( $handle, '', '', $prosewidth, "There "
1591             . ( @hidden_level == 1
1592             ? 'is one parameter'
1593             : 'are '.(0+@hidden_level).' parameters' )
1594             . ' explained at higher help levels.' );
1595             }
1596             }
1597 6         21 print $handle "\n";
1598             }
1599              
1600             sub INT_param_help
1601             {
1602 42     42 0 57 my $self = shift;
1603 42         86 my ($handle, $k, $level, $linewidth, $indent, $hidden_nonshort, $hidden_level) = @_;
1604              
1605             # Reasons to hide from current printout.
1606 42         54 my $hide = 0;
1607 42 0 33     93 if( $self->{config}{hidenonshort} and $self->{short}{$k} eq ''
      0        
      33        
1608             and not ($k eq 'version' and defined $self->{config}{version}) )
1609             {
1610 0         0 ++$hide;
1611 0         0 push(@{$hidden_nonshort}, $k);
  0         0  
1612             }
1613 42 50       91 if($level < $self->{level}{$k})
1614             {
1615 0         0 ++$hide;
1616 0         0 push(@{$hidden_level}, $k);
  0         0  
1617             }
1618             return
1619 42 50       83 if $hide;
1620              
1621 42 50       78 if($self->{config}{posixhelp})
1622             {
1623 0         0 $self->INT_param_help_posix($handle, $k, $linewidth, $indent);
1624             } else
1625             {
1626 42         83 $self->INT_param_help_table($handle, $k, $linewidth, $indent);
1627             }
1628             }
1629              
1630             sub INT_param_help_table
1631             {
1632 42     42 0 55 my $self = shift;
1633 42         65 my ($handle, $k, $linewidth, $indent) = @_;
1634            
1635             # This format will change, I presume.
1636             # This is the parameter syntax-agnostic print, where that
1637             # information is shown elsewhere. People are used to
1638             # -s, --long= Blablabla [default]
1639             # Let's go there.
1640             # long, s
1641 42         64 my $prefix = $k;
1642 42 100       124 $prefix .= ", $self->{short}{$k}" if($self->{short}{$k} ne '');
1643 42         57 $prefix .= ' ';
1644 42         98 my $content = $self->par_content($k, 'dump', 0);
1645 42         1681 my $stab = ' ' x $indent;
1646 42         64 my @help = split("\n", ${$self->{help}{$k}});
  42         134  
1647             push(@help, split("\n", $self->{extrahelp}))
1648             if( $k eq 'help' and $self->{param}{help} > 1
1649 42 100 100     139 and defined $self->{extrahelp} );
      66        
1650 42   33     195 $help[0] = $content.(@help and $help[0] ne '' ? " # $help[0]" : '');
1651 42         111 for(my $i=0; $i<@help; ++$i)
1652             {
1653 52 100       134 INT_wrap_print( $handle, ( $i==0
1654             ? $prefix.INT_indent_string($indent, length($prefix))
1655             : $stab ) , $stab, $linewidth, $help[$i] );
1656             }
1657             }
1658              
1659             sub INT_param_help_posix
1660             {
1661 0     0 0 0 my $self = shift;
1662 0         0 my ($handle, $k, $linewidth, $indent) = @_;
1663 0         0 my $stab = ' ' x $indent;
1664 0         0 my $prefix = '';
1665 0         0 my $pm = $self->_pm($k);
1666 0 0       0 $prefix = $self->{short}{$k} ne '' ? "$pm$self->{short}{$k}, " : ' ';
1667 0         0 $prefix .= $pm.$pm.$self->INT_namearg($k).' ';
1668 0         0 my @help = split("\n", ${$self->{help}{$k}});
  0         0  
1669             push(@help, split("\n", $self->{extrahelp}))
1670 0 0 0     0 if($k eq 'help' and $self->{param}{help} > 1);
1671             # Splitting the empty string does not give an array with one empty string,
1672             # but an empty array instead.
1673 0 0       0 push(@help, '')
1674             unless @help;
1675 0 0       0 $help[0] = 'disable: '.$help[0]
1676             if $pm eq '+';
1677 0         0 for(my $i=0; $i<@help; ++$i)
1678             {
1679 0 0       0 INT_wrap_print( $handle, ( $i==0
1680             ? $prefix.INT_indent_string($indent, length($prefix), ' ')
1681             : $stab ) , $stab, $linewidth, $help[$i] );
1682             }
1683             }
1684              
1685             # Have to cover two use cases:
1686             # 1. Have defined param space, just want values.
1687             # 2. Want to construct param space from file.
1688             # Parse configured config files.
1689             sub INT_parse_files
1690             {
1691 63     63 0 99 my $self = shift;
1692 63         91 my $construct = shift;
1693              
1694 63         89 for my $file (@{$self->{param}{config}})
  63         162  
1695             {
1696 10 100       29 return 0 unless $self->parse_file($file, $construct);
1697             }
1698 62         253 return 1;
1699             }
1700              
1701             # check if it's existing and not a directory
1702             # _not_ explicitly checking for files as that would exclude things that otherwise would work as files just fine
1703             sub INT_filelike
1704             {
1705 1302   66 1302 0 14026 return (-e $_[0] and not -d $_[0])
1706             }
1707              
1708             # Look for given config file name in configured directory or search for it in
1709             # the list of likely places. Appending the ending .conf is also tried.
1710             sub INT_find_config
1711             {
1712 101     101 0 449 my $self = shift;
1713 101         150 my $name = shift;
1714              
1715 101 100       611 return $name if File::Spec->file_name_is_absolute($name);
1716              
1717             # Let's special-case the current working directory. Do not want to spell it
1718             # out for the directory search loop.
1719             # But yes, it is a bit of duplication with the .conf addition. Sorry.
1720 86 100       208 return $name if(INT_filelike($name));
1721 84 50       354 return "$name.conf" if(INT_filelike("$name.conf"));
1722              
1723 84         237 my $path;
1724             my @dirs;
1725             #determine directory to search config files in
1726 84 50       231 if(defined $self->{config}{confdir})
1727             {
1728 0         0 @dirs = ($self->{config}{confdir});
1729             }
1730             else
1731             {
1732             @dirs = (
1733             File::Spec->catfile($ENV{HOME},'.'.$self->{config}{program})
1734             ,File::Spec->catfile($Bin,'..','etc',$self->{config}{program})
1735             ,File::Spec->catfile($Bin,'..','etc')
1736             ,File::Spec->catfile($Bin,'etc')
1737             ,$Bin
1738             ,File::Spec->catfile($ENV{HOME},'.config',$self->{config}{program})
1739 84         2432 ,File::Spec->catfile($ENV{HOME},'.config')
1740             );
1741             }
1742              
1743 84         383 for my $d (@dirs)
1744             {
1745 566         4110 my $f = File::Spec->catfile($d, $name);
1746 566 100       1260 $f .= '.conf' unless INT_filelike($f);
1747 566 100       1408 if(INT_filelike($f))
1748             {
1749 11         27 $path = $f;
1750 11         25 last;
1751             }
1752             }
1753              
1754 84 100       265 $self->INT_verb_msg("Found config: $path\n") if defined $path;
1755 84         229 return $path
1756             }
1757              
1758             # Parse one given file.
1759             sub parse_file
1760             {
1761 17     17 1 32 my $self = shift;
1762              
1763 17         29 my $confname = shift;
1764 17         22 my $construct = shift;
1765              
1766 17         29 my $lend = '(\012\015|\012|\015)';
1767 17         23 my $nlend = '[^\012\015]';
1768 17         21 my $olderrs = @{$self->{errors}};
  17         33  
1769 17         1566 require IO::File;
1770              
1771             # TODO: Support loading multiple occurences in order.
1772 17         26065 my $file = $self->INT_find_config($confname);
1773 17         85 my $cdat = new IO::File;
1774 17 50       550 if(not defined $file)
    50          
    50          
1775             {
1776 0 0       0 $self->INT_error("Couldn't find config file $confname!") unless $self->{config}{nocomplain};
1777             }
1778 5         21 elsif(grep {$_ eq $file} @{$self->{parse_chain}})
  17         115  
1779             {
1780 0         0 $self->INT_error("Trying to parse config file $file twice in one chain!");
1781             }
1782             elsif($cdat->open($file, '<'))
1783             {
1784 17         1059 push(@{$self->{parse_chain}}, $file);
  17         62  
1785 17         86 push(@{$self->{files}}, $file);
  17         41  
1786 17 50       56 if(defined $self->{config}{binmode})
1787             {
1788 0         0 binmode($cdat, $self->{config}{binmode});
1789             }
1790             #do we need or want binmode for newlines?
1791 17         33 my $multiline = '';
1792 17         22 my $mcollect = 0;
1793 17         30 my $ender = '';
1794 17         24 my $mkey ='';
1795 17         24 my $mop = '';
1796 17         28 my %curpar;
1797 17         23 my $ln = 0;
1798 17         353 while(<$cdat>)
1799             {
1800 298         445 ++$ln;
1801 298 100       460 unless($mcollect)
1802             {
1803 263 100 100     1427 next if ($_ =~ /^\s*#/ or $_ =~ /^\s*#?\s*$lend$/o);
1804              
1805 123 100       526 if($_ =~ /^=($nlend+)$lend*$/o)
1806             {
1807 39         93 my $meta = $1;
1808 39 100       81 if($construct)
1809             {
1810 13 100       44 if($meta =~ /^param file\s*(\(([^)]*)\)|)\s*for\s*(.+)$/)
    50          
    50          
    50          
1811             {
1812 1         4 $self->{config}{program} = $3;
1813 1         7 $self->INT_verb_msg("This file is for $self->{config}{program}.\n");
1814 1 50 33     6 if(defined $2 and $2 =~ /^(.+)$/)
1815             {
1816 0         0 for my $s (split(',', $1))
1817             {
1818 0         0 $self->INT_verb_msg("Activating option $s.\n");
1819 0 0       0 $self->INT_error("$file:$ln: eval option not supported anymore.") if($s eq 'eval');
1820 0         0 $self->{config}{$s} = 1;
1821             }
1822             }
1823             }
1824             elsif($meta =~ /^version\s*(.+)$/)
1825             {
1826 0         0 $self->{config}{version} = $1;
1827             }
1828             elsif($meta =~ /^info\s(.*)$/)
1829             {
1830 0         0 $self->{config}{info} .= $1."\n"; #dos, unix... whatever...
1831             }
1832             elsif($meta =~ /^infopod\s(.*)$/)
1833             {
1834 0         0 $self->{config}{infopod} .= $1."\n"; #dos, unix... whatever...
1835             }
1836             }
1837             # Groping for parameter description in any case.
1838 39 100       189 if($meta =~ /^(long|key)\s*(\S*)(\s*short\s*(\S)|)(\s*type\s*(\S+)|)/)
    100          
    100          
1839             {
1840 16 100       97 %curpar = (long=>$2, short=>defined $4 ? $4 : '', help=>'');
1841 16 50       44 my $type = defined $6 ? $6 : '';
1842 16 50       35 if(exists $typemap{$type})
1843             {
1844 16         38 $curpar{value} = $initval[$typemap{$type}];
1845 16         55 $self->INT_verb_msg("switching to key $curpar{long} / $curpar{short}\n");
1846             }
1847 0         0 else{ $self->INT_error("$file:$ln: unknown type $type"); %curpar = (); }
  0         0  
1848             }
1849             elsif($meta =~ /^(help|desc)\s(.*)$/)
1850             {
1851 16 50       83 $curpar{help} .= $curpar{help} ne '' ? "\n" : "" . $2;
1852             }
1853             elsif($meta =~ /^include\s*(.+)$/)
1854             {
1855 5         12 my $incfile = $1;
1856             # Avoid endless looping by making this path explicit.
1857             # Search for config file vicious if you tell it to load ../config and that also contains ../config ...
1858 5         18 $self->INT_verb_msg("including $incfile\n");
1859 5 50       80 unless(File::Spec->file_name_is_absolute($incfile))
1860             {
1861 5         179 my $dir = dirname($file);
1862 5         47 $dir = File::Spec->rel2abs($dir);
1863 5         43 $incfile = File::Spec->catfile($dir, $incfile);
1864 5 50       99 $incfile .= '.conf'
1865             unless -e $incfile;
1866             }
1867 5         43 $self->parse_file($incfile, $construct);
1868             }
1869             }
1870             else
1871             {
1872 84 100       1237 if($_ =~ /^\s*($parname)\s*($lopex)\s*($nlend*)$lend$/)
    50          
    50          
1873             {
1874 74         257 my ($par,$op,$val) = ($1,$2,$3);
1875             #remove trailing spaces
1876 74         358 $val =~ s/\s*$//;
1877             #remove quotes
1878 74         208 $val =~ s/^"(.*)"$/$1/;
1879 74         219 $self->INT_definery(\%curpar, $par, $construct);
1880 74 100       151 if(exists $self->{param}{$par})
1881             {
1882 71         225 $self->INT_verb_msg("Setting $par $op $val\n");
1883 71         140 $self->INT_apply_op($par, $op, $val, $file);
1884             }
1885             else
1886             {
1887 3 100       37 unless($self->{config}{ignore_unknown})
1888             {
1889 1 50       4 $self->{param}{help} = 1 if($self->{config}{nanny});
1890 1         8 $self->INT_error("$file:$ln: unknown parameter $par");
1891             }
1892             }
1893             }
1894             elsif($_ =~ /^\s*($parname)\s*$lend$/)
1895             {
1896 0         0 my $par = $1;
1897 0         0 $self->INT_definery(\%curpar, $par, $construct);
1898 0 0       0 if(exists $self->{param}{$par})
1899             {
1900 0         0 $self->INT_verb_msg("Setting $par so that it is true.\n");
1901 0         0 $self->{param}{$par} = $trueval[$self->{type}{$par}];
1902             }
1903             else
1904             {
1905 0 0       0 unless($self->{config}{ignore_unknown})
1906             {
1907 0 0       0 $self->{param}{help} = 1 if($self->{config}{nanny});
1908 0         0 $self->INT_error("$file:$ln: unknown parameter $par");
1909             }
1910             }
1911             }
1912             elsif($_ =~ /^\s*($parname)\s*([$ops]?)<<(.*)$/)
1913             {
1914 10         28 $ender = $3;
1915 10 100       30 $mop = $2 ne '' ? $2 : '=';
1916 10         16 $mkey = $1;
1917 10         14 $mcollect = 1;
1918 10 100       29 $mop .= '=' unless $mop =~ /=$/;
1919 10         33 $self->INT_verb_msg("Reading for $mkey...(till $ender)\n");
1920             }
1921             }
1922             }
1923             else
1924             {
1925 35         101 $self->INT_verb_msg("collect: $_");
1926 35 100       207 unless($_ =~ /^$ender$/)
1927             {
1928 25         170 s/(^|$nlend)$lend$/$1\n/o;
1929 25         85 $multiline .= $_;
1930             }
1931             else
1932             {
1933 10         19 $mcollect = 0;
1934             # remove last line end
1935 10         87 $multiline =~ s/(^|$nlend)$lend$/$1/o;
1936 10         36 $self->INT_definery(\%curpar, $mkey, $construct);
1937 10 50       30 if(exists $self->{param}{$mkey})
1938             {
1939             # apply the config file options first, with eval() when desired
1940 10         28 $self->INT_apply_op($mkey, $mop, $multiline, $file);
1941 10         30 $self->INT_verb_msg("set $mkey from $multiline\n");
1942             }
1943             else
1944             {
1945 0 0       0 unless($self->{config}{ignore_unknown})
1946             {
1947 0 0       0 if($self->{config}{nanny}){ $self->{param}{help} = 1; }
  0         0  
1948 0         0 $self->INT_error("$file:$ln: unknown parameter $mkey!");
1949             }
1950             }
1951              
1952 10         91 $multiline = '';
1953             }
1954             }
1955             }
1956 17         108 $cdat->close();
1957 17         305 $self->INT_verb_msg("... done parsing.\n");
1958 17         64 pop(@{$self->{parse_chain}});
  17         59  
1959             }
1960 0 0       0 else{ $self->INT_error("Couldn't open config file $file! ($!)") unless $self->{config}{nocomplain}; }
1961              
1962 17 100       31 if(@{$self->{errors}} == $olderrs)
  17         50  
1963             {
1964 16         126 return 1
1965             } else
1966             {
1967 1         3 $self->{bad_config_file} = 1;
1968 1         11 return 0;
1969             }
1970             }
1971              
1972             # Just helper for the above, not gerneral-purpose.
1973              
1974             # Define a parameter in construction mode or when needed to accept something unknown.
1975             sub INT_definery
1976             {
1977 84     84 0 178 my ($self, $curpar, $par, $construct) = @_;
1978 84 50 66     232 if(
      66        
1979             defined $curpar->{long}
1980             and (
1981             $construct
1982             or
1983             (
1984             $self->{config}{accept_unknown}
1985             and not exists $self->{param}{$par}
1986             and $curpar->{long} eq $par
1987             ))
1988 6         15 ){ $self->define($curpar); }
1989              
1990 84 50 33     190 $self->define({long=>$par}) if(not exists $self->{param}{$par} and ($construct or $self->{config}{accept_unknown}));
      66        
1991 84         114 %{$curpar} = ();
  84         170  
1992             }
1993              
1994             # Print out a config file.
1995             sub print_file
1996             {
1997 2     2 1 7 my ($self, $handle, $bare) = @_;
1998              
1999 2         7 my @omit = ('config','help');
2000 2 50       8 push(@omit,'version') if defined $self->{config}{version};
2001 2 50       6 push(@omit, @{$self->{config}{notinfile}}) if defined $self->{config}{notinfile};
  0         0  
2002 2 50       9 unless($bare)
2003             {
2004 2         14 print $handle <
2005             # Configuration file for $self->{config}{program}
2006             #
2007             # Syntax:
2008             #
2009             EOT
2010 2         8 print $handle <
2011             # name = value
2012             # or
2013             # name = "value"
2014             #
2015             # You can provide any number (including 0) of whitespaces before and after name and value. If you really want the whitespace in the value then use the second form and be happy;-)
2016             EOT
2017 2         20 print $handle <
2018             # It is also possible to set multiline strings with
2019             # name <
2020             # ...
2021             # ENDSTRING
2022             #
2023             # (just like in Perl but omitting the ;)
2024             # You can use .=, +=, /= and *= instead of = as operators for concatenation of strings or pushing to arrays/hashes, addition, substraction, division and multiplication, respectively.
2025             # The same holds likewise for .<<, +<<, /<< and *<< .
2026             #
2027             # The short names are just provided as a reference; they're only working as real command line parameters, not in this file!
2028             #
2029             # The lines starting with "=" are needed for parsers of the file (other than $self->{config}{program} itself) and are informative to you, too.
2030             # =param file (options) for program
2031             # says for whom the file is and possibly some hints (options)
2032             # =info INFO
2033             # is the general program info (multiple lines, normally)
2034             # =long NAME short S type TYPE
2035             # says that now comes stuff for the parameter NAME and its short form is S. Data TYPE can be scalar, array or hash.
2036             # =help SOME_TEXT
2037             # gives a description for the parameter.
2038             #
2039             # If you don't like/need all this bloated text, the you can strip all "#", "=" - started and empty lines and the result will still be a valid configuration file for $self->{config}{program}.
2040              
2041             EOT
2042             }
2043 2         7 print $handle '=param file ';
2044 2         6 my @opt = (); # There are no relevant options currently.
2045 2 50       6 print $handle '('.join(',',@opt).') ' if @opt;
2046 2         10 print $handle 'for '.$self->{config}{program}."\n";
2047 2 50       19 print $handle '=version '.$self->{config}{version}."\n" if defined $self->{config}{version};
2048 2         6 print $handle "\n";
2049 2 100 66     14 if(defined $self->{config}{info} and !$bare)
2050             {
2051 1         5 my @info = split("\n",$self->{config}{info});
2052 1         3 for(@info){ print $handle '=info '.$_."\n"; }
  1         5  
2053             }
2054 2 50 33     14 if(defined $self->{config}{infopod} and !$bare)
2055             {
2056 0         0 my @info = split("\n",$self->{config}{infopod});
2057 0         0 for(@info){ print $handle '=infopod '.$_."\n"; }
  0         0  
2058             }
2059 2         6 for my $k (sort keys %{$self->{param}})
  2         20  
2060             {
2061 15 100       189 unless(grep(/^$k$/, @omit))
2062             {
2063             #make line ending changeable...
2064             #or use proper system-independent line end
2065             #for now we just use \n - what may even work with active perl
2066             #
2067 11 50       29 unless($bare)
2068             {
2069             print $handle "\n=long $k"
2070 11 100       62 ,$self->{short}{$k} ne '' ? " short $self->{short}{$k}" : ''
2071             ," type $typename[$self->{type}{$k}]"
2072             ,"\n";
2073 11         18 my @help = split("\n",${$self->{help}{$k}});
  11         33  
2074 11         26 for(@help)
2075             {
2076 11         29 print $handle "=help $_\n";
2077             }
2078             }
2079 11 100       35 my $values = $self->{type}{$k} ? $self->{param}{$k} : [ $self->{param}{$k} ];
2080 11 100       27 if($self->{type}{$k} == $hash)
2081             {
2082 2         4 my @vals;
2083 2         5 for my $k (sort keys %{$values})
  2         14  
2084             {
2085 4 50       20 push(@vals, $k.(defined $values->{$k} ? '='.$values->{$k} : ''));
2086             }
2087 2         5 $values = \@vals;
2088             }
2089 11 50       21 $values = [ undef ] unless defined $values;
2090 11         19 my $first = 1;
2091 11 50       23 print $handle "\n" unless $bare;
2092 11         14 for my $v (@{$values})
  11         22  
2093             {
2094             my $preop = $self->{type}{$k}
2095             ? ( (not $first)
2096             ? '.'
2097 19 50       62 : ( (@{$values} > 1) ? ' ' : '' ) )
  4 100       15  
    100          
2098             : '';
2099 19 100       35 if(defined $v)
2100             {
2101 18 100       42 if($v =~ /[\012\015]/)
2102             {
2103 1         2 my $end = 'EOT';
2104 1         4 my $num = '';
2105 1         13 $v =~ s/[\012\015]*\z/\n/g; # that line end business needs testing
2106 1         26 while($v =~ /(^|\n)$end$num(\n|$)/){ ++$num; }
  1         32  
2107 1         18 print $handle "$k $preop<<$end$num\n$v$end$num\n";
2108             }
2109 17         51 else{ print $handle "$k $preop= \"$v\"\n"; }
2110             }
2111 1         68 else{ print $handle "# $k is undefined\n"; }
2112              
2113 19         47 $first = 0;
2114             }
2115             }
2116             }
2117             }
2118              
2119             sub INT_push_hash
2120             {
2121 75     75 0 108 my $self = shift;
2122 75         115 my $par = shift; for (@_)
  75         142  
2123             {
2124 104         276 my ($k, $v) = split('=',$_,2);
2125 104 50       200 if(defined $k)
2126             {
2127 104         326 $par->{$k} = $v;
2128             } else
2129             {
2130 0         0 $self->INT_error("Undefined key for hash $_[0]. Did you mean --$_[0]// to empty it?");
2131             }
2132             }
2133             }
2134              
2135             # The low-level worker for applying one parameter operation.
2136             sub INT_apply_op
2137             {
2138 280     280 0 429 my $self = shift; # (par, op, value, file||undef)
2139              
2140 280 50       592 return unless exists $self->{param}{$_[0]};
2141              
2142 280 100       738 if($self->{type}{$_[0]} == $scalar)
    100          
    50          
2143             {
2144 11     11   131 no warnings 'numeric';
  11         27  
  11         10690  
2145 101         187 my $par = \$self->{param}{$_[0]}; # scalar ref
2146 101 100       252 if ($_[1] eq '='){ $$par = $_[2]; }
  69 100       212  
    100          
    100          
    50          
    0          
2147 6         13 elsif($_[1] eq '.='){ $$par .= $_[2]; }
2148 10         39 elsif($_[1] eq '+='){ $$par += $_[2]; }
2149 11         37 elsif($_[1] eq '-='){ $$par -= $_[2]; }
2150 5         23 elsif($_[1] eq '*='){ $$par *= $_[2]; }
2151 0         0 elsif($_[1] eq '/='){ $$par /= $_[2]; }
2152 0         0 else{ $self->INT_error("Operator '$_[1]' on '$_[0]' is invalid."); $self->{param}{help} = 1; }
  0         0  
2153             }
2154             elsif($self->{type}{$_[0]} == $array)
2155             {
2156 101         159 my $par = $self->{param}{$_[0]}; # array ref
2157 101         154 my $bad;
2158 101 100 66     355 if ($_[1] eq '='){ @{$par} = ( $_[2] ); }
  18 100 66     32  
  18 100       51  
    100          
2159 54         83 elsif($_[1] eq '.='){ push(@{$par}, $_[2]); }
  54         103  
2160 3         16 elsif($_[1] eq '//=' or ($_[1] eq '/=' and $_[2] eq '/')){ @{$par} = (); }
  3         7  
2161             elsif($_[1] =~ m:^/(.)/(.*)$:) # operator with specified array separator
2162             {
2163 25         63 my $sep = $1; # array separator
2164 25         40 my $op = $2; # actual operator
2165 25         171 my @values = split(/\Q$sep\E/, $_[2]);
2166 25 100       70 if ($op eq '='){ @{$par} = @values; }
  11 50       16  
  11         35  
2167 14         21 elsif($op eq '.='){ push(@{$par}, @values); }
  14         41  
2168 0         0 else{ $bad = 1; }
2169             }
2170 1         3 else{ $bad = 1 }
2171 101 100       310 if($bad)
2172             {
2173 1         6 $self->INT_error("Operator '$_[1]' is invalid for array '$_[0]'!");
2174             #$self->{param}{help} = 1;
2175             }
2176             }
2177             elsif($self->{type}{$_[0]} == $hash)
2178             {
2179 78         125 my $par = $self->{param}{$_[0]}; # hash ref
2180 78         119 my $bad;
2181              
2182 78 100 66     369 if($_[1] =~ m:^/(.)/(.*)$:) # operator with specified array separator
    100 66        
2183             {
2184 25         55 my $sep = $1; # array separator
2185 25         37 my $op = $2; # actual operator
2186 25         163 my @values = split(/\Q$sep\E/, $_[2]);
2187             # a sub just to avoid duplicating the name=value splitting and setting
2188 25 100       71 if ($op eq '='){ %{$par} = (); $self->INT_push_hash($par,@values); }
  11 50       15  
  11         30  
  11         31  
2189 14         34 elsif($op eq '.='){ $self->INT_push_hash($par,@values); }
2190 0         0 else{ $bad = 1; }
2191             }
2192             elsif($_[1] eq '//=' or ($_[1] eq '/=' and $_[2] eq '/'))
2193             {
2194 3         7 %{$par} = ();
  3         9  
2195             } else
2196             {
2197 50 100       125 if ($_[1] eq '='){ %{$par} = (); $self->INT_push_hash($par, $_[2]); }
  12 50       18  
  12         25  
  12         33  
2198 38         97 elsif($_[1] eq '.='){ $self->INT_push_hash($par, $_[2]); }
2199 0         0 else{ $bad = 1 }
2200             }
2201 78 50       260 if($bad)
2202             {
2203 0         0 $self->INT_error("Operator '$_[1]' is invalid for hash '$_[0]'!");
2204 0         0 $self->{param}{help} = 1;
2205             }
2206             }
2207             }
2208              
2209             sub INT_value_check
2210             {
2211 60     60 0 111 my $self = shift;
2212 60         104 my $p = $self->{param};
2213 60         82 my $olderr = @{$self->{errors}};
  60         101  
2214 60         102 for my $k (keys %{$self->{regex}})
  60         209  
2215             {
2216 140 100       403 if($self->{type}{$k} == $scalar)
    100          
    50          
2217             {
2218             $self->INT_error("Value of $k does not match regex: $p->{$k}")
2219 64 50       468 unless $p->{$k} =~ $self->{regex}{$k};
2220             } elsif($self->{type}{$k} == $array)
2221             {
2222 68         138 for(my $i=0; $i<@{$p->{$k}}; ++$i)
  83         234  
2223             {
2224             $self->INT_error("Element $i of $k does not match regex: $p->{$k}[$i]")
2225 15 100       106 unless $p->{$k}[$i] =~ $self->{regex}{$k};
2226             }
2227             } elsif($self->{type}{$k} == $hash)
2228             {
2229 8         11 for my $n (sort keys %{$p->{$k}})
  8         24  
2230             {
2231             $self->INT_error("Element $n of $k does not match regex: $p->{$k}{$n}")
2232 4 50       21 unless $p->{$k}{$n} =~ $self->{regex}{$k};
2233             }
2234             }
2235             }
2236 60         112 for my $k (keys %{$p})
  60         186  
2237             {
2238 11     11   96 no warnings 'uninitialized';
  11         25  
  11         7664  
2239             next
2240 337 100       685 unless ($self->{flags}{$k} & $nonempty);
2241 16 100 66     68 unless(
      100        
      100        
      100        
      100        
2242             ( $self->{type}{$k} == $scalar and $p->{$k} ne '' ) or
2243 8         27 ( $self->{type}{$k} == $array and @{$p->{$k}} ) or
2244 4         14 ( $self->{type}{$k} == $hash and %{$p->{$k}} )
2245             ){
2246 3         16 $self->INT_error("Parameter $k is empty but should not be.");
2247             }
2248             }
2249 60         166 return $olderr == @{$self->{errors}};
  60         219  
2250             }
2251              
2252             sub current_setup
2253             {
2254 3     3 1 27 require Storable;
2255 3         6 my $self = shift;
2256 3         64 my $config = Storable::dclone($self->{config});
2257 3         8 my @pardef;
2258 3         9 my $bin = builtins($self->{config});
2259 3         10 for my $p (sort keys %{$self->{param}})
  3         23  
2260             {
2261 24 100       48 next if $bin->{$p};
2262 18 100       106 my $val = ref($self->{param}{$p}) ? Storable::dclone($self->{param}{$p}) : $self->{param}{$p};
2263 18         35 push(@pardef, $p, $val, $self->{short}{$p}, ${$self->{help}{$p}});
  18         56  
2264             }
2265 3         16 return ($config, \@pardef);
2266             }
2267              
2268              
2269             # Little hepler for modifying the parameters.
2270             # Apply all collected operations to a specific parameter.
2271             sub INT_apply_ops
2272             {
2273 206     206 0 293 my $self = shift;
2274 206         297 my $key = shift;
2275 206 100       457 return unless defined $self->{ops}{$key};
2276 144         227 $self->INT_verb_msg("Param: applying (@{$self->{ops}{$key}}) to $key of type $self->{type}{$key}\n");
  144         685  
2277 144         238 while(@{$self->{ops}{$key}})
  343         812  
2278             {
2279 199         289 my $op = shift(@{$self->{ops}{$key}});
  199         379  
2280 199         301 my $val = shift(@{$self->{ops}{$key}});
  199         360  
2281 199         428 $self->INT_apply_op($key, $op, $val);
2282             }
2283             }
2284              
2285             sub INT_verb_msg
2286             {
2287 1381     1381 0 2006 my $self = shift;
2288 1381 50 33     5023 return unless ($verbose or $self->{config}{verbose});
2289 0         0 print STDERR "[Config::Param] ", @_;
2290             }
2291              
2292             sub INT_error
2293             {
2294 14     14 0 25 my $self = shift;
2295             print STDERR "$self->{config}{program}: [Config::Param] Error: "
2296 14 50       77 , $_[0], "\n" unless $self->{config}{silenterr};
2297 14         23 push(@{$self->{errors}}, $_[0]);
  14         32  
2298 14         40 return 1;
2299             }
2300              
2301             1;
2302              
2303             __END__