lib/Mouse.pm

   1 #!perl
   2 package Mouse;
   3 use strict;
   4 use warnings;
   5
   6 our $VERSION = '0.05';
   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 99%. 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 Fixing this one slightly less soon. stevan has suggested an implementation
 232 strategy. Mouse currently mostly ignores methods.
 233
 234 =head3 Complex types
 235
 236 User-defined type constraints and parameterized types may be implemented. Type
 237 coercions probably not (patches welcome).
 238
 239 =head3 Bootstrapped meta world
 240
 241 Very handy for extensions to the MOP. Not pressing, but would be nice to have.
 242
 243 =head3 Modification of attribute metaclass
 244
 245 When you declare an attribute with L</has>, you get the inlined accessors
 246 installed immediately. Modifying the attribute metaclass, even if possible,
 247 does nothing.
 248
 249 =head3 Lots more..
 250
 251 MouseX?
 252
 253 =head1 KEYWORDS
 254
 255 =head2 meta -> Mouse::Meta::Class
 256
 257 Returns this class' metaclass instance.
 258
 259 =head2 extends superclasses
 260
 261 Sets this class' superclasses.
 262
 263 =head2 before (method|methods) => Code
 264
 265 Installs a "before" method modifier. See L<Moose/before> or
 266 L<Class::Method::Modifiers/before>.
 267
 268 =head2 after (method|methods) => Code
 269
 270 Installs an "after" method modifier. See L<Moose/after> or
 271 L<Class::Method::Modifiers/after>.
 272
 273 =head2 around (method|methods) => Code
 274
 275 Installs an "around" method modifier. See L<Moose/around> or
 276 L<Class::Method::Modifiers/around>.
 277
 278 =head2 has (name|names) => parameters
 279
 280 Adds an attribute (or if passed an arrayref of names, multiple attributes) to
 281 this class. Options:
 282
 283 =over 4
 284
 285 =item is => ro|rw
 286
 287 If specified, inlines a read-only/read-write accessor with the same name as
 288 the attribute.
 289
 290 =item isa => TypeConstraint
 291
 292 Provides basic type checking in the constructor and accessor. Basic types such
 293 as C<Int>, C<ArrayRef>, C<Defined> are supported. Any unknown type is taken to
 294 be a class check (e.g. isa => 'DateTime' would accept only L<DateTime>
 295 objects).
 296
 297 =item required => 0|1
 298
 299 Whether this attribute is required to have a value. If the attribute is lazy or
 300 has a builder, then providing a value for the attribute in the constructor is
 301 optional.
 302
 303 =item init_arg => Str
 304
 305 Allows you to use a different key name in the constructor.
 306
 307 =item default => Value | CodeRef
 308
 309 Sets the default value of the attribute. If the default is a coderef, it will
 310 be invoked to get the default value. Due to quirks of Perl, any bare reference
 311 is forbidden, you must wrap the reference in a coderef. Otherwise, all
 312 instances will share the same reference.
 313
 314 =item lazy => 0|1
 315
 316 If specified, the default is calculated on demand instead of in the
 317 constructor.
 318
 319 =item predicate => Str
 320
 321 Lets you specify a method name for installing a predicate method, which checks
 322 that the attribute has a value. It will not invoke a lazy default or builder
 323 method.
 324
 325 =item clearer => Str
 326
 327 Lets you specify a method name for installing a clearer method, which clears
 328 the attribute's value from the instance. On the next read, lazy or builder will
 329 be invoked.
 330
 331 =item handles => HashRef|ArrayRef
 332
 333 Lets you specify methods to delegate to the attribute. ArrayRef forwards the
 334 given method names to method calls on the attribute. HashRef maps local method
 335 names to remote method names called on the attribute. Other forms of
 336 L</handles>, such as regular expression and coderef, are not yet supported.
 337
 338 =item weak_ref => 0|1
 339
 340 Lets you automatically weaken any reference stored in the attribute.
 341
 342 =item trigger => CodeRef | HashRef
 343
 344 Triggers are like method modifiers for setting attribute values. You can have
 345 a "before" and an "after" trigger, each of which receive as arguments the instance, the new value, and the attribute metaclass. Historically, triggers have
 346 only been "after" modifiers, so if you use a coderef for the C<trigger> option,
 347 it will maintain that compatibility. Like method modifiers, you can't really
 348 affect the act of setting the attribute value, and the return values of the
 349 modifiers are ignored.
 350
 351 There's also an "around" trigger which you can use to change the value that
 352 is being set on the attribute, or even prevent the attribute from being
 353 updated. The around trigger receives as arguments a code reference to invoke
 354 to set the attribute's value (which expects as arguments the instance and
 355 the new value), the instance, the new value, and the attribute metaclass.
 356
 357 =item builder => Str
 358
 359 Defines a method name to be called to provide the default value of the
 360 attribute. C<< builder => 'build_foo' >> is mostly equivalent to
 361 C<< default => sub { $_[0]->build_foo } >>.
 362
 363 =item auto_deref => 0|1
 364
 365 Allows you to automatically dereference ArrayRef and HashRef attributes in list
 366 context. In scalar context, the reference is returned (NOT the list length or
 367 bucket status). You must specify an appropriate type constraint to use
 368 auto_deref.
 369
 370 =back
 371
 372 =head2 confess error -> BOOM
 373
 374 L<Carp/confess> for your convenience.
 375
 376 =head2 blessed value -> ClassName | undef
 377
 378 L<Scalar::Util/blessed> for your convenience.
 379
 380 =head1 MISC
 381
 382 =head2 import
 383
 384 Importing Mouse will default your class' superclass list to L<Mouse::Object>.
 385 You may use L</extends> to replace the superclass list.
 386
 387 =head2 unimport
 388
 389 Please unimport Mouse (C<no Mouse>) so that if someone calls one of the
 390 keywords (such as L</extends>) it will break loudly instead breaking subtly.
 391
 392 =head1 FUNCTIONS
 393
 394 =head2 load_class Class::Name
 395
 396 This will load a given C<Class::Name> (or die if it's not loadable).
 397 This function can be used in place of tricks like
 398 C<eval "use $module"> or using C<require>.
 399
 400 =head2 is_class_loaded Class::Name -> Bool
 401
 402 Returns whether this class is actually loaded or not. It uses a heuristic which
 403 involves checking for the existence of C<$VERSION>, C<@ISA>, and any
 404 locally-defined method.
 405
 406 =head1 AUTHOR
 407
 408 Shawn M Moore, C<< <sartak at gmail.com> >>
 409
 410 with plenty of code borrowed from L<Class::MOP> and L<Moose>
 411
 412 =head1 BUGS
 413
 414 No known bugs.
 415
 416 Please report any bugs through RT: email
 417 C<bug-mouse at rt.cpan.org>, or browse
 418 L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Mouse>.
 419
 420 =head1 COPYRIGHT AND LICENSE
 421
 422 Copyright 2008 Shawn M Moore.
 423
 424 This program is free software; you can redistribute it and/or modify it
 425 under the same terms as Perl itself.
 426
 427 =cut
 428