lib/Mouse.pm

   1
   2 package Mouse;
   3 use strict;
   4 use warnings;
   5 use 5.006;
   6 use base 'Exporter';
   7
   8 our $VERSION;
   9 our $PurePerl;
  10
  11 BEGIN {
  12     $VERSION  = '0.12';
  13
  14     if ($ENV{MOUSE_DEBUG}) {
  15         *DEBUG = sub (){ 1 };
  16     } else {
  17         *DEBUG = sub (){ 0 };
  18     }
  19
  20     if (! defined $PurePerl && $ENV{MOUSE_PUREPERL} && $ENV{MOUSE_PUREPERL} =~ /^(.+)$/) {
  21         $PurePerl = $1;
  22     }
  23
  24     if (! $PurePerl) {
  25         local $@;
  26         local $^W = 0;
  27         require XSLoader;
  28         $PurePerl = ! eval{ XSLoader::load(__PACKAGE__, $VERSION); 1 };
  29         warn "Failed to load XS mode: $@" if $@; #  && Mouse::DEBUG();
  30     }
  31 }
  32
  33 use Carp 'confess';
  34 use Mouse::Util 'blessed';
  35
  36 use Mouse::Meta::Attribute;
  37 use Mouse::Meta::Class;
  38 use Mouse::Object;
  39 use Mouse::TypeRegistry;
  40
  41 our @EXPORT = qw(extends has before after around blessed confess with);
  42
  43 sub extends { Mouse::Meta::Class->initialize(caller)->superclasses(@_) }
  44
  45 sub has {
  46     my $meta = Mouse::Meta::Class->initialize(caller);
  47
  48     my $names = shift;
  49     $names = [$names] if !ref($names);
  50
  51     for my $name (@$names) {
  52         if ($name =~ s/^\+//) {
  53             Mouse::Meta::Attribute->clone_parent($meta, $name, @_);
  54         }
  55         else {
  56             Mouse::Meta::Attribute->create($meta, $name, @_);
  57         }
  58     }
  59 }
  60
  61 sub before {
  62     my $meta = Mouse::Meta::Class->initialize(caller);
  63
  64     my $code = pop;
  65
  66     for (@_) {
  67         $meta->add_before_method_modifier($_ => $code);
  68     }
  69 }
  70
  71 sub after {
  72     my $meta = Mouse::Meta::Class->initialize(caller);
  73
  74     my $code = pop;
  75
  76     for (@_) {
  77         $meta->add_after_method_modifier($_ => $code);
  78     }
  79 }
  80
  81 sub around {
  82     my $meta = Mouse::Meta::Class->initialize(caller);
  83
  84     my $code = pop;
  85
  86     for (@_) {
  87         $meta->add_around_method_modifier($_ => $code);
  88     }
  89 }
  90
  91 sub with {
  92     my $meta = Mouse::Meta::Class->initialize(caller);
  93
  94     my $role  = shift;
  95     my $args  = shift || {};
  96
  97     confess "Mouse::Role only supports 'with' on individual roles at a time" if @_ || !ref $args;
  98
  99     Mouse::load_class($role);
 100     $role->meta->apply($meta, %$args);
 101 }
 102
 103 sub import {
 104     strict->import;
 105     warnings->import;
 106
 107     my $caller = caller;
 108
 109     my $meta = Mouse::Meta::Class->initialize($caller);
 110     $meta->superclasses('Mouse::Object')
 111         unless $meta->superclasses;
 112
 113     no strict 'refs';
 114     no warnings 'redefine';
 115     *{$caller.'::meta'} = sub { $meta };
 116
 117     __PACKAGE__->export_to_level( 1, @_);
 118 }
 119
 120 sub unimport {
 121     my $caller = caller;
 122
 123     no strict 'refs';
 124     for my $keyword (@EXPORT) {
 125         delete ${ $caller . '::' }{$keyword};
 126     }
 127 }
 128
 129 sub load_class {
 130     my $class = shift;
 131
 132     if (ref($class) || !defined($class) || !length($class)) {
 133         my $display = defined($class) ? $class : 'undef';
 134         confess "Invalid class name ($display)";
 135     }
 136
 137     return 1 if is_class_loaded($class);
 138
 139     (my $file = "$class.pm") =~ s{::}{/}g;
 140
 141     eval { CORE::require($file) };
 142     confess "Could not load class ($class) because : $@" if $@;
 143
 144     return 1;
 145 }
 146
 147 sub is_class_loaded {
 148     my $class = shift;
 149
 150     return 0 if ref($class) || !defined($class) || !length($class);
 151
 152     # walk the symbol table tree to avoid autovififying
 153     # \*{${main::}{"Foo::"}} == \*main::Foo::
 154
 155     my $pack = \*::;
 156     foreach my $part (split('::', $class)) {
 157         return 0 unless exists ${$$pack}{"${part}::"};
 158         $pack = \*{${$$pack}{"${part}::"}};
 159     }
 160
 161     # check for $VERSION or @ISA
 162     return 1 if exists ${$$pack}{VERSION}
 163              && defined *{${$$pack}{VERSION}}{SCALAR};
 164     return 1 if exists ${$$pack}{ISA}
 165              && defined *{${$$pack}{ISA}}{ARRAY};
 166
 167     # check for any method
 168     foreach ( keys %{$$pack} ) {
 169         next if substr($_, -2, 2) eq '::';
 170         return 1 if defined *{${$$pack}{$_}}{CODE};
 171     }
 172
 173     # fail
 174     return 0;
 175 }
 176
 177 1;
 178
 179 __END__
 180
 181 =head1 NAME
 182
 183 Mouse - Moose minus the antlers
 184
 185 =head1 SYNOPSIS
 186
 187     package Point;
 188     use Mouse; # automatically turns on strict and warnings
 189
 190     has 'x' => (is => 'rw', isa => 'Int');
 191     has 'y' => (is => 'rw', isa => 'Int');
 192
 193     sub clear {
 194         my $self = shift;
 195         $self->x(0);
 196         $self->y(0);
 197     }
 198
 199     package Point3D;
 200     use Mouse;
 201
 202     extends 'Point';
 203
 204     has 'z' => (is => 'rw', isa => 'Int');
 205
 206     after 'clear' => sub {
 207         my $self = shift;
 208         $self->z(0);
 209     };
 210
 211 =head1 DESCRIPTION
 212
 213 L<Moose> is wonderful.
 214
 215 Unfortunately, it's a little slow. Though significant progress has been made
 216 over the years, the compile time penalty is a non-starter for some
 217 applications.
 218
 219 Mouse aims to alleviate this by providing a subset of Moose's
 220 functionality, faster. In particular, L<Moose/has> is missing only a few
 221 expert-level features.
 222
 223 We're also going as light on dependencies as possible. Most functions we use
 224 from L<Scalar::Util> are copied into this dist. L<Scalar::Util> is required if
 225 you'd like weak references; there's simply no way to do it from pure Perl.
 226 L<Class::Method::Modifiers> is required if you want support for L</before>,
 227 L</after>, and L</around>.
 228
 229 =head2 MOOSE COMPAT
 230
 231 Compatibility with Moose has been the utmost concern. Fewer than 1% of the
 232 tests fail when run against Moose instead of Mouse. Mouse code coverage is also
 233 over 96%. Even the error messages are taken from Moose. The Mouse code just
 234 runs the test suite 4x faster.
 235
 236 The idea is that, if you need the extra power, you should be able to run
 237 C<s/Mouse/Moose/g> on your codebase and have nothing break. To that end,
 238 nothingmuch has written L<Squirrel> (part of this distribution) which will act
 239 as Mouse unless Moose is loaded, in which case it will act as Moose.
 240
 241 Mouse also has the blessings of Moose's author, stevan.
 242
 243 =head2 MISSING FEATURES
 244
 245 =head3 Roles
 246
 247 We're working on fixing this one! stevan has suggested an implementation
 248 strategy. Mouse currently ignores methods, so that needs to be fixed next.
 249 Roles that consist entirely of attributes may be usable in this very version.
 250
 251 =head3 Complex types
 252
 253 User-defined type constraints and parameterized types may be implemented. Type
 254 coercions probably not (patches welcome).
 255
 256 =head3 Bootstrapped meta world
 257
 258 Very handy for extensions to the MOP. Not pressing, but would be nice to have.
 259
 260 =head3 Modification of attribute metaclass
 261
 262 When you declare an attribute with L</has>, you get the inlined accessors
 263 installed immediately. Modifying the attribute metaclass, even if possible,
 264 does nothing.
 265
 266 =head3 Lots more..
 267
 268 MouseX?
 269
 270 =head1 KEYWORDS
 271
 272 =head2 meta -> Mouse::Meta::Class
 273
 274 Returns this class' metaclass instance.
 275
 276 =head2 extends superclasses
 277
 278 Sets this class' superclasses.
 279
 280 =head2 before (method|methods) => Code
 281
 282 Installs a "before" method modifier. See L<Moose/before> or
 283 L<Class::Method::Modifiers/before>.
 284
 285 Use of this feature requires L<Class::Method::Modifiers>!
 286
 287 =head2 after (method|methods) => Code
 288
 289 Installs an "after" method modifier. See L<Moose/after> or
 290 L<Class::Method::Modifiers/after>.
 291
 292 Use of this feature requires L<Class::Method::Modifiers>!
 293
 294 =head2 around (method|methods) => Code
 295
 296 Installs an "around" method modifier. See L<Moose/around> or
 297 L<Class::Method::Modifiers/around>.
 298
 299 Use of this feature requires L<Class::Method::Modifiers>!
 300
 301 =head2 has (name|names) => parameters
 302
 303 Adds an attribute (or if passed an arrayref of names, multiple attributes) to
 304 this class. Options:
 305
 306 =over 4
 307
 308 =item is => ro|rw
 309
 310 If specified, inlines a read-only/read-write accessor with the same name as
 311 the attribute.
 312
 313 =item isa => TypeConstraint
 314
 315 Provides basic type checking in the constructor and accessor. Basic types such
 316 as C<Int>, C<ArrayRef>, C<Defined> are supported. Any unknown type is taken to
 317 be a class check (e.g. isa => 'DateTime' would accept only L<DateTime>
 318 objects).
 319
 320 =item required => 0|1
 321
 322 Whether this attribute is required to have a value. If the attribute is lazy or
 323 has a builder, then providing a value for the attribute in the constructor is
 324 optional.
 325
 326 =item init_arg => Str | Undef
 327
 328 Allows you to use a different key name in the constructor.  If undef, the
 329 attribue can't be passed to the constructor.
 330
 331 =item default => Value | CodeRef
 332
 333 Sets the default value of the attribute. If the default is a coderef, it will
 334 be invoked to get the default value. Due to quirks of Perl, any bare reference
 335 is forbidden, you must wrap the reference in a coderef. Otherwise, all
 336 instances will share the same reference.
 337
 338 =item lazy => 0|1
 339
 340 If specified, the default is calculated on demand instead of in the
 341 constructor.
 342
 343 =item predicate => Str
 344
 345 Lets you specify a method name for installing a predicate method, which checks
 346 that the attribute has a value. It will not invoke a lazy default or builder
 347 method.
 348
 349 =item clearer => Str
 350
 351 Lets you specify a method name for installing a clearer method, which clears
 352 the attribute's value from the instance. On the next read, lazy or builder will
 353 be invoked.
 354
 355 =item handles => HashRef|ArrayRef
 356
 357 Lets you specify methods to delegate to the attribute. ArrayRef forwards the
 358 given method names to method calls on the attribute. HashRef maps local method
 359 names to remote method names called on the attribute. Other forms of
 360 L</handles>, such as regular expression and coderef, are not yet supported.
 361
 362 =item weak_ref => 0|1
 363
 364 Lets you automatically weaken any reference stored in the attribute.
 365
 366 Use of this feature requires L<Scalar::Util>!
 367
 368 =item trigger => CodeRef
 369
 370 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.
 371
 372 Mouse 0.05 supported more complex triggers, but this behavior is now removed.
 373
 374 =item builder => Str
 375
 376 Defines a method name to be called to provide the default value of the
 377 attribute. C<< builder => 'build_foo' >> is mostly equivalent to
 378 C<< default => sub { $_[0]->build_foo } >>.
 379
 380 =item auto_deref => 0|1
 381
 382 Allows you to automatically dereference ArrayRef and HashRef attributes in list
 383 context. In scalar context, the reference is returned (NOT the list length or
 384 bucket status). You must specify an appropriate type constraint to use
 385 auto_deref.
 386
 387 =item lazy_build => 0|1
 388
 389 Automatically define lazy => 1 as well as builder => "_build_$attr", clearer =>
 390 "clear_$attr', predicate => 'has_$attr' unless they are already defined.
 391
 392 =back
 393
 394 =head2 confess error -> BOOM
 395
 396 L<Carp/confess> for your convenience.
 397
 398 =head2 blessed value -> ClassName | undef
 399
 400 L<Scalar::Util/blessed> for your convenience.
 401
 402 =head1 MISC
 403
 404 =head2 import
 405
 406 Importing Mouse will default your class' superclass list to L<Mouse::Object>.
 407 You may use L</extends> to replace the superclass list.
 408
 409 =head2 unimport
 410
 411 Please unimport Mouse (C<no Mouse>) so that if someone calls one of the
 412 keywords (such as L</extends>) it will break loudly instead breaking subtly.
 413
 414 =head1 FUNCTIONS
 415
 416 =head2 load_class Class::Name
 417
 418 This will load a given C<Class::Name> (or die if it's not loadable).
 419 This function can be used in place of tricks like
 420 C<eval "use $module"> or using C<require>.
 421
 422 =head2 is_class_loaded Class::Name -> Bool
 423
 424 Returns whether this class is actually loaded or not. It uses a heuristic which
 425 involves checking for the existence of C<$VERSION>, C<@ISA>, and any
 426 locally-defined method.
 427
 428 =head1 AUTHOR
 429
 430 Shawn M Moore, C<< <sartak at gmail.com> >>
 431
 432 Yuval Kogman, C<< <nothingmuch at woobling.org> >>
 433
 434 with plenty of code borrowed from L<Class::MOP> and L<Moose>
 435
 436 =head1 BUGS
 437
 438 No known bugs.
 439
 440 Please report any bugs through RT: email
 441 C<bug-mouse at rt.cpan.org>, or browse
 442 L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Mouse>.
 443
 444 =head1 COPYRIGHT AND LICENSE
 445
 446 Copyright 2008 Shawn M Moore.
 447
 448 This program is free software; you can redistribute it and/or modify it
 449 under the same terms as Perl itself.
 450
 451 =cut
 452