t/op/tie.t

   1 #!./perl
   2
   3 # Add new tests to the end with format:
   4 # ########
   5 #
   6 # # test description
   7 # Test code
   8 # EXPECT
   9 # Warn or die msgs (if any) at - line 1234
  10 #
  11
  12 chdir 't' if -d 't';
  13 @INC = '../lib';
  14 $ENV{PERL5LIB} = "../lib";
  15
  16 $|=1;
  17
  18 undef $/;
  19 @prgs = split /^########\n/m, <DATA>;
  20
  21 require './test.pl';
  22 plan(tests => scalar @prgs);
  23 for (@prgs){
  24     ++$i;
  25     my($prog,$expected) = split(/\nEXPECT\n/, $_, 2);
  26     print("not ok $i # bad test format\n"), next
  27         unless defined $expected;
  28     my ($testname) = $prog =~ /^# (.*)\n/m;
  29     $testname ||= '';
  30     $results =~ s/\n+$//;
  31     $expected =~ s/\n+$//;
  32
  33     fresh_perl_is($prog, $expected, {}, $testname);
  34 }
  35
  36 __END__
  37
  38 # standard behaviour, without any extra references
  39 use Tie::Hash ;
  40 tie %h, Tie::StdHash;
  41 untie %h;
  42 EXPECT
  43 ########
  44
  45 # standard behaviour, without any extra references
  46 use Tie::Hash ;
  47 {package Tie::HashUntie;
  48  use base 'Tie::StdHash';
  49  sub UNTIE
  50   {
  51    warn "Untied\n";
  52   }
  53 }
  54 tie %h, Tie::HashUntie;
  55 untie %h;
  56 EXPECT
  57 Untied
  58 ########
  59
  60 # standard behaviour, with 1 extra reference
  61 use Tie::Hash ;
  62 $a = tie %h, Tie::StdHash;
  63 untie %h;
  64 EXPECT
  65 ########
  66
  67 # standard behaviour, with 1 extra reference via tied
  68 use Tie::Hash ;
  69 tie %h, Tie::StdHash;
  70 $a = tied %h;
  71 untie %h;
  72 EXPECT
  73 ########
  74
  75 # standard behaviour, with 1 extra reference which is destroyed
  76 use Tie::Hash ;
  77 $a = tie %h, Tie::StdHash;
  78 $a = 0 ;
  79 untie %h;
  80 EXPECT
  81 ########
  82
  83 # standard behaviour, with 1 extra reference via tied which is destroyed
  84 use Tie::Hash ;
  85 tie %h, Tie::StdHash;
  86 $a = tied %h;
  87 $a = 0 ;
  88 untie %h;
  89 EXPECT
  90 ########
  91
  92 # strict behaviour, without any extra references
  93 use warnings 'untie';
  94 use Tie::Hash ;
  95 tie %h, Tie::StdHash;
  96 untie %h;
  97 EXPECT
  98 ########
  99
 100 # strict behaviour, with 1 extra references generating an error
 101 use warnings 'untie';
 102 use Tie::Hash ;
 103 $a = tie %h, Tie::StdHash;
 104 untie %h;
 105 EXPECT
 106 untie attempted while 1 inner references still exist at - line 6.
 107 ########
 108
 109 # strict behaviour, with 1 extra references via tied generating an error
 110 use warnings 'untie';
 111 use Tie::Hash ;
 112 tie %h, Tie::StdHash;
 113 $a = tied %h;
 114 untie %h;
 115 EXPECT
 116 untie attempted while 1 inner references still exist at - line 7.
 117 ########
 118
 119 # strict behaviour, with 1 extra references which are destroyed
 120 use warnings 'untie';
 121 use Tie::Hash ;
 122 $a = tie %h, Tie::StdHash;
 123 $a = 0 ;
 124 untie %h;
 125 EXPECT
 126 ########
 127
 128 # strict behaviour, with extra 1 references via tied which are destroyed
 129 use warnings 'untie';
 130 use Tie::Hash ;
 131 tie %h, Tie::StdHash;
 132 $a = tied %h;
 133 $a = 0 ;
 134 untie %h;
 135 EXPECT
 136 ########
 137
 138 # strict error behaviour, with 2 extra references
 139 use warnings 'untie';
 140 use Tie::Hash ;
 141 $a = tie %h, Tie::StdHash;
 142 $b = tied %h ;
 143 untie %h;
 144 EXPECT
 145 untie attempted while 2 inner references still exist at - line 7.
 146 ########
 147
 148 # strict behaviour, check scope of strictness.
 149 no warnings 'untie';
 150 use Tie::Hash ;
 151 $A = tie %H, Tie::StdHash;
 152 $C = $B = tied %H ;
 153 {
 154     use warnings 'untie';
 155     use Tie::Hash ;
 156     tie %h, Tie::StdHash;
 157     untie %h;
 158 }
 159 untie %H;
 160 EXPECT
 161 ########
 162
 163 # Forbidden aggregate self-ties
 164 sub Self::TIEHASH { bless $_[1], $_[0] }
 165 {
 166     my %c;
 167     tie %c, 'Self', \%c;
 168 }
 169 EXPECT
 170 Self-ties of arrays and hashes are not supported at - line 6.
 171 ########
 172
 173 # Allowed scalar self-ties
 174 my $destroyed = 0;
 175 sub Self::TIESCALAR { bless $_[1], $_[0] }
 176 sub Self::DESTROY   { $destroyed = 1; }
 177 {
 178     my $c = 42;
 179     tie $c, 'Self', \$c;
 180 }
 181 die "self-tied scalar not DESTROYd" unless $destroyed == 1;
 182 EXPECT
 183 ########
 184
 185 # Allowed glob self-ties
 186 my $destroyed = 0;
 187 sub Self2::TIEHANDLE { bless $_[1], $_[0] }
 188 sub Self2::DESTROY   { $destroyed = 1; }
 189 {
 190     use Symbol;
 191     my $c = gensym;
 192     tie *$c, 'Self2', $c;
 193 }
 194 die "self-tied glob not DESTROYd" unless $destroyed == 1;
 195 EXPECT
 196 ########
 197
 198 # Allowed IO self-ties
 199 my $destroyed = 0;
 200 sub Self3::TIEHANDLE { bless $_[1], $_[0] }
 201 sub Self3::DESTROY   { $destroyed = 1; }
 202 {
 203     use Symbol 'geniosym';
 204     my $c = geniosym;
 205     tie *$c, 'Self3', $c;
 206 }
 207 die "self-tied IO not DESTROYd" unless $destroyed == 1;
 208 EXPECT
 209 ########
 210
 211 # Interaction of tie and vec
 212
 213 my ($a, $b);
 214 use Tie::Scalar;
 215 tie $a,Tie::StdScalar or die;
 216 vec($b,1,1)=1;
 217 $a = $b;
 218 vec($a,1,1)=0;
 219 vec($b,1,1)=0;
 220 die unless $a eq $b;
 221 EXPECT
 222 ########
 223
 224 # correct unlocalisation of tied hashes (patch #16431)
 225 use Tie::Hash ;
 226 tie %tied, Tie::StdHash;
 227 { local $hash{'foo'} } warn "plain hash bad unlocalize" if exists $hash{'foo'};
 228 { local $tied{'foo'} } warn "tied hash bad unlocalize" if exists $tied{'foo'};
 229 { local $ENV{'foo'}  } warn "%ENV bad unlocalize" if exists $ENV{'foo'};
 230 EXPECT
 231 ########
 232
 233 # An attempt at lvalueable barewords broke this
 234 tie FH, 'main';
 235 EXPECT
 236 Can't modify constant item in tie at - line 3, near "'main';"
 237 Execution of - aborted due to compilation errors.