From: gfx <gfuji@cpan.org>
Date: Fri, 4 Sep 2009 07:31:07 +0000 (+0900)
Subject: Retrieve topic/symbol-manipulator
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=6f5f0cd1a577891dbc153576ca1e9f039f41577f;p=gitmo%2FClass-MOP.git

Retrieve topic/symbol-manipulator

Revert "Revert "Merge branch 'master' into topic/symbol-manipulator""

This reverts commit 86e1c8d8dc9cc1fb9e927f5bcd283b6b672e8b9f.
---

diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm
index c2679a7..caa95b6 100644
--- a/lib/Class/MOP/Class.pm
+++ b/lib/Class/MOP/Class.pm
@@ -251,13 +251,19 @@ sub _check_metaclass_compatibility {
         my $current_meta = Class::MOP::get_metaclass_by_name($name);
         return if $current_meta ne $self;
 
+        if(my $isa_ref = $self->get_package_symbol('@ISA')){
+            @{$isa_ref} = ();
+        }
+
+        %{ $self->namespace } = ();
+
         my ($serial_id) = ($name =~ /^$ANON_CLASS_PREFIX(\d+)/o);
-        no strict 'refs';
-        @{$name . '::ISA'} = ();
-        %{$name . '::'}    = ();
-        delete ${$ANON_CLASS_PREFIX}{$serial_id . '::'};
 
         Class::MOP::remove_metaclass_by_name($name);
+
+        no strict 'refs';
+        delete ${$ANON_CLASS_PREFIX}{$serial_id . '::'};
+        return;
     }
 
 }
@@ -473,10 +479,9 @@ sub rebless_instance_away {
 
 sub superclasses {
     my $self     = shift;
-    my $var_spec = { sigil => '@', type => 'ARRAY', name => 'ISA' };
     if (@_) {
         my @supers = @_;
-        @{$self->get_package_symbol($var_spec)} = @supers;
+        @{$self->get_package_symbol('@ISA', create => 1)} = @supers;
 
         # NOTE:
         # on 5.8 and below, we need to call
@@ -495,7 +500,7 @@ sub superclasses {
         $self->_check_metaclass_compatibility();
         $self->_superclasses_updated();
     }
-    @{$self->get_package_symbol($var_spec)};
+    @{$self->get_package_symbol('@ISA', create => 1)};
 }
 
 sub _superclasses_updated {
diff --git a/lib/Class/MOP/Class/Immutable/Trait.pm b/lib/Class/MOP/Class/Immutable/Trait.pm
index a21d3a0..29c79e8 100644
--- a/lib/Class/MOP/Class/Immutable/Trait.pm
+++ b/lib/Class/MOP/Class/Immutable/Trait.pm
@@ -39,6 +39,7 @@ sub remove_method         { _immutable_cannot_call() }
 sub add_attribute         { _immutable_cannot_call() }
 sub remove_attribute      { _immutable_cannot_call() }
 sub remove_package_symbol { _immutable_cannot_call() }
+sub add_package_symbol    { _immutable_cannot_call() }
 
 sub class_precedence_list {
     my $orig = shift;
@@ -83,15 +84,6 @@ sub get_method_map {
     $self->{__immutable}{get_method_map} ||= $self->$orig;
 }
 
-sub add_package_symbol {
-    my $orig = shift;
-    my $self = shift;
-    confess "Cannot add package symbols to an immutable metaclass"
-        unless ( caller(3) )[3] eq 'Class::MOP::Package::get_package_symbol';
-
-    $self->$orig(@_);
-}
-
 1;
 
 __END__
diff --git a/lib/Class/MOP/Module.pm b/lib/Class/MOP/Module.pm
index e778812..ae89002 100644
--- a/lib/Class/MOP/Module.pm
+++ b/lib/Class/MOP/Module.pm
@@ -33,12 +33,12 @@ sub _new {
 
 sub version {  
     my $self = shift;
-    ${$self->get_package_symbol({ sigil => '$', type => 'SCALAR', name => 'VERSION' })};
+    ${$self->get_package_symbol('$VERSION', create => 1)};
 }
 
 sub authority {  
     my $self = shift;
-    ${$self->get_package_symbol({ sigil => '$', type => 'SCALAR', name => 'AUTHORITY' })};
+    ${$self->get_package_symbol('$AUTHORITY', create => 1)};
 }
 
 sub identifier {
@@ -61,10 +61,8 @@ sub _instantiate_module {
     Class::MOP::_is_valid_class_name($package_name)
         || confess "creation of $package_name failed: invalid package name";
 
-    no strict 'refs';
-    scalar %{ $package_name . '::' };    # touch the stash
-    ${ $package_name . '::VERSION' }   = $version   if defined $version;
-    ${ $package_name . '::AUTHORITY' } = $authority if defined $authority;
+    ${ $self->get_package_symbol('$VERSION',   create => 1) } = $version;
+    ${ $self->get_package_symbol('$AUTHORITY', create => 1) } = $authority;
 
     return;
 }
diff --git a/lib/Class/MOP/Package.pm b/lib/Class/MOP/Package.pm
index 92463aa..f2c8e44 100644
--- a/lib/Class/MOP/Package.pm
+++ b/lib/Class/MOP/Package.pm
@@ -100,6 +100,7 @@ sub namespace {
     # we could just store a ref and it would
     # Just Work, but oh well :\    
     no strict 'refs';    
+    no warnings 'uninitialized';
     \%{$_[0]->{'package'} . '::'} 
 }
 
@@ -140,84 +141,9 @@ sub _method_map              { $_[0]->{'methods'}                     }
 
 # ... 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) = @_;
-    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;
-        }
-    }
+    delete $self->namespace->{$name};
 }
 
 sub remove_package_symbol {
diff --git a/mop.h b/mop.h
index 288c8ad..1b1960b 100644
--- a/mop.h
+++ b/mop.h
@@ -49,6 +49,7 @@ XS(mop_xs_simple_reader);
 extern SV *mop_method_metaclass;
 extern SV *mop_associated_metaclass;
 extern SV *mop_wrap;
+extern SV *mop_namespace;
 
 UV mop_check_package_cache_flag(pTHX_ HV *stash);
 int mop_get_code_info (SV *coderef, char **pkg, char **name);
diff --git a/xs/MOP.xs b/xs/MOP.xs
index 959df7a..d074ade 100644
--- a/xs/MOP.xs
+++ b/xs/MOP.xs
@@ -3,6 +3,7 @@
 SV *mop_method_metaclass;
 SV *mop_associated_metaclass;
 SV *mop_wrap;
+SV *mop_namespace;
 
 static bool
 find_method (const char *key, STRLEN keylen, SV *val, void *ud)
@@ -29,6 +30,7 @@ BOOT:
     mop_method_metaclass     = newSVpvs("method_metaclass");
     mop_wrap                 = newSVpvs("wrap");
     mop_associated_metaclass = newSVpvs("associated_metaclass");
+    mop_namespace            = newSVpvs("namespace");
 
     MOP_CALL_BOOT (boot_Class__MOP__Package);
     MOP_CALL_BOOT (boot_Class__MOP__Attribute);
diff --git a/xs/Package.xs b/xs/Package.xs
index 362c407..2ab8c79 100644
--- a/xs/Package.xs
+++ b/xs/Package.xs
@@ -1,6 +1,165 @@
+
 #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) */
@@ -148,3 +307,123 @@ get_method_map(self)
 
 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