Also IRIX seems to have NaN comparison issues.

[perl5.git] / mg.c

diff --git a/mg.c b/mg.c
index 2ed1764..0f1c314 100644 (file)
--- a/mg.c
+++ b/mg.c
@@ -127,7 +127,7 @@ S_save_magic_flags(pTHX_ I32 mgs_ix, SV *sv, U32 flags)
 /*
 =for apidoc mg_magical
 
 /*
 =for apidoc mg_magical
 

-Turns on the magical status of an SV.  See C<sv_magic>.
+Turns on the magical status of an SV.  See C<L</sv_magic>>.

 
 =cut
 */
 
 =cut
 */


@@ -160,7 +160,7 @@ Perl_mg_magical(SV *sv)
 =for apidoc mg_get
 
 Do magic before a value is retrieved from the SV.  The type of SV must
 =for apidoc mg_get
 
 Do magic before a value is retrieved from the SV.  The type of SV must

-be >= SVt_PVMG.  See C<sv_magic>.
+be >= C<SVt_PVMG>.  See C<L</sv_magic>>.

 
 =cut
 */
 
 =cut
 */


@@ -245,7 +245,7 @@ Perl_mg_get(pTHX_ SV *sv)
 /*
 =for apidoc mg_set
 
 /*
 =for apidoc mg_set
 

-Do magic after a value is assigned to the SV.  See C<sv_magic>.
+Do magic after a value is assigned to the SV.  See C<L</sv_magic>>.

 
 =cut
 */
 
 =cut
 */


@@ -285,10 +285,10 @@ Perl_mg_set(pTHX_ SV *sv)
 =for apidoc mg_length
 
 Reports on the SV's length in bytes, calling length magic if available,
 =for apidoc mg_length
 
 Reports on the SV's length in bytes, calling length magic if available,

-but does not set the UTF8 flag on the sv.  It will fall back to 'get'
+but does not set the UTF8 flag on C<sv>.  It will fall back to 'get'

 magic if there is no 'length' magic, but with no indication as to
 magic if there is no 'length' magic, but with no indication as to

-whether it called 'get' magic.  It assumes the sv is a PVMG or
-higher.  Use sv_len() instead.
+whether it called 'get' magic.  It assumes C<sv> is a C<PVMG> or
+higher.  Use C<sv_len()> instead.

 
 =cut
 */
 
 =cut
 */


@@ -352,7 +352,7 @@ Perl_mg_size(pTHX_ SV *sv)
 /*
 =for apidoc mg_clear
 
 /*
 =for apidoc mg_clear
 

-Clear something magical that the SV represents.  See C<sv_magic>.
+Clear something magical that the SV represents.  See C<L</sv_magic>>.

 
 =cut
 */
 
 =cut
 */


@@ -403,7 +403,7 @@ S_mg_findext_flags(const SV *sv, int type, const MGVTBL *vtbl, U32 flags)
 /*
 =for apidoc mg_find
 
 /*
 =for apidoc mg_find
 

-Finds the magic pointer for type matching the SV.  See C<sv_magic>.
+Finds the magic pointer for C<type> matching the SV.  See C<L</sv_magic>>.

 
 =cut
 */
 
 =cut
 */


@@ -418,7 +418,7 @@ Perl_mg_find(const SV *sv, int type)
 =for apidoc mg_findext
 
 Finds the magic pointer of C<type> with the given C<vtbl> for the C<SV>.  See
 =for apidoc mg_findext
 
 Finds the magic pointer of C<type> with the given C<vtbl> for the C<SV>.  See

-C<sv_magicext>.
+C<L</sv_magicext>>.

 
 =cut
 */
 
 =cut
 */


@@ -447,7 +447,7 @@ Perl_mg_find_mglob(pTHX_ SV *sv)
 /*
 =for apidoc mg_copy
 
 /*
 =for apidoc mg_copy
 

-Copies the magic from one SV to another.  See C<sv_magic>.
+Copies the magic from one SV to another.  See C<L</sv_magic>>.

 
 =cut
 */
 
 =cut
 */


@@ -486,12 +486,12 @@ Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen)
 =for apidoc mg_localize
 
 Copy some of the magic from an existing SV to new localized version of that
 =for apidoc mg_localize
 
 Copy some of the magic from an existing SV to new localized version of that

-SV.  Container magic (eg %ENV, $1, tie)
-gets copied, value magic doesn't (eg
-taint, pos).
+SV.  Container magic (I<e.g.>, C<%ENV>, C<$1>, C<tie>)
+gets copied, value magic doesn't (I<e.g.>,
+C<taint>, C<pos>).

 
 

-If setmagic is false then no set magic will be called on the new (empty) SV.
-This typically means that assignment will soon follow (e.g. 'local $x = $y'),
+If C<setmagic> is false then no set magic will be called on the new (empty) SV.
+This typically means that assignment will soon follow (e.g. S<C<'local $x = $y'>>),

 and that will handle the magic.
 
 =cut
 and that will handle the magic.
 
 =cut


@@ -553,7 +553,7 @@ S_mg_free_struct(pTHX_ SV *sv, MAGIC *mg)
 /*
 =for apidoc mg_free
 
 /*
 =for apidoc mg_free
 

-Free any magic storage used by the SV.  See C<sv_magic>.
+Free any magic storage used by the SV.  See C<L</sv_magic>>.

 
 =cut
 */
 
 =cut
 */


@@ -579,7 +579,7 @@ Perl_mg_free(pTHX_ SV *sv)
 /*
 =for apidoc Am|void|mg_free_type|SV *sv|int how
 
 /*
 =for apidoc Am|void|mg_free_type|SV *sv|int how
 

-Remove any magic of type I<how> from the SV I<sv>.  See L</sv_magic>.
+Remove any magic of type C<how> from the SV C<sv>.  See L</sv_magic>.

 
 =cut
 */
 
 =cut
 */


@@ -1041,6 +1041,11 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
                          *PL_compiling.cop_warnings);
            }
        }
                          *PL_compiling.cop_warnings);
            }
        }

+#ifdef WIN32
+       else if (strEQ(remaining, "IN32_SLOPPY_STAT")) {
+           sv_setiv(sv, w32_sloppystat);
+       }
+#endif

        break;
     case '+':
        if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
        break;
     case '+':
        if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {


@@ -1210,7 +1215,7 @@ Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
     }
 #endif
 
     }
 #endif
 

-#if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
+#if !defined(OS2) && !defined(WIN32) && !defined(MSDOS)

                            /* And you'll never guess what the dog had */
                            /*   in its mouth... */
     if (TAINTING_get) {
                            /* And you'll never guess what the dog had */
                            /*   in its mouth... */
     if (TAINTING_get) {


@@ -1270,7 +1275,7 @@ Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
            }
        }
     }
            }
        }
     }

-#endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
+#endif /* neither OS2 nor WIN32 nor MSDOS */

 
     return 0;
 }
 
     return 0;
 }


@@ -1782,7 +1787,7 @@ The C<flags> can be:
 
 The arguments themselves are any values following the C<flags> argument.
 
 
 The arguments themselves are any values following the C<flags> argument.
 

-Returns the SV (if any) returned by the method, or NULL on failure.
+Returns the SV (if any) returned by the method, or C<NULL> on failure.

 
 
 =cut
 
 
 =cut


@@ -1802,6 +1807,7 @@ Perl_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, SV *meth, U32 flags,
     if (flags & G_WRITING_TO_STDERR) {
        SAVETMPS;
 
     if (flags & G_WRITING_TO_STDERR) {
        SAVETMPS;
 

+       save_re_context();

        SAVESPTR(PL_stderrgv);
        PL_stderrgv = NULL;
     }
        SAVESPTR(PL_stderrgv);
        PL_stderrgv = NULL;
     }


@@ -1809,7 +1815,9 @@ Perl_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, SV *meth, U32 flags,
     PUSHSTACKi(PERLSI_MAGIC);
     PUSHMARK(SP);
 
     PUSHSTACKi(PERLSI_MAGIC);
     PUSHMARK(SP);
 

-    EXTEND(SP, argc+1);
+    /* EXTEND() expects a signed argc; don't wrap when casting */
+    assert(argc <= I32_MAX);
+    EXTEND(SP, (I32)argc+1);

     PUSHs(SvTIED_obj(sv, mg));
     if (flags & G_UNDEF_FILL) {
        while (argc--) {
     PUSHs(SvTIED_obj(sv, mg));
     if (flags & G_UNDEF_FILL) {
        while (argc--) {


@@ -2799,6 +2807,11 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
                }
            }
        }
                }
            }
        }

+#ifdef WIN32
+       else if (strEQ(mg->mg_ptr+1, "IN32_SLOPPY_STAT")) {
+           w32_sloppystat = (bool)sv_true(sv);
+       }
+#endif

        break;
     case '.':
        if (PL_localizing) {
        break;
     case '.':
        if (PL_localizing) {


@@ -3013,6 +3026,12 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
        }
     case ')':
        {
        }
     case ')':
        {

+/* (hv) best guess: maybe we'll need configure probes to do a better job,
+ * but you can override it if you need to.
+ */
+#ifndef INVALID_GID
+#define INVALID_GID ((Gid_t)-1)
+#endif

         /* XXX $) currently silently ignores failures */
        Gid_t new_egid;
 #ifdef HAS_SETGROUPS
         /* XXX $) currently silently ignores failures */
        Gid_t new_egid;
 #ifdef HAS_SETGROUPS


@@ -3035,7 +3054,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
             if (grok_atoUV(p, &uv, &endptr))
                 new_egid = (Gid_t)uv;
             else {
             if (grok_atoUV(p, &uv, &endptr))
                 new_egid = (Gid_t)uv;
             else {

-                new_egid = 0;   /* XXX is this safe? */
+                new_egid = INVALID_GID;

                 endptr = NULL;
             }
             for (i = 0; i < maxgrp; ++i) {
                 endptr = NULL;
             }
             for (i = 0; i < maxgrp; ++i) {


@@ -3053,7 +3072,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
                 if (grok_atoUV(p, &uv, &endptr))
                     gary[i] = (Groups_t)uv;
                 else {
                 if (grok_atoUV(p, &uv, &endptr))
                     gary[i] = (Groups_t)uv;
                 else {

-                    gary[i] = 0;    /* XXX is this safe? */
+                    gary[i] = INVALID_GID;

                     endptr = NULL;
                 }
             }
                     endptr = NULL;
                 }
             }


@@ -3272,7 +3291,7 @@ Perl_sighandler(int sig)
        if (hek)
            Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL),
                                "SIG%s handler \"%"HEKf"\" not defined.\n",
        if (hek)
            Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL),
                                "SIG%s handler \"%"HEKf"\" not defined.\n",

-                                PL_sig_name[sig], hek);
+                                PL_sig_name[sig], HEKfARG(hek));

             /* diag_listed_as: SIG%s handler "%s" not defined */
        else Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL),
                           "SIG%s handler \"__ANON__\" not defined.\n",
             /* diag_listed_as: SIG%s handler "%s" not defined */
        else Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL),
                           "SIG%s handler \"__ANON__\" not defined.\n",


@@ -3388,12 +3407,6 @@ S_restore_magic(pTHX_ const void *p)
 
     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
        SvTEMP_off(sv); /* if it's still magical, this value isn't temporary */
 
     if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
        SvTEMP_off(sv); /* if it's still magical, this value isn't temporary */

-#ifdef PERL_OLD_COPY_ON_WRITE
-       /* While magic was saved (and off) sv_setsv may well have seen
-          this SV as a prime candidate for COW.  */
-       if (SvIsCOW(sv))
-           sv_force_normal_flags(sv, 0);
-#endif

        if (mgs->mgs_flags)
            SvFLAGS(sv) |= mgs->mgs_flags;
        else
        if (mgs->mgs_flags)
            SvFLAGS(sv) |= mgs->mgs_flags;
        else


@@ -3450,7 +3463,7 @@ S_unwind_handler_stack(pTHX_ const void *p)
 /*
 =for apidoc magic_sethint
 
 /*
 =for apidoc magic_sethint
 

-Triggered by a store to %^H, records the key/value pair to
+Triggered by a store to C<%^H>, records the key/value pair to

 C<PL_compiling.cop_hints_hash>.  It is assumed that hints aren't storing
 anything that would need a deep copy.  Maybe we should warn if we find a
 reference.
 C<PL_compiling.cop_hints_hash>.  It is assumed that hints aren't storing
 anything that would need a deep copy.  Maybe we should warn if we find a
 reference.


@@ -3482,7 +3495,7 @@ Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
 /*
 =for apidoc magic_clearhint
 
 /*
 =for apidoc magic_clearhint
 

-Triggered by a delete from %^H, records the key to
+Triggered by a delete from C<%^H>, records the key to

 C<PL_compiling.cop_hints_hash>.
 
 =cut
 C<PL_compiling.cop_hints_hash>.
 
 =cut


@@ -3506,7 +3519,7 @@ Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
 /*
 =for apidoc magic_clearhints
 
 /*
 =for apidoc magic_clearhints
 

-Triggered by clearing %^H, resets C<PL_compiling.cop_hints_hash>.
+Triggered by clearing C<%^H>, resets C<PL_compiling.cop_hints_hash>.

 
 =cut
 */
 
 =cut
 */


@@ -3570,11 +3583,5 @@ Perl_magic_getdebugvar(pTHX_ SV *sv, MAGIC *mg) {
 }
 
 /*
 }
 
 /*

- * Local variables:
- * c-indentation-style: bsd
- * c-basic-offset: 4
- * indent-tabs-mode: nil
- * End:
- *

  * ex: set ts=8 sts=4 sw=4 et:
  */
  * ex: set ts=8 sts=4 sw=4 et:
  */