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.22';
   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 type checking in the constructor and accessor. The following types are
 309 supported. Any unknown type is taken to be a class check (e.g. isa =>
 310 'DateTime' would accept only L<DateTime> objects).
 311
 312     Any Item Bool Undef Defined Value Num Int Str ClassName
 313     Ref ScalarRef ArrayRef HashRef CodeRef RegexpRef GlobRef
 314     FileHandle Object
 315
 316 For more documentation on type constraints, see L<Mouse::Util::TypeConstraints>.
 317
 318
 319 =item required => 0|1
 320
 321 Whether this attribute is required to have a value. If the attribute is lazy or
 322 has a builder, then providing a value for the attribute in the constructor is
 323 optional.
 324
 325 =item init_arg => Str | Undef
 326
 327 Allows you to use a different key name in the constructor.  If undef, the
 328 attribue can't be passed to the constructor.
 329
 330 =item default => Value | CodeRef
 331
 332 Sets the default value of the attribute. If the default is a coderef, it will
 333 be invoked to get the default value. Due to quirks of Perl, any bare reference
 334 is forbidden, you must wrap the reference in a coderef. Otherwise, all
 335 instances will share the same reference.
 336
 337 =item lazy => 0|1
 338
 339 If specified, the default is calculated on demand instead of in the
 340 constructor.
 341
 342 =item predicate => Str
 343
 344 Lets you specify a method name for installing a predicate method, which checks
 345 that the attribute has a value. It will not invoke a lazy default or builder
 346 method.
 347
 348 =item clearer => Str
 349
 350 Lets you specify a method name for installing a clearer method, which clears
 351 the attribute's value from the instance. On the next read, lazy or builder will
 352 be invoked.
 353
 354 =item handles => HashRef|ArrayRef
 355
 356 Lets you specify methods to delegate to the attribute. ArrayRef forwards the
 357 given method names to method calls on the attribute. HashRef maps local method
 358 names to remote method names called on the attribute. Other forms of
 359 L</handles>, such as regular expression and coderef, are not yet supported.
 360
 361 =item weak_ref => 0|1
 362
 363 Lets you automatically weaken any reference stored in the attribute.
 364
 365 Use of this feature requires L<Scalar::Util>!
 366
 367 =item trigger => CodeRef
 368
 369 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.
 370
 371 Mouse 0.05 supported more complex triggers, but this behavior is now removed.
 372
 373 =item builder => Str
 374
 375 Defines a method name to be called to provide the default value of the
 376 attribute. C<< builder => 'build_foo' >> is mostly equivalent to
 377 C<< default => sub { $_[0]->build_foo } >>.
 378
 379 =item auto_deref => 0|1
 380
 381 Allows you to automatically dereference ArrayRef and HashRef attributes in list
 382 context. In scalar context, the reference is returned (NOT the list length or
 383 bucket status). You must specify an appropriate type constraint to use
 384 auto_deref.
 385
 386 =item lazy_build => 0|1
 387
 388 Automatically define lazy => 1 as well as builder => "_build_$attr", clearer =>
 389 "clear_$attr', predicate => 'has_$attr' unless they are already defined.
 390
 391 =back
 392
 393 =head2 confess error -> BOOM
 394
 395 L<Carp/confess> for your convenience.
 396
 397 =head2 blessed value -> ClassName | undef
 398
 399 L<Scalar::Util/blessed> for your convenience.
 400
 401 =head1 MISC
 402
 403 =head2 import
 404
 405 Importing Mouse will default your class' superclass list to L<Mouse::Object>.
 406 You may use L</extends> to replace the superclass list.
 407
 408 =head2 unimport
 409
 410 Please unimport Mouse (C<no Mouse>) so that if someone calls one of the
 411 keywords (such as L</extends>) it will break loudly instead breaking subtly.
 412
 413 =head1 FUNCTIONS
 414
 415 =head2 load_class Class::Name
 416
 417 This will load a given C<Class::Name> (or die if it's not loadable).
 418 This function can be used in place of tricks like
 419 C<eval "use $module"> or using C<require>.
 420
 421 =head2 is_class_loaded Class::Name -> Bool
 422
 423 Returns whether this class is actually loaded or not. It uses a heuristic which
 424 involves checking for the existence of C<$VERSION>, C<@ISA>, and any
 425 locally-defined method.
 426
 427 =head1 SOURCE CODE ACCESS
 428
 429 We have a public git repo:
 430
 431  git clone git://jules.scsys.co.uk/gitmo/Mouse.git
 432
 433 =head1 AUTHORS
 434
 435 Shawn M Moore, C<< <sartak at gmail.com> >>
 436
 437 Yuval Kogman, C<< <nothingmuch at woobling.org> >>
 438
 439 tokuhirom
 440
 441 Yappo
 442
 443 wu-lee
 444
 445 with plenty of code borrowed from L<Class::MOP> and L<Moose>
 446
 447 =head1 BUGS
 448
 449 No known bugs.
 450
 451 Please report any bugs through RT: email
 452 C<bug-mouse at rt.cpan.org>, or browse
 453 L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Mouse>.
 454
 455 =head1 COPYRIGHT AND LICENSE
 456
 457 Copyright 2008 Shawn M Moore.
 458
 459 This program is free software; you can redistribute it and/or modify it
 460 under the same terms as Perl itself.
 461
 462 =cut
 463