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 =head2 Maintenance
 279
 280 The original author of this module has mostly stepped down from maintaining
 281 Mouse. See L<http://www.nntp.perl.org/group/perl.moose/2009/04/msg653.html>.
 282 If you would like to help maintain this module, please get in touch with us.
 283
 284 =head1 KEYWORDS
 285
 286 =head2 C<< $object->meta -> Mouse::Meta::Class >>
 287
 288 Returns this class' metaclass instance.
 289
 290 =head2 C<< extends superclasses >>
 291
 292 Sets this class' superclasses.
 293
 294 =head2 C<< before (method|methods) => CodeRef >>
 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 C<< after (method|methods) => CodeRef >>
 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 C<< around (method|methods) => CodeRef >>
 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 C<< 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 C<< is => ro|rw|bare >>
 323
 324 If specified, inlines a read-only/read-write accessor with the same name as
 325 the attribute.
 326
 327 =item C<< isa => TypeConstraint >>
 328
 329 Provides type checking in the constructor and accessor. The following types are
 330 supported. Any unknown type is taken to be a class check
 331 (e.g. C<< isa => 'DateTime' >> would accept only L<DateTime> objects).
 332
 333     Any Item Bool Undef Defined Value Num Int Str ClassName
 334     Ref ScalarRef ArrayRef HashRef CodeRef RegexpRef GlobRef
 335     FileHandle Object
 336
 337 For more documentation on type constraints, see L<Mouse::Util::TypeConstraints>.
 338
 339
 340 =item C<< required => Bool >>
 341
 342 Whether this attribute is required to have a value. If the attribute is lazy or
 343 has a builder, then providing a value for the attribute in the constructor is
 344 optional.
 345
 346 =item C<< init_arg => Str | Undef >>
 347
 348 Allows you to use a different key name in the constructor.  If undef, the
 349 attribute can't be passed to the constructor.
 350
 351 =item C<< default => Value | CodeRef >>
 352
 353 Sets the default value of the attribute. If the default is a coderef, it will
 354 be invoked to get the default value. Due to quirks of Perl, any bare reference
 355 is forbidden, you must wrap the reference in a coderef. Otherwise, all
 356 instances will share the same reference.
 357
 358 =item C<< lazy => Bool >>
 359
 360 If specified, the default is calculated on demand instead of in the
 361 constructor.
 362
 363 =item C<< predicate => Str >>
 364
 365 Lets you specify a method name for installing a predicate method, which checks
 366 that the attribute has a value. It will not invoke a lazy default or builder
 367 method.
 368
 369 =item C<< clearer => Str >>
 370
 371 Lets you specify a method name for installing a clearer method, which clears
 372 the attribute's value from the instance. On the next read, lazy or builder will
 373 be invoked.
 374
 375 =item C<< handles => HashRef|ArrayRef >>
 376
 377 Lets you specify methods to delegate to the attribute. ArrayRef forwards the
 378 given method names to method calls on the attribute. HashRef maps local method
 379 names to remote method names called on the attribute. Other forms of
 380 L</handles>, such as regular expression and coderef, are not yet supported.
 381
 382 =item C<< weak_ref => Bool >>
 383
 384 Lets you automatically weaken any reference stored in the attribute.
 385
 386 Use of this feature requires L<Scalar::Util>!
 387
 388 =item C<< trigger => CodeRef >>
 389
 390 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.
 391
 392 =item C<< builder => Str >>
 393
 394 Defines a method name to be called to provide the default value of the
 395 attribute. C<< builder => 'build_foo' >> is mostly equivalent to
 396 C<< default => sub { $_[0]->build_foo } >>.
 397
 398 =item C<< auto_deref => Bool >>
 399
 400 Allows you to automatically dereference ArrayRef and HashRef attributes in list
 401 context. In scalar context, the reference is returned (NOT the list length or
 402 bucket status). You must specify an appropriate type constraint to use
 403 auto_deref.
 404
 405 =item C<< lazy_build => Bool >>
 406
 407 Automatically define the following options:
 408
 409     has $attr => (
 410         # ...
 411         lazy      => 1
 412         builder   => "_build_$attr",
 413         clearer   => "clear_$attr",
 414         predicate => "has_$attr",
 415     );
 416
 417 =back
 418
 419 =head2 C<< confess(message) -> BOOM >>
 420
 421 L<Carp/confess> for your convenience.
 422
 423 =head2 C<< blessed(value) -> ClassName | undef >>
 424
 425 L<Scalar::Util/blessed> for your convenience.
 426
 427 =head1 MISC
 428
 429 =head2 import
 430
 431 Importing Mouse will default your class' superclass list to L<Mouse::Object>.
 432 You may use L</extends> to replace the superclass list.
 433
 434 =head2 unimport
 435
 436 Please unimport Mouse (C<no Mouse>) so that if someone calls one of the
 437 keywords (such as L</extends>) it will break loudly instead breaking subtly.
 438
 439 =head1 SOURCE CODE ACCESS
 440
 441 We have a public git repository:
 442
 443  git clone git://jules.scsys.co.uk/gitmo/Mouse.git
 444
 445 =head1 DEPENDENCIES
 446
 447 Perl 5.6.2 or later.
 448
 449 =head1 SEE ALSO
 450
 451 L<Moose>
 452
 453 L<Class::MOP>
 454
 455 =head1 AUTHORS
 456
 457 Shawn M Moore, E<lt>sartak at gmail.comE<gt>
 458
 459 Yuval Kogman, E<lt>nothingmuch at woobling.orgE<gt>
 460
 461 tokuhirom
 462
 463 Yappo
 464
 465 wu-lee
 466
 467 Goro Fuji (gfx) E<lt>gfuji at cpan.orgE<gt>
 468
 469 with plenty of code borrowed from L<Class::MOP> and L<Moose>
 470
 471 =head1 BUGS
 472
 473 All complex software has bugs lurking in it, and this module is no exception.
 474 Please report any bugs to C<bug-mouse at rt.cpan.org>, or through the web
 475 interface at L<http://rt.cpan.org/Public/Dist/Display.html?Name=Mouse>
 476
 477 =head1 COPYRIGHT AND LICENSE
 478
 479 Copyright 2008-2009 Infinity Interactive, Inc.
 480
 481 http://www.iinteractive.com/
 482
 483 This program is free software; you can redistribute it and/or modify it
 484 under the same terms as Perl itself.
 485
 486 =cut
 487