[p5sagit/p5-mst-13.2.git] / cpan / Module-Build / lib / Module / Build / YAML.pm

# Adapted from YAML::Tiny 1.40
package Module::Build::YAML;

use strict;
use Carp 'croak';

# UTF Support?
sub HAVE_UTF8 () { $] >= 5.007003 }
BEGIN {
	if ( HAVE_UTF8 ) {
		# The string eval helps hide this from Test::MinimumVersion
		eval "require utf8;";
		die "Failed to load UTF-8 support" if $@;
	}

	# Class structure
	require 5.004;

	$Module::Build::YAML::VERSION   = '1.40';

	# Error storage
	$Module::Build::YAML::errstr    = '';
}

# The character class of all characters we need to escape
# NOTE: Inlined, since it's only used once
# my $RE_ESCAPE   = '[\\x00-\\x08\\x0b-\\x0d\\x0e-\\x1f\"\n]';

# Printed form of the unprintable characters in the lowest range
# of ASCII characters, listed by ASCII ordinal position.
my @UNPRINTABLE = qw(
	z    x01  x02  x03  x04  x05  x06  a
	x08  t    n    v    f    r    x0e  x0f
	x10  x11  x12  x13  x14  x15  x16  x17
	x18  x19  x1a  e    x1c  x1d  x1e  x1f
);

# Printable characters for escapes
my %UNESCAPES = (
	z => "\x00", a => "\x07", t    => "\x09",
	n => "\x0a", v => "\x0b", f    => "\x0c",
	r => "\x0d", e => "\x1b", '\\' => '\\',
);

# Special magic boolean words
my %QUOTE = map { $_ => 1 } qw{
	null Null NULL
	y Y yes Yes YES n N no No NO
	true True TRUE false False FALSE
	on On ON off Off OFF
};

#####################################################################
# Implementation

# Create an empty Module::Build::YAML object
sub new {
	my $class = shift;
	bless [ @_ ], $class;
}

# Create an object from a file
sub read {
	my $class = ref $_[0] ? ref shift : shift;

	# Check the file
	my $file = shift or return $class->_error( 'You did not specify a file name' );
	return $class->_error( "File '$file' does not exist" )              unless -e $file;
	return $class->_error( "'$file' is a directory, not a file" )       unless -f _;
	return $class->_error( "Insufficient permissions to read '$file'" ) unless -r _;

	# Slurp in the file
	local $/ = undef;
	local *CFG;
	unless ( open(CFG, $file) ) {
		return $class->_error("Failed to open file '$file': $!");
	}
	my $contents = <CFG>;
	unless ( close(CFG) ) {
		return $class->_error("Failed to close file '$file': $!");
	}

	$class->read_string( $contents );
}

# Create an object from a string
sub read_string {
	my $class  = ref $_[0] ? ref shift : shift;
	my $self   = bless [], $class;
	my $string = $_[0];
	unless ( defined $string ) {
		return $self->_error("Did not provide a string to load");
	}

	# Byte order marks
	# NOTE: Keeping this here to educate maintainers
	# my %BOM = (
	#     "\357\273\277" => 'UTF-8',
	#     "\376\377"     => 'UTF-16BE',
	#     "\377\376"     => 'UTF-16LE',
	#     "\377\376\0\0" => 'UTF-32LE'
	#     "\0\0\376\377" => 'UTF-32BE',
	# );
	if ( $string =~ /^(?:\376\377|\377\376|\377\376\0\0|\0\0\376\377)/ ) {
		return $self->_error("Stream has a non UTF-8 BOM");
	} else {
		# Strip UTF-8 bom if found, we'll just ignore it
		$string =~ s/^\357\273\277//;
	}

	# Try to decode as utf8
	utf8::decode($string) if HAVE_UTF8;

	# Check for some special cases
	return $self unless length $string;
	unless ( $string =~ /[\012\015]+\z/ ) {
		return $self->_error("Stream does not end with newline character");
	}

	# Split the file into lines
	my @lines = grep { ! /^\s*(?:\#.*)?\z/ }
	            split /(?:\015{1,2}\012|\015|\012)/, $string;

	# Strip the initial YAML header
	@lines and $lines[0] =~ /^\%YAML[: ][\d\.]+.*\z/ and shift @lines;

	# A nibbling parser
	while ( @lines ) {
		# Do we have a document header?
		if ( $lines[0] =~ /^---\s*(?:(.+)\s*)?\z/ ) {
			# Handle scalar documents
			shift @lines;
			if ( defined $1 and $1 !~ /^(?:\#.+|\%YAML[: ][\d\.]+)\z/ ) {
				push @$self, $self->_read_scalar( "$1", [ undef ], \@lines );
				next;
			}
		}

		if ( ! @lines or $lines[0] =~ /^(?:---|\.\.\.)/ ) {
			# A naked document
			push @$self, undef;
			while ( @lines and $lines[0] !~ /^---/ ) {
				shift @lines;
			}

		} elsif ( $lines[0] =~ /^\s*\-/ ) {
			# An array at the root
			my $document = [ ];
			push @$self, $document;
			$self->_read_array( $document, [ 0 ], \@lines );

		} elsif ( $lines[0] =~ /^(\s*)\S/ ) {
			# A hash at the root
			my $document = { };
			push @$self, $document;
			$self->_read_hash( $document, [ length($1) ], \@lines );

		} else {
			croak("Module::Build::YAML failed to classify the line '$lines[0]'");
		}
	}

	$self;
}

# Deparse a scalar string to the actual scalar
sub _read_scalar {
	my ($self, $string, $indent, $lines) = @_;

	# Trim trailing whitespace
	$string =~ s/\s*\z//;

	# Explitic null/undef
	return undef if $string eq '~';

	# Quotes
	if ( $string =~ /^\'(.*?)\'\z/ ) {
		return '' unless defined $1;
		$string = $1;
		$string =~ s/\'\'/\'/g;
		return $string;
	}
	if ( $string =~ /^\"((?:\\.|[^\"])*)\"\z/ ) {
		# Reusing the variable is a little ugly,
		# but avoids a new variable and a string copy.
		$string = $1;
		$string =~ s/\\"/"/g;
		$string =~ s/\\([never\\fartz]|x([0-9a-fA-F]{2}))/(length($1)>1)?pack("H2",$2):$UNESCAPES{$1}/gex;
		return $string;
	}

	# Special cases
	if ( $string =~ /^[\'\"!&]/ ) {
		croak("Module::Build::YAML does not support a feature in line '$lines->[0]'");
	}
	return {} if $string eq '{}';
	return [] if $string eq '[]';

	# Regular unquoted string
	return $string unless $string =~ /^[>|]/;

	# Error
	croak("Module::Build::YAML failed to find multi-line scalar content") unless @$lines;

	# Check the indent depth
	$lines->[0]   =~ /^(\s*)/;
	$indent->[-1] = length("$1");
	if ( defined $indent->[-2] and $indent->[-1] <= $indent->[-2] ) {
		croak("Module::Build::YAML found bad indenting in line '$lines->[0]'");
	}

	# Pull the lines
	my @multiline = ();
	while ( @$lines ) {
		$lines->[0] =~ /^(\s*)/;
		last unless length($1) >= $indent->[-1];
		push @multiline, substr(shift(@$lines), length($1));
	}

	my $j = (substr($string, 0, 1) eq '>') ? ' ' : "\n";
	my $t = (substr($string, 1, 1) eq '-') ? ''  : "\n";
	return join( $j, @multiline ) . $t;
}

# Parse an array
sub _read_array {
	my ($self, $array, $indent, $lines) = @_;

	while ( @$lines ) {
		# Check for a new document
		if ( $lines->[0] =~ /^(?:---|\.\.\.)/ ) {
			while ( @$lines and $lines->[0] !~ /^---/ ) {
				shift @$lines;
			}
			return 1;
		}

		# Check the indent level
		$lines->[0] =~ /^(\s*)/;
		if ( length($1) < $indent->[-1] ) {
			return 1;
		} elsif ( length($1) > $indent->[-1] ) {
			croak("Module::Build::YAML found bad indenting in line '$lines->[0]'");
		}

		if ( $lines->[0] =~ /^(\s*\-\s+)[^\'\"]\S*\s*:(?:\s+|$)/ ) {
			# Inline nested hash
			my $indent2 = length("$1");
			$lines->[0] =~ s/-/ /;
			push @$array, { };
			$self->_read_hash( $array->[-1], [ @$indent, $indent2 ], $lines );

		} elsif ( $lines->[0] =~ /^\s*\-(\s*)(.+?)\s*\z/ ) {
			# Array entry with a value
			shift @$lines;
			push @$array, $self->_read_scalar( "$2", [ @$indent, undef ], $lines );

		} elsif ( $lines->[0] =~ /^\s*\-\s*\z/ ) {
			shift @$lines;
			unless ( @$lines ) {
				push @$array, undef;
				return 1;
			}
			if ( $lines->[0] =~ /^(\s*)\-/ ) {
				my $indent2 = length("$1");
				if ( $indent->[-1] == $indent2 ) {
					# Null array entry
					push @$array, undef;
				} else {
					# Naked indenter
					push @$array, [ ];
					$self->_read_array( $array->[-1], [ @$indent, $indent2 ], $lines );
				}

			} elsif ( $lines->[0] =~ /^(\s*)\S/ ) {
				push @$array, { };
				$self->_read_hash( $array->[-1], [ @$indent, length("$1") ], $lines );

			} else {
				croak("Module::Build::YAML failed to classify line '$lines->[0]'");
			}

		} elsif ( defined $indent->[-2] and $indent->[-1] == $indent->[-2] ) {
			# This is probably a structure like the following...
			# ---
			# foo:
			# - list
			# bar: value
			#
			# ... so lets return and let the hash parser handle it
			return 1;

		} else {
			croak("Module::Build::YAML failed to classify line '$lines->[0]'");
		}
	}

	return 1;
}

# Parse an array
sub _read_hash {
	my ($self, $hash, $indent, $lines) = @_;

	while ( @$lines ) {
		# Check for a new document
		if ( $lines->[0] =~ /^(?:---|\.\.\.)/ ) {
			while ( @$lines and $lines->[0] !~ /^---/ ) {
				shift @$lines;
			}
			return 1;
		}

		# Check the indent level
		$lines->[0] =~ /^(\s*)/;
		if ( length($1) < $indent->[-1] ) {
			return 1;
		} elsif ( length($1) > $indent->[-1] ) {
			croak("Module::Build::YAML found bad indenting in line '$lines->[0]'");
		}

		# Get the key
		unless ( $lines->[0] =~ s/^\s*([^\'\" ][^\n]*?)\s*:(\s+|$)// ) {
			if ( $lines->[0] =~ /^\s*[?\'\"]/ ) {
				croak("Module::Build::YAML does not support a feature in line '$lines->[0]'");
			}
			croak("Module::Build::YAML failed to classify line '$lines->[0]'");
		}
		my $key = $1;

		# Do we have a value?
		if ( length $lines->[0] ) {
			# Yes
			$hash->{$key} = $self->_read_scalar( shift(@$lines), [ @$indent, undef ], $lines );
		} else {
			# An indent
			shift @$lines;
			unless ( @$lines ) {
				$hash->{$key} = undef;
				return 1;
			}
			if ( $lines->[0] =~ /^(\s*)-/ ) {
				$hash->{$key} = [];
				$self->_read_array( $hash->{$key}, [ @$indent, length($1) ], $lines );
			} elsif ( $lines->[0] =~ /^(\s*)./ ) {
				my $indent2 = length("$1");
				if ( $indent->[-1] >= $indent2 ) {
					# Null hash entry
					$hash->{$key} = undef;
				} else {
					$hash->{$key} = {};
					$self->_read_hash( $hash->{$key}, [ @$indent, length($1) ], $lines );
				}
			}
		}
	}

	return 1;
}

# Save an object to a file
sub write {
	my $self = shift;
	my $file = shift or return $self->_error('No file name provided');

	# Write it to the file
	open( CFG, '>' . $file ) or return $self->_error(
		"Failed to open file '$file' for writing: $!"
		);
	print CFG $self->write_string;
	close CFG;

	return 1;
}

# Save an object to a string
sub write_string {
	my $self = shift;
	return '' unless @$self;

	# Iterate over the documents
	my $indent = 0;
	my @lines  = ();
	foreach my $cursor ( @$self ) {
		push @lines, '---';

		# An empty document
		if ( ! defined $cursor ) {
			# Do nothing

		# A scalar document
		} elsif ( ! ref $cursor ) {
			$lines[-1] .= ' ' . $self->_write_scalar( $cursor, $indent );

		# A list at the root
		} elsif ( ref $cursor eq 'ARRAY' ) {
			unless ( @$cursor ) {
				$lines[-1] .= ' []';
				next;
			}
			push @lines, $self->_write_array( $cursor, $indent, {} );

		# A hash at the root
		} elsif ( ref $cursor eq 'HASH' ) {
			unless ( %$cursor ) {
				$lines[-1] .= ' {}';
				next;
			}
			push @lines, $self->_write_hash( $cursor, $indent, {} );

		} else {
			croak("Cannot serialize " . ref($cursor));
		}
	}

	join '', map { "$_\n" } @lines;
}

sub _write_scalar {
	my $string = $_[1];
	return '~'  unless defined $string;
	return "''" unless length  $string;
	if ( $string =~ /[\x00-\x08\x0b-\x0d\x0e-\x1f\"\'\n]/ ) {
		$string =~ s/\\/\\\\/g;
		$string =~ s/"/\\"/g;
		$string =~ s/\n/\\n/g;
		$string =~ s/([\x00-\x1f])/\\$UNPRINTABLE[ord($1)]/g;
		return qq|"$string"|;
	}
	if ( $string =~ /(?:^\W|\s)/ or $QUOTE{$string} ) {
		return "'$string'";
	}
	return $string;
}

sub _write_array {
	my ($self, $array, $indent, $seen) = @_;
	if ( $seen->{refaddr($array)}++ ) {
		die "Module::Build::YAML does not support circular references";
	}
	my @lines  = ();
	foreach my $el ( @$array ) {
		my $line = ('  ' x $indent) . '-';
		my $type = ref $el;
		if ( ! $type ) {
			$line .= ' ' . $self->_write_scalar( $el, $indent + 1 );
			push @lines, $line;

		} elsif ( $type eq 'ARRAY' ) {
			if ( @$el ) {
				push @lines, $line;
				push @lines, $self->_write_array( $el, $indent + 1, $seen );
			} else {
				$line .= ' []';
				push @lines, $line;
			}

		} elsif ( $type eq 'HASH' ) {
			if ( keys %$el ) {
				push @lines, $line;
				push @lines, $self->_write_hash( $el, $indent + 1, $seen );
			} else {
				$line .= ' {}';
				push @lines, $line;
			}

		} else {
			die "Module::Build::YAML does not support $type references";
		}
	}

	@lines;
}

sub _write_hash {
	my ($self, $hash, $indent, $seen) = @_;
	if ( $seen->{refaddr($hash)}++ ) {
		die "Module::Build::YAML does not support circular references";
	}
	my @lines  = ();
	foreach my $name ( sort keys %$hash ) {
		my $el   = $hash->{$name};
		my $line = ('  ' x $indent) . "$name:";
		my $type = ref $el;
		if ( ! $type ) {
			$line .= ' ' . $self->_write_scalar( $el, $indent + 1 );
			push @lines, $line;

		} elsif ( $type eq 'ARRAY' ) {
			if ( @$el ) {
				push @lines, $line;
				push @lines, $self->_write_array( $el, $indent + 1, $seen );
			} else {
				$line .= ' []';
				push @lines, $line;
			}

		} elsif ( $type eq 'HASH' ) {
			if ( keys %$el ) {
				push @lines, $line;
				push @lines, $self->_write_hash( $el, $indent + 1, $seen );
			} else {
				$line .= ' {}';
				push @lines, $line;
			}

		} else {
			die "Module::Build::YAML does not support $type references";
		}
	}

	@lines;
}

# Set error
sub _error {
	$Module::Build::YAML::errstr = $_[1];
	undef;
}

# Retrieve error
sub errstr {
	$Module::Build::YAML::errstr;
}

#####################################################################
# YAML Compatibility

sub Dump {
	Module::Build::YAML->new(@_)->write_string;
}

sub Load {
	my $self = Module::Build::YAML->read_string(@_);
	unless ( $self ) {
		croak("Failed to load YAML document from string");
	}
	if ( wantarray ) {
		return @$self;
	} else {
		# To match YAML.pm, return the last document
		return $self->[-1];
	}
}

BEGIN {
	*freeze = *Dump;
	*thaw   = *Load;
}

sub DumpFile {
	my $file = shift;
	Module::Build::YAML->new(@_)->write($file);
}

sub LoadFile {
	my $self = Module::Build::YAML->read($_[0]);
	unless ( $self ) {
		croak("Failed to load YAML document from '" . ($_[0] || '') . "'");
	}
	if ( wantarray ) {
		return @$self;
	} else {
		# Return only the last document to match YAML.pm,
		return $self->[-1];
	}
}

#####################################################################
# Use Scalar::Util if possible, otherwise emulate it

BEGIN {
	eval {
		require Scalar::Util;
	};
	if ( $@ ) {
		# Failed to load Scalar::Util
		eval <<'END_PERL';
sub refaddr {
	my $pkg = ref($_[0]) or return undef;
	if (!!UNIVERSAL::can($_[0], 'can')) {
		bless $_[0], 'Scalar::Util::Fake';
	} else {
		$pkg = undef;
	}
	"$_[0]" =~ /0x(\w+)/;
	my $i = do { local $^W; hex $1 };
	bless $_[0], $pkg if defined $pkg;
	$i;
}
END_PERL
	} else {
		Scalar::Util->import('refaddr');
	}
}

1;

__END__
Commit	Line	Data
613f422f	1	# Adapted from YAML::Tiny 1.40
a314697d	2	package Module::Build::YAML;
	3
	4	use strict;
613f422f	5	use Carp 'croak';
a314697d	6
613f422f	7	# UTF Support?
	8	sub HAVE_UTF8 () { $] >= 5.007003 }
	9	BEGIN {
	10	if ( HAVE_UTF8 ) {
	11	# The string eval helps hide this from Test::MinimumVersion
	12	eval "require utf8;";
	13	die "Failed to load UTF-8 support" if $@;
	14	}
	15
	16	# Class structure
	17	require 5.004;
	18
	19	$Module::Build::YAML::VERSION = '1.40';
	20
	21	# Error storage
	22	$Module::Build::YAML::errstr = '';
	23	}
	24
	25	# The character class of all characters we need to escape
	26	# NOTE: Inlined, since it's only used once
	27	# my $RE_ESCAPE = '[\\x00-\\x08\\x0b-\\x0d\\x0e-\\x1f\"\n]';
	28
	29	# Printed form of the unprintable characters in the lowest range
	30	# of ASCII characters, listed by ASCII ordinal position.
	31	my @UNPRINTABLE = qw(
	32	z x01 x02 x03 x04 x05 x06 a
	33	x08 t n v f r x0e x0f
	34	x10 x11 x12 x13 x14 x15 x16 x17
	35	x18 x19 x1a e x1c x1d x1e x1f
	36	);
	37
	38	# Printable characters for escapes
	39	my %UNESCAPES = (
	40	z => "\x00", a => "\x07", t => "\x09",
	41	n => "\x0a", v => "\x0b", f => "\x0c",
	42	r => "\x0d", e => "\x1b", '\\' => '\\',
	43	);
	44
	45	# Special magic boolean words
	46	my %QUOTE = map { $_ => 1 } qw{
	47	null Null NULL
	48	y Y yes Yes YES n N no No NO
	49	true True TRUE false False FALSE
	50	on On ON off Off OFF
	51	};
	52
	53	#####################################################################
	54	# Implementation
	55
	56	# Create an empty Module::Build::YAML object
a314697d	57	sub new {
613f422f	58	my $class = shift;
613f422f	59	bless [ @_ ], $class;
a314697d	60	}
a314697d	61
613f422f	62	# Create an object from a file
	63	sub read {
	64	my $class = ref $_[0] ? ref shift : shift;
	65
	66	# Check the file
	67	my $file = shift or return $class->_error( 'You did not specify a file name' );
	68	return $class->_error( "File '$file' does not exist" ) unless -e $file;
	69	return $class->_error( "'$file' is a directory, not a file" ) unless -f _;
	70	return $class->_error( "Insufficient permissions to read '$file'" ) unless -r _;
	71
	72	# Slurp in the file
	73	local $/ = undef;
	74	local *CFG;
	75	unless ( open(CFG, $file) ) {
	76	return $class->_error("Failed to open file '$file': $!");
	77	}
	78	my $contents = <CFG>;
	79	unless ( close(CFG) ) {
	80	return $class->_error("Failed to close file '$file': $!");
	81	}
	82
	83	$class->read_string( $contents );
a314697d	84	}
a314697d	85
613f422f	86	# Create an object from a string
	87	sub read_string {
	88	my $class = ref $_[0] ? ref shift : shift;
	89	my $self = bless [], $class;
	90	my $string = $_[0];
	91	unless ( defined $string ) {
	92	return $self->_error("Did not provide a string to load");
	93	}
	94
	95	# Byte order marks
	96	# NOTE: Keeping this here to educate maintainers
	97	# my %BOM = (
	98	# "\357\273\277" => 'UTF-8',
	99	# "\376\377" => 'UTF-16BE',
	100	# "\377\376" => 'UTF-16LE',
	101	# "\377\376\0\0" => 'UTF-32LE'
	102	# "\0\0\376\377" => 'UTF-32BE',
	103	# );
	104	if ( $string =~ /^(?:\376\377\|\377\376\|\377\376\0\0\|\0\0\376\377)/ ) {
	105	return $self->_error("Stream has a non UTF-8 BOM");
	106	} else {
	107	# Strip UTF-8 bom if found, we'll just ignore it
	108	$string =~ s/^\357\273\277//;
	109	}
	110
	111	# Try to decode as utf8
	112	utf8::decode($string) if HAVE_UTF8;
	113
	114	# Check for some special cases
	115	return $self unless length $string;
	116	unless ( $string =~ /[\012\015]+\z/ ) {
	117	return $self->_error("Stream does not end with newline character");
	118	}
	119
	120	# Split the file into lines
	121	my @lines = grep { ! /^\s(?:\#.)?\z/ }
	122	split /(?:\015{1,2}\012\|\015\|\012)/, $string;
	123
	124	# Strip the initial YAML header
	125	@lines and $lines[0] =~ /^\%YAML[: ][\d\.]+.*\z/ and shift @lines;
	126
	127	# A nibbling parser
	128	while ( @lines ) {
	129	# Do we have a document header?
	130	if ( $lines[0] =~ /^---\s(?:(.+)\s)?\z/ ) {
	131	# Handle scalar documents
	132	shift @lines;
	133	if ( defined $1 and $1 !~ /^(?:\#.+\|\%YAML[: ][\d\.]+)\z/ ) {
	134	push @$self, $self->_read_scalar( "$1", [ undef ], \@lines );
	135	next;
	136	}
	137	}
	138
	139	if ( ! @lines or $lines[0] =~ /^(?:---\|\.\.\.)/ ) {
	140	# A naked document
	141	push @$self, undef;
	142	while ( @lines and $lines[0] !~ /^---/ ) {
	143	shift @lines;
	144	}
	145
	146	} elsif ( $lines[0] =~ /^\s*\-/ ) {
	147	# An array at the root
	148	my $document = [ ];
	149	push @$self, $document;
150	$self->_read_array( $document, [ 0 ], \@lines );
151
152	} elsif ( $lines[0] =~ /^(\s*)\S/ ) {
153	# A hash at the root
154	my $document = { };
155	push @$self, $document;
156	$self->_read_hash( $document, [ length($1) ], \@lines );
157
158	} else {
159	croak("Module::Build::YAML failed to classify the line '$lines[0]'");
160	}
161	}
162
163	$self;
a314697d	164	}
a314697d	165
613f422f	166	# Deparse a scalar string to the actual scalar
	167	sub _read_scalar {
	168	my ($self, $string, $indent, $lines) = @_;
	169
	170	# Trim trailing whitespace
	171	$string =~ s/\s*\z//;
	172
	173	# Explitic null/undef
	174	return undef if $string eq '~';
	175
	176	# Quotes
	177	if ( $string =~ /^\'(.*?)\'\z/ ) {
	178	return '' unless defined $1;
	179	$string = $1;
	180	$string =~ s/\'\'/\'/g;
	181	return $string;
	182	}
	183	if ( $string =~ /^\"((?:\\.\|[^\"])*)\"\z/ ) {
	184	# Reusing the variable is a little ugly,
	185	# but avoids a new variable and a string copy.
	186	$string = $1;
	187	$string =~ s/\\"/"/g;
	188	$string =~ s/\\([never\\fartz]\|x([0-9a-fA-F]{2}))/(length($1)>1)?pack("H2",$2):$UNESCAPES{$1}/gex;
	189	return $string;
	190	}
	191
	192	# Special cases
	193	if ( $string =~ /^[\'\"!&]/ ) {
	194	croak("Module::Build::YAML does not support a feature in line '$lines->[0]'");
	195	}
	196	return {} if $string eq '{}';
	197	return [] if $string eq '[]';
	198
	199	# Regular unquoted string
	200	return $string unless $string =~ /^[>\|]/;
	201
	202	# Error
	203	croak("Module::Build::YAML failed to find multi-line scalar content") unless @$lines;
	204
	205	# Check the indent depth
	206	$lines->[0] =~ /^(\s*)/;
	207	$indent->[-1] = length("$1");
	208	if ( defined $indent->[-2] and $indent->[-1] <= $indent->[-2] ) {
	209	croak("Module::Build::YAML found bad indenting in line '$lines->[0]'");
	210	}
	211
	212	# Pull the lines
	213	my @multiline = ();
	214	while ( @$lines ) {
	215	$lines->[0] =~ /^(\s*)/;
	216	last unless length($1) >= $indent->[-1];
	217	push @multiline, substr(shift(@$lines), length($1));
	218	}
	219
	220	my $j = (substr($string, 0, 1) eq '>') ? ' ' : "\n";
	221	my $t = (substr($string, 1, 1) eq '-') ? '' : "\n";
	222	return join( $j, @multiline ) . $t;
a314697d	223	}
a314697d	224
613f422f	225	# Parse an array
	226	sub _read_array {
	227	my ($self, $array, $indent, $lines) = @_;
a314697d	228
613f422f	229	while ( @$lines ) {
	230	# Check for a new document
	231	if ( $lines->[0] =~ /^(?:---\|\.\.\.)/ ) {
	232	while ( @$lines and $lines->[0] !~ /^---/ ) {
	233	shift @$lines;
	234	}
	235	return 1;
	236	}
	237
	238	# Check the indent level
	239	$lines->[0] =~ /^(\s*)/;
	240	if ( length($1) < $indent->[-1] ) {
	241	return 1;
	242	} elsif ( length($1) > $indent->[-1] ) {
	243	croak("Module::Build::YAML found bad indenting in line '$lines->[0]'");
	244	}
	245
	246	if ( $lines->[0] =~ /^(\s\-\s+)[^\'\"]\S\s*:(?:\s+\|$)/ ) {
	247	# Inline nested hash
	248	my $indent2 = length("$1");
	249	$lines->[0] =~ s/-/ /;
	250	push @$array, { };
	251	$self->_read_hash( $array->[-1], [ @$indent, $indent2 ], $lines );
	252
	253	} elsif ( $lines->[0] =~ /^\s\-(\s)(.+?)\s*\z/ ) {
	254	# Array entry with a value
	255	shift @$lines;
	256	push @$array, $self->_read_scalar( "$2", [ @$indent, undef ], $lines );
a314697d	257
613f422f	258	} elsif ( $lines->[0] =~ /^\s\-\s\z/ ) {
	259	shift @$lines;
	260	unless ( @$lines ) {
	261	push @$array, undef;
	262	return 1;
	263	}
	264	if ( $lines->[0] =~ /^(\s*)\-/ ) {
	265	my $indent2 = length("$1");
	266	if ( $indent->[-1] == $indent2 ) {
	267	# Null array entry
	268	push @$array, undef;
	269	} else {
	270	# Naked indenter
	271	push @$array, [ ];
	272	$self->_read_array( $array->[-1], [ @$indent, $indent2 ], $lines );
	273	}
a314697d	274
613f422f	275	} elsif ( $lines->[0] =~ /^(\s*)\S/ ) {
	276	push @$array, { };
	277	$self->_read_hash( $array->[-1], [ @$indent, length("$1") ], $lines );
a314697d	278
613f422f	279	} else {
	280	croak("Module::Build::YAML failed to classify line '$lines->[0]'");
	281	}
a314697d	282
613f422f	283	} elsif ( defined $indent->[-2] and $indent->[-1] == $indent->[-2] ) {
	284	# This is probably a structure like the following...
	285	# ---
	286	# foo:
	287	# - list
	288	# bar: value
	289	#
	290	# ... so lets return and let the hash parser handle it
	291	return 1;
a314697d	292
613f422f	293	} else {
	294	croak("Module::Build::YAML failed to classify line '$lines->[0]'");
	295	}
	296	}
a314697d	297
613f422f	298	return 1;
	299	}
	300
	301	# Parse an array
	302	sub _read_hash {
	303	my ($self, $hash, $indent, $lines) = @_;
	304
	305	while ( @$lines ) {
	306	# Check for a new document
	307	if ( $lines->[0] =~ /^(?:---\|\.\.\.)/ ) {
	308	while ( @$lines and $lines->[0] !~ /^---/ ) {
	309	shift @$lines;
	310	}
	311	return 1;
	312	}
a314697d	313
613f422f	314	# Check the indent level
	315	$lines->[0] =~ /^(\s*)/;
	316	if ( length($1) < $indent->[-1] ) {
	317	return 1;
	318	} elsif ( length($1) > $indent->[-1] ) {
	319	croak("Module::Build::YAML found bad indenting in line '$lines->[0]'");
	320	}
a314697d	321
613f422f	322	# Get the key
	323	unless ( $lines->[0] =~ s/^\s([^\'\" ][^\n]?)\s*:(\s+\|$)// ) {
	324	if ( $lines->[0] =~ /^\s*[?\'\"]/ ) {
	325	croak("Module::Build::YAML does not support a feature in line '$lines->[0]'");
	326	}
	327	croak("Module::Build::YAML failed to classify line '$lines->[0]'");
	328	}
	329	my $key = $1;
a314697d	330
613f422f	331	# Do we have a value?
	332	if ( length $lines->[0] ) {
	333	# Yes
	334	$hash->{$key} = $self->_read_scalar( shift(@$lines), [ @$indent, undef ], $lines );
	335	} else {
	336	# An indent
	337	shift @$lines;
	338	unless ( @$lines ) {
	339	$hash->{$key} = undef;
	340	return 1;
	341	}
	342	if ( $lines->[0] =~ /^(\s*)-/ ) {
	343	$hash->{$key} = [];
	344	$self->_read_array( $hash->{$key}, [ @$indent, length($1) ], $lines );
	345	} elsif ( $lines->[0] =~ /^(\s*)./ ) {
	346	my $indent2 = length("$1");
	347	if ( $indent->[-1] >= $indent2 ) {
	348	# Null hash entry
	349	$hash->{$key} = undef;
	350	} else {
	351	$hash->{$key} = {};
	352	$self->_read_hash( $hash->{$key}, [ @$indent, length($1) ], $lines );
	353	}
	354	}
	355	}
	356	}
a314697d	357
613f422f	358	return 1;
	359	}
	360
	361	# Save an object to a file
	362	sub write {
	363	my $self = shift;
	364	my $file = shift or return $self->_error('No file name provided');
a314697d	365
613f422f	366	# Write it to the file
	367	open( CFG, '>' . $file ) or return $self->_error(
	368	"Failed to open file '$file' for writing: $!"
	369	);
	370	print CFG $self->write_string;
	371	close CFG;
a314697d	372
613f422f	373	return 1;
613f422f	374	}
a314697d	375
613f422f	376	# Save an object to a string
	377	sub write_string {
	378	my $self = shift;
	379	return '' unless @$self;
a314697d	380
613f422f	381	# Iterate over the documents
	382	my $indent = 0;
	383	my @lines = ();
	384	foreach my $cursor ( @$self ) {
	385	push @lines, '---';
a314697d	386
613f422f	387	# An empty document
	388	if ( ! defined $cursor ) {
	389	# Do nothing
	390
	391	# A scalar document
	392	} elsif ( ! ref $cursor ) {
	393	$lines[-1] .= ' ' . $self->_write_scalar( $cursor, $indent );
	394
	395	# A list at the root
	396	} elsif ( ref $cursor eq 'ARRAY' ) {
	397	unless ( @$cursor ) {
	398	$lines[-1] .= ' []';
	399	next;
	400	}
	401	push @lines, $self->_write_array( $cursor, $indent, {} );
	402
	403	# A hash at the root
	404	} elsif ( ref $cursor eq 'HASH' ) {
	405	unless ( %$cursor ) {
	406	$lines[-1] .= ' {}';
	407	next;
	408	}
	409	push @lines, $self->_write_hash( $cursor, $indent, {} );
	410
	411	} else {
	412	croak("Cannot serialize " . ref($cursor));
	413	}
	414	}
	415
	416	join '', map { "$_\n" } @lines;
	417	}
	418
	419	sub _write_scalar {
	420	my $string = $_[1];
	421	return '~' unless defined $string;
	422	return "''" unless length $string;
	423	if ( $string =~ /[\x00-\x08\x0b-\x0d\x0e-\x1f\"\'\n]/ ) {
	424	$string =~ s/\\/\\\\/g;
	425	$string =~ s/"/\\"/g;
	426	$string =~ s/\n/\\n/g;
	427	$string =~ s/([\x00-\x1f])/\\$UNPRINTABLE[ord($1)]/g;
	428	return qq\|"$string"\|;
	429	}
	430	if ( $string =~ /(?:^\W\|\s)/ or $QUOTE{$string} ) {
	431	return "'$string'";
	432	}
	433	return $string;
	434	}
	435
	436	sub _write_array {
	437	my ($self, $array, $indent, $seen) = @_;
	438	if ( $seen->{refaddr($array)}++ ) {
	439	die "Module::Build::YAML does not support circular references";
	440	}
	441	my @lines = ();
	442	foreach my $el ( @$array ) {
	443	my $line = (' ' x $indent) . '-';
	444	my $type = ref $el;
	445	if ( ! $type ) {
	446	$line .= ' ' . $self->_write_scalar( $el, $indent + 1 );
	447	push @lines, $line;
	448
	449	} elsif ( $type eq 'ARRAY' ) {
	450	if ( @$el ) {
451	push @lines, $line;
452	push @lines, $self->_write_array( $el, $indent + 1, $seen );
453	} else {
454	$line .= ' []';
455	push @lines, $line;
456	}
457
458	} elsif ( $type eq 'HASH' ) {
459	if ( keys %$el ) {
460	push @lines, $line;
461	push @lines, $self->_write_hash( $el, $indent + 1, $seen );
462	} else {
463	$line .= ' {}';
464	push @lines, $line;
465	}
466
467	} else {
468	die "Module::Build::YAML does not support $type references";
469	}
470	}
471
472	@lines;
473	}
474
475	sub _write_hash {
476	my ($self, $hash, $indent, $seen) = @_;
477	if ( $seen->{refaddr($hash)}++ ) {
478	die "Module::Build::YAML does not support circular references";
479	}
480	my @lines = ();
481	foreach my $name ( sort keys %$hash ) {
482	my $el = $hash->{$name};
483	my $line = (' ' x $indent) . "$name:";
484	my $type = ref $el;
485	if ( ! $type ) {
486	$line .= ' ' . $self->_write_scalar( $el, $indent + 1 );
487	push @lines, $line;
488
489	} elsif ( $type eq 'ARRAY' ) {
490	if ( @$el ) {
491	push @lines, $line;
492	push @lines, $self->_write_array( $el, $indent + 1, $seen );
493	} else {
494	$line .= ' []';
495	push @lines, $line;
496	}
497
498	} elsif ( $type eq 'HASH' ) {
499	if ( keys %$el ) {
500	push @lines, $line;
501	push @lines, $self->_write_hash( $el, $indent + 1, $seen );
502	} else {
503	$line .= ' {}';
504	push @lines, $line;
505	}
506
507	} else {
508	die "Module::Build::YAML does not support $type references";
509	}
510	}
511
512	@lines;
513	}
514
515	# Set error
516	sub _error {
517	$Module::Build::YAML::errstr = $_[1];
518	undef;
519	}
520
521	# Retrieve error
522	sub errstr {
523	$Module::Build::YAML::errstr;
524	}
525
526	#####################################################################
527	# YAML Compatibility
528
529	sub Dump {
530	Module::Build::YAML->new(@_)->write_string;
531	}
532
533	sub Load {
534	my $self = Module::Build::YAML->read_string(@_);
535	unless ( $self ) {
536	croak("Failed to load YAML document from string");
537	}
538	if ( wantarray ) {
539	return @$self;
540	} else {
541	# To match YAML.pm, return the last document
542	return $self->[-1];
543	}
544	}
545
546	BEGIN {
547	freeze = Dump;
548	thaw = Load;
549	}
550
551	sub DumpFile {
552	my $file = shift;
553	Module::Build::YAML->new(@_)->write($file);
554	}
555
556	sub LoadFile {
557	my $self = Module::Build::YAML->read($_[0]);
558	unless ( $self ) {
559	croak("Failed to load YAML document from '" . ($_[0] \|\| '') . "'");
560	}
561	if ( wantarray ) {
562	return @$self;
563	} else {
564	# Return only the last document to match YAML.pm,
565	return $self->[-1];
566	}
567	}
568
569	#####################################################################
570	# Use Scalar::Util if possible, otherwise emulate it
571
572	BEGIN {
573	eval {
574	require Scalar::Util;
575	};
576	if ( $@ ) {
577	# Failed to load Scalar::Util
578	eval <<'END_PERL';
579	sub refaddr {
580	my $pkg = ref($_[0]) or return undef;
581	if (!!UNIVERSAL::can($_[0], 'can')) {
582	bless $_[0], 'Scalar::Util::Fake';
583	} else {
584	$pkg = undef;
585	}
586	"$_[0]" =~ /0x(\w+)/;
587	my $i = do { local $^W; hex $1 };
588	bless $_[0], $pkg if defined $pkg;
589	$i;
590	}
591	END_PERL
592	} else {
593	Scalar::Util->import('refaddr');
594	}
595	}
596
597	1;
598
599	__END__
a314697d	600