File Coverage

blib/lib/YAML/PP/Representer.pm
Criterion Covered Total %
statement 134 143 93.7
branch 77 96 80.2
condition 29 43 67.4
subroutine 15 15 100.0
pod 0 8 0.0
total 255 305 83.6


line stmt bran cond sub pod time code
1 35     35   296 use strict;
  35         84  
  35         1133  
2 35     35   200 use warnings;
  35         76  
  35         2043  
3             package YAML::PP::Representer;
4              
5             our $VERSION = '0.036_002'; # TRIAL VERSION
6              
7 35     35   233 use Scalar::Util qw/ reftype blessed refaddr /;
  35         89  
  35         2784  
8              
9 35         2671 use YAML::PP::Common qw/
10             YAML_PLAIN_SCALAR_STYLE YAML_SINGLE_QUOTED_SCALAR_STYLE
11             YAML_DOUBLE_QUOTED_SCALAR_STYLE
12             YAML_ANY_SCALAR_STYLE
13             YAML_LITERAL_SCALAR_STYLE YAML_FOLDED_SCALAR_STYLE
14             YAML_FLOW_SEQUENCE_STYLE YAML_FLOW_MAPPING_STYLE
15             YAML_BLOCK_MAPPING_STYLE YAML_BLOCK_SEQUENCE_STYLE
16             PRESERVE_ORDER PRESERVE_SCALAR_STYLE PRESERVE_FLOW_STYLE PRESERVE_ALIAS
17 35     35   257 /;
  35         84  
18 35     35   242 use B;
  35         99  
  35         55844  
19              
20             sub new {
21 746     746 0 2105 my ($class, %args) = @_;
22 746   100     2742 my $preserve = delete $args{preserve} || 0;
23 746 100       1738 if ($preserve == 1) {
24 1         2 $preserve = PRESERVE_ORDER | PRESERVE_SCALAR_STYLE | PRESERVE_FLOW_STYLE | PRESERVE_ALIAS;
25             }
26             my $self = bless {
27             schema => delete $args{schema},
28 746         2240 preserve => $preserve,
29             }, $class;
30 746 50       1860 if (keys %args) {
31 0         0 die "Unexpected arguments: " . join ', ', sort keys %args;
32             }
33 746         4686 return $self;
34             }
35              
36             sub clone {
37 9     9 0 20 my ($self) = @_;
38             my $clone = {
39             schema => $self->schema,
40             preserve => $self->{preserve},
41 9         20 };
42 9         39 return bless $clone, ref $self;
43             }
44              
45 3946     3946 0 11489 sub schema { return $_[0]->{schema} }
46 455     455 0 1358 sub preserve_order { return $_[0]->{preserve} & PRESERVE_ORDER }
47 3804     3804 0 5947 sub preserve_scalar_style { return $_[0]->{preserve} & PRESERVE_SCALAR_STYLE }
48 721     721 0 2090 sub preserve_flow_style { return $_[0]->{preserve} & PRESERVE_FLOW_STYLE }
49 3875     3875 0 7360 sub preserve_alias { return $_[0]->{preserve} & PRESERVE_ALIAS }
50              
51             sub represent_node {
52 3804     3804 0 6650 my ($self, $node) = @_;
53              
54 3804         7213 my $preserve_alias = $self->preserve_alias;
55 3804         7338 my $preserve_style = $self->preserve_scalar_style;
56 3804 100 100     12777 if ($preserve_style or $preserve_alias) {
57 131 100       286 if (ref $node->{value} eq 'YAML::PP::Preserve::Scalar') {
58 87         227 my $value = $node->{value}->value;
59 87 100       170 if ($preserve_style) {
60 21         48 $node->{style} = $node->{value}->style;
61             }
62             # $node->{tag} = $node->{value}->tag;
63 87         164 $node->{value} = $value;
64             }
65             }
66 3804         9537 $node->{reftype} = reftype($node->{value});
67 3804 100 100     15413 if (not $node->{reftype} and reftype(\$node->{value}) eq 'GLOB') {
68 6         27 $node->{reftype} = 'GLOB';
69             }
70              
71 3804 100       7963 if ($node->{reftype}) {
72 804         1912 $self->_represent_noderef($node);
73             }
74             else {
75 3000         6479 $self->_represent_node_nonref($node);
76             }
77 3804   100     13686 $node->{reftype} = (reftype $node->{data}) || '';
78              
79 3804 100 100     9654 if ($node->{reftype} eq 'HASH' and my $tied = tied(%{ $node->{data} })) {
  455         1619  
80 34         71 my $representers = $self->schema->representers;
81 34         72 $tied = ref $tied;
82 34 50       95 if (my $def = $representers->{tied_equals}->{ $tied }) {
83 0         0 my $code = $def->{code};
84 0         0 my $done = $code->($self, $node);
85             }
86             }
87              
88 3804 100       10610 if ($node->{reftype} eq 'HASH') {
    100          
    100          
89 455 50       1095 unless (defined $node->{items}) {
90             # by default we sort hash keys
91 455         666 my @keys;
92 455 100       980 if ($self->preserve_order) {
93 24         35 @keys = keys %{ $node->{data} };
  24         96  
94             }
95             else {
96 431         697 @keys = sort keys %{ $node->{data} };
  431         2265  
97             }
98 455         1307 for my $key (@keys) {
99 871         1290 push @{ $node->{items} }, $key, $node->{data}->{ $key };
  871         2919  
100             }
101             }
102 455         744 my %args;
103 455 100 66     960 if ($self->preserve_flow_style and reftype $node->{value} eq 'HASH') {
104 19 100       35 if (my $tied = tied %{ $node->{value} } ) {
  19         52  
105 18         37 $args{style} = $tied->{style};
106             }
107             }
108 455         1895 return [ mapping => $node, %args ];
109             }
110             elsif ($node->{reftype} eq 'ARRAY') {
111 266 50       663 unless (defined $node->{items}) {
112 266         400 @{ $node->{items} } = @{ $node->{data} };
  266         756  
  266         523  
113             }
114 266         533 my %args;
115 266 100 66     576 if ($self->preserve_flow_style and reftype $node->{value} eq 'ARRAY') {
116 10 50       15 if (my $tied = tied @{ $node->{value} } ) {
  10         38  
117 10         22 $args{style} = $tied->{style};
118             }
119             }
120 266         1082 return [ sequence => $node, %args ];
121             }
122             elsif ($node->{reftype}) {
123 1         16 die "Cannot handle reftype '$node->{reftype}' (you might want to enable YAML::PP::Schema::Perl)";
124             }
125             else {
126 3082 100       6431 unless (defined $node->{items}) {
127 3018         6673 $node->{items} = [$node->{data}];
128             }
129 3082         9112 return [ scalar => $node ];
130             }
131              
132             }
133              
134             my $bool_code = <<'EOM';
135             sub {
136             my ($x) = @_;
137             use experimental qw/ builtin /;
138             builtin::is_bool($x);
139             }
140             EOM
141             my $is_bool;
142              
143             sub _represent_node_nonref {
144 3000     3000   5251 my ($self, $node) = @_;
145 3000         5784 my $representers = $self->schema->representers;
146              
147 3000 100       7011 if (not defined $node->{value}) {
148 110 50       330 if (my $undef = $representers->{undef}) {
149 110 50       390 return 1 if $undef->($self, $node);
150             }
151             else {
152 0         0 $node->{style} = YAML_SINGLE_QUOTED_SCALAR_STYLE;
153 0         0 $node->{data} = '';
154 0         0 return 1;
155             }
156             }
157 2890 50 33     7428 if ($] >= 5.036000 and my $rep = $representers->{bool}) {
158 0   0     0 $is_bool ||= eval $bool_code;
159 0 0       0 if ($is_bool->($node->{value})) {
160 0         0 return $rep->{code}->($self, $node);
161             }
162             }
163 2890         3878 for my $rep (@{ $representers->{flags} }) {
  2890         7061  
164 4954         7576 my $check_flags = $rep->{flags};
165 4954         21211 my $flags = B::svref_2object(\$node->{value})->FLAGS;
166 4954 100       12690 if ($flags & $check_flags) {
167 514 100       1809 return 1 if $rep->{code}->($self, $node);
168             }
169              
170             }
171 2385 100       8090 if (my $rep = $representers->{equals}->{ $node->{value} }) {
172 137 50       566 return 1 if $rep->{code}->($self, $node);
173             }
174 2248         3183 for my $rep (@{ $representers->{regex} }) {
  2248         4614  
175 2044 100       18863 if ($node->{value} =~ $rep->{regex}) {
176 101 100       433 return 1 if $rep->{code}->($self, $node);
177             }
178             }
179 2153 50       5619 unless (defined $node->{data}) {
180 2153         4596 $node->{data} = $node->{value};
181             }
182 2153 100       4757 unless (defined $node->{style}) {
183 2137         3537 $node->{style} = YAML_ANY_SCALAR_STYLE;
184 2137         4254 $node->{style} = "";
185             }
186             }
187              
188             sub _represent_noderef {
189 804     804   1505 my ($self, $node) = @_;
190 804         1725 my $representers = $self->schema->representers;
191              
192 804 100       2699 if (my $classname = blessed($node->{value})) {
193 112 100       391 if (my $def = $representers->{class_equals}->{ $classname }) {
194 66         117 my $code = $def->{code};
195 66 50       243 return 1 if $code->($self, $node);
196             }
197 46         69 for my $matches (@{ $representers->{class_matches} }) {
  46         133  
198 43         111 my ($re, $code) = @$matches;
199 43 50 33     190 if (ref $re and $classname =~ $re or $re) {
      33        
200 43 100       137 return 1 if $code->($self, $node);
201             }
202             }
203 4         8 for my $isa (@{ $representers->{class_isa} }) {
  4         21  
204 3         10 my ($class_name, $code) = @$isa;
205 3 100       22 if ($node->{ value }->isa($class_name)) {
206 2 50       7 return 1 if $code->($self, $node);
207             }
208             }
209             }
210 694 100 100     1888 if ($node->{reftype} eq 'SCALAR' and my $scalarref = $representers->{scalarref}) {
211 4         10 my $code = $scalarref->{code};
212 4 50       15 return 1 if $code->($self, $node);
213             }
214 690 100 66     1859 if ($node->{reftype} eq 'REF' and my $refref = $representers->{refref}) {
215 4         13 my $code = $refref->{code};
216 4 50       19 return 1 if $code->($self, $node);
217             }
218 686 100 66     1780 if ($node->{reftype} eq 'CODE' and my $coderef = $representers->{coderef}) {
219 5         12 my $code = $coderef->{code};
220 5 50       20 return 1 if $code->($self, $node);
221             }
222 681 100 66     1558 if ($node->{reftype} eq 'GLOB' and my $glob = $representers->{glob}) {
223 6         10 my $code = $glob->{code};
224 6 50       22 return 1 if $code->($self, $node);
225             }
226 675         1487 $node->{data} = $node->{value};
227              
228             }
229              
230             1;