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