";
$style = "";
}
print "$header";
foreach my $key (sort keys(%{$$self{'__h_opt'}}))
{
my $ns = $$self{'__name_space'};
next if ($key !~ /^$ns/);
if (defined($key) && defined($$self{'__h_opt'}{$key}))
{
print "$newline$style$key$sep " . $$self{'__h_opt'}{$key};
}
}
print "${newline}Total number (all namespaces) of keys$sep " . $$self{'__nb'};
print "${newline}Last source$sep " . $$self{'__last_source'};
print "$tail";
}
=item SetBehaviour
$rh_param->SetBehaviour('assert_value_secure');
# when set, the assertion will fail if the value of the parameter does not match the pattern of secure values
$rh_param->SetBehaviour('assert_strict');
# when set, the assertion will fail if the parameter is not defined (default)
$rh_param->SetBehaviour('ignore_space');
# when set, the space between the '=' are ignored in the configuration file
$rh_param->SetBehaviour('exit_on_getopt_error')
# execute the usage function when GetOptions return an error code;
$rh_param->SetBehaviour('assert_empty_file_allowed')
# when set, no exit on empty files
$rh_param->SetBehaviour('use_substitution_table')
# when set, the substitution table is used at every Set
NOTE - When this behaviour is set, the function __SubstituteNow is called
Control the behaviour of the parser
=cut
sub SetBehaviour
{
my ($self, $key) = @_;
return unless (__ValidBehaviour($key));
$$self{'__h_behaviour'}{$key} = 1;
if ($key eq 'use_substitution_table')
{
$self->__SubstituteAll();
}
}
=item UnsetBehaviour
$rh_param->UnsetBehaviour('assert_value_secure');
# If unset, the module does not compare the parameter values to the secure pattern
$rh_param->UnsetBehaviour('assert_strict');
# if unset, the assertion is true when the parameter is not defined
$rh_param->UnsetBehaviour('ignore_space');
# if unset, the space between the '=' are not ignored in the configuration file (default)
$rh_param->UnSetBehaviour('exit_on_getopt_error')
# ignore the value returned by GetOptions (default)
$rh_param->UnSetBehaviour('assert_empty_file_allowed')
# if unset, then the program exits on empty files (default)
$rh_param->UnSetBehaviour('use_substitution_table')
# if unset, the substitution table is ignored (default)
Control the behaviour of the parser
=cut
sub UnsetBehaviour
{
my ($self, $key) = @_;
return unless (__ValidBehaviour($key));
$$self{'__h_behaviour'}{$key} = 0;
}
=item GetBehaviour
Returns 1 if the behaviour whose name is passed by parameter is set, 0 if not set.
=cut
sub GetBehaviour
{
my ($self, $key) = @_;
return 0 unless (__ValidBehaviour($key));
return $$self{'__h_behaviour'}{$key};
}
=item SetDefaultBehaviour
ParamParser::SetDefaultBehaviour($key)
The default behaviour for $key is 'Set', for the objects which will be created from now on
=cut
sub SetDefaultBehaviour
{
my $key=shift;
return unless (__ValidBehaviour($key));
$H_DEFBEHAVIOUR{$key} = 1;
};
=item UnSetDefaultBehaviour
ParamParser::UnSetDefaultBehaviour($key)
The default behaviour for $key is 'UnSet', for the objects which will be created from now on
=cut
sub UnSetDefaultBehaviour
{
my $key=shift;
return unless (__ValidBehaviour($key));
$H_DEFBEHAVIOUR{$key} = 0;
};
=item GetDefaultBehaviour
Returns 1 if the default behaviour whose name is passed by parameter is set, 0 if not set.
=cut
sub GetDefaultBehaviour
{
my $key = shift;
return 0 unless (__ValidBehaviour($key));
return $H_DEFBEHAVIOUR{$key};
}
=item AssertFullPath
$rh_param->AssertFullPath(@a_opt);
The programs stops if the key $opt does not refer to a full path of a file/dir
=cut
sub AssertFullPath
{
my ($self, @a_file) = @_;
foreach my $file (@a_file)
{
my $key = $$self{'__name_space'} . $file;
my ($lfile) = $$self{'__h_opt'}{$key};
if ( defined($lfile) && $lfile !~ /^\// )
{
&__PrintUsage($self);
$lfile = &__DefinedIfNot($lfile);
&Carp::croak(
"\n=>The value of the parameter $file is >$lfile< which is not full path file|dir name"
);
}
}
return 1;
}
=item AssertFileExists
$rh_param->AssertFileExists(@a_opt);
The programs stops if the key $opt does not refer to a non empty file
=cut
sub AssertFileExists
{
my ($self, @a_file) = @_;
foreach my $file (@a_file)
{
my $key = $$self{'__name_space'} . $file;
my ($lfile) = $$self{'__h_opt'}{$key} =~ /(\S+)/;
next if (!defined($lfile) && !$$self{'__h_behaviour'}{'assert_strict'});
if (!defined($lfile) || !-e $lfile || (-z $lfile && !$$self{'__h_behaviour'}{'assert_empty_file_allowed'}))
{
&__PrintUsage($self);
$lfile = &__DefinedIfNot($lfile);
&Carp::croak(
"\n=>The value of the parameter $file is >$lfile< which is not a name of an existing and non empty file"
);
}
}
return 1;
}
=item AssertDirExists
$rh_param->AssertDirExists(@a_opt);
The programs stops if the key $opt does not refer to a directory
=cut
sub AssertDirExists
{
my ($self, @a_file) = @_;
foreach my $file (@a_file)
{
my $key = $$self{'__name_space'} . $file;
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);
&Carp::croak(
"\n=>The value of the parameter $file is >$lfile< which is not a name of an existing directory");
}
}
return 1;
}
=item AssertInteger
$rh_param->AssertInteger(@a_opt);
The programs stops if one of the key in the list does not refer to an integer
=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);
&Carp::croak("\n=>The value of the parameter $opt is >$lopt< which is not a valid integer value");
}
}
return 1;
}
=item AssertDefined
$rh_param->AssertDefined(@a_opt);
The programs stop if one of the key in the list is not defined
=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);
&Carp::croak("=>The parameter $opt must be provided");
}
}
return 1;
}
=item AssertAllowedValue
$rh_param->AssertAllowedValue($value,@a_list_of_allowed_values);
The program stop if the value of the key does not match any value of the list of allowed patterns
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, $value, @a_list_of_allowed_values) = @_;
my $key = $$self{'__name_space'} . $value;
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 !
&Carp::croak(
"=>The current value of the parameter $value is >$lvalue< which is not in the set of allowed values [$allowed]"
);
}
=item AssertAllowedValueForAllKeys
$rh_param->AssertAllowedValueForAllKeys($value,@a_list_of_allowed_patterns);
The program stop if the value of some key does not match one value of the list of allowed values
=cut
sub AssertAllowedValueForAllKeys
{
my ($self, @a_list_of_allowed_patterns) = @_;
foreach my $key ($self->GetKeys())
{
$self->AssertAllowedValue($key,@a_list_of_allowed_patterns);
}
}
=item AssertAllowedPattern
$rh_param->AssertAllowedPattern($value,@a_list_of_allowed_patterns);
The program stop if the value of the key does not match one value of the list of allowed patterns
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);
&Carp::croak(
"=>The current value of the parameter $value is >$lvalue< which is not in the set of allowed patterns [$allowed]"
);
}
=item AssertAllowedPatternForAllKeys
$rh_param->AssertAllowedPatternForAllKeys($value,@a_list_of_allowed_patterns);
The program stop if the value of some key does not match one value of the list of allowed values
=cut
sub AssertAllowedPatternForAllKeys
{
my ($self, @a_list_of_allowed_patterns) = @_;
foreach my $key ($self->GetKeys())
{
$self->AssertAllowedPattern($key,@a_list_of_allowed_patterns);
}
}
=item AssertNonEmptyFile
$rh_param->AssertNonEmptyFile(@a_opt);
The programs stops if the elements of the list does not refer to non empty files
=cut
sub AssertNonEmptyFile
{
my ($self, @a_file) = @_;
foreach my $file (@a_file)
{
my $file = $$self{'__name_space'} . $file;
if (!defined($file) || !-e $file || -z $file)
{
&__PrintUsage($self);
$file = &__DefinedIfNot($file);
&Carp::croak("AssertNonEmptyFile failed for $file");
}
}
return 1;
}
=item Usage
$rh_param->Usage();
$rh_param->Usage('html');
Print the usage of the program
=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 = "$0
";
$tail = "
";
}
print $head;
&__PrintUsage($self);
print $tail;
exit;
}
=item SetUsage
$rh_param->SetUsage(my $usage= sub { &my_usage_fct();} )
or
$rh_param->SetUsage('USAGE_DELAYED')
Attach an usage fonction to the ParamParser object
or
Attach the private function UsageDelayed. 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.
=cut
sub SetUsage
{
my ($self, $r_fct_usage) = @_;
if ($r_fct_usage eq 'USAGE_DELAYED')
{
$$self{'__usage_delayed'} = 1;
$$self{'__usage'} = \&__UsageDelayed;
}
else
{
$$self{'__usage_delayed'} = 0;
$$self{'__usage'} = $r_fct_usage;
$self->__CallUsageIfNeeded();
};
}
=item SetDefaultUsage
ParamParser::SetDefaultUsage(my $usage= sub { &my_usage_fct();} )
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
=cut
sub SetDefaultUsage
{
my $r_fct_usage = shift;
$R_DEFUSAGE = $r_fct_usage;
}
=head2 function Encode
Title : Encode
Usage : $params_encoded = $o_param->Encode($params);
Prerequiste: uuencode must be installed
Function : Encode a $param if required
Returns : $params, encoded or not
Args : $param, a string, generally an url formatted parameters
globals : none
=cut
sub Encode
{
my ($parameters) = @_;
my $str = uuencode($parameters);
$str =~ s/^begin 644 uuencode.uu\s//o;
$str =~ s/`\send\s$//o;
$str =~ s/\=/code1/go;
$str =~ s/\&/code2/go;
$str =~ s/\?/code3/go;
$str =~ s/\n/code4/go;
$str =~ s/\"/code5/go;
$str =~ s/ /code6/go;
$str =~ s/([^A-Za-z0-9])/sprintf("%%%02X", ord($1))/seg;
$str=reverse($str);
return '' if ( $str eq '' );
return "__wb_url=$str";
}
=head2 function Decode
Title : Decode
Usage : $query_string = $self->Decode();
Prerequiste: uuencode must be installed
Function : Decode the $ENV{'QUERY_STRING'} if needed
Returns : the $ENV{'QUERY_STRING'} decoded
Args : none
globals : none
=cut
sub Decode
{
return '' unless (defined ($ENV{'QUERY_STRING'}));
return $ENV{'QUERY_STRING'} if ( $ENV{'QUERY_STRING'} !~ /__wb_url/ );
my ($encoded_substr) = $ENV{'QUERY_STRING'} =~ /__wb_url=([^\&]+)/;
my $encoded_ori = $encoded_substr;
$encoded_substr = reverse($encoded_substr);
$encoded_substr =~ s/code1/=/go;
$encoded_substr =~ s/code2/\&/go;
$encoded_substr =~ s/code3/\?/go;
$encoded_substr =~ s/code4/\n/go;
$encoded_substr =~ s/code5/\"/go;
$encoded_substr =~ s/code6/ /go;
$encoded_substr =~ s/\%([A-Fa-f0-9]{2})/pack('C', hex($1))/seg;
$encoded_substr = "begin 644 uuencode.uu\n$encoded_substr\`\nend\n";
my $str = uudecode($encoded_substr);
my $tmp = "__wb_url=$encoded_ori";
$ENV{'QUERY_STRING'} =~ s/$tmp/$str/om;
return $ENV{'QUERY_STRING'};
}
=item SetAuthorizedCharacters
$o_param->SetAuthorizedCharacters('[A-Za-z0-9_]');
Initialize the pattern of allowed 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('INIT'); # 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
=cut
sub SetAuthorizedCharacters
{
my($self,$perlpattern)=@_;
$$self{'__authorized_characters'} = $perlpattern;
$$self{'__h_behaviour'}{'assert_value_secure'} = 1;
}
=item SecurityControl
If assert_value_secure activated, it checks the content of all values, croak on any suspicious parameter value
=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
key=$item
value=$val
allowed characters are $secure_char"),
$cgi->end_html;
}
&Carp::croak("SECURITY ISSUE: Fatal error: the parameter >$item< is not secure enough (value=$val)\n");
}
}
}
}
=head1 EXAMPLE1
use CGI qw/:standard/;
use ParamParser;
my $rh_param = New ParamParser("CGIPM");
# attach an usage fonction to the parser
# the best way would be to reference a real fonction $rh_param->SetUsage(my $usage=sub { &UsageFct(); } );
$rh_param->SetUsage(my $usage=sub { print "\nPlease read the documentation\n"; } );
# add a single variable to the data structure
$rh_param->Set('TIMEOUT','10000');
# append all environment variables in overwrite mode (overwrite duplicates)
$rh_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.
$rh_param->AssertFileExists('CFG');
# add all variables contained in the configuration file in append mode (do not overwrite duplicates)
$rh_param->Update($rh_param->Get('CFG'),"A");
print header;
$rh_param->Print('html');
=cut
=head1 EXAMPLE2
use Getopt::Long;
use ParamParser;
my $rh_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 $rh_param->SetUsage(my $usage=sub { &UsageFct(); } );
$rh_param->SetUsage(my $usage=sub { print "\nPlease read the documentation\n"; } );
# append all environment variables in append mode (do not overwrite duplicates)
$rh_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.
$rh_param->AssertFileExists('inputfile');
# check that the value of the parameters are integers, print the usage and exit if one of them is not.
$rh_param->AssertInteger('max','min');
# check that the value of the parameter what is a correct value
$rh_param->AssertAllowedValue('what','yes','no','maybe');
# check that the value of the parameter what is a correct value (more restrictive: only 1 char)
$rh_param->AssertAllowedValue('what','[yYnN01]');
# check that the value of the parameters is a correct value, matching one of those patterns
$rh_param->AssertAllowedPattern('^[wW]hat$','^[yY]es', '^[nN]o','^maybe$');
# check each key's value for a list of allowed characters
$rh_param->AssertAllowedValueForEachKey('[0-9a-z]+');
# check that each key's value starts with a lower-case letter
$rh_param->AssertAllowedPatternForEachKey('^[a-z]');
$rh_param->Print();
=cut
=head1 INTERNAL METHOD CALLS
=cut
=item __CallUsageIfNeeded
$rh_param->__CallUsage()
Private method
Call Usage if --help specified
=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)
{
&Usage($self, 'html');
}
else
{
&Usage($self);
}
}
}
sub __UsageDelayed
{
my $self = shift;
$$self{'__usage_needed'} = 1; # We shall call Usage when possible
};
=item __PrintUsage
Print the usage of the program
=cut
sub __PrintUsage
{
my $self = shift;
&{$$self{'__usage'}}($self);
}
=item __UpdateIfPossible
Update the value of the given key, depending on the selected insertion mode
the third argument can be undef, beware !
=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) ;
}
}
=item __ValidBehaviour
__ValidBehaviour is a funtion, NOT a method - No $self arg
return 1 if the behaviour passed by parameter is legal, 0 if not.
If not legal, croak something.
=cut
sub __ValidBehaviour {
my $key = shift;
return 1 if (exists $H_DEFBEHAVIOUR{$key});
&Carp::croak("\n=>The behaviour $key is unknown");
return 0;
}
=item __SubstituteKey
Try to make the substitutions for the key passed by parameter
=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 'SCALAR') # Substitute if ref to a scalar
{
$to_subst =~ s/$s/$$r/g;
};
if (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;
}
=item __SubstituteAll
For each parameter, call __SubstituteKey
=cut
sub __SubstituteAll
{
my $self = shift;
foreach my $key (sort keys(%{$self->{'__h_opt'}}))
{
$self->__SubstituteKey($key);
}
}
=item __FromGetOptStd
Initialize the ParamParser object using Getopt::Std style as source of param/values
=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
}
=item __FromGetOptLong
Initialize the ParamParser object using Getopt::Long style as source of param/values
=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};
&__UpdateIfPossible($self, $real_key, $$r_tmp);
}
@ARGV = @a_backup; # restore original parameters
# -> can be parsed again is necessary
# -> avoid side effect
}
=item __FromCGILIB
Initialize the ParamParser object using CGI-LIB2 as source of param/value
=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});
}
}
}
=item __FromCGIPM
Initialize the ParamParser object using CGI.pm source
=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;
}
=item __FromFile
Initialize the ParamParser object using a configuration file.
=cut
sub __FromFile
{
my ($self, $source) = @_;
my $lock_flg = $self->GetBehaviour('lock_file');
my ($lign) = "";
my $lock_file=$source.'.lock';
if ($lock_flg==1)
{
open(L,"+>>$lock_file") or die "Cannot open $lock_file";
fcntl(L,F_SETLKW,pack('ssx32',F_RDLCK,0)) or die "Can't put a read lock on $lock_file: $!";
};
open(PARAMPARSERCFG, "$source") or &Carp::croak("ERROR Cannot open >$source<");
while ($lign = )
{
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]);
}
close(PARAMPARSERCFG);
if ($lock_flg==1)
{
fcntl(L,F_SETLKW,pack('ssx32',F_UNLCK,0)) or die "Can't release the read lock on $lock_file: $!";
close(L);
};
}
=item __FromARGV
Initialize the ParamParser object using the @ARGV array as source of param/values
=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]);
}
}
=item __FromENV
Initialize the ParamParser object using the %ENV hash as source of param/values
=cut
sub __FromENV
{
my ($self) = @_;
foreach my $option (keys(%ENV))
{
next if (!defined($option) || !defined($ENV{$option}));
&__UpdateIfPossible($self, $option, $ENV{$option});
}
}
=item __FromPARAMPARSER
Initialize the ParamParser object using another ParamParser object
=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});
}
}
=item __FromHASH
Initialize the ParamParser object using a hash
=cut
sub __FromHASH
{
my $self= shift;
my $rh_p= shift;
my ($keyin);
foreach $keyin (keys(%$rh_p))
{
&__UpdateIfPossible($self, $keyin, $rh_p->{$keyin});
}
}
=item __ToFile
Dump the paramparser into a file
=cut
sub __ToFile
{
my ($self, $target, $prefix) = @_;
my $ns = $$self{'__name_space'};
my $lock_file=$target.'.lock';
my $lock_flg = $self->GetBehaviour('lock_file');
if ($lock_flg==1)
{
open(L,">>$lock_file") or die "Cannot open $lock_file";
fcntl(L,F_SETLKW,pack('ssx32',F_WRLCK,0)) or die "Can't put a read lock on $lock_file: $!";
};
open(PARAMPARSERCFG, ">$target") or &Carp::croak("ERROR Can't open >$target< for writing\n");
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 PARAMPARSERCFG "$nkey=" . $$self{'__h_opt'}{$key} . "\n";
}
else
{
print PARAMPARSERCFG "$key=" . $$self{'__h_opt'}{$key} . "\n";
}
}
}
close(PARAMPARSERCFG);
if ($lock_flg==1)
{
fcntl(L,F_SETLKW,pack('ssx32',F_UNLCK,0)) or die "Can't release the read lock on $lock_file: $!";
close(L);
unlink($lock_file); # Forcing a cache reload with nfs
};
}
=item __ToENV
Dump the paramparser into the environment
=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}";
}
}
}
}
=item __ToHASH
Dump the paramparser into a HASH
=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}";
}
}
}
}
=item __ToGetOptLong
Dump the paramparser to @ARGV, using OptLong conventions
=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});
}
}
}
}
=item __DefinedIfNot
Init a variable if it is not defined (in order to avoid warnings)
=cut
sub __DefinedIfNot
{
my ($var) = @_;
if (!defined($var) || $var eq "")
{
return "undef";
}
return $var;
}
=item __InitPossibleSources
Build a list of possible sources depending on loaded modules
=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 ";
}
}
}
=head1 COPYRIGHT NOTICE
This software is governed by the CeCILL license - www.cecill.info
=cut
1;
|