lib/Mouse.pm

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