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.
 231
 232 Unfortunately, it's a little slow. Though significant progress has been made
 233 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
 237 functionality, faster. In particular, L<Moose/has> is missing only a few
 238 expert-level features.
 239
 240 We're also going as light on dependencies as possible.
 241 L<Class::Method::Modifiers> or L<Data::Util> is required if you want support
 242 for L</before>, L</after>, and L</around>.
 243
 244 =head2 MOOSE COMPAT
 245
 246 Compatibility with Moose has been the utmost concern. Fewer than 1% of the
 247 tests fail when run against Moose instead of Mouse. Mouse code coverage is also
 248 over 96%. Even the error messages are taken from Moose. The Mouse code just
 249 runs the test suite 4x faster.
 250
 251 The idea is that, if you need the extra power, you should be able to run
 252 C<s/Mouse/Moose/g> on your codebase and have nothing break. To that end,
 253 nothingmuch has written L<Squirrel> (part of this distribution) which will act
 254 as Mouse unless Moose is loaded, in which case it will act as Moose.
 255 L<Any::Moose> is a more high-tech L<Squirrel>.
 256
 257 =head2 MouseX
 258
 259 Please don't copy MooseX code to MouseX. If you need extensions, you really
 260 should upgrade to Moose. We don't need two parallel sets of extensions!
 261
 262 If you really must write a Mouse extension, please contact the Moose mailing
 263 list or #moose on IRC beforehand.
 264
 265 =head1 KEYWORDS
 266
 267 =head2 meta -> Mouse::Meta::Class
 268
 269 Returns this class' metaclass instance.
 270
 271 =head2 extends superclasses
 272
 273 Sets this class' superclasses.
 274
 275 =head2 before (method|methods) => Code
 276
 277 Installs a "before" method modifier. See L<Moose/before> or
 278 L<Class::Method::Modifiers/before>.
 279
 280 Use of this feature requires L<Class::Method::Modifiers>!
 281
 282 =head2 after (method|methods) => Code
 283
 284 Installs an "after" method modifier. See L<Moose/after> or
 285 L<Class::Method::Modifiers/after>.
 286
 287 Use of this feature requires L<Class::Method::Modifiers>!
 288
 289 =head2 around (method|methods) => Code
 290
 291 Installs an "around" method modifier. See L<Moose/around> or
 292 L<Class::Method::Modifiers/around>.
 293
 294 Use of this feature requires L<Class::Method::Modifiers>!
 295
 296 =head2 has (name|names) => parameters
 297
 298 Adds an attribute (or if passed an arrayref of names, multiple attributes) to
 299 this class. Options:
 300
 301 =over 4
 302
 303 =item is => ro|rw
 304
 305 If specified, inlines a read-only/read-write accessor with the same name as
 306 the attribute.
 307
 308 =item isa => TypeConstraint
 309
 310 Provides basic type checking in the constructor and accessor. Basic types such
 311 as C<Int>, C<ArrayRef>, C<Defined> are supported. Any unknown type is taken to
 312 be a class check (e.g. isa => 'DateTime' would accept only L<DateTime>
 313 objects).
 314
 315 =item required => 0|1
 316
 317 Whether this attribute is required to have a value. If the attribute is lazy or
 318 has a builder, then providing a value for the attribute in the constructor is
 319 optional.
 320
 321 =item init_arg => Str | Undef
 322
 323 Allows you to use a different key name in the constructor.  If undef, the
 324 attribue can't be passed to the constructor.
 325
 326 =item default => Value | CodeRef
 327
 328 Sets the default value of the attribute. If the default is a coderef, it will
 329 be invoked to get the default value. Due to quirks of Perl, any bare reference
 330 is forbidden, you must wrap the reference in a coderef. Otherwise, all
 331 instances will share the same reference.
 332
 333 =item lazy => 0|1
 334
 335 If specified, the default is calculated on demand instead of in the
 336 constructor.
 337
 338 =item predicate => Str
 339
 340 Lets you specify a method name for installing a predicate method, which checks
 341 that the attribute has a value. It will not invoke a lazy default or builder
 342 method.
 343
 344 =item clearer => Str
 345
 346 Lets you specify a method name for installing a clearer method, which clears
 347 the attribute's value from the instance. On the next read, lazy or builder will
 348 be invoked.
 349
 350 =item handles => HashRef|ArrayRef
 351
 352 Lets you specify methods to delegate to the attribute. ArrayRef forwards the
 353 given method names to method calls on the attribute. HashRef maps local method
 354 names to remote method names called on the attribute. Other forms of
 355 L</handles>, such as regular expression and coderef, are not yet supported.
 356
 357 =item weak_ref => 0|1
 358
 359 Lets you automatically weaken any reference stored in the attribute.
 360
 361 Use of this feature requires L<Scalar::Util>!
 362
 363 =item trigger => CodeRef
 364
 365 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.
 366
 367 Mouse 0.05 supported more complex triggers, but this behavior is now removed.
 368
 369 =item builder => Str
 370
 371 Defines a method name to be called to provide the default value of the
 372 attribute. C<< builder => 'build_foo' >> is mostly equivalent to
 373 C<< default => sub { $_[0]->build_foo } >>.
 374
 375 =item auto_deref => 0|1
 376
 377 Allows you to automatically dereference ArrayRef and HashRef attributes in list
 378 context. In scalar context, the reference is returned (NOT the list length or
 379 bucket status). You must specify an appropriate type constraint to use
 380 auto_deref.
 381
 382 =item lazy_build => 0|1
 383
 384 Automatically define lazy => 1 as well as builder => "_build_$attr", clearer =>
 385 "clear_$attr', predicate => 'has_$attr' unless they are already defined.
 386
 387 =back
 388
 389 =head2 confess error -> BOOM
 390
 391 L<Carp/confess> for your convenience.
 392
 393 =head2 blessed value -> ClassName | undef
 394
 395 L<Scalar::Util/blessed> for your convenience.
 396
 397 =head1 MISC
 398
 399 =head2 import
 400
 401 Importing Mouse will default your class' superclass list to L<Mouse::Object>.
 402 You may use L</extends> to replace the superclass list.
 403
 404 =head2 unimport
 405
 406 Please unimport Mouse (C<no Mouse>) so that if someone calls one of the
 407 keywords (such as L</extends>) it will break loudly instead breaking subtly.
 408
 409 =head1 FUNCTIONS
 410
 411 =head2 load_class Class::Name
 412
 413 This will load a given C<Class::Name> (or die if it's not loadable).
 414 This function can be used in place of tricks like
 415 C<eval "use $module"> or using C<require>.
 416
 417 =head2 is_class_loaded Class::Name -> Bool
 418
 419 Returns whether this class is actually loaded or not. It uses a heuristic which
 420 involves checking for the existence of C<$VERSION>, C<@ISA>, and any
 421 locally-defined method.
 422
 423 =head1 AUTHORS
 424
 425 Shawn M Moore, C<< <sartak at gmail.com> >>
 426
 427 Yuval Kogman, C<< <nothingmuch at woobling.org> >>
 428
 429 tokuhirom
 430
 431 Yappo
 432
 433 wu-lee
 434
 435 with plenty of code borrowed from L<Class::MOP> and L<Moose>
 436
 437 =head1 BUGS
 438
 439 No known bugs.
 440
 441 Please report any bugs through RT: email
 442 C<bug-mouse at rt.cpan.org>, or browse
 443 L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Mouse>.
 444
 445 =head1 COPYRIGHT AND LICENSE
 446
 447 Copyright 2008 Shawn M Moore.
 448
 449 This program is free software; you can redistribute it and/or modify it
 450 under the same terms as Perl itself.
 451
 452 =cut
 453