1#!perl 2 3print "1..32\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&f(""); # no error 75 76sub g(_) { is(shift, $expected) } 77 78$expected = "foo"; 79g("foo"); 80g($expected); 81$_ = $expected; 82g(); 83g; 84undef $expected; &g; # $_ not passed 85 86eval q{ sub wrong1 (_$); wrong1(1,2) }; 87like( $@, qr/Malformed prototype for main::wrong1/, 'wrong1' ); 88 89eval q{ sub wrong2 ($__); wrong2(1,2) }; 90like( $@, qr/Malformed prototype for main::wrong2/, 'wrong2' ); 91 92sub opt ($;_) { 93 is($_[0], "seen"); 94 is($_[1], undef, "; has precedence over _"); 95} 96 97opt("seen"); 98 99sub unop (_) { is($_[0], 11, "unary op") } 100unop 11, 22; # takes only the first parameter into account 101 102sub mymkdir (_;$) { is("@_", $expected, "mymkdir") } 103$expected = $_ = "mydir"; mymkdir(); 104mymkdir($expected = "foo"); 105$expected = "foo 493"; mymkdir foo => 0755; 106 107sub mylist (_@) { is("@_", $expected, "mylist") } 108$expected = "foo"; 109$_ = "foo"; 110mylist(); 111$expected = "10 11 12 13"; 112mylist(10, 11 .. 13); 113 114sub mylist2 (_%) { is("@_", $expected, "mylist2") } 115$expected = "foo"; 116$_ = "foo"; 117mylist2(); 118$expected = "10 a 1"; 119my %hash = (a => 1); 120mylist2(10, %hash); 121 122# $_ says modifiable, it's not passed by copy 123 124sub double(_) { $_[0] *= 2 } 125$_ = 21; 126double(); 127is( $_, 42, '$_ is modifiable' ); 128