1#!perl
2use warnings;
3use strict;
4use Test::More 0.94;
5
6# Include a cut-down version of YAML::Tiny so we don't introduce unnecessary
7# dependencies ourselves.
8
9package Local::YAML::Tiny;
10
11use strict;
12use Carp 'croak';
13
14# UTF Support?
15sub HAVE_UTF8 () { $] >= 5.007003 }
16BEGIN {
17    if ( HAVE_UTF8 ) {
18        # The string eval helps hide this from Test::MinimumVersion
19        eval "require utf8;";
20        die "Failed to load UTF-8 support" if $@;
21    }
22
23    # Class structure
24    require 5.004;
25    $YAML::Tiny::VERSION   = '1.40';
26
27    # Error storage
28    $YAML::Tiny::errstr    = '';
29}
30
31# Printable characters for escapes
32my %UNESCAPES = (
33    z => "\x00", a => "\x07", t    => "\x09",
34    n => "\x0a", v => "\x0b", f    => "\x0c",
35    r => "\x0d", e => "\x1b", '\\' => '\\',
36);
37
38
39#####################################################################
40# Implementation
41
42# Create an empty YAML::Tiny object
43sub new {
44    my $class = shift;
45    bless [ @_ ], $class;
46}
47
48# Create an object from a file
49sub read {
50    my $class = ref $_[0] ? ref shift : shift;
51
52    # Check the file
53    my $file = shift or return $class->_error( 'You did not specify a file name' );
54    return $class->_error( "File '$file' does not exist" )              unless -e $file;
55    return $class->_error( "'$file' is a directory, not a file" )       unless -f _;
56    return $class->_error( "Insufficient permissions to read '$file'" ) unless -r _;
57
58    # Slurp in the file
59    local $/ = undef;
60    local *CFG;
61    unless ( open(CFG, $file) ) {
62        return $class->_error("Failed to open file '$file': $!");
63    }
64    my $contents = <CFG>;
65    unless ( close(CFG) ) {
66        return $class->_error("Failed to close file '$file': $!");
67    }
68
69    $class->read_string( $contents );
70}
71
72# Create an object from a string
73sub read_string {
74    my $class  = ref $_[0] ? ref shift : shift;
75    my $self   = bless [], $class;
76    my $string = $_[0];
77    unless ( defined $string ) {
78        return $self->_error("Did not provide a string to load");
79    }
80
81    # Byte order marks
82    # NOTE: Keeping this here to educate maintainers
83    # my %BOM = (
84    #     "\357\273\277" => 'UTF-8',
85    #     "\376\377"     => 'UTF-16BE',
86    #     "\377\376"     => 'UTF-16LE',
87    #     "\377\376\0\0" => 'UTF-32LE'
88    #     "\0\0\376\377" => 'UTF-32BE',
89    # );
90    if ( $string =~ /^(?:\376\377|\377\376|\377\376\0\0|\0\0\376\377)/ ) {
91        return $self->_error("Stream has a non UTF-8 BOM");
92    } else {
93        # Strip UTF-8 bom if found, we'll just ignore it
94        $string =~ s/^\357\273\277//;
95    }
96
97    # Try to decode as utf8
98    utf8::decode($string) if HAVE_UTF8;
99
100    # Check for some special cases
101    return $self unless length $string;
102    unless ( $string =~ /[\012\015]+\z/ ) {
103        return $self->_error("Stream does not end with newline character");
104    }
105
106    # Split the file into lines
107    my @lines = grep { ! /^\s*(?:\#.*)?\z/ }
108                split /(?:\015{1,2}\012|\015|\012)/, $string;
109
110    # Strip the initial YAML header
111    @lines and $lines[0] =~ /^\%YAML[: ][\d\.]+.*\z/ and shift @lines;
112
113    # A nibbling parser
114    while ( @lines ) {
115        # Do we have a document header?
116        if ( $lines[0] =~ /^---\s*(?:(.+)\s*)?\z/ ) {
117            # Handle scalar documents
118            shift @lines;
119            if ( defined $1 and $1 !~ /^(?:\#.+|\%YAML[: ][\d\.]+)\z/ ) {
120                push @$self, $self->_read_scalar( "$1", [ undef ], \@lines );
121                next;
122            }
123        }
124
125        if ( ! @lines or $lines[0] =~ /^(?:---|\.\.\.)/ ) {
126            # A naked document
127            push @$self, undef;
128            while ( @lines and $lines[0] !~ /^---/ ) {
129                shift @lines;
130            }
131
132        } elsif ( $lines[0] =~ /^\s*\-/ ) {
133            # An array at the root
134            my $document = [ ];
135            push @$self, $document;
136            $self->_read_array( $document, [ 0 ], \@lines );
137
138        } elsif ( $lines[0] =~ /^(\s*)\S/ ) {
139            # A hash at the root
140            my $document = { };
141            push @$self, $document;
142            $self->_read_hash( $document, [ length($1) ], \@lines );
143
144        } else {
145            croak("YAML::Tiny failed to classify the line '$lines[0]'");
146        }
147    }
148
149    $self;
150}
151
152# Deparse a scalar string to the actual scalar
153sub _read_scalar {
154    my ($self, $string, $indent, $lines) = @_;
155
156    # Trim trailing whitespace
157    $string =~ s/\s*\z//;
158
159    # Explitic null/undef
160    return undef if $string eq '~';
161
162    # Quotes
163    if ( $string =~ /^\'(.*?)\'\z/ ) {
164        return '' unless defined $1;
165        $string = $1;
166        $string =~ s/\'\'/\'/g;
167        return $string;
168    }
169    if ( $string =~ /^\"((?:\\.|[^\"])*)\"\z/ ) {
170        # Reusing the variable is a little ugly,
171        # but avoids a new variable and a string copy.
172        $string = $1;
173        $string =~ s/\\"/"/g;
174        $string =~ s/\\([never\\fartz]|x([0-9a-fA-F]{2}))/(length($1)>1)?pack("H2",$2):$UNESCAPES{$1}/gex;
175        return $string;
176    }
177
178    # Special cases
179    if ( $string =~ /^[\'\"!&]/ ) {
180        croak("YAML::Tiny does not support a feature in line '$lines->[0]'");
181    }
182    return {} if $string eq '{}';
183    return [] if $string eq '[]';
184
185    # Regular unquoted string
186    return $string unless $string =~ /^[>|]/;
187
188    # Error
189    croak("YAML::Tiny failed to find multi-line scalar content") unless @$lines;
190
191    # Check the indent depth
192    $lines->[0]   =~ /^(\s*)/;
193    $indent->[-1] = length("$1");
194    if ( defined $indent->[-2] and $indent->[-1] <= $indent->[-2] ) {
195        croak("YAML::Tiny found bad indenting in line '$lines->[0]'");
196    }
197
198    # Pull the lines
199    my @multiline = ();
200    while ( @$lines ) {
201        $lines->[0] =~ /^(\s*)/;
202        last unless length($1) >= $indent->[-1];
203        push @multiline, substr(shift(@$lines), length($1));
204    }
205
206    my $j = (substr($string, 0, 1) eq '>') ? ' ' : "\n";
207    my $t = (substr($string, 1, 1) eq '-') ? ''  : "\n";
208    return join( $j, @multiline ) . $t;
209}
210
211# Parse an array
212sub _read_array {
213    my ($self, $array, $indent, $lines) = @_;
214
215    while ( @$lines ) {
216        # Check for a new document
217        if ( $lines->[0] =~ /^(?:---|\.\.\.)/ ) {
218            while ( @$lines and $lines->[0] !~ /^---/ ) {
219                shift @$lines;
220            }
221            return 1;
222        }
223
224        # Check the indent level
225        $lines->[0] =~ /^(\s*)/;
226        if ( length($1) < $indent->[-1] ) {
227            return 1;
228        } elsif ( length($1) > $indent->[-1] ) {
229            croak("YAML::Tiny found bad indenting in line '$lines->[0]'");
230        }
231
232        if ( $lines->[0] =~ /^(\s*\-\s+)[^\'\"]\S*\s*:(?:\s+|$)/ ) {
233            # Inline nested hash
234            my $indent2 = length("$1");
235            $lines->[0] =~ s/-/ /;
236            push @$array, { };
237            $self->_read_hash( $array->[-1], [ @$indent, $indent2 ], $lines );
238
239        } elsif ( $lines->[0] =~ /^\s*\-(\s*)(.+?)\s*\z/ ) {
240            # Array entry with a value
241            shift @$lines;
242            push @$array, $self->_read_scalar( "$2", [ @$indent, undef ], $lines );
243
244        } elsif ( $lines->[0] =~ /^\s*\-\s*\z/ ) {
245            shift @$lines;
246            unless ( @$lines ) {
247                push @$array, undef;
248                return 1;
249            }
250            if ( $lines->[0] =~ /^(\s*)\-/ ) {
251                my $indent2 = length("$1");
252                if ( $indent->[-1] == $indent2 ) {
253                    # Null array entry
254                    push @$array, undef;
255                } else {
256                    # Naked indenter
257                    push @$array, [ ];
258                    $self->_read_array( $array->[-1], [ @$indent, $indent2 ], $lines );
259                }
260
261            } elsif ( $lines->[0] =~ /^(\s*)\S/ ) {
262                push @$array, { };
263                $self->_read_hash( $array->[-1], [ @$indent, length("$1") ], $lines );
264
265            } else {
266                croak("YAML::Tiny failed to classify line '$lines->[0]'");
267            }
268
269        } elsif ( defined $indent->[-2] and $indent->[-1] == $indent->[-2] ) {
270            # This is probably a structure like the following...
271            # ---
272            # foo:
273            # - list
274            # bar: value
275            #
276            # ... so lets return and let the hash parser handle it
277            return 1;
278
279        } else {
280            croak("YAML::Tiny failed to classify line '$lines->[0]'");
281        }
282    }
283
284    return 1;
285}
286
287# Parse an array
288sub _read_hash {
289    my ($self, $hash, $indent, $lines) = @_;
290
291    while ( @$lines ) {
292        # Check for a new document
293        if ( $lines->[0] =~ /^(?:---|\.\.\.)/ ) {
294            while ( @$lines and $lines->[0] !~ /^---/ ) {
295                shift @$lines;
296            }
297            return 1;
298        }
299
300        # Check the indent level
301        $lines->[0] =~ /^(\s*)/;
302        if ( length($1) < $indent->[-1] ) {
303            return 1;
304        } elsif ( length($1) > $indent->[-1] ) {
305            croak("YAML::Tiny found bad indenting in line '$lines->[0]'");
306        }
307
308        # Get the key
309        unless ( $lines->[0] =~ s/^\s*([^\'\" ][^\n]*?)\s*:(\s+|$)// ) {
310            if ( $lines->[0] =~ /^\s*[?\'\"]/ ) {
311                croak("YAML::Tiny does not support a feature in line '$lines->[0]'");
312            }
313            croak("YAML::Tiny failed to classify line '$lines->[0]'");
314        }
315        my $key = $1;
316
317        # Do we have a value?
318        if ( length $lines->[0] ) {
319            # Yes
320            $hash->{$key} = $self->_read_scalar( shift(@$lines), [ @$indent, undef ], $lines );
321        } else {
322            # An indent
323            shift @$lines;
324            unless ( @$lines ) {
325                $hash->{$key} = undef;
326                return 1;
327            }
328            if ( $lines->[0] =~ /^(\s*)-/ ) {
329                $hash->{$key} = [];
330                $self->_read_array( $hash->{$key}, [ @$indent, length($1) ], $lines );
331            } elsif ( $lines->[0] =~ /^(\s*)./ ) {
332                my $indent2 = length("$1");
333                if ( $indent->[-1] >= $indent2 ) {
334                    # Null hash entry
335                    $hash->{$key} = undef;
336                } else {
337                    $hash->{$key} = {};
338                    $self->_read_hash( $hash->{$key}, [ @$indent, length($1) ], $lines );
339                }
340            }
341        }
342    }
343
344    return 1;
345}
346
347# Set error
348sub _error {
349    $YAML::Tiny::errstr = $_[1];
350    undef;
351}
352
353# Retrieve error
354sub errstr {
355    $YAML::Tiny::errstr;
356}
357
358
359
360#####################################################################
361# Use Scalar::Util if possible, otherwise emulate it
362
363BEGIN {
364    eval {
365        require Scalar::Util;
366    };
367    if ( $@ ) {
368        # Failed to load Scalar::Util
369        eval <<'END_PERL';
370sub refaddr {
371    my $pkg = ref($_[0]) or return undef;
372    if (!!UNIVERSAL::can($_[0], 'can')) {
373        bless $_[0], 'Scalar::Util::Fake';
374    } else {
375        $pkg = undef;
376    }
377    "$_[0]" =~ /0x(\w+)/;
378    my $i = do { local $^W; hex $1 };
379    bless $_[0], $pkg if defined $pkg;
380    $i;
381}
382END_PERL
383    } else {
384        Scalar::Util->import('refaddr');
385    }
386}
387
388
389#####################################################################
390# main test
391#####################################################################
392
393package main;
394
395BEGIN {
396
397    # Skip modules that either don't want to be loaded directly, such as
398    # Module::Install, or that mess with the test count, such as the Test::*
399    # modules listed here.
400    #
401    # Moose::Role conflicts if Moose is loaded as well, but Moose::Role is in
402    # the Moose distribution and it's certain that someone who uses
403    # Moose::Role also uses Moose somewhere, so if we disallow Moose::Role,
404    # we'll still get the relevant version number.
405
406    my %skip = map { $_ => 1 } qw(
407      App::FatPacker
408      Class::Accessor::Classy
409      Devel::Cover
410      Module::Install
411      Moose::Role
412      POE::Loop::Tk
413      Template::Test
414      Test::Kwalitee
415      Test::Pod::Coverage
416      Test::Portability::Files
417      Test::YAML::Meta
418      open
419    );
420
421    my $Test = Test::Builder->new;
422
423    $Test->plan(skip_all => "META.yml could not be found")
424        unless -f 'META.yml' and -r _;
425
426    my $meta = (Local::YAML::Tiny->read('META.yml'))->[0];
427    my %requires;
428    for my $require_key (grep { /requires/ } keys %$meta) {
429        my %h = %{ $meta->{$require_key} };
430        $requires{$_}++ for keys %h;
431    }
432    delete $requires{perl};
433
434    diag("Testing with Perl $], $^X");
435    for my $module (sort keys %requires) {
436        if ($skip{$module}) {
437            note "$module doesn't want to be loaded directly, skipping";
438            next;
439        }
440        local $SIG{__WARN__} = sub { note "$module: $_[0]" };
441        require_ok $module or BAIL_OUT("can't load $module");
442        my $version = $module->VERSION;
443        $version = 'undefined' unless defined $version;
444        diag("    $module version is $version");
445    }
446    done_testing;
447}
448