Class-Meta-0.66000755000767000024 011774573652 12774 5ustar00davidstaff000000000000Class-Meta-0.66/Build.PL000444000767000024 143211774573652 14425 0ustar00davidstaff000000000000use Module::Build; my $build = Module::Build->new( module_name => 'Class::Meta', license => 'perl', create_makefile_pl => 'traditional', configure_requires => { 'Module::Build' => '0.2701' }, recommends => { 'Test::Pod' => '1.41' }, build_requires => { 'Test::More' => '0.17', 'Module::Build' => '0.2701', }, requires => { 'Data::Types' => '0.05', 'Class::ISA' => '0.31', }, meta_merge => { resources => { homepage => 'http://search.cpan.org/dist/Class-Meta/', bugtracker => 'http://github.com/theory/class-meta/issues/', repository => 'http://github.com/theory/class-meta/', } }, ); $build->create_build_script; Class-Meta-0.66/Changes000444000767000024 4253311774573652 14453 0ustar00davidstaff000000000000Revision history for Perl extension Class::Meta. 0.66 2012-07-03T13:46:47Z - Fixed broken rt.cpan.org email address. - Added missing call to `build()` in the synopsis. Thanks to Laurnet Dami for the report (RT #72058). - Fixed a couple of typos in the Pod, with thanks to Gregor Herrmann and the Debian project (RT #78163). 0.65 2011-06-21T18:33:57 - Require Test::Pod 1.41 to run the Pod tests. - Removed redundant bug reporting email address from the documentation. - Fixed tests failures on Windows (hopefully). Thanks to Eric Brine for the suggested fix. 0.64 2011-06-20T00:30:45 - Moved repostitory to [GitHub](https://github.com/theory/class-meta/). - Switched to a "traditional" `Makefile.PL`. 0.63 2009-04-06T18:37:03 - Fixed POD formatting typo in Class::Meta::Type with thanks to Gregor Herrmann (RT #36143). 0.62 2008-05-22T03:08:06 - Fixed a warning from Perl 5.11 (I think). - Removed the spelling test from the distribution, since it can fail on systems without a spell program or using a different locale. Reported by Andreas Koenig. 0.61 2008-05-15T03:15:03 - Fixed test failures on Perl 5.6. Reported by Slaven Rezic and many others via cpan-testers. 0.60 2008-05-13T03:42:13 - Required constraints are now enforced by the constructor, as well as the individual attributes themselves. Frankly, it was a bug that this isn't the way it worked before, although at the time I thought it was a feature. This is a backwards compatibility change, but see the next point. Reported by Jon Swartz. - Added support for an optional subroutine reference to be passed as the final argument to constructors created by Class::Meta. The object being constructed will be passed to the anonymous sub after all of the specified and default values have been set, but before required constraints are enforced. This allows developers to have a scope within which to work before required attributes throw an exception. Yes, I did borrow this idea from Ruby. - Added a link to the Subversion repository. - Moved the "Justification" section of the documentation nearer to the bottom. Suggested by Jon Swartz. - The "view" parameter (PUBLIC, PRIVATE, PROTECTED, TRUSTED) is now enforced for methods when the method body is passed via the "code" parameter. Reported by Jon Swartz. - Added the `trusted` method to Class::Meta::Class. - You can now use strings to specify constant values when declaring class attributes, methods, etc. The strings correspond to their equivalent constant names, such as "PUBLIC", "PRIVATE", "GET", "SET", "OBJECT", "CLASS", and so on. The corresponding constant value will, however, be stored in the resulting Class::Meta object. - A more useful exception is now thrown when an attribute is added with a missing or unknown type. - Added the `default_type` parameter to `new()`, and the corresponding attribute to Class::Meta::Class. This value will be used for the data type of attributes created without a data type. Borrowed from Class::Meta::Express. - Many of the parameters to `Class::Meta->new` are now passed on to suclasses if they are not explicitly specified by those subclasses. This makes it easier to get the same settings (e.g., for Class::Meta subclasses or for the default type) without typing the same things over and over in subclasses. - Added a spelling test. This has the benefit of reducing the number of annoying spelling errors in the documentation. 0.55 2008-05-05T18:02:27 - Added the "configure_requires", and "recommends" parameters to Build.PL. - Updated the copyright. 0.54 2006-11-13T17:05:05 - Documented the 'name' parameter to new(). - The 'name' attribute of classes now defaults to the key name with underscores replaced with spaces and each word capitalized by the ucfirst operator. So "foo" will become "Foo" and "contact_type" will become "Contact Type". - Added an example and brief discussion of Class::Meta::Express to the docs. Suggested by Jonathan Swartz. 0.53 2006-05-30T00:54:52 - Added 'code' parameter to "new_constructor()" to install a constructor written by the user. This essentially works just like the 'code' method parameter. - Fixed tests that fail with Data::Types 0.06 and later. - Added 'is' parameter to the attribute constructor as an alias for 'type'. If both 'type and 'is' are passed to the attribute constructor, 'is' will be used. - Added the boolean method is() to the attribute class to compare a type. - Documented the 'create' parameter to "new_constructor()". - Data types in defined in the Class::Meta::Types namespace are now automatically loaded if they are used in an attribute and not already loaded. 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. Class-Meta-0.66/Makefile.PL000444000767000024 72711774573652 15071 0ustar00davidstaff000000000000# Note: this file was auto-generated by Module::Build::Compat version 0.40 use ExtUtils::MakeMaker; WriteMakefile ( 'NAME' => 'Class::Meta', 'VERSION_FROM' => 'lib/Class/Meta.pm', 'PREREQ_PM' => { 'Class::ISA' => '0.31', 'Data::Types' => '0.05', 'Module::Build' => '0.2701', 'Test::More' => '0.17' }, 'INSTALLDIRS' => 'site', 'EXE_FILES' => [], 'PL_FILES' => {} ) ; Class-Meta-0.66/MANIFEST000444000767000024 156411774573652 14270 0ustar00davidstaff000000000000Build.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.json META.yml README.md 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 Class-Meta-0.66/META.json000444000767000024 563311774573652 14561 0ustar00davidstaff000000000000{ "abstract" : "Class automation, introspection, and data validation", "author" : [ "David E. Wheeler " ], "dynamic_config" : 1, "generated_by" : "Module::Build version 0.4, CPAN::Meta::Converter version 2.120630", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Class-Meta", "prereqs" : { "build" : { "requires" : { "Module::Build" : "0.2701", "Test::More" : "0.17" } }, "configure" : { "requires" : { "Module::Build" : "0.2701" } }, "runtime" : { "recommends" : { "Test::Pod" : "1.41" }, "requires" : { "Class::ISA" : "0.31", "Data::Types" : "0.05" } } }, "provides" : { "Class::Meta" : { "file" : "lib/Class/Meta.pm", "version" : "0.66" }, "Class::Meta::AccessorBuilder" : { "file" : "lib/Class/Meta/AccessorBuilder.pm", "version" : "0.66" }, "Class::Meta::AccessorBuilder::Affordance" : { "file" : "lib/Class/Meta/AccessorBuilder/Affordance.pm", "version" : "0.66" }, "Class::Meta::AccessorBuilder::SemiAffordance" : { "file" : "lib/Class/Meta/AccessorBuilder/SemiAffordance.pm", "version" : "0.66" }, "Class::Meta::Attribute" : { "file" : "lib/Class/Meta/Attribute.pm", "version" : "0.66" }, "Class::Meta::Class" : { "file" : "lib/Class/Meta/Class.pm", "version" : "0.66" }, "Class::Meta::Constructor" : { "file" : "lib/Class/Meta/Constructor.pm", "version" : "0.66" }, "Class::Meta::Method" : { "file" : "lib/Class/Meta/Method.pm", "version" : "0.66" }, "Class::Meta::Type" : { "file" : "lib/Class/Meta/Type.pm", "version" : "0.66" }, "Class::Meta::Types::Boolean" : { "file" : "lib/Class/Meta/Types/Boolean.pm", "version" : "0.66" }, "Class::Meta::Types::Numeric" : { "file" : "lib/Class/Meta/Types/Numeric.pm", "version" : "0.66" }, "Class::Meta::Types::Perl" : { "file" : "lib/Class/Meta/Types/Perl.pm", "version" : "0.66" }, "Class::Meta::Types::String" : { "file" : "lib/Class/Meta/Types/String.pm", "version" : "0.66" } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "http://github.com/theory/class-meta/issues/" }, "homepage" : "http://search.cpan.org/dist/Class-Meta/", "license" : [ "http://dev.perl.org/licenses/" ], "repository" : { "url" : "http://github.com/theory/class-meta/" } }, "version" : "0.66" } Class-Meta-0.66/META.yml000444000767000024 356211774573652 14410 0ustar00davidstaff000000000000--- abstract: 'Class automation, introspection, and data validation' author: - 'David E. Wheeler ' build_requires: Module::Build: 0.2701 Test::More: 0.17 configure_requires: Module::Build: 0.2701 dynamic_config: 1 generated_by: 'Module::Build version 0.4, CPAN::Meta::Converter version 2.120630' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: Class-Meta provides: Class::Meta: file: lib/Class/Meta.pm version: 0.66 Class::Meta::AccessorBuilder: file: lib/Class/Meta/AccessorBuilder.pm version: 0.66 Class::Meta::AccessorBuilder::Affordance: file: lib/Class/Meta/AccessorBuilder/Affordance.pm version: 0.66 Class::Meta::AccessorBuilder::SemiAffordance: file: lib/Class/Meta/AccessorBuilder/SemiAffordance.pm version: 0.66 Class::Meta::Attribute: file: lib/Class/Meta/Attribute.pm version: 0.66 Class::Meta::Class: file: lib/Class/Meta/Class.pm version: 0.66 Class::Meta::Constructor: file: lib/Class/Meta/Constructor.pm version: 0.66 Class::Meta::Method: file: lib/Class/Meta/Method.pm version: 0.66 Class::Meta::Type: file: lib/Class/Meta/Type.pm version: 0.66 Class::Meta::Types::Boolean: file: lib/Class/Meta/Types/Boolean.pm version: 0.66 Class::Meta::Types::Numeric: file: lib/Class/Meta/Types/Numeric.pm version: 0.66 Class::Meta::Types::Perl: file: lib/Class/Meta/Types/Perl.pm version: 0.66 Class::Meta::Types::String: file: lib/Class/Meta/Types/String.pm version: 0.66 recommends: Test::Pod: 1.41 requires: Class::ISA: 0.31 Data::Types: 0.05 resources: bugtracker: http://github.com/theory/class-meta/issues/ homepage: http://search.cpan.org/dist/Class-Meta/ license: http://dev.perl.org/licenses/ repository: http://github.com/theory/class-meta/ version: 0.66 Class-Meta-0.66/README.md000444000767000024 417111774573652 14413 0ustar00davidstaff000000000000Class/Meta version 0.66 ======================= 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-2011, David E. Wheeler. Some Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Class-Meta-0.66/lib000755000767000024 011774573652 13542 5ustar00davidstaff000000000000Class-Meta-0.66/lib/Class000755000767000024 011774573652 14607 5ustar00davidstaff000000000000Class-Meta-0.66/lib/Class/Meta.pm000444000767000024 12242411774573652 16235 0ustar00davidstaff000000000000package Class::Meta; =head1 NAME Class::Meta - Class automation, introspection, and data validation =head1 SYNOPSIS Generate a class: package MyApp::Thingy; use strict; use Class::Meta; BEGIN { # Create a Class::Meta object for this class. my $cm = Class::Meta->new( key => 'thingy', default_type => 'string', ); # Add a constructor. $cm->add_constructor( name => 'new', create => 1, ); # Add a couple of attributes with generated methods. $cm->add_attribute( name => 'uuid', authz => 'READ', required => 1, default => sub { Data::UUID->new->create_str }, ); $cm->add_attribute( name => 'name', is => 'string', default => undef, ); $cm->add_attribute( name => 'age', is => 'integer', default => undef, ); # Add a custom method. $cm->add_method( name => 'chk_pass', view => 'PUBLIC', code => sub { ... }, ); $cm->build; } sub chck_pass { ... } Or use Class::Meta::Express for a more pleasant declarative syntax (highly recommended!): package MyApp::Thingy; use strict; use Class::Meta::Express; class { meta thingy => ( default_type => 'string' ); ctor 'new'; has uuid => ( authz => 'READ', required => 1, deafault => sub { Data::UUID->new->create_str }, ); has name => ( required => 1 ); has age => ( is => 'integer' ); method chk_pass => sub { ... } }; Now isn't that nicer? Then use the class: use MyApp::Thingy; my $thingy = MyApp::Thingy->new( id => 19 ); 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 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. First of all, you really want to be using L to declare your Class::Meta classes. It provides a much more pleasant class declaration experience than Class::Meta itself does. But since its functions support many of the same arguments as the declaration methods described here, it's worth it to skim the notes here, as well. Or if you're just a masochist and want to use the Class::Meta interface itself, well, read on! I recommend that you create your Class::Meta classes in a C block. Although this is not strictly necessary, it helps 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 block, as it won't be needed beyond that. All Class::Meta classes have a C 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 parameter to the C method tells Class::Meta to create the constructor named "C". =item * Then we call C 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 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 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 constructor and a C accessor for the "tail" attribute. And finally, Class::Meta will install another method, C. 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. Any of these will automatically be loaded by Class::Meta if it is used to create an attribute. They can also be loaded simply by Cing the appropriate module. The modules are: =over 4 =item L 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 =over 4 =item string Attributes of this type must contain a string value. Essentially, this means anything other than a reference. =back =item L =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 These data types are validated by the functions provided by L. =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 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 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 Describes the class. Each Class::Meta-generated class has a single constructor object that can be retrieved by calling a class' C 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 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 itself. =back =head3 L 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 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 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 attribute is passed to new, then this error handler will be associated with the new class. The default default error handler uses C 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 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 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 will remove all L objects from memory. Called with an argument, C 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. Many of the supported parameters values will default to values specified for the most immediate Class::Meta-built parent class, if any. The supported parameters are: =over 4 =item package The package that defines the class. Defaults to the package of the code that calls C. =item key A key name that uniquely identifies a class within an application. Defaults to the value of the C parameter if not specified. =item name The human name to use for the class. Defaults to the value of C with underscores replaced with spaces and each word capitalized by the C operator. So "foo" will become "Foo" and "contact_type" will become "Contact Type". =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 default_type A data type to use for attributes added to the class with no explicit data type. See L for some possible values for this parameter. Inheritable from parent class. =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. Inheritable from parent 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. Inheritable from parent class. =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. Inheritable from parent class. =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. Inheritable from parent class. =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 >>. Inheritable from parent class. =back =cut ############################################################################## # Dependencies # ############################################################################## use 5.006001; use strict; use Class::ISA (); ############################################################################## # 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; # Parameters passed on to subclasses. use constant INHERITABLE => qw( class_class error_handler attribute_class method_class constructor_class default_type ); ############################################################################## # 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.66'; ############################################################################## # Private Package Globals ############################################################################## CLASS: { 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}; # Find any parent C::M class. for my $super ( Class::ISA::super_path( $p{package} ) ) { next unless $super->can('my_class'); # Copy attributes. my $parent = $super->my_class; for my $param (INHERITABLE) { $p{$param} = $parent->{$param} unless exists $p{$param}; } last; } # 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. $classes{$p{package}}->_inherit( \%classes, 'attr'); # Return! return bless { package => $p{package} } => ref $pkg || $pkg; } ############################################################################## # add_constructor() =head3 add_constructor $cm->add_constructor( name => 'construct', 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 "_". Required. =item create When true, Class::Meta::Constructor will automatically create and install a constructor named for the C parameter. Defaults to true unless C is passed. In general you won't need to specify this parameter unless you've written your own constructor in the package, in which case you'll want to specify C<< create => 0 >>. =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 code You can implicitly define the constructor in your class by passing a code reference via the C parameter. Once C is called, L will install the constructor into the package for which the Class::Meta object was defined, and with the name specified via the C parameter. Note that if the constructor view is PRIVATE or PROTECTED, the constructor will be wrapped in extra code to constrain the view. 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 parameter to C. =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. You can also use strings aliases to the above constants, although the constant values will actually be stored in the L object, rather than the string. The supported strings are "PUBLIC", "PRIVATE", "TRUSTED", and "PROTECTED". =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 attribute on the class being defined. =back If Class::Meta creates the constructor, it will be a simple parameter-list constructor, wherein attribute values can be passed as a list of attribute-name/value pairs, e.g.: my $thingy = MyApp::Thingy->new( name => 'Larry', age => 32, ); Required attributes must have a value passed to the constructor, with one exception: You can pass an optional subroutine reference as the last argument to the constructor. After all parameter values and default values have been set on the object, but before any exceptions are thrown for undefined required attributes, the constructor will execute this subroutine reference, passing in the object being constructed as the sole argument. So, for example, if C is required but, for some reason, could not be set before constructing the object, you could set it like so: my $thingy = MyApp::Thingy->new( age => 32, sub { my $thingy = shift; # age and attributes with default values are already set. my $name = calculate_name( $thingy ); $thingy->name($name); }, ); This allows developers to have a scope-limited context in which to work before required constraints are enforced. =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 name The name of the attribute. The name must consist of only alphanumeric characters or "_". Required. =item type =item is The data type of the attribute. See L for some possible values for this parameter. If the type name corresponds to a data type in a package in the Class::Meta::Types name space, that package will automatically be loaded and configured with Perl-style accessors, so that the data type can simply be used. If both C and C are passed, C will be used. Required unless the class was declared with a C. =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 parameter to C 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. You can also use strings aliases to the above constants, although the constant values will actually be stored in the L object, rather than the string. The supported strings are "READ", "WRITE", "RDWR", and "NONE". =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 You can also use strings aliases to the above constants, although the constant values will actually be stored in the L object, rather than the string. The supported strings are "GET", "SET", "GETSET", and "NONE". If not unspecified, the value of the C parameter will correspond to the value of the C parameter like so: authz create ------------------ READ => GET WRITE => SET RDWR => GETSET NONE => NONE The C parameter differs from the C 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 and/or C 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 You can also use strings aliases to the above constants, although the constant values will actually be stored in the L object, rather than the string. The supported strings are "CLASS", and "OBJECT". =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 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 parameter to C for a description of its value. Class::Meta only enforces the C if the C parameter is used to define the method body. Otherwise, it's up to the class implementation itself to do the job. =item code You can implicitly define the method in your class by passing a code reference via the C parameter. Once C is called, L will install the method into the package for which the Class::Meta object was defined, and with the name specified via the C parameter. If the C is anything other than PUBLIC, it will be enforced. =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 parameter to C 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 method of L 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 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 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; } } # Trusted function to convert strings to their constant values. sub _str_to_const { my $val = shift; return $val if !$val || $val !~ /\w/; my $view = eval "Class::Meta::\U$val" or return $val; return $view; } 1; __END__ =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, to simple parameter validators, such as L, to more comprehensive systems, such as L and L. 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 "Gang of Four" 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 TO DO =over 4 =item * Add support for an C parameter to C that will be used for the accessor instead of generating one. =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 SUPPORT This module is stored in an open L. Feel free to fork and contribute! Please file bug reports via L or by sending mail to L. =head1 AUTHOR David E. Wheeler =head1 SEE ALSO First of all, use L instead of Class::Meta to declare your classes. I hope I've made that clear enough by now. Other classes of interest within the Class::Meta distribution include: =over 4 =item L =item L =item L =item L =item L =item L =item L =item L =item L =back For comparative purposes, you might also want to check out these fine modules: =over =item L Accessor and constructor automation. =item L Parameter validation. =item L Design by contract. =item L Accessor automation and data validation for Tangram applications. =item L An ambitious yet under-documented module that also manages accessor and constructor generation, data validation, and provides a reflection API. It also supports serialization. =item L Stevan Little's application of Perl 6 meta classes to Perl 5. =item L "It's the new camel." Another extension of the Perl 5 object system, built on Class::MOP. =back =head1 COPYRIGHT AND LICENSE Copyright (c) 2002-2011, David E. Wheeler. Some Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Class-Meta-0.66/lib/Class/Meta000755000767000024 011774573652 15475 5ustar00davidstaff000000000000Class-Meta-0.66/lib/Class/Meta/AccessorBuilder.pm000444000767000024 3355011774573652 21267 0ustar00davidstaff000000000000package Class::Meta::AccessorBuilder; =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. =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 attribute of the Class::Meta::Attribute for which the accessor is being created. For example, if the C 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 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 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 attribute of the attribute object for which accessors are to be built is C, 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 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 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 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 and returns a code reference that can be used by the C 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 and returns a code reference that can be used by the C 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 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 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 accessor (mutator) to validate new attribute values. =back =cut use strict; use Class::Meta; our $VERSION = '0.66'; 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; 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 SUPPORT This module is stored in an open L. Feel free to fork and contribute! Please file bug reports via L or by sending mail to L. =head1 AUTHOR David E. Wheeler =head1 SEE ALSO =over 4 =item L This class contains most of the documentation you need to get started with Class::Meta. =item L This module generates affordance style accessors (e.g., C and C. =item L This module generates semi-affordance style accessors (e.g., C and C. =item L This class manages the creation of data types. =item L This class manages Class::Meta class attributes, most of which will have generated accessors. =back =head1 COPYRIGHT AND LICENSE Copyright (c) 2002-2011, David E. Wheeler. Some Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Class-Meta-0.66/lib/Class/Meta/Attribute.pm000444000767000024 3475511774573652 20171 0ustar00davidstaff000000000000package Class::Meta::Attribute; =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 meta data 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 method to retrieve its Class::Meta::Class object, and then call the C method on the Class::Meta::Class object. =cut ############################################################################## # Dependencies # ############################################################################## use strict; ############################################################################## # Package Globals # ############################################################################## our $VERSION = '0.66'; ############################################################################## # Private Package Globals # ############################################################################## my %type_pkg_for = ( map( { $_ => 'Boolean' } qw(bool boolean) ), map( { $_ => 'Numeric' } qw(whole integer int decimal dec real float) ), map( { $_ => 'Perl' } qw(scalar scalarref array arrayref hash hashref code coderef closure) ), string => 'String', ); ############################################################################## # 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|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}) { $p{view} = Class::Meta::_str_to_const($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}) { $p{authz} = Class::Meta::_str_to_const($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}) { $p{create} = Class::Meta::_str_to_const($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}) { $p{context} = Class::Meta::_str_to_const($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 type. $p{type} = delete $p{is} if exists $p{is}; $p{type} ||= $class->default_type; $class->handle_error( "No type specified for the '$p{name}' attribute" ) unless $p{type}; unless ( eval { Class::Meta::Type->new($p{type}) } ) { my $pkg = $type_pkg_for{ $p{type} } or $class->handle_error( "Unknown type: '$p{type}'" ); eval "require Class::Meta::Types::$pkg"; $class->handle_error( "Unknown type: '$p{type}'" ) if $@; "Class::Meta::Types::$pkg"->import; } # 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 for a complete list. =head3 is if ($attr->is('string')) { # ... } A convenience method for C<< $attr->type eq $type >>. =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 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} } sub is { $_[0]->{type} eq $_[1] } ############################################################################## =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 may change on subsequent calls. It all depends on what was passed for the C parameter in the call to C 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 to execute the accessor, so the call to C itself will not appear in a call stack trace. =cut sub get { my $self = shift; my $code = $self->{_get} or $self->class->handle_error( q{Cannot get attribute '}, $self->name, q{'} ); 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 to execute the accessor, so the call to C itself will not appear in a call stack trace. =cut sub set { my $self = shift; my $code = $self->{_set} or $self->class->handle_error( q{Cannot set attribute '}, $self->name, q{'} ); 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 and C 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 and build any accessors. 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 SUPPORT This module is stored in an open L. Feel free to fork and contribute! Please file bug reports via L or by sending mail to L. =head1 AUTHOR David E. Wheeler =head1 SEE ALSO Other classes of interest within the Class::Meta distribution include: =over 4 =item L =item L =item L =item L =item L =back =head1 COPYRIGHT AND LICENSE Copyright (c) 2002-2011, David E. Wheeler. Some Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Class-Meta-0.66/lib/Class/Meta/Class.pm000444000767000024 3411411774573652 17260 0ustar00davidstaff000000000000package Class::Meta::Class; =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 meta data about the class itself, you can retrieve objects that describe the constructors, attributes, and methods of the class. See C 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 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.66'; 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|Class::Meta/new"> constructor on a Class::Meta object, instead. A Class::Meta::Class object will be constructed by default, and can always be retrieved via the C 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} ||= join ' ', map { ucfirst } split '_', $spec->{key}; # 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. =head3 default_type my $default_type = $class->default_type; The data type used for attributes of the class that were added with no explicit types. =head3 trusted my @trusted = $class->trusted; my $trusted = $class->trusted; In an array context, returns a list of class names that this class trusts. Returns the same list in an array reference in a scalar context. =cut sub package { $_[0]->{package} } sub key { $_[0]->{key} } sub name { $_[0]->{name} } sub desc { $_[0]->{desc} } sub abstract { $_[0]->{abstract} } sub default_type { $_[0]->{default_type} } sub trusted { wantarray ? @{ $_[0]->{trusted} } : [ @{ $_[0]->{trusted} } ] } ############################################################################## =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, C, and C 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 SUPPORT This module is stored in an open L. Feel free to fork and contribute! Please file bug reports via L or by sending mail to L. =head1 AUTHOR David E. Wheeler =head1 SEE ALSO Other classes of interest within the Class::Meta distribution include: =over 4 =item L =item L =item L =item L =back =head1 COPYRIGHT AND LICENSE Copyright (c) 2002-2011, David E. Wheeler. Some Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Class-Meta-0.66/lib/Class/Meta/Constructor.pm000444000767000024 3057711774573652 20551 0ustar00davidstaff000000000000package Class::Meta::Constructor; =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 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 method to retrieve its Class::Meta::Class object, and then call the C method on the Class::Meta::Class object. =cut ############################################################################## # Dependencies # ############################################################################## use strict; ############################################################################## # Package Globals # ############################################################################## our $VERSION = '0.66'; ############################################################################## # 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|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}) { $p{view} = Class::Meta::_str_to_const($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; } # Use passed code or create the constructor? if ($p{code}) { my $ref = ref $p{code}; $class->handle_error( 'Parameter code must be a code reference' ) unless $ref && $ref eq 'CODE'; $p{create} = 0; } else { $p{create} = 1 unless exists $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 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 to execute the constructor, so the call to C itself will not appear in a call stack trace. =cut sub call { my $self = shift; my $code = $self->{caller} or $self->class->handle_error( q{Cannot call constructor '}, $self->name, q{'} ); 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 method for the Class::Meta::Constructor, either by installing the code reference passed in the C parameter or by creating the constructor from scratch. 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 or installing the constructor. return $self unless delete $self->{create} || $self->{code}; # Build a construtor that takes a parameter list and assigns the # the values to the appropriate attributes. my $name = $self->name; my $sub = delete $self->{code} || 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; # Is there a sub passed as the last argument? my $sub = @_ % 2 && ref $_[-1] eq 'CODE' ? pop @_ : undef; # 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. my @req; 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}); } elsif (!exists $new->{$key}) { # Use the default value. $new->{$key} = $attr->default; push @req, $attr if $attr->required; } } } # 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 $" = q{', '}; $class->handle_error( "No such $c '@attributes' in $self->{package} objects" ); } # Run the block passed, if there is one. $sub->($new) if $sub; # Enforce required attributes. if (@req and my @miss = grep { !defined $new->{ $_->name } } @req ) { my $c = $#miss > 0 ? 'Attributes' : 'Attribute'; my $a = join q{', '}, map { $_->name } @miss; $class->handle_error( "$c '$a' must be defined 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 or report them via the CPAN Request Tracker at L. =head1 SUPPORT This module is stored in an open L. Feel free to fork and contribute! Please file bug reports via L or by sending mail to L. =head1 AUTHOR David E. Wheeler =head1 SEE ALSO Other classes of interest within the Class::Meta distribution include: =over 4 =item L =item L =item L =item L =back =head1 COPYRIGHT AND LICENSE Copyright (c) 2002-2011, David E. Wheeler. Some Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Class-Meta-0.66/lib/Class/Meta/Method.pm000444000767000024 2543111774573652 17435 0ustar00davidstaff000000000000package Class::Meta::Method; =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 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 method to retrieve its Class::Meta::Class object, and then call the C method on the Class::Meta::Class object. =cut ############################################################################## # Dependencies # ############################################################################## use strict; ############################################################################## # Package Globals # ############################################################################## our $VERSION = '0.66'; =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|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}) { $p{view} = Class::Meta::_str_to_const($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}) { $p{context} = Class::Meta::_str_to_const($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 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 to execute the method, so the call to C 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 installs the method if it was specified via the C parameter to C. 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}; if ($self->{view} < Class::Meta::PUBLIC ) { # Add a constraint to the code ref. my $real_meth = $code; if ($self->{view} == Class::Meta::PROTECTED) { $code = sub { $self->class->handle_error( "$name is a protected method of $pack" ) unless UNIVERSAL::isa(scalar caller, $pack); goto &$real_meth; }; } elsif ($self->{view} == Class::Meta::PRIVATE) { $code = sub { $self->class->handle_error( "$name is a private method of $pack" ) unless caller eq $pack; goto &$real_meth; }; } elsif ($self->{view} == Class::Meta::TRUSTED) { my $trusted = $self->class->trusted; $code = sub { my $caller = caller; goto &$real_meth if $caller eq $pack; for my $pkg ( @{ $trusted } ) { goto &$real_meth if UNIVERSAL::isa($caller, $pkg); } $self->class->handle_error( "$name is a trusted method of $pack" ); }; } } no strict 'refs'; *{"$pack\::$name"} = $code; } return $self; } 1; __END__ =head1 SUPPORT This module is stored in an open L. Feel free to fork and contribute! Please file bug reports via L or by sending mail to L. =head1 AUTHOR David E. Wheeler =head1 SEE ALSO Other classes of interest within the Class::Meta distribution include: =over 4 =item L =item L =item L =item L =back =head1 COPYRIGHT AND LICENSE Copyright (c) 2002-2011, David E. Wheeler. Some Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Class-Meta-0.66/lib/Class/Meta/Type.pm000444000767000024 6104211774573652 17134 0ustar00davidstaff000000000000package Class::Meta::Type; =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 us ed by C. 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 constructor. This is useful for creating custom types for your Class::Meta-built classes. BThis class manages the most advanced features of C. Before deciding to create your own accessor closures as described in L, you should have a thorough working knowledge of how Class::Meta works, and have studied the L method carefully. Simple data type definitions such as that shown in the L, on the other hand, are encouraged. =cut ############################################################################## # Dependencies # ############################################################################## use strict; ############################################################################## # Package Globals # ############################################################################## our $VERSION = '0.66'; ############################################################################## # 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 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 will implicitly call C 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 constructor, or by simply Cing one or more of the following modules: =over 4 =item L =over 4 =item scalar =item scalarref =item array =item hash =item code =back =item L =over 4 =item string =back =item L =over 4 =item boolean =back =item L =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; Class::Meta->handle_error('Type argument required') unless $_[0]; my $key = lc shift; 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. 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 to generate the validation checks. If you'd like to specify an alternative class validation code generator, pass one to the C 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 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 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 accessor and a C mutator. See L 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 to the accessor. So for an attribute "foo", the accessor would be named C and the mutator named C. See L for more information. =item A Package Name Pass in the name of a package that contains the functions C, C, and C. These functions will be used to create the necessary accessors for an attribute. See L 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 parameter to add(). The value set in this attribute will be used for the C 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 parameter to 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 parameter to C. 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 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, and usable as an indirect attribute accessor by the Class::Meta::Attribute C 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, and usable as an indirect attribute accessor by the Class::Meta::Attribute C 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 and passing in the name of a class for the C 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 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 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. 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 is called. Even better is to use L 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 line prevents the context from being thrown from within Class::Meta::Attribute, which is useful if you make use of that class' C 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 and L before taking on creating your own. Custom accessor building modules must have three functions. =head3 build The C 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 required constraints and accessibility (if the attribute is private, trusted, or protected). =item C<$create> The value of the C parameter 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 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 for example attribute creation functions. =head3 build_attr_get and build_attr_set The C and C 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 and C methods to get and set attribute values. Again, see L for examples before creating your own. =head1 SUPPORT This module is stored in an open L. Feel free to fork and contribute! Please file bug reports via L or by sending mail to L. =head1 AUTHOR David E. Wheeler =head1 SEE ALSO Other classes of interest within the Class::Meta distribution include: =over 4 =item L This class contains most of the documentation you need to get started with Class::Meta. =item L 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 =item L =item L =item L =back The modules that Class::Meta comes with for creating accessors are: =over 4 =item L Standard Perl-style accessors. =item L Affordance accessors--that is, explicit and independent get and set accessors. =item L Semi-affordance accessors--that is, independent get and set accessors with an explicit set accessor. =back =head1 COPYRIGHT AND LICENSE Copyright (c) 2002-2011, David E. Wheeler. Some Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Class-Meta-0.66/lib/Class/Meta/AccessorBuilder000755000767000024 011774573652 20546 5ustar00davidstaff000000000000Class-Meta-0.66/lib/Class/Meta/AccessorBuilder/Affordance.pm000444000767000024 3117611774573652 23321 0ustar00davidstaff000000000000package Class::Meta::AccessorBuilder::Affordance; =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 attribute of the Class::Meta::Attribute for which the accessor is being created. For example, if the C 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 is Class::Meta::READ, then only the get method will be created: my $value = $obj->io_socket; And finally, if the value of C 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 attribute of the attribute object for which accessors are to be built is C, 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 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 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 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 and returns a code reference that can be used by the C 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 and returns a code reference that can be used by the C 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 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 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 accessor (mutator) to validate new attribute values. =back =cut use strict; use Class::Meta; our $VERSION = '0.66'; 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) { 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 SUPPORT This module is stored in an open L. Feel free to fork and contribute! Please file bug reports via L or by sending mail to L. =head1 AUTHOR David E. Wheeler =head1 SEE ALSO =over 4 =item L This class contains most of the documentation you need to get started with Class::Meta. =item L This module generates Perl style accessors. =item L This class manages the creation of data types. =item L This class manages Class::Meta class attributes, most of which will have generated accessors. =back =head1 COPYRIGHT AND LICENSE Copyright (c) 2002-2011, David E. Wheeler. Some Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Class-Meta-0.66/lib/Class/Meta/AccessorBuilder/SemiAffordance.pm000444000767000024 2142011774573652 24126 0ustar00davidstaff000000000000package Class::Meta::AccessorBuilder::SemiAffordance; =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. This approach differs from that of affordance accessors, where the getter is prepended by C. The type of accessors created depends on the value of the C attribute of the Class::Meta::Attribute for which the accessor is being created. For example, if the C 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 is Class::Meta::READ, then only the get method will be created: my $value = $obj->io_socket; And finally, if the value of C 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 attribute of the attribute object for which accessors are to be built is C, 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 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 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 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 and returns a code reference that can be used by the C 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 and returns a code reference that can be used by the C 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 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 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 accessor (mutator) to validate new attribute values. =back =cut use strict; use Class::Meta; use base 'Class::Meta::AccessorBuilder::Affordance'; our $VERSION = '0.66'; 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 SUPPORT This module is stored in an open L. Feel free to fork and contribute! Please file bug reports via L or by sending mail to L. =head1 AUTHOR David E. Wheeler =head1 SEE ALSO =over 4 =item L This class contains most of the documentation you need to get started with Class::Meta. =item L This module generates Perl style accessors. =item L This class manages the creation of data types. =item L This class manages Class::Meta class attributes, most of which will have generated accessors. =back =head1 COPYRIGHT AND LICENSE Copyright (c) 2002-2011, David E. Wheeler. Some Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Class-Meta-0.66/lib/Class/Meta/Types000755000767000024 011774573652 16601 5ustar00davidstaff000000000000Class-Meta-0.66/lib/Class/Meta/Types/Boolean.pm000444000767000024 1235511774573652 20701 0ustar00davidstaff000000000000package Class::Meta::Types::Boolean; =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 method of a Class::Meta object to create an attribute of the boolean data type. See L 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 and C accessors common to other affordance-style accessors, it instead creates three: =over 4 =item C =item C =item C =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.66'; 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 SUPPORT This module is stored in an open L. Feel free to fork and contribute! Please file bug reports via L or by sending mail to L. =head1 AUTHOR David E. Wheeler =head1 SEE ALSO Other classes of interest within the Class::Meta distribution include: =over 4 =item L This class contains most of the documentation you need to get started with Class::Meta. =item L This class manages the creation of data types. =item L This class manages Class::Meta class attributes, all of which are based on data types. =back Other data type modules: =over 4 =item L =item L =item L =back =head1 COPYRIGHT AND LICENSE Copyright (c) 2002-2011, David E. Wheeler. Some Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Class-Meta-0.66/lib/Class/Meta/Types/Numeric.pm000444000767000024 1076311774573652 20725 0ustar00davidstaff000000000000package Class::Meta::Types::Numeric; =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 method of a Class::Meta object to create attributes of the numeric data type. See L 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.66'; # 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 SUPPORT This module is stored in an open L. Feel free to fork and contribute! Please file bug reports via L or by sending mail to L. =head1 AUTHOR David E. Wheeler =head1 SEE ALSO Other classes of interest within the Class::Meta distribution include: =over 4 =item L This class contains most of the documentation you need to get started with Class::Meta. =item L This class manages the creation of data types. =item L This class manages Class::Meta class attributes, all of which are based on data types. =back Other data type modules: =over 4 =item L =item L =item L =back =head1 COPYRIGHT AND LICENSE Copyright (c) 2002-2011, David E. Wheeler. Some Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Class-Meta-0.66/lib/Class/Meta/Types/Perl.pm000444000767000024 1007411774573652 20220 0ustar00davidstaff000000000000package Class::Meta::Types::Perl; =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 method of a Class::Meta object. See L 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. 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 must return 'SCALAR'. =item array =item arrayref A array reference. C must return 'ARRAY'. =item hash =item hashref A hash reference. C must return 'HASH'. =item code =item coderef =item closure A code reference. Also known as a closure. C must return 'CODE'. =back =cut use strict; use Class::Meta::Type; our $VERSION = '0.66'; 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 SUPPORT This module is stored in an open L. Feel free to fork and contribute! Please file bug reports via L or by sending mail to L. =head1 AUTHOR David E. Wheeler =head1 SEE ALSO Other classes of interest within the Class::Meta distribution include: =over 4 =item L This class contains most of the documentation you need to get started with Class::Meta. =item L This class manages the creation of data types. =item L This class manages Class::Meta class attributes, all of which are based on data types. =back Other data type modules: =over 4 =item L =item L =item L =back =head1 COPYRIGHT AND LICENSE Copyright (c) 2002-2011, David E. Wheeler. Some Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Class-Meta-0.66/lib/Class/Meta/Types/String.pm000444000767000024 526211774573652 20547 0ustar00davidstaff000000000000package Class::Meta::Types::String; =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 method of a Class::Meta object to create an attribute of the string data type. See L for more information on using and creating data types. =cut use strict; use Class::Meta::Type; our $VERSION = '0.66'; 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 SUPPORT This module is stored in an open L. Feel free to fork and contribute! Please file bug reports via L or by sending mail to L. =head1 AUTHOR David E. Wheeler =head1 SEE ALSO Other classes of interest within the Class::Meta distribution include: =over 4 =item L This class contains most of the documentation you need to get started with Class::Meta. =item L This class manages the creation of data types. =item L This class manages Class::Meta class attributes, all of which are based on data types. =back Other data type modules: =over 4 =item L =item L =item L =back =head1 COPYRIGHT AND LICENSE Copyright (c) 2002-2011, David E. Wheeler. Some Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Class-Meta-0.66/t000755000767000024 011774573652 13237 5ustar00davidstaff000000000000Class-Meta-0.66/t/attr.t000444000767000024 1643111774573652 14560 0ustar00davidstaff000000000000#!/usr/bin/perl -w ############################################################################## # Set up the tests. ############################################################################## use strict; use Test::More tests => 63; use Carp; ############################################################################## # Create a simple class. ############################################################################## package Class::Meta::TestPerson; use strict; use Test::More; # Make sure we can load Class::Meta. BEGIN { use_ok( 'Class::Meta' ); use_ok( 'Class::Meta::Types::String' ); } BEGIN { # 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', create => 'NONE', 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"); # Try a bogus type. eval { $c->add_attribute( name => 'bogus', type => 'bogus', ) }; ok( $err = $@, "Caught bogus type exception"); like( $err, qr/Unknown type: 'bogus'/, "Caught proper bogus type exception"); # Add an attribute with no type. eval { $c->add_attribute( name => 'no_type' ) }; ok( $err = $@, "Caught missing type exception"); like( $err, qr/No type specified for the 'no_type' attribute/, "Caught missing type exception"); # Now test all of the defaults. sub new_attr { 22 } ok( $attr = $c->add_attribute( name => 'new_attr', type => 'scalar', create => 'NONE', ), "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" ); ok $c->build, 'Build the class'; } # 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', type => 'scalar'), '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', type => 'scalar'), "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" ); ############################################################################## # Now create a class using strings instead of contants. STRINGS: { package My::Strings; use Test::More; ok my $cm = Class::Meta->new( key => 'strings' ), 'Create strings meta object'; ok $cm->add_attribute( name => 'foo', type => 'string', view => 'PUBLIC', authz => 'RDWR', create => 'GETSET', context => 'Object', ), 'Add an attribute using strings for constant values'; ok $cm->build, 'Build the class'; } ok my $class = My::Strings->my_class, 'Get the class object'; ok $attr = $class->attributes( 'foo' ), 'Get the "foo" attribute'; is $attr->view, Class::Meta::PUBLIC, 'The view should be PUBLIC'; is $attr->authz, Class::Meta::RDWR, 'The authz should be RDWR'; is $attr->context, Class::Meta::OBJECT, 'The context should be OBJECT'; ############################################################################## # Now create a class with a default type. STRINGS: { package My::DefType; use Test::More; ok my $cm = Class::Meta->new( key => 'def_type', default_type => 'integer', ), 'Create def_type meta object'; ok $cm->add_attribute( name => 'foo', ), 'Add an attribute with no type'; ok $cm->build, 'Build the class'; } ok $class = My::DefType->my_class, 'Get the class object'; ok $attr = $class->attributes( 'foo' ), 'Get the "foo" attribute'; is $attr->type, 'integer', 'Its type should be "integer"'; Class-Meta-0.66/t/base.t000444000767000024 3261411774573652 14521 0ustar00davidstaff000000000000#!perl -w ############################################################################## # Set up the tests. ############################################################################## use strict; use Test::More tests => 132; ############################################################################## # Create a simple class. ############################################################################## package Class::Meta::TestPerson; use strict; BEGIN { main::use_ok('Class::Meta'); } 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'); @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'); @keys = Class::Meta->keys; is_deeply(\@keys, ['person'], 'And it should delete a key if provided with one'); Class::Meta->clear('no_such_key'); @keys = Class::Meta->keys; is_deeply(\@keys, ['person'], 'But deleting a non-existent key should be a no-op'); Class::Meta->clear; @keys = Class::Meta->keys; is_deeply(\@keys, [], 'And calling it without arguments should remove all keys'); __END__ Class-Meta-0.66/t/chk_types.t000444000767000024 4270611774573652 15603 0ustar00davidstaff000000000000#!/usr/bin/perl -w ############################################################################## # 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" ); Class-Meta-0.66/t/chk_types_affordance.t000444000767000024 4520711774573652 17752 0ustar00davidstaff000000000000#!/usr/bin/perl -w ############################################################################## # 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" ); Class-Meta-0.66/t/chk_types_semi_affordance.t000444000767000024 4516311774573652 20770 0ustar00davidstaff000000000000#!/usr/bin/perl -w ############################################################################## # 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" ); Class-Meta-0.66/t/class.t000444000767000024 347211774573652 14674 0ustar00davidstaff000000000000#!/usr/bin/perl -w use strict; use Test::More tests => 16; 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', trust => 'Bar', default_type => 'string', }; # This should be okay. ok( $class = Class::Meta::Class->new($spec), 'Subclass can create class objects' ); # Test the simple accessors. is( $class->name, ucfirst $spec->{key}, 'name' ); is( $class->desc, $spec->{desc}, 'desc' ); is( $class->key, $spec->{key}, 'key' ); is_deeply( scalar $class->trusted, ['Bar'], 'trusted in scalar context' ); is_deeply( [ $class->trusted ], ['Bar'], 'trusted in list context' ); is( $class->default_type, 'string', 'default_type' ); # 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" ); Class-Meta-0.66/t/constraints.t000444000767000024 606711774573652 16141 0ustar00davidstaff000000000000#!perl -w ############################################################################## # 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" ); Class-Meta-0.66/t/constraints_affordance.t000444000767000024 576411774573652 20314 0ustar00davidstaff000000000000#!perl -w ############################################################################## # 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' ); Class-Meta-0.66/t/constraints_semi_affordance.t000444000767000024 574111774573652 21324 0ustar00davidstaff000000000000#!perl -w ############################################################################## # 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' ); Class-Meta-0.66/t/ctor.t000444000767000024 2133711774573652 14556 0ustar00davidstaff000000000000#!/usr/bin/perl ############################################################################## # Set up the tests. ############################################################################## use strict; use Test::More tests => 76; ############################################################################## # Create a simple class. ############################################################################## package Class::Meta::TestPerson; use strict; # Make sure we can load Class::Meta. BEGIN { main::use_ok( 'Class::Meta' ) } # Import the test functions. BEGIN { Test::More->import } BEGIN { # 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'; # Now write our own constructor. ok( $ctor = $cm->add_constructor( name => 'implicit', code => sub { ok 1, 'Implicit constructor called' }, ), 'Implicitly write 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"'; # Call implicit constructor and its test. Try::Mixed::Constructor->implicit; ############################################################################## # Now try passing a sub to the constructor. package Try::Passing::Sub; 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'; # Add some attributes. ok $cm->add_attribute( name => 'foo', type => 'scalar', required => 1, ), 'Add "foo" attribute'; ok $cm->add_attribute( name => 'bar', type => 'scalar', default => 1, ), 'Add "bar" attribute'; ok $cm->build, 'Build the new class'; ok $try = Try::Passing::Sub->new( foo => 'hey', sub { my $thing = shift; is $thing->foo, 'hey', 'Make sure "foo" was set'; is $thing->bar, 1, 'Make sure "bar" is set to its default'; ok $thing->bar(2), 'Set "bar" to a new value'; } ), 'Construct an instance of the new class'; is $try->foo, 'hey', '"foo" should be "hey"'; is $try->bar, 2, '"bar" should be 2'; # Now try passing no value for the required "foo" attribute. eval { Try::Passing::Sub->new }; ok my $err = $@, 'Caught an exception'; like $err, qr/Attribute 'foo' must be defined in Try::Passing::Sub objects/, 'Caught proper exception'; # Now still don't pass it, but set it in the sub. ok $try = Try::Passing::Sub->new( sub { shift->foo('howdy') } ), 'Set the required value in the passed sub'; is $try->foo, 'howdy', 'And that value should be properly set'; ############################################################################## # Now create a class using strings instead of contants. STRINGS: { package My::Strings; use Test::More; ok my $cm = Class::Meta->new( key => 'strings' ), 'Create strings meta object'; ok $cm->add_constructor( name => 'new', view => 'PUBLIC', ), 'Add a method using strings for constant values'; ok $cm->build, 'Build the class'; } ok my $class = My::Strings->my_class, 'Get the class object'; ok my $attr = $class->constructors( 'new' ), 'Get the "new" constructor'; is $attr->view, Class::Meta::PUBLIC, 'The view should be PUBLIC'; Class-Meta-0.66/t/custom_type_maker.t000444000767000024 2651711774573652 17346 0ustar00davidstaff000000000000#!/usr/bin/perl -w ############################################################################## # 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. Class-Meta-0.66/t/errors.t000444000767000024 2421711774573652 15123 0ustar00davidstaff000000000000#!perl -w ############################################################################## # Set up the tests. ############################################################################## use strict; use Test::More $] < 5.008 ? (skip_all => 'Older Carp lacks @CARP_NOT support') : (tests => 208); 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; @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$0\E|\Q$0\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') } Class-Meta-0.66/t/implicit_class_types.t000555000767000024 737311774573652 20021 0ustar00davidstaff000000000000#!/usr/bin/perl -w ############################################################################## # 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"; Class-Meta-0.66/t/inherit.t000444000767000024 3223311774573652 15246 0ustar00davidstaff000000000000#!perl -w ############################################################################## # Set up the tests. ############################################################################## use strict; use Test::More tests => 140; ############################################################################## # Create a simple class. ############################################################################## package My::Meta::Class; use base 'Class::Meta::Class'; package My::Meta::Method; use base 'Class::Meta::Method'; package My::Meta::Attribute; use base 'Class::Meta::Attribute'; package My::Meta::Constructor; use base 'Class::Meta::Constructor'; 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.', default_type => 'string', class_class => 'My::Meta::Class', method_class => 'My::Meta::Method', attribute_class => 'My::Meta::Attribute', constructor_class => 'My::Meta::Constructor', ), "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. ok( $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 attribute with same name using 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' ); isa_ok( $one_class, 'My::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" ); is $one_class->default_type, $one_class->default_type, 'Check that One inherits default_type'; # 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 One's class names. is( ref $one_attributes[0], 'My::Meta::Attribute', "Check for class class" ); is( ref $one_class->constructors('new'), 'My::Meta::Constructor'); is( ref $one_class->methods('foo'), 'My::Meta::Method'); # 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' ); isa_ok( $two_class, 'My::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->default_type, $one_class->default_type, 'Check that Two inherits default_type'; is( ($two_class->parents)[0], $one_class, "Check that Two has One for a parent" ); # Check Two's attribute objects. 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" ); # Check Two's class names. is( ref $two_attributes[0], 'My::Meta::Attribute', "Check for class class" ); is( ref $two_class->constructors('new'), 'My::Meta::Constructor'); is( ref $two_class->methods('foo'), 'My::Meta::Method'); # 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" ); Class-Meta-0.66/t/meth.t000444000767000024 2447311774573652 14550 0ustar00davidstaff000000000000#!/usr/bin/perl ############################################################################## # Set up the tests. ############################################################################## use strict; use Test::More tests => 109; use File::Spec; ############################################################################## # 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"); ############################################################################## # Now try enforcing method views. VIEW: { package My::View; use Test::More; BEGIN { ok my $cm = Class::Meta->new( key => 'view', package => __PACKAGE__, trust => 'My::Trust', ), 'Create CM object'; ok $cm->add_constructor( name => 'new' ), 'Add a constructor'; ok $cm->add_method( name => 'public', view => Class::Meta::PUBLIC, code => sub { }, ), 'Add a public method'; ok $cm->add_method( name => 'private', view => Class::Meta::PRIVATE, code => sub { }, ), 'Add a private method'; ok $cm->add_method( name => 'trusted', view => Class::Meta::TRUSTED, code => sub { }, ), 'Add a trusted method'; ok $cm->add_method( name => 'protected', view => Class::Meta::PROTECTED, code => sub { }, ), 'Add a protected method'; ok $cm->build, 'Build the class'; }; ok my $view = My::View->new, 'Create new private view object'; is undef, $view->public, 'Should be able to access public'; is undef, $view->private, 'Should be able to access private'; is undef, $view->trusted, 'Should be able to access trusted'; is undef, $view->protected, 'Should be able to access protected'; } # Make sure that visibility is enforced. ok my $view = My::View->new, 'Create new public view object'; is undef, $view->public, 'Should be able to access public'; eval { $view->private }; chk( 'private exception', qr/private is a private method of My::View/); eval { $view->trusted }; chk( 'trusted exception', qr/trusted is a trusted method of My::View/); eval { $view->protected }; chk( 'protected exception', qr/protected is a protected method of My::View/); # Check visibility in an inherited class. INHERIT: { package My::Viewer; use base 'My::View'; use Test::More; ok my $view = My::View->new, 'Create new inherited view object'; is undef, $view->public, 'Should be able to access public'; eval { $view->private }; main::chk( 'private exception', qr/private is a private method of My::View/); eval { $view->trusted }; main::chk( 'trusted exception', qr/trusted is a trusted method of My::View/); is undef, $view->protected, 'Should be able to access protected'; } # Check visibility in a trusted class. TRUST: { package My::Trust; use Test::More; ok my $view = My::View->new, 'Create new trusted view object'; is undef, $view->public, 'Should be able to access public'; eval { $view->private }; main::chk( 'private exception', qr/private is a private method of My::View/); is undef, $view->trusted, 'Should be able to access trusted'; eval { $view->protected }; main::chk( 'protected exception', qr/protected is a protected method of My::View/); } ############################################################################## # Now create a class using strings instead of contants. STRINGS: { package My::Strings; use Test::More; ok my $cm = Class::Meta->new( key => 'strings' ), 'Create strings meta object'; ok $cm->add_method( name => 'foo', view => 'PUBLIC', context => 'Object', ), 'Add a method using strings for constant values'; ok $cm->build, 'Build the class'; } ok my $class = My::Strings->my_class, 'Get the class object'; ok my $attr = $class->methods( 'foo' ), 'Get the "foo" method'; is $attr->view, Class::Meta::PUBLIC, 'The view should be PUBLIC'; is $attr->context, Class::Meta::OBJECT, 'The context should be OBJECT'; 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. SKIP: { skip 'Older Carp lacks @CARP_NOT support', 2 unless $] >= 5.008; like( $err, qr/(?:at\s+\Q$0\E|\Q$0\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') } } Class-Meta-0.66/t/pod-coverage.t000444000767000024 30411774573652 16111 0ustar00davidstaff000000000000#!perl -w 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(); Class-Meta-0.66/t/pod.t000444000767000024 24111774573652 14320 0ustar00davidstaff000000000000#!/usr/bin/perl -w use strict; use Test::More; eval "use Test::Pod 1.41"; plan skip_all => "Test::Pod 1.41 required for testing POD" if $@; all_pod_files_ok(); Class-Meta-0.66/t/types.t000444000767000024 2326211774573652 14752 0ustar00davidstaff000000000000#!/usr/bin/perl -w ############################################################################## # Set up the tests. ############################################################################## use strict; use Test::More tests => 60; ############################################################################## # 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, is => '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 => 'string', 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" ); ok( $alive->is('boolean'), "Check that is('boolean') returns true" ); ok( !$alive->is('string'), "Check that is('string') returns false" ); # Test whole number. SKIP: { skip 'Whole numbers can now be 0', 2 if Data::Types->VERSION > 0.05; 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 }.'); Class-Meta-0.66/t/types_affordance.t000444000767000024 2331011774573652 17114 0ustar00davidstaff000000000000#!/usr/bin/perl -w ############################################################################## # 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. SKIP: { skip 'Whole numbers can now be 0', 2 if Data::Types->VERSION > 0.05; 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 }.'); Class-Meta-0.66/t/types_semi_affordance.t000444000767000024 2331511774573652 20136 0ustar00davidstaff000000000000#!/usr/bin/perl -w ############################################################################## # 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. SKIP: { skip 'Whole numbers can now be 0', 2 if Data::Types->VERSION > 0.05; 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 }.'); Class-Meta-0.66/t/view.t000444000767000024 6532011774573652 14561 0ustar00davidstaff000000000000#!perl -w ############################################################################## # Set up the tests. ############################################################################## use strict; use Test::More $] < 5.008 ? (skip_all => 'Older Carp lacks @CARP_NOT support') : (tests => 394); use File::Spec; ############################################################################## # 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$0\E|\Q$0\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') } Class-Meta-0.66/t/view_affordance.t000444000767000024 5161711774573652 16735 0ustar00davidstaff000000000000#!perl -w ############################################################################## # 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'); Class-Meta-0.66/t/view_semi_affordance.t000444000767000024 5124411774573652 17746 0ustar00davidstaff000000000000#!perl -w ############################################################################## # 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');