X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=util.c;h=4698e901d09bf114d01ab750a463011e844c4cf3;hb=3836fe67c982a853016f3715017e513c5664fac3;hp=eb51151cb50aedd77e10b60c6a063e0a692ebafe;hpb=84486fc677f94d602e0c12e9f6669da65cedcb13;p=p5sagit%2Fp5-mst-13.2.git diff --git a/util.c b/util.c index eb51151..4698e90 100644 --- a/util.c +++ b/util.c @@ -88,16 +88,16 @@ safemalloc(MEM_SIZE size) #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; } @@ -136,22 +136,22 @@ saferealloc(Malloc_t where,MEM_SIZE size) #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; } @@ -164,9 +164,9 @@ Free_t safefree(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*/ @@ -195,18 +195,18 @@ safecalloc(MEM_SIZE count, MEM_SIZE size) 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; } @@ -486,11 +486,11 @@ perl_new_ctype(char *newctype) 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 */ @@ -505,22 +505,22 @@ perl_new_collate(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'). */ @@ -532,8 +532,8 @@ perl_new_collate(char *newcoll) 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; } } @@ -549,20 +549,20 @@ perl_new_numeric(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 */ @@ -573,10 +573,10 @@ perl_set_numeric_standard(void) { #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 */ @@ -587,10 +587,10 @@ perl_set_numeric_local(void) { #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 */ @@ -853,13 +853,13 @@ mem_collxfrm(const char *s, STRLEN len, STRLEN *xlen) /* 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; @@ -883,7 +883,7 @@ mem_collxfrm(const char *s, STRLEN len, STRLEN *xlen) } xbuf[xout] = '\0'; - *xlen = xout - sizeof(collation_ix); + *xlen = xout - sizeof(PL_collation_ix); return xbuf; bad: @@ -897,14 +897,15 @@ mem_collxfrm(const char *s, STRLEN len, STRLEN *xlen) 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) { @@ -927,9 +928,9 @@ fbm_compile(SV *sv, U32 flags /* not used yet */) 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]; @@ -938,7 +939,7 @@ fbm_compile(SV *sv, U32 flags /* not used yet */) } char * -fbm_instr(unsigned char *big, register unsigned char *bigend, SV *littlestr) +fbm_instr(unsigned char *big, register unsigned char *bigend, SV *littlestr, U32 flags) { register unsigned char *s; register I32 tmp; @@ -954,7 +955,7 @@ fbm_instr(unsigned char *big, register unsigned char *bigend, SV *littlestr) 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))) { @@ -972,7 +973,7 @@ fbm_instr(unsigned char *big, register unsigned char *bigend, SV *littlestr) } 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); @@ -1062,6 +1063,7 @@ fbm_instr(unsigned char *big, register unsigned char *bigend, SV *littlestr) char * screaminstr(SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last) { + dTHR; register unsigned char *s, *x; register unsigned char *big; register I32 pos; @@ -1073,8 +1075,8 @@ screaminstr(SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_ 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); @@ -1086,12 +1088,12 @@ screaminstr(SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_ 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 do { - if (pos >= stop_pos) return Nullch; + if (pos >= stop_pos) break; if (big[pos-previous] != first) continue; for (x=big+pos+1-previous,s=little; s < littleend; /**/ ) { @@ -1105,12 +1107,12 @@ screaminstr(SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_ 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; do { - if (pos >= stop_pos) return Nullch; + if (pos >= stop_pos) break; if (big[pos] != first) continue; for (x=big+pos+1,s=little; s < littleend; /**/ ) { @@ -1124,7 +1126,7 @@ screaminstr(SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_ 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 */ } @@ -1135,7 +1137,7 @@ ibcmp(char *s1, 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++; } @@ -1148,7 +1150,7 @@ ibcmp_locale(char *s1, 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++; } @@ -1202,11 +1204,11 @@ form(const char* pat, ...) { 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*)); + if (!PL_mess_sv) + PL_mess_sv = mess_alloc(); + sv_vsetpvfn(PL_mess_sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); va_end(args); - return SvPVX(mess_sv); + return SvPVX(PL_mess_sv); } char * @@ -1215,25 +1217,25 @@ mess(const char *pat, va_list *args) SV *sv; static char dgd[] = " during global destruction.\n"; - if (!mess_sv) - mess_sv = mess_alloc(); - sv = mess_sv; + 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; - 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"); } @@ -1247,32 +1249,28 @@ die(const char* pat, ...) 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))) { @@ -1289,25 +1287,23 @@ die(const char* pat, ...) msg = ERRSV; } - PUSHSTACK(SI_DIEHOOK); + PUSHSTACKi(PERLSI_DIEHOOK); PUSHMARK(SP); XPUSHs(msg); PUTBACK; perl_call_sv((SV*)cv, G_DISCARD); - POPSTACK(); + POPSTACK; LEAVE; } } - 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 @@ -1323,15 +1319,13 @@ croak(const char* pat, ...) 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))) { @@ -1343,17 +1337,17 @@ croak(const char* pat, ...) SvREADONLY_on(msg); SAVEFREESV(msg); - PUSHSTACK(SI_DIEHOOK); + PUSHSTACKi(PERLSI_DIEHOOK); PUSHMARK(SP); XPUSHs(msg); PUTBACK; perl_call_sv((SV*)cv, G_DISCARD); - POPSTACK(); + POPSTACK; 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); @@ -1374,13 +1368,13 @@ warn(const char* pat,...) 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))) { @@ -1392,12 +1386,12 @@ warn(const char* pat,...) SvREADONLY_on(msg); SAVEFREESV(msg); - PUSHSTACK(SI_WARNHOOK); + PUSHSTACKi(PERLSI_WARNHOOK); PUSHMARK(SP); XPUSHs(msg); PUTBACK; perl_call_sv((SV*)cv, G_DISCARD); - POPSTACK(); + POPSTACK; LEAVE; return; } @@ -1414,6 +1408,94 @@ warn(const char* pat,...) (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 @@ -1421,7 +1503,7 @@ my_setenv(char *nam, char *val) { 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; @@ -1796,7 +1878,7 @@ VTOH(vtohl,long) #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) { @@ -1813,7 +1895,7 @@ 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"); } @@ -1847,7 +1929,7 @@ 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 */ @@ -1856,8 +1938,8 @@ my_popen(char *cmd, char *mode) /*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 @@ -1869,10 +1951,10 @@ my_popen(char *cmd, char *mode) 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 @@ -1957,6 +2039,10 @@ rsignal(int signo, Sighandler_t handler) #ifdef SA_RESTART act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */ #endif +#ifdef SA_NOCLDWAIT + if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN) + act.sa_flags |= SA_NOCLDWAIT; +#endif if (sigaction(signo, &act, &oact) == -1) return SIG_ERR; else @@ -1985,6 +2071,10 @@ rsignal_save(int signo, Sighandler_t handler, Sigsave_t *save) #ifdef SA_RESTART act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */ #endif +#ifdef SA_NOCLDWAIT + if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN) + act.sa_flags |= SA_NOCLDWAIT; +#endif return sigaction(signo, &act, save); } @@ -2040,7 +2130,7 @@ rsignal_restore(int signo, Sigsave_t *save) #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) { @@ -2058,10 +2148,10 @@ 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); @@ -2108,23 +2198,23 @@ wait4pid(int pid, int *statusp, int flags) 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; } } @@ -2164,7 +2254,7 @@ pidgone(int pid, int status) 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; @@ -2210,10 +2300,8 @@ repeatcpy(register char *to, register char *from, I32 len, register I32 count) } } -#ifndef CASTNEGFLOAT U32 -cast_ulong(f) -double f; +cast_ulong(double f) { long along; @@ -2228,9 +2316,6 @@ double f; 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 @@ -2253,8 +2338,7 @@ double f; #endif I32 -cast_i32(f) -double f; +cast_i32(double f) { if (f >= I32_MAX) return (I32) I32_MAX; @@ -2264,8 +2348,7 @@ double f; } IV -cast_iv(f) -double f; +cast_iv(double f) { if (f >= IV_MAX) return (IV) IV_MAX; @@ -2275,21 +2358,16 @@ double f; } 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,'/'); @@ -2340,8 +2418,11 @@ scan_oct(char *start, I32 len, I32 *retlen) 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; } @@ -2353,18 +2434,27 @@ scan_hex(char *start, I32 len, I32 *retlen) 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; @@ -2468,7 +2558,8 @@ find_script(char *scriptname, bool dosearch, char **search_ext, I32 flags) #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 @@ -2495,8 +2586,8 @@ find_script(char *scriptname, bool dosearch, char **search_ext, I32 flags) && (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 @@ -2509,11 +2600,11 @@ find_script(char *scriptname, bool dosearch, char **search_ext, I32 flags) 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 */ @@ -2536,7 +2627,10 @@ find_script(char *scriptname, bool dosearch, char **search_ext, I32 flags) 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? */ @@ -2545,10 +2639,10 @@ find_script(char *scriptname, bool dosearch, char **search_ext, I32 flags) #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 ) { @@ -2559,21 +2653,26 @@ find_script(char *scriptname, bool dosearch, char **search_ext, I32 flags) 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) - scriptname = NULL; -/* croak("Can't %s %s%s%s", - (xfailed ? "execute" : "find"), - (xfailed ? xfailed : scriptname), - (xfailed ? "" : " on PATH"), - (xfailed || seen_dot) ? "" : ", '.' not in PATH"); */ + if (!xfound) { + if (flags & 1) { /* do or die? */ + croak("Can't %s %s%s%s", + (xfailed ? "execute" : "find"), + (xfailed ? xfailed : scriptname), + (xfailed ? "" : " on PATH"), + (xfailed || seen_dot) ? "" : ", '.' not in PATH"); + } + scriptname = Nullch; + } if (xfailed) Safefree(xfailed); scriptname = xfound; } - return scriptname; + return (scriptname ? savepv(scriptname) : Nullch); } @@ -2587,15 +2686,13 @@ schedule(void) } 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; @@ -2615,8 +2712,7 @@ perl_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; @@ -2637,8 +2733,7 @@ perl_cond *cp; } void -perl_cond_wait(cp) -perl_cond *cp; +perl_cond_wait(perl_cond *cp) { perl_cond cond; @@ -2656,17 +2751,17 @@ perl_cond *cp; } #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) @@ -2699,7 +2794,7 @@ 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));) } } @@ -2725,20 +2820,23 @@ new_struct_thread(struct perl_thread *t) 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(); @@ -2747,9 +2845,9 @@ new_struct_thread(struct perl_thread *t) 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? */ + 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? */ /* top_env needs to be non-zero. It points to an area @@ -2760,48 +2858,60 @@ new_struct_thread(struct perl_thread *t) 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); + 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_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); + + 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; /* 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); #ifdef HAVE_THREAD_INTERN init_thread_intern(thr); @@ -2827,37 +2937,137 @@ Perl_huge(void) 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; + 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; } +