AssertNonEmptyFile(@a_opt)
ParamParser - parse parameters from different sources (CGI.pm, GetOpt, cgi-lib, configuration file, ARGV, ENV)
1. parameter source defined from a configuration file use ParamParser; $rh_param = New ParamParser($filename);
------ example.cfg ------- # lines starting with # are ignored OPTION=value of the option --------------------------
2. from ARGV use ParamParser; $rh_param = New ParamParser('ARGV');
% program OPTION1="value of the option" OPTION2=value 3. from environment variables use ParamParser; $rh_param = New ParamParser('ENV'); or $rh_param = New ParamParser('ENV','prefix'); to add a tag to environment variables
4. from CGI object use CGI; use ParamParser; $rh_param = New ParamParser('CGIPM');
5. from CGI-LIB data structure (version 2) require "cgi-lib2.pl"; use ParamParser; $rh_param = New ParamParser('CGILIB');
6. from Getopt::Std object use Getopt::Std; use ParamParser; $rh_param = New ParamParser('GETOPTSTD',"list_of_singlet-character_switches");
run the command man Getopt::Std to see what is "list_of_singlet-character_switches" to use the same options with the current module you must write $rh_param = New ParamParser('GETOPTSTD',"oif:"); $rh_param = New ParamParser('GETOPTSTD',"oDI");
7. from Getopt::Long object use Getopt::Long; use ParamParser; $rh_param = New ParamParser('GETOPTLONG',(list_of_getoptlong_option));
run the command man Getopt::Long to see what is a "list_of_getoptlong_option" to use the same options with the current module you must write $rh_param = New ParamParser('GETOPTLONG',("length=i","file=s","verbose"));
8. from another ParamParser object use ParamParser; $rh_param = New ParamParser('PARAMPARSER',$rh_other_param); 9. from a hash use ParamParser; $rh_param = New ParamParser('HASH',\%some_hash);
use CGI qw/:standard/; use ParamParser;
my $o_param = New ParamParser("CGIPM");
# attach an usage fonction to the parser # the best way would be to reference a real fonction $o_param->SetUsage(my $usage=sub { &UsageFct(); } ); $o_param->SetUsage(my $usage=sub { print "\nPlease read the documentation\n"; } );
# add a single variable to the data structure $o_param->Set('TIMEOUT','10000');
# append all environment variables in overwrite mode (overwrite duplicates) $o_param->Update('ENV',"O");
# check that the value of the parameter CFG is an existing file, print the usage and exit if it is not. $o_param->AssertFileExists('CFG');
# add all variables contained in the configuration file in append mode (do not overwrite duplicates) $o_param->Update($o_param->Get('CFG'),"A");
print header; $o_param->Print('html');
use Getopt::Long; use ParamParser;
my $o_param = New ParamParser('GETOPTLONG',("help:s","min=i","max=i","inputfile=s","what=s"));
# attach an usage fonction to the parser # the best way is to reference a real fonction $o_param->SetUsage(my $usage=sub { &UsageFct(); } ); $o_param->SetUsage(my $usage=sub { print "\nPlease read the documentation\n"; } );
# append all environment variables in append mode (do not overwrite duplicates) $o_param->Update('ENV',"A");
# check that the value of the parameter inputfile is an existing file, print the usage and exit if it is not. $o_param->AssertFileExists('inputfile');
# check that the value of the parameters are integers, print the usage and exit if one of them is not. $o_param->AssertInteger('max','min');
# check that the value of the parameter what is a correct value $o_param->AssertAllowedValue('what','yes','no','maybe');
# check that the value of the parameter what is a correct value (more restrictive: only 1 char) $o_param->AssertAllowedValue('what','[yYnN01]');
# check that the value of the parameters is a correct value, matching one of those patterns $o_param->AssertAllowedPattern('^[wW]hat$','^[yY]es', '^[nN]o','^maybe$');
# check each key's value for a list of allowed characters $o_param->AssertAllowedValueForEachKey('[0-9a-z]+');
# check that each key's value starts with a lower-case letter $o_param->AssertAllowedPatternForEachKey('^[a-z]');
$o_param->Print();
Title : New Usage : my $o_param = New ParamParser(); my $o_param = New ParamParser('CGIPM'); my $o_param = New ParamParser('GETOPTLONG','some_switch','some_int=i','some_string=s'); (perldoc Getopt::Long for the details) my $o_param = New ParamParser('some_file'); my $o_param = New ParamParser('PARAMPARSER',$o_another_param); my $o_param = New ParamParser('HASH',\%h_parameters); Function : constructor of the object Returns : a valid object Args : $source (optional) The source of the parameters CGIPM|CGILIB|GetOptStd|GetOptLong|ARGV|$filename|HASH|ENV other prms (optional) following $source Globals : none
Title : Update Usage : $o_param->Update($source,$mode,@options); Procedure : Updates the parameters Args : $source The source to update from INIT|CGIPM|CGILIB|GetOptStd|GetOptLong|ARGV|$filename|HASH|ENV If $source if not defined, we try to automaticcaly detect a data source. On a given configuration the behaviour is always the same, but the behaviour is unpredictable from machine to machine The consequence is that New ParamParser() may be somewhat unpredictable, you may rather want New ParamParser('INIT'); $mode I init : clean the data structure first A Append : preserve the previous value of duplicate keys O Overwrite: replace the value of a duplicate key @options other prms (optional) following $source Globals : none
Title : Dump Usage : $o_param->Dump($filename [,$prefix]); $o_param->Dump('ENV' [,$prefix]); $o_param->Dump('GETOPTLONG'[,$prefix]); $o_param->Dump('HASH',$rh_output [,$prefix]); Procedure : Dumps the parameters to some target (a file for example) Args : $target (required) The target used for dumping $filename|ENV|GetOptLong|HASH $rh_output (required if target eq 'HASH') The hash used to dump to $prefix (optional) A prefix to write BEFORE each parameter name Globals : none
Title : SelectNameSpace Usage : $o_param->SelectNameSpace('SOME_PREFIX'); $o_param->SelectNameSpace(); Procedure : Select a prefix for each parameter name, it will be used for Get/Set operations Args : $ns the name space to use from this point If not specified, do not use any namespace Globals : none
Title : Init Usage : $o_param->Init(); $o_param->Update('I'); Procedure : Initialize the parameters NOTE - THE NAMESPACE IS NOT INITIALIZED This looks strange, but if we decide to reinitialize NAMESPACE, there will be an impact of the applications. Args : none
Title : Set Usage : $o_param->Set($key,$value); Procedure : Set the value of a single parameter Args : $key Parameter name - If using a name space, Set will prefix the name with the name space $value Parameter value - Will be subsituted and checked for security if necessary TODO : Passer plusieurs valeurs et utiliser &SEPARATOR (cf. __UndateIfPossible) APPELER __SecurityControl CORRIGER LE BUG
Title : SetUnlessDefined Usage : $o_param->SetUnlessDefined($opt,$value); Procedure : Call Set only if the opt is NOT already defined Args : $opt Parameter name - If using a name space, SetUnlessDefined will prefix the name with the name space $value Parameter value - Will be subsituted and checked for security if necessary
Title : Delete Usage : $o_param->Delete($opt) Procedure : Delete the parameter Args : $opt Parameter name - If using a name space, Delete will prefix the name with the name space
Title : Get Usage : my $value = $o_param->Get($opt); my @value = $o_param->Get($opt); my @value = $o_param->Get($opt1,$opt2,...); function : 1- Return the value of the $opt key 2- Return the value of the $opt key as a singleton array 3- Return the value of the keys as an array Args : $opt,... Parameter(s) name(s) - If using a name space, Get will prefix the name with the name space return : the parameter value(s) if defined or "" (NEVER return undef)
Title : GetInteger Usage : my $value = $o_param->GetInteger($opt); my @value = $o_param->GetInteger($opt); my @value = $o_param->GetInteger($opt1,$opt2,...); function : 1- Call AssertInteger and return the value of the $opt key 2- Call AssertInteger and return the value of the $opt key as a singleton array 3- Call AssertInteger and return the value of the keys as an array Args : $opt,... Parameter(s) name(s) - If using a name space, Get will prefix the name with the name space return : the parameter value(s) if defined or 0 (NEVER return undef) behaviours: assert_strict
Title : GetKeys Usage : my @keys = $o_param->GetKeys('pattern'); function : Return the the list of keys matching with: -The namespace prefix is a namespace is defined -The pattern if a pattern is passed Args : $pattern (optional) The pattern - If not specified each key is considered to match return : An array of matching keys, WITHOUT THEIR NAMESPACES
Title : IsDefined Usage : if ($o_param->IsDefined($opt)... function : Return true if the opt is defined IN THE NAMESPACE, false if not Args : $opt The opt to test for definition return : true/false
Title : HowMany Usage : my $nb = $o_param->HowMany(); function : Return the number of parameters Args : none return : the number of parameters
Title : GetSource Usage : my $srce = $o_param->GetSource(); function : Return the last source used for updating the parameters Args : none return : the last source
Title : SetSubstitution Usage : $o_param->SetSubstitution($pattern,$ref) procedure : Add en entry in the substitution table Args : $pattern The pattern (%a-%z,%A-%Z,%0-%9) to substitute $ref The ref (to a scalar or to a function) or value to subsitute with
Title : Print Usage : $o_param->Print(); $o_param->Print('html'); procedure : Print all the paramters and their values Args : 'html' (optional) Print through an html table
Title : SetBehaviour Usage : $o_param->SetBehaviour('some_behaviour') procedure : Set a behaviour Args : $behaviour The behaviour to set NOTES: -If the behaviour passed by parameter does not exist, the method is silently ignored -If the behaviour is 'use_substitution_table', the substitutions are automatically performed
Title : UnsetBehaviour Usage : $o_param->UnsetBehaviour('some_behaviour') procedure : Unset a behaviour Args : $behaviour The behaviour to unset NOTE If the behaviour passed by parameter does not exist, the method is silently ignored (thus nothing happens)
Title : GetBehaviour Usage : if($o_param->GetBehaviour('some_behaviour'))... procedure : Get the status of some behaviour Args : $behaviour The behaviour to get NOTE If the behaviour passed by parameter does not exist, the method returns FALSE
Title : SetDefaultBehaviour Usage : ParamParser::SetBehaviour('some_behaviour'); procedure : This is NOT a method, this is an ordinary function Set the default status of some behaviour Args : $behaviour The behaviour to set NOTE If the behaviour passed by parameter does not exist, the method is silently ignored (thus nothing happens)
Title : UnsetDefaultBehaviour Usage : ParamParser::UnsetDefaultBehaviour('some_behaviour') procedure : This is NOT a method, this is an ordinary function Unset the default status of some behaviour Args : $behaviour The behaviour to unset NOTE If the behaviour passed by parameter does not exist, the method is silently ignored (thus nothing happens)
Title : GetDefaultBehaviour Usage : ParamParser::GetDefaultBehaviour('some_behaviour'))... procedure : Get the Default status of some behaviour Args : $behaviour The behaviour to get NOTE If the behaviour passed by parameter does not exist, the method returns FALSE
Title : AssertFullPath Usage : $o_param->AssertFullPath(@a_opt); procedure : throw an exception unless every element of the array @a_opt is the full path of an existing file or dir Args : @a_opt A list of parameters to check
Title : AssertFileExists Usage : $o_param->AssertFileExists(@a_opt); procedure : throw an exception unless every element of the array @a_opt is the name of an existing file Args : @a_opt A list of parameters to check Behaviours: assert_strict and assert_empty_file_allowed
AssertNonEmptyFile(@a_opt)
Title : AssertNonEmptyFile Usage : $o_param->AssertNonEmptyFile(@a_opt); procedure : throw an exception unless every element of the array @a_opt refers to a non empty file Args : @a_opt A list of parameters to check Behaviours: none
Title : AssertDirExists Usage : $o_param->AssertDirExists(@a_opt); procedure : throw an exception unless every element of the array @a_opt is the name of an existing dir Args : @a_opt A list of parameters to check Behaviours: assert_strict =cut sub AssertDirExists { my ($self, @a_opt) = @_;
foreach my $opt (@a_opt) { my $key = $$self{'__name_space'} . $opt; my ($lfile) = $$self{'__h_opt'}{$key}; next if (!defined($lfile) && !$$self{'__h_behaviour'}{'assert_strict'}); if (!defined($lfile) || !-d $lfile) { &__PrintUsage($self); $lfile = &__DefinedIfNot($lfile); $self->__Die("\n=>The value of the parameter $opt is >$lfile< which is not a name of an existing directory","parameter"); } }
return 1; }
Title : AssertInteger Usage : $o_param->AssertInteger(@a_opt); procedure : throw an exception unless every element of the array @a_opt is an integer Args : @a_opt A list of parameters to check Behaviours: assert_strict =cut sub AssertInteger { my ($self, @a_opt) = @_;
foreach my $opt (@a_opt) { my $key = $$self{'__name_space'} . $opt; my ($lopt) = $$self{'__h_opt'}{$key}; next if (!defined($lopt) && !$$self{'__h_behaviour'}{'assert_strict'}); if (!defined($lopt) || $lopt !~ /^[\+\-]*\d+$/) { &__PrintUsage($self); $lopt = &__DefinedIfNot($lopt); $self->__Die("\n=>The value of the parameter $opt is >$lopt< which is not a valid integer value","parameter"); } } return 1; }
Title : AssertDefined Usage : $o_param->AssertDefined(@a_opt); procedure : throw an exception unless every element of the array @a_opt is defined Args : @a_opt A list of parameters to check Behaviours: none =cut sub AssertDefined { my ($self, @a_opt) = @_;
foreach my $opt (@a_opt) { my $key = $$self{'__name_space'} . $opt; my ($lopt) = $$self{'__h_opt'}{$key}; if (!defined($lopt)) { &__PrintUsage($self); $self->__Die("=>The parameter $opt must be provided","parameter"); } } return 1; }
Title : AssertallowedValue Usage : $o_param->AssertAllowedValue($a_opt,@a_regex); procedure : throw an exception unless the value of the passed parameter matches at least 1 *anchored* regex Args : $opt The parameter to check (ONLY ONE) @a_regex The regular expressions used for the match Behaviours: assert_strict NOTE : We test using a regex match, but the values entered ARE ANCHORED, so that this function is convenient to test a parameter agains a value, or a set of allowed characters, etc. If you want to test only if some value starts with some character, you should use AssertAllowedPattern instead
=cut sub AssertAllowedValue { my ($self, $opt, @a_list_of_allowed_values) = @_; my $key = $$self{'__name_space'} . $opt; my ($lvalue) = $$self{'__h_opt'}{$key}; if (defined($lvalue)) { foreach my $one_value (@a_list_of_allowed_values) { if ($lvalue =~ /^$one_value$/) { return 1; } } } else { if (!$$self{'__h_behaviour'}{'assert_strict'}) { return 1; } } &__PrintUsage($self); my ($allowed) = join(',', @a_list_of_allowed_values); $lvalue = &__DefinedIfNot($lvalue);
#ce carp n'envoye rien dans le fichier de logs d'apache ! $self->__Die( "=>The current value of the parameter $opt is >$lvalue< which is not in the set of allowed values [$allowed]", 'parameter' ); }
Title : AssertAllowedValueForAllKeys Usage : $o_param->AssertAllowedValueForAllKeys(@a_regex); procedure : Call AssertAllowedValue for every parameter Args : @a_regex The regular expressions used for the match Behaviours: assert_strict =cut sub AssertAllowedValueForAllKeys { my ($self, @a_list_of_allowed_patterns) = @_;
foreach my $key ($self->GetKeys()) { $self->AssertAllowedValue($key, @a_list_of_allowed_patterns); } }
Title : AssertallowedPattern Usage : $o_param->AssertAllowedValue($a_opt,@a_regex); procedure : throw an exception unless the value of the passed parameter matches at least 1 regex Args : $opt The parameter to check (ONLY ONE) @a_regex The regular expressions used for the match Behaviours: assert_strict NOTE : This sub is *NEARLY* the same as AssertAllowedValue, EXCEPT THAT here we do not anchor the regex. You can use AssertAllowedPattern to check that some parameter STARTS WITH something =cut sub AssertAllowedPattern { my ($self, $value, @a_list_of_allowed_patterns) = @_;
my $key = $$self{'__name_space'} . $value; my ($lvalue) = $$self{'__h_opt'}{$key}; if (defined($lvalue)) { foreach my $one_pattern (@a_list_of_allowed_patterns) { if ($lvalue =~ /$one_pattern/) { return 1; } } } else { if (!$$self{'__h_behaviour'}{'assert_strict'}) { return 1; } } &__PrintUsage($self); my ($allowed) = join(',', @a_list_of_allowed_patterns); $lvalue = &__DefinedIfNot($lvalue); $self->__Die( "=>The current value of the parameter $value is >$lvalue< which is not in the set of allowed patterns [$allowed]", 'parameter' ); }
Title : AssertAllowedPatternsForAllKeys Usage : $o_param->AssertAllowedPatternsForAllKeys(@a_regex); procedure : Call AssertAllowedPatterns for every parameter Args : @a_regex The regular expressions used for the match Behaviours: assert_strict =cut sub AssertAllowedPatternForAllKeys { my ($self, @a_list_of_allowed_patterns) = @_;
foreach my $key ($self->GetKeys()) { $self->AssertAllowedPattern($key, @a_list_of_allowed_patterns); } }
Title : SetUsage Usage : $o_param->SetUsage(my $usage= sub { &my_usage_fct();} ); $o_param->SetUsage(\&main::Usage); $o_param->SetUsage('USAGE_DELAYED'); procedure: Attach an usage fonction to the ParamParser object (1st, 2nd call). Attach the private function UsageDelayed (3rd call). If called, this function just sets a flag; If, somewhat later, SetUsage is called with a real function reference, this function will be immediately called. This way, the call of the Usage function is somewhat delayed. This can be useful when some other objects need to be built before calling Usage. args : $f_fct_usage a ref to an usage function OR the string 'USAGE_DELAYED'
Title : SetDefaultUsage Usage : $o_param->SetUsage$o_param->SetUsage(my $usage= sub { &my_usage_fct();} ); $o_param->SetUsag$o_param->SetUsage(\&main::Usage); procedure: Attach a default usage fonction to the ParamParser module This function will be automagically set to the usage function for the new objects created from now
Title : Usage Usage : $o_param->Usage(); $o_param->Usage('html'); procedure : Print the usage of the program, calling the attached procedure, and exit with code 1 Args : $format If html, print a mini but complete html page Behaviours: none =cut sub Usage { my ($self, $format) = @_; my ($head) = ""; my ($tail) = "";
return if (exists $$self{'_usage_delayed'}); # Nothing to do if the usage is delayed if (defined($format) && $format =~ /html/i) { $head = "<html><head><title>$0</title></head><body><br><pre>"; $tail = "<br></pre></body></html>"; } print $head; &__PrintUsage($self); print $tail; exit 1; }
Title : Encode Usage : &ParamParser::Encode($parameters); Prerequiste: uuencode must be installed Function : Encode a $param if required THIS FUNCTION IS NOT A METHOD Returns : $params, encoded or not Args : $param, a string, generally an url formatted parameters globals : none
Title : Decode Usage : $query_string = &ParamParser::Decode(); Prerequiste: uudecode must be installed Function : Decode the $ENV{'QUERY_STRING'} if needed THIS FUNCTION IS NOT A METHOD Returns : the $ENV{'QUERY_STRING'} decoded Args : none globals : $ENV{QUERY_STRING} modified
Title : SetAuthorizedCharacters Usage : $o_param->SetAuthorizedCharacters('[A-Za-z0-9_]'); procedure : Set the behaviour assert_value_secure and change the authorized characters For CGI programs, assert_value_secure is activated by default and used at the parameter parsing level so to modify the set of AuthorizedCharacters you must do it in several steps my $o_param = New ParamParser(); # first init the object $o_param->SetAuthorizedCharacters('[A-Za-z]'); # then modify the list $o_param->Update('CGIPM','A'); # then read the parameters
The more common usage my $o_param = New ParamParser('CGIPM'); requires a set of allowed values and uses the default set of characters Args : $pattern A perl regex Behaviours: assert_value_secure is set =cut
sub SetAuthorizedCharacters { my ($self, $perlpattern) = @_;
$$self{'__authorized_characters'} = $perlpattern; $$self{'__h_behaviour'}{'assert_value_secure'} = 1;
}
Title : __SecurityControl Usage : $self->__Securitycontrol($opt,\@values); procedure : If $opt is some reserved parameter, just return If behaviour 'assert_value_secure' unset, return Else, check every value agains the authorized characters. If a mismatch is found, throw an exception or (in CGIPM only) return with a fake http code Args : $opt The parameter name $ra_values The array of values to check Access : private Behaviours: assert_value_securenone =cut sub __SecurityControl { my ($self, $item, $ra_values) = @_;
return if ($item =~ /__wb_url|__wb_cookie/); # related to WebBuilder if ($$self{'__h_behaviour'}{'assert_value_secure'}) { my $secure_char = $$self{'__authorized_characters'}; foreach my $val (@$ra_values) { if ($val !~ /^($secure_char*)$/) { if ($$self{'__last_source'} =~ /CGI/) { my $cgi = new CGI; my $error = &HTTP_ERROR_SECURITY; $secure_char =~ s/\///g; print $cgi->header(-status => $error), $cgi->start_html('Security Issue'), $cgi->h3( "ERROR 888 : The request is not processed due to insecure character in<br>key=$item<br>value=$val<br>allowed characters are $secure_char" ), $cgi->end_html; } $self->__Die("SECURITY ISSUE: Fatal error: the parameter >$item< is not secure enough (value=$val)\n",'parameter'); } } } }
Title : __CallUsageIfNeeded Usage : $self->__CallUsageIfNeeded() procedure : Call Usage if the 'help' parameter is defined Args : none Access : private =cut sub __CallUsageIfNeeded { my $self = shift; if ($self->IsDefined('help') or $self->IsDefined('HELP')) { return if (defined($$self{'__usage_delayed'}) && $$self{'__usage_delayed'} == 1); if ($$self{'__last_source'} =~ /CGI/i) { $self->Usage('html'); } else { $self->Usage(); } } }
Title : __UsageDelayed Usage : $self->__UsageDelayed() procedure : Set the internal flag '__usage_needed' Args : none Access : private =cut sub __UsageDelayed { my $self = shift; $$self{'__usage_needed'} = 1; # We shall call Usage when possible }
Title : __PrintUsage Usage : $self->__PrintUsage() procedure : Call the registered usage function Args : none Access : private =cut sub __PrintUsage { my $self = shift;
&{$$self{'__usage'}}($self); }
Title : __UpdateIfPossible Usage : $self->__UpdateIfPossible($opt,@values); procedure : Update the $opt parameter with 1 or several values If several values are specified, they are joined, using the constant &SEPARATOR, before updating the parameter value The parameter is updated or not, depending on the mode Args : $opt The parameter to update @values The parameter value(s) - MAY BE UNDEF ! Access : private Behaviours: use_substitution_table =cut sub __UpdateIfPossible { my ($self, $item, @values) = @_;
$self->__SecurityControl($item, \@values);
my $how = ($$self{'__mode'} eq "") ? "A" : $$self{'__mode'};
$item = $$self{'__name_space'} . $item; if ( !defined($$self{'__h_opt'}{$item}) # the key doesn't already exist || (defined($$self{'__h_opt'}{$item}) && $how eq 'O') ) # or the key already exists but the mode is 'O'verwrite { $$self{'__nb'}++; if (defined($values[0])) # at least one value { if (defined($values[1])) # more than one { if (!ref($values[1])) # only simple values that can be merged { $$self{'__h_opt'}{$item} = join(&SEPARATOR, @values); } else # but do not try merging complex data types { $$self{'__h_opt'}{$item} = \@values; } } else { $$self{'__h_opt'}{$item} = $values[0]; } } else { $$self{'__h_opt'}{$item} = undef; } }
if ($self->GetBehaviour('use_substitution_table')) { $self->__SubstituteKey($item); } return; }
Title : __ValidBehaviour Usage : if (&ValidBehaviour($behaviour)) ... function : Return true if the behaviour name is valid throw an exceptnio if the behaviour name is invalid THIS IS NOT A METHOD, THIS IS AN ORDINARY FUNCTION Args : $behaviour The behaviour to validate Access : private =cut sub __ValidBehaviour { my $behaviour = shift; return 1 if (exists $H_DEFBEHAVIOUR{$behaviour}); &ParamParser::__Die('',"\n=>The behaviour $behaviour is unknown",'parameter'); return 0; }
Title : __SubstituteKey Usage : $self->SubstituteKey($key); procedure : Try to make the substitutions for the key passed by parameter Args : $key The key whose value will be substituted Access : private =cut sub __SubstituteKey { my ($self, $key) = @_; return unless (defined($self->{'__h_opt'}{$key})); # If value not defined, nothing to substitute return unless (exists $self->{'__substitution_table'}); # If no table, nothing to substitute
my $rh_sub_table = $self->{'__substitution_table'}; my $to_subst = $self->{'__h_opt'}{$key}; return unless ($to_subst =~ /%/); # If no %, nothing to substitute
foreach my $s (keys(%$rh_sub_table)) { next unless ($to_subst =~ /$s/); my $r = $rh_sub_table->{$s}; if (ref($r) eq '') # Substitute if not a ref { $to_subst =~ s/$s/$r/g; } elsif (ref($r) eq 'SCALAR') # Substitute if ref to a scalar { $to_subst =~ s/$s/$$r/g; } elsif (ref($r) eq 'CODE') # Substitute, calling the sub, if ref to a sub { my $subst = &$r($self, $key); $to_subst =~ s/$s/$subst/g; # N.B. May be several substitutions, but only 1 call } }
$self->{'__h_opt'}{$key} = $to_subst; return; }
Title : __SubstituteAll Usage : $self->SubstituteAll(); procedure : Call __self->SubstitueKey for each parameter Args : none Access : private =cut sub __SubstituteAll { my $self = shift; foreach my $key (sort keys(%{$self->{'__h_opt'}})) { $self->__SubstituteKey($key); } }
Title : __FromGetOptStd Usage : $self->__FromGetOptStd($optlist); procedure : Initialize the ParamParser object using Getopt::Std style as source of param/values Args : $optlist used by getopts Access : private =cut sub __FromGetOptStd { my ($self, $optlist) = @_;
use Getopt::Std; my @a_backup = @ARGV;
our %options = (); &getopts($optlist, \%options);
#my $getopt_succeed = &getopts($optlist,\%options); #if ( ! $getopt_succeed && $$self{'__h_behaviour'}{'exit_on_getopt_error'} ) #{ # &Usage(); #} foreach my $key (keys(%options)) { &__UpdateIfPossible($self, $key, $options{$key}); }
@ARGV = @a_backup; # restore original parameters # -> can be parsed again is necessary # -> avoid side effect }
Title : __FromGetOptLong Usage : $self->__FromGetOptLong(@a_opt); procedure : Initialize the ParamParser object using Getopt::Long style as source of param/values Args : @a_opt used by GetOptions Access : private =cut sub __FromGetOptLong { my ($self, @a_opt) = @_;
use Getopt::Long; my @a_backup = @ARGV; my %h_options = (); my %h_value = ();
foreach my $key (@a_opt) { my $val = undef; $h_options{$key} = \$val; } my $getopt_succeed = &GetOptions(%h_options);
if (!$getopt_succeed && $$self{'__h_behaviour'}{'exit_on_getopt_error'}) { &Usage($self); }
foreach my $key (keys(%h_options)) { my (@F) = split(/[:=]/, $key); my ($real_key) = $F[0]; my $r_tmp = $h_options{$key}; if (defined($$r_tmp)) { &__UpdateIfPossible($self, $real_key, $$r_tmp); } }
@ARGV = @a_backup; # restore original parameters # -> can be parsed again is necessary # -> avoid side effect }
Title : __FromCGILIB Usage : $self->__FromCGILIB(@a_backup); procedure : Initialize the ParamParser object using CGI-LIB2 as source of param/value Args : @a_backup ??? Access : private =cut sub __FromCGILIB { my ($self, @a_backup) = @_;
@_ = @a_backup; my ($keyin);
if (defined(ref(&main::ReadParse))) { &main::ReadParse;
foreach $keyin (keys(%main::in)) { &__UpdateIfPossible($self, $keyin, $main::in{$keyin}); } } }
Title : __FromCGIPM Usage : $self->__FromCGIPM(@a_backup); procedure : Initialize the ParamParser object using CGI.pm as source of param/value Args : none Access : private =cut sub __FromCGIPM { my ($self) = @_; &ParamParser::Decode(); my ($cgi) = new CGI();
my $original_mode = $self->{'__mode'}; $self->{'__mode'} = 'M';
foreach my $key ($cgi->param()) { my @a_value = (); my $fh = &CGI::upload($key); if (defined($fh)) # required to not modify the type { $a_value[0] = $cgi->param($key); # the value is a filehandle or an array of filehandle } else # required to manage multiple selection on list { @a_value = $cgi->param($key); } &__UpdateIfPossible($self, $key, @a_value); } $self->{'__mode'} = $original_mode; }
Title : __Fromfile Usage : $self->__FromFile($source); procedure : Initialize the ParamParser object using a configuration file Args : $source The file name Access : private =cut sub __FromFile { my ($self, $source) = @_; my $lock_flg = $self->GetBehaviour('lock_file');
my ($lign) = "";
my $lock_file = $source . '.lock'; my $fh_lock_file; if ($lock_flg == 1) { $fh_lock_file = new IO::File("+>>$lock_file") or $self->__Die("Cannot open $lock_file"); fcntl($fh_lock_file, F_SETLKW, pack('ssx32', F_RDLCK, 0)) or $self->__Die("Can't put a read lock on $lock_file: $!",'io'); } my $fh_source = new IO::File($source) or $self->__Die("ERROR Cannot open >$source<",'io'); while ($lign = <$fh_source>) { next if ($lign =~ /^#/); chomp($lign); my (@F); if ($$self{'__h_behaviour'}{'ignore_space'}) { @F = split(/\s*=\s*/, $lign, 2); } else { @F = split('=', $lign, 2); } next if (!defined($F[0]) || !defined($F[1])); &__UpdateIfPossible($self, $F[0], $F[1]); } $fh_source->close(); if ($lock_flg == 1) { fcntl($fh_lock_file, F_SETLKW, pack('ssx32', F_UNLCK, 0)) or $self->__Die("Can't release the read lock on $lock_file: $!",'io'); $fh_lock_file->close(); } }
Title : __FromARGV Usage : $self->__FromARGV(); procedure : Initialize the ParamParser object using @ARGV array as source of param/value Args : none Access : private =cut sub __FromARGV { my ($self) = @_;
foreach my $option (@ARGV) { my (@F) = split('=', $option, 2); next if (!defined($F[0]) || !defined($F[1])); &__UpdateIfPossible($self, $F[0], $F[1]); } }
Title : __FromENV Usage : $self->__FromENV(); procedure : Initialize the ParamParser object using the %ENV hash as source of param/value Args : none Access : private =cut sub __FromENV { my ($self) = @_;
foreach my $option (keys(%ENV)) { next if (!defined($option) || !defined($ENV{$option})); &__UpdateIfPossible($self, $option, $ENV{$option}); } }
Title : __FromPARAMPARSER Usage : $self->__FromPARAMPARSER($o_param); procedure : Initialize the ParamParser object using another ParamParser object Args : $o_param The other ParamParser object Access : private =cut sub __FromPARAMPARSER { my $self = shift; my $o_p = shift; my ($keyin);
my $rh_opt = $o_p->{'__h_opt'}; # The parameters from the other ParamParser object foreach $keyin (keys(%$rh_opt)) { &__UpdateIfPossible($self, $keyin, $rh_opt->{$keyin}); } }
Title : __FromHASH Usage : $self->__FromHASH(@a_backup); procedure : Initialize the ParamParser object using a hash Args : $rh_p the hash Access : private =cut sub __FromHASH { my $self = shift; my $rh_p = shift;
foreach my $keyin (keys(%$rh_p)) { &__UpdateIfPossible($self, $keyin, $rh_p->{$keyin}); } }
Title : __ToFile Usage : $self->__ToFile($target,$prefix) procedure : Dump the paramparser into a file Args : $target The file name $prefix Add a prefix to the key, unless already added (write to a namespace) Access : private =cut sub __ToFile { my ($self, $target, $prefix) = @_; my $ns = $$self{'__name_space'}; my $lock_file = $target . '.lock'; my $lock_flg = $self->GetBehaviour('lock_file'); my $fh_lock_file; if ($lock_flg == 1) { $fh_lock_file = new IO::File(">>$lock_file") or $self->__Die ("ERROR - Can't put a read lock on $lock_file: $!",'io'); fcntl($fh_lock_file, F_SETLKW, pack('ssx32', F_WRLCK, 0)) or die "Can't put a read lock on $lock_file: $!"; } my $fh_target = new IO::File(">$target") or $self->__Die("ERROR Can't open >$target< for writing\n",'io'); foreach my $key (sort keys(%{$$self{'__h_opt'}})) { if (defined($key) && defined($$self{'__h_opt'}{$key}) && $key =~ /^$ns/) { if ($prefix ne "" && $key !~ /^$prefix/) { my $nkey = "$prefix$key"; print $fh_target "$nkey=" . $$self{'__h_opt'}{$key} . "\n"; } else { print $fh_target "$key=" . $$self{'__h_opt'}{$key} . "\n"; } } } $fh_target->close(); if ($lock_flg == 1) { fcntl($fh_lock_file, F_SETLKW, pack('ssx32', F_UNLCK, 0)) or $self->__Die ("Can't release the read lock on $lock_file: $!",'io'); $fh_lock_file->close(); unlink($lock_file); # Forcing a cache reload with nfs } }
Title : __ToENV Usage : $self->__ToENV($prefix) procedure : Dump the paramparser into the environment Args : $prefix Add a prefix to the key, unless already added (write to a namespace) Access : private =cut sub __ToENV { my ($self, $prefix) = @_; my $ns = $$self{'__name_space'};
foreach my $key (sort keys(%{$$self{'__h_opt'}})) { next if ($key !~ /^$ns/); if (defined($key) && defined($$self{'__h_opt'}{$key})) { if ($prefix ne "" && $key !~ /^$prefix/) { my $nkey = "$prefix$key"; $ENV{$nkey} = "$$self{'__h_opt'}{$key}"; } else { $ENV{$key} = "$$self{'__h_opt'}{$key}"; } } } }
Title : __ToHASH Usage : $self->__ToHASH($rh_target,$prefix) procedure : Dump the paramparser into a hash Args : $rh_target The hash $prefix Add a prefix to the key, unless already added (write to a namespace) Access : private =cut sub __ToHASH { my ($self, $rh_target, $prefix) = @_; my $ns = $$self{'__name_space'};
foreach my $key (sort keys(%{$$self{'__h_opt'}})) { next if ($key !~ /^$ns/); if (defined($key) && defined($$self{'__h_opt'}{$key})) { if ($prefix ne "" && $key !~ /^$prefix/) { my $nkey = "$prefix$key"; $rh_target->{$nkey} = "$$self{'__h_opt'}{$key}"; } else { $rh_target->{$key} = "$$self{'__h_opt'}{$key}"; } } } }
Title : __ToGetOptLong Usage : $self->__ToGetOptLong($prefix) procedure : Dump the paramparser to @ARGV, using OptLong conventions Args : $prefix Add a prefix to the key, unless already added (write to a namespace) Access : private =cut sub __ToGetOptLong { my ($self, $prefix) = @_; my $ns = $$self{'__name_space'};
@ARGV = (); foreach my $key (sort keys(%{$$self{'__h_opt'}})) { next if ($key !~ /^$ns/); if (defined($key) && defined($$self{'__h_opt'}{$key})) { if ($prefix ne "" && $key !~ /^$prefix/) { my $nkey = "$prefix$key"; push(@ARGV, '--' . $nkey, $$self{'__h_opt'}{$key}); } else { push(@ARGV, '--' . $key, $$self{'__h_opt'}{$key}); } } } }
Title : __ToENV Usage : $self->__DefinedIfNot($r_var) function : Init a variable if it is not defined (in order to avoid warnings) Access : private =cut sub __DefinedIfNot { my ($var) = @_;
if (!defined($var) || $var eq "") { return "undef"; } return $var; }
Title : __InitPossibleSources Usage : $self->__InitPossiblesources() function : Build a list of possible sources depending on loaded modules Access : private =cut sub __InitPossibleSources { my ($self) = @_; my (%h_src) = ( "CGIPM" => defined($CGI::VERSION), "GETOPTSTD" => defined($Getopt::Std::VERSION), "GETOPTLONG" => defined($Getopt::Long::VERSION), "CGILIB" => defined($cgi_lib::version), "ARGV" => defined($ARGV[0]), "INIT" => 1, "PARAMPARSER" => 1, "HASH" => 1 );
$$self{'__possible_sources'} = " ENV ";
foreach my $key (keys(%h_src)) { if ($h_src{$key}) { $$self{'__possible_sources'} .= " $key "; } }
}
Title : __Die Usage : $this->__Die('message','type_of_exception',...) Procedure: Read the use_exceptions behaviour, and call croak or throw THIS PROCEDURE MAY BE USED AS A METHOD OR NOT Args : message The error message
This software is governed by the CeCILL license - www.cecill.info