← Index
Performance Profile   « block view • line view • sub view »
For /wise/base/deliv/dev/bin/getfix
  Run on Thu May 20 15:30:03 2010
Reported on Thu May 20 16:25:27 2010

File/wise/base/deliv/dev/lib/perl/WISE/Params.pm
Statements Executed38738
Total Time0.106722999999999 seconds

Subroutines — ordered by exclusive time
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
1110.016480.04028WISE::Params::parsedefs
1110.010280.01337WISE::Params::paramsfromfile
71410.009810.03212WISE::Params::Param_parse
1110.005750.00593WISE::Params::expand_tags
345310.003260.00436WISE::Params::paruqindex
1110.002470.00388WISE::Params::check_pragmas
408410.002340.00234WISE::Params::parunquote
404410.002160.00216WISE::Params::parblankquoted
86110.002140.00464WISE::Params::valstr
76110.001810.00639WISE::Params::paramchecklist
168310.001710.00250WISE::Params::parquote
86110.001640.00164WISE::Params::typeoftype
86110.001470.00147WISE::Params::paramcheck
76110.001250.00125WISE::Params::check_map_keys
33110.001190.00141WISE::Params::Param_reassign
24210.001130.00188WISE::Params::paramlist
138310.000930.00093WISE::Params::assign_ref
29110.000860.00086WISE::Params::parse_passon_param
1110.000860.00619WISE::Params::Param_lines
3110.000840.00239WISE::Params::paramlist2hash
2110.000750.00118WISE::Params::paramparselines
1110.000690.00069WISE::Params::parwrapup
1110.000600.00071WISE::Params::steps_resolve
76110.000520.00052WISE::Params::check_list_count
5110.000480.00048WISE::Params::parexpandlist
1110.000320.06583WISE::Params::Params
1110.000200.00020WISE::Params::check_required
2115.1e-55.1e-5WISE::Params::Param_get
1114.3e-50.00623WISE::Params::Param_print
1112.1e-50.00010WISE::Params::parwhoiam
1111.1e-51.1e-5WISE::Params::origval
00000WISE::Params::BEGIN
00000WISE::Params::Csh_set_params
00000WISE::Params::Emit_nmpar_defs
00000WISE::Params::Param_addval
00000WISE::Params::Param_default
00000WISE::Params::Param_help
00000WISE::Params::Param_specified
00000WISE::Params::cshescape
00000WISE::Params::loadparamsfromfile
00000WISE::Params::par_safe_eval
00000WISE::Params::paramsfrommodel
00000WISE::Params::paramsfromtty
00000WISE::Params::parcollapselist
00000WISE::Params::parqpat
00000WISE::Params::pass_filters

LineStmts.Exclusive
Time		Avg.Code
1#! /usr/bin/env perl
2
333.8e-51.3e-5use strict;
# spent 20µs making 1 call to strict::import
433.7e-51.2e-5use warnings;
# spent 19µs making 1 call to warnings::import
5
611.0e-61.0e-6my ($dataroot, $dynaroot, $localroot,$ramroot,
7 $unilocalroot, $hostname);
8
9#use Sys::Hostname qw/hostname/;
10
1130.000420.00014use Cwd ();
12
13BEGIN {
1480.008680.00108 chomp(($hostname) = `/bin/hostname -s 2>/dev/null`);
15 $hostname ||= 'UNKNOWN';
16 $dataroot = $ENV{WISE_DATAROOT};
17 $localroot = $ENV{WISE_LOCAL} || "/local";
18 $unilocalroot= $ENV{WISE_UNILOCAL} || "/compute/$hostname";
19 my $cwd = Cwd::fastcwd();
# spent 52µs making 1 call to Cwd::fastcwd
20 if($cwd) {
21 if($cwd =~ s!/+(scans|mops|coadds|ingest|ql)(/+.*|$)!!) {
22 $cwd =~ s!^/+wise-ops/+\d\d/+wise/+!/wise/!;
23 $dynaroot = $cwd if -d "$cwd/ref/params/wrap";
24 }
25 }
2610.000200.00020}
27
28
29package WISE::Params;
30
31# Functional interface to parameter handling.
32# See bottom for WISE::Pars package/class and its methods.
33
34#use threads::shared qw(share);
35
36use WISE::Env (cfglib=>'/wise/base/deliv/dev/lib/perl',
# spent 796µs making 1 call to WISE::Env::import, max recursion depth 1
3735.2e-51.7e-5 import=>[qw/$cfgdir $cfglib $basedir/]);
38
3930.000870.00029use WISE::Spawn;
# spent 26µs making 1 call to Exporter::Lite::import
4030.000740.00025use WISE::UtilsLight;
# spent 28µs making 1 call to Exporter::Lite::import
41
4212.0e-62.0e-6my $version = '$Id: Params.pm 7640 2010-03-21 21:07:10Z tim $ ';
43
4433.1e-51.0e-5use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION *DATA);
# spent 74µs making 1 call to vars::import
45
4635.2e-51.7e-5use Exporter::Lite;
# spent 37µs making 1 call to Exporter::Lite::import
47
4811.0e-61.0e-6$VERSION = 1.99;
4914.0e-64.0e-6@ISA = ();
50
5111.0e-61.0e-6@EXPORT_OK = qw();
52
5332.8e-59.3e-6use vars qw(@PARAMFILES @PARAMS_FROM_FILES);
# spent 35µs making 1 call to vars::import
54
55#use Carp;
5633.6e-51.2e-5use File::Basename;
# spent 79µs making 1 call to Exporter::import
5730.000400.00013use Scalar::Util 'reftype';
# spent 62µs making 1 call to Exporter::import
58
5911.0e-61.0e-6my $FPre = q/^\s*[-+]?(?:(?:(?:\d*\.?\d+|\d+\.)(?:[Ee][+-]?\d+)?)?|(?:[Nn]an|[Ii]nf))?\s*$/;
60
6111.1e-51.1e-5my %bools = (t=>1,f=>0,true=>1,false=>0,on=>1,off=>0,1=>1,0=>0,
62 "y"=>1,n=>0,yes=>1,"no"=>0);
63
6411.0e-61.0e-6my $err = '*** PARAMS';
65100my $warn= '=== PARAMS';
6611.0e-61.0e-6my $options_watch;
67100my $perlok = 0; # Disallow Perl data structures in list parameters
68
6912.0e-62.0e-6my %legal_file_pragmas = (in => 1, glob => 1, resolve => 1);
70
71my @defparamfiles = (
72 ($dataroot||$dynaroot||'/wise/fops').
73 "/ref/params/wrap/All.params", # Global
7418.0e-68.0e-6 (map {"$_/params/All.params"} (ref($cfgdir) # Config
75 ? @$cfgdir
76 : $cfgdir//'NONE')),
77 "./All.params" # Local
78 );
79
8014.0e-64.0e-6our %tag_predefs = (
81 #'@cfgdir' => $cfgdir, # Not ready for this
82 '@dynaroot' => $dynaroot,
83 '@dataroot' => $dataroot||'/wise/fops',
84 '@local' => $localroot,
85 '@unilocal' => $unilocalroot,
86 '@hostname' => $hostname,
87 );
88
8911.0e-61.0e-6our %params_from_model_opts = ();
90
91BEGIN {
9211.0e-61.0e-6 $^W = 0 if $ENV{_PARAM_DEBUG_};
9310.012850.01285}
94
95
96
# spent 65.8ms (323µs+65.5) within WISE::Params::Params which was called # once (323µs+65.5ms) by WISE::Pars::new at line 39 of /wise/base/deliv/dev/lib/perl/WISE/Pars.pm
sub Params {
971330.000403.0e-6 my $paramdefs = shift || "-";
98 my $opts = shift || {};
99 my ($argv);
100 local $_;
101
102 if(($_=reftype($opts))!~/hash/i) {
# spent 22µs making 1 call to Scalar::Util::reftype
103 die "$err: Don't know what to do with options of type $_ .\n";
104 }
105
106 my $ctxt = defined $opts->{defs} ? $opts->{defs} : {};
107
108 my $values = defined $opts->{vals} ? $opts->{vals} : {};
109 my $refs = $opts->{refs} || {};
110 my $strict = $opts->{strict}; # warn
111
112 if(($_=reftype($ctxt))!~/hash/i) {
# spent 5µs making 1 call to Scalar::Util::reftype
113 die "$err: Don't know what to do with defs of type '$_'.\n";
114 }
115 my $conditions = $opts->{conditions} || {};
116
117 $opts->{debug} ||= $ENV{_PARAM_DEBUG_} || 0;
118
119 my $debug = $opts->{debug};
120
121 # Variable references associated to command line param.s
122
123 if(($_=reftype($refs))!~/hash/i) {
# spent 5µs making 1 call to Scalar::Util::reftype
124 die "$err: Don't know what to do with refs of type '$_'.\n";
125 }
126 if(($_=reftype($values))!~/hash/i) {
# spent 5µs making 1 call to Scalar::Util::reftype
127 die "$err: Don't know what to do with vals of type '$_'.\n";
128 }
129 if(($_=reftype($ctxt))!~/hash/i) {
# spent 4µs making 1 call to Scalar::Util::reftype
130 die "$err: Don't know what to do with ctxt of type '$_'.\n";
131 }
132
133 # Create a local options param so it's passed on to other subs
134 my $myopts = {%$opts, defs=>$ctxt};
135
136 if(! $myopts->{noinit}) {
137 # Initialize data structures
138 %$values = ();
139 %$ctxt = ();
140 }
141
142 $ctxt->{_meta} = {};
143 $ctxt->{_meta}{vals} = $values;
144
145 $ctxt->{_meta}{debug} = $debug;
146 $^W = 0 if $debug; # Otherwise we get a bunch of uninit warnings
147
148 # Get our idea of our name.
149 my $iam = $ctxt->{_meta}{iam} = $opts->{iam} || parwhoiam();
150 $ctxt->{_meta}{iamorig} = $iam; # In case we're renamed
151 $err = "*** $iam/PARAMS";
152
153 my %refs;
154 %refs = %$refs;
155 $ctxt->{_meta}{refs} = \%refs;
156
157 my $tag_aliases = {};
158 %$tag_aliases = %{ $opts->{tag_aliases} || {} };
159 $ctxt->{_meta}{tag_aliases} = $tag_aliases;
160
161 # Parse parameter definitions
162 &parsedefs($paramdefs,$myopts); # ... modifies $ctxt
# spent 40.3ms making 1 call to WISE::Params::parsedefs
163
164 # Replace help, if specified
165 my $help = $opts->{help};
166 if($help) {
167 die "$err: Help option not a hash ref.\n"
168 if ref($help) !~ /hash/i;;
169 for my $param (keys %$help) {
170 my $ref = $help->{$param};
171 $ref = ! ref($ref) ? [$ref] : $ref;
172 die "$err: Help for parameter '$param' not an ".
173 "array ref or scalar.\n"
174 if ref($ref) !~ /array/i;
175 my $key = $param;
176 $key = '_meta' if $param =~ /^(general|top)$/i;
177 my $help = [];
178 @$help = map { (split /\n/) } @$ref;
179 $ctxt->{lc $key}{help} = $help;
180 }
181 }
182
183 if($myopts->{parseonly}) {
184 return $ctxt;
185 }
186
187 # Get argument list and save in defs structure
188 my @save;
189 if($myopts->{argv}) {
190 $argv = [];
191 @save = @$argv = @{ $myopts->{argv} };
192 } else {
193 @save = @ARGV;
194 $argv = \@ARGV;
195 }
196 $ctxt->{_meta}{argv} = $argv; # Named params will be eaten up ...
197 $ctxt->{_meta}{argv_orig} = \@save; # ... so keep the originals here
198
199 if(! @PARAMFILES && ! $ENV{NO_DEFAULT_PAR_FILES} &&
200 ! $opts->{nodefparfiles}) {
201 # Set up default parameter files.
202 @PARAMFILES = (defined $ENV{PAR_FILES}
203 ? split(/[:\s]+/,$ENV{PAR_FILES})
204 : (@defparamfiles
205 ? @defparamfiles
206 : () ));
207 push @PARAMFILES, (defined $ENV{PAR_ADDFILES}
208 ? split(/[:\s]+/,$ENV{PAR_ADDFILES})
209 : () );
210 }
211
212 @PARAMFILES = grep($_, @PARAMFILES); # Remove null names
213 {
214 my %there;
215 @PARAMFILES = grep(! $there{$_}++,@PARAMFILES); # Rem. dups
216 }
217
218 # Copy relevant parts of the environment to the "conditions" hash
219 $ctxt->{_meta}{conditions} = {};
220 for (qw(SODA_CONFIG PATH LD_LIBRARY_PATH PERL5LIB WISE HOSTNAME HOST
221 PWD USER UNIX DOMAIN OSTYPE LOGNAME GROUP USERNAME HOSTTYPE)) {
222 my $envval = $ENV{$_};
223 my $val;
224 # Split certain ':' or ',' separated lines
225 if($envval && /^(PATH|SODA_CONFIG|LD_LIBRARY_PATH|PERL5LIB)$/) {
226 $val = [];
227 @$val = split /[:,]+/, $envval;
228 }
229 $ctxt->{_meta}{conditions}{$_} = $val;
230 }
231 # Add explicit user conditions (possibly overriding those above.
232 for (keys %$conditions) {
233 my $cond = $conditions->{$_};
234 my $val;
235 if(ref $cond) {
236 $val = [];
237 @$val = @$cond;
238 } else {
239 $val = $cond;
240 }
241 $ctxt->{_meta}{conditions}{$_} = $val;
242 }
243
244 # Parse command line and assign param values and fill data structures
245 my @leftover = Param_parse($argv,{%$myopts,from=>1});
# spent 15.2ms making 1 call to WISE::Params::Param_parse
246
247 warn "$warn: Leftover arguments: @leftover.\n"
248 if $strict && @leftover;
249
250 # Add to predefined tags
251 $tag_predefs{'@iam'} = $ctxt->{_meta}{iam};
252
253 # Do tag expansion iteratively
254 if(! $opts->{notags} || ref $opts->{notags}) {
# spent 5.93ms making 1 call to WISE::Params::expand_tags
255 expand_tags($ctxt,$opts);
256 }
257
258 # Check to see if all required values are assigned
259 if(! $myopts->{norequired}) {
# spent 198µs making 1 call to WISE::Params::check_required
260 check_required($ctxt,$opts);
261 }
262
263 # Optionally check against file pragmas
264 if(! $opts->{nopragmas}) {
# spent 3.88ms making 1 call to WISE::Params::check_pragmas
265 check_pragmas($ctxt,$opts);
266 }
267
268 # If asked, print the parameters
269 if($myopts->{print}) { Param_print({defs=>$ctxt,%{$myopts->{printopts}}}); }
270
271 return $ctxt;
272}
273
274# Must be called only once per instantiation
275
# spent 40.3ms (16.5+23.8) within WISE::Params::parsedefs which was called # once (16.5ms+23.8ms) by WISE::Params::Params at line 162
sub parsedefs {
276102470.018121.8e-6 my($paramdefs,$opts) = (shift,shift);
277 my $com = '#';
278 my($cmnt,$ref,$orig,$ctxt,$values,$gotcmd,$unnamed);
279 my($aliases,$list,$hash,$otype,$type,$itype,$size,$mapkeys,$attribs);
280 my($intdefault,$default,$required,$nodefault,$postdefaults,%there);
281 my($i,$lastdef,$help,$refs,$iam,$tmp,$debug,$minlist,$maxlist,$rawtype);
282 my($minval,$maxval,$file_pragmas,$private,$quiet,$preinits);
283 my(@allhelp,@unnamed,%allaliases,@allparnames,@def);
284 local $_;
285
286 $ctxt = $opts->{defs} || die "$err/parsedefs: No defs.\n";
287 $nodefault = $opts->{nodefault};
288 $postdefaults = $opts->{defaults} || {}; # Out of band defaults
289 $preinits = $opts->{inits} || {}; # Out of band values
290 $debug = $opts->{debug} || $ctxt->{_meta}{debug} || 0;
291
292 $iam = $ctxt->{_meta}{iam};
293
294 $ctxt->{_meta}{parnames} = \@allparnames;
295 $ctxt->{_meta}{aliases} = \%allaliases;
296 $ctxt->{_meta}{help} = \@allhelp;
297 $ctxt->{_meta}{unnamed} = \@unnamed;
298
299 $values = $ctxt->{_meta}{vals};
300 $refs = $ctxt->{_meta}{refs};
301
302 # If $paramdefs is a array ref., read the contents pairwise into key=value
303 # pairs and join the keys into a str separated by newlines,
304 # and take the values as references to the target variables.
305 if(ref($paramdefs) =~ /array/i) {
306 my $newdefs = "";
307 while(@$paramdefs) {
308 my ($key,$val,$parm,$i);
309 # Copy comments and blank lines without further attention
310 $newdefs .= shift(@$paramdefs)."\n"
311 while @$paramdefs &&
312 ($paramdefs->[0] =~ /^\s*$com/ ||
313 $paramdefs->[0] =~ /^\s*$/);
314 last if ! @$paramdefs;
315 # Expand inclusions
316 if($paramdefs->[0] =~ /^\s*\$include_defs\s+(\S.*?)\s*$/) {
317 require WISE::Pars;
318 my $include_call = $1;
31911.8e-51.8e-5 my @inc_defs = eval "WISE::ParamDefs->$include_call";
# spent 651µs making 1 call to WISE::ParamDefs::basic
320 die "$err: Attempt to include definitions failed on ".
321 "'$include_call'.\n$@"
322 if $@;
323 shift @$paramdefs;
324 unshift @$paramdefs, @inc_defs;
325 next;
326 }
327 # Get param. definition
328 $key = shift @$paramdefs;
329 # Look ahead and see if a default is in the next entry
330 $key .= shift @$paramdefs if @$paramdefs &&
331 $paramdefs->[0] =~ /^\s*=/;
332 # Add to accumulating definition string.
333 $newdefs .= "$key\n";
334 # Skip comments
335 $newdefs .= shift(@$paramdefs)."\n"
336 while @$paramdefs && $paramdefs->[0] =~ /^\s*$com/;
337 # Get target reference (if any)
338 $val = shift @$paramdefs if @$paramdefs && ref $paramdefs->[0];
339 # Pull out first parameter alias
340 ($parm) = $key =~ m/^\s*([^$com].*?)\s*[,:]/;
341 # Use it as the key to the var. ref.
342 if(! $parm && $val) {
343 # Error if a valid identifier couldn't be found
344 die "$err: Pairwise definition of '$key' not valid.\n";
345 }
346 # Don't populate the hash if target is undefined
347 $refs->{lc $parm} = $val if $val;
348 ++$i;
349 }
350 # Now param defs are all one big string with individual defs
351 # separated by newlines
352 $paramdefs = $newdefs;
353 }
354
355 # Join lines split by newlines preceded by \
356 $paramdefs =~ s/(?<!\\)\\\n+[ \t]*//g;
357
358 # Now there's one parameter def. per line, and one line per param. def
359
360 # Split on newlines
361
362 for (split(/\n+/,$paramdefs)) {
363 next if /^\s*$/; # Skip blank lines
364
365 push @def,$_;
366
367 my (@aliases,@aliasesorig);
368
369 print "PARAM: Raw def of ".($iam||"?")." = '$_'\n" if $debug;
370 print "PARAM: ctxt = $ctxt\n" if $debug;
371
372 $orig = $_;
373 # Substitute in tags
374 s/\$iam\b/$iam/g if $iam; # Replace command name tag
375 # Look for an unquoted, unescaped comment character
376 if (($i=paruqindex($_,$com))>=0) {
# spent 3.53ms making 259 calls to WISE::Params::paruqindex, avg 14µs/call
377 # Trim off comments but save them as possible help strings
378 $cmnt = &parunquote(substr($_,$i+1),1);
# spent 1.04ms making 173 calls to WISE::Params::parunquote, avg 6µs/call
379 substr($_,$i) = ""; # Erase the line up to the comment char
380 $cmnt =~ s/^\s*$//; # Reduce blank lines to an empty string
381 } else {
382 # No comment
383 $cmnt = undef;
384 }
385 # Save help-related comments
386 if(defined $cmnt) {
387 # Comment is present and is not doubled (##), so save as help.
388 # (Double comments not saved (e.g. "## This is not help!"))
389 if($cmnt !~ /^$com/) {
390 if($cmnt=~/^\s*Command\s*=>\s*(\S+)/i) {
391 # Special syntax: Program name specified. Save it.
392 # Only take the first.
393 $iam = $ctxt->{_meta}{iam} = $1 if ! $iam;
394 $help = undef;
395 next;
396 } else {
397 # Just save the comment as regular help
398 ($help = $cmnt) =~ s/^ //; # .. after killing a leading sp
399 }
400 } else {
401 # Doubled comment. Treat as white space.
402 next;
403 }
404 } else {
405 $help = undef;
406 }
407 # Skip lines that are blank after comment stripping, after recording
408 # any help lines.
409 print "\tPARAM: HELP=/".(defined $help?$help:"<undef>")."/ ; ".
410 "lastdef='".(defined $lastdef?$lastdef:"<undef>")."'\n"
411 if $debug>1;
412 if (/^\s*$/) {
413 if(defined $help) {
414 # There was help on this line; which kind of help?
415 if(! defined $lastdef) { # General help
416 # This is before any param. def.s, so it's general help
417 # (i.e. not related to one parameter)
418 # (Only push blank help lines if there's help there now.)
419 print "\tPARAM: For General = ".
420 scalar(@allhelp)."\n"
421 if $debug>1;
422 push @allhelp,$help;
423 } else { # Parameter help
424 # This comment line followed a parameter def., so it's
425 # help specifically for that param.
426 # (Only push blank help lines if there's help there now.)
427 $ctxt->{$lastdef}{help} ||= [];
428 print "\tPARAM: For $lastdef = ".
429 scalar(@{$ctxt->{$lastdef}{help}})."\n"
430 if $debug>1;
431 push @{$ctxt->{$lastdef}{help}},$help
432 if @{$ctxt->{$lastdef}{help}} || $help ne "";
433 }
434 next;
435 }
436 }
437 print "\tPARAM: Massaged def = '$_'\n" if $debug;
438
439 # Parse definition
440 m'^ \s* ((?:[-\w]+\s*,\s*)*[-\w]+) \s* : # 1 = aliases
441 \s* (?:(list(?:\s*of)?
442 (?:\s+\d+(?:(?:\s+to\s+|\s*\.\.\s*|\s*-\s*)
443 (?:\d+|inf(?:inity)?))?)?
444 )\s+ )? # 2 = list (n)
445 ( # Types
446 (?: # numeric types
447 (?: r(?:eal)? | float | # real
448 d(?:oub(?:le)?)? | dbl |
449 i(?:nt(?:eger)?)? # integer
450 )
451 (?: \s* \( \s*
452 (?:[-+.\de]+|-inf(?:inity)?)
453 (?:\s+to\s+|\s*\.\.\s*)
454 (?:[-+.\de]+|inf(?:inity)?)
455 \s* \) )? # range
456 ) |
457 (?: # Bare string types
458 (?:
459 (?:s(?:tr(?:ing)?)?(?:\(\s*\d+\s*\))?) | # string
460 (?:c(?:h(?:ar(?:acter)?)?)?(?:\(\s*\d+\s*\))?) | # string
461 )
462 (?: \s* \( \s* # length range
463 \d+
464 (?:\s+to\s+|\s*\.\.\s*)
465 (?:\d+|inf(?:inity)?)
466 \s* \) )?
467 ) |
468 (?:(?:map(?:ping)? | hash | name[sd]?) \s*
469 (?: \([^()]*\) )? ) | # map/name type
470 b(?:ool(?:ean)?)? | # boolean type
471 (?:(?:file|fil?)(?:\s*\([^\)]*?\))?) | # file with pragma
472 sw(?:itch)? # switch
473 #| (?:g(?:r(?:oup)?)?(?:\(.*?\))?) # group
474 ) \s* # 3 = type
475 (?: ((?:(?:private|quiet)(?:\([^\)]*\))? \s*)+) )? # 4 = attributes
476 (?: =
477 (?: \s*
478 ( (?:(?:\$required|\$unnamed) \s* )+ ) # 5 =req/unnamed
479 )?
480 (?: \s* (\$default) \s* )? # 6 = internal default
481 (?: \s* (\S.*?) )? \s* # 7 = default value
482 )?
483 $'ix; #
484
485 print "\tPARAM: Raw parse = /".
486 join("/",map {$_//'UNDEF'} $1,$2,$3,$4,$5,$6,$7)."/\n"
487 if $debug;
488
489 if(! $1 || ! $3) {
490 die "$err: Bad parameter definition: '$orig'.\n";
491 }
492 ($aliases,$list,$rawtype) = ($1,$2,$3);
493 my $origtype = $rawtype;
494 ($attribs,$required,$intdefault,$default) = ($4,$5,$6,$7);
495 if($required) {
496 $unnamed = $required =~ s/\s*\$unnamed\s*//g;
497 } else {
498 $unnamed = undef;
499 }
500
501 if($list) {
502 $list =~ s/list(\s*of)?\s*/list of /;
503 if($list =~ s/(?<=list of )(\d+)(?:\s*(?:-|\.\.|\sto\s)\s*(\d+|inf))?\s*//i) {
504 $minlist = $1;
505 $maxlist = defined $2 ? $2 : $1;
506 } else {
507 $minlist = $maxlist = undef;
508 }
509 } else {
510 $minlist = $maxlist = undef;
511 }
512 @aliasesorig = split(/,+\s*/,$aliases);
513 @aliases = map {lc $_} @aliasesorig;
514 @there{@aliases} = (1)x@aliases;
515 @aliases = (@aliases,grep(! $there{$_}++,@aliasesorig));
516 if($unnamed) {
517 push @unnamed,$aliases[0];
518 }
519 if($rawtype =~ s/\s* \( \s*
520 ([-+.\de]+|-inf(?:inity)?)
521 (?:\s+to\s+|\s*\.\.\s*)
522 ([-+.\de]+|inf(?:inity)?)
523 \s* \) \s*//x) {
524 ($minval,$maxval) = ($1,$2);
525 $minval = eval {$minval + 0}
526 if $minval !~ /^-inf/;
527 $maxval = eval {$maxval + 0}
528 if defined $maxval && $maxval !~ /^inf/ && ! $@;
529 die "$err: Minval '$minval' or maxval '$maxval' is illegal ".
530 "for parameter $aliases[0].\n$@"
531 if $@;
532 $maxval = 'inf' if ! defined $maxval;
533 } else {
534 $minval = $maxval = undef;
535 }
536 if($rawtype =~ s/^(file|fil?)(?:\s*\((.*)\))/$1/i && $2) {
537 my $pragmas = $2;
538 $file_pragmas = [];
539 @$file_pragmas = split /\s*,\s*/, $pragmas;
540 print "\tPARAM: parsed pragmas for $aliasesorig[0]($1) = ".
541 "/@$file_pragmas/\n"
542 if $debug;
543 my @nope = grep {! $legal_file_pragmas{lc $_} } @$file_pragmas;
544 die "$err: Illegal file pragma(s) /".join("/",@nope)."/ ".
545 "for parameter $aliases[0].\n$@"
546 if @nope;
547 } else {
548 $file_pragmas = undef;
549 }
550
551 ($type,$itype,$size,$mapkeys,$otype) = &typeoftype($rawtype);
# spent 1.64ms making 86 calls to WISE::Params::typeoftype, avg 19µs/call
552
553 if(! $itype) {
554 die "$err: Type unknown for parameter $aliases[0], ".
555 "type='$rawtype'.\n";
556 }
557 $list = "list of" if $itype == 8 || $itype == 9;
558 $hash = $itype == 8 ? 1 : 0;
559 $private = $quiet = undef;
560 if($attribs) {
561 while($attribs =~ m%(private|quiet)(?:\(\s*(.*?)\s*\))?%ig) {
562 my ($attr,$spec) = ($1,$2);
563 $private = $spec ? $spec : 1 if lc($attr) eq 'private';
564 $quiet = $spec ? $spec : 1 if lc($attr) eq 'quiet';
565 }
566 }
567 # Default handling
568 if($nodefault) {
569 $default = undef;
570 } elsif(exists $postdefaults->{$aliases[0]}) {
571 $default = $postdefaults->{$aliases[0]};
572 $default = undef, $required = 1
573 if $default && $default=~/^\s*\$required\s*$/;
574 }
575 my $init;
576 if(exists $preinits->{$aliases[0]}) {
577 $init = $preinits->{$aliases[0]};
578 }
579 if(my ($dup) = grep defined $allaliases{$_},@aliases) {
580 die "$err: Duplicate parameter alias '$dup' ".
581 "found for param $allaliases{$dup} and $aliases[0].\n";
582 }
583 if($type eq "switch" and $list) {
584 die "$err: Switch parameter $aliases[0] ".
585 "may not be a list.\n";
586 }
587 if($type eq 'switch' && defined $default &&
588 ! defined $postdefaults->{$aliases[0]}) {
589 die "$err: Switch parameter $aliases[0] may not ".
590 "have a default.\n";
591 }
592 # Init meta structures for this param
593 @{$values}{@aliases,@aliasesorig} = () if $values;
594 if($list && $values) {
595 @{$values}{@aliases,@aliasesorig} =
596 ([])x(@aliases+@aliasesorig)
597 if ! $hash;
598 @{$values}{@aliases,@aliasesorig} =
599 ({})x(@aliases+@aliasesorig)
600 if $hash;
601 }
602 if($list) { $list .= " "; }
603
604 $ref = {
605 name=>$aliases[0], nameorig=>$aliasesorig[0],
606 aliases=>\@aliases, aliasesorig=>\@aliasesorig,
607 list=>$list, hash=>$hash, intdefault=>$intdefault,
608 otype=>$otype, type=>$type, itype=>$itype, rawtype=>$origtype,
609 size=>$size, mapkeys=>$mapkeys,
610 private=>$private, quiet=>$quiet,
611 defaultstr=>$default, required=>$required,
612 need=>$required, minlist=>$minlist, maxlist=>$maxlist,
613 minval=>$minval, maxval=>$maxval, file_pragmas=>$file_pragmas,
614 help=>[], unnamed=>$unnamed
615 };
616 $ctxt->{$aliases[0]} = $ref;
617
618 push @allparnames, $aliases[0];
619 @allaliases{@aliases,@aliasesorig} =
620 ($aliases[0]) x (@aliases+@aliasesorig);
621
622 if(defined $help && $help ne "") {
623 push @{$ctxt->{$aliases[0]}{help}},$help;
624 }
625
626 print "\tPARAM: Def = /$aliases[0]/$type/$itype/".
627 ($default//"UNDEF")."/".($required//"UNDEF")."/\n"
628 if $debug;
629
630 if($type ne "switch") {
631 if(defined $default) {
# spent 15.9ms making 62 calls to WISE::Params::Param_parse, avg 257µs/call
632 Param_parse(["-$aliases[0]",$default],
633 {%$opts,defaultdef=>1,from=>0});
634 }
635 if(defined $init) {
636 Param_parse(["-$aliases[0]",$init],
637 {%$opts,defaultdef=>0,from=>5});
638 }
639 } else {
640 # Switch. Need to handle value differently
641 Param_parse(["-$aliases[0]=0"],
# spent 1.03ms making 6 calls to WISE::Params::Param_parse, avg 172µs/call
642 {%$opts,defaultdef=>1,from=>0});
643 if(defined $init) {
644 Param_parse(["-$aliases[0]=$init"],
645 {%$opts,defaultdef=>0,from=>5});
646 }
647 }
648
649 $lastdef = $aliases[0];
650
651 } # Param loop
652
653 $ctxt->{_meta}{def} = \@def;
654
655 return $ctxt;
656}
657
658
659# Read command line param.s (including those from the environment and files)
660# and assign them according to the defined parameters.
661
662
# spent 32.1ms (9.81+22.3) within WISE::Params::Param_parse which was called 71 times, avg 452µs/call: # 62 times (7.44ms+8.47ms) by WISE::Params::parsedefs at line 631, avg 257µs/call # 6 times (662µs+371µs) by WISE::Params::parsedefs at line 641, avg 172µs/call # 2 times (1.05ms+-1052000ns) by WISE::Params::paramsfromfile at line 1590, avg 0/call # once (656µs+14.5ms) by WISE::Params::Params at line 245
sub Param_parse {
66381980.011021.3e-6 my ($argv,$opts) = @_;
664 $opts = { %$opts }; # Shallow clone
665
666 my $ctxt = $opts->{defs} or die "$err/parparse: No defs.\n";
667 my $nofiles = $opts->{nofiles};
668 my $debug = $opts->{debug} || $ctxt->{_meta}{debug} || 0;
669 my $nopasson = $opts->{nopasson} || 0;
670 my $from = $opts->{from};
671 my $defaultdef = $opts->{defaultdef} || 0;
672 my $strict = exists $opts->{strict} ? $opts->{strict} : 1; # warn
673
674 my $iam = $ctxt->{_meta}{iam};
675 my $values = $ctxt->{_meta}{vals} || 0;
676 my $refs = $ctxt->{_meta}{refs} || 0;
677
678 # Mark the param.s originally passed (before file and eniron var.
679 # interpolation) with their source of origin.
680 # -1=unknown, 0=default, 1=cmd line, 2=environ var., 3=file, 4=pass-on,
681 # 5=unnamed params
682 $from = $opts->{from} = ! defined $from ? -1 : $from;
683
684 print "\tPARAM_PARSE start: from=$from ...\n"
685 if $debug;
686 print "\tPARAM: ctxt=$ctxt, from=$from, argv='@$argv'\n"
687 if $debug;
688
689 if(! (keys %$ctxt)) {
690 return 0;
691 }
692
693 if(ref($argv) && ref($argv) !~ /array/i) {
694 die "*** $err: ARGV passed to Param_parse not an array ref.\n";
695 } elsif ($argv && ! ref($argv)) {
696 require Text::ParseWords; Text::ParseWords->import();
697 my $txt = $argv;
698 $argv = [];
699 @$argv = shellwords($txt);
700 } else {
701 $argv ||= []; # Got to put something there.
702 }
703
704 # More printble argv for error msgs
705 my @print_argv = @$argv;
706 for (@print_argv) {
707 $_ //= 'UNDEFINED';
708 $_ = length($_)>100 ? substr($_,0,100)."..." : $_;
709 }
710
711 my @add; # Unnamed params to process later
712
713 # Get parameters from "standard" files named in paramfiles
714 if(@PARAMFILES && ! $nofiles) {
715 my @files = @PARAMFILES; # Process in reverse order
716 @PARAMFILES = (); # To avoid infinite recursion
717 @add = paramsfromfile(1,\@files,$ctxt);
# spent 13.4ms making 1 call to WISE::Params::paramsfromfile
718 }
719
720 # Step through named parameters
721
722 my $pos = 0; # Position in cmd line arg list
723
724 ARGS: while (1) {
725
726 ++$pos;
727 my $p = shift @$argv;
728
729 print "\t\tPARAM: ctxt=$ctxt, param='".($p//'undef')."', ".
730 "next='".($argv->[0]//'undef')."'\n"
731 if $debug;
732
733 if(! defined $p) { last ARGS; } # Stop if not defined or if '--'
734 if($p eq '--') { last ARGS; }
735
736 if($p eq '-.DEBUG') {
737 $debug = $ctxt->{_meta}{debug} = 1;
738 next ARGS;
739 }
740
741 my $parname;
742 if($p =~ /^-(.+)$/) {
743 $parname = $1;
744 } else {
745 # END OF PARAMETER LIST, beginning of unnamed arguments
746 if($strict) {
747 my @dashes = grep {/^-+[^\d]/} @$argv;
748 if(@dashes) {
749 if($strict>1) {
750 die "$err: Some unnamed args begin with a dash: ".
751 join(",",@dashes).".\n";
752 } else {
753 warn "$warn: Some unnamed args begin with a dash: ".
754 join(",",@dashes).".\n";
755 }
756 }
757 }
758 --$pos;
759 unshift @$argv,$p;
760 last ARGS;
761 }
762
763 # Named parameter found. Process.
764
765 # OK if parameter is not defined?
766 my $skipok;
767 if($parname =~ s/^%//) {
768 $skipok = 1;
769 } else {
770 $skipok = 0;
771 }
772
773 # Add to or overwrite lists and hashes?
774 my $addlist;
775 if($parname =~ s/^\+//) {
776 # Add to lists/hashes
777 $addlist = 1;
778 } elsif($parname =~ s/^=//) {
779 # Overwrite lists/hashes
780 $addlist = 0;
781 } else {
782 # Final answer depends on whether the param is a hash or a list
783 $addlist = undef;
784 }
785
786 # Special processing for the '-help' option
787 # -help or -help[123] or -help_[123] or [brief,long,full,pod]_help
788 if($parname =~ /^(?:(brief|long|full)_?)?help(?:_?([0-2]))?$/ix) {
789 print "\t\tPARAM: Getting help /$1/$2/ for $parname\n"
790 if $debug;
791 my $val = &Param_help($1||$2||0,{%$opts,defs=>$ctxt,
792 param=>join(",",@$argv)});
793 exit($val ? 0 : 1);
794 }
795
796 # Special processing for the '-cache_parameters' option
797 if($parname =~ /^cache_parameters$/i) {
798 print "\t\tPARAM: Caching parameters for '$iam' ...\n"
799 if $debug;
800 &paramsfrommodel($0,{usecache=>1,
801 param_defs=>$ctxt->{_meta}{def},})
802 or die "$err: Unable to update cache.\n";
803 exit;
804 }
805
806 # Get parameters from files named on command line
807 if($parname =~ /^@(\S+)$/) {
808 my $files = $1;
809 print "--- Reading params from files '$files' ...\n" if $debug;
810 push @add,paramsfromfile($skipok,[split(':',$files)],$ctxt);
811 next ARGS;
812 }
813
814 my $rawname = $parname;
815 my $val;
816
817 # Look for an '=xxxx' subfield to the parameter that indicates
818 # a value is directly attached, not in the next word.
819 my $equals;
820 if($rawname !~ /:/ && $rawname =~ /^([^=]+)=(.+)$/) {
821 $rawname = $1;
822 $parname = lc $rawname;
823 $val = $2;
824 $equals = 1;
825 } else {
826 $equals = 0;
827 $parname = lc $parname;
828 }
829
830 if(! $nopasson && $parname =~ /:/) {
831 # Handle pass-on parameters (i.e. parameters meant to be
832 # passed on from one program to subsequent programs)
833
834 my $arg = shift @$argv;
835 ++$pos;
836
837 print "\t\tPARAM: Calling passon with /$parname/ = /$arg/ ...\n"
838 if $debug;
839
840 push @add, parse_passon_param($parname,$arg, { %$opts });
# spent 859µs making 29 calls to WISE::Params::parse_passon_param, avg 30µs/call
841
842 next ARGS;
843 }
844
845 # We only reach here if the parameter is a named parameter tag
846 # ("-something") meant for this app.
847
848 # Check to see if the name is recognized
849 my $full = $ctxt->{_meta}{aliases}{$parname};
850 if(! defined $full) {
851 if(! $skipok) { # Not known, and we care
852 die "$err: Unrecognized parameter: '$parname'.\n".
853 "$err: Bad cmd args: !".join("! ",@print_argv)."!.\n";
854 } else { # Not known, but we don't care
855 # Skip OK params are assumed to have args, unless they
856 # are already provided by the '='
857 shift @$argv if @$argv && ! $equals;
858 next ARGS;
859 }
860 }
861
862 my $fullorig = $ctxt->{$full}{nameorig}; # Original case
863 if($ctxt->{$full}{type} ne 'switch') {
864 if( ! $equals) {
865 ++$pos;
866 $val = shift @$argv;
867 }
868 if(! defined $val) {
869 die "$err: Parameter '$parname' missing its arg.\n".
870 "$err: Bad cmd args: !".join("! ",@print_argv)."!.\n";
871 }
872 }
873
874 # Record exactly how the user actually refered to the parameter name.
875 $ctxt->{$full}{given} = $parname;
876 # ...and exactly how the string looked originally
877 $ctxt->{$full}{origval} = $val;
878
879 # Check and return the value for this parameter
880 print "\t\tPARAM: VAL before paramchecklist = /$val/\n"
881 if $debug;
882
883 my $ary = &paramchecklist($full,$val,$ctxt,$opts);
# spent 6.39ms making 76 calls to WISE::Params::paramchecklist, avg 84µs/call
884
885 if(! defined $ary) {
886 die "$err: Paramchecklist failed on $full='$val'";
887 }
888
889 # Remove escape char.s and quotes
890 if(ref($ary)=~/array/i) {
891 $_=parunquote($_,1) for @$ary;
# spent 558µs making 86 calls to WISE::Params::parunquote, avg 6µs/call
892 } else {
893 for my $elem (values %$ary) {
894 if(! ref($elem)) {
# spent 107µs making 20 calls to WISE::Params::parunquote, avg 5µs/call
895 $elem = parunquote($elem,1);
896 } else {
897 $_ = parunquote($_, 1) for @$elem;
# spent 636µs making 129 calls to WISE::Params::parunquote, avg 5µs/call
898 }
899 }
900 }
901
902 $val = (! $ctxt->{$full}{list}
903 ? $ary->[0]
904 : $ary);
905
906 if($ctxt->{$full}{hash} && $ctxt->{$full}{val}) {
907 # If defined as a hash, add rather than replace, unless
908 # over-ridden by $addlist
909 if($addlist || ! defined $addlist) {
910 my @val = ref($val)=~/hash/i ? %$val : @$val;
911 $val = {};
912 %$val = ( %{$ctxt->{$full}{val}}, @val );
913 } else {
914 # $addlist is explicitly 0, meaning we need to replace
915 # the current hash value
916 # This will be done below by virtue of not having
917 # executed the line above.
918 }
919 } elsif ($ctxt->{$full}{list} && ! $ctxt->{$full}{hash} &&
920 $ctxt->{$full}{val}) {
921 # It's a list (not a hash) with an extant value.
922 # See if we've been instructed to add to the list
923 # rather than replace it.
924 if($addlist) {
925 @$val = (@{$ctxt->{$full}{val}},@$val);
926 }
927 }
928
929 my $nargs = $ctxt->{$full}{type} ne 'switch' && ! $equals
930 ? 1 : 0;
931
932 # Assign final values
933
934 print "\t\tPARAM: name=$full;val=$val".
935 (ref($val)?"=".join(",",ref($val)=~/hash/i?%$val:@$val)
936 :"").
937 ";from=$from;defdef=$defaultdef;".
938 "req=".($ctxt->{$full}{required}//"undef").";refs=$refs".
939 ($refs&&$refs->{$full}?":$refs->{$full}":"").
940 ";hash=$ctxt->{$full}{hash}/mapkeys=".
941 (ref($ctxt->{$full}{mapkeys})
942 ? "$ctxt->{$full}{mapkeys}:".
943 join(",",map{$_//'undef'}@{$ctxt->{$full}{mapkeys}})
944 : "none")."\n"
945 if $debug;
946
947 # Check validity of map keys
948 check_map_keys($full, $val, $from, $ctxt);
# spent 1.25ms making 76 calls to WISE::Params::check_map_keys, avg 16µs/call
949
950 # Check number of list elements
951 check_list_count($full,$val,$ctxt);
# spent 521µs making 76 calls to WISE::Params::check_list_count, avg 7µs/call
952
953 # Assign value(s)
954
955 if($values) {
956 # Antiquated global values hash
957 @{$values}{@{$ctxt->{$full}{aliases}},
958 @{$ctxt->{$full}{aliasesorig}}} =
959 ($val) x (@{$ctxt->{$full}{aliases}}+
960 @{$ctxt->{$full}{aliasesorig}});
961 }
962
963 $ctxt->{$full}{val} = $val;
964 $ctxt->{$full}{default} = $val if $defaultdef;
965 $ctxt->{$full}{isdefault} = 1 if $defaultdef;
966 $ctxt->{$full}{specified} = 0 if $defaultdef;
967 $ctxt->{$full}{isdefault} = 0 if ! $defaultdef;
968 $ctxt->{$full}{specified} = 1 if ! $defaultdef;
969 $ctxt->{$full}{need} = 0;
970 $ctxt->{$full}{source} = $from;
971 $ctxt->{$full}{pos} = $pos-1-$nargs;
972 $ctxt->{$full}{nargs} = $nargs;
973 $ctxt->{$full}{origname} = $rawname;
974
975 # If a variable ref. was defined for this option,
976 # put the value there too.
977 if($refs) {
978 my $ref = $refs->{$full} || $refs->{$fullorig};
979 assign_ref($ref, $val, $ctxt->{$full}, $full);
# spent 531µs making 76 calls to WISE::Params::assign_ref, avg 7µs/call
980 }
981
982 # ========================
983 # End of parameter parsing
984
985
986 } # while(1)
987
988 # Process parameters that take from the unnamed parameter list
989 my $unmparams = $ctxt->{_meta}{unnamed};
990 if($from == 1 && $unmparams && @$unmparams && @$argv) {
991 for my $param (@$unmparams) {
992 last if ! @$argv;
993 next if $ctxt->{$param}{specified};
994 # If a parameter associated itself with unnamed parameters,
995 # assign those values.
996 my $val;
997 #print "/--- 1 @$argv/\n";
998 if($ctxt->{$param}{list}) {
999 my @get;
1000 if($ctxt->{$param}{maxlist} &&
1001 $ctxt->{$param}{maxlist} !~ /^inf/i &&
1002 $ctxt->{$param}{maxlist} < @$argv ) {
1003 @get = splice @$argv,0,$ctxt->{$param}{maxlist};
1004 } else {
1005 @get = @$argv;
1006 @$argv = ();
1007 }
1008 $val = join(",",map { parquote($_,",") } @get);
1009 } else {
1010 $val = shift(@$argv);
1011 }
1012 #print "/--- 2 @$argv/\n";
1013 Param_parse(["-$param",$val],{defs=>$ctxt,
1014 vals=>$values,
1015 refs=>$refs,
1016 from=>5});
1017 }
1018 }
1019
1020 # Return any left over parameters from files or pass-on params
1021
1022 return (@$argv);
1023}
1024
1025
# spent 859µs within WISE::Params::parse_passon_param which was called 29 times, avg 30µs/call: # 29 times (859µs+0) by WISE::Params::Param_parse at line 840, avg 30µs/call
sub parse_passon_param {
10267190.000771.1e-6 my $parname = shift;
1027 my $arg = shift;
1028 my $opts = shift || {};
1029 my $ctxt = $opts->{defs};
1030 my $iam = $ctxt->{_meta}{iam} || $opts->{iam};
1031 my $dofilters = ! $opts->{nofilters};
1032 my $debug = $opts->{debug} || $ctxt->{_meta}{debug};
1033 my $from = $opts->{from};
1034 my @add;
1035
1036 require Text::ParseWords;
1037
1038 my (@list,@abslist);
1039
1040 # Split on the ':' "path" separator and filter out any
1041 # empty or undefined elements other than the first, for which
1042 # a NULL string is interpreted meaning the current executable.
1043 @list = split(/:/,$parname);
1044
1045 # Test for illegal '-:' construct.
1046 die "$err: Illegal pass-on parameter: '$parname'.\n"
1047 if ! @list;
1048
1049 # Remove and save a possible terminal filter
1050 my $filter;
1051 ($list[0] eq '*' && @list>1 ? $list[1] : $list[0]) =~ s|\{(.+)\}$||
1052 and
1053 $filter = $1;
1054
1055 # Substitute current name for empty field
1056 @list = ($list[0]||lc($iam), grep(defined $_, @list[1..$#list]));
1057
1058 # Test for name match.
1059
1060 # Expand any abbrev.s
1061 for my $nm (@list) {
1062 if(defined $WISE::Spawn::abbrev{$nm}) {
1063 $nm = $WISE::Spawn::abbrev{$nm};
1064 }
1065 }
1066
1067 @abslist = @list;
1068
1069 print "\t\t\tPARM->passon: /@list/ = /$arg/\n" if $debug;
1070
1071 my $global = 0;
1072 if ($list[0] eq '*' && defined $list[1]) {
1073 # Propogate; see if the next name matches. If so,
1074 # shift out the propogator and continue normal
1075 # processing. If not, propogate the whole thing.
1076 if(lc($list[1]) eq '*' && @list == 2) {
1077 # A global wildcard match ('-*:* ...'). Match and propgate.
1078 print "\t\t\t\tPARM->passon: !!! WILDCARD MATCH\n" if $debug;
1079 $global = 1;
1080 } elsif(lc($list[1]) eq lc($iam)) {
1081 # A normal match. Do not propagate
1082 shift @list;
1083 shift @list;
1084 }
1085 } elsif(lc($list[0]) eq lc($iam)) {
1086 # A direct match; shift it out and process below.
1087 print "\t\t\t\tPARM->passon: !!! MATCH\n" if $debug;
1088 shift @list;
1089 } else {
1090 # No match
1091 print "\t\t\t\tPARM->passon: NO MATCH: /$list[0]/!=/$iam/\n" if $debug;
1092 return ();
1093 }
1094
1095 if($dofilters && $filter) {
1096 # Process any terminal parameter filters
1097 print "\t\t\tPARM->passon: Filtering with /$filter/\n" if $debug;
1098 pass_filters($filter,{defs=>$ctxt,debug=>$debug}) or return ();
1099 }
1100
1101 # The name matched, see if there are more names which should be
1102 # passed on. If the list is empty, the arg.s are meant for this
1103 # execution.
1104
1105 if(@list) { # There are more
1106 # There are more names, so pass them on down the line.
1107 # Construct the pass-on param. name
1108 my $param = '-'.join(':',@list).':';
1109 my $absparam = '-'.join(':',@abslist).':';
1110
1111 # Error if there's no argument for the parameter
1112 die "$err: Pass-on paramter $param has no ".
1113 "argument.\n"
1114 if ! defined $arg ;
1115
1116 # Save parameters which need to be passed on further
1117
1118 $ctxt->{_meta}{pass_on} = []
1119 if ! $ctxt->{_meta}{pass_on};
1120 $ctxt->{_meta}{pass_on_abs} = []
1121 if ! $ctxt->{_meta}{pass_on_abs};
1122 $ctxt->{_meta}{pass_from} = []
1123 if ! $ctxt->{_meta}{pass_from};
1124
1125 push @{$ctxt->{_meta}{pass_on}},$param;
1126 push @{$ctxt->{_meta}{pass_from}},$from;
1127 # Argument
1128 push @{$ctxt->{_meta}{pass_on}}, $arg;
1129 push @{$ctxt->{_meta}{pass_from}},undef;
1130 # Same in absolute addressing
1131 push @{$ctxt->{_meta}{pass_on_abs}},$absparam;
1132 push @{$ctxt->{_meta}{pass_on_abs}}, $arg;
1133
1134
1135 # Since there are more names, this program can't be the
1136 # target. Move on to the next arg.
1137 # UNLESS the '$global' flag is set, in which case we're BOTH processing
1138 # and propagating
1139
1140 if(! $global) {
1141 return ();
1142 }
1143 }
1144
1145 # No more names, or match was global, so this app. is the target. Put
1146 # arg.s in the array and parse them.
1147
1148 die "$err: Pass-on paramter $parname has no argument.\n"
1149 if ! defined $arg;
1150
1151 # Put arguemnt targetted for this exec. onto its argument
1152 # list for parsing, after first separating on whitespace.
1153
1154 my @args = Text::ParseWords::quotewords('\s+',0,$arg);
1155
1156 print "\t\t\tPARM->passon: PARSING /@args/\n" if $debug;
1157
1158 push @add,Param_parse(\@args,{%$opts,from=>4});
1159
1160 return @add;
1161}
1162
1163sub pass_filters {
1164 my $filter = shift;
1165 my $opts = shift || {};
1166 my $ctxt = $opts->{defs};
1167 my $debug = $opts->{debug} || $ctxt->{_meta}{debug};
1168 my @filter;
1169
1170 @filter = split /\s*,\s*/,$filter if $filter;
1171
1172 while(@filter) {
1173 my $test = shift @filter;
1174 # Get param name and comparison value
1175 my ($tstparam,$check) =
1176 $test=~/^\s*([^=]+)\s*=\s*([^=]+)\s*$/;
1177 print "--- Applying filter '$tstparam=$check'\n" if $debug;
1178 die "$err: Filter not in 'param=test' form: '$test'.\n"
1179 if ! $tstparam;
1180 # Remove outer quotes from value
1181 $check =~ s/'([^'])'/$1/
1182 or
1183 $check =~ s/"([^"])"/$1/;
1184 my $tstfull = $ctxt->{_meta}{aliases}{lc $tstparam};
1185 my $parval = $ctxt->{$tstfull}{val};
1186 my $partype= $ctxt->{$tstfull}{type};
1187 die "$err: Unrecognized filter parameter '$tstparam'.\n"
1188 if ! $tstfull;
1189 die "$err: Can't filter on list param '$tstparam'.\n"
1190 if $ctxt->{$tstfull}{list};
1191 die "$err: Numeric filter '$tstparam=$check' has ".
1192 "non-numeric value.\n"
1193 if $partype=~/^(u?i)|d|r|float/ && $check !~ /$FPre/;
1194 $parval = 0
1195 if $partype=~/^sw/ && ! defined $parval;
1196 # If there's a match, pull off the filter and carry on.
1197 # Otherwise, skip this param.
1198 if(defined $parval &&
1199 (lc($check) =~ /^<def(ined)?>$/ ||
1200 ($partype=~/^s|c|f/ && $check eq $parval) ||
1201 ($partype=~/^(u?i)|d|r|float/ && $check == $parval) ||
1202 ($partype=~/^b/ && defined $bools{$check} &&
1203 $bools{$check} == $bools{$parval}) ||
1204 ($partype=~/^sw/ && !!$check + 0 == !!$parval + 0)
1205 ) ) {
1206 # Filter matched. Do nothing and carry on
1207 print "--- Filter '$tstparam=$check' matched ($parval).\n"
1208 if $debug;
1209 } else {
1210 # Filter failed; skip parameter
1211 print "--- Filter '$tstparam=$check' failed ($parval).\n"
1212 if $debug;
1213 return 0;
1214 }
1215 }
1216
1217 return 1;
1218}
1219
1220
# spent 521µs within WISE::Params::check_list_count which was called 76 times, avg 7µs/call: # 76 times (521µs+0) by WISE::Params::Param_parse at line 951, avg 7µs/call
sub check_list_count {
12213840.000359.1e-7 my $param = shift;
1222 my $val = shift;
1223 my $ctxt = shift;
1224
1225 if ($ctxt->{$param}{list} && defined $ctxt->{$param}{minlist}) {
1226 # Range check number of list entries
1227 my $n = @$val;
1228 if((defined $ctxt->{$param}{minlist} &&
1229 defined $ctxt->{$param}{maxlist} &&
1230 ($n < $ctxt->{$param}{minlist} ||
1231 ($ctxt->{$param}{maxlist}!~/^inf/i &&
1232 $n > $ctxt->{$param}{maxlist}))) ||
1233 (defined $ctxt->{$param}{minlist} &&
1234 ! defined $ctxt->{$param}{maxlist} &&
1235 $n != $ctxt->{$param}{minlist})
1236 ) {
1237 die "$err: Number of list values ($n) for parameter ".
1238 "$param is outside the range ".
1239 (defined $ctxt->{$param}{minlist} && $ctxt->{$param}{maxlist}
1240 ? "$ctxt->{$param}{minlist} to $ctxt->{$param}{maxlist}"
1241 : "$ctxt->{$param}{minlist} to $ctxt->{$param}{minlist}"
1242 ).".\n";
1243 }
1244 }
1245
1246 return 1;
1247}
1248
1249
# spent 1.25ms within WISE::Params::check_map_keys which was called 76 times, avg 16µs/call: # 76 times (1.25ms+0) by WISE::Params::Param_parse at line 948, avg 16µs/call
sub check_map_keys {
125013080.001058.0e-7 my $param = shift;
1251 my $val = shift;
1252 my $from = shift;
1253 my $ctxt = shift;
1254
1255 if(ref($val) && $ctxt->{$param}{mapkeys} &&
1256 @{$ctxt->{$param}{mapkeys}}) {
1257 # A specific set of allowable mapping keys were
1258 # defined. Check that only those keys are used.
1259 my (%seen,@nope);
1260 @$val = grep { ! $seen{$_}++ } @$val if ref($val) !~ /hash/i;
1261 #print STDERR "--- $0: $param $from /$val/ /$ctxt->{$param}{type}/ ".
1262 # "/$ctxt->{$param}{origval}/ ".
1263 # (ref($val)!~/hash/i
1264 # ? join(",",@$val)
1265 # : join(",",map{"$_=>$val->{$_}"}keys%$val))."\n";
1266 my @keys = ref($val) =~ /hash/i ? keys %$val : @$val;
1267 if($ctxt->{$param}{mapkeys}[0] =~ /^\@defaults$/i && $from==0) {
1268 # Get legal keys from defaults
1269 $ctxt->{$param}{mapkeys} = [];
1270 @{$ctxt->{$param}{mapkeys}} = @keys;
1271 #print STDERR "--- $0: $param /@keys/\n";
1272 }
1273 my @names = map { lc($_) } @{$ctxt->{$param}{mapkeys}};
1274 for my $k (@keys) {
1275 my $matched = 0;
1276 for my $name (@names) {
1277 if($name =~ s/^\s*-\+// || $name =~ s/^\s*\+-//) {
1278 # Convert to re for optional leading '+' or '-'
1279 $name = "/[-+]?$name/";
1280 }
1281 my ($re) = $name=~m|^/(.*)/$|;
1282 $matched = 1
1283 if defined $re ? lc($k)=~/^$re$/ : lc($k) eq $name;
1284 last if $matched;
1285 }
1286 push @nope, $k if ! $matched;
1287 }
1288 if(@nope) {
1289 die "$err: Value for parameter $param has illegal key(s) ".
1290 "'@nope'.\n";
1291 }
1292 }
1293
1294 return 1;
1295}
1296
1297
1298
1299
# spent 933µs within WISE::Params::assign_ref which was called 138 times, avg 7µs/call: # 76 times (531µs+0) by WISE::Params::Param_parse at line 979, avg 7µs/call # 33 times (216µs+0) by WISE::Params::Param_reassign at line 1501, avg 7µs/call # 29 times (186µs+0) by WISE::Params::expand_tags at line 2542, avg 6µs/call
sub assign_ref {
13006900.000588.4e-7 my $ref = shift;
1301 my $val = shift;
1302 my $def = shift;
1303 my $parname= shift || ""; # For better error msgs
1304
1305 return if ! $ref;
1306
1307 if(! ref($ref) || ref($ref)!~/scalar|hash|array/i) {
1308 die "$err: Don't know how to assign to target ref ".
1309 "'$ref'/'".ref($ref)."' ($parname)\n";
1310 }
1311
1312 if(ref($val) =~ /hash|array/i) {
1313 my @val = (ref($val) eq "ARRAY"
1314 ? @$val
1315 : ref($val) eq "HASH"
1316 ? map { ($_,$val->{$_}) } sort keys %$val
1317 : ()
1318 );
1319
1320 if((ref($ref) =~ /hash/i || $def->{itype} == 8) && (@val%2) > 0) {
1321 die "$err: Value for hash reference for parameter $parname ".
1322 "has odd number of elements.\n";
1323 }
1324 if(ref($ref) =~ /array/i) {
1325 if($def->{type} eq 'name') {
1326 # Only want the hash values
1327 @$ref = map { $val[$_] } grep { ! $_%2 } 0..$#val;
1328 } else {
1329 @$ref = @val;
1330 }
1331 } elsif(ref($ref) =~ /hash/i) {
1332 %$ref = @val;
1333 } else { # Scalar ref
1334 my $new;
1335 if($def->{hash}) {
1336 $new = {};
1337 %$new = @val;
1338 } else {
1339 $new = [];
1340 @$new = @val;
1341 }
1342 $$ref = $new;
1343 }
1344 } else {
1345 $$ref = $val;
1346 }
1347
1348 return $ref;
1349}
1350
1351sub Param_specified {
1352 my $alias = shift;
1353 my $opts = shift || {};
1354 my $ctxt = $opts->{defs};
1355 my $stealth = $opts->{stealth};
1356
1357 return if ! defined $alias;
1358
1359 my $full = ( $ctxt->{_meta}{aliases}{lc $alias} ||
1360 # Also look for stealth values
1361 ($stealth && exists $ctxt->{lc $alias} ? lc $alias : undef) );
1362
1363 if($full) {
1364 return $ctxt->{$full}{specified};
1365 } else {
1366 return;
1367 }
1368}
1369
1370sub Param_addval {
1371 my $full = shift;
1372 my $val = shift;
1373 my $opts = shift || {};
1374 my $ctxt = $opts->{defs} or die "$err/addval: No defs.\n";
1375 my $aliases = [];
1376 @$aliases = @{$opts->{aliases} || []}; # Make a copy
1377 my $tp = $opts->{type};
1378 my $help = [];
1379 @$help = @{$opts->{help} || []};
1380 my $stealth = $opts->{stealth};
1381
1382 $full = lc $full;
1383
1384 die "$err/addval: Name '$full' already used"
1385 if exists $ctxt->{$full};
1386
1387 die "$err/addval: One of the aliases '@$aliases' of '$full' already used"
1388 if grep exists $ctxt->{_meta}{aliases}{$_}, @$aliases;
1389
1390 unshift @$aliases,$full;
1391
1392 push @{$ctxt->{_meta}{parnames}},$full;
1393
1394 # Don't make aliases visible in stealth mode
1395 @{$ctxt->{_meta}{aliases}}{@$aliases} = ($full) x @$aliases
1396 if ! $stealth;
1397
1398 my ($type,$itype,$size,$mapkeys,$otype);
1399
1400 if($tp) {
1401 ($type,$itype,$size,$mapkeys,$otype) = WISE::Params::typeoftype($tp);
1402 } else {
1403 ($type,$itype,$size,$mapkeys,$otype) = ("",0,undef,undef,"");
1404 }
1405
1406 my $ref;
1407 my $ishash = ref($val)=~/hash/i;
1408
1409 $ref = {name => $full, nameorig => $full,
1410 aliases => $aliases, aliasesorig => $aliases,
1411 list => ref($val), otype => $otype,
1412 type => $type, itype => $itype,
1413 hash => $ishash, size => $size,
1414 mapkeys => $mapkeys, help => $help
1415 };
1416
1417 $ctxt->{$full} = $ref;
1418
1419 my @vals = Param_reassign($full,$val,$opts);
1420
1421 # Remove name from radar in stealth mode.
1422 # (Had to be added in above so reassign would work.)
1423 pop @{$ctxt->{_meta}{parnames}} if $stealth;
1424
1425 return @vals;
1426}
1427
1428
# spent 1.41ms (1.19+216µs) within WISE::Params::Param_reassign which was called 33 times, avg 43µs/call: # 33 times (1.19ms+216µs) by WISE::Params::check_pragmas at line 2033, avg 43µs/call
sub Param_reassign {
142911220.001161.0e-6 my $opts = ref $_[-1] ? pop : {};
1430 die "$err/reassign: opts not a hash ref" if ref($opts) ne 'HASH';
1431 my $ctxt = $opts->{defs} || die "$err/reassign: No defs.\n";
1432 my $default = $opts->{default}; # Only change if not specified
1433 my $missok = $opts->{missingok};
1434 my $stealth = $opts->{stealth};
1435 my $asgiven = $opts->{asgiven}; # Don't change specified/default status
1436 my $public = $opts->{public}; # Make private params public
1437 my $vals = $ctxt->{_meta}{vals};
1438 my $refs = $ctxt->{_meta}{refs};
1439 my ($alias,$newval,@newvals);
1440
1441 die "$err/reassign: Uneven (non-hash) arg count.\n" if @_%2;
1442
1443 while(@_) {
1444
1445 $alias = shift;
1446 $newval= shift;
1447
1448 die "$err/reassign: Undefined alias"
1449 if ! defined $alias && ! $missok;
1450
1451 next if ! defined $alias;
1452
1453 my $full = ( $ctxt->{_meta}{aliases}{lc $alias} ||
1454 # Also look for stealth values
1455 ($stealth && exists $ctxt->{lc $alias}
1456 ? lc $alias : undef) );
1457
1458 die "$err/reassign: Alias '$alias' not found"
1459 if ! defined $full && ! $missok;
1460
1461 next if ! defined $full;
1462
1463 # Make no change if the param was specified explicitly and we
1464 # only want to change the default.
1465 next if $default && Param_specified($full,$opts);
1466
1467 $ctxt->{$full} ||= {};
1468
1469 $ctxt->{$full}{need} = 0; # Since we have a value ...
1470
1471 # If a scalar was presented to a list param, make it an array ref
1472 if(! ref($newval) && $ctxt->{$full}{list}) {
1473 $newval = [$newval];
1474 }
1475
1476 if(! $asgiven) {
1477 if(! $default) {
1478 $ctxt->{$full}{specified} = 1;
1479 $ctxt->{$full}{isdefault} = 0;
1480 } else {
1481 $ctxt->{$full}{specified} = 0;
1482 $ctxt->{$full}{isdefault} = 1;
1483 }
1484 }
1485
1486 if($public) { $ctxt->{$full}{private} = 0; }
1487
1488 my $ref = $refs->{$full};
1489
1490 print "params: Reassigning $full = '".(defined$newval?$newval:"undef").
1491 "'.\n"
1492 if $opts->{verbose};
1493
1494 # Assign
1495
1496 $ctxt->{$full}{val} = $newval;
1497 @{$vals}{@{$ctxt->{$full}{aliases}},@{$ctxt->{$full}{aliasesorig}}} =
1498 ($newval)x(@{$ctxt->{$full}{aliases}}+
1499 @{$ctxt->{$full}{aliasesorig}});
1500
1501 assign_ref($ref, $newval, $ctxt->{$full}, $full);
# spent 216µs making 33 calls to WISE::Params::assign_ref, avg 7µs/call
1502
1503 # If treating as a default, make this the default value of record.
1504 if($default) {
1505 $ctxt->{$full}{default} = $newval;
1506 $ctxt->{$full}{defaultstr} = valstr($ctxt,$full,1);
1507 }
1508
1509 push @newvals,$newval;
1510 }
1511
1512 # Return the whole array (array context), or just the final value (scalar)
1513 return (@newvals);
1514}
1515
1516sub Param_default {
1517 my $opts = ref $_[-1] ? pop : {};
1518 return Param_reassign(@_,{%$opts,default => 1});
1519}
1520
1521
# spent 51µs within WISE::Params::Param_get which was called 2 times, avg 25µs/call: # 2 times (51µs+0) by WISE::Pars::get at line 110 of /wise/base/deliv/dev/lib/perl/WISE/Pars.pm, avg 25µs/call
sub Param_get {
1522303.7e-51.2e-6 my $opts = ref $_[-1] ? pop : {};
1523 die "$err/get: opts not a hash ref" if ref($opts) ne 'HASH';
1524 my $ctxt = $opts->{defs} || die "$err/get: No defs.\n";
1525 my $missok = $opts->{missingok};
1526 my $stealth = $opts->{stealth};
1527 my ($alias,$val,@vals);
1528
1529 while(@_) {
1530
1531 $alias = shift;
1532
1533 die "$err/get: Undefined alias.\n"
1534 if ! defined $alias && ! $missok;
1535
1536 next if ! defined $alias;
1537
1538 my $full = ( $ctxt->{_meta}{aliases}{$alias} ||
1539 # Also look for stealth values
1540 ($stealth && exists $ctxt->{$alias} ? $alias : undef ));
1541
1542 die "$err/get: Alias '$alias' not found"
1543 if ! defined $full && ! $missok;
1544
1545 $val = defined $full ? $ctxt->{$full}{val} : undef;
1546
1547 push @vals,$val;
1548 }
1549
1550 return wantarray ? @vals : $vals[-1] ;
1551}
1552
1553
# spent 13.4ms (10.3+3.09) within WISE::Params::paramsfromfile which was called # once (10.3ms+3.09ms) by WISE::Params::Param_parse at line 717
sub paramsfromfile {
1554420.010350.00025 my $skipok = shift;
1555 my $files = shift || [];
1556 my $ctxt = shift || die "$err/fromfile: No defs.\n";
1557 my (@in,@add,$debug);
1558
1559 $debug = $ctxt->{_meta}{debug} || 0;
1560
1561 print "--- Processing @$files...\n" if $debug;
1562 for my $in (@$files) {
1563 if(! defined $in || $in eq "") { next; }
1564 if($in ne '-') {
1565 if($skipok && (! -e $in || -z $in)) {
1566 print "--- Skipping param file '$in'\n" if $debug;
1567 next;
1568 }
1569 open(IN,"<$in") or
1570 die "$err: Can't input from '$in': $!\n";
1571 } else {
1572 open(IN,"<&STDIN") or
1573 die "$err: Can't input from STDIN: $!\n";
1574 }
1575 if($in ne "-" || ! -t STDIN || ! -t STDOUT || ! -t STDERR) {
1576 print "--- Reading from $in\n" if $debug;
1577 chomp(@in = <IN>); # For file input or redirected stdin
1578 } else {
1579 chomp(@in = &paramsfromtty(\*IN,$ctxt)); # input from terminal
1580 }
1581 close(IN) or
1582 die "$err: Trouble reading (on close) from '$in': $!\n";
1583
1584 my @fixed = paramparselines($in,\@in,$ctxt->{_meta}{conditions});
# spent 1.18ms making 2 calls to WISE::Params::paramparselines, avg 591µs/call
1585 print "--- Fixed = //".join("//",@fixed)."//\n" if $debug;
1586 if(@fixed) {
1587 print "PARAM: === Parsing ".@fixed." param lines from $in ...\n"
1588 if $debug;
1589 push @PARAMS_FROM_FILES,($in,[@fixed]);
1590 push @add, Param_parse(\@fixed,{defs=>$ctxt,from=>3});
# spent 1.91ms making 2 calls to WISE::Params::Param_parse, avg 0/call, max recursion depth 1
1591 }
1592 }
1593
1594 print "--- from param file(s):\n---------\n".
1595 (@add?"@add":"none")."\n---------\n"
1596 if $debug;
1597 return @add;
1598}
1599
1600
# spent 1.18ms (747µs+435µs) within WISE::Params::paramparselines which was called 2 times, avg 591µs/call: # 2 times (747µs+435µs) by WISE::Params::paramsfromfile at line 1584, avg 591µs/call
sub paramparselines {
16014510.000861.9e-6 my($infile,$in,$conditions) = @_;
1602 my($i,@in,$par,$val,@lines,%env,%cond);
1603 local $_;
1604
1605 if($conditions) {
1606 $cond{lc $_} = $conditions->{$_} for keys %$conditions;
1607 }
1608
1609 # Pre-filter to join continuation lines
1610 CONT: for (@$in) {
1611 chomp;
1612 if(/^\s+\S/) { # Continuation line
1613 if(defined $in[-1]) {
1614 s/^\s*//;
1615 $in[-1] =~ s/\s*$//;
1616 $in[-1] .= " ".$_;
1617 next CONT;
1618 } else {
1619 die "$err: Bad format reading from '$infile': ".
1620 "line continues from nowhere:\n$_\n";
1621 }
1622 }
1623 push @in,$_;
1624 }
1625
1626 LINE: for (@in) {
1627 if (($i=paruqindex($_,'#'))>=0) { # Comments
# spent 435µs making 53 calls to WISE::Params::paruqindex, avg 8µs/call
1628 my $cmnt = substr($_,$i+1);
1629 substr($_,$i) = ""; # Remove comment for subsequent processing
1630 my ($envtxt) = $cmnt =~ /(\{[^}]*\})/;
1631 if($envtxt) {
1632 my $env = par_safe_eval("$envtxt");
1633 die "$err: Error parsing configuration environment ".
1634 "'$env'.\n$@"
1635 if $@;
1636 %env = (%env,%$env);
1637 }
1638 }
1639 if(/^\s*$/) { next LINE; } # Blank line
1640 # Check conditions
1641 if(%cond && %env) {
1642 for my $k (keys %env) {
1643 #print "\t$k ...\n";
1644 next if ! defined $env{$k};
1645 next if ! defined $cond{lc $k};
1646 if(! ref $cond{lc $k}) {
1647 next LINE if lc($env{$k}) ne lc($cond{lc $k});
1648 } else {
1649 # Given value is an array ref.
1650 my @vals = grep { defined $_ && length $_ } @{$cond{lc $k}};
1651 next if ! @vals;
1652 my @env;
1653 # The environment to check against may also be an array
1654 if(ref $env{$k}) { @env = @{$env{$k}}; }
1655 else { @env = ($env{$k}); }
1656 my $mchs = 0;
1657 for my $env (@env) {
1658 # A match to *any* array element is acceptable
1659 ++$mchs if grep( defined $_ && lc($env) eq lc($_),
1660 @vals );
1661 }
1662 next LINE if ! $mchs;
1663 }
1664 }
1665 }
1666 ($par,$val) = m/^(-\S+)(?:\s+(\S.*))?$/;
1667 push @lines,$par;
1668 push @lines,$val if defined $val;
1669 }
1670
1671 return @lines;
1672}
1673
1674
1675sub paramsfromtty {
1676 my $IN = shift;
1677 my $ctxt = shift || die "$err/tty: No defs.\n";
1678 my ($ans,$nm,@in,$r,$def,$onoff,$val);
1679 my $iam = $ctxt->{_meta}{iam};
1680
1681 select +(select($IN), $|=1)[0];
1682
1683 print "\nEnter options for $iam:\n";
1684 OUTER: while(1) {
1685 print "\nOption name ('?[12] [param]' for options, 'run' to run)? ";
1686 $ans = <$IN>;
1687 if(! defined $ans) { last OUTER; }
1688 chomp $ans; $ans = lc $ans;
1689 $ans =~ s/^\s*(.*?)\s*$/$1/;
1690 if($ans =~ /^$/) { next OUTER; }
1691 if($ans =~ /^run|exit|quit|go$/i) { last; }
1692 if($ans !~ /^-/) { print "'$ans' needs leading '-'.\n"; next OUTER; }
1693 $ans =~ s/^-//;
1694 if($ans =~ /^(?:\?|help)(\d)?(?:\s+?(-?\w+(?:,-?\w+)*))?$/i) {
1695 &paramhelp($1||0,1,$2); next OUTER; }
1696 $nm = $ctxt->{_meta}{aliases}{$ans};
1697 if(! $nm) { print "'$ans' not recognized.\n"; next OUTER; }
1698 $r = $ctxt->{$nm};
1699 if($r->{type} eq 'switch') {
1700 print "Switch $nm set.\n";
1701 push @in,"-$nm\n";
1702 next OUTER;
1703 }
1704 $val = $ctxt->{$nm}{val};
1705 $def = sprintf("%-s (%-s %-s)",$nm,
1706 ($r->{list} ? $r->{list}." " : "").$r->{type},
1707 (defined $val && (! ref($val) || @$val)
1708 ? "= ".(! ref($val) ? $val : join(",",@$val))
1709 : "")
1710 );
1711 INNER: {
1712 print "Enter new value for $def: ";
1713 $ans = <$IN>;
1714 if (! defined $ans) { next OUTER; }
1715 chomp $ans; $ans =~ s/^\s*(.*?)\s*$/$1/;
1716 if ($ans =~ /^$/) { next OUTER; }
1717 if(! defined &paramchecklist($nm,$ans,$ctxt)) {
1718 print "Illegal value for this type. Redo.\n";
1719 redo INNER;
1720 }
1721 print "Setting $nm to value '$ans'.\n";
1722 push @in,"-$nm\t$ans\n";
1723 }
1724 }
1725
1726 return @in;
1727}
1728
1729
1730
# spent 6.39ms (1.81+4.58) within WISE::Params::paramchecklist which was called 76 times, avg 84µs/call: # 76 times (1.81ms+4.58ms) by WISE::Params::Param_parse at line 883, avg 84µs/call
sub paramchecklist {
173112030.001811.5e-6 my($parname,$val) = (shift,shift);
1732 my $ctxt = shift || die "$err/checklist: No defs.\n";
1733 my $opts = shift || {};
1734 my(@ary,$ary,@out,$perlish);
1735
1736 my $debug = $ctxt->{_meta}{debug} =~ /chk/;
1737 print "\t\t\t\tPARAMS paramchecklist: $parname=/$val/, ".
1738 "list='$ctxt->{$parname}{list}'\n"
1739 if $debug;
1740
1741 if($ctxt->{$parname}{list}) {
1742 ($ary,$perlish) = &paramlist($parname,$val,$ctxt);
# spent 717µs making 11 calls to WISE::Params::paramlist, avg 65µs/call
1743 if($debug) {
1744 eval "use WISE::Dumper; 1;"
1745 or die "$err: Can't load WISE::Dumper.\n$@";
1746 print "\t\t\t\tPARAMS paramchecklist: ary=$ary\n";
1747 print Dumper($ary);
1748 }
1749 return undef if ! defined $ary;
1750 @ary = @$ary;
1751 } else {
1752 @ary = ($val);
1753 }
1754
1755 if($perlish) {
1756 # As a special case, if the parameter starts with [ or { and
1757 # ends with a matching bracket, parse it as Perl.
1758 $ctxt->{$parname}{perlish} = $perlish;
1759 @out = @ary;
1760 } else {
1761 # Normal param parsing rules
1762 if($ctxt->{$parname}{itype} == 8) {
1763 # If it's supposed to be a hash, try to parse it accordingly
1764 if(grep(/->|=>?/,@ary) != @ary) {
1765 warn "$err: Map parameter $parname value doesn't ".
1766 "look like a mapping\n";
1767 return undef;
1768 }
1769 return paramlist2hash($parname,\@ary,$ctxt);
# spent 2.39ms making 3 calls to WISE::Params::paramlist2hash, avg 798µs/call
1770 }
1771 for $val (@ary) {
1772 $val = &paramcheck($parname,$val,$ctxt,$opts);
# spent 1.47ms making 86 calls to WISE::Params::paramcheck, avg 17µs/call
1773 return undef if ! defined $val;
1774 push @out,($val ne 'undef'? $val : undef);
1775 }
1776 }
1777
1778 return \@out;
1779}
1780
1781
# spent 1.88ms (1.13+751µs) within WISE::Params::paramlist which was called 24 times, avg 78µs/call: # 13 times (542µs+619µs) by WISE::Params::paramlist2hash at line 1876, avg 89µs/call # 11 times (585µs+132µs) by WISE::Params::paramchecklist at line 1742, avg 65µs/call
sub paramlist {
17824690.001202.6e-6 my $parname = shift;
1783 my $val = shift;
1784 my $ctxt = shift || die "$err/paramlist: No defs.\n";
1785 my ($i,@ary,$tmp,$perlish);
1786 my $quoted = "\000";
1787 my $sep = "\001";
1788 local $_;
1789
1790 if($val eq 'undef') { return []; }
1791 $ctxt = undef if ! $parname; # Special case; assume string processing
1792 # Blank-out quoted/escaped parts of the string using NULL as a replacement
1793 $tmp = parblankquoted($val,$quoted);
# spent 130µs making 24 calls to WISE::Params::parblankquoted, avg 5µs/call
1794 if($perlok && ($tmp =~ /^\s*\{.*\}\s*$/ || $tmp =~ /^\s*\[.*\]\s*$/)) {
1795 # As a special case, if the parameter starts with [ or { and
1796 # ends with a matching bracket, parse it as Perl.
1797 my $parsed;
1798 {
1799 local $^W = 0; # Suppress warnings to aid compactness
1800 $parsed = par_safe_eval($val);
1801 }
1802 if($@) {
1803 warn "$err: Unable to parse Perl-ish value '$val':\n$@";
1804 return;
1805 }
1806 if(! $parsed || ref($parsed) !~ /array|hash/i) {
1807 warn "$err: Non-array-like result from parsing of ".
1808 "Perl-ish value '$val' = $parsed .";
1809 return;
1810 }
1811 @ary = ref($parsed) =~ /array/i ? @$parsed : %$parsed;
1812 $perlish = 1;
1813 } else {
1814 # Parse normally
1815 # Replace active (unescaped) commas with binary 1's
1816 if(! $ctxt || $ctxt->{$parname}{itype} != 8) {
1817 # Normal list. Split on commas.
1818 $tmp =~ s/,/$sep/g;
1819 } else {
1820 # Mapping. Split on a ',.*=' pattern (more or less)
1821 $tmp =~ s/,(?=\s*[-\w\d_@#$%&:.!]+\s*(?:->|=>?))/$sep/g;
1822 }
1823 # Replace the NULLs in $tmp with the original characters
1824 $i=0;
1825 while($tmp=~m|$quoted+|) {
1826 substr($tmp, $-[0], $+[0]-$-[0]) = substr($val, $-[0], $+[0]-$-[0]);
1827 }
1828 # Split on the embedded binary 1's
1829 @ary = split(/$sep/,$tmp);
1830 # Handle lists of integers and strings allowing for range operations
1831 # Remove bracketing parens
1832 if(@ary && defined $ary[0] && defined $ary[-1] &&
# spent 137µs making 24 calls to WISE::Params::parblankquoted, avg 6µs/call
1833 parblankquoted($ary[0], 'X') =~ /^\s*\(/ &&
1834 parblankquoted($ary[-1],'X') =~ /\)\s*$/) {
1835 $ary[0] =~ s/^\s*\(//;
1836 $ary[-1] =~ s/\)\s*$//;
1837 }
1838 if (! $ctxt || $ctxt->{$parname}{type} eq 'char') {
1839 if(grep(/^[0-9a-zA-Z]..[0-9a-zA-Z]$/,@ary)) {
# spent 484µs making 5 calls to WISE::Params::parexpandlist, avg 97µs/call
1840 @ary = &parexpandlist(\@ary,1,1);
1841 }
1842 } elsif($ctxt->{$parname}{type} =~ /u?integer/) {
1843 if($val =~ /^\(?([-+\d\s,]|\.\.+)+\)?$/) {
1844 @ary = &parexpandlist(\@ary,1,1);
1845 } elsif ($val =~ /\.\./) { # Range operator is malformed; error
1846 my $bad;
1847 ($bad = $val) =~ s/[-+\d\s,()]|\.\.+//g;
1848 $bad = join('',sort split("",$bad));
1849 $bad =~ s/(.)\1+/$1/g;
1850 warn "$err: Expandable list '$val' has illegal char.s: ".
1851 "'$bad'\n";
1852 return undef;
1853 }
1854 }
1855 }
1856
1857 return wantarray ? (\@ary,$perlish) : \@ary;
1858}
1859
1860
# spent 2.39ms (839µs+1.55) within WISE::Params::paramlist2hash which was called 3 times, avg 798µs/call: # 3 times (839µs+1.55ms) by WISE::Params::paramchecklist at line 1769, avg 798µs/call
sub paramlist2hash {
18612520.000963.8e-6 my $parname = shift;
1862 my $list = shift;
1863 my $ctxt = shift || die "$err/list2hash: No defs.\n";
1864 my @newlist;
1865
1866 for (@$list) {
1867 if(! /^\s*(\S+)\s*(?:->|=>?)\s*(\S.*?)\s*$/) {
1868 warn "$err: Hashizing list failed on item '$_'\n";
1869 return;
1870 }
1871 my ($k,$v) = ($1,$2);
1872 # Check for embedded, unquoted/unescaped, non-terminal commas.
1873 # The non-terminal requirement avoids interpreting 'x=y,' as a
1874 # single-element array
1875 my $commaix;
1876 if(($commaix = paruqindex($v,",")) >= 0 &&
# spent 1.16ms making 13 calls to WISE::Params::paramlist, avg 89µs/call # spent 393µs making 33 calls to WISE::Params::paruqindex, avg 12µs/call
1877 $commaix < length($v)-1) {
1878 # There're embedded commas, so make a list of it
1879 $v=paramlist('',$v,$ctxt); # (Null parname => handle as str list)
1880 }
1881 defined $_ and $_ eq 'undef' and $_ = undef for (ref($v) ? (@$v) : ($v));
1882 push @newlist,$k,$v;
1883 }
1884
1885 my %ashash = @newlist;
1886
1887 return \%ashash;
1888}
1889
1890
# spent 1.47ms within WISE::Params::paramcheck which was called 86 times, avg 17µs/call: # 86 times (1.47ms+0) by WISE::Params::paramchecklist at line 1772, avg 17µs/call
sub paramcheck {
189110350.001271.2e-6 my ($parname,$val) = (shift,shift);
1892 my $ctxt = shift || die "$err/paramcheck: No defs.\n";
1893 my $opts = shift || {};
1894
1895 # No need to type check switches if no val is attached
1896 if($ctxt->{$parname}{type} eq 'switch' &&
1897 ! defined $val) { return 1; }
1898
1899 if(defined $val && $val eq 'undef') { return $val; }
1900
1901 if(! defined $val) { return undef; }
1902
1903 my $numeric;
1904 my $string;
1905 if($ctxt->{$parname}{type} =~ /integer/) { # int
1906 if($val =~ /^\s*[-+]?\d+\s*$/) { # decimal
1907 $val = $val + 0;
1908 } elsif($val =~ /^\s*0[xX][0-9a-fA-F]+\s*$/ || # hex
1909 $val =~ /^\s*0[oO][0-7]+\s*$/) { # octal
1910 $val =~ s/[oO]//;
1911 $val = oct($val);
1912 } elsif($val =~ /^\s*0[bB][01]+\s*$/) { # binary
1913 $val =~ s/0[bB]([01]+)/0 x (32-length($1)).$1/e;
1914 $val = unpack("N",pack("B*",$val));
1915 } else {
1916 warn "$err: Integer parameter '$parname' ".
1917 "has illegal value '$val'.\n";
1918 return undef;
1919 }
1920 $numeric = 1;
1921 } elsif($ctxt->{$parname}{type} eq 'real' ||
1922 $ctxt->{$parname}{type} eq 'double') { # real
1923 if($val !~ /$FPre/) {
1924 warn "$err: Real parameter '$parname' ".
1925 "has illegal value '$val'.\n";
1926 return undef;
1927 }
1928 {
1929 local $^W = 0;
1930 $val = $val + 0.0;
1931 }
1932 $numeric = 1;
1933 } elsif($ctxt->{$parname}{type} eq 'boolean' or
1934 $ctxt->{$parname}{type} eq 'switch') { # bools
1935 if(! defined $bools{$val}) {
1936 warn "$err: Boolean parameter '$parname' ".
1937 "has illegal value '$val'.\n";
1938 return undef;
1939 }
1940 $val = $bools{$val};
1941 } elsif($ctxt->{$parname}{type} eq 'file') { # file/dir name
1942 $val =~ s%/+$%%; # No trailing slashies
1943 $val =~ s%/+%/%; # No doubled slashies
1944 } elsif($ctxt->{$parname}{type} eq 'string' ||
1945 $ctxt->{$parname}{type} eq 'char') { # string
1946 # nothing to do
1947 $string = 1;
1948 } elsif($ctxt->{$parname}{type} eq 'name') {
1949 # nothing to do
1950 }
1951 # we're done! $val contains the string.
1952
1953 # Optionally check numeric ranges and string lengths
1954 if(($numeric || $string) && defined $ctxt->{$parname}{minval}) {
1955 my $min = $ctxt->{$parname}{minval};
1956 my $max = $ctxt->{$parname}{maxval};
1957 my $testval = $val;
1958 $testval = length($val//'') if $string;
1959 if(($min !~ /-inf/ && $testval < $min) ||
1960 ($max !~ /inf/ && $testval > $max)) {
1961 warn "$err: Numeric parameter '$parname' value '$val' ".
1962 "is outside specified range $min..$max .\n";
1963 return undef;
1964 }
1965 }
1966
1967 return $val;
1968
1969}
1970
1971
# spent 3.88ms (2.47+1.41) within WISE::Params::check_pragmas which was called # once (2.47ms+1.41ms) by WISE::Params::Params at line 264
sub check_pragmas {
19723650.002567.0e-6 my $ctxt = shift;
1973 my $opts = shift || {};
1974
1975 for my $parname (@{$ctxt->{_meta}{parnames}}) {
1976 next if $ctxt->{$parname}{type} !~ /file/i;
1977 next if ! defined $ctxt->{$parname}{val};
1978 # Get value(s)
1979 my @vals = ($ctxt->{$parname}{list}
1980 ? @{$ctxt->{$parname}{val}}
1981 : $ctxt->{$parname}{val}
1982 );
1983
1984 # Clean up
1985 for my $val (@vals) {
1986 $val =~ s|//+|/|g;
1987 }
1988
1989 my @pragmas = @{$ctxt->{$parname}{file_pragmas} || []};
1990
1991 if(@pragmas) {
1992 # Expand embedded globs for list params
1993 if(grep(lc($_) eq 'glob', @pragmas) && $ctxt->{$parname}{list}) {
1994 my @expanded;
1995 for my $val (@vals) {
1996 # The eval is so File::Glob won't be loaded until needed
199730.010150.00338 my @new = glob($val);
1998 push @expanded,@new;
1999 }
2000 @vals = @expanded;
2001 }
2002 if(grep(lc($_) eq 'resolve', @pragmas)) {
2003 # Won't work right if -run_dir is set and the user
2004 # is doing this through Env.pm
2005 require WISE::UtilsLight;
2006 for my $val (@vals) {
2007 if(! $ctxt->{run_dir} || ! $ctxt->{run_dir}{val} ||
2008 $val =~ m|^/|) {
2009 $val = WISE::UtilsLight::normalizepath(
2010 $val,
2011 {resolve=>1,notrail=>1}
2012 );
2013 }
2014 }
2015 }
2016 # Check to see if the file is present (if not tags extant)
2017 if(grep {lc($_) eq 'in'} @pragmas) {
2018 for my $val (@vals) {
2019 if($val && $val !~ /%[^%]+%/ &&
2020 ! -e $val && ! -e "$val.gz") {
2021 die "$err: File parameter '$parname' value '$val' ".
2022 "does not exist but is tagged as input.\n";
2023 }
2024 }
2025 }
2026 } # if @pragmas
2027
2028 # Write back new value
2029 my $val = ($ctxt->{$parname}{list}
2030 ? \@vals
2031 : $vals[0]
2032 );
2033 Param_reassign($parname,$val,{%$opts,asgiven=>1,defs=>$ctxt});
# spent 1.41ms making 33 calls to WISE::Params::Param_reassign, avg 43µs/call
2034
2035 } # for parnames
2036}
2037
2038
# spent 198µs within WISE::Params::check_required which was called # once (198µs+0) by WISE::Params::Params at line 259
sub check_required {
20391770.000181.0e-6 my $ctxt = shift || die "$err/checkreq: No defs.\n";
2040 my $opts = shift || {};
2041 my $debug = $ctxt->{_meta}{debug} || 0;
2042 local $_;
2043
2044 for my $parname (@{$ctxt->{_meta}{parnames}}) {
2045 print "\t\t\tPARAM: $parname required = ".
2046 "/".($ctxt->{$parname}{required}//'undef')."/\n"
2047 if $debug;
2048 if($ctxt->{$parname}{need}) {
2049 die "$err: Parameter '$ctxt->{$parname}{name}' ".
2050 "required value not given.\n"
2051 }
2052 }
2053}
2054
2055
# spent 1.64ms within WISE::Params::typeoftype which was called 86 times, avg 19µs/call: # 86 times (1.64ms+0) by WISE::Params::parsedefs at line 551, avg 19µs/call
sub typeoftype {
20567810.001381.8e-6 my $type = shift;
2057 my ($size,$mapkeys,$itype,$otype);
2058 local $_;
2059
2060 $_ = $otype = $type;
2061 if (/^i(?:nt(?:eger)?)?/ix) { $type = "integer"; $itype = 1;}
2062 elsif(/^r(?:eal)? | float$/ix) { $type = "real"; $itype = 2; }
2063 elsif(/^d(?:oub(?:le)?)? | dbl$/ix) { $type = "double"; $itype = 2; }
2064 elsif(/^b(?:ool(?:ean)?)?$/ix) { $type = "boolean"; $itype = 4; }
2065 elsif(/^sw(?:itch)?$/ix) { $type = "switch"; $itype = 5; }
2066 elsif(/^s(?:tr(?:ing)?)?(?:\[(\d+)\])?$/ix)
2067 { $type = "string"; $itype = 6;
2068 $size = $1||undef; }
2069 elsif(/^c(?:h(?:ar(?:acter)?)?)?(?:\[(\d+)\])?$/ix)
2070 { $type = "char"; $itype = 6;
2071 $size = $1||undef; }
2072 elsif(/^f(?:ile)?(?:\[(\d+)\])?$/ix)
2073 { $type = "file"; $itype = 7;
2074 $size = $1||undef; }
2075 elsif(/^(n(?:ame[sd]?)?|map(?:ping)?|hash)\s*(?:\((.*?)\))?$/ix) {
2076 my $tp = $1;
2077 my $names = $2;
2078 if(defined $names) {
2079 $mapkeys = [];
2080 @$mapkeys = split(/\s*,+\s*/,$names);
2081 } else {
2082 $mapkeys = undef;
2083 }
2084 $itype = $tp =~ /name/i ? 9 : 8;
2085 $type = $tp =~ /name/i ? 'name' : 'map';
2086 }
2087 else { $type = ""; $itype = 0; }
2088
2089 return wantarray ? ($type,$itype,$size,$mapkeys,$otype) : $type;
2090
2091}
2092
2093# Utility function to resolve -steps and -step_macros params to a hash
2094
2095
# spent 707µs (603+104) within WISE::Params::steps_resolve which was called # once (603µs+104µs) at line 305 of /wise/base/deliv/dev/bin/getfix
sub steps_resolve {
20962790.000612.2e-6 my $steps = shift;
2097 my $macros = shift || {};
2098 my $opts = shift || {};
2099 my $iam = $opts->{iam} || parwhoiam();
# spent 104µs making 1 call to WISE::Params::parwhoiam
2100 my $err = "*** $iam/STEPS";
2101 my @steps = @{$steps
2102 ? (ref($steps)
2103 ? (ref($steps)=~/hash/i ? [keys %$steps] : $steps)
2104 : [$steps])
2105 : [] };
2106
2107 my %do;
2108
2109 my %all = (map { (lc($_)=>1) } grep {! /^[-+]?@/} map { (ref($_)?@$_:$_) }
2110 values %$macros);
2111
2112 my @order;
2113
2114 # Examine each job step specification
2115 for my $step_spec (@steps) {
2116 my ($addsub,$step) = $step_spec =~ /^([-+]?)(\S+)$/;
2117 die "$err: Job step spec '$step_spec' not recognized.\n"
2118 if ! $step;
2119 $addsub ||= "";
2120 my @sub_steps = (lc $step);
2121 my $loop = 0;
2122 # Iteratively expand macros
2123 while(grep {/\@/} @sub_steps) {
2124 die "$err: Possible loop in job step resolution.\n"
2125 if ++$loop > 100;
2126 for my $i (grep { $sub_steps[$_]=~/^[-+]?\@/ } 0..$#sub_steps) {
2127 my ($macro_addsub,$macro) = $sub_steps[$i] =~ /^([-+]?)(\S+)$/;
2128 $macro_addsub ||= "";
2129 $macro = lc $macro;
2130 die "$err: Unknown macro '$macro'.\n"
2131 if ! $macros->{$macro};
2132 splice @sub_steps,$i,1,(map {s/^--//; s/^(-\+|\+-)/-/;
2133 $_; }
2134 map {$macro_addsub.lc($_)}
2135 (ref($macros->{$macro})
2136 ? @{$macros->{$macro}}
2137 : $macros->{$macro}) );
2138 last;
2139 }
2140 }
2141 for my $sub_step_spec (@sub_steps) {
2142 my ($sub_addsub,$sub_step) = $sub_step_spec =~ /^([-+]?)(\S+)$/;
2143 die "$err: Job step '$sub_step' not recognized.\n"
2144 if %all && ! $all{$sub_step};
2145 $sub_addsub ||= "";
2146 my $combined_addsub = $addsub.$sub_addsub;
2147 s/^--//, s/^(-\+|\+-)/-/ for $combined_addsub;
2148 if($combined_addsub eq '-') {
2149 delete $do{$sub_step} if $do{$sub_step};
2150 } else {
2151 $do{$sub_step} = 1;
2152 push @order, $sub_step;
2153 }
2154 }
2155 }
2156
2157 # Restore order
2158 my %seen;
2159 my @do = (map { ($_=>$do{$_}) }
2160 grep { ! $seen{$_}++ }
2161 grep { $do{$_} }
2162 @order);
2163
2164 return wantarray ? @do : \%do;
2165}
2166
2167# Produce help output or a help string.
2168#
2169# If $param is a comma separated list of valid param names or aliases,
2170# o/p help for only those param.s. Otherwise, dump all help.
2171# If $opts->{current} is set, give current values instead of using defaults.
2172#
2173# This code is a mess, mainly because POD output was shoehorned in. It badly
2174# needs a rewrite. The pod2html generator is fairly picky in the sort of POD
2175# written out if a standard-looking manpage-type page is to result. That's
2176# why there's alot of funny stuff. Be careful to test the results of
2177# xxx -help2 | perl -MWISE -e '$p=WISE::Pars->new([<STDIN>],{parseonly=>1});'
2178# -e '$p->help("pod")' \
2179# | pod2html > xxx.html
2180# pretty carefully as well as the results of just 'xxx -help' and 'xxx -help2'.
2181sub Param_help {
2182 my ($help,$opts,$param) = (shift||0,shift,shift);
2183 my ($ctxt,%param,$curr,$op,$fileh,$opt,$pod,$iam,$synop,$descrip);
2184 my $max_spec = defined $opts->{maxspec} ? $opts->{maxspec} : 75;
2185 my $debug;
2186 my $line = "";
2187
2188 $help =~ s/^_|_$//g;
2189 $help = {brief=>0,long=>1,full=>2,pod=>3}->{$help} if $help !~ /^\d$/;
2190 $help ||= 0;
2191 $help = 0 if $help < 0 || $help > 3;
2192
2193 if(! ref $opts) { $opts = { current=>$opts }; }
2194 $curr = $opts->{current};
2195 $op = ! $opts->{noop};
2196 $fileh = $opts->{fileh} || \*STDOUT;
2197 $param ||= $opts->{param};
2198 $pod = $opts->{pod} || ($help==3); # Print out help in pod format
2199 $help = $pod ? 3 : $help;
2200 $ctxt = $opts->{defs} || die "$err/help: No defs.\n";
2201 $debug = $opts->{debug} || $ctxt->{_meta}{debug};
2202
2203 print "\t\t\tPARAM: Help ctxt = $ctxt\n" if $debug;
2204
2205 my $lead = $pod ? "" : "# ";
2206 # =over and =back must be matched (paired) throughout.
2207 my $over = $pod ? "\n=over 4\n\n" : "";
2208 my $back = $pod ? "\n=back\n\n" : "";
2209 my $item = $pod ? "\n=item " : "";
2210 my $para = $pod ? "\n" : "";
2211 my $indent = $pod ? " " : "";
2212 my $sep = $pod ? "- " : "";
2213
2214 if(! defined $param || $param eq "") {
2215 # All parameters being printed. Check for synopsis and description
2216 my $genhelp = $ctxt->{_meta}{help} || [];
2217 if(@{$genhelp} || $pod) {
2218 # (If pod-izing, we always need to have a name - synopsis,
2219 # whether there is one or not)
2220 # A one line synopsis
2221 $synop = "$lead".(@{$genhelp}?$genhelp->[0]:"(Missing-synopsis)");
2222 $descrip= ($help > 1 && @{$genhelp} > 1
2223 ? "$lead$indent".join("\n$lead$indent",
2224 @{$genhelp}[1..$#$genhelp]).
2225 "\n"
2226 : ""
2227 );
2228 ($iam = $ctxt->{_meta}{iam}||"(Missing-name)")
2229 =~ s/(\s+|::).*//;
2230 $iam =~ s/perl-e/(Missing-name)/;
2231 # Pod::Html is picky; it looks for
2232 # /^=head1\s*NAME\b(\n\n)?(\S+\s+-+.*\S)/m
2233 # I.e. more or less "=head1 NAME something - something"
2234 $line .= ($pod?"=head1 NAME $iam\n\n$indent$iam $sep ".
2235 "$synop\n\n$over$back"
2236 :"${lead}Command => $iam\n\n$synop\n").
2237 ($pod?"=head1 DESCRIPTION\n\n":"").
2238 "$over$descrip$back\n";
2239 } else {
2240 $line .= "\n";
2241 }
2242 $param = undef;
2243 } else { # $param is defined and specifies which parameters need help
2244 for (split /,/,$param) {
2245 s/^\s*-?(\w+)\s*$/$1/;
2246 my $full = $ctxt->{_meta}{aliases}{$_};
2247 if(! defined $full) {
2248 warn "$err: Parameter '$_' not defined.\n";
2249 return undef;
2250 }
2251 $param{$full} = 1;
2252 }
2253 $param = \%param;
2254 }
2255
2256 $line .= "=head1 ARGUMENTS\n\n$over$back"
2257 if $pod && @{$ctxt->{_meta}{parnames}};
2258
2259 # Precompute some values so we can check for max. lengths
2260 my (%aliases,%specs);
2261 my ($alias_len,$spec_len) = (24,16);
2262 if(! $pod) {
2263 for (@{$ctxt->{_meta}{parnames}}) {
2264 next if defined $param && ! defined $param->{$_};
2265 my $r = $ctxt->{$_};
2266 my $mapkeys = $r->{mapkeys};
2267 $mapkeys = $mapkeys && @$mapkeys
2268 ? " (".join(",",@$mapkeys).")"
2269 : "";
2270 my $list = $r->{list} ? "list of " : "";
2271 my $nlist = (defined $r->{minlist}
2272 ? ("$r->{minlist}".(defined $r->{maxlist}
2273 ? " to $r->{maxlist}"
2274 : "")
2275 )." "
2276 : ""
2277 );
2278 my $range = (defined $r->{minval}
2279 ? " ($r->{minval} to $r->{maxval})"
2280 : "");
2281 my $fpragmas = ($r->{type} eq 'file' && $r->{file_pragmas} &&
2282 @{$r->{file_pragmas}}
2283 ? "(".join(",",@{$r->{file_pragmas}}).")"
2284 : "");
2285 my $private = $r->{private}
2286 ? $r->{private} eq "1"
2287 ? " private"
2288 : " private($r->{private})"
2289 : "";
2290 my $quiet = $r->{quiet}
2291 ? $r->{quiet} eq "1"
2292 ? " quiet"
2293 : " quiet($r->{quiet})"
2294 : "";
2295 $aliases{$_} = join(",",@{$r->{aliasesorig}});
2296 $specs{$_} = $list.$nlist.$r->{type}.$fpragmas.$mapkeys.$range.
2297 $private.$quiet;
2298 if(! $max_spec || length($aliases{$_}.$specs{$_}) <= $max_spec) {
2299 if(length($aliases{$_}) > $alias_len) {
2300 $alias_len = length($aliases{$_});
2301 }
2302 if(length($specs{$_}) > $spec_len) {
2303 $spec_len = length($specs{$_});
2304 }
2305 }
2306 }
2307 }
2308
2309 for (@{$ctxt->{_meta}{parnames}}) {
2310 next if defined $param && ! defined $param->{$_};
2311 my $r = $ctxt->{$_};
2312 next if $r->{quiet} && $help < 2;
2313 my $val = $r->{val};
2314 print "\t\t\tPARAM: Data for $_ = ".
2315 "/$r->{type}/$val/$r->{required}/\n" if $debug;
2316 my @val = ref($val) eq "ARRAY" ? @$val
2317 : ref($val) eq "HASH" ? %$val : ();
2318 my ($op,$cl,$asep) = $r->{hash} ? ("(",")",",") : ("(",")",",");
2319 if($r->{hash}) {
2320 my @tmp = @val;
2321 @val = ();
2322 while(@tmp) {
2323 my $k = shift(@tmp);
2324 my $v = shift(@tmp);
2325 $v //= 'undef';
2326 push @val,"$k=$v";
2327 }
2328 }
2329 my $def;
2330 if($curr) {
2331 # Use a value currently defined rather than just the default
2332 $def = ! defined $val ? "undef"
2333 : ! ref($val) ? $val
2334 : ! @val ? "$op$cl"
2335 : $op.join($asep,map {defined$_?$_:'undef'} @val).$cl;
2336 } else {
2337 $def .= $r->{required} ? "\$required " : "";
2338 $def .= $r->{unnamed} ? "\$unnamed " : "";
2339 $def .= $r->{intdefault} ? "\$default " : "";
2340 $def .= defined $r->{default} &&
2341 $r->{type} ne 'switch' ? valstr($ctxt,$_,1) : "";
2342 }
2343 $def = defined $def && $def ne "" ? ($pod?$def:"= $def") : "";
2344
2345 my $line2 = "";
2346 my $perhelp = $r->{help} || [];
2347
2348 if(! $pod) {
2349 $line2 .= sprintf("%-${alias_len}s: %-${spec_len}s %-s ",
2350 $aliases{$_}, $specs{$_}, $def);
2351 $line2 =~ s/\s*$//;
2352 } else {
2353 # Is there a better way to get vertical space?
2354 $line2 .= "=for html <br><br>\n <p></p>\n\n";
2355 $line2 .= "$over$item\nE<12>\n\n$back";
2356 # Argument header. See comment below.
2357 $line2 .= "\n\n=head2 Parameter $r->{aliasesorig}[0] ";
2358 }
2359
2360 if($help>0) {
2361 $line2 .= " " x (61-length($line2))." $lead".$perhelp->[0]
2362 if $help==1 && @$perhelp;
2363 if($pod) {
2364 # As for the NAME field, to be indexed properly the
2365 # =head2 (begun above) needs to look like
2366 # '=head2 something - something".
2367 $line2 .= "$sep ".(@$perhelp?$perhelp->[0]
2368 :"(Missing-description")."\n\n";
2369 $line2 .= "$over";
2370 $line2 .= "${lead}${item}B<Aliases>S< >- ".
2371 ($#{$r->{aliasesorig}} > 0 ?
2372 join(",",
2373 @{$r->{aliasesorig}}[1..$#{$r->{aliasesorig}}])
2374 : "none").
2375 "\n\n";
2376 $line2 .= "${lead}${item}B<Type>S< > - ".
2377 ($r->{list}||"").$r->{type}.
2378 "\n\n";
2379 $line2 .= "${lead}${item}B<Default>S< >- $def\n\n"
2380 if defined $def;
2381 $line2 .= "$back";
2382 }
2383 if(@$perhelp) {
2384 # Is there a better way to get vertical space?
2385 $line2 .= "$over$item\nE<12>\n\n$back" if $pod;
2386 $line2 .= "\n$lead$indent".
2387 join("\n$lead$indent",
2388 @{$perhelp}[($pod?1:0)..$#$perhelp])."\n"
2389 if $help>1;
2390 }
2391 } elsif($pod) {
2392 $line2 .= "\n\n$over$back";
2393 }
2394
2395 $line .= "$line2\n";
2396
2397 }
2398
2399 if($op) {
2400 my $save = select $fileh;
2401 $| = 1;
2402 print $fileh $line;
2403 select $save;
2404 }
2405
2406 return $line;
2407}
2408
2409
# spent 5.93ms (5.75+186µs) within WISE::Params::expand_tags which was called # once (5.75ms+186µs) by WISE::Params::Params at line 254
sub expand_tags {
241044820.005811.3e-6 my $ctxt = shift;
2411 my $opts = shift || {};
2412 my %notags =
2413 $opts->{notags} && ref $opts->{notags} ? %{$opts->{notags}} : ();
2414 my %tags =
2415 $opts->{tags} && ref $opts->{tags} ? %{$opts->{tags}} : ();
2416 my %tag_params =
2417 $opts->{tag_params} && ref $opts->{tag_params}
2418 ? %{$opts->{tag_params}} : ();
2419 my $debug = $ctxt->{_meta}{debug} || $opts->{debug};
2420 my $found;
2421 my %expanded;
2422 my %where;
2423 local $_;
2424
2425 while(! defined $found || $found) {
2426 $found = 0;
2427 for my $param (@{$ctxt->{_meta}{parnames}}) {
2428 next if %tag_params && ! $tag_params{$param};
2429 next if ! $ctxt->{$param}{val};
2430 next if $ctxt->{$param}{hash};
2431 my @origvals = ($ctxt->{$param}{list}
2432 ? @{$ctxt->{$param}{val}}
2433 : $ctxt->{$param}{val});
2434 print "--- |$param|@origvals|\n" if $debug;
2435 next if ! grep {/%/} @origvals;
2436 next if ! grep {/%[^%]+%/} @origvals;
2437 my $i = $ctxt->{$param}{list} ? 0 : undef;
2438 for my $origval (@origvals) {
2439 next if $origval !~ /%[^%]+%/; # No more
2440 print "--- |$param|".($i//"undef")."|$origval|$found|\n"
2441 if $debug;
2442 while($origval =~ /%([^%]+)%/g) {
2443 # Expand to full param name, if an alias of any param
2444 my $origtag = $1;
2445 my @args;
2446 my $tag = $origtag;
2447 if($tag =~ s/\((.*)\)$//) { # Strip off and save arg.s
2448 @args = split(/,/,$1);
2449 }
2450 # Look for tag alias
2451 $tag = ($ctxt->{_meta}{tag_aliases} &&
2452 $ctxt->{_meta}{tag_aliases}{lc $tag})
2453 // $tag;
2454 # Expand to full param name
2455 if($ctxt->{_meta}{aliases}{lc $tag}) {
2456 $tag = $ctxt->{_meta}{aliases}{lc $tag};
2457 } elsif(defined $tag_predefs{lc $tag}) {
2458 # Fine
2459 } else {
2460 # Need a known parameter or predefined value
2461 next;
2462 }
2463 # Not suppressed
2464 next if $notags{$tag} || $notags{lc $tag} ||
2465 $notags{"%$tag%"} || $notags{"%".lc($tag)."%"} ;
2466 next if %tags &&
2467 ! ($tags{$tag} || $tags{lc $tag} ||
2468 $tags{"%$tag%"} || $tags{"%".lc($tag)."%"});
2469 # Need a value
2470 my $val = (defined $ctxt->{$tag} &&
2471 defined $ctxt->{$tag}{val}
2472 ? $ctxt->{$tag}{val} # Param value
2473 : $tag_predefs{$tag} # Pre-defined value
2474 );
2475 print "--- |$param|$origtag|$tag|$ctxt->{$param}{val}|".
2476 ($ctxt->{$tag}{val}//"undef")."|".($val//"undef")."|\n"
2477 if $debug;
2478 next if ! defined $val;
2479 # Must be a scalar
2480 next if ref $val;
2481 # No recursion
2482 next if $tag eq $param;
2483 # No cycles
2484 die "$err: Cycle suspected in replacing tag $tag ".
2485 "in param $param.\n"
2486 if $expanded{$param}{$tag} &&
2487 $expanded{$param}{$tag} > 9;
2488 # If val is non-empty, apply the indicated operations
2489 # (so far this is just a substr or format).
2490 if(@args) {
2491 if(@args == 1 &&
2492 $args[0] =~ m/^[-+]?\d+(\.\d+)?[sdf]$/) {
2493 # sprintf format
2494 $val = sprintf("%$args[0]",$val);
2495 } elsif(grep(/^[-+]?\d+$/,@args) == 2) {
2496 # substring
2497 $val = substr($val,$args[0],$args[1]||1);
2498 } else {
2499 die "$err: Unrecognized args for tag '$tag'; /".
2500 join("/",@args)."/\n";
2501 }
2502 }
2503 # We have a valid tag. Substitute/expand next occurance.
2504 my $newval = $origval;
2505 if($ctxt->{$param}{itype} == 7 && length($val) == 0 &&
2506 $ctxt->{$param}{val} =~ m@[^/][-~_.]%$origtag%@) {
2507 # File types also eat preceding '-', '_', '~', or '.'
2508 # if the tag value is the empty string and the prev
2509 # character is not first or after a '/'.
2510 $newval =~ s/[-~_.]%$origtag%//;
2511 } else {
2512 $newval =~ s/\Q%$origtag%\E/$val/;
2513 }
2514 # Assign new value
2515 if(defined $i) {
2516 $ctxt->{$param}{val}[$i] = $newval;
2517 } else {
2518 $ctxt->{$param}{val} = $newval;
2519 }
2520 print "--- |$newval|\n" if $debug;
2521 if($ctxt->{$param}{isdefault} && $ctxt->{$tag}{specified}) {
2522 # Param now has a specified component
2523 $ctxt->{$param}{isdefault} = 0;
2524 $ctxt->{$param}{specified} = 1;
2525 }
2526 # Flag that we did something
2527 ++$found; # Continue iterating through all param values
2528 $expanded{$param}{$tag}++;
2529 $where{$param} = $i;
2530 } # While still tags
2531 } continue { # Value list
2532 ++$i;
2533 }
2534 } # Param
2535 }
2536
2537 # Assign refs for values with substitutions
2538 if($ctxt->{_meta}{refs}) {
2539 for my $param (keys %where) {
2540 $ctxt->{_meta}{vals}{$param} = $ctxt->{$param}{val};
2541 my $ref = $ctxt->{_meta}{refs}{$param};
2542 assign_ref($ref, $ctxt->{$param}{val}, $ctxt->{$param}, $param);
# spent 186µs making 29 calls to WISE::Params::assign_ref, avg 6µs/call
2543 }
2544 }
2545
2546 return 1;
2547}
2548
2549
# spent 6.19ms (856µs+5.33) within WISE::Params::Param_lines which was called # once (856µs+5.33ms) by WISE::Params::Param_print at line 2677
sub Param_lines {
25502770.001124.0e-6 my $width = shift || 80;
2551 my $prefix = shift || " ";
2552 my (@lines,$opts,$lines,$xtra,$title,$ctxt,$iam);
2553
2554 if(ref($prefix) =~ /hash/i) {
2555 $opts = $prefix;
2556 $prefix = undef;
2557 }
2558 $opts ||= {};
2559 $prefix ||= $opts->{prefix} || "";
2560 $xtra ||= $opts->{extra};
2561 $title ||= $opts->{title};
2562
2563 $ctxt = $opts->{defs} || die "$err/lines: No defs.\n";
2564 $iam = $ctxt->{_meta}{iam};
2565
2566 $lines = $title ? "\n${prefix}Named parameters for $iam:\n" : "";
2567
2568 for (@{$ctxt->{_meta}{parnames}}) {
2569 # from = -1/undef = n_o value
2570 # from = 0 => d_efault
2571 # from = 1 => c_ommand line
2572 # from = 2 => e_nvironment
2573 # from = 3 => f_ile
2574 # from = 4 => p_ass-on
2575 # from = 5 => i_nitialization
2576 my $from = $ctxt->{$_}{source} // -1;
2577 $from = [qw/n d c e f p i/]->[$from+1] // '?';
2578 push @lines,sprintf("%s(%s) = %-s;",$_,$from,valstr($ctxt,$_,0,1));
# spent 4.64ms making 86 calls to WISE::Params::valstr, avg 54µs/call
2579 }
2580 $lines .= parwrapup($width,$prefix,$prefix,0,@lines);
# spent 689µs making 1 call to WISE::Params::parwrapup
2581 if($xtra) {
2582 if(@ARGV) {
2583 $lines .= "${prefix}Unnamed parameters:\n".
2584 parwrapup(80,"$prefix ","$prefix ",1,@ARGV)."\n";
2585 }
2586 if(defined $ctxt->{_meta}{pass_on} &&
2587 @{$ctxt->{_meta}{pass_on}}) {
2588 $lines .= "${prefix}Passed-on parameters:\n".
2589 WISE::Spawn::Param_passon({defs=>$ctxt, dump=>1});
2590 }
2591 }
2592
2593 return $lines;
2594}
2595
2596
# spent 11µs within WISE::Params::origval which was called # once (11µs+0) by WISE::Pars::origval at line 208 of /wise/base/deliv/dev/lib/perl/WISE/Pars.pm
sub origval {
259735.0e-61.7e-6 my $ctxt = shift;
2598 my $full = shift;
2599 return $ctxt->{$full}{origval};
2600}
2601
2602
# spent 4.64ms (2.14+2.50) within WISE::Params::valstr which was called 86 times, avg 54µs/call: # 86 times (2.14ms+2.50ms) by WISE::Params::Param_lines at line 2578, avg 54µs/call
sub valstr {
260313640.002321.7e-6 my $ctxt = shift;
2604 my $full = shift;
2605 my $def = shift;
2606 my $print= shift;
2607 my $k;
2608
2609 my $val = $def ? $ctxt->{$full}{default} : $ctxt->{$full}{val};
2610 if($ctxt->{$full}{perlish}) {
2611 # Special case; dump as Perl string
2612 eval "use WISE::Dumper; 1;"
2613 or die "$err: Can't load WISE::Dumper.\n$@";
2614 ($val = Dumper $val) =~ s/\n\s+//sg;
2615 $val =~ s/^\s*\$VAR\S+\s*=\s*//;
2616 $val =~ s/;\s*$//;
2617 return $val;
2618 }
2619 my @val = ( ref($val) eq "ARRAY"
2620 ? @$val
2621 : ( ref($val) eq "HASH"
2622 ? (map { ($_,$val->{$_}) } sort keys %$val)
2623 : () ));
2624 my ($op,$cl,$sep) = $ctxt->{$full}{list} ? ("(",")",",") : ("","",",");
2625 if($ctxt->{$full}{hash}) {
2626 my @tmp = @val;
2627 @val = ();
2628 push @val,shift(@tmp)."=".(ref($tmp[0])
# spent 1.95ms making 129 calls to WISE::Params::parquote, avg 15µs/call
2629 ? join(",",map { parquote($_,",")//'undef' }
2630 @{shift(@tmp)})
# spent 247µs making 20 calls to WISE::Params::parquote, avg 12µs/call
2631 : parquote(shift(@tmp)//'undef',",")
2632 )
2633 while @tmp;
2634 } elsif ($ctxt->{$full}{list}) {
2635 $_ = parquote($_,",") for @val;
# spent 300µs making 19 calls to WISE::Params::parquote, avg 16µs/call
2636 }
2637 if(@val>10 && $ctxt->{$full}{type} eq 'integer') {
2638 @val = split /,/,parcollapselist(@val);
2639 }
2640 if($print && @val>10 && $ctxt->{$full}{type} eq 'file') {
2641 # For p/o ONLY, remove common prefixes from path lists
2642 @val = sort @val;
2643 my @new = ($val[0]);
2644 my $last = $val[0];
2645 for (@val[1..$#val]) {
2646 my $xor = "$_" ^ "$last"; # Common substrings will end up as NULLs
2647 my ($nulls) = $xor =~ /^(\000*)/;
2648 if(length($nulls) > 20) {
2649 push @new, "...".substr($_,length($nulls)-5);
2650 } else {
2651 push @new, $_;
2652 }
2653 $last = $_;
2654 }
2655 @val = @new;
2656 }
2657 $val = ( ! defined $val
2658 ? 'undef'
2659 : ( ! ref($val)
2660 ? $val
2661 : $op.join($sep,map {defined $_?$_:'undef'} @val).$cl ));
2662
2663 return $val;
2664}
2665
2666
# spent 6.23ms (43µs+6.19) within WISE::Params::Param_print which was called # once (43µs+6.19ms) by WISE::UtilsLight::banner at line 171 of /wise/base/deliv/dev/lib/perl/WISE/UtilsLight.pm
sub Param_print {
2667144.3e-53.1e-6 my ($copyto,$xtra,$width) = (shift,shift,shift);
2668 my ($lines,$opts,$to,$ctxt);
2669
2670 if(ref $copyto) { $opts = $copyto; $copyto = undef; }
2671 $opts ||= {};
2672 $width ||= $opts->{width}||120;
2673 $to = exists $opts->{to} ? $opts->{to} : \*STDOUT;
2674 $copyto ||= $to ? $copyto||$opts->{copyto} : undef;
2675 $xtra ||= $opts->{extra};
2676
2677 $lines = Param_lines($width,{%$opts,width=>$width,extra=>$xtra,title=>1});
# spent 6.19ms making 1 call to WISE::Params::Param_lines
2678 print $to $lines if $to;
2679 print $copyto $lines if $copyto;
2680
2681 return $lines;
2682}
2683
2684sub Csh_set_params {
2685 my $ctxt = shift || die "$err/cshset: No defs.\n";
2686 my (@lines);
2687
2688 for ($ctxt->{_meta}{parnames}) {
2689 my $val = $ctxt->{$_};
2690 printf("set opt_%s = %-s;\n",$_,
2691 (! defined $val ? "''":
2692 (! ref($val) ? &cshescape($val) :
2693 '('.join(" ",map {&cshescape($_)} @$val).')' )));
2694 }
2695}
2696
2697sub cshescape {
2698
2699 local $_ = shift;
2700
2701 if(! defined $_) { $_ = ""; }
2702
2703 s/([^\\])!/$1\\!/g;
2704 s/\'/\'\"\'\"\'/g;
2705
2706 "'$_'";
2707
2708}
2709
2710sub loadparamsfromfile {
2711 my $from = shift;
2712 my $opts = shift || {};
2713 my ($fromfile,$start,$end,$prefix,$suffix,$verbose);
2714
2715 return if ! defined $from;
2716
2717 $start = $opts->{paramstart} || "PARAM_START";
2718 $end = $opts->{paramend} || "PARAM_END";
2719 $prefix = $opts->{paramprefix} || "";
2720 $suffix = $opts->{paramsuffix} || "";
2721 $verbose = $opts->{verbose};
2722
2723 if(ref($from) =~ /glob/i) {
2724 print "Reading param. def.s from filehandle.\n" if $verbose;
2725 } elsif($from eq '-') {
2726 print "Reading param. def.s from stdin.\n" if $verbose;
2727 $from = \*STDIN;
2728 } else {
2729 $fromfile = $from;
2730 print "Reading param. def.s from '$from'.\n" if $verbose;
2731 if (! open(\*DEFS,"<$from") ) {
2732 warn "$err/loadparamsfromfile: Can't open input file '$from'; $!\n";
2733 return;
2734 }
2735 $from = \*DEFS;
2736 }
2737
2738 # Read the file and filter for the param def.s
2739 print "Reading ...\n" if $verbose;
2740 my @defs = <$from>;
2741 close $from;
2742
2743 if($start) {
2744 @defs = grep(/$start/../$end/,@defs);
2745 return if ! @defs;
2746 shift @defs if @defs; # Remove markers
2747 pop @defs if @defs;
2748 }
2749 # If no start tag is defined, assume the whole file should be used
2750
2751 # Remove line-by-line prefix and suffix
2752 if($prefix) { s/^\s*$prefix// for @defs; }
2753 if($suffix) { s/$suffix\s*$// for @defs; }
2754
2755 my $ctxttr = join("",@defs); # Make one big string
2756
2757 return wantarray ? ($ctxttr,$fromfile) : $ctxttr;
2758}
2759
2760# Return the index to the first unquoted and unescaped occurrence of $c in $s
2761
# spent 4.36ms (3.26+1.10) within WISE::Params::paruqindex which was called 345 times, avg 13µs/call: # 259 times (2.55ms+984µs) by WISE::Params::parsedefs at line 376, avg 14µs/call # 53 times (392µs+43µs) by WISE::Params::paramparselines at line 1627, avg 8µs/call # 33 times (322µs+71µs) by WISE::Params::paramlist2hash at line 1876, avg 12µs/call
sub paruqindex {
276210780.002732.5e-6 my ($s,$c,$j) = @_;
2763 return -1 if ! $s || $s !~ /$c/;
2764 # Blank out quoted text
2765 $s = parblankquoted($s,"\000");
# spent 1.10ms making 194 calls to WISE::Params::parblankquoted, avg 6µs/call
2766
2767 return index($s,$c,$j||0);
2768}
2769
2770# Blank out escaped/quoted char.s in $s
2771
# spent 2.16ms within WISE::Params::parblankquoted which was called 404 times, avg 5µs/call: # 194 times (1.10ms+0) by WISE::Params::paruqindex at line 2765, avg 6µs/call # 162 times (790µs+0) by WISE::Params::parquote at line 2826, avg 5µs/call # 24 times (137µs+0) by WISE::Params::paramlist at line 1832, avg 6µs/call # 24 times (130µs+0) by WISE::Params::paramlist at line 1793, avg 5µs/call
sub parblankquoted {
27728080.001281.6e-6 my $s = shift;
2773 return $s if ! $s || $s !~ /"/;
2774 my $blank = shift || "\000";
2775 my $qpat = &parqpat;
2776 my ($i,$j);
2777
2778 # Get rid of double backslashes
2779 # (Use a null as a blank-out char.)
2780 $s =~ s|\\\\|$blank$blank|g;
2781
2782 # Blank out singly-escaped single characters
2783 $s =~ s/\\[^\\]/$blank$blank/g;
2784
2785 # Blank out quoted parts of $s
2786 while($s =~ m/$qpat/o) {
2787 $s = $`.$1.($blank x length($2)).$';
2788 }
2789
2790 return $s;
2791}
2792
2793# This RE will find paired double quotes even if escaped quotes (\") are
2794# embedded. It handles double escapes correctly.
2795sub parqpat {
2796 q@((?<!\\\\)(?:\\\\{2})*)("(?:(?:(?<!\\\\)(?:\\\\{2})*\\\\")|[^"])*")@;
2797}
2798
2799# Remove quotes and un-escape the text
2800
# spent 2.34ms within WISE::Params::parunquote which was called 408 times, avg 6µs/call: # 173 times (1.04ms+0) by WISE::Params::parsedefs at line 378, avg 6µs/call # 129 times (636µs+0) by WISE::Params::Param_parse at line 897, avg 5µs/call # 86 times (558µs+0) by WISE::Params::Param_parse at line 891, avg 6µs/call # 20 times (107µs+0) by WISE::Params::Param_parse at line 894, avg 5µs/call
sub parunquote {
28018260.001351.6e-6 my $s = shift;
2802 return $s if ! $s || $s !~ /"/;
2803 my $outer = shift;
2804 my ($t);
2805 my $qpat = q@((?<!\\\\)(?:\\\\{2})*)("(?:(?:(?<!\\\\)(?:\\\\{2})*\\\\")|[^"])*")@;
2806 $qpat = "^$qpat\$" if $outer;
2807
2808 while($s =~ m/$qpat/o) {
2809 # print "\n\tMatched = /$1/$2/\n";
2810 $t = $2;
2811 $t = substr($t,1,-1);
2812 $s = $`.$1.$t.$';
2813 # print "\tresult = /$s/\n";
2814 }
2815
2816 if($s =~ m|\\+|) { $s =~ s|(\\+)|'\\'x(int(length($1)/2))|eg; }
2817
2818 return $s;
2819}
2820
2821# Backwhack any instances of $c that aren't already quoted or backwhacked
2822
# spent 2.50ms (1.71+790µs) within WISE::Params::parquote which was called 168 times, avg 15µs/call: # 129 times (1.34ms+614µs) by WISE::Params::valstr at line 2628, avg 15µs/call # 20 times (170µs+77µs) by WISE::Params::valstr at line 2630, avg 12µs/call # 19 times (201µs+99µs) by WISE::Params::valstr at line 2635, avg 16µs/call
sub parquote {
282313140.001581.2e-6 my $s = shift;
2824 my $c = shift;
2825 return $s if ! $s || ! defined $c;
2826 my $t = parblankquoted($s,"!");
# spent 790µs making 162 calls to WISE::Params::parblankquoted, avg 5µs/call
2827
2828 my $i = -1;
2829 my $off = 0;
2830 while(($i = index($t,$c,$i+1)) >= 0) {
2831 substr($s,$i+$off++,0,"\\"); # Insert backwhack
2832 }
2833 return $s;
2834}
2835
2836
# spent 689µs within WISE::Params::parwrapup which was called # once (689µs+0) by WISE::Params::Param_lines at line 2580
sub parwrapup {
28373620.000681.9e-6 my ($columns, $ip, $xp, $resplit) =
2838 (shift||80,shift,shift,shift);
2839 local $_;
2840 my (@t) = map {defined $_ ? $_ : ""} @_;
2841
2842 if(! @t) { return ""; }
2843
2844 my ($r,$s) = ("","");
2845 my $lead1 = defined $ip ? $ip : "";
2846 my $lead2 = defined $xp ? $xp : "";
2847 my ($lead,$ll,$ll1,$ll2);
2848
2849 if($resplit) { @t = split(" ",join(" ",@t)); }
2850 $ll1 = ($columns||80) - length($lead1) - 1;
2851 $ll2 = ($columns||80) - length($lead2) - 1;
2852
2853 $ll = $ll1;
2854 $lead = $lead1;
2855 for (@t) {
2856 s/\s*(.*?)\s*/$1/;
2857 if(length($r)+length($_) >= $ll) {
2858 if(length $r > 0) { $s .= "$lead$r\n"; }
2859 $r = "";
2860 $ll = $ll2;
2861 $lead = $lead2;
2862 }
2863 $r .= "$_ ";
2864
2865 }
2866
2867 if(length $r > 0) { $s .= "$lead$r\n"; }
2868
2869 return $s;
2870
2871}
2872
2873
2874
# spent 484µs within WISE::Params::parexpandlist which was called 5 times, avg 97µs/call: # 5 times (484µs+0) by WISE::Params::paramlist at line 1839, avg 97µs/call
sub parexpandlist {
28752570.000461.8e-6 my $str = shift;
2876 my $nouniq = shift;
2877 my $nosort = shift;
2878 my $min = shift;
2879 my $max = shift;
2880 my $sep = shift || '[,\s]+';
2881 my $run = shift || '\.\.+';
2882 my (@bits);
2883 local $_;
2884
2885 for ( ref $str ? (@$str) : (split(/$sep/,$str)) ) {
2886 if( /([+-]?\w+)$run([+-]?\w+)/ ) { push @bits, $1..$2; }
2887 elsif( /([+-]?\w+)$run/ ) {
2888 if(defined $max) { push @bits, $1..$max; }
2889 else { die "$err: Dangling range fragment: '$_'\n"; }
2890 } elsif( /$run([+-]?\w+)/) {
2891 if(defined $min) { push @bits, $min..$1; }
2892 else { die "$err: Dangling range fragment: '$_'\n"; }
2893 } else { push @bits, $_; }
2894 }
2895
2896 if(! $nouniq) {
2897 my %n;
2898 @n{@bits}=(0)x(scalar(@bits));
2899 @bits = grep(!$n{$_}++,@bits);
2900 }
2901 if(! $nosort) {
2902 @bits = sort {$a <=> $b} @bits;
2903 }
2904
2905 return wantarray ? @bits : scalar(@bits);
2906}
2907
2908
2909# Reverse the above operation.
2910# Parameters can be:
2911# List of integers
2912# Ref. to a list of int.s, followed by
2913# Positional arg.s
2914# An option hash
2915sub parcollapselist {
2916 my @list = @_;
2917 my ($str,$i,$n,$x,$y,$start,$end,$alpha,$nexty);
2918 my ($list,$uniq,$opts);
2919
2920 if(ref $list[0]) {
2921 $list = shift @list; # Lis
2922 @list = @$list; # Local copy
2923 # Other arg.s.
2924 if(ref($list[0]) !~ /hash/i) {
2925 # Positional
2926 ($uniq) = @list; # Uniquify
2927 } else {
2928 # Named options
2929 $opts = $list[0];
2930 $uniq = $opts->{unique} || $opts->{uniq};
2931 }
2932
2933 }
2934
2935 $alpha = grep(/[a-zA-Z]/,@list);
2936
2937 if($uniq) {
2938 my %n;
2939 @list = grep(!$n{$_}++,@list);
2940 }
2941
2942 # There's no "nosort" option because we must sort the list to collapse i
2943 @list = sort {$a <=> $b} @list if ! $alpha;
2944 @list = sort {$a cmp $b} @list if $alpha;
2945
2946 $n = @list;
2947 $str = "";
2948 $start = undef;
2949 $end = undef;
2950 # Nothing perl-ish here.
2951 for ($i=0; $i<$n; ++$i, $y = $x) {
2952 $x = $list[$i];
2953 if($i == 0) { $str = "$x"; next; }
2954 $nexty = $y;
2955 $nexty++;
2956 if((! $alpha && $x == $nexty) ||
2957 ( $alpha && $x eq $nexty)) {
2958 if(! defined $start) { $start = $y; }
2959 $end = $x;
2960 } else {
2961 if(defined $start) { $str .= "..$end"; }
2962 $start = $end = undef;
2963 $str .= ",$x";
2964 }
2965 }
2966 if(defined $start) { $str .= "..$end"; }
2967
2968 return wantarray ? ($str,$alpha) : $str;
2969}
2970
2971
2972
# spent 104µs (21+83) within WISE::Params::parwhoiam which was called # once (21µs+83µs) by WISE::Params::steps_resolve at line 2099
sub parwhoiam {
297341.3e-53.3e-6 my $iam;
2974 if($0 eq "-e") { $iam = "perl-e"; }
2975 else { $iam = basename($0); }
# spent 83µs making 1 call to File::Basename::basename
2976 return $iam;
2977}
2978
2979
2980# Provide a (fairly) safe compartment for eval'ing external code.
2981# (Still not safe against %SIG hijacking.)
2982sub par_safe_eval {
2983 my $code = shift;
2984 my $opts = shift || {};
2985 my $share = $opts->{share};
2986 warn("*** $0/par_safe_eval: share is not an array ref.\n"), return
2987 if $share && ref($share) !~ /array/i;
2988 if($code=~/( # Disallow package manipulation
2989 \w\s*\}?:: | \bpackage\b |
2990 # Disallow signal manipulation
2991 [\$%] \s* \{? \s* SIG \s* \}? \b |
2992 # Disallow call stack manipulation
2993 [\$\@] \s* \{? \s* _ \s* \}? \b )/x) {
2994 $@ = "*** $0/par_afe_eval: string contains unsafe ".
2995 "words/symbols '$1'.\n code='$code'\n";
2996 return;
2997 }
2998 {
2999 require Safe;
3000 Safe->import;
3001
3002 my $safe = Safe->new;
3003 $safe->permit_only(qw/:base_core :base_mem :base_orig :base_math/);
3004 $safe->deny(qw/:sys_db warn die dbmopen tie untie sselect select
3005 pipe_op sockpair/);
3006 $safe->share_from("main",$share) if $share;
3007 return $safe->reval($code,1);
3008 }
3009}
3010
3011
3012# Output a file which, when included by a main prog., will do Perl-like
3013# arg. handling using libnmpar.
3014sub Emit_nmpar_defs {
3015 my $from = shift; # File handle or name to get def.s from
3016 my $to = shift; # File handles or base name to write to
3017 my $opts = shift; # Option hash
3018 my ($genhelp,@defs,$ctxt,$verbose,$itflag,$fromfile,$toc,$toh,$suf,$toname);
3019 my ($prog_name,$prog_file,$prog_title,$stdout,$stdin,$ctxttr,$cname,$hname);
3020 my ($ext,$path) = ("","");
3021
3022 $ctxt = $opts->{defs} || die "$err/emit: No defs.\n";
3023 $verbose = $opts->{verbose};
3024 $prog_name = $opts->{iam};
3025 $suf = $opts->{suf} || "-def";
3026
3027 $toname = ! ref($to) && $to ne "-";
3028 $opts->{incc} &&= $toname;
3029
3030 if(! $to) {
3031 ($to,$path,$ext) = fileparse($from,'\.[^.]+');
3032 $to .= $suf;
3033 } elsif($toname) {
3034 ($to,$path,$ext) = fileparse($to,'\.[^.]+');
3035 }
3036 $ext ||= "";
3037
3038 $opts->{base} ||= fileparse($to,'\.[^.]+') if $toname;
3039
3040 print "\n== Param processing ==\n From=$from, to=$to, ext=$ext".
3041 "base=$opts->{base}\n\n"
3042 if $verbose;
3043
3044 if(defined $from) {
3045 # Need to read and parse def.s; otherwise we assume Params() has
3046 # already been called and put the results in $ctxt.
3047
3048 ($ctxttr,$fromfile) = loadparamsfromfile($from,$opts);
3049
3050 ($verbose&&warn("$warn; No param defs in $from.\n"),exit(0))
3051 if ! $ctxttr;
3052
3053 $prog_name ||= fileparse($fromfile,'\.[^.]+') if $fromfile;
3054 $stdin = $fromfile eq "-";
3055
3056 # Parse parameter def.s into internal structure
3057 print "Parsing ...\n$ctxttr" if $verbose;
3058 $ctxt = Params($ctxttr,{parseonly=>1,sep=>"\n",verbose=>$verbose,
3059 iam=>$prog_name,defs=>{}});
3060 }
3061 Param_help(2,{defs=>$ctxt}) if $verbose;
3062
3063 $genhelp = [ @{$ctxt->{_meta}{help} || []} ];
3064
3065 # Program name is in the first general help line by default if
3066 # it contains Command =>
3067 # ... there's a '::' in the line, on the left is the program name,
3068 # on the right is the program file name.
3069 my ($tmpprog,$tmpfile) =
3070 $genhelp->[0] =~
3071 /\s*Command\s*=>\s*([_a-zA-Z][-\w]*)(?::\s*:\s*(\S+))?/;
3072 if($tmpprog) {
3073 shift @{$genhelp}; # Shift out if found.
3074 $prog_name = $tmpprog;
3075 $prog_file = $tmpfile if $tmpfile;
3076 }
3077
3078 $prog_name ||= $ctxt->{_meta}{iam}; # Last chance
3079
3080 if(! $prog_name || $prog_name !~ /^[_a-zA-Z][-\w]*$/) { # No legal name
3081 die "$err/nmpar: Program name '$prog_name' is missing ".
3082 "or illegal.\n";
3083 }
3084
3085 (my $c_prog_name=$prog_name) =~ s/-/_/g; # Make into a valid c identifier
3086
3087 print "GenHelp=\n@{$genhelp}\n" if $verbose > 1;
3088
3089 # Prepare output file handles
3090 if(ref $to) {
3091 print "Writing nmpar def.s to filehandles.\n" if $verbose;
3092 if(ref($to)=~/array/i) {
3093 $toh = $to->[0];
3094 $toc = $to->[1];
3095 } else {
3096 $toh = $to;
3097 $toc = $to;
3098 }
3099 } elsif($to eq '-') {
3100 # Output 'file' is stdout.
3101 print "Writing nmpar def.s to stdout.\n" if $verbose;
3102 $toh = $toc = \*STDOUT;
3103 $stdout = 1;
3104 } else {
3105 # Not a handle or '-', must be a name
3106 $hname = "$to.h";
3107 print "Writing include file '$hname'.\n" if $verbose;
3108 if(! open(\*NMPARH,">$hname")) {
3109 die "$err/nmpar: Can't open output file '$hname'; $!\n";
3110 }
3111 $toh = \*NMPARH;
3112 $cname = "$to$ext";
3113 print "Writing C code file '$cname'.\n" if $verbose;
3114 if(! open(\*NMPARC,">$cname")) {
3115 die "$err/nmpar: Can't open output file '$cname'; $!\n";
3116 }
3117 $toc = \*NMPARC;
3118 }
3119
3120 # Processing options
3121 # Disallow environment option specification
3122 $opts->{noenv} ||= grep(/\*NO_ENV\*/ ,@defs);
3123 # Disallow init (rc) file opt specification
3124 $opts->{noinit} ||= grep(/\*NO_INIT\*/,@defs);
3125 # Disallow non-option (unnamed) command line arguments
3126 $opts->{noargs} ||= grep(/\*NO_ARGS\*/,@defs);
3127
3128 # Prepare the general help for use
3129 shift @{$genhelp} while @$genhelp && ! $genhelp->[0]; # Skip blank lines
3130
3131 $prog_title = shift @{$genhelp} if $genhelp->[0]; # Synopsis
3132 $prog_title ||= "";
3133 $prog_title =~ s/(?:^|[^\\])([""])/\\$1/; # Escape embedded quotes
3134 $prog_file ||= $fromfile || "UNKNOWN";
3135
3136 #
3137 # Emit .h file code for option processing in 'main'.
3138
3139 print "Writing include file to $toh ...\n" if $verbose;
3140
3141 print $toh "/* This file was auto-generated on ".gmtime(time).
3142 " GMT; DO NOT EDIT */\n\n";
3143 print $toh "/* prog_name\t\t=\t\"$prog_name\"; */\n";
3144 print $toh "/* prog_title\t\t=\t\"$prog_title\"; */\n";
3145 print $toh "/* prog_file_name\t\t=\t$prog_file; */\n\n";
3146
3147 (my $code = <<" EOT")=~s/^ *\t//gm;
3148 \t#include \"namedlist.h\"
3149 \t#include \"nmpar.h\"
3150 \tNamedList * ${c_prog_name}_defparse(NamedList * defs, NamedList * opts);
3151 \tint ${c_prog_name}_help(int help, NamedList * opts);
3152 \tNamedList * cmdlnopts=NULL, * cmdlndefs=NULL;
3153 \t#ifdef __cplusplus
3154 \t#define __BLOCKSTART__ do {
3155 \t#define __BLOCKEND__ } while(0)
3156 \t#else
3157 \t#define __BLOCKSTART__ ({
3158 \t#define __BLOCKEND__ nargs; })
3159 \t#endif
3160 \t#define DoOptions(argc,argv) \\
3161 \t __BLOCKSTART__ \\
3162 \t int nargs,help; \\
3163 \t if((help=help_wanted(argc,argv,NULL)) >= 0) { \\
3164 \t (void)${c_prog_name}_help(help,NULL); \\
3165 \t exit(0); \\
3166 \t } \\
3167 \t cmdlndefs = ${c_prog_name}_defparse(0,0); /* Set up defs */ \\
3168 \t cmdlnopts = /* first parse defaults */ \\
3169 \t parse_cmd_line(cmdlndefs,0,0,NULL,cmdlnopts,NULL); \\
3170 \t cmdlnopts = /* parse command line */ \\
3171 \t parse_cmd_line(cmdlndefs,argc,argv,&nargs, \\
3172 \t cmdlnopts,NULL); \\
3173 \t __BLOCKEND__
3174 EOT
3175 print $toh "$code\n\n";
3176 print $toh "\n#include \"$cname\"\n\n" if $opts->{incc};
3177
3178 close $toh if ! $stdout;
3179
3180 #
3181 # Emit .c (or .cpp) code for option processing; to be linked to main
3182
3183 print "Writing C code file to $toc ...\n" if $verbose;
3184
3185 print $toc "/* This file was auto-generated on ".gmtime(time).
3186 " GMT; DO NOT EDIT */\n\n";
3187 print $toc "/* prog_name\t\t=\t\"$prog_name\"; */\n";
3188 print $toc "/* prog_title\t\t=\t\"$prog_title\"; */\n";
3189 print $toc "/* prog_file_name\t\t=\t$prog_file; */\n\n";
3190
3191 print $toc "#include \"namedlist.h\"\n";
3192 print $toc "#include \"nmpar.h\"\n\n";
3193
3194 print $toc "NamedList * ${c_prog_name}_defparse(NamedList * defs,".
3195 "NamedList * opts)\n";
3196 print $toc "{\n";
3197 print $toc " NamedList *def;\n\n";
3198 print $toc " if(defs == NULL) defs = nm_alloc();\n\n";
3199
3200 # Write individual parameter definition block structures
3201
3202 for my $p (@{$ctxt->{_meta}{parnames}}) {
3203 my ($par,$def,$flag,$descrip,@doc,$val,@aliases,
3204 $type,$dummy,$fmt,$flag_code,$flag_arg);
3205 $par = lc $p;
3206 $def = $ctxt->{$par}; # All parameter definition info
3207 print "Param=$par, def=$def\n" if $verbose;
3208 next if ! $par || $par =~ /^[\*\s]/ || ! ref $def;
3209 if($par !~ /^[^:,""=''\#]+$/) { # Test name for legality '
3210 die "$err/nmpar: Opt name '$par' is illegal.\n";
3211 }
3212 $type = $def->{type};
3213 # Reduce plethora of types to a more manageable number
3214 if($type eq 'char' || $type eq 'name' || $type eq 'file')
3215 { $type = 'string'; }
3216 elsif($type eq 'real') { $type = 'double'; }
3217 print "\tType=$type\n" if $verbose;
3218
3219 # Map the type to a namedlist definition
3220 print $toc " (void)nm_add1(defs,\"$par(n)\",nm_alloctmp());\n";
3221 print $toc " nm_fetch(defs,\"$par\",def,NamedList *,NULL);\n";
3222 print $toc " (void)nm_add1(def,\"name(s)\",\"$par\");\n";
3223 my $nalias = @{$def->{aliases}};
3224 print $toc " { char *aliases[]={\n".
3225 " \"".join('","',@{$def->{aliases}})."\"\n".
3226 " };\n".
3227 " (void)nm_add1(def,\"aliases(s[*$nalias])\",aliases);\n".
3228 " }\n";
3229 print $toc " (void)nm_add1(def,\"type(s)\",\"$type\");\n";
3230 print $toc " (void)nm_add1(def,\"itype(i)\",$def->{itype});\n";
3231 print $toc " (void)nm_add1(def,\"list(i)\",1);\n" if $def->{list};
3232 if(defined $def->{default}) {
3233 if($def->{list}) {
3234 # Default lists look better if space is stripped from around
3235 # commas. We can't handle embedded commas anyway, so do the
3236 # substitution quick and dirty.
3237 $def->{default} =~ s/,\s+/, /g;
3238 }
3239 my $default = $def->{defaultstr};
3240 $default =~ s/^\s*([''""])(.*)\1\s*$/$2/; # Strip outer quotes
3241 $default =~ s/"/\\"/g; # Escape interior quotes "
3242 print $toc " (void)nm_add1(def,\"default(s)\",\"$default\");\n";
3243 print "\tDefault=$default\n" if $verbose;
3244 }
3245 print $toc " (void)nm_add1(def,\"required(i)\",1);\n"
3246 if $def->{required};
3247 # End main definition
3248 print $toc "\n\n";
3249
3250 # Done with parameter definitions
3251 }
3252 print $toc "\n return defs;\n";
3253 print $toc "\n}\n";
3254
3255 # Now write help routine
3256 (my $help0 = Param_help(0,{noop=>1,defs=>$ctxt})) =~ s/"/\\"/g;
3257 $help0 =~ s/\n/\\n"\n"/g;
3258 (my $help1 = Param_help(1,{noop=>1,defs=>$ctxt})) =~ s/"/\\"/g;
3259 $help1 =~ s/\n/\\n"\n"/g;
3260 (my $help2 = Param_help(2,{noop=>1,defs=>$ctxt})) =~ s/"/\\"/g;
3261 $help2 =~ s/\n/\\n"\n"/g;
3262 (my $help3 = Param_help(3,{noop=>1,defs=>$ctxt})) =~ s/"/\\"/g;
3263 $help3 =~ s/\n/\\n"\n"/g;
3264 my $tmp = <<" EOC";
3265 \tstatic char * help0 =
3266 \t"$help0";
3267 \t
3268 \tstatic char * help1 =
3269 \t"$help1";
3270 \t
3271 \tstatic char * help2 =
3272 \t"$help2";
3273 \t
3274 \tstatic char * help3 =
3275 \t"$help3";
3276 \t
3277 \tint ${c_prog_name}_help(int help,NamedList * opts)
3278 \t{
3279 \t if (help == 0) fprintf(stdout,"%s",help0);
3280 \t else if(help == 1) fprintf(stdout,"%s",help1);
3281 \t else if(help == 2) fprintf(stdout,"%s",help2);
3282 \t else if(help == 3) fprintf(stdout,"%s",help3);
3283 \t else return -1; // Failure
3284 \t return 0; // Success
3285 \t}
3286 EOC
3287 print "\n\nHelp o/p = ".length($tmp)." bytes.\n" if $verbose;
3288
3289 # A 5.6.0 bug requires doing this translation line-by-line
3290 $tmp = (join "\n",map { s/^ *\t//; $_; } split /\n/,$tmp)."\n";
3291 print $toc "\n\n$tmp\n";
3292
3293 close $toc if ! $stdout;
3294
3295 return 1;
3296}
3297
3298# Get the parameters from the help listing of another program
3299# using the params() call. These parameters will be usable as input
3300# to a subsequent params() call, allowing us to clone param lists
3301# and build on them.
3302sub paramsfrommodel {
3303 my $exec = shift;
3304 my $opts = shift || {};
3305 $opts = {%params_from_model_opts, %$opts}; # Add default opts
3306 my $execpath = $opts->{execpath} || "";
3307 my $usecache = exists $opts->{use_cache} || exists $opts->{usecache}
3308 ? $opts->{use_cache} // $opts->{usecache}
3309 : 1;
3310 my $cachedir = $opts->{cachedir};
3311 my $umask = $opts->{cache_umask} || 02;
3312 my $from = $opts->{included_from};
3313 my $param_defs = $opts->{param_defs};
3314 my ($base,$cachefile,$cache_uptodate,$ref);
3315
3316 # Establish name of cache, if used
3317
3318 if($usecache && ! $cachedir) {
3319 if(! $execpath) {
3320 ($exec,$execpath) = WISE::UtilsLight::whichami($exec);
3321 }
3322 $execpath = WISE::UtilsLight::normalizepath($execpath,{resolve=>1});
3323 $cachedir = "${execpath}param_cache/";
3324 $cachefile = $cachedir.basename($exec).".params";
3325 }
3326
3327 # Expand executable path
3328
3329 if($execpath && $exec !~ m|^/|) {
3330 $exec = "$execpath/$exec";
3331 }
3332
3333 if($usecache && -e $cachefile && -e $exec) {
3334 # Compare cache time to executable time
3335 $cache_uptodate = -e $cachefile && -M _ < -M $exec;
3336 # Also compare to WISE::Pars.pm time
3337 $cache_uptodate &&= -e $cachefile && -M _ < -M $INC{'WISE/Pars.pm'}
3338 if $INC{'WISE/Pars.pm'};
3339 $cache_uptodate &&= -e $cachefile && -M _ < -M $INC{'WISE/Params.pm'}
3340 if $INC{'WISE/Params.pm'};
3341 }
3342
3343
3344 my @defs;
3345
3346 if($param_defs) {
3347 # Newest defs handed to us
3348
3349 @defs = @$param_defs;
3350 $cache_uptodate = 0; # Always update in this case
3351
3352 } else {
3353 # Open source for command line defs
3354 my $def_fh;
3355
3356 # Try to read cache
3357 if($usecache && $cache_uptodate) {
3358 if(! open($def_fh,"<$cachefile")) {
3359 # May have been removed between testing for up-to-dateness and
3360 # now, so just carry on as if there was no cache
3361 $def_fh = undef;
3362 } else {
3363 $ref = $cachefile;
3364 }
3365 }
3366
3367 # No cache. Get by running executable
3368 if(! $def_fh) {
3369 local $ENV{NO_DEFAULT_PAR_FILES} = 1;
3370 if(! open($def_fh,"$exec -help2 |")) {
3371 warn "*** $0/PARAMMODEL: Couldn't start $exec to get ".
3372 "model param.s; $!\n";
3373 return;
3374 }
3375 $ref = $exec;
3376 }
3377
3378 # Read them
3379
3380 while(<$def_fh>) {
3381 chomp;
3382 push @defs, $_;
3383 }
3384
3385 if(! close($def_fh)) {
3386 warn "*** $0/PARAMMOD: Process failed getting model param.s from ".
3387 "'$ref' (close); $!.\n";
3388 return;
3389 }
3390 }
3391
3392 if(! @defs) {
3393 warn "*** $0/PARAMMOD: Process read NO model param.s from ".
3394 "'$ref'; $!.\n";
3395 return;
3396 }
3397
3398 # Update cache
3399
3400 if($usecache && ! $cache_uptodate) { UPDATE: {
3401 if(! -e $cachedir) {
3402 last UPDATE if ! -w "$cachedir/..";
3403 if(! mkdir($cachedir)) {
3404 warn "*** $0/PARAMMOD: Unable to make cache directory ".
3405 "'$cachedir'; $!.\n";
3406 last UPDATE;
3407 }
3408 }
3409 last UPDATE if -e $cachefile && ! -w $cachefile;
3410 # If $exec's parameters form part of someone else's parameters,
3411 # through an 'include_defs' directive, we need to
3412 # invalidate their cache too
3413 if($from) {
3414 my $from_cache = $cachedir.basename($from).".params";
3415 unlink($from_cache) if -e $from_cache;
3416 }
3417 # Use temporary file so update is atomic
3418 require File::Temp;
3419 my $cachefh = File::Temp->new(UNLINK=>0,DIR=>$cachedir);
3420 print $cachefh join("\n",@defs),"\n","\n## Cache_time=".time()."\n"
3421 or warn("*** $0/PARAMMOD: Unable to write cache file ".
3422 "'$cachefile'; $!.\n"),
3423 last UPDATE;
3424 close $cachefh
3425 or warn "*** $0/PARAMMOD: Unable to write (close) cache file ".
3426 "'$cachefile'; $!.\n";
3427 my $perms = (0666 & ~$umask);
3428 chmod $perms, $cachefh->filename();
3429 rename($cachefh->filename(),$cachefile);
3430 chmod $perms, $cachefile; # ... in case above chmod didn't work
3431 } }
3432
3433 # Set scalar return type
3434
3435 my $defs;
3436 $defs = join("\n",@defs)."\n" if ! $opts->{arrayref};
3437 $defs = \ @defs if $opts->{arrayref};
3438
3439 return wantarray && ! $opts->{arrayref} ? @defs : $defs;
3440}
3441
344212.2e-52.2e-51;

Report produced by the NYTProf 2.07 Perl profiler, developed by Tim Bunce and Adam Kaplan.