X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=util.c;h=dffe6f4063922d363436ca7ec0b1f5bb9ffdeae0;hb=d5d3e0f0cac42b271aa6d30a69d6eff7e2c063c2;hp=80e283b904f7c5a9474068b3e1e0d1ba0f0f6152;hpb=6460123ae692a9c25bc8c2253f12c8cf6f0ebdc0;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/util.c b/util.c
index 80e283b..dffe6f4 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;
@@ -1823,24 +1832,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 <stdio.h>,
+   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 +1909,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 +2216,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;
@@ -2313,7 +2352,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 +2511,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 +2524,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 +2533,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 +2803,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 +2858,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 +3066,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 +3191,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 +3210,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 */
@@ -4125,12 +4181,14 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
     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) )
@@ -4251,16 +4309,28 @@ 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 ( 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);
+	}
+	hv_store((HV *)hv, "original", 8, orig, 0);
+    }
+    else {
+	hv_store((HV *)hv, "original", 8, newSVpvn("0",1), 0);
 	av_push(av, newSViv(0));
+    }
+
+    /* And finally, store the AV in the hash */
+    hv_store((HV *)hv, "version", 7, newRV_noinc((SV *)av), 0);
 
     /* 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;
 }
 
@@ -4310,6 +4380,12 @@ Perl_new_version(pTHX_ SV *ver)
 	    hv_store((HV *)hv, "width", 5, newSViv(width), 0);
 	}
 
+	if ( hv_exists((HV*)ver, "original", 8 ) )
+	{
+	    SV * pv = *hv_fetchs((HV*)ver, "original", FALSE);
+	    hv_store((HV *)hv, "original", 8, newSVsv(pv), 0);
+	}
+
 	sav = (AV *)SvRV(*hv_fetchs((HV*)ver, "version", FALSE));
 	/* This will get reblessed later if a derived class*/
 	for ( key = 0; key <= av_len(sav); key++ )
@@ -4328,6 +4404,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 +4452,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 +4474,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 +4699,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;
 }
 
 /*
@@ -5771,6 +5854,43 @@ 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;
+    MAGIC *mg;
+
+    if (sv) {
+        if (SvMAGICAL(sv))
+            mg_get(sv);
+        if (SvROK(sv) &&
+            (tmpsv = (SV*)SvRV(sv)) &&            /* assign deliberate */
+            SvTYPE(tmpsv) == SVt_PVMG &&
+            (mg = mg_find(tmpsv, PERL_MAGIC_qr))) /* assign deliberate */
+        {
+            return (REGEXP *)mg->mg_obj;
+        }
+    }
+ 
+    return NULL;
+}
+
 /*
  * Local variables:
  * c-indentation-style: bsd