In perl.git, the branch jkeenan/134441-Dumpvalue has been updated <https://perl5.git.perl.org/perl.git/commitdiff/b797640f3b5c7e826051c31b9bb2c42c649123be?hp=0b5142f3dc81471eb97280315a1a4efd55e55d21>
- Log ----------------------------------------------------------------- commit b797640f3b5c7e826051c31b9bb2c42c649123be Author: James E Keenan <[email protected]> Date: Sun Oct 6 12:22:41 2019 -0400 Refactor for debugging commit 28bbe016a9afae16ab3896b0be57383498ee1c9c Author: James E Keenan <[email protected]> Date: Sun Oct 6 11:47:30 2019 -0400 Restore tests accidentally deleted commit 7eb947947f8107605e6b84a8a6f2087d1d426063 Author: James E Keenan <[email protected]> Date: Sun Oct 6 11:43:04 2019 -0400 Update MANIFEST for dist/Dumpvalue/t/rt-134441-dumpvalue.t commit 7dfd105fbfe84d1a93276db09f1381f1b335801e Author: James E Keenan <[email protected]> Date: Sun Oct 6 11:35:32 2019 -0400 Move tests for RT 134441 to separate file Because it is so difficult to tell what the state of the object is in dist/Dumpvalue/t/Dumpvalue.t, it's not wise to add new tests to the end of that file. So I'm moving them to a separate file and working only with the default state of the object. commit 0245b0577d12a9eb1a385c00674f731b552b9b25 Author: James E Keenan <[email protected]> Date: Sun Oct 6 11:10:37 2019 -0400 Uncomment code ----------------------------------------------------------------------- Summary of changes: MANIFEST | 1 + dist/Dumpvalue/t/Dumpvalue.t | 89 ++++++++--------------------- dist/Dumpvalue/t/rt-134441-dumpvalue.t | 100 +++++++++++++++++++++++++++++++++ 3 files changed, 124 insertions(+), 66 deletions(-) create mode 100644 dist/Dumpvalue/t/rt-134441-dumpvalue.t diff --git a/MANIFEST b/MANIFEST index 7bf62d8479..560bc8c460 100644 --- a/MANIFEST +++ b/MANIFEST @@ -3455,6 +3455,7 @@ dist/Devel-SelfStubber/lib/Devel/SelfStubber.pm Generate stubs for SelfLoader.pm dist/Devel-SelfStubber/t/Devel-SelfStubber.t See if Devel::SelfStubber works dist/Dumpvalue/lib/Dumpvalue.pm Screen dump of perl values dist/Dumpvalue/t/Dumpvalue.t See if Dumpvalue works +dist/Dumpvalue/t/rt-134441-dumpvalue.t See if Dumpvalue works dist/encoding-warnings/lib/encoding/warnings.pm warn on implicit encoding conversions dist/encoding-warnings/t/1-warning.t tests for encoding::warnings dist/encoding-warnings/t/2-fatal.t tests for encoding::warnings diff --git a/dist/Dumpvalue/t/Dumpvalue.t b/dist/Dumpvalue/t/Dumpvalue.t index 89af75aa60..7063dd984c 100644 --- a/dist/Dumpvalue/t/Dumpvalue.t +++ b/dist/Dumpvalue/t/Dumpvalue.t @@ -16,31 +16,31 @@ BEGIN { our ( $foo, @bar, %baz ); -use Test::More qw(no_plan); # tests => 88; +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' ); +$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 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' ); +# 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' ); +# 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'; @@ -270,56 +270,13 @@ is( $out->read, "'two'\n", 'dumpValue worked on array' ); $d->dumpValue(\$foo); is( $out->read, "-> 'one'\n", 'dumpValue worked on scalar ref' ); -# RT 134441 -@foobar = ('foo', 'bar'); -$d->dumpValue([@foobar]); -$x = $out->read; -is( $x, "0..1 'foo' 'bar'\n", 'dumpValue worked on array ref' ); -$d->dumpValues(@foobar); -$y = $out->read; -is( $y, "0..1 'foo' 'bar'\n", 'dumpValues worked on array' ); -is( $y, $x, - "dumpValues called on array returns same as dumpValue on array ref"); - -@foobar = (undef, 'bar'); -$d->dumpValue([@foobar]); -is( $out->read, "0..1 undef 'bar'\n", - 'dumpValue worked on array ref, first element undefined' ); -$d->dumpValues(@foobar); -is( $out->read, "0..1 undef 'bar'\n", - 'dumpValues worked on array, first element undefined' ); - -@foobar = ('bar', undef); -$d->dumpValue([@foobar]); -is( $out->read, "0..1 'bar' undef\n", - 'dumpValue worked on array ref, last element undefined' ); -$d->dumpValues(@foobar); -is( $out->read, "0..1 'bar' undef'bar'\n", - 'dumpValues worked on array, last element undefined' ); - -#@foobar = ('', 'bar'); -#$d->dumpValue([@foobar]); -#is( $out->read, "0..1 '' 'bar'\n", -# 'dumpValue worked on array ref, first element empty string' ); -#$d->dumpValues(@foobar); -#is( $out->read, "0..1 '' 'bar'\n", -# 'dumpValues worked on array, first element empty string' ); -# -#@foobar = ('bar', ''); -#$d->dumpValue([@foobar]); -#is( $out->read, "0..1 'bar' ''\n", -# 'dumpValue worked on array ref, last element empty string' ); -#$d->dumpValues(@foobar); -#is( $out->read, "0..1 'bar' ''\n", -# 'dumpValues worked on array, last element empty string' ); -# -## 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' ); +# 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; diff --git a/dist/Dumpvalue/t/rt-134441-dumpvalue.t b/dist/Dumpvalue/t/rt-134441-dumpvalue.t new file mode 100644 index 0000000000..14fbe5d46a --- /dev/null +++ b/dist/Dumpvalue/t/rt-134441-dumpvalue.t @@ -0,0 +1,100 @@ +BEGIN { + require Config; + if (($Config::Config{'extensions'} !~ m!\bList/Util\b!) ){ + print "1..0 # Skip -- Perl configured without List::Util module\n"; + exit 0; + } + + # `make test` in the CPAN version of this module runs us with -w, but + # Dumpvalue.pm relies on all sorts of things that can cause warnings. I + # don't think that's worth fixing, so we just turn off all warnings + # during testing. + $^W = 0; +} + +use Test::More qw(no_plan); # tests => 16; + +use_ok( 'Dumpvalue' ); + +my $d; +ok( $d = Dumpvalue->new(), 'create a new Dumpvalue object' ); + +# RT 134441 +my $out = tie *OUT, 'TieOut'; +select(OUT); + +my (@foobar, $x, $y); + +@foobar = ('foo', 'bar'); +$d->dumpValue([@foobar]); +$x = $out->read; +is( $x, "0 'foo'\n1 'bar'\n", 'dumpValue worked on array ref' ); +$d->dumpValues(@foobar); +$y = $out->read; +is( $y, "0 'foo'\n1 'bar'\n", 'dumpValues worked on array' ); +is( $y, $x, + "dumpValues called on array returns same as dumpValue on array ref"); + +@foobar = (undef, 'bar'); +$d->dumpValue([@foobar]); +#is( $out->read, "0..1 undef 'bar'\n", +is( $out->read, "0 undef\n1 'bar'\n", + 'dumpValue worked on array ref, first element undefined' ); +$d->dumpValues(@foobar); +#is( $out->read, "0..1 undef 'bar'\n", +$y = $out->read; +#is( $out->read, "0 undef\n1 'bar'\n", +is( $y, "0 undef\n1 'bar'\n", + 'dumpValues worked on array, first element undefined' ); + +#@foobar = ('bar', undef); +#$d->dumpValue([@foobar]); +##is( $out->read, "0..1 'bar' undef\n", +#is( $out->read, "0 'bar'\n1 undef\n", +# 'dumpValue worked on array ref, last element undefined' ); +#$d->dumpValues(@foobar); +##is( $out->read, "0..1 'bar' undef'bar'\n", +#is( $out->read, "0 'bar'\n1 undef 'bar'\n", +# 'dumpValues worked on array, last element undefined' ); +# +#@foobar = ('', 'bar'); +#$d->dumpValue([@foobar]); +#is( $out->read, "0..1 '' 'bar'\n", +# 'dumpValue worked on array ref, first element empty string' ); +#$d->dumpValues(@foobar); +#is( $out->read, "0..1 '' 'bar'\n", +# 'dumpValues worked on array, first element empty string' ); +# +#@foobar = ('bar', ''); +#$d->dumpValue([@foobar]); +#is( $out->read, "0..1 'bar' ''\n", +# 'dumpValue worked on array ref, last element empty string' ); +#$d->dumpValues(@foobar); +#is( $out->read, "0..1 'bar' ''\n", +# 'dumpValues worked on array, last element empty string' ); +# +## 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), ''); +} -- Perl5 Master Repository
