lib/Mouse.pm

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