dslinux/user/perl/ext/Data/Dumper/t bugs.t dumper.t freezer.t overload.t pair.t

cayenne dslinux_cayenne at user.in-berlin.de
Mon Dec 4 17:59:12 CET 2006


Update of /cvsroot/dslinux/dslinux/user/perl/ext/Data/Dumper/t
In directory antilope:/tmp/cvs-serv17422/ext/Data/Dumper/t

Added Files:
	bugs.t dumper.t freezer.t overload.t pair.t 
Log Message:
Adding fresh perl source to HEAD to branch from

--- NEW FILE: dumper.t ---
#!./perl -w
#
# testsuite for Data::Dumper
#

BEGIN {
    if ($ENV{PERL_CORE}){
        chdir 't' if -d 't';
        @INC = '../lib';
        require Config; import Config;
        if ($Config{'extensions'} !~ /\bData\/Dumper\b/) {
            print "1..0 # Skip: Data::Dumper was not built\n";
            exit 0;
        }
    }
}

# Since Perl 5.8.1 because otherwise hash ordering is really random.
local $Data::Dumper::Sortkeys = 1;
[...1355 lines suppressed...]
  TEST q(Data::Dumper->Dump([\\%foo])), "quotekeys == 0 for utf8 flagged ASCII";
  TEST q(Data::Dumper->Dumpxs([\\%foo])),
    "XS quotekeys == 0 for utf8 flagged ASCII" if $XS;
}
############# 358
{
  $WANT = <<'EOT';
#$VAR1 = [
#  undef,
#  undef,
#  1
#];
EOT
    @foo = ();
    $foo[2] = 1;
    TEST q(Data::Dumper->Dump([\@foo])), 'Richard Clamp, Message-Id: <20030104005247.GA27685 at mirth.demon.co.uk>';
    TEST q(Data::Dumper->Dumpxs([\@foo])) if $XS;
}



--- NEW FILE: overload.t ---
#!./perl -w

BEGIN {
    if ($ENV{PERL_CORE}){
        chdir 't' if -d 't';
        @INC = '../lib';
        require Config; import Config;
        no warnings 'once';
        if ($Config{'extensions'} !~ /\bData\/Dumper\b/) {
            print "1..0 # Skip: Data::Dumper was not built\n";
            exit 0;
        }
    }
}

use Data::Dumper;

print "1..1\n";

package Foo;
use overload '""' => 'as_string';

sub new { bless { foo => "bar" }, shift }
sub as_string { "%%%%" }

package main;

my $f = Foo->new;

print "#\$f=$f\n";

$_ = Dumper($f);
s/^/#/mg;
print $_;

print "not " unless /bar/ && /Foo/;
print "ok 1\n";


--- NEW FILE: pair.t ---
#!./perl -w
#
# test for $Data::Dumper::Pair AKA Data::Dumper->new([ ... ])->Pair('...')
#

BEGIN {
    if ($ENV{PERL_CORE}){
        chdir 't' if -d 't';
        unshift @INC, '../lib';
        require Config; import Config;
        no warnings 'once';
        if ($Config{'extensions'} !~ /\bData\/Dumper\b/) {
            print "1..0 # Skip: Data::Dumper was not built\n";
            exit 0;
        }
    }
}

use strict;
use vars qw($want_colon $want_comma);
use Test::More tests => 9;

no warnings qw(once);

require_ok 'Data::Dumper';

my $HASH = { alpha => 'beta', gamma => 'vlissides' };
my $WANT = q({'alpha' => 'beta','gamma' => 'vlissides'});

$Data::Dumper::Useperl = 1;
$Data::Dumper::Indent = 0;
$Data::Dumper::Terse = 1;
$Data::Dumper::Sortkeys = 1;

$want_colon = $want_comma = $WANT;
$want_colon =~ s/=>/:/g;
$want_comma =~ s/ => /,/g;

####################### XS Tests #####################

SKIP: {
    skip 'XS extension not loaded', 3 unless (defined &Data::Dumper::Dumpxs);
    is (Data::Dumper::DumperX($HASH), $WANT, 
	'XS: Default hash key/value separator: " => "');
    local $Data::Dumper::Pair = ' : ';
    is (Data::Dumper::DumperX($HASH), $want_colon, 'XS: $Data::Dumper::Pair = " : "');
    my $dd = Data::Dumper->new([ $HASH ])->Pair(',');
    is ($dd->Dumpxs(), $want_comma, 
	'XS: Data::Dumper->new([ $HASH ])->Pair(",")->Dumpxs()');
};

###################### Perl Tests ####################

{
    is ($Data::Dumper::Pair, ' => ', 'Perl: $Data::Dumper::Pair eq " => "');
    is (Data::Dumper::Dumper($HASH), $WANT, 
	'Perl: Default hash key/value separator: " => "');
    local $Data::Dumper::Pair = ' : ';
    is (Data::Dumper::Dumper($HASH), $want_colon, 'Perl: $Data::Dumper::Pair = " : "');
    my $dd = Data::Dumper->new([ $HASH ])->Pair(',');
    is ($dd->Pair(), ',', 
	'Perl: Data::Dumper->new([ $HASH ])->Pair(",")->Pair() eq ","');
    is ($dd->Dump(), $want_comma, 'Perl: Data::Dumper->new([ $HASH ])->Pair(",")->Dump()');
}

--- NEW FILE: freezer.t ---
#!./perl -w
#
# test a few problems with the Freezer option, not a complete Freezer
# test suite yet

BEGIN {
    if ($ENV{PERL_CORE}){
        chdir 't' if -d 't';
        unshift @INC, '../lib';
        require Config; import Config;
        no warnings 'once';
        if ($Config{'extensions'} !~ /\bData\/Dumper\b/) {
            print "1..0 # Skip: Data::Dumper was not built\n";
            exit 0;
        }
    }
}

use strict;
use Test::More qw(no_plan);
use Data::Dumper;
$Data::Dumper::Freezer = 'freeze';

# test for seg-fault bug when freeze() returns a non-ref
my $foo = Test1->new("foo");
my $dumped_foo = Dumper($foo);
ok($dumped_foo, 
   "Use of freezer sub which returns non-ref worked.");
like($dumped_foo, qr/frozed/, 
     "Dumped string has the key added by Freezer.");

# run the same tests with useperl.  this always worked
{
    local $Data::Dumper::Useperl = 1;
    my $foo = Test1->new("foo");
    my $dumped_foo = Dumper($foo);
    ok($dumped_foo, 
       "Use of freezer sub which returns non-ref worked with useperl");
    like($dumped_foo, qr/frozed/, 
         "Dumped string has the key added by Freezer with useperl.");
}

# test for warning when an object doesn't have a freeze()
{
    my $warned = 0;
    local $SIG{__WARN__} = sub { $warned++ };
    my $bar = Test2->new("bar");
    my $dumped_bar = Dumper($bar);
    is($warned, 0, "A missing freeze() shouldn't warn.");
}


# run the same test with useperl, which always worked
{
    local $Data::Dumper::Useperl = 1;
    my $warned = 0;
    local $SIG{__WARN__} = sub { $warned++ };
    my $bar = Test2->new("bar");
    my $dumped_bar = Dumper($bar);
    is($warned, 0, "A missing freeze() shouldn't warn with useperl");
}

# a freeze() which die()s should still trigger the warning
{
    my $warned = 0;
    local $SIG{__WARN__} = sub { $warned++; };
    my $bar = Test3->new("bar");
    my $dumped_bar = Dumper($bar);
    is($warned, 1, "A freeze() which die()s should warn.");
}

# the same should work in useperl
{
    local $Data::Dumper::Useperl = 1;
    my $warned = 0;
    local $SIG{__WARN__} = sub { $warned++; };
    my $bar = Test3->new("bar");
    my $dumped_bar = Dumper($bar);
    is($warned, 1, "A freeze() which die()s should warn with useperl.");
}

# a package with a freeze() which returns a non-ref
package Test1;
sub new { bless({name => $_[1]}, $_[0]) }
sub freeze {
    my $self = shift;
    $self->{frozed} = 1;
}

# a package without a freeze()
package Test2;
sub new { bless({name => $_[1]}, $_[0]) }

# a package with a freeze() which dies
package Test3;
sub new { bless({name => $_[1]}, $_[0]) }
sub freeze { die "freeze() is broked" }

--- NEW FILE: bugs.t ---
#!perl
#
# regression tests for old bugs that don't fit other categories

BEGIN {
    if ($ENV{PERL_CORE}){
	chdir 't' if -d 't';
	unshift @INC, '../lib';
	require Config; import Config;
	no warnings 'once';
	if ($Config{'extensions'} !~ /\bData\/Dumper\b/) {
	    print "1..0 # Skip: Data::Dumper was not built\n";
	    exit 0;
	}
    }
}

use strict;
use Test::More tests => 1;
use Data::Dumper;

{
    sub iterate_hash {
	my ($h) = @_;
	my $count = 0;
	$count++ while each %$h;
	return $count;
    }

    my $dumper = Data::Dumper->new( [\%ENV], ['ENV'] )->Sortkeys(1);
    my $orig_count = iterate_hash(\%ENV);
    $dumper->Dump;
    my $new_count = iterate_hash(\%ENV);
    is($new_count, $orig_count, 'correctly resets hash iterators');
}




More information about the dslinux-commit mailing list