lib/dumpvar.t

   1 #!./perl -- -*- mode: cperl; cperl-indent-level: 4 -*-
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     @INC = '../lib';
   6     unless (find PerlIO::Layer 'perlio') { # no perlio, no PerlIO::scalar.
   7         print "1..0 # Skip: not perlio\n";
   8         exit 0;
   9     }
  10 }
  11
  12 use strict;
  13
  14 $|=1;
  15
  16 my @prgs;
  17 {
  18     local $/;
  19     @prgs = split "########\n", <DATA>;
  20     close DATA;
  21 }
  22
  23 use Test::More;
  24
  25 plan tests => scalar @prgs;
  26
  27 require "dumpvar.pl";
  28
  29 sub unctrl    { print dumpvar::unctrl($_[0]), "\n" }
  30 sub uniescape { print dumpvar::uniescape($_[0]), "\n" }
  31 sub stringify { print dumpvar::stringify($_[0]), "\n" }
  32
  33 package Foo;
  34
  35 sub new { my $class = shift; bless [ @_ ], $class }
  36
  37 package Bar;
  38
  39 sub new { my $class = shift; bless [ @_ ], $class }
  40
  41 use overload '""' => sub { "Bar<@{$_[0]}>" };
  42
  43 package main;
  44
  45 my $foo = Foo->new(1..5);
  46 my $bar = Bar->new(1..5);
  47
  48 for (@prgs) {
  49     my($prog, $expected) = split(/\nEXPECT\n?/, $_);
  50     # TODO: dumpvar::stringify() is controlled by a pile of package
  51     # dumpvar variables: $printUndef, $unctrl, $quoteHighBit, $bareStringify,
  52     # and so forth.  We need to test with various settings of those.
  53     my $out = tie *STDOUT, 'TieOut';
  54     eval $prog;
  55     my $ERR = $@;
  56     untie $out;
  57     if ($ERR) {
  58         ok(0, "$prog - $ERR");
  59     } else {
  60         if ($expected =~ m:^/:) {
  61             like($$out, $expected, $prog);
  62         } else {
  63             is($$out, $expected, $prog);
  64         }
  65     }
  66 }
  67
  68 package TieOut;
  69
  70 sub TIEHANDLE {
  71     bless( \(my $self), $_[0] );
  72 }
  73
  74 sub PRINT {
  75     my $self = shift;
  76     $$self .= join('', @_);
  77 }
  78
  79 sub read {
  80     my $self = shift;
  81     substr( $$self, 0, length($$self), '' );
  82 }
  83
  84 __END__
  85 unctrl("A");
  86 EXPECT
  87 A
  88 ########
  89 unctrl("\cA");
  90 EXPECT
  91 ^A
  92 ########
  93 uniescape("A");
  94 EXPECT
  95 A
  96 ########
  97 uniescape("\x{100}");
  98 EXPECT
  99 \x{0100}
 100 ########
 101 stringify(undef);
 102 EXPECT
 103 undef
 104 ########
 105 stringify("foo");
 106 EXPECT
 107 'foo'
 108 ########
 109 stringify("\cA");
 110 EXPECT
 111 "\cA"
 112 ########
 113 stringify(*a);
 114 EXPECT
 115 *main::a
 116 ########
 117 stringify(\undef);
 118 EXPECT
 119 /^'SCALAR\(0x[0-9a-f]+\)'$/i
 120 ########
 121 stringify([]);
 122 EXPECT
 123 /^'ARRAY\(0x[0-9a-f]+\)'$/i
 124 ########
 125 stringify({});
 126 EXPECT
 127 /^'HASH\(0x[0-9a-f]+\)'$/i
 128 ########
 129 stringify(sub{});
 130 EXPECT
 131 /^'CODE\(0x[0-9a-f]+\)'$/i
 132 ########
 133 stringify(\*a);
 134 EXPECT
 135 /^'GLOB\(0x[0-9a-f]+\)'$/i
 136 ########
 137 stringify($foo);
 138 EXPECT
 139 /^'Foo=ARRAY\(0x[0-9a-f]+\)'$/i
 140 ########
 141 stringify($bar);
 142 EXPECT
 143 /^'Bar=ARRAY\(0x[0-9a-f]+\)'$/i
 144 ########
 145 dumpValue(undef);
 146 EXPECT
 147 undef
 148 ########
 149 dumpValue(1);
 150 EXPECT
 151 1
 152 ########
 153 dumpValue("\cA");
 154 EXPECT
 155 "\cA"
 156 ########
 157 dumpValue("\x{100}");
 158 EXPECT
 159 '\x{0100}'
 160 ########
 161 dumpValue("1\n2\n3");
 162 EXPECT
 163 '1
 164 2
 165 3'
 166 ########
 167 dumpValue([1..3],1);
 168 EXPECT
 169 0  1
 170 1  2
 171 2  3
 172 ########
 173 dumpValue({1..4},1);
 174 EXPECT
 175 1 => 2
 176 3 => 4
 177 ########
 178 dumpValue($foo,1);
 179 EXPECT
 180 0  1
 181 1  2
 182 2  3
 183 3  4
 184 4  5
 185 ########
 186 dumpValue($bar,1);
 187 EXPECT
 188 0  1
 189 1  2
 190 2  3
 191 3  4
 192 4  5
 193 ########