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