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