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