lib/dumpvar.t

   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 Tyre;
  53
  54 sub TIESCALAR{bless[]}
  55 # other methods intentionally omitted
  56
  57 package Kerb;
  58
  59 sub TIEHASH{bless{}}
  60 # other methods intentionally omitted
  61
  62 package main;
  63
  64 my $foo = Foo->new(1..5);
  65 my $bar = Bar->new(1..5);
  66
  67 for (@prgs) {
  68     my($prog, $expected) = split(/\nEXPECT\n?/, $_);
  69     # TODO: dumpvar::stringify() is controlled by a pile of package
  70     # dumpvar variables: $printUndef, $unctrl, $quoteHighBit, $bareStringify,
  71     # and so forth.  We need to test with various settings of those.
  72     my $out = tie *STDOUT, 'TieOut';
  73     eval $prog;
  74     my $ERR = $@;
  75     untie $out;
  76     if ($ERR) {
  77         ok(0, "$prog - $ERR");
  78     } else {
  79         if ($expected =~ m:^/:) {
  80             like($$out, $expected, $prog);
  81         } else {
  82             is($$out, $expected, $prog);
  83         }
  84     }
  85 }
  86
  87 package TieOut;
  88
  89 sub TIEHANDLE {
  90     bless( \(my $self), $_[0] );
  91 }
  92
  93 sub PRINT {
  94     my $self = shift;
  95     $$self .= join('', @_);
  96 }
  97
  98 sub read {
  99     my $self = shift;
 100     substr( $$self, 0, length($$self), '' );
 101 }
 102
 103 __END__
 104 unctrl("A");
 105 EXPECT
 106 A
 107 ########
 108 unctrl("\cA");
 109 EXPECT
 110 ^A
 111 ########
 112 uniescape("A");
 113 EXPECT
 114 A
 115 ########
 116 uniescape("\x{100}");
 117 EXPECT
 118 \x{0100}
 119 ########
 120 stringify(undef);
 121 EXPECT
 122 undef
 123 ########
 124 stringify("foo");
 125 EXPECT
 126 'foo'
 127 ########
 128 stringify("\cA");
 129 EXPECT
 130 "\cA"
 131 ########
 132 stringify(*a);
 133 EXPECT
 134 *main::a
 135 ########
 136 stringify(\undef);
 137 EXPECT
 138 /^'SCALAR\(0x[0-9a-f]+\)'$/i
 139 ########
 140 stringify([]);
 141 EXPECT
 142 /^'ARRAY\(0x[0-9a-f]+\)'$/i
 143 ########
 144 stringify({});
 145 EXPECT
 146 /^'HASH\(0x[0-9a-f]+\)'$/i
 147 ########
 148 stringify(sub{});
 149 EXPECT
 150 /^'CODE\(0x[0-9a-f]+\)'$/i
 151 ########
 152 stringify(\*a);
 153 EXPECT
 154 /^'GLOB\(0x[0-9a-f]+\)'$/i
 155 ########
 156 stringify($foo);
 157 EXPECT
 158 /^'Foo=ARRAY\(0x[0-9a-f]+\)'$/i
 159 ########
 160 stringify($bar);
 161 EXPECT
 162 /^'Bar=ARRAY\(0x[0-9a-f]+\)'$/i
 163 ########
 164 dumpValue(undef);
 165 EXPECT
 166 undef
 167 ########
 168 dumpValue(1);
 169 EXPECT
 170 1
 171 ########
 172 dumpValue("\cA");
 173 EXPECT
 174 "\cA"
 175 ########
 176 dumpValue("\x{100}");
 177 EXPECT
 178 '\x{0100}'
 179 ########
 180 dumpValue("1\n2\n3");
 181 EXPECT
 182 '1
 183 2
 184 3'
 185 ########
 186 dumpValue([1..3],1);
 187 EXPECT
 188 0  1
 189 1  2
 190 2  3
 191 ########
 192 dumpValue([1..3]);
 193 EXPECT
 194 0  1
 195 1  2
 196 2  3
 197 ########
 198 dumpValue({1..4},1);
 199 EXPECT
 200 1 => 2
 201 3 => 4
 202 ########
 203 dumpValue({1..4});
 204 EXPECT
 205 1 => 2
 206 3 => 4
 207 ########
 208 dumpValue($foo,1);
 209 EXPECT
 210 0  1
 211 1  2
 212 2  3
 213 3  4
 214 4  5
 215 ########
 216 dumpValue($foo);
 217 EXPECT
 218 0  1
 219 1  2
 220 2  3
 221 3  4
 222 4  5
 223 ########
 224 dumpValue($bar,1);
 225 EXPECT
 226 0  1
 227 1  2
 228 2  3
 229 3  4
 230 4  5
 231 ########
 232 dumpValue($bar);
 233 EXPECT
 234 0  1
 235 1  2
 236 2  3
 237 3  4
 238 4  5
 239 ########
 240 dumpvalue("a");
 241 EXPECT
 242 0  'a'
 243 ########
 244 dumpvalue("\cA");
 245 EXPECT
 246 0  "\cA"
 247 ########
 248 dumpvalue("\x{100}");
 249 EXPECT
 250 0  '\x{0100}'
 251 ########
 252 dumpvalue(undef);
 253 EXPECT
 254 0  undef
 255 ########
 256 dumpvalue("foo");
 257 EXPECT
 258 0  'foo'
 259 ########
 260 dumpvalue(\undef);
 261 EXPECT
 262 /0  SCALAR\(0x[0-9a-f]+\)\n   -> undef\n/i
 263 ########
 264 dumpvalue(\\undef);
 265 EXPECT
 266 /0  REF\(0x[0-9a-f]+\)\n   -> SCALAR\(0x[0-9a-f]+\)\n         -> undef\n/i
 267 ########
 268 dumpvalue([]);
 269 EXPECT
 270 /0  ARRAY\(0x[0-9a-f]+\)\n     empty array/i
 271 ########
 272 dumpvalue({});
 273 EXPECT
 274 /0  HASH\(0x[0-9a-f]+\)\n\s+empty hash/i
 275 ########
 276 dumpvalue(sub{});
 277 EXPECT
 278 /0  CODE\(0x[0-9a-f]+\)\n   -> &CODE\(0x[0-9a-f]+\) in /i
 279 ########
 280 dumpvalue(\*a);
 281 EXPECT
 282 /0  GLOB\(0x[0-9a-f]+\)\n   -> \*main::a\n/i
 283 ########
 284 dumpvalue($foo);
 285 EXPECT
 286 /0  Foo=ARRAY\(0x[0-9a-f]+\)\n   0  1\n   1  2\n   2  3\n   3  4\n   4  5\n/i
 287 ########
 288 dumpvalue($bar);
 289 EXPECT
 290 /0  Bar=ARRAY\(0x[0-9a-f]+\)\n   0  1\n   1  2\n   2  3\n   3  4\n   4  5\n/i
 291 ########
 292 dumpvalue("1\n2\n3")
 293 EXPECT
 294 /0  '1\n2\n3'\n/i
 295 ########
 296 dumpvalue([1..4]);
 297 EXPECT
 298 /0  ARRAY\(0x[0-9a-f]+\)\n   0  1\n   1  2\n   2  3\n   3  4\n/i
 299 ########
 300 dumpvalue({1..4});
 301 EXPECT
 302 /0  HASH\(0x[0-9a-f]+\)\n   1 => 2\n   3 => 4\n/i
 303 ########
 304 dumpvalue({1=>2,3=>4});
 305 EXPECT
 306 /0  HASH\(0x[0-9a-f]+\)\n   1 => 2\n   3 => 4\n/i
 307 ########
 308 dumpvalue({a=>1,b=>2});
 309 EXPECT
 310 /0  HASH\(0x[0-9a-f]+\)\n   'a' => 1\n   'b' => 2\n/i
 311 ########
 312 dumpvalue([{a=>[1,2,3],b=>{c=>1,d=>2}},{e=>{f=>1,g=>2},h=>[qw(i j k)]}]);
 313 EXPECT
 314 /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
 315 ########
 316 dumpvalue({reverse map {$_=>1} sort qw(the quick brown fox)})
 317 EXPECT
 318 /0  HASH\(0x[0-9a-f]+\)\n   1 => 'brown'\n/i
 319 ########
 320 my @x=qw(a b c); dumpvalue(\@x);
 321 EXPECT
 322 /0  ARRAY\(0x[0-9a-f]+\)\n   0  'a'\n   1  'b'\n   2  'c'\n/i
 323 ########
 324 my %x=(a=>1, b=>2); dumpvalue(\%x);
 325 EXPECT
 326 /0  HASH\(0x[0-9a-f]+\)\n   'a' => 1\n   'b' => 2\n/i
 327 ########
 328 dumpvalue(bless[1,2,3,4],"a=b=c");
 329 EXPECT
 330 /0  a=b=c=ARRAY\(0x[0-9a-f]+\)\n   0  1\n   1  2\n   2  3\n   3  4\n/i
 331 ########
 332 local *_; tie $_, 'Tyre'; stringify('');
 333 EXPECT
 334 ''
 335 ########
 336 local *_; tie $_, 'Tyre'; unctrl('abc');
 337 EXPECT
 338 abc
 339 ########
 340 tie my %h, 'Kerb'; my $v = { a => 1, b => \%h, c => 2 }; dumpvalue($v);
 341 EXPECT
 342 /'a' => 1\n.+Can't locate object method.+'c' => 2/s