This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[perl #87708] $tied % $tied and $tied * $tied under use integer
[perl5.git] / t / op / tie_fetch_count.t
index 9a767f1..6643941 100644 (file)
@@ -1,30 +1,39 @@
 #!./perl
 # Tests counting number of FETCHes.
 #
-# See Bug #76814.
+# See Bugs #76814 and #87708.
 
 BEGIN {
     chdir 't' if -d 't';
     @INC = '../lib';
     require './test.pl';
-    plan (tests => 92);
+    plan (tests => 172);
 }
 
 use strict;
 use warnings;
 
-my $TODO = "Bug 76814";
-
 my $count = 0;
 
-sub TIESCALAR {bless \do {my $var = $_ [1]} => $_ [0];}
-sub FETCH {$count ++; ${$_ [0]}}
+# Usage:
+#   tie $var, "main", $val;          # FETCH returns $val
+#   tie $var, "main", $val1, $val2;  # FETCH returns the values in order,
+#                                    # one at a time, repeating the last
+#                                    # when the list is exhausted.
+sub TIESCALAR {my $pack = shift; bless [@_], $pack;}
+sub FETCH {$count ++; @{$_ [0]} == 1 ? ${$_ [0]}[0] : shift @{$_ [0]}}
 sub STORE {1;}
 
 
 sub check_count {
     my $op = shift;
-    is $count, 1, "FETCH called just once using '$op'";
+    my $expected = shift() // 1;
+    is $count, $expected,
+        "FETCH called " . (
+          $expected == 1 ? "just once" : 
+          $expected == 2 ? "twice"     :
+                           "$count times"
+        ) . " using '$op'";
     $count = 0;
 }
 
@@ -83,12 +92,10 @@ $dummy  =  $var   |   1 ; check_count '|';
 $dummy  = ~$var         ; check_count '~';
 
 # Logical operators
-TODO: {
-    local $::TODO = $TODO;
-    $dummy  = !$var         ; check_count '!';
-    $dummy  =  $var  ||   1 ; check_count '||';
-    $dummy  = ($var  or   1); check_count 'or';
-}
+$dummy  = !$var         ; check_count '!';
+tie my $v_1, "main", 0;
+$dummy  =  $v_1  ||   1 ; check_count '||';
+$dummy  = ($v_1  or   1); check_count 'or';
 $dummy  =  $var  &&   1 ; check_count '&&';
 $dummy  = ($var and   1); check_count 'and';
 $dummy  = ($var xor   1); check_count 'xor';
@@ -143,12 +150,11 @@ $_ = "foo";
 $dummy  =  $var =~ m/ / ; check_count 'm//';
 $dummy  =  $var =~ s/ //; check_count 's///';
 $dummy  =  $var ~~    1 ; check_count '~~';
-TODO: {
-    local $::TODO = $TODO;
-    $dummy  =  $var =~ y/ //; check_count 'y///';
-               /$var/       ; check_count 'm/pattern/';
-              s/$var//      ; check_count 's/pattern//';
-}
+$dummy  =  $var =~ y/ //; check_count 'y///';
+           /$var/       ; check_count 'm/pattern/';
+           /$var foo/   ; check_count 'm/$tied foo/';
+          s/$var//      ; check_count 's/pattern//';
+          s/$var foo//  ; check_count 's/$tied foo//';
           s/./$var/     ; check_count 's//replacement/';
 
 # Dereferencing
@@ -167,4 +173,80 @@ $dummy  = %$var3        ; check_count '%{}';
 tie my $var5 => 'main', sub {1};
 $dummy  = &$var5        ; check_count '&{}';
 
+
+###############################################
+#        Tests for  $foo binop $foo           #
+###############################################
+
+# These test that binary ops call FETCH twice if the same scalar is used
+# for both operands. They also test that both return values from
+# FETCH are used.
+
+sub bin_test {
+    my $op = shift;
+    tie my $var, "main", @_[0..$#_-1];
+    is(eval "\$var $op \$var", pop, "retval of \$var $op \$var");
+    check_count $op, 2;
+}
+sub bin_int_test {
+    my $op = shift;
+    tie my $var, "main", @_[0..$#_-1];
+    is(eval "use integer; \$var $op \$var", pop,
+       "retval of \$var $op \$var under use integer");
+    check_count "$op under use integer", 2;
+}
+
+our $TODO;
+my  $todo = 'bug #87708';
+{
+    local $TODO = $todo;
+    bin_test '**',  2, 3, 8;
+    bin_test '*' ,  2, 3, 6;
+    bin_test '/' , 10, 2, 5;
+    bin_test '%' , 11, 2, 1;
+    bin_test 'x' , 11, 2, 1111;
+    bin_test '-' , 11, 2, 9;
+    bin_test '<<', 11, 2, 44;
+    bin_test '>>', 44, 2, 11;
+    bin_test '<' ,  1, 2, 1;
+    bin_test '>' , 44, 2, 1;
+    bin_test '<=', 44, 2, "";
+    bin_test '>=',  1, 2, "";
+    bin_test '!=',  1, 2, 1;
+    bin_test '<=>', 1, 2, -1;
+    bin_test 'le',  4, 2, "";
+    bin_test 'lt',  1, 2, 1;
+    bin_test 'gt',  4, 2, 1;
+    bin_test 'ge',  1, 2, "";
+    bin_test 'eq',  1, 2, "";
+    bin_test 'ne',  1, 2, 1;
+    bin_test 'cmp', 1, 2, -1;
+    bin_test '&' ,  1, 2, 0;
+    bin_test '|' ,  1, 2, 3;
+}
+bin_test '.' ,  1, 2, 12;
+{
+    local $TODO = $todo ;
+    bin_test '==',  1, 2, "";
+    bin_test '+' ,  1, 2, 3;
+}
+bin_int_test '*' ,  2, 3, 6;
+{
+    local $TODO = $todo ;
+    bin_int_test '/' , 10, 2, 5;
+}
+bin_int_test '%' , 11, 2, 1;
+bin_int_test '+' ,  1, 2, 3;
+bin_int_test '-' , 11, 2, 9;
+bin_int_test '<' ,  1, 2, 1;
+bin_int_test '>' , 44, 2, 1;
+bin_int_test '<=', 44, 2, "";
+bin_int_test '>=',  1, 2, "";
+bin_int_test '==',  1, 2, "";
+bin_int_test '!=',  1, 2, 1;
+bin_int_test '<=>', 1, 2, -1;
+tie $var, "main", 1, 4;
+cmp_ok(atan2($var, $var), '<', .3, 'retval of atan2 $var, $var');
+check_count 'atan2',  2;
+
 __DATA__