X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=util.c;h=0c26f8310bb4ae78c9f2f211c7b06ff968d0ae52;hb=8fc173423e29547f0d1de6373cac1b08dfb0c024;hp=e0f1f14a90031f483b27ff4eb6ef09d24a975d17;hpb=cc9b67681954df413fe79f7c379e7b91a3121259;p=p5sagit%2Fp5-mst-13.2.git diff --git a/util.c b/util.c index e0f1f14..0c26f83 100644 --- a/util.c +++ b/util.c @@ -659,6 +659,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 = @@ -666,6 +668,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 = @@ -673,6 +677,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 */ } @@ -689,14 +695,20 @@ 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 */ } @@ -808,15 +820,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); @@ -829,9 +842,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; } @@ -1896,14 +1922,20 @@ 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 */ +#ifdef USE_ENVIRON_ARRAY + /* VMS' and EPOC's my_setenv() is in vms.c and epoc.c */ #if !defined(WIN32) && !defined(__CYGWIN__) void Perl_my_setenv(pTHX_ char *nam, char *val) @@ -2070,7 +2102,7 @@ Perl_setenv_getix(pTHX_ char *nam) return i; } -#endif /* !VMS */ +#endif /* !VMS && !EPOC*/ #ifdef UNLINK_ALL_VERSIONS I32 @@ -2402,9 +2434,9 @@ Perl_my_popen(pTHX_ char *cmd, char *mode) PerlLIO_close(p[This]); p[This] = p[that]; } - MUTEX_LOCK(&PL_fdpid_mutex); + LOCK_FDPID_MUTEX; sv = *av_fetch(PL_fdpid,p[This],TRUE); - MUTEX_UNLOCK(&PL_fdpid_mutex); + UNLOCK_FDPID_MUTEX; (void)SvUPGRADE(sv,SVt_IV); SvIVX(sv) = pid; PL_forkprocess = pid; @@ -2622,9 +2654,9 @@ Perl_my_pclose(pTHX_ PerlIO *ptr) int saved_win32_errno; #endif - MUTEX_LOCK(&PL_fdpid_mutex); + LOCK_FDPID_MUTEX; svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE); - MUTEX_UNLOCK(&PL_fdpid_mutex); + UNLOCK_FDPID_MUTEX; pid = SvIVX(*svp); SvREFCNT_dec(*svp); *svp = &PL_sv_undef; @@ -2676,6 +2708,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); @@ -2698,6 +2731,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) @@ -3497,33 +3531,32 @@ Perl_condpair_magic(pTHX_ SV *sv) } SV * -Perl_lock(pTHX_ SV *osv) +Perl_sv_lock(pTHX_ SV *osv) { MAGIC *mg; SV *sv = osv; - SvLOCK(osv); + LOCK_SV_LOCK_MUTEX; if (SvROK(sv)) { sv = SvRV(sv); - SvUNLOCK(osv); - SvLOCK(sv); } mg = condpair_magic(sv); MUTEX_LOCK(MgMUTEXP(mg)); if (MgOWNER(mg) == thr) MUTEX_UNLOCK(MgMUTEXP(mg)); - else { + 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", + 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); } - SvUNLOCK(sv); - return sv; + UNLOCK_SV_LOCK_MUTEX; + return sv; } /* @@ -3574,7 +3607,7 @@ Perl_new_struct_thread(pTHX_ struct perl_thread *t) 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); @@ -3869,41 +3902,69 @@ Perl_my_fflush_all(pTHX) 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 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_closed_fh(pTHX_ GV *gv, IO *io, const char *func, const char *obj) -{ - SV *sv; - char *name; - - assert(gv); - - sv = sv_newmortal(); - gv_efullname3(sv, gv, Nullch); - name = SvPVX(sv); +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; + } - Perl_warner(aTHX_ WARN_CLOSED, "%s() on closed %s %s", func, obj, name); + if (gv && isGV(gv)) { + SV *sv = sv_newmortal(); + gv_efullname4(sv, gv, Nullch, FALSE); + name = SvPVX(sv); + } - if (io && IoDIRP(io)) - Perl_warner(aTHX_ WARN_CLOSED, - "\t(Are you trying to call %s() on dirhandle %s?)\n", - func, name); + 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); + } }