@@ -1,4 +1,17 @@
---
+version: 0.55
+date: Sun Jan 29 19:03:35 PST 2006
+change:
+- Load YAML::Node because Module::Build expects it to be loaded.
+ We can undo this when Module::Build starts loading it for itself.
+
+---
+version: 0.54
+date: Sun Jan 29 17:28:46 PST 2006
+change:
+- Remove dependency on Class::Spiffy (and/or Spiffy).
+
+---
version: 0.53
date: Thu Jan 19 06:03:17 PST 2006
change:
@@ -3,11 +3,14 @@ inc/Module/Install.pm
inc/Module/Install/Base.pm
inc/Module/Install/Can.pm
inc/Module/Install/Fetch.pm
+inc/Module/Install/Include.pm
inc/Module/Install/Makefile.pm
inc/Module/Install/Metadata.pm
inc/Module/Install/Scripts.pm
inc/Module/Install/Win32.pm
inc/Module/Install/WriteAll.pm
+inc/Test/Base.pm
+inc/Test/Base/Filter.pm
lib/Test/YAML.pm
lib/YAML.pm
lib/YAML/Base.pm
@@ -25,6 +28,7 @@ MANIFEST This list of files
META.yml
README
t/2-scalars.t
+t/Base.pm
t/basic-tests.t
t/bugs-emailed.t
t/bugs-rt.t
@@ -58,5 +62,4 @@ t/svk-config.yaml
t/svk.t
t/test.t
t/TestYAML.pm
-ToDo
ysh
@@ -5,12 +5,12 @@ no_index:
- t
generated_by: Module::Install version 0.54
distribution_type: module
-version: 0.53
+version: 0.55
name: YAML
author: "Ingy d\xC3\xB6t Net <ingy@cpan.org>"
license: perl
-requires:
- Class::Spiffy: 0.12
+build_requires:
Test::Base: 0.47
+requires:
perl: 5.6.1
abstract: YAML Ain't Markup Language (tm)
@@ -5,8 +5,9 @@ all_from 'lib/YAML.pm';
license 'perl';
requires 'perl' => '5.6.1';
-requires 'Class::Spiffy' => '0.12';
-requires 'Test::Base' => '0.47';
+build_requires 'Test::Base' => '0.47';
+include 'Test::Base';
+include 'Test::Base::Filter';
install_script 'ysh';
@@ -1,82 +0,0 @@
-=== 0.53
-- Spiffy => Class::Spiffy
-- add use strict;
-- remove -Base
-- sub foo() { }
-- DumpFile is broken!?
-
-=== 0.51
-+ Don't sign the tarball
- + Just use new Module::Install
-- Fix audrey's bugs
-+ Fix windows issues
-+ Checkin inc
-- Add tests to YAML::Syck
-+ Skip Diff tests in Test::Base if modules not installed
- + Eliminate prereqs
-
-=== Testing for release
-= test on clean perl install
-- Test on 5.6.1
-- Test on ActivePerl
-- Test on Cygwin
-- Test on Solaris
-- Check Test::YAML for YAML::Syck
-
-=== 0.50 Checklist
-+ get stringify working
-+ move t/TestYAML.pm to lib/Test/YAML.pm
-+ review rt bugs
-+ Fix Makefile.PL: 'Cannot determine perl version info from lib/YAML.pm'
-+ review code base
-+ review mailing list bugs
-+ Add doc to all classes
-+ Test that we can load well known YAML files like:
- + svk
- + META.yml
-+ Eliminate unsafe string eval-s
-x Put YAML::Node in YAML::Base ?
-+ Move audrey's 'can' thingy into Spiffy
-+ Refactor references of 'family' to 'tag'
-+ Write YAML::Marshall
- + Test YAML::Marshall
- + Rewrite dumper/loader/transfers to use methods
-+ Refactor YAML::Transfer to YAML::Types
-x Make 'perl/' configurable with $YAML::TagPrefix
-x Don't ship with Spiffy -Base filtering. (use -base)
-+ Add test for undef/empty (::Syck to_scalar.t)
-+ Fix Test::Base for multiple levels of inheritance.
-+ Get audreyt patch for ysh
-+ Refactor test suite to use t::TestYAML (which use Test::YAML)
-+ Release Spiffy 0.25
-+ Release Test::Base 0.45
-
-=== Next release
-
-- Consider only supporting 5.8.3+
-- Get error messages and warnings displaying the correct line in the
- code from where they were invoked.
-- Write a module (Scalar::Info) to correctly grok scalar (ref) info
-- Support these perl types:
-
- !perl/X::Y blessed hash
- !perl/@X::Y blessed array
- !perl/$X::Y blessed string
- !perl/& code
- !perl/&X::Y blessed code
- !perl/* glob
- !perl/*X::Y blessed glob
- !perl/~ regexp
- !perl/~X::Y blessed regexp
- !perl/' reference
- !perl/'X::Y blessed reference
-
- !perl/$ scalar reference (for completeness sake)
- # no types for array ref or hash ref though
-
- !perl/xyz: random data structure 'xyz'
- !perl/xyz:X::Y blessed random data structure 'xyz'
-
-- Support UseVersion or remove it
-- Rethink the VALUE construct
-- Rework _emit_str heuristics
@@ -0,0 +1,10 @@
+#line 1 "inc/Module/Install/Include.pm - /Users/ingy/local/lib/perl5/site_perl/5.8.6/Module/Install/Include.pm"
+package Module::Install::Include;
+use Module::Install::Base; @ISA = qw(Module::Install::Base);
+
+sub include { +shift->admin->include(@_) };
+sub include_deps { +shift->admin->include_deps(@_) };
+sub auto_include { +shift->admin->auto_include(@_) };
+sub auto_include_deps { +shift->admin->auto_include_deps(@_) };
+sub auto_include_dependent_dists { +shift->admin->auto_include_dependent_dists(@_) }
+1;
@@ -0,0 +1,343 @@
+#line 1 "inc/Test/Base/Filter.pm - /Users/ingy/local/lib/perl5/site_perl/5.8.6/Test/Base/Filter.pm"
+#. TODO:
+#.
+
+#===============================================================================
+# This is the default class for handling Test::Base data filtering.
+#===============================================================================
+package Test::Base::Filter;
+use Spiffy -Base;
+use Spiffy ':XXX';
+
+field 'current_block';
+
+our $arguments;
+sub current_arguments {
+ return undef unless defined $arguments;
+ my $args = $arguments;
+ $args =~ s/(\\s)/ /g;
+ $args =~ s/(\\[a-z])/'"' . $1 . '"'/gee;
+ return $args;
+}
+
+sub assert_scalar {
+ return if @_ == 1;
+ require Carp;
+ my $filter = (caller(1))[3];
+ $filter =~ s/.*:://;
+ Carp::croak "Input to the '$filter' filter must be a scalar, not a list";
+}
+
+sub _apply_deepest {
+ my $method = shift;
+ return () unless @_;
+ if (ref $_[0] eq 'ARRAY') {
+ for my $aref (@_) {
+ @$aref = $self->_apply_deepest($method, @$aref);
+ }
+ return @_;
+ }
+ $self->$method(@_);
+}
+
+sub _split_array {
+ map {
+ [$self->split($_)];
+ } @_;
+}
+
+sub _peel_deepest {
+ return () unless @_;
+ if (ref $_[0] eq 'ARRAY') {
+ if (ref $_[0]->[0] eq 'ARRAY') {
+ for my $aref (@_) {
+ @$aref = $self->_peel_deepest(@$aref);
+ }
+ return @_;
+ }
+ return map { $_->[0] } @_;
+ }
+ return @_;
+}
+
+#===============================================================================
+# these filters work on the leaves of nested arrays
+#===============================================================================
+sub Join { $self->_peel_deepest($self->_apply_deepest(join => @_)) }
+sub Reverse { $self->_apply_deepest(reverse => @_) }
+sub Split { $self->_apply_deepest(_split_array => @_) }
+sub Sort { $self->_apply_deepest(sort => @_) }
+
+
+sub append {
+ my $suffix = $self->current_arguments;
+ map { $_ . $suffix } @_;
+}
+
+sub array {
+ return [@_];
+}
+
+sub base64_decode {
+ $self->assert_scalar(@_);
+ require MIME::Base64;
+ MIME::Base64::decode_base64(shift);
+}
+
+sub base64_encode {
+ $self->assert_scalar(@_);
+ require MIME::Base64;
+ MIME::Base64::encode_base64(shift);
+}
+
+sub chomp {
+ map { CORE::chomp; $_ } @_;
+}
+
+sub chop {
+ map { CORE::chop; $_ } @_;
+}
+
+sub dumper {
+ no warnings 'once';
+ require Data::Dumper;
+ local $Data::Dumper::Sortkeys = 1;
+ local $Data::Dumper::Indent = 1;
+ local $Data::Dumper::Terse = 1;
+ Data::Dumper::Dumper(@_);
+}
+
+sub escape {
+ $self->assert_scalar(@_);
+ my $text = shift;
+ $text =~ s/(\\.)/eval "qq{$1}"/ge;
+ return $text;
+}
+
+sub eval {
+ $self->assert_scalar(@_);
+ my @return = CORE::eval(shift);
+ return $@ if $@;
+ return @return;
+}
+
+sub eval_all {
+ $self->assert_scalar(@_);
+ my $out = '';
+ my $err = '';
+ Test::Base::tie_output(*STDOUT, $out);
+ Test::Base::tie_output(*STDERR, $err);
+ my $return = CORE::eval(shift);
+ no warnings;
+ untie *STDOUT;
+ untie *STDERR;
+ return $return, $@, $out, $err;
+}
+
+sub eval_stderr {
+ $self->assert_scalar(@_);
+ my $output = '';
+ Test::Base::tie_output(*STDERR, $output);
+ CORE::eval(shift);
+ no warnings;
+ untie *STDERR;
+ return $output;
+}
+
+sub eval_stdout {
+ $self->assert_scalar(@_);
+ my $output = '';
+ Test::Base::tie_output(*STDOUT, $output);
+ CORE::eval(shift);
+ no warnings;
+ untie *STDOUT;
+ return $output;
+}
+
+sub exec_perl_stdout {
+ my $tmpfile = "/tmp/test-blocks-$$";
+ $self->_write_to($tmpfile, @_);
+ open my $execution, "$^X $tmpfile 2>&1 |"
+ or die "Couldn't open subprocess: $!\n";
+ local $/;
+ my $output = <$execution>;
+ close $execution;
+ unlink($tmpfile)
+ or die "Couldn't unlink $tmpfile: $!\n";
+ return $output;
+}
+
+sub flatten {
+ $self->assert_scalar(@_);
+ my $ref = shift;
+ if (ref($ref) eq 'HASH') {
+ return map {
+ ($_, $ref->{$_});
+ } sort keys %$ref;
+ }
+ if (ref($ref) eq 'ARRAY') {
+ return @$ref;
+ }
+ die "Can only flatten a hash or array ref";
+}
+
+sub get_url {
+ $self->assert_scalar(@_);
+ my $url = shift;
+ CORE::chomp($url);
+ require LWP::Simple;
+ LWP::Simple::get($url);
+}
+
+sub hash {
+ return +{ @_ };
+}
+
+sub head {
+ my $size = $self->current_arguments || 1;
+ return splice(@_, 0, $size);
+}
+
+sub join {
+ my $string = $self->current_arguments;
+ $string = '' unless defined $string;
+ CORE::join $string, @_;
+}
+
+sub lines {
+ $self->assert_scalar(@_);
+ my $text = shift;
+ return () unless length $text;
+ my @lines = ($text =~ /^(.*\n?)/gm);
+ return @lines;
+}
+
+sub norm {
+ $self->assert_scalar(@_);
+ my $text = shift || '';
+ $text =~ s/\015\012/\n/g;
+ $text =~ s/\r/\n/g;
+ return $text;
+}
+
+sub prepend {
+ my $prefix = $self->current_arguments;
+ map { $prefix . $_ } @_;
+}
+
+sub read_file {
+ $self->assert_scalar(@_);
+ my $file = shift;
+ CORE::chomp $file;
+ open my $fh, $file
+ or die "Can't open '$file' for input:\n$!";
+ CORE::join '', <$fh>;
+}
+
+sub regexp {
+ $self->assert_scalar(@_);
+ my $text = shift;
+ my $flags = $self->current_arguments;
+ if ($text =~ /\n.*?\n/s) {
+ $flags = 'xism'
+ unless defined $flags;
+ }
+ else {
+ CORE::chomp($text);
+ }
+ $flags ||= '';
+ my $regexp = eval "qr{$text}$flags";
+ die $@ if $@;
+ return $regexp;
+}
+
+sub reverse {
+ CORE::reverse(@_);
+}
+
+sub slice {
+ die "Invalid args for slice"
+ unless $self->current_arguments =~ /^(\d+)(?:,(\d))?$/;
+ my ($x, $y) = ($1, $2);
+ $y = $x if not defined $y;
+ die "Invalid args for slice"
+ if $x > $y;
+ return splice(@_, $x, 1 + $y - $x);
+}
+
+sub sort {
+ CORE::sort(@_);
+}
+
+sub split {
+ $self->assert_scalar(@_);
+ my $separator = $self->current_arguments;
+ if (defined $separator and $separator =~ s{^/(.*)/$}{$1}) {
+ my $regexp = $1;
+ $separator = qr{$regexp};
+ }
+ $separator = qr/\s+/ unless $separator;
+ CORE::split $separator, shift;
+}
+
+sub strict {
+ $self->assert_scalar(@_);
+ <<'...' . shift;
+use strict;
+use warnings;
+...
+}
+
+sub tail {
+ my $size = $self->current_arguments || 1;
+ return splice(@_, @_ - $size, $size);
+}
+
+sub trim {
+ map {
+ s/\A([ \t]*\n)+//;
+ s/(?<=\n)\s*\z//g;
+ $_;
+ } @_;
+}
+
+sub unchomp {
+ map { $_ . "\n" } @_;
+}
+
+sub write_file {
+ my $file = $self->current_arguments
+ or die "No file specified for write_file filter";
+ if ($file =~ /(.*)[\\\/]/) {
+ my $dir = $1;
+ if (not -e $dir) {
+ require File::Path;
+ File::Path::mkpath($dir)
+ or die "Can't create $dir";
+ }
+ }
+ open my $fh, ">$file"
+ or die "Can't open '$file' for output\n:$!";
+ print $fh @_;
+ close $fh;
+ return $file;
+}
+
+sub yaml {
+ $self->assert_scalar(@_);
+ require YAML;
+ return YAML::Load(shift);
+}
+
+sub _write_to {
+ my $filename = shift;
+ open my $script, ">$filename"
+ or die "Couldn't open $filename: $!\n";
+ print $script @_;
+ close $script
+ or die "Couldn't close $filename: $!\n";
+}
+
+__DATA__
+
+#line 638
@@ -0,0 +1,630 @@
+#line 1 "inc/Test/Base.pm - /Users/ingy/local/lib/perl5/site_perl/5.8.6/Test/Base.pm"
+# TODO:
+#
+package Test::Base;
+use 5.006001;
+use Spiffy 0.29 -Base;
+use Spiffy ':XXX';
+our $VERSION = '0.47';
+
+my @test_more_exports;
+BEGIN {
+ @test_more_exports = qw(
+ ok isnt like unlike is_deeply cmp_ok
+ skip todo_skip pass fail
+ eq_array eq_hash eq_set
+ plan can_ok isa_ok diag
+ $TODO
+ );
+}
+use Test::More import => \@test_more_exports;
+use Carp;
+
+our @EXPORT = (@test_more_exports, qw(
+ is no_diff
+
+ blocks next_block first_block
+ delimiters spec_file spec_string
+ filters filters_delay filter_arguments
+ run run_compare run_is run_is_deeply run_like run_unlike
+ WWW XXX YYY ZZZ
+ tie_output
+
+ find_my_self default_object
+
+ croak carp cluck confess
+));
+
+field '_spec_file';
+field '_spec_string';
+field _filters => [qw(norm trim)];
+field _filters_map => {};
+field spec =>
+ -init => '$self->_spec_init';
+field block_list =>
+ -init => '$self->_block_list_init';
+field _next_list => [];
+field block_delim =>
+ -init => '$self->block_delim_default';
+field data_delim =>
+ -init => '$self->data_delim_default';
+field _filters_delay => 0;
+
+field block_delim_default => '===';
+field data_delim_default => '---';
+
+my $default_class;
+my $default_object;
+my $reserved_section_names = {};
+
+sub default_object {
+ $default_object ||= $default_class->new;
+ return $default_object;
+}
+
+my $import_called = 0;
+sub import() {
+ $import_called = 1;
+ my $class = (grep /^-base$/i, @_)
+ ? scalar(caller)
+ : $_[0];
+ if (not defined $default_class) {
+ $default_class = $class;
+ }
+# else {
+# croak "Can't use $class after using $default_class"
+# unless $default_class->isa($class);
+# }
+
+ if (@_ > 1 and not grep /^-base$/i, @_) {
+ my @args = @_;
+ shift @args;
+ Test::More->import(import => \@test_more_exports, @args);
+ }
+
+ _strict_warnings();
+ goto &Spiffy::import;
+}
+
+# Wrap Test::Builder::plan
+my $plan_code = \&Test::Builder::plan;
+my $Have_Plan = 0;
+{
+ no warnings 'redefine';
+ *Test::Builder::plan = sub {
+ $Have_Plan = 1;
+ goto &$plan_code;
+ };
+}
+
+my $DIED = 0;
+$SIG{__DIE__} = sub { $DIED = 1; die @_ };
+
+sub block_class { $self->find_class('Block') }
+sub filter_class { $self->find_class('Filter') }
+
+sub find_class {
+ my $suffix = shift;
+ my $class = ref($self) . "::$suffix";
+ return $class if $class->can('new');
+ $class = __PACKAGE__ . "::$suffix";
+ return $class if $class->can('new');
+ eval "require $class";
+ return $class if $class->can('new');
+ die "Can't find a class for $suffix";
+}
+
+sub check_late {
+ if ($self->{block_list}) {
+ my $caller = (caller(1))[3];
+ $caller =~ s/.*:://;
+ croak "Too late to call $caller()"
+ }
+}
+
+sub find_my_self() {
+ my $self = ref($_[0]) eq $default_class
+ ? splice(@_, 0, 1)
+ : default_object();
+ return $self, @_;
+}
+
+sub blocks() {
+ (my ($self), @_) = find_my_self(@_);
+
+ croak "Invalid arguments passed to 'blocks'"
+ if @_ > 1;
+ croak sprintf("'%s' is invalid argument to blocks()", shift(@_))
+ if @_ && $_[0] !~ /^[a-zA-Z]\w*$/;
+
+ my $blocks = $self->block_list;
+
+ my $section_name = shift || '';
+ my @blocks = $section_name
+ ? (grep { exists $_->{$section_name} } @$blocks)
+ : (@$blocks);
+
+ return scalar(@blocks) unless wantarray;
+
+ return (@blocks) if $self->_filters_delay;
+
+ for my $block (@blocks) {
+ $block->run_filters
+ unless $block->is_filtered;
+ }
+
+ return (@blocks);
+}
+
+sub next_block() {
+ (my ($self), @_) = find_my_self(@_);
+ my $list = $self->_next_list;
+ if (@$list == 0) {
+ $list = [@{$self->block_list}, undef];
+ $self->_next_list($list);
+ }
+ my $block = shift @$list;
+ if (defined $block and not $block->is_filtered) {
+ $block->run_filters;
+ }
+ return $block;
+}
+
+sub first_block() {
+ (my ($self), @_) = find_my_self(@_);
+ $self->_next_list([]);
+ $self->next_block;
+}
+
+sub filters_delay() {
+ (my ($self), @_) = find_my_self(@_);
+ $self->_filters_delay(defined $_[0] ? shift : 1);
+}
+
+sub delimiters() {
+ (my ($self), @_) = find_my_self(@_);
+ $self->check_late;
+ my ($block_delimiter, $data_delimiter) = @_;
+ $block_delimiter ||= $self->block_delim_default;
+ $data_delimiter ||= $self->data_delim_default;
+ $self->block_delim($block_delimiter);
+ $self->data_delim($data_delimiter);
+ return $self;
+}
+
+sub spec_file() {
+ (my ($self), @_) = find_my_self(@_);
+ $self->check_late;
+ $self->_spec_file(shift);
+ return $self;
+}
+
+sub spec_string() {
+ (my ($self), @_) = find_my_self(@_);
+ $self->check_late;
+ $self->_spec_string(shift);
+ return $self;
+}
+
+sub filters() {
+ (my ($self), @_) = find_my_self(@_);
+ if (ref($_[0]) eq 'HASH') {
+ $self->_filters_map(shift);
+ }
+ else {
+ my $filters = $self->_filters;
+ push @$filters, @_;
+ }
+ return $self;
+}
+
+sub filter_arguments() {
+ $Test::Base::Filter::arguments;
+}
+
+sub have_text_diff {
+ eval { require Text::Diff; 1 } &&
+ $Text::Diff::VERSION >= 0.35 &&
+ $Algorithm::Diff::VERSION >= 1.15;
+}
+
+sub is($$;$) {
+ (my ($self), @_) = find_my_self(@_);
+ my ($actual, $expected, $name) = @_;
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+ if ($ENV{TEST_SHOW_NO_DIFFS} or
+ not defined $actual or
+ not defined $expected or
+ $actual eq $expected or
+ not($self->have_text_diff) or
+ $expected !~ /\n./s
+ ) {
+ Test::More::is($actual, $expected, $name);
+ }
+ else {
+ $name = '' unless defined $name;
+ ok $actual eq $expected,
+ $name . "\n" . Text::Diff::diff(\$expected, \$actual);
+ }
+}
+
+sub run(&;$) {
+ (my ($self), @_) = find_my_self(@_);
+ my $callback = shift;
+ for my $block (@{$self->block_list}) {
+ $block->run_filters unless $block->is_filtered;
+ &{$callback}($block);
+ }
+}
+
+my $name_error = "Can't determine section names";
+sub _section_names {
+ return @_ if @_ == 2;
+ my $block = $self->first_block
+ or croak $name_error;
+ my @names = grep {
+ $_ !~ /^(ONLY|LAST|SKIP)$/;
+ } @{$block->{_section_order}[0] || []};
+ croak "$name_error. Need two sections in first block"
+ unless @names == 2;
+ return @names;
+}
+
+sub _assert_plan {
+ plan('no_plan') unless $Have_Plan;
+}
+
+sub END {
+ run_compare() unless $Have_Plan or $DIED or not $import_called;
+}
+
+sub run_compare() {
+ (my ($self), @_) = find_my_self(@_);
+ $self->_assert_plan;
+ my ($x, $y) = $self->_section_names(@_);
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+ for my $block (@{$self->block_list}) {
+ next unless exists($block->{$x}) and exists($block->{$y});
+ $block->run_filters unless $block->is_filtered;
+ if (ref $block->$x) {
+ is_deeply($block->$x, $block->$y,
+ $block->name ? $block->name : ());
+ }
+ elsif (ref $block->$y eq 'Regexp') {
+ my $regexp = ref $y ? $y : $block->$y;
+ like($block->$x, $regexp, $block->name ? $block->name : ());
+ }
+ else {
+ is($block->$x, $block->$y, $block->name ? $block->name : ());
+ }
+ }
+}
+
+sub run_is() {
+ (my ($self), @_) = find_my_self(@_);
+ $self->_assert_plan;
+ my ($x, $y) = $self->_section_names(@_);
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+ for my $block (@{$self->block_list}) {
+ next unless exists($block->{$x}) and exists($block->{$y});
+ $block->run_filters unless $block->is_filtered;
+ is($block->$x, $block->$y,
+ $block->name ? $block->name : ()
+ );
+ }
+}
+
+sub run_is_deeply() {
+ (my ($self), @_) = find_my_self(@_);
+ $self->_assert_plan;
+ my ($x, $y) = $self->_section_names(@_);
+ for my $block (@{$self->block_list}) {
+ next unless exists($block->{$x}) and exists($block->{$y});
+ $block->run_filters unless $block->is_filtered;
+ is_deeply($block->$x, $block->$y,
+ $block->name ? $block->name : ()
+ );
+ }
+}
+
+sub run_like() {
+ (my ($self), @_) = find_my_self(@_);
+ $self->_assert_plan;
+ my ($x, $y) = $self->_section_names(@_);
+ for my $block (@{$self->block_list}) {
+ next unless exists($block->{$x}) and defined($y);
+ $block->run_filters unless $block->is_filtered;
+ my $regexp = ref $y ? $y : $block->$y;
+ like($block->$x, $regexp,
+ $block->name ? $block->name : ()
+ );
+ }
+}
+
+sub run_unlike() {
+ (my ($self), @_) = find_my_self(@_);
+ $self->_assert_plan;
+ my ($x, $y) = $self->_section_names(@_);
+ for my $block (@{$self->block_list}) {
+ next unless exists($block->{$x}) and defined($y);
+ $block->run_filters unless $block->is_filtered;
+ my $regexp = ref $y ? $y : $block->$y;
+ unlike($block->$x, $regexp,
+ $block->name ? $block->name : ()
+ );
+ }
+}
+
+sub _pre_eval {
+ my $spec = shift;
+ return $spec unless $spec =~
+ s/\A\s*<<<(.*?)>>>\s*$//sm;
+ my $eval_code = $1;
+ eval "package main; $eval_code";
+ croak $@ if $@;
+ return $spec;
+}
+
+sub _block_list_init {
+ my $spec = $self->spec;
+ $spec = $self->_pre_eval($spec);
+ my $cd = $self->block_delim;
+ my @hunks = ($spec =~ /^(\Q${cd}\E.*?(?=^\Q${cd}\E|\z))/msg);
+ my $blocks = $self->_choose_blocks(@hunks);
+ $self->block_list($blocks); # Need to set early for possible filter use
+ my $seq = 1;
+ for my $block (@$blocks) {
+ $block->blocks_object($self);
+ $block->seq_num($seq++);
+ }
+ return $blocks;
+}
+
+sub _choose_blocks {
+ my $blocks = [];
+ for my $hunk (@_) {
+ my $block = $self->_make_block($hunk);
+ if (exists $block->{ONLY}) {
+ return [$block];
+ }
+ next if exists $block->{SKIP};
+ push @$blocks, $block;
+ if (exists $block->{LAST}) {
+ return $blocks;
+ }
+ }
+ return $blocks;
+}
+
+sub _check_reserved {
+ my $id = shift;
+ croak "'$id' is a reserved name. Use something else.\n"
+ if $reserved_section_names->{$id} or
+ $id =~ /^_/;
+}
+
+sub _make_block {
+ my $hunk = shift;
+ my $cd = $self->block_delim;
+ my $dd = $self->data_delim;
+ my $block = $self->block_class->new;
+ $hunk =~ s/\A\Q${cd}\E[ \t]*(.*)\s+// or die;
+ my $name = $1;
+ my @parts = split /^\Q${dd}\E +\(?(\w+)\)? *(.*)?\n/m, $hunk;
+ my $description = shift @parts;
+ $description ||= '';
+ unless ($description =~ /\S/) {
+ $description = $name;
+ }
+ $description =~ s/\s*\z//;
+ $block->set_value(description => $description);
+
+ my $section_map = {};
+ my $section_order = [];
+ while (@parts) {
+ my ($type, $filters, $value) = splice(@parts, 0, 3);
+ $self->_check_reserved($type);
+ $value = '' unless defined $value;
+ $filters = '' unless defined $filters;
+ if ($filters =~ /:(\s|\z)/) {
+ croak "Extra lines not allowed in '$type' section"
+ if $value =~ /\S/;
+ ($filters, $value) = split /\s*:(?:\s+|\z)/, $filters, 2;
+ $value = '' unless defined $value;
+ $value =~ s/^\s*(.*?)\s*$/$1/;
+ }
+ $section_map->{$type} = {
+ filters => $filters,
+ };
+ push @$section_order, $type;
+ $block->set_value($type, $value);
+ }
+ $block->set_value(name => $name);
+ $block->set_value(_section_map => $section_map);
+ $block->set_value(_section_order => $section_order);
+ return $block;
+}
+
+sub _spec_init {
+ return $self->_spec_string
+ if $self->_spec_string;
+ local $/;
+ my $spec;
+ if (my $spec_file = $self->_spec_file) {
+ open FILE, $spec_file or die $!;
+ $spec = <FILE>;
+ close FILE;
+ }
+ else {
+ $spec = do {
+ package main;
+ no warnings 'once';
+ <DATA>;
+ };
+ }
+ return $spec;
+}
+
+sub _strict_warnings() {
+ require Filter::Util::Call;
+ my $done = 0;
+ Filter::Util::Call::filter_add(
+ sub {
+ return 0 if $done;
+ my ($data, $end) = ('', '');
+ while (my $status = Filter::Util::Call::filter_read()) {
+ return $status if $status < 0;
+ if (/^__(?:END|DATA)__\r?$/) {
+ $end = $_;
+ last;
+ }
+ $data .= $_;
+ $_ = '';
+ }
+ $_ = "use strict;use warnings;$data$end";
+ $done = 1;
+ }
+ );
+}
+
+sub tie_output() {
+ my $handle = shift;
+ die "No buffer to tie" unless @_;
+ tie $handle, 'Test::Base::Handle', $_[0];
+}
+
+sub no_diff {
+ $ENV{TEST_SHOW_NO_DIFFS} = 1;
+}
+
+package Test::Base::Handle;
+
+sub TIEHANDLE() {
+ my $class = shift;
+ bless \ $_[0], $class;
+}
+
+sub PRINT {
+ $$self .= $_ for @_;
+}
+
+#===============================================================================
+# Test::Base::Block
+#
+# This is the default class for accessing a Test::Base block object.
+#===============================================================================
+package Test::Base::Block;
+our @ISA = qw(Spiffy);
+
+our @EXPORT = qw(block_accessor);
+
+sub AUTOLOAD {
+ return;
+}
+
+sub block_accessor() {
+ my $accessor = shift;
+ no strict 'refs';
+ return if defined &$accessor;
+ *$accessor = sub {
+ my $self = shift;
+ if (@_) {
+ Carp::croak "Not allowed to set values for '$accessor'";
+ }
+ my @list = @{$self->{$accessor} || []};
+ return wantarray
+ ? (@list)
+ : $list[0];
+ };
+}
+
+block_accessor 'name';
+block_accessor 'description';
+Spiffy::field 'seq_num';
+Spiffy::field 'is_filtered';
+Spiffy::field 'blocks_object';
+Spiffy::field 'original_values' => {};
+
+sub set_value {
+ no strict 'refs';
+ my $accessor = shift;
+ block_accessor $accessor
+ unless defined &$accessor;
+ $self->{$accessor} = [@_];
+}
+
+sub run_filters {
+ my $map = $self->_section_map;
+ my $order = $self->_section_order;
+ Carp::croak "Attempt to filter a block twice"
+ if $self->is_filtered;
+ for my $type (@$order) {
+ my $filters = $map->{$type}{filters};
+ my @value = $self->$type;
+ $self->original_values->{$type} = $value[0];
+ for my $filter ($self->_get_filters($type, $filters)) {
+ $Test::Base::Filter::arguments =
+ $filter =~ s/=(.*)$// ? $1 : undef;
+ my $function = "main::$filter";
+ no strict 'refs';
+ if (defined &$function) {
+ $_ = join '', @value;
+ @value = &$function(@value);
+ if (not(@value) or
+ @value == 1 and $value[0] =~ /\A(\d+|)\z/
+ ) {
+ @value = ($_);
+ }
+ }
+ else {
+ my $filter_object = $self->blocks_object->filter_class->new;
+ die "Can't find a function or method for '$filter' filter\n"
+ unless $filter_object->can($filter);
+ $filter_object->current_block($self);
+ @value = $filter_object->$filter(@value);
+ }
+ # Set the value after each filter since other filters may be
+ # introspecting.
+ $self->set_value($type, @value);
+ }
+ }
+ $self->is_filtered(1);
+}
+
+sub _get_filters {
+ my $type = shift;
+ my $string = shift || '';
+ $string =~ s/\s*(.*?)\s*/$1/;
+ my @filters = ();
+ my $map_filters = $self->blocks_object->_filters_map->{$type} || [];
+ $map_filters = [ $map_filters ] unless ref $map_filters;
+ my @append = ();
+ for (
+ @{$self->blocks_object->_filters},
+ @$map_filters,
+ split(/\s+/, $string),
+ ) {
+ my $filter = $_;
+ last unless length $filter;
+ if ($filter =~ s/^-//) {
+ @filters = grep { $_ ne $filter } @filters;
+ }
+ elsif ($filter =~ s/^\+//) {
+ push @append, $filter;
+ }
+ else {
+ push @filters, $filter;
+ }
+ }
+ return @filters, @append;
+}
+
+{
+ %$reserved_section_names = map {
+ ($_, 1);
+ } keys(%Test::Base::Block::), qw( new DESTROY );
+}
+
+__DATA__
+
+#line 1265
@@ -2,7 +2,7 @@ package Test::YAML;
use Test::Base 0.47 -Base;
use lib 'lib';
-our $VERSION = '0.53';
+our $VERSION = '0.54';
our $YAML = 'YAML';
@@ -1,19 +1,78 @@
package YAML::Base;
use strict; use warnings;
-use Class::Spiffy 0.12 -base;
+use base 'Exporter';
-our @EXPORT = qw(
- XXX
-);
+our @EXPORT = qw(field XXX);
+
+sub new {
+ my $class = shift;
+ $class = ref($class) || $class;
+ my $self = bless {}, $class;
+ while (@_) {
+ my $method = shift;
+ $self->$method(shift);
+ }
+ return $self;
+}
# Use lexical subs to reduce pollution of private methods by base class.
-my ($_new_error, $_info, $_scalar_info);
+my ($_new_error, $_info, $_scalar_info, $parse_arguments, $default_as_code);
sub XXX {
require Data::Dumper;
CORE::die(Data::Dumper::Dumper(@_));
}
+my %code = (
+ sub_start =>
+ "sub {\n",
+ set_default =>
+ " \$_[0]->{%s} = %s\n unless exists \$_[0]->{%s};\n",
+ init =>
+ " return \$_[0]->{%s} = do { my \$self = \$_[0]; %s }\n" .
+ " unless \$#_ > 0 or defined \$_[0]->{%s};\n",
+ return_if_get =>
+ " return \$_[0]->{%s} unless \$#_ > 0;\n",
+ set =>
+ " \$_[0]->{%s} = \$_[1];\n",
+ sub_end =>
+ " return \$_[0]->{%s};\n}\n",
+);
+
+sub field {
+ my $package = caller;
+ my ($args, @values) = &$parse_arguments(
+ [ qw(-package -init) ],
+ @_,
+ );
+ my ($field, $default) = @values;
+ $package = $args->{-package} if defined $args->{-package};
+ return if defined &{"${package}::$field"};
+ my $default_string =
+ ( ref($default) eq 'ARRAY' and not @$default )
+ ? '[]'
+ : (ref($default) eq 'HASH' and not keys %$default )
+ ? '{}'
+ : &$default_as_code($default);
+
+ my $code = $code{sub_start};
+ if ($args->{-init}) {
+ my $fragment = $code{init};
+ $code .= sprintf $fragment, $field, $args->{-init}, ($field) x 4;
+ }
+ $code .= sprintf $code{set_default}, $field, $default_string, $field
+ if defined $default;
+ $code .= sprintf $code{return_if_get}, $field;
+ $code .= sprintf $code{set}, $field;
+ $code .= sprintf $code{sub_end}, $field;
+
+ my $sub = eval $code;
+ die $@ if $@;
+ no strict 'refs';
+ *{"${package}::$field"} = $sub;
+ return $code if defined wantarray;
+}
+
sub die {
my $self = shift;
my $error = $self->$_new_error(@_);
@@ -82,6 +141,32 @@ $_new_error = sub {
return $error;
};
+$parse_arguments = sub {
+ my $paired_arguments = shift || [];
+ my ($args, @values) = ({}, ());
+ my %pairs = map { ($_, 1) } @$paired_arguments;
+ while (@_) {
+ my $elem = shift;
+ if (defined $elem and defined $pairs{$elem} and @_) {
+ $args->{$elem} = shift;
+ }
+ else {
+ push @values, $elem;
+ }
+ }
+ return wantarray ? ($args, @values) : $args;
+};
+
+$default_as_code = sub {
+ no warnings 'once';
+ require Data::Dumper;
+ local $Data::Dumper::Sortkeys = 1;
+ my $code = Data::Dumper::Dumper(shift);
+ $code =~ s/^\$VAR1 = //;
+ $code =~ s/;$//;
+ return $code;
+};
+
__END__
=head1 NAME
@@ -95,8 +180,7 @@ YAML::Base - Base class for YAML classes
=head1 DESCRIPTION
-YAML::Base is the parent of all YAML classes. YAML::Base itself inherits
-from Class::Spiffy.
+YAML::Base is the parent of all YAML classes.
=head1 AUTHOR
@@ -1,6 +1,6 @@
package YAML::Dumper::Base;
use strict; use warnings;
-use YAML::Base -base;
+use YAML::Base; use base 'YAML::Base';
use YAML::Node;
# YAML Dumping options
@@ -1,6 +1,7 @@
package YAML::Dumper;
use strict; use warnings;
-use YAML::Dumper::Base -base;
+use YAML::Base;
+use base 'YAML::Dumper::Base';
use YAML::Node;
use YAML::Types;
@@ -1,6 +1,6 @@
package YAML::Error;
use strict; use warnings;
-use YAML::Base -base;
+use YAML::Base; use base 'YAML::Base';
field 'code';
field 'type' => 'Error';
@@ -1,6 +1,6 @@
package YAML::Loader::Base;
use strict; use warnings;
-use YAML::Base -base;
+use YAML::Base; use base 'YAML::Base';
field load_code => 0;
@@ -1,6 +1,7 @@
package YAML::Loader;
use strict; use warnings;
-use YAML::Loader::Base -base;
+use YAML::Base;
+use base 'YAML::Loader::Base';
use YAML::Types;
# Context constants
@@ -1,20 +1,21 @@
package YAML::Marshall;
use strict; use warnings;
-use Class::Spiffy -base;
use YAML::Node();
sub import {
- my ($package, $mixin, $tag) = @_;
- if ($mixin eq '-mixin' && $tag) {
- my $class = caller;
- no warnings 'once';
- $YAML::TagClass->{$tag} = $class;
- no strict 'refs';
- ${$class . "::YamlTag"} = $tag;
- pop @_;
+ my $class = shift;
+ no strict 'refs';
+ my $package = caller;
+ unless (grep { $_ eq $class} @{$package . '::ISA'}) {
+ push @{$package . '::ISA'}, $class;
}
- goto &Class::Spiffy::import;
+ my $tag = shift;
+ if ($tag) {
+ no warnings 'once';
+ $YAML::TagClass->{$tag} = $package;
+ ${$package . "::YamlTag"} = $tag;
+ }
}
sub yaml_dump {
@@ -1,6 +1,6 @@
package YAML::Node;
use strict; use warnings;
-use YAML::Base -base;
+use YAML::Base; use base 'YAML::Base';
use YAML::Tag;
our @EXPORT = qw(ynode);
@@ -1,6 +1,6 @@
package YAML::Types;
use strict; use warnings;
-use YAML::Base -base;
+use YAML::Base; use base 'YAML::Base';
use YAML::Node;
# XXX These classes and their APIs could still use some refactoring,
@@ -1,8 +1,10 @@
package YAML;
use strict; use warnings;
-use YAML::Base -base;
+use YAML::Base;
+use base 'YAML::Base';
+use YAML::Node; # XXX This is a temp fix for Module::Build
use 5.006001;
-our $VERSION = '0.53';
+our $VERSION = '0.55';
our @EXPORT = qw'Dump Load';
our @EXPORT_OK = qw'freeze thaw DumpFile LoadFile Bless Blessed';
@@ -0,0 +1,11 @@
+package t::Base;
+
+sub new {
+ my $self = bless {}, shift;
+ while (my ($k, $v) = splice @_, 0, 2) {
+ $self->{$k} = $v;
+ }
+ return $self;
+}
+
+1;
@@ -2,3 +2,5 @@ package t::TestYAML;
use Test::YAML 0.51 -Base;
$Test::YAML::YAML = 'YAML';
+
+$^W = 1;
@@ -1,27 +1,24 @@
use t::TestYAML tests => 2;
package Foo::Bar;
-use Class::Spiffy -base;
-
-field 'one';
-field 'two';
+use base 't::Base';
sub yaml_dump {
my $self = shift;
my $node = YAML::Node->new({
- two => $self->two - 1,
- one => $self->one + 1,
+ two => $self->{two} - 1,
+ one => $self->{one} + 1,
}, 'perl/Foo::Bar');
YAML::Node::ynode($node)->keys(['two', 'one']);
return $node;
}
-sub yaml_load() {
+sub yaml_load {
my $class = shift;
my $node = shift;
my $self = $class->new;
- $self->one($node->{one} - 1);
- $self->two($node->{two} + 1);
+ $self->{one} = ($node->{one} - 1);
+ $self->{two} = ($node->{two} + 1);
return $self;
}
@@ -35,8 +32,8 @@ __END__
=== Object class handles marshalling
+++ perl
my $fb = Foo::Bar->new();
-$fb->one(5);
-$fb->two(3);
+$fb->{one} = 5;
+$fb->{two} = 3;
$fb;
+++ yaml
--- !perl/Foo::Bar
@@ -1,3 +1,8 @@
+use Test::YAML();
+BEGIN {
+ @Test::YAML::EXPORT =
+ grep { not /^(Dump|Load)(File)?$/ } @Test::YAML::EXPORT;
+}
use t::TestYAML tests => 3;
use YAML 'DumpFile';
@@ -1,3 +1,8 @@
+use Test::YAML();
+BEGIN {
+ @Test::YAML::EXPORT =
+ grep { not /^(Dump|Load)(File)?$/ } @Test::YAML::EXPORT;
+}
use t::TestYAML tests => 3;
use YAML;
@@ -1,3 +1,8 @@
+use Test::YAML();
+BEGIN {
+ @Test::YAML::EXPORT =
+ grep { not /^(Dump|Load)(File)?$/ } @Test::YAML::EXPORT;
+}
use t::TestYAML tests => 9;
use YAML qw(Dump Load freeze thaw);
@@ -1,3 +1,8 @@
+use Test::YAML();
+BEGIN {
+ @Test::YAML::EXPORT =
+ grep { not /^(Dump|Load)(File)?$/ } @Test::YAML::EXPORT;
+}
use t::TestYAML tests => 4;
use YAML;
@@ -1,12 +1,11 @@
use t::TestYAML tests => 10;
+use strict;
+use warnings;
#-------------------------------------------------------------------------------
package Foo::Bar;
-use Class::Spiffy -base;
-use YAML::Marshall -mixin;
-
-field 'x';
-field 'y';
+use base 't::Base';
+use YAML::Marshall;
sub yaml_dump {
my $self = shift;
@@ -17,7 +16,7 @@ sub yaml_dump {
$self->yaml_node($array, 'perl/Foo::Bar');
}
-sub yaml_load() {
+sub yaml_load {
my $class = shift;
my $node = shift;
my $self = $class->new;
@@ -27,22 +26,24 @@ sub yaml_load() {
#-------------------------------------------------------------------------------
package Bar::Baz;
-use Class::Spiffy -base;
-use YAML::Marshall -mixin, 'random/object:bar.baz';
+use base 't::Base';
+use YAML::Marshall 'random/object:bar.baz';
#-------------------------------------------------------------------------------
package Baz::Foo;
-use Class::Spiffy -base;
-use YAML::Marshall -mixin;
+use base 't::Base';
+use YAML::Marshall;
sub yaml_dump {
- my $node = super;
+ my $self = shift;
+ my $node = $self->SUPER::yaml_dump(@_);
$node->{comment} = "Hi, Mom";
return $node;
}
sub yaml_load {
- my $node = super;
+ my $class = shift;
+ my $node = $class->SUPER::yaml_load(@_);
delete $node->{comment};
return $node;
}
@@ -21,14 +21,15 @@ __DATA__
},
'generated_by' => 'Module::Install version 0.54',
'distribution_type' => 'module',
- 'version' => '0.53',
+ 'version' => '0.55',
'name' => 'YAML',
'author' => 'Ingy döt Net <ingy@cpan.org>',
'license' => 'perl',
'requires' => {
- 'Class::Spiffy' => '0.12',
- 'Test::Base' => '0.47',
'perl' => '5.6.1'
},
+ 'build_requires' => {
+ 'Test::Base' => '0.47'
+ },
'abstract' => 'YAML Ain\'t Markup Language (tm)'
};