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 # 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 sub Self3::PRINT     { $printed = 1; }
 208 {
 209     use Symbol 'geniosym';
 210     my $c = geniosym;
 211     tie *$c, 'Self3', $c;
 212     print $c 'Hello';
 213 }
 214 die "self-tied IO not PRINTed" unless $printed == 1;
 215 die "self-tied IO not DESTROYed" unless $destroyed == 1;
 216 EXPECT
 217 ########
 218
 219 # TODO IO "self-tie" via TEMP glob
 220 my $destroyed = 0;
 221 sub Self3::TIEHANDLE { bless $_[1], $_[0] }
 222 sub Self3::DESTROY   { $destroyed = 1; }
 223 sub Self3::PRINT     { $printed = 1; }
 224 {
 225     use Symbol 'geniosym';
 226     my $c = geniosym;
 227     tie *$c, 'Self3', \*$c;
 228     print $c 'Hello';
 229 }
 230 die "IO tied to TEMP glob not PRINTed" unless $printed == 1;
 231 die "IO tied to TEMP glob not DESTROYed" unless $destroyed == 1;
 232 EXPECT
 233 ########
 234
 235 # Interaction of tie and vec
 236
 237 my ($a, $b);
 238 use Tie::Scalar;
 239 tie $a,Tie::StdScalar or die;
 240 vec($b,1,1)=1;
 241 $a = $b;
 242 vec($a,1,1)=0;
 243 vec($b,1,1)=0;
 244 die unless $a eq $b;
 245 EXPECT
 246 ########
 247
 248 # correct unlocalisation of tied hashes (patch #16431)
 249 use Tie::Hash ;
 250 tie %tied, Tie::StdHash;
 251 { local $hash{'foo'} } warn "plain hash bad unlocalize" if exists $hash{'foo'};
 252 { local $tied{'foo'} } warn "tied hash bad unlocalize" if exists $tied{'foo'};
 253 { local $ENV{'foo'}  } warn "%ENV bad unlocalize" if exists $ENV{'foo'};
 254 EXPECT
 255 ########
 256
 257 # An attempt at lvalueable barewords broke this
 258 tie FH, 'main';
 259 EXPECT
 260 Can't modify constant item in tie at - line 3, near "'main';"
 261 Execution of - aborted due to compilation errors.
 262 ########
 263
 264 # localizing tied hash slices
 265 $ENV{FooA} = 1;
 266 $ENV{FooB} = 2;
 267 print exists $ENV{FooA} ? 1 : 0, "\n";
 268 print exists $ENV{FooB} ? 2 : 0, "\n";
 269 print exists $ENV{FooC} ? 3 : 0, "\n";
 270 {
 271     local @ENV{qw(FooA FooC)};
 272     print exists $ENV{FooA} ? 4 : 0, "\n";
 273     print exists $ENV{FooB} ? 5 : 0, "\n";
 274     print exists $ENV{FooC} ? 6 : 0, "\n";
 275 }
 276 print exists $ENV{FooA} ? 7 : 0, "\n";
 277 print exists $ENV{FooB} ? 8 : 0, "\n";
 278 print exists $ENV{FooC} ? 9 : 0, "\n"; # this should not exist
 279 EXPECT
 280 1
 281 2
 282 0
 283 4
 284 5
 285 6
 286 7
 287 8
 288 0
 289 ########
 290 #
 291 # FETCH freeing tie'd SV
 292 sub TIESCALAR { bless [] }
 293 sub FETCH { *a = \1; 1 }
 294 tie $a, 'main';
 295 print $a;
 296 EXPECT
 297 Tied variable freed while still in use at - line 6.
 298 ########
 299
 300 #  [20020716.007] - nested FETCHES
 301
 302 sub F1::TIEARRAY { bless [], 'F1' }
 303 sub F1::FETCH { 1 }
 304 my @f1;
 305 tie @f1, 'F1';
 306
 307 sub F2::TIEARRAY { bless [2], 'F2' }
 308 sub F2::FETCH { my $self = shift; my $x = $f1[3]; $self }
 309 my @f2;
 310 tie @f2, 'F2';
 311
 312 print $f2[4][0],"\n";
 313
 314 sub F3::TIEHASH { bless [], 'F3' }
 315 sub F3::FETCH { 1 }
 316 my %f3;
 317 tie %f3, 'F3';
 318
 319 sub F4::TIEHASH { bless [3], 'F4' }
 320 sub F4::FETCH { my $self = shift; my $x = $f3{3}; $self }
 321 my %f4;
 322 tie %f4, 'F4';
 323
 324 print $f4{'foo'}[0],"\n";
 325
 326 EXPECT
 327 2
 328 3
 329 ########
 330 # test untie() from within FETCH
 331 package Foo;
 332 sub TIESCALAR { my $pkg = shift; return bless [@_], $pkg; }
 333 sub FETCH {
 334   my $self = shift;
 335   my ($obj, $field) = @$self;
 336   untie $obj->{$field};
 337   $obj->{$field} = "Bar";
 338 }
 339 package main;
 340 tie $a->{foo}, "Foo", $a, "foo";
 341 $a->{foo}; # access once
 342 # the hash element should not be tied anymore
 343 print defined tied $a->{foo} ? "not ok" : "ok";
 344 EXPECT
 345 ok
 346 ########
 347 # the tmps returned by FETCH should appear to be SCALAR
 348 # (even though they are now implemented using PVLVs.)
 349 package X;
 350 sub TIEHASH { bless {} }
 351 sub TIEARRAY { bless {} }
 352 sub FETCH {1}
 353 my (%h, @a);
 354 tie %h, 'X';
 355 tie @a, 'X';
 356 my $r1 = \$h{1};
 357 my $r2 = \$a[0];
 358 my $s = "$r1 ". ref($r1) . " $r2 " . ref($r2);
 359 $s=~ s/\(0x\w+\)//g;
 360 print $s, "\n";
 361 EXPECT
 362 SCALAR SCALAR SCALAR SCALAR
 363 ########
 364 # [perl #23287] segfault in untie
 365 sub TIESCALAR { bless $_[1], $_[0] }
 366 my $var;
 367 tie $var, 'main', \$var;
 368 untie $var;
 369 EXPECT
 370 ########
 371 # Test case from perlmonks by runrig
 372 # http://www.perlmonks.org/index.pl?node_id=273490
 373 # "Here is what I tried. I think its similar to what you've tried
 374 #  above. Its odd but convienient that after untie'ing you are left with
 375 #  a variable that has the same value as was last returned from
 376 #  FETCH. (At least on my perl v5.6.1). So you don't need to pass a
 377 #  reference to the variable in order to set it after the untie (here it
 378 #  is accessed through a closure)."
 379 use strict;
 380 use warnings;
 381 package MyTied;
 382 sub TIESCALAR {
 383     my ($class,$code) = @_;
 384     bless $code, $class;
 385 }
 386 sub FETCH {
 387     my $self = shift;
 388     print "Untie\n";
 389     $self->();
 390 }
 391 package main;
 392 my $var;
 393 tie $var, 'MyTied', sub { untie $var; 4 };
 394 print "One\n";
 395 print "$var\n";
 396 print "Two\n";
 397 print "$var\n";
 398 print "Three\n";
 399 print "$var\n";
 400 EXPECT
 401 One
 402 Untie
 403 4
 404 Two
 405 4
 406 Three
 407 4
 408 ########
 409 # [perl #22297] cannot untie scalar from within tied FETCH
 410 my $counter = 0;
 411 my $x = 7;
 412 my $ref = \$x;
 413 tie $x, 'Overlay', $ref, $x;
 414 my $y;
 415 $y = $x;
 416 $y = $x;
 417 $y = $x;
 418 $y = $x;
 419 #print "WILL EXTERNAL UNTIE $ref\n";
 420 untie $$ref;
 421 $y = $x;
 422 $y = $x;
 423 $y = $x;
 424 $y = $x;
 425 #print "counter = $counter\n";
 426
 427 print (($counter == 1) ? "ok\n" : "not ok\n");
 428
 429 package Overlay;
 430
 431 sub TIESCALAR
 432 {
 433         my $pkg = shift;
 434         my ($ref, $val) = @_;
 435         return bless [ $ref, $val ], $pkg;
 436 }
 437
 438 sub FETCH
 439 {
 440         my $self = shift;
 441         my ($ref, $val) = @$self;
 442         #print "WILL INTERNAL UNITE $ref\n";
 443         $counter++;
 444         untie $$ref;
 445         return $val;
 446 }
 447 EXPECT
 448 ok
 449 ########
 450
 451 # TODO [perl #948] cannot meaningfully tie $,
 452 package TieDollarComma;
 453
 454 sub TIESCALAR {
 455      my $pkg = shift;
 456      return bless \my $x, $pkg;
 457 }
 458
 459 sub STORE {
 460     my $self = shift;
 461     $$self = shift;
 462     print "STORE set '$$self'\n";
 463 }
 464
 465 sub FETCH {
 466     my $self = shift;
 467     print "FETCH\n";
 468     return $$self;
 469 }
 470 package main;
 471
 472 tie $,, 'TieDollarComma';
 473 $, = 'BOBBINS';
 474 print "join", "things", "up\n";
 475 EXPECT
 476 STORE set 'BOBBINS'
 477 FETCH
 478 FETCH
 479 joinBOBBINSthingsBOBBINSup
 480 ########
 481
 482 # test SCALAR method
 483 package TieScalar;
 484
 485 sub TIEHASH {
 486     my $pkg = shift;
 487     bless { } => $pkg;
 488 }
 489
 490 sub STORE {
 491     $_[0]->{$_[1]} = $_[2];
 492 }
 493
 494 sub FETCH {
 495     $_[0]->{$_[1]}
 496 }
 497
 498 sub CLEAR {
 499     %{ $_[0] } = ();
 500 }
 501
 502 sub SCALAR {
 503     print "SCALAR\n";
 504     return 0 if ! keys %{$_[0]};
 505     sprintf "%i/%i", scalar keys %{$_[0]}, scalar keys %{$_[0]};
 506 }
 507
 508 package main;
 509 tie my %h => "TieScalar";
 510 $h{key1} = "val1";
 511 $h{key2} = "val2";
 512 print scalar %h, "\n";
 513 %h = ();
 514 print scalar %h, "\n";
 515 EXPECT
 516 SCALAR
 517 2/2
 518 SCALAR
 519 0
 520 ########
 521
 522 # test scalar on tied hash when no SCALAR method has been given
 523 package TieScalar;
 524
 525 sub TIEHASH {
 526     my $pkg = shift;
 527     bless { } => $pkg;
 528 }
 529 sub STORE {
 530     $_[0]->{$_[1]} = $_[2];
 531 }
 532 sub FETCH {
 533     $_[0]->{$_[1]}
 534 }
 535 sub CLEAR {
 536     %{ $_[0] } = ();
 537 }
 538 sub FIRSTKEY {
 539     my $a = keys %{ $_[0] };
 540     print "FIRSTKEY\n";
 541     each %{ $_[0] };
 542 }
 543
 544 package main;
 545 tie my %h => "TieScalar";
 546
 547 if (!%h) {
 548     print "empty\n";
 549 } else {
 550     print "not empty\n";
 551 }
 552
 553 $h{key1} = "val1";
 554 print "not empty\n" if %h;
 555 print "not empty\n" if %h;
 556 print "-->\n";
 557 my ($k,$v) = each %h;
 558 print "<--\n";
 559 print "not empty\n" if %h;
 560 %h = ();
 561 print "empty\n" if ! %h;
 562 EXPECT
 563 FIRSTKEY
 564 empty
 565 FIRSTKEY
 566 not empty
 567 FIRSTKEY
 568 not empty
 569 -->
 570 FIRSTKEY
 571 <--
 572 not empty
 573 FIRSTKEY
 574 empty