X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/b3c85772f7a16b79e679c78c9638a7afa4856432..9f84c00564fd021b1da47513d58d337c301b73aa:/util.c diff --git a/util.c b/util.c index 4ccd589..5224a55 100644 --- a/util.c +++ b/util.c @@ -26,25 +26,10 @@ #endif #endif -#ifdef I_VFORK -# include -#endif - -/* Put this after #includes because fork and vfork prototypes may - conflict. -*/ -#ifndef HAS_VFORK -# define vfork fork -#endif - #ifdef I_SYS_WAIT # include #endif -#ifdef I_LOCALE -# include -#endif - #define FLUSH #ifdef LEAKTEST @@ -60,14 +45,14 @@ long lastxycount[MAXXCOUNT][MAXYCOUNT]; # define FD_CLOEXEC 1 /* NeXT needs this */ #endif -/* 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 * allocated hunks back to the original New to track down any memory leaks. * XXX This advice seems to be widely ignored :-( --AD August 1996. */ +/* paranoid version of system's malloc() */ + Malloc_t Perl_safesysmalloc(MEM_SIZE size) { @@ -340,6 +325,37 @@ S_xstat(pTHX_ int flag) #endif /* LEAKTEST */ +/* These must be defined when not using Perl's malloc for binary + * compatibility */ + +#ifndef MYMALLOC + +Malloc_t Perl_malloc (MEM_SIZE nbytes) +{ + dTHXs; + return PerlMem_malloc(nbytes); +} + +Malloc_t Perl_calloc (MEM_SIZE elements, MEM_SIZE size) +{ + dTHXs; + return PerlMem_calloc(elements, size); +} + +Malloc_t Perl_realloc (Malloc_t where, MEM_SIZE nbytes) +{ + dTHXs; + return PerlMem_realloc(where, nbytes); +} + +Free_t Perl_mfree (Malloc_t where) +{ + dTHXs; + PerlMem_free(where); +} + +#endif + /* copy a string up to some (non-backslashed) delimiter, if any */ char * @@ -457,528 +473,6 @@ Perl_rninstr(pTHX_ register const char *big, const char *bigend, const char *lit return Nullch; } -/* - * Set up for a new ctype locale. - */ -void -Perl_new_ctype(pTHX_ char *newctype) -{ -#ifdef USE_LOCALE_CTYPE - - int i; - - for (i = 0; i < 256; i++) { - if (isUPPER_LC(i)) - PL_fold_locale[i] = toLOWER_LC(i); - else if (isLOWER_LC(i)) - PL_fold_locale[i] = toUPPER_LC(i); - else - PL_fold_locale[i] = i; - } - -#endif /* USE_LOCALE_CTYPE */ -} - -/* - * 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_ char *newcoll) -{ -#ifdef USE_LOCALE_COLLATE - - if (! newcoll) { - 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 (! PL_collation_name || strNE(PL_collation_name, newcoll)) { - ++PL_collation_ix; - Safefree(PL_collation_name); - PL_collation_name = stdize_locale(savepv(newcoll)); - PL_collation_standard = (strEQ(newcoll, "C") || strEQ(newcoll, "POSIX")); - - { - /* 2: at most so many chars ('a', 'b'). */ - /* 50: surely no system expands a char more. */ -#define XFRMBUFSIZE (2 * 50) - char xbuf[XFRMBUFSIZE]; - Size_t fa = strxfrm(xbuf, "a", XFRMBUFSIZE); - Size_t fb = strxfrm(xbuf, "ab", XFRMBUFSIZE); - SSize_t mult = fb - fa; - if (mult < 1) - Perl_croak(aTHX_ "strxfrm() gets absurd"); - PL_collxfrm_base = (fa > mult) ? (fa - mult) : 0; - PL_collxfrm_mult = mult; - } - } - -#endif /* USE_LOCALE_COLLATE */ -} - -void -Perl_set_numeric_radix(pTHX) -{ -#ifdef USE_LOCALE_NUMERIC -# ifdef HAS_LOCALECONV - struct lconv* lc; - - lc = localeconv(); - if (lc && lc->decimal_point) { - if (lc->decimal_point[0] == '.' && lc->decimal_point[1] == 0) { - SvREFCNT_dec(PL_numeric_radix); - PL_numeric_radix = 0; - } - else { - if (PL_numeric_radix) - sv_setpv(PL_numeric_radix, lc->decimal_point); - else - PL_numeric_radix = newSVpv(lc->decimal_point, 0); - } - } - else - PL_numeric_radix = 0; -# endif /* HAS_LOCALECONV */ -#endif /* USE_LOCALE_NUMERIC */ -} - -/* - * Set up for a new numeric locale. - */ -void -Perl_new_numeric(pTHX_ char *newnum) -{ -#ifdef USE_LOCALE_NUMERIC - - if (! newnum) { - if (PL_numeric_name) { - Safefree(PL_numeric_name); - PL_numeric_name = NULL; - } - 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 = stdize_locale(savepv(newnum)); - PL_numeric_standard = (strEQ(newnum, "C") || strEQ(newnum, "POSIX")); - PL_numeric_local = TRUE; - set_numeric_radix(); - } - -#endif /* USE_LOCALE_NUMERIC */ -} - -void -Perl_set_numeric_standard(pTHX) -{ -#ifdef USE_LOCALE_NUMERIC - - if (! PL_numeric_standard) { - setlocale(LC_NUMERIC, "C"); - PL_numeric_standard = TRUE; - PL_numeric_local = FALSE; - set_numeric_radix(); - } - -#endif /* USE_LOCALE_NUMERIC */ -} - -void -Perl_set_numeric_local(pTHX) -{ -#ifdef USE_LOCALE_NUMERIC - - if (! PL_numeric_local) { - setlocale(LC_NUMERIC, PL_numeric_name); - PL_numeric_standard = FALSE; - PL_numeric_local = TRUE; - set_numeric_radix(); - } - -#endif /* USE_LOCALE_NUMERIC */ -} - -/* - * Initialize locale awareness. - */ -int -Perl_init_i18nl10n(pTHX_ int printwarn) -{ - int ok = 1; - /* returns - * 1 = set ok or not applicable, - * 0 = fallback to C locale, - * -1 = fallback to C locale failed - */ - -#if defined(USE_LOCALE) - -#ifdef USE_LOCALE_CTYPE - char *curctype = NULL; -#endif /* USE_LOCALE_CTYPE */ -#ifdef USE_LOCALE_COLLATE - char *curcoll = NULL; -#endif /* USE_LOCALE_COLLATE */ -#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; - -#ifdef LOCALE_ENVIRON_REQUIRED - - /* - * Ultrix setlocale(..., "") fails if there are no environment - * variables from which to get a locale name. - */ - - bool done = FALSE; - -#ifdef LC_ALL - if (lang) { - if (setlocale(LC_ALL, "")) - done = TRUE; - else - setlocale_failure = TRUE; - } - if (!setlocale_failure) { -#ifdef USE_LOCALE_CTYPE - if (! (curctype = - setlocale(LC_CTYPE, - (!done && (lang || PerlEnv_getenv("LC_CTYPE"))) - ? "" : Nullch))) - setlocale_failure = TRUE; - else - curctype = savepv(curctype); -#endif /* USE_LOCALE_CTYPE */ -#ifdef USE_LOCALE_COLLATE - if (! (curcoll = - setlocale(LC_COLLATE, - (!done && (lang || PerlEnv_getenv("LC_COLLATE"))) - ? "" : Nullch))) - setlocale_failure = TRUE; - else - curcoll = savepv(curcoll); -#endif /* USE_LOCALE_COLLATE */ -#ifdef USE_LOCALE_NUMERIC - if (! (curnum = - setlocale(LC_NUMERIC, - (!done && (lang || PerlEnv_getenv("LC_NUMERIC"))) - ? "" : Nullch))) - setlocale_failure = TRUE; - else - curnum = savepv(curnum); -#endif /* USE_LOCALE_NUMERIC */ - } - -#endif /* LC_ALL */ - -#endif /* !LOCALE_ENVIRON_REQUIRED */ - -#ifdef LC_ALL - if (! setlocale(LC_ALL, "")) - setlocale_failure = TRUE; -#endif /* LC_ALL */ - - if (!setlocale_failure) { -#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)))); - - if (locwarn) { -#ifdef LC_ALL - - PerlIO_printf(Perl_error_log, - "perl: warning: Setting locale failed.\n"); - -#else /* !LC_ALL */ - - PerlIO_printf(Perl_error_log, - "perl: warning: Setting locale failed for the categories:\n\t"); -#ifdef USE_LOCALE_CTYPE - if (! curctype) - PerlIO_printf(Perl_error_log, "LC_CTYPE "); -#endif /* USE_LOCALE_CTYPE */ -#ifdef USE_LOCALE_COLLATE - if (! curcoll) - PerlIO_printf(Perl_error_log, "LC_COLLATE "); -#endif /* USE_LOCALE_COLLATE */ -#ifdef USE_LOCALE_NUMERIC - if (! curnum) - PerlIO_printf(Perl_error_log, "LC_NUMERIC "); -#endif /* USE_LOCALE_NUMERIC */ - PerlIO_printf(Perl_error_log, "\n"); - -#endif /* LC_ALL */ - - PerlIO_printf(Perl_error_log, - "perl: warning: Please check that your locale settings:\n"); - -#ifdef __GLIBC__ - PerlIO_printf(Perl_error_log, - "\tLANGUAGE = %c%s%c,\n", - language ? '"' : '(', - language ? language : "unset", - language ? '"' : ')'); -#endif - - PerlIO_printf(Perl_error_log, - "\tLC_ALL = %c%s%c,\n", - lc_all ? '"' : '(', - lc_all ? lc_all : "unset", - lc_all ? '"' : ')'); - -#if defined(USE_ENVIRON_ARRAY) - { - char **e; - for (e = environ; *e; e++) { - if (strnEQ(*e, "LC_", 3) - && strnNE(*e, "LC_ALL=", 7) - && (p = strchr(*e, '='))) - PerlIO_printf(Perl_error_log, "\t%.*s = \"%s\",\n", - (int)(p - *e), *e, p + 1); - } - } -#else - PerlIO_printf(Perl_error_log, - "\t(possibly more locale environment variables)\n"); -#endif - - PerlIO_printf(Perl_error_log, - "\tLANG = %c%s%c\n", - lang ? '"' : '(', - lang ? lang : "unset", - lang ? '"' : ')'); - - PerlIO_printf(Perl_error_log, - " are supported and installed on your system.\n"); - } - -#ifdef LC_ALL - - if (setlocale(LC_ALL, "C")) { - if (locwarn) - PerlIO_printf(Perl_error_log, - "perl: warning: Falling back to the standard locale (\"C\").\n"); - ok = 0; - } - else { - if (locwarn) - PerlIO_printf(Perl_error_log, - "perl: warning: Failed to fall back to the standard locale (\"C\").\n"); - ok = -1; - } - -#else /* ! LC_ALL */ - - if (0 -#ifdef USE_LOCALE_CTYPE - || !(curctype || setlocale(LC_CTYPE, "C")) -#endif /* USE_LOCALE_CTYPE */ -#ifdef USE_LOCALE_COLLATE - || !(curcoll || setlocale(LC_COLLATE, "C")) -#endif /* USE_LOCALE_COLLATE */ -#ifdef USE_LOCALE_NUMERIC - || !(curnum || setlocale(LC_NUMERIC, "C")) -#endif /* USE_LOCALE_NUMERIC */ - ) - { - if (locwarn) - PerlIO_printf(Perl_error_log, - "perl: warning: Cannot fall back to the standard locale (\"C\").\n"); - ok = -1; - } - -#endif /* ! LC_ALL */ - -#ifdef USE_LOCALE_CTYPE - curctype = savepv(setlocale(LC_CTYPE, Nullch)); -#endif /* USE_LOCALE_CTYPE */ -#ifdef USE_LOCALE_COLLATE - curcoll = savepv(setlocale(LC_COLLATE, Nullch)); -#endif /* USE_LOCALE_COLLATE */ -#ifdef USE_LOCALE_NUMERIC - curnum = savepv(setlocale(LC_NUMERIC, Nullch)); -#endif /* USE_LOCALE_NUMERIC */ - } - else { - -#ifdef USE_LOCALE_CTYPE - new_ctype(curctype); -#endif /* USE_LOCALE_CTYPE */ - -#ifdef USE_LOCALE_COLLATE - new_collate(curcoll); -#endif /* USE_LOCALE_COLLATE */ - -#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; -} - -/* Backwards compatibility. */ -int -Perl_init_i18nl14n(pTHX_ int printwarn) -{ - return init_i18nl10n(printwarn); -} - -#ifdef USE_LOCALE_COLLATE - -/* - * mem_collxfrm() is a bit like strxfrm() but with two important - * differences. First, it handles embedded NULs. Second, it allocates - * a bit more memory than needed for the transformed data itself. - * The real transformed data begins at offset sizeof(collationix). - * Please see sv_collxfrm() to see how this is used. - */ -char * -Perl_mem_collxfrm(pTHX_ const char *s, STRLEN len, STRLEN *xlen) -{ - char *xbuf; - STRLEN xAlloc, xin, xout; /* xalloc is a reserved word in VC */ - - /* the first sizeof(collationix) bytes are used by sv_collxfrm(). */ - /* the +1 is for the terminating NUL. */ - - xAlloc = sizeof(PL_collation_ix) + PL_collxfrm_base + (PL_collxfrm_mult * len) + 1; - New(171, xbuf, xAlloc, char); - if (! xbuf) - goto bad; - - *(U32*)xbuf = PL_collation_ix; - xout = sizeof(PL_collation_ix); - for (xin = 0; xin < len; ) { - SSize_t xused; - - for (;;) { - xused = strxfrm(xbuf + xout, s + xin, xAlloc - xout); - if (xused == -1) - goto bad; - if (xused < xAlloc - xout) - break; - xAlloc = (2 * xAlloc) + 1; - Renew(xbuf, xAlloc, char); - if (! xbuf) - goto bad; - } - - xin += strlen(s + xin) + 1; - xout += xused; - - /* Embedded NULs are understood but silently skipped - * because they make no sense in locale collation. */ - } - - xbuf[xout] = '\0'; - *xlen = xout - sizeof(PL_collation_ix); - return xbuf; - - bad: - Safefree(xbuf); - *xlen = 0; - return NULL; -} - -#endif /* USE_LOCALE_COLLATE */ - #define FBM_TABLE_OFFSET 2 /* Number of bytes between EOS and table*/ /* As a space optimization, we do not compile tables for strings of length @@ -1010,7 +504,7 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags) sv_catpvn(sv, "\n", 1); /* Taken into account in fbm_instr() */ s = (U8*)SvPV_force(sv, len); (void)SvUPGRADE(sv, SVt_PVBM); - if (len == 0) /* TAIL might be on on a zero-length string. */ + if (len == 0) /* TAIL might be on a zero-length string. */ return; if (len > 2) { U8 mlen; @@ -1033,7 +527,7 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags) s--, i++; } } - sv_magic(sv, Nullsv, 'B', Nullch, 0); /* deep magic */ + sv_magic(sv, Nullsv, PERL_MAGIC_bm, Nullch, 0); /* deep magic */ SvVALID_on(sv); s = (unsigned char*)(SvPVX(sv)); /* deeper magic */ @@ -1218,16 +712,8 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit top2: /*SUPPRESS 560*/ if ((tmp = table[*s])) { -#ifdef POINTERRIGOR - if (bigend - s > tmp) { - s += tmp; - goto top2; - } - s += tmp; -#else if ((s += tmp) < bigend) goto top2; -#endif goto check_end; } else { /* less expensive than calling strncmp() */ @@ -1268,7 +754,7 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit */ /* If SvTAIL is actually due to \Z or \z, this gives false positives - if PL_multiline. In fact if !PL_multiline the autoritative answer + if PL_multiline. In fact if !PL_multiline the authoritative answer is not supported yet. */ char * @@ -1307,33 +793,20 @@ Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift /* The value of pos we can stop at: */ stop_pos = SvCUR(bigstr) - end_shift - (SvCUR(littlestr) - 1 - previous); if (previous + start_shift > stop_pos) { +/* + stop_pos does not include SvTAIL in the count, so this check is incorrect + (I think) - see [ID 20010618.006] and t/op/study.t. HVDS 2001/06/19 +*/ +#if 0 if (previous + start_shift == stop_pos + 1) /* A fake '\n'? */ goto check_tail; +#endif return Nullch; } while (pos < previous + start_shift) { if (!(pos += PL_screamnext[pos])) goto cant_find; } -#ifdef POINTERRIGOR - do { - if (pos >= stop_pos) break; - if (big[pos-previous] != first) - continue; - for (x=big+pos+1-previous,s=little; s < littleend; /**/ ) { - if (*s++ != *x++) { - s--; - break; - } - } - if (s == littleend) { - *old_posp = pos; - if (!last) return (char *)(big+pos-previous); - found = 1; - } - } while ( pos += PL_screamnext[pos] ); - return (last && found) ? (char *)(big+(*old_posp)-previous) : Nullch; -#else /* !POINTERRIGOR */ big -= previous; do { if (pos >= stop_pos) break; @@ -1353,7 +826,6 @@ Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift } while ( pos += PL_screamnext[pos] ); if (last && found) return (char *)(big+(*old_posp)); -#endif /* POINTERRIGOR */ check_tail: if (!SvTAIL(littlestr) || (end_shift > 0)) return Nullch; @@ -1520,17 +992,60 @@ Perl_mess(pTHX_ const char *pat, ...) return retval; } +STATIC COP* +S_closest_cop(pTHX_ COP *cop, OP *o) +{ + /* Look for PL_op starting from o. cop is the last COP we've seen. */ + + if (!o || o == PL_op) return cop; + + if (o->op_flags & OPf_KIDS) { + OP *kid; + for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) + { + COP *new_cop; + + /* If the OP_NEXTSTATE has been optimised away we can still use it + * the get the file and line number. */ + + if (kid->op_type == OP_NULL && kid->op_targ == OP_NEXTSTATE) + cop = (COP *)kid; + + /* Keep searching, and return when we've found something. */ + + new_cop = closest_cop(cop, kid); + if (new_cop) return new_cop; + } + } + + /* Nothing found. */ + + return 0; +} + SV * Perl_vmess(pTHX_ const char *pat, va_list *args) { SV *sv = mess_alloc(); static char dgd[] = " during global destruction.\n"; + COP *cop; sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') { - if (CopLINE(PL_curcop)) + + /* + * Try and find the file and line for PL_op. This will usually be + * PL_curcop, but it might be a cop that has been optimised away. We + * can try to find such a cop by searching through the optree starting + * from the sibling of PL_curcop. + */ + + cop = closest_cop(PL_curcop, PL_curcop->op_sibling); + if (!cop) cop = PL_curcop; + + if (CopLINE(cop)) Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf, - CopFILE(PL_curcop), (IV)CopLINE(PL_curcop)); + CopFILE(cop), (IV)CopLINE(cop)); 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'); @@ -1539,7 +1054,7 @@ Perl_vmess(pTHX_ const char *pat, va_list *args) line_mode ? "line" : "chunk", (IV)IoLINES(GvIOp(PL_last_in_gv))); } -#ifdef USE_THREADS +#ifdef USE_5005THREADS if (thr->tid) Perl_sv_catpvf(aTHX_ sv, " thread %ld", thr->tid); #endif @@ -1712,6 +1227,9 @@ Perl_vcroak(pTHX_ const char* pat, va_list *args) PL_restartop = die_where(message, msglen); JMPENV_JUMP(3); } + else if (!message) + message = SvPVx(ERRSV, msglen); + { #ifdef USE_SFIO /* SFIO can really mess with your errno */ @@ -1719,7 +1237,7 @@ Perl_vcroak(pTHX_ const char* pat, va_list *args) #endif PerlIO *serr = Perl_error_log; - PerlIO_write(serr, message, msglen); + PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen); (void)PerlIO_flush(serr); #ifdef USE_SFIO errno = e; @@ -1812,7 +1330,7 @@ Perl_vwarn(pTHX_ const char* pat, va_list *args) { PerlIO *serr = Perl_error_log; - PerlIO_write(serr, message, msglen); + PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen); #ifdef LEAKTEST DEBUG_L(*message == '!' ? (xstat(message[1]=='!' @@ -1891,9 +1409,9 @@ Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args) message = SvPV(msv, msglen); if (ckDEAD(err)) { -#ifdef USE_THREADS +#ifdef USE_5005THREADS DEBUG_S(PerlIO_printf(Perl_debug_log, "croak: 0x%"UVxf" %s", PTR2UV(thr), message)); -#endif /* USE_THREADS */ +#endif /* USE_5005THREADS */ if (PL_diehook) { /* sv_2cv might call Perl_croak() */ SV *olddiehook = PL_diehook; @@ -1927,7 +1445,7 @@ Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args) } { PerlIO *serr = Perl_error_log; - PerlIO_write(serr, message, msglen); + PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen); (void)PerlIO_flush(serr); } my_failure_exit(); @@ -1964,7 +1482,7 @@ Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args) } { PerlIO *serr = Perl_error_log; - PerlIO_write(serr, message, msglen); + PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen); #ifdef LEAKTEST DEBUG_L(*message == '!' ? (xstat(message[1]=='!' @@ -1978,15 +1496,26 @@ Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args) } } +/* since we've already done strlen() for both nam and val + * we can use that info to make things faster than + * sprintf(s, "%s=%s", nam, val) + */ +#define my_setenv_format(s, nam, nlen, val, vlen) \ + Copy(nam, s, nlen, char); \ + *(s+nlen) = '='; \ + Copy(val, s+(nlen+1), vlen, char); \ + *(s+(nlen+1+vlen)) = '\0' + #ifdef USE_ENVIRON_ARRAY /* VMS' and EPOC's my_setenv() is in vms.c and epoc.c */ -#if !defined(WIN32) +#if !defined(WIN32) && !defined(NETWARE) void Perl_my_setenv(pTHX_ 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? */ + int nlen, vlen; if (environ == PL_origenviron) { /* need we copy environment? */ I32 j; @@ -1997,8 +1526,9 @@ Perl_my_setenv(pTHX_ char *nam, char *val) for (max = i; environ[max]; max++) ; tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*)); for (j=0; j= 0) did_pipes = 1; - while ((pid = vfork()) < 0) { + while ((pid = PerlProc_fork()) < 0) { if (errno != EAGAIN) { PerlLIO_close(p[This]); if (did_pipes) { @@ -2345,8 +1884,6 @@ Perl_my_popen_list(pTHX_ char *mode, int n, SV **args) } if (pid == 0) { /* Child */ - GV* tmpgv; - int fd; #undef THIS #undef THAT #define THIS that @@ -2368,12 +1905,16 @@ Perl_my_popen_list(pTHX_ char *mode, int n, SV **args) } #if !defined(HAS_FCNTL) || !defined(F_SETFD) /* No automatic close - do it by hand */ -#ifndef NOFILE -#define NOFILE 20 -#endif - for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) { - if (fd != pp[1]) - PerlLIO_close(fd); +# ifndef NOFILE +# define NOFILE 20 +# endif + { + int fd; + + for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) { + if (fd != pp[1]) + PerlLIO_close(fd); + } } #endif do_aexec5(Nullsv, args-1, args-1+n, pp[1], did_pipes); @@ -2382,7 +1923,7 @@ Perl_my_popen_list(pTHX_ char *mode, int n, SV **args) #undef THAT } /* Parent */ - do_execfree(); /* free any memory malloced by child on vfork */ + do_execfree(); /* free any memory malloced by child on fork */ /* Close child's end of pipe */ PerlLIO_close(p[that]); if (did_pipes) @@ -2463,7 +2004,7 @@ Perl_my_popen(pTHX_ char *cmd, char *mode) return Nullfp; if (doexec && PerlProc_pipe(pp) >= 0) did_pipes = 1; - while ((pid = (doexec?vfork():fork())) < 0) { + while ((pid = PerlProc_fork()) < 0) { if (errno != EAGAIN) { PerlLIO_close(p[This]); if (did_pipes) { @@ -2502,11 +2043,16 @@ Perl_my_popen(pTHX_ char *cmd, char *mode) #ifndef NOFILE #define NOFILE 20 #endif - for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) - if (fd != pp[1]) - PerlLIO_close(fd); + { + int fd; + + for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) + if (fd != pp[1]) + PerlLIO_close(fd); + } #endif - do_exec3(cmd,pp[1],did_pipes); /* may or may not use the shell */ + /* may or may not use the shell */ + do_exec3(cmd, pp[1], did_pipes); PerlProc__exit(1); } #endif /* defined OS2 */ @@ -2519,7 +2065,7 @@ Perl_my_popen(pTHX_ char *cmd, char *mode) #undef THIS #undef THAT } - do_execfree(); /* free any memory malloced by child on vfork */ + do_execfree(); /* free any memory malloced by child on fork */ PerlLIO_close(p[that]); if (did_pipes) PerlLIO_close(pp[1]); @@ -2564,7 +2110,7 @@ Perl_my_popen(pTHX_ char *cmd, char *mode) return PerlIO_fdopen(p[This], mode); } #else -#if defined(atarist) || defined(DJGPP) +#if defined(atarist) FILE *popen(); PerlIO * Perl_my_popen(pTHX_ char *cmd, char *mode) @@ -2576,10 +2122,72 @@ Perl_my_popen(pTHX_ char *cmd, char *mode) */ return PerlIO_importFILE(popen(cmd, mode), 0); } +#else +#if defined(DJGPP) +FILE *djgpp_popen(); +PerlIO * +Perl_my_popen(pTHX_ char *cmd, char *mode) +{ + PERL_FLUSHALL_FOR_CHILD; + /* Call system's popen() to get a FILE *, then import it. + used 0 for 2nd parameter to PerlIO_importFILE; + apparently not used + */ + return PerlIO_importFILE(djgpp_popen(cmd, mode), 0); +} +#endif #endif #endif /* !DOSISH */ +/* this is called in parent before the fork() */ +void +Perl_atfork_lock(void) +{ +#if defined(USE_5005THREADS) || defined(USE_ITHREADS) + /* locks must be held in locking order (if any) */ +# ifdef MYMALLOC + MUTEX_LOCK(&PL_malloc_mutex); +# endif + OP_REFCNT_LOCK; +#endif +} + +/* this is called in both parent and child after the fork() */ +void +Perl_atfork_unlock(void) +{ +#if defined(USE_5005THREADS) || defined(USE_ITHREADS) + /* locks must be released in same order as in atfork_lock() */ +# ifdef MYMALLOC + MUTEX_UNLOCK(&PL_malloc_mutex); +# endif + OP_REFCNT_UNLOCK; +#endif +} + +Pid_t +Perl_my_fork(void) +{ +#if defined(HAS_FORK) + Pid_t pid; +#if (defined(USE_5005THREADS) || defined(USE_ITHREADS)) && !defined(HAS_PTHREAD_ATFORK) + atfork_lock(); + pid = fork(); + atfork_unlock(); +#else + /* atfork_lock() and atfork_unlock() are installed as pthread_atfork() + * handlers elsewhere in the code */ + pid = fork(); +#endif + return pid; +#else + /* this "canna happen" since nothing should be calling here if !HAS_FORK */ + Perl_croak_nocontext("fork() not available"); + return 0; +#endif /* HAS_FORK */ +} + #ifdef DUMP_FDS void Perl_dump_fds(pTHX_ char *s) @@ -2701,7 +2309,8 @@ Perl_rsignal(pTHX_ int signo, Sighandler_t handler) return PerlProc_signal(signo, handler); } -static int sig_trapped; +static int sig_trapped; /* XXX signals are process-wide anyway, so we + ignore the implications of this for threading */ static Signal_t @@ -2750,7 +2359,7 @@ Perl_my_pclose(pTHX_ PerlIO *ptr) Pid_t pid; Pid_t pid2; bool close_failed; - int saved_errno; + int saved_errno = 0; #ifdef VMS int saved_vaxc_errno; #endif @@ -2802,17 +2411,18 @@ Perl_my_pclose(pTHX_ PerlIO *ptr) } #endif /* !DOSISH */ -#if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL) +#if (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(MACOS_TRADITIONAL) I32 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) + { SV *sv; SV** svp; char spid[TYPE_CHARS(int)]; - 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); @@ -2834,6 +2444,7 @@ Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags) (void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD); return pid; } + } } #endif #ifdef HAS_WAITPID @@ -2862,7 +2473,7 @@ Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags) } #endif } -#endif /* !DOSISH || OS2 || WIN32 */ +#endif /* !DOSISH || OS2 || WIN32 || NETWARE */ void /*SUPPRESS 590*/ @@ -2878,7 +2489,7 @@ Perl_pidgone(pTHX_ Pid_t pid, int status) return; } -#if defined(atarist) || defined(OS2) || defined(DJGPP) +#if defined(atarist) || defined(OS2) int pclose(); #ifdef HAS_FORK int /* Cannot prototype with I32 @@ -2892,9 +2503,20 @@ Perl_my_pclose(pTHX_ PerlIO *ptr) /* Needs work for PerlIO ! */ FILE *f = PerlIO_findFILE(ptr); I32 result = pclose(f); + PerlIO_releaseFILE(ptr,f); + return result; +} +#endif + #if defined(DJGPP) +int djgpp_pclose(); +I32 +Perl_my_pclose(pTHX_ PerlIO *ptr) +{ + /* Needs work for PerlIO ! */ + FILE *f = PerlIO_findFILE(ptr); + I32 result = djgpp_pclose(f); result = (result << 8) & 0xff00; -#endif PerlIO_releaseFILE(ptr,f); return result; } @@ -2920,85 +2542,6 @@ Perl_repeatcpy(pTHX_ register char *to, register const char *from, I32 len, regi } } -U32 -Perl_cast_ulong(pTHX_ NV f) -{ - long along; - -#if CASTFLAGS & 2 -# define BIGDOUBLE 2147483648.0 - if (f >= BIGDOUBLE) - return (unsigned long)(f-(long)(f/BIGDOUBLE)*BIGDOUBLE)|0x80000000; -#endif - if (f >= 0.0) - return (unsigned long)f; - along = (long)f; - return (unsigned long)along; -} -# undef BIGDOUBLE - -/* Unfortunately, on some systems the cast_uv() function doesn't - work with the system-supplied definition of ULONG_MAX. The - comparison (f >= ULONG_MAX) always comes out true. It must be a - problem with the compiler constant folding. - - In any case, this workaround should be fine on any two's complement - system. If it's not, supply a '-DMY_ULONG_MAX=whatever' in your - ccflags. - --Andy Dougherty -*/ - -/* Code modified to prefer proper named type ranges, I32, IV, or UV, instead - of LONG_(MIN/MAX). - -- Kenneth Albanowski -*/ - -#ifndef MY_UV_MAX -# define MY_UV_MAX ((UV)IV_MAX * (UV)2 + (UV)1) -#endif - -I32 -Perl_cast_i32(pTHX_ NV f) -{ - if (f >= I32_MAX) - return (I32) I32_MAX; - if (f <= I32_MIN) - return (I32) I32_MIN; - return (I32) f; -} - -IV -Perl_cast_iv(pTHX_ NV f) -{ - if (f >= IV_MAX) { - UV uv; - - if (f >= (NV)UV_MAX) - return (IV) UV_MAX; - uv = (UV) f; - return (IV)uv; - } - if (f <= IV_MIN) - return (IV) IV_MIN; - return (IV) f; -} - -UV -Perl_cast_uv(pTHX_ NV f) -{ - if (f >= MY_UV_MAX) - return (UV) MY_UV_MAX; - if (f < 0) { - IV iv; - - if (f < IV_MIN) - return (UV)IV_MIN; - iv = (IV) f; - return (UV) iv; - } - return (UV) f; -} - #ifndef HAS_RENAME I32 Perl_same_dirent(pTHX_ char *a, char *b) @@ -3036,216 +2579,6 @@ Perl_same_dirent(pTHX_ char *a, char *b) } #endif /* !HAS_RENAME */ -NV -Perl_scan_bin(pTHX_ char *start, STRLEN len, STRLEN *retlen) -{ - register char *s = start; - register NV rnv = 0.0; - register UV ruv = 0; - register bool seenb = FALSE; - register bool overflowed = FALSE; - - for (; len-- && *s; s++) { - if (!(*s == '0' || *s == '1')) { - 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; - } - else { - if (ckWARN(WARN_DIGIT)) - Perl_warner(aTHX_ WARN_DIGIT, - "Illegal binary digit '%c' ignored", *s); - break; - } - } - if (!overflowed) { - register UV xuv = ruv << 1; - - if ((xuv >> 1) != ruv) { - overflowed = TRUE; - rnv = (NV) ruv; - if (ckWARN_d(WARN_OVERFLOW)) - Perl_warner(aTHX_ WARN_OVERFLOW, - "Integer overflow in binary number"); - } - else - ruv = xuv | (*s - '0'); - } - if (overflowed) { - rnv *= 2; - /* If an NV has not enough bits in its mantissa to - * represent an UV this summing of small low-order numbers - * is a waste of time (because the NV cannot preserve - * the low-order bits anyway): we could just remember when - * did we overflow and in the end just multiply rnv by the - * right amount. */ - rnv += (*s - '0'); - } - } - if (!overflowed) - rnv = (NV) ruv; - if ( ( overflowed && rnv > 4294967295.0) -#if UVSIZE > 4 - || (!overflowed && ruv > 0xffffffff ) -#endif - ) { - if (ckWARN(WARN_PORTABLE)) - Perl_warner(aTHX_ WARN_PORTABLE, - "Binary number > 0b11111111111111111111111111111111 non-portable"); - } - *retlen = s - start; - return rnv; -} - -NV -Perl_scan_oct(pTHX_ char *start, STRLEN len, STRLEN *retlen) -{ - register char *s = start; - register NV rnv = 0.0; - register UV ruv = 0; - register bool overflowed = FALSE; - - for (; len-- && *s; s++) { - if (!(*s >= '0' && *s <= '7')) { - 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 - * someone seems to want to use the digits eight and nine). */ - if (*s == '8' || *s == '9') { - if (ckWARN(WARN_DIGIT)) - Perl_warner(aTHX_ WARN_DIGIT, - "Illegal octal digit '%c' ignored", *s); - } - break; - } - } - if (!overflowed) { - register UV xuv = ruv << 3; - - if ((xuv >> 3) != ruv) { - overflowed = TRUE; - rnv = (NV) ruv; - if (ckWARN_d(WARN_OVERFLOW)) - Perl_warner(aTHX_ WARN_OVERFLOW, - "Integer overflow in octal number"); - } - else - ruv = xuv | (*s - '0'); - } - if (overflowed) { - rnv *= 8.0; - /* If an NV has not enough bits in its mantissa to - * represent an UV this summing of small low-order numbers - * is a waste of time (because the NV cannot preserve - * the low-order bits anyway): we could just remember when - * did we overflow and in the end just multiply rnv by the - * right amount of 8-tuples. */ - rnv += (NV)(*s - '0'); - } - } - if (!overflowed) - rnv = (NV) ruv; - if ( ( overflowed && rnv > 4294967295.0) -#if UVSIZE > 4 - || (!overflowed && ruv > 0xffffffff ) -#endif - ) { - if (ckWARN(WARN_PORTABLE)) - Perl_warner(aTHX_ WARN_PORTABLE, - "Octal number > 037777777777 non-portable"); - } - *retlen = s - start; - return rnv; -} - -NV -Perl_scan_hex(pTHX_ char *start, STRLEN len, STRLEN *retlen) -{ - register char *s = start; - register NV rnv = 0.0; - register UV ruv = 0; - register bool overflowed = FALSE; - char *hexdigit; - - if (len > 2) { - if (s[0] == 'x') { - s++; - len--; - } - else if (len > 3 && s[0] == '0' && s[1] == 'x') { - s+=2; - len-=2; - } - } - - for (; len-- && *s; s++) { - hexdigit = strchr((char *) PL_hexdigit, *s); - if (!hexdigit) { - if (*s == '_' && len && *retlen && s[1] - && (hexdigit = strchr((char *) PL_hexdigit, s[1]))) - { - --len; - ++s; - } - else { - if (ckWARN(WARN_DIGIT)) - Perl_warner(aTHX_ WARN_DIGIT, - "Illegal hexadecimal digit '%c' ignored", *s); - break; - } - } - if (!overflowed) { - register UV xuv = ruv << 4; - - if ((xuv >> 4) != ruv) { - overflowed = TRUE; - rnv = (NV) ruv; - if (ckWARN_d(WARN_OVERFLOW)) - Perl_warner(aTHX_ WARN_OVERFLOW, - "Integer overflow in hexadecimal number"); - } - else - ruv = xuv | ((hexdigit - PL_hexdigit) & 15); - } - if (overflowed) { - rnv *= 16.0; - /* If an NV has not enough bits in its mantissa to - * represent an UV this summing of small low-order numbers - * is a waste of time (because the NV cannot preserve - * the low-order bits anyway): we could just remember when - * did we overflow and in the end just multiply rnv by the - * right amount of 16-tuples. */ - rnv += (NV)((hexdigit - PL_hexdigit) & 15); - } - } - if (!overflowed) - rnv = (NV) ruv; - if ( ( overflowed && rnv > 4294967295.0) -#if UVSIZE > 4 - || (!overflowed && ruv > 0xffffffff ) -#endif - ) { - if (ckWARN(WARN_PORTABLE)) - Perl_warner(aTHX_ WARN_PORTABLE, - "Hexadecimal number > 0xffffffff non-portable"); - } - *retlen = s - start; - return rnv; -} - char* Perl_find_script(pTHX_ char *scriptname, bool dosearch, char **search_ext, I32 flags) { @@ -3482,18 +2815,18 @@ Perl_find_script(pTHX_ char *scriptname, bool dosearch, char **search_ext, I32 f void * Perl_get_context(void) { -#if defined(USE_THREADS) || defined(USE_ITHREADS) +#if defined(USE_5005THREADS) || 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 +# ifdef I_MACH_CTHREADS return (void*)cthread_data(cthread_self()); -# else - return (void*)pthread_getspecific(PL_thr_key); -# endif +# else + return (void*)PTHREAD_GETSPECIFIC(PL_thr_key); +# endif # endif #else return (void*)NULL; @@ -3503,7 +2836,7 @@ Perl_get_context(void) void Perl_set_context(void *t) { -#if defined(USE_THREADS) || defined(USE_ITHREADS) +#if defined(USE_5005THREADS) || defined(USE_ITHREADS) # ifdef I_MACH_CTHREADS cthread_set_data(cthread_self(), t); # else @@ -3515,7 +2848,7 @@ Perl_set_context(void *t) #endif /* !PERL_GET_CONTEXT_DEFINED */ -#ifdef USE_THREADS +#ifdef USE_5005THREADS #ifdef FAKE_THREADS /* Very simplistic scheduler for now */ @@ -3596,8 +2929,8 @@ Perl_condpair_magic(pTHX_ SV *sv) { MAGIC *mg; - SvUPGRADE(sv, SVt_PVMG); - mg = mg_find(sv, 'm'); + (void)SvUPGRADE(sv, SVt_PVMG); + mg = mg_find(sv, PERL_MAGIC_mutex); if (!mg) { condpair_t *cp; @@ -3607,7 +2940,7 @@ Perl_condpair_magic(pTHX_ SV *sv) COND_INIT(&cp->cond); cp->owner = 0; LOCK_CRED_MUTEX; /* XXX need separate mutex? */ - mg = mg_find(sv, 'm'); + mg = mg_find(sv, PERL_MAGIC_mutex); if (mg) { /* someone else beat us to initialising it */ UNLOCK_CRED_MUTEX; /* XXX need separate mutex? */ @@ -3617,13 +2950,13 @@ Perl_condpair_magic(pTHX_ SV *sv) Safefree(cp); } else { - sv_magic(sv, Nullsv, 'm', 0, 0); + sv_magic(sv, Nullsv, PERL_MAGIC_mutex, 0, 0); mg = SvMAGIC(sv); mg->mg_ptr = (char *)cp; mg->mg_len = sizeof(cp); UNLOCK_CRED_MUTEX; /* XXX need separate mutex? */ DEBUG_S(WITH_THR(PerlIO_printf(Perl_debug_log, - "%p: condpair_magic %p\n", thr, sv));) + "%p: condpair_magic %p\n", thr, sv))); } } return mg; @@ -3650,7 +2983,7 @@ Perl_sv_lock(pTHX_ SV *osv) MgOWNER(mg) = thr; DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": Perl_lock lock 0x%"UVxf"\n", - PTR2UV(thr), PTR2UV(sv));) + PTR2UV(thr), PTR2UV(sv))); MUTEX_UNLOCK(MgMUTEXP(mg)); SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv); } @@ -3729,6 +3062,8 @@ Perl_new_struct_thread(pTHX_ struct perl_thread *t) PL_reg_start_tmpl = 0; PL_reg_poscache = Nullch; + PL_peepp = MEMBER_TO_FPTR(Perl_peep); + /* parent thread's data needs to be locked while we make copy */ MUTEX_LOCK(&t->mutex); @@ -3742,8 +3077,7 @@ Perl_new_struct_thread(pTHX_ struct perl_thread *t) PL_tainted = t->Ttainted; PL_curpm = t->Tcurpm; /* XXX No PMOP ref count */ - PL_nrs = newSVsv(t->Tnrs); - PL_rs = t->Tnrs ? SvREFCNT_inc(PL_nrs) : Nullsv; + PL_rs = newSVsv(t->Trs); PL_last_in_gv = Nullgv; PL_ofs_sv = t->Tofs_sv ? SvREFCNT_inc(PL_ofs_sv) : Nullsv; PL_defoutgv = (GV*)SvREFCNT_inc(t->Tdefoutgv); @@ -3761,7 +3095,7 @@ Perl_new_struct_thread(pTHX_ struct perl_thread *t) if (*svp && *svp != &PL_sv_undef) { SV *sv = newSVsv(*svp); av_store(thr->threadsv, i, sv); - sv_magic(sv, 0, 0, &PL_threadsv_names[i], 1); + sv_magic(sv, 0, PERL_MAGIC_sv, &PL_threadsv_names[i], 1); DEBUG_S(PerlIO_printf(Perl_debug_log, "new_struct_thread: copied threadsv %"IVdf" %p->%p\n", (IV)i, t, thr)); @@ -3786,23 +3120,7 @@ Perl_new_struct_thread(pTHX_ struct perl_thread *t) #endif /* HAVE_THREAD_INTERN */ return thr; } -#endif /* USE_THREADS */ - -#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. - * Needed for SunOS with Sun's 'acc' for example. - */ -NV -Perl_huge(void) -{ -# if defined(USE_LONG_DOUBLE) && defined(HUGE_VALL) - return HUGE_VALL; -# endif - return HUGE_VAL; -} -#endif +#endif /* USE_5005THREADS */ #ifdef PERL_GLOBAL_STRUCT struct perl_vars * @@ -3923,7 +3241,7 @@ Perl_get_vtbl(pTHX_ int vtbl_id) case want_vtbl_uvar: result = &PL_vtbl_uvar; break; -#ifdef USE_THREADS +#ifdef USE_5005THREADS case want_vtbl_mutex: result = &PL_vtbl_mutex; break; @@ -3969,28 +3287,28 @@ Perl_my_fflush_all(pTHX) extern void _fwalk(int (*)(FILE *)); _fwalk(&fflush); return 0; -# else - long open_max = -1; +# else # if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY) + long open_max = -1; # ifdef PERL_FFLUSH_ALL_FOPEN_MAX open_max = PERL_FFLUSH_ALL_FOPEN_MAX; # else -# if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX) +# if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX) open_max = sysconf(_SC_OPEN_MAX); -# else -# ifdef FOPEN_MAX +# else +# ifdef FOPEN_MAX open_max = FOPEN_MAX; -# else -# ifdef OPEN_MAX +# else +# ifdef OPEN_MAX open_max = OPEN_MAX; -# else -# ifdef _NFILE +# else +# ifdef _NFILE open_max = _NFILE; +# endif +# endif # endif # endif # endif -# endif -# endif if (open_max > 0) { long i; for (i = 0; i < open_max; i++) @@ -4007,29 +3325,6 @@ Perl_my_fflush_all(pTHX) #endif } -NV -Perl_my_atof(pTHX_ const char* s) -{ - NV x = 0.0; -#ifdef USE_LOCALE_NUMERIC - if ((PL_hints & HINT_LOCALE) && PL_numeric_local) { - NV y; - - Perl_atof2(s, x); - SET_NUMERIC_STANDARD(); - Perl_atof2(s, y); - SET_NUMERIC_LOCAL(); - if ((y < 0.0 && y < x) || (y > 0.0 && y > x)) - return y; - } - else - Perl_atof2(s, x); -#else - Perl_atof2(s, x); -#endif - return x; -} - void Perl_report_evil_fh(pTHX_ GV *gv, IO *io, I32 op) { @@ -4040,11 +3335,12 @@ Perl_report_evil_fh(pTHX_ GV *gv, IO *io, I32 op) 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) ? + char *type = OP_IS_SOCKET(op) || + (gv && io && IoTYPE(io) == IoTYPE_SOCKET) ? "socket" : "filehandle"; char *name = NULL; - if (io && IoTYPE(io) == IoTYPE_CLOSED) { + if (gv && io && IoTYPE(io) == IoTYPE_CLOSED) { vile = "closed"; warn_type = WARN_CLOSED; } @@ -4078,7 +3374,7 @@ Perl_report_evil_fh(pTHX_ GV *gv, IO *io, I32 op) else { Perl_warner(aTHX_ warn_type, "%s%s on %s %s", func, pars, vile, type); - if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP)) + if (gv && 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); @@ -4125,16 +3421,6 @@ Perl_ebcdic_control(pTHX_ int ch) } #endif -#ifdef HAS_TZNAME -# if !defined(WIN32) && !defined(__CYGWIN__) -extern char *tzname[]; -# endif -#else -#if !defined(WIN32) || (defined(__MINGW32__) && !defined(tzname)) -char *tzname[] = { "" , "" }; -#endif -#endif - /* XXX struct tm on some systems (SunOS4/BSD) contains extra (non POSIX) * fields for which we don't have Configure support yet: * char *tm_zone; -- abbreviation of timezone name @@ -4156,7 +3442,7 @@ char *tzname[] = { "" , "" }; #endif void -init_tm(struct tm *ptm) /* see mktime, strftime and asctime */ +Perl_init_tm(pTHX_ struct tm *ptm) /* see mktime, strftime and asctime */ { #ifdef STRUCT_TM_HASZONE Time_t now; @@ -4170,7 +3456,7 @@ init_tm(struct tm *ptm) /* see mktime, strftime and asctime */ * semantics (and overhead) of mktime(). */ void -mini_mktime(struct tm *ptm) +Perl_mini_mktime(pTHX_ struct tm *ptm) { int yearday; int secs; @@ -4363,7 +3649,7 @@ mini_mktime(struct tm *ptm) } char * -my_strftime(char *fmt, int sec, int min, int hour, int mday, int mon, int year, int wday, int yday, int isdst) +Perl_my_strftime(pTHX_ char *fmt, int sec, int min, int hour, int mday, int mon, int year, int wday, int yday, int isdst) { #ifdef HAS_STRFTIME char *buf; @@ -4386,7 +3672,7 @@ my_strftime(char *fmt, int sec, int min, int hour, int mday, int mon, int year, New(0, buf, buflen, char); len = strftime(buf, buflen, fmt, &mytm); /* - ** The following is needed to handle to the situation where + ** The following is needed to handle to the situation where ** tmpbuf overflows. Basically we want to allocate a buffer ** and try repeatedly. The reason why it is so complicated ** is that getting a return value of 0 from strftime can indicate @@ -4405,7 +3691,7 @@ my_strftime(char *fmt, int sec, int min, int hour, int mday, int mon, int year, /* Possibly buf overflowed - try again with a bigger buf */ int fmtlen = strlen(fmt); int bufsize = fmtlen + buflen; - + New(0, buf, bufsize, char); while (buf) { buflen = strftime(buf, bufsize, fmt, &mytm); @@ -4427,3 +3713,174 @@ my_strftime(char *fmt, int sec, int min, int hour, int mday, int mon, int year, #endif } + +#define SV_CWD_RETURN_UNDEF \ +sv_setsv(sv, &PL_sv_undef); \ +return FALSE + +#define SV_CWD_ISDOT(dp) \ + (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \ + (dp->d_name[1] == '.' && dp->d_name[2] == '\0'))) + +/* +=for apidoc getcwd_sv + +Fill the sv with current working directory + +=cut +*/ + +/* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars. + * rewritten again by dougm, optimized for use with xs TARG, and to prefer + * getcwd(3) if available + * Comments from the orignal: + * This is a faster version of getcwd. It's also more dangerous + * because you might chdir out of a directory that you can't chdir + * back into. */ + +int +Perl_getcwd_sv(pTHX_ register SV *sv) +{ +#ifndef PERL_MICRO + +#ifndef INCOMPLETE_TAINTS + SvTAINTED_on(sv); +#endif + +#ifdef HAS_GETCWD + { + char buf[MAXPATHLEN]; + + /* Some getcwd()s automatically allocate a buffer of the given + * size from the heap if they are given a NULL buffer pointer. + * The problem is that this behaviour is not portable. */ + if (getcwd(buf, sizeof(buf) - 1)) { + STRLEN len = strlen(buf); + sv_setpvn(sv, buf, len); + return TRUE; + } + else { + sv_setsv(sv, &PL_sv_undef); + return FALSE; + } + } + +#else + + struct stat statbuf; + int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino; + int namelen, pathlen=0; + DIR *dir; + Direntry_t *dp; + + (void)SvUPGRADE(sv, SVt_PV); + + if (PerlLIO_lstat(".", &statbuf) < 0) { + SV_CWD_RETURN_UNDEF; + } + + orig_cdev = statbuf.st_dev; + orig_cino = statbuf.st_ino; + cdev = orig_cdev; + cino = orig_cino; + + for (;;) { + odev = cdev; + oino = cino; + + if (PerlDir_chdir("..") < 0) { + SV_CWD_RETURN_UNDEF; + } + if (PerlLIO_stat(".", &statbuf) < 0) { + SV_CWD_RETURN_UNDEF; + } + + cdev = statbuf.st_dev; + cino = statbuf.st_ino; + + if (odev == cdev && oino == cino) { + break; + } + if (!(dir = PerlDir_open("."))) { + SV_CWD_RETURN_UNDEF; + } + + while ((dp = PerlDir_read(dir)) != NULL) { +#ifdef DIRNAMLEN + namelen = dp->d_namlen; +#else + namelen = strlen(dp->d_name); +#endif + /* skip . and .. */ + if (SV_CWD_ISDOT(dp)) { + continue; + } + + if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) { + SV_CWD_RETURN_UNDEF; + } + + tdev = statbuf.st_dev; + tino = statbuf.st_ino; + if (tino == oino && tdev == odev) { + break; + } + } + + if (!dp) { + SV_CWD_RETURN_UNDEF; + } + + if (pathlen + namelen + 1 >= MAXPATHLEN) { + SV_CWD_RETURN_UNDEF; + } + + SvGROW(sv, pathlen + namelen + 1); + + if (pathlen) { + /* shift down */ + Move(SvPVX(sv), SvPVX(sv) + namelen + 1, pathlen, char); + } + + /* prepend current directory to the front */ + *SvPVX(sv) = '/'; + Move(dp->d_name, SvPVX(sv)+1, namelen, char); + pathlen += (namelen + 1); + +#ifdef VOID_CLOSEDIR + PerlDir_close(dir); +#else + if (PerlDir_close(dir) < 0) { + SV_CWD_RETURN_UNDEF; + } +#endif + } + + if (pathlen) { + SvCUR_set(sv, pathlen); + *SvEND(sv) = '\0'; + SvPOK_only(sv); + + if (PerlDir_chdir(SvPVX(sv)) < 0) { + SV_CWD_RETURN_UNDEF; + } + } + if (PerlLIO_stat(".", &statbuf) < 0) { + SV_CWD_RETURN_UNDEF; + } + + cdev = statbuf.st_dev; + cino = statbuf.st_ino; + + if (cdev != orig_cdev || cino != orig_cino) { + Perl_croak(aTHX_ "Unstable directory path, " + "current directory changed unexpectedly"); + } +#endif + + return TRUE; +#else + return FALSE; +#endif +} +