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

6 files changed, 129 insertions, 72 deletions

diff --git a/embed.fnc b/embed.fnc
index cf8f8913eb..f76805ea66 100644
--- 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 bbae4f1e70..a2fbb67052 100644
--- 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 ae33a7aee8..e64508b793 100644
--- 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 fc67d8eafa..b93bb2c525 100644
--- 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 7488bd90b9..2fbabb0214 100644
--- 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 72c85cdc76..a816cb99ba 100644
--- 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;
 }