From: Nick Ing-Simmons Date: Fri, 17 Nov 2000 21:56:31 +0000 (+0000) Subject: Experiment on use of attributes.pm interface. X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=b13b21351ea0b61f5fdc4e4ab614bbe813c655f7;p=p5sagit%2Fp5-mst-13.2.git 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 --- 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 --- 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,