lib/Moose.pm

   1
   2 package Moose;
   3
   4 use strict;
   5 use warnings;
   6
   7 our $VERSION = '0.06';
   8
   9 use Scalar::Util 'blessed', 'reftype';
  10 use Carp         'confess';
  11 use Sub::Name    'subname';
  12
  13 use UNIVERSAL::require;
  14 use Sub::Exporter;
  15
  16 use Class::MOP;
  17
  18 use Moose::Meta::Class;
  19 use Moose::Meta::TypeConstraint;
  20 use Moose::Meta::TypeCoercion;
  21 use Moose::Meta::Attribute;
  22 use Moose::Meta::Instance;
  23
  24 use Moose::Object;
  25 use Moose::Util::TypeConstraints;
  26
  27 {
  28     my $CALLER;
  29
  30     sub _init_meta {
  31         my $class = $CALLER;
  32
  33         # make a subtype for each Moose class
  34         subtype $class
  35             => as 'Object'
  36             => where { $_->isa($class) }
  37         unless find_type_constraint($class);
  38
  39         my $meta;
  40         if ($class->can('meta')) {
  41             # NOTE:
  42             # this is the case where the metaclass pragma
  43             # was used before the 'use Moose' statement to
  44             # override a specific class
  45             $meta = $class->meta();
  46             (blessed($meta) && $meta->isa('Moose::Meta::Class'))
  47                 || confess "Whoops, not møøsey enough";
  48         }
  49         else {
  50             # NOTE:
  51             # this is broken currently, we actually need
  52             # to allow the possiblity of an inherited
  53             # meta, which will not be visible until the
  54             # user 'extends' first. This needs to have
  55             # more intelligence to it
  56             $meta = Moose::Meta::Class->initialize($class);
  57             $meta->add_method('meta' => sub {
  58                 # re-initialize so it inherits properly
  59                 Moose::Meta::Class->initialize(blessed($_[0]) || $_[0]);
  60             })
  61         }
  62
  63         # make sure they inherit from Moose::Object
  64         $meta->superclasses('Moose::Object')
  65            unless $meta->superclasses();
  66     }
  67
  68     my %exports = (
  69         extends => sub {
  70             my $class = $CALLER;
  71             return subname 'Moose::extends' => sub {
  72                 _load_all_classes(@_);
  73                 my $meta = $class->meta;
  74                 foreach my $super (@_) {
  75                     # don't bother if it does not have a meta.
  76                     next unless $super->can('meta');
  77                     # if it's meta is a vanilla Moose,
  78                     # then we can safely ignore it.
  79                     next if blessed($super->meta) eq 'Moose::Meta::Class';
  80                     # but if we have anything else,
  81                     # we need to check it out ...
  82                     unless (# see if of our metaclass is incompatible
  83                             ($meta->isa(blessed($super->meta)) &&
  84                              # and see if our instance metaclass is incompatible
  85                              $meta->instance_metaclass->isa($super->meta->instance_metaclass)) &&
  86                             # ... and if we are just a vanilla Moose
  87                             $meta->isa('Moose::Meta::Class')) {
  88                         # re-initialize the meta ...
  89                         my $super_meta = $super->meta;
  90                         # NOTE:
  91                         # We might want to consider actually
  92                         # transfering any attributes from the
  93                         # original meta into this one, but in
  94                         # general you should not have any there
  95                         # at this point anyway, so it's very
  96                         # much an obscure edge case anyway
  97                         $meta = $super_meta->reinitialize($class => (
  98                             ':attribute_metaclass' => $super_meta->attribute_metaclass,
  99                             ':method_metaclass'    => $super_meta->method_metaclass,
 100                             ':instance_metaclass'  => $super_meta->instance_metaclass,
 101                         ));
 102                     }
 103                 }
 104                 $meta->superclasses(@_);
 105             };
 106         },
 107         with => sub {
 108             my $class = $CALLER;
 109             return subname 'Moose::with' => sub {
 110                 my (@roles) = @_;
 111                 _load_all_classes(@roles);
 112                 ($_->can('meta') && $_->meta->isa('Moose::Meta::Role'))
 113                     || confess "You can only consume roles, $_ is not a Moose role"
 114                         foreach @roles;
 115                 if (scalar @roles == 1) {
 116                     $roles[0]->meta->apply($class->meta);
 117                 }
 118                 else {
 119                     Moose::Meta::Role->combine(
 120                         map { $_->meta } @roles
 121                     )->apply($class->meta);
 122                 }
 123             };
 124         },
 125         has => sub {
 126             my $class = $CALLER;
 127             return subname 'Moose::has' => sub {
 128                 my ($name, %options) = @_;
 129                 my $meta = $class->meta;
 130                 if ($name =~ /^\+(.*)/) {
 131                     my $inherited_attr = $meta->find_attribute_by_name($1);
 132                     (defined $inherited_attr)
 133                         || confess "Could not find an attribute by the name of '$1' to inherit from";
 134                     my $new_attr = $inherited_attr->clone_and_inherit_options(%options);
 135                     $meta->add_attribute($new_attr);
 136                 }
 137                 else {
 138                     if ($options{metaclass}) {
 139                         _load_all_classes($options{metaclass});
 140                         $meta->add_attribute($options{metaclass}->new($name, %options));
 141                     }
 142                     else {
 143                         $meta->add_attribute($name, %options);
 144                     }
 145                 }
 146             };
 147         },
 148         before => sub {
 149             my $class = $CALLER;
 150             return subname 'Moose::before' => sub {
 151                 my $code = pop @_;
 152                 my $meta = $class->meta;
 153                 $meta->add_before_method_modifier($_, $code) for @_;
 154             };
 155         },
 156         after => sub {
 157             my $class = $CALLER;
 158             return subname 'Moose::after' => sub {
 159                 my $code = pop @_;
 160                 my $meta = $class->meta;
 161                 $meta->add_after_method_modifier($_, $code) for @_;
 162             };
 163         },
 164         around => sub {
 165             my $class = $CALLER;
 166             return subname 'Moose::around' => sub {
 167                 my $code = pop @_;
 168                 my $meta = $class->meta;
 169                 $meta->add_around_method_modifier($_, $code) for @_;
 170             };
 171         },
 172         super => sub {
 173             return subname 'Moose::super' => sub {};
 174         },
 175         override => sub {
 176             my $class = $CALLER;
 177             return subname 'Moose::override' => sub {
 178                 my ($name, $method) = @_;
 179                 $class->meta->add_override_method_modifier($name => $method);
 180             };
 181         },
 182         inner => sub {
 183             return subname 'Moose::inner' => sub {};
 184         },
 185         augment => sub {
 186             my $class = $CALLER;
 187             return subname 'Moose::augment' => sub {
 188                 my ($name, $method) = @_;
 189                 $class->meta->add_augment_method_modifier($name => $method);
 190             };
 191         },
 192         confess => sub {
 193             return \&Carp::confess;
 194         },
 195         blessed => sub {
 196             return \&Scalar::Util::blessed;
 197         }
 198     );
 199
 200     my $exporter = Sub::Exporter::build_exporter({
 201         exports => \%exports,
 202         groups  => {
 203             default => [':all']
 204         }
 205     });
 206
 207     sub import {
 208         $CALLER = caller();
 209
 210         # we should never export to main
 211         return if $CALLER eq 'main';
 212
 213         _init_meta();
 214
 215         goto $exporter;
 216     }
 217 }
 218
 219 ## Utility functions
 220
 221 sub _load_all_classes {
 222     foreach my $super (@_) {
 223         # see if this is already
 224         # loaded in the symbol table
 225         next if _is_class_already_loaded($super);
 226         # otherwise require it ...
 227         ($super->require)
 228             || confess "Could not load superclass '$super' because : " . $UNIVERSAL::require::ERROR;
 229     }
 230 }
 231
 232 sub _is_class_already_loaded {
 233         my $name = shift;
 234         no strict 'refs';
 235         return 1 if defined ${"${name}::VERSION"} || defined @{"${name}::ISA"};
 236         foreach (keys %{"${name}::"}) {
 237                 next if substr($_, -2, 2) eq '::';
 238                 return 1 if defined &{"${name}::$_"};
 239         }
 240     return 0;
 241 }
 242
 243 1;
 244
 245 __END__
 246
 247 =pod
 248
 249 =head1 NAME
 250
 251 Moose - Moose, it's the new Camel
 252
 253 =head1 SYNOPSIS
 254
 255   package Point;
 256   use Moose;
 257
 258   has 'x' => (isa => 'Int', is => 'rw');
 259   has 'y' => (isa => 'Int', is => 'rw');
 260
 261   sub clear {
 262       my $self = shift;
 263       $self->x(0);
 264       $self->y(0);
 265   }
 266
 267   package Point3D;
 268   use Moose;
 269
 270   extends 'Point';
 271
 272   has 'z' => (isa => 'Int');
 273
 274   after 'clear' => sub {
 275       my $self = shift;
 276       $self->{z} = 0;
 277   };
 278
 279 =head1 CAVEAT
 280
 281 This is an early release of this module, it still needs
 282 some fine tuning and B<lots> more documentation. I am adopting
 283 the I<release early and release often> approach with this module,
 284 so keep an eye on your favorite CPAN mirror!
 285
 286 =head1 DESCRIPTION
 287
 288 Moose is an extension of the Perl 5 object system.
 289
 290 =head2 Another object system!?!?
 291
 292 Yes, I know there has been an explosion recently of new ways to
 293 build object's in Perl 5, most of them based on inside-out objects,
 294 and other such things. Moose is different because it is not a new
 295 object system for Perl 5, but instead an extension of the existing
 296 object system.
 297
 298 Moose is built on top of L<Class::MOP>, which is a metaclass system
 299 for Perl 5. This means that Moose not only makes building normal
 300 Perl 5 objects better, but it also provides the power of metaclass
 301 programming.
 302
 303 =head2 What does Moose stand for??
 304
 305 Moose doesn't stand for one thing in particular, however, if you
 306 want, here are a few of my favorites, feel free to contribute
 307 more :)
 308
 309 =over 4
 310
 311 =item Make Other Object Systems Envious
 312
 313 =item Makes Object Orientation So Easy
 314
 315 =item Makes Object Orientation Spiffy- Er  (sorry ingy)
 316
 317 =item Most Other Object Systems Emasculate
 318
 319 =item My Overcraft Overfilled (with) Some Eels
 320
 321 =item Moose Often Ovulate Sorta Early
 322
 323 =item Many Overloaded Object Systems Exists
 324
 325 =item Moose Offers Often Super Extensions
 326
 327 =item Meta Object Orientation Syntax Extensions
 328
 329 =back
 330
 331 =head1 BUILDING CLASSES WITH MOOSE
 332
 333 Moose makes every attempt to provide as much convience during class
 334 construction/definition, but still stay out of your way if you want
 335 it to. Here are some of the features Moose provides:
 336
 337 Unless specified with C<extends>, any class which uses Moose will
 338 inherit from L<Moose::Object>.
 339
 340 Moose will also manage all attributes (including inherited ones) that
 341 are defined with C<has>. And assuming that you call C<new> which is
 342 inherited from L<Moose::Object>, then this includes properly initializing
 343 all instance slots, setting defaults where approprtiate and performing any
 344 type constraint checking or coercion.
 345
 346 For more details, see the ever expanding L<Moose::Cookbook>.
 347
 348 =head1 EXPORTED FUNCTIONS
 349
 350 Moose will export a number of functions into the class's namespace, which
 351 can then be used to set up the class. These functions all work directly
 352 on the current class.
 353
 354 =over 4
 355
 356 =item B<meta>
 357
 358 This is a method which provides access to the current class's metaclass.
 359
 360 =item B<extends (@superclasses)>
 361
 362 This function will set the superclass(es) for the current class.
 363
 364 This approach is recommended instead of C<use base>, because C<use base>
 365 actually C<push>es onto the class's C<@ISA>, whereas C<extends> will
 366 replace it. This is important to ensure that classes which do not have
 367 superclasses properly inherit from L<Moose::Object>.
 368
 369 =item B<with ($role)>
 370
 371 This will apply a given C<$role> to the local class. Role support is
 372 currently very experimental, see L<Moose::Role> for more details.
 373
 374 =item B<has ($name, %options)>
 375
 376 This will install an attribute of a given C<$name> into the current class.
 377 The list of C<%options> are the same as those provided by both
 378 L<Class::MOP::Attribute> and L<Moose::Meta::Attribute>, in addition to a
 379 few convience ones provided by Moose which are listed below:
 380
 381 =over 4
 382
 383 =item I<is =E<gt> 'rw'|'ro'>
 384
 385 The I<is> option accepts either I<rw> (for read/write) or I<ro> (for read
 386 only). These will create either a read/write accessor or a read-only
 387 accessor respectively, using the same name as the C<$name> of the attribute.
 388
 389 If you need more control over how your accessors are named, you can use the
 390 I<reader>, I<writer> and I<accessor> options inherited from L<Moose::Meta::Attribute>.
 391
 392 =item I<isa =E<gt> $type_name>
 393
 394 The I<isa> option uses Moose's type constraint facilities to set up runtime
 395 type checking for this attribute. Moose will perform the checks during class
 396 construction, and within any accessors. The C<$type_name> argument must be a
 397 string. The string can be either a class name, or a type defined using
 398 Moose's type defintion features.
 399
 400 =item I<coerce =E<gt> (1|0)>
 401
 402 This will attempt to use coercion with the supplied type constraint to change
 403 the value passed into any accessors of constructors. You B<must> have supplied
 404 a type constraint in order for this to work. See L<Moose::Cookbook::Recipe5>
 405 for an example usage.
 406
 407 =item I<does =E<gt> $role_name>
 408
 409 This will accept the name of a role which the value stored in this attribute
 410 is expected to have consumed.
 411
 412 =item I<required =E<gt> (1|0)>
 413
 414 This marks the attribute as being required. This means a value must be supplied
 415 during class construction, and the attribute can never be set to C<undef> with
 416 an accessor.
 417
 418 =item I<weak_ref =E<gt> (1|0)>
 419
 420 This will tell the class to strore the value of this attribute as a weakened
 421 reference. If an attribute is a weakened reference, it can B<not> also be coerced.
 422
 423 =item I<lazy =E<gt> (1|0)>
 424
 425 This will tell the class to not create this slot until absolutely nessecary.
 426 If an attribute is marked as lazy it B<must> have a default supplied.
 427
 428 =item I<trigger =E<gt> $code>
 429
 430 The trigger option is a CODE reference which will be called after the value of
 431 the attribute is set. The CODE ref will be passed the instance itself, the
 432 updated value and the attribute meta-object (this is for more advanced fiddling
 433 and can typically be ignored in most cases). You can B<not> have a trigger on
 434 a read-only attribute.
 435
 436 =back
 437
 438 =item B<before $name|@names =E<gt> sub { ... }>
 439
 440 =item B<after $name|@names =E<gt> sub { ... }>
 441
 442 =item B<around $name|@names =E<gt> sub { ... }>
 443
 444 This three items are syntactic sugar for the before, after and around method
 445 modifier features that L<Class::MOP> provides. More information on these can
 446 be found in the L<Class::MOP> documentation for now.
 447
 448 =item B<super>
 449
 450 The keyword C<super> is a noop when called outside of an C<override> method. In
 451 the context of an C<override> method, it will call the next most appropriate
 452 superclass method with the same arguments as the original method.
 453
 454 =item B<override ($name, &sub)>
 455
 456 An C<override> method, is a way of explictly saying "I am overriding this
 457 method from my superclass". You can call C<super> within this method, and
 458 it will work as expected. The same thing I<can> be accomplished with a normal
 459 method call and the C<SUPER::> pseudo-package, it is really your choice.
 460
 461 =item B<inner>
 462
 463 The keyword C<inner>, much like C<super>, is a no-op outside of the context of
 464 an C<augment> method. You can think of C<inner> as being the inverse of
 465 C<super>, the details of how C<inner> and C<augment> work is best described in
 466 the L<Moose::Cookbook>.
 467
 468 =item B<augment ($name, &sub)>
 469
 470 An C<augment> method, is a way of explictly saying "I am augmenting this
 471 method from my superclass". Once again, the details of how C<inner> and
 472 C<augment> work is best described in the L<Moose::Cookbook>.
 473
 474 =item B<confess>
 475
 476 This is the C<Carp::confess> function, and exported here beause I use it
 477 all the time. This feature may change in the future, so you have been warned.
 478
 479 =item B<blessed>
 480
 481 This is the C<Scalar::Uti::blessed> function, it is exported here beause I
 482 use it all the time. It is highly recommended that this is used instead of
 483 C<ref> anywhere you need to test for an object's class name.
 484
 485 =back
 486
 487 =head1 CAVEATS
 488
 489 =over 4
 490
 491 =item *
 492
 493 It should be noted that C<super> and C<inner> can B<not> be used in the same
 494 method. However, they can be combined together with the same class hierarchy,
 495 see F<t/014_override_augment_inner_super.t> for an example.
 496
 497 The reason that this is so is because C<super> is only valid within a method
 498 with the C<override> modifier, and C<inner> will never be valid within an
 499 C<override> method. In fact, C<augment> will skip over any C<override> methods
 500 when searching for it's appropriate C<inner>.
 501
 502 This might seem like a restriction, but I am of the opinion that keeping these
 503 two features seperate (but interoperable) actually makes them easy to use since
 504 their behavior is then easier to predict. Time will tell if I am right or not.
 505
 506 =back
 507
 508 =head1 ACKNOWLEDGEMENTS
 509
 510 =over 4
 511
 512 =item I blame Sam Vilain for introducing me to the insanity that is meta-models.
 513
 514 =item I blame Audrey Tang for then encouraging my meta-model habit in #perl6.
 515
 516 =item Without Yuval "nothingmuch" Kogman this module would not be possible,
 517 and it certainly wouldn't have this name ;P
 518
 519 =item The basis of the TypeContraints module was Rob Kinyon's idea
 520 originally, I just ran with it.
 521
 522 =item Thanks to mst & chansen and the whole #moose poose for all the
 523 ideas/feature-requests/encouragement
 524
 525 =back
 526
 527 =head1 SEE ALSO
 528
 529 =over 4
 530
 531 =item L<Class::MOP> documentation
 532
 533 =item The #moose channel on irc.perl.org
 534
 535 =item L<http://forum2.org/moose/>
 536
 537 =item L<http://www.cs.utah.edu/plt/publications/oopsla04-gff.pdf>
 538
 539 This paper (suggested by lbr on #moose) was what lead to the implementation
 540 of the C<super>/C<overrride> and C<inner>/C<augment> features. If you really
 541 want to understand this feature, I suggest you read this.
 542
 543 =back
 544
 545 =head1 BUGS
 546
 547 All complex software has bugs lurking in it, and this module is no
 548 exception. If you find a bug please either email me, or add the bug
 549 to cpan-RT.
 550
 551 =head1 AUTHOR
 552
 553 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 554
 555 Christian Hansen E<lt>chansen@cpan.orgE<gt>
 556
 557 Yuval Kogman E<lt>nothingmuch@woobling.orgE<gt>
 558
 559 =head1 COPYRIGHT AND LICENSE
 560
 561 Copyright 2006 by Infinity Interactive, Inc.
 562
 563 L<http://www.iinteractive.com>
 564
 565 This library is free software; you can redistribute it and/or modify
 566 it under the same terms as Perl itself.
 567
 568 =cut