[gitmo/Mouse.git] / lib / Mouse.pm

#!perl
package Mouse;
use strict;
use warnings;

our $VERSION = '0.05';
use 5.006;

use Sub::Exporter;
use Carp 'confess';
use Scalar::Util 'blessed';
use Class::Method::Modifiers ();

use Mouse::Meta::Attribute;
use Mouse::Meta::Class;
use Mouse::Object;
use Mouse::TypeRegistry;

do {
    my $CALLER;

    my %exports = (
        meta => sub {
            my $meta = Mouse::Meta::Class->initialize($CALLER);
            return sub { $meta };
        },

        extends => sub {
            my $caller = $CALLER;
            return sub {
                $caller->meta->superclasses(@_);
            };
        },

        has => sub {
            return sub {
                my $package = caller;
                my $names = shift;
                $names = [$names] if !ref($names);

                for my $name (@$names) {
                    if ($name =~ s/^\+//) {
                        Mouse::Meta::Attribute->clone_parent($package, $name, @_);
                    }
                    else {
                        Mouse::Meta::Attribute->create($package, $name, @_);
                    }
                }
            };
        },

        confess => sub {
            return \&confess;
        },

        blessed => sub {
            return \&blessed;
        },

        before => sub {
            return \&Class::Method::Modifiers::before;
        },

        after => sub {
            return \&Class::Method::Modifiers::after;
        },

        around => sub {
            return \&Class::Method::Modifiers::around;
        },
    );

    my $exporter = Sub::Exporter::build_exporter({
        exports => \%exports,
        groups  => { default => [':all'] },
    });

    sub import {
        $CALLER = caller;

        strict->import;
        warnings->import;

        my $meta = Mouse::Meta::Class->initialize($CALLER);
        $meta->superclasses('Mouse::Object')
            unless $meta->superclasses;

        goto $exporter;
    }

    sub unimport {
        my $caller = caller;

        no strict 'refs';
        for my $keyword (keys %exports) {
            next if $keyword eq 'meta'; # we don't delete this one
            delete ${ $caller . '::' }{$keyword};
        }
    }
};

sub load_class {
    my $class = shift;

    if (ref($class) || !defined($class) || !length($class)) {
        my $display = defined($class) ? $class : 'undef';
        confess "Invalid class name ($display)";
    }

    return 1 if is_class_loaded($class);

    (my $file = "$class.pm") =~ s{::}{/}g;

    eval { CORE::require($file) };
    confess "Could not load class ($class) because : $@" if $@;

    return 1;
}

sub is_class_loaded {
    my $class = shift;

    return 0 if ref($class) || !defined($class) || !length($class);

    # walk the symbol table tree to avoid autovififying
    # \*{${main::}{"Foo::"}} == \*main::Foo::

    my $pack = \*::;
    foreach my $part (split('::', $class)) {
        return 0 unless exists ${$$pack}{"${part}::"};
        $pack = \*{${$$pack}{"${part}::"}};
    }

    # check for $VERSION or @ISA
    return 1 if exists ${$$pack}{VERSION}
             && defined *{${$$pack}{VERSION}}{SCALAR};
    return 1 if exists ${$$pack}{ISA}
             && defined *{${$$pack}{ISA}}{ARRAY};

    # check for any method
    foreach ( keys %{$$pack} ) {
        next if substr($_, -2, 2) eq '::';
        return 1 if defined *{${$$pack}{$_}}{CODE};
    }

    # fail
    return 0;
}

1;

__END__

=head1 NAME

Mouse - Moose minus the antlers

=head1 SYNOPSIS

    package Point;
    use Mouse; # automatically turns on strict and warnings

    has 'x' => (is => 'rw', isa => 'Int');
    has 'y' => (is => 'rw', isa => 'Int');

    sub clear {
        my $self = shift;
        $self->x(0);
        $self->y(0);
    }

    package Point3D;
    use Mouse;

    extends 'Point';

    has 'z' => (is => 'rw', isa => 'Int');

    after 'clear' => sub {
        my $self = shift;
        $self->z(0);
    };

=head1 DESCRIPTION

L<Moose> is wonderful.

Unfortunately, it's a little slow. Though significant progress has been made
over the years, the compile time penalty is a non-starter for some
applications.

Mouse aims to alleviate this by providing a subset of Moose's
functionality, faster. In particular, L<Moose/has> is missing only a few
expert-level features.

=head2 MOOSE COMPAT

Compatibility with Moose has been the utmost concern. Fewer than 1% of the
tests fail when run against Moose instead of Mouse. Mouse code coverage is also
over 99%. Even the error messages are taken from Moose. The Mouse code just
runs the test suite 3x-4x faster.

The idea is that, if you need the extra power, you should be able to run
C<s/Mouse/Moose/g> on your codebase and have nothing break. To that end,
nothingmuch has written L<Squirrel> (part of this distribution) which will act
as Mouse unless Moose is loaded, in which case it will act as Moose.

Mouse also has the blessings of Moose's author, stevan.

=head2 MISSING FEATURES

=head3 Roles

Fixing this one slightly less soon. stevan has suggested an implementation
strategy. Mouse currently mostly ignores methods.

=head3 Complex types

User-defined type constraints and parameterized types may be implemented. Type
coercions probably not (patches welcome).

=head3 Bootstrapped meta world

Very handy for extensions to the MOP. Not pressing, but would be nice to have.

=head3 Modification of attribute metaclass

When you declare an attribute with L</has>, you get the inlined accessors
installed immediately. Modifying the attribute metaclass, even if possible,
does nothing.

=head3 Lots more..

MouseX?

=head1 KEYWORDS

=head2 meta -> Mouse::Meta::Class

Returns this class' metaclass instance.

=head2 extends superclasses

Sets this class' superclasses.

=head2 before (method|methods) => Code

Installs a "before" method modifier. See L<Moose/before> or
L<Class::Method::Modifiers/before>.

=head2 after (method|methods) => Code

Installs an "after" method modifier. See L<Moose/after> or
L<Class::Method::Modifiers/after>.

=head2 around (method|methods) => Code

Installs an "around" method modifier. See L<Moose/around> or
L<Class::Method::Modifiers/around>.

=head2 has (name|names) => parameters

Adds an attribute (or if passed an arrayref of names, multiple attributes) to
this class. Options:

=over 4

=item is => ro|rw

If specified, inlines a read-only/read-write accessor with the same name as
the attribute.

=item isa => TypeConstraint

Provides basic type checking in the constructor and accessor. Basic types such
as C<Int>, C<ArrayRef>, C<Defined> are supported. Any unknown type is taken to
be a class check (e.g. isa => 'DateTime' would accept only L<DateTime>
objects).

=item required => 0|1

Whether this attribute is required to have a value. If the attribute is lazy or
has a builder, then providing a value for the attribute in the constructor is
optional.

=item init_arg => Str

Allows you to use a different key name in the constructor.

=item default => Value | CodeRef

Sets the default value of the attribute. If the default is a coderef, it will
be invoked to get the default value. Due to quirks of Perl, any bare reference
is forbidden, you must wrap the reference in a coderef. Otherwise, all
instances will share the same reference.

=item lazy => 0|1

If specified, the default is calculated on demand instead of in the
constructor.

=item predicate => Str

Lets you specify a method name for installing a predicate method, which checks
that the attribute has a value. It will not invoke a lazy default or builder
method.

=item clearer => Str

Lets you specify a method name for installing a clearer method, which clears
the attribute's value from the instance. On the next read, lazy or builder will
be invoked.

=item handles => HashRef|ArrayRef

Lets you specify methods to delegate to the attribute. ArrayRef forwards the
given method names to method calls on the attribute. HashRef maps local method
names to remote method names called on the attribute. Other forms of
L</handles>, such as regular expression and coderef, are not yet supported.

=item weak_ref => 0|1

Lets you automatically weaken any reference stored in the attribute.

=item trigger => Coderef

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.

=item builder => Str

Defines a method name to be called to provide the default value of the
attribute. C<< builder => 'build_foo' >> is mostly equivalent to
C<< default => sub { $_[0]->build_foo } >>.

=item auto_deref => 0|1

Allows you to automatically dereference ArrayRef and HashRef attributes in list
context. In scalar context, the reference is returned (NOT the list length or
bucket status). You must specify an appropriate type constraint to use
auto_deref.

=back

=head2 confess error -> BOOM

L<Carp/confess> for your convenience.

=head2 blessed value -> ClassName | undef

L<Scalar::Util/blessed> for your convenience.

=head1 MISC

=head2 import

Importing Mouse will default your class' superclass list to L<Mouse::Object>.
You may use L</extends> to replace the superclass list.

=head2 unimport

Please unimport Mouse (C<no Mouse>) so that if someone calls one of the
keywords (such as L</extends>) it will break loudly instead breaking subtly.

=head1 FUNCTIONS

=head2 load_class Class::Name

This will load a given C<Class::Name> (or die if it's not loadable).
This function can be used in place of tricks like
C<eval "use $module"> or using C<require>.

=head2 is_class_loaded Class::Name -> Bool

Returns whether this class is actually loaded or not. It uses a heuristic which
involves checking for the existence of C<$VERSION>, C<@ISA>, and any
locally-defined method.

=head1 AUTHOR

Shawn M Moore, C<< <sartak at gmail.com> >>

with plenty of code borrowed from L<Class::MOP> and L<Moose>

=head1 BUGS

No known bugs.

Please report any bugs through RT: email
C<bug-mouse at rt.cpan.org>, or browse
L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Mouse>.

=head1 COPYRIGHT AND LICENSE

Copyright 2008 Shawn M Moore.

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

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