summaryrefslogtreecommitdiff
path: root/cpan/dist
diff options
context:
space:
mode:
authorfukachan <fukachan>2001-04-01 14:22:59 +0000
committerfukachan <fukachan>2001-04-01 14:22:59 +0000
commita69f2d3da0f33207fc9327b488bf55b32501d377 (patch)
treed94e92a8230017d17da252c1bfe424b8a51aa245 /cpan/dist
parent996850c6f7fcfd64d9dca3309a27802f909a5a58 (diff)
downloadfml8-a69f2d3da0f33207fc9327b488bf55b32501d377.tar.gz
fml8-a69f2d3da0f33207fc9327b488bf55b32501d377.tar.bz2
fml8-a69f2d3da0f33207fc9327b488bf55b32501d377.zip
Initial revision
Diffstat (limited to 'cpan/dist')
-rw-r--r--cpan/dist/Class-NamedParms/MANIFEST5
-rw-r--r--cpan/dist/Class-NamedParms/Makefile.PL11
-rw-r--r--cpan/dist/Class-NamedParms/README31
-rw-r--r--cpan/dist/Class-NamedParms/lib/Class/NamedParms.pm390
-rwxr-xr-xcpan/dist/Class-NamedParms/t/general.t97
-rw-r--r--cpan/dist/Class-ParmList/CHANGES11
-rw-r--r--cpan/dist/Class-ParmList/MANIFEST8
-rw-r--r--cpan/dist/Class-ParmList/Makefile.PL11
-rw-r--r--cpan/dist/Class-ParmList/README33
-rw-r--r--cpan/dist/Class-ParmList/lib/Class/ParmList.pm598
-rwxr-xr-xcpan/dist/Class-ParmList/t/01_object.t190
-rwxr-xr-xcpan/dist/Class-ParmList/t/02_simple_parms.t150
-rwxr-xr-xcpan/dist/Class-ParmList/t/03_parse_parms.t190
13 files changed, 1725 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 $@;
+ }
+ '';
+}