Add tests for

	Dumpvalue.pm
Message-Id: <20010923014628.7739.qmail@onion.perl.org>

p4raw-id: //depot/perl@12150

2 files changed, 300 insertions, 9 deletions

diff --git a/lib/Dumpvalue.pm b/lib/Dumpvalue.pm
index 427f57cc42..c9b1acafeb 100644
--- a/lib/Dumpvalue.pm
+++ b/lib/Dumpvalue.pm
@@ -1,9 +1,10 @@
 use 5.006_001;			# for (defined ref) and $#$v and our
 package Dumpvalue;
 use strict;
-our $VERSION = '1.00';
+our $VERSION = '1.10';
 our(%address, $stab, @stab, %stab, %subs);
 
+# documentation nits, handle complex data structures better by chromatic
 # translate control chars to ^X - Randal Schwartz
 # Modifications to print types by Peter Gordon v1.0
 
@@ -428,7 +429,14 @@ EOP
 
 sub scalarUsage {
   my $self = shift;
-  my $size = length($_[0]);
+  my $size;
+  if (UNIVERSAL::isa($_[0], 'ARRAY')) {
+	$size = $self->arrayUsage($_[0]);
+  } elsif (UNIVERSAL::isa($_[0], 'HASH')) {
+	$size = $self->hashUsage($_[0]);
+  } elsif (!ref($_[0])) {
+	$size = length($_[0]);
+  }
   $self->{TotalStrings} += $size;
   $self->{Strings}++;
   $size;
@@ -511,28 +519,28 @@ may be printed on one line.
 
 Whether to print contents of globs.
 
-=item C<DumpDBFiles>
+=item C<dumpDBFiles>
 
 Dump arrays holding contents of debugged files.
 
-=item C<DumpPackages>
+=item C<dumpPackages>
 
 Dump symbol tables of packages.
 
-=item C<DumpReused>
+=item C<dumpReused>
 
 Dump contents of "reused" addresses.
 
-=item C<tick>, C<HighBit>, C<printUndef>
+=item C<tick>, C<quoteHighBit>, C<printUndef>
 
 Change style of string dump.  Default value of C<tick> is C<auto>, one
 can enable either double-quotish dump, or single-quotish by setting it
 to C<"> or C<'>.  By default, characters with high bit set are printed
-I<as is>.
+I<as is>.  If C<quoteHighBit> is set, they will be quoted.
 
-=item C<UsageOnly>
+=item C<usageOnly>
 
-I<very> rudimentally per-package memory usage dump.  If set,
+rudimentally per-package memory usage dump.  If set,
 C<dumpvars> calculates total size of strings in variables in the package.
 
 =item unctrl
diff --git a/lib/Dumpvalue.t b/lib/Dumpvalue.t
new file mode 100644
index 0000000000..7c1d803021
--- /dev/null
+++ b/lib/Dumpvalue.t
@@ -0,0 +1,283 @@
+#!./perl
+
+BEGIN {
+	chdir 't' if -d 't';
+	@INC = '../lib';
+}
+
+use vars qw( $foo @bar %baz );
+
+use Test::More tests => 88;
+
+use_ok( 'Dumpvalue' );
+
+my $d;
+ok( $d = Dumpvalue->new(), 'create a new Dumpvalue object' );
+
+$d->set( globPrint => 1, dumpReused => 1 );
+is( $d->{globPrint}, 1, 'set an option correctly' );
+is( $d->get('globPrint'), 1, 'get an option correctly' );
+is( $d->get('globPrint', 'dumpReused'), qw( 1 1 ), 'get multiple options' );
+
+# check to see if unctrl works
+is( ref( Dumpvalue::unctrl(*FOO) ), 'GLOB', 'unctrl should not modify GLOB' );
+is( Dumpvalue::unctrl('donotchange'), 'donotchange', "unctrl shouldn't modify");
+like( Dumpvalue::unctrl("bo\007nd"), qr/bo\^.nd/, 'unctrl should escape' );
+
+# check to see if stringify works
+is( $d->stringify(), 'undef', 'stringify handles undef okay' );
+
+# the default is 1, but we want two single quotes
+$d->{printUndef} = 0;
+is( $d->stringify(), "''", 'stringify skips undef when asked nicely' );
+
+is( $d->stringify(*FOO), *FOO . "", 'stringify stringifies globs alright' );
+
+# check for double-quotes if there's an unprintable character
+$d->{tick} = 'auto';
+like( $d->stringify("hi\005"), qr/^"hi/, 'added double-quotes when necessary' );
+
+# if no unprintable character, escape ticks or backslashes
+is( $d->stringify('hi'), "'hi'", 'used single-quotes when appropriate' );
+
+# if 'unctrl' is set
+$d->{unctrl} = 'unctrl';
+like( $d->stringify('double and whack:\ "'), qr!\\ \"!, 'escaped with unctrl' );
+like( $d->stringify("a\005"), qr/^"a\^/, 'escaped ASCII value in unctrl' );
+like( $d->stringify("b\205"), qr!^'b.'$!, 'no high-bit escape value in unctrl');
+
+$d->{quoteHighBit} = 1;
+like( $d->stringify("b\205"), qr!^'b\\205!, 'high-bit now escaped in unctrl');
+
+# if 'quote' is set
+$d->{unctrl} = 'quote';
+is( $d->stringify('5@ $1'), "'5\@ \$1'", 'quoted $ and @ fine' );
+is( $d->stringify("5@\033\$1"), '"5\@\e\$1"', 'quoted $ and @ and \033 fine' );
+like( $d->stringify("\037"), qr/^"\\c/, 'escaped ASCII value okay' );
+
+# add ticks, if necessary
+is( $d->stringify("no ticks", 1), 'no ticks', 'avoid ticks if asked' );
+
+my $out = tie *OUT, 'TieOut';
+select(OUT);
+
+# test DumpElem, it does its magic with veryCompact set
+$d->{veryCompact} = 1;
+$d->DumpElem([1, 2, 3]);
+is( $out->read, "0..2  1 2 3\n", 'DumpElem worked on array ref');
+$d->DumpElem({ one => 1, two => 2 });
+is( $out->read, "'one' => 1, 'two' => 2\n", 'DumpElem worked on hash ref' );
+$d->DumpElem('hi');
+is( $out->read, "'hi'\n", 'DumpElem worked on simple scalar' );
+$d->{veryCompact} = 0;
+$d->DumpElem([]);
+like( $out->read, qr/ARRAY/, 'DumpElem okay with reference and no veryCompact');
+
+# should compact simple arrays just fine
+$d->{veryCompact} = 1;
+$d->DumpElem([1, 2, 3]);
+is( $out->read, "0..2  1 2 3\n", 'dumped array fine' );
+$d->{arrayDepth} = 2;
+$d->DumpElem([1, 2, 3]);
+is( $out->read, "0..2  1 2 ...\n", 'dumped limited array fine' );
+
+# should compact simple hashes just fine
+$d->DumpElem({ a => 1, b => 2, c => 3 });
+is( $out->read, "'a' => 1, 'b' => 2, 'c' => 3\n", 'dumped hash fine' );
+$d->{hashDepth} = 2;
+$d->DumpElem({ a => 1, b => 2, c => 3 });
+is( $out->read, "'a' => 1, 'b' => 2 ...\n", 'dumped limited hash fine' );
+
+# should just stringify what it is
+$d->{veryCompact} = 0;
+$d->DumpElem([]);
+like( $out->read, qr/ARRAY.+empty array/s, 'stringified empty array ref' );
+$d->DumpElem({});
+like( $out->read, qr/HASH.+empty hash/s, 'stringified empty hash ref' );
+$d->DumpElem(1);
+is( $out->read, "1\n", 'stringified simple scalar' );
+
+# test unwrap
+$DB::signal = $d->{stopDbSignal} = 1;
+is( $d->unwrap(), undef, 'unwrap returns if DB signal is set' );
+undef $DB::signal;
+
+my $foo = 7;
+$d->{dumpReused} = 0;
+$d->unwrap(\$foo);
+is( $out->read, "-> 7\n", 'unwrap worked on scalar' );
+$d->unwrap(\$foo);
+is( $out->read, "-> REUSED_ADDRESS\n", 'unwrap worked on scalar' );
+$d->unwrap({ one => 1 });
+
+# leaving this at zero may cause some subsequent tests to fail
+# if they reuse an address creating an anonymous variable
+$d->{dumpReused} = 1;
+is( $out->read, "'one' => 1\n", 'unwrap worked on hash' );
+$d->unwrap([ 2, 3 ]);
+is( $out->read, "0  2\n1  3\n", 'unwrap worked on array' );
+$d->unwrap(*FOO);
+is( $out->read, '', 'unwrap ignored glob on first try');
+$d->unwrap(*FOO);
+is( $out->read, "*DUMPED_GLOB*\n", 'unwrap worked on glob');
+$d->unwrap(qr/foo(.+)/);
+is( $out->read, "-> qr/(?-xism:foo(.+))/\n", 'unwrap worked on Regexp' );
+$d->unwrap( sub {} );
+like( $out->read, qr/^-> &CODE/, 'unwrap worked on sub ref' );
+
+# test matchvar
+# test to see if first arg 'eq' second
+ok( Dumpvalue::matchvar(1, 1), 'matchvar matched numbers fine' );
+ok( Dumpvalue::matchvar('hi', 'hi'), 'matchvar matched strings fine' );
+ok( !Dumpvalue::matchvar('hello', 1), 'matchvar caught failed match fine' );
+
+# test compactDump, which doesn't do much
+is( $d->compactDump(3), 3, 'set compactDump to 3' );
+is( $d->compactDump(1), 479, 'compactDump reset to 6*80-1 when less than 2' );
+
+# test veryCompact, which does slightly more, setting compactDump sometimes
+$d->{compactDump} = 0;
+is( $d->veryCompact(1), 1, 'set veryCompact successfully' );
+ok( $d->compactDump(), 'and it set compactDump as well' );
+
+# test set_unctrl
+$d->set_unctrl('impossible value');
+like( $out->read, qr/^Unknown value/, 'set_unctrl caught bad value' );
+is( $d->set_unctrl('quote'), 'quote', 'set quote fine' );
+is( $d->set_unctrl(), 'quote', 'retrieved quote fine' );
+
+# test set_quote
+$d->set_quote('"');
+is( $d->{tick}, '"', 'set_quote set tick right' );
+is( $d->{unctrl}, 'quote', 'set unctrl right too' );
+$d->set_quote('auto');
+is( $d->{tick}, 'auto', 'set_quote set auto right' );
+$d->set_quote('foo');
+is( $d->{tick}, "'", 'default value set to " correctly' );
+
+# test dumpglob
+# should do nothing if debugger signal flag is raised
+$d->{stopDbSignal} = $DB::signal = 1;
+is( $d->dumpglob(*DB::signal), undef, 'returned early with DB signal set' );
+undef $DB::signal;
+
+# test dumping "normal" variables, this is a nasty glob trick
+$foo = 1;
+$d->dumpglob( '', 2, 'foo', local *foo = \$foo );
+is( $out->read, "  \$foo = 1\n", 'dumped glob for $foo correctly' );
+@bar = (1, 2);
+
+# the key name is a little different here
+$d->dumpglob( '', 0, 'boo', *bar );
+is( $out->read, "\@boo = (\n   0..1  1 2\n)\n", 'dumped glob for @bar fine' );
+
+%baz = ( one => 1, two => 2 );
+$d->dumpglob( '', 0, 'baz', *baz );
+is( $out->read, "\%baz = (\n   'one' => 1, 'two' => 2\n)\n",
+	'dumped glob for %baz fine' );
+
+SKIP: {
+	skip( "Couldn't open $0 for reading", 1 ) unless open(FILE, $0);
+	my $fileno = fileno(FILE);
+	$d->dumpglob( '', 0, 'FILE', *FILE );
+	is( $out->read, "FileHandle(FILE) => fileno($fileno)\n",
+		'dumped filehandle from glob fine' );
+}
+
+$d->dumpglob( '', 0, 'read', *TieOut::read );
+is( $out->read, '', 'no sub dumped without $all set' );
+$d->dumpglob( '', 0, 'read', \&TieOut::read, 1 );
+is( $out->read, "&read in ???\n", 'sub dumped when requested' );
+
+# see if it dumps DB-like values correctly
+$d->{dumpDBFiles} = 1;
+$d->dumpglob( '', 0, '_<foo', *foo );
+is( $out->read, "\$_<foo = 1\n", 'dumped glob for $_<foo correctly (DB)' );
+
+# test CvGV name
+SKIP: {
+	skip( 'no Devel::Peek', 1 ) unless use_ok( 'Devel::Peek' );
+	is( $d->CvGV_name(\&TieOut::read), 'TieOut::read', 'CvGV_name found sub' );
+}
+
+# test dumpsub
+$d->dumpsub( '', 'TieOut::read' );
+like( $out->read, qr/&TieOut::read in/, 'dumpsub found sub fine' );
+
+# test findsubs
+is( $d->findsubs(), undef, 'findsubs returns nothing without %DB::sub' );
+$DB::sub{'TieOut::read'} = 'TieOut';
+is( $d->findsubs( \&TieOut::read ), 'TieOut::read', 'findsubs reported sub' );
+
+# now that it's capable of finding the package...
+$d->dumpsub( '', 'TieOut::read' );
+is( $out->read, "&TieOut::read in TieOut\n", 'dumpsub found sub fine again' );
+
+# this should print just a usage message
+$d->{usageOnly} = 1;
+$d->dumpvars( 'Fake', 'veryfake' );
+like( $out->read, qr/^String space:/, 'printed usage message fine' );
+delete $d->{usageOnly};
+
+# this should report @INC and %INC
+$d->dumpvars( 'main', 'INC' );
+like( $out->read, qr/\@INC =/, 'dumped variables from a package' );
+
+# this should report nothing
+$DB::signal = 1;
+$d->dumpvars( 'main', 'INC' );
+is( $out->read, '', 'no dump when $DB::signal is set' );
+undef $DB::signal;
+
+is( $d->scalarUsage('12345'), 5, 'scalarUsage reports length correctly' );
+is( $d->arrayUsage( [1, 2, 3], 'a' ), 3, 'arrayUsage reports correct lengths' );
+is( $out->read, "\@a = 3 items (data: 3 bytes)\n", 'arrayUsage message okay' );
+is( $d->hashUsage({ one => 1 }, 'b'), 4, 'hashUsage reports correct lengths' );
+is( $out->read, "\%b = 1 item (keys: 3; values: 1; total: 4 bytes)\n",
+	'hashUsage message okay' );
+is( $d->hashUsage({ one => [ 1, 2, 3 ]}, 'c'), 6, 'complex hash okay' );
+is( $out->read, "\%c = 1 item (keys: 3; values: 3; total: 6 bytes)\n",
+	'hashUsage complex message okay' );
+
+$foo = 'one';
+@foo = ('two');
+%foo = ( three => '123' );
+is( $d->globUsage(\*foo, 'foo'), 14, 'globUsage reports length correctly' );
+like( $out->read, qr/\@foo =.+\%foo =/s, 'globValue message okay' );
+
+# and now, the real show
+$d->dumpValue(undef);
+is( $out->read, "undef\n", 'dumpValue caught undef value okay' );
+$d->dumpValue($foo);
+is( $out->read, "'one'\n", 'dumpValue worked' );
+$d->dumpValue(@foo);
+is( $out->read, "'two'\n", 'dumpValue worked on array' );
+$d->dumpValue(\$foo);
+is( $out->read, "-> 'one'\n", 'dumpValue worked on scalar ref' );
+
+# dumpValues (the rest of these should be caught by unwrap)
+$d->dumpValues(undef);
+is( $out->read, "undef\n", 'dumpValues caught undef value fine' );
+$d->dumpValues(\@foo);
+is( $out->read, "0  0..0  'two'\n", 'dumpValues worked on array ref' );
+$d->dumpValues('one', 'two');
+is( $out->read, "0..1  'one' 'two'\n", 'dumpValues worked on multiple values' );
+
+
+package TieOut;
+use overload '"' => sub { "overloaded!" };
+
+sub TIEHANDLE {
+	my $class = shift;
+	bless(\( my $ref), $class);
+}
+
+sub PRINT {
+	my $self = shift;
+	$$self .= join('', @_);
+}
+
+sub read {
+	my $self = shift;
+	return substr($$self, 0, length($$self), '');
+}