From: Stevan Little Date: Tue, 24 Jan 2006 23:24:07 +0000 (+0000) Subject: Class::MOP - closer X-Git-Tag: 0_02~23 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=bfe4d0fc35c0b24b568cf6a0b4620a0df2aed649;p=gitmo%2FClass-MOP.git Class::MOP - closer --- diff --git a/lib/Class/MOP.pm b/lib/Class/MOP.pm index fc33b54..cadef21 100644 --- a/lib/Class/MOP.pm +++ b/lib/Class/MOP.pm @@ -8,11 +8,11 @@ use Scalar::Util 'blessed'; our $VERSION = '0.01'; -my %METAS; -sub UNIVERSAL::meta { - my $class = blessed($_[0]) || $_[0]; - $METAS{$class} ||= Class::MOP::Class->initialize($class) -} +# my %METAS; +# sub UNIVERSAL::meta { +# my $class = blessed($_[0]) || $_[0]; +# $METAS{$class} ||= Class::MOP::Class->initialize($class) +# } 1; @@ -40,6 +40,25 @@ set of extensions to the Perl 5 object system. Every attempt has been made for these tools to keep to the spirit of the Perl 5 object system that we all know and love. +=head2 What is a Meta Object Protocol? + +A meta object protocol is an API to an object system. + +To be more specific, it is a set of abstractions of the components of +an object system (typically things like; classes, object, methods, +object attributes, etc.). These abstractions can then be used to both +inspect and manipulate the object system which they describe. + +It can be said that there are two MOPs for any object system; the +implicit MOP, and the explicit MOP. The implicit MOP handles things +like method dispatch or inheritance, which happen automatically as +part of how the object system works. The explicit MOP typically +handles the introspection/reflection features of the object system. +All object systems have implicit MOPs, without one, they would not +work. Explict MOPs however as less common, and depending on the +language can vary from restrictive (Reflection in Java or C#) to +wide open (CLOS is a perfect example). + =head2 Who is this module for? This module is specifically for anyone who has ever created or @@ -49,6 +68,36 @@ complex things with Perl 5 classes by removing such barriers as the need to hack the symbol tables, or understand the fine details of method dispatch. +=head2 What changes do I have to make to use this module? + +This module was designed to be as unintrusive as possible. So many of +it's features are accessible without B change to your existsing +code at all. It is meant to be a compliment to your existing code and +not an intrusion on your code base. + +The only feature which requires additions to your code are the +attribute handling and instance construction features. The only reason +for this is because Perl 5's object system does not actually have +these features built in. More information about this feature can be +found below. + +=head2 A Note about Performance? + +It is a common misconception that explict MOPs are performance drains. +But this is not a universal truth at all, it is an side-effect of +specific implementations. For instance, using Java reflection is much +slower because the JVM cannot take advantage of any compiler +optimizations, and the JVM has to deal with much more runtime type +information as well. Reflection in C# is marginally better as it was +designed into the language and runtime (the CLR). In contrast, CLOS +(the Common Lisp Object System) was built to support an explicit MOP, +and so performance is tuned for it. + +This library in particular does it's absolute best to avoid putting +B drain at all upon your code's performance, while still trying +to make sure it is fast as well (although only as a secondary +concern). + =head1 PROTOCOLS The protocol is divided into 3 main sub-protocols: @@ -178,24 +227,23 @@ This just provides a simple way to check if the Class implements a specific C<$method_name>. It will I however, attempt to check if the class inherits the method. -This will correctly ignore functions imported from other packages, -and will correctly handle functions defined outside of the package -that use a fully qualified name (C). It -will B handle anon functions stored in the package using symbol -tables, unless the anon function is first named using B. -For instance, this will not return true with C: - - *{$pkg . '::' . $name} = sub { ... }; +This will correctly handle functions defined outside of the package +that use a fully qualified name (C). -However, this will DWIM: +This will correctly handle functions renamed with B and +installed using the symbol tables. However, if you are naming the +subroutine outside of the package scope, you must use the fully +qualified name, including the package name, for C to +correctly identify it. - my $full_name = $pkg . '::' . $name; - my $sub = sub { ... }; - Sub::Name::subname($full_name, $sub); - *{$full_name} = $sub; +This will attempt to correctly ignore functions imported from other +packages using B. It breaks down if the function imported +is an C<__ANON__> sub (such as with C), which very well +may be a valid method being applied to the class. -B this code need not be so tedious, it is only this way to -illustrate my point more clearly. +In short, this method cannot always be trusted to determine if the +C<$method_name> is actually a method. However, it will DWIM about +90% of the time, so it's a small trade off IMO. =item B diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm index ae5be70..277a212 100644 --- a/lib/Class/MOP/Class.pm +++ b/lib/Class/MOP/Class.pm @@ -13,26 +13,37 @@ our $VERSION = '0.01'; # Creation -sub initialize { - my ($class, $package_name) = @_; - (defined $package_name) - || confess "You must pass a package name"; - bless \$package_name => $class; +{ + # Metaclasses are singletons, so we cache them here. + # there is no need to worry about destruction though + # because they should die only when the program dies. + # After all, do package definitions even get reaped? + my %METAS; + sub initialize { + my ($class, $package_name) = @_; + (defined $package_name && $package_name) + || confess "You must pass a package name"; + $METAS{$package_name} ||= bless \$package_name => blessed($class) || $class; + } } sub create { my ($class, $package_name, $package_version, %options) = @_; - (defined $package_name) + (defined $package_name && $package_name) || confess "You must pass a package name"; my $code = "package $package_name;"; $code .= "\$$package_name\:\:VERSION = '$package_version';" if defined $package_version; eval $code; confess "creation of $package_name failed : $@" if $@; - my $meta = $package_name->meta; + my $meta = $class->initialize($package_name); $meta->superclasses(@{$options{superclasses}}) if exists $options{superclasses}; - # ... rest to come later ... + if (exists $options{methods}) { + foreach my $method_name (keys %{$options{methods}}) { + $meta->add_method($method_name, $options{methods}->{$method_name}); + } + } return $meta; } @@ -60,10 +71,17 @@ sub superclasses { sub class_precedence_list { my $self = shift; + # NOTE: + # We need to check for ciruclar inheirtance here. + # This will do nothing if all is well, and blow + # up otherwise. Yes, it's an ugly hack, better + # suggestions are welcome. + { $self->name->isa('This is a test for circular inheritance') } + # ... and no back to our regularly scheduled program ( $self->name, map { - $_->meta->class_precedence_list() + $self->initialize($_)->class_precedence_list() } $self->superclasses() ); } @@ -82,17 +100,26 @@ sub add_method { *{$full_method_name} = subname $full_method_name => $method; } -sub has_method { - my ($self, $method_name, $method) = @_; - (defined $method_name && $method_name) - || confess "You must define a method name"; +{ + + ## private utility functions for has_method + my $_find_subroutine_package_name = sub { eval { svref_2object($_[0])->GV->STASH->NAME } }; + my $_find_subroutine_name = sub { eval { svref_2object($_[0])->GV->NAME } }; + + sub has_method { + my ($self, $method_name, $method) = @_; + (defined $method_name && $method_name) + || confess "You must define a method name"; - my $sub_name = ($self->name . '::' . $method_name); + my $sub_name = ($self->name . '::' . $method_name); - no strict 'refs'; - return 0 unless defined &{$sub_name}; - return 0 unless _find_subroutine_package(\&{$sub_name}) eq $self->name; - return 1; + no strict 'refs'; + return 0 if !defined(&{$sub_name}); + return 0 if $_find_subroutine_package_name->(\&{$sub_name}) ne $self->name && + $_find_subroutine_name->(\&{$sub_name}) ne '__ANON__'; + return 1; + } + } sub get_method { @@ -102,18 +129,8 @@ sub get_method { no strict 'refs'; return \&{$self->name . '::' . $method_name} - if $self->has_method($method_name); -} - -## Private Utility Methods - -# initially borrowed from Class::Trait 0.20 - Thanks Ovid :) -# later re-worked to support subs named with Sub::Name -sub _find_subroutine_package { - my $sub = shift; - my $package = eval { svref_2object($sub)->GV->STASH->NAME }; - confess "Could not determine calling package: $@" if $@; - return $package; + if $self->has_method($method_name); + return; # <--- make sure to return undef } 1; diff --git a/t/001_basic.t b/t/001_basic.t index ce622a8..b04bd54 100644 --- a/t/001_basic.t +++ b/t/001_basic.t @@ -19,10 +19,10 @@ BEGIN { our @ISA = ('Foo'); } -my $Foo = Foo->meta(); +my $Foo = Class::MOP::Class->initialize('Foo'); isa_ok($Foo, 'Class::MOP::Class'); -my $Bar = Bar->meta(); +my $Bar = Class::MOP::Class->initialize('Bar'); isa_ok($Bar, 'Class::MOP::Class'); is($Foo->name, 'Foo', '... Foo->name == Foo'); @@ -55,7 +55,7 @@ my $Baz = Class::MOP::Class->create( superclasses => [ 'Bar' ] )); isa_ok($Baz, 'Class::MOP::Class'); -is(Baz->meta, $Baz, '... our metaclasses are singletons'); +is(Class::MOP::Class->initialize('Baz'), $Baz, '... our metaclasses are singletons'); is($Baz->name, 'Baz', '... Baz->name == Baz'); is($Baz->version, '0.10', '... Baz->version == 0.10'); diff --git a/t/002_class_precedence_list.t b/t/002_class_precedence_list.t index cc99286..686327b 100644 --- a/t/002_class_precedence_list.t +++ b/t/002_class_precedence_list.t @@ -31,26 +31,32 @@ B C } is_deeply( - [ My::D->meta->class_precedence_list ], + [ Class::MOP::Class->initialize('My::D')->class_precedence_list ], [ 'My::D', 'My::B', 'My::A', 'My::C', 'My::A' ], '... My::D->meta->class_precedence_list == (D B A C A)'); =pod -+-- B <-+ -| | -+-> A --+ + A <-+ + | | + B | + | | + C --+ =cut { package My::2::A; - our @ISA = ('My::2::B'); + our @ISA = ('My::2::C'); + package My::2::B; - our @ISA = ('My::2::A'); + our @ISA = ('My::2::A'); + + package My::2::C; + our @ISA = ('My::2::B'); } -eval { My::2::B->meta->class_precedence_list }; +eval { Class::MOP::Class->initialize('My::2::B')->class_precedence_list }; ok($@, '... recursive inheritance breaks correctly :)'); =pod @@ -75,6 +81,6 @@ ok($@, '... recursive inheritance breaks correctly :)'); } is_deeply( - [ My::3::D->meta->class_precedence_list ], + [ Class::MOP::Class->initialize('My::3::D')->class_precedence_list ], [ 'My::3::D', 'My::3::B', 'My::3::A', 'My::3::C', 'My::3::A', 'My::3::B', 'My::3::A' ], '... My::3::D->meta->class_precedence_list == (D B A C A B A)'); diff --git a/t/003_methods.t b/t/003_methods.t index 39db0f9..06b4f37 100644 --- a/t/003_methods.t +++ b/t/003_methods.t @@ -11,16 +11,25 @@ BEGIN { use_ok('Class::MOP::Class'); } -{ +{ # This package tries to test &has_method + # as exhaustively as possible. More corner + # cases are welcome :) package Foo; # import a sub use Scalar::Util 'blessed'; + use constant FOO_CONSTANT => 'Foo-CONSTANT'; + # define a sub in package sub bar { 'Foo::bar' } *baz = \&bar; - + + { # method named with Sub::Name inside the package scope + no strict 'refs'; + *{'Foo::floob'} = Sub::Name::subname 'floob' => sub { '!floob!' }; + } + # We hateses the "used only once" warnings { my $temp = \&Foo::baz } @@ -31,11 +40,14 @@ BEGIN { { no strict 'refs'; *{'Foo::bling'} = sub { '$$Bling$$' }; - *{'Foo::bang'} = Sub::Name::subname 'Foo::bang' => sub { '!BANG!' }; + *{'Foo::bang'} = Sub::Name::subname 'Foo::bang' => sub { '!BANG!' }; + *{'Foo::boom'} = Sub::Name::subname 'boom' => sub { '!BOOM!' }; + + eval "package Foo; sub evaled_foo { 'Foo::evaled_foo' }"; } } -my $Foo = Foo->meta; +my $Foo = Class::MOP::Class->initialize('Foo'); my $foo = sub { 'Foo::foo' }; @@ -44,15 +56,47 @@ lives_ok { } '... we added the method successfully'; ok($Foo->has_method('foo'), '... Foo->has_method(foo) (defined with Sub::Name)'); -ok(!$Foo->has_method('blessed'), '... !Foo->has_method(blessed) (imported into Foo)'); + +is($Foo->get_method('foo'), $foo, '... Foo->get_method(foo) == \&foo'); +is(Foo->foo(), 'Foo::foo', '... Foo->foo() returns "Foo::foo"'); + +# now check all our other items ... + +ok($Foo->has_method('FOO_CONSTANT'), '... Foo->has_method(FOO_CONSTANT) (defined w/ use constant)'); ok($Foo->has_method('bar'), '... Foo->has_method(bar) (defined in Foo)'); ok($Foo->has_method('baz'), '... Foo->has_method(baz) (typeglob aliased within Foo)'); +ok($Foo->has_method('floob'), '... Foo->has_method(floob) (defined in Foo:: using symbol tables and Sub::Name w/out package name)'); ok($Foo->has_method('blah'), '... Foo->has_method(blah) (defined in main:: using fully qualified package name)'); -ok(!$Foo->has_method('bling'), '... !Foo->has_method(bling) (defined in main:: using symbol tables (no Sub::Name))'); +ok($Foo->has_method('bling'), '... Foo->has_method(bling) (defined in main:: using symbol tables (no Sub::Name))'); ok($Foo->has_method('bang'), '... Foo->has_method(bang) (defined in main:: using symbol tables and Sub::Name)'); +ok($Foo->has_method('evaled_foo'), '... Foo->has_method(evaled_foo) (evaled in main::)'); -is($Foo->get_method('foo'), $foo, '... Foo->get_method(foo) == \&foo'); +ok(!$Foo->has_method('blessed'), '... !Foo->has_method(blessed) (imported into Foo)'); +ok(!$Foo->has_method('boom'), '... !Foo->has_method(boom) (defined in main:: using symbol tables and Sub::Name w/out package name)'); -is(Foo->foo(), 'Foo::foo', '... Foo->foo() returns "Foo::foo"'); -is(Foo->bar(), 'Foo::bar', '... Foo->bar() returns "Foo::bar"'); -is(Foo->baz(), 'Foo::bar', '... Foo->baz() returns "Foo::bar" (because it is aliased to &bar)'); +ok(!$Foo->has_method('not_a_real_method'), '... !Foo->has_method(not_a_real_method) (does not exist)'); +is($Foo->get_method('not_a_real_method'), undef, '... Foo->get_method(not_a_real_method) == undef'); + +# ... test our class creator + +my $Bar = Class::MOP::Class->create( + 'Bar' => '0.10' => ( + methods => { + foo => sub { 'Bar::foo' }, + bar => sub { 'Bar::bar' }, + } + )); +isa_ok($Bar, 'Class::MOP::Class'); + +ok($Bar->has_method('foo'), '... Bar->has_method(foo)'); +ok($Bar->has_method('bar'), '... Bar->has_method(bar)'); + +is(Bar->foo, 'Bar::foo', '... Bar->foo == Bar::foo'); +is(Bar->bar, 'Bar::bar', '... Bar->bar == Bar::bar'); + +lives_ok { + $Bar->add_method('foo' => sub { 'Bar::foo v2' }); +} '... overwriting a method is fine'; + +ok($Bar->has_method('foo'), '... Bar-> (still) has_method(foo)'); +is(Bar->foo, 'Bar::foo v2', '... Bar->foo == "Bar::foo v2"');