perl_alloc(void)
{
PerlInterpreter *my_perl;
+#ifdef USE_5005THREADS
+ dTHX;
+#endif
/* New() needs interpreter, so call malloc() instead */
my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
PL_fdpid = newAV(); /* for remembering popen pids by fd */
PL_modglobal = newHV(); /* pointers to per-interpreter module globals */
PL_errors = newSVpvn("",0);
+ sv_setpvn(PERL_DEBUG_PAD(0), "", 0); /* For regex debugging. */
+ sv_setpvn(PERL_DEBUG_PAD(1), "", 0); /* ext/re needs these */
+ sv_setpvn(PERL_DEBUG_PAD(2), "", 0); /* even without DEBUGGING. */
#ifdef USE_ITHREADS
PL_regex_padav = newAV();
av_push(PL_regex_padav,(SV*)newAV()); /* First entry is an array of empty elements */
PL_regex_pad = AvARRAY(PL_regex_padav);
#endif
#ifdef USE_REENTRANT_API
- New(31337, PL_reentrant_buffer,1, REBUF);
- New(31337, PL_reentrant_buffer->tmbuff,1, struct tm);
+ Perl_reentrant_init(aTHX);
#endif
/* Note that strtab is a rather special HV. Assumptions are made
}
/*
+=for apidoc nothreadhook
+
+Stub that provides thread hook for perl_destruct when there are
+no threads.
+
+=cut
+*/
+
+int
+Perl_nothreadhook(pTHX)
+{
+ return 0;
+}
+
+/*
=for apidoc perl_destruct
Shuts down a Perl interpreter. See L<perlembed>.
LEAVE;
FREETMPS;
+ if (CALL_FPTR(PL_threadhook)(aTHX)) {
+ /* Threads hook has vetoed further cleanup */
+ return STATUS_NATIVE_EXPORT;;
+ }
+
/* We must account for everything. */
/* Destroy the main CV and syntax tree */
FREETMPS;
if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) {
if (PL_scopestack_ix != 0)
- Perl_warner(aTHX_ WARN_INTERNAL,
+ Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
"Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
(long)PL_scopestack_ix);
if (PL_savestack_ix != 0)
- Perl_warner(aTHX_ WARN_INTERNAL,
+ Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
"Unbalanced saves: %ld more saves than restores\n",
(long)PL_savestack_ix);
if (PL_tmps_floor != -1)
- Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced tmps: %ld more allocs than frees\n",
+ Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced tmps: %ld more allocs than frees\n",
(long)PL_tmps_floor + 1);
if (cxstack_ix != -1)
- Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced context: %ld more PUSHes than POPs\n",
+ Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced context: %ld more PUSHes than POPs\n",
(long)cxstack_ix + 1);
}
hent = array[0];
for (;;) {
if (hent && ckWARN_d(WARN_INTERNAL)) {
- Perl_warner(aTHX_ WARN_INTERNAL,
+ Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
"Unbalanced string table refcount: (%d) for \"%s\"",
HeVAL(hent) - Nullsv, HeKEY(hent));
HeVAL(hent) = Nullsv;
SvREADONLY_off(&PL_sv_undef);
if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
- Perl_warner(aTHX_ WARN_INTERNAL,"Scalars leaked: %ld\n", (long)PL_sv_count);
+ Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Scalars leaked: %ld\n", (long)PL_sv_count);
#if defined(PERLIO_LAYERS)
/* No more IO - including error messages ! */
#endif /* USE_5005THREADS */
#ifdef USE_REENTRANT_API
- Safefree(PL_reentrant_buffer->tmbuff);
- Safefree(PL_reentrant_buffer);
+ Perl_reentrant_free(aTHX);
#endif
sv_free_arenas();
Sighandler_t sigstate = rsignal_state(SIGCHLD);
if (sigstate == SIG_IGN) {
if (ckWARN(WARN_SIGNAL))
- Perl_warner(aTHX_ WARN_SIGNAL,
+ Perl_warner(aTHX_ packWARN(WARN_SIGNAL),
"Can't ignore signal CHLD, forcing to default");
(void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
}
if (!PL_do_undump)
init_postdump_symbols(argc,argv,env);
+ if (PL_wantutf8) { /* Requires init_predump_symbols(). */
+ IO* io;
+ PerlIO* fp;
+ SV* sv;
+ if (PL_stdingv && (io = GvIO(PL_stdingv)) && (fp = IoIFP(io)))
+ PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
+ if (PL_defoutgv && (io = GvIO(PL_defoutgv)) && (fp = IoOFP(io)))
+ PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
+ if (PL_stderrgv && (io = GvIO(PL_stderrgv)) && (fp = IoOFP(io)))
+ PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
+ if ((sv = GvSV(gv_fetchpv("\017PEN", TRUE, SVt_PV)))) {
+ sv_setpvn(sv, ":utf8\0:utf8", 11);
+ SvSETMAGIC(sv);
+ }
+ }
+
init_lexer();
/* now parse the script */
"-s enable rudimentary parsing for switches after programfile",
"-S look for programfile using PATH environment variable",
"-T enable tainting checks",
+"-t enable tainting warnings",
"-u dump core after parsing program",
"-U allow unsafe operations",
"-v print version, subversion (includes VERY IMPORTANT perl info)",
forbid_setid("-D");
if (isALPHA(s[1])) {
/* if adding extra options, remember to update DEBUG_MASK */
- static char debopts[] = "psltocPmfrxuLHXDSTR";
+ static char debopts[] = "psltocPmfrxuLHXDSTRJ";
char *d;
for (s++; *s && (d = strchr(debopts,*s)); s++)
PL_debug = atoi(s+1);
for (s++; isDIGIT(*s); s++) ;
}
+#ifdef EBCDIC
+ if (DEBUG_p_TEST_ && ckWARN_d(WARN_DEBUGGING))
+ Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
+ "-Dp not implemented on this platform\n");
+#endif
PL_debug |= DEBUG_TOP_FLAG;
-#else
+#else /* !DEBUGGING */
if (ckWARN_d(WARN_DEBUGGING))
- Perl_warner(aTHX_ WARN_DEBUGGING,
+ Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
"Recompile perl with -DDEBUGGING to use -D switch\n");
for (s++; isALNUM(*s); s++) ;
#endif
#endif
#ifdef __VOS__
PerlIO_printf(PerlIO_stdout(),
- "Stratus VOS port by Paul_Green@stratus.com, 1997-2002\n");
+ "Stratus VOS port by Paul.Green@stratus.com, 1997-2002\n");
#endif
#ifdef __OPEN_VM
PerlIO_printf(PerlIO_stdout(),
{
GV *gv;
-
-
PL_curstash = PL_defstash = newHV();
PL_curstname = newSVpvn("main",4);
gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
/* This strips off Perl comments which might interfere with
- the C pre-processor, including #!. #line directives are
- deliberately stripped to avoid confusion with Perl's version
+ the C pre-processor, including #!. #line directives are
+ deliberately stripped to avoid confusion with Perl's version
of #line. FWP played some golf with it so it will fit
into VMS's 255 character buffer.
*/
Perl_sv_setpvf(aTHX_ cmd, "\
%s -ne%s%s%s %s | %"SVf" %s %"SVf" %s",
- perl, quote, code, quote, scriptname, cpp,
+ perl, quote, code, quote, scriptname, cpp,
cpp_discard_flag, sv, CPPMINUS);
PL_doextract = FALSE;
}
# endif /* IAMSUID */
- DEBUG_P(PerlIO_printf(Perl_debug_log,
- "PL_preprocess: cmd=\"%s\"\n",
+ DEBUG_P(PerlIO_printf(Perl_debug_log,
+ "PL_preprocess: cmd=\"%s\"\n",
SvPVX(cmd)));
PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
PL_statbuf.st_mode & (S_ISUID|S_ISGID))
{
/* try again */
- PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT,
- BIN_EXP, (int)PERL_REVISION,
+ PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT,
+ BIN_EXP, (int)PERL_REVISION,
(int)PERL_VERSION,
(int)PERL_SUBVERSION), PL_origargv);
Perl_croak(aTHX_ "Can't do setuid\n");
{
char buf[MAXPATHLEN];
int len = readlink(PROCSELFEXE_PATH, buf, sizeof(buf) - 1);
- if (len > 0) {
+ /* FreeBSD's implementation is acknowledged to be imperfect, sometimes
+ returning the text "unknown" from the readlink rather than the path
+ to the executable (or returning an error from the readlink). Any valid
+ path has a '/' in it somewhere, so use that to validate the result.
+ See http://www.freebsd.org/cgi/query-pr.cgi?pr=35703
+ */
+ if (len > 0 && memchr(buf, '/', len)) {
sv_setpvn(sv,buf,len);
}
else {
sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
SvREADONLY_on(GvSV(tmpgv));
}
+
+ /* touch @F array to prevent spurious warnings 20020415 MJD */
+ if (PL_minus_a) {
+ (void) get_av("main::F", TRUE | GV_ADDMULTI);
+ }
+ /* touch @- and @+ arrays to prevent spurious warnings 20020415 MJD */
+ (void) get_av("main::-", TRUE | GV_ADDMULTI);
+ (void) get_av("main::+", TRUE | GV_ADDMULTI);
}
STATIC void