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