source: devel/pb-modules/lib/ProjectBuilder/YAML.pm @ 2495

Last change on this file since 2495 was 2495, checked in by Bruno Cornec, 3 months ago

Rename functions to avoid clashes

File size: 42.3 KB
Line 
1use 5.008001; # sane UTF-8 support
2use strict;
3use warnings;
4# Original is YAML::Tiny git description: v1.72-7-g8682f63
5# We rename it here to allow embedded usage during setupv
6# when no YAML implementation is available on the target system
7#
8package ProjectBuilder::YAML;
9# XXX-INGY is 5.8.1 too old/broken for utf8?
10# XXX-XDG Lancaster consensus was that it was sufficient until
11# proven otherwise
12
13our $VERSION = '1.73';
14
15#####################################################################
16# The ProjectBuilder::YAML API.
17#
18# These are the currently documented API functions/methods and
19# exports:
20
21use Exporter;
22our @ISA       = qw{ Exporter  };
23our @EXPORT    = qw{ pb_Load pb_Dump };
24our @EXPORT_OK = qw{ pb_LoadFile pb_DumpFile freeze thaw };
25
26###
27# Functional/Export API:
28
29sub pb_Dump {
30    return ProjectBuilder::YAML->new(@_)->_dump_string;
31}
32
33# XXX-INGY Returning last document seems a bad behavior.
34# XXX-XDG I think first would seem more natural, but I don't know
35# that it's worth changing now
36sub pb_Load {
37    my $self = ProjectBuilder::YAML->_load_string(@_);
38    if ( wantarray ) {
39        return @$self;
40    } else {
41        # To match YAML.pm, return the last document
42        return $self->[-1];
43    }
44}
45
46# XXX-INGY Do we really need freeze and thaw?
47# XXX-XDG I don't think so.  I'd support deprecating them.
48BEGIN {
49    *freeze = \&pb_Dump;
50    *thaw   = \&pb_Load;
51}
52
53sub pb_DumpFile {
54    my $file = shift;
55    return ProjectBuilder::YAML->new(@_)->_dump_file($file);
56}
57
58sub pb_LoadFile {
59    my $file = shift;
60    my $self = ProjectBuilder::YAML->_load_file($file);
61    if ( wantarray ) {
62        return @$self;
63    } else {
64        # Return only the last document to match YAML.pm,
65        return $self->[-1];
66    }
67}
68
69
70###
71# Object Oriented API:
72
73# Create an empty ProjectBuilder::YAML object
74# XXX-INGY Why do we use ARRAY object?
75# NOTE: I get it now, but I think it's confusing and not needed.
76# Will change it on a branch later, for review.
77#
78# XXX-XDG I don't support changing it yet.  It's a very well-documented
79# "API" of ProjectBuilder::YAML.  I'd support deprecating it, but Adam suggested
80# we not change it until YAML.pm's own OO API is established so that
81# users only have one API change to digest, not two
82sub new {
83    my $class = shift;
84    bless [ @_ ], $class;
85}
86
87# XXX-INGY It probably doesn't matter, and it's probably too late to
88# change, but 'read/write' are the wrong names. Read and Write
89# are actions that take data from storage to memory
90# characters/strings. These take the data to/from storage to native
91# Perl objects, which the terms dump and load are meant. As long as
92# this is a legacy quirk to ProjectBuilder::YAML it's ok, but I'd prefer not
93# to add new {read,write}_* methods to this API.
94
95sub read_string {
96    my $self = shift;
97    $self->_load_string(@_);
98}
99
100sub write_string {
101    my $self = shift;
102    $self->_dump_string(@_);
103}
104
105sub read {
106    my $self = shift;
107    $self->_load_file(@_);
108}
109
110sub write {
111    my $self = shift;
112    $self->_dump_file(@_);
113}
114
115
116
117
118#####################################################################
119# Constants
120
121# Printed form of the unprintable characters in the lowest range
122# of ASCII characters, listed by ASCII ordinal position.
123my @UNPRINTABLE = qw(
124    0    x01  x02  x03  x04  x05  x06  a
125    b    t    n    v    f    r    x0E  x0F
126    x10  x11  x12  x13  x14  x15  x16  x17
127    x18  x19  x1A  e    x1C  x1D  x1E  x1F
128);
129
130# Printable characters for escapes
131my %UNESCAPES = (
132    0 => "\x00", z => "\x00", N    => "\x85",
133    a => "\x07", b => "\x08", t    => "\x09",
134    n => "\x0a", v => "\x0b", f    => "\x0c",
135    r => "\x0d", e => "\x1b", '\\' => '\\',
136);
137
138# XXX-INGY
139# I(ngy) need to decide if these values should be quoted in
140# ProjectBuilder::YAML or not. Probably yes.
141
142# These 3 values have special meaning when unquoted and using the
143# default YAML schema. They need quotes if they are strings.
144my %QUOTE = map { $_ => 1 } qw{
145    null true false
146};
147
148# The commented out form is simpler, but overloaded the Perl regex
149# engine due to recursion and backtracking problems on strings
150# larger than 32,000ish characters. Keep it for reference purposes.
151# qr/\"((?:\\.|[^\"])*)\"/
152my $re_capture_double_quoted = qr/\"([^\\"]*(?:\\.[^\\"]*)*)\"/;
153my $re_capture_single_quoted = qr/\'([^\']*(?:\'\'[^\']*)*)\'/;
154# unquoted re gets trailing space that needs to be stripped
155my $re_capture_unquoted_key  = qr/([^:]+(?::+\S(?:[^:]*|.*?(?=:)))*)(?=\s*\:(?:\s+|$))/;
156my $re_trailing_comment      = qr/(?:\s+\#.*)?/;
157my $re_key_value_separator   = qr/\s*:(?:\s+(?:\#.*)?|$)/;
158
159
160
161
162
163#####################################################################
164# ProjectBuilder::YAML Implementation.
165#
166# These are the private methods that do all the work. They may change
167# at any time.
168
169
170###
171# Loader functions:
172
173# Create an object from a file
174sub _load_file {
175    my $class = ref $_[0] ? ref shift : shift;
176
177    # Check the file
178    my $file = shift or $class->_error( 'You did not specify a file name' );
179    $class->_error( "File '$file' does not exist" )
180        unless -e $file;
181    $class->_error( "'$file' is a directory, not a file" )
182        unless -f _;
183    $class->_error( "Insufficient permissions to read '$file'" )
184        unless -r _;
185
186    # Open unbuffered with strict UTF-8 decoding and no translation layers
187    open( my $fh, "<:unix:encoding(UTF-8)", $file );
188    unless ( $fh ) {
189        $class->_error("Failed to open file '$file': $!");
190    }
191
192    # flock if available (or warn if not possible for OS-specific reasons)
193    if ( _can_flock() ) {
194        flock( $fh, Fcntl::LOCK_SH() )
195            or warn "Couldn't lock '$file' for reading: $!";
196    }
197
198    # slurp the contents
199    my $contents = eval {
200        use warnings FATAL => 'utf8';
201        local $/;
202        <$fh>
203    };
204    if ( my $err = $@ ) {
205        $class->_error("Error reading from file '$file': $err");
206    }
207
208    # close the file (release the lock)
209    unless ( close $fh ) {
210        $class->_error("Failed to close file '$file': $!");
211    }
212
213    $class->_load_string( $contents );
214}
215
216# Create an object from a string
217sub _load_string {
218    my $class  = ref $_[0] ? ref shift : shift;
219    my $self   = bless [], $class;
220    my $string = $_[0];
221    eval {
222        unless ( defined $string ) {
223            die \"Did not provide a string to load";
224        }
225
226        # Check if Perl has it marked as characters, but it's internally
227        # inconsistent.  E.g. maybe latin1 got read on a :utf8 layer
228        if ( utf8::is_utf8($string) && ! utf8::valid($string) ) {
229            die \<<'...';
230Read an invalid UTF-8 string (maybe mixed UTF-8 and 8-bit character set).
231Did you decode with lax ":utf8" instead of strict ":encoding(UTF-8)"?
232...
233        }
234
235        # Ensure Unicode character semantics, even for 0x80-0xff
236        utf8::upgrade($string);
237
238        # Check for and strip any leading UTF-8 BOM
239        $string =~ s/^\x{FEFF}//;
240
241        # Check for some special cases
242        return $self unless length $string;
243
244        # Split the file into lines
245        my @lines = grep { ! /^\s*(?:\#.*)?\z/ }
246                split /(?:\015{1,2}\012|\015|\012)/, $string;
247
248        # Strip the initial YAML header
249        @lines and $lines[0] =~ /^\%YAML[: ][\d\.]+.*\z/ and shift @lines;
250
251        # A nibbling parser
252        my $in_document = 0;
253        while ( @lines ) {
254            # Do we have a document header?
255            if ( $lines[0] =~ /^---\s*(?:(.+)\s*)?\z/ ) {
256                # Handle scalar documents
257                shift @lines;
258                if ( defined $1 and $1 !~ /^(?:\#.+|\%YAML[: ][\d\.]+)\z/ ) {
259                    push @$self,
260                        $self->_load_scalar( "$1", [ undef ], \@lines );
261                    next;
262                }
263                $in_document = 1;
264            }
265
266            if ( ! @lines or $lines[0] =~ /^(?:---|\.\.\.)/ ) {
267                # A naked document
268                push @$self, undef;
269                while ( @lines and $lines[0] !~ /^---/ ) {
270                    shift @lines;
271                }
272                $in_document = 0;
273
274            # XXX The final '-+$' is to look for -- which ends up being an
275            # error later.
276            } elsif ( ! $in_document && @$self ) {
277                # only the first document can be explicit
278                die \"ProjectBuilder::YAML failed to classify the line '$lines[0]'";
279            } elsif ( $lines[0] =~ /^\s*\-(?:\s|$|-+$)/ ) {
280                # An array at the root
281                my $document = [ ];
282                push @$self, $document;
283                $self->_load_array( $document, [ 0 ], \@lines );
284
285            } elsif ( $lines[0] =~ /^(\s*)\S/ ) {
286                # A hash at the root
287                my $document = { };
288                push @$self, $document;
289                $self->_load_hash( $document, [ length($1) ], \@lines );
290
291            } else {
292                # Shouldn't get here.  @lines have whitespace-only lines
293                # stripped, and previous match is a line with any
294                # non-whitespace.  So this clause should only be reachable via
295                # a perlbug where \s is not symmetric with \S
296
297                # uncoverable statement
298                die \"ProjectBuilder::YAML failed to classify the line '$lines[0]'";
299            }
300        }
301    };
302    my $err = $@;
303    if ( ref $err eq 'SCALAR' ) {
304        $self->_error(${$err});
305    } elsif ( $err ) {
306        $self->_error($err);
307    }
308
309    return $self;
310}
311
312sub _unquote_single {
313    my ($self, $string) = @_;
314    return '' unless length $string;
315    $string =~ s/\'\'/\'/g;
316    return $string;
317}
318
319sub _unquote_double {
320    my ($self, $string) = @_;
321    return '' unless length $string;
322    $string =~ s/\\"/"/g;
323    $string =~
324        s{\\([Nnever\\fartz0b]|x([0-9a-fA-F]{2}))}
325         {(length($1)>1)?pack("H2",$2):$UNESCAPES{$1}}gex;
326    return $string;
327}
328
329# Load a YAML scalar string to the actual Perl scalar
330sub _load_scalar {
331    my ($self, $string, $indent, $lines) = @_;
332
333    # Trim trailing whitespace
334    $string =~ s/\s*\z//;
335
336    # Explitic null/undef
337    return undef if $string eq '~';
338
339    # Single quote
340    if ( $string =~ /^$re_capture_single_quoted$re_trailing_comment\z/ ) {
341        return $self->_unquote_single($1);
342    }
343
344    # Double quote.
345    if ( $string =~ /^$re_capture_double_quoted$re_trailing_comment\z/ ) {
346        return $self->_unquote_double($1);
347    }
348
349    # Special cases
350    if ( $string =~ /^[\'\"!&]/ ) {
351        die \"ProjectBuilder::YAML does not support a feature in line '$string'";
352    }
353    return {} if $string =~ /^{}(?:\s+\#.*)?\z/;
354    return [] if $string =~ /^\[\](?:\s+\#.*)?\z/;
355
356    # Regular unquoted string
357    if ( $string !~ /^[>|]/ ) {
358        die \"ProjectBuilder::YAML found illegal characters in plain scalar: '$string'"
359            if $string =~ /^(?:-(?:\s|$)|[\@\%\`])/ or
360                $string =~ /:(?:\s|$)/;
361        $string =~ s/\s+#.*\z//;
362        return $string;
363    }
364
365    # Error
366    die \"ProjectBuilder::YAML failed to find multi-line scalar content" unless @$lines;
367
368    # Check the indent depth
369    $lines->[0]   =~ /^(\s*)/;
370    $indent->[-1] = length("$1");
371    if ( defined $indent->[-2] and $indent->[-1] <= $indent->[-2] ) {
372        die \"ProjectBuilder::YAML found bad indenting in line '$lines->[0]'";
373    }
374
375    # Pull the lines
376    my @multiline = ();
377    while ( @$lines ) {
378        $lines->[0] =~ /^(\s*)/;
379        last unless length($1) >= $indent->[-1];
380        push @multiline, substr(shift(@$lines), $indent->[-1]);
381    }
382
383    my $j = (substr($string, 0, 1) eq '>') ? ' ' : "\n";
384    my $t = (substr($string, 1, 1) eq '-') ? ''  : "\n";
385    return join( $j, @multiline ) . $t;
386}
387
388# Load an array
389sub _load_array {
390    my ($self, $array, $indent, $lines) = @_;
391
392    while ( @$lines ) {
393        # Check for a new document
394        if ( $lines->[0] =~ /^(?:---|\.\.\.)/ ) {
395            while ( @$lines and $lines->[0] !~ /^---/ ) {
396                shift @$lines;
397            }
398            return 1;
399        }
400
401        # Check the indent level
402        $lines->[0] =~ /^(\s*)/;
403        if ( length($1) < $indent->[-1] ) {
404            return 1;
405        } elsif ( length($1) > $indent->[-1] ) {
406            die \"ProjectBuilder::YAML found bad indenting in line '$lines->[0]'";
407        }
408
409        if ( $lines->[0] =~ /^(\s*\-\s+)[^\'\"]\S*\s*:(?:\s+|$)/ ) {
410            # Inline nested hash
411            my $indent2 = length("$1");
412            $lines->[0] =~ s/-/ /;
413            push @$array, { };
414            $self->_load_hash( $array->[-1], [ @$indent, $indent2 ], $lines );
415
416        } elsif ( $lines->[0] =~ /^\s*\-\s*\z/ ) {
417            shift @$lines;
418            unless ( @$lines ) {
419                push @$array, undef;
420                return 1;
421            }
422            if ( $lines->[0] =~ /^(\s*)\-/ ) {
423                my $indent2 = length("$1");
424                if ( $indent->[-1] == $indent2 ) {
425                    # Null array entry
426                    push @$array, undef;
427                } else {
428                    # Naked indenter
429                    push @$array, [ ];
430                    $self->_load_array(
431                        $array->[-1], [ @$indent, $indent2 ], $lines
432                    );
433                }
434
435            } elsif ( $lines->[0] =~ /^(\s*)\S/ ) {
436                push @$array, { };
437                $self->_load_hash(
438                    $array->[-1], [ @$indent, length("$1") ], $lines
439                );
440
441            } else {
442                die \"ProjectBuilder::YAML failed to classify line '$lines->[0]'";
443            }
444
445        } elsif ( $lines->[0] =~ /^\s*\-(\s*)(.+?)\s*\z/ ) {
446            # Array entry with a value
447            shift @$lines;
448            push @$array, $self->_load_scalar(
449                "$2", [ @$indent, undef ], $lines
450            );
451
452        } elsif ( defined $indent->[-2] and $indent->[-1] == $indent->[-2] ) {
453            # This is probably a structure like the following...
454            # ---
455            # foo:
456            # - list
457            # bar: value
458            #
459            # ... so lets return and let the hash parser handle it
460            return 1;
461
462        } else {
463            die \"ProjectBuilder::YAML failed to classify line '$lines->[0]'";
464        }
465    }
466
467    return 1;
468}
469
470# Load a hash
471sub _load_hash {
472    my ($self, $hash, $indent, $lines) = @_;
473
474    while ( @$lines ) {
475        # Check for a new document
476        if ( $lines->[0] =~ /^(?:---|\.\.\.)/ ) {
477            while ( @$lines and $lines->[0] !~ /^---/ ) {
478                shift @$lines;
479            }
480            return 1;
481        }
482
483        # Check the indent level
484        $lines->[0] =~ /^(\s*)/;
485        if ( length($1) < $indent->[-1] ) {
486            return 1;
487        } elsif ( length($1) > $indent->[-1] ) {
488            die \"ProjectBuilder::YAML found bad indenting in line '$lines->[0]'";
489        }
490
491        # Find the key
492        my $key;
493
494        # Quoted keys
495        if ( $lines->[0] =~
496            s/^\s*$re_capture_single_quoted$re_key_value_separator//
497        ) {
498            $key = $self->_unquote_single($1);
499        }
500        elsif ( $lines->[0] =~
501            s/^\s*$re_capture_double_quoted$re_key_value_separator//
502        ) {
503            $key = $self->_unquote_double($1);
504        }
505        elsif ( $lines->[0] =~
506            s/^\s*$re_capture_unquoted_key$re_key_value_separator//
507        ) {
508            $key = $1;
509            $key =~ s/\s+$//;
510        }
511        elsif ( $lines->[0] =~ /^\s*\?/ ) {
512            die \"ProjectBuilder::YAML does not support a feature in line '$lines->[0]'";
513        }
514        else {
515            die \"ProjectBuilder::YAML failed to classify line '$lines->[0]'";
516        }
517
518        if ( exists $hash->{$key} ) {
519            warn "ProjectBuilder::YAML found a duplicate key '$key' in line '$lines->[0]'";
520        }
521
522        # Do we have a value?
523        if ( length $lines->[0] ) {
524            # Yes
525            $hash->{$key} = $self->_load_scalar(
526                shift(@$lines), [ @$indent, undef ], $lines
527            );
528        } else {
529            # An indent
530            shift @$lines;
531            unless ( @$lines ) {
532                $hash->{$key} = undef;
533                return 1;
534            }
535            if ( $lines->[0] =~ /^(\s*)-/ ) {
536                $hash->{$key} = [];
537                $self->_load_array(
538                    $hash->{$key}, [ @$indent, length($1) ], $lines
539                );
540            } elsif ( $lines->[0] =~ /^(\s*)./ ) {
541                my $indent2 = length("$1");
542                if ( $indent->[-1] >= $indent2 ) {
543                    # Null hash entry
544                    $hash->{$key} = undef;
545                } else {
546                    $hash->{$key} = {};
547                    $self->_load_hash(
548                        $hash->{$key}, [ @$indent, length($1) ], $lines
549                    );
550                }
551            }
552        }
553    }
554
555    return 1;
556}
557
558
559###
560# Dumper functions:
561
562# Save an object to a file
563sub _dump_file {
564    my $self = shift;
565
566    require Fcntl;
567
568    # Check the file
569    my $file = shift or $self->_error( 'You did not specify a file name' );
570
571    my $fh;
572    # flock if available (or warn if not possible for OS-specific reasons)
573    if ( _can_flock() ) {
574        # Open without truncation (truncate comes after lock)
575        my $flags = Fcntl::O_WRONLY()|Fcntl::O_CREAT();
576        sysopen( $fh, $file, $flags )
577            or $self->_error("Failed to open file '$file' for writing: $!");
578
579        # Use no translation and strict UTF-8
580        binmode( $fh, ":raw:encoding(UTF-8)");
581
582        flock( $fh, Fcntl::LOCK_EX() )
583            or warn "Couldn't lock '$file' for reading: $!";
584
585        # truncate and spew contents
586        truncate $fh, 0;
587        seek $fh, 0, 0;
588    }
589    else {
590        open $fh, ">:unix:encoding(UTF-8)", $file;
591    }
592
593    # serialize and spew to the handle
594    print {$fh} $self->_dump_string;
595
596    # close the file (release the lock)
597    unless ( close $fh ) {
598        $self->_error("Failed to close file '$file': $!");
599    }
600
601    return 1;
602}
603
604# Save an object to a string
605sub _dump_string {
606    my $self = shift;
607    return '' unless ref $self && @$self;
608
609    # Iterate over the documents
610    my $indent = 0;
611    my @lines  = ();
612
613    eval {
614        foreach my $cursor ( @$self ) {
615            push @lines, '---';
616
617            # An empty document
618            if ( ! defined $cursor ) {
619                # Do nothing
620
621            # A scalar document
622            } elsif ( ! ref $cursor ) {
623                $lines[-1] .= ' ' . $self->_dump_scalar( $cursor );
624
625            # A list at the root
626            } elsif ( ref $cursor eq 'ARRAY' ) {
627                unless ( @$cursor ) {
628                    $lines[-1] .= ' []';
629                    next;
630                }
631                push @lines, $self->_dump_array( $cursor, $indent, {} );
632
633            # A hash at the root
634            } elsif ( ref $cursor eq 'HASH' ) {
635                unless ( %$cursor ) {
636                    $lines[-1] .= ' {}';
637                    next;
638                }
639                push @lines, $self->_dump_hash( $cursor, $indent, {} );
640
641            } else {
642                die \("Cannot serialize " . ref($cursor));
643            }
644        }
645    };
646    if ( ref $@ eq 'SCALAR' ) {
647        $self->_error(${$@});
648    } elsif ( $@ ) {
649        $self->_error($@);
650    }
651
652    join '', map { "$_\n" } @lines;
653}
654
655sub _has_internal_string_value {
656    my $value = shift;
657    my $b_obj = B::svref_2object(\$value);  # for round trip problem
658    return $b_obj->FLAGS & B::SVf_POK();
659}
660
661sub _dump_scalar {
662    my $string = $_[1];
663    my $is_key = $_[2];
664    # Check this before checking length or it winds up looking like a string!
665    my $has_string_flag = _has_internal_string_value($string);
666    return '~'  unless defined $string;
667    return "''" unless length  $string;
668    if (Scalar::Util::looks_like_number($string)) {
669        # keys and values that have been used as strings get quoted
670        if ( $is_key || $has_string_flag ) {
671            return qq['$string'];
672        }
673        else {
674            return $string;
675        }
676    }
677    if ( $string =~ /[\x00-\x09\x0b-\x0d\x0e-\x1f\x7f-\x9f\'\n]/ ) {
678        $string =~ s/\\/\\\\/g;
679        $string =~ s/"/\\"/g;
680        $string =~ s/\n/\\n/g;
681        $string =~ s/[\x85]/\\N/g;
682        $string =~ s/([\x00-\x1f])/\\$UNPRINTABLE[ord($1)]/g;
683        $string =~ s/([\x7f-\x9f])/'\x' . sprintf("%X",ord($1))/ge;
684        return qq|"$string"|;
685    }
686    if ( $string =~ /(?:^[~!@#%&*|>?:,'"`{}\[\]]|^-+$|\s|:\z)/ or
687        $QUOTE{$string}
688    ) {
689        return "'$string'";
690    }
691    return $string;
692}
693
694sub _dump_array {
695    my ($self, $array, $indent, $seen) = @_;
696    if ( $seen->{refaddr($array)}++ ) {
697        die \"ProjectBuilder::YAML does not support circular references";
698    }
699    my @lines  = ();
700    foreach my $el ( @$array ) {
701        my $line = ('  ' x $indent) . '-';
702        my $type = ref $el;
703        if ( ! $type ) {
704            $line .= ' ' . $self->_dump_scalar( $el );
705            push @lines, $line;
706
707        } elsif ( $type eq 'ARRAY' ) {
708            if ( @$el ) {
709                push @lines, $line;
710                push @lines, $self->_dump_array( $el, $indent + 1, $seen );
711            } else {
712                $line .= ' []';
713                push @lines, $line;
714            }
715
716        } elsif ( $type eq 'HASH' ) {
717            if ( keys %$el ) {
718                push @lines, $line;
719                push @lines, $self->_dump_hash( $el, $indent + 1, $seen );
720            } else {
721                $line .= ' {}';
722                push @lines, $line;
723            }
724
725        } else {
726            die \"ProjectBuilder::YAML does not support $type references";
727        }
728    }
729
730    @lines;
731}
732
733sub _dump_hash {
734    my ($self, $hash, $indent, $seen) = @_;
735    if ( $seen->{refaddr($hash)}++ ) {
736        die \"ProjectBuilder::YAML does not support circular references";
737    }
738    my @lines  = ();
739    foreach my $name ( sort keys %$hash ) {
740        my $el   = $hash->{$name};
741        my $line = ('  ' x $indent) . $self->_dump_scalar($name, 1) . ":";
742        my $type = ref $el;
743        if ( ! $type ) {
744            $line .= ' ' . $self->_dump_scalar( $el );
745            push @lines, $line;
746
747        } elsif ( $type eq 'ARRAY' ) {
748            if ( @$el ) {
749                push @lines, $line;
750                push @lines, $self->_dump_array( $el, $indent + 1, $seen );
751            } else {
752                $line .= ' []';
753                push @lines, $line;
754            }
755
756        } elsif ( $type eq 'HASH' ) {
757            if ( keys %$el ) {
758                push @lines, $line;
759                push @lines, $self->_dump_hash( $el, $indent + 1, $seen );
760            } else {
761                $line .= ' {}';
762                push @lines, $line;
763            }
764
765        } else {
766            die \"ProjectBuilder::YAML does not support $type references";
767        }
768    }
769
770    @lines;
771}
772
773
774
775#####################################################################
776# DEPRECATED API methods:
777
778# Error storage (DEPRECATED as of 1.57)
779our $errstr    = '';
780
781# Set error
782sub _error {
783    require Carp;
784    $errstr = $_[1];
785    $errstr =~ s/ at \S+ line \d+.*//;
786    Carp::croak( $errstr );
787}
788
789# Retrieve error
790my $errstr_warned;
791sub errstr {
792    require Carp;
793    Carp::carp( "ProjectBuilder::YAML->errstr and \$ProjectBuilder::YAML::errstr is deprecated" )
794        unless $errstr_warned++;
795    $errstr;
796}
797
798
799
800
801#####################################################################
802# Helper functions. Possibly not needed.
803
804
805# Use to detect nv or iv
806use B;
807
808# XXX-INGY Is flock ProjectBuilder::YAML's responsibility?
809# Some platforms can't flock :-(
810# XXX-XDG I think it is.  When reading and writing files, we ought
811# to be locking whenever possible.  People (foolishly) use YAML
812# files for things like session storage, which has race issues.
813my $HAS_FLOCK;
814sub _can_flock {
815    if ( defined $HAS_FLOCK ) {
816        return $HAS_FLOCK;
817    }
818    else {
819        require Config;
820        my $c = \%Config::Config;
821        $HAS_FLOCK = grep { $c->{$_} } qw/d_flock d_fcntl_can_lock d_lockf/;
822        require Fcntl if $HAS_FLOCK;
823        return $HAS_FLOCK;
824    }
825}
826
827
828# XXX-INGY Is this core in 5.8.1? Can we remove this?
829# XXX-XDG Scalar::Util 1.18 didn't land until 5.8.8, so we need this
830#####################################################################
831# Use Scalar::Util if possible, otherwise emulate it
832
833use Scalar::Util ();
834BEGIN {
835    local $@;
836    if ( eval { Scalar::Util->VERSION(1.18); } ) {
837        *refaddr = *Scalar::Util::refaddr;
838    }
839    else {
840        eval <<'END_PERL';
841# Scalar::Util failed to load or too old
842sub refaddr {
843    my $pkg = ref($_[0]) or return undef;
844    if ( !! UNIVERSAL::can($_[0], 'can') ) {
845        bless $_[0], 'Scalar::Util::Fake';
846    } else {
847        $pkg = undef;
848    }
849    "$_[0]" =~ /0x(\w+)/;
850    my $i = do { no warnings 'portable'; hex $1 };
851    bless $_[0], $pkg if defined $pkg;
852    $i;
853}
854END_PERL
855    }
856}
857
858delete $ProjectBuilder::YAML::{refaddr};
859
8601;
861
862# XXX-INGY Doc notes I'm putting up here. Changing the doc when it's wrong
863# but leaving grey area stuff up here.
864#
865# I would like to change Read/Write to Load/Dump below without
866# changing the actual API names.
867#
868# It might be better to put Load/Dump API in the SYNOPSIS instead of the
869# dubious OO API.
870#
871# null and bool explanations may be outdated.
872
873__END__
874
875=pod
876
877=head1 NAME
878
879ProjectBuilder::YAML - Read/Write YAML files with as little code as possible
880
881=head1 VERSION
882
883version 1.73
884
885=head1 PREAMBLE
886
887The YAML specification is huge. Really, B<really> huge. It contains all the
888functionality of XML, except with flexibility and choice, which makes it
889easier to read, but with a formal specification that is more complex than
890XML.
891
892The original pure-Perl implementation L<YAML> costs just over 4 megabytes
893of memory to load. Just like with Windows F<.ini> files (3 meg to load) and
894CSS (3.5 meg to load) the situation is just asking for a B<ProjectBuilder::YAML>
895module, an incomplete but correct and usable subset of the functionality,
896in as little code as possible.
897
898Like the other C<::Tiny> modules, ProjectBuilder::YAML has no non-core dependencies,
899does not require a compiler to install, is back-compatible to Perl v5.8.1,
900and can be inlined into other modules if needed.
901
902In exchange for this adding this extreme flexibility, it provides support
903for only a limited subset of YAML. But the subset supported contains most
904of the features for the more common uses of YAML.
905
906=head1 SYNOPSIS
907
908Assuming F<file.yml> like this:
909
910    ---
911    rootproperty: blah
912    section:
913      one: two
914      three: four
915      Foo: Bar
916      empty: ~
917
918
919Read and write F<file.yml> like this:
920
921    use ProjectBuilder::YAML;
922
923    # Open the config
924    my $yaml = ProjectBuilder::YAML->read( 'file.yml' );
925
926    # Get a reference to the first document
927    my $config = $yaml->[0];
928
929    # Or read properties directly
930    my $root = $yaml->[0]->{rootproperty};
931    my $one  = $yaml->[0]->{section}->{one};
932    my $Foo  = $yaml->[0]->{section}->{Foo};
933
934    # Change data directly
935    $yaml->[0]->{newsection} = { this => 'that' }; # Add a section
936    $yaml->[0]->{section}->{Foo} = 'Not Bar!';     # Change a value
937    delete $yaml->[0]->{section};                  # Delete a value
938
939    # Save the document back to the file
940    $yaml->write( 'file.yml' );
941
942To create a new YAML file from scratch:
943
944    # Create a new object with a single hashref document
945    my $yaml = ProjectBuilder::YAML->new( { wibble => "wobble" } );
946
947    # Add an arrayref document
948    push @$yaml, [ 'foo', 'bar', 'baz' ];
949
950    # Save both documents to a file
951    $yaml->write( 'data.yml' );
952
953Then F<data.yml> will contain:
954
955    ---
956    wibble: wobble
957    ---
958    - foo
959    - bar
960    - baz
961
962=head1 DESCRIPTION
963
964B<ProjectBuilder::YAML> is a perl class for reading and writing YAML-style files,
965written with as little code as possible, reducing load time and memory
966overhead.
967
968Most of the time it is accepted that Perl applications use a lot
969of memory and modules. The B<::Tiny> family of modules is specifically
970intended to provide an ultralight and zero-dependency alternative to
971many more-thorough standard modules.
972
973This module is primarily for reading human-written files (like simple
974config files) and generating very simple human-readable files. Note that
975I said B<human-readable> and not B<geek-readable>. The sort of files that
976your average manager or secretary should be able to look at and make
977sense of.
978
979=for stopwords normalise
980
981L<ProjectBuilder::YAML> does not generate comments, it won't necessarily preserve the
982order of your hashes, and it will normalise if reading in and writing out
983again.
984
985It only supports a very basic subset of the full YAML specification.
986
987=for stopwords embeddable
988
989Usage is targeted at files like Perl's META.yml, for which a small and
990easily-embeddable module is extremely attractive.
991
992Features will only be added if they are human readable, and can be written
993in a few lines of code. Please don't be offended if your request is
994refused. Someone has to draw the line, and for ProjectBuilder::YAML that someone
995is me.
996
997If you need something with more power move up to L<YAML> (7 megabytes of
998memory overhead) or L<YAML::XS> (6 megabytes memory overhead and requires
999a C compiler).
1000
1001To restate, L<ProjectBuilder::YAML> does B<not> preserve your comments, whitespace,
1002or the order of your YAML data. But it should round-trip from Perl
1003structure to file and back again just fine.
1004
1005=head1 METHODS
1006
1007=for Pod::Coverage HAVE_UTF8 refaddr
1008
1009=head2 new
1010
1011The constructor C<new> creates a C<ProjectBuilder::YAML> object as a blessed array
1012reference.  Any arguments provided are taken as separate documents
1013to be serialized.
1014
1015=head2 read $filename
1016
1017The C<read> constructor reads a YAML file from a file name,
1018and returns a new C<ProjectBuilder::YAML> object containing the parsed content.
1019
1020Returns the object on success or throws an error on failure.
1021
1022=head2 read_string $string;
1023
1024The C<read_string> constructor reads YAML data from a character string, and
1025returns a new C<ProjectBuilder::YAML> object containing the parsed content.  If you have
1026read the string from a file yourself, be sure that you have correctly decoded
1027it into characters first.
1028
1029Returns the object on success or throws an error on failure.
1030
1031=head2 write $filename
1032
1033The C<write> method generates the file content for the properties, and
1034writes it to disk using UTF-8 encoding to the filename specified.
1035
1036Returns true on success or throws an error on failure.
1037
1038=head2 write_string
1039
1040Generates the file content for the object and returns it as a character
1041string.  This may contain non-ASCII characters and should be encoded
1042before writing it to a file.
1043
1044Returns true on success or throws an error on failure.
1045
1046=for stopwords errstr
1047
1048=head2 errstr (DEPRECATED)
1049
1050Prior to version 1.57, some errors were fatal and others were available only
1051via the C<$ProjectBuilder::YAML::errstr> variable, which could be accessed via the
1052C<errstr()> method.
1053
1054Starting with version 1.57, all errors are fatal and throw exceptions.
1055
1056The C<$errstr> variable is still set when exceptions are thrown, but
1057C<$errstr> and the C<errstr()> method are deprecated and may be removed in a
1058future release.  The first use of C<errstr()> will issue a deprecation
1059warning.
1060
1061=head1 FUNCTIONS
1062
1063ProjectBuilder::YAML implements a number of functions to add compatibility with
1064the L<YAML> API. These should be a drop-in replacement.
1065
1066=head2 pb_Dump
1067
1068  my $string = pb_Dump(list-of-Perl-data-structures);
1069
1070Turn Perl data into YAML. This function works very much like
1071Data::Dumper::Dumper().
1072
1073It takes a list of Perl data structures and dumps them into a serialized
1074form.
1075
1076It returns a character string containing the YAML stream.  Be sure to encode
1077it as UTF-8 before serializing to a file or socket.
1078
1079The structures can be references or plain scalars.
1080
1081Dies on any error.
1082
1083=head2 pb_Load
1084
1085  my @data_structures = pb_Load(string-containing-a-YAML-stream);
1086
1087Turn YAML into Perl data. This is the opposite of Dump.
1088
1089Just like L<Storable>'s thaw() function or the eval() function in relation
1090to L<Data::Dumper>.
1091
1092It parses a character string containing a valid YAML stream into a list of
1093Perl data structures representing the individual YAML documents.  Be sure to
1094decode the character string  correctly if the string came from a file or
1095socket.
1096
1097  my $last_data_structure = pb_Load(string-containing-a-YAML-stream);
1098
1099For consistency with YAML.pm, when Load is called in scalar context, it
1100returns the data structure corresponding to the last of the YAML documents
1101found in the input stream.
1102
1103Dies on any error.
1104
1105=head2 freeze() and thaw()
1106
1107Aliases to pb_Dump() and pb_Load() for L<Storable> fans. This will also allow
1108ProjectBuilder::YAML to be plugged directly into modules like POE.pm, that use the
1109freeze/thaw API for internal serialization.
1110
1111=head2 pb_DumpFile(filepath, list)
1112
1113Writes the YAML stream to a file with UTF-8 encoding instead of just
1114returning a string.
1115
1116Dies on any error.
1117
1118=head2 LoadFile(filepath)
1119
1120Reads the YAML stream from a UTF-8 encoded file instead of a string.
1121
1122Dies on any error.
1123
1124=head1 YAML TINY SPECIFICATION
1125
1126This section of the documentation provides a specification for "YAML Tiny",
1127a subset of the YAML specification.
1128
1129It is based on and described comparatively to the YAML 1.1 Working Draft
11302004-12-28 specification, located at L<http://yaml.org/spec/current.html>.
1131
1132Terminology and chapter numbers are based on that specification.
1133
1134=head2 1. Introduction and Goals
1135
1136The purpose of the YAML Tiny specification is to describe a useful subset
1137of the YAML specification that can be used for typical document-oriented
1138use cases such as configuration files and simple data structure dumps.
1139
1140=for stopwords extensibility
1141
1142Many specification elements that add flexibility or extensibility are
1143intentionally removed, as is support for complex data structures, class
1144and object-orientation.
1145
1146In general, the YAML Tiny language targets only those data structures
1147available in JSON, with the additional limitation that only simple keys
1148are supported.
1149
1150As a result, all possible YAML Tiny documents should be able to be
1151transformed into an equivalent JSON document, although the reverse is
1152not necessarily true (but will be true in simple cases).
1153
1154=for stopwords PCRE
1155
1156As a result of these simplifications the YAML Tiny specification should
1157be implementable in a (relatively) small amount of code in any language
1158that supports Perl Compatible Regular Expressions (PCRE).
1159
1160=head2 2. Introduction
1161
1162YAML Tiny supports three data structures. These are scalars (in a variety
1163of forms), block-form sequences and block-form mappings. Flow-style
1164sequences and mappings are not supported, with some minor exceptions
1165detailed later.
1166
1167The use of three dashes "---" to indicate the start of a new document is
1168supported, and multiple documents per file/stream is allowed.
1169
1170Both line and inline comments are supported.
1171
1172Scalars are supported via the plain style, single quote and double quote,
1173as well as literal-style and folded-style multi-line scalars.
1174
1175The use of explicit tags is not supported.
1176
1177The use of "null" type scalars is supported via the ~ character.
1178
1179The use of "bool" type scalars is not supported.
1180
1181=for stopwords serializer
1182
1183However, serializer implementations should take care to explicitly escape
1184strings that match a "bool" keyword in the following set to prevent other
1185implementations that do support "bool" accidentally reading a string as a
1186boolean
1187
1188  y|Y|yes|Yes|YES|n|N|no|No|NO
1189  |true|True|TRUE|false|False|FALSE
1190  |on|On|ON|off|Off|OFF
1191
1192The use of anchors and aliases is not supported.
1193
1194The use of directives is supported only for the %YAML directive.
1195
1196=head2 3. Processing YAML Tiny Information
1197
1198B<Processes>
1199
1200=for stopwords deserialization
1201
1202The YAML specification dictates three-phase serialization and three-phase
1203deserialization.
1204
1205The YAML Tiny specification does not mandate any particular methodology
1206or mechanism for parsing.
1207
1208Any compliant parser is only required to parse a single document at a
1209time. The ability to support streaming documents is optional and most
1210likely non-typical.
1211
1212=for stopwords acyclic
1213
1214Because anchors and aliases are not supported, the resulting representation
1215graph is thus directed but (unlike the main YAML specification) B<acyclic>.
1216
1217Circular references/pointers are not possible, and any YAML Tiny serializer
1218detecting a circular reference should error with an appropriate message.
1219
1220B<Presentation Stream>
1221
1222=for stopwords unicode
1223
1224YAML Tiny reads and write UTF-8 encoded files.  Operations on strings expect
1225or produce Unicode characters not UTF-8 encoded bytes.
1226
1227B<Loading Failure Points>
1228
1229=for stopwords modality
1230
1231=for stopwords parsers
1232
1233YAML Tiny parsers and emitters are not expected to recover from, or
1234adapt to, errors. The specific error modality of any implementation is
1235not dictated (return codes, exceptions, etc.) but is expected to be
1236consistent.
1237
1238=head2 4. Syntax
1239
1240B<Character Set>
1241
1242YAML Tiny streams are processed in memory as Unicode characters and
1243read/written with UTF-8 encoding.
1244
1245The escaping and unescaping of the 8-bit YAML escapes is required.
1246
1247The escaping and unescaping of 16-bit and 32-bit YAML escapes is not
1248required.
1249
1250B<Indicator Characters>
1251
1252Support for the "~" null/undefined indicator is required.
1253
1254Implementations may represent this as appropriate for the underlying
1255language.
1256
1257Support for the "-" block sequence indicator is required.
1258
1259Support for the "?" mapping key indicator is B<not> required.
1260
1261Support for the ":" mapping value indicator is required.
1262
1263Support for the "," flow collection indicator is B<not> required.
1264
1265Support for the "[" flow sequence indicator is B<not> required, with
1266one exception (detailed below).
1267
1268Support for the "]" flow sequence indicator is B<not> required, with
1269one exception (detailed below).
1270
1271Support for the "{" flow mapping indicator is B<not> required, with
1272one exception (detailed below).
1273
1274Support for the "}" flow mapping indicator is B<not> required, with
1275one exception (detailed below).
1276
1277Support for the "#" comment indicator is required.
1278
1279Support for the "&" anchor indicator is B<not> required.
1280
1281Support for the "*" alias indicator is B<not> required.
1282
1283Support for the "!" tag indicator is B<not> required.
1284
1285Support for the "|" literal block indicator is required.
1286
1287Support for the ">" folded block indicator is required.
1288
1289Support for the "'" single quote indicator is required.
1290
1291Support for the """ double quote indicator is required.
1292
1293Support for the "%" directive indicator is required, but only
1294for the special case of a %YAML version directive before the
1295"---" document header, or on the same line as the document header.
1296
1297For example:
1298
1299  %YAML 1.1
1300  ---
1301  - A sequence with a single element
1302
1303Special Exception:
1304
1305To provide the ability to support empty sequences
1306and mappings, support for the constructs [] (empty sequence) and {}
1307(empty mapping) are required.
1308
1309For example,
1310
1311  %YAML 1.1
1312  # A document consisting of only an empty mapping
1313  --- {}
1314  # A document consisting of only an empty sequence
1315  --- []
1316  # A document consisting of an empty mapping within a sequence
1317  - foo
1318  - {}
1319  - bar
1320
1321B<Syntax Primitives>
1322
1323Other than the empty sequence and mapping cases described above, YAML Tiny
1324supports only the indentation-based block-style group of contexts.
1325
1326All five scalar contexts are supported.
1327
1328Indentation spaces work as per the YAML specification in all cases.
1329
1330Comments work as per the YAML specification in all simple cases.
1331Support for indented multi-line comments is B<not> required.
1332
1333Separation spaces work as per the YAML specification in all cases.
1334
1335B<YAML Tiny Character Stream>
1336
1337The only directive supported by the YAML Tiny specification is the
1338%YAML language/version identifier. Although detected, this directive
1339will have no control over the parsing itself.
1340
1341=for stopwords recognise
1342
1343The parser must recognise both the YAML 1.0 and YAML 1.1+ formatting
1344of this directive (as well as the commented form, although no explicit
1345code should be needed to deal with this case, being a comment anyway)
1346
1347That is, all of the following should be supported.
1348
1349  --- #YAML:1.0
1350  - foo
1351
1352  %YAML:1.0
1353  ---
1354  - foo
1355
1356  % YAML 1.1
1357  ---
1358  - foo
1359
1360Support for the %TAG directive is B<not> required.
1361
1362Support for additional directives is B<not> required.
1363
1364Support for the document boundary marker "---" is required.
1365
1366Support for the document boundary market "..." is B<not> required.
1367
1368If necessary, a document boundary should simply by indicated with a
1369"---" marker, with not preceding "..." marker.
1370
1371Support for empty streams (containing no documents) is required.
1372
1373Support for implicit document starts is required.
1374
1375That is, the following must be equivalent.
1376
1377 # Full form
1378 %YAML 1.1
1379 ---
1380 foo: bar
1381
1382 # Implicit form
1383 foo: bar
1384
1385B<Nodes>
1386
1387Support for nodes optional anchor and tag properties is B<not> required.
1388
1389Support for node anchors is B<not> required.
1390
1391Support for node tags is B<not> required.
1392
1393Support for alias nodes is B<not> required.
1394
1395Support for flow nodes is B<not> required.
1396
1397Support for block nodes is required.
1398
1399B<Scalar Styles>
1400
1401Support for all five scalar styles is required as per the YAML
1402specification, although support for quoted scalars spanning more
1403than one line is B<not> required.
1404
1405Support for multi-line scalar documents starting on the header
1406is not required.
1407
1408Support for the chomping indicators on multi-line scalar styles
1409is required.
1410
1411B<Collection Styles>
1412
1413Support for block-style sequences is required.
1414
1415Support for flow-style sequences is B<not> required.
1416
1417Support for block-style mappings is required.
1418
1419Support for flow-style mappings is B<not> required.
1420
1421Both sequences and mappings should be able to be arbitrarily
1422nested.
1423
1424Support for plain-style mapping keys is required.
1425
1426Support for quoted keys in mappings is B<not> required.
1427
1428Support for "?"-indicated explicit keys is B<not> required.
1429
1430=for stopwords endeth
1431
1432Here endeth the specification.
1433
1434=head2 Additional Perl-Specific Notes
1435
1436For some Perl applications, it's important to know if you really have a
1437number and not a string.
1438
1439That is, in some contexts is important that 3 the number is distinctive
1440from "3" the string.
1441
1442Because even Perl itself is not trivially able to understand the difference
1443(certainly without XS-based modules) Perl implementations of the YAML Tiny
1444specification are not required to retain the distinctiveness of 3 vs "3".
1445
1446=head1 SUPPORT
1447
1448Bugs should be reported via the CPAN bug tracker at
1449
1450L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=YAML-Tiny>
1451
1452=begin html
1453
1454For other issues, or commercial enhancement or support, please contact
1455<a href="http://ali.as/">Adam Kennedy</a> directly.
1456
1457=end html
1458
1459=head1 AUTHOR
1460
1461Adam Kennedy E<lt>adamk@cpan.orgE<gt>
1462
1463=head1 SEE ALSO
1464
1465=over 4
1466
1467=item * L<YAML>
1468
1469=item * L<YAML::Syck>
1470
1471=item * L<Config::Tiny>
1472
1473=item * L<CSS::Tiny>
1474
1475=item * L<http://use.perl.org/use.perl.org/_Alias/journal/29427.html>
1476
1477=item * L<http://ali.as/>
1478
1479=back
1480
1481=head1 COPYRIGHT
1482
1483Copyright 2006 - 2013 Adam Kennedy.
1484
1485This program is free software; you can redistribute
1486it and/or modify it under the same terms as Perl itself.
1487
1488The full text of the license can be found in the
1489LICENSE file included with this module.
1490
1491=cut
Note: See TracBrowser for help on using the repository browser.