[perl #114040] Parse here-docs correctly in quoted constructs

[perl5.git] / t / comp / opsubs.t

diff --git a/t/comp/opsubs.t b/t/comp/opsubs.t
index 0bbe099..89b1af5 100644 (file)
--- a/t/comp/opsubs.t
+++ b/t/comp/opsubs.t
@@ -1,9 +1,99 @@
-#!./perl -T
+#!./perl -Tw
+
+# Uncomment this for testing, but don't leave it in for "production", as
+# we've not yet verified that use works.
+# use strict;
 
-use warnings;
-use strict;
 $|++;
 
+print "1..36\n";
+my $test = 0;
+
+sub failed {
+    my ($got, $expected, $name) = @_;
+
+    if ($::TODO) {
+       print "not ok $test - $name # TODO: $::TODO\n";
+    }
+    else {
+       print "not ok $test - $name\n";
+    }
+    my @caller = caller(1);
+    print "# Failed test at $caller[1] line $caller[2]\n";
+    if (defined $got) {
+       print "# Got '$got'\n";
+    } else {
+       print "# Got undef\n";
+    }
+    print "# Expected $expected\n";
+    return;
+}
+
+sub like {
+    my ($got, $pattern, $name) = @_;
+    $test = $test + 1;
+    if (defined $got && $got =~ $pattern) {
+       if ($::TODO) {
+           print "ok $test - $name # TODO: $::TODO\n";
+       }
+       else {
+           print "ok $test - $name\n";
+       }
+       # Principle of least surprise - maintain the expected interface, even
+       # though we aren't using it here (yet).
+       return 1;
+    }
+    failed($got, $pattern, $name);
+}
+
+sub is {
+    my ($got, $expect, $name) = @_;
+    $test = $test + 1;
+    if (defined $got && $got eq $expect) {
+       if ($::TODO) {
+           print "ok $test - $name # TODO: $::TODO\n";
+       }
+       else {
+           print "ok $test - $name\n";
+       }
+       return 1;
+    }
+    failed($got, "'$expect'", $name);
+}
+
+sub isnt {
+    my ($got, $expect, $name) = @_;
+    $test = $test + 1;
+    if (defined $got && $got ne $expect) {
+       if ($::TODO) {
+           print "ok $test - $name # TODO: $::TODO\n";
+       }
+       else {
+           print "ok $test - $name\n";
+       }
+       return 1;
+    }
+    failed($got, "not '$expect'", $name);
+}
+
+sub can_ok {
+    my ($class, $method) = @_;
+    $test = $test + 1;
+    if (eval { $class->can($method) }) {
+       if ($::TODO) {
+           print "ok $test - $class->can('$method') # TODO: $::TODO\n";
+       }
+       else {
+           print "ok $test - $class->can('$method')\n";
+       }
+       return 1;
+    }
+    my @caller = caller;
+    print "# Failed test at $caller[1] line $caller[2]\n";
+    print "# $class cannot $method\n";
+    return;
+}
+
 =pod
 
 Even if you have a C<sub q{}>, calling C<q()> will be parsed as the
@@ -12,8 +102,6 @@ This test verifies this behavior for nine different operators.
 
 =cut
 
-use Test::More tests => 36;
-
 sub m  { return "m-".shift }
 sub q  { return "q-".shift }
 sub qq { return "qq-".shift }
@@ -27,7 +115,7 @@ sub y  { return "y-".shift }
 # m operator
 can_ok( 'main', "m" );
 SILENCE_WARNING: { # Complains because $_ is undef
-    no warnings;
+    local $^W;                
     isnt( m('unqualified'), "m-unqualified", "m('unqualified') is oper" );
 }
 is( main::m('main'), "m-main", "main::m() is func" );
@@ -59,13 +147,11 @@ is( &qw('amper'), "qw-amper", "&qw() is func" );
 
 # qx operator
 can_ok( 'main', "qx" );
-eval "qx('unqualified')";
-SKIP: {
-    skip("external command not portable on VMS", 1) if $^O eq 'VMS';
-    TODO: {
-       local $TODO = $^O eq 'MSWin32' ? "Tainting of PATH not working of Windows" : $TODO;
-       like( $@, qr/^Insecure/, "qx('unqualified') doesn't work" );
-    }
+eval "qx('unqualified'".
+     ($^O eq 'MSWin32' ? " 2>&1)" : ")");
+TODO: {
+    local $::TODO = $^O eq 'MSWin32' ? "Tainting of PATH not working of Windows" : $::TODO;
+    like( $@, qr/^Insecure/, "qx('unqualified') doesn't work" );
 }
 is( main::qx('main'), "qx-main", "main::qx() is func" );
 is( &qx('amper'), "qx-amper", "&qx() is func" );