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