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 COMPATIBILITY
 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 C<< $object->meta -> Mouse::Meta::Class >>
 285
 286 Returns this class' metaclass instance.
 287
 288 =head2 C<< extends superclasses >>
 289
 290 Sets this class' superclasses.
 291
 292 =head2 C<< before (method|methods) => CodeRef >>
 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 C<< after (method|methods) => CodeRef >>
 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 C<< around (method|methods) => CodeRef >>
 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 C<< 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 C<< is => ro|rw|bare >>
 321
 322 If specified, inlines a read-only/read-write accessor with the same name as
 323 the attribute.
 324
 325 =item C<< 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
 329 (e.g. C<< isa => '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 C<< required => Bool >>
 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 C<< init_arg => Str | Undef >>
 345
 346 Allows you to use a different key name in the constructor.  If undef, the
 347 attribute can't be passed to the constructor.
 348
 349 =item C<< 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 C<< lazy => Bool >>
 357
 358 If specified, the default is calculated on demand instead of in the
 359 constructor.
 360
 361 =item C<< 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 C<< 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 C<< 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 C<< weak_ref => Bool >>
 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 C<< 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 =item C<< builder => Str >>
 391
 392 Defines a method name to be called to provide the default value of the
 393 attribute. C<< builder => 'build_foo' >> is mostly equivalent to
 394 C<< default => sub { $_[0]->build_foo } >>.
 395
 396 =item C<< auto_deref => Bool >>
 397
 398 Allows you to automatically dereference ArrayRef and HashRef attributes in list
 399 context. In scalar context, the reference is returned (NOT the list length or
 400 bucket status). You must specify an appropriate type constraint to use
 401 auto_deref.
 402
 403 =item C<< lazy_build => Bool >>
 404
 405 Automatically define the following options:
 406
 407     has $attr => (
 408         # ...
 409         lazy      => 1
 410         builder   => "_build_$attr",
 411         clearer   => "clear_$attr",
 412         predicate => "has_$attr",
 413     );
 414
 415 =back
 416
 417 =head2 C<< confess(message) -> BOOM >>
 418
 419 L<Carp/confess> for your convenience.
 420
 421 =head2 C<< blessed(value) -> ClassName | undef >>
 422
 423 L<Scalar::Util/blessed> for your convenience.
 424
 425 =head1 MISC
 426
 427 =head2 import
 428
 429 Importing Mouse will default your class' superclass list to L<Mouse::Object>.
 430 You may use L</extends> to replace the superclass list.
 431
 432 =head2 unimport
 433
 434 Please unimport Mouse (C<no Mouse>) so that if someone calls one of the
 435 keywords (such as L</extends>) it will break loudly instead breaking subtly.
 436
 437 =head1 SOURCE CODE ACCESS
 438
 439 We have a public git repository:
 440
 441  git clone git://jules.scsys.co.uk/gitmo/Mouse.git
 442
 443 =head1 DEPENDENCIES
 444
 445 Perl 5.6.2 or later.
 446
 447 =head1 SEE ALSO
 448
 449 L<Moose>
 450
 451 L<Class::MOP>
 452
 453 =head1 AUTHORS
 454
 455 Shawn M Moore, C<< <sartak at gmail.com> >>
 456
 457 Yuval Kogman, C<< <nothingmuch at woobling.org> >>
 458
 459 tokuhirom
 460
 461 Yappo
 462
 463 wu-lee
 464
 465 Goro Fuji (gfx) C<< <gfuji at cpan.org> >>
 466
 467 with plenty of code borrowed from L<Class::MOP> and L<Moose>
 468
 469 =head1 BUGS
 470
 471 All complex software has bugs lurking in it, and this module is no exception.
 472 Please report any bugs to C<bug-mouse at rt.cpan.org>, or through the web
 473 interface at L<http://rt.cpan.org/Public/Dist/Display.html?Name=Mouse>
 474
 475 =head1 COPYRIGHT AND LICENSE
 476
 477 Copyright 2008-2009 Infinity Interactive, Inc.
 478
 479 http://www.iinteractive.com/
 480
 481 This program is free software; you can redistribute it and/or modify it
 482 under the same terms as Perl itself.
 483
 484 =cut
 485