t/op/or.t

   1 #!./perl
   2
   3 # Test || in weird situations.
   4
   5 BEGIN {
   6     chdir 't' if -d 't';
   7     @INC = '../lib';
   8 }
   9
  10
  11 package Countdown;
  12
  13 sub TIESCALAR {
  14   my $class = shift;
  15   my $instance = shift || undef;
  16   return bless \$instance => $class;
  17 }
  18
  19 sub FETCH {
  20   print "# FETCH!  ${$_[0]}\n";
  21   return ${$_[0]}--;
  22 }
  23
  24
  25 package main;
  26 require './test.pl';
  27
  28 plan( tests => 14 );
  29
  30
  31 my ($a, $b, $c);
  32
  33 $! = 1;
  34 $a = $!;
  35 my $a_str = sprintf "%s", $a;
  36 my $a_num = sprintf "%d", $a;
  37
  38 $c = $a || $b;
  39
  40 is($c, $a_str, "comparison of string equality");
  41 is($c+0, $a_num, "comparison of numeric equality");   # force numeric context.
  42
  43 $a =~ /./g or die "Match failed for some reason"; # Make $a magic
  44
  45 $c = $a || $b;
  46
  47 is($c, $a_str, "comparison of string equality");
  48 is($c+0, $a_num, "comparison of numeric equality");   # force numeric context.
  49
  50 my $val = 3;
  51
  52 $c = $val || $b;
  53 is($c, 3, "|| short-circuited as expected");
  54
  55 tie $a, 'Countdown', $val;
  56
  57 $c = $a;
  58 is($c, 3,       'Single FETCH on tied scalar');
  59
  60 $c = $a;
  61 is($c, 2,       '   $tied = $var');
  62
  63 $c = $a || $b;
  64
  65 {
  66     local $TODO = 'Double FETCH';
  67     is($c, 1,   '   $tied || $var');
  68 }
  69
  70 $y = " ";
  71 for (pos $x || pos $y) {
  72     eval { $_++ };
  73 }
  74 is(pos($y) || $@, 1, "|| propagates lvaluish context to its rhs");
  75
  76 $x = "  ";
  77 pos $x = 1;
  78 for (pos $x || pos $y) {
  79     eval { $_++ };
  80 }
  81 is(pos($x) || $@, 2, "|| propagates lvaluish context to its lhs");
  82
  83 for ($h{k} || $h{l}) {}
  84 ok(!exists $h{k},
  85   "|| does not propagate lvaluish cx to a subscript on its lhs");
  86 ok(!exists $h{l},
  87   "|| does not propagate lvaluish cx to a subscript on its rhs");
  88
  89 my $aa, $bb, $cc;
  90 $bb = 1;
  91
  92 my $res = 0;
  93 # Well, really testing OP_DOR I guess
  94 unless ($aa || $bb // $cc) {
  95         $res = 1;
  96 }
  97 is($res, 0, "res is 0 after mixed OR/DOR");
  98
  99 $res = 0;
 100 unless ($aa // $bb || $cc) {
 101         $res = 1;
 102 }
 103 is($res, 0, "res is 0 after mixed DOR/OR");