Commit | Line | Data |
---|---|---|
b13fd70a RGS |
1 | #!perl |
2 | ||
34daab0f | 3 | print "1..43\n"; |
cf1e28d2 NC |
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 NC |
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 RGS |
19 | } |
20 | ||
cf1e28d2 | 21 | sub like { |
cc2cb33e | 22 | my ($got, $pattern, $name) = @_; |
cf1e28d2 NC |
23 | $test = $test + 1; |
24 | if (defined $got && $got =~ $pattern) { | |
cc2cb33e | 25 | print "ok $test - $name\n"; |
cf1e28d2 NC |
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 NC |
31 | } |
32 | ||
33 | sub is { | |
cc2cb33e | 34 | my ($got, $expect, $name) = @_; |
cf1e28d2 NC |
35 | $test = $test + 1; |
36 | if (defined $expect) { | |
37 | if (defined $got && $got eq $expect) { | |
cc2cb33e | 38 | print "ok $test - $name\n"; |
cf1e28d2 NC |
39 | return 1; |
40 | } | |
9924e635 | 41 | failed($got, "'$expect'", $name); |
cf1e28d2 NC |
42 | } else { |
43 | if (!defined $got) { | |
cc2cb33e | 44 | print "ok $test - $name\n"; |
cf1e28d2 NC |
45 | return 1; |
46 | } | |
9924e635 | 47 | failed($got, 'undef', $name); |
cf1e28d2 NC |
48 | } |
49 | } | |
b13fd70a RGS |
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 | { |
90b58ec9 FC |
75 | # We have not tested require/use/no yet, so we must avoid this: |
76 | # no warnings 'deprecated'; | |
77 | BEGIN { $SIG{__WARN__} = sub {} } | |
236b555a | 78 | my $_ = "quarante-deux"; |
90b58ec9 | 79 | BEGIN { $SIG{__WARN__} = undef } |
236b555a RGS |
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 | ||
b13fd70a RGS |
93 | &f(""); # no error |
94 | ||
236b555a RGS |
95 | sub g(_) { is(shift, $expected) } |
96 | ||
97 | $expected = "foo"; | |
98 | g("foo"); | |
99 | g($expected); | |
100 | $_ = $expected; | |
101 | g(); | |
3cd0a11a | 102 | g; |
236b555a | 103 | undef $expected; &g; # $_ not passed |
90b58ec9 | 104 | BEGIN { $SIG{__WARN__} = sub {} } |
236b555a | 105 | { $expected = my $_ = "bar"; g() } |
90b58ec9 | 106 | BEGIN { $SIG{__WARN__} = undef } |
f00d1d61 RGS |
107 | |
108 | eval q{ sub wrong1 (_$); wrong1(1,2) }; | |
109 | like( $@, qr/Malformed prototype for main::wrong1/, 'wrong1' ); | |
110 | ||
111 | eval q{ sub wrong2 ($__); wrong2(1,2) }; | |
112 | like( $@, qr/Malformed prototype for main::wrong2/, 'wrong2' ); | |
5df4b323 | 113 | |
3d899d64 NC |
114 | sub opt ($;_) { |
115 | is($_[0], "seen"); | |
116 | is($_[1], undef, "; has precedence over _"); | |
117 | } | |
118 | ||
5df4b323 | 119 | opt("seen"); |
bfd79223 | 120 | |
cb40c25d | 121 | sub unop (_) { is($_[0], 11, "unary op") } |
bfd79223 | 122 | unop 11, 22; # takes only the first parameter into account |
cb40c25d RGS |
123 | |
124 | sub mymkdir (_;$) { is("@_", $expected, "mymkdir") } | |
125 | $expected = $_ = "mydir"; mymkdir(); | |
126 | mymkdir($expected = "foo"); | |
127 | $expected = "foo 493"; mymkdir foo => 0755; | |
6a8363ef | 128 | |
34daab0f RGS |
129 | sub mylist (_@) { is("@_", $expected, "mylist") } |
130 | $expected = "foo"; | |
131 | $_ = "foo"; | |
132 | mylist(); | |
133 | $expected = "10 11 12 13"; | |
134 | mylist(10, 11 .. 13); | |
135 | ||
136 | sub mylist2 (_%) { is("@_", $expected, "mylist2") } | |
137 | $expected = "foo"; | |
138 | $_ = "foo"; | |
139 | mylist2(); | |
140 | $expected = "10 a 1"; | |
141 | my %hash = (a => 1); | |
142 | mylist2(10, %hash); | |
143 | ||
6a8363ef RGS |
144 | # $_ says modifiable, it's not passed by copy |
145 | ||
146 | sub double(_) { $_[0] *= 2 } | |
147 | $_ = 21; | |
148 | double(); | |
149 | is( $_, 42, '$_ is modifiable' ); | |
150 | { | |
90b58ec9 | 151 | BEGIN { $SIG{__WARN__} = sub {} } |
6a8363ef | 152 | my $_ = 22; |
90b58ec9 | 153 | BEGIN { $SIG{__WARN__} = undef } |
6a8363ef RGS |
154 | double(); |
155 | is( $_, 44, 'my $_ is modifiable' ); | |
156 | } |