# we could just store a ref and it would
# Just Work, but oh well :\
no strict 'refs';
- no warnings 'uninitialized';
\%{$_[0]->{'package'} . '::'}
}
# ... these functions have to touch the symbol table itself,.. yuk
+sub add_package_symbol {
+ my ($self, $variable, $initial_value) = @_;
+
+ my ($name, $sigil, $type) = ref $variable eq 'HASH'
+ ? @{$variable}{qw[name sigil type]}
+ : $self->_deconstruct_variable_name($variable);
+
+ my $pkg = $self->{'package'};
+
+ no strict 'refs';
+ no warnings 'redefine', 'misc', 'prototype';
+ *{$pkg . '::' . $name} = ref $initial_value ? $initial_value : \$initial_value;
+}
+
sub remove_package_glob {
my ($self, $name) = @_;
- delete $self->namespace->{$name};
+ no strict 'refs';
+ delete ${$self->name . '::'}{$name};
+}
+
+# ... these functions deal with stuff on the namespace level
+
+sub has_package_symbol {
+ my ( $self, $variable ) = @_;
+
+ my ( $name, $sigil, $type )
+ = ref $variable eq 'HASH'
+ ? @{$variable}{qw[name sigil type]}
+ : $self->_deconstruct_variable_name($variable);
+
+ my $namespace = $self->namespace;
+
+ return 0 unless exists $namespace->{$name};
+
+ my $entry_ref = \$namespace->{$name};
+ if ( reftype($entry_ref) eq 'GLOB' ) {
+ if ( $type eq 'SCALAR' ) {
+ return defined( ${ *{$entry_ref}{SCALAR} } );
+ }
+ else {
+ 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, $sigil, $type) = ref $variable eq 'HASH'
+ ? @{$variable}{qw[name sigil type]}
+ : $self->_deconstruct_variable_name($variable);
+
+ my $namespace = $self->namespace;
+
+ # FIXME
+ $self->add_package_symbol($variable)
+ 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;
+ }
+ }
}
sub remove_package_symbol {
-
#include "mop.h"
static void
-mop_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) {
-
-
- if(SvROK(variable) && SvTYPE(SvRV(variable)) == SVt_PVHV){
- /* e.g. variable = { type => "SCALAR", name => "foo" } */
- HV* const hv = (HV*)SvRV(variable);
- SV** svp;
- STRLEN len;
- const char* pv;
-
- svp = hv_fetchs(hv, "name", FALSE);
- if(!(svp && SvOK(*svp))){
- croak("You must pass a variable name");
- }
- *var_name = SvPV_const(*svp, len);
- *var_name_len = len;
- if(len < 1){
- croak("You must pass a variable name");
- }
-
- svp = hv_fetchs(hv, "type", FALSE);
- if(!(svp && SvOK(*svp))) {
- croak("You must pass a variable type");
- }
- pv = SvPV_nolen_const(*svp);
- if(strEQ(pv, "SCALAR")){
- *type = SVt_PV; /* for all the type of scalars */
- }
- else if(strEQ(pv, "ARRAY")){
- *type = SVt_PVAV;
- }
- else if(strEQ(pv, "HASH")){
- *type = SVt_PVHV;
- }
- else if(strEQ(pv, "CODE")){
- *type = SVt_PVCV;
- }
- else if(strEQ(pv, "GLOB")){
- *type = SVt_PVGV;
- }
- else if(strEQ(pv, "IO")){
- *type = SVt_PVIO;
- }
- else{
- croak("I do not recognize that type '%s'", pv);
- }
- *type_name = pv;
- }
- else {
- 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]);
- }
- }
-}
-
-static GV*
-mop_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 = mop_call0(aTHX_ self, mop_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 = mop_call0(aTHX_ self, KEY_FOR(name));
-
- if(!SvOK(package_name)){
- croak("name() did not return a defined value");
- }
-
- 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);
-}
-
-static SV*
-mop_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;
-}
-
-
-static void
mop_update_method_map(pTHX_ SV *const self, SV *const class_name, HV *const stash, HV *const map)
{
const char *const class_name_pv = HvNAME(stash); /* must be HvNAME(stash), not SvPV_nolen_const(class_name) */
BOOT:
INSTALL_SIMPLE_READER_WITH_KEY(Package, name, package);
-
-
-SV*
-add_package_symbol(SV* self, SV* variable, SV* ref = &PL_sv_undef)
-PREINIT:
- svtype type;
- const char* type_name;
- const char* var_name;
- STRLEN var_name_len;
- GV* gv;
-CODE:
- mop_deconstruct_variable_name(aTHX_ variable, &var_name, &var_name_len, &type, &type_name);
- gv = mop_get_gv(aTHX_ self, type, var_name, var_name_len, GV_ADDMULTI);
-
- if(SvOK(ref)){ /* add_package_symbol with a value */
- if(type == SVt_PV){
- if(!SvROK(ref)){
- ref = newRV_noinc(newSVsv(ref));
- sv_2mortal(ref);
- }
- }
- else if(!(SvROK(ref) && SvTYPE(SvRV(ref)) == type)){
- croak("You must pass a reference of %s for the value of %s", type_name, GvNAME(CvGV(cv)));
- }
-
- if(type == SVt_PVCV && GvCV(gv)){
- /* XXX: clear it before redefinition */
- SvREFCNT_dec(GvCV(gv));
- GvCV(gv) = NULL;
- }
- sv_setsv_mg((SV*)gv, ref); /* magical assignment into type glob (*glob = $ref) */
-
- if(type == SVt_PVCV){ /* name a subroutine */
- CV* const subr = (CV*)SvRV(ref);
- if(CvANON(subr)
- && CvGV(subr)
- && isGV(CvGV(subr))
- && strEQ(GvNAME(CvGV(subr)), "__ANON__")){
-
- /* NOTE:
- A gv "has-a" cv, but a cv refers to a gv as a (pseudo) weak ref.
- so we can replace CvGV with no SvREFCNT_inc/dec.
- */
- CvGV(subr) = gv;
- CvANON_off(subr);
- }
- }
- RETVAL = ref;
- SvREFCNT_inc_simple_void_NN(ref);
- }
- else{
- SV* const sv = mop_gv_elem(aTHX_ gv, type, GV_ADDMULTI);
- RETVAL = (sv && GIMME_V != G_VOID) ? newRV_inc(sv) : &PL_sv_undef;
- }
-OUTPUT:
- RETVAL
-
-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:
- mop_deconstruct_variable_name(aTHX_ variable, &var_name, &var_name_len, &type, &type_name);
- gv = mop_get_gv(aTHX_ self, type, var_name, var_name_len, 0);
- if(type == SVt_PV){
- /* In SCALAR, for backword compatibility,
- defined(${*gv{SCALAR}}) instead of defined(*gv{SCALAR}) */
- SV* const sv = mop_gv_elem(aTHX_ gv, type, FALSE);
- RETVAL = (sv && SvOK(sv)) ? TRUE : FALSE;
- }
- else{
- /* Otherwise, defined(*gv{TYPE}) */
- RETVAL = mop_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:
- if(items > 2){ /* parse options */
- I32 i;
- if((items % 2) != 0){
- croak("Odd number of arguments for get_package_symbol()");
- }
- for(i = 2; i < items; i += 2){
- SV* const opt = ST(i);
- SV* const val = ST(i+1);
- if(strEQ(SvPV_nolen_const(opt), "create")){
- if(SvTRUE(val)){
- flags |= GV_ADDMULTI;
- }
- else{
- flags &= ~GV_ADDMULTI;
- }
- }
- else{
- warn("Unknown option \"%"SVf"\" for get_package_symbol()", opt);
- }
- }
- }
- mop_deconstruct_variable_name(aTHX_ variable, &var_name, &var_name_len, &type, &type_name);
- gv = mop_get_gv(aTHX_ self, type, var_name, var_name_len, flags);
- sv = mop_gv_elem(aTHX_ gv, type, FALSE);
-
- RETVAL = sv ? newRV_inc(sv) : &PL_sv_undef;
-OUTPUT:
- RETVAL
projects / gitmo/Class-MOP.git / commitdiff