X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=util.c;h=fd5e04150e9972cbdd1e2f77d7ccd8b2f16fea43;hb=45977657b0fa2c29b268b817f40e6b295a501d39;hp=b3375de4f0b41630036035c2758661eb719f3399;hpb=e90e236463307bd7f53439b91573fe42e9cb8901;p=p5sagit%2Fp5-mst-13.2.git diff --git a/util.c b/util.c index b3375de..fd5e041 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" @@ -218,7 +224,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 +246,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 */ @@ -280,7 +286,7 @@ 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) @@ -310,7 +316,7 @@ Perl_rninstr(pTHX_ register const char *big, const char *bigend, const char *lit { 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) @@ -433,14 +439,14 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit STRLEN l; register unsigned char *little = (unsigned char *)SvPV(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) && ((STRLEN)(bigend - big) == littlelen - 1) && (littlelen == 1 || (*big == *little && - memEQ((char *)big, (char *)little, littlelen - 1)))) + memEQ(big, little, littlelen - 1)))) return (char*)big; return Nullch; } @@ -561,7 +567,7 @@ 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 const unsigned char *table = little + littlelen + FBM_TABLE_OFFSET; register unsigned char *oldlittle; if (littlelen > (STRLEN)(bigend - big)) @@ -710,8 +716,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 +729,8 @@ 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; + 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; @@ -752,10 +758,18 @@ char * Perl_savepv(pTHX_ const char *pv) { register char *newaddr; +#ifdef PERL_MALLOC_WRAP + STRLEN pvlen; +#endif if (!pv) return Nullch; +#ifdef PERL_MALLOC_WRAP + pvlen = strlen(pv)+1; + New(902,newaddr,pvlen,char); +#else New(902,newaddr,strlen(pv)+1,char); +#endif return strcpy(newaddr,pv); } @@ -782,10 +796,10 @@ Perl_savepvn(pTHX_ const char *pv, register I32 len) if (pv) { /* might not be null terminated */ newaddr[len] = '\0'; - return CopyD(pv,newaddr,len,char); + return (char *) CopyD(pv,newaddr,len,char); } else { - return ZeroD(newaddr,len+1,char); + return (char *) ZeroD(newaddr,len+1,char); } } @@ -813,6 +827,26 @@ Perl_savesharedpv(pTHX_ const char *pv) return strcpy(newaddr,pv); } +/* +=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(sv, len); + register char *newaddr; + + ++len; + New(903,newaddr,len,char); + return (char *) CopyD(pv,newaddr,len,char); +} /* the SV for Perl_form() and mess() is not kept in an arena */ @@ -953,7 +987,6 @@ Perl_vmess(pTHX_ const char *pat, va_list *args) { SV *sv = mess_alloc(); static char dgd[] = " during global destruction.\n"; - COP *cop; sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') { @@ -965,14 +998,14 @@ 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) && + const bool line_mode = (RsSIMPLE(PL_rs) && SvCUR(PL_rs) == 1 && *SvPVX(PL_rs) == '\n'); Perl_sv_catpvf(aTHX_ sv, ", <%s> %s %"IVdf, PL_last_in_gv == PL_argvgv ? @@ -1031,74 +1064,94 @@ 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 */ + +void S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8); + +STATIC char * +S_vdie_croak_common(pTHX_ const char* pat, va_list* args, 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; - - DEBUG_S(PerlIO_printf(Perl_debug_log, - "%p: die: curstack = %p, mainstack = %p\n", - thr, PL_curstack, PL_mainstack)); if (pat) { - msv = vmess(pat, args); + SV *msv = vmess(pat, args); if (PL_errors && SvCUR(PL_errors)) { sv_catsv(PL_errors, msv); - message = SvPV(PL_errors, msglen); + message = SvPV(PL_errors, *msglen); SvCUR_set(PL_errors, 0); } else - message = SvPV(msv,msglen); - utf8 = SvUTF8(msv); + message = SvPV(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; - } +void +S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8) +{ + HV *stash; + GV *gv; + CV *cv; + /* sv_2cv might call Perl_croak() */ + SV *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; - PUSHSTACKi(PERLSI_DIEHOOK); - PUSHMARK(SP); - XPUSHs(msg); - PUTBACK; - call_sv((SV*)cv, G_DISCARD); - POPSTACK; - LEAVE; + 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; } +} + +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; + + DEBUG_S(PerlIO_printf(Perl_debug_log, + "%p: die: curstack = %p, mainstack = %p\n", + thr, PL_curstack, PL_mainstack)); + + message = S_vdie_croak_common(aTHX_ pat, args, &msglen, &utf8); PL_restartop = die_where(message, msglen); SvFLAGS(ERRSV) |= utf8; @@ -1138,66 +1191,12 @@ 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; - } - - DEBUG_S(PerlIO_printf(Perl_debug_log, "croak: 0x%"UVxf" %s", - PTR2UV(thr), message)); + message = S_vdie_croak_common(aTHX_ pat, args, &msglen, &utf8); - 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; @@ -1355,46 +1354,15 @@ 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); - if (ckDEAD(err)) { + SV *msv = vmess(pat, args); + STRLEN msglen; + const char *message = SvPV(msv, msglen); + 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); @@ -1405,36 +1373,7 @@ 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); } } @@ -1452,7 +1391,7 @@ 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) { #ifdef USE_ITHREADS /* only parent thread can modify process environment */ @@ -1460,6 +1399,7 @@ Perl_my_setenv(pTHX_ char *nam, char *val) #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; @@ -1473,7 +1413,7 @@ Perl_my_setenv(pTHX_ char *nam, char *val) for (max = i; environ[max]; max++) ; tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*)); for (j=0; j 0) { @@ -2130,7 +2073,7 @@ Perl_my_popen(pTHX_ char *cmd, char *mode) register I32 This, that; register Pid_t pid; SV *sv; - I32 doexec = strNE(cmd,"-"); + I32 doexec = !(*cmd == '-' && cmd[1] == '\0'); I32 did_pipes = 0; int pp[2]; @@ -2236,7 +2179,7 @@ Perl_my_popen(pTHX_ char *cmd, char *mode) sv = *av_fetch(PL_fdpid,p[This],TRUE); UNLOCK_FDPID_MUTEX; (void)SvUPGRADE(sv,SVt_IV); - SvIVX(sv) = pid; + SvIV_set(sv, pid); PL_forkprocess = pid; if (did_pipes && pid > 0) { int errkid; @@ -2624,7 +2567,7 @@ Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags) { SV *sv; SV** svp; - char spid[TYPE_CHARS(int)]; + char spid[TYPE_CHARS(IV)]; if (pid > 0) { sprintf(spid, "%"IVdf, (IV)pid); @@ -2640,9 +2583,6 @@ 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)]; - pid = atoi(hv_iterkey(entry,(I32*)statusp)); sv = hv_iterval(PL_pidstatus,entry); *statusp = SvIVX(sv); @@ -2691,12 +2631,12 @@ void 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; + SvIV_set(sv, status); return; } @@ -2791,9 +2731,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; @@ -2813,11 +2753,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 + (void)search_ext; # define MAX_EXT_LEN 0 #endif @@ -2875,7 +2816,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]) @@ -3079,10 +3020,10 @@ Perl_get_op_descs(pTHX) return PL_op_desc; } -char * +const char * Perl_get_no_modify(pTHX) { - return (char*)PL_no_modify; + return PL_no_modify; } U32 * @@ -3262,17 +3203,17 @@ 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 *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 *pars = OP_IS_FILETEST(op) ? "" : "()"; + const char *type = OP_IS_SOCKET(op) || (gv && io && IoTYPE(io) == IoTYPE_SOCKET) ? "socket" : "filehandle"; - char *name = NULL; + const char *name = NULL; if (gv && isGV(gv)) { name = GvENAME(gv); @@ -3291,7 +3232,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) { @@ -3336,7 +3277,7 @@ int Perl_ebcdic_control(pTHX_ int ch) { if (ch > 'a') { - char *ctlp; + const char *ctlp; if (islower(ch)) ch = toupper(ch); @@ -3598,7 +3539,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; @@ -3652,8 +3593,8 @@ 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); while (buf) { @@ -3666,8 +3607,7 @@ 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; } @@ -3873,14 +3813,15 @@ it doesn't. */ char * -Perl_scan_version(pTHX_ char *s, SV *rv, bool qv) +Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv) { const char *start = s; - char *pos = s; + const 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 */ + AvREAL_on((AV*)sv); /* pre-scan the imput string to check for decimals */ while ( *pos == '.' || *pos == '_' || isDIGIT(*pos) ) @@ -3916,7 +3857,7 @@ Perl_scan_version(pTHX_ char *s, SV *rv, bool qv) 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) == '_' ) { @@ -3927,7 +3868,7 @@ Perl_scan_version(pTHX_ char *s, SV *rv, bool qv) * floating point number, i.e. not quoted in any way */ if ( !qv && s > start+1 && saw_period == 1 ) { - mult *= 100; + mult *= 100; while ( s < end ) { orev = rev; rev += (*s - '0') * mult; @@ -3976,9 +3917,9 @@ Perl_scan_version(pTHX_ char *s, SV *rv, bool qv) */ len = 2 - len; while (len-- > 0) - av_push((AV *)sv, newSViv(0)); + av_push((AV *)sv, newSViv(0)); } - return s; + return (char *)s; } /* @@ -3998,6 +3939,20 @@ SV * Perl_new_version(pTHX_ SV *ver) { SV *rv = newSV(0); + if ( sv_derived_from(ver,"version") ) /* can just copy directly */ + { + I32 key; + AV *av = (AV *)SvRV(ver); + SV* sv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */ + (void)sv_upgrade(sv, SVt_PVAV); /* needs to be an AV type */ + AvREAL_on((AV*)sv); + for ( key = 0; key <= av_len(av); key++ ) + { + I32 rev = SvIV(*av_fetch(av, key, FALSE)); + av_push((AV *)sv, newSViv(rev)); + } + return rv; + } #ifdef SvVOK if ( SvVOK(ver) ) { /* already a v-string */ char *version; @@ -4049,8 +4004,7 @@ Perl_upg_version(pTHX_ SV *ver) #endif else /* must be a string or something like a string */ { - STRLEN n_a; - version = savepv(SvPV(ver,n_a)); + version = savesvpv(ver); } (void)scan_version(version, ver, qv); Safefree(version); @@ -4096,10 +4050,11 @@ Perl_vnumify(pTHX_ SV *vs) if ( len > 0 ) { digit = SvIVX(*av_fetch((AV *)vs, len, 0)); - - /* Don't display any additional trailing zeros */ if ( (int)PERL_ABS(digit) != 0 || len == 1 ) { + if ( digit < 0 ) /* alpha version */ + Perl_sv_catpv(aTHX_ sv,"_"); + /* Don't display additional trailing zeros */ Perl_sv_catpvf(aTHX_ sv,"%03d", (int)PERL_ABS(digit)); } } @@ -4170,12 +4125,13 @@ the original version contained 1 or more dots, respectively SV * Perl_vstringify(pTHX_ SV *vs) { - I32 len; + I32 len, digit; if ( SvROK(vs) ) vs = SvRV(vs); len = av_len((AV *)vs); + digit = SvIVX(*av_fetch((AV *)vs, len, 0)); - if ( len < 2 ) + if ( len < 2 || ( len == 2 && digit < 0 ) ) return vnumify(vs); else return vnormal(vs); @@ -4510,6 +4466,7 @@ some level of strict-ness. void Perl_sv_nosharing(pTHX_ SV *sv) { + (void)sv; } /* @@ -4525,6 +4482,7 @@ some level of strict-ness. void Perl_sv_nolocking(pTHX_ SV *sv) { + (void)sv; } @@ -4541,12 +4499,13 @@ some level of strict-ness. void Perl_sv_nounlocking(pTHX_ SV *sv) { + (void)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) { @@ -4681,7 +4640,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)