#endif
-#ifndef MYMALLOC
-
-/* paranoid version of malloc */
+/* paranoid version of system's malloc() */
/* NOTE: Do not call the next three routines directly. Use the macros
* in handy.h, so that we can easily redefine everything to do tracking of
*/
Malloc_t
-safemalloc(MEM_SIZE size)
+safesysmalloc(MEM_SIZE size)
{
Malloc_t ptr;
#ifdef HAS_64K_LIMIT
#endif
ptr = PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */
#if !(defined(I286) || defined(atarist))
- DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%x: (%05d) malloc %ld bytes\n",ptr,an++,(long)size));
+ 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 (nomemok)
+ 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;
}
/*NOTREACHED*/
}
-/* paranoid version of realloc */
+/* paranoid version of system's realloc() */
Malloc_t
-saferealloc(Malloc_t where,MEM_SIZE size)
+safesysrealloc(Malloc_t where,MEM_SIZE size)
{
Malloc_t ptr;
#if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE)
}
#endif /* HAS_64K_LIMIT */
if (!size) {
- safefree(where);
+ safesysfree(where);
return NULL;
}
if (!where)
- return safemalloc(size);
+ return safesysmalloc(size);
#ifdef DEBUGGING
if ((long)size < 0)
croak("panic: realloc");
#if !(defined(I286) || defined(atarist))
DEBUG_m( {
- PerlIO_printf(Perl_debug_log, "0x%x: (%05d) rfree\n",where,an++);
- PerlIO_printf(Perl_debug_log, "0x%x: (%05d) realloc %ld bytes\n",ptr,an++,(long)size);
+ PerlIO_printf(Perl_debug_log, "0x%x: (%05d) rfree\n",where,PL_an++);
+ PerlIO_printf(Perl_debug_log, "0x%x: (%05d) realloc %ld bytes\n",ptr,PL_an++,(long)size);
} )
#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
if (ptr != Nullch)
return ptr;
- else if (nomemok)
+ 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;
}
/*NOTREACHED*/
}
-/* safe version of free */
+/* safe version of system's free() */
Free_t
-safefree(Malloc_t where)
+safesysfree(Malloc_t where)
{
#if !(defined(I286) || defined(atarist))
- DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%x: (%05d) free\n",(char *) where,an++));
+ 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*/
}
}
-/* safe version of calloc */
+/* safe version of system's calloc() */
Malloc_t
-safecalloc(MEM_SIZE count, MEM_SIZE size)
+safesyscalloc(MEM_SIZE count, MEM_SIZE size)
{
Malloc_t ptr;
size *= count;
ptr = PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */
#if !(defined(I286) || defined(atarist))
- DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%x: (%05d) calloc %ld x %ld bytes\n",ptr,an++,(long)count,(long)size));
+ 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);
return ptr;
}
- else if (nomemok)
+ 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;
}
/*NOTREACHED*/
}
-#endif /* !MYMALLOC */
-
#ifdef LEAKTEST
struct mem_test_strut {
/* This routine was donated by Corey Satten. */
char *
-instr(register char *big, register char *little)
+instr(register const char *big, register const char *little)
{
- register char *s, *x;
+ register const char *s, *x;
register I32 first;
if (!little)
- return big;
+ return (char*)big;
first = *little++;
if (!first)
- return big;
+ return (char*)big;
while (*big) {
if (*big++ != first)
continue;
}
}
if (!*s)
- return big-1;
+ return (char*)(big-1);
}
return Nullch;
}
/* same as instr but allow embedded nulls */
char *
-ninstr(register char *big, register char *bigend, char *little, char *lend)
+ninstr(register const char *big, register const char *bigend, const char *little, const char *lend)
{
- register char *s, *x;
+ register const char *s, *x;
register I32 first = *little;
- register char *littleend = lend;
+ register const char *littleend = lend;
if (!first && little >= littleend)
- return big;
+ return (char*)big;
if (bigend - big < littleend - little)
return Nullch;
bigend -= littleend - little++;
}
}
if (s >= littleend)
- return big-1;
+ return (char*)(big-1);
}
return Nullch;
}
/* reverse of the above--find last substring */
char *
-rninstr(register char *big, char *bigend, char *little, char *lend)
+rninstr(register const char *big, const char *bigend, const char *little, const char *lend)
{
- register char *bigbeg;
- register char *s, *x;
+ register const char *bigbeg;
+ register const char *s, *x;
register I32 first = *little;
- register char *littleend = lend;
+ register const char *littleend = lend;
if (!first && little >= littleend)
- return bigend;
+ return (char*)bigend;
bigbeg = big;
big = bigend - (littleend - little++);
while (big >= bigbeg) {
}
}
if (s >= littleend)
- return big+1;
+ return (char*)(big+1);
}
return Nullch;
}
* Set up for a new ctype locale.
*/
void
-perl_new_ctype(char *newctype)
+perl_new_ctype(const char *newctype)
{
#ifdef USE_LOCALE_CTYPE
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 */
* Set up for a new collation locale.
*/
void
-perl_new_collate(char *newcoll)
+perl_new_collate(const char *newcoll)
{
#ifdef USE_LOCALE_COLLATE
if (! newcoll) {
- if (collation_name) {
- ++collation_ix;
- Safefree(collation_name);
- collation_name = NULL;
- collation_standard = TRUE;
- collxfrm_base = 0;
- collxfrm_mult = 2;
+ if (PL_collation_name) {
+ ++PL_collation_ix;
+ Safefree(PL_collation_name);
+ PL_collation_name = NULL;
+ PL_collation_standard = TRUE;
+ PL_collxfrm_base = 0;
+ PL_collxfrm_mult = 2;
}
return;
}
- if (! collation_name || strNE(collation_name, newcoll)) {
- ++collation_ix;
- Safefree(collation_name);
- collation_name = savepv(newcoll);
- collation_standard = (strEQ(newcoll, "C") || strEQ(newcoll, "POSIX"));
+ if (! PL_collation_name || strNE(PL_collation_name, newcoll)) {
+ ++PL_collation_ix;
+ Safefree(PL_collation_name);
+ PL_collation_name = savepv(newcoll);
+ PL_collation_standard = (strEQ(newcoll, "C") || strEQ(newcoll, "POSIX"));
{
/* 2: at most so many chars ('a', 'b'). */
SSize_t mult = fb - fa;
if (mult < 1)
croak("strxfrm() gets absurd");
- collxfrm_base = (fa > mult) ? (fa - mult) : 0;
- collxfrm_mult = mult;
+ PL_collxfrm_base = (fa > mult) ? (fa - mult) : 0;
+ PL_collxfrm_mult = mult;
}
}
* Set up for a new numeric locale.
*/
void
-perl_new_numeric(char *newnum)
+perl_new_numeric(const char *newnum)
{
#ifdef USE_LOCALE_NUMERIC
if (! newnum) {
- if (numeric_name) {
- Safefree(numeric_name);
- numeric_name = NULL;
- numeric_standard = TRUE;
- numeric_local = TRUE;
+ if (PL_numeric_name) {
+ Safefree(PL_numeric_name);
+ PL_numeric_name = NULL;
+ PL_numeric_standard = TRUE;
+ PL_numeric_local = TRUE;
}
return;
}
- if (! numeric_name || strNE(numeric_name, newnum)) {
- Safefree(numeric_name);
- numeric_name = savepv(newnum);
- numeric_standard = (strEQ(newnum, "C") || strEQ(newnum, "POSIX"));
- numeric_local = TRUE;
+ if (! PL_numeric_name || strNE(PL_numeric_name, newnum)) {
+ Safefree(PL_numeric_name);
+ PL_numeric_name = savepv(newnum);
+ PL_numeric_standard = (strEQ(newnum, "C") || strEQ(newnum, "POSIX"));
+ PL_numeric_local = TRUE;
}
#endif /* USE_LOCALE_NUMERIC */
{
#ifdef USE_LOCALE_NUMERIC
- if (! numeric_standard) {
+ if (! PL_numeric_standard) {
setlocale(LC_NUMERIC, "C");
- numeric_standard = TRUE;
- numeric_local = FALSE;
+ PL_numeric_standard = TRUE;
+ PL_numeric_local = FALSE;
}
#endif /* USE_LOCALE_NUMERIC */
{
#ifdef USE_LOCALE_NUMERIC
- if (! numeric_local) {
- setlocale(LC_NUMERIC, numeric_name);
- numeric_standard = FALSE;
- numeric_local = TRUE;
+ if (! PL_numeric_local) {
+ setlocale(LC_NUMERIC, PL_numeric_name);
+ PL_numeric_standard = FALSE;
+ PL_numeric_local = TRUE;
}
#endif /* USE_LOCALE_NUMERIC */
#ifdef USE_LOCALE_NUMERIC
char *curnum = NULL;
#endif /* USE_LOCALE_NUMERIC */
+#ifdef __GLIBC__
+ char *language = PerlEnv_getenv("LANGUAGE");
+#endif
char *lc_all = PerlEnv_getenv("LC_ALL");
char *lang = PerlEnv_getenv("LANG");
bool setlocale_failure = FALSE;
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;
PerlIO_printf(PerlIO_stderr(),
"perl: warning: Please check that your locale settings:\n");
+#ifdef __GLIBC__
+ PerlIO_printf(PerlIO_stderr(),
+ "\tLANGUAGE = %c%s%c,\n",
+ language ? '"' : '(',
+ language ? language : "unset",
+ language ? '"' : ')');
+#endif
+
PerlIO_printf(PerlIO_stderr(),
"\tLC_ALL = %c%s%c,\n",
lc_all ? '"' : '(',
/* the first sizeof(collationix) bytes are used by sv_collxfrm(). */
/* the +1 is for the terminating NUL. */
- xAlloc = sizeof(collation_ix) + collxfrm_base + (collxfrm_mult * len) + 1;
+ xAlloc = sizeof(PL_collation_ix) + PL_collxfrm_base + (PL_collxfrm_mult * len) + 1;
New(171, xbuf, xAlloc, char);
if (! xbuf)
goto bad;
- *(U32*)xbuf = collation_ix;
- xout = sizeof(collation_ix);
+ *(U32*)xbuf = PL_collation_ix;
+ xout = sizeof(PL_collation_ix);
for (xin = 0; xin < len; ) {
SSize_t xused;
}
xbuf[xout] = '\0';
- *xlen = xout - sizeof(collation_ix);
+ *xlen = xout - sizeof(PL_collation_ix);
return xbuf;
bad:
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 (!len) {
if (SvTAIL(littlestr)) { /* Can be only 0-len constant
substr => we can ignore SvVALID */
- if (multiline) {
+ if (PL_multiline) {
char *t = "\n";
if ((s = (unsigned char*)ninstr((char*)big, (char*)bigend,
t, t + len))) {
}
littlelen = SvCUR(littlestr);
- if (SvTAIL(littlestr) && !multiline) { /* tail anchored? */
+ if (SvTAIL(littlestr) && !PL_multiline) { /* tail anchored? */
if (littlelen > bigend - big)
return Nullch;
little = (unsigned char*)SvPVX(littlestr);
I32 found = 0;
if (*old_posp == -1
- ? (pos = screamfirst[BmRARE(littlestr)]) < 0
- : (((pos = *old_posp), pos += screamnext[pos]) == 0))
+ ? (pos = PL_screamfirst[BmRARE(littlestr)]) < 0
+ : (((pos = *old_posp), pos += PL_screamnext[pos]) == 0))
return Nullch;
little = (unsigned char *)(SvPVX(littlestr));
littleend = little + SvCUR(littlestr);
stop_pos = SvCUR(bigstr) - end_shift - (SvCUR(littlestr) - 1 - previous);
if (previous + start_shift > stop_pos) return Nullch;
while (pos < previous + start_shift) {
- if (!(pos += screamnext[pos]))
+ if (!(pos += PL_screamnext[pos]))
return Nullch;
}
#ifdef POINTERRIGOR
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;
if (!last) return (char *)(big+pos);
found = 1;
}
- } while ( pos += screamnext[pos] );
+ } while ( pos += PL_screamnext[pos] );
return (last && found) ? (char *)(big+(*old_posp)) : Nullch;
#endif /* POINTERRIGOR */
}
I32
-ibcmp(char *s1, char *s2, register I32 len)
+ibcmp(const char *s1, const char *s2, register I32 len)
{
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++;
}
}
I32
-ibcmp_locale(char *s1, char *s2, register I32 len)
+ibcmp_locale(const char *s1, const char *s2, register I32 len)
{
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++;
}
/* copy a string to a safe spot */
char *
-savepv(char *sv)
+savepv(const char *sv)
{
register char *newaddr;
/* same thing but with a known length */
char *
-savepvn(char *sv, register I32 len)
+savepvn(const char *sv, register I32 len)
{
register char *newaddr;
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 (!mess_sv)
- mess_sv = mess_alloc();
- sv_vsetpvfn(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(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 (!mess_sv)
- mess_sv = mess_alloc();
- sv = mess_sv;
sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
dTHR;
- if (dirty)
+ if (PL_dirty)
sv_catpv(sv, dgd);
else {
- if (curcop->cop_line)
+ if (PL_curcop->cop_line)
sv_catpvf(sv, " at %_ line %ld",
- GvSV(curcop->cop_filegv), (long)curcop->cop_line);
- if (GvIO(last_in_gv) && IoLINES(GvIOp(last_in_gv))) {
- bool line_mode = (RsSIMPLE(rs) &&
- SvLEN(rs) == 1 && *SvPVX(rs) == '\n');
+ GvSV(PL_curcop->cop_filegv), (long)PL_curcop->cop_line);
+ if (GvIO(PL_last_in_gv) && IoLINES(GvIOp(PL_last_in_gv))) {
+ bool line_mode = (RsSIMPLE(PL_rs) &&
+ SvLEN(PL_rs) == 1 && *SvPVX(PL_rs) == '\n');
sv_catpvf(sv, ", <%s> %s %ld",
- last_in_gv == argvgv ? "" : GvNAME(last_in_gv),
+ PL_last_in_gv == PL_argvgv ? "" : GvNAME(PL_last_in_gv),
line_mode ? "line" : "chunk",
- (long)IoLINES(GvIOp(last_in_gv)));
+ (long)IoLINES(GvIOp(PL_last_in_gv)));
}
sv_catpv(sv, ".\n");
}
dTHR;
va_list args;
char *message;
- int was_in_eval = in_eval;
+ int was_in_eval = PL_in_eval;
HV *stash;
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 */
- if (diehook) {
+ thr, message, PL_diehook));
+ if (PL_diehook) {
/* sv_2cv might call croak() */
- SV *olddiehook = diehook;
+ SV *olddiehook = PL_diehook;
ENTER;
- SAVESPTR(diehook);
- diehook = Nullsv;
+ SAVESPTR(PL_diehook);
+ PL_diehook = Nullsv;
cv = sv_2cv(olddiehook, &stash, &gv, 0);
LEAVE;
if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
}
}
- restartop = die_where(message);
-#ifdef USE_THREADS
- DEBUG_L(PerlIO_printf(PerlIO_stderr(),
+ PL_restartop = die_where(message);
+ 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 */
- if ((!restartop && was_in_eval) || top_env->je_prev)
+ thr, PL_restartop, was_in_eval, PL_top_env));
+ if ((!PL_restartop && was_in_eval) || PL_top_env->je_prev)
JMPENV_JUMP(3);
- return restartop;
+ return PL_restartop;
}
void
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 */
- if (diehook) {
+ DEBUG_S(PerlIO_printf(PerlIO_stderr(), "croak: 0x%lx %s", (unsigned long) thr, message));
+ if (PL_diehook) {
/* sv_2cv might call croak() */
- SV *olddiehook = diehook;
+ SV *olddiehook = PL_diehook;
ENTER;
- SAVESPTR(diehook);
- diehook = Nullsv;
+ SAVESPTR(PL_diehook);
+ PL_diehook = Nullsv;
cv = sv_2cv(olddiehook, &stash, &gv, 0);
LEAVE;
if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
LEAVE;
}
}
- if (in_eval) {
- restartop = die_where(message);
+ if (PL_in_eval) {
+ PL_restartop = die_where(message);
JMPENV_JUMP(3);
}
PerlIO_puts(PerlIO_stderr(),message);
message = mess(pat, &args);
va_end(args);
- if (warnhook) {
+ if (PL_warnhook) {
/* sv_2cv might call warn() */
dTHR;
- SV *oldwarnhook = warnhook;
+ SV *oldwarnhook = PL_warnhook;
ENTER;
- SAVESPTR(warnhook);
- warnhook = Nullsv;
+ SAVESPTR(PL_warnhook);
+ PL_warnhook = Nullsv;
cv = sv_2cv(oldwarnhook, &stash, &gv, 0);
LEAVE;
if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
(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
my_setenv(char *nam, char *val)
{
+#ifndef PERL_USE_SAFE_PUTENV
+ /* most putenv()s leak, so we manipulate environ directly */
register I32 i=setenv_getix(nam); /* where does it go? */
- if (environ == origenviron) { /* need we copy environment? */
+ if (environ == PL_origenviron) { /* need we copy environment? */
I32 j;
I32 max;
char **tmpenv;
/*SUPPRESS 530*/
for (max = i; environ[max]; max++) ;
- New(901,tmpenv, max+2, char*);
- for (j=0; j<max; j++) /* copy environment */
- tmpenv[j] = savepv(environ[j]);
+ tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*));
+ for (j=0; j<max; j++) { /* copy environment */
+ tmpenv[j] = (char*)safesysmalloc((strlen(environ[j])+1)*sizeof(char));
+ strcpy(tmpenv[j], environ[j]);
+ }
tmpenv[max] = Nullch;
environ = tmpenv; /* tell exec where it is now */
}
if (!val) {
- Safefree(environ[i]);
+ safesysfree(environ[i]);
while (environ[i]) {
environ[i] = environ[i+1];
i++;
return;
}
if (!environ[i]) { /* does not exist yet */
- Renew(environ, i+2, char*); /* just expand it a bit */
+ environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*));
environ[i+1] = Nullch; /* make sure it's null terminated */
}
else
- Safefree(environ[i]);
- New(904, environ[i], strlen(nam) + strlen(val) + 2, char);
+ safesysfree(environ[i]);
+ environ[i] = (char*)safesysmalloc((strlen(nam)+strlen(val)+2) * sizeof(char));
+
#ifndef MSDOS
(void)sprintf(environ[i],"%s=%s",nam,val);/* all that work just for this */
#else
strcpy(environ[i],nam); strupr(environ[i]);
(void)sprintf(environ[i] + strlen(nam),"=%s",val);
#endif /* MSDOS */
+
+#else /* PERL_USE_SAFE_PUTENV */
+ char *new_env;
+
+ new_env = (char*)safesysmalloc((strlen(nam) + strlen(val) + 2) * sizeof(char));
+#ifndef MSDOS
+ (void)sprintf(new_env,"%s=%s",nam,val);/* all that work just for this */
+#else
+ strcpy(new_env,nam); strupr(new_env);
+ (void)sprintf(new_env + strlen(nam),"=%s",val);
+#endif
+ (void)putenv(new_env);
+#endif /* PERL_USE_SAFE_PUTENV */
}
#else /* if WIN32 */
}
else
vallen = strlen(val);
- New(904, envstr, namlen + vallen + 3, char);
+ envstr = (char*)safesysmalloc((namlen + vallen + 3) * sizeof(char));
(void)sprintf(envstr,"%s=%s",nam,val);
(void)PerlEnv_putenv(envstr);
if (oldstr)
- Safefree(oldstr);
+ safesysfree(oldstr);
#ifdef _MSC_VER
- Safefree(envstr); /* MSVCRT leaks without this */
+ safesysfree(envstr); /* MSVCRT leaks without this */
#endif
#else /* !USE_WIN32_RTL_ENV */
- /* The sane way to deal with the environment.
- * Has these advantages over putenv() & co.:
- * * enables us to store a truly empty value in the
- * environment (like in UNIX).
- * * we don't have to deal with RTL globals, bugs and leaks.
- * * Much faster.
- * Why you may want to enable USE_WIN32_RTL_ENV:
- * * environ[] and RTL functions will not reflect changes,
- * which might be an issue if extensions want to access
- * the env. via RTL. This cuts both ways, since RTL will
- * not see changes made by extensions that call the Win32
- * functions directly, either.
- * GSAR 97-06-07
- */
- SetEnvironmentVariable(nam,val);
+ register char *envstr;
+ STRLEN len = strlen(nam) + 3;
+ if (!val) {
+ val = "";
+ }
+ len += strlen(val);
+ New(904, envstr, len, char);
+ (void)sprintf(envstr,"%s=%s",nam,val);
+ (void)PerlEnv_putenv(envstr);
+ Safefree(envstr);
#endif
}
#if !defined(HAS_BCOPY) || !defined(HAS_SAFE_BCOPY)
char *
-my_bcopy(register char *from,register char *to,register I32 len)
+my_bcopy(register const char *from,register char *to,register I32 len)
{
char *retval = to;
#ifndef HAS_MEMSET
void *
-my_memset(loc,ch,len)
-register char *loc;
-register I32 ch;
-register I32 len;
+my_memset(register char *loc, register I32 ch, register I32 len)
{
char *retval = loc;
#if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
char *
-my_bzero(loc,len)
-register char *loc;
-register I32 len;
+my_bzero(register char *loc, register I32 len)
{
char *retval = loc;
#if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
I32
-my_memcmp(s1,s2,len)
-char *s1;
-char *s2;
-register I32 len;
+my_memcmp(const char *s1, const char *s2, register I32 len)
{
register U8 *a = (U8 *)s1;
register U8 *b = (U8 *)s2;
#else
int
#endif
-vsprintf(dest, pat, args)
-char *dest;
-const char *pat;
-char *args;
+vsprintf(char *dest, const char *pat, char *args)
{
FILE fakebuf;
#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)
{
#endif
This = (*mode == 'w');
that = !This;
- if (doexec && tainting) {
+ if (doexec && PL_tainting) {
taint_env();
taint_proper("Insecure %s%s", "EXEC");
}
#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 */
/*SUPPRESS 560*/
if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
sv_setiv(GvSV(tmpgv), (IV)getpid());
- forkprocess = 0;
- hv_clear(pidstatus); /* we have no children */
+ PL_forkprocess = 0;
+ hv_clear(PL_pidstatus); /* we have no children */
return Nullfp;
#undef THIS
#undef THAT
PerlLIO_close(p[This]);
p[This] = p[that];
}
- sv = *av_fetch(fdpid,p[This],TRUE);
+ sv = *av_fetch(PL_fdpid,p[This],TRUE);
(void)SvUPGRADE(sv,SVt_IV);
SvIVX(sv) = pid;
- forkprocess = pid;
+ PL_forkprocess = pid;
return PerlIO_fdopen(p[This], mode);
}
#else
#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)
{
int saved_win32_errno;
#endif
- svp = av_fetch(fdpid,PerlIO_fileno(ptr),TRUE);
+ svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE);
pid = (int)SvIVX(*svp);
SvREFCNT_dec(*svp);
- *svp = &sv_undef;
+ *svp = &PL_sv_undef;
#ifdef OS2
if (pid == -1) { /* Opened by popen. */
return my_syspclose(ptr);
return -1;
if (pid > 0) {
sprintf(spid, "%d", pid);
- svp = hv_fetch(pidstatus,spid,strlen(spid),FALSE);
- if (svp && *svp != &sv_undef) {
+ svp = hv_fetch(PL_pidstatus,spid,strlen(spid),FALSE);
+ if (svp && *svp != &PL_sv_undef) {
*statusp = SvIVX(*svp);
- (void)hv_delete(pidstatus,spid,strlen(spid),G_DISCARD);
+ (void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD);
return pid;
}
}
else {
HE *entry;
- hv_iterinit(pidstatus);
- if (entry = hv_iternext(pidstatus)) {
+ hv_iterinit(PL_pidstatus);
+ if (entry = hv_iternext(PL_pidstatus)) {
pid = atoi(hv_iterkey(entry,(I32*)statusp));
- sv = hv_iterval(pidstatus,entry);
+ sv = hv_iterval(PL_pidstatus,entry);
*statusp = SvIVX(sv);
sprintf(spid, "%d", pid);
- (void)hv_delete(pidstatus,spid,strlen(spid),G_DISCARD);
+ (void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD);
return pid;
}
}
char spid[TYPE_CHARS(int)];
sprintf(spid, "%d", pid);
- sv = *hv_fetch(pidstatus,spid,strlen(spid),TRUE);
+ sv = *hv_fetch(PL_pidstatus,spid,strlen(spid),TRUE);
(void)SvUPGRADE(sv,SVt_IV);
SvIVX(sv) = status;
return;
#endif
void
-repeatcpy(register char *to, register char *from, I32 len, register I32 count)
+repeatcpy(register char *to, register const char *from, I32 len, register I32 count)
{
register I32 todo;
- register char *frombase = from;
+ register const char *frombase = from;
if (len == 1) {
- todo = *from;
+ register const char c = *from;
while (count-- > 0)
- *to++ = todo;
+ *to++ = c;
return;
}
while (count-- > 0) {
}
}
-#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,'/');
#endif /* !HAS_RENAME */
UV
+scan_bin(char *start, I32 len, I32 *retlen)
+{
+ register char *s = start;
+ register UV retval = 0;
+ bool overflowed = FALSE;
+ while (len && *s >= '0' && *s <= '1') {
+ register UV n = retval << 1;
+ if (!overflowed && (n >> 1) != retval) {
+ warn("Integer overflow in binary number");
+ overflowed = TRUE;
+ }
+ retval = n | (*s++ - '0');
+ len--;
+ }
+ if (len && (*s >= '2' || *s <= '9')) {
+ dTHR;
+ if (ckWARN(WARN_UNSAFE))
+ warner(WARN_UNSAFE, "Illegal binary digit ignored");
+ }
+ *retlen = s - start;
+ return retval;
+}
+UV
scan_oct(char *start, I32 len, I32 *retlen)
{
register char *s = start;
retval = n | (*s++ - '0');
len--;
}
- if (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 *) 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 - hexdigit) & 15);
- s++;
- }
- if (dowarn && !tmp) {
- warn("Illegal hex digit ignored");
+ retval = n | ((tmp - PL_hexdigit) & 15);
}
*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
&& (s = PerlEnv_getenv("PATH"))) {
bool seen_dot = 0;
- bufend = s + strlen(s);
- while (s < bufend) {
+ PL_bufend = s + strlen(s);
+ while (s < PL_bufend) {
#if defined(atarist) || defined(DOSISH)
for (len = 0; *s
# ifdef atarist
if (len < sizeof tmpbuf)
tmpbuf[len] = '\0';
#else /* ! (atarist || DOSISH) */
- s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend,
+ s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
':',
&len);
#endif /* ! (atarist || DOSISH) */
- if (s < bufend)
+ if (s < PL_bufend)
s++;
if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
continue; /* don't search dir with too-long name */
if (len
-#if defined(atarist) || defined(DOSISH)
+#if defined(atarist) || defined(__MINT__) || defined(DOSISH)
&& tmpbuf[len - 1] != '/'
&& tmpbuf[len - 1] != '\\'
#endif
do {
#endif
DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
- retval = PerlLIO_stat(tmpbuf,&statbuf);
+ 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? */
#endif
if (retval < 0)
continue;
- if (S_ISREG(statbuf.st_mode)
- && cando(S_IRUSR,TRUE,&statbuf)
+ if (S_ISREG(PL_statbuf.st_mode)
+ && cando(S_IRUSR,TRUE,&PL_statbuf)
#ifndef DOSISH
- && cando(S_IXUSR,TRUE,&statbuf)
+ && cando(S_IXUSR,TRUE,&PL_statbuf)
#endif
)
{
xfailed = savepv(tmpbuf);
}
#ifndef DOSISH
- if (!xfound && !seen_dot && !xfailed && (PerlLIO_stat(scriptname,&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 = newSVsv(t->Trs);
- 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;
-
+ 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 specialsv_list;
+ 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;
+#ifdef USE_LOCALE_COLLATE
+ case want_vtbl_collxfrm:
+ result = &PL_vtbl_collxfrm;
+ break;
+#endif
+ case want_vtbl_amagic:
+ result = &PL_vtbl_amagic;
+ break;
+ case want_vtbl_amagicelem:
+ result = &PL_vtbl_amagicelem;
+ break;
+ }
+ return result;
}
+
https://perl5.git.perl.org / perl5.git / blobdiff