r2608 - in /packages/libclass-mop-perl: ./ branches/
branches/upstream/
branches/upstream/current/ branches/upstream/current/examples/
branches/upstream/current/lib/ branches/upstream/current/lib/Class/
branches/upstream/current/lib/Class/MOP/ branches/upstream/current/t/
branches/upstream/current/t/lib/ tags/
eloy at users.alioth.debian.org
eloy at users.alioth.debian.org
Thu Apr 20 11:21:07 UTC 2006
Author: eloy
Date: Thu Apr 20 11:21:04 2006
New Revision: 2608
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=2608
Log:
[svn-inject] Installing original source of libclass-mop-perl
Added:
packages/libclass-mop-perl/
packages/libclass-mop-perl/branches/
packages/libclass-mop-perl/branches/upstream/
packages/libclass-mop-perl/branches/upstream/current/
packages/libclass-mop-perl/branches/upstream/current/Build.PL
packages/libclass-mop-perl/branches/upstream/current/Changes
packages/libclass-mop-perl/branches/upstream/current/MANIFEST
packages/libclass-mop-perl/branches/upstream/current/MANIFEST.SKIP
packages/libclass-mop-perl/branches/upstream/current/META.yml
packages/libclass-mop-perl/branches/upstream/current/Makefile.PL
packages/libclass-mop-perl/branches/upstream/current/README
packages/libclass-mop-perl/branches/upstream/current/examples/
packages/libclass-mop-perl/branches/upstream/current/examples/AttributesWithHistory.pod
packages/libclass-mop-perl/branches/upstream/current/examples/C3MethodDispatchOrder.pod
packages/libclass-mop-perl/branches/upstream/current/examples/ClassEncapsulatedAttributes.pod
packages/libclass-mop-perl/branches/upstream/current/examples/InsideOutClass.pod
packages/libclass-mop-perl/branches/upstream/current/examples/InstanceCountingClass.pod
packages/libclass-mop-perl/branches/upstream/current/examples/LazyClass.pod
packages/libclass-mop-perl/branches/upstream/current/examples/Perl6Attribute.pod
packages/libclass-mop-perl/branches/upstream/current/lib/
packages/libclass-mop-perl/branches/upstream/current/lib/Class/
packages/libclass-mop-perl/branches/upstream/current/lib/Class/MOP/
packages/libclass-mop-perl/branches/upstream/current/lib/Class/MOP.pm
packages/libclass-mop-perl/branches/upstream/current/lib/Class/MOP/Attribute.pm
packages/libclass-mop-perl/branches/upstream/current/lib/Class/MOP/Class.pm
packages/libclass-mop-perl/branches/upstream/current/lib/Class/MOP/Method.pm
packages/libclass-mop-perl/branches/upstream/current/lib/metaclass.pm
packages/libclass-mop-perl/branches/upstream/current/t/
packages/libclass-mop-perl/branches/upstream/current/t/000_load.t
packages/libclass-mop-perl/branches/upstream/current/t/001_basic.t
packages/libclass-mop-perl/branches/upstream/current/t/002_class_precedence_list.t
packages/libclass-mop-perl/branches/upstream/current/t/003_methods.t
packages/libclass-mop-perl/branches/upstream/current/t/004_advanced_methods.t
packages/libclass-mop-perl/branches/upstream/current/t/005_attributes.t
packages/libclass-mop-perl/branches/upstream/current/t/006_new_and_clone_metaclasses.t
packages/libclass-mop-perl/branches/upstream/current/t/010_self_introspection.t
packages/libclass-mop-perl/branches/upstream/current/t/011_create_class.t
packages/libclass-mop-perl/branches/upstream/current/t/012_package_variables.t
packages/libclass-mop-perl/branches/upstream/current/t/013_add_attribute_alternate.t
packages/libclass-mop-perl/branches/upstream/current/t/014_attribute_introspection.t
packages/libclass-mop-perl/branches/upstream/current/t/015_metaclass_inheritance.t
packages/libclass-mop-perl/branches/upstream/current/t/016_class_errors_and_edge_cases.t
packages/libclass-mop-perl/branches/upstream/current/t/017_add_method_modifier.t
packages/libclass-mop-perl/branches/upstream/current/t/020_attribute.t
packages/libclass-mop-perl/branches/upstream/current/t/021_attribute_errors_and_edge_cases.t
packages/libclass-mop-perl/branches/upstream/current/t/030_method.t
packages/libclass-mop-perl/branches/upstream/current/t/031_method_modifiers.t
packages/libclass-mop-perl/branches/upstream/current/t/040_metaclass.t
packages/libclass-mop-perl/branches/upstream/current/t/041_metaclass_incompatability.t
packages/libclass-mop-perl/branches/upstream/current/t/050_scala_style_mixin_composition.t
packages/libclass-mop-perl/branches/upstream/current/t/100_BinaryTree_test.t
packages/libclass-mop-perl/branches/upstream/current/t/101_InstanceCountingClass_test.t
packages/libclass-mop-perl/branches/upstream/current/t/102_InsideOutClass_test.t
packages/libclass-mop-perl/branches/upstream/current/t/103_Perl6Attribute_test.t
packages/libclass-mop-perl/branches/upstream/current/t/104_AttributesWithHistory_test.t
packages/libclass-mop-perl/branches/upstream/current/t/105_ClassEncapsulatedAttributes_test.t
packages/libclass-mop-perl/branches/upstream/current/t/106_LazyClass_test.t
packages/libclass-mop-perl/branches/upstream/current/t/107_C3MethodDispatchOrder_test.t
packages/libclass-mop-perl/branches/upstream/current/t/200_Class_C3_compatibility.t
packages/libclass-mop-perl/branches/upstream/current/t/300_random_eval_bug.t
packages/libclass-mop-perl/branches/upstream/current/t/lib/
packages/libclass-mop-perl/branches/upstream/current/t/lib/BinaryTree.pm
packages/libclass-mop-perl/branches/upstream/current/t/pod.t
packages/libclass-mop-perl/branches/upstream/current/t/pod_coverage.t
packages/libclass-mop-perl/tags/
Added: packages/libclass-mop-perl/branches/upstream/current/Build.PL
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libclass-mop-perl/branches/upstream/current/Build.PL?rev=2608&op=file
==============================================================================
--- packages/libclass-mop-perl/branches/upstream/current/Build.PL (added)
+++ packages/libclass-mop-perl/branches/upstream/current/Build.PL Thu Apr 20 11:21:04 2006
@@ -1,0 +1,29 @@
+use Module::Build;
+
+use strict;
+
+my $build = Module::Build->new(
+ module_name => 'Class::MOP',
+ license => 'perl',
+ requires => {
+ 'Scalar::Util' => '1.18',
+ 'Sub::Name' => '0.02',
+ 'Carp' => '0.01',
+ 'B' => '0',
+ },
+ optional => {
+ },
+ build_requires => {
+ 'Test::More' => '0.47',
+ 'Test::Exception' => '0.21',
+ 'File::Spec' => '0',
+ },
+ create_makefile_pl => 'traditional',
+ recursive_test_files => 1,
+ add_to_cleanup => [
+ 'META.yml', '*.bak', '*.gz', 'Makefile.PL',
+ ],
+);
+
+$build->create_build_script;
+
Added: packages/libclass-mop-perl/branches/upstream/current/Changes
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libclass-mop-perl/branches/upstream/current/Changes?rev=2608&op=file
==============================================================================
--- packages/libclass-mop-perl/branches/upstream/current/Changes (added)
+++ packages/libclass-mop-perl/branches/upstream/current/Changes Thu Apr 20 11:21:04 2006
@@ -1,0 +1,191 @@
+Revision history for Perl extension Class-MOP.
+
+0.24 Tues. April 11, 2006
+ * Class::MOP::Class
+ - cleaned up how the before/after/around method
+ modifiers get named with Sub::Name
+
+0.23 Thurs. March 30, 2006
+ * Class::MOP::Class
+ - fixed the way attribute defaults are handled
+ during instance construction (bug found by chansen)
+
+ * Class::MOP::Attribute
+ - read-only accessors ('reader') will now die if
+ passed more than one argument (attempting to write
+ to them basically)
+ - added tests for this
+ - adjusted all /example files to comply
+
+
+0.22 Mon. March 20, 2006
+ * Class::MOP::Class
+ - localized $@ in the *_package_variable functions
+ because otherwise, it does ugly things in Moose.
+ - added test case for this
+
+0.21 Wed. March 15, 2006
+ * Class::MOP::Class
+ - fixed issue where metaclasses are reaped from
+ our cache in global destruction, and so are not
+ available in DESTORY calls
+
+0.20 Thurs. March 2, 2006
+ - removed the dependency for Clone since
+ we no longer to deep-cloning by default.
+
+ * Class::MOP::Method
+ - added &package_name, &name and
+ &fully_qualified_name methods, some of
+ which were formerly private subs in
+ Class::MOP::Class
+
+ * Class::MOP::Method::Wrapped
+ - allows for a method to be wrapped with
+ before, after and around modifiers
+ - added tests and docs for this feature
+
+ * Class::MOP::Class
+ - improved &get_package_variable
+ - &version and &superclasses now use it
+ - methods are now blessed into Class::MOP::Method
+ whenever possible
+ - added methods to install CLOS-style method modifiers
+ - &add_before_method_modifier
+ - &add_after_method_modifier
+ - &add_around_method_modifier
+ - added tests and docs for these
+ - added &find_next_method_by_name which finds the
+ equivalent of SUPER::method_name
+
+0.12 Thurs. Feb 23, 2006
+ - reduced the dependency on B, no need to always
+ have the latest
+
+ * examples/
+ - added docs to the C3 method dispatch order test
+ - fixed missing Algorithm::C3 dependency by making
+ the test skip if it is not installed
+
+0.11 Mon Feb. 20, 2006
+ * examples/
+ - added example of changing method dispatch order to C3
+
+ * Class::MOP::Class
+ - changed how clone_instance behaves, it now only does a
+ shallow clone (see docs for more details)
+ - added docs and tests
+
+0.10 Tues Feb. 14, 2006
+ ** This release was mostly about writing more tests and
+ cleaning out old and dusty code, the MOP should now
+ be considered "ready to use".
+
+ - adding more tests to get coverage up a little higher,
+ mostly testing errors and edge cases.
+ - test coverage is now at 99%
+
+ * Class::MOP
+ - no longer optionally exports to UNIVERSAL::meta or
+ creates a custom metaclass generator, use the
+ metaclass pragma instead.
+
+ * Class::MOP::Class
+ - fixed a number of minor issues which came up in the
+ error/edge-case tests
+
+ * Class::MOP::Attribute
+ - fixed a number of minor issues which came up in the
+ error/edge-case tests
+
+ * examples/
+ - fixing the AttributesWithHistory example, it was broken.
+
+0.06 Thurs Feb. 9, 2006
+ * metaclass
+ - adding new metaclass pragma to make setting up the
+ metaclass a little more straightforward
+
+ * Class::MOP
+ - clean up bootstrapping to include more complete
+ attribute definitions for Class::MOP::Class and
+ Class::MOP::Attribute (accessors, readers, writers,
+ etc.) ... it is redundant, but is useful meta-info
+ to have around.
+
+ * Class::MOP::Class
+ - fixing minor meta-circularity issue with &meta, it
+ is now more useful for subclasses
+ - added &get_attribute_map as an accessor for the
+ hash of attribute meta objects
+ - &compute_all_applicable_attributes now just returns
+ the attribute meta-object, rather than the HASH ref
+ since all the same info can be gotten from the
+ attribute meta-object itself
+ - updated docs & tests to reflect
+ - added &clone_instance method which does a deep clone
+ of the instance structure created by &construct_instance
+ - added docs & tests for this
+ - added Clone as a dependency
+ - added &new_object and &clone_object convience methods to
+ return blessed new or cloned instances
+ - they handle Class::MOP::Class singletons correctly too
+ - added docs & tests for this
+ - cleaned up the &constuct_class_instance so that it behaves
+ more like &construct_instance (and managed the singletons too)
+ - added the &check_metaclass_compatibility method to make sure
+ that metaclasses are upward and downward compatible.
+ - added tests and docs for this
+
+ * examples/
+ - adjusting code to use the &Class::MOP::Class::meta
+ fix detailed above
+ - adjusting code to use the metaclass pragma
+
+0.05 Sat Feb. 4, 2006
+ * Class::MOP::Class
+ - added the &attribute_metaclass and &method_metaclass
+ attributes which contain a metaclass name to use for
+ attributes/methods respectively
+
+ * Class::MOP
+ - bootstrap additional attributes for Class::MOP::Class
+
+ * examples/
+ - adjusted the example code and tests to use the new
+ &attribute_metaclass feature of Class::MOP::Class
+ - added new example:
+ - LazyClass
+
+0.04 Fri Feb. 3, 2006
+ * Class::MOP::Class
+ - some documentation suggestions from #perl6
+
+ * Class::MOP::Attribute
+ - improved error messages
+
+ * examples/
+ - added new examples:
+ - AttributesWithHistory
+ - ClassEncapsultedAttributes
+
+0.03 Fri Feb. 3, 2006
+ - converted to Module::Build instead of EU::MM
+
+ * Class::MOP::Attribute
+ - refactored method generation code
+ - attributes are now associated with class directly
+
+ * examples/
+ - refactored the InsideOut example to take advantage
+ of the Class::MOP::Attribute refactoring
+ - changed example files to .pod files and hide thier
+ package names from PAUSE (I don't want to own these
+ namespaces really, they are just examples)
+
+0.02 Thurs Feb. 2, 2006
+ - moving examples from t/lib/* to examples/*
+ - adding POD documentation to the examples
+
+0.01 Thurs Feb. 2, 2006
+ - Initial release
Added: packages/libclass-mop-perl/branches/upstream/current/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libclass-mop-perl/branches/upstream/current/MANIFEST?rev=2608&op=file
==============================================================================
--- packages/libclass-mop-perl/branches/upstream/current/MANIFEST (added)
+++ packages/libclass-mop-perl/branches/upstream/current/MANIFEST Thu Apr 20 11:21:04 2006
@@ -1,0 +1,54 @@
+Build.PL
+Changes
+Makefile.PL
+META.yml
+MANIFEST
+MANIFEST.SKIP
+README
+examples/AttributesWithHistory.pod
+examples/C3MethodDispatchOrder.pod
+examples/ClassEncapsulatedAttributes.pod
+examples/InsideOutClass.pod
+examples/InstanceCountingClass.pod
+examples/LazyClass.pod
+examples/Perl6Attribute.pod
+lib/metaclass.pm
+lib/Class/MOP.pm
+lib/Class/MOP/Attribute.pm
+lib/Class/MOP/Class.pm
+lib/Class/MOP/Method.pm
+t/000_load.t
+t/001_basic.t
+t/002_class_precedence_list.t
+t/003_methods.t
+t/004_advanced_methods.t
+t/005_attributes.t
+t/006_new_and_clone_metaclasses.t
+t/010_self_introspection.t
+t/011_create_class.t
+t/012_package_variables.t
+t/013_add_attribute_alternate.t
+t/014_attribute_introspection.t
+t/015_metaclass_inheritance.t
+t/016_class_errors_and_edge_cases.t
+t/017_add_method_modifier.t
+t/020_attribute.t
+t/021_attribute_errors_and_edge_cases.t
+t/030_method.t
+t/031_method_modifiers.t
+t/040_metaclass.t
+t/041_metaclass_incompatability.t
+t/050_scala_style_mixin_composition.t
+t/100_BinaryTree_test.t
+t/101_InstanceCountingClass_test.t
+t/102_InsideOutClass_test.t
+t/103_Perl6Attribute_test.t
+t/104_AttributesWithHistory_test.t
+t/105_ClassEncapsulatedAttributes_test.t
+t/106_LazyClass_test.t
+t/107_C3MethodDispatchOrder_test.t
+t/200_Class_C3_compatibility.t
+t/300_random_eval_bug.t
+t/pod.t
+t/pod_coverage.t
+t/lib/BinaryTree.pm
Added: packages/libclass-mop-perl/branches/upstream/current/MANIFEST.SKIP
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libclass-mop-perl/branches/upstream/current/MANIFEST.SKIP?rev=2608&op=file
==============================================================================
--- packages/libclass-mop-perl/branches/upstream/current/MANIFEST.SKIP (added)
+++ packages/libclass-mop-perl/branches/upstream/current/MANIFEST.SKIP Thu Apr 20 11:21:04 2006
@@ -1,0 +1,18 @@
+^_build
+^Build$
+^blib
+~$
+\.bak$
+^MANIFEST\.SKIP$
+CVS
+\.svn
+\.DS_Store
+cover_db
+\..*\.sw.?$
+^Makefile$
+^pm_to_blib$
+^MakeMaker-\d
+^blibdirs$
+\.old$
+^#.*#$
+^\.#
Added: packages/libclass-mop-perl/branches/upstream/current/META.yml
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libclass-mop-perl/branches/upstream/current/META.yml?rev=2608&op=file
==============================================================================
--- packages/libclass-mop-perl/branches/upstream/current/META.yml (added)
+++ packages/libclass-mop-perl/branches/upstream/current/META.yml Thu Apr 20 11:21:04 2006
@@ -1,0 +1,39 @@
+---
+name: Class-MOP
+version: 0.24
+author:
+ - Stevan Little E<lt>stevan at iinteractive.comE<gt>
+abstract: A Meta Object Protocol for Perl 5
+license: perl
+requires:
+ B: 0
+ Carp: 0.01
+ Scalar::Util: 1.18
+ Sub::Name: 0.02
+build_requires:
+ File::Spec: 0
+ Test::Exception: 0.21
+ Test::More: 0.47
+provides:
+ Class::MOP:
+ file: lib/Class/MOP.pm
+ version: 0.24
+ Class::MOP::Attribute:
+ file: lib/Class/MOP/Attribute.pm
+ version: 0.05
+ Class::MOP::Attribute::Accessor:
+ file: lib/Class/MOP/Attribute.pm
+ version: 0.05
+ Class::MOP::Class:
+ file: lib/Class/MOP/Class.pm
+ version: 0.10
+ Class::MOP::Method:
+ file: lib/Class/MOP/Method.pm
+ version: 0.02
+ Class::MOP::Method::Wrapped:
+ file: lib/Class/MOP/Method.pm
+ version: 0.02
+ metaclass:
+ file: lib/metaclass.pm
+ version: 0.02
+generated_by: Module::Build version 0.2611
Added: packages/libclass-mop-perl/branches/upstream/current/Makefile.PL
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libclass-mop-perl/branches/upstream/current/Makefile.PL?rev=2608&op=file
==============================================================================
--- packages/libclass-mop-perl/branches/upstream/current/Makefile.PL (added)
+++ packages/libclass-mop-perl/branches/upstream/current/Makefile.PL Thu Apr 20 11:21:04 2006
@@ -1,0 +1,19 @@
+# Note: this file was auto-generated by Module::Build::Compat version 0.03
+use ExtUtils::MakeMaker;
+WriteMakefile
+(
+ 'NAME' => 'Class::MOP',
+ 'VERSION_FROM' => 'lib/Class/MOP.pm',
+ 'PREREQ_PM' => {
+ 'B' => '0',
+ 'Carp' => '0.01',
+ 'File::Spec' => '0',
+ 'Scalar::Util' => '1.18',
+ 'Sub::Name' => '0.02',
+ 'Test::Exception' => '0.21',
+ 'Test::More' => '0.47'
+ },
+ 'INSTALLDIRS' => 'site',
+ 'PL_FILES' => {}
+ )
+;
Added: packages/libclass-mop-perl/branches/upstream/current/README
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libclass-mop-perl/branches/upstream/current/README?rev=2608&op=file
==============================================================================
--- packages/libclass-mop-perl/branches/upstream/current/README (added)
+++ packages/libclass-mop-perl/branches/upstream/current/README Thu Apr 20 11:21:04 2006
@@ -1,0 +1,32 @@
+Class::MOP version 0.24
+===========================
+
+See the individual module documentation for more information
+
+INSTALLATION
+
+To install this module type the following:
+
+ perl Makefile.PL
+ make
+ make test
+ make install
+
+DEPENDENCIES
+
+This module requires these other modules and libraries:
+
+ Scalar::Util
+ Sub::Name
+ Carp
+ B
+
+COPYRIGHT AND LICENCE
+
+Copyright (C) 2006 Infinity Interactive, Inc.
+
+http://www.iinteractive.com
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
Added: packages/libclass-mop-perl/branches/upstream/current/examples/AttributesWithHistory.pod
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libclass-mop-perl/branches/upstream/current/examples/AttributesWithHistory.pod?rev=2608&op=file
==============================================================================
--- packages/libclass-mop-perl/branches/upstream/current/examples/AttributesWithHistory.pod (added)
+++ packages/libclass-mop-perl/branches/upstream/current/examples/AttributesWithHistory.pod Thu Apr 20 11:21:04 2006
@@ -1,0 +1,122 @@
+
+package # hide the package from PAUSE
+ AttributesWithHistory;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.04';
+
+use base 'Class::MOP::Attribute';
+
+# this is for an extra attribute constructor
+# option, which is to be able to create a
+# way for the class to access the history
+AttributesWithHistory->meta->add_attribute('history_accessor' => (
+ reader => 'history_accessor',
+ init_arg => 'history_accessor',
+ predicate => 'has_history_accessor',
+));
+
+# this is a place to store the actual
+# history of the attribute
+AttributesWithHistory->meta->add_attribute('_history' => (
+ accessor => '_history',
+ default => sub { {} },
+));
+
+# generate the methods
+
+sub generate_history_accessor_method {
+ my ($self, $attr_name) = @_;
+ eval qq{sub {
+ unless (ref \$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\}) \{
+ \$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\} = [];
+ \}
+ \@\{\$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\}\};
+ }};
+}
+
+sub generate_accessor_method {
+ my ($self, $attr_name) = @_;
+ eval qq{sub {
+ if (scalar(\@_) == 2) {
+ unless (ref \$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\}) \{
+ \$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\} = [];
+ \}
+ push \@\{\$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\}\} => \$_[1];
+ \$_[0]->{'$attr_name'} = \$_[1];
+ }
+ \$_[0]->{'$attr_name'};
+ }};
+}
+
+sub generate_writer_method {
+ my ($self, $attr_name) = @_;
+ eval qq{sub {
+ unless (ref \$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\}) \{
+ \$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\} = [];
+ \}
+ push \@\{\$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\}\} => \$_[1];
+ \$_[0]->{'$attr_name'} = \$_[1];
+ }};
+}
+
+AttributesWithHistory->meta->add_after_method_modifier('install_accessors' => sub {
+ my ($self) = @_;
+ # and now add the history accessor
+ $self->associated_class->add_method(
+ $self->process_accessors('history_accessor' => $self->history_accessor())
+ ) if $self->has_history_accessor();
+});
+
+1;
+
+=pod
+
+=head1 NAME
+
+AttributesWithHistory - An example attribute metaclass which keeps a history of changes
+
+=head1 SYSNOPSIS
+
+ package Foo;
+
+ Foo->meta->add_attribute(AttributesWithHistory->new('foo' => (
+ accessor => 'foo',
+ history_accessor => 'get_foo_history',
+ )));
+
+ Foo->meta->add_attribute(AttributesWithHistory->new('bar' => (
+ reader => 'get_bar',
+ writer => 'set_bar',
+ history_accessor => 'get_bar_history',
+ )));
+
+ sub new {
+ my $class = shift;
+ $class->meta->new_object(@_);
+ }
+
+=head1 DESCRIPTION
+
+This is an example of an attribute metaclass which keeps a
+record of all the values it has been assigned. It stores the
+history as a field in the attribute meta-object, and will
+autogenerate a means of accessing that history for the class
+which these attributes are added too.
+
+=head1 AUTHOR
+
+Stevan Little E<lt>stevan at iinteractive.comE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2006 by Infinity Interactive, Inc.
+
+L<http://www.iinteractive.com>
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
Added: packages/libclass-mop-perl/branches/upstream/current/examples/C3MethodDispatchOrder.pod
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libclass-mop-perl/branches/upstream/current/examples/C3MethodDispatchOrder.pod?rev=2608&op=file
==============================================================================
--- packages/libclass-mop-perl/branches/upstream/current/examples/C3MethodDispatchOrder.pod (added)
+++ packages/libclass-mop-perl/branches/upstream/current/examples/C3MethodDispatchOrder.pod Thu Apr 20 11:21:04 2006
@@ -1,0 +1,134 @@
+
+package # hide from PAUSE
+ C3MethodDispatchOrder;
+
+use strict;
+use warnings;
+
+use Carp 'confess';
+use Algorithm::C3;
+
+our $VERSION = '0.03';
+
+use base 'Class::MOP::Class';
+
+my $_find_method = sub {
+ my ($class, $method) = @_;
+ foreach my $super ($class->class_precedence_list) {
+ return $super->meta->get_method($method)
+ if $super->meta->has_method($method);
+ }
+};
+
+C3MethodDispatchOrder->meta->add_around_method_modifier('initialize' => sub {
+ my $cont = shift;
+ my $meta = $cont->(@_);
+ $meta->add_method('AUTOLOAD' => sub {
+ my $meta = $_[0]->meta;
+ my $method_name;
+ {
+ no strict 'refs';
+ my $label = ${$meta->name . '::AUTOLOAD'};
+ $method_name = (split /\:\:/ => $label)[-1];
+ }
+ my $method = $_find_method->($meta, $method_name);
+ (defined $method) || confess "Method ($method_name) not found";
+ goto &$method;
+ }) unless $meta->has_method('AUTOLOAD');
+ $meta->add_method('can' => sub {
+ $_find_method->($_[0]->meta, $_[1]);
+ }) unless $meta->has_method('can');
+ return $meta;
+});
+
+sub superclasses {
+ my $self = shift;
+ no strict 'refs';
+ if (@_) {
+ my @supers = @_;
+ @{$self->get_package_variable('@SUPERS')} = @supers;
+ }
+ @{$self->get_package_variable('@SUPERS')};
+}
+
+sub class_precedence_list {
+ my $self = shift;
+ return map {
+ $_->name;
+ } Algorithm::C3::merge($self, sub {
+ my $class = shift;
+ map { $_->meta } $class->superclasses;
+ });
+}
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+C3MethodDispatchOrder - An example attribute metaclass for changing to C3 method dispatch order
+
+=head1 SYNOPSIS
+
+ # a classic diamond inheritence graph
+ #
+ # <A>
+ # / \
+ # <B> <C>
+ # \ /
+ # <D>
+
+ package A;
+ use metaclass 'C3MethodDispatchOrder';
+
+ sub hello { return "Hello from A" }
+
+ package B;
+ use metaclass 'C3MethodDispatchOrder';
+ B->meta->superclasses('A');
+
+ package C;
+ use metaclass 'C3MethodDispatchOrder';
+ C->meta->superclasses('A');
+
+ sub hello { return "Hello from C" }
+
+ package D;
+ use metaclass 'C3MethodDispatchOrder';
+ D->meta->superclasses('B', 'C');
+
+ print join ", " => D->meta->class_precedence_list; # prints C3 order D, B, C, A
+
+ # later in other code ...
+
+ print D->hello; # print 'Hello from C' instead of the normal 'Hello from A'
+
+=head1 DESCRIPTION
+
+This is an example of how you could change the method dispatch order of a
+class using L<Class::MOP>. Using the L<Algorithm::C3> module, this repleces
+the normal depth-first left-to-right perl dispatch order with the C3 method
+dispatch order (see the L<Algorithm::C3> or L<Class::C3> docs for more
+information about this).
+
+This example could be used as a template for other method dispatch orders
+as well, all that is required is to write a the C<class_precedence_list> method
+which will return a linearized list of classes to dispatch along.
+
+=head1 AUTHOR
+
+Stevan Little E<lt>stevan at iinteractive.comE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2006 by Infinity Interactive, Inc.
+
+L<http://www.iinteractive.com>
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
Added: packages/libclass-mop-perl/branches/upstream/current/examples/ClassEncapsulatedAttributes.pod
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libclass-mop-perl/branches/upstream/current/examples/ClassEncapsulatedAttributes.pod?rev=2608&op=file
==============================================================================
--- packages/libclass-mop-perl/branches/upstream/current/examples/ClassEncapsulatedAttributes.pod (added)
+++ packages/libclass-mop-perl/branches/upstream/current/examples/ClassEncapsulatedAttributes.pod Thu Apr 20 11:21:04 2006
@@ -1,0 +1,169 @@
+
+package # hide the package from PAUSE
+ ClassEncapsulatedAttributes;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.04';
+
+use base 'Class::MOP::Class';
+
+sub initialize {
+ (shift)->SUPER::initialize(@_,
+ # use the custom attribute metaclass here
+ ':attribute_metaclass' => 'ClassEncapsulatedAttributes::Attribute'
+ );
+}
+
+sub construct_instance {
+ my ($class, %params) = @_;
+ my $instance = {};
+ foreach my $current_class ($class->class_precedence_list()) {
+ $instance->{$current_class} = {}
+ unless exists $instance->{$current_class};
+ my $meta = $current_class->meta;
+ foreach my $attr_name ($meta->get_attribute_list()) {
+ my $attr = $meta->get_attribute($attr_name);
+ # if the attr has an init_arg, use that, otherwise,
+ # use the attributes name itself as the init_arg
+ my $init_arg = $attr->init_arg();
+ # try to fetch the init arg from the %params ...
+ my $val;
+ $val = $params{$current_class}->{$init_arg}
+ if exists $params{$current_class} &&
+ exists ${$params{$current_class}}{$init_arg};
+ # if nothing was in the %params, we can use the
+ # attribute's default value (if it has one)
+ if (!defined $val && $attr->has_default) {
+ $val = $attr->default($instance);
+ }
+ # now add this to the instance structure
+ $instance->{$current_class}->{$attr_name} = $val;
+ }
+ }
+ return $instance;
+}
+
+package # hide the package from PAUSE
+ ClassEncapsulatedAttributes::Attribute;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.02';
+
+use base 'Class::MOP::Attribute';
+
+sub generate_accessor_method {
+ my ($self, $attr_name) = @_;
+ my $class_name = $self->associated_class->name;
+ eval qq{sub {
+ \$_[0]->{'$class_name'}->{'$attr_name'} = \$_[1] if scalar(\@_) == 2;
+ \$_[0]->{'$class_name'}->{'$attr_name'};
+ }};
+}
+
+sub generate_reader_method {
+ my ($self, $attr_name) = @_;
+ my $class_name = $self->associated_class->name;
+ eval qq{sub {
+ Carp::confess "Cannot assign a value to a read-only accessor" if \@_ > 1;
+ \$_[0]->{'$class_name'}->{'$attr_name'};
+ }};
+}
+
+sub generate_writer_method {
+ my ($self, $attr_name) = @_;
+ my $class_name = $self->associated_class->name;
+ eval qq{sub {
+ \$_[0]->{'$class_name'}->{'$attr_name'} = \$_[1];
+ }};
+}
+
+sub generate_predicate_method {
+ my ($self, $attr_name) = @_;
+ my $class_name = $self->associated_class->name;
+ eval qq{sub {
+ defined \$_[0]->{'$class_name'}->{'$attr_name'} ? 1 : 0;
+ }};
+}
+
+## &remove_attribute is left as an exercise for the reader :)
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+ClassEncapsulatedAttributes - A set of example metaclasses with class encapsulated attributes
+
+=head1 SYNOPSIS
+
+ package Foo;
+
+ use metaclass 'ClassEncapsulatedAttributes';
+
+ Foo->meta->add_attribute('foo' => (
+ accessor => 'Foo_foo',
+ default => 'init in FOO'
+ ));
+
+ sub new {
+ my $class = shift;
+ $class->meta->new_object(@_);
+ }
+
+ package Bar;
+ our @ISA = ('Foo');
+
+ # duplicate the attribute name here
+ Bar->meta->add_attribute('foo' => (
+ accessor => 'Bar_foo',
+ default => 'init in BAR'
+ ));
+
+ # ... later in other code ...
+
+ my $bar = Bar->new();
+ prints $bar->Bar_foo(); # init in BAR
+ prints $bar->Foo_foo(); # init in FOO
+
+ # and ...
+
+ my $bar = Bar->new(
+ 'Foo' => { 'foo' => 'Foo::foo' },
+ 'Bar' => { 'foo' => 'Bar::foo' }
+ );
+
+ prints $bar->Bar_foo(); # Foo::foo
+ prints $bar->Foo_foo(); # Bar::foo
+
+=head1 DESCRIPTION
+
+This is an example metaclass which encapsulates a class's
+attributes on a per-class basis. This means that there is no
+possibility of name clashes with inherited attributes. This
+is similar to how C++ handles its data members.
+
+=head1 ACKNOWLEDGEMENTS
+
+Thanks to Yuval "nothingmuch" Kogman for the idea for this example.
+
+=head1 AUTHOR
+
+Stevan Little E<lt>stevan at iinteractive.comE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2006 by Infinity Interactive, Inc.
+
+L<http://www.iinteractive.com>
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
Added: packages/libclass-mop-perl/branches/upstream/current/examples/InsideOutClass.pod
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libclass-mop-perl/branches/upstream/current/examples/InsideOutClass.pod?rev=2608&op=file
==============================================================================
--- packages/libclass-mop-perl/branches/upstream/current/examples/InsideOutClass.pod (added)
+++ packages/libclass-mop-perl/branches/upstream/current/examples/InsideOutClass.pod Thu Apr 20 11:21:04 2006
@@ -1,0 +1,154 @@
+
+package # hide the package from PAUSE
+ InsideOutClass;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.04';
+
+use Scalar::Util 'refaddr';
+
+use base 'Class::MOP::Class';
+
+sub construct_instance {
+ my ($class, %params) = @_;
+ # create a scalar ref to use as
+ # the inside-out instance
+ my $instance = \(my $var);
+ foreach my $attr ($class->compute_all_applicable_attributes()) {
+ # if the attr has an init_arg, use that, otherwise,
+ # use the attributes name itself as the init_arg
+ my $init_arg = $attr->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 && $attr->has_default) {
+ $val = $attr->default($instance);
+ }
+ # now add this to the instance structure
+ $class->get_package_variable('%' . $attr->name)->{ refaddr($instance) } = $val;
+ }
+ return $instance;
+}
+
+package # hide the package from PAUSE
+ InsideOutClass::Attribute;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.04';
+
+use Carp 'confess';
+use Scalar::Util 'refaddr';
+
+use base 'Class::MOP::Attribute';
+
+sub generate_accessor_method {
+ my ($self, $attr_name) = @_;
+ $attr_name = ($self->associated_class->name . '::' . $attr_name);
+ eval 'sub {
+ $' . $attr_name . '{ refaddr($_[0]) } = $_[1] if scalar(@_) == 2;
+ $' . $attr_name . '{ refaddr($_[0]) };
+ }';
+}
+
+sub generate_reader_method {
+ my ($self, $attr_name) = @_;
+ eval 'sub {
+ confess "Cannot assign a value to a read-only accessor" if @_ > 1;
+ $' . ($self->associated_class->name . '::' . $attr_name) . '{ refaddr($_[0]) };
+ }';
+}
+
+sub generate_writer_method {
+ my ($self, $attr_name) = @_;
+ eval 'sub {
+ $' . ($self->associated_class->name . '::' . $attr_name) . '{ refaddr($_[0]) } = $_[1];
+ }';
+}
+
+sub generate_predicate_method {
+ my ($self, $attr_name) = @_;
+ eval 'sub {
+ defined($' . ($self->associated_class->name . '::' . $attr_name) . '{ refaddr($_[0]) }) ? 1 : 0;
+ }';
+}
+
+## &remove_attribute is left as an exercise for the reader :)
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+InsideOutClass - A set of example metaclasses which implement the Inside-Out technique
+
+=head1 SYNOPSIS
+
+ package Foo;
+
+ use metaclass 'InsideOutClass' => (
+ # tell our metaclass to use the
+ # InsideOut attribute metclass
+ # to construct all it's attributes
+ ':attribute_metaclass' => 'InsideOutClass::Attribute'
+ );
+
+ __PACKAGE__->meta->add_attribute('foo' => (
+ reader => 'get_foo',
+ writer => 'set_foo'
+ ));
+
+ sub new {
+ my $class = shift;
+ $class->meta->new_object(@_);
+ }
+
+ # now you can just use the class as normal
+
+=head1 DESCRIPTION
+
+This is a set of example metaclasses which implement the Inside-Out
+class technique. What follows is a brief explaination of the code
+found in this module.
+
+First step is to subclass B<Class::MOP::Class> and override the
+C<construct_instance> method. The default C<construct_instance>
+will create a HASH reference using the parameters and attribute
+default values. Since inside-out objects don't use HASH refs, and
+use package variables instead, we need to write code to handle
+this difference.
+
+The next step is to create the subclass of B<Class::MOP::Attribute>
+and override the method generation code. This requires overloading
+C<generate_accessor_method>, C<generate_reader_method>,
+C<generate_writer_method> and C<generate_predicate_method>. All
+other aspects are taken care of with the existing B<Class::MOP::Attribute>
+infastructure.
+
+And that is pretty much all. Of course I am ignoring need for
+inside-out objects to be C<DESTROY>-ed, and some other details as
+well, but this is an example. A real implementation is left as an
+exercise to the reader.
+
+=head1 AUTHOR
+
+Stevan Little E<lt>stevan at iinteractive.comE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2006 by Infinity Interactive, Inc.
+
+L<http://www.iinteractive.com>
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
Added: packages/libclass-mop-perl/branches/upstream/current/examples/InstanceCountingClass.pod
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libclass-mop-perl/branches/upstream/current/examples/InstanceCountingClass.pod?rev=2608&op=file
==============================================================================
--- packages/libclass-mop-perl/branches/upstream/current/examples/InstanceCountingClass.pod (added)
+++ packages/libclass-mop-perl/branches/upstream/current/examples/InstanceCountingClass.pod Thu Apr 20 11:21:04 2006
@@ -1,0 +1,71 @@
+
+package # hide the package from PAUSE
+ InstanceCountingClass;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.03';
+
+use base 'Class::MOP::Class';
+
+InstanceCountingClass->meta->add_attribute('$:count' => (
+ reader => 'get_count',
+ default => 0
+));
+
+InstanceCountingClass->meta->add_before_method_modifier('construct_instance' => sub {
+ my ($class) = @_;
+ $class->{'$:count'}++;
+});
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+InstanceCountingClass - An example metaclass which counts instances
+
+=head1 SYNOPSIS
+
+ package Foo;
+
+ use metaclass 'InstanceCountingClass';
+
+ sub new {
+ my $class = shift;
+ $class->meta->new_object(@_);
+ }
+
+ # ... meanwhile, somewhere in the code
+
+ my $foo = Foo->new();
+ print Foo->meta->get_count(); # prints 1
+
+ my $foo2 = Foo->new();
+ print Foo->meta->get_count(); # prints 2
+
+ # ... etc etc etc
+
+=head1 DESCRIPTION
+
+This is a classic example of a metaclass which keeps a count of each
+instance which is created.
+
+=head1 AUTHOR
+
+Stevan Little E<lt>stevan at iinteractive.comE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2006 by Infinity Interactive, Inc.
+
+L<http://www.iinteractive.com>
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
Added: packages/libclass-mop-perl/branches/upstream/current/examples/LazyClass.pod
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libclass-mop-perl/branches/upstream/current/examples/LazyClass.pod?rev=2608&op=file
==============================================================================
--- packages/libclass-mop-perl/branches/upstream/current/examples/LazyClass.pod (added)
+++ packages/libclass-mop-perl/branches/upstream/current/examples/LazyClass.pod Thu Apr 20 11:21:04 2006
@@ -1,0 +1,137 @@
+
+package # hide the package from PAUSE
+ LazyClass;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.02';
+
+use base 'Class::MOP::Class';
+
+sub construct_instance {
+ my ($class, %params) = @_;
+ my $instance = {};
+ foreach my $attr ($class->compute_all_applicable_attributes()) {
+ # if the attr has an init_arg, use that, otherwise,
+ # use the attributes name itself as the init_arg
+ my $init_arg = $attr->init_arg();
+ # try to fetch the init arg from the %params ...
+ my $val;
+ $val = $params{$init_arg} if exists $params{$init_arg};
+ # now add this to the instance structure
+ # only if we have found a value at all
+ $instance->{$attr->name} = $val if defined $val;
+ }
+ return $instance;
+}
+
+package # hide the package from PAUSE
+ LazyClass::Attribute;
+
+use strict;
+use warnings;
+
+use Carp 'confess';
+
+our $VERSION = '0.02';
+
+use base 'Class::MOP::Attribute';
+
+sub generate_accessor_method {
+ my ($self, $attr_name) = @_;
+ sub {
+ if (scalar(@_) == 2) {
+ $_[0]->{$attr_name} = $_[1];
+ }
+ else {
+ if (!exists $_[0]->{$attr_name}) {
+ my $attr = $self->associated_class->get_attribute($attr_name);
+ $_[0]->{$attr_name} = $attr->has_default ? $attr->default($_[0]) : undef;
+ }
+ $_[0]->{$attr_name};
+ }
+ };
+}
+
+sub generate_reader_method {
+ my ($self, $attr_name) = @_;
+ sub {
+ confess "Cannot assign a value to a read-only accessor" if @_ > 1;
+ if (!exists $_[0]->{$attr_name}) {
+ my $attr = $self->associated_class->get_attribute($attr_name);
+ $_[0]->{$attr_name} = $attr->has_default ? $attr->default($_[0]) : undef;
+ }
+ $_[0]->{$attr_name};
+ };
+}
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+LazyClass - An example metaclass with lazy initialization
+
+=head1 SYNOPSIS
+
+ package BinaryTree;
+
+ use metaclass 'LazyClass' => (
+ ':attribute_metaclass' => 'LazyClass::Attribute'
+ );
+
+ BinaryTree->meta->add_attribute('$:node' => (
+ accessor => 'node',
+ init_arg => ':node'
+ ));
+
+ BinaryTree->meta->add_attribute('$:left' => (
+ reader => 'left',
+ default => sub { BinaryTree->new() }
+ ));
+
+ BinaryTree->meta->add_attribute('$:right' => (
+ reader => 'right',
+ default => sub { BinaryTree->new() }
+ ));
+
+ sub new {
+ my $class = shift;
+ $class->meta->new_object(@_);
+ }
+
+ # ... later in code
+
+ my $btree = BinaryTree->new();
+ # ... $btree is an empty hash, no keys are initialized yet
+
+=head1 DESCRIPTION
+
+This is an example metclass in which all attributes are created
+lazily. This means that no entries are made in the instance HASH
+until the last possible moment.
+
+The example above of a binary tree is a good use for such a
+metaclass because it allows the class to be space efficient
+without complicating the programing of it. This would also be
+ideal for a class which has a large amount of attributes,
+several of which are optional.
+
+=head1 AUTHOR
+
+Stevan Little E<lt>stevan at iinteractive.comE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2006 by Infinity Interactive, Inc.
+
+L<http://www.iinteractive.com>
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
Added: packages/libclass-mop-perl/branches/upstream/current/examples/Perl6Attribute.pod
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libclass-mop-perl/branches/upstream/current/examples/Perl6Attribute.pod?rev=2608&op=file
==============================================================================
--- packages/libclass-mop-perl/branches/upstream/current/examples/Perl6Attribute.pod (added)
+++ packages/libclass-mop-perl/branches/upstream/current/examples/Perl6Attribute.pod Thu Apr 20 11:21:04 2006
@@ -1,0 +1,81 @@
+
+package # hide the package from PAUSE
+ Perl6Attribute;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.02';
+
+use base 'Class::MOP::Attribute';
+
+Perl6Attribute->meta->add_around_method_modifier('new' => sub {
+ my $cont = shift;
+ my ($class, $attribute_name, %options) = @_;
+
+ # extract the sigil and accessor name
+ my ($sigil, $accessor_name) = ($attribute_name =~ /^([\$\@\%])\.(.*)$/);
+
+ # pass the accessor name
+ $options{accessor} = $accessor_name;
+
+ # create a default value based on the sigil
+ $options{default} = sub { [] } if ($sigil eq '@');
+ $options{default} = sub { {} } if ($sigil eq '%');
+
+ $cont->($class, $attribute_name, %options);
+});
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+Perl6Attribute - An example attribute metaclass for Perl 6 style attributes
+
+=head1 SYNOPSIS
+
+ package Foo;
+
+ Foo->meta->add_attribute(Perl6Attribute->new('$.foo'));
+ Foo->meta->add_attribute(Perl6Attribute->new('@.bar'));
+ Foo->meta->add_attribute(Perl6Attribute->new('%.baz'));
+
+ sub new {
+ my $class = shift;
+ $class->meta->new_object(@_);
+ }
+
+=head1 DESCRIPTION
+
+This is an attribute metaclass which implements Perl 6 style
+attributes, including the auto-generating accessors.
+
+This code is very simple, we only need to subclass
+C<Class::MOP::Attribute> and override C<&new>. Then we just
+pre-process the attribute name, and create the accessor name
+and default value based on it.
+
+More advanced features like the C<handles> trait (see
+L<Perl6::Bible/A12>) can be accomplished as well doing the
+same pre-processing approach. This is left as an exercise to
+the reader though (if you do it, please send me a patch
+though, and will update this).
+
+=head1 AUTHOR
+
+Stevan Little E<lt>stevan at iinteractive.comE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2006 by Infinity Interactive, Inc.
+
+L<http://www.iinteractive.com>
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
Added: packages/libclass-mop-perl/branches/upstream/current/lib/Class/MOP.pm
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libclass-mop-perl/branches/upstream/current/lib/Class/MOP.pm?rev=2608&op=file
==============================================================================
--- packages/libclass-mop-perl/branches/upstream/current/lib/Class/MOP.pm (added)
+++ packages/libclass-mop-perl/branches/upstream/current/lib/Class/MOP.pm Thu Apr 20 11:21:04 2006
@@ -1,0 +1,441 @@
+
+package Class::MOP;
+
+use strict;
+use warnings;
+
+use Carp 'confess';
+use Scalar::Util ();
+
+use Class::MOP::Class;
+use Class::MOP::Attribute;
+use Class::MOP::Method;
+
+our $VERSION = '0.24';
+
+## ----------------------------------------------------------------------------
+## Setting up our environment ...
+## ----------------------------------------------------------------------------
+## Class::MOP needs to have a few things in the global perl environment so
+## that it can operate effectively. Those things are done here.
+## ----------------------------------------------------------------------------
+
+# ... nothing yet actually ;)
+
+## ----------------------------------------------------------------------------
+## Bootstrapping
+## ----------------------------------------------------------------------------
+## The code below here is to bootstrap our MOP with itself. This is also
+## sometimes called "tying the knot". By doing this, we make it much easier
+## to extend the MOP through subclassing and such since now you can use the
+## MOP itself to extend itself.
+##
+## Yes, I know, thats weird and insane, but it's a good thing, trust me :)
+## ----------------------------------------------------------------------------
+
+# We need to add in the meta-attributes here so that
+# any subclass of Class::MOP::* will be able to
+# inherit them using &construct_instance
+
+## Class::MOP::Class
+
+Class::MOP::Class->meta->add_attribute(
+ Class::MOP::Attribute->new('$:package' => (
+ reader => 'name',
+ init_arg => ':package',
+ ))
+);
+
+Class::MOP::Class->meta->add_attribute(
+ Class::MOP::Attribute->new('%:attributes' => (
+ reader => 'get_attribute_map',
+ init_arg => ':attributes',
+ default => sub { {} }
+ ))
+);
+
+Class::MOP::Class->meta->add_attribute(
+ Class::MOP::Attribute->new('$:attribute_metaclass' => (
+ reader => 'attribute_metaclass',
+ init_arg => ':attribute_metaclass',
+ default => 'Class::MOP::Attribute',
+ ))
+);
+
+Class::MOP::Class->meta->add_attribute(
+ Class::MOP::Attribute->new('$:method_metaclass' => (
+ reader => 'method_metaclass',
+ init_arg => ':method_metaclass',
+ default => 'Class::MOP::Method',
+ ))
+);
+
+## Class::MOP::Attribute
+
+Class::MOP::Attribute->meta->add_attribute(
+ Class::MOP::Attribute->new('name' => (
+ reader => 'name'
+ ))
+);
+
+Class::MOP::Attribute->meta->add_attribute(
+ Class::MOP::Attribute->new('associated_class' => (
+ reader => 'associated_class'
+ ))
+);
+
+Class::MOP::Attribute->meta->add_attribute(
+ Class::MOP::Attribute->new('accessor' => (
+ reader => 'accessor',
+ predicate => 'has_accessor',
+ ))
+);
+
+Class::MOP::Attribute->meta->add_attribute(
+ Class::MOP::Attribute->new('reader' => (
+ reader => 'reader',
+ predicate => 'has_reader',
+ ))
+);
+
+Class::MOP::Attribute->meta->add_attribute(
+ Class::MOP::Attribute->new('writer' => (
+ reader => 'writer',
+ predicate => 'has_writer',
+ ))
+);
+
+Class::MOP::Attribute->meta->add_attribute(
+ Class::MOP::Attribute->new('predicate' => (
+ reader => 'predicate',
+ predicate => 'has_predicate',
+ ))
+);
+
+Class::MOP::Attribute->meta->add_attribute(
+ Class::MOP::Attribute->new('init_arg' => (
+ reader => 'init_arg',
+ predicate => 'has_init_arg',
+ ))
+);
+
+Class::MOP::Attribute->meta->add_attribute(
+ Class::MOP::Attribute->new('default' => (
+ # default has a custom 'reader' method ...
+ predicate => 'has_default',
+ ))
+);
+
+
+# NOTE: (meta-circularity)
+# This should be one of the last things done
+# it will "tie the knot" with Class::MOP::Attribute
+# so that it uses the attributes meta-objects
+# to construct itself.
+Class::MOP::Attribute->meta->add_method('new' => sub {
+ my $class = shift;
+ my $name = shift;
+ my %options = @_;
+
+ (defined $name && $name)
+ || confess "You must provide a name for the attribute";
+ $options{init_arg} = $name
+ if not exists $options{init_arg};
+
+ # return the new object
+ $class->meta->new_object(name => $name, %options);
+});
+
+Class::MOP::Attribute->meta->add_method('clone' => sub {
+ my $self = shift;
+ $self->meta->clone_object($self, @_);
+});
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+Class::MOP - A Meta Object Protocol for Perl 5
+
+=head1 SYNOPSIS
+
+ # ... This will come later, for now see
+ # the other SYNOPSIS for more information
+
+=head1 DESCRIPTON
+
+This module is an attempt to create a meta object protocol for the
+Perl 5 object system. It makes no attempt to change the behavior or
+characteristics of the Perl 5 object system, only to create a
+protocol for its manipulation and introspection.
+
+That said, it does attempt to create the tools for building a rich
+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 Yet Another Class Builder!! Why?
+
+This is B<not> a class builder so much as it is a I<class builder
+B<builder>>. My intent is that an end user does not use this module
+directly, but instead this module is used by module authors to
+build extensions and features onto the Perl 5 object system.
+
+=head2 Who is this module for?
+
+This module is specifically for anyone who has ever created or
+wanted to create a module for the Class:: namespace. The tools which
+this module will provide will hopefully make it easier to do more
+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. Many of
+its features are accessible without B<any> 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. Unlike many other B<Class::>
+modules, this module B<does not> require you subclass it, or even that
+you C<use> it in within your module's package.
+
+The only features which requires additions to your code are the
+attribute handling and instance construction features, and these are
+both completely optional 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<any> drain at all upon your code's performance. In fact, by itself
+it does nothing to affect your existing code. So you only pay for
+what you actually use.
+
+=head2 About Metaclass compatibility
+
+This module makes sure that all metaclasses created are both upwards
+and downwards compatible. The topic of metaclass compatibility is
+highly esoteric and is something only encountered when doing deep and
+involved metaclass hacking. There are two basic kinds of metaclass
+incompatibility; upwards and downwards.
+
+Upwards metaclass compatibility means that the metaclass of a
+given class is either the same as (or a subclass of) all of the
+class's ancestors.
+
+Downward metaclass compatibility means that the metaclasses of a
+given class's anscestors are all either the same as (or a subclass
+of) that metaclass.
+
+Here is a diagram showing a set of two classes (C<A> and C<B>) and
+two metaclasses (C<Meta::A> and C<Meta::B>) which have correct
+metaclass compatibility both upwards and downwards.
+
+ +---------+ +---------+
+ | Meta::A |<----| Meta::B | <....... (instance of )
+ +---------+ +---------+ <------- (inherits from)
+ ^ ^
+ : :
+ +---------+ +---------+
+ | A |<----| B |
+ +---------+ +---------+
+
+As I said this is a highly esoteric topic and one you will only run
+into if you do a lot of subclassing of B<Class::MOP::Class>. If you
+are interested in why this is an issue see the paper
+I<Uniform and safe metaclass composition> linked to in the
+L<SEE ALSO> section of this document.
+
+=head2 Using custom metaclasses
+
+Always use the metaclass pragma when using a custom metaclass, this
+will ensure the proper initialization order and not accidentely
+create an incorrect type of metaclass for you. This is a very rare
+problem, and one which can only occur if you are doing deep metaclass
+programming. So in other words, don't worry about it.
+
+=head1 PROTOCOLS
+
+The protocol is divided into 3 main sub-protocols:
+
+=over 4
+
+=item The Class protocol
+
+This provides a means of manipulating and introspecting a Perl 5
+class. It handles all of symbol table hacking for you, and provides
+a rich set of methods that go beyond simple package introspection.
+
+See L<Class::MOP::Class> for more details.
+
+=item The Attribute protocol
+
+This provides a consistent represenation for an attribute of a
+Perl 5 class. Since there are so many ways to create and handle
+atttributes in Perl 5 OO, this attempts to provide as much of a
+unified approach as possible, while giving the freedom and
+flexibility to subclass for specialization.
+
+See L<Class::MOP::Attribute> for more details.
+
+=item The Method protocol
+
+This provides a means of manipulating and introspecting methods in
+the Perl 5 object system. As with attributes, there are many ways to
+approach this topic, so we try to keep it pretty basic, while still
+making it possible to extend the system in many ways.
+
+See L<Class::MOP::Method> for more details.
+
+=back
+
+=head1 SEE ALSO
+
+=head2 Books
+
+There are very few books out on Meta Object Protocols and Metaclasses
+because it is such an esoteric topic. The following books are really
+the only ones I have found. If you know of any more, B<I<please>>
+email me and let me know, I would love to hear about them.
+
+=over 4
+
+=item "The Art of the Meta Object Protocol"
+
+=item "Advances in Object-Oriented Metalevel Architecture and Reflection"
+
+=item "Putting MetaClasses to Work"
+
+=item "Smalltalk: The Language"
+
+=back
+
+=head2 Papers
+
+=over 4
+
+=item Uniform and safe metaclass composition
+
+An excellent paper by the people who brought us the original Traits paper.
+This paper is on how Traits can be used to do safe metaclass composition,
+and offers an excellent introduction section which delves into the topic of
+metaclass compatibility.
+
+L<http://www.iam.unibe.ch/~scg/Archive/Papers/Duca05ySafeMetaclassTrait.pdf>
+
+=item Safe Metaclass Programming
+
+This paper seems to precede the above paper, and propose a mix-in based
+approach as opposed to the Traits based approach. Both papers have similar
+information on the metaclass compatibility problem space.
+
+L<http://citeseer.ist.psu.edu/37617.html>
+
+=back
+
+=head2 Prior Art
+
+=over 4
+
+=item The Perl 6 MetaModel work in the Pugs project
+
+=over 4
+
+=item L<http://svn.openfoundry.org/pugs/perl5/Perl6-MetaModel>
+
+=item L<http://svn.openfoundry.org/pugs/perl5/Perl6-ObjectSpace>
+
+=back
+
+=back
+
+=head1 SIMILAR MODULES
+
+As I have said above, this module is a class-builder-builder, so it is
+not the same thing as modules like L<Class::Accessor> and
+L<Class::MethodMaker>. That being said there are very few modules on CPAN
+with similar goals to this module. The one I have found which is most
+like this module is L<Class::Meta>, although it's philosophy and the MOP it
+creates are very different from this modules.
+
+=head1 BUGS
+
+All complex software has bugs lurking in it, and this module is no
+exception. If you find a bug please either email me, or add the bug
+to cpan-RT.
+
+=head1 CODE COVERAGE
+
+I use L<Devel::Cover> to test the code coverage of my tests, below is the
+L<Devel::Cover> report on this module's test suite.
+
+ ---------------------------- ------ ------ ------ ------ ------ ------ ------
+ File stmt bran cond sub pod time total
+ ---------------------------- ------ ------ ------ ------ ------ ------ ------
+ Class/MOP.pm 100.0 100.0 100.0 100.0 n/a 21.4 100.0
+ Class/MOP/Attribute.pm 100.0 100.0 88.9 100.0 100.0 27.1 99.3
+ Class/MOP/Class.pm 100.0 100.0 93.7 100.0 100.0 44.8 99.1
+ Class/MOP/Method.pm 100.0 100.0 83.3 100.0 100.0 4.8 97.1
+ metaclass.pm 100.0 100.0 80.0 100.0 n/a 1.9 97.3
+ ---------------------------- ------ ------ ------ ------ ------ ------ ------
+ Total 100.0 100.0 92.2 100.0 100.0 100.0 99.0
+ ---------------------------- ------ ------ ------ ------ ------ ------ ------
+
+=head1 ACKNOWLEDGEMENTS
+
+=over 4
+
+=item Rob Kinyon E<lt>rob at iinteractive.comE<gt>
+
+Thanks to Rob for actually getting the development of this module kick-started.
+
+=back
+
+=head1 AUTHOR
+
+Stevan Little E<lt>stevan at iinteractive.comE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2006 by Infinity Interactive, Inc.
+
+L<http://www.iinteractive.com>
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
Added: packages/libclass-mop-perl/branches/upstream/current/lib/Class/MOP/Attribute.pm
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libclass-mop-perl/branches/upstream/current/lib/Class/MOP/Attribute.pm?rev=2608&op=file
==============================================================================
--- packages/libclass-mop-perl/branches/upstream/current/lib/Class/MOP/Attribute.pm (added)
+++ packages/libclass-mop-perl/branches/upstream/current/lib/Class/MOP/Attribute.pm Thu Apr 20 11:21:04 2006
@@ -1,0 +1,509 @@
+
+package Class::MOP::Attribute;
+
+use strict;
+use warnings;
+
+use Carp 'confess';
+use Scalar::Util 'blessed', 'reftype', 'weaken';
+
+our $VERSION = '0.05';
+
+sub meta {
+ require Class::MOP::Class;
+ Class::MOP::Class->initialize(blessed($_[0]) || $_[0]);
+}
+
+# NOTE: (meta-circularity)
+# This method will be replaces in the
+# boostrap section of Class::MOP, by
+# a new version which uses the
+# &Class::MOP::Class::construct_instance
+# method to build an attribute meta-object
+# which itself is described with attribute
+# meta-objects.
+# - Ain't meta-circularity grand? :)
+sub new {
+ my $class = shift;
+ my $name = shift;
+ my %options = @_;
+
+ (defined $name && $name)
+ || confess "You must provide a name for the attribute";
+ $options{init_arg} = $name
+ if not exists $options{init_arg};
+
+ bless {
+ name => $name,
+ accessor => $options{accessor},
+ reader => $options{reader},
+ writer => $options{writer},
+ predicate => $options{predicate},
+ init_arg => $options{init_arg},
+ default => $options{default},
+ # keep a weakened link to the
+ # class we are associated with
+ associated_class => undef,
+ } => $class;
+}
+
+# NOTE:
+# this is a primative (and kludgy) clone operation
+# for now, it will be repleace in the Class::MOP
+# bootstrap with a proper one, however we know
+# that this one will work fine for now.
+sub clone {
+ my $self = shift;
+ my %options = @_;
+ (blessed($self))
+ || confess "Can only clone an instance";
+ return bless { %{$self}, %options } => blessed($self);
+}
+
+# NOTE:
+# the next bunch of methods will get bootstrapped
+# away in the Class::MOP bootstrapping section
+
+sub name { $_[0]->{name} }
+
+sub associated_class { $_[0]->{associated_class} }
+
+sub has_accessor { defined($_[0]->{accessor}) ? 1 : 0 }
+sub has_reader { defined($_[0]->{reader}) ? 1 : 0 }
+sub has_writer { defined($_[0]->{writer}) ? 1 : 0 }
+sub has_predicate { defined($_[0]->{predicate}) ? 1 : 0 }
+sub has_init_arg { defined($_[0]->{init_arg}) ? 1 : 0 }
+sub has_default { defined($_[0]->{default}) ? 1 : 0 }
+
+sub accessor { $_[0]->{accessor} }
+sub reader { $_[0]->{reader} }
+sub writer { $_[0]->{writer} }
+sub predicate { $_[0]->{predicate} }
+sub init_arg { $_[0]->{init_arg} }
+
+# end bootstrapped away method section.
+# (all methods below here are kept intact)
+
+sub default {
+ my $self = shift;
+ if (reftype($self->{default}) && reftype($self->{default}) eq 'CODE') {
+ # if the default is a CODE ref, then
+ # we pass in the instance and default
+ # can return a value based on that
+ # instance. Somewhat crude, but works.
+ return $self->{default}->(shift);
+ }
+ $self->{default};
+}
+
+# class association
+
+sub attach_to_class {
+ my ($self, $class) = @_;
+ (blessed($class) && $class->isa('Class::MOP::Class'))
+ || confess "You must pass a Class::MOP::Class instance (or a subclass)";
+ weaken($self->{associated_class} = $class);
+}
+
+sub detach_from_class {
+ my $self = shift;
+ $self->{associated_class} = undef;
+}
+
+## Method generation helpers
+
+sub generate_accessor_method {
+ my ($self, $attr_name) = @_;
+ sub {
+ $_[0]->{$attr_name} = $_[1] if scalar(@_) == 2;
+ $_[0]->{$attr_name};
+ };
+}
+
+sub generate_reader_method {
+ my ($self, $attr_name) = @_;
+ sub {
+ confess "Cannot assign a value to a read-only accessor" if @_ > 1;
+ $_[0]->{$attr_name};
+ };
+}
+
+sub generate_writer_method {
+ my ($self, $attr_name) = @_;
+ sub { $_[0]->{$attr_name} = $_[1] };
+}
+
+sub generate_predicate_method {
+ my ($self, $attr_name) = @_;
+ sub { defined $_[0]->{$attr_name} ? 1 : 0 };
+}
+
+sub process_accessors {
+ my ($self, $type, $accessor) = @_;
+ if (reftype($accessor)) {
+ (reftype($accessor) eq 'HASH')
+ || confess "bad accessor/reader/writer/predicate format, must be a HASH ref";
+ my ($name, $method) = each %{$accessor};
+ return ($name, Class::MOP::Attribute::Accessor->wrap($method));
+ }
+ else {
+ my $generator = $self->can('generate_' . $type . '_method');
+ ($generator)
+ || confess "There is no method generator for the type='$type'";
+ if (my $method = $self->$generator($self->name)) {
+ return ($accessor => Class::MOP::Attribute::Accessor->wrap($method));
+ }
+ confess "Could not create the '$type' method for " . $self->name . " because : $@";
+ }
+}
+
+sub install_accessors {
+ my $self = shift;
+ my $class = $self->associated_class;
+
+ $class->add_method(
+ $self->process_accessors('accessor' => $self->accessor())
+ ) if $self->has_accessor();
+
+ $class->add_method(
+ $self->process_accessors('reader' => $self->reader())
+ ) if $self->has_reader();
+
+ $class->add_method(
+ $self->process_accessors('writer' => $self->writer())
+ ) if $self->has_writer();
+
+ $class->add_method(
+ $self->process_accessors('predicate' => $self->predicate())
+ ) if $self->has_predicate();
+ return;
+}
+
+{
+ my $_remove_accessor = sub {
+ my ($accessor, $class) = @_;
+ if (reftype($accessor) && reftype($accessor) eq 'HASH') {
+ ($accessor) = keys %{$accessor};
+ }
+ my $method = $class->get_method($accessor);
+ $class->remove_method($accessor)
+ if (blessed($method) && $method->isa('Class::MOP::Attribute::Accessor'));
+ };
+
+ sub remove_accessors {
+ my $self = shift;
+ $_remove_accessor->($self->accessor(), $self->associated_class()) if $self->has_accessor();
+ $_remove_accessor->($self->reader(), $self->associated_class()) if $self->has_reader();
+ $_remove_accessor->($self->writer(), $self->associated_class()) if $self->has_writer();
+ $_remove_accessor->($self->predicate(), $self->associated_class()) if $self->has_predicate();
+ return;
+ }
+
+}
+
+package Class::MOP::Attribute::Accessor;
+
+use strict;
+use warnings;
+
+use Class::MOP::Method;
+
+our $VERSION = '0.01';
+
+our @ISA = ('Class::MOP::Method');
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+Class::MOP::Attribute - Attribute Meta Object
+
+=head1 SYNOPSIS
+
+ Class::MOP::Attribute->new('$foo' => (
+ accessor => 'foo', # dual purpose get/set accessor
+ predicate => 'has_foo' # predicate check for defined-ness
+ init_arg => '-foo', # class->new will look for a -foo key
+ default => 'BAR IS BAZ!' # if no -foo key is provided, use this
+ ));
+
+ Class::MOP::Attribute->new('$.bar' => (
+ reader => 'bar', # getter
+ writer => 'set_bar', # setter
+ predicate => 'has_bar' # predicate check for defined-ness
+ init_arg => ':bar', # class->new will look for a :bar key
+ # no default value means it is undef
+ ));
+
+=head1 DESCRIPTION
+
+The Attribute Protocol is almost entirely an invention of this module,
+and is completely optional to this MOP. This is because Perl 5 does not
+have consistent notion of what is an attribute of a class. There are
+so many ways in which this is done, and very few (if any) are
+easily discoverable by this module.
+
+So, all that said, this module attempts to inject some order into this
+chaos, by introducing a consistent API which can be used to create
+object attributes.
+
+=head1 METHODS
+
+=head2 Creation
+
+=over 4
+
+=item B<new ($name, ?%options)>
+
+An attribute must (at the very least), have a C<$name>. All other
+C<%options> are contained added as key-value pairs. Acceptable keys
+are as follows:
+
+=item B<clone (%options)>
+
+=over 4
+
+=item I<init_arg>
+
+This should be a string value representing the expected key in
+an initialization hash. For instance, if we have an I<init_arg>
+value of C<-foo>, then the following code will Just Work.
+
+ MyClass->meta->construct_instance(-foo => "Hello There");
+
+In an init_arg is not assigned, it will automatically use the
+value of C<$name>.
+
+=item I<default>
+
+The value of this key is the default value which
+C<Class::MOP::Class::construct_instance> will initialize the
+attribute to.
+
+B<NOTE:>
+If the value is a simple scalar (string or number), then it can
+be just passed as is. However, if you wish to initialize it with
+a HASH or ARRAY ref, then you need to wrap that inside a CODE
+reference, like so:
+
+ Class::MOP::Attribute->new('@foo' => (
+ default => sub { [] },
+ ));
+
+ # or ...
+
+ Class::MOP::Attribute->new('%foo' => (
+ default => sub { {} },
+ ));
+
+If you wish to initialize an attribute with a CODE reference
+itself, then you need to wrap that in a subroutine as well, like
+so:
+
+ Class::MOP::Attribute->new('&foo' => (
+ default => sub { sub { print "Hello World" } },
+ ));
+
+And lastly, if the value of your attribute is dependent upon
+some other aspect of the instance structure, then you can take
+advantage of the fact that when the I<default> value is a CODE
+reference, it is passed the raw (unblessed) instance structure
+as it's only argument. So you can do things like this:
+
+ Class::MOP::Attribute->new('$object_identity' => (
+ default => sub { Scalar::Util::refaddr($_[0]) },
+ ));
+
+This last feature is fairly limited as there is no gurantee of
+the order of attribute initializations, so you cannot perform
+any kind of dependent initializations. However, if this is
+something you need, you could subclass B<Class::MOP::Class> and
+this class to acheive it. However, this is currently left as
+an exercise to the reader :).
+
+=back
+
+The I<accessor>, I<reader>, I<writer> and I<predicate> keys can
+contain either; the name of the method and an appropriate default
+one will be generated for you, B<or> a HASH ref containing exactly one
+key (which will be used as the name of the method) and one value,
+which should contain a CODE reference which will be installed as
+the method itself.
+
+=over 4
+
+=item I<accessor>
+
+The I<accessor> is a standard perl-style read/write accessor. It will
+return the value of the attribute, and if a value is passed as an argument,
+it will assign that value to the attribute.
+
+B<NOTE:>
+This method will properly handle the following code, by assigning an
+C<undef> value to the attribute.
+
+ $object->set_something(undef);
+
+=item I<reader>
+
+This is a basic read-only accessor, it will just return the value of
+the attribute.
+
+=item I<writer>
+
+This is a basic write accessor, it accepts a single argument, and
+assigns that value to the attribute. This method does not intentially
+return a value, however perl will return the result of the last
+expression in the subroutine, which returns in this returning the
+same value that it was passed.
+
+B<NOTE:>
+This method will properly handle the following code, by assigning an
+C<undef> value to the attribute.
+
+ $object->set_something();
+
+=item I<predicate>
+
+This is a basic test to see if the value of the attribute is not
+C<undef>. It will return true (C<1>) if the attribute's value is
+defined, and false (C<0>) otherwise.
+
+=back
+
+=back
+
+=head2 Informational
+
+These are all basic read-only value accessors for the values
+passed into C<new>. I think they are pretty much self-explanitory.
+
+=over 4
+
+=item B<name>
+
+=item B<accessor>
+
+=item B<reader>
+
+=item B<writer>
+
+=item B<predicate>
+
+=item B<init_arg>
+
+=item B<default (?$instance)>
+
+As noted in the documentation for C<new> above, if the I<default>
+value is a CODE reference, this accessor will pass a single additional
+argument C<$instance> into it and return the value.
+
+=back
+
+=head2 Informational predicates
+
+These are all basic predicate methods for the values passed into C<new>.
+
+=over 4
+
+=item B<has_accessor>
+
+=item B<has_reader>
+
+=item B<has_writer>
+
+=item B<has_predicate>
+
+=item B<has_init_arg>
+
+=item B<has_default>
+
+=back
+
+=head2 Class association
+
+=over 4
+
+=item B<associated_class>
+
+=item B<attach_to_class ($class)>
+
+=item B<detach_from_class>
+
+=back
+
+=head2 Attribute Accessor generation
+
+=over 4
+
+=item B<install_accessors>
+
+This allows the attribute to generate and install code for it's own
+I<accessor/reader/writer/predicate> methods. This is called by
+C<Class::MOP::Class::add_attribute>.
+
+This method will call C<process_accessors> for each of the possible
+method types (accessor, reader, writer & predicate).
+
+=item B<process_accessors ($type, $value)>
+
+This takes a C<$type> (accessor, reader, writer or predicate), and
+a C<$value> (the value passed into the constructor for each of the
+different types). It will then either generate the method itself
+(using the C<generate_*_method> methods listed below) or it will
+use the custom method passed through the constructor.
+
+=over 4
+
+=item B<generate_accessor_method ($attr_name)>
+
+=item B<generate_predicate_method ($attr_name)>
+
+=item B<generate_reader_method ($attr_name)>
+
+=item B<generate_writer_method ($attr_name)>
+
+=back
+
+=item B<remove_accessors>
+
+This allows the attribute to remove the method for it's own
+I<accessor/reader/writer/predicate>. This is called by
+C<Class::MOP::Class::remove_attribute>.
+
+=back
+
+=head2 Introspection
+
+=over 4
+
+=item B<meta>
+
+This will return a B<Class::MOP::Class> instance which is related
+to this class.
+
+It should also be noted that B<Class::MOP> will actually bootstrap
+this module by installing a number of attribute meta-objects into
+it's metaclass. This will allow this class to reap all the benifits
+of the MOP when subclassing it.
+
+=back
+
+=head1 AUTHOR
+
+Stevan Little E<lt>stevan at iinteractive.comE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2006 by Infinity Interactive, Inc.
+
+L<http://www.iinteractive.com>
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
Added: packages/libclass-mop-perl/branches/upstream/current/lib/Class/MOP/Class.pm
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libclass-mop-perl/branches/upstream/current/lib/Class/MOP/Class.pm?rev=2608&op=file
==============================================================================
--- packages/libclass-mop-perl/branches/upstream/current/lib/Class/MOP/Class.pm (added)
+++ packages/libclass-mop-perl/branches/upstream/current/lib/Class/MOP/Class.pm Thu Apr 20 11:21:04 2006
@@ -1,0 +1,1127 @@
+
+package Class::MOP::Class;
+
+use strict;
+use warnings;
+
+use Carp 'confess';
+use Scalar::Util 'blessed', 'reftype';
+use Sub::Name 'subname';
+use B 'svref_2object';
+
+our $VERSION = '0.10';
+
+# Self-introspection
+
+sub meta { Class::MOP::Class->initialize(blessed($_[0]) || $_[0]) }
+
+# 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.
+ # After all, do package definitions even get reaped?
+ my %METAS;
+
+ sub initialize {
+ my $class = shift;
+ my $package_name = shift;
+ (defined $package_name && $package_name && !blessed($package_name))
+ || confess "You must pass a package name and it cannot be blessed";
+ $class->construct_class_instance(':package' => $package_name, @_);
+ }
+
+ # NOTE: (meta-circularity)
+ # this is a special form of &construct_instance
+ # (see below), which is used to construct class
+ # meta-object instances for any Class::MOP::*
+ # class. All other classes will use the more
+ # normal &construct_instance.
+ sub construct_class_instance {
+ my $class = shift;
+ my %options = @_;
+ my $package_name = $options{':package'};
+ (defined $package_name && $package_name)
+ || confess "You must pass a package name";
+ # NOTE:
+ # return the metaclass if we have it cached,
+ # and it is still defined (it has not been
+ # reaped by DESTROY yet, which can happen
+ # annoyingly enough during global destruction)
+ return $METAS{$package_name}
+ if exists $METAS{$package_name} && defined $METAS{$package_name};
+ $class = blessed($class) || $class;
+ # now create the metaclass
+ my $meta;
+ if ($class =~ /^Class::MOP::/) {
+ $meta = bless {
+ '$:package' => $package_name,
+ '%:attributes' => {},
+ '$:attribute_metaclass' => $options{':attribute_metaclass'} || 'Class::MOP::Attribute',
+ '$:method_metaclass' => $options{':method_metaclass'} || 'Class::MOP::Method',
+ } => $class;
+ }
+ else {
+ # NOTE:
+ # it is safe to use meta here because
+ # class will always be a subclass of
+ # Class::MOP::Class, which defines meta
+ $meta = bless $class->meta->construct_instance(%options) => $class
+ }
+ # and check the metaclass compatibility
+ $meta->check_metaclass_compatability();
+ $METAS{$package_name} = $meta;
+ }
+
+ sub check_metaclass_compatability {
+ my $self = shift;
+
+ # this is always okay ...
+ return if blessed($self) eq 'Class::MOP::Class';
+
+ my @class_list = $self->class_precedence_list;
+ shift @class_list; # shift off $self->name
+
+ foreach my $class_name (@class_list) {
+ my $meta = $METAS{$class_name} || next;
+ ($self->isa(blessed($meta)))
+ || confess $self->name . "->meta => (" . (blessed($self)) . ")" .
+ " is not compatible with the " .
+ $class_name . "->meta => (" . (blessed($meta)) . ")";
+ }
+ }
+}
+
+sub create {
+ my ($class, $package_name, $package_version, %options) = @_;
+ (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 = $class->initialize($package_name);
+
+ $meta->add_method('meta' => sub {
+ Class::MOP::Class->initialize(blessed($_[0]) || $_[0]);
+ });
+
+ $meta->superclasses(@{$options{superclasses}})
+ if exists $options{superclasses};
+ # NOTE:
+ # process attributes first, so that they can
+ # install accessors, but locally defined methods
+ # can then overwrite them. It is maybe a little odd, but
+ # I think this should be the order of things.
+ if (exists $options{attributes}) {
+ foreach my $attr (@{$options{attributes}}) {
+ $meta->add_attribute($attr);
+ }
+ }
+ if (exists $options{methods}) {
+ foreach my $method_name (keys %{$options{methods}}) {
+ $meta->add_method($method_name, $options{methods}->{$method_name});
+ }
+ }
+ return $meta;
+}
+
+## Attribute readers
+
+# NOTE:
+# all these attribute readers will be bootstrapped
+# away in the Class::MOP bootstrap section
+
+sub name { $_[0]->{'$:package'} }
+sub get_attribute_map { $_[0]->{'%:attributes'} }
+sub attribute_metaclass { $_[0]->{'$:attribute_metaclass'} }
+sub method_metaclass { $_[0]->{'$:method_metaclass'} }
+
+# Instance Construction & Cloning
+
+sub new_object {
+ my $class = shift;
+ # NOTE:
+ # we need to protect the integrity of the
+ # Class::MOP::Class singletons here, so we
+ # delegate this to &construct_class_instance
+ # which will deal with the singletons
+ return $class->construct_class_instance(@_)
+ if $class->name->isa('Class::MOP::Class');
+ bless $class->construct_instance(@_) => $class->name;
+}
+
+sub construct_instance {
+ my ($class, %params) = @_;
+ my $instance = {};
+ foreach my $attr ($class->compute_all_applicable_attributes()) {
+ my $init_arg = $attr->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 && $attr->has_default) {
+ $val = $attr->default($instance);
+ }
+ $instance->{$attr->name} = $val;
+ }
+ return $instance;
+}
+
+sub clone_object {
+ my $class = shift;
+ my $instance = shift;
+ (blessed($instance) && $instance->isa($class->name))
+ || confess "You must pass an instance ($instance) of the metaclass (" . $class->name . ")";
+ # NOTE:
+ # we need to protect the integrity of the
+ # Class::MOP::Class singletons here, they
+ # should not be cloned.
+ return $instance if $instance->isa('Class::MOP::Class');
+ bless $class->clone_instance($instance, @_) => blessed($instance);
+}
+
+sub clone_instance {
+ my ($class, $instance, %params) = @_;
+ (blessed($instance))
+ || confess "You can only clone instances, \$self is not a blessed instance";
+ my $clone = { %$instance, %params };
+ return $clone;
+}
+
+# Informational
+
+# &name should be here too, but it is above
+# because it gets bootstrapped away
+
+sub version {
+ my $self = shift;
+ ${$self->get_package_variable('$VERSION')};
+}
+
+# Inheritance
+
+sub superclasses {
+ my $self = shift;
+ if (@_) {
+ my @supers = @_;
+ @{$self->get_package_variable('@ISA')} = @supers;
+ }
+ @{$self->get_package_variable('@ISA')};
+}
+
+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 now back to our regularly scheduled program
+ (
+ $self->name,
+ map {
+ $self->initialize($_)->class_precedence_list()
+ } $self->superclasses()
+ );
+}
+
+## Methods
+
+sub add_method {
+ my ($self, $method_name, $method) = @_;
+ (defined $method_name && $method_name)
+ || confess "You must define a method name";
+ # use reftype here to allow for blessed subs ...
+ ('CODE' eq (reftype($method) || ''))
+ || confess "Your code block must be a CODE reference";
+ my $full_method_name = ($self->name . '::' . $method_name);
+
+ $method = $self->method_metaclass->wrap($method) unless blessed($method);
+
+ no strict 'refs';
+ no warnings 'redefine';
+ *{$full_method_name} = subname $full_method_name => $method;
+}
+
+{
+ my $fetch_and_prepare_method = sub {
+ my ($self, $method_name) = @_;
+ # fetch it locally
+ my $method = $self->get_method($method_name);
+ # if we dont have local ...
+ unless ($method) {
+ # make sure this method even exists ...
+ ($self->find_next_method_by_name($method_name))
+ || confess "The method '$method_name' is not found in the inherience hierarchy for this class";
+ # if so, then create a local which just
+ # calls the next applicable method ...
+ $self->add_method($method_name => sub {
+ $self->find_next_method_by_name($method_name)->(@_);
+ });
+ $method = $self->get_method($method_name);
+ }
+
+ # now make sure we wrap it properly
+ # (if it isnt already)
+ unless ($method->isa('Class::MOP::Method::Wrapped')) {
+ $method = Class::MOP::Method::Wrapped->wrap($method);
+ $self->add_method($method_name => $method);
+ }
+ return $method;
+ };
+
+ sub add_before_method_modifier {
+ my ($self, $method_name, $method_modifier) = @_;
+ (defined $method_name && $method_name)
+ || confess "You must pass in a method name";
+ my $method = $fetch_and_prepare_method->($self, $method_name);
+ $method->add_before_modifier(subname ':before' => $method_modifier);
+ }
+
+ sub add_after_method_modifier {
+ my ($self, $method_name, $method_modifier) = @_;
+ (defined $method_name && $method_name)
+ || confess "You must pass in a method name";
+ my $method = $fetch_and_prepare_method->($self, $method_name);
+ $method->add_after_modifier(subname ':after' => $method_modifier);
+ }
+
+ sub add_around_method_modifier {
+ my ($self, $method_name, $method_modifier) = @_;
+ (defined $method_name && $method_name)
+ || confess "You must pass in a method name";
+ my $method = $fetch_and_prepare_method->($self, $method_name);
+ $method->add_around_modifier(subname ':around' => $method_modifier);
+ }
+
+ # NOTE:
+ # the methods above used to be named like this:
+ # ${pkg}::${method}:(before|after|around)
+ # but this proved problematic when using one modifier
+ # to wrap multiple methods (something which is likely
+ # to happen pretty regularly IMO). So instead of naming
+ # it like this, I have chosen to just name them purely
+ # with their modifier names, like so:
+ # :(before|after|around)
+ # The fact is that in a stack trace, it will be fairly
+ # evident from the context what method they are attached
+ # to, and so don't need the fully qualified name.
+}
+
+sub alias_method {
+ my ($self, $method_name, $method) = @_;
+ (defined $method_name && $method_name)
+ || confess "You must define a method name";
+ # use reftype here to allow for blessed subs ...
+ ('CODE' eq (reftype($method) || ''))
+ || confess "Your code block must be a CODE reference";
+ my $full_method_name = ($self->name . '::' . $method_name);
+
+ $method = $self->method_metaclass->wrap($method) unless blessed($method);
+
+ no strict 'refs';
+ no warnings 'redefine';
+ *{$full_method_name} = $method;
+}
+
+sub has_method {
+ my ($self, $method_name) = @_;
+ (defined $method_name && $method_name)
+ || confess "You must define a method name";
+
+ my $sub_name = ($self->name . '::' . $method_name);
+
+ no strict 'refs';
+ return 0 if !defined(&{$sub_name});
+ my $method = \&{$sub_name};
+ return 0 if (svref_2object($method)->GV->STASH->NAME || '') ne $self->name &&
+ (svref_2object($method)->GV->NAME || '') ne '__ANON__';
+
+ # at this point we are relatively sure
+ # it is our method, so we bless/wrap it
+ $self->method_metaclass->wrap($method) unless blessed($method);
+ return 1;
+}
+
+sub get_method {
+ my ($self, $method_name) = @_;
+ (defined $method_name && $method_name)
+ || confess "You must define a method name";
+
+ return unless $self->has_method($method_name);
+
+ no strict 'refs';
+ return \&{$self->name . '::' . $method_name};
+}
+
+sub remove_method {
+ my ($self, $method_name) = @_;
+ (defined $method_name && $method_name)
+ || confess "You must define a method name";
+
+ my $removed_method = $self->get_method($method_name);
+
+ no strict 'refs';
+ delete ${$self->name . '::'}{$method_name}
+ if defined $removed_method;
+
+ return $removed_method;
+}
+
+sub get_method_list {
+ my $self = shift;
+ no strict 'refs';
+ grep { $self->has_method($_) } %{$self->name . '::'};
+}
+
+sub compute_all_applicable_methods {
+ my $self = shift;
+ my @methods;
+ # 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, %seen_method);
+ foreach my $class ($self->class_precedence_list()) {
+ next if $seen_class{$class};
+ $seen_class{$class}++;
+ # fetch the meta-class ...
+ my $meta = $self->initialize($class);
+ foreach my $method_name ($meta->get_method_list()) {
+ next if exists $seen_method{$method_name};
+ $seen_method{$method_name}++;
+ push @methods => {
+ name => $method_name,
+ class => $class,
+ code => $meta->get_method($method_name)
+ };
+ }
+ }
+ return @methods;
+}
+
+sub find_all_methods_by_name {
+ my ($self, $method_name) = @_;
+ (defined $method_name && $method_name)
+ || confess "You must define a method name to find";
+ my @methods;
+ # 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);
+ push @methods => {
+ name => $method_name,
+ class => $class,
+ code => $meta->get_method($method_name)
+ } if $meta->has_method($method_name);
+ }
+ return @methods;
+}
+
+sub find_next_method_by_name {
+ my ($self, $method_name) = @_;
+ (defined $method_name && $method_name)
+ || confess "You must define a method name to find";
+ # 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;
+ my @cpl = $self->class_precedence_list();
+ shift @cpl; # discard ourselves
+ foreach my $class (@cpl) {
+ next if $seen_class{$class};
+ $seen_class{$class}++;
+ # fetch the meta-class ...
+ my $meta = $self->initialize($class);
+ return $meta->get_method($method_name)
+ if $meta->has_method($method_name);
+ }
+ return;
+}
+
+## Attributes
+
+sub add_attribute {
+ my $self = shift;
+ # either we have an attribute object already
+ # or we need to create one from the args provided
+ my $attribute = blessed($_[0]) ? $_[0] : $self->attribute_metaclass->new(@_);
+ # make sure it is derived from the correct type though
+ ($attribute->isa('Class::MOP::Attribute'))
+ || confess "Your attribute must be an instance of Class::MOP::Attribute (or a subclass)";
+ $attribute->attach_to_class($self);
+ $attribute->install_accessors();
+ $self->get_attribute_map->{$attribute->name} = $attribute;
+}
+
+sub has_attribute {
+ my ($self, $attribute_name) = @_;
+ (defined $attribute_name && $attribute_name)
+ || confess "You must define an attribute name";
+ exists $self->get_attribute_map->{$attribute_name} ? 1 : 0;
+}
+
+sub get_attribute {
+ 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);
+ return;
+}
+
+sub remove_attribute {
+ my ($self, $attribute_name) = @_;
+ (defined $attribute_name && $attribute_name)
+ || confess "You must define an attribute name";
+ my $removed_attribute = $self->get_attribute_map->{$attribute_name};
+ return unless defined $removed_attribute;
+ delete $self->get_attribute_map->{$attribute_name};
+ $removed_attribute->remove_accessors();
+ $removed_attribute->detach_from_class();
+ return $removed_attribute;
+}
+
+sub get_attribute_list {
+ my $self = shift;
+ keys %{$self->get_attribute_map};
+}
+
+sub compute_all_applicable_attributes {
+ my $self = shift;
+ my @attrs;
+ # 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, %seen_attr);
+ foreach my $class ($self->class_precedence_list()) {
+ next if $seen_class{$class};
+ $seen_class{$class}++;
+ # fetch the meta-class ...
+ my $meta = $self->initialize($class);
+ foreach my $attr_name ($meta->get_attribute_list()) {
+ next if exists $seen_attr{$attr_name};
+ $seen_attr{$attr_name}++;
+ push @attrs => $meta->get_attribute($attr_name);
+ }
+ }
+ return @attrs;
+}
+
+# Class attributes
+
+sub add_package_variable {
+ my ($self, $variable, $initial_value) = @_;
+ (defined $variable && $variable =~ /^[\$\@\%]/)
+ || confess "variable name does not have a sigil";
+
+ my ($sigil, $name) = ($variable =~ /^(.)(.*)$/);
+ if (defined $initial_value) {
+ no strict 'refs';
+ *{$self->name . '::' . $name} = $initial_value;
+ }
+ else {
+ my $e;
+ {
+ # NOTE:
+ # We HAVE to localize $@ or all
+ # hell breaks loose. It is not
+ # good, believe me, not good.
+ local $@;
+ eval $sigil . $self->name . '::' . $name;
+ $e = $@ if $@;
+ }
+ confess "Could not create package variable ($variable) because : $e" if $e;
+ }
+}
+
+sub has_package_variable {
+ my ($self, $variable) = @_;
+ (defined $variable && $variable =~ /^[\$\@\%]/)
+ || confess "variable name does not have a sigil";
+ my ($sigil, $name) = ($variable =~ /^(.)(.*)$/);
+ no strict 'refs';
+ defined ${$self->name . '::'}{$name} ? 1 : 0;
+}
+
+sub get_package_variable {
+ my ($self, $variable) = @_;
+ (defined $variable && $variable =~ /^[\$\@\%]/)
+ || confess "variable name does not have a sigil";
+ my ($sigil, $name) = ($variable =~ /^(.)(.*)$/);
+ my ($ref, $e);
+ {
+ # NOTE:
+ # We HAVE to localize $@ or all
+ # hell breaks loose. It is not
+ # good, believe me, not good.
+ local $@;
+ $ref = eval '\\' . $sigil . $self->name . '::' . $name;
+ $e = $@ if $@;
+ }
+ confess "Could not get the package variable ($variable) because : $e" if $e;
+ # if we didn't die, then we can return it
+ return $ref;
+}
+
+sub remove_package_variable {
+ my ($self, $variable) = @_;
+ (defined $variable && $variable =~ /^[\$\@\%]/)
+ || confess "variable name does not have a sigil";
+ my ($sigil, $name) = ($variable =~ /^(.)(.*)$/);
+ no strict 'refs';
+ delete ${$self->name . '::'}{$name};
+}
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+Class::MOP::Class - Class Meta Object
+
+=head1 SYNOPSIS
+
+ # assuming that class Foo
+ # has been defined, you can
+
+ # use this for introspection ...
+
+ # add a method to Foo ...
+ Foo->meta->add_method('bar' => sub { ... })
+
+ # get a list of all the classes searched
+ # the method dispatcher in the correct order
+ Foo->meta->class_precedence_list()
+
+ # remove a method from Foo
+ Foo->meta->remove_method('bar');
+
+ # or use this to actually create classes ...
+
+ Class::MOP::Class->create('Bar' => '0.01' => (
+ superclasses => [ 'Foo' ],
+ attributes => [
+ Class::MOP:::Attribute->new('$bar'),
+ Class::MOP:::Attribute->new('$baz'),
+ ],
+ methods => {
+ calculate_bar => sub { ... },
+ construct_baz => sub { ... }
+ }
+ ));
+
+=head1 DESCRIPTION
+
+This is the largest and currently most complex part of the Perl 5
+meta-object protocol. It controls the introspection and
+manipulation of Perl 5 classes (and it can create them too). The
+best way to understand what this module can do, is to read the
+documentation for each of it's methods.
+
+=head1 METHODS
+
+=head2 Self Introspection
+
+=over 4
+
+=item B<meta>
+
+This will return a B<Class::MOP::Class> instance which is related
+to this class. Thereby allowing B<Class::MOP::Class> to actually
+introspect itself.
+
+As with B<Class::MOP::Attribute>, B<Class::MOP> will actually
+bootstrap this module by installing a number of attribute meta-objects
+into it's metaclass. This will allow this class to reap all the benifits
+of the MOP when subclassing it.
+
+=back
+
+=head2 Class construction
+
+These methods will handle creating B<Class::MOP::Class> objects,
+which can be used to both create new classes, and analyze
+pre-existing classes.
+
+This module will internally store references to all the instances
+you create with these methods, so that they do not need to be
+created any more than nessecary. Basically, they are singletons.
+
+=over 4
+
+=item B<create ($package_name, ?$package_version,
+ superclasses =E<gt> ?@superclasses,
+ methods =E<gt> ?%methods,
+ attributes =E<gt> ?%attributes)>
+
+This returns a B<Class::MOP::Class> object, bringing the specified
+C<$package_name> into existence and adding any of the
+C<$package_version>, C<@superclasses>, C<%methods> and C<%attributes>
+to it.
+
+=item B<initialize ($package_name)>
+
+This initializes and returns returns a B<Class::MOP::Class> object
+for a given a C<$package_name>.
+
+=item B<construct_class_instance (%options)>
+
+This will construct an instance of B<Class::MOP::Class>, it is
+here so that we can actually "tie the knot" for B<Class::MOP::Class>
+to use C<construct_instance> once all the bootstrapping is done. This
+method is used internally by C<initialize> and should never be called
+from outside of that method really.
+
+=item B<check_metaclass_compatability>
+
+This method is called as the very last thing in the
+C<construct_class_instance> method. This will check that the
+metaclass you are creating is compatible with the metaclasses of all
+your ancestors. For more inforamtion about metaclass compatibility
+see the C<About Metaclass compatibility> section in L<Class::MOP>.
+
+=back
+
+=head2 Object instance construction and cloning
+
+These methods are B<entirely optional>, it is up to you whether you want
+to use them or not.
+
+=over 4
+
+=item B<new_object (%params)>
+
+This is a convience method for creating a new object of the class, and
+blessing it into the appropriate package as well. Ideally your class
+would call a C<new> this method like so:
+
+ sub MyClass::new {
+ my ($class, %param) = @_;
+ $class->meta->new_object(%params);
+ }
+
+Of course the ideal place for this would actually be in C<UNIVERSAL::>
+but that is considered bad style, so we do not do that.
+
+=item B<construct_instance (%params)>
+
+This method is used to construct an instace structure suitable for
+C<bless>-ing into your package of choice. It works in conjunction
+with the Attribute protocol to collect all applicable attributes.
+
+This will construct and instance using a HASH ref as storage
+(currently only HASH references are supported). This will collect all
+the applicable attributes and layout out the fields in the HASH ref,
+it will then initialize them using either use the corresponding key
+in C<%params> or any default value or initializer found in the
+attribute meta-object.
+
+=item B<clone_object ($instance, %params)>
+
+This is a convience method for cloning an object instance, then
+blessing it into the appropriate package. This method will call
+C<clone_instance>, which performs a shallow copy of the object,
+see that methods documentation for more details. Ideally your
+class would call a C<clone> this method like so:
+
+ sub MyClass::clone {
+ my ($self, %param) = @_;
+ $self->meta->clone_object($self, %params);
+ }
+
+Of course the ideal place for this would actually be in C<UNIVERSAL::>
+but that is considered bad style, so we do not do that.
+
+=item B<clone_instance($instance, %params)>
+
+This method is a compliment of C<construct_instance> (which means if
+you override C<construct_instance>, you need to override this one too),
+and clones the instance shallowly.
+
+The cloned structure returned is (like with C<construct_instance>) an
+unC<bless>ed HASH reference, it is your responsibility to then bless
+this cloned structure into the right class (which C<clone_object> will
+do for you).
+
+As of 0.11, this method will clone the C<$instance> structure shallowly,
+as opposed to the deep cloning implemented in prior versions. After much
+thought, research and discussion, I have decided that anything but basic
+shallow cloning is outside the scope of the meta-object protocol. I
+think Yuval "nothingmuch" Kogman put it best when he said that cloning
+is too I<context-specific> to be part of the MOP.
+
+=back
+
+=head2 Informational
+
+=over 4
+
+=item B<name>
+
+This is a read-only attribute which returns the package name for the
+given B<Class::MOP::Class> instance.
+
+=item B<version>
+
+This is a read-only attribute which returns the C<$VERSION> of the
+package for the given B<Class::MOP::Class> instance.
+
+=back
+
+=head2 Inheritance Relationships
+
+=over 4
+
+=item B<superclasses (?@superclasses)>
+
+This is a read-write attribute which represents the superclass
+relationships of the class the B<Class::MOP::Class> instance is
+associated with. Basically, it can get and set the C<@ISA> for you.
+
+B<NOTE:>
+Perl will occasionally perform some C<@ISA> and method caching, if
+you decide to change your superclass relationship at runtime (which
+is quite insane and very much not recommened), then you should be
+aware of this and the fact that this module does not make any
+attempt to address this issue.
+
+=item B<class_precedence_list>
+
+This computes the a list of all the class's ancestors in the same order
+in which method dispatch will be done. This is similair to
+what B<Class::ISA::super_path> does, but we don't remove duplicate names.
+
+=back
+
+=head2 Methods
+
+=over 4
+
+=item B<method_metaclass>
+
+=item B<add_method ($method_name, $method)>
+
+This will take a C<$method_name> and CODE reference to that
+C<$method> and install it into the class's package.
+
+B<NOTE>:
+This does absolutely nothing special to C<$method>
+other than use B<Sub::Name> to make sure it is tagged with the
+correct name, and therefore show up correctly in stack traces and
+such.
+
+=item B<alias_method ($method_name, $method)>
+
+This will take a C<$method_name> and CODE reference to that
+C<$method> and alias the method into the class's package.
+
+B<NOTE>:
+Unlike C<add_method>, this will B<not> try to name the
+C<$method> using B<Sub::Name>, it only aliases the method in
+the class's package.
+
+=item B<has_method ($method_name)>
+
+This just provides a simple way to check if the class implements
+a specific C<$method_name>. It will I<not> however, attempt to check
+if the class inherits the method (use C<UNIVERSAL::can> for that).
+
+This will correctly handle functions defined outside of the package
+that use a fully qualified name (C<sub Package::name { ... }>).
+
+This will correctly handle functions renamed with B<Sub::Name> 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<has_method> to
+correctly identify it.
+
+This will attempt to correctly ignore functions imported from other
+packages using B<Exporter>. It breaks down if the function imported
+is an C<__ANON__> sub (such as with C<use constant>), which very well
+may be a valid method being applied to the class.
+
+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 I think.
+
+=item B<get_method ($method_name)>
+
+This will return a CODE reference of the specified C<$method_name>,
+or return undef if that method does not exist.
+
+=item B<remove_method ($method_name)>
+
+This will attempt to remove a given C<$method_name> from the class.
+It will return the CODE reference that it has removed, and will
+attempt to use B<Sub::Name> to clear the methods associated name.
+
+=item B<get_method_list>
+
+This will return a list of method names for all I<locally> defined
+methods. It does B<not> provide a list of all applicable methods,
+including any inherited ones. If you want a list of all applicable
+methods, use the C<compute_all_applicable_methods> method.
+
+=item B<compute_all_applicable_methods>
+
+This will return a list of all the methods names this class will
+respond to, taking into account inheritance. The list will be a list of
+HASH references, each one containing the following information; method
+name, the name of the class in which the method lives and a CODE
+reference for the actual method.
+
+=item B<find_all_methods_by_name ($method_name)>
+
+This will traverse the inheritence hierarchy and locate all methods
+with a given C<$method_name>. Similar to
+C<compute_all_applicable_methods> it returns a list of HASH references
+with the following information; method name (which will always be the
+same as C<$method_name>), the name of the class in which the method
+lives and a CODE reference for the actual method.
+
+The list of methods produced is a distinct list, meaning there are no
+duplicates in it. This is especially useful for things like object
+initialization and destruction where you only want the method called
+once, and in the correct order.
+
+=item B<find_next_method_by_name ($method_name)>
+
+This will return the first method to match a given C<$method_name> in
+the superclasses, this is basically equivalent to calling
+C<SUPER::$method_name>, but it can be dispatched at runtime.
+
+=back
+
+=head2 Method Modifiers
+
+Method modifiers are a concept borrowed from CLOS, in which a method
+can be wrapped with I<before>, I<after> and I<around> method modifiers
+that will be called everytime the method is called.
+
+=head3 How method modifiers work?
+
+Method modifiers work by wrapping the original method and then replacing
+it in the classes symbol table. The wrappers will handle calling all the
+modifiers in the appropariate orders and preserving the calling context
+for the original method.
+
+Each method modifier serves a particular purpose, which may not be
+obvious to users of other method wrapping modules. To start with, the
+return values of I<before> and I<after> modifiers are ignored. This is
+because thier purpose is B<not> to filter the input and output of the
+primary method (this is done with an I<around> modifier). This may seem
+like an odd restriction to some, but doing this allows for simple code
+to be added at the begining or end of a method call without jeapordizing
+the normal functioning of the primary method or placing any extra
+responsibility on the code of the modifier. Of course if you have more
+complex needs, then use the I<around> modifier, which uses a variation
+of continutation passing style to allow for a high degree of flexibility.
+
+Before and around modifiers are called in last-defined-first-called order,
+while after modifiers are called in first-defined-first-called order. So
+the call tree might looks something like this:
+
+ before 2
+ before 1
+ around 2
+ around 1
+ primary
+ after 1
+ after 2
+
+To see examples of using method modifiers, see the following examples
+included in the distribution; F<InstanceCountingClass>, F<Perl6Attribute>,
+F<AttributesWithHistory> and F<C3MethodDispatchOrder>. There is also a
+classic CLOS usage example in the test F<017_add_method_modifier.t>.
+
+=head3 What is the performance impact?
+
+Of course there is a performance cost associated with method modifiers,
+but we have made every effort to make that cost be directly proportional
+to the amount of modifier features you utilize.
+
+The wrapping method does it's best to B<only> do as much work as it
+absolutely needs to. In order to do this we have moved some of the
+performance costs to set-up time, where they are easier to amortize.
+
+All this said, my benchmarks have indicated the following:
+
+ simple wrapper with no modifiers 100% slower
+ simple wrapper with simple before modifier 400% slower
+ simple wrapper with simple after modifier 450% slower
+ simple wrapper with simple around modifier 500-550% slower
+ simple wrapper with all 3 modifiers 1100% slower
+
+These numbers may seem daunting, but you must remember, every feature
+comes with some cost. To put things in perspective, just doing a simple
+C<AUTOLOAD> which does nothing but extract the name of the method called
+and return it costs about 400% over a normal method call.
+
+=over 4
+
+=item B<add_before_method_modifier ($method_name, $code)>
+
+This will wrap the method at C<$method_name> and the supplied C<$code>
+will be passed the C<@_> arguments, and called before the original
+method is called. As specified above, the return value of the I<before>
+method modifiers is ignored, and it's ability to modify C<@_> is
+fairly limited. If you need to do either of these things, use an
+C<around> method modifier.
+
+=item B<add_after_method_modifier ($method_name, $code)>
+
+This will wrap the method at C<$method_name> so that the original
+method will be called, it's return values stashed, and then the
+supplied C<$code> will be passed the C<@_> arguments, and called.
+As specified above, the return value of the I<after> method
+modifiers is ignored, and it cannot modify the return values of
+the original method. If you need to do either of these things, use an
+C<around> method modifier.
+
+=item B<add_around_method_modifier ($method_name, $code)>
+
+This will wrap the method at C<$method_name> so that C<$code>
+will be called and passed the original method as an extra argument
+at the begining of the C<@_> argument list. This is a variation of
+continuation passing style, where the function prepended to C<@_>
+can be considered a continuation. It is up to C<$code> if it calls
+the original method or not, there is no restriction on what the
+C<$code> can or cannot do.
+
+=back
+
+=head2 Attributes
+
+It should be noted that since there is no one consistent way to define
+the attributes of a class in Perl 5. These methods can only work with
+the information given, and can not easily discover information on
+their own. See L<Class::MOP::Attribute> for more details.
+
+=over 4
+
+=item B<attribute_metaclass>
+
+=item B<get_attribute_map>
+
+=item B<add_attribute ($attribute_name, $attribute_meta_object)>
+
+This stores a C<$attribute_meta_object> in the B<Class::MOP::Class>
+instance associated with the given class, and associates it with
+the C<$attribute_name>. Unlike methods, attributes within the MOP
+are stored as meta-information only. They will be used later to
+construct instances from (see C<construct_instance> above).
+More details about the attribute meta-objects can be found in the
+L<Class::MOP::Attribute> or the L<Class::MOP/The Attribute protocol>
+section.
+
+It should be noted that any accessor, reader/writer or predicate
+methods which the C<$attribute_meta_object> has will be installed
+into the class at this time.
+
+=item B<has_attribute ($attribute_name)>
+
+Checks to see if this class has an attribute by the name of
+C<$attribute_name> and returns a boolean.
+
+=item B<get_attribute ($attribute_name)>
+
+Returns the attribute meta-object associated with C<$attribute_name>,
+if none is found, it will return undef.
+
+=item B<remove_attribute ($attribute_name)>
+
+This will remove the attribute meta-object stored at
+C<$attribute_name>, then return the removed attribute meta-object.
+
+B<NOTE:>
+Removing an attribute will only affect future instances of
+the class, it will not make any attempt to remove the attribute from
+any existing instances of the class.
+
+It should be noted that any accessor, reader/writer or predicate
+methods which the attribute meta-object stored at C<$attribute_name>
+has will be removed from the class at this time. This B<will> make
+these attributes somewhat inaccessable in previously created
+instances. But if you are crazy enough to do this at runtime, then
+you are crazy enough to deal with something like this :).
+
+=item B<get_attribute_list>
+
+This returns a list of attribute names which are defined in the local
+class. If you want a list of all applicable attributes for a class,
+use the C<compute_all_applicable_attributes> method.
+
+=item B<compute_all_applicable_attributes>
+
+This will traverse the inheritance heirachy and return a list of all
+the applicable attributes for this class. It does not construct a
+HASH reference like C<compute_all_applicable_methods> because all
+that same information is discoverable through the attribute
+meta-object itself.
+
+=back
+
+=head2 Package Variables
+
+Since Perl's classes are built atop the Perl package system, it is
+fairly common to use package scoped variables for things like static
+class variables. The following methods are convience methods for
+the creation and inspection of package scoped variables.
+
+=over 4
+
+=item B<add_package_variable ($variable_name, ?$initial_value)>
+
+Given a C<$variable_name>, which must contain a leading sigil, this
+method will create that variable within the package which houses the
+class. It also takes an optional C<$initial_value>, which must be a
+reference of the same type as the sigil of the C<$variable_name>
+implies.
+
+=item B<get_package_variable ($variable_name)>
+
+This will return a reference to the package variable in
+C<$variable_name>.
+
+=item B<has_package_variable ($variable_name)>
+
+Returns true (C<1>) if there is a package variable defined for
+C<$variable_name>, and false (C<0>) otherwise.
+
+=item B<remove_package_variable ($variable_name)>
+
+This will attempt to remove the package variable at C<$variable_name>.
+
+=back
+
+=head1 AUTHOR
+
+Stevan Little E<lt>stevan at iinteractive.comE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2006 by Infinity Interactive, Inc.
+
+L<http://www.iinteractive.com>
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
Added: packages/libclass-mop-perl/branches/upstream/current/lib/Class/MOP/Method.pm
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libclass-mop-perl/branches/upstream/current/lib/Class/MOP/Method.pm?rev=2608&op=file
==============================================================================
--- packages/libclass-mop-perl/branches/upstream/current/lib/Class/MOP/Method.pm (added)
+++ packages/libclass-mop-perl/branches/upstream/current/lib/Class/MOP/Method.pm Thu Apr 20 11:21:04 2006
@@ -1,0 +1,299 @@
+
+package Class::MOP::Method;
+
+use strict;
+use warnings;
+
+use Carp 'confess';
+use Scalar::Util 'reftype', 'blessed';
+use B 'svref_2object';
+
+our $VERSION = '0.02';
+
+# introspection
+
+sub meta {
+ require Class::MOP::Class;
+ Class::MOP::Class->initialize(blessed($_[0]) || $_[0]);
+}
+
+# construction
+
+sub wrap {
+ my $class = shift;
+ my $code = shift;
+ ('CODE' eq (reftype($code) || ''))
+ || confess "You must supply a CODE reference to bless";
+ bless $code => blessed($class) || $class;
+}
+
+# informational
+
+sub package_name {
+ my $code = shift;
+ (blessed($code))
+ || confess "Can only ask the package name of a blessed CODE";
+ svref_2object($code)->GV->STASH->NAME;
+}
+
+sub name {
+ my $code = shift;
+ (blessed($code))
+ || confess "Can only ask the package name of a blessed CODE";
+ svref_2object($code)->GV->NAME;
+}
+
+sub fully_qualified_name {
+ my $code = shift;
+ (blessed($code))
+ || confess "Can only ask the package name of a blessed CODE";
+ $code->package_name . '::' . $code->name;
+}
+
+package Class::MOP::Method::Wrapped;
+
+use strict;
+use warnings;
+
+use Carp 'confess';
+use Scalar::Util 'reftype', 'blessed';
+use Sub::Name 'subname';
+
+our $VERSION = '0.01';
+
+our @ISA = ('Class::MOP::Method');
+
+# NOTE:
+# this ugly beast is the result of trying
+# to micro optimize this as much as possible
+# while not completely loosing maintainability.
+# At this point it's "fast enough", after all
+# you can't get something for nothing :)
+my $_build_wrapped_method = sub {
+ my $modifier_table = shift;
+ my ($before, $after, $around) = (
+ $modifier_table->{before},
+ $modifier_table->{after},
+ $modifier_table->{around},
+ );
+ if (@$before && @$after) {
+ $modifier_table->{cache} = sub {
+ $_->(@_) for @{$before};
+ my @rval;
+ ((defined wantarray) ?
+ ((wantarray) ?
+ (@rval = $around->{cache}->(@_))
+ :
+ ($rval[0] = $around->{cache}->(@_)))
+ :
+ $around->{cache}->(@_));
+ $_->(@_) for @{$after};
+ return unless defined wantarray;
+ return wantarray ? @rval : $rval[0];
+ }
+ }
+ elsif (@$before && !@$after) {
+ $modifier_table->{cache} = sub {
+ $_->(@_) for @{$before};
+ return $around->{cache}->(@_);
+ }
+ }
+ elsif (@$after && !@$before) {
+ $modifier_table->{cache} = sub {
+ my @rval;
+ ((defined wantarray) ?
+ ((wantarray) ?
+ (@rval = $around->{cache}->(@_))
+ :
+ ($rval[0] = $around->{cache}->(@_)))
+ :
+ $around->{cache}->(@_));
+ $_->(@_) for @{$after};
+ return unless defined wantarray;
+ return wantarray ? @rval : $rval[0];
+ }
+ }
+ else {
+ $modifier_table->{cache} = $around->{cache};
+ }
+};
+
+my %MODIFIERS;
+
+sub wrap {
+ my $class = shift;
+ my $code = shift;
+ (blessed($code) && $code->isa('Class::MOP::Method'))
+ || confess "Can only wrap blessed CODE";
+ my $modifier_table = {
+ cache => undef,
+ orig => $code,
+ before => [],
+ after => [],
+ around => {
+ cache => $code,
+ methods => [],
+ },
+ };
+ $_build_wrapped_method->($modifier_table);
+ my $method = $class->SUPER::wrap(sub { $modifier_table->{cache}->(@_) });
+ $MODIFIERS{$method} = $modifier_table;
+ $method;
+}
+
+sub add_before_modifier {
+ my $code = shift;
+ my $modifier = shift;
+ (exists $MODIFIERS{$code})
+ || confess "You must first wrap your method before adding a modifier";
+ (blessed($code))
+ || confess "Can only ask the package name of a blessed CODE";
+ ('CODE' eq (reftype($code) || ''))
+ || confess "You must supply a CODE reference for a modifier";
+ unshift @{$MODIFIERS{$code}->{before}} => $modifier;
+ $_build_wrapped_method->($MODIFIERS{$code});
+}
+
+sub add_after_modifier {
+ my $code = shift;
+ my $modifier = shift;
+ (exists $MODIFIERS{$code})
+ || confess "You must first wrap your method before adding a modifier";
+ (blessed($code))
+ || confess "Can only ask the package name of a blessed CODE";
+ ('CODE' eq (reftype($code) || ''))
+ || confess "You must supply a CODE reference for a modifier";
+ push @{$MODIFIERS{$code}->{after}} => $modifier;
+ $_build_wrapped_method->($MODIFIERS{$code});
+}
+
+{
+ # NOTE:
+ # this is another possible canidate for
+ # optimization as well. There is an overhead
+ # associated with the currying that, if
+ # eliminated might make around modifiers
+ # more manageable.
+ my $compile_around_method = sub {{
+ my $f1 = pop;
+ return $f1 unless @_;
+ my $f2 = pop;
+ push @_, sub { $f2->( $f1, @_ ) };
+ redo;
+ }};
+
+ sub add_around_modifier {
+ my $code = shift;
+ my $modifier = shift;
+ (exists $MODIFIERS{$code})
+ || confess "You must first wrap your method before adding a modifier";
+ (blessed($code))
+ || confess "Can only ask the package name of a blessed CODE";
+ ('CODE' eq (reftype($code) || ''))
+ || confess "You must supply a CODE reference for a modifier";
+ unshift @{$MODIFIERS{$code}->{around}->{methods}} => $modifier;
+ $MODIFIERS{$code}->{around}->{cache} = $compile_around_method->(
+ @{$MODIFIERS{$code}->{around}->{methods}},
+ $MODIFIERS{$code}->{orig}
+ );
+ $_build_wrapped_method->($MODIFIERS{$code});
+ }
+}
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+Class::MOP::Method - Method Meta Object
+
+=head1 SYNOPSIS
+
+ # ... more to come later maybe
+
+=head1 DESCRIPTION
+
+The Method Protocol is very small, since methods in Perl 5 are just
+subroutines within the particular package. Basically all we do is to
+bless the subroutine.
+
+Currently this package is largely unused. Future plans are to provide
+some very simple introspection methods for the methods themselves.
+Suggestions for this are welcome.
+
+=head1 METHODS
+
+=head2 Introspection
+
+=over 4
+
+=item B<meta>
+
+This will return a B<Class::MOP::Class> instance which is related
+to this class.
+
+=back
+
+=head2 Construction
+
+=over 4
+
+=item B<wrap (&code)>
+
+This simply blesses the C<&code> reference passed to it.
+
+=back
+
+=head2 Informational
+
+=over 4
+
+=item B<name>
+
+=item B<package_name>
+
+=item B<fully_qualified_name>
+
+=back
+
+=head1 Class::MOP::Method::Wrapped METHODS
+
+=head2 Construction
+
+=over 4
+
+=item B<wrap (&code)>
+
+This simply blesses the C<&code> reference passed to it.
+
+=back
+
+=head2 Modifiers
+
+=over 4
+
+=item B<add_before_modifier ($code)>
+
+=item B<add_after_modifier ($code)>
+
+=item B<add_around_modifier ($code)>
+
+=back
+
+=head1 AUTHOR
+
+Stevan Little E<lt>stevan at iinteractive.comE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2006 by Infinity Interactive, Inc.
+
+L<http://www.iinteractive.com>
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
Added: packages/libclass-mop-perl/branches/upstream/current/lib/metaclass.pm
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libclass-mop-perl/branches/upstream/current/lib/metaclass.pm?rev=2608&op=file
==============================================================================
--- packages/libclass-mop-perl/branches/upstream/current/lib/metaclass.pm (added)
+++ packages/libclass-mop-perl/branches/upstream/current/lib/metaclass.pm Thu Apr 20 11:21:04 2006
@@ -1,0 +1,82 @@
+
+package metaclass;
+
+use strict;
+use warnings;
+
+use Carp 'confess';
+use Scalar::Util 'blessed';
+
+our $VERSION = '0.02';
+
+use Class::MOP;
+
+sub import {
+ shift;
+ my $metaclass = shift || 'Class::MOP::Class';
+ my %options = @_;
+ my $package = caller();
+
+ ($metaclass->isa('Class::MOP::Class'))
+ || confess 'The metaclass must be derived from Class::MOP::Class';
+
+ # create a meta object so we can install &meta
+ my $meta = $metaclass->initialize($package => %options);
+ $meta->add_method('meta' => sub {
+ # we must re-initialize so that it
+ # works as expected in subclasses,
+ # since metaclass instances are
+ # singletons, this is not really a
+ # big deal anyway.
+ $metaclass->initialize((blessed($_[0]) || $_[0]) => %options)
+ });
+}
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+metaclass - a pragma for installing and using Class::MOP metaclasses
+
+=head1 SYNOPSIS
+
+ package MyClass;
+
+ # use Class::MOP::Class
+ use metaclass;
+
+ # ... or use a custom metaclass
+ use metaclass 'MyMetaClass';
+
+ # ... or use a custom metaclass
+ # and custom attribute and method
+ # metaclasses
+ use metaclass 'MyMetaClass' => (
+ ':attribute_metaclass' => 'MyAttributeMetaClass',
+ ':method_metaclass' => 'MyMethodMetaClass',
+ );
+
+=head1 DESCRIPTION
+
+This is a pragma to make it easier to use a specific metaclass
+and a set of custom attribute and method metaclasses. It also
+installs a C<meta> method to your class as well.
+
+=head1 AUTHOR
+
+Stevan Little E<lt>stevan at iinteractive.comE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2006 by Infinity Interactive, Inc.
+
+L<http://www.iinteractive.com>
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
Added: packages/libclass-mop-perl/branches/upstream/current/t/000_load.t
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libclass-mop-perl/branches/upstream/current/t/000_load.t?rev=2608&op=file
==============================================================================
--- packages/libclass-mop-perl/branches/upstream/current/t/000_load.t (added)
+++ packages/libclass-mop-perl/branches/upstream/current/t/000_load.t Thu Apr 20 11:21:04 2006
@@ -1,0 +1,13 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 4;
+
+BEGIN {
+ use_ok('Class::MOP');
+ use_ok('Class::MOP::Class');
+ use_ok('Class::MOP::Attribute');
+ use_ok('Class::MOP::Method');
+}
Added: packages/libclass-mop-perl/branches/upstream/current/t/001_basic.t
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libclass-mop-perl/branches/upstream/current/t/001_basic.t?rev=2608&op=file
==============================================================================
--- packages/libclass-mop-perl/branches/upstream/current/t/001_basic.t (added)
+++ packages/libclass-mop-perl/branches/upstream/current/t/001_basic.t Thu Apr 20 11:21:04 2006
@@ -1,0 +1,69 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 19;
+use Test::Exception;
+
+BEGIN {
+ use_ok('Class::MOP');
+ use_ok('Class::MOP::Class');
+}
+
+{
+ package Foo;
+ use metaclass;
+ our $VERSION = '0.01';
+
+ package Bar;
+ our @ISA = ('Foo');
+}
+
+my $Foo = Foo->meta;
+isa_ok($Foo, 'Class::MOP::Class');
+
+my $Bar = Bar->meta;
+isa_ok($Bar, 'Class::MOP::Class');
+
+is($Foo->name, 'Foo', '... Foo->name == Foo');
+is($Bar->name, 'Bar', '... Bar->name == Bar');
+
+is($Foo->version, '0.01', '... Foo->version == 0.01');
+is($Bar->version, undef, '... Bar->version == undef');
+
+is_deeply([$Foo->superclasses], [], '... Foo has no superclasses');
+is_deeply([$Bar->superclasses], ['Foo'], '... Bar->superclasses == (Foo)');
+
+$Foo->superclasses('UNIVERSAL');
+
+is_deeply([$Foo->superclasses], ['UNIVERSAL'], '... Foo->superclasses == (UNIVERSAL) now');
+
+is_deeply(
+ [ $Foo->class_precedence_list ],
+ [ 'Foo', 'UNIVERSAL' ],
+ '... Foo->class_precedence_list == (Foo, UNIVERSAL)');
+
+is_deeply(
+ [ $Bar->class_precedence_list ],
+ [ 'Bar', 'Foo', 'UNIVERSAL' ],
+ '... Bar->class_precedence_list == (Bar, Foo, UNIVERSAL)');
+
+# create a class using Class::MOP::Class ...
+
+my $Baz = Class::MOP::Class->create(
+ 'Baz' => '0.10' => (
+ superclasses => [ 'Bar' ]
+ ));
+isa_ok($Baz, 'Class::MOP::Class');
+is(Baz->meta, $Baz, '... our metaclasses are singletons');
+
+is($Baz->name, 'Baz', '... Baz->name == Baz');
+is($Baz->version, '0.10', '... Baz->version == 0.10');
+
+is_deeply([$Baz->superclasses], ['Bar'], '... Baz->superclasses == (Bar)');
+
+is_deeply(
+ [ $Baz->class_precedence_list ],
+ [ 'Baz', 'Bar', 'Foo', 'UNIVERSAL' ],
+ '... Baz->class_precedence_list == (Baz, Bar, Foo, UNIVERSAL)');
Added: packages/libclass-mop-perl/branches/upstream/current/t/002_class_precedence_list.t
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libclass-mop-perl/branches/upstream/current/t/002_class_precedence_list.t?rev=2608&op=file
==============================================================================
--- packages/libclass-mop-perl/branches/upstream/current/t/002_class_precedence_list.t (added)
+++ packages/libclass-mop-perl/branches/upstream/current/t/002_class_precedence_list.t Thu Apr 20 11:21:04 2006
@@ -1,0 +1,148 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 6;
+
+BEGIN {
+ use_ok('Class::MOP');
+ use_ok('Class::MOP::Class');
+}
+
+=pod
+
+ A
+ / \
+B C
+ \ /
+ D
+
+=cut
+
+{
+ package My::A;
+ use metaclass;
+ package My::B;
+ our @ISA = ('My::A');
+ package My::C;
+ our @ISA = ('My::A');
+ package My::D;
+ our @ISA = ('My::B', 'My::C');
+}
+
+is_deeply(
+ [ My::D->meta->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
+
+ A <-+
+ | |
+ B |
+ | |
+ C --+
+
+=cut
+
+{
+ package My::2::A;
+ use metaclass;
+ our @ISA = ('My::2::C');
+
+ package My::2::B;
+ our @ISA = ('My::2::A');
+
+ package My::2::C;
+ our @ISA = ('My::2::B');
+}
+
+eval { My::2::B->meta->class_precedence_list };
+ok($@, '... recursive inheritance breaks correctly :)');
+
+=pod
+
+ +--------+
+ | A |
+ | / \ |
+ +->B C-+
+ \ /
+ D
+
+=cut
+
+{
+ package My::3::A;
+ use metaclass;
+ package My::3::B;
+ our @ISA = ('My::3::A');
+ package My::3::C;
+ our @ISA = ('My::3::A', 'My::3::B');
+ package My::3::D;
+ our @ISA = ('My::3::B', 'My::3::C');
+}
+
+is_deeply(
+ [ My::3::D->meta->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)');
+
+=pod
+
+Test all the class_precedence_lists
+using Perl's own dispatcher to check
+against.
+
+=cut
+
+my @CLASS_PRECEDENCE_LIST;
+
+{
+ package Foo;
+ use metaclass;
+
+ sub CPL { push @CLASS_PRECEDENCE_LIST => 'Foo' }
+
+ package Bar;
+ our @ISA = ('Foo');
+
+ sub CPL {
+ push @CLASS_PRECEDENCE_LIST => 'Bar';
+ $_[0]->SUPER::CPL();
+ }
+
+ package Baz;
+ use metaclass;
+ our @ISA = ('Bar');
+
+ sub CPL {
+ push @CLASS_PRECEDENCE_LIST => 'Baz';
+ $_[0]->SUPER::CPL();
+ }
+
+ package Foo::Bar;
+ our @ISA = ('Baz');
+
+ sub CPL {
+ push @CLASS_PRECEDENCE_LIST => 'Foo::Bar';
+ $_[0]->SUPER::CPL();
+ }
+
+ package Foo::Bar::Baz;
+ our @ISA = ('Foo::Bar');
+
+ sub CPL {
+ push @CLASS_PRECEDENCE_LIST => 'Foo::Bar::Baz';
+ $_[0]->SUPER::CPL();
+ }
+
+}
+
+Foo::Bar::Baz->CPL();
+
+is_deeply(
+ [ Foo::Bar::Baz->meta->class_precedence_list ],
+ [ @CLASS_PRECEDENCE_LIST ],
+ '... Foo::Bar::Baz->meta->class_precedence_list == @CLASS_PRECEDENCE_LIST');
+
Added: packages/libclass-mop-perl/branches/upstream/current/t/003_methods.t
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libclass-mop-perl/branches/upstream/current/t/003_methods.t?rev=2608&op=file
==============================================================================
--- packages/libclass-mop-perl/branches/upstream/current/t/003_methods.t (added)
+++ packages/libclass-mop-perl/branches/upstream/current/t/003_methods.t Thu Apr 20 11:21:04 2006
@@ -1,0 +1,225 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 52;
+use Test::Exception;
+
+BEGIN {
+ use_ok('Class::MOP');
+ 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 }
+
+ package main;
+
+ sub Foo::blah { $_[0]->Foo::baz() }
+
+ {
+ no strict 'refs';
+ *{'Foo::bling'} = sub { '$$Bling$$' };
+ *{'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 = Class::MOP::Class->initialize('Foo');
+
+my $foo = sub { 'Foo::foo' };
+
+ok(!UNIVERSAL::isa($foo, 'Class::MOP::Method'), '... our method is not yet blessed');
+
+lives_ok {
+ $Foo->add_method('foo' => $foo);
+} '... we added the method successfully';
+
+isa_ok($foo, 'Class::MOP::Method');
+
+is($foo->name, 'foo', '... got the right name for the method');
+is($foo->package_name, 'Foo', '... got the right package name for the method');
+
+ok($Foo->has_method('foo'), '... Foo->has_method(foo) (defined with Sub::Name)');
+
+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('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::)');
+
+# calling get_method blessed them all
+isa_ok($_, 'Class::MOP::Method') for (
+ \&Foo::FOO_CONSTANT,
+ \&Foo::bar,
+ \&Foo::baz,
+ \&Foo::floob,
+ \&Foo::blah,
+ \&Foo::bling,
+ \&Foo::bang,
+ \&Foo::evaled_foo,
+ );
+
+{
+ package Foo::Aliasing;
+ use metaclass;
+ sub alias_me { '...' }
+}
+
+$Foo->alias_method('alias_me' => Foo::Aliasing->meta->get_method('alias_me'));
+
+ok(!$Foo->has_method('alias_me'), '... !Foo->has_method(alias_me) (aliased from Foo::Aliasing)');
+ok(defined &Foo::alias_me, '... Foo does have a symbol table slow for alias_me though');
+
+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)');
+
+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');
+
+is_deeply(
+ [ sort $Foo->get_method_list ],
+ [ qw(FOO_CONSTANT bang bar baz blah bling evaled_foo floob foo) ],
+ '... got the right method list for Foo');
+
+is_deeply(
+ [ sort { $a->{name} cmp $b->{name} } $Foo->compute_all_applicable_methods() ],
+ [
+ map {
+ {
+ name => $_,
+ class => 'Foo',
+ code => $Foo->get_method($_)
+ }
+ } qw(
+ FOO_CONSTANT
+ bang
+ bar
+ baz
+ blah
+ bling
+ evaled_foo
+ floob
+ foo
+ )
+ ],
+ '... got the right list of applicable methods for Foo');
+
+is($Foo->remove_method('foo'), $foo, '... removed the foo method');
+ok(!$Foo->has_method('foo'), '... !Foo->has_method(foo) we just removed it');
+dies_ok { Foo->foo } '... cannot call Foo->foo because it is not there';
+
+is_deeply(
+ [ sort $Foo->get_method_list ],
+ [ qw(FOO_CONSTANT bang bar baz blah bling evaled_foo floob) ],
+ '... got the right method list for Foo');
+
+ok($Foo->remove_method('FOO_CONSTANT'), '... removed the FOO_CONSTANT method');
+ok(!$Foo->has_method('FOO_CONSTANT'), '... !Foo->has_method(FOO_CONSTANT) we just removed it');
+dies_ok { Foo->FOO_CONSTANT } '... cannot call Foo->FOO_CONSTANT because it is not there';
+
+is_deeply(
+ [ sort $Foo->get_method_list ],
+ [ qw(bang bar baz blah bling evaled_foo floob) ],
+ '... got the right method list for Foo');
+
+# ... test our class creator
+
+my $Bar = Class::MOP::Class->create(
+ 'Bar' => '0.10' => (
+ superclasses => [ 'Foo' ],
+ 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"');
+
+is_deeply(
+ [ sort $Bar->get_method_list ],
+ [ qw(bar foo meta) ],
+ '... got the right method list for Bar');
+
+is_deeply(
+ [ sort { $a->{name} cmp $b->{name} } $Bar->compute_all_applicable_methods() ],
+ [
+ {
+ name => 'bang',
+ class => 'Foo',
+ code => $Foo->get_method('bang')
+ },
+ {
+ name => 'bar',
+ class => 'Bar',
+ code => $Bar->get_method('bar')
+ },
+ (map {
+ {
+ name => $_,
+ class => 'Foo',
+ code => $Foo->get_method($_)
+ }
+ } qw(
+ baz
+ blah
+ bling
+ evaled_foo
+ floob
+ )),
+ {
+ name => 'foo',
+ class => 'Bar',
+ code => $Bar->get_method('foo')
+ },
+ {
+ name => 'meta',
+ class => 'Bar',
+ code => $Bar->get_method('meta')
+ }
+ ],
+ '... got the right list of applicable methods for Bar');
+
+
Added: packages/libclass-mop-perl/branches/upstream/current/t/004_advanced_methods.t
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libclass-mop-perl/branches/upstream/current/t/004_advanced_methods.t?rev=2608&op=file
==============================================================================
--- packages/libclass-mop-perl/branches/upstream/current/t/004_advanced_methods.t (added)
+++ packages/libclass-mop-perl/branches/upstream/current/t/004_advanced_methods.t Thu Apr 20 11:21:04 2006
@@ -1,0 +1,219 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 9;
+use Test::Exception;
+
+BEGIN {
+ use_ok('Class::MOP');
+ use_ok('Class::MOP::Class');
+}
+
+=pod
+
+The following class hierarhcy is very contrived
+and totally horrid (it won't work under C3 even),
+but it tests a number of aspect of this module.
+
+A more real-world example would be a nice addition :)
+
+=cut
+
+{
+ package Foo;
+
+ sub BUILD { 'Foo::BUILD' }
+ sub foo { 'Foo::foo' }
+
+ package Bar;
+ our @ISA = ('Foo');
+
+ sub BUILD { 'Bar::BUILD' }
+ sub bar { 'Bar::bar' }
+
+ package Baz;
+ our @ISA = ('Bar');
+
+ sub baz { 'Baz::baz' }
+ sub foo { 'Baz::foo' }
+
+ package Foo::Bar;
+ our @ISA = ('Foo', 'Bar');
+
+ sub BUILD { 'Foo::Bar::BUILD' }
+ sub foobar { 'Foo::Bar::foobar' }
+
+ package Foo::Bar::Baz;
+ our @ISA = ('Foo', 'Bar', 'Baz');
+
+ sub BUILD { 'Foo::Bar::Baz::BUILD' }
+ sub bar { 'Foo::Bar::Baz::bar' }
+ sub foobarbaz { 'Foo::Bar::Baz::foobarbaz' }
+}
+
+is_deeply(
+ [ sort { $a->{name} cmp $b->{name} } Class::MOP::Class->initialize('Foo')->compute_all_applicable_methods() ],
+ [
+ {
+ name => 'BUILD',
+ class => 'Foo',
+ code => \&Foo::BUILD
+ },
+ {
+ name => 'foo',
+ class => 'Foo',
+ code => \&Foo::foo
+ },
+ ],
+ '... got the right list of applicable methods for Foo');
+
+is_deeply(
+ [ sort { $a->{name} cmp $b->{name} } Class::MOP::Class->initialize('Bar')->compute_all_applicable_methods() ],
+ [
+ {
+ name => 'BUILD',
+ class => 'Bar',
+ code => \&Bar::BUILD
+ },
+ {
+ name => 'bar',
+ class => 'Bar',
+ code => \&Bar::bar
+ },
+ {
+ name => 'foo',
+ class => 'Foo',
+ code => \&Foo::foo
+ },
+ ],
+ '... got the right list of applicable methods for Bar');
+
+
+is_deeply(
+ [ sort { $a->{name} cmp $b->{name} } Class::MOP::Class->initialize('Baz')->compute_all_applicable_methods() ],
+ [
+ {
+ name => 'BUILD',
+ class => 'Bar',
+ code => \&Bar::BUILD
+ },
+ {
+ name => 'bar',
+ class => 'Bar',
+ code => \&Bar::bar
+ },
+ {
+ name => 'baz',
+ class => 'Baz',
+ code => \&Baz::baz
+ },
+ {
+ name => 'foo',
+ class => 'Baz',
+ code => \&Baz::foo
+ },
+ ],
+ '... got the right list of applicable methods for Baz');
+
+is_deeply(
+ [ sort { $a->{name} cmp $b->{name} } Class::MOP::Class->initialize('Foo::Bar')->compute_all_applicable_methods() ],
+ [
+ {
+ name => 'BUILD',
+ class => 'Foo::Bar',
+ code => \&Foo::Bar::BUILD
+ },
+ {
+ name => 'bar',
+ class => 'Bar',
+ code => \&Bar::bar
+ },
+ {
+ name => 'foo',
+ class => 'Foo',
+ code => \&Foo::foo
+ },
+ {
+ name => 'foobar',
+ class => 'Foo::Bar',
+ code => \&Foo::Bar::foobar
+ },
+ ],
+ '... got the right list of applicable methods for Foo::Bar');
+
+is_deeply(
+ [ sort { $a->{name} cmp $b->{name} } Class::MOP::Class->initialize('Foo::Bar::Baz')->compute_all_applicable_methods() ],
+ [
+ {
+ name => 'BUILD',
+ class => 'Foo::Bar::Baz',
+ code => \&Foo::Bar::Baz::BUILD
+ },
+ {
+ name => 'bar',
+ class => 'Foo::Bar::Baz',
+ code => \&Foo::Bar::Baz::bar
+ },
+ {
+ name => 'baz',
+ class => 'Baz',
+ code => \&Baz::baz
+ },
+ {
+ name => 'foo',
+ class => 'Foo',
+ code => \&Foo::foo
+ },
+ {
+ name => 'foobarbaz',
+ class => 'Foo::Bar::Baz',
+ code => \&Foo::Bar::Baz::foobarbaz
+ },
+ ],
+ '... got the right list of applicable methods for Foo::Bar::Baz');
+
+## find_all_methods_by_name
+
+is_deeply(
+ [ Class::MOP::Class->initialize('Foo::Bar')->find_all_methods_by_name('BUILD') ],
+ [
+ {
+ name => 'BUILD',
+ class => 'Foo::Bar',
+ code => \&Foo::Bar::BUILD
+ },
+ {
+ name => 'BUILD',
+ class => 'Foo',
+ code => \&Foo::BUILD
+ },
+ {
+ name => 'BUILD',
+ class => 'Bar',
+ code => \&Bar::BUILD
+ }
+ ],
+ '... got the right list of BUILD methods for Foo::Bar');
+
+is_deeply(
+ [ Class::MOP::Class->initialize('Foo::Bar::Baz')->find_all_methods_by_name('BUILD') ],
+ [
+ {
+ name => 'BUILD',
+ class => 'Foo::Bar::Baz',
+ code => \&Foo::Bar::Baz::BUILD
+ },
+ {
+ name => 'BUILD',
+ class => 'Foo',
+ code => \&Foo::BUILD
+ },
+ {
+ name => 'BUILD',
+ class => 'Bar',
+ code => \&Bar::BUILD
+ },
+ ],
+ '... got the right list of BUILD methods for Foo::Bar::Baz');
Added: packages/libclass-mop-perl/branches/upstream/current/t/005_attributes.t
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libclass-mop-perl/branches/upstream/current/t/005_attributes.t?rev=2608&op=file
==============================================================================
--- packages/libclass-mop-perl/branches/upstream/current/t/005_attributes.t (added)
+++ packages/libclass-mop-perl/branches/upstream/current/t/005_attributes.t Thu Apr 20 11:21:04 2006
@@ -1,0 +1,152 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 40;
+use Test::Exception;
+
+BEGIN {
+ use_ok('Class::MOP');
+}
+
+my $FOO_ATTR = Class::MOP::Attribute->new('$foo');
+my $BAR_ATTR = Class::MOP::Attribute->new('$bar' => (
+ accessor => 'bar'
+));
+my $BAZ_ATTR = Class::MOP::Attribute->new('$baz' => (
+ reader => 'get_baz',
+ writer => 'set_baz',
+));
+
+my $BAR_ATTR_2 = Class::MOP::Attribute->new('$bar');
+
+{
+ package Foo;
+ use metaclass;
+
+ my $meta = Foo->meta;
+ ::lives_ok {
+ $meta->add_attribute($FOO_ATTR);
+ } '... we added an attribute to Foo successfully';
+ ::ok($meta->has_attribute('$foo'), '... Foo has $foo attribute');
+ ::is($meta->get_attribute('$foo'), $FOO_ATTR, '... got the right attribute back for Foo');
+
+ ::ok(!$meta->has_method('foo'), '... no accessor created');
+
+ ::lives_ok {
+ $meta->add_attribute($BAR_ATTR_2);
+ } '... we added an attribute to Foo successfully';
+ ::ok($meta->has_attribute('$bar'), '... Foo has $bar attribute');
+ ::is($meta->get_attribute('$bar'), $BAR_ATTR_2, '... got the right attribute back for Foo');
+
+ ::ok(!$meta->has_method('bar'), '... no accessor created');
+}
+{
+ package Bar;
+ our @ISA = ('Foo');
+
+ my $meta = Bar->meta;
+ ::lives_ok {
+ $meta->add_attribute($BAR_ATTR);
+ } '... we added an attribute to Bar successfully';
+ ::ok($meta->has_attribute('$bar'), '... Bar has $bar attribute');
+ ::is($meta->get_attribute('$bar'), $BAR_ATTR, '... got the right attribute back for Bar');
+
+ ::ok($meta->has_method('bar'), '... an accessor has been created');
+ ::isa_ok($meta->get_method('bar'), 'Class::MOP::Attribute::Accessor');
+}
+{
+ package Baz;
+ our @ISA = ('Bar');
+
+ my $meta = Baz->meta;
+ ::lives_ok {
+ $meta->add_attribute($BAZ_ATTR);
+ } '... we added an attribute to Baz successfully';
+ ::ok($meta->has_attribute('$baz'), '... Baz has $baz attribute');
+ ::is($meta->get_attribute('$baz'), $BAZ_ATTR, '... got the right attribute back for Baz');
+
+ ::ok($meta->has_method('get_baz'), '... a reader has been created');
+ ::ok($meta->has_method('set_baz'), '... a writer has been created');
+
+ ::isa_ok($meta->get_method('get_baz'), 'Class::MOP::Attribute::Accessor');
+ ::isa_ok($meta->get_method('set_baz'), 'Class::MOP::Attribute::Accessor');
+}
+
+{
+ my $meta = Baz->meta;
+ isa_ok($meta, 'Class::MOP::Class');
+
+ is_deeply(
+ [ sort { $a->name cmp $b->name } $meta->compute_all_applicable_attributes() ],
+ [
+ $BAR_ATTR,
+ $BAZ_ATTR,
+ $FOO_ATTR,
+ ],
+ '... got the right list of applicable attributes for Baz');
+
+ is_deeply(
+ [ map { $_->associated_class } sort { $a->name cmp $b->name } $meta->compute_all_applicable_attributes() ],
+ [ Bar->meta, Baz->meta, Foo->meta ],
+ '... got the right list of associated classes from the applicable attributes for Baz');
+
+ my $attr;
+ lives_ok {
+ $attr = $meta->remove_attribute('$baz');
+ } '... removed the $baz attribute successfully';
+ is($attr, $BAZ_ATTR, '... got the right attribute back for Baz');
+
+ ok(!$meta->has_attribute('$baz'), '... Baz no longer has $baz attribute');
+ is($meta->get_attribute('$baz'), undef, '... Baz no longer has $baz attribute');
+
+ ok(!$meta->has_method('get_baz'), '... a reader has been removed');
+ ok(!$meta->has_method('set_baz'), '... a writer has been removed');
+
+ is_deeply(
+ [ sort { $a->name cmp $b->name } $meta->compute_all_applicable_attributes() ],
+ [
+ $BAR_ATTR,
+ $FOO_ATTR,
+ ],
+ '... got the right list of applicable attributes for Baz');
+
+ is_deeply(
+ [ map { $_->associated_class } sort { $a->name cmp $b->name } $meta->compute_all_applicable_attributes() ],
+ [ Bar->meta, Foo->meta ],
+ '... got the right list of associated classes from the applicable attributes for Baz');
+
+ {
+ my $attr;
+ lives_ok {
+ $attr = Bar->meta->remove_attribute('$bar');
+ } '... removed the $bar attribute successfully';
+ is($attr, $BAR_ATTR, '... got the right attribute back for Bar');
+
+ ok(!Bar->meta->has_attribute('$bar'), '... Bar no longer has $bar attribute');
+
+ ok(!Bar->meta->has_method('bar'), '... a accessor has been removed');
+ }
+
+ is_deeply(
+ [ sort { $a->name cmp $b->name } $meta->compute_all_applicable_attributes() ],
+ [
+ $BAR_ATTR_2,
+ $FOO_ATTR,
+ ],
+ '... got the right list of applicable attributes for Baz');
+
+ is_deeply(
+ [ map { $_->associated_class } sort { $a->name cmp $b->name } $meta->compute_all_applicable_attributes() ],
+ [ Foo->meta, Foo->meta ],
+ '... got the right list of associated classes from the applicable attributes for Baz');
+
+ # remove attribute which is not there
+ my $val;
+ lives_ok {
+ $val = $meta->remove_attribute('$blammo');
+ } '... attempted to remove the non-existent $blammo attribute';
+ is($val, undef, '... got the right value back (undef)');
+
+}
Added: packages/libclass-mop-perl/branches/upstream/current/t/006_new_and_clone_metaclasses.t
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libclass-mop-perl/branches/upstream/current/t/006_new_and_clone_metaclasses.t?rev=2608&op=file
==============================================================================
--- packages/libclass-mop-perl/branches/upstream/current/t/006_new_and_clone_metaclasses.t (added)
+++ packages/libclass-mop-perl/branches/upstream/current/t/006_new_and_clone_metaclasses.t Thu Apr 20 11:21:04 2006
@@ -1,0 +1,130 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 36;
+use Test::Exception;
+
+BEGIN {
+ use_ok('Class::MOP');
+}
+
+# make sure the Class::MOP::Class->meta does the right thing
+
+my $meta = Class::MOP::Class->meta();
+isa_ok($meta, 'Class::MOP::Class');
+
+my $new_meta = $meta->new_object(':package' => 'Class::MOP::Class');
+isa_ok($new_meta, 'Class::MOP::Class');
+is($new_meta, $meta, '... it still creates the singleton');
+
+my $cloned_meta = $meta->clone_object($meta);
+isa_ok($cloned_meta, 'Class::MOP::Class');
+is($cloned_meta, $meta, '... it creates the singleton even if you try to clone it');
+
+# make sure other metaclasses do the right thing
+
+{
+ package Foo;
+ use metaclass;
+}
+
+my $foo_meta = Foo->meta;
+isa_ok($foo_meta, 'Class::MOP::Class');
+
+is($meta->new_object(':package' => 'Foo'), $foo_meta, '... got the right Foo->meta singleton');
+is($meta->clone_object($foo_meta), $foo_meta, '... cloning got the right Foo->meta singleton');
+
+# make sure subclassed of Class::MOP::Class do the right thing
+
+{
+ package MyMetaClass;
+ use base 'Class::MOP::Class';
+}
+
+my $my_meta = MyMetaClass->meta;
+isa_ok($my_meta, 'Class::MOP::Class');
+
+my $new_my_meta = $my_meta->new_object(':package' => 'MyMetaClass');
+isa_ok($new_my_meta, 'Class::MOP::Class');
+is($new_my_meta, $my_meta, '... even subclasses still create the singleton');
+
+my $cloned_my_meta = $meta->clone_object($my_meta);
+isa_ok($cloned_my_meta, 'Class::MOP::Class');
+is($cloned_my_meta, $my_meta, '... and subclasses creates the singleton even if you try to clone it');
+
+is($my_meta->new_object(':package' => 'Foo'), $foo_meta, '... got the right Foo->meta singleton (w/subclass)');
+is($meta->clone_object($foo_meta), $foo_meta, '... cloning got the right Foo->meta singleton (w/subclass)');
+
+# now create a metaclass for real
+
+my $bar_meta = $my_meta->new_object(':package' => 'Bar');
+isa_ok($bar_meta, 'Class::MOP::Class');
+
+is($bar_meta->name, 'Bar', '... got the right name for the Bar metaclass');
+is($bar_meta->version, undef, '... Bar does not exists, so it has no version');
+
+$bar_meta->superclasses('Foo');
+
+# check with MyMetaClass
+
+{
+ package Baz;
+ use metaclass 'MyMetaClass';
+}
+
+my $baz_meta = Baz->meta;
+isa_ok($baz_meta, 'Class::MOP::Class');
+isa_ok($baz_meta, 'MyMetaClass');
+
+is($my_meta->new_object(':package' => 'Baz'), $baz_meta, '... got the right Baz->meta singleton');
+is($my_meta->clone_object($baz_meta), $baz_meta, '... cloning got the right Baz->meta singleton');
+
+$baz_meta->superclasses('Bar');
+
+# now create a regular objects for real
+
+my $foo = $foo_meta->new_object();
+isa_ok($foo, 'Foo');
+
+my $bar = $bar_meta->new_object();
+isa_ok($bar, 'Bar');
+isa_ok($bar, 'Foo');
+
+my $baz = $baz_meta->new_object();
+isa_ok($baz, 'Baz');
+isa_ok($baz, 'Bar');
+isa_ok($baz, 'Foo');
+
+my $cloned_foo = $foo_meta->clone_object($foo);
+isa_ok($cloned_foo, 'Foo');
+
+isnt($cloned_foo, $foo, '... $cloned_foo is a new object different from $foo');
+
+# check some errors
+
+dies_ok {
+ $foo_meta->clone_object($meta);
+} '... this dies as expected';
+
+# test stuff
+
+{
+ package FooBar;
+ use metaclass;
+
+ FooBar->meta->add_attribute('test');
+}
+
+my $attr = FooBar->meta->get_attribute('test');
+isa_ok($attr, 'Class::MOP::Attribute');
+
+my $attr_clone = $attr->clone();
+isa_ok($attr_clone, 'Class::MOP::Attribute');
+
+isnt($attr, $attr_clone, '... we successfully cloned our attributes');
+is($attr->associated_class,
+ $attr_clone->associated_class,
+ '... we successfully did not clone our associated metaclass');
+
Added: packages/libclass-mop-perl/branches/upstream/current/t/010_self_introspection.t
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libclass-mop-perl/branches/upstream/current/t/010_self_introspection.t?rev=2608&op=file
==============================================================================
--- packages/libclass-mop-perl/branches/upstream/current/t/010_self_introspection.t (added)
+++ packages/libclass-mop-perl/branches/upstream/current/t/010_self_introspection.t Thu Apr 20 11:21:04 2006
@@ -1,0 +1,166 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 126;
+use Test::Exception;
+
+BEGIN {
+ use_ok('Class::MOP');
+ use_ok('Class::MOP::Class');
+}
+
+{
+ my $class = Class::MOP::Class->initialize('Foo');
+ is($class->meta, Class::MOP::Class->meta, '... instance and class both lead to the same meta');
+}
+
+my $meta = Class::MOP::Class->meta();
+isa_ok($meta, 'Class::MOP::Class');
+
+my @methods = qw(
+ meta
+
+ initialize create
+
+ new_object clone_object
+ construct_instance construct_class_instance clone_instance
+ check_metaclass_compatability
+
+ name version
+
+ attribute_metaclass method_metaclass
+
+ superclasses class_precedence_list
+
+ has_method get_method add_method remove_method alias_method
+ get_method_list compute_all_applicable_methods
+ find_all_methods_by_name find_next_method_by_name
+
+ 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
+
+ add_package_variable get_package_variable has_package_variable remove_package_variable
+ );
+
+is_deeply([ sort @methods ], [ sort $meta->get_method_list ], '... got the correct method list');
+
+foreach my $method_name (@methods) {
+ ok($meta->has_method($method_name), '... Class::MOP::Class->has_method(' . $method_name . ')');
+ {
+ no strict 'refs';
+ is($meta->get_method($method_name),
+ \&{'Class::MOP::Class::' . $method_name},
+ '... Class::MOP::Class->get_method(' . $method_name . ') == &Class::MOP::Class::' . $method_name);
+ }
+}
+
+# check for imported functions which are not methods
+
+foreach my $non_method_name (qw(
+ confess
+ blessed reftype
+ subname
+ svref_2object
+ )) {
+ ok(!$meta->has_method($non_method_name), '... NOT Class::MOP::Class->has_method(' . $non_method_name . ')');
+}
+
+# check for the right attributes
+
+my @attributes = ('$:package', '%:attributes', '$:attribute_metaclass', '$:method_metaclass');
+
+is_deeply(
+ [ sort @attributes ],
+ [ sort $meta->get_attribute_list ],
+ '... got the right list of attributes');
+
+is_deeply(
+ [ sort @attributes ],
+ [ sort keys %{$meta->get_attribute_map} ],
+ '... got the right list of attributes');
+
+foreach my $attribute_name (@attributes) {
+ ok($meta->has_attribute($attribute_name), '... Class::MOP::Class->has_attribute(' . $attribute_name . ')');
+ isa_ok($meta->get_attribute($attribute_name), 'Class::MOP::Attribute');
+}
+
+## check the attributes themselves
+
+ok($meta->get_attribute('$:package')->has_reader, '... Class::MOP::Class $:package has a reader');
+is($meta->get_attribute('$:package')->reader, 'name', '... Class::MOP::Class $:package\'s a reader is &name');
+
+ok($meta->get_attribute('$:package')->has_init_arg, '... Class::MOP::Class $:package has a init_arg');
+is($meta->get_attribute('$:package')->init_arg, ':package', '... Class::MOP::Class $:package\'s a init_arg is :package');
+
+ok($meta->get_attribute('%:attributes')->has_reader, '... Class::MOP::Class %:attributes has a reader');
+is($meta->get_attribute('%:attributes')->reader,
+ 'get_attribute_map',
+ '... Class::MOP::Class %:attributes\'s a reader is &get_attribute_map');
+
+ok($meta->get_attribute('%:attributes')->has_init_arg, '... Class::MOP::Class %:attributes has a init_arg');
+is($meta->get_attribute('%:attributes')->init_arg,
+ ':attributes',
+ '... Class::MOP::Class %:attributes\'s a init_arg is :attributes');
+
+ok($meta->get_attribute('%:attributes')->has_default, '... Class::MOP::Class %:attributes has a default');
+is_deeply($meta->get_attribute('%:attributes')->default,
+ {},
+ '... Class::MOP::Class %:attributes\'s a default of {}');
+
+ok($meta->get_attribute('$:attribute_metaclass')->has_reader, '... Class::MOP::Class $:attribute_metaclass has a reader');
+is($meta->get_attribute('$:attribute_metaclass')->reader,
+ 'attribute_metaclass',
+ '... Class::MOP::Class $:attribute_metaclass\'s a reader is &attribute_metaclass');
+
+ok($meta->get_attribute('$:attribute_metaclass')->has_init_arg, '... Class::MOP::Class $:attribute_metaclass has a init_arg');
+is($meta->get_attribute('$:attribute_metaclass')->init_arg,
+ ':attribute_metaclass',
+ '... Class::MOP::Class $:attribute_metaclass\'s a init_arg is :attribute_metaclass');
+
+ok($meta->get_attribute('$:attribute_metaclass')->has_default, '... Class::MOP::Class $:attribute_metaclass has a default');
+is($meta->get_attribute('$:attribute_metaclass')->default,
+ 'Class::MOP::Attribute',
+ '... Class::MOP::Class $:attribute_metaclass\'s a default is Class::MOP:::Attribute');
+
+ok($meta->get_attribute('$:method_metaclass')->has_reader, '... Class::MOP::Class $:method_metaclass has a reader');
+is($meta->get_attribute('$:method_metaclass')->reader,
+ 'method_metaclass',
+ '... Class::MOP::Class $:method_metaclass\'s a reader is &method_metaclass');
+
+ok($meta->get_attribute('$:method_metaclass')->has_init_arg, '... Class::MOP::Class $:method_metaclass has a init_arg');
+is($meta->get_attribute('$:method_metaclass')->init_arg,
+ ':method_metaclass',
+ '... Class::MOP::Class $:method_metaclass\'s init_arg is :method_metaclass');
+
+ok($meta->get_attribute('$:method_metaclass')->has_default, '... Class::MOP::Class $:method_metaclass has a default');
+is($meta->get_attribute('$:method_metaclass')->default,
+ 'Class::MOP::Method',
+ '... Class::MOP::Class $:method_metaclass\'s a default is Class::MOP:::Method');
+
+# check the values of some of the methods
+
+is($meta->name, 'Class::MOP::Class', '... Class::MOP::Class->name');
+is($meta->version, $Class::MOP::Class::VERSION, '... Class::MOP::Class->version');
+
+ok($meta->has_package_variable('$VERSION'), '... Class::MOP::Class->has_package_variable($VERSION)');
+is(${$meta->get_package_variable('$VERSION')},
+ $Class::MOP::Class::VERSION,
+ '... Class::MOP::Class->get_package_variable($VERSION)');
+
+is_deeply(
+ [ $meta->superclasses ],
+ [],
+ '... Class::MOP::Class->superclasses == []');
+
+is_deeply(
+ [ $meta->class_precedence_list ],
+ [ 'Class::MOP::Class' ],
+ '... Class::MOP::Class->class_precedence_list == []');
+
+is($meta->attribute_metaclass, 'Class::MOP::Attribute', '... got the right value for attribute_metaclass');
+is($meta->method_metaclass, 'Class::MOP::Method', '... got the right value for method_metaclass');
+
Added: packages/libclass-mop-perl/branches/upstream/current/t/011_create_class.t
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libclass-mop-perl/branches/upstream/current/t/011_create_class.t?rev=2608&op=file
==============================================================================
--- packages/libclass-mop-perl/branches/upstream/current/t/011_create_class.t (added)
+++ packages/libclass-mop-perl/branches/upstream/current/t/011_create_class.t Thu Apr 20 11:21:04 2006
@@ -1,0 +1,115 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 28;
+use Test::Exception;
+
+BEGIN {
+ use_ok('Class::MOP');
+}
+
+my $Point = Class::MOP::Class->create('Point' => '0.01' => (
+ attributes => [
+ Class::MOP::Attribute->new('$.x' => (
+ reader => 'x',
+ init_arg => 'x'
+ )),
+ Class::MOP::Attribute->new('$.y' => (
+ accessor => 'y',
+ init_arg => 'y'
+ )),
+ ],
+ methods => {
+ 'new' => sub {
+ my $class = shift;
+ my $instance = $class->meta->construct_instance(@_);
+ bless $instance => $class;
+ },
+ 'clear' => sub {
+ my $self = shift;
+ $self->{'$.x'} = 0;
+ $self->{'$.y'} = 0;
+ }
+ }
+));
+
+my $Point3D = Class::MOP::Class->create('Point3D' => '0.01' => (
+ superclasses => [ 'Point' ],
+ attributes => [
+ Class::MOP::Attribute->new('$:z' => (
+ default => 123
+ )),
+ ],
+ methods => {
+ 'clear' => sub {
+ my $self = shift;
+ $self->{'$:z'} = 0;
+ $self->SUPER::clear();
+ }
+ }
+));
+
+isa_ok($Point, 'Class::MOP::Class');
+isa_ok($Point3D, 'Class::MOP::Class');
+
+# ... test the classes themselves
+
+my $point = Point->new('x' => 2, 'y' => 3);
+isa_ok($point, 'Point');
+
+can_ok($point, 'x');
+can_ok($point, 'y');
+can_ok($point, 'clear');
+
+{
+ my $meta = $point->meta;
+ is($meta, Point->meta(), '... got the meta from the instance too');
+}
+
+is($point->y, 3, '... the $.y attribute was initialized correctly through the metaobject');
+
+$point->y(42);
+is($point->y, 42, '... the $.y attribute was set properly with the accessor');
+
+is($point->x, 2, '... the $.x attribute was initialized correctly through the metaobject');
+
+dies_ok {
+ $point->x(42);
+} '... cannot write to a read-only accessor';
+is($point->x, 2, '... the $.x attribute was not altered');
+
+$point->clear();
+
+is($point->y, 0, '... the $.y attribute was cleared correctly');
+is($point->x, 0, '... the $.x attribute was cleared correctly');
+
+my $point3d = Point3D->new('x' => 1, 'y' => 2, '$:z' => 3);
+isa_ok($point3d, 'Point3D');
+isa_ok($point3d, 'Point');
+
+{
+ my $meta = $point3d->meta;
+ is($meta, Point3D->meta(), '... got the meta from the instance too');
+}
+
+can_ok($point3d, 'x');
+can_ok($point3d, 'y');
+can_ok($point3d, 'clear');
+
+is($point3d->x, 1, '... the $.x attribute was initialized correctly through the metaobject');
+is($point3d->y, 2, '... the $.y attribute was initialized correctly through the metaobject');
+is($point3d->{'$:z'}, 3, '... the $:z attribute was initialized correctly through the metaobject');
+
+{
+ my $point3d = Point3D->new();
+ isa_ok($point3d, 'Point3D');
+
+ is($point3d->x, undef, '... the $.x attribute was not initialized');
+ is($point3d->y, undef, '... the $.y attribute was not initialized');
+ is($point3d->{'$:z'}, 123, '... the $:z attribute was initialized correctly through the metaobject');
+
+}
+
+
Added: packages/libclass-mop-perl/branches/upstream/current/t/012_package_variables.t
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libclass-mop-perl/branches/upstream/current/t/012_package_variables.t?rev=2608&op=file
==============================================================================
--- packages/libclass-mop-perl/branches/upstream/current/t/012_package_variables.t (added)
+++ packages/libclass-mop-perl/branches/upstream/current/t/012_package_variables.t Thu Apr 20 11:21:04 2006
@@ -1,0 +1,121 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 34;
+use Test::Exception;
+
+BEGIN {
+ use_ok('Class::MOP');
+}
+
+{
+ package Foo;
+ use metaclass;
+}
+
+ok(!defined($Foo::{foo}), '... the %foo slot has not been created yet');
+ok(!Foo->meta->has_package_variable('%foo'), '... the meta agrees');
+
+lives_ok {
+ Foo->meta->add_package_variable('%foo' => { one => 1 });
+} '... created %Foo::foo successfully';
+
+ok(defined($Foo::{foo}), '... the %foo slot was created successfully');
+ok(Foo->meta->has_package_variable('%foo'), '... the meta agrees');
+
+{
+ no strict 'refs';
+ ok(exists ${'Foo::foo'}{one}, '... our %foo was initialized correctly');
+ is(${'Foo::foo'}{one}, 1, '... our %foo was initialized correctly');
+}
+
+my $foo = Foo->meta->get_package_variable('%foo');
+is_deeply({ one => 1 }, $foo, '... got the right package variable back');
+
+$foo->{two} = 2;
+
+{
+ no strict 'refs';
+ is(\%{'Foo::foo'}, Foo->meta->get_package_variable('%foo'), '... our %foo is the same as the metas');
+
+ ok(exists ${'Foo::foo'}{two}, '... our %foo was updated correctly');
+ is(${'Foo::foo'}{two}, 2, '... our %foo was updated correctly');
+}
+
+ok(!defined($Foo::{bar}), '... the @bar slot has not been created yet');
+
+lives_ok {
+ Foo->meta->add_package_variable('@bar' => [ 1, 2, 3 ]);
+} '... created @Foo::bar successfully';
+
+ok(defined($Foo::{bar}), '... the @bar slot was created successfully');
+
+{
+ no strict 'refs';
+ is(scalar @{'Foo::bar'}, 3, '... our @bar was initialized correctly');
+ is(${'Foo::bar'}[1], 2, '... our @bar was initialized correctly');
+}
+
+# now without initial value
+
+ok(!defined($Foo::{baz}), '... the %baz slot has not been created yet');
+
+lives_ok {
+ Foo->meta->add_package_variable('%baz');
+} '... created %Foo::baz successfully';
+
+ok(defined($Foo::{baz}), '... the %baz slot was created successfully');
+
+{
+ no strict 'refs';
+ ${'Foo::baz'}{one} = 1;
+
+ ok(exists ${'Foo::baz'}{one}, '... our %baz was initialized correctly');
+ is(${'Foo::baz'}{one}, 1, '... our %baz was initialized correctly');
+}
+
+ok(!defined($Foo::{bling}), '... the @bling slot has not been created yet');
+
+lives_ok {
+ Foo->meta->add_package_variable('@bling');
+} '... created @Foo::bling successfully';
+
+ok(defined($Foo::{bling}), '... the @bling slot was created successfully');
+
+{
+ no strict 'refs';
+ is(scalar @{'Foo::bling'}, 0, '... our @bling was initialized correctly');
+ ${'Foo::bling'}[1] = 2;
+ is(${'Foo::bling'}[1], 2, '... our @bling was assigned too correctly');
+}
+
+lives_ok {
+ Foo->meta->remove_package_variable('%foo');
+} '... removed %Foo::foo successfully';
+
+ok(!defined($Foo::{foo}), '... the %foo slot was removed successfully');
+
+# check some errors
+
+dies_ok {
+ Foo->meta->add_package_variable('bar');
+} '... no sigil for bar';
+
+dies_ok {
+ Foo->meta->remove_package_variable('bar');
+} '... no sigil for bar';
+
+dies_ok {
+ Foo->meta->get_package_variable('bar');
+} '... no sigil for bar';
+
+dies_ok {
+ Foo->meta->has_package_variable('bar');
+} '... no sigil for bar';
+
+
+dies_ok {
+ Foo->meta->get_package_variable('@.....bar');
+} '... could not fetch variable';
Added: packages/libclass-mop-perl/branches/upstream/current/t/013_add_attribute_alternate.t
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libclass-mop-perl/branches/upstream/current/t/013_add_attribute_alternate.t?rev=2608&op=file
==============================================================================
--- packages/libclass-mop-perl/branches/upstream/current/t/013_add_attribute_alternate.t (added)
+++ packages/libclass-mop-perl/branches/upstream/current/t/013_add_attribute_alternate.t Thu Apr 20 11:21:04 2006
@@ -1,0 +1,111 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 28;
+use Test::Exception;
+
+BEGIN {
+ use_ok('Class::MOP');
+}
+
+{
+ package Point;
+ use metaclass;
+
+ Point->meta->add_attribute('$.x' => (
+ reader => 'x',
+ init_arg => 'x'
+ ));
+
+ Point->meta->add_attribute('$.y' => (
+ accessor => 'y',
+ init_arg => 'y'
+ ));
+
+ sub new {
+ my $class = shift;
+ bless $class->meta->construct_instance(@_) => $class;
+ }
+
+ sub clear {
+ my $self = shift;
+ $self->{'$.x'} = 0;
+ $self->{'$.y'} = 0;
+ }
+
+ package Point3D;
+ our @ISA = ('Point');
+
+ Point3D->meta->add_attribute('$:z' => (
+ default => 123
+ ));
+
+ sub clear {
+ my $self = shift;
+ $self->{'$:z'} = 0;
+ $self->SUPER::clear();
+ }
+}
+
+isa_ok(Point->meta, 'Class::MOP::Class');
+isa_ok(Point3D->meta, 'Class::MOP::Class');
+
+# ... test the classes themselves
+
+my $point = Point->new('x' => 2, 'y' => 3);
+isa_ok($point, 'Point');
+
+can_ok($point, 'x');
+can_ok($point, 'y');
+can_ok($point, 'clear');
+
+{
+ my $meta = $point->meta;
+ is($meta, Point->meta(), '... got the meta from the instance too');
+}
+
+is($point->y, 3, '... the $.y attribute was initialized correctly through the metaobject');
+
+$point->y(42);
+is($point->y, 42, '... the $.y attribute was set properly with the accessor');
+
+is($point->x, 2, '... the $.x attribute was initialized correctly through the metaobject');
+
+dies_ok {
+ $point->x(42);
+} '... cannot write to a read-only accessor';
+is($point->x, 2, '... the $.x attribute was not altered');
+
+$point->clear();
+
+is($point->y, 0, '... the $.y attribute was cleared correctly');
+is($point->x, 0, '... the $.x attribute was cleared correctly');
+
+my $point3d = Point3D->new('x' => 1, 'y' => 2, '$:z' => 3);
+isa_ok($point3d, 'Point3D');
+isa_ok($point3d, 'Point');
+
+{
+ my $meta = $point3d->meta;
+ is($meta, Point3D->meta(), '... got the meta from the instance too');
+}
+
+can_ok($point3d, 'x');
+can_ok($point3d, 'y');
+can_ok($point3d, 'clear');
+
+is($point3d->x, 1, '... the $.x attribute was initialized correctly through the metaobject');
+is($point3d->y, 2, '... the $.y attribute was initialized correctly through the metaobject');
+is($point3d->{'$:z'}, 3, '... the $:z attribute was initialized correctly through the metaobject');
+
+{
+ my $point3d = Point3D->new();
+ isa_ok($point3d, 'Point3D');
+
+ is($point3d->x, undef, '... the $.x attribute was not initialized');
+ is($point3d->y, undef, '... the $.y attribute was not initialized');
+ is($point3d->{'$:z'}, 123, '... the $:z attribute was initialized correctly through the metaobject');
+
+}
Added: packages/libclass-mop-perl/branches/upstream/current/t/014_attribute_introspection.t
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libclass-mop-perl/branches/upstream/current/t/014_attribute_introspection.t?rev=2608&op=file
==============================================================================
--- packages/libclass-mop-perl/branches/upstream/current/t/014_attribute_introspection.t (added)
+++ packages/libclass-mop-perl/branches/upstream/current/t/014_attribute_introspection.t Thu Apr 20 11:21:04 2006
@@ -1,0 +1,75 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 39;
+use Test::Exception;
+
+BEGIN {
+ use_ok('Class::MOP');
+}
+
+{
+ my $attr = Class::MOP::Attribute->new('$test');
+ is($attr->meta, Class::MOP::Attribute->meta, '... instance and class both lead to the same meta');
+}
+
+{
+ my $meta = Class::MOP::Attribute->meta();
+ isa_ok($meta, 'Class::MOP::Class');
+
+ my @methods = qw(
+ meta
+ new clone
+ name
+ has_accessor accessor
+ has_writer writer
+ has_reader reader
+ has_predicate predicate
+ has_init_arg init_arg
+ has_default default
+
+ associated_class
+ attach_to_class detach_from_class
+
+ generate_accessor_method
+ generate_reader_method
+ generate_writer_method
+ generate_predicate_method
+
+ process_accessors
+ install_accessors
+ remove_accessors
+ );
+
+ is_deeply(
+ [ sort @methods ],
+ [ sort $meta->get_method_list ],
+ '... our method list matches');
+
+ foreach my $method_name (@methods) {
+ ok($meta->has_method($method_name), '... Class::MOP::Attribute->has_method(' . $method_name . ')');
+ }
+
+ my @attributes = qw(
+ name accessor reader writer predicate
+ init_arg default associated_class
+ );
+
+ is_deeply(
+ [ sort @attributes ],
+ [ sort $meta->get_attribute_list ],
+ '... our attribute list matches');
+
+ foreach my $attribute_name (@attributes) {
+ ok($meta->has_attribute($attribute_name), '... Class::MOP::Attribute->has_attribute(' . $attribute_name . ')');
+ }
+
+ # We could add some tests here to make sure that
+ # the attribute have the appropriate
+ # accessor/reader/writer/predicate combinations,
+ # but that is getting a little excessive so I
+ # wont worry about it for now. Maybe if I get
+ # bored I will do it.
+}
Added: packages/libclass-mop-perl/branches/upstream/current/t/015_metaclass_inheritance.t
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libclass-mop-perl/branches/upstream/current/t/015_metaclass_inheritance.t?rev=2608&op=file
==============================================================================
--- packages/libclass-mop-perl/branches/upstream/current/t/015_metaclass_inheritance.t (added)
+++ packages/libclass-mop-perl/branches/upstream/current/t/015_metaclass_inheritance.t Thu Apr 20 11:21:04 2006
@@ -1,0 +1,47 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 10;
+use Test::Exception;
+
+BEGIN {
+ use_ok('Class::MOP');
+}
+
+=pod
+
+Test that a default set up will cause metaclasses to inherit
+the same metaclass type, but produce different metaclasses.
+
+=cut
+
+{
+ package Foo;
+ use metaclass;
+
+ package Bar;
+ use base 'Foo';
+
+ package Baz;
+ use base 'Bar';
+}
+
+my $foo_meta = Foo->meta;
+isa_ok($foo_meta, 'Class::MOP::Class');
+
+is($foo_meta->name, 'Foo', '... foo_meta->name == Foo');
+
+my $bar_meta = Bar->meta;
+isa_ok($bar_meta, 'Class::MOP::Class');
+
+is($bar_meta->name, 'Bar', '... bar_meta->name == Bar');
+isnt($bar_meta, $foo_meta, '... Bar->meta != Foo->meta');
+
+my $baz_meta = Baz->meta;
+isa_ok($baz_meta, 'Class::MOP::Class');
+
+is($baz_meta->name, 'Baz', '... baz_meta->name == Baz');
+isnt($baz_meta, $bar_meta, '... Baz->meta != Bar->meta');
+isnt($baz_meta, $foo_meta, '... Baz->meta != Foo->meta');
Added: packages/libclass-mop-perl/branches/upstream/current/t/016_class_errors_and_edge_cases.t
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libclass-mop-perl/branches/upstream/current/t/016_class_errors_and_edge_cases.t?rev=2608&op=file
==============================================================================
--- packages/libclass-mop-perl/branches/upstream/current/t/016_class_errors_and_edge_cases.t (added)
+++ packages/libclass-mop-perl/branches/upstream/current/t/016_class_errors_and_edge_cases.t Thu Apr 20 11:21:04 2006
@@ -1,0 +1,260 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 53;
+use Test::Exception;
+
+BEGIN {
+ use_ok('Class::MOP');
+}
+
+{
+ dies_ok {
+ Class::MOP::Class->initialize();
+ } '... initialize requires a name parameter';
+
+ dies_ok {
+ Class::MOP::Class->initialize('');
+ } '... initialize requires a name valid parameter';
+
+ dies_ok {
+ Class::MOP::Class->initialize(bless {} => 'Foo');
+ } '... initialize requires an unblessed parameter'
+}
+
+{
+ dies_ok {
+ Class::MOP::Class->construct_class_instance();
+ } '... construct_class_instance requires an :package parameter';
+
+ dies_ok {
+ Class::MOP::Class->construct_class_instance(':package' => undef);
+ } '... construct_class_instance requires a defined :package parameter';
+
+ dies_ok {
+ Class::MOP::Class->construct_class_instance(':package' => '');
+ } '... construct_class_instance requires a valid :package parameter';
+}
+
+
+{
+ dies_ok {
+ Class::MOP::Class->create();
+ } '... create requires an package_name parameter';
+
+ dies_ok {
+ Class::MOP::Class->create(undef);
+ } '... create requires a defined package_name parameter';
+
+ dies_ok {
+ Class::MOP::Class->create('');
+ } '... create requires a valid package_name parameter';
+
+ throws_ok {
+ Class::MOP::Class->create('+++');
+ } qr/^creation of \+\+\+ failed/, '... create requires a valid package_name parameter';
+
+}
+
+{
+ dies_ok {
+ Class::MOP::Class->clone_object(1);
+ } '... can only clone instances';
+
+ dies_ok {
+ Class::MOP::Class->clone_instance(1);
+ } '... can only clone instances';
+}
+
+{
+ dies_ok {
+ Class::MOP::Class->add_method();
+ } '... add_method dies as expected';
+
+ dies_ok {
+ Class::MOP::Class->add_method('');
+ } '... add_method dies as expected';
+
+ dies_ok {
+ Class::MOP::Class->add_method('foo' => 'foo');
+ } '... add_method dies as expected';
+
+ dies_ok {
+ Class::MOP::Class->add_method('foo' => []);
+ } '... add_method dies as expected';
+}
+
+{
+ dies_ok {
+ Class::MOP::Class->alias_method();
+ } '... alias_method dies as expected';
+
+ dies_ok {
+ Class::MOP::Class->alias_method('');
+ } '... alias_method dies as expected';
+
+ dies_ok {
+ Class::MOP::Class->alias_method('foo' => 'foo');
+ } '... alias_method dies as expected';
+
+ dies_ok {
+ Class::MOP::Class->alias_method('foo' => []);
+ } '... alias_method dies as expected';
+}
+
+{
+ dies_ok {
+ Class::MOP::Class->has_method();
+ } '... has_method dies as expected';
+
+ dies_ok {
+ Class::MOP::Class->has_method('');
+ } '... has_method dies as expected';
+}
+
+{
+ dies_ok {
+ Class::MOP::Class->get_method();
+ } '... get_method dies as expected';
+
+ dies_ok {
+ Class::MOP::Class->get_method('');
+ } '... get_method dies as expected';
+}
+
+{
+ dies_ok {
+ Class::MOP::Class->remove_method();
+ } '... remove_method dies as expected';
+
+ dies_ok {
+ Class::MOP::Class->remove_method('');
+ } '... remove_method dies as expected';
+}
+
+{
+ dies_ok {
+ Class::MOP::Class->find_all_methods_by_name();
+ } '... find_all_methods_by_name dies as expected';
+
+ dies_ok {
+ Class::MOP::Class->find_all_methods_by_name('');
+ } '... find_all_methods_by_name dies as expected';
+}
+
+{
+ dies_ok {
+ Class::MOP::Class->add_attribute(bless {} => 'Foo');
+ } '... add_attribute dies as expected';
+}
+
+
+{
+ dies_ok {
+ Class::MOP::Class->has_attribute();
+ } '... has_attribute dies as expected';
+
+ dies_ok {
+ Class::MOP::Class->has_attribute('');
+ } '... has_attribute dies as expected';
+}
+
+{
+ dies_ok {
+ Class::MOP::Class->get_attribute();
+ } '... get_attribute dies as expected';
+
+ dies_ok {
+ Class::MOP::Class->get_attribute('');
+ } '... get_attribute dies as expected';
+}
+
+{
+ dies_ok {
+ Class::MOP::Class->remove_attribute();
+ } '... remove_attribute dies as expected';
+
+ dies_ok {
+ Class::MOP::Class->remove_attribute('');
+ } '... remove_attribute dies as expected';
+}
+
+{
+ dies_ok {
+ Class::MOP::Class->add_package_variable();
+ } '... add_package_variable dies as expected';
+
+ dies_ok {
+ Class::MOP::Class->add_package_variable('');
+ } '... add_package_variable dies as expected';
+
+ dies_ok {
+ Class::MOP::Class->add_package_variable('foo');
+ } '... add_package_variable dies as expected';
+
+ dies_ok {
+ Class::MOP::Class->add_package_variable('&foo');
+ } '... add_package_variable dies as expected';
+
+ throws_ok {
+ Class::MOP::Class->meta->add_package_variable('@-');
+ } qr/^Could not create package variable \(\@\-\) because/,
+ '... add_package_variable dies as expected';
+}
+
+{
+ dies_ok {
+ Class::MOP::Class->has_package_variable();
+ } '... has_package_variable dies as expected';
+
+ dies_ok {
+ Class::MOP::Class->has_package_variable('');
+ } '... has_package_variable dies as expected';
+
+ dies_ok {
+ Class::MOP::Class->has_package_variable('foo');
+ } '... has_package_variable dies as expected';
+
+ dies_ok {
+ Class::MOP::Class->has_package_variable('&foo');
+ } '... has_package_variable dies as expected';
+}
+
+{
+ dies_ok {
+ Class::MOP::Class->get_package_variable();
+ } '... get_package_variable dies as expected';
+
+ dies_ok {
+ Class::MOP::Class->get_package_variable('');
+ } '... get_package_variable dies as expected';
+
+ dies_ok {
+ Class::MOP::Class->get_package_variable('foo');
+ } '... get_package_variable dies as expected';
+
+ dies_ok {
+ Class::MOP::Class->get_package_variable('&foo');
+ } '... get_package_variable dies as expected';
+}
+
+{
+ dies_ok {
+ Class::MOP::Class->remove_package_variable();
+ } '... remove_package_variable dies as expected';
+
+ dies_ok {
+ Class::MOP::Class->remove_package_variable('');
+ } '... remove_package_variable dies as expected';
+
+ dies_ok {
+ Class::MOP::Class->remove_package_variable('foo');
+ } '... remove_package_variable dies as expected';
+
+ dies_ok {
+ Class::MOP::Class->remove_package_variable('&foo');
+ } '... remove_package_variable dies as expected';
+}
+
Added: packages/libclass-mop-perl/branches/upstream/current/t/017_add_method_modifier.t
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libclass-mop-perl/branches/upstream/current/t/017_add_method_modifier.t?rev=2608&op=file
==============================================================================
--- packages/libclass-mop-perl/branches/upstream/current/t/017_add_method_modifier.t (added)
+++ packages/libclass-mop-perl/branches/upstream/current/t/017_add_method_modifier.t Thu Apr 20 11:21:04 2006
@@ -1,0 +1,103 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 17;
+use Test::Exception;
+
+BEGIN {
+ use_ok('Class::MOP');
+}
+
+{
+ package BankAccount;
+
+ use strict;
+ use warnings;
+ use metaclass;
+
+ use Carp 'confess';
+
+ BankAccount->meta->add_attribute('$:balance' => (
+ accessor => 'balance',
+ init_arg => 'balance',
+ default => 0
+ ));
+
+ sub new { (shift)->meta->new_object(@_) }
+
+ sub deposit {
+ my ($self, $amount) = @_;
+ $self->balance($self->balance + $amount);
+ }
+
+ sub withdraw {
+ my ($self, $amount) = @_;
+ my $current_balance = $self->balance();
+ ($current_balance >= $amount)
+ || confess "Account overdrawn";
+ $self->balance($current_balance - $amount);
+ }
+
+ package CheckingAccount;
+
+ use strict;
+ use warnings;
+ use metaclass;
+
+ use base 'BankAccount';
+
+ CheckingAccount->meta->add_attribute('$:overdraft_account' => (
+ accessor => 'overdraft_account',
+ init_arg => 'overdraft',
+ ));
+
+ CheckingAccount->meta->add_before_method_modifier('withdraw' => sub {
+ my ($self, $amount) = @_;
+ my $overdraft_amount = $amount - $self->balance();
+ if ($overdraft_amount > 0) {
+ $self->overdraft_account->withdraw($overdraft_amount);
+ $self->deposit($overdraft_amount);
+ }
+ });
+
+ ::ok(CheckingAccount->meta->has_method('withdraw'), '... checking account now has a withdraw method');
+}
+
+
+my $savings_account = BankAccount->new(balance => 250);
+isa_ok($savings_account, 'BankAccount');
+
+is($savings_account->balance, 250, '... got the right savings balance');
+lives_ok {
+ $savings_account->withdraw(50);
+} '... withdrew from savings successfully';
+is($savings_account->balance, 200, '... got the right savings balance after withdrawl');
+
+$savings_account->deposit(150);
+is($savings_account->balance, 350, '... got the right savings balance after deposit');
+
+my $checking_account = CheckingAccount->new(
+ balance => 100,
+ overdraft => $savings_account
+ );
+isa_ok($checking_account, 'CheckingAccount');
+isa_ok($checking_account, 'BankAccount');
+
+is($checking_account->overdraft_account, $savings_account, '... got the right overdraft account');
+
+is($checking_account->balance, 100, '... got the right checkings balance');
+
+lives_ok {
+ $checking_account->withdraw(50);
+} '... withdrew from checking successfully';
+is($checking_account->balance, 50, '... got the right checkings balance after withdrawl');
+is($savings_account->balance, 350, '... got the right savings balance after checking withdrawl (no overdraft)');
+
+lives_ok {
+ $checking_account->withdraw(200);
+} '... withdrew from checking successfully';
+is($checking_account->balance, 0, '... got the right checkings balance after withdrawl');
+is($savings_account->balance, 200, '... got the right savings balance after overdraft withdrawl');
+
Added: packages/libclass-mop-perl/branches/upstream/current/t/020_attribute.t
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libclass-mop-perl/branches/upstream/current/t/020_attribute.t?rev=2608&op=file
==============================================================================
--- packages/libclass-mop-perl/branches/upstream/current/t/020_attribute.t (added)
+++ packages/libclass-mop-perl/branches/upstream/current/t/020_attribute.t Thu Apr 20 11:21:04 2006
@@ -1,0 +1,147 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 67;
+use Test::Exception;
+
+BEGIN {
+ use_ok('Class::MOP');
+ use_ok('Class::MOP::Attribute');
+}
+
+{
+ my $attr = Class::MOP::Attribute->new('$foo');
+ isa_ok($attr, 'Class::MOP::Attribute');
+
+ is($attr->name, '$foo', '... $attr->name == $foo');
+ ok($attr->has_init_arg, '... $attr does have an init_arg');
+ is($attr->init_arg, '$foo', '... $attr init_arg is the name');
+
+ ok(!$attr->has_accessor, '... $attr does not have an accessor');
+ ok(!$attr->has_reader, '... $attr does not have an reader');
+ ok(!$attr->has_writer, '... $attr does not have an writer');
+ ok(!$attr->has_default, '... $attr does not have an default');
+
+ my $class = Class::MOP::Class->initialize('Foo');
+ isa_ok($class, 'Class::MOP::Class');
+
+ lives_ok {
+ $attr->attach_to_class($class);
+ } '... attached a class successfully';
+
+ is($attr->associated_class, $class, '... the class was associated correctly');
+
+ my $attr_clone = $attr->clone();
+ isa_ok($attr_clone, 'Class::MOP::Attribute');
+ isnt($attr, $attr_clone, '... but they are different instances');
+
+ is($attr->associated_class, $attr_clone->associated_class, '... the associated classes are the same though');
+ is($attr->associated_class, $class, '... the associated classes are the same though');
+ is($attr_clone->associated_class, $class, '... the associated classes are the same though');
+
+ is_deeply($attr, $attr_clone, '... but they are the same inside');
+}
+
+{
+ my $attr = Class::MOP::Attribute->new('$foo', (
+ init_arg => '-foo',
+ default => 'BAR'
+ ));
+ isa_ok($attr, 'Class::MOP::Attribute');
+
+ is($attr->name, '$foo', '... $attr->name == $foo');
+
+ ok($attr->has_init_arg, '... $attr does have an init_arg');
+ is($attr->init_arg, '-foo', '... $attr->init_arg == -foo');
+ ok($attr->has_default, '... $attr does have an default');
+ is($attr->default, 'BAR', '... $attr->default == BAR');
+
+ ok(!$attr->has_accessor, '... $attr does not have an accessor');
+ ok(!$attr->has_reader, '... $attr does not have an reader');
+ ok(!$attr->has_writer, '... $attr does not have an writer');
+
+ my $attr_clone = $attr->clone();
+ isa_ok($attr_clone, 'Class::MOP::Attribute');
+ isnt($attr, $attr_clone, '... but they are different instances');
+
+ is($attr->associated_class, $attr_clone->associated_class, '... the associated classes are the same though');
+ is($attr->associated_class, undef, '... the associated class is actually undef');
+ is($attr_clone->associated_class, undef, '... the associated class is actually undef');
+
+ is_deeply($attr, $attr_clone, '... but they are the same inside');
+}
+
+{
+ my $attr = Class::MOP::Attribute->new('$foo', (
+ accessor => 'foo',
+ init_arg => '-foo',
+ default => 'BAR'
+ ));
+ isa_ok($attr, 'Class::MOP::Attribute');
+
+ is($attr->name, '$foo', '... $attr->name == $foo');
+
+ ok($attr->has_init_arg, '... $attr does have an init_arg');
+ is($attr->init_arg, '-foo', '... $attr->init_arg == -foo');
+ ok($attr->has_default, '... $attr does have an default');
+ is($attr->default, 'BAR', '... $attr->default == BAR');
+
+ ok($attr->has_accessor, '... $attr does have an accessor');
+ is($attr->accessor, 'foo', '... $attr->accessor == foo');
+
+ ok(!$attr->has_reader, '... $attr does not have an reader');
+ ok(!$attr->has_writer, '... $attr does not have an writer');
+
+ my $attr_clone = $attr->clone();
+ isa_ok($attr_clone, 'Class::MOP::Attribute');
+ isnt($attr, $attr_clone, '... but they are different instances');
+
+ is_deeply($attr, $attr_clone, '... but they are the same inside');
+}
+
+{
+ my $attr = Class::MOP::Attribute->new('$foo', (
+ reader => 'get_foo',
+ writer => 'set_foo',
+ init_arg => '-foo',
+ default => 'BAR'
+ ));
+ isa_ok($attr, 'Class::MOP::Attribute');
+
+ is($attr->name, '$foo', '... $attr->name == $foo');
+
+ ok($attr->has_init_arg, '... $attr does have an init_arg');
+ is($attr->init_arg, '-foo', '... $attr->init_arg == -foo');
+ ok($attr->has_default, '... $attr does have an default');
+ is($attr->default, 'BAR', '... $attr->default == BAR');
+
+ ok($attr->has_reader, '... $attr does have an reader');
+ is($attr->reader, 'get_foo', '... $attr->reader == get_foo');
+ ok($attr->has_writer, '... $attr does have an writer');
+ is($attr->writer, 'set_foo', '... $attr->writer == set_foo');
+
+ ok(!$attr->has_accessor, '... $attr does not have an accessor');
+
+ my $attr_clone = $attr->clone();
+ isa_ok($attr_clone, 'Class::MOP::Attribute');
+ isnt($attr, $attr_clone, '... but they are different instances');
+
+ is_deeply($attr, $attr_clone, '... but they are the same inside');
+}
+
+{
+ my $attr = Class::MOP::Attribute->new('$foo');
+ isa_ok($attr, 'Class::MOP::Attribute');
+
+ my $attr_clone = $attr->clone('name' => '$bar');
+ isa_ok($attr_clone, 'Class::MOP::Attribute');
+ isnt($attr, $attr_clone, '... but they are different instances');
+
+ isnt($attr->name, $attr_clone->name, '... we changes the name parameter');
+
+ is($attr->name, '$foo', '... $attr->name == $foo');
+ is($attr_clone->name, '$bar', '... $attr_clone->name == $bar');
+}
+
Added: packages/libclass-mop-perl/branches/upstream/current/t/021_attribute_errors_and_edge_cases.t
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libclass-mop-perl/branches/upstream/current/t/021_attribute_errors_and_edge_cases.t?rev=2608&op=file
==============================================================================
--- packages/libclass-mop-perl/branches/upstream/current/t/021_attribute_errors_and_edge_cases.t (added)
+++ packages/libclass-mop-perl/branches/upstream/current/t/021_attribute_errors_and_edge_cases.t Thu Apr 20 11:21:04 2006
@@ -1,0 +1,140 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 20;
+use Test::Exception;
+
+BEGIN {
+ use_ok('Class::MOP');
+ use_ok('Class::MOP::Attribute');
+}
+
+
+{
+ my $regexp = qr/hello (.*)/;
+ my $attr = Class::MOP::Attribute->new('$test' => (
+ default => $regexp
+ ));
+
+ ok($attr->has_default, '... we have a default value');
+ is($attr->default, $regexp, '... and got the value we expected');
+}
+
+{ # bad construtor args
+ dies_ok {
+ Class::MOP::Attribute->new();
+ } '... no name argument';
+
+ dies_ok {
+ Class::MOP::Attribute->new('');
+ } '... bad name argument';
+
+ dies_ok {
+ Class::MOP::Attribute->new(0);
+ } '... bad name argument';
+}
+
+{
+ my $attr = Class::MOP::Attribute->new('$test');
+ dies_ok {
+ $attr->attach_to_class();
+ } '... attach_to_class died as expected';
+
+ dies_ok {
+ $attr->attach_to_class('Fail');
+ } '... attach_to_class died as expected';
+
+ dies_ok {
+ $attr->attach_to_class(bless {} => 'Fail');
+ } '... attach_to_class died as expected';
+}
+
+{
+ my $attr = Class::MOP::Attribute->new('$test' => (
+ reader => [ 'whoops, this wont work' ]
+ ));
+
+ $attr->attach_to_class(Class::MOP::Class->initialize('Foo'));
+
+ dies_ok {
+ $attr->install_accessors;
+ } '... bad reader format';
+}
+
+{
+ my $attr = Class::MOP::Attribute->new('$test');
+
+ dies_ok {
+ $attr->process_accessors('fail', 'my_failing_sub');
+ } '... cannot find "fail" type generator';
+}
+
+
+{
+ {
+ package My::Attribute;
+ our @ISA = ('Class::MOP::Attribute');
+ sub generate_reader_method { eval { die } }
+ }
+
+ my $attr = My::Attribute->new('$test' => (
+ reader => 'test'
+ ));
+
+ dies_ok {
+ $attr->install_accessors;
+ } '... failed to generate accessors correctly';
+}
+
+{
+ my $attr = Class::MOP::Attribute->new('$test' => (
+ predicate => 'has_test'
+ ));
+
+ my $Bar = Class::MOP::Class->create('Bar' => '0.01');
+ isa_ok($Bar, 'Class::MOP::Class');
+
+ $Bar->add_attribute($attr);
+
+ can_ok('Bar', 'has_test');
+
+ is($attr, $Bar->remove_attribute('$test'), '... removed the $test attribute');
+
+ ok(!Bar->can('has_test'), '... Bar no longer has the "has_test" method');
+}
+
+
+{
+ # NOTE:
+ # the next three tests once tested that
+ # the code would fail, but we lifted the
+ # restriction so you can have an accessor
+ # along with a reader/writer pair (I mean
+ # why not really). So now they test that
+ # it works, which is kinda silly, but it
+ # tests the API change, so I keep it.
+
+ lives_ok {
+ Class::MOP::Attribute->new('$foo', (
+ accessor => 'foo',
+ reader => 'get_foo',
+ ));
+ } '... can create accessors with reader/writers';
+
+ lives_ok {
+ Class::MOP::Attribute->new('$foo', (
+ accessor => 'foo',
+ writer => 'set_foo',
+ ));
+ } '... can create accessors with reader/writers';
+
+ lives_ok {
+ Class::MOP::Attribute->new('$foo', (
+ accessor => 'foo',
+ reader => 'get_foo',
+ writer => 'set_foo',
+ ));
+ } '... can create accessors with reader/writers';
+}
Added: packages/libclass-mop-perl/branches/upstream/current/t/030_method.t
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libclass-mop-perl/branches/upstream/current/t/030_method.t?rev=2608&op=file
==============================================================================
--- packages/libclass-mop-perl/branches/upstream/current/t/030_method.t (added)
+++ packages/libclass-mop-perl/branches/upstream/current/t/030_method.t Thu Apr 20 11:21:04 2006
@@ -1,0 +1,44 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 18;
+use Test::Exception;
+
+BEGIN {
+ use_ok('Class::MOP');
+ use_ok('Class::MOP::Method');
+}
+
+my $method = Class::MOP::Method->wrap(sub { 1 });
+is($method->meta, Class::MOP::Method->meta, '... instance and class both lead to the same meta');
+
+is($method->package_name, 'main', '... our package is main::');
+is($method->name, '__ANON__', '... our sub name is __ANON__');
+
+my $meta = Class::MOP::Method->meta;
+isa_ok($meta, 'Class::MOP::Class');
+
+foreach my $method_name (qw(
+ wrap
+ package_name
+ name
+ )) {
+ ok($meta->has_method($method_name), '... Class::MOP::Method->has_method(' . $method_name . ')');
+ my $method = $meta->get_method($method_name);
+ is($method->package_name, 'Class::MOP::Method', '... our package is Class::MOP::Method');
+ is($method->name, $method_name, '... our sub name is "' . $method_name . '"');
+}
+
+dies_ok {
+ Class::MOP::Method->wrap()
+} '... bad args for &wrap';
+
+dies_ok {
+ Class::MOP::Method->wrap('Fail')
+} '... bad args for &wrap';
+
+dies_ok {
+ Class::MOP::Method->wrap([])
+} '... bad args for &wrap';
Added: packages/libclass-mop-perl/branches/upstream/current/t/031_method_modifiers.t
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libclass-mop-perl/branches/upstream/current/t/031_method_modifiers.t?rev=2608&op=file
==============================================================================
--- packages/libclass-mop-perl/branches/upstream/current/t/031_method_modifiers.t (added)
+++ packages/libclass-mop-perl/branches/upstream/current/t/031_method_modifiers.t Thu Apr 20 11:21:04 2006
@@ -1,0 +1,119 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 26;
+use Test::Exception;
+
+BEGIN {
+ use_ok('Class::MOP');
+ use_ok('Class::MOP::Method');
+}
+
+# test before and afters
+{
+ my $trace = '';
+
+ my $method = Class::MOP::Method->wrap(sub { $trace .= 'primary' });
+ isa_ok($method, 'Class::MOP::Method');
+
+ $method->();
+ is($trace, 'primary', '... got the right return value from method');
+ $trace = '';
+
+ my $wrapped = Class::MOP::Method::Wrapped->wrap($method);
+ isa_ok($wrapped, 'Class::MOP::Method::Wrapped');
+ isa_ok($wrapped, 'Class::MOP::Method');
+
+ $wrapped->();
+ is($trace, 'primary', '... got the right return value from the wrapped method');
+ $trace = '';
+
+ lives_ok {
+ $wrapped->add_before_modifier(sub { $trace .= 'before -> ' });
+ } '... added the before modifier okay';
+
+ $wrapped->();
+ is($trace, 'before -> primary', '... got the right return value from the wrapped method (w/ before)');
+ $trace = '';
+
+ lives_ok {
+ $wrapped->add_after_modifier(sub { $trace .= ' -> after' });
+ } '... added the after modifier okay';
+
+ $wrapped->();
+ is($trace, 'before -> primary -> after', '... got the right return value from the wrapped method (w/ before)');
+ $trace = '';
+}
+
+# test around method
+{
+ my $method = Class::MOP::Method->wrap(sub { 4 });
+ isa_ok($method, 'Class::MOP::Method');
+
+ is($method->(), 4, '... got the right value from the wrapped method');
+
+ my $wrapped = Class::MOP::Method::Wrapped->wrap($method);
+ isa_ok($wrapped, 'Class::MOP::Method::Wrapped');
+ isa_ok($wrapped, 'Class::MOP::Method');
+
+ is($wrapped->(), 4, '... got the right value from the wrapped method');
+
+ lives_ok {
+ $wrapped->add_around_modifier(sub { (3, $_[0]->()) });
+ $wrapped->add_around_modifier(sub { (2, $_[0]->()) });
+ $wrapped->add_around_modifier(sub { (1, $_[0]->()) });
+ $wrapped->add_around_modifier(sub { (0, $_[0]->()) });
+ } '... added the around modifier okay';
+
+ is_deeply(
+ [ $wrapped->() ],
+ [ 0, 1, 2, 3, 4 ],
+ '... got the right results back from the around methods (in list context)');
+
+ is(scalar $wrapped->(), 4, '... got the right results back from the around methods (in scalar context)');
+}
+
+{
+ my @tracelog;
+
+ my $method = Class::MOP::Method->wrap(sub { push @tracelog => 'primary' });
+ isa_ok($method, 'Class::MOP::Method');
+
+ my $wrapped = Class::MOP::Method::Wrapped->wrap($method);
+ isa_ok($wrapped, 'Class::MOP::Method::Wrapped');
+ isa_ok($wrapped, 'Class::MOP::Method');
+
+ lives_ok {
+ $wrapped->add_before_modifier(sub { push @tracelog => 'before 1' });
+ $wrapped->add_before_modifier(sub { push @tracelog => 'before 2' });
+ $wrapped->add_before_modifier(sub { push @tracelog => 'before 3' });
+ } '... added the before modifier okay';
+
+ lives_ok {
+ $wrapped->add_around_modifier(sub { push @tracelog => 'around 1'; $_[0]->(); });
+ $wrapped->add_around_modifier(sub { push @tracelog => 'around 2'; $_[0]->(); });
+ $wrapped->add_around_modifier(sub { push @tracelog => 'around 3'; $_[0]->(); });
+ } '... added the around modifier okay';
+
+ lives_ok {
+ $wrapped->add_after_modifier(sub { push @tracelog => 'after 1' });
+ $wrapped->add_after_modifier(sub { push @tracelog => 'after 2' });
+ $wrapped->add_after_modifier(sub { push @tracelog => 'after 3' });
+ } '... added the after modifier okay';
+
+ $wrapped->();
+ is_deeply(
+ \@tracelog,
+ [
+ 'before 3', 'before 2', 'before 1', # last-in-first-out order
+ 'around 3', 'around 2', 'around 1', # last-in-first-out order
+ 'primary',
+ 'after 1', 'after 2', 'after 3', # first-in-first-out order
+ ],
+ '... got the right tracelog from all our before/around/after methods');
+}
+
+
+
Added: packages/libclass-mop-perl/branches/upstream/current/t/040_metaclass.t
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libclass-mop-perl/branches/upstream/current/t/040_metaclass.t?rev=2608&op=file
==============================================================================
--- packages/libclass-mop-perl/branches/upstream/current/t/040_metaclass.t (added)
+++ packages/libclass-mop-perl/branches/upstream/current/t/040_metaclass.t Thu Apr 20 11:21:04 2006
@@ -1,0 +1,61 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 12;
+
+BEGIN {
+ use_ok('metaclass');
+}
+
+{
+ package FooMeta;
+ use base 'Class::MOP::Class';
+
+ package Foo;
+ use metaclass 'FooMeta';
+}
+
+can_ok('Foo', 'meta');
+isa_ok(Foo->meta, 'FooMeta');
+isa_ok(Foo->meta, 'Class::MOP::Class');
+
+{
+ package BarMeta;
+ use base 'Class::MOP::Class';
+
+ package BarMeta::Attribute;
+ use base 'Class::MOP::Attribute';
+
+ package BarMeta::Method;
+ use base 'Class::MOP::Method';
+
+ package Bar;
+ use metaclass 'BarMeta' => (
+ ':attribute_metaclass' => 'BarMeta::Attribute',
+ ':method_metaclass' => 'BarMeta::Method',
+ );
+}
+
+can_ok('Bar', 'meta');
+isa_ok(Bar->meta, 'BarMeta');
+isa_ok(Bar->meta, 'Class::MOP::Class');
+
+is(Bar->meta->attribute_metaclass, 'BarMeta::Attribute', '... got the right attribute metaobject');
+is(Bar->meta->method_metaclass, 'BarMeta::Method', '... got the right method metaobject');
+
+{
+ package Baz;
+ use metaclass;
+}
+
+can_ok('Baz', 'meta');
+isa_ok(Baz->meta, 'Class::MOP::Class');
+
+eval {
+ package Boom;
+ metaclass->import('Foo');
+};
+ok($@, '... metaclasses must be subclass of Class::MOP::Class');
+
Added: packages/libclass-mop-perl/branches/upstream/current/t/041_metaclass_incompatability.t
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libclass-mop-perl/branches/upstream/current/t/041_metaclass_incompatability.t?rev=2608&op=file
==============================================================================
--- packages/libclass-mop-perl/branches/upstream/current/t/041_metaclass_incompatability.t (added)
+++ packages/libclass-mop-perl/branches/upstream/current/t/041_metaclass_incompatability.t Thu Apr 20 11:21:04 2006
@@ -1,0 +1,70 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 7;
+
+BEGIN {
+ use_ok('metaclass');
+}
+
+# meta classes
+{
+ package Foo::Meta;
+ use base 'Class::MOP::Class';
+
+ package Bar::Meta;
+ use base 'Class::MOP::Class';
+
+ package FooBar::Meta;
+ use base 'Foo::Meta', 'Bar::Meta';
+}
+
+$@ = undef;
+eval {
+ package Foo;
+ metaclass->import('Foo::Meta');
+};
+ok(!$@, '... Foo.meta => Foo::Meta is compatible') || diag $@;
+
+$@ = undef;
+eval {
+ package Bar;
+ metaclass->import('Bar::Meta');
+};
+ok(!$@, '... Bar.meta => Bar::Meta is compatible') || diag $@;
+
+$@ = undef;
+eval {
+ package Foo::Foo;
+ use base 'Foo';
+ metaclass->import('Bar::Meta');
+};
+ok($@, '... Foo::Foo.meta => Bar::Meta is not compatible') || diag $@;
+
+$@ = undef;
+eval {
+ package Bar::Bar;
+ use base 'Bar';
+ metaclass->import('Foo::Meta');
+};
+ok($@, '... Bar::Bar.meta => Foo::Meta is not compatible') || diag $@;
+
+$@ = undef;
+eval {
+ package FooBar;
+ use base 'Foo';
+ metaclass->import('FooBar::Meta');
+};
+ok(!$@, '... FooBar.meta => FooBar::Meta is compatible') || diag $@;
+
+$@ = undef;
+eval {
+ package FooBar2;
+ use base 'Bar';
+ metaclass->import('FooBar::Meta');
+};
+ok(!$@, '... FooBar2.meta => FooBar::Meta is compatible') || diag $@;
+
+
Added: packages/libclass-mop-perl/branches/upstream/current/t/050_scala_style_mixin_composition.t
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libclass-mop-perl/branches/upstream/current/t/050_scala_style_mixin_composition.t?rev=2608&op=file
==============================================================================
--- packages/libclass-mop-perl/branches/upstream/current/t/050_scala_style_mixin_composition.t (added)
+++ packages/libclass-mop-perl/branches/upstream/current/t/050_scala_style_mixin_composition.t Thu Apr 20 11:21:04 2006
@@ -1,0 +1,177 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More;
+
+BEGIN {
+ eval "use SUPER 1.10";
+ plan skip_all => "SUPER 1.10 required for this test" if $@;
+ plan tests => 4;
+}
+
+=pod
+
+This test demonstrates how simple it is to create Scala Style
+Class Mixin Composition. Below is an example taken from the
+Scala web site's example section, and trancoded to Class::MOP.
+
+NOTE:
+We require SUPER for this test to handle the issue with SUPER::
+being determined at compile time.
+
+L<http://scala.epfl.ch/intro/mixin.html>
+
+A class can only be used as a mixin in the definition of another
+class, if this other class extends a subclass of the superclass
+of the mixin. Since ColoredPoint3D extends Point3D and Point3D
+extends Point2D which is the superclass of ColoredPoint2D, the
+code above is well-formed.
+
+ class Point2D(xc: Int, yc: Int) {
+ val x = xc;
+ val y = yc;
+ override def toString() = "x = " + x + ", y = " + y;
+ }
+
+ class ColoredPoint2D(u: Int, v: Int, c: String) extends Point2D(u, v) {
+ val color = c;
+ def setColor(newCol: String): Unit = color = newCol;
+ override def toString() = super.toString() + ", col = " + color;
+ }
+
+ class Point3D(xc: Int, yc: Int, zc: Int) extends Point2D(xc, yc) {
+ val z = zc;
+ override def toString() = super.toString() + ", z = " + z;
+ }
+
+ class ColoredPoint3D(xc: Int, yc: Int, zc: Int, col: String)
+ extends Point3D(xc, yc, zc)
+ with ColoredPoint2D(xc, yc, col);
+
+
+ Console.println(new ColoredPoint3D(1, 2, 3, "blue").toString())
+
+ "x = 1, y = 2, z = 3, col = blue"
+
+=cut
+
+use Scalar::Util 'blessed';
+use Carp 'confess';
+
+sub ::with ($) {
+ # fetch the metaclass for the
+ # caller and the mixin arg
+ my $metaclass = (caller)->meta;
+ my $mixin = (shift)->meta;
+
+ # according to Scala, the
+ # the superclass of our class
+ # must be a subclass of the
+ # superclass of the mixin (see above)
+ my ($super_meta) = $metaclass->superclasses();
+ my ($super_mixin) = $mixin->superclasses();
+ ($super_meta->isa($super_mixin))
+ || confess "The superclass must extend a subclass of the superclass of the mixin";
+
+ # collect all the attributes
+ # and clone them so they can
+ # associate with the new class
+ my @attributes = map {
+ $mixin->get_attribute($_)->clone()
+ } $mixin->get_attribute_list;
+
+ my %methods = map {
+ my $method = $mixin->get_method($_);
+ # we want to ignore accessors since
+ # they will be created with the attrs
+ (blessed($method) && $method->isa('Class::MOP::Attribute::Accessor'))
+ ? () : ($_ => $method)
+ } $mixin->get_method_list;
+
+ # NOTE:
+ # I assume that locally defined methods
+ # and attributes get precedence over those
+ # from the mixin.
+
+ # add all the attributes in ....
+ foreach my $attr (@attributes) {
+ $metaclass->add_attribute($attr)
+ unless $metaclass->has_attribute($attr->name);
+ }
+
+ # add all the methods in ....
+ foreach my $method_name (keys %methods) {
+ $metaclass->alias_method($method_name => $methods{$method_name})
+ unless $metaclass->has_method($method_name);
+ }
+}
+
+{
+ package Point2D;
+ use metaclass;
+
+ Point2D->meta->add_attribute('$x' => (
+ accessor => 'x',
+ init_arg => 'x',
+ ));
+
+ Point2D->meta->add_attribute('$y' => (
+ accessor => 'y',
+ init_arg => 'y',
+ ));
+
+ sub new {
+ my $class = shift;
+ $class->meta->new_object(@_);
+ }
+
+ sub toString {
+ my $self = shift;
+ "x = " . $self->x . ", y = " . $self->y;
+ }
+
+ package ColoredPoint2D;
+ our @ISA = ('Point2D');
+
+ ColoredPoint2D->meta->add_attribute('$color' => (
+ accessor => 'color',
+ init_arg => 'color',
+ ));
+
+ sub toString {
+ my $self = shift;
+ $self->SUPER() . ', col = ' . $self->color;
+ }
+
+ package Point3D;
+ our @ISA = ('Point2D');
+
+ Point3D->meta->add_attribute('$z' => (
+ accessor => 'z',
+ init_arg => 'z',
+ ));
+
+ sub toString {
+ my $self = shift;
+ $self->SUPER() . ', z = ' . $self->z;
+ }
+
+ package ColoredPoint3D;
+ our @ISA = ('Point3D');
+
+ ::with('ColoredPoint2D');
+
+}
+
+my $colored_point_3d = ColoredPoint3D->new(x => 1, y => 2, z => 3, color => 'blue');
+isa_ok($colored_point_3d, 'ColoredPoint3D');
+isa_ok($colored_point_3d, 'Point3D');
+isa_ok($colored_point_3d, 'Point2D');
+
+is($colored_point_3d->toString(),
+ 'x = 1, y = 2, z = 3, col = blue',
+ '... got the right toString method');
+
+
Added: packages/libclass-mop-perl/branches/upstream/current/t/100_BinaryTree_test.t
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libclass-mop-perl/branches/upstream/current/t/100_BinaryTree_test.t?rev=2608&op=file
==============================================================================
--- packages/libclass-mop-perl/branches/upstream/current/t/100_BinaryTree_test.t (added)
+++ packages/libclass-mop-perl/branches/upstream/current/t/100_BinaryTree_test.t Thu Apr 20 11:21:04 2006
@@ -1,0 +1,322 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 68;
+
+BEGIN {
+ use_ok('Class::MOP');
+ use_ok('t::lib::BinaryTree');
+}
+
+## ----------------------------------------------------------------------------
+## These are all tests which are derived from the Tree::Binary test suite
+## ----------------------------------------------------------------------------
+
+## ----------------------------------------------------------------------------
+## t/10_Tree_Binary_test.t
+
+can_ok("BinaryTree", 'new');
+can_ok("BinaryTree", 'setLeft');
+can_ok("BinaryTree", 'setRight');
+
+my $btree = BinaryTree->new("/")
+ ->setLeft(
+ BinaryTree->new("+")
+ ->setLeft(
+ BinaryTree->new("2")
+ )
+ ->setRight(
+ BinaryTree->new("2")
+ )
+ )
+ ->setRight(
+ BinaryTree->new("*")
+ ->setLeft(
+ BinaryTree->new("4")
+ )
+ ->setRight(
+ BinaryTree->new("5")
+ )
+ );
+isa_ok($btree, 'BinaryTree');
+
+## informational methods
+
+can_ok($btree, 'isRoot');
+ok($btree->isRoot(), '... this is the root');
+
+can_ok($btree, 'isLeaf');
+ok(!$btree->isLeaf(), '... this is not a leaf node');
+ok($btree->getLeft()->getLeft()->isLeaf(), '... this is a leaf node');
+
+can_ok($btree, 'hasLeft');
+ok($btree->hasLeft(), '... this has a left node');
+
+can_ok($btree, 'hasRight');
+ok($btree->hasRight(), '... this has a right node');
+
+## accessors
+
+can_ok($btree, 'getUID');
+
+{
+ my $UID = $btree->getUID();
+ is(("$btree" =~ /\((.*?)\)$/), $UID, '... our UID is derived from the stringified object');
+}
+
+can_ok($btree, 'getNodeValue');
+is($btree->getNodeValue(), '/', '... got what we expected');
+
+{
+ can_ok($btree, 'getLeft');
+ my $left = $btree->getLeft();
+
+ isa_ok($left, 'BinaryTree');
+
+ is($left->getNodeValue(), '+', '... got what we expected');
+
+ can_ok($left, 'getParent');
+
+ my $parent = $left->getParent();
+ isa_ok($parent, 'BinaryTree');
+
+ is($parent, $btree, '.. got what we expected');
+}
+
+{
+ can_ok($btree, 'getRight');
+ my $right = $btree->getRight();
+
+ isa_ok($right, 'BinaryTree');
+
+ is($right->getNodeValue(), '*', '... got what we expected');
+
+ can_ok($right, 'getParent');
+
+ my $parent = $right->getParent();
+ isa_ok($parent, 'BinaryTree');
+
+ is($parent, $btree, '.. got what we expected');
+}
+
+## mutators
+
+can_ok($btree, 'setUID');
+$btree->setUID("Our UID for this tree");
+
+is($btree->getUID(), 'Our UID for this tree', '... our UID is not what we expected');
+
+can_ok($btree, 'setNodeValue');
+$btree->setNodeValue('*');
+
+is($btree->getNodeValue(), '*', '... got what we expected');
+
+
+{
+ can_ok($btree, 'removeLeft');
+ my $left = $btree->removeLeft();
+ isa_ok($left, 'BinaryTree');
+
+ ok(!$btree->hasLeft(), '... we dont have a left node anymore');
+ ok(!$btree->isLeaf(), '... and we are not a leaf node');
+
+ $btree->setLeft($left);
+
+ ok($btree->hasLeft(), '... we have our left node again');
+ is($btree->getLeft(), $left, '... and it is what we told it to be');
+}
+
+{
+ # remove left leaf
+ my $left_leaf = $btree->getLeft()->removeLeft();
+ isa_ok($left_leaf, 'BinaryTree');
+
+ ok($left_leaf->isLeaf(), '... our left leaf is a leaf');
+
+ ok(!$btree->getLeft()->hasLeft(), '... we dont have a left leaf node anymore');
+
+ $btree->getLeft()->setLeft($left_leaf);
+
+ ok($btree->getLeft()->hasLeft(), '... we have our left leaf node again');
+ is($btree->getLeft()->getLeft(), $left_leaf, '... and it is what we told it to be');
+}
+
+{
+ can_ok($btree, 'removeRight');
+ my $right = $btree->removeRight();
+ isa_ok($right, 'BinaryTree');
+
+ ok(!$btree->hasRight(), '... we dont have a right node anymore');
+ ok(!$btree->isLeaf(), '... and we are not a leaf node');
+
+ $btree->setRight($right);
+
+ ok($btree->hasRight(), '... we have our right node again');
+ is($btree->getRight(), $right, '... and it is what we told it to be')
+}
+
+{
+ # remove right leaf
+ my $right_leaf = $btree->getRight()->removeRight();
+ isa_ok($right_leaf, 'BinaryTree');
+
+ ok($right_leaf->isLeaf(), '... our right leaf is a leaf');
+
+ ok(!$btree->getRight()->hasRight(), '... we dont have a right leaf node anymore');
+
+ $btree->getRight()->setRight($right_leaf);
+
+ ok($btree->getRight()->hasRight(), '... we have our right leaf node again');
+ is($btree->getRight()->getRight(), $right_leaf, '... and it is what we told it to be');
+}
+
+# some of the recursive informational methods
+
+{
+
+ my $btree = BinaryTree->new("o")
+ ->setLeft(
+ BinaryTree->new("o")
+ ->setLeft(
+ BinaryTree->new("o")
+ )
+ ->setRight(
+ BinaryTree->new("o")
+ ->setLeft(
+ BinaryTree->new("o")
+ ->setLeft(
+ BinaryTree->new("o")
+ ->setRight(BinaryTree->new("o"))
+ )
+ )
+ )
+ )
+ ->setRight(
+ BinaryTree->new("o")
+ ->setLeft(
+ BinaryTree->new("o")
+ ->setRight(
+ BinaryTree->new("o")
+ ->setLeft(
+ BinaryTree->new("o")
+ )
+ ->setRight(
+ BinaryTree->new("o")
+ )
+ )
+ )
+ ->setRight(
+ BinaryTree->new("o")
+ ->setRight(BinaryTree->new("o"))
+ )
+ );
+ isa_ok($btree, 'BinaryTree');
+
+ can_ok($btree, 'size');
+ cmp_ok($btree->size(), '==', 14, '... we have 14 nodes in the tree');
+
+ can_ok($btree, 'height');
+ cmp_ok($btree->height(), '==', 6, '... the tree is 6 nodes tall');
+
+}
+
+## ----------------------------------------------------------------------------
+## t/13_Tree_Binary_mirror_test.t
+
+sub inOrderTraverse {
+ my $tree = shift;
+ my @results;
+ my $_inOrderTraverse = sub {
+ my ($tree, $traversal_function) = @_;
+ $traversal_function->($tree->getLeft(), $traversal_function) if $tree->hasLeft();
+ push @results => $tree->getNodeValue();
+ $traversal_function->($tree->getRight(), $traversal_function) if $tree->hasRight();
+ };
+ $_inOrderTraverse->($tree, $_inOrderTraverse);
+ @results;
+}
+
+# test it on a simple well balanaced tree
+{
+ my $btree = BinaryTree->new(4)
+ ->setLeft(
+ BinaryTree->new(2)
+ ->setLeft(
+ BinaryTree->new(1)
+ )
+ ->setRight(
+ BinaryTree->new(3)
+ )
+ )
+ ->setRight(
+ BinaryTree->new(6)
+ ->setLeft(
+ BinaryTree->new(5)
+ )
+ ->setRight(
+ BinaryTree->new(7)
+ )
+ );
+ isa_ok($btree, 'BinaryTree');
+
+ is_deeply(
+ [ inOrderTraverse($btree) ],
+ [ 1 .. 7 ],
+ '... check that our tree starts out correctly');
+
+ can_ok($btree, 'mirror');
+ $btree->mirror();
+
+ is_deeply(
+ [ inOrderTraverse($btree) ],
+ [ reverse(1 .. 7) ],
+ '... check that our tree ends up correctly');
+}
+
+# test is on a more chaotic tree
+{
+ my $btree = BinaryTree->new(4)
+ ->setLeft(
+ BinaryTree->new(20)
+ ->setLeft(
+ BinaryTree->new(1)
+ ->setRight(
+ BinaryTree->new(10)
+ ->setLeft(
+ BinaryTree->new(5)
+ )
+ )
+ )
+ ->setRight(
+ BinaryTree->new(3)
+ )
+ )
+ ->setRight(
+ BinaryTree->new(6)
+ ->setLeft(
+ BinaryTree->new(5)
+ ->setRight(
+ BinaryTree->new(7)
+ ->setLeft(
+ BinaryTree->new(90)
+ )
+ ->setRight(
+ BinaryTree->new(91)
+ )
+ )
+ )
+ );
+ isa_ok($btree, 'BinaryTree');
+
+ my @results = inOrderTraverse($btree);
+
+ $btree->mirror();
+
+ is_deeply(
+ [ inOrderTraverse($btree) ],
+ [ reverse(@results) ],
+ '... this should be the reverse of the original');
+}
+
Added: packages/libclass-mop-perl/branches/upstream/current/t/101_InstanceCountingClass_test.t
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libclass-mop-perl/branches/upstream/current/t/101_InstanceCountingClass_test.t?rev=2608&op=file
==============================================================================
--- packages/libclass-mop-perl/branches/upstream/current/t/101_InstanceCountingClass_test.t (added)
+++ packages/libclass-mop-perl/branches/upstream/current/t/101_InstanceCountingClass_test.t Thu Apr 20 11:21:04 2006
@@ -1,0 +1,59 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 12;
+use File::Spec;
+
+BEGIN {
+ use_ok('Class::MOP');
+ require_ok(File::Spec->catdir('examples', 'InstanceCountingClass.pod'));
+}
+
+=pod
+
+This is a trivial and contrived example of how to
+make a metaclass which will count all the instances
+created. It is not meant to be anything more than
+a simple demonstration of how to make a metaclass.
+
+=cut
+
+{
+ package Foo;
+
+ use metaclass 'InstanceCountingClass';
+
+ sub new {
+ my $class = shift;
+ $class->meta->new_object(@_);
+ }
+
+ package Bar;
+
+ our @ISA = ('Foo');
+}
+
+is(Foo->meta->get_count(), 0, '... our Foo count is 0');
+is(Bar->meta->get_count(), 0, '... our Bar count is 0');
+
+my $foo = Foo->new();
+isa_ok($foo, 'Foo');
+
+is(Foo->meta->get_count(), 1, '... our Foo count is now 1');
+is(Bar->meta->get_count(), 0, '... our Bar count is still 0');
+
+my $bar = Bar->new();
+isa_ok($bar, 'Bar');
+
+is(Foo->meta->get_count(), 1, '... our Foo count is still 1');
+is(Bar->meta->get_count(), 1, '... our Bar count is now 1');
+
+for (2 .. 10) {
+ Foo->new();
+}
+
+is(Foo->meta->get_count(), 10, '... our Foo count is now 10');
+is(Bar->meta->get_count(), 1, '... our Bar count is still 1');
+
Added: packages/libclass-mop-perl/branches/upstream/current/t/102_InsideOutClass_test.t
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libclass-mop-perl/branches/upstream/current/t/102_InsideOutClass_test.t?rev=2608&op=file
==============================================================================
--- packages/libclass-mop-perl/branches/upstream/current/t/102_InsideOutClass_test.t (added)
+++ packages/libclass-mop-perl/branches/upstream/current/t/102_InsideOutClass_test.t Thu Apr 20 11:21:04 2006
@@ -1,0 +1,68 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 19;
+use File::Spec;
+
+BEGIN {
+ use_ok('Class::MOP');
+ require_ok(File::Spec->catdir('examples', 'InsideOutClass.pod'));
+}
+
+{
+ package Foo;
+
+ use metaclass 'InsideOutClass' => (
+ ':attribute_metaclass' => 'InsideOutClass::Attribute'
+ );
+
+ Foo->meta->add_attribute('foo' => (
+ accessor => 'foo',
+ predicate => 'has_foo',
+ ));
+
+ Foo->meta->add_attribute('bar' => (
+ reader => 'get_bar',
+ writer => 'set_bar',
+ default => 'FOO is BAR'
+ ));
+
+ sub new {
+ my $class = shift;
+ $class->meta->new_object(@_);
+ }
+}
+
+my $foo = Foo->new();
+isa_ok($foo, 'Foo');
+
+can_ok($foo, 'foo');
+can_ok($foo, 'has_foo');
+can_ok($foo, 'get_bar');
+can_ok($foo, 'set_bar');
+
+ok(!$foo->has_foo, '... Foo::foo is not defined yet');
+is($foo->foo(), undef, '... Foo::foo is not defined yet');
+is($foo->get_bar(), 'FOO is BAR', '... Foo::bar has been initialized');
+
+$foo->foo('This is Foo');
+
+ok($foo->has_foo, '... Foo::foo is defined now');
+is($foo->foo(), 'This is Foo', '... Foo::foo == "This is Foo"');
+
+$foo->set_bar(42);
+is($foo->get_bar(), 42, '... Foo::bar == 42');
+
+my $foo2 = Foo->new();
+isa_ok($foo2, 'Foo');
+
+ok(!$foo2->has_foo, '... Foo2::foo is not defined yet');
+is($foo2->foo(), undef, '... Foo2::foo is not defined yet');
+is($foo2->get_bar(), 'FOO is BAR', '... Foo2::bar has been initialized');
+
+$foo2->set_bar('DONT PANIC');
+is($foo2->get_bar(), 'DONT PANIC', '... Foo2::bar == DONT PANIC');
+
+is($foo->get_bar(), 42, '... Foo::bar == 42');
Added: packages/libclass-mop-perl/branches/upstream/current/t/103_Perl6Attribute_test.t
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libclass-mop-perl/branches/upstream/current/t/103_Perl6Attribute_test.t?rev=2608&op=file
==============================================================================
--- packages/libclass-mop-perl/branches/upstream/current/t/103_Perl6Attribute_test.t (added)
+++ packages/libclass-mop-perl/branches/upstream/current/t/103_Perl6Attribute_test.t Thu Apr 20 11:21:04 2006
@@ -1,0 +1,42 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 10;
+use File::Spec;
+
+BEGIN {
+ use_ok('Class::MOP');
+ require_ok(File::Spec->catdir('examples', 'Perl6Attribute.pod'));
+}
+
+{
+ package Foo;
+
+ use metaclass;
+
+ Foo->meta->add_attribute(Perl6Attribute->new('$.foo'));
+ Foo->meta->add_attribute(Perl6Attribute->new('@.bar'));
+ Foo->meta->add_attribute(Perl6Attribute->new('%.baz'));
+
+ sub new {
+ my $class = shift;
+ $class->meta->new_object(@_);
+ }
+}
+
+my $foo = Foo->new();
+isa_ok($foo, 'Foo');
+
+can_ok($foo, 'foo');
+can_ok($foo, 'bar');
+can_ok($foo, 'baz');
+
+is($foo->foo, undef, '... Foo.foo == undef');
+
+$foo->foo(42);
+is($foo->foo, 42, '... Foo.foo == 42');
+
+is_deeply($foo->bar, [], '... Foo.bar == []');
+is_deeply($foo->baz, {}, '... Foo.baz == {}');
Added: packages/libclass-mop-perl/branches/upstream/current/t/104_AttributesWithHistory_test.t
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libclass-mop-perl/branches/upstream/current/t/104_AttributesWithHistory_test.t?rev=2608&op=file
==============================================================================
--- packages/libclass-mop-perl/branches/upstream/current/t/104_AttributesWithHistory_test.t (added)
+++ packages/libclass-mop-perl/branches/upstream/current/t/104_AttributesWithHistory_test.t Thu Apr 20 11:21:04 2006
@@ -1,0 +1,120 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 28;
+use File::Spec;
+
+BEGIN {
+ use_ok('Class::MOP');
+ require_ok(File::Spec->catdir('examples', 'AttributesWithHistory.pod'));
+}
+
+{
+ package Foo;
+ use metaclass;
+
+ Foo->meta->add_attribute(AttributesWithHistory->new('foo' => (
+ accessor => 'foo',
+ history_accessor => 'get_foo_history',
+ )));
+
+ Foo->meta->add_attribute(AttributesWithHistory->new('bar' => (
+ reader => 'get_bar',
+ writer => 'set_bar',
+ history_accessor => 'get_bar_history',
+ )));
+
+ sub new {
+ my $class = shift;
+ $class->meta->new_object(@_);
+ }
+}
+
+my $foo = Foo->new();
+isa_ok($foo, 'Foo');
+
+can_ok($foo, 'foo');
+can_ok($foo, 'get_foo_history');
+can_ok($foo, 'set_bar');
+can_ok($foo, 'get_bar');
+can_ok($foo, 'get_bar_history');
+
+my $foo2 = Foo->new();
+isa_ok($foo2, 'Foo');
+
+is($foo->foo, undef, '... foo is not yet defined');
+is_deeply(
+ [ $foo->get_foo_history() ],
+ [ ],
+ '... got correct empty history for foo');
+
+is($foo2->foo, undef, '... foo2 is not yet defined');
+is_deeply(
+ [ $foo2->get_foo_history() ],
+ [ ],
+ '... got correct empty history for foo2');
+
+$foo->foo(42);
+is($foo->foo, 42, '... foo == 42');
+is_deeply(
+ [ $foo->get_foo_history() ],
+ [ 42 ],
+ '... got correct history for foo');
+
+is($foo2->foo, undef, '... foo2 is still not yet defined');
+is_deeply(
+ [ $foo2->get_foo_history() ],
+ [ ],
+ '... still got correct empty history for foo2');
+
+$foo2->foo(100);
+is($foo->foo, 42, '... foo is still == 42');
+is_deeply(
+ [ $foo->get_foo_history() ],
+ [ 42 ],
+ '... still got correct history for foo');
+
+is($foo2->foo, 100, '... foo2 == 100');
+is_deeply(
+ [ $foo2->get_foo_history() ],
+ [ 100 ],
+ '... got correct empty history for foo2');
+
+$foo->foo(43);
+$foo->foo(44);
+$foo->foo(45);
+$foo->foo(46);
+
+is_deeply(
+ [ $foo->get_foo_history() ],
+ [ 42, 43, 44, 45, 46 ],
+ '... got correct history for foo');
+
+is($foo->get_bar, undef, '... bar is not yet defined');
+is_deeply(
+ [ $foo->get_bar_history() ],
+ [ ],
+ '... got correct empty history for foo');
+
+
+$foo->set_bar("FOO");
+is($foo->get_bar, "FOO", '... bar == "FOO"');
+is_deeply(
+ [ $foo->get_bar_history() ],
+ [ "FOO" ],
+ '... got correct history for foo');
+
+$foo->set_bar("BAR");
+$foo->set_bar("BAZ");
+
+is_deeply(
+ [ $foo->get_bar_history() ],
+ [ qw/FOO BAR BAZ/ ],
+ '... got correct history for bar');
+
+is_deeply(
+ [ $foo->get_foo_history() ],
+ [ 42, 43, 44, 45, 46 ],
+ '... still have the correct history for foo');
Added: packages/libclass-mop-perl/branches/upstream/current/t/105_ClassEncapsulatedAttributes_test.t
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libclass-mop-perl/branches/upstream/current/t/105_ClassEncapsulatedAttributes_test.t?rev=2608&op=file
==============================================================================
--- packages/libclass-mop-perl/branches/upstream/current/t/105_ClassEncapsulatedAttributes_test.t (added)
+++ packages/libclass-mop-perl/branches/upstream/current/t/105_ClassEncapsulatedAttributes_test.t Thu Apr 20 11:21:04 2006
@@ -1,0 +1,109 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 29;
+use File::Spec;
+
+BEGIN {
+ use_ok('Class::MOP');
+ require_ok(File::Spec->catdir('examples', 'ClassEncapsulatedAttributes.pod'));
+}
+
+{
+ package Foo;
+
+ use metaclass 'ClassEncapsulatedAttributes';
+
+ Foo->meta->add_attribute('foo' => (
+ accessor => 'foo',
+ predicate => 'has_foo',
+ default => 'init in FOO'
+ ));
+
+ Foo->meta->add_attribute('bar' => (
+ reader => 'get_bar',
+ writer => 'set_bar',
+ default => 'init in FOO'
+ ));
+
+ sub new {
+ my $class = shift;
+ $class->meta->new_object(@_);
+ }
+
+ package Bar;
+ our @ISA = ('Foo');
+
+ Bar->meta->add_attribute('foo' => (
+ accessor => 'foo',
+ predicate => 'has_foo',
+ default => 'init in BAR'
+ ));
+
+ Bar->meta->add_attribute('bar' => (
+ reader => 'get_bar',
+ writer => 'set_bar',
+ default => 'init in BAR'
+ ));
+
+ sub SUPER_foo { (shift)->SUPER::foo(@_) }
+ sub SUPER_has_foo { (shift)->SUPER::foo(@_) }
+ sub SUPER_get_bar { (shift)->SUPER::get_bar() }
+ sub SUPER_set_bar { (shift)->SUPER::set_bar(@_) }
+
+}
+
+{
+ my $foo = Foo->new();
+ isa_ok($foo, 'Foo');
+
+ can_ok($foo, 'foo');
+ can_ok($foo, 'has_foo');
+ can_ok($foo, 'get_bar');
+ can_ok($foo, 'set_bar');
+
+ my $bar = Bar->new();
+ isa_ok($bar, 'Bar');
+
+ can_ok($bar, 'foo');
+ can_ok($bar, 'has_foo');
+ can_ok($bar, 'get_bar');
+ can_ok($bar, 'set_bar');
+
+ ok($foo->has_foo, '... Foo::has_foo == 1');
+ ok($bar->has_foo, '... Bar::has_foo == 1');
+
+ is($foo->foo, 'init in FOO', '... got the right default value for Foo::foo');
+ is($bar->foo, 'init in BAR', '... got the right default value for Bar::foo');
+
+ is($bar->SUPER_foo(), 'init in FOO', '... got the right default value for Bar::SUPER::foo');
+
+ $bar->SUPER_foo(undef);
+
+ is($bar->SUPER_foo(), undef, '... successfully set Foo::foo through Bar::SUPER::foo');
+ ok(!$bar->SUPER_has_foo, '... BAR::SUPER::has_foo == 0');
+
+ ok($foo->has_foo, '... Foo::has_foo (is still) 1');
+}
+
+{
+ my $bar = Bar->new(
+ 'Foo' => { 'foo' => 'Foo::foo' },
+ 'Bar' => { 'foo' => 'Bar::foo' }
+ );
+ isa_ok($bar, 'Bar');
+
+ can_ok($bar, 'foo');
+ can_ok($bar, 'has_foo');
+ can_ok($bar, 'get_bar');
+ can_ok($bar, 'set_bar');
+
+ ok($bar->has_foo, '... Bar::has_foo == 1');
+ ok($bar->SUPER_has_foo, '... Bar::SUPER_has_foo == 1');
+
+ is($bar->foo, 'Bar::foo', '... got the right default value for Bar::foo');
+ is($bar->SUPER_foo(), 'Foo::foo', '... got the right default value for Bar::SUPER::foo');
+}
+
Added: packages/libclass-mop-perl/branches/upstream/current/t/106_LazyClass_test.t
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libclass-mop-perl/branches/upstream/current/t/106_LazyClass_test.t?rev=2608&op=file
==============================================================================
--- packages/libclass-mop-perl/branches/upstream/current/t/106_LazyClass_test.t (added)
+++ packages/libclass-mop-perl/branches/upstream/current/t/106_LazyClass_test.t Thu Apr 20 11:21:04 2006
@@ -1,0 +1,82 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 26;
+use File::Spec;
+
+BEGIN {
+ use_ok('Class::MOP');
+ require_ok(File::Spec->catdir('examples', 'LazyClass.pod'));
+}
+
+{
+ package BinaryTree;
+
+ use metaclass 'LazyClass' => (
+ ':attribute_metaclass' => 'LazyClass::Attribute'
+ );
+
+ BinaryTree->meta->add_attribute('$:node' => (
+ accessor => 'node',
+ init_arg => ':node'
+ ));
+
+ BinaryTree->meta->add_attribute('$:left' => (
+ reader => 'left',
+ default => sub { BinaryTree->new() }
+ ));
+
+ BinaryTree->meta->add_attribute('$:right' => (
+ reader => 'right',
+ default => sub { BinaryTree->new() }
+ ));
+
+ sub new {
+ my $class = shift;
+ bless $class->meta->construct_instance(@_) => $class;
+ }
+}
+
+my $root = BinaryTree->new(':node' => 0);
+isa_ok($root, 'BinaryTree');
+
+ok(exists($root->{'$:node'}), '... node attribute has been initialized yet');
+ok(!exists($root->{'$:left'}), '... left attribute has not been initialized yet');
+ok(!exists($root->{'$:right'}), '... right attribute has not been initialized yet');
+
+isa_ok($root->left, 'BinaryTree');
+isa_ok($root->right, 'BinaryTree');
+
+ok(exists($root->{'$:left'}), '... left attribute has now been initialized');
+ok(exists($root->{'$:right'}), '... right attribute has now been initialized');
+
+ok(!exists($root->left->{'$:node'}), '... node attribute has not been initialized yet');
+ok(!exists($root->left->{'$:left'}), '... left attribute has not been initialized yet');
+ok(!exists($root->left->{'$:right'}), '... right attribute has not been initialized yet');
+
+ok(!exists($root->right->{'$:node'}), '... node attribute has not been initialized yet');
+ok(!exists($root->right->{'$:left'}), '... left attribute has not been initialized yet');
+ok(!exists($root->right->{'$:right'}), '... right attribute has not been initialized yet');
+
+is($root->left->node(), undef, '... the left node is uninitialized');
+
+ok(exists($root->left->{'$:node'}), '... node attribute has now been initialized');
+
+$root->left->node(1);
+is($root->left->node(), 1, '... the left node == 1');
+
+ok(!exists($root->left->{'$:left'}), '... left attribute still has not been initialized yet');
+ok(!exists($root->left->{'$:right'}), '... right attribute still has not been initialized yet');
+
+is($root->right->node(), undef, '... the right node is uninitialized');
+
+ok(exists($root->right->{'$:node'}), '... node attribute has now been initialized');
+
+$root->right->node(2);
+is($root->right->node(), 2, '... the right node == 1');
+
+ok(!exists($root->right->{'$:left'}), '... left attribute still has not been initialized yet');
+ok(!exists($root->right->{'$:right'}), '... right attribute still has not been initialized yet');
+
Added: packages/libclass-mop-perl/branches/upstream/current/t/107_C3MethodDispatchOrder_test.t
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libclass-mop-perl/branches/upstream/current/t/107_C3MethodDispatchOrder_test.t?rev=2608&op=file
==============================================================================
--- packages/libclass-mop-perl/branches/upstream/current/t/107_C3MethodDispatchOrder_test.t (added)
+++ packages/libclass-mop-perl/branches/upstream/current/t/107_C3MethodDispatchOrder_test.t Thu Apr 20 11:21:04 2006
@@ -1,0 +1,47 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More;
+use File::Spec;
+
+BEGIN {
+ eval "use Algorithm::C3";
+ plan skip_all => "Algorithm::C3 required for this test" if $@;
+ plan tests => 5;
+
+ use_ok('Class::MOP');
+ require_ok(File::Spec->catdir('examples', 'C3MethodDispatchOrder.pod'));
+}
+
+{
+ package Diamond_A;
+ use metaclass 'C3MethodDispatchOrder';
+
+ sub hello { 'Diamond_A::hello' }
+
+ package Diamond_B;
+ use metaclass 'C3MethodDispatchOrder';
+ __PACKAGE__->meta->superclasses('Diamond_A');
+
+ package Diamond_C;
+ use metaclass 'C3MethodDispatchOrder';
+ __PACKAGE__->meta->superclasses('Diamond_A');
+
+ sub hello { 'Diamond_C::hello' }
+
+ package Diamond_D;
+ use metaclass 'C3MethodDispatchOrder';
+ __PACKAGE__->meta->superclasses('Diamond_B', 'Diamond_C');
+}
+
+is_deeply(
+ [ Diamond_D->meta->class_precedence_list ],
+ [ qw(Diamond_D Diamond_B Diamond_C Diamond_A) ],
+ '... got the right MRO for Diamond_D');
+
+is(Diamond_D->hello, 'Diamond_C::hello', '... got the right dispatch order');
+is(Diamond_D->can('hello')->(), 'Diamond_C::hello', '... can(method) resolved itself as expected');
+
+
Added: packages/libclass-mop-perl/branches/upstream/current/t/200_Class_C3_compatibility.t
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libclass-mop-perl/branches/upstream/current/t/200_Class_C3_compatibility.t?rev=2608&op=file
==============================================================================
--- packages/libclass-mop-perl/branches/upstream/current/t/200_Class_C3_compatibility.t (added)
+++ packages/libclass-mop-perl/branches/upstream/current/t/200_Class_C3_compatibility.t Thu Apr 20 11:21:04 2006
@@ -1,0 +1,63 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More;
+
+=pod
+
+This tests that Class::MOP works correctly
+with Class::C3 and it's somewhat insane
+approach to method resolution.
+
+=cut
+
+BEGIN {
+ eval "use Class::C3";
+ plan skip_all => "Class::C3 required for this test" if $@;
+ plan tests => 7;
+}
+
+{
+ package Diamond_A;
+ Class::C3->import;
+ use metaclass; # everyone will just inherit this now :)
+
+ sub hello { 'Diamond_A::hello' }
+}
+{
+ package Diamond_B;
+ use base 'Diamond_A';
+ Class::C3->import;
+}
+{
+ package Diamond_C;
+ Class::C3->import;
+ use base 'Diamond_A';
+
+ sub hello { 'Diamond_C::hello' }
+}
+{
+ package Diamond_D;
+ use base ('Diamond_B', 'Diamond_C');
+ Class::C3->import;
+}
+
+# we have to manually initialize
+# Class::C3 since we potentially
+# skip this test if it is not present
+Class::C3::initialize();
+
+is_deeply(
+ [ Class::C3::calculateMRO('Diamond_D') ],
+ [ qw(Diamond_D Diamond_B Diamond_C Diamond_A) ],
+ '... got the right MRO for Diamond_D');
+
+ok(Diamond_A->meta->has_method('hello'), '... A has a method hello');
+ok(!Diamond_B->meta->has_method('hello'), '... B does not have a method hello');
+ok(defined &Diamond_B::hello, '... B does have an alias to the method hello');
+
+ok(Diamond_C->meta->has_method('hello'), '... C has a method hello');
+ok(!Diamond_D->meta->has_method('hello'), '... D does not have a method hello');
+ok(defined &Diamond_D::hello, '... D does have an alias to the method hello');
Added: packages/libclass-mop-perl/branches/upstream/current/t/300_random_eval_bug.t
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libclass-mop-perl/branches/upstream/current/t/300_random_eval_bug.t?rev=2608&op=file
==============================================================================
--- packages/libclass-mop-perl/branches/upstream/current/t/300_random_eval_bug.t (added)
+++ packages/libclass-mop-perl/branches/upstream/current/t/300_random_eval_bug.t Thu Apr 20 11:21:04 2006
@@ -1,0 +1,51 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 2;
+
+BEGIN {
+ use_ok('Class::MOP');
+}
+
+=pod
+
+This tests a bug which is fixed in 0.22 by
+localizing all the $@'s around any evals.
+This a real pain to track down.
+
+Moral of the story:
+
+ ALWAYS localize your globals :)
+
+=cut
+
+{
+ package Company;
+ use strict;
+ use warnings;
+ use metaclass;
+
+ sub new {
+ my ($class) = @_;
+ return bless {} => $class;
+ }
+
+ sub employees {
+ die "This didnt work";
+ }
+
+ sub DESTROY {
+ my $self = shift;
+ foreach my $method ($self->meta->find_all_methods_by_name('DEMOLISH')) {
+ $method->{code}->($self);
+ }
+ }
+}
+
+eval {
+ my $c = Company->new();
+ $c->employees();
+};
+ok($@, '... we die correctly with bad args');
Added: packages/libclass-mop-perl/branches/upstream/current/t/lib/BinaryTree.pm
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libclass-mop-perl/branches/upstream/current/t/lib/BinaryTree.pm?rev=2608&op=file
==============================================================================
--- packages/libclass-mop-perl/branches/upstream/current/t/lib/BinaryTree.pm (added)
+++ packages/libclass-mop-perl/branches/upstream/current/t/lib/BinaryTree.pm Thu Apr 20 11:21:04 2006
@@ -1,0 +1,124 @@
+
+package BinaryTree;
+
+use strict;
+use warnings;
+
+use metaclass;
+
+our $VERSION = '0.02';
+
+BinaryTree->meta->add_attribute('$:uid' => (
+ reader => 'getUID',
+ writer => 'setUID',
+ default => sub {
+ my $instance = shift;
+ ("$instance" =~ /\((.*?)\)$/);
+ }
+));
+
+BinaryTree->meta->add_attribute('$:node' => (
+ reader => 'getNodeValue',
+ writer => 'setNodeValue',
+ init_arg => ':node'
+));
+
+BinaryTree->meta->add_attribute('$:parent' => (
+ predicate => 'hasParent',
+ reader => 'getParent',
+ writer => 'setParent'
+));
+
+BinaryTree->meta->add_attribute('$:left' => (
+ predicate => 'hasLeft',
+ reader => 'getLeft',
+ writer => {
+ 'setLeft' => sub {
+ my ($self, $tree) = @_;
+ $tree->setParent($self) if defined $tree;
+ $self->{'$:left'} = $tree;
+ $self;
+ }
+ },
+));
+
+BinaryTree->meta->add_attribute('$:right' => (
+ predicate => 'hasRight',
+ reader => 'getRight',
+ writer => {
+ 'setRight' => sub {
+ my ($self, $tree) = @_;
+ $tree->setParent($self) if defined $tree;
+ $self->{'$:right'} = $tree;
+ $self;
+ }
+ }
+));
+
+sub new {
+ my $class = shift;
+ $class->meta->new_object(':node' => shift);
+}
+
+sub removeLeft {
+ my ($self) = @_;
+ my $left = $self->getLeft();
+ $left->setParent(undef);
+ $self->setLeft(undef);
+ return $left;
+}
+
+sub removeRight {
+ my ($self) = @_;
+ my $right = $self->getRight;
+ $right->setParent(undef);
+ $self->setRight(undef);
+ return $right;
+}
+
+sub isLeaf {
+ my ($self) = @_;
+ return (!$self->hasLeft && !$self->hasRight);
+}
+
+sub isRoot {
+ my ($self) = @_;
+ return !$self->hasParent;
+}
+
+sub traverse {
+ my ($self, $func) = @_;
+ $func->($self);
+ $self->getLeft->traverse($func) if $self->hasLeft;
+ $self->getRight->traverse($func) if $self->hasRight;
+}
+
+sub mirror {
+ my ($self) = @_;
+ # swap left for right
+ my $left = $self->getLeft;
+ $self->setLeft($self->getRight());
+ $self->setRight($left);
+ # and recurse
+ $self->getLeft->mirror() if $self->hasLeft();
+ $self->getRight->mirror() if $self->hasRight();
+ $self;
+}
+
+sub size {
+ my ($self) = @_;
+ my $size = 1;
+ $size += $self->getLeft->size() if $self->hasLeft();
+ $size += $self->getRight->size() if $self->hasRight();
+ return $size;
+}
+
+sub height {
+ my ($self) = @_;
+ my ($left_height, $right_height) = (0, 0);
+ $left_height = $self->getLeft->height() if $self->hasLeft();
+ $right_height = $self->getRight->height() if $self->hasRight();
+ return 1 + (($left_height > $right_height) ? $left_height : $right_height);
+}
+
+1;
Added: packages/libclass-mop-perl/branches/upstream/current/t/pod.t
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libclass-mop-perl/branches/upstream/current/t/pod.t?rev=2608&op=file
==============================================================================
--- packages/libclass-mop-perl/branches/upstream/current/t/pod.t (added)
+++ packages/libclass-mop-perl/branches/upstream/current/t/pod.t Thu Apr 20 11:21:04 2006
@@ -1,0 +1,11 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More;
+
+eval "use Test::Pod 1.14";
+plan skip_all => "Test::Pod 1.14 required for testing POD" if $@;
+
+all_pod_files_ok();
Added: packages/libclass-mop-perl/branches/upstream/current/t/pod_coverage.t
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libclass-mop-perl/branches/upstream/current/t/pod_coverage.t?rev=2608&op=file
==============================================================================
--- packages/libclass-mop-perl/branches/upstream/current/t/pod_coverage.t (added)
+++ packages/libclass-mop-perl/branches/upstream/current/t/pod_coverage.t Thu Apr 20 11:21:04 2006
@@ -1,0 +1,11 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More;
+
+eval "use Test::Pod::Coverage 1.04";
+plan skip_all => "Test::Pod::Coverage 1.04 required for testing POD coverage" if $@;
+
+all_pod_coverage_ok();
More information about the Pkg-perl-cvs-commits
mailing list