From: gfx Date: Mon, 26 Oct 2009 07:05:58 +0000 (+0900) Subject: Implement a class_type generator X-Git-Tag: 0.40_01~11 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=1d5ecd5f15a0f418bee471c00af2357ba63b99ba;p=gitmo%2FMouse.git Implement a class_type generator --- diff --git a/lib/Mouse/PurePerl.pm b/lib/Mouse/PurePerl.pm index 8644c93..f2802db 100644 --- a/lib/Mouse/PurePerl.pm +++ b/lib/Mouse/PurePerl.pm @@ -77,9 +77,23 @@ sub get_code_ref{ package Mouse::Util::TypeConstraints; +sub _generate_class_type_for{ + my($for_class, $name) = @_; + + my $predicate = sub{ Scalar::Util::blessd($_[0]) && $_[0]->isa($for_class) }; + + if(defined $name){ + no strict 'refs'; + *{ caller() . '::' . $name } = $predicate; + return; + } + + return $predicate; +} + + sub Any { 1 } sub Item { 1 } -sub Maybe { 1 } sub Bool { $_[0] ? $_[0] eq '1' : 1 } sub Undef { !defined($_[0]) } diff --git a/lib/Mouse/Util/TypeConstraints.pm b/lib/Mouse/Util/TypeConstraints.pm index be539b0..ef0751d 100644 --- a/lib/Mouse/Util/TypeConstraints.pm +++ b/lib/Mouse/Util/TypeConstraints.pm @@ -155,15 +155,16 @@ sub class_type { if ($conf && $conf->{class}) { # No, you're using this wrong warn "class_type() should be class_type(ClassName). Perhaps you're looking for subtype $name => as '$conf->{class}'?"; - _create_type 'type', $name => ( + _create_type 'subtype', $name => ( as => $conf->{class}, type => 'Class', ); } else { - _create_type 'type', $name => ( - optimized_as => sub { blessed($_[0]) && $_[0]->isa($name) }, + _create_type 'subtype', $name => ( + as => 'Object', + optimized_as => _generate_class_type_for($name), type => 'Class', ); @@ -173,7 +174,8 @@ sub class_type { sub role_type { my($name, $conf) = @_; my $role = ($conf && $conf->{role}) ? $conf->{role} : $name; - _create_type 'type', $name => ( + _create_type 'subtype', $name => ( + as => 'Object', optimized_as => sub { blessed($_[0]) && does_role($_[0], $role) }, type => 'Role', @@ -220,27 +222,12 @@ sub _find_or_create_regular_type{ return; } - my $check; - my $type; if($meta->isa('Mouse::Meta::Role')){ - $check = sub{ - return blessed($_[0]) && $_[0]->does($spec); - }; - $type = 'Role'; + return role_type($spec); } else{ - $check = sub{ - return blessed($_[0]) && $_[0]->isa($spec); - }; - $type = 'Class'; + return class_type($spec); } - - return $TYPE{$spec} = Mouse::Meta::TypeConstraint->new( - name => $spec, - optimized => $check, - - type => $type, - ); } $TYPE{ArrayRef}{constraint_generator} = sub { diff --git a/mouse.h b/mouse.h index fdc50f4..1267c9e 100644 --- a/mouse.h +++ b/mouse.h @@ -151,7 +151,8 @@ typedef enum mouse_tc{ /* type constraints */ -int mouse_tc_check(pTHX_ mouse_tc const tc, SV* sv); +int mouse_tc_check(pTHX_ SV* const tc, SV* const sv); +int mouse_builtin_tc_check(pTHX_ mouse_tc const tc, SV* const sv); int mouse_tc_Any (pTHX_ SV* const sv); int mouse_tc_Bool (pTHX_ SV* const sv); diff --git a/xs-src/Mouse.xs b/xs-src/Mouse.xs index c4ba5f1..44ccf84 100644 --- a/xs-src/Mouse.xs +++ b/xs-src/Mouse.xs @@ -10,6 +10,7 @@ PROTOTYPES: DISABLE BOOT: mouse_package = newSVpvs_share("package"); mouse_namespace = newSVpvs_share("namespace"); + MOUSE_CALL_BOOT(Mouse__Util__TypeConstraints); bool @@ -81,37 +82,6 @@ OUTPUT: RETVAL -MODULE = Mouse PACKAGE = Mouse::Util::TypeConstraints - -void -Item(SV* sv = &PL_sv_undef) -ALIAS: - Any = MOUSE_TC_ANY - Item = MOUSE_TC_ITEM - Undef = MOUSE_TC_UNDEF - Defined = MOUSE_TC_DEFINED - Bool = MOUSE_TC_BOOL - Value = MOUSE_TC_VALUE - Ref = MOUSE_TC_REF - Str = MOUSE_TC_STR - Num = MOUSE_TC_NUM - Int = MOUSE_TC_INT - ScalarRef = MOUSE_TC_SCALAR_REF - ArrayRef = MOUSE_TC_ARRAY_REF - HashRef = MOUSE_TC_HASH_REF - CodeRef = MOUSE_TC_CODE_REF - GlobRef = MOUSE_TC_GLOB_REF - FileHandle = MOUSE_TC_FILEHANDLE - RegexpRef = MOUSE_TC_REGEXP_REF - Object = MOUSE_TC_OBJECT - ClassName = MOUSE_TC_CLASS_NAME - RoleName = MOUSE_TC_ROLE_NAME -CODE: - SvGETMAGIC(sv); - ST(0) = boolSV( mouse_tc_check(aTHX_ ix, sv) ); - XSRETURN(1); - - MODULE = Mouse PACKAGE = Mouse::Meta::Module BOOT: diff --git a/xs-src/mouse_accessor.xs b/xs-src/mouse_accessor.xs index 54c2db6..e509843 100644 --- a/xs-src/mouse_accessor.xs +++ b/xs-src/mouse_accessor.xs @@ -135,7 +135,6 @@ static SV* mouse_apply_type_constraint(pTHX_ AV* const xa, SV* value, U16 const flags){ SV* const tc = MOUSE_xa_tc(xa); SV* tc_code; - int ok; if(flags & MOUSEf_ATTR_SHOULD_COERCE){ value = mcall1s(tc, "coerce", value); @@ -160,30 +159,7 @@ mouse_apply_type_constraint(pTHX_ AV* const xa, SV* value, U16 const flags){ tc_code = MOUSE_xa_tc_code(xa); } - if(SvIOK(tc_code)){ /* built-in type constraints */ - ok = mouse_tc_check(aTHX_ SvIVX(tc_code), value); - } - else { - dSP; - - ENTER; - SAVETMPS; - - PUSHMARK(SP); - XPUSHs(value); - PUTBACK; - - call_sv(tc_code, G_SCALAR); - - SPAGAIN; - ok = SvTRUEx(POPs); - PUTBACK; - - FREETMPS; - LEAVE; - } - - if(!ok){ + if(!mouse_tc_check(aTHX_ tc_code, value)){ mouse_throw_error(MOUSE_xa_attribute(xa), value, "Attribute (%"SVf") does not pass the type constraint because: %"SVf, mcall0s(MOUSE_xa_attribute(xa), "name"), diff --git a/xs-src/mouse_type_constraint.xs b/xs-src/mouse_type_constraint.xs index 2da5843..938a6d4 100644 --- a/xs-src/mouse_type_constraint.xs +++ b/xs-src/mouse_type_constraint.xs @@ -14,9 +14,37 @@ #define SvRXOK(sv) (SvROK(sv) && SvMAGICAL(SvRV(sv)) && mg_find(SvRV(sv), PERL_MAGIC_qr)) #endif +int +mouse_tc_check(pTHX_ SV* const tc_code, SV* const sv) { + if(SvIOK(tc_code)){ /* built-in type constraints */ + return mouse_builtin_tc_check(aTHX_ SvIVX(tc_code), sv); + } + else { + int ok; + dSP; + + ENTER; + SAVETMPS; + + PUSHMARK(SP); + XPUSHs(sv); + PUTBACK; + + call_sv(tc_code, G_SCALAR); + + SPAGAIN; + ok = SvTRUEx(POPs); + PUTBACK; + + FREETMPS; + LEAVE; + + return ok; + } +} int -mouse_tc_check(pTHX_ mouse_tc const tc, SV* const sv) { +mouse_builtin_tc_check(pTHX_ mouse_tc const tc, SV* const sv) { switch(tc){ case MOUSE_TC_ANY: return mouse_tc_Any(aTHX_ sv); case MOUSE_TC_ITEM: return mouse_tc_Any(aTHX_ sv); @@ -233,3 +261,234 @@ mouse_tc_Object(pTHX_ SV* const sv) { return SvROK(sv) && SvOBJECT(SvRV(sv)) && !SvRXOK(sv); } +/* + * This class_type generator is taken from Scalar::Util::Instance + */ + +#define MY_CXT_KEY "Mouse::Util::TypeConstraints::_guts" XS_VERSION +typedef struct sui_cxt{ + GV* universal_isa; +} my_cxt_t; +START_MY_CXT + +#define MG_klass_stash(mg) ((HV*)(mg)->mg_obj) +#define MG_klass_pv(mg) ((mg)->mg_ptr) +#define MG_klass_len(mg) ((mg)->mg_len) + +static MGVTBL mouse_util_type_constraints_vtbl; + +static const char* +canonicalize_package_name(const char* name){ + + /* "::Foo" -> "Foo" */ + if(name[0] == ':' && name[1] == ':'){ + name += 2; + } + + /* "main::main::main::Foo" -> "Foo" */ + while(strnEQ(name, "main::", sizeof("main::")-1)){ + name += sizeof("main::")-1; + } + + return name; +} + +static int +lookup_isa(pTHX_ HV* const instance_stash, const char* const klass_pv){ + AV* const linearized_isa = mro_get_linear_isa(instance_stash); + SV** svp = AvARRAY(linearized_isa); + SV** const end = svp + AvFILLp(linearized_isa) + 1; + + while(svp != end){ + assert(SvPVX(*svp)); + if(strEQ(klass_pv, canonicalize_package_name(SvPVX(*svp)))){ + return TRUE; + } + svp++; + } + return FALSE; +} + +static int +instance_isa(pTHX_ SV* const instance, const MAGIC* const mg){ + dMY_CXT; + HV* const instance_stash = SvSTASH(SvRV(instance)); + GV* const instance_isa = gv_fetchmeth_autoload(instance_stash, "isa", sizeof("isa")-1, 0); + + /* the instance has no own isa method */ + if(instance_isa == NULL || GvCV(instance_isa) == GvCV(MY_CXT.universal_isa)){ + return MG_klass_stash(mg) == instance_stash + || lookup_isa(aTHX_ instance_stash, MG_klass_pv(mg)); + } + /* the instance has its own isa method */ + else { + int retval; + dSP; + + ENTER; + SAVETMPS; + + PUSHMARK(SP); + EXTEND(SP, 2); + PUSHs(instance); + mPUSHp(MG_klass_pv(mg), MG_klass_len(mg)); + PUTBACK; + + call_sv((SV*)instance_isa, G_SCALAR); + + SPAGAIN; + + retval = SvTRUEx(POPs); + + PUTBACK; + + FREETMPS; + LEAVE; + + return retval; + } +} + +XS(XS_isa_check); /* -W */ +XS(XS_isa_check){ + dVAR; + dXSARGS; + SV* sv; + + assert(XSANY.any_ptr != NULL); + + if(items != 1){ + if(items < 1){ + croak("Not enough arguments for is-a predicate"); + } + else{ + croak("Too many arguments for is-a predicate"); + } + } + + sv = ST(0); + SvGETMAGIC(sv); + + ST(0) = boolSV( SvROK(sv) && SvOBJECT(SvRV(sv)) && instance_isa(aTHX_ sv, (MAGIC*)XSANY.any_ptr) ); + XSRETURN(1); +} + +XS(XS_isa_check_for_universal); /* -W */ +XS(XS_isa_check_for_universal){ + dVAR; + dXSARGS; + SV* sv; + PERL_UNUSED_VAR(cv); + + if(items != 1){ + if(items < 1){ + croak("Not enough arguments for is-a predicate"); + } + else{ + croak("Too many arguments for is-a predicate"); + } + } + + sv = ST(0); + SvGETMAGIC(sv); + + ST(0) = boolSV( SvROK(sv) && SvOBJECT(SvRV(sv)) ); + XSRETURN(1); +} + +static void +setup_my_cxt(pTHX_ pMY_CXT){ + MY_CXT.universal_isa = gv_fetchpvs("UNIVERSAL::isa", GV_ADD, SVt_PVCV); + SvREFCNT_inc_simple_void_NN(MY_CXT.universal_isa); +} + +MODULE = Mouse::Util::TypeConstraints PACKAGE = Mouse::Util::TypeConstraints + +PROTOTYPES: DISABLE + +BOOT: +{ + MY_CXT_INIT; + setup_my_cxt(aTHX_ aMY_CXT); +} + +#ifdef USE_ITHREADS + +void +CLONE(...) +CODE: +{ + MY_CXT_CLONE; + setup_my_cxt(aTHX_ aMY_CXT); + PERL_UNUSED_VAR(items); +} + +#endif /* !USE_ITHREADS */ + +void +_generate_class_type_for(SV* klass, const char* predicate_name = NULL) +PPCODE: +{ + STRLEN klass_len; + const char* klass_pv; + HV* stash; + CV* xsub; + + if(!SvOK(klass)){ + croak("You must define a class name for generate_for"); + } + klass_pv = SvPV_const(klass, klass_len); + klass_pv = canonicalize_package_name(klass_pv); + + if(strNE(klass_pv, "UNIVERSAL")){ + xsub = newXS(predicate_name, XS_isa_check, __FILE__); + + stash = gv_stashpvn(klass_pv, klass_len, GV_ADD); + + CvXSUBANY(xsub).any_ptr = sv_magicext( + (SV*)xsub, + (SV*)stash, /* mg_obj */ + PERL_MAGIC_ext, + &mouse_util_type_constraints_vtbl, + klass_pv, /* mg_ptr */ + klass_len /* mg_len */ + ); + } + else{ + xsub = newXS(predicate_name, XS_isa_check_for_universal, __FILE__); + } + + if(predicate_name == NULL){ /* anonymous predicate */ + XPUSHs( newRV_noinc((SV*)xsub) ); + } +} + +void +Item(SV* sv = &PL_sv_undef) +ALIAS: + Any = MOUSE_TC_ANY + Item = MOUSE_TC_ITEM + Undef = MOUSE_TC_UNDEF + Defined = MOUSE_TC_DEFINED + Bool = MOUSE_TC_BOOL + Value = MOUSE_TC_VALUE + Ref = MOUSE_TC_REF + Str = MOUSE_TC_STR + Num = MOUSE_TC_NUM + Int = MOUSE_TC_INT + ScalarRef = MOUSE_TC_SCALAR_REF + ArrayRef = MOUSE_TC_ARRAY_REF + HashRef = MOUSE_TC_HASH_REF + CodeRef = MOUSE_TC_CODE_REF + GlobRef = MOUSE_TC_GLOB_REF + FileHandle = MOUSE_TC_FILEHANDLE + RegexpRef = MOUSE_TC_REGEXP_REF + Object = MOUSE_TC_OBJECT + ClassName = MOUSE_TC_CLASS_NAME + RoleName = MOUSE_TC_ROLE_NAME +CODE: + SvGETMAGIC(sv); + ST(0) = boolSV( mouse_builtin_tc_check(aTHX_ ix, sv) ); + XSRETURN(1); + +