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 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