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