File Coverage

blib/lib/YAML/Perl/Loader.pm
Criterion Covered Total %
statement 49 161 30.4
branch 9 60 15.0
condition 3 8 37.5
subroutine 12 36 33.3
pod 0 32 0.0
total 73 297 24.5


line stmt bran cond sub pod time code
1 5     5   89780 use strict;
  5         12  
  5         119  
2 5     5   21 use warnings;
  5         10  
  5         288  
3             package YAML::Perl::Loader;
4              
5             our $VERSION = '0.12';
6              
7 5 50 33 5   30 use constant DEBUG => ($ENV{YAML_PP_LOAD_DEBUG} or $ENV{YAML_PP_LOAD_TRACE}) ? 1 : 0;
  5         13  
  5         335  
8 5 50   5   34 use constant TRACE => $ENV{YAML_PP_LOAD_TRACE} ? 1 : 0;
  5         12  
  5         7479  
9              
10             sub new {
11 4     4 0 1209 my ($class, %args) = @_;
12 4   100     46 my $bool = delete $args{boolean} // 'perl';
13 4         9 my $truefalse;
14 4 50       24 if ($bool eq 'JSON::PP') {
    50          
    100          
15 0         0 require JSON::PP;
16 0         0 $truefalse = \&bool_jsonpp;
17             }
18             elsif ($bool eq 'boolean') {
19 0         0 require boolean;
20 0         0 $truefalse = \&bool_booleanpm;
21             }
22             elsif ($bool eq 'perl') {
23 3         11 $truefalse = \&bool_perl;
24             }
25             else {
26 1         9 die "Invalid value for 'boolean': '$bool'. Allowed: ('perl', 'boolean', 'JSON::PP')";
27             }
28              
29 3         9 my $parser = delete $args{parser};
30 3 50       15 unless ($parser) {
31 3         1599 require YAML::PP::Parser;
32 3         27546 $parser = YAML::PP::Parser->new;
33             }
34 3 100       44 if (keys %args) {
35 1         15 die "Unexpected arguments: " . join ', ', sort keys %args;
36             }
37 2         15 my $self = bless {
38             boolean => $bool,
39             truefalse => $truefalse,
40             parser => $parser,
41             }, $class;
42 2         10 $parser->set_receiver($self);
43 2         22 return $self;
44             }
45              
46 2     2 0 7 sub parser { return $_[0]->{parser} }
47 0     0 0 0 sub data { return $_[0]->{data} }
48 0     0 0 0 sub docs { return $_[0]->{docs} }
49 0     0 0 0 sub refs { return $_[0]->{refs} }
50 0     0 0 0 sub anchors { return $_[0]->{anchors} }
51 2     2 0 6 sub set_data { $_[0]->{data} = $_[1] }
52 2     2 0 13 sub set_docs { $_[0]->{docs} = $_[1] }
53 2     2 0 6 sub set_refs { $_[0]->{refs} = $_[1] }
54 2     2 0 6 sub set_anchors { $_[0]->{anchors} = $_[1] }
55 0     0 0 0 sub boolean { return $_[0]->{boolean} }
56 0     0 0 0 sub truefalse { return $_[0]->{truefalse} }
57              
58             sub load {
59 2     2 0 18 my ($self, $yaml) = @_;
60 2         11 $self->set_docs([]);
61 2         7 my $parser = $self->parser;
62 2         9 $self->set_data(undef);
63 2         8 $self->set_refs([]);
64 2         9 $self->set_anchors({});
65              
66 2         8 $parser->parse($yaml);
67              
68 0         0 $self->set_data(undef);
69 0         0 $self->set_refs([]);
70 0         0 $self->set_anchors({});
71 0         0 my $docs = $self->docs;
72 0 0       0 return wantarray ? @$docs : $docs->[0];
73             }
74              
75              
76             sub begin {
77 0     0 0 0 my ($self, $data, $event) = @_;
78              
79 0         0 my $refs = $self->refs;
80              
81 0         0 my $ref = $refs->[-1];
82 0 0       0 if (not defined $$ref) {
    0          
    0          
83 0         0 $$ref = $data;
84             }
85             elsif (ref $$ref eq 'ARRAY') {
86 0         0 push @$$ref, $data;
87 0         0 push @$refs, \$data;
88             }
89             elsif (ref $$ref eq 'HASH') {
90             # we got a complex key
91 0         0 push @$refs, \\undef;
92 0         0 push @$refs, \$data;
93             }
94             else {
95 0         0 die "Unexpected";
96             }
97 0 0       0 if (defined(my $anchor = $event->{anchor})) {
98 0         0 $self->anchors->{ $anchor } = \$data;
99             }
100             }
101              
102             sub document_start_event {
103 0     0 0 0 my ($self, $event) = @_;
104 0         0 $self->set_data(undef);
105 0         0 $self->set_refs([ \$self->{data} ]);
106 0         0 $self->set_anchors({});
107             }
108              
109             sub document_end_event {
110 0     0 0 0 my ($self, $event) = @_;
111 0         0 my $refs = $self->refs;
112 0         0 my $docs = $self->docs;
113 0         0 push @$docs, $self->data;
114 0 0       0 pop @$refs if @$refs;
115             }
116              
117             sub mapping_start_event {
118 0     0 0 0 my ($self, $event) = @_;
119 0         0 my $data = {};
120 0         0 shift->begin($data, @_);
121             }
122              
123             sub mapping_end_event {
124 0     0 0 0 shift->end(@_);
125             }
126              
127             sub sequence_start_event {
128 0     0 0 0 my ($self, $event) = @_;
129 0         0 my $data = [];
130 0         0 shift->begin($data, @_);
131             }
132              
133             sub sequence_end_event {
134 0     0 0 0 shift->end(@_);
135             }
136              
137             sub stream_start_event {
138 0     0 0 0 my ($self, $event) = @_;
139 0         0 my $refs = $self->refs;
140 0 0       0 pop @$refs if @$refs;
141             }
142              
143       0 0   sub stream_end_event {}
144              
145             sub end {
146 0     0 0 0 my ($self, $event) = @_;
147 0         0 my $refs = $self->refs;
148              
149 0         0 my $complex = pop @$refs;
150 0 0       0 if (@$refs > 1) {
151 0         0 my $ref1 = $refs->[-1];
152 0         0 my $ref2 = $refs->[-2];
153 0 0       0 if (ref $$ref1 eq 'SCALAR') {
154 0         0 pop @$refs;
155 0         0 my $string = $self->stringify_complex($$complex);
156 0 0       0 if (ref $$ref2 eq 'HASH') {
157 0         0 $$ref2->{ $string } = undef;
158 0         0 push @$refs, \$$ref2->{ $string };
159             }
160             else {
161 0         0 die "Unexpected";
162             }
163             }
164             }
165             }
166              
167              
168             sub scalar_event {
169 0     0 0 0 my ($self, $event) = @_;
170 0         0 my $value = $self->render_value($event);
171 0         0 $self->event(value => $value, event => $event);
172 0         0 DEBUG and warn YAML::PP::Parser->event_to_test_suite([value => $event]) ."\n";
173             }
174              
175             sub alias {
176 0     0 0 0 my ($self, $event) = @_;
177 0         0 my $value;
178 0         0 my $name = $event->{content};
179 0 0       0 if (my $anchor = $self->anchors->{ $name }) {
180 0         0 $value = $$anchor;
181             }
182 0         0 DEBUG and warn YAML::PP::Parser->event_to_test_suite([alias => $event]) ."\n";
183 0         0 $self->event(value => $value, event => $event);
184             }
185              
186             sub event {
187 0     0 0 0 my ($self, %args) = @_;
188 0         0 my $value = $args{value};
189 0         0 my $event = $args{event};
190              
191 0         0 my $refs = $self->refs;
192              
193 0         0 my $ref = $refs->[-1];
194 0 0       0 if (not defined $$ref) {
    0          
    0          
195 0         0 $$ref = $value;
196 0         0 pop @$refs;
197             }
198             elsif (ref $$ref eq 'HASH') {
199 0         0 $$ref->{ $value } = undef;
200 0         0 push @$refs, \$$ref->{ $value };
201             }
202             elsif (ref $$ref eq 'ARRAY') {
203 0         0 push @{ $$ref }, $value;
  0         0  
204             }
205             }
206              
207             my %control = ( '\\' => '\\', n => "\n", t => "\t", r => "\r", b => "\b" );
208             sub render_value {
209 0     0 0 0 my ($self, $info) = @_;
210 0         0 my $value;
211 0         0 my $content = $info->{content};
212 0         0 my $style = $info->{style};
213 0         0 DEBUG and warn "CONTENT $content ($style)\n";
214 0 0       0 if ($style eq ':') {
215 0         0 $value = $self->render_plain_scalar($content);
216             }
217             else {
218 0         0 $value = $content;
219 0         0 $value =~ s/\\([\\ntrb])/$control{ $1 }/eg;
  0         0  
220             }
221 0         0 TRACE and local $Data::Dumper::Useqq = 1;
222 0         0 TRACE and warn __PACKAGE__.':'.__LINE__.$".Data::Dumper->Dump([\$value], ['value']);
223 0         0 return $value;
224             }
225              
226             sub stringify_complex {
227 4     4 0 25 my ($self, $data) = @_;
228 4         15 require Data::Dumper;
229 4         9 local $Data::Dumper::Quotekeys = 0;
230 4         5 local $Data::Dumper::Terse = 1;
231 4         6 local $Data::Dumper::Indent = 0;
232 4         6 local $Data::Dumper::Useqq = 0;
233 4         6 local $Data::Dumper::Sortkeys = 1;
234 4         14 my $string = Data::Dumper->Dump([$data], ['data']);
235 4         168 $string =~ s/^\$data = //;
236 4         13 return $string;
237             }
238              
239             sub render_plain_scalar {
240 0     0 0   my ($self, $content) = @_;
241 0 0         return unless defined $content;
242 0           my $value;
243 0 0 0       if ($content =~ m/^($YAML::PP::Parser::RE_INT|$YAML::PP::Parser::RE_FLOAT)$/){
    0          
    0          
    0          
244 0           $value = 0 + $1;
245             }
246             elsif ($content =~ m/^($YAML::PP::Parser::RE_HEX)/) {
247 0           $value = hex $content;
248             }
249             elsif ($content =~ m/^($YAML::PP::Parser::RE_OCT)/) {
250 0           my $oct = 0 . substr($content, 2);
251 0           $value = oct $oct;
252             }
253             elsif ($content eq 'true' or $content eq 'false') {
254 0           $value = $self->truefalse->($content);
255             }
256             else {
257 0           $value = $content;
258 0           $value =~ s/\\n/\n/g;
259 0           $value =~ s/\\t/\t/g;
260             }
261 0           return $value;
262             }
263              
264             sub bool_jsonpp {
265 0 0   0 0   $_[0] eq 'true' ? JSON::PP::true() : JSON::PP::false()
266             }
267              
268             sub bool_booleanpm {
269 0 0   0 0   $_[0] eq 'true' ? boolean::true() : boolean::false()
270             }
271              
272             sub bool_perl {
273 0 0   0 0   $_[0] eq 'true' ? 1 : 0
274             }
275              
276             1;