r1848 - in packages: . libclass-meta-perl
libclass-meta-perl/branches libclass-meta-perl/branches/upstream
libclass-meta-perl/branches/upstream/current
libclass-meta-perl/branches/upstream/current/lib
libclass-meta-perl/branches/upstream/current/lib/Class
libclass-meta-perl/branches/upstream/current/lib/Class/Meta
libclass-meta-perl/branches/upstream/current/lib/Class/Meta/AccessorBuilder
libclass-meta-perl/branches/upstream/current/lib/Class/Meta/Types
libclass-meta-perl/branches/upstream/current/t
Krzysztof Krzyzaniak
eloy at costa.debian.org
Wed Jan 4 09:25:23 UTC 2006
Author: eloy
Date: 2006-01-04 09:24:55 +0000 (Wed, 04 Jan 2006)
New Revision: 1848
Added:
packages/libclass-meta-perl/
packages/libclass-meta-perl/branches/
packages/libclass-meta-perl/branches/upstream/
packages/libclass-meta-perl/branches/upstream/current/
packages/libclass-meta-perl/branches/upstream/current/Build.PL
packages/libclass-meta-perl/branches/upstream/current/Changes
packages/libclass-meta-perl/branches/upstream/current/MANIFEST
packages/libclass-meta-perl/branches/upstream/current/META.yml
packages/libclass-meta-perl/branches/upstream/current/Makefile.PL
packages/libclass-meta-perl/branches/upstream/current/README
packages/libclass-meta-perl/branches/upstream/current/lib/
packages/libclass-meta-perl/branches/upstream/current/lib/Class/
packages/libclass-meta-perl/branches/upstream/current/lib/Class/Meta.pm
packages/libclass-meta-perl/branches/upstream/current/lib/Class/Meta/
packages/libclass-meta-perl/branches/upstream/current/lib/Class/Meta/AccessorBuilder.pm
packages/libclass-meta-perl/branches/upstream/current/lib/Class/Meta/AccessorBuilder/
packages/libclass-meta-perl/branches/upstream/current/lib/Class/Meta/AccessorBuilder/Affordance.pm
packages/libclass-meta-perl/branches/upstream/current/lib/Class/Meta/AccessorBuilder/SemiAffordance.pm
packages/libclass-meta-perl/branches/upstream/current/lib/Class/Meta/Attribute.pm
packages/libclass-meta-perl/branches/upstream/current/lib/Class/Meta/Class.pm
packages/libclass-meta-perl/branches/upstream/current/lib/Class/Meta/Constructor.pm
packages/libclass-meta-perl/branches/upstream/current/lib/Class/Meta/Method.pm
packages/libclass-meta-perl/branches/upstream/current/lib/Class/Meta/Type.pm
packages/libclass-meta-perl/branches/upstream/current/lib/Class/Meta/Types/
packages/libclass-meta-perl/branches/upstream/current/lib/Class/Meta/Types/Boolean.pm
packages/libclass-meta-perl/branches/upstream/current/lib/Class/Meta/Types/Numeric.pm
packages/libclass-meta-perl/branches/upstream/current/lib/Class/Meta/Types/Perl.pm
packages/libclass-meta-perl/branches/upstream/current/lib/Class/Meta/Types/String.pm
packages/libclass-meta-perl/branches/upstream/current/t/
packages/libclass-meta-perl/branches/upstream/current/t/attr.t
packages/libclass-meta-perl/branches/upstream/current/t/base.t
packages/libclass-meta-perl/branches/upstream/current/t/chk_types.t
packages/libclass-meta-perl/branches/upstream/current/t/chk_types_affordance.t
packages/libclass-meta-perl/branches/upstream/current/t/chk_types_semi_affordance.t
packages/libclass-meta-perl/branches/upstream/current/t/class.t
packages/libclass-meta-perl/branches/upstream/current/t/constraints.t
packages/libclass-meta-perl/branches/upstream/current/t/constraints_affordance.t
packages/libclass-meta-perl/branches/upstream/current/t/constraints_semi_affordance.t
packages/libclass-meta-perl/branches/upstream/current/t/ctor.t
packages/libclass-meta-perl/branches/upstream/current/t/custom_type_maker.t
packages/libclass-meta-perl/branches/upstream/current/t/errors.t
packages/libclass-meta-perl/branches/upstream/current/t/implicit_class_types.t
packages/libclass-meta-perl/branches/upstream/current/t/inherit.t
packages/libclass-meta-perl/branches/upstream/current/t/meth.t
packages/libclass-meta-perl/branches/upstream/current/t/pod-coverage.t
packages/libclass-meta-perl/branches/upstream/current/t/pod.t
packages/libclass-meta-perl/branches/upstream/current/t/types.t
packages/libclass-meta-perl/branches/upstream/current/t/types_affordance.t
packages/libclass-meta-perl/branches/upstream/current/t/types_semi_affordance.t
packages/libclass-meta-perl/branches/upstream/current/t/view.t
packages/libclass-meta-perl/branches/upstream/current/t/view_affordance.t
packages/libclass-meta-perl/branches/upstream/current/t/view_semi_affordance.t
packages/libclass-meta-perl/tags/
Log:
[svn-inject] Installing original source of libclass-meta-perl
Added: packages/libclass-meta-perl/branches/upstream/current/Build.PL
===================================================================
--- packages/libclass-meta-perl/branches/upstream/current/Build.PL 2006-01-04 09:19:20 UTC (rev 1847)
+++ packages/libclass-meta-perl/branches/upstream/current/Build.PL 2006-01-04 09:24:55 UTC (rev 1848)
@@ -0,0 +1,13 @@
+use Module::Build;
+
+my $build = Module::Build->new(
+ module_name => 'Class::Meta',
+ license => 'perl',
+ requires => { Data::Types => '0.05',
+ Class::ISA => '0.31',
+ },
+ build_requires => { Test::Simple => '0.17',
+ },
+ create_makefile_pl => 'passthrough',
+);
+$build->create_build_script;
Added: packages/libclass-meta-perl/branches/upstream/current/Changes
===================================================================
--- packages/libclass-meta-perl/branches/upstream/current/Changes 2006-01-04 09:19:20 UTC (rev 1847)
+++ packages/libclass-meta-perl/branches/upstream/current/Changes 2006-01-04 09:24:55 UTC (rev 1848)
@@ -0,0 +1,244 @@
+Revision history for Perl extension Class::Meta.
+
+0.52 2005-12-30T00:08:36
+ - The constructor method created by Class::Meta::Constructor no longer
+ assigns the default value to an attribute if that attribute has
+ already been set by another attribute accessor. This is useful, for
+ example, when the setting of one attribute triggers the setting of
+ another attribute, as when a public attribute implicitly sets a
+ private attribute.
+
+0.51 2005-12-17T03:40:26
+ - Added "code" parameter to add_method(), so that a new method can be
+ defined right in the call to add_method(), and Class::Meta::Method
+ will install it. Inspired by Ovid's Class::Meta::Declare.
+
+0.50 2005-12-14T04:33:46
+ - Constructors created by Class::Meta now iterate over the attributes
+ when assigning arguments or defaults in the order in which the
+ were defined, rather than randomly.
+ - The "attributes()", "constructors()", and "methods()" methods of
+ Class::Meta::Class now return *all* objects, including private and
+ trusted objects, when called from the class that defined those
+ objects.
+ - Minor optimizations to the constructor created by Class::Meta.
+
+0.49 2005-11-02T03:27:10
+ - Added "keys" method to allow all Class Object keys to be fetched.
+ - Added "args" and "returns" parameters to "add_method()" to allow
+ methods to be better described.
+ - Added "clear" method to delete Class Object keys.
+
+0.48 2005-04-13T21:32:39
+ - Fixed accessor generation for "once" attributes with a default so that
+ a value can be passed to a constructor and properly assigned to the
+ "once" attribute instead of its default, rather than throwing a
+ read-only exception.
+ - Added "default_builder()" class method to Class::Meta::Type. This
+ allows a default builder other than "default" to be specified when
+ none is explicitly passed to Class::Meta::Type->add(), such as when
+ data types are implicitly created for attributes that reference
+ objects of Class::Meta classes.
+
+0.47 2005-04-05T16:25:28
+ - Changed the "constructors()", "attributes()", and "methods()" methods
+ in Class::Meta::Class so that any classes thta inherit from
+ Class::Meta::Class are never considered to be the caller.
+ - Added the "trusted" parameter to "new()" to identify trusted packages.
+ Added a new constant, TRUSTED, for the "view" parameter to identfy
+ constructors, attributes, and methods that can be used by trusted
+ packages.
+
+0.46 2005-03-09T18:24:59
+ - Fixed documentation to reflect that the "class()" method in the
+ Constructor class requires the package name as its first argument.
+ - Modified "add_method()" so that methods can optionally be
+ automatically created by "build()". Patch from Tim Canfield.
+ - A call to "build()" now deletes unneeded references to objects,
+ freeing up a bit of memory.
+ - Changed minimum required Perl version to 5.6.1. Certain tests are
+ disabled in this version, since the version of Carp included in
+ Perl 5.6 lacks the @CARP_NOT feature. Everything should work fine,
+ however. Suggested by Tim Canfield.
+
+0.45 2005-01-07T19:41:41
+ - Added "parents()" method to Class::Meta::Class to return the class
+ objects for any classes that the class inherits from.
+ - Attributes that use an alias to set their types will now have the
+ alias converted to the canonical type key.
+ - Fixed typo in Class::Meta that named the generated method "class()"
+ instead of "my_class()". Reported by Curtis Poe.
+ - Documented "bool" synonym for the "boolean" data type in the
+ Class::Meta library documentation (it was already documented in
+ Class::Meta::Types::Boolean, of course).
+ - Fixed broken links to Class::Meta::Types classes in Class::Meta
+ library documentation. Reported by Curtis Poe.
+
+0.44 2004-10-28T01:25:12
+ - Classes created by Class::Meta will now be used as data types. This
+ saves the developer having to generate classes *and* add the new
+ classes as data types when objects of a class will be attributes of
+ another class.
+ - Added "class_validation_generator()" class method to Class::Meta::Type
+ so that a custom object validation generator can be specified instead
+ of the default. This simplifies specifying objects as data types
+ without custom creating validation checks for every one, and is
+ especially useful with the new implicit Class::Meta class data types,
+ as it will be used to generate the validation checks.
+
+0.43 2004-09-20T06:19:27
+ - Accessor builder classes that don't properly load will now correctly
+ cause Class::Meta to die.
+ - Class::Meta::Class->handle_error() now joins multiple arguments it
+ receives into a single string to be passed to the error handler
+ code reference.
+ - Class::Meta::Attribute now correctly finds attribute accessors that
+ were not created by Class::Meta (that is, when the "create" parameter
+ is set to NONE), provided that the build_attr_set() and
+ build_attr_get() functions of the accessor builder package can
+ find them (as the accessor builders include with Class::Meta can).
+
+0.42 2004-09-19T23:57:53
+ - Fixed test failures on Windows in "t/errors.t".
+ - Added "abstract" attribute to class objects to identify abstract
+ (a.k.a. "virtual") classes. Constructors generated by Class::Meta
+ will throw an exception if they are used to try to construct an
+ object in an abstract class.
+
+0.41 2004-08-27T02:32:17
+ - Added "for_key()" class method to Class::Meta to return a
+ Class::Meta::Class class for a class key.
+ - Eliminated '"my" variable $objs masks earlier declaration in same
+ scope' warning.
+
+0.40 2004-08-27T01:51:12
+ - Remembered to actually apply the patch taht fixes the tests under
+ Windows. Sheesh!
+ - Subclasses of Class, Constructor, Attribute, and Method can now call
+ "SUPER::new()" and "SUPER::build()" without getting errors.
+ - Changed implementation of Class::Meta::Class so that its attributes
+ are stored in the object hash itself. This brings it in line with
+ the implementation of Constructor, Attribute, and Method, thus
+ making subclassing consistent with those classes. However it also
+ required that references to its contents be changed in all the other
+ classes, as well. Hence the bump to 0.40.
+
+0.36 2004-07-30T00:59:31
+ - Finally, truly got the tests fixed for Windows. Without question.
+ The fix was even tested, first! Thanks to Robert Rothenberg for
+ his persistence.
+ - Minor doc fixes, repoted by Jesse Vincent.
+ - Added simple example for a default value code reference. Suggested
+ by Jesse Vincent.
+
+0.35 2004-06-28T23:16:16
+ - Fixed the names of the included types classes in the documentation
+ of Class::Meta::Type. Spotted by Dan Kubb.
+ - Fixed a few documentation references to a "class()" method to
+ reference the correctly named "my_class()" method.
+ - Fixed failing tests on Win32. For real this time, I hope! Reported
+ by Robert Rothenberg's CPAN testing.
+ - Added build() method to Class::Meta::Method to parallel the same
+ method in Class::Meta::Attribute and Class::Meta::Constructor.
+ It's a no-op, but will be called when Class::Meta::build() is
+ called, so it could be useful for subclasses. Inspired by a
+ suggestion by Mark Jaroski.
+ - Added POD coverage test.
+ - Documented undocumented methods and functions. Most of these are
+ actually protected methods, but they will be of interest to those
+ creating their own subclasses or accessor generators Class::Meta.
+
+0.34 2004-06-17T17:52:30
+ - Fixed failing tests on Win32. Reported by Robert Rothenberg's CPAN
+ testing.
+
+0.33 2004-06-17T00:05:47
+ - Added "override" parameter to "add_attribute()" so that subclasses
+ can override attributes in their parent classes.
+
+0.32 2004-05-25T17:09:39
+ - Fixed the MANIFEST so that the new semi-affordance accessor generation
+ actually works. Reported by Mark Jaroski.
+
+0.31 2004-04-20T18:25:25
+ - Moved extra code to prevent AccessorBuilder from pointing to
+ Constructor in the default (croak) error handler from AccessorBuilder
+ to the default error handler. Carp is a PITA.
+ - Added "handle_error()" class method to Class::Meta. This method is
+ used by Class::Meta classes when no Class::Meta::Class object is
+ available
+
+0.30 2004-04-19T23:44:26
+ - Added semi-affordance accessor generation.
+ - Modified arguments passed to check code references. Now, in addition
+ to the new value to be assiged to the attribute, the object being
+ assigned to and the Class::Meta::Attribute object that describes the
+ attribute are passed. If the attribute is a class attribute, then the
+ second argument is a hash reference containing the existing value and
+ the name of the package.
+ - Thanks the the presence of the attribute object as an argument to
+ check code references, the name of the attribute is now included in
+ exceptions thrown for "once" and "required" attributes.
+ - Added "class" accessors to Constructor, Attribute, and Method, to
+ return the Class object for the class in which the constructor,
+ attribute, or method was defined.
+ - Added "error_handler" parameter to Class::Meta->new to be called for
+ fatal errors.
+ - Added default_error_handler() class method to Class::Meta to act
+ as the default error handler when no "error_handler" parameter is
+ passed to Class::Meta->new.
+
+0.20 2004-01-28T22:03:09
+ - Added more documentation to the Class::Meta synopsis that highlights
+ the generated constructor and attribute accessors, as well as the
+ introspection API.
+ - Fixed documentation to reflect that the introspection class method
+ installed in a generated class is called my_class(), not class().
+ Thanks to Marcus Ramberg for the spot!
+ - Documented the "required" attribute of Class::Meta::Attribute.
+ - Added "once" attribute to Class::Meta::Attribute. This attribute
+ indicates whether an attribute value can be set to a defined value
+ only once.
+ - Renamed the call_get() and call_set() methods of
+ Class::Meta::Attribute to simply get() and set().
+
+0.14 2004-01-21T01:00:18
+ - Private and protected constructors generated by Class::Meta are now
+ truly private and protected.
+ - Class::Meta no longer generates constructors when they're added with
+ create => 0.
+
+0.13 2004-01-20T21:36:30
+ - For default accessors, object and class attribute accessors were
+ reversed.
+ - Private and protected attributes now are truly private and protected
+ if they're constructed by the accessor builder packages that come with
+ Class::Meta.
+ - The call_get() and call_set() methods of Class::Meta::Attribute and
+ the call() methods of Class::Meta::Constructor and
+ Class::Meta::::Method now use goto to execute the true methods. This
+ removes the call to call_get() or call_set() or call() from the call
+ stack trace, and makes it possible for the private and protected
+ checks to always work properly.
+
+0.12 2004-01-17T20:25:58
+ - The class "name" attribute now defaults to be the same as the key
+ if it is not explicitly set.
+ - The constructor generated by Class::Meta no longer attempts to set
+ class attributes.
+ - A package name now must be passed to the Class::Meta::Constructor's
+ call() method as the first argument. This is allow for proper support
+ for inheritance.
+ - Accessor generators now create accessors for class attributes as
+ class attributes, instead of as object attributes.
+
+0.11 2004-01-15T03:47:33
+ - Added link to rt.cpan.org for reporting bugs.
+ - Added distribution information to all modules.
+ - The package attribute now properly defaults to the package
+ calling Class::Meta->new.
+ - Class::Meta::Class->construtors now works.
+
+0.10 2004-01-09T03:56:11
+ - Initial public release.
+
Added: packages/libclass-meta-perl/branches/upstream/current/MANIFEST
===================================================================
--- packages/libclass-meta-perl/branches/upstream/current/MANIFEST 2006-01-04 09:19:20 UTC (rev 1847)
+++ packages/libclass-meta-perl/branches/upstream/current/MANIFEST 2006-01-04 09:24:55 UTC (rev 1848)
@@ -0,0 +1,42 @@
+Build.PL
+Changes
+lib/Class/Meta.pm
+lib/Class/Meta/AccessorBuilder.pm
+lib/Class/Meta/AccessorBuilder/Affordance.pm
+lib/Class/Meta/AccessorBuilder/SemiAffordance.pm
+lib/Class/Meta/Attribute.pm
+lib/Class/Meta/Class.pm
+lib/Class/Meta/Constructor.pm
+lib/Class/Meta/Method.pm
+lib/Class/Meta/Type.pm
+lib/Class/Meta/Types/Boolean.pm
+lib/Class/Meta/Types/Numeric.pm
+lib/Class/Meta/Types/Perl.pm
+lib/Class/Meta/Types/String.pm
+Makefile.PL
+MANIFEST This list of files
+META.yml
+README
+t/attr.t
+t/base.t
+t/chk_types.t
+t/chk_types_affordance.t
+t/chk_types_semi_affordance.t
+t/class.t
+t/constraints.t
+t/constraints_affordance.t
+t/constraints_semi_affordance.t
+t/ctor.t
+t/custom_type_maker.t
+t/errors.t
+t/implicit_class_types.t
+t/inherit.t
+t/meth.t
+t/pod-coverage.t
+t/pod.t
+t/types.t
+t/types_affordance.t
+t/types_semi_affordance.t
+t/view.t
+t/view_affordance.t
+t/view_semi_affordance.t
Added: packages/libclass-meta-perl/branches/upstream/current/META.yml
===================================================================
--- packages/libclass-meta-perl/branches/upstream/current/META.yml 2006-01-04 09:19:20 UTC (rev 1847)
+++ packages/libclass-meta-perl/branches/upstream/current/META.yml 2006-01-04 09:24:55 UTC (rev 1848)
@@ -0,0 +1,58 @@
+---
+name: Class-Meta
+version: 0.52
+author:
+ - David Wheeler <david at kineticode.com>
+abstract: 'Class automation, introspection, and data validation'
+license: perl
+resources:
+ license: http://dev.perl.org/licenses/
+requires:
+ Class::ISA: 0.31
+ Data::Types: 0.05
+build_requires:
+ Test::Simple: 0.17
+provides:
+ Class::Meta:
+ file: lib/Class/Meta.pm
+ version: 0.52
+ Class::Meta::AccessorBuilder:
+ file: lib/Class/Meta/AccessorBuilder.pm
+ version: 0.52
+ Class::Meta::AccessorBuilder::Affordance:
+ file: lib/Class/Meta/AccessorBuilder/Affordance.pm
+ version: 0.52
+ Class::Meta::AccessorBuilder::SemiAffordance:
+ file: lib/Class/Meta/AccessorBuilder/SemiAffordance.pm
+ version: 0.52
+ Class::Meta::Attribute:
+ file: lib/Class/Meta/Attribute.pm
+ version: 0.52
+ Class::Meta::Class:
+ file: lib/Class/Meta/Class.pm
+ version: 0.52
+ Class::Meta::Constructor:
+ file: lib/Class/Meta/Constructor.pm
+ version: 0.52
+ Class::Meta::Method:
+ file: lib/Class/Meta/Method.pm
+ version: 0.52
+ Class::Meta::Type:
+ file: lib/Class/Meta/Type.pm
+ version: 0.52
+ Class::Meta::Types::Boolean:
+ file: lib/Class/Meta/Types/Boolean.pm
+ version: 0.52
+ Class::Meta::Types::Numeric:
+ file: lib/Class/Meta/Types/Numeric.pm
+ version: 0.52
+ Class::Meta::Types::Perl:
+ file: lib/Class/Meta/Types/Perl.pm
+ version: 0.52
+ Class::Meta::Types::String:
+ file: lib/Class/Meta/Types/String.pm
+ version: 0.52
+generated_by: Module::Build version 0.2704
+meta-spec:
+ url: http://module-build.sourceforge.net/META-spec-v1.2.html
+ version: 1.2
Added: packages/libclass-meta-perl/branches/upstream/current/Makefile.PL
===================================================================
--- packages/libclass-meta-perl/branches/upstream/current/Makefile.PL 2006-01-04 09:19:20 UTC (rev 1847)
+++ packages/libclass-meta-perl/branches/upstream/current/Makefile.PL 2006-01-04 09:24:55 UTC (rev 1848)
@@ -0,0 +1,30 @@
+# Note: this file was auto-generated by Module::Build::Compat version 0.03
+
+ unless (eval "use Module::Build::Compat 0.02; 1" ) {
+ print "This module requires Module::Build to install itself.\n";
+
+ require ExtUtils::MakeMaker;
+ my $yn = ExtUtils::MakeMaker::prompt
+ (' Install Module::Build now from CPAN?', 'y');
+
+ unless ($yn =~ /^y/i) {
+ die " *** Cannot install without Module::Build. Exiting ...\n";
+ }
+
+ require Cwd;
+ require File::Spec;
+ require CPAN;
+
+ # Save this 'cause CPAN will chdir all over the place.
+ my $cwd = Cwd::cwd();
+
+ CPAN::Shell->install('Module::Build::Compat')
+ or die " *** Cannot install without Module::Build. Exiting ...\n";
+
+ chdir $cwd or die "Cannot chdir() back to $cwd: $!";
+ }
+ eval "use Module::Build::Compat 0.02; 1" or die $@;
+
+ Module::Build::Compat->run_build_pl(args => \@ARGV);
+ require Module::Build;
+ Module::Build::Compat->write_makefile(build_class => 'Module::Build');
Added: packages/libclass-meta-perl/branches/upstream/current/README
===================================================================
--- packages/libclass-meta-perl/branches/upstream/current/README 2006-01-04 09:19:20 UTC (rev 1847)
+++ packages/libclass-meta-perl/branches/upstream/current/README 2006-01-04 09:24:55 UTC (rev 1848)
@@ -0,0 +1,61 @@
+Class/Meta version 0.52
+=======================
+
+Class::Meta provides an interface for automating the creation of Perl classes
+with attribute data type validation. It differs from other such modules in
+that it includes an introspection API that can be used as a unified interface
+for all Class::Meta-generated classes. In this sense, it is an implementation
+of the "Facade" design pattern.
+
+JUSTIFICATION
+
+One might argue that there are already too many class automation and parameter
+validation modules on CPAN. And one would be right. They range from simple
+accessor generators, such as Class::Accessor, to simple parameter validators,
+such as Params::Validate, to more comprehensive systems, such as
+Class::Contract and Class::Tangram. But, naturally, none of them could do
+exactly what I needed.
+
+What I needed was an implementation of the "Facade" design pattern. Okay, this
+isn't a facade like the GOF meant it, but it is in the respect that it
+creates classes with a common API so that objects of these classes can all be
+used identically, calling the same methods on each. This is done via the
+implementation of an introspection API. So the process of creating classes
+with Class::Meta not only creates attributes and accessors, but also creates
+objects that describe those classes. Using these descriptive objects, client
+applications can determine what to do with objects of Class::Meta-generated
+classes. This is particularly useful for user interface code.
+
+INSTALLATION
+
+To install this module, type the following:
+
+ perl Build.PL
+ ./Build
+ ./Build test
+ ./Build install
+
+Or, if you don't have Module::Build installed, type the following:
+
+ perl Makefile.PL
+ make
+ make test
+ make install
+
+DEPENDENCIES
+
+This module requires these other modules and libraries:
+
+ Data::Types 0.05 or later
+ Class::ISA 0.35 or later
+
+The test suite requires:
+
+ Test::Simple 0.17 or later
+
+COPYRIGHT AND LICENCE
+
+Copyright (c) 2002-2005, David Wheeler. All Rights Reserved.
+
+This module is free software; you can redistribute it and/or modify it under
+the same terms as Perl itself.
Added: packages/libclass-meta-perl/branches/upstream/current/lib/Class/Meta/AccessorBuilder/Affordance.pm
===================================================================
--- packages/libclass-meta-perl/branches/upstream/current/lib/Class/Meta/AccessorBuilder/Affordance.pm 2006-01-04 09:19:20 UTC (rev 1847)
+++ packages/libclass-meta-perl/branches/upstream/current/lib/Class/Meta/AccessorBuilder/Affordance.pm 2006-01-04 09:24:55 UTC (rev 1848)
@@ -0,0 +1,386 @@
+package Class::Meta::AccessorBuilder::Affordance;
+
+# $Id: Affordance.pm 2405 2005-12-17 03:41:09Z theory $
+
+=head1 NAME
+
+Class::Meta::AccessorBuilder::Affordance - Affordance style accessor generation
+
+=head1 SYNOPSIS
+
+ package MyApp::TypeDef;
+
+ use strict;
+ use Class::Meta::Type;
+ use IO::Socket;
+
+ my $type = Class::Meta::Type->add( key => 'io_socket',
+ builder => 'affordance',
+ desc => 'IO::Socket object',
+ name => 'IO::Socket Object' );
+
+=head1 DESCRIPTION
+
+This module provides the an affordance style accessor builder for Class::Meta.
+Affordance accessors are attribute accessor methods that separate the getting
+and setting of an attribute value into distinct methods. The approach both
+eliminates the overhead of checking to see whether an accessor is called as a
+getter or a setter, which is common for Perl style accessors, while also
+creating a psychological barrier to accidentally misusing an attribute.
+
+=head2 Accessors
+
+Class::Meta::AccessorBuilder::Affordance create two different types of
+accessors: getters and setters. The type of accessors created depends on the
+value of the C<authz> attribute of the Class::Meta::Attribute for which the
+accessor is being created.
+
+For example, if the C<authz> is Class::Meta::RDWR, then two accessor methods
+will be created:
+
+ my $value = $obj->get_io_socket;
+ $obj->set_io_socket($value);
+
+If the value of C<authz> is Class::Meta::READ, then only the get method
+will be created:
+
+ my $value = $obj->io_socket;
+
+And finally, if the value of C<authz> is Class::Meta::WRITE, then only the set
+method will be created (why anyone would want this is beyond me, but I provide
+for the sake of completeness):
+
+ my $value = $obj->io_socket;
+
+=head2 Data Type Validation
+
+Class::Meta::AccessorBuilder::Affordance uses all of the validation checks
+passed to it to validate new values before assigning them to an attribute. It
+also checks to see if the attribute is required, and if so, adds a check to
+ensure that its value is never undefined. It does not currently check to
+ensure that private and protected methods are used only in their appropriate
+contexts, but may do so in a future release.
+
+=head2 Class Attributes
+
+If the C<context> attribute of the attribute object for which accessors are to
+be built is C<Class::Meta::CLASS>, Class::Meta::AccessorBuilder will build
+accessors for a class attribute instead of an object attribute. Of course,
+this means that if you change the value of the class attribute in any
+context--whether via a an object, the class name, or an an inherited class
+name or object, the value will be changed everywhere.
+
+For example, for a class attribute "count", you can expect the following to
+work:
+
+ MyApp::Custom->set_count(10);
+ my $count = MyApp::Custom->get_count; # Returns 10.
+ my $obj = MyApp::Custom->new;
+ $count = $obj->get_count; # Returns 10.
+
+ $obj->set_count(22);
+ $count = $obj->get_count; # Returns 22.
+ my $count = MyApp::Custom->get_count; # Returns 22.
+
+ MyApp::Custom->set_count(35);
+ $count = $obj->get_count; # Returns 35.
+ my $count = MyApp::Custom->get_count; # Returns 35.
+
+Currently, class attribute accessors are not designed to be inheritable in the
+way designed by Class::Data::Inheritable, although this might be changed in a
+future release. For now, I expect that the current simple approach will cover
+the vast majority of circumstances.
+
+B<Note:> Class attribute accessors will not work accurately in multiprocess
+environments such as mod_perl. If you change a class attribute's value in one
+process, it will not be changed in any of the others. Furthermore, class
+attributes are not currently shared across threads. So if you're using
+Class::Meta class attributes in a multi-threaded environment (such as iThreads
+in Perl 5.8.0 and later) the changes to a class attribute in one thread will
+not be reflected in other threads.
+
+=head1 Private and Protected Attributes
+
+Any attributes that have their C<view> attribute set to Class::Meta::Private
+or Class::Meta::Protected get additional validation installed to ensure that
+they're truly private and protected. This includes when they are set via
+parameters to constructors generated by Class::Meta. The validation is
+performed by checking the caller of the accessors, and throwing an exception
+when the caller isn't the class that owns the attribute (for private
+attributes) or when it doesn't inherit from the class that owns the attribute
+(for protected attributes).
+
+As an implementation note, this validation is performed for parameters passed
+to constructors created by Class::Meta by ignoring looking for the first
+caller that isn't Class::Meta::Constructor:
+
+ my $caller = caller;
+ # Circumvent generated constructors.
+ for (my $i = 1; $caller eq 'Class::Meta::Constructor'; $i++) {
+ $caller = caller($i);
+ }
+
+This works because Class::Meta::Constructor installs the closures that become
+constructors, and thus, when those closures call accessors to set new values
+for attributes, the caller is Class::Meta::Constructor. By going up the stack
+until we find another package, we correctly check to see what context is
+setting attribute values via a constructor, rather than the constructor method
+itself being the context.
+
+This is a bit of a hack, but since Perl uses call stacks for checking security
+in this way, it's the best I could come up with. Other suggestions welcome. Or
+see L<Class::Meta::Type|Class::Meta::Type/"Custom Accessor Building"> to
+create your own accessor generation code
+
+=head1 INTERFACE
+
+The following functions must be implemented by any Class::Meta accessor
+generation module.
+
+=head2 Functions
+
+=head3 build_attr_get
+
+ my $code = Class::Meta::AccessorBuilder::Affordance::build_attr_get();
+
+This function is called by C<Class::Meta::Type::make_attr_get()> and returns a
+code reference that can be used by the C<get()> method of
+Class::Meta::Attribute to return the value stored for that attribute for the
+object passed to the code reference.
+
+=head3 build_attr_set
+
+ my $code = Class::Meta::AccessorBuilder::Affordance::build_attr_set();
+
+This function is called by C<Class::Meta::Type::make_attr_set()> and returns a
+code reference that can be used by the C<set()> method of
+Class::Meta::Attribute to set the value stored for that attribute for the
+object passed to the code reference.
+
+=head3 build
+
+ Class::Meta::AccessorBuilder::Affordance::build(
+ $pkg, $attribute, $create, @checks
+ );
+
+This method is called by the C<build()> method of Class::Meta::Type, and does
+the work of actually generating the accessors for an attribute object. The
+arguments passed to it are:
+
+=over 4
+
+=item $pkg
+
+The name of the class to which the accessors will be added.
+
+=item $attribute
+
+The Class::Meta::Attribute object that specifies the attribute for which the
+accessors will be created.
+
+=item $create
+
+The value of the C<create> attribute of the Class::Meta::Attribute object,
+which determines what accessors, if any, are to be created.
+
+=item @checks
+
+A list of code references that validate the value of an attribute. These will
+be used in the set acccessor (mutator) to validate new attribute values.
+
+=back
+
+=cut
+
+use strict;
+use Class::Meta;
+our $VERSION = "0.52";
+
+sub build_attr_get {
+ UNIVERSAL::can($_[0]->package, 'get_' . $_[0]->name);
+}
+
+sub build_attr_set {
+ UNIVERSAL::can($_[0]->package, 'set_' . $_[0]->name);
+}
+
+my $req_chk = sub {
+ $_[2]->class->handle_error("Attribute ", $_[2]->name, " must be defined")
+ unless defined $_[0];
+};
+
+my $once_chk = sub {
+ $_[2]->class->handle_error("Attribute ", $_[2]->name,
+ " can only be set once")
+ if defined $_[1]->{$_[2]->name};
+};
+
+sub build {
+ my ($pkg, $attr, $name, $get, $set) = __PACKAGE__->_build(@_);
+ # Install the accessors.
+ no strict 'refs';
+ *{"${pkg}::get_$name"} = $get if $get;
+ *{"${pkg}::set_$name"} = $set if $set;
+}
+
+sub _build {
+ shift;
+ my ($pkg, $attr, $create, @checks) = @_;
+ my $name = $attr->name;
+
+ # Add the required check, if needed.
+ unshift @checks, $req_chk if $attr->required;
+
+ # Add a once check, if needed.
+ unshift @checks, $once_chk if $attr->once;
+
+ my ($get, $set);
+ if ($attr->context == Class::Meta::CLASS) {
+ # Create class attribute accessors by creating a closure tha
+ # references this variable.
+ my $data = $attr->default;
+
+ if ($create >= Class::Meta::GET) {
+ # Create GET accessor.
+ $get = sub { $data };
+ }
+
+ if ($create >= Class::Meta::SET) {
+ # Create SET accessor.
+ if (@checks) {
+ $set = sub {
+ # Check the value passed in.
+ $_->($_[1], { $name => $data,
+ __pkg => ref $_[0] || $_[0] },
+ $attr) for @checks;
+ # Assign the value.
+ $data = $_[1];
+ };
+ } else {
+ $set = sub {
+ # Assign the value.
+ $data = $_[1];
+ };
+ }
+ }
+ } else {
+ # Create object attribute accessors.
+ if ($create >= Class::Meta::GET) {
+ # Create GET accessor.
+ $get = sub { $_[0]->{$name} };
+ }
+
+ if ($create >= Class::Meta::SET) {
+ # Create SET accessor.
+ if (@checks) {
+ $set = sub {
+ # Check the value passed in.
+ $_->($_[1], $_[0], $attr) for @checks;
+ # Assign the value.
+ $_[0]->{$name} = $_[1];
+ };
+ } else {
+ $set = sub {
+ # Assign the value.
+ $_[0]->{$name} = $_[1];
+ };
+ }
+ }
+ }
+
+ # Add public and private checks, if required.
+ if ($attr->view == Class::Meta::PROTECTED) {
+ for ($get, $set) {
+ my $real_sub = $_ or next;
+ $_ = sub {
+ my $caller = caller;
+ # Circumvent generated constructors.
+ for (my $i = 1; $caller eq 'Class::Meta::Constructor'; $i++) {
+ $caller = caller($i);
+ }
+ $attr->class->handle_error("$name is a protected attribute "
+ . "of $pkg")
+ unless UNIVERSAL::isa($caller, $pkg);
+ goto &$real_sub;
+ };
+ }
+ } elsif ($attr->view == Class::Meta::PRIVATE) {
+ for ($get, $set) {
+ my $real_sub = $_ or next;
+ $_ = sub {
+ my $caller = caller;
+ # Circumvent generated constructors.
+ for (my $i = 1; $caller eq 'Class::Meta::Constructor'; $i++) {
+ $caller = caller($i);
+ }
+ $attr->class->handle_error("$name is a private attribute of $pkg")
+ unless $caller eq $pkg;
+ goto &$real_sub;
+ };
+ }
+ } elsif ($attr->view == Class::Meta::TRUSTED) {
+ # XXX Should we have an accessor for this?
+ my $trusted = $attr->class->{trusted};
+ for ($get, $set) {
+ my $real_sub = $_ or next;
+ $_ = sub {
+ my $caller = caller;
+ # Circumvent generated constructors.
+ for (my $i = 1; $caller eq 'Class::Meta::Constructor'; $i++) {
+ $caller = caller($i);
+ }
+ goto &$real_sub if $caller eq $pkg;
+ for my $pack (@{$trusted}) {
+ goto &$real_sub if UNIVERSAL::isa($caller, $pack);
+ }
+ $attr->class->handle_error("$name is a trusted attribute of $pkg");
+ };
+ }
+ }
+ return ($pkg, $attr, $name, $get, $set);
+}
+
+1;
+__END__
+
+=head1 BUGS
+
+Please send bug reports to <bug-class-meta at rt.cpan.org> or report them via the
+CPAN Request Tracker at L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Class-Meta>.
+
+=head1 AUTHOR
+
+David Wheeler <david at kineticode.com>
+
+=head1 SEE ALSO
+
+=over 4
+
+=item L<Class::Meta|Class::Meta>
+
+This class contains most of the documentation you need to get started with
+Class::Meta.
+
+=item L<Class::Meta::AccessorBuilder|Class::Meta::AccessorBuilder>
+
+This module generates Perl style accessors.
+
+=item L<Class::Meta::Type|Class::Meta::Type>
+
+This class manages the creation of data types.
+
+=item L<Class::Meta::Attribute|Class::Meta::Attribute>
+
+This class manages Class::Meta class attributes, most of which will have
+generated accessors.
+
+=back
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (c) 2002-2005, David Wheeler. All Rights Reserved.
+
+This module is free software; you can redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=cut
Added: packages/libclass-meta-perl/branches/upstream/current/lib/Class/Meta/AccessorBuilder/SemiAffordance.pm
===================================================================
--- packages/libclass-meta-perl/branches/upstream/current/lib/Class/Meta/AccessorBuilder/SemiAffordance.pm 2006-01-04 09:19:20 UTC (rev 1847)
+++ packages/libclass-meta-perl/branches/upstream/current/lib/Class/Meta/AccessorBuilder/SemiAffordance.pm 2006-01-04 09:24:55 UTC (rev 1848)
@@ -0,0 +1,261 @@
+package Class::Meta::AccessorBuilder::SemiAffordance;
+
+# $Id: SemiAffordance.pm 2405 2005-12-17 03:41:09Z theory $
+
+=head1 NAME
+
+Class::Meta::AccessorBuilder::SemiAffordance - Semi-Affordance style accessor generation
+
+=head1 SYNOPSIS
+
+ package MyApp::TypeDef;
+
+ use strict;
+ use Class::Meta::Type;
+ use IO::Socket;
+
+ my $type = Class::Meta::Type->add( key => 'io_socket',
+ builder => 'semi-affordance',
+ desc => 'IO::Socket object',
+ name => 'IO::Socket Object' );
+
+=head1 DESCRIPTION
+
+This module provides a semi-affordance style accessor builder for Class::Meta.
+Affordance accessors are attribute accessor methods that separate the getting
+and setting of an attribute value into distinct methods. The approach both
+eliminates the overhead of checking to see whether an accessor is called as a
+getter or a setter, which is common for Perl style accessors, while also
+creating a psychological barrier to accidentally misusing an attribute.
+
+
+=head2 Accessors
+
+Class::Meta::AccessorBuilder::SemiAffordance create two different types of
+accessors: getters and setters. What makes the accessors generated by this
+class "semi-affordance" rather than "affordance" accessors is that the getter
+is simply named for the attribute, while the setter is prepended by C<set_>.
+This approach differs from that of affordance accessors, where the getter is
+prepended by C<get_>.
+
+The type of accessors created depends on the value of the C<authz> attribute
+of the Class::Meta::Attribute for which the accessor is being created.
+
+For example, if the C<authz> is Class::Meta::RDWR, then two accessor methods
+will be created:
+
+ my $value = $obj->io_socket;
+ $obj->set_io_socket($value);
+
+If the value of C<authz> is Class::Meta::READ, then only the get method
+will be created:
+
+ my $value = $obj->io_socket;
+
+And finally, if the value of C<authz> is Class::Meta::WRITE, then only the set
+method will be created (why anyone would want this is beyond me, but I provide
+for the sake of completeness):
+
+ my $value = $obj->io_socket;
+
+=head2 Data Type Validation
+
+Class::Meta::AccessorBuilder::SemiAffordance uses all of the validation checks
+passed to it to validate new values before assigning them to an attribute. It
+also checks to see if the attribute is required, and if so, adds a check to
+ensure that its value is never undefined. It does not currently check to
+ensure that private and protected methods are used only in their appropriate
+contexts, but may do so in a future release.
+
+=head2 Class Attributes
+
+If the C<context> attribute of the attribute object for which accessors are to
+be built is C<Class::Meta::CLASS>, Class::Meta::AccessorBuilder will build
+accessors for a class attribute instead of an object attribute. Of course,
+this means that if you change the value of the class attribute in any
+context--whether via a an object, the class name, or an an inherited class
+name or object, the value will be changed everywhere.
+
+For example, for a class attribute "count", you can expect the following to
+work:
+
+ MyApp::Custom->set_count(10);
+ my $count = MyApp::Custom->count; # Returns 10.
+ my $obj = MyApp::Custom->new;
+ $count = $obj->count; # Returns 10.
+
+ $obj->set_count(22);
+ $count = $obj->count; # Returns 22.
+ my $count = MyApp::Custom->count; # Returns 22.
+
+ MyApp::Custom->set_count(35);
+ $count = $obj->count; # Returns 35.
+ my $count = MyApp::Custom->count; # Returns 35.
+
+Currently, class attribute accessors are not designed to be inheritable in the
+way designed by Class::Data::Inheritable, although this might be changed in a
+future release. For now, I expect that the current simple approach will cover
+the vast majority of circumstances.
+
+B<Note:> Class attribute accessors will not work accurately in multiprocess
+environments such as mod_perl. If you change a class attribute's value in one
+process, it will not be changed in any of the others. Furthermore, class
+attributes are not currently shared across threads. So if you're using
+Class::Meta class attributes in a multi-threaded environment (such as iThreads
+in Perl 5.8.0 and later) the changes to a class attribute in one thread will
+not be reflected in other threads.
+
+=head1 Private and Protected Attributes
+
+Any attributes that have their C<view> attribute set to Class::Meta::Private
+or Class::Meta::Protected get additional validation installed to ensure that
+they're truly private and protected. This includes when they are set via
+parameters to constructors generated by Class::Meta. The validation is
+performed by checking the caller of the accessors, and throwing an exception
+when the caller isn't the class that owns the attribute (for private
+attributes) or when it doesn't inherit from the class that owns the attribute
+(for protected attributes).
+
+As an implementation note, this validation is performed for parameters passed
+to constructors created by Class::Meta by ignoring looking for the first
+caller that isn't Class::Meta::Constructor:
+
+ my $caller = caller;
+ # Circumvent generated constructors.
+ for (my $i = 1; $caller eq 'Class::Meta::Constructor'; $i++) {
+ $caller = caller($i);
+ }
+
+This works because Class::Meta::Constructor installs the closures that become
+constructors, and thus, when those closures call accessors to set new values
+for attributes, the caller is Class::Meta::Constructor. By going up the stack
+until we find another package, we correctly check to see what context is
+setting attribute values via a constructor, rather than the constructor method
+itself being the context.
+
+This is a bit of a hack, but since Perl uses call stacks for checking security
+in this way, it's the best I could come up with. Other suggestions welcome. Or
+see L<Class::Meta::Type|Class::Meta::Type/"Custom Accessor Building"> to
+create your own accessor generation code
+
+=head1 INTERFACE
+
+The following functions must be implemented by any Class::Meta accessor
+generation module.
+
+=head2 Functions
+
+=head3 build_attr_get
+
+ my $code = Class::Meta::AccessorBuilder::SemiAffordance::build_attr_get();
+
+This function is called by C<Class::Meta::Type::make_attr_get()> and returns a
+code reference that can be used by the C<get()> method of
+Class::Meta::Attribute to return the value stored for that attribute for the
+object passed to the code reference.
+
+=head3 build_attr_set
+
+ my $code = Class::Meta::AccessorBuilder::SemiAffordance::build_attr_set();
+
+This function is called by C<Class::Meta::Type::make_attr_set()> and returns a
+code reference that can be used by the C<set()> method of
+Class::Meta::Attribute to set the value stored for that attribute for the
+object passed to the code reference.
+
+=head3 build
+
+ Class::Meta::AccessorBuilder::SemiAffordance::build(
+ $pkg, $attribute, $create, @checks
+ );
+
+This method is called by the C<build()> method of Class::Meta::Type, and does
+the work of actually generating the accessors for an attribute object. The
+arguments passed to it are:
+
+=over 4
+
+=item $pkg
+
+The name of the class to which the accessors will be added.
+
+=item $attribute
+
+The Class::Meta::Attribute object that specifies the attribute for which the
+accessors will be created.
+
+=item $create
+
+The value of the C<create> attribute of the Class::Meta::Attribute object,
+which determines what accessors, if any, are to be created.
+
+=item @checks
+
+A list of code references that validate the value of an attribute. These will
+be used in the set acccessor (mutator) to validate new attribute values.
+
+=back
+
+=cut
+
+use strict;
+use Class::Meta;
+use base 'Class::Meta::AccessorBuilder::Affordance';
+our $VERSION = "0.52";
+
+sub build_attr_get {
+ UNIVERSAL::can($_[0]->package, $_[0]->name);
+}
+
+sub build {
+ my ($pkg, $attr, $name, $get, $set) = __PACKAGE__->_build(@_);
+ # Install the accessors.
+ no strict 'refs';
+ *{"${pkg}::$name"} = $get if $get;
+ *{"${pkg}::set_$name"} = $set if $set;
+}
+
+1;
+__END__
+
+=head1 BUGS
+
+Please send bug reports to <bug-class-meta at rt.cpan.org> or report them via the
+CPAN Request Tracker at L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Class-Meta>.
+
+=head1 AUTHOR
+
+David Wheeler <david at kineticode.com>
+
+=head1 SEE ALSO
+
+=over 4
+
+=item L<Class::Meta|Class::Meta>
+
+This class contains most of the documentation you need to get started with
+Class::Meta.
+
+=item L<Class::Meta::AccessorBuilder|Class::Meta::AccessorBuilder>
+
+This module generates Perl style accessors.
+
+=item L<Class::Meta::Type|Class::Meta::Type>
+
+This class manages the creation of data types.
+
+=item L<Class::Meta::Attribute|Class::Meta::Attribute>
+
+This class manages Class::Meta class attributes, most of which will have
+generated accessors.
+
+=back
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (c) 2002-2005, David Wheeler. All Rights Reserved.
+
+This module is free software; you can redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=cut
Added: packages/libclass-meta-perl/branches/upstream/current/lib/Class/Meta/AccessorBuilder.pm
===================================================================
--- packages/libclass-meta-perl/branches/upstream/current/lib/Class/Meta/AccessorBuilder.pm 2006-01-04 09:19:20 UTC (rev 1847)
+++ packages/libclass-meta-perl/branches/upstream/current/lib/Class/Meta/AccessorBuilder.pm 2006-01-04 09:24:55 UTC (rev 1848)
@@ -0,0 +1,426 @@
+package Class::Meta::AccessorBuilder;
+
+# $Id: AccessorBuilder.pm 2405 2005-12-17 03:41:09Z theory $
+
+=head1 NAME
+
+Class::Meta::AccessorBuilder - Perl style accessor generation
+
+=head1 SYNOPSIS
+
+ package MyApp::TypeDef;
+
+ use strict;
+ use Class::Meta::Type;
+ use IO::Socket;
+
+ my $type = Class::Meta::Type->add( key => 'io_socket',
+ builder => 'default',
+ desc => 'IO::Socket object',
+ name => 'IO::Socket Object' );
+
+=head1 DESCRIPTION
+
+This module provides the default accessor builder for Class::Meta. It builds
+standard Perl-style accessors. For example, an attribute named "io_socket"
+would have a single accessor method, C<io_socket>.
+
+=head2 Accessors
+
+Class::Meta::AccessorBuilder create three different types of accessors:
+read-only, write-only, and read/write. The type of accessor created depends on
+the value of the C<authz> attribute of the Class::Meta::Attribute for which
+the accessor is being created.
+
+For example, if the C<authz> is Class::Meta::RDWR, then the method will be
+able to both read and write the attribute.
+
+ my $value = $obj->io_socket;
+ $obj->io_socket($value);
+
+If the value of C<authz> is Class::Meta::READ, then the method will not
+be able to change the value of the attribute:
+
+ my $value = $obj->io_socket;
+ $obj->io_socket($value); # Has no effect.
+
+And finally, if the value of C<authz> is Class::Meta::WRITE, then the method
+will not return the value of the attribute (why anyone would want this is
+beyond me, but I provide for the sake of completeness):
+
+ $obj->io_socket($value);
+ my $value = $obj->io_socket; # Always returns undef.
+
+=head2 Data Type Validation
+
+Class::Meta::AccessorBuilder uses all of the validation checks passed to it to
+validate new values before assigning them to an attribute. It also checks to
+see if the attribute is required, and if so, adds a check to ensure that its
+value is never undefined. It does not currently check to ensure that private
+and protected methods are used only in their appropriate contexts, but may do
+so in a future release.
+
+=head2 Class Attributes
+
+If the C<context> attribute of the attribute object for which accessors are to
+be built is C<Class::Meta::CLASS>, Class::Meta::AccessorBuilder will build
+accessors for a class attribute instead of an object attribute. Of course,
+this means that if you change the value of the class attribute in any
+context--whether via a an object, the class name, or an an inherited class
+name or object, the value will be changed everywhere.
+
+For example, for a class attribute "count", you can expect the following to
+work:
+
+ MyApp::Custom->count(10);
+ my $count = MyApp::Custom->count; # Returns 10.
+ my $obj = MyApp::Custom->new;
+ $count = $obj->count; # Returns 10.
+
+ $obj->count(22);
+ $count = $obj->count; # Returns 22.
+ my $count = MyApp::Custom->count; # Returns 22.
+
+ MyApp::Custom->count(35);
+ $count = $obj->count; # Returns 35.
+ my $count = MyApp::Custom->count; # Returns 35.
+
+Currently, class attribute accessors are not designed to be inheritable in the
+way designed by Class::Data::Inheritable, although this might be changed in a
+future release. For now, I expect that the current simple approach will cover
+the vast majority of circumstances.
+
+B<Note:> Class attribute accessors will not work accurately in multiprocess
+environments such as mod_perl. If you change a class attribute's value in one
+process, it will not be changed in any of the others. Furthermore, class
+attributes are not currently shared across threads. So if you're using
+Class::Meta class attributes in a multi-threaded environment (such as iThreads
+in Perl 5.8.0 and later) the changes to a class attribute in one thread will
+not be reflected in other threads.
+
+=head1 Private and Protected Attributes
+
+Any attributes that have their C<view> attribute set to Class::Meta::Private
+or Class::Meta::Protected get additional validation installed to ensure that
+they're truly private or protected. This includes when they are set via
+parameters to constructors generated by Class::Meta. The validation is
+performed by checking the caller of the accessors, and throwing an exception
+when the caller isn't the class that owns the attribute (for private
+attributes) or when it doesn't inherit from the class that owns the attribute
+(for protected attributes).
+
+As an implementation note, this validation is performed for parameters passed
+to constructors created by Class::Meta by ignoring looking for the first
+caller that isn't Class::Meta::Constructor:
+
+ my $caller = caller;
+ # Circumvent generated constructors.
+ for (my $i = 1; $caller eq 'Class::Meta::Constructor'; $i++) {
+ $caller = caller($i);
+ }
+
+This works because Class::Meta::Constructor installs the closures that become
+constructors, and thus, when those closures call accessors to set new values
+for attributes, the caller is Class::Meta::Constructor. By going up the stack
+until we find another package, we correctly check to see what context is
+setting attribute values via a constructor, rather than the constructor method
+itself being the context.
+
+This is a bit of a hack, but since Perl uses call stacks for checking security
+in this way, it's the best I could come up with. Other suggestions welcome. Or
+see L<Class::Meta::Type|Class::Meta::Type/"Custom Accessor Building"> to
+create your own accessor generation code
+
+=head1 INTERFACE
+
+The following functions must be implemented by any Class::Meta accessor
+generation module.
+
+=head2 Functions
+
+=head3 build_attr_get
+
+ my $code = Class::Meta::AccessorBuilder::build_attr_get();
+
+This function is called by C<Class::Meta::Type::make_attr_get()> and returns a
+code reference that can be used by the C<get()> method of
+Class::Meta::Attribute to return the value stored for that attribute for the
+object passed to the code reference.
+
+=head3 build_attr_set
+
+ my $code = Class::Meta::AccessorBuilder::build_attr_set();
+
+This function is called by C<Class::Meta::Type::make_attr_set()> and returns a
+code reference that can be used by the C<set()> method of
+Class::Meta::Attribute to set the value stored for that attribute for the
+object passed to the code reference.
+
+=head3 build
+
+ Class::Meta::AccessorBuilder::build($pkg, $attribute, $create, @checks);
+
+This method is called by the C<build()> method of Class::Meta::Type, and does
+the work of actually generating the accessors for an attribute object. The
+arguments passed to it are:
+
+=over 4
+
+=item $pkg
+
+The name of the class to which the accessors will be added.
+
+=item $attribute
+
+The Class::Meta::Attribute object that specifies the attribute for which the
+accessors will be created.
+
+=item $create
+
+The value of the C<create> attribute of the Class::Meta::Attribute object,
+which determines what accessors, if any, are to be created.
+
+=item @checks
+
+A list of code references that validate the value of an attribute. These will
+be used in the set acccessor (mutator) to validate new attribute values.
+
+=back
+
+=cut
+
+use strict;
+use Class::Meta;
+our $VERSION = "0.52";
+
+sub build_attr_get {
+ UNIVERSAL::can($_[0]->package, $_[0]->name);
+}
+
+sub build_attr_set { &build_attr_get }
+
+my $req_chk = sub {
+ $_[2]->class->handle_error("Attribute ", $_[2]->name, " must be defined")
+ unless defined $_[0];
+};
+
+my $once_chk = sub {
+ $_[2]->class->handle_error("Attribute ", $_[2]->name,
+ " can only be set once")
+ if defined $_[1]->{$_[2]->name};
+};
+
+sub build {
+ my ($pkg, $attr, $create, @checks) = @_;
+ my $name = $attr->name;
+
+ # Add the required check, if needed.
+ unshift @checks, $req_chk if $attr->required;
+
+ # Add a once check, if needed.
+ unshift @checks, $once_chk if $attr->once;
+
+ my $sub;
+ if ($attr->context == Class::Meta::CLASS) {
+ # Create class attribute accessors by creating a closure that
+ # references this variable.
+ my $data = $attr->default;
+
+ if ($create == Class::Meta::GET) {
+ # Create GET accessor.
+ $sub = sub { $data };
+
+ } elsif ($create == Class::Meta::SET) {
+ # Create SET accessor.
+ if (@checks) {
+ $sub = sub {
+ # Check the value passed in.
+ $_->($_[1], { $name => $data,
+ __pkg => ref $_[0] || $_[0] },
+ $attr) for @checks;
+ # Assign the value.
+ $data = $_[1];
+ return;
+ };
+ } else {
+ $sub = sub {
+ # Assign the value.
+ $data = $_[1];
+ return;
+ };
+ }
+
+ } elsif ($create == Class::Meta::GETSET) {
+ # Create GETSET accessor(s).
+ if (@checks) {
+ $sub = sub {
+ my $self = shift;
+ return $data unless @_;
+ # Check the value passed in.
+ $_->($_[1], { $name => $data,
+ __pkg => ref $self || $self },
+ $attr) for @checks;
+ # Assign the value.
+ return $data = $_[0];
+ };
+ } else {
+ $sub = sub {
+ my $self = shift;
+ return $data unless @_;
+ # Assign the value.
+ return $data = shift;
+ };
+ }
+ } else {
+ # Well, nothing I guess.
+ }
+ } else {
+ # Create object attribute accessors.
+ if ($create == Class::Meta::GET) {
+ # Create GET accessor.
+ $sub = sub { $_[0]->{$name} };
+
+ } elsif ($create == Class::Meta::SET) {
+ # Create SET accessor.
+ if (@checks) {
+ $sub = sub {
+ # Check the value passed in.
+ $_->($_[1], $_[0], $attr) for @checks;
+ # Assign the value.
+ $_[0]->{$name} = $_[1];
+ return;
+ };
+ } else {
+ $sub = sub {
+ # Assign the value.
+ $_[0]->{$name} = $_[1];
+ return;
+ };
+ }
+
+ } elsif ($create == Class::Meta::GETSET) {
+ # Create GETSET accessor(s).
+ if (@checks) {
+ $sub = sub {
+ my $self = shift;
+ return $self->{$name} unless @_;
+ # Check the value passed in.
+ $_->($_[0], $self, $attr) for @checks;
+ # Assign the value.
+ return $self->{$name} = $_[0];
+ };
+ } else {
+ $sub = sub {
+ my $self = shift;
+ return $self->{$name} unless @_;
+ # Assign the value.
+ return $self->{$name} = shift;
+ };
+ }
+ } else {
+ # Well, nothing I guess.
+ }
+ }
+
+ # Add public and private checks, if required.
+ if ($attr->view == Class::Meta::PROTECTED) {
+ my $real_sub = $sub;
+ $sub = sub {
+ my $caller = caller;
+ # Circumvent generated constructors.
+ for (my $i = 1; $caller eq 'Class::Meta::Constructor'; $i++) {
+ $caller = caller($i);
+ }
+
+ $attr->class->handle_error("$name is a protected attribute "
+ . "of $pkg")
+ unless UNIVERSAL::isa($caller, $pkg);
+ goto &$real_sub;
+ };
+ } elsif ($attr->view == Class::Meta::PRIVATE) {
+ my $real_sub = $sub;
+ $sub = sub {
+ my $caller = caller;
+ # Circumvent generated constructors.
+ for (my $i = 1; $caller eq 'Class::Meta::Constructor'; $i++) {
+ $caller = caller($i);
+ }
+
+ $attr->class->handle_error("$name is a private attribute of $pkg")
+ unless $caller eq $pkg;
+ goto &$real_sub;
+ };
+ } elsif ($attr->view == Class::Meta::TRUSTED) {
+ my $real_sub = $sub;
+ # XXX Should we have an accessor for this?
+ my $trusted = $attr->class->{trusted};
+ $sub = sub {
+ my $caller = caller;
+ # Circumvent generated constructors.
+ for (my $i = 1; $caller eq 'Class::Meta::Constructor'; $i++) {
+ $caller = caller($i);
+ }
+
+ goto &$real_sub if $caller eq $pkg;
+ for my $pack (@{$trusted}) {
+ goto &$real_sub if UNIVERSAL::isa($caller, $pack);
+ }
+ $attr->class->handle_error("$name is a trusted attribute of $pkg");
+ };
+ }
+
+ # Install the accessor.
+ no strict 'refs';
+ *{"${pkg}::$name"} = $sub;
+}
+
+1;
+__END__
+
+=head1 BUGS
+
+Please send bug reports to <bug-class-meta at rt.cpan.org> or report them via the
+CPAN Request Tracker at L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Class-Meta>.
+
+=head1 AUTHOR
+
+David Wheeler <david at kineticode.com>
+
+=head1 SEE ALSO
+
+=over 4
+
+=item L<Class::Meta|Class::Meta>
+
+This class contains most of the documentation you need to get started with
+Class::Meta.
+
+=item L<Class::Meta::AccessorBuilder::Affordance|Class::Meta::AccessorBuilder::Affordance>
+
+This module generates affordance style accessors (e.g., C<get_foo()> and
+C<set_foo()>.
+
+=item L<Class::Meta::AccessorBuilder::SemiAffordance|Class::Meta::AccessorBuilder::SemiAffordance>
+
+This module generates semi-affordance style accessors (e.g., C<foo()> and
+C<set_foo()>.
+
+=item L<Class::Meta::Type|Class::Meta::Type>
+
+This class manages the creation of data types.
+
+=item L<Class::Meta::Attribute|Class::Meta::Attribute>
+
+This class manages Class::Meta class attributes, most of which will have
+generated accessors.
+
+=back
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (c) 2002-2005, David Wheeler. All Rights Reserved.
+
+This module is free software; you can redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=cut
Added: packages/libclass-meta-perl/branches/upstream/current/lib/Class/Meta/Attribute.pm
===================================================================
--- packages/libclass-meta-perl/branches/upstream/current/lib/Class/Meta/Attribute.pm 2006-01-04 09:19:20 UTC (rev 1847)
+++ packages/libclass-meta-perl/branches/upstream/current/lib/Class/Meta/Attribute.pm 2006-01-04 09:24:55 UTC (rev 1848)
@@ -0,0 +1,463 @@
+package Class::Meta::Attribute;
+
+# $Id: Attribute.pm 2405 2005-12-17 03:41:09Z theory $
+
+=head1 NAME
+
+Class::Meta::Attribute - Class::Meta class attribute introspection
+
+=head1 SYNOPSIS
+
+ # Assuming MyApp::Thingy was generated by Class::Meta.
+ my $class = MyApp::Thingy->my_class;
+ my $thingy = MyApp::Thingy->new;
+
+ print "\nAttributes:\n";
+ for my $attr ($class->attributes) {
+ print " o ", $attr->name, " => ", $attr->get($thingy), $/;
+ if ($attr->authz >= Class::Meta::SET && $attr->type eq 'string') {
+ $attr->get($thingy, 'hey there!');
+ print " Changed to: ", $attr->get($thingy) $/;
+ }
+ }
+
+=head1 DESCRIPTION
+
+An object of this class describes an attribute of a class created by
+Class::Meta. It includes metadata such as the name of the attribute, its data
+type, its accessibility, and whether or not a value is required. It also
+provides methods to easily get and set the value of the attribute for a given
+instance of the class.
+
+Class::Meta::Attribute objects are created by Class::Meta; they are never
+instantiated directly in client code. To access the attribute objects for a
+Class::Meta-generated class, simply call its C<my_class()> method to retrieve
+its Class::Meta::Class object, and then call the C<attributes()> method on the
+Class::Meta::Class object.
+
+=cut
+
+##############################################################################
+# Dependencies #
+##############################################################################
+use strict;
+
+##############################################################################
+# Package Globals #
+##############################################################################
+our $VERSION = "0.52";
+
+##############################################################################
+# Constructors #
+##############################################################################
+
+=head1 INTERFACE
+
+=head2 Constructors
+
+=head3 new
+
+A protected method for constructing a Class::Meta::Attribute object. Do not
+call this method directly; Call the
+L<C<add_attribute()>|Class::Meta/"add_attribute"> method on a Class::Meta
+object, instead.
+
+=cut
+
+sub new {
+ my $pkg = shift;
+ my $class = shift;
+
+ # Check to make sure that only Class::Meta or a subclass is constructing a
+ # Class::Meta::Attribute object.
+ my $caller = caller;
+ Class::Meta->handle_error("Package '$caller' cannot create $pkg "
+ . "objects")
+ unless UNIVERSAL::isa($caller, 'Class::Meta')
+ || UNIVERSAL::isa($caller, __PACKAGE__);
+
+ # Make sure we can get all the arguments.
+ $class->handle_error("Odd number of parameters in call to new() when "
+ . "named parameters were expected")
+ if @_ % 2;
+ my %p = @_;
+
+ # Validate the name.
+ $class->handle_error("Parameter 'name' is required in call to new()")
+ unless $p{name};
+ # Is this too paranoid?
+ $class->handle_error("Attribute '$p{name}' is not a valid attribute "
+ . "name -- only alphanumeric and '_' characters "
+ . "allowed")
+ if $p{name} =~ /\W/;
+
+ # Grab the package name.
+ $p{package} = $class->{package};
+
+ # Set the required and once attributes.
+ for (qw(required once)) {
+ $p{$_} = $p{$_} ? 1 : 0;
+ }
+
+ # Make sure the name hasn't already been used for another attribute
+ $class->handle_error("Attribute '$p{name}' already exists in class '"
+ . $class->{attrs}{$p{name}}{package} . "'")
+ if ! delete $p{override} && exists $class->{attrs}{$p{name}};
+
+ # Check the view.
+ if (exists $p{view}) {
+ $class->handle_error("Not a valid view parameter: "
+ . "'$p{view}'")
+ unless $p{view} == Class::Meta::PUBLIC
+ or $p{view} == Class::Meta::PROTECTED
+ or $p{view} == Class::Meta::TRUSTED
+ or $p{view} == Class::Meta::PRIVATE;
+ } else {
+ # Make it public by default.
+ $p{view} = Class::Meta::PUBLIC;
+ }
+
+ # Check the authorization level.
+ if (exists $p{authz}) {
+ $class->handle_error("Not a valid authz parameter: "
+ . "'$p{authz}'")
+ unless $p{authz} == Class::Meta::NONE
+ or $p{authz} == Class::Meta::READ
+ or $p{authz} == Class::Meta::WRITE
+ or $p{authz} == Class::Meta::RDWR;
+ } else {
+ # Make it read/write by default.
+ $p{authz} = Class::Meta::RDWR;
+ }
+
+ # Check the creation constant.
+ if (exists $p{create}) {
+ $class->handle_error("Not a valid create parameter: "
+ . "'$p{create}'")
+ unless $p{create} == Class::Meta::NONE
+ or $p{create} == Class::Meta::GET
+ or $p{create} == Class::Meta::SET
+ or $p{create} == Class::Meta::GETSET;
+ } else {
+ # Rely on the authz setting by default.
+ $p{create} = $p{authz};
+ }
+
+ # Check the context.
+ if (exists $p{context}) {
+ $class->handle_error("Not a valid context parameter: "
+ . "'$p{context}'")
+ unless $p{context} == Class::Meta::OBJECT
+ or $p{context} == Class::Meta::CLASS;
+ } else {
+ # Put it in object context by default.
+ $p{context} = Class::Meta::OBJECT;
+ }
+
+ # Check the default.
+ if (exists $p{default}) {
+ # A code ref should be executed when the default is called.
+ $p{_def_code} = delete $p{default}
+ if ref $p{default} eq 'CODE';
+ }
+
+ # Create and cache the attribute object.
+ $class->{attrs}{$p{name}} = bless \%p, ref $pkg || $pkg;
+
+ # Index its view.
+ push @{ $class->{all_attr_ord} }, $p{name};
+ if ($p{view} > Class::Meta::PRIVATE) {
+ push @{$class->{prot_attr_ord}}, $p{name}
+ unless $p{view} == Class::Meta::TRUSTED;
+ if ($p{view} > Class::Meta::PROTECTED) {
+ push @{$class->{trst_attr_ord}}, $p{name};
+ push @{$class->{attr_ord}}, $p{name}
+ if $p{view} == Class::Meta::PUBLIC;
+ }
+ }
+
+ # Store a reference to the class object.
+ $p{class} = $class;
+
+ # Let 'em have it.
+ return $class->{attrs}{$p{name}};
+}
+
+##############################################################################
+# Instance Methods #
+##############################################################################
+
+=head2 Instance Methods
+
+=head3 name
+
+ my $name = $attr->name;
+
+Returns the name of the attribute.
+
+=head3 type
+
+ my $type = $attr->type;
+
+Returns the name of the attribute's data type. Typical values are "scalar",
+"string", and "boolean". See L<Class::Meta|Class::Meta/"Data Types"> for a
+complete list.
+
+=head3 desc
+
+ my $desc = $attr->desc;
+
+Returns a description of the attribute.
+
+=head3 label
+
+ my $label = $attr->label;
+
+Returns a label for the attribute, suitable for use in a user interface. It is
+distinguished from the attribute name, which functions to name the accessor
+methods for the attribute.
+
+=head3 required
+
+ my $req = $attr->required;
+
+Indicates if the attribute is required to have a value.
+
+=head3 once
+
+ my $once = $attr->once;
+
+Indicates whether an attribute value can be set to a defined value only once.
+
+=head3 package
+
+ my $package = $attr->package;
+
+Returns the package name of the class that attribute is associated with.
+
+=head3 view
+
+ my $view = $attr->view;
+
+Returns the view of the attribute, reflecting its visibility. The possible
+values are defined by the following constants:
+
+=over 4
+
+=item Class::Meta::PUBLIC
+
+=item Class::Meta::PRIVATE
+
+=item Class::Meta::TRUSTED
+
+=item Class::Meta::PROTECTED
+
+=back
+
+=head3 context
+
+ my $context = $attr->context;
+
+Returns the context of the attribute, essentially whether it is a class or
+object attribute. The possible values are defined by the following constants:
+
+=over 4
+
+=item Class::Meta::CLASS
+
+=item Class::Meta::OBJECT
+
+=back
+
+=head3 authz
+
+ my $authz = $attr->authz;
+
+Returns the authorization for the attribute, which determines whether it can be
+read or changed. The possible values are defined by the following constants:
+
+=over 4
+
+=item Class::Meta::READ
+
+=item Class::Meta::WRITE
+
+=item Class::Meta::RDWR
+
+=item Class::Meta::NONE
+
+=back
+
+=head3 class
+
+ my $class = $attr->class;
+
+Returns the Class::Meta::Class object that this attribute is associated
+with. Note that this object will always represent the class in which the
+attribute is defined, and I<not> any of its subclasses.
+
+=cut
+
+sub name { $_[0]->{name} }
+sub type { $_[0]->{type} }
+sub desc { $_[0]->{desc} }
+sub label { $_[0]->{label} }
+sub required { $_[0]->{required} }
+sub once { $_[0]->{once} }
+sub package { $_[0]->{package} }
+sub view { $_[0]->{view} }
+sub context { $_[0]->{context} }
+sub authz { $_[0]->{authz} }
+sub class { $_[0]->{class} }
+
+##############################################################################
+
+=head3 default
+
+ my $default = $attr->default;
+
+Returns the default value for a new instance of this attribute. Since the
+default value can be determined dynamically, the value returned by
+C<default()> may change on subsequent calls. It all depends on what was
+passed for the C<default> parameter in the call to C<add_attribute()> on the
+Class::Meta object that generated the class.
+
+=cut
+
+sub default {
+ if (my $code = $_[0]->{_def_code}) {
+ return $code->();
+ }
+ return $_[0]->{default};
+}
+
+##############################################################################
+
+=head3 get
+
+ my $value = $attr->get($thingy);
+
+This method calls the "get" accessor method on the object passed as the sole
+argument and returns the value of the attribute for that object. Note that it
+uses a C<goto> to execute the accessor, so the call to C<set()> itself
+will not appear in a call stack trace.
+
+=cut
+
+sub get {
+ my $self = shift;
+ my $code = $self->{_get}
+ or $self->class->handle_error("Cannot get attribute '",
+ $self->name, "'");
+ goto &$code;
+}
+
+##############################################################################
+
+=head3 set
+
+ $attr->set($thingy, $new_value);
+
+This method calls the "set" accessor method on the object passed as the first
+argument and passes any remaining arguments to assign a new value to the
+attribute for that object. Note that it uses a C<goto> to execute the
+accessor, so the call to C<set()> itself will not appear in a call stack
+trace.
+
+=cut
+
+sub set {
+ my $self = shift;
+ my $code = $self->{_set}
+ or $self->class->handle_error("Cannot set attribute '",
+ $self->name, "'");
+ goto &$code;
+}
+
+##############################################################################
+
+=head3 build
+
+ $attr->build($class);
+
+This is a protected method, designed to be called only by the Class::Meta
+class or a subclass of Class::Meta. It takes a single argument, the
+Class::Meta::Class object for the class in which the attribute was defined,
+and generates attribute accessors by calling out to the C<make_attr_get()> and
+C<make_attr_set()> methods of Class::Meta::Type as appropriate for the
+Class::Meta::Attribute object.
+
+Although you should never call this method directly, subclasses of
+Class::Meta::Constructor may need to override its behavior.
+
+=cut
+
+sub build {
+ my ($self, $class) = @_;
+
+ # Check to make sure that only Class::Meta or a subclass is building
+ # attribute accessors.
+ my $caller = caller;
+ $self->class->handle_error("Package '$caller' cannot call " . ref($self)
+ . "->build")
+ unless UNIVERSAL::isa($caller, 'Class::Meta')
+ || UNIVERSAL::isa($caller, __PACKAGE__);
+
+ # Get the data type object, replace any alias, and assemble the
+ # validation checks.
+ my $type = Class::Meta::Type->new($self->{type});
+ $self->{type} = $type->key;
+ my $create = delete $self->{create};
+ $type->build($class->{package}, $self, $create)
+ if $create != Class::Meta::NONE;
+
+ # Create the attribute object get code reference.
+ if ($self->{authz} >= Class::Meta::READ) {
+ $self->{_get} = $type->make_attr_get($self);
+ }
+
+ # Create the attribute object set code reference.
+ if ($self->{authz} >= Class::Meta::WRITE) {
+ $self->{_set} = $type->make_attr_set($self);
+ }
+
+}
+
+1;
+__END__
+
+=head1 BUGS
+
+Please send bug reports to <bug-class-meta at rt.cpan.org> or report them via the
+CPAN Request Tracker at L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Class-Meta>.
+
+=head1 AUTHOR
+
+David Wheeler <david at kineticode.com>
+
+=head1 SEE ALSO
+
+Other classes of interest within the Class::Meta distribution include:
+
+=over 4
+
+=item L<Class::Meta|Class::Meta>
+
+=item L<Class::Meta::Class|Class::Meta::Class>
+
+=item L<Class::Meta::Method|Class::Meta::Method>
+
+=item L<Class::Meta::Constructor|Class::Meta::Constructor>
+
+=item L<Class::Meta::Type|Class::Meta::Type>
+
+=back
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (c) 2002-2005, David Wheeler. All Rights Reserved.
+
+This module is free software; you can redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=cut
Added: packages/libclass-meta-perl/branches/upstream/current/lib/Class/Meta/Class.pm
===================================================================
--- packages/libclass-meta-perl/branches/upstream/current/lib/Class/Meta/Class.pm 2006-01-04 09:19:20 UTC (rev 1847)
+++ packages/libclass-meta-perl/branches/upstream/current/lib/Class/Meta/Class.pm 2006-01-04 09:24:55 UTC (rev 1848)
@@ -0,0 +1,435 @@
+package Class::Meta::Class;
+
+# $Id: Class.pm 2405 2005-12-17 03:41:09Z theory $
+
+=head1 NAME
+
+Class::Meta::Class - Class::Meta class introspection
+
+=head1 SYNOPSIS
+
+ # Assuming MyApp::Thingy was generated by Class::Meta.
+ my $class = MyApp::Thingy->my_class;
+ my $thingy = MyApp::Thingy->new;
+
+ print "Examining object of class ", $class->package, $/;
+
+ print "\nConstructors:\n";
+ for my $ctor ($class->constructors) {
+ print " o ", $ctor->name, $/;
+ }
+
+ print "\nAttributes:\n";
+ for my $attr ($class->attributes) {
+ print " o ", $attr->name, " => ", $attr->get($thingy) $/;
+ }
+
+ print "\nMethods:\n";
+ for my $meth ($class->methods) {
+ print " o ", $meth->name, $/;
+ }
+
+=head1 DESCRIPTION
+
+Object of this class describe classes created by Class::Meta. They contain
+everything you need to know about a class to be able to put objects of that
+class to good use. In addition to retrieving metadata about the class itself,
+you can retrieve objects that describe the constructors, attributes, and
+methods of the class. See C<Class::Meta|Class::Meta> for a fuller description
+of the utility of the Class::Meta suite of modules.
+
+Class::Meta::Class objects are created by Class::Meta; they are never
+instantiated directly in client code. To access the class object for a
+Class::Meta-generated class, simply call its C<my_class()> method.
+
+At this point, those attributes tend to be database-specific. Once other types
+of data stores are added (XML, LDAP, etc.), other attributes may be added to
+allow their schemas to be built, as well.
+
+=cut
+
+##############################################################################
+# Dependencies #
+##############################################################################
+use strict;
+use Class::ISA ();
+use Class::Meta;
+use Class::Meta::Attribute;
+use Class::Meta::Method;
+
+##############################################################################
+# Package Globals #
+##############################################################################
+our $VERSION = "0.52";
+our @CARP_NOT = qw(Class::Meta);
+
+=head1 INTERFACE
+
+=head2 Constructors
+
+=head3 new
+
+A protected method for constructing a Class::Meta::Class object. Do not call
+this method directly; Call the L<C<new()>|Class::Meta/new"> constructor on a
+Class::Meta object, instead. A Class::Meta::Class object will be constructed
+by default, and can always be retreived via the C<my_class()> method of the
+class for which it was constructed.
+
+=cut
+
+##############################################################################
+
+sub new {
+ my ($pkg, $spec) = @_;
+ # Check to make sure that only Class::Meta or a subclass is
+ # constructing a Class::Meta::Class object.
+ my $caller = caller;
+ Class::Meta->handle_error("Package '$caller' cannot create $pkg objects")
+ unless UNIVERSAL::isa($caller, 'Class::Meta')
+ || UNIVERSAL::isa($caller, __PACKAGE__);
+
+ # Set the name to be the same as the key by default.
+ $spec->{name} = $spec->{key} unless defined $spec->{name};
+
+ # Set the abstract attribute.
+ $spec->{abstract} = $spec->{abstract} ? 1 : 0;
+
+ # Set the trusted attribute.
+ $spec->{trusted} = exists $spec->{trust}
+ ? ref $spec->{trust} ? delete $spec->{trust} : [ delete $spec->{trust} ]
+ : [];
+
+ # Okay, create the class object.
+ my $self = bless $spec, ref $pkg || $pkg;
+}
+
+##############################################################################
+# Instance Methods
+##############################################################################
+
+=head2 Instance Methods
+
+=head3 package
+
+ my $pkg = $class->package;
+
+Returns the name of the package that the Class::Meta::Class object describes.
+
+=head3 key
+
+ my $key = $class->key;
+
+Returns the key name that uniquely identifies the class across the
+application. The key name may simply be the same as the package name.
+
+=head3 name
+
+ my $name = $class->name;
+
+Returns the name of the the class. This should generally be a descriptive
+name, rather than a package name.
+
+=head3 desc
+
+ my $desc = $class->desc;
+
+Returns a description of the class.
+
+=head3 abstract
+
+ my $abstract = $class->abstract;
+
+Returns true if the class is an abstract class, and false if it is not.
+
+=cut
+
+sub package { $_[0]->{package} }
+sub key { $_[0]->{key} }
+sub name { $_[0]->{name} }
+sub desc { $_[0]->{desc} }
+sub abstract { $_[0]->{abstract} }
+
+##############################################################################
+
+=head3 is_a
+
+ if ($class->is_a('MyApp::Base')) {
+ print "All your base are belong to us\n";
+ }
+
+This method returns true if the object or package name passed as an argument
+is an instance of the class described by the Class::Meta::Class object or one
+of its subclasses. Functionally equivalent to
+C<< $class->package->isa($pkg) >>, but more efficient.
+
+=cut
+
+sub is_a { UNIVERSAL::isa($_[0]->{package}, $_[1]) }
+
+##############################################################################
+# Accessors to get at the constructor, attribute, and method objects.
+##############################################################################
+
+=head3 constructors
+
+ my @constructors = $class->constructors;
+ my $ctor = $class->constructors($ctor_name);
+ @constructors = $class->constructors(@ctor_names);
+
+Provides access to the Class::Meta::Constructor objects that describe the
+constructors for the class. When called with no arguments, it returns all of
+the constructor objects. When called with a single argument, it returns the
+constructor object for the constructor with the specified name. When called
+with a list of arguments, returns all of the constructor objects with the
+specified names.
+
+=cut
+
+##############################################################################
+
+=head3 attributes
+
+ my @attributes = $class->attributes;
+ my $attr = $class->attributes($attr_name);
+ @attributes = $class->attributes(@attr_names);
+
+Provides access to the Class::Meta::Attribute objects that describe the
+attributes for the class. When called with no arguments, it returns all of the
+attribute objects. When called with a single argument, it returns the
+attribute object for the attribute with the specified name. When called with a
+list of arguments, returns all of the attribute objects with the specified
+names.
+
+=cut
+
+##############################################################################
+
+=head3 methods
+
+ my @methods = $class->methods;
+ my $meth = $class->methods($meth_name);
+ @methods = $class->methods(@meth_names);
+
+Provides access to the Class::Meta::Method objects that describe the methods
+for the class. When called with no arguments, it returns all of the method
+objects. When called with a single argument, it returns the method object for
+the method with the specified name. When called with a list of arguments,
+returns all of the method objects with the specified names.
+
+=cut
+
+for ([qw(attributes attr)], [qw(methods meth)], [qw(constructors ctor)]) {
+ my ($meth, $key) = @$_;
+ no strict 'refs';
+ *{$meth} = sub {
+ my $self = shift;
+ my $objs = $self->{"${key}s"};
+ # Who's talking to us?
+ my $caller = caller;
+ for (my $i = 1; UNIVERSAL::isa($caller, __PACKAGE__); $i++) {
+ $caller = caller($i);
+ }
+ # XXX Do we want to make these additive instead of discreet, so that
+ # a class can get both protected and trusted attributes, for example?
+ my $list = do {
+ if (@_) {
+ # Explicit list requested.
+ \@_;
+ } elsif ($caller eq $self->{package}) {
+ # List of protected interface objects.
+ $self->{"priv_$key\_ord"} || [];
+ } elsif (UNIVERSAL::isa($caller, $self->{package})) {
+ # List of protected interface objects.
+ $self->{"prot_$key\_ord"} || [];
+ } elsif (_trusted($self, $caller)) {
+ # List of trusted interface objects.
+ $self->{"trst_$key\_ord"} || [];
+ } else {
+ # List of public interface objects.
+ $self->{"$key\_ord"} || [];
+ }
+ };
+ return @$list == 1 ? $objs->{$list->[0]} : @{$objs}{@$list};
+ };
+}
+
+##############################################################################
+
+=head3 parents
+
+ my @parents = $class->parents;
+
+Returns a list of Class::Meta::Class objects representing all of the
+Class::Meta-built parent classes of a class.
+
+=cut
+
+sub parents {
+ my $self = shift;
+ return map { $_->my_class } grep { UNIVERSAL::can($_, 'my_class') }
+ Class::ISA::super_path($self->package);
+}
+
+##############################################################################
+
+=head3 handle_error
+
+ $class->handle_error($error)
+
+Handles Class::Meta-related errors using either the error handler specified
+when the Class::Meta::Class object was created or the default error handler at
+the time the Class::Meta::Class object was created.
+
+=cut
+
+sub handle_error {
+ my $code = shift->{error_handler};
+ $code->(join '', @_)
+}
+
+##############################################################################
+
+=head3 build
+
+ $class->build($classes);
+
+This is a protected method, designed to be called only by the Class::Meta
+class or a subclass of Class::Meta. It copies the attribute, constructor, and
+method objects from all of the parent classes of the class object so that they
+will be readily available from the C<attributes()>, C<constructors()>, and
+C<methods()> methods. Its sole argument is a reference to the hash of all
+Class::Meta::Class objects (keyed off their package names) stored by
+Class::Meta.
+
+Although you should never call this method directly, subclasses of
+Class::Meta::Class may need to override its behavior.
+
+=cut
+
+sub build {
+ my ($self, $classes) = @_;
+
+ # Check to make sure that only Class::Meta or a subclass is building
+ # attribute accessors.
+ my $caller = caller;
+ $self->handle_error("Package '$caller' cannot call " . ref($self)
+ . "->build")
+ unless UNIVERSAL::isa($caller, 'Class::Meta')
+ || UNIVERSAL::isa($caller, __PACKAGE__);
+
+ # Copy attributes again to make sure that overridden attributes
+ # truly override.
+ $self->_inherit($classes, qw(ctor meth attr));
+}
+
+##############################################################################
+# Private Methods.
+##############################################################################
+
+sub _inherit {
+ my $self = shift;
+ my $classes = shift;
+
+ # Get a list of all of the parent classes.
+ my $package = $self->package;
+ my @classes = reverse Class::ISA::self_and_super_path($package);
+
+ # Hrm, how can I avoid iterating over the classes a second time?
+ my @trusted;
+ for my $super (@classes) {
+ push @trusted, @{$classes->{$super}{trusted}}
+ if $classes->{$super}{trusted};
+ }
+ $self->{trusted} = \@trusted if @trusted;
+
+ # For each metadata class, copy the parents' objects.
+ for my $key (@_) {
+ my (@lookup, @all, @ord, @prot, @trst, @priv, %sall, %sord, %sprot, %strst);
+ for my $super (@classes) {
+ my $class = $classes->{$super};
+ if (my $things = $class->{$key . 's'}) {
+ push @lookup, %{ $things };
+
+ if (my $ord = $class->{"$key\_ord"}) {
+ push @ord, grep { not $sord{$_}++ } @{ $ord} ;
+ }
+
+ if (my $prot = $class->{"prot_$key\_ord"}) {
+ push @prot, grep { not $sprot{$_}++ } @{ $prot };
+ }
+
+ if (my $trust = $class->{"trst_$key\_ord"}) {
+ push @trst, grep { not $strst{$_}++ } @{ $trust };
+ }
+
+ if (my $all = $class->{"all_$key\_ord"}) {
+ for my $name (@{ $all }) {
+ next if $sall{$name}++;
+ push @all, $name;
+ my $view = $things->{$name}->view;
+ push @priv, $name if $super eq $package
+ || $view == Class::Meta::PUBLIC
+ || $view == Class::Meta::PROTECTED
+ || _trusted($class, $package);
+ }
+ }
+ }
+ }
+
+ $self->{"${key}s"} = { @lookup } if @lookup;
+ $self->{"$key\_ord"} = \@ord if @ord;
+ $self->{"all_$key\_ord"} = \@all if @all;
+ $self->{"prot_$key\_ord"} = \@prot if @prot;
+ $self->{"trst_$key\_ord"} = \@trst if @trst;
+ $self->{"priv_$key\_ord"} = \@priv if @priv;
+ }
+
+
+ return $self;
+}
+
+sub _trusted {
+ my ($self, $caller) = @_;
+ my $trusted = $self->{trusted} or return;
+ for my $pkg (@{$trusted}) {
+ return 1 if UNIVERSAL::isa($caller, $pkg);
+ }
+ return;
+}
+
+1;
+__END__
+
+=head1 BUGS
+
+Please send bug reports to <bug-class-meta at rt.cpan.org> or report them via the
+CPAN Request Tracker at L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Class-Meta>.
+
+=head1 AUTHOR
+
+David Wheeler <david at kineticode.com>
+
+=head1 SEE ALSO
+
+Other classes of interest within the Class::Meta distribution include:
+
+=over 4
+
+=item L<Class::Meta|Class::Meta>
+
+=item L<Class::Meta::Constructor|Class::Meta::Constructor>
+
+=item L<Class::Meta::Attribute|Class::Meta::Attribute>
+
+=item L<Class::Meta::Method|Class::Meta::Method>
+
+=back
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (c) 2002-2005, David Wheeler. All Rights Reserved.
+
+This module is free software; you can redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=cut
Added: packages/libclass-meta-perl/branches/upstream/current/lib/Class/Meta/Constructor.pm
===================================================================
--- packages/libclass-meta-perl/branches/upstream/current/lib/Class/Meta/Constructor.pm 2006-01-04 09:19:20 UTC (rev 1847)
+++ packages/libclass-meta-perl/branches/upstream/current/lib/Class/Meta/Constructor.pm 2006-01-04 09:24:55 UTC (rev 1848)
@@ -0,0 +1,368 @@
+package Class::Meta::Constructor;
+
+# $Id: Constructor.pm 2449 2005-12-30 00:07:53Z theory $
+
+=head1 NAME
+
+Class::Meta::Constructor - Class::Meta class constructor introspection
+
+=head1 SYNOPSIS
+
+ # Assuming MyApp::Thingy was generated by Class::Meta.
+ my $class = MyApp::Thingy->my_class;
+
+ print "\nConstructors:\n";
+ for my $ctor ($class->constructors) {
+ print " o ", $ctor->name, $/;
+ my $thingy = $ctor->call($class->package);
+ }
+
+=head1 DESCRIPTION
+
+This class provides an interface to the C<Class::Meta> objects that describe
+class constructors. It supports a simple description of the constructor, a
+label, and the constructor visibility (private, protected, trusted,or public).
+
+Class::Meta::Constructor objects are created by Class::Meta; they are never
+instantiated directly in client code. To access the constructor objects for a
+Class::Meta-generated class, simply call its C<my_class()> method to retrieve
+its Class::Meta::Class object, and then call the C<constructors()> method on
+the Class::Meta::Class object.
+
+=cut
+
+##############################################################################
+# Dependencies #
+##############################################################################
+use strict;
+
+##############################################################################
+# Package Globals #
+##############################################################################
+our $VERSION = "0.52";
+
+##############################################################################
+# Constructors #
+##############################################################################
+
+=head1 INTERFACE
+
+=head2 Constructors
+
+=head3 new
+
+A protected method for constructing a Class::Meta::Constructor object. Do not
+call this method directly; Call the
+L<C<add_constructor()>|Class::Meta/"add_constructor"> method on a Class::Meta
+object, instead.
+
+=cut
+
+sub new {
+ my $pkg = shift;
+ my $class = shift;
+
+ # Check to make sure that only Class::Meta or a subclass is constructing a
+ # Class::Meta::Constructor object.
+ my $caller = caller;
+ Class::Meta->handle_error("Package '$caller' cannot create $pkg "
+ . "objects")
+ unless UNIVERSAL::isa($caller, 'Class::Meta')
+ || UNIVERSAL::isa($caller, __PACKAGE__);
+
+ # Make sure we can get all the arguments.
+ $class->handle_error("Odd number of parameters in call to new() when "
+ . "named parameters were expected")
+ if @_ % 2;
+ my %p = @_;
+
+ # Validate the name.
+ $class->handle_error("Parameter 'name' is required in call to new()")
+ unless $p{name};
+ $class->handle_error("Constructor '$p{name}' is not a valid constructor "
+ . "name -- only alphanumeric and '_' characters "
+ . "allowed")
+ if $p{name} =~ /\W/;
+
+ # Make sure the name hasn't already been used for another constructor or
+ # method.
+ $class->handle_error("Method '$p{name}' already exists in class "
+ . "'$class->{package}'")
+ if exists $class->{ctors}{$p{name}}
+ or exists $class->{meths}{$p{name}};
+
+ # Check the visibility.
+ if (exists $p{view}) {
+ $class->handle_error("Not a valid view parameter: '$p{view}'")
+ unless $p{view} == Class::Meta::PUBLIC
+ || $p{view} == Class::Meta::PROTECTED
+ || $p{view} == Class::Meta::TRUSTED
+ || $p{view} == Class::Meta::PRIVATE;
+ } else {
+ # Make it public by default.
+ $p{view} = Class::Meta::PUBLIC;
+ }
+
+ # Check the creation constant.
+ $p{create} = 1 unless defined $p{create};
+
+ # Validate or create the method caller if necessary.
+ if ($p{caller}) {
+ my $ref = ref $p{caller};
+ $class->handle_error("Parameter caller must be a code reference")
+ unless $ref && $ref eq 'CODE';
+ } else {
+ $p{caller} = UNIVERSAL::can($class->{package}, $p{name})
+ unless $p{create};
+ }
+
+ # Create and cache the constructor object.
+ $p{package} = $class->{package};
+ $class->{ctors}{$p{name}} = bless \%p, ref $pkg || $pkg;
+
+ # Index its view.
+ push @{ $class->{all_ctor_ord} }, $p{name};
+ if ($p{view} > Class::Meta::PRIVATE) {
+ push @{$class->{prot_ctor_ord}}, $p{name}
+ unless $p{view} == Class::Meta::TRUSTED;
+ if ($p{view} > Class::Meta::PROTECTED) {
+ push @{$class->{trst_ctor_ord}}, $p{name};
+ push @{$class->{ctor_ord}}, $p{name}
+ if $p{view} == Class::Meta::PUBLIC;
+ }
+ }
+
+ # Store a reference to the class object.
+ $p{class} = $class;
+
+ # Let 'em have it.
+ return $class->{ctors}{$p{name}};
+}
+
+
+##############################################################################
+# Instance Methods #
+##############################################################################
+
+=head2 Instance Methods
+
+=head3 name
+
+ my $name = $ctor->name;
+
+Returns the constructor name.
+
+=head3 package
+
+ my $package = $ctor->package;
+
+Returns the package name of the class that constructor is associated with.
+
+=head3 desc
+
+ my $desc = $ctor->desc;
+
+Returns the description of the constructor.
+
+=head3 label
+
+ my $desc = $ctor->label;
+
+Returns label for the constructor.
+
+=head3 view
+
+ my $view = $ctor->view;
+
+Returns the view of the constructor, reflecting its visibility. The possible
+values are defined by the following constants:
+
+=over 4
+
+=item Class::Meta::PUBLIC
+
+=item Class::Meta::PRIVATE
+
+=item Class::Meta::TRUSTED
+
+=item Class::Meta::PROTECTED
+
+=back
+
+=head3 class
+
+ my $class = $ctor->class;
+
+Returns the Class::Meta::Class object that this constructor is associated
+with. Note that this object will always represent the class in which the
+constructor is defined, and I<not> any of its subclasses.
+
+=cut
+
+sub name { $_[0]->{name} }
+sub package { $_[0]->{package} }
+sub desc { $_[0]->{desc} }
+sub label { $_[0]->{label} }
+sub view { $_[0]->{view} }
+sub class { $_[0]->{class} }
+
+=head3 call
+
+ my $obj = $ctor->call($package, @params);
+
+Executes the constructor. Pass in the name of the class for which it is being
+executed (since, thanks to subclassing, it may be different than the class
+with which the constructor is associated). All other parameters will be passed
+to the constructor. Note that it uses a C<goto> to execute the constructor, so
+the call to C<call()> itself will not appear in a call stack trace.
+
+=cut
+
+sub call {
+ my $self = shift;
+ my $code = $self->{caller}
+ or $self->class->handle_error("Cannot call constructor '",
+ $self->name, "'");
+ goto &$code;
+}
+
+##############################################################################
+
+=head3 build
+
+ $ctor->build($class);
+
+This is a protected method, designed to be called only by the Class::Meta
+class or a subclass of Class::Meta. It takes a single argument, the
+Class::Meta::Class object for the class in which the constructor was defined,
+and generates constructor methods for the Class::Meta::Constructor object.
+
+Although you should never call this method directly, subclasses of
+Class::Meta::Constructor may need to override its behavior.
+
+=cut
+
+sub build {
+ my ($self, $specs) = @_;
+
+ # Check to make sure that only Class::Meta or a subclass is building
+ # constructors.
+ my $caller = caller;
+ $self->class->handle_error("Package '$caller' cannot call " . ref($self)
+ . "->build")
+ unless UNIVERSAL::isa($caller, 'Class::Meta')
+ || UNIVERSAL::isa($caller, __PACKAGE__);
+
+ # Just bail if we're not creating the constructor.
+ return $self unless delete $self->{create};
+
+ # Build a construtor that takes a parameter list and assigns the
+ # the values to the appropriate attributes.
+ my $name = $self->name;
+
+ my $sub = sub {
+ my $package = ref $_[0] ? ref shift : shift;
+ my $class = $specs->{$package};
+
+ # Throw an exception for attempts to create items of an abstract
+ # class.
+ $class->handle_error(
+ "Cannot construct objects of astract class $package"
+ ) if $class->abstract;
+
+ # Just grab the parameters and let an error be thrown by Perl
+ # if there aren't the right number of them.
+ my %p = @_;
+ my $new = bless {}, $package;
+
+ # Assign all of the attribute values.
+ if (my $attrs = $class->{attrs}) {
+ foreach my $attr (@{ $attrs }{ @{ $class->{all_attr_ord} } }) {
+ # Skip class attributes.
+ next if $attr->context == Class::Meta::CLASS;
+ my $key = $attr->name;
+ if (exists $p{$key} && $attr->authz >= Class::Meta::SET) {
+ # Let them set the value.
+ $attr->set($new, delete $p{$key});
+ } else {
+ # Use the default value.
+ $new->{$key} = $attr->default unless exists $new->{$key};
+ }
+ }
+ }
+
+ # Check for params for which attributes are private or don't exist.
+ if (my @attributes = keys %p) {
+ # Attempts to assign to non-existent attributes fail.
+ my $c = $#attributes > 0 ? 'attributes' : 'attribute';
+ local $" = "', '";
+ $class->handle_error(
+ "No such $c '@attributes' in $self->{package} objects"
+ );
+ }
+ return $new;
+ };
+
+ # Add protected, private, or trusted checks, if required.
+ if ($self->view == Class::Meta::PROTECTED) {
+ my $real_sub = $sub;
+ my $pkg = $self->package;
+ my $class = $self->class;
+ $sub = sub {
+ $class->handle_error("$name is a protected constrctor of $pkg")
+ unless caller->isa($pkg);
+ goto &$real_sub;
+ };
+ } elsif ($self->view == Class::Meta::PRIVATE) {
+ my $real_sub = $sub;
+ my $pkg = $self->package;
+ my $class = $self->class;
+ $sub = sub {
+ $class->handle_error("$name is a private constructor of $pkg")
+ unless caller eq $pkg;
+ goto &$real_sub;
+ };
+ }
+
+ # Install the constructor.
+ $self->{caller} ||= $sub;
+ no strict 'refs';
+ *{"$self->{package}::$name"} = $sub;
+}
+
+1;
+__END__
+
+=head1 BUGS
+
+Please send bug reports to <bug-class-meta at rt.cpan.org> or report them via the
+CPAN Request Tracker at L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Class-Meta>.
+
+=head1 AUTHOR
+
+David Wheeler <david at kineticode.com>
+
+=head1 SEE ALSO
+
+Other classes of interest within the Class::Meta distribution include:
+
+=over 4
+
+=item L<Class::Meta|Class::Meta>
+
+=item L<Class::Meta::Class|Class::Meta::Class>
+
+=item L<Class::Meta::Method|Class::Meta::Method>
+
+=item L<Class::Meta::Attribute|Class::Meta::Attribute>
+
+=back
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (c) 2002-2005, David Wheeler. All Rights Reserved.
+
+This module is free software; you can redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=cut
Added: packages/libclass-meta-perl/branches/upstream/current/lib/Class/Meta/Method.pm
===================================================================
--- packages/libclass-meta-perl/branches/upstream/current/lib/Class/Meta/Method.pm 2006-01-04 09:19:20 UTC (rev 1847)
+++ packages/libclass-meta-perl/branches/upstream/current/lib/Class/Meta/Method.pm 2006-01-04 09:24:55 UTC (rev 1848)
@@ -0,0 +1,341 @@
+package Class::Meta::Method;
+
+# $Id: Method.pm 2405 2005-12-17 03:41:09Z theory $
+
+=head1 NAME
+
+Class::Meta::Method - Class::Meta class method introspection
+
+=head1 SYNOPSIS
+
+ # Assuming MyApp::Thingy was generated by Class::Meta.
+ my $class = MyApp::Thingy->my_class;
+ my $thingy = MyApp::Thingy->new;
+
+ print "\nMethods:\n";
+ for my $meth ($class->methods) {
+ print " o ", $meth->name, $/;
+ $meth->call($thingy);
+ }
+
+=head1 DESCRIPTION
+
+This class provides an interface to the C<Class::Meta> objects that describe
+methods. It supports a simple description of the method, a label, and its
+visibility (private, protected, trusted, or public).
+
+Class::Meta::Method objects are created by Class::Meta; they are never
+instantiated directly in client code. To access the method objects for a
+Class::Meta-generated class, simply call its C<my_class()> method to retrieve
+its Class::Meta::Class object, and then call the C<methods()> method on the
+Class::Meta::Class object.
+
+=cut
+
+##############################################################################
+# Dependencies #
+##############################################################################
+use strict;
+
+##############################################################################
+# Package Globals #
+##############################################################################
+our $VERSION = "0.52";
+
+=head1 INTERFACE
+
+=head2 Constructors
+
+=head3 new
+
+A protected method for constructing a Class::Meta::Method object. Do not call
+this method directly; Call the L<C<add_method()>|Class::Meta/"add_method">
+method on a Class::Meta object, instead.
+
+=cut
+
+sub new {
+ my $pkg = shift;
+ my $class = shift;
+
+ # Check to make sure that only Class::Meta or a subclass is constructing a
+ # Class::Meta::Method object.
+ my $caller = caller;
+ Class::Meta->handle_error("Package '$caller' cannot create $pkg "
+ . "objects")
+ unless UNIVERSAL::isa($caller, 'Class::Meta')
+ || UNIVERSAL::isa($caller, __PACKAGE__);
+
+ # Make sure we can get all the arguments.
+ $class->handle_error("Odd number of parameters in call to new() "
+ . "when named parameters were expected")
+ if @_ % 2;
+
+ my %p = @_;
+
+ # Validate the name.
+ $class->handle_error("Parameter 'name' is required in call to "
+ . "new()") unless $p{name};
+ $class->handle_error("Method '$p{name}' is not a valid method "
+ . "name -- only alphanumeric and '_' characters allowed")
+ if $p{name} =~ /\W/;
+
+ # Make sure the name hasn't already been used for another method
+ # or constructor.
+ $class->handle_error("Method '$p{name}' already exists in class "
+ . "'$class->{package}'")
+ if exists $class->{meths}{$p{name}}
+ || exists $class->{ctors}{$p{name}};
+
+ # Check the visibility.
+ if (exists $p{view}) {
+ $class->handle_error("Not a valid view parameter: '$p{view}'")
+ unless $p{view} == Class::Meta::PUBLIC
+ || $p{view} == Class::Meta::PROTECTED
+ || $p{view} == Class::Meta::TRUSTED
+ || $p{view} == Class::Meta::PRIVATE;
+ } else {
+ # Make it public by default.
+ $p{view} = Class::Meta::PUBLIC;
+ }
+
+ # Check the context.
+ if (exists $p{context}) {
+ $class->handle_error("Not a valid context parameter: "
+ . "'$p{context}'")
+ unless $p{context} == Class::Meta::OBJECT
+ || $p{context} == Class::Meta::CLASS;
+ } else {
+ # Make it public by default.
+ $p{context} = Class::Meta::OBJECT;
+ }
+
+ # Validate or create the method caller if necessary.
+ if ($p{caller}) {
+ my $ref = ref $p{caller};
+ $class->handle_error(
+ 'Parameter caller must be a code reference'
+ ) unless $ref && $ref eq 'CODE'
+ } else {
+ $p{caller} = eval "sub { shift->$p{name}(\@_) }"
+ if $p{view} > Class::Meta::PRIVATE;
+ }
+
+ if ($p{code}) {
+ my $ref = ref $p{code};
+ $class->handle_error(
+ 'Parameter code must be a code reference'
+ ) unless $ref && $ref eq 'CODE'
+ }
+
+ # Create and cache the method object.
+ $p{package} = $class->{package};
+ $class->{meths}{$p{name}} = bless \%p, ref $pkg || $pkg;
+
+ # Index its view.
+ push @{ $class->{all_meth_ord} }, $p{name};
+ if ($p{view} > Class::Meta::PRIVATE) {
+ push @{$class->{prot_meth_ord}}, $p{name}
+ unless $p{view} == Class::Meta::TRUSTED;
+ if ($p{view} > Class::Meta::PROTECTED) {
+ push @{$class->{trst_meth_ord}}, $p{name};
+ push @{$class->{meth_ord}}, $p{name}
+ if $p{view} == Class::Meta::PUBLIC;
+ }
+ }
+
+ # Store a reference to the class object.
+ $p{class} = $class;
+
+ # Let 'em have it.
+ return $class->{meths}{$p{name}};
+}
+
+##############################################################################
+# Instance Methods #
+##############################################################################
+
+=head2 Instance Methods
+
+=head3 name
+
+ my $name = $meth->name;
+
+Returns the method name.
+
+=head3 package
+
+ my $package = $meth->package;
+
+Returns the method package.
+
+=head3 desc
+
+ my $desc = $meth->desc;
+
+Returns the description of the method.
+
+=head3 label
+
+ my $desc = $meth->label;
+
+Returns label for the method.
+
+=head3 view
+
+ my $view = $meth->view;
+
+Returns the view of the method, reflecting its visibility. The possible
+values are defined by the following constants:
+
+=over 4
+
+=item Class::Meta::PUBLIC
+
+=item Class::Meta::PRIVATE
+
+=item Class::Meta::TRUSTED
+
+=item Class::Meta::PROTECTED
+
+=back
+
+=head3 context
+
+ my $context = $meth->context;
+
+Returns the context of the method, essentially whether it is a class or
+object method. The possible values are defined by the following constants:
+
+=over 4
+
+=item Class::Meta::CLASS
+
+=item Class::Meta::OBJECT
+
+=back
+
+=head3 args
+
+A description of the arguments to the method. This can be anything you like,
+but I recommend something like a string for a single argument, an array
+reference for a list of arguments, or a hash reference for parameter
+arguments.
+
+=head3 returns
+
+A description of the return value or values of the method.
+
+=head3 class
+
+ my $class = $meth->class;
+
+Returns the Class::Meta::Class object that this method is associated
+with. Note that this object will always represent the class in which the
+method is defined, and I<not> any of its subclasses.
+
+=cut
+
+sub name { $_[0]->{name} }
+sub package { $_[0]->{package} }
+sub desc { $_[0]->{desc} }
+sub label { $_[0]->{label} }
+sub view { $_[0]->{view} }
+sub context { $_[0]->{context} }
+sub args { $_[0]->{args} }
+sub returns { $_[0]->{returns} }
+sub class { $_[0]->{class} }
+
+=head3 call
+
+ my $ret = $meth->call($obj, @args);
+
+Calls the method on the C<$obj> object, passing in any arguments. Note that it
+uses a C<goto> to execute the method, so the call to C<call()> itself will not
+appear in a call stack trace.
+
+=cut
+
+sub call {
+ my $self = shift;
+ my $code = $self->{caller}
+ or $self->class->handle_error("Cannot call method '", $self->name, "'");
+ goto &$code;
+}
+
+##############################################################################
+
+=head3 build
+
+ $meth->build($class);
+
+This is a protected method, designed to be called only by the Class::Meta
+class or a subclass of Class::Meta. It takes a single argument, the
+Class::Meta::Class object for the class in which the method was defined. Once
+it checks to make sure that it is only called by Class::Meta or a subclass of
+Class::Meta or of Class::Meta::Method, C<Cbuild()> installs the method if it
+was specified via the C<code> parameter to C<new()>.
+
+Although you should never call this method directly, subclasses of
+Class::Meta::Method may need to override it in order to add behavior.
+
+=cut
+
+sub build {
+ my ($self, $class) = @_;
+
+ # Check to make sure that only Class::Meta or a subclass is building
+ # methods.
+ my $caller = caller;
+ $self->class->handle_error(
+ "Package '$caller' cannot call " . ref($self) . "->build"
+ ) unless UNIVERSAL::isa($caller, 'Class::Meta')
+ || UNIVERSAL::isa($caller, __PACKAGE__);
+
+ # Install the method if we've got it.
+ if (my $code = delete $self->{code}) {
+ my $pack = $self->package;
+ my $name = $self->{name};
+ no strict 'refs';
+ *{"$pack\::$name"} = $code;
+ }
+
+ return $self;
+}
+
+1;
+__END__
+
+=head1 BUGS
+
+Please send bug reports to <bug-class-meta at rt.cpan.org> or report them via the
+CPAN Request Tracker at L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Class-Meta>.
+
+=head1 AUTHOR
+
+David Wheeler <david at kineticode.com>
+
+=head1 SEE ALSO
+
+Other classes of interest within the Class::Meta distribution include:
+
+=over 4
+
+=item L<Class::Meta|Class::Meta>
+
+=item L<Class::Meta::Class|Class::Meta::Class>
+
+=item L<Class::Meta::Constructor|Class::Meta::Constructor>
+
+=item L<Class::Meta::Attribute|Class::Meta::Attribute>
+
+=back
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (c) 2002-2005, David Wheeler. All Rights Reserved.
+
+This module is free software; you can redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=cut
Added: packages/libclass-meta-perl/branches/upstream/current/lib/Class/Meta/Type.pm
===================================================================
--- packages/libclass-meta-perl/branches/upstream/current/lib/Class/Meta/Type.pm 2006-01-04 09:19:20 UTC (rev 1847)
+++ packages/libclass-meta-perl/branches/upstream/current/lib/Class/Meta/Type.pm 2006-01-04 09:24:55 UTC (rev 1848)
@@ -0,0 +1,786 @@
+package Class::Meta::Type;
+
+# $Id: Type.pm 2405 2005-12-17 03:41:09Z theory $
+
+=head1 NAME
+
+Class::Meta::Type - Data type validation and accessor building.
+
+=head1 SYNOPSIS
+
+ package MyApp::TypeDef;
+
+ use strict;
+ use Class::Meta::Type;
+ use IO::Socket;
+
+ my $type = Class::Meta::Type->add( key => 'io_socket',
+ desc => 'IO::Socket object',
+ name => 'IO::Socket Object' );
+
+=head1 DESCRIPTION
+
+This class stores the various data types used by C<Class::Meta>. It manages
+all aspects of data type validation and method creation. New data types can be
+added to Class::Meta::Type by means of the C<add()> constructor. This is
+useful for creating custom types for your Class::Meta-built classes.
+
+B<Note:>This class manages the most advanced features of C<Class::Meta>.
+Before deciding to create your own accessor closures as described in L<add()>,
+you should have a thorough working knowledge of how Class::Meta works, and
+have studied the L<add()> method carefully. Simple data type definitions such
+as that shown in the L<SYNOPSIS>, on the other hand, are encouraged.
+
+=cut
+
+##############################################################################
+# Dependencies #
+##############################################################################
+use strict;
+
+##############################################################################
+# Package Globals #
+##############################################################################
+our $VERSION = "0.52";
+
+##############################################################################
+# Private Package Globals #
+##############################################################################
+my %def_builders = (
+ 'default' => 'Class::Meta::AccessorBuilder',
+ 'affordance' => 'Class::Meta::AccessorBuilder::Affordance',
+ 'semi-affordance' => 'Class::Meta::AccessorBuilder::SemiAffordance',
+);
+
+# This code ref builds object/reference value checkers.
+my $class_validation_generator = sub {
+ my ($pkg, $type) = @_;
+ return [
+ sub {
+ return unless defined $_[0];
+ UNIVERSAL::isa($_[0], $pkg)
+ or $_[2]->class->handle_error("Value '$_[0]' is not a valid "
+ . "$type");
+ }
+ ];
+};
+
+##############################################################################
+# Data type definition storage.
+##############################################################################
+{
+ my %types = ();
+
+##############################################################################
+# Constructors #
+##############################################################################
+
+=head1 CONSTRUCTORS
+
+=head2 new
+
+ my $type = Class::Meta::Type->new($key);
+
+Returns the data type definition for an existing data type. The definition
+will be looked up by the C<$key> argument. Use C<add()> to specify new types.
+If no data type exists for a given key, but C<< Class::Meta->for_key >>
+returns a Class::Meta::Class object for that key, then C<new()> will
+implicitly call C<add()> to create add a new type corresponding to that
+class. This makes it easy to use any Class::Meta class as a data type.
+
+Other data types can be added by means of the C<add()> constructor, or by
+simply C<use>ing one or more of the following modules:
+
+=over 4
+
+=item L<Class::Meta::Types::Perl|Class::Meta::Types::Perl>
+
+=over 4
+
+=item scalar
+
+=item scalarref
+
+=item array
+
+=item hash
+
+=item code
+
+=back
+
+=item L<Class::Meta::Types::String|Class::Meta::Types::String>
+
+=over 4
+
+=item string
+
+=back
+
+=item L<Class::Meta::Types::Boolean|Class::Meta::Types::Boolean>
+
+=over 4
+
+=item boolean
+
+=back
+
+=item L<Class::Meta::Types::Numeric|Class::Meta::Types::Numeric>
+
+=over 4
+
+=item whole
+
+=item integer
+
+=item decimal
+
+=item real
+
+=item float
+
+=back
+
+=back
+
+Read the documentation for the individual modules for details on their data
+types.
+
+=cut
+
+ sub new {
+ my $class = shift;
+ my $key = lc shift
+ || Class::Meta->handle_error("Type argument required");
+ unless (exists $types{$key}) {
+ # See if there's a Class::Meta class defined for this key.
+ my $cmc = Class::Meta->for_key($key)
+ or Class::Meta->handle_error("Type '$key' does not exist");
+
+ # Create a new type for this class.
+ return $class->add(
+ key => $key,
+ name => $cmc->package,
+ check => $cmc->package
+ );
+ }
+ return bless $types{$key}, $class;
+ }
+
+##############################################################################
+
+=head2 add
+
+ my $type = Class::Meta::Type->add( key => 'io_socket',
+ name => 'IO::Socket Object',
+ desc => 'IO::Socket object' );
+
+Creates a new data type definition and stores it for future use. Use this
+constructor to add new data types to meet the needs of your class. The named
+parameter arguments are:
+
+=over 4
+
+=item key
+
+Required. The key with which the data type can be looked up in the future via a
+call to C<new()>. Note that the key will be used case-insensitively, so "foo",
+"Foo", and "FOO" are equivalent, and the key must be unique.
+
+=item name
+
+Required. The name of the data type. This should be formatted for display
+purposes, and indeed, Class::Meta will often use it in its own exceptions.
+
+=item check
+
+Optional. Specifies how to validate the value of an attribute of this type.
+The check parameter can be specified in any of the following ways:
+
+=over 4
+
+=item *
+
+As a code reference. When Class::Meta executes this code reference, it will
+pass in the value to check, the object for which the attribute will be set,
+and the Class::Meta::Attribute object describing the attribute. If the attribute
+is a class attribute, then the second argument will not be an object, but a
+hash reference with two keys:
+
+=over 8
+
+=item $name
+
+The existing value for the attribute is stored under the attribute name.
+
+=item __pkg
+
+The name of the package to which the attribute is being assigned.
+
+=back
+
+If the new value is not the proper value for your custom data type, the code
+reference should throw an exception. Here's an example; it's the code
+reference used by "string" data type, which you can add to Class::Meta::Type
+simply by using Class::Meta::Types::String:
+
+ check => sub {
+ my $value = shift;
+ return unless defined $value && ref $value;
+ require Carp;
+ our @CARP_NOT = qw(Class::Meta::Attribute);
+ Carp::croak("Value '$value' is not a valid string");
+ }
+
+Here's another example. This code reference might be used to make sure that a
+new value is always greater than the existing value.
+
+ check => sub {
+ my ($new_val, $obj, $attr) = @_;
+ # Just return if the new value is greater than the old value.
+ return if defined $new_val && $new_val > $_[1]->{$_[2]->get_name};
+ require Carp;
+ our @CARP_NOT = qw(Class::Meta::Attribute);
+ Carp::croak("Value '$new_val' is not greater than '$old_val'");
+ }
+
+=item *
+
+As an array reference. All items in this array reference must be code
+references that perform checks on a value, as specified above.
+
+=item *
+
+As a string. In this case, Class::Meta::Type assumes that your data type
+identifies a particular object type. Thus it will use the string to construct
+a validation code reference for you. For example, if you wanted to create a
+data type for IO::Socket objects, pass the string 'IO::Socket' to the check
+parameter and Class::Meta::Type will use the code reference returned by
+C<class_validation_generator()> to generate the validation checks. If you'd
+like to specify an alternative class validation code generator, pass one to
+the C<class_validation_generator()> class method. Or pass in a code reference
+or array reference of code reference as just described to use your own
+validator once.
+
+=back
+
+Note that if the C<check> parameter is not specified, there will never be any
+validation of your custom data type. And yes, there may be times when you want
+this -- The default "scalar" and "boolean" data types, for example, have no
+checks.
+
+=item builder
+
+Optional. This parameter specifies the accessor builder for attributes of this
+type. The C<builder> parameter can be any of the following values:
+
+=over 4
+
+=item "default"
+
+The string 'default' uses Class::Meta::Type's default accessor building code,
+provided by Class::Meta::AccessorBuilder. This is the default value, of
+course.
+
+=item "affordance"
+
+The string 'default' uses Class::Meta::Type's affordance accessor building
+code, provided by Class::Meta::AccessorBuilder::Affordance. Affordance accessors
+provide two accessors for an attribute, a C<get_*> accessor and a C<set_*>
+mutator. See
+L<Class::Meta::AccessorBuilder::Affordance|Class::Meta::AccessorBuilder::Affordance>
+for more information.
+
+=item "semi-affordance"
+
+The string 'default' uses Class::Meta::Type's semi-affordance accessor
+building code, provided by Class::Meta::AccessorBuilder::SemiAffordance.
+Semi-affordance accessors differ from affordance accessors in that they do not
+prepend C<get_> to the accessor. So for an attribute "foo", the accessor would
+be named C<foo()> and the mutator named C<set_foo()>. See
+L<Class::Meta::AccessorBuilder::SemiAffordance|Class::Meta::AccessorBuilder::SemiAffordance>
+for more information.
+
+=item A Package Name
+
+Pass in the name of a package that contains the functions C<build()>,
+C<build_attr_get()>, and C<build_attr_set()>. These functions will be used to
+create the necessary accessors for an attribute. See L<Custom Accessor
+Building|"Custom Accessor Building"> for details on creating your own
+accessor builders.
+
+=back
+
+=back
+
+=cut
+
+ sub add {
+ my $pkg = shift;
+ # Make sure we can process the parameters.
+ Class::Meta->handle_error("Odd number of parameters in "
+ . "call to new() when named "
+ . "parameters were expected")
+ if @_ % 2;
+
+ my %params = @_;
+
+ # Check required paremeters.
+ foreach (qw(key name)) {
+ Class::Meta->handle_error("Parameter '$_' is required")
+ unless $params{$_};
+ }
+
+ # Check the key parameter.
+ $params{key} = lc $params{key};
+ Class::Meta->handle_error("Type '$params{key}' already defined")
+ if exists $types{$params{key}};
+
+ # Set up the check croak.
+ my $chk_die = sub {
+ Class::Meta->handle_error(
+ "Paremter 'check' in call to add() must be a code reference, "
+ . "an array of code references, or a scalar naming an object "
+ . "type"
+ );
+ };
+
+ # Check the check parameter.
+ if ($params{check}) {
+ my $ref = ref $params{check};
+ if (not $ref) {
+ # It names the object to be checked. So generate a validator.
+ $params{check} =
+ $class_validation_generator->(@params{qw(check name)});
+ $params{check} = [$params{check}]
+ if ref $params{check} eq 'CODE';
+ } elsif ($ref eq 'CODE') {
+ $params{check} = [$params{check}]
+ } elsif ($ref eq 'ARRAY') {
+ # Make sure that they're all code references.
+ foreach my $chk (@{$params{check}}) {
+ $chk_die->() unless ref $chk eq 'CODE';
+ }
+ } else {
+ # It's bogus.
+ $chk_die->();
+ }
+ }
+
+ # Check the builder parameter.
+ $params{builder} ||= $pkg->default_builder;
+
+ my $builder = $def_builders{$params{builder}} || $params{builder};
+ # Make sure it's loaded.
+ eval "require $builder" or die $@;
+
+ $params{builder} = UNIVERSAL::can($builder, 'build')
+ || Class::Meta->handle_error("No such function "
+ . "'${builder}::build()'");
+
+ $params{attr_get} = UNIVERSAL::can($builder, 'build_attr_get')
+ || Class::Meta->handle_error("No such function "
+ . "'${builder}::build_attr_get()'");
+
+ $params{attr_set} = UNIVERSAL::can($builder, 'build_attr_set')
+ || Class::Meta->handle_error("No such function "
+ . "'${builder}::build_attr_set()'");
+
+ # Okay, add the new type to the cache and construct it.
+ $types{$params{key}} = \%params;
+
+ # Grab any aliases.
+ if (my $alias = delete $params{alias}) {
+ if (ref $alias) {
+ $types{$_} = \%params for @$alias;
+ } else {
+ $types{$alias} = \%params;
+ }
+ }
+ return $pkg->new($params{key});
+ }
+}
+
+##############################################################################
+
+=head1 CLASS METHODS
+
+=head2 default_builder
+
+ my $default_builder = Class::Meta::Type->default_builder;
+ Class::Meta::Type->default_builder($default_builder);
+
+Get or set the default builder class attribute. The value can be any one of
+the values specified for the C<builder> parameter to add(). The value set in
+this attribute will be used for the C<builder> parameter to to add() when none
+is explicitly passed. Defaults to "default".
+
+=cut
+
+my $default_builder = 'default';
+sub default_builder {
+ my $pkg = shift;
+ return $default_builder unless @_;
+ $default_builder = shift;
+ return $pkg;
+}
+
+##############################################################################
+
+=head2 class_validation_generator
+
+ my $gen = Class::Meta::Type->class_validation_generator;
+ Class::Meta::Type->class_validation_generator( sub {
+ my ($pkg, $name) = @_;
+ return sub {
+ die "'$pkg' is not a valid $name"
+ unless UNIVERSAL::isa($pkg, $name);
+ };
+ });
+
+Gets or sets a code reference that will be used to generate the validation
+checks for class data types. That is to say, it will be used when a string is
+passed to the C<checks> parameter to <add()> to generate the validation
+checking code for data types that are objects. By default, it will generate a
+validation checker like this:
+
+ sub {
+ my $value = shift;
+ return if UNIVERSAL::isa($value, 'IO::Socket')
+ require Carp;
+ our @CARP_NOT = qw(Class::Meta::Attribute);
+ Carp::croak("Value '$value' is not a IO::Socket object");
+ };
+
+But if you'd like to specify an alternate validation check generator--perhaps
+you'd like to throw exception objects rather than use Carp--just pass a code
+reference to this class method. The code reference should expect two
+arguments: the data type value to be validated, and the string passed via the
+C<checks> parameter to C<add()>. It should return a code reference or array of
+code references that validate the value. For example, you might want to do
+something like this to throw exception objects:
+
+ use Exception::Class('MyException');
+
+ Class::Meta::Type->class_validation_generator( sub {
+ my ($pkg, $type) = @_;
+ return [ sub {
+ my ($value, $object, $attr) = @_;
+ MyException->throw("Value '$value' is not a valid $type")
+ unless UNIVERSAL::isa($value, $pkg);
+ } ];
+ });
+
+But if the default object data type validator is good enough for you, don't
+worry about it.
+
+=cut
+
+sub class_validation_generator {
+ my $class = shift;
+ return $class_validation_generator unless @_;
+ $class_validation_generator = shift;
+}
+
+##############################################################################
+# Instance methods.
+##############################################################################
+
+=head1 INTERFACE
+
+=head2 Instance Methods
+
+=head3 key
+
+ my $key = $type->key;
+
+Returns the key name for the type.
+
+=head3 name
+
+ my $name = $type->name;
+
+Returns the type name.
+
+=head3 check
+
+ my $checks = $type->check;
+ my @checks = $type->check;
+
+Returns an array reference or list of the data type validation code references
+for the data type.
+
+=cut
+
+sub key { $_[0]->{key} }
+sub name { $_[0]->{name} }
+sub check {
+ return unless $_[0]->{check};
+ wantarray ? @{$_[0]->{check}} : $_[0]->{check}
+}
+
+##############################################################################
+
+=head3 build
+
+This is a protected method, designed to be called only by the
+Class::Meta::Attribute class or a subclass of Class::Meta::Attribute. It
+creates accessors for the class that the Class::Meta::Attribute object is a
+part of by calling out to the C<build()> method of the accessor builder class.
+
+Although you should never call this method directly, subclasses of
+Class::Meta::Type may need to override its behavior.
+
+=cut
+
+sub build {
+ # Check to make sure that only Class::Meta or a subclass is building
+ # attribute accessors.
+ my $caller = caller;
+ Class::Meta->handle_error("Package '$caller' cannot call "
+ . __PACKAGE__ . "->build")
+ unless UNIVERSAL::isa($caller, 'Class::Meta::Attribute');
+
+ my $self = shift;
+ my $code = $self->{builder};
+ $code->(@_, $self->check);
+ return $self;
+}
+
+##############################################################################
+
+=head3 make_attr_set
+
+This is a protected method, designed to be called only by the
+Class::Meta::Attribute class or a subclass of Class::Meta::Attribute. It
+returns a reference to the attribute set accessor (mutator) created by the
+call to C<build()>, and usable as an indirect attribute accessor by the
+Class::Meta::Attribute C<set()> method.
+
+Although you should never call this method directly, subclasses of
+Class::Meta::Type may need to override its behavior.
+
+=cut
+
+sub make_attr_set {
+ my $self = shift;
+ my $code = $self->{attr_set};
+ $code->(@_);
+}
+
+##############################################################################
+
+=head3 make_attr_get
+
+This is a protected method, designed to be called only by the
+Class::Meta::Attribute class or a subclass of Class::Meta::Attribute. It
+returns a reference to the attribute get accessor created by the call to
+C<build()>, and usable as an indirect attribute accessor by the
+Class::Meta::Attribute C<get()> method.
+
+Although you should never call this method directly, subclasses of
+Class::Meta::Type may need to override its behavior.
+
+=cut
+
+sub make_attr_get {
+ my $self = shift;
+ my $code = $self->{attr_get};
+ $code->(@_);
+}
+
+1;
+__END__
+
+=head1 CUSTOM DATA TYPES
+
+Creating custom data types can be as simple as calling C<add()> and passing in
+the name of a class for the C<check> parameter. This is especially useful when
+you just need to create attributes that contain objects of a particular type,
+and you're happy with the accessors that Class::Meta will create for you. For
+example, if you needed a data type for a DateTime object, you can set it
+up--complete with validation of the data type, like this:
+
+ my $type = Class::Meta::Type->add( key => 'datetime',
+ check => 'DateTime',
+ desc => 'DateTime object',
+ name => 'DateTime Object' );
+
+From then on, you can create attributes of the type "datetime" without any
+further work. If you wanted to use affordance accessors, you'd simply
+add the requisite C<builder> attribute:
+
+ my $type = Class::Meta::Type->add( key => 'datetime',
+ check => 'DateTime',
+ builder => 'affordance',
+ desc => 'DateTime object',
+ name => 'DateTime Object' );
+
+The same goes for using semi-affordance accessors.
+
+Other than that, adding other data types is really a matter of the judicious
+use of the C<check> parameter. Ultimately, all attributes are scalar
+values. Whether they adhere to a particular data type depends entirely on the
+validation code references passed via C<check>. For example, if you wanted to
+create a "range" attribute with only the allowed values 1-5, you could do it
+like this:
+
+ my $range_chk = sub {
+ my $value = shift;
+ die "Value is not a number" unless $value =~ /^[1..5]$/;
+ };
+
+ my $type = Class::Meta::Type->add( key => 'range',
+ check => $range_chk,
+ desc => 'Pick a number between 1 and 5',
+ name => 'Range (1-5)' );
+
+Of course, the above value validator will throw an exception with the
+line number from which C<die> is called. Even better is to use L<Carp|Carp>
+to throw an error with the file and line number of the client code:
+
+ my $range_chk = sub {
+ my $value = shift;
+ return if $value =~ /^[1..5]$/;
+ require Carp;
+ our @CARP_NOT = qw(Class::Meta::Attribute);
+ Carp::croak("Value is not a number");
+ };
+
+The C<our @CARP_NOT> line prevents the context from being thrown from within
+Class::Meta::Attribute, which is useful if you make use of that class'
+C<set()> method.
+
+=head2 Custom Accessor Building
+
+Class::Meta also allows you to craft your own accessors. Perhaps you'd prefer
+to use a StudlyCaps affordance accessor standard. In that case, you'll need to
+create your own module that builds accessors. I recommend that you study
+L<Class::Meta::AccessorBuilder|Class::Meta::AccessorBuilder> and
+LClass::Meta::AccessorBuilder::Affordance|Class::Meta::AccessorBuilder::Affordance>
+before taking on creating your own.
+
+Custom accessor building modules must have three functions.
+
+=head3 build
+
+The C<build()> function creates and installs the actual accessor methods in a
+class. It should expect the following arguments:
+
+ sub build {
+ my ($class, $attribute, $create, @checks) = @_;
+ # ...
+ }
+
+These are:
+
+=over 4
+
+=item C<$class>
+
+The name of the class into which the accessors are to be installed.
+
+=item C<$attribute>
+
+A Class::Meta::Attribute object representing the attribute for which accessors
+are to be created. Use it to determine what types of accessors to create
+(read-only, write-only, or read/write, class or object), and to add checks for
+requiredness and accessibility (if the attribute is private or protected).
+
+=item C<$create>
+
+The value of the C<create> paramter passed to Class::Meta::Attribute when the
+attribute object was created. Use this argument to determine what type of
+accessor(s) to create. See L<Class::Meta::Attribute|Class::Meta::Attribute>
+for the possible values for this argument.
+
+=item C<@checks>
+
+A list of one or more data type validation code references. Use these in any
+accessors that set attribute values to check that the new value has a valid
+value.
+
+=back
+
+See L<Class::Meta::AccessorBuilder|Class::Meta::AccessorBuilder> for example
+attribute creation functions.
+
+=head3 build_attr_get and build_attr_set
+
+The C<build_attr_get()> and C<build_attr_set()> functions take a single
+argument, a Class::Meta::Attribute object, and return code references that
+either represent the corresponding methods, or that call the appropriate
+accessor methods to get and set an attribute, respectively. The code
+references will be used by Class::Meta::Attribute's C<get()> and
+C<set()> methods to get and set attribute values. Again, see
+L<Class::Meta::AccessorBuilder|Class::Meta::AccessorBuilder> for examples
+before creating your own.
+
+=head1 BUGS
+
+Please send bug reports to <bug-class-meta at rt.cpan.org> or report them via the
+CPAN Request Tracker at L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Class-Meta>.
+
+=head1 AUTHOR
+
+David Wheeler <david at kineticode.com>
+
+=head1 SEE ALSO
+
+Other classes of interest within the Class::Meta distribution include:
+
+=over 4
+
+=item L<Class::Meta|Class::Meta>
+
+This class contains most of the documentation you need to get started with
+Class::Meta.
+
+=item L<Class::Meta::Attribute|Class::Meta::Attribute>
+
+This class manages Class::Meta class attributes, all of which are based on
+data types.
+
+=back
+
+These modules provide some data types to get you started:
+
+=over 4
+
+=item L<Class::Meta::Types::Perl|Class::Meta::Types::Perl>
+
+=item L<Class::Meta::Types::String|Class::Meta::Types::String>
+
+=item L<Class::Meta::Types::Boolean|Class::Meta::Types::Boolean>
+
+=item L<Class::Meta::Types::Numeric|Class::Meta::Types::Numeric>
+
+=back
+
+The modules that Class::Meta comes with for creating accessors are:
+
+=over 4
+
+=item L<Class::Meta::AccessorBuilder|Class::Meta::AccessorBuilder>
+
+Standard Perl-style accessors.
+
+=item L<Class::Meta::AccessorBuilder::Affordance|Class::Meta::AccessorBuilder::Affordance>
+
+Affordance accessors--that is, explicit and independent get and set accessors.
+
+=item L<Class::Meta::AccessorBuilder::SemiAffordance|Class::Meta::AccessorBuilder::SemiAffordance>
+
+Semi-ffordance accessors--that is, independent get and set accessors with an
+explicit set accessor.
+
+=back
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (c) 2002-2005, David Wheeler. All Rights Reserved.
+
+This module is free software; you can redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=cut
Added: packages/libclass-meta-perl/branches/upstream/current/lib/Class/Meta/Types/Boolean.pm
===================================================================
--- packages/libclass-meta-perl/branches/upstream/current/lib/Class/Meta/Types/Boolean.pm 2006-01-04 09:19:20 UTC (rev 1847)
+++ packages/libclass-meta-perl/branches/upstream/current/lib/Class/Meta/Types/Boolean.pm 2006-01-04 09:24:55 UTC (rev 1848)
@@ -0,0 +1,206 @@
+package Class::Meta::Types::Boolean;
+
+# $Id: Boolean.pm 2405 2005-12-17 03:41:09Z theory $
+
+=head1 NAME
+
+Class::Meta::Types::Boolean - Boolean data types
+
+=head1 SYNOPSIS
+
+ package MyApp::Thingy;
+ use strict;
+ use Class::Meta;
+ use Class::Meta::Types::Boolean;
+ # OR...
+ # use Class::Meta::Types::Boolean 'affordance';
+ # OR...
+ # use Class::Meta::Types::Boolean 'semi-affordance';
+
+ BEGIN {
+ # Create a Class::Meta object for this class.
+ my $cm = Class::Meta->new( key => 'thingy' );
+
+ # Add a boolean attribute.
+ $cm->add_attribute( name => 'alive',
+ type => 'boolean' );
+ $cm->build;
+ }
+
+=head1 DESCRIPTION
+
+This module provides a boolean data type for use with Class::Meta attributes.
+Simply load it, then pass "boolean" (or the alias "bool") to the
+C<add_attribute()> method of a Class::Meta object to create an attribute of
+the boolean data type. See L<Class::Meta::Type|Class::Meta::Type> for more
+information on using and creating data types.
+
+=head2 Accessors
+
+Although the boolean data type has both "default" and "affordance" accessor
+options available, unlike the other data types that ship with Class::Meta,
+they have different implementations. The reason for this is to ensure that
+the value of a boolean attribute is always 0 or 1.
+
+For the "default" accessor style, there is no difference in the interface from
+the default accessors for other data types. The default accessor merely checks
+the truth of the new value, and assigns 1 if it's a true value, and 0 if it's
+a false value. The result is an efficient accessor that maintains the
+consistency of the data.
+
+For the "affordance" accessor style, however, the boolean data type varies in
+the accessors it creates. For example, for a boolean attributed named "alive",
+instead of creating the C<get_alive> and C<set_alive> accessors common to
+other affordance-style accessors, it instead creates three:
+
+=over 4
+
+=item C<is_alive>
+
+=item C<set_alive_on>
+
+=item C<set_alive_off>
+
+=back
+
+The result is highly efficient accessors that ensure the integrity of the data
+without the overhead of validation checks.
+
+=cut
+
+use strict;
+use Class::Meta::Type;
+our $VERSION = "0.52";
+
+sub import {
+ my ($pkg, $builder) = @_;
+ $builder ||= 'default';
+ return if eval "Class::Meta::Type->new('boolean')";
+
+ if ($builder eq 'default') {
+ eval q|
+sub build_attr_get {
+ UNIVERSAL::can($_[0]->package, $_[0]->name);
+}
+
+*build_attr_set = \&build_attr_get;
+
+sub build {
+ my ($pkg, $attr, $create) = @_;
+ $attr = $attr->name;
+
+ no strict 'refs';
+ if ($create == Class::Meta::GET) {
+ # Create GET accessor.
+ *{"${pkg}::$attr"} = sub { $_[0]->{$attr} };
+
+ } elsif ($create == Class::Meta::SET) {
+ # Create SET accessor.
+ *{"${pkg}::$attr"} = sub { $_[0]->{$attr} = $_[1] ? 1 : 0 };
+
+ } elsif ($create == Class::Meta::GETSET) {
+ # Create GETSET accessor.
+ *{"${pkg}::$attr"} = sub {
+ my $self = shift;
+ return $self->{$attr} unless @_;
+ $self->{$attr} = $_[0] ? 1 : 0
+ };
+ } else {
+ # Well, nothing I guess.
+ }
+}|
+ } else {
+
+ my $code = q|
+sub build_attr_get {
+ UNIVERSAL::can($_[0]->package, 'is_' . $_[0]->name);
+}
+
+sub build_attr_set {
+ my $name = shift->name;
+ eval "sub { \$_[1] ? \$_[0]->set_$name\_on : \$_[0]->set_$name\_off }";
+}
+
+sub build {
+ my ($pkg, $attr, $create) = @_;
+ $attr = $attr->name;
+
+ no strict 'refs';
+ if ($create >= Class::Meta::GET) {
+ # Create GET accessor.
+ *{"${pkg}::is_$attr"} = sub { $_[0]->{$attr} };
+ }
+ if ($create >= Class::Meta::SET) {
+ # Create SET accessors.
+ *{"${pkg}::set_$attr\_on"} = sub { $_[0]->{$attr} = 1 };
+ *{"${pkg}::set_$attr\_off"} = sub { $_[0]->{$attr} = 0 };
+ }
+}|;
+
+ $code =~ s/get_//g unless $builder eq 'affordance';
+ eval $code;
+ }
+
+ Class::Meta::Type->add(
+ key => "boolean",
+ name => "Boolean",
+ desc => "Boolean",
+ alias => 'bool',
+ builder => __PACKAGE__
+ );
+}
+
+1;
+__END__
+
+=head1 BUGS
+
+Please send bug reports to <bug-class-meta at rt.cpan.org> or report them via the
+CPAN Request Tracker at L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Class-Meta>.
+
+=head1 AUTHOR
+
+David Wheeler <david at kineticode.com>
+
+=head1 SEE ALSO
+
+Other classes of interest within the Class::Meta distribution include:
+
+=over 4
+
+=item L<Class::Meta|Class::Meta>
+
+This class contains most of the documentation you need to get started with
+Class::Meta.
+
+=item L<Class::Meta::Type|Class::Meta::Type>
+
+This class manages the creation of data types.
+
+=item L<Class::Meta::Attribute|Class::Meta::Attribute>
+
+This class manages Class::Meta class attributes, all of which are based on
+data types.
+
+=back
+
+Other data type modules:
+
+=over 4
+
+=item L<Class::Meta::Types::Perl|Class::Meta::Types::Perl>
+
+=item L<Class::Meta::Types::String|Class::Meta::Types::String>
+
+=item L<Class::Meta::Types::Numeric|Class::Meta::Types::Numeric>
+
+=back
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (c) 2002-2005, David Wheeler. All Rights Reserved.
+
+This module is free software; you can redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=cut
Added: packages/libclass-meta-perl/branches/upstream/current/lib/Class/Meta/Types/Numeric.pm
===================================================================
--- packages/libclass-meta-perl/branches/upstream/current/lib/Class/Meta/Types/Numeric.pm 2006-01-04 09:19:20 UTC (rev 1847)
+++ packages/libclass-meta-perl/branches/upstream/current/lib/Class/Meta/Types/Numeric.pm 2006-01-04 09:24:55 UTC (rev 1848)
@@ -0,0 +1,194 @@
+package Class::Meta::Types::Numeric;
+
+# $Id: Numeric.pm 2405 2005-12-17 03:41:09Z theory $
+
+=head1 NAME
+
+Class::Meta::Types::Numeric - Numeric data types
+
+=head1 SYNOPSIS
+
+ package MyApp::Thingy;
+ use strict;
+ use Class::Meta;
+ use Class::Meta::Types::Numeric;
+ # OR...
+ # use Class::Meta::Types::Numeric 'affordance';
+ # OR...
+ # use Class::Meta::Types::Numeric 'semi-affordance';
+
+ BEGIN {
+ # Create a Class::Meta object for this class.
+ my $cm = Class::Meta->new( key => 'thingy' );
+
+ # Add an integer attribute.
+ $cm->add_attribute( name => 'age',
+ type => 'integer' );
+ $cm->build;
+ }
+
+=head1 DESCRIPTION
+
+This module provides numeric data types for use with Class::Meta attributes.
+Simply load it, then pass the name of one of its types to the
+C<add_attribute()> method of a Class::Meta object to create attributes of the
+numeric data type. See L<Class::Meta::Type|Class::Meta::Type> for more
+information on using and creating data types.
+
+The validation checks for Class::Meta::Types::Numeric are provided by the
+Data::Types module. Consult its documentation to find out what it considers to
+be a number and what's not.
+
+The data types created by Class::Meta::Types::Numeric are:
+
+=over
+
+=item whole
+
+A whole number. That is, a positive integer.
+
+=item integer
+
+=item int
+
+An integer number.
+
+=item decimal
+
+=item dec
+
+A decimal number.
+
+=item real
+
+A real number.
+
+=item float
+
+A floating point number.
+
+=back
+
+=cut
+
+use strict;
+use Class::Meta::Type;
+use Data::Types ();
+our $VERSION = "0.52";
+
+# This code ref builds value checkers.
+my $mk_chk = sub {
+ my ($code, $type) = @_;
+ return [
+ sub {
+ return unless defined $_[0];
+ $code->($_[0])
+ or $_[2]->class->handle_error("Value '$_[0]' is not a valid "
+ . "$type");
+ }
+ ];
+};
+
+##############################################################################
+sub import {
+ my ($pkg, $builder) = @_;
+ $builder ||= 'default';
+ return if eval "Class::Meta::Type->new('whole')";
+
+ Class::Meta::Type->add(
+ key => "whole",
+ name => "Whole Number",
+ desc => "Whole number",
+ builder => $builder,
+ check => $mk_chk->(\&Data::Types::is_whole, 'whole number'),
+ );
+
+ Class::Meta::Type->add(
+ key => "integer",
+ name => "Integer",
+ desc => "Integer",
+ alias => 'int',
+ builder => $builder,
+ check => $mk_chk->(\&Data::Types::is_int, 'integer'),
+ );
+
+ Class::Meta::Type->add(
+ key => "decimal",
+ name => "Decimal Number",
+ desc => "Decimal number",
+ alias => 'dec',
+ builder => $builder,
+ check => $mk_chk->(\&Data::Types::is_decimal, 'decimal number'),
+ );
+
+ Class::Meta::Type->add(
+ key => "real",
+ name => "Real Number",
+ desc => "Real number",
+ builder => $builder,
+ check => $mk_chk->(\&Data::Types::is_real, 'real number'),
+ );
+
+ Class::Meta::Type->add(
+ key => "float",
+ name => "Floating Point Number",
+ desc => "Floating point number",
+ builder => $builder,
+ check => $mk_chk->(\&Data::Types::is_float, 'floating point number'),
+ );
+}
+
+1;
+__END__
+
+=head1 BUGS
+
+Please send bug reports to <bug-class-meta at rt.cpan.org> or report them via the
+CPAN Request Tracker at L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Class-Meta>.
+
+=head1 AUTHOR
+
+David Wheeler <david at kineticode.com>
+
+=head1 SEE ALSO
+
+Other classes of interest within the Class::Meta distribution include:
+
+=over 4
+
+=item L<Class::Meta|Class::Meta>
+
+This class contains most of the documentation you need to get started with
+Class::Meta.
+
+=item L<Class::Meta::Type|Class::Meta::Type>
+
+This class manages the creation of data types.
+
+=item L<Class::Meta::Attribute|Class::Meta::Attribute>
+
+This class manages Class::Meta class attributes, all of which are based on
+data types.
+
+=back
+
+Other data type modules:
+
+=over 4
+
+=item L<Class::Meta::Types::Perl|Class::Meta::Types::Perl>
+
+=item L<Class::Meta::Types::String|Class::Meta::Types::String>
+
+=item L<Class::Meta::Types::Boolean|Class::Meta::Types::Boolean>
+
+=back
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (c) 2002-2005, David Wheeler. All Rights Reserved.
+
+This module is free software; you can redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=cut
Added: packages/libclass-meta-perl/branches/upstream/current/lib/Class/Meta/Types/Perl.pm
===================================================================
--- packages/libclass-meta-perl/branches/upstream/current/lib/Class/Meta/Types/Perl.pm 2006-01-04 09:19:20 UTC (rev 1847)
+++ packages/libclass-meta-perl/branches/upstream/current/lib/Class/Meta/Types/Perl.pm 2006-01-04 09:24:55 UTC (rev 1848)
@@ -0,0 +1,184 @@
+package Class::Meta::Types::Perl;
+
+# $Id: Perl.pm 2405 2005-12-17 03:41:09Z theory $
+
+=head1 NAME
+
+Class::Meta::Types::Perl - Perl data types
+
+=head1 SYNOPSIS
+
+ package MyApp::Thingy;
+ use strict;
+ use Class::Meta;
+ use Class::Meta::Types::Perl;
+ # OR...
+ # use Class::Meta::Types::Perl 'affordance';
+ # OR...
+ # use Class::Meta::Types::Perl 'semi-affordance';
+
+ BEGIN {
+ # Create a Class::Meta object for this class.
+ my $cm = Class::Meta->new( key => 'thingy' );
+
+ # Add an integer attribute.
+ $cm->add_attribute( name => 'my_hash',
+ type => 'hash' );
+ $cm->build;
+ }
+
+=head1 DESCRIPTION
+
+This module provides Perl data types for use with Class::Meta attributes.
+Simply load it, then pass the name of one of its types to the
+C<add_attribute()> method of a Class::Meta object. See
+L<Class::Meta::Type|Class::Meta::Type> for more information on using and
+creating data types.
+
+The validation checks for Class::Meta::Types::Perl are provided by the
+Class::Meta::Type's support for object type validation, since Perl data types
+are understood by C<UNIVERSAL::isa()>.
+
+The data types created by Class::Meta::Types::Perl are:
+
+=over
+
+=item scalar
+
+A simple scalar value. This can be anything, and has no validation checks.
+
+=item scalarref
+
+A scalar reference. C<UNIVERSAL::isa()> must return 'SCALAR'.
+
+=item array
+
+=item arrayref
+
+A array reference. C<UNIVERSAL::isa()> must return 'ARRAY'.
+
+=item hash
+
+=item hashref
+
+A hash reference. C<UNIVERSAL::isa()> must return 'HASH'.
+
+=item code
+
+=item coderef
+
+=item closure
+
+A code reference. Also known as a closure. C<UNIVERSAL::isa()> must return
+'CODE'.
+
+=back
+
+=cut
+
+use strict;
+use Class::Meta::Type;
+our $VERSION = "0.52";
+
+sub import {
+ my ($pkg, $builder) = @_;
+ $builder ||= 'default';
+ return if eval "Class::Meta::Type->new('array')";
+
+ Class::Meta::Type->add(
+ key => "scalar",
+ name => "Scalar",
+ desc => "Scalar",
+ builder => $builder,
+ );
+
+ Class::Meta::Type->add(
+ key => "scalarref",
+ name => "Scalar Reference",
+ desc => "Scalar reference",
+ builder => $builder,
+ check => 'SCALAR',
+ );
+
+ Class::Meta::Type->add(
+ key => "array",
+ name => "Array Reference",
+ desc => "Array reference",
+ alias => 'arrayref',
+ builder => $builder,
+ check => 'ARRAY',
+ );
+
+ Class::Meta::Type->add(
+ key => "hash",
+ name => "Hash Reference",
+ desc => "Hash reference",
+ alias => 'hashref',
+ builder => $builder,
+ check => 'HASH',
+ );
+
+ Class::Meta::Type->add(
+ key => "code",
+ name => "Code Reference",
+ desc => "Code reference",
+ alias => [qw(coderef closure)],
+ builder => $builder,
+ check => 'CODE',
+ );
+}
+
+1;
+__END__
+
+=head1 BUGS
+
+Please send bug reports to <bug-class-meta at rt.cpan.org> or report them via the
+CPAN Request Tracker at L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Class-Meta>.
+
+=head1 AUTHOR
+
+David Wheeler <david at kineticode.com>
+
+=head1 SEE ALSO
+
+Other classes of interest within the Class::Meta distribution include:
+
+=over 4
+
+=item L<Class::Meta|Class::Meta>
+
+This class contains most of the documentation you need to get started with
+Class::Meta.
+
+=item L<Class::Meta::Type|Class::Meta::Type>
+
+This class manages the creation of data types.
+
+=item L<Class::Meta::Attribute|Class::Meta::Attribute>
+
+This class manages Class::Meta class attributes, all of which are based on
+data types.
+
+=back
+
+Other data type modules:
+
+=over 4
+
+=item L<Class::Meta::Types::String|Class::Meta::Types::String>
+
+=item L<Class::Meta::Types::Boolean|Class::Meta::Types::Boolean>
+
+=item L<Class::Meta::Types::Numeric|Class::Meta::Types::Numeric>
+
+=back
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (c) 2002-2005, David Wheeler. All Rights Reserved.
+
+This module is free software; you can redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=cut
Added: packages/libclass-meta-perl/branches/upstream/current/lib/Class/Meta/Types/String.pm
===================================================================
--- packages/libclass-meta-perl/branches/upstream/current/lib/Class/Meta/Types/String.pm 2006-01-04 09:19:20 UTC (rev 1847)
+++ packages/libclass-meta-perl/branches/upstream/current/lib/Class/Meta/Types/String.pm 2006-01-04 09:24:55 UTC (rev 1848)
@@ -0,0 +1,114 @@
+package Class::Meta::Types::String;
+
+# $Id: String.pm 2405 2005-12-17 03:41:09Z theory $
+
+=head1 NAME
+
+Class::Meta::Types::String - String data types
+
+=head1 SYNOPSIS
+
+ package MyApp::Thingy;
+ use strict;
+ use Class::Meta;
+ use Class::Meta::Types::String;
+ # OR...
+ # use Class::Meta::Types::String 'affordance';
+ # OR...
+ # use Class::Meta::Types::String 'semi-affordance';
+
+ BEGIN {
+ # Create a Class::Meta object for this class.
+ my $cm = Class::Meta->new( key => 'thingy' );
+
+ # Add a string attribute.
+ $cm->add_attribute( name => 'name',
+ type => 'string' );
+ $cm->build;
+ }
+
+=head1 DESCRIPTION
+
+This module provides a string data type for use with Class::Meta attributes.
+Simply load it, then pass "string" to the C<add_attribute()> method of a
+Class::Meta object to create an attribute of the string data type. See
+L<Class::Meta::Type|Class::Meta::Type> for more information on using and
+creating data types.
+
+=cut
+
+use strict;
+use Class::Meta::Type;
+our $VERSION = "0.52";
+
+sub import {
+ my ($pkg, $builder) = @_;
+ $builder ||= 'default';
+ return if eval "Class::Meta::Type->new('string')";
+
+ Class::Meta::Type->add(
+ key => "string",
+ name => "String",
+ desc => "String",
+ builder => $builder,
+ check => sub {
+ return unless defined $_[0] && ref $_[0];
+ $_[2]->class->handle_error("Value '$_[0]' is not a valid string");
+ }
+ );
+}
+
+1;
+__END__
+
+=head1 BUGS
+
+Please send bug reports to <bug-class-meta at rt.cpan.org> or report them via the
+CPAN Request Tracker at L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Class-Meta>.
+
+=head1 AUTHOR
+
+David Wheeler <david at kineticode.com>
+
+=head1 SEE ALSO
+
+Other classes of interest within the Class::Meta distribution include:
+
+=over 4
+
+=item L<Class::Meta|Class::Meta>
+
+This class contains most of the documentation you need to get started with
+Class::Meta.
+
+=item L<Class::Meta::Type|Class::Meta::Type>
+
+This class manages the creation of data types.
+
+=item L<Class::Meta::Attribute|Class::Meta::Attribute>
+
+This class manages Class::Meta class attributes, all of which are based on
+data types.
+
+=back
+
+Other data type modules:
+
+=over 4
+
+=item L<Class::Meta::Types::Perl|Class::Meta::Types::Perl>
+
+=item L<Class::Meta::Types::Boolean|Class::Meta::Types::Boolean>
+
+=item L<Class::Meta::Types::Numeric|Class::Meta::Types::Numeric>
+
+=back
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (c) 2002-2005, David Wheeler. All Rights Reserved.
+
+This module is free software; you can redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=cut
Added: packages/libclass-meta-perl/branches/upstream/current/lib/Class/Meta.pm
===================================================================
--- packages/libclass-meta-perl/branches/upstream/current/lib/Class/Meta.pm 2006-01-04 09:19:20 UTC (rev 1847)
+++ packages/libclass-meta-perl/branches/upstream/current/lib/Class/Meta.pm 2006-01-04 09:24:55 UTC (rev 1848)
@@ -0,0 +1,1244 @@
+package Class::Meta;
+
+# $Id: Meta.pm 2405 2005-12-17 03:41:09Z theory $
+
+=head1 NAME
+
+Class::Meta - Class automation, introspection, and data validation
+
+=head1 SYNOPSIS
+
+Generate a class:
+
+ package MyApp::Thingy;
+ use strict;
+ use Class::Meta;
+ use Class::Meta::Types::String;
+ use Class::Meta::Types::Numeric;
+
+ BEGIN {
+ # Create a Class::Meta object for this class.
+ my $cm = Class::Meta->new( key => 'thingy' );
+
+ # Add a constructor.
+ $cm->add_constructor( name => 'new',
+ create => 1 );
+
+ # Add a couple of attributes with generated methods.
+ $cm->add_attribute( name => 'id',
+ authz => Class::Meta::READ,
+ type => 'integer',
+ required => 1,
+ default => sub { Data::UUID->new->create_str } );
+ $cm->add_attribute( name => 'name',
+ type => 'string',
+ required => 1,
+ default => undef );
+ $cm->add_attribute( name => 'age',
+ type => 'integer',
+ default => undef );
+
+ # Add a custom method.
+ $cm->add_method( name => 'chk_pass',
+ view => Class::Meta::PUBLIC );
+ $cm->build;
+ }
+
+Then use the class:
+
+ use MyApp::Thingy;
+
+ my $thingy = MyApp::Thingy->new;
+ print "ID: ", $thingy->id, $/;
+ $thingy->name('Larry');
+ print "Name: ", $thingy->name, $/;
+ $thingy->age(42);
+ print "Age: ", $thingy->age, $/;
+
+Or make use of the introspection API:
+
+ use MyApp::Thingy;
+
+ my $class = MyApp::Thingy->my_class;
+ my $thingy;
+
+ print "Examining object of class ", $class->package, $/;
+
+ print "\nConstructors:\n";
+ for my $ctor ($class->constructors) {
+ print " o ", $ctor->name, $/;
+ $thingy = $ctor->call($class->package);
+ }
+
+ print "\nAttributes:\n";
+ for my $attr ($class->attributes) {
+ print " o ", $attr->name, " => ", $attr->get($thingy), $/;
+ if ($attr->authz >= Class::Meta::SET && $attr->type eq 'string') {
+ $attr->get($thingy, 'hey there!');
+ print " Changed to: ", $attr->get($thingy), $/;
+ }
+ }
+
+ print "\nMethods:\n";
+ for my $meth ($class->methods) {
+ print " o ", $meth->name, $/;
+ $meth->call($thingy);
+ }
+
+=head1 DESCRIPTION
+
+Class::Meta provides an interface for automating the creation of Perl classes
+with attribute data type validation. It differs from other such modules in
+that it includes an introspection API that can be used as a unified interface
+for all Class::Meta-generated classes. In this sense, it is an implementation
+of the "Facade" design pattern.
+
+=head1 JUSTIFICATION
+
+One might argue that there are already too many class automation and parameter
+validation modules on CPAN. And one would be right. They range from simple
+accessor generators, such as L<Class::Accessor|Class::Accessor>, to simple
+parameter validators, such as L<Params::Validate|Params::Validate>, to more
+comprehensive systems, such as L<Class::Contract|Class::Contract> and
+L<Class::Tangram|Class::Tangram>. But, naturally, none of them could do
+exactly what I needed.
+
+What I needed was an implementation of the "Facade" design pattern. Okay, this
+isn't a facade like the GOF meant it, but it is in the respect that it
+creates classes with a common API so that objects of these classes can all be
+used identically, calling the same methods on each. This is done via the
+implementation of an introspection API. So the process of creating classes
+with Class::Meta not only creates attributes and accessors, but also creates
+objects that describe those classes. Using these descriptive objects, client
+applications can determine what to do with objects of Class::Meta-generated
+classes. This is particularly useful for user interface code.
+
+=head1 USAGE
+
+Before we get to the introspection API, let's take a look at how to create
+classes with Class::Meta. Unlike many class automation modules for Perl, the
+classes that Class::Meta builds do not inherit from Class::Meta. This frees
+you from any dependencies on the interfaces that such a base class might
+compel. For example, you can create whatever constructors you like, and name
+them whatever you like.
+
+I recommend that you create your Class::Meta classes in a C<BEGIN>
+block. Although this is not strictly necessary, it helps to ensure that the
+classes you're building are completely constructed and ready to go by the time
+compilation has completed. Creating classes with Class::Meta is easy, using
+the Class::Meta object oriented interface. Here is an example of a very simple
+class:
+
+ package MyApp::Dog;
+ use strict;
+ use Class::Meta;
+ use Class::Meta::Types::Perl;
+
+ BEGIN {
+ # Create a Class::Meta object for this class.
+ my $cm = Class::Meta->new( key => 'dog' );
+
+ # Add a constructor.
+ $cm->add_constructor( name => 'new',
+ create => 1 );
+
+ # Add an attribute.
+ $cm->add_attribute( name => 'tail',
+ type => 'scalar' );
+
+ # Add a custom method.
+ $cm->add_method( name => 'wag' );
+ $cm->build;
+ }
+
+ sub wag {
+ my $self = shift;
+ print "Wagging ", $self->tail;
+ }
+
+This simple example shows of the construction of all three types of objects
+supported by Class::Meta: constructors, attributes, and methods. Here's how
+it does it:
+
+=over 4
+
+=item *
+
+First we load Class::Meta and Class::Meta::Types::Perl. The latter module
+creates data types that can be used for attributes, including a "scalar"
+data type.
+
+=item *
+
+Second, we create a Class::Meta object. It's okay to create it within the
+C<BEGIN> block, as it won't be needed beyond that. All Class::Meta classes
+have a C<key> that uniquely identifies them across an application. If none is
+provided, the class name will be used, instead.
+
+=item *
+
+Next, we create a Class::Meta::Constructor object to describe a constructor
+method for the class. The C<create> parameter to the C<add_constructor()> method
+tells Class::Meta to create the constructor named "C<new()>".
+
+=item *
+
+Then we call C<add_attribute()> to create a single attribute, "tail". This is a
+simple scalar attribute, meaning that any scalar value can be stored in
+it. Class::Meta will create a Class::Meta::Attribute object that describes
+this attribute, and will also shortly create accessor methods for the
+attribute.
+
+=item *
+
+The C<add_method()> method constructs a Class::Meta::Method object to describe
+any methods written for the class. In this case, we've told Class::Meta that
+there will be a C<wag()> method.
+
+=item *
+
+And finally, we tell Class::Meta to build the class. This is the point at
+which all constructors and accessor methods will be created in the class. In
+this case, these include the C<new()> constructor and a C<tail()> accessor for
+the "tail" attribute. And finally, Class::Meta will install another method,
+C<my_class()>. This method will return a Class::Meta::Class object that
+describes the class, and provides the complete introspection API.
+
+=back
+
+Thus, the class the above code creates has this interface:
+
+ sub my_class;
+ sub new;
+ sub tail;
+ sub wag;
+
+=head2 Data Types
+
+By default, Class::Meta loads no data types. If you attempt to create an
+attribute without creating or loading the appropriate data type, you will
+get an error.
+
+But I didn't want to leave you out in the cold, so I created a whole bunch of
+data types to get you started. They can be loaded simply by creating the
+appropriate module. The modules are:
+
+=over 4
+
+=item L<Class::Meta::Types::Perl|Class::Meta::Types::Perl>
+
+Typical Perl data types.
+
+=over 4
+
+=item scalar
+
+Any scalar value.
+
+=item scalarref
+
+A scalar reference.
+
+=item array
+
+=item arrayref
+
+An array reference.
+
+=item hash
+
+=item hashref
+
+A hash reference.
+
+=item code
+
+=item coderef
+
+=item closure
+
+A code reference.
+
+=back
+
+=item L<Class::Meta::Types::String|Class::Meta::Types::String>
+
+=over 4
+
+=item string
+
+Attributes of this type must contain a string value. Essentially, this means
+anything other than a reference.
+
+=back
+
+=item L<Class::Meta::Types::Boolean|Class::Meta::Types::Boolean>
+
+=over 4
+
+=item boolean
+
+=item bool
+
+Attributes of this type store a boolean value. Implementation-wise, this means
+either a 1 or a 0.
+
+=back
+
+=item L<Class::Meta::Types::Numeric|Class::Meta::Types::Numeric>
+
+These data types are validated by the functions provided by
+L<Data::Types|Data::Types>.
+
+=over 4
+
+=item whole
+
+A whole number.
+
+=item integer
+
+An integer.
+
+=item decimal
+
+A decimal number.
+
+=item real
+
+A real number.
+
+=item float
+
+a floating point number.
+
+=back
+
+=back
+
+Other data types may be added in the future. See the individual data type
+modules for more information.
+
+=head2 Accessors
+
+Class::Meta supports the creation of three different types of attribute
+accessors: typical Perl single-method accessors, "affordance" accessors, and
+"semi-affordance" accessors. The single accessors are named for their
+attributes, and typically tend to look like this:
+
+ sub tail {
+ my $self = shift;
+ return $self->{tail} unless @_;
+ return $self->{tail} = shift;
+ }
+
+Although this can be an oversimplification if the data type has associated
+validation checks.
+
+Affordance accessors provide at up to two accessors for every attribute: One
+to set the value and one to retrieve the value. They tend to look like this:
+
+ sub get_tail { shift->{tail} }
+
+ sub set_tail { shift->{tail} = shift }
+
+These accessors offer a bit less overhead than the traditional Perl accessors,
+in that they don't have to check whether they're called to get or set a
+value. They also have the benefit of creating a psychological barrier to
+misuse. Since traditional Perl accessors I<can> be created as read-only or
+write-only accessors, one can't tell just by looking at them which is the
+case. The affordance accessors make this point moot, as they make clear what
+their purpose is.
+
+Semi-affordance accessors are similar to affordance accessors in that they
+provide at least two accessors for every attribute. However, the accessor that
+fetches the value is named for the attribute. Thus, they tend to look like
+this:
+
+ sub tail { shift->{tail} }
+
+ sub set_tail { shift->{tail} = shift }
+
+To get Class::Meta's data types to create affordance accessors, simply pass
+the string "affordance" to them when you load them:
+
+ use Class::Meta::Types::Perl 'affordance';
+
+Likewise, to get them to create semi-affordance accessors, pass the string
+"semi-affordance":
+
+ use Class::Meta::Types::Perl 'semi-affordance';
+
+The boolean data type is the only one that uses a slightly different approach
+to the creation of affordance accessors: It creates three of them. Assuming
+you're creating a boolean attribute named "alive", it will create these
+accessors:
+
+ sub is_alive { shift->{alive} }
+ sub set_alive_on { shift->{alive} = 1 }
+ sub set_alive_off { shift->{alive} = 0 }
+
+Incidentally, I stole the term "affordance" from Damian Conway's "Object
+Oriented Perl," pp 83-84, where he borrows it from Donald Norman.
+
+See L<Class::Meta::Type|Class::Meta::Type> for details on creating new data
+types.
+
+=head2 Introspection API
+
+Class::Meta provides four classes the make up the introspection API for
+Class::Meta-generated classes. Those classes are:
+
+=head3 L<Class::Meta::Class|Class::Meta::Class>
+
+Describes the class. Each Class::Meta-generated class has a single constructor
+object that can be retrieved by calling a class' C<my_class()> class
+method. Using the Class::Meta::Class object, you can get access to all of the
+other objects that describe the class. The relevant methods are:
+
+=over 4
+
+=item constructors
+
+Provides access to all of the Class::Meta::Constructor objects that describe
+the class' constructors, and provide indirect access to those constructors.
+
+=item attributes
+
+Provides access to all of the Class::Meta::Attribute objects that describe the
+class' attributes, and provide methods for indirectly getting and setting
+their values.
+
+=item methods
+
+Provides access to all of the Class::Meta::Method objects that describe the
+class' methods, and provide indirect execution of those constructors.
+
+=back
+
+=head3 L<Class::Meta::Constructor|Class::Meta::Constructor>
+
+Describes a class constructor. Typically a class will have only a single
+constructor, but there could be more, and client code doesn't necessarily know
+its name. Class::Meta::Constructor objects resolve these issues by describing
+all of the constructors in a class. The most useful methods are:
+
+=over 4
+
+=item name
+
+Returns the name of the constructor, such as "new".
+
+=item call
+
+Calls the constructor on an object, passing in the arguments passed to
+C<call()> itself.
+
+=back
+
+=head3 L<Class::Meta::Attribute|Class::Meta::Attribute>
+
+Describes a class attribute, including its name and data type. Attribute
+objects are perhaps the most useful Class::Meta objects, in that they can
+provide a great deal of information about the structure of a class. The most
+interesting methods are:
+
+=over 4
+
+=item name
+
+Returns the name of the attribute.
+
+=item type
+
+Returns the name of the attribute's data type.
+
+=item required
+
+Returns true if the attribute is required to have a value.
+
+=item once
+
+Returns true if the attribute value can be set to a defined value only once.
+
+=item set
+
+Sets the value of an attribute on an object.
+
+=item get
+
+Returns the value of an attribute on an object.
+
+=back
+
+=head3 L<Class::Meta::Method|Class::Meta::Method>
+
+Describes a method of a class, including its name and context (class
+vs. instance). The relevant methods are:
+
+=over 4
+
+=item name
+
+The method name.
+
+=item context
+
+The context of the method indicated by a value corresponding to either
+Class::Meta::OBJECT or Class::Meta::CLASS.
+
+=item call
+
+Calls the method, passing in the arguments passed to C<call()> itself.
+
+=back
+
+Consult the documentation of the individual classes for a complete description
+of their interfaces.
+
+=cut
+
+##############################################################################
+# Class Methods
+##############################################################################
+
+=head1 INTERFACE
+
+=head2 Class Methods
+
+=head3 default_error_handler
+
+ Class::Meta->default_error_handler($code);
+ my $default_error_handler = Class::Meta->default_error_handler;
+
+Sets the default error handler for Class::Meta classes. If no C<error_handler>
+attribute is passed to new, then this error handler will be associated with
+the new class. The default default error handler uses C<Carp::croak()> to
+handle errors.
+
+Note that if other modules are using Class::Meta that they will use your
+default error handler unless you reset the default error handler to its
+original value before loading them.
+
+=head3 handle_error
+
+ Class::Meta->handle_error($err);
+
+Uses the code reference returned by C<default_error_handler()> to handle an
+error. Used internally Class::Meta classes when no Class::Meta::Class object
+is available. Probably not useful outside of Class::Meta unless you're
+creating your own accessor generation class. Use the C<handle_error()>
+instance method in Class::Meta::Class, instead.
+
+=head3 for_key
+
+ my $class = Class::Meta->for_key($key);
+
+Returns the Class::Meta::Class object for a class by its key name. This can be
+useful in circumstances where the key has been used to track a class, and you
+need to get a handle on that class. With the class package name, you can of
+course simply call C<< $pkg->my_class >>; this method is the solution for
+getting the class object for a class key.
+
+=head3 keys
+
+ my @keys = Class::Meta->keys;
+
+Returns the keys for all Class::Meta::Class objects. The order of keys is
+not guaranteed. In scalar context, this method returns an array reference
+containing the keys.
+
+=head3 clear
+
+ Class::Meta->clear;
+ Class::Meta->clear($key);
+
+Called without arguments, C<clear> will remove all
+L<Class::Meta::Class|Class::Meta::Class> objects from memory. Called with an
+argument, C<clear> attempts to remove only that key from memory. Calling it
+with a non-existent key is a no-op.
+
+In general, you probably won't want to use this method, except perhaps in
+tests, when you might need to do funky things with your classes.
+
+=cut
+
+##############################################################################
+# Constructors #
+##############################################################################
+
+=head2 Constructors
+
+=head3 new
+
+ my $cm = Class::Meta->new( key => $key );
+
+Constructs and returns a new Class::Meta object that can then be used to
+define and build the complete interface of a class. The supported parameters
+are:
+
+=over 4
+
+=item package
+
+The package that defines the class. Defaults to the package of the code
+that calls C<new()>.
+
+=item key
+
+A key name that uniquely identifies a class within an application. Defaults to
+the value of the C<package> parameter if not specified.
+
+=item abstract
+
+A boolean indicating whether the class being defined is an abstract class. An
+abstract class, also known as a "virtual" class, is not intended to be used
+directly. No objects of an abstract class should every be created. Instead,
+classes that inherit from an abstract class must be implemented.
+
+=item trust
+
+An array reference of key names or packages that are trusted by the class.
+
+ trust => ['Foo::Bar', 'Foo::Bat'],
+
+Trusted packages and the classes that inherit from them can retrieve trusted
+attributes and methods of the class. Trusted packages need not be Class::Meta
+classes. Trusted classes do not include the declaring class by default, so if
+you want the class that declares an attribute to be able to use trusted
+attribute accessors, be sure to include it in the list of trusted packages:
+
+ trust => [__PACKAGE__, 'Foo::Bar', 'Foo::Bat'],
+
+If you need to trust a single class, you may pass in the key name or package
+of that class rather than an array reference:
+
+ trust => 'Foo::Bar',
+
+=item class_class
+
+The name of a class that inherits from Class::Meta::Class to be used to create
+all of the class objects for the class. Defaults to Class::Meta::Class.
+
+=item constructor_class
+
+The name of a class that inherits from Class::Meta::Constructor to be used to
+create all of the constructor objects for the class. Defaults to
+Class::Meta::Constructor.
+
+=item attribute_class
+
+The name of a class that inherits from Class::Meta::Attribute to be used to
+create all of the attribute objects for the class. Defaults to
+Class::Meta::Attribute.
+
+=item method_class
+
+The name of a class that inherits from Class::Meta::Method to be used to
+create all of the method objects for the class. Defaults to
+Class::Meta::Method.
+
+=item error_handler
+
+A code reference that will be used to handle errors thrown by the methods
+created for the new class. Defaults to the value returned by
+C<< Class::Meta->default_error_handler >>.
+
+=back
+
+=cut
+
+##############################################################################
+# Dependencies #
+##############################################################################
+use 5.006001;
+use strict;
+
+##############################################################################
+# Constants #
+##############################################################################
+
+# View. These determine who can get metadata objects back from method calls.
+use constant PRIVATE => 0x01;
+use constant PROTECTED => 0x02;
+use constant TRUSTED => 0x03;
+use constant PUBLIC => 0x04;
+
+# Authorization. These determine what kind of accessors (get, set, both, or
+# none) are available for a given attribute or method.
+use constant NONE => 0x01;
+use constant READ => 0x02;
+use constant WRITE => 0x03;
+use constant RDWR => 0x04;
+
+# Method generation. These tell Class::Meta which accessors to create. Use
+# NONE above for NONE. These will use the values in the authz argument by
+# default. They're separate because sometimes an accessor needs to be built
+# by hand, rather than custom-generated by Class::Meta, and the
+# authorization needs to reflect that.
+use constant GET => READ;
+use constant SET => WRITE;
+use constant GETSET => RDWR;
+
+# Method and attribute context.
+use constant CLASS => 0x01;
+use constant OBJECT => 0x02;
+
+##############################################################################
+# Dependencies that rely on the above constants #
+##############################################################################
+use Class::Meta::Type;
+use Class::Meta::Class;
+use Class::Meta::Constructor;
+use Class::Meta::Attribute;
+use Class::Meta::Method;
+
+##############################################################################
+# Package Globals #
+##############################################################################
+our $VERSION = "0.52";
+
+##############################################################################
+# Private Package Globals
+##############################################################################
+{
+ my (%classes, %keys);
+ my $error_handler = sub {
+ require Carp;
+ our @CARP_NOT = qw(Class::Meta
+ Class::Meta::Attribute
+ Class::Meta::Constructor
+ Class::Meta::Method
+ Class::Meta::Type
+ Class::Meta::Types::Numeric
+ Class::Meta::Types::String
+ Class::Meta::AccessorBuilder);
+ # XXX Make sure Carp doesn't point to Class/Meta/Constructor.pm when
+ # an exception is thrown by Class::Meta::AccessorBuilder. I have no
+ # idea why this is necessary for AccessorBuilder but nowhere else!
+ # Damn Carp.
+ @Class::Meta::AccessorBuilder::CARP_NOT = @CARP_NOT
+ if caller(1) eq 'Class::Meta::AccessorBuilder';
+ Carp::croak(@_);
+ };
+
+ sub default_error_handler {
+ shift;
+ return $error_handler unless @_;
+ $error_handler->("Error handler must be a code reference")
+ unless ref $_[0] eq 'CODE';
+ return $error_handler = shift;
+ }
+
+ sub handle_error {
+ shift;
+ $error_handler->(@_);
+ }
+
+ sub for_key { $keys{$_[1]} }
+
+ sub keys { wantarray ? keys %keys : [keys %keys] }
+
+ sub clear { shift; @_ ? delete $keys{+shift} : undef %keys }
+
+ sub new {
+ my $pkg = shift;
+
+ # Make sure we can get all the arguments.
+ $error_handler->("Odd number of parameters in call to new() when named "
+ . "parameters were expected" ) if @_ % 2;
+ my %p = @_;
+
+ # Class defaults to caller. Key defaults to class.
+ $p{package} ||= caller;
+ $p{key} ||= $p{package};
+
+ # Configure the error handler.
+ if (exists $p{error_handler}) {
+ $error_handler->("Error handler must be a code reference")
+ unless ref $p{error_handler} eq 'CODE';
+ } else {
+ $p{error_handler} = $pkg->default_error_handler;
+ }
+
+ # Check to make sure we haven't created this class already.
+ $p{error_handler}->("Class object for class '$p{package}' "
+ . "already exists")
+ if $classes{$p{package}};
+
+ $p{class_class} ||= 'Class::Meta::Class';
+ $p{constructor_class} ||= 'Class::Meta::Constructor';
+ $p{attribute_class} ||= 'Class::Meta::Attribute';
+ $p{method_class} ||= 'Class::Meta::Method';
+
+ # Instantiate and cache Class object.
+ $keys{$p{key}} = $classes{$p{package}} = $p{class_class}->new(\%p);
+
+ # Copy its parents' attributes and return.
+ $classes{$p{package}}->_inherit( \%classes, 'attr');
+
+ # Return!
+ return bless { package => $p{package} }, ref $pkg || $pkg;
+ }
+
+
+##############################################################################
+# add_constructor()
+
+=head3 add_constructor
+
+ $cm->add_constructor( name => 'new',
+ create => 1 );
+
+Creates and returns a Class::Meta::Constructor object that describes a
+constructor for the class. The supported parameters are:
+
+=over 4
+
+=item name
+
+The name of the constructor. The name must consist of only alphanumeric
+characters or "_".
+
+=item label
+
+A label for the constructor. Generally used for displaying its name in a user
+interface. Optional.
+
+=item desc
+
+A description of the constructor. Possibly useful for displaying help text in
+a user interface. Optional.
+
+=item view
+
+The visibility of the constructor. The possible values are defined by the
+following constants:
+
+=over 4
+
+=item Class::Meta::PUBLIC
+
+Can be used by any client.
+
+=item Class::Meta::PRIVATE
+
+Can only be used by the declaring class.
+
+=item Class::Meta::TRUSTED
+
+Can only be used by the classes specified by the C<trust> parameter to
+C<new()>.
+
+=item Class::Meta::PROTECTED
+
+Can only be used by the declaring class or by classes that inherit from it.
+
+=back
+
+Defaults to Class::Meta::PUBLIC if not defined.
+
+=item caller
+
+A code reference that calls the constructor. Defaults to a code reference that
+calls a method with the name provided by the C<name> attribute on the class
+being defined.
+
+=back
+
+=cut
+
+ sub add_constructor {
+ my $class = $classes{ shift->{package} };
+ push @{$class->{build_ctor_ord}},
+ $class->{constructor_class}->new($class, @_);
+ return $class->{build_ctor_ord}[-1];
+ }
+
+##############################################################################
+# add_attribute()
+
+=head3 add_attribute
+
+ $cm->add_attribute( name => 'tail',
+ type => 'scalar' );
+
+Creates and returns a Class::Meta::Attribute object that describes an
+attribute of the class. The supported parameters are:
+
+=over 4
+
+=item type
+
+The data type of the attribute. See L</"Data Types"> for some possible values
+for this parameter. Required.
+
+=item name
+
+The name of the attribute. The name must consist of only alphanumeric
+characters or "_". Required.
+
+=item required
+
+A boolean value indicating whether the attribute is required to have a value.
+Defaults to false.
+
+=item once
+
+A boolean value indicating whether the attribute can be set to a defined value
+only once. Defaults to false.
+
+=item label
+
+A label for the attribute. Generally used for displaying its name in a user
+interface. Optional.
+
+=item desc
+
+A description of the attribute. Possibly useful for displaying help text in a
+user interface. Optional.
+
+=item view
+
+The visibility of the attribute. See the description of the C<view> parameter
+to C<add_constructor> for a description of its value.
+
+=item authz
+
+The authorization of the attribute. This value indicates whether it is
+read-only, write-only, read/write, or inaccessible. The possible values are
+defined by the following constants:
+
+=over 4
+
+=item Class::Meta::READ
+
+=item Class::Meta::WRITE
+
+=item Class::Meta::RDWR
+
+=item Class::Meta::NONE
+
+=back
+
+Defaults to Class::Meta::RDWR if not defined.
+
+=item create
+
+Indicates what type of accessor or accessors are to be created for the
+attribute.
+
+=over 4
+
+=item Class::Meta::GET
+
+Create read-only accessor(s).
+
+=item Class::Meta::SET
+
+Create write-only accessor(s).
+
+=item Class::Meta::GETSET
+
+Create read/write accessor(s).
+
+=item Class::Meta::NONE
+
+Create no accessors.
+
+=back
+
+If not unspecified, the value of the C<create> parameter will correspond to
+the value of the C<authz> parameter like so:
+
+ authz create
+ ------------------
+ READ => GET
+ WRITE => SET
+ RDWR => GETSET
+ NONE => NONE
+
+The C<create> parameter differs from the C<authz> parameter in case you've
+taken it upon yourself to create some accessors, and therefore don't need
+Class::Meta to do so. For example, if you were using standard Perl-style
+accessors, and needed to do something a little different by coding your own
+accessor, you'd specify it like this:
+
+ $cm->add_attribute( name => $name,
+ type => $type,
+ authz => Class::Meta::RDWR,
+ create => Class::Meta::NONE );
+
+Just be sure that your custom accessor compiles before you call
+C<< $cm->build >> so that Class::Meta::Attribute can get a handle on it for
+its C<get()> and/or C<set()> methods.
+
+=item context
+
+The context of the attribute. This indicates whether it's a class attribute or
+an object attribute. The possible values are defined by the following
+constants:
+
+=over 4
+
+=item Class::Meta::CLASS
+
+=item Class::Meta::OBJECT
+
+=back
+
+=item default
+
+The default value for the attribute, if any. This may be either a literal
+value or a code reference that will be executed to generate a default value.
+
+=item override
+
+If an attribute being added to a class has the same name as an attribute in a
+parent class, Class::Meta will normally throw an exception. However, in some
+cases you might want to override an attribute in a parent class to change its
+properties. In such a case, pass a true value to the C<override> parameter to
+override the attribute and avoid the exception.
+
+=back
+
+=cut
+
+ sub add_attribute {
+ my $class = $classes{ shift->{package} };
+ push @{$class->{build_attr_ord}},
+ $class->{attribute_class}->new($class, @_);
+ return $class->{build_attr_ord}[-1];
+ }
+
+##############################################################################
+# add_method()
+
+=head3 add_method
+
+ $cm->add_method( name => 'wag' );
+
+Creates and returns a Class::Meta::Method object that describes a method of
+the class. The supported parameters are:
+
+=over 4
+
+=item name
+
+The name of the method. The name must consist of only alphanumeric
+characters or "_".
+
+=item label
+
+A label for the method. Generally used for displaying its name in a user
+interface. Optional.
+
+=item desc
+
+A description of the method. Possibly useful for displaying help text in a
+user interface. Optional.
+
+=item view
+
+The visibility of the method. See the description of the C<view> parameter to
+C<add_constructor> for a description of its value.
+
+=item code
+
+You can implicitly define the method in your class by passing a code reference
+via teh C<code> parameter. Once C<build()> is called,
+L<Kinetic::Meta::Method|Kinetic::Meta::Method> will install the method into
+the package for which the Class::Meta object was defined, and with the name
+specified via the C<name> parameter. This can make it easy to declare an
+entire class in a single Class::Meta declaration.
+
+=item context
+
+The context of the method. This indicates whether it's a class method or an
+object method. See the description of the C<context> parameter to C<add_attribute>
+for a description of its value.
+
+=item caller
+
+A code reference that calls the method. This code reference will be be used by
+the C<call()> method of L<Class::Meta::Method|Class::Meta::Method> to execute
+the method on behalf of an object. Defaults to a code reference that calls a
+method with the name provided by the C<name> attribute on the class being
+defined.
+
+=item args
+
+A description of the arguments to the method. This can be anything you like,
+but I recommend something like a string for a single argument, an array
+reference for a list of arguments, or a hash reference for parameter
+arguments.
+
+=item returns
+
+A string describing the return value or values of the method.
+
+=back
+
+=cut
+
+ sub add_method {
+ my $class = $classes{ shift->{package} };
+ push @{$class->{build_meth_ord}},
+ $class->{method_class}->new($class, @_);
+ return $class->{build_meth_ord}[-1];
+ }
+
+##############################################################################
+# Instance Methods #
+##############################################################################
+
+=head2 Instance Methods
+
+=head3 class
+
+ my $class = $cm->class;
+
+Returns the instance of the Class::Meta::Class object that will be used to
+provide the introspection API for the class being generated.
+
+=cut
+
+ # Simple accessor.
+ sub class { $classes{ $_[0]->{package} } }
+
+##############################################################################
+# build()
+
+=head3 build
+
+ $cm->build;
+
+Builds the class defined by the Class::Meta object, including the
+C<my_class()> class method, and all requisite constructors and accessors.
+
+=cut
+
+ sub build {
+ my $self = shift;
+ my $class = $classes{ $self->{package} };
+
+ # Build the attribute accessors.
+ if (my $attrs = delete $class->{build_attr_ord}) {
+ $_->build($class) for @$attrs;
+ }
+
+ # Build the constructors.
+ if (my $ctors = delete $class->{build_ctor_ord}) {
+ $_->build(\%classes) for @$ctors;
+ }
+
+ # Build the methods.
+ if (my $meths = delete $class->{build_meth_ord}) {
+ $_->build(\%classes) for @$meths;
+ }
+
+ # Build the class; it needs to get at the data added by the above
+ # calls to build() methods.
+ $class->build(\%classes);
+
+ # Build the Class::Meta::Class accessor and key shortcut.
+ no strict 'refs';
+ *{"$class->{package}::my_class"} = sub { $class };
+
+ return $self;
+ }
+}
+
+1;
+__END__
+
+=head1 TO DO
+
+=over 4
+
+=item *
+
+Make class attribute accessors behave as they do in Class::Data::Inheritable.
+
+=item *
+
+Modify class attribute accessors so that they are thread safe. This will
+involve sharing the attributes across threads, and locking them before
+changing their values. If they've also been made to behave as they do in
+Class::Data::Inheritable, we'll have to figure out a way to make it so that
+newly generated accessors for subclasses are shared between threads, too. This
+may not be easy.
+
+=back
+
+=head1 BUGS
+
+Please send bug reports to <bug-class-meta at rt.cpan.org> or report them via the
+CPAN Request Tracker at L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Class-Meta>.
+
+=head1 AUTHOR
+
+David Wheeler <david at kineticode.com>
+
+=head1 SEE ALSO
+
+Other classes of interest within the Class::Meta distribution include:
+
+=over 4
+
+=item L<Class::Meta::Class|Class::Meta::Class>
+
+=item L<Class::Meta::Constructor|Class::Meta::Constructor>
+
+=item L<Class::Meta::Attribute|Class::Meta::Attribute>
+
+=item L<Class::Meta::Method|Class::Meta::Method>
+
+=item L<Class::Meta::Type|Class::Meta::Type>
+
+=item L<Class::Meta::Types::Perl|Class::Meta::Types::Perl>
+
+=item L<Class::Meta::Types::String|Class::Meta::Types::String>
+
+=item L<Class::Meta::Types::Boolean|Class::Meta::Types::Boolean>
+
+=item L<Class::Meta::Types::Numeric|Class::Meta::Types::Numeric>
+
+=back
+
+For comparative purposes, you might also want to check out these fine modules:
+
+=over
+
+=item L<Class::Accessor|Class::Accessor>
+
+Accessor and constructor automation.
+
+=item L<Params::Validate|Params::Validate>
+
+Parameter validation.
+
+=item L<Class::Contract|Class::Contract>
+
+Design by contract.
+
+=item L<Class::Tangram|Class::Tangram>
+
+Accessor automation and data validation for Tangram applications.
+
+=item L<Class::Maker|Class::Maker>
+
+An ambitious yet underdocumented module that also manages accessor and
+constructor generation, data validation, and provides a reflection API. It
+also supports serialization.
+
+=back
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (c) 2002-2005, David Wheeler. All Rights Reserved.
+
+This module is free software; you can redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=cut
Added: packages/libclass-meta-perl/branches/upstream/current/t/attr.t
===================================================================
--- packages/libclass-meta-perl/branches/upstream/current/t/attr.t 2006-01-04 09:19:20 UTC (rev 1847)
+++ packages/libclass-meta-perl/branches/upstream/current/t/attr.t 2006-01-04 09:24:55 UTC (rev 1848)
@@ -0,0 +1,156 @@
+#!/usr/bin/perl
+
+# $Id: attr.t 682 2004-09-28 05:59:10Z theory $
+
+##############################################################################
+# Set up the tests.
+##############################################################################
+
+use strict;
+use Test::More tests => 44;
+
+##############################################################################
+# Create a simple class.
+##############################################################################
+
+package Class::Meta::TestPerson;
+use strict;
+
+# Make sure we can load Class::Meta.
+BEGIN {
+ main::use_ok( 'Class::Meta' );
+ main::use_ok( 'Class::Meta::Types::String' );
+}
+
+BEGIN {
+ # Import Test::More functions into this package.
+ Test::More->import;
+
+ # Create a new Class::Meta object.
+ ok( my $c = Class::Meta->new(key => 'person'),
+ "Create CM object" );
+ isa_ok($c, 'Class::Meta');
+
+ # Create an attribute.
+ sub inst { bless {} }
+ ok( my $attr = $c->add_attribute( name => 'inst',
+ type => 'string',
+ desc => 'The inst attribute',
+ label => 'inst Attribute',
+ view => Class::Meta::PUBLIC ),
+ "Create 'inst' attr");
+ isa_ok($attr, 'Class::Meta::Attribute');
+
+ # Test its accessors.
+ is( $attr->name, "inst", "Check inst name" );
+ is( $attr->desc, "The inst attribute", "Check inst desc" );
+ is( $attr->label, "inst Attribute", "Check inst label" );
+ is( $attr->type, "string", "Check inst type" );
+ ok( $attr->view == Class::Meta::PUBLIC, "Check inst view" );
+
+ # Okay, now test to make sure that an attempt to create a attribute
+ # directly fails.
+ eval { my $attr = Class::Meta::Attribute->new };
+ ok( my $err = $@, "Get attribute construction exception");
+ like( $err, qr/Package 'Class::Meta::TestPerson' cannot create/,
+ "Caught proper exception");
+
+ # Now try it without a name.
+ eval{ $c->add_attribute() };
+ ok( $err = $@, "Caught no name exception");
+ like( $err, qr/Parameter 'name' is required in call to new/,
+ "Caught proper no name exception");
+
+ # Try a duplicately-named attribute.
+ eval{ $c->add_attribute(name => 'inst') };
+ ok( $err = $@, "Caught dupe name exception");
+ like( $err, qr/Attribute 'inst' already exists in class/,
+ "Caught proper dupe name exception");
+
+ # Try a couple of bogus visibilities.
+ eval { $c->add_attribute( name => 'new_attr',
+ view => 25) };
+ ok( $err = $@, "Caught bogus view exception");
+ like( $err, qr/Not a valid view parameter: '25'/,
+ "Caught proper bogus view exception");
+ eval { $c->add_attribute( name => 'new_attr',
+ view => 10) };
+ ok( $err = $@, "Caught another bogus view exception");
+ like( $err, qr/Not a valid view parameter: '10'/,
+ "Caught another proper bogus view exception");
+
+ # Try a bogus caller.
+ eval { $c->add_method( name => 'new_inst',
+ caller => 'foo' ) };
+ ok( $err = $@, "Caught bogus caller exception");
+ like( $err, qr/Parameter caller must be a code reference/,
+ "Caught proper bogus caller exception");
+
+ # Now test all of the defaults.
+ sub new_attr { 22 }
+ ok( $attr = $c->add_attribute( name => 'new_attr' ), "Create 'new_attr'" );
+ isa_ok($attr, 'Class::Meta::Attribute');
+
+ # Test its accessors.
+ is( $attr->name, "new_attr", "Check new_attr name" );
+ ok( ! defined $attr->desc, "Check new_attr desc" );
+ ok( ! defined $attr->label, "Check new_attr label" );
+ ok( $attr->view == Class::Meta::PUBLIC, "Check new_attr view" );
+}
+
+# Now try subclassing Class::Meta.
+
+package Class::Meta::SubClass;
+use base 'Class::Meta';
+sub add_attribute {
+ Class::Meta::Attribute->new( shift->SUPER::class, @_);
+}
+
+package Class::Meta::AnotherTest;
+use strict;
+
+BEGIN {
+ # Import Test::More functions into this package.
+ Test::More->import;
+
+ # Create a new Class::Meta object.
+ ok( my $c = Class::Meta::SubClass->new
+ (another => __PACKAGE__), "Create subclassed CM object" );
+ isa_ok($c, 'Class::Meta');
+ isa_ok($c, 'Class::Meta::SubClass');
+
+ sub foo_attr { bless {} }
+ ok( my $attr = $c->add_attribute( name => 'foo_attr'),
+ 'Create subclassed foo_attr' );
+
+ isa_ok($attr, 'Class::Meta::Attribute');
+
+ # Test its accessors.
+ is( $attr->name, "foo_attr", "Check new foo_attr name" );
+ ok( ! defined $attr->desc, "Check new foo_attr desc" );
+ ok( ! defined $attr->label, "Check new foo_attr label" );
+ ok( $attr->view == Class::Meta::PUBLIC, "Check new foo_attr view" );
+}
+
+##############################################################################
+# Now try subclassing Class::Meta::Attribute.
+package Class::Meta::Attribute::Sub;
+use base 'Class::Meta::Attribute';
+
+# Make sure we can override new and build.
+sub new { shift->SUPER::new(@_) }
+sub build { shift->SUPER::build(@_) }
+
+sub foo { shift->{foo} }
+
+package main;
+ok( my $cm = Class::Meta->new(
+ attribute_class => 'Class::Meta::Attribute::Sub',
+), "Create Class" );
+ok( my $attr = $cm->add_attribute(name => 'foo', foo => 'bar'),
+ "Add foo attribute" );
+isa_ok($attr, 'Class::Meta::Attribute::Sub');
+isa_ok($attr, 'Class::Meta::Attribute');
+is( $attr->name, 'foo', "Check an attibute");
+is( $attr->foo, 'bar', "Check added attribute" );
+
Added: packages/libclass-meta-perl/branches/upstream/current/t/base.t
===================================================================
--- packages/libclass-meta-perl/branches/upstream/current/t/base.t 2006-01-04 09:19:20 UTC (rev 1847)
+++ packages/libclass-meta-perl/branches/upstream/current/t/base.t 2006-01-04 09:24:55 UTC (rev 1848)
@@ -0,0 +1,362 @@
+#!perl -w
+
+# $Id: base.t 1889 2005-07-13 01:31:50Z curtis $
+
+##############################################################################
+# Set up the tests.
+##############################################################################
+
+use strict;
+#use Test::More tests => 130;
+use Test::More 'no_plan';
+
+##############################################################################
+# Create a simple class.
+##############################################################################
+
+package Class::Meta::TestPerson;
+use strict;
+
+BEGIN {
+ main::use_ok('Class::Meta');
+ main::use_ok('Class::Meta::Types::Numeric');
+ main::use_ok('Class::Meta::Types::String');
+}
+
+BEGIN {
+ my $c = Class::Meta->new(
+ key => 'person',
+ package => __PACKAGE__,
+ name => 'Class::Meta::TestPerson Class',
+ desc => 'Special person class just for testing Class::Meta.',
+ );
+
+ # Add a constructor.
+ $c->add_constructor( name => 'new',
+ create => 1 );
+
+ # Add a couple of attributes with created methods.
+ $c->add_attribute( name => 'id',
+ view => Class::Meta::PUBLIC,
+ authz => Class::Meta::READ,
+ create => Class::Meta::GET,
+ type => 'integer',
+ label => 'ID',
+ desc => "The person object's ID.",
+ required => 1,
+ default => 12,
+ );
+ $c->add_attribute( name => 'name',
+ view => Class::Meta::PUBLIC,
+ authz => Class::Meta::RDWR,
+ create => Class::Meta::GETSET,
+ type => 'string',
+ label => 'Name',
+ desc => "The person's name.",
+ required => 1,
+ default => '',
+ );
+ $c->add_attribute( name => 'age',
+ view => Class::Meta::PUBLIC,
+ authz => Class::Meta::RDWR,
+ create => Class::Meta::GETSET,
+ type => 'integer',
+ label => 'Age',
+ desc => "The person's age.",
+ required => 0,
+ default => undef,
+ );
+
+ # Our custom accessor for goop.
+ sub goop { shift->{goop} }
+
+ # Add an attribute for which we will create the accessor method.
+ $c->add_attribute( name => 'goop',
+ view => Class::Meta::PUBLIC,
+ authz => Class::Meta::READ,
+ create => Class::Meta::NONE,
+ type => 'string',
+ label => 'Goop',
+ desc => "The person's gooposity.",
+ required => 0,
+ default => 'very',
+ );
+
+ # Add a class attribute.
+ $c->add_attribute( name => 'count',
+ type => 'integer',
+ label => 'Count',
+ context => Class::Meta::CLASS,
+ default => 0,
+ );
+
+ # Add a couple of custom methods.
+ $c->add_method( name => 'chk_pass',
+ view => Class::Meta::PUBLIC,
+ args => ['string', 'string'],
+ returns => 'bool',
+ );
+
+ $c->add_method( name => 'shame',
+ view => Class::Meta::PUBLIC,
+ returns => 'person',
+ );
+
+ $c->build;
+
+ my $d = Class::Meta->new(
+ key => 'green_monkey',
+ package => 'Class::Meta::GreenMonkey',
+ name => 'Class::Meta::GreenMonkey Class',
+ desc => 'Special monkey class just for testing Class::Meta.',
+ );
+
+ # Add a constructor.
+ $d->add_constructor( name => 'new',
+ create => 1 );
+
+ # Add a couple of attributes with created methods.
+ $d->add_attribute( name => 'id',
+ view => Class::Meta::PUBLIC,
+ authz => Class::Meta::READ,
+ create => Class::Meta::GET,
+ type => 'integer',
+ label => 'ID',
+ desc => "The monkey object's ID.",
+ required => 1,
+ default => 12,
+ );
+ $d->build;
+}
+
+sub chk_pass {
+ my ($self, $un, $pw) = @_;
+ return $un eq 'larry' && $pw eq 'yrral' ? 1 : 0;
+}
+
+sub shame { shift }
+
+##############################################################################
+# Do the tests.
+##############################################################################
+
+package main;
+# Instantiate a base class object and test its accessors.
+ok( my $t = Class::Meta::TestPerson->new, 'Class::Meta::TestPerson->new');
+is( $t->id, 12, 'id is 12');
+eval { $t->id(1) };
+
+# Test string.
+ok( $t->name('David'), 'name to "David"' );
+is( $t->name, 'David', 'name is "David"' );
+eval { $t->name([]) };
+ok( my $err = $@, 'name to array ref croaks' );
+like( $err, qr/^Value .* is not a valid string/, 'correct string exception' );
+
+# Grab its metadata object.
+ok( my $class = $t->my_class, "Get Class::Meta::Class object" );
+
+# Test the is_a() method.
+ok( $class->is_a('Class::Meta::TestPerson'), 'Class is_a TestPerson');
+
+# Test the key methods.
+is( $class->key, 'person', 'Key is correct');
+
+# Test the package methods.
+is($class->package, 'Class::Meta::TestPerson', 'package()');
+
+# Test the name methods.
+is( $class->name, 'Class::Meta::TestPerson Class', "Name is correct");
+
+# Test the description methods.
+is( $class->desc, 'Special person class just for testing Class::Meta.',
+ "Description is correct");
+
+# Test attributes().
+ok(my @attributes = $class->attributes, "Get attributes from attributes()" );
+is( scalar @attributes, 5, "Five attributes from attributes()" );
+isa_ok($attributes[0], 'Class::Meta::Attribute',
+ "First object is a attribute object" );
+isa_ok($attributes[1], 'Class::Meta::Attribute',
+ "Second object is a attribute object" );
+isa_ok($attributes[2], 'Class::Meta::Attribute',
+ "Third object is a attribute object" );
+isa_ok($attributes[3], 'Class::Meta::Attribute',
+ "Fourth object is a attribute object" );
+is( $attributes[0]->class, $class, "Check attribute class" );
+
+# Get specific attributes.
+ok( @attributes = $class->attributes(qw(age name)), 'Get specific attributes' );
+is( scalar @attributes, 2, "Two specific attributes from attributes()" );
+isa_ok($attributes[0], 'Class::Meta::Attribute', "Attribute object type" );
+
+is( $attributes[0]->name, 'age', 'First attr name' );
+is( $attributes[1]->name, 'name', 'Second attr name' );
+
+# Check the attributes of the "ID" attribute object.
+ok( my $p = $class->attributes('id'), "Get ID attribute object" );
+is( $p->name, 'id', 'ID name' );
+is( $p->desc, "The person object's ID.", 'ID description' );
+is( $p->view, Class::Meta::PUBLIC, 'ID view' );
+is( $p->authz, Class::Meta::READ, 'ID authorization' );
+is( $p->type, 'integer', 'ID type' );
+is( $p->label, 'ID', 'ID label' );
+ok( $p->required, "ID required" );
+is( $p->default, 12, "ID default" );
+
+# Test the attribute accessors.
+is( $p->get($t), 12, 'ID is 12' );
+# ID is READ, so we shouldn't be able to set it.
+eval { $p->set($t, 10) };
+ok( $err = $@, "Set val failure" );
+like( $err, qr/Cannot set attribute 'id/, 'set val exception' );
+
+# Check the attributes of the "Name" attribute object.
+ok( $p = $class->attributes('name'), "Get name attribute" );
+is( $p->name, 'name', 'Name name' );
+is( $p->desc, "The person's name.", 'Name description' );
+is( $p->view, Class::Meta::PUBLIC, 'Name view' );
+is( $p->authz, Class::Meta::RDWR, 'Name authorization' );
+is( $p->type, 'string', 'Name type' );
+is( $p->label, 'Name', 'Name label' );
+ok( $p->required, "Name required" );
+is( $p->default, '', "Name default" );
+
+# Test the attribute accessors.
+is( $p->get($t), 'David', 'Name get' );
+ok( $p->set($t, 'Larry'), 'Name set' );
+is( $p->get($t), 'Larry', 'New Name get' );
+is( $t->name, 'Larry', 'Object name');
+ok( $t->name('Damian'), 'Object name' );
+is( $p->get($t), 'Damian', 'Final Name get' );
+
+# Check the attributes of the "Age" attribute object.
+ok( $p = $class->attributes('age'), "Get age attribute" );
+is( $p->name, 'age', 'Age name' );
+is( $p->desc, "The person's age.", 'Age description' );
+is( $p->view, Class::Meta::PUBLIC, 'Age view' );
+is( $p->authz, Class::Meta::RDWR, 'Age authorization' );
+is( $p->type, 'integer', 'Age type' );
+is( $p->label, 'Age', 'Age label' );
+ok( $p->required == 0, "Age required" );
+is( $p->default, undef, "Age default" );
+
+# Test the age attribute accessors.
+ok( ! defined $p->get($t), 'Age get' );
+ok( $p->set($t, 10), 'Age set' );
+is( $p->get($t), 10, 'New Age get' );
+ok( $t->age == 10, 'Object age');
+ok( $t->age(22), 'Object age' );
+is( $p->get($t), 22, 'Final Age get' );
+
+# Check the attributes of the "Count" attribute object.
+ok( $p = $class->attributes('count'), "Get count attribute" );
+is( $p->name, 'count', 'Count name' );
+is( $p->desc, undef, 'Count description' );
+is( $p->view, Class::Meta::PUBLIC, 'Count view' );
+is( $p->authz, Class::Meta::RDWR, 'Count authorization' );
+is( $p->type, 'integer', 'Count type' );
+is( $p->label, 'Count', 'Count label' );
+is( $p->required, 0, "Count required" );
+is( $p->default, 0, "Count default" );
+
+# Test the count attribute accessors.
+is( $p->get($t), 0, 'Count get' );
+ok( $p->set($t, 10), 'Count set' );
+is( $p->get($t), 10, 'New Count get' );
+is( $t->count, 10, 'Object count');
+ok( $t->count(22), 'Set object count' );
+is( $p->get($t), 22, 'Final Count get' );
+
+# Make sure they also work as class attributes.
+is( Class::Meta::TestPerson->count, 22, 'Class count' );
+ok( Class::Meta::TestPerson->count(35), 'Set class count' );
+is( Class::Meta::TestPerson->count, 35, 'Class count again' );
+is( $t->count, 35, 'Object count after class');
+is( $p->get($t), 35, 'Final Count get after class' );
+
+# Test goop attribute accessor.
+is( $t->goop, 'very', "Got goop" );
+$t->goop('feh');
+is( $t->goop, 'very', "Still got goop" );
+ok( $p = $class->attributes('goop'), "Get goop attribute object" );
+is( $p->get($t), 'very', "Got attribute goop" );
+eval { $p->set($t, 'feh') };
+ok( $@, "Can't set goop" );
+is( $p->get($t), 'very', "Still got attribute goop" );
+
+# Test methods().
+ok( my @methods = $class->methods, "Get method objects" );
+is( scalar @methods, 2, 'Number of methods from methods()' );
+isa_ok($methods[0], 'Class::Meta::Method',
+ "First object is a method object" );
+isa_ok($methods[1], 'Class::Meta::Method',
+ "Second object is a method object" );
+
+# Check the order in which they're returned.
+is( $methods[0]->name, 'chk_pass', 'First method' );
+is( $methods[1]->name, 'shame', 'Second method' );
+is( $methods[0]->class, $class, "Check method class" );
+is_deeply( $methods[0]->args, ['string', 'string'], "Check method args" );
+is( $methods[0]->returns, 'bool', "Check method returns" );
+is( $methods[1]->args, undef, 'Second specific method args' );
+is( $methods[1]->returns, 'person', 'Second specific method returns' );
+
+# Get a few specific methods.
+ok( @methods = $class->methods(qw(shame chk_pass)),
+ 'Grab specific methods.');
+is( scalar @methods, 2, 'Two methods from methods()' );
+is( $methods[0]->name, 'shame', 'First specific method' );
+is( $methods[1]->name, 'chk_pass', 'Second specific method' );
+
+# Check out the chk_pass method.
+ok( my $m = $class->methods('chk_pass'), "Get chk_pass method object" );
+is( $m->name, 'chk_pass', 'chk_pass name' );
+ok( $m->call($t, 'larry', 'yrral') == 1, 'Call chk_pass returns true' );
+ok( $m->call($t, 'larry', 'foo') == 0, 'Call chk_pass returns false' );
+
+# Test constructors().
+ok( my @constructors = $class->constructors, "Get constructor objects" );
+is( scalar @constructors, 1, 'Number of constructors from constructors()' );
+isa_ok($constructors[0], 'Class::Meta::Constructor',
+ "First object is a constructor object" );
+
+# Check the order in which they're returned.
+is( $constructors[0]->name, 'new', 'Check new constructor name' );
+is( $constructors[0]->class, $class, "Check constructor class" );
+
+# Get a few specific constructors.
+ok( @constructors = $class->constructors(qw(new)),
+ 'Grab specific constructor.');
+is( scalar @constructors, 1, 'Two constructors from constructors()' );
+is( $constructors[0]->name, 'new', 'Check specific constructor' );
+
+# Try getting the class object via the for_key() class method.
+is( Class::Meta->for_key($class->key), $class, "for_key returns class" );
+
+# Try getting a list of all class object keys
+can_ok( 'Class::Meta', 'keys' );
+ok( my $keys = Class::Meta->keys, 'Calling keys in scalar context should succeed');
+is( ref $keys, 'ARRAY', 'And it should return an array ref');
+@$keys = sort @$keys;
+is_deeply($keys, [qw/green_monkey person/], 'And keys should return the correct keys');
+
+ok( my @keys = Class::Meta->keys, 'Calling keys in list context should succeed');
+is(scalar @keys, 2, 'And it should return the correct number of keys');
+ at keys = sort @keys;
+is_deeply(\@keys, [qw/green_monkey person/], 'And keys should return the correct keys');
+
+# try deleting the class object classes
+can_ok('Class::Meta', 'clear');
+Class::Meta->clear('green_monkey');
+ at keys = Class::Meta->keys;
+is_deeply(\@keys, ['person'], 'And it should delete a key if provided with one');
+
+Class::Meta->clear('no_such_key');
+ at keys = Class::Meta->keys;
+is_deeply(\@keys, ['person'], 'But deleting a non-existent key should be a no-op');
+
+Class::Meta->clear;
+ at keys = Class::Meta->keys;
+is_deeply(\@keys, [], 'And calling it without arguments should remove all keys');
+__END__
Added: packages/libclass-meta-perl/branches/upstream/current/t/chk_types.t
===================================================================
--- packages/libclass-meta-perl/branches/upstream/current/t/chk_types.t 2006-01-04 09:19:20 UTC (rev 1847)
+++ packages/libclass-meta-perl/branches/upstream/current/t/chk_types.t 2006-01-04 09:24:55 UTC (rev 1848)
@@ -0,0 +1,460 @@
+#!/usr/bin/perl -w
+
+# $Id: chk_types.t 682 2004-09-28 05:59:10Z theory $
+
+##############################################################################
+# Set up the tests.
+##############################################################################
+
+package Class::Meta::Testing;
+
+use strict;
+use Test::More tests => 195;
+BEGIN {
+ $SIG{__DIE__} = \&Carp::confess;
+ use_ok( 'Class::Meta');
+ use_ok( 'Class::Meta::Type');
+ use_ok( 'Class::Meta::Types::Numeric');
+ use_ok( 'Class::Meta::Types::Perl');
+ use_ok( 'Class::Meta::Types::String');
+ use_ok( 'Class::Meta::Types::Boolean');
+ our @ISA = qw(Class::Meta::Attribute);
+}
+
+my $obj = bless {};
+my $aname = 'foo';
+my $i = 0;
+my $attr;
+
+##############################################################################
+# Create a Class::Meta object. We'll use it to create attributes for testing
+# the creation of accessors.
+ok( my $cm = Class::Meta->new, "Create Class::Meta object" );
+
+##############################################################################
+# Check string data type.
+ok( my $type = Class::Meta::Type->new('string'), 'Get string' );
+is( $type, Class::Meta::Type->new('STRING'), 'Check lc conversion on key' );
+is( $type->key, 'string', "Check string key" );
+is( $type->name, 'String', "Check string name" );
+is( ref $type->check, 'ARRAY', "Check string check" );
+
+foreach my $chk (@{ $type->check }) {
+ is( ref $chk, 'CODE', 'Check string code');
+}
+
+# Check to make sure that the accessor is created properly. Start with a
+# simple set_ method.
+ok( $attr = $cm->add_attribute( name => $aname . ++$i, type => 'string'),
+ "Create $aname$i attribute" );
+ok( $type->build(__PACKAGE__, $attr, Class::Meta::GETSET),
+ "Make simple string set" );
+ok( my $acc = UNIVERSAL::can(__PACKAGE__, $aname . $i),
+ "String accessor exists");
+
+# Test it.
+ok( $obj->$acc('test'), "Set string value" );
+is( $obj->$acc, 'test', "Check string value" );
+
+# Make it fail the checks.
+eval { $obj->$acc([]) };
+ok( my $err = $@, "Got invalid string error" );
+like( $err, qr/^Value .* is not a valid string/, 'correct string exception' );
+
+# Check to make sure that the Attribute class accessor coderefs are getting
+# created.
+ok( my $set = $type->make_attr_set($attr), "Check string attr_set" );
+ok( my $get = $type->make_attr_get($attr), "Check string attr_get" );
+
+# Make sure they get and set values correctly.
+is( $get->($obj), 'test', "Check string getter" );
+ok( $set->($obj, 'bar'), "Check string setter" );
+is( $get->($obj), 'bar', "Check string getter again" );
+
+##############################################################################
+# Check boolean data type.
+ok( $type = Class::Meta::Type->new('boolean'), 'Get boolean' );
+is( $type, Class::Meta::Type->new('bool'), 'Check bool alias' );
+is( $type->key, 'boolean', "Check boolean key" );
+is( $type->name, 'Boolean', "Check boolean name" );
+# Boolean is special -- it has no checkers.
+ok( ! defined $type->check, "Check boolean check" );
+
+# Check to make sure that the accessor is created properly. Start with a
+# simple set_ method.
+ok( $attr = $cm->add_attribute( name => $aname . ++$i, type => 'string'),
+ "Create $aname$i attribute" );
+ok( $type->build(__PACKAGE__, $attr, Class::Meta::GETSET),
+ "Make simple boolean set" );
+ok( $acc = UNIVERSAL::can(__PACKAGE__, $aname . $i),
+ "Boolean accessor exists");
+
+# Test it.
+ok( $obj->$acc('test'), "Set boolean value" );
+is( $obj->$acc, 1, "Check boolean value" );
+
+# And finally, check to make sure that the Attribute class accessor coderefs
+# are getting created.
+ok( $set = $type->make_attr_set($attr), "Check boolean attr_set" );
+ok( $get = $type->make_attr_get($attr), "Check boolean attr_get" );
+
+# Make sure they get and set values correctly.
+is( $get->($obj), 1, "Check boolean getter" );
+$set->($obj, '');
+is( $get->($obj), 0, "Check boolean getter again" );
+
+##############################################################################
+# Check whole data type.
+ok( $type = Class::Meta::Type->new('whole'), 'Get whole' );
+is( $type->key, 'whole', "Check whole key" );
+is( $type->name, 'Whole Number', "Check whole name" );
+is( ref $type->check, 'ARRAY', "Check whole check" );
+foreach my $chk (@{ $type->check }) {
+ is( ref $chk, 'CODE', 'Check whole code');
+}
+
+# Check to make sure that the accessor is created properly. Start with a
+# simple set_ method.
+ok( $attr = $cm->add_attribute( name => $aname . ++$i, type => 'string'),
+ "Create $aname$i attribute" );
+ok( $type->build(__PACKAGE__, $attr, Class::Meta::GETSET),
+ "Make simple whole set" );
+ok( $acc = UNIVERSAL::can(__PACKAGE__, $aname . $i), "Whole accessor exists");
+
+# Test it.
+ok( $obj->$acc(12), "Set whole value" );
+is( $obj->$acc, 12, "Check whole value" );
+
+# Make it fail the checks.
+eval { $obj->$acc(-12) };
+ok( $err = $@, "Got invalid whole error" );
+like( $err, qr/^Value .* is not a valid whole number/,
+ 'correct whole exception' );
+
+# Check to make sure that the Attribute class accessor coderefs are getting
+# created.
+ok( $set = $type->make_attr_set($attr), "Check whole attr_set" );
+ok( $get = $type->make_attr_get($attr), "Check whole attr_get" );
+
+# Make sure they get and set values correctly.
+is( $get->($obj), 12, "Check whole getter" );
+ok( $set->($obj, 100), "Check whole setter" );
+is( $get->($obj), 100, "Check whole getter again" );
+
+##############################################################################
+# Check integer data type.
+ok( $type = Class::Meta::Type->new('integer'), 'Get integer' );
+is( $type, Class::Meta::Type->new('int'), 'Check int alias' );
+is( $type->key, 'integer', "Check integer key" );
+is( $type->name, 'Integer', "Check integer name" );
+is( ref $type->check, 'ARRAY', "Check integer check" );
+foreach my $chk (@{ $type->check }) {
+ is( ref $chk, 'CODE', 'Check integer code');
+}
+
+# Check to make sure that the accessor is created properly. Start with a
+# simple set_ method.
+ok( $attr = $cm->add_attribute( name => $aname . ++$i, type => 'string'),
+ "Create $aname$i attribute" );
+ok( $type->build(__PACKAGE__, $attr, Class::Meta::GETSET),
+ "Make simple integer set" );
+ok( $acc = UNIVERSAL::can(__PACKAGE__, $aname . $i),
+ "Integer accessor exists");
+
+# Test it.
+ok( $obj->$acc(12), "Set integer value" );
+is( $obj->$acc, 12, "Check integer value" );
+
+# Make it fail the checks.
+eval { $obj->$acc(12.2) };
+ok( $err = $@, "Got invalid integer error" );
+like( $err, qr/^Value .* is not a valid integer/,
+ 'correct integer exception' );
+
+# Check to make sure that the Attribute class accessor coderefs are getting
+# created.
+ok( $set = $type->make_attr_set($attr), "Check integer attr_set" );
+ok( $get = $type->make_attr_get($attr), "Check integer attr_get" );
+
+# Make sure they get and set values correctly.
+is( $get->($obj), 12, "Check integer getter" );
+ok( $set->($obj, -100), "Check integer setter" );
+is( $get->($obj), -100, "Check integer getter again" );
+
+##############################################################################
+# Check decimal data type.
+ok( $type = Class::Meta::Type->new('decimal'), 'Get decimal' );
+is( $type, Class::Meta::Type->new('dec'), 'Check dec alias' );
+is( $type->key, 'decimal', "Check decimal key" );
+is( $type->name, 'Decimal Number', "Check decimal name" );
+is( ref $type->check, 'ARRAY', "Check decimal check" );
+foreach my $chk (@{ $type->check }) {
+ is( ref $chk, 'CODE', 'Check decimal code');
+}
+
+# Check to make sure that the accessor is created properly. Start with a
+# simple set_ method.
+ok( $attr = $cm->add_attribute( name => $aname . ++$i, type => 'string'),
+ "Create $aname$i attribute" );
+ok( $type->build(__PACKAGE__, $attr, Class::Meta::GETSET),
+ "Make simple decimal set" );
+ok( $acc = UNIVERSAL::can(__PACKAGE__, $aname . $i),
+ "Decimal accessor exists");
+
+# Test it.
+ok( $obj->$acc(12.2), "Set decimal value" );
+is( $obj->$acc, 12.2, "Check decimal value" );
+
+# Make it fail the checks.
+eval { $obj->$acc('foo') };
+ok( $err = $@, "Got invalid decimal error" );
+like( $err, qr/^Value .* is not a valid decimal/,
+ 'correct decimal exception' );
+
+# Check to make sure that the Attribute class accessor coderefs are getting
+# created.
+ok( $set = $type->make_attr_set($attr), "Check decimal attr_set" );
+ok( $get = $type->make_attr_get($attr), "Check decimal attr_get" );
+
+# Make sure they get and set values correctly.
+is( $get->($obj), 12.2, "Check decimal getter" );
+ok( $set->($obj, +100.23), "Check decimal setter" );
+is( $get->($obj), +100.23, "Check decimal getter again" );
+
+##############################################################################
+# Check float data type.
+ok( $type = Class::Meta::Type->new('float'), 'Get float' );
+is( $type->key, 'float', "Check float key" );
+is( $type->name, 'Floating Point Number', "Check float name" );
+is( ref $type->check, 'ARRAY', "Check float check" );
+foreach my $chk (@{ $type->check }) {
+ is( ref $chk, 'CODE', 'Check float code');
+}
+
+# Check to make sure that the accessor is created properly. Start with a
+# simple set_ method.
+ok( $attr = $cm->add_attribute( name => $aname . ++$i, type => 'string'),
+ "Create $aname$i attribute" );
+ok( $type->build(__PACKAGE__, $attr, Class::Meta::GETSET),
+ "Make simple float set" );
+ok( $acc = UNIVERSAL::can(__PACKAGE__, $aname . $i),
+ "Float accessor exists");
+
+# Test it.
+ok( $obj->$acc(1.23e99), "Set float value" );
+is( $obj->$acc, 1.23e99, "Check float value" );
+
+# Make it fail the checks.
+eval { $obj->$acc('foo') };
+ok( $err = $@, "Got invalid float error" );
+like( $err, qr/^Value .* is not a valid float/,
+ 'correct float exception' );
+
+# Check to make sure that the Attribute class accessor coderefs are getting
+# created.
+ok( $set = $type->make_attr_set($attr), "Check float attr_set" );
+ok( $get = $type->make_attr_get($attr), "Check float attr_get" );
+
+# Make sure they get and set values correctly.
+is( $get->($obj), 1.23e99, "Check float getter" );
+ok( $set->($obj, -100.23543), "Check float setter" );
+is( $get->($obj), -100.23543, "Check float getter again" );
+
+##############################################################################
+# Check scalar data type.
+ok( $type = Class::Meta::Type->new('scalar'), 'Get scalar' );
+is( $type->key, 'scalar', "Check scalar key" );
+is( $type->name, 'Scalar', "Check scalar name" );
+# Scalars aren't validated or convted.
+ok( ! defined $type->check, "Check scalar check" );
+
+# Check to make sure that the accessor is created properly. Start with a
+# simple set_ method.
+ok( $attr = $cm->add_attribute( name => $aname . ++$i, type => 'string'),
+ "Create $aname$i attribute" );
+ok( $type->build(__PACKAGE__, $attr, Class::Meta::GETSET),
+ "Make simple scalar set" );
+ok( $acc = UNIVERSAL::can(__PACKAGE__, $aname . $i),
+ "Scalar accessor exists");
+
+# Test it.
+ok( $obj->$acc('foo'), "Set scalar value" );
+is( $obj->$acc, 'foo', "Check scalar value" );
+
+# Check to make sure that the Attribute class accessor coderefs are getting
+# created.
+ok( $set = $type->make_attr_set($attr), "Check scalar attr_set" );
+ok( $get = $type->make_attr_get($attr), "Check scalar attr_get" );
+
+# Make sure they get and set values correctly.
+is( $get->($obj), 'foo', "Check scalar getter" );
+ok( $set->($obj, []), "Check scalar setter" );
+is( ref $get->($obj), 'ARRAY', "Check scalar getter again" );
+
+##############################################################################
+# Check scalar reference data type.
+ok( $type = Class::Meta::Type->new('scalarref'), 'Get scalar ref' );
+is( $type->key, 'scalarref', "Check scalar ref key" );
+is( $type->name, 'Scalar Reference', "Check scalar ref name" );
+is( ref $type->check, 'ARRAY', "Check scalar ref check" );
+foreach my $chk (@{ $type->check }) {
+ is( ref $chk, 'CODE', 'Check scalar ref code');
+}
+
+# Check to make sure that the accessor is created properly. Start with a
+# simple set_ method.
+ok( $attr = $cm->add_attribute( name => $aname . ++$i, type => 'string'),
+ "Create $aname$i attribute" );
+ok( $type->build(__PACKAGE__, $attr, Class::Meta::GETSET),
+ "Make simple scalarref set" );
+ok( $acc = UNIVERSAL::can(__PACKAGE__, $aname . $i),
+ "Scalarref accessor exists");
+
+# Test it.
+my $sref = \"foo";
+ok( $obj->$acc($sref), "Set scalarref value" );
+is( $obj->$acc, $sref, "Check scalarref value" );
+
+# Make it fail the checks.
+eval { $obj->$acc('foo') };
+ok( $err = $@, "Got invalid scalarref error" );
+like( $err, qr/^Value .* is not a valid Scalar Reference/,
+ 'correct scalarref exception' );
+
+# Check to make sure that the Attribute class accessor coderefs are getting
+# created.
+ok( $set = $type->make_attr_set($attr), "Check scalarref attr_set" );
+ok( $get = $type->make_attr_get($attr), "Check scalarref attr_get" );
+
+# Make sure they get and set values correctly.
+is( $get->($obj), $sref, "Check scalarref getter" );
+$sref = \"bar";
+ok( $set->($obj, $sref), "Check scalarref setter" );
+is( $get->($obj), $sref, "Check scalarref getter again" );
+
+##############################################################################
+# Check array data type.
+ok( $type = Class::Meta::Type->new('array'), 'Get array' );
+is( $type, Class::Meta::Type->new('arrayref'), 'Check arrayref alias' );
+is( $type->key, 'array', "Check array key" );
+is( $type->name, 'Array Reference', "Check array name" );
+is( ref $type->check, 'ARRAY', "Check array check" );
+foreach my $chk (@{ $type->check }) {
+ is( ref $chk, 'CODE', 'Check array code');
+}
+
+# Check to make sure that the accessor is created properly. Start with a
+# simple set_ method.
+ok( $attr = $cm->add_attribute( name => $aname . ++$i, type => 'string'),
+ "Create $aname$i attribute" );
+ok( $type->build(__PACKAGE__, $attr, Class::Meta::GETSET),
+ "Make simple arrayref set" );
+ok( $acc = UNIVERSAL::can(__PACKAGE__, $aname . $i),
+ "Arrayref accessor exists");
+
+# Test it.
+my $aref = [1,2,3];
+ok( $obj->$acc($aref), "Set arrayref value" );
+is( $obj->$acc, $aref, "Check arrayref value" );
+
+# Make it fail the checks.
+eval { $obj->$acc('foo') };
+ok( $err = $@, "Got invalid arrayref error" );
+like( $err, qr/^Value .* is not a valid Array Reference/,
+ 'correct arrayref exception' );
+
+# Check to make sure that the Attribute class accessor coderefs are getting
+# created.
+ok( $set = $type->make_attr_set($attr), "Check arrayref attr_set" );
+ok( $get = $type->make_attr_get($attr), "Check arrayref attr_get" );
+
+# Make sure they get and set values correctly.
+is( $get->($obj), $aref, "Check arrayref getter" );
+$aref = [4,5,6];
+ok( $set->($obj, $aref), "Check arrayref setter" );
+is( $get->($obj), $aref, "Check arrayref getter again" );
+
+##############################################################################
+# Check hash data type.
+ok( $type = Class::Meta::Type->new('hash'), 'Get hash' );
+is( $type, Class::Meta::Type->new('hashref'), 'Check hashref alias' );
+is( $type->key, 'hash', "Check hash key" );
+is( $type->name, 'Hash Reference', "Check hash name" );
+is( ref $type->check, 'ARRAY', "Check hash check" );
+foreach my $chk (@{ $type->check }) {
+ is( ref $chk, 'CODE', 'Check hash code');
+}
+
+# Check to make sure that the accessor is created properly. Start with a
+# simple set_ method.
+ok( $attr = $cm->add_attribute( name => $aname . ++$i, type => 'string'),
+ "Create $aname$i attribute" );
+ok( $type->build(__PACKAGE__, $attr, Class::Meta::GETSET),
+ "Make simple hashref set" );
+ok( $acc = UNIVERSAL::can(__PACKAGE__, $aname . $i),
+ "Hashref accessor exists");
+
+# Test it.
+my $href = {};
+ok( $obj->$acc($href), "Set hashref value" );
+is( $obj->$acc, $href, "Check hashref value" );
+
+# Make it fail the checks.
+eval { $obj->$acc('foo') };
+ok( $err = $@, "Got invalid hashref error" );
+like( $err, qr/^Value .* is not a valid Hash Reference/,
+ 'correct hashref exception' );
+
+# Check to make sure that the Attribute class accessor coderefs are getting
+# created.
+ok( $set = $type->make_attr_set($attr), "Check hashref attr_set" );
+ok( $get = $type->make_attr_get($attr), "Check hashref attr_get" );
+
+# Make sure they get and set values correctly.
+is( $get->($obj), $href, "Check hashref getter" );
+$href = { foo => 'bar' };
+ok( $set->($obj, $href), "Check hashref setter" );
+is( $get->($obj), $href, "Check hashref getter again" );
+
+##############################################################################
+# Check code data type.
+ok( $type = Class::Meta::Type->new('code'), 'Get code' );
+is( $type, Class::Meta::Type->new('coderef'), 'Check coderef alias' );
+is( $type, Class::Meta::Type->new('closure'), 'Check closure alias' );
+is( $type->key, 'code', "Check code key" );
+is( $type->name, 'Code Reference', "Check code name" );
+is( ref $type->check, 'ARRAY', "Check code check" );
+foreach my $chk (@{ $type->check }) {
+ is( ref $chk, 'CODE', 'Check code code');
+}
+
+# Check to make sure that the accessor is created properly. Start with a
+# simple set_ method.
+ok( $attr = $cm->add_attribute( name => $aname . ++$i, type => 'string'),
+ "Create $aname$i attribute" );
+ok( $type->build(__PACKAGE__, $attr, Class::Meta::GETSET),
+ "Make simple coderef set" );
+ok( $acc = UNIVERSAL::can(__PACKAGE__, $aname . $i),
+ "Coderef accessor exists");
+
+# Test it.
+my $cref = sub {};
+ok( $obj->$acc($cref), "Set coderef value" );
+is( $obj->$acc, $cref, "Check coderef value" );
+
+# Make it fail the checks.
+eval { $obj->$acc('foo') };
+ok( $err = $@, "Got invalid coderef error" );
+like( $err, qr/^Value .* is not a valid Code Reference/,
+ 'correct coderef exception' );
+
+# Check to make sure that the Attribute class accessor coderefs are getting
+# created.
+ok( $set = $type->make_attr_set($attr), "Check coderef attr_set" );
+ok( $get = $type->make_attr_get($attr), "Check coderef attr_get" );
+
+# Make sure they get and set values correctly.
+is( $get->($obj), $cref, "Check coderef getter" );
+$cref = sub { 'foo' };
+ok( $set->($obj, $cref), "Check coderef setter" );
+is( $get->($obj), $cref, "Check coderef getter again" );
Added: packages/libclass-meta-perl/branches/upstream/current/t/chk_types_affordance.t
===================================================================
--- packages/libclass-meta-perl/branches/upstream/current/t/chk_types_affordance.t 2006-01-04 09:19:20 UTC (rev 1847)
+++ packages/libclass-meta-perl/branches/upstream/current/t/chk_types_affordance.t 2006-01-04 09:24:55 UTC (rev 1848)
@@ -0,0 +1,487 @@
+#!/usr/bin/perl -w
+
+# $Id: chk_types_affordance.t 682 2004-09-28 05:59:10Z theory $
+
+##############################################################################
+# Set up the tests.
+##############################################################################
+
+package Class::Meta::Testing;
+
+use strict;
+use Test::More tests => 208;
+BEGIN {
+ $SIG{__DIE__} = \&Carp::confess;
+ use_ok( 'Class::Meta');
+ use_ok( 'Class::Meta::Type');
+ use_ok( 'Class::Meta::Types::Numeric', 'affordance');
+ use_ok( 'Class::Meta::Types::Perl', 'affordance');
+ use_ok( 'Class::Meta::Types::String', 'affordance');
+ use_ok( 'Class::Meta::Types::Boolean', 'affordance');
+ our @ISA = qw(Class::Meta::Attribute);
+}
+
+my $obj = bless {};
+my $aname = 'foo';
+my $i = 0;
+my $attr;
+
+##############################################################################
+# Create a Class::Meta object. We'll use it to create attributes for testing
+# the creation of accessors.
+ok( my $cm = Class::Meta->new, "Create Class::Meta object" );
+
+##############################################################################
+# Check string data type.
+ok( my $type = Class::Meta::Type->new('string'), 'Get string' );
+is( $type, Class::Meta::Type->new('STRING'), 'Check lc conversion on key' );
+is( $type->key, 'string', "Check string key" );
+is( $type->name, 'String', "Check string name" );
+is( ref $type->check, 'ARRAY', "Check string check" );
+
+foreach my $chk (@{ $type->check }) {
+ is( ref $chk, 'CODE', 'Check string code');
+}
+
+# Check to make sure that the accessor is created properly. Start with a
+# simple set_ method.
+ok( $attr = $cm->add_attribute( name => $aname . ++$i, type => 'string'),
+ "Create $aname$i attribute" );
+ok( $type->build(__PACKAGE__, $attr, Class::Meta::GETSET),
+ "Make simple string set" );
+ok( my $mut = UNIVERSAL::can(__PACKAGE__, "set_$aname$i"),
+ "String mutator exists");
+ok( my $acc = UNIVERSAL::can(__PACKAGE__, "get_$aname$i"),
+ "String getter exists");
+
+# Test it.
+ok( $obj->$mut('test'), "Set string value" );
+is( $obj->$acc, 'test', "Check string value" );
+
+# Make it fail the checks.
+eval { $obj->$mut([]) };
+ok( my $err = $@, "Got invalid string error" );
+like( $err, qr/^Value .* is not a valid string/, 'correct string exception' );
+
+# Check to make sure that the Attribute class accessor coderefs are getting
+# created.
+ok( my $set = $type->make_attr_set($attr), "Check string attr_set" );
+ok( my $get = $type->make_attr_get($attr), "Check string attr_get" );
+
+# Make sure they get and set values correctly.
+is( $get->($obj), 'test', "Check string getter" );
+ok( $set->($obj, 'bar'), "Check string setter" );
+is( $get->($obj), 'bar', "Check string getter again" );
+
+##############################################################################
+# Check boolean data type.
+ok( $type = Class::Meta::Type->new('boolean'), 'Get boolean' );
+is( $type, Class::Meta::Type->new('bool'), 'Check bool alias' );
+is( $type->key, 'boolean', "Check boolean key" );
+is( $type->name, 'Boolean', "Check boolean name" );
+# Boolean is special -- it has no checkers.
+ok( ! defined $type->check, "Check boolean check" );
+
+# Check to make sure that the accessor is created properly. Start with a
+# simple set_ method.
+ok( $attr = $cm->add_attribute( name => $aname . ++$i, type => 'string'),
+ "Create $aname$i attribute" );
+ok( $type->build(__PACKAGE__, $attr, Class::Meta::GETSET),
+ "Make simple boolean set" );
+ok( $mut = UNIVERSAL::can(__PACKAGE__, "set_$aname$i\_on"),
+ "Boolean on mutator exists");
+ok( my $off = UNIVERSAL::can(__PACKAGE__, "set_$aname$i\_off"),
+ "Boolean off mutator exists");
+ok( $acc = UNIVERSAL::can(__PACKAGE__, "is_$aname$i"),
+ "Boolean mutator exists");
+
+# Test it.
+ok( $obj->$mut, "Set boolean value on" );
+is( $obj->$acc, 1, "Check boolean value on" );
+$obj->$off; # Set boolean value off.
+is( $obj->$acc, 0, "Check boolean value off" );
+
+# And finally, check to make sure that the Attribute class accessor coderefs
+# are getting created.
+ok( $set = $type->make_attr_set($attr), "Check boolean attr_set" );
+ok( $get = $type->make_attr_get($attr), "Check boolean attr_get" );
+
+# Make sure they get and set values correctly.
+is( $get->($obj), 0, "Check boolean getter" );
+$set->($obj, 12);
+is( $get->($obj), 1, "Check boolean getter again" );
+
+##############################################################################
+# Check whole data type.
+ok( $type = Class::Meta::Type->new('whole'), 'Get whole' );
+is( $type->key, 'whole', "Check whole key" );
+is( $type->name, 'Whole Number', "Check whole name" );
+is( ref $type->check, 'ARRAY', "Check whole check" );
+foreach my $chk (@{ $type->check }) {
+ is( ref $chk, 'CODE', 'Check whole code');
+}
+
+# Check to make sure that the accessor is created properly. Start with a
+# simple set_ method.
+ok( $attr = $cm->add_attribute( name => $aname . ++$i, type => 'string'),
+ "Create $aname$i attribute" );
+ok( $type->build(__PACKAGE__, $attr, Class::Meta::GETSET),
+ "Make simple whole set" );
+ok( $mut = UNIVERSAL::can(__PACKAGE__, "set_$aname$i"),
+ "Whole mutator exists");
+ok( $acc = UNIVERSAL::can(__PACKAGE__, "get_$aname$i"),
+ "Whole getter exists");
+
+# Test it.
+ok( $obj->$mut(12), "Set whole value" );
+is( $obj->$acc, 12, "Check whole value" );
+
+# Make it fail the checks.
+eval { $obj->$mut(-12) };
+ok( $err = $@, "Got invalid whole error" );
+like( $err, qr/^Value .* is not a valid whole number/,
+ 'correct whole exception' );
+
+# Check to make sure that the Attribute class accessor coderefs are getting
+# created.
+ok( $set = $type->make_attr_set($attr), "Check whole attr_set" );
+ok( $get = $type->make_attr_get($attr), "Check whole attr_get" );
+
+# Make sure they get and set values correctly.
+is( $get->($obj), 12, "Check whole getter" );
+ok( $set->($obj, 100), "Check whole setter" );
+is( $get->($obj), 100, "Check whole getter again" );
+
+##############################################################################
+# Check integer data type.
+ok( $type = Class::Meta::Type->new('integer'), 'Get integer' );
+is( $type, Class::Meta::Type->new('int'), 'Check int alias' );
+is( $type->key, 'integer', "Check integer key" );
+is( $type->name, 'Integer', "Check integer name" );
+is( ref $type->check, 'ARRAY', "Check integer check" );
+foreach my $chk (@{ $type->check }) {
+ is( ref $chk, 'CODE', 'Check integer code');
+}
+
+# Check to make sure that the accessor is created properly. Start with a
+# simple set_ method.
+ok( $attr = $cm->add_attribute( name => $aname . ++$i, type => 'string'),
+ "Create $aname$i attribute" );
+ok( $type->build(__PACKAGE__, $attr, Class::Meta::GETSET),
+ "Make simple integer set" );
+ok( $mut = UNIVERSAL::can(__PACKAGE__, "set_$aname$i"),
+ "Integer mutator exists");
+ok( $acc = UNIVERSAL::can(__PACKAGE__, "get_$aname$i"),
+ "Integer getter exists");
+
+# Test it.
+ok( $obj->$mut(12), "Set integer value" );
+is( $obj->$acc, 12, "Check integer value" );
+
+# Make it fail the checks.
+eval { $obj->$mut(12.2) };
+ok( $err = $@, "Got invalid integer error" );
+like( $err, qr/^Value .* is not a valid integer/,
+ 'correct integer exception' );
+
+# Check to make sure that the Attribute class accessor coderefs are getting
+# created.
+ok( $set = $type->make_attr_set($attr), "Check integer attr_set" );
+ok( $get = $type->make_attr_get($attr), "Check integer attr_get" );
+
+# Make sure they get and set values correctly.
+is( $get->($obj), 12, "Check integer getter" );
+ok( $set->($obj, -100), "Check integer setter" );
+is( $get->($obj), -100, "Check integer getter again" );
+
+##############################################################################
+# Check decimal data type.
+ok( $type = Class::Meta::Type->new('decimal'), 'Get decimal' );
+is( $type, Class::Meta::Type->new('dec'), 'Check dec alias' );
+is( $type->key, 'decimal', "Check decimal key" );
+is( $type->name, 'Decimal Number', "Check decimal name" );
+is( ref $type->check, 'ARRAY', "Check decimal check" );
+foreach my $chk (@{ $type->check }) {
+ is( ref $chk, 'CODE', 'Check decimal code');
+}
+
+# Check to make sure that the accessor is created properly. Start with a
+# simple set_ method.
+ok( $attr = $cm->add_attribute( name => $aname . ++$i, type => 'string'),
+ "Create $aname$i attribute" );
+ok( $type->build(__PACKAGE__, $attr, Class::Meta::GETSET),
+ "Make simple decimal set" );
+ok( $mut = UNIVERSAL::can(__PACKAGE__, "set_$aname$i"),
+ "Decimal mutator exists");
+ok( $acc = UNIVERSAL::can(__PACKAGE__, "get_$aname$i"),
+ "Decimal getter exists");
+
+# Test it.
+ok( $obj->$mut(12.2), "Set decimal value" );
+is( $obj->$acc, 12.2, "Check decimal value" );
+
+# Make it fail the checks.
+eval { $obj->$mut('foo') };
+ok( $err = $@, "Got invalid decimal error" );
+like( $err, qr/^Value .* is not a valid decimal/,
+ 'correct decimal exception' );
+
+# Check to make sure that the Attribute class accessor coderefs are getting
+# created.
+ok( $set = $type->make_attr_set($attr), "Check decimal attr_set" );
+ok( $get = $type->make_attr_get($attr), "Check decimal attr_get" );
+
+# Make sure they get and set values correctly.
+is( $get->($obj), 12.2, "Check decimal getter" );
+ok( $set->($obj, +100.23), "Check decimal setter" );
+is( $get->($obj), +100.23, "Check decimal getter again" );
+
+##############################################################################
+# Check float data type.
+ok( $type = Class::Meta::Type->new('float'), 'Get float' );
+is( $type->key, 'float', "Check float key" );
+is( $type->name, 'Floating Point Number', "Check float name" );
+is( ref $type->check, 'ARRAY', "Check float check" );
+foreach my $chk (@{ $type->check }) {
+ is( ref $chk, 'CODE', 'Check float code');
+}
+
+# Check to make sure that the accessor is created properly. Start with a
+# simple set_ method.
+ok( $attr = $cm->add_attribute( name => $aname . ++$i, type => 'string'),
+ "Create $aname$i attribute" );
+ok( $type->build(__PACKAGE__, $attr, Class::Meta::GETSET),
+ "Make simple float set" );
+ok( $mut = UNIVERSAL::can(__PACKAGE__, "set_$aname$i"),
+ "Float mutator exists");
+ok( $acc = UNIVERSAL::can(__PACKAGE__, "get_$aname$i"),
+ "Float getter exists");
+
+# Test it.
+ok( $obj->$mut(1.23e99), "Set float value" );
+is( $obj->$acc, 1.23e99, "Check float value" );
+
+# Make it fail the checks.
+eval { $obj->$mut('foo') };
+ok( $err = $@, "Got invalid float error" );
+like( $err, qr/^Value .* is not a valid float/,
+ 'correct float exception' );
+
+# Check to make sure that the Attribute class accessor coderefs are getting
+# created.
+ok( $set = $type->make_attr_set($attr), "Check float attr_set" );
+ok( $get = $type->make_attr_get($attr), "Check float attr_get" );
+
+# Make sure they get and set values correctly.
+is( $get->($obj), 1.23e99, "Check float getter" );
+ok( $set->($obj, -100.23543), "Check float setter" );
+is( $get->($obj), -100.23543, "Check float getter again" );
+
+##############################################################################
+# Check scalar data type.
+ok( $type = Class::Meta::Type->new('scalar'), 'Get scalar' );
+is( $type->key, 'scalar', "Check scalar key" );
+is( $type->name, 'Scalar', "Check scalar name" );
+# Scalars aren't validated or convted.
+ok( ! defined $type->check, "Check scalar check" );
+
+# Check to make sure that the accessor is created properly. Start with a
+# simple set_ method.
+ok( $attr = $cm->add_attribute( name => $aname . ++$i, type => 'string'),
+ "Create $aname$i attribute" );
+ok( $type->build(__PACKAGE__, $attr, Class::Meta::GETSET),
+ "Make simple scalar set" );
+ok( $mut = UNIVERSAL::can(__PACKAGE__, "set_$aname$i"),
+ "Scalar mutator exists");
+ok( $acc = UNIVERSAL::can(__PACKAGE__, "get_$aname$i"),
+ "Scalar getter exists");
+
+# Test it.
+ok( $obj->$mut('foo'), "Set scalar value" );
+is( $obj->$acc, 'foo', "Check scalar value" );
+
+# Check to make sure that the Attribute class accessor coderefs are getting
+# created.
+ok( $set = $type->make_attr_set($attr), "Check scalar attr_set" );
+ok( $get = $type->make_attr_get($attr), "Check scalar attr_get" );
+
+# Make sure they get and set values correctly.
+is( $get->($obj), 'foo', "Check scalar getter" );
+ok( $set->($obj, []), "Check scalar setter" );
+is( ref $get->($obj), 'ARRAY', "Check scalar getter again" );
+
+##############################################################################
+# Check scalar reference data type.
+ok( $type = Class::Meta::Type->new('scalarref'), 'Get scalar ref' );
+is( $type->key, 'scalarref', "Check scalar ref key" );
+is( $type->name, 'Scalar Reference', "Check scalar ref name" );
+is( ref $type->check, 'ARRAY', "Check scalar ref check" );
+foreach my $chk (@{ $type->check }) {
+ is( ref $chk, 'CODE', 'Check scalar ref code');
+}
+
+# Check to make sure that the accessor is created properly. Start with a
+# simple set_ method.
+ok( $attr = $cm->add_attribute( name => $aname . ++$i, type => 'string'),
+ "Create $aname$i attribute" );
+ok( $type->build(__PACKAGE__, $attr, Class::Meta::GETSET),
+ "Make simple scalarref set" );
+ok( $mut = UNIVERSAL::can(__PACKAGE__, "set_$aname$i"),
+ "Scalarref mutator exists");
+ok( $acc = UNIVERSAL::can(__PACKAGE__, "get_$aname$i"),
+ "Scalarref getter exists");
+
+# Test it.
+my $sref = \"foo";
+ok( $obj->$mut($sref), "Set scalarref value" );
+is( $obj->$acc, $sref, "Check scalarref value" );
+
+# Make it fail the checks.
+eval { $obj->$mut('foo') };
+ok( $err = $@, "Got invalid scalarref error" );
+like( $err, qr/^Value .* is not a valid Scalar Reference/,
+ 'correct scalarref exception' );
+
+# Check to make sure that the Attribute class accessor coderefs are getting
+# created.
+ok( $set = $type->make_attr_set($attr), "Check scalarref attr_set" );
+ok( $get = $type->make_attr_get($attr), "Check scalarref attr_get" );
+
+# Make sure they get and set values correctly.
+is( $get->($obj), $sref, "Check scalarref getter" );
+$sref = \"bar";
+ok( $set->($obj, $sref), "Check scalarref setter" );
+is( $get->($obj), $sref, "Check scalarref getter again" );
+
+##############################################################################
+# Check array data type.
+ok( $type = Class::Meta::Type->new('array'), 'Get array' );
+is( $type, Class::Meta::Type->new('arrayref'), 'Check arrayref alias' );
+is( $type->key, 'array', "Check array key" );
+is( $type->name, 'Array Reference', "Check array name" );
+is( ref $type->check, 'ARRAY', "Check array check" );
+foreach my $chk (@{ $type->check }) {
+ is( ref $chk, 'CODE', 'Check array code');
+}
+
+# Check to make sure that the accessor is created properly. Start with a
+# simple set_ method.
+ok( $attr = $cm->add_attribute( name => $aname . ++$i, type => 'string'),
+ "Create $aname$i attribute" );
+ok( $type->build(__PACKAGE__, $attr, Class::Meta::GETSET),
+ "Make simple arrayref set" );
+ok( $mut = UNIVERSAL::can(__PACKAGE__, "set_$aname$i"),
+ "Arrayref mutator exists");
+ok( $acc = UNIVERSAL::can(__PACKAGE__, "get_$aname$i"),
+ "Arrayref getter exists");
+
+# Test it.
+my $aref = [1,2,3];
+ok( $obj->$mut($aref), "Set arrayref value" );
+is( $obj->$acc, $aref, "Check arrayref value" );
+
+# Make it fail the checks.
+eval { $obj->$mut('foo') };
+ok( $err = $@, "Got invalid arrayref error" );
+like( $err, qr/^Value .* is not a valid Array Reference/,
+ 'correct arrayref exception' );
+
+# Check to make sure that the Attribute class accessor coderefs are getting
+# created.
+ok( $set = $type->make_attr_set($attr), "Check arrayref attr_set" );
+ok( $get = $type->make_attr_get($attr), "Check arrayref attr_get" );
+
+# Make sure they get and set values correctly.
+is( $get->($obj), $aref, "Check arrayref getter" );
+$aref = [4,5,6];
+ok( $set->($obj, $aref), "Check arrayref setter" );
+is( $get->($obj), $aref, "Check arrayref getter again" );
+
+##############################################################################
+# Check hash data type.
+ok( $type = Class::Meta::Type->new('hash'), 'Get hash' );
+is( $type, Class::Meta::Type->new('hashref'), 'Check hashref alias' );
+is( $type->key, 'hash', "Check hash key" );
+is( $type->name, 'Hash Reference', "Check hash name" );
+is( ref $type->check, 'ARRAY', "Check hash check" );
+foreach my $chk (@{ $type->check }) {
+ is( ref $chk, 'CODE', 'Check hash code');
+}
+
+# Check to make sure that the accessor is created properly. Start with a
+# simple set_ method.
+ok( $attr = $cm->add_attribute( name => $aname . ++$i, type => 'string'),
+ "Create $aname$i attribute" );
+ok( $type->build(__PACKAGE__, $attr, Class::Meta::GETSET),
+ "Make simple hashref set" );
+ok( $mut = UNIVERSAL::can(__PACKAGE__, "set_$aname$i"),
+ "Hashref mutator exists");
+ok( $acc = UNIVERSAL::can(__PACKAGE__, "get_$aname$i"),
+ "Hashref getter exists");
+
+# Test it.
+my $href = {};
+ok( $obj->$mut($href), "Set hashref value" );
+is( $obj->$acc, $href, "Check hashref value" );
+
+# Make it fail the checks.
+eval { $obj->$mut('foo') };
+ok( $err = $@, "Got invalid hashref error" );
+like( $err, qr/^Value .* is not a valid Hash Reference/,
+ 'correct hashref exception' );
+
+# Check to make sure that the Attribute class accessor coderefs are getting
+# created.
+ok( $set = $type->make_attr_set($attr), "Check hashref attr_set" );
+ok( $get = $type->make_attr_get($attr), "Check hashref attr_get" );
+
+# Make sure they get and set values correctly.
+is( $get->($obj), $href, "Check hashref getter" );
+$href = { foo => 'bar' };
+ok( $set->($obj, $href), "Check hashref setter" );
+is( $get->($obj), $href, "Check hashref getter again" );
+
+##############################################################################
+# Check code data type.
+ok( $type = Class::Meta::Type->new('code'), 'Get code' );
+is( $type, Class::Meta::Type->new('coderef'), 'Check coderef alias' );
+is( $type, Class::Meta::Type->new('closure'), 'Check closure alias' );
+is( $type->key, 'code', "Check code key" );
+is( $type->name, 'Code Reference', "Check code name" );
+is( ref $type->check, 'ARRAY', "Check code check" );
+foreach my $chk (@{ $type->check }) {
+ is( ref $chk, 'CODE', 'Check code code');
+}
+
+# Check to make sure that the accessor is created properly. Start with a
+# simple set_ method.
+ok( $attr = $cm->add_attribute( name => $aname . ++$i, type => 'string'),
+ "Create $aname$i attribute" );
+ok( $type->build(__PACKAGE__, $attr, Class::Meta::GETSET),
+ "Make simple coderef set" );
+ok( $mut = UNIVERSAL::can(__PACKAGE__, "set_$aname$i"),
+ "Coderef mutator exists");
+ok( $acc = UNIVERSAL::can(__PACKAGE__, "get_$aname$i"),
+ "Coderef getter exists");
+
+# Test it.
+my $cref = sub {};
+ok( $obj->$mut($cref), "Set coderef value" );
+is( $obj->$acc, $cref, "Check coderef value" );
+
+# Make it fail the checks.
+eval { $obj->$mut('foo') };
+ok( $err = $@, "Got invalid coderef error" );
+like( $err, qr/^Value .* is not a valid Code Reference/,
+ 'correct coderef exception' );
+
+# Check to make sure that the Attribute class accessor coderefs are getting
+# created.
+ok( $set = $type->make_attr_set($attr), "Check coderef attr_set" );
+ok( $get = $type->make_attr_get($attr), "Check coderef attr_get" );
+
+# Make sure they get and set values correctly.
+is( $get->($obj), $cref, "Check coderef getter" );
+$cref = sub { 'foo' };
+ok( $set->($obj, $cref), "Check coderef setter" );
+is( $get->($obj), $cref, "Check coderef getter again" );
Added: packages/libclass-meta-perl/branches/upstream/current/t/chk_types_semi_affordance.t
===================================================================
--- packages/libclass-meta-perl/branches/upstream/current/t/chk_types_semi_affordance.t 2006-01-04 09:19:20 UTC (rev 1847)
+++ packages/libclass-meta-perl/branches/upstream/current/t/chk_types_semi_affordance.t 2006-01-04 09:24:55 UTC (rev 1848)
@@ -0,0 +1,487 @@
+#!/usr/bin/perl -w
+
+# $Id: chk_types_semi_affordance.t 682 2004-09-28 05:59:10Z theory $
+
+##############################################################################
+# Set up the tests.
+##############################################################################
+
+package Class::Meta::Testing;
+
+use strict;
+use Test::More tests => 208;
+BEGIN {
+ $SIG{__DIE__} = \&Carp::confess;
+ use_ok( 'Class::Meta');
+ use_ok( 'Class::Meta::Type');
+ use_ok( 'Class::Meta::Types::Numeric', 'semi-affordance');
+ use_ok( 'Class::Meta::Types::Perl', 'semi-affordance');
+ use_ok( 'Class::Meta::Types::String', 'semi-affordance');
+ use_ok( 'Class::Meta::Types::Boolean', 'semi-affordance');
+ our @ISA = qw(Class::Meta::Attribute);
+}
+
+my $obj = bless {};
+my $aname = 'foo';
+my $i = 0;
+my $attr;
+
+##############################################################################
+# Create a Class::Meta object. We'll use it to create attributes for testing
+# the creation of accessors.
+ok( my $cm = Class::Meta->new, "Create Class::Meta object" );
+
+##############################################################################
+# Check string data type.
+ok( my $type = Class::Meta::Type->new('string'), 'Get string' );
+is( $type, Class::Meta::Type->new('STRING'), 'Check lc conversion on key' );
+is( $type->key, 'string', "Check string key" );
+is( $type->name, 'String', "Check string name" );
+is( ref $type->check, 'ARRAY', "Check string check" );
+
+foreach my $chk (@{ $type->check }) {
+ is( ref $chk, 'CODE', 'Check string code');
+}
+
+# Check to make sure that the accessor is created properly. Start with a
+# simple set_ method.
+ok( $attr = $cm->add_attribute( name => $aname . ++$i, type => 'string'),
+ "Create $aname$i attribute" );
+ok( $type->build(__PACKAGE__, $attr, Class::Meta::GETSET),
+ "Make simple string set" );
+ok( my $mut = UNIVERSAL::can(__PACKAGE__, "set_$aname$i"),
+ "String mutator exists");
+ok( my $acc = UNIVERSAL::can(__PACKAGE__, "$aname$i"),
+ "String getter exists");
+
+# Test it.
+ok( $obj->$mut('test'), "Set string value" );
+is( $obj->$acc, 'test', "Check string value" );
+
+# Make it fail the checks.
+eval { $obj->$mut([]) };
+ok( my $err = $@, "Got invalid string error" );
+like( $err, qr/^Value .* is not a valid string/, 'correct string exception' );
+
+# Check to make sure that the Attribute class accessor coderefs are getting
+# created.
+ok( my $set = $type->make_attr_set($attr), "Check string attr_set" );
+ok( my $get = $type->make_attr_get($attr), "Check string attr_get" );
+
+# Make sure they get and set values correctly.
+is( $get->($obj), 'test', "Check string getter" );
+ok( $set->($obj, 'bar'), "Check string setter" );
+is( $get->($obj), 'bar', "Check string getter again" );
+
+##############################################################################
+# Check boolean data type.
+ok( $type = Class::Meta::Type->new('boolean'), 'Get boolean' );
+is( $type, Class::Meta::Type->new('bool'), 'Check bool alias' );
+is( $type->key, 'boolean', "Check boolean key" );
+is( $type->name, 'Boolean', "Check boolean name" );
+# Boolean is special -- it has no checkers.
+ok( ! defined $type->check, "Check boolean check" );
+
+# Check to make sure that the accessor is created properly. Start with a
+# simple set_ method.
+ok( $attr = $cm->add_attribute( name => $aname . ++$i, type => 'string'),
+ "Create $aname$i attribute" );
+ok( $type->build(__PACKAGE__, $attr, Class::Meta::GETSET),
+ "Make simple boolean set" );
+ok( $mut = UNIVERSAL::can(__PACKAGE__, "set_$aname$i\_on"),
+ "Boolean on mutator exists");
+ok( my $off = UNIVERSAL::can(__PACKAGE__, "set_$aname$i\_off"),
+ "Boolean off mutator exists");
+ok( $acc = UNIVERSAL::can(__PACKAGE__, "is_$aname$i"),
+ "Boolean mutator exists");
+
+# Test it.
+ok( $obj->$mut, "Set boolean value on" );
+is( $obj->$acc, 1, "Check boolean value on" );
+$obj->$off; # Set boolean value off.
+is( $obj->$acc, 0, "Check boolean value off" );
+
+# And finally, check to make sure that the Attribute class accessor coderefs
+# are getting created.
+ok( $set = $type->make_attr_set($attr), "Check boolean attr_set" );
+ok( $get = $type->make_attr_get($attr), "Check boolean attr_get" );
+
+# Make sure they get and set values correctly.
+is( $get->($obj), 0, "Check boolean getter" );
+$set->($obj, 12);
+is( $get->($obj), 1, "Check boolean getter again" );
+
+##############################################################################
+# Check whole data type.
+ok( $type = Class::Meta::Type->new('whole'), 'Get whole' );
+is( $type->key, 'whole', "Check whole key" );
+is( $type->name, 'Whole Number', "Check whole name" );
+is( ref $type->check, 'ARRAY', "Check whole check" );
+foreach my $chk (@{ $type->check }) {
+ is( ref $chk, 'CODE', 'Check whole code');
+}
+
+# Check to make sure that the accessor is created properly. Start with a
+# simple set_ method.
+ok( $attr = $cm->add_attribute( name => $aname . ++$i, type => 'string'),
+ "Create $aname$i attribute" );
+ok( $type->build(__PACKAGE__, $attr, Class::Meta::GETSET),
+ "Make simple whole set" );
+ok( $mut = UNIVERSAL::can(__PACKAGE__, "set_$aname$i"),
+ "Whole mutator exists");
+ok( $acc = UNIVERSAL::can(__PACKAGE__, "$aname$i"),
+ "Whole getter exists");
+
+# Test it.
+ok( $obj->$mut(12), "Set whole value" );
+is( $obj->$acc, 12, "Check whole value" );
+
+# Make it fail the checks.
+eval { $obj->$mut(-12) };
+ok( $err = $@, "Got invalid whole error" );
+like( $err, qr/^Value .* is not a valid whole number/,
+ 'correct whole exception' );
+
+# Check to make sure that the Attribute class accessor coderefs are getting
+# created.
+ok( $set = $type->make_attr_set($attr), "Check whole attr_set" );
+ok( $get = $type->make_attr_get($attr), "Check whole attr_get" );
+
+# Make sure they get and set values correctly.
+is( $get->($obj), 12, "Check whole getter" );
+ok( $set->($obj, 100), "Check whole setter" );
+is( $get->($obj), 100, "Check whole getter again" );
+
+##############################################################################
+# Check integer data type.
+ok( $type = Class::Meta::Type->new('integer'), 'Get integer' );
+is( $type, Class::Meta::Type->new('int'), 'Check int alias' );
+is( $type->key, 'integer', "Check integer key" );
+is( $type->name, 'Integer', "Check integer name" );
+is( ref $type->check, 'ARRAY', "Check integer check" );
+foreach my $chk (@{ $type->check }) {
+ is( ref $chk, 'CODE', 'Check integer code');
+}
+
+# Check to make sure that the accessor is created properly. Start with a
+# simple set_ method.
+ok( $attr = $cm->add_attribute( name => $aname . ++$i, type => 'string'),
+ "Create $aname$i attribute" );
+ok( $type->build(__PACKAGE__, $attr, Class::Meta::GETSET),
+ "Make simple integer set" );
+ok( $mut = UNIVERSAL::can(__PACKAGE__, "set_$aname$i"),
+ "Integer mutator exists");
+ok( $acc = UNIVERSAL::can(__PACKAGE__, "$aname$i"),
+ "Integer getter exists");
+
+# Test it.
+ok( $obj->$mut(12), "Set integer value" );
+is( $obj->$acc, 12, "Check integer value" );
+
+# Make it fail the checks.
+eval { $obj->$mut(12.2) };
+ok( $err = $@, "Got invalid integer error" );
+like( $err, qr/^Value .* is not a valid integer/,
+ 'correct integer exception' );
+
+# Check to make sure that the Attribute class accessor coderefs are getting
+# created.
+ok( $set = $type->make_attr_set($attr), "Check integer attr_set" );
+ok( $get = $type->make_attr_get($attr), "Check integer attr_get" );
+
+# Make sure they get and set values correctly.
+is( $get->($obj), 12, "Check integer getter" );
+ok( $set->($obj, -100), "Check integer setter" );
+is( $get->($obj), -100, "Check integer getter again" );
+
+##############################################################################
+# Check decimal data type.
+ok( $type = Class::Meta::Type->new('decimal'), 'Get decimal' );
+is( $type, Class::Meta::Type->new('dec'), 'Check dec alias' );
+is( $type->key, 'decimal', "Check decimal key" );
+is( $type->name, 'Decimal Number', "Check decimal name" );
+is( ref $type->check, 'ARRAY', "Check decimal check" );
+foreach my $chk (@{ $type->check }) {
+ is( ref $chk, 'CODE', 'Check decimal code');
+}
+
+# Check to make sure that the accessor is created properly. Start with a
+# simple set_ method.
+ok( $attr = $cm->add_attribute( name => $aname . ++$i, type => 'string'),
+ "Create $aname$i attribute" );
+ok( $type->build(__PACKAGE__, $attr, Class::Meta::GETSET),
+ "Make simple decimal set" );
+ok( $mut = UNIVERSAL::can(__PACKAGE__, "set_$aname$i"),
+ "Decimal mutator exists");
+ok( $acc = UNIVERSAL::can(__PACKAGE__, "$aname$i"),
+ "Decimal getter exists");
+
+# Test it.
+ok( $obj->$mut(12.2), "Set decimal value" );
+is( $obj->$acc, 12.2, "Check decimal value" );
+
+# Make it fail the checks.
+eval { $obj->$mut('foo') };
+ok( $err = $@, "Got invalid decimal error" );
+like( $err, qr/^Value .* is not a valid decimal/,
+ 'correct decimal exception' );
+
+# Check to make sure that the Attribute class accessor coderefs are getting
+# created.
+ok( $set = $type->make_attr_set($attr), "Check decimal attr_set" );
+ok( $get = $type->make_attr_get($attr), "Check decimal attr_get" );
+
+# Make sure they get and set values correctly.
+is( $get->($obj), 12.2, "Check decimal getter" );
+ok( $set->($obj, +100.23), "Check decimal setter" );
+is( $get->($obj), +100.23, "Check decimal getter again" );
+
+##############################################################################
+# Check float data type.
+ok( $type = Class::Meta::Type->new('float'), 'Get float' );
+is( $type->key, 'float', "Check float key" );
+is( $type->name, 'Floating Point Number', "Check float name" );
+is( ref $type->check, 'ARRAY', "Check float check" );
+foreach my $chk (@{ $type->check }) {
+ is( ref $chk, 'CODE', 'Check float code');
+}
+
+# Check to make sure that the accessor is created properly. Start with a
+# simple set_ method.
+ok( $attr = $cm->add_attribute( name => $aname . ++$i, type => 'string'),
+ "Create $aname$i attribute" );
+ok( $type->build(__PACKAGE__, $attr, Class::Meta::GETSET),
+ "Make simple float set" );
+ok( $mut = UNIVERSAL::can(__PACKAGE__, "set_$aname$i"),
+ "Float mutator exists");
+ok( $acc = UNIVERSAL::can(__PACKAGE__, "$aname$i"),
+ "Float getter exists");
+
+# Test it.
+ok( $obj->$mut(1.23e99), "Set float value" );
+is( $obj->$acc, 1.23e99, "Check float value" );
+
+# Make it fail the checks.
+eval { $obj->$mut('foo') };
+ok( $err = $@, "Got invalid float error" );
+like( $err, qr/^Value .* is not a valid float/,
+ 'correct float exception' );
+
+# Check to make sure that the Attribute class accessor coderefs are getting
+# created.
+ok( $set = $type->make_attr_set($attr), "Check float attr_set" );
+ok( $get = $type->make_attr_get($attr), "Check float attr_get" );
+
+# Make sure they get and set values correctly.
+is( $get->($obj), 1.23e99, "Check float getter" );
+ok( $set->($obj, -100.23543), "Check float setter" );
+is( $get->($obj), -100.23543, "Check float getter again" );
+
+##############################################################################
+# Check scalar data type.
+ok( $type = Class::Meta::Type->new('scalar'), 'Get scalar' );
+is( $type->key, 'scalar', "Check scalar key" );
+is( $type->name, 'Scalar', "Check scalar name" );
+# Scalars aren't validated or convted.
+ok( ! defined $type->check, "Check scalar check" );
+
+# Check to make sure that the accessor is created properly. Start with a
+# simple set_ method.
+ok( $attr = $cm->add_attribute( name => $aname . ++$i, type => 'string'),
+ "Create $aname$i attribute" );
+ok( $type->build(__PACKAGE__, $attr, Class::Meta::GETSET),
+ "Make simple scalar set" );
+ok( $mut = UNIVERSAL::can(__PACKAGE__, "set_$aname$i"),
+ "Scalar mutator exists");
+ok( $acc = UNIVERSAL::can(__PACKAGE__, "$aname$i"),
+ "Scalar getter exists");
+
+# Test it.
+ok( $obj->$mut('foo'), "Set scalar value" );
+is( $obj->$acc, 'foo', "Check scalar value" );
+
+# Check to make sure that the Attribute class accessor coderefs are getting
+# created.
+ok( $set = $type->make_attr_set($attr), "Check scalar attr_set" );
+ok( $get = $type->make_attr_get($attr), "Check scalar attr_get" );
+
+# Make sure they get and set values correctly.
+is( $get->($obj), 'foo', "Check scalar getter" );
+ok( $set->($obj, []), "Check scalar setter" );
+is( ref $get->($obj), 'ARRAY', "Check scalar getter again" );
+
+##############################################################################
+# Check scalar reference data type.
+ok( $type = Class::Meta::Type->new('scalarref'), 'Get scalar ref' );
+is( $type->key, 'scalarref', "Check scalar ref key" );
+is( $type->name, 'Scalar Reference', "Check scalar ref name" );
+is( ref $type->check, 'ARRAY', "Check scalar ref check" );
+foreach my $chk (@{ $type->check }) {
+ is( ref $chk, 'CODE', 'Check scalar ref code');
+}
+
+# Check to make sure that the accessor is created properly. Start with a
+# simple set_ method.
+ok( $attr = $cm->add_attribute( name => $aname . ++$i, type => 'string'),
+ "Create $aname$i attribute" );
+ok( $type->build(__PACKAGE__, $attr, Class::Meta::GETSET),
+ "Make simple scalarref set" );
+ok( $mut = UNIVERSAL::can(__PACKAGE__, "set_$aname$i"),
+ "Scalarref mutator exists");
+ok( $acc = UNIVERSAL::can(__PACKAGE__, "$aname$i"),
+ "Scalarref getter exists");
+
+# Test it.
+my $sref = \"foo";
+ok( $obj->$mut($sref), "Set scalarref value" );
+is( $obj->$acc, $sref, "Check scalarref value" );
+
+# Make it fail the checks.
+eval { $obj->$mut('foo') };
+ok( $err = $@, "Got invalid scalarref error" );
+like( $err, qr/^Value .* is not a valid Scalar Reference/,
+ 'correct scalarref exception' );
+
+# Check to make sure that the Attribute class accessor coderefs are getting
+# created.
+ok( $set = $type->make_attr_set($attr), "Check scalarref attr_set" );
+ok( $get = $type->make_attr_get($attr), "Check scalarref attr_get" );
+
+# Make sure they get and set values correctly.
+is( $get->($obj), $sref, "Check scalarref getter" );
+$sref = \"bar";
+ok( $set->($obj, $sref), "Check scalarref setter" );
+is( $get->($obj), $sref, "Check scalarref getter again" );
+
+##############################################################################
+# Check array data type.
+ok( $type = Class::Meta::Type->new('array'), 'Get array' );
+is( $type, Class::Meta::Type->new('arrayref'), 'Check arrayref alias' );
+is( $type->key, 'array', "Check array key" );
+is( $type->name, 'Array Reference', "Check array name" );
+is( ref $type->check, 'ARRAY', "Check array check" );
+foreach my $chk (@{ $type->check }) {
+ is( ref $chk, 'CODE', 'Check array code');
+}
+
+# Check to make sure that the accessor is created properly. Start with a
+# simple set_ method.
+ok( $attr = $cm->add_attribute( name => $aname . ++$i, type => 'string'),
+ "Create $aname$i attribute" );
+ok( $type->build(__PACKAGE__, $attr, Class::Meta::GETSET),
+ "Make simple arrayref set" );
+ok( $mut = UNIVERSAL::can(__PACKAGE__, "set_$aname$i"),
+ "Arrayref mutator exists");
+ok( $acc = UNIVERSAL::can(__PACKAGE__, "$aname$i"),
+ "Arrayref getter exists");
+
+# Test it.
+my $aref = [1,2,3];
+ok( $obj->$mut($aref), "Set arrayref value" );
+is( $obj->$acc, $aref, "Check arrayref value" );
+
+# Make it fail the checks.
+eval { $obj->$mut('foo') };
+ok( $err = $@, "Got invalid arrayref error" );
+like( $err, qr/^Value .* is not a valid Array Reference/,
+ 'correct arrayref exception' );
+
+# Check to make sure that the Attribute class accessor coderefs are getting
+# created.
+ok( $set = $type->make_attr_set($attr), "Check arrayref attr_set" );
+ok( $get = $type->make_attr_get($attr), "Check arrayref attr_get" );
+
+# Make sure they get and set values correctly.
+is( $get->($obj), $aref, "Check arrayref getter" );
+$aref = [4,5,6];
+ok( $set->($obj, $aref), "Check arrayref setter" );
+is( $get->($obj), $aref, "Check arrayref getter again" );
+
+##############################################################################
+# Check hash data type.
+ok( $type = Class::Meta::Type->new('hash'), 'Get hash' );
+is( $type, Class::Meta::Type->new('hashref'), 'Check hashref alias' );
+is( $type->key, 'hash', "Check hash key" );
+is( $type->name, 'Hash Reference', "Check hash name" );
+is( ref $type->check, 'ARRAY', "Check hash check" );
+foreach my $chk (@{ $type->check }) {
+ is( ref $chk, 'CODE', 'Check hash code');
+}
+
+# Check to make sure that the accessor is created properly. Start with a
+# simple set_ method.
+ok( $attr = $cm->add_attribute( name => $aname . ++$i, type => 'string'),
+ "Create $aname$i attribute" );
+ok( $type->build(__PACKAGE__, $attr, Class::Meta::GETSET),
+ "Make simple hashref set" );
+ok( $mut = UNIVERSAL::can(__PACKAGE__, "set_$aname$i"),
+ "Hashref mutator exists");
+ok( $acc = UNIVERSAL::can(__PACKAGE__, "$aname$i"),
+ "Hashref getter exists");
+
+# Test it.
+my $href = {};
+ok( $obj->$mut($href), "Set hashref value" );
+is( $obj->$acc, $href, "Check hashref value" );
+
+# Make it fail the checks.
+eval { $obj->$mut('foo') };
+ok( $err = $@, "Got invalid hashref error" );
+like( $err, qr/^Value .* is not a valid Hash Reference/,
+ 'correct hashref exception' );
+
+# Check to make sure that the Attribute class accessor coderefs are getting
+# created.
+ok( $set = $type->make_attr_set($attr), "Check hashref attr_set" );
+ok( $get = $type->make_attr_get($attr), "Check hashref attr_get" );
+
+# Make sure they get and set values correctly.
+is( $get->($obj), $href, "Check hashref getter" );
+$href = { foo => 'bar' };
+ok( $set->($obj, $href), "Check hashref setter" );
+is( $get->($obj), $href, "Check hashref getter again" );
+
+##############################################################################
+# Check code data type.
+ok( $type = Class::Meta::Type->new('code'), 'Get code' );
+is( $type, Class::Meta::Type->new('coderef'), 'Check coderef alias' );
+is( $type, Class::Meta::Type->new('closure'), 'Check closure alias' );
+is( $type->key, 'code', "Check code key" );
+is( $type->name, 'Code Reference', "Check code name" );
+is( ref $type->check, 'ARRAY', "Check code check" );
+foreach my $chk (@{ $type->check }) {
+ is( ref $chk, 'CODE', 'Check code code');
+}
+
+# Check to make sure that the accessor is created properly. Start with a
+# simple set_ method.
+ok( $attr = $cm->add_attribute( name => $aname . ++$i, type => 'string'),
+ "Create $aname$i attribute" );
+ok( $type->build(__PACKAGE__, $attr, Class::Meta::GETSET),
+ "Make simple coderef set" );
+ok( $mut = UNIVERSAL::can(__PACKAGE__, "set_$aname$i"),
+ "Coderef mutator exists");
+ok( $acc = UNIVERSAL::can(__PACKAGE__, "$aname$i"),
+ "Coderef getter exists");
+
+# Test it.
+my $cref = sub {};
+ok( $obj->$mut($cref), "Set coderef value" );
+is( $obj->$acc, $cref, "Check coderef value" );
+
+# Make it fail the checks.
+eval { $obj->$mut('foo') };
+ok( $err = $@, "Got invalid coderef error" );
+like( $err, qr/^Value .* is not a valid Code Reference/,
+ 'correct coderef exception' );
+
+# Check to make sure that the Attribute class accessor coderefs are getting
+# created.
+ok( $set = $type->make_attr_set($attr), "Check coderef attr_set" );
+ok( $get = $type->make_attr_get($attr), "Check coderef attr_get" );
+
+# Make sure they get and set values correctly.
+is( $get->($obj), $cref, "Check coderef getter" );
+$cref = sub { 'foo' };
+ok( $set->($obj, $cref), "Check coderef setter" );
+is( $get->($obj), $cref, "Check coderef getter again" );
Added: packages/libclass-meta-perl/branches/upstream/current/t/class.t
===================================================================
--- packages/libclass-meta-perl/branches/upstream/current/t/class.t 2006-01-04 09:19:20 UTC (rev 1847)
+++ packages/libclass-meta-perl/branches/upstream/current/t/class.t 2006-01-04 09:24:55 UTC (rev 1848)
@@ -0,0 +1,58 @@
+#!/usr/bin/perl -w
+
+# $Id: class.t 682 2004-09-28 05:59:10Z theory $
+
+use strict;
+use Test::More tests => 13;
+BEGIN { use_ok( 'Class::Meta') }
+
+# Make sure we can't instantiate a class object from here.
+my $class;
+eval { $class = Class::Meta::Class->new };
+ok( my $err = $@, 'Error creating class' );
+like($err, qr/^Package 'main' cannot create.*objects/,
+ 'Check error message' );
+
+# Now try inheritance.
+package Class::Meta::FooSub;
+use strict;
+use base 'Class::Meta';
+Test::More->import;
+
+# Set up simple settings.
+my $spec = { desc => 'Foo Class description',
+ package => 'FooClass',
+ class => Class::Meta->new->class,
+ error_handler => Class::Meta->default_error_handler,
+ key => 'foo' };
+
+# This should be okay.
+ok( $class = Class::Meta::Class->new($spec),
+ 'Subclass can create class objects' );
+
+# Test the simple accessors.
+is( $class->name, $spec->{key}, 'name' );
+is( $class->desc, $spec->{desc}, 'desc' );
+is( $class->key, $spec->{key}, 'key' );
+
+# Now try inheritance for Class.
+package Class::Meta::Class::Sub;
+use base 'Class::Meta::Class';
+
+# Make sure we can override new and build.
+sub new { shift->SUPER::new(@_) }
+sub build { shift->SUPER::build(@_) }
+
+sub foo { shift->{foo} }
+
+package main;
+ok( my $cm = Class::Meta->new(
+ class_class => 'Class::Meta::Class::Sub',
+ foo => 'bar',
+), "Create Class" );
+ok( $class = $cm->class, "Retrieve class" );
+isa_ok($class, 'Class::Meta::Class::Sub');
+isa_ok($class, 'Class::Meta::Class');
+is( $class->package, __PACKAGE__, "Check an attibute");
+is( $class->foo, 'bar', "Check added attribute" );
+
Added: packages/libclass-meta-perl/branches/upstream/current/t/constraints.t
===================================================================
--- packages/libclass-meta-perl/branches/upstream/current/t/constraints.t 2006-01-04 09:19:20 UTC (rev 1847)
+++ packages/libclass-meta-perl/branches/upstream/current/t/constraints.t 2006-01-04 09:24:55 UTC (rev 1848)
@@ -0,0 +1,98 @@
+#!perl -w
+
+# $Id: constraints.t 1492 2005-04-07 19:19:38Z theory $
+
+##############################################################################
+# Set up the tests.
+##############################################################################
+
+use strict;
+use Test::More tests => 24;
+
+##############################################################################
+# Create a simple class.
+##############################################################################
+
+package Class::Meta::Testing123;
+use strict;
+
+BEGIN {
+ main::use_ok('Class::Meta');
+ main::use_ok('Class::Meta::Types::String');
+}
+
+BEGIN {
+ # Import Test::More functions into this package.
+ Test::More->import;
+ ok( my $cm = Class::Meta->new, "Create new Class::Meta object" );
+
+ # Add a constructor.
+ ok( $cm->add_constructor( name => 'new',
+ create => 1 ),
+ "Add constructor" );
+
+ # Add a required attribute with a default
+ ok( $cm->add_attribute( name => 'req_def',
+ type => 'string',
+ required => 1,
+ default => 'hello',
+ ),
+ "Add required attribute with a default" );
+
+ # Add a once attribute.
+ ok( $cm->add_attribute( name => 'once',
+ type => 'string',
+ once => 1,
+ ),
+ "Add a once attribute" );
+
+ # Add a once attribute with a default.
+ ok( $cm->add_attribute( name => 'once_def',
+ type => 'string',
+ once => 1,
+ default => 'hola',
+ ),
+ "Add a once attribute" );
+
+ # Add a required once attribute with a default.
+ ok( $cm->add_attribute( name => 'once_req',
+ type => 'string',
+ once => 1,
+ required => 1,
+ default => 'bonjour',
+ ),
+ "Add a required once attribute" );
+
+ # Build the class.
+ ok( $cm->build, "Build class" );
+}
+
+package main;
+
+ok( my $obj = Class::Meta::Testing123->new, 'Create new object' );
+
+# Check required attribute.
+is( $obj->req_def, 'hello', 'Check required attribute' );
+ok( $obj->req_def('foo'), 'Set required attribute' );
+is( $obj->req_def, 'foo', 'Check required attribute new value' );
+eval { $obj->req_def(undef) };
+ok( $@, 'Catch required exception' );
+
+# Check once attribute.
+is( $obj->once, undef, "Once is undefined" );
+ok( $obj->once('hee'), "set once attribute" );
+is( $obj->once, 'hee', "Check new once value" );
+eval { $obj->once('ha') };
+ok( $@, 'Catch once exception' );
+
+# Check once with a default.
+is( $obj->once_def, 'hola', 'Check once_def' );
+eval { $obj->once_def('ha') };
+ok( $@, 'Catch once_def exception' );
+is( $obj->once_def, 'hola', "Check once_def hasn't changed" );
+
+# Check required once with a default.
+is( $obj->once_req, 'bonjour', 'Check once_req' );
+eval { $obj->once_req('ha') };
+ok( $@, 'Catch once_req exception' );
+is( $obj->once_req, 'bonjour', "Check once_req hasn't changed" );
Added: packages/libclass-meta-perl/branches/upstream/current/t/constraints_affordance.t
===================================================================
--- packages/libclass-meta-perl/branches/upstream/current/t/constraints_affordance.t 2006-01-04 09:19:20 UTC (rev 1847)
+++ packages/libclass-meta-perl/branches/upstream/current/t/constraints_affordance.t 2006-01-04 09:24:55 UTC (rev 1848)
@@ -0,0 +1,96 @@
+#!perl -w
+
+# $Id: constraints_affordance.t 682 2004-09-28 05:59:10Z theory $
+
+##############################################################################
+# Set up the tests.
+##############################################################################
+
+use strict;
+use Test::More tests => 22;
+
+##############################################################################
+# Create a simple class.
+##############################################################################
+
+package Class::Meta::Testing123;
+use strict;
+
+BEGIN {
+ main::use_ok('Class::Meta');
+ main::use_ok('Class::Meta::Types::String', 'affordance');
+}
+
+BEGIN {
+ # Import Test::More functions into this package.
+ Test::More->import;
+ ok( my $cm = Class::Meta->new, "Create new Class::Meta object" );
+
+ # Add a constructor.
+ ok( $cm->add_constructor( name => 'new',
+ create => 1 ),
+ "Add constructor" );
+
+ # Add a required attribute with a default
+ ok( $cm->add_attribute( name => 'req_def',
+ type => 'string',
+ required => 1,
+ default => 'hello',
+ ),
+ "Add required attribute with a default" );
+
+ # Add a once attribute.
+ ok( $cm->add_attribute( name => 'once',
+ type => 'string',
+ once => 1,
+ ),
+ "Add a once attribute" );
+
+ # Add a once attribute with a default.
+ ok( $cm->add_attribute( name => 'once_def',
+ type => 'string',
+ once => 1,
+ default => 'hola',
+ ),
+ "Add a once attribute" );
+
+ # Add a required once attribute with a default.
+ ok( $cm->add_attribute( name => 'once_req',
+ type => 'string',
+ once => 1,
+ required => 1,
+ default => 'bonjour',
+ ),
+ "Add a required once attribute" );
+
+ # Build the class.
+ ok( $cm->build, "Build class" );
+}
+
+package main;
+
+ok( my $obj = Class::Meta::Testing123->new, 'Create new object' );
+
+# Check required attribute.
+is( $obj->get_req_def, 'hello', 'Check required attribute' );
+ok( $obj->set_req_def('foo'), 'Set required attribute' );
+is( $obj->get_req_def, 'foo', 'Check required attribute new value' );
+eval { $obj->set_req_def(undef) };
+ok( $@, 'Catch required exception' );
+
+# Check once attribute.
+is( $obj->get_once, undef, "Once is undefined" );
+ok( $obj->set_once('hee'), "set once attribute" );
+is( $obj->get_once, 'hee', "Check new once value" );
+eval { $obj->set_once('ha') };
+ok( $@, 'Catch once exception' );
+
+# Check once with a default.
+is( $obj->get_once_def, 'hola', 'Check once_def' );
+eval { $obj->set_once_def('ha') };
+ok( $@, 'Catch once_def exception' );
+
+# Check required once with a default.
+is( $obj->get_once_req, 'bonjour', 'Check once_req' );
+eval { $obj->set_once_def('ha') };
+ok( $@, 'Catch once_req exception' );
Added: packages/libclass-meta-perl/branches/upstream/current/t/constraints_semi_affordance.t
===================================================================
--- packages/libclass-meta-perl/branches/upstream/current/t/constraints_semi_affordance.t 2006-01-04 09:19:20 UTC (rev 1847)
+++ packages/libclass-meta-perl/branches/upstream/current/t/constraints_semi_affordance.t 2006-01-04 09:24:55 UTC (rev 1848)
@@ -0,0 +1,96 @@
+#!perl -w
+
+# $Id: constraints_semi_affordance.t 682 2004-09-28 05:59:10Z theory $
+
+##############################################################################
+# Set up the tests.
+##############################################################################
+
+use strict;
+use Test::More tests => 22;
+
+##############################################################################
+# Create a simple class.
+##############################################################################
+
+package Class::Meta::Testing123;
+use strict;
+
+BEGIN {
+ main::use_ok('Class::Meta');
+ main::use_ok('Class::Meta::Types::String', 'semi-affordance');
+}
+
+BEGIN {
+ # Import Test::More functions into this package.
+ Test::More->import;
+ ok( my $cm = Class::Meta->new, "Create new Class::Meta object" );
+
+ # Add a constructor.
+ ok( $cm->add_constructor( name => 'new',
+ create => 1 ),
+ "Add constructor" );
+
+ # Add a required attribute with a default
+ ok( $cm->add_attribute( name => 'req_def',
+ type => 'string',
+ required => 1,
+ default => 'hello',
+ ),
+ "Add required attribute with a default" );
+
+ # Add a once attribute.
+ ok( $cm->add_attribute( name => 'once',
+ type => 'string',
+ once => 1,
+ ),
+ "Add a once attribute" );
+
+ # Add a once attribute with a default.
+ ok( $cm->add_attribute( name => 'once_def',
+ type => 'string',
+ once => 1,
+ default => 'hola',
+ ),
+ "Add a once attribute" );
+
+ # Add a required once attribute with a default.
+ ok( $cm->add_attribute( name => 'once_req',
+ type => 'string',
+ once => 1,
+ required => 1,
+ default => 'bonjour',
+ ),
+ "Add a required once attribute" );
+
+ # Build the class.
+ ok( $cm->build, "Build class" );
+}
+
+package main;
+
+ok( my $obj = Class::Meta::Testing123->new, 'Create new object' );
+
+# Check required attribute.
+is( $obj->req_def, 'hello', 'Check required attribute' );
+ok( $obj->set_req_def('foo'), 'Set required attribute' );
+is( $obj->req_def, 'foo', 'Check required attribute new value' );
+eval { $obj->set_req_def(undef) };
+ok( $@, 'Catch required exception' );
+
+# Check once attribute.
+is( $obj->once, undef, "Once is undefined" );
+ok( $obj->set_once('hee'), "set once attribute" );
+is( $obj->once, 'hee', "Check new once value" );
+eval { $obj->set_once('ha') };
+ok( $@, 'Catch once exception' );
+
+# Check once with a default.
+is( $obj->once_def, 'hola', 'Check once_def' );
+eval { $obj->set_once_def('ha') };
+ok( $@, 'Catch once_def exception' );
+
+# Check required once with a default.
+is( $obj->once_req, 'bonjour', 'Check once_req' );
+eval { $obj->set_once_def('ha') };
+ok( $@, 'Catch once_req exception' );
Added: packages/libclass-meta-perl/branches/upstream/current/t/ctor.t
===================================================================
--- packages/libclass-meta-perl/branches/upstream/current/t/ctor.t 2006-01-04 09:19:20 UTC (rev 1847)
+++ packages/libclass-meta-perl/branches/upstream/current/t/ctor.t 2006-01-04 09:24:55 UTC (rev 1848)
@@ -0,0 +1,191 @@
+#!/usr/bin/perl
+
+# $Id: ctor.t 2449 2005-12-30 00:07:53Z theory $
+
+##############################################################################
+# Set up the tests.
+##############################################################################
+
+use strict;
+use Test::More tests => 53;
+
+##############################################################################
+# Create a simple class.
+##############################################################################
+
+package Class::Meta::TestPerson;
+use strict;
+
+# Make sure we can load Class::Meta.
+BEGIN { main::use_ok( 'Class::Meta' ) }
+
+BEGIN {
+ # Import Test::More functions into this package.
+ Test::More->import;
+
+ # Create a new Class::Meta object.
+ ok( my $c = Class::Meta->new(package => __PACKAGE__,
+ key => 'person'),
+ "Create CM object" );
+ isa_ok($c, 'Class::Meta');
+
+ # Create a constructor.
+ sub inst { bless {} }
+ ok( my $ctor = $c->add_constructor( name => 'inst',
+ desc => 'The inst constructor',
+ label => 'inst Constructor',
+ create => 0,
+ view => Class::Meta::PUBLIC ),
+ "Create 'inst' ctor");
+ isa_ok($ctor, 'Class::Meta::Constructor');
+
+ # Test its accessors.
+ is( $ctor->name, "inst", "Check inst name" );
+ is( $ctor->desc, "The inst constructor", "Check inst desc" );
+ is( $ctor->label, "inst Constructor", "Check inst label" );
+ ok( $ctor->view == Class::Meta::PUBLIC, "Check inst view" );
+ isa_ok( $ctor->call(__PACKAGE__), __PACKAGE__);
+
+ # Okay, now test to make sure that an attempt to create a constructor
+ # directly fails.
+ eval { my $ctor = Class::Meta::Constructor->new };
+ ok( my $err = $@, "Get constructor construction exception");
+ like( $err, qr/Package 'Class::Meta::TestPerson' cannot create/,
+ "Caught proper exception");
+
+ # Now try it without a name.
+ eval{ $c->add_constructor() };
+ ok( $err = $@, "Caught no name exception");
+ like( $err, qr/Parameter 'name' is required in call to new/,
+ "Caught proper no name exception");
+
+ # Try a duplicately-named constructor.
+ eval{ $c->add_constructor(name => 'inst') };
+ ok( $err = $@, "Caught dupe name exception");
+ like( $err, qr/Method 'inst' already exists in class/,
+ "Caught proper dupe name exception");
+
+ # Try a couple of bogus visibilities.
+ eval { $c->add_constructor( name => 'new_ctor',
+ view => 25) };
+ ok( $err = $@, "Caught bogus view exception");
+ like( $err, qr/Not a valid view parameter: '25'/,
+ "Caught proper bogus view exception");
+ eval { $c->add_constructor( name => 'new_ctor',
+ view => 10) };
+ ok( $err = $@, "Caught another bogus view exception");
+ like( $err, qr/Not a valid view parameter: '10'/,
+ "Caught another proper bogus view exception");
+
+ # Try a bogus caller.
+ eval { $c->add_method( name => 'new_inst',
+ caller => 'foo' ) };
+ ok( $err = $@, "Caught bogus caller exception");
+ like( $err, qr/Parameter caller must be a code reference/,
+ "Caught proper bogus caller exception");
+
+ # Now test all of the defaults.
+ sub new_ctor { 22 }
+ ok( $ctor = $c->add_constructor( name => 'new_ctor',
+ create => 0 ), "Create 'new_ctor'" );
+ isa_ok($ctor, 'Class::Meta::Constructor');
+
+ # Test its accessors.
+ is( $ctor->name, "new_ctor", "Check new_ctor name" );
+ ok( ! defined $ctor->desc, "Check new_ctor desc" );
+ ok( ! defined $ctor->label, "Check new_ctor label" );
+ ok( $ctor->view == Class::Meta::PUBLIC, "Check new_ctor view" );
+ is ($ctor->call(__PACKAGE__), '22',
+ 'Call the new_ctor constructor indirectly' );
+}
+
+# Now try subclassing Class::Meta.
+
+package Class::Meta::SubClass;
+use base 'Class::Meta';
+sub add_constructor {
+ Class::Meta::Constructor->new( shift->SUPER::class, @_);
+}
+
+package Class::Meta::AnotherTest;
+use strict;
+
+BEGIN {
+ # Import Test::More functions into this package.
+ Test::More->import;
+
+ # Create a new Class::Meta object.
+ ok( my $c = Class::Meta::SubClass->new
+ (another => __PACKAGE__), "Create subclassed CM object" );
+ isa_ok($c, 'Class::Meta');
+ isa_ok($c, 'Class::Meta::SubClass');
+
+ sub foo_ctor { bless {} }
+ ok( my $ctor = $c->add_constructor( name => 'foo_ctor',
+ create => 0 ),
+ 'Create subclassed foo_ctor' );
+
+ isa_ok($ctor, 'Class::Meta::Constructor');
+
+ # Test its accessors.
+ is( $ctor->name, "foo_ctor", "Check new foo_ctor name" );
+ ok( ! defined $ctor->desc, "Check new foo_ctor desc" );
+ ok( ! defined $ctor->label, "Check new foo_ctor label" );
+ ok( $ctor->view == Class::Meta::PUBLIC, "Check new foo_ctor view" );
+ isa_ok($ctor->call(__PACKAGE__), __PACKAGE__);
+}
+
+##############################################################################
+# Now try subclassing Class::Meta::Constructor.
+package Class::Meta::Constructor::Sub;
+use base 'Class::Meta::Constructor';
+
+# Make sure we can override new and build.
+sub new { shift->SUPER::new(@_) }
+sub build { shift->SUPER::build(@_) }
+
+sub foo { shift->{foo} }
+
+package main;
+ok( my $cm = Class::Meta->new(
+ constructor_class => 'Class::Meta::Constructor::Sub'
+), "Create Class" );
+ok( my $ctor = $cm->add_constructor(name => 'foo', foo => 'bar'),
+ "Add foo constructor" );
+isa_ok($ctor, 'Class::Meta::Constructor::Sub');
+isa_ok($ctor, 'Class::Meta::Constructor');
+is( $ctor->name, 'foo', "Check an attibute");
+is( $ctor->foo, 'bar', "Check added attibute");
+
+##############################################################################
+# Now try mixing the setting of attributes.
+package Try::Mixed::Constructor;
+use Class::Meta::Types::Perl;
+BEGIN { Test::More->import }
+
+ok $cm = Class::Meta->new, 'Create new Class::Meta object';
+ok $cm->add_constructor(name => 'new'), 'Add a constructor';
+ok $cm->add_attribute(
+ name => 'foo',
+ type => 'scalar',
+), 'Add "foo" attribute';
+
+ok $cm->add_attribute(
+ name => 'bar',
+ type => 'scalar',
+ create => Class::Meta::NONE,
+), 'Add "bar" attribute';
+
+sub bar {
+ my $self = shift;
+ return $self->{bar} unless @_;
+ $self->foo(shift);
+ $self->{bar} = 'set';
+}
+
+ok $cm->build, 'Build the new class';
+
+ok my $try = Try::Mixed::Constructor->new(bar => 'hey'),
+ 'Construct an instance of the new class';
+is $try->bar, 'set', '"bar" should be "set"';
+is $try->foo, 'hey', '"foo" should be "hey"';
Added: packages/libclass-meta-perl/branches/upstream/current/t/custom_type_maker.t
===================================================================
--- packages/libclass-meta-perl/branches/upstream/current/t/custom_type_maker.t 2006-01-04 09:19:20 UTC (rev 1847)
+++ packages/libclass-meta-perl/branches/upstream/current/t/custom_type_maker.t 2006-01-04 09:24:55 UTC (rev 1848)
@@ -0,0 +1,317 @@
+#!/usr/bin/perl -w
+
+# $Id: custom_type_maker.t 682 2004-09-28 05:59:10Z theory $
+
+##############################################################################
+# Set up the tests.
+##############################################################################
+
+package Class::Meta::Testing;
+
+use strict;
+use Test::More tests => 102;
+
+BEGIN {
+ use_ok('Class::Meta');
+ use_ok( 'Class::Meta::Type' );
+ our @ISA = qw(Class::Meta::Attribute);
+}
+
+my $aname = 'foo';
+my $i = 0;
+my ($set, $get, $acc, $mut, $err, $type);
+my $obj = bless {};
+my $attr;
+
+##############################################################################
+# Create a Class::Meta object. We'll use it to create attributes for testing
+# the creation of accessors.
+ok( my $cm = Class::Meta->new, "Create Class::Meta object" );
+
+##############################################################################
+# Try creating a type with the bare minimum number of arguments.
+ok( $type = Class::Meta::Type->add( name => 'Homer Object',
+ key => 'homer',
+ ),
+ "Create Homer data type" );
+
+is( $type, Class::Meta::Type->new('Homer'), 'Check lc conversion on key' );
+is( $type->key, 'homer', "Check homer key" );
+is( $type->name, 'Homer Object', "Check homer name" );
+ok( ! defined $type->check, "Check homer checker" );
+
+# Check to make sure that the accessor is created properly. Start with a
+# simple set_ method.
+ok( $attr = $cm->add_attribute( name => $aname . ++$i, type => 'string'),
+ "Create $aname$i attribute" );
+ok( $type->build(__PACKAGE__, $attr, Class::Meta::GETSET),
+ "Make simple homer set" );
+ok( $acc = UNIVERSAL::can(__PACKAGE__, $aname . $i),
+ "homer accessor exists");
+
+# Test it.
+my $homer = bless {}, 'Homer';
+ok( $obj->$acc($homer), "Set homer value" );
+is( $obj->$acc, $homer, "Check homer value" );
+
+# Check to make sure that the Attribute class accessor coderefs are getting
+# created.
+ok( $set = $type->make_attr_set($attr), "Check homer attr_set" );
+ok( $get = $type->make_attr_get($attr), "Check homer attr_get" );
+
+# Make sure they get and set values correctly.
+is( $get->($obj), $homer, "Check homer getter" );
+$homer = bless {}, 'Homer';
+ok( $set->($obj, $homer), "Check homer setter" );
+is( $get->($obj), $homer, "Check homer getter again" );
+
+##############################################################################
+# Try the same thing with undefs.
+ok( $type = Class::Meta::Type->add( name => 'Bart Object',
+ key => 'bart',
+ check => undef,
+ builder => undef,
+ ),
+ "Create Bart data type" );
+
+is( $type, Class::Meta::Type->new('Bart'), 'Check lc conversion on key' );
+is( $type->key, 'bart', "Check bart key" );
+is( $type->name, 'Bart Object', "Check bart name" );
+ok( ! defined $type->check, "Check bart checker" );
+
+# Check to make sure that the accessor is created properly. Start with a
+# simple set_ method.
+ok( $attr = $cm->add_attribute( name => $aname . ++$i, type => 'string'),
+ "Create $aname$i attribute" );
+ok( $type->build(__PACKAGE__, $attr, Class::Meta::GETSET),
+ "Make simple bart set" );
+ok( $acc = UNIVERSAL::can(__PACKAGE__, $aname . $i),
+ "bart accessor exists");
+
+# Test it.
+my $bart = bless {}, 'Bart';
+ok( $obj->$acc($bart), "Set bart value" );
+is( $obj->$acc, $bart, "Check bart value" );
+
+# Check to make sure that the Attribute class accessor coderefs are getting
+# created.
+ok( $set = $type->make_attr_set($attr), "Check bart attr_set" );
+ok( $get = $type->make_attr_get($attr), "Check bart attr_get" );
+
+# Make sure they get and set values correctly.
+is( $get->($obj), $bart, "Check bart getter" );
+$bart = bless {}, 'Bart';
+ok( $set->($obj, $bart), "Check bart setter" );
+is( $get->($obj), $bart, "Check bart getter again" );
+
+##############################################################################
+# Try creating a type with an object type validation check.
+ok( $type = Class::Meta::Type->add
+ ( name => 'Marge Object',
+ key => 'marge',
+ check => 'Marge',
+ ), "Create Marge data type" );
+
+is( $type, Class::Meta::Type->new('Marge'),
+ 'Check lc conversion on key' );
+is( $type->key, 'marge', "Check marge key" );
+is( $type->name, 'Marge Object', "Check marge name" );
+foreach my $chk (@{ $type->check }) {
+ is( ref $chk, 'CODE', 'Check marge code');
+}
+
+# Check to make sure that the accessor is created properly. Start with a
+# simple set_ method.
+ok( $attr = $cm->add_attribute( name => $aname . ++$i, type => 'string'),
+ "Create $aname$i attribute" );
+ok( $type->build(__PACKAGE__, $attr, Class::Meta::GETSET),
+ "Make simple marge set" );
+ok( $acc = UNIVERSAL::can(__PACKAGE__, $aname . $i),
+ "marge accessor exists");
+
+# Test it.
+my $marge = bless {}, 'Marge';
+ok( $obj->$acc($marge), "Set marge value" );
+is( $obj->$acc, $marge, "Check marge value" );
+
+# Make it fail the checks.
+eval { $obj->$acc('foo') };
+ok( $err = $@, "Got invalid marge error" );
+like( $err, qr/^Value .* is not a valid Marge/,
+ 'correct marge exception' );
+
+# Check to make sure that the Attribute class accessor coderefs are getting
+# created.
+ok( $set = $type->make_attr_set($attr), "Check marge attr_set" );
+ok( $get = $type->make_attr_get($attr), "Check marge attr_get" );
+
+# Make sure they get and set values correctly.
+is( $get->($obj), $marge, "Check marge getter" );
+$marge = bless {}, 'Marge';
+ok( $set->($obj, $marge), "Check marge setter" );
+is( $get->($obj), $marge, "Check marge getter again" );
+
+##############################################################################
+# Try creating a type with affordance accessors.
+ok( $type = Class::Meta::Type->add
+ ( name => 'Lisa Object',
+ key => 'lisa',
+ builder => 'affordance',
+ ), "Create Lisa data type" );
+
+is( $type, Class::Meta::Type->new('Lisa'),
+ 'Check lc conversion on key' );
+is( $type->key, 'lisa', "Check lisa key" );
+is( $type->name, 'Lisa Object', "Check lisa name" );
+ok( ! defined $type->check, "Check lisa checker" );
+
+# Check to make sure that the accessor is created properly. Start with a
+# simple set_ method.
+ok( $attr = $cm->add_attribute( name => $aname . ++$i, type => 'string'),
+ "Create $aname$i attribute" );
+ok( $type->build(__PACKAGE__, $attr, Class::Meta::GETSET),
+ "Make simple lisa set" );
+ok( $mut = UNIVERSAL::can(__PACKAGE__, "set_$aname$i"),
+ "Lisa mutator exists");
+ok( $acc = UNIVERSAL::can(__PACKAGE__, "get_$aname$i"),
+ "Lisa getter exists");
+
+# Test it.
+my $lisa = bless {}, 'Lisa';
+ok( $obj->$mut($lisa), "Set lisa value" );
+is( $obj->$acc, $lisa, "Check lisa value" );
+
+# Check to make sure that the Attribute class accessor coderefs are getting
+# created.
+ok( $set = $type->make_attr_set($attr), "Check lisa attr_set" );
+ok( $get = $type->make_attr_get($attr), "Check lisa attr_get" );
+
+# Make sure they get and set values correctly.
+is( $get->($obj), $lisa, "Check lisa getter" );
+$lisa = bless {}, 'Lisa';
+ok( $set->($obj, $lisa), "Check lisa setter" );
+is( $get->($obj), $lisa, "Check lisa getter again" );
+
+##############################################################################
+# Try creating a type with affordance accessors and an object type validation
+# check.
+ok( $type = Class::Meta::Type->add
+ ( name => 'Maggie Object',
+ key => 'maggie',
+ check => 'Maggie',
+ builder => 'affordance',
+ ), "Create Maggie data type" );
+
+is( $type, Class::Meta::Type->new('Maggie'),
+ 'Check lc conversion on key' );
+is( $type->key, 'maggie', "Check maggie key" );
+is( $type->name, 'Maggie Object', "Check maggie name" );
+foreach my $chk (@{ $type->check }) {
+ is( ref $chk, 'CODE', 'Check maggie code');
+}
+
+# Check to make sure that the accessor is created properly. Start with a
+# simple set_ method.
+ok( $attr = $cm->add_attribute( name => $aname . ++$i, type => 'string'),
+ "Create $aname$i attribute" );
+ok( $type->build(__PACKAGE__, $attr, Class::Meta::GETSET),
+ "Make simple maggie set" );
+ok( $mut = UNIVERSAL::can(__PACKAGE__, "set_$aname$i"),
+ "Maggie mutator exists");
+ok( $acc = UNIVERSAL::can(__PACKAGE__, "get_$aname$i"),
+ "Maggie getter exists");
+
+# Test it.
+my $maggie = bless {}, 'Maggie';
+ok( $obj->$mut($maggie), "Set maggie value" );
+is( $obj->$acc, $maggie, "Check maggie value" );
+
+# Make it fail the checks.
+eval { $obj->$mut('foo') };
+ok( $err = $@, "Got invalid maggie error" );
+like( $err, qr/^Value .* is not a valid Maggie/,
+ 'correct maggie exception' );
+
+# Check to make sure that the Attribute class accessor coderefs are getting
+# created.
+ok( $set = $type->make_attr_set($attr), "Check maggie attr_set" );
+ok( $get = $type->make_attr_get($attr), "Check maggie attr_get" );
+
+# Make sure they get and set values correctly.
+is( $get->($obj), $maggie, "Check maggie getter" );
+$maggie = bless {}, 'Maggie';
+ok( $set->($obj, $maggie), "Check maggie setter" );
+is( $get->($obj), $maggie, "Check maggie getter again" );
+
+##############################################################################
+# Now try one with the checker doing an isa() call.
+ok( $type = Class::Meta::Type->add(
+ name => 'FooBar Object',
+ key => 'foobar',
+ check => 'FooBar'
+), "Create FooBar data type" );
+
+is( ref $type->check, 'ARRAY', "Check foobar check" );
+foreach my $check (@{ $type->check }) {
+ is( ref $check, 'CODE', 'Check foobar code');
+}
+
+##############################################################################
+# Now create our own checker.
+ok( $type = Class::Meta::Type->add(
+ name => 'BarGoo Object',
+ key => 'bargoo',
+ check => sub { 'bargoo' }
+), "Create BarGoo data type" );
+
+is( ref $type->check, 'ARRAY', "Check bargoo check" );
+foreach my $check (@{ $type->check }) {
+ is( ref $check, 'CODE', 'Check bargoo code');
+}
+
+##############################################################################
+# And then try an array of checkers.
+ok( $type = Class::Meta::Type->add(
+ name => 'Doh Object',
+ key => 'doh',
+ check => [sub { 'doh' }, sub { 'doh!' } ]
+), "Create Doh data type" );
+
+is( ref $type->check, 'ARRAY', "Check doh check" );
+foreach my $check (@{ $type->check }) {
+ is( ref $check, 'CODE', 'Check doh code');
+}
+
+##############################################################################
+# And finally, pass in a bogus value for the check parameter.
+eval {
+ $type = Class::Meta::Type->add(
+ name => 'Bogus',
+ key => 'bogus',
+ check => { so => 'bogus' }
+ )
+};
+ok( $err = $@, "Error for bogus check");
+like( $err, qr/Paremter 'check' in call to add\(\) must be a code/,
+ "Proper error for bogus check");
+
+##############################################################################
+# Okay, now try to trigger errors by not passing in required paramters.
+eval { $type = Class::Meta::Type->add(name => 'foo') };
+ok($err = $@, "Error for missing key");
+like( $err, qr/Parameter 'key' is required/, "Proper error for missing key");
+
+eval { $type = Class::Meta::Type->add(key => 'foo') };
+ok($err = $@, "Error for missing name");
+like( $err, qr/Parameter 'name' is required/,
+ "Proper error for missing name");
+
+##############################################################################
+# Now try to create one that exists already.
+eval { $type = Class::Meta::Type->add(name => 'bart', key => 'bart') };
+ok($err = $@, "Error for duplicate key");
+like( $err, qr/Type 'bart' already defined/,
+ "Proper error for duplicate key");
+
+##############################################################################
+# And finally, let's try some custom accessor code refs.
Added: packages/libclass-meta-perl/branches/upstream/current/t/errors.t
===================================================================
--- packages/libclass-meta-perl/branches/upstream/current/t/errors.t 2006-01-04 09:19:20 UTC (rev 1847)
+++ packages/libclass-meta-perl/branches/upstream/current/t/errors.t 2006-01-04 09:24:55 UTC (rev 1848)
@@ -0,0 +1,306 @@
+#!perl -w
+
+# $Id: errors.t 1379 2005-03-09 18:27:05Z theory $
+
+##############################################################################
+# Set up the tests.
+##############################################################################
+use strict;
+use Test::More $] < 5.008
+ ? (skip_all => 'Older Carp lacks @CARP_NOT support')
+ : (tests => 208);
+use File::Spec;
+my $fn = File::Spec->catfile('t', 'errors.t');
+
+BEGIN {
+ main::use_ok('Class::Meta');
+ main::use_ok('Class::Meta::Types::String');
+}
+
+##############################################################################
+# Packages we'll use for testing type errors.
+package NoAttrBuild;
+sub foo {}
+$INC{'NoAttrBuild.pm'} = __FILE__;
+
+package NoAttrGet;
+sub build {}
+$INC{'NoAttrGet.pm'} = __FILE__;
+
+package NoAttrSet;
+sub build {}
+sub build_attr_get {}
+$INC{'NoAttrSet.pm'} = __FILE__;
+
+##############################################################################
+# Create some simple classes.
+##############################################################################
+
+package Class::Meta::Testing;
+
+BEGIN {
+ my $cm = Class::Meta->new;
+ $cm->add_constructor( name => 'new' );
+ $cm->add_attribute( name => 'tail', type => 'string' );
+ $cm->build;
+}
+
+package Class::Meta::TestAbstract;
+ at Class::Meta::TestAbstract::ISA = qw(Class::Meta::Testing);
+
+BEGIN {
+ my $cm = Class::Meta->new(abstract => 1);
+ $cm->build;
+}
+
+package main;
+
+##############################################################################
+# Test Class::Meta errors.
+eval { Class::Meta->new('foobar') };
+chk('odd number to Class::Meta->new',
+ qr/Odd number of parameters in call to new()/);
+
+my $cm = Class::Meta->new( package => 'foobar' );
+eval { Class::Meta->new( package => 'foobar' ) };
+
+##############################################################################
+# Test Class::Meta::Attribute errors.
+eval { Class::Meta::Attribute->new };
+chk('Attribute->new protected',
+ qr/ cannot create Class::Meta::Attribute objects/);
+
+eval { $cm->add_attribute('foo') };
+chk('odd number to Class::Meta::Attribute->new',
+ qr/Odd number of parameters in call to new()/);
+
+eval { $cm->add_attribute(desc => 'foo') };
+chk('Attribute name required',
+ qr/Parameter 'name' is required in call to new()/);
+
+eval { $cm->add_attribute(name => 'fo&o') };
+chk('Invalid attribute name',
+ qr/Attribute 'fo&o' is not a valid attribute name/);
+
+# Create an attribute to use for a few tests. It's private so that there are
+# no accessors.
+ok( my $attr = $cm->add_attribute( name => 'foo',
+ type => 'string',
+ view => Class::Meta::PRIVATE),
+ "Create 'foo' attribute");
+
+eval { $cm->add_attribute( name => 'foo') };
+chk('Attribute exists', qr/Attribute 'foo' already exists/);
+
+for my $p (qw(view authz create context)) {
+ eval { $cm->add_attribute( name => 'hey', $p => 100) };
+ chk("Invalid Attribute $p", qr/Not a valid $p parameter: '100'/);
+}
+
+eval { $attr->get };
+chk('No attribute get method', qr/Cannot get attribute 'foo'/);
+
+eval { $attr->set };
+chk('No attribute set method', qr/Cannot set attribute 'foo'/);
+
+eval { $attr->build };
+chk('Attribute->build protected',
+ qr/ cannot call Class::Meta::Attribute->build/);
+
+##############################################################################
+# Test Class::Meta::Class errors.
+eval { Class::Meta::Class->new };
+chk('Class->new protected',
+ qr/ cannot create Class::Meta::Class objects/);
+
+eval { Class::Meta->new( package => 'foobar' ) };
+chk('Duplicate class', qr/Class object for class 'foobar' already exists/);
+
+eval { $cm->class->build };
+chk('Class->build protected',
+ qr/ cannot call Class::Meta::Class->build/);
+
+##############################################################################
+# Test Class::Meta::Constructor errors.
+my $ctor = $cm->class->constructors('new');
+eval { Class::Meta::Constructor->new };
+chk('Constructor->new protected',
+ qr/ cannot create Class::Meta::Constructor objects/);
+
+eval { $cm->add_constructor('foo') };
+chk('odd number to Class::Meta::Constructor->new',
+ qr/Odd number of parameters in call to new()/);
+
+eval { $cm->add_constructor(desc => 'foo') };
+chk('Constructor name required',
+ qr/Parameter 'name' is required in call to new()/);
+
+eval { $cm->add_constructor(name => 'fo&o') };
+chk('Invalid constructor name',
+ qr/Constructor 'fo&o' is not a valid constructor name/);
+
+# Create an constructor to use for a few tests. It's private so that it
+# can't be called from here.
+ok( $ctor = $cm->add_constructor( name => 'newer',
+ view => Class::Meta::PRIVATE),
+ "Create 'newer' constructor");
+
+eval { $cm->add_constructor( name => 'newer') };
+chk('Constructor exists', qr/Method 'newer' already exists/);
+
+eval { $cm->add_constructor( name => 'hey', view => 100) };
+chk("Invalid Constructor view", qr/Not a valid view parameter: '100'/);
+
+eval { $cm->add_constructor( name => 'hey', caller => 100) };
+chk("Invalid Constructor caller",
+ qr/Parameter caller must be a code reference/);
+
+eval { $ctor->call };
+chk('Cannot call constructor', qr/Cannot call constructor 'newer'/);
+
+eval { $ctor->build };
+chk('Constructor->build protected',
+ qr/ cannot call Class::Meta::Constructor->build/);
+
+# Make sure that the actual constructor's own errors are thrown.
+eval { Class::Meta::Testing->new( foo => 1 ) };
+chk('Invalid parameter to generated constructor',
+ qr/No such attribute 'foo' in Class::Meta::Testing objects/);
+
+##############################################################################
+# Test Class::Meta::Method errors.
+eval { Class::Meta::Method->new };
+chk('Method->new protected',
+ qr/ cannot create Class::Meta::Method objects/);
+
+eval { $cm->add_method('foo') };
+chk('odd number to Class::Meta::Method->new',
+ qr/Odd number of parameters in call to new()/);
+
+eval { $cm->add_method(desc => 'foo') };
+chk('Method name required',
+ qr/Parameter 'name' is required in call to new()/);
+
+eval { $cm->add_method(name => 'fo&o') };
+chk('Invalid method name',
+ qr/Method 'fo&o' is not a valid method name/);
+
+# Create an method to use for a few tests. It's private so that it
+# can't be called from here.
+ok( my $meth = $cm->add_method( name => 'hail',
+ view => Class::Meta::PRIVATE),
+ "Create 'hail' method");
+
+eval { $cm->add_method( name => 'hail') };
+chk('Method exists', qr/Method 'hail' already exists/);
+
+for my $p (qw(view context)) {
+ eval { $cm->add_method( name => 'hey', $p => 100) };
+ chk("Invalid Method $p", qr/Not a valid $p parameter: '100'/);
+}
+
+eval { $cm->add_method( name => 'hey', caller => 100) };
+chk("Invalid Method caller", qr/Parameter caller must be a code reference/);
+
+eval { $meth->call };
+chk('Cannot call method', qr/Cannot call method 'hail'/);
+
+##############################################################################
+# Test Class::Meta::Type errors.
+eval { Class::Meta::Type->new };
+chk(' Missing type', qr/Type argument required/);
+
+eval { Class::Meta::Type->new('foo') };
+chk('Invalid type', qr/Type 'foo' does not exist/);
+
+eval { Class::Meta::Type->add };
+chk('Type key required', qr/Parameter 'key' is required/);
+
+eval { Class::Meta::Type->add( key => 'foo') };
+chk('Type name required', qr/Parameter 'name' is required/);
+
+eval { Class::Meta::Type->add( key => 'string', name => 'string' ) };
+chk('Type already exists', qr/Type 'string' already defined/);
+
+eval { Class::Meta::Type->add( key => 'foo', name => 'foo', check => {}) };
+chk('Invalid type check',
+ qr/Paremter 'check' in call to add\(\) must be a code reference/);
+
+eval { Class::Meta::Type->add( key => 'foo', name => 'foo', check => [{}]) };
+chk('Invalid type check array',
+ qr/Paremter 'check' in call to add\(\) must be a code reference/);
+
+eval {
+ Class::Meta::Type->add( key => 'foo',
+ name => 'foo',
+ builder => 'NoAttrBuild');
+};
+chk('No build', qr/No such function 'NoAttrBuild::build\(\)'/);
+
+eval {
+ Class::Meta::Type->add( key => 'foo',
+ name => 'foo',
+ builder => 'NoAttrGet');
+};
+chk('No attr get', qr/No such function 'NoAttrGet::build_attr_get\(\)'/);
+
+eval {
+ Class::Meta::Type->add( key => 'foo',
+ name => 'foo',
+ builder => 'NoAttrSet');
+};
+chk('No attr set', qr/No such function 'NoAttrSet::build_attr_set\(\)'/);
+
+eval { Class::Meta::Type->build };
+chk('Type->build protected', qr/ cannot call Class::Meta::Type->build/);
+
+eval { Class::Meta->default_error_handler('') };
+chk('Bad error handler', qr/Error handler must be a code reference/);
+
+# Make sure we get an error for invalid class error handlers.
+eval { Class::Meta->new(error_handler => '') };
+chk('Class cannot have invalid error handler',
+ qr/Error handler must be a code reference/);
+
+my $foo;
+Class::Meta->default_error_handler(sub { $foo = shift });
+
+# Some places still use the default, of course.
+eval {
+ Class::Meta::Type->add( key => 'foo',
+ name => 'foo',
+ builder => 'NoAttrSet');
+};
+like( $foo, qr/No such function 'NoAttrSet::build_attr_set\(\)'/,
+ "New error handler");
+
+# Others muse use the original, since the class object was defined before
+# we set up the new default.
+eval { $cm->class->build };
+chk('Class->build still protected',
+ qr/ cannot call Class::Meta::Class->build/);
+
+# Test the abstract attribute.
+is( Class::Meta::Testing->my_class->abstract, 0,
+ "Testing class isn't abstract" );
+is( Class::Meta::TestAbstract->my_class->abstract, 1,
+ "TestAbstract class isn't abstract" );
+
+eval { Class::Meta::TestAbstract->new };
+chk( 'Cannot create from abstract class',
+ qr/^Cannot construct objects of astract class Class::Meta::TestAbstract/);
+
+##############################################################################
+# This function handles all the tests.
+##############################################################################
+sub chk {
+ my ($name, $qr) = @_;
+ # Catch the exception.
+ ok( my $err = $@, "Caught $name error" );
+ # Check its message.
+ like( $err, $qr, "Correct error" );
+ # Make sure it refers to this file.
+ like( $err, qr/(?:at\s+\Q$fn\E|\Q$fn\E\s+at)\s+line/, 'Correct context' );
+ # Make sure it doesn't refer to other Class::Meta files.
+ unlike( $err, qr|lib/Class/Meta|, 'Not incorrect context')
+}
Added: packages/libclass-meta-perl/branches/upstream/current/t/implicit_class_types.t
===================================================================
--- packages/libclass-meta-perl/branches/upstream/current/t/implicit_class_types.t 2006-01-04 09:19:20 UTC (rev 1847)
+++ packages/libclass-meta-perl/branches/upstream/current/t/implicit_class_types.t 2006-01-04 09:24:55 UTC (rev 1848)
@@ -0,0 +1,119 @@
+#!/usr/bin/perl -w
+
+# $Id: implicit_class_types.t 1525 2005-04-13 21:14:20Z theory $
+
+##############################################################################
+# Set up the tests.
+##############################################################################
+
+use strict;
+use Test::More tests => 28;
+
+##############################################################################
+# Create a simple class.
+##############################################################################
+
+package Class::Meta::TestTypes;
+
+BEGIN {
+ $SIG{__DIE__} = \&Carp::confess;
+ main::use_ok( 'Class::Meta');
+ main::use_ok( 'Class::Meta::Type');
+}
+
+BEGIN {
+ use Test::More;
+ ok my $cm = Class::Meta->new(
+ package => __PACKAGE__,
+ key => 'types',
+ name => 'Class::Meta::TestTypes Class',
+ ), "Create TestTypes CM object";
+
+ ok $cm->add_constructor(name => 'new'), "Create TestTypes constctor";
+ ok $cm->build, "Build TestTypes";
+}
+
+##############################################################################
+# Create another class that implicitly uses the other class as a valid data
+# type.
+##############################################################################
+
+package Class::Meta::Another;
+
+BEGIN {
+ use Test::More;
+ ok my $cm = Class::Meta->new(
+ package => __PACKAGE__,
+ key => 'another',
+ name => 'Class::Meta::Another Class',
+ ), "Create Another CM object";
+
+ ok $cm->add_constructor(name => 'new'), "Create Another constctor";
+ ok $cm->add_attribute(
+ name => 'implicit',
+ type => 'types',
+ default => sub { Class::Meta::TestTypes->new },
+ ), 'Add "types" attribute';
+
+ ok $cm->build, "Build Another";
+}
+
+package Class::Meta::YetAnother;
+our $ERROR;
+
+BEGIN {
+ use Test::More;
+ # Replace the validation checker with one of our own.
+ ok( Class::Meta::Type->class_validation_generator( sub {
+ my ($pkg, $type) = @_;
+ return [ sub {
+ my ($value, $object, $attr) = @_;
+ return if UNIVERSAL::isa($value, $pkg);
+ $ERROR = "Value '$value' is not a valid $type";
+ die "hooyah!";
+ } ];
+ }), "Replace class type check generator");
+
+ can_ok 'Class::Meta::Type', 'default_builder';
+ ok( Class::Meta::Type->default_builder('affordance'),
+ "Make affordance accessors for YetAnother objects" );
+
+ ok my $cm = Class::Meta->new(
+ package => __PACKAGE__,
+ key => 'yet_another',
+ name => 'Class::Meta::YetAnother Class',
+ ), "Create YetAnother CM object";
+
+ ok $cm->add_constructor(name => 'new'), "Create Another constctor";
+ ok $cm->add_attribute(
+ name => 'another_implicit',
+ type => 'another',
+ default => sub { Class::Meta::Another->new },
+ ), 'Add "another" attribute';
+
+ ok $cm->build, "Build YetAnother";
+}
+
+package main;
+
+# Check that the "another" class was added as a data type.
+ok my $an = Class::Meta::Another->new, 'Create Another object';
+isa_ok $an->implicit, 'Class::Meta::TestTypes';
+ok $an->implicit(Class::Meta::TestTypes->new), 'Replace TestTypes object';
+isa_ok $an->implicit, 'Class::Meta::TestTypes';
+eval { $an->implicit('foo') };
+ok my $err = $@, "Catch TestTypes exception";
+like $err, qr/Value 'foo' is not a valid Class::Meta::TestTypes/,
+ "Check TestTypes exception string";
+
+# Now try with our replaced class check generator.
+ok my $yet = Class::Meta::YetAnother->new, 'Create YetAnother object';
+isa_ok $yet->get_another_implicit, 'Class::Meta::Another';
+is $Class::Meta::YetAnother::ERROR, undef, "Check for undef error";
+eval { $yet->set_another_implicit('foo') };
+ok $err = $@, "Catch Another exception";
+like $err, qr/hooyah\!/,
+ "Check Another exception string";
+is $Class::Meta::YetAnother::ERROR,
+ "Value 'foo' is not a valid Class::Meta::Another",
+ "Check for defined error";
Property changes on: packages/libclass-meta-perl/branches/upstream/current/t/implicit_class_types.t
___________________________________________________________________
Name: svn:executable
+
Added: packages/libclass-meta-perl/branches/upstream/current/t/inherit.t
===================================================================
--- packages/libclass-meta-perl/branches/upstream/current/t/inherit.t 2006-01-04 09:19:20 UTC (rev 1847)
+++ packages/libclass-meta-perl/branches/upstream/current/t/inherit.t 2006-01-04 09:24:55 UTC (rev 1848)
@@ -0,0 +1,317 @@
+#!perl -w
+
+# $Id: inherit.t 801 2004-10-28 22:33:20Z theory $
+
+##############################################################################
+# Set up the tests.
+##############################################################################
+
+use strict;
+use Test::More tests => 129;
+
+##############################################################################
+# Create a simple class.
+##############################################################################
+
+package Test::One;
+
+BEGIN {
+ Test::More->import;
+ use_ok( 'Class::Meta');
+ use_ok( 'Class::Meta::Types::Numeric', 'affordance');
+ use_ok( 'Class::Meta::Types::String', 'affordance');
+}
+
+BEGIN {
+ ok( my $c = Class::Meta->new( key => 'one',
+ package => __PACKAGE__,
+ name => 'One Class',
+ desc => 'Test One Class.'),
+ "Create One's Class::Meta" );
+
+ # Add a constructor.
+ ok( $c->add_constructor( name => 'new',
+ create => 1 ),
+ "Create One's construtor" );
+
+ # Add a couple of attributes with created methods.
+ ok( $c->add_attribute( name => 'id',
+ view => Class::Meta::PUBLIC,
+ authz => Class::Meta::READ,
+ create => Class::Meta::GET,
+ type => 'integer',
+ label => 'ID',
+ desc => "The object's ID.",
+ required => 1,
+ default => 12,
+ ),
+ "Create One's ID attribute" );
+
+ ok( $c->add_attribute( name => 'name',
+ view => Class::Meta::PUBLIC,
+ authz => Class::Meta::RDWR,
+ create => Class::Meta::GETSET,
+ type => 'string',
+ label => 'Name',
+ desc => "The object's name.",
+ required => 1,
+ default => 'foo',
+ ),
+ "Create One's name attribute" );
+
+ ok( $c->add_attribute( name => 'count',
+ view => Class::Meta::PUBLIC,
+ authz => Class::Meta::RDWR,
+ create => Class::Meta::GETSET,
+ context => Class::Meta::CLASS,
+ type => 'integer',
+ label => 'Count',
+ desc => "The object count.",
+ default => 0,
+ ),
+ "Create One's count attribute" );
+
+ ok( $c->add_method(name => 'foo'), "Add foo method to One" );
+ ok( $c->add_method(name => 'bar'), "Add bar method to One" );
+ ok( $c->build, "Build Test::One" );
+}
+sub foo { __PACKAGE__ }
+sub bar { __PACKAGE__ }
+
+package Test::Two;
+use base 'Test::One';
+
+BEGIN {
+ Test::More->import;
+ main::use_ok( 'Class::Meta');
+}
+
+BEGIN {
+ ok( my $c = Class::Meta->new( key => 'two',
+ package => __PACKAGE__,
+ name => 'Two Class',
+ desc => 'Test Two Class.'),
+ "Create Two's Class::Meta" );
+
+ # Add another constructor.
+ ok( $c->add_constructor(name => 'two_new'), "Create Two's ctor" );
+
+ # Add an attribute.
+ ok( $c->add_attribute( name => 'description',
+ view => Class::Meta::PUBLIC,
+ authz => Class::Meta::RDWR,
+ create => Class::Meta::GETSET,
+ type => 'string',
+ label => 'Description',
+ desc => "The object's description.",
+ required => 1,
+ default => '',
+ ),
+ "Create Two's description attribute" );
+
+ # Make sure that adding an attribute with the same name as in a parent class
+ # causes an exception.
+ eval {
+ $c->add_attribute( name => 'name',
+ view => Class::Meta::PUBLIC,
+ authz => Class::Meta::RDWR,
+ create => Class::Meta::GETSET,
+ type => 'string',
+ label => 'Name',
+ desc => "The object's name.",
+ required => 1,
+ default => '',
+ )
+ };
+
+ ok( my $err = $@, "Catch duplicate attribute exception" );
+ like( $err, qr/Attribute 'name' already exists in class 'Test::One'/,
+ "Check error message" );
+
+ # But allow an attribute with the same name to be added using the override
+ # parameter.
+ $c->add_attribute( name => 'name',
+ view => Class::Meta::PUBLIC,
+ authz => Class::Meta::RDWR,
+ create => Class::Meta::GETSET,
+ type => 'string',
+ label => 'Overridden Name',
+ desc => "The object's name.",
+ required => 1,
+ default => '',
+ override => 1,
+ );
+
+ # Add a method.
+ ok( $c->add_method(name => 'woah'), "Add woah method to One" );
+ # Add an overriding method.
+ ok( $c->add_method(name => 'bar'), "Add bar method to Two" );
+
+ ok( $c->build, "Build Test::Two" );
+}
+
+sub woah { __PACKAGE__ }
+sub bar { __PACKAGE__ }
+
+package main;
+
+# Check out Test::One's class object.
+ok( my $one_class = Test::One->my_class, "Get One's Class object" );
+isa_ok( $one_class, 'Class::Meta::Class' );
+ok( $one_class->is_a('Test::One'), "Check it's for Test::One" );
+ok( ! $one_class->is_a('Test::Two'), "Check it's not for Test::Two" );
+ok( ! $one_class->parents, "Check that One has no parents" );
+
+# Check One's attributes.
+ok( my @one_attributes = $one_class->attributes, "Get attributes" );
+is( scalar @one_attributes, 3, "Check for three attributes" );
+is( $one_attributes[0]->name, 'id', "Check for id attribute" );
+is( $one_attributes[1]->name, 'name', "Check for name attribute" );
+is( $one_attributes[2]->name, 'count', "Check for count attribute" );
+
+# Check out Test::Two's class object.
+ok( my $two_class = Test::Two->my_class, "Get Two's Class object" );
+isa_ok( $two_class, 'Class::Meta::Class' );
+ok( $two_class->is_a('Test::One'), "Check it's for Test::One" );
+ok( $two_class->is_a('Test::Two'), "Check it's for Test::Two" );
+is( ($two_class->parents)[0], $one_class, "Check that Two has One for a parent" );
+
+# Check Two's attributes.
+ok( my @two_attributes = $two_class->attributes, "Get attributes" );
+is( scalar @two_attributes, 4, "Check for four attributes" );
+is( $two_attributes[0]->name, 'id', "Check for id attribute" );
+is( $one_attributes[0], $two_attributes[0], "Check for same id as One" );
+is( $two_attributes[1]->name, 'name', "Check for name attribute" );
+isnt( $one_attributes[1], $two_attributes[1], "Check for different name than One" );
+is( $two_attributes[1]->label, 'Overridden Name', 'Check for overridden name' );
+is( $two_attributes[2]->name, 'count', "Check for count attribute" );
+is( $one_attributes[2], $two_attributes[2], "Check for same count as One" );
+is( $two_attributes[3]->name, 'description', "Check for description attribute" );
+
+# Make sure that One's new() constructor works.
+ok( my $one = Test::One->new( name => 'foo'), "Construct One object" );
+isa_ok( $one, 'Test::One' );
+eval { Test::One->new(name => 'foo', description => 'bar') };
+ok( my $err = $@, 'Catch bad One parameter exception' );
+like( $err, qr/No such attribute 'description' in Test::One/,
+ 'Check bad One exception' );
+
+# Make sure that One's new constructor object works.
+ok( my $one_new = $one_class->constructors('new'), "Get one's new object" );
+ok( $one = $one_new->call('Test::One'), "Create new one indirectly" );
+isa_ok( $one, 'Test::One' );
+
+# Check One's attribute accessors.
+is( $one->get_name, 'foo', "Check One's name" );
+ok( $one->set_name('hello'), "Set One's name" );
+is( $one->get_name, 'hello', "Check One's new name" );
+is( $one->get_id, 12, "Check One's id" );
+eval { $one->set_id(1) };
+ok( $err = $@, "Check for set_id exception" );
+
+# Check One's attribute object accessors.
+is( $one_attributes[0]->get($one), 12, "Check attr call id" );
+ok( $one_attributes[1]->set($one, 'howdy'), "Call set on One" );
+is( $one_attributes[1]->get($one), 'howdy', "Call get on One" );
+
+# Check One's methods.
+is( $one->foo, 'Test::One', "Check One->foo" );
+is( $one->bar, 'Test::One', "Check One->bar" );
+eval { $one->woah };
+ok( $err = $@, "Catch One->woah exception" );
+
+# Check One's method objects.
+ok( my $foo = $one_class->methods('foo'), "Get foo method object" );
+is( $foo->package, 'Test::One', "Check One foo's package" );
+is( $foo->call($one), 'Test::One', "Check One foo's call" );
+ok( my $bar = $one_class->methods('bar'), "Get bar method object" );
+is( $bar->package, 'Test::One', "Check One bar's package" );
+is( $bar->call($one), 'Test::One', "Check One bar's call" );
+
+# Make sure that Two inherits new() and works with its attributes.
+ok( my $two = Test::Two->new( name => 'foo'), "Construct Two object" );
+isa_ok( $two, 'Test::Two' );
+ok( $two = Test::Two->new(name => 'foo', description => 'bar'),
+ "Construct another Two object" );
+isa_ok( $two, 'Test::Two' );
+
+# Make sure that One's new constructor object works.
+ok( my $two_new = $two_class->constructors('new'), "Get two's new object" );
+is( $two_new, $one_new, 'Check for the same new as in one' );
+ok( $two = $one_new->call('Test::Two'), "Create new two indirectly" );
+isa_ok( $two, 'Test::Two' );
+
+# make sure that Two's own constructor works, too.
+ok( $two = Test::Two->two_new(name => 'Larry'),
+ "Construct another Two object" );
+isa_ok( $two, 'Test::Two' );
+
+# Check Two's attribute accessors.
+is( $two->get_id, 12, "Check Two's id" );
+eval { $two->set_id(1) };
+ok( $err = $@, "Check for set_id exception" );
+is( $two->get_name, 'Larry', "Check Two's name" );
+ok( $two->set_name('hello'), "Set Two's name" );
+is( $two->get_name, 'hello', "Check Two's new name" );
+
+is( $two->get_count, 0, "Check Two's count" );
+ok( $two->set_count(12), "Set Two's count" );
+is( $two->get_count, 12, "Check Two's new count" );
+
+is( $two->get_description, '', "Check Two's description" );
+ok( $two->set_description('yello'), "Set Two's description" );
+is( $two->get_description, 'yello', "Check Two's new description" );
+
+# Check Two's attribute object accessors.
+is( $two_attributes[0]->get($two), 12, "Check attr call id" );
+
+is( $two_attributes[1]->get($two), 'hello', "Call get name on Two" );
+ok( $two_attributes[1]->set($two, 'howdy'), "Call set name on Two" );
+is( $two_attributes[1]->get($two), 'howdy', "Call get name on Two again" );
+
+is( $two_attributes[2]->get($two), 12, "Call get count on Two" );
+ok( $two_attributes[2]->set($two, 10), "Call set count on Two" );
+is( $two_attributes[2]->get($two), 10, "Call get count on Two again" );
+
+is( $two_attributes[3]->get($two), 'yello', "Call get on Two" );
+ok( $two_attributes[3]->set($two, 'rowdy'), "Call set on Two" );
+is( $two_attributes[3]->get($two), 'rowdy', "Call get on Two again" );
+
+# Make sure that the count class attribute accessors work as expected.
+is( $one->get_count, 10, 'Check one get_count' );
+is( $two->get_count, 10, 'Check two get_count' );
+is( Test::One->get_count, 10, 'Check Test::One get_count' );
+is( Test::Two->get_count, 10, 'Check Test::Two get_count' );
+
+ok( Test::One->set_count(22), 'Set One count' );
+is( $one->get_count, 22, 'Check one get_count again' );
+is( $two->get_count, 22, 'Check two get_count again' );
+is( Test::One->get_count, 22, 'Check Test::One get_count again' );
+is( Test::Two->get_count, 22, 'Check Test::Two get_count again' );
+
+ok( $one->set_count(35), 'Set $one count' );
+is( $one->get_count, 35, 'Check one get_count three' );
+is( $two->get_count, 35, 'Check two get_count three' );
+is( Test::One->get_count, 35, 'Check Test::One get_count three' );
+is( Test::Two->get_count, 35, 'Check Test::Two get_count three' );
+
+# Check Two's methods.
+is( $two->foo, 'Test::One', 'Check Two->foo' );
+is( $two->bar, 'Test::Two', 'Check Two->bar' );
+is( $two->woah, 'Test::Two', 'Check Two->woah' );
+
+# Check Two's methods.
+is( $two->foo, 'Test::One', "Check Two->foo" );
+is( $two->bar, 'Test::Two', "Check Two->bar" );
+is( $two->woah, 'Test::Two', "Check Two->woah" );
+
+# Check Two's method objects.
+ok( $foo = $two_class->methods('foo'), "Get foo method object" );
+is( $foo->package, 'Test::One', "Check Two foo's package" );
+is( $foo->call($two), 'Test::One', "Check Two foo's call" );
+ok( $bar = $two_class->methods('bar'), "Get bar method object" );
+is( $bar->package, 'Test::Two', "Check Two bar's package" );
+is( $bar->call($two), 'Test::Two', "Check Two bar's call" );
+ok( my $woah = $two_class->methods('woah'), "Get woah method object" );
+is( $woah->package, 'Test::Two', "Check Two woah's package" );
+is( $woah->call($two), 'Test::Two', "Check Two woah's call" );
Added: packages/libclass-meta-perl/branches/upstream/current/t/meth.t
===================================================================
--- packages/libclass-meta-perl/branches/upstream/current/t/meth.t 2006-01-04 09:19:20 UTC (rev 1847)
+++ packages/libclass-meta-perl/branches/upstream/current/t/meth.t 2006-01-04 09:24:55 UTC (rev 1848)
@@ -0,0 +1,179 @@
+#!/usr/bin/perl
+
+# $Id: meth.t 2404 2005-12-17 03:40:23Z theory $
+
+##############################################################################
+# Set up the tests.
+##############################################################################
+
+use strict;
+use Test::More tests => 54;
+
+##############################################################################
+# Create a simple class.
+##############################################################################
+
+package Class::Meta::TestPerson;
+use strict;
+
+# Make sure we can load Class::Meta.
+BEGIN { main::use_ok( 'Class::Meta' ) }
+
+BEGIN {
+ # Import Test::More functions into this package.
+ Test::More->import;
+
+ # Create a new Class::Meta object.
+ ok( my $c = Class::Meta->new(key => 'person',
+ package => __PACKAGE__),
+ "Create CM object" );
+
+ isa_ok($c, 'Class::Meta');
+
+ # Create a new method with all of the parameters set.
+ sub foo_meth { 'foo' }
+ ok( my $meth = $c->add_method(
+ name => 'foo_meth',
+ desc => 'The foo method',
+ label => 'Foo method',
+ context => Class::Meta::CLASS,
+ view => Class::Meta::PUBLIC
+ ), 'Create foo_meth' );
+
+ isa_ok($meth, 'Class::Meta::Method');
+
+ # Test its accessors.
+ is( $meth->name, "foo_meth", "Check foo_meth name" );
+ is( $meth->desc, "The foo method", "Check foo_meth desc" );
+ is( $meth->label, "Foo method", "Check foo_meth label" );
+ ok( $meth->view == Class::Meta::PUBLIC, "Check foo_meth view" );
+ ok( $meth->context == Class::Meta::CLASS, "Check foo_meth context" );
+ is ($meth->call(__PACKAGE__), 'foo', 'Call the foo_meth method' );
+
+ # Okay, now test to make sure that an attempt to create a method directly
+ # fails.
+ eval { my $meth = Class::Meta::Method->new };
+ ok( my $err = $@, "Get method construction exception");
+ like( $err, qr/Package 'Class::Meta::TestPerson' cannot create/,
+ "Caught proper exception");
+
+ # Now try it without a name.
+ eval{ $c->add_method() };
+ ok( $err = $@, "Caught no name exception");
+ like( $err, qr/Parameter 'name' is required in call to new/,
+ "Caught proper no name exception");
+
+ # Try a duplicately-named method.
+ eval{ $c->add_method(name => 'foo_meth') };
+ ok( $err = $@, "Caught dupe name exception");
+ like( $err, qr/Method 'foo_meth' already exists in class/,
+ "Caught proper dupe name exception");
+
+ # Try a of bogus visibility.
+ eval { $c->add_method( name => 'new_meth',
+ view => 10) };
+ ok( $err = $@, "Caught another bogus view exception");
+ like( $err, qr/Not a valid view parameter: '10'/,
+ "Caught another proper bogus view exception");
+
+ # Try a of bogus context.
+ eval { $c->add_method( name => 'new_meth',
+ context => 10) };
+ ok( $err = $@, "Caught another bogus context exception");
+ like( $err, qr/Not a valid context parameter: '10'/,
+ "Caught another proper bogus context exception");
+
+ # Try a bogus caller.
+ eval { $c->add_method( name => 'new_meth',
+ caller => 'foo' ) };
+ ok( $err = $@, "Caught bogus caller exception");
+ like( $err, qr/Parameter caller must be a code reference/,
+ "Caught proper bogus caller exception");
+
+ # Now test all of the defaults.
+ sub new_meth { 22 }
+ ok( $meth = $c->add_method( name => 'new_meth' ), "Create 'new_meth'" );
+ isa_ok($meth, 'Class::Meta::Method');
+
+ # Test its accessors.
+ is( $meth->name, "new_meth", "Check new_meth name" );
+ ok( ! defined $meth->desc, "Check new_meth desc" );
+ ok( ! defined $meth->label, "Check new_meth label" );
+ ok( $meth->view == Class::Meta::PUBLIC, "Check new_meth view" );
+ ok( $meth->context == Class::Meta::OBJECT, "Check new_meth context" );
+ is( $meth->call(__PACKAGE__), '22', 'Call the new_meth method' );
+
+ # Now install a method.
+ ok( $meth = $c->add_method(
+ name => 'implicit',
+ code => sub { return 'implicitly' },
+ ), 'Define a method');
+ isa_ok($meth, 'Class::Meta::Method');
+
+ ok( $c->build, 'Build the class' );
+ can_ok( __PACKAGE__, 'implicit' );
+ is( __PACKAGE__->implicit, 'implicitly',
+ 'It should be the method we installed' );
+ is( $meth->call(__PACKAGE__), 'implicitly',
+ 'and we should be able to call it indirectly' );
+}
+
+# Now try subclassing Class::Meta.
+
+package Class::Meta::SubClass;
+use base 'Class::Meta';
+sub add_method {
+ Class::Meta::Method->new( shift->SUPER::class, @_);
+}
+
+package Class::Meta::AnotherTest;
+use strict;
+
+BEGIN {
+ # Import Test::More functions into this package.
+ Test::More->import;
+
+ # Create a new Class::Meta object.
+ ok( my $c = Class::Meta::SubClass->new(
+ key => 'another',
+ package => __PACKAGE__
+ ), "Create subclassed CM object" );
+
+ isa_ok($c, 'Class::Meta');
+ isa_ok($c, 'Class::Meta::SubClass');
+ sub foo_meth { 100 }
+ ok( my $meth = $c->add_method( name => 'foo_meth'),
+ 'Create subclassed foo_meth' );
+
+ isa_ok($meth, 'Class::Meta::Method');
+
+ # Test its accessors.
+ is( $meth->name, "foo_meth", "Check new foo_meth name" );
+ ok( ! defined $meth->desc, "Check new foo_meth desc" );
+ ok( ! defined $meth->label, "Check new foo_meth label" );
+ ok( $meth->view == Class::Meta::PUBLIC, "Check new foo_meth view" );
+ ok( $meth->context == Class::Meta::OBJECT, "Check new foo_meth context" );
+ is( $meth->call(__PACKAGE__), '100', 'Call the new foo_meth method' );
+}
+
+##############################################################################
+# Now try subclassing Class::Meta::Method.
+package Class::Meta::Method::Sub;
+use base 'Class::Meta::Method';
+
+# Make sure we can override new and build.
+sub new { shift->SUPER::new(@_) }
+sub build { shift->SUPER::build(@_) }
+
+sub foo { shift->{foo} }
+
+package main;
+ok( my $cm = Class::Meta->new( method_class => 'Class::Meta::Method::Sub'),
+ "Create Class" );
+ok( my $meth = $cm->add_method(name => 'foo', foo => 'bar'),
+ "Add foo method" );
+isa_ok($meth, 'Class::Meta::Method::Sub');
+isa_ok($meth, 'Class::Meta::Method');
+is( $meth->name, 'foo', "Check an attibute");
+is( $meth->foo, 'bar', "Check added attibute");
+
Added: packages/libclass-meta-perl/branches/upstream/current/t/pod-coverage.t
===================================================================
--- packages/libclass-meta-perl/branches/upstream/current/t/pod-coverage.t 2006-01-04 09:19:20 UTC (rev 1847)
+++ packages/libclass-meta-perl/branches/upstream/current/t/pod-coverage.t 2006-01-04 09:24:55 UTC (rev 1848)
@@ -0,0 +1,11 @@
+#!perl -w
+
+# $Id: pod-coverage.t 682 2004-09-28 05:59:10Z theory $
+
+use strict;
+use Test::More;
+use File::Spec;
+eval "use Test::Pod::Coverage 0.08";
+plan skip_all => "Test::Pod::Coverage required for testing POD coverage" if $@;
+
+all_pod_coverage_ok();
Added: packages/libclass-meta-perl/branches/upstream/current/t/pod.t
===================================================================
--- packages/libclass-meta-perl/branches/upstream/current/t/pod.t 2006-01-04 09:19:20 UTC (rev 1847)
+++ packages/libclass-meta-perl/branches/upstream/current/t/pod.t 2006-01-04 09:24:55 UTC (rev 1848)
@@ -0,0 +1,9 @@
+#!/usr/bin/perl -w
+
+# $Id: pod.t 682 2004-09-28 05:59:10Z theory $
+
+use strict;
+use Test::More;
+eval "use Test::Pod 1.00";
+plan skip_all => "Test::Pod 1.00 required for testing POD" if $@;
+all_pod_files_ok();
Added: packages/libclass-meta-perl/branches/upstream/current/t/types.t
===================================================================
--- packages/libclass-meta-perl/branches/upstream/current/t/types.t 2006-01-04 09:19:20 UTC (rev 1847)
+++ packages/libclass-meta-perl/branches/upstream/current/t/types.t 2006-01-04 09:24:55 UTC (rev 1848)
@@ -0,0 +1,276 @@
+#!/usr/bin/perl -w
+
+# $Id: types.t 802 2004-10-28 23:21:10Z theory $
+
+##############################################################################
+# Set up the tests.
+##############################################################################
+
+use strict;
+use Test::More tests => 58;
+
+##############################################################################
+# Create a simple class.
+##############################################################################
+
+package Class::Meta::TestTypes;
+use strict;
+
+BEGIN {
+ $SIG{__DIE__} = \&Carp::confess;
+ main::use_ok( 'Class::Meta');
+ main::use_ok( 'Class::Meta::Type');
+ main::use_ok( 'Class::Meta::Types::Numeric');
+ main::use_ok( 'Class::Meta::Types::Perl');
+ main::use_ok( 'Class::Meta::Types::String');
+ main::use_ok( 'Class::Meta::Types::Boolean');
+ @Bart::ISA = qw(Simpson);
+}
+
+BEGIN {
+ # Add the new data type.
+ Class::Meta::Type->add( key => 'simpson',
+ name => 'Simpson',
+ desc => 'An Simpson object.',
+ check => 'Simpson',
+ );
+
+ my $c = Class::Meta->new(package => __PACKAGE__,
+ key => 'types',
+ name => 'Class::Meta::TestTypes Class',
+ desc => 'Just for testing Class::Meta.'
+ );
+ $c->add_constructor(name => 'new');
+
+ $c->add_attribute( name => 'name',
+ view => Class::Meta::PUBLIC,
+ type => 'string',
+ length => 256,
+ label => 'Name',
+ field => 'text',
+ desc => "The person's name.",
+ required => 0,
+ default => undef,
+ create => Class::Meta::GETSET
+ );
+ $c->add_attribute( name => 'age',
+ view => Class::Meta::PUBLIC,
+ type => 'integer',
+ label => 'Age',
+ field => 'text',
+ desc => "The person's age.",
+ required => 0,
+ default => undef,
+ create => Class::Meta::GETSET
+ );
+ $c->add_attribute( name => 'alive',
+ view => Class::Meta::PUBLIC,
+ type => 'bool',
+ label => 'Living',
+ field => 'checkbox',
+ desc => "Is the person alive?",
+ required => 0,
+ default => 1,
+ );
+ $c->add_attribute( name => 'whole',
+ view => Class::Meta::PUBLIC,
+ type => 'whole',
+ label => 'A whole number.',
+ field => 'text',
+ desc => "A whole number.",
+ required => 0,
+ default => undef,
+ create => Class::Meta::GETSET
+ );
+ $c->add_attribute( name => 'dec',
+ view => Class::Meta::PUBLIC,
+ type => 'decimal',
+ label => 'A decimal number.',
+ field => 'text',
+ desc => "A decimal number.",
+ required => 0,
+ default => undef,
+ create => Class::Meta::GETSET
+ );
+ $c->add_attribute( name => 'real',
+ view => Class::Meta::PUBLIC,
+ type => 'real',
+ label => 'A real number.',
+ field => 'text',
+ desc => "A real number.",
+ required => 0,
+ default => undef,
+ create => Class::Meta::GETSET
+ );
+ $c->add_attribute( name => 'float',
+ view => Class::Meta::PUBLIC,
+ type => 'float',
+ label => 'A float.',
+ field => 'text',
+ desc => "A floating point number.",
+ required => 0,
+ default => undef,
+ create => Class::Meta::GETSET
+ );
+ $c->add_attribute( name => 'scalar',
+ view => Class::Meta::PUBLIC,
+ type => 'scalarref',
+ label => 'A scalar.',
+ field => 'text',
+ desc => "A scalar reference.",
+ required => 0,
+ default => undef,
+ create => Class::Meta::GETSET
+ );
+ $c->add_attribute( name => 'array',
+ view => Class::Meta::PUBLIC,
+ type => 'array',
+ label => 'A array.',
+ field => 'text',
+ desc => "A array reference.",
+ required => 0,
+ default => undef,
+ create => Class::Meta::GETSET
+ );
+ $c->add_attribute( name => 'hash',
+ view => Class::Meta::PUBLIC,
+ type => 'hash',
+ label => 'A hash.',
+ field => 'text',
+ desc => "A hash reference.",
+ required => 0,
+ default => undef,
+ create => Class::Meta::GETSET
+ );
+ $c->add_attribute( name => 'simpson',
+ view => Class::Meta::PUBLIC,
+ type => 'simpson',
+ label => 'A Simpson Object',
+ field => 'text',
+ desc => 'A Simpson object.',
+ required => 0,
+ default => sub { bless {}, 'Simpson' },
+ create => Class::Meta::GETSET
+ );
+
+ $c->build;
+}
+
+
+##############################################################################
+# Do the tests.
+##############################################################################
+
+package main;
+# Instantiate a base class object and test its accessors.
+ok( my $t = Class::Meta::TestTypes->new, 'Class::Meta::TestTypes->new');
+
+# Grab its metadata object.
+ok( my $class = $t->my_class, "Get the Class::Meta::Class object" );
+
+# Test the is_a() method.
+ok( $class->is_a('Class::Meta::TestTypes'), 'Class isa TestTypes');
+
+# Test the key methods.
+is( $class->key, 'types', 'Key is correct');
+
+# Test the name method.
+is( $class->name, 'Class::Meta::TestTypes Class', "Name is correct");
+
+# Test the description methods.
+is( $class->desc, 'Just for testing Class::Meta.',
+ "Description is correct");
+
+# Test string.
+ok( $t->name('David'), 'name to "David"' );
+is( $t->name, 'David', 'name is "David"' );
+eval { $t->name([]) };
+ok( my $err = $@, 'name to array ref croaks' );
+like( $err, qr/^Value .* is not a valid string/, 'correct string exception' );
+
+# Test boolean.
+ok( $t->alive, 'alive true');
+is( $t->alive(0), 0, 'alive off');
+ok( !$t->alive, 'alive false');
+ok( $t->alive(1), 'alive on' );
+ok( $t->alive, 'alive true again');
+ok( my $alive = $class->attributes('alive'), "Get alive attribute object" );
+is( $alive->type, 'boolean', "Check that the alias was converted" );
+
+# Test whole number.
+eval { $t->whole(0) };
+ok( $err = $@, 'whole to 0 croaks' );
+like( $err, qr/^Value '0' is not a valid whole number/,
+ 'correct whole number exception' );
+ok( $t->whole(1), 'whole to 1.');
+
+# Test integer.
+eval { $t->age(0.5) };
+ok( $err = $@, 'age to 0.5 croaks');
+like( $err, qr/^Value '0\.5' is not a valid integer/,
+ 'correct integer exception' );
+ok( $t->age(10), 'age to 10.');
+
+# Test decimal.
+eval { $t->dec('+') };
+ok( $err = $@, 'dec to "+" croaks');
+like( $err, qr/^Value '\+' is not a valid decimal number/,
+ 'correct decimal exception' );
+ok( $t->dec(3.14), 'dec to 3.14.');
+
+# Test real.
+eval { $t->real('+') };
+ok( $err = $@, 'real to "+" croaks');
+like( $err, qr/^Value '\+' is not a valid real number/,
+ 'correct real exception' );
+ok( $t->real(123.4567), 'real to 123.4567.');
+ok( $t->real(-123.4567), 'real to -123.4567.');
+
+# Test float.
+eval { $t->float('+') };
+ok( $err = $@, 'float to "+" croaks');
+like( $err, qr/^Value '\+' is not a valid floating point number/,
+ 'correct float exception' );
+ok( $t->float(1.23e99), 'float to 1.23e99.');
+
+# Test OBJECT with default specifying object type.
+ok( my $simpson = $t->simpson, 'simpson' );
+isa_ok($simpson, 'Simpson');
+eval { $t->simpson('foo') };
+ok( $err = $@, 'simpson to "foo" croaks' );
+like( $err, qr/^Value 'foo' is not a valid Simpson/,
+ 'correct object exception' );
+
+# Try a wrong object.
+eval { $t->simpson($t) };
+ok( $err = $@, 'simpson to \$fh croaks' );
+like( $err, qr/^Value '.*' is not a valid Simpson/,
+ 'correct object exception' );
+ok( $t->simpson($simpson), 'simpson to \$simpson.');
+
+# Try a subclass.
+my $bart = bless {}, 'Bart';
+ok( $t->simpson($bart), "Set simpson to a subclass." );
+isa_ok($t->simpson, 'Bart', "Check subclass" );
+ok( $t->simpson($simpson), 'simpson to \$simpson.');
+
+# Test SCALAR.
+eval { $t->scalar('foo') };
+ok( $err = $@, 'scalar to "foo" croaks' );
+like( $err, qr/^Value 'foo' is not a valid Scalar Reference/,
+ 'correct scalar exception' );
+ok( $t->scalar(\"foo"), 'scalar to \\"foo".');
+
+# Test ARRAY.
+eval { $t->array('foo') };
+ok( $err = $@, 'array to "foo" croaks' );
+like( $err, qr/^Value 'foo' is not a valid Array Reference/,
+ 'correct array exception' );
+ok( $t->array(["foo"]), 'array to ["foo"].');
+
+# Test HASH.
+eval { $t->hash('foo') };
+ok( $err = $@, 'hash to "foo" croaks' );
+like( $err, qr/^Value 'foo' is not a valid Hash Reference/,
+ 'correct hash exception' );
+ok( $t->hash({ foo => 1 }), 'hash to { foo => 1 }.');
Added: packages/libclass-meta-perl/branches/upstream/current/t/types_affordance.t
===================================================================
--- packages/libclass-meta-perl/branches/upstream/current/t/types_affordance.t 2006-01-04 09:19:20 UTC (rev 1847)
+++ packages/libclass-meta-perl/branches/upstream/current/t/types_affordance.t 2006-01-04 09:24:55 UTC (rev 1848)
@@ -0,0 +1,274 @@
+#!/usr/bin/perl -w
+
+# $Id: types_affordance.t 682 2004-09-28 05:59:10Z theory $
+
+##############################################################################
+# Set up the tests.
+##############################################################################
+
+use strict;
+use Test::More tests => 56;
+
+##############################################################################
+# Create a simple class.
+##############################################################################
+
+package Class::Meta::TestTypes;
+use strict;
+
+BEGIN {
+ $SIG{__DIE__} = \&Carp::confess;
+ main::use_ok( 'Class::Meta');
+ main::use_ok( 'Class::Meta::Type');
+ main::use_ok( 'Class::Meta::Types::Numeric', 'affordance');
+ main::use_ok( 'Class::Meta::Types::Perl', 'affordance');
+ main::use_ok( 'Class::Meta::Types::String', 'affordance');
+ main::use_ok( 'Class::Meta::Types::Boolean', 'affordance');
+ @Bart::ISA = qw(Simpson);
+}
+
+BEGIN {
+ # Add the new data type.
+ Class::Meta::Type->add( key => 'simpson',
+ name => 'Simpson',
+ desc => 'An Simpson object.',
+ check => 'Simpson',
+ builder => 'affordance',
+ );
+
+ my $c = Class::Meta->new(package => __PACKAGE__,
+ key => 'types',
+ name => 'Class::Meta::TestTypes Class',
+ desc => 'Just for testing Class::Meta.'
+ );
+ $c->add_constructor(name => 'new');
+
+ $c->add_attribute( name => 'name',
+ view => Class::Meta::PUBLIC,
+ type => 'string',
+ length => 256,
+ label => 'Name',
+ field => 'text',
+ desc => "The person's name.",
+ required => 0,
+ default => undef,
+ create => Class::Meta::GETSET
+ );
+ $c->add_attribute( name => 'age',
+ view => Class::Meta::PUBLIC,
+ type => 'integer',
+ label => 'Age',
+ field => 'text',
+ desc => "The person's age.",
+ required => 0,
+ default => undef,
+ create => Class::Meta::GETSET
+ );
+ $c->add_attribute( name => 'alive',
+ view => Class::Meta::PUBLIC,
+ type => 'boolean',
+ label => 'Living',
+ field => 'checkbox',
+ desc => "Is the person alive?",
+ required => 0,
+ default => 1,
+ );
+ $c->add_attribute( name => 'whole',
+ view => Class::Meta::PUBLIC,
+ type => 'whole',
+ label => 'A whole number.',
+ field => 'text',
+ desc => "A whole number.",
+ required => 0,
+ default => undef,
+ create => Class::Meta::GETSET
+ );
+ $c->add_attribute( name => 'dec',
+ view => Class::Meta::PUBLIC,
+ type => 'decimal',
+ label => 'A decimal number.',
+ field => 'text',
+ desc => "A decimal number.",
+ required => 0,
+ default => undef,
+ create => Class::Meta::GETSET
+ );
+ $c->add_attribute( name => 'real',
+ view => Class::Meta::PUBLIC,
+ type => 'real',
+ label => 'A real number.',
+ field => 'text',
+ desc => "A real number.",
+ required => 0,
+ default => undef,
+ create => Class::Meta::GETSET
+ );
+ $c->add_attribute( name => 'float',
+ view => Class::Meta::PUBLIC,
+ type => 'float',
+ label => 'A float.',
+ field => 'text',
+ desc => "A floating point number.",
+ required => 0,
+ default => undef,
+ create => Class::Meta::GETSET
+ );
+ $c->add_attribute( name => 'scalar',
+ view => Class::Meta::PUBLIC,
+ type => 'scalarref',
+ label => 'A scalar.',
+ field => 'text',
+ desc => "A scalar reference.",
+ required => 0,
+ default => undef,
+ create => Class::Meta::GETSET
+ );
+ $c->add_attribute( name => 'array',
+ view => Class::Meta::PUBLIC,
+ type => 'array',
+ label => 'A array.',
+ field => 'text',
+ desc => "A array reference.",
+ required => 0,
+ default => undef,
+ create => Class::Meta::GETSET
+ );
+ $c->add_attribute( name => 'hash',
+ view => Class::Meta::PUBLIC,
+ type => 'hash',
+ label => 'A hash.',
+ field => 'text',
+ desc => "A hash reference.",
+ required => 0,
+ default => undef,
+ create => Class::Meta::GETSET
+ );
+ $c->add_attribute( name => 'simpson',
+ view => Class::Meta::PUBLIC,
+ type => 'simpson',
+ label => 'A Simpson Object',
+ field => 'text',
+ desc => 'A Simpson object.',
+ required => 0,
+ default => sub { bless {}, 'Simpson' },
+ create => Class::Meta::GETSET
+ );
+ $c->build;
+}
+
+
+##############################################################################
+# Do the tests.
+##############################################################################
+
+package main;
+# Instantiate a base class object and test its accessors.
+ok( my $t = Class::Meta::TestTypes->new, 'Class::Meta::TestTypes->new');
+
+# Grab its metadata object.
+ok( my $class = $t->my_class, "Get the Class::Meta::Class object" );
+
+# Test the is_a() method.
+ok( $class->is_a('Class::Meta::TestTypes'), 'Class isa TestTypes');
+
+# Test the key methods.
+is( $class->key, 'types', 'Key is correct');
+
+# Test the name method.
+is( $class->name, 'Class::Meta::TestTypes Class', "Name is correct");
+
+# Test the description methods.
+is( $class->desc, 'Just for testing Class::Meta.',
+ "Description is correct");
+
+# Test string.
+ok( $t->set_name('David'), 'set_name to "David"' );
+is( $t->get_name, 'David', 'get_name is "David"' );
+eval { $t->set_name([]) };
+ok( my $err = $@, 'set_name to array ref croaks' );
+like( $err, qr/^Value .* is not a valid string/, 'correct string exception' );
+
+# Test boolean.
+ok( $t->is_alive, 'is_alive true');
+is( $t->set_alive_off, 0, 'set_alive_off');
+ok( !$t->is_alive, 'is_alive false');
+ok( $t->set_alive_on, 'set_alive_on' );
+ok( $t->is_alive, 'is_alive true again');
+
+# Test whole number.
+eval { $t->set_whole(0) };
+ok( $err = $@, 'set_whole to 0 croaks' );
+like( $err, qr/^Value '0' is not a valid whole number/,
+ 'correct whole number exception' );
+ok( $t->set_whole(1), 'set_whole to 1.');
+
+# Test integer.
+eval { $t->set_age(0.5) };
+ok( $err = $@, 'set_age to 0.5 croaks');
+like( $err, qr/^Value '0\.5' is not a valid integer/,
+ 'correct integer exception' );
+ok( $t->set_age(10), 'set_age to 10.');
+
+# Test decimal.
+eval { $t->set_dec('+') };
+ok( $err = $@, 'set_dec to "+" croaks');
+like( $err, qr/^Value '\+' is not a valid decimal number/,
+ 'correct decimal exception' );
+ok( $t->set_dec(3.14), 'set_dec to 3.14.');
+
+# Test real.
+eval { $t->set_real('+') };
+ok( $err = $@, 'set_real to "+" croaks');
+like( $err, qr/^Value '\+' is not a valid real number/,
+ 'correct real exception' );
+ok( $t->set_real(123.4567), 'set_real to 123.4567.');
+ok( $t->set_real(-123.4567), 'set_real to -123.4567.');
+
+# Test float.
+eval { $t->set_float('+') };
+ok( $err = $@, 'set_float to "+" croaks');
+like( $err, qr/^Value '\+' is not a valid floating point number/,
+ 'correct float exception' );
+ok( $t->set_float(1.23e99), 'set_float to 1.23e99.');
+
+# Test OBJECT with default specifying object type.
+ok( my $simpson = $t->get_simpson, 'get_simpson' );
+isa_ok($simpson, 'Simpson');
+eval { $t->set_simpson('foo') };
+ok( $err = $@, 'set_simpson to "foo" croaks' );
+like( $err, qr/^Value 'foo' is not a valid Simpson/,
+ 'correct object exception' );
+
+# Try a wrong object.
+eval { $t->set_simpson($t) };
+ok( $err = $@, 'set_simpson to \$fh croaks' );
+like( $err, qr/^Value '.*' is not a valid Simpson/,
+ 'correct object exception' );
+ok( $t->set_simpson($simpson), 'set_simpson to \$simpson.');
+
+# Try a subclass.
+my $bart = bless {}, 'Bart';
+ok( $t->set_simpson($bart), "Set simpson to a subclass." );
+isa_ok($t->get_simpson, 'Bart', "Check subclass" );
+ok( $t->set_simpson($simpson), 'set_simpson to \$simpson.');
+
+# Test SCALAR.
+eval { $t->set_scalar('foo') };
+ok( $err = $@, 'set_scalar to "foo" croaks' );
+like( $err, qr/^Value 'foo' is not a valid Scalar Reference/,
+ 'correct scalar exception' );
+ok( $t->set_scalar(\"foo"), 'set_scalar to \\"foo".');
+
+# Test ARRAY.
+eval { $t->set_array('foo') };
+ok( $err = $@, 'set_array to "foo" croaks' );
+like( $err, qr/^Value 'foo' is not a valid Array Reference/,
+ 'correct array exception' );
+ok( $t->set_array(["foo"]), 'set_array to ["foo"].');
+
+# Test HASH.
+eval { $t->set_hash('foo') };
+ok( $err = $@, 'set_hash to "foo" croaks' );
+like( $err, qr/^Value 'foo' is not a valid Hash Reference/,
+ 'correct hash exception' );
+ok( $t->set_hash({ foo => 1 }), 'set_hash to { foo => 1 }.');
Added: packages/libclass-meta-perl/branches/upstream/current/t/types_semi_affordance.t
===================================================================
--- packages/libclass-meta-perl/branches/upstream/current/t/types_semi_affordance.t 2006-01-04 09:19:20 UTC (rev 1847)
+++ packages/libclass-meta-perl/branches/upstream/current/t/types_semi_affordance.t 2006-01-04 09:24:55 UTC (rev 1848)
@@ -0,0 +1,274 @@
+#!/usr/bin/perl -w
+
+# $Id: types_semi_affordance.t 682 2004-09-28 05:59:10Z theory $
+
+##############################################################################
+# Set up the tests.
+##############################################################################
+
+use strict;
+use Test::More tests => 56;
+
+##############################################################################
+# Create a simple class.
+##############################################################################
+
+package Class::Meta::TestTypes;
+use strict;
+
+BEGIN {
+ $SIG{__DIE__} = \&Carp::confess;
+ main::use_ok( 'Class::Meta');
+ main::use_ok( 'Class::Meta::Type');
+ main::use_ok( 'Class::Meta::Types::Numeric', 'semi-affordance');
+ main::use_ok( 'Class::Meta::Types::Perl', 'semi-affordance');
+ main::use_ok( 'Class::Meta::Types::String', 'semi-affordance');
+ main::use_ok( 'Class::Meta::Types::Boolean', 'semi-affordance');
+ @Bart::ISA = qw(Simpson);
+}
+
+BEGIN {
+ # Add the new data type.
+ Class::Meta::Type->add( key => 'simpson',
+ name => 'Simpson',
+ desc => 'An Simpson object.',
+ check => 'Simpson',
+ builder => 'semi-affordance',
+ );
+
+ my $c = Class::Meta->new(package => __PACKAGE__,
+ key => 'types',
+ name => 'Class::Meta::TestTypes Class',
+ desc => 'Just for testing Class::Meta.'
+ );
+ $c->add_constructor(name => 'new');
+
+ $c->add_attribute( name => 'name',
+ view => Class::Meta::PUBLIC,
+ type => 'string',
+ length => 256,
+ label => 'Name',
+ field => 'text',
+ desc => "The person's name.",
+ required => 0,
+ default => undef,
+ create => Class::Meta::GETSET
+ );
+ $c->add_attribute( name => 'age',
+ view => Class::Meta::PUBLIC,
+ type => 'integer',
+ label => 'Age',
+ field => 'text',
+ desc => "The person's age.",
+ required => 0,
+ default => undef,
+ create => Class::Meta::GETSET
+ );
+ $c->add_attribute( name => 'alive',
+ view => Class::Meta::PUBLIC,
+ type => 'boolean',
+ label => 'Living',
+ field => 'checkbox',
+ desc => "Is the person alive?",
+ required => 0,
+ default => 1,
+ );
+ $c->add_attribute( name => 'whole',
+ view => Class::Meta::PUBLIC,
+ type => 'whole',
+ label => 'A whole number.',
+ field => 'text',
+ desc => "A whole number.",
+ required => 0,
+ default => undef,
+ create => Class::Meta::GETSET
+ );
+ $c->add_attribute( name => 'dec',
+ view => Class::Meta::PUBLIC,
+ type => 'decimal',
+ label => 'A decimal number.',
+ field => 'text',
+ desc => "A decimal number.",
+ required => 0,
+ default => undef,
+ create => Class::Meta::GETSET
+ );
+ $c->add_attribute( name => 'real',
+ view => Class::Meta::PUBLIC,
+ type => 'real',
+ label => 'A real number.',
+ field => 'text',
+ desc => "A real number.",
+ required => 0,
+ default => undef,
+ create => Class::Meta::GETSET
+ );
+ $c->add_attribute( name => 'float',
+ view => Class::Meta::PUBLIC,
+ type => 'float',
+ label => 'A float.',
+ field => 'text',
+ desc => "A floating point number.",
+ required => 0,
+ default => undef,
+ create => Class::Meta::GETSET
+ );
+ $c->add_attribute( name => 'scalar',
+ view => Class::Meta::PUBLIC,
+ type => 'scalarref',
+ label => 'A scalar.',
+ field => 'text',
+ desc => "A scalar reference.",
+ required => 0,
+ default => undef,
+ create => Class::Meta::GETSET
+ );
+ $c->add_attribute( name => 'array',
+ view => Class::Meta::PUBLIC,
+ type => 'array',
+ label => 'A array.',
+ field => 'text',
+ desc => "A array reference.",
+ required => 0,
+ default => undef,
+ create => Class::Meta::GETSET
+ );
+ $c->add_attribute( name => 'hash',
+ view => Class::Meta::PUBLIC,
+ type => 'hash',
+ label => 'A hash.',
+ field => 'text',
+ desc => "A hash reference.",
+ required => 0,
+ default => undef,
+ create => Class::Meta::GETSET
+ );
+ $c->add_attribute( name => 'simpson',
+ view => Class::Meta::PUBLIC,
+ type => 'simpson',
+ label => 'A Simpson Object',
+ field => 'text',
+ desc => 'A Simpson object.',
+ required => 0,
+ default => sub { bless {}, 'Simpson' },
+ create => Class::Meta::GETSET
+ );
+ $c->build;
+}
+
+
+##############################################################################
+# Do the tests.
+##############################################################################
+
+package main;
+# Instantiate a base class object and test its accessors.
+ok( my $t = Class::Meta::TestTypes->new, 'Class::Meta::TestTypes->new');
+
+# Grab its metadata object.
+ok( my $class = $t->my_class, "Get the Class::Meta::Class object" );
+
+# Test the is_a() method.
+ok( $class->is_a('Class::Meta::TestTypes'), 'Class isa TestTypes');
+
+# Test the key methods.
+is( $class->key, 'types', 'Key is correct');
+
+# Test the name method.
+is( $class->name, 'Class::Meta::TestTypes Class', "Name is correct");
+
+# Test the description methods.
+is( $class->desc, 'Just for testing Class::Meta.',
+ "Description is correct");
+
+# Test string.
+ok( $t->set_name('David'), 'set_name to "David"' );
+is( $t->name, 'David', 'name is "David"' );
+eval { $t->set_name([]) };
+ok( my $err = $@, 'set_name to array ref croaks' );
+like( $err, qr/^Value .* is not a valid string/, 'correct string exception' );
+
+# Test boolean.
+ok( $t->is_alive, 'is_alive true');
+is( $t->set_alive_off, 0, 'set_alive_off');
+ok( !$t->is_alive, 'is_alive false');
+ok( $t->set_alive_on, 'set_alive_on' );
+ok( $t->is_alive, 'is_alive true again');
+
+# Test whole number.
+eval { $t->set_whole(0) };
+ok( $err = $@, 'set_whole to 0 croaks' );
+like( $err, qr/^Value '0' is not a valid whole number/,
+ 'correct whole number exception' );
+ok( $t->set_whole(1), 'set_whole to 1.');
+
+# Test integer.
+eval { $t->set_age(0.5) };
+ok( $err = $@, 'set_age to 0.5 croaks');
+like( $err, qr/^Value '0\.5' is not a valid integer/,
+ 'correct integer exception' );
+ok( $t->set_age(10), 'set_age to 10.');
+
+# Test decimal.
+eval { $t->set_dec('+') };
+ok( $err = $@, 'set_dec to "+" croaks');
+like( $err, qr/^Value '\+' is not a valid decimal number/,
+ 'correct decimal exception' );
+ok( $t->set_dec(3.14), 'set_dec to 3.14.');
+
+# Test real.
+eval { $t->set_real('+') };
+ok( $err = $@, 'set_real to "+" croaks');
+like( $err, qr/^Value '\+' is not a valid real number/,
+ 'correct real exception' );
+ok( $t->set_real(123.4567), 'set_real to 123.4567.');
+ok( $t->set_real(-123.4567), 'set_real to -123.4567.');
+
+# Test float.
+eval { $t->set_float('+') };
+ok( $err = $@, 'set_float to "+" croaks');
+like( $err, qr/^Value '\+' is not a valid floating point number/,
+ 'correct float exception' );
+ok( $t->set_float(1.23e99), 'set_float to 1.23e99.');
+
+# Test OBJECT with default specifying object type.
+ok( my $simpson = $t->simpson, 'simpson' );
+isa_ok($simpson, 'Simpson');
+eval { $t->set_simpson('foo') };
+ok( $err = $@, 'set_simpson to "foo" croaks' );
+like( $err, qr/^Value 'foo' is not a valid Simpson/,
+ 'correct object exception' );
+
+# Try a wrong object.
+eval { $t->set_simpson($t) };
+ok( $err = $@, 'set_simpson to \$fh croaks' );
+like( $err, qr/^Value '.*' is not a valid Simpson/,
+ 'correct object exception' );
+ok( $t->set_simpson($simpson), 'set_simpson to \$simpson.');
+
+# Try a subclass.
+my $bart = bless {}, 'Bart';
+ok( $t->set_simpson($bart), "Set simpson to a subclass." );
+isa_ok($t->simpson, 'Bart', "Check subclass" );
+ok( $t->set_simpson($simpson), 'set_simpson to \$simpson.');
+
+# Test SCALAR.
+eval { $t->set_scalar('foo') };
+ok( $err = $@, 'set_scalar to "foo" croaks' );
+like( $err, qr/^Value 'foo' is not a valid Scalar Reference/,
+ 'correct scalar exception' );
+ok( $t->set_scalar(\"foo"), 'set_scalar to \\"foo".');
+
+# Test ARRAY.
+eval { $t->set_array('foo') };
+ok( $err = $@, 'set_array to "foo" croaks' );
+like( $err, qr/^Value 'foo' is not a valid Array Reference/,
+ 'correct array exception' );
+ok( $t->set_array(["foo"]), 'set_array to ["foo"].');
+
+# Test HASH.
+eval { $t->set_hash('foo') };
+ok( $err = $@, 'set_hash to "foo" croaks' );
+like( $err, qr/^Value 'foo' is not a valid Hash Reference/,
+ 'correct hash exception' );
+ok( $t->set_hash({ foo => 1 }), 'set_hash to { foo => 1 }.');
Added: packages/libclass-meta-perl/branches/upstream/current/t/view.t
===================================================================
--- packages/libclass-meta-perl/branches/upstream/current/t/view.t 2006-01-04 09:19:20 UTC (rev 1847)
+++ packages/libclass-meta-perl/branches/upstream/current/t/view.t 2006-01-04 09:24:55 UTC (rev 1848)
@@ -0,0 +1,704 @@
+#!perl -w
+
+# $Id: view.t 2384 2005-12-14 04:27:23Z theory $
+
+##############################################################################
+# Set up the tests.
+##############################################################################
+
+use strict;
+use Test::More $] < 5.008
+ ? (skip_all => 'Older Carp lacks @CARP_NOT support')
+ : (tests => 394);
+use File::Spec;
+my $fn = File::Spec->catfile('t', 'view.t');
+
+##############################################################################
+# Create a simple class.
+##############################################################################
+
+package Class::Meta::Test;
+use strict;
+
+BEGIN {
+ Test::More->import;
+ use_ok('Class::Meta');
+ use_ok('Class::Meta::Types::Numeric');
+ use_ok('Class::Meta::Types::String');
+}
+
+BEGIN {
+ ok( my $c = Class::Meta->new(
+ key => 'person',
+ package => __PACKAGE__,
+ name => 'Class::Meta::TestPerson Class',
+ trust => 'Class::Meta::TrustMe',
+ desc => 'Special person class just for testing Class::Meta.',
+ ), "Create Class::Meta object" );
+
+ # Add a constructor.
+ ok( $c->add_constructor( name => 'new',
+ create => 1 ),
+ "Add new constructor" );
+
+ # Add a protected constructor.
+ ok( $c->add_constructor( name => 'prot_new',
+ view => Class::Meta::PROTECTED,
+ create => 1 ),
+ "Add protected constructor" );
+
+ # Add a private constructor.
+ ok( $c->add_constructor( name => 'priv_new',
+ view => Class::Meta::PRIVATE,
+ create => 1 ),
+ "Add private constructor" );
+
+ # Add a trusted constructor.
+ ok( $c->add_constructor( name => 'trust_new',
+ view => Class::Meta::TRUSTED,
+ create => 1 ),
+ "Add trusted constructor" );
+
+ # Add a couple of attributes with created methods.
+ ok( $c->add_attribute( name => 'id',
+ view => Class::Meta::PUBLIC,
+ type => 'integer',
+ label => 'ID',
+ required => 1,
+ default => 22,
+ ),
+ "Add id attribute" );
+ ok( $c->add_attribute( name => 'name',
+ view => Class::Meta::PROTECTED,
+ type => 'string',
+ label => 'Name',
+ required => 1,
+ default => '',
+ ),
+ "Add protected name attribute" );
+ ok( $c->add_attribute( name => 'age',
+ view => Class::Meta::PRIVATE,
+ type => 'integer',
+ label => 'Age',
+ desc => "The person's age.",
+ required => 0,
+ default => 0,
+ ),
+ "Add private age attribute" );
+ ok( $c->add_attribute( name => 'sn',
+ view => Class::Meta::TRUSTED,
+ type => 'string',
+ label => 'SN',
+ desc => "The person's serial number.",
+ required => 0,
+ default => '',
+ ),
+ "Add trusted sn attribute" );
+ $c->build;
+}
+
+##############################################################################
+# From within the package, the all attributes should just work.
+##############################################################################
+
+ok( my $obj = __PACKAGE__->new, "Create new object" );
+ok( my $class = __PACKAGE__->my_class, "Get class object" );
+is_deeply(
+ [map { $_->name } $class->attributes],
+ [qw(id name age sn)],
+ 'Call to attributes() should return all attributes'
+);
+
+is_deeply(
+ [map { $_->name } $class->constructors],
+ [qw(new prot_new priv_new trust_new)],
+ 'Call to constructors() should return all constructors'
+);
+
+# Check id public attribute.
+is( $obj->id, 22, 'Check default ID' );
+ok( $obj->id(12), "Set ID" );
+is( $obj->id, 12, 'Check 12 ID' );
+ok( my $attr = $class->attributes('id'), 'Get "id" attribute object' );
+is( $attr->get($obj), 12, "Check indirect 12 ID" );
+ok( $attr->set($obj, 15), "Indirectly set ID" );
+is( $attr->get($obj), 15, "Check indirect 15 ID" );
+
+# Check name protected attribute succeeds.
+is( $obj->name, '', 'Check empty name' );
+ok( $obj->name('Larry'), "Set name" );
+is( $obj->name, 'Larry', 'Check "Larry" name' );
+ok( $attr = $class->attributes('name'), 'Get "name" attribute object' );
+is( $attr->get($obj), 'Larry', 'Check indirect "Larry" name' );
+ok( $attr->set($obj, 'Chip'), "Indirectly set name" );
+is( $attr->get($obj), 'Chip', 'Check indirect "chip" name' );
+
+# Check age private attribute succeeds.
+is( $obj->age, 0, 'Check default age' );
+ok( $obj->age(42), "Set age" );
+is( $obj->age, 42, 'Check 42 age' );
+ok( $attr = $class->attributes('age'), 'Get "age" attribute object' );
+is( $attr->get($obj), 42, "Check indirect 12 age" );
+ok( $attr->set($obj, 15), "Indirectly set age" );
+is( $attr->get($obj), 15, "Check indirect 15 age" );
+
+# Check sn trusted attribute succeeds.
+is( $obj->sn, '', 'Check empty sn' );
+ok( $obj->sn('123456789'), "Set sn" );
+is( $obj->sn, '123456789', 'Check "123456789" sn' );
+ok( $attr = $class->attributes('sn'), 'Get "sn" attribute object' );
+is( $attr->get($obj), '123456789', 'Check indirect "123456789" sn' );
+ok( $attr->set($obj, '987654321'), "Indirectly set sn" );
+is( $attr->get($obj), '987654321', 'Check indirect "987654321" sn' );
+
+# Make sure that we can set all of the attributes via new().
+ok( $obj = __PACKAGE__->new( id => 10,
+ name => 'Damian',
+ sn => 'au',
+ age => 35),
+ "Create another new object" );
+
+is( $obj->id, 10, 'Check 10 ID' );
+is( $obj->name, 'Damian', 'Check Damian name' );
+is( $obj->age, 35, 'Check 35 age' );
+is( $obj->sn, 'au', 'Check sn is "au"');
+
+# Do the same with the constructor object.
+ok( my $ctor = $class->constructors('new'), 'Get "new" constructor object' );
+ok( $obj = $ctor->call(__PACKAGE__,
+ id => 10,
+ name => 'Damian',
+ sn => 'au',
+ age => 35),
+ "Create another new object" );
+
+is( $obj->id, 10, 'Check 10 ID' );
+is( $obj->name, 'Damian', 'Check Damian name' );
+is( $obj->age, 35, 'Check 35 age' );
+is( $obj->sn, 'au', 'Check sn is "au"');
+
+# Make sure that we can set all of the attributes via prot_new().
+ok( $obj = __PACKAGE__->prot_new( id => 10,
+ name => 'Damian',
+ sn => 'au',
+ age => 35),
+ "Create another prot_new object" );
+
+is( $obj->id, 10, 'Check 10 ID' );
+is( $obj->name, 'Damian', 'Check Damian name' );
+is( $obj->age, 35, 'Check 35 age' )
+;is( $obj->sn, 'au', 'Check sn is "au"');
+
+# Do the same with the constructor object.
+ok( $ctor = $class->constructors('prot_new'),
+ 'Get "prot_new" constructor object' );
+ok( $obj = $ctor->call(__PACKAGE__,
+ id => 10,
+ name => 'Damian',
+ sn => 'au',
+ age => 35),
+ "Create another prot_new object" );
+
+is( $obj->id, 10, 'Check 10 ID' );
+is( $obj->name, 'Damian', 'Check Damian name' );
+is( $obj->age, 35, 'Check 35 age' );
+is( $obj->sn, 'au', 'Check sn is "au"');
+
+# Make sure that we can set all of the attributes via priv_new().
+ok( $obj = __PACKAGE__->priv_new( id => 10,
+ name => 'Damian',
+ sn => 'au',
+ age => 35),
+ "Create another priv_new object" );
+
+is( $obj->id, 10, 'Check 10 ID' );
+is( $obj->name, 'Damian', 'Check Damian name' );
+is( $obj->age, 35, 'Check 35 age' );
+is( $obj->sn, 'au', 'Check sn is "au"');
+
+# Do the same with the constructor object.
+ok( $ctor = $class->constructors('priv_new'),
+ 'Get "priv_new" constructor object' );
+ok( $obj = $ctor->call(__PACKAGE__,
+ id => 10,
+ name => 'Damian',
+ sn => 'au',
+ age => 35),
+ "Create another priv_new object" );
+
+is( $obj->id, 10, 'Check 10 ID' );
+is( $obj->name, 'Damian', 'Check Damian name' );
+is( $obj->age, 35, 'Check 35 age' );
+is( $obj->sn, 'au', 'Check sn is "au"');
+
+# Make sure that we can set all of the attributes via trust_new().
+ok( $obj = __PACKAGE__->trust_new( id => 10,
+ name => 'Damian',
+ sn => 'au',
+ age => 35),
+ "Create another trust_new object" );
+
+is( $obj->id, 10, 'Check 10 ID' );
+is( $obj->name, 'Damian', 'Check Damian name' );
+is( $obj->age, 35, 'Check 35 age' );
+is( $obj->sn, 'au', 'Check sn is "au"');
+
+# Do the same with the constructor object.
+ok( $ctor = $class->constructors('trust_new'),
+ 'Get "trust_new" constructor object' );
+ok( $obj = $ctor->call(__PACKAGE__,
+ id => 10,
+ name => 'Damian',
+ sn => 'au',
+ age => 35),
+ "Create another priv_new object" );
+
+is( $obj->id, 10, 'Check 10 ID' );
+is( $obj->name, 'Damian', 'Check Damian name' );
+is( $obj->age, 35, 'Check 35 age' );
+is( $obj->sn, 'au', 'Check sn is "au"');
+
+##############################################################################
+# Set up an inherited package.
+##############################################################################
+package Class::Meta::Testarama;
+use strict;
+use base 'Class::Meta::Test';
+
+BEGIN {
+ Test::More->import;
+ Class::Meta->new(key => 'testarama')->build;
+}
+
+ok( $obj = __PACKAGE__->new, "Create new Testarama object" );
+ok( $class = __PACKAGE__->my_class, "Get Testarama class object" );
+is_deeply( [map { $_->name } $class->attributes], [qw(id name)],
+ "Call to attributes() should return public and protected attrs" );
+is_deeply( [map { $_->name } $class->constructors], [qw(new prot_new)],
+ "Call to constructors() should return public and protected ctors" );
+
+# Check id public attribute.
+is( $obj->id, 22, 'Check default ID' );
+ok( $obj->id(12), "Set ID" );
+is( $obj->id, 12, 'Check 12 ID' );
+ok( $attr = $class->attributes('id'), 'Get "id" attribute object' );
+is( $attr->get($obj), 12, "Check indirect 12 ID" );
+ok( $attr->set($obj, 15), "Indirectly set ID" );
+is( $attr->get($obj), 15, "Check indirect 15 ID" );
+
+# Check name protected attribute succeeds.
+is( $obj->name, '', 'Check empty name' );
+ok( $obj->name('Larry'), "Set name" );
+is( $obj->name, 'Larry', 'Check Larry name' );
+ok( $attr = $class->attributes('name'), 'Get "name" attribute object' );
+is( $attr->get($obj), 'Larry', 'Check indirect "Larry" name' );
+ok( $attr->set($obj, 'Chip'), "Indirectly set name" );
+is( $attr->get($obj), 'Chip', 'Check indirect "chip" name' );
+
+# Check age private attribute
+eval { $obj->age(12) };
+main::chk( 'private exception',
+ qr/age is a private attribute of Class::Meta::Test/);
+eval { $obj->age };
+main::chk( 'private exception again',
+ qr/age is a private attribute of Class::Meta::Test/);
+
+# Check that age fails when accessed indirectly, too.
+ok( $attr = $class->attributes('age'), 'Get "age" attribute object' );
+eval { $attr->set($obj, 12) };
+main::chk('indirect private exception',
+ qr/age is a private attribute of Class::Meta::Test/);
+eval { $attr->get($obj) };
+main::chk('another indirect private exception',
+ qr/age is a private attribute of Class::Meta::Test/);
+
+# Check sn trusted attribute fails.
+eval { $obj->sn('foo') };
+main::chk( 'trusted exception',
+ qr/sn is a trusted attribute of Class::Meta::Test/);
+eval { $obj->sn };
+main::chk( 'trusted exception again',
+ qr/sn is a trusted attribute of Class::Meta::Test/);
+
+# Check that sn fails when accessed indirectly, too.
+ok( $attr = $class->attributes('sn'), 'Get "sn" attribute object' );
+eval { $attr->set($obj, 'foo') };
+main::chk('indirect trusted exception',
+ qr/sn is a trusted attribute of Class::Meta::Test/);
+eval { $attr->get($obj) };
+main::chk('another indirect trusted exception',
+ qr/sn is a trusted attribute of Class::Meta::Test/);
+
+# Make sure that we can set protected attributes via new().
+ok( $obj = __PACKAGE__->new( id => 10,
+ name => 'Damian'),
+ "Create another new object" );
+
+is( $obj->id, 10, 'Check 10 ID' );
+is( $obj->name, 'Damian', 'Check Damian name' );
+
+# Make sure that the private attribute fails.
+$ENV{FOO} = 1;
+eval { __PACKAGE__->new( age => 44 ) };
+delete $ENV{FOO};
+main::chk('constructor private exception',
+ qr/age is a private attribute of Class::Meta::Test/);
+
+# Do the same with the new constructor object.
+ok( $ctor = $class->constructors('new'), 'Get "new" constructor object' );
+ok( $obj = $ctor->call(__PACKAGE__,
+ id => 10,
+ name => 'Damian'),
+ "Create another new object" );
+
+is( $obj->id, 10, 'Check 10 ID' );
+is( $obj->name, 'Damian', 'Check Damian name' );
+
+# Make sure that the private attribute fails.
+eval { $ctor->call(__PACKAGE__, age => 44 ) };
+main::chk('indirect constructor private exception',
+ qr/age is a private attribute of Class::Meta::Test/);
+
+# Make sure that we can set protected attributes via prot_new().
+ok( $obj = __PACKAGE__->prot_new( id => 10,
+ name => 'Damian'),
+ "Create another prot_new object" );
+
+is( $obj->id, 10, 'Check 10 ID' );
+is( $obj->name, 'Damian', 'Check Damian name' );
+
+# Make sure that the private attribute fails.
+eval { __PACKAGE__->prot_new( age => 44 ) };
+main::chk('constructor private exception',
+ qr/age is a private attribute of Class::Meta::Test/);
+
+# Do the same with the prot_new constructor object.
+ok( $ctor = $class->constructors('prot_new'),
+ 'Get "prot_new" constructor object' );
+ok( $obj = $ctor->call(__PACKAGE__,
+ id => 10,
+ name => 'Damian'),
+ "Create another prot_new object" );
+
+is( $obj->id, 10, 'Check 10 ID' );
+is( $obj->name, 'Damian', 'Check Damian name' );
+
+# Make sure that the private attribute fails.
+eval { $ctor->call(__PACKAGE__, age => 44 ) };
+main::chk('indirect constructor private exception',
+ qr/age is a private attribute of Class::Meta::Test/);
+
+# Make sure that the private constructor fails.
+eval { __PACKAGE__->priv_new };
+main::chk('priv_new exeption',
+ qr/priv_new is a private constructor of Class::Meta::Test/);
+
+# Make sure the same is true of the priv_new constructor object.
+ok( $ctor = $class->constructors('priv_new'),
+ 'Get "priv_new" constructor object' );
+eval { $ctor->call(__PACKAGE__) };
+main::chk('indirect priv_new exeption',
+ qr/priv_new is a private constructor of Class::Meta::Test/);
+
+##############################################################################
+# Set up a trusted package.
+##############################################################################
+package Class::Meta::TrustMe;
+use strict;
+
+BEGIN { Test::More->import }
+
+ok( $obj = Class::Meta::Test->new, "Create new Test object" );
+ok( $class = Class::Meta::Test->my_class, "Get Test class object" );
+is_deeply( [map { $_->name } $class->attributes], [qw(id sn)],
+ "Call to attributes() should return public and trusted attrs" );
+is_deeply(
+ [map { $_->name } Class::Meta::Testarama->my_class->attributes],
+ [qw(id sn)],
+ 'Call to attributes() should return public and trusted attrs',
+);
+
+is_deeply(
+ [map { $_->name } Class::Meta::Testarama->my_class->constructors],
+ [qw(new trust_new)],
+ 'Call to constructors() should return public and trusted ctors',
+);
+
+# Check id public attribute.
+is( $obj->id, 22, 'Check default ID' );
+ok( $obj->id(12), "Set ID" );
+is( $obj->id, 12, 'Check 12 ID' );
+ok( $attr = $class->attributes('id'), 'Get "id" attribute object' );
+is( $attr->get($obj), 12, "Check indirect 12 ID" );
+ok( $attr->set($obj, 15), "Indirectly set ID" );
+is( $attr->get($obj), 15, "Check indirect 15 ID" );
+
+# Check name protected attribute
+eval { $obj->name('foo') };
+main::chk('protected exception',
+ qr/name is a protected attribute of Class::Meta::Test/);
+eval { $obj->name };
+main::chk('another protected exception',
+ qr/name is a protected attribute of Class::Meta::Test/);
+
+# Check that name fails when accessed indirectly, too.
+ok( $attr = $class->attributes('name'), 'Get "name" attribute object' );
+eval { $attr->set($obj, 'foo') };
+main::chk('indirect protected exception',
+ qr/name is a protected attribute of Class::Meta::Test/);
+eval { $attr->get($obj) };
+main::chk('another indirect protected exception',
+ qr/name is a protected attribute of Class::Meta::Test/);
+
+# Check age private attribute
+eval { $obj->age(12) };
+main::chk( 'private exception',
+ qr/age is a private attribute of Class::Meta::Test/);
+eval { $obj->age };
+main::chk( 'private exception again',
+ qr/age is a private attribute of Class::Meta::Test/);
+
+# Check that age fails when accessed indirectly, too.
+ok( $attr = $class->attributes('age'), 'Get "age" attribute object' );
+eval { $attr->set($obj, 12) };
+main::chk('indirect private exception',
+ qr/age is a private attribute of Class::Meta::Test/);
+eval { $attr->get($obj) };
+main::chk('another indirect private exception',
+ qr/age is a private attribute of Class::Meta::Test/);
+
+# Check sn trusted attribute succeeds.
+is( $obj->sn, '', 'Check empty sn' );
+ok( $obj->sn('123456789'), "Set sn" );
+is( $obj->sn, '123456789', 'Check "123456789" sn' );
+ok( $attr = $class->attributes('sn'), 'Get "sn" attribute object' );
+is( $attr->get($obj), '123456789', 'Check indirect "123456789" sn' );
+ok( $attr->set($obj, '987654321'), "Indirectly set sn" );
+is( $attr->get($obj), '987654321', 'Check indirect "987654321" sn' );
+
+# Make sure that sn trusted attribute works for subclasses, too.
+ok( $obj = Class::Meta::Testarama->new, "Create new Testarama object" );
+is( $obj->sn, '', 'Check empty sn' );
+ok( $obj->sn('123456789'), "Set sn" );
+is( $obj->sn, '123456789', 'Check "123456789" sn' );
+ok( $attr = $class->attributes('sn'), 'Get "sn" attribute object' );
+is( $attr->get($obj), '123456789', 'Check indirect "123456789" sn' );
+ok( $attr->set($obj, '987654321'), "Indirectly set sn" );
+is( $attr->get($obj), '987654321', 'Check indirect "987654321" sn' );
+
+# Make sure that we can set trusted attributes via new().
+ok( $obj = Class::Meta::Test->new( id => 10,
+ sn => 'foo'),
+ "Create another new object" );
+
+is( $obj->id, 10, 'Check 10 ID' );
+is( $obj->sn, 'foo', 'Check foo sn' );
+
+# Make sure that the private attribute fails.
+eval { Class::Meta::Test->new( age => 44 ) };
+main::chk('constructor private exception',
+ qr/age is a private attribute of Class::Meta::Test/);
+
+# Make sure that the protected attribute fails.
+eval { Class::Meta::Test->new( name => 'Damian' ) };
+main::chk('constructor protected exception',
+ qr/name is a protected attribute of Class::Meta::Test/);
+
+# Do the same with the new constructor object.
+ok( $ctor = $class->constructors('new'), 'Get "new" constructor object' );
+ok( $obj = $ctor->call('Class::Meta::Test',
+ id => 10,
+ sn => 'foo'),
+ "Create another new object" );
+
+is( $obj->id, 10, 'Check 10 ID' );
+is( $obj->sn, 'foo', 'Check foo sn' );
+
+# Make sure that the private attribute fails.
+eval { $ctor->call('Class::Meta::Test', age => 44 ) };
+main::chk('indirect constructor private exception',
+ qr/age is a private attribute of Class::Meta::Test/);
+
+# Make sure that the protected attribute fails.
+eval { $ctor->call('Class::Meta::Test', name => 'Damian' ) };
+main::chk('indirect constructor protected exception',
+ qr/name is a protected attribute of Class::Meta::Test/);
+
+# Make sure that we can set trusted attributes via trust_new().
+ok( $obj = Class::Meta::Test->trust_new( id => 10,
+ sn => 'foo'),
+ "Create another trust_new object" );
+
+is( $obj->id, 10, 'Check 10 ID' );
+is( $obj->sn, 'foo', 'Check foo name' );
+
+# Make sure that the private attribute fails.
+eval { Class::Meta::Test->trust_new( age => 44 ) };
+main::chk('constructor private exception',
+ qr/age is a private attribute of Class::Meta::Test/);
+
+# Make sure that the protected attribute fails.
+eval { Class::Meta::Test->trust_new( name => 'Damian' ) };
+main::chk('constructor protected exception',
+ qr/name is a protected attribute of Class::Meta::Test/);
+
+# Do the same with the trust_new constructor object.
+ok( $ctor = $class->constructors('trust_new'),
+ 'Get "trust_new" constructor object' );
+ok( $obj = $ctor->call('Class::Meta::Test',
+ id => 10,
+ sn => 'foo'),
+ "Create another trust_new object" );
+
+is( $obj->id, 10, 'Check 10 ID' );
+is( $obj->sn, 'foo', 'Check foo name' );
+
+# Make sure that the private attribute fails.
+eval { $ctor->call('Class::Meta::Test', age => 44 ) };
+main::chk('indirect constructor private exception',
+ qr/age is a private attribute of Class::Meta::Test/);
+
+# Make sure that the private attribute fails.
+eval { $ctor->call('Class::Meta::Test', age => 44 ) };
+main::chk('indirect constructor private exception',
+ qr/age is a private attribute of Class::Meta::Test/);
+
+# Make sure that the protected constructor fails.
+eval { Class::Meta::Test->prot_new };
+main::chk('prot_new exeption',
+ qr/prot_new is a protected constrctor of Class::Meta::Test/);
+
+# Make sure the same is true of the priv_new constructor object.
+ok( $ctor = $class->constructors('priv_new'),
+ 'Get "priv_new" constructor object' );
+eval { $ctor->call('Class::Meta::Test') };
+main::chk('indirect priv_new exeption',
+ qr/priv_new is a private constructor of Class::Meta::Test/);
+
+##############################################################################
+# Now do test in a completely independent package.
+##############################################################################
+package main;
+
+ok( $obj = Class::Meta::Test->new, "Create new object in main" );
+ok( $class = Class::Meta::Test->my_class, "Get class object in main" );
+
+# Make sure we can access id.
+is( $obj->id, 22, 'Check default ID' );
+ok( $obj->id(12), "Set ID" );
+is( $obj->id, 12, 'Check 12 ID' );
+ok( $attr = $class->attributes('id'), 'Get "id" attribute object' );
+is( $attr->get($obj), 12, "Check indirect 12 ID" );
+ok( $attr->set($obj, 15), "Indirectly set ID" );
+is( $attr->get($obj), 15, "Check indirect 15 ID" );
+
+# Check name protected attribute
+eval { $obj->name('foo') };
+chk('protected exception',
+ qr/name is a protected attribute of Class::Meta::Test/);
+eval { $obj->name };
+chk('another protected exception',
+ qr/name is a protected attribute of Class::Meta::Test/);
+
+# Check that name fails when accessed indirectly, too.
+ok( $attr = $class->attributes('name'), 'Get "name" attribute object' );
+eval { $attr->set($obj, 'foo') };
+chk('indirect protected exception',
+ qr/name is a protected attribute of Class::Meta::Test/);
+eval { $attr->get($obj) };
+chk('another indirect protected exception',
+ qr/name is a protected attribute of Class::Meta::Test/);
+
+# Check sn trusted attribute, which can't be accessed by subclasses.
+eval { $obj->sn('foo') };
+main::chk( 'trusted exception',
+ qr/sn is a trusted attribute of Class::Meta::Test/);
+eval { $obj->sn };
+main::chk( 'trusted exception again',
+ qr/sn is a trusted attribute of Class::Meta::Test/);
+
+# Check that sn fails when accessed indirectly, too.
+ok( $attr = $class->attributes('sn'), 'Get "sn" attribute object' );
+eval { $attr->set($obj, 'foo') };
+main::chk('indirect trusted exception',
+ qr/sn is a trusted attribute of Class::Meta::Test/);
+eval { $attr->get($obj) };
+main::chk('another indirect trusted exception',
+ qr/sn is a trusted attribute of Class::Meta::Test/);
+
+# Check age private attribute
+eval { $obj->age(12) };
+chk( 'private exception',
+ qr/age is a private attribute of Class::Meta::Test/ );
+eval { $obj->age };
+chk( 'another private exception',
+ qr/age is a private attribute of Class::Meta::Test/);
+
+# Check that age fails when accessed indirectly, too.
+ok( $attr = $class->attributes('age'), 'Get "age" attribute object' );
+eval { $attr->set($obj, 12) };
+chk( 'indirect private exception',
+ qr/age is a private attribute of Class::Meta::Test/);
+eval { $attr->get($obj) };
+chk( 'another indirect private exception',
+ qr/age is a private attribute of Class::Meta::Test/);
+
+# Try the constructor with parameters.
+ok( $obj = Class::Meta::Test->new( id => 1 ), "Create new object with id" );
+is( $obj->id, 1, 'Check 1 ID' );
+ok( $ctor = $class->constructors('new'), "Get new constructor" );
+ok( $obj = $ctor->call('Class::Meta::Test', id => 52 ),
+ "Indirectly create new object with id" );
+is( $obj->id, 52, 'Check 52 ID' );
+
+# Make sure that the protected attribute fails.
+eval { Class::Meta::Test->new( name => 'foo' ) };
+chk( 'constructor protected exception',
+ qr/name is a protected attribute of Class::Meta::Test/ );
+eval { $ctor->call('Class::Meta::Test', name => 'foo' ) };
+chk( 'indirect constructor protected exception',
+ qr/name is a protected attribute of Class::Meta::Test/);
+
+# Make sure that the private attribute fails.
+eval { Class::Meta::Test->new( age => 44 ) };
+chk('constructor private exception',
+ qr/age is a private attribute of Class::Meta::Test/);
+eval { $ctor->call('Class::Meta::Test', age => 44 ) };
+chk( 'indirect constructor private exception',
+ qr/age is a private attribute of Class::Meta::Test/);
+
+# Make sure that the protected constructor fails.
+eval { Class::Meta::Test->prot_new };
+chk( 'prot_new exeption',
+ qr/prot_new is a protected constrctor of Class::Meta::Test/ );
+
+# Make sure the same is true of the prot_new constructor object.
+ok( $ctor = $class->constructors('prot_new'),
+ 'Get "prot_new" constructor object' );
+eval { $ctor->call(__PACKAGE__) };
+chk( 'indirect prot_new exeption',
+ qr/prot_new is a protected constrctor of Class::Meta::Test/ );
+
+# Make sure that the private constructor fails.
+eval { Class::Meta::Test->priv_new };
+chk( 'priv_new exeption',
+ qr/priv_new is a private constructor of Class::Meta::Test/ );
+
+# Make sure the same is true of the priv_new constructor object.
+ok( $ctor = $class->constructors('priv_new'),
+ 'Get "priv_new" constructor object' );
+eval { $ctor->call(__PACKAGE__) };
+chk( 'indirect priv_new exeption',
+ qr/priv_new is a private constructor of Class::Meta::Test/ );
+
+sub chk {
+ my ($name, $qr) = @_;
+ # Catch the exception.
+ ok( my $err = $@, "Caught $name error" );
+ # Check its message.
+ like( $err, $qr, "Correct error" );
+ # Make sure it refers to this file.
+ like( $err, qr/(?:at\s+\Q$fn\E|\Q$fn\E\s+at)\s+line/, 'Correct context' );
+ # Make sure it doesn't refer to other Class::Meta files.
+ unlike( $err, qr|lib/Class/Meta|, 'Not incorrect context')
+}
Added: packages/libclass-meta-perl/branches/upstream/current/t/view_affordance.t
===================================================================
--- packages/libclass-meta-perl/branches/upstream/current/t/view_affordance.t 2006-01-04 09:19:20 UTC (rev 1847)
+++ packages/libclass-meta-perl/branches/upstream/current/t/view_affordance.t 2006-01-04 09:24:55 UTC (rev 1848)
@@ -0,0 +1,502 @@
+#!perl -w
+
+# $Id: view_affordance.t 2384 2005-12-14 04:27:23Z theory $
+
+##############################################################################
+# Set up the tests.
+##############################################################################
+
+use strict;
+use Test::More tests => 209;
+
+##############################################################################
+# Create a simple class.
+##############################################################################
+
+package Class::Meta::Test;
+use strict;
+
+BEGIN {
+ Test::More->import;
+ use_ok('Class::Meta');
+ use_ok('Class::Meta::Types::Numeric', 'affordance');
+ use_ok('Class::Meta::Types::String', 'affordance');
+}
+
+BEGIN {
+ ok( my $c = Class::Meta->new(
+ key => 'person',
+ package => __PACKAGE__,
+ trust => 'Class::Meta::TrustMe',
+ name => 'Class::Meta::TestPerson Class',
+ desc => 'Special person class just for testing Class::Meta.',
+ ), "Create Class::Meta object" );
+
+ # Add a constructor.
+ ok( $c->add_constructor( name => 'new',
+ create => 1 ),
+ "Add new constructor" );
+
+ # Add a couple of attributes with created methods.
+ ok( $c->add_attribute( name => 'id',
+ view => Class::Meta::PUBLIC,
+ type => 'integer',
+ label => 'ID',
+ required => 1,
+ default => 22,
+ ),
+ "Add id attribute" );
+ ok( $c->add_attribute( name => 'name',
+ view => Class::Meta::PROTECTED,
+ type => 'string',
+ label => 'Name',
+ required => 1,
+ default => '',
+ ),
+ "Add protected name attribute" );
+ ok( $c->add_attribute( name => 'age',
+ view => Class::Meta::PRIVATE,
+ type => 'integer',
+ label => 'Age',
+ desc => "The person's age.",
+ required => 0,
+ default => 0,
+ ),
+ "Add private age attribute" );
+ ok( $c->add_attribute( name => 'sn',
+ view => Class::Meta::TRUSTED,
+ type => 'string',
+ label => 'SN',
+ desc => "The person's serial number.",
+ required => 0,
+ default => '',
+ ),
+ "Add trusted sn attribute" );
+ $c->build;
+}
+
+##############################################################################
+# From within the package, the private and public attributes should just work.
+##############################################################################
+
+ok( my $obj = __PACKAGE__->new, "Create new object" );
+ok( my $class = __PACKAGE__->my_class, "Get class object" );
+is_deeply( [map { $_->name } $class->attributes], [qw(id name age sn)],
+ 'Call to attributes() should return all attributes' );
+
+# Check id public attribute.
+is( $obj->get_id, 22, 'Check default ID' );
+ok( $obj->set_id(12), "Set ID" );
+is( $obj->get_id, 12, 'Check 12 ID' );
+ok( my $attr = $class->attributes('id'), 'Get "id" attribute object' );
+is( $attr->get($obj), 12, "Check indirect 12 ID" );
+ok( $attr->set($obj, 15), "Indirectly set ID" );
+is( $attr->get($obj), 15, "Check indirect 15 ID" );
+
+# Check name protected attribute succeeds.
+is( $obj->get_name, '', 'Check empty name' );
+ok( $obj->set_name('Larry'), "Set name" );
+is( $obj->get_name, 'Larry', 'Check "Larry" name' );
+ok( $attr = $class->attributes('name'), 'Get "name" attribute object' );
+is( $attr->get($obj), 'Larry', 'Check indirect "Larry" name' );
+ok( $attr->set($obj, 'Chip'), "Indirectly set name" );
+is( $attr->get($obj), 'Chip', 'Check indirect "chip" name' );
+
+# Check age private attribute succeeds.
+is( $obj->get_age, 0, 'Check default age' );
+ok( $obj->set_age(42), "Set age" );
+is( $obj->get_age, 42, 'Check 42 age' );
+ok( $attr = $class->attributes('age'), 'Get "age" attribute object' );
+is( $attr->get($obj), 42, "Check indirect 12 age" );
+ok( $attr->set($obj, 15), "Indirectly set age" );
+is( $attr->get($obj), 15, "Check indirect 15 age" );
+
+# Check sn trusted attribute succeeds.
+is( $obj->get_sn, '', 'Check empty sn' );
+ok( $obj->set_sn('123456789'), "Set sn" );
+is( $obj->get_sn, '123456789', 'Check "123456789" sn' );
+ok( $attr = $class->attributes('sn'), 'Get "sn" attribute object' );
+is( $attr->get($obj), '123456789', 'Check indirect "123456789" sn' );
+ok( $attr->set($obj, '987654321'), "Indirectly set sn" );
+is( $attr->get($obj), '987654321', 'Check indirect "987654321" sn' );
+
+# Make sure that we can set all of the attributes via new().
+ok( $obj = __PACKAGE__->new( id => 10,
+ name => 'Damian',
+ sn => 'au',
+ age => 35),
+ "Create another new object" );
+
+is( $obj->get_id, 10, 'Check 10 ID' );
+is( $obj->get_name, 'Damian', 'Check Damian name' );
+is( $obj->get_age, 35, 'Check 35 age' );
+is( $obj->get_sn, 'au', 'Check sn is "au"');
+
+# Do the same with the constructor object.
+ok( my $ctor = $class->constructors('new'), 'Get "new" constructor object' );
+ok( $obj = $ctor->call(__PACKAGE__,
+ id => 10,
+ name => 'Damian',
+ sn => 'au',
+ age => 35),
+ "Create another new object" );
+
+is( $obj->get_id, 10, 'Check 10 ID' );
+is( $obj->get_name, 'Damian', 'Check Damian name' );
+is( $obj->get_age, 35, 'Check 35 age' );
+is( $obj->get_sn, 'au', 'Check sn is "au"');
+
+##############################################################################
+# Set up an inherited package.
+##############################################################################
+package Class::Meta::Testarama;
+use strict;
+use base 'Class::Meta::Test';
+
+BEGIN {
+ Test::More->import;
+ Class::Meta->new(key => 'testarama')->build;
+}
+
+ok( $obj = __PACKAGE__->new, "Create new Testarama object" );
+ok( $class = __PACKAGE__->my_class, "Get Testarama class object" );
+is_deeply( [map { $_->name } $class->attributes], [qw(id name)],
+ "Call to attributes() should return public and protected attrs" );
+
+# Check id public attribute.
+is( $obj->get_id, 22, 'Check default ID' );
+ok( $obj->set_id(12), "Set ID" );
+is( $obj->get_id, 12, 'Check 12 ID' );
+ok( $attr = $class->attributes('id'), 'Get "id" attribute object' );
+is( $attr->get($obj), 12, "Check indirect 12 ID" );
+ok( $attr->set($obj, 15), "Indirectly set ID" );
+is( $attr->get($obj), 15, "Check indirect 15 ID" );
+
+# Check name protected attribute succeeds.
+is( $obj->get_name, '', 'Check empty name' );
+ok( $obj->set_name('Larry'), "Set name" );
+is( $obj->get_name, 'Larry', 'Check Larry name' );
+ok( $attr = $class->attributes('name'), 'Get "name" attribute object' );
+is( $attr->get($obj), 'Larry', 'Check indirect "Larry" name' );
+ok( $attr->set($obj, 'Chip'), "Indirectly set name" );
+is( $attr->get($obj), 'Chip', 'Check indirect "chip" name' );
+
+# Check age private attribute
+eval { $obj->set_age(12) };
+ok( my $err = $@, 'Catch private exception');
+like( $err, qr/age is a private attribute of Class::Meta::Test/,
+ 'Correct private exception');
+eval { $obj->get_age };
+ok( $err = $@, 'Catch another private exception');
+like( $err, qr/age is a private attribute of Class::Meta::Test/,
+ 'Correct private exception again');
+
+# Check that age fails when accessed indirectly, too.
+ok( $attr = $class->attributes('age'), 'Get "age" attribute object' );
+eval { $attr->set($obj, 12) };
+ok( $err = $@, 'Catch indirect private exception');
+like( $err, qr/age is a private attribute of Class::Meta::Test/,
+ 'Correct indirectprivate exception');
+eval { $attr->get($obj) };
+ok( $err = $@, 'Catch another indirect private exception');
+like( $err, qr/age is a private attribute of Class::Meta::Test/,
+ 'Correct indirect private exception again');
+
+# Check fail sn trusted attribute
+eval { $obj->set_sn('foo') };
+ok( $err = $@, 'Catch private exception');
+like( $err, qr/sn is a trusted attribute of Class::Meta::Test/,
+ 'Correct private exception');
+eval { $obj->get_sn };
+ok( $err = $@, 'Catch another private exception');
+like( $err, qr/sn is a trusted attribute of Class::Meta::Test/,
+ 'Correct private exception again');
+
+# Check that sn fails when accessed indirectly, too.
+ok( $attr = $class->attributes('sn'), 'Get "sn" attribute object' );
+eval { $attr->set($obj, 'foo') };
+ok( $err = $@, 'Catch indirect private exception');
+like( $err, qr/sn is a trusted attribute of Class::Meta::Test/,
+ 'Correct indirectprivate exception');
+eval { $attr->get($obj) };
+ok( $err = $@, 'Catch another indirect private exception');
+like( $err, qr/sn is a trusted attribute of Class::Meta::Test/,
+ 'Correct indirect private exception again');
+
+# Make sure that we can set protected attributes via new().
+ok( $obj = __PACKAGE__->new( id => 10,
+ name => 'Damian'),
+ "Create another new object" );
+
+is( $obj->get_id, 10, 'Check 10 ID' );
+is( $obj->get_name, 'Damian', 'Check Damian name' );
+
+# Make sure that the private attribute fails.
+eval { __PACKAGE__->new( age => 44 ) };
+ok( $err = $@, 'Catch constructor private exception');
+like( $err, qr/age is a private attribute of Class::Meta::Test/,
+ 'Correct private constructor exception');
+
+# Make sure that the trusted attribute fails.
+eval { __PACKAGE__->new( sn => 'foo' ) };
+ok( $err = $@, 'Catch constructor trusted exception');
+like( $err, qr/sn is a trusted attribute of Class::Meta::Test/,
+ 'Correct trusted constructor exception');
+
+# Do the same with the constructor object.
+ok( $ctor = $class->constructors('new'), 'Get "new" constructor object' );
+ok( $obj = $ctor->call(__PACKAGE__,
+ id => 10,
+ name => 'Damian'),
+ "Create another new object" );
+
+is( $obj->get_id, 10, 'Check 10 ID' );
+is( $obj->get_name, 'Damian', 'Check Damian name' );
+
+# Make sure that the private attribute fails.
+eval { $ctor->call(__PACKAGE__, age => 44 ) };
+ok( $err = $@, 'Catch indirect constructor private exception');
+like( $err, qr/age is a private attribute of Class::Meta::Test/,
+ 'Correct indirect private constructor exception');
+
+# Make sure that the private attribute fails.
+eval { $ctor->call(__PACKAGE__, sn => 'foo' ) };
+ok( $err = $@, 'Catch indirect constructor trusted exception');
+like( $err, qr/sn is a trusted attribute of Class::Meta::Test/,
+ 'Correct indirect trusted constructor exception');
+
+##############################################################################
+# Set up a trusted package.
+##############################################################################
+package Class::Meta::TrustMe;
+use strict;
+
+BEGIN { Test::More->import }
+
+ok( $obj = Class::Meta::Test->new, "Create new Test object" );
+ok( $class = Class::Meta::Test->my_class, "Get Test class object" );
+is_deeply( [map { $_->name } $class->attributes], [qw(id sn)],
+ "Call to attributes() should return public and trusted attrs" );
+is_deeply( [map { $_->name } Class::Meta::Testarama->my_class->attributes],
+ [qw(id sn)],
+ "Call to inherited attributes() should also return public and protected attrs" );
+
+# Check id public attribute.
+is( $obj->get_id, 22, 'Check default ID' );
+ok( $obj->set_id(12), "Set ID" );
+is( $obj->get_id, 12, 'Check 12 ID' );
+ok( $attr = $class->attributes('id'), 'Get "id" attribute object' );
+is( $attr->get($obj), 12, "Check indirect 12 ID" );
+ok( $attr->set($obj, 15), "Indirectly set ID" );
+is( $attr->get($obj), 15, "Check indirect 15 ID" );
+
+# Check name protected attribute
+eval { $obj->set_name('foo') };
+ok( $err = $@, "Catch protected exception");
+like( $err, qr/name is a protected attribute of Class::Meta::Test/,
+ "Correct protected exception" );
+eval { $obj->get_name };
+ok( $err = $@, "Catch another protected exception");
+like( $err, qr/name is a protected attribute of Class::Meta::Test/,
+ "Another correct protected exception" );
+
+# Check that name fails when accessed indirectly, too.
+ok( $attr = $class->attributes('name'), 'Get "name" attribute object' );
+eval { $attr->set($obj, 'foo') };
+ok( $err = $@, "Catch indirect protected exception");
+like( $err, qr/name is a protected attribute of Class::Meta::Test/,
+ "Correct indirect protected exception" );
+eval { $attr->get($obj, 'foo') };
+ok( $err = $@, "Catch another indirect protected exception");
+like( $err, qr/name is a protected attribute of Class::Meta::Test/,
+ "Another correct indirect protected exception" );
+
+# Check age private attribute
+eval { $obj->set_age(12) };
+ok( $err = $@, 'Catch private exception');
+like( $err, qr/age is a private attribute of Class::Meta::Test/,
+ 'Correct private exception');
+eval { $obj->get_age };
+ok( $err = $@, 'Catch another private exception');
+like( $err, qr/age is a private attribute of Class::Meta::Test/,
+ 'Correct private exception again');
+
+# Check that age fails when accessed indirectly, too.
+ok( $attr = $class->attributes('age'), 'Get "age" attribute object' );
+eval { $attr->set($obj, 12) };
+ok( $err = $@, 'Catch indirect private exception');
+like( $err, qr/age is a private attribute of Class::Meta::Test/,
+ 'Correct indirectprivate exception');
+eval { $attr->get($obj) };
+ok( $err = $@, 'Catch another indirect private exception');
+like( $err, qr/age is a private attribute of Class::Meta::Test/,
+ 'Correct indirect private exception again');
+
+# Check sn trusted attribute succeeds.
+is( $obj->get_sn, '', 'Check empty sn' );
+ok( $obj->set_sn('123456789'), "Set sn" );
+is( $obj->get_sn, '123456789', 'Check "123456789" sn' );
+ok( $attr = $class->attributes('sn'), 'Get "sn" attribute object' );
+is( $attr->get($obj), '123456789', 'Check indirect "123456789" sn' );
+ok( $attr->set($obj, '987654321'), "Indirectly set sn" );
+is( $attr->get($obj), '987654321', 'Check indirect "987654321" sn' );
+
+# Make sure that sn trusted attribute works for subclasses, too.
+ok( $obj = Class::Meta::Testarama->new, "Create new Testarama object" );
+is( $obj->get_sn, '', 'Check empty sn' );
+ok( $obj->set_sn('123456789'), "Set sn" );
+is( $obj->get_sn, '123456789', 'Check "123456789" sn' );
+ok( $attr = $class->attributes('sn'), 'Get "sn" attribute object' );
+is( $attr->get($obj), '123456789', 'Check indirect "123456789" sn' );
+ok( $attr->set($obj, '987654321'), "Indirectly set sn" );
+is( $attr->get($obj), '987654321', 'Check indirect "987654321" sn' );
+
+# Make sure that we can set trusted attributes via new().
+ok( $obj = Class::Meta::Test->new( id => 10,
+ sn => 'foo'),
+ "Create another new object" );
+is( $obj->get_id, 10, 'Check 10 ID' );
+is( $obj->get_sn, 'foo', 'Check foo sn' );
+
+# Make sure that the private attribute fails.
+eval { Class::Meta::Test->new( age => 44 ) };
+ok( $err = $@, "Catch constructor private exception");
+like( $err, qr/age is a private attribute of Class::Meta::Test/,
+ "Got the right constructor private exception");
+
+# Make sure that the protected attribute fails.
+eval { Class::Meta::Test->new( name => 'Damian' ) };
+ok( $err = $@, "Catch constructor protected exception");
+like( $err, qr/name is a protected attribute of Class::Meta::Test/,
+ "Got the right constructor protected exception");
+
+# Do the same with the new constructor object.
+ok( $ctor = $class->constructors('new'), 'Get "new" constructor object' );
+ok( $obj = $ctor->call('Class::Meta::Test',
+ id => 10,
+ sn => 'foo'),
+ "Create another new object" );
+
+is( $obj->get_id, 10, 'Check 10 ID' );
+is( $obj->get_sn, 'foo', 'Check foo sn' );
+
+# Make sure that the private attribute fails.
+eval { $ctor->call('Class::Meta::Test', age => 44 ) };
+ok( $err = $@, "Catch indirect constructor private exception");
+like( $err, qr/age is a private attribute of Class::Meta::Test/,
+ "Got the right indirect constructor private exception");
+
+# Make sure that the protected attribute fails.
+eval { $ctor->call('Class::Meta::Test', name => 'Damian' ) };
+ok( $err = $@, "Catch indirect constructor protected exception");
+like( $err, qr/name is a protected attribute of Class::Meta::Test/,
+ "Got the right indirect constructor protected exception");
+
+##############################################################################
+# Now do test in a completely independent package.
+##############################################################################
+package main;
+
+ok( $obj = Class::Meta::Test->new, "Create new object in main" );
+ok( $class = Class::Meta::Test->my_class, "Get class object in main" );
+
+# Make sure we can access id.
+is( $obj->get_id, 22, 'Check default ID' );
+ok( $obj->set_id(12), "Set ID" );
+is( $obj->get_id, 12, 'Check 12 ID' );
+ok( $attr = $class->attributes('id'), 'Get "id" attribute object' );
+is( $attr->get($obj), 12, "Check indirect 12 ID" );
+ok( $attr->set($obj, 15), "Indirectly set ID" );
+is( $attr->get($obj), 15, "Check indirect 15 ID" );
+
+# Check name protected attribute
+eval { $obj->set_name('foo') };
+ok( $err = $@, 'Catch protected exception');
+like( $err, qr/name is a protected attribute of Class::Meta::Test/,
+ 'Correct protected exception');
+eval { $obj->get_name };
+ok( $err = $@, 'Catch another protected exception');
+like( $err, qr/name is a protected attribute of Class::Meta::Test/,
+ 'Correct protected exception again');
+
+# Check that name fails when accessed indirectly, too.
+ok( $attr = $class->attributes('name'), 'Get "name" attribute object' );
+eval { $attr->set($obj, 'foo') };
+ok( $err = $@, 'Catch indirect protected exception');
+like( $err, qr/name is a protected attribute of Class::Meta::Test/,
+ 'Correct indirectprotected exception');
+eval { $attr->get($obj) };
+ok( $err = $@, 'Catch another indirect protected exception');
+like( $err, qr/name is a protected attribute of Class::Meta::Test/,
+ 'Correct indirect protected exception again');
+
+# Check age private attribute
+eval { $obj->set_age(12) };
+ok( $err = $@, 'Catch private exception');
+like( $err, qr/age is a private attribute of Class::Meta::Test/,
+ 'Correct private exception');
+eval { $obj->get_age };
+ok( $err = $@, 'Catch another private exception');
+like( $err, qr/age is a private attribute of Class::Meta::Test/,
+ 'Correct private exception again');
+
+# Check that age fails when accessed indirectly, too.
+ok( $attr = $class->attributes('age'), 'Get "age" attribute object' );
+eval { $attr->set($obj, 12) };
+ok( $err = $@, 'Catch indirect private exception');
+like( $err, qr/age is a private attribute of Class::Meta::Test/,
+ 'Correct indirectprivate exception');
+eval { $attr->get($obj) };
+ok( $err = $@, 'Catch another indirect private exception');
+like( $err, qr/age is a private attribute of Class::Meta::Test/,
+ 'Correct indirect private exception again');
+
+# Check sn trusted attribute
+eval { $obj->set_sn('foo') };
+ok( $err = $@, 'Catch private exception');
+like( $err, qr/sn is a trusted attribute of Class::Meta::Test/,
+ 'Correct private exception');
+eval { $obj->get_sn };
+ok( $err = $@, 'Catch another private exception');
+like( $err, qr/sn is a trusted attribute of Class::Meta::Test/,
+ 'Correct private exception again');
+
+# Check that sn fails when accessed indirectly, too.
+ok( $attr = $class->attributes('sn'), 'Get "sn" attribute object' );
+eval { $attr->set($obj, 'foo') };
+ok( $err = $@, 'Catch indirect private exception');
+like( $err, qr/sn is a trusted attribute of Class::Meta::Test/,
+ 'Correct indirectprivate exception');
+eval { $attr->get($obj) };
+ok( $err = $@, 'Catch another indirect private exception');
+like( $err, qr/sn is a trusted attribute of Class::Meta::Test/,
+ 'Correct indirect private exception again');
+
+# Try the constructor with parameters.
+ok( $obj = Class::Meta::Test->new( id => 1 ), "Create new object with id" );
+is( $obj->get_id, 1, 'Check 1 ID' );
+ok( $ctor = $class->constructors('new'), "Get new constructor" );
+ok( $obj = $ctor->call('Class::Meta::Test', id => 52 ),
+ "Indirectly create new object with id" );
+is( $obj->get_id, 52, 'Check 52 ID' );
+
+# Make sure that the protected attribute fails.
+eval { Class::Meta::Test->new( name => 'foo' ) };
+ok( $err = $@, 'Catch constructor protected exception');
+like( $err, qr/name is a protected attribute of Class::Meta::Test/,
+ 'Correct protected constructor exception');
+eval { $ctor->call('Class::Meta::Test', name => 'foo' ) };
+ok( $err = $@, 'Catch indirect constructor protected exception');
+like( $err, qr/name is a protected attribute of Class::Meta::Test/,
+ 'Correct indirect protected constructor exception');
+
+# Make sure that the private attribute fails.
+eval { Class::Meta::Test->new( age => 44 ) };
+ok( $err = $@, 'Catch constructor private exception');
+like( $err, qr/age is a private attribute of Class::Meta::Test/,
+ 'Correct private constructor exception');
+eval { $ctor->call('Class::Meta::Test', age => 44 ) };
+ok( $err = $@, 'Catch indirect constructor private exception');
+like( $err, qr/age is a private attribute of Class::Meta::Test/,
+ 'Correct indirect private constructor exception');
+
Added: packages/libclass-meta-perl/branches/upstream/current/t/view_semi_affordance.t
===================================================================
--- packages/libclass-meta-perl/branches/upstream/current/t/view_semi_affordance.t 2006-01-04 09:19:20 UTC (rev 1847)
+++ packages/libclass-meta-perl/branches/upstream/current/t/view_semi_affordance.t 2006-01-04 09:24:55 UTC (rev 1848)
@@ -0,0 +1,501 @@
+#!perl -w
+
+# $Id: view_semi_affordance.t 2384 2005-12-14 04:27:23Z theory $
+
+##############################################################################
+# Set up the tests.
+##############################################################################
+
+use strict;
+use Test::More tests => 209;
+
+##############################################################################
+# Create a simple class.
+##############################################################################
+
+package Class::Meta::Test;
+use strict;
+
+BEGIN {
+ Test::More->import;
+ use_ok('Class::Meta');
+ use_ok('Class::Meta::Types::Numeric', 'semi-affordance');
+ use_ok('Class::Meta::Types::String', 'semi-affordance');
+}
+
+BEGIN {
+ ok( my $c = Class::Meta->new(
+ key => 'person',
+ package => __PACKAGE__,
+ trust => 'Class::Meta::TrustMe',
+ name => 'Class::Meta::TestPerson Class',
+ desc => 'Special person class just for testing Class::Meta.',
+ ), "Create Class::Meta object" );
+
+ # Add a constructor.
+ ok( $c->add_constructor( name => 'new',
+ create => 1 ),
+ "Add new constructor" );
+
+ # Add a couple of attributes with created methods.
+ ok( $c->add_attribute( name => 'id',
+ view => Class::Meta::PUBLIC,
+ type => 'integer',
+ label => 'ID',
+ required => 1,
+ default => 22,
+ ),
+ "Add id attribute" );
+ ok( $c->add_attribute( name => 'name',
+ view => Class::Meta::PROTECTED,
+ type => 'string',
+ label => 'Name',
+ required => 1,
+ default => '',
+ ),
+ "Add protected name attribute" );
+ ok( $c->add_attribute( name => 'age',
+ view => Class::Meta::PRIVATE,
+ type => 'integer',
+ label => 'Age',
+ desc => "The person's age.",
+ required => 0,
+ default => 0,
+ ),
+ "Add private age attribute" );
+ ok( $c->add_attribute( name => 'sn',
+ view => Class::Meta::TRUSTED,
+ type => 'string',
+ label => 'SN',
+ desc => "The person's serial number.",
+ required => 0,
+ default => '',
+ ),
+ "Add trusted sn attribute" );
+ $c->build;
+}
+
+##############################################################################
+# From within the package, the private and public attributes should just work.
+##############################################################################
+
+ok( my $obj = __PACKAGE__->new, "Create new object" );
+ok( my $class = __PACKAGE__->my_class, "Get class object" );
+is_deeply( [map { $_->name } $class->attributes], [qw(id name age sn)],
+ 'Call to attributes() should return all attributes' );
+
+# Check id public attribute.
+is( $obj->id, 22, 'Check default ID' );
+ok( $obj->set_id(12), "Set ID" );
+is( $obj->id, 12, 'Check 12 ID' );
+ok( my $attr = $class->attributes('id'), 'Get "id" attribute object' );
+is( $attr->get($obj), 12, "Check indirect 12 ID" );
+ok( $attr->set($obj, 15), "Indirectly set ID" );
+is( $attr->get($obj), 15, "Check indirect 15 ID" );
+
+# Check name protected attribute succeeds.
+is( $obj->name, '', 'Check empty name' );
+ok( $obj->set_name('Larry'), "Set name" );
+is( $obj->name, 'Larry', 'Check "Larry" name' );
+ok( $attr = $class->attributes('name'), 'Get "name" attribute object' );
+is( $attr->get($obj), 'Larry', 'Check indirect "Larry" name' );
+ok( $attr->set($obj, 'Chip'), "Indirectly set name" );
+is( $attr->get($obj), 'Chip', 'Check indirect "chip" name' );
+
+# Check age private attribute succeeds.
+is( $obj->age, 0, 'Check default age' );
+ok( $obj->set_age(42), "Set age" );
+is( $obj->age, 42, 'Check 42 age' );
+ok( $attr = $class->attributes('age'), 'Get "age" attribute object' );
+is( $attr->get($obj), 42, "Check indirect 12 age" );
+ok( $attr->set($obj, 15), "Indirectly set age" );
+is( $attr->get($obj), 15, "Check indirect 15 age" );
+
+# Check sn trusted attribute succeeds.
+is( $obj->sn, '', 'Check empty sn' );
+ok( $obj->set_sn('123456789'), "Set sn" );
+is( $obj->sn, '123456789', 'Check "123456789" sn' );
+ok( $attr = $class->attributes('sn'), 'Get "sn" attribute object' );
+is( $attr->get($obj), '123456789', 'Check indirect "123456789" sn' );
+ok( $attr->set($obj, '987654321'), "Indirectly set sn" );
+is( $attr->get($obj), '987654321', 'Check indirect "987654321" sn' );
+
+# Make sure that we can set all of the attributes via new().
+ok( $obj = __PACKAGE__->new( id => 10,
+ name => 'Damian',
+ sn => 'au',
+ age => 35),
+ "Create another new object" );
+
+is( $obj->id, 10, 'Check 10 ID' );
+is( $obj->name, 'Damian', 'Check Damian name' );
+is( $obj->age, 35, 'Check 35 age' );
+is( $obj->sn, 'au', 'Check sn is "au"');
+
+# Do the same with the constructor object.
+ok( my $ctor = $class->constructors('new'), 'Get "new" constructor object' );
+ok( $obj = $ctor->call(__PACKAGE__,
+ id => 10,
+ name => 'Damian',
+ sn => 'au',
+ age => 35),
+ "Create another new object" );
+
+is( $obj->id, 10, 'Check 10 ID' );
+is( $obj->name, 'Damian', 'Check Damian name' );
+is( $obj->age, 35, 'Check 35 age' );
+is( $obj->sn, 'au', 'Check sn is "au"');
+
+##############################################################################
+# Set up an inherited package.
+##############################################################################
+package Class::Meta::Testarama;
+use strict;
+use base 'Class::Meta::Test';
+
+BEGIN {
+ Test::More->import;
+ Class::Meta->new(key => 'testarama')->build;
+}
+
+ok( $obj = __PACKAGE__->new, "Create new Testarama object" );
+ok( $class = __PACKAGE__->my_class, "Get Testarama class object" );
+is_deeply( [map { $_->name } $class->attributes], [qw(id name)],
+ "Call to attributes() should return public and protected attrs" );
+
+# Check id public attribute.
+is( $obj->id, 22, 'Check default ID' );
+ok( $obj->set_id(12), "Set ID" );
+is( $obj->id, 12, 'Check 12 ID' );
+ok( $attr = $class->attributes('id'), 'Get "id" attribute object' );
+is( $attr->get($obj), 12, "Check indirect 12 ID" );
+ok( $attr->set($obj, 15), "Indirectly set ID" );
+is( $attr->get($obj), 15, "Check indirect 15 ID" );
+
+# Check name protected attribute succeeds.
+is( $obj->name, '', 'Check empty name' );
+ok( $obj->set_name('Larry'), "Set name" );
+is( $obj->name, 'Larry', 'Check Larry name' );
+ok( $attr = $class->attributes('name'), 'Get "name" attribute object' );
+is( $attr->get($obj), 'Larry', 'Check indirect "Larry" name' );
+ok( $attr->set($obj, 'Chip'), "Indirectly set name" );
+is( $attr->get($obj), 'Chip', 'Check indirect "chip" name' );
+
+# Check age private attribute
+eval { $obj->set_age(12) };
+ok( my $err = $@, 'Catch private exception');
+like( $err, qr/age is a private attribute of Class::Meta::Test/,
+ 'Correct private exception');
+eval { $obj->age };
+ok( $err = $@, 'Catch another private exception');
+like( $err, qr/age is a private attribute of Class::Meta::Test/,
+ 'Correct private exception again');
+
+# Check that age fails when accessed indirectly, too.
+ok( $attr = $class->attributes('age'), 'Get "age" attribute object' );
+eval { $attr->set($obj, 12) };
+ok( $err = $@, 'Catch indirect private exception');
+like( $err, qr/age is a private attribute of Class::Meta::Test/,
+ 'Correct indirectprivate exception');
+eval { $attr->get($obj) };
+ok( $err = $@, 'Catch another indirect private exception');
+like( $err, qr/age is a private attribute of Class::Meta::Test/,
+ 'Correct indirect private exception again');
+
+# Check fail sn trusted attribute
+eval { $obj->set_sn('foo') };
+ok( $err = $@, 'Catch private exception');
+like( $err, qr/sn is a trusted attribute of Class::Meta::Test/,
+ 'Correct private exception');
+eval { $obj->sn };
+ok( $err = $@, 'Catch another private exception');
+like( $err, qr/sn is a trusted attribute of Class::Meta::Test/,
+ 'Correct private exception again');
+
+# Check that sn fails when accessed indirectly, too.
+ok( $attr = $class->attributes('sn'), 'Get "sn" attribute object' );
+eval { $attr->set($obj, 'foo') };
+ok( $err = $@, 'Catch indirect private exception');
+like( $err, qr/sn is a trusted attribute of Class::Meta::Test/,
+ 'Correct indirectprivate exception');
+eval { $attr->get($obj) };
+ok( $err = $@, 'Catch another indirect private exception');
+like( $err, qr/sn is a trusted attribute of Class::Meta::Test/,
+ 'Correct indirect private exception again');
+
+# Make sure that we can set protected attributes via new().
+ok( $obj = __PACKAGE__->new( id => 10,
+ name => 'Damian'),
+ "Create another new object" );
+
+is( $obj->id, 10, 'Check 10 ID' );
+is( $obj->name, 'Damian', 'Check Damian name' );
+
+# Make sure that the private attribute fails.
+eval { __PACKAGE__->new( age => 44 ) };
+ok( $err = $@, 'Catch constructor private exception');
+like( $err, qr/age is a private attribute of Class::Meta::Test/,
+ 'Correct private constructor exception');
+
+# Make sure that the trusted attribute fails.
+eval { __PACKAGE__->new( sn => 'foo' ) };
+ok( $err = $@, 'Catch constructor trusted exception');
+like( $err, qr/sn is a trusted attribute of Class::Meta::Test/,
+ 'Correct trusted constructor exception');
+
+# Do the same with the constructor object.
+ok( $ctor = $class->constructors('new'), 'Get "new" constructor object' );
+ok( $obj = $ctor->call(__PACKAGE__,
+ id => 10,
+ name => 'Damian'),
+ "Create another new object" );
+
+is( $obj->id, 10, 'Check 10 ID' );
+is( $obj->name, 'Damian', 'Check Damian name' );
+
+# Make sure that the private attribute fails.
+eval { $ctor->call(__PACKAGE__, age => 44 ) };
+ok( $err = $@, 'Catch indirect constructor private exception');
+like( $err, qr/age is a private attribute of Class::Meta::Test/,
+ 'Correct indirect private constructor exception');
+
+# Make sure that the private attribute fails.
+eval { $ctor->call(__PACKAGE__, sn => 'foo' ) };
+ok( $err = $@, 'Catch indirect constructor trusted exception');
+like( $err, qr/sn is a trusted attribute of Class::Meta::Test/,
+ 'Correct indirect trusted constructor exception');
+
+##############################################################################
+# Set up a trusted package.
+##############################################################################
+package Class::Meta::TrustMe;
+use strict;
+
+BEGIN { Test::More->import }
+
+ok( $obj = Class::Meta::Test->new, "Create new Test object" );
+ok( $class = Class::Meta::Test->my_class, "Get Test class object" );
+is_deeply( [map { $_->name } $class->attributes], [qw(id sn)],
+ "Call to attributes() should return public and trusted attrs" );
+is_deeply( [map { $_->name } Class::Meta::Testarama->my_class->attributes],
+ [qw(id sn)],
+ "Call to inherited attributes() should also return public and protected attrs" );
+
+# Check id public attribute.
+is( $obj->id, 22, 'Check default ID' );
+ok( $obj->set_id(12), "Set ID" );
+is( $obj->id, 12, 'Check 12 ID' );
+ok( $attr = $class->attributes('id'), 'Get "id" attribute object' );
+is( $attr->get($obj), 12, "Check indirect 12 ID" );
+ok( $attr->set($obj, 15), "Indirectly set ID" );
+is( $attr->get($obj), 15, "Check indirect 15 ID" );
+
+# Check name protected attribute
+eval { $obj->set_name('foo') };
+ok( $err = $@, "Catch protected exception");
+like( $err, qr/name is a protected attribute of Class::Meta::Test/,
+ "Correct protected exception" );
+eval { $obj->name };
+ok( $err = $@, "Catch another protected exception");
+like( $err, qr/name is a protected attribute of Class::Meta::Test/,
+ "Another correct protected exception" );
+
+# Check that name fails when accessed indirectly, too.
+ok( $attr = $class->attributes('name'), 'Get "name" attribute object' );
+eval { $attr->set($obj, 'foo') };
+ok( $err = $@, "Catch indirect protected exception");
+like( $err, qr/name is a protected attribute of Class::Meta::Test/,
+ "Correct indirect protected exception" );
+eval { $attr->get($obj, 'foo') };
+ok( $err = $@, "Catch another indirect protected exception");
+like( $err, qr/name is a protected attribute of Class::Meta::Test/,
+ "Another correct indirect protected exception" );
+
+# Check age private attribute
+eval { $obj->set_age(12) };
+ok( $err = $@, 'Catch private exception');
+like( $err, qr/age is a private attribute of Class::Meta::Test/,
+ 'Correct private exception');
+eval { $obj->age };
+ok( $err = $@, 'Catch another private exception');
+like( $err, qr/age is a private attribute of Class::Meta::Test/,
+ 'Correct private exception again');
+
+# Check that age fails when accessed indirectly, too.
+ok( $attr = $class->attributes('age'), 'Get "age" attribute object' );
+eval { $attr->set($obj, 12) };
+ok( $err = $@, 'Catch indirect private exception');
+like( $err, qr/age is a private attribute of Class::Meta::Test/,
+ 'Correct indirectprivate exception');
+eval { $attr->get($obj) };
+ok( $err = $@, 'Catch another indirect private exception');
+like( $err, qr/age is a private attribute of Class::Meta::Test/,
+ 'Correct indirect private exception again');
+
+# Check sn trusted attribute succeeds.
+is( $obj->sn, '', 'Check empty sn' );
+ok( $obj->set_sn('123456789'), "Set sn" );
+is( $obj->sn, '123456789', 'Check "123456789" sn' );
+ok( $attr = $class->attributes('sn'), 'Get "sn" attribute object' );
+is( $attr->get($obj), '123456789', 'Check indirect "123456789" sn' );
+ok( $attr->set($obj, '987654321'), "Indirectly set sn" );
+is( $attr->get($obj), '987654321', 'Check indirect "987654321" sn' );
+
+ok( $obj = Class::Meta::Testarama->new, "Create new Testarama object" );
+is( $obj->sn, '', 'Check empty sn' );
+ok( $obj->set_sn('123456789'), "Set sn" );
+is( $obj->sn, '123456789', 'Check "123456789" sn' );
+ok( $attr = $class->attributes('sn'), 'Get "sn" attribute object' );
+is( $attr->get($obj), '123456789', 'Check indirect "123456789" sn' );
+ok( $attr->set($obj, '987654321'), "Indirectly set sn" );
+is( $attr->get($obj), '987654321', 'Check indirect "987654321" sn' );
+
+# Make sure that we can set trusted attributes via new().
+ok( $obj = Class::Meta::Test->new( id => 10,
+ sn => 'foo'),
+ "Create another new object" );
+is( $obj->id, 10, 'Check 10 ID' );
+is( $obj->sn, 'foo', 'Check foo sn' );
+
+# Make sure that the private attribute fails.
+eval { Class::Meta::Test->new( age => 44 ) };
+ok( $err = $@, "Catch constructor private exception");
+like( $err, qr/age is a private attribute of Class::Meta::Test/,
+ "Got the right constructor private exception");
+
+# Make sure that the protected attribute fails.
+eval { Class::Meta::Test->new( name => 'Damian' ) };
+ok( $err = $@, "Catch constructor protected exception");
+like( $err, qr/name is a protected attribute of Class::Meta::Test/,
+ "Got the right constructor protected exception");
+
+# Do the same with the new constructor object.
+ok( $ctor = $class->constructors('new'), 'Get "new" constructor object' );
+ok( $obj = $ctor->call('Class::Meta::Test',
+ id => 10,
+ sn => 'foo'),
+ "Create another new object" );
+
+is( $obj->id, 10, 'Check 10 ID' );
+is( $obj->sn, 'foo', 'Check foo sn' );
+
+# Make sure that the private attribute fails.
+eval { $ctor->call('Class::Meta::Test', age => 44 ) };
+ok( $err = $@, "Catch indirect constructor private exception");
+like( $err, qr/age is a private attribute of Class::Meta::Test/,
+ "Got the right indirect constructor private exception");
+
+# Make sure that the protected attribute fails.
+eval { $ctor->call('Class::Meta::Test', name => 'Damian' ) };
+ok( $err = $@, "Catch indirect constructor protected exception");
+like( $err, qr/name is a protected attribute of Class::Meta::Test/,
+ "Got the right indirect constructor protected exception");
+
+##############################################################################
+# Now do test in a completely independent package.
+##############################################################################
+package main;
+
+ok( $obj = Class::Meta::Test->new, "Create new object in main" );
+ok( $class = Class::Meta::Test->my_class, "Get class object in main" );
+
+# Make sure we can access id.
+is( $obj->id, 22, 'Check default ID' );
+ok( $obj->set_id(12), "Set ID" );
+is( $obj->id, 12, 'Check 12 ID' );
+ok( $attr = $class->attributes('id'), 'Get "id" attribute object' );
+is( $attr->get($obj), 12, "Check indirect 12 ID" );
+ok( $attr->set($obj, 15), "Indirectly set ID" );
+is( $attr->get($obj), 15, "Check indirect 15 ID" );
+
+# Check name protected attribute
+eval { $obj->set_name('foo') };
+ok( $err = $@, 'Catch protected exception');
+like( $err, qr/name is a protected attribute of Class::Meta::Test/,
+ 'Correct protected exception');
+eval { $obj->name };
+ok( $err = $@, 'Catch another protected exception');
+like( $err, qr/name is a protected attribute of Class::Meta::Test/,
+ 'Correct protected exception again');
+
+# Check that name fails when accessed indirectly, too.
+ok( $attr = $class->attributes('name'), 'Get "name" attribute object' );
+eval { $attr->set($obj, 'foo') };
+ok( $err = $@, 'Catch indirect protected exception');
+like( $err, qr/name is a protected attribute of Class::Meta::Test/,
+ 'Correct indirectprotected exception');
+eval { $attr->get($obj) };
+ok( $err = $@, 'Catch another indirect protected exception');
+like( $err, qr/name is a protected attribute of Class::Meta::Test/,
+ 'Correct indirect protected exception again');
+
+# Check age private attribute
+eval { $obj->set_age(12) };
+ok( $err = $@, 'Catch private exception');
+like( $err, qr/age is a private attribute of Class::Meta::Test/,
+ 'Correct private exception');
+eval { $obj->age };
+ok( $err = $@, 'Catch another private exception');
+like( $err, qr/age is a private attribute of Class::Meta::Test/,
+ 'Correct private exception again');
+
+# Check that age fails when accessed indirectly, too.
+ok( $attr = $class->attributes('age'), 'Get "age" attribute object' );
+eval { $attr->set($obj, 12) };
+ok( $err = $@, 'Catch indirect private exception');
+like( $err, qr/age is a private attribute of Class::Meta::Test/,
+ 'Correct indirectprivate exception');
+eval { $attr->get($obj) };
+ok( $err = $@, 'Catch another indirect private exception');
+like( $err, qr/age is a private attribute of Class::Meta::Test/,
+ 'Correct indirect private exception again');
+
+# Check sn trusted attribute
+eval { $obj->set_sn('foo') };
+ok( $err = $@, 'Catch private exception');
+like( $err, qr/sn is a trusted attribute of Class::Meta::Test/,
+ 'Correct private exception');
+eval { $obj->sn };
+ok( $err = $@, 'Catch another private exception');
+like( $err, qr/sn is a trusted attribute of Class::Meta::Test/,
+ 'Correct private exception again');
+
+# Check that sn fails when accessed indirectly, too.
+ok( $attr = $class->attributes('sn'), 'Get "sn" attribute object' );
+eval { $attr->set($obj, 'foo') };
+ok( $err = $@, 'Catch indirect private exception');
+like( $err, qr/sn is a trusted attribute of Class::Meta::Test/,
+ 'Correct indirectprivate exception');
+eval { $attr->get($obj) };
+ok( $err = $@, 'Catch another indirect private exception');
+like( $err, qr/sn is a trusted attribute of Class::Meta::Test/,
+ 'Correct indirect private exception again');
+
+# Try the constructor with parameters.
+ok( $obj = Class::Meta::Test->new( id => 1 ), "Create new object with id" );
+is( $obj->id, 1, 'Check 1 ID' );
+ok( $ctor = $class->constructors('new'), "Get new constructor" );
+ok( $obj = $ctor->call('Class::Meta::Test', id => 52 ),
+ "Indirectly create new object with id" );
+is( $obj->id, 52, 'Check 52 ID' );
+
+# Make sure that the protected attribute fails.
+eval { Class::Meta::Test->new( name => 'foo' ) };
+ok( $err = $@, 'Catch constructor protected exception');
+like( $err, qr/name is a protected attribute of Class::Meta::Test/,
+ 'Correct protected constructor exception');
+eval { $ctor->call('Class::Meta::Test', name => 'foo' ) };
+ok( $err = $@, 'Catch indirect constructor protected exception');
+like( $err, qr/name is a protected attribute of Class::Meta::Test/,
+ 'Correct indirect protected constructor exception');
+
+# Make sure that the private attribute fails.
+eval { Class::Meta::Test->new( age => 44 ) };
+ok( $err = $@, 'Catch constructor private exception');
+like( $err, qr/age is a private attribute of Class::Meta::Test/,
+ 'Correct private constructor exception');
+eval { $ctor->call('Class::Meta::Test', age => 44 ) };
+ok( $err = $@, 'Catch indirect constructor private exception');
+like( $err, qr/age is a private attribute of Class::Meta::Test/,
+ 'Correct indirect private constructor exception');
+
More information about the Pkg-perl-cvs-commits
mailing list