lib/Mouse.pm

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