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

                confess "Mouse::Role only supports 'with' on individual roles at a time" if @_;

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