lib/dumpvar.t

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