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