[p5sagit/p5-mst-13.2.git] / t / op / switch.t

#!./perl

BEGIN {
    chdir 't' if -d 't';
    @INC = '../lib';
}

use strict;
use warnings;

use Test::More tests => 111;

# The behaviour of the feature pragma should be tested by lib/switch.t
# using the tests in t/lib/switch/*. This file tests the behaviour of
# the switch ops themselves.
              

use feature 'switch';
no warnings "numeric";

eval { continue };
like($@, qr/^Can't "continue" outside/, "continue outside");

eval { break };
like($@, qr/^Can't "break" outside/, "break outside");

# Scoping rules

{
    my $x = "foo";
    given(my $x = "bar") {
	is($x, "bar", "given scope starts");
    }
    is($x, "foo", "given scope ends");
}

sub be_true {1}

given(my $x = "foo") {
    when(be_true(my $x = "bar")) {
	is($x, "bar", "given scope starts");
    }
    is($x, "foo", "given scope ends");
}

$_ = "outside";
given("inside") { check_outside1() }
sub check_outside1 { is($_, "outside", "\$_ lexically scoped") }

{
    my $_ = "outside";
    given("inside") { check_outside2() }
    sub check_outside2 {
	is($_, "outside", "\$_ lexically scoped (lexical \$_)")
    }
}

# Basic string/numeric comparisons and control flow

{    
    my $ok;
    given(3) {
	when(2) { $ok = 'two'; }
	when(3) { $ok = 'three'; }
	when(4) { $ok = 'four'; }
	default { $ok = 'd'; }
    }
    is($ok, 'three', "numeric comparison");
}

{    
    my $ok;
    use integer;
    given(3.14159265) {
	when(2) { $ok = 'two'; }
	when(3) { $ok = 'three'; }
	when(4) { $ok = 'four'; }
	default { $ok = 'd'; }
    }
    is($ok, 'three', "integer comparison");
}

{    
    my ($ok1, $ok2);
    given(3) {
	when(3.1)   { $ok1 = 'n'; }
	when(3.0)   { $ok1 = 'y'; continue }
	when("3.0") { $ok2 = 'y'; }
	default     { $ok2 = 'n'; }
    }
    is($ok1, 'y', "more numeric (pt. 1)");
    is($ok2, 'y', "more numeric (pt. 2)");
}

{
    my $ok;
    given("c") {
	when("b") { $ok = 'B'; }
	when("c") { $ok = 'C'; }
	when("d") { $ok = 'D'; }
	default   { $ok = 'def'; }
    }
    is($ok, 'C', "string comparison");
}

{
    my $ok;
    given("c") {
	when("b") { $ok = 'B'; }
	when("c") { $ok = 'C'; continue }
	when("c") { $ok = 'CC'; }
	default   { $ok = 'D'; }
    }
    is($ok, 'CC', "simple continue");
}

# Definedness
{
    my $ok = 1;
    given (0) { when(undef) {$ok = 0} }
    is($ok, 1, "Given(0) when(undef)");
}
{
    my $undef;
    my $ok = 1;
    given (0) { when($undef) {$ok = 0} }
    is($ok, 1, 'Given(0) when($undef)');
}
{
    my $undef;
    my $ok = 0;
    given (0) { when($undef++) {$ok = 1} }
    is($ok, 1, "Given(0) when($undef++)");
}
{
    my $ok = 1;
    given (undef) { when(0) {$ok = 0} }
    is($ok, 1, "Given(undef) when(0)");
}
{
    my $undef;
    my $ok = 1;
    given ($undef) { when(0) {$ok = 0} }
    is($ok, 1, 'Given($undef) when(0)');
}
########
{
    my $ok = 1;
    given ("") { when(undef) {$ok = 0} }
    is($ok, 1, 'Given("") when(undef)');
}
{
    my $undef;
    my $ok = 1;
    given ("") { when($undef) {$ok = 0} }
    is($ok, 1, 'Given("") when($undef)');
}
{
    my $ok = 1;
    given (undef) { when("") {$ok = 0} }
    is($ok, 1, 'Given(undef) when("")');
}
{
    my $undef;
    my $ok = 1;
    given ($undef) { when("") {$ok = 0} }
    is($ok, 1, 'Given($undef) when("")');
}
########
{
    my $ok = 0;
    given (undef) { when(undef) {$ok = 1} }
    is($ok, 1, "Given(undef) when(undef)");
}
{
    my $undef;
    my $ok = 0;
    given (undef) { when($undef) {$ok = 1} }
    is($ok, 1, 'Given(undef) when($undef)');
}
{
    my $undef;
    my $ok = 0;
    given ($undef) { when(undef) {$ok = 1} }
    is($ok, 1, 'Given($undef) when(undef)');
}
{
    my $undef;
    my $ok = 0;
    given ($undef) { when($undef) {$ok = 1} }
    is($ok, 1, 'Given($undef) when($undef)');
}


# Regular expressions
{
    my ($ok1, $ok2);
    given("Hello, world!") {
	when(/lo/)
	    { $ok1 = 'y'; continue}
	when(/no/)
	    { $ok1 = 'n'; continue}
	when(/^(Hello,|Goodbye cruel) world[!.?]/)
	    { $ok2 = 'Y'; continue}
	when(/^(Hello cruel|Goodbye,) world[!.?]/)
	    { $ok2 = 'n'; continue}
    }
    is($ok1, 'y', "regex 1");
    is($ok2, 'Y', "regex 2");
}

# Comparisons
{
    my $test = "explicit numeric comparison (<)";
    my $twenty_five = 25;
    my $ok;
    given($twenty_five) {
	when ($_ < 10) { $ok = "ten" }
	when ($_ < 20) { $ok = "twenty" }
	when ($_ < 30) { $ok = "thirty" }
	when ($_ < 40) { $ok = "forty" }
	default        { $ok = "default" }
    }
    is($ok, "thirty", $test);
}

{
    use integer;
    my $test = "explicit numeric comparison (integer <)";
    my $twenty_five = 25;
    my $ok;
    given($twenty_five) {
	when ($_ < 10) { $ok = "ten" }
	when ($_ < 20) { $ok = "twenty" }
	when ($_ < 30) { $ok = "thirty" }
	when ($_ < 40) { $ok = "forty" }
	default        { $ok = "default" }
    }
    is($ok, "thirty", $test);
}

{
    my $test = "explicit numeric comparison (<=)";
    my $twenty_five = 25;
    my $ok;
    given($twenty_five) {
	when ($_ <= 10) { $ok = "ten" }
	when ($_ <= 20) { $ok = "twenty" }
	when ($_ <= 30) { $ok = "thirty" }
	when ($_ <= 40) { $ok = "forty" }
	default         { $ok = "default" }
    }
    is($ok, "thirty", $test);
}

{
    use integer;
    my $test = "explicit numeric comparison (integer <=)";
    my $twenty_five = 25;
    my $ok;
    given($twenty_five) {
	when ($_ <= 10) { $ok = "ten" }
	when ($_ <= 20) { $ok = "twenty" }
	when ($_ <= 30) { $ok = "thirty" }
	when ($_ <= 40) { $ok = "forty" }
	default         { $ok = "default" }
    }
    is($ok, "thirty", $test);
}


{
    my $test = "explicit numeric comparison (>)";
    my $twenty_five = 25;
    my $ok;
    given($twenty_five) {
	when ($_ > 40) { $ok = "forty" }
	when ($_ > 30) { $ok = "thirty" }
	when ($_ > 20) { $ok = "twenty" }
	when ($_ > 10) { $ok = "ten" }
	default        { $ok = "default" }
    }
    is($ok, "twenty", $test);
}

{
    my $test = "explicit numeric comparison (>=)";
    my $twenty_five = 25;
    my $ok;
    given($twenty_five) {
	when ($_ >= 40) { $ok = "forty" }
	when ($_ >= 30) { $ok = "thirty" }
	when ($_ >= 20) { $ok = "twenty" }
	when ($_ >= 10) { $ok = "ten" }
	default         { $ok = "default" }
    }
    is($ok, "twenty", $test);
}

{
    use integer;
    my $test = "explicit numeric comparison (integer >)";
    my $twenty_five = 25;
    my $ok;
    given($twenty_five) {
	when ($_ > 40) { $ok = "forty" }
	when ($_ > 30) { $ok = "thirty" }
	when ($_ > 20) { $ok = "twenty" }
	when ($_ > 10) { $ok = "ten" }
	default        { $ok = "default" }
    }
    is($ok, "twenty", $test);
}

{
    use integer;
    my $test = "explicit numeric comparison (integer >=)";
    my $twenty_five = 25;
    my $ok;
    given($twenty_five) {
	when ($_ >= 40) { $ok = "forty" }
	when ($_ >= 30) { $ok = "thirty" }
	when ($_ >= 20) { $ok = "twenty" }
	when ($_ >= 10) { $ok = "ten" }
	default         { $ok = "default" }
    }
    is($ok, "twenty", $test);
}


{
    my $test = "explicit string comparison (lt)";
    my $twenty_five = "25";
    my $ok;
    given($twenty_five) {
	when ($_ lt "10") { $ok = "ten" }
	when ($_ lt "20") { $ok = "twenty" }
	when ($_ lt "30") { $ok = "thirty" }
	when ($_ lt "40") { $ok = "forty" }
	default           { $ok = "default" }
    }
    is($ok, "thirty", $test);
}

{
    my $test = "explicit string comparison (le)";
    my $twenty_five = "25";
    my $ok;
    given($twenty_five) {
	when ($_ le "10") { $ok = "ten" }
	when ($_ le "20") { $ok = "twenty" }
	when ($_ le "30") { $ok = "thirty" }
	when ($_ le "40") { $ok = "forty" }
	default           { $ok = "default" }
    }
    is($ok, "thirty", $test);
}

{
    my $test = "explicit string comparison (gt)";
    my $twenty_five = 25;
    my $ok;
    given($twenty_five) {
	when ($_ ge "40") { $ok = "forty" }
	when ($_ ge "30") { $ok = "thirty" }
	when ($_ ge "20") { $ok = "twenty" }
	when ($_ ge "10") { $ok = "ten" }
	default           { $ok = "default" }
    }
    is($ok, "twenty", $test);
}

{
    my $test = "explicit string comparison (ge)";
    my $twenty_five = 25;
    my $ok;
    given($twenty_five) {
	when ($_ ge "40") { $ok = "forty" }
	when ($_ ge "30") { $ok = "thirty" }
	when ($_ ge "20") { $ok = "twenty" }
	when ($_ ge "10") { $ok = "ten" }
	default           { $ok = "default" }
    }
    is($ok, "twenty", $test);
}

# Make sure it still works with a lexical $_:
{
    my $_;
    my $test = "explicit comparison with lexical \$_";
    my $twenty_five = 25;
    my $ok;
    given($twenty_five) {
	when ($_ ge "40") { $ok = "forty" }
	when ($_ ge "30") { $ok = "thirty" }
	when ($_ ge "20") { $ok = "twenty" }
	when ($_ ge "10") { $ok = "ten" }
	default           { $ok = "default" }
    }
    is($ok, "twenty", $test);
}

# Optimized-away comparisons
{
    my $ok;
    given(23) {
	when (2 + 2 == 4) { $ok = 'y'; continue }
	when (2 + 2 == 5) { $ok = 'n' }
    }
    is($ok, 'y', "Optimized-away comparison");
}

# File tests
#  (How to be both thorough and portable? Pinch a few ideas
#  from t/op/filetest.t. We err on the side of portability for
#  the time being.)

{
    my ($ok_d, $ok_f, $ok_r);
    given("op") {
	when(-d)  {$ok_d = 1; continue}
	when(!-f) {$ok_f = 1; continue}
	when(-r)  {$ok_r = 1; continue}
    }
    ok($ok_d, "Filetest -d");
    ok($ok_f, "Filetest -f");
    ok($ok_r, "Filetest -r");
}

# Sub and method calls
sub bar {"bar"}
{
    my $ok = 0;
    given("foo") {
	when(bar()) {$ok = 1}
    }
    ok($ok, "Sub call acts as boolean")
}

{
    my $ok = 0;
    given("foo") {
	when(main->bar()) {$ok = 1}
    }
    ok($ok, "Class-method call acts as boolean")
}

{
    my $ok = 0;
    my $obj = bless [];
    given("foo") {
	when($obj->bar()) {$ok = 1}
    }
    ok($ok, "Object-method call acts as boolean")
}

# Other things that should not be smart matched
{
    my $ok = 0;
    given(12) {
        when( /(\d+)/ and ( 1 <= $1 and $1 <= 12 ) ) {
            $ok = 1;
        }
    }
    ok($ok, "bool not smartmatches");
}

{
    my $ok = 0;
    given(0) {
	when(eof(DATA)) {
	    $ok = 1;
	}
    }
    ok($ok, "eof() not smartmatched");
}

{
    my $ok = 0;
    my %foo = ("bar", 0);
    given(0) {
	when(exists $foo{bar}) {
	    $ok = 1;
	}
    }
    ok($ok, "exists() not smartmatched");
}

{
    my $ok = 0;
    given(0) {
	when(defined $ok) {
	    $ok = 1;
	}
    }
    ok($ok, "defined() not smartmatched");
}

{
    my $ok = 1;
    given("foo") {
	when((1 == 1) && "bar") {
	    $ok = 0;
	}
	when((1 == 1) && $_ eq "foo") {
	    $ok = 2;
	}
    }
    is($ok, 2, "((1 == 1) && \"bar\") not smartmatched");
}

{
    my $ok = 0;
    given("foo") {
	when((1 == $ok) || "foo") {
	    $ok = 1;
	}
    }
    ok($ok, '((1 == $ok) || "foo") smartmatched');
}

TODO: {
    local $TODO = "RT #50538: when( \@n && \%n ) fails to smart match";
    { # this should smart match on each side of &&
 	my @n = qw(fred barney betty);
	my @m = @n;
	
	my $ok = 0;
	given( "fred" ) {
	when( @n ) {
		$ok++; continue;
	}
	when( @m ) {
		$ok++; continue;
	}
	when( @m && @n ) {
		$ok++;
	}
	}

	is($ok, 3, '(@n && @m) smart-matched');	
    }

    { # this should smart match on each side of &&
	my @n = qw(fred barney betty);
	my %n = map { $_, 1 } @n;
	
	my $ok = 0;
	given( "fred" ) {
	when( @n ) {
		$ok++; continue;
	}
	when( %n ) {
		$ok++; continue;
	}
	when( @n && %n ) {
		$ok++;
	}
	}

	is($ok, 3, '(@n && %n) smart-matched');	
    }

    { # this should smart match on each side of &&
	my %n = map { $_, 1 } qw(fred barney betty);
	my %m = %n;
	
	my $ok = 0;
	given( "fred" ) {
	when( %m ) {
		$ok++; continue;
	}
	when( %n ) {
		$ok++; continue;
	}
	when( %m && %n ) {
		$ok++;
	}
	}

	is($ok, 3, '(%m && %n) smart-matched');	
    }
}

# Make sure we aren't invoking the get-magic more than once

{ # A helper class to count the number of accesses.
    package FetchCounter;
    sub TIESCALAR {
	my ($class) = @_;
	bless {value => undef, count => 0}, $class;
    }
    sub STORE {
        my ($self, $val) = @_;
        $self->{count} = 0;
        $self->{value} = $val;
    }
    sub FETCH {
	my ($self) = @_;
	# Avoid pre/post increment here
	$self->{count} = 1 + $self->{count};
	$self->{value};
    }
    sub count {
	my ($self) = @_;
	$self->{count};
    }
}

my $f = tie my $v, "FetchCounter";

{   my $test_name = "Only one FETCH (in given)";
    my $ok;
    given($v = 23) {
    	when(undef) {}
    	when(sub{0}->()) {}
	when(21) {}
	when("22") {}
	when(23) {$ok = 1}
	when(/24/) {$ok = 0}
    }
    is($ok, 1, "precheck: $test_name");
    is($f->count(), 1, $test_name);
}

{   my $test_name = "Only one FETCH (numeric when)";
    my $ok;
    $v = 23;
    is($f->count(), 0, "Sanity check: $test_name");
    given(23) {
    	when(undef) {}
    	when(sub{0}->()) {}
	when(21) {}
	when("22") {}
	when($v) {$ok = 1}
	when(/24/) {$ok = 0}
    }
    is($ok, 1, "precheck: $test_name");
    is($f->count(), 1, $test_name);
}

{   my $test_name = "Only one FETCH (string when)";
    my $ok;
    $v = "23";
    is($f->count(), 0, "Sanity check: $test_name");
    given("23") {
    	when(undef) {}
    	when(sub{0}->()) {}
	when("21") {}
	when("22") {}
	when($v) {$ok = 1}
	when(/24/) {$ok = 0}
    }
    is($ok, 1, "precheck: $test_name");
    is($f->count(), 1, $test_name);
}

{   my $test_name = "Only one FETCH (undef)";
    my $ok;
    $v = undef;
    is($f->count(), 0, "Sanity check: $test_name");
    given(my $undef) {
    	when(sub{0}->()) {}
	when("21")  {}
	when("22")  {}
    	when($v)    {$ok = 1}
	when(undef) {$ok = 0}
    }
    is($ok, 1, "precheck: $test_name");
    is($f->count(), 1, $test_name);
}

# Loop topicalizer
{
    my $first = 1;
    for (1, "two") {
	when ("two") {
	    is($first, 0, "Loop: second");
	    eval {break};
	    like($@, qr/^Can't "break" in a loop topicalizer/,
	    	q{Can't "break" in a loop topicalizer});
	}
	when (1) {
	    is($first, 1, "Loop: first");
	    $first = 0;
	    # Implicit break is okay
	}
    }
}

{
    my $first = 1;
    for $_ (1, "two") {
	when ("two") {
	    is($first, 0, "Explicit \$_: second");
	    eval {break};
	    like($@, qr/^Can't "break" in a loop topicalizer/,
	    	q{Can't "break" in a loop topicalizer});
	}
	when (1) {
	    is($first, 1, "Explicit \$_: first");
	    $first = 0;
	    # Implicit break is okay
	}
    }
}

{
    my $first = 1;
    my $_;
    for (1, "two") {
	when ("two") {
	    is($first, 0, "Implicitly lexical loop: second");
	    eval {break};
	    like($@, qr/^Can't "break" in a loop topicalizer/,
	    	q{Can't "break" in a loop topicalizer});
	}
	when (1) {
	    is($first, 1, "Implicitly lexical loop: first");
	    $first = 0;
	    # Implicit break is okay
	}
    }
}

{
    my $first = 1;
    my $_;
    for $_ (1, "two") {
	when ("two") {
	    is($first, 0, "Implicitly lexical, explicit \$_: second");
	    eval {break};
	    like($@, qr/^Can't "break" in a loop topicalizer/,
	    	q{Can't "break" in a loop topicalizer});
	}
	when (1) {
	    is($first, 1, "Implicitly lexical, explicit \$_: first");
	    $first = 0;
	    # Implicit break is okay
	}
    }
}

{
    my $first = 1;
    for my $_ (1, "two") {
	when ("two") {
	    is($first, 0, "Lexical loop: second");
	    eval {break};
	    like($@, qr/^Can't "break" in a loop topicalizer/,
	    	q{Can't "break" in a loop topicalizer});
	}
	when (1) {
	    is($first, 1, "Lexical loop: first");
	    $first = 0;
	    # Implicit break is okay
	}
    }
}


# Code references
{
    no warnings "redefine";
    my $called_foo = 0;
    sub foo {$called_foo = 1}
    my $called_bar = 0;
    sub bar {$called_bar = 1}
    my ($matched_foo, $matched_bar) = (0, 0);
    given(\&foo) {
	when(\&bar) {$matched_bar = 1}
	when(\&foo) {$matched_foo = 1}
    }
    is($called_foo, 0,  "Code ref comparison: foo not called");
    is($called_bar, 0,  "Code ref comparison: bar not called");
    is($matched_bar, 0, "Code ref didn't match different one");
    is($matched_foo, 1, "Code ref did match itself");
}

sub contains_x {
    my $x = shift;
    return ($x =~ /x/);
}
{
    my ($ok1, $ok2) = (0,0);
    given("foxy!") {
	when(contains_x($_))
	    { $ok1 = 1; continue }
	when(\&contains_x)
	    { $ok2 = 1; continue }
    }
    is($ok1, 1, "Calling sub directly (true)");
    is($ok2, 1, "Calling sub indirectly (true)");

    given("foggy") {
	when(contains_x($_))
	    { $ok1 = 2; continue }
	when(\&contains_x)
	    { $ok2 = 2; continue }
    }
    is($ok1, 1, "Calling sub directly (false)");
    is($ok2, 1, "Calling sub indirectly (false)");
}

SKIP: {
    skip "Scalar/Util.pm not yet available", 20
	unless -r "$INC[0]/Scalar/Util.pm";
    # Test overloading
    { package OverloadTest;

      use overload '""' => sub{"string value of obj"};

      use overload "~~" => sub {
	  my ($self, $other, $reversed) = @_;
	  if ($reversed) {
	      $self->{left}  = $other;
	      $self->{right} = $self;
	      $self->{reversed} = 1;
	  } else {
	      $self->{left}  = $self;
	      $self->{right} = $other;
	      $self->{reversed} = 0;
	  }
	  $self->{called} = 1;
	  return $self->{retval};
      };
    
      sub new {
	  my ($pkg, $retval) = @_;
	  bless {
		 called => 0,
		 retval => $retval,
		}, $pkg;
      }
  }

    {
	my $test = "Overloaded obj in given (true)";
	my $obj = OverloadTest->new(1);
	my $matched;
	given($obj) {
	    when ("other arg") {$matched = 1}
	    default {$matched = 0}
	}
    
	is($obj->{called},  1, "$test: called");
	ok($matched, "$test: matched");
	is($obj->{left}, "string value of obj", "$test: left");
	is($obj->{right}, "other arg", "$test: right");
	ok(!$obj->{reversed}, "$test: not reversed");
    }

    {
	my $test = "Overloaded obj in given (false)";
	my $obj = OverloadTest->new(0);
	my $matched;
	given($obj) {
	    when ("other arg") {$matched = 1}
	}
    
	is($obj->{called},  1, "$test: called");
	ok(!$matched, "$test: not matched");
	is($obj->{left}, "string value of obj", "$test: left");
	is($obj->{right}, "other arg", "$test: right");
	ok(!$obj->{reversed}, "$test: not reversed");
    }

    {
	my $test = "Overloaded obj in when (true)";
	my $obj = OverloadTest->new(1);
	my $matched;
	given("topic") {
	    when ($obj) {$matched = 1}
	    default {$matched = 0}
	}
    
	is($obj->{called},  1, "$test: called");
	ok($matched, "$test: matched");
	is($obj->{left}, "topic", "$test: left");
	is($obj->{right}, "string value of obj", "$test: right");
	ok($obj->{reversed}, "$test: reversed");
    }

    {
	my $test = "Overloaded obj in when (false)";
	my $obj = OverloadTest->new(0);
	my $matched;
	given("topic") {
	    when ($obj) {$matched = 1}
	    default {$matched = 0}
	}
    
	is($obj->{called}, 1, "$test: called");
	ok(!$matched, "$test: not matched");
	is($obj->{left}, "topic", "$test: left");
	is($obj->{right}, "string value of obj", "$test: right");
	ok($obj->{reversed}, "$test: reversed");
    }
}
# Okay, that'll do for now. The intricacies of the smartmatch
# semantics are tested in t/op/smartmatch.t
__END__
Commit	Line	Data
0d863452	1	#!./perl
	2
	3	BEGIN {
	4	chdir 't' if -d 't';
	5	@INC = '../lib';
	6	}
	7
	8	use strict;
	9	use warnings;
	10
1dcb720a	11	use Test::More tests => 111;
0d863452	12
	13	# The behaviour of the feature pragma should be tested by lib/switch.t
	14	# using the tests in t/lib/switch/*. This file tests the behaviour of
	15	# the switch ops themselves.
	16
	17
	18	use feature 'switch';
	19	no warnings "numeric";
	20
	21	eval { continue };
	22	like($@, qr/^Can't "continue" outside/, "continue outside");
	23
	24	eval { break };
	25	like($@, qr/^Can't "break" outside/, "break outside");
	26
	27	# Scoping rules
	28
	29	{
	30	my $x = "foo";
	31	given(my $x = "bar") {
	32	is($x, "bar", "given scope starts");
	33	}
	34	is($x, "foo", "given scope ends");
	35	}
	36
	37	sub be_true {1}
	38
	39	given(my $x = "foo") {
	40	when(be_true(my $x = "bar")) {
	41	is($x, "bar", "given scope starts");
	42	}
	43	is($x, "foo", "given scope ends");
	44	}
	45
	46	$_ = "outside";
	47	given("inside") { check_outside1() }
	48	sub check_outside1 { is($_, "outside", "\$_ lexically scoped") }
	49
	50	{
	51	my $_ = "outside";
	52	given("inside") { check_outside2() }
	53	sub check_outside2 {
	54	is($_, "outside", "\$_ lexically scoped (lexical \$_)")
	55	}
	56	}
	57
	58	# Basic string/numeric comparisons and control flow
	59
	60	{
cd9c531b	61	my $ok;
0d863452	62	given(3) {
cd9c531b	63	when(2) { $ok = 'two'; }
	64	when(3) { $ok = 'three'; }
	65	when(4) { $ok = 'four'; }
	66	default { $ok = 'd'; }
0d863452	67	}
cd9c531b	68	is($ok, 'three', "numeric comparison");
0d863452	69	}
	70
	71	{
cd9c531b	72	my $ok;
0d863452	73	use integer;
0d863452	74	given(3.14159265) {
cd9c531b	75	when(2) { $ok = 'two'; }
	76	when(3) { $ok = 'three'; }
	77	when(4) { $ok = 'four'; }
	78	default { $ok = 'd'; }
0d863452	79	}
cd9c531b	80	is($ok, 'three', "integer comparison");
0d863452	81	}
	82
	83	{
cd9c531b	84	my ($ok1, $ok2);
0d863452	85	given(3) {
cd9c531b	86	when(3.1) { $ok1 = 'n'; }
	87	when(3.0) { $ok1 = 'y'; continue }
	88	when("3.0") { $ok2 = 'y'; }
	89	default { $ok2 = 'n'; }
0d863452	90	}
cd9c531b	91	is($ok1, 'y', "more numeric (pt. 1)");
cd9c531b	92	is($ok2, 'y', "more numeric (pt. 2)");
0d863452	93	}
	94
	95	{
cd9c531b	96	my $ok;
0d863452	97	given("c") {
cd9c531b	98	when("b") { $ok = 'B'; }
	99	when("c") { $ok = 'C'; }
	100	when("d") { $ok = 'D'; }
	101	default { $ok = 'def'; }
0d863452	102	}
cd9c531b	103	is($ok, 'C', "string comparison");
0d863452	104	}
	105
	106	{
cd9c531b	107	my $ok;
0d863452	108	given("c") {
cd9c531b	109	when("b") { $ok = 'B'; }
	110	when("c") { $ok = 'C'; continue }
	111	when("c") { $ok = 'CC'; }
	112	default { $ok = 'D'; }
0d863452	113	}
cd9c531b	114	is($ok, 'CC', "simple continue");
0d863452	115	}
	116
	117	# Definedness
	118	{
	119	my $ok = 1;
	120	given (0) { when(undef) {$ok = 0} }
cd9c531b	121	is($ok, 1, "Given(0) when(undef)");
0d863452	122	}
	123	{
	124	my $undef;
	125	my $ok = 1;
	126	given (0) { when($undef) {$ok = 0} }
cd9c531b	127	is($ok, 1, 'Given(0) when($undef)');
0d863452	128	}
	129	{
	130	my $undef;
	131	my $ok = 0;
	132	given (0) { when($undef++) {$ok = 1} }
cd9c531b	133	is($ok, 1, "Given(0) when($undef++)");
0d863452	134	}
	135	{
	136	my $ok = 1;
	137	given (undef) { when(0) {$ok = 0} }
cd9c531b	138	is($ok, 1, "Given(undef) when(0)");
0d863452	139	}
	140	{
	141	my $undef;
	142	my $ok = 1;
	143	given ($undef) { when(0) {$ok = 0} }
cd9c531b	144	is($ok, 1, 'Given($undef) when(0)');
0d863452	145	}
	146	########
	147	{
	148	my $ok = 1;
	149	given ("") { when(undef) {$ok = 0} }
cd9c531b	150	is($ok, 1, 'Given("") when(undef)');
0d863452	151	}
	152	{
	153	my $undef;
	154	my $ok = 1;
	155	given ("") { when($undef) {$ok = 0} }
cd9c531b	156	is($ok, 1, 'Given("") when($undef)');
0d863452	157	}
	158	{
	159	my $ok = 1;
	160	given (undef) { when("") {$ok = 0} }
cd9c531b	161	is($ok, 1, 'Given(undef) when("")');
0d863452	162	}
	163	{
	164	my $undef;
	165	my $ok = 1;
	166	given ($undef) { when("") {$ok = 0} }
cd9c531b	167	is($ok, 1, 'Given($undef) when("")');
0d863452	168	}
	169	########
	170	{
	171	my $ok = 0;
	172	given (undef) { when(undef) {$ok = 1} }
cd9c531b	173	is($ok, 1, "Given(undef) when(undef)");
0d863452	174	}
	175	{
	176	my $undef;
	177	my $ok = 0;
	178	given (undef) { when($undef) {$ok = 1} }
cd9c531b	179	is($ok, 1, 'Given(undef) when($undef)');
0d863452	180	}
	181	{
	182	my $undef;
	183	my $ok = 0;
	184	given ($undef) { when(undef) {$ok = 1} }
cd9c531b	185	is($ok, 1, 'Given($undef) when(undef)');
0d863452	186	}
	187	{
	188	my $undef;
	189	my $ok = 0;
	190	given ($undef) { when($undef) {$ok = 1} }
cd9c531b	191	is($ok, 1, 'Given($undef) when($undef)');
0d863452	192	}
	193
	194
	195	# Regular expressions
	196	{
cd9c531b	197	my ($ok1, $ok2);
0d863452	198	given("Hello, world!") {
0d863452	199	when(/lo/)
cd9c531b	200	{ $ok1 = 'y'; continue}
0d863452	201	when(/no/)
cd9c531b	202	{ $ok1 = 'n'; continue}
0d863452	203	when(/^(Hello,\|Goodbye cruel) world[!.?]/)
cd9c531b	204	{ $ok2 = 'Y'; continue}
0d863452	205	when(/^(Hello cruel\|Goodbye,) world[!.?]/)
cd9c531b	206	{ $ok2 = 'n'; continue}
0d863452	207	}
cd9c531b	208	is($ok1, 'y', "regex 1");
cd9c531b	209	is($ok2, 'Y', "regex 2");
0d863452	210	}
	211
	212	# Comparisons
	213	{
	214	my $test = "explicit numeric comparison (<)";
	215	my $twenty_five = 25;
cd9c531b	216	my $ok;
0d863452	217	given($twenty_five) {
cd9c531b	218	when ($_ < 10) { $ok = "ten" }
	219	when ($_ < 20) { $ok = "twenty" }
	220	when ($_ < 30) { $ok = "thirty" }
	221	when ($_ < 40) { $ok = "forty" }
	222	default { $ok = "default" }
0d863452	223	}
cd9c531b	224	is($ok, "thirty", $test);
0d863452	225	}
	226
	227	{
	228	use integer;
	229	my $test = "explicit numeric comparison (integer <)";
	230	my $twenty_five = 25;
cd9c531b	231	my $ok;
0d863452	232	given($twenty_five) {
cd9c531b	233	when ($_ < 10) { $ok = "ten" }
	234	when ($_ < 20) { $ok = "twenty" }
	235	when ($_ < 30) { $ok = "thirty" }
	236	when ($_ < 40) { $ok = "forty" }
	237	default { $ok = "default" }
0d863452	238	}
cd9c531b	239	is($ok, "thirty", $test);
0d863452	240	}
	241
	242	{
	243	my $test = "explicit numeric comparison (<=)";
	244	my $twenty_five = 25;
cd9c531b	245	my $ok;
0d863452	246	given($twenty_five) {
cd9c531b	247	when ($_ <= 10) { $ok = "ten" }
	248	when ($_ <= 20) { $ok = "twenty" }
	249	when ($_ <= 30) { $ok = "thirty" }
	250	when ($_ <= 40) { $ok = "forty" }
	251	default { $ok = "default" }
0d863452	252	}
cd9c531b	253	is($ok, "thirty", $test);
0d863452	254	}
	255
	256	{
	257	use integer;
	258	my $test = "explicit numeric comparison (integer <=)";
	259	my $twenty_five = 25;
cd9c531b	260	my $ok;
0d863452	261	given($twenty_five) {
cd9c531b	262	when ($_ <= 10) { $ok = "ten" }
	263	when ($_ <= 20) { $ok = "twenty" }
	264	when ($_ <= 30) { $ok = "thirty" }
	265	when ($_ <= 40) { $ok = "forty" }
	266	default { $ok = "default" }
0d863452	267	}
cd9c531b	268	is($ok, "thirty", $test);
0d863452	269	}
	270
	271
	272	{
	273	my $test = "explicit numeric comparison (>)";
	274	my $twenty_five = 25;
cd9c531b	275	my $ok;
0d863452	276	given($twenty_five) {
cd9c531b	277	when ($_ > 40) { $ok = "forty" }
	278	when ($_ > 30) { $ok = "thirty" }
	279	when ($_ > 20) { $ok = "twenty" }
	280	when ($_ > 10) { $ok = "ten" }
	281	default { $ok = "default" }
0d863452	282	}
cd9c531b	283	is($ok, "twenty", $test);
0d863452	284	}
	285
	286	{
	287	my $test = "explicit numeric comparison (>=)";
	288	my $twenty_five = 25;
cd9c531b	289	my $ok;
0d863452	290	given($twenty_five) {
cd9c531b	291	when ($_ >= 40) { $ok = "forty" }
	292	when ($_ >= 30) { $ok = "thirty" }
	293	when ($_ >= 20) { $ok = "twenty" }
	294	when ($_ >= 10) { $ok = "ten" }
	295	default { $ok = "default" }
0d863452	296	}
cd9c531b	297	is($ok, "twenty", $test);
0d863452	298	}
	299
	300	{
	301	use integer;
	302	my $test = "explicit numeric comparison (integer >)";
	303	my $twenty_five = 25;
cd9c531b	304	my $ok;
0d863452	305	given($twenty_five) {
cd9c531b	306	when ($_ > 40) { $ok = "forty" }
	307	when ($_ > 30) { $ok = "thirty" }
	308	when ($_ > 20) { $ok = "twenty" }
	309	when ($_ > 10) { $ok = "ten" }
	310	default { $ok = "default" }
0d863452	311	}
cd9c531b	312	is($ok, "twenty", $test);
0d863452	313	}
	314
	315	{
	316	use integer;
	317	my $test = "explicit numeric comparison (integer >=)";
	318	my $twenty_five = 25;
cd9c531b	319	my $ok;
0d863452	320	given($twenty_five) {
cd9c531b	321	when ($_ >= 40) { $ok = "forty" }
	322	when ($_ >= 30) { $ok = "thirty" }
	323	when ($_ >= 20) { $ok = "twenty" }
	324	when ($_ >= 10) { $ok = "ten" }
	325	default { $ok = "default" }
0d863452	326	}
cd9c531b	327	is($ok, "twenty", $test);
0d863452	328	}
	329
	330
	331	{
	332	my $test = "explicit string comparison (lt)";
	333	my $twenty_five = "25";
cd9c531b	334	my $ok;
0d863452	335	given($twenty_five) {
cd9c531b	336	when ($_ lt "10") { $ok = "ten" }
	337	when ($_ lt "20") { $ok = "twenty" }
	338	when ($_ lt "30") { $ok = "thirty" }
	339	when ($_ lt "40") { $ok = "forty" }
	340	default { $ok = "default" }
0d863452	341	}
cd9c531b	342	is($ok, "thirty", $test);
0d863452	343	}
	344
	345	{
	346	my $test = "explicit string comparison (le)";
	347	my $twenty_five = "25";
cd9c531b	348	my $ok;
0d863452	349	given($twenty_five) {
cd9c531b	350	when ($_ le "10") { $ok = "ten" }
	351	when ($_ le "20") { $ok = "twenty" }
	352	when ($_ le "30") { $ok = "thirty" }
	353	when ($_ le "40") { $ok = "forty" }
	354	default { $ok = "default" }
0d863452	355	}
cd9c531b	356	is($ok, "thirty", $test);
0d863452	357	}
	358
	359	{
	360	my $test = "explicit string comparison (gt)";
	361	my $twenty_five = 25;
cd9c531b	362	my $ok;
0d863452	363	given($twenty_five) {
cd9c531b	364	when ($_ ge "40") { $ok = "forty" }
	365	when ($_ ge "30") { $ok = "thirty" }
	366	when ($_ ge "20") { $ok = "twenty" }
	367	when ($_ ge "10") { $ok = "ten" }
	368	default { $ok = "default" }
0d863452	369	}
cd9c531b	370	is($ok, "twenty", $test);
0d863452	371	}
	372
	373	{
	374	my $test = "explicit string comparison (ge)";
	375	my $twenty_five = 25;
cd9c531b	376	my $ok;
0d863452	377	given($twenty_five) {
cd9c531b	378	when ($_ ge "40") { $ok = "forty" }
	379	when ($_ ge "30") { $ok = "thirty" }
	380	when ($_ ge "20") { $ok = "twenty" }
	381	when ($_ ge "10") { $ok = "ten" }
	382	default { $ok = "default" }
0d863452	383	}
cd9c531b	384	is($ok, "twenty", $test);
0d863452	385	}
	386
	387	# Make sure it still works with a lexical $_:
	388	{
	389	my $_;
	390	my $test = "explicit comparison with lexical \$_";
	391	my $twenty_five = 25;
cd9c531b	392	my $ok;
0d863452	393	given($twenty_five) {
cd9c531b	394	when ($_ ge "40") { $ok = "forty" }
	395	when ($_ ge "30") { $ok = "thirty" }
	396	when ($_ ge "20") { $ok = "twenty" }
	397	when ($_ ge "10") { $ok = "ten" }
	398	default { $ok = "default" }
0d863452	399	}
cd9c531b	400	is($ok, "twenty", $test);
0d863452	401	}
	402
	403	# Optimized-away comparisons
	404	{
cd9c531b	405	my $ok;
0d863452	406	given(23) {
cd9c531b	407	when (2 + 2 == 4) { $ok = 'y'; continue }
cd9c531b	408	when (2 + 2 == 5) { $ok = 'n' }
0d863452	409	}
cd9c531b	410	is($ok, 'y', "Optimized-away comparison");
0d863452	411	}
	412
	413	# File tests
	414	# (How to be both thorough and portable? Pinch a few ideas
	415	# from t/op/filetest.t. We err on the side of portability for
	416	# the time being.)
	417
	418	{
	419	my ($ok_d, $ok_f, $ok_r);
	420	given("op") {
	421	when(-d) {$ok_d = 1; continue}
	422	when(!-f) {$ok_f = 1; continue}
	423	when(-r) {$ok_r = 1; continue}
	424	}
	425	ok($ok_d, "Filetest -d");
	426	ok($ok_f, "Filetest -f");
	427	ok($ok_r, "Filetest -r");
	428	}
	429
	430	# Sub and method calls
	431	sub bar {"bar"}
	432	{
	433	my $ok = 0;
	434	given("foo") {
	435	when(bar()) {$ok = 1}
	436	}
	437	ok($ok, "Sub call acts as boolean")
	438	}
	439
	440	{
	441	my $ok = 0;
	442	given("foo") {
	443	when(main->bar()) {$ok = 1}
	444	}
	445	ok($ok, "Class-method call acts as boolean")
	446	}
	447
	448	{
	449	my $ok = 0;
	450	my $obj = bless [];
	451	given("foo") {
	452	when($obj->bar()) {$ok = 1}
	453	}
	454	ok($ok, "Object-method call acts as boolean")
	455	}
	456
	457	# Other things that should not be smart matched
	458	{
	459	my $ok = 0;
1e1d4b91	460	given(12) {
	461	when( /(\d+)/ and ( 1 <= $1 and $1 <= 12 ) ) {
	462	$ok = 1;
	463	}
	464	}
	465	ok($ok, "bool not smartmatches");
	466	}
	467
	468	{
	469	my $ok = 0;
0d863452	470	given(0) {
	471	when(eof(DATA)) {
	472	$ok = 1;
	473	}
	474	}
	475	ok($ok, "eof() not smartmatched");
	476	}
	477
	478	{
	479	my $ok = 0;
	480	my %foo = ("bar", 0);
	481	given(0) {
	482	when(exists $foo{bar}) {
	483	$ok = 1;
	484	}
	485	}
	486	ok($ok, "exists() not smartmatched");
	487	}
	488
	489	{
	490	my $ok = 0;
	491	given(0) {
	492	when(defined $ok) {
	493	$ok = 1;
	494	}
	495	}
	496	ok($ok, "defined() not smartmatched");
	497	}
	498
	499	{
	500	my $ok = 1;
	501	given("foo") {
	502	when((1 == 1) && "bar") {
	503	$ok = 0;
	504	}
	505	when((1 == 1) && $_ eq "foo") {
	506	$ok = 2;
	507	}
	508	}
	509	is($ok, 2, "((1 == 1) && \"bar\") not smartmatched");
	510	}
	511
	512	{
1e1d4b91	513	my $ok = 0;
1e1d4b91	514	given("foo") {
0d863452	515	when((1 == $ok) \|\| "foo") {
1e1d4b91	516	$ok = 1;
0d863452	517	}
0d863452	518	}
1e1d4b91	519	ok($ok, '((1 == $ok) \|\| "foo") smartmatched');
0d863452	520	}
0d863452	521
1dcb720a	522	TODO: {
	523	local $TODO = "RT #50538: when( \@n && \%n ) fails to smart match";
	524	{ # this should smart match on each side of &&
	525	my @n = qw(fred barney betty);
	526	my @m = @n;
	527
	528	my $ok = 0;
	529	given( "fred" ) {
	530	when( @n ) {
	531	$ok++; continue;
	532	}
	533	when( @m ) {
	534	$ok++; continue;
	535	}
	536	when( @m && @n ) {
	537	$ok++;
	538	}
	539	}
	540
	541	is($ok, 3, '(@n && @m) smart-matched');
	542	}
	543
	544	{ # this should smart match on each side of &&
	545	my @n = qw(fred barney betty);
	546	my %n = map { $_, 1 } @n;
	547
	548	my $ok = 0;
	549	given( "fred" ) {
	550	when( @n ) {
	551	$ok++; continue;
	552	}
	553	when( %n ) {
	554	$ok++; continue;
	555	}
	556	when( @n && %n ) {
	557	$ok++;
	558	}
	559	}
	560
	561	is($ok, 3, '(@n && %n) smart-matched');
	562	}
	563
	564	{ # this should smart match on each side of &&
	565	my %n = map { $_, 1 } qw(fred barney betty);
	566	my %m = %n;
	567
	568	my $ok = 0;
	569	given( "fred" ) {
	570	when( %m ) {
	571	$ok++; continue;
	572	}
	573	when( %n ) {
	574	$ok++; continue;
	575	}
	576	when( %m && %n ) {
	577	$ok++;
	578	}
	579	}
	580
	581	is($ok, 3, '(%m && %n) smart-matched');
	582	}
	583	}
0d863452	584
	585	# Make sure we aren't invoking the get-magic more than once
	586
	587	{ # A helper class to count the number of accesses.
	588	package FetchCounter;
	589	sub TIESCALAR {
	590	my ($class) = @_;
	591	bless {value => undef, count => 0}, $class;
	592	}
	593	sub STORE {
	594	my ($self, $val) = @_;
	595	$self->{count} = 0;
	596	$self->{value} = $val;
	597	}
	598	sub FETCH {
	599	my ($self) = @_;
	600	# Avoid pre/post increment here
	601	$self->{count} = 1 + $self->{count};
	602	$self->{value};
	603	}
	604	sub count {
	605	my ($self) = @_;
	606	$self->{count};
	607	}
	608	}
	609
	610	my $f = tie my $v, "FetchCounter";
	611
	612	{ my $test_name = "Only one FETCH (in given)";
cd9c531b	613	my $ok;
0d863452	614	given($v = 23) {
	615	when(undef) {}
	616	when(sub{0}->()) {}
	617	when(21) {}
	618	when("22") {}
	619	when(23) {$ok = 1}
	620	when(/24/) {$ok = 0}
	621	}
cd9c531b	622	is($ok, 1, "precheck: $test_name");
0d863452	623	is($f->count(), 1, $test_name);
	624	}
	625
	626	{ my $test_name = "Only one FETCH (numeric when)";
cd9c531b	627	my $ok;
0d863452	628	$v = 23;
	629	is($f->count(), 0, "Sanity check: $test_name");
	630	given(23) {
	631	when(undef) {}
	632	when(sub{0}->()) {}
	633	when(21) {}
	634	when("22") {}
	635	when($v) {$ok = 1}
	636	when(/24/) {$ok = 0}
	637	}
cd9c531b	638	is($ok, 1, "precheck: $test_name");
0d863452	639	is($f->count(), 1, $test_name);
	640	}
	641
	642	{ my $test_name = "Only one FETCH (string when)";
cd9c531b	643	my $ok;
0d863452	644	$v = "23";
	645	is($f->count(), 0, "Sanity check: $test_name");
	646	given("23") {
	647	when(undef) {}
	648	when(sub{0}->()) {}
	649	when("21") {}
	650	when("22") {}
	651	when($v) {$ok = 1}
	652	when(/24/) {$ok = 0}
	653	}
cd9c531b	654	is($ok, 1, "precheck: $test_name");
0d863452	655	is($f->count(), 1, $test_name);
	656	}
	657
	658	{ my $test_name = "Only one FETCH (undef)";
cd9c531b	659	my $ok;
0d863452	660	$v = undef;
	661	is($f->count(), 0, "Sanity check: $test_name");
	662	given(my $undef) {
	663	when(sub{0}->()) {}
	664	when("21") {}
	665	when("22") {}
	666	when($v) {$ok = 1}
	667	when(undef) {$ok = 0}
	668	}
cd9c531b	669	is($ok, 1, "precheck: $test_name");
0d863452	670	is($f->count(), 1, $test_name);
	671	}
	672
	673	# Loop topicalizer
	674	{
	675	my $first = 1;
	676	for (1, "two") {
	677	when ("two") {
	678	is($first, 0, "Loop: second");
	679	eval {break};
	680	like($@, qr/^Can't "break" in a loop topicalizer/,
	681	q{Can't "break" in a loop topicalizer});
	682	}
	683	when (1) {
	684	is($first, 1, "Loop: first");
	685	$first = 0;
	686	# Implicit break is okay
	687	}
	688	}
	689	}
	690
	691	{
	692	my $first = 1;
	693	for $_ (1, "two") {
	694	when ("two") {
	695	is($first, 0, "Explicit \$_: second");
	696	eval {break};
	697	like($@, qr/^Can't "break" in a loop topicalizer/,
	698	q{Can't "break" in a loop topicalizer});
	699	}
	700	when (1) {
	701	is($first, 1, "Explicit \$_: first");
	702	$first = 0;
	703	# Implicit break is okay
	704	}
	705	}
	706	}
	707
	708	{
	709	my $first = 1;
	710	my $_;
	711	for (1, "two") {
	712	when ("two") {
	713	is($first, 0, "Implicitly lexical loop: second");
	714	eval {break};
	715	like($@, qr/^Can't "break" in a loop topicalizer/,
	716	q{Can't "break" in a loop topicalizer});
	717	}
	718	when (1) {
	719	is($first, 1, "Implicitly lexical loop: first");
	720	$first = 0;
	721	# Implicit break is okay
	722	}
	723	}
	724	}
	725
	726	{
	727	my $first = 1;
	728	my $_;
	729	for $_ (1, "two") {
	730	when ("two") {
	731	is($first, 0, "Implicitly lexical, explicit \$_: second");
	732	eval {break};
	733	like($@, qr/^Can't "break" in a loop topicalizer/,
734	q{Can't "break" in a loop topicalizer});
735	}
736	when (1) {
737	is($first, 1, "Implicitly lexical, explicit \$_: first");
738	$first = 0;
739	# Implicit break is okay
740	}
741	}
742	}
743
744	{
745	my $first = 1;
746	for my $_ (1, "two") {
747	when ("two") {
748	is($first, 0, "Lexical loop: second");
749	eval {break};
750	like($@, qr/^Can't "break" in a loop topicalizer/,
751	q{Can't "break" in a loop topicalizer});
752	}
753	when (1) {
1dcb720a	754	is($first, 1, "Lexical loop: first");
0d863452	755	$first = 0;
	756	# Implicit break is okay
	757	}
	758	}
	759	}
	760
	761
	762	# Code references
	763	{
	764	no warnings "redefine";
	765	my $called_foo = 0;
	766	sub foo {$called_foo = 1}
	767	my $called_bar = 0;
	768	sub bar {$called_bar = 1}
	769	my ($matched_foo, $matched_bar) = (0, 0);
	770	given(\&foo) {
	771	when(\&bar) {$matched_bar = 1}
	772	when(\&foo) {$matched_foo = 1}
	773	}
	774	is($called_foo, 0, "Code ref comparison: foo not called");
	775	is($called_bar, 0, "Code ref comparison: bar not called");
	776	is($matched_bar, 0, "Code ref didn't match different one");
	777	is($matched_foo, 1, "Code ref did match itself");
	778	}
	779
	780	sub contains_x {
	781	my $x = shift;
	782	return ($x =~ /x/);
	783	}
	784	{
	785	my ($ok1, $ok2) = (0,0);
	786	given("foxy!") {
	787	when(contains_x($_))
	788	{ $ok1 = 1; continue }
	789	when(\&contains_x)
	790	{ $ok2 = 1; continue }
	791	}
	792	is($ok1, 1, "Calling sub directly (true)");
	793	is($ok2, 1, "Calling sub indirectly (true)");
	794
	795	given("foggy") {
	796	when(contains_x($_))
	797	{ $ok1 = 2; continue }
	798	when(\&contains_x)
	799	{ $ok2 = 2; continue }
	800	}
	801	is($ok1, 1, "Calling sub directly (false)");
	802	is($ok2, 1, "Calling sub indirectly (false)");
	803	}
	804
02eafbe2	805	SKIP: {
	806	skip "Scalar/Util.pm not yet available", 20
	807	unless -r "$INC[0]/Scalar/Util.pm";
	808	# Test overloading
	809	{ package OverloadTest;
	810
	811	use overload '""' => sub{"string value of obj"};
	812
	813	use overload "~~" => sub {
	814	my ($self, $other, $reversed) = @_;
	815	if ($reversed) {
	816	$self->{left} = $other;
	817	$self->{right} = $self;
	818	$self->{reversed} = 1;
	819	} else {
	820	$self->{left} = $self;
	821	$self->{right} = $other;
	822	$self->{reversed} = 0;
	823	}
	824	$self->{called} = 1;
	825	return $self->{retval};
	826	};
0d863452	827
02eafbe2	828	sub new {
	829	my ($pkg, $retval) = @_;
	830	bless {
	831	called => 0,
	832	retval => $retval,
	833	}, $pkg;
	834	}
	835	}
	836
	837	{
	838	my $test = "Overloaded obj in given (true)";
	839	my $obj = OverloadTest->new(1);
	840	my $matched;
	841	given($obj) {
	842	when ("other arg") {$matched = 1}
	843	default {$matched = 0}
	844	}
0d863452	845
02eafbe2	846	is($obj->{called}, 1, "$test: called");
	847	ok($matched, "$test: matched");
	848	is($obj->{left}, "string value of obj", "$test: left");
	849	is($obj->{right}, "other arg", "$test: right");
	850	ok(!$obj->{reversed}, "$test: not reversed");
	851	}
	852
	853	{
	854	my $test = "Overloaded obj in given (false)";
	855	my $obj = OverloadTest->new(0);
	856	my $matched;
	857	given($obj) {
	858	when ("other arg") {$matched = 1}
	859	}
0d863452	860
02eafbe2	861	is($obj->{called}, 1, "$test: called");
	862	ok(!$matched, "$test: not matched");
	863	is($obj->{left}, "string value of obj", "$test: left");
	864	is($obj->{right}, "other arg", "$test: right");
	865	ok(!$obj->{reversed}, "$test: not reversed");
	866	}
	867
	868	{
	869	my $test = "Overloaded obj in when (true)";
	870	my $obj = OverloadTest->new(1);
	871	my $matched;
	872	given("topic") {
	873	when ($obj) {$matched = 1}
	874	default {$matched = 0}
	875	}
0d863452	876
02eafbe2	877	is($obj->{called}, 1, "$test: called");
	878	ok($matched, "$test: matched");
	879	is($obj->{left}, "topic", "$test: left");
	880	is($obj->{right}, "string value of obj", "$test: right");
	881	ok($obj->{reversed}, "$test: reversed");
	882	}
	883
	884	{
	885	my $test = "Overloaded obj in when (false)";
	886	my $obj = OverloadTest->new(0);
	887	my $matched;
	888	given("topic") {
	889	when ($obj) {$matched = 1}
	890	default {$matched = 0}
	891	}
0d863452	892
02eafbe2	893	is($obj->{called}, 1, "$test: called");
	894	ok(!$matched, "$test: not matched");
	895	is($obj->{left}, "topic", "$test: left");
	896	is($obj->{right}, "string value of obj", "$test: right");
	897	ok($obj->{reversed}, "$test: reversed");
	898	}
0d863452	899	}
0d863452	900	# Okay, that'll do for now. The intricacies of the smartmatch
	901	# semantics are tested in t/op/smartmatch.t
	902	__END__