Author: dagolden
Date: Thu Sep 10 22:47:17 2009
New Revision: 13301
Added:
Module-Build/trunk/devtools/update_yamltiny.pl (contents, props changed)
Removed:
Module-Build/trunk/t/mbyaml.t
Modified:
Module-Build/trunk/Build.PL
Module-Build/trunk/Changes
Module-Build/trunk/lib/Module/Build.pm
Module-Build/trunk/lib/Module/Build/API.pod
Module-Build/trunk/lib/Module/Build/Base.pm
Module-Build/trunk/lib/Module/Build/YAML.pm
Module-Build/trunk/t/extend.t
Log:
Replace YAML.pm with YAML::Tiny
We now use YAML::Tiny in place of YAML.pm. We lose ordered META.yml
files, but YAML::Tiny is more robust and better maintained. Also,
Parse::CPAN::Meta is based on YAML::Tiny, so now we are writing in the
same YAML dialect it expects. Module::Build::YAML has been updated
with the guts of YAML::Tiny and there is a nifty developer tool to
suck in the latest guts of YAML::Tiny, stop it from exporting things,
and s/YAML::Tiny/Module::Build::YAML/.
Modified: Module-Build/trunk/Build.PL
==============================================================================
--- Module-Build/trunk/Build.PL (original)
+++ Module-Build/trunk/Build.PL Thu Sep 10 22:47:17 2009
@@ -71,8 +71,8 @@
auto_features => {
YAML_support => {
- description => "Use YAML.pm to write META.yml files",
- requires => {YAML => ' >= 0.35, != 0.49_01 '},
+ description => "Use YAML::Tiny to write META.yml files",
+ requires => {'YAML::Tiny' => 1.38},
},
C_support => {
description => "Compile/link C & XS code",
Modified: Module-Build/trunk/Changes
==============================================================================
--- Module-Build/trunk/Changes (original)
+++ Module-Build/trunk/Changes Thu Sep 10 22:47:17 2009
@@ -2,6 +2,15 @@
0.35_03 -
+ *** API CHANGE ***
+ - The prepare_metadata() method used to take a YAML::Node object as an
+ argument for modification. The method now takes no arguments and just
+ returns a hash reference of metadata. [David Golden]
+
+ Other:
+ - Replaced use of YAML.pm with YAML::Tiny; Module::Build::YAML is now
+ based on YAML::Tiny as well [David Golden]
+
0.35_02 - Mon Sep 7 22:37:42 EDT 2009
Enhancements:
Added: Module-Build/trunk/devtools/update_yamltiny.pl
==============================================================================
--- (empty file)
+++ Module-Build/trunk/devtools/update_yamltiny.pl Thu Sep 10 22:47:17 2009
@@ -0,0 +1,37 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+
+use Path::Class;
+require YAML::Tiny;
+require PPI;
+require PPI::Dumper;
+
+my $Doc = PPI::Document->new($INC{'YAML/Tiny.pm'});
+$Doc->prune('PPI::Token::Pod');
+$Doc->prune( sub {
+ $_[1]->isa('PPI::Statement')
+ && $_[1]->first_element->isa('PPI::Token::Symbol')
+ && $_[1]->first_element->symbol =~ /EXPORT|ISA/
+ }
+);
+$Doc->prune( sub {
+ $_[1]->isa('PPI::Statement::Include')
+ && $_[1]->child(2)->isa('PPI::Token::Word')
+ && $_[1]->child(2)->content eq 'Exporter'
+ }
+);
+
+#my $Dumper = PPI::Dumper->new( $Doc );
+#$Dumper->print;
+
+my $content = $Doc->serialize;
+$content =~ s{YAML::Tiny}{Module::Build::YAML}g;
+$content = "# Adapted from YAML::Tiny " . YAML::Tiny->VERSION . "\n$content";
+$content =~ s{^\s+\n(\s+\n)+}{\n}gms;
+
+my $mby = file(qw/lib Module Build YAML.pm/);
+die "Can't find $mby" unless -e $mby;
+my $fh = $mby->openw;
+print {$fh} $content;
+
Modified: Module-Build/trunk/lib/Module/Build.pm
==============================================================================
--- Module-Build/trunk/lib/Module/Build.pm (original)
+++ Module-Build/trunk/lib/Module/Build.pm Thu Sep 10 22:47:17 2009
@@ -337,8 +337,8 @@
distribution. The metadata includes the distribution name, version,
abstract, prerequisites, license, and various other data about the
distribution. This file is created as F<META.yml> in YAML format.
-It is recommended that the C<YAML> module be installed to create it.
-If the C<YAML> module is not installed, an internal module supplied
+It is recommended that the C<YAML::Tiny> module be installed to create it.
+If the C<YAML::Tiny> module is not installed, an internal module supplied
with Module::Build will be used to write the META.yml file, and this
will most likely be fine.
@@ -1097,7 +1097,7 @@
=head1 SEE ALSO
perl(1), L<Module::Build::Cookbook>, L<Module::Build::Authoring>,
-L<Module::Build::API>, L<ExtUtils::MakeMaker>, L<YAML>
+L<Module::Build::API>, L<ExtUtils::MakeMaker>, L<YAML::Tiny>
F<META.yml> Specification:
L<http://module-build.sourceforge.net/META-spec-current.html>
Modified: Module-Build/trunk/lib/Module/Build/API.pod
==============================================================================
--- Module-Build/trunk/lib/Module/Build/API.pod (original)
+++ Module-Build/trunk/lib/Module/Build/API.pod Thu Sep 10 22:47:17 2009
@@ -1566,22 +1566,25 @@
=item prepare_metadata()
-[version 0.28]
+[version 0.36]
-This method is provided for authors to override to customize the
-fields of F<META.yml>. It is passed a YAML::Node node object which can
-be modified as desired and then returned. E.g.
+This method returns a hash reference of metadata that can be used to create a
+YAML datastream. It is provided for authors to override or customize the fields
+of F<META.yml>. E.g.
package My::Builder;
use base 'Module::Build';
sub prepare_metadata {
my $self = shift;
- my $node = $self->SUPER::prepare_metadata( shift );
- $node->{custom_field} = 'foo';
- return $node;
+ my $data = $self->SUPER::prepare_metadata();
+ $data->{custom_field} = 'foo';
+ return $data;
}
+Prior to version 0.36, this method took a YAML::Node as an argument to hold
+assembled metadata.
+
=item prereq_failures()
[version 0.11]
@@ -1847,7 +1850,7 @@
=head1 SEE ALSO
perl(1), L<Module::Build>(3), L<Module::Build::Authoring>(3),
-L<Module::Build::Cookbook>(3), L<ExtUtils::MakeMaker>(3), L<YAML>(3)
+L<Module::Build::Cookbook>(3), L<ExtUtils::MakeMaker>(3), L<YAML::Tiny>(3)
F<META.yml> Specification:
L<http://module-build.sourceforge.net/META-spec-current.html>
Modified: Module-Build/trunk/lib/Module/Build/Base.pm
==============================================================================
--- Module-Build/trunk/lib/Module/Build/Base.pm (original)
+++ Module-Build/trunk/lib/Module/Build/Base.pm Thu Sep 10 22:47:17 2009
@@ -1601,7 +1601,7 @@
$self->log_info("Removed previous '$mymetafile'\n");
}
$self->log_info("Creating new '$mymetafile' with configuration results\n");
- if ( $self->write_metafile( $mymetafile, $self->generate_metadata ) ) {
+ if ( $self->write_metafile( $mymetafile, $self->prepare_metadata ) ) {
$self->add_to_cleanup( $mymetafile );
}
@@ -3907,7 +3907,7 @@
push @INC, File::Spec->catdir($self->blib, 'lib');
}
- if ( $self->write_metafile( $self->metafile, $self->generate_metadata ) ) {
+ if ( $self->write_metafile( $self->metafile, $self->prepare_metadata ) ) {
$self->{wrote_metadata} = 1;
$self->_add_to_manifest('MANIFEST', $metafile);
}
@@ -3915,42 +3915,22 @@
return 1;
}
-sub generate_metadata {
- my $self = shift;
- my $node = {};
-
- if ($self->_mb_feature('YAML_support')) {
- require YAML;
- require YAML::Node;
- # We use YAML::Node to get the order nice in the YAML file.
- $self->prepare_metadata( $node = YAML::Node->new({}) );
- } else {
- require Module::Build::YAML;
- my @order_keys;
- $self->prepare_metadata($node, \...@order_keys);
- $node->{_order} = \...@order_keys;
- }
- return $node;
-}
-
sub write_metafile {
my $self = shift;
my ($metafile, $node) = @_;
+ my $yaml;
if ($self->_mb_feature('YAML_support')) {
# XXX this is probably redundant, but stick with it
- require YAML;
- require YAML::Node;
- delete $node->{_order}; # XXX also probably redundant, but for safety
- # YAML API changed after version 0.30
- my $yaml_sub = $YAML::VERSION le '0.30' ? \&YAML::StoreFile :
\&YAML::DumpFile;
- $yaml_sub->( $metafile, $node );
+ require YAML::Tiny;
+ $yaml = YAML::Tiny->new($node);
} else {
- # XXX probably redundant
require Module::Build::YAML;
- &Module::Build::YAML::DumpFile($metafile, $node);
+ $yaml = Module::Build::YAML->new($node);
}
- return 1;
+ my $result = $yaml->write($metafile)
+ or $self->log_warn( "Error writing '$metafile': " . $yaml->errstr . "\n");
+ return $result;
}
sub normalize_version {
@@ -3973,14 +3953,14 @@
}
sub prepare_metadata {
- my ($self, $node, $keys) = @_;
+ my ($self) = @_;
my $p = $self->{properties};
+ my $node = {};
# A little helper sub
my $add_node = sub {
my ($name, $val) = @_;
$node->{$name} = $val;
- push @$keys, $name if $keys;
};
foreach (qw(dist_name dist_version dist_author dist_abstract license)) {
Modified: Module-Build/trunk/lib/Module/Build/YAML.pm
==============================================================================
--- Module-Build/trunk/lib/Module/Build/YAML.pm (original)
+++ Module-Build/trunk/lib/Module/Build/YAML.pm Thu Sep 10 22:47:17 2009
@@ -1,162 +1,600 @@
+# Adapted from YAML::Tiny 1.40
package Module::Build::YAML;
use strict;
-use Config;
-use vars qw($VERSION @EXPORT @EXPORT_OK);
-$VERSION = "0.50";
-...@export = ();
-...@export_ok = qw(Dump Load DumpFile LoadFile);
+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 $this = shift;
- my $class = ref($this) || $this;
- my $self = {};
- bless $self, $class;
- return($self);
+ my $class = shift;
+ bless [ @_ ], $class;
}
-sub Dump {
- shift if ($_[0] eq __PACKAGE__ || ref($_[0]) eq __PACKAGE__);
- my $yaml = "";
- foreach my $item (@_) {
- $yaml .= "---\n";
- $yaml .= &_yaml_chunk("", $item);
- }
- return $yaml;
+# 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 );
}
-sub Load {
- shift if ($_[0] eq __PACKAGE__ || ref($_[0]) eq __PACKAGE__);
- die "not yet implemented";
+# 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;
}
-# This is basically copied out of YAML.pm and simplified a little.
-sub DumpFile {
- shift if ($_[0] eq __PACKAGE__ || ref($_[0]) eq __PACKAGE__);
- my $filename = shift;
- local $/ = "\n"; # reset special to "sane"
- my $mode = '>';
- if ($filename =~ /^\s*(>{1,2})\s*(.*)$/) {
- ($mode, $filename) = ($1, $2);
- }
- open my $OUT, "$mode $filename"
- or die "Can't open $filename for writing: $!";
- binmode($OUT, ':utf8') if $] >= 5.008 && $Config{useperlio};
- print $OUT Dump(@_);
- close $OUT;
+# 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;
}
-# This is basically copied out of YAML.pm and simplified a little.
-sub LoadFile {
- shift if ($_[0] eq __PACKAGE__ || ref($_[0]) eq __PACKAGE__);
- my $filename = shift;
- open my $IN, $filename
- or die "Can't open $filename for reading: $!";
- binmode($IN, ':utf8') if $] >= 5.008 && $Config{useperlio};
- return Load(do { local $/; <$IN> });
- close $IN;
-}
-
-sub _yaml_chunk {
- my ($indent, $values) = @_;
- my $yaml_chunk = "";
- my $ref = ref($values);
- my ($value, @allkeys, %keyseen);
- if (!$ref) { # a scalar
- $yaml_chunk .= &_yaml_value($values) . "\n";
- }
- elsif ($ref eq "ARRAY") {
- foreach $value (@$values) {
- $yaml_chunk .= "$indent-";
- $ref = ref($value);
- if (!$ref) {
- $yaml_chunk .= " " . &_yaml_value($value) . "\n";
- }
- else {
- $yaml_chunk .= "\n";
- $yaml_chunk .= &_yaml_chunk("$indent ", $value);
- }
- }
- }
- else { # assume "HASH"
- if ($values->{_order} && ref($values->{_order}) eq "ARRAY") {
- @allkeys = @{$values->{_order}};
- $values = { %$values };
- delete $values->{_order};
- }
- push(@allkeys, sort keys %$values);
- foreach my $key (@allkeys) {
- next if (!defined $key || $key eq "" || $keyseen{$key});
- $keyseen{$key} = 1;
- $yaml_chunk .= "$indent$key:";
- $value = $values->{$key};
- $ref = ref($value);
- if (!$ref) {
- $yaml_chunk .= " " . &_yaml_value($value) . "\n";
- }
- else {
- $yaml_chunk .= "\n";
- $yaml_chunk .= &_yaml_chunk("$indent ", $value);
- }
- }
- }
- return($yaml_chunk);
-}
-
-sub _yaml_value {
- my ($value) = @_;
- # undefs become ~
- return '~' if not defined $value;
-
- # empty strings will become empty strings
- return '""' if $value eq '';
-
- # allow simple scalars (without embedded quote chars) to be unquoted
- # (includes $%_+=-\;:,./)
- return $value if $value !~ /["'`~\...@\#^\&\*\(\)\{\}\[\]\|<>\?]/;
-
- # quote and escape strings with special values
- return "'$value'"
- if $value !~ /['`~\n!\#^\&\*\(\)\{\}\[\]\|\?]/; # nothing but " or @ or <
or > (email addresses)
-
- $value =~ s/\n/\\n/g; # handle embedded newlines
- $value =~ s/"/\\"/g; # handle embedded quotes
- return qq{"$value"};
+# 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;
}
-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 );
+ }
+ }
+ }
+ }
-__END__
+ return 1;
+}
-=head1 NAME
+# 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;
-Module::Build::YAML - Provides just enough YAML support so that Module::Build
works even if YAML.pm is not installed
+ return 1;
+}
-=head1 SYNOPSIS
+# 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));
+ }
+ }
- use Module::Build::YAML;
+ 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;
+}
-=head1 DESCRIPTION
+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";
+ }
+ }
-Provides just enough YAML support so that Module::Build works even if YAML.pm
is not installed.
+ @lines;
+}
-Currently, this amounts to the ability to write META.yml files when C<perl
Build distmeta>
-is executed via the Dump() and DumpFile() functions/methods.
+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";
+ }
+ }
-=head1 AUTHOR
+ @lines;
+}
-Stephen Adkins <[email protected]>
+# Set error
+sub _error {
+ $Module::Build::YAML::errstr = $_[1];
+ undef;
+}
-=head1 COPYRIGHT
+# 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;
+}
-Copyright (c) 2006. Stephen Adkins. All rights reserved.
+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];
+ }
+}
-This program is free software; you can redistribute it and/or modify it
-under the same terms as Perl itself.
+#####################################################################
+# Use Scalar::Util if possible, otherwise emulate it
-See L<http://www.perl.com/perl/misc/Artistic.html>
+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');
+ }
+}
-=cut
+1;
+
+__END__
Modified: Module-Build/trunk/t/extend.t
==============================================================================
--- Module-Build/trunk/t/extend.t (original)
+++ Module-Build/trunk/t/extend.t Thu Sep 10 22:47:17 2009
@@ -186,21 +186,20 @@
meta_add => {foo => 'bar'},
conflicts => {'Foo::Barxx' => 0},
);
- my %data;
- $mb->prepare_metadata( \%data );
- is $data{foo}, 'bar';
+ my $data = $mb->prepare_metadata;
+ is $data->{foo}, 'bar';
$mb->meta_merge(foo => 'baz');
- $mb->prepare_metadata( \%data );
- is $data{foo}, 'baz';
+ $data = $mb->prepare_metadata;
+ is $data->{foo}, 'baz';
$mb->meta_merge(conflicts => {'Foo::Fooxx' => 0});
- $mb->prepare_metadata( \%data );
- is_deeply $data{conflicts}, {'Foo::Barxx' => 0, 'Foo::Fooxx' => 0};
+ $data = $mb->prepare_metadata;
+ is_deeply $data->{conflicts}, {'Foo::Barxx' => 0, 'Foo::Fooxx' => 0};
$mb->meta_add(conflicts => {'Foo::Bazxx' => 0});
- $mb->prepare_metadata( \%data );
- is_deeply $data{conflicts}, {'Foo::Bazxx' => 0, 'Foo::Fooxx' => 0};
+ $data = $mb->prepare_metadata;
+ is_deeply $data->{conflicts}, {'Foo::Bazxx' => 0, 'Foo::Fooxx' => 0};
}
{
