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