lib/Moose.pm

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