1package Config::Options; 2our $VERSION = 0.08; 3# Copyright (c) 2007 Edward Allen III. All rights reserved. 4# 5## This program is free software; you can redistribute it and/or 6## modify it under the terms of the Artistic License, distributed 7## with Perl. 8# 9 10=pod 11 12=head1 NAME 13 14Config::Options - module to provide a configuration hash with option to read from file. 15 16=head1 SYNOPSIS 17 18 use Config::Options; 19 20 my $options = Config::Options->new({ verbose => 1, optionb => 2, mood => "sardonic" }); 21 22 # Access option as a hash... 23 print "My mode is ", $options->{mood}, "\n"; 24 25 # Merge a hash of options... 26 $options->options({ optionc => 5, style => "poor"}); 27 28 # Merge options from file 29 30 $options->options("optionfile", $ENV{HOME} . "/.myoptions.conf"); 31 $options->fromfile_perl(); 32 33 34=head1 AUTHOR 35 36Edward Allen, ealleniii _at_ cpan _dot_ org 37 38=head1 DESCRIPTION 39 40The motivation for this module was to provide an option hash with a little bit of brains. It's 41pretty simple and used mainly by other modules I have written. 42 43=cut 44 45use strict; 46use Data::Dumper; 47use Carp; 48use Scalar::Util; 49use Config; 50 51=pod 52 53=head1 METHODS 54 55=over 4 56 57=item new() 58 59Create new options hash. Pass it a hash ref to start with. Please note that this reference 60is copied, not blessed. 61 62 my $options = Config::Options->new({hash_of_startup_options}); 63 64=cut 65 66sub new { 67 my $class = shift; 68 if ($Config{useithreads}) { 69 require Config::Options::Threaded; 70 return Config::Options::Threaded->new(@_); 71 } 72 else { 73 return $class->_new(@_); 74 } 75} 76 77sub _new { 78 my $class = shift; 79 my $self = {}; 80 bless $self, $class; 81 $self->options(@_); 82} 83 84=item clone() 85 86Creates a clone of options object. 87 88 my $newoptions = $options->clone(); 89 90=cut 91 92sub clone { 93 my $self = shift; 94 my $clone = {%$self}; 95 bless $clone, ref $self; 96 return $clone; 97} 98 99=item options() 100 101This is a utility function for accessing options. If passed a hashref, merges it. 102If passed a scalar, returns the value. If passed two scalars, sets the option. 103 104 my $optionsb = $options->options; # Duplicates option file. Not very usefull. 105 $options->options($hashref); # Same as $options->merge($hashref); 106 my $value = $options->options("key") # Return option value. 107 $options->options("key", "value") # Set an option. 108 109=cut 110 111sub options { 112 my $self = shift; 113 my $option = shift; 114 if ( ref $option ) { 115 return $self->merge($option); 116 } 117 elsif ($option) { 118 my $value = shift; 119 if ( defined $value ) { 120 $self->_setoption($option, $value); 121 $self->{$option} = $value; 122 } 123 return $self->{$option}; 124 } 125 return $self; 126} 127 128 129=item merge() 130 131Takes a hashref as argument and merges with current options. 132 133 $options->merge($hashref); 134 135 136=cut 137 138sub merge { 139 my $self = shift; 140 my $option = shift; 141 return unless ( ref $option ); 142 while ( my ( $k, $v ) = each %{$option} ) { 143 $self->_setoption($k, $v); 144 } 145 return $self; 146} 147 148# Safely set an option 149sub _setoption { 150 my $self = shift; 151 my ($key, $value) = @_; 152 my $new = $value; 153 if (ref $value) { 154 $new = $self->_copyref($value); 155 } 156 $self->{$key} = $new; 157 return $value; 158} 159 160sub _newhash { 161 return {}; 162} 163 164sub _newarray { 165 return []; 166} 167 168 169# Created a shared copy of a (potentially unshared) reference 170sub _copyref { 171 my $self = shift; 172 my $in = shift; 173 my $haveseen = shift || []; 174 my $depth = shift || 0; 175 if (++$depth > 20) { 176 carp "More than 20 deep on nested reference. Is this a loop?"; 177 return $in; 178 } 179 my $seen = [ @{$haveseen} ]; 180 foreach (@{$seen}) { if(Scalar::Util::refaddr($in) == $_) { carp "Attempt to create circular reference!"; return $in } } 181 push @{$seen}, Scalar::Util::refaddr($in); 182 if (Scalar::Util::reftype($in) eq "HASH") { 183 my $out = $self->_newhash(); 184 while (my ($k, $v) = each %{$in}) { 185 if (ref $v) { 186 $out->{$k} = $self->_copyref($v, $seen, $depth); 187 } 188 else { 189 $out->{$k} = $v; 190 } 191 } 192 return $out; 193 } 194 elsif (Scalar::Util::reftype($in) eq "ARRAY") { 195 my $out = $self->_newarray(); 196 foreach my $v (@{$in}) { 197 if (ref $v) { 198 push @{$out}, $self->_copyref($v, $seen, $depth); 199 } 200 else { 201 push @{$out}, $v; 202 } 203 } 204 return $out; 205 } 206 elsif (ref $in) { 207 croak "Attempt to copy unsupported reference type: " . (ref $in); 208 } 209 else { 210 return $in; 211 } 212} 213 214# If $from and $to are both refs of same type, merge. Otherwise $to replaces $from. 215# 216sub _mergerefs { 217 my $self = shift; 218 my $from = shift; 219 my $to = shift; 220 my $haveseen = shift || []; 221 my $depth = shift || 0; 222 if (++$depth > 20) { 223 carp "More than 20 deep on nested reference. Is this a loop?"; 224 return $to; 225 } 226 if (Scalar::Util::refaddr($from) == Scalar::Util::refaddr($to)) { 227 croak "Do NOT try to merge two identical references!" 228 } 229 my $seen = [ @{$haveseen} ]; 230 foreach (@{$seen}) { if(Scalar::Util::refaddr($from) == $_) { carp "Attempt to create circular reference!"; return $to } } 231 push @{$seen}, Scalar::Util::refaddr($from), Scalar::Util::refaddr($to); 232 return unless ((ref $from) && (ref $to)); 233 if (Scalar::Util::reftype($from) eq Scalar::Util::reftype($to)) { 234 if (Scalar::Util::reftype($from) eq "HASH") { 235 while (my ($k, $v) = each %{$from} ) { 236 if (exists $to->{$k}) { 237 if (defined $v) { 238 if (ref $v) { 239 $self->_mergerefs($from->{$k}, $to->{$k}, $seen, $depth) 240 } 241 else { 242 $to->{$k} = $v; 243 } 244 } 245 } 246 else { 247 if (ref $v) { 248 $to->{$k} = $self->_copyref($v, $seen, $depth); 249 } 250 else { 251 $to->{$k} = $v; 252 } 253 } 254 } 255 } 256 elsif (Scalar::Util::reftype($from) eq "ARRAY") { 257 foreach my $v (@{$from}) { 258 if (ref $v) { 259 push @{$to}, $self->_copyref($v, $seen, $depth); 260 } 261 else { 262 push @{$to}, $v; 263 } 264 } 265 } 266 } 267 else { 268 $to = $self->_copyref($from, $seen, $depth); 269 } 270 return $to; 271} 272 273 274=item deepmerge() 275 276Same as merge, except when a value is a hash or array reference. For example: 277 278 my $options = Config::Options->new({ moods => [ qw(happy sad angry) ] }); 279 $options->deepmerge({ moods => [ qw(sardonic twisted) ] }); 280 281 print join(" ", @{$options->{moods}}), "\n"; 282 283The above outputs: 284 285 happy sad angry sardonic twisted 286 287=cut 288 289sub deepmerge { 290 my $self = shift; 291 my $option = shift; 292 $self->_mergerefs($option, $self); 293} 294 295=pod 296 297=item tofile_perl() 298 299This is used to store options to a file. The file is actually a perl program that 300returns a hash. By default uses option 'optionfile' as filename, or value passed as argument. 301 302If 'optionfile' is an array, then uses LAST option in array as default. 303 304 $options->tofile_perl("/path/to/optionfile"); 305 306=cut 307 308sub tofile_perl { 309 my $self = shift; 310 my $filename = shift || $self->options("optionfile"); 311 my $file; 312 if ( ref $filename ) { 313 $file = $filename->[-1]; 314 } 315 else { 316 $file = $filename; 317 } 318 local *OUT; 319 open( OUT, ">", $file ) or croak "Can't open option file: $file for write: $!"; 320 my $data = $self->serialize(); 321 print OUT $data; 322 close(OUT) or croak "Error closing file: ${file}: $!"; 323 return $self; 324} 325 326=pod 327 328=item fromfile_perl() 329 330This is used to retreive options from a file. The optionfile is actually a perl program that 331returns a hash. By default uses option 'optionfile' as filename if none is passed. 332 333If 'optionfile' is an array, reads all option files in order. 334 335Non-existant files are ignored. 336 337Please note that values for this are cached. 338 339 $options->fromfile_perl("/path/to/optionfile"); 340 341=cut 342 343sub fromfile_perl { 344 my $self = shift; 345 my $filename = shift || $self->options("optionfile"); 346 my @files = (); 347 if ( ref $filename eq "ARRAY" ) { 348 push @files, @{$filename}; 349 } 350 else { 351 push @files, $filename; 352 } 353 my $n = 0; 354 foreach my $f ( @files ) { 355 if ( -e $f ) { 356 if ( ( exists $self->{verbose} ) && ( $self->{verbose} ) ) { 357 print STDERR "Loading options from $f\n"; 358 } 359 local *IN; 360 my $sub = ""; 361 open( IN, $f ) or croak "Couldn't open option file $f: $!"; 362 while (<IN>) { 363 $sub .= $_; 364 } 365 close(IN); 366 my $o = $self->deserialize( $sub, "Options File: $f" ); 367 $o && $n++; 368 } 369 } 370 return $n; 371} 372 373=pod 374 375=item deserialize($data, $source) 376 377Takes a scalar as argument and evals it, then merges option. If second option is given uses this in error message if the eval fails. 378 379 my $options = $options->deserialize($scalar, $source); 380 381=cut 382 383sub deserialize { 384 my $self = shift; 385 my $data = shift; 386 my $source = shift || "Scalar"; 387 my $o = eval $data; 388 if ($@) { croak "Can't process ${source}: $@" } 389 else { 390 $self->deepmerge($o); 391 return $self; 392 } 393} 394 395=pod 396 397=item serialize() 398 399Output optons hash as a scalar using Data::Dumper. 400 401 my $scalar = $options->serialize(); 402 403=cut 404 405sub serialize { 406 my $self = shift; 407 my $d = Data::Dumper->new( [ { %{$self} } ] ); 408 return $d->Purity(1)->Terse(1)->Deepcopy(1)->Dump; 409} 410 411=item del($key) 412 413Removes $key from options. 414 415=cut 416 417sub DESTROY { 418} 419 420=back 421 422=head1 BUGS 423 424=over 4 425 426=item Deepmerge does a poor job at recogniaing recursive loops. 427 428For example, $options->deepmerge($options) will really screw things up. As protection, will only loop 20 deep. 429 430=item fromfile_perl provides tainted data. 431 432Since it comes from an external file, the data is considered tainted. 433 434=back 435 436=head1 SEE ALSO 437 438L<Config::General> 439 440=head1 LICENSE 441 442This program is free software; you can redistribute it and/or 443modify it under the terms of the Artistic License, distributed 444with Perl. 445 446=head1 COPYRIGHT 447 448Copyright (c) 2007 Edward Allen III. Some rights reserved. 449 450 451 452=cut 453 4541; 455