/* 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.
void
perl_destruct(pTHXx)
{
- dTHR;
int destruct_level; /* 0=none, 1=full, 2=full with checks */
I32 last_sv_count;
HV *hv;
/* 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 */
}
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;
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 ? */
# if defined(PERL_IMPLICIT_SYS)
void *host = w32_internal_host;
if (PerlProc_lasthost()) {
- PerlIO_cleanup();
+ PerlIO_cleanup();
}
PerlMem_free(aTHXx);
win32_delete_internal_host(host);
#else
- PerlIO_cleanup();
+ PerlIO_cleanup();
PerlMem_free(aTHXx);
#endif
# else
int
perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
{
- dTHR;
I32 oldscope;
int ret;
dJMPENV;
STATIC void *
S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
{
- dTHR;
int argc = PL_origargc;
char **argv = PL_origargv;
char *scriptname = NULL;
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);
}
}
}
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"));
#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);
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 */
switch (*s) {
case '0':
{
- dTHR;
numlen = 0; /* disallow underscores */
rschar = (U32)scan_oct(s, 4, &numlen);
SvREFCNT_dec(PL_nrs);
}
PL_debug |= 0x80000000;
#else
- dTHR;
if (ckWARN_d(WARN_DEBUGGING))
Perl_warner(aTHX_ WARN_DEBUGGING,
"Recompile perl with -DDEBUGGING to use -D switch\n");
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':
#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(),
- "\nMacOS port Copyright (c) 1991-2000, Matthias Neeracher\n");
+ "\nMac OS port Copyright (c) 1991-2001, Matthias Neeracher\n");
#endif
#ifdef MSDOS
PerlIO_printf(PerlIO_stdout(),
STATIC void
S_init_main_stash(pTHX)
{
- dTHR;
GV *gv;
/* Note that strtab is a rather special HV. Assumptions are made
STATIC void
S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
{
- dTHR;
-
*fdscript = -1;
if (PL_e_script) {
*/
#ifdef DOSUID
- dTHR;
char *s, *s2;
if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
#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 */
+ /* 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) {
void
Perl_init_debugger(pTHX)
{
- dTHR;
HV *ostash = PL_curstash;
PL_curstash = PL_debstash;
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;
+ 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) {
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
if (addsubdirs) {
#ifdef MACOS_TRADITIONAL
#define PERL_AV_SUFFIX_FMT ""
-#define PERL_ARCH_FMT ":%s"
+#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_AV_SUFFIX_FMT PERL_FS_VER_FMT PERL_ARCH_FMT,
+ 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_AV_SUFFIX_FMT 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 &&
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;
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) {
STATIC void
S_my_exit_jump(pTHX)
{
- dTHR;
register PERL_CONTEXT *cx;
I32 gimme;
SV **newsp;
https://perl5.git.perl.org / perl5.git / blobdiff