summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorfukachan <fukachan>2006-01-01 14:47:49 +0000
committerfukachan <fukachan>2006-01-01 14:47:49 +0000
commit0722f15fe24ff3f66e932aa2418c8abb28f6550b (patch)
treed3340149741eae147392c0af1241c5e28de8096e
parent21fe11b978e0d7a0eb82db4683ffd26a9d02a82a (diff)
downloadfml8-0722f15fe24ff3f66e932aa2418c8abb28f6550b.tar.gz
fml8-0722f15fe24ff3f66e932aa2418c8abb28f6550b.tar.bz2
fml8-0722f15fe24ff3f66e932aa2418c8abb28f6550b.zip
not used, so removed:
Class::NamedParms Class::ParmList
-rw-r--r--cpan/MANIFEST5
-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
-rw-r--r--cpan/lib/Class/NamedParms.pm390
-rw-r--r--cpan/lib/Class/ParmList.pm598
16 files changed, 1 insertions, 2717 deletions
diff --git a/cpan/MANIFEST b/cpan/MANIFEST
index 3dbab8db..de89740a 100644
--- a/cpan/MANIFEST
+++ b/cpan/MANIFEST
@@ -4,9 +4,6 @@
----------------------------------------------------------------
AsciiDB-TagFile 1.05 perl itself
-Class-NamedParms 1.04 perl itself
-Class-ParmList 1.03 perl itself
-
Crypt-RandPasswd 0.02 perl itself
Crypt-TripleDES 0.24 perl itself
Crypt-UnixCrypt 1.0 perl itself
@@ -43,4 +40,4 @@ Text-CSV 0.01 perl itself
Unicode-Japanese 0.09 perl itself
-$FML: MANIFEST,v 1.11 2003/09/19 13:10:46 fukachan Exp $
+$FML: MANIFEST,v 1.12 2005/06/02 11:47:45 fukachan Exp $
diff --git a/cpan/dist/Class-NamedParms/MANIFEST b/cpan/dist/Class-NamedParms/MANIFEST
deleted file mode 100644
index 4c888864..00000000
--- a/cpan/dist/Class-NamedParms/MANIFEST
+++ /dev/null
@@ -1,5 +0,0 @@
-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
deleted file mode 100644
index 4b5a6fd6..00000000
--- a/cpan/dist/Class-NamedParms/Makefile.PL
+++ /dev/null
@@ -1,11 +0,0 @@
-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
deleted file mode 100644
index a53829c5..00000000
--- a/cpan/dist/Class-NamedParms/README
+++ /dev/null
@@ -1,31 +0,0 @@
-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
deleted file mode 100644
index 2be2e037..00000000
--- a/cpan/dist/Class-NamedParms/lib/Class/NamedParms.pm
+++ /dev/null
@@ -1,390 +0,0 @@
-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
deleted file mode 100755
index 43a749cc..00000000
--- a/cpan/dist/Class-NamedParms/t/general.t
+++ /dev/null
@@ -1,97 +0,0 @@
-#!/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
deleted file mode 100644
index e04dd146..00000000
--- a/cpan/dist/Class-ParmList/CHANGES
+++ /dev/null
@@ -1,11 +0,0 @@
- 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
deleted file mode 100644
index 8ea0467a..00000000
--- a/cpan/dist/Class-ParmList/MANIFEST
+++ /dev/null
@@ -1,8 +0,0 @@
-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
deleted file mode 100644
index 72614646..00000000
--- a/cpan/dist/Class-ParmList/Makefile.PL
+++ /dev/null
@@ -1,11 +0,0 @@
-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
deleted file mode 100644
index 5b37c333..00000000
--- a/cpan/dist/Class-ParmList/README
+++ /dev/null
@@ -1,33 +0,0 @@
-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
deleted file mode 100644
index d7355d4e..00000000
--- a/cpan/dist/Class-ParmList/lib/Class/ParmList.pm
+++ /dev/null
@@ -1,598 +0,0 @@
-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
deleted file mode 100755
index a5bbb6e6..00000000
--- a/cpan/dist/Class-ParmList/t/01_object.t
+++ /dev/null
@@ -1,190 +0,0 @@
-#!/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
deleted file mode 100755
index 01339efe..00000000
--- a/cpan/dist/Class-ParmList/t/02_simple_parms.t
+++ /dev/null
@@ -1,150 +0,0 @@
-#!/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
deleted file mode 100755
index 118aa4bb..00000000
--- a/cpan/dist/Class-ParmList/t/03_parse_parms.t
+++ /dev/null
@@ -1,190 +0,0 @@
-#!/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
deleted file mode 100644
index 2be2e037..00000000
--- a/cpan/lib/Class/NamedParms.pm
+++ /dev/null
@@ -1,390 +0,0 @@
-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
deleted file mode 100644
index d7355d4e..00000000
--- a/cpan/lib/Class/ParmList.pm
+++ /dev/null
@@ -1,598 +0,0 @@
-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;