X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=universal.c;h=4822d3dd8c8cd8f0eaa1ac14269c95de5a731d13;hb=b4ad57f4f7fe2aca6dc52ea357ce9be7a7d38769;hp=926d1c349d4782d25f68511761e0f2412b34e48c;hpb=fe7bca907fe77f091cc40c458c768c0db469e921;p=p5sagit%2Fp5-mst-13.2.git diff --git a/universal.c b/universal.c index 926d1c3..4822d3d 100644 --- a/universal.c +++ b/universal.c @@ -1,6 +1,7 @@ /* universal.c * - * Copyright (c) 1997-2002, Larry Wall + * Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, + * by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -17,6 +18,10 @@ #define PERL_IN_UNIVERSAL_C #include "perl.h" +#ifdef USE_PERLIO +#include "perliol.h" /* For the PERLIO_F_XXX */ +#endif + /* * Contributed by Graham Barr * The main guts of traverse_isa was actually copied from gv_fetchmeth @@ -40,6 +45,9 @@ S_isa_lookup(pTHX_ HV *stash, const char *name, HV* name_stash, if (strEQ(HvNAME(stash), name)) return &PL_sv_yes; + if (strEQ(name, "UNIVERSAL")) + return &PL_sv_yes; + if (level > 100) Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'", HvNAME(stash)); @@ -49,7 +57,7 @@ S_isa_lookup(pTHX_ HV *stash, const char *name, HV* name_stash, if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (subgen = GvSV(gv)) && (hv = GvHV(gv))) { - if (SvIV(subgen) == PL_sub_generation) { + if (SvIV(subgen) == (IV)PL_sub_generation) { SV* sv; SV** svp = (SV**)hv_fetch(hv, name, len, FALSE); if (svp && (sv = *svp) != (SV*)&PL_sv_undef) { @@ -94,8 +102,8 @@ S_isa_lookup(pTHX_ HV *stash, const char *name, HV* name_stash, if (!basestash) { if (ckWARN(WARN_MISC)) Perl_warner(aTHX_ packWARN(WARN_SYNTAX), - "Can't locate package %s for @%s::ISA", - SvPVX(sv), HvNAME(stash)); + "Can't locate package %"SVf" for @%s::ISA", + sv, HvNAME(stash)); continue; } if (&PL_sv_yes == isa_lookup(basestash, name, name_stash, @@ -107,8 +115,7 @@ S_isa_lookup(pTHX_ HV *stash, const char *name, HV* name_stash, (void)hv_store(hv,name,len,&PL_sv_no,0); } } - - return boolSV(strEQ(name, "UNIVERSAL")); + return &PL_sv_no; } /* @@ -160,6 +167,15 @@ Perl_sv_derived_from(pTHX_ SV *sv, const char *name) void XS_UNIVERSAL_isa(pTHX_ CV *cv); void XS_UNIVERSAL_can(pTHX_ CV *cv); void XS_UNIVERSAL_VERSION(pTHX_ CV *cv); +XS(XS_version_new); +XS(XS_version_stringify); +XS(XS_version_numify); +XS(XS_version_vcmp); +XS(XS_version_boolean); +XS(XS_version_noop); +XS(XS_version_is_alpha); +XS(XS_version_qv); +XS(XS_utf8_is_utf8); XS(XS_utf8_valid); XS(XS_utf8_encode); XS(XS_utf8_decode); @@ -170,6 +186,11 @@ XS(XS_utf8_native_to_unicode); XS(XS_Internals_SvREADONLY); XS(XS_Internals_SvREFCNT); XS(XS_Internals_hv_clear_placehold); +XS(XS_PerlIO_get_layers); +XS(XS_Regexp_DESTROY); +XS(XS_Internals_hash_seed); +XS(XS_Internals_rehash_seed); +XS(XS_Internals_HvREHASH); void Perl_boot_core_UNIVERSAL(pTHX) @@ -179,6 +200,27 @@ Perl_boot_core_UNIVERSAL(pTHX) newXS("UNIVERSAL::isa", XS_UNIVERSAL_isa, file); newXS("UNIVERSAL::can", XS_UNIVERSAL_can, file); newXS("UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, file); + { + /* register the overloading (type 'A') magic */ + PL_amagic_generation++; + /* Make it findable via fetchmethod */ + newXS("version::()", XS_version_noop, file); + newXS("version::new", XS_version_new, file); + newXS("version::(\"\"", XS_version_stringify, file); + newXS("version::stringify", XS_version_stringify, file); + newXS("version::(0+", XS_version_numify, file); + newXS("version::numify", XS_version_numify, file); + newXS("version::(cmp", XS_version_vcmp, file); + newXS("version::(<=>", XS_version_vcmp, file); + newXS("version::vcmp", XS_version_vcmp, file); + newXS("version::(bool", XS_version_boolean, file); + newXS("version::boolean", XS_version_boolean, file); + newXS("version::(nomethod", XS_version_noop, file); + newXS("version::noop", XS_version_noop, file); + newXS("version::is_alpha", XS_version_is_alpha, file); + newXS("version::qv", XS_version_qv, file); + } + newXS("utf8::is_utf8", XS_utf8_is_utf8, file); newXS("utf8::valid", XS_utf8_valid, file); newXS("utf8::encode", XS_utf8_encode, file); newXS("utf8::decode", XS_utf8_decode, file); @@ -190,6 +232,12 @@ Perl_boot_core_UNIVERSAL(pTHX) newXSproto("Internals::SvREFCNT",XS_Internals_SvREFCNT, file, "\\[$%@];$"); newXSproto("Internals::hv_clear_placeholders", XS_Internals_hv_clear_placehold, file, "\\%"); + newXSproto("PerlIO::get_layers", + XS_PerlIO_get_layers, file, "*;@"); + newXS("Regexp::DESTROY", XS_Regexp_DESTROY, file); + newXSproto("Internals::hash_seed",XS_Internals_hash_seed, file, ""); + newXSproto("Internals::rehash_seed",XS_Internals_rehash_seed, file, ""); + newXSproto("Internals::HvREHASH", XS_Internals_HvREHASH, file, "\\%"); } @@ -208,7 +256,8 @@ XS(XS_UNIVERSAL_isa) if (SvGMAGICAL(sv)) mg_get(sv); - if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv)))) + if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv)) + || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv)))) XSRETURN_UNDEF; name = (char *)SvPV(ST(1),n_a); @@ -234,7 +283,8 @@ XS(XS_UNIVERSAL_can) if (SvGMAGICAL(sv)) mg_get(sv); - if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv)))) + if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv)) + || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv)))) XSRETURN_UNDEF; name = (char *)SvPV(ST(1),n_a); @@ -284,6 +334,8 @@ XS(XS_UNIVERSAL_VERSION) SV *nsv = sv_newmortal(); sv_setsv(nsv, sv); sv = nsv; + if ( !sv_derived_from(sv, "version")) + upg_version(sv); undef = Nullch; } else { @@ -307,70 +359,292 @@ XS(XS_UNIVERSAL_VERSION) "%s defines neither package nor VERSION--version check failed", str); } } - if (!SvNIOK(sv) && SvPOK(sv)) { - char *str = SvPVx(sv,len); - while (len) { - --len; - /* XXX could DWIM "1.2.3" here */ - if (!isDIGIT(str[len]) && str[len] != '.' && str[len] != '_') - break; - } - if (len) { - if (SvNOK(req) && SvPOK(req)) { - /* they said C and $Foo::VERSION - * doesn't look like a float: do string compare */ - if (sv_cmp(req,sv) == 1) { - Perl_croak(aTHX_ "%s v%"VDf" required--" - "this is only v%"VDf, - HvNAME(pkg), req, sv); - } - goto finish; - } - /* they said C and $Foo::VERSION - * doesn't look like a float: force numeric compare */ - (void)SvUPGRADE(sv, SVt_PVNV); - SvNVX(sv) = str_to_version(sv); - SvPOK_off(sv); - SvNOK_on(sv); - } - } - /* if we get here, we're looking for a numeric comparison, - * so force the required version into a float, even if they - * said C */ - if (SvNOK(req) && SvPOK(req)) { - NV n = SvNV(req); - req = sv_newmortal(); - sv_setnv(req, n); + + if ( !sv_derived_from(req, "version")) { + /* req may very well be R/O, so create a new object */ + SV *nsv = sv_newmortal(); + sv_setsv(nsv, req); + req = nsv; + upg_version(req); } - if (SvNV(req) > SvNV(sv)) - Perl_croak(aTHX_ "%s version %s required--this is only version %s", - HvNAME(pkg), SvPV_nolen(req), SvPV_nolen(sv)); + if ( vcmp( req, sv ) > 0 ) + Perl_croak(aTHX_ + "%s version %"SVf" required--this is only version %"SVf, + HvNAME(pkg), req, sv); } -finish: ST(0) = sv; XSRETURN(1); } -XS(XS_utf8_valid) +XS(XS_version_new) +{ + dXSARGS; + if (items > 3) + Perl_croak(aTHX_ "Usage: version::new(class, version)"); + SP -= items; + { + char * class = (char *)SvPV_nolen(ST(0)); + SV *vs = ST(1); + SV *rv; + if (items == 3 ) + { + vs = sv_newmortal(); + Perl_sv_setpvf(aTHX_ vs,"v%s",SvPV_nolen(ST(2))); + } + + rv = new_version(vs); + if ( strcmp(class,"version") != 0 ) /* inherited new() */ + sv_bless(rv, gv_stashpv(class,TRUE)); + + PUSHs(sv_2mortal(rv)); + PUTBACK; + return; + } +} + +XS(XS_version_stringify) +{ + dXSARGS; + if (items < 1) + Perl_croak(aTHX_ "Usage: version::stringify(lobj, ...)"); + SP -= items; + { + SV * lobj; + + if (sv_derived_from(ST(0), "version")) { + SV *tmp = SvRV(ST(0)); + lobj = tmp; + } + else + Perl_croak(aTHX_ "lobj is not of type version"); + + PUSHs(sv_2mortal(vstringify(lobj))); + + PUTBACK; + return; + } +} + +XS(XS_version_numify) +{ + dXSARGS; + if (items < 1) + Perl_croak(aTHX_ "Usage: version::numify(lobj, ...)"); + SP -= items; + { + SV * lobj; + + if (sv_derived_from(ST(0), "version")) { + SV *tmp = SvRV(ST(0)); + lobj = tmp; + } + else + Perl_croak(aTHX_ "lobj is not of type version"); + + PUSHs(sv_2mortal(vnumify(lobj))); + + PUTBACK; + return; + } +} + +XS(XS_version_vcmp) +{ + dXSARGS; + if (items < 1) + Perl_croak(aTHX_ "Usage: version::vcmp(lobj, ...)"); + SP -= items; + { + SV * lobj; + + if (sv_derived_from(ST(0), "version")) { + SV *tmp = SvRV(ST(0)); + lobj = tmp; + } + else + Perl_croak(aTHX_ "lobj is not of type version"); + + { + SV *rs; + SV *rvs; + SV * robj = ST(1); + IV swap = (IV)SvIV(ST(2)); + + if ( ! sv_derived_from(robj, "version") ) + { + robj = new_version(robj); + } + rvs = SvRV(robj); + + if ( swap ) + { + rs = newSViv(vcmp(rvs,lobj)); + } + else + { + rs = newSViv(vcmp(lobj,rvs)); + } + + PUSHs(sv_2mortal(rs)); + } + + PUTBACK; + return; + } +} + +XS(XS_version_boolean) +{ + dXSARGS; + if (items < 1) + Perl_croak(aTHX_ "Usage: version::boolean(lobj, ...)"); + SP -= items; + { + SV * lobj; + + if (sv_derived_from(ST(0), "version")) { + SV *tmp = SvRV(ST(0)); + lobj = tmp; + } + else + Perl_croak(aTHX_ "lobj is not of type version"); + + { + SV *rs; + rs = newSViv( vcmp(lobj,new_version(newSVpvn("0",1))) ); + PUSHs(sv_2mortal(rs)); + } + + PUTBACK; + return; + } +} + +XS(XS_version_noop) +{ + dXSARGS; + if (items < 1) + Perl_croak(aTHX_ "Usage: version::noop(lobj, ...)"); + { + SV * lobj; + + if (sv_derived_from(ST(0), "version")) { + SV *tmp = SvRV(ST(0)); + lobj = tmp; + } + else + Perl_croak(aTHX_ "lobj is not of type version"); + + { + Perl_croak(aTHX_ "operation not supported with version object"); + } + + } + XSRETURN_EMPTY; +} + +XS(XS_version_is_alpha) { dXSARGS; if (items != 1) - Perl_croak(aTHX_ "Usage: utf8::valid(sv)"); + Perl_croak(aTHX_ "Usage: version::is_alpha(lobj)"); + SP -= items; { - SV * sv = ST(0); - { - STRLEN len; - char *s = SvPV(sv,len); - if (!SvUTF8(sv) || is_utf8_string((U8*)s,len)) - XSRETURN_YES; - else - XSRETURN_NO; - } + SV *lobj; + + if (sv_derived_from(ST(0), "version")) { + SV *tmp = SvRV(ST(0)); + lobj = tmp; + } + else + Perl_croak(aTHX_ "lobj is not of type version"); +{ + I32 len = av_len((AV *)lobj); + I32 digit = SvIVX(*av_fetch((AV *)lobj, len, 0)); + if ( digit < 0 ) + XSRETURN_YES; + else + XSRETURN_NO; +} + PUTBACK; + return; } - XSRETURN_EMPTY; +} + +XS(XS_version_qv) +{ + dXSARGS; + if (items != 1) + Perl_croak(aTHX_ "Usage: version::qv(ver)"); + SP -= items; + { + SV * ver = ST(0); + if ( !SvVOK(ver) ) /* only need to do with if not already v-string */ + { + SV *vs = sv_newmortal(); + char *version; + if ( SvNOK(ver) ) /* may get too much accuracy */ + { + char tbuf[64]; + sprintf(tbuf,"%.9"NVgf, SvNVX(ver)); + version = savepv(tbuf); + } + else + { + version = savepv(SvPV_nolen(ver)); + } + (void)scan_version(version,vs,TRUE); + Safefree(version); + + PUSHs(vs); + } + else + { + PUSHs(sv_2mortal(new_version(ver))); + } + + PUTBACK; + return; + } +} + +XS(XS_utf8_is_utf8) +{ + dXSARGS; + if (items != 1) + Perl_croak(aTHX_ "Usage: utf8::is_utf8(sv)"); + { + SV * sv = ST(0); + { + if (SvUTF8(sv)) + XSRETURN_YES; + else + XSRETURN_NO; + } + } + XSRETURN_EMPTY; +} + +XS(XS_utf8_valid) +{ + dXSARGS; + if (items != 1) + Perl_croak(aTHX_ "Usage: utf8::valid(sv)"); + { + SV * sv = ST(0); + { + STRLEN len; + char *s = SvPV(sv,len); + if (!SvUTF8(sv) || is_utf8_string((U8*)s,len)) + XSRETURN_YES; + else + XSRETURN_NO; + } + } + XSRETURN_EMPTY; } XS(XS_utf8_encode) @@ -503,52 +777,173 @@ XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */ XSRETURN_UNDEF; /* Can't happen. */ } -/* Maybe this should return the number of placeholders found in scalar context, - and a list of them in list context. */ XS(XS_Internals_hv_clear_placehold) { dXSARGS; HV *hv = (HV *) SvRV(ST(0)); + if (items != 1) + Perl_croak(aTHX_ "Usage: UNIVERSAL::hv_clear_placeholders(hv)"); + hv_clear_placeholders(hv); + XSRETURN(0); +} - /* I don't care how many parameters were passed in, but I want to avoid - the unused variable warning. */ - - items = HvPLACEHOLDERS(hv); - - if (items) { - HE *entry; - I32 riter = HvRITER(hv); - HE *eiter = HvEITER(hv); - hv_iterinit(hv); - /* This may look suboptimal with the items *after* the iternext, but - it's quite deliberate. We only get here with items==0 if we've - just deleted the last placeholder in the hash. If we've just done - that then it means that the hash is in lazy delete mode, and the - HE is now only referenced in our iterator. If we just quit the loop - and discarded our iterator then the HE leaks. So we do the && the - other way to ensure iternext is called just one more time, which - has the side effect of triggering the lazy delete. */ - while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS)) - && items) { - SV *val = hv_iterval(hv, entry); - - if (val == &PL_sv_undef) { - - /* It seems that I have to go back in the front of the hash - API to delete a hash, even though I have a HE structure - pointing to the very entry I want to delete, and could hold - onto the previous HE that points to it. And it's easier to - go in with SVs as I can then specify the precomputed hash, - and don't have fun and games with utf8 keys. */ - SV *key = hv_iterkeysv(entry); - - hv_delete_ent (hv, key, G_DISCARD, HeHASH(entry)); - items--; - } - } - HvRITER(hv) = riter; - HvEITER(hv) = eiter; +XS(XS_Regexp_DESTROY) +{ + +} + +XS(XS_PerlIO_get_layers) +{ + dXSARGS; + if (items < 1 || items % 2 == 0) + Perl_croak(aTHX_ "Usage: PerlIO_get_layers(filehandle[,args])"); +#ifdef USE_PERLIO + { + SV * sv; + GV * gv; + IO * io; + bool input = TRUE; + bool details = FALSE; + + if (items > 1) { + SV **svp; + + for (svp = MARK + 2; svp <= SP; svp += 2) { + SV **varp = svp; + SV **valp = svp + 1; + STRLEN klen; + char *key = SvPV(*varp, klen); + + switch (*key) { + case 'i': + if (klen == 5 && memEQ(key, "input", 5)) { + input = SvTRUE(*valp); + break; + } + goto fail; + case 'o': + if (klen == 6 && memEQ(key, "output", 6)) { + input = !SvTRUE(*valp); + break; + } + goto fail; + case 'd': + if (klen == 7 && memEQ(key, "details", 7)) { + details = SvTRUE(*valp); + break; + } + goto fail; + default: + fail: + Perl_croak(aTHX_ + "get_layers: unknown argument '%s'", + key); + } + } + + SP -= (items - 1); + } + + sv = POPs; + gv = (GV*)sv; + + if (!isGV(sv)) { + if (SvROK(sv) && isGV(SvRV(sv))) + gv = (GV*)SvRV(sv); + else + gv = gv_fetchpv(SvPVX(sv), FALSE, SVt_PVIO); + } + + if (gv && (io = GvIO(gv))) { + dTARGET; + AV* av = PerlIO_get_layers(aTHX_ input ? + IoIFP(io) : IoOFP(io)); + I32 i; + I32 last = av_len(av); + I32 nitem = 0; + + for (i = last; i >= 0; i -= 3) { + SV **namsvp; + SV **argsvp; + SV **flgsvp; + bool namok, argok, flgok; + + namsvp = av_fetch(av, i - 2, FALSE); + argsvp = av_fetch(av, i - 1, FALSE); + flgsvp = av_fetch(av, i, FALSE); + + namok = namsvp && *namsvp && SvPOK(*namsvp); + argok = argsvp && *argsvp && SvPOK(*argsvp); + flgok = flgsvp && *flgsvp && SvIOK(*flgsvp); + + if (details) { + XPUSHs(namok ? + newSVpv(SvPVX(*namsvp), 0) : &PL_sv_undef); + XPUSHs(argok ? + newSVpv(SvPVX(*argsvp), 0) : &PL_sv_undef); + if (flgok) + XPUSHi(SvIVX(*flgsvp)); + else + XPUSHs(&PL_sv_undef); + nitem += 3; + } + else { + if (namok && argok) + XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")", + *namsvp, *argsvp)); + else if (namok) + XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf, *namsvp)); + else + XPUSHs(&PL_sv_undef); + nitem++; + if (flgok) { + IV flags = SvIVX(*flgsvp); + + if (flags & PERLIO_F_UTF8) { + XPUSHs(newSVpvn("utf8", 4)); + nitem++; + } + } + } + } + + SvREFCNT_dec(av); + + XSRETURN(nitem); + } } +#endif XSRETURN(0); } + +XS(XS_Internals_hash_seed) +{ + /* Using dXSARGS would also have dITEM and dSP, + * which define 2 unused local variables. */ + dMARK; dAX; + XSRETURN_UV(PERL_HASH_SEED); +} + +XS(XS_Internals_rehash_seed) +{ + /* Using dXSARGS would also have dITEM and dSP, + * which define 2 unused local variables. */ + dMARK; dAX; + XSRETURN_UV(PL_rehash_seed); +} + +XS(XS_Internals_HvREHASH) /* Subject to change */ +{ + dXSARGS; + if (SvROK(ST(0))) { + HV *hv = (HV *) SvRV(ST(0)); + if (items == 1 && SvTYPE(hv) == SVt_PVHV) { + if (HvREHASH(hv)) + XSRETURN_YES; + else + XSRETURN_NO; + } + } + Perl_croak(aTHX_ "Internals::HvREHASH $hashref"); +}