}
package main;
tie $a->{foo}, "Foo", $a, "foo";
-$a->{foo}; # access once
+my $s = $a->{foo}; # access once
# the hash element should not be tied anymore
print defined tied $a->{foo} ? "not ok" : "ok";
EXPECT
tie my %h => "TieScalar";
$h{key1} = "val1";
$h{key2} = "val2";
-print scalar %h, "\n";
+print scalar %h, "\n"
+ if %h; # this should also call SCALAR but implicitly
%h = ();
-print scalar %h, "\n";
+print scalar %h, "\n"
+ if !%h; # this should also call SCALAR but implicitly
EXPECT
SCALAR
+SCALAR
2/2
SCALAR
+SCALAR
0
########
EXPECT
01
########
+# Bug 53482 (and maybe others)
sub TIESCALAR { my $foo = $_[1]; bless \$foo, $_[0] }
sub FETCH { ${$_[0]} }
-tie my $x, "main", 2;
-tie my $y, "main", 8;
-print $x | $y;
+tie my $x1, "main", 2;
+tie my $y1, "main", 8;
+print $x1 | $y1;
+print $x1 | $y1;
+tie my $x2, "main", "2";
+tie my $y2, "main", "8";
+print $x2 | $y2;
+print $x2 | $y2;
EXPECT
-10
+1010::
########
# Bug 36267
sub TIEHASH { bless {}, $_[0] }
}
print "tied\n" if tied %h;
EXPECT
+########
+# RT 20727: PL_defoutgv is left as a tied element
+sub TIESCALAR { return bless {}, 'main' }
+
+sub STORE {
+ select($_[1]);
+ $_[1] = 1;
+ select(); # this used to coredump or assert fail
+}
+tie $SELECT, 'main';
+$SELECT = *STDERR;
+EXPECT
+########
+# RT 23810: eval in die in FETCH can corrupt context stack
+
+my $file = 'rt23810.pm';
+
+my $e;
+my $s;
+
+sub do_require {
+ my ($str, $eval) = @_;
+ open my $fh, '>', $file or die "Can't create $file: $!\n";
+ print $fh $str;
+ close $fh;
+ if ($eval) {
+ $s .= '-ERQ';
+ eval { require $pm; $s .= '-ENDE' }
+ }
+ else {
+ $s .= '-RQ';
+ require $pm;
+ }
+ $s .= '-ENDRQ';
+ unlink $file;
+}
+
+sub TIEHASH { bless {} }
+
+sub FETCH {
+ # 10 or more syntax errors makes yyparse croak()
+ my $bad = q{$x+;$x+;$x+;$x+;$x+;$x+;$x+;$x+;$x+$x+;$x+;$x+;$x+;$x+;;$x+;};
+
+ if ($_[1] eq 'eval') {
+ $s .= 'EVAL';
+ eval q[BEGIN { die; $s .= '-X1' }];
+ $s .= '-BD';
+ eval q[BEGIN { $x+ }];
+ $s .= '-BS';
+ eval '$x+';
+ $s .= '-E1';
+ $s .= '-S1' while $@ =~ /syntax error at/g;
+ eval $bad;
+ $s .= '-E2';
+ $s .= '-S2' while $@ =~ /syntax error at/g;
+ }
+ elsif ($_[1] eq 'require') {
+ $s .= 'REQUIRE';
+ my @text = (
+ q[BEGIN { die; $s .= '-X1' }],
+ q[BEGIN { $x+ }],
+ '$x+',
+ $bad
+ );
+ for my $i (0..$#text) {
+ $s .= "-$i";
+ do_require($txt[$i], 0) if $e;;
+ do_require($txt[$i], 1);
+ }
+ }
+ elsif ($_[1] eq 'exit') {
+ eval q[exit(0); print "overshot eval\n"];
+ }
+ else {
+ print "unknown key: '$_[1]'\n";
+ }
+ return "-R";
+}
+my %foo;
+tie %foo, "main";
+
+for my $action(qw(eval require)) {
+ $s = ''; $e = 0; $s .= main->FETCH($action); print "$action: s0=$s\n";
+ $s = ''; $e = 1; eval { $s .= main->FETCH($action)}; print "$action: s1=$s\n";
+ $s = ''; $e = 0; $s .= $foo{$action}; print "$action: s2=$s\n";
+ $s = ''; $e = 1; eval { $s .= $foo{$action}}; print "$action: s3=$s\n";
+}
+1 while unlink $file;
+
+$foo{'exit'};
+print "overshot main\n"; # shouldn't reach here
+
+EXPECT
+eval: s0=EVAL-BD-BS-E1-S1-E2-S2-S2-S2-S2-S2-S2-S2-S2-S2-S2-R
+eval: s1=EVAL-BD-BS-E1-S1-E2-S2-S2-S2-S2-S2-S2-S2-S2-S2-S2-R
+eval: s2=EVAL-BD-BS-E1-S1-E2-S2-S2-S2-S2-S2-S2-S2-S2-S2-S2-R
+eval: s3=EVAL-BD-BS-E1-S1-E2-S2-S2-S2-S2-S2-S2-S2-S2-S2-S2-R
+require: s0=REQUIRE-0-ERQ-ENDRQ-1-ERQ-ENDRQ-2-ERQ-ENDRQ-3-ERQ-ENDRQ-R
+require: s1=REQUIRE-0-RQ
+require: s2=REQUIRE-0-ERQ-ENDRQ-1-ERQ-ENDRQ-2-ERQ-ENDRQ-3-ERQ-ENDRQ-R
+require: s3=REQUIRE-0-RQ
+########
+# RT 8857: STORE incorrectly invoked for local($_) on aliased tied array
+# element
+
+sub TIEARRAY { bless [], $_[0] }
+sub TIEHASH { bless [], $_[0] }
+sub FETCH { $_[0]->[$_[1]] }
+sub STORE { $_[0]->[$_[1]] = $_[2] }
+
+
+sub f {
+ local $_[0];
+}
+tie @a, 'main';
+tie %h, 'main';
+
+foreach ($a[0], $h{a}) {
+ f($_);
+}
+# on failure, chucks up 'premature free' etc messages
+EXPECT
+########
+# RT 5475:
+# the initial fix for this bug caused tied scalar FETCH to be called
+# multiple times when that scalar was an element in an array. Check it
+# only gets called once now.
+
+sub TIESCALAR { bless [], $_[0] }
+my $c = 0;
+sub FETCH { $c++; 0 }
+sub FETCHSIZE { 1 }
+sub STORE { $c += 100; 0 }
+
+
+my (@a, %h);
+tie $a[0], 'main';
+tie $h{foo}, 'main';
+
+my $i = 0;
+my $x = $a[0] + $h{foo} + $a[$i] + (@a)[0];
+print "x=$x c=$c\n";
+EXPECT
+x=0 c=4
+########
+# Bug 68192 - numeric ops not calling mg_get when tied scalar holds a ref
+sub TIESCALAR { bless {}, __PACKAGE__ };
+sub STORE {};
+sub FETCH {
+ print "fetching... "; # make sure FETCH is called once per op
+ 123456
+};
+my $foo;
+tie $foo, __PACKAGE__;
+my $a = [1234567];
+$foo = $a;
+print "+ ", 0 + $foo, "\n";
+print "** ", $foo**1, "\n";
+print "* ", $foo*1, "\n";
+print "/ ", $foo*1, "\n";
+print "% ", $foo%123457, "\n";
+print "- ", $foo-0, "\n";
+print "neg ", - -$foo, "\n";
+print "int ", int $foo, "\n";
+print "abs ", abs $foo, "\n";
+print "== ", 123456 == $foo, "\n";
+print "< ", 123455 < $foo, "\n";
+print "> ", 123457 > $foo, "\n";
+print "<= ", 123456 <= $foo, "\n";
+print ">= ", 123456 >= $foo, "\n";
+print "!= ", 0 != $foo, "\n";
+print "<=> ", 123457 <=> $foo, "\n";
+EXPECT
+fetching... + 123456
+fetching... ** 123456
+fetching... * 123456
+fetching... / 123456
+fetching... % 123456
+fetching... - 123456
+fetching... neg 123456
+fetching... int 123456
+fetching... abs 123456
+fetching... == 1
+fetching... < 1
+fetching... > 1
+fetching... <= 1
+fetching... >= 1
+fetching... != 1
+fetching... <=> 1
+########
+# Ties returning overloaded objects
+{
+ package overloaded;
+ use overload
+ '*{}' => sub { print '*{}'; \*100 },
+ '@{}' => sub { print '@{}'; \@100 },
+ '%{}' => sub { print '%{}'; \%100 },
+ '${}' => sub { print '${}'; \$100 },
+ map {
+ my $op = $_;
+ $_ => sub { print "$op"; 100 }
+ } qw< 0+ "" + ** * / % - neg int abs == < > <= >= != <=> >
+}
+$o = bless [], overloaded;
+
+sub TIESCALAR { bless {}, "" }
+sub FETCH { print "fetching... "; $o }
+sub STORE{}
+tie $ghew, "";
+
+$ghew=undef; 1+$ghew; print "\n";
+$ghew=undef; $ghew**1; print "\n";
+$ghew=undef; $ghew*1; print "\n";
+$ghew=undef; $ghew/1; print "\n";
+$ghew=undef; $ghew%1; print "\n";
+$ghew=undef; $ghew-1; print "\n";
+$ghew=undef; -$ghew; print "\n";
+$ghew=undef; int $ghew; print "\n";
+$ghew=undef; abs $ghew; print "\n";
+$ghew=undef; 1 == $ghew; print "\n";
+$ghew=undef; $ghew<1; print "\n";
+$ghew=undef; $ghew>1; print "\n";
+$ghew=undef; $ghew<=1; print "\n";
+$ghew=undef; $ghew >=1; print "\n";
+$ghew=undef; $ghew != 1; print "\n";
+$ghew=undef; $ghew<=>1; print "\n";
+$ghew=\*shrext; *$ghew; print "\n";
+$ghew=\@spled; @$ghew; print "\n";
+$ghew=\%frit; %$ghew; print "\n";
+$ghew=\$drile; $$ghew; print "\n";
+EXPECT
+fetching... +
+fetching... **
+fetching... *
+fetching... /
+fetching... %
+fetching... -
+fetching... neg
+fetching... int
+fetching... abs
+fetching... ==
+fetching... <
+fetching... >
+fetching... <=
+fetching... >=
+fetching... !=
+fetching... <=>
+fetching... *{}
+fetching... @{}
+fetching... %{}
+fetching... ${}
projects / p5sagit/p5-mst-13.2.git / blobdiff