lib/Mouse.pm

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