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