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

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

our $VERSION = '0.02';
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) {
                    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 VERSION

Version 0.02 released 11 Jun 08

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