/* perl.c
*
- * Copyright (c) 1987-2000 Larry Wall
+ * Copyright (c) 1987-2001 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.
#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 */
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 */
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;
#ifdef USE_LOCALE_NUMERIC
Safefree(PL_numeric_name);
PL_numeric_name = Nullch;
+ SvREFCNT_dec(PL_numeric_radix);
#endif
/* clear utf8 character classes */
if (!specialWARN(PL_compiling.cop_warnings))
SvREFCNT_dec(PL_compiling.cop_warnings);
PL_compiling.cop_warnings = Nullsv;
-#ifndef USE_ITHREADS
+ 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_set(&PL_compiling, Nullgv);
+ CopFILEGV(&PL_compiling) = Nullgv;
+ /* cop_stash is not refcounted */
#endif
/* Prepare to destruct main symbol table. */
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,
}
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;
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_reg_poscache);
Safefree(HeKEY_hek(&PL_hv_fetch_ent_mh));
Safefree(PL_op_mask);
+ Safefree(PL_psig_ptr);
+ Safefree(PL_psig_name);
+ Safefree(PL_psig_pend);
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;
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) {
PL_tainting = TRUE;
else {
while (s && *s) {
+ char *d;
while (isSPACE(*s))
s++;
if (*s == '-') {
if (isSPACE(*s))
continue;
}
+ d = s;
if (!*s)
break;
if (!strchr("DIMUdmw", *s))
Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
- s = moreswitches(s);
+ while (++s && *s) {
+ if (isSPACE(*s)) {
+ *s++ = '\0';
+ break;
+ }
+ }
+ moreswitches(d);
}
}
}
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) {
+#else
if (PL_doextract) {
+#endif
find_beginning();
if (cddir && PerlDir_chdir(cddir) < 0)
Perl_croak(aTHX_ "Can't chdir to %s",cddir);
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 */
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);
PL_origfilename);
}
}
+#endif
CopLINE_set(PL_curcop, 0);
PL_curstash = PL_defstash;
PL_preprocess = FALSE;
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"));
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)
- 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 */
{
/* name of the subroutine */
/* See G_* flags in cop.h */
{
- 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);
+ return call_sv(sv_2mortal(newSVpv(methname,0)), flags | G_METHOD);
}
/* May be called with any of a CV, a GV, or an SV containing the name. */
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;
&& !(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);
CATCH_SET(oldcatch);
}
else {
- cLOGOP->op_other = PL_op;
+ myop.op_other = (OP*)&myop;
PL_markstack_ptr--;
/* we're trying to emulate pp_entertry() here */
{
register PERL_CONTEXT *cx;
I32 gimme = GIMME_V;
-
+
ENTER;
SAVETMPS;
-
- push_return(PL_op->op_next);
+
+ 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);
+ PL_op = Perl_pp_entereval(aTHX); /* this doesn't do a POPMARK */
else
- PL_op = Perl_pp_entersub(aTHX);
+ PL_op = Perl_pp_entersub(aTHX); /* this does */
}
if (PL_op)
CALLRUNOPS(aTHX);
I32
Perl_eval_sv(pTHX_ SV *sv, I32 flags)
-
+
/* See G_* flags in cop.h */
{
dSP;
dSP;
SV* sv = newSVpv(p, 0);
- PUSHMARK(SP);
eval_sv(sv, G_SCALAR);
SvREFCNT_dec(sv);
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':
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;
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)
#endif
PerlIO_printf(PerlIO_stdout(),
- "\n\nCopyright 1987-2000, Larry Wall\n");
+ "\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
#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) {
}
}
+#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 = "";
sv_catpvn(sv, "-I", 2);
sv_catpv(sv,PRIVLIB_EXP);
-#ifdef MSDOS
+#if defined(MSDOS) || defined(WIN32)
Perl_sv_setpvf(aTHX_ cmd, "\
sed %s -e \"/^[^#]/b\" \
-e \"/^#[ ]*include[ ]/b\" \
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)
||
/* 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;
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;
PL_statname = NEWSV(66,0); /* last filename we did stat on */
- if (!PL_osname)
- PL_osname = savepv(OSNAME);
+ if (PL_osname)
+ Safefree(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;
+#ifdef NEED_ENVIRON_DUP_FOR_MODIFY
+ int dup_env_count = 0;
+#endif
argc--,argv++; /* skip name of script */
if (PL_doswitches) {
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());
+ sv_setpv(GvSV(tmpgv), os2_execname(aTHX));
#else
sv_setpv(GvSV(tmpgv),PL_origargv[0]);
#endif
GvMULTI_on(PL_envgv);
hv = GvHVn(PL_envgv);
hv_magic(hv, PL_envgv, 'E');
-#if !defined( VMS) && !defined(EPOC) /* 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
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 **)
+ safemalloc( sizeof(char *) * (dup_env_count+1) ))) {
+ char **dup_env;
+ for (env = env_base, dup_env = dup_env_base;
+ *env;
+ env++, dup_env++)
+ *dup_env = savepv(*env);
+ *dup_env = Nullch;
+ env = dup_env_base;
+ } /* else what? */
+ }
+#endif /* NEED_ENVIRON_DUP_FOR_MODIFY */
for (; *env; env++) {
if (!(s = strchr(*env,'=')))
continue;
(void)PerlEnv_putenv(savepv(*env));
#endif
}
-#endif
+ if (dup_env_base) {
+ char **dup_env;
+ for (dup_env = dup_env_base; *dup_env; dup_env++)
+ Safefree(*dup_env);
+ Safefree(dup_env_base);
+ }
+#endif /* USE_ENVIRON_ARRAY */
#ifdef DYNAMIC_ENV_FETCH
HvNAME(hv) = savepv(ENV_HV_NAME);
#endif
#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
-#if defined(WIN32)
+#if defined(WIN32)
incpush(PRIVLIB_EXP, TRUE, FALSE);
#else
incpush(PRIVLIB_EXP, FALSE, FALSE);
if (!PL_tainting)
incpush(".", FALSE, FALSE);
+#endif /* MACOS_TRADITIONAL */
}
-#if defined(DOSISH)
+#if defined(DOSISH) || defined(EPOC)
# define PERLLIB_SEP ';'
#else
# if defined(VMS)
# define PERLLIB_SEP '|'
# else
-# define PERLLIB_SEP ':'
+# if defined(MACOS_TRADITIONAL)
+# define PERLLIB_SEP ','
+# else
+# define PERLLIB_SEP ':'
+# endif
# endif
#endif
#ifndef PERLLIB_MANGLE
# define PERLLIB_MANGLE(s,n) (s)
-#endif
+#endif
STATIC void
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
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_FS_VER_FMT"/%s",
+ Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH PERL_ARCH_FMT,
libdir,
(int)PERL_REVISION, (int)PERL_VERSION,
(int)PERL_SUBVERSION, ARCHNAME);
av_push(GvAVn(PL_incgv), newSVsv(subdir));
/* .../version if -d .../version */
- Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/"PERL_FS_VER_FMT, libdir,
+ Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH, libdir,
(int)PERL_REVISION, (int)PERL_VERSION,
(int)PERL_SUBVERSION);
if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
av_push(GvAVn(PL_incgv), newSVsv(subdir));
/* .../archname if -d .../archname */
- Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/%s", libdir, ARCHNAME);
+ Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, ARCHNAME);
if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
S_ISDIR(tmpstatbuf.st_mode))
av_push(GvAVn(PL_incgv), newSVsv(subdir));
if (addoldvers) {
for (incver = incverlist; *incver; incver++) {
/* .../xxx if -d .../xxx */
- Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/%s", libdir, *incver);
+ Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, *incver);
if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
S_ISDIR(tmpstatbuf.st_mode))
av_push(GvAVn(PL_incgv), newSVsv(subdir));
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;
https://perl5.git.perl.org / perl5.git / blobdiff