File Coverage

lib/Class/NamedParms.pm
Criterion Covered Total %
statement 109 109 100.0
branch 38 38 100.0
condition n/a
subroutine 13 13 100.0
pod 10 10 100.0
total 170 170 100.0


line stmt bran cond sub pod time code
1             package Class::NamedParms;
2              
3 2     2   3813 use strict;
  2         10  
  2         59  
4 2     2   9 use warnings;
  2         3  
  2         67  
5              
6             BEGIN {
7 2     2   2251 $Class::NamedParms::VERSION = '1.07';
8             }
9              
10             ######################################################################
11              
12             sub new {
13 27     27 1 2099 my $proto = shift;
14 27         33 my $package = __PACKAGE__;
15 27         60 my $class;
16 27 100       54 if (ref($proto)) {
    100          
17 1         4 $class = ref($proto);
18             } elsif ($proto) {
19 25         28 $class = $proto;
20             } else {
21 1         1 $class = $package;
22             }
23 27         46 my $self = bless {},$class;
24            
25 27         35 my $vars = {};
26 27         46 $self->{$package} = $vars;
27 27         37 $vars->{-legal_parms} = {};
28 27         32 $vars->{-parm_values} = {};
29              
30 27 100       53 if ($#_ != -1) {
31 22         41 $self->declare(@_);
32             }
33              
34 27         57 $self;
35             }
36              
37             ######################################################################
38              
39             sub list_declared_parms {
40 2     2 1 11 my $self = shift;
41 2         4 my $package = __PACKAGE__;
42 2 100       8 my $vars = $self->{$package} ? $self->{$package} : $self;
43              
44 2         4 my @parmnames = keys %{$vars->{-legal_parms}};
  2         8  
45 2         6 return @parmnames;
46             }
47              
48             ######################################################################
49              
50             sub list_initialized_parms {
51 4     4 1 18 my $self = shift;
52              
53 4         7 my $package = __PACKAGE__;
54 4 100       9 my $vars = $self->{$package} ? $self->{$package} : $self;
55              
56 4         6 my @parmnames = keys %{$vars->{-parm_values}};
  4         14  
57 4         10 return @parmnames;
58             }
59              
60             ######################################################################
61              
62             sub declare {
63 23     23 1 34 my $self = shift;
64              
65 23         38 my @parmnames = @_;
66              
67 23         24 my $package = __PACKAGE__;
68 23 100       45 my $vars = $self->{$package} ? $self->{$package} : $self;
69              
70 23         27 foreach my $parmname (@parmnames) {
71 38         53 $parmname = lc ($parmname);
72 38         67 $vars->{-legal_parms}->{$parmname} = 1;
73             }
74 23         34 return;
75             }
76              
77             ######################################################################
78              
79             sub undeclare {
80 4     4 1 297 my $self = shift;
81              
82 4         4 my $package = __PACKAGE__;
83 4 100       11 my $vars = $self->{$package} ? $self->{$package} : $self;
84              
85 4         9 my @parmnames = @_;
86              
87 4         8 foreach my $parmname (@parmnames) {
88 4         9 $parmname = lc ($parmname);
89 4 100       10 unless (CORE::exists $vars->{-legal_parms}->{$parmname}) {
90 2         11 require Carp;
91 2         169 Carp::confess (__PACKAGE__ . "::undeclare() - Attempted to undeclare a parameter name ($parmname) that was never declared\n");
92             }
93 2         5 delete $vars->{-legal_parms}->{$parmname};
94 2         6 delete $vars->{-parm_values}->{$parmname};
95             }
96             }
97              
98             ######################################################################
99              
100             sub exists {
101 6     6 1 32 my $self = shift;
102              
103 6         18 my $package = __PACKAGE__;
104 6 100       11 my $vars = $self->{$package} ? $self->{$package} : $self;
105              
106 6         12 my ($parmname) = @_;
107 6         9 $parmname = lc $parmname;
108 6         12 return CORE::exists $vars->{-parm_values}->{$parmname};
109             }
110              
111             ######################################################################
112              
113             sub set {
114 20     20 1 128 my $self = shift;
115              
116 20         21 my $parm_ref;
117 20 100       38 if ($#_ == 0) {
    100          
118 16         18 $parm_ref = shift;
119             } elsif ($#_ > 0) {
120 2         5 $parm_ref = { @_ };
121             } else {
122 2         13 $parm_ref = {};
123             }
124            
125 20         32 my $package = __PACKAGE__;
126 20 100       33 my $vars = $self->{$package} ? $self->{$package} : $self;
127              
128 20         45 my @parmnames = keys %$parm_ref;
129 20         31 foreach my $parmname (@parmnames) {
130 28         36 my $keyname = lc ($parmname);
131 28         31 my $value = $parm_ref->{$parmname};
132 28 100       47 unless (CORE::exists $vars->{-legal_parms}->{$keyname}) {
133 2         33 require Carp;
134 2         427 Carp::confess (__PACKAGE__ . "::set() - Attempted to set an undeclared named parameter: '$keyname'\n");
135             }
136 26         50 $vars->{-parm_values}->{$keyname} = $value;
137             }
138 18         64 return;
139             }
140              
141             ######################################################################
142              
143             sub clear {
144 4     4 1 24 my $self = shift;
145              
146 4         9 my @parmnames = @_;
147              
148 4         6 my $package = __PACKAGE__;
149 4 100       12 my $vars = $self->{$package} ? $self->{$package} : $self;
150              
151 4         7 foreach my $parmname (@parmnames) {
152 4         6 my $keyname = lc ($parmname);
153 4 100       11 unless (CORE::exists $vars->{-legal_parms}->{$keyname}) {
154 2         11 require Carp;
155 2         185 Carp::confess (__PACKAGE__ . "::clear() - Attempted to clear an undeclared named parameter: '$keyname'\n");
156             }
157 2         5 $vars->{-parm_values}->{$keyname} = undef;
158             }
159 2         5 return;
160             }
161              
162             ######################################################################
163              
164             sub get {
165 24     24 1 422 my $self = shift;
166              
167 24 100       67 if ($#_ == -1) {
168 2         12 require Carp;
169 2         216 Carp::confess(__PACKAGE__ . "::get() - Called without any parameters\n");
170             }
171              
172 22         24 my $package = __PACKAGE__;
173 22 100       37 my $vars = $self->{$package} ? $self->{$package} : $self;
174              
175 22         24 my @results = ();
176 22         33 foreach (@_) {
177 30         42 my $keyname = lc ($_);
178 30 100       47 unless (CORE::exists $vars->{-parm_values}->{$keyname}) {
179 6         27 require Carp;
180 6         600 Carp::confess (__PACKAGE__ . "::get() - Attempted to retrieve an undeclared or unitialized named parameter: '$keyname'\n");
181             }
182 24         40 push (@results,$vars->{-parm_values}->{$keyname});
183             }
184 16 100       28 if (wantarray) {
185 2         9 return @results;
186             }
187 14         34 return $results[$#results];
188             }
189              
190             ################################################################
191              
192             sub all_parms {
193 2     2 1 12 my $self = shift;
194              
195 2         4 my @parm_list = $self->list_initialized_parms;
196 2         5 my $all_p = {};
197 2         4 foreach my $parm (@parm_list) {
198 4         8 $all_p->{$parm} = $self->get($parm);
199             }
200 2         6 return $all_p;
201             }
202              
203             #################################################################
204              
205             1;