lib/Moose.pm

   1
   2 package Moose;
   3
   4 use strict;
   5 use warnings;
   6
   7 our $VERSION = '0.17';
   8
   9 use Scalar::Util 'blessed', 'reftype';
  10 use Carp         'confess';
  11 use Sub::Name    'subname';
  12 use B            'svref_2object';
  13
  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             => optimize_as { blessed($_[0]) && $_[0]->isa($class) }
  38         unless find_type_constraint($class);
  39
  40         my $meta;
  41         if ($class->can('meta')) {
  42             # NOTE:
  43             # this is the case where the metaclass pragma
  44             # was used before the 'use Moose' statement to
  45             # override a specific class
  46             $meta = $class->meta();
  47             (blessed($meta) && $meta->isa('Moose::Meta::Class'))
  48                 || confess "You already have a &meta function, but it does not return a Moose::Meta::Class";
  49         }
  50         else {
  51             # NOTE:
  52             # this is broken currently, we actually need
  53             # to allow the possiblity of an inherited
  54             # meta, which will not be visible until the
  55             # user 'extends' first. This needs to have
  56             # more intelligence to it
  57             $meta = Moose::Meta::Class->initialize($class);
  58             $meta->add_method('meta' => sub {
  59                 # re-initialize so it inherits properly
  60                 Moose::Meta::Class->initialize(blessed($_[0]) || $_[0]);
  61             })
  62         }
  63
  64         # make sure they inherit from Moose::Object
  65         $meta->superclasses('Moose::Object')
  66            unless $meta->superclasses();
  67     }
  68
  69     my %exports = (
  70         extends => sub {
  71             my $class = $CALLER;
  72             return subname 'Moose::extends' => sub (@) {
  73                 confess "Must derive at least one class" unless @_;
  74                 _load_all_classes(@_);
  75                 # this checks the metaclass to make sure
  76                 # it is correct, sometimes it can get out
  77                 # of sync when the classes are being built
  78                 my $meta = $class->meta->_fix_metaclass_incompatability(@_);
  79                 $meta->superclasses(@_);
  80             };
  81         },
  82         with => sub {
  83             my $class = $CALLER;
  84             return subname 'Moose::with' => sub (@) {
  85                 my (@roles) = @_;
  86                 confess "Must specify at least one role" unless @roles;
  87                 _load_all_classes(@roles);
  88                 $class->meta->_apply_all_roles(@roles);
  89             };
  90         },
  91         has => sub {
  92             my $class = $CALLER;
  93             return subname 'Moose::has' => sub ($;%) {
  94                 my ($name, %options) = @_;
  95                 $class->meta->_process_attribute($name, %options);
  96             };
  97         },
  98         before => sub {
  99             my $class = $CALLER;
 100             return subname 'Moose::before' => sub (@&) {
 101                 my $code = pop @_;
 102                 my $meta = $class->meta;
 103                 $meta->add_before_method_modifier($_, $code) for @_;
 104             };
 105         },
 106         after => sub {
 107             my $class = $CALLER;
 108             return subname 'Moose::after' => sub (@&) {
 109                 my $code = pop @_;
 110                 my $meta = $class->meta;
 111                 $meta->add_after_method_modifier($_, $code) for @_;
 112             };
 113         },
 114         around => sub {
 115             my $class = $CALLER;
 116             return subname 'Moose::around' => sub (@&) {
 117                 my $code = pop @_;
 118                 my $meta = $class->meta;
 119                 $meta->add_around_method_modifier($_, $code) for @_;
 120             };
 121         },
 122         super => sub {
 123             return subname 'Moose::super' => sub {};
 124         },
 125         override => sub {
 126             my $class = $CALLER;
 127             return subname 'Moose::override' => sub ($&) {
 128                 my ($name, $method) = @_;
 129                 $class->meta->add_override_method_modifier($name => $method);
 130             };
 131         },
 132         inner => sub {
 133             return subname 'Moose::inner' => sub {};
 134         },
 135         augment => sub {
 136             my $class = $CALLER;
 137             return subname 'Moose::augment' => sub (@&) {
 138                 my ($name, $method) = @_;
 139                 $class->meta->add_augment_method_modifier($name => $method);
 140             };
 141         },
 142
 143         # NOTE:
 144         # this is experimental, but I am not
 145         # happy with it. If you want to try
 146         # it, you will have to uncomment it
 147         # yourself.
 148         # There is a really good chance that
 149         # this will be deprecated, dont get
 150         # too attached
 151         # self => sub {
 152         #     return subname 'Moose::self' => sub {};
 153         # },
 154         # method => sub {
 155         #     my $class = $CALLER;
 156         #     return subname 'Moose::method' => sub {
 157         #         my ($name, $method) = @_;
 158         #         $class->meta->add_method($name, sub {
 159         #             my $self = shift;
 160         #             no strict   'refs';
 161         #             no warnings 'redefine';
 162         #             local *{$class->meta->name . '::self'} = sub { $self };
 163         #             $method->(@_);
 164         #         });
 165         #     };
 166         # },
 167
 168         confess => sub {
 169             return \&Carp::confess;
 170         },
 171         blessed => sub {
 172             return \&Scalar::Util::blessed;
 173         },
 174     );
 175
 176     my $exporter = Sub::Exporter::build_exporter({
 177         exports => \%exports,
 178         groups  => {
 179             default => [':all']
 180         }
 181     });
 182
 183     sub import {
 184         $CALLER = caller();
 185
 186         strict->import;
 187         warnings->import;
 188
 189         # we should never export to main
 190         return if $CALLER eq 'main';
 191
 192         _init_meta();
 193
 194         goto $exporter;
 195     }
 196
 197     sub unimport {
 198         no strict 'refs';
 199         my $class = caller();
 200         # loop through the exports ...
 201         foreach my $name (keys %exports) {
 202             next if $name =~ /inner|super|self/;
 203
 204             # if we find one ...
 205             if (defined &{$class . '::' . $name}) {
 206                 my $keyword = \&{$class . '::' . $name};
 207
 208                 # make sure it is from Moose
 209                 my $pkg_name = eval { svref_2object($keyword)->GV->STASH->NAME };
 210                 next if $@;
 211                 next if $pkg_name ne 'Moose';
 212
 213                 # and if it is from Moose then undef the slot
 214                 delete ${$class . '::'}{$name};
 215             }
 216         }
 217     }
 218 }
 219
 220 ## Utility functions
 221
 222 sub _load_all_classes {
 223     foreach my $class (@_) {
 224         # see if this is already
 225         # loaded in the symbol table
 226         next if _is_class_already_loaded($class);
 227         # otherwise require it ...
 228         my $file = $class . '.pm';
 229         $file =~ s{::}{/}g;
 230         eval { CORE::require($file) };
 231         confess(
 232             "Could not load module '$class' because : $@"
 233             ) if $@;
 234     }
 235 }
 236
 237 sub _is_class_already_loaded {
 238         my $name = shift;
 239         no strict 'refs';
 240         return 1 if defined ${"${name}::VERSION"} || defined @{"${name}::ISA"};
 241         foreach (keys %{"${name}::"}) {
 242                 next if substr($_, -2, 2) eq '::';
 243                 return 1 if defined &{"${name}::$_"};
 244         }
 245         return 0;
 246 }
 247
 248 1;
 249
 250 __END__
 251
 252 =pod
 253
 254 =head1 NAME
 255
 256 Moose - A complete modern object system for Perl 5
 257
 258 =head1 SYNOPSIS
 259
 260   package Point;
 261   use strict;
 262   use warnings;
 263   use Moose;
 264
 265   has 'x' => (is => 'rw', isa => 'Int');
 266   has 'y' => (is => 'rw', isa => 'Int');
 267
 268   sub clear {
 269       my $self = shift;
 270       $self->x(0);
 271       $self->y(0);
 272   }
 273
 274   package Point3D;
 275   use strict;
 276   use warnings;
 277   use Moose;
 278
 279   extends 'Point';
 280
 281   has 'z' => (is => 'rw', isa => 'Int');
 282
 283   after 'clear' => sub {
 284       my $self = shift;
 285       $self->z(0);
 286   };
 287
 288 =head1 CAVEAT
 289
 290 Moose is a rapidly maturing module, and is already being used by
 291 a number of people. It's test suite is growing larger by the day,
 292 and the docs should soon follow.
 293
 294 This said, Moose is not yet finished, and should still be considered
 295 to be evolving. Much of the outer API is stable, but the internals
 296 are still subject to change (although not without serious thought
 297 given to it).
 298
 299 =head1 DESCRIPTION
 300
 301 Moose is an extension of the Perl 5 object system.
 302
 303 =head2 Another object system!?!?
 304
 305 Yes, I know there has been an explosion recently of new ways to
 306 build object's in Perl 5, most of them based on inside-out objects
 307 and other such things. Moose is different because it is not a new
 308 object system for Perl 5, but instead an extension of the existing
 309 object system.
 310
 311 Moose is built on top of L<Class::MOP>, which is a metaclass system
 312 for Perl 5. This means that Moose not only makes building normal
 313 Perl 5 objects better, but it also provides the power of metaclass
 314 programming.
 315
 316 =head2 Can I use this in production? Or is this just an experiment?
 317
 318 Moose is I<based> on the prototypes and experiments I did for the Perl 6
 319 meta-model; however Moose is B<NOT> an experiment/prototype, it is
 320 for B<real>. I will be deploying Moose into production environments later
 321 this year, and I have every intentions of using it as my de facto class
 322 builder from now on.
 323
 324 =head2 Is Moose just Perl 6 in Perl 5?
 325
 326 No. While Moose is very much inspired by Perl 6, it is not itself Perl 6.
 327 Instead, it is an OO system for Perl 5. I built Moose because I was tired or
 328 writing the same old boring Perl 5 OO code, and drooling over Perl 6 OO. So
 329 instead of switching to Ruby, I wrote Moose :)
 330
 331 =head1 BUILDING CLASSES WITH MOOSE
 332
 333 Moose makes every attempt to provide as much convenience as possible during
 334 class construction/definition, but still stay out of your way if you want it
 335 to. Here are a few items to note when building classes with Moose.
 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 appropriate, and performing any
 344 type constraint checking or coercion.
 345
 346 =head1 EXPORTED FUNCTIONS
 347
 348 Moose will export a number of functions into the class's namespace which
 349 can then be used to set up the class. These functions all work directly
 350 on the current class.
 351
 352 =over 4
 353
 354 =item B<meta>
 355
 356 This is a method which provides access to the current class's metaclass.
 357
 358 =item B<extends (@superclasses)>
 359
 360 This function will set the superclass(es) for the current class.
 361
 362 This approach is recommended instead of C<use base>, because C<use base>
 363 actually C<push>es onto the class's C<@ISA>, whereas C<extends> will
 364 replace it. This is important to ensure that classes which do not have
 365 superclasses still properly inherit from L<Moose::Object>.
 366
 367 =item B<with (@roles)>
 368
 369 This will apply a given set of C<@roles> to the local class. Role support
 370 is currently under heavy development; see L<Moose::Role> for more details.
 371
 372 =item B<has ($name, %options)>
 373
 374 This will install an attribute of a given C<$name> into the current class.
 375 The list of C<%options> are the same as those provided by
 376 L<Class::MOP::Attribute>, in addition to the list below which are provided
 377 by Moose (L<Moose::Meta::Attribute> to be more specific):
 378
 379 =over 4
 380
 381 =item I<is =E<gt> 'rw'|'ro'>
 382
 383 The I<is> option accepts either I<rw> (for read/write) or I<ro> (for read
 384 only). These will create either a read/write accessor or a read-only
 385 accessor respectively, using the same name as the C<$name> of the attribute.
 386
 387 If you need more control over how your accessors are named, you can use the
 388 I<reader>, I<writer> and I<accessor> options inherited from L<Class::MOP::Attribute>.
 389
 390 =item I<isa =E<gt> $type_name>
 391
 392 The I<isa> option uses Moose's type constraint facilities to set up runtime
 393 type checking for this attribute. Moose will perform the checks during class
 394 construction, and within any accessors. The C<$type_name> argument must be a
 395 string. The string can be either a class name or a type defined using
 396 Moose's type definition features.
 397
 398 =item I<coerce =E<gt> (1|0)>
 399
 400 This will attempt to use coercion with the supplied type constraint to change
 401 the value passed into any accessors or constructors. You B<must> have supplied
 402 a type constraint in order for this to work. See L<Moose::Cookbook::Recipe5>
 403 for an example usage.
 404
 405 =item I<does =E<gt> $role_name>
 406
 407 This will accept the name of a role which the value stored in this attribute
 408 is expected to have consumed.
 409
 410 =item I<required =E<gt> (1|0)>
 411
 412 This marks the attribute as being required. This means a value must be supplied
 413 during class construction, and the attribute can never be set to C<undef> with
 414 an accessor.
 415
 416 =item I<weak_ref =E<gt> (1|0)>
 417
 418 This will tell the class to store the value of this attribute as a weakened
 419 reference. If an attribute is a weakened reference, it B<cannot> also be
 420 coerced.
 421
 422 =item I<lazy =E<gt> (1|0)>
 423
 424 This will tell the class to not create this slot until absolutely necessary.
 425 If an attribute is marked as lazy it B<must> have a default supplied.
 426
 427 =item I<auto_deref =E<gt> (1|0)>
 428
 429 This tells the accessor whether to automatically dereference the value returned.
 430 This is only legal if your C<isa> option is either an C<ArrayRef> or C<HashRef>.
 431
 432 =item I<trigger =E<gt> $code>
 433
 434 The trigger option is a CODE reference which will be called after the value of
 435 the attribute is set. The CODE ref will be passed the instance itself, the
 436 updated value and the attribute meta-object (this is for more advanced fiddling
 437 and can typically be ignored in most cases). You B<cannot> have a trigger on
 438 a read-only attribute.
 439
 440 =item I<handles =E<gt> [ @handles ]>
 441
 442 There is experimental support for attribute delegation using the C<handles>
 443 option. More docs to come later.
 444
 445 =back
 446
 447 =item B<before $name|@names =E<gt> sub { ... }>
 448
 449 =item B<after $name|@names =E<gt> sub { ... }>
 450
 451 =item B<around $name|@names =E<gt> sub { ... }>
 452
 453 This three items are syntactic sugar for the before, after, and around method
 454 modifier features that L<Class::MOP> provides. More information on these can
 455 be found in the L<Class::MOP> documentation for now.
 456
 457 =item B<super>
 458
 459 The keyword C<super> is a no-op when called outside of an C<override> method. In
 460 the context of an C<override> method, it will call the next most appropriate
 461 superclass method with the same arguments as the original method.
 462
 463 =item B<override ($name, &sub)>
 464
 465 An C<override> method is a way of explicitly saying "I am overriding this
 466 method from my superclass". You can call C<super> within this method, and
 467 it will work as expected. The same thing I<can> be accomplished with a normal
 468 method call and the C<SUPER::> pseudo-package; it is really your choice.
 469
 470 =item B<inner>
 471
 472 The keyword C<inner>, much like C<super>, is a no-op outside of the context of
 473 an C<augment> method. You can think of C<inner> as being the inverse of
 474 C<super>; the details of how C<inner> and C<augment> work is best described in
 475 the L<Moose::Cookbook>.
 476
 477 =item B<augment ($name, &sub)>
 478
 479 An C<augment> method, is a way of explicitly saying "I am augmenting this
 480 method from my superclass". Once again, the details of how C<inner> and
 481 C<augment> work is best described in the L<Moose::Cookbook>.
 482
 483 =item B<confess>
 484
 485 This is the C<Carp::confess> function, and exported here because I use it
 486 all the time. This feature may change in the future, so you have been warned.
 487
 488 =item B<blessed>
 489
 490 This is the C<Scalar::Uti::blessed> function, it is exported here because I
 491 use it all the time. It is highly recommended that this is used instead of
 492 C<ref> anywhere you need to test for an object's class name.
 493
 494 =back
 495
 496 =head1 UNEXPORTING FUNCTIONS
 497
 498 =head2 B<unimport>
 499
 500 Moose offers a way of removing the keywords it exports though the C<unimport>
 501 method. You simply have to say C<no Moose> at the bottom of your code for this
 502 to work. Here is an example:
 503
 504     package Person;
 505     use Moose;
 506
 507     has 'first_name' => (is => 'rw', isa => 'Str');
 508     has 'last_name'  => (is => 'rw', isa => 'Str');
 509
 510     sub full_name {
 511         my $self = shift;
 512         $self->first_name . ' ' . $self->last_name
 513     }
 514
 515     no Moose; # keywords are removed from the Person package
 516
 517 =head1 MISC.
 518
 519 =head2 What does Moose stand for??
 520
 521 Moose doesn't stand for one thing in particular, however, if you
 522 want, here are a few of my favorites; feel free to contribute
 523 more :)
 524
 525 =over 4
 526
 527 =item Make Other Object Systems Envious
 528
 529 =item Makes Object Orientation So Easy
 530
 531 =item Makes Object Orientation Spiffy- Er  (sorry ingy)
 532
 533 =item Most Other Object Systems Emasculate
 534
 535 =item Moose Often Ovulate Sorta Early
 536
 537 =item Moose Offers Often Super Extensions
 538
 539 =item Meta Object Orientation Syntax Extensions
 540
 541 =back
 542
 543 =head1 CAVEATS
 544
 545 =over 4
 546
 547 =item *
 548
 549 It should be noted that C<super> and C<inner> C<cannot> be used in the same
 550 method. However, they can be combined together with the same class hierarchy;
 551 see F<t/014_override_augment_inner_super.t> for an example.
 552
 553 The reason for this is that C<super> is only valid within a method
 554 with the C<override> modifier, and C<inner> will never be valid within an
 555 C<override> method. In fact, C<augment> will skip over any C<override> methods
 556 when searching for its appropriate C<inner>.
 557
 558 This might seem like a restriction, but I am of the opinion that keeping these
 559 two features separate (but interoperable) actually makes them easy to use, since
 560 their behavior is then easier to predict. Time will tell if I am right or not.
 561
 562 =back
 563
 564 =head1 ACKNOWLEDGEMENTS
 565
 566 =over 4
 567
 568 =item I blame Sam Vilain for introducing me to the insanity that is meta-models.
 569
 570 =item I blame Audrey Tang for then encouraging my meta-model habit in #perl6.
 571
 572 =item Without Yuval "nothingmuch" Kogman this module would not be possible,
 573 and it certainly wouldn't have this name ;P
 574
 575 =item The basis of the TypeContraints module was Rob Kinyon's idea
 576 originally, I just ran with it.
 577
 578 =item Thanks to mst & chansen and the whole #moose poose for all the
 579 ideas/feature-requests/encouragement
 580
 581 =item Thanks to David "Theory" Wheeler for meta-discussions and spelling fixes.
 582
 583 =back
 584
 585 =head1 SEE ALSO
 586
 587 =over 4
 588
 589 =item L<Class::MOP> documentation
 590
 591 =item The #moose channel on irc.perl.org
 592
 593 =item The Moose mailing list - moose@perl.org
 594
 595 =item L<http://forum2.org/moose/>
 596
 597 =item L<http://www.cs.utah.edu/plt/publications/oopsla04-gff.pdf>
 598
 599 This paper (suggested by lbr on #moose) was what lead to the implementation
 600 of the C<super>/C<overrride> and C<inner>/C<augment> features. If you really
 601 want to understand this feature, I suggest you read this.
 602
 603 =back
 604
 605 =head1 BUGS
 606
 607 All complex software has bugs lurking in it, and this module is no
 608 exception. If you find a bug please either email me, or add the bug
 609 to cpan-RT.
 610
 611 =head1 AUTHOR
 612
 613 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 614
 615 Christian Hansen E<lt>chansen@cpan.orgE<gt>
 616
 617 Yuval Kogman E<lt>nothingmuch@woobling.orgE<gt>
 618
 619 =head1 COPYRIGHT AND LICENSE
 620
 621 Copyright 2006 by Infinity Interactive, Inc.
 622
 623 L<http://www.iinteractive.com>
 624
 625 This library is free software; you can redistribute it and/or modify
 626 it under the same terms as Perl itself.
 627
 628 =cut