lib/Mouse.pm

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