Regen some files...
[p5sagit/p5-mst-13.2.git] / util.c
diff --git a/util.c b/util.c
index 2ec3940..173e5d7 100644 (file)
--- a/util.c
+++ b/util.c
@@ -1832,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
@@ -1882,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;
@@ -2186,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;
@@ -2322,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)
 {
@@ -2481,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.
@@ -2494,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.
@@ -2503,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
 
@@ -2765,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)
 {
@@ -2820,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)
 {
@@ -3020,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
@@ -3144,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
@@ -3163,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 */
@@ -4092,6 +4139,7 @@ Perl_getcwd_sv(pTHX_ register SV *sv)
 #endif
 }
 
+#define VERSION_MAX 0x7FFFFFFF
 /*
 =for apidoc scan_version
 
@@ -4123,14 +4171,11 @@ 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++;
 
@@ -4172,14 +4217,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++;
@@ -4192,7 +4238,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
@@ -4201,11 +4247,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++;
@@ -4213,18 +4266,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;
@@ -4263,21 +4327,26 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
     }
 
     /* need to save off the current version string for later */
-    if ( s > start ) {
+    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);
        }
-       hv_store((HV *)hv, "original", 8, orig, 0);
+       (void)hv_stores((HV *)hv, "original", orig);
     }
     else {
-       hv_store((HV *)hv, "original", 8, newSVpvn("0",1), 0);
+       (void)hv_stores((HV *)hv, "original", newSVpvn("0",1));
        av_push(av, newSViv(0));
     }
 
     /* And finally, store the AV in the hash */
-    hv_store((HV *)hv, "version", 7, newRV_noinc((SV *)av), 0);
+    (void)hv_stores((HV *)hv, "version", newRV_noinc((SV *)av));
 
     /* fix RT#19517 - special case 'undef' as string */
     if ( *s == 'u' && strEQ(s,"undef") ) {
@@ -4313,30 +4382,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);
-           hv_store((HV *)hv, "original", 8, newSVsv(pv), 0);
+           (void)hv_stores((HV *)hv, "original", newSVsv(pv));
        }
 
        sav = (AV *)SvRV(*hv_fetchs((HV*)ver, "version", FALSE));
@@ -4347,7 +4413,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
@@ -5039,6 +5105,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)
 {
@@ -5612,7 +5698,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);
@@ -5808,7 +5895,7 @@ Perl_get_db_sub(pTHX_ SV **svp, CV *cv)
 }
 
 int
-Perl_my_dirfd(DIR * dir) {
+Perl_my_dirfd(pTHX_ DIR * dir) {
 
     /* Most dirfd implementations have problems when passed NULL. */
     if(!dir)
@@ -5824,6 +5911,26 @@ Perl_my_dirfd(DIR * dir) {
 #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