X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=util.c;h=556abb715da8e076742a54afb16f5e4c650e2a63;hb=d2aeed1648166d254ac68525c35b77dec4ba8772;hp=80e283b904f7c5a9474068b3e1e0d1ba0f0f6152;hpb=6460123ae692a9c25bc8c2253f12c8cf6f0ebdc0;p=p5sagit%2Fp5-mst-13.2.git diff --git a/util.c b/util.c index 80e283b..556abb7 100644 --- a/util.c +++ b/util.c @@ -258,14 +258,19 @@ Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size) { dTHX; Malloc_t ptr; -#if defined(DEBUGGING) || defined(HAS_64K_LIMIT) || defined(PERL_TRACK_MEMPOOL) - const MEM_SIZE total_size = size * count -#ifdef PERL_TRACK_MEMPOOL - + sTHX -#endif - ; -#endif + MEM_SIZE total_size = 0; + /* Even though calloc() for zero bytes is strange, be robust. */ + if (size && (count <= MEM_SIZE_MAX / size)) + total_size = size * count; + else + Perl_croak_nocontext(PL_memory_wrap); +#ifdef PERL_TRACK_MEMPOOL + if (sTHX <= MEM_SIZE_MAX - (MEM_SIZE)total_size) + total_size += sTHX; + else + Perl_croak_nocontext(PL_memory_wrap); +#endif #ifdef HAS_64K_LIMIT if (total_size > 0xffff) { PerlIO_printf(Perl_error_log, @@ -280,11 +285,15 @@ Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size) #ifdef PERL_TRACK_MEMPOOL /* Have to use malloc() because we've added some space for our tracking header. */ - ptr = (Malloc_t)PerlMem_malloc(total_size); + /* malloc(0) is non-portable. */ + ptr = (Malloc_t)PerlMem_malloc(total_size ? total_size : 1); #else /* Use calloc() because it might save a memset() if the memory is fresh and clean from the OS. */ - ptr = (Malloc_t)PerlMem_calloc(count, size); + if (count && size) + ptr = (Malloc_t)PerlMem_calloc(count, size); + else /* calloc(0) is non-portable. */ + ptr = (Malloc_t)PerlMem_calloc(count ? count : 1, size ? size : 1); #endif 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)total_size)); @@ -421,13 +430,13 @@ Perl_ninstr(pTHX_ const char *big, const char *bigend, const char *little, const bigend -= lend - little; OUTER: while (big <= bigend) { - if (*big++ != first) - goto OUTER; - for (x=big,s=little; s < lend; x++,s++) { - if (*s != *x) - goto OUTER; + if (*big++ == first) { + for (x=big,s=little; s < lend; x++,s++) { + if (*s != *x) + goto OUTER; + } + return (char*)(big-1); } - return (char*)(big-1); } } return NULL; @@ -1016,7 +1025,7 @@ S_mess_alloc(pTHX) XPVMG *any; if (!PL_dirty) - return sv_2mortal(newSVpvs("")); + return newSVpvs_flags("", SVs_TEMP); if (PL_mess_sv) return PL_mess_sv; @@ -1207,7 +1216,7 @@ Perl_write_to_stderr(pTHX_ const char* message, int msglen) PUSHMARK(SP); EXTEND(SP,2); PUSHs(SvTIED_obj((SV*)io, mg)); - PUSHs(sv_2mortal(newSVpvn(message, msglen))); + mPUSHp(message, msglen); PUTBACK; call_method("PRINT", G_SCALAR); @@ -1261,8 +1270,7 @@ S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8, bool warn) *hook = NULL; } if (warn || message) { - msg = newSVpvn(message, msglen); - SvFLAGS(msg) |= utf8; + msg = newSVpvn_flags(message, msglen, utf8); SvREADONLY_on(msg); SAVEFREESV(msg); } @@ -1823,24 +1831,51 @@ Perl_my_memcmp(const char *s1, const char *s2, register I32 len) #endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */ #ifndef HAS_VPRINTF +/* This vsprintf replacement should generally never get used, since + vsprintf was available in both System V and BSD 2.11. (There may + be some cross-compilation or embedded set-ups where it is needed, + however.) + + If you encounter a problem in this function, it's probably a symptom + that Configure failed to detect your system's vprintf() function. + See the section on "item vsprintf" in the INSTALL file. + + This version may compile on systems with BSD-ish , + but probably won't on others. +*/ #ifdef USE_CHAR_VSPRINTF char * #else int #endif -vsprintf(char *dest, const char *pat, char *args) +vsprintf(char *dest, const char *pat, void *args) { FILE fakebuf; +#if defined(STDIO_PTR_LVALUE) && defined(STDIO_CNT_LVALUE) + FILE_ptr(&fakebuf) = (STDCHAR *) dest; + FILE_cnt(&fakebuf) = 32767; +#else + /* These probably won't compile -- If you really need + this, you'll have to figure out some other method. */ fakebuf._ptr = dest; fakebuf._cnt = 32767; +#endif #ifndef _IOSTRG #define _IOSTRG 0 #endif fakebuf._flag = _IOWRT|_IOSTRG; _doprnt(pat, args, &fakebuf); /* what a kludge */ - (void)putc('\0', &fakebuf); +#if defined(STDIO_PTR_LVALUE) + *(FILE_ptr(&fakebuf)++) = '\0'; +#else + /* PerlIO has probably #defined away fputc, but we want it here. */ +# ifdef fputc +# undef fputc /* XXX Should really restore it later */ +# endif + (void)fputc('\0', &fakebuf); +#endif #ifdef USE_CHAR_VSPRINTF return(dest); #else @@ -1873,7 +1908,10 @@ Perl_my_htonl(pTHX_ long l) char c[sizeof(long)]; } u; -#if BYTEORDER == 0x1234 +#if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678 +#if BYTEORDER == 0x12345678 + u.result = 0; +#endif u.c[0] = (l >> 24) & 255; u.c[1] = (l >> 16) & 255; u.c[2] = (l >> 8) & 255; @@ -2177,7 +2215,7 @@ Perl_my_swabn(void *ptr, int n) PerlIO * Perl_my_popen_list(pTHX_ char *mode, int n, SV **args) { -#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) && !defined(NETWARE) +#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) && !defined(NETWARE) && !defined(__LIBCATAMOUNT__) dVAR; int p[2]; register I32 This, that; @@ -2304,7 +2342,7 @@ Perl_my_popen_list(pTHX_ char *mode, int n, SV **args) return PerlIO_fdopen(p[This], mode); #else # ifdef OS2 /* Same, without fork()ing and all extra overhead... */ - return my_syspopen4(aTHX_ Nullch, mode, n, args); + return my_syspopen4(aTHX_ NULL, mode, n, args); # else Perl_croak(aTHX_ "List form of piped open not implemented"); return (PerlIO *) NULL; @@ -2313,7 +2351,7 @@ 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) +#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) && !defined(__LIBCATAMOUNT__) PerlIO * Perl_my_popen(pTHX_ const char *cmd, const char *mode) { @@ -2472,7 +2510,7 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode) #if defined(atarist) || defined(EPOC) FILE *popen(); PerlIO * -Perl_my_popen((pTHX_ const char *cmd, const char *mode) +Perl_my_popen(pTHX_ const char *cmd, const char *mode) { PERL_FLUSHALL_FOR_CHILD; /* Call system's popen() to get a FILE *, then import it. @@ -2485,7 +2523,7 @@ Perl_my_popen((pTHX_ const char *cmd, const char *mode) #if defined(DJGPP) FILE *djgpp_popen(); PerlIO * -Perl_my_popen((pTHX_ const char *cmd, const char *mode) +Perl_my_popen(pTHX_ const char *cmd, const char *mode) { PERL_FLUSHALL_FOR_CHILD; /* Call system's popen() to get a FILE *, then import it. @@ -2494,6 +2532,14 @@ Perl_my_popen((pTHX_ const char *cmd, const char *mode) */ return PerlIO_importFILE(djgpp_popen(cmd, mode), 0); } +#else +#if defined(__LIBCATAMOUNT__) +PerlIO * +Perl_my_popen(pTHX_ const char *cmd, const char *mode) +{ + return NULL; +} +#endif #endif #endif @@ -2756,7 +2802,7 @@ Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save) #endif /* !PERL_MICRO */ /* VMS' my_pclose() 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) +#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) && !defined(__LIBCATAMOUNT__) I32 Perl_my_pclose(pTHX_ PerlIO *ptr) { @@ -2811,9 +2857,17 @@ Perl_my_pclose(pTHX_ PerlIO *ptr) } return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status)); } +#else +#if defined(__LIBCATAMOUNT__) +I32 +Perl_my_pclose(pTHX_ PerlIO *ptr) +{ + return -1; +} +#endif #endif /* !DOSISH */ -#if (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(MACOS_TRADITIONAL) +#if (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(MACOS_TRADITIONAL) && !defined(__LIBCATAMOUNT__) I32 Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags) { @@ -3011,6 +3065,7 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch, register char *s; I32 len = 0; int retval; + char *bufend; #if defined(DOSISH) && !defined(OS2) && !defined(atarist) # define SEARCH_EXTS ".bat", ".cmd", NULL # define MAX_EXT_LEN 4 @@ -3135,10 +3190,10 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch, { bool seen_dot = 0; - PL_bufend = s + strlen(s); - while (s < PL_bufend) { + bufend = s + strlen(s); + while (s < bufend) { #ifdef MACOS_TRADITIONAL - s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend, + s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend, ',', &len); #else @@ -3154,12 +3209,12 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch, if (len < sizeof tmpbuf) tmpbuf[len] = '\0'; #else /* ! (atarist || DOSISH) */ - s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend, + s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend, ':', &len); #endif /* ! (atarist || DOSISH) */ #endif /* MACOS_TRADITIONAL */ - if (s < PL_bufend) + if (s < bufend) s++; if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf) continue; /* don't search dir with too-long name */ @@ -4083,6 +4138,7 @@ Perl_getcwd_sv(pTHX_ register SV *sv) #endif } +#define VERSION_MAX 0x7FFFFFFF /* =for apidoc scan_version @@ -4114,23 +4170,22 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv) int saw_period = 0; int alpha = 0; int width = 3; + bool vinf = FALSE; AV * const av = newAV(); SV * const 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++; + start = last = s; + if (*s == 'v') { s++; /* get past 'v' */ qv = 1; /* force quoted version processing */ } - start = last = pos = s; + pos = s; /* pre-scan the input string to check for decimals/underbars */ while ( *pos == '.' || *pos == '_' || isDIGIT(*pos) ) @@ -4161,14 +4216,15 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv) if ( saw_period > 1 ) qv = 1; /* force quoted version processing */ + last = pos; pos = s; if ( qv ) - hv_store((HV *)hv, "qv", 2, newSViv(qv), 0); + (void)hv_stores((HV *)hv, "qv", newSViv(qv)); if ( alpha ) - hv_store((HV *)hv, "alpha", 5, newSViv(alpha), 0); + (void)hv_stores((HV *)hv, "alpha", newSViv(alpha)); if ( !qv && width < 3 ) - hv_store((HV *)hv, "width", 5, newSViv(width), 0); + (void)hv_stores((HV *)hv, "width", newSViv(width)); while (isDIGIT(*pos)) pos++; @@ -4181,7 +4237,7 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv) /* this is atoi() that delimits on underscores */ const char *end = pos; I32 mult = 1; - I32 orev; + I32 orev; /* the following if() will only be true after the decimal * point of a version originally created with a bare @@ -4190,11 +4246,18 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv) if ( !qv && s > start && saw_period == 1 ) { mult *= 100; while ( s < end ) { - orev = rev; + orev = rev; rev += (*s - '0') * mult; mult /= 10; - if ( PERL_ABS(orev) > PERL_ABS(rev) ) - Perl_croak(aTHX_ "Integer overflow in version"); + if ( (PERL_ABS(orev) > PERL_ABS(rev)) + || (PERL_ABS(rev) > VERSION_MAX )) { + if(ckWARN(WARN_OVERFLOW)) + Perl_warner(aTHX_ packWARN(WARN_OVERFLOW), + "Integer overflow in version %d",VERSION_MAX); + s = end - 1; + rev = VERSION_MAX; + vinf = 1; + } s++; if ( *s == '_' ) s++; @@ -4202,18 +4265,29 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv) } else { while (--end >= s) { - orev = rev; + orev = rev; rev += (*end - '0') * mult; mult *= 10; - if ( PERL_ABS(orev) > PERL_ABS(rev) ) - Perl_croak(aTHX_ "Integer overflow in version"); + if ( (PERL_ABS(orev) > PERL_ABS(rev)) + || (PERL_ABS(rev) > VERSION_MAX )) { + if(ckWARN(WARN_OVERFLOW)) + Perl_warner(aTHX_ packWARN(WARN_OVERFLOW), + "Integer overflow in version"); + end = s - 1; + rev = VERSION_MAX; + vinf = 1; + } } } } /* Append revision */ av_push(av, newSViv(rev)); - if ( *pos == '.' ) + if ( vinf ) { + s = last; + break; + } + else if ( *pos == '.' ) s = ++pos; else if ( *pos == '_' && isDIGIT(pos[1]) ) s = ++pos; @@ -4251,16 +4325,33 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv) av_push(av, newSViv(0)); } - if ( av_len(av) == -1 ) /* oops, someone forgot to pass a value */ + /* need to save off the current version string for later */ + if ( vinf ) { + SV * orig = newSVpvn("v.Inf", sizeof("v.Inf")-1); + (void)hv_stores((HV *)hv, "original", orig); + (void)hv_stores((HV *)hv, "vinf", newSViv(1)); + } + else if ( s > start ) { + SV * orig = newSVpvn(start,s-start); + if ( qv && saw_period == 1 && *start != 'v' ) { + /* need to insert a v to be consistent */ + sv_insert(orig, 0, 0, "v", 1); + } + (void)hv_stores((HV *)hv, "original", orig); + } + else { + (void)hv_stores((HV *)hv, "original", newSVpvn("0",1)); av_push(av, newSViv(0)); + } + + /* And finally, store the AV in the hash */ + (void)hv_stores((HV *)hv, "version", newRV_noinc((SV *)av)); /* fix RT#19517 - special case 'undef' as string */ if ( *s == 'u' && strEQ(s,"undef") ) { s += 5; } - /* And finally, store the AV in the hash */ - hv_store((HV *)hv, "version", 7, newRV_noinc((SV *)av), 0); return s; } @@ -4290,24 +4381,27 @@ Perl_new_version(pTHX_ SV *ver) /* 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); + (void)hv_stores((HV *)hv, "qv", newSViv(1)); if ( hv_exists((HV *)ver, "alpha", 5) ) - hv_store((HV *)hv, "alpha", 5, &PL_sv_yes, 0); + (void)hv_stores((HV *)hv, "alpha", newSViv(1)); if ( hv_exists((HV*)ver, "width", 5 ) ) { const I32 width = SvIV(*hv_fetchs((HV*)ver, "width", FALSE)); - hv_store((HV *)hv, "width", 5, newSViv(width), 0); + (void)hv_stores((HV *)hv, "width", newSViv(width)); + } + + if ( hv_exists((HV*)ver, "original", 8 ) ) + { + SV * pv = *hv_fetchs((HV*)ver, "original", FALSE); + (void)hv_stores((HV *)hv, "original", newSVsv(pv)); } sav = (AV *)SvRV(*hv_fetchs((HV*)ver, "version", FALSE)); @@ -4318,7 +4412,7 @@ Perl_new_version(pTHX_ SV *ver) av_push(av, newSViv(rev)); } - hv_store((HV *)hv, "version", 7, newRV_noinc((SV *)av), 0); + (void)hv_stores((HV *)hv, "version", newRV_noinc((SV *)av)); return rv; } #ifdef SvVOK @@ -4328,6 +4422,9 @@ Perl_new_version(pTHX_ SV *ver) const STRLEN len = mg->mg_len; char * const version = savepvn( (const char*)mg->mg_ptr, len); sv_setpvn(rv,version,len); + /* this is for consistency with the pure Perl class */ + if ( *version != 'v' ) + sv_insert(rv, 0, 0, "v", 1); Safefree(version); } else { @@ -4373,6 +4470,7 @@ Perl_upg_version(pTHX_ SV *ver, bool qv) setlocale(LC_NUMERIC, loc); #endif while (tbuf[len-1] == '0' && len > 0) len--; + if ( tbuf[len-1] == '.' ) len--; /* eat the trailing decimal */ version = savepvn(tbuf, len); } #ifdef SvVOK @@ -4394,10 +4492,11 @@ Perl_upg_version(pTHX_ SV *ver, bool qv) const char *nver; const char *pos; int saw_period = 0; - sv_setpvf(nsv,"%vd",ver); + sv_setpvf(nsv,"v%vd",ver); pos = nver = savepv(SvPV_nolen(nsv)); /* scan the resulting formatted string */ + pos++; /* skip the leading 'v' */ while ( *pos == '.' || isDIGIT(*pos) ) { if ( *pos == '.' ) saw_period++ ; @@ -4618,16 +4717,18 @@ the original version contained 1 or more dots, respectively SV * Perl_vstringify(pTHX_ SV *vs) { + SV *pv; if ( SvROK(vs) ) vs = SvRV(vs); if ( !vverify(vs) ) Perl_croak(aTHX_ "Invalid version object"); - if ( hv_exists((HV *)vs, "qv", 2) ) - return vnormal(vs); + pv = *hv_fetchs((HV*)vs, "original", FALSE); + if ( SvPOK(pv) ) + return newSVsv(pv); else - return vnumify(vs); + return &PL_sv_undef; } /* @@ -5003,6 +5104,26 @@ Perl_sv_nosharing(pTHX_ SV *sv) PERL_UNUSED_ARG(sv); } +/* + +=for apidoc sv_destroyable + +Dummy routine which reports that object can be destroyed when there is no +sharing module present. It ignores its single SV argument, and returns +'true'. Exists to avoid test for a NULL function pointer and because it +could potentially warn under some level of strict-ness. + +=cut +*/ + +bool +Perl_sv_destroyable(pTHX_ SV *sv) +{ + PERL_UNUSED_CONTEXT; + PERL_UNUSED_ARG(sv); + return TRUE; +} + U32 Perl_parse_unicode_opts(pTHX_ const char **popt) { @@ -5576,7 +5697,8 @@ Perl_my_clearenv(pTHX) bsiz = l + 1; /* + 1 for the \0. */ buf = (char*)safesysmalloc(bufsiz); } - my_strlcpy(buf, *environ, l + 1); + memcpy(buf, *environ, l); + buf[l] = '\0'; (void)unsetenv(buf); } (void)safesysfree(buf); @@ -5771,6 +5893,41 @@ Perl_get_db_sub(pTHX_ SV **svp, CV *cv) } } +int +Perl_my_dirfd(pTHX_ DIR * dir) { + + /* Most dirfd implementations have problems when passed NULL. */ + if(!dir) + return -1; +#ifdef HAS_DIRFD + return dirfd(dir); +#elif defined(HAS_DIR_DD_FD) + return dir->dd_fd; +#else + Perl_die(aTHX_ PL_no_func, "dirfd"); + /* NOT REACHED */ + return 0; +#endif +} + +REGEXP * +Perl_get_re_arg(pTHX_ SV *sv) { + SV *tmpsv; + + if (sv) { + if (SvMAGICAL(sv)) + mg_get(sv); + if (SvROK(sv) && + (tmpsv = (SV*)SvRV(sv)) && /* assign deliberate */ + SvTYPE(tmpsv) == SVt_REGEXP) + { + return (REGEXP*) tmpsv; + } + } + + return NULL; +} + /* * Local variables: * c-indentation-style: bsd