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   569513 use strict;
  11         92  
  11         273  
27 11     11   50 use warnings;
  11         13  
  11         224  
28              
29 11     11   48 use Carp;
  11         16  
  11         509  
30 11     11   252 use 5.008;
  11         27  
31             # major.minor.bugfix, the latter two with 3 digits each
32             # or major.minor_alpha
33             our $VERSION = '4.000004';
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   4330 use Sys::Hostname;
  11         9885  
  11         544  
53 11     11   4273 use FindBin qw($Bin);
  11         9926  
  11         1098  
54 11     11   64 use File::Spec;
  11         17  
  11         160  
55 11     11   44 use File::Basename;
  11         16  
  11         53701  
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 52529 my $config = ref $_[0] eq 'HASH' ? shift : {};
68 67         99 my $pardef;
69 67         124 my $args = \@ARGV;
70 67         96 my $give_error;
71 67 100       152 if(ref $_[0] eq 'ARRAY')
72             {
73 66         105 $pardef = shift;
74 66 100       171 if(ref $_[0] eq 'ARRAY')
75             {
76 64         83 $args = shift;
77 64         139 $give_error = 1;
78             }
79             }
80 1         2 else{ $pardef = \@_; }
81              
82 67         255 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     159 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         226 $pars->final_action($bad);
93              
94 67 100       175 $_[0] = $pars->{errors} if $give_error;
95 67         204 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 1062 my ($long, $short) = @_;
166             return
167             (
168 657   66     9483 (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 1023 my $type = lc(ref $_[0]);
177 657         1017 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 741 my $def = shift;
185             $_[0] = (defined $def->{type} and not defined $def->{value})
186             ? $def->{type}
187 657 50 33     1442 : 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     1049 and ( not defined $def->{call} or ref $def->{call} eq 'CODE' )
194             );
195             }
196              
197             sub hashdef
198             {
199 234     234 1 990 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       480 $h{short} = '' unless defined $h{short};
204 234 100       407 $h{flags} = 0 unless defined $h{flags};
205 234         337 return \%h;
206             }
207              
208             sub builtins
209             {
210 79     79 1 292 my $config = shift;
211 79         238 my %bldi = (help=>1, h=>1, I=>1, config=>1);
212 79 50 33     292 $bldi{version} = 1 if(defined $config and defined $config->{version});
213 79         163 return \%bldi;
214             }
215              
216             # helper for below
217             sub INT_defchecker
218             {
219 259     259 0 299 my $def = shift;
220 259         275 my $name_there = shift;
221 259 100       458 my $short = defined $def->{short} ? $def->{short} : '';
222              
223             return ''
224 259 50       414 if defined $def->{section};
225 259 50       332 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     965 if($name_there->{$def->{long}} or $name_there->{$short});
    100          
229             $name_there->{$def->{long}} = 1
230 257 50       580 if defined $def->{long};
231 257 100       521 $name_there->{$short} = 1 if $short ne '';
232              
233 257         410 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 109 my $config = shift;
242 70         145 my $name_there = builtins($config);
243 70         103 my $indef = $_[0];
244 70         112 $_[0] = []; # If an error comes, nothing is sane.
245 70 100       84 if(@{$indef})
  70         154  
246             {
247 69 100       201 if(ref $indef->[0] ne '')
248             {
249             # each element is a ref, check them all
250 33         49 for my $d (@{$indef})
  33         83  
251             {
252 86         132 my $t = ref $d;
253 86 50       158 return 'mix of array/hash and other stuff'
254             if($t eq '');
255 86 50 66     194 return 'strange refs, neither hash nor array'
256             if($t ne 'ARRAY' and $t ne 'HASH');
257              
258 86 100       152 my $def = $t eq 'ARRAY' ? hashdef(@{$d}) : $d;
  61         120  
259 86         152 my $problem = INT_defchecker($def, $name_there);
260 86         112 $d = $def;
261 86 50       211 return $problem if $problem;
262             }
263             }
264             else
265             {
266 36 50       41 return 'plain member count not multiple of 4' if(@{$indef} % 4);
  36         88  
267              
268 36         51 my @spars = ();
269 36         49 while(@{$indef})
  207         329  
270             {
271 173         186 my $sdef;
272 173         183 my $def = hashdef(splice(@{$indef}, 0, 4));
  173         282  
273 173         298 my $problem = INT_defchecker($def, $name_there);
274 173 100       284 return $problem if $problem;
275 171         244 push(@spars, $def);
276             }
277 34         58 $indef = \@spars;
278             }
279             }
280 68         124 $_[0] = $indef; # only after full success
281 68         194 return '';
282             }
283              
284             sub escape_pod
285             {
286 143 100   143 1 286 return undef unless defined $_[0];
287 141         266 my @text = split("\n", shift, -1);
288 141         200 for(@text)
289             {
290 173 100       308 next if m/^\s/; # indented stuff is verbatim
291 157         171 s/^=(\w)/=Z<>$1/;
292 157         220 s/([A-Z])
293             }
294 141         468 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 1361 my $class = shift;
302 70         112 my $self = {};
303 70         111 bless $self, $class;
304              
305 70         171 $self->{config} = shift;
306 70 100       168 $self->{config} = {} unless defined $self->{config};
307 70         99 my $pars = shift;
308 70 100       124 $pars = [] unless defined $pars;
309 70         141 $self->{files} = [];
310 70         120 $self->{errors} = [];
311              
312 70 100       1574 $self->{config}{program} = basename($0) unless defined $self->{config}{program};
313 70 100       248 $self->{config}{shortdefaults} = 1 unless exists $self->{config}{shortdefaults};
314 70         136 $self->{printconfig} = 0;
315 70         129 my $hh = 'Show the help message. Value 1..9: help level, par:'
316             . ' help for paramter par (long name) only.';
317 70         144 $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         116 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     190 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       171 $self->{longprefix} = $self->{config}{posixhelp} ? '--' : '';
334             # Same for - and short names.
335 70 50       154 $self->{shortprefix} = $self->{config}{posixhelp} ? '-' : '';
336             # An array of sections, with {name=>foo, member=>[$long1, $long2, ...]}.
337             # If I opted for
338 70         222 $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         391 , 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         182 $self->{param} = {}; # parameter values
348 70         114 $self->{help} = {}; # help texts
349 70         113 $self->{long} = {}; # map short to long names
350 70         114 $self->{short} = {}; # map long to short names
351 70         120 $self->{arg} = {}; # argument name
352 70         123 $self->{type} = {}; # type code
353             # store default values, for even more detailed documentation
354 70         112 $self->{default} = {}; # default value
355 70         174 $self->{level} = {}; # parameter level for help output
356 70         115 $self->{length} = 0; # max length of long names
357 70         102 $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         116 $self->{parse_chain} = [];
360             # TODO set from config hash
361 70 100       575 $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   2 unless(defined $_[2])
370             {
371 1         2 $self->{printconfig} += 1;
372 1         2 undef $_[0]; # Skip this operation.
373             }
374 1         1 return 0;
375             }
376 70 100       730 });
377             $self->define({ long=>'version', value=>0, short=>''
378             , help=>\'print out the program version', arg=>''
379             , flags=>0, regex=>qr/./ })
380 70 50       262 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       169 if exists $self->{config}{ignorehelp};
385             $self->INT_error("Update your program: eval option not supported anymore.")
386 70 50       152 if exists $self->{config}{eval};
387              
388 70         177 my $problem = sane_pardef($self->{config}, $pars);
389 70 100       147 if($problem)
390             {
391 2         7 $self->INT_error("bad parameter specification: $problem");
392             } else
393             {
394 68         95 my $di = 0;
395 68         82 for my $def (@{$pars})
  68         114  
396             {
397 252         284 ++$di;
398             # definition failure here is an error in the module
399 252 50       398 $self->INT_error("Very unexpected failure to evaluate parameter definition $di.")
400             unless($self->define($def));
401             }
402 68         158 $self->find_config_files();
403             }
404 70         321 return $self;
405             }
406              
407             sub good
408             {
409 67     67 1 102 my $self = shift;
410 67         83 return @{$self->{errors}} == 0;
  67         301  
411             }
412              
413             # name[=arg] and variants
414             sub INT_namearg
415             {
416 398     398 0 453 my $self = shift;
417 398         492 my $name = shift;
418 398         548 my $flags = $self->{flags}{$name};
419 398         620 my $val= $self->{arg}{$name};
420 398 100       713 $val = 'val' unless defined $val;
421 398 50       1221 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 587 my $self = shift;
431 468         507 my $pd = shift;
432              
433             my $helpref = defined $pd->{help}
434             ? ( ref $pd->{help} ? $pd->{help} : \$pd->{help} )
435 468 100       1060 : \"";
    100          
436             # The section keyword defines a section instead of a parameter.
437 468 100       807 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       144 my $flags = defined $pd->{flags} ? 0+$pd->{flags} : 0;
443 70 50       167 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       86 if @{$self->{section}};
  70         179  
448 70         331 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         95 , flags=>$flags, regex=>$pd->{regex}, call=>$pd->{call} });
452 70         140 return 1;
453             }
454              
455 398 50       423 unless(@{$self->{section}})
  398         738  
456             {
457 0         0 $self->INT_error("Define the default section first!");
458 0         0 return 1;
459             }
460              
461 398         491 my $section = $self->{section}[$#{$self->{section}}];
  398         638  
462 398         567 my $name = $pd->{long};
463              
464 398 100       667 $pd->{help} = \'' unless defined $pd->{help};
465 398 100       607 $pd->{short} = '' unless defined $pd->{short};
466 398         449 my $type; # valid_def sets that
467 398 50       627 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       866 : $section->{flags};
475             $flags |= $pd->{addflags}
476 398 50       672 if defined $pd->{addflags};
477             my $regex = defined $pd->{regex}
478             ? $pd->{regex}
479 398 100       649 : $section->{regex};
480             my $call = defined $pd->{call}
481             ? $pd->{call}
482 398 100       597 : $section->{call};
483 398 50 33     746 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     1153 unless(defined $self->{param}{$name} or defined $self->{long}{$pd->{short}})
489             {
490 398         629 $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       590 if(ref $pd->{value})
496             {
497 212         2183 require Storable; # Only require it if there is really the need.
498 212         11185 $self->{param}{$name} = Storable::dclone($pd->{value});
499 212         2143 $self->{default}{$name} = Storable::dclone($pd->{value});
500             }
501             else
502             {
503 186         291 $self->{param}{$name} = $pd->{value};
504 186         292 $self->{default}{$name} = $pd->{value};
505             }
506             $self->{long}{$pd->{short}} = $name
507 398 100       1134 if $pd->{short} ne '';
508 398         666 $self->{short}{$name} = $pd->{short};
509 398         545 $self->{help}{$name} = $helpref;
510 398         538 $self->{arg}{$name} = $pd->{arg};
511             my $lev = $self->{level}{$name} = 0+( defined $pd->{level}
512             ? $pd->{level}
513 398 50       830 : $section->{level} );
514             # Store the minimum level needed to display at least one section member.
515             $section->{minlevel} = $lev
516 398 100       725 if $lev < $section->{minlevel};
517 398         557 $self->{flags}{$name} = $flags;
518             $self->{arg}{$name} = ''
519 398 50       727 if $self->{flags}{$name} & $switch;
520 398         470 push(@{$section->{member}}, $name);
  398         821  
521 398         1795 $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       809 if length($name) > $self->{length};
525 398         726 my $arglen = length($self->INT_namearg($name));
526             $self->{arglength} = $arglen
527 398 100       756 if $arglen > $self->{arglength};
528 398 100       736 $self->{regex}{$name} = $regex
529             if defined $regex;
530 398 100       782 $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         1250 return 1;
539             }
540              
541             sub find_config_files
542             {
543 68     68 1 104 my $self = shift;
544              
545 68 50       170 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     174 unless($self->{config}{nofile} or @{$self->{param}{config}})
  42         135  
555             {
556             # Default to reading program.conf and/or program.host.conf if found.
557 42         242 my $pconf = $self->INT_find_config($self->{config}{program}.'.conf');
558 42         233 my $hconf = $self->INT_find_config($self->{config}{program}.'.'.hostname().'.conf');
559 42         87 my @l;
560 42 100       114 push(@l, $pconf) if defined $pconf;
561 42 50       93 push(@l, $hconf) if defined $hconf;
562             # That list can be empty if none existing.
563 42         193 $self->INT_verb_msg("possible config files: @l\n");
564             # The last entry in the list has precedence.
565 42 50       128 unless($self->{config}{multi})
566             {
567 42 100       114 @l = ($l[$#l]) if @l; # Only the last element, if any, prevails.
568             }
569 42         61 @{$self->{param}{config}} = @l;
  42         142  
570             }
571             }
572              
573             # Parse abcd to the list of corresponding long names.
574             sub INT_long_names
575             {
576 65     65 0 93 my $self = shift;
577 65         98 my $sname = shift;
578 65         140 my @names;
579 65         199 for my $s (split(//,$sname))
580             {
581 69 50       199 if(defined (my $name = $self->{long}{$s}))
582             {
583 69         189 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         160 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 272 my $self = shift;
610 206         248 my $lastoption = shift;
611 206         248 my $sign = shift;
612 206         258 my $name = shift;
613             # op:$_[0] val:$_[1] args:$_[2]
614 206         309 my $flags = $self->{flags}{$name};
615             my $arrhash = defined $self->{type}{$name}
616 206 100       526 and grep {$_==$self->{type}{$name}} ($array, $hash);
  410         784  
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     690 if(defined $_[0] and $arrhash)
    100 100        
622             {
623             # -a/,/=bla and -a/,/bla are equivalent, as is -a/,/ bla
624 158 100 100     407 if($_[0] eq '/' and $_[1] =~ m:(./)(=?)(.*):)
625             {
626 16         39 $_[0] .= $1.$2;
627 16 100 66     59 $_[1] = ($3 eq '' and $2 eq '') ? undef : $3;
628 16 100 100     54 $_[0] .= '='
629             if($2 eq '' and defined $_[1]);
630             }
631 158 100 66     364 if($_[0] =~ m:^/./$: and $flags & $arg)
632             {
633 8 50       11 unless(@{$_[2]})
  8         19  
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         11 $_[1] = shift @{$_[2]};
  8         19  
641             }
642             } elsif(not defined $_[0] and $flags & $arg)
643             {
644 16 50 33     39 unless($lastoption and @{$_[2]})
  16         39  
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         26 $_[0] = '=';
651 16         20 $_[1] = shift @{$_[2]};
  16         29  
652             }
653              
654             # Defined empty value with undefined operator is just confusing to the callback.
655 206 100       364 undef $_[1]
656             unless defined $_[0];
657              
658             # The callback that could modify things.
659              
660 206 100       424 if(defined $self->{call}{$name})
661             {
662 6         8 my $nname = $name;
663 6         20 my $ret = $self->{call}{$name}->($nname, $sign, $_[0], $_[1]);
664 6 100 66     39 if($ret or (not defined $nname or $nname ne $name))
      33        
665             {
666 1 50       2 $self->INT_error("Callback for $name returned an error: $ret")
667             if $ret; # otherwise intentional drop
668 1         3 undef $_[0];
669 1         2 return;
670             }
671             }
672              
673             # Final translation of operator.
674              
675 205 100       330 unless(defined $_[0])
676             {
677 30 50       66 if($flags & $count)
678             {
679 0 0       0 ($_[0], $_[1]) = $sign =~ /^-/ ? ('+=', 1) : ('=', 0);
680             }
681             else
682             {
683 30         45 $_[0] = '=';
684 30 50       111 $_[1] = $sign =~ /^-/ ? 1 : 0;
685             }
686             }
687 205 100       326 if($arrhash)
688             {
689             $_[0] =~ s:(^|[^\.])=$:$1.=:
690 204 100       753 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 248 my $self = shift;
699 206         420 my ($name, $op, $val) = (shift, shift, shift);
700             $self->{ops}{$name} = []
701 206 100       499 unless defined $self->{ops}{$name};
702             return # undefined ops are intentionally dropped
703 206 100       351 unless defined $op;
704 205         561 $self->INT_verb_msg("name: $name op: $op (val: $val)\n");
705 205 100       283 push(@{$self->{ops}{$name}}, ($op =~ /=$/ ? $op : $op.'='), $val);
  205         1058  
706             }
707              
708             # Step 1: parse command line
709             sub parse_args
710             {
711 66     66 1 101 my $self = shift;
712 66         82 my $args = shift;
713              
714 66         82 my $olderrs = @{$self->{errors}};
  66         105  
715 66         227 $self->{ops} = {};
716 66         102 $self->{printconfig} = 0;
717              
718 66 50 33     167 $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         93 my $shorts = $shortex_strict;
722 66         86 my $longex = $longex_strict;
723 66         90 my $separator = '^--$'; #exactly this string means "Stop the parsing!"
724              
725 66 100       148 if($self->{config}{lazy})
726             {
727 15         19 $shorts = $shortex_lazy;
728 15         16 $longex = $longex_lazy;
729 15         21 $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         89 while(@{$args})
  273         540  
734             {
735 208         584 $self->INT_verb_msg("parsing $args->[0]\n");
736 208         432 my $e = index($args->[0], "\n");
737 208         259 my $begin;
738 208         240 my $end = "";
739 208         227 my $name;
740 208 50       368 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         347 $begin = $args->[0];
748             }
749 208 50 66     2403 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         154 $self->INT_verb_msg("short with value\n");
760 46 100       125 my $op = $2 ne '' ? $2 : '=';
761 46         83 my $val = $3.$end;
762 46         57 shift @{$args};
  46         63  
763 46         107 $self->INT_settle_op(1, '-', $name, $op, $val, $args);
764 46         100 $self->INT_add_op($name, $op, $val);
765             }
766             elsif($begin =~ /$shorts/o)
767             {
768 65         154 my $sign = $2;
769 65 100       159 $sign = '-' if $sign eq '';
770 65         107 my $op = $5;
771 65 100       138 my $sname = defined $op ? $4 : $3;
772 65 100       189 my $val = (defined $6 ? $6 : '').$end;
773 65         137 $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         192 my $names = $self->INT_long_names($sname, $op, $val);
779 65 50       87 last unless @{$names};
  65         134  
780 65         82 shift @{$args}; # It is settled now that this is options.
  65         96  
781              
782 65         80 while(@{$names})
  134         334  
783             {
784 69         79 my $olderr = @{$self->{errors}};
  69         106  
785 69         91 my $name = shift @{$names};
  69         134  
786 69         95 my $lastoption = not @{$names};
  69         101  
787             # Only the last one gets the specified operation.
788 69 100       121 my $kop = $lastoption ? $op : undef;
789 69 100       121 my $kval = $lastoption ? $val : undef;
790 69         187 $self->INT_settle_op($lastoption, $sign, $name, $kop, $kval, $args);
791             $self->INT_add_op($name, $kop, $kval)
792 69 50       84 if(@{$self->{errors}} == $olderr);
  69         199  
793             }
794             }
795             elsif($begin =~ $longex)
796             {
797             #yeah, long option
798 96         175 my $olderr = @{$self->{errors}};
  96         165  
799 96 50       256 my $sign = defined $7 ? $7 : $2;
800 96 100       196 $sign = '--' if $sign eq '';
801 96 50       191 my $name = defined $8 ? $8 : $3;
802 96         253 $self->INT_verb_msg("param $name\n");
803 96         186 my $op = $5;
804 96 100       229 my $val = (defined $6 ? $6 : '').$end;
805 96 50 66     200 unless(exists $self->{param}{$name} or $self->{config}{accept_unknown})
806             {
807 6 50       12 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     20 unless($self->{config}{ignore_unknown} and $self->{config}{ignore_unknown} > 1)
815             {
816 5         15 $self->INT_error("Unknown parameter (long option): $name");
817             }
818             }
819             }
820 96         106 shift @{$args};
  96         132  
821             # hack for operators, regex may swallow the . in .=
822 96 50       444 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       122 if(@{$self->{errors}} == $olderr);
  96         332  
831             $self->INT_add_op($name, $op, $val)
832 96 100       116 if(@{$self->{errors}} == $olderr);
  96         274  
833             }
834             else
835             {
836 1         4 $self->INT_verb_msg("No parameter, end.\n");
837 1         2 last;
838             } #was no option... consider the switch part over
839             }
840 66         162 $self->{bad_command_line} = not (@{$self->{errors}} == $olderrs)
841 66 50       156 unless $self->{bad_command_line};
842 66         309 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 130 my $self = shift;
849 63         81 my $olderr = @{$self->{errors}};
  63         109  
850             # Do operations on config file parameter first.
851 63         166 $self->INT_apply_ops('config');
852 63         86 my $newerr = @{$self->{errors}};
  63         98  
853 63 50       140 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         177 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 99 my $self = shift;
868 62         82 my $olderrs = @{$self->{errors}};
  62         103  
869 62         100 for my $key (keys %{$self->{ops}})
  62         223  
870             {
871 144 50 66     315 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       247 if(exists $self->{param}{$key})
    50          
878             {
879 143         237 $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         135 $self->{bad_command_line} = not (@{$self->{errors}} == $olderrs)
887 62 50       157 unless $self->{bad_command_line};
888 62         273 return not $self->{bad_command_line};
889             }
890              
891             # Step 4: Take final action.
892             sub final_action
893             {
894 67     67 1 100 my $self = shift;
895 67         93 my $end = shift;
896 67 100       156 return if($self->{config}{nofinals});
897              
898 27         38 my $handle = $self->{config}{output};
899 27 100       71 $handle = \*STDOUT
900             unless defined $handle;
901 27         105 my $exitcode = @{$self->{errors}}
902             ? ( $self->{bad_command_line}
903             ? $ex_usage
904 27 0       42 : ($self->{bad_config_file} ? $ex_config : $ex_software)
    0          
    50          
905             )
906             : 0;
907              
908 27 50       55 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     86 if($self->{param}{help})
    50          
    100          
921             {
922 15         31 $self->help();
923             exit($exitcode)
924 15 50       40 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         3 $self->print_file($handle, ($self->{printconfig} > 1));
935             exit($exitcode)
936 1 50       4 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 89 my $self = shift;
946 71         80 my $k = shift; # The parameter name.
947 71         78 my $format = shift; # formatting choice
948 71         78 my $indent = shift; # indent value for dumper
949 71         72 my $mk = shift; # value selector: 'param' or 'default', usually
950 71 50       118 $mk = 'param'
951             unless defined $mk;
952 71 100 66     182 if(not defined $format or $format eq 'dump')
    50          
953             {
954 68 50       78 if(eval { require Data::Dumper })
  68         817  
955             {
956 11     11   89 no warnings 'once'; # triggers when embedding the module
  11         20  
  11         80264  
957 68         5843 local $Data::Dumper::Terse = 1;
958 68         73 local $Data::Dumper::Deepcopy = 1;
959 68         84 local $Data::Dumper::Indent = $indent;
960 68 50       96 $Data::Dumper::Indent = 0 unless defined $Data::Dumper::Indent;
961 68         74 local $Data::Dumper::Sortkeys = 1;
962 68         70 local $Data::Dumper::Quotekeys = 0;
963 68         206 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       7 return "\n" unless(defined $self->{$mk}{$k});
970 3 100       8 if($self->{type}{$k} == $array)
    100          
971             {
972 1 50       2 return "" unless @{$self->{$mk}{$k}};
  1         4  
973 1         2 return join("\n", @{$self->{$mk}{$k}})."\n";
  1         6  
974             }
975             elsif($self->{type}{$k} == $hash)
976             {
977 1         2 my $ret = '';
978 1         1 for my $sk (sort keys %{$self->{$mk}{$k}})
  1         5  
979             {
980 2         7 $ret .= "$sk=$self->{$mk}{$k}{$sk}\n";
981             }
982 1         3 return $ret;
983             }
984 1         4 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 73 my ($indent, $prefill, $filler) = @_;
992 48 50       83 $filler = '.'
993             unless defined $filler;
994 48 100 66     220 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 173 my ($handle, $itab, $stab, $length) = (shift, shift, shift, shift);
1004 87 50       134 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         262 my @paragraphs = split("\n", join("", @_), -1);
1010             # Drop trailing empty lines. We do not wrap what.
1011 87   66     298 while(@paragraphs and $paragraphs[$#paragraphs] eq '')
1012             {
1013 6         21 pop @paragraphs;
1014             }
1015 87         120 my $first = 1;
1016 87         137 print $handle $itab;
1017 87 50       135 print $handle "\n"
1018             unless @paragraphs;
1019 87         99 my $line = undef;
1020 87         100 my $llen = length($itab);
1021 87         93 my $slen = length($stab);
1022 87   33     182 my $can_wrap = $length > $llen && $length > $slen;
1023 87         142 while(@paragraphs)
1024             {
1025 131         184 my $p = shift(@paragraphs);
1026             # Try to handle command line/code blocks by not messing with them.
1027 131 100       339 if($p =~ /^\t/)
    100          
    50          
1028             {
1029 3 50       6 print $handle $line."\n"
1030             if $llen;
1031 3         9 print $handle $stab.$p."\n";
1032 3         5 $line = '';
1033 3         8 $llen = 0;
1034             }
1035             elsif($p eq '')
1036             {
1037 33 100       55 $line = '' # Just for the warnings.
1038             unless defined $line;
1039 33         60 print $handle $line."\n";
1040 33         38 $line = '';
1041 33         61 $llen = 0;
1042             }
1043             elsif($can_wrap)
1044             {
1045 95         622 my @words = split(/\s+/, $p);
1046 95   100     288 while($llen>$slen or @words)
1047             {
1048 1326         1692 my $w = shift(@words);
1049 1326         1722 my $l = length($w);
1050 1326 100 100     3256 if(not $l or $l+$llen >= $length)
1051             {
1052 220         415 print $handle $line."\n";
1053 220         279 $llen = 0;
1054 220         239 $line = '';
1055 220         243 $first = 0;
1056             }
1057 1326 100       2090 if($l)
1058             {
1059 1231 100       2096 unless(defined $line)
    100          
1060             {
1061 60         89 $line = '';
1062             }
1063 0         0 elsif($llen)
1064             {
1065 1011         1237 $line .= ' ';
1066 1011         1222 $llen += 1;
1067             }
1068             else
1069             {
1070 160         184 $line = $stab;
1071 160         183 $llen = $slen;
1072             }
1073 1231         1392 $line .= $w;
1074 1231         2610 $llen += $l;
1075             }
1076             }
1077 95         134 $line = '';
1078 95         306 $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 6 my $self = shift;
1103 4         6 my $handle = $self->{config}{output};
1104 4 50       9 $handle = \*STDOUT unless defined $handle;
1105              
1106 4         7 my $prog = escape_pod($self->{config}{program});
1107 4         11 my $tagline = escape_pod($self->{config}{tagline});
1108             # usage line is unescaped
1109 4         10 my $usage = $self->{config}{usage};
1110 4         6 my @desc = (); # usage might come from here
1111             @desc = split("\n", $self->{config}{info}, -1)
1112 4 100       15 if(defined $self->{config}{info});
1113              
1114 4 100 66     15 $tagline = escape_pod(shift @desc)
1115             unless(defined $tagline or not defined $prog);
1116              
1117 4   100     15 while(@desc and $desc[0] =~ /^\s*$/){ shift @desc; }
  1         5  
1118              
1119 4 100 100     16 unless(defined $usage or not @desc)
1120             {
1121 1 50       8 if(lc($desc[0]) =~ /^\s*usage:\s*(.*\S?)\s*$/)
1122             {
1123 1 50       4 $usage = $1 if $1 ne '';
1124 1         3 shift(@desc);
1125 1   33     7 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     4 if(not defined $usage and @desc)
1129             {
1130 1         2 $usage = shift @desc;
1131 1         5 $usage =~ s/^\s*//;
1132 1         6 $usage =~ s/\s*$//;
1133 1   66     7 while(@desc and $desc[0] =~ /^\s*$/){ shift @desc; }
  1         5  
1134             }
1135             }
1136             }
1137 4 50       10 if(defined $prog)
1138             {
1139 4         16 print $handle "\n=head1 NAME\n\n$prog";
1140 4 50       13 print $handle " - $tagline" if defined $tagline;
1141 4         6 print $handle "\n";
1142             }
1143 4 100       9 if(defined $usage)
1144             {
1145 2         6 print $handle "\n=head1 SYNOPSIS\n\n";
1146 2         10 print $handle "\t$_\n" for(split("\n", $usage));
1147             }
1148 4 100 66     15 if(@desc or defined $self->{config}{infopod})
1149             {
1150 1         2 print $handle "\n=head1 DESCRIPTION\n\n";
1151 1 50       3 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         2  
1157             }
1158             }
1159 4 50       13 my $nprog = defined $prog ? $prog : 'some_program';
1160              
1161 4         7 print $handle "\n=head1 PARAMETERS\n\n";
1162 4         4 print $handle "These are the general rules for specifying parameters to this program:\n";
1163 4         10 print $handle "\n\t$nprog ";
1164 4 50       8 if($self->{config}{lazy})
1165             {
1166 4         8 print $handle escape_pod($example{lazy}),"\n\n";
1167 4         11 print $handle escape_pod($lazyinfo),"\n";
1168             }
1169             else
1170             {
1171 0         0 print $handle escape_pod($example{normal}),"\n";
1172             }
1173 4         9 print $handle "\n";
1174 4         6 for(@morehelp)
1175             {
1176 32         50 print $handle escape_pod($_);
1177             }
1178 4         7 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         4 print $handle "\n=over 2\n";
1180 4         7 for my $k (sort keys %{$self->{param}})
  4         21  
1181             {
1182             print $handle "\n=item B<".escape_pod($k).">".
1183 28 100       41 ($self->{short}{$k} ne '' ? ', B<'.escape_pod($self->{short}{$k}).'>' : '').
1184             " ($typename[$self->{type}{$k}])".
1185             "\n\n";
1186 28 100       74 my @content = $k eq 'help'
1187             ? 0
1188             : split("\n", $self->par_content($k, 'dump', 1));
1189 28         865 print $handle "\t$_\n" for(@content);
1190 28         42 print $handle "\n".escape_pod(${$self->{help}{$k}})."\n";
  28         51  
1191 28 100       78 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         4 my @podsections;
1197             # user-provided
1198 4         9 push(@podsections, @{$self->{config}{extrapod}})
1199 4 50       10 if(defined $self->{config}{extrapod});
1200              
1201             # standard
1202 4         23 for( ['BUGS','bugs'], ['AUTHOR', 'author'], ['LICENSE AND COPYRIGHT', 'copyright'] )
1203             {
1204             push(@podsections, {head=>$_->[0], body=>$self->{config}{$_->[1]}})
1205 12 100       34 if(defined $self->{config}{$_->[1]});
1206             }
1207              
1208 4         9 for my $ps (@podsections)
1209             {
1210 16         32 print $handle "\n=head1 $ps->{head}\n";
1211 16 100       35 print $handle "\n",$ps->{verbatim} ? $ps->{body} : escape_pod($ps->{body}),"\n";
1212             }
1213              
1214 4         44 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 18 my $self = shift;
1231 15         19 my $handle = $self->{config}{output};
1232 15 50       21 $handle = \*STDOUT unless defined $handle;
1233             my $indent = $self->{config}{posixhelp}
1234             ? $self->{arglength} + 7 # -s, --name[=arg]
1235 15 50       27 : $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         18 my $linewidth = 0;
1239 15 50       21 if(defined $self->{config}{linewidth})
    0          
    0          
1240             {
1241 15         20 $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       62 my $prosewidth = $linewidth > 80 ? 80 : $linewidth;
1259              
1260 15 100       45 if($self->{param}{help} =~ /^(-\d+),?(.*)$/)
1261             {
1262 9         20 my $code = $1;
1263 9         20 my @keys = split(',', $2);
1264 9         11 my $badkeys;
1265 9         17 for(@keys)
1266             {
1267 5 50       10 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       16 if $badkeys;
1275              
1276 9 100       54 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         3 , join(' ', sort keys %{$self->{param}}) );
  1         7  
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         8  
1284             }
1285             elsif($code == -3)
1286             { # param list, one one each line, without builtins
1287 1         3 my $builtin = builtins($self->{config});
1288 1         2 my @pars = sort grep {not $builtin->{$_}} keys %{$self->{param}};
  7         13  
  1         3  
1289 1 50       8 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         2 for(@keys)
1295             {
1296 2 100       53 if($first){ $first=0; }
  1         1  
1297 1         4 else{ print $handle ", "; }
1298 2         6 print $handle $self->par_content($_, 'dump', 1);
1299             }
1300             }
1301             elsif($code == -11)
1302             { # line values
1303 1         3 for(@keys){ print $handle $self->par_content($_, 'lines'); }
  3         6  
1304             }
1305             elsif($code == -100)
1306             {
1307 4         10 $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         50 return;
1316             }
1317              
1318             # Anything with at least two characters could be a parameter name.
1319 6 50       16 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       13 my $vst = (defined $self->{config}{version} ? "v$self->{config}{version} " : '');
1455 6 100       12 if(defined $self->{config}{tagline})
1456             {
1457 3         20 INT_wrap_print($handle, '', '', $prosewidth, "\n$self->{config}{program} ${vst}- ",$self->{config}{tagline});
1458 3 100       11 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       11 if(defined $self->{config}{info})
    50          
1464             {
1465 1         5 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       15 if defined $self->{config}{copyright};
1473             }
1474             else
1475             {
1476 3 50       7 if(defined $self->{config}{info})
    0          
1477             {
1478             INT_wrap_print($handle, '', '', $prosewidth, "\n$self->{config}{program} ${vst}- ".$self->{config}{info})
1479 3         21 } 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       13 if defined $self->{config}{copyright};
1487             }
1488              
1489 6         11 my $level = 0+$self->{param}{help};
1490 6         7 my $tablehead = '';
1491              
1492 6 50       9 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         7 my $preprint = "NAME, SHORT ";
1503 6 50       12 $indent = length($preprint)
1504             if length($preprint) > $indent;
1505 6         13 $tablehead = $preprint
1506             . INT_indent_string($indent, length($preprint))."VALUE [# DESCRIPTION]\n";
1507 6         13 INT_wrap_print( $handle, '', '', $prosewidth
1508             , "\nGeneric parameter example (list of real parameters follows):\n" );
1509 6         11 print $handle "\n";
1510 6 50       9 if($self->{config}{lazy})
1511             {
1512 6         23 print $handle "\t$self->{config}{program} $example{lazy}\n";
1513 6 100       27 if($level > 1)
1514             {
1515 2         5 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         19 print $handle "\n";
1523 6 100       9 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         8 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         18 my @hidden_nonshort;
1536             my @hidden_level;
1537 6 50       11 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         14 print $handle "\n".$tablehead;
1559 6         7 for my $k ( sort keys %{$self->{param}} )
  6         34  
1560             {
1561 42         122 $self->INT_param_help( $handle, $k, $level, $prosewidth, $indent
1562             , \@hidden_nonshort, \@hidden_level );
1563             }
1564             }
1565 6 50       14 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       13 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         16 print $handle "\n";
1598             }
1599              
1600             sub INT_param_help
1601             {
1602 42     42 0 50 my $self = shift;
1603 42         77 my ($handle, $k, $level, $linewidth, $indent, $hidden_nonshort, $hidden_level) = @_;
1604              
1605             # Reasons to hide from current printout.
1606 42         42 my $hide = 0;
1607 42 0 33     84 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       74 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       58 if $hide;
1620              
1621 42 50       65 if($self->{config}{posixhelp})
1622             {
1623 0         0 $self->INT_param_help_posix($handle, $k, $linewidth, $indent);
1624             } else
1625             {
1626 42         66 $self->INT_param_help_table($handle, $k, $linewidth, $indent);
1627             }
1628             }
1629              
1630             sub INT_param_help_table
1631             {
1632 42     42 0 48 my $self = shift;
1633 42         54 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         51 my $prefix = $k;
1642 42 100       104 $prefix .= ", $self->{short}{$k}" if($self->{short}{$k} ne '');
1643 42         52 $prefix .= ' ';
1644 42         100 my $content = $self->par_content($k, 'dump', 0);
1645 42         1365 my $stab = ' ' x $indent;
1646 42         49 my @help = split("\n", ${$self->{help}{$k}});
  42         111  
1647             push(@help, split("\n", $self->{extrahelp}))
1648             if( $k eq 'help' and $self->{param}{help} > 1
1649 42 100 100     117 and defined $self->{extrahelp} );
      66        
1650 42   33     168 $help[0] = $content.(@help and $help[0] ne '' ? " # $help[0]" : '');
1651 42         90 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 91 my $self = shift;
1692 63         90 my $construct = shift;
1693              
1694 63         83 for my $file (@{$self->{param}{config}})
  63         139  
1695             {
1696 10 100       25 return 0 unless $self->parse_file($file, $construct);
1697             }
1698 62         259 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 13290 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 464 my $self = shift;
1713 101         176 my $name = shift;
1714              
1715 101 100       732 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       191 return $name if(INT_filelike($name));
1721 84 50       342 return "$name.conf" if(INT_filelike("$name.conf"));
1722              
1723 84         261 my $path;
1724             my @dirs;
1725             #determine directory to search config files in
1726 84 50       225 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         3146 ,File::Spec->catfile($ENV{HOME},'.config')
1740             );
1741             }
1742              
1743 84         465 for my $d (@dirs)
1744             {
1745 566         4286 my $f = File::Spec->catfile($d, $name);
1746 566 100       1454 $f .= '.conf' unless INT_filelike($f);
1747 566 100       1313 if(INT_filelike($f))
1748             {
1749 11         31 $path = $f;
1750 11         30 last;
1751             }
1752             }
1753              
1754 84 100       291 $self->INT_verb_msg("Found config: $path\n") if defined $path;
1755 84         271 return $path
1756             }
1757              
1758             # Parse one given file.
1759             sub parse_file
1760             {
1761 17     17 1 27 my $self = shift;
1762              
1763 17         42 my $confname = shift;
1764 17         28 my $construct = shift;
1765              
1766 17         21 my $lend = '(\012\015|\012|\015)';
1767 17         22 my $nlend = '[^\012\015]';
1768 17         21 my $olderrs = @{$self->{errors}};
  17         29  
1769 17         1343 require IO::File;
1770              
1771             # TODO: Support loading multiple occurences in order.
1772 17         21994 my $file = $self->INT_find_config($confname);
1773 17         113 my $cdat = new IO::File;
1774 17 50       515 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         110  
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         967 push(@{$self->{parse_chain}}, $file);
  17         61  
1785 17         74 push(@{$self->{files}}, $file);
  17         39  
1786 17 50       55 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         27 my $multiline = '';
1792 17         25 my $mcollect = 0;
1793 17         20 my $ender = '';
1794 17         20 my $mkey ='';
1795 17         22 my $mop = '';
1796 17         26 my %curpar;
1797 17         20 my $ln = 0;
1798 17         322 while(<$cdat>)
1799             {
1800 298         446 ++$ln;
1801 298 100       404 unless($mcollect)
1802             {
1803 263 100 100     1386 next if ($_ =~ /^\s*#/ or $_ =~ /^\s*#?\s*$lend$/o);
1804              
1805 123 100       469 if($_ =~ /^=($nlend+)$lend*$/o)
1806             {
1807 39         83 my $meta = $1;
1808 39 100       63 if($construct)
1809             {
1810 13 100       43 if($meta =~ /^param file\s*(\(([^)]*)\)|)\s*for\s*(.+)$/)
    50          
    50          
    50          
1811             {
1812 1         3 $self->{config}{program} = $3;
1813 1         6 $self->INT_verb_msg("This file is for $self->{config}{program}.\n");
1814 1 50 33     5 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       152 if($meta =~ /^(long|key)\s*(\S*)(\s*short\s*(\S)|)(\s*type\s*(\S+)|)/)
    100          
    100          
1839             {
1840 16 100       74 %curpar = (long=>$2, short=>defined $4 ? $4 : '', help=>'');
1841 16 50       39 my $type = defined $6 ? $6 : '';
1842 16 50       33 if(exists $typemap{$type})
1843             {
1844 16         27 $curpar{value} = $initval[$typemap{$type}];
1845 16         46 $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       94 $curpar{help} .= $curpar{help} ne '' ? "\n" : "" . $2;
1852             }
1853             elsif($meta =~ /^include\s*(.+)$/)
1854             {
1855 5         9 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         14 $self->INT_verb_msg("including $incfile\n");
1859 5 50       33 unless(File::Spec->file_name_is_absolute($incfile))
1860             {
1861 5         184 my $dir = dirname($file);
1862 5         50 $dir = File::Spec->rel2abs($dir);
1863 5         46 $incfile = File::Spec->catfile($dir, $incfile);
1864 5 50       89 $incfile .= '.conf'
1865             unless -e $incfile;
1866             }
1867 5         36 $self->parse_file($incfile, $construct);
1868             }
1869             }
1870             else
1871             {
1872 84 100       972 if($_ =~ /^\s*($parname)\s*($lopex)\s*($nlend*)$lend$/)
    50          
    50          
1873             {
1874 74         210 my ($par,$op,$val) = ($1,$2,$3);
1875             #remove trailing spaces
1876 74         264 $val =~ s/\s*$//;
1877             #remove quotes
1878 74         161 $val =~ s/^"(.*)"$/$1/;
1879 74         190 $self->INT_definery(\%curpar, $par, $construct);
1880 74 100       129 if(exists $self->{param}{$par})
1881             {
1882 71         199 $self->INT_verb_msg("Setting $par $op $val\n");
1883 71         139 $self->INT_apply_op($par, $op, $val, $file);
1884             }
1885             else
1886             {
1887 3 100       28 unless($self->{config}{ignore_unknown})
1888             {
1889 1 50       4 $self->{param}{help} = 1 if($self->{config}{nanny});
1890 1         6 $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         23 $ender = $3;
1915 10 100       26 $mop = $2 ne '' ? $2 : '=';
1916 10         13 $mkey = $1;
1917 10         13 $mcollect = 1;
1918 10 100       23 $mop .= '=' unless $mop =~ /=$/;
1919 10         30 $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       189 unless($_ =~ /^$ender$/)
1927             {
1928 25         160 s/(^|$nlend)$lend$/$1\n/o;
1929 25         95 $multiline .= $_;
1930             }
1931             else
1932             {
1933 10         14 $mcollect = 0;
1934             # remove last line end
1935 10         65 $multiline =~ s/(^|$nlend)$lend$/$1/o;
1936 10         28 $self->INT_definery(\%curpar, $mkey, $construct);
1937 10 50       18 if(exists $self->{param}{$mkey})
1938             {
1939             # apply the config file options first, with eval() when desired
1940 10         23 $self->INT_apply_op($mkey, $mop, $multiline, $file);
1941 10         44 $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         94 $multiline = '';
1953             }
1954             }
1955             }
1956 17         105 $cdat->close();
1957 17         308 $self->INT_verb_msg("... done parsing.\n");
1958 17         24 pop(@{$self->{parse_chain}});
  17         56  
1959             }
1960 0 0       0 else{ $self->INT_error("Couldn't open config file $file! ($!)") unless $self->{config}{nocomplain}; }
1961              
1962 17 100       27 if(@{$self->{errors}} == $olderrs)
  17         50  
1963             {
1964 16         134 return 1
1965             } else
1966             {
1967 1         2 $self->{bad_config_file} = 1;
1968 1         10 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 147 my ($self, $curpar, $par, $construct) = @_;
1978 84 50 66     202 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         11 ){ $self->define($curpar); }
1989              
1990 84 50 33     173 $self->define({long=>$par}) if(not exists $self->{param}{$par} and ($construct or $self->{config}{accept_unknown}));
      66        
1991 84         99 %{$curpar} = ();
  84         151  
1992             }
1993              
1994             # Print out a config file.
1995             sub print_file
1996             {
1997 2     2 1 6 my ($self, $handle, $bare) = @_;
1998              
1999 2         5 my @omit = ('config','help');
2000 2 50       7 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       4 unless($bare)
2003             {
2004 2         19 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         17 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         6 print $handle '=param file ';
2044 2         4 my @opt = (); # There are no relevant options currently.
2045 2 50       6 print $handle '('.join(',',@opt).') ' if @opt;
2046 2         7 print $handle 'for '.$self->{config}{program}."\n";
2047 2 50       11 print $handle '=version '.$self->{config}{version}."\n" if defined $self->{config}{version};
2048 2         4 print $handle "\n";
2049 2 100 66     8 if(defined $self->{config}{info} and !$bare)
2050             {
2051 1         4 my @info = split("\n",$self->{config}{info});
2052 1         2 for(@info){ print $handle '=info '.$_."\n"; }
  1         4  
2053             }
2054 2 50 33     12 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         4 for my $k (sort keys %{$self->{param}})
  2         12  
2060             {
2061 15 100       172 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       22 unless($bare)
2068             {
2069             print $handle "\n=long $k"
2070 11 100       46 ,$self->{short}{$k} ne '' ? " short $self->{short}{$k}" : ''
2071             ," type $typename[$self->{type}{$k}]"
2072             ,"\n";
2073 11         14 my @help = split("\n",${$self->{help}{$k}});
  11         29  
2074 11         19 for(@help)
2075             {
2076 11         25 print $handle "=help $_\n";
2077             }
2078             }
2079 11 100       26 my $values = $self->{type}{$k} ? $self->{param}{$k} : [ $self->{param}{$k} ];
2080 11 100       21 if($self->{type}{$k} == $hash)
2081             {
2082 2         4 my @vals;
2083 2         3 for my $k (sort keys %{$values})
  2         8  
2084             {
2085 4 50       17 push(@vals, $k.(defined $values->{$k} ? '='.$values->{$k} : ''));
2086             }
2087 2         5 $values = \@vals;
2088             }
2089 11 50       20 $values = [ undef ] unless defined $values;
2090 11         12 my $first = 1;
2091 11 50       21 print $handle "\n" unless $bare;
2092 11         13 for my $v (@{$values})
  11         16  
2093             {
2094             my $preop = $self->{type}{$k}
2095             ? ( (not $first)
2096             ? '.'
2097 19 50       64 : ( (@{$values} > 1) ? ' ' : '' ) )
  4 100       16  
    100          
2098             : '';
2099 19 100       31 if(defined $v)
2100             {
2101 18 100       34 if($v =~ /[\012\015]/)
2102             {
2103 1         2 my $end = 'EOT';
2104 1         2 my $num = '';
2105 1         11 $v =~ s/[\012\015]*\z/\n/g; # that line end business needs testing
2106 1         18 while($v =~ /(^|\n)$end$num(\n|$)/){ ++$num; }
  1         25  
2107 1         5 print $handle "$k $preop<<$end$num\n$v$end$num\n";
2108             }
2109 17         43 else{ print $handle "$k $preop= \"$v\"\n"; }
2110             }
2111 1         53 else{ print $handle "# $k is undefined\n"; }
2112              
2113 19         42 $first = 0;
2114             }
2115             }
2116             }
2117             }
2118              
2119             sub INT_push_hash
2120             {
2121 75     75 0 103 my $self = shift;
2122 75         93 my $par = shift; for (@_)
  75         150  
2123             {
2124 104         284 my ($k, $v) = split('=',$_,2);
2125 104 50       199 if(defined $k)
2126             {
2127 104         348 $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 328 my $self = shift; # (par, op, value, file||undef)
2139              
2140 280 50       567 return unless exists $self->{param}{$_[0]};
2141              
2142 280 100       707 if($self->{type}{$_[0]} == $scalar)
    100          
    50          
2143             {
2144 11     11   123 no warnings 'numeric';
  11         22  
  11         8867  
2145 101         189 my $par = \$self->{param}{$_[0]}; # scalar ref
2146 101 100       238 if ($_[1] eq '='){ $$par = $_[2]; }
  69 100       240  
    100          
    100          
    50          
    0          
2147 6         15 elsif($_[1] eq '.='){ $$par .= $_[2]; }
2148 10         44 elsif($_[1] eq '+='){ $$par += $_[2]; }
2149 11         40 elsif($_[1] eq '-='){ $$par -= $_[2]; }
2150 5         24 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         160 my $par = $self->{param}{$_[0]}; # array ref
2157 101         131 my $bad;
2158 101 100 66     375 if ($_[1] eq '='){ @{$par} = ( $_[2] ); }
  18 100 66     21  
  18 100       37  
    100          
2159 54         64 elsif($_[1] eq '.='){ push(@{$par}, $_[2]); }
  54         96  
2160 3         7 elsif($_[1] eq '//=' or ($_[1] eq '/=' and $_[2] eq '/')){ @{$par} = (); }
  3         6  
2161             elsif($_[1] =~ m:^/(.)/(.*)$:) # operator with specified array separator
2162             {
2163 25         67 my $sep = $1; # array separator
2164 25         41 my $op = $2; # actual operator
2165 25         176 my @values = split(/\Q$sep\E/, $_[2]);
2166 25 100       81 if ($op eq '='){ @{$par} = @values; }
  11 50       21  
  11         40  
2167 14         17 elsif($op eq '.='){ push(@{$par}, @values); }
  14         40  
2168 0         0 else{ $bad = 1; }
2169             }
2170 1         2 else{ $bad = 1 }
2171 101 100       312 if($bad)
2172             {
2173 1         4 $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         128 my $par = $self->{param}{$_[0]}; # hash ref
2180 78         89 my $bad;
2181              
2182 78 100 66     359 if($_[1] =~ m:^/(.)/(.*)$:) # operator with specified array separator
    100 66        
2183             {
2184 25         49 my $sep = $1; # array separator
2185 25         44 my $op = $2; # actual operator
2186 25         161 my @values = split(/\Q$sep\E/, $_[2]);
2187             # a sub just to avoid duplicating the name=value splitting and setting
2188 25 100       76 if ($op eq '='){ %{$par} = (); $self->INT_push_hash($par,@values); }
  11 50       16  
  11         27  
  11         37  
2189 14         35 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         11  
2195             } else
2196             {
2197 50 100       134 if ($_[1] eq '='){ %{$par} = (); $self->INT_push_hash($par, $_[2]); }
  12 50       22  
  12         27  
  12         37  
2198 38         85 elsif($_[1] eq '.='){ $self->INT_push_hash($par, $_[2]); }
2199 0         0 else{ $bad = 1 }
2200             }
2201 78 50       290 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 91 my $self = shift;
2212 60         91 my $p = $self->{param};
2213 60         82 my $olderr = @{$self->{errors}};
  60         106  
2214 60         84 for my $k (keys %{$self->{regex}})
  60         173  
2215             {
2216 140 100       377 if($self->{type}{$k} == $scalar)
    100          
    50          
2217             {
2218             $self->INT_error("Value of $k does not match regex: $p->{$k}")
2219 64 50       353 unless $p->{$k} =~ $self->{regex}{$k};
2220             } elsif($self->{type}{$k} == $array)
2221             {
2222 68         122 for(my $i=0; $i<@{$p->{$k}}; ++$i)
  83         219  
2223             {
2224             $self->INT_error("Element $i of $k does not match regex: $p->{$k}[$i]")
2225 15 100       81 unless $p->{$k}[$i] =~ $self->{regex}{$k};
2226             }
2227             } elsif($self->{type}{$k} == $hash)
2228             {
2229 8         9 for my $n (sort keys %{$p->{$k}})
  8         23  
2230             {
2231             $self->INT_error("Element $n of $k does not match regex: $p->{$k}{$n}")
2232 4 50       20 unless $p->{$k}{$n} =~ $self->{regex}{$k};
2233             }
2234             }
2235             }
2236 60         114 for my $k (keys %{$p})
  60         177  
2237             {
2238 11     11   77 no warnings 'uninitialized';
  11         20  
  11         6282  
2239             next
2240 337 100       596 unless ($self->{flags}{$k} & $nonempty);
2241 16 100 66     48 unless(
      100        
      100        
      100        
      100        
2242             ( $self->{type}{$k} == $scalar and $p->{$k} ne '' ) or
2243 8         24 ( $self->{type}{$k} == $array and @{$p->{$k}} ) or
2244 4         11 ( $self->{type}{$k} == $hash and %{$p->{$k}} )
2245             ){
2246 3         9 $self->INT_error("Parameter $k is empty but should not be.");
2247             }
2248             }
2249 60         91 return $olderr == @{$self->{errors}};
  60         196  
2250             }
2251              
2252             sub current_setup
2253             {
2254 3     3 1 20 require Storable;
2255 3         6 my $self = shift;
2256 3         64 my $config = Storable::dclone($self->{config});
2257 3         6 my @pardef;
2258 3         8 my $bin = builtins($self->{config});
2259 3         6 for my $p (sort keys %{$self->{param}})
  3         17  
2260             {
2261 24 100       41 next if $bin->{$p};
2262 18 100       75 my $val = ref($self->{param}{$p}) ? Storable::dclone($self->{param}{$p}) : $self->{param}{$p};
2263 18         29 push(@pardef, $p, $val, $self->{short}{$p}, ${$self->{help}{$p}});
  18         48  
2264             }
2265 3         13 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 247 my $self = shift;
2274 206         266 my $key = shift;
2275 206 100       418 return unless defined $self->{ops}{$key};
2276 144         200 $self->INT_verb_msg("Param: applying (@{$self->{ops}{$key}}) to $key of type $self->{type}{$key}\n");
  144         627  
2277 144         218 while(@{$self->{ops}{$key}})
  343         751  
2278             {
2279 199         235 my $op = shift(@{$self->{ops}{$key}});
  199         349  
2280 199         233 my $val = shift(@{$self->{ops}{$key}});
  199         317  
2281 199         425 $self->INT_apply_op($key, $op, $val);
2282             }
2283             }
2284              
2285             sub INT_verb_msg
2286             {
2287 1381     1381 0 1719 my $self = shift;
2288 1381 50 33     4213 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 31 my $self = shift;
2295             print STDERR "$self->{config}{program}: [Config::Param] Error: "
2296 14 50       22 , $_[0], "\n" unless $self->{config}{silenterr};
2297 14         20 push(@{$self->{errors}}, $_[0]);
  14         28  
2298 14         50 return 1;
2299             }
2300              
2301             1;
2302              
2303             __END__