Changeset 6094

Show
Ignore:
Timestamp:
08/06/05 23:00:58 (3 years ago)
Author:
Stevan
Message:

Perl6::MetaModel? - (p5)
* $?CLASS now returns the ::Class object
* all methods and attributes are now associated with the ::Class object

instead of just the class name

* improved the name of ::get_obj_id to ::get_P6opaque_instance_id so that

no one will try to use it :P

* also added ::get_P6opaque_instance_class to peek into the class slot

(needed this for submethods)

Location:
perl5/Perl6-MetaModel
Files:
7 modified

Legend:

Unmodified
Added
Removed

  • perl5/Perl6-MetaModel/lib/Perl6/Class.pm

    r6093 r6094  
    4545 
    4646sub _apply_class_to_environment { 
    47     my ($self) = @_; 
     47    my ($self) = @_;     
    4848    my ($name) = $self->{instance_data}->{name}; 
    4949    # create the package ... 
    … …  
    5353        \$$name\:\:META = undef; 
    5454        1; 
    55     |; 
     55    |;     
    5656    eval $code || confess "Could not initialize class '$name'";    
     57    _create_metaclass($self);     
     58    _build_class($self);      
    5759    # alias the full name ... 
    5860    eval {   
    … …  
    6163    }; 
    6264    confess "Could not create full name " . $self->{instance_data}->{identifier} . " : $@" if $@;    
    63     _build_class($self);  
    6465} 
    6566 
    … …  
    9394} 
    9495 
    95 sub _build_class { 
     96sub _create_metaclass { 
    9697    my ($self) = @_; 
    97      
    9898    my ($name, $version, $authority) = ($self->{instance_data}->{name}, $self->{instance_data}->{version}, $self->{instance_data}->{authority});     
    9999 
    … …  
    129129        $self->{instance_data}->{meta} = $meta;  
    130130    }; 
    131     confess "Could not initialize the metaclass for $name : $@" if $@;  
     131    confess "Could not initialize the metaclass for $name : $@" if $@;      
     132} 
     133 
     134sub _build_class { 
     135    my ($self) = @_; 
     136 
     137    my $meta = $self->{instance_data}->{meta}; 
    132138 
    133139    my $superclasses = $self->{instance_data}->{params}->{is}; 
    … …  
    136142    if (my $instance = $self->{instance_data}->{params}->{instance}) { 
    137143 
    138         ::dispatch($meta, 'add_method', ('BUILD' => Perl6::Method->create_submethod($name => $instance->{BUILD}))) 
     144        ::dispatch($meta, 'add_method', ('BUILD' => Perl6::Method->create_submethod($self => $instance->{BUILD}))) 
    139145            if exists $instance->{BUILD};             
    140         ::dispatch($meta, 'add_method', ('DESTROY' => Perl6::Method->create_submethod($name => $instance->{DESTROY}))) 
     146        ::dispatch($meta, 'add_method', ('DESTROY' => Perl6::Method->create_submethod($self => $instance->{DESTROY}))) 
    141147            if exists $instance->{DESTROY}; 
    142148             
    … …  
    144150            foreach (keys %{$instance->{methods}}) { 
    145151                if (/^_/) { 
    146                     ::dispatch($meta, 'add_method', ($_ => Perl6::Method->create_private_method($name, $instance->{methods}->{$_}))); 
     152                    ::dispatch($meta, 'add_method', ($_ => Perl6::Method->create_private_method($self, $instance->{methods}->{$_}))); 
    147153                } 
    148154                else { 
    149                     ::dispatch($meta, 'add_method', ($_ => Perl6::Method->create_instance_method($name, $instance->{methods}->{$_}))); 
     155                    ::dispatch($meta, 'add_method', ($_ => Perl6::Method->create_instance_method($self, $instance->{methods}->{$_}))); 
    150156                } 
    151157            } 
    152158        } 
    153159        if (exists $instance->{submethods}) { 
    154             ::dispatch($meta, 'add_method', ($_ => Perl6::Method->create_submethod($name, $instance->{submethods}->{$_}))) 
     160            ::dispatch($meta, 'add_method', ($_ => Perl6::Method->create_submethod($self, $instance->{submethods}->{$_}))) 
    155161                foreach keys %{$instance->{submethods}}; 
    156162        }         
    … …  
    162168                } 
    163169                ::dispatch($meta, 'add_attribute', ( 
    164                     $attr => Perl6::Instance::Attribute->new($name => $attr, $props) 
     170                    $attr => Perl6::Instance::Attribute->new($self => $attr, $props) 
    165171                ));               
    166172            } 
    … …  
    176182                } 
    177183                ::dispatch($meta, 'add_attribute', ( 
    178                     $attr => Perl6::Class::Attribute->new($name => $attr, $props) 
     184                    $attr => Perl6::Class::Attribute->new($self => $attr, $props) 
    179185                )); 
    180186            }             
    … …  
    184190            foreach my $label (keys %{$class->{methods}}) { 
    185191                if ($label =~ /^_/) { 
    186                     ::dispatch($meta, 'add_method', ($label => Perl6::Method->create_private_method($name, $class->{methods}->{$label}))); 
     192                    ::dispatch($meta, 'add_method', ($label => Perl6::Method->create_private_method($self, $class->{methods}->{$label}))); 
    187193                } 
    188194                else { 
    189                     ::dispatch($meta, 'add_method', ($label => Perl6::Method->create_class_method($name, $class->{methods}->{$label}))); 
     195                    ::dispatch($meta, 'add_method', ($label => Perl6::Method->create_class_method($self, $class->{methods}->{$label}))); 
    190196                } 
    191197            } 

  • perl5/Perl6-MetaModel/lib/Perl6/MetaClass.pm

    r6092 r6094  
    77use Scalar::Util 'blessed'; 
    88use Carp 'confess'; 
    9  
    10 use Perl6::MetaClass::Dispatcher; 
    119 
    1210sub new { 
    … …  
    240238        'dispatcher' => Perl6::Method->create_instance_method('Perl6::MetaClass' => sub {    
    241239            my ($self, $order) = @_; 
     240            require Perl6::MetaClass::Dispatcher; 
    242241            Perl6::MetaClass::Dispatcher->new($self, $order); 
    243242        }) 

  • perl5/Perl6-MetaModel/lib/Perl6/MetaModel.pm

    r6093 r6094  
    7676# this means that our code should not try to peak into it 
    7777# and so we should then use some kind of outside mechanism  
    78 # to get at the object id 
    79 sub ::get_obj_id { (shift)->{id} } 
     78# to get at the object id and class  
     79sub ::get_P6opaque_instance_id    { (shift)->{id}    } 
     80sub ::get_P6opaque_instance_class { (shift)->{class} } 
    8081 
    8182sub ::meta { 

  • perl5/Perl6-MetaModel/lib/Perl6/Method.pm

    r6089 r6094  
    3737        $method = bless sub {  
    3838            unless (ref($_[0]) eq 'FORCE') { 
    39                 return ::next_METHOD() if $_[0]->[0]->{class} ne $associated_with;  
     39                return ::next_METHOD()  
     40                    ## XXX 
     41                    # this should not be accessing either the  
     42                    # instance_data->name slot, but we cannot 
     43                    # do anything about it for now ... 
     44                    if ::get_P6opaque_instance_class($_[0]->[0]) ne $associated_with->{instance_data}->{name};  
    4045            } 
    4146            $old->($_[1]);  

  • perl5/Perl6-MetaModel/lib/Perl6/Object.pm

    r6091 r6094  
    9999            'isa' => $isa, 
    100100            'can' => $can,  
    101             'id' => sub { ::get_obj_id(shift) } 
     101            'id' => sub { ::get_P6opaque_instance_id(shift) } 
    102102        } 
    103103    } 

  • perl5/Perl6-MetaModel/t/03_DESTROY.t

    r5790 r6094  
    2828        instance => { 
    2929            DESTROY => sub { 
    30                 push @classes_destroyed, (CLASS . '::DESTROY'); 
     30                push @classes_destroyed, ('Foo::DESTROY'); 
    3131            } 
    3232        } 
    … …  
    3939            submethods => { 
    4040                DESTROY => sub { 
    41                     push @classes_destroyed, (CLASS . '::DESTROY'); 
     41                    push @classes_destroyed, ('Bar::DESTROY'); 
    4242                } 
    4343            } 
    … …  
    4949        instance => { 
    5050            DESTROY => sub { 
    51                 push @classes_destroyed, (CLASS . '::DESTROY'); 
     51                push @classes_destroyed, ('Foo::Bar::DESTROY'); 
    5252            } 
    5353        } 
    … …  
    7777        instance => { 
    7878            DESTROY => sub { 
    79                 push @classes_destroyed, (CLASS . '::DESTROY'); 
     79                push @classes_destroyed, ('A::DESTROY'); 
    8080            } 
    8181        } 
    … …  
    8686        instance => { 
    8787            DESTROY => sub { 
    88                 push @classes_destroyed, (CLASS . '::DESTROY'); 
     88                push @classes_destroyed, ('B::DESTROY'); 
    8989            } 
    9090        } 
    … …  
    9595        instance => { 
    9696            DESTROY => sub { 
    97                 push @classes_destroyed, (CLASS . '::DESTROY'); 
     97                push @classes_destroyed, ('C::DESTROY'); 
    9898            } 
    9999        } 
    … …  
    104104        instance => { 
    105105            DESTROY => sub { 
    106                 push @classes_destroyed, (CLASS . '::DESTROY'); 
     106                push @classes_destroyed, ('D::DESTROY'); 
    107107            } 
    108108        } 

  • perl5/Perl6-MetaModel/t/15_CLASS.t

    r5790 r6094  
    4040        $val = Foo->this_will_not_die(); 
    4141    } '... CLASS can be called from a Class method'; 
    42     is($val, 'Foo', '... got the right value from CLASS too'); 
     42    isa_ok($val, 'Foo'); 
    4343} 
    4444 
    … …  
    5151        $val = $foo->bar(); 
    5252    } '... CLASS can be used to call Class methods'; 
    53     is($val, 'Foo', '... got the right value from CLASS too'); 
     53    isa_ok($val, 'Foo'); 
    5454} 
    5555 
    … …  
    5959        $val = $foo->foo(); 
    6060    } '... CLASS can be called from an instance method'; 
    61     is($val, 'Foo', '... got the right value from CLASS too'); 
     61    isa_ok($val, 'Foo'); 
    6262}