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