lib/Mouse.pm

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