1#!perl 2 3print "1..43\n"; 4my $test = 0; 5 6sub failed { 7 my ($got, $expected, $name) = @_; 8 9 print "not ok $test - $name\n"; 10 my @caller = caller(1); 11 print "# Failed test at $caller[1] line $caller[2]\n"; 12 if (defined $got) { 13 print "# Got '$got'\n"; 14 } else { 15 print "# Got undef\n"; 16 } 17 print "# Expected $expected\n"; 18 return; 19} 20 21sub like { 22 my ($got, $pattern, $name) = @_; 23 $test = $test + 1; 24 if (defined $got && $got =~ $pattern) { 25 print "ok $test - $name\n"; 26 # Principle of least surprise - maintain the expected interface, even 27 # though we aren't using it here (yet). 28 return 1; 29 } 30 failed($got, $pattern, $name); 31} 32 33sub is { 34 my ($got, $expect, $name) = @_; 35 $test = $test + 1; 36 if (defined $expect) { 37 if (defined $got && $got eq $expect) { 38 print "ok $test - $name\n"; 39 return 1; 40 } 41 failed($got, "'$expect'", $name); 42 } else { 43 if (!defined $got) { 44 print "ok $test - $name\n"; 45 return 1; 46 } 47 failed($got, 'undef', $name); 48 } 49} 50 51sub f($$_) { my $x = shift; is("@_", $x) } 52 53$foo = "FOO"; 54my $bar = "BAR"; 55$_ = 42; 56 57f("FOO xy", $foo, "xy"); 58f("BAR zt", $bar, "zt"); 59f("FOO 42", $foo); 60f("BAR 42", $bar); 61f("y 42", substr("xy",1,1)); 62f("1 42", ("abcdef" =~ /abc/)); 63f("not undef 42", $undef || "not undef"); 64f(" 42", -f "no_such_file"); 65f("FOOBAR 42", ($foo . $bar)); 66f("FOOBAR 42", ($foo .= $bar)); 67f("FOOBAR 42", $foo); 68 69eval q{ f("foo") }; 70like( $@, qr/Not enough arguments for main::f at/ ); 71eval q{ f(1,2,3,4) }; 72like( $@, qr/Too many arguments for main::f at/ ); 73 74{ 75 # We have not tested require/use/no yet, so we must avoid this: 76 # no warnings 'deprecated'; 77 BEGIN { $SIG{__WARN__} = sub {} } 78 my $_ = "quarante-deux"; 79 BEGIN { $SIG{__WARN__} = undef } 80 $foo = "FOO"; 81 $bar = "BAR"; 82 f("FOO quarante-deux", $foo); 83 f("BAR quarante-deux", $bar); 84 f("y quarante-deux", substr("xy",1,1)); 85 f("1 quarante-deux", ("abcdef" =~ /abc/)); 86 f("not undef quarante-deux", $undef || "not undef"); 87 f(" quarante-deux", -f "no_such_file"); 88 f("FOOBAR quarante-deux", ($foo . $bar)); 89 f("FOOBAR quarante-deux", ($foo .= $bar)); 90 f("FOOBAR quarante-deux", $foo); 91} 92 93&f(""); # no error 94 95sub g(_) { is(shift, $expected) } 96 97$expected = "foo"; 98g("foo"); 99g($expected); 100$_ = $expected; 101g(); 102g; 103undef $expected; &g; # $_ not passed 104BEGIN { $SIG{__WARN__} = sub {} } 105{ $expected = my $_ = "bar"; g() } 106BEGIN { $SIG{__WARN__} = undef } 107 108eval q{ sub wrong1 (_$); wrong1(1,2) }; 109like( $@, qr/Malformed prototype for main::wrong1/, 'wrong1' ); 110 111eval q{ sub wrong2 ($__); wrong2(1,2) }; 112like( $@, qr/Malformed prototype for main::wrong2/, 'wrong2' ); 113 114sub opt ($;_) { 115 is($_[0], "seen"); 116 is($_[1], undef, "; has precedence over _"); 117} 118 119opt("seen"); 120 121sub unop (_) { is($_[0], 11, "unary op") } 122unop 11, 22; # takes only the first parameter into account 123 124sub mymkdir (_;$) { is("@_", $expected, "mymkdir") } 125$expected = $_ = "mydir"; mymkdir(); 126mymkdir($expected = "foo"); 127$expected = "foo 493"; mymkdir foo => 0755; 128 129sub mylist (_@) { is("@_", $expected, "mylist") } 130$expected = "foo"; 131$_ = "foo"; 132mylist(); 133$expected = "10 11 12 13"; 134mylist(10, 11 .. 13); 135 136sub mylist2 (_%) { is("@_", $expected, "mylist2") } 137$expected = "foo"; 138$_ = "foo"; 139mylist2(); 140$expected = "10 a 1"; 141my %hash = (a => 1); 142mylist2(10, %hash); 143 144# $_ says modifiable, it's not passed by copy 145 146sub double(_) { $_[0] *= 2 } 147$_ = 21; 148double(); 149is( $_, 42, '$_ is modifiable' ); 150{ 151 BEGIN { $SIG{__WARN__} = sub {} } 152 my $_ = 22; 153 BEGIN { $SIG{__WARN__} = undef } 154 double(); 155 is( $_, 44, 'my $_ is modifiable' ); 156} 157