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) {
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_utf8_valid);
XS(XS_utf8_encode);
XS(XS_utf8_decode);
XS(XS_utf8_native_to_unicode);
XS(XS_Internals_SvREADONLY);
XS(XS_Internals_SvREFCNT);
-XS(XS_Internals_hv_clear_placeholders);
+XS(XS_Internals_hv_clear_placehold);
void
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("utf8::valid", XS_utf8_valid, file);
newXS("utf8::encode", XS_utf8_encode, file);
newXS("utf8::decode", XS_utf8_decode, file);
newXSproto("Internals::SvREADONLY",XS_Internals_SvREADONLY, file, "\\[$%@];$");
newXSproto("Internals::SvREFCNT",XS_Internals_SvREFCNT, file, "\\[$%@];$");
newXSproto("Internals::hv_clear_placeholders",
- XS_Internals_hv_clear_placeholders, file, "\\%");
+ XS_Internals_hv_clear_placehold, file, "\\%");
}
"%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<use Foo v1.2.3> 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<use Foo 1.002_003> 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<use Foo v1.2.3> */
- if (SvNOK(req) && SvPOK(req)) {
- NV n = SvNV(req);
- req = sv_newmortal();
- sv_setnv(req, n);
- }
+ if ( !sv_derived_from(sv, "version"))
+ sv = new_version(sv);
+
+ if ( !sv_derived_from(req, "version"))
+ req = new_version(req);
- if (SvNV(req) > SvNV(sv))
+ if ( vcmp( SvRV(req), SvRV(sv) ) > 0 )
Perl_croak(aTHX_ "%s version %s required--this is only version %s",
- HvNAME(pkg), SvPV_nolen(req), SvPV_nolen(sv));
+ HvNAME(pkg), SvPV(req,PL_na), SvPV(sv,PL_na));
}
-finish:
ST(0) = sv;
XSRETURN(1);
}
+XS(XS_version_new)
+{
+ dXSARGS;
+ if (items != 2)
+ Perl_croak(aTHX_ "Usage: version::new(class, version)");
+ SP -= items;
+ {
+/* char * class = (char *)SvPV_nolen(ST(0)); */
+ SV * version = ST(1);
+
+{
+ PUSHs(new_version(version));
+}
+
+ 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(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(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(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(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_utf8_valid)
{
dXSARGS;
/* 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_placeholders)
+XS(XS_Internals_hv_clear_placehold)
{
dXSARGS;
HV *hv = (HV *) SvRV(ST(0));
/* I don't care how many parameters were passed in, but I want to avoid
the unused variable warning. */
- items = HvPLACEHOLDERS(hv);
+ items = (I32)HvPLACEHOLDERS(hv);
if (items) {
HE *entry;
I32 riter = HvRITER(hv);
HE *eiter = HvEITER(hv);
hv_iterinit(hv);
- while (items
- && (entry
- = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))) {
+ /* 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) {
projects / p5sagit/p5-mst-13.2.git / blobdiff