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