File Coverage

blib/lib/Getopt/EvaP.pm
Criterion Covered Total %
statement 347 492 70.5
branch 219 328 66.7
condition 41 77 53.2
subroutine 18 23 78.2
pod 0 5 0.0
total 625 925 67.5


line stmt bran cond sub pod time code
1             $Getopt::EvaP::VERSION |= '2.7';
2              
3             package Getopt::EvaP;
4              
5             # EvaP.pm - Evaluate Parameters for Perl (the getopt et.al. replacement)
6             #
7             # Stephen.O.Lidie@Lehigh.EDU, 94/10/28
8             #
9             # Made to conform, as much as possible, to the C function evap. The C, Perl
10             # and Tcl versions of evap are patterned after the Control Data procedure
11             # CLP$EVALUATE_PARAMETERS for the NOS/VE operating system, although none
12             # approach the richness of CDC's implementation.
13             #
14             # Availability is via anonymous FTP from ftp.Lehigh.EDU in the directory
15             # pub/evap/evap-2.x.
16             #
17             # Stephen O. Lidie, Lehigh University Computing Center.
18             #
19             # Copyright (C) 1993 - 2014 by Stephen O. Lidie. All rights reserved.
20             #
21             # This program is free software; you can redistribute it and/or modify it under
22             # the same terms as Perl itself.
23             #
24             # For related information see the evap/C header file evap.h. Complete
25             # help can be found in the man pages evap(2), evap.c(2), EvaP.pm(2),
26             # evap.tcl(2) and evap_pac(2).
27              
28             require 5.002;
29 1     1   2490 use Text::ParseWords;
  1         2056  
  1         81  
30 1         7 use subs qw/evap_fin evap_parse_command_line evap_parse_PDT evap_PDT_error
31 1     1   1297 evap_set_value/;
  1         25  
32 1     1   148 use strict qw/refs subs/;
  1         6  
  1         29  
33 1     1   5 use Exporter;
  1         2  
  1         428  
34             @ISA = qw/Exporter/;
35             @EXPORT = qw/EvaP EvaP_PAC/;
36             @EXPORT_OK = qw/evap evap_pac/;
37              
38             *EvaP = \&evap; # new alias for good 'ol Evaluate Parameters
39             *EvaP_PAC = \&evap_pac; # new alias for Process Application Commands
40              
41             sub evap { # Parameter Description Table, Message Module
42              
43 6     6 0 14625 my($ref_PDT, $ref_MM, $ref_Opt) = @_;
44            
45 6 100       40 $evap_DOS = 0 unless defined $evap_DOS; # 1 iff MS-DOS, else Unix
46              
47 6         29 local($pdt_reg_exp1) = '^(.)(.)(.?)$';
48 6         14 local($pdt_reg_exp2) = '^TRUE$|^YES$|^ON$|^1$';
49 6         14 local($pdt_reg_exp3) = '^FALSE$|^NO$|^OFF$|^0$';
50 6         13 local($pdt_reg_exp4) = '^\s*no_file_list\s*$';
51 6         15 local($pdt_reg_exp5) = '^\s*optional_file_list\s*$';
52 6         18 local($pdt_reg_exp6) = '^\s*required_file_list\s*$';
53 6         17 local($full_help) = 0;
54 6         13 local($usage_help) = 0;
55 6         23 local($file_list) = 'optional_file_list';
56 6         10 local($error) = 0;
57 6         41 local($pkg) = (caller)[0];
58 6         280 local($value, $rt, $type, $required, @P_PARAMETER, %P_INFO, %P_ALIAS,
59             @P_REQUIRED, %P_VALID_VALUES, %P_ENV, %P_SET);
60 6         31 local($option, $default_value, $list, $parameter, $alias, @keys,
61             $found, $length, %P_EVALUATE, %P_DEFAULT_VALUE);
62 6         13 local(@local_pdt);
63 6         11 local($lref_MM) = $ref_MM; # maintain a local reference
64 6         12 local($lref_Opt) = $ref_Opt;
65            
66 6 100       25 $evap_embed = 0 unless defined $evap_embed; # 1 iff embed evap
67 6 100       29 if ($evap_embed) { # initialize for a new call
68 5 50       54 if (defined $lref_Opt) {
69 0         0 undef %$lref_Opt;
70             } else {
71 1     1   5 no strict 'refs';
  1         2  
  1         1447  
72 5         26 undef %{"${pkg}::Options"};
  5         193  
73 5         20 undef %{"${pkg}::options"};
  5         51  
74             }
75             }
76              
77 6         40 evap_parse_PDT $ref_PDT;
78 6         22 return evap_parse_command_line;
79              
80             } # end evap
81            
82             sub evap_parse_PDT {
83            
84             # Verify correctness of the PDT. Check for duplicate parameter names and
85             # aliases. Extract default values and possible keywords. Decode the user
86             # syntax and convert into a simpler form (ala NGetOpt) for internal use.
87             # Handle 'file list' too.
88              
89 6     6   14 my($ref_PDT) = @_;
90              
91 6         11 @local_pdt = @{$ref_PDT}; # private copy of the PDT
  6         282  
92 6         30 unshift @local_pdt, 'help, h: switch'; # supply -help automatically
93 6         13 @P_PARAMETER = (); # no parameter names
94 6         16 %P_INFO = (); # no encoded parameter information
95 6         11 %P_ALIAS = (); # no aliases
96 6         11 @P_REQUIRED = (); # no required parameters
97 6         14 %P_VALID_VALUES = (); # no keywords
98 6         13 %P_ENV = (); # no default environment variables
99 6         12 %P_EVALUATE = (); # no PDT values evaluated yet
100 6         11 %P_DEFAULT_VALUE = (); # no default values yet
101 6         12 %P_SET = (); # no sets yet
102              
103             OPTIONS:
104 6         23 foreach $option (@local_pdt) {
105              
106 72         1033 $option =~ s/\s*$//; # trim trailing spaces
107 72 100       952 next OPTIONS if $option =~ /^#.*|PDT\s+|pdt\s+|PDT$|pdt$/;
108 66         776 $option =~ s/\s*PDTEND|\s*pdtend//;
109 66 50       237 next OPTIONS if $option =~ /^ ?$/;
110            
111 66 100       958 if ($option =~ /$pdt_reg_exp4|$pdt_reg_exp5|$pdt_reg_exp6/) {
112 6         12 $file_list = $option; # remember user specified file_list
113 6         21 next OPTIONS;
114             }
115            
116 60         479 ($parameter, $alias, $_) =
117             ($option =~ /^\s*(\S*)\s*,\s*(\S*)\s*:\s*(.*)$/);
118 60 50 33     908 evap_PDT_error "Error in an Evaluate Parameters 'parameter, alias: " .
      33        
119             "type' option specification: \"$option\".\n"
120             unless defined $parameter and defined $alias and defined $_;
121 60 50       172 evap_PDT_error "Duplicate parameter $parameter: \"$option\".\n"
122             if defined( $P_INFO{$parameter});
123 60         137 push @P_PARAMETER, $parameter; # update the ordered list of parameters
124              
125 60 50       279 if (/(\bswitch\b|\binteger\b|\bstring\b|\breal\b|\bfile\b|\bboolean\b|\bkey\b|\bname\b|\bapplication\b|\bintegers\b|\bstrings\b|\breals\b|\bfiles\b|\bbooleans\b|\bkeys\b|\bnames\b|\bapplications\b)/) {
126 60         329 ($list, $type, $_) = ($`, $1, $');
127             } else {
128 0         0 evap_PDT_error "Parameter $parameter has an undefined type: " .
129             "\"$option\".\n";
130             }
131 60 50 66     272 evap_PDT_error "Expecting 'list of', found: \"$list\".\n"
      33        
132             if $list ne '' and $list !~ /\s*list\s+of\s+/ and
133             $list !~ /\d+\s+/;
134 60         113 my($set) = $list =~ /(\d+)\s+/;
135 60         178 $P_SET{$parameter} = $set;
136 60         108 $list =~ s/\d+\s+//;
137 60 100       130 $list = '1' if $list; # list state = 1, possible default PDT values
138 60 100       165 $type = 'w' if $type =~ /^switch$/;
139 60         122 $type = substr $type, 0, 1;
140              
141 60 100       370 ($_, $default_value) = /\s*=\s*/ ? ($`, $') :
142             ('', ''); # get possible default value
143 60 100       260 if ($default_value =~ /^([^\(]{1})(\w*)\s*,\s*(.*)/) {
144             # If environment variable AND not a list.
145 6         39 $default_value = $3;
146 6         27 $P_ENV{$parameter} = $1 . $2;
147             }
148 60 100       152 $required = ($default_value eq '$required') ? 'R' : 'O';
149 60 50       217 $P_INFO{$parameter} = defined $type ? $required . $type . $list : "";
150 60 100       433 push @P_REQUIRED, $parameter if $required =~ /^R$/;
151              
152 60 100       134 if ($type =~ /^k$/) {
153 6         33 $_ =~ s/,/ /g;
154 6         36 @keys = split ' ';
155 6         13 pop @keys; # remove 'keyend'
156 6         25 $P_VALID_VALUES{$parameter} = join ' ', @keys;
157             } # ifend keyword type
158            
159 60         212 foreach $value (keys %P_ALIAS) {
160 270 50       759 evap_PDT_error "Duplicate alias $alias: \"$option\".\n"
161             if $alias eq $P_ALIAS{$value};
162             }
163 60         260 $P_ALIAS{$parameter} = $alias; # remember alias
164              
165 60 50       157 evap_PDT_error "Cannot have 'list of switch': \"$option\".\n"
166             if $P_INFO{$parameter} =~ /^.w1$/;
167              
168 60 100 100     294 if ($default_value ne '' and $default_value ne '$required') {
    100          
169 42 50 66     239 $default_value = $ENV{$P_ENV{$parameter}} if $P_ENV{$parameter}
170             and $ENV{$P_ENV{$parameter}};
171 42         87 $P_DEFAULT_VALUE{$parameter} = $default_value;
172 42         217 evap_set_value 0, $type, $list, $default_value, $parameter;
173             } elsif ($evap_embed) {
174 1     1   176 no strict 'refs';
  1         3  
  1         2261  
175 15 50       48 undef ${"${pkg}::opt_${parameter}"} if not defined $lref_Opt;
  15         171  
176             }
177            
178             } # forend OPTIONS
179              
180 6 50       32 if ($error) {
181 0         0 print STDERR "Read the `man' page \"EvaP.pm\" for details on PDT syntax.\n";
182 0         0 exit 1;
183             }
184              
185             } # end evap_parse_PDT
186              
187             sub evap_parse_command_line {
188              
189             # Process arguments from the command line, stopping at the first parameter
190             # without a leading dash, or a --. Convert a parameter alias into its full
191             # form, type-check parameter values and store the value into global
192             # variables for use by the caller. When complete call evap_fin to
193             # perform final processing.
194            
195             ARGUMENTS:
196 6     6   127 while ($#ARGV >= 0) {
197            
198 25         62 $option = shift @ARGV; # get next command line parameter
199 25         44 $value = undef; # assume no value
200            
201 25 100       95 $full_help = 1 if $option =~ /^-(full-help|\Q???\E)$/;
202 25 100       238 $usage_help = 1 if $option =~ /^-(usage-help|\Q??\E)$/;
203 25 100 66     190 $option = '-help' if $full_help or $usage_help or
      66        
204             $option =~ /^-(\Q?\E)$/;
205            
206 25 100       111 if ($option =~ /^(--|-)/) { # check for end of parameters
207 24 50       63 if ($option eq '--') {
208 0         0 return evap_fin;
209             }
210 24         77 $option = $'; # option name without dash
211             } else { # not an option, push it back on the list
212 1         2 unshift @ARGV, $option;
213 1         26 return evap_fin;
214             }
215            
216 24         113 foreach $alias (keys %P_ALIAS) { # replace alias with the full spelling
217 240 100       644 $option = $alias if $option eq $P_ALIAS{$alias};
218             }
219            
220 24 100       104 if (not defined($rt = $P_INFO{$option})) {
221 2         6 $found = 0;
222 2         4 $length = length $option;
223 2         8 foreach $key (keys %P_INFO) { # try substring match
224 20 100       53 if ($option eq substr $key, 0, $length) {
225 1 50       4 if ($found) {
226 0         0 print STDERR "Ambiguous parameter: -$option.\n";
227 0         0 $error++;
228 0         0 last;
229             }
230 1         4 $found = $key; # remember full spelling
231             }
232             } # forend
233 2 100       13 $option = $found ? $found : $option;
234 2 100       10 if (not defined($rt = $P_INFO{$option})) {
235 1         17 print STDERR "Invalid parameter: -$option.\n";
236 1         2 $error++;
237 1         4 next ARGUMENTS;
238             }
239             } # ifend non-substring match
240            
241 23         199 ($required, $type, $list) = ($rt =~ /$pdt_reg_exp1/);
242            
243 23 100       108 if ($type !~ /^w$/) {
244 19 100       51 if ($#ARGV < 0) { # if argument list is exhausted
245 1         14 print STDERR "Value required for parameter -$option.\n";
246 1         3 $error++;
247 1         4 next ARGUMENTS;
248             } else {
249 18         45 $value = shift @ARGV;
250             }
251             }
252            
253 22 100       182 if ($type =~ /^w$/) { # switch
    100          
    100          
    100          
    100          
    100          
    50          
254 4         9 $value = 1;
255             } elsif ($type =~ /^i$/) { # integer
256 3 100       22 if ($value !~ /^[+-]?[0-9]+$/) {
257 1         17 print STDERR "Expecting integer reference, found \"$value\" for parameter -$option.\n";
258 1         2 $error++;
259 1         3 undef $value;
260             }
261             } elsif ($type =~ /^r$/) { # real number, int is also ok
262 5 100       54 if ($value !~ /^\s*[+-]?(\d+(\.\d*)?|\.\d+)([eE][+-]?\d+)?\s*$/) {
263 1         63 print STDERR "Expecting real reference, found \"$value\" for parameter -$option.\n";
264 1         2 $error++;
265 1         2 undef $value;
266             }
267             } elsif ($type =~ /^s$|^n$|^a$/) { # string or name or application
268             } elsif ($type =~ /^f$/) { # file
269 1 50       8 if (length $value > 255) {
270 0         0 print STDERR "Expecting file reference, found \"$value\" for parameter -$option.\n";
271 0         0 $error++;
272 0         0 undef $value;
273             }
274             } elsif ($type =~ /^b$/) { # boolean
275 2         8 $value =~ tr/a-z/A-Z/;
276 2 100       104 if ($value !~ /$pdt_reg_exp2|$pdt_reg_exp3/i) {
277 1         14 print STDERR "Expecting boolean reference, found \"$value\" for parameter -$option.\n";
278 1         2 $error++;
279 1         2 undef $value;
280             }
281             } elsif ($type =~ /^k$/) { # keyword
282              
283             # First try exact match, then substring match.
284              
285 2         7 undef $found;
286 2         15 @keys = split ' ', $P_VALID_VALUES{$option};
287 2   100     29 for ($i = 0; $i <= $#keys and not defined $found; $i++) {
288 5 100       35 $found = 1 if $value eq $keys[$i];
289             }
290 2 100       11 if (not defined $found) { # try substring match
291 1         4 $length = length $value;
292 1         5 for ($i = 0; $i <= $#keys; $i++) {
293 4 50       18 if ($value eq substr $keys[$i], 0, $length) {
294 0 0       0 if (defined $found) {
295 0         0 print STDERR "Ambiguous keyword for parameter -$option: $value.\n";
296 0         0 $error++;
297 0         0 last; # for
298             }
299 0         0 $found = $keys[$i]; # remember full spelling
300             }
301             } # forend
302 1 50       5 $value = defined( $found ) ? $found : $value;
303             } # ifend
304 2 100       16 if (not defined $found) {
305 1         16 print STDERR "\"$value\" is not a valid value for the parameter -$option.\n";
306 1         3 $error++;
307 1         2 undef $value;
308             }
309             } # ifend type-check
310            
311 22 100       74 next ARGUMENTS if not defined $value;
312            
313 18 100       6018 $list = '2' if $list =~ /^1$/; # advance list state
314 18 50       716 evap_set_value 1, $type, $list, $value, $option if defined $value;
315             # Remove from $required list if specified.
316 18         85 @P_REQUIRED = grep $option ne $_, @P_REQUIRED;
317 18 100       92 $P_INFO{$option} = $required . $type . '3' if $list;
318              
319             } # whilend ARGUMENTS
320            
321 5         17 return evap_fin;
322            
323             } # end evap_parse_command_line
324              
325             sub evap_fin {
326              
327             # Finish up Evaluate Parameters processing:
328             #
329             # If -usage-help, -help or -full-help was requested then do it and exit.
330             # Else,
331             #
332             # . Store program name in `help' variables.
333             # . Perform deferred evaluations.
334             # . Ensure all $required parameters have been given a value.
335             # . Ensure the validity of the trailing file list.
336             # . Exit with a Unix return code of 1 if there were errors and
337             # $evap_embed = 0, else return to the calling Perl program with a
338             # proper return code.
339            
340 1     1   11 use File::Basename;
  1         4  
  1         544  
341            
342 6     6   21 my($m, $p, $required, $type, $list, $rt, $def, $element, $is_string,
343             $pager, $do_page);
344              
345             # Define Help Hooks text as required.
346            
347 6 100       21 $evap_Help_Hooks{'P_HHURFL'} = " file(s)\n"
348             if not defined $evap_Help_Hooks{'P_HHURFL'};
349 6 100       17 $evap_Help_Hooks{'P_HHUOFL'} = " [file(s)]\n"
350             if not defined $evap_Help_Hooks{'P_HHUOFL'};
351 6 100       17 $evap_Help_Hooks{'P_HHUNFL'} = "\n"
352             if not defined $evap_Help_Hooks{'P_HHUNFL'};
353 6 100       12 $evap_Help_Hooks{'P_HHBRFL'} = "\nfile(s) required by this command\n\n"
354             if not defined $evap_Help_Hooks{'P_HHBRFL'};
355 6 100       18 $evap_Help_Hooks{'P_HHBOFL'} = "\n[file(s)] optionally required by this command\n\n"
356             if not defined $evap_Help_Hooks{'P_HHBOFL'};
357 6 100       20 $evap_Help_Hooks{'P_HHBNFL'} = "\n"
358             if not defined $evap_Help_Hooks{'P_HHBNFL'};
359 6 100       14 $evap_Help_Hooks{'P_HHERFL'} = "Trailing file name(s) required.\n"
360             if not defined $evap_Help_Hooks{'P_HHERFL'};
361 6 100       21 $evap_Help_Hooks{'P_HHENFL'} = "Trailing file name(s) not permitted.\n"
362             if not defined $evap_Help_Hooks{'P_HHENFL'};
363              
364 6         10 my $want_help = 0;
365 6 100       12 if (defined $lref_Opt) {
366 1         2 $want_help = $lref_Opt->{'help'};
367             } else {
368 1     1   7 no strict 'refs';
  1         3  
  1         1035  
369 5         10 $want_help = "${pkg}::opt_help";
370 5         15 $want_help = $$want_help;
371             }
372              
373 6 100       14 if ($want_help) { # see if help was requested
374            
375 3         10 my($optional);
376 3         9 my(%parameter_help) = ();
377 3         5 my($parameter_help_in_progress) = 0;
378 3         55 my(%type_list) = (
379             'w' => 'switch',
380             'i' => 'integer',
381             's' => 'string',
382             'r' => 'real',
383             'f' => 'file',
384             'b' => 'boolean',
385             'k' => 'key',
386             'n' => 'name',
387             'a' => 'application',
388             );
389              
390             # Establish the pager and open the pipeline. Do no paging if the
391             # boolean environment variable D_EVAP_DO_PAGE is FALSE.
392              
393 3         5 $pager = 'more';
394 3 50 33     22 $pager = $ENV{'PAGER'} if defined $ENV{'PAGER'} and $ENV{'PAGER'};
395 3 50 33     19 $pager = $ENV{'MANPAGER'} if defined $ENV{'MANPAGER'} and
396             $ENV{'MANPAGER'};
397 3         10 $pager = '|' . $pager;
398 3 50 33     13 if (defined $ENV{'D_EVAP_DO_PAGE'} and
399             (($do_page = $ENV{'D_EVAP_DO_PAGE'}) ne '')) {
400 0         0 $do_page =~ tr/a-z/A-Z/;
401 0 0       0 $pager = '>-' if $do_page =~ /$pdt_reg_exp3/;
402             }
403 3 50       30 $pager = '>-' if $^O eq 'MacOS';
404 3 50       8368 open(PAGER, "$pager") or warn "'$pager' open failed: $!";
405            
406 3 100       85 print PAGER "Command Source: $0\n\n" if $full_help;
407              
408             # Print the Message Module text and save any full help. The key is the
409             # parameter name and the value is a list of strings with the newline as
410             # a separator. If there is no Message Module or it's empty then
411             # display an abbreviated usage message.
412            
413 3 100 66     122 if ($usage_help or not defined @{$lref_MM} or $#{$lref_MM} < 0) {
  2   66     53  
  2         16  
414            
415 1         352 $basename = basename($0, "");
416 1         20 print PAGER "\nUsage: ", $basename;
417 1         7 $optional = '';
418 1         12 foreach $p (@P_PARAMETER) {
419 10 100       43 if ($P_INFO{$p} =~ /^R..?$/) { # if $required
420 1         8 print PAGER " -$P_ALIAS{$p}";
421             } else {
422 9         31 $optional .= " -$P_ALIAS{$p}";
423             }
424             } # forend
425 1 50       11 print PAGER " [$optional]" if $optional;
426 1 50       207 if ($file_list =~ /$pdt_reg_exp5/) {
    0          
427 1         5 print PAGER "$evap_Help_Hooks{'P_HHUOFL'}";
428             } elsif ($file_list =~ /$pdt_reg_exp6/) {
429 0         0 print PAGER "$evap_Help_Hooks{'P_HHURFL'}";
430             } else {
431 0         0 print PAGER "$evap_Help_Hooks{'P_HHUNFL'}";
432             }
433            
434             } else {
435            
436 2         27 MESSAGE_LINE:
437 2         21 foreach $m (@{$lref_MM}) {
438            
439 122 100       361 if ($m =~ /^\.(.*)$/) { # look for 'dot' leadin character
440 18         50 $p = $1; # full spelling of parameter
441 18         26 $parameter_help_in_progress = 1;
442 18         91 $parameter_help{$p} = "\n";
443 18         42 next MESSAGE_LINE;
444             } # ifend start of help text for a new parameter
445 104 100       167 if ($parameter_help_in_progress) {
446 80         217 $parameter_help{$p} .= $m . "\n";
447             } else {
448 24         73 print PAGER $m, "\n";
449             }
450            
451             } # forend MESSAGE_LINE
452            
453             } # ifend usage_help
454              
455             # Pass through the PDT list printing a standard evap help summary.
456              
457 3         21 print PAGER "\nParameters:\n";
458 3 100       15 if (not $full_help) {print PAGER "\n";}
  2         4  
459            
460             ALL_PARAMETERS:
461 3         14 foreach $p (@P_PARAMETER) {
462              
463 1     1   7 no strict 'refs';
  1         3  
  1         1992  
464 30 100       69 if ($full_help) {print PAGER "\n";}
  10         22  
465            
466 30 100       78 if ($p =~ /^help$/) {
467 3         21 print PAGER "-$p, $P_ALIAS{$p}, usage-help, full-help: Display Command Information\n";
468 3 100       16 if ($full_help) {
469 1         8 print PAGER <<"end_of_DISCI";
470             \n Display information about this command, which includes a command description with examples, as well as a synopsis of the
471             command line parameters. If you specify -full-help rather than -help complete parameter help is displayed if it's available.
472             end_of_DISCI
473             }
474 3         399 next ALL_PARAMETERS;
475             }
476            
477 27         109 $rt = $P_INFO{$p}; # get encoded required/type information
478 27         334 ($required, $type, $list) = ($rt =~ /$pdt_reg_exp1/); # unpack
479 27         71 $type = $type_list{$type};
480 27         54 $is_string = ($type =~ /^string$/);
481            
482 27 50       74 my $set = $P_SET{$p} ? "$P_SET{$p} " : '';
483 27 100       124 print PAGER "-$p, $P_ALIAS{$p}: ", $list ? "list of " : '', "$set$type";
484 27 50 33     88 if (defined($P_SET{$p}) and $P_SET{$p} > 1) {print PAGER 's'}
  0         0  
485            
486 27 100       1308 print PAGER " ", join(', ', split(' ', $P_VALID_VALUES{$p})), ", keyend" if $type =~ /^key$/;
487            
488 27         46 my($ref);
489 27 50       48 if (defined $lref_Opt) {
490 0         0 $ref = \$lref_Opt->{$p};
491 0 0       0 $ref = \@{$lref_Opt->{$p}} if $list;
  0         0  
492             } else {
493 27         60 $ref = "${pkg}::opt_${p}";
494             }
495 27 100       52 if ($list) {
496 3 50       6 $def = defined @{$ref} ? 1 : 0;
  3         23  
497             } else {
498 24 100       34 $def = defined ${$ref} ? 1 : 0;
  24         121  
499             }
500            
501 27 100 66     169 if ($required =~ /^O$/ or $def == 1) { # if $optional or defined
    50          
502            
503 24 100       42 if ($def == 0) { # undefined and $optional
504 3         14 print PAGER "\n";
505             } else { # defined (either $optional or $required), display the default value(s)
506 21 100       39 if ($list) {
507 3 50       11 print PAGER $P_ENV{$p} ? " = $P_ENV{$p}, " : " = ";
508 3 50       14 print PAGER $is_string ? "(\"" : "(", $is_string ? join('", "', @{$ref}) : join(', ', @{$ref}), $is_string ? "\")\n" : ")\n";
  0 50       0  
  3 50       24  
509             } else { # not 'list of'
510 18 100       229 print PAGER $P_ENV{$p} ? " = $P_ENV{$p}, " : " = ";
511 18 100       34 print PAGER $is_string ? "\"" : "", ${$ref}, $is_string ? "\"\n" : "\n";
  18 100       101  
512             } # ifend 'list of'
513             } # ifend
514            
515             } elsif ($required =~ /R/) {
516 3 50       13 print PAGER $P_ENV{$p} ? " = $P_ENV{$p}, " : " = ";
517 3         5 print PAGER "\$required\n";
518             } else {
519 0         0 print PAGER "\n";
520             } # ifend $optional or defined parameter
521            
522 27 100       88 if ($full_help) {
523 9 50       59 if (defined $parameter_help{$p}) {
524 9         38 print PAGER "$parameter_help{$p}";
525             } else {
526 0         0 print PAGER "\n";
527             }
528             }
529            
530             } # forend ALL_PARAMETERS
531              
532 3 50       46 if ($file_list =~ /$pdt_reg_exp5/) {
    0          
533 3         13 print PAGER "$evap_Help_Hooks{'P_HHBOFL'}";
534             } elsif ($file_list =~ /$pdt_reg_exp6/) {
535 0         0 print PAGER "$evap_Help_Hooks{'P_HHBRFL'}";
536             } else {
537 0         0 print PAGER "$evap_Help_Hooks{'P_HHBNFL'}";
538             }
539              
540 3         2131 close PAGER;
541 3 50       15 if ($evap_embed) {
542 3         571 return -1;
543             } else {
544 0         0 exit 0;
545             }
546            
547             } # ifend help requested
548              
549             # Evaluate remaining unspecified command line parameters. This has been
550             # deferred until now so that if -help was requested the user sees
551             # unevaluated boolean, file and backticked values.
552              
553 3         6 foreach $parameter (@P_PARAMETER) {
554 30 100 100     170 if (not $P_EVALUATE{$parameter} and $P_DEFAULT_VALUE{$parameter}) {
555 14         152 ($required, $type, $list) = ($P_INFO{$parameter} =~ /$pdt_reg_exp1/);
556 14 50       44 if ($type ne 'w') {
557 14 100       28 $list = 2 if $list; # force re-initialization of the list
558 14         49 evap_set_value 1, $type, $list, $P_DEFAULT_VALUE{$parameter}, $parameter;
559             } # ifend non-switch
560             } # ifend not specified
561             } # forend all PDT parameters
562              
563             # Store program name for caller.
564              
565 3         28 evap_set_value 0, 'w', '', $0, 'help';
566            
567             # Ensure all $required parameters have been specified on the command line.
568              
569 3         87 foreach $p (@P_REQUIRED) {
570 1         38 print STDERR "Parameter $p is required but was omitted.\n";
571 1         7 $error++;
572             } # forend
573            
574             # Ensure any required files follow, or none do if that is the case.
575              
576 3 50 33     96 if ($file_list =~ /$pdt_reg_exp4/ and $#ARGV > 0 - 1) {
    50 33        
577 0         0 print STDERR "$evap_Help_Hooks{'P_HHENFL'}";
578 0         0 $error++;
579             } elsif ($file_list =~ /$pdt_reg_exp6/ and $#ARGV == 0 - 1) {
580 0         0 print STDERR "$evap_Help_Hooks{'P_HHERFL'}";
581 0         0 $error++;
582             }
583            
584 3 100       23 print STDERR "Type $0 -h for command line parameter information.\n" if $error;
585              
586 3 50 66     33 exit 1 if $error and not $evap_embed;
587 3 100       22 if (not $error) {
588 2         113 return 1;
589             } else {
590 1         126 return 0;
591             }
592            
593             } # end evap_fin
594              
595             sub evap_PDT_error {
596              
597             # Inform the application developer that they've screwed up!
598              
599 0     0   0 my($msg) = @_;
600              
601 0         0 print STDERR "$msg";
602 0         0 $error++;
603 0         0 next OPTIONS;
604              
605             } # end evap_PDT_error
606              
607             sub evap_set_value {
608            
609             # Store a parameter's value; some parameter types require special type
610             # conversion. Store values the old way in scalar/list variables of the
611             # form $opt_parameter and @opt_parameter, as well as the new way in hashes
612             # named %options and %Options. 'list of' parameters are returned as a
613             # reference in %options/%Options (a simple list in @opt_parameter). Or,
614             # just stuff them in a user hash, is specified.
615             #
616             # Evaluate items in grave accents (backticks), boolean and files if
617             # `evaluate' is TRUE.
618             #
619             # Handle list syntax (item1, item2, ...) for 'list of' types.
620             #
621             # Lists are a little weird as they may already have default values from the
622             # PDT declaration. The first time a list parameter is specified on the
623             # command line we must first empty the list of its default values. The
624             # P_INFO list flag thus can be in one of three states: 1 = the list has
625             # possible default values from the PDT, 2 = first time for this command
626             # line parameter so empty the list and THEN push the parameter's value, and
627             # 3 = just keep pushing new command line values on the list.
628              
629 77     77   205 my($evaluate, $type, $list, $v, $hash_index) = @_;
630 77         242 my($option, $hash1, $hash2) = ("${pkg}::opt_${hash_index}",
631             "${pkg}::options", "${pkg}::Options");
632 77         100 my($value, @values);
633              
634 77 100       489 if ($list =~ /^2$/) { # empty list of default values
635 3 100       23 if (defined $lref_Opt) {
636 1         9 $lref_Opt->{$hash_index} = [];
637             } else {
638 1     1   9 no strict 'refs';
  1         2  
  1         585  
639 2         6 @{$option} = ();
  2         17  
640 2         5 $hash1->{$hash_index} = \@{$option};
  2         12  
641 2         5 $hash2->{$hash_index} = \@{$option};
  2         11  
642             }
643             }
644              
645 77 100 100     292 if ($list and $v =~ /^\(+.*\)+$/) { # check for list
646 8         1488 @values = eval "$v"; # let Perl do the walking
647             } else {
648              
649             # Original line
650             # $v =~ s/["|'](.*)["|']/$1/s; # remove any bounding superfluous quotes
651              
652             ##########################################################################
653             # Avner Moshkovitz changed (on 29 Apr 2009):
654             # ^\s* to force the leading quotes to be in the beginning of the string
655             # \s$ to force the trailing quotes to be in the end of the string
656             # /s as a substitution option to match only at the end of the string
657             # rather then at the end of the line
658             #
659             # /s without /m will force ``^'' to match only at the beginning of the
660             # string and ``$'' to match only at the end (or just before a newline at the end)
661             # of the string
662             ##########################################################################
663              
664             # The need came when ingesting a string with multiple lines, such as the
665             # -analyzers argument in the example below:
666             #
667             # /opt/cvi/SENSNET/lib/ExpLhlSensorActivityEvaluator.pl -v -minSensorActivityTime 4 -analyzers '
668             #
669             #
670             #
671             # 2
672             #
673             # '
674             #
675             # In this case the leading eand trailing quotes were already removed by perl before even calling the
676             # EvaP module, as shown below:
677             #
678             # Cmd line params: -v -minSensorActivityTime 4 -analyzers
679             #
680             #
681             #
682             # 2
683             #
684             #
685             #
686             # Before the change the first double quotes in the first line (i.e. the double quotes "1.0 ... -8" )
687             # where removed resulting in the next line:
688             # version="1.0" encoding="UTF-8"?
689             # After the change there is no change in the string and the quotes are not deleted
690              
691              
692 69         186 $v =~ s/^\s*["|'](.*)["|']\s*$/$1/s; # remove any bounding superfluous quotes
693              
694              
695 69         285 @values = $v; # a simple scalar
696             } # ifend initialize list of values
697              
698 77         166 foreach $value (@values) {
699              
700 93 100       198 if ($evaluate) {
701 36         108 $P_EVALUATE{$hash_index} = 'evaluated';
702 36         152 $value =~ /^(`*)([^`]*)(`*)$/; # check for backticks
703 36 100 66     9219 chop($value = `$2`) if $1 eq '`' and $3 eq '`';
704 36 100 66     251 if (not $evap_DOS and $type =~ /^f$/) {
705 3         15 my(@path) = split /\//, $value;
706 3 50       29 if ($value =~ /^stdin$/) {
    100          
    50          
707 0         0 $value = '-';
708             } elsif ($value =~ /^stdout$/) {
709 2         5 $value = '>-';
710             } elsif ($path[0] =~ /(^~$|^\$HOME$)/) {
711 0         0 $path[0] = $ENV{'HOME'};
712 0         0 $value = join '/', @path;
713             }
714             } # ifend file type
715              
716 36 100       117 if ($type =~ /^b$/) {
717 3 100       37 $value = '1' if $value =~ /$pdt_reg_exp2/i;
718 3 100       28 $value = '0' if $value =~ /$pdt_reg_exp3/i;
719             } # ifend boolean type
720             } # ifend evaluate
721              
722 93 100       180 if ($list) { # extend list with new value
723 27 100       76 if (defined $lref_Opt) {
724 6         9 push @{$lref_Opt->{$hash_index}}, $value;
  6         28  
725             } else {
726 1     1   8 no strict 'refs';
  1         2  
  1         80  
727 21         40 push @{$option}, $value;
  21         81  
728 21         41 $hash1->{$hash_index} = \@{$option};
  21         84  
729 21         42 $hash2->{$hash_index} = \@{$option};
  21         127  
730             }
731             } else { # store scalar value
732 66 100       121 if (defined $lref_Opt) {
733 14         100 $lref_Opt->{$hash_index} = $value;
734             } else {
735 1     1   4 no strict 'refs';
  1         2  
  1         807  
736 52         65 ${$option} = $value;
  52         359  
737 52         189 $hash1->{$hash_index} = $value;
738 52         390 $hash2->{$hash_index} = $value;
739             # ${$hash2}{$hash_index} = $value; EQUIVALENT !
740             }
741             }
742              
743             } # forend
744            
745             } # end evap_set_value
746              
747             sub evap_isatty {
748              
749 0     0 0   my $in = shift;
750 0           my $s = -t $in;
751 0           return $s;
752              
753             }
754              
755             sub evap_pac {
756              
757 0     0 0   eval {
758 0           require Term::ReadLine;
759             };
760 0           my $noReadLine = $@;
761              
762             # Process Application Commands - an application command can be envoked by entering either its full spelling or the alias.
763              
764 0           my($prompt, $I, %cmds) = @_;
765              
766 0 0         $noReadLine = 1 if not evap_isatty( $I );
767              
768 0           my($proc, $args, %long, %alias, $name, $long, $alias);
769 0           my $pkg = (caller)[0];
770 0 0         my $inp = ref($I) ? $I : "${pkg}::${I}";
771              
772 0           $evap_embed = 1; # enable embedding
773 0 0 0       $shell = (defined $ENV{'SHELL'} and $ENV{'SHELL'} ne '') ?
774             $ENV{'SHELL'} : '/bin/sh';
775 0           foreach $name (keys %cmds) {
776 0           $cmds{$name} = $pkg . '::' . $cmds{$name}; # qualify
777             }
778 0           $cmds{'display_application_commands|disac'} = 'evap_disac_proc(%cmds)';
779 0           $cmds{'!'} = 'evap_bang_proc';
780              
781             # First, create new hash variables with full/alias names.
782              
783 0           foreach $name (keys %cmds) {
784 0 0         if ($name =~ /\|/) {
785 0           ($long, $alias) = ($name =~ /(.*)\|(.*)/);
786 0           $long{$long} = $cmds{$name};
787 0           $alias{$alias} = $cmds{$name};
788             } else {
789 0           $long{$name} = $cmds{$name};
790             }
791             }
792              
793 0           my ( $term, $out );
794 0 0         if ( $noReadLine ) {
795 0           print STDOUT "$prompt";
796             } else {
797 0           $term = Term::ReadLine->new( $prompt );
798 0   0       $OUT = $term->OUT || \*STDOUT;
799             }
800 0           my $eofCount = $ENV{IGNOREEOF};
801 0 0         $eofCount = 0 unless defined $eofCount;
802              
803 1     1   7 no strict 'refs';
  1         3  
  1         1730  
804             GET_USER_INPUT:
805 0           while ( 1 ) {
806 0 0         if ( $noReadLine ) {
807 0           $_ = <$inp>;
808             } else {
809 0           $_ = $term->readline( $prompt );
810             }
811 0 0         if ( not defined $_ ) {
812 0           $eofCount--;
813 0 0         last if $eofCount < 0;
814 0           print "\n";
815 0           next GET_USER_INPUT;
816             }
817 0 0         next GET_USER_INPUT if /^\s*$/; # ignore empty input lines
818              
819 0 0         if (/^\s*!(.+)/) {
820 0           $_ = '! ' . $1;
821             }
822              
823 0           ($0, $args) = /\s*(\S+)\s*(.*)/;
824 0 0         if ( $0 =~ m/^help$|^h$/i ) {
825 0           $0 = 'disac';
826 0           $args = '-do f';
827             }
828 0 0         if (defined $long{$0}) {
    0          
829 0           $proc = $long{$0};
830             } elsif (defined $alias{$0}) {
831 0           $proc = $alias{$0};
832             } else {
833 0           print STDERR <<"end_of_ERROR";
834             Error - unknown command '$0'. Type 'help' for a list of valid application commands. You can then type 'xyzzy -h' for help on application command 'xyzzy'.
835             end_of_ERROR
836 0           next GET_USER_INPUT;
837             }
838              
839 0 0         if ($0 eq '!') {
840 0           @ARGV = $args;
841             } else {
842 0           @ARGV = Text::ParseWords::quotewords( '\s+', 0, $args );
843             }
844              
845 0 0 0       if ( ($proc =~ m/^evap_(.*)_proc/) or exists &$proc ) {
846 0           eval "&$proc;"; # call the evap/user procedure
847 0 0         print STDERR $EVAL_ERROR if $EVAL_ERROR;
848             } else {
849 0           print STDERR "Procedure '$proc' does not exist in your application and cannot be called.\n";
850             }
851              
852 0           @ARGV = ();
853              
854             } # whilend GET_USER_INPUT
855             continue { # while GET_USER_INPUT
856 0 0         print STDOUT "$prompt" if $noReadLine;
857             } # continuend
858 0 0         print STDOUT "\n" unless $prompt eq "";
859              
860             } # end evap_pac
861              
862             sub evap_bang_proc {
863            
864             # Issue commands to the user's shell. If the SHELL environment variable is
865             # not defined or is empty, then /bin/sh is used.
866              
867 0     0 0   my $cmd = $ARGV[0];
868              
869 0 0         if ($cmd ne '') {
870 0           $bang_proc_MM = <<"END";
871             !
872              
873             Bang! Issue one or more commands to the shell. If the SHELL environment variable is not defined or is empty, then /bin/sh is used.
874              
875             Examples:
876              
877             !date
878             !del *.o; ls -al
879             END
880 0           $bang_proc_PDT = <<"END";
881             PDT !
882             PDTEND optional_file_list
883             END
884 0           $evap_Help_Hooks{'P_HHUOFL'} = " Command(s)\n";
885 0           $evap_Help_Hooks{'P_HHBOFL'} = "\nA list of shell Commands.\n\n";
886 0           @bang_proc_MM = split /\n/, $bang_proc_MM;
887 0           @bang_proc_PDT = split /\n/, $bang_proc_PDT;
888 0 0         if (EvaP(\@bang_proc_PDT, \@bang_proc_MM) != 1) {return;}
  0            
889 0           system "$shell -c '$cmd'";
890             } else {
891 0           print STDOUT "Starting a new `$shell' shell; use `exit' to return to this application.\n";
892 0           system $shell;
893             }
894              
895             } # end evap_bang_proc
896              
897             sub evap_disac_proc {
898            
899             # Display the list of legal application commands.
900              
901 0     0 0   my(%commands) = @_;
902 0           my(@brief, @full, $name, $long, $alias);
903 0           $disac_proc_MM = <<"END";
904             display_application_commands, display_application_command, disac
905              
906             Displays a list of legal commands for this application.
907              
908             Examples:
909              
910             disac # the `brief' display
911             disac -do f # the `full' display
912             .display_option
913             Specifies the level of output desired.
914             .output
915             Specifies the name of the file to write information to.
916             END
917 0           $disac_proc_PDT = <<"END";
918             PDT disac
919             display_option, do: key brief, full, keyend = brief
920             output, o: file = stdout
921             PDTEND no_file_list
922             END
923 0           @disac_proc_MM = split /\n/, $disac_proc_MM;
924 0           @disac_proc_PDT = split /\n/, $disac_proc_PDT;
925 0 0         if (EvaP(\@disac_proc_PDT, \@disac_proc_MM) != 1) {return;}
  0            
926              
927 0           my $len = 1;
928 0           foreach $name (keys %commands) {
929 0 0         if ($name =~ /\|/) {
930 0           ($long, $alias) = ($name =~ /(.*)\|(.*)/);
931             } else {
932 0           $long = $name;
933 0           $alias = '';
934             }
935 0           my $l = length $long;
936 0 0         $len = $l if $l > $len;
937             }
938 0           foreach $name (keys %commands) {
939 0 0         if ($name =~ /\|/) {
940 0           ($long, $alias) = ($name =~ /(.*)\|(.*)/);
941             } else {
942 0           $long = $name;
943 0           $alias = '';
944             }
945 0           push @brief, $long;
946 0 0         push @full, ($alias ne '') ? sprintf("%-${len}s, %s", $long, $alias) : "$long";
947             }
948              
949 0           open H, ">$Options{'output'}";
950 0 0         if ($Options{'display_option'} eq 'full') {
951 0           print H "\nFor help on any application command (or command alias) use the -h switch. For example, try 'disac -h' for help on 'display_application_commands'.\n";
952 0           print H "\nCommand and alias list for this application:\n\n";
953 0           print H " ", join("\n ", sort(@full)), "\n";
954             } else {
955 0           print H join("\n", sort(@brief)), "\n";
956             }
957 0           close H;
958              
959             } # end evap_disac_proc
960              
961             #sub evap_setup_for_evap {
962             #
963             # # Initialize evap_pac's builtin commands' PDT/MM variables.
964             #
965             # my($command) = @_;
966             #
967             # open IN, "ar p $message_modules ${command}_pdt|";
968             # eval "\@${command}_proc_PDT = ;";
969             # close IN;
970             #
971             # open IN, "ar p $message_modules ${command}.mm|";
972             # eval "\@${command}_proc_MM = grep \$@ = s/\n\$//, ;";
973             # close IN;
974             #
975             #} # end evap_setup_for_evap
976              
977             1;
978             __END__