File Coverage

blib/lib/YAML/Accessor.pm
Criterion Covered Total %
statement 78 93 83.8
branch 17 26 65.3
condition 5 6 83.3
subroutine 10 12 83.3
pod 3 5 60.0
total 113 142 79.5


line stmt bran cond sub pod time code
1             package YAML::Accessor;
2              
3 5     5   122523 use 5.10.0;
  5         21  
  5         281  
4              
5 5     5   29 use feature qw{ state };
  5         6  
  5         1485  
6 5     5   32 use base qw{ Class::Accessor };
  5         23  
  5         4875  
7              
8             # hi, mst.
9 5     5   18528 use strictures 1;
  5         3830  
  5         141  
10              
11 5     5   4413 use YAML::XS;
  5         15663  
  5         284  
12 5     5   4588 use Params::Validate qw{ :types validate };
  5         50150  
  5         1262  
13 5     5   43 use Scalar::Util qw{ blessed };
  5         10  
  5         5909  
14              
15             sub new {
16 5     5 1 3788 my $package = shift;
17 5         64 state $spec = {
18             file => {
19             optional => 0,
20             type => SCALAR | HANDLE,
21             },
22             autocommit => {
23             optional => 1,
24             default => 0,
25             type => SCALAR,
26             },
27             readonly => {
28             optional => 1,
29             default => 1,
30             type => SCALAR,
31             },
32             damian => {
33             optional => 1,
34             default => 1,
35             type => SCALAR,
36             }
37             };
38            
39 5         408 my %params = validate( @_, $spec );
40            
41 5 50 66     59 if ($params{readonly} and $params{autocommit}) {
42 0         0 $! = "Failed by having readonly and autocommit set.";
43 0         0 return undef;
44             }
45            
46             # Uri made it safe for us to slurp files by name or by handle,
47             # but Ingy does it just fine in YAML::Accessor:
48             # return YAML::XS::LibYAML::Load(do { local $/; <$IN> });
49             # XXX: don't change this, Ingy.
50 5         30 my $yaml = YAML::XS::LoadFile( $params{file} );
51            
52             # There's recursion here, so we have to use Class::Accessor instead
53             # of our own package.
54 5         1304 my $object_params = bless \%params, 'Class::Accessor';
55              
56             # the choice to damian here is mine.
57 5         32 $object_params->follow_best_practice();
58 5         138 $object_params->mk_ro_accessors( keys %{ $object_params } );
  5         46  
59 5         589 my $damian = $object_params->get_damian();
60              
61 5         84 my $obj = bless {
62             yaml => $yaml,
63             params => $object_params,
64             }, $package;
65              
66 5         36 $obj->mk_ro_accessors( qw{ params } );
67              
68 5 50       287 if ($obj->{params}->get_damian()) {
69 5         81 $package->follow_best_practice();
70             }
71              
72             # Both accessors and mutators need local get/set methods
73             # because we don't want to just access the values of the
74             # YAML::Accessor object, we want to access the sub-accessors, too.
75 5 100       73 if ($obj->{params}->get_readonly()) {
76 4         37 foreach my $key ( %{ $yaml } ) {
  4         18  
77 48         3982 $obj->mk_ro_accessors( keys %{ $yaml } );
  48         400  
78             }
79 4         326 return $obj;
80             }
81             else {
82 1         9 $obj->mk_accessors( keys %{ $yaml } );
  1         12  
83 1         213 return $obj;
84             }
85             }
86              
87             sub set { # {{{
88 1     1 1 342 my $self = shift;
89 1         3 my ($key, @values) = (@_);
90            
91 1 50       5 return undef if $self->{params}->get_readonly();
92            
93             # Note to the user: you may be creating a new YAML key here.
94             # XXX: NOTE: Class::Accessor tells us we might actually have more than one
95             # value here. That seems like hogwash. So, the below line is commented. If
96             # this is actually broken, tell me how to fix it.
97             #
98             # $self->{yaml}->{$key} = (scalar @values > 1 ) ? shift @values : \@values;
99 1         11 $self->{yaml}->{$key} = shift @values;
100            
101             # Since the object has set the values, we can push to the file if that's
102             # what the user asked for. We don't need to run the constructor again
103             # since the object is updated and intact.
104 1 50       5 if ($self->{params}->get_autocommit()) {
105 0         0 $self->commit();
106 0         0 return $self->{yaml}->{$key};
107             }
108            
109 1         10 return @values;
110             } # }}}
111              
112             sub get { # {{{
113 33     33 1 1830 my $self = shift;
114 33         38 my $child_package = 'YAML::Accessor';
115              
116 33         51 my (@keys) = (@_);
117              
118             # Hashrefslice again because they have asked for multiple keys.
119             # Class::Accessor says this can happen. I'm not sure how that's
120             # possible.
121 33 50       80 if ( scalar @keys > 1 ) {
122 0         0 return [ @{ $self->{yaml} }{ @keys } ]
  0         0  
123             }
124              
125 33         41 my $key = shift @keys;
126              
127 33 100       69 if (exists $self->{yaml}) { # {{{ top-most object
128             # we are the parent object
129 22 100 100     138 if (not blessed $self->{yaml}->{$key} and
130             ref $self->{yaml}->{$key} eq 'HASH') {
131 4         12 my $new_accessor = bless $self->{yaml}->{$key}, $child_package;
132             # Ensure our parameters propagate
133 4         30 $new_accessor->{params} = $self->{params};
134 4 50       43 if ($self->{params}->get_damian()) {
135 4         43 $new_accessor->follow_best_practice();
136             }
137 4         39 my @sub_accessors = keys %{ $self->{yaml}->{$key} };
  4         21  
138 4         10 $new_accessor->mk_ro_accessors( @sub_accessors );
139 4         518 $self->{$key} = $new_accessor;
140 4         55 return $new_accessor;
141             }
142             else {
143             # This isn't a hashref and/or the object is already blessed. So just
144             # return it.
145 18         94 return $self->{yaml}->{$key};
146             }
147             } # }}}
148             else { # {{{ sub-object
149             # We are a sub-object, so check for blessedness, bless as appropriate
150             # and move on
151 11 100       29 if (blessed $self->{$key}) {
152 6         24 return $self->{$key};
153             }
154             else {
155 5 100       9 if (ref $self->{$key} eq 'HASH') {
156 3         7 my $new_accessor = bless $self->{$key}, $child_package;
157 3 50       8 if ($self->{params}->get_damian()) {
158 3         27 $new_accessor->follow_best_practice();
159             }
160             # Ensure our parameters propagate
161 3         36 $new_accessor->{params} = $self->{params};
162 3         4 $new_accessor->mk_ro_accessors( keys %{ $new_accessor } );
  3         12  
163 3         214 return $new_accessor;
164             }
165             else {
166             # This isn't a hashref, just return the value
167 2         10 return $self->{$key};
168             }
169             }
170             } # }}}
171             } # }}}
172              
173             # In case you're not using autocommit and want to force a write to the disk.
174             sub commit { # {{{
175 0     0 0   my $self = shift;
176 0           my $yaml = $self->{yaml};
177 0           my $fn = $self->{params}->{file};
178             # arg 1 is a filename, everything afterwards gets written to the specified
179             # file.
180 0           return YAML::XS::DumpFile( $fn, $yaml ); # ingy, does this set $! ?
181             } # }}}
182              
183             # In the event that your yaml changes while you're running, we can re-read
184             # the file. This is useful for tools that poll their config files for
185             # changes.
186             sub refresh {
187 0     0 0   my ($self) = shift;
188 0 0         return $self unless $self->{params}->{file};
189 0           my $refreshed_self = new( __PACKAGE__, %{ $self->{params} } );
  0            
190 0           return $refreshed_self;
191             }
192              
193             22/7;
194              
195             =pod
196              
197             =head1 NAME
198              
199             YAML::Accessor
200              
201             =head1 ABSTRACT
202              
203             Syntactic sugar for YAML::XS using Class::Accessor with sub-accessors.
204              
205             =head1 SYNOPSIS
206              
207             package YConfig;
208             use base qw{ YAML::Accessor };
209            
210             # Load by filename
211             my $yc = YConfig->new(
212             file => 'config.yml', # Can be a filehandle.
213             readonly => 1, # This is a default. Can be 1 (true).
214             damian => 1, # See below. Can be 0 (false).
215              
216             # Implemented, but probably buggy and not tested.
217             autocommit => 0, # This is a default. Can be 1 (true).
218             )
219             or die "failed to load 'config.yml' [$!]";
220              
221             =head1 DESCRIPTION
222              
223             C aims to create a "gettr/settr" interface for YAML
224             objects/files and allow the user to both manipulate their structure
225             and to read and write from the (specified) file(s).
226              
227             It doesn't use the simple C call C and this may
228             seem unituitive for users of YAML::XS. The point is not to reinvent
229             L, but rather to create intuitive, easily-constructed objects
230             with proper accessor/mutator methods.
231              
232             There are lots of things one could do with this; the obvious use case
233             is a config file.
234              
235             =head1 PARAMETERS
236              
237             C is not optional. It's got to be a filehandle or a scalar that
238             (hopefully) refers to a file you can read. If not, C barfs and
239             properly sets C<$!> for you.
240              
241             C is optional. If you set this to true, your file will be
242             written to each time a mutator is called.
243              
244             C is optional. It defaults to true. This means you get no
245             mutators ("settrs") and you won't munge your file accidentally. If you
246             set C and C both to true, C explodes and you
247             deserve what you get. But you still get C<$!>.
248              
249             C refers to the L method "follow_best_practice",
250             which is defined in Damian Conway's book on "Perl Best Practices" on ORA.
251             If you set this to true, your methods will be
252            
253             $obj->get_foo(); # gets the value of foo
254             $obj->set_foo(100); # sets foo to 100
255              
256             If you don't like this, set damian to false (that is, 0 or undef or ''),
257             and your methods will be:
258            
259             $foo = $obj->foo(); # returns value of foo
260             $obj->foo(100); # sets foo to 100
261              
262             C defaults to true.
263              
264             =head1 ACCESSORS
265              
266             C accessors will return whatever the value of C is (note
267             use of "Damianized" accessor here). In the event there's a list of things,
268             you need to read the code to the C method in this module.
269              
270             C mutators will set the value of whatever field is specified
271             (in this case, "foo" -- noting again the "Damianized" mutator). Mutators
272             return one of two things. If you've set C to true, the mutator
273             will return the value of the latest attempt to "commit" (write) your file.
274             In the event you have not turned on C during the constructor,
275             the mutator will simply return the value(s) supplied. For more detail,
276             have a look at the code. But really, it's not too complicated.
277              
278             =head1 METHODS
279              
280             C allows you to force the current yaml to be flushed to disk.
281             Note that YAML::Accessor calls this method internally when you use
282             mutators.
283              
284             =head1 SUB-ACCESSORS
285              
286             When calling an accessor method, the object will try to determine whether
287             the value you are requesting is itself an accessor (or rather, should be
288             made an accessor). Therefore you may use a construct such as:
289              
290             $obj->get_foo()->get_bar();
291              
292             and it should Just Work. Note that this only works for hash values. If you
293             request an accessor that has an array or scalar (or anything else), you'll
294             simply get what you asked for.
295              
296             Note that this is not standard L behavior. The reason for
297             this is that YAML allows us to have deeply-nested structures, and having to
298             refer to their hash keys after a single layer of accessors, like such:
299              
300             $obj->get_foo()->{bar};
301              
302             is tedious and misses the point of this package.
303              
304             =head1 SEE ALSO
305              
306             YAML::XS
307             Class::Accessor
308              
309             Perl Best Practices
310             Damian Conway
311             O'Reilly & Associates
312             ISBN-13: 978-0596001735
313             ASIN: 0596001738
314              
315             =head1 BUGS
316              
317             The implementation actually doesn't allow this module to internally use
318             L and instead overrides its C and C functions
319             to refer to your shiny YAML object. That's kind of inconsistent, but you
320             wanted YAML, not an object that referred to YAML. If you can come up with
321             a way to fix it, awesome. This way is simpler.
322              
323             Also, it looks like doing something like
324              
325             use base qw{ Class::Accessor };
326             use base qw{ YAML::Accessor };
327              
328             is fraught with peril. Don't do that.
329              
330             While not exactly a bug, this package uses L instead of L
331             in the interest of speed and ingy's preference.
332              
333             =head1 AUTHOR
334              
335             Jane A. Avriette, Ejane@cpan.orgE
336              
337             =head1 COPYRIGHT AND LICENSE
338              
339             Copyright (C) 2011 by Jane A. Avriette
340              
341             This library is free software; you can redistribute it and/or modify
342             it under the same terms as Perl itself, either Perl version 5.10.0 or,
343             at your option, any later version of Perl 5 you may have available.
344              
345             =cut