t/op/tie.t

   1 #!./perl
   2
   3 # This test harness will (eventually) test the "tie" functionality
   4 # without the need for a *DBM* implementation.
   5
   6 # Currently it only tests use strict "untie".
   7
   8 chdir 't' if -d 't';
   9 @INC = "../lib";
  10 $ENV{PERL5LIB} = "../lib";
  11
  12 $|=1;
  13
  14 undef $/;
  15 @prgs = split "\n########\n", <DATA>;
  16 print "1..", scalar @prgs, "\n";
  17
  18 for (@prgs){
  19     my($prog,$expected) = split(/\nEXPECT\n/, $_);
  20     eval "$prog" ;
  21     $status = $?;
  22     $results = $@ ;
  23     $results =~ s/\n+$//;
  24     $expected =~ s/\n+$//;
  25     if ( $status or $results !~ /^$expected/){
  26         print STDERR "STATUS: $status\n";
  27         print STDERR "PROG: $prog\n";
  28         print STDERR "EXPECTED:\n$expected\n";
  29         print STDERR "GOT:\n$results\n";
  30         print "not ";
  31     }
  32     print "ok ", ++$i, "\n";
  33 }
  34
  35 __END__
  36
  37 # standard behaviour, without any extra references
  38 use Tie::Hash ;
  39 tie %h, Tie::StdHash;
  40 untie %h;
  41 EXPECT
  42 ########
  43
  44 # standard behaviour, with 1 extra reference
  45 use Tie::Hash ;
  46 $a = tie %h, Tie::StdHash;
  47 untie %h;
  48 EXPECT
  49 ########
  50
  51 # standard behaviour, with 1 extra reference via tied
  52 use Tie::Hash ;
  53 tie %h, Tie::StdHash;
  54 $a = tied %h;
  55 untie %h;
  56 EXPECT
  57 ########
  58
  59 # standard behaviour, with 1 extra reference which is destroyed
  60 use Tie::Hash ;
  61 $a = tie %h, Tie::StdHash;
  62 $a = 0 ;
  63 untie %h;
  64 EXPECT
  65 ########
  66
  67 # standard behaviour, with 1 extra reference via tied which is destroyed
  68 use Tie::Hash ;
  69 tie %h, Tie::StdHash;
  70 $a = tied %h;
  71 $a = 0 ;
  72 untie %h;
  73 EXPECT
  74 ########
  75
  76 # strict behaviour, without any extra references
  77 use strict 'untie';
  78 use Tie::Hash ;
  79 tie %h, Tie::StdHash;
  80 untie %h;
  81 EXPECT
  82 ########
  83
  84 # strict behaviour, with 1 extra references generating an error
  85 use strict 'untie';
  86 use Tie::Hash ;
  87 $a = tie %h, Tie::StdHash;
  88 untie %h;
  89 EXPECT
  90 Can't untie: 1 inner references still exist at
  91 ########
  92
  93 # strict behaviour, with 1 extra references via tied generating an error
  94 use strict 'untie';
  95 use Tie::Hash ;
  96 tie %h, Tie::StdHash;
  97 $a = tied %h;
  98 untie %h;
  99 EXPECT
 100 Can't untie: 1 inner references still exist at
 101 ########
 102
 103 # strict behaviour, with 1 extra references which are destroyed
 104 use strict 'untie';
 105 use Tie::Hash ;
 106 $a = tie %h, Tie::StdHash;
 107 $a = 0 ;
 108 untie %h;
 109 EXPECT
 110 ########
 111
 112 # strict behaviour, with extra 1 references via tied which are destroyed
 113 use strict 'untie';
 114 use Tie::Hash ;
 115 tie %h, Tie::StdHash;
 116 $a = tied %h;
 117 $a = 0 ;
 118 untie %h;
 119 EXPECT
 120 ########
 121
 122 # strict error behaviour, with 2 extra references
 123 use strict 'untie';
 124 use Tie::Hash ;
 125 $a = tie %h, Tie::StdHash;
 126 $b = tied %h ;
 127 untie %h;
 128 EXPECT
 129 Can't untie: 2 inner references still exist at
 130 ########
 131
 132 # strict behaviour, check scope of strictness.
 133 no strict 'untie';
 134 use Tie::Hash ;
 135 $A = tie %H, Tie::StdHash;
 136 $C = $B = tied %H ;
 137 {
 138     use strict 'untie';
 139     use Tie::Hash ;
 140     tie %h, Tie::StdHash;
 141     untie %h;
 142 }
 143 untie %H;
 144 EXPECT