File Coverage

blib/lib/Venus/Yaml.pm
Criterion Covered Total %
statement 26 100 26.0
branch 2 22 9.0
condition 0 6 0.0
subroutine 6 24 25.0
pod 4 13 30.7
total 38 165 23.0


line stmt bran cond sub pod time code
1             package Venus::Yaml;
2              
3 2     2   1337 use 5.018;
  2         6  
4              
5 2     2   24 use strict;
  2         5  
  2         48  
6 2     2   11 use warnings;
  2         7  
  2         75  
7              
8             use overload (
9 2         19 '""' => 'explain',
10             '~~' => 'explain',
11             fallback => 1,
12 2     2   14 );
  2         166  
13              
14 2     2   227 use Venus::Class 'attr', 'base', 'with';
  2         8  
  2         19  
15              
16             base 'Venus::Kind::Utility';
17              
18             with 'Venus::Role::Valuable';
19             with 'Venus::Role::Buildable';
20             with 'Venus::Role::Accessible';
21             with 'Venus::Role::Explainable';
22              
23             # ATTRIBUTES
24              
25             attr 'decoder';
26             attr 'encoder';
27              
28             # BUILDERS
29              
30             sub build_arg {
31 0     0 0 0 my ($self, $data) = @_;
32              
33             return {
34 0         0 value => $data
35             };
36             }
37              
38             sub build_args {
39 0     0 0 0 my ($self, $data) = @_;
40              
41 0 0 0     0 if (keys %$data == 1 && exists $data->{value}) {
42 0         0 return $data;
43             }
44             return {
45 0         0 value => $data
46             };
47             }
48              
49             sub build_nil {
50 0     0 0 0 my ($self, $data) = @_;
51              
52             return {
53 0         0 value => $data
54             };
55             }
56              
57             sub build_self {
58 0     0 0 0 my ($self, $data) = @_;
59              
60 0         0 return $self->config;
61             }
62              
63             # METHODS
64              
65             sub assertion {
66 0     0 1 0 my ($self) = @_;
67              
68 0         0 my $assert = $self->SUPER::assertion;
69              
70 0         0 $assert->clear->expression('hashref');
71              
72 0         0 return $assert;
73             }
74              
75             sub config {
76 0     0 0 0 my ($self, $package) = @_;
77              
78 0 0 0     0 $package ||= $self->package
79             or $self->error({throw => 'error_on_config'});
80              
81             # YAML::XS
82 0 0       0 if ($package eq 'YAML::XS') {
83             $self->decoder(sub {
84 0     0   0 my ($text) = @_;
85 0         0 local $YAML::XS::Boolean = 'JSON::PP';
86 0         0 YAML::XS::Load($text);
87 0         0 });
88             $self->encoder(sub {
89 0     0   0 my ($data) = @_;
90 0         0 local $YAML::XS::Boolean = 'JSON::PP';
91 0         0 YAML::XS::Dump($data);
92 0         0 });
93             }
94              
95             # YAML::PP::LibYAML
96 0 0       0 if ($package eq 'YAML::PP::LibYAML') {
97             $self->decoder(sub {
98 0     0   0 my ($text) = @_;
99 0         0 YAML::PP->new(boolean => 'JSON::PP')->load_string($text);
100 0         0 });
101             $self->encoder(sub {
102 0     0   0 my ($data) = @_;
103 0         0 YAML::PP->new(boolean => 'JSON::PP')->dump_string($data);
104 0         0 });
105             }
106              
107             # YAML::PP
108 0 0       0 if ($package eq 'YAML::PP') {
109             $self->decoder(sub {
110 0     0   0 my ($text) = @_;
111 0         0 YAML::PP->new(boolean => 'JSON::PP')->load_string($text);
112 0         0 });
113             $self->encoder(sub {
114 0     0   0 my ($data) = @_;
115 0         0 YAML::PP->new(boolean => 'JSON::PP')->dump_string($data);
116 0         0 });
117             }
118              
119 0         0 return $self;
120             }
121              
122             sub decode {
123 0     0 1 0 my ($self, $data) = @_;
124              
125             # double-traversing the data structure due to lack of serialization hooks
126 0         0 return $self->set(FROM_BOOL($self->decoder->($data)));
127             }
128              
129             sub encode {
130 0     0 1 0 my ($self) = @_;
131              
132             # double-traversing the data structure due to lack of serialization hooks
133 0         0 return $self->encoder->(TO_BOOL($self->get));
134             }
135              
136             sub explain {
137 0     0 0 0 my ($self) = @_;
138              
139 0         0 return $self->encode;
140             }
141              
142             sub package {
143 5     5 0 41 my ($self) = @_;
144              
145 5         8 state $engine;
146              
147 5 50       11 return $engine if defined $engine;
148              
149 5         19 my %packages = (
150             'YAML::XS' => '0.67',
151             'YAML::PP::LibYAML' => '0.004',
152             'YAML::PP' => '0.023',
153             );
154 5         22 for my $package (
155             grep defined,
156             $ENV{VENUS_YAML_PACKAGE},
157             qw(YAML::XS YAML::PP::LibYAML YAML::PP)
158             )
159             {
160 15         52 my $criteria = "require $package; $package->VERSION($packages{$package})";
161 15 50       25 if (do {local $@; eval "$criteria"; $@}) {
  15         20  
  15         952  
  15         105  
162 15         49 next;
163             }
164             else {
165 0         0 $engine = $package;
166 0         0 last;
167             }
168             }
169              
170 5         21 return $engine;
171             }
172              
173             sub FROM_BOOL {
174 0     0 0   my ($value) = @_;
175              
176 0           require Venus::Boolean;
177              
178 0 0         if (ref($value) eq 'HASH') {
179 0           for my $key (keys %$value) {
180 0           $value->{$key} = FROM_BOOL($value->{$key});
181             }
182 0           return $value;
183             }
184              
185 0 0         if (ref($value) eq 'ARRAY') {
186 0           for my $key (keys @$value) {
187 0           $value->[$key] = FROM_BOOL($value->[$key]);
188             }
189 0           return $value;
190             }
191              
192 0           return Venus::Boolean::TO_BOOL(Venus::Boolean::FROM_BOOL($value));
193             }
194              
195             sub TO_BOOL {
196 0     0 0   my ($value) = @_;
197              
198 0           require Venus::Boolean;
199              
200 0 0         if (ref($value) eq 'HASH') {
201 0           $value = {
202             %$value
203             };
204 0           for my $key (keys %$value) {
205 0           $value->{$key} = TO_BOOL($value->{$key});
206             }
207 0           return $value;
208             }
209              
210 0 0         if (ref($value) eq 'ARRAY') {
211 0           $value = [
212             @$value
213             ];
214 0           for my $key (keys @$value) {
215 0           $value->[$key] = TO_BOOL($value->[$key]);
216             }
217 0           return $value;
218             }
219              
220 0           return Venus::Boolean::TO_BOOL_JPO($value);
221             }
222              
223             # ERRORS
224              
225             sub error_on_config {
226 0     0 1   my ($self) = @_;
227              
228             return {
229 0           name => 'on.config',
230             message => 'No suitable YAML package',
231             raise => true,
232             };
233             }
234              
235             1;
236              
237              
238              
239             =head1 NAME
240              
241             Venus::Yaml - Yaml Class
242              
243             =cut
244              
245             =head1 ABSTRACT
246              
247             Yaml Class for Perl 5
248              
249             =cut
250              
251             =head1 SYNOPSIS
252              
253             package main;
254              
255             use Venus::Yaml;
256              
257             my $yaml = Venus::Yaml->new(
258             value => { name => ['Ready', 'Robot'], version => 0.12, stable => !!1, }
259             );
260              
261             # $yaml->encode;
262              
263             =cut
264              
265             =head1 DESCRIPTION
266              
267             This package provides methods for reading and writing L
268             data. B This package requires that a suitable YAML library is installed,
269             currently either C C<0.67+>, C C<0.004+>, or
270             C C<0.23+>. You can use the C environment
271             variable to include or prioritize your preferred YAML library.
272              
273             =cut
274              
275             =head1 ATTRIBUTES
276              
277             This package has the following attributes:
278              
279             =cut
280              
281             =head2 decoder
282              
283             decoder(CodeRef)
284              
285             This attribute is read-write, accepts C<(CodeRef)> values, and is optional.
286              
287             =cut
288              
289             =head2 encoder
290              
291             encoder(CodeRef)
292              
293             This attribute is read-write, accepts C<(CodeRef)> values, and is optional.
294              
295             =cut
296              
297             =head1 INHERITS
298              
299             This package inherits behaviors from:
300              
301             L
302              
303             =cut
304              
305             =head1 INTEGRATES
306              
307             This package integrates behaviors from:
308              
309             L
310              
311             L
312              
313             L
314              
315             L
316              
317             =cut
318              
319             =head1 METHODS
320              
321             This package provides the following methods:
322              
323             =cut
324              
325             =head2 decode
326              
327             decode(string $yaml) (any)
328              
329             The decode method decodes the YAML string, sets the object value, and returns
330             the decoded value.
331              
332             I>
333              
334             =over 4
335              
336             =item decode example 1
337              
338             # given: synopsis;
339              
340             my $decode = $yaml->decode("codename: ['Ready','Robot']\nstable: true");
341              
342             # { codename => ["Ready", "Robot"], stable => 1 }
343              
344             =back
345              
346             =cut
347              
348             =head2 encode
349              
350             encode() (string)
351              
352             The encode method encodes the objects value as a YAML string and returns the
353             encoded string.
354              
355             I>
356              
357             =over 4
358              
359             =item encode example 1
360              
361             # given: synopsis;
362              
363             my $encode = $yaml->encode;
364              
365             # "---\nname:\n- Ready\n- Robot\nstable: true\nversion: 0.12\n"
366              
367             =back
368              
369             =cut
370              
371             =head1 ERRORS
372              
373             This package may raise the following errors:
374              
375             =cut
376              
377             =over 4
378              
379             =item error: C
380              
381             This package may raise an error_on_config exception.
382              
383             B
384              
385             # given: synopsis;
386              
387             my $input = {
388             throw => 'error_on_config',
389             };
390              
391             my $error = $yaml->catch('error', $input);
392              
393             # my $name = $error->name;
394              
395             # "on_config"
396              
397             # my $message = $error->message;
398              
399             # "No suitable YAML package"
400              
401             =back
402              
403             =head1 AUTHORS
404              
405             Awncorp, C
406              
407             =cut
408              
409             =head1 LICENSE
410              
411             Copyright (C) 2000, Awncorp, C.
412              
413             This program is free software, you can redistribute it and/or modify it under
414             the terms of the Apache license version 2.0.
415              
416             =cut