[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 => 113;

# 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 notfoo {"bar"}
{
    my $ok = 0;
    given("foo") {
	when(notfoo()) {$ok = 1}
    }
    ok($ok, "Sub call acts as boolean")
}

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

{
    my $ok = 0;
    my $obj = bless [];
    given("foo") {
	when($obj->notfoo()) {$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 $n = 0;
    for my $l qw(a b c d) {
	given ($l) {
	    when ($_ eq "b" ... $_ eq "c") { $n = 1 }
	    default { $n = 0 }
	}
	ok(($n xor $l =~ /[ad]/), 'when(E1...E2) evaluates in boolean context');
    }
}

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

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

# 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; "@_" eq "foo"}
    my $called_bar = 0;
    sub bar {$called_bar = 1; "@_" eq "bar"}
    my ($matched_foo, $matched_bar) = (0, 0);
    given("foo") {
	when(\&bar) {$matched_bar = 1}
	when(\&foo) {$matched_foo = 1}
    }
    is($called_foo, 1,  "foo() was called");
    is($called_bar, 1,  "bar() was called");
    is($matched_bar, 0, "bar didn't match");
    is($matched_foo, 1, "foo did match");
}

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
6e03d743	11	use Test::More tests => 113;
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
84c82fbf	431	sub notfoo {"bar"}
0d863452	432	{
	433	my $ok = 0;
	434	given("foo") {
84c82fbf	435	when(notfoo()) {$ok = 1}
0d863452	436	}
	437	ok($ok, "Sub call acts as boolean")
	438	}
	439
	440	{
	441	my $ok = 0;
	442	given("foo") {
84c82fbf	443	when(main->notfoo()) {$ok = 1}
0d863452	444	}
	445	ok($ok, "Class-method call acts as boolean")
	446	}
	447
	448	{
	449	my $ok = 0;
	450	my $obj = bless [];
	451	given("foo") {
84c82fbf	452	when($obj->notfoo()) {$ok = 1}
0d863452	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	{
6e03d743	513	my $n = 0;
	514	for my $l qw(a b c d) {
	515	given ($l) {
	516	when ($_ eq "b" ... $_ eq "c") { $n = 1 }
	517	default { $n = 0 }
	518	}
	519	ok(($n xor $l =~ /[ad]/), 'when(E1...E2) evaluates in boolean context');
	520	}
	521	}
	522
	523	{
1e1d4b91	524	my $ok = 0;
1e1d4b91	525	given("foo") {
0d863452	526	when((1 == $ok) \|\| "foo") {
1e1d4b91	527	$ok = 1;
0d863452	528	}
0d863452	529	}
1e1d4b91	530	ok($ok, '((1 == $ok) \|\| "foo") smartmatched');
0d863452	531	}
0d863452	532
f92e1a16	533	{
	534	my $ok = 0;
	535	given("foo") {
	536	when((1 == $ok \|\| undef) // "foo") {
	537	$ok = 1;
	538	}
	539	}
	540	ok($ok, '((1 == $ok \|\| undef) // "foo") smartmatched');
	541	}
	542
0d863452	543	# Make sure we aren't invoking the get-magic more than once
	544
	545	{ # A helper class to count the number of accesses.
	546	package FetchCounter;
	547	sub TIESCALAR {
	548	my ($class) = @_;
	549	bless {value => undef, count => 0}, $class;
	550	}
	551	sub STORE {
	552	my ($self, $val) = @_;
	553	$self->{count} = 0;
	554	$self->{value} = $val;
	555	}
	556	sub FETCH {
	557	my ($self) = @_;
	558	# Avoid pre/post increment here
	559	$self->{count} = 1 + $self->{count};
	560	$self->{value};
	561	}
	562	sub count {
	563	my ($self) = @_;
	564	$self->{count};
	565	}
	566	}
	567
	568	my $f = tie my $v, "FetchCounter";
	569
	570	{ my $test_name = "Only one FETCH (in given)";
cd9c531b	571	my $ok;
0d863452	572	given($v = 23) {
	573	when(undef) {}
	574	when(sub{0}->()) {}
	575	when(21) {}
	576	when("22") {}
	577	when(23) {$ok = 1}
	578	when(/24/) {$ok = 0}
	579	}
cd9c531b	580	is($ok, 1, "precheck: $test_name");
0d863452	581	is($f->count(), 1, $test_name);
	582	}
	583
	584	{ my $test_name = "Only one FETCH (numeric when)";
cd9c531b	585	my $ok;
0d863452	586	$v = 23;
	587	is($f->count(), 0, "Sanity check: $test_name");
	588	given(23) {
	589	when(undef) {}
	590	when(sub{0}->()) {}
	591	when(21) {}
	592	when("22") {}
	593	when($v) {$ok = 1}
	594	when(/24/) {$ok = 0}
	595	}
cd9c531b	596	is($ok, 1, "precheck: $test_name");
0d863452	597	is($f->count(), 1, $test_name);
	598	}
	599
	600	{ my $test_name = "Only one FETCH (string when)";
cd9c531b	601	my $ok;
0d863452	602	$v = "23";
	603	is($f->count(), 0, "Sanity check: $test_name");
	604	given("23") {
	605	when(undef) {}
	606	when(sub{0}->()) {}
	607	when("21") {}
	608	when("22") {}
	609	when($v) {$ok = 1}
	610	when(/24/) {$ok = 0}
	611	}
cd9c531b	612	is($ok, 1, "precheck: $test_name");
0d863452	613	is($f->count(), 1, $test_name);
	614	}
	615
	616	{ my $test_name = "Only one FETCH (undef)";
cd9c531b	617	my $ok;
0d863452	618	$v = undef;
	619	is($f->count(), 0, "Sanity check: $test_name");
	620	given(my $undef) {
	621	when(sub{0}->()) {}
	622	when("21") {}
	623	when("22") {}
	624	when($v) {$ok = 1}
	625	when(undef) {$ok = 0}
	626	}
cd9c531b	627	is($ok, 1, "precheck: $test_name");
0d863452	628	is($f->count(), 1, $test_name);
	629	}
	630
	631	# Loop topicalizer
	632	{
	633	my $first = 1;
	634	for (1, "two") {
	635	when ("two") {
	636	is($first, 0, "Loop: second");
	637	eval {break};
	638	like($@, qr/^Can't "break" in a loop topicalizer/,
	639	q{Can't "break" in a loop topicalizer});
	640	}
	641	when (1) {
	642	is($first, 1, "Loop: first");
	643	$first = 0;
	644	# Implicit break is okay
	645	}
	646	}
	647	}
	648
	649	{
	650	my $first = 1;
	651	for $_ (1, "two") {
	652	when ("two") {
	653	is($first, 0, "Explicit \$_: second");
	654	eval {break};
	655	like($@, qr/^Can't "break" in a loop topicalizer/,
	656	q{Can't "break" in a loop topicalizer});
	657	}
	658	when (1) {
	659	is($first, 1, "Explicit \$_: first");
	660	$first = 0;
	661	# Implicit break is okay
	662	}
	663	}
	664	}
	665
	666	{
	667	my $first = 1;
	668	my $_;
	669	for (1, "two") {
	670	when ("two") {
	671	is($first, 0, "Implicitly lexical loop: second");
	672	eval {break};
	673	like($@, qr/^Can't "break" in a loop topicalizer/,
	674	q{Can't "break" in a loop topicalizer});
	675	}
	676	when (1) {
	677	is($first, 1, "Implicitly lexical loop: first");
	678	$first = 0;
	679	# Implicit break is okay
	680	}
	681	}
	682	}
	683
	684	{
	685	my $first = 1;
	686	my $_;
	687	for $_ (1, "two") {
	688	when ("two") {
	689	is($first, 0, "Implicitly lexical, explicit \$_: second");
	690	eval {break};
	691	like($@, qr/^Can't "break" in a loop topicalizer/,
692	q{Can't "break" in a loop topicalizer});
693	}
694	when (1) {
695	is($first, 1, "Implicitly lexical, explicit \$_: first");
696	$first = 0;
697	# Implicit break is okay
698	}
699	}
700	}
701
702	{
703	my $first = 1;
704	for my $_ (1, "two") {
705	when ("two") {
706	is($first, 0, "Lexical loop: second");
707	eval {break};
708	like($@, qr/^Can't "break" in a loop topicalizer/,
709	q{Can't "break" in a loop topicalizer});
710	}
711	when (1) {
1dcb720a	712	is($first, 1, "Lexical loop: first");
0d863452	713	$first = 0;
	714	# Implicit break is okay
	715	}
	716	}
	717	}
	718
	719
	720	# Code references
	721	{
	722	no warnings "redefine";
	723	my $called_foo = 0;
84c82fbf	724	sub foo {$called_foo = 1; "@_" eq "foo"}
0d863452	725	my $called_bar = 0;
84c82fbf	726	sub bar {$called_bar = 1; "@_" eq "bar"}
0d863452	727	my ($matched_foo, $matched_bar) = (0, 0);
84c82fbf	728	given("foo") {
0d863452	729	when(\&bar) {$matched_bar = 1}
	730	when(\&foo) {$matched_foo = 1}
	731	}
84c82fbf	732	is($called_foo, 1, "foo() was called");
	733	is($called_bar, 1, "bar() was called");
	734	is($matched_bar, 0, "bar didn't match");
	735	is($matched_foo, 1, "foo did match");
0d863452	736	}
	737
	738	sub contains_x {
	739	my $x = shift;
	740	return ($x =~ /x/);
	741	}
	742	{
	743	my ($ok1, $ok2) = (0,0);
	744	given("foxy!") {
	745	when(contains_x($_))
	746	{ $ok1 = 1; continue }
	747	when(\&contains_x)
	748	{ $ok2 = 1; continue }
	749	}
	750	is($ok1, 1, "Calling sub directly (true)");
	751	is($ok2, 1, "Calling sub indirectly (true)");
	752
	753	given("foggy") {
	754	when(contains_x($_))
	755	{ $ok1 = 2; continue }
	756	when(\&contains_x)
	757	{ $ok2 = 2; continue }
	758	}
	759	is($ok1, 1, "Calling sub directly (false)");
	760	is($ok2, 1, "Calling sub indirectly (false)");
	761	}
	762
02eafbe2	763	SKIP: {
	764	skip "Scalar/Util.pm not yet available", 20
	765	unless -r "$INC[0]/Scalar/Util.pm";
	766	# Test overloading
	767	{ package OverloadTest;
	768
	769	use overload '""' => sub{"string value of obj"};
	770
	771	use overload "~~" => sub {
	772	my ($self, $other, $reversed) = @_;
	773	if ($reversed) {
	774	$self->{left} = $other;
	775	$self->{right} = $self;
	776	$self->{reversed} = 1;
	777	} else {
	778	$self->{left} = $self;
	779	$self->{right} = $other;
	780	$self->{reversed} = 0;
	781	}
	782	$self->{called} = 1;
	783	return $self->{retval};
	784	};
0d863452	785
02eafbe2	786	sub new {
	787	my ($pkg, $retval) = @_;
	788	bless {
	789	called => 0,
	790	retval => $retval,
	791	}, $pkg;
	792	}
	793	}
	794
	795	{
	796	my $test = "Overloaded obj in given (true)";
	797	my $obj = OverloadTest->new(1);
	798	my $matched;
	799	given($obj) {
	800	when ("other arg") {$matched = 1}
	801	default {$matched = 0}
	802	}
0d863452	803
02eafbe2	804	is($obj->{called}, 1, "$test: called");
	805	ok($matched, "$test: matched");
	806	is($obj->{left}, "string value of obj", "$test: left");
	807	is($obj->{right}, "other arg", "$test: right");
	808	ok(!$obj->{reversed}, "$test: not reversed");
	809	}
	810
	811	{
	812	my $test = "Overloaded obj in given (false)";
	813	my $obj = OverloadTest->new(0);
	814	my $matched;
	815	given($obj) {
	816	when ("other arg") {$matched = 1}
	817	}
0d863452	818
02eafbe2	819	is($obj->{called}, 1, "$test: called");
	820	ok(!$matched, "$test: not matched");
	821	is($obj->{left}, "string value of obj", "$test: left");
	822	is($obj->{right}, "other arg", "$test: right");
	823	ok(!$obj->{reversed}, "$test: not reversed");
	824	}
	825
	826	{
	827	my $test = "Overloaded obj in when (true)";
	828	my $obj = OverloadTest->new(1);
	829	my $matched;
	830	given("topic") {
	831	when ($obj) {$matched = 1}
	832	default {$matched = 0}
	833	}
0d863452	834
02eafbe2	835	is($obj->{called}, 1, "$test: called");
	836	ok($matched, "$test: matched");
	837	is($obj->{left}, "topic", "$test: left");
	838	is($obj->{right}, "string value of obj", "$test: right");
	839	ok($obj->{reversed}, "$test: reversed");
	840	}
	841
	842	{
	843	my $test = "Overloaded obj in when (false)";
	844	my $obj = OverloadTest->new(0);
	845	my $matched;
	846	given("topic") {
	847	when ($obj) {$matched = 1}
	848	default {$matched = 0}
	849	}
0d863452	850
02eafbe2	851	is($obj->{called}, 1, "$test: called");
	852	ok(!$matched, "$test: not matched");
	853	is($obj->{left}, "topic", "$test: left");
	854	is($obj->{right}, "string value of obj", "$test: right");
	855	ok($obj->{reversed}, "$test: reversed");
	856	}
0d863452	857	}
0d863452	858	# Okay, that'll do for now. The intricacies of the smartmatch
	859	# semantics are tested in t/op/smartmatch.t
	860	__END__