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

#!/usr/bin/env perl
package Mouse;
use strict;
use warnings;

our $VERSION = '0.07';
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 {
            my $caller = $CALLER;

            return sub {
                my $meta = $caller->meta;

                my $names = shift;
                $names = [$names] if !ref($names);

                for my $name (@$names) {
                    if ($name =~ s/^\+//) {
                        Mouse::Meta::Attribute->clone_parent($meta, $name, @_);
                    }
                    else {
                        Mouse::Meta::Attribute->create($meta, $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 97%. 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

We're working on fixing this one! stevan has suggested an implementation
strategy. Mouse currently ignores methods, so that needs to be fixed next.
Roles that consist entirely of attributes may be usable in this very version.

=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.

Mouse 0.05 supported more complex triggers, but this behavior is now deprecated.

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