[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;
        },

        with => sub {
            my $caller = $CALLER;

            return sub {
                my $role  = shift;
                my $class = $caller->meta;

                Mouse::load_class($role);
                $role->apply_to_class($class);
            };
        },
    );

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