X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=util.c;h=923907087084e601d0e4c46fc37ba90c37d00fa9;hb=7d654f43b92f51303a8d5388d3c3bfb7ebbceb22;hp=59c287f55e60146db1aa4367f93cf0691a46658e;hpb=cd57dc11b379d64c4f58020ac5a49cbd7893e35a;p=p5sagit%2Fp5-mst-13.2.git diff --git a/util.c b/util.c index 59c287f..9239070 100644 --- a/util.c +++ b/util.c @@ -92,19 +92,32 @@ Perl_safesysmalloc(MEM_SIZE 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) { + if (ptr != NULL) { #ifdef PERL_TRACK_MEMPOOL - ((struct perl_memory_debug_header *)ptr)->interpreter = aTHX; + struct perl_memory_debug_header *const header + = (struct perl_memory_debug_header *)ptr; +#endif + +#ifdef PERL_POISON + PoisonNew(((char *)ptr), size, char); +#endif + +#ifdef PERL_TRACK_MEMPOOL + header->interpreter = aTHX; + /* Link us into the list. */ + header->prev = &PL_memory_debug_header; + header->next = PL_memory_debug_header.next; + PL_memory_debug_header.next = header; + header->next->prev = header; # ifdef PERL_POISON - ((struct perl_memory_debug_header *)ptr)->size = size; - ((struct perl_memory_debug_header *)ptr)->in_use = PERL_POISON_INUSE; + header->size = size; # endif ptr = (Malloc_t)((char*)ptr+sTHX); #endif return ptr; } else if (PL_nomemok) - return Nullch; + return NULL; else { return write_no_mem(); } @@ -139,18 +152,24 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size) #ifdef PERL_TRACK_MEMPOOL where = (Malloc_t)((char*)where-sTHX); size += sTHX; - if (((struct perl_memory_debug_header *)where)->interpreter != aTHX) { - Perl_croak_nocontext("panic: realloc from wrong pool"); - } + { + struct perl_memory_debug_header *const header + = (struct perl_memory_debug_header *)where; + + if (header->interpreter != aTHX) { + Perl_croak_nocontext("panic: realloc from wrong pool"); + } + assert(header->next->prev == header); + assert(header->prev->next == header); # ifdef PERL_POISON - if (((struct perl_memory_debug_header *)where)->size > size) { - const MEM_SIZE freed_up = - ((struct perl_memory_debug_header *)where)->size - size; - char *start_of_freed = ((char *)where) + size; - Poison(start_of_freed, freed_up, char); - } - ((struct perl_memory_debug_header *)where)->size = size; + if (header->size > size) { + const MEM_SIZE freed_up = header->size - size; + char *start_of_freed = ((char *)where) + size; + PoisonFree(start_of_freed, freed_up, char); + } + header->size = size; # endif + } #endif #ifdef DEBUGGING if ((long)size < 0) @@ -162,14 +181,28 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE 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) { + if (ptr != NULL) { #ifdef PERL_TRACK_MEMPOOL + struct perl_memory_debug_header *const header + = (struct perl_memory_debug_header *)ptr; + +# ifdef PERL_POISON + if (header->size < size) { + const MEM_SIZE fresh = size - header->size; + char *start_of_fresh = ((char *)ptr) + size; + PoisonNew(start_of_fresh, fresh, char); + } +# endif + + header->next->prev = header; + header->prev->next = header; + ptr = (Malloc_t)((char*)ptr+sTHX); #endif return ptr; } else if (PL_nomemok) - return Nullch; + return NULL; else { return write_no_mem(); } @@ -190,24 +223,29 @@ Perl_safesysfree(Malloc_t where) if (where) { #ifdef PERL_TRACK_MEMPOOL where = (Malloc_t)((char*)where-sTHX); - if (((struct perl_memory_debug_header *)where)->interpreter != aTHX) { - Perl_croak_nocontext("panic: free from wrong pool"); - } -# ifdef PERL_POISON { - if (((struct perl_memory_debug_header *)where)->in_use - == PERL_POISON_FREE) { + struct perl_memory_debug_header *const header + = (struct perl_memory_debug_header *)where; + + if (header->interpreter != aTHX) { + Perl_croak_nocontext("panic: free from wrong pool"); + } + if (!header->prev) { Perl_croak_nocontext("panic: duplicate free"); } - if (((struct perl_memory_debug_header *)where)->in_use - != PERL_POISON_INUSE) { - Perl_croak_nocontext("panic: bad free "); + if (!(header->next) || header->next->prev != header + || header->prev->next != header) { + Perl_croak_nocontext("panic: bad free"); } - ((struct perl_memory_debug_header *)where)->in_use - = PERL_POISON_FREE; - } - Poison(where, ((struct perl_memory_debug_header *)where)->size, char); + /* Unlink us from the chain. */ + header->next->prev = header->prev; + header->prev->next = header->next; +# ifdef PERL_POISON + PoisonNew(where, header->size, char); # endif + /* Trigger the duplicate free warning. */ + header->next = NULL; + } #endif PerlMem_free(where); } @@ -239,20 +277,29 @@ Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE 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) { + if (ptr != NULL) { memset((void*)ptr, 0, size); #ifdef PERL_TRACK_MEMPOOL - ((struct perl_memory_debug_header *)ptr)->interpreter = aTHX; + { + struct perl_memory_debug_header *const header + = (struct perl_memory_debug_header *)ptr; + + header->interpreter = aTHX; + /* Link us into the list. */ + header->prev = &PL_memory_debug_header; + header->next = PL_memory_debug_header.next; + PL_memory_debug_header.next = header; + header->next->prev = header; # ifdef PERL_POISON - ((struct perl_memory_debug_header *)ptr)->size = size; - ((struct perl_memory_debug_header *)ptr)->in_use = PERL_POISON_INUSE; + header->size = size; # endif - ptr = (Malloc_t)((char*)ptr+sTHX); + ptr = (Malloc_t)((char*)ptr+sTHX); + } #endif return ptr; } else if (PL_nomemok) - return Nullch; + return NULL; return write_no_mem(); } @@ -293,6 +340,7 @@ char * Perl_delimcpy(pTHX_ register char *to, register const char *toend, register const char *from, register const char *fromend, register int delim, I32 *retlen) { register I32 tolen; + PERL_UNUSED_CONTEXT; for (tolen = 0; from < fromend; from++, tolen++) { if (*from == '\\') { if (from[1] == delim) @@ -322,6 +370,7 @@ char * Perl_instr(pTHX_ register const char *big, register const char *little) { register I32 first; + PERL_UNUSED_CONTEXT; if (!little) return (char*)big; @@ -334,7 +383,7 @@ Perl_instr(pTHX_ register const char *big, register const char *little) continue; for (x=big,s=little; *s; /**/ ) { if (!*x) - return Nullch; + return NULL; if (*s != *x) break; else { @@ -345,7 +394,7 @@ Perl_instr(pTHX_ register const char *big, register const char *little) if (!*s) return (char*)(big-1); } - return Nullch; + return NULL; } /* same as instr but allow embedded nulls */ @@ -353,6 +402,7 @@ Perl_instr(pTHX_ register const char *big, register const char *little) char * Perl_ninstr(pTHX_ const char *big, const char *bigend, const char *little, const char *lend) { + PERL_UNUSED_CONTEXT; if (little >= lend) return (char*)big; { @@ -370,7 +420,7 @@ Perl_ninstr(pTHX_ const char *big, const char *bigend, const char *little, const return (char*)(big-1); } } - return Nullch; + return NULL; } /* reverse of the above--find last substring */ @@ -381,6 +431,7 @@ Perl_rninstr(pTHX_ register const char *big, const char *bigend, const char *lit register const char *bigbeg; register const I32 first = *little; register const char * const littleend = lend; + PERL_UNUSED_CONTEXT; if (little >= littleend) return (char*)bigend; @@ -401,7 +452,7 @@ Perl_rninstr(pTHX_ register const char *big, const char *bigend, const char *lit if (s >= littleend) return (char*)(big+1); } - return Nullch; + return NULL; } #define FBM_TABLE_OFFSET 2 /* Number of bytes between EOS and table*/ @@ -461,7 +512,7 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags) s--, i++; } } - sv_magic(sv, Nullsv, PERL_MAGIC_bm, Nullch, 0); /* deep magic */ + sv_magic(sv, NULL, PERL_MAGIC_bm, NULL, 0); /* deep magic */ SvVALID_on(sv); s = (const unsigned char*)(SvPVX_const(sv)); /* deeper magic */ @@ -488,7 +539,7 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags) =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 +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. @@ -512,7 +563,7 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit || (*big == *little && memEQ((char *)big, (char *)little, littlelen - 1)))) return (char*)big; - return Nullch; + return NULL; } if (littlelen <= 2) { /* Special-cased */ @@ -532,7 +583,7 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit } if (SvTAIL(littlestr)) return (char *) bigend; - return Nullch; + return NULL; } if (!littlelen) return (char*)big; /* Cannot be SvTAIL! */ @@ -543,7 +594,7 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit return (char*)bigend - 2; if (bigend[-1] == *little) return (char*)bigend - 1; - return Nullch; + return NULL; } { /* This should be better than FBM if c1 == c2, and almost @@ -596,7 +647,7 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit check_1char_anchor: /* One char and anchor! */ if (SvTAIL(littlestr) && (*bigend == *little)) return (char *)bigend; /* bigend is already decremented. */ - return Nullch; + return NULL; } if (SvTAIL(littlestr) && !multiline) { /* tail anchored? */ s = bigend - littlelen; @@ -611,7 +662,7 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit { return (char*)s + 1; /* how sweet it is */ } - return Nullch; + return NULL; } if (SvTYPE(littlestr) != SVt_PVBM || !SvVALID(littlestr)) { char * const b = ninstr((char*)big,(char*)bigend, @@ -625,7 +676,7 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit { return (char*)s; } - return Nullch; + return NULL; } return b; } @@ -635,7 +686,7 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit register const unsigned char *oldlittle; if (littlelen > (STRLEN)(bigend - big)) - return Nullch; + return NULL; --littlelen; /* Last char found by table lookup */ s = big + littlelen; @@ -672,7 +723,7 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit && memEQ((char *)(bigend - littlelen), (char *)(oldlittle - littlelen), littlelen) ) return (char*)bigend - littlelen; - return Nullch; + return NULL; } } @@ -715,7 +766,7 @@ Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift first = *little++; goto check_tail; } - return Nullch; + return NULL; } little = (const unsigned char *)(SvPVX_const(littlestr)); @@ -735,7 +786,7 @@ Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift if (previous + start_shift == stop_pos + 1) /* A fake '\n'? */ goto check_tail; #endif - return Nullch; + return NULL; } while (pos < previous + start_shift) { if (!(pos += PL_screamnext[pos])) @@ -763,7 +814,7 @@ Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift return (char *)(big+(*old_posp)); check_tail: if (!SvTAIL(littlestr) || (end_shift > 0)) - return Nullch; + return NULL; /* Ignore the trailing "\n". This code is not microoptimized */ big = (const unsigned char *)(SvPVX_const(bigstr) + SvCUR(bigstr)); stop_pos = littleend - little; /* Actual littlestr len */ @@ -774,7 +825,7 @@ Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift && ((stop_pos == 1) || memEQ((char *)(big + 1), (char *)little, stop_pos - 1))) return (char*)big; - return Nullch; + return NULL; } I32 @@ -782,6 +833,8 @@ Perl_ibcmp(pTHX_ const char *s1, const char *s2, register I32 len) { register const U8 *a = (const U8 *)s1; register const U8 *b = (const U8 *)s2; + PERL_UNUSED_CONTEXT; + while (len--) { if (*a != *b && *a != PL_fold[*b]) return 1; @@ -796,6 +849,8 @@ Perl_ibcmp_locale(pTHX_ const char *s1, const char *s2, register I32 len) dVAR; register const U8 *a = (const U8 *)s1; register const U8 *b = (const U8 *)s2; + PERL_UNUSED_CONTEXT; + while (len--) { if (*a != *b && *a != PL_fold_locale[*b]) return 1; @@ -822,15 +877,15 @@ be freed with the C function. char * Perl_savepv(pTHX_ const char *pv) { + PERL_UNUSED_CONTEXT; if (!pv) - return Nullch; + return NULL; else { char *newaddr; const STRLEN pvlen = strlen(pv)+1; Newx(newaddr,pvlen,char); return memcpy(newaddr,pv,pvlen); } - } /* same thing but with a known length */ @@ -850,6 +905,7 @@ char * Perl_savepvn(pTHX_ const char *pv, register I32 len) { register char *newaddr; + PERL_UNUSED_CONTEXT; Newx(newaddr,len+1,char); /* Give a meaning to NULL pointer mainly for the use in sv_magic() */ @@ -877,7 +933,7 @@ Perl_savesharedpv(pTHX_ const char *pv) register char *newaddr; STRLEN pvlen; if (!pv) - return Nullch; + return NULL; pvlen = strlen(pv)+1; newaddr = (char*)PerlMemShared_malloc(pvlen); @@ -984,7 +1040,7 @@ char * Perl_vform(pTHX_ const char *pat, va_list *args) { SV * const sv = mess_alloc(); - sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); + sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL); return SvPVX(sv); } @@ -1013,8 +1069,8 @@ Perl_mess(pTHX_ const char *pat, ...) return retval; } -STATIC COP* -S_closest_cop(pTHX_ COP *cop, const OP *o) +STATIC const COP* +S_closest_cop(pTHX_ const COP *cop, const OP *o) { dVAR; /* Look for PL_op starting from o. cop is the last COP we've seen. */ @@ -1023,15 +1079,15 @@ S_closest_cop(pTHX_ COP *cop, const OP *o) return cop; if (o->op_flags & OPf_KIDS) { - OP *kid; + const OP *kid; for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) { - COP *new_cop; + const 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; + cop = (const COP *)kid; /* Keep searching, and return when we've found something. */ @@ -1043,7 +1099,7 @@ S_closest_cop(pTHX_ COP *cop, const OP *o) /* Nothing found. */ - return Null(COP *); + return NULL; } SV * @@ -1051,11 +1107,9 @@ Perl_vmess(pTHX_ const char *pat, va_list *args) { dVAR; SV * const sv = mess_alloc(); - static const char dgd[] = " during global destruction.\n"; - sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); + sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL); if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') { - /* * 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 @@ -1064,7 +1118,8 @@ Perl_vmess(pTHX_ const char *pat, va_list *args) */ const COP *cop = closest_cop(PL_curcop, PL_curcop->op_sibling); - if (!cop) cop = PL_curcop; + if (!cop) + cop = PL_curcop; if (CopLINE(cop)) Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf, @@ -1073,12 +1128,13 @@ Perl_vmess(pTHX_ const char *pat, va_list *args) const bool line_mode = (RsSIMPLE(PL_rs) && SvCUR(PL_rs) == 1 && *SvPVX_const(PL_rs) == '\n'); Perl_sv_catpvf(aTHX_ sv, ", <%s> %s %"IVdf, - PL_last_in_gv == PL_argvgv ? - "" : GvNAME(PL_last_in_gv), + PL_last_in_gv == PL_argvgv ? "" : GvNAME(PL_last_in_gv), line_mode ? "line" : "chunk", (IV)IoLINES(GvIOp(PL_last_in_gv))); } - sv_catpv(sv, PL_dirty ? dgd : ".\n"); + if (PL_dirty) + sv_catpvs(sv, " during global destruction"); + sv_catpvs(sv, ".\n"); } return sv; } @@ -1100,7 +1156,7 @@ Perl_write_to_stderr(pTHX_ const char* message, int msglen) save_re_context(); SAVESPTR(PL_stderrgv); - PL_stderrgv = Nullgv; + PL_stderrgv = NULL; PUSHSTACKi(PERLSI_MAGIC); @@ -1130,23 +1186,25 @@ Perl_write_to_stderr(pTHX_ const char* message, int msglen) } } -/* Common code used by vcroak, vdie and vwarner */ +/* Common code used by vcroak, vdie, vwarn and vwarner */ -STATIC void -S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8) +STATIC bool +S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8, bool warn) { dVAR; HV *stash; GV *gv; CV *cv; - /* sv_2cv might call Perl_croak() */ - SV * const olddiehook = PL_diehook; + SV **const hook = warn ? &PL_warnhook : &PL_diehook; + /* sv_2cv might call Perl_croak() or Perl_warner() */ + SV * const oldhook = *hook; + + assert(oldhook); - assert(PL_diehook); ENTER; - SAVESPTR(PL_diehook); - PL_diehook = Nullsv; - cv = sv_2cv(olddiehook, &stash, &gv, 0); + SAVESPTR(*hook); + *hook = NULL; + cv = sv_2cv(oldhook, &stash, &gv, 0); LEAVE; if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) { dSP; @@ -1154,7 +1212,11 @@ S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8) ENTER; save_re_context(); - if (message) { + if (warn) { + SAVESPTR(*hook); + *hook = NULL; + } + if (warn || message) { msg = newSVpvn(message, msglen); SvFLAGS(msg) |= utf8; SvREADONLY_on(msg); @@ -1164,14 +1226,16 @@ S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8) msg = ERRSV; } - PUSHSTACKi(PERLSI_DIEHOOK); + PUSHSTACKi(warn ? PERLSI_WARNHOOK : PERLSI_DIEHOOK); PUSHMARK(SP); XPUSHs(msg); PUTBACK; call_sv((SV*)cv, G_DISCARD); POPSTACK; LEAVE; + return TRUE; } + return FALSE; } STATIC const char * @@ -1193,14 +1257,14 @@ S_vdie_croak_common(pTHX_ const char* pat, va_list* args, STRLEN* msglen, *utf8 = SvUTF8(msv); } else { - message = Nullch; + message = NULL; } DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: die/croak: message = %s\ndiehook = %p\n", thr, message, PL_diehook)); if (PL_diehook) { - S_vdie_common(aTHX_ message, *msglen, *utf8); + S_vdie_common(aTHX_ message, *msglen, *utf8, FALSE); } return message; } @@ -1301,11 +1365,11 @@ function. Calling C returns control directly to Perl, 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(): +C<$@> and then pass C to croak(): errsv = get_sv("@", TRUE); sv_setsv(errsv, exception_object); - croak(Nullch); + croak(NULL); =cut */ @@ -1330,39 +1394,8 @@ Perl_vwarn(pTHX_ const char* pat, va_list *args) const char * const message = SvPV_const(msv, msglen); if (PL_warnhook) { - /* sv_2cv might call Perl_warn() */ - SV * const oldwarnhook = PL_warnhook; - CV * cv; - HV * stash; - GV * gv; - - ENTER; - SAVESPTR(PL_warnhook); - PL_warnhook = Nullsv; - cv = sv_2cv(oldwarnhook, &stash, &gv, 0); - LEAVE; - if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) { - dSP; - SV *msg; - - ENTER; - SAVESPTR(PL_warnhook); - PL_warnhook = Nullsv; - save_re_context(); - msg = newSVpvn(message, msglen); - SvFLAGS(msg) |= utf8; - SvREADONLY_on(msg); - SAVEFREESV(msg); - - PUSHSTACKi(PERLSI_WARNHOOK); - PUSHMARK(SP); - XPUSHs(msg); - PUTBACK; - call_sv((SV*)cv, G_DISCARD); - POPSTACK; - LEAVE; + if (vdie_common(message, msglen, utf8, TRUE)) return; - } } write_to_stderr(message, msglen); @@ -1431,7 +1464,7 @@ Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args) if (PL_diehook) { assert(message); - S_vdie_common(aTHX_ message, msglen, utf8); + S_vdie_common(aTHX_ message, msglen, utf8, FALSE); } if (PL_in_eval) { PL_restartop = die_where(message, msglen); @@ -1540,7 +1573,7 @@ Perl_my_setenv(pTHX_ const char *nam, const char *val) tmpenv[j] = (char*)safesysmalloc((len+1)*sizeof(char)); Copy(environ[j], tmpenv[j], len+1, char); } - tmpenv[max] = Nullch; + tmpenv[max] = NULL; environ = tmpenv; /* tell exec where it is now */ } if (!val) { @@ -1553,7 +1586,7 @@ Perl_my_setenv(pTHX_ const char *nam, const char *val) } if (!environ[i]) { /* does not exist yet */ environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*)); - environ[i+1] = Nullch; /* make sure it's null terminated */ + environ[i+1] = NULL; /* make sure it's null terminated */ } else safesysfree(environ[i]); @@ -1635,6 +1668,7 @@ Perl_setenv_getix(pTHX_ const char *nam) { register I32 i; register const I32 len = strlen(nam); + PERL_UNUSED_CONTEXT; for (i = 0; environ[i]; i++) { if ( @@ -2099,7 +2133,7 @@ Perl_my_popen_list(pTHX_ char *mode, int n, SV **args) taint_proper("Insecure %s%s", "EXEC"); } if (PerlProc_pipe(p) < 0) - return Nullfp; + return NULL; /* Try for another pipe pair for error return */ if (PerlProc_pipe(pp) >= 0) did_pipes = 1; @@ -2111,7 +2145,7 @@ Perl_my_popen_list(pTHX_ char *mode, int n, SV **args) PerlLIO_close(pp[0]); PerlLIO_close(pp[1]); } - return Nullfp; + return NULL; } sleep(5); } @@ -2152,7 +2186,7 @@ Perl_my_popen_list(pTHX_ char *mode, int n, SV **args) } } #endif - do_aexec5(Nullsv, args-1, args-1+n, pp[1], did_pipes); + do_aexec5(NULL, args-1, args-1+n, pp[1], did_pipes); PerlProc__exit(1); #undef THIS #undef THAT @@ -2200,7 +2234,7 @@ Perl_my_popen_list(pTHX_ char *mode, int n, SV **args) pid2 = wait4pid(pid, &status, 0); } while (pid2 == -1 && errno == EINTR); errno = errkid; /* Propagate errno from kid */ - return Nullfp; + return NULL; } } if (did_pipes) @@ -2239,7 +2273,7 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode) taint_proper("Insecure %s%s", "EXEC"); } if (PerlProc_pipe(p) < 0) - return Nullfp; + return NULL; if (doexec && PerlProc_pipe(pp) >= 0) did_pipes = 1; while ((pid = PerlProc_fork()) < 0) { @@ -2252,7 +2286,7 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode) } if (!doexec) Perl_croak(aTHX_ "Can't fork"); - return Nullfp; + return NULL; } sleep(5); } @@ -2296,7 +2330,7 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode) PerlProc__exit(1); } #endif /* defined OS2 */ - if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) { + if ((tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV))) { SvREADONLY_off(GvSV(tmpgv)); sv_setiv(GvSV(tmpgv), PerlProc_getpid()); SvREADONLY_on(GvSV(tmpgv)); @@ -2308,7 +2342,7 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode) #ifdef PERL_USES_PL_PIDSTATUS hv_clear(PL_pidstatus); /* we have no children */ #endif - return Nullfp; + return NULL; #undef THIS #undef THAT } @@ -2352,7 +2386,7 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode) pid2 = wait4pid(pid, &status, 0); } while (pid2 == -1 && errno == EINTR); errno = errkid; /* Propagate errno from kid */ - return Nullfp; + return NULL; } } if (did_pipes) @@ -2532,6 +2566,7 @@ Sighandler_t Perl_rsignal_state(pTHX_ int signo) { struct sigaction oact; + PERL_UNUSED_CONTEXT; if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1) return (Sighandler_t) SIG_ERR; @@ -2758,7 +2793,7 @@ Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags) goto finish; #endif #if !defined(HAS_WAITPID) && defined(HAS_WAIT4) - result = wait4((pid==-1)?0:pid,statusp,flags,Null(struct rusage *)); + result = wait4((pid==-1)?0:pid,statusp,flags,NULL); goto finish; #endif #ifdef PERL_USES_PL_PIDSTATUS @@ -2837,6 +2872,7 @@ Perl_repeatcpy(pTHX_ register char *to, register const char *from, I32 len, regi { register I32 todo; register const char * const frombase = from; + PERL_UNUSED_CONTEXT; if (len == 1) { register const char c = *from; @@ -2894,8 +2930,8 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch, const char *const *const search_ext, I32 flags) { dVAR; - const char *xfound = Nullch; - char *xfailed = Nullch; + const char *xfound = NULL; + char *xfailed = NULL; char tmpbuf[MAXPATHLEN]; register char *s; I32 len = 0; @@ -2917,7 +2953,7 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch, static const char *const exts[] = { SEARCH_EXTS }; const char *const *const ext = search_ext ? search_ext : exts; int extidx = 0, i = 0; - const char *curext = Nullch; + const char *curext = NULL; #else PERL_UNUSED_ARG(search_ext); # define MAX_EXT_LEN 0 @@ -2950,13 +2986,13 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch, int idx = 0, deftypes = 1; bool seen_dot = 1; - const int hasdir = !dosearch || (strpbrk(scriptname,":[mg_len; - char * const version = savepvn( (const char*)mg->mg_ptr, len); - sv_setpvn(rv,version,len); - Safefree(version); - } - else { + { + const MAGIC* const mg = SvVOK(ver); + if ( mg ) { /* already a v-string */ + const STRLEN len = mg->mg_len; + char * const version = savepvn( (const char*)mg->mg_ptr, len); + sv_setpvn(rv,version,len); + Safefree(version); + } + else { #endif - sv_setsv(rv,ver); /* make a duplicate */ + sv_setsv(rv,ver); /* make a duplicate */ #ifdef SvVOK + } } #endif - upg_version(rv); - return rv; + return upg_version(rv); } /* @@ -4227,6 +4269,9 @@ Perl_upg_version(pTHX_ SV *ver) { const char *version, *s; bool qv = 0; +#ifdef SvVOK + const MAGIC *mg; +#endif if ( SvNOK(ver) ) /* may get too much accuracy */ { @@ -4235,8 +4280,7 @@ Perl_upg_version(pTHX_ SV *ver) version = savepvn(tbuf, len); } #ifdef SvVOK - else if ( SvVOK(ver) ) { /* already a v-string */ - const MAGIC* const mg = mg_find(ver,PERL_MAGIC_vstring); + else if ( (mg = SvVOK(ver)) ) { /* already a v-string */ version = savepvn( (const char*)mg->mg_ptr,mg->mg_len ); qv = 1; } @@ -4246,9 +4290,11 @@ Perl_upg_version(pTHX_ SV *ver) version = savepv(SvPV_nolen(ver)); } s = scan_version(version, ver, qv); - if ( *s != '\0' ) - Perl_warn(aTHX_ "Version string '%s' contains invalid data; " - "ignoring: '%s'", version, s); + if ( *s != '\0' ) + if(ckWARN(WARN_MISC)) + Perl_warner(aTHX_ packWARN(WARN_MISC), + "Version string '%s' contains invalid data; " + "ignoring: '%s'", version, s); Safefree(version); return ver; } @@ -4286,7 +4332,7 @@ 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_fetch((HV*)vs, "version", 7, FALSE))) + && (sv = SvRV(*hv_fetchs((HV*)vs, "version", FALSE))) && SvTYPE(sv) == SVt_PVAV ) return TRUE; else @@ -4325,13 +4371,13 @@ Perl_vnumify(pTHX_ SV *vs) if ( hv_exists((HV*)vs, "alpha", 5 ) ) alpha = TRUE; if ( hv_exists((HV*)vs, "width", 5 ) ) - width = SvIV(*hv_fetch((HV*)vs, "width", 5, FALSE)); + width = SvIV(*hv_fetchs((HV*)vs, "width", FALSE)); else width = 3; /* attempt to retrieve the version array */ - if ( !(av = (AV *)SvRV(*hv_fetch((HV*)vs, "version", 7, FALSE)) ) ) { + if ( !(av = (AV *)SvRV(*hv_fetchs((HV*)vs, "version", FALSE)) ) ) { sv_catpvs(sv,"0"); return sv; } @@ -4401,7 +4447,7 @@ Perl_vnormal(pTHX_ SV *vs) if ( hv_exists((HV*)vs, "alpha", 5 ) ) alpha = TRUE; - av = (AV *)SvRV(*hv_fetch((HV*)vs, "version", 7, FALSE)); + av = (AV *)SvRV(*hv_fetchs((HV*)vs, "version", FALSE)); len = av_len(av); if ( len == -1 ) @@ -4489,12 +4535,12 @@ Perl_vcmp(pTHX_ SV *lhv, SV *rhv) Perl_croak(aTHX_ "Invalid version object"); /* get the left hand term */ - lav = (AV *)SvRV(*hv_fetch((HV*)lhv, "version", 7, FALSE)); + lav = (AV *)SvRV(*hv_fetchs((HV*)lhv, "version", FALSE)); if ( hv_exists((HV*)lhv, "alpha", 5 ) ) lalpha = TRUE; /* and the right hand term */ - rav = (AV *)SvRV(*hv_fetch((HV*)rhv, "version", 7, FALSE)); + rav = (AV *)SvRV(*hv_fetchs((HV*)rhv, "version", FALSE)); if ( hv_exists((HV*)rhv, "alpha", 5 ) ) ralpha = TRUE; @@ -4630,8 +4676,8 @@ S_socketpair_udp (int fd[2]) { fd_set rset; FD_ZERO(&rset); - FD_SET(sockets[0], &rset); - FD_SET(sockets[1], &rset); + FD_SET((unsigned int)sockets[0], &rset); + FD_SET((unsigned int)sockets[1], &rset); got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor); if (got != 2 || !FD_ISSET(sockets[0], &rset) @@ -4828,6 +4874,7 @@ potentially warn under some level of strict-ness. void Perl_sv_nosharing(pTHX_ SV *sv) { + PERL_UNUSED_CONTEXT; PERL_UNUSED_ARG(sv); } @@ -5011,6 +5058,7 @@ Perl_stashpv_hvname_match(pTHX_ const COP *c, const HV *hv) { const char * const stashpv = CopSTASHPV(c); const char * const name = HvNAME_get(hv); + PERL_UNUSED_CONTEXT; if (stashpv == name) return TRUE;