perl_construct(pTHXx)
{
#ifdef USE_THREADS
- int i;
#ifndef FAKE_THREADS
struct perl_thread *thr = NULL;
#endif /* FAKE_THREADS */
* space. The other alternative would be to provide STDAUX and STDPRN
* filehandles.
*/
- (void)fclose(stdaux);
- (void)fclose(stdprn);
+ (void)PerlIO_close(PerlIO_importFILE(stdaux, 0));
+ (void)PerlIO_close(PerlIO_importFILE(stdprn, 0));
#endif
}
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);
PL_fdpid = newAV(); /* for remembering popen pids by fd */
PL_modglobal = newHV(); /* pointers to per-interpreter module globals */
PL_errors = newSVpvn("",0);
-
+#ifdef USE_ITHREADS
+ PL_regex_padav = newAV();
+#endif
+#ifdef USE_REENTRANT_API
+ New(31337, PL_reentrant_buffer,1, REBUF);
+ New(31337, PL_reentrant_buffer->tmbuff,1, struct tm);
+#endif
ENTER;
}
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
+
+#ifdef USE_ITHREADS
+ /* the syntax tree is shared between clones
+ * so op_free(PL_main_root) only ReREFCNT_dec's
+ * REGEXPs in the parent interpreter
+ * we need to manually ReREFCNT_dec for the clones
+ */
+ {
+ I32 i = AvFILLp(PL_regex_padav) + 1;
+ SV **ary = AvARRAY(PL_regex_padav);
+
+ while (i) {
+ SV *resv = ary[--i];
+ REGEXP *re = (REGEXP *)SvIVX(resv);
+
+ if (SvFLAGS(resv) & SVf_BREAK) {
+ /* this is PL_reg_curpm, already freed
+ * flag is set in regexec.c:S_regtry
+ */
+ SvFLAGS(resv) &= ~SVf_BREAK;
+ }
+ else {
+ ReREFCNT_dec(re);
+ }
+ }
+ }
+ SvREFCNT_dec(PL_regex_padav);
+ PL_regex_padav = Nullav;
+ PL_regex_pad = NULL;
+#endif
+
/* loosen bonds of global variables */
if(PL_rsfp) {
PL_e_script = Nullsv;
}
+ while (--PL_origargc >= 0) {
+ Safefree(PL_origargv[PL_origargc]);
+ }
+ Safefree(PL_origargv);
+
/* magical thingies */
SvREFCNT_dec(PL_ofs_sv); /* $, */
#ifdef USE_LOCALE_NUMERIC
Safefree(PL_numeric_name);
PL_numeric_name = Nullch;
- SvREFCNT_dec(PL_numeric_radix);
+ 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;
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 ? */
PL_thrsv = Nullsv;
#endif /* USE_THREADS */
+#ifdef USE_REENTRANT_API
+ Safefree(PL_reentrant_buffer->tmbuff);
+ Safefree(PL_reentrant_buffer);
+#endif
+
sv_free_arenas();
/* As the absolutely last thing, free the non-arena SV for mess() */
MAGIC* moremagic;
for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
moremagic = mg->mg_moremagic;
- if (mg->mg_ptr && mg->mg_type != 'g' && mg->mg_len >= 0)
+ if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global
+ && mg->mg_len >= 0)
Safefree(mg->mg_ptr);
Safefree(mg);
}
#if defined(PERL_OBJECT)
PerlMem_free(this);
#else
-# if defined(WIN32)
+# if defined(WIN32) || defined(NETWARE)
# if defined(PERL_IMPLICIT_SYS)
- void *host = w32_internal_host;
- if (PerlProc_lasthost()) {
+ #ifdef NETWARE
+ void *host = nw_internal_host;
+ #else
+ void *host = w32_internal_host;
+ #endif
+ #ifndef NETWARE
+ if (PerlProc_lasthost()) {
PerlIO_cleanup();
- }
+ }
+ #endif
PerlMem_free(aTHXx);
- win32_delete_internal_host(host);
+ #ifdef NETWARE
+ nw5_delete_internal_host(host);
+ #else
+ win32_delete_internal_host(host);
+ #endif
#else
PerlIO_cleanup();
PerlMem_free(aTHXx);
("__environ", (unsigned long *) &environ_pointer, NULL);
#endif /* environ */
- PL_origargv = argv;
PL_origargc = argc;
+ {
+ /* we copy rather than point to argv
+ * since perl_clone will copy and perl_destruct
+ * has no way of knowing if we've made a copy or
+ * just point to argv
+ */
+ int i = PL_origargc;
+ New(0, PL_origargv, i+1, char*);
+ PL_origargv[i] = '\0';
+ while (i-- > 0) {
+ PL_origargv[i] = savepv(argv[i]);
+ }
+ }
+
#ifdef USE_ENVIRON_ARRAY
PL_origenviron = environ;
#endif
AV* comppadlist;
register SV *sv;
register char *s;
- char *cddir = Nullch;
+ char *popts, *cddir = Nullch;
sv_setpvn(PL_linestr,"",0);
sv = newSVpvn("",0); /* first used for -I flags */
#endif
sv_catpv(PL_Sv, "; \
$\"=\"\\n \"; \
-@env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
+@env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; ");
+#ifdef __CYGWIN__
+ sv_catpv(PL_Sv,"\
+push @env, \"CYGWIN=\\\"$ENV{CYGWIN}\\\"\";");
+#endif
+ sv_catpv(PL_Sv, "\
print \" \\%ENV:\\n @env\\n\" if @env; \
print \" \\@INC:\\n @INC\\n\";");
}
#ifndef SECURE_INTERNAL_GETENV
!PL_tainting &&
#endif
- (s = PerlEnv_getenv("PERL5OPT")))
+ (popts = PerlEnv_getenv("PERL5OPT")))
{
+ s = savepv(popts);
while (isSPACE(*s))
s++;
if (*s == '-' && *(s+1) == 'T')
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);
}
}
}
av_store(comppadlist, 1, (SV*)PL_comppad);
CvPADLIST(PL_compcv) = comppadlist;
+ boot_core_PerlIO();
boot_core_UNIVERSAL();
#ifndef PERL_MICRO
boot_core_xsutils();
LOGOP myop; /* fake syntax tree node */
UNOP method_op;
I32 oldmark;
- I32 retval;
+ volatile I32 retval = 0;
I32 oldscope;
bool oldcatch = CATCH_GET;
int ret;
{
dSP;
UNOP myop; /* fake syntax tree node */
- I32 oldmark = SP - PL_stack_base;
- I32 retval;
+ volatile I32 oldmark = SP - PL_stack_base;
+ volatile I32 retval = 0;
I32 oldscope;
int ret;
OP* oldop = PL_op;
/*
=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)
register GV *gv;
if ((gv = gv_fetchpv(sym,TRUE, SVt_PV)))
- sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
+ sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, namlen);
}
STATIC void
S_usage(pTHX_ char *name) /* XXX move this out into a module ? */
{
/* This message really ought to be max 23 lines.
- * Removed -h because the user already knows that opton. Others? */
+ * Removed -h because the user already knows that option. Others? */
static char *usage_msg[] = {
"-0[octal] specify record separator (\\0, if no argument)",
#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,
s++;
return s;
case 'v':
+#if !defined(DGUX)
PerlIO_printf(PerlIO_stdout(),
Perl_form(aTHX_ "\nThis is perl, v%"VDf" built for %s",
PL_patchlevel, ARCHNAME));
+#else /* DGUX */
+/* Adjust verbose output as in the perl that ships with the DG/UX OS from EMC */
+ PerlIO_printf(PerlIO_stdout(),
+ Perl_form(aTHX_ "\nThis is perl, version %vd\n", PL_patchlevel));
+ PerlIO_printf(PerlIO_stdout(),
+ Perl_form(aTHX_ " built under %s at %s %s\n",
+ OSNAME, __DATE__, __TIME__));
+ PerlIO_printf(PerlIO_stdout(),
+ Perl_form(aTHX_ " OS Specific Release: %s\n",
+ OSVERS));
+#endif /* !DGUX */
+
#if defined(LOCAL_PATCH_COUNT)
if (LOCAL_PATCH_COUNT > 0)
PerlIO_printf(PerlIO_stdout(),
#endif
#ifdef MPE
PerlIO_printf(PerlIO_stdout(),
- "MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-1999\n");
+ "MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-2001\n");
#endif
#ifdef OEMVS
PerlIO_printf(PerlIO_stdout(),
PerlIO_printf(PerlIO_stdout(),
"EPOC port by Olaf Flebbe, 1999-2000\n");
#endif
+#ifdef UNDER_CE
+ printf("WINCE port by Rainer Keuchel, 2001\n");
+ printf("Built on " __DATE__ " " __TIME__ "\n\n");
+ wce_hitreturn();
+#endif
#ifdef BINARY_BUILD_NOTICE
BINARY_BUILD_NOTICE;
#endif
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
}
}
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"))) {
+ s2 = s;
+ if (*s == '#' && s[1] == '!' && ((s = instr(s,"perl")) || (s = instr(s2,"PERL")))) {
PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */
PL_doextract = FALSE;
while (*s && !(isSPACE (*s) || *s == '#')) s++;
while ((s = moreswitches(s)))
;
}
+#ifdef MACOS_TRADITIONAL
+ break;
+#endif
}
}
}
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;
+#ifdef NEED_ENVIRON_DUP_FOR_MODIFY
char **dup_env_base = 0;
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, PERL_MAGIC_env);
#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
#ifdef NEED_ENVIRON_DUP_FOR_MODIFY
{
char **env_base;
- for (env_base = env; *env; env++)
+ for (env_base = env; *env; env++)
dup_env_count++;
if ((dup_env_base = (char **)
- safemalloc( sizeof(char *) * (dup_env_count+1) ))) {
+ safesysmalloc( 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);
+ 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 (env)
+ for (; *env; env++) {
if (!(s = strchr(*env,'=')))
continue;
*s++ = '\0';
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++)
- Safefree(*dup_env);
- Safefree(dup_env_base);
+ 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
}
TAINT_NOT;
if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV)))
(void) find_threadsv("@"); /* Ensure $@ is initialised early */
PL_maxscream = -1;
+ PL_peepp = MEMBER_TO_FPTR(Perl_peep);
PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);