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     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
  27 sub 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     }
  36     failed($got, $pattern);
  37 }
  38
  39 sub 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     }
  46     failed($got, "'$expect'");
  47 }
  48
  49 sub 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     }
  56     failed($got, "not '$expect'");
  57 }
  58
  59 sub 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 }
  71
  72 =pod
  73
  74 Even if you have a C<sub q{}>, calling C<q()> will be parsed as the
  75 C<q()> operator.  Calling C<&q()> or C<main::q()> gets you the function.
  76 This test verifies this behavior for nine different operators.
  77
  78 =cut
  79
  80 sub m  { return "m-".shift }
  81 sub q  { return "q-".shift }
  82 sub qq { return "qq-".shift }
  83 sub qr { return "qr-".shift }
  84 sub qw { return "qw-".shift }
  85 sub qx { return "qx-".shift }
  86 sub s  { return "s-".shift }
  87 sub tr { return "tr-".shift }
  88 sub y  { return "y-".shift }
  89
  90 # m operator
  91 can_ok( 'main', "m" );
  92 SILENCE_WARNING: { # Complains because $_ is undef
  93     local $^W;
  94     isnt( m('unqualified'), "m-unqualified", "m('unqualified') is oper" );
  95 }
  96 is( main::m('main'), "m-main", "main::m() is func" );
  97 is( &m('amper'), "m-amper", "&m() is func" );
  98
  99 # q operator
 100 can_ok( 'main', "q" );
 101 isnt( q('unqualified'), "q-unqualified", "q('unqualified') is oper" );
 102 is( main::q('main'), "q-main", "main::q() is func" );
 103 is( &q('amper'), "q-amper", "&q() is func" );
 104
 105 # qq operator
 106 can_ok( 'main', "qq" );
 107 isnt( qq('unqualified'), "qq-unqualified", "qq('unqualified') is oper" );
 108 is( main::qq('main'), "qq-main", "main::qq() is func" );
 109 is( &qq('amper'), "qq-amper", "&qq() is func" );
 110
 111 # qr operator
 112 can_ok( 'main', "qr" );
 113 isnt( qr('unqualified'), "qr-unqualified", "qr('unqualified') is oper" );
 114 is( main::qr('main'), "qr-main", "main::qr() is func" );
 115 is( &qr('amper'), "qr-amper", "&qr() is func" );
 116
 117 # qw operator
 118 can_ok( 'main', "qw" );
 119 isnt( qw('unqualified'), "qw-unqualified", "qw('unqualified') is oper" );
 120 is( main::qw('main'), "qw-main", "main::qw() is func" );
 121 is( &qw('amper'), "qw-amper", "&qw() is func" );
 122
 123 # qx operator
 124 can_ok( 'main', "qx" );
 125 eval "qx('unqualified'".
 126      ($^O eq 'MSWin32' ? " 2>&1)" : ")");
 127 SKIP: {
 128     skip("external command not portable on VMS", 1) if $^O eq 'VMS';
 129     TODO: {
 130         local $::TODO = $^O eq 'MSWin32' ? "Tainting of PATH not working of Windows" : $::TODO;
 131         like( $@, qr/^Insecure/, "qx('unqualified') doesn't work" );
 132     }
 133 }
 134 is( main::qx('main'), "qx-main", "main::qx() is func" );
 135 is( &qx('amper'), "qx-amper", "&qx() is func" );
 136
 137 # s operator
 138 can_ok( 'main', "s" );
 139 eval "s('unqualified')";
 140 like( $@, qr/^Substitution replacement not terminated/, "s('unqualified') doesn't work" );
 141 is( main::s('main'), "s-main", "main::s() is func" );
 142 is( &s('amper'), "s-amper", "&s() is func" );
 143
 144 # tr operator
 145 can_ok( 'main', "tr" );
 146 eval "tr('unqualified')";
 147 like( $@, qr/^Transliteration replacement not terminated/, "tr('unqualified') doesn't work" );
 148 is( main::tr('main'), "tr-main", "main::tr() is func" );
 149 is( &tr('amper'), "tr-amper", "&tr() is func" );
 150
 151 # y operator
 152 can_ok( 'main', "y" );
 153 eval "y('unqualified')";
 154 like( $@, qr/^Transliteration replacement not terminated/, "y('unqualified') doesn't work" );
 155 is( main::y('main'), "y-main", "main::y() is func" );
 156 is( &y('amper'), "y-amper", "&y() is func" );
 157
 158 =pod
 159
 160 from irc://irc.perl.org/p5p 2004/08/12
 161
 162  <kane-xs>  bug or feature?
 163  <purl>     You decide!!!!
 164  <kane-xs>  [kane@coke ~]$ perlc -le'sub y{1};y(1)'
 165  <kane-xs>  Transliteration replacement not terminated at -e line 1.
 166  <Nicholas> bug I think
 167  <kane-xs>  i'll perlbug
 168  <rgs>      feature
 169  <kane-xs>  smiles at rgs
 170  <kane-xs>  done
 171  <rgs>      will be closed at not a bug,
 172  <rgs>      like the previous reports of this one
 173  <Nicholas> feature being first class and second class keywords?
 174  <rgs>      you have similar ones with q, qq, qr, qx, tr, s and m
 175  <rgs>      one could say 1st class keywords, yes
 176  <rgs>      and I forgot qw
 177  <kane-xs>  hmm silly...
 178  <Nicholas> it's acutally operators, isn't it?
 179  <Nicholas> as in you can't call a subroutine with the same name as an
 180             operator unless you have the & ?
 181  <kane-xs>  or fqpn (fully qualified package name)
 182  <kane-xs>  main::y() works just fine
 183  <kane-xs>  as does &y; but not y()
 184  <Andy>     If that's a feature, then let's write a test that it continues
 185             to work like that.
 186
 187 =cut