X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMoose.pm;h=8f6d75e1d98048f1f9528a0cf9fa0ff4ef456955;hb=3c2bc5e2dc448e36704a71f25d66503cef8831fb;hp=0d1068dc1e1b44d735a2348f416e086f7f96e8d2;hpb=4b598ea31ff4d1ec8f76f2f27cac8d56cbccc39f;p=gitmo%2FMoose.git diff --git a/lib/Moose.pm b/lib/Moose.pm index 0d1068d..8f6d75e 100644 --- a/lib/Moose.pm +++ b/lib/Moose.pm @@ -1,131 +1,246 @@ -use lib '/Users/stevan/Projects/CPAN/Class-MOP/Class-MOP/lib'; - package Moose; use strict; use warnings; -our $VERSION = '0.02'; +our $VERSION = '0.13'; use Scalar::Util 'blessed', 'reftype'; use Carp 'confess'; use Sub::Name 'subname'; +use B 'svref_2object'; -use UNIVERSAL::require; +use Sub::Exporter; use Class::MOP; use Moose::Meta::Class; +use Moose::Meta::TypeConstraint; +use Moose::Meta::TypeCoercion; use Moose::Meta::Attribute; +use Moose::Meta::Instance; use Moose::Object; -use Moose::Util::TypeConstraints ':no_export'; - -sub import { - shift; - my $pkg = caller(); - - # we should never export to main - return if $pkg eq 'main'; - - Moose::Util::TypeConstraints->import($pkg); - - # make a subtype for each Moose class - Moose::Util::TypeConstraints::subtype($pkg - => Moose::Util::TypeConstraints::as Object - => Moose::Util::TypeConstraints::where { $_->isa($pkg) } - ); - - my $meta; - if ($pkg->can('meta')) { - $meta = $pkg->meta(); - (blessed($meta) && $meta->isa('Class::MOP::Class')) - || confess "Whoops, not møøsey enough"; - } - else { - $meta = Moose::Meta::Class->initialize($pkg => ( - ':attribute_metaclass' => 'Moose::Meta::Attribute' - )); - $meta->add_method('meta' => sub { - # re-initialize so it inherits properly - Moose::Meta::Class->initialize($pkg => ( - ':attribute_metaclass' => 'Moose::Meta::Attribute' - )); - }) +use Moose::Util::TypeConstraints; + +{ + my $CALLER; + + sub _init_meta { + my $class = $CALLER; + + # make a subtype for each Moose class + subtype $class + => as 'Object' + => where { $_->isa($class) } + unless find_type_constraint($class); + + my $meta; + if ($class->can('meta')) { + # NOTE: + # this is the case where the metaclass pragma + # was used before the 'use Moose' statement to + # override a specific class + $meta = $class->meta(); + (blessed($meta) && $meta->isa('Moose::Meta::Class')) + || confess "You already have a &meta function, but it does not return a Moose::Meta::Class"; + } + else { + # NOTE: + # this is broken currently, we actually need + # to allow the possiblity of an inherited + # meta, which will not be visible until the + # user 'extends' first. This needs to have + # more intelligence to it + $meta = Moose::Meta::Class->initialize($class); + $meta->add_method('meta' => sub { + # re-initialize so it inherits properly + Moose::Meta::Class->initialize(blessed($_[0]) || $_[0]); + }) + } + + # make sure they inherit from Moose::Object + $meta->superclasses('Moose::Object') + unless $meta->superclasses(); + } + + my %exports = ( + extends => sub { + my $class = $CALLER; + return subname 'Moose::extends' => sub (@) { + confess "Must derive at least one class" unless @_; + _load_all_classes(@_); + # this checks the metaclass to make sure + # it is correct, sometimes it can get out + # of sync when the classes are being built + my $meta = $class->meta->_fix_metaclass_incompatability(@_); + $meta->superclasses(@_); + }; + }, + with => sub { + my $class = $CALLER; + return subname 'Moose::with' => sub (@) { + my (@roles) = @_; + confess "Must specify at least one role" unless @roles; + _load_all_classes(@roles); + $class->meta->_apply_all_roles(@roles); + }; + }, + has => sub { + my $class = $CALLER; + return subname 'Moose::has' => sub ($;%) { + my ($name, %options) = @_; + $class->meta->_process_attribute($name, %options); + }; + }, + before => sub { + my $class = $CALLER; + return subname 'Moose::before' => sub (@&) { + my $code = pop @_; + my $meta = $class->meta; + $meta->add_before_method_modifier($_, $code) for @_; + }; + }, + after => sub { + my $class = $CALLER; + return subname 'Moose::after' => sub (@&) { + my $code = pop @_; + my $meta = $class->meta; + $meta->add_after_method_modifier($_, $code) for @_; + }; + }, + around => sub { + my $class = $CALLER; + return subname 'Moose::around' => sub (@&) { + my $code = pop @_; + my $meta = $class->meta; + $meta->add_around_method_modifier($_, $code) for @_; + }; + }, + super => sub { + return subname 'Moose::super' => sub {}; + }, + override => sub { + my $class = $CALLER; + return subname 'Moose::override' => sub ($&) { + my ($name, $method) = @_; + $class->meta->add_override_method_modifier($name => $method); + }; + }, + inner => sub { + return subname 'Moose::inner' => sub {}; + }, + augment => sub { + my $class = $CALLER; + return subname 'Moose::augment' => sub (@&) { + my ($name, $method) = @_; + $class->meta->add_augment_method_modifier($name => $method); + }; + }, + + # NOTE: + # this is experimental for now ... + self => sub { + return subname 'Moose::self' => sub {}; + }, + method => sub { + my $class = $CALLER; + return subname 'Moose::method' => sub { + my ($name, $method) = @_; + $class->meta->add_method($name, sub { + my $self = shift; + no strict 'refs'; + no warnings 'redefine'; + local *{$class->meta->name . '::self'} = sub { $self }; + $method->(@_); + }); + }; + }, + + confess => sub { + return \&Carp::confess; + }, + blessed => sub { + return \&Scalar::Util::blessed; + }, + ); + + my $exporter = Sub::Exporter::build_exporter({ + exports => \%exports, + groups => { + default => [':all'] + } + }); + + sub import { + $CALLER = caller(); + + strict->import; + warnings->import; + + # we should never export to main + return if $CALLER eq 'main'; + + _init_meta(); + + goto $exporter; + } + + sub unimport { + no strict 'refs'; + my $class = caller(); + # loop through the exports ... + foreach my $name (keys %exports) { + next if $name =~ /inner|super|self/; + + # if we find one ... + if (defined &{$class . '::' . $name}) { + my $keyword = \&{$class . '::' . $name}; + + # make sure it is from Moose + my $pkg_name = eval { svref_2object($keyword)->GV->STASH->NAME }; + next if $@; + next if $pkg_name ne 'Moose'; + + # and if it is from Moose then undef the slot + delete ${$class . '::'}{$name}; + } + } + } +} + +## Utility functions + +sub _load_all_classes { + foreach my $super (@_) { + # see if this is already + # loaded in the symbol table + next if _is_class_already_loaded($super); + # otherwise require it ... + # NOTE: + # just in case the class we are + # loading has a locally defined + # &require, we make sure that we + # use the on in UNIVERSAL + my $file = $class . '.pm'; + $file =~ s{::}{/}g; + eval { CORE::require($file) }; + confess( + "Could not load module '$super' because : $@" + ) if $@; + } +} + +sub _is_class_already_loaded { + my $name = shift; + no strict 'refs'; + return 1 if defined ${"${name}::VERSION"} || defined @{"${name}::ISA"}; + foreach (keys %{"${name}::"}) { + next if substr($_, -2, 2) eq '::'; + return 1 if defined &{"${name}::$_"}; } - - # NOTE: - # &alias_method will install the method, but it - # will not name it with - - # handle superclasses - $meta->alias_method('extends' => subname 'Moose::extends' => sub { - $_->require for @_; - $meta->superclasses(@_) - }); - - # handle attributes - $meta->alias_method('has' => subname 'Moose::has' => sub { - my ($name, %options) = @_; - if (exists $options{is}) { - if ($options{is} eq 'ro') { - $options{reader} = $name; - } - elsif ($options{is} eq 'rw') { - $options{accessor} = $name; - } - } - if (exists $options{isa}) { - # allow for anon-subtypes here ... - if (reftype($options{isa}) && reftype($options{isa}) eq 'CODE') { - $options{type_constraint} = $options{isa}; - } - else { - # otherwise assume it is a constraint - my $constraint = Moose::Util::TypeConstraints::find_type_constraint($options{isa}); - # if the constraing it not found .... - unless (defined $constraint) { - # assume it is a foreign class, and make - # an anon constraint for it - $constraint = Moose::Util::TypeConstraints::subtype( - Object => Moose::Util::TypeConstraints::where { $_->isa($constraint) } - ); - } - $options{type_constraint} = $constraint; - } - } - if (exists $options{coerce} && $options{coerce} && $options{isa}) { - my $coercion = Moose::Util::TypeConstraints::find_type_coercion($options{isa}); - (defined $coercion) - || confess "Cannot find coercion for type " . $options{isa}; - $options{coerce} = $coercion; - } - $meta->add_attribute($name, %options) - }); - - # handle method modifers - $meta->alias_method('before' => subname 'Moose::before' => sub { - my $code = pop @_; - $meta->add_before_method_modifier($_, $code) for @_; - }); - $meta->alias_method('after' => subname 'Moose::after' => sub { - my $code = pop @_; - $meta->add_after_method_modifier($_, $code) for @_; - }); - $meta->alias_method('around' => subname 'Moose::around' => sub { - my $code = pop @_; - $meta->add_around_method_modifier($_, $code) for @_; - }); - - # make sure they inherit from Moose::Object - $meta->superclasses('Moose::Object') - unless $meta->superclasses(); - - # we recommend using these things - # so export them for them - $meta->alias_method('confess' => \&Carp::confess); - $meta->alias_method('blessed' => \&Scalar::Util::blessed); + return 0; } 1; @@ -136,15 +251,17 @@ __END__ =head1 NAME -Moose - Moose, it's the new Camel +Moose - A complete modern object system for Perl 5 =head1 SYNOPSIS package Point; + use strict; + use warnings; use Moose; - has 'x' => (isa => 'Int', is => 'rw'); - has 'y' => (isa => 'Int', is => 'rw'); + has 'x' => (is => 'rw', isa => 'Int'); + has 'y' => (is => 'rw', isa => 'Int'); sub clear { my $self = shift; @@ -153,23 +270,32 @@ Moose - Moose, it's the new Camel } package Point3D; + use strict; + use warnings; use Moose; extends 'Point'; - has 'z' => (isa => 'Int'); + has 'z' => (is => 'rw', isa => 'Int'); after 'clear' => sub { my $self = shift; - $self->{z} = 0; + $self->z(0); }; =head1 CAVEAT -This is a B early release of this module, it still needs -some fine tuning and B more documentation. I am adopting -the I approach with this module, -so keep an eye on your favorite CPAN mirror! +Moose is a rapidly maturing module, and is already being used by +a number of people. It's test suite is growing larger by the day, +and the docs should soon follow. + +This said, Moose is not yet finished, and should still be considered +to be evolving. Much of the outer API is stable, but the internals +are still subject to change (although not without serious thought +given to it). + +For more details, please refer to the L section of +this document. =head1 DESCRIPTION @@ -178,7 +304,7 @@ Moose is an extension of the Perl 5 object system. =head2 Another object system!?!? Yes, I know there has been an explosion recently of new ways to -build object's in Perl 5, most of them based on inside-out objects, +build object's in Perl 5, most of them based on inside-out objects and other such things. Moose is different because it is not a new object system for Perl 5, but instead an extension of the existing object system. @@ -188,10 +314,213 @@ for Perl 5. This means that Moose not only makes building normal Perl 5 objects better, but it also provides the power of metaclass programming. +=head2 Can I use this in production? Or is this just an experiment? + +Moose is I on the prototypes and experiments I did for the Perl 6 +meta-model; however Moose is B an experiment/prototype, it is +for B. I will be deploying Moose into production environments later +this year, and I have every intentions of using it as my de facto class +builder from now on. + +=head2 Is Moose just Perl 6 in Perl 5? + +No. While Moose is very much inspired by Perl 6, it is not itself Perl 6. +Instead, it is an OO system for Perl 5. I built Moose because I was tired or +writing the same old boring Perl 5 OO code, and drooling over Perl 6 OO. So +instead of switching to Ruby, I wrote Moose :) + +=head1 BUILDING CLASSES WITH MOOSE + +Moose makes every attempt to provide as much convenience as possible during +class construction/definition, but still stay out of your way if you want it +to. Here are a few items to note when building classes with Moose. + +Unless specified with C, any class which uses Moose will +inherit from L. + +Moose will also manage all attributes (including inherited ones) that +are defined with C. And assuming that you call C, which is +inherited from L, then this includes properly initializing +all instance slots, setting defaults where appropriate, and performing any +type constraint checking or coercion. + +=head1 EXPORTED FUNCTIONS + +Moose will export a number of functions into the class's namespace which +can then be used to set up the class. These functions all work directly +on the current class. + +=over 4 + +=item B + +This is a method which provides access to the current class's metaclass. + +=item B + +This function will set the superclass(es) for the current class. + +This approach is recommended instead of C, because C +actually Ces onto the class's C<@ISA>, whereas C will +replace it. This is important to ensure that classes which do not have +superclasses still properly inherit from L. + +=item B + +This will apply a given set of C<@roles> to the local class. Role support +is currently under heavy development; see L for more details. + +=item B + +This will install an attribute of a given C<$name> into the current class. +The list of C<%options> are the same as those provided by +L, in addition to the list below which are provided +by Moose (L to be more specific): + +=over 4 + +=item I 'rw'|'ro'> + +The I option accepts either I (for read/write) or I (for read +only). These will create either a read/write accessor or a read-only +accessor respectively, using the same name as the C<$name> of the attribute. + +If you need more control over how your accessors are named, you can use the +I, I and I options inherited from L. + +=item I $type_name> + +The I option uses Moose's type constraint facilities to set up runtime +type checking for this attribute. Moose will perform the checks during class +construction, and within any accessors. The C<$type_name> argument must be a +string. The string can be either a class name or a type defined using +Moose's type definition features. + +=item I (1|0)> + +This will attempt to use coercion with the supplied type constraint to change +the value passed into any accessors or constructors. You B have supplied +a type constraint in order for this to work. See L +for an example usage. + +=item I $role_name> + +This will accept the name of a role which the value stored in this attribute +is expected to have consumed. + +=item I (1|0)> + +This marks the attribute as being required. This means a value must be supplied +during class construction, and the attribute can never be set to C with +an accessor. + +=item I (1|0)> + +This will tell the class to store the value of this attribute as a weakened +reference. If an attribute is a weakened reference, it B also be +coerced. + +=item I (1|0)> + +This will tell the class to not create this slot until absolutely necessary. +If an attribute is marked as lazy it B have a default supplied. + +=item I (1|0)> + +This tells the accessor whether to automatically dereference the value returned. +This is only legal if your C option is either an C or C. + +=item I $code> + +The trigger option is a CODE reference which will be called after the value of +the attribute is set. The CODE ref will be passed the instance itself, the +updated value and the attribute meta-object (this is for more advanced fiddling +and can typically be ignored in most cases). You B have a trigger on +a read-only attribute. + +=item I [ @handles ]> + +There is experimental support for attribute delegation using the C +option. More docs to come later. + +=back + +=item B sub { ... }> + +=item B sub { ... }> + +=item B sub { ... }> + +This three items are syntactic sugar for the before, after, and around method +modifier features that L provides. More information on these can +be found in the L documentation for now. + +=item B + +The keyword C is a no-op when called outside of an C method. In +the context of an C method, it will call the next most appropriate +superclass method with the same arguments as the original method. + +=item B + +An C method is a way of explicitly saying "I am overriding this +method from my superclass". You can call C within this method, and +it will work as expected. The same thing I be accomplished with a normal +method call and the C pseudo-package; it is really your choice. + +=item B + +The keyword C, much like C, is a no-op outside of the context of +an C method. You can think of C as being the inverse of +C; the details of how C and C work is best described in +the L. + +=item B + +An C method, is a way of explicitly saying "I am augmenting this +method from my superclass". Once again, the details of how C and +C work is best described in the L. + +=item B + +This is the C function, and exported here because I use it +all the time. This feature may change in the future, so you have been warned. + +=item B + +This is the C function, it is exported here because I +use it all the time. It is highly recommended that this is used instead of +C anywhere you need to test for an object's class name. + +=back + +=head1 UNEXPORTING FUNCTIONS + +=head2 B + +Moose offers a way of removing the keywords it exports though the C +method. You simply have to say C at the bottom of your code for this +to work. Here is an example: + + package Person; + use Moose; + + has 'first_name' => (is => 'rw', isa => 'Str'); + has 'last_name' => (is => 'rw', isa => 'Str'); + + sub full_name { + my $self = shift; + $self->first_name . ' ' . $self->last_name + } + + no Moose; # keywords are removed from the Person package + +=head1 MISC. + =head2 What does Moose stand for?? Moose doesn't stand for one thing in particular, however, if you -want, here are a few of my favorites, feel free to contribute +want, here are a few of my favorites; feel free to contribute more :) =over 4 @@ -204,38 +533,74 @@ more :) =item Most Other Object Systems Emasculate -=item My Overcraft Overfilled (with) Some Eels - =item Moose Often Ovulate Sorta Early -=item Many Overloaded Object Systems Exists - =item Moose Offers Often Super Extensions +=item Meta Object Orientation Syntax Extensions + +=back + +=head1 CAVEATS + +=over 4 + +=item * + +It should be noted that C and C C be used in the same +method. However, they can be combined together with the same class hierarchy; +see F for an example. + +The reason for this is that C is only valid within a method +with the C modifier, and C will never be valid within an +C method. In fact, C will skip over any C methods +when searching for its appropriate C. + +This might seem like a restriction, but I am of the opinion that keeping these +two features separate (but interoperable) actually makes them easy to use, since +their behavior is then easier to predict. Time will tell if I am right or not. + =back =head1 ACKNOWLEDGEMENTS =over 4 -=item I blame Sam Vilain for giving me my first hit of meta-model crack. +=item I blame Sam Vilain for introducing me to the insanity that is meta-models. -=item I blame Audrey Tang for encouraging that meta-crack habit in #perl6. +=item I blame Audrey Tang for then encouraging my meta-model habit in #perl6. -=item Without the love and encouragement of Yuval "nothingmuch" Kogman, -this module would not be possible (and it wouldn't have a name). +=item Without Yuval "nothingmuch" Kogman this module would not be possible, +and it certainly wouldn't have this name ;P =item The basis of the TypeContraints module was Rob Kinyon's idea originally, I just ran with it. +=item Thanks to mst & chansen and the whole #moose poose for all the +ideas/feature-requests/encouragement + +=item Thanks to David "Theory" Wheeler for meta-discussions and spelling fixes. + =back =head1 SEE ALSO =over 4 +=item L documentation + +=item The #moose channel on irc.perl.org + +=item The Moose mailing list - moose@perl.org + =item L +=item L + +This paper (suggested by lbr on #moose) was what lead to the implementation +of the C/C and C/C features. If you really +want to understand this feature, I suggest you read this. + =back =head1 BUGS @@ -248,6 +613,10 @@ to cpan-RT. Stevan Little Estevan@iinteractive.comE +Christian Hansen Echansen@cpan.orgE + +Yuval Kogman Enothingmuch@woobling.orgE + =head1 COPYRIGHT AND LICENSE Copyright 2006 by Infinity Interactive, Inc. @@ -257,4 +626,4 @@ L This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. -=cut \ No newline at end of file +=cut