ext/Compress/Zlib/lib/Compress/Zlib/ParseParameters.pm

   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_07';
  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 use constant OFF_FIRST_ONLY => 4 ;
  27 use constant OFF_STICKY     => 5 ;
  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 ;
  51
  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
  82     my $got = $self->{Got} ;
  83     my $firstTime = keys %{ $got } == 0 ;
  84
  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
 115     while (my ($key, $v) = each %$default)
 116     {
 117         croak "need 4 params [@$v]"
 118             if @$v != 4 ;
 119
 120         my ($first_only, $sticky, $type, $value) = @$v ;
 121         my $x ;
 122         $self->_checkType($key, \$value, $type, 0, \$x)
 123             or return undef ;
 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 ;
 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/^-// ;
 142         my $canonkey = lc $key;
 143
 144         if ($got->{$canonkey} && ($firstTime ||
 145                                   ! $got->{$canonkey}[OFF_FIRST_ONLY]  ))
 146         {
 147             my $type = $got->{$canonkey}[OFF_TYPE] ;
 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 ;
 153             $got->{$canonkey} = [1, $type, $value, $s] ;
 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
 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     {
 197         return $self->setError("Parameter '$key' must be an unsigned int, got 'undef'")
 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     {
 207         return $self->setError("Parameter '$key' must be a signed int, got 'undef'")
 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     {
 217         return $self->setError("Parameter '$key' must be an int, got '$value'")
 218             if $validate && defined $value && $value !~ /^\d*$/;
 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
 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
 294 1;
 295