NAME

ParamParser - parse parameters from different sources (CGI.pm, GetOpt, cgi-lib, configuration file, ARGV, ENV)


DESCRIPTION

        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);


EXAMPLE1

 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');


EXAMPLE2

 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();

function New

        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

procedure Update

        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

procedure Dump

        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

procedure SelectNameSpace

    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

procedure Init

    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

procedure Set

    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

procedure SetUnlessDefined

    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

procedure Delete

    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

function Get

    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)

function GetInteger

    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

function GetKeys

    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

function IsDefined

    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

function HowMany

    Title     : HowMany
    Usage     : my $nb = $o_param->HowMany();
    function  : Return the number of parameters
    Args      : none
    return    : the number of parameters

function GetSource

    Title     : GetSource
    Usage     : my $srce = $o_param->GetSource();
    function  : Return the last source used for updating the parameters
    Args      : none
    return    : the last source

procedure SetSubstitution

    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

procedure Print

    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

procedure SetBehaviour

    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

procedure UnsetBehaviour

    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)

procedure GetBehaviour

    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

procedure SetDefaultBehaviour

    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)

procedure UnsetDefaultBehaviour

    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)

procedure GetDefaultBehaviour

    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

procedure AssertFullPath

    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

procedure AssertFileExists

    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

procedure 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

procedure AssertDirExists

    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;
}

procedure AssertInteger

    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;
}

procedure AssertInteger

    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;
}

procedure AssertAllowedValue

    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'
         );
}

procedure AssertAllowedValueForAllKeys

    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);
    }
}

procedure AssertAllowedPattern

    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'
        );
}

procedure AssertAllowedPatternsForAllKeys

    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);
    }
}

procedure SetUsage

    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'

procedure SetDefaultUsage

    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

procedure Usage

    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;
}

function Encode

        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

function Decode

        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

procedure SetAuthorizedCharacters

    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;

}


PRIVATE METHODS

procedure __SecurityControl

    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');
            }
        }
    }
}

procedure __CallUsageIfNeeded

    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();
        }
    }
}

procedure __UsageDelayed

    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
}

procedure __PrintUsage

    Title     : __PrintUsage
    Usage     : $self->__PrintUsage()
    procedure : Call the registered usage function
    Args      : none
    Access    : private
    
=cut
sub __PrintUsage
{
    my $self = shift;
    &{$$self{'__usage'}}($self);
}

procedure __UpdateIfPossible

    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;
}

function __ValidBehaviour

    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;
}

procedure __SubstituteKey

    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;
}

procedure __SubstituteAll

    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);
    }
}

procedure __FromGetOptStd

    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
}

procedure __FromGetOptLong

    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
}

procedure __FromCGILIB

    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});
        }
    }
}

procedure __FromCGIPM

    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;
}

procedure __FromFILE

    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();
    }
}

procedure __FromARGV

    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]);
    }
}

procedure __FromENV

    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});
    }
}

procedure __FromPARAMPARSER

    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});
    }
}

procedure __FromHASH

    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});
    }
}

procedure __ToFile

    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
    }
}

procedure __ToENV

    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}";
            }
        }
    }
}

procedure __ToHASH

    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}";
            }
        }
    }
}

procedure __ToGetOptLong

    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});
            }
        }
    }
}

function __DefinedIfNot

    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;
}

function __InitPossibleSources

    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 ";
        }
    }

}

__Die

  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


COPYRIGHT NOTICE

This software is governed by the CeCILL license - www.cecill.info