Commit | Line | Data |
b13fd70a |
1 | #!perl |
2 | |
cf1e28d2 |
3 | print "1..39\n"; |
4 | my $test = 0; |
5 | |
6 | sub failed { |
9924e635 |
7 | my ($got, $expected, $name) = @_; |
cf1e28d2 |
8 | |
9924e635 |
9 | print "not ok $test - $name\n"; |
cf1e28d2 |
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; |
b13fd70a |
19 | } |
20 | |
cf1e28d2 |
21 | sub like { |
22 | my ($got, $pattern) = @_; |
23 | $test = $test + 1; |
24 | if (defined $got && $got =~ $pattern) { |
25 | print "ok $test\n"; |
26 | # Principle of least surprise - maintain the expected interface, even |
27 | # though we aren't using it here (yet). |
28 | return 1; |
29 | } |
9924e635 |
30 | failed($got, $pattern, $name); |
cf1e28d2 |
31 | } |
32 | |
33 | sub is { |
34 | my ($got, $expect) = @_; |
35 | $test = $test + 1; |
36 | if (defined $expect) { |
37 | if (defined $got && $got eq $expect) { |
38 | print "ok $test\n"; |
39 | return 1; |
40 | } |
9924e635 |
41 | failed($got, "'$expect'", $name); |
cf1e28d2 |
42 | } else { |
43 | if (!defined $got) { |
44 | print "ok $test\n"; |
45 | return 1; |
46 | } |
9924e635 |
47 | failed($got, 'undef', $name); |
cf1e28d2 |
48 | } |
49 | } |
b13fd70a |
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 | |
236b555a |
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 | |
b13fd70a |
89 | &f(""); # no error |
90 | |
236b555a |
91 | sub g(_) { is(shift, $expected) } |
92 | |
93 | $expected = "foo"; |
94 | g("foo"); |
95 | g($expected); |
96 | $_ = $expected; |
97 | g(); |
3cd0a11a |
98 | g; |
236b555a |
99 | undef $expected; &g; # $_ not passed |
100 | { $expected = my $_ = "bar"; g() } |
f00d1d61 |
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' ); |
5df4b323 |
107 | |
3d899d64 |
108 | sub opt ($;_) { |
109 | is($_[0], "seen"); |
110 | is($_[1], undef, "; has precedence over _"); |
111 | } |
112 | |
5df4b323 |
113 | opt("seen"); |
bfd79223 |
114 | |
cb40c25d |
115 | sub unop (_) { is($_[0], 11, "unary op") } |
bfd79223 |
116 | unop 11, 22; # takes only the first parameter into account |
cb40c25d |
117 | |
118 | sub mymkdir (_;$) { is("@_", $expected, "mymkdir") } |
119 | $expected = $_ = "mydir"; mymkdir(); |
120 | mymkdir($expected = "foo"); |
121 | $expected = "foo 493"; mymkdir foo => 0755; |
6a8363ef |
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 | } |