1# ABSTRACT: Construct data structure from Parser Events
2use strict;
3use warnings;
4package YAML::PP::Constructor;
5
6our $VERSION = '0.020'; # VERSION
7
8use YAML::PP;
9use Scalar::Util qw/ reftype /;
10
11use constant DEBUG => ($ENV{YAML_PP_LOAD_DEBUG} or $ENV{YAML_PP_LOAD_TRACE}) ? 1 : 0;
12use constant TRACE => $ENV{YAML_PP_LOAD_TRACE} ? 1 : 0;
13
14my %cyclic_refs = qw/ allow 1 ignore 1 warn 1 fatal 1 /;
15
16sub new {
17    my ($class, %args) = @_;
18
19    my $default_yaml_version = delete $args{default_yaml_version};
20    my $cyclic_refs = delete $args{cyclic_refs} || 'allow';
21    die "Invalid value for cyclic_refs: $cyclic_refs"
22        unless $cyclic_refs{ $cyclic_refs };
23    my $schemas = delete $args{schemas};
24
25    if (keys %args) {
26        die "Unexpected arguments: " . join ', ', sort keys %args;
27    }
28
29    my $self = bless {
30        default_yaml_version => $default_yaml_version,
31        schemas => $schemas,
32        cyclic_refs => $cyclic_refs,
33    }, $class;
34    $self->init;
35    return $self;
36}
37
38sub clone {
39    my ($self) = @_;
40    my $clone = {
41        schemas => $self->{schemas},
42        schema => $self->{schema},
43        default_yaml_version => $self->{default_yaml_version},
44        cyclic_refs => $self->cyclic_refs,
45    };
46    return bless $clone, ref $self;
47}
48
49sub init {
50    my ($self) = @_;
51    $self->set_docs([]);
52    $self->set_stack([]);
53    $self->set_anchors({});
54    $self->set_yaml_version($self->default_yaml_version);
55    $self->set_schema($self->schemas->{ $self->yaml_version } );
56}
57
58sub docs { return $_[0]->{docs} }
59sub stack { return $_[0]->{stack} }
60sub anchors { return $_[0]->{anchors} }
61sub set_docs { $_[0]->{docs} = $_[1] }
62sub set_stack { $_[0]->{stack} = $_[1] }
63sub set_anchors { $_[0]->{anchors} = $_[1] }
64sub schemas { return $_[0]->{schemas} }
65sub schema { return $_[0]->{schema} }
66sub set_schema { $_[0]->{schema} = $_[1] }
67sub cyclic_refs { return $_[0]->{cyclic_refs} }
68sub set_cyclic_refs { $_[0]->{cyclic_refs} = $_[1] }
69sub yaml_version { return $_[0]->{yaml_version} }
70sub set_yaml_version { $_[0]->{yaml_version} = $_[1] }
71sub default_yaml_version { return $_[0]->{default_yaml_version} }
72
73sub document_start_event {
74    my ($self, $event) = @_;
75    my $stack = $self->stack;
76    if ($event->{version_directive}) {
77        my $version = $event->{version_directive};
78        if ($self->{schemas}->{ $version }) {
79            $self->set_yaml_version($version);
80            $self->set_schema($self->schemas->{ $version });
81        }
82        else {
83            $self->set_yaml_version($self->default_yaml_version);
84            $self->set_schema($self->schemas->{ $self->default_yaml_version });
85        }
86    }
87    my $ref = [];
88    push @$stack, { type => 'document', ref => $ref, data => $ref, event => $event };
89}
90
91sub document_end_event {
92    my ($self, $event) = @_;
93    my $stack = $self->stack;
94    my $last = pop @$stack;
95    $last->{type} eq 'document' or die "Expected mapping, but got $last->{type}";
96    if (@$stack) {
97        die "Got unexpected end of document";
98    }
99    my $docs = $self->docs;
100    push @$docs, $last->{ref}->[0];
101    $self->set_anchors({});
102    $self->set_stack([]);
103}
104
105sub mapping_start_event {
106    my ($self, $event) = @_;
107    my ($data, $on_data) = $self->schema->create_mapping($self, $event);
108    my $ref = {
109        type => 'mapping',
110        ref => [],
111        data => $data,
112        event => $event,
113        on_data => $on_data,
114    };
115    my $stack = $self->stack;
116
117    push @$stack, $ref;
118    if (defined(my $anchor = $event->{anchor})) {
119        $self->anchors->{ $anchor } = { data => $ref->{data} };
120    }
121}
122
123sub mapping_end_event {
124    my ($self, $event) = @_;
125    my $stack = $self->stack;
126
127    my $last = pop @$stack;
128    my ($ref, $data) = @{ $last }{qw/ ref data /};
129    $last->{type} eq 'mapping' or die "Expected mapping, but got $last->{type}";
130
131    my @merge_keys;
132    my @ref;
133    for (my $i = 0; $i < @$ref; $i += 2) {
134        my $key = $ref->[ $i ];
135        if (ref $key eq 'YAML::PP::Type::MergeKey') {
136            my $merge = $ref->[ $i + 1 ];
137            if ((reftype($merge) || '') eq 'HASH') {
138                push @merge_keys, $merge;
139            }
140            elsif ((reftype($merge) || '') eq 'ARRAY') {
141                for my $item (@$merge) {
142                    if ((reftype($item) || '') eq 'HASH') {
143                        push @merge_keys, $item;
144                    }
145                    else {
146                        die "Expected hash for merge key";
147                    }
148                }
149            }
150            else {
151                die "Expected hash or array for merge key";
152            }
153        }
154        else {
155            push @ref, $key, $ref->[ $i + 1 ];
156        }
157    }
158    for my $merge (@merge_keys) {
159        for my $key (keys %$merge) {
160            unless (exists $data->{ $key }) {
161                $data->{ $key } = $merge->{ $key };
162            }
163        }
164    }
165    my $on_data = $last->{on_data} || sub {
166        my ($self, $hash, $items) = @_;
167        for (my $i = 0; $i < @$items; $i += 2) {
168            my ($key, $value) = @$items[ $i, $i + 1 ];
169            $key = '' unless defined $key;
170            if (ref $key) {
171                $key = $self->stringify_complex($key);
172            }
173            $$hash->{ $key } = $value;
174        }
175    };
176    $on_data->($self, \$data, \@ref);
177    push @{ $stack->[-1]->{ref} }, $data;
178    if (defined(my $anchor = $last->{event}->{anchor})) {
179        $self->anchors->{ $anchor }->{finished} = 1;
180    }
181    return;
182}
183
184sub sequence_start_event {
185    my ($self, $event) = @_;
186    my ($data, $on_data) = $self->schema->create_sequence($self, $event);
187    my $ref = {
188        type => 'sequence',
189        ref => [],
190        data => $data,
191        event => $event,
192        on_data => $on_data,
193    };
194    my $stack = $self->stack;
195
196    push @$stack, $ref;
197    if (defined(my $anchor = $event->{anchor})) {
198        $self->anchors->{ $anchor } = { data => $ref->{data} };
199    }
200}
201
202sub sequence_end_event {
203    my ($self, $event) = @_;
204    my $stack = $self->stack;
205    my $last = pop @$stack;
206    $last->{type} eq 'sequence' or die "Expected mapping, but got $last->{type}";
207    my ($ref, $data) = @{ $last }{qw/ ref data /};
208
209    my $on_data = $last->{on_data} || sub {
210        my ($self, $array, $items) = @_;
211        push @$$array, @$items;
212    };
213    $on_data->($self, \$data, $ref);
214    push @{ $stack->[-1]->{ref} }, $data;
215    if (defined(my $anchor = $last->{event}->{anchor})) {
216        $self->anchors->{ $anchor }->{finished} = 1;
217    }
218    return;
219}
220
221sub stream_start_event {}
222
223sub stream_end_event {}
224
225sub scalar_event {
226    my ($self, $event) = @_;
227    DEBUG and warn "CONTENT $event->{value} ($event->{style})\n";
228    my $value = $self->schema->load_scalar($self, $event);
229    if (defined (my $name = $event->{anchor})) {
230        $self->anchors->{ $name } = { data => $value, finished => 1 };
231    }
232    my $last = $self->stack->[-1];
233    push @{ $last->{ref} }, $value;
234}
235
236sub alias_event {
237    my ($self, $event) = @_;
238    my $value;
239    my $name = $event->{value};
240    if (my $anchor = $self->anchors->{ $name }) {
241        # We know this is a cyclic ref since the node hasn't
242        # been constructed completely yet
243        unless ($anchor->{finished} ) {
244            my $cyclic_refs = $self->cyclic_refs;
245            if ($cyclic_refs ne 'allow') {
246                if ($cyclic_refs eq 'fatal') {
247                    die "Found cyclic ref";
248                }
249                if ($cyclic_refs eq 'warn') {
250                    $anchor = { data => undef };
251                    warn "Found cyclic ref";
252                }
253                elsif ($cyclic_refs eq 'ignore') {
254                    $anchor = { data => undef };
255                }
256            }
257        }
258        $value = $anchor->{data};
259    }
260    my $last = $self->stack->[-1];
261    push @{ $last->{ref} }, $value;
262}
263
264sub stringify_complex {
265    my ($self, $data) = @_;
266    require Data::Dumper;
267    local $Data::Dumper::Quotekeys = 0;
268    local $Data::Dumper::Terse = 1;
269    local $Data::Dumper::Indent = 0;
270    local $Data::Dumper::Useqq = 0;
271    local $Data::Dumper::Sortkeys = 1;
272    my $string = Data::Dumper->Dump([$data], ['data']);
273    $string =~ s/^\$data = //;
274    return $string;
275}
276
2771;
278
279__END__
280
281=pod
282
283=encoding utf-8
284
285=head1 NAME
286
287YAML::PP::Constructor - Constructing data structure from parsing events
288
289=head1 METHODS
290
291=over
292
293=item new
294
295The Constructor constructor
296
297    my $constructor = YAML::PP::Constructor->new(
298        schema => $schema,
299        cyclic_refs => $cyclic_refs,
300    );
301
302=item init
303
304Resets any data being used during construction.
305
306    $constructor->init;
307
308=item document_start_event, document_end_event, mapping_start_event, mapping_end_event, sequence_start_event, sequence_end_event, scalar_event, alias_event, stream_start_event, stream_end_event
309
310These methods are called from L<YAML::PP::Parser>:
311
312    $constructor->document_start_event($event);
313
314=item anchors, set_anchors
315
316Helper for storing anchors during construction
317
318=item docs, set_docs
319
320Helper for storing resulting documents during construction
321
322=item stack, set_stack
323
324Helper for storing data during construction
325
326=item cyclic_refs, set_cyclic_refs
327
328Option for controlling the behaviour when finding circular references
329
330=item schema, set_schema
331
332Holds a L<YAML::PP::Schema> object
333
334=item stringify_complex
335
336When constructing a hash and getting a non-scalar key, this method is
337used to stringify the key.
338
339It uses a terse Data::Dumper output. Other modules, like L<YAML::XS>, use
340the default stringification, C<ARRAY(0x55617c0c7398)> for example.
341
342=back
343
344=cut
345