#include "EXTERN.h"
#include "perl.h"
-#if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
+/* XXX Configure test needed */
+#if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX) || defined(__NetBSD__)
#include <signal.h>
#endif
#if !(defined(I286) || defined(atarist))
DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%x: (%05d) malloc %ld bytes\n",ptr,PL_an++,(long)size));
#else
- DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) malloc %ld bytes\n",ptr,an++,(long)size));
+ DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) malloc %ld bytes\n",ptr,PL_an++,(long)size));
#endif
if (ptr != Nullch)
return ptr;
else if (PL_nomemok)
return Nullch;
else {
- PerlIO_puts(PerlIO_stderr(),no_mem) FLUSH;
+ PerlIO_puts(PerlIO_stderr(),PL_no_mem) FLUSH;
my_exit(1);
return Nullch;
}
} )
#else
DEBUG_m( {
- PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) rfree\n",where,an++);
- PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) realloc %ld bytes\n",ptr,an++,(long)size);
+ PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) rfree\n",where,PL_an++);
+ PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) realloc %ld bytes\n",ptr,PL_an++,(long)size);
} )
#endif
else if (PL_nomemok)
return Nullch;
else {
- PerlIO_puts(PerlIO_stderr(),no_mem) FLUSH;
+ PerlIO_puts(PerlIO_stderr(),PL_no_mem) FLUSH;
my_exit(1);
return Nullch;
}
#if !(defined(I286) || defined(atarist))
DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%x: (%05d) free\n",(char *) where,PL_an++));
#else
- DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) free\n",(char *) where,an++));
+ DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) free\n",(char *) where,PL_an++));
#endif
if (where) {
/*SUPPRESS 701*/
#if !(defined(I286) || defined(atarist))
DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%x: (%05d) calloc %ld x %ld bytes\n",ptr,PL_an++,(long)count,(long)size));
#else
- DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) calloc %ld x %ld bytes\n",ptr,an++,(long)count,(long)size));
+ DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) calloc %ld x %ld bytes\n",ptr,PL_an++,(long)count,(long)size));
#endif
if (ptr != Nullch) {
memset((void*)ptr, 0, size);
else if (PL_nomemok)
return Nullch;
else {
- PerlIO_puts(PerlIO_stderr(),no_mem) FLUSH;
+ PerlIO_puts(PerlIO_stderr(),PL_no_mem) FLUSH;
my_exit(1);
return Nullch;
}
for (i = 0; i < 256; i++) {
if (isUPPER_LC(i))
- fold_locale[i] = toLOWER_LC(i);
+ PL_fold_locale[i] = toLOWER_LC(i);
else if (isLOWER_LC(i))
- fold_locale[i] = toUPPER_LC(i);
+ PL_fold_locale[i] = toUPPER_LC(i);
else
- fold_locale[i] = i;
+ PL_fold_locale[i] = i;
}
#endif /* USE_LOCALE_CTYPE */
else
setlocale_failure = TRUE;
}
- if (!setlocale_failure)
-#endif /* LC_ALL */
- {
+ if (!setlocale_failure) {
#ifdef USE_LOCALE_CTYPE
- if (! (curctype = setlocale(LC_CTYPE,
- (!done && (lang || PerlEnv_getenv("LC_CTYPE")))
+ if (! (curctype =
+ setlocale(LC_CTYPE,
+ (!done && (lang || PerlEnv_getenv("LC_CTYPE")))
? "" : Nullch)))
setlocale_failure = TRUE;
#endif /* USE_LOCALE_CTYPE */
#ifdef USE_LOCALE_COLLATE
- if (! (curcoll = setlocale(LC_COLLATE,
- (!done && (lang || PerlEnv_getenv("LC_COLLATE")))
+ if (! (curcoll =
+ setlocale(LC_COLLATE,
+ (!done && (lang || PerlEnv_getenv("LC_COLLATE")))
? "" : Nullch)))
setlocale_failure = TRUE;
#endif /* USE_LOCALE_COLLATE */
#ifdef USE_LOCALE_NUMERIC
- if (! (curnum = setlocale(LC_NUMERIC,
- (!done && (lang || PerlEnv_getenv("LC_NUMERIC")))
+ if (! (curnum =
+ setlocale(LC_NUMERIC,
+ (!done && (lang || PerlEnv_getenv("LC_NUMERIC")))
? "" : Nullch)))
setlocale_failure = TRUE;
#endif /* USE_LOCALE_NUMERIC */
}
-#else /* !LOCALE_ENVIRON_REQUIRED */
+#endif /* LC_ALL */
-#ifdef LC_ALL
+#endif /* !LOCALE_ENVIRON_REQUIRED */
+#ifdef LC_ALL
if (! setlocale(LC_ALL, ""))
setlocale_failure = TRUE;
- else {
-#ifdef USE_LOCALE_CTYPE
- curctype = setlocale(LC_CTYPE, Nullch);
-#endif /* USE_LOCALE_CTYPE */
-#ifdef USE_LOCALE_COLLATE
- curcoll = setlocale(LC_COLLATE, Nullch);
-#endif /* USE_LOCALE_COLLATE */
-#ifdef USE_LOCALE_NUMERIC
- curnum = setlocale(LC_NUMERIC, Nullch);
-#endif /* USE_LOCALE_NUMERIC */
- }
-
-#else /* !LC_ALL */
+#endif /* LC_ALL */
+ if (!setlocale_failure) {
#ifdef USE_LOCALE_CTYPE
- if (! (curctype = setlocale(LC_CTYPE, "")))
- setlocale_failure = TRUE;
+ if (! (curctype = setlocale(LC_CTYPE, "")))
+ setlocale_failure = TRUE;
#endif /* USE_LOCALE_CTYPE */
#ifdef USE_LOCALE_COLLATE
- if (! (curcoll = setlocale(LC_COLLATE, "")))
- setlocale_failure = TRUE;
+ if (! (curcoll = setlocale(LC_COLLATE, "")))
+ setlocale_failure = TRUE;
#endif /* USE_LOCALE_COLLATE */
#ifdef USE_LOCALE_NUMERIC
- if (! (curnum = setlocale(LC_NUMERIC, "")))
- setlocale_failure = TRUE;
+ if (! (curnum = setlocale(LC_NUMERIC, "")))
+ setlocale_failure = TRUE;
#endif /* USE_LOCALE_NUMERIC */
-
-#endif /* LC_ALL */
-
-#endif /* !LOCALE_ENVIRON_REQUIRED */
+ }
if (setlocale_failure) {
char *p;
void
fbm_compile(SV *sv, U32 flags /* not used yet */)
{
- register unsigned char *s;
- register unsigned char *table;
+ register U8 *s;
+ register U8 *table;
register U32 i;
- register U32 len = SvCUR(sv);
+ STRLEN len;
I32 rarest = 0;
U32 frequency = 256;
- sv_upgrade(sv, SVt_PVBM);
+ s = (U8*)SvPV_force(sv, len);
+ (void)SvUPGRADE(sv, SVt_PVBM);
if (len > 255 || len == 0) /* TAIL might be on on a zero-length string. */
return; /* can't have offsets that big */
if (len > 2) {
s = (unsigned char*)(SvPVX(sv)); /* deeper magic */
for (i = 0; i < len; i++) {
- if (freq[s[i]] < frequency) {
+ if (PL_freq[s[i]] < frequency) {
rarest = i;
- frequency = freq[s[i]];
+ frequency = PL_freq[s[i]];
}
}
BmRARE(sv) = s[rarest];
if (!last) return (char *)(big+pos-previous);
found = 1;
}
- } while ( pos += screamnext[pos] );
+ } while ( pos += PL_screamnext[pos] );
return (last && found) ? (char *)(big+(*old_posp)-previous) : Nullch;
#else /* !POINTERRIGOR */
big -= previous;
register U8 *a = (U8 *)s1;
register U8 *b = (U8 *)s2;
while (len--) {
- if (*a != *b && *a != fold[*b])
+ if (*a != *b && *a != PL_fold[*b])
return 1;
a++,b++;
}
register U8 *a = (U8 *)s1;
register U8 *b = (U8 *)s2;
while (len--) {
- if (*a != *b && *a != fold_locale[*b])
+ if (*a != *b && *a != PL_fold_locale[*b])
return 1;
a++,b++;
}
STATIC SV *
mess_alloc(void)
{
+ dTHR;
SV *sv;
XPVMG *any;
+ if (!PL_dirty)
+ return sv_2mortal(newSVpvn("",0));
+
+ if (PL_mess_sv)
+ return PL_mess_sv;
+
/* Create as PVMG now, to avoid any upgrading later */
New(905, sv, 1, SV);
Newz(905, any, 1, XPVMG);
SvFLAGS(sv) = SVt_PVMG;
SvANY(sv) = (void*)any;
SvREFCNT(sv) = 1 << 30; /* practically infinite */
+ PL_mess_sv = sv;
return sv;
}
char *
form(const char* pat, ...)
{
+ SV *sv = mess_alloc();
va_list args;
va_start(args, pat);
- if (!PL_mess_sv)
- PL_mess_sv = mess_alloc();
- sv_vsetpvfn(PL_mess_sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
+ sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
va_end(args);
- return SvPVX(PL_mess_sv);
+ return SvPVX(sv);
}
char *
mess(const char *pat, va_list *args)
{
- SV *sv;
+ SV *sv = mess_alloc();
static char dgd[] = " during global destruction.\n";
- if (!PL_mess_sv)
- PL_mess_sv = mess_alloc();
- sv = PL_mess_sv;
sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
dTHR;
GV *gv;
CV *cv;
-#ifdef USE_THREADS
- DEBUG_L(PerlIO_printf(PerlIO_stderr(),
+ DEBUG_S(PerlIO_printf(PerlIO_stderr(),
"%p: die: curstack = %p, mainstack = %p\n",
- thr, curstack, mainstack));
-#endif /* USE_THREADS */
+ thr, PL_curstack, PL_mainstack));
va_start(args, pat);
message = pat ? mess(pat, &args) : Nullch;
va_end(args);
-#ifdef USE_THREADS
- DEBUG_L(PerlIO_printf(PerlIO_stderr(),
+ DEBUG_S(PerlIO_printf(PerlIO_stderr(),
"%p: die: message = %s\ndiehook = %p\n",
- thr, message, diehook));
-#endif /* USE_THREADS */
+ thr, message, PL_diehook));
if (PL_diehook) {
/* sv_2cv might call croak() */
SV *olddiehook = PL_diehook;
}
PL_restartop = die_where(message);
-#ifdef USE_THREADS
- DEBUG_L(PerlIO_printf(PerlIO_stderr(),
+ DEBUG_S(PerlIO_printf(PerlIO_stderr(),
"%p: die: restartop = %p, was_in_eval = %d, top_env = %p\n",
- thr, restartop, was_in_eval, top_env));
-#endif /* USE_THREADS */
+ thr, PL_restartop, was_in_eval, PL_top_env));
if ((!PL_restartop && was_in_eval) || PL_top_env->je_prev)
JMPENV_JUMP(3);
return PL_restartop;
va_start(args, pat);
message = mess(pat, &args);
va_end(args);
-#ifdef USE_THREADS
- DEBUG_L(PerlIO_printf(PerlIO_stderr(), "croak: 0x%lx %s", (unsigned long) thr, message));
-#endif /* USE_THREADS */
+ DEBUG_S(PerlIO_printf(PerlIO_stderr(), "croak: 0x%lx %s", (unsigned long) thr, message));
if (PL_diehook) {
/* sv_2cv might call croak() */
SV *olddiehook = PL_diehook;
(void)PerlIO_flush(PerlIO_stderr());
}
+void
+warner(U32 err, const char* pat,...)
+{
+ dTHR;
+ va_list args;
+ char *message;
+ HV *stash;
+ GV *gv;
+ CV *cv;
+
+ va_start(args, pat);
+ message = mess(pat, &args);
+ va_end(args);
+
+ if (ckDEAD(err)) {
+#ifdef USE_THREADS
+ DEBUG_S(PerlIO_printf(PerlIO_stderr(), "croak: 0x%lx %s", (unsigned long) thr, message));
+#endif /* USE_THREADS */
+ if (PL_diehook) {
+ /* sv_2cv might call croak() */
+ SV *olddiehook = PL_diehook;
+ ENTER;
+ SAVESPTR(PL_diehook);
+ PL_diehook = Nullsv;
+ cv = sv_2cv(olddiehook, &stash, &gv, 0);
+ LEAVE;
+ if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
+ dSP;
+ SV *msg;
+
+ ENTER;
+ msg = newSVpv(message, 0);
+ SvREADONLY_on(msg);
+ SAVEFREESV(msg);
+
+ PUSHMARK(sp);
+ XPUSHs(msg);
+ PUTBACK;
+ perl_call_sv((SV*)cv, G_DISCARD);
+
+ LEAVE;
+ }
+ }
+ if (PL_in_eval) {
+ PL_restartop = die_where(message);
+ JMPENV_JUMP(3);
+ }
+ PerlIO_puts(PerlIO_stderr(),message);
+ (void)PerlIO_flush(PerlIO_stderr());
+ my_failure_exit();
+
+ }
+ else {
+ if (PL_warnhook) {
+ /* sv_2cv might call warn() */
+ dTHR;
+ SV *oldwarnhook = PL_warnhook;
+ ENTER;
+ SAVESPTR(PL_warnhook);
+ PL_warnhook = Nullsv;
+ cv = sv_2cv(oldwarnhook, &stash, &gv, 0);
+ LEAVE;
+ if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
+ dSP;
+ SV *msg;
+
+ ENTER;
+ msg = newSVpv(message, 0);
+ SvREADONLY_on(msg);
+ SAVEFREESV(msg);
+
+ PUSHMARK(sp);
+ XPUSHs(msg);
+ PUTBACK;
+ perl_call_sv((SV*)cv, G_DISCARD);
+
+ LEAVE;
+ return;
+ }
+ }
+ PerlIO_puts(PerlIO_stderr(),message);
+#ifdef LEAKTEST
+ DEBUG_L(xstat());
+#endif
+ (void)PerlIO_flush(PerlIO_stderr());
+ }
+}
+
#ifndef VMS /* VMS' my_setenv() is in VMS.c */
#ifndef WIN32
void
#endif
/* VMS' my_popen() is in VMS.c, same with OS/2. */
-#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS)
+#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM)
PerlIO *
my_popen(char *cmd, char *mode)
{
#ifndef NOFILE
#define NOFILE 20
#endif
- for (fd = maxsysfd + 1; fd < NOFILE; fd++)
+ for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
PerlLIO_close(fd);
#endif
do_exec(cmd); /* may or may not use the shell */
#endif /* !HAS_SIGACTION */
/* VMS' my_pclose() is in VMS.c; same with OS/2 */
-#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS)
+#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM)
I32
my_pclose(PerlIO *ptr)
{
}
}
-#ifndef CASTNEGFLOAT
U32
-cast_ulong(f)
-double f;
+cast_ulong(double f)
{
long along;
return (unsigned long)along;
}
# undef BIGDOUBLE
-#endif
-
-#ifndef CASTI32
/* Unfortunately, on some systems the cast_uv() function doesn't
work with the system-supplied definition of ULONG_MAX. The
#endif
I32
-cast_i32(f)
-double f;
+cast_i32(double f)
{
if (f >= I32_MAX)
return (I32) I32_MAX;
}
IV
-cast_iv(f)
-double f;
+cast_iv(double f)
{
if (f >= IV_MAX)
return (IV) IV_MAX;
}
UV
-cast_uv(f)
-double f;
+cast_uv(double f)
{
if (f >= MY_UV_MAX)
return (UV) MY_UV_MAX;
return (UV) f;
}
-#endif
-
#ifndef HAS_RENAME
I32
-same_dirent(a,b)
-char *a;
-char *b;
+same_dirent(char *a, char *b)
{
char *fa = strrchr(a,'/');
char *fb = strrchr(b,'/');
retval = n | (*s++ - '0');
len--;
}
- if (PL_dowarn && len && (*s == '8' || *s == '9'))
- warn("Illegal octal digit ignored");
+ if (len && (*s == '8' || *s == '9')) {
+ dTHR;
+ if (ckWARN(WARN_OCTAL))
+ warner(WARN_OCTAL, "Illegal octal digit ignored");
+ }
*retlen = s - start;
return retval;
}
register UV retval = 0;
bool overflowed = FALSE;
char *tmp = s;
+ register UV n;
- while (len-- && *s && (tmp = strchr((char *) PL_hexdigit, *s))) {
- register UV n = retval << 4;
+ while (len-- && *s) {
+ tmp = strchr((char *) PL_hexdigit, *s++);
+ if (!tmp) {
+ if (*(s-1) == '_' || (*(s-1) == 'x' && retval == 0))
+ continue;
+ else {
+ dTHR;
+ --s;
+ if (ckWARN(WARN_UNSAFE))
+ warner(WARN_UNSAFE,"Illegal hex digit ignored");
+ break;
+ }
+ }
+ n = retval << 4;
if (!overflowed && (n >> 4) != retval) {
warn("Integer overflow in hex number");
overflowed = TRUE;
}
retval = n | ((tmp - PL_hexdigit) & 15);
- s++;
- }
- if (PL_dowarn && !tmp) {
- warn("Illegal hex digit ignored");
}
*retlen = s - start;
return retval;
dTHR;
char *xfound = Nullch;
char *xfailed = Nullch;
- char tmpbuf[512];
+ char tmpbuf[MAXPATHLEN];
register char *s;
I32 len;
int retval;
#endif
DEBUG_p(PerlIO_printf(Perl_debug_log,
"Looking for %s\n",cur));
- if (PerlLIO_stat(cur,&statbuf) >= 0) {
+ if (PerlLIO_stat(cur,&PL_statbuf) >= 0
+ && !S_ISDIR(PL_statbuf.st_mode)) {
dosearch = 0;
scriptname = cur;
#ifdef SEARCH_EXTS
#endif
DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
retval = PerlLIO_stat(tmpbuf,&PL_statbuf);
+ if (S_ISDIR(PL_statbuf.st_mode)) {
+ retval = -1;
+ }
#ifdef SEARCH_EXTS
} while ( retval < 0 /* not there */
&& extidx>=0 && ext[extidx] /* try an extension? */
xfailed = savepv(tmpbuf);
}
#ifndef DOSISH
- if (!xfound && !seen_dot && !xfailed && (PerlLIO_stat(scriptname,&PL_statbuf) < 0))
+ if (!xfound && !seen_dot && !xfailed &&
+ (PerlLIO_stat(scriptname,&PL_statbuf) < 0
+ || S_ISDIR(PL_statbuf.st_mode)))
#endif
seen_dot = 1; /* Disable message. */
if (!xfound) {
}
void
-perl_cond_init(cp)
-perl_cond *cp;
+perl_cond_init(perl_cond *cp)
{
*cp = 0;
}
void
-perl_cond_signal(cp)
-perl_cond *cp;
+perl_cond_signal(perl_cond *cp)
{
perl_os_thread t;
perl_cond cond = *cp;
}
void
-perl_cond_broadcast(cp)
-perl_cond *cp;
+perl_cond_broadcast(perl_cond *cp)
{
perl_os_thread t;
perl_cond cond, cond_next;
}
void
-perl_cond_wait(cp)
-perl_cond *cp;
+perl_cond_wait(perl_cond *cp)
{
perl_cond cond;
}
#endif /* FAKE_THREADS */
-#ifdef OLD_PTHREADS_API
+#ifdef PTHREAD_GETSPECIFIC_INT
struct perl_thread *
getTHR _((void))
{
pthread_addr_t t;
- if (pthread_getspecific(thr_key, &t))
+ if (pthread_getspecific(PL_thr_key, &t))
croak("panic: pthread_getspecific");
return (struct perl_thread *) t;
}
-#endif /* OLD_PTHREADS_API */
+#endif
MAGIC *
condpair_magic(SV *sv)
mg->mg_ptr = (char *)cp;
mg->mg_len = sizeof(cp);
UNLOCK_SV_MUTEX;
- DEBUG_L(WITH_THR(PerlIO_printf(PerlIO_stderr(),
+ DEBUG_S(WITH_THR(PerlIO_printf(PerlIO_stderr(),
"%p: condpair_magic %p\n", thr, sv));)
}
}
SvGROW(sv, sizeof(struct perl_thread) + 1);
SvCUR_set(sv, sizeof(struct perl_thread));
thr = (Thread) SvPVX(sv);
- /* debug */
+#ifdef DEBUGGING
memset(thr, 0xab, sizeof(struct perl_thread));
- markstack = 0;
- scopestack = 0;
- savestack = 0;
- retstack = 0;
- dirty = 0;
- localizing = 0;
- /* end debug */
+ PL_markstack = 0;
+ PL_scopestack = 0;
+ PL_savestack = 0;
+ PL_retstack = 0;
+ PL_dirty = 0;
+ PL_localizing = 0;
+ Zero(&PL_hv_fetch_ent_mh, 1, HE);
+#else
+ Zero(thr, 1, struct perl_thread);
+#endif
thr->oursv = sv;
init_stacks(ARGS);
- curcop = &compiling;
+ PL_curcop = &PL_compiling;
thr->cvcache = newHV();
thr->threadsv = newAV();
thr->specific = newAV();
thr->flags = THRf_R_JOINABLE;
MUTEX_INIT(&thr->mutex);
- curcop = t->Tcurcop; /* XXX As good a guess as any? */
- defstash = t->Tdefstash; /* XXX maybe these should */
- curstash = t->Tcurstash; /* always be set to main? */
-
-
/* top_env needs to be non-zero. It points to an area
in which longjmp() stuff is stored, as C callstack
info there at least is thread specific this has to
See comments in scope.h
Initialize top entry (as in perl.c for main thread)
*/
- start_env.je_prev = NULL;
- start_env.je_ret = -1;
- start_env.je_mustcatch = TRUE;
- top_env = &start_env;
-
- in_eval = FALSE;
- restartop = 0;
-
- tainted = t->Ttainted;
- curpm = t->Tcurpm; /* XXX No PMOP ref count */
- nrs = newSVsv(t->Tnrs);
- rs = SvREFCNT_inc(nrs);
- last_in_gv = (GV*)SvREFCNT_inc(t->Tlast_in_gv);
- ofslen = t->Tofslen;
- ofs = savepvn(t->Tofs, ofslen);
- defoutgv = (GV*)SvREFCNT_inc(t->Tdefoutgv);
- chopset = t->Tchopset;
- formtarget = newSVsv(t->Tformtarget);
- bodytarget = newSVsv(t->Tbodytarget);
- toptarget = newSVsv(t->Ttoptarget);
-
- statname = NEWSV(66,0);
- maxscream = -1;
- regcompp = FUNC_NAME_TO_PTR(pregcomp);
- regexecp = FUNC_NAME_TO_PTR(regexec_flags);
- regindent = 0;
- reginterp_cnt = 0;
- lastscream = Nullsv;
- screamfirst = 0;
- screamnext = 0;
- reg_start_tmp = 0;
- reg_start_tmpl = 0;
-
+ PL_start_env.je_prev = NULL;
+ PL_start_env.je_ret = -1;
+ PL_start_env.je_mustcatch = TRUE;
+ PL_top_env = &PL_start_env;
+
+ PL_in_eval = FALSE;
+ PL_restartop = 0;
+
+ PL_statname = NEWSV(66,0);
+ PL_maxscream = -1;
+ PL_regcompp = FUNC_NAME_TO_PTR(pregcomp);
+ PL_regexecp = FUNC_NAME_TO_PTR(regexec_flags);
+ PL_regindent = 0;
+ PL_reginterp_cnt = 0;
+ PL_lastscream = Nullsv;
+ PL_screamfirst = 0;
+ PL_screamnext = 0;
+ PL_reg_start_tmp = 0;
+ PL_reg_start_tmpl = 0;
+
+ /* parent thread's data needs to be locked while we make copy */
+ MUTEX_LOCK(&t->mutex);
+
+ PL_curcop = t->Tcurcop; /* XXX As good a guess as any? */
+ PL_defstash = t->Tdefstash; /* XXX maybe these should */
+ PL_curstash = t->Tcurstash; /* always be set to main? */
+
+ PL_tainted = t->Ttainted;
+ PL_curpm = t->Tcurpm; /* XXX No PMOP ref count */
+ PL_nrs = newSVsv(t->Tnrs);
+ PL_rs = SvREFCNT_inc(PL_nrs);
+ PL_last_in_gv = Nullgv;
+ PL_ofslen = t->Tofslen;
+ PL_ofs = savepvn(t->Tofs, PL_ofslen);
+ PL_defoutgv = (GV*)SvREFCNT_inc(t->Tdefoutgv);
+ PL_chopset = t->Tchopset;
+ PL_formtarget = newSVsv(t->Tformtarget);
+ PL_bodytarget = newSVsv(t->Tbodytarget);
+ PL_toptarget = newSVsv(t->Ttoptarget);
+
/* Initialise all per-thread SVs that the template thread used */
svp = AvARRAY(t->threadsv);
for (i = 0; i <= AvFILLp(t->threadsv); i++, svp++) {
- if (*svp && *svp != &sv_undef) {
+ if (*svp && *svp != &PL_sv_undef) {
SV *sv = newSVsv(*svp);
av_store(thr->threadsv, i, sv);
- sv_magic(sv, 0, 0, &threadsv_names[i], 1);
- DEBUG_L(PerlIO_printf(PerlIO_stderr(),
+ sv_magic(sv, 0, 0, &PL_threadsv_names[i], 1);
+ DEBUG_S(PerlIO_printf(PerlIO_stderr(),
"new_struct_thread: copied threadsv %d %p->%p\n",i, t, thr));
}
}
thr->threadsvp = AvARRAY(thr->threadsv);
- MUTEX_LOCK(&threads_mutex);
- nthreads++;
- thr->tid = ++threadnum;
+ MUTEX_LOCK(&PL_threads_mutex);
+ PL_nthreads++;
+ thr->tid = ++PL_threadnum;
thr->next = t->next;
thr->prev = t;
t->next = thr;
thr->next->prev = thr;
- MUTEX_UNLOCK(&threads_mutex);
+ MUTEX_UNLOCK(&PL_threads_mutex);
+
+ /* done copying parent's state */
+ MUTEX_UNLOCK(&t->mutex);
#ifdef HAVE_THREAD_INTERN
init_thread_intern(thr);
struct perl_vars *
Perl_GetVars(void)
{
- return &Perl_Vars;
+ return &PL_Vars;
}
#endif
char **
get_op_names(void)
{
- return op_name;
+ return PL_op_name;
}
char **
get_op_descs(void)
{
- return op_desc;
+ return PL_op_desc;
}
char *
get_no_modify(void)
{
- return (char*)no_modify;
+ return (char*)PL_no_modify;
}
U32 *
get_opargs(void)
{
- return opargs;
+ return PL_opargs;
}
-
SV **
get_specialsv_list(void)
{
return PL_specialsv_list;
}
+
+
+MGVTBL*
+get_vtbl(int vtbl_id)
+{
+ MGVTBL* result = Null(MGVTBL*);
+
+ switch(vtbl_id) {
+ case want_vtbl_sv:
+ result = &PL_vtbl_sv;
+ break;
+ case want_vtbl_env:
+ result = &PL_vtbl_env;
+ break;
+ case want_vtbl_envelem:
+ result = &PL_vtbl_envelem;
+ break;
+ case want_vtbl_sig:
+ result = &PL_vtbl_sig;
+ break;
+ case want_vtbl_sigelem:
+ result = &PL_vtbl_sigelem;
+ break;
+ case want_vtbl_pack:
+ result = &PL_vtbl_pack;
+ break;
+ case want_vtbl_packelem:
+ result = &PL_vtbl_packelem;
+ break;
+ case want_vtbl_dbline:
+ result = &PL_vtbl_dbline;
+ break;
+ case want_vtbl_isa:
+ result = &PL_vtbl_isa;
+ break;
+ case want_vtbl_isaelem:
+ result = &PL_vtbl_isaelem;
+ break;
+ case want_vtbl_arylen:
+ result = &PL_vtbl_arylen;
+ break;
+ case want_vtbl_glob:
+ result = &PL_vtbl_glob;
+ break;
+ case want_vtbl_mglob:
+ result = &PL_vtbl_mglob;
+ break;
+ case want_vtbl_nkeys:
+ result = &PL_vtbl_nkeys;
+ break;
+ case want_vtbl_taint:
+ result = &PL_vtbl_taint;
+ break;
+ case want_vtbl_substr:
+ result = &PL_vtbl_substr;
+ break;
+ case want_vtbl_vec:
+ result = &PL_vtbl_vec;
+ break;
+ case want_vtbl_pos:
+ result = &PL_vtbl_pos;
+ break;
+ case want_vtbl_bm:
+ result = &PL_vtbl_bm;
+ break;
+ case want_vtbl_fm:
+ result = &PL_vtbl_fm;
+ break;
+ case want_vtbl_uvar:
+ result = &PL_vtbl_uvar;
+ break;
+#ifdef USE_THREADS
+ case want_vtbl_mutex:
+ result = &PL_vtbl_mutex;
+ break;
+#endif
+ case want_vtbl_defelem:
+ result = &PL_vtbl_defelem;
+ break;
+ case want_vtbl_regexp:
+ result = &PL_vtbl_regexp;
+ break;
+ case want_vtbl_regdata:
+ result = &PL_vtbl_regdata;
+ break;
+ case want_vtbl_regdatum:
+ result = &PL_vtbl_regdatum;
+ break;
+ case want_vtbl_collxfrm:
+ result = &PL_vtbl_collxfrm;
+ break;
+ case want_vtbl_amagic:
+ result = &PL_vtbl_amagic;
+ break;
+ case want_vtbl_amagicelem:
+ result = &PL_vtbl_amagicelem;
+ break;
+ }
+ return result;
+}
+
projects / p5sagit/p5-mst-13.2.git / blobdiff