/* perl.c
*
- * Copyright (c) 1987-2001 Larry Wall
+ * Copyright (c) 1987-2002 Larry Wall
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
#include "perl.h"
#include "patchlevel.h" /* for local_patches */
+#ifdef NETWARE
+#include "nwutil.h"
+char *nw_get_sitelib(const char *pl);
+#endif
+
/* XXX If this causes problems, set i_unistd=undef in the hint file. */
#ifdef I_UNISTD
#include <unistd.h>
#endif
+#ifdef __BEOS__
+# define HZ 1000000
+#endif
+
+#ifndef HZ
+# ifdef CLK_TCK
+# define HZ CLK_TCK
+# else
+# define HZ 60
+# endif
+#endif
+
#if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE) && !defined(PERL_MICRO)
char *getenv (char *); /* Usually in <stdlib.h> */
#endif
#else
/*
+=head1 Embedding Functions
+
=for apidoc perl_alloc
Allocates a new Perl interpreter. See L<perlembed>.
perl_alloc(void)
{
PerlInterpreter *my_perl;
+#ifdef USE_5005THREADS
+ dTHX;
+#endif
/* New() needs interpreter, so call malloc() instead */
my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
PL_sighandlerp = Perl_sighandler;
PL_pidstatus = newHV();
-
-#ifdef MSDOS
- /*
- * There is no way we can refer to them from Perl so close them to save
- * space. The other alternative would be to provide STDAUX and STDPRN
- * filehandles.
- */
- (void)PerlIO_close(PerlIO_importFILE(stdaux, 0));
- (void)PerlIO_close(PerlIO_importFILE(stdprn, 0));
-#endif
}
PL_rs = newSVpvn("\n", 1);
PL_fdpid = newAV(); /* for remembering popen pids by fd */
PL_modglobal = newHV(); /* pointers to per-interpreter module globals */
PL_errors = newSVpvn("",0);
+ sv_setpvn(PERL_DEBUG_PAD(0), "", 0); /* For regex debugging. */
+ sv_setpvn(PERL_DEBUG_PAD(1), "", 0); /* ext/re needs these */
+ sv_setpvn(PERL_DEBUG_PAD(2), "", 0); /* even without DEBUGGING. */
#ifdef USE_ITHREADS
PL_regex_padav = newAV();
av_push(PL_regex_padav,(SV*)newAV()); /* First entry is an array of empty elements */
PL_regex_pad = AvARRAY(PL_regex_padav);
#endif
#ifdef USE_REENTRANT_API
- New(31337, PL_reentrant_buffer,1, REBUF);
- New(31337, PL_reentrant_buffer->tmbuff,1, struct tm);
-#endif
-
-#ifdef DEBUGGING
- sv_setpvn(PERL_DEBUG_PAD(0), "", 0);
- sv_setpvn(PERL_DEBUG_PAD(1), "", 0);
- sv_setpvn(PERL_DEBUG_PAD(2), "", 0);
+ Perl_reentrant_init(aTHX);
#endif
/* Note that strtab is a rather special HV. Assumptions are made
PL_origenviron = environ;
#endif
+ /* Use sysconf(_SC_CLK_TCK) if available, if not
+ * available or if the sysconf() fails, use the HZ. */
+#if defined(HAS_SYSCONF) && defined(_SC_CLK_TCK)
+ PL_clocktick = sysconf(_SC_CLK_TCK);
+ if (PL_clocktick <= 0)
+#endif
+ PL_clocktick = HZ;
+
ENTER;
}
/*
+=for apidoc nothreadhook
+
+Stub that provides thread hook for perl_destruct when there are
+no threads.
+
+=cut
+*/
+
+int
+Perl_nothreadhook(pTHX)
+{
+ return 0;
+}
+
+/*
=for apidoc perl_destruct
Shuts down a Perl interpreter. See L<perlembed>.
LEAVE;
FREETMPS;
+ /* Need to flush since END blocks can produce output */
+ my_fflush_all();
+
+ if (CALL_FPTR(PL_threadhook)(aTHX)) {
+ /* Threads hook has vetoed further cleanup */
+ return STATUS_NATIVE_EXPORT;
+ }
+
/* We must account for everything. */
/* Destroy the main CV and syntax tree */
if (PL_main_root) {
- PL_curpad = AvARRAY(PL_comppad);
+ /* If running under -d may not have PL_comppad. */
+ PL_curpad = PL_comppad ? AvARRAY(PL_comppad) : NULL;
op_free(PL_main_root);
PL_main_root = Nullop;
}
#endif
/* The exit() function will do everything that needs doing. */
- return STATUS_NATIVE_EXPORT;;
+ return STATUS_NATIVE_EXPORT;
}
/* jettison our possibly duplicated environment */
* so we certainly shouldn't free it here
*/
#if defined(USE_ENVIRON_ARRAY) && !defined(PERL_USE_SAFE_PUTENV)
- if (environ != PL_origenviron) {
+ if (environ != PL_origenviron
+#ifdef USE_ITHREADS
+ /* only main thread can free environ[0] contents */
+ && PL_curinterp == aTHX
+#endif
+ )
+ {
I32 i;
for (i = 0; environ[i]; i++)
SvREFCNT_dec(PL_beginav_save);
SvREFCNT_dec(PL_endav);
SvREFCNT_dec(PL_checkav);
+ SvREFCNT_dec(PL_checkav_save);
SvREFCNT_dec(PL_initav);
PL_beginav = Nullav;
PL_beginav_save = Nullav;
PL_endav = Nullav;
PL_checkav = Nullav;
+ PL_checkav_save = Nullav;
PL_initav = Nullav;
/* shortcuts just get cleared */
SvREFCNT_dec(PL_utf8_totitle);
SvREFCNT_dec(PL_utf8_tolower);
SvREFCNT_dec(PL_utf8_tofold);
+ SvREFCNT_dec(PL_utf8_idstart);
+ SvREFCNT_dec(PL_utf8_idcont);
PL_utf8_alnum = Nullsv;
PL_utf8_alnumc = Nullsv;
PL_utf8_ascii = Nullsv;
PL_utf8_totitle = Nullsv;
PL_utf8_tolower = Nullsv;
PL_utf8_tofold = Nullsv;
+ PL_utf8_idstart = Nullsv;
+ PL_utf8_idcont = Nullsv;
if (!specialWARN(PL_compiling.cop_warnings))
SvREFCNT_dec(PL_compiling.cop_warnings);
if (!specialCopIO(PL_compiling.cop_io))
SvREFCNT_dec(PL_compiling.cop_io);
PL_compiling.cop_io = Nullsv;
-#ifdef USE_ITHREADS
- Safefree(CopFILE(&PL_compiling));
- CopFILE(&PL_compiling) = Nullch;
- Safefree(CopSTASHPV(&PL_compiling));
-#else
- SvREFCNT_dec(CopFILEGV(&PL_compiling));
- CopFILEGV(&PL_compiling) = Nullgv;
- /* cop_stash is not refcounted */
-#endif
+ CopFILE_free(&PL_compiling);
+ CopSTASH_free(&PL_compiling);
/* Prepare to destruct main symbol table. */
FREETMPS;
if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) {
if (PL_scopestack_ix != 0)
- Perl_warner(aTHX_ WARN_INTERNAL,
+ Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
"Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
(long)PL_scopestack_ix);
if (PL_savestack_ix != 0)
- Perl_warner(aTHX_ WARN_INTERNAL,
+ Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
"Unbalanced saves: %ld more saves than restores\n",
(long)PL_savestack_ix);
if (PL_tmps_floor != -1)
- Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced tmps: %ld more allocs than frees\n",
+ Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced tmps: %ld more allocs than frees\n",
(long)PL_tmps_floor + 1);
if (cxstack_ix != -1)
- Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced context: %ld more PUSHes than POPs\n",
+ Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced context: %ld more PUSHes than POPs\n",
(long)cxstack_ix + 1);
}
hent = array[0];
for (;;) {
if (hent && ckWARN_d(WARN_INTERNAL)) {
- Perl_warner(aTHX_ WARN_INTERNAL,
+ Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
"Unbalanced string table refcount: (%d) for \"%s\"",
HeVAL(hent) - Nullsv, HeKEY(hent));
HeVAL(hent) = Nullsv;
SvANY(&PL_sv_no) = NULL;
SvFLAGS(&PL_sv_no) = 0;
- SvREFCNT(&PL_sv_undef) = 0;
- SvREADONLY_off(&PL_sv_undef);
+ {
+ int i;
+ for (i=0; i<=2; i++) {
+ SvREFCNT(PERL_DEBUG_PAD(i)) = 0;
+ sv_clear(PERL_DEBUG_PAD(i));
+ SvANY(PERL_DEBUG_PAD(i)) = NULL;
+ SvFLAGS(PERL_DEBUG_PAD(i)) = 0;
+ }
+ }
if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
- Perl_warner(aTHX_ WARN_INTERNAL,"Scalars leaked: %ld\n", (long)PL_sv_count);
+ Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Scalars leaked: %ld\n", (long)PL_sv_count);
#if defined(PERLIO_LAYERS)
/* No more IO - including error messages ! */
PerlIO_cleanup(aTHX);
#endif
+ /* sv_undef needs to stay immortal until after PerlIO_cleanup
+ as currently layers use it rather than Nullsv as a marker
+ for no arg - and will try and SvREFCNT_dec it.
+ */
+ SvREFCNT(&PL_sv_undef) = 0;
+ SvREADONLY_off(&PL_sv_undef);
+
Safefree(PL_origfilename);
Safefree(PL_reg_start_tmp);
if (PL_reg_curpm)
#endif /* USE_5005THREADS */
#ifdef USE_REENTRANT_API
- Safefree(PL_reentrant_buffer->tmbuff);
- Safefree(PL_reentrant_buffer);
+ Perl_reentrant_free(aTHX);
#endif
sv_free_arenas();
# endif
PerlMem_free(aTHXx);
# ifdef NETWARE
- nw5_delete_internal_host(host);
+ nw_delete_internal_host(host);
# else
win32_delete_internal_host(host);
# endif
goto reswitch;
break;
+ case 't':
+ if( !PL_tainting ) {
+ PL_taint_warn = TRUE;
+ PL_tainting = TRUE;
+ }
+ s++;
+ goto reswitch;
case 'T':
PL_tainting = TRUE;
+ PL_taint_warn = FALSE;
s++;
goto reswitch;
#ifdef MACOS_TRADITIONAL
/* ignore -e for Dev:Pseudo argument */
if (argv[1] && !strcmp(argv[1], "Dev:Pseudo"))
- break;
+ break;
#endif
if (PL_euid != PL_uid || PL_egid != PL_gid)
Perl_croak(aTHX_ "No -e allowed in setuid scripts");
char *popt = s;
while (isSPACE(*s))
s++;
- if (*s == '-' && *(s+1) == 'T')
+ if (*s == '-' && *(s+1) == 'T') {
PL_tainting = TRUE;
+ PL_taint_warn = FALSE;
+ }
else {
char *popt_copy = Nullch;
while (s && *s) {
d = s;
if (!*s)
break;
- if (!strchr("DIMUdmw", *s))
+ if (!strchr("DIMUdmtw", *s))
Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
while (++s && *s) {
if (isSPACE(*s)) {
break;
}
}
- moreswitches(d);
+ if (*d == 't') {
+ if( !PL_tainting ) {
+ PL_taint_warn = TRUE;
+ PL_tainting = TRUE;
+ }
+ } else {
+ moreswitches(d);
+ }
}
}
}
+ if (PL_taint_warn && PL_dowarn != G_WARN_ALL_OFF) {
+ PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
+ }
+
if (!scriptname)
scriptname = argv[0];
if (PL_e_script) {
Sighandler_t sigstate = rsignal_state(SIGCHLD);
if (sigstate == SIG_IGN) {
if (ckWARN(WARN_SIGNAL))
- Perl_warner(aTHX_ WARN_SIGNAL,
+ Perl_warner(aTHX_ packWARN(WARN_SIGNAL),
"Can't ignore signal CHLD, forcing to default");
(void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
}
if (!PL_do_undump)
init_postdump_symbols(argc,argv,env);
+ /* PL_wantutf8 is conditionally turned on by
+ * locale.c:Perl_init_i18nl10n() if the environment
+ * look like the user wants to use UTF-8. */
+ if (PL_wantutf8) { /* Requires init_predump_symbols(). */
+ IO* io;
+ PerlIO* fp;
+ SV* sv;
+ /* Turn on UTF-8-ness on STDIN, STDOUT, STDERR
+ * _and_ the default open discipline. */
+ if (PL_stdingv && (io = GvIO(PL_stdingv)) && (fp = IoIFP(io)))
+ PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
+ if (PL_defoutgv && (io = GvIO(PL_defoutgv)) && (fp = IoOFP(io)))
+ PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
+ if (PL_stderrgv && (io = GvIO(PL_stderrgv)) && (fp = IoOFP(io)))
+ PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
+ if ((sv = GvSV(gv_fetchpv("\017PEN", TRUE, SVt_PV)))) {
+ sv_setpvn(sv, ":utf8\0:utf8", 11);
+ SvSETMAGIC(sv);
+ }
+ }
+
init_lexer();
/* now parse the script */
if (PL_minus_c) {
#ifdef MACOS_TRADITIONAL
- PerlIO_printf(Perl_error_log, "# %s syntax OK\n", MacPerl_MPWFileName(PL_origfilename));
+ PerlIO_printf(Perl_error_log, "%s%s syntax OK\n",
+ (gMacPerl_ErrorFormat ? "# " : ""),
+ MacPerl_MPWFileName(PL_origfilename));
#else
PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
#endif
}
/*
+=head1 SV Manipulation Functions
+
=for apidoc p||get_sv
Returns the SV of the specified Perl scalar. If C<create> is set and the
}
/*
+=head1 Array Manipulation Functions
+
=for apidoc p||get_av
Returns the AV of the specified Perl array. If C<create> is set and the
}
/*
+=head1 Hash Manipulation Functions
+
=for apidoc p||get_hv
Returns the HV of the specified Perl hash. If C<create> is set and the
}
/*
+=head1 CV Manipulation Functions
+
=for apidoc p||get_cv
Returns the CV of the specified Perl subroutine. If C<create> is set and
/* Be sure to refetch the stack pointer after calling these routines. */
/*
+
+=head1 Callback Functions
+
=for apidoc p||call_argv
Performs a callback to the specified Perl sub. See L<perlcall>.
/* Require a module. */
/*
+=head1 Embedding Functions
+
=for apidoc p||require_pv
Tells Perl to C<require> the file named by the string argument. It is
"-s enable rudimentary parsing for switches after programfile",
"-S look for programfile using PATH environment variable",
"-T enable tainting checks",
+"-t enable tainting warnings",
"-u dump core after parsing program",
"-U allow unsafe operations",
"-v print version, subversion (includes VERY IMPORTANT perl info)",
else if (!rschar && numlen >= 2)
PL_rs = newSVpvn("", 0);
else {
- char ch = rschar;
+ char ch = (char)rschar;
PL_rs = newSVpvn(&ch, 1);
}
return s + numlen;
forbid_setid("-D");
if (isALPHA(s[1])) {
/* if adding extra options, remember to update DEBUG_MASK */
- static char debopts[] = "psltocPmfrxuLHXDSTR";
+ static char debopts[] = "psltocPmfrxuLHXDSTRJvC";
char *d;
for (s++; *s && (d = strchr(debopts,*s)); s++)
PL_debug = atoi(s+1);
for (s++; isDIGIT(*s); s++) ;
}
+#ifdef EBCDIC
+ if (DEBUG_p_TEST_ && ckWARN_d(WARN_DEBUGGING))
+ Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
+ "-Dp not implemented on this platform\n");
+#endif
PL_debug |= DEBUG_TOP_FLAG;
-#else
+#else /* !DEBUGGING */
if (ckWARN_d(WARN_DEBUGGING))
- Perl_warner(aTHX_ WARN_DEBUGGING,
+ Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
"Recompile perl with -DDEBUGGING to use -D switch\n");
for (s++; isALNUM(*s); s++) ;
#endif
}
case 'h':
usage(PL_origargv[0]);
- PerlProc_exit(0);
+ my_exit(0);
case 'i':
if (PL_inplace)
Safefree(PL_inplace);
+#if defined(__CYGWIN__) /* do backup extension automagically */
+ if (*(s+1) == '\0') {
+ PL_inplace = savepv(".bak");
+ return s+1;
+ }
+#endif /* __CYGWIN__ */
PL_inplace = savepv(s+1);
/*SUPPRESS 530*/
for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
PL_doswitches = TRUE;
s++;
return s;
+ case 't':
+ if (!PL_tainting)
+ Perl_croak(aTHX_ "Too late for \"-t\" option");
+ s++;
+ return s;
case 'T':
if (!PL_tainting)
Perl_croak(aTHX_ "Too late for \"-T\" option");
#endif
PerlIO_printf(PerlIO_stdout(),
- "\n\nCopyright 1987-2001, Larry Wall\n");
+ "\n\nCopyright 1987-2002, Larry Wall\n");
#ifdef MACOS_TRADITIONAL
PerlIO_printf(PerlIO_stdout(),
- "\nMac OS port Copyright 1991-2001, Matthias Neeracher;\n"
+ "\nMac OS port Copyright 1991-2002, Matthias Neeracher;\n"
"maintained by Chris Nandor\n");
#endif
#ifdef MSDOS
#ifdef OS2
PerlIO_printf(PerlIO_stdout(),
"\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
- "Version 5 port Copyright (c) 1994-1999, Andreas Kaiser, Ilya Zakharevich\n");
+ "Version 5 port Copyright (c) 1994-2002, Andreas Kaiser, Ilya Zakharevich\n");
#endif
#ifdef atarist
PerlIO_printf(PerlIO_stdout(),
#endif
#ifdef MPE
PerlIO_printf(PerlIO_stdout(),
- "MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-2001\n");
+ "MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-2002\n");
#endif
#ifdef OEMVS
PerlIO_printf(PerlIO_stdout(),
#endif
#ifdef __VOS__
PerlIO_printf(PerlIO_stdout(),
- "Stratus VOS port by Paul_Green@stratus.com, 1997-1999\n");
+ "Stratus VOS port by Paul.Green@stratus.com, 1997-2002\n");
#endif
#ifdef __OPEN_VM
PerlIO_printf(PerlIO_stdout(),
#endif
#ifdef EPOC
PerlIO_printf(PerlIO_stdout(),
- "EPOC port by Olaf Flebbe, 1999-2000\n");
+ "EPOC port by Olaf Flebbe, 1999-2002\n");
#endif
#ifdef UNDER_CE
- printf("WINCE port by Rainer Keuchel, 2001\n");
+ printf("WINCE port by Rainer Keuchel, 2001-2002\n");
printf("Built on " __DATE__ " " __TIME__ "\n\n");
wce_hitreturn();
#endif
Complete documentation for Perl, including FAQ lists, should be found on\n\
this system using `man perl' or `perldoc perl'. If you have access to the\n\
Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
- PerlProc_exit(0);
+ my_exit(0);
case 'w':
if (! (PL_dowarn & G_WARN_ALL_MASK))
PL_dowarn |= G_WARN_ON;
return s;
case 'W':
PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
+ if (!specialWARN(PL_compiling.cop_warnings))
+ SvREFCNT_dec(PL_compiling.cop_warnings);
PL_compiling.cop_warnings = pWARN_ALL ;
s++;
return s;
case 'X':
PL_dowarn = G_WARN_ALL_OFF;
+ if (!specialWARN(PL_compiling.cop_warnings))
+ SvREFCNT_dec(PL_compiling.cop_warnings);
PL_compiling.cop_warnings = pWARN_NONE ;
s++;
return s;
{
GV *gv;
-
-
PL_curstash = PL_defstash = newHV();
PL_curstname = newSVpvn("main",4);
gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
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) {
}
}
-#ifdef USE_ITHREADS
- Safefree(CopFILE(PL_curcop));
-#else
- SvREFCNT_dec(CopFILEGV(PL_curcop));
-#endif
+ CopFILE_free(PL_curcop);
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;
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",
}
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
}
}
defined(HAS_STRUCT_FS_DATA) && \
defined(NOSTAT_ONE)
# define FD_ON_NOSUID_CHECK_OKAY
- struct stat fdst;
+ Stat_t fdst;
if (fstat(fd, &fdst) == 0) {
struct ustat us;
# define FD_ON_NOSUID_CHECK_OKAY
FILE *mtab = fopen("/etc/mtab", "r");
struct mntent *entry;
- struct stat stb, fsb;
+ Stat_t stb, fsb;
if (mtab && (fstat(fd, &stb) == 0)) {
while (entry = getmntent(mtab)) {
* Then we just have to make sure he or she can execute it.
*/
{
- struct stat tmpstatbuf;
+ Stat_t tmpstatbuf;
if (
#ifdef HAS_SETREUID
S_find_beginning(pTHX)
{
register char *s, *s2;
+#ifdef MACOS_TRADITIONAL
+ int maclines = 0;
+#endif
/* skip forward in input to the real script? */
if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
if (!gMacPerl_AlwaysExtract)
Perl_croak(aTHX_ "No Perl script found in input\n");
-
+
if (PL_doextract) /* require explicit override ? */
if (!OverrideExtract(PL_origfilename))
Perl_croak(aTHX_ "User aborted script\n");
else
PL_doextract = FALSE;
-
+
/* Pater peccavi, file does not have #! */
PerlIO_rewind(PL_rsfp);
-
+
break;
}
#else
;
}
#ifdef MACOS_TRADITIONAL
+ /* We are always searching for the #!perl line in MacPerl,
+ * so if we find it, still keep the line count correct
+ * by counting lines we already skipped over
+ */
+ for (; maclines > 0 ; maclines--)
+ PerlIO_ungetc(PL_rsfp, '\n');
+
break;
+
+ /* gMacPerl_AlwaysExtract is false in MPW tool */
+ } else if (gMacPerl_AlwaysExtract) {
+ ++maclines;
#endif
}
}
{
char buf[MAXPATHLEN];
int len = readlink(PROCSELFEXE_PATH, buf, sizeof(buf) - 1);
- if (len > 0) {
+
+ /* On Playstation2 Linux V1.0 (kernel 2.2.1) readlink(/proc/self/exe)
+ includes a spurious NUL which will cause $^X to fail in system
+ or backticks (this will prevent extensions from being built and
+ many tests from working). readlink is not meant to add a NUL.
+ Normal readlink works fine.
+ */
+ if (len > 0 && buf[len-1] == '\0') {
+ len--;
+ }
+
+ /* FreeBSD's implementation is acknowledged to be imperfect, sometimes
+ returning the text "unknown" from the readlink rather than the path
+ to the executable (or returning an error from the readlink). Any valid
+ path has a '/' in it somewhere, so use that to validate the result.
+ See http://www.freebsd.org/cgi/query-pr.cgi?pr=35703
+ */
+ if (len > 0 && memchr(buf, '/', len)) {
sv_setpvn(sv,buf,len);
}
else {
char *s;
SV *sv;
GV* tmpgv;
-#ifdef NEED_ENVIRON_DUP_FOR_MODIFY
- char **dup_env_base = 0;
- int dup_env_count = 0;
-#endif
PL_toptarget = NEWSV(0,0);
sv_upgrade(PL_toptarget, SVt_PVFM);
*/
if (!env)
env = environ;
- if (env != environ)
- environ[0] = Nullch;
-#ifdef NEED_ENVIRON_DUP_FOR_MODIFY
+ if (env != environ
+# ifdef USE_ITHREADS
+ && PL_curinterp == aTHX
+# endif
+ )
{
- char **env_base;
- for (env_base = env; *env; env++)
- dup_env_count++;
- if ((dup_env_base = (char **)
- safesysmalloc( sizeof(char *) * (dup_env_count+1) ))) {
- char **dup_env;
- for (env = env_base, dup_env = dup_env_base;
- *env;
- env++, dup_env++) {
- /* With environ one needs to use safesysmalloc(). */
- *dup_env = safesysmalloc(strlen(*env) + 1);
- (void)strcpy(*dup_env, *env);
- }
- *dup_env = Nullch;
- env = dup_env_base;
- } /* else what? */
+ environ[0] = Nullch;
}
-#endif /* NEED_ENVIRON_DUP_FOR_MODIFY */
if (env)
for (; *env; env++) {
if (!(s = strchr(*env,'=')))
continue;
- *s++ = '\0';
#if defined(MSDOS)
+ *s = '\0';
(void)strupr(*env);
+ *s = '=';
#endif
- sv = newSVpv(s--,0);
+ sv = newSVpv(s+1, 0);
(void)hv_store(hv, *env, s - *env, sv, 0);
- *s = '=';
+ if (env != environ)
+ mg_set(sv);
}
-#ifdef NEED_ENVIRON_DUP_FOR_MODIFY
- if (dup_env_base) {
- char **dup_env;
- for (dup_env = dup_env_base; *dup_env; dup_env++)
- safesysfree(*dup_env);
- safesysfree(dup_env_base);
- }
-#endif /* NEED_ENVIRON_DUP_FOR_MODIFY */
#endif /* USE_ENVIRON_ARRAY */
}
TAINT_NOT;
- if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV)))
+ if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) {
+ SvREADONLY_off(GvSV(tmpgv));
sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
+ SvREADONLY_on(GvSV(tmpgv));
+ }
+#ifdef THREADS_HAVE_PIDS
+ PL_ppid = (IV)getppid();
+#endif
+
+ /* touch @F array to prevent spurious warnings 20020415 MJD */
+ if (PL_minus_a) {
+ (void) get_av("main::F", TRUE | GV_ADDMULTI);
+ }
+ /* touch @- and @+ arrays to prevent spurious warnings 20020415 MJD */
+ (void) get_av("main::-", TRUE | GV_ADDMULTI);
+ (void) get_av("main::+", TRUE | GV_ADDMULTI);
}
STATIC void
#endif
#ifdef MACOS_TRADITIONAL
{
- struct stat tmpstatbuf;
+ Stat_t tmpstatbuf;
SV * privdir = NEWSV(55, 0);
char * macperl = PerlEnv_getenv("MACPERL");
p = Nullch; /* break out */
}
#ifdef MACOS_TRADITIONAL
- if (!strchr(SvPVX(libdir), ':'))
- sv_insert(libdir, 0, 0, ":", 1);
+ if (!strchr(SvPVX(libdir), ':')) {
+ char buf[256];
+
+ sv_setpv(libdir, MacPerl_CanonDir(SvPVX(libdir), buf, 0));
+ }
if (SvPVX(libdir)[SvCUR(libdir)-1] != ':')
sv_catpv(libdir, ":");
#endif
const char *incverlist[] = { PERL_INC_VERSION_LIST };
const char **incver;
#endif
- struct stat tmpstatbuf;
+ Stat_t tmpstatbuf;
#ifdef VMS
char *unix;
STRLEN len;
while (AvFILL(paramList) >= 0) {
cv = (CV*)av_shift(paramList);
- if (PL_savebegin && (paramList == PL_beginav)) {
+ if (PL_savebegin) {
+ if (paramList == PL_beginav) {
/* save PL_beginav for compiler */
- if (! PL_beginav_save)
- PL_beginav_save = newAV();
- av_push(PL_beginav_save, (SV*)cv);
+ if (! PL_beginav_save)
+ PL_beginav_save = newAV();
+ av_push(PL_beginav_save, (SV*)cv);
+ }
+ else if (paramList == PL_checkav) {
+ /* save PL_checkav for compiler */
+ if (! PL_checkav_save)
+ PL_checkav_save = newAV();
+ av_push(PL_checkav_save, (SV*)cv);
+ }
} else {
SAVEFREESV(cv);
}
https://perl5.git.perl.org / perl5.git / blobdiff