Fix excess whitespace in pod.

[perl5.git] / util.c

diff --git a/util.c b/util.c
index 5e7a24e..8d9d2e4 100644 (file)
--- a/util.c
+++ b/util.c
@@ -70,12 +70,18 @@ S_write_no_mem(pTHX)
     NORETURN_FUNCTION_END;
 }
 
     NORETURN_FUNCTION_END;
 }
 

+#if defined (DEBUGGING) || defined(PERL_IMPLICIT_SYS) || defined (PERL_TRACK_MEMPOOL)
+#  define ALWAYS_NEED_THX
+#endif
+

 /* paranoid version of system's malloc() */
 
 Malloc_t
 Perl_safesysmalloc(MEM_SIZE size)
 {
 /* paranoid version of system's malloc() */
 
 Malloc_t
 Perl_safesysmalloc(MEM_SIZE size)
 {

+#ifdef ALWAYS_NEED_THX

     dTHX;
     dTHX;

+#endif

     Malloc_t ptr;
 #ifdef HAS_64K_LIMIT
        if (size > 0xffff) {
     Malloc_t ptr;
 #ifdef HAS_64K_LIMIT
        if (size > 0xffff) {


@@ -93,7 +99,6 @@ Perl_safesysmalloc(MEM_SIZE size)
 #endif
     ptr = (Malloc_t)PerlMem_malloc(size?size:1);       /* malloc(0) is NASTY on our system */
     PERL_ALLOC_CHECK(ptr);
 #endif
     ptr = (Malloc_t)PerlMem_malloc(size?size:1);       /* malloc(0) is NASTY on our system */
     PERL_ALLOC_CHECK(ptr);

-    DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));

     if (ptr != NULL) {
 #ifdef PERL_TRACK_MEMPOOL
        struct perl_memory_debug_header *const header
     if (ptr != NULL) {
 #ifdef PERL_TRACK_MEMPOOL
        struct perl_memory_debug_header *const header


@@ -116,12 +121,18 @@ Perl_safesysmalloc(MEM_SIZE size)
 #  endif
         ptr = (Malloc_t)((char*)ptr+sTHX);
 #endif
 #  endif
         ptr = (Malloc_t)((char*)ptr+sTHX);
 #endif

+       DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));

        return ptr;
 }
        return ptr;
 }

-    else if (PL_nomemok)
-       return NULL;

     else {
     else {

-       return write_no_mem();
+#ifndef ALWAYS_NEED_THX
+       dTHX;
+#endif
+       if (PL_nomemok)
+           return NULL;
+       else {
+           return write_no_mem();
+       }

     }
     /*NOTREACHED*/
 }
     }
     /*NOTREACHED*/
 }


@@ -131,7 +142,9 @@ Perl_safesysmalloc(MEM_SIZE size)
 Malloc_t
 Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
 {
 Malloc_t
 Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
 {

+#ifdef ALWAYS_NEED_THX

     dTHX;
     dTHX;

+#endif

     Malloc_t ptr;
 #if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) && !defined(PERL_MICRO)
     Malloc_t PerlMem_realloc();
     Malloc_t ptr;
 #if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) && !defined(PERL_MICRO)
     Malloc_t PerlMem_realloc();


@@ -213,10 +226,15 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
     if (ptr != NULL) {
        return ptr;
     }
     if (ptr != NULL) {
        return ptr;
     }

-    else if (PL_nomemok)
-       return NULL;

     else {
     else {

-       return write_no_mem();
+#ifndef ALWAYS_NEED_THX
+       dTHX;
+#endif
+       if (PL_nomemok)
+           return NULL;
+       else {
+           return write_no_mem();
+       }

     }
     /*NOTREACHED*/
 }
     }
     /*NOTREACHED*/
 }


@@ -226,7 +244,7 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
 Free_t
 Perl_safesysfree(Malloc_t where)
 {
 Free_t
 Perl_safesysfree(Malloc_t where)
 {

-#if defined(PERL_IMPLICIT_SYS) || defined(PERL_TRACK_MEMPOOL)
+#ifdef ALWAYS_NEED_THX

     dTHX;
 #else
     dVAR;
     dTHX;
 #else
     dVAR;


@@ -268,7 +286,9 @@ Perl_safesysfree(Malloc_t where)
 Malloc_t
 Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
 {
 Malloc_t
 Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
 {

+#ifdef ALWAYS_NEED_THX

     dTHX;
     dTHX;

+#endif

     Malloc_t ptr;
     MEM_SIZE total_size = 0;
 
     Malloc_t ptr;
     MEM_SIZE total_size = 0;
 


@@ -330,9 +350,14 @@ Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
 #endif
        return ptr;
     }
 #endif
        return ptr;
     }

-    else if (PL_nomemok)
-       return NULL;
-    return write_no_mem();
+    else {
+#ifndef ALWAYS_NEED_THX
+       dTHX;
+#endif
+       if (PL_nomemok)
+           return NULL;
+       return write_no_mem();
+    }

 }
 
 /* These must be defined when not using Perl's malloc for binary
 }
 
 /* These must be defined when not using Perl's malloc for binary


@@ -878,37 +903,79 @@ Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift
     return NULL;
 }
 
     return NULL;
 }
 

+/*
+=for apidoc foldEQ
+
+Returns true if the leading len bytes of the strings s1 and s2 are the same
+case-insensitively; false otherwise.  Uppercase and lowercase ASCII range bytes
+match themselves and their opposite case counterparts.  Non-cased and non-ASCII
+range bytes match only themselves.
+
+=cut
+*/
+
+

 I32
 I32

-Perl_ibcmp(const char *s1, const char *s2, register I32 len)
+Perl_foldEQ(const char *s1, const char *s2, register I32 len)

 {
     register const U8 *a = (const U8 *)s1;
     register const U8 *b = (const U8 *)s2;
 
 {
     register const U8 *a = (const U8 *)s1;
     register const U8 *b = (const U8 *)s2;
 

-    PERL_ARGS_ASSERT_IBCMP;
+    PERL_ARGS_ASSERT_FOLDEQ;

 
     while (len--) {
        if (*a != *b && *a != PL_fold[*b])
 
     while (len--) {
        if (*a != *b && *a != PL_fold[*b])

-           return 1;
+           return 0;

        a++,b++;
     }
        a++,b++;
     }

-    return 0;
+    return 1;

 }
 }

+I32
+Perl_foldEQ_latin1(const char *s1, const char *s2, register I32 len)
+{
+    /* Compare non-utf8 using Unicode (Latin1) semantics.  Does not work on
+     * MICRO_SIGN, LATIN_SMALL_LETTER_SHARP_S, nor
+     * LATIN_SMALL_LETTER_Y_WITH_DIAERESIS, and does not check for these.  Nor
+     * does it check that the strings each have at least 'len' characters */
+
+    register const U8 *a = (const U8 *)s1;
+    register const U8 *b = (const U8 *)s2;
+
+    PERL_ARGS_ASSERT_FOLDEQ_LATIN1;
+
+    while (len--) {
+       if (*a != *b && *a != PL_fold_latin1[*b]) {
+           return 0;
+       }
+       a++, b++;
+    }
+    return 1;
+}
+
+/*
+=for apidoc foldEQ_locale
+
+Returns true if the leading len bytes of the strings s1 and s2 are the same
+case-insensitively in the current locale; false otherwise.
+
+=cut
+*/

 
 I32
 
 I32

-Perl_ibcmp_locale(const char *s1, const char *s2, register I32 len)
+Perl_foldEQ_locale(const char *s1, const char *s2, register I32 len)

 {
     dVAR;
     register const U8 *a = (const U8 *)s1;
     register const U8 *b = (const U8 *)s2;
 
 {
     dVAR;
     register const U8 *a = (const U8 *)s1;
     register const U8 *b = (const U8 *)s2;
 

-    PERL_ARGS_ASSERT_IBCMP_LOCALE;
+    PERL_ARGS_ASSERT_FOLDEQ_LOCALE;

 
     while (len--) {
        if (*a != *b && *a != PL_fold_locale[*b])
 
     while (len--) {
        if (*a != *b && *a != PL_fold_locale[*b])

-           return 1;
+           return 0;

        a++,b++;
     }
        a++,b++;
     }

-    return 0;
+    return 1;

 }
 
 /* copy a string to a safe spot */
 }
 
 /* copy a string to a safe spot */


@@ -1041,6 +1108,25 @@ Perl_savesvpv(pTHX_ SV *sv)
     return (char *) CopyD(pv,newaddr,len,char);
 }
 
     return (char *) CopyD(pv,newaddr,len,char);
 }
 

+/*
+=for apidoc savesharedsvpv
+
+A version of C<savesharedpv()> which allocates the duplicate string in
+memory which is shared between threads.
+
+=cut
+*/
+
+char *
+Perl_savesharedsvpv(pTHX_ SV *sv)
+{
+    STRLEN len;
+    const char * const pv = SvPV_const(sv, len);
+
+    PERL_ARGS_ASSERT_SAVESHAREDSVPV;
+
+    return savesharedpvn(pv, len);
+}

 
 /* the SV for Perl_form() and mess() is not kept in an arena */
 
 
 /* the SV for Perl_form() and mess() is not kept in an arena */
 


@@ -1051,7 +1137,7 @@ S_mess_alloc(pTHX)
     SV *sv;
     XPVMG *any;
 
     SV *sv;
     XPVMG *any;
 

-    if (!PL_dirty)
+    if (PL_phase != PERL_PHASE_DESTRUCT)

        return newSVpvs_flags("", SVs_TEMP);
 
     if (PL_mess_sv)
        return newSVpvs_flags("", SVs_TEMP);
 
     if (PL_mess_sv)


@@ -1278,7 +1364,7 @@ Perl_mess_sv(pTHX_ SV *basemsg, bool consume)
                           line_mode ? "line" : "chunk",
                           (IV)IoLINES(GvIOp(PL_last_in_gv)));
        }
                           line_mode ? "line" : "chunk",
                           (IV)IoLINES(GvIOp(PL_last_in_gv)));
        }

-       if (PL_dirty)
+       if (PL_phase == PERL_PHASE_DESTRUCT)

            sv_catpvs(sv, " during global destruction");
        sv_catpvs(sv, ".\n");
     }
            sv_catpvs(sv, " during global destruction");
        sv_catpvs(sv, ".\n");
     }


@@ -1325,38 +1411,16 @@ Perl_write_to_stderr(pTHX_ SV* msv)
     if (PL_stderrgv && SvREFCNT(PL_stderrgv) 
        && (io = GvIO(PL_stderrgv))
        && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) 
     if (PL_stderrgv && SvREFCNT(PL_stderrgv) 
        && (io = GvIO(PL_stderrgv))
        && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) 

-    {
-       dSP;
-       ENTER;
-       SAVETMPS;
-
-       save_re_context();
-       SAVESPTR(PL_stderrgv);
-       PL_stderrgv = NULL;
-
-       PUSHSTACKi(PERLSI_MAGIC);
-
-       PUSHMARK(SP);
-       EXTEND(SP,2);
-       PUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
-       PUSHs(msv);
-       PUTBACK;
-       call_method("PRINT", G_SCALAR);
-
-       POPSTACK;
-       FREETMPS;
-       LEAVE;
-    }
+       Perl_magic_methcall(aTHX_ MUTABLE_SV(io), mg, "PRINT",
+                           G_SCALAR | G_DISCARD | G_WRITING_TO_STDERR, 1, msv);

     else {
 #ifdef USE_SFIO
        /* SFIO can really mess with your errno */
        dSAVED_ERRNO;
 #endif
        PerlIO * const serr = Perl_error_log;
     else {
 #ifdef USE_SFIO
        /* SFIO can really mess with your errno */
        dSAVED_ERRNO;
 #endif
        PerlIO * const serr = Perl_error_log;

-       STRLEN msglen;
-       const char* message = SvPVx_const(msv, msglen);

 
 

-       PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
+       do_print(msv, serr);

        (void)PerlIO_flush(serr);
 #ifdef USE_SFIO
        RESTORE_ERRNO;
        (void)PerlIO_flush(serr);
 #ifdef USE_SFIO
        RESTORE_ERRNO;


@@ -1592,6 +1656,22 @@ Perl_croak(pTHX_ const char *pat, ...)
 }
 
 /*
 }
 
 /*

+=for apidoc Am|void|croak_no_modify
+
+Exactly equivalent to C<Perl_croak(aTHX_ "%s", PL_no_modify)>, but generates
+terser object code than using C<Perl_croak>. Less code used on exception code
+paths reduces CPU cache pressure.
+
+=cut
+*/
+
+void
+Perl_croak_no_modify(pTHX)
+{
+    Perl_croak(aTHX_ "%s", PL_no_modify);
+}
+
+/*

 =for apidoc Am|void|warn_sv|SV *baseex
 
 This is an XS interface to Perl's C<warn> function.
 =for apidoc Am|void|warn_sv|SV *baseex
 
 This is an XS interface to Perl's C<warn> function.


@@ -3764,70 +3844,73 @@ Perl_my_fflush_all(pTHX)
 }
 
 void
 }
 
 void

-Perl_report_evil_fh(pTHX_ const GV *gv, const IO *io, I32 op)
-{
-    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 * const direction =
-               (const char *)((op == OP_phoney_INPUT_ONLY) ? "in" : "out");
-           if (name && *name)
-               Perl_warner(aTHX_ packWARN(WARN_IO),
-                           "Filehandle %s opened only for %sput",
-                           name, direction);
-           else
-               Perl_warner(aTHX_ packWARN(WARN_IO),
-                           "Filehandle opened only for %sput", direction);
-       }
+Perl_report_wrongway_fh(pTHX_ const GV *gv, char have)
+{
+    if (ckWARN(WARN_IO)) {
+       const char * const name
+           = gv && (isGV(gv) || isGV_with_GP(gv)) ? GvENAME(gv) : NULL;
+       const char * const direction = have == '>' ? "out" : "in";
+
+       if (name && *name)
+           Perl_warner(aTHX_ packWARN(WARN_IO),
+                       "Filehandle %s opened only for %sput",
+                       name, direction);
+       else
+           Perl_warner(aTHX_ packWARN(WARN_IO),
+                       "Filehandle opened only for %sput", direction);

     }
     }

-    else {
-        const char *vile;
-       I32   warn_type;
+}

 
 

-       if (gv && io && IoTYPE(io) == IoTYPE_CLOSED) {
-           vile = "closed";
-           warn_type = WARN_CLOSED;
+void
+Perl_report_evil_fh(pTHX_ const GV *gv)
+{
+    const IO *io = gv ? GvIO(gv) : NULL;
+    const PERL_BITFIELD16 op = PL_op->op_type;
+    const char *vile;
+    I32 warn_type;
+
+    if (io && IoTYPE(io) == IoTYPE_CLOSED) {
+       vile = "closed";
+       warn_type = WARN_CLOSED;
+    }
+    else {
+       vile = "unopened";
+       warn_type = WARN_UNOPENED;
+    }
+
+    if (ckWARN(warn_type)) {
+       const char * const name
+           = gv && (isGV(gv) || isGV_with_GP(gv)) ? GvENAME(gv) : NULL;
+       const char * const pars =
+           (const char *)(OP_IS_FILETEST(op) ? "" : "()");
+       const char * const func =
+           (const char *)
+           (op == OP_READLINE   ? "readline"  :        /* "<HANDLE>" not nice */
+            op == OP_LEAVEWRITE ? "write" :            /* "write exit" not nice */
+            PL_op_desc[op]);
+       const char * const type =
+           (const char *)
+           (OP_IS_SOCKET(op) || (io && IoTYPE(io) == IoTYPE_SOCKET)
+            ? "socket" : "filehandle");
+       if (name && *name) {
+           Perl_warner(aTHX_ packWARN(warn_type),
+                       "%s%s on %s %s %s", func, pars, vile, type, name);
+           if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
+               Perl_warner(
+                           aTHX_ packWARN(warn_type),
+                           "\t(Are you trying to call %s%s on dirhandle %s?)\n",
+                           func, pars, name
+                           );

        }
        else {
        }
        else {

-           vile = "unopened";
-           warn_type = WARN_UNOPENED;
-       }
-
-       if (ckWARN(warn_type)) {
-           const char * const pars =
-               (const char *)(OP_IS_FILETEST(op) ? "" : "()");
-           const char * const func =
-               (const char *)
-               (op == OP_READLINE   ? "readline"  :    /* "<HANDLE>" not nice */
-                op == OP_LEAVEWRITE ? "write" :                /* "write exit" not nice */
-                op < 0              ? "" :              /* handle phoney cases */
-                PL_op_desc[op]);
-           const char * const type =
-               (const char *)
-               (OP_IS_SOCKET(op) ||
-                (gv && io && IoTYPE(io) == IoTYPE_SOCKET) ?
-                "socket" : "filehandle");
-           if (name && *name) {
-               Perl_warner(aTHX_ packWARN(warn_type),
-                           "%s%s on %s %s %s", func, pars, vile, type, name);
-               if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
-                   Perl_warner(
-                       aTHX_ packWARN(warn_type),
-                       "\t(Are you trying to call %s%s on dirhandle %s?)\n",
-                       func, pars, name
-                   );
-           }
-           else {
-               Perl_warner(aTHX_ packWARN(warn_type),
-                           "%s%s on %s %s", func, pars, vile, type);
-               if (gv && io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
-                   Perl_warner(
-                       aTHX_ packWARN(warn_type),
-                       "\t(Are you trying to call %s%s on dirhandle?)\n",
-                       func, pars
-                   );
-           }
+           Perl_warner(aTHX_ packWARN(warn_type),
+                       "%s%s on %s %s", func, pars, vile, type);
+           if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
+               Perl_warner(
+                           aTHX_ packWARN(warn_type),
+                           "\t(Are you trying to call %s%s on dirhandle?)\n",
+                           func, pars
+                           );

        }
     }
 }
        }
     }
 }


@@ -3842,7 +3925,7 @@ Perl_report_evil_fh(pTHX_ const GV *gv, const IO *io, I32 op)
 char
 Perl_grok_bslash_c(pTHX_ const char source, const bool output_warning)
 {
 char
 Perl_grok_bslash_c(pTHX_ const char source, const bool output_warning)
 {

-    
+

     U8 result;
 
     if (! isASCII(source)) {
     U8 result;
 
     if (! isASCII(source)) {


@@ -3855,16 +3938,103 @@ Perl_grok_bslash_c(pTHX_ const char source, const bool output_warning)
            Perl_croak(aTHX_ "It is proposed that \"\\c{\" no longer be valid. It has historically evaluated to\n \";\".  If you disagree with this proposal, send email to perl5-porters@perl.org\nOtherwise, or in the meantime, you can work around this failure by changing\n\"\\c{\" to \";\"");
        }
        else if (output_warning) {
            Perl_croak(aTHX_ "It is proposed that \"\\c{\" no longer be valid. It has historically evaluated to\n \";\".  If you disagree with this proposal, send email to perl5-porters@perl.org\nOtherwise, or in the meantime, you can work around this failure by changing\n\"\\c{\" to \";\"");
        }
        else if (output_warning) {

+           U8 clearer[3];
+           U8 i = 0;
+           if (! isALNUM(result)) {
+               clearer[i++] = '\\';
+           }
+           clearer[i++] = result;
+           clearer[i++] = '\0';
+

            Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
            Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),

-                           "\"\\c%c\" more clearly written simply as \"%c\"",
+                           "\"\\c%c\" more clearly written simply as \"%s\"",

                            source,
                            source,

-                           result);
+                           clearer);

        }
     }
 
     return result;
 }
 
        }
     }
 
     return result;
 }
 

+bool
+Perl_grok_bslash_o(pTHX_ const char *s,
+                        UV *uv,
+                        STRLEN *len,
+                        const char** error_msg,
+                        const bool output_warning)
+{
+
+/*  Documentation to be supplied when interface nailed down finally
+ *  This returns FALSE if there is an error which the caller need not recover
+ *  from; , otherwise TRUE.  In either case the caller should look at *len
+ *  On input:
+ *     s   points to a string that begins with 'o', and the previous character
+ *         was a backslash.
+ *     uv  points to a UV that will hold the output value, valid only if the
+ *         return from the function is TRUE
+ *     len on success will point to the next character in the string past the
+ *                    end of this construct.
+ *         on failure, it will point to the failure
+ *      error_msg is a pointer that will be set to an internal buffer giving an
+ *         error message upon failure (the return is FALSE).  Untouched if
+ *         function succeeds
+ *     output_warning says whether to output any warning messages, or suppress
+ *         them
+ */
+    const char* e;
+    STRLEN numbers_len;
+    I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
+               | PERL_SCAN_DISALLOW_PREFIX
+               /* XXX Until the message is improved in grok_oct, handle errors
+                * ourselves */
+               | PERL_SCAN_SILENT_ILLDIGIT;
+
+    PERL_ARGS_ASSERT_GROK_BSLASH_O;
+
+
+    assert(*s == 'o');
+    s++;
+
+    if (*s != '{') {
+       *len = 1;       /* Move past the o */
+       *error_msg = "Missing braces on \\o{}";
+       return FALSE;
+    }
+
+    e = strchr(s, '}');
+    if (!e) {
+       *len = 2;       /* Move past the o{ */
+       *error_msg = "Missing right brace on \\o{";
+       return FALSE;
+    }
+
+    /* Return past the '}' no matter what is inside the braces */
+    *len = e - s + 2;  /* 2 = 1 for the o + 1 for the '}' */
+
+    s++;    /* Point to first digit */
+
+    numbers_len = e - s;
+    if (numbers_len == 0) {
+       *error_msg = "Number with no digits";
+       return FALSE;
+    }
+
+    *uv = NATIVE_TO_UNI(grok_oct(s, &numbers_len, &flags, NULL));
+    /* Note that if has non-octal, will ignore everything starting with that up
+     * to the '}' */
+
+    if (output_warning && numbers_len != (STRLEN) (e - s)) {
+       Perl_ck_warner(aTHX_ packWARN(WARN_DIGIT),
+       /* diag_listed_as: Non-octal character '%c'.  Resolved as "%s" */
+                      "Non-octal character '%c'.  Resolved as \"\\o{%.*s}\"",
+                      *(s + numbers_len),
+                      (int) numbers_len,
+                      s);
+    }
+
+    return TRUE;
+}
+

 /* To workaround core dumps from the uninitialised tm_zone we get the
  * system to give us a reasonable struct to copy.  This fix means that
  * strftime uses the tm_zone and tm_gmtoff values returned by
 /* To workaround core dumps from the uninitialised tm_zone we get the
  * system to give us a reasonable struct to copy.  This fix means that
  * strftime uses the tm_zone and tm_gmtoff values returned by


@@ -3985,7 +4155,7 @@ Perl_mini_mktime(pTHX_ struct tm *ptm)
  * outside the scope for this routine.  Since we convert back based on the
  * same rules we used to build the yearday, you'll only get strange results
  * for input which needed normalising, or for the 'odd' century years which
  * outside the scope for this routine.  Since we convert back based on the
  * same rules we used to build the yearday, you'll only get strange results
  * for input which needed normalising, or for the 'odd' century years which

- * were leap years in the Julian calander but not in the Gregorian one.
+ * were leap years in the Julian calendar but not in the Gregorian one.

  * I can live with that.
  *
  * This algorithm also fails to handle years before A.D. 1 gracefully, but
  * I can live with that.
  *
  * This algorithm also fails to handle years before A.D. 1 gracefully, but


@@ -4164,7 +4334,7 @@ Perl_my_strftime(pTHX_ const char *fmt, int sec, int min, int hour, int mday, in
     const int fmtlen = strlen(fmt);
     int bufsize = fmtlen + buflen;
 
     const int fmtlen = strlen(fmt);
     int bufsize = fmtlen + buflen;
 

-    Newx(buf, bufsize, char);
+    Renew(buf, bufsize, char);

     while (buf) {
       buflen = strftime(buf, bufsize, fmt, &mytm);
       if (buflen > 0 && buflen < bufsize)
     while (buf) {
       buflen = strftime(buf, bufsize, fmt, &mytm);
       if (buflen > 0 && buflen < bufsize)


@@ -4367,6 +4537,11 @@ Perl_getcwd_sv(pTHX_ register SV *sv)
 /*
 =for apidoc prescan_version
 
 /*
 =for apidoc prescan_version
 

+Validate that a given string can be parsed as a version object, but doesn't
+actually perform the parsing.  Can use either strict or lax validation rules.
+Can optionally set a number of hint variables to save the parsing code
+some time when tokenizing.
+

 =cut
 */
 const char *
 =cut
 */
 const char *


@@ -4900,29 +5075,35 @@ Perl_upg_version(pTHX_ SV *ver, bool qv)
 #ifndef SvVOK
 #  if PERL_VERSION > 5
        /* This will only be executed for 5.6.0 - 5.8.0 inclusive */
 #ifndef SvVOK
 #  if PERL_VERSION > 5
        /* This will only be executed for 5.6.0 - 5.8.0 inclusive */

-       if ( len >= 3 && !instr(version,".") && !instr(version,"_")
-           && !(*version == 'u' && strEQ(version, "undef"))
-           && (*version < '0' || *version > '9') ) {
+       if ( len >= 3 && !instr(version,".") && !instr(version,"_")) {

            /* may be a v-string */
            /* may be a v-string */

-           SV * const nsv = sv_newmortal();
-           const char *nver;
-           const char *pos;
-           int saw_decimal = 0;
-           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_decimal++ ;
-               pos++;
-           }
+           char *testv = (char *)version;
+           STRLEN tlen = len;
+           for (tlen=0; tlen < len; tlen++, testv++) {
+               /* if one of the characters is non-text assume v-string */
+               if (testv[0] < ' ') {
+                   SV * const nsv = sv_newmortal();
+                   const char *nver;
+                   const char *pos;
+                   int saw_decimal = 0;
+                   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_decimal++ ;
+                       pos++;
+                   }

 
 

-           /* is definitely a v-string */
-           if ( saw_decimal >= 2 ) {
-               Safefree(version);
-               version = nver;
+                   /* is definitely a v-string */
+                   if ( saw_decimal >= 2 ) {   
+                       Safefree(version);
+                       version = nver;
+                   }
+                   break;
+               }

            }
        }
 #  endif
            }
        }
 #  endif


@@ -4941,27 +5122,30 @@ Perl_upg_version(pTHX_ SV *ver, bool qv)
 /*
 =for apidoc vverify
 
 /*
 =for apidoc vverify
 

-Validates that the SV contains a valid version object.
+Validates that the SV contains valid internal structure for a version object.
+It may be passed either the version object (RV) or the hash itself (HV).  If
+the structure is valid, it returns the HV.  If the structure is invalid,
+it returns NULL.

 
 

-    bool vverify(SV *vobj);
+    SV *hv = vverify(sv);

 
 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
 
 
 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 SV is an HV or a reference to an HV

 
 =item * The hash contains a "version" key
 
 
 =item * The hash contains a "version" key
 

-=item * The "version" key has [a reference to] an AV as its value
+=item * The "version" key has a reference to an AV as its value

 
 =back
 
 =cut
 */
 
 
 =back
 
 =cut
 */
 

-bool
+SV *

 Perl_vverify(pTHX_ SV *vs)
 {
     SV *sv;
 Perl_vverify(pTHX_ SV *vs)
 {
     SV *sv;


@@ -4976,9 +5160,9 @@ Perl_vverify(pTHX_ SV *vs)
         && hv_exists(MUTABLE_HV(vs), "version", 7)
         && (sv = SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)))
         && SvTYPE(sv) == SVt_PVAV )
         && hv_exists(MUTABLE_HV(vs), "version", 7)
         && (sv = SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)))
         && SvTYPE(sv) == SVt_PVAV )

-       return TRUE;
+       return vs;

     else
     else

-       return FALSE;
+       return NULL;

 }
 
 /*
 }
 
 /*


@@ -4992,6 +5176,8 @@ point representation.  Call like:
 NOTE: you can pass either the object directly or the SV
 contained within the RV.
 
 NOTE: you can pass either the object directly or the SV
 contained within the RV.
 

+The SV returned has a refcount of 1.
+

 =cut
 */
 
 =cut
 */
 


@@ -5006,10 +5192,9 @@ Perl_vnumify(pTHX_ SV *vs)
 
     PERL_ARGS_ASSERT_VNUMIFY;
 
 
     PERL_ARGS_ASSERT_VNUMIFY;
 

-    if ( SvROK(vs) )
-       vs = SvRV(vs);
-
-    if ( !vverify(vs) )
+    /* extract the HV from the object */
+    vs = vverify(vs);
+    if ( ! vs )

        Perl_croak(aTHX_ "Invalid version object");
 
     /* see if various flags exist */
        Perl_croak(aTHX_ "Invalid version object");
 
     /* see if various flags exist */


@@ -5072,6 +5257,8 @@ representation.  Call like:
 NOTE: you can pass either the object directly or the SV
 contained within the RV.
 
 NOTE: you can pass either the object directly or the SV
 contained within the RV.
 

+The SV returned has a refcount of 1.
+

 =cut
 */
 
 =cut
 */
 


@@ -5085,10 +5272,9 @@ Perl_vnormal(pTHX_ SV *vs)
 
     PERL_ARGS_ASSERT_VNORMAL;
 
 
     PERL_ARGS_ASSERT_VNORMAL;
 

-    if ( SvROK(vs) )
-       vs = SvRV(vs);
-
-    if ( !vverify(vs) )
+    /* extract the HV from the object */
+    vs = vverify(vs);
+    if ( ! vs )

        Perl_croak(aTHX_ "Invalid version object");
 
     if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
        Perl_croak(aTHX_ "Invalid version object");
 
     if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )


@@ -5130,7 +5316,9 @@ Perl_vnormal(pTHX_ SV *vs)
 In order to maintain maximum compatibility with earlier versions
 of Perl, this function will return either the floating point
 notation or the multiple dotted notation, depending on whether
 In order to maintain maximum compatibility with earlier versions
 of Perl, this function will return either the floating point
 notation or the multiple dotted notation, depending on whether

-the original version contained 1 or more dots, respectively
+the original version contained 1 or more dots, respectively.
+
+The SV returned has a refcount of 1.

 
 =cut
 */
 
 =cut
 */


@@ -5140,10 +5328,9 @@ Perl_vstringify(pTHX_ SV *vs)
 {
     PERL_ARGS_ASSERT_VSTRINGIFY;
 
 {
     PERL_ARGS_ASSERT_VSTRINGIFY;
 

-    if ( SvROK(vs) )
-       vs = SvRV(vs);
-
-    if ( !vverify(vs) )
+    /* extract the HV from the object */
+    vs = vverify(vs);
+    if ( ! vs )

        Perl_croak(aTHX_ "Invalid version object");
 
     if (hv_exists(MUTABLE_HV(vs), "original",  sizeof("original") - 1)) {
        Perl_croak(aTHX_ "Invalid version object");
 
     if (hv_exists(MUTABLE_HV(vs), "original",  sizeof("original") - 1)) {


@@ -5183,15 +5370,10 @@ Perl_vcmp(pTHX_ SV *lhv, SV *rhv)
 
     PERL_ARGS_ASSERT_VCMP;
 
 
     PERL_ARGS_ASSERT_VCMP;
 

-    if ( SvROK(lhv) )
-       lhv = SvRV(lhv);
-    if ( SvROK(rhv) )
-       rhv = SvRV(rhv);
-
-    if ( !vverify(lhv) )
-       Perl_croak(aTHX_ "Invalid version object");
-
-    if ( !vverify(rhv) )
+    /* extract the HVs from the objects */
+    lhv = vverify(lhv);
+    rhv = vverify(rhv);
+    if ( ! ( lhv && rhv ) )

        Perl_croak(aTHX_ "Invalid version object");
 
     /* get the left hand term */
        Perl_croak(aTHX_ "Invalid version object");
 
     /* get the left hand term */


@@ -5571,8 +5753,11 @@ Perl_parse_unicode_opts(pTHX_ const char **popt)
            opt = (U32) atoi(p);
            while (isDIGIT(*p))
                p++;
            opt = (U32) atoi(p);
            while (isDIGIT(*p))
                p++;

-           if (*p && *p != '\n' && *p != '\r')
+           if (*p && *p != '\n' && *p != '\r') {
+            if(isSPACE(*p)) goto the_end_of_the_opts_parser;
+            else

                 Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
                 Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);

+           }

        }
        else {
            for (; *p; p++) {
        }
        else {
            for (; *p; p++) {


@@ -5598,9 +5783,12 @@ Perl_parse_unicode_opts(pTHX_ const char **popt)
                 case PERL_UNICODE_UTF8CACHEASSERT:
                      opt |= PERL_UNICODE_UTF8CACHEASSERT_FLAG; break;
                 default:
                 case PERL_UNICODE_UTF8CACHEASSERT:
                      opt |= PERL_UNICODE_UTF8CACHEASSERT_FLAG; break;
                 default:

-                     if (*p != '\n' && *p != '\r')
+                     if (*p != '\n' && *p != '\r') {
+                       if(isSPACE(*p)) goto the_end_of_the_opts_parser;
+                       else

                          Perl_croak(aTHX_
                                     "Unknown Unicode option letter '%c'", *p);
                          Perl_croak(aTHX_
                                     "Unknown Unicode option letter '%c'", *p);

+                     }

                 }
            }
        }
                 }
            }
        }


@@ -5608,6 +5796,8 @@ Perl_parse_unicode_opts(pTHX_ const char **popt)
   else
        opt = PERL_UNICODE_DEFAULT_FLAGS;
 
   else
        opt = PERL_UNICODE_DEFAULT_FLAGS;
 

+  the_end_of_the_opts_parser:
+

   if (opt & ~PERL_UNICODE_ALL_FLAGS)
        Perl_croak(aTHX_ "Unknown Unicode option value %"UVuf,
                  (UV) (opt & ~PERL_UNICODE_ALL_FLAGS));
   if (opt & ~PERL_UNICODE_ALL_FLAGS)
        Perl_croak(aTHX_ "Unknown Unicode option value %"UVuf,
                  (UV) (opt & ~PERL_UNICODE_ALL_FLAGS));


@@ -5968,7 +6158,7 @@ S_mem_log_common(enum mem_log_type mlt, const UV n,
     mem_log_common   (alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm)
 #else
 /* this is suboptimal, but bug compatible.  User is providing their
     mem_log_common   (alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm)
 #else
 /* this is suboptimal, but bug compatible.  User is providing their

-   own implemenation, but is getting these functions anyway, and they
+   own implementation, but is getting these functions anyway, and they

    do nothing. But _NOIMPL users should be able to cope or fix */
 # define \
     mem_log_common_if(alty, num, tysz, tynm, u, oal, nal, flnm, ln, fnnm) \
    do nothing. But _NOIMPL users should be able to cope or fix */
 # define \
     mem_log_common_if(alty, num, tysz, tynm, u, oal, nal, flnm, ln, fnnm) \


@@ -6077,8 +6267,14 @@ Perl_my_snprintf(char *buffer, const Size_t len, const char *format, ...)
     retval = vsprintf(buffer, format, ap);
 #endif
     va_end(ap);
     retval = vsprintf(buffer, format, ap);
 #endif
     va_end(ap);

-    /* vsnprintf() shows failure with >= len, vsprintf() with < 0 */
-    if (retval < 0 || (len > 0 && (Size_t)retval >= len))
+    /* vsprintf() shows failure with < 0 */
+    if (retval < 0
+#ifdef HAS_VSNPRINTF
+    /* vsnprintf() shows failure with >= len */
+        ||
+        (len > 0 && (Size_t)retval >= len) 
+#endif
+    )

        Perl_croak(aTHX_ "panic: my_snprintf buffer overflow");
     return retval;
 }
        Perl_croak(aTHX_ "panic: my_snprintf buffer overflow");
     return retval;
 }


@@ -6117,8 +6313,14 @@ Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap
     retval = vsprintf(buffer, format, ap);
 # endif
 #endif /* #ifdef NEED_VA_COPY */
     retval = vsprintf(buffer, format, ap);
 # endif
 #endif /* #ifdef NEED_VA_COPY */

-    /* vsnprintf() shows failure with >= len, vsprintf() with < 0 */
-    if (retval < 0 || (len > 0 && (Size_t)retval >= len))
+    /* vsprintf() shows failure with < 0 */
+    if (retval < 0
+#ifdef HAS_VSNPRINTF
+    /* vsnprintf() shows failure with >= len */
+        ||
+        (len > 0 && (Size_t)retval >= len) 
+#endif
+    )

        Perl_croak(aTHX_ "panic: my_vsnprintf buffer overflow");
     return retval;
 }
        Perl_croak(aTHX_ "panic: my_vsnprintf buffer overflow");
     return retval;
 }


@@ -6296,6 +6498,84 @@ Perl_my_cxt_init(pTHX_ const char *my_cxt_key, size_t size)
 #endif /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */
 #endif /* PERL_IMPLICIT_CONTEXT */
 
 #endif /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */
 #endif /* PERL_IMPLICIT_CONTEXT */
 

+void
+Perl_xs_version_bootcheck(pTHX_ U32 items, U32 ax, const char *xs_p,
+                         STRLEN xs_len)
+{
+    SV *sv;
+    const char *vn = NULL;
+    SV *const module = PL_stack_base[ax];
+
+    PERL_ARGS_ASSERT_XS_VERSION_BOOTCHECK;
+
+    if (items >= 2)     /* version supplied as bootstrap arg */
+       sv = PL_stack_base[ax + 1];
+    else {
+       /* XXX GV_ADDWARN */
+       vn = "XS_VERSION";
+       sv = get_sv(Perl_form(aTHX_ "%"SVf"::%s", module, vn), 0);
+       if (!sv || !SvOK(sv)) {
+           vn = "VERSION";
+           sv = get_sv(Perl_form(aTHX_ "%"SVf"::%s", module, vn), 0);
+       }
+    }
+    if (sv) {
+       SV *xssv = Perl_newSVpvn_flags(aTHX_ xs_p, xs_len, SVs_TEMP);
+       SV *pmsv = sv_derived_from(sv, "version")
+           ? sv : sv_2mortal(new_version(sv));
+       xssv = upg_version(xssv, 0);
+       if ( vcmp(pmsv,xssv) ) {
+           SV *string = vstringify(xssv);
+           SV *xpt = Perl_newSVpvf(aTHX_ "%"SVf" object version %"SVf
+                                   " does not match ", module, string);
+
+           SvREFCNT_dec(string);
+           string = vstringify(pmsv);
+
+           if (vn) {
+               Perl_sv_catpvf(aTHX_ xpt, "$%"SVf"::%s %"SVf, module, vn,
+                              string);
+           } else {
+               Perl_sv_catpvf(aTHX_ xpt, "bootstrap parameter %"SVf, string);
+           }
+           SvREFCNT_dec(string);
+
+           Perl_sv_2mortal(aTHX_ xpt);
+           Perl_croak_sv(aTHX_ xpt);
+       }
+    }
+}
+
+void
+Perl_xs_apiversion_bootcheck(pTHX_ SV *module, const char *api_p,
+                            STRLEN api_len)
+{
+    SV *xpt = NULL;
+    SV *compver = Perl_newSVpvn_flags(aTHX_ api_p, api_len, SVs_TEMP);
+    SV *runver;
+
+    PERL_ARGS_ASSERT_XS_APIVERSION_BOOTCHECK;
+
+    /* This might croak  */
+    compver = upg_version(compver, 0);
+    /* This should never croak */
+    runver = new_version(PL_apiversion);
+    if (vcmp(compver, runver)) {
+       SV *compver_string = vstringify(compver);
+       SV *runver_string = vstringify(runver);
+       xpt = Perl_newSVpvf(aTHX_ "Perl API version %"SVf
+                           " of %"SVf" does not match %"SVf,
+                           compver_string, module, runver_string);
+       Perl_sv_2mortal(aTHX_ xpt);
+
+       SvREFCNT_dec(compver_string);
+       SvREFCNT_dec(runver_string);
+    }
+    SvREFCNT_dec(runver);
+    if (xpt)
+       Perl_croak_sv(aTHX_ xpt);
+}
+

 #ifndef HAS_STRLCAT
 Size_t
 Perl_my_strlcat(char *dst, const char *src, Size_t size)
 #ifndef HAS_STRLCAT
 Size_t
 Perl_my_strlcat(char *dst, const char *src, Size_t size)


@@ -6340,21 +6620,28 @@ Perl_get_db_sub(pTHX_ SV **svp, CV *cv)
 {
     dVAR;
     SV * const dbsv = GvSVn(PL_DBsub);
 {
     dVAR;
     SV * const dbsv = GvSVn(PL_DBsub);

+    const bool save_taint = PL_tainted;
+

     /* We do not care about using sv to call CV;
      * it's for informational purposes only.
      */
 
     PERL_ARGS_ASSERT_GET_DB_SUB;
 
     /* We do not care about using sv to call CV;
      * it's for informational purposes only.
      */
 
     PERL_ARGS_ASSERT_GET_DB_SUB;
 

+    PL_tainted = FALSE;

     save_item(dbsv);
     if (!PERLDB_SUB_NN) {
     save_item(dbsv);
     if (!PERLDB_SUB_NN) {

-       GV * const gv = CvGV(cv);
+       GV *gv = CvGV(cv);

 
        if ( svp && ((CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
             || strEQ(GvNAME(gv), "END")
             || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
                 !( (SvTYPE(*svp) == SVt_PVGV)
 
        if ( svp && ((CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
             || strEQ(GvNAME(gv), "END")
             || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
                 !( (SvTYPE(*svp) == SVt_PVGV)

-                   && (GvCV((const GV *)*svp) == cv) )))) {
+                   && (GvCV((const GV *)*svp) == cv)
+                   && (gv = (GV *)*svp) 
+                 )
+               )
+       )) {

            /* Use GV from the stack as a fallback. */
            /* GV is potentially non-unique, or contain different CV. */
            SV * const tmp = newRV(MUTABLE_SV(cv));
            /* Use GV from the stack as a fallback. */
            /* GV is potentially non-unique, or contain different CV. */
            SV * const tmp = newRV(MUTABLE_SV(cv));


@@ -6372,6 +6659,7 @@ Perl_get_db_sub(pTHX_ SV **svp, CV *cv)
        (void)SvIOK_on(dbsv);
        SvIV_set(dbsv, PTR2IV(cv));     /* Do it the quickest way  */
     }
        (void)SvIOK_on(dbsv);
        SvIV_set(dbsv, PTR2IV(cv));     /* Do it the quickest way  */
     }

+    TAINT_IF(save_taint);

 }
 
 int
 }
 
 int