From: Michael G. Schwern <schwern@pobox.com>
Date: Thu, 29 Nov 2001 22:05:11 +0000 (-0500)
Subject: -P on VMS.  Evicting sed
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=1b24ed4b35a915c6e59d3fc62a8dd13d3947354a;p=p5sagit%2Fp5-mst-13.2.git

-P on VMS.  Evicting sed
Message-ID: <20011129220510.A18869@blackrider>

TODO 1: if cppstdin is used and not yet installed,
the Px.t will fail (must do the same as in cpp.t)

TODO 2: does this work if no Perl whatsoever has
yet been installed?  That is, we should be using
the Perl we are building to execute the one-liner.

p4raw-id: //depot/perl@13383
---

diff --git a/MANIFEST b/MANIFEST
index 9ee6af4..e3bfc12 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -2320,6 +2320,8 @@ t/run/switches.t		Tests for the other switches
 t/run/switchF.t			Test the -F switch
 t/run/switchn.t			Test the -n switch
 t/run/switchp.t			Test the -p switch
+t/run/switchPx.aux              Data for switchPx.t
+t/run/switchPx.t                Test the -Px combination
 t/run/switchx.aux               Data for switchx.t
 t/run/switchx.t                 Test the -x switch
 t/TEST				The regression tester
diff --git a/configure.com b/configure.com
index e83eda1..d8833d3 100644
--- a/configure.com
+++ b/configure.com
@@ -2904,9 +2904,9 @@ $   lib_ext=".olb"
 $ ENDIF
 $ dlobj="dl_vms''obj_ext'"
 $!
-$ cppstdin="''perl_cc'/noobj/preprocess=sys$output sys$input"
+$ cppstdin="''perl_cc'/noobj/comments=as_is/preprocess=sys$output sys$input"
 $ cppminus=" "
-$ cpprun="''perl_cc'/noobj/preprocess=sys$output sys$input"
+$ cpprun="''perl_cc'/noobj/comments=as_is/preprocess=sys$output sys$input"
 $ cpplast=" "
 $!
 $ timetype="time_t"
diff --git a/perl.c b/perl.c
index 8b3066e..e1d3d18 100644
--- a/perl.c
+++ b/perl.c
@@ -2645,6 +2645,11 @@ S_init_main_stash(pTHX)
 STATIC void
 S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
 {
+    char *quote;
+    char *code;
+    char *cpp_discard_flag;
+    char *perl;
+
     *fdscript = -1;
 
     if (PL_e_script) {
@@ -2667,20 +2672,21 @@ S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
 	}
     }
 
-#ifdef USE_ITHREADS
-    Safefree(CopFILE(PL_curcop));
-#else
-    SvREFCNT_dec(CopFILEGV(PL_curcop));
-#endif
+#   ifdef USE_ITHREADS
+        Safefree(CopFILE(PL_curcop));
+#   else
+        SvREFCNT_dec(CopFILEGV(PL_curcop));
+#   endif
     CopFILE_set(PL_curcop, PL_origfilename);
     if (strEQ(PL_origfilename,"-"))
 	scriptname = "";
     if (*fdscript >= 0) {
 	PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
-#if defined(HAS_FCNTL) && defined(F_SETFD)
-	if (PL_rsfp)
-	    fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);  /* ensure close-on-exec */
-#endif
+#       if defined(HAS_FCNTL) && defined(F_SETFD)
+	    if (PL_rsfp)
+                /* ensure close-on-exec */
+	        fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
+#       endif
     }
     else if (PL_preprocess) {
 	char *cpp_cfg = CPPSTDIN;
@@ -2691,88 +2697,73 @@ S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
 	    Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
 	sv_catpv(cpp, cpp_cfg);
 
-	sv_catpvn(sv, "-I", 2);
-	sv_catpv(sv,PRIVLIB_EXP);
+#       ifndef VMS
+	    sv_catpvn(sv, "-I", 2);
+	    sv_catpv(sv,PRIVLIB_EXP);
+#       endif
 
 	DEBUG_P(PerlIO_printf(Perl_debug_log,
 			      "PL_preprocess: scriptname=\"%s\", cpp=\"%s\", sv=\"%s\", CPPMINUS=\"%s\"\n",
 			      scriptname, SvPVX (cpp), SvPVX (sv), CPPMINUS));
-#if defined(MSDOS) || defined(WIN32)
-	Perl_sv_setpvf(aTHX_ cmd, "\
-sed %s -e \"/^[^#]/b\" \
- -e \"/^#[ 	]*include[ 	]/b\" \
- -e \"/^#[ 	]*define[ 	]/b\" \
- -e \"/^#[ 	]*if[ 	]/b\" \
- -e \"/^#[ 	]*ifdef[ 	]/b\" \
- -e \"/^#[ 	]*ifndef[ 	]/b\" \
- -e \"/^#[ 	]*else/b\" \
- -e \"/^#[ 	]*elif[ 	]/b\" \
- -e \"/^#[ 	]*undef[ 	]/b\" \
- -e \"/^#[ 	]*endif/b\" \
- -e \"s/^#.*//\" \
- %s | %"SVf" -C %"SVf" %s",
-	  (PL_doextract ? "-e \"1,/^#/d\n\"" : ""),
-#else
-#  ifdef __OPEN_VM
-	Perl_sv_setpvf(aTHX_ cmd, "\
-%s %s -e '/^[^#]/b' \
- -e '/^#[ 	]*include[ 	]/b' \
- -e '/^#[ 	]*define[ 	]/b' \
- -e '/^#[ 	]*if[ 	]/b' \
- -e '/^#[ 	]*ifdef[ 	]/b' \
- -e '/^#[ 	]*ifndef[ 	]/b' \
- -e '/^#[ 	]*else/b' \
- -e '/^#[ 	]*elif[ 	]/b' \
- -e '/^#[ 	]*undef[ 	]/b' \
- -e '/^#[ 	]*endif/b' \
- -e 's/^[ 	]*#.*//' \
- %s | %"SVf" %"SVf" %s",
-#  else
-	Perl_sv_setpvf(aTHX_ cmd, "\
-%s %s -e '/^[^#]/b' \
- -e '/^#[ 	]*include[ 	]/b' \
- -e '/^#[ 	]*define[ 	]/b' \
- -e '/^#[ 	]*if[ 	]/b' \
- -e '/^#[ 	]*ifdef[ 	]/b' \
- -e '/^#[ 	]*ifndef[ 	]/b' \
- -e '/^#[ 	]*else/b' \
- -e '/^#[ 	]*elif[ 	]/b' \
- -e '/^#[ 	]*undef[ 	]/b' \
- -e '/^#[ 	]*endif/b' \
- -e 's/^[ 	]*#.*//' \
- %s | %"SVf" -C %"SVf" %s",
-#  endif
-#ifdef LOC_SED
-	  LOC_SED,
-#else
-	  "sed",
-#endif
-	  (PL_doextract ? "-e '1,/^#/d\n'" : ""),
-#endif
-	  scriptname, cpp, sv, CPPMINUS);
+
+#       if defined(MSDOS) || defined(WIN32) || defined(VMS)
+            quote = "\"";
+#       else
+            quote = "'";
+#       endif
+
+#       ifdef VMS
+            cpp_discard_flag = "";
+#       else
+            cpp_discard_flag = "-C";
+#       endif
+
+#       ifdef OS2
+            perl = os2_execname(aTHX);
+#       else
+            perl = PL_origargv[0];
+#       endif
+
+
+        /* This strips off Perl comments which might interfere with
+           the C pre-processor, including #!.  #line directives are 
+           deliberately stripped to avoid confusion with Perl's version 
+           of #line.  FWP played some golf with it so it will fit
+           into VMS's 255 character buffer.
+        */
+        if( PL_doextract )
+            code = "(1../^#!.*perl/i)|/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
+        else
+            code = "/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
+
+        Perl_sv_setpvf(aTHX_ cmd, "\
+%s -ne%s%s%s %s | %"SVf" %s %"SVf" %s",
+                       perl, quote, code, quote, scriptname, cpp, 
+                       cpp_discard_flag, sv, CPPMINUS);
+
 	PL_doextract = FALSE;
-#ifdef IAMSUID				/* actually, this is caught earlier */
-	if (PL_euid != PL_uid && !PL_euid) {	/* if running suidperl */
-#ifdef HAS_SETEUID
-	    (void)seteuid(PL_uid);		/* musn't stay setuid root */
-#else
-#ifdef HAS_SETREUID
-	    (void)setreuid((Uid_t)-1, PL_uid);
-#else
-#ifdef HAS_SETRESUID
-	    (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
-#else
-	    PerlProc_setuid(PL_uid);
-#endif
-#endif
-#endif
+#       ifdef IAMSUID			/* actually, this is caught earlier */
+	    if (PL_euid != PL_uid && !PL_euid) {  /* if running suidperl */
+#               ifdef HAS_SETEUID
+	            (void)seteuid(PL_uid);	  /* musn't stay setuid root */
+#               else
+#               ifdef HAS_SETREUID
+	            (void)setreuid((Uid_t)-1, PL_uid);
+#               else
+#               ifdef HAS_SETRESUID
+	            (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
+#               else
+	            PerlProc_setuid(PL_uid);
+#               endif
+#               endif
+#               endif
 	    if (PerlProc_geteuid() != PL_uid)
 		Perl_croak(aTHX_ "Can't do seteuid!\n");
 	}
-#endif /* IAMSUID */
+#       endif /* IAMSUID */
 
-        DEBUG_P(PerlIO_printf(Perl_debug_log,
-                              "PL_preprocess: cmd=\"%s\"\n",
+        DEBUG_P(PerlIO_printf(Perl_debug_log, 
+                              "PL_preprocess: cmd=\"%s\"\n", 
                               SvPVX(cmd)));
 
 	PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
@@ -2785,34 +2776,36 @@ sed %s -e \"/^[^#]/b\" \
     }
     else {
 	PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
-#if defined(HAS_FCNTL) && defined(F_SETFD)
-	if (PL_rsfp)
-	    fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);  /* ensure close-on-exec */
-#endif
+#       if defined(HAS_FCNTL) && defined(F_SETFD)
+	    if (PL_rsfp)
+                /* ensure close-on-exec */
+	        fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
+#       endif
     }
     if (!PL_rsfp) {
-#ifdef DOSUID
-#ifndef IAMSUID		/* in case script is not readable before setuid */
-	if (PL_euid &&
-	    PerlLIO_stat(CopFILE(PL_curcop),&PL_statbuf) >= 0 &&
-	    PL_statbuf.st_mode & (S_ISUID|S_ISGID))
-	{
-	    /* try again */
-	    PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
-				     (int)PERL_REVISION, (int)PERL_VERSION,
-				     (int)PERL_SUBVERSION), PL_origargv);
-	    Perl_croak(aTHX_ "Can't do setuid\n");
-	}
-#endif
-#endif
-#ifdef IAMSUID
-	errno = EPERM;
-	Perl_croak(aTHX_ "Can't open perl script: %s\n",
-		   Strerror(errno));
-#else
-	Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
-		   CopFILE(PL_curcop), Strerror(errno));
-#endif
+#       ifdef DOSUID
+#       ifndef IAMSUID	/* in case script is not readable before setuid */
+	    if (PL_euid &&
+                PerlLIO_stat(CopFILE(PL_curcop),&PL_statbuf) >= 0 &&
+                PL_statbuf.st_mode & (S_ISUID|S_ISGID))
+            {
+                /* try again */
+                PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, 
+                                         BIN_EXP, (int)PERL_REVISION, 
+                                         (int)PERL_VERSION,
+                                         (int)PERL_SUBVERSION), PL_origargv);
+                Perl_croak(aTHX_ "Can't do setuid\n");
+            }
+#       endif
+#       endif
+#       ifdef IAMSUID
+            errno = EPERM;
+            Perl_croak(aTHX_ "Can't open perl script: %s\n",
+                       Strerror(errno));
+#       else
+            Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
+                       CopFILE(PL_curcop), Strerror(errno));
+#       endif
     }
 }
 
diff --git a/t/comp/cpp.aux b/t/comp/cpp.aux
index 536268a..0589032 100755
--- a/t/comp/cpp.aux
+++ b/t/comp/cpp.aux
@@ -1,4 +1,7 @@
-#!./perl -P
+#!./perl -l
+
+# There's a bug in -P where the #! line is ignored.  If this test
+# suddenly starts printing blank lines that bug has been fixed.
 
 print "1..3\n";
 
@@ -11,11 +14,11 @@ print MESS;
 	print "not ok 2\n";
 #endif
 
-open(TRY,">Comp.cpp.tmp") || die "Can't open temp perl file.";
+open(TRY,">Comp_cpp.tmp") || die "Can't open temp perl file: $!";
 
 ($prog = <<'END') =~ s/X//g;
 X$ok = "not ok 3\n";
-X#include "Comp.cpp.inc"
+X#include "Comp_cpp.inc"
 X#ifdef OK
 X$ok = OK;
 X#endif
@@ -24,12 +27,9 @@ END
 print TRY $prog;
 close TRY;
 
-open(TRY,">Comp.cpp.inc") || (die "Can't open temp include file.");
+open(TRY,">Comp_cpp.inc") || (die "Can't open temp include file: $!");
 print TRY '#define OK "ok 3\n"' . "\n";
 close TRY;
 
-$pwd=`pwd`;
-$pwd =~ s/\n//;
-$x = `./perl -P Comp.cpp.tmp`;
-print $x;
-unlink "Comp.cpp.tmp", "Comp.cpp.inc";
+print `$^X "-P" Comp_cpp.tmp`;
+unlink "Comp_cpp.tmp", "Comp_cpp.inc";
diff --git a/t/comp/cpp.t b/t/comp/cpp.t
index cb8df50..e80ce33 100755
--- a/t/comp/cpp.t
+++ b/t/comp/cpp.t
@@ -15,4 +15,4 @@ if ( $^O eq 'MSWin32' or $^O eq 'MacOS' or
     exit; 		# Cannot test till after install, alas.
 }
 
-system "./perl -P comp/cpp.aux"
+system qq{$^X -"P" "comp/cpp.aux"};
diff --git a/t/run/switchPx.aux b/t/run/switchPx.aux
new file mode 100644
index 0000000..68ebc83
--- /dev/null
+++ b/t/run/switchPx.aux
@@ -0,0 +1,34 @@
+Some stuff that's not Perl
+
+This CPP directive should not be read.
+#define BARMAR 1
+
+#perl
+
+Still not perl.
+
+#!
+
+still not perl
+
+#!/something/else
+
+still not perl
+
+#!/some/path/that/leads/to/perl -l
+
+# The -l switch should be applied from the #! line.
+# Unfortunately, -P has a bug whereby the #! line is ignored.
+# If this test suddenly starts printing blank lines that bug is fixed.
+
+#define FOO "ok 1\n"
+
+#ifdef BARMAR
+#   define YAR "not ok 2\n"
+#else
+#   define YAR "ok 2\n"
+#endif
+
+print "1..2\n";
+print FOO;
+print YAR;
diff --git a/t/run/switchPx.t b/t/run/switchPx.t
new file mode 100644
index 0000000..0f029a7
--- /dev/null
+++ b/t/run/switchPx.t
@@ -0,0 +1,14 @@
+#!./perl
+
+# Ensure that the -P and -x flags work together.
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib';
+}
+
+require './test.pl';
+
+print runperl( switches => ['-Px'], 
+               nolib => 1,   # for some reason this is necessary under VMS
+               progfile => 'run/switchPx.aux' );
diff --git a/vms/test.com b/vms/test.com
index f71e243..11f6a30 100644
--- a/vms/test.com
+++ b/vms/test.com
@@ -114,9 +114,7 @@ $   Deck/Dollar=$$END-OF-TEST$$
 use Config;
 use File::Spec;
 
-@compexcl=('cpp.t');
-@opexcl=('die_exit.t','exec.t','stat.t');
-@exclist=(@compexcl,@libexcl,@opexcl);
+@exclist=('exec.t','stat.t');
 foreach $file (@exclist) { $skip{$file}++; }
 
 $| = 1;