From: gfx Date: Sat, 28 Nov 2009 08:19:45 +0000 (+0900) Subject: Port (get|has)_package_symbol from Class::MOP X-Git-Tag: 0.40_09~21 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=f18345f1ff14d11b71695cde4b67638ae942af8c;p=gitmo%2FMouse.git Port (get|has)_package_symbol from Class::MOP --- diff --git a/lib/Mouse/PurePerl.pm b/lib/Mouse/PurePerl.pm index f51b4c2..383c0c8 100644 --- a/lib/Mouse/PurePerl.pm +++ b/lib/Mouse/PurePerl.pm @@ -199,6 +199,77 @@ sub add_method { return; } +my %SIGIL_MAP = ( + '$' => 'SCALAR', + '@' => 'ARRAY', + '%' => 'HASH', + '&' => 'CODE', + '*' => 'GLOB', +); + +sub _deconstruct_variable_name { + my($self, $variable) = @_; + + (defined $variable) + || $self->throw_error("You must pass a variable name"); + + my $sigil = substr($variable, 0, 1, ''); + + (defined $sigil) + || $self->throw_error("The variable name must include a sigil"); + + (exists $SIGIL_MAP{$sigil}) + || $self->throw_error("I do not recognize that sigil '$sigil'"); + + return ($variable, $SIGIL_MAP{$sigil}); +} + +sub has_package_symbol { + my($self, $variable) = @_; + + my($name, $type) = $self->_deconstruct_variable_name($variable); + + my $namespace = $self->namespace; + + return 0 unless exists $namespace->{$name}; + + my $entry_ref = \$namespace->{$name}; + if ( ref($entry_ref) eq 'GLOB' ) { + return defined( *{$entry_ref}{$type} ); + } + else { + # a symbol table entry can be -1 (stub), string (stub with prototype), + # or reference (constant) + return $type eq 'CODE'; + } +} + +sub get_package_symbol { + my ($self, $variable) = @_; + + my($name, $type) = $self->_deconstruct_variable_name($variable); + + my $namespace = $self->namespace; + + return undef + unless exists $namespace->{$name}; + + my $entry_ref = \$namespace->{$name}; + + if ( ref($entry_ref) eq 'GLOB' ) { + return *{$entry_ref}{$type}; + } + else { + if ( $type eq 'CODE' ) { + no strict 'refs'; + return \&{ $self->name . '::' . $name }; + } + else { + return undef; + } + } +} + package Mouse::Meta::Class; diff --git a/xs-src/Mouse.xs b/xs-src/Mouse.xs index 8cab310..41ce1d1 100644 --- a/xs-src/Mouse.xs +++ b/xs-src/Mouse.xs @@ -335,6 +335,122 @@ mouse_initialize_metaclass(pTHX_ SV* const klass) { return meta; } + +/* copied from Class-MOP/topic/symbol-manipluator */ +static GV* +mouse_get_gv(pTHX_ SV* const self, svtype const type, const char* const var_name, I32 const var_name_len, I32 const flags){ + SV* package_name; + STRLEN len; + const char* pv; + + if(!flags){ + SV* const ns = mcall0(self, mouse_namespace); + GV** gvp; + if(!(SvROK(ns) && SvTYPE(SvRV(ns)) == SVt_PVHV)){ + croak("namespace() did not return a hash reference"); + } + gvp = (GV**)hv_fetch((HV*)SvRV(ns), var_name, var_name_len, FALSE); + if(gvp && isGV_with_GP(*gvp)){ + return *gvp; + } + } + + package_name = get_slot(self, mouse_package); + + if(!(package_name && SvOK(package_name))){ + croak("No package name defined"); + } + + pv = SvPV_const(package_name, len); + + return gv_fetchpvn_flags(Perl_form(aTHX_ "%s::%s", pv, var_name), (len + var_name_len + 2), flags, type); +} + +/* copied from Class-MOP/topic/symbol-manipluator */ +static SV* +mouse_gv_elem(pTHX_ GV* const gv, svtype const type, I32 const add){ + SV* sv; + + if(!gv){ + return NULL; + } + + assert(isGV_with_GP(gv)); + + switch(type){ + case SVt_PVAV: + sv = (SV*)(add ? GvAVn(gv) : GvAV(gv)); + break; + case SVt_PVHV: + sv = (SV*)(add ? GvHVn(gv) : GvHV(gv)); + break; + case SVt_PVCV: + sv = (SV*)GvCV(gv); + break; + case SVt_PVIO: + sv = (SV*)(add ? GvIOn(gv) : GvIO(gv)); + break; + case SVt_PVGV: + sv = (SV*)gv; + break; + default: /* SCALAR */ + sv = add ? GvSVn(gv) : GvSV(gv); + break; + } + + return sv; +} + +/* copied from Class-MOP/topic/symbol-manipluator */ +static void +mouse_deconstruct_variable_name(pTHX_ SV* const variable, + const char** const var_name, STRLEN* const var_name_len, + svtype* const type, + const char** const type_name) { + + STRLEN len; + const char* pv; + + /* e.g. variable = '$foo' */ + + if(!SvOK(variable)) { + croak("You must pass a variable name"); + } + pv = SvPV_const(variable, len); + if(len < 2){ + croak("You must pass a variable name including a sigil"); + } + + *var_name = pv + 1; + *var_name_len = len - 1; + + switch(pv[0]){ + case '$': + *type = SVt_PV; /* for all the types of scalars */ + *type_name = "SCALAR"; + break; + case '@': + *type = SVt_PVAV; + *type_name = "ARRAY"; + break; + case '%': + *type = SVt_PVHV; + *type_name = "HASH"; + break; + case '&': + *type = SVt_PVCV; + *type_name = "CODE"; + break; + case '*': + *type = SVt_PVGV; + *type_name = "GLOB"; + break; + default: + croak("I do not recognize that sigil '%c'", pv[0]); + } +} + + MODULE = Mouse PACKAGE = Mouse PROTOTYPES: DISABLE @@ -431,6 +547,41 @@ CODE: } } +bool +has_package_symbol(SV* self, SV* variable) +PREINIT: + svtype type; + const char* type_name; + const char* var_name; + STRLEN var_name_len; + GV* gv; +CODE: + mouse_deconstruct_variable_name(aTHX_ variable, &var_name, &var_name_len, &type, &type_name); + gv = mouse_get_gv(aTHX_ self, type, var_name, var_name_len, 0); + RETVAL = mouse_gv_elem(aTHX_ gv, type, FALSE) ? TRUE : FALSE; +OUTPUT: + RETVAL + +SV* +get_package_symbol(SV* self, SV* variable) +PREINIT: + svtype type; + const char* type_name; + const char* var_name; + STRLEN var_name_len; + I32 flags = 0; + GV* gv; + SV* sv; +CODE: + mouse_deconstruct_variable_name(aTHX_ variable, &var_name, &var_name_len, &type, &type_name); + gv = mouse_get_gv(aTHX_ self, type, var_name, var_name_len, flags); + sv = mouse_gv_elem(aTHX_ gv, type, FALSE); + + RETVAL = sv ? newRV_inc(sv) : &PL_sv_undef; +OUTPUT: + RETVAL + + MODULE = Mouse PACKAGE = Mouse::Meta::Class BOOT: