lib/Mouse.pm

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