Experiment on use of attributes.pm interface.

 Valid generic fix to auto-vivify code in rv2gv - only "upgrade" to
 SVt_PVRV if not already something better (else vivify of say magic gets
 core dump).

p4raw-id: //depot/perlio@7727

diff --git a/perlio.c b/perlio.c
index f5135ca..05f589a 100644 (file)
--- a/perlio.c
+++ b/perlio.c
@@ -231,7 +231,7 @@ PerlIO_fileno(PerlIO *f)
  return (*PerlIOBase(f)->tab->Fileno)(f);
 }
 
-XS(XS_perlio_import)
+XS(XS_io_import)
 {
  dXSARGS;
  GV *gv = CvGV(cv);
@@ -241,7 +241,7 @@ XS(XS_perlio_import)
  XSRETURN_EMPTY;
 }
 
-XS(XS_perlio_unimport)
+XS(XS_io_unimport)
 {
  dXSARGS;
  GV *gv = CvGV(cv);
@@ -265,11 +265,95 @@ PerlIO_find_layer(char *name, STRLEN len)
  return NULL;
 }
 
+
+static int
+perlio_mg_set(pTHX_ SV *sv, MAGIC *mg)
+{
+ if (SvROK(sv))
+  {
+   IO *io = GvIOn(SvRV(sv));
+   PerlIO *ifp = IoIFP(io);
+   PerlIO *ofp = IoOFP(io);
+   AV *av = (AV *) mg->mg_obj;
+   Perl_warn(aTHX_ "set %_ %p %p %p",sv,io,ifp,ofp);
+  }
+ return 0;
+}
+
+static int
+perlio_mg_get(pTHX_ SV *sv, MAGIC *mg)
+{
+ if (SvROK(sv))
+  {
+   IO *io = GvIOn(SvRV(sv));
+   PerlIO *ifp = IoIFP(io);
+   PerlIO *ofp = IoOFP(io);
+   AV *av = (AV *) mg->mg_obj;
+   Perl_warn(aTHX_ "get %_ %p %p %p",sv,io,ifp,ofp);
+  }
+ return 0;
+}
+
+static int
+perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg)
+{
+ Perl_warn(aTHX_ "clear %_",sv);
+ return 0;
+}
+
+static int
+perlio_mg_free(pTHX_ SV *sv, MAGIC *mg)
+{
+ Perl_warn(aTHX_ "free %_",sv);
+ return 0;
+}
+
+MGVTBL perlio_vtab = {
+ perlio_mg_get,
+ perlio_mg_set,
+ NULL, /* len */
+ NULL,
+ perlio_mg_free
+};
+
+XS(XS_io_MODIFY_SCALAR_ATTRIBUTES)
+{
+ dXSARGS;
+ SV *sv    = SvRV(ST(1));
+ AV *av    = newAV();
+ MAGIC *mg;
+ int count = 0;
+ int i;
+ sv_magic(sv, (SV *)av, '~', NULL, 0);
+ SvRMAGICAL_off(sv);
+ mg = mg_find(sv,'~');
+ mg->mg_virtual = &perlio_vtab;
+ mg_magical(sv);
+ Perl_warn(aTHX_ "attrib %_",sv);
+ for (i=2; i < items; i++)
+  {
+   STRLEN len;
+   char *name = SvPV(ST(i),len);
+   SV *layer  = PerlIO_find_layer(name,len);
+   if (layer)
+    {
+     av_push(av,SvREFCNT_inc(layer));
+    }
+   else
+    {
+     ST(count) = ST(i);
+     count++;
+    }
+  }
+ SvREFCNT_dec(av);
+ XSRETURN(count);
+}
+
 void
 PerlIO_define_layer(PerlIO_funcs *tab)
 {
  dTHX;
- HV *stash = gv_stashpv("perlio::Layer", TRUE);
+ HV *stash = gv_stashpv("io::Layer", TRUE);
  SV *sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))),stash);
  hv_store(PerlIO_layer_hv,tab->name,strlen(tab->name),sv,0);
 }
@@ -285,10 +369,11 @@ PerlIO_default_layer(I32 n)
  if (!PerlIO_layer_hv)
   {
    char *s  = PerlEnv_getenv("PERLIO");
-   newXS("perlio::import",XS_perlio_import,__FILE__);
-   newXS("perlio::unimport",XS_perlio_unimport,__FILE__);
-   PerlIO_layer_hv = get_hv("open::layers",GV_ADD|GV_ADDMULTI);
-   PerlIO_layer_av = get_av("open::layers",GV_ADD|GV_ADDMULTI);
+   newXS("io::import",XS_io_import,__FILE__);
+   newXS("io::unimport",XS_io_unimport,__FILE__);
+   newXS("io::MODIFY_SCALAR_ATTRIBUTES",XS_io_MODIFY_SCALAR_ATTRIBUTES,__FILE__);
+   PerlIO_layer_hv = get_hv("io::layers",GV_ADD|GV_ADDMULTI);
+   PerlIO_layer_av = get_av("io::layers",GV_ADD|GV_ADDMULTI);
    PerlIO_define_layer(&PerlIO_unix);
    PerlIO_define_layer(&PerlIO_perlio);
    PerlIO_define_layer(&PerlIO_stdio);

diff --git a/pp.c b/pp.c
index 6001165..40a3970 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -178,7 +178,7 @@ PP(pp_padany)
 
 PP(pp_rv2gv)
 {
-    djSP; dTOPss;  
+    djSP; dTOPss;
 
     if (SvROK(sv)) {
       wasref:
@@ -206,9 +206,9 @@ PP(pp_rv2gv)
                    goto wasref;
            }
            if (!SvOK(sv) && sv != &PL_sv_undef) {
-               /* If this is a 'my' scalar and flag is set then vivify 
+               /* If this is a 'my' scalar and flag is set then vivify
                 * NI-S 1999/05/07
-                */ 
+                */
                if (PL_op->op_private & OPpDEREF) {
                    char *name;
                    GV *gv;
@@ -223,7 +223,8 @@ PP(pp_rv2gv)
                        name = CopSTASHPV(PL_curcop);
                        gv = newGVgen(name);
                    }
-                   sv_upgrade(sv, SVt_RV);
+                   if (SvTYPE(sv) < SVt_RV)
+                       sv_upgrade(sv, SVt_RV);
                    SvRV(sv) = (SV*)gv;
                    SvROK_on(sv);
                    SvSETMAGIC(sv);
@@ -410,7 +411,7 @@ PP(pp_prototype)
        char *s = SvPVX(TOPs);
        if (strnEQ(s, "CORE::", 6)) {
            int code;
-           
+       
            code = keyword(s + 6, SvCUR(TOPs) - 6);
            if (code < 0) {     /* Overridable. */
 #define MAX_ARGS_OP ((sizeof(I32) - 1) * 2)
@@ -434,9 +435,9 @@ PP(pp_prototype)
                        seen_question = 1;
                        str[n++] = ';';
                    }
-                   else if (n && str[0] == ';' && seen_question) 
+                   else if (n && str[0] == ';' && seen_question)
                        goto set;       /* XXXX system, exec */
-                   if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF 
+                   if ((oa & (OA_OPTIONAL - 1)) >= OA_AVREF
                        && (oa & (OA_OPTIONAL - 1)) <= OA_HVREF) {
                        str[n++] = '\\';
                    }
@@ -567,7 +568,7 @@ PP(pp_bless)
            Perl_croak(aTHX_ "Attempt to bless into a reference");
        ptr = SvPV(ssv,len);
        if (ckWARN(WARN_MISC) && len == 0)
-           Perl_warner(aTHX_ WARN_MISC, 
+           Perl_warner(aTHX_ WARN_MISC,
                   "Explicit blessing to '' (assuming package main)");
        stash = gv_stashpvn(ptr, len, TRUE);
     }
@@ -584,7 +585,7 @@ PP(pp_gelem)
     char *elem;
     djSP;
     STRLEN n_a;
- 
+
     sv = POPs;
     elem = SvPV(sv, n_a);
     gv = (GV*)POPs;
@@ -1571,7 +1572,7 @@ PP(pp_i_divide)
 
 PP(pp_i_modulo)
 {
-    djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN); 
+    djSP; dATARGET; tryAMAGICbin(modulo,opASSIGN);
     {
       dPOPTOPiirl;
       if (!right)
@@ -2308,7 +2309,7 @@ PP(pp_crypt)
     sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
 #endif
 #else
-    DIE(aTHX_ 
+    DIE(aTHX_
       "The crypt() function is unimplemented due to excessive paranoia.");
 #endif
     SETs(TARG);
@@ -2916,7 +2917,7 @@ PP(pp_lslice)
        ix = SvIVx(*lelem);
        if (ix < 0)
            ix += max;
-       else 
+       else
            ix -= arybase;
        if (ix < 0 || ix >= max)
            *lelem = &PL_sv_undef;
@@ -4248,7 +4249,7 @@ PP(pp_unpack)
              */
             if (PL_uudmap['M'] == 0) {
                 int i;
- 
+
                 for (i = 0; i < sizeof(PL_uuemap); i += 1)
                     PL_uudmap[(U8)PL_uuemap[i]] = i;
                 /*
@@ -4493,7 +4494,7 @@ PP(pp_pack)
            patcopy++;
            continue;
         }
-       if (datumtype == 'U' && pat == patcopy+1) 
+       if (datumtype == 'U' && pat == patcopy+1)
            SvUTF8_on(cat);
        if (datumtype == '#') {
            while (pat < patend && *pat != '\n')
@@ -5224,7 +5225,7 @@ PP(pp_split)
     else {
        maxiters += (strend - s) * rx->nparens;
        while (s < strend && --limit
-/*            && (!rx->check_substr 
+/*            && (!rx->check_substr
                   || ((s = CALLREG_INTUIT_START(aTHX_ rx, sv, s, strend,
                                                 0, NULL))))
 */            && CALLREGEXEC(aTHX_ rx, s, strend, orig,