| 1 | #!./perl -- -*- mode: cperl; cperl-indent-level: 4 -*- |
| 2 | |
| 3 | BEGIN { |
| 4 | chdir 't' if -d 't'; |
| 5 | @INC = '../lib'; |
| 6 | require Config; |
| 7 | if (($Config::Config{'extensions'} !~ m!\bList/Util\b!) ){ |
| 8 | print "1..0 # Skip -- Perl configured without List::Util module\n"; |
| 9 | exit 0; |
| 10 | } |
| 11 | } |
| 12 | |
| 13 | use strict; |
| 14 | |
| 15 | $|=1; |
| 16 | |
| 17 | my @prgs; |
| 18 | { |
| 19 | local $/; |
| 20 | @prgs = split "########\n", <DATA>; |
| 21 | close DATA; |
| 22 | } |
| 23 | |
| 24 | use Test::More; |
| 25 | |
| 26 | plan tests => scalar @prgs; |
| 27 | |
| 28 | require "dumpvar.pl"; |
| 29 | |
| 30 | sub unctrl { print dumpvar::unctrl($_[0]), "\n" } |
| 31 | sub uniescape { print dumpvar::uniescape($_[0]), "\n" } |
| 32 | sub stringify { print dumpvar::stringify($_[0]), "\n" } |
| 33 | sub dumpvalue { |
| 34 | # Call main::dumpValue exactly as the perl5db.pl calls it. |
| 35 | local $\ = ''; |
| 36 | local $, = ''; |
| 37 | local $" = ' '; |
| 38 | my @params = @_; |
| 39 | &main::dumpValue(\@params,-1); |
| 40 | } |
| 41 | |
| 42 | package Foo; |
| 43 | |
| 44 | sub new { my $class = shift; bless [ @_ ], $class } |
| 45 | |
| 46 | package Bar; |
| 47 | |
| 48 | sub new { my $class = shift; bless [ @_ ], $class } |
| 49 | |
| 50 | use overload '""' => sub { "Bar<@{$_[0]}>" }; |
| 51 | |
| 52 | package main; |
| 53 | |
| 54 | my $foo = Foo->new(1..5); |
| 55 | my $bar = Bar->new(1..5); |
| 56 | |
| 57 | for (@prgs) { |
| 58 | my($prog, $expected) = split(/\nEXPECT\n?/, $_); |
| 59 | # TODO: dumpvar::stringify() is controlled by a pile of package |
| 60 | # dumpvar variables: $printUndef, $unctrl, $quoteHighBit, $bareStringify, |
| 61 | # and so forth. We need to test with various settings of those. |
| 62 | my $out = tie *STDOUT, 'TieOut'; |
| 63 | eval $prog; |
| 64 | my $ERR = $@; |
| 65 | untie $out; |
| 66 | if ($ERR) { |
| 67 | ok(0, "$prog - $ERR"); |
| 68 | } else { |
| 69 | if ($expected =~ m:^/:) { |
| 70 | like($$out, $expected, $prog); |
| 71 | } else { |
| 72 | is($$out, $expected, $prog); |
| 73 | } |
| 74 | } |
| 75 | } |
| 76 | |
| 77 | package TieOut; |
| 78 | |
| 79 | sub TIEHANDLE { |
| 80 | bless( \(my $self), $_[0] ); |
| 81 | } |
| 82 | |
| 83 | sub PRINT { |
| 84 | my $self = shift; |
| 85 | $$self .= join('', @_); |
| 86 | } |
| 87 | |
| 88 | sub read { |
| 89 | my $self = shift; |
| 90 | substr( $$self, 0, length($$self), '' ); |
| 91 | } |
| 92 | |
| 93 | __END__ |
| 94 | unctrl("A"); |
| 95 | EXPECT |
| 96 | A |
| 97 | ######## |
| 98 | unctrl("\cA"); |
| 99 | EXPECT |
| 100 | ^A |
| 101 | ######## |
| 102 | uniescape("A"); |
| 103 | EXPECT |
| 104 | A |
| 105 | ######## |
| 106 | uniescape("\x{100}"); |
| 107 | EXPECT |
| 108 | \x{0100} |
| 109 | ######## |
| 110 | stringify(undef); |
| 111 | EXPECT |
| 112 | undef |
| 113 | ######## |
| 114 | stringify("foo"); |
| 115 | EXPECT |
| 116 | 'foo' |
| 117 | ######## |
| 118 | stringify("\cA"); |
| 119 | EXPECT |
| 120 | "\cA" |
| 121 | ######## |
| 122 | stringify(*a); |
| 123 | EXPECT |
| 124 | *main::a |
| 125 | ######## |
| 126 | stringify(\undef); |
| 127 | EXPECT |
| 128 | /^'SCALAR\(0x[0-9a-f]+\)'$/i |
| 129 | ######## |
| 130 | stringify([]); |
| 131 | EXPECT |
| 132 | /^'ARRAY\(0x[0-9a-f]+\)'$/i |
| 133 | ######## |
| 134 | stringify({}); |
| 135 | EXPECT |
| 136 | /^'HASH\(0x[0-9a-f]+\)'$/i |
| 137 | ######## |
| 138 | stringify(sub{}); |
| 139 | EXPECT |
| 140 | /^'CODE\(0x[0-9a-f]+\)'$/i |
| 141 | ######## |
| 142 | stringify(\*a); |
| 143 | EXPECT |
| 144 | /^'GLOB\(0x[0-9a-f]+\)'$/i |
| 145 | ######## |
| 146 | stringify($foo); |
| 147 | EXPECT |
| 148 | /^'Foo=ARRAY\(0x[0-9a-f]+\)'$/i |
| 149 | ######## |
| 150 | stringify($bar); |
| 151 | EXPECT |
| 152 | /^'Bar=ARRAY\(0x[0-9a-f]+\)'$/i |
| 153 | ######## |
| 154 | dumpValue(undef); |
| 155 | EXPECT |
| 156 | undef |
| 157 | ######## |
| 158 | dumpValue(1); |
| 159 | EXPECT |
| 160 | 1 |
| 161 | ######## |
| 162 | dumpValue("\cA"); |
| 163 | EXPECT |
| 164 | "\cA" |
| 165 | ######## |
| 166 | dumpValue("\x{100}"); |
| 167 | EXPECT |
| 168 | '\x{0100}' |
| 169 | ######## |
| 170 | dumpValue("1\n2\n3"); |
| 171 | EXPECT |
| 172 | '1 |
| 173 | 2 |
| 174 | 3' |
| 175 | ######## |
| 176 | dumpValue([1..3],1); |
| 177 | EXPECT |
| 178 | 0 1 |
| 179 | 1 2 |
| 180 | 2 3 |
| 181 | ######## |
| 182 | dumpValue([1..3]); |
| 183 | EXPECT |
| 184 | 0 1 |
| 185 | 1 2 |
| 186 | 2 3 |
| 187 | ######## |
| 188 | dumpValue({1..4},1); |
| 189 | EXPECT |
| 190 | 1 => 2 |
| 191 | 3 => 4 |
| 192 | ######## |
| 193 | dumpValue({1..4}); |
| 194 | EXPECT |
| 195 | 1 => 2 |
| 196 | 3 => 4 |
| 197 | ######## |
| 198 | dumpValue($foo,1); |
| 199 | EXPECT |
| 200 | 0 1 |
| 201 | 1 2 |
| 202 | 2 3 |
| 203 | 3 4 |
| 204 | 4 5 |
| 205 | ######## |
| 206 | dumpValue($foo); |
| 207 | EXPECT |
| 208 | 0 1 |
| 209 | 1 2 |
| 210 | 2 3 |
| 211 | 3 4 |
| 212 | 4 5 |
| 213 | ######## |
| 214 | dumpValue($bar,1); |
| 215 | EXPECT |
| 216 | 0 1 |
| 217 | 1 2 |
| 218 | 2 3 |
| 219 | 3 4 |
| 220 | 4 5 |
| 221 | ######## |
| 222 | dumpValue($bar); |
| 223 | EXPECT |
| 224 | 0 1 |
| 225 | 1 2 |
| 226 | 2 3 |
| 227 | 3 4 |
| 228 | 4 5 |
| 229 | ######## |
| 230 | dumpvalue("a"); |
| 231 | EXPECT |
| 232 | 0 'a' |
| 233 | ######## |
| 234 | dumpvalue("\cA"); |
| 235 | EXPECT |
| 236 | 0 "\cA" |
| 237 | ######## |
| 238 | dumpvalue("\x{100}"); |
| 239 | EXPECT |
| 240 | 0 '\x{0100}' |
| 241 | ######## |
| 242 | dumpvalue(undef); |
| 243 | EXPECT |
| 244 | 0 undef |
| 245 | ######## |
| 246 | dumpvalue("foo"); |
| 247 | EXPECT |
| 248 | 0 'foo' |
| 249 | ######## |
| 250 | dumpvalue(\undef); |
| 251 | EXPECT |
| 252 | /0 SCALAR\(0x[0-9a-f]+\)\n -> undef\n/i |
| 253 | ######## |
| 254 | dumpvalue(\\undef); |
| 255 | EXPECT |
| 256 | /0 REF\(0x[0-9a-f]+\)\n -> SCALAR\(0x[0-9a-f]+\)\n -> undef\n/i |
| 257 | ######## |
| 258 | dumpvalue([]); |
| 259 | EXPECT |
| 260 | /0 ARRAY\(0x[0-9a-f]+\)\n empty array/i |
| 261 | ######## |
| 262 | dumpvalue({}); |
| 263 | EXPECT |
| 264 | /0 HASH\(0x[0-9a-f]+\)\n\s+empty hash/i |
| 265 | ######## |
| 266 | dumpvalue(sub{}); |
| 267 | EXPECT |
| 268 | /0 CODE\(0x[0-9a-f]+\)\n -> &CODE\(0x[0-9a-f]+\) in /i |
| 269 | ######## |
| 270 | dumpvalue(\*a); |
| 271 | EXPECT |
| 272 | /0 GLOB\(0x[0-9a-f]+\)\n -> \*main::a\n/i |
| 273 | ######## |
| 274 | dumpvalue($foo); |
| 275 | EXPECT |
| 276 | /0 Foo=ARRAY\(0x[0-9a-f]+\)\n 0 1\n 1 2\n 2 3\n 3 4\n 4 5\n/i |
| 277 | ######## |
| 278 | dumpvalue($bar); |
| 279 | EXPECT |
| 280 | /0 Bar=ARRAY\(0x[0-9a-f]+\)\n 0 1\n 1 2\n 2 3\n 3 4\n 4 5\n/i |
| 281 | ######## |
| 282 | dumpvalue("1\n2\n3") |
| 283 | EXPECT |
| 284 | /0 '1\n2\n3'\n/i |
| 285 | ######## |
| 286 | dumpvalue([1..4]); |
| 287 | EXPECT |
| 288 | /0 ARRAY\(0x[0-9a-f]+\)\n 0 1\n 1 2\n 2 3\n 3 4\n/i |
| 289 | ######## |
| 290 | dumpvalue({1..4}); |
| 291 | EXPECT |
| 292 | /0 HASH\(0x[0-9a-f]+\)\n 1 => 2\n 3 => 4\n/i |
| 293 | ######## |
| 294 | dumpvalue({1=>2,3=>4}); |
| 295 | EXPECT |
| 296 | /0 HASH\(0x[0-9a-f]+\)\n 1 => 2\n 3 => 4\n/i |
| 297 | ######## |
| 298 | dumpvalue({a=>1,b=>2}); |
| 299 | EXPECT |
| 300 | /0 HASH\(0x[0-9a-f]+\)\n 'a' => 1\n 'b' => 2\n/i |
| 301 | ######## |
| 302 | dumpvalue([{a=>[1,2,3],b=>{c=>1,d=>2}},{e=>{f=>1,g=>2},h=>[qw(i j k)]}]); |
| 303 | EXPECT |
| 304 | /0 ARRAY\(0x[0-9a-f]+\)\n 0 HASH\(0x[0-9a-f]+\)\n 'a' => ARRAY\(0x[0-9a-f]+\)\n 0 1\n 1 2\n 2 3\n 'b' => HASH\(0x[0-9a-f]+\)\n 'c' => 1\n 'd' => 2\n 1 HASH\(0x[0-9a-f]+\)\n 'e' => HASH\(0x[0-9a-f]+\)\n 'f' => 1\n 'g' => 2\n 'h' => ARRAY\(0x[0-9a-f]+\)\n 0 'i'\n 1 'j'\n 2 'k'/i |
| 305 | ######## |
| 306 | dumpvalue({reverse map {$_=>1} sort qw(the quick brown fox)}) |
| 307 | EXPECT |
| 308 | /0 HASH\(0x[0-9a-f]+\)\n 1 => 'brown'\n/i |
| 309 | ######## |
| 310 | my @x=qw(a b c); dumpvalue(\@x); |
| 311 | EXPECT |
| 312 | /0 ARRAY\(0x[0-9a-f]+\)\n 0 'a'\n 1 'b'\n 2 'c'\n/i |
| 313 | ######## |
| 314 | my %x=(a=>1, b=>2); dumpvalue(\%x); |
| 315 | EXPECT |
| 316 | /0 HASH\(0x[0-9a-f]+\)\n 'a' => 1\n 'b' => 2\n/i |