File Coverage

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