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