Change 13383 by jhi@alpha on 2001/11/30 13:59:18
Subject: [PATCH perl.c ...] -P on VMS. Evicting sed
From: Michael G Schwern <[EMAIL PROTECTED]>
Date: Thu, 29 Nov 2001 22:05:11 -0500
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.
Affected files ...
.... //depot/perl/MANIFEST#649 edit
.... //depot/perl/configure.com#133 edit
.... //depot/perl/perl.c#398 edit
.... //depot/perl/t/comp/cpp.aux#7 edit
.... //depot/perl/t/comp/cpp.t#11 edit
.... //depot/perl/t/run/switchPx.aux#1 add
.... //depot/perl/t/run/switchPx.t#1 add
.... //depot/perl/vms/test.com#42 edit
Differences ...
==== //depot/perl/MANIFEST#649 (text) ====
Index: perl/MANIFEST
--- perl/MANIFEST.~1~ Fri Nov 30 07:15:05 2001
+++ perl/MANIFEST Fri Nov 30 07:15:05 2001
@@ -2320,6 +2320,8 @@
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
==== //depot/perl/configure.com#133 (text) ====
Index: perl/configure.com
--- perl/configure.com.~1~ Fri Nov 30 07:15:05 2001
+++ perl/configure.com Fri Nov 30 07:15:05 2001
@@ -2904,9 +2904,9 @@
$ 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"
==== //depot/perl/perl.c#398 (text) ====
Index: perl/perl.c
--- perl/perl.c.~1~ Fri Nov 30 07:15:05 2001
+++ perl/perl.c Fri Nov 30 07:15:05 2001
@@ -2645,6 +2645,11 @@
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 @@
}
}
-#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 @@
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 @@
}
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
}
}
==== //depot/perl/t/comp/cpp.aux#7 (xtext) ====
Index: perl/t/comp/cpp.aux
--- perl/t/comp/cpp.aux.~1~ Fri Nov 30 07:15:05 2001
+++ perl/t/comp/cpp.aux Fri Nov 30 07:15:05 2001
@@ -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 "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 @@
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";
==== //depot/perl/t/comp/cpp.t#11 (xtext) ====
Index: perl/t/comp/cpp.t
--- perl/t/comp/cpp.t.~1~ Fri Nov 30 07:15:05 2001
+++ perl/t/comp/cpp.t Fri Nov 30 07:15:05 2001
@@ -15,4 +15,4 @@
exit; # Cannot test till after install, alas.
}
-system "./perl -P comp/cpp.aux"
+system qq{$^X -"P" "comp/cpp.aux"};
==== //depot/perl/vms/test.com#42 (text) ====
Index: perl/vms/test.com
--- perl/vms/test.com.~1~ Fri Nov 30 07:15:05 2001
+++ perl/vms/test.com Fri Nov 30 07:15:05 2001
@@ -114,9 +114,7 @@
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;
==== //depot/perl/t/run/switchPx.aux#1 (text) ====
Index: perl/t/run/switchPx.aux
--- perl/t/run/switchPx.aux.~1~ Fri Nov 30 07:15:05 2001
+++ perl/t/run/switchPx.aux Fri Nov 30 07:15:05 2001
@@ -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;
==== //depot/perl/t/run/switchPx.t#1 (text) ====
Index: perl/t/run/switchPx.t
--- perl/t/run/switchPx.t.~1~ Fri Nov 30 07:15:05 2001
+++ perl/t/run/switchPx.t Fri Nov 30 07:15:05 2001
@@ -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' );
End of Patch.
