X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=util.c;h=ea84cdadab952a4dd27569006ed20cbbda177632;hb=2f30d0d0af5b459d5c0f4734d92d4b55e9dcc9b7;hp=7efbbd4886cc8fec39df1a08ec531d69b9275011;hpb=bef8a12803580c2fb97a03ebe6e7df3e52cd10bf;p=p5sagit%2Fp5-mst-13.2.git diff --git a/util.c b/util.c index 7efbbd4..ea84cda 100644 --- a/util.c +++ b/util.c @@ -1,7 +1,7 @@ /* util.c * - * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, - * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, by Larry Wall and others + * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, + * 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -9,8 +9,10 @@ */ /* - * "Very useful, no doubt, that was to Saruman; yet it seems that he was - * not content." --Gandalf + * 'Very useful, no doubt, that was to Saruman; yet it seems that he was + * not content.' --Gandalf to Pippin + * + * [p.598 of _The Lord of the Rings_, III/xi: "The Palantír"] */ /* This file contains assorted utility routines. @@ -274,12 +276,12 @@ Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size) if (size && (count <= MEM_SIZE_MAX / size)) total_size = size * count; else - Perl_croak_nocontext(PL_memory_wrap); + Perl_croak_nocontext("%s", PL_memory_wrap); #ifdef PERL_TRACK_MEMPOOL if (sTHX <= MEM_SIZE_MAX - (MEM_SIZE)total_size) total_size += sTHX; else - Perl_croak_nocontext(PL_memory_wrap); + Perl_croak_nocontext("%s", PL_memory_wrap); #endif #ifdef HAS_64K_LIMIT if (total_size > 0xffff) { @@ -1243,7 +1245,7 @@ Perl_write_to_stderr(pTHX_ const char* message, int msglen) if (PL_stderrgv && SvREFCNT(PL_stderrgv) && (io = GvIO(PL_stderrgv)) - && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) + && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) { dSP; ENTER; @@ -1257,7 +1259,7 @@ Perl_write_to_stderr(pTHX_ const char* message, int msglen) PUSHMARK(SP); EXTEND(SP,2); - PUSHs(SvTIED_obj((SV*)io, mg)); + PUSHs(SvTIED_obj(MUTABLE_SV(io), mg)); mPUSHp(message, msglen); PUTBACK; call_method("PRINT", G_SCALAR); @@ -1269,14 +1271,14 @@ Perl_write_to_stderr(pTHX_ const char* message, int msglen) else { #ifdef USE_SFIO /* SFIO can really mess with your errno */ - const int e = errno; + dSAVED_ERRNO; #endif PerlIO * const serr = Perl_error_log; PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen); (void)PerlIO_flush(serr); #ifdef USE_SFIO - errno = e; + RESTORE_ERRNO; #endif } } @@ -1324,7 +1326,7 @@ S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8, bool warn) PUSHMARK(SP); XPUSHs(msg); PUTBACK; - call_sv((SV*)cv, G_DISCARD); + call_sv(MUTABLE_SV(cv), G_DISCARD); POPSTACK; LEAVE; return TRUE; @@ -1360,8 +1362,8 @@ S_vdie_croak_common(pTHX_ const char* pat, va_list* args, STRLEN* msglen, return message; } -OP * -Perl_vdie(pTHX_ const char* pat, va_list *args) +static OP * +S_vdie(pTHX_ const char* pat, va_list *args) { dVAR; const char *message; @@ -1452,7 +1454,7 @@ sidestepping the normal C order of execution. 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); + errsv = get_sv("@", GV_ADD); sv_setsv(errsv, exception_object); croak(NULL); @@ -1665,9 +1667,16 @@ Perl_my_setenv(pTHX_ const char *nam, const char *val) #ifndef PERL_USE_SAFE_PUTENV if (!PL_use_safe_putenv) { /* most putenv()s leak, so we manipulate environ directly */ - register I32 i=setenv_getix(nam); /* where does it go? */ + register I32 i; + register const I32 len = strlen(nam); int nlen, vlen; + /* where does it go? */ + for (i = 0; environ[i]; i++) { + if (strnEQ(environ[i],nam,len) && environ[i][len] == '=') + break; + } + if (environ == PL_origenviron) { /* need we copy environment? */ I32 j; I32 max; @@ -1771,30 +1780,6 @@ Perl_my_setenv(pTHX_ const char *nam, const char *val) #endif /* WIN32 || NETWARE */ -#ifndef PERL_MICRO -I32 -Perl_setenv_getix(pTHX_ const char *nam) -{ - register I32 i; - register const I32 len = strlen(nam); - - PERL_ARGS_ASSERT_SETENV_GETIX; - PERL_UNUSED_CONTEXT; - - for (i = 0; environ[i]; i++) { - if ( -#ifdef WIN32 - strnicmp(environ[i],nam,len) == 0 -#else - strnEQ(environ[i],nam,len) -#endif - && environ[i][len] == '=') - break; /* strnEQ must come first to avoid */ - } /* potential SEGV's */ - return i; -} -#endif /* !PERL_MICRO */ - #endif /* !VMS && !EPOC*/ #ifdef UNLINK_ALL_VERSIONS @@ -2303,6 +2288,8 @@ Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args) } return NULL; } + if (ckWARN(WARN_PIPE)) + Perl_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds"); sleep(5); } if (pid == 0) { @@ -2448,9 +2435,11 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode) PerlLIO_close(pp[1]); } if (!doexec) - Perl_croak(aTHX_ "Can't fork"); + Perl_croak(aTHX_ "Can't fork: %s", Strerror(errno)); return NULL; } + if (ckWARN(WARN_PIPE)) + Perl_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds"); sleep(5); } if (pid == 0) { @@ -2877,10 +2866,7 @@ Perl_my_pclose(pTHX_ PerlIO *ptr) Pid_t pid; Pid_t pid2; bool close_failed; - int saved_errno = 0; -#ifdef WIN32 - int saved_win32_errno; -#endif + dSAVEDERRNO; LOCK_FDPID_MUTEX; svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE); @@ -2893,12 +2879,8 @@ Perl_my_pclose(pTHX_ PerlIO *ptr) return my_syspclose(ptr); } #endif - if ((close_failed = (PerlIO_close(ptr) == EOF))) { - saved_errno = errno; -#ifdef WIN32 - saved_win32_errno = GetLastError(); -#endif - } + close_failed = (PerlIO_close(ptr) == EOF); + SAVE_ERRNO; #ifdef UTS if(PerlProc_kill(pid, 0) < 0) { return(pid); } /* HOM 12/23/91 */ #endif @@ -2916,7 +2898,7 @@ Perl_my_pclose(pTHX_ PerlIO *ptr) rsignal_restore(SIGQUIT, &qstat); #endif if (close_failed) { - SETERRNO(saved_errno, 0); + RESTORE_ERRNO; return -1; } return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status)); @@ -3018,7 +3000,7 @@ Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags) #ifdef PERL_USES_PL_PIDSTATUS void -Perl_pidgone(pTHX_ Pid_t pid, int status) +S_pidgone(pTHX_ Pid_t pid, int status) { register SV *sv; @@ -3108,13 +3090,13 @@ Perl_same_dirent(pTHX_ const char *a, const char *b) if (strNE(a,b)) return FALSE; if (fa == a) - sv_setpvn(tmpsv, ".", 1); + sv_setpvs(tmpsv, "."); else sv_setpvn(tmpsv, a, fa - a); if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0) return FALSE; if (fb == b) - sv_setpvn(tmpsv, ".", 1); + sv_setpvs(tmpsv, "."); else sv_setpvn(tmpsv, b, fb - b); if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0) @@ -4305,11 +4287,11 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv) pos = s; if ( qv ) - (void)hv_stores((HV *)hv, "qv", newSViv(qv)); + (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(qv)); if ( alpha ) - (void)hv_stores((HV *)hv, "alpha", newSViv(alpha)); + (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(alpha)); if ( !qv && width < 3 ) - (void)hv_stores((HV *)hv, "width", newSViv(width)); + (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width)); while (isDIGIT(*pos)) pos++; @@ -4403,7 +4385,7 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv) Compiler in question is: gcc version 3.3 20030304 (Apple Computer, Inc. build 1640) for ( len = 2 - len; len > 0; len-- ) - av_push((AV *)sv, newSViv(0)); + av_push(MUTABLE_AV(sv), newSViv(0)); */ len = 2 - len; while (len-- > 0) @@ -4413,8 +4395,8 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv) /* need to save off the current version string for later */ if ( vinf ) { SV * orig = newSVpvn("v.Inf", sizeof("v.Inf")-1); - (void)hv_stores((HV *)hv, "original", orig); - (void)hv_stores((HV *)hv, "vinf", newSViv(1)); + (void)hv_stores(MUTABLE_HV(hv), "original", orig); + (void)hv_stores(MUTABLE_HV(hv), "vinf", newSViv(1)); } else if ( s > start ) { SV * orig = newSVpvn(start,s-start); @@ -4422,15 +4404,15 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv) /* need to insert a v to be consistent */ sv_insert(orig, 0, 0, "v", 1); } - (void)hv_stores((HV *)hv, "original", orig); + (void)hv_stores(MUTABLE_HV(hv), "original", orig); } else { - (void)hv_stores((HV *)hv, "original", newSVpvn("0",1)); + (void)hv_stores(MUTABLE_HV(hv), "original", newSVpvs("0")); av_push(av, newSViv(0)); } /* And finally, store the AV in the hash */ - (void)hv_stores((HV *)hv, "version", newRV_noinc((SV *)av)); + (void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av))); /* fix RT#19517 - special case 'undef' as string */ if ( *s == 'u' && strEQ(s,"undef") ) { @@ -4472,25 +4454,25 @@ Perl_new_version(pTHX_ SV *ver) ver = SvRV(ver); /* Begin copying all of the elements */ - if ( hv_exists((HV *)ver, "qv", 2) ) - (void)hv_stores((HV *)hv, "qv", newSViv(1)); + if ( hv_exists(MUTABLE_HV(ver), "qv", 2) ) + (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(1)); - if ( hv_exists((HV *)ver, "alpha", 5) ) - (void)hv_stores((HV *)hv, "alpha", newSViv(1)); + if ( hv_exists(MUTABLE_HV(ver), "alpha", 5) ) + (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(1)); - if ( hv_exists((HV*)ver, "width", 5 ) ) + if ( hv_exists(MUTABLE_HV(ver), "width", 5 ) ) { - const I32 width = SvIV(*hv_fetchs((HV*)ver, "width", FALSE)); - (void)hv_stores((HV *)hv, "width", newSViv(width)); + const I32 width = SvIV(*hv_fetchs(MUTABLE_HV(ver), "width", FALSE)); + (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width)); } - if ( hv_exists((HV*)ver, "original", 8 ) ) + if ( hv_exists(MUTABLE_HV(ver), "original", 8 ) ) { - SV * pv = *hv_fetchs((HV*)ver, "original", FALSE); - (void)hv_stores((HV *)hv, "original", newSVsv(pv)); + SV * pv = *hv_fetchs(MUTABLE_HV(ver), "original", FALSE); + (void)hv_stores(MUTABLE_HV(hv), "original", newSVsv(pv)); } - sav = (AV *)SvRV(*hv_fetchs((HV*)ver, "version", FALSE)); + sav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(ver), "version", FALSE))); /* This will get reblessed later if a derived class*/ for ( key = 0; key <= av_len(sav); key++ ) { @@ -4498,7 +4480,7 @@ Perl_new_version(pTHX_ SV *ver) av_push(av, newSViv(rev)); } - (void)hv_stores((HV *)hv, "version", newRV_noinc((SV *)av)); + (void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av))); return rv; } #ifdef SvVOK @@ -4646,8 +4628,8 @@ Perl_vverify(pTHX_ SV *vs) /* see if the appropriate elements exist */ if ( SvTYPE(vs) == SVt_PVHV - && hv_exists((HV*)vs, "version", 7) - && (sv = SvRV(*hv_fetchs((HV*)vs, "version", FALSE))) + && hv_exists(MUTABLE_HV(vs), "version", 7) + && (sv = SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE))) && SvTYPE(sv) == SVt_PVAV ) return TRUE; else @@ -4686,16 +4668,16 @@ Perl_vnumify(pTHX_ SV *vs) Perl_croak(aTHX_ "Invalid version object"); /* see if various flags exist */ - if ( hv_exists((HV*)vs, "alpha", 5 ) ) + if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) ) alpha = TRUE; - if ( hv_exists((HV*)vs, "width", 5 ) ) - width = SvIV(*hv_fetchs((HV*)vs, "width", FALSE)); + if ( hv_exists(MUTABLE_HV(vs), "width", 5 ) ) + width = SvIV(*hv_fetchs(MUTABLE_HV(vs), "width", FALSE)); else width = 3; /* attempt to retrieve the version array */ - if ( !(av = (AV *)SvRV(*hv_fetchs((HV*)vs, "version", FALSE)) ) ) { + if ( !(av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE))) ) ) { sv_catpvs(sv,"0"); return sv; } @@ -4766,9 +4748,9 @@ Perl_vnormal(pTHX_ SV *vs) if ( !vverify(vs) ) Perl_croak(aTHX_ "Invalid version object"); - if ( hv_exists((HV*)vs, "alpha", 5 ) ) + if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) ) alpha = TRUE; - av = (AV *)SvRV(*hv_fetchs((HV*)vs, "version", FALSE)); + av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE))); len = av_len(av); if ( len == -1 ) @@ -4822,16 +4804,16 @@ Perl_vstringify(pTHX_ SV *vs) if ( !vverify(vs) ) Perl_croak(aTHX_ "Invalid version object"); - if (hv_exists((HV*)vs, "original", sizeof("original") - 1)) { + if (hv_exists(MUTABLE_HV(vs), "original", sizeof("original") - 1)) { SV *pv; - pv = *hv_fetchs((HV*)vs, "original", FALSE); + pv = *hv_fetchs(MUTABLE_HV(vs), "original", FALSE); if ( SvPOK(pv) ) return newSVsv(pv); else return &PL_sv_undef; } else { - if ( hv_exists((HV *)vs, "qv", 2) ) + if ( hv_exists(MUTABLE_HV(vs), "qv", 2) ) return vnormal(vs); else return vnumify(vs); @@ -4871,13 +4853,13 @@ Perl_vcmp(pTHX_ SV *lhv, SV *rhv) Perl_croak(aTHX_ "Invalid version object"); /* get the left hand term */ - lav = (AV *)SvRV(*hv_fetchs((HV*)lhv, "version", FALSE)); - if ( hv_exists((HV*)lhv, "alpha", 5 ) ) + lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(lhv), "version", FALSE))); + if ( hv_exists(MUTABLE_HV(lhv), "alpha", 5 ) ) lalpha = TRUE; /* and the right hand term */ - rav = (AV *)SvRV(*hv_fetchs((HV*)rhv, "version", FALSE)); - if ( hv_exists((HV*)rhv, "alpha", 5 ) ) + rav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(rhv), "version", FALSE))); + if ( hv_exists(MUTABLE_HV(rhv), "alpha", 5 ) ) ralpha = TRUE; l = av_len(lav); @@ -5067,12 +5049,12 @@ S_socketpair_udp (int fd[2]) { errno = ECONNABORTED; tidy_up_and_fail: { - const int save_errno = errno; + dSAVE_ERRNO; if (sockets[0] != -1) PerlLIO_close(sockets[0]); if (sockets[1] != -1) PerlLIO_close(sockets[1]); - errno = save_errno; + RESTORE_ERRNO; return -1; } } @@ -5171,14 +5153,14 @@ Perl_my_socketpair (int family, int type, int protocol, int fd[2]) { #endif tidy_up_and_fail: { - const int save_errno = errno; + dSAVE_ERRNO; if (listener != -1) PerlLIO_close(listener); if (connector != -1) PerlLIO_close(connector); if (acceptor != -1) PerlLIO_close(acceptor); - errno = save_errno; + RESTORE_ERRNO; return -1; } } @@ -5586,7 +5568,7 @@ S_mem_log_common(enum mem_log_type mlt, const UV n, const UV typesize, const cha (void)time(&when); # endif /* If there are other OS specific ways of hires time than - * gettimeofday() (see ext/Time/HiRes), the easiest way is + * gettimeofday() (see ext/Time-HiRes), the easiest way is * probably that they would be used to fill in the struct * timeval. */ # endif @@ -6005,10 +5987,11 @@ Perl_get_db_sub(pTHX_ SV **svp, CV *cv) if ( svp && ((CvFLAGS(cv) & (CVf_ANON | CVf_CLONED)) || strEQ(GvNAME(gv), "END") || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */ - !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv) )))) { + !( (SvTYPE(*svp) == SVt_PVGV) + && (GvCV((const GV *)*svp) == cv) )))) { /* Use GV from the stack as a fallback. */ /* GV is potentially non-unique, or contain different CV. */ - SV * const tmp = newRV((SV*)cv); + SV * const tmp = newRV(MUTABLE_SV(cv)); sv_setsv(dbsv, tmp); SvREFCNT_dec(tmp); } @@ -6050,7 +6033,7 @@ Perl_get_re_arg(pTHX_ SV *sv) { if (SvMAGICAL(sv)) mg_get(sv); if (SvROK(sv) && - (tmpsv = (SV*)SvRV(sv)) && /* assign deliberate */ + (tmpsv = MUTABLE_SV(SvRV(sv))) && /* assign deliberate */ SvTYPE(tmpsv) == SVt_REGEXP) { return (REGEXP*) tmpsv;