diff options
| author | fukachan <fukachan> | 2001-04-01 14:22:59 +0000 |
|---|---|---|
| committer | fukachan <fukachan> | 2001-04-01 14:22:59 +0000 |
| commit | a69f2d3da0f33207fc9327b488bf55b32501d377 (patch) | |
| tree | d94e92a8230017d17da252c1bfe424b8a51aa245 /cpan | |
| parent | 996850c6f7fcfd64d9dca3309a27802f909a5a58 (diff) | |
| download | fml8-a69f2d3da0f33207fc9327b488bf55b32501d377.tar.gz fml8-a69f2d3da0f33207fc9327b488bf55b32501d377.tar.bz2 fml8-a69f2d3da0f33207fc9327b488bf55b32501d377.zip | |
Initial revision
Diffstat (limited to 'cpan')
| -rw-r--r-- | cpan/dist/Class-NamedParms/MANIFEST | 5 | ||||
| -rw-r--r-- | cpan/dist/Class-NamedParms/Makefile.PL | 11 | ||||
| -rw-r--r-- | cpan/dist/Class-NamedParms/README | 31 | ||||
| -rw-r--r-- | cpan/dist/Class-NamedParms/lib/Class/NamedParms.pm | 390 | ||||
| -rwxr-xr-x | cpan/dist/Class-NamedParms/t/general.t | 97 | ||||
| -rw-r--r-- | cpan/dist/Class-ParmList/CHANGES | 11 | ||||
| -rw-r--r-- | cpan/dist/Class-ParmList/MANIFEST | 8 | ||||
| -rw-r--r-- | cpan/dist/Class-ParmList/Makefile.PL | 11 | ||||
| -rw-r--r-- | cpan/dist/Class-ParmList/README | 33 | ||||
| -rw-r--r-- | cpan/dist/Class-ParmList/lib/Class/ParmList.pm | 598 | ||||
| -rwxr-xr-x | cpan/dist/Class-ParmList/t/01_object.t | 190 | ||||
| -rwxr-xr-x | cpan/dist/Class-ParmList/t/02_simple_parms.t | 150 | ||||
| -rwxr-xr-x | cpan/dist/Class-ParmList/t/03_parse_parms.t | 190 | ||||
| -rw-r--r-- | cpan/lib/Class/NamedParms.pm | 390 | ||||
| -rw-r--r-- | cpan/lib/Class/ParmList.pm | 598 |
15 files changed, 2713 insertions, 0 deletions
diff --git a/cpan/dist/Class-NamedParms/MANIFEST b/cpan/dist/Class-NamedParms/MANIFEST new file mode 100644 index 00000000..4c888864 --- /dev/null +++ b/cpan/dist/Class-NamedParms/MANIFEST @@ -0,0 +1,5 @@ +MANIFEST +Makefile.PL +README +lib/Class/NamedParms.pm +t/general.t diff --git a/cpan/dist/Class-NamedParms/Makefile.PL b/cpan/dist/Class-NamedParms/Makefile.PL new file mode 100644 index 00000000..4b5a6fd6 --- /dev/null +++ b/cpan/dist/Class-NamedParms/Makefile.PL @@ -0,0 +1,11 @@ +use ExtUtils::MakeMaker; +# See lib/ExtUtils/MakeMaker.pm for details of how to influence +# the contents of the Makefile that is written. +WriteMakefile( + 'NAME' => 'Class::NamedParms', + 'VERSION_FROM' => 'lib/Class/NamedParms.pm', + 'PREREQ_PM' => {}, + 'linkext' => { LINKTYPE=>'' }, # no link needed + 'dist' => {'COMPRESS'=>'gzip -9f', 'SUFFIX' => 'gz', + 'ZIP' => '/usr/bin/zip','ZIPFLAGS'=>'-rl'} +); diff --git a/cpan/dist/Class-NamedParms/README b/cpan/dist/Class-NamedParms/README new file mode 100644 index 00000000..a53829c5 --- /dev/null +++ b/cpan/dist/Class-NamedParms/README @@ -0,0 +1,31 @@ +Class::NamedParms + + Provides standard get/set/clear accessors for a class via named + parameter with forced lexical checking of named parameters + for validity and initialization validation. Lightweight and simple + to use. Designed as a base class for inheritance by other modules. + +CHANGES + + 1.00 1999.06.16 Initial release + + 1.01 1999.06.17 Bug fix to 'clear' method. Added 'make test' support. + + 1.02 1999.06.18 Performance tweeks + + 1.03 1999.06.21 Minor doc fixes. Removal of 'use attrs' for portability. + 1.04 1999.10.08 Bug fix to 'all_parms' method. + +To install: + +perl Makefile.PL +make +make test +make install + +Type 'perldoc Class::NamedParms' after installation for the documentation +or go to <URL:http://www.nihongo.org/snowhare/utilities/modules/class-namedparms/> + +Copyright 1999, Benjamin Franz (<URL:http://www.nihongo.org/snowhare/>) and +FreeRun Technologies, Inc. (<URL:http://www.freeruntech.com/>). All Rights Reserved. +This software may be copied or redistributed under the same terms as Perl itelf. diff --git a/cpan/dist/Class-NamedParms/lib/Class/NamedParms.pm b/cpan/dist/Class-NamedParms/lib/Class/NamedParms.pm new file mode 100644 index 00000000..2be2e037 --- /dev/null +++ b/cpan/dist/Class-NamedParms/lib/Class/NamedParms.pm @@ -0,0 +1,390 @@ +package Class::NamedParms; + +# $RCSfile: NamedParms.pm,v $ $Revision: 1.1 $ $Date: 1999/06/15 17:25:38 $ $Author: snowhare $ + +use strict; +use Carp; +use vars qw($VERSION); + +$VERSION = '1.04'; + +=head1 NAME + +Class::NamedParms - A lightweight named parameter handling system. + +=head1 SYNOPSIS + + package SomePackage; + use Class::NamedParms; + use vars qw (@ISA); + @ISA=qw(Class::NamedParms); + + sub new { + + my ($proto) = shift; + my ($class) = ref ($proto) || $proto; + + $self = Class::NamedParms->new(-benefits,-costs); + $self = bless $self,$class; + + $self; + } + + $thingy = SomePackage->new; + $thingy->set({ -benefits => 1, -costs => 0.5 }); + my ($costs,$benefits) = $thingy->get(-costs,-benefits); + +=head1 DESCRIPTION + +Provides key name checking for named accessor parameters. This allows +the use of a generic 'get/set' type parameterized accessor while +automatically catching accidental mis-spellings and usage of uninitialized +parameters. This catches a large class of programming errors without requiring +a new accessor for every object parameter. + +=head1 CHANGES + + 1.00 1999.06.16 - Initial release. + + 1.01 1999.06.17 - Bug fix to 'clear' method. Added 'make test' support. + + 1.02 1999.06.18 - Performance tweak to 'get' method. + + 1.03 1999.06.21 - Minor docs tweaks. Removal of 'use attrs' for portability + + 1.04 1999.10.08 - Bug fix to 'all_parms' method + +=head2 Initialization + +=cut + +###################################################################### + +=over 4 + +=item C<new;> + +Creates a new instance of a NamedParms object. + +You can optionally 'declare' the legal parameter keys at the same time. + +Example: + + my $self = Class::NamedParms(-benefits,-costs,-other); + +=back + +=cut + +sub new { + my ($class) = shift; + my $self = bless {},$class; + + $self->{-legal_parms} = {}; + $self->{-parm_values} = {}; + + if ($#_ != -1) { + $self->declare(@_); + } + + $self; +} + +###################################################################### + +=over 4 + +=item C<list_declared_parms;> + +Returns a list of all parm names that have been declared for this +NamedParms object. List is unsorted. + +=back + +=cut + +sub list_declared_parms { + my $self = shift; + + my (@parmnames) = keys %{$self->{-legal_parms}}; + return @parmnames; +} + +###################################################################### + +=over 4 + +=item C<list_initialized_parms;> + +Lists all parms that have had values initialized for this NamedParms object +Returns a list of the parameter names. List is unsorted. + +=back + +=cut + +sub list_initialized_parms { + my $self = shift; + + my (@parmnames) = keys %{$self->{-parm_values}}; + return @parmnames; +} + +###################################################################### + +=over 4 + +=item C<declare($parmname,[$parmname1,...]);> + +Declares one or more parameters for use with the NamedParms object. + +Example: + + $self->declare(-moved_in,-car_key,-house_key,-relationship); + +This *does not* initialize the parameters - only declares them +to be legal for use. + +=back + +=cut + +sub declare { + my $self = shift; + + my (@parmnames) = @_; + + my $parmname; + foreach $parmname (@parmnames) { + $parmname = lc ($parmname); + $self->{-legal_parms}->{$parmname} = 1; + } +} + +###################################################################### + +=over 4 + +=item C<undeclare($parmname,$parmname1,...);> + +'undeclares' one or more parameters for use with the NamedParms object. +This also deletes any values assigned to those parameters. + +Example: + + $self->undeclare(-house_key,-car_key,-relationship); + +=back + +=cut + +sub undeclare { + my $self = shift; + + my (@parmnames) = @_; + + my $parmname; + foreach $parmname (@parmnames) { + $parmname = lc ($parmname); + if (exists $self->{-legal_parms}->{$parmname}) { + delete $self->{-legal_parms}->{$parmname}; + if (exists $self->{-parm_values}->{$parmname}) { + delete $self->{-parm_values}->{$parmname}; + } + } else { + confess (__PACKAGE__ . "::undeclare() - Attempted to undeclare a parameter name ($parmname) that was never declared\n"); + } + } +} + +###################################################################### + +=over 4 + +=item C<exists($parmname);> + +Returns true if the specified parmname has been initialized via 'set'. + +=back + +=cut + +sub exists { + my $self = shift; + + my ($parmname) = @_; + $parmname = lc $parmname; + # The Perl built-in, not us. + CORE::exists $self->{-parm_values}->{$parmname}; +} + +###################################################################### + +=over 4 + +=item C<set($parm_ref);> + +Sets one or more named parameter values. + +Example: + + $self->set({ -thingy => 'test', -other_thingy => 'more stuff' }); + +Will 'confess' if an attempt is made to set an undeclared parameter key. + +=back + +=cut + +sub set { + my $self = shift; + + my $parm_ref = {}; + if ($#_ == 0) { + $parm_ref = shift; + } elsif ($#_ > 0) { + %$parm_ref = @_; + } + + my (@parmnames) = keys %$parm_ref; + my $parmname; + foreach $parmname (@parmnames) { + my $keyname = lc ($parmname); + my $value = $parm_ref->{$parmname}; + confess (__PACKAGE__ . "::set() - Attempted to set an undeclared named parameter: '$keyname'\n") if (not exists $self->{-legal_parms}->{$keyname}); + $self->{-parm_values}->{$keyname} = $value; + } +} + +###################################################################### + +=over 4 + +=item C<clear(@parm_names);> + +Clears (deletes) one or more named parameter values. + +Example: + + $self->clear(-this,-that,-the_other_thing); + +Note: A 'cleared' value returns undef from 'get'. + +=back + +=cut + +sub clear { + my $self = shift; + + my (@parmnames) = @_; + my $parmname; + foreach $parmname (@parmnames) { + my $keyname = lc ($parmname); + confess (__PACKAGE__ . "::clear() - Attempted to clear an undeclared named parameter: '$keyname'\n") if (not exists $self->{-legal_parms}->{$keyname}); + $self->{-parm_values}->{$keyname} = undef; + } +} + +###################################################################### + +=over 4 + +=item C<get(@parm_names);> + +Gets one or more named parameter values. + +Screams and dies (well, 'confess'es) if you attempt to read +a value that has not been initialized. Results are returned +in the same order as the parameter names passed. + +In a scalar context, the _last_ result is what is returned. + +Example: + + my ($age,$gender) = $self->get(-age,-gender); + +Will 'confess' if an attempt is made to access an undeclared key or if +the requested value has not been initialized. + +=back + +=cut + +sub get { + my $self = shift; + + if ($#_ == -1) { confess(__PACKAGE__ . "::get() - Called without any parameters\n"); } + my (@results) = (); + foreach (@_) { + my $keyname = lc $_; + if (not exists $self->{-parm_values}->{$keyname}) { + confess (__PACKAGE__ . "::get() - Attempted to retrieve an undeclared or unitialized named parameter: '$keyname'\n"); + } + push (@results,$self->{-parm_values}->{$keyname}); + } + if (wantarray) { + return @results; + } + $results[$#results]; +} + +################################################################ + +=over 4 + +=item C<all_parms;> + +Returns an anonymous hash containing all the currently +set keys and values. This hash is suitable for usage +with Class::NamedParms or Class::ParmList for setting +keys/values with their 'set' methods. + +It works by making a shallow copy of the data. This means +that it copies the scalar values. In the case of simple +numbers and strings, this produces a new copy, in the case +of references to hashes and arrays or objects, it returns +the reference to the original object such that alterations +of the returned object are reflected in the live copy. + +Example: + + my $parms = $parms->all_parms; + +=back + +=cut + +sub all_parms { + my ($self) = shift; + my (@parm_list) = $self->list_initialized_parms; + my ($all_p) = {}; + foreach my $parm (@parm_list) { + $all_p->{$parm} = $self->get($parm); + } + $all_p; +} + +####################################################################### + +=head1 COPYRIGHT + +Copyright 1999, Benjamin Franz (<URL:http://www.nihongo.org/snowhare/>) and +FreeRun Technologies, Inc. (<URL:http://www.freeruntech.com/>). All Rights Reserved. +This software may be copied or redistributed under the same terms as Perl itelf. + +=head1 AUTHOR + +Benjamin Franz + +=head1 VERSION + + 1.04 + +=head1 TODO + +Debugging. + +=cut + +1; diff --git a/cpan/dist/Class-NamedParms/t/general.t b/cpan/dist/Class-NamedParms/t/general.t new file mode 100755 index 00000000..43a749cc --- /dev/null +++ b/cpan/dist/Class-NamedParms/t/general.t @@ -0,0 +1,97 @@ +#!/usr/bin/perl -w + +use strict; +use lib ('./blib','../lib','./lib'); +use Class::NamedParms; + +my @do_tests=(1..3); + +my $test_subs = { + 1 => { -code => \&test1, -desc => 'set ' }, + 2 => { -code => \&test2, -desc => 'get ' }, + 3 => { -code => \&test3, -desc => 'clear ' }, +}; +print $do_tests[0],'..',$do_tests[$#do_tests],"\n"; +print STDERR "\n"; +my $n_failures = 0; +foreach my $test (@do_tests) { + my $sub = $test_subs->{$test}->{-code}; + my $desc = $test_subs->{$test}->{-desc}; + my $failure = ''; + eval { $failure = &$sub; }; + if ($@) { + $failure = $@; + } + if ($failure ne '') { + chomp $failure; + print "not ok $test\n"; + print STDERR " $desc - $failure\n"; + $n_failures++; + } else { + print "ok $test\n"; + print STDERR " $desc - ok\n"; + + } +} +print "END\n"; +exit; + +######################################## +# set # +######################################## +sub test1 { + eval { + my $class = Class::NamedParms->new(-testing); + $class->set({ -testing => 1 }); + }; + + if ($@) { + return $@; + } + ''; +} + +######################################## +# get # +######################################## +sub test2 { + my $class = Class::NamedParms->new(-testing); + my $test_value = '1.0056'; + $class->set({ -testing => $test_value }); + eval { + my $value = $class->get(-testing); + if ($value ne $test_value) { + return "value returned was not the same as value set\n"; + } + }; + + if ($@) { + return $@; + } + ''; +} + +######################################## +# clear # +######################################## +sub test3 { + eval { + my $class = Class::NamedParms->new(-testing); + my $test_value = '1.0054'; + $class->set({ -testing => $test_value }); + my $value = $class->get(-testing); + if ($value ne $test_value) { + return "value returned was not the same as value set\n"; + } + $class->clear(-testing); + my $new_value = $class->get(-testing); + if (defined $new_value) { + return "failed to clear value\n"; + } + }; + + if ($@) { + return $@; + } + ''; +} diff --git a/cpan/dist/Class-ParmList/CHANGES b/cpan/dist/Class-ParmList/CHANGES new file mode 100644 index 00000000..e04dd146 --- /dev/null +++ b/cpan/dist/Class-ParmList/CHANGES @@ -0,0 +1,11 @@ + 1.00 1999.06.15 - Initial release + + 1.01 1999.06.18 - Performance tweaks. Addition of 'make test' support + + 1.02 1999.06.21 - Fixed '-legal' (broken by performance tweaks in 1.01), + removed use of 'use attrs' for portability, extended + 'make test' tests. + + 1.03 2000.12.06 - Added exportable class functions 'simple_parms' + and 'parse_parms' and allowed 'stacking' references + for parms to the object to improve calling usage. diff --git a/cpan/dist/Class-ParmList/MANIFEST b/cpan/dist/Class-ParmList/MANIFEST new file mode 100644 index 00000000..8ea0467a --- /dev/null +++ b/cpan/dist/Class-ParmList/MANIFEST @@ -0,0 +1,8 @@ +MANIFEST +Makefile.PL +README +CHANGES +lib/Class/ParmList.pm +t/01_object.t +t/02_simple_parms.t +t/03_parse_parms.t diff --git a/cpan/dist/Class-ParmList/Makefile.PL b/cpan/dist/Class-ParmList/Makefile.PL new file mode 100644 index 00000000..72614646 --- /dev/null +++ b/cpan/dist/Class-ParmList/Makefile.PL @@ -0,0 +1,11 @@ +use ExtUtils::MakeMaker; +# See lib/ExtUtils/MakeMaker.pm for details of how to influence +# the contents of the Makefile that is written. +WriteMakefile( + 'NAME' => 'Class::ParmList', + 'VERSION_FROM' => 'lib/Class/ParmList.pm', + 'PREREQ_PM' => {}, + 'linkext' => { LINKTYPE=>'' }, # no link needed + 'dist' => {'COMPRESS'=>'gzip -9f', 'SUFFIX' => 'gz', + 'ZIP' => '/usr/bin/zip','ZIPFLAGS'=>'-rl'} +); diff --git a/cpan/dist/Class-ParmList/README b/cpan/dist/Class-ParmList/README new file mode 100644 index 00000000..5b37c333 --- /dev/null +++ b/cpan/dist/Class-ParmList/README @@ -0,0 +1,33 @@ +Class::ParmList + + General named parameter list parser. Handles default values, + required vs allowed distinctions, optional name lexical checking, + multiple retrieval, and error reporting. Works well as a complement to + Class::NamedParms. + +Changes + 1.00 1999.06.15 - Initial release + + 1.01 1999.06.18 - Performance tweaks. Addition of 'make test' support + + 1.02 1999.06.21 - Fixed '-legal' (broken by performance tweaks in 1.01), + removed use of 'use attrs' for portability, extended + 'make test' tests. + + 1.03 2000.12.06 - Added exportable class functions 'simple_parms' + and 'parse_parms' and allowed 'stacking' references + for parms to the object to improve calling usage. + +To install: + +perl Makefile.PL +make +make test +make install + +Type 'perldoc Class::ParmList' after installation for the documentation +or go to <URL:http://www.nihongo.org/snowhare/utilities/modules/class-parmlist/> + +Copyright 1999, Benjamin Franz (<URL:http://www.nihongo.org/snowhare/>) and +FreeRun Technologies, Inc. (<URL:http://www.freeruntech.com/>). All Rights Reserved. +This software may be copied or redistributed under the same terms as Perl itelf. diff --git a/cpan/dist/Class-ParmList/lib/Class/ParmList.pm b/cpan/dist/Class-ParmList/lib/Class/ParmList.pm new file mode 100644 index 00000000..d7355d4e --- /dev/null +++ b/cpan/dist/Class-ParmList/lib/Class/ParmList.pm @@ -0,0 +1,598 @@ +package Class::ParmList; + +# $RCSfile: ParmList.pm,v $ $Revision: 1.4 $ $Date: 2000/12/07 00:06:26 $ $Author: snowhare $ + +use strict; +use Carp; +use Exporter; +use vars qw (@ISA $VERSION @EXPORT_OK %EXPORT_TAGS @EXPORT); + +BEGIN { + $VERSION = '1.03'; + @ISA = qw (Exporter); + @EXPORT = (); + @EXPORT_OK = qw (simple_parms parse_parms); + %EXPORT_TAGS = (); +} + +my $error = ''; + +=head1 NAME + +Class::ParmList - A collection of routines for processing named parameter lists for method calls. + +=head1 SYNOPSIS + + use Class::ParmList qw(simple_parms parse_parms); + + $thingy->some_method({ + -bgcolor => '#ff0000', + -textcolor => '#000000' + }); + + sub some_method { + my ($self) = shift; + + my ($parm_ref) = @_; + + my $parms = Class::ParmList->new ({ + -parms => $parm_ref, + -legal => [qw (-textcolor -border -cellpadding)], + -required => [qw (-bgcolor)], + -defaults => { + -bgcolor => "#ffffff", + -textcolor => "#000000" + } + }); + + if (not defined $parms) { + my $error_message = Class::ParmList->error; + die ($error_message); + } + + # Stuff... + + } + + sub another_method { + my $self = shift; + my ($name,$rank,$serial_number) = simple_parms([qw(-name -rank -serial_number)], @_); + + #... + } + + sub still_another { + my $parms = parse_parms ({ + -parms => \@_, + -legal => [qw (-textcolor -border -cellpadding)], + -required => [qw (-bgcolor)], + -defaults => { + -bgcolor => "#ffffff", + -textcolor => "#000000" + } + }); + if (not defined $parms) { + my $error_message = Class::ParmList->error; + die ($error_message); + } + + # ... + } + +=head1 DESCRIPTION + +This is a simple package for validating calling parameters to a subroutine or +method. It allows you to use "named parameters" while providing checking for +number and naming of parameters for verifying inputs are as expected and +meet any minimum requirements. It also allows the setting of default +values for the named parameters if omitted. + +=cut + +=head1 CHANGES + + 1.00 1999.06.16 - Initial release + + 1.01 1999.06.18 - Performance tweaks + + 1.02 1999.06.21 - Fixing of failure to catch undeclared parm, + removal of 'use attrs qw(method)', and + extension of 'make test' support. + + 1.03 2000.12.06 - Added exportable class functions 'simple_parms' + and 'parse_parms' and allowed 'stacking' references + for parms to the object to improve calling usage. + +=head1 METHODS + +=over 4 + +=item C<new($parm_list_ref);> + +Returns a reference to an object that can be used to return +values. If an improper specification is passed, returns 'undef'. +Otherwise returns the reference. + +Example: + + my $parms = Class::ParmList->new ({ + -parms => $parm_ref, + -legal => [qw (-textcolor -border -cellpadding)], + -required => [qw (-bgcolor)], + -defaults => { + -bgcolor => "#ffffff", + -textcolor => "#000000" + } + }); +All four parameters (-parms, -legal, -required, and -defaults) are +optional. It is liberal in that anything defined for a -default +or -required is automatically added to the '-legal' list. + +If the '-legal' parameter is not _explicitly_ called out, no +checking against the legal list is done. If it _is_ explicitly +called out, then all -parms are checked against it and it will +fail with an error if a -parms parameter is present but not +defined in the -legal explict or implict definitions. + +To simplify calling routines, the '-parms' parameters is allowed +to 'stack' anon list references: [['parm','value']] + +This gives a calling routine the ability to parse @_ without +jumping through hoops to handle the cases of arrays vs hashes for +the passed parameters. + +Example: + + sub example_sub { + my $parms = Class::ParmList->new({ -parms => \@_, + -legal => [], + -required => ['-file','-data'], + -defaults => {}, + }); + + #... + } + +This routine would accept *either* + + example_sub({ '-file' => 'test', '-data' => 'stuff' }); + +or + + example_sub( '-file' => 'test', '-data' => 'stuff' ); + +with no code changes. + +=back + +=over 4 + +=item C<parse_parms($parm_list_ref);> + +This is a functional equivalent to the 'new' method. Calling +parameters are identical, but it is called as a function +that may be exported. + +Example: + + my $parms = parse_parms({ -parms => \@_, + -legal => [], + -required => ['-file','-data'], + -defaults => {}, + }); + +=back + +=cut + +sub parse_parms { + my $parms = new(__PACKAGE__, @_); + return $parms; +} + +sub new { + my ($something) = shift; + my $package = __PACKAGE__; + my ($class) = ref ($something) || $something || $package; + my $self = bless {},$class; + + # Clear any outstanding errors + $error = ''; + + if (-1 == $#_) { # It's legal to pass no parms. + $self->{-name_list} = []; + $self->{-parms} = {}; + return $self; + } + + my $raw_parm_list = {}; + my $reftype = ref $_[0]; + if ($reftype eq 'HASH') { # A basic HASH setup + ($raw_parm_list) = @_; + } else { # An unwrapped list + %$raw_parm_list = @_; + } + + # Transform to lowercase keys on our own parameters + my $parms = {}; + %$parms = map { (lc($_),$raw_parm_list->{$_}) } keys %$raw_parm_list; + + # Check for bad parms + my @parm_keys = keys %$parms; + my @bad_parm_keys = grep(!/^-(parms|legal|defaults|required)$/,@parm_keys); + if ($#bad_parm_keys > -1) { + $error = "Invalid parameters ("."@bad_parm_keys".") passed to Class::ParmList->new\n"; + return; + } + + my $check_legal = 0; + my $check_required = 0; + + # Legal Parameter names + my $legal_names = {}; + if (defined $parms->{-legal}) { + %$legal_names = map { (lc($_),1) } @{$parms->{-legal}}; + $check_legal = 1; + } + + # Required Parameter names + my $required_names = {}; + if (defined $parms->{-required}) { + my $lk; + %$required_names = map { $lk = lc $_; $legal_names->{$lk} = 1; ($lk,1) } @{$parms->{-required}}; + $check_required = 1; + } + + # Set defaults if needed + my $parm_list = {}; + my $defaults = $parms->{-defaults}; + if (defined $defaults) { + my $lk; + %$parm_list = map { $lk = lc $_; $legal_names->{$lk} = 1; ($lk,$defaults->{$_}) } keys %$defaults; + } + + # The actual list of parms + my $base_parm_list = $parms->{-parms}; + # Unwrap references to ARRAY referenced parms + while (defined($base_parm_list) && (ref($base_parm_list) eq 'ARRAY')) { + my @data = @$base_parm_list; + if ($#data == 0) { + $base_parm_list = $data[0]; + } else { + $base_parm_list = { @data }; + } + } + + if (defined ($base_parm_list)) { + my @key_list = keys %$base_parm_list; + foreach my $key (@key_list) { + $parm_list->{lc($key)} = $base_parm_list->{$key}; + } + } + + # Check for Required parameters + if ($check_required) { + foreach my $name (keys %$required_names) { + next if (exists $parm_list->{$name}); + $error .= "Required parameter '$name' missing\n"; + } + } + + # Check for illegal parameters + my $final_parm_names = [keys %$parm_list]; + if ($check_legal) { + foreach my $name (@$final_parm_names) { + next if (exists $legal_names->{$name}); + $error .= "Parameter '$name' not legal here.\n"; + } + $self->{-legal} = $legal_names; + } + + return if ($error ne ''); + + # Save the parms for accessing + $self->{-name_list} = $final_parm_names; + $self->{-parms} = $parm_list; + + $self; +} + +################################################################ + +=over 4 + +=item C<get($parm_name1,$parm_name2,...);> + +Returns the parameter value(s) specified in the call line. If +a parameter is not defined, it returns undef. If a set of +'-legal' parameters were declared, it croaks if a parameter +not in the '-legal' set is asked for. + +Example: + my ($help,$who) = $parms->get(-help,-who); + +=back + +=cut + +sub get { + my ($self) = shift; + + my (@parmnames) = @_; + if ($#parmnames == -1) { + croak(__PACKAGE__ . '::get() called without any parameters'); + } + my (@results) = (); + my $parmname; + foreach $parmname (@parmnames) { + my $keyname = lc ($parmname); + croak (__PACKAGE__ . "::get() called with an illegal named parameter: '$keyname'") if (exists ($self->{-legal}) and not exists ($self->{-legal}->{$keyname})); + push (@results,$self->{-parms}->{$keyname}); + } + if (wantarray) { + return @results; + } else { + return $results[$#results]; + } +} + +################################################################ + +=over 4 + +=item C<exists($parm_name);> + +Returns true if the parameter specifed by $parm_name (qv. +has been initialized), false if it does not exist. + + if ($parms->exists(-help) { + # do stuff + } + +=back + +=cut + +sub exists { + my ($self) = shift; + + my ($name) = @_; + + $name = lc ($name); + CORE::exists ($self->{-parms}->{$name}); +} + +################################################################ + +=over 4 + +=item C<list_parms;> + +Returns the list of parameter names. (Names are always +presented in lowercase). + +Example: + + my (@parm_names) = $parms->list_parms; + +=back + +=cut + +sub list_parms { + my ($self) = shift; + + my (@names) = @{$self->{-name_list}}; + + return @names; +} + +################################################################ + +=over 4 + +=item C<all_parms;> + +Returns an anonymous hash containing all the currently +set keys and values. This hash is suitable for usage +with Class::NamedParms or Class::ParmList for setting +keys/values. It works by making a shallow copy of +the data. This means that it copies the scalar values. +In the case of simple numbers and strings, this produces +a new copy, in the case of references to hashes and arrays or +objects, it returns the references to the original objects. + +Example: + + my $parms = $parms->all_parms; + +=back + +=cut + +sub all_parms { + my ($self) = shift; + + my (@parm_list) = $self->list_parms; + my ($all_p) = {}; + foreach my $parm (@parm_list) { + $all_p->{$parm} = $self->get($parm); + } + $all_p; +} + +=head1 FUNCTIONS + +################################################################ + +=over 4 + +=item C<error;> + +Returns the error message for the most recent invokation of +'new'. (Static method - does not require an object to function) + +Example: + + my $error_message = Class::ParmList->error; + die ($error_message); + +=back + +=cut + +sub error { + $error; +} + +####################################################################### + +=over 4 + +=item C<simple_parms(['-list','-of','-parameter_names'],@_);> + +Parses the passed named parameter list (croaking/confessing if extra or +missing parameters are found). + +Examples: + + use Class::ParmList qw(simple_parms); + + sub some_method { + my $self = shift; + + my ($name,$rank) = simple_parms([qw(-name -rank)],@_); + # Now do stuff + } + + sub some_function { + my $serial_number = simple_parms([qw(-serial_number)],@_); + # Now do stuff + } + +The passed parameter values for parsing this way may be either an anonymous hash of parameters + +Example: + a_function({ -parm1_name => $parm1_value, -parm2_name => $parm2_value }) ) + +or a straight list of parameters: + +Example: + a_function(-parm1_name => $parm1_value, -parm2_name => $parm2_value) ) + +Note that it *IS* legal for a parameter to be passed with an 'undef' value - it +will not trigger an error. + +If you need optional parameters, this function is not well suited. You should +use the object methods above instead for that case - they are much more +flexible (but quite a bit slower and slightly more complex to use). + +Its main virtues are that is is simple to use, has rugged error checking for +mis-usages and is reasonably fast. + +'simple_parms' can be exported by specifying it on the 'use' line. + +=back + +=cut + +sub simple_parms { + local $SIG{__DIE__} = ''; + my $parm_list = shift; + if (not (ref($parm_list) eq 'ARRAY')) { + confess ('[' . localtime(time) . '] [error] ' . __PACKAGE__ . "::simple_parms() - The first parameter to 'simple_parms()' must be an anonymous list of parameter names."); + } + + if (($#_ > 0) && (($#_ + 1) % 2)) { + confess ('[' . localtime(time) . '] [error] ' . __PACKAGE__ . "::simple_parms() - Odd number of parameter array elements"); + } + + # Read any other passed parms + my ($parm_ref) = {}; + if ($#_ == 0) { + $parm_ref = shift; + } elsif ($#_ > 0) { + if (($#_ + 1) % 2) { + confess ('[' . localtime(time) . '] [error] ' . __PACKAGE__ . "::simple_parms() - Odd number of parameter array elements"); + } + %$parm_ref = @_; + } + + if (ref ($parm_ref) ne 'HASH') { + confess ('[' . localtime(time) . '] [error] ' . __PACKAGE__ . "::simple_parms() - A bad parameter list was passed (not either an anon hash or an array)"); + } + + my @parm_keys = keys %$parm_ref; + if ($#parm_keys != $#$parm_list) { + confess ('[' . localtime(time) . '] [error] ' . __PACKAGE__ . ":simple_parms() - An incorrect number of parameters were passed"); + } + if ($#parm_keys == -1) { + croak ('[' . localtime(time) . '] [error] ' . __PACKAGE__ . "::simple_parms() - At least one parameter is required to be requested"); + } + + my @extra_parms = (); + my %checkoff_parms = (); + my @parsed_parms = (); + foreach my $parm_name (@$parm_list) { + $checkoff_parms{"'$parm_name'"} = 1; + push (@parsed_parms,$parm_ref->{$parm_name}); + } + foreach my $parm_name (@parm_keys) { + if (not exists $parm_ref->{$parm_name}) { + push (@extra_parms,"'$parm_name'"); + } else { + delete $checkoff_parms{"'$parm_name'"}; + } + } + my @missing_parms = keys %checkoff_parms; + my $errors = ''; + if ($#missing_parms > -1) { + $errors = "Parameters " . join (', ',@missing_parms) . " were not found."; + } + if ($#extra_parms > -1) { + $errors .= "Parameters " . join (', ',@extra_parms) . " are not legal here."; + } + if ($errors ne '') { + confess ('[' . localtime(time) . '] [error] ' . __PACKAGE__ . "::simple_parms() - $errors"); + } + if (wantarray) { + return (@parsed_parms); + } + if ($#parsed_parms > 0) { + croak ('[' . localtime(time) . '] [error] ' . __PACKAGE__ . "::simple_parms() - Requested multiple values in a 'SCALAR' context."); + } + $parsed_parms[0]; +} + +####################################################################### +# Non-public methods # +####################################################################### + +####################################################################### + +# Keeps 'AUTOLOAD' from sucking cycles during object destruction +sub DESTROY {} + +####################################################################### + +=head1 VERSION + +1.03 2000.12.06 + +=head1 COPYRIGHT + +Copyright 1999,2000 Benjamin Franz (<URL:http://www.nihongo.org/snowhare/>) and +FreeRun Technologies, Inc. (<URL:http://www.freeruntech.com/>). All Rights Reserved. +This software may be copied or redistributed under the same terms as Perl itelf. + +=head1 AUTHOR + +Benjamin Franz + +=head1 TODO + +Everything. + +=cut + +1; diff --git a/cpan/dist/Class-ParmList/t/01_object.t b/cpan/dist/Class-ParmList/t/01_object.t new file mode 100755 index 00000000..a5bbb6e6 --- /dev/null +++ b/cpan/dist/Class-ParmList/t/01_object.t @@ -0,0 +1,190 @@ +#!/usr/bin/perl -w + +use strict; +use lib ('./blib','../lib','./lib'); +use Class::ParmList; + +my @do_tests=(1..5); + +my $test_subs = { + 1 => { -code => \&test1, -desc => 'legal ' }, + 2 => { -code => \&test2, -desc => 'required ' }, + 3 => { -code => \&test3, -desc => 'defaults ' }, + 4 => { -code => \&test4, -desc => 'stacked parms (hash) ' }, + 5 => { -code => \&test5, -desc => 'stacked parms (list) ' }, +}; +print $do_tests[0],'..',$do_tests[$#do_tests],"\n"; +print STDERR "\n"; +my $n_failures = 0; +foreach my $test (@do_tests) { + my $sub = $test_subs->{$test}->{-code}; + my $desc = $test_subs->{$test}->{-desc}; + my $failure = ''; + eval { $failure = &$sub; }; + if ($@) { + $failure = $@; + } + if ($failure ne '') { + chomp $failure; + print "not ok $test\n"; + print STDERR " $desc - $failure\n"; + $n_failures++; + } else { + print "ok $test\n"; + print STDERR " $desc - ok\n"; + + } +} +print "END\n"; +exit; + +######################################## +# legal # +######################################## +sub test1 { + my $parms = { -test => 'hello' }; + eval { + my $class = Class::ParmList->new({ -parms => $parms, + -defaults => {}, + -required => [], + -legal => [qw(-test)], + }); + if (not defined $class) { + die "failed to create new object and parse data"; + } + my ($test) = $class->get(-test); + }; + + if ($@) { + return $@; + } + eval { + my $class; + $class = Class::ParmList->new({ -parms => $parms, + -defaults => {}, + -required => [], + -legal => [-burp], + }); + if (defined $class) { + die "failed to flag undeclared parameter"; + } + }; + if ($@) { + return $@; + } + ''; +} +######################################## +# required # +######################################## +sub test2 { + my $parms = { -test => 'hello' }; + eval { + my $class = Class::ParmList->new({ -parms => $parms, + -defaults => {}, + -required => [qw(-burp)], + -legal => [qw(-test)], + }); + if (defined $class) { + die "failed to flag missing required parameter"; + } + }; + if ($@) { + return $@; + } + eval { + my $class = Class::ParmList->new({ -parms => $parms, + -defaults => {}, + -required => [qw(-test)], + -legal => [qw(-burp)], + }); + if (not defined $class) { + die "failed to accept required parameter"; + } + }; + if ($@) { + return $@; + } + ''; +} +######################################## +# defaults # +######################################## +sub test3 { + my $parms = { -test => 'hello' }; + eval { + my $class = Class::ParmList->new({ -parms => $parms, + -defaults => {-heathen => 'yes', -test=> 'goodbye' }, + -required => [], + -legal => [qw(-test -heathen)], + }); + if (not defined $class) { + die "failed to flag missing required parameter"; + } + my ($test,$heathen) = $class->get(-test,-heathen); + if ($test ne 'hello') { + return "failed to overwrite default"; + } + if ($heathen ne 'yes') { + return 'failed to set default'; + } + }; + if ($@) { + return $@; + } + ''; +} +######################################## +# stacked parms hash # +######################################## +sub test4 { + my $parms = [{ '-test' => 'hello' }]; + eval { + my $class = Class::ParmList->new({ -parms => $parms, + -defaults => {-heathen => 'yes', -test=> 'goodbye' }, + -required => [], + -legal => [qw(-test -heathen)], + }); + if (not defined $class) { + die "failed to flag missing required parameter"; + } + my ($test,$heathen) = $class->get(-test,-heathen); + if ($test ne 'hello') { + return "failed to overwrite default"; + } + if ($heathen ne 'yes') { + return 'failed to set default'; + } + }; + if ($@) { + return $@; + } + ''; +} +######################################## +# stacked parms list # +######################################## +sub test5 { + my $parms = [ '-test' => 'hello' ]; + eval { + my $class = Class::ParmList->new({ -parms => $parms, + -defaults => {-heathen => 'yes', -test=> 'goodbye' }, + -required => [], + -legal => [qw(-test -heathen)], + }); + if (not defined $class) { + die "failed to flag missing required parameter"; + } + my ($test,$heathen) = $class->get(-test,-heathen); + if ($test ne 'hello') { + return "failed to overwrite default"; + } + if ($heathen ne 'yes') { + return 'failed to set default'; + } + }; + if ($@) { + return $@; + } + ''; +} diff --git a/cpan/dist/Class-ParmList/t/02_simple_parms.t b/cpan/dist/Class-ParmList/t/02_simple_parms.t new file mode 100755 index 00000000..01339efe --- /dev/null +++ b/cpan/dist/Class-ParmList/t/02_simple_parms.t @@ -0,0 +1,150 @@ +#!/usr/bin/perl -w + +use strict; +use lib ('./blib','../blib','../lib','./lib'); +use Class::ParmList qw(simple_parms); + +# General info for writing test modules: +# +# When running as 'make test' the default +# working directory is the one _above_ the +# 't/' directory. + +my @do_tests=(1..5); + +my $test_subs = { + 1 => { -code => \&test1, -desc => ' malformed parameter list ' }, + 2 => { -code => \&test2, -desc => ' correctly formed parameter list ' }, + 3 => { -code => \&test3, -desc => ' missing parameters ' }, + 4 => { -code => \&test4, -desc => ' extra parameters ' }, + 5 => { -code => \&test5, -desc => ' bad context ' }, +}; +print $do_tests[0],'..',$do_tests[$#do_tests],"\n"; +print STDERR "\n"; +my $n_failures = 0; +foreach my $test (@do_tests) { + my $sub = $test_subs->{$test}->{-code}; + my $desc = $test_subs->{$test}->{-desc}; + my $failure = ''; + eval { $failure = &$sub; }; + if ($@) { + $failure = $@; + } + if ($failure ne '') { + chomp $failure; + print "not ok $test\n"; + print STDERR " $desc - $failure\n"; + $n_failures++; + } else { + print "ok $test\n"; + print STDERR " $desc - ok\n"; + + } +} +print "END\n"; +exit; + +######################################## +# malformed parameter lists # +######################################## +sub test1 { + eval { my ($parm1,$parm2) = simple_parms('parm1','parm2','key1','value1'); }; + if (not $@) { return 'Failed to detect simple malformed parameter list (no prototype list)' } + eval { my ($parm1,$parm2) = simple_parms(['parm1','parm2'],'key1'); }; + if (not $@) { return 'Failed to detect hashed malformed parameter list (odd number of parms)' } + eval { my ($parm1,$parm2) = simple_parms(['parm1','parm2'],'key1','value2','key2'); }; + if (not $@) { return 'Failed to detect hashed malformed parameter list (odd number of parms)' } + return ''; +} + +######################################## +# correctly formed parameter lists # +######################################## +sub test2 { + my ($parm1,$parm2,$parm3,$parm4); + eval { ($parm1,$parm2) = simple_parms(['parm1','parm2'],'parm1','value1','parm2','value2'); }; + if ($@) { + return "Failed to parse simple list parameters correctly: $@"; + } + if (($parm1 ne 'value1') || ($parm2 ne 'value2')) { + return 'Failed to parse simple list parameters correctly - returned values were incorrect'; + } + eval { + ($parm1,$parm2,$parm3,$parm4) = simple_parms(['parm1','parm2','earm3','arm4'], + { 'parm1' => 'value1', + 'parm2' => 'value2', + 'earm3' => 'value3', + 'arm4' => 'value4' }); + }; + if ($@) { + return "Failed to parse anon hash parameter correctly: $@"; + } + if (($parm1 ne 'value1') || ($parm2 ne 'value2') || ($parm3 ne 'value3') || ($parm4 ne 'value4')) { + return 'Failed to parse anon hash parameters correctly - returned values were incorrect'; + } + + # Check for ordering dependancies + eval { + ($parm3,$parm1,$parm2,$parm4) = simple_parms(['earm3','parm1','parm2','arm4'], + { 'parm1' => 'value1', + 'parm2' => 'value2', + 'earm3' => 'value3', + 'arm4' => 'value4' }); + }; + if ($@) { + return "Failed to parse anon hash parameter correctly: $@"; + } + if (($parm1 ne 'value1') || ($parm2 ne 'value2') || ($parm3 ne 'value3') || ($parm4 ne 'value4')) { + return 'Failed to parse anon hash parameters correctly - returned values were incorrect when permuted'; + } + return ''; +} + +######################################## +# Missing parameters # +######################################## +sub test3 { + eval { my ($parm1,$parm2) = simple_parms(['parm1','parm2'],'parm1','value1'); }; + if (not $@) { + return "Failed to detect missing parameters in a simple list"; + } + + eval { my ($parm1,$parm2) = simple_parms(['parm1','parm2'],{ 'parm1' => 'value1'} ); }; + if (not $@) { + return "Failed to detect missing parameters in hash list"; + } + return ''; +} + +######################################## +# Extra parameters # +######################################## +sub test4 { + eval { my ($parm1,$parm2) = simple_parms(['parm1','parm2'],'parm1','value1','parm2','value2','parm3','value3'); }; + if (not $@) { + return "Failed to detect extra parameters in a simple list"; + } + + eval { my ($parm1,$parm2) = simple_parms(['parm1','parm2'],{ 'parm1' => 'value1', 'parm2' => 'value2', 'parm3' => 'value3'} ); }; + if (not $@) { + return "Failed to detect extra parameters in hash list"; + } + return ''; +} + +######################################## +# Bad context # +######################################## +sub test5 { + eval { my $parm1 = simple_parms(['parm1','parm2'],'parm1','value1','parm2','value2'); }; + if (not $@) { + return "Failed to detect a bad context for returned results with a simple list"; + } + + eval { my $parm1 = simple_parms(['parm1','parm2'],{ 'parm1' => 'value1', 'parm2' => 'value2'} ); }; + if (not $@) { + return "Failed to detect a bad context for returned results for a hash list"; + } + + return ''; +} diff --git a/cpan/dist/Class-ParmList/t/03_parse_parms.t b/cpan/dist/Class-ParmList/t/03_parse_parms.t new file mode 100755 index 00000000..118aa4bb --- /dev/null +++ b/cpan/dist/Class-ParmList/t/03_parse_parms.t @@ -0,0 +1,190 @@ +#!/usr/bin/perl -w + +use strict; +use lib ('./blib','../lib','./lib'); +use Class::ParmList qw(parse_parms); + +my @do_tests=(1..5); + +my $test_subs = { + 1 => { -code => \&test1, -desc => 'legal ' }, + 2 => { -code => \&test2, -desc => 'required ' }, + 3 => { -code => \&test3, -desc => 'defaults ' }, + 4 => { -code => \&test4, -desc => 'stacked parms (hash) ' }, + 5 => { -code => \&test5, -desc => 'stacked parms (list) ' }, +}; +print $do_tests[0],'..',$do_tests[$#do_tests],"\n"; +print STDERR "\n"; +my $n_failures = 0; +foreach my $test (@do_tests) { + my $sub = $test_subs->{$test}->{-code}; + my $desc = $test_subs->{$test}->{-desc}; + my $failure = ''; + eval { $failure = &$sub; }; + if ($@) { + $failure = $@; + } + if ($failure ne '') { + chomp $failure; + print "not ok $test\n"; + print STDERR " $desc - $failure\n"; + $n_failures++; + } else { + print "ok $test\n"; + print STDERR " $desc - ok\n"; + + } +} +print "END\n"; +exit; + +######################################## +# legal # +######################################## +sub test1 { + my $parms = { -test => 'hello' }; + eval { + my $class = parse_parms({ -parms => $parms, + -defaults => {}, + -required => [], + -legal => [qw(-test)], + }); + if (not defined $class) { + die "failed to create new object and parse data"; + } + my ($test) = $class->get(-test); + }; + + if ($@) { + return $@; + } + eval { + my $class; + $class = parse_parms({ -parms => $parms, + -defaults => {}, + -required => [], + -legal => [-burp], + }); + if (defined $class) { + die "failed to flag undeclared parameter"; + } + }; + if ($@) { + return $@; + } + ''; +} +######################################## +# required # +######################################## +sub test2 { + my $parms = { -test => 'hello' }; + eval { + my $class = parse_parms({ -parms => $parms, + -defaults => {}, + -required => [qw(-burp)], + -legal => [qw(-test)], + }); + if (defined $class) { + die "failed to flag missing required parameter"; + } + }; + if ($@) { + return $@; + } + eval { + my $class = parse_parms({ -parms => $parms, + -defaults => {}, + -required => [qw(-test)], + -legal => [qw(-burp)], + }); + if (not defined $class) { + die "failed to accept required parameter"; + } + }; + if ($@) { + return $@; + } + ''; +} +######################################## +# defaults # +######################################## +sub test3 { + my $parms = { -test => 'hello' }; + eval { + my $class = parse_parms({ -parms => $parms, + -defaults => {-heathen => 'yes', -test=> 'goodbye' }, + -required => [], + -legal => [qw(-test -heathen)], + }); + if (not defined $class) { + die "failed to flag missing required parameter"; + } + my ($test,$heathen) = $class->get(-test,-heathen); + if ($test ne 'hello') { + return "failed to overwrite default"; + } + if ($heathen ne 'yes') { + return 'failed to set default'; + } + }; + if ($@) { + return $@; + } + ''; +} +######################################## +# stacked parms hash # +######################################## +sub test4 { + my $parms = [{ '-test' => 'hello' }]; + eval { + my $class = parse_parms({ -parms => $parms, + -defaults => {-heathen => 'yes', -test=> 'goodbye' }, + -required => [], + -legal => [qw(-test -heathen)], + }); + if (not defined $class) { + die "failed to flag missing required parameter"; + } + my ($test,$heathen) = $class->get(-test,-heathen); + if ($test ne 'hello') { + return "failed to overwrite default"; + } + if ($heathen ne 'yes') { + return 'failed to set default'; + } + }; + if ($@) { + return $@; + } + ''; +} +######################################## +# stacked parms list # +######################################## +sub test5 { + my $parms = [ '-test' => 'hello' ]; + eval { + my $class = parse_parms({ -parms => $parms, + -defaults => {-heathen => 'yes', -test=> 'goodbye' }, + -required => [], + -legal => [qw(-test -heathen)], + }); + if (not defined $class) { + die "failed to flag missing required parameter"; + } + my ($test,$heathen) = $class->get(-test,-heathen); + if ($test ne 'hello') { + return "failed to overwrite default"; + } + if ($heathen ne 'yes') { + return 'failed to set default'; + } + }; + if ($@) { + return $@; + } + ''; +} diff --git a/cpan/lib/Class/NamedParms.pm b/cpan/lib/Class/NamedParms.pm new file mode 100644 index 00000000..2be2e037 --- /dev/null +++ b/cpan/lib/Class/NamedParms.pm @@ -0,0 +1,390 @@ +package Class::NamedParms; + +# $RCSfile: NamedParms.pm,v $ $Revision: 1.1 $ $Date: 1999/06/15 17:25:38 $ $Author: snowhare $ + +use strict; +use Carp; +use vars qw($VERSION); + +$VERSION = '1.04'; + +=head1 NAME + +Class::NamedParms - A lightweight named parameter handling system. + +=head1 SYNOPSIS + + package SomePackage; + use Class::NamedParms; + use vars qw (@ISA); + @ISA=qw(Class::NamedParms); + + sub new { + + my ($proto) = shift; + my ($class) = ref ($proto) || $proto; + + $self = Class::NamedParms->new(-benefits,-costs); + $self = bless $self,$class; + + $self; + } + + $thingy = SomePackage->new; + $thingy->set({ -benefits => 1, -costs => 0.5 }); + my ($costs,$benefits) = $thingy->get(-costs,-benefits); + +=head1 DESCRIPTION + +Provides key name checking for named accessor parameters. This allows +the use of a generic 'get/set' type parameterized accessor while +automatically catching accidental mis-spellings and usage of uninitialized +parameters. This catches a large class of programming errors without requiring +a new accessor for every object parameter. + +=head1 CHANGES + + 1.00 1999.06.16 - Initial release. + + 1.01 1999.06.17 - Bug fix to 'clear' method. Added 'make test' support. + + 1.02 1999.06.18 - Performance tweak to 'get' method. + + 1.03 1999.06.21 - Minor docs tweaks. Removal of 'use attrs' for portability + + 1.04 1999.10.08 - Bug fix to 'all_parms' method + +=head2 Initialization + +=cut + +###################################################################### + +=over 4 + +=item C<new;> + +Creates a new instance of a NamedParms object. + +You can optionally 'declare' the legal parameter keys at the same time. + +Example: + + my $self = Class::NamedParms(-benefits,-costs,-other); + +=back + +=cut + +sub new { + my ($class) = shift; + my $self = bless {},$class; + + $self->{-legal_parms} = {}; + $self->{-parm_values} = {}; + + if ($#_ != -1) { + $self->declare(@_); + } + + $self; +} + +###################################################################### + +=over 4 + +=item C<list_declared_parms;> + +Returns a list of all parm names that have been declared for this +NamedParms object. List is unsorted. + +=back + +=cut + +sub list_declared_parms { + my $self = shift; + + my (@parmnames) = keys %{$self->{-legal_parms}}; + return @parmnames; +} + +###################################################################### + +=over 4 + +=item C<list_initialized_parms;> + +Lists all parms that have had values initialized for this NamedParms object +Returns a list of the parameter names. List is unsorted. + +=back + +=cut + +sub list_initialized_parms { + my $self = shift; + + my (@parmnames) = keys %{$self->{-parm_values}}; + return @parmnames; +} + +###################################################################### + +=over 4 + +=item C<declare($parmname,[$parmname1,...]);> + +Declares one or more parameters for use with the NamedParms object. + +Example: + + $self->declare(-moved_in,-car_key,-house_key,-relationship); + +This *does not* initialize the parameters - only declares them +to be legal for use. + +=back + +=cut + +sub declare { + my $self = shift; + + my (@parmnames) = @_; + + my $parmname; + foreach $parmname (@parmnames) { + $parmname = lc ($parmname); + $self->{-legal_parms}->{$parmname} = 1; + } +} + +###################################################################### + +=over 4 + +=item C<undeclare($parmname,$parmname1,...);> + +'undeclares' one or more parameters for use with the NamedParms object. +This also deletes any values assigned to those parameters. + +Example: + + $self->undeclare(-house_key,-car_key,-relationship); + +=back + +=cut + +sub undeclare { + my $self = shift; + + my (@parmnames) = @_; + + my $parmname; + foreach $parmname (@parmnames) { + $parmname = lc ($parmname); + if (exists $self->{-legal_parms}->{$parmname}) { + delete $self->{-legal_parms}->{$parmname}; + if (exists $self->{-parm_values}->{$parmname}) { + delete $self->{-parm_values}->{$parmname}; + } + } else { + confess (__PACKAGE__ . "::undeclare() - Attempted to undeclare a parameter name ($parmname) that was never declared\n"); + } + } +} + +###################################################################### + +=over 4 + +=item C<exists($parmname);> + +Returns true if the specified parmname has been initialized via 'set'. + +=back + +=cut + +sub exists { + my $self = shift; + + my ($parmname) = @_; + $parmname = lc $parmname; + # The Perl built-in, not us. + CORE::exists $self->{-parm_values}->{$parmname}; +} + +###################################################################### + +=over 4 + +=item C<set($parm_ref);> + +Sets one or more named parameter values. + +Example: + + $self->set({ -thingy => 'test', -other_thingy => 'more stuff' }); + +Will 'confess' if an attempt is made to set an undeclared parameter key. + +=back + +=cut + +sub set { + my $self = shift; + + my $parm_ref = {}; + if ($#_ == 0) { + $parm_ref = shift; + } elsif ($#_ > 0) { + %$parm_ref = @_; + } + + my (@parmnames) = keys %$parm_ref; + my $parmname; + foreach $parmname (@parmnames) { + my $keyname = lc ($parmname); + my $value = $parm_ref->{$parmname}; + confess (__PACKAGE__ . "::set() - Attempted to set an undeclared named parameter: '$keyname'\n") if (not exists $self->{-legal_parms}->{$keyname}); + $self->{-parm_values}->{$keyname} = $value; + } +} + +###################################################################### + +=over 4 + +=item C<clear(@parm_names);> + +Clears (deletes) one or more named parameter values. + +Example: + + $self->clear(-this,-that,-the_other_thing); + +Note: A 'cleared' value returns undef from 'get'. + +=back + +=cut + +sub clear { + my $self = shift; + + my (@parmnames) = @_; + my $parmname; + foreach $parmname (@parmnames) { + my $keyname = lc ($parmname); + confess (__PACKAGE__ . "::clear() - Attempted to clear an undeclared named parameter: '$keyname'\n") if (not exists $self->{-legal_parms}->{$keyname}); + $self->{-parm_values}->{$keyname} = undef; + } +} + +###################################################################### + +=over 4 + +=item C<get(@parm_names);> + +Gets one or more named parameter values. + +Screams and dies (well, 'confess'es) if you attempt to read +a value that has not been initialized. Results are returned +in the same order as the parameter names passed. + +In a scalar context, the _last_ result is what is returned. + +Example: + + my ($age,$gender) = $self->get(-age,-gender); + +Will 'confess' if an attempt is made to access an undeclared key or if +the requested value has not been initialized. + +=back + +=cut + +sub get { + my $self = shift; + + if ($#_ == -1) { confess(__PACKAGE__ . "::get() - Called without any parameters\n"); } + my (@results) = (); + foreach (@_) { + my $keyname = lc $_; + if (not exists $self->{-parm_values}->{$keyname}) { + confess (__PACKAGE__ . "::get() - Attempted to retrieve an undeclared or unitialized named parameter: '$keyname'\n"); + } + push (@results,$self->{-parm_values}->{$keyname}); + } + if (wantarray) { + return @results; + } + $results[$#results]; +} + +################################################################ + +=over 4 + +=item C<all_parms;> + +Returns an anonymous hash containing all the currently +set keys and values. This hash is suitable for usage +with Class::NamedParms or Class::ParmList for setting +keys/values with their 'set' methods. + +It works by making a shallow copy of the data. This means +that it copies the scalar values. In the case of simple +numbers and strings, this produces a new copy, in the case +of references to hashes and arrays or objects, it returns +the reference to the original object such that alterations +of the returned object are reflected in the live copy. + +Example: + + my $parms = $parms->all_parms; + +=back + +=cut + +sub all_parms { + my ($self) = shift; + my (@parm_list) = $self->list_initialized_parms; + my ($all_p) = {}; + foreach my $parm (@parm_list) { + $all_p->{$parm} = $self->get($parm); + } + $all_p; +} + +####################################################################### + +=head1 COPYRIGHT + +Copyright 1999, Benjamin Franz (<URL:http://www.nihongo.org/snowhare/>) and +FreeRun Technologies, Inc. (<URL:http://www.freeruntech.com/>). All Rights Reserved. +This software may be copied or redistributed under the same terms as Perl itelf. + +=head1 AUTHOR + +Benjamin Franz + +=head1 VERSION + + 1.04 + +=head1 TODO + +Debugging. + +=cut + +1; diff --git a/cpan/lib/Class/ParmList.pm b/cpan/lib/Class/ParmList.pm new file mode 100644 index 00000000..d7355d4e --- /dev/null +++ b/cpan/lib/Class/ParmList.pm @@ -0,0 +1,598 @@ +package Class::ParmList; + +# $RCSfile: ParmList.pm,v $ $Revision: 1.4 $ $Date: 2000/12/07 00:06:26 $ $Author: snowhare $ + +use strict; +use Carp; +use Exporter; +use vars qw (@ISA $VERSION @EXPORT_OK %EXPORT_TAGS @EXPORT); + +BEGIN { + $VERSION = '1.03'; + @ISA = qw (Exporter); + @EXPORT = (); + @EXPORT_OK = qw (simple_parms parse_parms); + %EXPORT_TAGS = (); +} + +my $error = ''; + +=head1 NAME + +Class::ParmList - A collection of routines for processing named parameter lists for method calls. + +=head1 SYNOPSIS + + use Class::ParmList qw(simple_parms parse_parms); + + $thingy->some_method({ + -bgcolor => '#ff0000', + -textcolor => '#000000' + }); + + sub some_method { + my ($self) = shift; + + my ($parm_ref) = @_; + + my $parms = Class::ParmList->new ({ + -parms => $parm_ref, + -legal => [qw (-textcolor -border -cellpadding)], + -required => [qw (-bgcolor)], + -defaults => { + -bgcolor => "#ffffff", + -textcolor => "#000000" + } + }); + + if (not defined $parms) { + my $error_message = Class::ParmList->error; + die ($error_message); + } + + # Stuff... + + } + + sub another_method { + my $self = shift; + my ($name,$rank,$serial_number) = simple_parms([qw(-name -rank -serial_number)], @_); + + #... + } + + sub still_another { + my $parms = parse_parms ({ + -parms => \@_, + -legal => [qw (-textcolor -border -cellpadding)], + -required => [qw (-bgcolor)], + -defaults => { + -bgcolor => "#ffffff", + -textcolor => "#000000" + } + }); + if (not defined $parms) { + my $error_message = Class::ParmList->error; + die ($error_message); + } + + # ... + } + +=head1 DESCRIPTION + +This is a simple package for validating calling parameters to a subroutine or +method. It allows you to use "named parameters" while providing checking for +number and naming of parameters for verifying inputs are as expected and +meet any minimum requirements. It also allows the setting of default +values for the named parameters if omitted. + +=cut + +=head1 CHANGES + + 1.00 1999.06.16 - Initial release + + 1.01 1999.06.18 - Performance tweaks + + 1.02 1999.06.21 - Fixing of failure to catch undeclared parm, + removal of 'use attrs qw(method)', and + extension of 'make test' support. + + 1.03 2000.12.06 - Added exportable class functions 'simple_parms' + and 'parse_parms' and allowed 'stacking' references + for parms to the object to improve calling usage. + +=head1 METHODS + +=over 4 + +=item C<new($parm_list_ref);> + +Returns a reference to an object that can be used to return +values. If an improper specification is passed, returns 'undef'. +Otherwise returns the reference. + +Example: + + my $parms = Class::ParmList->new ({ + -parms => $parm_ref, + -legal => [qw (-textcolor -border -cellpadding)], + -required => [qw (-bgcolor)], + -defaults => { + -bgcolor => "#ffffff", + -textcolor => "#000000" + } + }); +All four parameters (-parms, -legal, -required, and -defaults) are +optional. It is liberal in that anything defined for a -default +or -required is automatically added to the '-legal' list. + +If the '-legal' parameter is not _explicitly_ called out, no +checking against the legal list is done. If it _is_ explicitly +called out, then all -parms are checked against it and it will +fail with an error if a -parms parameter is present but not +defined in the -legal explict or implict definitions. + +To simplify calling routines, the '-parms' parameters is allowed +to 'stack' anon list references: [['parm','value']] + +This gives a calling routine the ability to parse @_ without +jumping through hoops to handle the cases of arrays vs hashes for +the passed parameters. + +Example: + + sub example_sub { + my $parms = Class::ParmList->new({ -parms => \@_, + -legal => [], + -required => ['-file','-data'], + -defaults => {}, + }); + + #... + } + +This routine would accept *either* + + example_sub({ '-file' => 'test', '-data' => 'stuff' }); + +or + + example_sub( '-file' => 'test', '-data' => 'stuff' ); + +with no code changes. + +=back + +=over 4 + +=item C<parse_parms($parm_list_ref);> + +This is a functional equivalent to the 'new' method. Calling +parameters are identical, but it is called as a function +that may be exported. + +Example: + + my $parms = parse_parms({ -parms => \@_, + -legal => [], + -required => ['-file','-data'], + -defaults => {}, + }); + +=back + +=cut + +sub parse_parms { + my $parms = new(__PACKAGE__, @_); + return $parms; +} + +sub new { + my ($something) = shift; + my $package = __PACKAGE__; + my ($class) = ref ($something) || $something || $package; + my $self = bless {},$class; + + # Clear any outstanding errors + $error = ''; + + if (-1 == $#_) { # It's legal to pass no parms. + $self->{-name_list} = []; + $self->{-parms} = {}; + return $self; + } + + my $raw_parm_list = {}; + my $reftype = ref $_[0]; + if ($reftype eq 'HASH') { # A basic HASH setup + ($raw_parm_list) = @_; + } else { # An unwrapped list + %$raw_parm_list = @_; + } + + # Transform to lowercase keys on our own parameters + my $parms = {}; + %$parms = map { (lc($_),$raw_parm_list->{$_}) } keys %$raw_parm_list; + + # Check for bad parms + my @parm_keys = keys %$parms; + my @bad_parm_keys = grep(!/^-(parms|legal|defaults|required)$/,@parm_keys); + if ($#bad_parm_keys > -1) { + $error = "Invalid parameters ("."@bad_parm_keys".") passed to Class::ParmList->new\n"; + return; + } + + my $check_legal = 0; + my $check_required = 0; + + # Legal Parameter names + my $legal_names = {}; + if (defined $parms->{-legal}) { + %$legal_names = map { (lc($_),1) } @{$parms->{-legal}}; + $check_legal = 1; + } + + # Required Parameter names + my $required_names = {}; + if (defined $parms->{-required}) { + my $lk; + %$required_names = map { $lk = lc $_; $legal_names->{$lk} = 1; ($lk,1) } @{$parms->{-required}}; + $check_required = 1; + } + + # Set defaults if needed + my $parm_list = {}; + my $defaults = $parms->{-defaults}; + if (defined $defaults) { + my $lk; + %$parm_list = map { $lk = lc $_; $legal_names->{$lk} = 1; ($lk,$defaults->{$_}) } keys %$defaults; + } + + # The actual list of parms + my $base_parm_list = $parms->{-parms}; + # Unwrap references to ARRAY referenced parms + while (defined($base_parm_list) && (ref($base_parm_list) eq 'ARRAY')) { + my @data = @$base_parm_list; + if ($#data == 0) { + $base_parm_list = $data[0]; + } else { + $base_parm_list = { @data }; + } + } + + if (defined ($base_parm_list)) { + my @key_list = keys %$base_parm_list; + foreach my $key (@key_list) { + $parm_list->{lc($key)} = $base_parm_list->{$key}; + } + } + + # Check for Required parameters + if ($check_required) { + foreach my $name (keys %$required_names) { + next if (exists $parm_list->{$name}); + $error .= "Required parameter '$name' missing\n"; + } + } + + # Check for illegal parameters + my $final_parm_names = [keys %$parm_list]; + if ($check_legal) { + foreach my $name (@$final_parm_names) { + next if (exists $legal_names->{$name}); + $error .= "Parameter '$name' not legal here.\n"; + } + $self->{-legal} = $legal_names; + } + + return if ($error ne ''); + + # Save the parms for accessing + $self->{-name_list} = $final_parm_names; + $self->{-parms} = $parm_list; + + $self; +} + +################################################################ + +=over 4 + +=item C<get($parm_name1,$parm_name2,...);> + +Returns the parameter value(s) specified in the call line. If +a parameter is not defined, it returns undef. If a set of +'-legal' parameters were declared, it croaks if a parameter +not in the '-legal' set is asked for. + +Example: + my ($help,$who) = $parms->get(-help,-who); + +=back + +=cut + +sub get { + my ($self) = shift; + + my (@parmnames) = @_; + if ($#parmnames == -1) { + croak(__PACKAGE__ . '::get() called without any parameters'); + } + my (@results) = (); + my $parmname; + foreach $parmname (@parmnames) { + my $keyname = lc ($parmname); + croak (__PACKAGE__ . "::get() called with an illegal named parameter: '$keyname'") if (exists ($self->{-legal}) and not exists ($self->{-legal}->{$keyname})); + push (@results,$self->{-parms}->{$keyname}); + } + if (wantarray) { + return @results; + } else { + return $results[$#results]; + } +} + +################################################################ + +=over 4 + +=item C<exists($parm_name);> + +Returns true if the parameter specifed by $parm_name (qv. +has been initialized), false if it does not exist. + + if ($parms->exists(-help) { + # do stuff + } + +=back + +=cut + +sub exists { + my ($self) = shift; + + my ($name) = @_; + + $name = lc ($name); + CORE::exists ($self->{-parms}->{$name}); +} + +################################################################ + +=over 4 + +=item C<list_parms;> + +Returns the list of parameter names. (Names are always +presented in lowercase). + +Example: + + my (@parm_names) = $parms->list_parms; + +=back + +=cut + +sub list_parms { + my ($self) = shift; + + my (@names) = @{$self->{-name_list}}; + + return @names; +} + +################################################################ + +=over 4 + +=item C<all_parms;> + +Returns an anonymous hash containing all the currently +set keys and values. This hash is suitable for usage +with Class::NamedParms or Class::ParmList for setting +keys/values. It works by making a shallow copy of +the data. This means that it copies the scalar values. +In the case of simple numbers and strings, this produces +a new copy, in the case of references to hashes and arrays or +objects, it returns the references to the original objects. + +Example: + + my $parms = $parms->all_parms; + +=back + +=cut + +sub all_parms { + my ($self) = shift; + + my (@parm_list) = $self->list_parms; + my ($all_p) = {}; + foreach my $parm (@parm_list) { + $all_p->{$parm} = $self->get($parm); + } + $all_p; +} + +=head1 FUNCTIONS + +################################################################ + +=over 4 + +=item C<error;> + +Returns the error message for the most recent invokation of +'new'. (Static method - does not require an object to function) + +Example: + + my $error_message = Class::ParmList->error; + die ($error_message); + +=back + +=cut + +sub error { + $error; +} + +####################################################################### + +=over 4 + +=item C<simple_parms(['-list','-of','-parameter_names'],@_);> + +Parses the passed named parameter list (croaking/confessing if extra or +missing parameters are found). + +Examples: + + use Class::ParmList qw(simple_parms); + + sub some_method { + my $self = shift; + + my ($name,$rank) = simple_parms([qw(-name -rank)],@_); + # Now do stuff + } + + sub some_function { + my $serial_number = simple_parms([qw(-serial_number)],@_); + # Now do stuff + } + +The passed parameter values for parsing this way may be either an anonymous hash of parameters + +Example: + a_function({ -parm1_name => $parm1_value, -parm2_name => $parm2_value }) ) + +or a straight list of parameters: + +Example: + a_function(-parm1_name => $parm1_value, -parm2_name => $parm2_value) ) + +Note that it *IS* legal for a parameter to be passed with an 'undef' value - it +will not trigger an error. + +If you need optional parameters, this function is not well suited. You should +use the object methods above instead for that case - they are much more +flexible (but quite a bit slower and slightly more complex to use). + +Its main virtues are that is is simple to use, has rugged error checking for +mis-usages and is reasonably fast. + +'simple_parms' can be exported by specifying it on the 'use' line. + +=back + +=cut + +sub simple_parms { + local $SIG{__DIE__} = ''; + my $parm_list = shift; + if (not (ref($parm_list) eq 'ARRAY')) { + confess ('[' . localtime(time) . '] [error] ' . __PACKAGE__ . "::simple_parms() - The first parameter to 'simple_parms()' must be an anonymous list of parameter names."); + } + + if (($#_ > 0) && (($#_ + 1) % 2)) { + confess ('[' . localtime(time) . '] [error] ' . __PACKAGE__ . "::simple_parms() - Odd number of parameter array elements"); + } + + # Read any other passed parms + my ($parm_ref) = {}; + if ($#_ == 0) { + $parm_ref = shift; + } elsif ($#_ > 0) { + if (($#_ + 1) % 2) { + confess ('[' . localtime(time) . '] [error] ' . __PACKAGE__ . "::simple_parms() - Odd number of parameter array elements"); + } + %$parm_ref = @_; + } + + if (ref ($parm_ref) ne 'HASH') { + confess ('[' . localtime(time) . '] [error] ' . __PACKAGE__ . "::simple_parms() - A bad parameter list was passed (not either an anon hash or an array)"); + } + + my @parm_keys = keys %$parm_ref; + if ($#parm_keys != $#$parm_list) { + confess ('[' . localtime(time) . '] [error] ' . __PACKAGE__ . ":simple_parms() - An incorrect number of parameters were passed"); + } + if ($#parm_keys == -1) { + croak ('[' . localtime(time) . '] [error] ' . __PACKAGE__ . "::simple_parms() - At least one parameter is required to be requested"); + } + + my @extra_parms = (); + my %checkoff_parms = (); + my @parsed_parms = (); + foreach my $parm_name (@$parm_list) { + $checkoff_parms{"'$parm_name'"} = 1; + push (@parsed_parms,$parm_ref->{$parm_name}); + } + foreach my $parm_name (@parm_keys) { + if (not exists $parm_ref->{$parm_name}) { + push (@extra_parms,"'$parm_name'"); + } else { + delete $checkoff_parms{"'$parm_name'"}; + } + } + my @missing_parms = keys %checkoff_parms; + my $errors = ''; + if ($#missing_parms > -1) { + $errors = "Parameters " . join (', ',@missing_parms) . " were not found."; + } + if ($#extra_parms > -1) { + $errors .= "Parameters " . join (', ',@extra_parms) . " are not legal here."; + } + if ($errors ne '') { + confess ('[' . localtime(time) . '] [error] ' . __PACKAGE__ . "::simple_parms() - $errors"); + } + if (wantarray) { + return (@parsed_parms); + } + if ($#parsed_parms > 0) { + croak ('[' . localtime(time) . '] [error] ' . __PACKAGE__ . "::simple_parms() - Requested multiple values in a 'SCALAR' context."); + } + $parsed_parms[0]; +} + +####################################################################### +# Non-public methods # +####################################################################### + +####################################################################### + +# Keeps 'AUTOLOAD' from sucking cycles during object destruction +sub DESTROY {} + +####################################################################### + +=head1 VERSION + +1.03 2000.12.06 + +=head1 COPYRIGHT + +Copyright 1999,2000 Benjamin Franz (<URL:http://www.nihongo.org/snowhare/>) and +FreeRun Technologies, Inc. (<URL:http://www.freeruntech.com/>). All Rights Reserved. +This software may be copied or redistributed under the same terms as Perl itelf. + +=head1 AUTHOR + +Benjamin Franz + +=head1 TODO + +Everything. + +=cut + +1; |
