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