Split out core of sv_magic() into sv_magicext().

sv_magic provides the extra restictions (no READONLY, only
one of each type, canned set of vtables), and sv_magicext()
does the actual data twiddling.
Also enhances semantics of ->mg_ptr setting via name/namlen
to allow either an uncopied ptr (namlen == 0), or a Newz()ed
scratch area (namlen > 0 && name == NULL).
sv_magicext also returns the MAGIC * it added.
sv_magicext is intended mainly for PERL_MAGIC_ext (~) magic.

To come sv_unmagicext() - which will remove just one magic
of particular type, and additionaly match against ->mg_ptr,
or the MAGIC * (need to experiment as to which is more natural).

p4raw-id: //depot/perlio@14335

diff --git a/embed.fnc b/embed.fnc
index cf8f891..f76805e 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -729,6 +729,8 @@ Apd |STRLEN |sv_len         |SV* sv
 Apd    |STRLEN |sv_len_utf8    |SV* sv
 Apd    |void   |sv_magic       |SV* sv|SV* obj|int how|const char* name \
                                |I32 namlen
+Apd    |MAGIC *|sv_magicext    |SV* sv|SV* obj|int how|MGVTBL *vtbl \
+                               | const char* name|I32 namlen   
 Apd    |SV*    |sv_mortalcopy  |SV* oldsv
 Apd    |SV*    |sv_newmortal
 Apd    |SV*    |sv_newref      |SV* sv

diff --git a/embed.h b/embed.h
index bbae4f1..a2fbb67 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -688,6 +688,7 @@
 #define sv_len                 Perl_sv_len
 #define sv_len_utf8            Perl_sv_len_utf8
 #define sv_magic               Perl_sv_magic
+#define sv_magicext            Perl_sv_magicext
 #define sv_mortalcopy          Perl_sv_mortalcopy
 #define sv_newmortal           Perl_sv_newmortal
 #define sv_newref              Perl_sv_newref
@@ -2239,6 +2240,7 @@
 #define sv_len(a)              Perl_sv_len(aTHX_ a)
 #define sv_len_utf8(a)         Perl_sv_len_utf8(aTHX_ a)
 #define sv_magic(a,b,c,d,e)    Perl_sv_magic(aTHX_ a,b,c,d,e)
+#define sv_magicext(a,b,c,d,e,f)       Perl_sv_magicext(aTHX_ a,b,c,d,e,f)
 #define sv_mortalcopy(a)       Perl_sv_mortalcopy(aTHX_ a)
 #define sv_newmortal()         Perl_sv_newmortal(aTHX)
 #define sv_newref(a)           Perl_sv_newref(aTHX_ a)

diff --git a/global.sym b/global.sym
index ae33a7a..e64508b 100644 (file)
--- a/global.sym
+++ b/global.sym
@@ -440,6 +440,7 @@ Perl_sv_isobject
 Perl_sv_len
 Perl_sv_len_utf8
 Perl_sv_magic
+Perl_sv_magicext
 Perl_sv_mortalcopy
 Perl_sv_newmortal
 Perl_sv_newref

diff --git a/proto.h b/proto.h
index fc67d8e..b93bb2c 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -758,6 +758,7 @@ PERL_CALLCONV int   Perl_sv_isobject(pTHX_ SV* sv);
 PERL_CALLCONV STRLEN   Perl_sv_len(pTHX_ SV* sv);
 PERL_CALLCONV STRLEN   Perl_sv_len_utf8(pTHX_ SV* sv);
 PERL_CALLCONV void     Perl_sv_magic(pTHX_ SV* sv, SV* obj, int how, const char* name, I32 namlen);
+PERL_CALLCONV MAGIC *  Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, MGVTBL *vtbl, const char* name, I32 namlen     );
 PERL_CALLCONV SV*      Perl_sv_mortalcopy(pTHX_ SV* oldsv);
 PERL_CALLCONV SV*      Perl_sv_newmortal(pTHX);
 PERL_CALLCONV SV*      Perl_sv_newref(pTHX_ SV* sv);

diff --git a/sv.c b/sv.c
index 7488bd9..2fbabb0 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -4415,43 +4415,34 @@ Perl_newSV(pTHX_ STRLEN len)
     }
     return sv;
 }
-
 /*
-=for apidoc sv_magic
+=for apidoc sv_magicext
 
-Adds magic to an SV. First upgrades C<sv> to type C<SVt_PVMG> if necessary,
-then adds a new magic item of type C<how> to the head of the magic list.
+Adds magic to an SV, upgrading it if necessary. Applies the 
+supplied vtable and returns pointer to the magic added.
+
+Note that sv_magicext will allow things that sv_magic will not.
+In particular you can add magic to SvREADONLY SVs and and more than 
+one instance of the same 'how'
 
-C<name> is assumed to contain an C<SV*> if C<(name && namelen == HEf_SVKEY)>
+I C<namelen> is greater then zero then a savepvn() I<copy> of C<name> is stored,
+(if C<name> is NULL then namelen bytes are allocated and Zero()-ed),
+if C<namelen> is zero then C<name> is stored as-is and - as another special 
+case - if C<(name && namelen == HEf_SVKEY)> then C<name> is assumed to contain 
+an C<SV*> and has its REFCNT incremented
+
+(This is now used as a subroutine by sv_magic.)
 
 =cut
 */
-
-void
-Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
+MAGIC *        
+Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, MGVTBL *vtable,
+                const char* name, I32 namlen)
 {
     MAGIC* mg;
-
-    if (SvREADONLY(sv)) {
-       if (PL_curcop != &PL_compiling
-           && how != PERL_MAGIC_regex_global
-           && how != PERL_MAGIC_bm
-           && how != PERL_MAGIC_fm
-           && how != PERL_MAGIC_sv
-          )
-       {
-           Perl_croak(aTHX_ PL_no_modify);
-       }
-    }
-    if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
-       if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
-           if (how == PERL_MAGIC_taint)
-               mg->mg_len |= 1;
-           return;
-       }
-    }
-    else {
-        (void)SvUPGRADE(sv, SVt_PVMG);
+    
+    if (SvTYPE(sv) < SVt_PVMG) {
+       (void)SvUPGRADE(sv, SVt_PVMG);
     }
     Newz(702,mg, 1, MAGIC);
     mg->mg_moremagic = SvMAGIC(sv);
@@ -4478,129 +4469,182 @@ Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 nam
     mg->mg_type = how;
     mg->mg_len = namlen;
     if (name) {
-       if (namlen >= 0)
+       if (namlen > 0)
            mg->mg_ptr = savepvn(name, namlen);
        else if (namlen == HEf_SVKEY)
            mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
+       else 
+           mg->mg_ptr = (char *) name;
     }
+    mg->mg_virtual = vtable;
+    
+    mg_magical(sv);
+    if (SvGMAGICAL(sv))
+       SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
+    return mg;
+}
+
+/*
+=for apidoc sv_magic
+
+Adds magic to an SV. First upgrades C<sv> to type C<SVt_PVMG> if necessary,
+then adds a new magic item of type C<how> to the head of the magic list.
+
+=cut
+*/
+
+void
+Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
+{ 
+    MAGIC* mg;
+    MGVTBL *vtable = 0;
 
+    if (SvREADONLY(sv)) {
+       if (PL_curcop != &PL_compiling
+           && how != PERL_MAGIC_regex_global
+           && how != PERL_MAGIC_bm
+           && how != PERL_MAGIC_fm
+           && how != PERL_MAGIC_sv
+          )
+       {
+           Perl_croak(aTHX_ PL_no_modify);
+       }
+    }
+    if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
+       if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
+           /* sv_magic() refuses to add a magic of the same 'how' as an 
+              existing one 
+            */
+           if (how == PERL_MAGIC_taint)
+               mg->mg_len |= 1;
+           return;
+       }
+    }
+        
     switch (how) {
     case PERL_MAGIC_sv:
-       mg->mg_virtual = &PL_vtbl_sv;
+       vtable = &PL_vtbl_sv;
        break;
     case PERL_MAGIC_overload:
-        mg->mg_virtual = &PL_vtbl_amagic;
+        vtable = &PL_vtbl_amagic;
         break;
     case PERL_MAGIC_overload_elem:
-        mg->mg_virtual = &PL_vtbl_amagicelem;
+        vtable = &PL_vtbl_amagicelem;
         break;
     case PERL_MAGIC_overload_table:
-        mg->mg_virtual = &PL_vtbl_ovrld;
+        vtable = &PL_vtbl_ovrld;
         break;
     case PERL_MAGIC_bm:
-       mg->mg_virtual = &PL_vtbl_bm;
+       vtable = &PL_vtbl_bm;
        break;
     case PERL_MAGIC_regdata:
-       mg->mg_virtual = &PL_vtbl_regdata;
+       vtable = &PL_vtbl_regdata;
        break;
     case PERL_MAGIC_regdatum:
-       mg->mg_virtual = &PL_vtbl_regdatum;
+       vtable = &PL_vtbl_regdatum;
        break;
     case PERL_MAGIC_env:
-       mg->mg_virtual = &PL_vtbl_env;
+       vtable = &PL_vtbl_env;
        break;
     case PERL_MAGIC_fm:
-       mg->mg_virtual = &PL_vtbl_fm;
+       vtable = &PL_vtbl_fm;
        break;
     case PERL_MAGIC_envelem:
-       mg->mg_virtual = &PL_vtbl_envelem;
+       vtable = &PL_vtbl_envelem;
        break;
     case PERL_MAGIC_regex_global:
-       mg->mg_virtual = &PL_vtbl_mglob;
+       vtable = &PL_vtbl_mglob;
        break;
     case PERL_MAGIC_isa:
-       mg->mg_virtual = &PL_vtbl_isa;
+       vtable = &PL_vtbl_isa;
        break;
     case PERL_MAGIC_isaelem:
-       mg->mg_virtual = &PL_vtbl_isaelem;
+       vtable = &PL_vtbl_isaelem;
        break;
     case PERL_MAGIC_nkeys:
-       mg->mg_virtual = &PL_vtbl_nkeys;
+       vtable = &PL_vtbl_nkeys;
        break;
     case PERL_MAGIC_dbfile:
-       SvRMAGICAL_on(sv);
-       mg->mg_virtual = 0;
+       vtable = 0;
        break;
     case PERL_MAGIC_dbline:
-       mg->mg_virtual = &PL_vtbl_dbline;
+       vtable = &PL_vtbl_dbline;
        break;
 #ifdef USE_5005THREADS
     case PERL_MAGIC_mutex:
-       mg->mg_virtual = &PL_vtbl_mutex;
+       vtable = &PL_vtbl_mutex;
        break;
 #endif /* USE_5005THREADS */
 #ifdef USE_LOCALE_COLLATE
     case PERL_MAGIC_collxfrm:
-        mg->mg_virtual = &PL_vtbl_collxfrm;
+        vtable = &PL_vtbl_collxfrm;
         break;
 #endif /* USE_LOCALE_COLLATE */
     case PERL_MAGIC_tied:
-       mg->mg_virtual = &PL_vtbl_pack;
+       vtable = &PL_vtbl_pack;
        break;
     case PERL_MAGIC_tiedelem:
     case PERL_MAGIC_tiedscalar:
-       mg->mg_virtual = &PL_vtbl_packelem;
+       vtable = &PL_vtbl_packelem;
        break;
     case PERL_MAGIC_qr:
-       mg->mg_virtual = &PL_vtbl_regexp;
+       vtable = &PL_vtbl_regexp;
        break;
     case PERL_MAGIC_sig:
-       mg->mg_virtual = &PL_vtbl_sig;
+       vtable = &PL_vtbl_sig;
        break;
     case PERL_MAGIC_sigelem:
-       mg->mg_virtual = &PL_vtbl_sigelem;
+       vtable = &PL_vtbl_sigelem;
        break;
     case PERL_MAGIC_taint:
-       mg->mg_virtual = &PL_vtbl_taint;
-       mg->mg_len = 1;
+       vtable = &PL_vtbl_taint;
        break;
     case PERL_MAGIC_uvar:
-       mg->mg_virtual = &PL_vtbl_uvar;
+       vtable = &PL_vtbl_uvar;
        break;
     case PERL_MAGIC_vec:
-       mg->mg_virtual = &PL_vtbl_vec;
+       vtable = &PL_vtbl_vec;
        break;
     case PERL_MAGIC_substr:
-       mg->mg_virtual = &PL_vtbl_substr;
+       vtable = &PL_vtbl_substr;
        break;
     case PERL_MAGIC_defelem:
-       mg->mg_virtual = &PL_vtbl_defelem;
+       vtable = &PL_vtbl_defelem;
        break;
     case PERL_MAGIC_glob:
-       mg->mg_virtual = &PL_vtbl_glob;
+       vtable = &PL_vtbl_glob;
        break;
     case PERL_MAGIC_arylen:
-       mg->mg_virtual = &PL_vtbl_arylen;
+       vtable = &PL_vtbl_arylen;
        break;
     case PERL_MAGIC_pos:
-       mg->mg_virtual = &PL_vtbl_pos;
+       vtable = &PL_vtbl_pos;
        break;
     case PERL_MAGIC_backref:
-       mg->mg_virtual = &PL_vtbl_backref;
+       vtable = &PL_vtbl_backref;
        break;
     case PERL_MAGIC_ext:
        /* Reserved for use by extensions not perl internals.           */
        /* Useful for attaching extension internal data to perl vars.   */
        /* Note that multiple extensions may clash if magical scalars   */
        /* etc holding private data from one are passed to another.     */
-       SvRMAGICAL_on(sv);
        break;
     default:
        Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
     }
-    mg_magical(sv);
-    if (SvGMAGICAL(sv))
-       SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
+    
+    /* Rest of work is done else where */
+    mg = sv_magicext(sv,obj,how,vtable,name,namlen);
+    
+    switch (how) {
+    case PERL_MAGIC_taint:
+       mg->mg_len = 1;
+       break;
+    case PERL_MAGIC_ext:
+    case PERL_MAGIC_dbfile:
+       SvRMAGICAL_on(sv);
+       break;
+    }
 }
 
 /*
@@ -4626,7 +4670,7 @@ Perl_sv_unmagic(pTHX_ SV *sv, int type)
            if (vtbl && vtbl->svt_free)
                CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
            if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
-               if (mg->mg_len >= 0)
+               if (mg->mg_len > 0)
                    Safefree(mg->mg_ptr);
                else if (mg->mg_len == HEf_SVKEY)
                    SvREFCNT_dec((SV*)mg->mg_ptr);

diff --git a/util.c b/util.c
index 72c85cd..a816cb9 100644 (file)
--- a/util.c
+++ b/util.c
@@ -905,7 +905,8 @@ Perl_savepv(pTHX_ const char *sv)
 =for apidoc savepvn
 
 Copy a string to a safe spot.  The C<len> indicates number of bytes to
-copy.  This does not use an SV.
+copy. If pointer is NULL allocate space for a string of size specified.
+This does not use an SV.
 
 =cut
 */
@@ -916,8 +917,14 @@ Perl_savepvn(pTHX_ const char *sv, register I32 len)
     register char *newaddr;
 
     New(903,newaddr,len+1,char);
-    Copy(sv,newaddr,len,char);         /* might not be null terminated */
-    newaddr[len] = '\0';               /* is now */
+    /* Give a meaning to NULL pointer mainly for the use in sv_magic() */
+    if (sv) {
+       Copy(sv,newaddr,len,char);      /* might not be null terminated */
+       newaddr[len] = '\0';            /* is now */
+    }
+    else {
+       Zero(newaddr,len+1,char);
+    }
     return newaddr;
 }