Show test names in output
[perl.git] / t / comp / uproto.t
1 #!perl
2
3 print "1..39\n";
4 my $test = 0;
5
6 sub 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
21 sub 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
33 sub 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
51 sub f($$_) { my $x = shift; is("@_", $x) }
52
53 $foo = "FOO";
54 my $bar = "BAR";
55 $_ = 42;
56
57 f("FOO xy", $foo, "xy");
58 f("BAR zt", $bar, "zt");
59 f("FOO 42", $foo);
60 f("BAR 42", $bar);
61 f("y 42", substr("xy",1,1));
62 f("1 42", ("abcdef" =~ /abc/));
63 f("not undef 42", $undef || "not undef");
64 f(" 42", -f "no_such_file");
65 f("FOOBAR 42", ($foo . $bar));
66 f("FOOBAR 42", ($foo .= $bar));
67 f("FOOBAR 42", $foo);
68
69 eval q{ f("foo") };
70 like( $@, qr/Not enough arguments for main::f at/ );
71 eval q{ f(1,2,3,4) };
72 like( $@, qr/Too many arguments for main::f at/ );
73
74 {
75     my $_ = "quarante-deux";
76     $foo = "FOO";
77     $bar = "BAR";
78     f("FOO quarante-deux", $foo);
79     f("BAR quarante-deux", $bar);
80     f("y quarante-deux", substr("xy",1,1));
81     f("1 quarante-deux", ("abcdef" =~ /abc/));
82     f("not undef quarante-deux", $undef || "not undef");
83     f(" quarante-deux", -f "no_such_file");
84     f("FOOBAR quarante-deux", ($foo . $bar));
85     f("FOOBAR quarante-deux", ($foo .= $bar));
86     f("FOOBAR quarante-deux", $foo);
87 }
88
89 &f(""); # no error
90
91 sub g(_) { is(shift, $expected) }
92
93 $expected = "foo";
94 g("foo");
95 g($expected);
96 $_ = $expected;
97 g();
98 g;
99 undef $expected; &g; # $_ not passed
100 { $expected = my $_ = "bar"; g() }
101
102 eval q{ sub wrong1 (_$); wrong1(1,2) };
103 like( $@, qr/Malformed prototype for main::wrong1/, 'wrong1' );
104
105 eval q{ sub wrong2 ($__); wrong2(1,2) };
106 like( $@, qr/Malformed prototype for main::wrong2/, 'wrong2' );
107
108 sub opt ($;_) {
109     is($_[0], "seen");
110     is($_[1], undef, "; has precedence over _");
111 }
112
113 opt("seen");
114
115 sub unop (_) { is($_[0], 11, "unary op") }
116 unop 11, 22; # takes only the first parameter into account
117
118 sub mymkdir (_;$) { is("@_", $expected, "mymkdir") }
119 $expected = $_ = "mydir"; mymkdir();
120 mymkdir($expected = "foo");
121 $expected = "foo 493"; mymkdir foo => 0755;
122
123 # $_ says modifiable, it's not passed by copy
124
125 sub double(_) { $_[0] *= 2 }
126 $_ = 21;
127 double();
128 is( $_, 42, '$_ is modifiable' );
129 {
130     my $_ = 22;
131     double();
132     is( $_, 44, 'my $_ is modifiable' );
133 }