summaryrefslogtreecommitdiffstats
path: root/contrib/perl5/perl.c
diff options
context:
space:
mode:
Diffstat (limited to 'contrib/perl5/perl.c')
-rw-r--r--contrib/perl5/perl.c549
1 files changed, 166 insertions, 383 deletions
diff --git a/contrib/perl5/perl.c b/contrib/perl5/perl.c
index 9596b6a..a84bf85 100644
--- a/contrib/perl5/perl.c
+++ b/contrib/perl5/perl.c
@@ -1,10 +1,11 @@
/* perl.c
*
- * Copyright (c) 1987-2001 Larry Wall
+ * Copyright (c) 1987-2000 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.
*
+ * $FreeBSD$
*/
/*
@@ -180,8 +181,6 @@ perl_construct(pTHXx)
# endif /* EMULATE_ATOMIC_REFCOUNTS */
MUTEX_INIT(&PL_cred_mutex);
- MUTEX_INIT(&PL_sv_lock_mutex);
- MUTEX_INIT(&PL_fdpid_mutex);
thr = init_main_thread();
#endif /* USE_THREADS */
@@ -274,15 +273,10 @@ perl_construct(pTHXx)
PL_localpatches = local_patches; /* For possible -v */
#endif
-#ifdef HAVE_INTERP_INTERN
- sys_intern_init();
-#endif
-
PerlIO_init(); /* 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);
ENTER;
}
@@ -298,7 +292,9 @@ Shuts down a Perl interpreter. See L<perlembed>.
void
perl_destruct(pTHXx)
{
+ dTHR;
int destruct_level; /* 0=none, 1=full, 2=full with checks */
+ I32 last_sv_count;
HV *hv;
#ifdef USE_THREADS
Thread t;
@@ -375,7 +371,6 @@ perl_destruct(pTHXx)
DEBUG_S(PerlIO_printf(Perl_debug_log, "perl_destruct: armageddon has arrived\n"));
MUTEX_DESTROY(&PL_threads_mutex);
COND_DESTROY(&PL_nthreads_cond);
- PL_nthreads--;
#endif /* !defined(FAKE_THREADS) */
#endif /* USE_THREADS */
@@ -437,21 +432,6 @@ perl_destruct(pTHXx)
return;
}
- /* jettison our possibly duplicated environment */
-
-#ifdef USE_ENVIRON_ARRAY
- if (environ != PL_origenviron) {
- I32 i;
-
- for (i = 0; environ[i]; i++)
- safesysfree(environ[i]);
- /* Must use safesysfree() when working with environ. */
- safesysfree(environ);
-
- environ = PL_origenviron;
- }
-#endif
-
/* loosen bonds of global variables */
if(PL_rsfp) {
@@ -576,7 +556,6 @@ perl_destruct(pTHXx)
#ifdef USE_LOCALE_NUMERIC
Safefree(PL_numeric_name);
PL_numeric_name = Nullch;
- SvREFCNT_dec(PL_numeric_radix_sv);
#endif
/* clear utf8 character classes */
@@ -617,14 +596,9 @@ perl_destruct(pTHXx)
if (!specialWARN(PL_compiling.cop_warnings))
SvREFCNT_dec(PL_compiling.cop_warnings);
PL_compiling.cop_warnings = Nullsv;
-#ifdef USE_ITHREADS
- Safefree(CopFILE(&PL_compiling));
- CopFILE(&PL_compiling) = Nullch;
- Safefree(CopSTASHPV(&PL_compiling));
-#else
+#ifndef USE_ITHREADS
SvREFCNT_dec(CopFILEGV(&PL_compiling));
- CopFILEGV(&PL_compiling) = Nullgv;
- /* cop_stash is not refcounted */
+ CopFILEGV_set(&PL_compiling, Nullgv);
#endif
/* Prepare to destruct main symbol table. */
@@ -658,13 +632,13 @@ perl_destruct(pTHXx)
}
/* Now absolutely destruct everything, somehow or other, loops or no. */
+ last_sv_count = 0;
SvFLAGS(PL_fdpid) |= SVTYPEMASK; /* don't clean out pid table now */
SvFLAGS(PL_strtab) |= SVTYPEMASK; /* don't clean out strtab now */
-
- /* the 2 is for PL_fdpid and PL_strtab */
- while (PL_sv_count > 2 && sv_clean_all())
- ;
-
+ while (PL_sv_count != 0 && PL_sv_count != last_sv_count) {
+ last_sv_count = PL_sv_count;
+ sv_clean_all();
+ }
SvFLAGS(PL_fdpid) &= ~SVTYPEMASK;
SvFLAGS(PL_fdpid) |= SVt_PVAV;
SvFLAGS(PL_strtab) &= ~SVTYPEMASK;
@@ -674,10 +648,6 @@ perl_destruct(pTHXx)
SvREFCNT_dec(PL_fdpid); /* needed in io_close() */
PL_fdpid = Nullav;
-#ifdef HAVE_INTERP_INTERN
- sys_intern_clear();
-#endif
-
/* Destruct the global string table. */
{
/* Yell and reset the HeVAL() slots that are still holding refcounts,
@@ -709,11 +679,6 @@ perl_destruct(pTHXx)
}
SvREFCNT_dec(PL_strtab);
-#ifdef USE_ITHREADS
- /* free the pointer table used for cloning */
- ptr_table_free(PL_ptr_table);
-#endif
-
/* free special SVs */
SvREFCNT(&PL_sv_yes) = 0;
@@ -732,6 +697,9 @@ perl_destruct(pTHXx)
if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
Perl_warner(aTHX_ WARN_INTERNAL,"Scalars leaked: %ld\n", (long)PL_sv_count);
+ sv_free_arenas();
+
+ /* No SVs have survived, need to clean out */
Safefree(PL_origfilename);
Safefree(PL_reg_start_tmp);
if (PL_reg_curpm)
@@ -739,9 +707,6 @@ perl_destruct(pTHXx)
Safefree(PL_reg_poscache);
Safefree(HeKEY_hek(&PL_hv_fetch_ent_mh));
Safefree(PL_op_mask);
- Safefree(PL_psig_ptr);
- Safefree(PL_psig_name);
- Safefree(PL_bitcount);
nuke_stacks();
PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */
@@ -751,7 +716,6 @@ perl_destruct(pTHXx)
MUTEX_DESTROY(&PL_sv_mutex);
MUTEX_DESTROY(&PL_eval_mutex);
MUTEX_DESTROY(&PL_cred_mutex);
- MUTEX_DESTROY(&PL_fdpid_mutex);
COND_DESTROY(&PL_eval_cond);
#ifdef EMULATE_ATOMIC_REFCOUNTS
MUTEX_DESTROY(&PL_svref_mutex);
@@ -764,8 +728,6 @@ perl_destruct(pTHXx)
PL_thrsv = Nullsv;
#endif /* USE_THREADS */
- sv_free_arenas();
-
/* As the absolutely last thing, free the non-arena SV for mess() */
if (PL_mess_sv) {
@@ -833,6 +795,7 @@ Tells a Perl interpreter to parse a Perl script. See L<perlembed>.
int
perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
{
+ dTHR;
I32 oldscope;
int ret;
dJMPENV;
@@ -855,7 +818,7 @@ setuid perl scripts securely.\n");
PL_origargv = argv;
PL_origargc = argc;
-#ifdef USE_ENVIRON_ARRAY
+#ifndef VMS /* VMS doesn't have environ array */
PL_origenviron = environ;
#endif
@@ -934,6 +897,7 @@ S_vparse_body(pTHX_ va_list args)
STATIC void *
S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
{
+ dTHR;
int argc = PL_origargc;
char **argv = PL_origargv;
char *scriptname = NULL;
@@ -1001,11 +965,6 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
goto reswitch;
case 'e':
-#ifdef MACOS_TRADITIONAL
- /* ignore -e for Dev:Pseudo argument */
- if (argv[1] && !strcmp(argv[1], "Dev:Pseudo"))
- break;
-#endif
if (PL_euid != PL_uid || PL_egid != PL_gid)
Perl_croak(aTHX_ "No -e allowed in setuid scripts");
if (!PL_e_script) {
@@ -1176,7 +1135,6 @@ print \" \\@INC:\\n @INC\\n\";");
PL_tainting = TRUE;
else {
while (s && *s) {
- char *d;
while (isSPACE(*s))
s++;
if (*s == '-') {
@@ -1184,18 +1142,11 @@ print \" \\@INC:\\n @INC\\n\";");
if (isSPACE(*s))
continue;
}
- d = s;
if (!*s)
break;
if (!strchr("DIMUdmw", *s))
Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
- while (++s && *s) {
- if (isSPACE(*s)) {
- *s++ = '\0';
- break;
- }
- }
- moreswitches(d);
+ s = moreswitches(s);
}
}
}
@@ -1235,11 +1186,7 @@ print \" \\@INC:\\n @INC\\n\";");
}
#endif
-#ifdef MACOS_TRADITIONAL
- if (PL_doextract || gMacPerl_AlwaysExtract) {
-#else
if (PL_doextract) {
-#endif
find_beginning();
if (cddir && PerlDir_chdir(cddir) < 0)
Perl_croak(aTHX_ "Can't chdir to %s",cddir);
@@ -1279,16 +1226,12 @@ print \" \\@INC:\\n @INC\\n\";");
if (xsinit)
(*xsinit)(aTHXo); /* in case linked C routines want magical variables */
-#if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) || defined(EPOC)
+#if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__)
init_os_extras();
#endif
#ifdef USE_SOCKS
-# ifdef HAS_SOCKS5_INIT
- socks5_init(argv[0]);
-# else
SOCKSinit(argv[0]);
-# endif
#endif
init_predump_symbols();
@@ -1304,16 +1247,6 @@ print \" \\@INC:\\n @INC\\n\";");
SETERRNO(0,SS$_NORMAL);
PL_error_count = 0;
-#ifdef MACOS_TRADITIONAL
- if (gMacPerl_SyntaxError = (yyparse() || PL_error_count)) {
- if (PL_minus_c)
- Perl_croak(aTHX_ "%s had compilation errors.\n", MacPerl_MPWFileName(PL_origfilename));
- else {
- Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
- MacPerl_MPWFileName(PL_origfilename));
- }
- }
-#else
if (yyparse() || PL_error_count) {
if (PL_minus_c)
Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
@@ -1322,7 +1255,6 @@ print \" \\@INC:\\n @INC\\n\";");
PL_origfilename);
}
}
-#endif
CopLINE_set(PL_curcop, 0);
PL_curstash = PL_defstash;
PL_preprocess = FALSE;
@@ -1368,6 +1300,7 @@ Tells a Perl interpreter to run. See L<perlembed>.
int
perl_run(pTHXx)
{
+ dTHR;
I32 oldscope;
int ret = 0;
dJMPENV;
@@ -1435,6 +1368,8 @@ S_vrun_body(pTHX_ va_list args)
STATIC void *
S_run_body(pTHX_ I32 oldscope)
{
+ dTHR;
+
DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
PL_sawampersand ? "Enabling" : "Omitting"));
@@ -1445,11 +1380,7 @@ S_run_body(pTHX_ I32 oldscope)
PTR2UV(thr)));
if (PL_minus_c) {
-#ifdef MACOS_TRADITIONAL
- 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
my_exit(0);
}
if (PERLDB_SINGLE && PL_DBsingle)
@@ -1493,8 +1424,10 @@ Perl_get_sv(pTHX_ const char *name, I32 create)
#ifdef USE_THREADS
if (name[1] == '\0' && !isALPHA(name[0])) {
PADOFFSET tmp = find_threadsv(name);
- if (tmp != NOT_IN_PAD)
+ if (tmp != NOT_IN_PAD) {
+ dTHR;
return THREADSV(tmp);
+ }
}
#endif /* USE_THREADS */
gv = gv_fetchpv(name, create, SVt_PV);
@@ -1633,7 +1566,18 @@ Perl_call_method(pTHX_ const char *methname, I32 flags)
/* name of the subroutine */
/* See G_* flags in cop.h */
{
- return call_sv(sv_2mortal(newSVpv(methname,0)), flags | G_METHOD);
+ dSP;
+ OP myop;
+ if (!PL_op) {
+ Zero(&myop, 1, OP);
+ PL_op = &myop;
+ }
+ XPUSHs(sv_2mortal(newSVpv(methname,0)));
+ PUTBACK;
+ pp_method();
+ if (PL_op == &myop)
+ PL_op = Nullop;
+ return call_sv(*PL_stack_sp--, flags);
}
/* May be called with any of a CV, a GV, or an SV containing the name. */
@@ -1648,11 +1592,11 @@ L<perlcall>.
I32
Perl_call_sv(pTHX_ SV *sv, I32 flags)
+
/* See G_* flags in cop.h */
{
dSP;
LOGOP myop; /* fake syntax tree node */
- UNOP method_op;
I32 oldmark;
I32 retval;
I32 oldscope;
@@ -1690,14 +1634,6 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags)
&& !(flags & G_NODEBUG))
PL_op->op_private |= OPpENTERSUB_DB;
- if (flags & G_METHOD) {
- Zero(&method_op, 1, UNOP);
- method_op.op_next = PL_op;
- method_op.op_ppaddr = PL_ppaddr[OP_METHOD];
- myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB];
- PL_op = (OP*)&method_op;
- }
-
if (!(flags & G_EVAL)) {
CATCH_SET(TRUE);
call_body((OP*)&myop, FALSE);
@@ -1705,7 +1641,7 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags)
CATCH_SET(oldcatch);
}
else {
- myop.op_other = (OP*)&myop;
+ cLOGOP->op_other = PL_op;
PL_markstack_ptr--;
/* we're trying to emulate pp_entertry() here */
{
@@ -1715,7 +1651,7 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags)
ENTER;
SAVETMPS;
- push_return(Nullop);
+ push_return(PL_op->op_next);
PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
PUSHEVAL(cx, 0, 0);
PL_eval_root = PL_op; /* Only needed so that goto works right. */
@@ -1814,11 +1750,13 @@ S_vcall_body(pTHX_ va_list args)
STATIC void
S_call_body(pTHX_ OP *myop, int is_eval)
{
+ dTHR;
+
if (PL_op == myop) {
if (is_eval)
- PL_op = Perl_pp_entereval(aTHX); /* this doesn't do a POPMARK */
+ PL_op = Perl_pp_entereval(aTHX);
else
- PL_op = Perl_pp_entersub(aTHX); /* this does */
+ PL_op = Perl_pp_entersub(aTHX);
}
if (PL_op)
CALLRUNOPS(aTHX);
@@ -1940,6 +1878,7 @@ Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
dSP;
SV* sv = newSVpv(p, 0);
+ PUSHMARK(SP);
eval_sv(sv, G_SCALAR);
SvREFCNT_dec(sv);
@@ -2000,7 +1939,7 @@ S_usage(pTHX_ char *name) /* XXX move this out into a module ? */
"-0[octal] specify record separator (\\0, if no argument)",
"-a autosplit mode with -n or -p (splits $_ into @F)",
"-C enable native wide character system interfaces",
-"-c check syntax only (runs BEGIN and CHECK blocks)",
+"-c check syntax only (runs BEGIN and END blocks)",
"-d[:debugger] run program under debugger",
"-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
"-e 'command' one line of program (several -e's allowed, omit programfile)",
@@ -2028,11 +1967,9 @@ NULL
};
char **p = usage_msg;
- PerlIO_printf(PerlIO_stdout(),
- "\nUsage: %s [switches] [--] [programfile] [arguments]",
- name);
+ printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
while (*p)
- PerlIO_printf(PerlIO_stdout(), "\n %s", *p++);
+ printf("\n %s", *p++);
}
/* This routine handles any switches that can be given during run */
@@ -2040,13 +1977,13 @@ NULL
char *
Perl_moreswitches(pTHX_ char *s)
{
- STRLEN numlen;
+ I32 numlen;
U32 rschar;
switch (*s) {
case '0':
{
- numlen = 0; /* disallow underscores */
+ dTHR;
rschar = (U32)scan_oct(s, 4, &numlen);
SvREFCNT_dec(PL_nrs);
if (rschar & ~((U8)~0))
@@ -2079,25 +2016,9 @@ Perl_moreswitches(pTHX_ char *s)
case 'd':
forbid_setid("-d");
s++;
- /* The following permits -d:Mod to accepts arguments following an =
- in the fashion that -MSome::Mod does. */
- if (*s == ':' || *s == '=') {
- char *start;
- SV *sv;
- sv = newSVpv("use Devel::", 0);
- start = ++s;
- /* We now allow -d:Module=Foo,Bar */
- while(isALNUM(*s) || *s==':') ++s;
- if (*s != '=')
- sv_catpv(sv, start);
- else {
- sv_catpvn(sv, start, s-start);
- sv_catpv(sv, " split(/,/,q{");
- sv_catpv(sv, ++s);
- sv_catpv(sv, "})");
- }
+ if (*s == ':' || *s == '=') {
+ my_setenv("PERL5DB", Perl_form(aTHX_ "use Devel::%s;", ++s));
s += strlen(s);
- my_setenv("PERL5DB", SvPV(sv, PL_na));
}
if (!PL_perldb) {
PL_perldb = PERLDB_ALL;
@@ -2109,7 +2030,7 @@ Perl_moreswitches(pTHX_ char *s)
#ifdef DEBUGGING
forbid_setid("-D");
if (isALPHA(s[1])) {
- static char debopts[] = "psltocPmfrxuLHXDST";
+ static char debopts[] = "psltocPmfrxuLHXDS";
char *d;
for (s++; *s && (d = strchr(debopts,*s)); s++)
@@ -2121,6 +2042,7 @@ Perl_moreswitches(pTHX_ char *s)
}
PL_debug |= 0x80000000;
#else
+ dTHR;
if (ckWARN_d(WARN_DEBUGGING))
Perl_warner(aTHX_ WARN_DEBUGGING,
"Recompile perl with -DDEBUGGING to use -D switch\n");
@@ -2177,11 +2099,11 @@ Perl_moreswitches(pTHX_ char *s)
if (isDIGIT(*s)) {
PL_ors = savepv("\n");
PL_orslen = 1;
- numlen = 0; /* disallow underscores */
*PL_ors = (char)scan_oct(s, 3 + (*s == '0'), &numlen);
s += numlen;
}
else {
+ dTHR;
if (RsPARA(PL_nrs)) {
PL_ors = "\n\n";
PL_orslen = 2;
@@ -2214,9 +2136,6 @@ Perl_moreswitches(pTHX_ char *s)
sv_catpv( sv, " ()");
}
} else {
- if (s == start)
- Perl_croak(aTHX_ "Module name required with -%c option",
- s[-1]);
sv_catpvn(sv, start, s-start);
sv_catpv(sv, " split(/,/,q{");
sv_catpv(sv, ++s);
@@ -2249,9 +2168,6 @@ Perl_moreswitches(pTHX_ char *s)
s++;
return s;
case 'u':
-#ifdef MACOS_TRADITIONAL
- Perl_croak(aTHX_ "Believe me, you don't want to use \"-u\" on a Macintosh");
-#endif
PL_do_undump = TRUE;
s++;
return s;
@@ -2260,81 +2176,59 @@ Perl_moreswitches(pTHX_ char *s)
s++;
return s;
case 'v':
- PerlIO_printf(PerlIO_stdout(),
- Perl_form(aTHX_ "\nThis is perl, v%"VDf" built for %s",
- PL_patchlevel, ARCHNAME));
+ printf(Perl_form(aTHX_ "\nThis is perl, v%vd built for %s",
+ PL_patchlevel, ARCHNAME));
#if defined(LOCAL_PATCH_COUNT)
if (LOCAL_PATCH_COUNT > 0)
- PerlIO_printf(PerlIO_stdout(),
- "\n(with %d registered patch%s, "
- "see perl -V for more detail)",
- (int)LOCAL_PATCH_COUNT,
- (LOCAL_PATCH_COUNT!=1) ? "es" : "");
+ printf("\n(with %d registered patch%s, see perl -V for more detail)",
+ (int)LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
#endif
- PerlIO_printf(PerlIO_stdout(),
- "\n\nCopyright 1987-2001, Larry Wall\n");
-#ifdef MACOS_TRADITIONAL
- PerlIO_printf(PerlIO_stdout(),
- "\nMac OS port Copyright (c) 1991-2001, Matthias Neeracher\n");
-#endif
+ printf("\n\nCopyright 1987-2000, Larry Wall\n");
#ifdef MSDOS
- PerlIO_printf(PerlIO_stdout(),
- "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
+ printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
#endif
#ifdef DJGPP
- PerlIO_printf(PerlIO_stdout(),
- "djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n"
- "djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
+ printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
+ printf("djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
#endif
#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");
+ printf("\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");
#endif
#ifdef atarist
- PerlIO_printf(PerlIO_stdout(),
- "atariST series port, ++jrb bammi@cadence.com\n");
+ printf("atariST series port, ++jrb bammi@cadence.com\n");
#endif
#ifdef __BEOS__
- PerlIO_printf(PerlIO_stdout(),
- "BeOS port Copyright Tom Spindler, 1997-1999\n");
+ printf("BeOS port Copyright Tom Spindler, 1997-1999\n");
#endif
#ifdef MPE
- PerlIO_printf(PerlIO_stdout(),
- "MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-1999\n");
+ printf("MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-1999\n");
#endif
#ifdef OEMVS
- PerlIO_printf(PerlIO_stdout(),
- "MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
+ printf("MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
#endif
#ifdef __VOS__
- PerlIO_printf(PerlIO_stdout(),
- "Stratus VOS port by Paul_Green@stratus.com, 1997-1999\n");
+ printf("Stratus VOS port by Paul_Green@stratus.com, 1997-1999\n");
#endif
#ifdef __OPEN_VM
- PerlIO_printf(PerlIO_stdout(),
- "VM/ESA port by Neale Ferguson, 1998-1999\n");
+ printf("VM/ESA port by Neale Ferguson, 1998-1999\n");
#endif
#ifdef POSIX_BC
- PerlIO_printf(PerlIO_stdout(),
- "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
+ printf("BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
#endif
#ifdef __MINT__
- PerlIO_printf(PerlIO_stdout(),
- "MiNT port by Guido Flohr, 1997-1999\n");
+ printf("MiNT port by Guido Flohr, 1997-1999\n");
#endif
#ifdef EPOC
- PerlIO_printf(PerlIO_stdout(),
- "EPOC port by Olaf Flebbe, 1999-2000\n");
+ printf("EPOC port by Olaf Flebbe, 1999-2000\n");
#endif
#ifdef BINARY_BUILD_NOTICE
BINARY_BUILD_NOTICE;
#endif
- PerlIO_printf(PerlIO_stdout(),
- "\n\
+ printf("\n\
Perl may be copied only under the terms of either the Artistic License or the\n\
-GNU General Public License, which may be found in the Perl 5 source kit.\n\n\
+GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n\
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");
@@ -2496,6 +2390,7 @@ S_init_interp(pTHX)
STATIC void
S_init_main_stash(pTHX)
{
+ dTHR;
GV *gv;
/* Note that strtab is a rather special HV. Assumptions are made
@@ -2531,7 +2426,6 @@ S_init_main_stash(pTHX)
CopSTASH_set(&PL_compiling, PL_defstash);
PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
- PL_nullstash = GvHV(gv_fetchpv("<none>::", GV_ADDMULTI, SVt_PVHV));
/* We must init $/ before switches are processed. */
sv_setpvn(get_sv("/", TRUE), "\n", 1);
}
@@ -2539,6 +2433,8 @@ S_init_main_stash(pTHX)
STATIC void
S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
{
+ dTHR;
+
*fdscript = -1;
if (PL_e_script) {
@@ -2561,11 +2457,6 @@ 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
CopFILE_set(PL_curcop, PL_origfilename);
if (strEQ(PL_origfilename,"-"))
scriptname = "";
@@ -2588,7 +2479,7 @@ S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
sv_catpvn(sv, "-I", 2);
sv_catpv(sv,PRIVLIB_EXP);
-#if defined(MSDOS) || defined(WIN32)
+#ifdef MSDOS
Perl_sv_setpvf(aTHX_ cmd, "\
sed %s -e \"/^[^#]/b\" \
-e \"/^#[ ]*include[ ]/b\" \
@@ -2687,7 +2578,7 @@ sed %s -e \"/^[^#]/b\" \
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");
+ Perl_croak(aTHX_ "Can't do setuid; ensure that the setuid bit is set on suidperl\n");
}
#endif
#endif
@@ -2718,85 +2609,72 @@ S_fd_on_nosuid_fs(pTHX_ int fd)
* an irrelevant filesystem while trying to reach the right one.
*/
-#undef FD_ON_NOSUID_CHECK_OKAY /* found the syscalls to do the check? */
-
-# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
- defined(HAS_FSTATVFS)
-# define FD_ON_NOSUID_CHECK_OKAY
+# ifdef HAS_FSTATVFS
struct statvfs stfs;
-
check_okay = fstatvfs(fd, &stfs) == 0;
on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID);
-# endif /* fstatvfs */
-
-# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
- defined(PERL_MOUNT_NOSUID) && \
- defined(HAS_FSTATFS) && \
- defined(HAS_STRUCT_STATFS) && \
- defined(HAS_STRUCT_STATFS_F_FLAGS)
-# define FD_ON_NOSUID_CHECK_OKAY
+# else
+# ifdef PERL_MOUNT_NOSUID
+# if defined(HAS_FSTATFS) && \
+ defined(HAS_STRUCT_STATFS) && \
+ defined(HAS_STRUCT_STATFS_F_FLAGS)
struct statfs stfs;
-
check_okay = fstatfs(fd, &stfs) == 0;
on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
-# endif /* fstatfs */
-
-# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
- defined(PERL_MOUNT_NOSUID) && \
- defined(HAS_FSTAT) && \
- defined(HAS_USTAT) && \
- defined(HAS_GETMNT) && \
- defined(HAS_STRUCT_FS_DATA) && \
- defined(NOSTAT_ONE)
-# define FD_ON_NOSUID_CHECK_OKAY
+# else
+# if defined(HAS_FSTAT) && \
+ defined(HAS_USTAT) && \
+ defined(HAS_GETMNT) && \
+ defined(HAS_STRUCT_FS_DATA) && \
+ defined(NOSTAT_ONE)
struct stat fdst;
-
if (fstat(fd, &fdst) == 0) {
- struct ustat us;
- if (ustat(fdst.st_dev, &us) == 0) {
- struct fs_data fsd;
- /* NOSTAT_ONE here because we're not examining fields which
- * vary between that case and STAT_ONE. */
+ struct ustat us;
+ if (ustat(fdst.st_dev, &us) == 0) {
+ struct fs_data fsd;
+ /* NOSTAT_ONE here because we're not examining fields which
+ * vary between that case and STAT_ONE. */
if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) {
- size_t cmplen = sizeof(us.f_fname);
- if (sizeof(fsd.fd_req.path) < cmplen)
- cmplen = sizeof(fsd.fd_req.path);
- if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
- fdst.st_dev == fsd.fd_req.dev) {
- check_okay = 1;
- on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
- }
- }
- }
- }
- }
-# endif /* fstat+ustat+getmnt */
-
-# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
- defined(HAS_GETMNTENT) && \
- defined(HAS_HASMNTOPT) && \
- defined(MNTOPT_NOSUID)
-# define FD_ON_NOSUID_CHECK_OKAY
- FILE *mtab = fopen("/etc/mtab", "r");
- struct mntent *entry;
- struct stat stb, fsb;
+ size_t cmplen = sizeof(us.f_fname);
+ if (sizeof(fsd.fd_req.path) < cmplen)
+ cmplen = sizeof(fsd.fd_req.path);
+ if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
+ fdst.st_dev == fsd.fd_req.dev) {
+ check_okay = 1;
+ on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
+ }
+ }
+ }
+ }
+ }
+# endif /* fstat+ustat+getmnt */
+# endif /* fstatfs */
+# else
+# if defined(HAS_GETMNTENT) && \
+ defined(HAS_HASMNTOPT) && \
+ defined(MNTOPT_NOSUID)
+ FILE *mtab = fopen("/etc/mtab", "r");
+ struct mntent *entry;
+ struct stat stb, fsb;
if (mtab && (fstat(fd, &stb) == 0)) {
- while (entry = getmntent(mtab)) {
- if (stat(entry->mnt_dir, &fsb) == 0
- && fsb.st_dev == stb.st_dev)
- {
- /* found the filesystem */
- check_okay = 1;
- if (hasmntopt(entry, MNTOPT_NOSUID))
- on_nosuid = 1;
- break;
- } /* A single fs may well fail its stat(). */
- }
+ while (entry = getmntent(mtab)) {
+ if (stat(entry->mnt_dir, &fsb) == 0
+ && fsb.st_dev == stb.st_dev)
+ {
+ /* found the filesystem */
+ check_okay = 1;
+ if (hasmntopt(entry, MNTOPT_NOSUID))
+ on_nosuid = 1;
+ break;
+ } /* A single fs may well fail its stat(). */
+ }
}
if (mtab)
- fclose(mtab);
-# endif /* getmntent+hasmntopt */
+ fclose(mtab);
+# endif /* getmntent+hasmntopt */
+# endif /* PERL_MOUNT_NOSUID: fstatfs or fstat+ustat+statfs */
+# endif /* statvfs */
if (!check_okay)
Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid", PL_origfilename);
@@ -2832,6 +2710,7 @@ S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
*/
#ifdef DOSUID
+ dTHR;
char *s, *s2;
if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
@@ -2941,7 +2820,7 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
(int)PERL_REVISION, (int)PERL_VERSION,
(int)PERL_SUBVERSION), PL_origargv);
#endif
- Perl_croak(aTHX_ "Can't do setuid\n");
+ Perl_croak(aTHX_ "Can't do setuid; ensure that the setuid bit is set on suidperl\n");
}
if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
@@ -3024,11 +2903,12 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
PerlProc_execv(Perl_form(aTHX_ "%s/perl"PERL_FS_VER_FMT, BIN_EXP,
(int)PERL_REVISION, (int)PERL_VERSION,
(int)PERL_SUBVERSION), PL_origargv);/* try again */
- Perl_croak(aTHX_ "Can't do setuid\n");
+ Perl_croak(aTHX_ "Can't do setuid; ensure that the setuid bit is set on suidperl\n");
#endif /* IAMSUID */
#else /* !DOSUID */
if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
#ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
+ dTHR;
PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */
if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
||
@@ -3051,29 +2931,9 @@ S_find_beginning(pTHX)
/* skip forward in input to the real script? */
forbid_setid("-x");
-#ifdef MACOS_TRADITIONAL
- /* Since the Mac OS does not honor #! arguments for us, we do it ourselves */
- while (PL_doextract || gMacPerl_AlwaysExtract) {
- 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
while (PL_doextract) {
if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
Perl_croak(aTHX_ "No Perl script found in input\n");
-#endif
if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */
PL_doextract = FALSE;
@@ -3118,6 +2978,7 @@ S_forbid_setid(pTHX_ char *s)
void
Perl_init_debugger(pTHX)
{
+ dTHR;
HV *ostash = PL_curstash;
PL_curstash = PL_debstash;
@@ -3185,6 +3046,7 @@ Perl_init_stacks(pTHX)
STATIC void
S_nuke_stacks(pTHX)
{
+ dTHR;
while (PL_curstackinfo->si_next)
PL_curstackinfo = PL_curstackinfo->si_next;
while (PL_curstackinfo) {
@@ -3221,6 +3083,7 @@ S_init_lexer(pTHX)
STATIC void
S_init_predump_symbols(pTHX)
{
+ dTHR;
GV *tmpgv;
IO *io;
@@ -3252,19 +3115,17 @@ S_init_predump_symbols(pTHX)
PL_statname = NEWSV(66,0); /* last filename we did stat on */
- if (PL_osname)
- Safefree(PL_osname);
- PL_osname = savepv(OSNAME);
+ if (!PL_osname)
+ PL_osname = savepv(OSNAME);
}
STATIC void
S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
{
+ dTHR;
char *s;
SV *sv;
GV* tmpgv;
- char **dup_env_base = 0;
- int dup_env_count = 0;
argc--,argv++; /* skip name of script */
if (PL_doswitches) {
@@ -3293,17 +3154,12 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register
TAINT;
if ((tmpgv = gv_fetchpv("0",TRUE, SVt_PV))) {
-#ifdef MACOS_TRADITIONAL
- /* $0 is not majick on a Mac */
- sv_setpv(GvSV(tmpgv),MacPerl_MPWFileName(PL_origfilename));
-#else
sv_setpv(GvSV(tmpgv),PL_origfilename);
magicname("0", "0", 1);
-#endif
}
if ((tmpgv = gv_fetchpv("\030",TRUE, SVt_PV)))
#ifdef OS2
- sv_setpv(GvSV(tmpgv), os2_execname(aTHX));
+ sv_setpv(GvSV(tmpgv), os2_execname());
#else
sv_setpv(GvSV(tmpgv),PL_origargv[0]);
#endif
@@ -3315,15 +3171,15 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register
SV *sv = newSVpv(argv[0],0);
av_push(GvAVn(PL_argvgv),sv);
if (PL_widesyscalls)
- (void)sv_utf8_decode(sv);
+ sv_utf8_upgrade(sv);
}
}
if ((PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV))) {
HV *hv;
GvMULTI_on(PL_envgv);
hv = GvHVn(PL_envgv);
- hv_magic(hv, Nullgv, 'E');
-#ifdef USE_ENVIRON_ARRAY
+ hv_magic(hv, PL_envgv, 'E');
+#if !defined( VMS) && !defined(EPOC) /* VMS doesn't have environ array */
/* Note that if the supplied env parameter is actually a copy
of the global environ then it may now point to free'd memory
if the environment has been modified since. To avoid this
@@ -3333,26 +3189,6 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register
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 */
for (; *env; env++) {
if (!(s = strchr(*env,'=')))
continue;
@@ -3363,16 +3199,12 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register
sv = newSVpv(s--,0);
(void)hv_store(hv, *env, s - *env, sv, 0);
*s = '=';
+#if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
+ /* Sins of the RTL. See note in my_setenv(). */
+ (void)PerlEnv_putenv(savepv(*env));
+#endif
}
-#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 */
+#endif
#ifdef DYNAMIC_ENV_FETCH
HvNAME(hv) = savepv(ENV_HV_NAME);
#endif
@@ -3417,27 +3249,6 @@ S_init_perllib(pTHX)
#ifdef ARCHLIB_EXP
incpush(ARCHLIB_EXP, FALSE, FALSE);
#endif
-#ifdef MACOS_TRADITIONAL
- {
- struct stat tmpstatbuf;
- SV * privdir = NEWSV(55, 0);
- char * macperl = PerlEnv_getenv("MACPERL");
-
- if (!macperl)
- macperl = "";
-
- Perl_sv_setpvf(aTHX_ privdir, "%slib:", macperl);
- if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
- incpush(SvPVX(privdir), TRUE, FALSE);
- Perl_sv_setpvf(aTHX_ privdir, "%ssite_perl:", macperl);
- if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
- incpush(SvPVX(privdir), TRUE, FALSE);
-
- SvREFCNT_dec(privdir);
- }
- if (!PL_tainting)
- incpush(":", FALSE, FALSE);
-#else
#ifndef PRIVLIB_EXP
# define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
#endif
@@ -3487,26 +3298,17 @@ S_init_perllib(pTHX)
incpush(PERL_VENDORLIB_STEM, FALSE, TRUE);
#endif
-#ifdef PERL_OTHERLIBDIRS
- incpush(PERL_OTHERLIBDIRS, TRUE, TRUE);
-#endif
-
if (!PL_tainting)
incpush(".", FALSE, FALSE);
-#endif /* MACOS_TRADITIONAL */
}
-#if defined(DOSISH) || defined(EPOC)
+#if defined(DOSISH)
# define PERLLIB_SEP ';'
#else
# if defined(VMS)
# define PERLLIB_SEP '|'
# else
-# if defined(MACOS_TRADITIONAL)
-# define PERLLIB_SEP ','
-# else
-# define PERLLIB_SEP ':'
-# endif
+# define PERLLIB_SEP ':'
# endif
#endif
#ifndef PERLLIB_MANGLE
@@ -3546,12 +3348,6 @@ S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers)
sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
p = Nullch; /* break out */
}
-#ifdef MACOS_TRADITIONAL
- if (!strchr(SvPVX(libdir), ':'))
- sv_insert(libdir, 0, 0, ":", 1);
- if (SvPVX(libdir)[SvCUR(libdir)-1] != ':')
- sv_catpv(libdir, ":");
-#endif
/*
* BEFORE pushing libdir onto @INC we may first push version- and
@@ -3579,17 +3375,8 @@ S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers)
SvPV(libdir,len));
#endif
if (addsubdirs) {
-#ifdef MACOS_TRADITIONAL
-#define PERL_AV_SUFFIX_FMT ""
-#define PERL_ARCH_FMT "%s:"
-#define PERL_ARCH_FMT_PATH PERL_FS_VER_FMT PERL_AV_SUFFIX_FMT
-#else
-#define PERL_AV_SUFFIX_FMT "/"
-#define PERL_ARCH_FMT "/%s"
-#define PERL_ARCH_FMT_PATH PERL_AV_SUFFIX_FMT PERL_FS_VER_FMT
-#endif
/* .../version/archname if -d .../version/archname */
- Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH PERL_ARCH_FMT,
+ Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/"PERL_FS_VER_FMT"/%s",
libdir,
(int)PERL_REVISION, (int)PERL_VERSION,
(int)PERL_SUBVERSION, ARCHNAME);
@@ -3598,7 +3385,7 @@ S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers)
av_push(GvAVn(PL_incgv), newSVsv(subdir));
/* .../version if -d .../version */
- Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH, libdir,
+ Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/"PERL_FS_VER_FMT, libdir,
(int)PERL_REVISION, (int)PERL_VERSION,
(int)PERL_SUBVERSION);
if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
@@ -3606,7 +3393,7 @@ S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers)
av_push(GvAVn(PL_incgv), newSVsv(subdir));
/* .../archname if -d .../archname */
- Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, ARCHNAME);
+ Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/%s", libdir, ARCHNAME);
if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
S_ISDIR(tmpstatbuf.st_mode))
av_push(GvAVn(PL_incgv), newSVsv(subdir));
@@ -3616,7 +3403,7 @@ S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers)
if (addoldvers) {
for (incver = incverlist; *incver; incver++) {
/* .../xxx if -d .../xxx */
- Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, *incver);
+ Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/%s", libdir, *incver);
if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
S_ISDIR(tmpstatbuf.st_mode))
av_push(GvAVn(PL_incgv), newSVsv(subdir));
@@ -3681,9 +3468,8 @@ S_init_main_thread(pTHX)
PERL_SET_THX(thr);
/*
- * These must come after the thread self setting
- * because sv_setpvn does SvTAINT and the taint
- * fields thread selfness being set.
+ * These must come after the SET_THR because sv_setpvn does
+ * SvTAINT and the taint fields require dTHR.
*/
PL_toptarget = NEWSV(0,0);
sv_upgrade(PL_toptarget, SVt_PVFM);
@@ -3711,6 +3497,7 @@ S_init_main_thread(pTHX)
void
Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
{
+ dTHR;
SV *atsv;
line_t oldline = CopLINE(PL_curcop);
CV *cv;
@@ -3720,14 +3507,7 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
while (AvFILL(paramList) >= 0) {
cv = (CV*)av_shift(paramList);
- if ((PL_minus_c & 0x10) && (paramList == PL_beginav)) {
- /* save PL_beginav for compiler */
- if (! PL_beginav_save)
- PL_beginav_save = newAV();
- av_push(PL_beginav_save, (SV*)cv);
- } else {
- SAVEFREESV(cv);
- }
+ SAVEFREESV(cv);
#ifdef PERL_FLEXIBLE_EXCEPTIONS
CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_list_body), cv);
#else
@@ -3815,6 +3595,8 @@ S_call_list_body(pTHX_ CV *cv)
void
Perl_my_exit(pTHX_ U32 status)
{
+ dTHR;
+
DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
thr, (unsigned long) status));
switch (status) {
@@ -3863,6 +3645,7 @@ Perl_my_failure_exit(pTHX)
STATIC void
S_my_exit_jump(pTHX)
{
+ dTHR;
register PERL_CONTEXT *cx;
I32 gimme;
SV **newsp;
OpenPOWER on IntegriCloud