#include <sys/file.h>
#endif
-dEXTCONST char rcsid[] = "perl.c\nPatch level: ###\n";
-
#ifdef IAMSUID
#ifndef DOSUID
#define DOSUID
void
#ifdef PERL_OBJECT
-CPerlObj::perl_construct(void)
+perl_construct(void)
#else
perl_construct(register PerlInterpreter *sv_interp)
#endif
MUTEX_INIT(&PL_svref_mutex);
#endif /* EMULATE_ATOMIC_REFCOUNTS */
+ MUTEX_INIT(&PL_cred_mutex);
+
thr = init_main_thread();
#endif /* USE_THREADS */
+ PL_curcop = &PL_compiling; /* needed by ckWARN, right away */
+
PL_linestr = NEWSV(65,79);
sv_upgrade(PL_linestr,SVt_PVIV);
void
#ifdef PERL_OBJECT
-CPerlObj::perl_destruct(void)
+perl_destruct(void)
#else
perl_destruct(register PerlInterpreter *sv_interp)
#endif
/* Pass 1 on any remaining threads: detach joinables, join zombies */
retry_cleanup:
MUTEX_LOCK(&PL_threads_mutex);
- DEBUG_L(PerlIO_printf(PerlIO_stderr(),
+ DEBUG_S(PerlIO_printf(PerlIO_stderr(),
"perl_destruct: waiting for %d threads...\n",
PL_nthreads - 1));
for (t = thr->next; t != thr; t = t->next) {
switch (ThrSTATE(t)) {
AV *av;
case THRf_ZOMBIE:
- DEBUG_L(PerlIO_printf(PerlIO_stderr(),
+ DEBUG_S(PerlIO_printf(PerlIO_stderr(),
"perl_destruct: joining zombie %p\n", t));
ThrSETSTATE(t, THRf_DEAD);
MUTEX_UNLOCK(&t->mutex);
MUTEX_UNLOCK(&PL_threads_mutex);
JOIN(t, &av);
SvREFCNT_dec((SV*)av);
- DEBUG_L(PerlIO_printf(PerlIO_stderr(),
+ DEBUG_S(PerlIO_printf(PerlIO_stderr(),
"perl_destruct: joined zombie %p OK\n", t));
goto retry_cleanup;
case THRf_R_JOINABLE:
- DEBUG_L(PerlIO_printf(PerlIO_stderr(),
+ DEBUG_S(PerlIO_printf(PerlIO_stderr(),
"perl_destruct: detaching thread %p\n", t));
ThrSETSTATE(t, THRf_R_DETACHED);
/*
MUTEX_UNLOCK(&t->mutex);
goto retry_cleanup;
default:
- DEBUG_L(PerlIO_printf(PerlIO_stderr(),
+ DEBUG_S(PerlIO_printf(PerlIO_stderr(),
"perl_destruct: ignoring %p (state %u)\n",
t, ThrSTATE(t)));
MUTEX_UNLOCK(&t->mutex);
/* Pass 2 on remaining threads: wait for the thread count to drop to one */
while (PL_nthreads > 1)
{
- DEBUG_L(PerlIO_printf(PerlIO_stderr(),
+ DEBUG_S(PerlIO_printf(PerlIO_stderr(),
"perl_destruct: final wait for %d threads\n",
PL_nthreads - 1));
COND_WAIT(&PL_nthreads_cond, &PL_threads_mutex);
}
/* At this point, we're the last thread */
MUTEX_UNLOCK(&PL_threads_mutex);
- DEBUG_L(PerlIO_printf(PerlIO_stderr(), "perl_destruct: armageddon has arrived\n"));
+ DEBUG_S(PerlIO_printf(PerlIO_stderr(), "perl_destruct: armageddon has arrived\n"));
MUTEX_DESTROY(&PL_threads_mutex);
COND_DESTROY(&PL_nthreads_cond);
#endif /* !defined(FAKE_THREADS) */
PL_main_start = Nullop;
SvREFCNT_dec(PL_main_cv);
PL_main_cv = Nullcv;
+ PL_dirty = TRUE;
if (PL_sv_objcount) {
/*
* destructors and destructees still exist. Some sv's might remain.
* Non-referenced objects are on their own.
*/
-
- PL_dirty = TRUE;
sv_clean_objs();
}
PL_minus_a = FALSE;
PL_minus_F = FALSE;
PL_doswitches = FALSE;
- PL_dowarn = FALSE;
+ PL_dowarn = G_WARN_OFF;
PL_doextract = FALSE;
PL_sawampersand = FALSE; /* must save all match strings */
PL_sawstudy = FALSE; /* do fbm_instr on all strings */
Safefree(PL_origfilename);
Safefree(PL_archpat_auto);
Safefree(PL_reg_start_tmp);
+ if (PL_reg_curpm)
+ Safefree(PL_reg_curpm);
Safefree(HeKEY_hek(&PL_hv_fetch_ent_mh));
Safefree(PL_op_mask);
nuke_stacks();
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);
COND_DESTROY(&PL_eval_cond);
/* As the penultimate thing, free the non-arena SV for thrsv */
void
#ifdef PERL_OBJECT
-CPerlObj::perl_free(void)
+perl_free(void)
#else
perl_free(PerlInterpreter *sv_interp)
#endif
void
#ifdef PERL_OBJECT
-CPerlObj::perl_atexit(void (*fn) (CPerlObj*,void *), void *ptr)
+perl_atexit(void (*fn) (CPerlObj*,void *), void *ptr)
#else
perl_atexit(void (*fn) (void *), void *ptr)
#endif
int
#ifdef PERL_OBJECT
-CPerlObj::perl_parse(void (*xsinit) (CPerlObj*), int argc, char **argv, char **env)
+perl_parse(void (*xsinit) (CPerlObj*), int argc, char **argv, char **env)
#else
perl_parse(PerlInterpreter *sv_interp, void (*xsinit) (void), int argc, char **argv, char **env)
#endif
time(&PL_basetime);
oldscope = PL_scopestack_ix;
+ PL_dowarn = G_WARN_OFF;
JMPENV_PUSH(ret);
switch (ret) {
case 'u':
case 'U':
case 'v':
+ case 'W':
+ case 'X':
case 'w':
if (s = moreswitches(s))
goto reswitch;
#else
sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
#endif
-#if defined(DEBUGGING) || defined(NO_EMBED) || defined(MULTIPLICITY)
+#if defined(DEBUGGING) || defined(MULTIPLICITY)
sv_catpv(PL_Sv,"\" Compile-time options:");
# ifdef DEBUGGING
sv_catpv(PL_Sv," DEBUGGING");
# endif
-# ifdef NO_EMBED
- sv_catpv(PL_Sv," NO_EMBED");
-# endif
# ifdef MULTIPLICITY
sv_catpv(PL_Sv," MULTIPLICITY");
# endif
sv_catpv(PL_Sv,"\" Locally applied patches:\\n\",");
for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
if (PL_localpatches[i])
- sv_catpvf(PL_Sv,"\" \\t%s\\n\",",PL_localpatches[i]);
+ sv_catpvf(PL_Sv,"q\" \t%s\n\",",PL_localpatches[i]);
}
}
#endif
if (PL_do_undump)
my_unexec();
- if (PL_dowarn)
+ if (ckWARN(WARN_ONCE))
gv_check(PL_defstash);
LEAVE;
int
#ifdef PERL_OBJECT
-CPerlObj::perl_run(void)
+perl_run(void)
#else
perl_run(PerlInterpreter *sv_interp)
#endif
{
- dSP;
+ dTHR;
I32 oldscope;
dJMPENV;
int ret;
if (!PL_restartop) {
DEBUG_x(dump_all());
DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
-#ifdef USE_THREADS
- DEBUG_L(PerlIO_printf(Perl_debug_log, "main thread is 0x%lx\n",
+ DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%lx\n",
(unsigned long) thr));
-#endif /* USE_THREADS */
if (PL_minus_c) {
PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", PL_origfilename);
perl_get_cv(char *name, I32 create)
{
GV* gv = gv_fetchpv(name, create, SVt_PVCV);
+ /* XXX unsafe for threads if eval_owner isn't held */
if (create && !GvCVu(gv))
return newSUB(start_subparse(FALSE, 0),
newSVOP(OP_CONST, 0, newSVpv(name,0)),
sv = POPs;
PUTBACK;
- if (croak_on_error && SvTRUE(ERRSV))
- croak(SvPVx(ERRSV, PL_na));
+ if (croak_on_error && SvTRUE(ERRSV)) {
+ STRLEN n_a;
+ croak(SvPVx(ERRSV, n_a));
+ }
return sv;
}
#ifdef DEBUGGING
forbid_setid("-D");
if (isALPHA(s[1])) {
- static char debopts[] = "psltocPmfrxuLHXD";
+ static char debopts[] = "psltocPmfrxuLHXDS";
char *d;
for (s++; *s && (d = strchr(debopts,*s)); s++)
#ifdef MPE
printf("MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-1998\n");
#endif
+#ifdef OEMVS
+ printf("MVS (OS390) port by Mortice Kern Systems, 1997-1998\n");
+#endif
+#ifdef __VOS__
+ printf("Stratus VOS port by Paul_Green@stratus.com, 1997-1998\n");
+#endif
+#ifdef __OPEN_VM
+ printf("VM/ESA port by Neale Ferguson, 1998\n");
+#endif
+#ifdef POSIX_BC
+ printf("BS2000 (POSIX) port by Start Amadeus GmbH, 1998\n");
+#endif
#ifdef BINARY_BUILD_NOTICE
BINARY_BUILD_NOTICE;
#endif
Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
PerlProc_exit(0);
case 'w':
- PL_dowarn = TRUE;
+ if (! (PL_dowarn & G_WARN_ALL_MASK))
+ PL_dowarn |= G_WARN_ON;
+ s++;
+ return s;
+ case 'W':
+ PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
+ PL_compiling.cop_warnings = WARN_ALL ;
+ s++;
+ return s;
+ case 'X':
+ PL_dowarn = G_WARN_ALL_OFF;
+ PL_compiling.cop_warnings = WARN_NONE ;
s++;
return s;
case '*':
break;
case '-':
case 0:
-#ifdef WIN32
+#if defined(WIN32) || !defined(PERL_STRICT_CR)
case '\r':
#endif
case '\n':
PL_curcopdb = NULL; \
PL_dbargs = 0; \
PL_dlmax = 128; \
+ PL_dumpindent = 4; \
PL_laststatval = -1; \
PL_laststype = OP_STAT; \
PL_maxscream = -1; \
PL_profiledata = NULL; \
PL_rsfp = Nullfp; \
PL_rsfp_filters = Nullav; \
+ PL_dirty = FALSE; \
} STMT_END
I_REINIT;
#else
# undef PERLVAR
# undef PERLVARI
# undef PERLVARIC
-# else
+# else
# define PERLVAR(var,type)
# define PERLVARI(var,type,init) PL_##var = init;
# define PERLVARIC(var,type,init) PL_##var = init;
about not iterating on it, and not adding tie magic to it.
It is properly deallocated in perl_destruct() */
PL_strtab = newHV();
+#ifdef USE_THREADS
+ MUTEX_INIT(&PL_strtab_mutex);
+#endif
HvSHAREKEYS_off(PL_strtab); /* mandatory */
hv_ksplit(PL_strtab, 512);
PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
/* We must init $/ before switches are processed. */
- sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
+ sv_setpvn(perl_get_sv("/", TRUE), "\n", 1);
}
STATIC void
%s | %_ -C %_ %s",
(PL_doextract ? "-e \"1,/^#/d\n\"" : ""),
#else
+# ifdef __OPEN_VM
+ sv_setpvf(cmd, "\
+%s %s -e '/^[^#]/b' \
+ -e '/^#[ ]*include[ ]/b' \
+ -e '/^#[ ]*define[ ]/b' \
+ -e '/^#[ ]*if[ ]/b' \
+ -e '/^#[ ]*ifdef[ ]/b' \
+ -e '/^#[ ]*ifndef[ ]/b' \
+ -e '/^#[ ]*else/b' \
+ -e '/^#[ ]*elif[ ]/b' \
+ -e '/^#[ ]*undef[ ]/b' \
+ -e '/^#[ ]*endif/b' \
+ -e 's/^[ ]*#.*//' \
+ %s | %_ %_ %s",
+# else
sv_setpvf(cmd, "\
%s %s -e '/^[^#]/b' \
-e '/^#[ ]*include[ ]/b' \
-e '/^#[ ]*endif/b' \
-e 's/^[ ]*#.*//' \
%s | %_ -C %_ %s",
+# endif
#ifdef LOC_SED
LOC_SED,
#else
croak("Can't stat script \"%s\"",PL_origfilename);
if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
I32 len;
+ STRLEN n_a;
#ifdef IAMSUID
#ifndef HAS_SETREUID
PL_doswitches = FALSE; /* -s is insecure in suid */
PL_curcop->cop_line++;
if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
- strnNE(SvPV(PL_linestr,PL_na),"#!",2) ) /* required even on Sys V */
+ strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
croak("No #! line");
- s = SvPV(PL_linestr,PL_na)+2;
+ s = SvPV(PL_linestr,n_a)+2;
if (*s == ' ') s++;
while (!isSPACE(*s)) s++;
- for (s2 = s; (s2 > SvPV(PL_linestr,PL_na)+2 &&
+ for (s2 = s; (s2 > SvPV(PL_linestr,n_a)+2 &&
(isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
croak("Not a perl script");
char *unix;
STRLEN len;
- if ((unix = tounixspec_ts(SvPV(libdir,PL_na),Nullch)) != Nullch) {
+ if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
len = strlen(unix);
while (unix[len-1] == '/') len--; /* Cosmetic */
sv_usepvn(libdir,unix,len);
else
PerlIO_printf(PerlIO_stderr(),
"Failed to unixify @INC element \"%s\"\n",
- SvPV(libdir,PL_na));
+ SvPV(libdir,len));
#endif
/* .../archname/version if -d .../archname/version/auto */
sv_setsv(subdir, libdir);
*SvEND(PL_thrsv) = '\0'; /* in the trailing_nul field */
thr->oursv = PL_thrsv;
PL_chopset = " \n-";
+ PL_dumpindent = 4;
MUTEX_LOCK(&PL_threads_mutex);
PL_nthreads++;
{
dTHR;
-#ifdef USE_THREADS
- DEBUG_L(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
+ DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
thr, (unsigned long) status));
-#endif /* USE_THREADS */
switch (status) {
case 0:
STATUS_ALL_SUCCESS;
STATIC void
my_exit_jump(void)
{
- dSP;
+ dTHR;
register PERL_CONTEXT *cx;
I32 gimme;
SV **newsp;
p = SvPVX(PL_e_script);
nl = strchr(p, '\n');
nl = (nl) ? nl+1 : SvEND(PL_e_script);
- if (nl-p == 0)
+ if (nl-p == 0) {
+ filter_del(read_e_script);
return 0;
+ }
sv_catpvn(buf_sv, p, nl-p);
sv_chop(PL_e_script, nl);
return 1;
projects / p5sagit/p5-mst-13.2.git / blobdiff