X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMouse.pm;h=c6013e99933fe87b1312ad9164370b1b82091ec3;hb=c5cbafa4db9e41ee4f489943581b46915ecb7145;hp=1c06330de2525178b9a7e4c0609f9c13b9a3198d;hpb=c3398f5bd45f2851b7cd40ca9823bcf7d2378469;p=gitmo%2FMouse.git diff --git a/lib/Mouse.pm b/lib/Mouse.pm index 1c06330..c6013e9 100644 --- a/lib/Mouse.pm +++ b/lib/Mouse.pm @@ -3,22 +3,25 @@ package Mouse; use strict; use warnings; -our $VERSION = '0.01'; +our $VERSION = '0.05'; +use 5.006; use Sub::Exporter; use Carp 'confess'; use Scalar::Util 'blessed'; +use Class::Method::Modifiers (); -use Mouse::Attribute; -use Mouse::Class; +use Mouse::Meta::Attribute; +use Mouse::Meta::Class; use Mouse::Object; +use Mouse::TypeRegistry; do { my $CALLER; my %exports = ( meta => sub { - my $meta = Mouse::Class->initialize($CALLER); + my $meta = Mouse::Meta::Class->initialize($CALLER); return sub { $meta }; }, @@ -30,23 +33,57 @@ do { }, has => sub { + my $caller = $CALLER; + return sub { - my $package = caller; + my $meta = $caller->meta; + my $names = shift; $names = [$names] if !ref($names); for my $name (@$names) { - Mouse::Attribute->create($package, $name, @_); + if ($name =~ s/^\+//) { + Mouse::Meta::Attribute->clone_parent($meta, $name, @_); + } + else { + Mouse::Meta::Attribute->create($meta, $name, @_); + } } }; }, confess => sub { - return \&Carp::confess; + return \&confess; }, blessed => sub { - return \&Scalar::Util::blessed; + return \&blessed; + }, + + before => sub { + return \&Class::Method::Modifiers::before; + }, + + after => sub { + return \&Class::Method::Modifiers::after; + }, + + around => sub { + return \&Class::Method::Modifiers::around; + }, + + with => sub { + my $caller = $CALLER; + + return sub { + my $role = shift; + my $class = $caller->meta; + + confess "Mouse::Role only supports 'with' on individual roles at a time" if @_; + + Mouse::load_class($role); + $role->meta->apply($class); + }; }, ); @@ -61,8 +98,9 @@ do { strict->import; warnings->import; - no strict 'refs'; - @{ $CALLER . '::ISA' } = 'Mouse::Object'; + my $meta = Mouse::Meta::Class->initialize($CALLER); + $meta->superclasses('Mouse::Object') + unless $meta->superclasses; goto $exporter; } @@ -81,51 +119,140 @@ do { sub load_class { my $class = shift; + if (ref($class) || !defined($class) || !length($class)) { + my $display = defined($class) ? $class : 'undef'; + confess "Invalid class name ($display)"; + } + + return 1 if is_class_loaded($class); + (my $file = "$class.pm") =~ s{::}{/}g; eval { CORE::require($file) }; - confess "Could not load class ($class) because : $@" - if $@ - && $@ !~ /^Can't locate .*? at /; + confess "Could not load class ($class) because : $@" if $@; return 1; } +sub is_class_loaded { + my $class = shift; + + return 0 if ref($class) || !defined($class) || !length($class); + + # walk the symbol table tree to avoid autovififying + # \*{${main::}{"Foo::"}} == \*main::Foo:: + + my $pack = \*::; + foreach my $part (split('::', $class)) { + return 0 unless exists ${$$pack}{"${part}::"}; + $pack = \*{${$$pack}{"${part}::"}}; + } + + # check for $VERSION or @ISA + return 1 if exists ${$$pack}{VERSION} + && defined *{${$$pack}{VERSION}}{SCALAR}; + return 1 if exists ${$$pack}{ISA} + && defined *{${$$pack}{ISA}}{ARRAY}; + + # check for any method + foreach ( keys %{$$pack} ) { + next if substr($_, -2, 2) eq '::'; + return 1 if defined *{${$$pack}{$_}}{CODE}; + } + + # fail + return 0; +} + 1; __END__ =head1 NAME -Mouse - miniature Moose near the speed of light - -=head1 VERSION - -Version 0.01 released ??? +Mouse - Moose minus the antlers =head1 SYNOPSIS package Point; + use Mouse; # automatically turns on strict and warnings + + has 'x' => (is => 'rw', isa => 'Int'); + has 'y' => (is => 'rw', isa => 'Int'); + + sub clear { + my $self = shift; + $self->x(0); + $self->y(0); + } + + package Point3D; use Mouse; - has x => ( - is => 'rw', - ); + extends 'Point'; - has y => ( - is => 'rw', - default => 0, - predicate => 'has_y', - clearer => 'clear_y', - ); + has 'z' => (is => 'rw', isa => 'Int'); + + after 'clear' => sub { + my $self = shift; + $self->z(0); + }; =head1 DESCRIPTION -Moose. +L is wonderful. + +Unfortunately, it's a little slow. Though significant progress has been made +over the years, the compile time penalty is a non-starter for some +applications. + +Mouse aims to alleviate this by providing a subset of Moose's +functionality, faster. In particular, L is missing only a few +expert-level features. + +=head2 MOOSE COMPAT + +Compatibility with Moose has been the utmost concern. Fewer than 1% of the +tests fail when run against Moose instead of Mouse. Mouse code coverage is also +over 99%. Even the error messages are taken from Moose. The Mouse code just +runs the test suite 3x-4x faster. + +The idea is that, if you need the extra power, you should be able to run +C on your codebase and have nothing break. To that end, +nothingmuch has written L (part of this distribution) which will act +as Mouse unless Moose is loaded, in which case it will act as Moose. + +Mouse also has the blessings of Moose's author, stevan. + +=head2 MISSING FEATURES -=head1 INTERFACE +=head3 Roles -=head2 meta -> Mouse::Class +Fixing this one slightly less soon. stevan has suggested an implementation +strategy. Mouse currently mostly ignores methods. + +=head3 Complex types + +User-defined type constraints and parameterized types may be implemented. Type +coercions probably not (patches welcome). + +=head3 Bootstrapped meta world + +Very handy for extensions to the MOP. Not pressing, but would be nice to have. + +=head3 Modification of attribute metaclass + +When you declare an attribute with L, you get the inlined accessors +installed immediately. Modifying the attribute metaclass, even if possible, +does nothing. + +=head3 Lots more.. + +MouseX? + +=head1 KEYWORDS + +=head2 meta -> Mouse::Meta::Class Returns this class' metaclass instance. @@ -133,10 +260,114 @@ Returns this class' metaclass instance. Sets this class' superclasses. +=head2 before (method|methods) => Code + +Installs a "before" method modifier. See L or +L. + +=head2 after (method|methods) => Code + +Installs an "after" method modifier. See L or +L. + +=head2 around (method|methods) => Code + +Installs an "around" method modifier. See L or +L. + =head2 has (name|names) => parameters Adds an attribute (or if passed an arrayref of names, multiple attributes) to -this class. +this class. Options: + +=over 4 + +=item is => ro|rw + +If specified, inlines a read-only/read-write accessor with the same name as +the attribute. + +=item isa => TypeConstraint + +Provides basic type checking in the constructor and accessor. Basic types such +as C, C, C are supported. Any unknown type is taken to +be a class check (e.g. isa => 'DateTime' would accept only L +objects). + +=item required => 0|1 + +Whether this attribute is required to have a value. If the attribute is lazy or +has a builder, then providing a value for the attribute in the constructor is +optional. + +=item init_arg => Str + +Allows you to use a different key name in the constructor. + +=item default => Value | CodeRef + +Sets the default value of the attribute. If the default is a coderef, it will +be invoked to get the default value. Due to quirks of Perl, any bare reference +is forbidden, you must wrap the reference in a coderef. Otherwise, all +instances will share the same reference. + +=item lazy => 0|1 + +If specified, the default is calculated on demand instead of in the +constructor. + +=item predicate => Str + +Lets you specify a method name for installing a predicate method, which checks +that the attribute has a value. It will not invoke a lazy default or builder +method. + +=item clearer => Str + +Lets you specify a method name for installing a clearer method, which clears +the attribute's value from the instance. On the next read, lazy or builder will +be invoked. + +=item handles => HashRef|ArrayRef + +Lets you specify methods to delegate to the attribute. ArrayRef forwards the +given method names to method calls on the attribute. HashRef maps local method +names to remote method names called on the attribute. Other forms of +L, such as regular expression and coderef, are not yet supported. + +=item weak_ref => 0|1 + +Lets you automatically weaken any reference stored in the attribute. + +=item trigger => CodeRef | HashRef + +Triggers are like method modifiers for setting attribute values. You can have +a "before" and an "after" trigger, each of which receive as arguments the instance, the new value, and the attribute metaclass. Historically, triggers have +only been "after" modifiers, so if you use a coderef for the C option, +it will maintain that compatibility. Like method modifiers, you can't really +affect the act of setting the attribute value, and the return values of the +modifiers are ignored. + +There's also an "around" trigger which you can use to change the value that +is being set on the attribute, or even prevent the attribute from being +updated. The around trigger receives as arguments a code reference to invoke +to set the attribute's value (which expects as arguments the instance and +the new value), the instance, the new value, and the attribute metaclass. + +=item builder => Str + +Defines a method name to be called to provide the default value of the +attribute. C<< builder => 'build_foo' >> is mostly equivalent to +C<< default => sub { $_[0]->build_foo } >>. + +=item auto_deref => 0|1 + +Allows you to automatically dereference ArrayRef and HashRef attributes in list +context. In scalar context, the reference is returned (NOT the list length or +bucket status). You must specify an appropriate type constraint to use +auto_deref. + +=back =head2 confess error -> BOOM @@ -150,26 +381,34 @@ L for your convenience. =head2 import -Importing Mouse will set your class' superclass list to L. +Importing Mouse will default your class' superclass list to L. You may use L to replace the superclass list. =head2 unimport -Please unimport Mouse so that if someone calls one of the keywords (such as -L) it will break loudly instead breaking subtly. +Please unimport Mouse (C) so that if someone calls one of the +keywords (such as L) it will break loudly instead breaking subtly. =head1 FUNCTIONS =head2 load_class Class::Name -This will load a given Class::Name> (or die if it's not loadable). +This will load a given C (or die if it's not loadable). This function can be used in place of tricks like C or using C. +=head2 is_class_loaded Class::Name -> Bool + +Returns whether this class is actually loaded or not. It uses a heuristic which +involves checking for the existence of C<$VERSION>, C<@ISA>, and any +locally-defined method. + =head1 AUTHOR Shawn M Moore, C<< >> +with plenty of code borrowed from L and L + =head1 BUGS No known bugs.