/* 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.
if (PERL_REVISION > 127 || PERL_VERSION > 127 || PERL_SUBVERSION > 127)
SvGROW(PL_patchlevel, UTF8_MAXLEN*3+1);
s = (U8*)SvPVX(PL_patchlevel);
- s = uv_to_utf8(s, (UV)PERL_REVISION);
- s = uv_to_utf8(s, (UV)PERL_VERSION);
- s = uv_to_utf8(s, (UV)PERL_SUBVERSION);
+ /* Build version strings using "native" characters */
+ s = uvchr_to_utf8(s, (UV)PERL_REVISION);
+ s = uvchr_to_utf8(s, (UV)PERL_VERSION);
+ s = uvchr_to_utf8(s, (UV)PERL_SUBVERSION);
*s = '\0';
SvCUR_set(PL_patchlevel, s - (U8*)SvPVX(PL_patchlevel));
SvPOK_on(PL_patchlevel);
perl_destruct(pTHXx)
{
int destruct_level; /* 0=none, 1=full, 2=full with checks */
- I32 last_sv_count;
HV *hv;
#ifdef USE_THREADS
Thread t;
LEAVE;
FREETMPS;
+
/* We must account for everything. */
/* Destroy the main CV and syntax tree */
PL_main_cv = Nullcv;
PL_dirty = TRUE;
+ /* Tell PerlIO we are about to tear things apart in case
+ we have layers which are using resources that should
+ be cleaned up now.
+ */
+
+ PerlIO_destruct(aTHX);
+
if (PL_sv_objcount) {
/*
* Try to destruct global references. We do this first so that the
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) {
/* 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_sv);
#endif
/* clear utf8 character classes */
}
/* 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 */
- while (PL_sv_count != 0 && PL_sv_count != last_sv_count) {
- last_sv_count = PL_sv_count;
- sv_clean_all();
- }
+
+ /* the 2 is for PL_fdpid and PL_strtab */
+ while (PL_sv_count > 2 && sv_clean_all())
+ ;
+
SvFLAGS(PL_fdpid) &= ~SVTYPEMASK;
SvFLAGS(PL_fdpid) |= SVt_PVAV;
SvFLAGS(PL_strtab) &= ~SVTYPEMASK;
}
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_bitcount);
+ Safefree(PL_psig_pend);
nuke_stacks();
PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */
# if defined(WIN32)
# if defined(PERL_IMPLICIT_SYS)
void *host = w32_internal_host;
- if (PerlProc_lasthost())
+ if (PerlProc_lasthost()) {
PerlIO_cleanup();
+ }
PerlMem_free(aTHXx);
win32_delete_internal_host(host);
#else
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);
}
}
}
/*
=for apidoc p||require_pv
-Tells Perl to C<require> a module.
+Tells Perl to C<require> the file named by the string argument. It is
+analogous to the Perl code C<eval "require '$file'">. It's even
+implemented that way; consider using Perl_load_module instead.
-=cut
-*/
+=cut */
void
Perl_require_pv(pTHX_ const char *pv)
#ifdef DEBUGGING
forbid_setid("-D");
if (isALPHA(s[1])) {
- static char debopts[] = "psltocPmfrxuLHXDST";
+ /* if adding extra options, remember to update DEBUG_MASK */
+ static char debopts[] = "psltocPmfrxuLHXDSTR";
char *d;
for (s++; *s && (d = strchr(debopts,*s)); s++)
PL_debug = atoi(s+1);
for (s++; isDIGIT(*s); s++) ;
}
- PL_debug |= 0x80000000;
+ PL_debug |= DEBUG_TOP_FLAG;
#else
if (ckWARN_d(WARN_DEBUGGING))
Perl_warner(aTHX_ WARN_DEBUGGING,
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 {
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(),
sv_catpvn(sv, "-I", 2);
sv_catpv(sv,PRIVLIB_EXP);
+ 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\" \
}
#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
}
}
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) {
PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
GvMULTI_on(PL_stdingv);
io = GvIOp(PL_stdingv);
+ IoTYPE(io) = IoTYPE_RDONLY;
IoIFP(io) = PerlIO_stdin();
tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
GvMULTI_on(tmpgv);
tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
GvMULTI_on(tmpgv);
io = GvIOp(tmpgv);
+ IoTYPE(io) = IoTYPE_WRONLY;
IoOFP(io) = IoIFP(io) = PerlIO_stdout();
setdefout(tmpgv);
tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
PL_stderrgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
GvMULTI_on(PL_stderrgv);
io = GvIOp(PL_stderrgv);
+ IoTYPE(io) = IoTYPE_WRONLY;
IoOFP(io) = IoIFP(io) = PerlIO_stderr();
tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
GvMULTI_on(tmpgv);
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) {
HV *hv;
GvMULTI_on(PL_envgv);
hv = GvHVn(PL_envgv);
- hv_magic(hv, PL_envgv, 'E');
+ hv_magic(hv, Nullgv, 'E');
#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
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;
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
}
-#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 */
#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 &&
projects / p5sagit/p5-mst-13.2.git / blobdiff