/* 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
-#if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE)
+#if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE) && !defined(PERL_MICRO)
char *getenv (char *); /* Usually in <stdlib.h> */
#endif
-static I32 read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen);
+static I32 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen);
#ifdef IAMSUID
#ifndef DOSUID
#endif
#endif
-#ifdef PERL_OBJECT
-#define perl_construct Perl_construct
-#define perl_parse Perl_parse
-#define perl_run Perl_run
-#define perl_destruct Perl_destruct
-#define perl_free Perl_free
-#endif
-
#if defined(USE_5005THREADS)
# define INIT_TLS_AND_INTERP \
STMT_START { \
struct IPerlProc* ipP)
{
PerlInterpreter *my_perl;
-#ifdef PERL_OBJECT
- my_perl = (PerlInterpreter*)new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd,
- ipLIO, ipD, ipS, ipP);
- INIT_TLS_AND_INTERP;
-#else
/* New() needs interpreter, so call malloc() instead */
my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
INIT_TLS_AND_INTERP;
PL_Dir = ipD;
PL_Sock = ipS;
PL_Proc = ipP;
-#endif
return my_perl;
}
#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));
SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
}
-#ifdef PERL_OBJECT
- /* TODO: */
- /* PL_sighandlerp = sighandler; */
-#else
PL_sighandlerp = Perl_sighandler;
-#endif
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_nrs = newSVpvn("\n", 1);
- PL_rs = SvREFCNT_inc(PL_nrs);
+ PL_rs = newSVpvn("\n", 1);
init_stacks();
sys_intern_init();
#endif
- PerlIO_init(); /* Hook to IO system */
+ PerlIO_init(aTHX); /* Hook to IO system */
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);
+ Perl_reentrant_init(aTHX);
#endif
+
+ /* Note that strtab is a rather special HV. Assumptions are made
+ about not iterating on it, and not adding tie magic to it.
+ It is properly deallocated in perl_destruct() */
+ PL_strtab = newHV();
+
+#ifdef USE_5005THREADS
+ MUTEX_INIT(&PL_strtab_mutex);
+#endif
+ HvSHAREKEYS_off(PL_strtab); /* mandatory */
+ hv_ksplit(PL_strtab, 512);
+
+#if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__))
+ _dyld_lookup_and_bind
+ ("__environ", (unsigned long *) &environ_pointer, NULL);
+#endif /* environ */
+
+#ifdef USE_ENVIRON_ARRAY
+ PL_origenviron = environ;
+#endif
+
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>.
int
perl_destruct(pTHXx)
{
- int destruct_level; /* 0=none, 1=full, 2=full with checks */
+ volatile int destruct_level; /* 0=none, 1=full, 2=full with checks */
HV *hv;
#ifdef USE_5005THREADS
Thread t;
LEAVE;
FREETMPS;
+ /* Need to flush since END blocks can produce output */
+ PerlIO_flush((PerlIO*)NULL);
+
+ 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 */
/* call exit list functions */
while (PL_exitlistlen-- > 0)
- PL_exitlist[PL_exitlistlen].fn(aTHXo_ PL_exitlist[PL_exitlistlen].ptr);
+ PL_exitlist[PL_exitlistlen].fn(aTHX_ PL_exitlist[PL_exitlistlen].ptr);
Safefree(PL_exitlist);
DEBUG_P(debprofdump());
+#if defined(PERLIO_LAYERS)
+ /* No more IO - including error messages ! */
+ PerlIO_cleanup(aTHX);
+#endif
+
/* The exit() function will do everything that needs doing. */
return STATUS_NATIVE_EXPORT;;
}
/* jettison our possibly duplicated environment */
-
-#ifdef USE_ENVIRON_ARRAY
+ /* if PERL_USE_SAFE_PUTENV is defined environ will not have been copied
+ * so we certainly shouldn't free it here
+ */
+#if defined(USE_ENVIRON_ARRAY) && !defined(PERL_USE_SAFE_PUTENV)
if (environ != PL_origenviron) {
I32 i;
for (i = 0; environ[i]; i++)
safesysfree(environ[i]);
+
/* Must use safesysfree() when working with environ. */
safesysfree(environ);
while (i) {
SV *resv = ary[--i];
- REGEXP *re = (REGEXP *)SvIVX(resv);
+ REGEXP *re = INT2PTR(REGEXP *,SvIVX(resv));
if (SvFLAGS(resv) & SVf_BREAK) {
/* this is PL_reg_curpm, already freed
* flag is set in regexec.c:S_regtry
*/
SvFLAGS(resv) &= ~SVf_BREAK;
- }
+ }
else if(SvREPADTMP(resv)) {
SvREPADTMP_off(resv);
}
SvREFCNT_dec(PL_rs); /* $/ */
PL_rs = Nullsv;
- SvREFCNT_dec(PL_nrs); /* $/ helper */
- PL_nrs = Nullsv;
-
PL_multiline = 0; /* $* */
Safefree(PL_osname); /* $^O */
PL_osname = Nullch;
/* startup and shutdown function lists */
SvREFCNT_dec(PL_beginav);
+ SvREFCNT_dec(PL_beginav_save);
SvREFCNT_dec(PL_endav);
SvREFCNT_dec(PL_checkav);
SvREFCNT_dec(PL_initav);
PL_beginav = Nullav;
+ PL_beginav_save = Nullav;
PL_endav = Nullav;
PL_checkav = Nullav;
PL_initav = Nullav;
SvREFCNT_dec(PL_utf8_xdigit);
SvREFCNT_dec(PL_utf8_mark);
SvREFCNT_dec(PL_utf8_toupper);
+ 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_toupper = 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;
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
Safefree(PL_origfilename);
Safefree(PL_reg_start_tmp);
#endif /* USE_5005THREADS */
#ifdef USE_REENTRANT_API
- Safefree(PL_reentrant_buffer->tmbuff);
- Safefree(PL_reentrant_buffer);
+ Perl_reentrant_free(aTHX);
#endif
sv_free_arenas();
void
perl_free(pTHXx)
{
-#if defined(PERL_OBJECT)
- PerlMem_free(this);
-#else
-# if defined(WIN32) || defined(NETWARE)
+#if defined(WIN32) || defined(NETWARE)
# if defined(PERL_IMPLICIT_SYS)
- #ifdef NETWARE
- void *host = nw_internal_host;
- #else
- void *host = w32_internal_host;
- #endif
- #ifndef NETWARE
- if (PerlProc_lasthost()) {
- PerlIO_cleanup();
- }
- #endif
- PerlMem_free(aTHXx);
- #ifdef NETWARE
- nw5_delete_internal_host(host);
- #else
- win32_delete_internal_host(host);
- #endif
-#else
- PerlIO_cleanup();
+# ifdef NETWARE
+ void *host = nw_internal_host;
+# else
+ void *host = w32_internal_host;
+# endif
PerlMem_free(aTHXx);
-#endif
+# ifdef NETWARE
+ nw_delete_internal_host(host);
+# else
+ win32_delete_internal_host(host);
+# endif
# else
PerlMem_free(aTHXx);
# endif
+#else
+ PerlMem_free(aTHXx);
#endif
}
#endif
#endif
-#if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__))
- _dyld_lookup_and_bind
- ("__environ", (unsigned long *) &environ_pointer, NULL);
-#endif /* environ */
-
PL_origargc = argc;
{
/* we copy rather than point to argv
* since perl_clone will copy and perl_destruct
- * has no way of knowing if we've made a copy or
+ * has no way of knowing if we've made a copy or
* just point to argv
*/
int i = PL_origargc;
}
}
-#ifdef USE_ENVIRON_ARRAY
- PL_origenviron = environ;
-#endif
+
if (PL_do_undump) {
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 USE_SOCKS
sv_catpv(PL_Sv," USE_SOCKS");
# endif
-# ifdef PERL_OBJECT
- sv_catpv(PL_Sv," PERL_OBJECT");
-# endif
# ifdef PERL_IMPLICIT_CONTEXT
sv_catpv(PL_Sv," PERL_IMPLICIT_CONTEXT");
# endif
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);
}
#endif
if (xsinit)
- (*xsinit)(aTHXo); /* in case linked C routines want magical variables */
+ (*xsinit)(aTHX); /* in case linked C routines want magical variables */
#ifndef PERL_MICRO
#if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) || defined(EPOC)
init_os_extras();
if (!PL_do_undump)
init_postdump_symbols(argc,argv,env);
+ if (PL_wantutf8) { /* Requires init_predump_symbols(). */
+ IO* io;
+ PerlIO* fp;
+ SV* sv;
+ 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 */
PL_e_script = Nullsv;
}
- /* now that script is parsed, we can modify record separator */
- SvREFCNT_dec(PL_rs);
- PL_rs = SvREFCNT_inc(PL_nrs);
+/*
+ Not sure that this is still the right place to do this now that we
+ no longer use PL_nrs. HVDS 2001/09/09
+*/
sv_setsv(get_sv("/", TRUE), PL_rs);
+
if (PL_do_undump)
my_unexec();
#endif
oldscope = PL_scopestack_ix;
+#ifdef VMS
+ VMSISH_HUSHED = 0;
+#endif
#ifdef PERL_FLEXIBLE_EXCEPTIONS
redo_body:
LEAVE;
FREETMPS;
PL_curstash = PL_defstash;
- if (!(PL_exit_flags & PERL_EXIT_DESTRUCT_END) &&
+ if (!(PL_exit_flags & PERL_EXIT_DESTRUCT_END) &&
PL_endav && !PL_minus_c)
call_list(oldscope, PL_endav);
#ifdef MYMALLOC
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 syntax OK\n", 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)",
switch (*s) {
case '0':
{
- numlen = 0; /* disallow underscores */
- rschar = (U32)scan_oct(s, 4, &numlen);
- SvREFCNT_dec(PL_nrs);
+ I32 flags = 0;
+ numlen = 4;
+ rschar = (U32)grok_oct(s, &numlen, &flags, NULL);
+ SvREFCNT_dec(PL_rs);
if (rschar & ~((U8)~0))
- PL_nrs = &PL_sv_undef;
+ PL_rs = &PL_sv_undef;
else if (!rschar && numlen >= 2)
- PL_nrs = newSVpvn("", 0);
+ PL_rs = newSVpvn("", 0);
else {
- char ch = rschar;
- PL_nrs = newSVpvn(&ch, 1);
+ char ch = (char)rschar;
+ PL_rs = newSVpvn(&ch, 1);
}
return s + numlen;
}
return s;
case 'F':
PL_minus_F = TRUE;
- PL_splitstr = savepv(s + 1);
- s += strlen(s);
+ PL_splitstr = ++s;
+ while (*s && !isSPACE(*s)) ++s;
+ *s = '\0';
+ PL_splitstr = savepv(PL_splitstr);
return s;
case 'a':
PL_minus_a = TRUE;
forbid_setid("-D");
if (isALPHA(s[1])) {
/* if adding extra options, remember to update DEBUG_MASK */
- static char debopts[] = "psltocPmfrxuLHXDSTR";
+ static char debopts[] = "psltocPmfrxuLHXDSTRJ";
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
s++;
}
return s;
- case 'I': /* -I handled both here and in parse_perl() */
+ case 'I': /* -I handled both here and in parse_body() */
forbid_setid("-I");
++s;
while (*s && isSPACE(*s))
PL_ors_sv = Nullsv;
}
if (isDIGIT(*s)) {
+ I32 flags = 0;
PL_ors_sv = newSVpvn("\n",1);
- numlen = 0; /* disallow underscores */
- *SvPVX(PL_ors_sv) = (char)scan_oct(s, 3 + (*s == '0'), &numlen);
+ numlen = 3 + (*s == '0');
+ *SvPVX(PL_ors_sv) = (char)grok_oct(s, &numlen, &flags, NULL);
s += numlen;
}
else {
- if (RsPARA(PL_nrs)) {
+ if (RsPARA(PL_rs)) {
PL_ors_sv = newSVpvn("\n\n",2);
}
else {
- PL_ors_sv = newSVsv(PL_nrs);
+ PL_ors_sv = newSVsv(PL_rs);
}
}
return 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 (c) 1991-2001, Matthias Neeracher\n");
+ "\nMac OS port Copyright 1991-2002, Matthias Neeracher;\n"
+ "maintained by Chris Nandor\n");
#endif
#ifdef MSDOS
PerlIO_printf(PerlIO_stdout(),
#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
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;
S_init_interp(pTHX)
{
-#ifdef PERL_OBJECT /* XXX kludge */
-#define I_REINIT \
- STMT_START { \
- PL_chopset = " \n-"; \
- PL_copline = NOLINE; \
- PL_curcop = &PL_compiling;\
- PL_curcopdb = NULL; \
- PL_dbargs = 0; \
- PL_dumpindent = 4; \
- PL_laststatval = -1; \
- PL_laststype = OP_STAT; \
- PL_maxscream = -1; \
- PL_maxsysfd = MAXSYSFD; \
- PL_statname = Nullsv; \
- PL_tmps_floor = -1; \
- PL_tmps_ix = -1; \
- PL_op_mask = NULL; \
- PL_laststatval = -1; \
- PL_laststype = OP_STAT; \
- PL_mess_sv = Nullsv; \
- PL_splitstr = " "; \
- PL_generation = 100; \
- PL_exitlist = NULL; \
- PL_exitlistlen = 0; \
- PL_regindent = 0; \
- PL_in_clean_objs = FALSE; \
- PL_in_clean_all = FALSE; \
- PL_profiledata = NULL; \
- PL_rsfp = Nullfp; \
- PL_rsfp_filters = Nullav; \
- PL_dirty = FALSE; \
- } STMT_END
- I_REINIT;
-#else
-# ifdef MULTIPLICITY
-# define PERLVAR(var,type)
-# define PERLVARA(var,n,type)
-# if defined(PERL_IMPLICIT_CONTEXT)
-# if defined(USE_5005THREADS)
-# define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
-# define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
-# else /* !USE_5005THREADS */
-# define PERLVARI(var,type,init) aTHX->var = init;
-# define PERLVARIC(var,type,init) aTHX->var = init;
-# endif /* USE_5005THREADS */
-# else
-# define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
+#ifdef MULTIPLICITY
+# define PERLVAR(var,type)
+# define PERLVARA(var,n,type)
+# if defined(PERL_IMPLICIT_CONTEXT)
+# if defined(USE_5005THREADS)
+# define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
# define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
-# endif
-# include "intrpvar.h"
-# ifndef USE_5005THREADS
-# include "thrdvar.h"
-# endif
-# undef PERLVAR
-# undef PERLVARA
-# undef PERLVARI
-# undef PERLVARIC
+# else /* !USE_5005THREADS */
+# define PERLVARI(var,type,init) aTHX->var = init;
+# define PERLVARIC(var,type,init) aTHX->var = init;
+# endif /* USE_5005THREADS */
# else
-# define PERLVAR(var,type)
-# define PERLVARA(var,n,type)
-# define PERLVARI(var,type,init) PL_##var = init;
-# define PERLVARIC(var,type,init) PL_##var = init;
-# include "intrpvar.h"
-# ifndef USE_5005THREADS
-# include "thrdvar.h"
-# endif
-# undef PERLVAR
-# undef PERLVARA
-# undef PERLVARI
-# undef PERLVARIC
+# define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
+# define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
+# endif
+# include "intrpvar.h"
+# ifndef USE_5005THREADS
+# include "thrdvar.h"
+# endif
+# undef PERLVAR
+# undef PERLVARA
+# undef PERLVARI
+# undef PERLVARIC
+#else
+# define PERLVAR(var,type)
+# define PERLVARA(var,n,type)
+# define PERLVARI(var,type,init) PL_##var = init;
+# define PERLVARIC(var,type,init) PL_##var = init;
+# include "intrpvar.h"
+# ifndef USE_5005THREADS
+# include "thrdvar.h"
# endif
+# undef PERLVAR
+# undef PERLVARA
+# undef PERLVARI
+# undef PERLVARIC
#endif
}
{
GV *gv;
- /* Note that strtab is a rather special HV. Assumptions are made
- about not iterating on it, and not adding tie magic to it.
- It is properly deallocated in perl_destruct() */
- PL_strtab = newHV();
-#ifdef USE_5005THREADS
- MUTEX_INIT(&PL_strtab_mutex);
-#endif
- HvSHAREKEYS_off(PL_strtab); /* mandatory */
- hv_ksplit(PL_strtab, 512);
-
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",
+ SvPVX(cmd)));
+
PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
SvREFCNT_dec(cmd);
SvREFCNT_dec(cpp);
}
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
Safefree(PL_retstack);
}
-#ifndef PERL_OBJECT
-static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
-#endif
-
STATIC void
S_init_lexer(pTHX)
{
-#ifdef PERL_OBJECT
- PerlIO *tmpfp;
-#endif
+ PerlIO *tmpfp;
tmpfp = PL_rsfp;
PL_rsfp = Nullfp;
lex_start(PL_linestr);
PL_osname = savepv(OSNAME);
}
-STATIC void
-S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
+void
+Perl_init_argv_symbols(pTHX_ register int argc, register char **argv)
{
char *s;
- SV *sv;
- GV* tmpgv;
-#ifdef NEED_ENVIRON_DUP_FOR_MODIFY
- char **dup_env_base = 0;
- int dup_env_count = 0;
-#endif
-
argc--,argv++; /* skip name of script */
if (PL_doswitches) {
for (; argc > 0 && **argv == '-'; argc--,argv++) {
sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
}
}
+ if ((PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV))) {
+ GvMULTI_on(PL_argvgv);
+ (void)gv_AVadd(PL_argvgv);
+ av_clear(GvAVn(PL_argvgv));
+ for (; argc > 0; argc--,argv++) {
+ SV *sv = newSVpv(argv[0],0);
+ av_push(GvAVn(PL_argvgv),sv);
+ if (PL_widesyscalls)
+ (void)sv_utf8_decode(sv);
+ }
+ }
+}
+
+#ifdef HAS_PROCSELFEXE
+/* This is a function so that we don't hold on to MAXPATHLEN
+ bytes of stack longer than necessary
+ */
+STATIC void
+S_procself_val(pTHX_ SV *sv, char *arg0)
+{
+ char buf[MAXPATHLEN];
+ int len = readlink(PROCSELFEXE_PATH, buf, sizeof(buf) - 1);
+ /* 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 {
+ sv_setpv(sv,arg0);
+ }
+}
+#endif /* HAS_PROCSELFEXE */
+
+STATIC void
+S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
+{
+ char *s;
+ SV *sv;
+ GV* tmpgv;
+
PL_toptarget = NEWSV(0,0);
sv_upgrade(PL_toptarget, SVt_PVFM);
sv_setpvn(PL_toptarget, "", 0);
PL_formtarget = PL_bodytarget;
TAINT;
+
+ init_argv_symbols(argc,argv);
+
if ((tmpgv = gv_fetchpv("0",TRUE, SVt_PV))) {
#ifdef MACOS_TRADITIONAL
/* $0 is not majick on a Mac */
magicname("0", "0", 1);
#endif
}
- if ((tmpgv = gv_fetchpv("\030",TRUE, SVt_PV)))
+ if ((tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))) {/* $^X */
+#ifdef HAS_PROCSELFEXE
+ S_procself_val(aTHX_ GvSV(tmpgv), PL_origargv[0]);
+#else
#ifdef OS2
sv_setpv(GvSV(tmpgv), os2_execname(aTHX));
#else
sv_setpv(GvSV(tmpgv),PL_origargv[0]);
#endif
- if ((PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV))) {
- GvMULTI_on(PL_argvgv);
- (void)gv_AVadd(PL_argvgv);
- av_clear(GvAVn(PL_argvgv));
- for (; argc > 0; argc--,argv++) {
- SV *sv = newSVpv(argv[0],0);
- av_push(GvAVn(PL_argvgv),sv);
- if (PL_widesyscalls)
- (void)sv_utf8_decode(sv);
- }
+#endif
}
if ((PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV))) {
HV *hv;
env = environ;
if (env != environ)
environ[0] = Nullch;
-#ifdef NEED_ENVIRON_DUP_FOR_MODIFY
- {
- 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? */
- }
-#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));
+ }
+
+ /* 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");
const char *incverlist[] = { PERL_INC_VERSION_LIST };
const char **incver;
#endif
- struct stat tmpstatbuf;
+ Stat_t tmpstatbuf;
#ifdef VMS
char *unix;
STRLEN len;
JMPENV_JUMP(2);
}
-#ifdef PERL_OBJECT
-#include "XSUB.h"
-#endif
-
static I32
-read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen)
+read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen)
{
char *p, *nl;
p = SvPVX(PL_e_script);
https://perl5.git.perl.org / perl5.git / blobdiff