lib/Mouse.pm

   1 package Mouse;
   2 use strict;
   3 use warnings;
   4 use 5.006;
   5 use base 'Exporter';
   6
   7 our $VERSION = '0.30';
   8
   9 use Carp 'confess';
  10 use Scalar::Util 'blessed';
  11 use Mouse::Util;
  12
  13 use Mouse::Meta::Attribute;
  14 use Mouse::Meta::Module; # class_of()
  15 use Mouse::Meta::Class;
  16 use Mouse::Object;
  17 use Mouse::Util::TypeConstraints;
  18
  19 our @EXPORT = qw(extends has before after around override super blessed confess with);
  20
  21 our %is_removable = map{ $_ => undef } @EXPORT;
  22 delete $is_removable{blessed};
  23 delete $is_removable{confess};
  24
  25 sub extends { Mouse::Meta::Class->initialize(caller)->superclasses(@_) }
  26
  27 sub has {
  28     my $meta = Mouse::Meta::Class->initialize(caller);
  29     $meta->add_attribute(@_);
  30 }
  31
  32 sub before {
  33     my $meta = Mouse::Meta::Class->initialize(caller);
  34
  35     my $code = pop;
  36
  37     for (@_) {
  38         $meta->add_before_method_modifier($_ => $code);
  39     }
  40 }
  41
  42 sub after {
  43     my $meta = Mouse::Meta::Class->initialize(caller);
  44
  45     my $code = pop;
  46
  47     for (@_) {
  48         $meta->add_after_method_modifier($_ => $code);
  49     }
  50 }
  51
  52 sub around {
  53     my $meta = Mouse::Meta::Class->initialize(caller);
  54
  55     my $code = pop;
  56
  57     for (@_) {
  58         $meta->add_around_method_modifier($_ => $code);
  59     }
  60 }
  61
  62 sub with {
  63     Mouse::Util::apply_all_roles((caller)[0], @_);
  64 }
  65
  66 our $SUPER_PACKAGE;
  67 our $SUPER_BODY;
  68 our @SUPER_ARGS;
  69
  70 sub super {
  71     # This check avoids a recursion loop - see
  72     # t/100_bugs/020_super_recursion.t
  73     return if defined $SUPER_PACKAGE && $SUPER_PACKAGE ne caller();
  74     return unless $SUPER_BODY; $SUPER_BODY->(@SUPER_ARGS);
  75 }
  76
  77 sub override {
  78     my $meta = Mouse::Meta::Class->initialize(caller);
  79     my $pkg = $meta->name;
  80
  81     my $name = shift;
  82     my $code = shift;
  83
  84     my $body = $pkg->can($name)
  85         or confess "You cannot override '$name' because it has no super method";
  86
  87     $meta->add_method($name => sub {
  88         local $SUPER_PACKAGE = $pkg;
  89         local @SUPER_ARGS = @_;
  90         local $SUPER_BODY = $body;
  91
  92         $code->(@_);
  93     });
  94 }
  95
  96 sub init_meta {
  97     # This used to be called as a function. This hack preserves
  98     # backwards compatibility.
  99     if ( $_[0] ne __PACKAGE__ ) {
 100         return __PACKAGE__->init_meta(
 101             for_class  => $_[0],
 102             base_class => $_[1],
 103             metaclass  => $_[2],
 104         );
 105     }
 106
 107     shift;
 108     my %args = @_;
 109
 110     my $class = $args{for_class}
 111       or Carp::croak(
 112         "Cannot call init_meta without specifying a for_class");
 113     my $base_class = $args{base_class} || 'Mouse::Object';
 114     my $metaclass  = $args{metaclass}  || 'Mouse::Meta::Class';
 115
 116     Carp::croak("The Metaclass $metaclass must be a subclass of Mouse::Meta::Class.")
 117             unless $metaclass->isa('Mouse::Meta::Class');
 118
 119     # make a subtype for each Mouse class
 120     class_type($class)
 121         unless find_type_constraint($class);
 122
 123     my $meta = $metaclass->initialize($class);
 124     $meta->superclasses($base_class)
 125         unless $meta->superclasses;
 126
 127     $meta->add_method(meta => sub{
 128         return Mouse::Meta::Class->initialize(ref($_[0]) || $_[0]);
 129     });
 130
 131
 132     return $meta;
 133 }
 134
 135 sub import {
 136     my $class = shift;
 137
 138     strict->import;
 139     warnings->import;
 140
 141     my $opts = do {
 142         if (ref($_[0]) && ref($_[0]) eq 'HASH') {
 143             shift @_;
 144         } else {
 145             +{ };
 146         }
 147     };
 148     my $level = delete $opts->{into_level};
 149        $level = 0 unless defined $level;
 150     my $caller = caller($level);
 151
 152     # we should never export to main
 153     if ($caller eq 'main') {
 154         warn qq{$class does not export its sugar to the 'main' package.\n};
 155         return;
 156     }
 157
 158     Mouse->init_meta(
 159         for_class  => $caller,
 160     );
 161
 162     if (@_) {
 163         __PACKAGE__->export_to_level( $level+1, $class, @_);
 164     } else {
 165         # shortcut for the common case of no type character
 166         no strict 'refs';
 167         for my $keyword (@EXPORT) {
 168             *{ $caller . '::' . $keyword } = *{__PACKAGE__ . '::' . $keyword};
 169         }
 170     }
 171 }
 172
 173 sub unimport {
 174     my $caller = caller;
 175
 176     my $stash = do{
 177         no strict 'refs';
 178         \%{$caller . '::'}
 179     };
 180
 181     for my $keyword (@EXPORT) {
 182         my $code;
 183         if(exists $is_removable{$keyword}
 184             && ($code = $caller->can($keyword))
 185             && (Mouse::Util::get_code_info($code))[0] eq __PACKAGE__){
 186
 187             delete $stash->{$keyword};
 188         }
 189     }
 190 }
 191
 192 sub load_class {
 193     my $class = shift;
 194
 195     if (!Mouse::Util::is_valid_class_name($class)) {
 196         my $display = defined($class) ? $class : 'undef';
 197         confess "Invalid class name ($display)";
 198     }
 199
 200     return 1 if is_class_loaded($class);
 201
 202     (my $file = "$class.pm") =~ s{::}{/}g;
 203
 204     eval { CORE::require($file) };
 205     confess "Could not load class ($class) because : $@" if $@;
 206
 207     return 1;
 208 }
 209
 210 my %is_class_loaded_cache;
 211 sub is_class_loaded {
 212     my $class = shift;
 213
 214     return 0 if ref($class) || !defined($class) || !length($class);
 215
 216     return 1 if exists $is_class_loaded_cache{$class};
 217
 218     # walk the symbol table tree to avoid autovififying
 219     # \*{${main::}{"Foo::"}} == \*main::Foo::
 220
 221     my $pack = \*::;
 222     foreach my $part (split('::', $class)) {
 223         return 0 unless exists ${$$pack}{"${part}::"};
 224         $pack = \*{${$$pack}{"${part}::"}};
 225     }
 226
 227     # check for $VERSION or @ISA
 228     return ++$is_class_loaded_cache{$class} if exists ${$$pack}{VERSION}
 229              && defined *{${$$pack}{VERSION}}{SCALAR};
 230     return ++$is_class_loaded_cache{$class} if exists ${$$pack}{ISA}
 231              && defined *{${$$pack}{ISA}}{ARRAY};
 232
 233     # check for any method
 234     foreach ( keys %{$$pack} ) {
 235         next if substr($_, -2, 2) eq '::';
 236         return ++$is_class_loaded_cache{$class} if defined *{${$$pack}{$_}}{CODE};
 237     }
 238
 239     # fail
 240     return 0;
 241 }
 242
 243 1;
 244
 245 __END__
 246
 247 =head1 NAME
 248
 249 Mouse - Moose minus the antlers
 250
 251 =head1 SYNOPSIS
 252
 253     package Point;
 254     use Mouse; # automatically turns on strict and warnings
 255
 256     has 'x' => (is => 'rw', isa => 'Int');
 257     has 'y' => (is => 'rw', isa => 'Int');
 258
 259     sub clear {
 260         my $self = shift;
 261         $self->x(0);
 262         $self->y(0);
 263     }
 264
 265     package Point3D;
 266     use Mouse;
 267
 268     extends 'Point';
 269
 270     has 'z' => (is => 'rw', isa => 'Int');
 271
 272     after 'clear' => sub {
 273         my $self = shift;
 274         $self->z(0);
 275     };
 276
 277 =head1 DESCRIPTION
 278
 279 L<Moose> is wonderful. B<Use Moose instead of Mouse.>
 280
 281 Unfortunately, Moose has a compile-time penalty. Though significant progress
 282 has been made over the years, the compile time penalty is a non-starter for
 283 some very specific applications. If you are writing a command-line application
 284 or CGI script where startup time is essential, you may not be able to use
 285 Moose. We recommend that you instead use L<HTTP::Engine> and FastCGI for the
 286 latter, if possible.
 287
 288 Mouse aims to alleviate this by providing a subset of Moose's functionality,
 289 faster.
 290
 291 We're also going as light on dependencies as possible.
 292 L<Class::Method::Modifiers::Fast> or L<Class::Method::Modifiers> is required
 293 if you want support for L</before>, L</after>, and L</around>.
 294
 295 =head2 MOOSE COMPAT
 296
 297 Compatibility with Moose has been the utmost concern. Fewer than 1% of the
 298 tests fail when run against Moose instead of Mouse. Mouse code coverage is also
 299 over 96%. Even the error messages are taken from Moose. The Mouse code just
 300 runs the test suite 4x faster.
 301
 302 The idea is that, if you need the extra power, you should be able to run
 303 C<s/Mouse/Moose/g> on your codebase and have nothing break. To that end,
 304 we have written L<Any::Moose> which will act as Mouse unless Moose is loaded,
 305 in which case it will act as Moose. Since Mouse is a little sloppier than
 306 Moose, if you run into weird errors, it would be worth running:
 307
 308     ANY_MOOSE=Moose perl your-script.pl
 309
 310 to see if the bug is caused by Mouse. Moose's diagnostics and validation are
 311 also much better.
 312
 313 =head2 MouseX
 314
 315 Please don't copy MooseX code to MouseX. If you need extensions, you really
 316 should upgrade to Moose. We don't need two parallel sets of extensions!
 317
 318 If you really must write a Mouse extension, please contact the Moose mailing
 319 list or #moose on IRC beforehand.
 320
 321 =head2 Maintenance
 322
 323 The original author of this module has mostly stepped down from maintaining
 324 Mouse. See L<http://www.nntp.perl.org/group/perl.moose/2009/04/msg653.html>.
 325 If you would like to help maintain this module, please get in touch with us.
 326
 327 =head1 KEYWORDS
 328
 329 =head2 meta -> Mouse::Meta::Class
 330
 331 Returns this class' metaclass instance.
 332
 333 =head2 extends superclasses
 334
 335 Sets this class' superclasses.
 336
 337 =head2 before (method|methods) => Code
 338
 339 Installs a "before" method modifier. See L<Moose/before> or
 340 L<Class::Method::Modifiers/before>.
 341
 342 Use of this feature requires L<Class::Method::Modifiers>!
 343
 344 =head2 after (method|methods) => Code
 345
 346 Installs an "after" method modifier. See L<Moose/after> or
 347 L<Class::Method::Modifiers/after>.
 348
 349 Use of this feature requires L<Class::Method::Modifiers>!
 350
 351 =head2 around (method|methods) => Code
 352
 353 Installs an "around" method modifier. See L<Moose/around> or
 354 L<Class::Method::Modifiers/around>.
 355
 356 Use of this feature requires L<Class::Method::Modifiers>!
 357
 358 =head2 has (name|names) => parameters
 359
 360 Adds an attribute (or if passed an arrayref of names, multiple attributes) to
 361 this class. Options:
 362
 363 =over 4
 364
 365 =item is => ro|rw
 366
 367 If specified, inlines a read-only/read-write accessor with the same name as
 368 the attribute.
 369
 370 =item isa => TypeConstraint
 371
 372 Provides type checking in the constructor and accessor. The following types are
 373 supported. Any unknown type is taken to be a class check (e.g. isa =>
 374 'DateTime' would accept only L<DateTime> objects).
 375
 376     Any Item Bool Undef Defined Value Num Int Str ClassName
 377     Ref ScalarRef ArrayRef HashRef CodeRef RegexpRef GlobRef
 378     FileHandle Object
 379
 380 For more documentation on type constraints, see L<Mouse::Util::TypeConstraints>.
 381
 382
 383 =item required => 0|1
 384
 385 Whether this attribute is required to have a value. If the attribute is lazy or
 386 has a builder, then providing a value for the attribute in the constructor is
 387 optional.
 388
 389 =item init_arg => Str | Undef
 390
 391 Allows you to use a different key name in the constructor.  If undef, the
 392 attribue can't be passed to the constructor.
 393
 394 =item default => Value | CodeRef
 395
 396 Sets the default value of the attribute. If the default is a coderef, it will
 397 be invoked to get the default value. Due to quirks of Perl, any bare reference
 398 is forbidden, you must wrap the reference in a coderef. Otherwise, all
 399 instances will share the same reference.
 400
 401 =item lazy => 0|1
 402
 403 If specified, the default is calculated on demand instead of in the
 404 constructor.
 405
 406 =item predicate => Str
 407
 408 Lets you specify a method name for installing a predicate method, which checks
 409 that the attribute has a value. It will not invoke a lazy default or builder
 410 method.
 411
 412 =item clearer => Str
 413
 414 Lets you specify a method name for installing a clearer method, which clears
 415 the attribute's value from the instance. On the next read, lazy or builder will
 416 be invoked.
 417
 418 =item handles => HashRef|ArrayRef
 419
 420 Lets you specify methods to delegate to the attribute. ArrayRef forwards the
 421 given method names to method calls on the attribute. HashRef maps local method
 422 names to remote method names called on the attribute. Other forms of
 423 L</handles>, such as regular expression and coderef, are not yet supported.
 424
 425 =item weak_ref => 0|1
 426
 427 Lets you automatically weaken any reference stored in the attribute.
 428
 429 Use of this feature requires L<Scalar::Util>!
 430
 431 =item trigger => CodeRef
 432
 433 Any time the attribute's value is set (either through the accessor or the constructor), the trigger is called on it. The trigger receives as arguments the instance, the new value, and the attribute instance.
 434
 435 Mouse 0.05 supported more complex triggers, but this behavior is now removed.
 436
 437 =item builder => Str
 438
 439 Defines a method name to be called to provide the default value of the
 440 attribute. C<< builder => 'build_foo' >> is mostly equivalent to
 441 C<< default => sub { $_[0]->build_foo } >>.
 442
 443 =item auto_deref => 0|1
 444
 445 Allows you to automatically dereference ArrayRef and HashRef attributes in list
 446 context. In scalar context, the reference is returned (NOT the list length or
 447 bucket status). You must specify an appropriate type constraint to use
 448 auto_deref.
 449
 450 =item lazy_build => 0|1
 451
 452 Automatically define lazy => 1 as well as builder => "_build_$attr", clearer =>
 453 "clear_$attr', predicate => 'has_$attr' unless they are already defined.
 454
 455 =back
 456
 457 =head2 confess error -> BOOM
 458
 459 L<Carp/confess> for your convenience.
 460
 461 =head2 blessed value -> ClassName | undef
 462
 463 L<Scalar::Util/blessed> for your convenience.
 464
 465 =head1 MISC
 466
 467 =head2 import
 468
 469 Importing Mouse will default your class' superclass list to L<Mouse::Object>.
 470 You may use L</extends> to replace the superclass list.
 471
 472 =head2 unimport
 473
 474 Please unimport Mouse (C<no Mouse>) so that if someone calls one of the
 475 keywords (such as L</extends>) it will break loudly instead breaking subtly.
 476
 477 =head1 FUNCTIONS
 478
 479 =head2 load_class Class::Name
 480
 481 This will load a given C<Class::Name> (or die if it's not loadable).
 482 This function can be used in place of tricks like
 483 C<eval "use $module"> or using C<require>.
 484
 485 =head2 is_class_loaded Class::Name -> Bool
 486
 487 Returns whether this class is actually loaded or not. It uses a heuristic which
 488 involves checking for the existence of C<$VERSION>, C<@ISA>, and any
 489 locally-defined method.
 490
 491 =head1 SOURCE CODE ACCESS
 492
 493 We have a public git repo:
 494
 495  git clone git://jules.scsys.co.uk/gitmo/Mouse.git
 496
 497 =head1 AUTHORS
 498
 499 Shawn M Moore, C<< <sartak at gmail.com> >>
 500
 501 Yuval Kogman, C<< <nothingmuch at woobling.org> >>
 502
 503 tokuhirom
 504
 505 Yappo
 506
 507 wu-lee
 508
 509 with plenty of code borrowed from L<Class::MOP> and L<Moose>
 510
 511 =head1 BUGS
 512
 513 There is a known issue with Mouse on 5.6.2 regarding the @ISA tests. Until
 514 this is resolve the minimum version of Perl for Mouse is set to 5.8.0. Patches
 515 to resolve these tests are more than welcome.
 516
 517 Please report any bugs through RT: email
 518 C<bug-mouse at rt.cpan.org>, or browse
 519 L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Mouse>.
 520
 521 =head1 COPYRIGHT AND LICENSE
 522
 523 Copyright 2008-2009 Infinity Interactive, Inc.
 524
 525 http://www.iinteractive.com/
 526
 527 This program is free software; you can redistribute it and/or modify it
 528 under the same terms as Perl itself.
 529
 530 =cut
 531