lib/Mouse.pm

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