X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=util.c;h=fe88f234142f39f42539896a0558d7efc92c96f4;hb=240a5ecf567cf5d54bbf1144872c0b74f2a322b7;hp=cc09a64179a8ae81a2b1e98de2d1454a601ccad5;hpb=cd39f2b66bd181466dfcec205891c8c477478488;p=p5sagit%2Fp5-mst-13.2.git diff --git a/util.c b/util.c index cc09a64..fe88f23 100644 --- a/util.c +++ b/util.c @@ -1,6 +1,6 @@ /* util.c * - * Copyright (c) 1991-1999, Larry Wall + * Copyright (c) 1991-2000, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -16,6 +16,7 @@ #define PERL_IN_UTIL_C #include "perl.h" +#ifndef PERL_MICRO #if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX) #include #endif @@ -23,6 +24,7 @@ #ifndef SIG_ERR # define SIG_ERR ((Sighandler_t) -1) #endif +#endif /* XXX If this causes problems, set i_unistd=undef in the hint file. */ #ifdef I_UNISTD @@ -40,13 +42,6 @@ # define vfork fork #endif -#ifdef I_FCNTL -# include -#endif -#ifdef I_SYS_FILE -# include -#endif - #ifdef I_SYS_WAIT # include #endif @@ -78,11 +73,6 @@ long lastxycount[MAXXCOUNT][MAXYCOUNT]; * XXX This advice seems to be widely ignored :-( --AD August 1996. */ -#ifdef MACOS_TRADITIONAL -extern void * gSacrificialGoat; -#define MAC_CHECK_GOAT(p) if (!gSacrificialGoat && p) { PerlMem_free(p); p = NULL; } else -#endif - Malloc_t Perl_safesysmalloc(MEM_SIZE size) { @@ -99,11 +89,9 @@ Perl_safesysmalloc(MEM_SIZE size) if ((long)size < 0) Perl_croak_nocontext("panic: malloc"); #endif - ptr = PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */ -#ifdef MACOS_TRADITIONAL - MAC_CHECK_GOAT(ptr); -#endif - DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05d) malloc %ld bytes\n",PTR2UV(ptr),PL_an++,(long)size)); + ptr = (Malloc_t)PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */ + PERL_ALLOC_CHECK(ptr); + DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size)); if (ptr != Nullch) return ptr; else if (PL_nomemok) @@ -123,7 +111,7 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size) { dTHX; Malloc_t ptr; -#if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) +#if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) && !defined(PERL_MICRO) Malloc_t PerlMem_realloc(); #endif /* !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) */ @@ -145,14 +133,11 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size) if ((long)size < 0) Perl_croak_nocontext("panic: realloc"); #endif - ptr = PerlMem_realloc(where,size); - -#ifdef MACOS_TRADITIONAL - MAC_CHECK_GOAT(ptr); -#endif + ptr = (Malloc_t)PerlMem_realloc(where,size); + PERL_ALLOC_CHECK(ptr); - DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05d) rfree\n",PTR2UV(where),PL_an++)); - DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05d) realloc %ld bytes\n",PTR2UV(ptr),PL_an++,(long)size)); + DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++)); + DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size)); if (ptr != Nullch) return ptr; @@ -171,8 +156,10 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size) Free_t Perl_safesysfree(Malloc_t where) { +#ifdef PERL_IMPLICIT_SYS dTHX; - DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05d) free\n",PTR2UV(where),PL_an++)); +#endif + DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) free\n",PTR2UV(where),(long)PL_an++)); if (where) { /*SUPPRESS 701*/ PerlMem_free(where); @@ -199,11 +186,9 @@ Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size) Perl_croak_nocontext("panic: calloc"); #endif size *= count; - ptr = PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */ -#ifdef MACOS_TRADITIONAL - MAC_CHECK_GOAT(ptr); -#endif - DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05d) calloc %ld x %ld bytes\n",PTR2UV(ptr),PL_an++,(long)count,(long)size)); + ptr = (Malloc_t)PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */ + PERL_ALLOC_CHECK(ptr); + DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) calloc %ld x %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)count,(long)size)); if (ptr != Nullch) { memset((void*)ptr, 0, size); return ptr; @@ -481,7 +466,7 @@ Perl_rninstr(pTHX_ register const char *big, const char *bigend, const char *lit * Set up for a new ctype locale. */ void -Perl_new_ctype(pTHX_ const char *newctype) +Perl_new_ctype(pTHX_ char *newctype) { #ifdef USE_LOCALE_CTYPE @@ -500,10 +485,54 @@ Perl_new_ctype(pTHX_ const char *newctype) } /* + * Standardize the locale name from a string returned by 'setlocale'. + * + * The standard return value of setlocale() is either + * (1) "xx_YY" if the first argument of setlocale() is not LC_ALL + * (2) "xa_YY xb_YY ..." if the first argument of setlocale() is LC_ALL + * (the space-separated values represent the various sublocales, + * in some unspecificed order) + * + * In some platforms it has a form like "LC_SOMETHING=Lang_Country.866\n", + * which is harmful for further use of the string in setlocale(). + * + */ +STATIC char * +S_stdize_locale(pTHX_ char *locs) +{ + char *s; + bool okay = TRUE; + + if ((s = strchr(locs, '='))) { + char *t; + + okay = FALSE; + if ((t = strchr(s, '.'))) { + char *u; + + if ((u = strchr(t, '\n'))) { + + if (u[1] == 0) { + STRLEN len = u - s; + Move(s + 1, locs, len, char); + locs[len] = 0; + okay = TRUE; + } + } + } + } + + if (!okay) + Perl_croak(aTHX_ "Can't fix broken locale name \"%s\"", locs); + + return locs; +} + +/* * Set up for a new collation locale. */ void -Perl_new_collate(pTHX_ const char *newcoll) +Perl_new_collate(pTHX_ char *newcoll) { #ifdef USE_LOCALE_COLLATE @@ -512,17 +541,17 @@ Perl_new_collate(pTHX_ const char *newcoll) ++PL_collation_ix; Safefree(PL_collation_name); PL_collation_name = NULL; - PL_collation_standard = TRUE; - PL_collxfrm_base = 0; - PL_collxfrm_mult = 2; } + PL_collation_standard = TRUE; + PL_collxfrm_base = 0; + PL_collxfrm_mult = 2; return; } if (! PL_collation_name || strNE(PL_collation_name, newcoll)) { ++PL_collation_ix; Safefree(PL_collation_name); - PL_collation_name = savepv(newcoll); + PL_collation_name = stdize_locale(savepv(newcoll)); PL_collation_standard = (strEQ(newcoll, "C") || strEQ(newcoll, "POSIX")); { @@ -566,7 +595,7 @@ Perl_set_numeric_radix(pTHX) * Set up for a new numeric locale. */ void -Perl_new_numeric(pTHX_ const char *newnum) +Perl_new_numeric(pTHX_ char *newnum) { #ifdef USE_LOCALE_NUMERIC @@ -574,15 +603,15 @@ Perl_new_numeric(pTHX_ const char *newnum) if (PL_numeric_name) { Safefree(PL_numeric_name); PL_numeric_name = NULL; - PL_numeric_standard = TRUE; - PL_numeric_local = TRUE; } + PL_numeric_standard = TRUE; + PL_numeric_local = TRUE; return; } if (! PL_numeric_name || strNE(PL_numeric_name, newnum)) { Safefree(PL_numeric_name); - PL_numeric_name = savepv(newnum); + PL_numeric_name = stdize_locale(savepv(newnum)); PL_numeric_standard = (strEQ(newnum, "C") || strEQ(newnum, "POSIX")); PL_numeric_local = TRUE; set_numeric_radix(); @@ -600,6 +629,7 @@ Perl_set_numeric_standard(pTHX) setlocale(LC_NUMERIC, "C"); PL_numeric_standard = TRUE; PL_numeric_local = FALSE; + set_numeric_radix(); } #endif /* USE_LOCALE_NUMERIC */ @@ -674,6 +704,8 @@ Perl_init_i18nl10n(pTHX_ int printwarn) (!done && (lang || PerlEnv_getenv("LC_CTYPE"))) ? "" : Nullch))) setlocale_failure = TRUE; + else + curctype = savepv(curctype); #endif /* USE_LOCALE_CTYPE */ #ifdef USE_LOCALE_COLLATE if (! (curcoll = @@ -681,6 +713,8 @@ Perl_init_i18nl10n(pTHX_ int printwarn) (!done && (lang || PerlEnv_getenv("LC_COLLATE"))) ? "" : Nullch))) setlocale_failure = TRUE; + else + curcoll = savepv(curcoll); #endif /* USE_LOCALE_COLLATE */ #ifdef USE_LOCALE_NUMERIC if (! (curnum = @@ -688,6 +722,8 @@ Perl_init_i18nl10n(pTHX_ int printwarn) (!done && (lang || PerlEnv_getenv("LC_NUMERIC"))) ? "" : Nullch))) setlocale_failure = TRUE; + else + curnum = savepv(curnum); #endif /* USE_LOCALE_NUMERIC */ } @@ -704,22 +740,28 @@ Perl_init_i18nl10n(pTHX_ int printwarn) #ifdef USE_LOCALE_CTYPE if (! (curctype = setlocale(LC_CTYPE, ""))) setlocale_failure = TRUE; + else + curctype = savepv(curctype); #endif /* USE_LOCALE_CTYPE */ #ifdef USE_LOCALE_COLLATE if (! (curcoll = setlocale(LC_COLLATE, ""))) setlocale_failure = TRUE; + else + curcoll = savepv(curcoll); #endif /* USE_LOCALE_COLLATE */ #ifdef USE_LOCALE_NUMERIC if (! (curnum = setlocale(LC_NUMERIC, ""))) setlocale_failure = TRUE; + else + curnum = savepv(curnum); #endif /* USE_LOCALE_NUMERIC */ } if (setlocale_failure) { char *p; bool locwarn = (printwarn > 1 || - printwarn && - (!(p = PerlEnv_getenv("PERL_BADLANG")) || atoi(p))); + (printwarn && + (!(p = PerlEnv_getenv("PERL_BADLANG")) || atoi(p)))); if (locwarn) { #ifdef LC_ALL @@ -823,15 +865,16 @@ Perl_init_i18nl10n(pTHX_ int printwarn) #endif /* ! LC_ALL */ #ifdef USE_LOCALE_CTYPE - curctype = setlocale(LC_CTYPE, Nullch); + curctype = savepv(setlocale(LC_CTYPE, Nullch)); #endif /* USE_LOCALE_CTYPE */ #ifdef USE_LOCALE_COLLATE - curcoll = setlocale(LC_COLLATE, Nullch); + curcoll = savepv(setlocale(LC_COLLATE, Nullch)); #endif /* USE_LOCALE_COLLATE */ #ifdef USE_LOCALE_NUMERIC - curnum = setlocale(LC_NUMERIC, Nullch); + curnum = savepv(setlocale(LC_NUMERIC, Nullch)); #endif /* USE_LOCALE_NUMERIC */ } + else { #ifdef USE_LOCALE_CTYPE new_ctype(curctype); @@ -844,9 +887,22 @@ Perl_init_i18nl10n(pTHX_ int printwarn) #ifdef USE_LOCALE_NUMERIC new_numeric(curnum); #endif /* USE_LOCALE_NUMERIC */ + } #endif /* USE_LOCALE */ +#ifdef USE_LOCALE_CTYPE + if (curctype != NULL) + Safefree(curctype); +#endif /* USE_LOCALE_CTYPE */ +#ifdef USE_LOCALE_COLLATE + if (curcoll != NULL) + Safefree(curcoll); +#endif /* USE_LOCALE_COLLATE */ +#ifdef USE_LOCALE_NUMERIC + if (curnum != NULL) + Safefree(curnum); +#endif /* USE_LOCALE_NUMERIC */ return ok; } @@ -924,6 +980,15 @@ Perl_mem_collxfrm(pTHX_ const char *s, STRLEN len, STRLEN *xlen) If FBMcf_TAIL, the table is created as if the string has a trailing \n. */ +/* +=for apidoc fbm_compile + +Analyses the string in order to make fast searches on it using fbm_instr() +-- the Boyer-Moore algorithm. + +=cut +*/ + void Perl_fbm_compile(pTHX_ SV *sv, U32 flags) { @@ -984,6 +1049,17 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags) /* If SvTAIL is actually due to \Z or \z, this gives false positives if multiline */ +/* +=for apidoc fbm_instr + +Returns the location of the SV in the string delimited by C and +C. It returns C if the string can't be found. The C +does not have to be fbm_compiled, but the search will not be as fast +then. + +=cut +*/ + char * Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *littlestr, U32 flags) { @@ -994,17 +1070,16 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit register I32 multiline = flags & FBMrf_MULTILINE; if (bigend - big < littlelen) { - check_tail: if ( SvTAIL(littlestr) && (bigend - big == littlelen - 1) && (littlelen == 1 - || *big == *little && memEQ(big, little, littlelen - 1))) + || (*big == *little && + memEQ((char *)big, (char *)little, littlelen - 1)))) return (char*)big; return Nullch; } if (littlelen <= 2) { /* Special-cased */ - register char c; if (littlelen == 1) { if (SvTAIL(littlestr) && !multiline) { /* Anchor only! */ @@ -1156,7 +1231,6 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit while (tmp--) { if (*--s == *--little) continue; - differ: s = olds + 1; /* here we pay the price for failure */ little = oldlittle; if (s < bigend) /* fake up continue to outer loop */ @@ -1168,7 +1242,8 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit } check_end: if ( s == bigend && (table[-1] & FBMcf_TAIL) - && memEQ(bigend - littlelen, oldlittle - littlelen, littlelen) ) + && memEQ((char *)(bigend - littlelen), + (char *)(oldlittle - littlelen), littlelen) ) return (char*)bigend - littlelen; return Nullch; } @@ -1283,7 +1358,8 @@ Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift return (char*)big; big -= stop_pos; if (*big == first - && ((stop_pos == 1) || memEQ(big + 1, little, stop_pos - 1))) + && ((stop_pos == 1) || + memEQ((char *)(big + 1), (char *)little, stop_pos - 1))) return (char*)big; return Nullch; } @@ -1316,6 +1392,14 @@ Perl_ibcmp_locale(pTHX_ const char *s1, const char *s2, register I32 len) /* copy a string to a safe spot */ +/* +=for apidoc savepv + +Copy a string to a safe spot. This does not use an SV. + +=cut +*/ + char * Perl_savepv(pTHX_ const char *sv) { @@ -1328,6 +1412,15 @@ Perl_savepv(pTHX_ const char *sv) /* same thing but with a known length */ +/* +=for apidoc savepvn + +Copy a string to a safe spot. The C indicates number of bytes to +copy. This does not use an SV. + +=cut +*/ + char * Perl_savepvn(pTHX_ const char *sv, register I32 len) { @@ -1428,19 +1521,12 @@ Perl_vmess(pTHX_ const char *pat, va_list *args) SV *sv = mess_alloc(); static char dgd[] = " during global destruction.\n"; -#ifdef MACOS_TRADITIONAL - sv_setpv(sv, "# "); - sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); - if (SvPVX(sv)[2] == '#') - sv_insert(sv, 0, 2, "", 0); -#else sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); -#endif if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') { dTHR; - if (PL_curcop->cop_line) - Perl_sv_catpvf(aTHX_ sv, " at %_ line %"IVdf, - GvSV(PL_curcop->cop_filegv), (IV)PL_curcop->cop_line); + if (CopLINE(PL_curcop)) + Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf, + CopFILE(PL_curcop), (IV)CopLINE(PL_curcop)); if (GvIO(PL_last_in_gv) && IoLINES(GvIOp(PL_last_in_gv))) { bool line_mode = (RsSIMPLE(PL_rs) && SvCUR(PL_rs) == 1 && *SvPVX(PL_rs) == '\n'); @@ -1454,12 +1540,6 @@ Perl_vmess(pTHX_ const char *pat, va_list *args) Perl_sv_catpvf(aTHX_ sv, " thread %ld", thr->tid); #endif sv_catpv(sv, PL_dirty ? dgd : ".\n"); -#ifdef MACOS_TRADITIONAL - if (PL_curcop->cop_line) { - MPWPosIndication(sv, SvPVX(GvSV(PL_curcop->cop_filegv)), PL_curcop->cop_line); - sv_catpv(sv, "\n"); - } -#endif } return sv; } @@ -1492,6 +1572,7 @@ Perl_vdie(pTHX_ const char* pat, va_list *args) } else { message = Nullch; + msglen = 0; } DEBUG_S(PerlIO_printf(Perl_debug_log, @@ -1510,6 +1591,7 @@ Perl_vdie(pTHX_ const char* pat, va_list *args) SV *msg; ENTER; + save_re_context(); if (message) { msg = newSVpvn(message, msglen); SvREADONLY_on(msg); @@ -1574,14 +1656,20 @@ Perl_vcroak(pTHX_ const char* pat, va_list *args) SV *msv; STRLEN msglen; - msv = vmess(pat, args); - if (PL_errors && SvCUR(PL_errors)) { - sv_catsv(PL_errors, msv); - message = SvPV(PL_errors, msglen); - SvCUR_set(PL_errors, 0); + if (pat) { + msv = vmess(pat, args); + if (PL_errors && SvCUR(PL_errors)) { + sv_catsv(PL_errors, msv); + message = SvPV(PL_errors, msglen); + SvCUR_set(PL_errors, 0); + } + else + message = SvPV(msv,msglen); + } + else { + message = Nullch; + msglen = 0; } - else - message = SvPV(msv,msglen); DEBUG_S(PerlIO_printf(Perl_debug_log, "croak: 0x%"UVxf" %s", PTR2UV(thr), message)); @@ -1599,9 +1687,15 @@ Perl_vcroak(pTHX_ const char* pat, va_list *args) SV *msg; ENTER; - msg = newSVpvn(message, msglen); - SvREADONLY_on(msg); - SAVEFREESV(msg); + save_re_context(); + if (message) { + msg = newSVpvn(message, msglen); + SvREADONLY_on(msg); + SAVEFREESV(msg); + } + else { + msg = ERRSV; + } PUSHSTACKi(PERLSI_DIEHOOK); PUSHMARK(SP); @@ -1629,9 +1723,6 @@ Perl_vcroak(pTHX_ const char* pat, va_list *args) errno = e; #endif } -#ifdef MACOS_TRADITIONAL - MacPosCommit(); -#endif my_failure_exit(); } @@ -1648,6 +1739,23 @@ Perl_croak_nocontext(const char *pat, ...) } #endif /* PERL_IMPLICIT_CONTEXT */ +/* +=for apidoc croak + +This is the XSUB-writer's interface to Perl's C function. +Normally use this function the same way you use the C C +function. See C. + +If you want to throw an exception object, assign the object to +C<$@> and then pass C to croak(): + + errsv = get_sv("@", TRUE); + sv_setsv(errsv, exception_object); + croak(Nullch); + +=cut +*/ + void Perl_croak(pTHX_ const char *pat, ...) { @@ -1685,6 +1793,7 @@ Perl_vwarn(pTHX_ const char* pat, va_list *args) SV *msg; ENTER; + save_re_context(); msg = newSVpvn(message, msglen); SvREADONLY_on(msg); SAVEFREESV(msg); @@ -1727,6 +1836,16 @@ Perl_warn_nocontext(const char *pat, ...) } #endif /* PERL_IMPLICIT_CONTEXT */ +/* +=for apidoc warn + +This is the XSUB-writer's interface to Perl's C function. Use this +function the same way you use the C C function. See +C. + +=cut +*/ + void Perl_warn(pTHX_ const char *pat, ...) { @@ -1788,15 +1907,17 @@ Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args) SV *msg; ENTER; + save_re_context(); msg = newSVpvn(message, msglen); SvREADONLY_on(msg); SAVEFREESV(msg); + PUSHSTACKi(PERLSI_DIEHOOK); PUSHMARK(sp); XPUSHs(msg); PUTBACK; call_sv((SV*)cv, G_DISCARD); - + POPSTACK; LEAVE; } } @@ -1821,21 +1942,23 @@ Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args) SAVESPTR(PL_warnhook); PL_warnhook = Nullsv; cv = sv_2cv(oldwarnhook, &stash, &gv, 0); - LEAVE; + LEAVE; if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) { dSP; SV *msg; ENTER; + save_re_context(); msg = newSVpvn(message, msglen); SvREADONLY_on(msg); SAVEFREESV(msg); + PUSHSTACKi(PERLSI_WARNHOOK); PUSHMARK(sp); XPUSHs(msg); PUTBACK; call_sv((SV*)cv, G_DISCARD); - + POPSTACK; LEAVE; return; } @@ -1844,15 +1967,21 @@ Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args) PerlIO *serr = Perl_error_log; PerlIO_write(serr, message, msglen); #ifdef LEAKTEST - DEBUG_L(xstat()); + DEBUG_L(*message == '!' + ? (xstat(message[1]=='!' + ? (message[2]=='!' ? 2 : 1) + : 0) + , 0) + : 0); #endif (void)PerlIO_flush(serr); } } } -#ifndef VMS /* VMS' my_setenv() is in VMS.c */ -#if !defined(WIN32) && !defined(CYGWIN) +#ifdef USE_ENVIRON_ARRAY + /* VMS' and EPOC's my_setenv() is in vms.c and epoc.c */ +#if !defined(WIN32) void Perl_my_setenv(pTHX_ char *nam, char *val) { @@ -1894,50 +2023,19 @@ Perl_my_setenv(pTHX_ char *nam, char *val) (void)sprintf(environ[i],"%s=%s",nam,val);/* all that work just for this */ #else /* PERL_USE_SAFE_PUTENV */ +# if defined(__CYGWIN__) + setenv(nam, val, 1); +# else char *new_env; new_env = (char*)safesysmalloc((strlen(nam) + strlen(val) + 2) * sizeof(char)); (void)sprintf(new_env,"%s=%s",nam,val);/* all that work just for this */ (void)putenv(new_env); +# endif /* __CYGWIN__ */ #endif /* PERL_USE_SAFE_PUTENV */ } -#else /* WIN32 || CYGWIN */ -#if defined(CYGWIN) -/* - * Save environ of perl.exe, currently Cygwin links in separate environ's - * for each exe/dll. Probably should be a member of impure_ptr. - */ -static char ***Perl_main_environ; - -EXTERN_C void -Perl_my_setenv_init(char ***penviron) -{ - Perl_main_environ = penviron; -} - -void -my_setenv(char *nam, char *val) -{ - /* You can not directly manipulate the environ[] array because - * the routines do some additional work that syncs the Cygwin - * environment with the Windows environment. - */ - char *oldstr = environ[setenv_getix(nam)]; - - if (!val) { - if (!oldstr) - return; - unsetenv(nam); - Safefree(oldstr); - return; - } - setenv(nam, val, 1); - environ = *Perl_main_environ; /* environ realloc can occur in setenv */ - if(oldstr && environ[setenv_getix(nam)] != oldstr) - Safefree(oldstr); -} -#else /* if WIN32 */ +#else /* WIN32 */ void Perl_my_setenv(pTHX_ char *nam,char *val) @@ -1998,7 +2096,6 @@ Perl_my_setenv(pTHX_ char *nam,char *val) } #endif /* WIN32 */ -#endif I32 Perl_setenv_getix(pTHX_ char *nam) @@ -2018,7 +2115,7 @@ Perl_setenv_getix(pTHX_ char *nam) return i; } -#endif /* !VMS */ +#endif /* !VMS && !EPOC*/ #ifdef UNLINK_ALL_VERSIONS I32 @@ -2031,9 +2128,10 @@ Perl_unlnk(pTHX_ char *f) /* unlink all versions of a file */ } #endif +/* this is a drop-in replacement for bcopy() */ #if !defined(HAS_BCOPY) || !defined(HAS_SAFE_BCOPY) char * -Perl_my_bcopy(pTHX_ register const char *from,register char *to,register I32 len) +Perl_my_bcopy(register const char *from,register char *to,register I32 len) { char *retval = to; @@ -2051,9 +2149,10 @@ Perl_my_bcopy(pTHX_ register const char *from,register char *to,register I32 len } #endif +/* this is a drop-in replacement for memset() */ #ifndef HAS_MEMSET void * -Perl_my_memset(pTHX_ register char *loc, register I32 ch, register I32 len) +Perl_my_memset(register char *loc, register I32 ch, register I32 len) { char *retval = loc; @@ -2063,9 +2162,10 @@ Perl_my_memset(pTHX_ register char *loc, register I32 ch, register I32 len) } #endif +/* this is a drop-in replacement for bzero() */ #if !defined(HAS_BZERO) && !defined(HAS_MEMSET) char * -Perl_my_bzero(pTHX_ register char *loc, register I32 len) +Perl_my_bzero(register char *loc, register I32 len) { char *retval = loc; @@ -2075,9 +2175,10 @@ Perl_my_bzero(pTHX_ register char *loc, register I32 len) } #endif +/* this is a drop-in replacement for memcmp() */ #if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP) I32 -Perl_my_memcmp(pTHX_ const char *s1, const char *s2, register I32 len) +Perl_my_memcmp(const char *s1, const char *s2, register I32 len) { register U8 *a = (U8 *)s1; register U8 *b = (U8 *)s2; @@ -2268,7 +2369,7 @@ Perl_my_popen(pTHX_ char *cmd, char *mode) PERL_FLUSHALL_FOR_CHILD; #ifdef OS2 if (doexec) { - return my_syspopen(cmd,mode); + return my_syspopen(aTHX_ cmd,mode); } #endif This = (*mode == 'w'); @@ -2329,8 +2430,8 @@ Perl_my_popen(pTHX_ char *cmd, char *mode) } #endif /* defined OS2 */ /*SUPPRESS 560*/ - if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV)) - sv_setiv(GvSV(tmpgv), getpid()); + if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) + sv_setiv(GvSV(tmpgv), PerlProc_getpid()); PL_forkprocess = 0; hv_clear(PL_pidstatus); /* we have no children */ return Nullfp; @@ -2346,7 +2447,9 @@ Perl_my_popen(pTHX_ char *cmd, char *mode) PerlLIO_close(p[This]); p[This] = p[that]; } + LOCK_FDPID_MUTEX; sv = *av_fetch(PL_fdpid,p[This],TRUE); + UNLOCK_FDPID_MUTEX; (void)SvUPGRADE(sv,SVt_IV); SvIVX(sv) = pid; PL_forkprocess = pid; @@ -2440,7 +2543,7 @@ dup2(int oldfd, int newfd) } #endif - +#ifndef PERL_MICRO #ifdef HAS_SIGACTION Sighandler_t @@ -2525,7 +2628,7 @@ Perl_rsignal_state(pTHX_ int signo) oldsig = PerlProc_signal(signo, sig_trap); PerlProc_signal(signo, oldsig); if (sig_trapped) - PerlProc_kill(getpid(), signo); + PerlProc_kill(PerlProc_getpid(), signo); return oldsig; } @@ -2543,6 +2646,7 @@ Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save) } #endif /* !HAS_SIGACTION */ +#endif /* !PERL_MICRO */ /* VMS' my_pclose() is in VMS.c; same with OS/2 */ #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) @@ -2563,7 +2667,9 @@ Perl_my_pclose(pTHX_ PerlIO *ptr) int saved_win32_errno; #endif + LOCK_FDPID_MUTEX; svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE); + UNLOCK_FDPID_MUTEX; pid = SvIVX(*svp); SvREFCNT_dec(*svp); *svp = &PL_sv_undef; @@ -2584,15 +2690,19 @@ Perl_my_pclose(pTHX_ PerlIO *ptr) #ifdef UTS if(PerlProc_kill(pid, 0) < 0) { return(pid); } /* HOM 12/23/91 */ #endif +#ifndef PERL_MICRO rsignal_save(SIGHUP, SIG_IGN, &hstat); rsignal_save(SIGINT, SIG_IGN, &istat); rsignal_save(SIGQUIT, SIG_IGN, &qstat); +#endif do { pid2 = wait4pid(pid, &status, 0); } while (pid2 == -1 && errno == EINTR); +#ifndef PERL_MICRO rsignal_restore(SIGHUP, &hstat); rsignal_restore(SIGINT, &istat); rsignal_restore(SIGQUIT, &qstat); +#endif if (close_failed) { SETERRNO(saved_errno, saved_vaxc_errno); return -1; @@ -2611,6 +2721,7 @@ Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags) if (!pid) return -1; +#if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME) if (pid > 0) { sprintf(spid, "%"IVdf, (IV)pid); svp = hv_fetch(PL_pidstatus,spid,strlen(spid),FALSE); @@ -2624,7 +2735,7 @@ Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags) HE *entry; hv_iterinit(PL_pidstatus); - if (entry = hv_iternext(PL_pidstatus)) { + if ((entry = hv_iternext(PL_pidstatus))) { pid = atoi(hv_iterkey(entry,(I32*)statusp)); sv = hv_iterval(PL_pidstatus,entry); *statusp = SvIVX(sv); @@ -2633,6 +2744,7 @@ Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags) return pid; } } +#endif #ifdef HAS_WAITPID # ifdef HAS_WAITPID_RUNTIME if (!HAS_WAITPID_RUNTIME) @@ -2834,7 +2946,7 @@ Perl_same_dirent(pTHX_ char *a, char *b) #endif /* !HAS_RENAME */ NV -Perl_scan_bin(pTHX_ char *start, I32 len, I32 *retlen) +Perl_scan_bin(pTHX_ char *start, STRLEN len, STRLEN *retlen) { register char *s = start; register NV rnv = 0.0; @@ -2844,9 +2956,13 @@ Perl_scan_bin(pTHX_ char *start, I32 len, I32 *retlen) for (; len-- && *s; s++) { if (!(*s == '0' || *s == '1')) { - if (*s == '_') - continue; /* Note: does not check for __ and the like. */ - if (seenb == FALSE && *s == 'b' && ruv == 0) { + if (*s == '_' && len && *retlen + && (s[1] == '0' || s[1] == '1')) + { + --len; + ++s; + } + else if (seenb == FALSE && *s == 'b' && ruv == 0) { /* Disallow 0bbb0b0bbb... */ seenb = TRUE; continue; @@ -2869,7 +2985,8 @@ Perl_scan_bin(pTHX_ char *start, I32 len, I32 *retlen) if (ckWARN_d(WARN_OVERFLOW)) Perl_warner(aTHX_ WARN_OVERFLOW, "Integer overflow in binary number"); - } else + } + else ruv = xuv | (*s - '0'); } if (overflowed) { @@ -2900,7 +3017,7 @@ Perl_scan_bin(pTHX_ char *start, I32 len, I32 *retlen) } NV -Perl_scan_oct(pTHX_ char *start, I32 len, I32 *retlen) +Perl_scan_oct(pTHX_ char *start, STRLEN len, STRLEN *retlen) { register char *s = start; register NV rnv = 0.0; @@ -2909,8 +3026,12 @@ Perl_scan_oct(pTHX_ char *start, I32 len, I32 *retlen) for (; len-- && *s; s++) { if (!(*s >= '0' && *s <= '7')) { - if (*s == '_') - continue; /* Note: does not check for __ and the like. */ + if (*s == '_' && len && *retlen + && (s[1] >= '0' && s[1] <= '7')) + { + --len; + ++s; + } else { /* Allow \octal to work the DWIM way (that is, stop scanning * as soon as non-octal characters are seen, complain only iff @@ -2934,7 +3055,8 @@ Perl_scan_oct(pTHX_ char *start, I32 len, I32 *retlen) if (ckWARN_d(WARN_OVERFLOW)) Perl_warner(aTHX_ WARN_OVERFLOW, "Integer overflow in octal number"); - } else + } + else ruv = xuv | (*s - '0'); } if (overflowed) { @@ -2965,7 +3087,7 @@ Perl_scan_oct(pTHX_ char *start, I32 len, I32 *retlen) } NV -Perl_scan_hex(pTHX_ char *start, I32 len, I32 *retlen) +Perl_scan_hex(pTHX_ char *start, STRLEN len, STRLEN *retlen) { register char *s = start; register NV rnv = 0.0; @@ -2977,9 +3099,13 @@ Perl_scan_hex(pTHX_ char *start, I32 len, I32 *retlen) for (; len-- && *s; s++) { hexdigit = strchr((char *) PL_hexdigit, *s); if (!hexdigit) { - if (*s == '_') - continue; /* Note: does not check for __ and the like. */ - if (seenx == FALSE && *s == 'x' && ruv == 0) { + if (*s == '_' && len && *retlen && s[1] + && (hexdigit = strchr((char *) PL_hexdigit, s[1]))) + { + --len; + ++s; + } + else if (seenx == FALSE && *s == 'x' && ruv == 0) { /* Disallow 0xxx0x0xxx... */ seenx = TRUE; continue; @@ -3002,7 +3128,8 @@ Perl_scan_hex(pTHX_ char *start, I32 len, I32 *retlen) if (ckWARN_d(WARN_OVERFLOW)) Perl_warner(aTHX_ WARN_OVERFLOW, "Integer overflow in hexadecimal number"); - } else + } + else ruv = xuv | ((hexdigit - PL_hexdigit) & 15); } if (overflowed) { @@ -3230,7 +3357,7 @@ Perl_find_script(pTHX_ char *scriptname, bool dosearch, char **search_ext, I32 f continue; if (S_ISREG(PL_statbuf.st_mode) && cando(S_IRUSR,TRUE,&PL_statbuf) -#if !defined(DOSISH) && !defined(MACOS_TRDITIONAL) +#if !defined(DOSISH) && !defined(MACOS_TRADITIONAL) && cando(S_IXUSR,TRUE,&PL_statbuf) #endif ) @@ -3264,8 +3391,46 @@ Perl_find_script(pTHX_ char *scriptname, bool dosearch, char **search_ext, I32 f return (scriptname ? savepv(scriptname) : Nullch); } +#ifndef PERL_GET_CONTEXT_DEFINED + +void * +Perl_get_context(void) +{ +#if defined(USE_THREADS) || defined(USE_ITHREADS) +# ifdef OLD_PTHREADS_API + pthread_addr_t t; + if (pthread_getspecific(PL_thr_key, &t)) + Perl_croak_nocontext("panic: pthread_getspecific"); + return (void*)t; +# else +# ifdef I_MACH_CTHREADS + return (void*)cthread_data(cthread_self()); +# else + return (void*)pthread_getspecific(PL_thr_key); +# endif +# endif +#else + return (void*)NULL; +#endif +} + +void +Perl_set_context(void *t) +{ +#if defined(USE_THREADS) || defined(USE_ITHREADS) +# ifdef I_MACH_CTHREADS + cthread_set_data(cthread_self(), t); +# else + if (pthread_setspecific(PL_thr_key, t)) + Perl_croak_nocontext("panic: pthread_setspecific"); +# endif +#endif +} + +#endif /* !PERL_GET_CONTEXT_DEFINED */ #ifdef USE_THREADS + #ifdef FAKE_THREADS /* Very simplistic scheduler for now */ void @@ -3340,18 +3505,6 @@ Perl_cond_wait(pTHX_ perl_cond *cp) } #endif /* FAKE_THREADS */ -#ifdef PTHREAD_GETSPECIFIC_INT -struct perl_thread * -Perl_getTHR(pTHX) -{ - pthread_addr_t t; - - if (pthread_getspecific(PL_thr_key, &t)) - Perl_croak(aTHX_ "panic: pthread_getspecific"); - return (struct perl_thread *) t; -} -#endif - MAGIC * Perl_condpair_magic(pTHX_ SV *sv) { @@ -3367,11 +3520,11 @@ Perl_condpair_magic(pTHX_ SV *sv) COND_INIT(&cp->owner_cond); COND_INIT(&cp->cond); cp->owner = 0; - MUTEX_LOCK(&PL_cred_mutex); /* XXX need separate mutex? */ + LOCK_CRED_MUTEX; /* XXX need separate mutex? */ mg = mg_find(sv, 'm'); if (mg) { /* someone else beat us to initialising it */ - MUTEX_UNLOCK(&PL_cred_mutex); /* XXX need separate mutex? */ + UNLOCK_CRED_MUTEX; /* XXX need separate mutex? */ MUTEX_DESTROY(&cp->mutex); COND_DESTROY(&cp->owner_cond); COND_DESTROY(&cp->cond); @@ -3382,7 +3535,7 @@ Perl_condpair_magic(pTHX_ SV *sv) mg = SvMAGIC(sv); mg->mg_ptr = (char *)cp; mg->mg_len = sizeof(cp); - MUTEX_UNLOCK(&PL_cred_mutex); /* XXX need separate mutex? */ + UNLOCK_CRED_MUTEX; /* XXX need separate mutex? */ DEBUG_S(WITH_THR(PerlIO_printf(Perl_debug_log, "%p: condpair_magic %p\n", thr, sv));) } @@ -3390,6 +3543,35 @@ Perl_condpair_magic(pTHX_ SV *sv) return mg; } +SV * +Perl_sv_lock(pTHX_ SV *osv) +{ + MAGIC *mg; + SV *sv = osv; + + LOCK_SV_LOCK_MUTEX; + if (SvROK(sv)) { + sv = SvRV(sv); + } + + mg = condpair_magic(sv); + MUTEX_LOCK(MgMUTEXP(mg)); + if (MgOWNER(mg) == thr) + MUTEX_UNLOCK(MgMUTEXP(mg)); + else { + while (MgOWNER(mg)) + COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg)); + MgOWNER(mg) = thr; + DEBUG_S(PerlIO_printf(Perl_debug_log, + "0x%"UVxf": Perl_lock lock 0x%"UVxf"\n", + PTR2UV(thr), PTR2UV(sv));) + MUTEX_UNLOCK(MgMUTEXP(mg)); + SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv); + } + UNLOCK_SV_LOCK_MUTEX; + return sv; +} + /* * Make a new perl thread structure using t as a prototype. Some of the * fields for the new thread are copied from the prototype thread, t, @@ -3420,12 +3602,12 @@ Perl_new_struct_thread(pTHX_ struct perl_thread *t) PL_dirty = 0; PL_localizing = 0; Zero(&PL_hv_fetch_ent_mh, 1, HE); + PL_efloatbuf = (char*)NULL; + PL_efloatsize = 0; #else Zero(thr, 1, struct perl_thread); #endif - PL_protect = MEMBER_TO_FPTR(Perl_default_protect); - thr->oursv = sv; init_stacks(); @@ -3436,22 +3618,12 @@ Perl_new_struct_thread(pTHX_ struct perl_thread *t) thr->specific = newAV(); thr->errsv = newSVpvn("", 0); thr->flags = THRf_R_JOINABLE; + thr->thr_done = 0; MUTEX_INIT(&thr->mutex); - /* 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 - be per-thread. Otherwise a 'die' in a thread gives - that thread the C stack of last thread to do an eval {}! - See comments in scope.h - Initialize top entry (as in perl.c for main thread) - */ - PL_start_env.je_prev = NULL; - PL_start_env.je_ret = -1; - PL_start_env.je_mustcatch = TRUE; - PL_top_env = &PL_start_env; + JMPENV_BOOTSTRAP; - PL_in_eval = EVAL_NULL; /* ~(EVAL_INEVAL|EVAL_WARNONLY|EVAL_KEEPERR) */ + PL_in_eval = EVAL_NULL; /* ~(EVAL_INEVAL|EVAL_WARNONLY|EVAL_KEEPERR|EVAL_INREQUIRE) */ PL_restartop = 0; PL_statname = NEWSV(66,0); @@ -3474,7 +3646,9 @@ Perl_new_struct_thread(pTHX_ struct perl_thread *t) /* parent thread's data needs to be locked while we make copy */ MUTEX_LOCK(&t->mutex); +#ifdef PERL_FLEXIBLE_EXCEPTIONS PL_protect = t->Tprotect; +#endif PL_curcop = t->Tcurcop; /* XXX As good a guess as any? */ PL_defstash = t->Tdefstash; /* XXX maybe these should */ @@ -3489,9 +3663,12 @@ Perl_new_struct_thread(pTHX_ struct perl_thread *t) 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); + if (t->Tformtarget == t->Ttoptarget) + PL_formtarget = PL_toptarget; + else + PL_formtarget = PL_bodytarget; /* Initialise all per-thread SVs that the template thread used */ svp = AvARRAY(t->threadsv); @@ -3501,7 +3678,8 @@ Perl_new_struct_thread(pTHX_ struct perl_thread *t) av_store(thr->threadsv, i, sv); sv_magic(sv, 0, 0, &PL_threadsv_names[i], 1); DEBUG_S(PerlIO_printf(Perl_debug_log, - "new_struct_thread: copied threadsv %d %p->%p\n",i, t, thr)); + "new_struct_thread: copied threadsv %"IVdf" %p->%p\n", + (IV)i, t, thr)); } } thr->threadsvp = AvARRAY(thr->threadsv); @@ -3525,7 +3703,7 @@ Perl_new_struct_thread(pTHX_ struct perl_thread *t) } #endif /* USE_THREADS */ -#ifdef HUGE_VAL +#if defined(HUGE_VAL) || (defined(USE_LONG_DOUBLE) && defined(HUGE_VALL)) /* * This hack is to force load of "huge" support from libm.a * So it is in perl for (say) POSIX to use. @@ -3534,7 +3712,10 @@ Perl_new_struct_thread(pTHX_ struct perl_thread *t) NV Perl_huge(void) { - return HUGE_VAL; +# if defined(USE_LONG_DOUBLE) && defined(HUGE_VALL) + return HUGE_VALL; +# endif + return HUGE_VAL; } #endif @@ -3573,12 +3754,12 @@ Perl_get_opargs(pTHX) PPADDR_t* Perl_get_ppaddr(pTHX) { - return &PL_ppaddr; + return (PPADDR_t*)PL_ppaddr; } #ifndef HAS_GETENV_LEN char * -Perl_getenv_len(pTHX_ char *env_elem, unsigned long *len) +Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len) { char *env_trans = PerlEnv_getenv(env_elem); if (env_trans) @@ -3735,22 +3916,71 @@ Perl_my_fflush_all(pTHX) } NV -Perl_my_atof(pTHX_ const char* s) { +Perl_my_atof(pTHX_ const char* s) +{ + NV x = 0.0; #ifdef USE_LOCALE_NUMERIC if ((PL_hints & HINT_LOCALE) && PL_numeric_local) { - NV x, y; + NV y; - x = Perl_atof(s); + Perl_atof2(s, x); SET_NUMERIC_STANDARD(); - y = Perl_atof(s); + Perl_atof2(s, y); SET_NUMERIC_LOCAL(); if ((y < 0.0 && y < x) || (y > 0.0 && y > x)) return y; - return x; } else - return Perl_atof(s); + Perl_atof2(s, x); #else - return Perl_atof(s); + Perl_atof2(s, x); #endif + return x; +} + +void +Perl_report_evil_fh(pTHX_ GV *gv, IO *io, I32 op) +{ + char *vile; + I32 warn_type; + char *func = + op == OP_READLINE ? "readline" : /* "" not nice */ + op == OP_LEAVEWRITE ? "write" : /* "write exit" not nice */ + PL_op_desc[op]; + char *pars = OP_IS_FILETEST(op) ? "" : "()"; + char *type = OP_IS_SOCKET(op) || (io && IoTYPE(io) == IoTYPE_SOCKET) ? + "socket" : "filehandle"; + char *name = NULL; + + if (io && IoTYPE(io) == IoTYPE_CLOSED) { + vile = "closed"; + warn_type = WARN_CLOSED; + } + else { + vile = "unopened"; + warn_type = WARN_UNOPENED; + } + + if (gv && isGV(gv)) { + SV *sv = sv_newmortal(); + gv_efullname4(sv, gv, Nullch, FALSE); + name = SvPVX(sv); + } + + if (name && *name) { + Perl_warner(aTHX_ warn_type, + "%s%s on %s %s %s", func, pars, vile, type, name); + if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP)) + Perl_warner(aTHX_ warn_type, + "\t(Are you trying to call %s%s on dirhandle %s?)\n", + func, pars, name); + } + else { + Perl_warner(aTHX_ warn_type, + "%s%s on %s %s", func, pars, vile, type); + if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP)) + Perl_warner(aTHX_ warn_type, + "\t(Are you trying to call %s%s on dirhandle?)\n", + func, pars); + } }