Note enum and override/super implementations in Changes
[gitmo/Mouse.git] / lib / Mouse.pm
1 package Mouse;
2 use strict;
3 use warnings;
4 use 5.006;
5 use base 'Exporter';
6
7 our $VERSION = '0.15';
8
9 BEGIN {
10     if ($ENV{MOUSE_DEBUG}) {
11         *DEBUG = sub (){ 1 };
12     } else {
13         *DEBUG = sub (){ 0 };
14     }
15 }
16
17 use Carp 'confess';
18 use Scalar::Util 'blessed';
19 use Mouse::Util;
20
21 use Mouse::Meta::Attribute;
22 use Mouse::Meta::Class;
23 use Mouse::Object;
24 use Mouse::Util::TypeConstraints;
25
26 our @EXPORT = qw(extends has before after around override super blessed confess with);
27
28 sub extends { Mouse::Meta::Class->initialize(caller)->superclasses(@_) }
29
30 sub has {
31     my $meta = Mouse::Meta::Class->initialize(caller);
32
33     my $names = shift;
34     $names = [$names] if !ref($names);
35
36     for my $name (@$names) {
37         if ($name =~ s/^\+//) {
38             Mouse::Meta::Attribute->clone_parent($meta, $name, @_);
39         }
40         else {
41             Mouse::Meta::Attribute->create($meta, $name, @_);
42         }
43     }
44 }
45
46 sub before {
47     my $meta = Mouse::Meta::Class->initialize(caller);
48
49     my $code = pop;
50
51     for (@_) {
52         $meta->add_before_method_modifier($_ => $code);
53     }
54 }
55
56 sub after {
57     my $meta = Mouse::Meta::Class->initialize(caller);
58
59     my $code = pop;
60
61     for (@_) {
62         $meta->add_after_method_modifier($_ => $code);
63     }
64 }
65
66 sub around {
67     my $meta = Mouse::Meta::Class->initialize(caller);
68
69     my $code = pop;
70
71     for (@_) {
72         $meta->add_around_method_modifier($_ => $code);
73     }
74 }
75
76 sub with {
77     Mouse::Util::apply_all_roles((caller)[0], @_);
78 }
79
80 our $SUPER_PACKAGE;
81 our $SUPER_BODY;
82 our @SUPER_ARGS;
83
84 sub super {
85     # This check avoids a recursion loop - see
86     # t/100_bugs/020_super_recursion.t
87     return if defined $SUPER_PACKAGE && $SUPER_PACKAGE ne caller();
88     return unless $SUPER_BODY; $SUPER_BODY->(@SUPER_ARGS);
89 }
90
91 sub override {
92     my $meta = Mouse::Meta::Class->initialize(caller);
93     my $pkg = $meta->name;
94
95     my $name = shift;
96     my $code = shift;
97
98     my $body = $pkg->can($name)
99         or confess "You cannot override '$name' because it has no super method";
100
101     $meta->add_method($name => sub {
102         local $SUPER_PACKAGE = $pkg;
103         local @SUPER_ARGS = @_;
104         local $SUPER_BODY = $body;
105
106         $code->(@_);
107     });
108 }
109
110 sub import {
111     my $class = shift;
112
113     strict->import;
114     warnings->import;
115
116     my $caller = caller;
117
118     # we should never export to main
119     if ($caller eq 'main') {
120         warn qq{$class does not export its sugar to the 'main' package.\n};
121         return;
122     }
123
124     my $meta = Mouse::Meta::Class->initialize($caller);
125     $meta->superclasses('Mouse::Object')
126         unless $meta->superclasses;
127
128     no strict 'refs';
129     no warnings 'redefine';
130     *{$caller.'::meta'} = sub { $meta };
131
132     if (@_) {
133         __PACKAGE__->export_to_level( 1, $class, @_);
134     } else {
135         # shortcut for the common case of no type character
136         no strict 'refs';
137         for my $keyword (@EXPORT) {
138             *{ $caller . '::' . $keyword } = *{__PACKAGE__ . '::' . $keyword};
139         }
140     }
141 }
142
143 sub unimport {
144     my $caller = caller;
145
146     no strict 'refs';
147     for my $keyword (@EXPORT) {
148         delete ${ $caller . '::' }{$keyword};
149     }
150 }
151
152 sub load_class {
153     my $class = shift;
154
155     if (ref($class) || !defined($class) || !length($class)) {
156         my $display = defined($class) ? $class : 'undef';
157         confess "Invalid class name ($display)";
158     }
159
160     return 1 if $class eq 'Mouse::Object';
161     return 1 if is_class_loaded($class);
162
163     (my $file = "$class.pm") =~ s{::}{/}g;
164
165     eval { CORE::require($file) };
166     confess "Could not load class ($class) because : $@" if $@;
167
168     return 1;
169 }
170
171 sub is_class_loaded {
172     my $class = shift;
173
174     return 0 if ref($class) || !defined($class) || !length($class);
175
176     # walk the symbol table tree to avoid autovififying
177     # \*{${main::}{"Foo::"}} == \*main::Foo::
178
179     my $pack = \*::;
180     foreach my $part (split('::', $class)) {
181         return 0 unless exists ${$$pack}{"${part}::"};
182         $pack = \*{${$$pack}{"${part}::"}};
183     }
184
185     # check for $VERSION or @ISA
186     return 1 if exists ${$$pack}{VERSION}
187              && defined *{${$$pack}{VERSION}}{SCALAR};
188     return 1 if exists ${$$pack}{ISA}
189              && defined *{${$$pack}{ISA}}{ARRAY};
190
191     # check for any method
192     foreach ( keys %{$$pack} ) {
193         next if substr($_, -2, 2) eq '::';
194         return 1 if defined *{${$$pack}{$_}}{CODE};
195     }
196
197     # fail
198     return 0;
199 }
200
201 1;
202
203 __END__
204
205 =head1 NAME
206
207 Mouse - Moose minus the antlers
208
209 =head1 SYNOPSIS
210
211     package Point;
212     use Mouse; # automatically turns on strict and warnings
213
214     has 'x' => (is => 'rw', isa => 'Int');
215     has 'y' => (is => 'rw', isa => 'Int');
216
217     sub clear {
218         my $self = shift;
219         $self->x(0);
220         $self->y(0);
221     }
222
223     package Point3D;
224     use Mouse;
225
226     extends 'Point';
227
228     has 'z' => (is => 'rw', isa => 'Int');
229
230     after 'clear' => sub {
231         my $self = shift;
232         $self->z(0);
233     };
234
235 =head1 DESCRIPTION
236
237 L<Moose> is wonderful.
238
239 Unfortunately, it's a little slow. Though significant progress has been made
240 over the years, the compile time penalty is a non-starter for some
241 applications.
242
243 Mouse aims to alleviate this by providing a subset of Moose's
244 functionality, faster. In particular, L<Moose/has> is missing only a few
245 expert-level features.
246
247 We're also going as light on dependencies as possible. Most functions we use
248 from L<Scalar::Util> are copied into this dist. L<Scalar::Util> is required if
249 you'd like weak references; there's simply no way to do it from pure Perl.
250 L<Class::Method::Modifiers> is required if you want support for L</before>,
251 L</after>, and L</around>.
252
253 =head2 MOOSE COMPAT
254
255 Compatibility with Moose has been the utmost concern. Fewer than 1% of the
256 tests fail when run against Moose instead of Mouse. Mouse code coverage is also
257 over 96%. Even the error messages are taken from Moose. The Mouse code just
258 runs the test suite 4x faster.
259
260 The idea is that, if you need the extra power, you should be able to run
261 C<s/Mouse/Moose/g> on your codebase and have nothing break. To that end,
262 nothingmuch has written L<Squirrel> (part of this distribution) which will act
263 as Mouse unless Moose is loaded, in which case it will act as Moose.
264
265 Mouse also has the blessings of Moose's author, stevan.
266
267 =head2 MouseX
268
269 Please don't copy MooseX code to MouseX. If you need extensions, you really
270 should upgrade to Moose. We don't need two parallel sets of extensions!
271
272 If you really must write a Mouse extension, please contact the Moose mailing
273 list or #moose on IRC beforehand.
274
275 =head1 KEYWORDS
276
277 =head2 meta -> Mouse::Meta::Class
278
279 Returns this class' metaclass instance.
280
281 =head2 extends superclasses
282
283 Sets this class' superclasses.
284
285 =head2 before (method|methods) => Code
286
287 Installs a "before" method modifier. See L<Moose/before> or
288 L<Class::Method::Modifiers/before>.
289
290 Use of this feature requires L<Class::Method::Modifiers>!
291
292 =head2 after (method|methods) => Code
293
294 Installs an "after" method modifier. See L<Moose/after> or
295 L<Class::Method::Modifiers/after>.
296
297 Use of this feature requires L<Class::Method::Modifiers>!
298
299 =head2 around (method|methods) => Code
300
301 Installs an "around" method modifier. See L<Moose/around> or
302 L<Class::Method::Modifiers/around>.
303
304 Use of this feature requires L<Class::Method::Modifiers>!
305
306 =head2 has (name|names) => parameters
307
308 Adds an attribute (or if passed an arrayref of names, multiple attributes) to
309 this class. Options:
310
311 =over 4
312
313 =item is => ro|rw
314
315 If specified, inlines a read-only/read-write accessor with the same name as
316 the attribute.
317
318 =item isa => TypeConstraint
319
320 Provides basic type checking in the constructor and accessor. Basic types such
321 as C<Int>, C<ArrayRef>, C<Defined> are supported. Any unknown type is taken to
322 be a class check (e.g. isa => 'DateTime' would accept only L<DateTime>
323 objects).
324
325 =item required => 0|1
326
327 Whether this attribute is required to have a value. If the attribute is lazy or
328 has a builder, then providing a value for the attribute in the constructor is
329 optional.
330
331 =item init_arg => Str | Undef
332
333 Allows you to use a different key name in the constructor.  If undef, the
334 attribue can't be passed to the constructor.
335
336 =item default => Value | CodeRef
337
338 Sets the default value of the attribute. If the default is a coderef, it will
339 be invoked to get the default value. Due to quirks of Perl, any bare reference
340 is forbidden, you must wrap the reference in a coderef. Otherwise, all
341 instances will share the same reference.
342
343 =item lazy => 0|1
344
345 If specified, the default is calculated on demand instead of in the
346 constructor.
347
348 =item predicate => Str
349
350 Lets you specify a method name for installing a predicate method, which checks
351 that the attribute has a value. It will not invoke a lazy default or builder
352 method.
353
354 =item clearer => Str
355
356 Lets you specify a method name for installing a clearer method, which clears
357 the attribute's value from the instance. On the next read, lazy or builder will
358 be invoked.
359
360 =item handles => HashRef|ArrayRef
361
362 Lets you specify methods to delegate to the attribute. ArrayRef forwards the
363 given method names to method calls on the attribute. HashRef maps local method
364 names to remote method names called on the attribute. Other forms of
365 L</handles>, such as regular expression and coderef, are not yet supported.
366
367 =item weak_ref => 0|1
368
369 Lets you automatically weaken any reference stored in the attribute.
370
371 Use of this feature requires L<Scalar::Util>!
372
373 =item trigger => CodeRef
374
375 Any time the attribute's value is set (either through the accessor or the constructor), the trigger is called on it. The trigger receives as arguments the instance, the new value, and the attribute instance.
376
377 Mouse 0.05 supported more complex triggers, but this behavior is now removed.
378
379 =item builder => Str
380
381 Defines a method name to be called to provide the default value of the
382 attribute. C<< builder => 'build_foo' >> is mostly equivalent to
383 C<< default => sub { $_[0]->build_foo } >>.
384
385 =item auto_deref => 0|1
386
387 Allows you to automatically dereference ArrayRef and HashRef attributes in list
388 context. In scalar context, the reference is returned (NOT the list length or
389 bucket status). You must specify an appropriate type constraint to use
390 auto_deref.
391
392 =item lazy_build => 0|1
393
394 Automatically define lazy => 1 as well as builder => "_build_$attr", clearer =>
395 "clear_$attr', predicate => 'has_$attr' unless they are already defined.
396
397 =back
398
399 =head2 confess error -> BOOM
400
401 L<Carp/confess> for your convenience.
402
403 =head2 blessed value -> ClassName | undef
404
405 L<Scalar::Util/blessed> for your convenience.
406
407 =head1 MISC
408
409 =head2 import
410
411 Importing Mouse will default your class' superclass list to L<Mouse::Object>.
412 You may use L</extends> to replace the superclass list.
413
414 =head2 unimport
415
416 Please unimport Mouse (C<no Mouse>) so that if someone calls one of the
417 keywords (such as L</extends>) it will break loudly instead breaking subtly.
418
419 =head1 FUNCTIONS
420
421 =head2 load_class Class::Name
422
423 This will load a given C<Class::Name> (or die if it's not loadable).
424 This function can be used in place of tricks like
425 C<eval "use $module"> or using C<require>.
426
427 =head2 is_class_loaded Class::Name -> Bool
428
429 Returns whether this class is actually loaded or not. It uses a heuristic which
430 involves checking for the existence of C<$VERSION>, C<@ISA>, and any
431 locally-defined method.
432
433 =head1 AUTHORS
434
435 Shawn M Moore, C<< <sartak at gmail.com> >>
436
437 Yuval Kogman, C<< <nothingmuch at woobling.org> >>
438
439 tokuhirom
440
441 Yappo
442
443 with plenty of code borrowed from L<Class::MOP> and L<Moose>
444
445 =head1 BUGS
446
447 No known bugs.
448
449 Please report any bugs through RT: email
450 C<bug-mouse at rt.cpan.org>, or browse
451 L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Mouse>.
452
453 =head1 COPYRIGHT AND LICENSE
454
455 Copyright 2008 Shawn M Moore.
456
457 This program is free software; you can redistribute it and/or modify it
458 under the same terms as Perl itself.
459
460 =cut
461