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

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

Fix YAML module usage in setupv

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