# this is basically -*- perl -*- # NACL::OptionSet # Copyright NetApp 2009 # Options (Parameters) basic functionality. # # See http://wikid.netapp.com/w/QA/projects/Libraries_Initiative/Project/Common_Infrastructure/Functional_Spec/Parameter_Processing_Func_Spec # See also http://wikid.netapp.com/w/QA/projects/Libraries_Initiative/Project/Common_Infrastructure/Design_Spec/Parameter_Processing_Design_Spec # # Author: Scott Henry # ## @summary Optionset ## @author Scott Henry dl-nacl-dev@netapp.com ## @status shared ## @pod here use strict; use warnings; package NACL::OptionSet; our $debug; use NATE::Log qw(log_global); my $Log = log_global(); my $may_enter = $Log->may_enter(); my $may_exit = $Log->may_exit(); use NATE::Exceptions::Argument qw(:try); use NACL::Exceptions::Constraint; use Params::Validate qw(:all); use Data::Dumper; # This is a subclass of NATE::ParamSet use base qw(NATE::ParamSet); =head1 NAME NACL::OptionSet - manage and validate input parameters to a test =head1 SYNOPSIS use NACL::OptionSet; my $options = NACL::OptionSet->new(); $options->parameters(definitions=> [ { name => "foo.bar", description => "the foo.bar variable", }, { name => "bar.foo", description => "the bar.foo variable", }, { name => "a.b.c", description => "test out dependencies", dependencies => [qw(foo.bar)], }, { name => "", description => "", }, { name => "", description => "", }, { name => "", description => "", }, { name => "", description => "", }, ], require_one_of => [["foo.bar", "bar.foo"]]); $options->process(); $options->process($parmset1, $paramset2); The following functions are the same as NATE::ParamSet, and are available after C has been run: my $foobar = $options->get("foo.bar"); my $fooparm = $options->get_params("foo", merge=>1, expand=>1); my $param = $options->clone(); =head1 DESCRIPTION "OptionSet" implements an object which is used for all option/parameter handling by both libraries and scripts. Each script or library creates an OptionSet object and calls the parameters method to actually define the parameters that will be used by the code. This is simply a defini- tion and does not actually process the params. The idea is that each piece of code handles the definitions that it will use. Once all of the parameters have been defined, the "process" method is called to actu- ally process the params that have been defined. The actual values for the parameters are stored in the object and can be accessed via calls to "get". The object is actually implemented as a "singleton"; there is only ever one version of the object in the code that gets created by the first caller. Each successive new call returns this same object. This design allows for all OptionSet objects to contain the same values for the params. =head1 METHODS =head2 new my $Optionset = NACL::OptionSet->new(); "new" is the invocant for the OptionSet object. The data structures for the object are all stored in the class so they share the same information. it returns the object on success and dies on failure. =cut # The singleton instance and the globals. my $GlobalOptions; my @definitions; my @require1; sub new () { $Log->enter() if $may_enter; my ($proto, %args) = @_; my $class = ref($proto) || $proto; if ($GlobalOptions) { return $GlobalOptions; } # create the hash to bless. my $self = {}; bless $self, $class; # Create and store the base element $self->{base_element} = NATE::ParamElement->new(data_origin => "new", long_name => "root", data_type => "tree", data_value => {}); $self->{search} = ["", "DEFAULT"]; $debug = $args{debug} if defined($args{debug}); $Carp::Verbose = 1 if $debug; $GlobalOptions = $self; # defining some debug capability. $Log->exit() if $may_exit; return $self; } ## end sub new =head2 clone Create a clone of an existing OptionSet. As OptionSet is a singleton, the clone is of the nested ParamSet. Note that the nested ParamSet is empty unless C has been run once before the clone operation. =over =item RETURNS clone() returns a reference to a deep-copy of the nested ParamSet. It may be chained to apply modifications. =back =cut sub clone () { $Log->enter() if $may_enter; my ($self) = @_; my $base = NATE::ParamSet->new(); _deep_copy($self->{base_element}, $base->{base_element}, 1); $Log->exit() if $may_exit; return $base; } =head2 parameters $Optionset->parameters(definitions=>[{},{},...], require_one_of=>[[...],[...],...]); The "parameters" method provides definitions for the options that should be processed. The definitions can also provide further testing that should occur on the option as it is processed. The call returns nothing and will die on error. =over =item definitions (Required) List of option definitions, specified as hashes. example: { name => name, spec => "s@", description => "This is a parameter", required => "You must specify this basic parameter", default => [], subroutine => [\&routine, arg1, arg2,...], dependencies => [qw(option1 option2)], } =over =item name (Required) the name for the option =item spec (Optional) Specifies the option specifier as defined in Getopt::Long. The values that are currently supported are: =over =item undef signifies a simple scalar value =item 'boolean' signifies that the value is a boolean. Possible values that equate to true: true, 1, on, yes, defined Possible values that equate to false: false, 0, off, no, undef Internally, a true value is represented by 1 and a false value is represented by undef. =item 'evaluate' signifies that the parameter value should be evaluated, further described below. The param should be separated by ':' or ','. Internally, the options is stored in an anony- mous array. If the "spec" specifies an array, an empty anonymous array will be created for options that have not been specified. The 'evaluate' specifier is used to enable evaluation of strings to perform evaluation of the parameter to perform math functions (really could be any perl function) as well as common size substitutions like kilo, mega, etc. For example, specifying '1k-2' as a value would result in the param being set to 1022. The common substitutions are: =over =item k => 1024, m => 1024^2, g => 1024^3, t => 1024^4, p => 1024^5, e => 1024^6 =item K => 1000, M => 1000^2, G => 1000^3, T => 1000^4, P => 1000^5, E => 1000^6 =item time Signifies that the value is a unit of time and should be converted to the base number of seconds. The available time units are 'm' for minutes, 'h' for hours, 'd' for days. 1m will convert into 60 1h will convert into 3600 1d will convert into 86400 =item 's@' which signifies that the option is for a list =back =item description (Required) The text that describes the usage of the option. This text is printed when 'help' is specified. =item required (Optional) The text that is printed when the option is required but is not specified. =item default (Optional) The default value for the option =item subroutine (Optional) This param indicates that a subroutine should be called if this option is specified. The value of this parameter is a list. The first element is a reference to the routine to call. The remainder of the list will be passed as params to the routine. The value of the parameter is prepended to the list prior to calling the routine. =item less (Optional) The value of the param (after optional processing by spec and subroutine) must be numerically less than this value. =item greater_equal (Optional) The value of the param (after optional processing by spec and subroutine) must be numerically greater than or equal to this value. =item valid_values (Optional) The value of the param (after optional processing by spec and subroutine) must match one of the members of this list. =item dependencies (Optional) a list of additional options which are required if this option is specified. If any of these dependencies are also not specified, an error is generated. =back =item require_one_of (Optional) a list of lists of options, each of which specifies that at least one of its elements must be present; otherwise, an error is generated. example: require_one_of => [[qw(option1 option2)], [qw(option3 option4)]], =back =back =cut sub parameters { $Log->enter() if $may_enter; my $self = shift; if ( $Log->may_debug() ) { $Log->debug( "Opts to 'parameters' front end are:\n" . Dumper( \@_ ) ); } my %args = validate( @_, { definitions => { type => ARRAYREF }, require_one_of => { type => ARRAYREF, optional => 1 }, }); push(@definitions, @{$args{definitions}}); push(@require1, @{$args{require_one_of}}) if $args{require_one_of}; $Log->exit() if $may_exit; return $self; } =head2 process $optionset->process($paramset1, $paramset2, ...); "process" is the method that will actually examine all sources of options and store the values internally. Once stored, the options will be available via the "get" and "get_params" methods. The "process" method can be called multiple times and has to be called at least once before options are available internally. When called, it will only process the options which have been defined via "parameters" and "compatability", and only those parameters will be available via the "get" or "get_params" methods. =over =item $paramset1, ... One or more ParamSet containing parameters to process. They will be searched in order for the parameters, with the default search path and with merge and expand set. If no ParamSet are specified as an argument, the default ParamSet is used. If the default ParamSet is wanted as well as additional ParamSets, then the default ParamSet must be explicitely specified, in the sequence location desired. =back =cut sub process () { $Log->enter() if $may_enter; my $self = shift; if ( $Log->may_debug() ) { $Log->debug( "Opts to 'process' front end are:\n" . Dumper( \@_ ) ); } my @psets = @_; if (! @psets) { push(@psets, NATE::ParamSet::get_global()); } my $base = $self->{base_element}; # first pass: process required, default, limits foreach my $pref (@definitions) { my $newp; my ($value, $origin) = _search_all($pref->{name}, @psets); if (defined $value) { $Log->debug(" _search_all($pref->{name}) returns " . $value); # found the parameter name, now validate & process it my $newval = _process_one($value, $pref); # dies if validation failure $self->set(key=>$pref->{name}, value=>$newval, origin=>$origin, allow_replace=>1); } else { $Log->debug(" _search_all($pref->{name}) returns undef"); # not found. Check for optional or default if ($pref->{required}) { $Log->exit() if $may_exit; NATE::Exceptions::Argument->throw($pref->{required}); } if (defined $pref->{default}) { $self->set(key=>$pref->{name}, value=>$pref->{default}, origin=>"default", allow_replace=>1); } } } # second pass: process dependencies foreach my $pref (@definitions) { if ($pref->{dependencies}) { foreach my $dep (@{$pref->{dependencies}}) { unless($self->get($dep)) { $Log->exit() if $may_exit; NACL::Exceptions::Constraint->throw( $pref->{name}." has missing dependency $dep"); } } } } # third pass: process require_one_of foreach my $req (@require1) { my $found = 0; foreach my $check (@{$req}) { $found++ if $self->get($check); } unless($found > 0) { $Log->exit() if $may_exit; NACL::Exceptions::Constraint->throw("need to define at least one of @{$req}"); } } $Log->exit() if $may_exit; return $self; } #============================================================================ # private functions # Search the list of ParamSets for the key, with default search path. # # Since we are searching from the root (all the options defined in # $optionset->parameters() are defined from the root), we don't specify # 'search' option and thus it gets defaulted to root [""]. Since the search # path is absolute starting from the root, we don't have to bother about # 'merge' option as there can be only one match. So we will stick with # the defaults for 'merge' which is 0. # The return value from get() could be a scalar or hash depending on # whether the matched node is a leaf node or internal node in ParamSet. # All the parameters processed are expected to be leaf nodes and so we will # ignore the value if it is a hash. Also note that when searching against # multiple paramsets, there could be more than one match but we will take # the first match. The usecase is that if we have a paramset defining defaults # for the options and if user specified values are obtained using global # paramset in which case we would like to give precedence to the user specified # value in the global paramset and ignore the default value specified in # default paramset. # # Return the value & origin, or undef. Do not die here... sub _search_all { $Log->enter() if $may_enter; my ($key, @psets) = @_; foreach my $p (@psets) { my $base = $p->{base_element}; my $res = $p->get($key); if ((defined $res) && (!ref($res))) { # This is a leaf node as expected. Now find the origin as well. my $origin = $p->get_attribute(key => $key, attr => "origin"); # The following line is required till burt516816 is fixed. $origin = (defined $origin)? $origin: "dummy_path_added_by_OptionSet"; $Log->exit() if $may_exit; return ($res, $origin); } } $Log->exit() if $may_exit; return (undef, undef); } # Provides the default delimiters sub get_default_delimiter { $Log->enter(); $Log->exit() if $may_exit; # ',' and ':' are standard dlimiters used by testbeds. return qr(,|:); } # process the constraints on one parameter. Must wait until all are processed # to handle dependencies sub _process_one { $Log->enter() if $may_enter; my ($val, $pref) = @_; my $name = $pref->{name}; if ($pref->{spec}) { if ($pref->{spec} eq "boolean") { unless($val =~ /^(1|0|true|false|yes|no|defined|undef|on|off)$/i) { $Log->exit() if $may_exit; NATE::Exceptions::Argument->throw("parameter $name (value $val) is not a boolean"); } } elsif ($pref->{spec} eq "s@") { my $delim = $pref->{delimiter} ? $pref->{delimiter} : get_default_delimiter(); my @v = split(/$delim/, $val); $val = \@v; $Log->debug(" _process_one:array: " . $val . "=>[@v]\n"); } elsif ($pref->{spec} =~ /^eval/) { my $newval; if ($val =~ /^(\d*):(\d+):(\d+)$/) { # format = hour:minutes:seconds $newval = ((($1 * 60) + $2) * 60) + $3; } elsif ($val =~ /^(\d+)\D+(\d+):(\d+):(\d+)$/) { # format = days hours:minutes:seconds $newval = ((((($1 * 24) + $2) * 60) + $3) * 60) + $4; } else { $newval = _map_units($val); } $val = eval $newval; } } if ($pref->{subroutine}) { foreach my $func (@{$pref->{subroutine}}) { $val = &{$func}($val, $pref); } } if ($pref->{less}) { unless($val < $pref->{less}) { $Log->exit() if $may_exit; NATE::Exceptions::Argument->throw("parameter $name (value $val) " . "is not less than $pref->{less}"); } } if ($pref->{greater_equal}) { unless($val >= $pref->{greater_equal}) { $Log->exit() if $may_exit; NATE::Exceptions::Argument->throw("parameter $name (value $val) " . "is not greater than or equal to $pref->{greater_equal}"); } } if ($pref->{valid_values}) { my @valid = @{$pref->{valid_values}}; unless (grep(/^$val$/, @valid)) { $Log->exit() if $may_exit; NATE::Exceptions::Argument->throw("parameter $name (value $val) " . "is not one of [ @valid ]"); } } $Log->exit() if $may_exit; return $val; } # map the SI and binary units into eval-able math sub _map_units { $Log->enter() if $may_enter; my ($s) = @_; # map the binary scale $s =~ s/(\d+)k/($1*1024)/g; $s =~ s/(\d+)m/($1*1024*1024)/g; $s =~ s/(\d+)g/($1*1024*1024*1024)/g; $s =~ s/(\d+)t/($1*1024*1024*1024*1024)/g; $s =~ s/(\d+)p/($1*1024*1024*1024*1024*1024)/g; $s =~ s/(\d+)e/($1*1024*1024*1024*1024*1024*1024)/g; # map the SI scale $s =~ s/(\d+)K/($1*1000)/g; $s =~ s/(\d+)M/($1*1000000)/g; $s =~ s/(\d+)G/($1*1000000000)/g; $s =~ s/(\d+)T/($1*1000000000000)/g; $s =~ s/(\d+)P/($1*1000000000000000)/g; $s =~ s/(\d+)E/($1*1000000000000000000)/g; $Log->exit() if $may_exit; return $s; } 1; # Check # Local Variables: # tab-width: 4 # perl-indent-level: 4 # indent-tabs-mode: nil # End: