summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorgregor herrmann <gregoa@debian.org>2023-02-25 02:18:01 +0100
committergregor herrmann <gregoa@debian.org>2023-02-25 02:18:01 +0100
commitd430c24cd3afd01bd11f07ffa0f70104d542d7b9 (patch)
tree25f57e528271dc1db166a974ffd9d8ab9517b81b
parent87a084d0bb4201855a26d91a8f30400b25ea4e12 (diff)
parentea8629edbbc0eaa731cde78ff6cdc98dfa3eb477 (diff)
Update upstream source from tag 'upstream/2.42'
Update to upstream version '2.42' with Debian dir 23a82b9242fe63f72b534e47ee5aa501c41c00c4
Diffstat
-rw-r--r--Build.PL2
-rw-r--r--Changes6
-rw-r--r--INSTALL.SKIP1
-rw-r--r--MANIFEST6
-rw-r--r--MANIFEST.SKIP3
-rw-r--r--META.json10
-rw-r--r--META.yml8
-rw-r--r--inc/My/Builder.pm83
-rw-r--r--lib/Data/Dump/Streamer.pm2990
-rw-r--r--lib/Data/Dump/Streamer/_/Printers.pm41
-rw-r--r--t/as.t9
-rw-r--r--t/blessed.t6
-rw-r--r--t/dogpound.t43
-rw-r--r--t/dump.t341
-rw-r--r--t/filter.t89
-rw-r--r--t/globtest.t235
-rw-r--r--t/hardrefs.t68
-rw-r--r--t/impure_madness.t171
-rw-r--r--t/lexicals.t161
-rw-r--r--t/locked.t174
-rw-r--r--t/madness.t172
-rw-r--r--t/madness_json.t181
-rw-r--r--t/madness_w.t198
-rw-r--r--t/names.t379
-rw-r--r--t/overload.t75
-rw-r--r--t/readonly.t25
-rw-r--r--t/refaddr.t37
-rw-r--r--t/refcount.t66
-rw-r--r--t/refelem.t22
-rw-r--r--t/reftype.t57
-rw-r--r--t/sortkeys.t57
-rw-r--r--t/stash.t6
-rw-r--r--t/terse.t23
-rw-r--r--t/test_helper.pl1
-rw-r--r--t/tree.t60
-rw-r--r--t/usage.t30
-rw-r--r--t/xs_subs.t211
37 files changed, 3299 insertions, 2748 deletions
diff --git a/Build.PL b/Build.PL
index 081e9be..888aa0c 100644
--- a/Build.PL
+++ b/Build.PL
@@ -8,7 +8,7 @@ use My::Builder;
my $build = My::Builder->new(
module_name => 'Data::Dump::Streamer',
- dist_author => 'Yves Orton <yves@cpan.org>, Joshua ben Jore <jjore@cpan.org>',
+ dist_author => 'Yves Orton <yves@cpan.org>',
license => 'perl',
configure_requires => {
'perl' => '5.006',
diff --git a/Changes b/Changes
index 3904274..633e248 100644
--- a/Changes
+++ b/Changes
@@ -1,3 +1,9 @@
+2.42
+
+Perltidy source to my preferred format. Fixed issues serializing
+the global stash. Added test to detect if serializing the global
+stash breaks anything.
+
2.41
Merged in all the open PR's. Some MUCH much later than I originally
diff --git a/INSTALL.SKIP b/INSTALL.SKIP
index 7f7b270..e02d943 100644
--- a/INSTALL.SKIP
+++ b/INSTALL.SKIP
@@ -1,4 +1,3 @@
-:#$Id: INSTALL.SKIP 33 2007-08-22 22:00:26Z demerphq $id
# Avoid version control files.
\bRCS\b
\bCVS\b
diff --git a/MANIFEST b/MANIFEST
index c584b01..dcf2503 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -1,5 +1,5 @@
-.patch
.gitignore
+.patch
Build.PL
Changes
inc/My/Builder.pm
@@ -10,6 +10,7 @@ lib/Data/Dump/Streamer.xs
lib/Data/Dump/Streamer/_/Printers.pm
MANIFEST This list of files
MANIFEST.SKIP
+META.json
META.yml
README.md
t/as.t
@@ -33,9 +34,10 @@ t/refcount.t
t/refelem.t
t/reftype.t
t/sortkeys.t
+t/stash.t
+t/terse.t
t/test_helper.pl
t/tree.t
t/usage.t
t/xs_subs.t
typemap
-META.json
diff --git a/MANIFEST.SKIP b/MANIFEST.SKIP
index bc33a77..1c8941b 100644
--- a/MANIFEST.SKIP
+++ b/MANIFEST.SKIP
@@ -47,3 +47,6 @@ DDS\.pm
\.(bs|c|def|obj|pdb)$
^dds\w+\.pl
^MYMETA.yml$
+^MYMETA\.json$
+.travis.yml
+tidyall.sh
diff --git a/META.json b/META.json
index ba41e75..6e4d72b 100644
--- a/META.json
+++ b/META.json
@@ -1,7 +1,7 @@
{
"abstract" : "Accurately serialize a data structure as Perl code.",
"author" : [
- "Yves Orton <yves@cpan.org>, Joshua ben Jore <jjore@cpan.org>"
+ "Yves Orton <yves@cpan.org>"
],
"dynamic_config" : 1,
"generated_by" : "Module::Build version 0.4232",
@@ -73,11 +73,11 @@
"provides" : {
"Data::Dump::Streamer" : {
"file" : "lib/Data/Dump/Streamer.pm",
- "version" : "2.41"
+ "version" : "2.42"
},
"Data::Dump::Streamer::Deparser" : {
"file" : "lib/Data/Dump/Streamer.pm",
- "version" : "2.41"
+ "version" : "2.42"
}
},
"release_status" : "stable",
@@ -89,6 +89,6 @@
"url" : "https://github.com/demerphq/Data-Dump-Streamer"
}
},
- "version" : "2.41",
- "x_serialization_backend" : "JSON::PP version 4.16"
+ "version" : "2.42",
+ "x_serialization_backend" : "JSON::PP version 4.06"
}
diff --git a/META.yml b/META.yml
index 7c56050..3c70104 100644
--- a/META.yml
+++ b/META.yml
@@ -1,7 +1,7 @@
---
abstract: 'Accurately serialize a data structure as Perl code.'
author:
- - 'Yves Orton <yves@cpan.org>, Joshua ben Jore <jjore@cpan.org>'
+ - 'Yves Orton <yves@cpan.org>'
build_requires:
B::Deparse: '0'
Carp: '0'
@@ -33,10 +33,10 @@ name: Data-Dump-Streamer
provides:
Data::Dump::Streamer:
file: lib/Data/Dump/Streamer.pm
- version: '2.41'
+ version: '2.42'
Data::Dump::Streamer::Deparser:
file: lib/Data/Dump/Streamer.pm
- version: '2.41'
+ version: '2.42'
recommends:
Algorithm::Diff: '0'
Compress::Zlib: '0'
@@ -64,5 +64,5 @@ requires:
resources:
license: http://dev.perl.org/licenses/
repository: https://github.com/demerphq/Data-Dump-Streamer
-version: '2.41'
+version: '2.42'
x_serialization_backend: 'CPAN::Meta::YAML version 0.018'
diff --git a/inc/My/Builder.pm b/inc/My/Builder.pm
index abdeade..a91bf66 100644
--- a/inc/My/Builder.pm
+++ b/inc/My/Builder.pm
@@ -4,84 +4,87 @@ use strict;
use warnings;
use Module::Build;
-our @ISA = 'Module::Build';
+our @ISA= 'Module::Build';
sub new {
- my $class = shift @_;
+ my $class= shift @_;
{
- my $B_Utils_required = 0.05;
- eval {
- require B::Utils;
- };
- if ( $@ or B::Utils->VERSION < $B_Utils_required ) {
+ my $B_Utils_required= 0.05;
+ eval { require B::Utils; };
+ if ($@ or B::Utils->VERSION < $B_Utils_required) {
# If I don't have B::Utils then I must have ExtUtils::Depends
- my $ExtUtils_Depends_required = 0.302; #minimum version that works on Win32+gcc
- eval {
- require ExtUtils::Depends;
- };
- if ( $@ or ExtUtils::Depends->VERSION < $ExtUtils_Depends_required ) {
- print "ExtUtils::Depends $ExtUtils_Depends_required is required to configure our B::Utils dependency, please install it manually or upgrade your CPAN/CPANPLUS\n";
+ my $ExtUtils_Depends_required=
+ 0.302; #minimum version that works on Win32+gcc
+ eval { require ExtUtils::Depends; };
+ if ($@ or ExtUtils::Depends->VERSION < $ExtUtils_Depends_required) {
+ print
+ "ExtUtils::Depends $ExtUtils_Depends_required is required to configure our B::Utils dependency, please install it manually or upgrade your CPAN/CPANPLUS\n";
exit(0);
}
- };
+ }
}
# Handle both: `./Build.PL DDS' and `./Build.PL NODDS'
#
my $create_dds_alias;
- if ( @ARGV && $ARGV[0] =~ /^(?:NO)?DDS$/i ) {
- my $arg = uc shift @ARGV;
- $create_dds_alias = 'DDS' eq $arg;
+ if (@ARGV && $ARGV[0] =~ /^(?:NO)?DDS$/i) {
+ my $arg= uc shift @ARGV;
+ $create_dds_alias= 'DDS' eq $arg;
}
print "Installing Data::Dump::Streamer\n";
- if ( ! defined $create_dds_alias
- && -e '.answer'
- && open my $fh, "<", '.answer') {
- print "I will install (or not) the DDS shortcut as you requested previously.\n";
- print "If you wish to override the previous answer then state so explicitly\n";
+ if (!defined $create_dds_alias && -e '.answer' && open my $fh,
+ "<", '.answer')
+ {
+ print
+ "I will install (or not) the DDS shortcut as you requested previously.\n";
+ print
+ "If you wish to override the previous answer then state so explicitly\n";
print "by saying 'perl Build.PL [NO]DDS'\n";
- my $cached_value = <$fh>;
+ my $cached_value= <$fh>;
chomp $cached_value;
print "Previous answer was: $cached_value\n";
-
- $create_dds_alias = 'yes' eq lc $cached_value;
+
+ $create_dds_alias= 'yes' eq lc $cached_value;
}
-
- if ( ! defined $create_dds_alias ) {
- my $default =
- ( 0 == system( qq($^X -e "chdir '/';exit( eval { require DDS } ? 0: 1 )") )
- || ( -e "./lib/DDS.pm") )
+
+ if (!defined $create_dds_alias) {
+ my $default= (
+ 0 == system(
+ qq($^X -e "chdir '/';exit( eval { require DDS } ? 0: 1 )"))
+ || (-e "./lib/DDS.pm"))
? 'yes'
: 'no';
print "\n";
print "I can install a shortcut so you can use the package 'DDS'\n";
- print "as though it was 'Data::Dump::Streamer'. This is handy for oneliners.\n";
+ print
+ "as though it was 'Data::Dump::Streamer'. This is handy for oneliners.\n";
print "*Note* that if you select 'no' below and you already\n";
print "have it installed then it will be removed.\n";
print "\n";
- my $yn = !! $class->y_n("Would you like me to install the shortcut? (yes/no)",
- $default);
+ my $yn=
+ !!$class->y_n("Would you like me to install the shortcut? (yes/no)",
+ $default);
if (open my $fh, ">", '.answer') {
print $fh $yn ? "yes\n" : "no\n";
close $fh;
}
- $create_dds_alias = $yn;
+ $create_dds_alias= $yn;
}
- my $self = $class->SUPER::new( @_ );
+ my $self= $class->SUPER::new(@_);
- if ( $create_dds_alias ) {
+ if ($create_dds_alias) {
print "I will also install DDS as an alias.\n";
open my $ofh, ">", "./lib/DDS.pm"
or die "Failed to open ./lib/DDS.pm: $!";
- print { $ofh } DDS();
+ print {$ofh} DDS();
close $ofh;
- $self->add_to_cleanup( './lib/DDS.pm' );
+ $self->add_to_cleanup('./lib/DDS.pm');
}
else {
unlink "./lib/DDS.pm";
@@ -91,7 +94,7 @@ sub new {
}
sub DDS {
- my $text = <<'EOF_DDS';
+ my $text= <<'EOF_DDS';
##This all has to be one line for MakeMaker version scanning.
#use Data::Dump::Streamer (); BEGIN{ *DDS:: = \%Data::Dump::Streamer:: } $VERSION=$DDS::VERSION;
#1;
@@ -119,6 +122,4 @@ EOF_DDS
return $text;
}
-
-
1;
diff --git a/lib/Data/Dump/Streamer.pm b/lib/Data/Dump/Streamer.pm
index 2c508d0..e6ab7f9 100644
--- a/lib/Data/Dump/Streamer.pm
+++ b/lib/Data/Dump/Streamer.pm
@@ -3,44 +3,50 @@ use strict;
use warnings;
use warnings::register;
-use B ();
-use B::Deparse ();
-use B::Utils ();
-use Data::Dumper ();
-use DynaLoader ();
-use Exporter ();
-use IO::File ();
-use Symbol ();
-use Text::Abbrev ();
+use B ();
+use B::Deparse ();
+use B::Utils ();
+use Data::Dumper ();
+use DynaLoader ();
+use Exporter ();
+use IO::File ();
+use Symbol ();
+use Text::Abbrev ();
use Text::Balanced ();
-use overload ();
+use overload ();
use Data::Dump::Streamer::_::Printers;
+# The style of this file is determined by:
+#
+# perltidy -w -ple -bbb -bbc -bbs -nolq -l=80 -noll -nola -nwls='=' \
+# -isbc -nolc -otr -kis -ci=4 -se -sot -sct -nsbl -pt=2 -fs \
+# -fsb='#start-no-tidy' -fse='#end-no-tidy' -cpb -bfvt=2
+
# use overload qw("" printit); # does diabolical stuff.
use vars qw(
- $VERSION
- $XS_VERSION
- $AUTOLOAD
- @ISA
- @EXPORT @EXPORT_OK @EXPORT_FAIL %EXPORT_TAGS
- %Freeze
- %Thaw
- $DEBUG
- $HasPadWalker
- );
-
-$DEBUG=0;
-BEGIN{ $HasPadWalker=eval "use PadWalker 0.99; 1"; }
+ $VERSION
+ $XS_VERSION
+ $AUTOLOAD
+ @ISA
+ @EXPORT @EXPORT_OK @EXPORT_FAIL %EXPORT_TAGS
+ %Freeze
+ %Thaw
+ $DEBUG
+ $HasPadWalker
+);
+
+$DEBUG= 0;
+BEGIN { $HasPadWalker= eval "use PadWalker 0.99; 1"; }
BEGIN {
- $VERSION ='2.41';
- $XS_VERSION = $VERSION;
- $VERSION = eval $VERSION; # used for beta stuff.
- @ISA = qw(Exporter DynaLoader);
- @EXPORT=qw(Dump DumpLex DumpVars);
- @EXPORT_OK = qw(
+ $VERSION= '2.42';
+ $XS_VERSION= $VERSION;
+ $VERSION= eval $VERSION; # used for beta stuff.
+ @ISA= qw(Exporter DynaLoader);
+ @EXPORT= qw(Dump DumpLex DumpVars);
+ @EXPORT_OK= qw(
Dump
DumpLex
DumpVars
@@ -89,43 +95,44 @@ BEGIN {
alias
sqz
usqz
- );
-
- %EXPORT_TAGS = (
- undump => [ qw( alias_av alias_hv alias_ref make_ro
- lock_ref_keys
- lock_keys
- lock_ref_keys_plus
- lock_keys_plus
- alias_to
- dualvar
- weaken
- usqz
- )
- ],
- special=> [ qw( readonly_set ) ],
- all => [ @EXPORT,@EXPORT_OK ],
- alias => [ qw( alias_av alias_hv alias_ref push_alias ) ],
- bin => [ @EXPORT_OK ],
- Dumper => [ qw( Dumper DDumper )],
- util => [ qw (
- dualvar
- blessed reftype refaddr refcount sv_refcount
- readonly looks_like_number regex is_numeric
- make_ro readonly_set reftype_or_glob
- refaddr_or_glob globname
- weak_refcount isweak weaken
- )
- ],
-
);
+ %EXPORT_TAGS= (
+ undump => [
+ qw( alias_av alias_hv alias_ref make_ro
+ lock_ref_keys
+ lock_keys
+ lock_ref_keys_plus
+ lock_keys_plus
+ alias_to
+ dualvar
+ weaken
+ usqz
+ )
+ ],
+ special => [qw( readonly_set )],
+ all => [ @EXPORT, @EXPORT_OK ],
+ alias => [qw( alias_av alias_hv alias_ref push_alias )],
+ bin => [@EXPORT_OK],
+ Dumper => [qw( Dumper DDumper )],
+ util => [ qw (
+ dualvar
+ blessed reftype refaddr refcount sv_refcount
+ readonly looks_like_number regex is_numeric
+ make_ro readonly_set reftype_or_glob
+ refaddr_or_glob globname
+ weak_refcount isweak weaken
+ )
+ ],
+
+ );
sub alias_to { return shift }
#warn $VERSION;
Data::Dump::Streamer->bootstrap($XS_VERSION);
- if ($]>=5.013010) {
+ if ($] >= 5.013010) {
+
# As I write this, 5.13.10 doesn't exist so I'm guessing that
# we can begin using the ordinary core function again.
eval q[
@@ -133,7 +140,8 @@ BEGIN {
*regex= *regexp_pattern;
] or die $@;
}
- elsif ($]>=5.013006) {
+ elsif ($] >= 5.013006) {
+
# Perl-5.13.6 through perl-5.13.9 began returning modifier
# flags that weren't yet legal at the time.
eval q[
@@ -153,7 +161,7 @@ BEGIN {
1;
] or die $@;
}
- elsif ($]>=5.009004) {
+ elsif ($] >= 5.009004) {
eval q[
use re qw(regexp_pattern is_regexp);
*regex= *regexp_pattern;
@@ -161,28 +169,29 @@ BEGIN {
] or die $@;
}
else {
- eval q[sub is_regexp($) { defined regex($_[0]) }];
+ eval q[sub is_regexp($) { defined regex($_[0]) }];
}
- if ($]<=5.008) {
- *hidden_keys=sub(\%) { return () };
- *legal_keys=sub(\%) { return keys %{$_[0]} };
- *all_keys=sub(\%\@\@) { @{$_[1]}=keys %{$_[0]}; @$_[2]=(); };
+ if ($] <= 5.008) {
+ *hidden_keys= sub(\%) { return () };
+ *legal_keys= sub(\%) { return keys %{ $_[0] } };
+ *all_keys= sub(\%\@\@) { @{ $_[1] }= keys %{ $_[0] }; @$_[2]= (); };
}
- if ( $]<5.008 ) {
- no strict 'refs';
- foreach my $sub (qw(lock_keys lock_keys_plus )) {
- *$sub=sub(\%;@) {
- warnings::warn "$sub doesn't do anything before Perl 5.8.0\n";
- return $_[0];
- }
+ if ($] < 5.008) {
+ no strict 'refs';
+ foreach my $sub (qw(lock_keys lock_keys_plus )) {
+ *$sub= sub(\%;@) {
+ warnings::warn "$sub doesn't do anything before Perl 5.8.0\n";
+ return $_[0];
}
- foreach my $sub (qw(lock_ref_keys lock_ref_keys_plus )) {
- *$sub=sub($;@) {
- warnings::warn "$sub doesn't do anything before Perl 5.8.0\n";
- return $_[0];
- }
+ }
+ foreach my $sub (qw(lock_ref_keys lock_ref_keys_plus )) {
+ *$sub= sub($;@) {
+ warnings::warn "$sub doesn't do anything before Perl 5.8.0\n";
+ return $_[0];
}
- } else {
+ }
+ }
+ else {
eval <<'EO_HU'
use Hash::Util qw(lock_keys);
sub lock_ref_keys($;@) {
@@ -193,71 +202,75 @@ BEGIN {
$hash
}
EO_HU
- ;
- *lock_ref_keys_plus=sub($;@){
- my ($hash,@keys)=@_;
+ ;
+ *lock_ref_keys_plus= sub($;@) {
+ my ($hash, @keys)= @_;
my @delete;
Internals::hv_clear_placeholders(%$hash);
foreach my $key (@keys) {
unless (exists($hash->{$key})) {
- $hash->{$key}=undef;
- push @delete,$key;
+ $hash->{$key}= undef;
+ push @delete, $key;
}
}
- SvREADONLY_ref($hash,1);
+ SvREADONLY_ref($hash, 1);
delete @{$hash}{@delete};
- $hash
+ $hash;
};
- *lock_keys_plus=sub(\%;@){lock_ref_keys_plus(@_)};
+ *lock_keys_plus= sub(\%;@) { lock_ref_keys_plus(@_) };
}
if ($] <= 5.008008) {
- *disable_overloading = \&SvAMAGIC_off;
- *restore_overloading = sub ($$) {
+ *disable_overloading= \&SvAMAGIC_off;
+ *restore_overloading= sub ($$) {
SvAMAGIC_on($_[0], undef);
# Visit all classes we are ISA and fetch the () entry from
# every stash.
my %done;
- my %todo = (
+ my %todo= (
$_[0] => undef,
UNIVERSAL => undef,
);
no strict 'refs';
for my $todo_class (keys %todo) {
delete $todo{$todo_class};
- $done{$todo_class} = undef;
+ $done{$todo_class}= undef;
for my $isa (@{"${todo_class}::ISA"}) {
- $todo{$isa} = undef unless exists $done{$isa};
+ $todo{$isa}= undef unless exists $done{$isa};
}
}
};
- } else {
- *disable_overloading = sub ($) {
+ }
+ else {
+ *disable_overloading= sub ($) {
+
# we use eval because $_[0] might be read-only
# its a crappy solution, but whatever, it works
eval { bless $_[0], 'Does::Not::Exist' };
};
- *restore_overloading = sub ($$) {
+ *restore_overloading= sub ($$) {
eval { bless $_[0], $_[1] }
};
}
- my %fail=map { ( $_ => 1 ) } @EXPORT_FAIL;
- @EXPORT_OK=grep { !$fail{$_} } @EXPORT_OK;
+ my %fail= map { ($_ => 1) } @EXPORT_FAIL;
+ @EXPORT_OK= grep { !$fail{$_} } @EXPORT_OK;
}
sub import {
- my ($pkg) = @_;
+ my ($pkg)= @_;
my ($idx, $alias);
- if ($idx = (grep lc($_[$_]) eq 'as', 0..$#_)) {
+ if ($idx= (grep lc($_[$_]) eq 'as', 0 .. $#_)) {
+
#print "found alias at $idx:\n";
- ($idx, $alias) = splice(@_, $idx, 2);
+ ($idx, $alias)= splice(@_, $idx, 2);
+
#print "found alias: $idx => $alias\n";
no strict 'refs';
- *{$alias.'::'} = *{__PACKAGE__.'::'};
+ *{ $alias . '::' }= *{ __PACKAGE__ . '::' };
}
- $pkg->export_to_level(1,@_);
+ $pkg->export_to_level(1, @_);
}
# NOTE
@@ -721,72 +734,75 @@ See C<Dump()> for a better way to do things.
sub _compressor {
return "use Data::Dump::Streamer qw(usqz);\n"
if !@_;
- return sqz($_[0], "usqz('", "')" );
+ return sqz($_[0], "usqz('", "')");
}
sub new {
- my $class = shift;
- my $self = bless {
+ my $class= shift;
+ my $self= bless {
style => {
- hashsep => '=>', # use this to separate key vals
- arysep => ',',
- pairsep => ',',
- optspace => ' ',
- bless => 'bless()', # use this to bless objects, needs fixing
-
- compress => 0, # if nonzero use compressor to compress strings
- # longer than this value.
- compressor => \&_compressor,
-
- indent => 2, # should we indent at all?
- indentkeys => 1, # indent keys
- declare => 0, # predeclare vars? allows refs to root vars if 0
+ hashsep => '=>', # use this to separate key vals
+ arysep => ',',
+ pairsep => ',',
+ optspace => ' ',
+ bless => 'bless()', # use this to bless objects, needs fixing
+
+ compress => 0, # if nonzero use compressor to compress strings
+ # longer than this value.
+ compressor => \&_compressor,
+
+ indent => 2, # should we indent at all?
+ indentkeys => 1, # indent keys
+ declare => 0, # predeclare vars? allows refs to root vars if 0
sortkeys => {},
- verbose => 1, # use long names and detailed fill ins
- dumpglob => 1, # dump glob contents
+ verbose => 1, # use long names and detailed fill ins
+ dumpglob => 1, # dump glob contents
deparseglob => 1,
- deparse => 1, # deparse code refs?
- freezer => 'DDS_freeze', # default freezer
- freeze_class => {}, # freeze classes
+ deparse => 1, # deparse code refs?
+ freezer => 'DDS_freeze', # default freezer
+ freeze_class => {}, # freeze classes
- rle => 1, # run length encode arrays
- ignore => {}, # ignore classes
- indentcols => 2, # indent this number of cols
- ro => 1, # track readonly vars
- dualvars => 1, # dump dualvars
- eclipsename => "%s_eclipse_%d",
+ rle => 1, # run length encode arrays
+ ignore => {}, # ignore classes
+ indentcols => 2, # indent this number of cols
+ ro => 1, # track readonly vars
+ dualvars => 1, # dump dualvars
+ eclipsename => "%s_eclipse_%d",
- purity => 1, # test
+ purity => 1, # test
- terse => 0,
+ terse => 0,
# use this if deparse is 0
- codestub => 'sub { Carp::confess "Dumped code stub!" }',
- formatstub => 'do{ local *F; eval "format F =\nFormat Stub\n.\n"; *F{FORMAT} }',
+ codestub => 'sub { Carp::confess "Dumped code stub!" }',
+ formatstub =>
+ 'do{ local *F; eval "format F =\nFormat Stub\n.\n"; *F{FORMAT} }',
+
# use these opts if deparse is 1
- deparseopts => ["-sCi2v'Useless const omitted'"],
- special => 0,
+ deparseopts => ["-sCi2v'Useless const omitted'"],
+ special => 0,
# not yet implemented
- array_warn => 10_000, # warn if an array has more than this number of elements
- array_chop => 32_767, # chop arrays over this size
- array_max => 1_000_000, # die if arrays have more than this size
- smart_array => 1, # special handling of very large arrays
- # with hashes as their 0 index. (pseudo-hash error detection)
+ array_warn =>
+ 10_000, # warn if an array has more than this number of elements
+ array_chop => 32_767, # chop arrays over this size
+ array_max => 1_000_000, # die if arrays have more than this size
+ smart_array => 1, # special handling of very large arrays
+ # with hashes as their 0 index. (pseudo-hash error detection)
},
- debug => 0,
+ debug => 0,
cataloged => 0,
- ref_id => 0,
- sv_id => 0
+ ref_id => 0,
+ sv_id => 0
}, $class;
return $self;
}
sub _safe_self {
- my $self = shift;
- unless ( ref $self ) {
- $self = $self->new();
+ my $self= shift;
+ unless (ref $self) {
+ $self= $self->new();
}
return $self;
}
@@ -802,10 +818,10 @@ sub DDumper {
#sub _is_utf8 { length $_[0] != do { use bytes; length $_[0] } }
BEGIN {
- my $numeric_rex=qr/\A-?(?:0|[1-9]\d*)(\.\d+(?<!0))?\z/;
+ my $numeric_rex= qr/\A-?(?:0|[1-9]\d*)(\.\d+(?<!0))?\z/;
# used by _qquote below
- my %esc = (
+ my %esc= (
"\a" => "\\a",
"\b" => "\\b",
"\t" => "\\t",
@@ -820,35 +836,37 @@ BEGIN {
# put a string value in double quotes
# Fixes by [ysth]
sub _qquote {
- my $str = shift;
+ my $str= shift;
my @ret;
while (length($str)) {
- local($_)=substr($str,0,72,"");
+ local ($_)= substr($str, 0, 72, "");
s/([\\\"\@\$])/\\$1/g;
unless (/[^ !""\#\$%&''()*+,\-.\/0-9:;<=>?\@A-Z[\\\]^_`a-z{|}~]/) {
- push @ret,qq("$_"); # fast exit
+ push @ret, qq("$_"); # fast exit
next;
}
-
s/([\a\b\t\n\f\r\e])/$esc{$1}/g;
- if ( ord('^') == 94 ) {
+ if (ord('^') == 94) {
+
# ascii / utf8
# no need for 3 digits in escape if followed by a digit
s/([\0-\037])(?!\d) / sprintf '\\%o', ord($1)/xeg;
s/([\0-\037\177]) / sprintf '\\%03o', ord($1)/xeg;
if (length $_ != do { use bytes; length $_ }) {
- use utf8; #perl 5.6.1 needs this, 5.9.2 doesn't. sigh
+ use utf8; #perl 5.6.1 needs this, 5.9.2 doesn't. sigh
s/([\200-\377]) / sprintf '\\%03o', ord($1)/xeg;
s/([^\040-\176])/ sprintf '\\x{%x}', ord($1)/xeg;
- } else {
+ }
+ else {
# must not be under "use utf8" for 5.6.x
s/([\200-\377]) / sprintf '\\%03o', ord($1)/xeg;
}
- } else {
+ }
+ else {
# ebcdic
s{([^ !""\#\$%&''()*+,\-.\/0-9:;<=>?\@A-Z[\\\]^_`a-z{|}~])(?!\d)}
{
@@ -858,18 +876,18 @@ BEGIN {
{'\\'.sprintf('%03o',ord($1))}eg;
}
- push @ret,qq("$_");
+ push @ret, qq("$_");
}
- return join ".\n\t",@ret;
+ return join ".\n\t", @ret;
}
-
# single quote
sub _quote {
- my $v = join "", @_;
- if ($v=~$numeric_rex) {
+ my $v= join "", @_;
+ if ($v =~ $numeric_rex) {
return $v;
- } elsif ($v!~/[^\x20-\x7E]/) {
+ }
+ elsif ($v !~ /[^\x20-\x7E]/) {
$v =~ s/([\\''])/\\$1/g;
return "'$v'";
}
@@ -878,61 +896,65 @@ BEGIN {
# quote a key
sub _quotekey {
- my $key = shift;
+ my $key= shift;
if (!defined($key) or $key eq '') {
- return '""'
- } elsif ($key=~$numeric_rex or $key =~ /\A-?[A-Za-z_]\w*\z/) {
- return $key
- } else {
+ return '""';
+ }
+ elsif ($key =~ $numeric_rex or $key =~ /\A-?[A-Za-z_]\w*\z/) {
+ return $key;
+ }
+ else {
_qquote($key);
}
}
}
-my %ttrans = (
- reftype( {} ) => '%',
- reftype( [] ) => '@',
- reftype( \ 'foo' ) => '$',
- reftype( \\'foo' ) => '$', # REF
- reftype( sub{} ) => '&',
- '' => '$',
+my %ttrans= (
+ reftype({}) => '%',
+ reftype([]) => '@',
+ reftype(\ 'foo') => '$',
+ reftype(\\'foo') => '$', # REF
+ reftype(sub { }) => '&',
+ '' => '$',
);
-
sub _make_name {
- my ( $self, $obj, $indx ) = @_;
+ my ($self, $obj, $indx)= @_;
+
#warn Dumper($self->{unames})."'$self->{unames}'
# : @{$self->{unames}||[]} @{[defined $indx ? $indx : '-']}";
- my $uname = ( $self->{unames} || [] )->[ $indx || 0 ];
+ my $uname= ($self->{unames} || [])->[ $indx || 0 ];
unless ($uname) {
- my $name = blessed($_[1])
- || reftype($_[1])
- || ((readonly($_[1]) && (\$_[1] != \undef)) ? "RO" : "VAR");
+ my $name=
+ blessed($_[1])
+ || reftype($_[1])
+ || ((readonly($_[1]) && (\$_[1] != \undef)) ? "RO" : "VAR");
unless ($self->{style}{verbose}) {
- my $n=1;
- (my $abr=$name)=~s/(\w)\w*::/$1/g;
- $self->{type_abrv}{$name}||=$name;
- while ($n<=length($abr) and
- $self->{type_abrv}{substr($abr,0,$n)} and
- $self->{type_abrv}{substr($abr,0,$n)} ne $name) {
+ my $n= 1;
+ (my $abr= $name) =~ s/(\w)\w*::/$1/g;
+ $self->{type_abrv}{$name} ||= $name;
+ while ( $n <= length($abr)
+ and $self->{type_abrv}{ substr($abr, 0, $n) }
+ and $self->{type_abrv}{ substr($abr, 0, $n) } ne $name)
+ {
$n++;
}
- if ($n<=length($abr)) {
- $self->{type_abrv}{substr($abr,0,$n)}=$name;
- return '$' .
- substr($abr,0,$n) .
- ( ++$self->{type_ids}{$name} );
+ if ($n <= length($abr)) {
+ $self->{type_abrv}{ substr($abr, 0, $n) }= $name;
+ return '$' . substr($abr, 0, $n) . (++$self->{type_ids}{$name});
}
}
$name =~ s/::/_/g;
- ($name)=$name=~/(\w+)/; #take the first word;
- return '$' . $name . ( ++$self->{type_ids}{$name} );
- } elsif ( $uname =~ /^[-*]/ ) {
- my $type = reftype( $_[1] ) || '';
+ ($name)= $name =~ /(\w+)/; #take the first word;
+ return '$' . $name . (++$self->{type_ids}{$name});
+ }
+ elsif ($uname =~ /^[-*]/) {
+ my $type= reftype($_[1]) || '';
$uname =~ s//$ttrans{$type}/;
$uname;
- } else {
+ }
+ else {
return '$' . $uname;
}
}
@@ -945,16 +967,16 @@ sub _make_name {
#=cut
sub diag {
- my $self=shift;
- my $handle=shift || \*STDOUT;
+ my $self= shift;
+ my $handle= shift || \*STDOUT;
print $handle "+---+\n";
my $oidx;
- foreach my $idx (1..$self->{sv_id}) {
+ foreach my $idx (1 .. $self->{sv_id}) {
print $handle $self->diag_sv_idx($idx);
}
print "-----\n" if $self->{ref_id} and $self->{sv_id};
- foreach my $idx (1..($self->{ref_id}||0)) {
+ foreach my $idx (1 .. ($self->{ref_id} || 0)) {
print $handle $self->diag_ref_idx($idx);
}
@@ -963,123 +985,126 @@ sub diag {
}
sub remove_deref {
- my $var=shift;
+ my $var= shift;
- my ($brace,$rest,$sigil);
- if ($var=~s/^([\@\%\$])(?=\$)//) {
- ($sigil,$brace)=($1,$var)
- } else {
+ my ($brace, $rest, $sigil);
+ if ($var =~ s/^([\@\%\$])(?=\$)//) {
+ ($sigil, $brace)= ($1, $var);
+ }
+ else {
local $@;
- ($brace,$rest,$sigil)= Text::Balanced::extract_bracketed( $var, '{q}',qr/[\@\%\$]/ );
+ ($brace, $rest, $sigil)=
+ Text::Balanced::extract_bracketed($var, '{q}', qr/[\@\%\$]/);
}
if ($brace and !$rest) {
- $brace=~s/^\{(.*)\}$/$1/;
- return wantarray ? ($sigil,$brace) : $brace;
- } else {
+ $brace =~ s/^\{(.*)\}$/$1/;
+ return wantarray ? ($sigil, $brace) : $brace;
+ }
+ else {
return;
}
}
-my %tname=qw(HASH % ARRAY @ SCALAR $ REF $);
+my %tname= qw(HASH % ARRAY @ SCALAR $ REF $);
sub _build_name {
- my ( $self, $name, $type, $val ) = @_;
+ my ($self, $name, $type, $val)= @_;
- $DEBUG>1 and print STDOUT " _build_name( $name '$type' => ";
- $type=$tname{$type} if $tname{$type};
- if ($type=~/[[{]/) {
+ $DEBUG > 1 and print STDOUT " _build_name( $name '$type' => ";
+ $type= $tname{$type} if $tname{$type};
+ if ($type =~ /[[{]/) {
- $name=~s/[\@\%]\$/\$/;
- my ($sigil,$brace)=remove_deref($name);
- if ( $name =~ /^([\@\%\$])(\w+)$/ or $sigil
- or $name=~/^\*.*\{(?:SCALAR|HASH|ARRAY)\}$/
- )
+ $name =~ s/[\@\%]\$/\$/;
+ my ($sigil, $brace)= remove_deref($name);
+ if ( $name =~ /^([\@\%\$])(\w+)$/
+ or $sigil
+ or $name =~ /^\*.*\{(?:SCALAR|HASH|ARRAY)\}$/)
{
- $name .= '->' if !($name =~ s/^[\@\%]/\$/)
- or $sigil;
- $name=~s/^\$(\$.*)->$/\$\{$1\}->/;
+ $name .= '->'
+ if !($name =~ s/^[\@\%]/\$/)
+ or $sigil;
+ $name =~ s/^\$(\$.*)->$/\$\{$1\}->/;
}
- $DEBUG>1 and print STDOUT "$name => ";
+ $DEBUG > 1 and print STDOUT "$name => ";
- if ( $type eq '[' ) {
+ if ($type eq '[') {
$name .= "[$val]";
- } elsif ( $type eq '{' ) {
+ }
+ elsif ($type eq '{') {
$name .= "{" . _quotekey($val) . "}";
- } else {
+ }
+ else {
Carp::confess "Fallen off the end of the world...";
}
- } elsif ( $type =~ /^[\@\%\$]$/ ) {
- $name = "{$name}"
- if $name =~ /[\[\{]/ or $name=~/^\*/;
- $name = $type . $name
- unless substr( $name, 0, 1 ) eq $type and $type ne '$';
+ }
+ elsif ($type =~ /^[\@\%\$]$/) {
+ $name= "{$name}"
+ if $name =~ /[\[\{]/ or $name =~ /^\*/;
+ $name= $type . $name
+ unless substr($name, 0, 1) eq $type and $type ne '$';
- } else {
- no warnings; # XXX - why is this here? Yves
+ }
+ else {
+ no warnings; # XXX - why is this here? Yves
Carp::confess "unimplemented _build_name";
}
- $DEBUG>1 and print "$name )\n";
+ $DEBUG > 1 and print "$name )\n";
$name;
}
sub _reset {
- my $self=shift;
+ my $self= shift;
foreach my $key (keys %$self) {
- next unless $key=~/^(sv|ref|fix|cat|type|names|reqs|cache)/;
+ next unless $key =~ /^(sv|ref|fix|cat|type|names|reqs|cache)/;
delete $self->{$key};
}
- $self->{sv_id}=$self->{ref_id}=0;
+ $self->{sv_id}= $self->{ref_id}= 0;
$self;
}
sub diag_sv_idx {
- my $self=shift;
- my $idx=shift;
- my $prefix=shift||'';
- my $oidx=$self->{ref}{$self->{sva}[$idx]};
- my $ret=$prefix.
- sprintf "S%s%2d : %#x(c%2d|%2d) Dp:%2d %s Du:%s => %s %s %s %s\n",
- ($self->{special}{$idx} ? '*' : ' '),$idx,
+ my $self= shift;
+ my $idx= shift;
+ my $prefix= shift || '';
+ my $oidx= $self->{ref}{ $self->{sva}[$idx] };
+ my $ret= $prefix
+ . sprintf "S%s%2d : %#x(c%2d|%2d) Dp:%2d %s Du:%s => %s %s %s %s\n",
+ ($self->{special}{$idx} ? '*' : ' '), $idx,
(map { $self->{$_}[$idx] } qw( sva svc svt svd )),
($self->{svro}[$idx] ? 'RO ' : 'RW'),
- (!$self->{svdu}[$idx]
- ? '-'
- : defined ${$self->{svdu}[$idx]}
- ? ${$self->{svdu}[$idx]}
- : '?'),
- $self->{svn}[$idx],
- (defined $self->{unames}[$idx-1] ? "($self->{unames}[$idx-1])" : ""),
- (($oidx) ? "< $self->{refn}[$oidx] >" : ""),
- ($self->{svon}{$idx} ? ": $self->{svon}{$idx}" : "")
- ;
+ (
+ !$self->{svdu}[$idx] ? '-'
+ : defined ${ $self->{svdu}[$idx] } ? ${ $self->{svdu}[$idx] }
+ : '?'
+ ),
+ $self->{svn}[$idx], (
+ defined $self->{unames}[ $idx - 1 ] ? "($self->{unames}[$idx-1])" : ""),
+ (($oidx) ? "< $self->{refn}[$oidx] >" : ""),
+ ($self->{svon}{$idx} ? ": $self->{svon}{$idx}" : "");
if ($prefix and $oidx) {
- $ret.=$prefix.$self->diag_ref_idx($oidx);
+ $ret .= $prefix . $self->diag_ref_idx($oidx);
}
$ret;
}
sub diag_ref_idx {
- my $self=shift;
- my $idx=shift;
- my $oidx=$self->{sv}{$self->{refa}[$idx]};
+ my $self= shift;
+ my $idx= shift;
+ my $oidx= $self->{sv}{ $self->{refa}[$idx] };
sprintf "R %2d : %#x(c%2d|%2d) Dp:%2d Du:%s => %s %s\n",
$idx,
- (map {
- defined $self->{$_}[$idx] ? $self->{$_}[$idx] : -1
- } qw(refa refc reft refd )),
- (!$self->{refdu}[$idx]
- ? '-'
- : defined ${$self->{refdu}[$idx]}
- ? ${$self->{refdu}[$idx]}
- : '?'),
+ (map { defined $self->{$_}[$idx] ? $self->{$_}[$idx] : -1 }
+ qw(refa refc reft refd )), (
+ !$self->{refdu}[$idx] ? '-'
+ : defined ${ $self->{refdu}[$idx] } ? ${ $self->{refdu}[$idx] }
+ : '?'
+ ),
$self->{refn}[$idx],
- (($oidx) ? " < $self->{svn}[$oidx] >" : "")
- ;
+ (($oidx) ? " < $self->{svn}[$oidx] >" : "");
}
-
=item Dump
=item Dump VALUES
@@ -1154,34 +1179,36 @@ Hopefully this should make method use more or less DWIM.
my %args_insideout;
sub DESTROY {
- my $self=shift;
- delete $args_insideout{Data::Dump::Streamer::refaddr $self} if $self;
+ my $self= shift;
+ delete $args_insideout{ Data::Dump::Streamer::refaddr $self} if $self;
}
sub Dump {
my $obj;
- if ( blessed($_[0]) and blessed($_[0]) eq __PACKAGE__ ) {
- $obj=shift;
+ if (blessed($_[0]) and blessed($_[0]) eq __PACKAGE__) {
+ $obj= shift;
}
if (@_) {
- if ( defined wantarray and !wantarray ) {
+ if (defined wantarray and !wantarray) {
$obj ||= __PACKAGE__->new();
$obj->_make_args(@_);
return $obj;
- } else {
- $obj||=__PACKAGE__;
+ }
+ else {
+ $obj ||= __PACKAGE__;
return $obj->Data(@_)->Out();
}
- } else {
+ }
+ else {
if ($obj) {
return $obj->Out();
- } else {
+ }
+ else {
return __PACKAGE__->new();
}
}
}
-
=item DumpLex VALUES
DumpLex is similar to Dump except it will try to automatically determine
@@ -1196,18 +1223,19 @@ similar wrapper around L<Data::Dumper>.
=cut
-
sub DumpLex {
- if ( ! $HasPadWalker ) {
+ if (!$HasPadWalker) {
+
#warn( "Can't use DumpLex without ".
# "PadWalker v1.0 or later installed.");
goto &Dump;
}
my $obj;
- if ( blessed($_[0]) and blessed($_[0]) eq __PACKAGE__ ) {
- $obj=shift;
+ if (blessed($_[0]) and blessed($_[0]) eq __PACKAGE__) {
+ $obj= shift;
}
my @names;
+
# = map {
# PadWalker::var_name(1,\$_)
# || PadWalker::var_name(1,\$_)
@@ -1217,28 +1245,27 @@ sub DumpLex {
#if ( !@names && @_ ) {
my %pad_vars;
- foreach my $pad ( PadWalker::peek_my(1),
- PadWalker::peek_our(1)
- ){
- while (my ($var,$ref) = each %$pad) {
+ foreach my $pad (PadWalker::peek_my(1), PadWalker::peek_our(1)) {
+ while (my ($var, $ref)= each %$pad) {
$pad_vars{ refaddr $ref } ||= $var;
}
}
foreach (@_) {
my $name;
- INNER:foreach ( \$_, $_ ) {
- $name=$pad_vars{refaddr $_}
+ INNER: foreach (\$_, $_) {
+ $name= $pad_vars{ refaddr $_}
and last INNER;
}
push @names, $name;
}
- if ( defined wantarray and !wantarray ) {
+ if (defined wantarray and !wantarray) {
$obj ||= __PACKAGE__->new();
$obj->_make_args(@_);
$obj->Names(@names);
return $obj;
- } else {
- $obj||=__PACKAGE__;
+ }
+ else {
+ $obj ||= __PACKAGE__;
return $obj->Names(@names)->Data(@_)->Out();
}
}
@@ -1253,11 +1280,10 @@ passed to L<Names()|/Names>.
=cut
-
sub DumpVars {
my $obj;
- if ( blessed($_[0]) and blessed($_[0]) eq __PACKAGE__ ) {
- $obj=shift;
+ if (blessed($_[0]) and blessed($_[0]) eq __PACKAGE__) {
+ $obj= shift;
}
if (@_ % 2) {
warnings::warnif "Odd number of arguments in DumpVars";
@@ -1265,99 +1291,100 @@ sub DumpVars {
}
my @names;
my @args;
- for ( 0 .. $#_/2 ) {
- $names[$_]=$_[$_*2];
- $args[$_]=$_*2+1;
+ for (0 .. $#_ / 2) {
+ $names[$_]= $_[ $_ * 2 ];
+ $args[$_]= $_ * 2 + 1;
}
+
#die "@_:@names|@args";
- if ( defined wantarray and !wantarray ) {
+ if (defined wantarray and !wantarray) {
$obj ||= __PACKAGE__->new();
$obj->_make_args(@_[@args]);
$obj->Names(@names);
return $obj;
- } else {
- $obj||=__PACKAGE__;
+ }
+ else {
+ $obj ||= __PACKAGE__;
return $obj->Data(@_[@args])->Names(@names)->Out();
}
}
-
sub _reg_ref {
- my ($self,$item,$depth,$name,$cnt,$arg)=@_;
+ my ($self, $item, $depth, $name, $cnt, $arg)= @_;
- warn "_ref_ref($depth,$name,$cnt)\n" if $DEBUG;
+ print "_reg_ref($depth,$name,$cnt)\n" if $DEBUG;
- my $addr=refaddr $item;
- $arg->{raddr}=$addr if $arg;
+ my $addr= refaddr $item;
+ $arg->{raddr}= $addr if $arg;
my $idx;
- unless ($idx=$self->{ref}{$addr}) {
- $idx=$self->{ref}{$addr}=++$self->{ref_id};
- $arg->{ridx}=$idx if $arg;
- $self->{refn}[$idx]=$name;
- $self->{refd}[$idx]=$depth;
- $self->{refa}[$idx]=$addr;
- $self->{refc}[$idx]=$cnt;
- return wantarray ? ($idx,0) : $idx
+ unless ($idx= $self->{ref}{$addr}) {
+ $idx= $self->{ref}{$addr}= ++$self->{ref_id};
+ $arg->{ridx}= $idx if $arg;
+ $self->{refn}[$idx]= $name;
+ $self->{refd}[$idx]= $depth;
+ $self->{refa}[$idx]= $addr;
+ $self->{refc}[$idx]= $cnt;
+ return wantarray ? ($idx, 0) : $idx;
}
$self->{reft}[$idx]++;
- $arg->{ridx}=$idx if $arg;
- return wantarray ? ($idx,1) : undef;
+ $arg->{ridx}= $idx if $arg;
+ return wantarray ? ($idx, 1) : undef;
}
-
sub _reg_scalar {
- my ($self,$item,$depth,$cnt,$ro,$name,$arg)=@_;
- Carp::cluck $name if $name=~/^\$\*/;
- my $addr=refaddr \$_[1];
+ my ($self, $item, $depth, $cnt, $ro, $name, $arg)= @_;
+ Carp::cluck $name if $name =~ /^\$\*/;
+ my $addr= refaddr \$_[1];
my $idx;
- $arg->{addr}=$addr if $arg;
- unless ($idx=$self->{sv}{$addr}) {
- $idx=$self->{sv}{$addr}=++$self->{sv_id};
- $self->{svd}[$idx]=$depth;
- $self->{sva}[$idx]=$addr;
- $self->{svro}[$idx]=$ro;
- $self->{svc}[$idx]=$cnt;
- $self->{svw}{$addr}=!0
+ $arg->{addr}= $addr if $arg;
+ unless ($idx= $self->{sv}{$addr}) {
+ $idx= $self->{sv}{$addr}= ++$self->{sv_id};
+ $self->{svd}[$idx]= $depth;
+ $self->{sva}[$idx]= $addr;
+ $self->{svro}[$idx]= $ro;
+ $self->{svc}[$idx]= $cnt;
+ $self->{svw}{$addr}= !0
if isweak($_[1]);
- ($self->{svn}[$idx]=$name)=~s/^[\@\%\&]/\$/;
+ ($self->{svn}[$idx]= $name) =~ s/^[\@\%\&]/\$/;
if ($self->{svn}[$idx] ne $name) {
- $self->{svn}[$idx].="_"; #XXX
- #warn "$self->{svn}[$idx] ne $name"
- $self->{svon}{$idx}=$name;
+ $self->{svn}[$idx] .= "_"; #XXX
+ #warn "$self->{svn}[$idx] ne $name"
+ $self->{svon}{$idx}= $name;
}
- } else{
- if ($DEBUG>9) {
+ }
+ else {
+ if ($DEBUG > 9) {
print $self->diag_sv_idx($idx);
- print "$name is already registered as $self->{svn}[$idx] ".
- "Depth ($self->{svd}[$idx]) $depth\n";
+ print "$name is already registered as $self->{svn}[$idx] "
+ . "Depth ($self->{svd}[$idx]) $depth\n";
}
- if ($self->{svn}[$idx]=~/^\$\{?\$/ and $name!~/^\$\{?\$/) {
- $self->{svn}[$idx]=$name;
+ if ($self->{svn}[$idx] =~ /^\$\{?\$/ and $name !~ /^\$\{?\$/) {
+ $self->{svn}[$idx]= $name;
}
}
$self->{svt}[$idx]++;
- $arg->{idx}=$idx if $arg;
+ $arg->{idx}= $idx if $arg;
Carp::confess "Dupe name!" if $self->{svrt}{$name};
- $self->{svrt}{$name}=$idx;
+ $self->{svrt}{$name}= $idx;
return $name;
}
-*Precise=\&Dump;
+*Precise= \&Dump;
# we make an array of hashes containing useful info about the arguments
sub _make_args {
- my $self=shift;
- $args_insideout{refaddr $self}= [
- map {
- {
- item => \$_[$_],
- ro => readonly($_[$_]),
- refcnt => sv_refcount($_[$_]),
- }
- } 0..$#_
- ];
- return $args_insideout{refaddr $self}
+ my $self= shift;
+ $args_insideout{ refaddr $self}= [
+ map {
+ {
+ item => \$_[$_],
+ ro => readonly($_[$_]),
+ refcnt => sv_refcount($_[$_]),
+ }
+ } 0 .. $#_
+ ];
+ return $args_insideout{ refaddr $self};
}
=back
@@ -1382,12 +1409,13 @@ Returns $self.
=cut
-
sub _add_queue {
- my ($self,$queue,$type,$item,$depth,$name,$rcount,$arg)=@_;
- if (substr($type,0,1) ne '*') {
- push @$queue,[\$item,$depth,$name,$rcount,$arg];
- } elsif($self->{style}{dumpglob}) {
+ my ($self, $queue, $type, $item, $depth, $name, $rcount, $arg)= @_;
+ print "add_queue($name)\n" if $DEBUG;
+ if (substr($type, 0, 1) ne '*') {
+ push @$queue, [ \$item, $depth, $name, $rcount, $arg ];
+ }
+ elsif ($self->{style}{dumpglob}) {
local @_;
foreach my $t ($self->_glob_slots('FORMAT')) {
@@ -1396,53 +1424,47 @@ sub _add_queue {
#$self->_reg_scalar(*$item{$t},$depth+1,sv_refcount(*$item{$t}),
# readonly(*$item{$t}),'*'.$name."{$t}");
- my $v=*$item{$t};
+ my $v= *$item{$t};
next unless defined $v;
next if $t eq 'SCALAR' and !defined($$v);
- push @$queue,[
- \*$item{$t},
- $depth+1,
- $type."{$t}",
- refcount(\*$item{$t})
- ];
+ push @$queue, [
+ \*$item{$t}, $depth + 1,
+ $type . "{$t}", refcount(\*$item{$t}) ];
}
}
+
#use Scalar::Util qw(weaken);
$self;
}
sub Data {
- my $self=shift->_safe_self;
+ my $self= shift->_safe_self;
my $args;
- print "Data(".scalar(@_)." vars)\n"
+ print "Data(" . scalar(@_) . " vars)\n"
if $DEBUG;
if (@_) {
$self->_reset;
$self->_make_args(@_);
- } elsif ( $self->{cataloged} ) {
+ }
+ elsif ($self->{cataloged}) {
$self->_reset;
}
- $args= $args_insideout{refaddr $self}
+ $args= $args_insideout{ refaddr $self}
|| Carp::carp "No arguments!";
- my $pass=1;
-PASS:{
+ my $pass= 1;
+ PASS: {
my @queue;
- my $idx=0;
+ my $idx= 0;
foreach my $arg (@$args) {
+
#($self,$item,$depth,$cnt,$ro,$name)
- my $make_name=$self->_make_name(${ $arg->{item} },$idx++);
- my $name=$self->_reg_scalar(
- ${ $arg->{item} },
- 1,
- $arg->{refcnt},
- $arg->{ro},
- $make_name,
- $arg
- );
- $arg->{name}=$name;
- if (my $type=reftype_or_glob ${ $arg->{item} }) {
- $self->_add_queue(\@queue, $type, ${ $arg->{item} }, 2,
- $name, refcount ${ $arg->{item} },$arg)
+ my $make_name= $self->_make_name(${ $arg->{item} }, $idx++);
+ my $name= $self->_reg_scalar(${ $arg->{item} },
+ 1, $arg->{refcnt}, $arg->{ro}, $make_name, $arg);
+ $arg->{name}= $name;
+ if (my $type= reftype_or_glob ${ $arg->{item} }) {
+ $self->_add_queue(\@queue, $type, ${ $arg->{item} },
+ 2, $name, refcount ${ $arg->{item} }, $arg);
}
}
@@ -1451,492 +1473,572 @@ PASS:{
my %lex_name;
my %lex_special;
+ ITEM:
while (@queue) {
+
# If the scalar (container) is of any interest it is
# already registered by the time we see it here.
# at this point we only care about the contents, not the
# container.
- print Data::Dumper->new([\@queue],['*queue'])->Maxdepth(3)->Dump
- if $DEBUG>=10;
-
- my ($ritem,
- $cdepth,
- $cname,
- $rcnt,
- $arg)=@{shift @queue};
+ print Data::Dumper->new([ \@queue ], ['*queue'])->Maxdepth(3)->Dump
+ if $DEBUG >= 10;
+ my ($ritem, $cdepth, $cname, $rcnt, $arg)= @{ shift @queue };
-
- my ($frozen,$item,$raddr,$class);
- DEQUEUE:{
- $item=$$ritem;
- $raddr=refaddr($item);
- $class=blessed($item);
+ my ($frozen, $item, $raddr, $class);
+ DEQUEUE: {
+ $item= $$ritem;
+ $raddr= refaddr($item);
+ $class= blessed($item);
if ($self->{ref_fz}{$raddr}) {
print "Skipping frozen element $raddr\n" if $DEBUG;
- next;
+ next ITEM;
+ }
+ if ($cname =~ /^\*DB::args/) {
+ print "Skipping \*DB::args\n" if $DEBUG;
+ next ITEM;
}
- $DEBUG and
- print "Q-> $item $cdepth $cname $rcnt ($raddr)\n";
+ $DEBUG
+ and print "Q-> $item $cdepth $cname $rcnt ($raddr)\n";
unless ($raddr) {
- $DEBUG and
- print " Skipping '$cname' as it isn't a reference.\n";
- next;
+ $DEBUG
+ and print
+ " Skipping '$cname' as it isn't a reference.\n";
+ next ITEM;
}
last DEQUEUE if $frozen;
- $frozen=1;
- if ($self->{style}{ignore}{"#$raddr"} || ($class&& $self->{style}{ignore}{".$class"})) {
- $DEBUG and
- print "Ignoring '$cname' as its class ($class) in ".
- "our ignore list.\n";
- next;
- } elsif ($class && !$self->{"cache_skip_freeze"}{$class}) {
+ $frozen= 1;
+ if ($self->{style}{ignore}{"#$raddr"}
+ || ($class && $self->{style}{ignore}{".$class"}))
+ {
+ $DEBUG
+ and print "Ignoring '$cname' as its class ($class) in "
+ . "our ignore list.\n";
+ next ITEM;
+ }
+ elsif ($class && !$self->{"cache_skip_freeze"}{$class}) {
my $freezer= $self->{cache_freeze_class}{$class};
- my ( $proxy, $thaw, $postop );
- if (! defined $freezer ) {
- for ( $self->{style}{freeze_class}{$class},
- $self->{style}{freezer},
- 'DDS_freeze' )
+ my ($proxy, $thaw, $postop);
+ if (!defined $freezer) {
+ TRY_FREEZE:
+ for ($self->{style}{freeze_class}{$class},
+ $self->{style}{freezer}, 'DDS_freeze')
{
$freezer= $_;
- if ( $freezer ) {
+ if ($freezer) {
if (ref $freezer) {
eval {
- ($proxy,$thaw,$postop)= $freezer->($$ritem);
+ ($proxy, $thaw, $postop)=
+ $freezer->($$ritem);
};
- last if !$@;
- } elsif ( $class->can($freezer) ) {
+ last TRY_FREEZE if !$@;
+ }
+ elsif ($class->can($freezer)) {
eval {
- ($proxy,$thaw,$postop)= ${$ritem}->$freezer();
+ ($proxy, $thaw, $postop)=
+ ${$ritem}->$freezer();
};
- last if !$@;
+ last TRY_FREEZE if !$@;
}
- } elsif ( defined $freezer ) {
- last;
}
+ elsif (defined $freezer) {
+ last TRY_FREEZE;
+ }
+ }
+ if (!defined $proxy) {
+ $self->{"cache_skip_freeze"}{$class}= 1;
}
- if (! defined $proxy) {
- $self->{"cache_skip_freeze"}{$class}=1;
- } else {
+ else {
$self->{cache_freeze_class}{$class}= $freezer;
}
- } elsif (ref $freezer) {
- ($proxy,$thaw)= $freezer->($$ritem);
- } else {
- ($proxy,$thaw)= ${$ritem}->$freezer();
}
- if ( $thaw ) {
+ elsif (ref $freezer) {
+ ($proxy, $thaw)= $freezer->($$ritem);
+ }
+ else {
+ ($proxy, $thaw)= ${$ritem}->$freezer();
+ }
+ if ($thaw) {
$self->{ref_thaw}{$raddr}= $thaw;
}
- if ( $postop ) {
+ if ($postop) {
$self->{ref_postop}{$raddr}= $postop;
}
- if ( refaddr($proxy) != $raddr ) {
+ if (refaddr($proxy) != $raddr) {
$self->{ref_fz}{$raddr}= $proxy;
$ritem= \$proxy;
if (ref $proxy) {
redo DEQUEUE;
- } else {
- next;
}
}
}
+ } # DEQUEUE
- }
+ my ($idx, $dupe)=
+ $self->_reg_ref($item, $cdepth, $cname, $rcnt, $arg);
- my ($idx,$dupe)=$self->_reg_ref($item,$cdepth,$cname,$rcnt,$arg);
- $DEBUG and print " Skipping '$cname' as it is a dupe of ".
- "$self->{refn}[$idx]\n"
+ $DEBUG
+ and print " Skipping '$cname' as it is a dupe of "
+ . "$self->{refn}[$idx]\n"
if $dupe;
- $DEBUG>9 and $self->diag;
+ $DEBUG > 9 and $self->diag;
next if $dupe;
-
- my $reftype=reftype $item;
- my $cnt=refcount($item);
- my $overloaded=undef;
- my $isoverloaded=0;
+ my $reftype= reftype $item;
+ my $cnt= refcount($item);
+ my $overloaded= undef;
+ my $isoverloaded= 0;
if (defined $class and overload::Overloaded($item)) {
- disable_overloading( $item );
+ disable_overloading($item);
$overloaded= $class;
$isoverloaded= 1;
}
-
- if ( $reftype eq 'SCALAR' or
- $reftype eq 'REF' or
- $reftype eq 'GLOB' )
+ if ( $reftype eq 'SCALAR'
+ or $reftype eq 'REF'
+ or $reftype eq 'GLOB')
{
- my $name=$self->_build_name($cname,'$');
- my $cnt=sv_refcount($$item);
- if ($cnt>1) {
- $self->_reg_scalar($$item,$cdepth+1,$cnt,
- readonly($$item),$name);
+ my $name= $self->_build_name($cname, '$');
+ my $cnt= sv_refcount($$item);
+ if ($cnt > 1) {
+ $self->_reg_scalar($$item, $cdepth + 1,
+ $cnt, readonly($$item), $name);
}
- if (my $type=reftype_or_glob $$item) {
- $self->_add_queue(\@queue,$type,$$item,
- $cdepth+2,$name,$cnt)
+ if (my $type= reftype_or_glob $$item) {
+ $self->_add_queue(\@queue, $type, $$item, $cdepth + 2,
+ $name, $cnt);
}
- } elsif ($reftype eq 'ARRAY') {
- foreach my $idx (0..$#$item) {
- my $name=$self->_build_name($cname,'[',$idx);
- my $cnt=sv_refcount($item->[$idx]);
- if ($cnt>1) {
+ }
+ elsif ($reftype eq 'ARRAY') {
+ foreach my $idx (0 .. $#$item) {
+ my $name= $self->_build_name($cname, '[', $idx);
+ my $cnt= sv_refcount($item->[$idx]);
+ if ($cnt > 1) {
print "refcount($name)==$cnt\n"
- if $DEBUG>9;
- $self->_reg_scalar($item->[$idx],$cdepth+1,$cnt,
- readonly($item->[$idx]),$name);
+ if $DEBUG > 9;
+ $self->_reg_scalar($item->[$idx], $cdepth + 1,
+ $cnt, readonly($item->[$idx]), $name);
}
- if (my $type=reftype_or_glob $item->[$idx]) {
- $self->_add_queue(\@queue,$type,$item->[$idx],
- $cdepth+2,$name,$cnt)
+ if (my $type= reftype_or_glob $item->[$idx]) {
+ $self->_add_queue(\@queue, $type, $item->[$idx],
+ $cdepth + 2,
+ $name, $cnt);
}
}
- } elsif ($reftype eq 'HASH') {
- my $ik=$self->{style}{indentkeys};
- my ($keyary, $thaw)= $self->_get_keys($item,0,$raddr,$class);
+ }
+ elsif ($reftype eq 'HASH') {
+ my $ik= $self->{style}{indentkeys};
+ my ($keyary, $thaw)= $self->_get_keys($item, 0, $raddr, $class);
if ($thaw) {
$self->{ref_thaw}{$raddr}= $thaw;
}
- my $key_len=0;
- my $key_sum=0;
- my $key_count=0;
+ my $key_len= 0;
+ my $key_sum= 0;
+ my $key_count= 0;
die reftype $keyary if $keyary && reftype($keyary) ne 'ARRAY';
- while ( defined( my $key =
- defined $keyary ? $keyary->[$key_count] : each %$item
- ))
- {
+ while (
+ defined(
+ my $key=
+ defined $keyary
+ ? $keyary->[$key_count]
+ : each %$item
+ )
+ ) {
if ($ik) {
- my $qk=_quotekey($key);
- $key_sum+=length($qk);
- $key_len=length($qk) if $key_len<length($qk);
+ my $qk= _quotekey($key);
+ $key_sum += length($qk);
+ $key_len= length($qk) if $key_len < length($qk);
}
$key_count++;
- my $name=$self->_build_name($cname,'{',$key);
- my $cnt=sv_refcount($item->{$key});
- if ($cnt>1) {
- $self->_reg_scalar($item->{$key},$cdepth+1,$cnt,
- readonly($item->{$key}),$name);
+ my $name= $self->_build_name($cname, '{', $key);
+ my $cnt= sv_refcount($item->{$key});
+ if ($cnt > 1) {
+ $self->_reg_scalar($item->{$key}, $cdepth + 1,
+ $cnt, readonly($item->{$key}), $name);
}
- if (my $type=reftype_or_glob $item->{$key}) {
- $self->_add_queue(\@queue,$type,$item->{$key},
- $cdepth+2,$name,$cnt);
+ if (my $type= reftype_or_glob $item->{$key}) {
+ $self->_add_queue(\@queue, $type, $item->{$key},
+ $cdepth + 2,
+ $name, $cnt);
}
}
- my $avg=$key_count>0 ? $key_sum/$key_count : 0;
- $self->{ref_hklen}{$raddr}=($key_len>8 && (2/3*$key_len)>$avg)
- ? int(0.5+$avg) : $key_len;
- $self->{ref_hkcnt}{$raddr}=$key_count;
+ my $avg= $key_count > 0 ? $key_sum / $key_count : 0;
+ $self->{ref_hklen}{$raddr}=
+ ($key_len > 8 && (2 / 3 * $key_len) > $avg)
+ ? int(0.5 + $avg)
+ : $key_len;
+ $self->{ref_hkcnt}{$raddr}= $key_count;
+
#warn "$raddr => $key_count";
- } elsif ($reftype eq 'CODE') {
+ }
+ elsif ($reftype eq 'CODE') {
if ($pass == 1) {
- my $used=_get_lexicals($item);
+ my $used= _get_lexicals($item);
foreach my $name (keys %$used) {
- next unless $name=~/\D/;
- my $addr=refaddr($used->{$name});
- if ( !$lex_addr{$addr} ) {
- $lex_addr{$addr}=$used->{$name};
- if ( $lex_name{$name} ) {
- my $tmpname=sprintf "%s".$self->{style}{eclipsename},
- substr($name,0,1),
- $self->{style}{eclipsename}=~/^[^%]*%s/
- ? ( substr($name,1),
- ++$lex_special{$name}, )
- : ( ++$lex_special{$name},
- substr($name,1), );
- $lex_name{$tmpname}=$addr;
- $lex_addr2name{$addr}=$tmpname;
- $self->_add_queue(\@queue,reftype_or_glob $used->{$name},
- $used->{$name},$cdepth+1,$tmpname,2);
- } else {
- $lex_name{$name}=$addr;
- $lex_addr2name{$addr}=$name;
- $self->_add_queue(\@queue,reftype_or_glob $used->{$name},
- $used->{$name},$cdepth+1,$name,2);
+ next unless $name =~ /\D/;
+ my $addr= refaddr($used->{$name});
+ if (!$lex_addr{$addr}) {
+ $lex_addr{$addr}= $used->{$name};
+ if ($lex_name{$name}) {
+ my $tmpname=
+ sprintf "%s" . $self->{style}{eclipsename},
+ substr($name, 0, 1),
+ $self->{style}{eclipsename} =~ /^[^%]*%s/
+ ? (substr($name, 1), ++$lex_special{$name},)
+ : (++$lex_special{$name},
+ substr($name, 1),);
+ $lex_name{$tmpname}= $addr;
+ $lex_addr2name{$addr}= $tmpname;
+ $self->_add_queue(
+ \@queue, reftype_or_glob $used->{$name},
+ $used->{$name}, $cdepth + 1,
+ $tmpname, 2
+ );
+ }
+ else {
+ $lex_name{$name}= $addr;
+ $lex_addr2name{$addr}= $name;
+ $self->_add_queue(
+ \@queue, reftype_or_glob $used->{$name},
+ $used->{$name}, $cdepth + 1,
+ $name, 2
+ );
}
}
}
}
- } elsif ($reftype eq 'FORMAT') {
+ }
+ elsif ($reftype eq 'FORMAT') {
+
# Code similar to that of CODE should go here I think.
- } else {
+ }
+ else {
# IO?
- Carp::confess "Data() can't handle '$reftype' objects yet ($item)\n :-(\n"
+ Carp::confess
+ "Data() can't handle '$reftype' objects yet ($item)\n :-(\n"
if $ENV{DDS_STRICT};
}
if ($isoverloaded) {
- restore_overloading( $item, $overloaded );
+ restore_overloading($item, $overloaded);
}
}
- if ( $pass++ == 1 ) {
+ if ($pass++ == 1) {
my %items;
- for my $idx ( 0..$#{$args_insideout{refaddr $self}} ) {
- my $item=$args_insideout{refaddr $self}[$idx];
- $items{ refaddr $item->{item} } = $idx;
+ for my $idx (0 .. $#{ $args_insideout{ refaddr $self} }) {
+ my $item= $args_insideout{ refaddr $self}[$idx];
+ $items{ refaddr $item->{item} }= $idx;
}
my @add;
- my $added=0;
+ my $added= 0;
if (0) {
- @add=keys %lex_addr;
- } else {
+ @add= keys %lex_addr;
+ }
+ else {
for my $addr (keys %lex_addr) {
- if ( exists $items{$addr} ) {
- my $idx = $items{$addr};
- if ( !$self->{unames}[$idx] ){
- for ($self->{unames}[$idx] = $lex_addr2name{$addr}) {
+ if (exists $items{$addr}) {
+ my $idx= $items{$addr};
+ if (!$self->{unames}[$idx]) {
+ for ($self->{unames}[$idx]= $lex_addr2name{$addr}) {
s/^[^\$]/*/; s/^\$//;
}
$added++;
- } else {
- my $new=$self->{unames}[$idx];
- my $old=$lex_addr2name{$addr};
- $new=~s/^(\*)?/substr($old,0,1)/e;
- delete $lex_name{$lex_addr2name{$addr}};
- $lex_addr2name{$addr}=$new;
- $lex_name{$self->{unames}[$idx]} = $addr; # xxx
}
- } else {
- push @add,$addr;
+ else {
+ my $new= $self->{unames}[$idx];
+ my $old= $lex_addr2name{$addr};
+ $new =~ s/^(\*)?/substr($old,0,1)/e;
+ delete $lex_name{ $lex_addr2name{$addr} };
+ $lex_addr2name{$addr}= $new;
+ $lex_name{ $self->{unames}[$idx] }= $addr; # xxx
+ }
+ }
+ else {
+ push @add, $addr;
}
}
}
- @add=sort {$lex_addr2name{$a} cmp $lex_addr2name{$b}} @add;
+ @add= sort { $lex_addr2name{$a} cmp $lex_addr2name{$b} } @add;
- $self->{lexicals}={
- a2n => \%lex_addr2name,
- name => \%lex_name
- };
+ $self->{lexicals}= {
+ a2n => \%lex_addr2name,
+ name => \%lex_name
+ };
if (@add) {
- unshift @{$args_insideout{refaddr $self}},
- map {
- my $rt=reftype($lex_addr{$_});
- my $item;
- if ($rt ne 'SCALAR' and $rt ne 'GLOB' and $rt ne 'REF') {
- $item=\$lex_addr{$_};
- } else {
- $item=$lex_addr{$_};
- }
- {
- item => $item,
- usemy => 1,
- ro => 0,
- refcnt => refcount($lex_addr{$_}),
- }
- } @add;
- $self->{lexicals}{added}={ map { $lex_addr2name{$_} => 1 } @add };
- unshift @{$self->{unames}},
- map {
- (my $n=$lex_addr2name{$_})=~s/^[^\$]/*/;
- $n=~s/^\$//;
- $n
- } @add;
+ unshift @{ $args_insideout{ refaddr $self} }, map {
+ my $rt= reftype($lex_addr{$_});
+ my $item;
+ if ($rt ne 'SCALAR' and $rt ne 'GLOB' and $rt ne 'REF') {
+ $item= \$lex_addr{$_};
+ }
+ else {
+ $item= $lex_addr{$_};
+ }
+ {
+ item => $item,
+ usemy => 1,
+ ro => 0,
+ refcnt => refcount($lex_addr{$_}),
+ }
+ } @add;
+ $self->{lexicals}{added}=
+ { map { $lex_addr2name{$_} => 1 } @add };
+ unshift @{ $self->{unames} }, map {
+ (my $n= $lex_addr2name{$_}) =~ s/^[^\$]/*/;
+ $n =~ s/^\$//;
+ $n
+ } @add;
$self->_reset;
redo PASS;
- } elsif ($added) {
+ }
+ elsif ($added) {
$self->_reset;
redo PASS;
}
}
}
- $self->{cataloged}=1;
+ $self->{cataloged}= 1;
return $self;
}
sub _add_fix {
- my ($self,@args)=@_;
+ my ($self, @args)= @_;
+
# 'var','glob','method call','lock','ref','sv','#'
# TODO
# add a fix statement to the list of fixes.
- my $fix=@args==1 ? shift @args : [@args];
- unless ($fix->[0]=~/^(var|glob|thaw|ref|sv|#|sub call|lock|bless)$/) {
- Carp::confess "Unknown variant:".Dumper($fix);
+ my $fix= @args == 1 ? shift @args : [@args];
+ unless ($fix->[0] =~ /^(var|glob|thaw|ref|sv|#|sub call|lock|bless)$/) {
+ Carp::confess "Unknown variant:" . Dumper($fix);
}
if ($args[0] eq 'var') {
- unshift @{$self->{fix}},$fix;
- } else {
- push @{$self->{fix}},$fix;
+ unshift @{ $self->{fix} }, $fix;
+ }
+ else {
+ push @{ $self->{fix} }, $fix;
}
}
sub _glob_slots {
- my ($self,$inc_format)=@_;
+ my ($self, $inc_format)= @_;
+
# $inc_format is for a special case.
return (
- qw(SCALAR HASH ARRAY),
- (($self->{style}{deparse} && $self->{style}{deparseglob})
- ? 'CODE' : ()),
- (($inc_format && $self->{style}{deparse} && $self->{style}{deparseglob})
- ? 'FORMAT' : () )
- );
+ qw(SCALAR HASH ARRAY), (
+ ($self->{style}{deparse} && $self->{style}{deparseglob})
+ ? 'CODE'
+ : ()
+ ), ((
+ $inc_format
+ && $self->{style}{deparse}
+ && $self->{style}{deparseglob}
+ ) ? 'FORMAT' : ()));
}
-sub _dump_apply_fix { #handle fix statements and GLOB's here.
- my ($self,$isfinal)=@_;
+sub _dump_apply_fix { #handle fix statements and GLOB's here.
+ my ($self, $isfinal)= @_;
+
# go through the fix statements and out any that are
# now fully dumped.
# currently the following types are grokked:
# 'var','glob','method call','tlock','ref','sv','#'
my @globs;
- GLOB:{
- @globs=();
- @{$self->{fix}}=grep {
- my $keep=1;
- my $fix=$_;
+ GLOB: {
+ @globs= ();
+ @{ $self->{fix} }= grep {
+ my $keep= 1;
+ my $fix= $_;
if (ref $fix) {
- my ($type,$lhs,$rhs,$class)=@$fix;
+ my ($type, $lhs, $rhs, $class)= @$fix;
if ($type eq '#') {
- $self->{fh}->print(map "# $_\n",@$fix[0..$#$fix]);
- $keep=0;
- } elsif ($type eq 'bless') {
- if ($isfinal) { # $self->{"refdu"}[$lhs]
- $lhs=$self->{"refn"}[$lhs];
+ $self->{fh}->print(map "# $_\n", @$fix[ 0 .. $#$fix ]);
+ $keep= 0;
+ }
+ elsif ($type eq 'bless') {
+ if ($isfinal) { # $self->{"refdu"}[$lhs]
+ $lhs= $self->{"refn"}[$lhs];
$self->{fh}->print(
- substr($self->{style}{bless},0,-1)," ",$lhs,", ",
- _quote($rhs)," ",substr($self->{style}{bless},-1),
- ";\n");
- $keep=0;
+ substr($self->{style}{bless}, 0, -1),
+ " ",
+ $lhs,
+ ", ",
+ _quote($rhs),
+ " ",
+ substr($self->{style}{bless}, -1),
+ ";\n"
+ );
+ $keep= 0;
}
- } elsif ($type eq 'sv') {
-
- my $dref=$_->[-1];
- if ($self->{$type."du"}[$rhs] and ${$self->{$type."du"}[$rhs]}) {
- $rhs=$self->{$type."n"}[$rhs];
- my ($sigil,$var)=remove_deref($lhs);
+ }
+ elsif ($type eq 'sv') {
+
+ my $dref= $_->[-1];
+ if ($self->{ $type . "du" }[$rhs]
+ and ${ $self->{ $type . "du" }[$rhs] })
+ {
+ $rhs= $self->{ $type . "n" }[$rhs];
+ my ($sigil, $var)= remove_deref($lhs);
if ($sigil) {
- $rhs="\\".$rhs;
- $lhs=$var;
+ $rhs= "\\" . $rhs;
+ $lhs= $var;
}
$self->{fh}->print("$lhs = $rhs;\n");
- $$dref=1 if ref $dref;
- $keep=0
+ $$dref= 1 if ref $dref;
+ $keep= 0;
}
- } elsif ($type eq 'ref') {
+ }
+ elsif ($type eq 'ref') {
- if ($self->{$type."du"}[$rhs] and ${$self->{$type."du"}[$rhs]}) {
+ if ($self->{ $type . "du" }[$rhs]
+ and ${ $self->{ $type . "du" }[$rhs] })
+ {
- $rhs=$self->{$type."n"}[$rhs];
+ $rhs= $self->{ $type . "n" }[$rhs];
- if ($rhs=~/^[\@\%\&]/) {
- $rhs="\\".$rhs;
- $rhs="bless( $rhs, "._quote($class).' )'
+ if ($rhs =~ /^[\@\%\&]/) {
+ $rhs= "\\" . $rhs;
+ $rhs= "bless( $rhs, " . _quote($class) . ' )'
if $class;
- } # Warn if
+ } # Warn if
$self->{fh}->print("$lhs = $rhs;\n");
- $keep=0
+ $keep= 0;
}
- } elsif ($type eq 'lock') {
- if ($self->{refdu}[$lhs] and ${$self->{"refdu"}[$lhs]}) {
- $lhs=$self->{"refn"}[$lhs];
- $self->{fh}->print(@$rhs ? "lock_keys_plus( $lhs, "
- : "lock_keys( $lhs ",
- join(", ",map{ _quote($_) } @$rhs),
- ");\n");
- $keep=0;
+ }
+ elsif ($type eq 'lock') {
+ if ($self->{refdu}[$lhs] and ${ $self->{"refdu"}[$lhs] }) {
+ $lhs= $self->{"refn"}[$lhs];
+ $self->{fh}->print(
+ @$rhs
+ ? "lock_keys_plus( $lhs, "
+ : "lock_keys( $lhs ",
+ join(", ", map { _quote($_) } @$rhs),
+ ");\n"
+ );
+ $keep= 0;
}
- } elsif ($type eq 'thaw') {
+ }
+ elsif ($type eq 'thaw') {
+
# these have to happen at the end.
if ($isfinal) {
+
#if ($self->{refdu}[$lhs] and ${$self->{"refdu"}[$lhs]}) {
- ${$self->{refdu}[$lhs]}=1;
- $lhs=$self->{"refn"}[$lhs];
- my @args=@$_[3..$#$_];
- if ($rhs=~/^(->)?((?:\w*::)*\w+)(\(\))?$/) {
+ ${ $self->{refdu}[$lhs] }= 1;
+ $lhs= $self->{"refn"}[$lhs];
+ my @args= @$_[ 3 .. $#$_ ];
+ if ($rhs =~ /^(->)?((?:\w*::)*\w+)(\(\))?$/) {
if ($3) {
- $self->{fh}->print("$2( ".join(", ",$lhs,@args)." );\n");
- } else {
- $self->{fh}->print("$lhs->$2(".join(", ",@args).");\n");
+ $self->{fh}->print(
+ "$2( " . join(", ", $lhs, @args) . " );\n");
+ }
+ else {
+ $self->{fh}->print(
+ "$lhs->$2(" . join(", ", @args) . ");\n");
}
- } else {
- $rhs=~s/^\t//mg;
+ }
+ else {
+ $rhs =~ s/^\t//mg;
$self->{fh}->print("for ($lhs) {\n$rhs\n}\n");
}
- $keep=0;
+ $keep= 0;
}
- } elsif ($type eq 'glob') {
- push @globs,$_;
- $keep=0;
- } elsif ($type eq 'var') {
- $rhs="\\".$rhs;
- $rhs="bless( $rhs, "._quote($class).' )'
+ }
+ elsif ($type eq 'glob') {
+ push @globs, $_;
+ $keep= 0;
+ }
+ elsif ($type eq 'var') {
+ $rhs= "\\" . $rhs;
+ $rhs= "bless( $rhs, " . _quote($class) . ' )'
if $class;
- $self->{fh}->print(($self->{style}{declare} ? 'my ' : ""),"$lhs = $rhs;\n");
- $keep=0;
- } elsif ($type eq 'sub call') {
- my @r=grep { ref $_ and (!$self->{svdu}[$$_] or !${$self->{svdu}[$$_]}) } @$fix;
+ $self->{fh}->print(($self->{style}{declare} ? 'my ' : ""),
+ "$lhs = $rhs;\n");
+ $keep= 0;
+ }
+ elsif ($type eq 'sub call') {
+ my @r= grep {
+ ref $_
+ and
+ (!$self->{svdu}[$$_] or !${ $self->{svdu}[$$_] })
+ } @$fix;
unless (@r) {
- my ($type,$sub,@args)=map { ref $_ ? $self->{svn}[$$_] : $_ } @$fix;
- $self->{fh}->print("$sub(",join(", ",@args),");\n");
- $keep=0;
+ my ($type, $sub, @args)=
+ map { ref $_ ? $self->{svn}[$$_] : $_ } @$fix;
+ $self->{fh}->print("$sub(", join(", ", @args), ");\n");
+ $keep= 0;
}
- } else {
- die "Bad fix: ",Dumper($fix);
+ }
+ else {
+ die "Bad fix: ", Dumper($fix);
}
}
$keep;
- } @{$self->{fix}};
+ } @{ $self->{fix} };
foreach my $glob (@globs) {
- my ($type,$lhs,$rhs,$depth,$name)=@$glob;
+ my ($type, $lhs, $rhs, $depth, $name)= @$glob;
print "Symbol: $name\n" if $DEBUG and $name;
local @_;
- $name=$name ? '*'.$name : $rhs;
- my $overloaded=undef;
- my $isoverloaded=0;
- if (defined( blessed $lhs ) and
- overload::Overloaded( $lhs ) )
+ $name= $name ? '*' . $name : $rhs;
+ my $overloaded= undef;
+ my $isoverloaded= 0;
+ if (defined(blessed $lhs )
+ and overload::Overloaded($lhs))
{
- $overloaded=blessed $lhs;
- disable_overloading( $lhs );
- $isoverloaded=1;
+ $overloaded= blessed $lhs;
+ disable_overloading($lhs);
+ $isoverloaded= 1;
}
- foreach my $t ($self->_glob_slots(''))
- {
- my $v=*$lhs{$t};
+ foreach my $t ($self->_glob_slots('')) {
+ my $v= *$lhs{$t};
- if ( not(defined $v) or
- ($t eq 'SCALAR' and !defined($$v)))
+ if (not(defined $v)
+ or ($t eq 'SCALAR' and !defined($$v)))
{
next;
}
+ my $dumped= 0;
- my $dumped=0;
-
-
- my $gaddr=refaddr(*$lhs{$t});
- my $gidx=$self->{ref}{$gaddr};
+ my $gaddr= refaddr(*$lhs{$t});
+ my $gidx= $self->{ref}{$gaddr};
unless ($gidx) {
- next
- } elsif ($self->{refd}[$gidx]<$depth+1) {
- $self->_add_fix('ref',$name,$gidx,blessed(*$lhs{$t}));
+ next;
+ }
+ elsif ($self->{refd}[$gidx] < $depth + 1) {
+ $self->_add_fix('ref', $name, $gidx, blessed(*$lhs{$t}));
next;
}
$self->{fh}->print("$name = ") unless $self->{style}{terse};
- my $ret=$self->_dump_sv(*$lhs{$t},$depth,\$dumped,$name,length($name)+3);
- Carp::confess "\nUnhandled alias value '$ret' returned to _dump_apply_fix()!"
+ my $ret= $self->_dump_sv(*$lhs{$t}, $depth, \$dumped, $name,
+ length($name) + 3);
+ Carp::confess
+ "\nUnhandled alias value '$ret' returned to _dump_apply_fix()!"
if $ret;
$self->{fh}->print(";\n");
- $dumped=1;
+ $dumped= 1;
}
- if ($self->{style}{deparse} && $self->{style}{deparseglob}
+ if (
+ $self->{style}{deparse}
+ && $self->{style}{deparseglob}
+
#and defined *$lhs{FORMAT}
) {
# from link from [ysth]: http://groups.google.com/groups?selm=laUs8gzkgOlT092yn%40efn.org
@@ -1946,27 +2048,25 @@ sub _dump_apply_fix { #handle fix statements and GLOB's here.
# 2acc3314e31a9342e325f35c5b592967c9850c9b, keep the
# value \*$lhs alive while we inspect it as a B object
# or else it'll be reaped while we're using it.
- my $lhs_glob = \*$lhs;
- my $Bobj = B::svref_2object($lhs_glob);
+ my $lhs_glob= \*$lhs;
+ my $Bobj= B::svref_2object($lhs_glob);
# if passed a glob or globref, get the format
- $Bobj = B::GV::FORM($Bobj) if ref $Bobj eq 'B::GV';
+ $Bobj= B::GV::FORM($Bobj) if ref $Bobj eq 'B::GV';
if (ref $Bobj eq 'B::FM') {
- (my $cleaned=$name)=~s/^\*(::)?//;
+ (my $cleaned= $name) =~ s/^\*(::)?//;
$self->{fh}->print("format $cleaned =\n");
- my $deparser = Data::Dump::Streamer::Deparser->new();
+ my $deparser= Data::Dump::Streamer::Deparser->new();
$self->{fh}->print(
- $deparser->indent($deparser->deparse_format($Bobj))
- );
+ $deparser->indent($deparser->deparse_format($Bobj)));
$self->{fh}->print("\n");
}
}
if ($isoverloaded) {
- restore_overloading( $lhs, $overloaded );
+ restore_overloading($lhs, $overloaded);
}
-
}
redo GLOB if @globs;
}
@@ -2032,402 +2132,445 @@ All should DWIM.
# w/the right tags for now...
sub Out {
- local($\,$",$,)=("","",""); # prevent globals from messing with our output via print
- my $self = shift->_safe_self;
- print "Out(".scalar(@_)." vars)\n"
+ local ($\, $", $,)=
+ ("", "", ""); # prevent globals from messing with our output via print
+ my $self= shift->_safe_self;
+ print "Out(" . scalar(@_) . " vars)\n"
if $DEBUG;
- if ( !$self->{in_printit} and (@_ or !$self->{cataloged} )) {
+ if (!$self->{in_printit} and (@_ or !$self->{cataloged})) {
$self->Data(@_);
}
my $fh;
- unless ( $self->{fh} ) {
+ unless ($self->{fh}) {
print " no filehandle using "
if $DEBUG;
if (defined wantarray) {
- my $class= __PACKAGE__ . (wantarray ? "::_::ListPrinter" : "::_::StringPrinter");
- print $class,"\n"
+ my $class= __PACKAGE__
+ . (wantarray ? "::_::ListPrinter" : "::_::StringPrinter");
+ print $class, "\n"
if $DEBUG;
- $fh = $class->new()
- or Carp::confess "$class failed to build!";
- $self->{'return'} = $fh;
- } else {
+ $fh= $class->new()
+ or Carp::confess "$class failed to build!";
+ $self->{'return'}= $fh;
+ }
+ else {
print "STDOUT\n" if $DEBUG;
- $fh = \*STDOUT;
+ $fh= \*STDOUT;
}
- $self->{fh} = $fh;
+ $self->{fh}= $fh;
}
+
# loop over the list
# and dump out each one in turn
# handling any potential fixes after
# each definition is complete
- $self->{out_names}=[];
- $self->{declare}=[];
- $self->{special}={};
- $DEBUG>9 and $self->diag;
+ $self->{out_names}= [];
+ $self->{declare}= [];
+ $self->{special}= {};
+ $DEBUG > 9 and $self->diag;
- my @items=@{$args_insideout{refaddr $self}};
+ my @items= @{ $args_insideout{ refaddr $self} };
- my $namestr="";
+ my $namestr= "";
- push @{$self->{out_names}},map{$_->{name}}@items; #must
- push @{$self->{declare}},map{$_->{name}}@items;
+ push @{ $self->{out_names} }, map { $_->{name} } @items; #must
+ push @{ $self->{declare} }, map { $_->{name} } @items;
if ($self->{style}{special}) {
- warn DDumper(\@items) if $DEBUG;
-
- $namestr="# (".join (", ",@{$self->{out_names}}).")\n";
-
- @items=sort { $self->{svc}[$b->{idx}] <=> $self->{svc}[$a->{idx}]||
- ($b->{raddr} ? $self->{refc}[$b->{ridx}] : 0)
- <=>
- ($a->{raddr} ? $self->{refc}[$a->{ridx}] : 0)
- } @items;
-
+ print DDumper(\@items) if $DEBUG;
+ $namestr= "# (" . join(", ", @{ $self->{out_names} }) . ")\n";
+ @items= sort {
+ $self->{svc}[ $b->{idx} ] <=> $self->{svc}[ $a->{idx} ]
+ || ($b->{raddr} ? $self->{refc}[ $b->{ridx} ] : 0)
+ <=> ($a->{raddr} ? $self->{refc}[ $a->{ridx} ] : 0)
+ } @items;
- warn DDumper(\@items) if $DEBUG;
+ print DDumper(\@items) if $DEBUG;
}
if ($self->{style}{compress} && $self->{style}{compressor}) {
- my $prelude=$self->{style}{compressor}->();
+ my $prelude= $self->{style}{compressor}->();
$self->{fh}->print($prelude) if $prelude;
}
- $self->{fh}->print("my (",join(",",sort keys %{$self->{lexicals}{added}}),");\n")
+ $self->{fh}
+ ->print("my (", join(",", sort keys %{ $self->{lexicals}{added} }),
+ ");\n")
if $self->{lexicals}{added};
foreach my $item (@items) {
- my $dumped=0;
- my $ret=$self->_dump_sv(${$item->{item}},1,\$dumped,$item->{name});
+ my $dumped= 0;
+ my $ret=
+ $self->_dump_sv(${ $item->{item} }, 1, \$dumped, $item->{name});
Carp::confess "\nUnhandled alias value '$ret' returned to Out()!"
if $ret;
$self->{fh}->print(";\n");
- $dumped=1;
+ $dumped= 1;
$self->_dump_apply_fix();
}
$self->_dump_apply_fix('final');
$self->{fh}->print($namestr) if $namestr;
$self->diag if $DEBUG;
+
#warn "@{$self->{out_names}}";
- if ( $self->{return} and defined wantarray) {
- my $r = delete $self->{return};
+ if ($self->{return} and defined wantarray) {
+ my $r= delete $self->{return};
delete $self->{fh};
return $r->value;
- } else {
+ }
+ else {
return $self;
}
}
-
# sqz(str,begin,end)
sub sqz {
require Compress::Zlib;
require MIME::Base64;
- my $res= Compress::Zlib::compress($_[0],9);
+ my $res= Compress::Zlib::compress($_[0], 9);
return $_[1]
- ? $_[1]
- . MIME::Base64::encode($res,"")
- . $_[2]
- : MIME::Base64::encode($res,"");
+ ? $_[1] . MIME::Base64::encode($res, "") . $_[2]
+ : MIME::Base64::encode($res, "");
}
# usqz(str)
sub usqz {
- return Compress::Zlib::uncompress(
- MIME::Base64::decode($_[0])
- );
+ return Compress::Zlib::uncompress(MIME::Base64::decode($_[0]));
}
-
-
sub _dump_sv {
- my ($self,$item,$depth,$dumped,$name,$indent,$is_ref)=@_;
+ my ($self, $item, $depth, $dumped, $name, $indent, $is_ref)= @_;
- $self->{do_nl}=0;
+ $self->{do_nl}= 0;
- my $addr=refaddr(\$_[1]);
- my $idx=$self->{sv}{$addr};
+ my $addr= refaddr(\$_[1]);
+ my $idx= $self->{sv}{$addr};
my $ro;
- $DEBUG and printf "_dump_sv %d %s %#x - %d\n",$depth, $name,$addr,$idx||0;
-
+ $DEBUG
+ and printf "_dump_sv %d %s %#x - %d\n", $depth, $name, $addr, $idx || 0;
- $name||=$self->{svn}[$idx];
- (my $clean_name=$name)=~s/^[\@\%\&](\w+)/\$${1}_/; # XXX
- my $optspace=$self->{style}{optspace};
+ $name ||= $self->{svn}[$idx];
+ (my $clean_name= $name) =~ s/^[\@\%\&](\w+)/\$${1}_/; # XXX
+ my $optspace= $self->{style}{optspace};
if ($idx) {
# Its a monitored scalar.
- my $pre_dumped=$self->{svdu}[$idx];
- my $name_diff=(
- $self->{svd}[$idx]==$depth
- and $self->{svn}[$idx] ne $clean_name
- and $clean_name!~/\*/
- and $name!~/^\&/
- );
+ my $pre_dumped= $self->{svdu}[$idx];
+ my $name_diff=
+ ( $self->{svd}[$idx] == $depth
+ and $self->{svn}[$idx] ne $clean_name
+ and $clean_name !~ /\*/
+ and $name !~ /^\&/);
#print "Idx: $idx Special keys:",join("-",keys %{$self->{special}}),"\n"
# if $DEBUG and keys %{$self->{special}};
- print "sv_dump Monitored:\n",$self->diag_sv_idx($idx," ") if $DEBUG;
-
+ print "sv_dump Monitored:\n", $self->diag_sv_idx($idx, " ") if $DEBUG;
- if (( $pre_dumped and !$self->{svon}{$idx})
- or (!$self->{svon}{$idx} ? ($self->{svd}[$idx]<$depth or $name_diff) : undef) )
- {
+ if (
+ ($pre_dumped and !$self->{svon}{$idx})
+ or (
+ !$self->{svon}{$idx}
+ ? ($self->{svd}[$idx] < $depth or $name_diff)
+ : undef
+ )
+ ) {
print "PREDUMPED: $self->{svon}{$idx}\n"
- if $DEBUG and $self->{svon}{$idx} and $pre_dumped and $$pre_dumped;
+ if $DEBUG
+ and $self->{svon}{$idx}
+ and $pre_dumped
+ and $$pre_dumped;
# We've seen it before.
# Unless its a ref it must be an alias
- print(($name_diff ? "Name diff" : "No name diff"), " $name, $clean_name","\n")
+ print(($name_diff ? "Name diff" : "No name diff"),
+ " $name, $clean_name", "\n")
if $DEBUG;
- my ($str,$ret)=('',undef);
+ my ($str, $ret)= ('', undef);
if ($is_ref) {
- if ($self->{svd}[$idx]==1 && !$self->{style}{declare}
- || ($pre_dumped && $$pre_dumped)
- ) {
- $str="\\$self->{svn}[$idx]";
- } else {
+ if ($self->{svd}[$idx] == 1 && !$self->{style}{declare}
+ || ($pre_dumped && $$pre_dumped))
+ {
+ $str= "\\$self->{svn}[$idx]";
+ }
+ else {
#see the 'Many refs' tests in t\dump.t for
#why this is here. basically we need to
#ensure the ref is modifiable. If its two $'s
#then its modifiable anyway, more and it wont be.
# $ref=\\$x; $ref=RW $$ref=RO $$$ref=$x=RW
unless ($self->{style}{purity}) {
- $str="\\$self->{svn}[$idx]";
- } else {
- my $need_do=($name=~/^\$\$\$+/);
+ $str= "\\$self->{svn}[$idx]";
+ }
+ else {
+ my $need_do= ($name =~ /^\$\$\$+/);
if ($need_do) {
- $str.=join($optspace,qw( do { my $f = ),'');
+ $str .= join($optspace, qw( do { my $f = ), '');
}
- $str.=!$self->{style}{verbose}
- ? "'R'" : _quote($DEBUG ? 'SR: ' : 'R: ',
- "$self->{svn}[$idx]");
- $ret=\do{my $nope=0};
- $self->_add_fix('sv',$name,$idx,$ret);
+ $str .=
+ !$self->{style}{verbose}
+ ? "'R'"
+ : _quote($DEBUG ? 'SR: ' : 'R: ',
+ "$self->{svn}[$idx]");
+ $ret= \do { my $nope= 0 };
+ $self->_add_fix('sv', $name, $idx, $ret);
- $str.="$optspace}" if ($need_do)
+ $str .= "$optspace}" if ($need_do);
}
}
- } else {
- if ($depth==1) {
+ }
+ else {
+ if ($depth == 1) {
if ($self->{style}{declare}) {
- $str.="my $name;\n";
+ $str .= "my $name;\n";
}
+
#push @{$self->{out_names}},$name;
#push @{$self->{declare}},$name;
- $str.="alias_ref(\\$name,\\$self->{svn}[$idx])";
- } elsif ($self->{style}{purity}) {
- $str.=!$self->{style}{verbose} ? "'A'" : _quote("A: ",$self->{svn}[$idx]);
- $ret=\$idx;
- } else {
- $str.="alias_to($self->{svn}[$idx])";
- $ret='';
+ $str .= "alias_ref(\\$name,\\$self->{svn}[$idx])";
+ }
+ elsif ($self->{style}{purity}) {
+ $str .=
+ !$self->{style}{verbose}
+ ? "'A'"
+ : _quote("A: ", $self->{svn}[$idx]);
+ $ret= \$idx;
+ }
+ else {
+ $str .= "alias_to($self->{svn}[$idx])";
+ $ret= '';
}
}
- $self->{buf}+=length($str);
- $self->{buf}=length($1) if $str=~/\n([^\n]*)\s*\z/;
+ $self->{buf} += length($str);
+ $self->{buf}= length($1) if $str =~ /\n([^\n]*)\s*\z/;
$self->{fh}->print($str);
- return $ret ? $ret : ()
- } else {
+ return $ret ? $ret : ();
+ }
+ else {
# we've never seen it before and we need to dump it.
- $self->{svdu}[$idx]||=$dumped;
+ $self->{svdu}[$idx] ||= $dumped;
- print "Defining Special:".$self->diag_sv_idx($idx)
+ print "Defining Special:" . $self->diag_sv_idx($idx)
if $DEBUG and $self->{special}{$idx};
- $self->{svn}[$idx]=$name if $self->{special}{$idx};
- $self->{svd}[$idx]=$depth if $self->{special}{$idx};
+ $self->{svn}[$idx]= $name if $self->{special}{$idx};
+ $self->{svd}[$idx]= $depth if $self->{special}{$idx};
}
- $ro=$self->{svro}[$idx];
- } else {
- $ro=readonly $_[1] unless defined $ro;
+ $ro= $self->{svro}[$idx];
+ }
+ else {
+ $ro= readonly $_[1] unless defined $ro;
}
print "sv_dump: Postindexed\n" if $DEBUG;
- if ($depth==1) {
+ if ($depth == 1) {
+
# root level object. declare it
- if ($name ne $clean_name and $name!~/^\*/ and $self->{svc}[$idx]>1) {
-
- print "Special $name\n" if $DEBUG;
- my $oidx=$self->{ref}{$self->{sva}[$idx]};
- if ($oidx) {
- #theres a ref to us out there
- my $name=$self->_build_name($self->{refn}[$oidx],'$');
- $self->{svn}[$idx]=$name;
- print "Oindex! $oidx $name\n" if $DEBUG;
- #$self->{svd}[$idx]=$self->{refd}[$idx]+1;
- }
+ if ($name ne $clean_name and $name !~ /^\*/ and $self->{svc}[$idx] > 1)
+ {
+
+ print "Special $name\n" if $DEBUG;
+ my $oidx= $self->{ref}{ $self->{sva}[$idx] };
+ if ($oidx) {
+
+ #theres a ref to us out there
+ my $name= $self->_build_name($self->{refn}[$oidx], '$');
+ $self->{svn}[$idx]= $name;
+ print "Oindex! $oidx $name\n" if $DEBUG;
+
+ #$self->{svd}[$idx]=$self->{refd}[$idx]+1;
+ }
- #$self->{special}{$idx}++;
- $self->{svdu}[$idx]=undef;
+ #$self->{special}{$idx}++;
+ $self->{svdu}[$idx]= undef;
- print $self->diag_sv_idx($idx,1) if $DEBUG;
+ print $self->diag_sv_idx($idx, 1) if $DEBUG;
}
+
#push @{$self->{out_names}},$name; #must
#push @{$self->{declare}},$name;
- unless ($self->{style}{terse} || $name=~/^\&/) { # XXX
- my $str=(($self->{style}{declare} && $name!~/^\*/
- && !$self->{lexicals}{added}{$name}
- ) ? "my$optspace" : ""
- )."$name$optspace=$optspace";
+ unless ($self->{style}{terse} || $name =~ /^\&/) { # XXX
+ my $str= ((
+ $self->{style}{declare}
+ && $name !~ /^\*/
+ && !$self->{lexicals}{added}{$name}
+ ) ? "my$optspace" : ""
+ ) . "$name$optspace=$optspace";
$self->{fh}->print($str);
- $indent=length($str);
- $self->{buf}=0;
- } else {
- $indent=0;
+ $indent= length($str);
+ $self->{buf}= 0;
+ }
+ else {
+ $indent= 0;
}
print "toplevel\n" if $DEBUG;
}
- my $iaddr=refaddr $item;
+ my $iaddr= refaddr $item;
$self->{fh}->print("\\")
if $is_ref;
- my $glob=globname $item;
- my $add_do=$self->{style}{purity}
- && !$ro
- && $is_ref
- && !blessed($_[1])
- && !$glob
- && do {
- my $rtype= reftype($_[1]);
- $rtype eq "" or
- ($rtype eq "SCALAR" and ( $] < 5.020 or !readonly(${ $_[1] }) ) )
- }
- ;
-
+ my $glob= globname $item;
+ my $add_do=
+ $self->{style}{purity}
+ && !$ro
+ && $is_ref
+ && !blessed($_[1])
+ && !$glob
+ && do {
+ my $rtype= reftype($_[1]);
+ $rtype eq ""
+ or ($rtype eq "SCALAR" and ($] < 5.020 or !readonly(${ $_[1] })));
+ };
if ($add_do) {
+
#warn "\n!$ro && $is_ref && !blessed($_[1]) && !$glob";
- $self->{fh}->print(join $optspace,qw(do { my $v = ),'');
- $self->{buf}+=13;
+ $self->{fh}->print(join $optspace, qw(do { my $v = ), '');
+ $self->{buf} += 13;
}
unless ($iaddr) {
print "iaddr $glob\n" if $DEBUG;
unless (defined $item) {
$self->{fh}->print('undef');
- $self->{buf}+=5;
- } else {
- my $is_ro=($self->{style}{ro} && $ro && !$is_ref);
+ $self->{buf} += 5;
+ }
+ else {
+ my $is_ro= ($self->{style}{ro} && $ro && !$is_ref);
if ($is_ro and !$self->{style}{purity} and !$self->{style}{terse}) {
$self->{fh}->print("make_ro($optspace");
}
if ($glob) {
- if ($glob=~/^\*Symbol::GEN/) {
- $self->_dump_symbol($_[1],$name,$glob,'deref',$depth);
- } else
- {
- $self->{buf}+=length($glob);
+ if ($glob =~ /^\*Symbol::GEN/) {
+ $self->_dump_symbol($_[1], $name, $glob, 'deref', $depth);
+ }
+ else {
+ $self->{buf} += length($glob);
$self->{fh}->print($glob);
- if ($self->{style}{dumpglob} and
- !$self->{sv_glob_du}{$glob}++) {
- $self->_add_fix('glob',$_[1],$glob,$depth+1);
+ if ($self->{style}{dumpglob}
+ and !$self->{sv_glob_du}{$glob}++)
+ {
+ $self->_add_fix('glob', $_[1], $glob, $depth + 1);
}
}
- } else {
+ }
+ else {
my $quoted;
if ($self->{style}{dualvars}) {
- no warnings 'numeric'; # XXX: is this required?
- if (_could_be_dualvar($item) && 0+$item ne $item && "$item" != $item ) {
- $quoted="dualvar( ".join(",$optspace",0+$item,_quote("$item"))."$optspace)";
+ no warnings 'numeric'; # XXX: is this required?
+ if ( _could_be_dualvar($item)
+ && 0 + $item ne $item
+ && "$item" != $item)
+ {
+ $quoted=
+ "dualvar( "
+ . join(",$optspace", 0 + $item, _quote("$item"))
+ . "$optspace)";
}
}
+
# XXX main scalar output here!
- if ( ! $quoted ) {
+ if (!$quoted) {
my $style= $self->{style};
- if ( $style->{compress} &&
- $style->{compressor} &&
- length($_[1]) > $style->{compress}
- ){
- $quoted= $style->{compressor}->($_[1],$self);
- } else {
- $quoted=_quote($item);
+ if ( $style->{compress}
+ && $style->{compressor}
+ && length($_[1]) > $style->{compress})
+ {
+ $quoted= $style->{compressor}->($_[1], $self);
+ }
+ else {
+ $quoted= _quote($item);
}
}
- $self->{buf}+=length($quoted);
- $self->{buf}=length($1) if $quoted=~/\n([^\n]*)\s*\z/;
- $self->{fh}->print($quoted); #;
+ $self->{buf} += length($quoted);
+ $self->{buf}= length($1) if $quoted =~ /\n([^\n]*)\s*\z/;
+ $self->{fh}->print($quoted); #;
}
- if( !$self->{style}{terse} ) {
+ if (!$self->{style}{terse}) {
if ($is_ro && $self->{style}{purity}) {
- $self->_add_fix('sub call','make_ro',$name);
- } elsif ($is_ro) {
+ $self->_add_fix('sub call', 'make_ro', $name);
+ }
+ elsif ($is_ro) {
$self->{fh}->print("$optspace)");
}
}
+
#return
}
- $self->{do_nl}=0;
- } else {
- $self->{do_nl}=1;
- $self->_dump_rv($item,$depth+1,$dumped,$name,$indent,$is_ref && !$add_do);
+ $self->{do_nl}= 0;
+ }
+ else {
+ $self->{do_nl}= 1;
+ $self->_dump_rv($item, $depth + 1, $dumped, $name, $indent,
+ $is_ref && !$add_do);
}
$self->{fh}->print("$optspace}")
- if $add_do;
- $self->_add_fix('sub call','weaken',$name)
- if $self->{svw}{$addr};
- return
+ if $add_do;
+ $self->_add_fix('sub call', 'weaken', $name)
+ if $self->{svw}{$addr};
+ return;
}
sub _brace {
- my ($self,$name,$type,$cond,$indent,$child)=@_;
- my $open=$type=~/[\{\[\(]/;
-
- my $brace= $name !~ /^[%@]/
- ? $type
- : $type =~ /[\{\[\(]/
- ? '('
- : ')';
+ my ($self, $name, $type, $cond, $indent, $child)= @_;
+ my $open= $type =~ /[\{\[\(]/;
+
+ my $brace=
+ $name !~ /^[%@]/ ? $type
+ : $type =~ /[\{\[\(]/ ? '('
+ : ')';
$child= $child ? $self->{style}{optspace} : "";
- if ( $cond ) {
- $_[-2] += $open ? $self->{style}{indentcols}
- : -$self->{style}{indentcols};
- $self->{fh}->print($open ? "" : "\n".(" " x $_[-2]),
- $brace,
- $open ? "\n".(" " x $_[-2]) : "");
- } else {
- $self->{fh}->print($open ? "" : $child ,
- $brace,
- $open ? $child : "");
- }
- return
+ if ($cond) {
+ $_[-2] +=
+ $open
+ ? $self->{style}{indentcols}
+ : -$self->{style}{indentcols};
+ $self->{fh}->print($open ? "" : "\n" . (" " x $_[-2]),
+ $brace, $open ? "\n" . (" " x $_[-2]) : "");
+ }
+ else {
+ $self->{fh}->print($open ? "" : $child, $brace, $open ? $child : "");
+ }
+ return;
}
sub _dump_qr {
- my ($self,$pat,$mod)=@_;
+ my ($self, $pat, $mod)= @_;
my %counts;
- $counts{$_}++ foreach split //,$pat;
- my ($quotes,$best)=('',length($pat)+1);
- foreach my $char (qw( / ! % & <> {} " ),'#') { #"
- my $bad=0;
- $bad+=$counts{$_}||0 for split //,$char;
- ($quotes,$best)=($char,$bad) if $bad<$best;
+ $counts{$_}++ foreach split //, $pat;
+ my ($quotes, $best)= ('', length($pat) + 1);
+ foreach my $char (qw( / ! % & <> {} " ), '#') { #"
+ my $bad= 0;
+ $bad += $counts{$_} || 0 for split //, $char;
+ ($quotes, $best)= ($char, $bad) if $bad < $best;
last unless $best;
}
- $pat=~s/(?!\\)([$quotes])/\\$1/g
+ $pat =~ s/(?!\\)([$quotes])/\\$1/g
if $best;
{
- use utf8;
- #$pat=~s/([^\x00-\x7f])/sprintf '\\x{%x}',ord $1/ge;
- $pat=~s/([^\040-\176])/sprintf "\\x{%x}", ord($1)/ge;
+ use utf8;
+
+ #$pat=~s/([^\x00-\x7f])/sprintf '\\x{%x}',ord $1/ge;
+ $pat =~ s/([^\040-\176])/sprintf "\\x{%x}", ord($1)/ge;
}
- $self->{fh}->print('qr',substr($quotes,0,1),$pat,substr($quotes,-1),$mod);
- return
+ $self->{fh}
+ ->print('qr', substr($quotes, 0, 1), $pat, substr($quotes, -1), $mod);
+ return;
}
=for uedit32
@@ -2436,84 +2579,91 @@ sub _default_key_sorters{}
=cut
my %default_key_sorters= (
- numeric => sub { [ sort {$a <=> $b} keys %{$_[0]} ] },
- lexical => sub { [ sort keys %{$_[0]} ] },
- smart => sub {
+ numeric => sub {
+ [ sort { $a <=> $b } keys %{ $_[0] } ]
+ },
+ lexical => sub { [ sort keys %{ $_[0] } ] },
+ smart => sub {
[
map { $_->[-1] }
- sort {
- ( $a->[2] <=> $b->[2] )
- ||
- ( defined($a->[0])
+ sort {
+ ($a->[2] <=> $b->[2])
+ || (
+ defined($a->[0])
? $a->[0] <=> $b->[0] || ($a->[1] cmp $b->[1])
- : $a->[1] cmp $b->[1] )
- ||
- ( $a->[-1] cmp $b->[-1] )
- }
- map {
- my $chars=lc($_);
- my $num;
- $num=$1 if $chars=~
- s/\A(-?(?:0|[1-9]\d{0,8})(?:\.\d{0,15})?)(?!\d)//;
- $chars=~s/\W//g;
- [ $num, $chars, !defined $num ? 2 :
+ : $a->[1] cmp $b->[1])
+ || ($a->[-1] cmp $b->[-1])
+ }
+ map {
+ my $chars= lc($_);
+ my $num;
+ $num= $1
+ if $chars =~
+ s/\A(-?(?:0|[1-9]\d{0,8})(?:\.\d{0,15})?)(?!\d)//;
+ $chars =~ s/\W//g;
+ [
+ $num, $chars,
+ !defined $num ? 2
+ :
+
# length($chars) ? 1 :
- 0, $_ ]
- } keys %{$_[0]}
- ]
+ 0, $_
+ ]
+ } keys %{ $_[0] } ]
},
- 'each'=>sub { undef },
+ 'each' => sub { undef },
);
-$default_key_sorters{alphabetical}=$default_key_sorters{lexical};
-$default_key_sorters{intelligent}=$default_key_sorters{smart};
+$default_key_sorters{alphabetical}= $default_key_sorters{lexical};
+$default_key_sorters{intelligent}= $default_key_sorters{smart};
for my $h (\%default_key_sorters) {
- my $abr=Text::Abbrev::abbrev(keys %$h);
+ my $abr= Text::Abbrev::abbrev(keys %$h);
foreach my $short (keys %$abr) {
- $h->{$short}=$h->{$abr->{$short}};
+ $h->{$short}= $h->{ $abr->{$short} };
}
}
-
sub _get_keys {
- my ($self,$item,$pass,$addr,$class)=@_;
+ my ($self, $item, $pass, $addr, $class)= @_;
my $sorter;
- $class= "" if ! defined $class;
-
- $sorter= $self->{style}{sortkeys}{"#$addr"}
- || $self->{cache_sorter}{$class};
- if ( ! $sorter ) {
- $sorter= $self->{style}{sortkeys}{".$class"}
- || ($class && $class->can("DDS_sortkeys") )
- || $self->{style}{sortkeys}{"."};
- ;
+ $class= "" if !defined $class;
+
+ $sorter= $self->{style}{sortkeys}{"#$addr"}
+ || $self->{cache_sorter}{$class};
+ if (!$sorter) {
+ $sorter=
+ $self->{style}{sortkeys}{".$class"}
+ || ($class && $class->can("DDS_sortkeys"))
+ || $self->{style}{sortkeys}{"."};
+
$self->{cache_sorter}{$class}=
($sorter ||= $default_key_sorters{smart});
}
- my ($ary,$thaw)=$sorter->( $item, $pass, $addr, $class );
+ my ($ary, $thaw)= $sorter->($item, $pass, $addr, $class);
die "$item:$pass:$addr:$class:$ary:$thaw"
- if $ary and reftype($ary) ne "ARRAY";
- return ($ary,$thaw);
+ if $ary and reftype($ary) ne "ARRAY";
+ return ($ary, $thaw);
}
-
sub _dump_hash {
- my ($self,$item,$depth,$dumped,$name,$indent,$addr,$class)=@_;
+ my ($self, $item, $depth, $dumped, $name, $indent, $addr, $class)= @_;
#Carp::confess "$name" unless defined $self->{ref_hkcnt}{$addr};
- my ($keyary)= $self->_get_keys($item,1,$addr,$class);
+ my ($keyary)= $self->_get_keys($item, 1, $addr, $class);
if ($keyary and $DEBUG) {
- warn "Keys: $keyary : @$keyary"
+ warn "Keys: $keyary : @$keyary";
}
- my $full_indent=$self->{style}{indent}>1;
- my $ind=($self->{style}{indent}) &&
- (!defined($self->{ref_hkcnt}{$addr}) or $self->{ref_hkcnt}{$addr}>1);
+ my $full_indent= $self->{style}{indent} > 1;
+ my $ind= ($self->{style}{indent})
+ && (!defined($self->{ref_hkcnt}{$addr})
+ or $self->{ref_hkcnt}{$addr} > 1);
- $self->_brace($name,'{',$ind,$indent,$self->{ref_hkcnt}{$addr}) ;
+ $self->_brace($name, '{', $ind, $indent, $self->{ref_hkcnt}{$addr});
- my $indkey=($ind && $self->{style}{indentkeys}) ? $self->{ref_hklen}{$addr} : 0;
+ my $indkey=
+ ($ind && $self->{style}{indentkeys}) ? $self->{ref_hklen}{$addr} : 0;
my $cindent= $indent;
my $style= $self->{style};
@@ -2521,237 +2671,246 @@ sub _dump_hash {
my $sep= $optspace . $self->{style}{hashsep} . $optspace;
my $pairsep= $self->{style}{pairsep};
if ($indkey) {
- $cindent+= $indkey + length($sep);
+ $cindent += $indkey + length($sep);
}
- $DEBUG==10 and print "Indent $ind $indkey $cindent\n";
- my ($kc,$ix)=(0,0);
- my $last_n=0;
- my $ind_str=" " x $indent;
-
- while (defined(my $k=defined $keyary ? $keyary->[$ix++] : each %$item)) {
- $last_n=0 if ref $item->{$k};
- if ( $kc ) {
- my $do_ind=$ind && !$last_n ;
+ $DEBUG == 10 and print "Indent $ind $indkey $cindent\n";
+ my ($kc, $ix)= (0, 0);
+ my $last_n= 0;
+ my $ind_str= " " x $indent;
+
+ while (defined(my $k= defined $keyary ? $keyary->[ $ix++ ] : each %$item)) {
+ $last_n= 0 if ref $item->{$k};
+ if ($kc) {
+ my $do_ind= $ind && !$last_n;
$self->{fh}->print($pairsep, $do_ind ? "\n$ind_str" : $optspace);
$self->{buf}++;
if ($do_ind) {
- $self->{buf}=0;
- } elsif (!$do_ind && !$optspace && $self->{buf} > 1024 ) {
+ $self->{buf}= 0;
+ }
+ elsif (!$do_ind && !$optspace && $self->{buf} > 1024) {
$self->{fh}->print("\n");
- $self->{buf}=0;
+ $self->{buf}= 0;
}
- } else {
+ }
+ else {
#$self->{fh}->print("\n$ind_str") if !$last_n;
- $kc=1;
+ $kc= 1;
}
if ($indkey) {
- my $qk=_quotekey($k);
- my $str=$indkey>=length($qk)
- ? join "",$qk," " x ($indkey-length($qk)), $sep
- : join "",$qk,"\n$ind_str"," " x $indkey, $sep
- ;
+ my $qk= _quotekey($k);
+ my $str=
+ $indkey >= length($qk)
+ ? join "", $qk, " " x ($indkey - length($qk)), $sep
+ : join "", $qk, "\n$ind_str", " " x $indkey, $sep;
- $self->{buf}+=length($str);
+ $self->{buf} += length($str);
$self->{fh}->print($str);
- } else {
- my $str=_quotekey($k).$sep;
- $self->{buf}+=length($str);
+ }
+ else {
+ my $str= _quotekey($k) . $sep;
+ $self->{buf} += length($str);
$self->{fh}->print($str);
}
- my $alias=$self->_dump_sv($item->{$k},$depth+1,$dumped,
- $self->_build_name($name,'{',$k),
- $cindent
- );
- if (!$full_indent and !$self->{do_nl} and $self->{buf}<60) {
+ my $alias= $self->_dump_sv($item->{$k}, $depth + 1, $dumped,
+ $self->_build_name($name, '{', $k), $cindent);
+ if (!$full_indent and !$self->{do_nl} and $self->{buf} < 60) {
+
#warn "$self->{buf}\n";
$last_n++;
- } else {
+ }
+ else {
#warn "$self->{buf}\n";
- $last_n=0;
+ $last_n= 0;
}
if ($alias) {
- $self->_add_fix('sub call','alias_hv',
- $self->_build_name($name,'%'),
- _quote($k),
- $alias
- );
+ $self->_add_fix('sub call', 'alias_hv',
+ $self->_build_name($name, '%'),
+ _quote($k), $alias);
}
}
- $self->_brace($name,'}',$ind,$indent,$self->{ref_hkcnt}{$addr});
- return
+ $self->_brace($name, '}', $ind, $indent, $self->{ref_hkcnt}{$addr});
+ return;
}
sub _dump_array {
- my ($self,$item,$depth,$dumped,$name,$indent)=@_;
- my $full_indent=$self->{style}{indent}>1;
- my $ind=$self->{style}{indent} && @$item>1;
-
- $self->_brace($name,'[',$ind,$indent,scalar @$item);
- my $last_n=0;
- my $ind_str=(" " x $indent);
- my ($optspace,$sep)=@{$self->{style}}{qw(optspace arysep)};
- unless ($self->{style}{rle} ) {
- foreach my $k (0..$#$item) {
- my $do_ind=$ind && (!$last_n || ref $item->[$k]);
+ my ($self, $item, $depth, $dumped, $name, $indent)= @_;
+ my $full_indent= $self->{style}{indent} > 1;
+ my $ind= $self->{style}{indent} && @$item > 1;
+
+ $self->_brace($name, '[', $ind, $indent, scalar @$item);
+ my $last_n= 0;
+ my $ind_str= (" " x $indent);
+ my ($optspace, $sep)= @{ $self->{style} }{qw(optspace arysep)};
+ unless ($self->{style}{rle}) {
+ foreach my $k (0 .. $#$item) {
+ my $do_ind= $ind && (!$last_n || ref $item->[$k]);
if ($k) {
$self->{fh}->print($sep, $do_ind ? "\n$ind_str" : $optspace);
if ($do_ind) {
- $self->{buf}=0;
- } elsif (!$do_ind && !$optspace && $self->{buf} > 1024 ) {
+ $self->{buf}= 0;
+ }
+ elsif (!$do_ind && !$optspace && $self->{buf} > 1024) {
$self->{fh}->print("\n");
- $self->{buf}=0;
+ $self->{buf}= 0;
}
}
+ my $alias= $self->_dump_sv($item->[$k], $depth + 1, $dumped,
+ $self->_build_name($name, '[', $k), $indent);
- my $alias=$self->_dump_sv($item->[$k],$depth+1,$dumped,
- $self->_build_name($name,'[',$k),
- $indent
- );
+ if (!$full_indent and !$self->{do_nl} and $self->{buf} < 60) {
- if (!$full_indent and !$self->{do_nl} and $self->{buf}<60) {
#warn "$last_n\n";
$last_n++;
- } else {
- $last_n=0;
+ }
+ else {
+ $last_n= 0;
}
if ($alias) {
- $self->_add_fix('sub call','alias_av',
- $self->_build_name($name,'@'),
- $k,
- $alias
- );
+ $self->_add_fix('sub call', 'alias_av',
+ $self->_build_name($name, '@'),
+ $k, $alias);
}
}
- } else {
+ }
+ else {
# this is evil and must be changed.
# ... evil ... totally evil... blech
- for ( my $k = 0 ; $k <= $#$item ; ) {
- my $v = $item->[$k];
- my $count = 1;
- if (!refaddr($item->[$k]) and !readonly($item->[$k])
- and (!$self->{sv}{refaddr(\$item->[$k])} or
- $self->{svt}[$self->{sv}{refaddr(\$item->[$k])}]==1)
- )
- {
- COUNT:while (
- $k + $count <= $#$item
+ for (my $k= 0 ; $k <= $#$item ;) {
+ my $v= $item->[$k];
+ my $count= 1;
+ if (
+ !refaddr($item->[$k])
+ and !readonly($item->[$k])
+ and ( !$self->{sv}{ refaddr(\$item->[$k]) }
+ or $self->{svt}[ $self->{sv}{ refaddr(\$item->[$k]) } ] ==
+ 1)
+ ) {
+ COUNT:
+ while (
+ $k + $count <= $#$item
and !refaddr($item->[ $k + $count ])
and !readonly($item->[ $k + $count ])
- and (!$self->{sv}{refaddr(\$item->[$k + $count])} or
- $self->{svt}[$self->{sv}{refaddr(\$item->[$k + $count])}]==1)
+ and ( !$self->{sv}{ refaddr(\$item->[ $k + $count ]) }
+ or $self->{svt}
+ [ $self->{sv}{ refaddr(\$item->[ $k + $count ]) } ] ==
+ 1)
and !$v == !$item->[ $k + $count ]
- and defined($v) == defined($item->[ $k + $count ])
- )
+ and defined($v) == defined($item->[ $k + $count ]))
{
- if (!defined( $item->[ $k + $count ] )) {
+ if (!defined($item->[ $k + $count ])) {
last COUNT if defined($v);
- } else {
- last COUNT if
- $v ne overload::StrVal( $item->[ $k + $count ] )
+ }
+ else {
+ last COUNT
+ if $v ne overload::StrVal($item->[ $k + $count ]);
}
$count++;
}
}
- my $do_ind=$ind && (!$last_n || ref $item->[$k]);
+ my $do_ind= $ind && (!$last_n || ref $item->[$k]);
$self->{fh}->print($sep, $do_ind ? "\n$ind_str" : $optspace)
if $k;
- $self->{buf}=0 if $do_ind and $k;
- if ($count>1){
+ $self->{buf}= 0 if $do_ind and $k;
+ if ($count > 1) {
$self->{fh}->print("($optspace");
- $self->{buf}+=2;
+ $self->{buf} += 2;
}
- my $alias=$self->_dump_sv($item->[$k],$depth+1,$dumped,
- $self->_build_name($name,'[',$k),
- $indent
- );
- if (!$full_indent and !$self->{do_nl} and $self->{buf}<60) {
+ my $alias= $self->_dump_sv($item->[$k], $depth + 1, $dumped,
+ $self->_build_name($name, '[', $k), $indent);
+ if (!$full_indent and !$self->{do_nl} and $self->{buf} < 60) {
$last_n++;
- } else {
- $last_n=0;
+ }
+ else {
+ $last_n= 0;
}
if ($alias) {
- $self->_add_fix('sub call','alias_av',
- $self->_build_name($name,'@'),
- $k,
- $alias
- );
- }
- if ($count>1) {
- my $str=join $optspace,'',')','x',$count;
- $self->{buf}+=length($str);
+ $self->_add_fix('sub call', 'alias_av',
+ $self->_build_name($name, '@'),
+ $k, $alias);
+ }
+ if ($count > 1) {
+ my $str= join $optspace, '', ')', 'x', $count;
+ $self->{buf} += length($str);
$self->{fh}->print($str);
}
$k += $count;
}
}
- $self->_brace($name,']',$ind,$indent,scalar @$item);
- return
+ $self->_brace($name, ']', $ind, $indent, scalar @$item);
+ return;
}
sub __vstr {
- my ($v,@v);
+ my ($v, @v);
unless (@_) {
- $v=$];
- } elsif (@_==1) {
- $v=shift;
- } else {
- @v=@_;
- }
- return join ".", @v ? (@v,(0) x 3)[0..2]
- : map { $v * 1000**$_ % 1000 } 0..2
+ $v= $];
+ }
+ elsif (@_ == 1) {
+ $v= shift;
+ }
+ else {
+ @v= @_;
+ }
+ return join ".", @v
+ ? (@v, (0) x 3)[ 0 .. 2 ]
+ : map { $v * 1000**$_ % 1000 } 0 .. 2;
}
sub _dump_code {
- my ($self,$item,$name,$indent,$class)=@_;
+ my ($self, $item, $name, $indent, $class)= @_;
unless ($self->{style}{deparse}) {
$self->{fh}->print($self->{style}{codestub});
- } else { #deparseopts
- my $cv=B::svref_2object($item);
+ }
+ else { #deparseopts
+ my $cv= B::svref_2object($item);
- if (ref($cv->ROOT)=~/NULL/) {
- my $gv=$cv->GV;
- $self->{fh}->print("\\&",$gv->STASH->NAME,"::",$gv->SAFENAME);
+ if (ref($cv->ROOT) =~ /NULL/) {
+ my $gv= $cv->GV;
+ $self->{fh}->print("\\&", $gv->STASH->NAME, "::", $gv->SAFENAME);
return;
}
- my $deparser=Data::Dump::Streamer::Deparser->new(@{$self->{style}{deparseopts}});
+ my $deparser= Data::Dump::Streamer::Deparser->new(
+ @{ $self->{style}{deparseopts} });
my $used= _get_lexicals($item);
my %targ;
foreach my $targ (keys %$used) {
- next if $targ=~/\D/;
- my $addr=refaddr($used->{$targ});
- $targ{$targ}=$self->{lexicals}{a2n}{$addr}
+ next if $targ =~ /\D/;
+ my $addr= refaddr($used->{$targ});
+ $targ{$targ}= $self->{lexicals}{a2n}{$addr}
if $self->{lexicals}{a2n}{$addr};
}
# we added this method, its not a normal method. see bottom of file.
$deparser->dds_usenames(\%targ);
- my $bless=undef;
+ my $bless= undef;
my $code;
- DEPARSE:{
- $bless=($class,bless($item,$bless))[0] if defined $bless;
- eval { $code=$deparser->coderef2text($item) };
- bless $item,$bless if defined $bless;
- if (!defined $bless and $@ and
- $@ =~ /^\QUsage: ->coderef2text(CODEREF)\E/)
+ DEPARSE: {
+ $bless= ($class, bless($item, $bless))[0] if defined $bless;
+ eval { $code= $deparser->coderef2text($item) };
+ bless $item, $bless if defined $bless;
+ if ( !defined $bless
+ and $@
+ and $@ =~ /^\QUsage: ->coderef2text(CODEREF)\E/)
{
- $bless='CODE';
+ $bless= 'CODE';
redo DEPARSE;
- } elsif ($@) {
- warnings::warnif "Using CODE stub for $name as ".
- "B::Deparse->coderef2text (v$B::Deparse::VERSION".
- " on v@{[__vstr]}) failed. Message was:\n $@";
+ }
+ elsif ($@) {
+ warnings::warnif "Using CODE stub for $name as "
+ . "B::Deparse->coderef2text (v$B::Deparse::VERSION"
+ . " on v@{[__vstr]}) failed. Message was:\n $@";
$self->{fh}->print($self->{style}{codestub});
return;
}
@@ -2761,288 +2920,332 @@ sub _dump_code {
#$code=~s/^\s*(\([^)]+\)|)\s*/sub$1\n/;
- $code=~s/(\%\{)(\s*\{\}\s*)/$1;$2/g;
+ $code =~ s/(\%\{)(\s*\{\}\s*)/$1;$2/g;
- $code="sub".($code=~/^\s*\(/ ? "" : " ").$code;
+ $code= "sub" . ($code =~ /^\s*\(/ ? "" : " ") . $code;
if ($self->{style}{indent}) {
- $code=~s/\n/"\n"." " x $indent/meg;
+ $code =~ s/\n/"\n"." " x $indent/meg;
}
+
#warn $name;
- if ($name=~s/^\&//) {
- $code=~s/sub(\s)?/sub $name$1/;
+ if ($name =~ s/^\&//) {
+ $code =~ s/sub(\s)?/sub $name$1/;
}
$self->{fh}->print("$code");
}
- return
+ return;
}
sub _dump_format {
+
# from link from [ysth]: http://groups.google.com/groups?selm=laUs8gzkgOlT092yn%40efn.org
# translate arg (or reference to it) into a B::* object
- my ($self,$item,$name,$indent)=@_;
-
+ my ($self, $item, $name, $indent)= @_;
if ($self->{style}{deparse}) {
- my $Bobj = B::svref_2object($item);
+ my $Bobj= B::svref_2object($item);
+
# if passed a glob or globref, get the format
- $Bobj = B::GV::FORM($Bobj) if ref $Bobj eq 'B::GV';
+ $Bobj= B::GV::FORM($Bobj) if ref $Bobj eq 'B::GV';
if (ref $Bobj eq 'B::FM') {
my $format;
eval {
- my $deparser = Data::Dump::Streamer::Deparser->new();
- $format=$deparser->indent($deparser->deparse_format($Bobj));
+ my $deparser= Data::Dump::Streamer::Deparser->new();
+ $format= $deparser->indent($deparser->deparse_format($Bobj));
};
if ($@) {
- warnings::warnif "B::Deparse (v$B::Deparse::VERSION on v@{[__vstr]}) failed FORMAT ref deparse.\n";
- $format="B::Deparse (v$B::Deparse::VERSION on v@{[__vstr]}) failed FORMAT ref deparse.\n.\n";
+ warnings::warnif
+ "B::Deparse (v$B::Deparse::VERSION on v@{[__vstr]}) failed FORMAT ref deparse.\n";
+ $format=
+ "B::Deparse (v$B::Deparse::VERSION on v@{[__vstr]}) failed FORMAT ref deparse.\n.\n";
}
- my $ind=$self->{style}{indent} ? ' ' x $indent : '';
- $format="format F =\n$format";
- $format=~s/^/${ind}# /gm;
+ my $ind= $self->{style}{indent} ? ' ' x $indent : '';
+ $format= "format F =\n$format";
+ $format =~ s/^/${ind}# /gm;
- my $end='_EOF_FORMAT_';
- $end=~s/T(\d*)_/sprintf "T%02d_",($1||0)+1/e
- while $format=~/$end/;
+ my $end= '_EOF_FORMAT_';
+ $end =~ s/T(\d*)_/sprintf "T%02d_",($1||0)+1/e
+ while $format =~ /$end/;
- $self->{fh}->print("do{ local *F; my \$F=<<'$end'; \$F=~s/^\\s+# //mg; eval \$F; die \$F.\$@ if \$@; *F{FORMAT};\n$format\n$end\n$ind}");
- return
+ $self->{fh}->print(
+ "do{ local *F; my \$F=<<'$end'; \$F=~s/^\\s+# //mg; eval \$F; die \$F.\$@ if \$@; *F{FORMAT};\n$format\n$end\n$ind}"
+ );
+ return;
}
}
$self->{fh}->print($self->{style}{formatstub});
-
}
sub _dump_symbol {
- my ($self,$item,$name,$glob,$deref,$depth)=@_;
+ my ($self, $item, $name, $glob, $deref, $depth)= @_;
- my $ret="Symbol::gensym";
- $ret="do{ require Symbol; $ret }"
+ my $ret= "Symbol::gensym";
+ $ret= "do{ require Symbol; $ret }"
unless $self->{reqs}{Symbol}++;
- $ret="*{ $ret }"
+ $ret= "*{ $ret }"
if $deref;
- $self->{fh}->print( $ret );
+ $self->{fh}->print($ret);
if ($self->{style}{dumpglob} and !$self->{sv_glob_du}{$glob}++) {
- $self->_add_fix('glob',$_[1],$glob,$depth+1,$name);
+ $self->_add_fix('glob', $_[1], $glob, $depth + 1, $name);
}
}
sub _dump_rv {
- my ($self,$item,$depth,$dumped,$name,$indent,$add_do)=@_;
+ my ($self, $item, $depth, $dumped, $name, $indent, $add_do)= @_;
- my ($addr,$idx,$type,$class,$is_frozen_replacement,$overloaded,
+ my ($addr, $idx, $type, $class, $is_frozen_replacement, $overloaded,
$raddr);
GETITEM: {
- $addr=refaddr($item) or Carp::confess "$name : $item";
- $idx=$self->{ref}{$addr};
- $type=reftype($item);
- $class=blessed($item);
- $class=undef if $class and $class eq 'Regexp' and is_regexp $item;
+ $addr= refaddr($item) or Carp::confess "$name : $item";
+ $idx= $self->{ref}{$addr};
+ $type= reftype($item);
+ $class= blessed($item);
+ $class= undef if $class and $class eq 'Regexp' and is_regexp $item;
- $DEBUG and
- printf "_dump_rv %d %s %#x\n",$depth,$name,$addr;
+ $DEBUG
+ and printf "_dump_rv %d %s %#x\n", $depth, $name, $addr;
- my $ignore=0;
+ my $ignore= 0;
if ($self->{ref_fz}{$addr}) {
$item= $self->{ref_fz}{$addr};
- if ( ! $item ) {
- $ignore=1;
- } elsif (ref $item) {
- $is_frozen_replacement=1;
- $dumped= \do{my $d};
- $raddr=$addr;
+ if (!$item) {
+ $ignore= 1;
+ }
+ elsif (ref $item) {
+ $is_frozen_replacement= 1;
+ $dumped= \do { my $d };
+ $raddr= $addr;
redo GETITEM;
- } else {
- $self->{buf}+=length($item);
+ }
+ else {
+ $self->{buf} += length($item);
$self->{fh}->print($item);
- return
+ return;
}
}
- if ($ignore or $self->{style}{ignore}{"#".($raddr||$addr)} or
- (defined $class and $self->{style}{ignore}{".$class"} )
- ){
- my $str= _quote("Ignored Obj [".overload::StrVal($item)."]");
+ if ( $ignore
+ or $self->{style}{ignore}{ "#" . ($raddr || $addr) }
+ or (defined $class and $self->{style}{ignore}{".$class"}))
+ {
+ my $str= _quote("Ignored Obj [" . overload::StrVal($item) . "]");
$self->{buf} += length($str);
$self->{fh}->print($str);
- return
+ return;
}
}
-
unless ($idx) {
+
#Carp::confess "Unhandled address $addr $name\n";
# this should only happen for localized globs.
- ($idx)=$self->_reg_ref($item,$depth,$name,refcount($item));
+ ($idx)= $self->_reg_ref($item, $depth, $name, refcount($item));
}
- my $optspace=$self->{style}{optspace};
+ my $optspace= $self->{style}{optspace};
if ($idx) {
- my $pre_dumped=$self->{refdu}[$idx];
- my $str="";
+ my $pre_dumped= $self->{refdu}[$idx];
+ my $str= "";
if ($pre_dumped and $$pre_dumped) {
+
# its been dumped totally
$DEBUG and print " predumped $self->{refn}[$idx]\n";
- if ($self->{refn}[$idx]=~/^[\@\%\&]/) {
+ if ($self->{refn}[$idx] =~ /^[\@\%\&]/) {
if (SvREADONLY_ref($item)) {
- my @hidden_keys=sort(hidden_keys(%$item));
- $self->_add_fix('lock',$idx,\@hidden_keys);
+ my @hidden_keys= sort(hidden_keys(%$item));
+ $self->_add_fix('lock', $idx, \@hidden_keys);
}
- $str=join "",($class ? "bless($optspace" : ''),
- '\\'.$self->{refn}[$idx],
- ($class ? ",$optspace"._quote($class)."$optspace)" : '');
- } else {
- $str=$self->{refn}[$idx];
+ $str= join "", ($class ? "bless($optspace" : ''),
+ '\\' . $self->{refn}[$idx], (
+ $class ? ",$optspace" . _quote($class) . "$optspace)" : '');
+ }
+ else {
+ $str= $self->{refn}[$idx];
}
- $self->{buf}+=length($str);
+ $self->{buf} += length($str);
$self->{fh}->print($str);
- return
- } elsif ($pre_dumped or $self->{refd}[$idx] < $depth) {
- $DEBUG and print " inprocess or depth violation: $self->{refd}[$idx] < $depth\n";
+ return;
+ }
+ elsif ($pre_dumped or $self->{refd}[$idx] < $depth) {
+ $DEBUG
+ and print
+ " inprocess or depth violation: $self->{refd}[$idx] < $depth\n";
+
# we are in the process of dumping it
# output a place holder and add a fix statement
# XXX is this sigil test correct? why not $?
- if ($self->{refn}[$idx]=~/^[\@\%\&]/ and (!$self->{style}{declare})) {
- $str=join"",( $class ? "bless($optspace" : '' ),
- '\\'.$self->{refn}[$idx],
- ( $class ? ",$optspace"._quote($class)."$optspace)" : '' );
- } else {
+ if ($self->{refn}[$idx] =~ /^[\@\%\&]/
+ and (!$self->{style}{declare}))
+ {
+ $str= join "", ($class ? "bless($optspace" : ''),
+ '\\' . $self->{refn}[$idx], (
+ $class ? ",$optspace" . _quote($class) . "$optspace)" : '');
+ }
+ else {
if ($self->{style}{purity}) {
- $str=join"",$add_do ? join($optspace,qw(do { my $v = ),'') : '',
- !$self->{style}{verbose} ? "'V'" : _quote("V: ",$self->{refn}[$idx]),
- $add_do ? $optspace."}" : '';
+ $str=
+ join "",
+ $add_do ? join($optspace, qw(do { my $v = ), '') : '',
+ !$self->{style}{verbose}
+ ? "'V'"
+ : _quote("V: ", $self->{refn}[$idx]),
+ $add_do ? $optspace . "}" : '';
#Carp::cluck "$name $self->{refd}[$idx] < $depth" if $name=~/\*/;
- $self->_add_fix('ref',$name,$idx,$class);
- } else {
- $str=$self->{refn}[$idx];
+ $self->_add_fix('ref', $name, $idx, $class);
+ }
+ else {
+ $str= $self->{refn}[$idx];
}
}
- $self->{buf}+=length($str);
+ $self->{buf} += length($str);
$self->{fh}->print($str);
- return
+ return;
}
- $self->{refdu}[$idx]||=$dumped;
+ $self->{refdu}[$idx] ||= $dumped;
+
#$name=$self->{refn}[$idx]; # override inherited names. ??? maybe not needed
- } else {
+ }
+ else {
Carp::confess "Unhandled object '$item'\n";
}
- my $isoverloaded=0;
+ my $isoverloaded= 0;
if (defined $class and overload::Overloaded($item)) {
- disable_overloading( $item );
+ disable_overloading($item);
$overloaded= $class;
$isoverloaded= 1;
}
- my $thaw= $self->{ref_thaw}{$raddr||$addr};
- my ($inline,$thawtype);
- if ( $thaw ) {
+ my $thaw= $self->{ref_thaw}{ $raddr || $addr };
+ my ($inline, $thawtype);
+ if ($thaw) {
if ($thaw =~ /[^\w:>()-]/) {
- $thawtype= "code";
- } else{
- $inline= $thaw=~s/^->//;
- $thawtype= $thaw=~s/\(\)$// ? "sub" : "method";
+ $thawtype= "code";
+ }
+ else {
+ $inline= $thaw =~ s/^->//;
+ $thawtype= $thaw =~ s/\(\)$// ? "sub" : "method";
}
if ($inline && $thawtype eq 'sub') {
- $self->{buf}+=length($thaw)+1;
- $self->{fh}->print($thaw."(${optspace}");
+ $self->{buf} += length($thaw) + 1;
+ $self->{fh}->print($thaw . "(${optspace}");
}
}
- $self->{do_nl}=1;
- my $add_lock=($type eq 'HASH') && SvREADONLY_ref($item);
- my $fix_lock=0;
- my @hidden_keys=$add_lock ? sort(hidden_keys(%$item)) : ();
+ $self->{do_nl}= 1;
+ my $add_lock= ($type eq 'HASH') && SvREADONLY_ref($item);
+ my $fix_lock= 0;
+ my @hidden_keys= $add_lock ? sort(hidden_keys(%$item)) : ();
if ($add_lock) {
+
#warn "$name\n";
- if ($name!~/^\$/) {
- $fix_lock=1;
- $add_lock=0;
- } else {
- $self->{fh}->print("lock_ref_keys",
- @hidden_keys ? '_plus' : '',
- "(${optspace}"
- );
+ if ($name !~ /^\$/) {
+ $fix_lock= 1;
+ $add_lock= 0;
+ }
+ else {
+ $self->{fh}->print("lock_ref_keys", @hidden_keys ? '_plus' : '',
+ "(${optspace}");
}
}
-
- my $add_bless=defined($class) && ($name!~/^[\@\%\&]/);
+ my $add_bless= defined($class) && ($name !~ /^[\@\%\&]/);
if ($add_bless && !$overloaded) {
- $self->{fh}->print(substr($self->{style}{bless},0,-1),$optspace);
+ $self->{fh}->print(substr($self->{style}{bless}, 0, -1), $optspace);
}
$DEBUG and print " $type : Start typecheck\n";
if ($type eq 'SCALAR' or $type eq 'REF' or $type eq 'GLOB') {
- my ($pat,$mod)=$type eq 'SCALAR' ? regex($item) : ();
- my $glob=$type eq 'GLOB' ? globname $$item : '';
- if ($glob=~/^\*Symbol::GEN/) {
- $self->_dump_symbol($_[1],$name,$glob,0,$depth);
- } elsif (defined $pat) {
+ my ($pat, $mod)= $type eq 'SCALAR' ? regex($item) : ();
+ my $glob= $type eq 'GLOB' ? globname $$item : '';
+ if ($glob =~ /^\*Symbol::GEN/) {
+ $self->_dump_symbol($_[1], $name, $glob, 0, $depth);
+ }
+ elsif (defined $pat) {
+
# its a regex
- $self->_dump_qr($pat,$mod);
- } else {
- my $ret=$self->_dump_sv($$item,$depth+1,$dumped,
- $self->_build_name($name,'$'),
- $indent,'is_ref'
- );
- $self->{refdu}[$idx]=$ret if $ret;
- }
- } elsif ($type eq 'ARRAY') {
- $self->_dump_array($item,$depth,$dumped,$name,$indent);
- } elsif ($type eq 'HASH') {
- $self->_dump_hash($item,$depth,$dumped,$name,$indent,$addr,$class);
- } elsif ($type eq 'CODE') {
- $self->_dump_code($item,$name,$indent,$class);
- } elsif ($type eq 'FORMAT') {
+ $self->_dump_qr($pat, $mod);
+ }
+ else {
+ my $ret=
+ $self->_dump_sv($$item, $depth + 1, $dumped,
+ $self->_build_name($name, '$'),
+ $indent, 'is_ref');
+ $self->{refdu}[$idx]= $ret if $ret;
+ }
+ }
+ elsif ($type eq 'ARRAY') {
+ $self->_dump_array($item, $depth, $dumped, $name, $indent);
+ }
+ elsif ($type eq 'HASH') {
+ $self->_dump_hash($item, $depth, $dumped, $name, $indent, $addr,
+ $class);
+ }
+ elsif ($type eq 'CODE') {
+ $self->_dump_code($item, $name, $indent, $class);
+ }
+ elsif ($type eq 'FORMAT') {
+
#$self->_dump_code($item,$name,$indent,$class); #muwhahahah
- $self->_dump_format($item,$name,$indent);
- } elsif ($type eq 'IO') {
+ $self->_dump_format($item, $name, $indent);
+ }
+ elsif ($type eq 'IO') {
$self->{fh}->print("*{Symbol::gensym()}{IO}");
- } elsif ($type eq 'ORANGE' || $type eq 'Regexp' || $type eq 'REGEXP') {
- my ($pat,$mod)=regex($item);
- $self->_dump_qr($pat,$mod);
- } else {
- Carp::confess "_dump_rv() can't handle '$type' objects yet\n :-(\n";
+ }
+ elsif ($type eq 'ORANGE' || $type eq 'Regexp' || $type eq 'REGEXP') {
+ my ($pat, $mod)= regex($item);
+ $self->_dump_qr($pat, $mod);
+ }
+ else {
+ Carp::confess "_dump_rv() can't handle '$type' objects yet\n :-(\n";
}
if ($add_bless) {
- unless ( defined $overloaded ) {
- $self->{fh}->print(",${optspace}",_quote($class),$optspace,substr($self->{style}{bless},-1))
- } else {
- $self->_add_fix('bless',$idx,$overloaded);
+ unless (defined $overloaded) {
+ $self->{fh}->print(",${optspace}", _quote($class), $optspace,
+ substr($self->{style}{bless}, -1));
+ }
+ else {
+ $self->_add_fix('bless', $idx, $overloaded);
}
if ($isoverloaded) {
- restore_overloading( $item, $overloaded );
+ restore_overloading($item, $overloaded);
}
}
if ($fix_lock && !defined($class)) {
- $self->_add_fix('lock',$idx,\@hidden_keys);
+ $self->_add_fix('lock', $idx, \@hidden_keys);
}
if ($add_lock) {
if (@hidden_keys) {
- $self->{fh}->print(",${optspace}",join(",${optspace}",map {_quote($_)} @hidden_keys));
+ $self->{fh}->print(",${optspace}",
+ join(",${optspace}", map { _quote($_) } @hidden_keys));
}
$self->{fh}->print("${optspace})");
}
- if ( $thaw ) {
+ if ($thaw) {
if ($inline) {
if ($thawtype eq 'sub') {
$self->{fh}->print("${optspace})");
- } elsif ($thawtype eq 'method') {
+ }
+ elsif ($thawtype eq 'method') {
$self->{fh}->print("->$thaw()");
}
+
#$$dumped=1;
- } else {
- $self->_add_fix('thaw', $idx, $thaw.($thawtype eq 'sub' ? "()" :"" ));
+ }
+ else {
+ $self->_add_fix('thaw', $idx,
+ $thaw . ($thawtype eq 'sub' ? "()" : ""));
}
}
- if ( my $postop=$self->{ref_postop}{$raddr||$addr} ) {
+ if (my $postop= $self->{ref_postop}{ $raddr || $addr }) {
if (ref $postop) {
$postop->($_[1]);
- } else {
+ }
+ else {
$_[1]->$postop();
}
}
- $self->{do_nl}=1;
+ $self->{do_nl}= 1;
- return
+ return;
}
=item Names
@@ -3073,27 +3276,30 @@ If you wish to have no names, use L<Terse>.
=cut
sub Names {
- my $self = shift->_safe_self;
+ my $self= shift->_safe_self;
if (@_) {
- my $v=(@_==1 and reftype $_[0] eq 'ARRAY') ? shift @_ : \@_;
- $self->{unames} = [
+ my $v= (@_ == 1 and reftype $_[0] eq 'ARRAY') ? shift @_ : \@_;
+ $self->{unames}= [
map {
- ( my $s = $_ ) =~ s/^[\@\%\&-]/*/;
- $s=~s/^\$//;
+ (my $s= $_) =~ s/^[\@\%\&-]/*/;
+ $s =~ s/^\$//;
Carp::confess "Bad name '$_'"
- if $s && $s!~/^\*?\w+$/;
+ if $s && $s !~ /^\*?\w+$/;
$s
- } grep {defined} @$v ];
+ } grep { defined } @$v
+ ];
return $self;
- } elsif (! defined wantarray ) {
- $self->{unames}=[];
}
+ elsif (!defined wantarray) {
+ $self->{unames}= [];
+ }
+
#elsif ( eval { require PadWalker; 1 } ) {
# print DDumper(PadWalker::peek_my(1));
# return $self;
#}
- return wantarray ? @{$self->{unames}||[]} : $self->{unames}
+ return wantarray ? @{ $self->{unames} || [] } : $self->{unames};
}
=item Terse
@@ -3109,9 +3315,9 @@ anonymous references or values.
=cut
sub Terse {
- my $self = shift->_safe_self;
- if( @_ ) {
- $self->{style}{terse} = shift;
+ my $self= shift->_safe_self;
+ if (@_) {
+ $self->{style}{terse}= shift;
return $self;
}
else {
@@ -3119,7 +3325,6 @@ sub Terse {
}
}
-
=for UEDIT
sub Purity {}
@@ -3159,9 +3364,9 @@ changed, or the object is destroyed.
=cut
sub To {
- my $self = shift->_safe_self;
+ my $self= shift->_safe_self;
if (@_) {
- $self->{fh} = shift;
+ $self->{fh}= shift;
return $self;
}
return $self->{fh};
@@ -3185,21 +3390,22 @@ Defaults to False.
=cut
sub Indent {
- my $self=shift->_safe_self();
+ my $self= shift->_safe_self();
if (@_) {
- my $val=shift;
+ my $val= shift;
- if ( $val == 0 && length $self->{style}{optspace} ) {
+ if ($val == 0 && length $self->{style}{optspace}) {
$self->{style}{last_optspace}= $self->{style}{optspace};
$self->{style}{optspace}= "";
- } elsif( !$self->{style}{indent} && ! length $self->{style}{optspace} )
- {
+ }
+ elsif (!$self->{style}{indent} && !length $self->{style}{optspace}) {
$self->{style}{optspace}= $self->{style}{last_optspace};
}
$self->{style}{indent}= $val;
- return $self
- } else {
- return $self->{style}{indent}
+ return $self;
+ }
+ else {
+ return $self->{style}{indent};
}
}
@@ -3501,24 +3707,27 @@ Must be set before C<Data()> is called.
sub Freezer {
my $self= shift;
- if ( @_==1 ) {
+ if (@_ == 1) {
$self->{style}{freezer}= shift;
return $self;
- } elsif ( @_==2 ) {
- my ( $class, $action )= @_;
+ }
+ elsif (@_ == 2) {
+ my ($class, $action)= @_;
$self->{style}{freeze_class}{$class}= $action;
return $self;
}
- return wantarray ? ($self->{style}{freezer},
- map { $_ => $self->{style}{freeze_class}{$_} }
- keys %{$self->{style}{freeze_class}} )
- : $self->{style}{freezer};
+ return wantarray
+ ? (
+ $self->{style}{freezer},
+ map { $_ => $self->{style}{freeze_class}{$_} }
+ keys %{ $self->{style}{freeze_class} })
+ : $self->{style}{freezer};
}
sub ResetFreezer {
- my $self=shift;
- $self->{style}{freezer}='DDS_freeze';
- $self->{style}{freeze_class}={};
+ my $self= shift;
+ $self->{style}{freezer}= 'DDS_freeze';
+ $self->{style}{freeze_class}= {};
return $self;
}
@@ -3544,25 +3753,27 @@ Must be set before C<Data()> is called.
=cut
sub Ignore {
- my $self=shift;
- if (@_==0) {
- return map { s/^.//; $_ } keys %{$self->{style}{ignore}};
+ my $self= shift;
+ if (@_ == 0) {
+ return map { s/^.//; $_ } keys %{ $self->{style}{ignore} };
}
Carp::confess("Must have an even number of arguments in Ignore()")
- if @_>1 && @_ %2;
+ if @_ > 1 && @_ % 2;
while (@_) {
- my $item=shift;
- if ( ref $item ) {
- $item="#".refaddr($item);
- } else {
- $item=".$item";
+ my $item= shift;
+ if (ref $item) {
+ $item= "#" . refaddr($item);
+ }
+ else {
+ $item= ".$item";
}
- if ( ! @_ ) {
+ if (!@_) {
return $self->{style}{ignore}{$item};
}
- if ( shift ) {
+ if (shift) {
$self->{style}{ignore}{$item}= 1;
- } else {
+ }
+ else {
delete $self->{style}{ignore}{$item};
}
}
@@ -3619,61 +3830,70 @@ much less efficient for storing binary data.
=cut
# weird styling here deliberate.
-sub
-DeparseOpts
-{
- my $self=shift;
+sub DeparseOpts {
+ my $self= shift;
if (@_) {
if (ref $_[0]) {
- $self->{style}{deparseopts}=shift;
- } else {
- $self->{style}{deparseopts}=[@_];
+ $self->{style}{deparseopts}= shift;
+ }
+ else {
+ $self->{style}{deparseopts}= [@_];
}
return $self;
- } else {
- return wantarray ? @{$self->{style}{deparseopts}}
- : $self->{style}{deparseopts};
+ }
+ else {
+ return wantarray
+ ? @{ $self->{style}{deparseopts} }
+ : $self->{style}{deparseopts};
}
}
sub KeyOrder {
my $self= shift;
- Carp::croak("KeyOrder() Must have an even number of arguments if doing a multiple set.")
- if @_>2 and @_ % 2;
+ Carp::croak(
+ "KeyOrder() Must have an even number of arguments if doing a multiple set."
+ ) if @_ > 2 and @_ % 2;
while (@_) {
my $obj= shift;
my $name;
if (ref $obj) {
- $name= "#" .refaddr($obj)
- } else {
- $name= "" if ! defined $obj;
+ $name= "#" . refaddr($obj);
+ }
+ else {
+ $name= "" if !defined $obj;
$name= ".$obj";
}
- if ( ! @_ ) {
- return $self->{style}{sortkeys_string}{$name}||
- $self->{style}{sortkeys}{$name};
+ if (!@_) {
+ return $self->{style}{sortkeys_string}{$name}
+ || $self->{style}{sortkeys}{$name};
}
my $val= shift;
- if ( ! defined $val ) {
+ if (!defined $val) {
delete $self->{style}{sortkeys}{$name};
delete $self->{style}{sortkeys_string}{$name};
- } else {
- if ( ! ref $val ) {
+ }
+ else {
+ if (!ref $val) {
my $subref= $default_key_sorters{$val};
- Carp::confess("Unblessed or per object Sortkeys() must be coderefs:'$val'\n")
- if (!$subref or $name eq "." )
- and reftype($subref) ne "CODE";
+ Carp::confess(
+ "Unblessed or per object Sortkeys() must be coderefs:'$val'\n"
+ )
+ if (!$subref or $name eq ".")
+ and reftype($subref) ne "CODE";
$subref ||= $obj->can($val);
die "Unknown sortkeys '$val', and "
- . (ref($obj)||$obj)." doesn't know how to do it.\n"
+ . (ref($obj) || $obj)
+ . " doesn't know how to do it.\n"
if !$subref;
- $self->{style}{sortkeys_string}{$name}=$val;
+ $self->{style}{sortkeys_string}{$name}= $val;
$val= $subref;
- } elsif ( reftype($val) eq 'ARRAY' ) {
+ }
+ elsif (reftype($val) eq 'ARRAY') {
my $aryref= $val;
- $val= sub{ return $aryref; };
- } elsif ( reftype($val) ne 'CODE' ) {
+ $val= sub { return $aryref; };
+ }
+ elsif (reftype($val) ne 'CODE') {
Carp::confess("Can't use '$val' as KeyOrder() value");
}
$self->{style}{sortkeys}{$name}= $val;
@@ -3681,130 +3901,134 @@ sub KeyOrder {
}
return $self;
}
-*Keyorder=*KeyOrder;
+*Keyorder= *KeyOrder;
+
sub SortKeys {
- my $self=shift;
- $self->KeyOrder("",@_);
+ my $self= shift;
+ $self->KeyOrder("", @_);
}
*Sortkeys= *SortKeys;
-*HashKeys = *Hashkeys = *KeyOrder;
+*HashKeys= *Hashkeys= *KeyOrder;
-my %scalar_meth=map{ $_ => lc($_)}
- qw(Declare Indent IndentCols IndentKeys
- Verbose DumpGlob Deparse DeparseGlob DeparseFormat CodeStub
- FormatStub Rle RLE Purity DualVars Dualvars EclipseName
- Compress Compressor OptSpace);
+my %scalar_meth= map { $_ => lc($_) } qw(Declare Indent IndentCols IndentKeys
+ Verbose DumpGlob Deparse DeparseGlob DeparseFormat CodeStub
+ FormatStub Rle RLE Purity DualVars Dualvars EclipseName
+ Compress Compressor OptSpace);
sub AUTOLOAD {
- (my $meth=$AUTOLOAD)=~s/^((?:\w+::)+)//;
+ (my $meth= $AUTOLOAD) =~ s/^((?:\w+::)+)//;
my $name;
- if (defined($name=$scalar_meth{$meth})) {
+ if (defined($name= $scalar_meth{$meth})) {
$DEBUG and print "AUTLOADING scalar meth $meth ($name)\n";
eval '
- sub '.$meth.' {
+ sub ' . $meth . ' {
my $self=shift->_safe_self();
if (@_) {
- $self->{style}{'.$name.'}=shift;
+ $self->{style}{' . $name . '}=shift;
return $self
} else {
- return $self->{style}{'.$name.'}
+ return $self->{style}{' . $name . '}
}
}
';
$@ and die "$meth:$@\n";
goto &$meth;
- } elsif ($meth=~/[^A-Z]/) {
+ }
+ elsif ($meth =~ /[^A-Z]/) {
Carp::confess "Unhandled method/subroutine call $AUTOLOAD";
}
}
sub _get_lexicals {
- my $cv=shift;
+ my $cv= shift;
if ($HasPadWalker) {
- my ($names,$targs)=PadWalker::closed_over($cv);
+ my ($names, $targs)= PadWalker::closed_over($cv);
if ($PadWalker::VERSION < 1) {
- $names->{$_}=$names->{$targs->{$_}} for keys %$targs;
- } else {
- %$names=(%$names,%$targs);
+ $names->{$_}= $names->{ $targs->{$_} } for keys %$targs;
+ }
+ else {
+ %$names= (%$names, %$targs);
}
return $names;
}
- my $svo=B::svref_2object($cv);
- my @pl_array = eval { $svo->PADLIST->ARRAY };
- my @name_obj = eval { $pl_array[0]->ARRAY };
+ my $svo= B::svref_2object($cv);
+ my @pl_array= eval { $svo->PADLIST->ARRAY };
+ my @name_obj= eval { $pl_array[0]->ARRAY };
my %named;
- for my $i ( 0..$#name_obj ) {
- if ( ref($name_obj[$i])!~/SPECIAL/) {
- $named{$i} = $name_obj[$i]->PV;
+ for my $i (0 .. $#name_obj) {
+ if (ref($name_obj[$i]) !~ /SPECIAL/) {
+ $named{$i}= $name_obj[$i]->PV;
}
}
my %inited;
my %used;
B::Utils::walkoptree_filtered(
- $svo->ROOT,
- sub { B::Utils::opgrep { name => [ qw[ padsv padav padhv ] ] }, @_ },
- sub {
- my ( $op, @items )=@_;
- my $targ = $op->targ;
- my $name = $named{$targ}
- or return;
-
- $inited{$name}++
- if $op->private & 128;
-
- if ( !$inited{$name} ) {
- $used{$name} = $pl_array[1]->ARRAYelt($targ)->object_2svref;
- $used{$targ} = $used{$name};
- $inited{$name}++;
- }
+ $svo->ROOT,
+ sub { B::Utils::opgrep { name => [qw[ padsv padav padhv ]] }, @_ },
+ sub {
+ my ($op, @items)= @_;
+ my $targ= $op->targ;
+ my $name= $named{$targ}
+ or return;
+
+ $inited{$name}++
+ if $op->private & 128;
+
+ if (!$inited{$name}) {
+ $used{$name}= $pl_array[1]->ARRAYelt($targ)->object_2svref;
+ $used{$targ}= $used{$name};
+ $inited{$name}++;
}
- );
+ });
return \%used;
}
package Data::Dump::Streamer::Deparser;
use B::Deparse;
-our @ISA=qw(B::Deparse);
+our @ISA= qw(B::Deparse);
my %cache;
-our $VERSION = '2.41';
+our $VERSION= '2.42';
$VERSION= eval $VERSION;
-if ( $VERSION ne $Data::Dump::Streamer::VERSION ) {
- die "Incompatible Data::Dump::Streamer::Deparser v$VERSION vs Data::Dump::Streamer v$Data::Dump::Streamer::VERSION";
+if ($VERSION ne $Data::Dump::Streamer::VERSION) {
+ die
+ "Incompatible Data::Dump::Streamer::Deparser v$VERSION vs Data::Dump::Streamer v$Data::Dump::Streamer::VERSION";
}
sub dds_usenames {
- my $self=shift;
- my $names=shift;
- $cache{Data::Dump::Streamer::refaddr $self}=$names;
+ my $self= shift;
+ my $names= shift;
+ $cache{ Data::Dump::Streamer::refaddr $self}= $names;
}
sub padname {
- my $self = shift;
- my $targ = shift;
- if ( $cache{Data::Dump::Streamer::refaddr $self} and $cache{Data::Dump::Streamer::refaddr $self}{$targ} ) {
- return $cache{Data::Dump::Streamer::refaddr $self}{$targ}
+ my $self= shift;
+ my $targ= shift;
+ if ( $cache{ Data::Dump::Streamer::refaddr $self}
+ and $cache{ Data::Dump::Streamer::refaddr $self}{$targ})
+ {
+ return $cache{ Data::Dump::Streamer::refaddr $self}{$targ};
}
return $self->padname_sv($targ)->PVX;
}
sub DESTROY {
- my $self=shift;
- delete $cache{Data::Dump::Streamer::refaddr $self};
+ my $self= shift;
+ delete $cache{ Data::Dump::Streamer::refaddr $self};
}
unless (B::AV->can('ARRAYelt')) {
- eval <<' EOF_EVAL';
+ eval <<'EOF_EVAL';
sub B::AV::ARRAYelt {
my ($obj,$idx)=@_;
my @array=$obj->ARRAY;
return $array[$idx];
}
- EOF_EVAL
+EOF_EVAL
}
1;
diff --git a/lib/Data/Dump/Streamer/_/Printers.pm b/lib/Data/Dump/Streamer/_/Printers.pm
index 4ca2484..045825b 100644
--- a/lib/Data/Dump/Streamer/_/Printers.pm
+++ b/lib/Data/Dump/Streamer/_/Printers.pm
@@ -1,58 +1,59 @@
{
- package Data::Dump::Streamer::_::StringPrinter;
- #$Id: Printers.pm 26 2006-04-16 15:18:52Z demerphq $#
+ package # hide from PAUSE
+ Data::Dump::Streamer::_::StringPrinter;
$VERSION= "0.1";
my %items;
- sub DESTROY { delete $items{$_[0]} }
+ sub DESTROY { delete $items{ $_[0] } }
sub new {
- my $class = shift;
- my $self = bless \do { my $str = '' }, $class;
+ my $class= shift;
+ my $self= bless \do { my $str= '' }, $class;
$self->print(@_);
return $self;
}
sub print {
- my $self = shift;
+ my $self= shift;
$items{$self} .= join "", @_;
}
- sub value { $items{$_[0]} }
+ sub value { $items{ $_[0] } }
sub string { $_[0]->value() }
1;
}
{
- package Data::Dump::Streamer::_::ListPrinter;
+ package # Hide from PAUSE
+ Data::Dump::Streamer::_::ListPrinter;
$VERSION= "0.1";
my %items;
- sub DESTROY { delete $items{$_[0]} }
+ sub DESTROY { delete $items{ $_[0] } }
sub new {
- my $class = shift;
- my $self = bless \do { my $str = '' }, $class;
- $items{$self} = [];
+ my $class= shift;
+ my $self= bless \do { my $str= '' }, $class;
+ $items{$self}= [];
$self->print(@_);
return $self;
}
sub print {
- my $self = $items{shift (@_)};
- my $str = join ( '', @_ );
- if ( !@$self
+ my $self= $items{ shift(@_) };
+ my $str= join('', @_);
+ if ( !@$self
or $self->[-1] =~ /\n/
- or length( $self->[-1] ) > 4000 )
+ or length($self->[-1]) > 4000)
{
push @{$self}, $str;
- } else {
+ }
+ else {
$self->[-1] .= $str;
}
}
- sub value { @{$items{$_[0]}} }
- sub string { join ( '', @{$items{$_[0]}} ) }
+ sub value { @{ $items{ $_[0] } } }
+ sub string { join('', @{ $items{ $_[0] } }) }
1;
}
-
__END__
diff --git a/t/as.t b/t/as.t
index 8b3565f..1907cb4 100644
--- a/t/as.t
+++ b/t/as.t
@@ -1,7 +1,5 @@
#!perl -w
-#$Id: as.t 26 2006-04-16 15:18:52Z demerphq $#
-
use Test::More tests => 4;
use_ok 'Data::Dump::Streamer';
@@ -9,6 +7,7 @@ use_ok 'Data::Dump::Streamer';
import Data::Dump::Streamer as => 'DDS';
{
+
package Foo;
use base Data::Dump::Streamer;
import Data::Dump::Streamer as => 'Bar';
@@ -16,11 +15,11 @@ import Data::Dump::Streamer as => 'DDS';
my $dds;
-$dds = DDS->new;
+$dds= DDS->new;
ok($dds, "aliased namespace works for object construction");
-$dds = Foo->new;
+$dds= Foo->new;
ok($dds, "derived package constructor works");
-$dds = Bar->new;
+$dds= Bar->new;
ok($dds, "aliased namespace works with derived package constructor");
diff --git a/t/blessed.t b/t/blessed.t
index a556b17..0c3e94e 100644
--- a/t/blessed.t
+++ b/t/blessed.t
@@ -1,8 +1,6 @@
# This is from the Scalar::Utils distro
use Data::Dump::Streamer qw(blessed);
-#$Id: blessed.t 26 2006-04-16 15:18:52Z demerphq $#
-
use vars qw($t $y $x);
print "1..7\n";
@@ -19,12 +17,12 @@ print "ok 3\n";
print "not " if blessed([]);
print "ok 4\n";
-$y = \$t;
+$y= \$t;
print "not " if blessed($y);
print "ok 5\n";
-$x = bless [], "ABC";
+$x= bless [], "ABC";
print "not " unless blessed($x);
print "ok 6\n";
diff --git a/t/dogpound.t b/t/dogpound.t
index 3d63a61..53824a3 100644
--- a/t/dogpound.t
+++ b/t/dogpound.t
@@ -1,14 +1,13 @@
use Test::More tests => 11;
-#$Id: dogpound.t 26 2006-04-16 15:18:52Z demerphq $#
-
-BEGIN { use_ok( 'Data::Dump::Streamer', qw(:undump) ); }
+BEGIN { use_ok('Data::Dump::Streamer', qw(:undump)); }
use strict;
use warnings;
use Data::Dumper;
# imports same()
require "./t/test_helper.pl";
+
# use this one for simple, non evalable tests. (GLOB)
# same ( $got,$expected,$name,$obj )
#
@@ -16,18 +15,18 @@ require "./t/test_helper.pl";
# same ( $name,$obj,$expected,@args )
my $dump;
-my $o = Data::Dump::Streamer->new();
+my $o= Data::Dump::Streamer->new();
{
- our @dogs = ( 'Fido', 'Wags' );
- our %kennel = (
- First => \$dogs[0],
- Second => \$dogs[1],
+ our @dogs= ('Fido', 'Wags');
+ our %kennel= (
+ First => \$dogs[0],
+ Second => \$dogs[1],
);
- $dogs[2] = \%kennel;
- our $mutts = \%kennel;
- $mutts = $mutts; # avoid warning
- same( "Dog Pound 1", $o->Declare(1), <<'EXPECT', ( \@dogs,\%kennel,$mutts ) );
+ $dogs[2]= \%kennel;
+ our $mutts= \%kennel;
+ $mutts= $mutts; # avoid warning
+ same("Dog Pound 1", $o->Declare(1), <<'EXPECT', (\@dogs, \%kennel, $mutts));
my $ARRAY1 = [
'Fido',
'Wags',
@@ -40,7 +39,7 @@ my $HASH1 = {
$ARRAY1->[2] = $HASH1;
my $HASH2 = $HASH1;
EXPECT
- same( "Dog Pound 2",$o->Declare(1), <<'EXPECT', ( \%kennel,\@dogs,$mutts ) );
+ same("Dog Pound 2", $o->Declare(1), <<'EXPECT', (\%kennel, \@dogs, $mutts));
my $HASH1 = {
First => 'R: $ARRAY1->[0]',
Second => 'R: $ARRAY1->[1]'
@@ -54,7 +53,7 @@ $HASH1->{First} = \$ARRAY1->[0];
$HASH1->{Second} = \$ARRAY1->[1];
my $HASH2 = $HASH1;
EXPECT
- same( "Dog Pound 3", $o->Declare(1), <<'EXPECT',( \%kennel,$mutts,\@dogs ));
+ same("Dog Pound 3", $o->Declare(1), <<'EXPECT', (\%kennel, $mutts, \@dogs));
my $HASH1 = {
First => 'R: $ARRAY1->[0]',
Second => 'R: $ARRAY1->[1]'
@@ -68,7 +67,7 @@ my $ARRAY1 = [
$HASH1->{First} = \$ARRAY1->[0];
$HASH1->{Second} = \$ARRAY1->[1];
EXPECT
- same( "Dog Pound 4", $o->Declare(1), <<'EXPECT',( $mutts,\%kennel,\@dogs ));
+ same("Dog Pound 4", $o->Declare(1), <<'EXPECT', ($mutts, \%kennel, \@dogs));
my $HASH1 = {
First => 'R: $ARRAY1->[0]',
Second => 'R: $ARRAY1->[1]'
@@ -82,7 +81,8 @@ my $ARRAY1 = [
$HASH1->{First} = \$ARRAY1->[0];
$HASH1->{Second} = \$ARRAY1->[1];
EXPECT
- same( "Dog Pound 5", $o->Declare(1), <<'EXPECT',( $mutts,\@dogs,\%kennel, ) );
+ same("Dog Pound 5", $o->Declare(1),
+ <<'EXPECT', ($mutts, \@dogs, \%kennel,));
my $HASH1 = {
First => 'R: $ARRAY1->[0]',
Second => 'R: $ARRAY1->[1]'
@@ -97,7 +97,7 @@ $HASH1->{Second} = \$ARRAY1->[1];
my $HASH2 = $HASH1;
EXPECT
- same( "Dog Pound 6", $o->Declare(0), <<'EXPECT',( \@dogs,\%kennel,$mutts ));
+ same("Dog Pound 6", $o->Declare(0), <<'EXPECT', (\@dogs, \%kennel, $mutts));
$ARRAY1 = [
'Fido',
'Wags',
@@ -110,7 +110,7 @@ $HASH1 = {
$ARRAY1->[2] = $HASH1;
$HASH2 = $HASH1;
EXPECT
- same( "Dog Pound 7", $o->Declare(0), <<'EXPECT',( \%kennel,\@dogs,$mutts ) );
+ same("Dog Pound 7", $o->Declare(0), <<'EXPECT', (\%kennel, \@dogs, $mutts));
$HASH1 = {
First => 'R: $ARRAY1->[0]',
Second => 'R: $ARRAY1->[1]'
@@ -124,7 +124,7 @@ $HASH1->{First} = \$ARRAY1->[0];
$HASH1->{Second} = \$ARRAY1->[1];
$HASH2 = $HASH1;
EXPECT
- same( "Dog Pound 8",$o->Declare(0), <<'EXPECT', ( \%kennel,$mutts,\@dogs ));
+ same("Dog Pound 8", $o->Declare(0), <<'EXPECT', (\%kennel, $mutts, \@dogs));
$HASH1 = {
First => 'R: $ARRAY1->[0]',
Second => 'R: $ARRAY1->[1]'
@@ -138,7 +138,7 @@ $ARRAY1 = [
$HASH1->{First} = \$ARRAY1->[0];
$HASH1->{Second} = \$ARRAY1->[1];
EXPECT
- same( "Dog Pound 9", $o->Declare(0), <<'EXPECT',( $mutts,\%kennel,\@dogs ) );
+ same("Dog Pound 9", $o->Declare(0), <<'EXPECT', ($mutts, \%kennel, \@dogs));
$HASH1 = {
First => 'R: $ARRAY1->[0]',
Second => 'R: $ARRAY1->[1]'
@@ -152,7 +152,8 @@ $ARRAY1 = [
$HASH1->{First} = \$ARRAY1->[0];
$HASH1->{Second} = \$ARRAY1->[1];
EXPECT
- same( "Dog Pound 10", $o->Declare(0), <<'EXPECT', ( $mutts,\@dogs,\%kennel, ) );
+ same("Dog Pound 10", $o->Declare(0),
+ <<'EXPECT', ($mutts, \@dogs, \%kennel,));
$HASH1 = {
First => 'R: $ARRAY1->[0]',
Second => 'R: $ARRAY1->[1]'
diff --git a/t/dump.t b/t/dump.t
index 5d0ae48..a58ce80 100644
--- a/t/dump.t
+++ b/t/dump.t
@@ -1,13 +1,12 @@
use Test::More tests => 49;
-BEGIN { use_ok( 'Data::Dump::Streamer', qw(:undump Dump DumpLex DumpVars) ); }
+BEGIN { use_ok('Data::Dump::Streamer', qw(:undump Dump DumpLex DumpVars)); }
use strict;
use warnings;
use Data::Dumper;
-#$Id: dump.t 40 2007-12-22 00:37:55Z demerphq $#
-
# imports same()
require "./t/test_helper.pl";
+
# use this one for simple, non evalable tests. (GLOB)
# same ( $got,$expected,$name,$obj )
#
@@ -15,20 +14,25 @@ require "./t/test_helper.pl";
# same ( $name,$obj,$expected,@args )
my $dump;
-my $o = Data::Dump::Streamer->new();
+my $o= Data::Dump::Streamer->new();
-isa_ok( $o, 'Data::Dump::Streamer' );
+isa_ok($o, 'Data::Dump::Streamer');
{
- our ($foo,@foo,%foo,$bar);
- local $foo='yada';
- local @foo=((1)x10,(2) x 10);
+ our ($foo, @foo, %foo, $bar);
+ local $foo= 'yada';
+ local @foo= ((1) x 10, (2) x 10);
no warnings;
- local %foo=(2,*bar,3,sub{ print ('this is a test'),'foo'; print qq(\"bar\"\n); });
+ local %foo= (
+ 2, *bar, 3, sub { print('this is a test'), 'foo'; print qq(\"bar\"\n); }
+ );
use warnings;
- local $bar='BAR';
- my $x=*foo;
- same( do {$dump = $o->Data( $x )->Out; $dump=~s/^\s*(?:use|no).*\n//mg; $dump},
- <<'EXPECT', "DumpGlob, Rle, Deparse", $o );
+ local $bar= 'BAR';
+ my $x= *foo;
+ same(
+ do {
+ $dump= $o->Data($x)->Out; $dump =~ s/^\s*(?:use|no).*\n//mg; $dump;
+ },
+ <<'EXPECT', "DumpGlob, Rle, Deparse", $o);
$VAR1 = *::foo;
*::foo = \do { my $v = 'yada' };
*::foo = {
@@ -46,27 +50,29 @@ $VAR1 = *::foo;
EXPECT
}
{
- local $\="\n";
- same( "Bart's Refs", $o,<<'EXPECT', ( \{},\[],\do{my $x="foo"},\('bar') ) );
+ local $\= "\n";
+ same("Bart's Refs", $o,
+ <<'EXPECT', (\{}, \[], \do { my $x= "foo" }, \('bar')));
$REF1 = \{};
$REF2 = \[];
$SCALAR1 = \do { my $v = 'foo' };
$SCALAR2 = \'bar';
EXPECT
+
# originally the $o was an accident that exposed a bug
# it was supposed to be $t all along, but they tickle different things.
- my $t={};
- bless $t,"Barts::Object::${t}::${o}";
- same( "Bart's Funky Refs", $o,<<'EXPECT', ( $t ) );
+ my $t= {};
+ bless $t, "Barts::Object::${t}::${o}";
+ same("Bart's Funky Refs", $o, <<'EXPECT', ($t));
$Barts_Object_HASH1 = bless( {}, 'Barts::Object::HASH(0xdeadbeef)::Data::Dump::Streamer=HASH(0xdeadbeef)' );
EXPECT
}
{
- my ($a,$b);
-$a = [{ a => \$b }, { b => undef }];
-$b = [{ c => \$b }, { d => \$a }];
- same("Simple Arrays of Simple Hashes", $o, <<'EXPECT', ( $a,$b ) );
+ my ($a, $b);
+ $a= [ { a => \$b }, { b => undef } ];
+ $b= [ { c => \$b }, { d => \$a } ];
+ same("Simple Arrays of Simple Hashes", $o, <<'EXPECT', ($a, $b));
$ARRAY1 = [
{ a => \$ARRAY2 },
{ b => undef }
@@ -76,8 +82,8 @@ $ARRAY2 = [
{ d => \$ARRAY1 }
];
EXPECT
- same( "Predeclare Simple Arrays of Simple Hashes", $o->Declare(1),
- <<'EXPECT',( $a,$b ) );
+ same("Predeclare Simple Arrays of Simple Hashes",
+ $o->Declare(1), <<'EXPECT', ($a, $b));
my $ARRAY1 = [
{ a => 'R: $ARRAY2' },
{ b => undef }
@@ -91,90 +97,94 @@ $ARRAY2->[0]{c} = $ARRAY1->[0]{a};
EXPECT
}
{
- my $x=\"foo";
- my $y=\$x;
- same( "Many Refs ( \$x, \$y ) No declare 1", $o->Declare(0),
- <<'EXPECT', ( $x, $y ) );
+ my $x= \"foo";
+ my $y= \$x;
+ same("Many Refs ( \$x, \$y ) No declare 1",
+ $o->Declare(0), <<'EXPECT', ($x, $y));
$SCALAR1 = \'foo';
$REF1 = \$SCALAR1;
EXPECT
+
#same( "Many Refs ( \$x, \$y )", $o, <<'EXPECT', $x, $y );
#same( $dump = $o->Data( $x,$y )->Declare(1)->Out, <<'EXPECT', "Many Refs Declare ( \$x, \$y )", $o );
- same( "Many Refs Declare ( \$x, \$y ) 1", $o->Declare(1),
- <<'EXPECT', ( $x, $y ) );
+ same("Many Refs Declare ( \$x, \$y ) 1",
+ $o->Declare(1), <<'EXPECT', ($x, $y));
my $SCALAR1 = \'foo';
my $REF1 = \$SCALAR1;
EXPECT
- same( "Many Refs Declare ( \$y, \$x ) 1", $o->Declare(1),
- <<'EXPECT', ( $y,$x ) );
+ same("Many Refs Declare ( \$y, \$x ) 1",
+ $o->Declare(1), <<'EXPECT', ($y, $x));
my $REF1 = 'R: $SCALAR1';
my $SCALAR1 = \'foo';
$REF1 = \$SCALAR1;
EXPECT
- same("Many Refs ( \$y, \$x ) No Declare 1", $o->Declare(0),
- <<'EXPECT', ( $y,$x ) );
+ same("Many Refs ( \$y, \$x ) No Declare 1",
+ $o->Declare(0), <<'EXPECT', ($y, $x));
$REF1 = \$SCALAR1;
$SCALAR1 = \'foo';
EXPECT
}
{
- my $x=\\"foo";
- my $y=\\$x;
- same( "Many Refs ( \$x, \$y ) No declare 2", $o->Declare(0),
- <<'EXPECT', ( $x, $y ) );
+ my $x= \\"foo";
+ my $y= \\$x;
+ same("Many Refs ( \$x, \$y ) No declare 2",
+ $o->Declare(0), <<'EXPECT', ($x, $y));
$REF1 = \\'foo';
$REF2 = \\$REF1;
EXPECT
+
#same( "Many Refs ( \$x, \$y )", $o, <<'EXPECT', $x, $y );
#same( $dump = $o->Data( $x,$y )->Declare(1)->Out, <<'EXPECT', "Many Refs Declare ( \$x, \$y )", $o );
- same( "Many Refs Declare ( \$x, \$y ) 2", $o->Declare(1),
- <<'EXPECT', ( $x, $y ) );
+ same("Many Refs Declare ( \$x, \$y ) 2",
+ $o->Declare(1), <<'EXPECT', ($x, $y));
my $REF1 = \\'foo';
my $REF2 = \\$REF1;
EXPECT
- same( "Many Refs Declare ( \$y, \$x ) 2", $o->Declare(1),
- <<'EXPECT', ( $y,$x ) );
+ same("Many Refs Declare ( \$y, \$x ) 2",
+ $o->Declare(1), <<'EXPECT', ($y, $x));
my $REF1 = \do { my $f = 'R: $REF2' };
my $REF2 = \\'foo';
$$REF1 = \$REF2;
EXPECT
- same("Many Refs ( \$y, \$x ) No Declare 2", $o->Declare(0),
- <<'EXPECT', ( $y,$x ) );
+ same("Many Refs ( \$y, \$x ) No Declare 2",
+ $o->Declare(0), <<'EXPECT', ($y, $x));
$REF1 = \\$REF2;
$REF2 = \\'foo';
EXPECT
}
{
- my $x=\\\"foo";
- my $y=\\\$x;
- same( "Many Refs ( \$x, \$y ) No declare 3", $o->Declare(0),
- <<'EXPECT', ( $x, $y ) );
+ my $x= \\\"foo";
+ my $y= \\\$x;
+ same("Many Refs ( \$x, \$y ) No declare 3",
+ $o->Declare(0), <<'EXPECT', ($x, $y));
$REF1 = \\\'foo';
$REF2 = \\\$REF1;
EXPECT
+
#same( "Many Refs ( \$x, \$y )", $o, <<'EXPECT', $x, $y );
#same( $dump = $o->Data( $x,$y )->Declare(1)->Out, <<'EXPECT', "Many Refs Declare ( \$x, \$y )", $o );
- same( "Many Refs Declare ( \$x, \$y ) 3", $o->Declare(1),
- <<'EXPECT', ( $x, $y ) );
+ same("Many Refs Declare ( \$x, \$y ) 3",
+ $o->Declare(1), <<'EXPECT', ($x, $y));
my $REF1 = \\\'foo';
my $REF2 = \\\$REF1;
EXPECT
- same( "Many Refs Declare ( \$y, \$x ) 3", $o->Declare(1),
- <<'EXPECT', ( $y,$x ) );
+ same("Many Refs Declare ( \$y, \$x ) 3",
+ $o->Declare(1), <<'EXPECT', ($y, $x));
my $REF1 = \\do { my $f = 'R: $REF2' };
my $REF2 = \\\'foo';
$$$REF1 = \$REF2;
EXPECT
- same("Many Refs ( \$y, \$x ) No Declare 3", $o->Declare(0),
- <<'EXPECT', ( $y,$x ) );
+ same("Many Refs ( \$y, \$x ) No Declare 3",
+ $o->Declare(0), <<'EXPECT', ($y, $x));
$REF1 = \\\$REF2;
$REF2 = \\\'foo';
EXPECT
}
+
# with eval testing
{
- my $x=[(1) x 4, 0, (1) x 4];
- same( "Rle(1)", $o->Declare(0)->Rle(0), <<'EXPECT', ( $x ) );
+ my $x= [ (1) x 4, 0, (1) x 4 ];
+ same("Rle(1)", $o->Declare(0)->Rle(0), <<'EXPECT', ($x));
$ARRAY1 = [
1,
1,
@@ -188,23 +198,26 @@ $ARRAY1 = [
];
EXPECT
- same( "Rle(1) Tight", $o->Verbose(0)->Indent(0)->Rle(1), <<'EXPECT', ( $x ) );
+ same("Rle(1) Tight", $o->Verbose(0)->Indent(0)->Rle(1), <<'EXPECT', ($x));
$A1=[(1)x4,0,(1)x4];
EXPECT
- same( "Rle(1)", $o->Verbose(1)->Indent(2)->Rle(1), <<'EXPECT', ( $x ) );
+ same("Rle(1)", $o->Verbose(1)->Indent(2)->Rle(1), <<'EXPECT', ($x));
$ARRAY1 = [
( 1 ) x 4,
0,
( 1 ) x 4
];
EXPECT
+
#local $Data::Dump::Streamer::DEBUG=1;
- my $one=1;
+ my $one= 1;
+
#do this to avoid problems with differing behaviour in (1) x 3
- my @one=(1,1,1);
- my @two=(1,1,1);
- my $y=sub { \@_ }->(@one,$one,0,$one,@two);
- same( "Rle(1) Alias", $o->Rle(1), <<'EXPECT', ( $y ) );
+ my @one= (1, 1, 1);
+ my @two= (1, 1, 1);
+ my $y= sub { \@_ }
+ ->(@one, $one, 0, $one, @two);
+ same("Rle(1) Alias", $o->Rle(1), <<'EXPECT', ($y));
$ARRAY1 = [
( 1 ) x 3,
1,
@@ -218,14 +231,14 @@ EXPECT
}
{
- my $x={
- hash => {0..5},
- array => [0..5],
- object => bless(\do{my $x='Foo!'},'Bar'),
- regex => qr/(?:baz)/,
- };
+ my $x= {
+ hash => { 0 .. 5 },
+ array => [ 0 .. 5 ],
+ object => bless(\do { my $x= 'Foo!' }, 'Bar'),
+ regex => qr/(?:baz)/,
+ };
- same( "Indent", $o->Indent(2), <<'EXPECT', ( $x ) );
+ same("Indent", $o->Indent(2), <<'EXPECT', ($x));
$HASH1 = {
array => [
0,
@@ -244,10 +257,10 @@ $HASH1 = {
regex => qr/(?:baz)/
};
EXPECT
- same( "Indent(0)", $o->Indent(0), <<'EXPECT', ( $x ) );
+ same("Indent(0)", $o->Indent(0), <<'EXPECT', ($x));
$HASH1={array=>[0,1,2,3,4,5],hash=>{0=>1,2=>3,4=>5},object=>bless(\do{my$v='Foo!'},'Bar'),regex=>qr/(?:baz)/};
EXPECT
- same( "IndentCols(0)", $o->Indent(2)->IndentCols(0), <<'EXPECT', ( $x ) );
+ same("IndentCols(0)", $o->Indent(2)->IndentCols(0), <<'EXPECT', ($x));
$HASH1 = {
array => [
0,
@@ -266,7 +279,7 @@ $HASH1 = {
regex => qr/(?:baz)/
};
EXPECT
- same( "IndentCols(4)", $o->Indent(2)->IndentCols(4), <<'EXPECT', ( $x ) );
+ same("IndentCols(4)", $o->Indent(2)->IndentCols(4), <<'EXPECT', ($x));
$HASH1 = {
array => [
0,
@@ -285,7 +298,7 @@ $HASH1 = {
regex => qr/(?:baz)/
};
EXPECT
- same( "IndentCols(2)", $o->Indent(2)->IndentCols(2), <<'EXPECT', ( $x ) );
+ same("IndentCols(2)", $o->Indent(2)->IndentCols(2), <<'EXPECT', ($x));
$HASH1 = {
array => [
0,
@@ -306,8 +319,11 @@ $HASH1 = {
EXPECT
}
{
- my $nums=['00123','00','+001','-001','1e40','-0.1000',-0.1000,1.0,'1.0'];
- same( "Numbers", $o, <<'EXPECT', ( $nums ) );
+ my $nums= [
+ '00123', '00', '+001', '-001', '1e40', '-0.1000',
+ -0.1000, 1.0, '1.0'
+ ];
+ same("Numbers", $o, <<'EXPECT', ($nums));
$ARRAY1 = [
'00123',
'00',
@@ -321,28 +337,32 @@ $ARRAY1 = [
];
EXPECT
}
+
# with eval testing
{
- my ($x,$y)=10;
- my $obj=Dump();
- isa_ok($obj, "Data::Dump::Streamer","Dump() Return noarg/scalar");
- $obj=Dump($x,$y);
- isa_ok($obj, "Data::Dump::Streamer","Dump() Return arg/scalar");
- my @lines=Dump($x,$y);
- ok(!ref($lines[0]),"Dump() Return args/list");
- @lines=Dump($x,$y)->Indent(0)->Out();
- ok(!ref($lines[0]),"Dump() Return args/list-scalar");
+ my ($x, $y)= 10;
+ my $obj= Dump();
+ isa_ok($obj, "Data::Dump::Streamer", "Dump() Return noarg/scalar");
+ $obj= Dump($x, $y);
+ isa_ok($obj, "Data::Dump::Streamer", "Dump() Return arg/scalar");
+ my @lines= Dump($x, $y);
+ ok(!ref($lines[0]), "Dump() Return args/list");
+ @lines= Dump($x, $y)->Indent(0)->Out();
+ ok(!ref($lines[0]), "Dump() Return args/list-scalar");
}
+
# with eval testing
{
- my $x=1;
- my $y=[];
- my $array=sub{\@_ }->( $x,$x,$y );
- push @$array,$y,1;
- unshift @$array,\$array->[-1];
+ my $x= 1;
+ my $y= [];
+ my $array= sub { \@_ }
+ ->($x, $x, $y);
+ push @$array, $y, 1;
+ unshift @$array, \$array->[-1];
+
#Dump($array);
- same( "Documentation example", $o, <<'EXPECT', ( $array ) );
+ same("Documentation example", $o, <<'EXPECT', ($array));
$ARRAY1 = [
'R: $ARRAY1->[5]',
1,
@@ -356,11 +376,12 @@ alias_av(@$ARRAY1, 2, $ARRAY1->[1]);
$ARRAY1->[4] = $ARRAY1->[3];
EXPECT
}
+
# with eval testing
{
- my @a = ('a0'..'a9');
+ my @a= ('a0' .. 'a9');
unshift @a, \\$a[2];
- same( "merlyns test", $o, <<'EXPECT', ( \\@a ) );
+ same("merlyns test", $o, <<'EXPECT', (\\@a));
$REF1 = \[
\do { my $v = 'R: ${$REF1}->[3]' },
'a0',
@@ -378,11 +399,15 @@ ${${$REF1}->[0]} = \${$REF1}->[3];
EXPECT
}
{
- my @a = ('a0'..'a9');
+ my @a= ('a0' .. 'a9');
unshift @a, \\$a[2];
- test_dump( {name=>"merlyns test 2",
- verbose=>1}, $o, ( \\@a ),
- <<'EXPECT', );
+ test_dump({
+ name => "merlyns test 2",
+ verbose => 1
+ },
+ $o,
+ (\\@a),
+ <<'EXPECT',);
$REF1 = \[
\do { my $v = 'R: ${$REF1}->[3]' },
'a0',
@@ -400,7 +425,7 @@ ${${$REF1}->[0]} = \${$REF1}->[3];
EXPECT
}
{
- my $expect = $] >= 5.013_010 ? <<'U_FLAG' : <<'NO_U_FLAG';
+ my $expect= $] >= 5.013_010 ? <<'U_FLAG' : <<'NO_U_FLAG';
$VAR1 = "This contains unicode: /\x{263a}/";
$Regexp1 = qr!This contains unicode: /\x{263a}/!u;
U_FLAG
@@ -409,91 +434,114 @@ $Regexp1 = qr!This contains unicode: /\x{263a}/!;
NO_U_FLAG
use utf8;
- my $r = "This contains unicode: /\x{263A}/";
+ my $r= "This contains unicode: /\x{263A}/";
my $qr= qr/$r/;
- test_dump( {name=>"Unicode qr// and string",
- no_dumper => 1, verbose => 1 }, $o, ( $r,$qr ),
- $expect);
+ test_dump({
+ name => "Unicode qr// and string",
+ no_dumper => 1,
+ verbose => 1
+ },
+ $o,
+ ($r, $qr),
+ $expect
+ );
}
{
use utf8;
- my $r = "\x{100}\x{101}\x{102}";
- test_dump( {name=>"Unicode qr// and string",
- no_dumper=>1,verbose=>1}, $o, ( $r ),
- <<'EXPECT', );
+ my $r= "\x{100}\x{101}\x{102}";
+ test_dump({
+ name => "Unicode qr// and string",
+ no_dumper => 1,
+ verbose => 1
+ },
+ $o,
+ ($r),
+ <<'EXPECT',);
$VAR1 = "\x{100}\x{101}\x{102}";
EXPECT
}
{
- use warnings FATAL=>'all';
- my $r = "Günter";
- test_dump( {name=>"Non unicode, high char",
- verbose=>1}, $o, ( $r ),
- <<'EXPECT', );
+ use warnings FATAL => 'all';
+ my $r= "Günter";
+ test_dump({
+ name => "Non unicode, high char",
+ verbose => 1
+ },
+ $o,
+ ($r),
+ <<'EXPECT',);
$VAR1 = "G\374nter";
EXPECT
}
{
- my $dv=dualvar(unpack('N','JAPH'),'JAPH');
- test_dump( {name=>"Dualvars(0) ",
- verbose=>1}, $o->Dualvars(0), ( $dv ),
- <<'EXPECT', );
+ my $dv= dualvar(unpack('N', 'JAPH'), 'JAPH');
+ test_dump({
+ name => "Dualvars(0) ",
+ verbose => 1
+ },
+ $o->Dualvars(0),
+ ($dv),
+ <<'EXPECT',);
$VAR1 = 'JAPH';
EXPECT
- test_dump( {name=>"Dualvars(1)",
- verbose=>1}, $o->Dualvars(1), ( $dv ),
- <<'EXPECT', );
+ test_dump({
+ name => "Dualvars(1)",
+ verbose => 1
+ },
+ $o->Dualvars(1),
+ ($dv),
+ <<'EXPECT',);
$VAR1 = dualvar( 1245794376, 'JAPH' );
EXPECT
}
{
- my ($x,%y,@z);
- $x=\@z;
- our $global=\@z;
- my $res1=Dump($x,\%y,\@z)->Names(qw(x *y *z))->Out();
- my $res3=DumpVars(x=>$x,-y=>\%y,-z=>\@z)->Out();
- is($res1,$res3,'DumpVars');
+ my ($x, %y, @z);
+ $x= \@z;
+ our $global= \@z;
+ my $res1= Dump($x, \%y, \@z)->Names(qw(x *y *z))->Out();
+ my $res3= DumpVars(x => $x, -y => \%y, -z => \@z)->Out();
+ is($res1, $res3, 'DumpVars');
SKIP: {
- skip "needs PadWalker 0.99 or later", 3
- if !eval "use PadWalker 0.99; 1";
- my $res2=DumpLex($x,\%y,\@z)->Out();
- is($res1,$res2,'DumpLex');
- is($res2,$res3,'DumpLex eq DumpVars');
- is("".DumpLex($x,$global)->Out(),<<'EXPECT','DumpLex w/global');
+ skip "needs PadWalker 0.99 or later", 3
+ if !eval "use PadWalker 0.99; 1";
+ my $res2= DumpLex($x, \%y, \@z)->Out();
+ is($res1, $res2, 'DumpLex');
+ is($res2, $res3, 'DumpLex eq DumpVars');
+ is("" . DumpLex($x, $global)->Out(), <<'EXPECT', 'DumpLex w/global');
$x = [];
$global = $x;
EXPECT
}
}
- SKIP: {
- skip "needs Compress::Zlib and MIME::Base64", 2
+SKIP: {
+ skip "needs Compress::Zlib and MIME::Base64", 2
if !eval "use Compress::Zlib; use MIME::Base64; 1";
- my $str="a" x 1000;
- my $i=bless \$str,"Fnorble";
- my $rep=MIME::Base64::encode(Compress::Zlib::compress($str,9),"");
+ my $str= "a" x 1000;
+ my $i= bless \$str, "Fnorble";
+ my $rep= MIME::Base64::encode(Compress::Zlib::compress($str, 9), "");
$o->Compress(-1);
- my $out=$o->Data($i)->Out();
- (my $expect=<<'EXPECT')=~s/XXX/$rep/;
+ my $out= $o->Data($i)->Out();
+ (my $expect= <<'EXPECT') =~ s/XXX/$rep/;
use Data::Dump::Streamer qw(usqz);
$Fnorble1 = bless( \do { my $v = usqz('XXX') }, 'Fnorble' );
EXPECT
- is($out,$expect,"Compress literal");
+ is($out, $expect, "Compress literal");
$o->OptSpace("");
- $out=$o->Data($i)->Out();
- ($expect=<<'EXPECT')=~s/XXX/$rep/;
+ $out= $o->Data($i)->Out();
+ ($expect= <<'EXPECT') =~ s/XXX/$rep/;
use Data::Dump::Streamer qw(usqz);
$Fnorble1=bless(\do{my$v=usqz('XXX')},'Fnorble');
EXPECT
- is($out,$expect,"Optspace");
- $o->Compress(0);
+ is($out, $expect, "Optspace");
+ $o->Compress(0);
}
{
- my $h={'-'=>1,'-1efg'=>1};
+ my $h= { '-' => 1, '-1efg' => 1 };
$o->OptSpace("");
- same( "'-' hashkeys", $o, <<'EXPECT', ( $h ) );
+ same("'-' hashkeys", $o, <<'EXPECT', ($h));
$HASH1={
"-1efg"=>1,
"-" =>1
@@ -501,10 +549,11 @@ $HASH1={
EXPECT
}
+
# with eval testing
{
- my $h= { "blah\n" => 1,"blah\nblah\n" => 2, "blahblahblah\n\n" => 3 };
- same( "hashkeys with newlines", $o, <<'EXPECT', ( $h ) );
+ my $h= { "blah\n" => 1, "blah\nblah\n" => 2, "blahblahblah\n\n" => 3 };
+ same("hashkeys with newlines", $o, <<'EXPECT', ($h));
$HASH1={
"blah\n" =>1,
"blah\nblah\n" =>2,
diff --git a/t/filter.t b/t/filter.t
index c8de30c..167921b 100644
--- a/t/filter.t
+++ b/t/filter.t
@@ -1,13 +1,12 @@
use Test::More tests => 11;
-BEGIN { use_ok( 'Data::Dump::Streamer', qw(:undump) ); }
+BEGIN { use_ok('Data::Dump::Streamer', qw(:undump)); }
use strict;
use warnings;
use Data::Dumper;
-#$Id: filter.t 26 2006-04-16 15:18:52Z demerphq $#
-
# imports same()
require "./t/test_helper.pl";
+
# use this one for simple, non evalable tests. (GLOB)
# same ( $got,$expected,$name,$obj )
#
@@ -15,21 +14,23 @@ require "./t/test_helper.pl";
# same ( $name,$obj,$expected,@args )
my $dump;
-my $o = Data::Dump::Streamer->new();
+my $o= Data::Dump::Streamer->new();
-isa_ok( $o, 'Data::Dump::Streamer' );
+isa_ok($o, 'Data::Dump::Streamer');
{
- my $ig=bless {},"Ignore";
- my %h=(One=>1,Two=>2,Three=>$ig);
+ my $ig= bless {}, "Ignore";
+ my %h= (One => 1, Two => 2, Three => $ig);
- same( $dump = $o->Ignore('Ignore'=>1)->Data( \%h )->Out, <<'EXPECT', "Ignore(1)", $o );
+ same($dump= $o->Ignore('Ignore' => 1)->Data(\%h)->Out,
+ <<'EXPECT', "Ignore(1)", $o);
$HASH1 = {
One => 1,
Three => 'Ignored Obj [Ignore=HASH(0x24b89cc)]',
Two => 2
};
EXPECT
- same( $dump = $o->Ignore('Ignore'=>0)->Data( \%h )->Out, <<'EXPECT', "Ignore(0)", $o );
+ same($dump= $o->Ignore('Ignore' => 0)->Data(\%h)->Out,
+ <<'EXPECT', "Ignore(0)", $o);
$HASH1 = {
One => 1,
Three => bless( {}, 'Ignore' ),
@@ -41,32 +42,33 @@ EXPECT
{
#$Data::Dump::Streamer::DEBUG=1;
sub Water::DDS_freeze {
- my ($self)=@_;
- return bless(\do{my $x=join "-",@$self},ref $self),
- 'DDS_thaw';
+ my ($self)= @_;
+ return bless(\do { my $x= join "-", @$self }, ref $self), 'DDS_thaw';
}
+
sub Water::DDS_thaw {
- my ($self)=@_;
- $_[0]= bless([ map {split /-/,$_ } $$self ],ref $self);
+ my ($self)= @_;
+ $_[0]= bless([ map { split /-/, $_ } $$self ], ref $self);
}
+
sub Water::Freeze {
- my ($self)=@_;
- return bless(\do{my $x=join "-",@$self},ref $self),
- '->DDS_thaw';
+ my ($self)= @_;
+ return bless(\do { my $x= join "-", @$self }, ref $self), '->DDS_thaw';
}
+
sub Juice::Freeze {
- my ($self)=@_;
- return bless(\do{my $x=join "-",@$self},ref $self),
- 'Thaw';
+ my ($self)= @_;
+ return bless(\do { my $x= join "-", @$self }, ref $self), 'Thaw';
}
+
sub Juice::Thaw {
- my ($self)=@_;
- $_[0]= bless([ map {split /-/,$_ } $$self ],ref $self);
+ my ($self)= @_;
+ $_[0]= bless([ map { split /-/, $_ } $$self ], ref $self);
}
- my $ig=bless ["A".."D"],"Water";
- my %h=(One=>1,Two=>2,Three=>$ig);
+ my $ig= bless [ "A" .. "D" ], "Water";
+ my %h= (One => 1, Two => 2, Three => $ig);
- same( $dump = $o->Data( \%h )->Out, <<'EXPECT', "FreezeThaw", $o );
+ same($dump= $o->Data(\%h)->Out, <<'EXPECT', "FreezeThaw", $o);
$HASH1 = {
One => 1,
Three => bless( \do { my $v = 'A-B-C-D' }, 'Water' ),
@@ -75,9 +77,11 @@ $HASH1 = {
$HASH1->{Three}->DDS_thaw();
EXPECT
{
- no warnings 'redefine';
- local *Water::DDS_freeze=sub { return };
- same( $dump = $o->Data( \%h )->Out, <<'EXPECT', "FreezeThaw Localization 2", $o );
+ no warnings 'redefine';
+ local *Water::DDS_freeze= sub { return };
+ same(
+ $dump= $o->Data(\%h)->Out,
+ <<'EXPECT', "FreezeThaw Localization 2", $o);
$HASH1 = {
One => 1,
Three => bless( [
@@ -92,7 +96,8 @@ EXPECT
}
{
- same( $dump = $o->Freezer('Freeze')->Data( \%h )->Out, <<'EXPECT', "FreezeThaw Localization 3", $o );
+ same($dump= $o->Freezer('Freeze')->Data(\%h)->Out,
+ <<'EXPECT', "FreezeThaw Localization 3", $o);
$HASH1 = {
One => 1,
Three => bless( \do { my $v = 'A-B-C-D' }, 'Water' )->DDS_thaw(),
@@ -102,7 +107,8 @@ EXPECT
}
{
- same( $dump = $o->Freezer('')->Data( \%h )->Out, <<'EXPECT', "FreezeThaw Localization 3", $o );
+ same($dump= $o->Freezer('')->Data(\%h)->Out,
+ <<'EXPECT', "FreezeThaw Localization 3", $o);
$HASH1 = {
One => 1,
Three => bless( [
@@ -117,7 +123,8 @@ EXPECT
}
{
- same( $dump = $o->ResetFreezer()->Data( \%h )->Out, <<'EXPECT', "ResetFreezer()", $o );
+ same($dump= $o->ResetFreezer()->Data(\%h)->Out,
+ <<'EXPECT', "ResetFreezer()", $o);
$HASH1 = {
One => 1,
Three => bless( \do { my $v = 'A-B-C-D' }, 'Water' ),
@@ -129,31 +136,31 @@ EXPECT
}
{
- my $x=bless [],'CIO';
- my $y={x=>$x};
- $x->[0]=$y;
- my $nope=0;
+ my $x= bless [], 'CIO';
+ my $y= { x => $x };
+ $x->[0]= $y;
+ my $nope= 0;
+
sub CIO::DDS_freeze {
- my $self=shift;
+ my $self= shift;
return if $nope;
- return { x0 => $self->[0] },'Unfreeze()'
+ return { x0 => $self->[0] }, 'Unfreeze()';
}
- same( $dump = $o->Data( $x,$y )->Out, <<'EXPECT', "freeze/circular", $o );
+ same($dump= $o->Data($x, $y)->Out, <<'EXPECT', "freeze/circular", $o);
$CIO1 = { x0 => 'V: $HASH1' };
$HASH1 = { x => 'V: $CIO1' };
$CIO1->{x0} = $HASH1;
Unfreeze( $CIO1 );
$HASH1->{x} = $CIO1;
EXPECT
- $nope=1;
- same( $dump = $o->Data( $x,$y )->Out, <<'EXPECT', "nofreeze / circular", $o );
+ $nope= 1;
+ same($dump= $o->Data($x, $y)->Out, <<'EXPECT', "nofreeze / circular", $o);
$CIO1 = bless( [ 'V: $HASH1' ], 'CIO' );
$HASH1 = { x => $CIO1 };
$CIO1->[0] = $HASH1;
EXPECT
}
-
__END__
# with eval testing
{
diff --git a/t/globtest.t b/t/globtest.t
index fc55e56..12a6298 100644
--- a/t/globtest.t
+++ b/t/globtest.t
@@ -1,63 +1,61 @@
-use Test::More tests=>19;
+use Test::More tests => 19;
-#$Id: globtest.t 26 2006-04-16 15:18:52Z demerphq $#
-
-BEGIN { use_ok( 'Data::Dump::Streamer', qw(regex Dump alias_av alias_hv) ); }
+BEGIN { use_ok('Data::Dump::Streamer', qw(regex Dump alias_av alias_hv)); }
use strict;
use warnings;
use Data::Dumper;
# imports same()
require "./t/test_helper.pl";
+
# use this one for simple, non evalable tests. (GLOB)
# same ( $got,$expected,$name,$obj )
#
# use this one for eval checks and dumper checks but NOT for GLOB's
# same ( $name,$obj,$expected,@args )
+my $o= Data::Dump::Streamer->new();
-my $o = Data::Dump::Streamer->new();
-
-isa_ok( $o, 'Data::Dump::Streamer' );
+isa_ok($o, 'Data::Dump::Streamer');
{
- no strict;
- # no. 3 - a glob
- {
- local *g;
- same( scalar $o->Data(*g)->Out, <<'EXPECT', "a glob", $o );
+ no strict;
+
+ # no. 3 - a glob
+ {
+ local *g;
+ same(scalar $o->Data(*g)->Out, <<'EXPECT', "a glob", $o);
$VAR1 = *::g;
EXPECT
- }
+ }
- # no. 4 - scalar slot
- {
- local *g = \"a string";
- ## XXX: the empty globs are an icky 5.8.0 bug
- $^V lt v5.8 ?
- same( scalar $o->Data(*g)->Out, <<'EXPECT', "scalar slot", $o )
+ # no. 4 - scalar slot
+ {
+ local *g= \"a string";
+ ## XXX: the empty globs are an icky 5.8.0 bug
+ $^V lt v5.8
+ ? same(scalar $o->Data(*g)->Out, <<'EXPECT', "scalar slot", $o)
$VAR1 = *::g;
*::g = \'a string';
EXPECT
- :
- same( scalar $o->Data(*g)->Out, <<'EXPECT', "scalar slot", $o )
+ : same(scalar $o->Data(*g)->Out, <<'EXPECT', "scalar slot", $o)
$VAR1 = *::g;
*::g = \'a string';
*::g = {};
*::g = [];
EXPECT
- ;
- }
+ ;
+ }
- # no. 5 - data slots
- {
- local *g;
- $g = 'a string';
- @g = qw/a list/;
- %g = qw/a hash/;
- our ($off,$width,$bits,$val,$res);
- ($off,$width,$bits,$val,$res)=($off,$width,$bits,$val,$res);
- eval'
+ # no. 5 - data slots
+ {
+ local *g;
+ $g= 'a string';
+ @g= qw/a list/;
+ %g= qw/a hash/;
+ our ($off, $width, $bits, $val, $res);
+ ($off, $width, $bits, $val, $res)= ($off, $width, $bits, $val, $res);
+ eval '
format g =
vec($_,@#,@#) = @<< == @######### @>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
$off, $width, $bits, $val, $res
@@ -65,8 +63,11 @@ vec($_,@#,@#) = @<< == @######### @>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
$off, $width, $bits, $val, $res
.
';
- if ( 5.021009 <= $] ) {
- same( scalar $o->Data(*g)->Out, <<'EXPECT', "data slots (glob/FORMAT)", $o );
+
+ if (5.021009 <= $]) {
+ same(
+ scalar $o->Data(*g)->Out,
+ <<'EXPECT', "data slots (glob/FORMAT)", $o);
$VAR1 = *::g;
*::g = \do { my $v = 'a string' };
*::g = { a => 'hash' };
@@ -82,8 +83,11 @@ vec($_,@#,@#) = @<< == @######### @>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
$off, $width, $bits, $val, $res
.
EXPECT
- } else {
- same( scalar $o->Data(*g)->Out, <<'EXPECT', "data slots (glob/FORMAT)", $o );
+ }
+ else {
+ same(
+ scalar $o->Data(*g)->Out,
+ <<'EXPECT', "data slots (glob/FORMAT)", $o);
$VAR1 = *::g;
*::g = \do { my $v = 'a string' };
*::g = { a => 'hash' };
@@ -99,14 +103,17 @@ $off, $width, $bits, $val, $res
.
EXPECT
- }
- SKIP: {
- skip "no FORMAT refs before ".vstr(5,7)." and this is ".vstr(),
- my $NUM=3
- unless 5.008 <= $];
- if ( 5.021009 <= $] ) {
+ }
+ SKIP: {
+ skip "no FORMAT refs before "
+ . vstr(5, 7)
+ . " and this is "
+ . vstr(), my $NUM= 3
+ unless 5.008 <= $];
+ if (5.021009 <= $]) {
- same( scalar $o->Data(*g{FORMAT})->Out, <<'EXPECT', "data slots (ref/FORMAT)", $o );
+ same(scalar $o->Data(*g{FORMAT})->Out,
+ <<'EXPECT', "data slots (ref/FORMAT)", $o);
$FORMAT1 = do{ local *F; my $F=<<'_EOF_FORMAT_'; $F=~s/^\s+# //mg; eval $F; die $F.$@ if $@; *F{FORMAT};
# format F =
# vec($_,@#,@#) = @<< == @######### @>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
@@ -118,8 +125,10 @@ $FORMAT1 = do{ local *F; my $F=<<'_EOF_FORMAT_'; $F=~s/^\s+# //mg; eval $F; die
_EOF_FORMAT_
};
EXPECT
- } else {
- same( scalar $o->Data(*g{FORMAT})->Out, <<'EXPECT', "data slots (ref/FORMAT)", $o );
+ }
+ else {
+ same(scalar $o->Data(*g{FORMAT})->Out,
+ <<'EXPECT', "data slots (ref/FORMAT)", $o);
$FORMAT1 = do{ local *F; my $F=<<'_EOF_FORMAT_'; $F=~s/^\s+# //mg; eval $F; die $F.$@ if $@; *F{FORMAT};
# format F =
# vec($_,@#,@#) = @<< == @######### @>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
@@ -130,17 +139,21 @@ $FORMAT1 = do{ local *F; my $F=<<'_EOF_FORMAT_'; $F=~s/^\s+# //mg; eval $F; die
_EOF_FORMAT_
};
EXPECT
- }
- my $y=bless *g{FORMAT},"Thank::YSTH";
- if ( 5.021009 <= $] ) {
- #same ( scalar $o->Data(*g{FORMAT})->Out, <<'EXPECT', "data slots (blessed FORMAT)", $o );
- test_dump( {name=>"data slots (blessed FORMAT)",
- verbose=>1,
- pre_eval=>'our ($off,$width,$bits,$val,$res);',
- no_dumper=>1,
- no_redump=>1,
- },
- $o, *g{FORMAT}, <<'EXPECT' );
+ }
+ my $y= bless *g{FORMAT}, "Thank::YSTH";
+ if (5.021009 <= $]) {
+
+ #same ( scalar $o->Data(*g{FORMAT})->Out, <<'EXPECT', "data slots (blessed FORMAT)", $o );
+ test_dump({
+ name => "data slots (blessed FORMAT)",
+ verbose => 1,
+ pre_eval => 'our ($off,$width,$bits,$val,$res);',
+ no_dumper => 1,
+ no_redump => 1,
+ },
+ $o,
+ *g{FORMAT},
+ <<'EXPECT' );
$Thank_YSTH1 = bless( do{ local *F; my $F=<<'_EOF_FORMAT_'; $F=~s/^\s+# //mg; eval $F; die $F.$@ if $@; *F{FORMAT};
# format F =
# vec($_,@#,@#) = @<< == @######### @>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
@@ -152,13 +165,17 @@ $Thank_YSTH1 = bless( do{ local *F; my $F=<<'_EOF_FORMAT_'; $F=~s/^\s+# //mg; ev
_EOF_FORMAT_
}, 'Thank::YSTH' );
EXPECT
- } else {
- test_dump( {name=>"data slots (blessed FORMAT)",
- verbose=>1,
- pre_eval=>'our ($off,$width,$bits,$val,$res);',
- no_dumper=>1,
- },
- $o, *g{FORMAT}, <<'EXPECT' );
+ }
+ else {
+ test_dump({
+ name => "data slots (blessed FORMAT)",
+ verbose => 1,
+ pre_eval => 'our ($off,$width,$bits,$val,$res);',
+ no_dumper => 1,
+ },
+ $o,
+ *g{FORMAT},
+ <<'EXPECT' );
$Thank_YSTH1 = bless( do{ local *F; my $F=<<'_EOF_FORMAT_'; $F=~s/^\s+# //mg; eval $F; die $F.$@ if $@; *F{FORMAT};
# format F =
# vec($_,@#,@#) = @<< == @######### @>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
@@ -170,46 +187,49 @@ _EOF_FORMAT_
}, 'Thank::YSTH' );
EXPECT
- }
- our $gg=1; #silence a warning;
- same( scalar $o->Data(*gg{FORMAT})->Out, <<'EXPECT', "data slots (empty FORMAT)", $o );
+ }
+ our $gg= 1; #silence a warning;
+ same(
+ scalar $o->Data(*gg{FORMAT})->Out,
+ <<'EXPECT', "data slots (empty FORMAT)", $o);
$VAR1 = undef;
EXPECT
- };
- }
+ }
+ }
- # no. 6 - self glob
- {
- local *g;
- $g = *g{SCALAR};
- same( scalar $o->Data(*g)->Out, <<'EXPECT', "self glob", $o );
+ # no. 6 - self glob
+ {
+ local *g;
+ $g= *g{SCALAR};
+ same(scalar $o->Data(*g)->Out, <<'EXPECT', "self glob", $o);
$VAR1 = *::g;
*::g = \do { my $v = 'V: *::g{SCALAR}' };
${*::g} = *::g{SCALAR};
EXPECT
- }
+ }
- # no. 7 - icky readonly scalars
- {
- local(*g, $s);
- *g = \"cannae be modified";
- $s = "do as you please";
+ # no. 7 - icky readonly scalars
+ {
+ local (*g, $s);
+ *g= \"cannae be modified";
+ $s= "do as you please";
- same( scalar $o->Data($g,$s)->Out, <<'EXPECT', "icky SCALAR slot", $o );
+ same(scalar $o->Data($g, $s)->Out, <<'EXPECT', "icky SCALAR slot", $o);
$RO1 = 'cannae be modified';
make_ro($RO1);
$VAR1 = 'do as you please';
EXPECT
- }
+ }
}
{
#local $Data::Dump::Streamer::DEBUG=1;
- our $foo = 5;
- our @foo = (-10,\*foo);
- our %foo = (a=>1,b=>\$foo,c=>\@foo);
- $foo{d} = \%foo;
- $foo[2] = \%foo;
- same( "Named Globs", $o->Declare(0)->Names('*foo', '*bar', '*baz'), <<'EXPECT', ( \\*foo, \\@foo, \\%foo ) );
+ our $foo= 5;
+ our @foo= (-10, \*foo);
+ our %foo= (a => 1, b => \$foo, c => \@foo);
+ $foo{d}= \%foo;
+ $foo[2]= \%foo;
+ same("Named Globs", $o->Declare(0)->Names('*foo', '*bar', '*baz'),
+ <<'EXPECT', (\\*foo, \\@foo, \\%foo));
$foo = \\*::foo;
*::foo = \do { my $v = 5 };
$bar = \[
@@ -228,7 +248,10 @@ $baz = \{
${$bar}->[2] = $$baz;
${$baz}->{d} = $$baz;
EXPECT
- same( "Named Globs Two", $o->Names('foo', 'bar', 'baz'), <<'EXPECT', ( \\*foo, \\@foo, \\%foo ) );
+ same(
+ "Named Globs Two",
+ $o->Names('foo', 'bar', 'baz'),
+ <<'EXPECT', (\\*foo, \\@foo, \\%foo));
$foo = \\*::foo;
*::foo = \do { my $v = 5 };
$bar = \[
@@ -247,7 +270,10 @@ $baz = \{
${$bar}->[2] = $$baz;
${$baz}->{d} = $$baz;
EXPECT
- same( "Named Globs Declare", $o->Declare(1)->Names('*foo', '*bar', '*baz'), <<'EXPECT', ( \\*foo, \\@foo, \\%foo ) );
+ same(
+ "Named Globs Declare",
+ $o->Declare(1)->Names('*foo', '*bar', '*baz'),
+ <<'EXPECT', (\\*foo, \\@foo, \\%foo));
my $foo = \\*::foo;
*::foo = \do { my $v = 5 };
my $bar = \[
@@ -266,7 +292,10 @@ my $baz = \{
${$bar}->[2] = $$baz;
${$baz}->{d} = $$baz;
EXPECT
- same( "Named Globs Two Declare", $o->Names('foo', 'bar', 'baz'), <<'EXPECT', ( \\*foo, \\@foo, \\%foo ) );
+ same(
+ "Named Globs Two Declare",
+ $o->Names('foo', 'bar', 'baz'),
+ <<'EXPECT', (\\*foo, \\@foo, \\%foo));
my $foo = \\*::foo;
*::foo = \do { my $v = 5 };
my $bar = \[
@@ -286,33 +315,35 @@ ${$bar}->[2] = $$baz;
${$baz}->{d} = $$baz;
EXPECT
}
+
# with eval testing
{
use Symbol;
- my $x=gensym;
- my $names=$o->Names(); # scalar context
- same( scalar $o->Data($x)->Out(),<<'EXPECT', "Symbol 1", $o );
+ my $x= gensym;
+ my $names= $o->Names(); # scalar context
+ same(scalar $o->Data($x)->Out(), <<'EXPECT', "Symbol 1", $o);
my $foo = do{ require Symbol; Symbol::gensym };
EXPECT
- my @names=$o->Names(); # scalar context
- same( scalar $o->Data($x)->Out(),<<'EXPECT', "Symbol 2", $o );
+ my @names= $o->Names(); # scalar context
+ same(scalar $o->Data($x)->Out(), <<'EXPECT', "Symbol 2", $o);
my $foo = do{ require Symbol; Symbol::gensym };
EXPECT
$o->Names();
- same( scalar $o->Data($x)->Out(),<<'EXPECT', "Symbol 3", $o );
+ same(scalar $o->Data($x)->Out(), <<'EXPECT', "Symbol 3", $o);
my $GLOB1 = do{ require Symbol; Symbol::gensym };
EXPECT
#local $Data::Dump::Streamer::DEBUG=1;
- $x=\gensym; #
- *$$x = $x;
- *$$x = $names;
- *$$x = { Thank => '[ysth]', Grr => bless \gensym,'Foo' };
+ $x= \gensym; #
+ *$$x= $x;
+ *$$x= $names;
+ *$$x= { Thank => '[ysth]', Grr => bless \gensym, 'Foo' };
+
#Devel::Peek::Dump $x
- same( scalar $o->Data( $x )->Out(),<<'EXPECT', "Symbol 4", $o );
+ same(scalar $o->Data($x)->Out(), <<'EXPECT', "Symbol 4", $o);
my $REF1 = \do{ require Symbol; Symbol::gensym };
*$$REF1 = {
Grr => bless( \Symbol::gensym, 'Foo' ),
@@ -328,7 +359,7 @@ EXPECT
}
{
- same( my $dump=$o->Data(*{gensym()})->Out, <<'EXPECT', "Symbol 5", $o );
+ same(my $dump= $o->Data(*{ gensym() })->Out, <<'EXPECT', "Symbol 5", $o);
my $VAR1 = *{ do{ require Symbol; Symbol::gensym } };
EXPECT
}
diff --git a/t/hardrefs.t b/t/hardrefs.t
index b17eebb..4015fbe 100644
--- a/t/hardrefs.t
+++ b/t/hardrefs.t
@@ -1,14 +1,13 @@
use Test::More tests => 16;
-#$Id: hardrefs.t 26 2006-04-16 15:18:52Z demerphq $#
-
-BEGIN { use_ok( 'Data::Dump::Streamer', qw(:undump) ); }
+BEGIN { use_ok('Data::Dump::Streamer', qw(:undump)); }
use strict;
use warnings;
use Data::Dumper;
# imports same()
require "./t/test_helper.pl";
+
# use this one for simple, non evalable tests. (GLOB)
# same ( $got,$expected,$name,$obj )
#
@@ -16,19 +15,19 @@ require "./t/test_helper.pl";
# same ( $name,$obj,$expected,@args )
my $dump;
-my $o = Data::Dump::Streamer->new();
+my $o= Data::Dump::Streamer->new();
-isa_ok( $o, 'Data::Dump::Streamer' );
+isa_ok($o, 'Data::Dump::Streamer');
-{ # Hard Refs
+{ # Hard Refs
- my $array = [];
- my $hash = {A => \$array};
- @$array = ( \$hash );
- my $top = [ $array, $hash ];
+ my $array= [];
+ my $hash= { A => \$array };
+ @$array= (\$hash);
+ my $top= [ $array, $hash ];
- #same( $dump = $o->Data($top)->Out, <<'EXPECT', "Hard Refs", $o );
- same( "Hard Refs", $o ,<<'EXPECT', ( $top ) );
+ #same( $dump = $o->Data($top)->Out, <<'EXPECT', "Hard Refs", $o );
+ same("Hard Refs", $o, <<'EXPECT', ($top));
$ARRAY1 = [
[ \do { my $v = 'V: $ARRAY1->[1]' } ],
{ A => \do { my $v = 'V: $ARRAY1->[0]' } }
@@ -37,41 +36,36 @@ ${$ARRAY1->[0][0]} = $ARRAY1->[1];
${$ARRAY1->[1]{A}} = $ARRAY1->[0];
EXPECT
-
- same( "Hard Refs Two", $o,
- <<'EXPECT', ( $array, $hash ) );
+ same("Hard Refs Two", $o, <<'EXPECT', ($array, $hash));
$ARRAY1 = [ \$HASH1 ];
$HASH1 = { A => \$ARRAY1 };
EXPECT
- same("Hard Refs Three", $o->Declare(1),
- <<'EXPECT',( $array, $hash ) );
+ same("Hard Refs Three", $o->Declare(1), <<'EXPECT', ($array, $hash));
my $ARRAY1 = [ 'R: $HASH1' ];
my $HASH1 = { A => \$ARRAY1 };
$ARRAY1->[0] = \$HASH1;
EXPECT
- ;
- same( "Hard Refs Five", $o->Declare(1),
- <<'EXPECT', ( $hash,$array, ) );
+
+ same("Hard Refs Five", $o->Declare(1), <<'EXPECT', ($hash, $array,));
my $HASH1 = { A => 'R: $ARRAY1' };
my $ARRAY1 = [ \$HASH1 ];
$HASH1->{A} = \$ARRAY1;
EXPECT
- same( "Hard Refs Four", $o->Declare(0),
- <<'EXPECT', ( $hash, $array, ) );
+ same("Hard Refs Four", $o->Declare(0), <<'EXPECT', ($hash, $array,));
$HASH1 = { A => \$ARRAY1 };
$ARRAY1 = [ \$HASH1 ];
EXPECT
}
{ # Scalar Cross
- my ( $ar, $x, $y ) = ( [ 1, 2 ] );
- $x = \$y;
- $y = \$x;
- $ar->[0] = \$ar->[1];
- $ar->[1] = \$ar->[0];
+ my ($ar, $x, $y)= ([ 1, 2 ]);
+ $x= \$y;
+ $y= \$x;
+ $ar->[0]= \$ar->[1];
+ $ar->[1]= \$ar->[0];
- same( "Scalar Cross One (\$ar)", $o, <<'EXPECT', ($ar) );
+ same("Scalar Cross One (\$ar)", $o, <<'EXPECT', ($ar));
$ARRAY1 = [
'R: $ARRAY1->[1]',
'R: $ARRAY1->[0]'
@@ -81,14 +75,14 @@ $ARRAY1->[1] = \$ARRAY1->[0];
EXPECT
{ #local $Data::Dump::Streamer::DEBUG=1;
- same( "Scalar Cross Two (\$x,\$y)", $o, <<'EXPECT', ( $x, $y ) );
+ same("Scalar Cross Two (\$x,\$y)", $o, <<'EXPECT', ($x, $y));
$REF1 = \$REF2;
$REF2 = \$REF1;
EXPECT
}
#local $Data::Dump::Streamer::DEBUG=1;
- same( "Scalar Cross Three [ \$x,\$y ]", $o , <<'EXPECT', [ $x, $y ] );
+ same("Scalar Cross Three [ \$x,\$y ]", $o, <<'EXPECT', [ $x, $y ]);
$ARRAY1 = [
\do { my $v = 'V: $ARRAY1->[1]' },
\do { my $v = 'V: $ARRAY1->[0]' }
@@ -100,32 +94,32 @@ EXPECT
{
my $x;
- $x = \$x;
+ $x= \$x;
- same("Declare Leaf One ( \$x )", $o->Declare(1),<<'EXPECT',$x );
+ same("Declare Leaf One ( \$x )", $o->Declare(1), <<'EXPECT', $x);
my $REF1 = 'R: $REF1';
$REF1 = \$REF1;
EXPECT
- same( "Declare Leaf Two [ \$x ]", $o->Declare(1) , <<'EXPECT', [$x] );
+ same("Declare Leaf Two [ \$x ]", $o->Declare(1), <<'EXPECT', [$x]);
my $ARRAY1 = [ \do { my $v = 'V: $ARRAY1->[0]' } ];
${$ARRAY1->[0]} = $ARRAY1->[0];
EXPECT
- same( 'Declare Leaf Three ( \\$x )', $o->Declare(1), <<'EXPECT', \$x );
+ same('Declare Leaf Three ( \\$x )', $o->Declare(1), <<'EXPECT', \$x);
my $REF1 = \do { my $v = 'V: $REF1' };
$$REF1 = $REF1;
EXPECT
- same("Leaf One ( \$x )", $o->Declare(0),<<'EXPECT',$x );
+ same("Leaf One ( \$x )", $o->Declare(0), <<'EXPECT', $x);
$REF1 = \$REF1;
EXPECT
- same( "Leaf Two [ \$x ]", $o->Declare(0) , <<'EXPECT', [$x] );
+ same("Leaf Two [ \$x ]", $o->Declare(0), <<'EXPECT', [$x]);
$ARRAY1 = [ \do { my $v = 'V: $ARRAY1->[0]' } ];
${$ARRAY1->[0]} = $ARRAY1->[0];
EXPECT
- same( 'Leaf Three ( \\$x )', $o->Declare(0), <<'EXPECT', \$x );
+ same('Leaf Three ( \\$x )', $o->Declare(0), <<'EXPECT', \$x);
$REF1 = \do { my $v = 'V: $REF1' };
$$REF1 = $REF1;
EXPECT
diff --git a/t/impure_madness.t b/t/impure_madness.t
index db496a0..c5c7bb8 100644
--- a/t/impure_madness.t
+++ b/t/impure_madness.t
@@ -1,14 +1,13 @@
use Test::More tests => 8;
-#$Id: impure_madness.t 26 2006-04-16 15:18:52Z demerphq $#
-
-BEGIN { use_ok( 'Data::Dump::Streamer', qw(:undump) ); }
+BEGIN { use_ok('Data::Dump::Streamer', qw(:undump)); }
use strict;
use warnings;
use Data::Dumper;
# imports same()
require "./t/test_helper.pl";
+
# use this one for simple, non evalable tests. (GLOB)
# same ( $got,$expected,$name,$obj )
#
@@ -16,63 +15,69 @@ require "./t/test_helper.pl";
# same ( $name,$obj,$expected,@args )
my $dump;
-my $o = Data::Dump::Streamer->new();
-isa_ok( $o, 'Data::Dump::Streamer' );
-is( $o->Purity, 1 ,'Purity is the norm...');
+my $o= Data::Dump::Streamer->new();
+isa_ok($o, 'Data::Dump::Streamer');
+is($o->Purity, 1, 'Purity is the norm...');
$o->Purity(0);
-is( $o->Purity, 0 ,'... but some like it impure!');
+is($o->Purity, 0, '... but some like it impure!');
{
local *icky;
- *icky=\ "icky";
+ *icky= \ "icky";
our $icky;
- my $id = 0;
+ my $id= 0;
my $btree;
- $btree = sub {
- my ( $d, $m, $p ) = @_;
+ $btree= sub {
+ my ($d, $m, $p)= @_;
return $p
- if $d > $m;
- return [ $btree->( $d + 1, $m, $p . '0' ), $btree->( $d + 1, $m, $p . '1' ) ];
+ if $d > $m;
+ return [ $btree->($d + 1, $m, $p . '0'),
+ $btree->($d + 1, $m, $p . '1') ];
};
- my $t = $btree->( 0, 1, '' );
- my ( $x, $y, $qr );
- $x = \$y;
- $y = \$x;
- $qr = bless qr/this is a test/m, 'foo_bar';
+ my $t= $btree->(0, 1, '');
+ my ($x, $y, $qr);
+ $x= \$y;
+ $y= \$x;
+ $qr= bless qr/this is a test/m, 'foo_bar';
- my $array = [];
- my $hash = bless {
+ my $array= [];
+ my $hash= bless {
A => \$array,
'B-B' => ['$array'],
'CCCD' => [ 'foo', 'bar' ],
- 'E'=>\\1,
- 'F'=>\\undef,
- 'Q'=>sub{\@_}->($icky),
- },
- 'ThisIsATest';
- $hash->{G}=\$hash;
- my $boo = 'boo';
- @$array = ( \$hash, \$hash, \$hash, \$qr, \$qr, \'foo', \$boo );
- my $cap = capture( $x, $y, $qr, $x, $y, $qr );
-
- test_dump( {
- name=>'Impure Impure Madness cap( $qr,$qr )',
- no_redump=>1,
- no_dumper=>1,
- }, $o, capture( $qr, $qr ),
- <<'EXPECT');
+ 'E' => \\1,
+ 'F' => \\undef,
+ 'Q' => sub { \@_ }
+ ->($icky),
+ },
+ 'ThisIsATest';
+ $hash->{G}= \$hash;
+ my $boo= 'boo';
+ @$array= (\$hash, \$hash, \$hash, \$qr, \$qr, \'foo', \$boo);
+ my $cap= capture($x, $y, $qr, $x, $y, $qr);
+
+ test_dump({
+ name => 'Impure Impure Madness cap( $qr,$qr )',
+ no_redump => 1,
+ no_dumper => 1,
+ },
+ $o,
+ capture($qr, $qr),
+ <<'EXPECT');
$ARRAY1 = [
bless( qr/this is a test/m, 'foo_bar' ),
alias_to($ARRAY1->[0])
];
EXPECT
-
- test_dump( {name=>"Total Impure Madness",
- no_redump=>1,
- no_dumper=>1,
- }, $o, ( $cap,$array,$boo,$hash,$qr ),
- <<'EXPECT');
+ test_dump({
+ name => "Total Impure Madness",
+ no_redump => 1,
+ no_dumper => 1,
+ },
+ $o,
+ ($cap, $array, $boo, $hash, $qr),
+ <<'EXPECT');
$ARRAY1 = [
\$ARRAY1->[1],
\$ARRAY1->[0],
@@ -107,41 +112,49 @@ $foo_bar1 = bless( qr/this is a test/m, 'foo_bar' );
EXPECT
-
}
{
- my ($x,$y);
- $x=\$y;
- $y=\$x;
+ my ($x, $y);
+ $x= \$y;
+ $y= \$x;
- my $a=[1,2];
- $a->[0]=\$a->[1];
- $a->[1]=\$a->[0];
+ my $a= [ 1, 2 ];
+ $a->[0]= \$a->[1];
+ $a->[1]= \$a->[0];
#$cap->[-1]=5;
my $s;
- $s=\$s;
- my $bar='bar';
- my $foo='foo';
- my $halias= {foo=>1,bar=>2};
- alias_hv(%$halias,'foo',$foo);
- alias_hv(%$halias,'bar',$bar);
- alias_hv(%$halias,'foo2',$foo);
-
- my ($t,$u,$v,$w)=(1,2,3,4);
- my $cap=sub{ \@_ }->($x,$y);
- my $q1=qr/foo/;
- my $q2=bless qr/bar/,'bar';
- my $q3=\bless qr/baz/,'baz';
+ $s= \$s;
+ my $bar= 'bar';
+ my $foo= 'foo';
+ my $halias= { foo => 1, bar => 2 };
+ alias_hv(%$halias, 'foo', $foo);
+ alias_hv(%$halias, 'bar', $bar);
+ alias_hv(%$halias, 'foo2', $foo);
+
+ my ($t, $u, $v, $w)= (1, 2, 3, 4);
+ my $cap= sub { \@_ }
+ ->($x, $y);
+ my $q1= qr/foo/;
+ my $q2= bless qr/bar/, 'bar';
+ my $q3= \bless qr/baz/, 'baz';
+
#same( $dump = $o->Data( $a,$q1,$q2,$q3,[$x,$y],[$s,$x,$y],$t,$u,$v,$t,[1,2,3],{1..4},$cap,$cap,$t,$u,$v,$halias)->Out, <<'EXPECT', "More Impure Madness", $o );
- test_dump( {
- name=>"More Impure Madness",
- no_redump=>1,
- no_dumper=>1,
- }, $o,
- ( $a,$q1,$q2,$q3,[$x,$y],[$s,$x,$y],$t,$u,$v,$t,[1,2,3],
- {1..4},$cap,$cap,$t,$u,$v,$halias),
- <<'EXPECT');
+ test_dump({
+ name => "More Impure Madness",
+ no_redump => 1,
+ no_dumper => 1,
+ },
+ $o, (
+ $a, $q1, $q2, $q3,
+ [ $x, $y ],
+ [ $s, $x, $y ],
+ $t, $u, $v, $t,
+ [ 1, 2, 3 ],
+ { 1 .. 4 },
+ $cap, $cap, $t, $u, $v, $halias
+ ),
+ <<'EXPECT');
$ARRAY1 = [
\$ARRAY1->[1],
\$ARRAY1->[0]
@@ -189,15 +202,17 @@ EXPECT
{
#local $Data::Dump::Streamer::DEBUG = 1;
my $x;
- $x = sub { \@_ }->( $x, $x );
+ $x= sub { \@_ }
+ ->($x, $x);
push @$x, $x;
- test_dump( {
- name=>"Impure Alias Array",
- no_redump=>1,
- no_dumper=>1,
- }, $o,
- ( $x ),
- <<'EXPECT');
+ test_dump({
+ name => "Impure Alias Array",
+ no_redump => 1,
+ no_dumper => 1,
+ },
+ $o,
+ ($x),
+ <<'EXPECT');
$ARRAY1 = [
alias_to($ARRAY1),
alias_to($ARRAY1),
diff --git a/t/lexicals.t b/t/lexicals.t
index 5369b0d..2fbfa84 100644
--- a/t/lexicals.t
+++ b/t/lexicals.t
@@ -1,8 +1,6 @@
use strict;
use warnings;
-#$Id: lexicals.t 26 2006-04-16 15:18:52Z demerphq $#
-
use Data::Dump::Streamer;
use Test::More tests => 14;
require "./t/test_helper.pl";
@@ -10,40 +8,37 @@ diag "\nPadWalker ",
eval "use PadWalker 0.99; 1" ? qq($PadWalker::VERSION is) : "isn't",
" installed";
-$::No_Redump=$::No_Redump=1;
-$::No_Dumper=$::No_Dumper=1;
+$::No_Redump= $::No_Redump= 1;
+$::No_Dumper= $::No_Dumper= 1;
{
- my $v = 'foo';
- my @v = ('f','o','o');
- my $z = 1;
+ my $v= 'foo';
+ my @v= ('f', 'o', 'o');
+ my $z= 1;
no warnings;
+
sub get_sub {
- my @v=(@v,1);
- my @y=('b','a','r');
- my $x = join " ", @_, @v, $v, $z;
+ my @v= (@v, 1);
+ my @y= ('b', 'a', 'r');
+ my $x= join " ", @_, @v, $v, $z;
sub {
- my @y = ( $x, "A".."G", @y);
- my @v = ( "M".."R", @v);
- my $x = join ":", @y, @v, $z||'undef';
+ my @y= ($x, "A" .. "G", @y);
+ my @v= ("M" .. "R", @v);
+ my $x= join ":", @y, @v, $z || 'undef';
$x . "!!";
- },
- sub { $x = shift; $z = shift if @_; },
- do {
- my @y=split //,'fuzz';
- sub { return join "+",$z,$x,@y;}
- },
+ }, sub { $x= shift; $z= shift if @_; }, do {
+ my @y= split //, 'fuzz';
+ sub { return join "+", $z, $x, @y; }
+ },;
}
}
-
-
{
my $expect;
- if ( $] >= 5.013_001 ) {
- $expect = <<'EXPECT';
+ if ($] >= 5.013_001) {
+ $expect= <<'EXPECT';
my ($x,$z,@v,@y,@y_eclipse_1);
$x = 'f o o 1 foo 1';
$z = 1;
@@ -79,7 +74,7 @@ $CODE3 = sub {
EXPECT
}
else {
- $expect = <<'EXPECT';
+ $expect= <<'EXPECT';
my ($x,$z,@v,@y,@y_eclipse_1);
$x = 'f o o 1 foo 1';
$z = 1;
@@ -115,16 +110,16 @@ $CODE3 = sub {
EXPECT
}
- test_dump( 'Lexicals!!', scalar(Dump()), ( get_sub() ), $expect);
+ test_dump('Lexicals!!', scalar(Dump()), (get_sub()), $expect);
}
{
# local $Data::Dump::Streamer::DEBUG=1;
my $x;
- $x = sub { $x };
+ $x= sub { $x };
- test_dump( "Self-referential", scalar(Dump()),( $x ), <<'EXPECT');
+ test_dump("Self-referential", scalar(Dump()), ($x), <<'EXPECT');
$x = sub {
$x;
};
@@ -133,10 +128,10 @@ EXPECT
{
my $a;
- my $b = sub { $a };
+ my $b= sub { $a };
- test_dump( "Nested closure with shared state", scalar(Dump()),
- ( sub { $a, $b } ), <<'EXPECT');
+ test_dump("Nested closure with shared state",
+ scalar(Dump()), (sub { $a, $b }), <<'EXPECT');
my ($a,$b);
$a = undef;
$b = sub {
@@ -152,10 +147,11 @@ EXPECT
my $a;
my $b;
- my $z = sub { $a, $b };
- my $y = do { my $b; sub { $a, $b } };
- test_dump( "Overlapping declarations", scalar(Dump()),
- ( $y, $z ), <<'EXPECT');
+ my $z= sub { $a, $b };
+ my $y= do {
+ my $b; sub { $a, $b }
+ };
+ test_dump("Overlapping declarations", scalar(Dump()), ($y, $z), <<'EXPECT');
my ($a,$b,$b_eclipse_1);
$a = undef;
$b = undef;
@@ -172,12 +168,12 @@ EXPECT
{
my $a;
- my $z = sub { $a };
+ my $z= sub { $a };
my $b;
- my $y = sub { $a, $b };
+ my $y= sub { $a, $b };
- test_dump( "Overlapping declarations two", scalar(Dump()),
- ( $y, $z ), <<'EXPECT');
+ test_dump("Overlapping declarations two",
+ scalar(Dump()), ($y, $z), <<'EXPECT');
my ($a,$b);
$a = undef;
$b = undef;
@@ -192,17 +188,16 @@ EXPECT
{
- my $z = do {
+ my $z= do {
my $a;
sub { $a };
};
- my $y = do {
+ my $y= do {
my $a;
sub { $a };
};
- test_dump( "Unrelated environments", scalar(Dump()),
- ( $z, $y ), <<'EXPECT');
+ test_dump("Unrelated environments", scalar(Dump()), ($z, $y), <<'EXPECT');
my ($a,$a_eclipse_1);
$a = undef;
$a_eclipse_1 = undef;
@@ -216,18 +211,19 @@ EXPECT
}
{
- my $bad = \&Not::Implemented;
- test_dump( "Unimplemented code", scalar(Dump()), ( $bad ), <<'EXPECT');
+ my $bad= \&Not::Implemented;
+ test_dump("Unimplemented code", scalar(Dump()), ($bad), <<'EXPECT');
$CODE1 = \&Not::Implemented;
EXPECT
}
{
my $a;
- my $z = sub { $a };
+ my $z= sub { $a };
- test_dump( "Shared state/enclosed", scalar(Dump()), ( $z, sub { $a, $z } ),
- <<'EXPECT');
+ test_dump(
+ "Shared state/enclosed", scalar(Dump()),
+ ($z, sub { $a, $z }), <<'EXPECT');
my ($a);
$a = undef;
$z = sub {
@@ -238,9 +234,10 @@ $CODE1 = sub {
};
EXPECT
- test_dump( "Named Shared state/enclosed", scalar(Dump())->Names('foo','bar'),
- ( $z, sub { $a, $z } ),
- <<'EXPECT');
+ test_dump(
+ "Named Shared state/enclosed",
+ scalar(Dump())->Names('foo', 'bar'),
+ ($z, sub { $a, $z }), <<'EXPECT');
my ($a);
$a = undef;
$foo = sub {
@@ -256,15 +253,15 @@ EXPECT
no warnings;
our $b;
my $a;
- my $b = sub { $b };
+ my $b= sub { $b };
- test_dump( "sub b", scalar(Dump()), ( $b ), <<'EXPECT');
+ test_dump("sub b", scalar(Dump()), ($b), <<'EXPECT');
$CODE1 = sub {
$b;
};
EXPECT
- test_dump( "double sub b", scalar(Dump()), ( sub { $b } ), <<'EXPECT');
+ test_dump("double sub b", scalar(Dump()), (sub { $b }), <<'EXPECT');
my ($b);
$b = sub {
$b;
@@ -274,14 +271,13 @@ $CODE1 = sub {
};
EXPECT
-
}
{
- my $a = "foo";
- my $x = sub { return $a . "bar" };
+ my $a= "foo";
+ my $x= sub { return $a . "bar" };
sub f { print $x->() }
- test_dump( "recursively nested subs", scalar(Dump()), ( \&f ), <<'EXPECT');
+ test_dump("recursively nested subs", scalar(Dump()), (\&f), <<'EXPECT');
my ($a,$x);
$a = 'foo';
$x = sub {
@@ -293,14 +289,18 @@ $CODE1 = sub {
EXPECT
}
{
- test_dump( "EclipseName", Dump->EclipseName('%d_foiled_%s'),
- ( [
- map {
- my $x;
- my $x_eclipse_1;
- sub {$x}, sub {$x_eclipse_1};
- } 1, 2
- ] ), <<'EXPECT');
+ test_dump(
+ "EclipseName",
+ Dump->EclipseName('%d_foiled_%s'), ([
+ map {
+ my $x;
+ my $x_eclipse_1;
+ sub { $x }, sub { $x_eclipse_1 };
+ } 1,
+ 2
+ ]
+ ),
+ <<'EXPECT');
my ($1_foiled_x,$1_foiled_x_eclipse_1,$x,$x_eclipse_1);
$1_foiled_x = undef;
$1_foiled_x_eclipse_1 = undef;
@@ -325,14 +325,18 @@ EXPECT
}
{
- test_dump( "EclipseName 2", Dump->EclipseName('%s_muhaha_%d'),
- ( [
- map {
- my $x;
- my $x_eclipse_1;
- sub {$x}, sub {$x_eclipse_1};
- } 1, 2
- ] ), <<'EXPECT');
+ test_dump(
+ "EclipseName 2",
+ Dump->EclipseName('%s_muhaha_%d'), ([
+ map {
+ my $x;
+ my $x_eclipse_1;
+ sub { $x }, sub { $x_eclipse_1 };
+ } 1,
+ 2
+ ]
+ ),
+ <<'EXPECT');
my ($x,$x_eclipse_1,$x_eclipse_1_muhaha_1,$x_muhaha_1);
$x = undef;
$x_eclipse_1 = undef;
@@ -356,20 +360,21 @@ EXPECT
}
+if (0) {
-if (0){
#no warnings;
my @close;
- my ($x,$y)=(3.141,5);
+ my ($x, $y)= (3.141, 5);
for my $a ($x, $y) {
for my $b ($x, $y) {
- push @close, sub { ++$a, ++$b; return } if \$a != \$b
+ push @close, sub { ++$a, ++$b; return }
+ if \$a != \$b;
}
}
- my $out=Dump(\@close)->Out();
+ my $out= Dump(\@close)->Out();
print $out;
+
#print B::Deparse::WARN_MASK;
}
-
__END__
diff --git a/t/locked.t b/t/locked.t
index 24b8539..37d2fba 100644
--- a/t/locked.t
+++ b/t/locked.t
@@ -1,15 +1,13 @@
use vars qw /$TESTS/;
-use Test::More tests=>2+($TESTS=9);
+use Test::More tests => 2 + ($TESTS= 9);
-#$Id: locked.t 26 2006-04-16 15:18:52Z demerphq $#
-
-BEGIN { use_ok( 'Data::Dump::Streamer', qw(:undump Dump) ); }
+BEGIN { use_ok('Data::Dump::Streamer', qw(:undump Dump)); }
use strict;
use warnings;
-
# imports same()
require "./t/test_helper.pl";
+
# use this one for simple, non evalable tests. (GLOB)
# same ( $got,$expected,$name,$obj )
#
@@ -17,21 +15,23 @@ require "./t/test_helper.pl";
# same ( $name,$obj,$expected,@args )
my $dump;
-my $o = Data::Dump::Streamer->new();
-isa_ok( $o, 'Data::Dump::Streamer' );
-SKIP:{
- skip "No locked hashes before 5.8.0",
- $TESTS
- if $]<5.008;
- skip "Can't tell which keys are locked before 5.8.1",
- $TESTS
- if $]==5.008;
-{
- my %h = ('a0'..'a9');
- lock_keys(%h);
- test_dump( {name=>"locked_ref_keys",
- verbose=>1}, $o, ( \%h ),
- <<'EXPECT', );
+my $o= Data::Dump::Streamer->new();
+isa_ok($o, 'Data::Dump::Streamer');
+SKIP: {
+ skip "No locked hashes before 5.8.0", $TESTS
+ if $] < 5.008;
+ skip "Can't tell which keys are locked before 5.8.1", $TESTS
+ if $] == 5.008;
+ {
+ my %h= ('a0' .. 'a9');
+ lock_keys(%h);
+ test_dump({
+ name => "locked_ref_keys",
+ verbose => 1
+ },
+ $o,
+ (\%h),
+ <<'EXPECT',);
$HASH1 = lock_ref_keys( {
a0 => 'a1',
a2 => 'a3',
@@ -40,23 +40,31 @@ $HASH1 = lock_ref_keys( {
a8 => 'a9'
} );
EXPECT
- delete (@h{qw(a2 a6)});
- test_dump( {name=>"locked_ref_keys_plus",
- verbose=>1}, $o, ( \%h ),
- <<'EXPECT', );
+ delete(@h{qw(a2 a6)});
+ test_dump({
+ name => "locked_ref_keys_plus",
+ verbose => 1
+ },
+ $o,
+ (\%h),
+ <<'EXPECT',);
$HASH1 = lock_ref_keys_plus( {
a0 => 'a1',
a4 => 'a5',
a8 => 'a9'
}, 'a2', 'a6' );
EXPECT
-}
-{
- my %h = ('a0'..'a9');
- lock_keys(%h);
- test_dump( {name=>"locked_keys",
- verbose=>1}, $o->Names('*h'), ( \%h ),
- <<'EXPECT', );
+ }
+ {
+ my %h= ('a0' .. 'a9');
+ lock_keys(%h);
+ test_dump({
+ name => "locked_keys",
+ verbose => 1
+ },
+ $o->Names('*h'),
+ (\%h),
+ <<'EXPECT',);
%h = (
a0 => 'a1',
a2 => 'a3',
@@ -66,10 +74,14 @@ EXPECT
);
lock_keys( %h );
EXPECT
- delete (@h{qw(a2 a6)});
- test_dump( {name=>"locked_keys_plus",
- verbose=>1}, $o, ( \%h ),
- <<'EXPECT', );
+ delete(@h{qw(a2 a6)});
+ test_dump({
+ name => "locked_keys_plus",
+ verbose => 1
+ },
+ $o,
+ (\%h),
+ <<'EXPECT',);
%h = (
a0 => 'a1',
a4 => 'a5',
@@ -77,14 +89,18 @@ EXPECT
);
lock_keys_plus( %h, 'a2', 'a6');
EXPECT
- $o->Names();
-}
-{
- my $h = bless {'a0'..'a9'},'locked';
- lock_keys(%$h);
- test_dump( {name=>"blessed locked_ref_keys",
- verbose=>1}, $o, ( \%$h ),
- <<'EXPECT', );
+ $o->Names();
+ }
+ {
+ my $h= bless { 'a0' .. 'a9' }, 'locked';
+ lock_keys(%$h);
+ test_dump({
+ name => "blessed locked_ref_keys",
+ verbose => 1
+ },
+ $o,
+ (\%$h),
+ <<'EXPECT',);
$locked1 = lock_ref_keys( bless( {
a0 => 'a1',
a2 => 'a3',
@@ -93,23 +109,31 @@ $locked1 = lock_ref_keys( bless( {
a8 => 'a9'
}, 'locked' ) );
EXPECT
- delete (@$h{qw(a2 a6)});
- test_dump( {name=>"blessed locked_ref_keys_plus",
- verbose=>1}, $o, ( \%$h ),
- <<'EXPECT', );
+ delete(@$h{qw(a2 a6)});
+ test_dump({
+ name => "blessed locked_ref_keys_plus",
+ verbose => 1
+ },
+ $o,
+ (\%$h),
+ <<'EXPECT',);
$locked1 = lock_ref_keys_plus( bless( {
a0 => 'a1',
a4 => 'a5',
a8 => 'a9'
}, 'locked' ), 'a2', 'a6' );
EXPECT
-}
-{
- my $h = bless {'a0'..'a9'},'locked';
- lock_keys(%$h);
- test_dump( {name=>"blessed locked_keys",
- verbose=>1}, $o->Names('*h'), ( $h,$h ),
- <<'EXPECT', );
+ }
+ {
+ my $h= bless { 'a0' .. 'a9' }, 'locked';
+ lock_keys(%$h);
+ test_dump({
+ name => "blessed locked_keys",
+ verbose => 1
+ },
+ $o->Names('*h'),
+ ($h, $h),
+ <<'EXPECT',);
%h = (
a0 => 'a1',
a2 => 'a3',
@@ -120,10 +144,14 @@ EXPECT
$locked1 = bless( \%h, 'locked' );
lock_keys( %h );
EXPECT
- delete (@$h{qw(a2 a6)});
- test_dump( {name=>"blessed locked_keys_plus",
- verbose=>1}, $o, ( $h,$h ),
- <<'EXPECT', );
+ delete(@$h{qw(a2 a6)});
+ test_dump({
+ name => "blessed locked_keys_plus",
+ verbose => 1
+ },
+ $o,
+ ($h, $h),
+ <<'EXPECT',);
%h = (
a0 => 'a1',
a4 => 'a5',
@@ -132,15 +160,20 @@ EXPECT
$locked1 = bless( \%h, 'locked' );
lock_keys_plus( %h, 'a2', 'a6');
EXPECT
- $o->Names();
-}
-{
- my $x=0;
- my %hashes=map { $_=>lock_ref_keys_plus({foo=>$_},$x++) } 1..10;
- lock_keys_plus(%hashes,10..19);
- test_dump( {name=>"blessed locked_keys_plus",
- verbose=>1}, $o, ( \%hashes ),
- <<'EXPECT', );
+ $o->Names();
+ }
+ {
+ my $x= 0;
+ my %hashes=
+ map { $_ => lock_ref_keys_plus({ foo => $_ }, $x++) } 1 .. 10;
+ lock_keys_plus(%hashes, 10 .. 19);
+ test_dump({
+ name => "blessed locked_keys_plus",
+ verbose => 1
+ },
+ $o,
+ (\%hashes),
+ <<'EXPECT',);
$HASH1 = lock_ref_keys_plus( {
1 => lock_ref_keys_plus( { foo => 1 }, 0 ),
2 => lock_ref_keys_plus( { foo => 2 }, 1 ),
@@ -155,12 +188,9 @@ $HASH1 = lock_ref_keys_plus( {
}, 11, 12, 13, 14, 15, 16, 17, 18, 19 );
EXPECT
-}
-
-
-
+ }
-}# SKIP
+} # SKIP
__END__
# with eval testing
{
diff --git a/t/madness.t b/t/madness.t
index fd40e7e..bd0bdc2 100644
--- a/t/madness.t
+++ b/t/madness.t
@@ -1,13 +1,13 @@
use Test::More tests => 7;
-#$Id: madness.t 26 2006-04-16 15:18:52Z demerphq $#
-
-BEGIN { use_ok( 'Data::Dump::Streamer', qw(:undump) ); }
+BEGIN { use_ok('Data::Dump::Streamer', qw(:undump)); }
use strict;
use warnings;
use Data::Dumper;
+
# imports same()
require "./t/test_helper.pl";
+
# use this one for simple, non evalable tests. (GLOB)
# same ( $got,$expected,$name,$obj )
#
@@ -15,46 +15,47 @@ require "./t/test_helper.pl";
# same ( $name,$obj,$expected,@args )
my $dump;
-my $o = Data::Dump::Streamer->new();
+my $o= Data::Dump::Streamer->new();
-isa_ok( $o, 'Data::Dump::Streamer' );
+isa_ok($o, 'Data::Dump::Streamer');
{
local *icky;
- *icky=\ "icky";
+ *icky= \ "icky";
our $icky;
- my $id = 0;
+ my $id= 0;
my $btree;
- $btree = sub {
- my ( $d, $m, $p ) = @_;
+ $btree= sub {
+ my ($d, $m, $p)= @_;
return $p
- if $d > $m;
- return [ $btree->( $d + 1, $m, $p . '0' ), $btree->( $d + 1, $m, $p . '1' ) ];
+ if $d > $m;
+ return [ $btree->($d + 1, $m, $p . '0'),
+ $btree->($d + 1, $m, $p . '1') ];
};
- my $t = $btree->( 0, 1, '' );
- my ( $x, $y, $qr );
- $x = \$y;
- $y = \$x;
- $qr = bless qr/this is a test/m, 'foo_bar';
+ my $t= $btree->(0, 1, '');
+ my ($x, $y, $qr);
+ $x= \$y;
+ $y= \$x;
+ $qr= bless qr/this is a test/m, 'foo_bar';
- my $array = [];
- my $hash = bless {
+ my $array= [];
+ my $hash= bless {
A => \$array,
'B-B' => ['$array'],
'CCCD' => [ 'foo', 'bar' ],
- 'E'=>\\1,
- 'F'=>\\undef,
- 'Q'=>sub{\@_}->($icky),
- },
- 'ThisIsATest';
- $hash->{G}=\$hash;
- my $boo = 'boo';
- @$array = ( \$hash, \$hash, \$hash, \$qr, \$qr, \'foo', \$boo );
- my $cap = capture( $x, $y, $qr, $x, $y, $qr );
+ 'E' => \\1,
+ 'F' => \\undef,
+ 'Q' => sub { \@_ }
+ ->($icky),
+ },
+ 'ThisIsATest';
+ $hash->{G}= \$hash;
+ my $boo= 'boo';
+ @$array= (\$hash, \$hash, \$hash, \$qr, \$qr, \'foo', \$boo);
+ my $cap= capture($x, $y, $qr, $x, $y, $qr);
-
- same( 'Madness cap( $qr,$qr )', $o ,<<'EXPECT', capture( $qr, $qr ) );
+ same('Madness cap( $qr,$qr )', $o, <<'EXPECT', capture($qr, $qr));
$ARRAY1 = [
bless( qr/this is a test/m, 'foo_bar' ),
'A: $ARRAY1->[0]'
@@ -62,9 +63,8 @@ $ARRAY1 = [
alias_av(@$ARRAY1, 1, $ARRAY1->[0]);
EXPECT
-
#same( $dump = $o->Data( $cap,$array,$boo,$hash,$qr )->Out, <<'EXPECT', "Total Madness", $o );
- same( "Total Madness", $o,<<'EXPECT',( $cap,$array,$boo,$hash,$qr ) );
+ same("Total Madness", $o, <<'EXPECT', ($cap, $array, $boo, $hash, $qr));
$ARRAY1 = [
'R: $ARRAY1->[1]',
'R: $ARRAY1->[0]',
@@ -108,35 +108,38 @@ alias_av(@$ARRAY1, 2, $foo_bar1);
alias_av(@$ARRAY1, 5, $foo_bar1);
EXPECT
-
}
{
- my ($x,$y);
- $x=\$y;
- $y=\$x;
+ my ($x, $y);
+ $x= \$y;
+ $y= \$x;
- my $a=[1,2];
- $a->[0]=\$a->[1];
- $a->[1]=\$a->[0];
+ my $a= [ 1, 2 ];
+ $a->[0]= \$a->[1];
+ $a->[1]= \$a->[0];
#$cap->[-1]=5;
my $s;
- $s=\$s;
- my $bar='bar';
- my $foo='foo';
- my $halias= {foo=>1,bar=>2};
- alias_hv(%$halias,'foo',$foo);
- alias_hv(%$halias,'bar',$bar);
- alias_hv(%$halias,'foo2',$foo);
+ $s= \$s;
+ my $bar= 'bar';
+ my $foo= 'foo';
+ my $halias= { foo => 1, bar => 2 };
+ alias_hv(%$halias, 'foo', $foo);
+ alias_hv(%$halias, 'bar', $bar);
+ alias_hv(%$halias, 'foo2', $foo);
+
+ my ($t, $u, $v, $w)= (1, 2, 3, 4);
+ my $cap= sub { \@_ }
+ ->($x, $y);
+ my $q1= qr/foo/;
+ my $q2= bless qr/bar/, 'bar';
+ my $q3= \bless qr/baz/, 'baz';
- my ($t,$u,$v,$w)=(1,2,3,4);
- my $cap=sub{ \@_ }->($x,$y);
- my $q1=qr/foo/;
- my $q2=bless qr/bar/,'bar';
- my $q3=\bless qr/baz/,'baz';
#same( $dump = $o->Data( $a,$q1,$q2,$q3,[$x,$y],[$s,$x,$y],$t,$u,$v,$t,[1,2,3],{1..4},$cap,$cap,$t,$u,$v,$halias)->Out, <<'EXPECT', "More Madness", $o );
- same( "More Madness", $o ,
- <<'EXPECT',( $a,$q1,$q2,$q3,[$x,$y],[$s,$x,$y],$t,$u,$v,$t,[1,2,3],{1..4},$cap,$cap,$t,$u,$v,$halias));
+ same(
+ "More Madness",
+ $o,
+ <<'EXPECT', ($a, $q1, $q2, $q3, [ $x, $y ], [ $s, $x, $y ], $t, $u, $v, $t, [ 1, 2, 3 ], { 1 .. 4 }, $cap, $cap, $t, $u, $v, $halias));
$ARRAY1 = [
'R: $ARRAY1->[1]',
'R: $ARRAY1->[0]'
@@ -194,9 +197,10 @@ EXPECT
{
#local $Data::Dump::Streamer::DEBUG = 1;
my $x;
- $x = sub { \@_ }->( $x, $x );
+ $x= sub { \@_ }
+ ->($x, $x);
push @$x, $x;
- same( "Tye Alias Array", $o, <<'EXPECT',( $x ) );
+ same("Tye Alias Array", $o, <<'EXPECT', ($x));
$ARRAY1 = [
'A: $ARRAY1',
'A: $ARRAY1',
@@ -209,44 +213,44 @@ EXPECT
}
{
undef $!;
-format STDOUT =
+ format STDOUT =
@<<<<<< @││││││ @>>>>>>
"left", "middle", "right"
.
my $expected_dot;
- if ( defined $. && length $. ) {
- $expected_dot = $.;
+ if (defined $. && length $.) {
+ $expected_dot= $.;
}
- elsif ( defined $. ) {
- $expected_dot = "''";
+ elsif (defined $.) {
+ $expected_dot= "''";
}
else {
- $expected_dot = 'undef';
+ $expected_dot= 'undef';
}
- my %hash = (
+ my %hash= (
UND => undef,
IV => 1,
NV => 3.14159265358979,
PV => "string",
PV8 => "ab\ncd\x{20ac}\t",
RV => \$.,
- AR => [ 1..2 ],
+ AR => [ 1 .. 2 ],
HR => { key => "value" },
CR => sub { "code"; },
GLB => *STDERR,
- IO => *{$::{STDERR}}{IO},
- FMT => \*{$::{STDOUT}}{FORMAT},
- OBJ => bless(qr/("[^"]+")/,"Zorp"),
- );
+ IO => *{ $::{STDERR} }{IO},
+ FMT => \*{ $::{STDOUT} }{FORMAT},
+ OBJ => bless(qr/("[^"]+")/, "Zorp"),
+ );
# Dumping differences per perl version:
# 5.12.0+:
#
# IO handles are now blessed into IO::File, I guess?
#
- if ( $] >= 5.012_000 ) {
- my $expect = <<'EXPECT';
+ if ($] >= 5.012_000) {
+ my $expect= <<'EXPECT';
$HASH1 = {
AR => [
1,
@@ -277,15 +281,21 @@ _EOF_FORMAT_
};
EXPECT
require B::Deparse;
- if (new B::Deparse -> coderef2text (
- sub { no strict; 1; use strict; 1; }
- ) !~ 'refs') {
+ if (new B::Deparse->coderef2text(sub { no strict; 1; use strict; 1; })
+ !~ 'refs')
+ {
$expect =~ s/strict 'refs'/strict/;
}
- same( $dump= $o->Data(\%hash)->Out, template( $expect, expected_dot => $expected_dot ), "", $o);
+ same(
+ $dump= $o->Data(\%hash)->Out,
+ template($expect, expected_dot => $expected_dot),
+ "", $o
+ );
}
- elsif ( $] >= 5.008_008 ) {
- same( $dump= $o->Data(\%hash)->Out, template( <<'EXPECT', expected_dot => $expected_dot ), "", $o);
+ elsif ($] >= 5.008_008) {
+ same(
+ $dump= $o->Data(\%hash)->Out,
+ template( <<'EXPECT', expected_dot => $expected_dot), "", $o);
$HASH1 = {
AR => [
1,
@@ -316,8 +326,10 @@ _EOF_FORMAT_
};
EXPECT
}
- elsif ( $] >= 5.008_000 ) {
- same( $dump= $o->Data(\%hash)->Out, template( <<'EXPECT', expected_dot => $expected_dot ), "", $o);
+ elsif ($] >= 5.008_000) {
+ same(
+ $dump= $o->Data(\%hash)->Out,
+ template( <<'EXPECT', expected_dot => $expected_dot), "", $o);
$HASH1 = {
AR => [
1,
@@ -349,7 +361,9 @@ _EOF_FORMAT_
EXPECT
}
else {
- same( $dump= $o->Data(\%hash)->Out, template( <<'EXPECT', expected_dot => $expected_dot ), "", $o);
+ same(
+ $dump= $o->Data(\%hash)->Out,
+ template( <<'EXPECT', expected_dot => $expected_dot), "", $o);
$HASH1 = {
AR => [
1,
@@ -375,9 +389,9 @@ EXPECT
}
sub template {
- my ( $pattern, %replacements ) = @_;
+ my ($pattern, %replacements)= @_;
- for ( keys %replacements ) {
+ for (keys %replacements) {
$pattern =~ s/$_/$replacements{$_}/g;
}
diff --git a/t/madness_json.t b/t/madness_json.t
index b65fa16..404f2b2 100644
--- a/t/madness_json.t
+++ b/t/madness_json.t
@@ -2,17 +2,21 @@ use Test::More;
use strict;
use warnings;
use Data::Dumper;
+
BEGIN {
- if (eval"require Cpanel::JSON::XS; 1") {
+ if (eval "require Cpanel::JSON::XS; 1") {
plan tests => 7;
- } else {
+ }
+ else {
plan skip_all => "No Cpanel::JSON::XS";
- exit; # not sure if this is needed
+ exit; # not sure if this is needed
}
-};
-BEGIN { use_ok( 'Data::Dump::Streamer', qw(:undump) ); }
+}
+BEGIN { use_ok('Data::Dump::Streamer', qw(:undump)); }
+
# imports same()
require "./t/test_helper.pl";
+
# use this one for simple, non evalable tests. (GLOB)
# same ( $got,$expected,$name,$obj )
#
@@ -20,46 +24,47 @@ require "./t/test_helper.pl";
# same ( $name,$obj,$expected,@args )
my $dump;
-my $o = Data::Dump::Streamer->new();
+my $o= Data::Dump::Streamer->new();
-isa_ok( $o, 'Data::Dump::Streamer' );
+isa_ok($o, 'Data::Dump::Streamer');
{
local *icky;
- *icky=\ "icky";
+ *icky= \ "icky";
our $icky;
- my $id = 0;
+ my $id= 0;
my $btree;
- $btree = sub {
- my ( $d, $m, $p ) = @_;
+ $btree= sub {
+ my ($d, $m, $p)= @_;
return $p
- if $d > $m;
- return [ $btree->( $d + 1, $m, $p . '0' ), $btree->( $d + 1, $m, $p . '1' ) ];
+ if $d > $m;
+ return [ $btree->($d + 1, $m, $p . '0'),
+ $btree->($d + 1, $m, $p . '1') ];
};
- my $t = $btree->( 0, 1, '' );
- my ( $x, $y, $qr );
- $x = \$y;
- $y = \$x;
- $qr = bless qr/this is a test/m, 'foo_bar';
+ my $t= $btree->(0, 1, '');
+ my ($x, $y, $qr);
+ $x= \$y;
+ $y= \$x;
+ $qr= bless qr/this is a test/m, 'foo_bar';
- my $array = [];
- my $hash = bless {
+ my $array= [];
+ my $hash= bless {
A => \$array,
'B-B' => ['$array'],
'CCCD' => [ 'foo', 'bar' ],
- 'E'=>\\1,
- 'F'=>\\undef,
- 'Q'=>sub{\@_}->($icky),
- },
- 'ThisIsATest';
- $hash->{G}=\$hash;
- my $boo = 'boo';
- @$array = ( \$hash, \$hash, \$hash, \$qr, \$qr, \'foo', \$boo );
- my $cap = capture( $x, $y, $qr, $x, $y, $qr );
-
+ 'E' => \\1,
+ 'F' => \\undef,
+ 'Q' => sub { \@_ }
+ ->($icky),
+ },
+ 'ThisIsATest';
+ $hash->{G}= \$hash;
+ my $boo= 'boo';
+ @$array= (\$hash, \$hash, \$hash, \$qr, \$qr, \'foo', \$boo);
+ my $cap= capture($x, $y, $qr, $x, $y, $qr);
- same( 'Madness cap( $qr,$qr )', $o ,<<'EXPECT', capture( $qr, $qr ) );
+ same('Madness cap( $qr,$qr )', $o, <<'EXPECT', capture($qr, $qr));
$ARRAY1 = [
bless( qr/this is a test/m, 'foo_bar' ),
'A: $ARRAY1->[0]'
@@ -67,9 +72,8 @@ $ARRAY1 = [
alias_av(@$ARRAY1, 1, $ARRAY1->[0]);
EXPECT
-
#same( $dump = $o->Data( $cap,$array,$boo,$hash,$qr )->Out, <<'EXPECT', "Total Madness", $o );
- same( "Total Madness", $o,<<'EXPECT',( $cap,$array,$boo,$hash,$qr ) );
+ same("Total Madness", $o, <<'EXPECT', ($cap, $array, $boo, $hash, $qr));
$ARRAY1 = [
'R: $ARRAY1->[1]',
'R: $ARRAY1->[0]',
@@ -113,35 +117,38 @@ alias_av(@$ARRAY1, 2, $foo_bar1);
alias_av(@$ARRAY1, 5, $foo_bar1);
EXPECT
-
}
{
- my ($x,$y);
- $x=\$y;
- $y=\$x;
+ my ($x, $y);
+ $x= \$y;
+ $y= \$x;
- my $a=[1,2];
- $a->[0]=\$a->[1];
- $a->[1]=\$a->[0];
+ my $a= [ 1, 2 ];
+ $a->[0]= \$a->[1];
+ $a->[1]= \$a->[0];
#$cap->[-1]=5;
my $s;
- $s=\$s;
- my $bar='bar';
- my $foo='foo';
- my $halias= {foo=>1,bar=>2};
- alias_hv(%$halias,'foo',$foo);
- alias_hv(%$halias,'bar',$bar);
- alias_hv(%$halias,'foo2',$foo);
+ $s= \$s;
+ my $bar= 'bar';
+ my $foo= 'foo';
+ my $halias= { foo => 1, bar => 2 };
+ alias_hv(%$halias, 'foo', $foo);
+ alias_hv(%$halias, 'bar', $bar);
+ alias_hv(%$halias, 'foo2', $foo);
+
+ my ($t, $u, $v, $w)= (1, 2, 3, 4);
+ my $cap= sub { \@_ }
+ ->($x, $y);
+ my $q1= qr/foo/;
+ my $q2= bless qr/bar/, 'bar';
+ my $q3= \bless qr/baz/, 'baz';
- my ($t,$u,$v,$w)=(1,2,3,4);
- my $cap=sub{ \@_ }->($x,$y);
- my $q1=qr/foo/;
- my $q2=bless qr/bar/,'bar';
- my $q3=\bless qr/baz/,'baz';
#same( $dump = $o->Data( $a,$q1,$q2,$q3,[$x,$y],[$s,$x,$y],$t,$u,$v,$t,[1,2,3],{1..4},$cap,$cap,$t,$u,$v,$halias)->Out, <<'EXPECT', "More Madness", $o );
- same( "More Madness", $o ,
- <<'EXPECT',( $a,$q1,$q2,$q3,[$x,$y],[$s,$x,$y],$t,$u,$v,$t,[1,2,3],{1..4},$cap,$cap,$t,$u,$v,$halias));
+ same(
+ "More Madness",
+ $o,
+ <<'EXPECT', ($a, $q1, $q2, $q3, [ $x, $y ], [ $s, $x, $y ], $t, $u, $v, $t, [ 1, 2, 3 ], { 1 .. 4 }, $cap, $cap, $t, $u, $v, $halias));
$ARRAY1 = [
'R: $ARRAY1->[1]',
'R: $ARRAY1->[0]'
@@ -199,9 +206,10 @@ EXPECT
{
#local $Data::Dump::Streamer::DEBUG = 1;
my $x;
- $x = sub { \@_ }->( $x, $x );
+ $x= sub { \@_ }
+ ->($x, $x);
push @$x, $x;
- same( "Tye Alias Array", $o, <<'EXPECT',( $x ) );
+ same("Tye Alias Array", $o, <<'EXPECT', ($x));
$ARRAY1 = [
'A: $ARRAY1',
'A: $ARRAY1',
@@ -214,49 +222,51 @@ EXPECT
}
{
undef $!;
-format STDOUT =
+ format STDOUT =
@<<<<<< @││││││ @>>>>>>
"left", "middle", "right"
.
my $expected_dot;
- if ( defined $. && length $. ) {
- $expected_dot = $.;
+ if (defined $. && length $.) {
+ $expected_dot= $.;
}
- elsif ( defined $. ) {
- $expected_dot = "''";
+ elsif (defined $.) {
+ $expected_dot= "''";
}
else {
- $expected_dot = 'undef';
+ $expected_dot= 'undef';
}
my $jstrue= Cpanel::JSON::XS::decode_json("[true]")->[0];
- my %hash = (
+ my %hash= (
UND => undef,
IV => 1,
NV => 3.14159265358979,
PV => "string",
PV8 => "ab\ncd\x{20ac}\t",
RV => \$.,
- AR => [ 1..2 ],
+ AR => [ 1 .. 2 ],
HR => { key => "value" },
CR => sub { "code"; },
GLB => *STDERR,
- IO => *{$::{STDERR}}{IO},
- FMT => \*{$::{STDOUT}}{FORMAT},
- OBJ => bless(qr/("[^"]+")/,"Zorp"),
+ IO => *{ $::{STDERR} }{IO},
+ FMT => \*{ $::{STDOUT} }{FORMAT},
+ OBJ => bless(qr/("[^"]+")/, "Zorp"),
JSB => $jstrue,
- );
+ );
my $expect;
- my $json_bool_class = ref( $jstrue );
+ my $json_bool_class= ref($jstrue);
+
# Dumping differences per perl version:
# 5.12.0+:
#
# IO handles are now blessed into IO::File, I guess?
#
- if ( $] >= 5.012_000 ) {
+ if ($] >= 5.012_000) {
+
# This fixes https://github.com/demerphq/Data-Dump-Streamer/issues/8
- $expect = <<'EXPECT';
+ $expect= <<'EXPECT';
$HASH1 = {
AR => [
1,
@@ -289,14 +299,14 @@ _EOF_FORMAT_
bless( $HASH1->{JSB}, 'Cpanel::JSON::XS::Boolean' );
EXPECT
require B::Deparse;
- if (new B::Deparse -> coderef2text (
- sub { no strict; 1; use strict; 1; }
- ) !~ 'refs') {
+ if (new B::Deparse->coderef2text(sub { no strict; 1; use strict; 1; })
+ !~ 'refs')
+ {
$expect =~ s/strict 'refs'/strict/;
}
}
- elsif ( $] >= 5.008_008 ) {
- $expect = <<'EXPECT';
+ elsif ($] >= 5.008_008) {
+ $expect= <<'EXPECT';
$HASH1 = {
AR => [
1,
@@ -329,8 +339,8 @@ _EOF_FORMAT_
bless( $HASH1->{JSB}, 'Cpanel::JSON::XS::Boolean' );
EXPECT
}
- elsif ( $] >= 5.008_000 ) {
- $expect = <<'EXPECT';
+ elsif ($] >= 5.008_000) {
+ $expect= <<'EXPECT';
$HASH1 = {
AR => [
1,
@@ -364,7 +374,7 @@ bless( $HASH1->{JSB}, 'Cpanel::JSON::XS::Boolean' );
EXPECT
}
else {
- $expect = <<'EXPECT';
+ $expect= <<'EXPECT';
$HASH1 = {
AR => [
1,
@@ -389,17 +399,22 @@ $HASH1 = {
bless( $HASH1->{JSB}, 'Cpanel::JSON::XS::Boolean' );
EXPECT
}
+
# In Cpanel::JSON::XS before 3.0201, the boolean class is JSON::XS::Boolean
# and thereafter it is JSON::PP::Boolean
- my $json_boolean_class = ref Cpanel::JSON::XS::decode_json("[true]")->[0];
+ my $json_boolean_class= ref Cpanel::JSON::XS::decode_json("[true]")->[0];
$expect =~ s{Cpanel::JSON::XS::Boolean}{$json_boolean_class}g;
- same( $dump= $o->Data(\%hash)->Out, template( $expect, expected_dot => $expected_dot ), "", $o);
+ same(
+ $dump= $o->Data(\%hash)->Out,
+ template($expect, expected_dot => $expected_dot),
+ "", $o
+ );
}
sub template {
- my ( $pattern, %replacements ) = @_;
+ my ($pattern, %replacements)= @_;
- for ( keys %replacements ) {
+ for (keys %replacements) {
$pattern =~ s/$_/$replacements{$_}/g;
}
diff --git a/t/madness_w.t b/t/madness_w.t
index 0c70e6c..850cb07 100644
--- a/t/madness_w.t
+++ b/t/madness_w.t
@@ -1,67 +1,68 @@
use Test::More tests => 6;
-#$Id: madness_w.t 26 2006-04-16 15:18:52Z demerphq $#
-
-BEGIN { use_ok( 'Data::Dump::Streamer', qw(:undump weaken) ); }
+BEGIN { use_ok('Data::Dump::Streamer', qw(:undump weaken)); }
use strict;
use warnings;
use Data::Dumper;
-SKIP:{
- my ($_item,$_ref);
- $_ref=\$_item;
- skip ( "No Weak Refs", 5 )
+SKIP: {
+ my ($_item, $_ref);
+ $_ref= \$_item;
+ skip("No Weak Refs", 5)
unless eval { weaken($_ref) };
# imports same()
-require "./t/test_helper.pl";
+ require "./t/test_helper.pl";
+
# use this one for simple, non evalable tests. (GLOB)
# same ( $got,$expected,$name,$obj )
#
# use this one for eval checks and dumper checks but NOT for GLOB's
# same ( $name,$obj,$expected,@args )
-my $dump;
-my $o = Data::Dump::Streamer->new();
-
-isa_ok( $o, 'Data::Dump::Streamer' );
-
-{
- local *icky;
- *icky=\ "icky";
- our $icky;
- my $id = 0;
- my $btree;
- $btree = sub {
- my ( $d, $m, $p ) = @_;
- return $p
- if $d > $m;
- return [ $btree->( $d + 1, $m, $p . '0' ), $btree->( $d + 1, $m, $p . '1' ) ];
- };
-
- my $t = $btree->( 0, 1, '' );
- my ( $x, $y, $qr );
- $x = \$y;
- $y = \$x;
- $qr = bless qr/this is a test/m, 'foo_bar';
- weaken($y);
- my $array = [];
- my $hash = bless {
- A => \$array,
- 'B-B' => ['$array'],
- 'CCCD' => [ 'foo', 'bar' ],
- 'E'=>\\1,
- 'F'=>\\undef,
- 'Q'=>sub{\@_}->($icky),
- },
- 'ThisIsATest';
- $hash->{G}=\$hash;
- my $boo = 'boo';
- @$array = ( \$hash, \$hash, \$hash, \$qr, \$qr, \'foo', \$boo );
- my $cap = capture( $x, $y, $qr, $x, $y, $qr );
-
-
- same( 'Madness cap( $qr,$qr )', $o ,<<'EXPECT', capture( $qr, $qr ) );
+ my $dump;
+ my $o= Data::Dump::Streamer->new();
+
+ isa_ok($o, 'Data::Dump::Streamer');
+
+ {
+ local *icky;
+ *icky= \ "icky";
+ our $icky;
+ my $id= 0;
+ my $btree;
+ $btree= sub {
+ my ($d, $m, $p)= @_;
+ return $p
+ if $d > $m;
+ return [
+ $btree->($d + 1, $m, $p . '0'),
+ $btree->($d + 1, $m, $p . '1') ];
+ };
+
+ my $t= $btree->(0, 1, '');
+ my ($x, $y, $qr);
+ $x= \$y;
+ $y= \$x;
+ $qr= bless qr/this is a test/m, 'foo_bar';
+ weaken($y);
+ my $array= [];
+ my $hash= bless {
+ A => \$array,
+ 'B-B' => ['$array'],
+ 'CCCD' => [ 'foo', 'bar' ],
+ 'E' => \\1,
+ 'F' => \\undef,
+ 'Q' => sub { \@_ }
+ ->($icky),
+ },
+ 'ThisIsATest';
+ $hash->{G}= \$hash;
+ my $boo= 'boo';
+ @$array= (\$hash, \$hash, \$hash, \$qr, \$qr, \'foo', \$boo);
+ my $cap= capture($x, $y, $qr, $x, $y, $qr);
+
+ same('Madness cap( $qr,$qr )', $o, <<'EXPECT', capture($qr, $qr));
$ARRAY1 = [
bless( qr/this is a test/m, 'foo_bar' ),
'A: $ARRAY1->[0]'
@@ -69,10 +70,8 @@ $ARRAY1 = [
alias_av(@$ARRAY1, 1, $ARRAY1->[0]);
EXPECT
-
-
- #same( $dump = $o->Data( $cap,$array,$boo,$hash,$qr )->Out, <<'EXPECT', "Total Madness", $o );
- same( "Total Madness", $o,<<'EXPECT',( $cap,$array,$boo,$hash,$qr ) );
+ #same( $dump = $o->Data( $cap,$array,$boo,$hash,$qr )->Out, <<'EXPECT', "Total Madness", $o );
+ same("Total Madness", $o, <<'EXPECT', ($cap, $array, $boo, $hash, $qr));
$ARRAY1 = [
'R: $ARRAY1->[1]',
'R: $ARRAY1->[0]',
@@ -117,37 +116,40 @@ alias_av(@$ARRAY1, 2, $foo_bar1);
alias_av(@$ARRAY1, 5, $foo_bar1);
EXPECT
-
-
-}
-{
- my ($x,$y);
- $x=\$y;
- $y=\$x;
-
- my $a=[1,2];
- $a->[0]=\$a->[1];
- $a->[1]=\$a->[0];
- weaken($a->[1]);
- weaken($x);
- #$cap->[-1]=5;
- my $s;
- $s=\$s;
- my $bar='bar';
- my $foo='foo';
- my $halias= {foo=>1,bar=>2};
- alias_hv(%$halias,'foo',$foo);
- alias_hv(%$halias,'bar',$bar);
- alias_hv(%$halias,'foo2',$foo);
-
- my ($t,$u,$v,$w)=(1,2,3,4);
- my $cap=sub{ \@_ }->($x,$y);
- my $q1=qr/foo/;
- my $q2=bless qr/bar/,'bar';
- my $q3=\bless qr/baz/,'baz';
- #same( $dump = $o->Data( $a,$q1,$q2,$q3,[$x,$y],[$s,$x,$y],$t,$u,$v,$t,[1,2,3],{1..4},$cap,$cap,$t,$u,$v,$halias)->Out, <<'EXPECT', "More Madness", $o );
- same( "More Madness", $o ,
- <<'EXPECT',( $a,$q1,$q2,$q3,[$x,$y],[$s,$x,$y],$t,$u,$v,$t,[1,2,3],{1..4},$cap,$cap,$t,$u,$v,$halias));
+ }
+ {
+ my ($x, $y);
+ $x= \$y;
+ $y= \$x;
+
+ my $a= [ 1, 2 ];
+ $a->[0]= \$a->[1];
+ $a->[1]= \$a->[0];
+ weaken($a->[1]);
+ weaken($x);
+
+ #$cap->[-1]=5;
+ my $s;
+ $s= \$s;
+ my $bar= 'bar';
+ my $foo= 'foo';
+ my $halias= { foo => 1, bar => 2 };
+ alias_hv(%$halias, 'foo', $foo);
+ alias_hv(%$halias, 'bar', $bar);
+ alias_hv(%$halias, 'foo2', $foo);
+
+ my ($t, $u, $v, $w)= (1, 2, 3, 4);
+ my $cap= sub { \@_ }
+ ->($x, $y);
+ my $q1= qr/foo/;
+ my $q2= bless qr/bar/, 'bar';
+ my $q3= \bless qr/baz/, 'baz';
+
+ #same( $dump = $o->Data( $a,$q1,$q2,$q3,[$x,$y],[$s,$x,$y],$t,$u,$v,$t,[1,2,3],{1..4},$cap,$cap,$t,$u,$v,$halias)->Out, <<'EXPECT', "More Madness", $o );
+ same(
+ "More Madness",
+ $o,
+ <<'EXPECT', ($a, $q1, $q2, $q3, [ $x, $y ], [ $s, $x, $y ], $t, $u, $v, $t, [ 1, 2, 3 ], { 1 .. 4 }, $cap, $cap, $t, $u, $v, $halias));
$ARRAY1 = [
'R: $ARRAY1->[1]',
'R: $ARRAY1->[0]'
@@ -204,17 +206,19 @@ $HASH2 = {
alias_hv(%$HASH2, 'foo2', $HASH2->{foo});
EXPECT
-}
-{
- skip ( "Causes error at global destruction on 5.8.0", 1 )
- if $]==5.008;
- #local $Data::Dump::Streamer::DEBUG = 1;
- my $x;
- $x = sub { \@_ }->( $x, $x );
- my $y = $x; #keep it alive
- weaken($x);
- push @$x, $x;
- same( "Tye Alias Array", $o, <<'EXPECT',( $x ) );
+ }
+ {
+ skip("Causes error at global destruction on 5.8.0", 1)
+ if $] == 5.008;
+
+ #local $Data::Dump::Streamer::DEBUG = 1;
+ my $x;
+ $x= sub { \@_ }
+ ->($x, $x);
+ my $y= $x; #keep it alive
+ weaken($x);
+ push @$x, $x;
+ same("Tye Alias Array", $o, <<'EXPECT', ($x));
$ARRAY1 = [
'A: $ARRAY1',
'A: $ARRAY1',
@@ -225,8 +229,8 @@ alias_av(@$ARRAY1, 1, $ARRAY1);
$ARRAY1->[2] = $ARRAY1;
weaken($ARRAY1);
EXPECT
-}
-undef $o;
+ }
+ undef $o;
}
diff --git a/t/names.t b/t/names.t
index 1e72e4c..8d6d20d 100644
--- a/t/names.t
+++ b/t/names.t
@@ -1,13 +1,12 @@
use Test::More tests => 50;
-BEGIN { use_ok( 'Data::Dump::Streamer', qw(:undump Dump) ); }
+BEGIN { use_ok('Data::Dump::Streamer', qw(:undump Dump)); }
use strict;
use warnings;
use Data::Dumper;
-#$Id: names.t 26 2006-04-16 15:18:52Z demerphq $#
-
# imports same()
require "./t/test_helper.pl";
+
# use this one for simple, non evalable tests. (GLOB)
# same ( $got,$expected,$name,$obj )
#
@@ -15,24 +14,30 @@ require "./t/test_helper.pl";
# same ( $name,$obj,$expected,@args )
my $dump;
-my $o = Data::Dump::Streamer->new();
+my $o= Data::Dump::Streamer->new();
+
+isa_ok($o, 'Data::Dump::Streamer');
-isa_ok( $o, 'Data::Dump::Streamer' );
# Make sure Dump($var)->Names($name)->Out() works...
-is (scalar(Dump(@{[0,1]})->Names('foo','bar')->Out()),"\$foo = 0;\n\$bar = 1;\n",'Dump()->Names()');
+is(
+ scalar(Dump(@{ [ 0, 1 ] })->Names('foo', 'bar')->Out()),
+ "\$foo = 0;\n\$bar = 1;\n",
+ 'Dump()->Names()'
+);
{
- same( "Named", $o->Declare(0)->Names('x','y'), <<'EXPECT', ( @{[ 0 , 1 ]} ) );
+ same("Named", $o->Declare(0)->Names('x', 'y'), <<'EXPECT', (@{ [ 0, 1 ] }));
$x = 0;
$y = 1;
EXPECT
}
{
- my $s=0;
- my $a=[];
- my $h={};
- my $c=sub{1};
+ my $s= 0;
+ my $a= [];
+ my $h= {};
+ my $c= sub { 1 };
- same( "Named Vars ", $o->Declare(0)->Names('*s','*a','*h','*c'), <<'EXPECT', ( $s,$a,$h,$c ) );
+ same("Named Vars ", $o->Declare(0)->Names('*s', '*a', '*h', '*c'),
+ <<'EXPECT', ($s, $a, $h, $c));
$s = 0;
@a = ();
%h = ();
@@ -40,8 +45,12 @@ sub c {
1;
};
EXPECT
+
#local $Data::Dump::Streamer::DEBUG=0;
- same( "Named Vars Refs", $o->Declare(0)->Names('*s','*a','*h','*c'), <<'EXPECT', ( $s,$a,$h,$c, ),\( $s,$a,$h,$c, ) );
+ same(
+ "Named Vars Refs",
+ $o->Declare(0)->Names('*s', '*a', '*h', '*c'),
+ <<'EXPECT', ($s, $a, $h, $c,), \($s, $a, $h, $c,));
$s = 0;
@a = ();
%h = ();
@@ -53,14 +62,15 @@ $REF1 = \\@a;
$REF2 = \\%h;
$REF3 = \\&c;
EXPECT
+
#$o->diag;
}
{
-my $z=[1,2,3];
-my $x=\$z->[0];
-my $y=\$z->[2];
+ my $z= [ 1, 2, 3 ];
+ my $x= \$z->[0];
+ my $y= \$z->[2];
- same( "Named() two", $o->Names('*z','x','y'), <<'EXPECT', ( $z,$x,$y ) );
+ same("Named() two", $o->Names('*z', 'x', 'y'), <<'EXPECT', ($z, $x, $y));
@z = (
1,
2,
@@ -69,8 +79,9 @@ my $y=\$z->[2];
$x = \$z[0];
$y = \$z[2];
EXPECT
+
#local $Data::Dump::Streamer::DEBUG=1;
- same( "Named() three", $o->Names('x','y','*z'), <<'EXPECT', ( $x,$y,$z ) );
+ same("Named() three", $o->Names('x', 'y', '*z'), <<'EXPECT', ($x, $y, $z));
$x = 'R: $z[0]';
$y = 'R: $z[2]';
@z = (
@@ -84,10 +95,10 @@ EXPECT
}
{
- my ($a,$b);
- $a = [{ a => \$b }, { b => undef }];
- $b = [{ c => \$b }, { d => \$a }];
- same( "Named Harder", $o->Names('*prime','ref'), <<'EXPECT', ( $a,$b ) );
+ my ($a, $b);
+ $a= [ { a => \$b }, { b => undef } ];
+ $b= [ { c => \$b }, { d => \$a } ];
+ same("Named Harder", $o->Names('*prime', 'ref'), <<'EXPECT', ($a, $b));
@prime = (
{ a => \$ref },
{ b => undef }
@@ -98,7 +109,7 @@ $ref = [
];
EXPECT
- same( "Named Harder Swap", $o->Names('prime','*ref'), <<'EXPECT', ( $a,$b ) );
+ same("Named Harder Swap", $o->Names('prime', '*ref'), <<'EXPECT', ($a, $b));
$prime = [
{ a => \\@ref },
{ b => undef }
@@ -108,7 +119,7 @@ $prime = [
{ d => \$prime }
);
EXPECT
- same( "Named Harder Two", $o->Names('*prime','*ref'), <<'EXPECT', ( $a,$b ) );
+ same("Named Harder Two", $o->Names('*prime', '*ref'), <<'EXPECT', ($a, $b));
@prime = (
{ a => \\@ref },
{ b => undef }
@@ -118,16 +129,17 @@ EXPECT
{ d => \\@prime }
);
EXPECT
+
#print $o->diag;
}
{
#local $Data::Dump::Streamer::DEBUG=1;
- my ($a,$b);
- $a = [undef, { b => undef }];
- $b = [undef, { d => $a }];
- $b->[0]={ c => $b };
- $a->[0]={ a => $b };
- same( "Named Simpler", $o->Names('*prime','ref'), <<'EXPECT', ( $a,$b ) );
+ my ($a, $b);
+ $a= [ undef, { b => undef } ];
+ $b= [ undef, { d => $a } ];
+ $b->[0]= { c => $b };
+ $a->[0]= { a => $b };
+ same("Named Simpler", $o->Names('*prime', 'ref'), <<'EXPECT', ($a, $b));
@prime = (
{ a => 'V: $ref' },
{ b => undef }
@@ -139,7 +151,8 @@ $ref = [
$prime[0]{a} = $ref;
$ref->[0]{c} = $ref;
EXPECT
- same( "Named Simpler Swap", $o->Names('prime','*ref'), <<'EXPECT', ( $a,$b ) );
+ same("Named Simpler Swap", $o->Names('prime', '*ref'),
+ <<'EXPECT', ($a, $b));
$prime = [
{ a => \@ref },
{ b => undef }
@@ -149,7 +162,8 @@ $prime = [
{ d => $prime }
);
EXPECT
- same( "Named Simpler Two", $o->Names('*prime','*ref'), <<'EXPECT', ( $a,$b ) );
+ same("Named Simpler Two", $o->Names('*prime', '*ref'),
+ <<'EXPECT', ($a, $b));
@prime = (
{ a => \@ref },
{ b => undef }
@@ -159,20 +173,27 @@ EXPECT
{ d => \@prime }
);
EXPECT
+
#print $o->diag;
}
{
- same( "Declare Named()", $o->Declare(1)->Names('x','y'), <<'EXPECT', ( @{[ 0 , 1 ]} ) );
+ same(
+ "Declare Named()",
+ $o->Declare(1)->Names('x', 'y'),
+ <<'EXPECT', (@{ [ 0, 1 ] }));
my $x = 0;
my $y = 1;
EXPECT
}
{
-my $z=[1,2,3];
-my $x=\$z->[0];
-my $y=\$z->[2];
+ my $z= [ 1, 2, 3 ];
+ my $x= \$z->[0];
+ my $y= \$z->[2];
- same( "Declare Named() two", $o->Names('*z','x','y'), <<'EXPECT', ( $z,$x,$y ) );
+ same(
+ "Declare Named() two",
+ $o->Names('*z', 'x', 'y'),
+ <<'EXPECT', ($z, $x, $y));
my @z = (
1,
2,
@@ -182,7 +203,10 @@ my $x = \$z[0];
my $y = \$z[2];
EXPECT
- same( "Declare Named() three", $o->Names('x','y','*z'), <<'EXPECT', ( $x,$y,$z ) );
+ same(
+ "Declare Named() three",
+ $o->Names('x', 'y', '*z'),
+ <<'EXPECT', ($x, $y, $z));
my $x = 'R: $z[0]';
my $y = 'R: $z[2]';
my @z = (
@@ -196,10 +220,13 @@ EXPECT
}
{
#local $Data::Dump::Streamer::DEBUG=1;
- my ($a,$b);
- $a = [{ a => \$b }, { b => undef }];
- $b = [{ c => \$b }, { d => \$a }];
- same( "Declare Named Harder", $o->Names('*prime','ref'), <<'EXPECT', ( $a,$b ) );
+ my ($a, $b);
+ $a= [ { a => \$b }, { b => undef } ];
+ $b= [ { c => \$b }, { d => \$a } ];
+ same(
+ "Declare Named Harder",
+ $o->Names('*prime', 'ref'),
+ <<'EXPECT', ($a, $b));
my @prime = (
{ a => 'R: $ref' },
{ b => undef }
@@ -211,7 +238,10 @@ my $ref = [
$prime[0]{a} = \$ref;
$ref->[0]{c} = $prime[0]{a};
EXPECT
- same( "Declare Named Harder Swap", $o->Names('prime','*ref'), <<'EXPECT', ( $a,$b ) );
+ same(
+ "Declare Named Harder Swap",
+ $o->Names('prime', '*ref'),
+ <<'EXPECT', ($a, $b));
my $prime = [
{ a => \do { my $v = 'V: @ref' } },
{ b => undef }
@@ -222,7 +252,10 @@ my @ref = (
);
${$prime->[0]{a}} = \@ref;
EXPECT
- same( "Declare Named Harder Two", $o->Names('*prime','*ref'), <<'EXPECT', ( $a,$b ) );
+ same(
+ "Declare Named Harder Two",
+ $o->Names('*prime', '*ref'),
+ <<'EXPECT', ($a, $b));
my @prime = (
{ a => \do { my $v = 'V: @ref' } },
{ b => undef }
@@ -238,12 +271,15 @@ EXPECT
}
{
#local $Data::Dump::Streamer::DEBUG=1;
- my ($a,$b);
- $a = [undef, { b => undef }];
- $b = [undef, { d => $a }];
- $b->[0]={ c => $b };
- $a->[0]={ a => $b };
- same( "Declare Named Simpler", $o->Names('*prime','ref'), <<'EXPECT', ( $a,$b ) );
+ my ($a, $b);
+ $a= [ undef, { b => undef } ];
+ $b= [ undef, { d => $a } ];
+ $b->[0]= { c => $b };
+ $a->[0]= { a => $b };
+ same(
+ "Declare Named Simpler",
+ $o->Names('*prime', 'ref'),
+ <<'EXPECT', ($a, $b));
my @prime = (
{ a => 'V: $ref' },
{ b => undef }
@@ -255,7 +291,10 @@ my $ref = [
$prime[0]{a} = $ref;
$ref->[0]{c} = $ref;
EXPECT
- same( "Declare Named Simpler Swap", $o->Names('prime','*ref'), <<'EXPECT', ( $a,$b ) );
+ same(
+ "Declare Named Simpler Swap",
+ $o->Names('prime', '*ref'),
+ <<'EXPECT', ($a, $b));
my $prime = [
{ a => 'V: @ref' },
{ b => undef }
@@ -267,7 +306,10 @@ my @ref = (
$prime->[0]{a} = \@ref;
$ref[0]{c} = \@ref;
EXPECT
- same( "Declare Named Simpler Two", $o->Names('*prime','*ref'), <<'EXPECT', ( $a,$b ) );
+ same(
+ "Declare Named Simpler Two",
+ $o->Names('*prime', '*ref'),
+ <<'EXPECT', ($a, $b));
my @prime = (
{ a => 'V: @ref' },
{ b => undef }
@@ -279,15 +321,19 @@ my @ref = (
$prime[0]{a} = \@ref;
$ref[0]{c} = \@ref;
EXPECT
+
#print $o->diag;
}
{
#local $Data::Dump::Streamer::DEBUG=1;
- my ($x,$y,$z);
- $z = [($x={ a => \$y }), { b => undef }];
- $y = [{ c => \$y }, ({ d => \$z })];
+ my ($x, $y, $z);
+ $z= [ ($x= { a => \$y }), { b => undef } ];
+ $y= [ { c => \$y }, ({ d => \$z }) ];
- same( "Hash Named Harder", $o->Declare(0)->Names('*prime','ref'), <<'EXPECT', ( $x,$y ) );
+ same(
+ "Hash Named Harder",
+ $o->Declare(0)->Names('*prime', 'ref'),
+ <<'EXPECT', ($x, $y));
%prime = ( a => \$ref );
$ref = [
{ c => $prime{a} },
@@ -297,7 +343,10 @@ $ref = [
] }
];
EXPECT
- same( "Hash Named Harder Swap", $o->Names('prime','*ref'), <<'EXPECT', ( $y,$x ) );
+ same(
+ "Hash Named Harder Swap",
+ $o->Names('prime', '*ref'),
+ <<'EXPECT', ($y, $x));
$prime = [
{ c => 'V: $ref{a}' },
{ d => \[
@@ -308,7 +357,10 @@ $prime = [
%ref = ( a => \$prime );
$prime->[0]{c} = $ref{a};
EXPECT
- same( "Hash Named Harder Two", $o->Names('*prime','*ref'), <<'EXPECT', ( $x,$y ) );
+ same(
+ "Hash Named Harder Two",
+ $o->Names('*prime', '*ref'),
+ <<'EXPECT', ($x, $y));
%prime = ( a => \\@ref );
@ref = (
{ c => $prime{a} },
@@ -318,17 +370,19 @@ EXPECT
] }
);
EXPECT
+
#print $o->diag;
}
{
#local $Data::Dump::Streamer::DEBUG=1;
- my ($x,$y,$z);
- $z = [undef, { b => undef }];
- $y = [undef, { d => $z }];
- $x=$y->[0]={ c => $y };
- $z->[0]={ a => $y };
+ my ($x, $y, $z);
+ $z= [ undef, { b => undef } ];
+ $y= [ undef, { d => $z } ];
+ $x= $y->[0]= { c => $y };
+ $z->[0]= { a => $y };
- same( "Hash Named Simpler", $o->Names('*prime','ref'), <<'EXPECT', ( $x,$y ) );
+ same("Hash Named Simpler", $o->Names('*prime', 'ref'),
+ <<'EXPECT', ($x, $y));
%prime = ( c => 'V: $ref' );
$ref = [
\%prime,
@@ -340,7 +394,10 @@ $ref = [
$prime{c} = $ref;
$ref->[1]{d}[0]{a} = $ref;
EXPECT
- same( "Hash Named Simpler Swap", $o->Names('prime','*ref'), <<'EXPECT', ( $x,$y ) );
+ same(
+ "Hash Named Simpler Swap",
+ $o->Names('prime', '*ref'),
+ <<'EXPECT', ($x, $y));
$prime = { c => \@ref };
@ref = (
$prime,
@@ -350,7 +407,10 @@ $prime = { c => \@ref };
] }
);
EXPECT
- same( "Hash Named Simpler Two", $o->Names('*prime','*ref'), <<'EXPECT', ( $x,$y ) );
+ same(
+ "Hash Named Simpler Two",
+ $o->Names('*prime', '*ref'),
+ <<'EXPECT', ($x, $y));
%prime = ( c => \@ref );
@ref = (
\%prime,
@@ -360,14 +420,18 @@ EXPECT
] }
);
EXPECT
+
#print $o->diag;
}
{
-my $z={0..3};
-my $x=\$z->{0};
-my $y=\$z->{2};
+ my $z= { 0 .. 3 };
+ my $x= \$z->{0};
+ my $y= \$z->{2};
- same( "Hash Declare Named() two", $o->Declare(1)->Names('*z','x','y'), <<'EXPECT', ( $z,$x,$y ) );
+ same(
+ "Hash Declare Named() two",
+ $o->Declare(1)->Names('*z', 'x', 'y'),
+ <<'EXPECT', ($z, $x, $y));
my %z = (
0 => 1,
2 => 3
@@ -376,7 +440,10 @@ my $x = \$z{0};
my $y = \$z{2};
EXPECT
- same( "Hash Declare Named() three", $o->Names('x','y','*z'), <<'EXPECT', ( $x,$y,$z ) );
+ same(
+ "Hash Declare Named() three",
+ $o->Names('x', 'y', '*z'),
+ <<'EXPECT', ($x, $y, $z));
my $x = 'R: $z{0}';
my $y = 'R: $z{2}';
my %z = (
@@ -389,10 +456,13 @@ EXPECT
}
{
#local $Data::Dump::Streamer::DEBUG=1;
- my ($x,$y,$z);
- $z = [($x={ a => \$y }), { b => undef }];
- $y = [{ c => \$y }, { d => \$z }];
- same( "Hash Declare Named Harder", $o->Names('*prime','ref'), <<'EXPECT', ( $x,$y ) );
+ my ($x, $y, $z);
+ $z= [ ($x= { a => \$y }), { b => undef } ];
+ $y= [ { c => \$y }, { d => \$z } ];
+ same(
+ "Hash Declare Named Harder",
+ $o->Names('*prime', 'ref'),
+ <<'EXPECT', ($x, $y));
my %prime = ( a => 'R: $ref' );
my $ref = [
{ c => 'V: $prime{a}' },
@@ -404,7 +474,10 @@ my $ref = [
$prime{a} = \$ref;
$ref->[0]{c} = $prime{a};
EXPECT
- same( "Hash Declare Named Harder Swap", $o->Names('prime','*ref'), <<'EXPECT', ( $x,$y ) );
+ same(
+ "Hash Declare Named Harder Swap",
+ $o->Names('prime', '*ref'),
+ <<'EXPECT', ($x, $y));
my $prime = { a => \do { my $v = 'V: @ref' } };
my @ref = (
{ c => $prime->{a} },
@@ -415,7 +488,10 @@ my @ref = (
);
${$prime->{a}} = \@ref;
EXPECT
- same( "Hash Declare Named Harder Two", $o->Names('*prime','*ref'), <<'EXPECT', ( $x,$y ) );
+ same(
+ "Hash Declare Named Harder Two",
+ $o->Names('*prime', '*ref'),
+ <<'EXPECT', ($x, $y));
my %prime = ( a => \do { my $v = 'V: @ref' } );
my @ref = (
{ c => $prime{a} },
@@ -431,12 +507,15 @@ EXPECT
}
{
#local $Data::Dump::Streamer::DEBUG=1;
- my ($x,$y,$z);
- $z = [undef, { b => undef }];
- $y = [undef, { d => $z }];
- $x=$y->[0]={ c => $y };
- $z->[0]={ a => $y };
- same( "Hash Declare Named Simpler", $o->Names('*prime','ref'), <<'EXPECT', ( $x,$y ) );
+ my ($x, $y, $z);
+ $z= [ undef, { b => undef } ];
+ $y= [ undef, { d => $z } ];
+ $x= $y->[0]= { c => $y };
+ $z->[0]= { a => $y };
+ same(
+ "Hash Declare Named Simpler",
+ $o->Names('*prime', 'ref'),
+ <<'EXPECT', ($x, $y));
my %prime = ( c => 'V: $ref' );
my $ref = [
\%prime,
@@ -448,7 +527,10 @@ my $ref = [
$prime{c} = $ref;
$ref->[1]{d}[0]{a} = $ref;
EXPECT
- same( "Hash Declare Named Simpler Swap", $o->Names('prime','*ref'), <<'EXPECT', ( $x,$y ) );
+ same(
+ "Hash Declare Named Simpler Swap",
+ $o->Names('prime', '*ref'),
+ <<'EXPECT', ($x, $y));
my $prime = { c => 'V: @ref' };
my @ref = (
$prime,
@@ -460,7 +542,10 @@ my @ref = (
$prime->{c} = \@ref;
$ref[1]{d}[0]{a} = \@ref;
EXPECT
- same( "Hash Declare Named Simpler Two", $o->Names('*prime','*ref'), <<'EXPECT', ( $x,$y ) );
+ same(
+ "Hash Declare Named Simpler Two",
+ $o->Names('*prime', '*ref'),
+ <<'EXPECT', ($x, $y));
my %prime = ( c => 'V: @ref' );
my @ref = (
\%prime,
@@ -472,17 +557,21 @@ my @ref = (
$prime{c} = \@ref;
$ref[1]{d}[0]{a} = \@ref;
EXPECT
-$o->Declare(0);
+ $o->Declare(0);
+
#print $o->diag;
}
{
#local $Data::Dump::Streamer::DEBUG=1;
- my ($x,$y,$z);
- $z = [undef, { b => undef }];
- $y = bless [undef, { d => $z }],'bar';
- $x=bless(($y->[0]={ c => $y }),'foo');
- $z->[0]={ a => $y };
- same( "Blessed Declare Named Simpler", $o->Declare(1)->Names('*prime','ref'), <<'EXPECT', ( $x,$y ) );
+ my ($x, $y, $z);
+ $z= [ undef, { b => undef } ];
+ $y= bless [ undef, { d => $z } ], 'bar';
+ $x= bless(($y->[0]= { c => $y }), 'foo');
+ $z->[0]= { a => $y };
+ same(
+ "Blessed Declare Named Simpler",
+ $o->Declare(1)->Names('*prime', 'ref'),
+ <<'EXPECT', ($x, $y));
my %prime = ( c => 'V: $ref' );
my $ref = bless( [
bless( \%prime, 'foo' ),
@@ -494,7 +583,10 @@ my $ref = bless( [
$prime{c} = $ref;
$ref->[1]{d}[0]{a} = $ref;
EXPECT
- same( "Blessed Declare Named Simpler Swap", $o->Names('prime','*ref'), <<'EXPECT', ( $x,$y ) );
+ same(
+ "Blessed Declare Named Simpler Swap",
+ $o->Names('prime', '*ref'),
+ <<'EXPECT', ($x, $y));
my $prime = bless( { c => 'V: @ref' }, 'foo' );
my @ref = (
$prime,
@@ -506,7 +598,10 @@ my @ref = (
$prime->{c} = bless( \@ref, 'bar' );
$ref[1]{d}[0]{a} = bless( \@ref, 'bar' );
EXPECT
- same( "Blessed Declare Named Simpler Two", $o->Names('*prime','*ref'), <<'EXPECT', ( $x,$y ) );
+ same(
+ "Blessed Declare Named Simpler Two",
+ $o->Names('*prime', '*ref'),
+ <<'EXPECT', ($x, $y));
my %prime = ( c => 'V: @ref' );
my @ref = (
bless( \%prime, 'foo' ),
@@ -518,17 +613,21 @@ my @ref = (
$prime{c} = bless( \@ref, 'bar' );
$ref[1]{d}[0]{a} = bless( \@ref, 'bar' );
EXPECT
-$o->Declare(0);
+ $o->Declare(0);
+
#print $o->diag;
}
{
#local $Data::Dump::Streamer::DEBUG=1;
- my ($x,$y,$z);
- $z = [undef, { b => undef }];
- $y = bless [undef, { d => $z }],'bar';
- $x=bless(($y->[0]={ c => $y }),'foo');
- $z->[0]={ a => $y };
- same( "Blessed Named Simpler", $o->Declare(0)->Names('*prime','ref'), <<'EXPECT', ( $x,$y ) );
+ my ($x, $y, $z);
+ $z= [ undef, { b => undef } ];
+ $y= bless [ undef, { d => $z } ], 'bar';
+ $x= bless(($y->[0]= { c => $y }), 'foo');
+ $z->[0]= { a => $y };
+ same(
+ "Blessed Named Simpler",
+ $o->Declare(0)->Names('*prime', 'ref'),
+ <<'EXPECT', ($x, $y));
%prime = ( c => 'V: $ref' );
$ref = bless( [
bless( \%prime, 'foo' ),
@@ -540,7 +639,10 @@ $ref = bless( [
$prime{c} = $ref;
$ref->[1]{d}[0]{a} = $ref;
EXPECT
- same( "Blessed Named Simpler Swap", $o->Names('prime','*ref'), <<'EXPECT', ( $x,$y ) );
+ same(
+ "Blessed Named Simpler Swap",
+ $o->Names('prime', '*ref'),
+ <<'EXPECT', ($x, $y));
$prime = bless( { c => bless( \@ref, 'bar' ) }, 'foo' );
@ref = (
$prime,
@@ -550,7 +652,10 @@ $prime = bless( { c => bless( \@ref, 'bar' ) }, 'foo' );
] }
);
EXPECT
- same( "Blessed Named Simpler Two", $o->Names('*prime','*ref'), <<'EXPECT', ( $x,$y ) );
+ same(
+ "Blessed Named Simpler Two",
+ $o->Names('*prime', '*ref'),
+ <<'EXPECT', ($x, $y));
%prime = ( c => bless( \@ref, 'bar' ) );
@ref = (
bless( \%prime, 'foo' ),
@@ -560,17 +665,21 @@ EXPECT
] }
);
EXPECT
-$o->Declare(0);
+ $o->Declare(0);
+
#print $o->diag;
}
{
#local $Data::Dump::Streamer::DEBUG=1;
- my ($x,$y,$z);
- $z = [undef, { b => undef }];
- $y = bless [undef, { d => \$z }],'bar';
- $x=bless(($y->[0]={ c => \$y }),'foo');
- $z->[0]={ a => \$y };
- same( "Harder Blessed Named", $o->Declare(0)->Names('*prime','ref'), <<'EXPECT', ( $x,$y ) );
+ my ($x, $y, $z);
+ $z= [ undef, { b => undef } ];
+ $y= bless [ undef, { d => \$z } ], 'bar';
+ $x= bless(($y->[0]= { c => \$y }), 'foo');
+ $z->[0]= { a => \$y };
+ same(
+ "Harder Blessed Named",
+ $o->Declare(0)->Names('*prime', 'ref'),
+ <<'EXPECT', ($x, $y));
%prime = ( c => \$ref );
$ref = bless( [
bless( \%prime, 'foo' ),
@@ -580,7 +689,10 @@ $ref = bless( [
] }
], 'bar' );
EXPECT
- same( "Harder Blessed Named Swap", $o->Names('prime','*ref'), <<'EXPECT', ( $x,$y ) );
+ same(
+ "Harder Blessed Named Swap",
+ $o->Names('prime', '*ref'),
+ <<'EXPECT', ($x, $y));
$prime = bless( { c => \bless( \@ref, 'bar' ) }, 'foo' );
@ref = (
$prime,
@@ -590,7 +702,10 @@ $prime = bless( { c => \bless( \@ref, 'bar' ) }, 'foo' );
] }
);
EXPECT
- same( "Harder Blessed Named Two", $o->Names('*prime','*ref'), <<'EXPECT', ( $x,$y ) );
+ same(
+ "Harder Blessed Named Two",
+ $o->Names('*prime', '*ref'),
+ <<'EXPECT', ($x, $y));
%prime = ( c => \bless( \@ref, 'bar' ) );
@ref = (
bless( \%prime, 'foo' ),
@@ -600,17 +715,21 @@ EXPECT
] }
);
EXPECT
-$o->Declare(0);
+ $o->Declare(0);
+
#print $o->diag;
}
{
#local $Data::Dump::Streamer::DEBUG=1;
- my ($x,$y,$z);
- $z = [undef, { b => undef }];
- $y = bless [undef, { d => \$z }],'bar';
- $x=bless(($y->[0]={ c => \$y }),'foo');
- $z->[0]={ a => \$y };
- same( "Declare Harder Blessed Named", $o->Declare(1)->Names('*prime','ref'), <<'EXPECT', ( $x,$y ) );
+ my ($x, $y, $z);
+ $z= [ undef, { b => undef } ];
+ $y= bless [ undef, { d => \$z } ], 'bar';
+ $x= bless(($y->[0]= { c => \$y }), 'foo');
+ $z->[0]= { a => \$y };
+ same(
+ "Declare Harder Blessed Named",
+ $o->Declare(1)->Names('*prime', 'ref'),
+ <<'EXPECT', ($x, $y));
my %prime = ( c => 'R: $ref' );
my $ref = bless( [
bless( \%prime, 'foo' ),
@@ -622,7 +741,10 @@ my $ref = bless( [
$prime{c} = \$ref;
${$ref->[1]{d}}->[0]{a} = $prime{c};
EXPECT
- same( "Declare Harder Blessed Named Swap", $o->Names('prime','*ref'), <<'EXPECT', ( $x,$y ) );
+ same(
+ "Declare Harder Blessed Named Swap",
+ $o->Names('prime', '*ref'),
+ <<'EXPECT', ($x, $y));
my $prime = bless( { c => \do { my $v = 'V: @ref' } }, 'foo' );
my @ref = (
$prime,
@@ -633,7 +755,10 @@ my @ref = (
);
${$prime->{c}} = bless( \@ref, 'bar' );
EXPECT
- same( "Declare Harder Blessed Named Two", $o->Names('*prime','*ref'), <<'EXPECT', ( $x,$y ) );
+ same(
+ "Declare Harder Blessed Named Two",
+ $o->Names('*prime', '*ref'),
+ <<'EXPECT', ($x, $y));
my %prime = ( c => \do { my $v = 'V: @ref' } );
my @ref = (
bless( \%prime, 'foo' ),
@@ -644,17 +769,19 @@ my @ref = (
);
${$prime{c}} = bless( \@ref, 'bar' );
EXPECT
-$o->Declare(0);
+ $o->Declare(0);
+
#print $o->diag;
}
{
- my $x=[];
- push @$x,\$x;
- same( "Doc Array Self ref", $o->Names('*x')->Declare(0), <<'EXPECT', ( $x ) );
+ my $x= [];
+ push @$x, \$x;
+ same("Doc Array Self ref", $o->Names('*x')->Declare(0), <<'EXPECT', ($x));
@x = ( \\@x );
EXPECT
}
- #Dump->Names('*x')->Out($x);
+
+#Dump->Names('*x')->Out($x);
__END__
# with eval testing
{
diff --git a/t/overload.t b/t/overload.t
index 3baae8a..ecd67f7 100644
--- a/t/overload.t
+++ b/t/overload.t
@@ -6,55 +6,49 @@ use strict;
use warnings;
require overload;
-#$Id: overload.t 26 2006-04-16 15:18:52Z demerphq $#
-
# imports same()
require "./t/test_helper.pl";
sub dump_obj {
- my $obj = shift;
+ my $obj= shift;
my $error;
- if ( not eval { my @list = Dump( $obj ); 1 } ) {
- $error = $@;
- diag( $error );
+ if (not eval { my @list= Dump($obj); 1 }) {
+ $error= $@;
+ diag($error);
}
- return ! defined $error;
+ return !defined $error;
}
-ok( dump_obj( bless( do{ my $v="FooBar"; \ $v }, 'T' ) ),
- '${} overloading' );
+ok(dump_obj(bless(do { my $v= "FooBar"; \$v }, 'T')), '${} overloading');
{
- my $h={a=>'b'};
- ok( dump_obj( [ bless( [ 1, 2, 3, 4, $h ], 'T' ),$h ] ),
- '@{} overloading' );
+ my $h= { a => 'b' };
+ ok(dump_obj([ bless([ 1, 2, 3, 4, $h ], 'T'), $h ]), '@{} overloading');
}
-ok( dump_obj( bless( {a=>'b',c=>[1,2,3,4]}, 'T' ) ),
- '%{} overloading' );
-ok( dump_obj( bless( sub{}, 'T' ) ),
- '&{} overloading' );
-ok( dump_obj( bless( gensym(), 'T' ) ),
- '*{} overloading' );
-our @foofoo=qw(foo foo);
-our $foofoo=bless \@foofoo,'T';
-my $x=bless \*foofoo,'T';
-ok( dump_obj( $x ),'containing glob' );
+ok(dump_obj(bless({ a => 'b', c => [ 1, 2, 3, 4 ] }, 'T')), '%{} overloading');
+ok(dump_obj(bless(sub { }, 'T')), '&{} overloading');
+ok(dump_obj(bless(gensym(), 'T')), '*{} overloading');
+our @foofoo= qw(foo foo);
+our $foofoo= bless \@foofoo, 'T';
+my $x= bless \*foofoo, 'T';
+ok(dump_obj($x), 'containing glob');
{
- my ($r1,$r2);
- $r1 = \$r2;
- $r2 = \$r1;
- my $c= sub {die};
+ my ($r1, $r2);
+ $r1= \$r2;
+ $r2= \$r1;
+ my $c= sub { die };
my $fh= gensym();
- my $gv= \*foofoo ;
- my $h={a=>'b',r1=>$r1,r2=>$r2,c=>$c,gv=>$gv};
- my $a1=[ 0..4, $h, $r1, $r2,$c,$fh,$gv ];
- $h->{array}=$a1;
- my $a2=[$a1,$h];
+ my $gv= \*foofoo;
+ my $h= { a => 'b', r1 => $r1, r2 => $r2, c => $c, gv => $gv };
+ my $a1= [ 0 .. 4, $h, $r1, $r2, $c, $fh, $gv ];
+ $h->{array}= $a1;
+ my $a2= [ $a1, $h ];
- bless $_,'T' for $r1,$r2,$c,$fh,$gv,$h,$a1,$a2;
+ bless $_, 'T' for $r1, $r2, $c, $fh, $gv, $h, $a1, $a2;
- my $o=Dump();
- test_dump( {name=>'overloading madness',no_dumper=>1}, $o, $a2, <<'EXPECT');
+ my $o= Dump();
+ test_dump({ name => 'overloading madness', no_dumper => 1 },
+ $o, $a2, <<'EXPECT');
$T1 = [
[
0,
@@ -105,13 +99,16 @@ bless( *::foofoo{ARRAY}, 'T' );
EXPECT
}
-
package T;
+
BEGIN {
overload->import(
- map { my $operation = $_;
- $operation => sub { Carp::confess( "The overloaded method $operation was called" ) } }
- map { split( ' ' ) }
- values %overload::ops
+ map {
+ my $operation= $_;
+ $operation => sub {
+ Carp::confess("The overloaded method $operation was called");
+ }
+ }
+ map { split(' ') } values %overload::ops
);
}
diff --git a/t/readonly.t b/t/readonly.t
index 06bf1bb..c5ead6b 100644
--- a/t/readonly.t
+++ b/t/readonly.t
@@ -1,29 +1,26 @@
#!./perl
-#$Id: readonly.t 26 2006-04-16 15:18:52Z demerphq $#
-
BEGIN {
unless (-d 'blib') {
- chdir 't' if -d 't';
- @INC = '../lib';
- require Config; import Config;
- keys %Config; # Silence warning
- if ($Config{extensions} !~ /\bList\/Util\b/) {
- print "1..0 # Skip: List::Util was not built\n";
- exit 0;
- }
+ chdir 't' if -d 't';
+ @INC= '../lib';
+ require Config; import Config;
+ keys %Config; # Silence warning
+ if ($Config{extensions} !~ /\bList\/Util\b/) {
+ print "1..0 # Skip: List::Util was not built\n";
+ exit 0;
+ }
}
}
use Data::Dump::Streamer qw(readonly);
-
print "1..9\n";
print "not " unless readonly(1);
print "ok 1\n";
-my $var = 2;
+my $var= 2;
print "not " if readonly($var);
print "ok 2\n";
@@ -34,7 +31,7 @@ print "ok 3\n";
print "not " unless readonly("fred");
print "ok 4\n";
-$var = "fred";
+$var= "fred";
print "not " if readonly($var);
print "ok 5\n";
@@ -42,7 +39,7 @@ print "ok 5\n";
print "not " unless $var eq "fred";
print "ok 6\n";
-$var = \2;
+$var= \2;
print "not " if readonly($var);
print "ok 7\n";
diff --git a/t/refaddr.t b/t/refaddr.t
index f44c153..c55f95e 100644
--- a/t/refaddr.t
+++ b/t/refaddr.t
@@ -1,40 +1,39 @@
use Data::Dump::Streamer qw(refaddr);
-use vars qw($t $y $x *F $v $r);
-use Symbol qw(gensym);
-
-#$Id: refaddr.t 26 2006-04-16 15:18:52Z demerphq $#
+use vars qw($t $y $x *F $v $r);
+use Symbol qw(gensym);
# Ensure we do not trigger and tied methods
tie *F, 'MyTie';
print "1..13\n";
-my $i = 1;
+my $i= 1;
foreach $v (undef, 10, 'string') {
- print "not " if refaddr($v);
- print "ok ",$i++,"\n";
+ print "not " if refaddr($v);
+ print "ok ", $i++, "\n";
}
-foreach $r ({}, \$t, [], \*F, sub {}) {
- my $addr = $r + 0;
- print "not " unless refaddr($r) == $addr;
- print "ok ",$i++,"\n";
- my $obj = bless $r, 'FooBar';
- print "not " unless refaddr($r) == $addr;
- print "ok ",$i++,"\n";
+foreach $r ({}, \$t, [], \*F, sub { }) {
+ my $addr= $r + 0;
+ print "not " unless refaddr($r) == $addr;
+ print "ok ", $i++, "\n";
+ my $obj= bless $r, 'FooBar';
+ print "not " unless refaddr($r) == $addr;
+ print "ok ", $i++, "\n";
}
package FooBar;
-use overload '0+' => sub { 10 },
- '+' => sub { 10 + $_[1] };
+use overload
+ '0+' => sub { 10 },
+ '+' => sub { 10 + $_[1] };
package MyTie;
sub TIEHANDLE { bless {} }
-sub DESTROY {}
+sub DESTROY { }
sub AUTOLOAD {
- warn "$AUTOLOAD called";
- exit 1; # May be in an eval
+ warn "$AUTOLOAD called";
+ exit 1; # May be in an eval
}
diff --git a/t/refcount.t b/t/refcount.t
index 1e0a69d..8294a03 100644
--- a/t/refcount.t
+++ b/t/refcount.t
@@ -1,52 +1,54 @@
use Test::More tests => 18;
use Devel::Peek;
-#$Id: refcount.t 26 2006-04-16 15:18:52Z demerphq $#
-
-BEGIN { use_ok( 'Data::Dump::Streamer',
- qw(refcount sv_refcount is_numeric looks_like_number weak_refcount weaken isweak));
+BEGIN {
+ use_ok('Data::Dump::Streamer',
+ qw(refcount sv_refcount is_numeric looks_like_number weak_refcount weaken isweak)
+ );
}
-my $sv="Foo";
-my $rav=[];
-my $rhv={};
+my $sv= "Foo";
+my $rav= [];
+my $rhv= {};
-is sv_refcount($sv),1,"sv_refcount";
-is refcount($rav),1,"refcount av";
-is refcount($rhv),1,"refcount hv";
+is sv_refcount($sv), 1, "sv_refcount";
+is refcount($rav), 1, "refcount av";
+is refcount($rhv), 1, "refcount hv";
-is refcount(\$sv),2,'refcount \\$foo';
+is refcount(\$sv), 2, 'refcount \\$foo';
-my $ref=\$sv;
+my $ref= \$sv;
-is sv_refcount($sv),2,'sv_refcount after';
-is refcount(\$sv),3,'refcount after';
+is sv_refcount($sv), 2, 'sv_refcount after';
+is refcount(\$sv), 3, 'refcount after';
SKIP: {
- skip ( "No Weak Refs", 3 )
+ skip("No Weak Refs", 3)
unless eval { weaken($ref) };
- is isweak($ref),1,"is weakened";
- is sv_refcount($sv),2,"weakened sv_refcount";
- is weak_refcount($sv),1,"weak_refcount";
- is refcount(\$sv),3,"weakened refcount";
+ is isweak($ref), 1, "is weakened";
+ is sv_refcount($sv), 2, "weakened sv_refcount";
+ is weak_refcount($sv), 1, "weak_refcount";
+ is refcount(\$sv), 3, "weakened refcount";
}
{
use strict;
- my $sv="Foo";
- my $iv=100;
- my $nv=1.234;
- my $dbl=1e40;
-
- my %hash=(100=>1,1.234=>1,1e40=>1);
-
- for my $t ( [$sv,''],
- [$iv,1], [$nv,1],
- [$dbl,1],
- map {[$_,'']} keys %hash
- ){
- is is_numeric($t->[0]),$t->[1],"Test:".$t->[0];
+ my $sv= "Foo";
+ my $iv= 100;
+ my $nv= 1.234;
+ my $dbl= 1e40;
+
+ my %hash= (100 => 1, 1.234 => 1, 1e40 => 1);
+
+ for my $t (
+ [ $sv, '' ],
+ [ $iv, 1 ],
+ [ $nv, 1 ],
+ [ $dbl, 1 ],
+ map { [ $_, '' ] } keys %hash
+ ) {
+ is is_numeric($t->[0]), $t->[1], "Test:" . $t->[0];
}
}
__END__
diff --git a/t/refelem.t b/t/refelem.t
index 8672415..3fa13da 100644
--- a/t/refelem.t
+++ b/t/refelem.t
@@ -1,12 +1,10 @@
print "1..5\n";
-#$Id: refelem.t 26 2006-04-16 15:18:52Z demerphq $#
-
use strict;
use Data::Dump::Streamer qw(alias_av push_alias alias_hv);
-my $a = "a";
-my @a = (1, 2, 3, 4);
+my $a= "a";
+my @a= (1, 2, 3, 4);
alias_av(@a, 1, $a);
push_alias(@a, $a);
@@ -14,30 +12,30 @@ push_alias(@a, $a);
print "not " unless "@a" eq "1 a 3 4 a";
print "ok 1\n";
-$a = 2;
+$a= 2;
print "not " unless "@a" eq "1 2 3 4 2";
print "ok 2\n";
-$a[1] = "z";
+$a[1]= "z";
print "not " unless $a[4] eq "z";
print "ok 3\n";
my %h;
alias_hv(%h, "foo", $a);
-$h{foo} = "bar";
+$h{foo}= "bar";
print "not " unless $a eq "bar";
print "ok 4\n";
-$a[2] = [3];
+$a[2]= [3];
alias_av(@a, 2, $a[2][0]);
print "not " unless $a[2] == 3;
print "ok 5\n";
if (shift) {
- require Devel::Peek;
- Devel::Peek::Dump($a);
- Devel::Peek::Dump(\@a);
- Devel::Peek::Dump(\%h);
+ require Devel::Peek;
+ Devel::Peek::Dump($a);
+ Devel::Peek::Dump(\@a);
+ Devel::Peek::Dump(\%h);
}
diff --git a/t/reftype.t b/t/reftype.t
index 78515d9..fb0842b 100644
--- a/t/reftype.t
+++ b/t/reftype.t
@@ -1,48 +1,47 @@
# this is from the Scalar::Utils distro
use Data::Dump::Streamer qw(reftype);
-use vars qw($t $y $x *F);
-use Symbol qw(gensym);
-
-#$Id: reftype.t 26 2006-04-16 15:18:52Z demerphq $#
+use vars qw($t $y $x *F);
+use Symbol qw(gensym);
# Ensure we do not trigger and tied methods
tie *F, 'MyTie';
-@test = (
- [ undef, 1],
- [ undef, 'A'],
- [ HASH => {} ],
- [ ARRAY => [] ],
- [ SCALAR => \$t ],
- [ REF => \(\$t) ],
- [ GLOB => \*F ],
- [ GLOB => gensym ],
- [ CODE => sub {} ],
+@test= (
+ [ undef, 1 ],
+ [ undef, 'A' ],
+ [ HASH => {} ],
+ [ ARRAY => [] ],
+ [ SCALAR => \$t ],
+ [ REF => \(\$t) ],
+ [ GLOB => \*F ],
+ [ GLOB => gensym ],
+ [ CODE => sub { } ],
+
# [ IO => *STDIN{IO} ] the internal sv_reftype returns UNKNOWN
);
-print "1..", @test*4, "\n";
+print "1..", @test * 4, "\n";
-my $i = 1;
+my $i= 1;
foreach $test (@test) {
- my($type,$what) = @$test;
- my $pack;
- foreach $pack (undef,"ABC","0",undef) {
- print "# $what\n";
- my $res = reftype($what);
- printf "# '%s' - '%s'\n", map { defined $_ ? $_ : 'undef' } $type,$res;
- print "not " if $type ? $res ne $type : $res;
- bless $what, $pack if $type && defined $pack;
- print "ok ",$i++,"\n";
- }
+ my ($type, $what)= @$test;
+ my $pack;
+ foreach $pack (undef, "ABC", "0", undef) {
+ print "# $what\n";
+ my $res= reftype($what);
+ printf "# '%s' - '%s'\n", map { defined $_ ? $_ : 'undef' } $type, $res;
+ print "not " if $type ? $res ne $type : $res;
+ bless $what, $pack if $type && defined $pack;
+ print "ok ", $i++, "\n";
+ }
}
package MyTie;
sub TIEHANDLE { bless {} }
-sub DESTROY {}
+sub DESTROY { }
sub AUTOLOAD {
- warn "$AUTOLOAD called";
- exit 1; # May be in an eval
+ warn "$AUTOLOAD called";
+ exit 1; # May be in an eval
}
diff --git a/t/sortkeys.t b/t/sortkeys.t
index 0267239..7adfc96 100644
--- a/t/sortkeys.t
+++ b/t/sortkeys.t
@@ -1,13 +1,12 @@
use Test::More tests => 10;
-BEGIN { use_ok( 'Data::Dump::Streamer', qw(:undump) ); }
+BEGIN { use_ok('Data::Dump::Streamer', qw(:undump)); }
use strict;
use warnings;
use Data::Dumper;
-#$Id: sortkeys.t 26 2006-04-16 15:18:52Z demerphq $#
-
# imports same()
require "./t/test_helper.pl";
+
# use this one for simple, non evalable tests. (GLOB)
# same ( $got,$expected,$name,$obj )
#
@@ -15,14 +14,17 @@ require "./t/test_helper.pl";
# same ( $name,$obj,$expected,@args )
my $dump;
-my $o = Data::Dump::Streamer->new();
+my $o= Data::Dump::Streamer->new();
-isa_ok( $o, 'Data::Dump::Streamer' );
+isa_ok($o, 'Data::Dump::Streamer');
{
- use warnings FATAL=>'all';
- my $hash={(map {$_ => $_, "1$_"=>"1$_" } 0..9,'a'..'j','A'..'J'),map { ( chr(65+$_).$_ => $_, $_.chr(65+$_) => $_) } 0..9};
-same( "Sortkeys Mixed Default (smart)", $o , <<'EXPECT',$hash );
+ use warnings FATAL => 'all';
+ my $hash= {
+ (map { $_ => $_, "1$_" => "1$_" } 0 .. 9, 'a' .. 'j', 'A' .. 'J'),
+ map { (chr(65 + $_) . $_ => $_, $_ . chr(65 + $_) => $_) } 0 .. 9
+ };
+ same("Sortkeys Mixed Default (smart)", $o, <<'EXPECT', $hash);
$HASH1 = {
0 => 0,
"0A" => 0,
@@ -105,7 +107,7 @@ $HASH1 = {
J9 => 9
};
EXPECT
-same( "Sortkeys Mixed Lexico", $o->SortKeys('lex'), <<'EXPECT',( $hash ));
+ same("Sortkeys Mixed Lexico", $o->SortKeys('lex'), <<'EXPECT', ($hash));
$HASH1 = {
0 => 0,
"0A" => 0,
@@ -188,8 +190,11 @@ $HASH1 = {
j => 'j'
};
EXPECT
-$hash={map { $_ => 1} (1,10,11,2,20,100)};
-same( "Sortkeys Numeric Alph==Lex", $o->SortKeys('alph'), <<'EXPECT', ( $hash ) );
+ $hash= { map { $_ => 1 } (1, 10, 11, 2, 20, 100) };
+ same(
+ "Sortkeys Numeric Alph==Lex",
+ $o->SortKeys('alph'),
+ <<'EXPECT', ($hash));
$HASH1 = {
1 => 1,
10 => 1,
@@ -199,7 +204,7 @@ $HASH1 = {
20 => 1
};
EXPECT
-same( "Sortkeys Numeric", $o->SortKeys('num') , <<'EXPECT', ( $hash ) );
+ same("Sortkeys Numeric", $o->SortKeys('num'), <<'EXPECT', ($hash));
$HASH1 = {
1 => 1,
2 => 1,
@@ -209,7 +214,7 @@ $HASH1 = {
100 => 1
};
EXPECT
-same( "Sortkeys Numeric Smart", $o->SortKeys('smart'), <<'EXPECT', ( $hash ) );
+ same("Sortkeys Numeric Smart", $o->SortKeys('smart'), <<'EXPECT', ($hash));
$HASH1 = {
1 => 1,
2 => 1,
@@ -219,7 +224,13 @@ $HASH1 = {
100 => 1
};
EXPECT
-same( $dump = $o->SortKeys(sub {[ sort grep { /1/ } keys %{shift @_} ]})->Data( $hash )->Out, <<'EXPECT', "Sortkeys Custom Filter", $o );
+ same(
+ $dump= $o->SortKeys(
+ sub {
+ [ sort grep { /1/ } keys %{ shift @_ } ]
+ }
+ )->Data($hash)->Out,
+ <<'EXPECT', "Sortkeys Custom Filter", $o);
$HASH1 = {
1 => 1,
10 => 1,
@@ -227,15 +238,16 @@ $HASH1 = {
11 => 1
};
EXPECT
-$o->SortKeys('smart');
+ $o->SortKeys('smart');
}
{
#local $Data::Dump::Streamer::DEBUG=1;
- my $h={'A'...'J'};
- my $h2={'A'..'J'};
- my $foo_bar=bless {foo=>1,bar=>2,baz=>3},'Foo::Bar';
- $o->HashKeys('Foo::Bar'=>[qw(foo bar)],$h=>[qw( C G E )]);
-same( $dump = $o->Data($h2,$h,$foo_bar)->Out, <<'EXPECT', "HashKeys - array", $o );
+ my $h= { 'A' ... 'J' };
+ my $h2= { 'A' .. 'J' };
+ my $foo_bar= bless { foo => 1, bar => 2, baz => 3 }, 'Foo::Bar';
+ $o->HashKeys('Foo::Bar' => [qw(foo bar)], $h => [qw( C G E )]);
+ same($dump= $o->Data($h2, $h, $foo_bar)->Out,
+ <<'EXPECT', "HashKeys - array", $o);
$HASH1 = {
A => 'B',
C => 'D',
@@ -253,8 +265,9 @@ $Foo_Bar1 = bless( {
bar => 2
}, 'Foo::Bar' );
EXPECT
- $o->HashKeys($h2=>sub { return ['I'] });
- same( $dump = $o->Data($h2,$h,$foo_bar)->Out, <<'EXPECT', "HashKeys - coderef", $o );
+ $o->HashKeys($h2 => sub { return ['I'] });
+ same($dump= $o->Data($h2, $h, $foo_bar)->Out,
+ <<'EXPECT', "HashKeys - coderef", $o);
$HASH1 = { I => 'J' };
$HASH2 = {
C => 'D',
diff --git a/t/stash.t b/t/stash.t
new file mode 100644
index 0000000..a839d75
--- /dev/null
+++ b/t/stash.t
@@ -0,0 +1,6 @@
+use Test::More;
+use Data::Dump::Streamer qw(Dump);
+
+my $dump= Dump(\%::);
+pass("Dumping the stash did not die");
+done_testing;
diff --git a/t/terse.t b/t/terse.t
new file mode 100644
index 0000000..86ffcea
--- /dev/null
+++ b/t/terse.t
@@ -0,0 +1,23 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More;
+
+use Data::Dump::Streamer;
+
+note "Single variable with Terse"; {
+ is_deeply(eval(Dump([])->Terse(1)->Out), []);
+ is_deeply eval(Dump({})->Terse(1)->Out), {};
+ is eval(Dump(23)->Terse(1)->Out), 23;
+ is_deeply eval(Dump({ foo => 23 })->Terse(1)->Out), { foo => 23 };
+}
+
+note "Many variables with Terse";
+
+note "Code refs with Terse"; {
+ is eval(Dump(sub { 23 })->Terse(1)->Out)->(), 23;
+}
+
+done_testing;
diff --git a/t/test_helper.pl b/t/test_helper.pl
index 2519636..f48e9ea 100644
--- a/t/test_helper.pl
+++ b/t/test_helper.pl
@@ -8,7 +8,6 @@ BEGIN {
$Has{sortkeys}=!!eval "Data::Dumper->new([1])->Sortkeys(1)->Dump()";
}
-#$Id: test_helper.pl 26 2006-04-16 15:18:52Z demerphq $#
# all of this is acumulated junk used for making the various test easier.
# as a close inspection shows, this all derives from different periods of
diff --git a/t/tree.t b/t/tree.t
index 74abf1d..80d0957 100644
--- a/t/tree.t
+++ b/t/tree.t
@@ -1,13 +1,12 @@
use Test::More tests => 6;
-BEGIN { use_ok( 'Data::Dump::Streamer', qw(:undump) ); }
+BEGIN { use_ok('Data::Dump::Streamer', qw(:undump)); }
use strict;
use warnings;
use Data::Dumper;
-#$Id: tree.t 26 2006-04-16 15:18:52Z demerphq $#
-
# imports same()
require "./t/test_helper.pl";
+
# use this one for simple, non evalable tests. (GLOB)
# same ( $got,$expected,$name,$obj )
#
@@ -15,41 +14,42 @@ require "./t/test_helper.pl";
# same ( $name,$obj,$expected,@args )
my $dump;
-my $o = Data::Dump::Streamer->new();
+my $o= Data::Dump::Streamer->new();
-isa_ok( $o, 'Data::Dump::Streamer' );
+isa_ok($o, 'Data::Dump::Streamer');
{
sub tree {
- my ($nodes,$md,$t,$d,$p,$par)=@_;
- $t||='@';
- $d||=0;
- $p=':' unless defined $p;
- if ($d<$md) {
+ my ($nodes, $md, $t, $d, $p, $par)= @_;
+ $t ||= '@';
+ $d ||= 0;
+ $p= ':' unless defined $p;
+ if ($d < $md) {
my $node;
if ($t eq '%') {
- $node={};
- push @$nodes,$node;
- %$node=(par=>$par,
- left=>tree ( $nodes,$md,$t,$d+1,$p.'0',$node),
- right=>tree ( $nodes,$md,$t,$d+1,$p.'1',$node)
- );
+ $node= {};
+ push @$nodes, $node;
+ %$node= (
+ par => $par,
+ left => tree($nodes, $md, $t, $d + 1, $p . '0', $node),
+ right => tree($nodes, $md, $t, $d + 1, $p . '1', $node));
- } else {
- $node=[];
- push @$nodes,$node;
- push @$node,$par,
- tree ( $nodes,$md,$t,$d+1,$p.'0',$node),
- tree ( $nodes,$md,$t,$d+1,$p.'1',$node);
+ }
+ else {
+ $node= [];
+ push @$nodes, $node;
+ push @$node, $par,
+ tree($nodes, $md, $t, $d + 1, $p . '0', $node),
+ tree($nodes, $md, $t, $d + 1, $p . '1', $node);
}
return $node;
}
return $p;
}
- my (@anodes,@hnodes);
- my $at=tree(\@anodes,3,'@');
- my $ht=tree(\@hnodes,3,'%');
- same( "Parent Array Tree", $o, <<'EXPECT',( $at ) );
+ my (@anodes, @hnodes);
+ my $at= tree(\@anodes, 3, '@');
+ my $ht= tree(\@hnodes, 3, '%');
+ same("Parent Array Tree", $o, <<'EXPECT', ($at));
$ARRAY1 = [
undef,
[
@@ -87,8 +87,7 @@ $ARRAY1->[2][1][0] = $ARRAY1->[2];
$ARRAY1->[2][2][0] = $ARRAY1->[2];
EXPECT
-
- same( "Parent tree Array Nodes", $o , <<'EXPECT', ( \@anodes ) );
+ same("Parent tree Array Nodes", $o, <<'EXPECT', (\@anodes));
$ARRAY1 = [
[
undef,
@@ -139,7 +138,7 @@ $ARRAY1->[4][2] = $ARRAY1->[6];
$ARRAY1->[5][0] = $ARRAY1->[4];
$ARRAY1->[6][0] = $ARRAY1->[4];
EXPECT
- same( "Parent tree Hash", $o , <<'EXPECT',( $ht ));
+ same("Parent tree Hash", $o, <<'EXPECT', ($ht));
$HASH1 = {
left => {
left => {
@@ -177,8 +176,7 @@ $HASH1->{right}{par} = $HASH1;
$HASH1->{right}{right}{par} = $HASH1->{right};
EXPECT
-
- same( "Parent Tree Hash Nodes", $o, <<'EXPECT', ( \@hnodes ) );
+ same("Parent Tree Hash Nodes", $o, <<'EXPECT', (\@hnodes));
$ARRAY1 = [
{
left => 'V: $ARRAY1->[1]',
diff --git a/t/usage.t b/t/usage.t
index 8cf29ce..ecc8d21 100644
--- a/t/usage.t
+++ b/t/usage.t
@@ -1,7 +1,8 @@
-our (@tests,$x,$obj,@list,$string);
+our (@tests, $x, $obj, @list, $string);
+
BEGIN {
- @tests=(
- 'Dump($x);',
+ @tests= (
+ 'Dump($x);',
'$obj=Dump(); ref $obj eq "Data::Dump::Streamer"',
'$obj=Dump($x); ref $obj eq "Data::Dump::Streamer"',
'$obj=Dump($x)->Purity(0); ref $obj eq "Data::Dump::Streamer"',
@@ -11,22 +12,17 @@ BEGIN {
'$string=$obj->Names("foo")->Data($x)->Dump(); $string =~/1,/ && $string=~/foo/',
);
}
-use Test::More tests => 1+@tests;
-BEGIN { use_ok( 'Data::Dump::Streamer', qw(:undump Dump) ); }
+use Test::More tests => 1 + @tests;
+BEGIN { use_ok('Data::Dump::Streamer', qw(:undump Dump)); }
use strict;
use warnings;
-$obj="";
-$x=[1..10];
-for my $snippet (@tests){
- my ($title)=split /;/,$snippet;
- @list=();
- $string="";
- ok(eval($snippet)&&!$@,$title)
+$obj= "";
+$x= [ 1 .. 10 ];
+for my $snippet (@tests) {
+ my ($title)= split /;/, $snippet;
+ @list= ();
+ $string= "";
+ ok(eval($snippet) && !$@, $title)
or diag @list ? "[@list]" : $string;
}
-#$Id: usage.t 26 2006-04-16 15:18:52Z demerphq $#
-
-
-
-
diff --git a/t/xs_subs.t b/t/xs_subs.t
index e2560a9..60725b1 100644
--- a/t/xs_subs.t
+++ b/t/xs_subs.t
@@ -1,123 +1,122 @@
-#$Id: xs_subs.t 26 2006-04-16 15:18:52Z demerphq $#
-
use vars qw/$XTRA/;
-use Test::More tests=>10+($XTRA=26);
+use Test::More tests => 10 + ($XTRA= 26);
BEGIN {
- use_ok( 'Data::Dump::Streamer', qw(
- Dump readonly hidden_keys legal_keys lock_keys lock_ref_keys
- lock_keys_plus lock_ref_keys_plus ));
+ use_ok(
+ 'Data::Dump::Streamer', qw(
+ Dump readonly hidden_keys legal_keys lock_keys lock_ref_keys
+ lock_keys_plus lock_ref_keys_plus )
+ );
}
# from Scalar::Util readonly.t
-ok(readonly(1),'readonly(1)');
-
-my $var = 2;
-ok(!readonly($var),'$var = 2; readonly($var)');
-ok($var == 2,'$var==2');
+ok(readonly(1), 'readonly(1)');
+my $var= 2;
+ok(!readonly($var), '$var = 2; readonly($var)');
+ok($var == 2, '$var==2');
-ok(readonly("fred"),'readonly("fred")');
+ok(readonly("fred"), 'readonly("fred")');
-$var = "fred";
-ok(!readonly($var),'$var = fred; readonly($var)');
-ok($var eq "fred",'$var eq "fred"');
+$var= "fred";
+ok(!readonly($var), '$var = fred; readonly($var)');
+ok($var eq "fred", '$var eq "fred"');
-$var = \2;
-ok(!readonly($var),'$var=\2; readonly($var)');
-ok(readonly($$var),'readonly($$var)');
-ok(!readonly(*STDOUT),'readonly(*STDOUT)');
+$var= \2;
+ok(!readonly($var), '$var=\2; readonly($var)');
+ok(readonly($$var), 'readonly($$var)');
+ok(!readonly(*STDOUT), 'readonly(*STDOUT)');
# new
-SKIP:{
- skip "No locked key semantics before 5.8.0",
- $XTRA
- if $]<5.008;
-{
- my %hash=map { $_ => 1 } qw( a b c d e f);
- delete $hash{c};
- lock_keys(%hash);
- ok(Internals::SvREADONLY(%hash),'lock_keys');
+SKIP: {
+ skip "No locked key semantics before 5.8.0", $XTRA
+ if $] < 5.008;
+ {
+ my %hash= map { $_ => 1 } qw( a b c d e f);
+ delete $hash{c};
+ lock_keys(%hash);
+ ok(Internals::SvREADONLY(%hash), 'lock_keys');
- # we do this skip here just to make sure lock_keys is correctly setup.
- skip "Cant tell if a key is locked in 5.8.0",
- $XTRA - 1
- if $]==5.008;
+ # we do this skip here just to make sure lock_keys is correctly setup.
+ skip "Cant tell if a key is locked in 5.8.0", $XTRA - 1
+ if $] == 5.008;
- delete @hash{qw(b e)};
- my @hidden=sort(hidden_keys(%hash));
- my @legal=sort(legal_keys(%hash));
- my @keys=sort(keys(%hash));
- #warn "@legal\n@keys\n";
- is("@hidden","b e",'lock_keys @hidden');
- is("@legal","a b d e f",'lock_keys @legal');
- is("@keys","a d f",'lock_keys @keys');
-}
-{
- my %hash=(0..9);
- lock_keys(%hash);
- ok(Internals::SvREADONLY(%hash),'lock_keys');
- Hash::Util::unlock_keys(%hash);
- ok(!Internals::SvREADONLY(%hash),'unlock_keys');
-}
-{
- my %hash=(0..9);
- lock_keys(%hash,keys(%hash),'a'..'f');
- ok(Internals::SvREADONLY(%hash),'lock_keys args');
- my @hidden=sort(hidden_keys(%hash));
- my @legal=sort(legal_keys(%hash));
- my @keys=sort(keys(%hash));
- is("@hidden","a b c d e f",'lock_keys() @hidden');
- is("@legal","0 2 4 6 8 a b c d e f",'lock_keys() @legal');
- is("@keys","0 2 4 6 8",'lock_keys() @keys');
-}
-{
- my %hash=map { $_ => 1 } qw( a b c d e f);
- delete $hash{c};
- lock_ref_keys(\%hash);
- ok(Internals::SvREADONLY(%hash),'lock_ref_keys');
- delete @hash{qw(b e)};
- my @hidden=sort(hidden_keys(%hash));
- my @legal=sort(legal_keys(%hash));
- my @keys=sort(keys(%hash));
- #warn "@legal\n@keys\n";
- is("@hidden","b e",'lock_ref_keys @hidden');
- is("@legal","a b d e f",'lock_ref_keys @legal');
- is("@keys","a d f",'lock_ref_keys @keys');
-}
-{
- my %hash=(0..9);
- lock_ref_keys(\%hash,keys %hash,'a'..'f');
- ok(Internals::SvREADONLY(%hash),'lock_ref_keys args');
- my @hidden=sort(hidden_keys(%hash));
- my @legal=sort(legal_keys(%hash));
- my @keys=sort(keys(%hash));
- is("@hidden","a b c d e f",'lock_ref_keys() @hidden');
- is("@legal","0 2 4 6 8 a b c d e f",'lock_ref_keys() @legal');
- is("@keys","0 2 4 6 8",'lock_ref_keys() @keys');
-}
-{
- my %hash=(0..9);
- lock_ref_keys_plus(\%hash,'a'..'f');
- ok(Internals::SvREADONLY(%hash),'lock_ref_keys args');
- my @hidden=sort(hidden_keys(%hash));
- my @legal=sort(legal_keys(%hash));
- my @keys=sort(keys(%hash));
- is("@hidden","a b c d e f",'lock_ref_keys_plus() @hidden');
- is("@legal","0 2 4 6 8 a b c d e f",'lock_ref_keys_plus() @legal');
- is("@keys","0 2 4 6 8",'lock_ref_keys_plus() @keys');
-}
-{
- my %hash=(0..9);
- lock_keys_plus(%hash,'a'..'f');
- ok(Internals::SvREADONLY(%hash),'lock_keys args');
- my @hidden=sort(hidden_keys(%hash));
- my @legal=sort(legal_keys(%hash));
- my @keys=sort(keys(%hash));
- is("@hidden","a b c d e f",'lock_keys_plus() @hidden');
- is("@legal","0 2 4 6 8 a b c d e f",'lock_keys_plus() @legal');
- is("@keys","0 2 4 6 8",'lock_keys_plus() @keys');
-}
+ delete @hash{qw(b e)};
+ my @hidden= sort(hidden_keys(%hash));
+ my @legal= sort(legal_keys(%hash));
+ my @keys= sort(keys(%hash));
+
+ #warn "@legal\n@keys\n";
+ is("@hidden", "b e", 'lock_keys @hidden');
+ is("@legal", "a b d e f", 'lock_keys @legal');
+ is("@keys", "a d f", 'lock_keys @keys');
+ }
+ {
+ my %hash= (0 .. 9);
+ lock_keys(%hash);
+ ok(Internals::SvREADONLY(%hash), 'lock_keys');
+ Hash::Util::unlock_keys(%hash);
+ ok(!Internals::SvREADONLY(%hash), 'unlock_keys');
+ }
+ {
+ my %hash= (0 .. 9);
+ lock_keys(%hash, keys(%hash), 'a' .. 'f');
+ ok(Internals::SvREADONLY(%hash), 'lock_keys args');
+ my @hidden= sort(hidden_keys(%hash));
+ my @legal= sort(legal_keys(%hash));
+ my @keys= sort(keys(%hash));
+ is("@hidden", "a b c d e f", 'lock_keys() @hidden');
+ is("@legal", "0 2 4 6 8 a b c d e f", 'lock_keys() @legal');
+ is("@keys", "0 2 4 6 8", 'lock_keys() @keys');
+ }
+ {
+ my %hash= map { $_ => 1 } qw( a b c d e f);
+ delete $hash{c};
+ lock_ref_keys(\%hash);
+ ok(Internals::SvREADONLY(%hash), 'lock_ref_keys');
+ delete @hash{qw(b e)};
+ my @hidden= sort(hidden_keys(%hash));
+ my @legal= sort(legal_keys(%hash));
+ my @keys= sort(keys(%hash));
+
+ #warn "@legal\n@keys\n";
+ is("@hidden", "b e", 'lock_ref_keys @hidden');
+ is("@legal", "a b d e f", 'lock_ref_keys @legal');
+ is("@keys", "a d f", 'lock_ref_keys @keys');
+ }
+ {
+ my %hash= (0 .. 9);
+ lock_ref_keys(\%hash, keys %hash, 'a' .. 'f');
+ ok(Internals::SvREADONLY(%hash), 'lock_ref_keys args');
+ my @hidden= sort(hidden_keys(%hash));
+ my @legal= sort(legal_keys(%hash));
+ my @keys= sort(keys(%hash));
+ is("@hidden", "a b c d e f", 'lock_ref_keys() @hidden');
+ is("@legal", "0 2 4 6 8 a b c d e f", 'lock_ref_keys() @legal');
+ is("@keys", "0 2 4 6 8", 'lock_ref_keys() @keys');
+ }
+ {
+ my %hash= (0 .. 9);
+ lock_ref_keys_plus(\%hash, 'a' .. 'f');
+ ok(Internals::SvREADONLY(%hash), 'lock_ref_keys args');
+ my @hidden= sort(hidden_keys(%hash));
+ my @legal= sort(legal_keys(%hash));
+ my @keys= sort(keys(%hash));
+ is("@hidden", "a b c d e f", 'lock_ref_keys_plus() @hidden');
+ is("@legal", "0 2 4 6 8 a b c d e f", 'lock_ref_keys_plus() @legal');
+ is("@keys", "0 2 4 6 8", 'lock_ref_keys_plus() @keys');
+ }
+ {
+ my %hash= (0 .. 9);
+ lock_keys_plus(%hash, 'a' .. 'f');
+ ok(Internals::SvREADONLY(%hash), 'lock_keys args');
+ my @hidden= sort(hidden_keys(%hash));
+ my @legal= sort(legal_keys(%hash));
+ my @keys= sort(keys(%hash));
+ is("@hidden", "a b c d e f", 'lock_keys_plus() @hidden');
+ is("@legal", "0 2 4 6 8 a b c d e f", 'lock_keys_plus() @legal');
+ is("@keys", "0 2 4 6 8", 'lock_keys_plus() @keys');
+ }
}
generated by cgit v1.2.3 (git 2.25.1) at 2024-06-02 16:03:01 +0000