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