r2879 - in /packages/libclass-mop-perl/trunk: Changes META.yml
README debian/changelog lib/Class/MOP.pm lib/Class/MOP/Attribute.pm
lib/Class/MOP/Class.pm t/005_attributes.t t/010_self_introspection.t
eloy at users.alioth.debian.org
eloy at users.alioth.debian.org
Tue Jun 6 12:16:01 UTC 2006
Author: eloy
Date: Tue Jun 6 12:16:01 2006
New Revision: 2879
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=2879
Log:
eloy: new upstream version
Modified:
packages/libclass-mop-perl/trunk/Changes
packages/libclass-mop-perl/trunk/META.yml
packages/libclass-mop-perl/trunk/README
packages/libclass-mop-perl/trunk/debian/changelog
packages/libclass-mop-perl/trunk/lib/Class/MOP.pm
packages/libclass-mop-perl/trunk/lib/Class/MOP/Attribute.pm
packages/libclass-mop-perl/trunk/lib/Class/MOP/Class.pm
packages/libclass-mop-perl/trunk/t/005_attributes.t
packages/libclass-mop-perl/trunk/t/010_self_introspection.t
Modified: packages/libclass-mop-perl/trunk/Changes
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libclass-mop-perl/trunk/Changes?rev=2879&op=diff
==============================================================================
--- packages/libclass-mop-perl/trunk/Changes (original)
+++ packages/libclass-mop-perl/trunk/Changes Tue Jun 6 12:16:01 2006
@@ -1,4 +1,13 @@
Revision history for Perl extension Class-MOP.
+
+0.26 Mon. April 24, 2006
+ * Class::MOP::Class
+ - added find_attribute_by_name method
+ - added tests and docs for this
+ - some small optimizations
+
+ * Class::MOP::Attribute
+ - some small optimizations
0.25 Thurs. April 20, 2006
* Class::MOP::Class
Modified: packages/libclass-mop-perl/trunk/META.yml
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libclass-mop-perl/trunk/META.yml?rev=2879&op=diff
==============================================================================
--- packages/libclass-mop-perl/trunk/META.yml (original)
+++ packages/libclass-mop-perl/trunk/META.yml Tue Jun 6 12:16:01 2006
@@ -1,6 +1,6 @@
---
name: Class-MOP
-version: 0.25
+version: 0.26
author:
- Stevan Little E<lt>stevan at iinteractive.comE<gt>
abstract: A Meta Object Protocol for Perl 5
@@ -17,16 +17,16 @@
provides:
Class::MOP:
file: lib/Class/MOP.pm
- version: 0.25
+ version: 0.26
Class::MOP::Attribute:
file: lib/Class/MOP/Attribute.pm
- version: 0.06
+ version: 0.07
Class::MOP::Attribute::Accessor:
file: lib/Class/MOP/Attribute.pm
- version: 0.06
+ version: 0.07
Class::MOP::Class:
file: lib/Class/MOP/Class.pm
- version: 0.12
+ version: 0.13
Class::MOP::Method:
file: lib/Class/MOP/Method.pm
version: 0.02
Modified: packages/libclass-mop-perl/trunk/README
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libclass-mop-perl/trunk/README?rev=2879&op=diff
==============================================================================
--- packages/libclass-mop-perl/trunk/README (original)
+++ packages/libclass-mop-perl/trunk/README Tue Jun 6 12:16:01 2006
@@ -1,4 +1,4 @@
-Class::MOP version 0.25
+Class::MOP version 0.26
===========================
See the individual module documentation for more information
Modified: packages/libclass-mop-perl/trunk/debian/changelog
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libclass-mop-perl/trunk/debian/changelog?rev=2879&op=diff
==============================================================================
--- packages/libclass-mop-perl/trunk/debian/changelog (original)
+++ packages/libclass-mop-perl/trunk/debian/changelog Tue Jun 6 12:16:01 2006
@@ -1,3 +1,9 @@
+libclass-mop-perl (0.26-1) UNRELEASED; urgency=low
+
+ * (NOT RELEASED YET) New upstream release
+
+ -- Krzysztof Krzyzaniak (eloy) <eloy at debian.org> Tue, 6 Jun 2006 14:15:20 +0200
+
libclass-mop-perl (0.25-1) unstable; urgency=low
* New upstream release (closes: #363685)
Modified: packages/libclass-mop-perl/trunk/lib/Class/MOP.pm
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libclass-mop-perl/trunk/lib/Class/MOP.pm?rev=2879&op=diff
==============================================================================
--- packages/libclass-mop-perl/trunk/lib/Class/MOP.pm (original)
+++ packages/libclass-mop-perl/trunk/lib/Class/MOP.pm Tue Jun 6 12:16:01 2006
@@ -11,7 +11,7 @@
use Class::MOP::Attribute;
use Class::MOP::Method;
-our $VERSION = '0.25';
+our $VERSION = '0.26';
## ----------------------------------------------------------------------------
## Setting up our environment ...
Modified: packages/libclass-mop-perl/trunk/lib/Class/MOP/Attribute.pm
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libclass-mop-perl/trunk/lib/Class/MOP/Attribute.pm?rev=2879&op=diff
==============================================================================
--- packages/libclass-mop-perl/trunk/lib/Class/MOP/Attribute.pm (original)
+++ packages/libclass-mop-perl/trunk/lib/Class/MOP/Attribute.pm Tue Jun 6 12:16:01 2006
@@ -7,7 +7,7 @@
use Carp 'confess';
use Scalar::Util 'blessed', 'reftype', 'weaken';
-our $VERSION = '0.06';
+our $VERSION = '0.07';
sub meta {
require Class::MOP::Class;
@@ -62,13 +62,13 @@
sub initialize_instance_slot {
my ($self, $class, $instance, $params) = @_;
- my $init_arg = $self->init_arg();
+ my $init_arg = $self->{init_arg};
# try to fetch the init arg from the %params ...
my $val;
$val = $params->{$init_arg} if exists $params->{$init_arg};
# if nothing was in the %params, we can use the
# attribute's default value (if it has one)
- if (!defined $val && $self->has_default) {
+ if (!defined $val && defined $self->{default}) {
$val = $self->default($instance);
}
$instance->{$self->name} = $val;
Modified: packages/libclass-mop-perl/trunk/lib/Class/MOP/Class.pm
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libclass-mop-perl/trunk/lib/Class/MOP/Class.pm?rev=2879&op=diff
==============================================================================
--- packages/libclass-mop-perl/trunk/lib/Class/MOP/Class.pm (original)
+++ packages/libclass-mop-perl/trunk/lib/Class/MOP/Class.pm Tue Jun 6 12:16:01 2006
@@ -9,7 +9,7 @@
use Sub::Name 'subname';
use B 'svref_2object';
-our $VERSION = '0.12';
+our $VERSION = '0.13';
# Self-introspection
@@ -17,7 +17,7 @@
# Creation
-{
+#{
# 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.
@@ -97,7 +97,7 @@
$class_name . "->meta => (" . (blessed($meta)) . ")";
}
}
-}
+#}
sub create {
my ($class, $package_name, $package_version, %options) = @_;
@@ -217,11 +217,12 @@
sub superclasses {
my $self = shift;
+ no strict 'refs';
if (@_) {
my @supers = @_;
- @{$self->get_package_variable('@ISA')} = @supers;
- }
- @{$self->get_package_variable('@ISA')};
+ @{$self->name . '::ISA'} = @supers;
+ }
+ @{$self->name . '::ISA'};
}
sub class_precedence_list {
@@ -231,12 +232,16 @@
# 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') }
+ { ($self->name || return)->isa('This is a test for circular inheritance') }
# ... and now back to our regularly scheduled program
(
$self->name,
map {
- $self->initialize($_)->class_precedence_list()
+ # OPTIMIZATION NOTE:
+ # we grab the metaclass from the %METAS
+ # hash here to save the initialize() call
+ # if we can, but it is not always possible
+ ($METAS{$_} || $self->initialize($_))->class_precedence_list()
} $self->superclasses()
);
}
@@ -488,8 +493,12 @@
my ($self, $attribute_name) = @_;
(defined $attribute_name && $attribute_name)
|| confess "You must define an attribute name";
- return $self->get_attribute_map->{$attribute_name}
- if $self->has_attribute($attribute_name);
+ # OPTIMIZATION NOTE:
+ # we used to say `if $self->has_attribute($attribute_name)`
+ # here, but since get_attribute is called so often, we
+ # eliminate the function call here
+ return $self->{'%:attributes'}->{$attribute_name}
+ if exists $self->{'%:attributes'}->{$attribute_name};
return;
}
@@ -507,7 +516,12 @@
sub get_attribute_list {
my $self = shift;
- keys %{$self->get_attribute_map};
+ # OPTIMIZATION NOTE:
+ # We don't use get_attribute_map here because
+ # we ask for the attribute list quite often
+ # in compute_all_applicable_attributes, so
+ # eliminating the function call helps
+ keys %{$self->{'%:attributes'}};
}
sub compute_all_applicable_attributes {
@@ -522,7 +536,10 @@
next if $seen_class{$class};
$seen_class{$class}++;
# fetch the meta-class ...
- my $meta = $self->initialize($class);
+ # OPTIMIZATION NOTE:
+ # we grab the metaclass from the %METAS
+ # hash here to save the initialize() call
+ my $meta = $METAS{$class};
foreach my $attr_name ($meta->get_attribute_list()) {
next if exists $seen_attr{$attr_name};
$seen_attr{$attr_name}++;
@@ -530,6 +547,24 @@
}
}
return @attrs;
+}
+
+sub find_attribute_by_name {
+ my ($self, $attr_name) = @_;
+ # keep a record of what we have seen
+ # here, this will handle all the
+ # inheritence issues because we are
+ # using the &class_precedence_list
+ my %seen_class;
+ foreach my $class ($self->class_precedence_list()) {
+ next if $seen_class{$class};
+ $seen_class{$class}++;
+ # fetch the meta-class ...
+ my $meta = $self->initialize($class);
+ return $meta->get_attribute($attr_name)
+ if $meta->has_attribute($attr_name);
+ }
+ return;
}
# Class attributes
@@ -1110,6 +1145,12 @@
that same information is discoverable through the attribute
meta-object itself.
+=item B<find_attribute_by_name ($attr_name)>
+
+This method will traverse the inheritance heirachy and find the
+first attribute whose name matches C<$attr_name>, then return it.
+It will return undef if nothing is found.
+
=back
=head2 Package Variables
Modified: packages/libclass-mop-perl/trunk/t/005_attributes.t
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libclass-mop-perl/trunk/t/005_attributes.t?rev=2879&op=diff
==============================================================================
--- packages/libclass-mop-perl/trunk/t/005_attributes.t (original)
+++ packages/libclass-mop-perl/trunk/t/005_attributes.t Tue Jun 6 12:16:01 2006
@@ -3,7 +3,7 @@
use strict;
use warnings;
-use Test::More tests => 40;
+use Test::More tests => 43;
use Test::Exception;
BEGIN {
@@ -78,6 +78,10 @@
my $meta = Baz->meta;
isa_ok($meta, 'Class::MOP::Class');
+ is($meta->find_attribute_by_name('$bar'), $BAR_ATTR, '... got the right attribute for "bar"');
+ is($meta->find_attribute_by_name('$baz'), $BAZ_ATTR, '... got the right attribute for "baz"');
+ is($meta->find_attribute_by_name('$foo'), $FOO_ATTR, '... got the right attribute for "foo"');
+
is_deeply(
[ sort { $a->name cmp $b->name } $meta->compute_all_applicable_attributes() ],
[
Modified: packages/libclass-mop-perl/trunk/t/010_self_introspection.t
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libclass-mop-perl/trunk/t/010_self_introspection.t?rev=2879&op=diff
==============================================================================
--- packages/libclass-mop-perl/trunk/t/010_self_introspection.t (original)
+++ packages/libclass-mop-perl/trunk/t/010_self_introspection.t Tue Jun 6 12:16:01 2006
@@ -3,7 +3,7 @@
use strict;
use warnings;
-use Test::More tests => 134;
+use Test::More tests => 136;
use Test::Exception;
BEGIN {
@@ -43,7 +43,7 @@
add_before_method_modifier add_after_method_modifier add_around_method_modifier
has_attribute get_attribute add_attribute remove_attribute
- get_attribute_list get_attribute_map compute_all_applicable_attributes
+ get_attribute_list get_attribute_map compute_all_applicable_attributes find_attribute_by_name
add_package_variable get_package_variable has_package_variable remove_package_variable
);
More information about the Pkg-perl-cvs-commits
mailing list