1#line 1 2use 5.008001; # sane UTF-8 support 3use strict; 4use warnings; 5package YAML::Tiny; # git description: v1.69-8-g2c1e266 6# XXX-INGY is 5.8.1 too old/broken for utf8? 7# XXX-XDG Lancaster consensus was that it was sufficient until 8# proven otherwise 9 10our $VERSION = '1.70'; 11 12##################################################################### 13# The YAML::Tiny API. 14# 15# These are the currently documented API functions/methods and 16# exports: 17 18use Exporter; 19our @ISA = qw{ Exporter }; 20our @EXPORT = qw{ Load Dump }; 21our @EXPORT_OK = qw{ LoadFile DumpFile freeze thaw }; 22 23### 24# Functional/Export API: 25 26sub Dump { 27 return YAML::Tiny->new(@_)->_dump_string; 28} 29 30# XXX-INGY Returning last document seems a bad behavior. 31# XXX-XDG I think first would seem more natural, but I don't know 32# that it's worth changing now 33sub Load { 34 my $self = YAML::Tiny->_load_string(@_); 35 if ( wantarray ) { 36 return @$self; 37 } else { 38 # To match YAML.pm, return the last document 39 return $self->[-1]; 40 } 41} 42 43# XXX-INGY Do we really need freeze and thaw? 44# XXX-XDG I don't think so. I'd support deprecating them. 45BEGIN { 46 *freeze = \&Dump; 47 *thaw = \&Load; 48} 49 50sub DumpFile { 51 my $file = shift; 52 return YAML::Tiny->new(@_)->_dump_file($file); 53} 54 55sub LoadFile { 56 my $file = shift; 57 my $self = YAML::Tiny->_load_file($file); 58 if ( wantarray ) { 59 return @$self; 60 } else { 61 # Return only the last document to match YAML.pm, 62 return $self->[-1]; 63 } 64} 65 66 67### 68# Object Oriented API: 69 70# Create an empty YAML::Tiny object 71# XXX-INGY Why do we use ARRAY object? 72# NOTE: I get it now, but I think it's confusing and not needed. 73# Will change it on a branch later, for review. 74# 75# XXX-XDG I don't support changing it yet. It's a very well-documented 76# "API" of YAML::Tiny. I'd support deprecating it, but Adam suggested 77# we not change it until YAML.pm's own OO API is established so that 78# users only have one API change to digest, not two 79sub new { 80 my $class = shift; 81 bless [ @_ ], $class; 82} 83 84# XXX-INGY It probably doesn't matter, and it's probably too late to 85# change, but 'read/write' are the wrong names. Read and Write 86# are actions that take data from storage to memory 87# characters/strings. These take the data to/from storage to native 88# Perl objects, which the terms dump and load are meant. As long as 89# this is a legacy quirk to YAML::Tiny it's ok, but I'd prefer not 90# to add new {read,write}_* methods to this API. 91 92sub read_string { 93 my $self = shift; 94 $self->_load_string(@_); 95} 96 97sub write_string { 98 my $self = shift; 99 $self->_dump_string(@_); 100} 101 102sub read { 103 my $self = shift; 104 $self->_load_file(@_); 105} 106 107sub write { 108 my $self = shift; 109 $self->_dump_file(@_); 110} 111 112 113 114 115##################################################################### 116# Constants 117 118# Printed form of the unprintable characters in the lowest range 119# of ASCII characters, listed by ASCII ordinal position. 120my @UNPRINTABLE = qw( 121 0 x01 x02 x03 x04 x05 x06 a 122 b t n v f r x0E x0F 123 x10 x11 x12 x13 x14 x15 x16 x17 124 x18 x19 x1A e x1C x1D x1E x1F 125); 126 127# Printable characters for escapes 128my %UNESCAPES = ( 129 0 => "\x00", z => "\x00", N => "\x85", 130 a => "\x07", b => "\x08", t => "\x09", 131 n => "\x0a", v => "\x0b", f => "\x0c", 132 r => "\x0d", e => "\x1b", '\\' => '\\', 133); 134 135# XXX-INGY 136# I(ngy) need to decide if these values should be quoted in 137# YAML::Tiny or not. Probably yes. 138 139# These 3 values have special meaning when unquoted and using the 140# default YAML schema. They need quotes if they are strings. 141my %QUOTE = map { $_ => 1 } qw{ 142 null true false 143}; 144 145# The commented out form is simpler, but overloaded the Perl regex 146# engine due to recursion and backtracking problems on strings 147# larger than 32,000ish characters. Keep it for reference purposes. 148# qr/\"((?:\\.|[^\"])*)\"/ 149my $re_capture_double_quoted = qr/\"([^\\"]*(?:\\.[^\\"]*)*)\"/; 150my $re_capture_single_quoted = qr/\'([^\']*(?:\'\'[^\']*)*)\'/; 151# unquoted re gets trailing space that needs to be stripped 152my $re_capture_unquoted_key = qr/([^:]+(?::+\S(?:[^:]*|.*?(?=:)))*)(?=\s*\:(?:\s+|$))/; 153my $re_trailing_comment = qr/(?:\s+\#.*)?/; 154my $re_key_value_separator = qr/\s*:(?:\s+(?:\#.*)?|$)/; 155 156 157 158 159 160##################################################################### 161# YAML::Tiny Implementation. 162# 163# These are the private methods that do all the work. They may change 164# at any time. 165 166 167### 168# Loader functions: 169 170# Create an object from a file 171sub _load_file { 172 my $class = ref $_[0] ? ref shift : shift; 173 174 # Check the file 175 my $file = shift or $class->_error( 'You did not specify a file name' ); 176 $class->_error( "File '$file' does not exist" ) 177 unless -e $file; 178 $class->_error( "'$file' is a directory, not a file" ) 179 unless -f _; 180 $class->_error( "Insufficient permissions to read '$file'" ) 181 unless -r _; 182 183 # Open unbuffered with strict UTF-8 decoding and no translation layers 184 open( my $fh, "<:unix:encoding(UTF-8)", $file ); 185 unless ( $fh ) { 186 $class->_error("Failed to open file '$file': $!"); 187 } 188 189 # flock if available (or warn if not possible for OS-specific reasons) 190 if ( _can_flock() ) { 191 flock( $fh, Fcntl::LOCK_SH() ) 192 or warn "Couldn't lock '$file' for reading: $!"; 193 } 194 195 # slurp the contents 196 my $contents = eval { 197 use warnings FATAL => 'utf8'; 198 local $/; 199 <$fh> 200 }; 201 if ( my $err = $@ ) { 202 $class->_error("Error reading from file '$file': $err"); 203 } 204 205 # close the file (release the lock) 206 unless ( close $fh ) { 207 $class->_error("Failed to close file '$file': $!"); 208 } 209 210 $class->_load_string( $contents ); 211} 212 213# Create an object from a string 214sub _load_string { 215 my $class = ref $_[0] ? ref shift : shift; 216 my $self = bless [], $class; 217 my $string = $_[0]; 218 eval { 219 unless ( defined $string ) { 220 die \"Did not provide a string to load"; 221 } 222 223 # Check if Perl has it marked as characters, but it's internally 224 # inconsistent. E.g. maybe latin1 got read on a :utf8 layer 225 if ( utf8::is_utf8($string) && ! utf8::valid($string) ) { 226 die \<<'...'; 227Read an invalid UTF-8 string (maybe mixed UTF-8 and 8-bit character set). 228Did you decode with lax ":utf8" instead of strict ":encoding(UTF-8)"? 229... 230 } 231 232 # Ensure Unicode character semantics, even for 0x80-0xff 233 utf8::upgrade($string); 234 235 # Check for and strip any leading UTF-8 BOM 236 $string =~ s/^\x{FEFF}//; 237 238 # Check for some special cases 239 return $self unless length $string; 240 241 # Split the file into lines 242 my @lines = grep { ! /^\s*(?:\#.*)?\z/ } 243 split /(?:\015{1,2}\012|\015|\012)/, $string; 244 245 # Strip the initial YAML header 246 @lines and $lines[0] =~ /^\%YAML[: ][\d\.]+.*\z/ and shift @lines; 247 248 # A nibbling parser 249 my $in_document = 0; 250 while ( @lines ) { 251 # Do we have a document header? 252 if ( $lines[0] =~ /^---\s*(?:(.+)\s*)?\z/ ) { 253 # Handle scalar documents 254 shift @lines; 255 if ( defined $1 and $1 !~ /^(?:\#.+|\%YAML[: ][\d\.]+)\z/ ) { 256 push @$self, 257 $self->_load_scalar( "$1", [ undef ], \@lines ); 258 next; 259 } 260 $in_document = 1; 261 } 262 263 if ( ! @lines or $lines[0] =~ /^(?:---|\.\.\.)/ ) { 264 # A naked document 265 push @$self, undef; 266 while ( @lines and $lines[0] !~ /^---/ ) { 267 shift @lines; 268 } 269 $in_document = 0; 270 271 # XXX The final '-+$' is to look for -- which ends up being an 272 # error later. 273 } elsif ( ! $in_document && @$self ) { 274 # only the first document can be explicit 275 die \"YAML::Tiny failed to classify the line '$lines[0]'"; 276 } elsif ( $lines[0] =~ /^\s*\-(?:\s|$|-+$)/ ) { 277 # An array at the root 278 my $document = [ ]; 279 push @$self, $document; 280 $self->_load_array( $document, [ 0 ], \@lines ); 281 282 } elsif ( $lines[0] =~ /^(\s*)\S/ ) { 283 # A hash at the root 284 my $document = { }; 285 push @$self, $document; 286 $self->_load_hash( $document, [ length($1) ], \@lines ); 287 288 } else { 289 # Shouldn't get here. @lines have whitespace-only lines 290 # stripped, and previous match is a line with any 291 # non-whitespace. So this clause should only be reachable via 292 # a perlbug where \s is not symmetric with \S 293 294 # uncoverable statement 295 die \"YAML::Tiny failed to classify the line '$lines[0]'"; 296 } 297 } 298 }; 299 my $err = $@; 300 if ( ref $err eq 'SCALAR' ) { 301 $self->_error(${$err}); 302 } elsif ( $err ) { 303 $self->_error($err); 304 } 305 306 return $self; 307} 308 309sub _unquote_single { 310 my ($self, $string) = @_; 311 return '' unless length $string; 312 $string =~ s/\'\'/\'/g; 313 return $string; 314} 315 316sub _unquote_double { 317 my ($self, $string) = @_; 318 return '' unless length $string; 319 $string =~ s/\\"/"/g; 320 $string =~ 321 s{\\([Nnever\\fartz0b]|x([0-9a-fA-F]{2}))} 322 {(length($1)>1)?pack("H2",$2):$UNESCAPES{$1}}gex; 323 return $string; 324} 325 326# Load a YAML scalar string to the actual Perl scalar 327sub _load_scalar { 328 my ($self, $string, $indent, $lines) = @_; 329 330 # Trim trailing whitespace 331 $string =~ s/\s*\z//; 332 333 # Explitic null/undef 334 return undef if $string eq '~'; 335 336 # Single quote 337 if ( $string =~ /^$re_capture_single_quoted$re_trailing_comment\z/ ) { 338 return $self->_unquote_single($1); 339 } 340 341 # Double quote. 342 if ( $string =~ /^$re_capture_double_quoted$re_trailing_comment\z/ ) { 343 return $self->_unquote_double($1); 344 } 345 346 # Special cases 347 if ( $string =~ /^[\'\"!&]/ ) { 348 die \"YAML::Tiny does not support a feature in line '$string'"; 349 } 350 return {} if $string =~ /^{}(?:\s+\#.*)?\z/; 351 return [] if $string =~ /^\[\](?:\s+\#.*)?\z/; 352 353 # Regular unquoted string 354 if ( $string !~ /^[>|]/ ) { 355 die \"YAML::Tiny found illegal characters in plain scalar: '$string'" 356 if $string =~ /^(?:-(?:\s|$)|[\@\%\`])/ or 357 $string =~ /:(?:\s|$)/; 358 $string =~ s/\s+#.*\z//; 359 return $string; 360 } 361 362 # Error 363 die \"YAML::Tiny failed to find multi-line scalar content" unless @$lines; 364 365 # Check the indent depth 366 $lines->[0] =~ /^(\s*)/; 367 $indent->[-1] = length("$1"); 368 if ( defined $indent->[-2] and $indent->[-1] <= $indent->[-2] ) { 369 die \"YAML::Tiny found bad indenting in line '$lines->[0]'"; 370 } 371 372 # Pull the lines 373 my @multiline = (); 374 while ( @$lines ) { 375 $lines->[0] =~ /^(\s*)/; 376 last unless length($1) >= $indent->[-1]; 377 push @multiline, substr(shift(@$lines), length($1)); 378 } 379 380 my $j = (substr($string, 0, 1) eq '>') ? ' ' : "\n"; 381 my $t = (substr($string, 1, 1) eq '-') ? '' : "\n"; 382 return join( $j, @multiline ) . $t; 383} 384 385# Load an array 386sub _load_array { 387 my ($self, $array, $indent, $lines) = @_; 388 389 while ( @$lines ) { 390 # Check for a new document 391 if ( $lines->[0] =~ /^(?:---|\.\.\.)/ ) { 392 while ( @$lines and $lines->[0] !~ /^---/ ) { 393 shift @$lines; 394 } 395 return 1; 396 } 397 398 # Check the indent level 399 $lines->[0] =~ /^(\s*)/; 400 if ( length($1) < $indent->[-1] ) { 401 return 1; 402 } elsif ( length($1) > $indent->[-1] ) { 403 die \"YAML::Tiny found bad indenting in line '$lines->[0]'"; 404 } 405 406 if ( $lines->[0] =~ /^(\s*\-\s+)[^\'\"]\S*\s*:(?:\s+|$)/ ) { 407 # Inline nested hash 408 my $indent2 = length("$1"); 409 $lines->[0] =~ s/-/ /; 410 push @$array, { }; 411 $self->_load_hash( $array->[-1], [ @$indent, $indent2 ], $lines ); 412 413 } elsif ( $lines->[0] =~ /^\s*\-\s*\z/ ) { 414 shift @$lines; 415 unless ( @$lines ) { 416 push @$array, undef; 417 return 1; 418 } 419 if ( $lines->[0] =~ /^(\s*)\-/ ) { 420 my $indent2 = length("$1"); 421 if ( $indent->[-1] == $indent2 ) { 422 # Null array entry 423 push @$array, undef; 424 } else { 425 # Naked indenter 426 push @$array, [ ]; 427 $self->_load_array( 428 $array->[-1], [ @$indent, $indent2 ], $lines 429 ); 430 } 431 432 } elsif ( $lines->[0] =~ /^(\s*)\S/ ) { 433 push @$array, { }; 434 $self->_load_hash( 435 $array->[-1], [ @$indent, length("$1") ], $lines 436 ); 437 438 } else { 439 die \"YAML::Tiny failed to classify line '$lines->[0]'"; 440 } 441 442 } elsif ( $lines->[0] =~ /^\s*\-(\s*)(.+?)\s*\z/ ) { 443 # Array entry with a value 444 shift @$lines; 445 push @$array, $self->_load_scalar( 446 "$2", [ @$indent, undef ], $lines 447 ); 448 449 } elsif ( defined $indent->[-2] and $indent->[-1] == $indent->[-2] ) { 450 # This is probably a structure like the following... 451 # --- 452 # foo: 453 # - list 454 # bar: value 455 # 456 # ... so lets return and let the hash parser handle it 457 return 1; 458 459 } else { 460 die \"YAML::Tiny failed to classify line '$lines->[0]'"; 461 } 462 } 463 464 return 1; 465} 466 467# Load a hash 468sub _load_hash { 469 my ($self, $hash, $indent, $lines) = @_; 470 471 while ( @$lines ) { 472 # Check for a new document 473 if ( $lines->[0] =~ /^(?:---|\.\.\.)/ ) { 474 while ( @$lines and $lines->[0] !~ /^---/ ) { 475 shift @$lines; 476 } 477 return 1; 478 } 479 480 # Check the indent level 481 $lines->[0] =~ /^(\s*)/; 482 if ( length($1) < $indent->[-1] ) { 483 return 1; 484 } elsif ( length($1) > $indent->[-1] ) { 485 die \"YAML::Tiny found bad indenting in line '$lines->[0]'"; 486 } 487 488 # Find the key 489 my $key; 490 491 # Quoted keys 492 if ( $lines->[0] =~ 493 s/^\s*$re_capture_single_quoted$re_key_value_separator// 494 ) { 495 $key = $self->_unquote_single($1); 496 } 497 elsif ( $lines->[0] =~ 498 s/^\s*$re_capture_double_quoted$re_key_value_separator// 499 ) { 500 $key = $self->_unquote_double($1); 501 } 502 elsif ( $lines->[0] =~ 503 s/^\s*$re_capture_unquoted_key$re_key_value_separator// 504 ) { 505 $key = $1; 506 $key =~ s/\s+$//; 507 } 508 elsif ( $lines->[0] =~ /^\s*\?/ ) { 509 die \"YAML::Tiny does not support a feature in line '$lines->[0]'"; 510 } 511 else { 512 die \"YAML::Tiny failed to classify line '$lines->[0]'"; 513 } 514 515 if ( exists $hash->{$key} ) { 516 warn "YAML::Tiny found a duplicate key '$key' in line '$lines->[0]'"; 517 } 518 519 # Do we have a value? 520 if ( length $lines->[0] ) { 521 # Yes 522 $hash->{$key} = $self->_load_scalar( 523 shift(@$lines), [ @$indent, undef ], $lines 524 ); 525 } else { 526 # An indent 527 shift @$lines; 528 unless ( @$lines ) { 529 $hash->{$key} = undef; 530 return 1; 531 } 532 if ( $lines->[0] =~ /^(\s*)-/ ) { 533 $hash->{$key} = []; 534 $self->_load_array( 535 $hash->{$key}, [ @$indent, length($1) ], $lines 536 ); 537 } elsif ( $lines->[0] =~ /^(\s*)./ ) { 538 my $indent2 = length("$1"); 539 if ( $indent->[-1] >= $indent2 ) { 540 # Null hash entry 541 $hash->{$key} = undef; 542 } else { 543 $hash->{$key} = {}; 544 $self->_load_hash( 545 $hash->{$key}, [ @$indent, length($1) ], $lines 546 ); 547 } 548 } 549 } 550 } 551 552 return 1; 553} 554 555 556### 557# Dumper functions: 558 559# Save an object to a file 560sub _dump_file { 561 my $self = shift; 562 563 require Fcntl; 564 565 # Check the file 566 my $file = shift or $self->_error( 'You did not specify a file name' ); 567 568 my $fh; 569 # flock if available (or warn if not possible for OS-specific reasons) 570 if ( _can_flock() ) { 571 # Open without truncation (truncate comes after lock) 572 my $flags = Fcntl::O_WRONLY()|Fcntl::O_CREAT(); 573 sysopen( $fh, $file, $flags ) 574 or $self->_error("Failed to open file '$file' for writing: $!"); 575 576 # Use no translation and strict UTF-8 577 binmode( $fh, ":raw:encoding(UTF-8)"); 578 579 flock( $fh, Fcntl::LOCK_EX() ) 580 or warn "Couldn't lock '$file' for reading: $!"; 581 582 # truncate and spew contents 583 truncate $fh, 0; 584 seek $fh, 0, 0; 585 } 586 else { 587 open $fh, ">:unix:encoding(UTF-8)", $file; 588 } 589 590 # serialize and spew to the handle 591 print {$fh} $self->_dump_string; 592 593 # close the file (release the lock) 594 unless ( close $fh ) { 595 $self->_error("Failed to close file '$file': $!"); 596 } 597 598 return 1; 599} 600 601# Save an object to a string 602sub _dump_string { 603 my $self = shift; 604 return '' unless ref $self && @$self; 605 606 # Iterate over the documents 607 my $indent = 0; 608 my @lines = (); 609 610 eval { 611 foreach my $cursor ( @$self ) { 612 push @lines, '---'; 613 614 # An empty document 615 if ( ! defined $cursor ) { 616 # Do nothing 617 618 # A scalar document 619 } elsif ( ! ref $cursor ) { 620 $lines[-1] .= ' ' . $self->_dump_scalar( $cursor ); 621 622 # A list at the root 623 } elsif ( ref $cursor eq 'ARRAY' ) { 624 unless ( @$cursor ) { 625 $lines[-1] .= ' []'; 626 next; 627 } 628 push @lines, $self->_dump_array( $cursor, $indent, {} ); 629 630 # A hash at the root 631 } elsif ( ref $cursor eq 'HASH' ) { 632 unless ( %$cursor ) { 633 $lines[-1] .= ' {}'; 634 next; 635 } 636 push @lines, $self->_dump_hash( $cursor, $indent, {} ); 637 638 } else { 639 die \("Cannot serialize " . ref($cursor)); 640 } 641 } 642 }; 643 if ( ref $@ eq 'SCALAR' ) { 644 $self->_error(${$@}); 645 } elsif ( $@ ) { 646 $self->_error($@); 647 } 648 649 join '', map { "$_\n" } @lines; 650} 651 652sub _has_internal_string_value { 653 my $value = shift; 654 my $b_obj = B::svref_2object(\$value); # for round trip problem 655 return $b_obj->FLAGS & B::SVf_POK(); 656} 657 658sub _dump_scalar { 659 my $string = $_[1]; 660 my $is_key = $_[2]; 661 # Check this before checking length or it winds up looking like a string! 662 my $has_string_flag = _has_internal_string_value($string); 663 return '~' unless defined $string; 664 return "''" unless length $string; 665 if (Scalar::Util::looks_like_number($string)) { 666 # keys and values that have been used as strings get quoted 667 if ( $is_key || $has_string_flag ) { 668 return qq['$string']; 669 } 670 else { 671 return $string; 672 } 673 } 674 if ( $string =~ /[\x00-\x09\x0b-\x0d\x0e-\x1f\x7f-\x9f\'\n]/ ) { 675 $string =~ s/\\/\\\\/g; 676 $string =~ s/"/\\"/g; 677 $string =~ s/\n/\\n/g; 678 $string =~ s/[\x85]/\\N/g; 679 $string =~ s/([\x00-\x1f])/\\$UNPRINTABLE[ord($1)]/g; 680 $string =~ s/([\x7f-\x9f])/'\x' . sprintf("%X",ord($1))/ge; 681 return qq|"$string"|; 682 } 683 if ( $string =~ /(?:^[~!@#%&*|>?:,'"`{}\[\]]|^-+$|\s|:\z)/ or 684 $QUOTE{$string} 685 ) { 686 return "'$string'"; 687 } 688 return $string; 689} 690 691sub _dump_array { 692 my ($self, $array, $indent, $seen) = @_; 693 if ( $seen->{refaddr($array)}++ ) { 694 die \"YAML::Tiny does not support circular references"; 695 } 696 my @lines = (); 697 foreach my $el ( @$array ) { 698 my $line = (' ' x $indent) . '-'; 699 my $type = ref $el; 700 if ( ! $type ) { 701 $line .= ' ' . $self->_dump_scalar( $el ); 702 push @lines, $line; 703 704 } elsif ( $type eq 'ARRAY' ) { 705 if ( @$el ) { 706 push @lines, $line; 707 push @lines, $self->_dump_array( $el, $indent + 1, $seen ); 708 } else { 709 $line .= ' []'; 710 push @lines, $line; 711 } 712 713 } elsif ( $type eq 'HASH' ) { 714 if ( keys %$el ) { 715 push @lines, $line; 716 push @lines, $self->_dump_hash( $el, $indent + 1, $seen ); 717 } else { 718 $line .= ' {}'; 719 push @lines, $line; 720 } 721 722 } else { 723 die \"YAML::Tiny does not support $type references"; 724 } 725 } 726 727 @lines; 728} 729 730sub _dump_hash { 731 my ($self, $hash, $indent, $seen) = @_; 732 if ( $seen->{refaddr($hash)}++ ) { 733 die \"YAML::Tiny does not support circular references"; 734 } 735 my @lines = (); 736 foreach my $name ( sort keys %$hash ) { 737 my $el = $hash->{$name}; 738 my $line = (' ' x $indent) . $self->_dump_scalar($name, 1) . ":"; 739 my $type = ref $el; 740 if ( ! $type ) { 741 $line .= ' ' . $self->_dump_scalar( $el ); 742 push @lines, $line; 743 744 } elsif ( $type eq 'ARRAY' ) { 745 if ( @$el ) { 746 push @lines, $line; 747 push @lines, $self->_dump_array( $el, $indent + 1, $seen ); 748 } else { 749 $line .= ' []'; 750 push @lines, $line; 751 } 752 753 } elsif ( $type eq 'HASH' ) { 754 if ( keys %$el ) { 755 push @lines, $line; 756 push @lines, $self->_dump_hash( $el, $indent + 1, $seen ); 757 } else { 758 $line .= ' {}'; 759 push @lines, $line; 760 } 761 762 } else { 763 die \"YAML::Tiny does not support $type references"; 764 } 765 } 766 767 @lines; 768} 769 770 771 772##################################################################### 773# DEPRECATED API methods: 774 775# Error storage (DEPRECATED as of 1.57) 776our $errstr = ''; 777 778# Set error 779sub _error { 780 require Carp; 781 $errstr = $_[1]; 782 $errstr =~ s/ at \S+ line \d+.*//; 783 Carp::croak( $errstr ); 784} 785 786# Retrieve error 787my $errstr_warned; 788sub errstr { 789 require Carp; 790 Carp::carp( "YAML::Tiny->errstr and \$YAML::Tiny::errstr is deprecated" ) 791 unless $errstr_warned++; 792 $errstr; 793} 794 795 796 797 798##################################################################### 799# Helper functions. Possibly not needed. 800 801 802# Use to detect nv or iv 803use B; 804 805# XXX-INGY Is flock YAML::Tiny's responsibility? 806# Some platforms can't flock :-( 807# XXX-XDG I think it is. When reading and writing files, we ought 808# to be locking whenever possible. People (foolishly) use YAML 809# files for things like session storage, which has race issues. 810my $HAS_FLOCK; 811sub _can_flock { 812 if ( defined $HAS_FLOCK ) { 813 return $HAS_FLOCK; 814 } 815 else { 816 require Config; 817 my $c = \%Config::Config; 818 $HAS_FLOCK = grep { $c->{$_} } qw/d_flock d_fcntl_can_lock d_lockf/; 819 require Fcntl if $HAS_FLOCK; 820 return $HAS_FLOCK; 821 } 822} 823 824 825# XXX-INGY Is this core in 5.8.1? Can we remove this? 826# XXX-XDG Scalar::Util 1.18 didn't land until 5.8.8, so we need this 827##################################################################### 828# Use Scalar::Util if possible, otherwise emulate it 829 830use Scalar::Util (); 831BEGIN { 832 local $@; 833 if ( eval { Scalar::Util->VERSION(1.18); } ) { 834 *refaddr = *Scalar::Util::refaddr; 835 } 836 else { 837 eval <<'END_PERL'; 838# Scalar::Util failed to load or too old 839sub refaddr { 840 my $pkg = ref($_[0]) or return undef; 841 if ( !! UNIVERSAL::can($_[0], 'can') ) { 842 bless $_[0], 'Scalar::Util::Fake'; 843 } else { 844 $pkg = undef; 845 } 846 "$_[0]" =~ /0x(\w+)/; 847 my $i = do { no warnings 'portable'; hex $1 }; 848 bless $_[0], $pkg if defined $pkg; 849 $i; 850} 851END_PERL 852 } 853} 854 855delete $YAML::Tiny::{refaddr}; 856 8571; 858 859# XXX-INGY Doc notes I'm putting up here. Changing the doc when it's wrong 860# but leaving grey area stuff up here. 861# 862# I would like to change Read/Write to Load/Dump below without 863# changing the actual API names. 864# 865# It might be better to put Load/Dump API in the SYNOPSIS instead of the 866# dubious OO API. 867# 868# null and bool explanations may be outdated. 869 870__END__ 871 872#line 1487 873