Commit | Line | Data |
642e522c |
1 | |
2 | package Compress::Zlib::ParseParameters ; |
3 | |
4 | use strict; |
5 | use warnings; |
6 | use Carp; |
7 | |
8 | require Exporter; |
9 | our ($VERSION, @ISA, @EXPORT); |
1a6a8453 |
10 | $VERSION = '2.000_07'; |
642e522c |
11 | @ISA = qw(Exporter); |
12 | |
13 | use constant Parse_any => 0x01; |
14 | use constant Parse_unsigned => 0x02; |
15 | use constant Parse_signed => 0x04; |
16 | use constant Parse_boolean => 0x08; |
17 | use constant Parse_string => 0x10; |
18 | use constant Parse_custom => 0x12; |
19 | |
20 | use constant Parse_store_ref => 0x100 ; |
21 | |
22 | use constant OFF_PARSED => 0 ; |
23 | use constant OFF_TYPE => 1 ; |
24 | use constant OFF_DEFAULT => 2 ; |
25 | use constant OFF_FIXED => 3 ; |
1a6a8453 |
26 | use constant OFF_FIRST_ONLY => 4 ; |
27 | use constant OFF_STICKY => 5 ; |
642e522c |
28 | |
29 | push @EXPORT, qw( ParseParameters |
30 | Parse_any Parse_unsigned Parse_signed |
31 | Parse_boolean Parse_custom Parse_string |
32 | Parse_store_ref |
33 | ); |
34 | |
35 | sub ParseParameters |
36 | { |
37 | my $level = shift || 0 ; |
38 | |
39 | my $sub = (caller($level + 1))[3] ; |
40 | local $Carp::CarpLevel = 1 ; |
41 | my $p = new Compress::Zlib::ParseParameters() ; |
42 | $p->parse(@_) |
43 | or croak "$sub: $p->{Error}" ; |
44 | |
45 | return $p; |
46 | } |
47 | |
48 | sub new |
49 | { |
50 | my $class = shift ; |
1a6a8453 |
51 | |
642e522c |
52 | my $obj = { Error => '', |
53 | Got => {}, |
54 | } ; |
55 | |
56 | #return bless $obj, ref($class) || $class || __PACKAGE__ ; |
57 | return bless $obj ; |
58 | } |
59 | |
60 | sub setError |
61 | { |
62 | my $self = shift ; |
63 | my $error = shift ; |
64 | my $retval = @_ ? shift : undef ; |
65 | |
66 | $self->{Error} = $error ; |
67 | return $retval; |
68 | } |
69 | |
70 | #sub getError |
71 | #{ |
72 | # my $self = shift ; |
73 | # return $self->{Error} ; |
74 | #} |
75 | |
76 | sub parse |
77 | { |
78 | my $self = shift ; |
79 | |
80 | my $default = shift ; |
81 | |
1a6a8453 |
82 | my $got = $self->{Got} ; |
83 | my $firstTime = keys %{ $got } == 0 ; |
84 | |
642e522c |
85 | my (@Bad) ; |
86 | my @entered = () ; |
87 | |
88 | # Allow the options to be passed as a hash reference or |
89 | # as the complete hash. |
90 | if (@_ == 0) { |
91 | @entered = () ; |
92 | } |
93 | elsif (@_ == 1) { |
94 | my $href = $_[0] ; |
95 | return $self->setError("Expected even number of parameters, got 1") |
96 | if ! defined $href or ! ref $href or ref $href ne "HASH" ; |
97 | |
98 | foreach my $key (keys %$href) { |
99 | push @entered, $key ; |
100 | push @entered, \$href->{$key} ; |
101 | } |
102 | } |
103 | else { |
104 | my $count = @_; |
105 | return $self->setError("Expected even number of parameters, got $count") |
106 | if $count % 2 != 0 ; |
107 | |
108 | for my $i (0.. $count / 2 - 1) { |
109 | push @entered, $_[2* $i] ; |
110 | push @entered, \$_[2* $i+1] ; |
111 | } |
112 | } |
113 | |
114 | |
642e522c |
115 | while (my ($key, $v) = each %$default) |
116 | { |
1a6a8453 |
117 | croak "need 4 params [@$v]" |
118 | if @$v != 4 ; |
119 | |
120 | my ($first_only, $sticky, $type, $value) = @$v ; |
642e522c |
121 | my $x ; |
122 | $self->_checkType($key, \$value, $type, 0, \$x) |
123 | or return undef ; |
1a6a8453 |
124 | |
125 | $key = lc $key; |
126 | |
127 | if ($firstTime || ! $sticky) { |
128 | $got->{$key} = [0, $type, $value, $x, $first_only, $sticky] ; |
129 | } |
130 | |
131 | $got->{$key}[OFF_PARSED] = 0 ; |
642e522c |
132 | } |
133 | |
134 | for my $i (0.. @entered / 2 - 1) { |
135 | my $key = $entered[2* $i] ; |
136 | my $value = $entered[2* $i+1] ; |
137 | |
138 | #print "Key [$key] Value [$value]" ; |
139 | #print defined $$value ? "[$$value]\n" : "[undef]\n"; |
140 | |
141 | $key =~ s/^-// ; |
1a6a8453 |
142 | my $canonkey = lc $key; |
642e522c |
143 | |
1a6a8453 |
144 | if ($got->{$canonkey} && ($firstTime || |
145 | ! $got->{$canonkey}[OFF_FIRST_ONLY] )) |
642e522c |
146 | { |
1a6a8453 |
147 | my $type = $got->{$canonkey}[OFF_TYPE] ; |
642e522c |
148 | my $s ; |
149 | $self->_checkType($key, $value, $type, 1, \$s) |
150 | or return undef ; |
151 | #$value = $$value unless $type & Parse_store_ref ; |
152 | $value = $$value ; |
1a6a8453 |
153 | $got->{$canonkey} = [1, $type, $value, $s] ; |
642e522c |
154 | } |
155 | else |
156 | { push (@Bad, $key) } |
157 | } |
158 | |
159 | if (@Bad) { |
160 | my ($bad) = join(", ", @Bad) ; |
161 | return $self->setError("unknown key value(s) @Bad") ; |
162 | } |
163 | |
642e522c |
164 | return 1; |
165 | } |
166 | |
167 | sub _checkType |
168 | { |
169 | my $self = shift ; |
170 | |
171 | my $key = shift ; |
172 | my $value = shift ; |
173 | my $type = shift ; |
174 | my $validate = shift ; |
175 | my $output = shift; |
176 | |
177 | #local $Carp::CarpLevel = $level ; |
178 | #print "PARSE $type $key $value $validate $sub\n" ; |
179 | if ( $type & Parse_store_ref) |
180 | { |
181 | #$value = $$value |
182 | # if ref ${ $value } ; |
183 | |
184 | $$output = $value ; |
185 | return 1; |
186 | } |
187 | |
188 | $value = $$value ; |
189 | |
190 | if ($type & Parse_any) |
191 | { |
192 | $$output = $value ; |
193 | return 1; |
194 | } |
195 | elsif ($type & Parse_unsigned) |
196 | { |
1a6a8453 |
197 | return $self->setError("Parameter '$key' must be an unsigned int, got 'undef'") |
642e522c |
198 | if $validate && ! defined $value ; |
199 | return $self->setError("Parameter '$key' must be an unsigned int, got '$value'") |
200 | if $validate && $value !~ /^\d+$/; |
201 | |
202 | $$output = defined $value ? $value : 0 ; |
203 | return 1; |
204 | } |
205 | elsif ($type & Parse_signed) |
206 | { |
1a6a8453 |
207 | return $self->setError("Parameter '$key' must be a signed int, got 'undef'") |
642e522c |
208 | if $validate && ! defined $value ; |
209 | return $self->setError("Parameter '$key' must be a signed int, got '$value'") |
210 | if $validate && $value !~ /^-?\d+$/; |
211 | |
212 | $$output = defined $value ? $value : 0 ; |
213 | return 1 ; |
214 | } |
215 | elsif ($type & Parse_boolean) |
216 | { |
1a6a8453 |
217 | return $self->setError("Parameter '$key' must be an int, got '$value'") |
218 | if $validate && defined $value && $value !~ /^\d*$/; |
642e522c |
219 | $$output = defined $value ? $value != 0 : 0 ; |
220 | return 1; |
221 | } |
222 | elsif ($type & Parse_string) |
223 | { |
224 | $$output = defined $value ? $value : "" ; |
225 | return 1; |
226 | } |
227 | |
228 | $$output = $value ; |
229 | return 1; |
230 | } |
231 | |
232 | |
233 | |
234 | sub parsed |
235 | { |
236 | my $self = shift ; |
237 | my $name = shift ; |
238 | |
239 | return $self->{Got}{lc $name}[OFF_PARSED] ; |
240 | } |
241 | |
242 | sub value |
243 | { |
244 | my $self = shift ; |
245 | my $name = shift ; |
246 | |
247 | if (@_) |
248 | { |
249 | $self->{Got}{lc $name}[OFF_PARSED] = 1; |
250 | $self->{Got}{lc $name}[OFF_DEFAULT] = $_[0] ; |
251 | $self->{Got}{lc $name}[OFF_FIXED] = $_[0] ; |
252 | } |
253 | |
254 | return $self->{Got}{lc $name}[OFF_FIXED] ; |
255 | } |
256 | |
257 | sub valueOrDefault |
258 | { |
259 | my $self = shift ; |
260 | my $name = shift ; |
261 | my $default = shift ; |
262 | |
263 | my $value = $self->{Got}{lc $name}[OFF_DEFAULT] ; |
264 | |
265 | return $value if defined $value ; |
266 | return $default ; |
267 | } |
268 | |
269 | sub wantValue |
270 | { |
271 | my $self = shift ; |
272 | my $name = shift ; |
273 | |
274 | return defined $self->{Got}{lc $name}[OFF_DEFAULT] ; |
275 | |
276 | } |
277 | |
1a6a8453 |
278 | sub clone |
279 | { |
280 | my $self = shift ; |
281 | my $obj = { }; |
282 | my %got ; |
283 | |
284 | while (my ($k, $v) = each %{ $self->{Got} }) { |
285 | $got{$k} = [ @$v ]; |
286 | } |
287 | |
288 | $obj->{Error} = $self->{Error}; |
289 | $obj->{Got} = \%got ; |
290 | |
291 | return bless $obj ; |
292 | } |
293 | |
642e522c |
294 | 1; |
295 | |