This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Fix failed() calls in t/comp
[perl5.git] / t / comp / opsubs.t
CommitLineData
f3ce0eb7 1#!./perl -Tw
02c3ec76 2
f3ce0eb7
NC
3# Uncomment this for testing, but don't leave it in for "production", as
4# we've not yet verified that use works.
5# use strict;
520974d5 6
02c3ec76
AL
7$|++;
8
6b077beb
NC
9print "1..36\n";
10my $test = 0;
520974d5 11
6b077beb
NC
12sub failed {
13 my ($got, $expected, $name) = @_;
14
15 print "not ok $test - $name\n";
16 my @caller = caller(1);
17 print "# Failed test at $caller[1] line $caller[2]\n";
18 if (defined $got) {
19 print "# Got '$got'\n";
20 } else {
21 print "# Got undef\n";
22 }
23 print "# Expected $expected\n";
24 return;
25}
26
27sub like {
28 my ($got, $pattern, $name) = @_;
29 $test = $test + 1;
30 if (defined $got && $got =~ $pattern) {
31 print "ok $test - $name\n";
32 # Principle of least surprise - maintain the expected interface, even
33 # though we aren't using it here (yet).
34 return 1;
35 }
9924e635 36 failed($got, $pattern, $name);
6b077beb
NC
37}
38
39sub is {
40 my ($got, $expect, $name) = @_;
41 $test = $test + 1;
42 if (defined $got && $got eq $expect) {
43 print "ok $test - $name\n";
44 return 1;
45 }
9924e635 46 failed($got, "'$expect'", $name);
6b077beb
NC
47}
48
49sub isnt {
50 my ($got, $expect, $name) = @_;
51 $test = $test + 1;
52 if (defined $got && $got ne $expect) {
53 print "ok $test - $name\n";
54 return 1;
55 }
9924e635 56 failed($got, "not '$expect'", $name);
6b077beb
NC
57}
58
59sub can_ok {
60 my ($class, $method) = @_;
61 $test = $test + 1;
62 if (eval { $class->can($method) }) {
63 print "ok $test - $class->can('$method')\n";
64 return 1;
65 }
66 my @caller = caller;
67 print "# Failed test at $caller[1] line $caller[2]\n";
68 print "# $class cannot $method\n";
69 return;
70}
520974d5 71
02c3ec76
AL
72=pod
73
74Even if you have a C<sub q{}>, calling C<q()> will be parsed as the
75C<q()> operator. Calling C<&q()> or C<main::q()> gets you the function.
76This test verifies this behavior for nine different operators.
77
78=cut
79
02c3ec76
AL
80sub m { return "m-".shift }
81sub q { return "q-".shift }
82sub qq { return "qq-".shift }
83sub qr { return "qr-".shift }
84sub qw { return "qw-".shift }
85sub qx { return "qx-".shift }
86sub s { return "s-".shift }
87sub tr { return "tr-".shift }
88sub y { return "y-".shift }
89
90# m operator
91can_ok( 'main', "m" );
92SILENCE_WARNING: { # Complains because $_ is undef
f3ce0eb7 93 local $^W;
02c3ec76
AL
94 isnt( m('unqualified'), "m-unqualified", "m('unqualified') is oper" );
95}
96is( main::m('main'), "m-main", "main::m() is func" );
97is( &m('amper'), "m-amper", "&m() is func" );
98
99# q operator
100can_ok( 'main', "q" );
101isnt( q('unqualified'), "q-unqualified", "q('unqualified') is oper" );
102is( main::q('main'), "q-main", "main::q() is func" );
103is( &q('amper'), "q-amper", "&q() is func" );
104
105# qq operator
106can_ok( 'main', "qq" );
107isnt( qq('unqualified'), "qq-unqualified", "qq('unqualified') is oper" );
108is( main::qq('main'), "qq-main", "main::qq() is func" );
109is( &qq('amper'), "qq-amper", "&qq() is func" );
110
111# qr operator
112can_ok( 'main', "qr" );
113isnt( qr('unqualified'), "qr-unqualified", "qr('unqualified') is oper" );
114is( main::qr('main'), "qr-main", "main::qr() is func" );
115is( &qr('amper'), "qr-amper", "&qr() is func" );
116
117# qw operator
118can_ok( 'main', "qw" );
119isnt( qw('unqualified'), "qw-unqualified", "qw('unqualified') is oper" );
120is( main::qw('main'), "qw-main", "main::qw() is func" );
121is( &qw('amper'), "qw-amper", "&qw() is func" );
122
123# qx operator
124can_ok( 'main', "qx" );
b7c34493
YO
125eval "qx('unqualified'".
126 ($^O eq 'MSWin32' ? " 2>&1)" : ")");
b590cc3c 127TODO: {
9924e635
SH
128 local $::TODO = $^O eq 'MSWin32' ? "Tainting of PATH not working of Windows" : $::TODO;
129 like( $@, qr/^Insecure/, "qx('unqualified') doesn't work" );
83176b6e 130}
02c3ec76
AL
131is( main::qx('main'), "qx-main", "main::qx() is func" );
132is( &qx('amper'), "qx-amper", "&qx() is func" );
133
134# s operator
135can_ok( 'main', "s" );
136eval "s('unqualified')";
137like( $@, qr/^Substitution replacement not terminated/, "s('unqualified') doesn't work" );
138is( main::s('main'), "s-main", "main::s() is func" );
139is( &s('amper'), "s-amper", "&s() is func" );
140
141# tr operator
142can_ok( 'main', "tr" );
143eval "tr('unqualified')";
144like( $@, qr/^Transliteration replacement not terminated/, "tr('unqualified') doesn't work" );
145is( main::tr('main'), "tr-main", "main::tr() is func" );
146is( &tr('amper'), "tr-amper", "&tr() is func" );
147
148# y operator
149can_ok( 'main', "y" );
150eval "y('unqualified')";
151like( $@, qr/^Transliteration replacement not terminated/, "y('unqualified') doesn't work" );
152is( main::y('main'), "y-main", "main::y() is func" );
153is( &y('amper'), "y-amper", "&y() is func" );
154
155=pod
156
157from irc://irc.perl.org/p5p 2004/08/12
158
159 <kane-xs> bug or feature?
160 <purl> You decide!!!!
161 <kane-xs> [kane@coke ~]$ perlc -le'sub y{1};y(1)'
162 <kane-xs> Transliteration replacement not terminated at -e line 1.
163 <Nicholas> bug I think
164 <kane-xs> i'll perlbug
165 <rgs> feature
166 <kane-xs> smiles at rgs
167 <kane-xs> done
168 <rgs> will be closed at not a bug,
169 <rgs> like the previous reports of this one
170 <Nicholas> feature being first class and second class keywords?
171 <rgs> you have similar ones with q, qq, qr, qx, tr, s and m
172 <rgs> one could say 1st class keywords, yes
173 <rgs> and I forgot qw
174 <kane-xs> hmm silly...
175 <Nicholas> it's acutally operators, isn't it?
176 <Nicholas> as in you can't call a subroutine with the same name as an
177 operator unless you have the & ?
178 <kane-xs> or fqpn (fully qualified package name)
179 <kane-xs> main::y() works just fine
180 <kane-xs> as does &y; but not y()
181 <Andy> If that's a feature, then let's write a test that it continues
182 to work like that.
183
184=cut