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