Dogcows Code - chaz/p5-Catalyst-Plugin-Sitemap/blob - t/000-report-versions.t

   1 #!perl
   2 use warnings;
   3 use strict;
   4 use Test::More 0.94;
   5
   6 # Include a cut-down version of YAML::Tiny so we don't introduce unnecessary
   7 # dependencies ourselves.
   8
   9 package Local::YAML::Tiny;
  10
  11 use strict;
  12 use Carp 'croak';
  13
  14 # UTF Support?
  15 sub HAVE_UTF8 () { $] >= 5.007003 }
  16 BEGIN {
  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
  32 my %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
  43 sub new {
  44     my $class = shift;
  45     bless [ @_ ], $class;
  46 }
  47
  48 # Create an object from a file
  49 sub 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
  73 sub 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
 153 sub _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
 212 sub _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
 288 sub _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
 348 sub _error {
 349     $YAML::Tiny::errstr = $_[1];
 350     undef;
 351 }
 352
 353 # Retrieve error
 354 sub errstr {
 355     $YAML::Tiny::errstr;
 356 }
 357
 358
 359
 360 #####################################################################
 361 # Use Scalar::Util if possible, otherwise emulate it
 362
 363 BEGIN {
 364     eval {
 365         require Scalar::Util;
 366     };
 367     if ( $@ ) {
 368         # Failed to load Scalar::Util
 369         eval <<'END_PERL';
 370 sub 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 }
 382 END_PERL
 383     } else {
 384         Scalar::Util->import('refaddr');
 385     }
 386 }
 387
 388
 389 #####################################################################
 390 # main test
 391 #####################################################################
 392
 393 package main;
 394
 395 BEGIN {
 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     );
 419
 420     my $Test = Test::Builder->new;
 421
 422     $Test->plan(skip_all => "META.yml could not be found")
 423         unless -f 'META.yml' and -r _;
 424
 425     my $meta = (Local::YAML::Tiny->read('META.yml'))->[0];
 426     my %requires;
 427     for my $require_key (grep { /requires/ } keys %$meta) {
 428         my %h = %{ $meta->{$require_key} };
 429         $requires{$_}++ for keys %h;
 430     }
 431     delete $requires{perl};
 432
 433     diag("Testing with Perl $], $^X");
 434     for my $module (sort keys %requires) {
 435         if ($skip{$module}) {
 436             note "$module doesn't want to be loaded directly, skipping";
 437             next;
 438         }
 439         local $SIG{__WARN__} = sub { note "$module: $_[0]" };
 440         use_ok $module or BAIL_OUT("can't load $module");
 441         my $version = $module->VERSION;
 442         $version = 'undefined' unless defined $version;
 443         diag("    $module version is $version");
 444     }
 445     done_testing;
 446 }