t/comp/opsubs.t

   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
   9 print "1..36\n";
  10 my $test = 0;
  11
  12 sub 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
  32 sub 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
  49 sub 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
  64 sub 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
  79 sub 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
  99 Even if you have a C<sub q{}>, calling C<q()> will be parsed as the
 100 C<q()> operator.  Calling C<&q()> or C<main::q()> gets you the function.
 101 This test verifies this behavior for nine different operators.
 102
 103 =cut
 104
 105 sub m  { return "m-".shift }
 106 sub q  { return "q-".shift }
 107 sub qq { return "qq-".shift }
 108 sub qr { return "qr-".shift }
 109 sub qw { return "qw-".shift }
 110 sub qx { return "qx-".shift }
 111 sub s  { return "s-".shift }
 112 sub tr { return "tr-".shift }
 113 sub y  { return "y-".shift }
 114
 115 # m operator
 116 can_ok( 'main', "m" );
 117 SILENCE_WARNING: { # Complains because $_ is undef
 118     local $^W;
 119     isnt( m('unqualified'), "m-unqualified", "m('unqualified') is oper" );
 120 }
 121 is( main::m('main'), "m-main", "main::m() is func" );
 122 is( &m('amper'), "m-amper", "&m() is func" );
 123
 124 # q operator
 125 can_ok( 'main', "q" );
 126 isnt( q('unqualified'), "q-unqualified", "q('unqualified') is oper" );
 127 is( main::q('main'), "q-main", "main::q() is func" );
 128 is( &q('amper'), "q-amper", "&q() is func" );
 129
 130 # qq operator
 131 can_ok( 'main', "qq" );
 132 isnt( qq('unqualified'), "qq-unqualified", "qq('unqualified') is oper" );
 133 is( main::qq('main'), "qq-main", "main::qq() is func" );
 134 is( &qq('amper'), "qq-amper", "&qq() is func" );
 135
 136 # qr operator
 137 can_ok( 'main', "qr" );
 138 isnt( qr('unqualified'), "qr-unqualified", "qr('unqualified') is oper" );
 139 is( main::qr('main'), "qr-main", "main::qr() is func" );
 140 is( &qr('amper'), "qr-amper", "&qr() is func" );
 141
 142 # qw operator
 143 can_ok( 'main', "qw" );
 144 isnt( qw('unqualified'), "qw-unqualified", "qw('unqualified') is oper" );
 145 is( main::qw('main'), "qw-main", "main::qw() is func" );
 146 is( &qw('amper'), "qw-amper", "&qw() is func" );
 147
 148 # qx operator
 149 can_ok( 'main', "qx" );
 150 eval "qx('unqualified'".
 151      ($^O eq 'MSWin32' ? " 2>&1)" : ")");
 152 TODO: {
 153     local $::TODO = $^O eq 'MSWin32' ? "Tainting of PATH not working of Windows" : $::TODO;
 154     like( $@, qr/^Insecure/, "qx('unqualified') doesn't work" );
 155 }
 156 is( main::qx('main'), "qx-main", "main::qx() is func" );
 157 is( &qx('amper'), "qx-amper", "&qx() is func" );
 158
 159 # s operator
 160 can_ok( 'main', "s" );
 161 eval "s('unqualified')";
 162 like( $@, qr/^Substitution replacement not terminated/, "s('unqualified') doesn't work" );
 163 is( main::s('main'), "s-main", "main::s() is func" );
 164 is( &s('amper'), "s-amper", "&s() is func" );
 165
 166 # tr operator
 167 can_ok( 'main', "tr" );
 168 eval "tr('unqualified')";
 169 like( $@, qr/^Transliteration replacement not terminated/, "tr('unqualified') doesn't work" );
 170 is( main::tr('main'), "tr-main", "main::tr() is func" );
 171 is( &tr('amper'), "tr-amper", "&tr() is func" );
 172
 173 # y operator
 174 can_ok( 'main', "y" );
 175 eval "y('unqualified')";
 176 like( $@, qr/^Transliteration replacement not terminated/, "y('unqualified') doesn't work" );
 177 is( main::y('main'), "y-main", "main::y() is func" );
 178 is( &y('amper'), "y-amper", "&y() is func" );
 179
 180 =pod
 181
 182 from 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