#ifdef MULTIPLICITY
init_interp();
- PL_perl_destruct_level = 1;
+ PL_perl_destruct_level = 1;
#else
if (PL_perl_destruct_level > 0)
init_interp();
# 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 */
void
perl_destruct(pTHXx)
{
- dTHR;
int destruct_level; /* 0=none, 1=full, 2=full with checks */
I32 last_sv_count;
HV *hv;
DEBUG_S(PerlIO_printf(Perl_debug_log,
"perl_destruct: detaching thread %p\n", t));
ThrSETSTATE(t, THRf_R_DETACHED);
- /*
+ /*
* We unlock threads_mutex and t->mutex in the opposite order
* from which we locked them just so that DETACH won't
* deadlock if it panics. It's only a breach of good style
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 */
if (destruct_level == 0){
DEBUG_P(debprofdump());
-
+
/* The exit() function will do everything that needs doing. */
return;
}
/* magical thingies */
- Safefree(PL_ofs); /* $, */
- PL_ofs = Nullch;
+ SvREFCNT_dec(PL_ofs_sv); /* $, */
+ PL_ofs_sv = Nullsv;
- Safefree(PL_ors); /* $\ */
- PL_ors = Nullch;
+ SvREFCNT_dec(PL_ors_sv); /* $\ */
+ PL_ors_sv = Nullsv;
SvREFCNT_dec(PL_rs); /* $/ */
PL_rs = Nullsv;
if (!specialWARN(PL_compiling.cop_warnings))
SvREFCNT_dec(PL_compiling.cop_warnings);
PL_compiling.cop_warnings = Nullsv;
+ 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;
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,
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)
Safefree(PL_psig_name);
nuke_stacks();
PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */
-
+
DEBUG_P(debprofdump());
#ifdef USE_THREADS
MUTEX_DESTROY(&PL_strtab_mutex);
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);
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) {
#if defined(PERL_OBJECT)
PerlMem_free(this);
#else
-# if defined(PERL_IMPLICIT_SYS) && defined(WIN32)
+# if defined(WIN32)
+# if defined(PERL_IMPLICIT_SYS)
void *host = w32_internal_host;
+ if (PerlProc_lasthost())
+ PerlIO_cleanup();
PerlMem_free(aTHXx);
win32_delete_internal_host(host);
+#else
+ PerlIO_cleanup();
+ PerlMem_free(aTHXx);
+#endif
# else
PerlMem_free(aTHXx);
# endif
int
perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
{
- dTHR;
I32 oldscope;
int ret;
dJMPENV;
PL_origargv = argv;
PL_origargc = argc;
-#ifndef VMS /* VMS doesn't have environ array */
+#ifdef USE_ENVIRON_ARRAY
PL_origenviron = environ;
#endif
STATIC void *
S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
{
- dTHR;
int argc = PL_origargc;
char **argv = PL_origargv;
char *scriptname = NULL;
#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");
validate_suid(validarg, scriptname,fdscript);
+#ifndef PERL_MICRO
#if defined(SIGCHLD) || defined(SIGCLD)
{
#ifndef SIGCHLD
}
}
#endif
+#endif
#ifdef MACOS_TRADITIONAL
if (PL_doextract || gMacPerl_AlwaysExtract) {
if (xsinit)
(*xsinit)(aTHXo); /* in case linked C routines want magical variables */
-#if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__)
+#ifndef PERL_MICRO
+#if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) || defined(EPOC)
init_os_extras();
#endif
+#endif
#ifdef USE_SOCKS
+# ifdef HAS_SOCKS5_INIT
+ socks5_init(argv[0]);
+# else
SOCKSinit(argv[0]);
-#endif
+# endif
+#endif
init_predump_symbols();
/* init_postdump_symbols not currently designed to be called */
int
perl_run(pTHXx)
{
- dTHR;
I32 oldscope;
int ret = 0;
dJMPENV;
STATIC void *
S_run_body(pTHX_ I32 oldscope)
{
- dTHR;
-
DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
PL_sawampersand ? "Enabling" : "Omitting"));
my_exit(0);
}
if (PERLDB_SINGLE && PL_DBsingle)
- sv_setiv(PL_DBsingle, 1);
+ sv_setiv(PL_DBsingle, 1);
if (PL_initav)
call_list(oldscope, PL_initav);
}
#ifdef USE_THREADS
if (name[1] == '\0' && !isALPHA(name[0])) {
PADOFFSET tmp = find_threadsv(name);
- if (tmp != NOT_IN_PAD) {
- dTHR;
+ if (tmp != NOT_IN_PAD)
return THREADSV(tmp);
- }
}
#endif /* USE_THREADS */
gv = gv_fetchpv(name, create, SVt_PV);
I32
Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
-
+
/* See G_* flags in cop.h */
/* null terminated arg list */
{
{
register PERL_CONTEXT *cx;
I32 gimme = GIMME_V;
-
+
ENTER;
SAVETMPS;
-
+
push_return(Nullop);
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. */
-
+
PL_in_eval = EVAL_INEVAL;
if (flags & G_KEEPERR)
PL_in_eval |= EVAL_KEEPERR;
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 */
I32
Perl_eval_sv(pTHX_ SV *sv, I32 flags)
-
+
/* See G_* flags in cop.h */
{
dSP;
char *
Perl_moreswitches(pTHX_ char *s)
{
- I32 numlen;
+ STRLEN numlen;
U32 rschar;
switch (*s) {
case '0':
{
- dTHR;
numlen = 0; /* disallow underscores */
rschar = (U32)scan_oct(s, 4, &numlen);
SvREFCNT_dec(PL_nrs);
case 'd':
forbid_setid("-d");
s++;
- if (*s == ':' || *s == '=') {
- my_setenv("PERL5DB", Perl_form(aTHX_ "use Devel::%s;", ++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, "})");
+ }
s += strlen(s);
+ my_setenv("PERL5DB", SvPV(sv, PL_na));
}
if (!PL_perldb) {
PL_perldb = PERLDB_ALL;
#ifdef DEBUGGING
forbid_setid("-D");
if (isALPHA(s[1])) {
- static char debopts[] = "psltocPmfrxuLHXDS";
+ static char debopts[] = "psltocPmfrxuLHXDST";
char *d;
for (s++; *s && (d = strchr(debopts,*s)); 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");
return s;
}
case 'h':
- usage(PL_origargv[0]);
+ usage(PL_origargv[0]);
PerlProc_exit(0);
case 'i':
if (PL_inplace)
case 'l':
PL_minus_l = TRUE;
s++;
- if (PL_ors)
- Safefree(PL_ors);
+ if (PL_ors_sv) {
+ SvREFCNT_dec(PL_ors_sv);
+ PL_ors_sv = Nullsv;
+ }
if (isDIGIT(*s)) {
- PL_ors = savepv("\n");
- PL_orslen = 1;
+ PL_ors_sv = newSVpvn("\n",1);
numlen = 0; /* disallow underscores */
- *PL_ors = (char)scan_oct(s, 3 + (*s == '0'), &numlen);
+ *SvPVX(PL_ors_sv) = (char)scan_oct(s, 3 + (*s == '0'), &numlen);
s += numlen;
}
else {
- dTHR;
if (RsPARA(PL_nrs)) {
- PL_ors = "\n\n";
- PL_orslen = 2;
+ PL_ors_sv = newSVpvn("\n\n",2);
+ }
+ else {
+ PL_ors_sv = newSVsv(PL_nrs);
}
- else
- PL_ors = SvPV(PL_nrs, PL_orslen);
- PL_ors = savepvn(PL_ors, PL_orslen);
}
return s;
case 'M':
return s;
case 'v':
PerlIO_printf(PerlIO_stdout(),
- Perl_form(aTHX_ "\nThis is perl, v%vd built for %s",
+ Perl_form(aTHX_ "\nThis is perl, v%"VDf" built for %s",
PL_patchlevel, ARCHNAME));
#if defined(LOCAL_PATCH_COUNT)
if (LOCAL_PATCH_COUNT > 0)
PerlIO_printf(PerlIO_stdout(),
"\n\nCopyright 1987-2000, Larry Wall\n");
+#ifdef MACOS_TRADITIONAL
+ PerlIO_printf(PerlIO_stdout(),
+ "\nMacOS port Copyright (c) 1991-2000, Matthias Neeracher\n");
+#endif
#ifdef MSDOS
PerlIO_printf(PerlIO_stdout(),
"\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
PerlIO_printf(PerlIO_stdout(),
"\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.0 source kit.\n\n\
+GNU General Public License, which may be found in the Perl 5 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");
PerlProc_exit(0);
case 'w':
if (! (PL_dowarn & G_WARN_ALL_MASK))
- PL_dowarn |= G_WARN_ON;
+ PL_dowarn |= G_WARN_ON;
s++;
return s;
case 'W':
- PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
+ PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
PL_compiling.cop_warnings = pWARN_ALL ;
s++;
return s;
case 'X':
- PL_dowarn = G_WARN_ALL_OFF;
+ PL_dowarn = G_WARN_ALL_OFF;
PL_compiling.cop_warnings = pWARN_NONE ;
s++;
return s;
STATIC void
S_init_main_stash(pTHX)
{
- dTHR;
GV *gv;
/* Note that strtab is a rather special HV. Assumptions are made
#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)
{
- dTHR;
-
*fdscript = -1;
if (PL_e_script) {
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) && \
fclose(mtab);
# endif /* getmntent+hasmntopt */
- if (!check_okay)
+ if (!check_okay)
Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid", PL_origfilename);
return on_nosuid;
}
*/
#ifdef DOSUID
- dTHR;
char *s, *s2;
if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
tmpstatbuf.st_ino != PL_statbuf.st_ino) {
(void)PerlIO_close(PL_rsfp);
- if (PL_rsfp = PerlProc_popen("/bin/mail root","w")) { /* heh, heh */
- PerlIO_printf(PL_rsfp,
-"User %"Uid_t_f" tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
-(Filename of set-id script was %s, uid %"Uid_t_f" gid %"Gid_t_f".)\n\nSincerely,\nperl\n",
- PL_uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
- (long)PL_statbuf.st_dev, (long)PL_statbuf.st_ino,
- CopFILE(PL_curcop),
- PL_statbuf.st_uid, PL_statbuf.st_gid);
- (void)PerlProc_pclose(PL_rsfp);
- }
Perl_croak(aTHX_ "Permission denied\n");
}
if (
#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)
||
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)
/* Pater peccavi, file does not have #! */
PerlIO_rewind(PL_rsfp);
-
+
break;
}
#else
void
Perl_init_debugger(pTHX)
{
- dTHR;
HV *ostash = PL_curstash;
PL_curstash = PL_debstash;
PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
sv_upgrade(GvSV(PL_DBsub), SVt_IV); /* IVX accessed if PERLDB_SUB_NN */
PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
- sv_setiv(PL_DBsingle, 0);
+ sv_setiv(PL_DBsingle, 0);
PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
- sv_setiv(PL_DBtrace, 0);
+ sv_setiv(PL_DBtrace, 0);
PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
- sv_setiv(PL_DBsignal, 0);
+ sv_setiv(PL_DBsignal, 0);
PL_curstash = ostash;
}
STATIC void
S_nuke_stacks(pTHX)
{
- dTHR;
while (PL_curstackinfo->si_next)
PL_curstackinfo = PL_curstackinfo->si_next;
while (PL_curstackinfo) {
STATIC void
S_init_predump_symbols(pTHX)
{
- dTHR;
GV *tmpgv;
IO *io;
STATIC void
S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
{
- dTHR;
char *s;
SV *sv;
GV* tmpgv;
GvMULTI_on(PL_envgv);
hv = GvHVn(PL_envgv);
hv_magic(hv, PL_envgv, 'E');
-#if !defined( VMS) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) /* VMS doesn't have environ array */
+#ifdef USE_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
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)
#ifndef PRIVLIB_EXP
# define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
#endif
-#if defined(WIN32)
+#if defined(WIN32)
incpush(PRIVLIB_EXP, TRUE, FALSE);
#else
incpush(PRIVLIB_EXP, FALSE, FALSE);
#endif /* MACOS_TRADITIONAL */
}
-#if defined(DOSISH)
+#if defined(DOSISH) || defined(EPOC)
# define PERLLIB_SEP ';'
#else
# if defined(VMS)
#endif
#ifndef PERLLIB_MANGLE
# define PERLLIB_MANGLE(s,n) (s)
-#endif
+#endif
STATIC void
S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers)
#define PERL_ARCH_FMT "/%s"
#endif
/* .../version/archname if -d .../version/archname */
- Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_AV_SUFFIX_FMT PERL_FS_VER_FMT PERL_ARCH_FMT,
+ Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_AV_SUFFIX_FMT PERL_FS_VER_FMT PERL_ARCH_FMT,
libdir,
(int)PERL_REVISION, (int)PERL_VERSION,
(int)PERL_SUBVERSION, ARCHNAME);
thr->tid = 0;
thr->next = thr;
thr->prev = thr;
+ thr->thr_done = 0;
MUTEX_UNLOCK(&PL_threads_mutex);
#ifdef HAVE_THREAD_INTERN
PERL_SET_THX(thr);
/*
- * These must come after the SET_THR because sv_setpvn does
- * SvTAINT and the taint fields require dTHR.
+ * These must come after the thread self setting
+ * because sv_setpvn does SvTAINT and the taint
+ * fields thread selfness being set.
*/
PL_toptarget = NEWSV(0,0);
sv_upgrade(PL_toptarget, SVt_PVFM);
void
Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
{
- dTHR;
SV *atsv;
line_t oldline = CopLINE(PL_curcop);
CV *cv;
while (AvFILL(paramList) >= 0) {
cv = (CV*)av_shift(paramList);
- SAVEFREESV(cv);
+ 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);
+ }
#ifdef PERL_FLEXIBLE_EXCEPTIONS
CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_list_body), cv);
#else
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) {
if (errno & 255)
STATUS_POSIX_SET(errno);
else {
- exitstatus = STATUS_POSIX >> 8;
+ exitstatus = STATUS_POSIX >> 8;
if (exitstatus & 255)
STATUS_POSIX_SET(exitstatus);
else
STATIC void
S_my_exit_jump(pTHX)
{
- dTHR;
register PERL_CONTEXT *cx;
I32 gimme;
SV **newsp;
projects / p5sagit/p5-mst-13.2.git / blobdiff