X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/a7cb70fb771fb5beedde33170ea9e6b2b2c36bf9..4cec2b33f0aa04d807b9b31c6b4212fe462cd7d4:/util.c diff --git a/util.c b/util.c index 824b3a0..6e39cb6 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, by Larry Wall and others + * 2000, 2001, 2002, 2003, 2004, 2005, 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. @@ -13,6 +13,12 @@ * not content." --Gandalf */ +/* This file contains assorted utility routines. + * Which is a polite way of saying any stuff that people couldn't think of + * a better place for. Amongst other things, it includes the warning and + * dieing stuff, plus wrappers for malloc code. + */ + #include "EXTERN.h" #define PERL_IN_UTIL_C #include "perl.h" @@ -24,6 +30,11 @@ #endif #endif +#ifdef __Lynx__ +/* Missing protos on LynxOS */ +int putenv(char *); +#endif + #ifdef I_SYS_WAIT # include #endif @@ -135,12 +146,12 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size) Free_t Perl_safesysfree(Malloc_t where) { + dVAR; #ifdef PERL_IMPLICIT_SYS dTHX; #endif DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) free\n",PTR2UV(where),(long)PL_an++)); if (where) { - /*SUPPRESS 701*/ PerlMem_free(where); } } @@ -218,7 +229,7 @@ Free_t Perl_mfree (Malloc_t where) /* copy a string up to some (non-backslashed) delimiter, if any */ char * -Perl_delimcpy(pTHX_ register char *to, register char *toend, register char *from, register char *fromend, register int delim, I32 *retlen) +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; for (tolen = 0; from < fromend; from++, tolen++) { @@ -240,7 +251,7 @@ Perl_delimcpy(pTHX_ register char *to, register char *toend, register char *from if (to < toend) *to = '\0'; *retlen = tolen; - return from; + return (char *)from; } /* return ptr to little string in big string, NULL if not found */ @@ -249,7 +260,6 @@ Perl_delimcpy(pTHX_ register char *to, register char *toend, register char *from char * Perl_instr(pTHX_ register const char *big, register const char *little) { - register const char *s, *x; register I32 first; if (!little) @@ -258,6 +268,7 @@ Perl_instr(pTHX_ register const char *big, register const char *little) if (!first) return (char*)big; while (*big) { + register const char *s, *x; if (*big++ != first) continue; for (x=big,s=little; *s; /**/ ) { @@ -279,8 +290,7 @@ Perl_instr(pTHX_ register const char *big, register const char *little) char * Perl_ninstr(pTHX_ register const char *big, register const char *bigend, const char *little, const char *lend) { - register const char *s, *x; - register I32 first = *little; + register const I32 first = *little; register const char *littleend = lend; if (!first && little >= littleend) @@ -289,6 +299,7 @@ Perl_ninstr(pTHX_ register const char *big, register const char *bigend, const c return Nullch; bigend -= littleend - little++; while (big <= bigend) { + register const char *s, *x; if (*big++ != first) continue; for (x=big,s=little; s < littleend; /**/ ) { @@ -309,8 +320,7 @@ char * Perl_rninstr(pTHX_ register const char *big, const char *bigend, const char *little, const char *lend) { register const char *bigbeg; - register const char *s, *x; - register I32 first = *little; + register const I32 first = *little; register const char *littleend = lend; if (!first && little >= littleend) @@ -318,6 +328,7 @@ Perl_rninstr(pTHX_ register const char *big, const char *bigend, const char *lit bigbeg = big; big = bigend - (littleend - little++); while (big >= bigbeg) { + register const char *s, *x; if (*big-- != first) continue; for (x=big+2,s=little; s < littleend; /**/ ) { @@ -354,33 +365,29 @@ Analyses the string in order to make fast searches on it using fbm_instr() void Perl_fbm_compile(pTHX_ SV *sv, U32 flags) { - register U8 *s; - register U8 *table; + const register U8 *s; register U32 i; STRLEN len; I32 rarest = 0; U32 frequency = 256; if (flags & FBMcf_TAIL) { - MAGIC *mg = SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL; + MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL; sv_catpvn(sv, "\n", 1); /* Taken into account in fbm_instr() */ if (mg && mg->mg_len >= 0) mg->mg_len++; } - s = (U8*)SvPV_force(sv, len); - (void)SvUPGRADE(sv, SVt_PVBM); + s = (U8*)SvPV_force_mutable(sv, len); + SvUPGRADE(sv, SVt_PVBM); if (len == 0) /* TAIL might be on a zero-length string. */ return; if (len > 2) { - U8 mlen; - unsigned char *sb; + const unsigned char *sb; + const U8 mlen = (len>255) ? 255 : (U8)len; + register U8 *table; - if (len > 255) - mlen = 255; - else - mlen = (U8)len; Sv_Grow(sv, len + 256 + FBM_TABLE_OFFSET); - table = (unsigned char*)(SvPVX(sv) + len + FBM_TABLE_OFFSET); + table = (unsigned char*)(SvPVX_mutable(sv) + len + FBM_TABLE_OFFSET); s = table - 1 - FBM_TABLE_OFFSET; /* last char */ memset((void*)table, mlen, 256); table[-1] = (U8)flags; @@ -395,7 +402,7 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags) sv_magic(sv, Nullsv, PERL_MAGIC_bm, Nullch, 0); /* deep magic */ SvVALID_on(sv); - s = (unsigned char*)(SvPVX(sv)); /* deeper magic */ + s = (const unsigned char*)(SvPVX_const(sv)); /* deeper magic */ for (i = 0; i < len; i++) { if (PL_freq[s[i]] < frequency) { rarest = i; @@ -431,9 +438,10 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit { register unsigned char *s; STRLEN l; - register unsigned char *little = (unsigned char *)SvPV(littlestr,l); + register const unsigned char *little + = (const unsigned char *)SvPV_const(littlestr,l); register STRLEN littlelen = l; - register I32 multiline = flags & FBMrf_MULTILINE; + register const I32 multiline = flags & FBMrf_MULTILINE; if ((STRLEN)(bigend - big) < littlelen) { if ( SvTAIL(littlestr) @@ -479,8 +487,8 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit /* This should be better than FBM if c1 == c2, and almost as good otherwise: maybe better since we do less indirection. And we save a lot of memory by caching no table. */ - register unsigned char c1 = little[0]; - register unsigned char c2 = little[1]; + const unsigned char c1 = little[0]; + const unsigned char c2 = little[1]; s = big + 1; bigend--; @@ -561,8 +569,8 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit } { /* Do actual FBM. */ - register unsigned char *table = little + littlelen + FBM_TABLE_OFFSET; - register unsigned char *oldlittle; + register const unsigned char *table = little + littlelen + FBM_TABLE_OFFSET; + const register unsigned char *oldlittle; if (littlelen > (STRLEN)(bigend - big)) return Nullch; @@ -575,14 +583,13 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit register I32 tmp; top2: - /*SUPPRESS 560*/ if ((tmp = table[*s])) { if ((s += tmp) < bigend) goto top2; goto check_end; } else { /* less expensive than calling strncmp() */ - register unsigned char *olds = s; + register unsigned char * const olds = s; tmp = littlelen; @@ -609,7 +616,7 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit /* start_shift, end_shift are positive quantities which give offsets of ends of some substring of bigstr. - If `last' we want the last occurrence. + If "last" we want the last occurrence. old_posp is the way of communication between consequent calls if the next call needs to find the . The initial *old_posp should be -1. @@ -625,14 +632,13 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit char * Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last) { - register unsigned char *s, *x; - register unsigned char *big; + const register unsigned char *big; register I32 pos; register I32 previous; register I32 first; - register unsigned char *little; + const register unsigned char *little; register I32 stop_pos; - register unsigned char *littleend; + const register unsigned char *littleend; I32 found = 0; if (*old_posp == -1 @@ -641,7 +647,7 @@ Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift cant_find: if ( BmRARE(littlestr) == '\n' && BmPREVIOUS(littlestr) == SvCUR(littlestr) - 1) { - little = (unsigned char *)(SvPVX(littlestr)); + little = (const unsigned char *)(SvPVX_const(littlestr)); littleend = little + SvCUR(littlestr); first = *little++; goto check_tail; @@ -649,12 +655,12 @@ Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift return Nullch; } - little = (unsigned char *)(SvPVX(littlestr)); + little = (const unsigned char *)(SvPVX_const(littlestr)); littleend = little + SvCUR(littlestr); first = *little++; /* The value of pos we can start at: */ previous = BmPREVIOUS(littlestr); - big = (unsigned char *)(SvPVX(bigstr)); + big = (const unsigned char *)(SvPVX_const(bigstr)); /* The value of pos we can stop at: */ stop_pos = SvCUR(bigstr) - end_shift - (SvCUR(littlestr) - 1 - previous); if (previous + start_shift > stop_pos) { @@ -674,6 +680,7 @@ Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift } big -= previous; do { + const register unsigned char *s, *x; if (pos >= stop_pos) break; if (big[pos] != first) continue; @@ -695,7 +702,7 @@ Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift if (!SvTAIL(littlestr) || (end_shift > 0)) return Nullch; /* Ignore the trailing "\n". This code is not microoptimized */ - big = (unsigned char *)(SvPVX(bigstr) + SvCUR(bigstr)); + big = (const unsigned char *)(SvPVX_const(bigstr) + SvCUR(bigstr)); stop_pos = littleend - little; /* Actual littlestr len */ if (stop_pos == 0) return (char*)big; @@ -710,8 +717,8 @@ Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift I32 Perl_ibcmp(pTHX_ const char *s1, const char *s2, register I32 len) { - register U8 *a = (U8 *)s1; - register U8 *b = (U8 *)s2; + register const U8 *a = (const U8 *)s1; + register const U8 *b = (const U8 *)s2; while (len--) { if (*a != *b && *a != PL_fold[*b]) return 1; @@ -723,8 +730,9 @@ Perl_ibcmp(pTHX_ const char *s1, const char *s2, register I32 len) I32 Perl_ibcmp_locale(pTHX_ const char *s1, const char *s2, register I32 len) { - register U8 *a = (U8 *)s1; - register U8 *b = (U8 *)s2; + dVAR; + register const U8 *a = (const U8 *)s1; + register const U8 *b = (const U8 *)s2; while (len--) { if (*a != *b && *a != PL_fold_locale[*b]) return 1; @@ -751,12 +759,15 @@ be freed with the C function. char * Perl_savepv(pTHX_ const char *pv) { - register char *newaddr = Nullch; - if (pv) { - New(902,newaddr,strlen(pv)+1,char); - (void)strcpy(newaddr,pv); + if (!pv) + return Nullch; + else { + char *newaddr; + const STRLEN pvlen = strlen(pv)+1; + Newx(newaddr,pvlen,char); + return memcpy(newaddr,pv,pvlen); } - return newaddr; + } /* same thing but with a known length */ @@ -777,16 +788,16 @@ Perl_savepvn(pTHX_ const char *pv, register I32 len) { register char *newaddr; - New(903,newaddr,len+1,char); + Newx(newaddr,len+1,char); /* Give a meaning to NULL pointer mainly for the use in sv_magic() */ if (pv) { - Copy(pv,newaddr,len,char); /* might not be null terminated */ - newaddr[len] = '\0'; /* is now */ + /* might not be null terminated */ + newaddr[len] = '\0'; + return (char *) CopyD(pv,newaddr,len,char); } else { - Zero(newaddr,len+1,char); + return (char *) ZeroD(newaddr,len+1,char); } - return newaddr; } /* @@ -800,14 +811,41 @@ which is shared between threads. char * Perl_savesharedpv(pTHX_ const char *pv) { - register char *newaddr = Nullch; - if (pv) { - newaddr = (char*)PerlMemShared_malloc(strlen(pv)+1); - (void)strcpy(newaddr,pv); + register char *newaddr; + STRLEN pvlen; + if (!pv) + return Nullch; + + pvlen = strlen(pv)+1; + newaddr = (char*)PerlMemShared_malloc(pvlen); + if (!newaddr) { + PerlLIO_write(PerlIO_fileno(Perl_error_log), + PL_no_mem, strlen(PL_no_mem)); + my_exit(1); } - return newaddr; + return memcpy(newaddr,pv,pvlen); } +/* +=for apidoc savesvpv + +A version of C/C which gets the string to duplicate from +the passed in SV using C + +=cut +*/ + +char * +Perl_savesvpv(pTHX_ SV *sv) +{ + STRLEN len; + const char *pv = SvPV_const(sv, len); + register char *newaddr; + + ++len; + Newx(newaddr,len,char); + return (char *) CopyD(pv,newaddr,len,char); +} /* the SV for Perl_form() and mess() is not kept in an arena */ @@ -825,10 +863,11 @@ S_mess_alloc(pTHX) return PL_mess_sv; /* Create as PVMG now, to avoid any upgrading later */ - New(905, sv, 1, SV); - Newz(905, any, 1, XPVMG); + Newx(sv, 1, SV); + Newxz(any, 1, XPVMG); SvFLAGS(sv) = SVt_PVMG; SvANY(sv) = (void*)any; + SvPV_set(sv, 0); SvREFCNT(sv) = 1 << 30; /* practically infinite */ PL_mess_sv = sv; return sv; @@ -882,7 +921,7 @@ Perl_form(pTHX_ const char* pat, ...) char * Perl_vform(pTHX_ const char *pat, va_list *args) { - SV *sv = mess_alloc(); + SV * const sv = mess_alloc(); sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); return SvPVX(sv); } @@ -913,7 +952,7 @@ Perl_mess(pTHX_ const char *pat, ...) } STATIC COP* -S_closest_cop(pTHX_ COP *cop, OP *o) +S_closest_cop(pTHX_ COP *cop, const OP *o) { /* Look for PL_op starting from o. cop is the last COP we've seen. */ @@ -940,15 +979,14 @@ S_closest_cop(pTHX_ COP *cop, OP *o) /* Nothing found. */ - return 0; + return Null(COP *); } SV * Perl_vmess(pTHX_ const char *pat, va_list *args) { SV *sv = mess_alloc(); - static char dgd[] = " during global destruction.\n"; - COP *cop; + static const char dgd[] = " during global destruction.\n"; sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') { @@ -960,15 +998,15 @@ Perl_vmess(pTHX_ const char *pat, va_list *args) * from the sibling of PL_curcop. */ - cop = closest_cop(PL_curcop, PL_curcop->op_sibling); + const COP *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, OutCopFILE(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'); + 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), @@ -983,6 +1021,7 @@ Perl_vmess(pTHX_ const char *pat, va_list *args) void Perl_write_to_stderr(pTHX_ const char* message, int msglen) { + dVAR; IO *io; MAGIC *mg; @@ -1014,9 +1053,9 @@ Perl_write_to_stderr(pTHX_ const char* message, int msglen) else { #ifdef USE_SFIO /* SFIO can really mess with your errno */ - int e = errno; + const int e = errno; #endif - PerlIO *serr = Perl_error_log; + PerlIO * const serr = Perl_error_log; PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen); (void)PerlIO_flush(serr); @@ -1026,74 +1065,93 @@ Perl_write_to_stderr(pTHX_ const char* message, int msglen) } } -OP * -Perl_vdie(pTHX_ const char* pat, va_list *args) +/* Common code used by vcroak, vdie and vwarner */ + +STATIC void +S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8) { - char *message; - int was_in_eval = PL_in_eval; HV *stash; GV *gv; CV *cv; - SV *msv; - STRLEN msglen; - I32 utf8 = 0; + /* sv_2cv might call Perl_croak() */ + SV * const olddiehook = PL_diehook; + + assert(PL_diehook); + ENTER; + SAVESPTR(PL_diehook); + PL_diehook = Nullsv; + cv = sv_2cv(olddiehook, &stash, &gv, 0); + LEAVE; + if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) { + dSP; + SV *msg; - DEBUG_S(PerlIO_printf(Perl_debug_log, - "%p: die: curstack = %p, mainstack = %p\n", - thr, PL_curstack, PL_mainstack)); + ENTER; + save_re_context(); + if (message) { + msg = newSVpvn(message, msglen); + SvFLAGS(msg) |= utf8; + SvREADONLY_on(msg); + SAVEFREESV(msg); + } + else { + msg = ERRSV; + } + + PUSHSTACKi(PERLSI_DIEHOOK); + PUSHMARK(SP); + XPUSHs(msg); + PUTBACK; + call_sv((SV*)cv, G_DISCARD); + POPSTACK; + LEAVE; + } +} + +STATIC const char * +S_vdie_croak_common(pTHX_ const char* pat, va_list* args, STRLEN* msglen, + I32* utf8) +{ + dVAR; + const char *message; if (pat) { - msv = vmess(pat, args); + SV * const msv = vmess(pat, args); if (PL_errors && SvCUR(PL_errors)) { sv_catsv(PL_errors, msv); - message = SvPV(PL_errors, msglen); + message = SvPV_const(PL_errors, *msglen); SvCUR_set(PL_errors, 0); } else - message = SvPV(msv,msglen); - utf8 = SvUTF8(msv); + message = SvPV_const(msv,*msglen); + *utf8 = SvUTF8(msv); } else { message = Nullch; - msglen = 0; } DEBUG_S(PerlIO_printf(Perl_debug_log, - "%p: die: message = %s\ndiehook = %p\n", + "%p: die/croak: message = %s\ndiehook = %p\n", thr, message, PL_diehook)); if (PL_diehook) { - /* sv_2cv might call Perl_croak() */ - SV *olddiehook = PL_diehook; - ENTER; - SAVESPTR(PL_diehook); - PL_diehook = Nullsv; - cv = sv_2cv(olddiehook, &stash, &gv, 0); - LEAVE; - if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) { - dSP; - SV *msg; + S_vdie_common(aTHX_ message, *msglen, *utf8); + } + return message; +} - ENTER; - save_re_context(); - if (message) { - msg = newSVpvn(message, msglen); - SvFLAGS(msg) |= utf8; - SvREADONLY_on(msg); - SAVEFREESV(msg); - } - else { - msg = ERRSV; - } +OP * +Perl_vdie(pTHX_ const char* pat, va_list *args) +{ + const char *message; + const int was_in_eval = PL_in_eval; + STRLEN msglen; + I32 utf8 = 0; - PUSHSTACKi(PERLSI_DIEHOOK); - PUSHMARK(SP); - XPUSHs(msg); - PUTBACK; - call_sv((SV*)cv, G_DISCARD); - POPSTACK; - LEAVE; - } - } + DEBUG_S(PerlIO_printf(Perl_debug_log, + "%p: die: curstack = %p, mainstack = %p\n", + thr, PL_curstack, PL_mainstack)); + + message = vdie_croak_common(pat, args, &msglen, &utf8); PL_restartop = die_where(message, msglen); SvFLAGS(ERRSV) |= utf8; @@ -1133,73 +1191,19 @@ Perl_die(pTHX_ const char* pat, ...) void Perl_vcroak(pTHX_ const char* pat, va_list *args) { - char *message; - HV *stash; - GV *gv; - CV *cv; - SV *msv; + const char *message; STRLEN msglen; I32 utf8 = 0; - if (pat) { - msv = vmess(pat, args); - if (PL_errors && SvCUR(PL_errors)) { - sv_catsv(PL_errors, msv); - message = SvPV(PL_errors, msglen); - SvCUR_set(PL_errors, 0); - } - else - message = SvPV(msv,msglen); - utf8 = SvUTF8(msv); - } - else { - message = Nullch; - msglen = 0; - } + message = S_vdie_croak_common(aTHX_ pat, args, &msglen, &utf8); - DEBUG_S(PerlIO_printf(Perl_debug_log, "croak: 0x%"UVxf" %s", - PTR2UV(thr), message)); - - if (PL_diehook) { - /* sv_2cv might call Perl_croak() */ - SV *olddiehook = PL_diehook; - ENTER; - SAVESPTR(PL_diehook); - PL_diehook = Nullsv; - cv = sv_2cv(olddiehook, &stash, &gv, 0); - LEAVE; - if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) { - dSP; - SV *msg; - - ENTER; - save_re_context(); - if (message) { - msg = newSVpvn(message, msglen); - SvFLAGS(msg) |= utf8; - SvREADONLY_on(msg); - SAVEFREESV(msg); - } - else { - msg = ERRSV; - } - - PUSHSTACKi(PERLSI_DIEHOOK); - PUSHMARK(SP); - XPUSHs(msg); - PUTBACK; - call_sv((SV*)cv, G_DISCARD); - POPSTACK; - LEAVE; - } - } if (PL_in_eval) { PL_restartop = die_where(message, msglen); SvFLAGS(ERRSV) |= utf8; JMPENV_JUMP(3); } else if (!message) - message = SvPVx(ERRSV, msglen); + message = SvPVx_const(ERRSV, msglen); write_to_stderr(message, msglen); my_failure_exit(); @@ -1251,21 +1255,19 @@ Perl_croak(pTHX_ const char *pat, ...) void Perl_vwarn(pTHX_ const char* pat, va_list *args) { - char *message; - HV *stash; - GV *gv; - CV *cv; - SV *msv; + dVAR; STRLEN msglen; - I32 utf8 = 0; - - msv = vmess(pat, args); - utf8 = SvUTF8(msv); - message = SvPV(msv, msglen); + SV * const msv = vmess(pat, args); + const I32 utf8 = SvUTF8(msv); + const char * const message = SvPV_const(msv, msglen); if (PL_warnhook) { /* sv_2cv might call Perl_warn() */ - SV *oldwarnhook = PL_warnhook; + SV * const oldwarnhook = PL_warnhook; + CV * cv; + HV * stash; + GV * gv; + ENTER; SAVESPTR(PL_warnhook); PL_warnhook = Nullsv; @@ -1276,6 +1278,8 @@ Perl_vwarn(pTHX_ const char* pat, va_list *args) SV *msg; ENTER; + SAVESPTR(PL_warnhook); + PL_warnhook = Nullsv; save_re_context(); msg = newSVpvn(message, msglen); SvFLAGS(msg) |= utf8; @@ -1330,7 +1334,7 @@ Perl_warn(pTHX_ const char *pat, ...) void Perl_warner_nocontext(U32 err, const char *pat, ...) { - dTHX; + dTHX; va_list args; va_start(args, pat); vwarner(err, pat, &args); @@ -1350,46 +1354,16 @@ Perl_warner(pTHX_ U32 err, const char* pat,...) void Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args) { - char *message; - HV *stash; - GV *gv; - CV *cv; - SV *msv; - STRLEN msglen; - I32 utf8 = 0; - - msv = vmess(pat, args); - message = SvPV(msv, msglen); - utf8 = SvUTF8(msv); - + dVAR; if (ckDEAD(err)) { + SV * const msv = vmess(pat, args); + STRLEN msglen; + const char *message = SvPV_const(msv, msglen); + const I32 utf8 = SvUTF8(msv); + if (PL_diehook) { - /* sv_2cv might call Perl_croak() */ - SV *olddiehook = PL_diehook; - ENTER; - SAVESPTR(PL_diehook); - PL_diehook = Nullsv; - cv = sv_2cv(olddiehook, &stash, &gv, 0); - LEAVE; - if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) { - dSP; - SV *msg; - - ENTER; - save_re_context(); - msg = newSVpvn(message, msglen); - SvFLAGS(msg) |= utf8; - SvREADONLY_on(msg); - SAVEFREESV(msg); - - PUSHSTACKi(PERLSI_DIEHOOK); - PUSHMARK(sp); - XPUSHs(msg); - PUTBACK; - call_sv((SV*)cv, G_DISCARD); - POPSTACK; - LEAVE; - } + assert(message); + S_vdie_common(aTHX_ message, msglen, utf8); } if (PL_in_eval) { PL_restartop = die_where(message, msglen); @@ -1400,39 +1374,62 @@ Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args) my_failure_exit(); } else { - if (PL_warnhook) { - /* sv_2cv might call Perl_warn() */ - SV *oldwarnhook = PL_warnhook; - 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; - 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; - return; - } - } - write_to_stderr(message, msglen); + Perl_vwarn(aTHX_ pat, args); } } +/* implements the ckWARN? macros */ + +bool +Perl_ckwarn(pTHX_ U32 w) +{ + return + ( + isLEXWARN_on + && PL_curcop->cop_warnings != pWARN_NONE + && ( + PL_curcop->cop_warnings == pWARN_ALL + || isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w)) + || (unpackWARN2(w) && + isWARN_on(PL_curcop->cop_warnings, unpackWARN2(w))) + || (unpackWARN3(w) && + isWARN_on(PL_curcop->cop_warnings, unpackWARN3(w))) + || (unpackWARN4(w) && + isWARN_on(PL_curcop->cop_warnings, unpackWARN4(w))) + ) + ) + || + ( + isLEXWARN_off && PL_dowarn & G_WARN_ON + ) + ; +} + +/* implements the ckWARN?_d macro */ + +bool +Perl_ckwarn_d(pTHX_ U32 w) +{ + return + isLEXWARN_off + || PL_curcop->cop_warnings == pWARN_ALL + || ( + PL_curcop->cop_warnings != pWARN_NONE + && ( + isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w)) + || (unpackWARN2(w) && + isWARN_on(PL_curcop->cop_warnings, unpackWARN2(w))) + || (unpackWARN3(w) && + isWARN_on(PL_curcop->cop_warnings, unpackWARN3(w))) + || (unpackWARN4(w) && + isWARN_on(PL_curcop->cop_warnings, unpackWARN4(w))) + ) + ) + ; +} + + + /* 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) @@ -1447,14 +1444,16 @@ Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args) /* VMS' my_setenv() is in vms.c */ #if !defined(WIN32) && !defined(NETWARE) void -Perl_my_setenv(pTHX_ char *nam, char *val) +Perl_my_setenv(pTHX_ const char *nam, const char *val) { + dVAR; #ifdef USE_ITHREADS /* only parent thread can modify process environment */ if (PL_curinterp == aTHX) #endif { #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? */ int nlen, vlen; @@ -1464,11 +1463,10 @@ Perl_my_setenv(pTHX_ char *nam, char *val) I32 max; char **tmpenv; - /*SUPPRESS 530*/ for (max = i; environ[max]; max++) ; tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*)); for (j=0; j= 0) { while (len--) @@ -1594,7 +1598,7 @@ Perl_my_bcopy(register const char *from,register char *to,register I32 len) void * Perl_my_memset(register char *loc, register I32 ch, register I32 len) { - char *retval = loc; + char * const retval = loc; while (len--) *loc++ = ch; @@ -1607,7 +1611,7 @@ Perl_my_memset(register char *loc, register I32 ch, register I32 len) char * Perl_my_bzero(register char *loc, register I32 len) { - char *retval = loc; + char * const retval = loc; while (len--) *loc++ = 0; @@ -1620,12 +1624,12 @@ Perl_my_bzero(register char *loc, register I32 len) I32 Perl_my_memcmp(const char *s1, const char *s2, register I32 len) { - register U8 *a = (U8 *)s1; - register U8 *b = (U8 *)s2; + register const U8 *a = (const U8 *)s1; + register const U8 *b = (const U8 *)s2; register I32 tmp; while (len--) { - if (tmp = *a++ - *b++) + if ((tmp = *a++ - *b++)) return tmp; } return 0; @@ -1746,7 +1750,7 @@ Perl_my_ntohl(pTHX_ long l) * -DWS */ -#define HTOV(name,type) \ +#define HTOLE(name,type) \ type \ name (register type n) \ { \ @@ -1755,14 +1759,14 @@ Perl_my_ntohl(pTHX_ long l) char c[sizeof(type)]; \ } u; \ register I32 i; \ - register I32 s; \ - for (i = 0, s = 0; i < sizeof(u.c); i++, s += 8) { \ + register I32 s = 0; \ + for (i = 0; i < sizeof(u.c); i++, s += 8) { \ u.c[i] = (n >> s) & 0xFF; \ } \ return u.value; \ } -#define VTOH(name,type) \ +#define LETOH(name,type) \ type \ name (register type n) \ { \ @@ -1771,28 +1775,219 @@ Perl_my_ntohl(pTHX_ long l) char c[sizeof(type)]; \ } u; \ register I32 i; \ - register I32 s; \ + register I32 s = 0; \ u.value = n; \ n = 0; \ - for (i = 0, s = 0; i < sizeof(u.c); i++, s += 8) { \ - n += (u.c[i] & 0xFF) << s; \ + for (i = 0; i < sizeof(u.c); i++, s += 8) { \ + n |= ((type)(u.c[i] & 0xFF)) << s; \ } \ return n; \ } +/* + * Big-endian byte order functions. + */ + +#define HTOBE(name,type) \ + type \ + name (register type n) \ + { \ + union { \ + type value; \ + char c[sizeof(type)]; \ + } u; \ + register I32 i; \ + register I32 s = 8*(sizeof(u.c)-1); \ + for (i = 0; i < sizeof(u.c); i++, s -= 8) { \ + u.c[i] = (n >> s) & 0xFF; \ + } \ + return u.value; \ + } + +#define BETOH(name,type) \ + type \ + name (register type n) \ + { \ + union { \ + type value; \ + char c[sizeof(type)]; \ + } u; \ + register I32 i; \ + register I32 s = 8*(sizeof(u.c)-1); \ + u.value = n; \ + n = 0; \ + for (i = 0; i < sizeof(u.c); i++, s -= 8) { \ + n |= ((type)(u.c[i] & 0xFF)) << s; \ + } \ + return n; \ + } + +/* + * If we just can't do it... + */ + +#define NOT_AVAIL(name,type) \ + type \ + name (register type n) \ + { \ + Perl_croak_nocontext(#name "() not available"); \ + return n; /* not reached */ \ + } + + #if defined(HAS_HTOVS) && !defined(htovs) -HTOV(htovs,short) +HTOLE(htovs,short) #endif #if defined(HAS_HTOVL) && !defined(htovl) -HTOV(htovl,long) +HTOLE(htovl,long) #endif #if defined(HAS_VTOHS) && !defined(vtohs) -VTOH(vtohs,short) +LETOH(vtohs,short) #endif #if defined(HAS_VTOHL) && !defined(vtohl) -VTOH(vtohl,long) +LETOH(vtohl,long) +#endif + +#ifdef PERL_NEED_MY_HTOLE16 +# if U16SIZE == 2 +HTOLE(Perl_my_htole16,U16) +# else +NOT_AVAIL(Perl_my_htole16,U16) +# endif +#endif +#ifdef PERL_NEED_MY_LETOH16 +# if U16SIZE == 2 +LETOH(Perl_my_letoh16,U16) +# else +NOT_AVAIL(Perl_my_letoh16,U16) +# endif +#endif +#ifdef PERL_NEED_MY_HTOBE16 +# if U16SIZE == 2 +HTOBE(Perl_my_htobe16,U16) +# else +NOT_AVAIL(Perl_my_htobe16,U16) +# endif +#endif +#ifdef PERL_NEED_MY_BETOH16 +# if U16SIZE == 2 +BETOH(Perl_my_betoh16,U16) +# else +NOT_AVAIL(Perl_my_betoh16,U16) +# endif +#endif + +#ifdef PERL_NEED_MY_HTOLE32 +# if U32SIZE == 4 +HTOLE(Perl_my_htole32,U32) +# else +NOT_AVAIL(Perl_my_htole32,U32) +# endif +#endif +#ifdef PERL_NEED_MY_LETOH32 +# if U32SIZE == 4 +LETOH(Perl_my_letoh32,U32) +# else +NOT_AVAIL(Perl_my_letoh32,U32) +# endif +#endif +#ifdef PERL_NEED_MY_HTOBE32 +# if U32SIZE == 4 +HTOBE(Perl_my_htobe32,U32) +# else +NOT_AVAIL(Perl_my_htobe32,U32) +# endif +#endif +#ifdef PERL_NEED_MY_BETOH32 +# if U32SIZE == 4 +BETOH(Perl_my_betoh32,U32) +# else +NOT_AVAIL(Perl_my_betoh32,U32) +# endif +#endif + +#ifdef PERL_NEED_MY_HTOLE64 +# if U64SIZE == 8 +HTOLE(Perl_my_htole64,U64) +# else +NOT_AVAIL(Perl_my_htole64,U64) +# endif +#endif +#ifdef PERL_NEED_MY_LETOH64 +# if U64SIZE == 8 +LETOH(Perl_my_letoh64,U64) +# else +NOT_AVAIL(Perl_my_letoh64,U64) +# endif +#endif +#ifdef PERL_NEED_MY_HTOBE64 +# if U64SIZE == 8 +HTOBE(Perl_my_htobe64,U64) +# else +NOT_AVAIL(Perl_my_htobe64,U64) +# endif +#endif +#ifdef PERL_NEED_MY_BETOH64 +# if U64SIZE == 8 +BETOH(Perl_my_betoh64,U64) +# else +NOT_AVAIL(Perl_my_betoh64,U64) +# endif +#endif + +#ifdef PERL_NEED_MY_HTOLES +HTOLE(Perl_my_htoles,short) +#endif +#ifdef PERL_NEED_MY_LETOHS +LETOH(Perl_my_letohs,short) +#endif +#ifdef PERL_NEED_MY_HTOBES +HTOBE(Perl_my_htobes,short) +#endif +#ifdef PERL_NEED_MY_BETOHS +BETOH(Perl_my_betohs,short) #endif +#ifdef PERL_NEED_MY_HTOLEI +HTOLE(Perl_my_htolei,int) +#endif +#ifdef PERL_NEED_MY_LETOHI +LETOH(Perl_my_letohi,int) +#endif +#ifdef PERL_NEED_MY_HTOBEI +HTOBE(Perl_my_htobei,int) +#endif +#ifdef PERL_NEED_MY_BETOHI +BETOH(Perl_my_betohi,int) +#endif + +#ifdef PERL_NEED_MY_HTOLEL +HTOLE(Perl_my_htolel,long) +#endif +#ifdef PERL_NEED_MY_LETOHL +LETOH(Perl_my_letohl,long) +#endif +#ifdef PERL_NEED_MY_HTOBEL +HTOBE(Perl_my_htobel,long) +#endif +#ifdef PERL_NEED_MY_BETOHL +BETOH(Perl_my_betohl,long) +#endif + +void +Perl_my_swabn(void *ptr, int n) +{ + register char *s = (char *)ptr; + register char *e = s + (n-1); + register char tc; + + for (n /= 2; n > 0; s++, e--, n--) { + tc = *s; + *s = *e; + *e = tc; + } +} + PerlIO * Perl_my_popen_list(pTHX_ char *mode, int n, SV **args) { @@ -1886,8 +2081,8 @@ Perl_my_popen_list(pTHX_ char *mode, int n, SV **args) LOCK_FDPID_MUTEX; sv = *av_fetch(PL_fdpid,p[This],TRUE); UNLOCK_FDPID_MUTEX; - (void)SvUPGRADE(sv,SVt_IV); - SvIVX(sv) = pid; + SvUPGRADE(sv,SVt_IV); + SvIV_set(sv, pid); PL_forkprocess = pid; /* If we managed to get status pipe check for exec fail */ if (did_pipes && pid > 0) { @@ -1928,13 +2123,13 @@ Perl_my_popen_list(pTHX_ char *mode, int n, SV **args) /* VMS' my_popen() is in VMS.c, same with OS/2. */ #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) PerlIO * -Perl_my_popen(pTHX_ char *cmd, char *mode) +Perl_my_popen(pTHX_ const char *cmd, const char *mode) { int p[2]; register I32 This, that; register Pid_t pid; SV *sv; - I32 doexec = strNE(cmd,"-"); + const I32 doexec = !(*cmd == '-' && cmd[1] == '\0'); I32 did_pipes = 0; int pp[2]; @@ -1992,8 +2187,6 @@ Perl_my_popen(pTHX_ char *cmd, char *mode) #ifndef OS2 if (doexec) { #if !defined(HAS_FCNTL) || !defined(F_SETFD) - int fd; - #ifndef NOFILE #define NOFILE 20 #endif @@ -2010,7 +2203,6 @@ Perl_my_popen(pTHX_ char *cmd, char *mode) PerlProc__exit(1); } #endif /* defined OS2 */ - /*SUPPRESS 560*/ if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) { SvREADONLY_off(GvSV(tmpgv)); sv_setiv(GvSV(tmpgv), PerlProc_getpid()); @@ -2039,8 +2231,8 @@ Perl_my_popen(pTHX_ char *cmd, char *mode) LOCK_FDPID_MUTEX; sv = *av_fetch(PL_fdpid,p[This],TRUE); UNLOCK_FDPID_MUTEX; - (void)SvUPGRADE(sv,SVt_IV); - SvIVX(sv) = pid; + SvUPGRADE(sv,SVt_IV); + SvIV_set(sv, pid); PL_forkprocess = pid; if (did_pipes && pid > 0) { int errkid; @@ -2107,6 +2299,7 @@ Perl_my_popen(pTHX_ char *cmd, char *mode) void Perl_atfork_lock(void) { + dVAR; #if defined(USE_ITHREADS) /* locks must be held in locking order (if any) */ # ifdef MYMALLOC @@ -2120,6 +2313,7 @@ Perl_atfork_lock(void) void Perl_atfork_unlock(void) { + dVAR; #if defined(USE_ITHREADS) /* locks must be released in same order as in atfork_lock() */ # ifdef MYMALLOC @@ -2164,6 +2358,7 @@ Perl_dump_fds(pTHX_ char *s) PerlIO_printf(Perl_debug_log," %d",fd); } PerlIO_printf(Perl_debug_log,"\n"); + return; } #endif /* DUMP_FDS */ @@ -2212,15 +2407,16 @@ dup2(int oldfd, int newfd) Sighandler_t Perl_rsignal(pTHX_ int signo, Sighandler_t handler) { + dVAR; struct sigaction act, oact; #ifdef USE_ITHREADS /* only "parent" interpreter can diddle signals */ if (PL_curinterp != aTHX) - return SIG_ERR; + return (Sighandler_t) SIG_ERR; #endif - act.sa_handler = handler; + act.sa_handler = (void(*)(int))handler; sigemptyset(&act.sa_mask); act.sa_flags = 0; #ifdef SA_RESTART @@ -2228,13 +2424,13 @@ Perl_rsignal(pTHX_ int signo, Sighandler_t handler) act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */ #endif #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */ - if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN) + if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN) act.sa_flags |= SA_NOCLDWAIT; #endif if (sigaction(signo, &act, &oact) == -1) - return SIG_ERR; + return (Sighandler_t) SIG_ERR; else - return oact.sa_handler; + return (Sighandler_t) oact.sa_handler; } Sighandler_t @@ -2243,14 +2439,15 @@ Perl_rsignal_state(pTHX_ int signo) struct sigaction oact; if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1) - return SIG_ERR; + return (Sighandler_t) SIG_ERR; else - return oact.sa_handler; + return (Sighandler_t) oact.sa_handler; } int Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save) { + dVAR; struct sigaction act; #ifdef USE_ITHREADS @@ -2259,7 +2456,7 @@ Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save) return -1; #endif - act.sa_handler = handler; + act.sa_handler = (void(*)(int))handler; sigemptyset(&act.sa_mask); act.sa_flags = 0; #ifdef SA_RESTART @@ -2267,7 +2464,7 @@ Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save) act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */ #endif #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */ - if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN) + if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN) act.sa_flags |= SA_NOCLDWAIT; #endif return sigaction(signo, &act, save); @@ -2276,6 +2473,7 @@ Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save) int Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save) { + dVAR; #ifdef USE_ITHREADS /* only "parent" interpreter can diddle signals */ if (PL_curinterp != aTHX) @@ -2293,37 +2491,36 @@ Perl_rsignal(pTHX_ int signo, Sighandler_t handler) #if defined(USE_ITHREADS) && !defined(WIN32) /* only "parent" interpreter can diddle signals */ if (PL_curinterp != aTHX) - return SIG_ERR; + return (Sighandler_t) SIG_ERR; #endif return PerlProc_signal(signo, handler); } -static int sig_trapped; /* XXX signals are process-wide anyway, so we - ignore the implications of this for threading */ - static Signal_t sig_trap(int signo) { - sig_trapped++; + dVAR; + PL_sig_trapped++; } Sighandler_t Perl_rsignal_state(pTHX_ int signo) { + dVAR; Sighandler_t oldsig; #if defined(USE_ITHREADS) && !defined(WIN32) /* only "parent" interpreter can diddle signals */ if (PL_curinterp != aTHX) - return SIG_ERR; + return (Sighandler_t) SIG_ERR; #endif - sig_trapped = 0; + PL_sig_trapped = 0; oldsig = PerlProc_signal(signo, sig_trap); PerlProc_signal(signo, oldsig); - if (sig_trapped) + if (PL_sig_trapped) PerlProc_kill(PerlProc_getpid(), signo); return oldsig; } @@ -2337,7 +2534,7 @@ Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save) return -1; #endif *save = PerlProc_signal(signo, handler); - return (*save == SIG_ERR) ? -1 : 0; + return (*save == (Sighandler_t) SIG_ERR) ? -1 : 0; } int @@ -2348,7 +2545,7 @@ Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save) if (PL_curinterp != aTHX) return -1; #endif - return (PerlProc_signal(signo, *save) == SIG_ERR) ? -1 : 0; + return (PerlProc_signal(signo, *save) == (Sighandler_t) SIG_ERR) ? -1 : 0; } #endif /* !HAS_SIGACTION */ @@ -2366,9 +2563,6 @@ Perl_my_pclose(pTHX_ PerlIO *ptr) Pid_t pid2; bool close_failed; int saved_errno = 0; -#ifdef VMS - int saved_vaxc_errno; -#endif #ifdef WIN32 int saved_win32_errno; #endif @@ -2386,9 +2580,6 @@ Perl_my_pclose(pTHX_ PerlIO *ptr) #endif if ((close_failed = (PerlIO_close(ptr) == EOF))) { saved_errno = errno; -#ifdef VMS - saved_vaxc_errno = vaxc$errno; -#endif #ifdef WIN32 saved_win32_errno = GetLastError(); #endif @@ -2397,9 +2588,9 @@ Perl_my_pclose(pTHX_ PerlIO *ptr) if(PerlProc_kill(pid, 0) < 0) { return(pid); } /* HOM 12/23/91 */ #endif #ifndef PERL_MICRO - rsignal_save(SIGHUP, SIG_IGN, &hstat); - rsignal_save(SIGINT, SIG_IGN, &istat); - rsignal_save(SIGQUIT, SIG_IGN, &qstat); + rsignal_save(SIGHUP, (Sighandler_t) SIG_IGN, &hstat); + rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &istat); + rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qstat); #endif do { pid2 = wait4pid(pid, &status, 0); @@ -2410,7 +2601,7 @@ Perl_my_pclose(pTHX_ PerlIO *ptr) rsignal_restore(SIGQUIT, &qstat); #endif if (close_failed) { - SETERRNO(saved_errno, saved_vaxc_errno); + SETERRNO(saved_errno, 0); return -1; } return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status)); @@ -2421,16 +2612,15 @@ Perl_my_pclose(pTHX_ PerlIO *ptr) I32 Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags) { - I32 result; + I32 result = 0; if (!pid) return -1; #if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME) { - SV *sv; - SV** svp; - char spid[TYPE_CHARS(int)]; + char spid[TYPE_CHARS(IV)]; if (pid > 0) { + SV** svp; sprintf(spid, "%"IVdf, (IV)pid); svp = hv_fetch(PL_pidstatus,spid,strlen(spid),FALSE); if (svp && *svp != &PL_sv_undef) { @@ -2444,11 +2634,9 @@ Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags) hv_iterinit(PL_pidstatus); if ((entry = hv_iternext(PL_pidstatus))) { - SV *sv; - char spid[TYPE_CHARS(int)]; + SV *sv = hv_iterval(PL_pidstatus,entry); pid = atoi(hv_iterkey(entry,(I32*)statusp)); - sv = hv_iterval(PL_pidstatus,entry); *statusp = SvIVX(sv); sprintf(spid, "%"IVdf, (IV)pid); (void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD); @@ -2470,7 +2658,9 @@ Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags) goto finish; #endif #if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME) +#if defined(HAS_WAITPID) && defined(HAS_WAITPID_RUNTIME) hard_way: +#endif { if (flags) Perl_croak(aTHX_ "Can't do waitpid with flags"); @@ -2482,7 +2672,9 @@ Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags) } } #endif +#if defined(HAS_WAITPID) || defined(HAS_WAIT4) finish: +#endif if (result < 0 && errno == EINTR) { PERL_ASYNC_CHECK(); } @@ -2491,16 +2683,15 @@ Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags) #endif /* !DOSISH || OS2 || WIN32 || NETWARE */ void -/*SUPPRESS 590*/ Perl_pidgone(pTHX_ Pid_t pid, int status) { register SV *sv; - char spid[TYPE_CHARS(int)]; + char spid[TYPE_CHARS(IV)]; sprintf(spid, "%"IVdf, (IV)pid); sv = *hv_fetch(PL_pidstatus,spid,strlen(spid),TRUE); - (void)SvUPGRADE(sv,SVt_IV); - SvIVX(sv) = status; + SvUPGRADE(sv,SVt_IV); + SvIV_set(sv, status); return; } @@ -2559,7 +2750,7 @@ Perl_repeatcpy(pTHX_ register char *to, register const char *from, I32 len, regi #ifndef HAS_RENAME I32 -Perl_same_dirent(pTHX_ char *a, char *b) +Perl_same_dirent(pTHX_ const char *a, const char *b) { char *fa = strrchr(a,'/'); char *fb = strrchr(b,'/'); @@ -2578,16 +2769,16 @@ Perl_same_dirent(pTHX_ char *a, char *b) if (strNE(a,b)) return FALSE; if (fa == a) - sv_setpv(tmpsv, "."); + sv_setpvn(tmpsv, ".", 1); else sv_setpvn(tmpsv, a, fa - a); - if (PerlLIO_stat(SvPVX(tmpsv), &tmpstatbuf1) < 0) + if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0) return FALSE; if (fb == b) - sv_setpv(tmpsv, "."); + sv_setpvn(tmpsv, ".", 1); else sv_setpvn(tmpsv, b, fb - b); - if (PerlLIO_stat(SvPVX(tmpsv), &tmpstatbuf2) < 0) + if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0) return FALSE; return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev && tmpstatbuf1.st_ino == tmpstatbuf2.st_ino; @@ -2595,9 +2786,9 @@ Perl_same_dirent(pTHX_ char *a, char *b) #endif /* !HAS_RENAME */ char* -Perl_find_script(pTHX_ char *scriptname, bool dosearch, char **search_ext, I32 flags) +Perl_find_script(pTHX_ const char *scriptname, bool dosearch, const char **search_ext, I32 flags) { - char *xfound = Nullch; + const char *xfound = Nullch; char *xfailed = Nullch; char tmpbuf[MAXPATHLEN]; register char *s; @@ -2617,11 +2808,12 @@ Perl_find_script(pTHX_ char *scriptname, bool dosearch, char **search_ext, I32 f #endif /* additional extensions to try in each dir if scriptname not found */ #ifdef SEARCH_EXTS - char *exts[] = { SEARCH_EXTS }; - char **ext = search_ext ? search_ext : exts; + const char *exts[] = { SEARCH_EXTS }; + const char **ext = search_ext ? search_ext : exts; int extidx = 0, i = 0; - char *curext = Nullch; + const char *curext = Nullch; #else + PERL_UNUSED_ARG(search_ext); # define MAX_EXT_LEN 0 #endif @@ -2679,7 +2871,7 @@ Perl_find_script(pTHX_ char *scriptname, bool dosearch, char **search_ext, I32 f if (strEQ(scriptname, "-")) dosearch = 0; if (dosearch) { /* Look in '.' first. */ - char *cur = scriptname; + const char *cur = scriptname; #ifdef SEARCH_EXTS if ((curext = strrchr(scriptname,'.'))) /* possible current ext */ while (ext[i]) @@ -2704,6 +2896,7 @@ Perl_find_script(pTHX_ char *scriptname, bool dosearch, char **search_ext, I32 f len = strlen(scriptname); if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf)) break; + /* FIXME? Convert to memcpy */ cur = strcpy(tmpbuf, scriptname); } } while (extidx >= 0 && ext[extidx] /* try an extension? */ @@ -2758,15 +2951,17 @@ Perl_find_script(pTHX_ char *scriptname, bool dosearch, char **search_ext, I32 f tmpbuf[len++] = ':'; #else if (len -#if defined(atarist) || defined(__MINT__) || defined(DOSISH) +# if defined(atarist) || defined(__MINT__) || defined(DOSISH) && tmpbuf[len - 1] != '/' && tmpbuf[len - 1] != '\\' -#endif +# endif ) tmpbuf[len++] = '/'; if (len == 2 && tmpbuf[0] == '.') seen_dot = 1; #endif + /* FIXME? Convert to memcpy by storing previous strlen(scriptname) + */ (void)strcpy(tmpbuf + len, scriptname); #endif /* !VMS */ @@ -2818,8 +3013,7 @@ Perl_find_script(pTHX_ char *scriptname, bool dosearch, char **search_ext, I32 f } scriptname = Nullch; } - if (xfailed) - Safefree(xfailed); + Safefree(xfailed); scriptname = xfound; } return (scriptname ? savepv(scriptname) : Nullch); @@ -2830,6 +3024,7 @@ Perl_find_script(pTHX_ char *scriptname, bool dosearch, char **search_ext, I32 f void * Perl_get_context(void) { + dVAR; #if defined(USE_ITHREADS) # ifdef OLD_PTHREADS_API pthread_addr_t t; @@ -2851,6 +3046,7 @@ Perl_get_context(void) void Perl_set_context(void *t) { + dVAR; #if defined(USE_ITHREADS) # ifdef I_MACH_CTHREADS cthread_set_data(cthread_self(), t); @@ -2858,12 +3054,14 @@ Perl_set_context(void *t) if (pthread_setspecific(PL_thr_key, t)) Perl_croak_nocontext("panic: pthread_setspecific"); # endif +#else + PERL_UNUSED_ARG(t); #endif } #endif /* !PERL_GET_CONTEXT_DEFINED */ -#ifdef PERL_GLOBAL_STRUCT +#if defined(PERL_GLOBAL_STRUCT) && !defined(PERL_GLOBAL_STRUCT_PRIVATE) struct perl_vars * Perl_GetVars(pTHX) { @@ -2874,30 +3072,31 @@ Perl_GetVars(pTHX) char ** Perl_get_op_names(pTHX) { - return PL_op_name; + return (char **)PL_op_name; } char ** Perl_get_op_descs(pTHX) { - return PL_op_desc; + return (char **)PL_op_desc; } -char * +const char * Perl_get_no_modify(pTHX) { - return (char*)PL_no_modify; + return PL_no_modify; } U32 * Perl_get_opargs(pTHX) { - return PL_opargs; + return (U32 *)PL_opargs; } PPADDR_t* Perl_get_ppaddr(pTHX) { + dVAR; return (PPADDR_t*)PL_ppaddr; } @@ -2905,7 +3104,7 @@ Perl_get_ppaddr(pTHX) char * Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len) { - char *env_trans = PerlEnv_getenv(env_elem); + char * const env_trans = PerlEnv_getenv(env_elem); if (env_trans) *len = strlen(env_trans); return env_trans; @@ -2916,7 +3115,7 @@ Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len) MGVTBL* Perl_get_vtbl(pTHX_ int vtbl_id) { - MGVTBL* result = Null(MGVTBL*); + const MGVTBL* result = Null(MGVTBL*); switch(vtbl_id) { case want_vtbl_sv: @@ -3012,7 +3211,7 @@ Perl_get_vtbl(pTHX_ int vtbl_id) result = &PL_vtbl_utf8; break; } - return result; + return (MGVTBL*)result; } I32 @@ -3066,25 +3265,21 @@ Perl_my_fflush_all(pTHX) } void -Perl_report_evil_fh(pTHX_ GV *gv, IO *io, I32 op) +Perl_report_evil_fh(pTHX_ const GV *gv, const IO *io, I32 op) { - char *func = + const char * const 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) + const char * const pars = OP_IS_FILETEST(op) ? "" : "()"; + const char * const type = OP_IS_SOCKET(op) || (gv && io && IoTYPE(io) == IoTYPE_SOCKET) ? "socket" : "filehandle"; - char *name = NULL; - - if (gv && isGV(gv)) { - name = GvENAME(gv); - } + const char * const name = gv && isGV(gv) ? GvENAME(gv) : NULL; if (op == OP_phoney_OUTPUT_ONLY || op == OP_phoney_INPUT_ONLY) { if (ckWARN(WARN_IO)) { - const char *direction = (op == OP_phoney_INPUT_ONLY) ? "in" : "out"; + const char * const direction = (op == OP_phoney_INPUT_ONLY) ? "in" : "out"; if (name && *name) Perl_warner(aTHX_ packWARN(WARN_IO), "Filehandle %s opened only for %sput", @@ -3095,7 +3290,7 @@ Perl_report_evil_fh(pTHX_ GV *gv, IO *io, I32 op) } } else { - char *vile; + const char *vile; I32 warn_type; if (gv && io && IoTYPE(io) == IoTYPE_CLOSED) { @@ -3140,7 +3335,7 @@ int Perl_ebcdic_control(pTHX_ int ch) { if (ch > 'a') { - char *ctlp; + const char *ctlp; if (islower(ch)) ch = toupper(ch); @@ -3199,8 +3394,13 @@ Perl_init_tm(pTHX_ struct tm *ptm) /* see mktime, strftime and asctime */ { #ifdef HAS_TM_TM_ZONE Time_t now; + const struct tm* my_tm; (void)time(&now); - Copy(localtime(&now), ptm, 1, struct tm); + my_tm = localtime(&now); + if (my_tm) + Copy(my_tm, ptm, 1, struct tm); +#else + PERL_UNUSED_ARG(ptm); #endif } @@ -3402,7 +3602,7 @@ Perl_mini_mktime(pTHX_ struct tm *ptm) } char * -Perl_my_strftime(pTHX_ char *fmt, int sec, int min, int hour, int mday, int mon, int year, int wday, int yday, int isdst) +Perl_my_strftime(pTHX_ const 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; @@ -3436,7 +3636,7 @@ Perl_my_strftime(pTHX_ char *fmt, int sec, int min, int hour, int mday, int mon, } STMT_END; #endif buflen = 64; - New(0, buf, buflen, char); + Newx(buf, buflen, char); len = strftime(buf, buflen, fmt, &mytm); /* ** The following is needed to handle to the situation where @@ -3456,10 +3656,10 @@ Perl_my_strftime(pTHX_ char *fmt, int sec, int min, int hour, int mday, int mon, return buf; else { /* Possibly buf overflowed - try again with a bigger buf */ - int fmtlen = strlen(fmt); - int bufsize = fmtlen + buflen; + const int fmtlen = strlen(fmt); + const int bufsize = fmtlen + buflen; - New(0, buf, bufsize, char); + Newx(buf, bufsize, char); while (buf) { buflen = strftime(buf, bufsize, fmt, &mytm); if (buflen > 0 && buflen < bufsize) @@ -3470,13 +3670,13 @@ Perl_my_strftime(pTHX_ char *fmt, int sec, int min, int hour, int mday, int mon, buf = NULL; break; } - bufsize *= 2; - Renew(buf, bufsize, char); + Renew(buf, bufsize*2, char); } return buf; } #else Perl_croak(aTHX_ "panic: no strftime"); + return NULL; #endif } @@ -3524,8 +3724,7 @@ Perl_getcwd_sv(pTHX_ register SV *sv) * 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); + sv_setpvn(sv, buf, strlen(buf)); return TRUE; } else { @@ -3538,11 +3737,10 @@ Perl_getcwd_sv(pTHX_ register SV *sv) Stat_t statbuf; int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino; - int namelen, pathlen=0; - DIR *dir; + int pathlen=0; Direntry_t *dp; - (void)SvUPGRADE(sv, SVt_PV); + SvUPGRADE(sv, SVt_PV); if (PerlLIO_lstat(".", &statbuf) < 0) { SV_CWD_RETURN_UNDEF; @@ -3554,6 +3752,7 @@ Perl_getcwd_sv(pTHX_ register SV *sv) cino = orig_cino; for (;;) { + DIR *dir; odev = cdev; oino = cino; @@ -3576,9 +3775,9 @@ Perl_getcwd_sv(pTHX_ register SV *sv) while ((dp = PerlDir_read(dir)) != NULL) { #ifdef DIRNAMLEN - namelen = dp->d_namlen; + const int namelen = dp->d_namlen; #else - namelen = strlen(dp->d_name); + const int namelen = strlen(dp->d_name); #endif /* skip . and .. */ if (SV_CWD_ISDOT(dp)) { @@ -3608,7 +3807,7 @@ Perl_getcwd_sv(pTHX_ register SV *sv) if (pathlen) { /* shift down */ - Move(SvPVX(sv), SvPVX(sv) + namelen + 1, pathlen, char); + Move(SvPVX_const(sv), SvPVX(sv) + namelen + 1, pathlen, char); } /* prepend current directory to the front */ @@ -3630,7 +3829,7 @@ Perl_getcwd_sv(pTHX_ register SV *sv) *SvEND(sv) = '\0'; SvPOK_only(sv); - if (PerlDir_chdir(SvPVX(sv)) < 0) { + if (PerlDir_chdir(SvPVX_const(sv)) < 0) { SV_CWD_RETURN_UNDEF; } } @@ -3676,62 +3875,84 @@ it doesn't. =cut */ -char * -Perl_scan_version(pTHX_ char *s, SV *rv, bool qv) +const char * +Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv) { - const char *start = s; - char *pos = s; - I32 saw_period = 0; - bool saw_under = 0; - SV* sv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */ - (void)sv_upgrade(sv, SVt_PVAV); /* needs to be an AV type */ - - /* pre-scan the imput string to check for decimals */ + const char *start; + const char *pos; + const char *last; + int saw_period = 0; + int alpha = 0; + int width = 3; + AV *av = newAV(); + SV *hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */ + (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */ + +#ifndef NODEFAULT_SHAREKEYS + HvSHAREKEYS_on(hv); /* key-sharing on by default */ +#endif + + while (isSPACE(*s)) /* leading whitespace is OK */ + s++; + + if (*s == 'v') { + s++; /* get past 'v' */ + qv = 1; /* force quoted version processing */ + } + + start = last = pos = s; + + /* pre-scan the input string to check for decimals/underbars */ while ( *pos == '.' || *pos == '_' || isDIGIT(*pos) ) { if ( *pos == '.' ) { - if ( saw_under ) + if ( alpha ) Perl_croak(aTHX_ "Invalid version format (underscores before decimal)"); saw_period++ ; + last = pos; } else if ( *pos == '_' ) { - if ( saw_under ) + if ( alpha ) Perl_croak(aTHX_ "Invalid version format (multiple underscores)"); - saw_under = 1; + alpha = 1; + width = pos - last - 1; /* natural width of sub-version */ } pos++; } - pos = s; - if (*pos == 'v') { - pos++; /* get past 'v' */ + if ( saw_period > 1 ) qv = 1; /* force quoted version processing */ - } + + pos = s; + + if ( qv ) + hv_store((HV *)hv, "qv", 2, newSViv(qv), 0); + if ( alpha ) + hv_store((HV *)hv, "alpha", 5, newSViv(alpha), 0); + if ( !qv && width < 3 ) + hv_store((HV *)hv, "width", 5, newSViv(width), 0); + while (isDIGIT(*pos)) pos++; if (!isALPHA(*pos)) { I32 rev; - if (*s == 'v') s++; /* get past 'v' */ - for (;;) { rev = 0; { /* this is atoi() that delimits on underscores */ - char *end = pos; + const char *end = pos; I32 mult = 1; I32 orev; - if ( s < pos && s > start && *(s-1) == '_' ) { - mult *= -1; /* alpha version */ - } + /* the following if() will only be true after the decimal * point of a version originally created with a bare * floating point number, i.e. not quoted in any way */ - if ( !qv && s > start+1 && saw_period == 1 && !saw_under ) { - mult = 100; + if ( !qv && s > start && saw_period == 1 ) { + mult *= 100; while ( s < end ) { orev = rev; rev += (*s - '0') * mult; @@ -3739,6 +3960,8 @@ Perl_scan_version(pTHX_ char *s, SV *rv, bool qv) if ( PERL_ABS(orev) > PERL_ABS(rev) ) Perl_croak(aTHX_ "Integer overflow in version"); s++; + if ( *s == '_' ) + s++; } } else { @@ -3751,10 +3974,12 @@ Perl_scan_version(pTHX_ char *s, SV *rv, bool qv) } } } - + /* Append revision */ - av_push((AV *)sv, newSViv(rev)); - if ( (*pos == '.' || *pos == '_') && isDIGIT(pos[1])) + av_push(av, newSViv(rev)); + if ( *pos == '.' && isDIGIT(pos[1]) ) + s = ++pos; + else if ( *pos == '_' && isDIGIT(pos[1]) ) s = ++pos; else if ( isDIGIT(*pos) ) s = pos; @@ -3762,18 +3987,39 @@ Perl_scan_version(pTHX_ char *s, SV *rv, bool qv) s = pos; break; } - while ( isDIGIT(*pos) ) { - if ( !saw_under && saw_period == 1 && pos-s == 3 ) - break; - pos++; + if ( qv ) { + while ( isDIGIT(*pos) ) + pos++; + } + else { + int digits = 0; + while ( ( isDIGIT(*pos) || *pos == '_' ) && digits < 3 ) { + if ( *pos != '_' ) + digits++; + pos++; + } } } } - if ( qv ) { /* quoted versions always become full version objects */ - I32 len = av_len((AV *)sv); - for ( len = 2 - len; len != 0; len-- ) - av_push((AV *)sv, newSViv(0)); + if ( qv ) { /* quoted versions always get at least three terms*/ + I32 len = av_len(av); + /* This for loop appears to trigger a compiler bug on OS X, as it + loops infinitely. Yes, len is negative. No, it makes no sense. + 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)); + */ + len = 2 - len; + while (len-- > 0) + av_push(av, newSViv(0)); } + + if ( av_len(av) == -1 ) /* oops, someone forgot to pass a value */ + av_push(av, newSViv(0)); + + /* And finally, store the AV in the hash */ + hv_store((HV *)hv, "version", 7, newRV_noinc((SV *)av), 0); return s; } @@ -3793,13 +4039,52 @@ want to upgrade the SV. SV * Perl_new_version(pTHX_ SV *ver) { - SV *rv = newSV(0); + SV * const rv = newSV(0); + if ( sv_derived_from(ver,"version") ) /* can just copy directly */ + { + I32 key; + AV * const av = newAV(); + AV *sav; + /* This will get reblessed later if a derived class*/ + SV * const hv = newSVrv(rv, "version"); + (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */ +#ifndef NODEFAULT_SHAREKEYS + HvSHAREKEYS_on(hv); /* key-sharing on by default */ +#endif + + if ( SvROK(ver) ) + ver = SvRV(ver); + + /* Begin copying all of the elements */ + if ( hv_exists((HV *)ver, "qv", 2) ) + hv_store((HV *)hv, "qv", 2, &PL_sv_yes, 0); + + if ( hv_exists((HV *)ver, "alpha", 5) ) + hv_store((HV *)hv, "alpha", 5, &PL_sv_yes, 0); + + if ( hv_exists((HV*)ver, "width", 5 ) ) + { + const I32 width = SvIV(*hv_fetch((HV*)ver, "width", 5, FALSE)); + hv_store((HV *)hv, "width", 5, newSViv(width), 0); + } + + sav = (AV *)SvRV(*hv_fetch((HV*)ver, "version", 7, FALSE)); + /* This will get reblessed later if a derived class*/ + for ( key = 0; key <= av_len(sav); key++ ) + { + const I32 rev = SvIV(*av_fetch(sav, key, FALSE)); + av_push(av, newSViv(rev)); + } + + hv_store((HV *)hv, "version", 7, newRV_noinc((SV *)av), 0); + return rv; + } #ifdef SvVOK if ( SvVOK(ver) ) { /* already a v-string */ - char *version; - MAGIC* mg = mg_find(ver,PERL_MAGIC_vstring); - version = savepvn( (const char*)mg->mg_ptr,mg->mg_len ); - sv_setpv(rv,version); + const MAGIC* const mg = mg_find(ver,PERL_MAGIC_vstring); + const STRLEN len = mg->mg_len; + char * const version = savepvn( (const char*)mg->mg_ptr, len); + sv_setpvn(rv,version,len); Safefree(version); } else { @@ -3838,21 +4123,59 @@ Perl_upg_version(pTHX_ SV *ver) } #ifdef SvVOK else if ( SvVOK(ver) ) { /* already a v-string */ - MAGIC* mg = mg_find(ver,PERL_MAGIC_vstring); + const MAGIC* const mg = mg_find(ver,PERL_MAGIC_vstring); version = savepvn( (const char*)mg->mg_ptr,mg->mg_len ); qv = 1; } #endif else /* must be a string or something like a string */ { - STRLEN n_a; - version = savepv(SvPV(ver,n_a)); + version = savepv(SvPV_nolen(ver)); } (void)scan_version(version, ver, qv); Safefree(version); return ver; } +/* +=for apidoc vverify + +Validates that the SV contains a valid version object. + + bool vverify(SV *vobj); + +Note that it only confirms the bare minimum structure (so as not to get +confused by derived classes which may contain additional hash entries): + +=over 4 + +=item * The SV contains a [reference to a] hash + +=item * The hash contains a "version" key + +=item * The "version" key has [a reference to] an AV as its value + +=back + +=cut +*/ + +bool +Perl_vverify(pTHX_ SV *vs) +{ + SV *sv; + if ( SvROK(vs) ) + vs = SvRV(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))) + && SvTYPE(sv) == SVt_PVAV ) + return TRUE; + else + return FALSE; +} /* =for apidoc vnumify @@ -3872,25 +4195,64 @@ SV * Perl_vnumify(pTHX_ SV *vs) { I32 i, len, digit; - SV *sv = newSV(0); + int width; + bool alpha = FALSE; + SV * const sv = newSV(0); + AV *av; if ( SvROK(vs) ) vs = SvRV(vs); - len = av_len((AV *)vs); + + if ( !vverify(vs) ) + Perl_croak(aTHX_ "Invalid version object"); + + /* see if various flags exist */ + 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)); + else + width = 3; + + + /* attempt to retrieve the version array */ + if ( !(av = (AV *)SvRV(*hv_fetch((HV*)vs, "version", 7, FALSE)) ) ) { + sv_catpvn(sv,"0",1); + return sv; + } + + len = av_len(av); if ( len == -1 ) { - Perl_sv_catpv(aTHX_ sv,"0"); + sv_catpvn(sv,"0",1); return sv; } - digit = SvIVX(*av_fetch((AV *)vs, 0, 0)); - Perl_sv_setpvf(aTHX_ sv,"%d.", (int)PERL_ABS(digit)); - for ( i = 1 ; i <= len ; i++ ) + + digit = SvIV(*av_fetch(av, 0, 0)); + Perl_sv_setpvf(aTHX_ sv, "%d.", (int)PERL_ABS(digit)); + for ( i = 1 ; i < len ; i++ ) + { + digit = SvIV(*av_fetch(av, i, 0)); + if ( width < 3 ) { + const int denom = (int)pow(10,(3-width)); + const div_t term = div((int)PERL_ABS(digit),denom); + Perl_sv_catpvf(aTHX_ sv, "%0*d_%d", width, term.quot, term.rem); + } + else { + Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit); + } + } + + if ( len > 0 ) { - digit = SvIVX(*av_fetch((AV *)vs, i, 0)); - Perl_sv_catpvf(aTHX_ sv,"%03d", (int)PERL_ABS(digit)); + digit = SvIV(*av_fetch(av, len, 0)); + if ( alpha && width == 3 ) /* alpha version */ + sv_catpvn(sv,"_",1); + Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit); + } + else /* len == 0 */ + { + sv_catpvn(sv,"000",3); } - if ( len == 0 ) - Perl_sv_catpv(aTHX_ sv,"000"); - sv_setnv(sv, SvNV(sv)); return sv; } @@ -3912,33 +4274,48 @@ SV * Perl_vnormal(pTHX_ SV *vs) { I32 i, len, digit; - SV *sv = newSV(0); + bool alpha = FALSE; + SV * const sv = newSV(0); + AV *av; if ( SvROK(vs) ) vs = SvRV(vs); - len = av_len((AV *)vs); + + if ( !vverify(vs) ) + Perl_croak(aTHX_ "Invalid version object"); + + if ( hv_exists((HV*)vs, "alpha", 5 ) ) + alpha = TRUE; + av = (AV *)SvRV(*hv_fetch((HV*)vs, "version", 7, FALSE)); + + len = av_len(av); if ( len == -1 ) { - Perl_sv_catpv(aTHX_ sv,""); + sv_catpvn(sv,"",0); return sv; } - digit = SvIVX(*av_fetch((AV *)vs, 0, 0)); - Perl_sv_setpvf(aTHX_ sv,"%"IVdf,(IV)digit); - for ( i = 1 ; i <= len ; i++ ) + digit = SvIV(*av_fetch(av, 0, 0)); + Perl_sv_setpvf(aTHX_ sv, "v%"IVdf, (IV)digit); + for ( i = 1 ; i < len ; i++ ) { + digit = SvIV(*av_fetch(av, i, 0)); + Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit); + } + + if ( len > 0 ) { - digit = SvIVX(*av_fetch((AV *)vs, i, 0)); - if ( digit < 0 ) - Perl_sv_catpvf(aTHX_ sv,"_%"IVdf,(IV)-digit); + /* handle last digit specially */ + digit = SvIV(*av_fetch(av, len, 0)); + if ( alpha ) + Perl_sv_catpvf(aTHX_ sv, "_%"IVdf, (IV)digit); else - Perl_sv_catpvf(aTHX_ sv,".%"IVdf,(IV)digit); + Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit); } - + if ( len <= 2 ) { /* short version, must be at least three */ for ( len = 2 - len; len != 0; len-- ) - Perl_sv_catpv(aTHX_ sv,".0"); + sv_catpvn(sv,".0",2); } - return sv; -} +} /* =for apidoc vstringify @@ -3954,15 +4331,16 @@ the original version contained 1 or more dots, respectively SV * Perl_vstringify(pTHX_ SV *vs) { - I32 len; if ( SvROK(vs) ) vs = SvRV(vs); - len = av_len((AV *)vs); - if ( len < 2 ) - return vnumify(vs); - else + if ( !vverify(vs) ) + Perl_croak(aTHX_ "Invalid version object"); + + if ( hv_exists((HV *)vs, "qv", 2) ) return vnormal(vs); + else + return vnumify(vs); } /* @@ -3975,40 +4353,71 @@ converted into version objects. */ int -Perl_vcmp(pTHX_ SV *lsv, SV *rsv) +Perl_vcmp(pTHX_ SV *lhv, SV *rhv) { I32 i,l,m,r,retval; - if ( SvROK(lsv) ) - lsv = SvRV(lsv); - if ( SvROK(rsv) ) - rsv = SvRV(rsv); - l = av_len((AV *)lsv); - r = av_len((AV *)rsv); + bool lalpha = FALSE; + bool ralpha = FALSE; + I32 left = 0; + I32 right = 0; + AV *lav, *rav; + if ( SvROK(lhv) ) + lhv = SvRV(lhv); + if ( SvROK(rhv) ) + rhv = SvRV(rhv); + + if ( !vverify(lhv) ) + Perl_croak(aTHX_ "Invalid version object"); + + if ( !vverify(rhv) ) + Perl_croak(aTHX_ "Invalid version object"); + + /* get the left hand term */ + lav = (AV *)SvRV(*hv_fetch((HV*)lhv, "version", 7, 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)); + if ( hv_exists((HV*)rhv, "alpha", 5 ) ) + ralpha = TRUE; + + l = av_len(lav); + r = av_len(rav); m = l < r ? l : r; retval = 0; i = 0; while ( i <= m && retval == 0 ) { - I32 left = SvIV(*av_fetch((AV *)lsv,i,0)); - I32 right = SvIV(*av_fetch((AV *)rsv,i,0)); - bool lalpha = left < 0 ? 1 : 0; - bool ralpha = right < 0 ? 1 : 0; - left = abs(left); - right = abs(right); - if ( left < right || (left == right && lalpha && !ralpha) ) + left = SvIV(*av_fetch(lav,i,0)); + right = SvIV(*av_fetch(rav,i,0)); + if ( left < right ) retval = -1; - if ( left > right || (left == right && ralpha && !lalpha) ) + if ( left > right ) retval = +1; i++; } + /* tiebreaker for alpha with identical terms */ + if ( retval == 0 && l == r && left == right && ( lalpha || ralpha ) ) + { + if ( lalpha && !ralpha ) + { + retval = -1; + } + else if ( ralpha && !lalpha) + { + retval = +1; + } + } + if ( l != r && retval == 0 ) /* possible match except for trailing 0's */ { if ( l < r ) { while ( i <= r && retval == 0 ) { - if ( SvIV(*av_fetch((AV *)rsv,i,0)) != 0 ) + if ( SvIV(*av_fetch(rav,i,0)) != 0 ) retval = -1; /* not a match after all */ i++; } @@ -4017,7 +4426,7 @@ Perl_vcmp(pTHX_ SV *lsv, SV *rsv) { while ( i <= l && retval == 0 ) { - if ( SvIV(*av_fetch((AV *)lsv,i,0)) != 0 ) + if ( SvIV(*av_fetch(lav,i,0)) != 0 ) retval = +1; /* not a match after all */ i++; } @@ -4160,7 +4569,7 @@ S_socketpair_udp (int fd[2]) { errno = ECONNABORTED; tidy_up_and_fail: { - int save_errno = errno; + const int save_errno = errno; if (sockets[0] != -1) PerlLIO_close(sockets[0]); if (sockets[1] != -1) @@ -4253,7 +4662,15 @@ Perl_my_socketpair (int family, int type, int protocol, int fd[2]) { return 0; abort_tidy_up_and_fail: - errno = ECONNABORTED; /* I hope this is portable and appropriate. */ +#ifdef ECONNABORTED + errno = ECONNABORTED; /* This would be the standard thing to do. */ +#else +# ifdef ECONNREFUSED + errno = ECONNREFUSED; /* E.g. Symbian does not have ECONNABORTED. */ +# else + errno = ETIMEDOUT; /* Desperation time. */ +# endif +#endif tidy_up_and_fail: { int save_errno = errno; @@ -4294,6 +4711,7 @@ some level of strict-ness. void Perl_sv_nosharing(pTHX_ SV *sv) { + PERL_UNUSED_ARG(sv); } /* @@ -4309,6 +4727,7 @@ some level of strict-ness. void Perl_sv_nolocking(pTHX_ SV *sv) { + PERL_UNUSED_ARG(sv); } @@ -4325,12 +4744,13 @@ some level of strict-ness. void Perl_sv_nounlocking(pTHX_ SV *sv) { + PERL_UNUSED_ARG(sv); } U32 -Perl_parse_unicode_opts(pTHX_ char **popt) +Perl_parse_unicode_opts(pTHX_ const char **popt) { - char *p = *popt; + const char *p = *popt; U32 opt = 0; if (*p) { @@ -4434,7 +4854,7 @@ Perl_seed(pTHX) #endif fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0); if (fd != -1) { - if (PerlLIO_read(fd, &u, sizeof u) != sizeof u) + if (PerlLIO_read(fd, (void*)&u, sizeof u) != sizeof u) u = 0; PerlLIO_close(fd); if (u) @@ -4465,7 +4885,7 @@ Perl_seed(pTHX) UV Perl_get_hash_seed(pTHX) { - char *s = PerlEnv_getenv("PERL_HASH_SEED"); + const char *s = PerlEnv_getenv("PERL_HASH_SEED"); UV myseed = 0; if (s) @@ -4498,3 +4918,153 @@ Perl_get_hash_seed(pTHX) return myseed; } + +#ifdef USE_ITHREADS +bool +Perl_stashpv_hvname_match(pTHX_ const COP *c, const HV *hv) +{ + const char * const stashpv = CopSTASHPV(c); + const char * const name = HvNAME_get(hv); + + if (stashpv == name) + return TRUE; + if (stashpv && name) + if (strEQ(stashpv, name)) + return TRUE; + return FALSE; +} +#endif + + +#ifdef PERL_GLOBAL_STRUCT + +struct perl_vars * +Perl_init_global_struct(pTHX) +{ + struct perl_vars *plvarsp = NULL; +#ifdef PERL_GLOBAL_STRUCT +# define PERL_GLOBAL_STRUCT_INIT +# include "opcode.h" /* the ppaddr and check */ + IV nppaddr = sizeof(Gppaddr)/sizeof(Perl_ppaddr_t); + IV ncheck = sizeof(Gcheck) /sizeof(Perl_check_t); +# ifdef PERL_GLOBAL_STRUCT_PRIVATE + /* PerlMem_malloc() because can't use even safesysmalloc() this early. */ + plvarsp = (struct perl_vars*)PerlMem_malloc(sizeof(struct perl_vars)); + if (!plvarsp) + exit(1); +# else + plvarsp = PL_VarsPtr; +# endif /* PERL_GLOBAL_STRUCT_PRIVATE */ +# undef PERLVAR +# undef PERLVARA +# undef PERLVARI +# undef PERLVARIC +# undef PERLVARISC +# define PERLVAR(var,type) /**/ +# define PERLVARA(var,n,type) /**/ +# define PERLVARI(var,type,init) plvarsp->var = init; +# define PERLVARIC(var,type,init) plvarsp->var = init; +# define PERLVARISC(var,init) Copy(init, plvarsp->var, sizeof(init), char); +# include "perlvars.h" +# undef PERLVAR +# undef PERLVARA +# undef PERLVARI +# undef PERLVARIC +# undef PERLVARISC +# ifdef PERL_GLOBAL_STRUCT + plvarsp->Gppaddr = PerlMem_malloc(nppaddr * sizeof(Perl_ppaddr_t)); + if (!plvarsp->Gppaddr) + exit(1); + plvarsp->Gcheck = PerlMem_malloc(ncheck * sizeof(Perl_check_t)); + if (!plvarsp->Gcheck) + exit(1); + Copy(Gppaddr, plvarsp->Gppaddr, nppaddr, Perl_ppaddr_t); + Copy(Gcheck, plvarsp->Gcheck, ncheck, Perl_check_t); +# endif +# ifdef PERL_SET_VARS + PERL_SET_VARS(plvarsp); +# endif +# undef PERL_GLOBAL_STRUCT_INIT +#endif + return plvarsp; +} + +#endif /* PERL_GLOBAL_STRUCT */ + +#ifdef PERL_GLOBAL_STRUCT + +void +Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp) +{ +#ifdef PERL_GLOBAL_STRUCT +# ifdef PERL_UNSET_VARS + PERL_UNSET_VARS(plvarsp); +# endif + free(plvarsp->Gppaddr); + free(plvarsp->Gcheck); +# ifdef PERL_GLOBAL_STRUCT_PRIVATE + free(plvarsp); +# endif +#endif +} + +#endif /* PERL_GLOBAL_STRUCT */ + +#ifdef PERL_MEM_LOG + +#define PERL_MEM_LOG_SPRINTF_BUF_SIZE 128 + +Malloc_t +Perl_mem_log_alloc(const UV n, const UV typesize, const char *typename, Malloc_t newalloc, const char *filename, const int linenumber, const char *funcname) +{ +#ifdef PERL_MEM_LOG_STDERR + /* We can't use PerlIO for obvious reasons. */ + char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE]; + sprintf(buf, + "alloc: %s:%d:%s: %"IVdf" %"UVuf" %s = %"IVdf": %"UVxf"\n", + filename, linenumber, funcname, + n, typesize, typename, n * typesize, PTR2UV(newalloc)); + PerlLIO_write(2, buf, strlen(buf)); +#endif + return newalloc; +} + +Malloc_t +Perl_mem_log_realloc(const UV n, const UV typesize, const char *typename, Malloc_t oldalloc, Malloc_t newalloc, const char *filename, const int linenumber, const char *funcname) +{ +#ifdef PERL_MEM_LOG_STDERR + /* We can't use PerlIO for obvious reasons. */ + char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE]; + sprintf(buf, + "realloc: %s:%d:%s: %"IVdf" %"UVuf" %s = %"IVdf": %"UVxf" -> %"UVxf"\n", + filename, linenumber, funcname, + n, typesize, typename, n * typesize, PTR2UV(oldalloc), PTR2UV(newalloc)); + PerlLIO_write(2, buf, strlen(buf)); +#endif + return newalloc; +} + +Malloc_t +Perl_mem_log_free(Malloc_t oldalloc, const char *filename, const int linenumber, const char *funcname) +{ +#ifdef PERL_MEM_LOG_STDERR + /* We can't use PerlIO for obvious reasons. */ + char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE]; + sprintf(buf, "free: %s:%d:%s: %"UVxf"\n", + filename, linenumber, funcname, PTR2UV(oldalloc)); + PerlLIO_write(2, buf, strlen(buf)); +#endif + return oldalloc; +} + +#endif /* PERL_MEM_LOG */ + +/* + * Local variables: + * c-indentation-style: bsd + * c-basic-offset: 4 + * indent-tabs-mode: t + * End: + * + * ex: set ts=8 sts=4 sw=4 noet: + */