This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
perlapi: Add some S<>
[perl5.git] / mg.c
diff --git a/mg.c b/mg.c
index 6538003..1859391 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
 
-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
 */
@@ -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
-be >= SVt_PVMG.  See C<sv_magic>.
+be >= C<SVt_PVMG>.  See C<L</sv_magic>>.
 
 =cut
 */
@@ -245,7 +245,7 @@ Perl_mg_get(pTHX_ SV *sv)
 /*
 =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
 */
@@ -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,
-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
-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
 */
@@ -352,7 +352,7 @@ Perl_mg_size(pTHX_ SV *sv)
 /*
 =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
 */
@@ -390,8 +390,6 @@ S_mg_findext_flags(const SV *sv, int type, const MGVTBL *vtbl, U32 flags)
     if (sv) {
        MAGIC *mg;
 
-       assert(!(SvTYPE(sv) == SVt_PVAV && AvPAD_NAMELIST(sv)));
-
        for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
            if (mg->mg_type == type && (!flags || mg->mg_virtual == vtbl)) {
                return mg;
@@ -405,7 +403,7 @@ S_mg_findext_flags(const SV *sv, int type, const MGVTBL *vtbl, U32 flags)
 /*
 =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
 */
@@ -420,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
-C<sv_magicext>.
+C<L</sv_magicext>>.
 
 =cut
 */
@@ -449,7 +447,7 @@ Perl_mg_find_mglob(pTHX_ SV *sv)
 /*
 =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
 */
@@ -488,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
-SV.  Container magic (eg %ENV, $1, tie)
+SV.  Container magic (eg C<%ENV>, C<$1>, C<tie>)
 gets copied, value magic doesn't (eg
-taint, pos).
+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
@@ -555,7 +553,7 @@ S_mg_free_struct(pTHX_ SV *sv, MAGIC *mg)
 /*
 =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
 */
@@ -581,7 +579,7 @@ Perl_mg_free(pTHX_ SV *sv)
 /*
 =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
 */
@@ -751,15 +749,16 @@ S_fixup_errno_string(pTHX_ SV* sv)
          * case we should turn on that flag.  This didn't use to happen, and to
          * avoid as many possible backward compatibility issues as possible, we
          * don't turn on the flag unless we have to.  So the flag stays off for
-         * an entirely ASCII string.  We assume that if the string looks like
-         * UTF-8, it really is UTF-8:  "text in any other encoding that uses
-         * bytes with the high bit set is extremely unlikely to pass a UTF-8
-         * validity test" (http://en.wikipedia.org/wiki/Charset_detection).
-         * There is a potential that we will get it wrong however, especially
-         * on short error message text.  (If it turns out to be necessary, we
-         * could also keep track if the current LC_MESSAGES locale is UTF-8) */
+         * an entirely invariant string.  We assume that if the string looks
+         * like UTF-8, it really is UTF-8:  "text in any other encoding that
+         * uses bytes with the high bit set is extremely unlikely to pass a
+         * UTF-8 validity test"
+         * (http://en.wikipedia.org/wiki/Charset_detection).  There is a
+         * potential that we will get it wrong however, especially on short
+         * error message text.  (If it turns out to be necessary, we could also
+         * keep track if the current LC_MESSAGES locale is UTF-8) */
         if (! IN_BYTES  /* respect 'use bytes' */
-            && ! is_ascii_string((U8*) SvPVX_const(sv), SvCUR(sv))
+            && ! is_invariant_string((U8*) SvPVX_const(sv), SvCUR(sv))
             && is_utf8_string((U8*) SvPVX_const(sv), SvCUR(sv)))
         {
             SvUTF8_on(sv);
@@ -1104,7 +1103,6 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
            sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
        break;
     case ':':
-       break;
     case '/':
        break;
     case '[':
@@ -1390,12 +1388,14 @@ Perl_csighandler(int sig)
 #else
     dTHX;
 #endif
+#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
 #if defined(__cplusplus) && defined(__GNUC__)
     /* g++ doesn't support PERL_UNUSED_DECL, so the sip and uap
      * parameters would be warned about. */
     PERL_UNUSED_ARG(sip);
     PERL_UNUSED_ARG(uap);
 #endif
+#endif
 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
     (void) rsignal(sig, PL_csighandlerp);
     if (PL_sig_ignoring[sig]) return;
@@ -1782,7 +1782,7 @@ The C<flags> can be:
 
 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
@@ -1802,6 +1802,7 @@ Perl_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, SV *meth, U32 flags,
     if (flags & G_WRITING_TO_STDERR) {
        SAVETMPS;
 
+       save_re_context();
        SAVESPTR(PL_stderrgv);
        PL_stderrgv = NULL;
     }
@@ -2546,8 +2547,8 @@ Perl_magic_setlvref(pTHX_ SV *sv, MAGIC *mg)
                 SvREFCNT_inc_simple_NN(SvRV(sv)));
        break;
     case SVt_PVHV:
-       hv_store_ent((HV *)mg->mg_obj, (SV *)mg->mg_ptr,
-                    SvREFCNT_inc_simple_NN(SvRV(sv)), 0);
+       (void)hv_store_ent((HV *)mg->mg_obj, (SV *)mg->mg_ptr,
+                           SvREFCNT_inc_simple_NN(SvRV(sv)), 0);
     }
     if (mg->mg_flags & MGf_PERSIST)
        NOOP; /* This sv is in use as an iterator var and will be reused,
@@ -2867,6 +2868,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
                         );
                     }
                 } else {
+                    sv_setsv(sv, PL_rs);
               /* diag_listed_as: Setting $/ to %s reference is forbidden */
                     Perl_croak(aTHX_ "Setting $/ to a%s %s reference is forbidden",
                                       *reftype == 'A' ? "n" : "", reftype);
@@ -3012,6 +3014,12 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
        }
     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
@@ -3019,6 +3027,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
            const char *p = SvPV_const(sv, len);
             Groups_t *gary = NULL;
             const char* endptr;
+            UV uv;
 #ifdef _SC_NGROUPS_MAX
            int maxgrp = sysconf(_SC_NGROUPS_MAX);
 
@@ -3030,7 +3039,12 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
 
             while (isSPACE(*p))
                 ++p;
-            new_egid = (Gid_t)grok_atou(p, &endptr);
+            if (grok_atoUV(p, &uv, &endptr))
+                new_egid = (Gid_t)uv;
+            else {
+                new_egid = INVALID_GID;
+                endptr = NULL;
+            }
             for (i = 0; i < maxgrp; ++i) {
                 if (endptr == NULL)
                     break;
@@ -3043,7 +3057,12 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
                     Newx(gary, i + 1, Groups_t);
                 else
                     Renew(gary, i + 1, Groups_t);
-                gary[i] = (Groups_t)grok_atou(p, &endptr);
+                if (grok_atoUV(p, &uv, &endptr))
+                    gary[i] = (Groups_t)uv;
+                else {
+                    gary[i] = INVALID_GID;
+                    endptr = NULL;
+                }
             }
             if (i)
                 PERL_UNUSED_RESULT(setgroups(i, gary));
@@ -3260,7 +3279,7 @@ Perl_sighandler(int sig)
        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",
@@ -3351,7 +3370,7 @@ Perl_sighandler(int sig)
        }
     }
 
-cleanup:
+  cleanup:
     /* pop any of SAVEFREESV, SAVEDESTRUCTOR_X and "save in progress" */
     PL_savestack_ix = old_ss_ix;
     if (flags & 8)
@@ -3376,12 +3395,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 */
-#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
@@ -3438,7 +3451,7 @@ S_unwind_handler_stack(pTHX_ const void *p)
 /*
 =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.
@@ -3470,7 +3483,7 @@ Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
 /*
 =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
@@ -3494,7 +3507,7 @@ Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
 /*
 =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
 */
@@ -3558,11 +3571,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:
  */