Change 14346 by jhi@alpha on 2002/01/19 17:55:55
Integrate perlio; Split out core of sv_magic() into sv_magicext().
Affected files ...
.... //depot/perl/embed.fnc#11 integrate
.... //depot/perl/embed.h#332 integrate
.... //depot/perl/embedvar.h#139 integrate
.... //depot/perl/global.sym#203 integrate
.... //depot/perl/perlapi.c#129 integrate
.... //depot/perl/perlapi.h#61 integrate
.... //depot/perl/pod/perlapi.pod#128 integrate
.... //depot/perl/pod/perlintern.pod#17 integrate
.... //depot/perl/proto.h#374 integrate
.... //depot/perl/sv.c#511 integrate
.... //depot/perl/util.c#318 integrate
Differences ...
==== //depot/perl/embed.fnc#11 (text) ====
Index: perl/embed.fnc
--- perl/embed.fnc.~1~ Sat Jan 19 11:00:05 2002
+++ perl/embed.fnc Sat Jan 19 11:00:05 2002
@@ -729,6 +729,8 @@
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
==== //depot/perl/embed.h#332 (text+w) ====
Index: perl/embed.h
--- perl/embed.h.~1~ Sat Jan 19 11:00:05 2002
+++ perl/embed.h Sat Jan 19 11:00:05 2002
@@ -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)
==== //depot/perl/embedvar.h#139 (text+w) ====
==== //depot/perl/global.sym#203 (text+w) ====
Index: perl/global.sym
--- perl/global.sym.~1~ Sat Jan 19 11:00:05 2002
+++ perl/global.sym Sat Jan 19 11:00:05 2002
@@ -440,6 +440,7 @@
Perl_sv_len
Perl_sv_len_utf8
Perl_sv_magic
+Perl_sv_magicext
Perl_sv_mortalcopy
Perl_sv_newmortal
Perl_sv_newref
==== //depot/perl/perlapi.c#129 (text+w) ====
==== //depot/perl/perlapi.h#61 (text+w) ====
==== //depot/perl/pod/perlapi.pod#128 (text+w) ====
==== //depot/perl/pod/perlintern.pod#17 (text+w) ====
==== //depot/perl/proto.h#374 (text+w) ====
Index: perl/proto.h
--- perl/proto.h.~1~ Sat Jan 19 11:00:05 2002
+++ perl/proto.h Sat Jan 19 11:00:05 2002
@@ -758,6 +758,7 @@
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);
==== //depot/perl/sv.c#511 (text) ====
Index: perl/sv.c
--- perl/sv.c.~1~ Sat Jan 19 11:00:05 2002
+++ perl/sv.c Sat Jan 19 11:00:05 2002
@@ -4415,44 +4415,35 @@
}
return sv;
}
+/*
+=for apidoc sv_magicext
+
+Adds magic to an SV, upgrading it if necessary. Applies the
+supplied vtable and returns pointer to the magic added.
-/*
-=for apidoc sv_magic
+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'
-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.
+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
-C<name> is assumed to contain an C<SV*> if C<(name && namelen == HEf_SVKEY)>
+(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;
- }
+
+ if (SvTYPE(sv) < SVt_PVMG) {
+ (void)SvUPGRADE(sv, SVt_PVMG);
}
- else {
- (void)SvUPGRADE(sv, SVt_PVMG);
- }
Newz(702,mg, 1, MAGIC);
mg->mg_moremagic = SvMAGIC(sv);
SvMAGIC(sv) = mg;
@@ -4478,129 +4469,182 @@
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 @@
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);
==== //depot/perl/util.c#318 (text) ====
Index: perl/util.c
--- perl/util.c.~1~ Sat Jan 19 11:00:05 2002
+++ perl/util.c Sat Jan 19 11:00:05 2002
@@ -905,7 +905,8 @@
=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 @@
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;
}
End of Patch.
