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