Commit upstream/0.55 - libmoose-perl

+41

-0

Changes less more

0	0	Revision history for Perl extension Moose
	1
	2	0.55 Sun August 3, 2008
	3	* Moose::Meta::Attribute
	4	- breaking down the way 'handles' methods are
	5	created so that the process can be more easily
	6	overridden by subclasses (stevan)
	7
	8	* Moose::Meta::TypeConstraint
	9	- fixing what is passed into a ->message with
	10	the type constraints (RT #37569)
	11	- added tests for this (Charles Alderman)
	12
	13	* Moose::Util::TypeConstraints
	14	- fix coerce to accept anon types like subtype can (mst)
	15
	16	* Moose::Cookbook
	17	- reorganized the recipes into sections - Basics, Roles, Meta,
	18	Extending - and wrote abstracts for each section (Dave Rolsky)
	19
	20	* Moose::Cookbook::Basics::Recipe10
	21	- A new recipe that demonstrates operator overloading
	22	in combination with Moose. (bluefeet)
	23
	24	* Moose::Cookbook::Meta::Recipe1
	25	- an introduction to what meta is and why you'd want to make
	26	your own metaclass extensions (Dave Rolsky)
	27
	28	* Moose::Cookbook::Meta::Recipe4
	29	- a very simple metaclass example (Dave Rolsky)
	30
	31	* Moose::Cookbook::Extending::Recipe1
	32	- how to write a Moose-alike module to use your own object base
	33	class (Dave Rolsky)
	34
	35	* Moose::Cookbook::Extending::Recipe2
	36	- how to write modules with an API just like C<Moose.pm> (Dave
	37	Rolsky)
	38
	39	* all documentation
	40	- Tons of fixes, both syntactical and grammatical (Dave
	41	Rolsky, Paul Fenwick)
1	42
2	43	0.54 Thurs. July 3, 2008
3	44	... this is not my day today ...

+36

-22

MANIFEST less more

12	12	inc/Module/Install/WriteAll.pm
13	13	lib/Moose.pm
14	14	lib/Moose/Cookbook.pod
	15	lib/Moose/Cookbook/Basics/Recipe1.pod
	16	lib/Moose/Cookbook/Basics/Recipe10.pod
	17	lib/Moose/Cookbook/Basics/Recipe2.pod
	18	lib/Moose/Cookbook/Basics/Recipe3.pod
	19	lib/Moose/Cookbook/Basics/Recipe4.pod
	20	lib/Moose/Cookbook/Basics/Recipe5.pod
	21	lib/Moose/Cookbook/Basics/Recipe6.pod
	22	lib/Moose/Cookbook/Basics/Recipe7.pod
	23	lib/Moose/Cookbook/Basics/Recipe9.pod
	24	lib/Moose/Cookbook/Extending/Recipe1.pod
	25	lib/Moose/Cookbook/Extending/Recipe2.pod
15	26	lib/Moose/Cookbook/FAQ.pod
16		lib/Moose/Cookbook/Recipe1.pod
17		lib/Moose/Cookbook/Recipe10.pod
18		lib/Moose/Cookbook/Recipe11.pod
19		lib/Moose/Cookbook/Recipe2.pod
20		lib/Moose/Cookbook/Recipe21.pod
21		lib/Moose/Cookbook/Recipe22.pod
22		lib/Moose/Cookbook/Recipe3.pod
23		lib/Moose/Cookbook/Recipe4.pod
24		lib/Moose/Cookbook/Recipe5.pod
25		lib/Moose/Cookbook/Recipe6.pod
26		lib/Moose/Cookbook/Recipe7.pod
27		lib/Moose/Cookbook/Recipe9.pod
	27	lib/Moose/Cookbook/Meta/Recipe1.pod
	28	lib/Moose/Cookbook/Meta/Recipe2.pod
	29	lib/Moose/Cookbook/Meta/Recipe3.pod
	30	lib/Moose/Cookbook/Meta/Recipe4.pod
	31	lib/Moose/Cookbook/Roles/Recipe1.pod
	32	lib/Moose/Cookbook/Roles/Recipe2.pod
28	33	lib/Moose/Cookbook/Snack/Keywords.pod
29	34	lib/Moose/Cookbook/Snack/Types.pod
30	35	lib/Moose/Cookbook/Style.pod

71	76	META.yml
72	77	README
73	78	t/000_load.t
74		t/000_recipes/001_point.t
75		t/000_recipes/002_bank_account.t
76		t/000_recipes/003_binary_tree.t
77		t/000_recipes/004_company.t
78		t/000_recipes/005_coercion.t
79		t/000_recipes/006_augment_inner.t
80		t/000_recipes/010_roles.t
81		t/000_recipes/011_advanced_role_composition.t
82		t/000_recipes/021_meta_attribute.t
83		t/000_recipes/022_attribute_trait.t
	79	t/000_recipes/basics/001_point.t
	80	t/000_recipes/basics/002_bank_account.t
	81	t/000_recipes/basics/003_binary_tree.t
	82	t/000_recipes/basics/004_company.t
	83	t/000_recipes/basics/005_coercion.t
	84	t/000_recipes/basics/006_augment_inner.t
	85	t/000_recipes/basics/010_genes.t
	86	t/000_recipes/meta/002_meta_attribute.t
	87	t/000_recipes/meta/003_attribute_trait.t
	88	t/000_recipes/roles/001_roles.t
	89	t/000_recipes/roles/002_advanced_role_composition.t
84	90	t/010_basics/001_basic_class_setup.t
85	91	t/010_basics/002_require_superclasses.t
86	92	t/010_basics/003_super_and_override.t

136	142	t/030_roles/016_runtime_roles_and_nonmoose.t
137	143	t/030_roles/017_extending_role_attrs.t
138	144	t/030_roles/018_runtime_roles_w_params.t
	145	t/030_roles/019_build.t
139	146	t/030_roles/020_role_composite.t
140	147	t/030_roles/021_role_composite_exclusion.t
141	148	t/030_roles/022_role_composition_req_methods.t

192	199	t/100_bugs/013_lazybuild_required_undef.t
193	200	t/100_bugs/014_DEMOLISHALL.t
194	201	t/100_bugs/016_inheriting_from_roles.t
	202	t/100_bugs/017_type_constraint_messages.t
	203	t/100_bugs/018_immutable_metaclass_does_role.t
195	204	t/200_examples/001_example.t
196	205	t/200_examples/002_example_Moose_POOP.t
197	206	t/200_examples/003_example.t

216	225	t/500_test_moose/002_test_moose_does_ok.t
217	226	t/500_test_moose/003_test_moose_has_attribute_ok.t
218	227	t/500_test_moose/004_test_moose_meta_ok.t
	228	t/600_todo_tests/001_exception_reflects_failed_constraint.t
	229	t/600_todo_tests/002_various_role_shit.t
	230	t/600_todo_tests/003_immutable_n_around.t
	231	t/600_todo_tests/004_inlined_constructor_modified_new.t
	232	t/600_todo_tests/005_moose_and_threads.t
219	233	t/lib/Bar.pm
220	234	t/lib/Foo.pm
221	235	t/lib/MyMooseA.pm

+12

-12

META.yml less more

0		---
1		abstract: 'A postmodern object system for Perl 5'
2		author:
3		- 'Stevan Little <stevan@iinteractive.com>'
4		build_requires:
	0	---
	1	abstract: A postmodern object system for Perl 5
	2	author: Stevan Little <stevan@iinteractive.com>
	3	build_requires:
5	4	Test::Exception: 0.21
6	5	Test::LongString: 0
7	6	Test::More: 0.62
8	7	distribution_type: module
9		generated_by: 'Module::Install version 0.75'
	8	generated_by: Module::Install version 0.67
10	9	license: perl
11		meta-spec:
	10	meta-spec:
12	11	url: http://module-build.sourceforge.net/META-spec-v1.3.html
13	12	version: 1.3
14	13	name: Moose
15		no_index:
16		directory:
	14	no_index:
	15	directory:
17	16	- inc
18	17	- t
19		requires:
	18	requires:
20	19	Carp: 0
21		Class::MOP: 0.59
	20	Class::MOP: 0.64
22	21	Filter::Simple: 0
23	22	Scalar::Util: 1.18
24	23	Sub::Exporter: 0.972
25		version: 0.54
	24	tests: t/.t t/000_recipes/basics/.t t/000_recipes/meta/.t t/000_recipes/roles/.t t/010_basics/.t t/020_attributes/.t t/030_roles/.t t/040_type_constraints/.t t/050_metaclasses/.t t/060_compat/.t t/100_bugs/.t t/200_examples/.t t/300_immutable/.t t/400_moose_util/.t t/500_test_moose/.t t/600_todo_tests/.t
	25	version: 0.55

+1

-1

Makefile.PL less more

11	11	# prereqs
12	12	requires 'Scalar::Util' => $win32 ? '1.17' : '1.18';
13	13	requires 'Carp';
14		requires 'Class::MOP' => '0.59';
	14	requires 'Class::MOP' => '0.64';
15	15	requires 'Sub::Exporter' => '0.972';
16	16
17	17	# only used by oose.pm, not Moose.pm :P

+1

-1

README less more

0		Moose version 0.54
	0	Moose version 0.55
1	1	===========================
2	2
3	3	See the individual module documentation for more information

+1

-1

inc/Module/Install/AutoInstall.pm less more

5	5
6	6	use vars qw{$VERSION $ISCORE @ISA};
7	7	BEGIN {
8		$VERSION = '0.75';
	8	$VERSION = '0.67';
9	9	$ISCORE = 1;
10	10	@ISA = qw{Module::Install::Base};
11	11	}

+1

-1

inc/Module/Install/Base.pm less more

0	0	#line 1
1	1	package Module::Install::Base;
2	2
3		$VERSION = '0.75';
	3	$VERSION = '0.67';
4	4
5	5	# Suspend handler for "redefined" warnings
6	6	BEGIN {

+1

-1

inc/Module/Install/Can.pm less more

10	10
11	11	use vars qw{$VERSION $ISCORE @ISA};
12	12	BEGIN {
13		$VERSION = '0.75';
	13	$VERSION = '0.67';
14	14	$ISCORE = 1;
15	15	@ISA = qw{Module::Install::Base};
16	16	}

+1

-1

inc/Module/Install/Fetch.pm less more

5	5
6	6	use vars qw{$VERSION $ISCORE @ISA};
7	7	BEGIN {
8		$VERSION = '0.75';
	8	$VERSION = '0.67';
9	9	$ISCORE = 1;
10	10	@ISA = qw{Module::Install::Base};
11	11	}

+1

-1

inc/Module/Install/Include.pm less more

5	5
6	6	use vars qw{$VERSION $ISCORE @ISA};
7	7	BEGIN {
8		$VERSION = '0.75';
	8	$VERSION = '0.67';
9	9	$ISCORE = 1;
10	10	@ISA = qw{Module::Install::Base};
11	11	}

+13

-21

inc/Module/Install/Makefile.pm less more

6	6
7	7	use vars qw{$VERSION $ISCORE @ISA};
8	8	BEGIN {
9		$VERSION = '0.75';
	9	$VERSION = '0.67';
10	10	$ISCORE = 1;
11	11	@ISA = qw{Module::Install::Base};
12	12	}

36	36	sub makemaker_args {
37	37	my $self = shift;
38	38	my $args = ($self->{makemaker_args} \|\|= {});
39		%$args = ( %$args, @_ ) if @_;
	39	%$args = ( %$args, @_ ) if @_;
40	40	$args;
41	41	}
42	42

62	62	sub clean_files {
63	63	my $self = shift;
64	64	my $clean = $self->makemaker_args->{clean} \|\|= {};
65		%$clean = (
	65	%$clean = (
66	66	%$clean,
67		FILES => join ' ', grep { length $_ } ($clean->{FILES} \|\| (), @_),
	67	FILES => join(' ', grep length, $clean->{FILES}, @_),
68	68	);
69	69	}
70	70
71	71	sub realclean_files {
72		my $self = shift;
	72	my $self = shift;
73	73	my $realclean = $self->makemaker_args->{realclean} \|\|= {};
74		%$realclean = (
	74	%$realclean = (
75	75	%$realclean,
76		FILES => join ' ', grep { length $_ } ($realclean->{FILES} \|\| (), @_),
	76	FILES => join(' ', grep length, $realclean->{FILES}, @_),
77	77	);
78	78	}
79	79

103	103	unless ( -d $dir ) {
104	104	die "tests_recursive dir '$dir' does not exist";
105	105	}
	106	require File::Find;
106	107	%test_dir = ();
107		require File::Find;
108	108	File::Find::find( \&_wanted_t, $dir );
109	109	$self->tests( join ' ', map { "$_/*.t" } sort keys %test_dir );
110	110	}

113	113	my $self = shift;
114	114	die "&Makefile->write() takes no arguments\n" if @_;
115	115
116		# Make sure we have a new enough
117		require ExtUtils::MakeMaker;
118		$self->configure_requires( 'ExtUtils::MakeMaker' => $ExtUtils::MakeMaker::VERSION );
119
120		# Generate the
121	116	my $args = $self->makemaker_args;
122	117	$args->{DISTNAME} = $self->name;
123		$args->{NAME} = $self->module_name \|\| $self->name;
124		$args->{VERSION} = $self->version;
	118	$args->{NAME} = $self->module_name \|\| $self->name \|\| $self->determine_NAME($args);
	119	$args->{VERSION} = $self->version \|\| $self->determine_VERSION($args);
125	120	$args->{NAME} =~ s/-/::/g;
126	121	if ( $self->tests ) {
127	122	$args->{test} = { TESTS => $self->tests };

146	141	map { @$_ }
147	142	map { @$_ }
148	143	grep $_,
149		($self->configure_requires, $self->build_requires, $self->requires)
	144	($self->build_requires, $self->requires)
150	145	);
151
152		# Remove any reference to perl, PREREQ_PM doesn't support it
153		delete $args->{PREREQ_PM}->{perl};
154	146
155	147	# merge both kinds of requires into prereq_pm
156	148	my $subdirs = ($args->{DIR} \|\|= []);

212	204	#$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m;
213	205
214	206	# Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well.
215		$makefile =~ s/(\"?)-I\$$PERL_LIB$\1//g;
	207	$makefile =~ s/("?)-I\$$PERL_LIB$\1//g;
216	208
217	209	# XXX - This is currently unused; not sure if it breaks other MM-users
218	210	# $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg;

241	233
242	234	__END__
243	235
244		#line 371
	236	#line 363

+268

-339

inc/Module/Install/Metadata.pm less more

5	5
6	6	use vars qw{$VERSION $ISCORE @ISA};
7	7	BEGIN {
8		$VERSION = '0.75';
	8	$VERSION = '0.67';
9	9	$ISCORE = 1;
10	10	@ISA = qw{Module::Install::Base};
11	11	}
12	12
13	13	my @scalar_keys = qw{
14		name
15		module_name
16		abstract
17		author
18		version
19		license
20		distribution_type
21		perl_version
22		tests
23		installdirs
	14	name module_name abstract author version license
	15	distribution_type perl_version tests installdirs
24	16	};
25	17
26	18	my @tuple_keys = qw{
27		configure_requires
28		build_requires
29		requires
30		recommends
31		bundles
32		resources
	19	build_requires requires recommends bundles
33	20	};
34	21
35	22	sub Meta { shift }

37	24	sub Meta_TupleKeys { @tuple_keys }
38	25
39	26	foreach my $key (@scalar_keys) {
40		*$key = sub {
41		my $self = shift;
42		return $self->{values}{$key} if defined wantarray and !@_;
43		$self->{values}{$key} = shift;
44		return $self;
45		};
46		}
47
48		sub requires {
49		my $self = shift;
50		while ( @_ ) {
51		my $module = shift or last;
52		my $version = shift \|\| 0;
53		push @{ $self->{values}->{requires} }, [ $module, $version ];
54		}
55		$self->{values}{requires};
56		}
57
58		sub build_requires {
59		my $self = shift;
60		while ( @_ ) {
61		my $module = shift or last;
62		my $version = shift \|\| 0;
63		push @{ $self->{values}->{build_requires} }, [ $module, $version ];
64		}
65		$self->{values}{build_requires};
66		}
67
68		sub configure_requires {
69		my $self = shift;
70		while ( @_ ) {
71		my $module = shift or last;
72		my $version = shift \|\| 0;
73		push @{ $self->{values}->{configure_requires} }, [ $module, $version ];
74		}
75		$self->{values}->{configure_requires};
76		}
77
78		sub recommends {
79		my $self = shift;
80		while ( @_ ) {
81		my $module = shift or last;
82		my $version = shift \|\| 0;
83		push @{ $self->{values}->{recommends} }, [ $module, $version ];
84		}
85		$self->{values}->{recommends};
86		}
87
88		sub bundles {
89		my $self = shift;
90		while ( @_ ) {
91		my $module = shift or last;
92		my $version = shift \|\| 0;
93		push @{ $self->{values}->{bundles} }, [ $module, $version ];
94		}
95		$self->{values}->{bundles};
96		}
97
98		# Resource handling
99		sub resources {
100		my $self = shift;
101		while ( @_ ) {
102		my $resource = shift or last;
103		my $value = shift or next;
104		push @{ $self->{values}->{resources} }, [ $resource, $value ];
105		}
106		$self->{values}->{resources};
107		}
108
109		sub repository {
110		my $self = shift;
111		$self->resources( repository => shift );
112		return 1;
113		}
	27	*$key = sub {
	28	my $self = shift;
	29	return $self->{values}{$key} if defined wantarray and !@_;
	30	$self->{values}{$key} = shift;
	31	return $self;
	32	};
	33	}
	34
	35	foreach my $key (@tuple_keys) {
	36	*$key = sub {
	37	my $self = shift;
	38	return $self->{values}{$key} unless @_;
	39
	40	my @rv;
	41	while (@_) {
	42	my $module = shift or last;
	43	my $version = shift \|\| 0;
	44	if ( $module eq 'perl' ) {
	45	$version =~ s{^(\d+)\.(\d+)\.(\d+)}
	46	{$1 + $2/1_000 + $3/1_000_000}e;
	47	$self->perl_version($version);
	48	next;
	49	}
	50	my $rv = [ $module, $version ];
	51	push @rv, $rv;
	52	}
	53	push @{ $self->{values}{$key} }, @rv;
	54	@rv;
	55	};
	56	}
	57
	58	# configure_requires is currently a null-op
	59	sub configure_requires { 1 }
114	60
115	61	# Aliases for build_requires that will have alternative
116	62	# meanings in some future version of META.yml.
117		sub test_requires { shift->build_requires(@_) }
118		sub install_requires { shift->build_requires(@_) }
	63	sub test_requires { shift->build_requires(@_) }
	64	sub install_requires { shift->build_requires(@_) }
119	65
120	66	# Aliases for installdirs options
121	67	sub install_as_core { $_[0]->installdirs('perl') }

124	70	sub install_as_vendor { $_[0]->installdirs('vendor') }
125	71
126	72	sub sign {
127		my $self = shift;
128		return $self->{'values'}{'sign'} if defined wantarray and ! @_;
129		$self->{'values'}{'sign'} = ( @_ ? $_[0] : 1 );
130		return $self;
	73	my $self = shift;
	74	return $self->{'values'}{'sign'} if defined wantarray and ! @_;
	75	$self->{'values'}{'sign'} = ( @_ ? $_[0] : 1 );
	76	return $self;
131	77	}
132	78
133	79	sub dynamic_config {

136	82	warn "You MUST provide an explicit true/false value to dynamic_config, skipping\n";
137	83	return $self;
138	84	}
139		$self->{values}{dynamic_config} = $_[0] ? 1 : 0;
	85	$self->{'values'}{'dynamic_config'} = $_[0] ? 1 : 0;
140	86	return $self;
141	87	}
142	88
143	89	sub all_from {
144		my ( $self, $file ) = @_;
145
146		unless ( defined($file) ) {
147		my $name = $self->name
148		or die "all_from called with no args without setting name() first";
149		$file = join('/', 'lib', split(/-/, $name)) . '.pm';
150		$file =~ s{.*/}{} unless -e $file;
151		die "all_from: cannot find $file from $name" unless -e $file;
152		}
153
154		# Some methods pull from POD instead of code.
155		# If there is a matching .pod, use that instead
156		my $pod = $file;
157		$pod =~ s/\.pm$/.pod/i;
158		$pod = $file unless -e $pod;
159
160		# Pull the different values
161		$self->name_from($file) unless $self->name;
162		$self->version_from($file) unless $self->version;
163		$self->perl_version_from($file) unless $self->perl_version;
164		$self->author_from($pod) unless $self->author;
165		$self->license_from($pod) unless $self->license;
166		$self->abstract_from($pod) unless $self->abstract;
167
168		return 1;
	90	my ( $self, $file ) = @_;
	91
	92	unless ( defined($file) ) {
	93	my $name = $self->name
	94	or die "all_from called with no args without setting name() first";
	95	$file = join('/', 'lib', split(/-/, $name)) . '.pm';
	96	$file =~ s{.*/}{} unless -e $file;
	97	die "all_from: cannot find $file from $name" unless -e $file;
	98	}
	99
	100	$self->version_from($file) unless $self->version;
	101	$self->perl_version_from($file) unless $self->perl_version;
	102
	103	# The remaining probes read from POD sections; if the file
	104	# has an accompanying .pod, use that instead
	105	my $pod = $file;
	106	if ( $pod =~ s/\.pm$/.pod/i and -e $pod ) {
	107	$file = $pod;
	108	}
	109
	110	$self->author_from($file) unless $self->author;
	111	$self->license_from($file) unless $self->license;
	112	$self->abstract_from($file) unless $self->abstract;
169	113	}
170	114
171	115	sub provides {
172		my $self = shift;
173		my $provides = ( $self->{values}{provides} \|\|= {} );
174		%$provides = (%$provides, @_) if @_;
175		return $provides;
	116	my $self = shift;
	117	my $provides = ( $self->{values}{provides} \|\|= {} );
	118	%$provides = (%$provides, @_) if @_;
	119	return $provides;
176	120	}
177	121
178	122	sub auto_provides {
179		my $self = shift;
180		return $self unless $self->is_admin;
181		unless (-e 'MANIFEST') {
182		warn "Cannot deduce auto_provides without a MANIFEST, skipping\n";
183		return $self;
184		}
185		# Avoid spurious warnings as we are not checking manifest here.
186		local $SIG{__WARN__} = sub {1};
187		require ExtUtils::Manifest;
188		local *ExtUtils::Manifest::manicheck = sub { return };
189
190		require Module::Build;
191		my $build = Module::Build->new(
192		dist_name => $self->name,
193		dist_version => $self->version,
194		license => $self->license,
195		);
196		$self->provides( %{ $build->find_dist_packages \|\| {} } );
	123	my $self = shift;
	124	return $self unless $self->is_admin;
	125
	126	unless (-e 'MANIFEST') {
	127	warn "Cannot deduce auto_provides without a MANIFEST, skipping\n";
	128	return $self;
	129	}
	130
	131	# Avoid spurious warnings as we are not checking manifest here.
	132
	133	local $SIG{__WARN__} = sub {1};
	134	require ExtUtils::Manifest;
	135	local *ExtUtils::Manifest::manicheck = sub { return };
	136
	137	require Module::Build;
	138	my $build = Module::Build->new(
	139	dist_name => $self->name,
	140	dist_version => $self->version,
	141	license => $self->license,
	142	);
	143	$self->provides(%{ $build->find_dist_packages \|\| {} });
197	144	}
198	145
199	146	sub feature {
200		my $self = shift;
201		my $name = shift;
202		my $features = ( $self->{values}{features} \|\|= [] );
203		my $mods;
204
205		if ( @_ == 1 and ref( $_[0] ) ) {
206		# The user used ->feature like ->features by passing in the second
207		# argument as a reference. Accomodate for that.
208		$mods = $_[0];
209		} else {
210		$mods = \@_;
211		}
212
213		my $count = 0;
214		push @$features, (
215		$name => [
216		map {
217		ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_
218		} @$mods
219		]
220		);
221
222		return @$features;
	147	my $self = shift;
	148	my $name = shift;
	149	my $features = ( $self->{values}{features} \|\|= [] );
	150
	151	my $mods;
	152
	153	if ( @_ == 1 and ref( $_[0] ) ) {
	154	# The user used ->feature like ->features by passing in the second
	155	# argument as a reference. Accomodate for that.
	156	$mods = $_[0];
	157	} else {
	158	$mods = \@_;
	159	}
	160
	161	my $count = 0;
	162	push @$features, (
	163	$name => [
	164	map {
	165	ref($_) ? ( ref($_) eq 'HASH' ) ? %$_
	166	: @$_
	167	: $_
	168	} @$mods
	169	]
	170	);
	171
	172	return @$features;
223	173	}
224	174
225	175	sub features {
226		my $self = shift;
227		while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) {
228		$self->feature( $name, @$mods );
229		}
230		return $self->{values}->{features}
231		? @{ $self->{values}->{features} }
232		: ();
	176	my $self = shift;
	177	while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) {
	178	$self->feature( $name, @$mods );
	179	}
	180	return $self->{values}->{features}
	181	? @{ $self->{values}->{features} }
	182	: ();
233	183	}
234	184
235	185	sub no_index {
236		my $self = shift;
237		my $type = shift;
238		push @{ $self->{values}{no_index}{$type} }, @_ if $type;
239		return $self->{values}{no_index};
	186	my $self = shift;
	187	my $type = shift;
	188	push @{ $self->{values}{no_index}{$type} }, @_ if $type;
	189	return $self->{values}{no_index};
240	190	}
241	191
242	192	sub read {
243		my $self = shift;
244		$self->include_deps( 'YAML::Tiny', 0 );
245
246		require YAML::Tiny;
247		my $data = YAML::Tiny::LoadFile('META.yml');
248
249		# Call methods explicitly in case user has already set some values.
250		while ( my ( $key, $value ) = each %$data ) {
251		next unless $self->can($key);
252		if ( ref $value eq 'HASH' ) {
253		while ( my ( $module, $version ) = each %$value ) {
254		$self->can($key)->($self, $module => $version );
255		}
256		} else {
257		$self->can($key)->($self, $value);
	193	my $self = shift;
	194	$self->include_deps( 'YAML', 0 );
	195
	196	require YAML;
	197	my $data = YAML::LoadFile('META.yml');
	198
	199	# Call methods explicitly in case user has already set some values.
	200	while ( my ( $key, $value ) = each %$data ) {
	201	next unless $self->can($key);
	202	if ( ref $value eq 'HASH' ) {
	203	while ( my ( $module, $version ) = each %$value ) {
	204	$self->can($key)->($self, $module => $version );
	205	}
	206	}
	207	else {
	208	$self->can($key)->($self, $value);
	209	}
	210	}
	211	return $self;
	212	}
	213
	214	sub write {
	215	my $self = shift;
	216	return $self unless $self->is_admin;
	217	$self->admin->write_meta;
	218	return $self;
	219	}
	220
	221	sub version_from {
	222	my ( $self, $file ) = @_;
	223	require ExtUtils::MM_Unix;
	224	$self->version( ExtUtils::MM_Unix->parse_version($file) );
	225	}
	226
	227	sub abstract_from {
	228	my ( $self, $file ) = @_;
	229	require ExtUtils::MM_Unix;
	230	$self->abstract(
	231	bless(
	232	{ DISTNAME => $self->name },
	233	'ExtUtils::MM_Unix'
	234	)->parse_abstract($file)
	235	);
	236	}
	237
	238	sub _slurp {
	239	my ( $self, $file ) = @_;
	240
	241	local *FH;
	242	open FH, "< $file" or die "Cannot open $file.pod: $!";
	243	do { local $/; <FH> };
	244	}
	245
	246	sub perl_version_from {
	247	my ( $self, $file ) = @_;
	248
	249	if (
	250	$self->_slurp($file) =~ m/
	251	^
	252	use \s*
	253	v?
	254	([\d_\.]+)
	255	\s* ;
	256	/ixms
	257	)
	258	{
	259	my $v = $1;
	260	$v =~ s{_}{}g;
	261	$self->perl_version($1);
	262	}
	263	else {
	264	warn "Cannot determine perl version info from $file\n";
	265	return;
	266	}
	267	}
	268
	269	sub author_from {
	270	my ( $self, $file ) = @_;
	271	my $content = $self->_slurp($file);
	272	if ($content =~ m/
	273	=head \d \s+ (?:authors?)\b \s*
	274	([^\n]*)
	275	\|
	276	=head \d \s+ (?:licen[cs]e\|licensing\|copyright\|legal)\b \s*
	277	.? copyright .? \d\d\d[\d.]+ \s* (?:\bby\b)? \s*
	278	([^\n]*)
	279	/ixms) {
	280	my $author = $1 \|\| $2;
	281	$author =~ s{E<lt>}{<}g;
	282	$author =~ s{E<gt>}{>}g;
	283	$self->author($author);
	284	}
	285	else {
	286	warn "Cannot determine author info from $file\n";
	287	}
	288	}
	289
	290	sub license_from {
	291	my ( $self, $file ) = @_;
	292
	293	if (
	294	$self->_slurp($file) =~ m/
	295	(
	296	=head \d \s+
	297	(?:licen[cs]e\|licensing\|copyright\|legal)\b
	298	.*?
	299	)
	300	(=head\\d.\|=cut.\|)
	301	\z
	302	/ixms
	303	)
	304	{
	305	my $license_text = $1;
	306	my @phrases = (
	307	'under the same (?:terms\|license) as perl itself' => 'perl', 1,
	308	'GNU public license' => 'gpl', 1,
	309	'GNU lesser public license' => 'gpl', 1,
	310	'BSD license' => 'bsd', 1,
	311	'Artistic license' => 'artistic', 1,
	312	'GPL' => 'gpl', 1,
	313	'LGPL' => 'lgpl', 1,
	314	'BSD' => 'bsd', 1,
	315	'Artistic' => 'artistic', 1,
	316	'MIT' => 'mit', 1,
	317	'proprietary' => 'proprietary', 0,
	318	);
	319	while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) {
	320	$pattern =~ s{\s+}{\\s+}g;
	321	if ( $license_text =~ /\b$pattern\b/i ) {
	322	if ( $osi and $license_text =~ /All rights reserved/i ) {
	323	warn "LEGAL WARNING: 'All rights reserved' may invalidate Open Source licenses. Consider removing it.";
258	324	}
259		}
260		return $self;
261		}
262
263		sub write {
264		my $self = shift;
265		return $self unless $self->is_admin;
266		$self->admin->write_meta;
267		return $self;
268		}
269
270		sub version_from {
271		require ExtUtils::MM_Unix;
272		my ( $self, $file ) = @_;
273		$self->version( ExtUtils::MM_Unix->parse_version($file) );
274		}
275
276		sub abstract_from {
277		require ExtUtils::MM_Unix;
278		my ( $self, $file ) = @_;
279		$self->abstract(
280		bless(
281		{ DISTNAME => $self->name },
282		'ExtUtils::MM_Unix'
283		)->parse_abstract($file)
284		);
285		}
286
287		# Add both distribution and module name
288		sub name_from {
289		my ($self, $file) = @_;
290		if (
291		Module::Install::_read($file) =~ m/
292		^ \s*
293		package \s*
294		([\w:]+)
295		\s* ;
296		/ixms
297		) {
298		my ($name, $module_name) = ($1, $1);
299		$name =~ s{::}{-}g;
300		$self->name($name);
301		unless ( $self->module_name ) {
302		$self->module_name($module_name);
303		}
304		} else {
305		die "Cannot determine name from $file\n";
306		}
307		}
308
309		sub perl_version_from {
310		my $self = shift;
311		if (
312		Module::Install::_read($_[0]) =~ m/
313		^
314		(?:use\|require) \s*
315		v?
316		([\d_\.]+)
317		\s* ;
318		/ixms
319		) {
320		my $perl_version = $1;
321		$perl_version =~ s{_}{}g;
322		$self->perl_version($perl_version);
323		} else {
324		warn "Cannot determine perl version info from $_[0]\n";
325		return;
326		}
327		}
328
329		sub author_from {
330		my $self = shift;
331		my $content = Module::Install::_read($_[0]);
332		if ($content =~ m/
333		=head \d \s+ (?:authors?)\b \s*
334		([^\n]*)
335		\|
336		=head \d \s+ (?:licen[cs]e\|licensing\|copyright\|legal)\b \s*
337		.? copyright .? \d\d\d[\d.]+ \s* (?:\bby\b)? \s*
338		([^\n]*)
339		/ixms) {
340		my $author = $1 \|\| $2;
341		$author =~ s{E<lt>}{<}g;
342		$author =~ s{E<gt>}{>}g;
343		$self->author($author);
344		} else {
345		warn "Cannot determine author info from $_[0]\n";
346		}
347		}
348
349		sub license_from {
350		my $self = shift;
351		if (
352		Module::Install::_read($_[0]) =~ m/
353		(
354		=head \d \s+
355		(?:licen[cs]e\|licensing\|copyright\|legal)\b
356		.*?
357		)
358		(=head\\d.\|=cut.\|)
359		\z
360		/ixms ) {
361		my $license_text = $1;
362		my @phrases = (
363		'under the same (?:terms\|license) as perl itself' => 'perl', 1,
364		'GNU public license' => 'gpl', 1,
365		'GNU lesser public license' => 'lgpl', 1,
366		'BSD license' => 'bsd', 1,
367		'Artistic license' => 'artistic', 1,
368		'GPL' => 'gpl', 1,
369		'LGPL' => 'lgpl', 1,
370		'BSD' => 'bsd', 1,
371		'Artistic' => 'artistic', 1,
372		'MIT' => 'mit', 1,
373		'proprietary' => 'proprietary', 0,
374		);
375		while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) {
376		$pattern =~ s{\s+}{\\s+}g;
377		if ( $license_text =~ /\b$pattern\b/i ) {
378		if ( $osi and $license_text =~ /All rights reserved/i ) {
379		print "WARNING: 'All rights reserved' in copyright may invalidate Open Source license.\n";
380		}
381		$self->license($license);
382		return 1;
383		}
384		}
385		}
386
387		warn "Cannot determine license info from $_[0]\n";
388		return 'unknown';
389		}
390
391		sub install_script {
392		my $self = shift;
393		my $args = $self->makemaker_args;
394		my $exe = $args->{EXE_FILES} \|\|= [];
395		foreach ( @_ ) {
396		if ( -f $_ ) {
397		push @$exe, $_;
398		} elsif ( -d 'script' and -f "script/$_" ) {
399		push @$exe, "script/$_";
400		} else {
401		die "Cannot find script '$_'";
402		}
403		}
	325	$self->license($license);
	326	return 1;
	327	}
	328	}
	329	}
	330
	331	warn "Cannot determine license info from $file\n";
	332	return 'unknown';
404	333	}
405	334
406	335	1;

+7

-6

inc/Module/Install/Win32.pm less more

3	3	use strict;
4	4	use Module::Install::Base;
5	5
6		use vars qw{$VERSION @ISA $ISCORE};
	6	use vars qw{$VERSION $ISCORE @ISA};
7	7	BEGIN {
8		$VERSION = '0.75';
	8	$VERSION = '0.67';
	9	$ISCORE = 1;
9	10	@ISA = qw{Module::Install::Base};
10		$ISCORE = 1;
11	11	}
12	12
13	13	# determine if the user needs nmake, and download it if needed

15	15	my $self = shift;
16	16	$self->load('can_run');
17	17	$self->load('get_file');
18
	18
19	19	require Config;
20	20	return unless (
21	21	$^O eq 'MSWin32' and

37	37	remove => 1,
38	38	);
39	39
40		die <<'END_MESSAGE' unless $rv;
	40	if (!$rv) {
	41	die <<'END_MESSAGE';
41	42
42	43	-------------------------------------------------------------------------------
43	44

57	58
58	59	-------------------------------------------------------------------------------
59	60	END_MESSAGE
60
	61	}
61	62	}
62	63
63	64	1;

+27

-24

inc/Module/Install/WriteAll.pm less more

3	3	use strict;
4	4	use Module::Install::Base;
5	5
6		use vars qw{$VERSION @ISA $ISCORE};
	6	use vars qw{$VERSION $ISCORE @ISA};
7	7	BEGIN {
8		$VERSION = '0.75';
	8	$VERSION = '0.67';
	9	$ISCORE = 1;
9	10	@ISA = qw{Module::Install::Base};
10		$ISCORE = 1;
11	11	}
12	12
13	13	sub WriteAll {
14		my $self = shift;
15		my %args = (
16		meta => 1,
17		sign => 0,
18		inline => 0,
19		check_nmake => 1,
20		@_,
21		);
	14	my $self = shift;
	15	my %args = (
	16	meta => 1,
	17	sign => 0,
	18	inline => 0,
	19	check_nmake => 1,
	20	@_
	21	);
22	22
23		$self->sign(1) if $args{sign};
24		$self->Meta->write if $args{meta};
25		$self->admin->WriteAll(%args) if $self->is_admin;
	23	$self->sign(1) if $args{sign};
	24	$self->Meta->write if $args{meta};
	25	$self->admin->WriteAll(%args) if $self->is_admin;
26	26
27		$self->check_nmake if $args{check_nmake};
28		unless ( $self->makemaker_args->{PL_FILES} ) {
29		$self->makemaker_args( PL_FILES => {} );
30		}
31
32		if ( $args{inline} ) {
33		$self->Inline->write;
34		} else {
35		$self->Makefile->write;
36		}
	27	if ( $0 =~ /Build.PL$/i ) {
	28	$self->Build->write;
	29	} else {
	30	$self->check_nmake if $args{check_nmake};
	31	unless ( $self->makemaker_args->{'PL_FILES'} ) {
	32	$self->makemaker_args( PL_FILES => {} );
	33	}
	34	if ($args{inline}) {
	35	$self->Inline->write;
	36	} else {
	37	$self->Makefile->write;
	38	}
	39	}
37	40	}
38	41
39	42	1;

+189

-261

inc/Module/Install.pm less more

16	16	# 3. The ./inc/ version of Module::Install loads
17	17	# }
18	18
19		BEGIN {
20		require 5.004;
21		}
	19	use 5.004;
22	20	use strict 'vars';
23	21
24	22	use vars qw{$VERSION};
25	23	BEGIN {
26		# All Module::Install core packages now require synchronised versions.
27		# This will be used to ensure we don't accidentally load old or
28		# different versions of modules.
29		# This is not enforced yet, but will be some time in the next few
30		# releases once we can make sure it won't clash with custom
31		# Module::Install extensions.
32		$VERSION = '0.75';
33
34		inc::Module::Install::VERSION = VERSION;
35		@inc::Module::Install::ISA = __PACKAGE__;
36
37		}
38
39
40
41
	24	# All Module::Install core packages now require synchronised versions.
	25	# This will be used to ensure we don't accidentally load old or
	26	# different versions of modules.
	27	# This is not enforced yet, but will be some time in the next few
	28	# releases once we can make sure it won't clash with custom
	29	# Module::Install extensions.
	30	$VERSION = '0.67';
	31	}
42	32
43	33	# Whether or not inc::Module::Install is actually loaded, the
44	34	# $INC{inc/Module/Install.pm} is what will still get set as long as

47	37	# they may not have a MI version that works with the Makefile.PL. This would
48	38	# result in false errors or unexpected behaviour. And we don't want that.
49	39	my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm';
50		unless ( $INC{$file} ) { die <<"END_DIE" }
51
	40	unless ( $INC{$file} ) {
	41	die <<"END_DIE";
52	42	Please invoke ${\__PACKAGE__} with:
53	43
54		use inc::${\__PACKAGE__};
	44	use inc::${\__PACKAGE__};
55	45
56	46	not:
57	47
58		use ${\__PACKAGE__};
	48	use ${\__PACKAGE__};
59	49
60	50	END_DIE
61
62
63
64
	51	}
65	52
66	53	# If the script that is loading Module::Install is from the future,
67	54	# then make will detect this and cause it to re-run over and over
68	55	# again. This is bad. Rather than taking action to touch it (which
69	56	# is unreliable on some platforms and requires write permissions)
70	57	# for now we should catch this and refuse to run.
71		if ( -f $0 and (stat($0))[9] > time ) { die <<"END_DIE" }
72
	58	if ( -f $0 and (stat($0))[9] > time ) {
	59	die << "END_DIE";
73	60	Your installer $0 has a modification time in the future.
74	61
75	62	This is known to create infinite loops in make.

77	64	Please correct this, then run $0 again.
78	65
79	66	END_DIE
80
81
82
83
84
85		# Build.PL was formerly supported, but no longer is due to excessive
86		# difficulty in implementing every single feature twice.
87		if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" }
88
89		Module::Install no longer supports Build.PL.
90
91		It was impossible to maintain duel backends, and has been deprecated.
92
93		Please remove all Build.PL files and only use the Makefile.PL installer.
94
95		END_DIE
96
97
98
99
100
101		# To save some more typing in Module::Install installers, every...
102		# use inc::Module::Install
103		# ...also acts as an implicit use strict.
104		$^H \|= strict::bits(qw(refs subs vars));
105
106
107
108
	67	}
109	68
110	69	use Cwd ();
111	70	use File::Find ();
112	71	use File::Path ();
113	72	use FindBin;
114	73
	74	inc::Module::Install::VERSION = VERSION;
	75	@inc::Module::Install::ISA = __PACKAGE__;
	76
115	77	sub autoload {
116		my $self = shift;
117		my $who = $self->_caller;
118		my $cwd = Cwd::cwd();
119		my $sym = "${who}::AUTOLOAD";
120		$sym->{$cwd} = sub {
121		my $pwd = Cwd::cwd();
122		if ( my $code = $sym->{$pwd} ) {
123		# delegate back to parent dirs
124		goto &$code unless $cwd eq $pwd;
125		}
126		$$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym";
127		unshift @_, ( $self, $1 );
128		goto &{$self->can('call')} unless uc($1) eq $1;
129		};
	78	my $self = shift;
	79	my $who = $self->_caller;
	80	my $cwd = Cwd::cwd();
	81	my $sym = "${who}::AUTOLOAD";
	82	$sym->{$cwd} = sub {
	83	my $pwd = Cwd::cwd();
	84	if ( my $code = $sym->{$pwd} ) {
	85	# delegate back to parent dirs
	86	goto &$code unless $cwd eq $pwd;
	87	}
	88	$$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym";
	89	unshift @_, ($self, $1);
	90	goto &{$self->can('call')} unless uc($1) eq $1;
	91	};
130	92	}
131	93
132	94	sub import {
133		my $class = shift;
134		my $self = $class->new(@_);
135		my $who = $self->_caller;
136
137		unless ( -f $self->{file} ) {
138		require "$self->{path}/$self->{dispatch}.pm";
139		File::Path::mkpath("$self->{prefix}/$self->{author}");
140		$self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self );
141		$self->{admin}->init;
142		@_ = ($class, _self => $self);
143		goto &{"$self->{name}::import"};
144		}
145
146		*{"${who}::AUTOLOAD"} = $self->autoload;
147		$self->preload;
148
149		# Unregister loader and worker packages so subdirs can use them again
150		delete $INC{"$self->{file}"};
151		delete $INC{"$self->{path}.pm"};
152
153		return 1;
	95	my $class = shift;
	96	my $self = $class->new(@_);
	97	my $who = $self->_caller;
	98
	99	unless ( -f $self->{file} ) {
	100	require "$self->{path}/$self->{dispatch}.pm";
	101	File::Path::mkpath("$self->{prefix}/$self->{author}");
	102	$self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self );
	103	$self->{admin}->init;
	104	@_ = ($class, _self => $self);
	105	goto &{"$self->{name}::import"};
	106	}
	107
	108	*{"${who}::AUTOLOAD"} = $self->autoload;
	109	$self->preload;
	110
	111	# Unregister loader and worker packages so subdirs can use them again
	112	delete $INC{"$self->{file}"};
	113	delete $INC{"$self->{path}.pm"};
154	114	}
155	115
156	116	sub preload {
157		my $self = shift;
158		unless ( $self->{extensions} ) {
159		$self->load_extensions(
160		"$self->{prefix}/$self->{path}", $self
161		);
162		}
163
164		my @exts = @{$self->{extensions}};
165		unless ( @exts ) {
166		my $admin = $self->{admin};
167		@exts = $admin->load_all_extensions;
168		}
169
170		my %seen;
171		foreach my $obj ( @exts ) {
172		while (my ($method, $glob) = each %{ref($obj) . '::'}) {
173		next unless $obj->can($method);
174		next if $method =~ /^_/;
175		next if $method eq uc($method);
176		$seen{$method}++;
177		}
178		}
179
180		my $who = $self->_caller;
181		foreach my $name ( sort keys %seen ) {
182		*{"${who}::$name"} = sub {
183		${"${who}::AUTOLOAD"} = "${who}::$name";
184		goto &{"${who}::AUTOLOAD"};
185		};
186		}
	117	my ($self) = @_;
	118
	119	unless ( $self->{extensions} ) {
	120	$self->load_extensions(
	121	"$self->{prefix}/$self->{path}", $self
	122	);
	123	}
	124
	125	my @exts = @{$self->{extensions}};
	126	unless ( @exts ) {
	127	my $admin = $self->{admin};
	128	@exts = $admin->load_all_extensions;
	129	}
	130
	131	my %seen;
	132	foreach my $obj ( @exts ) {
	133	while (my ($method, $glob) = each %{ref($obj) . '::'}) {
	134	next unless $obj->can($method);
	135	next if $method =~ /^_/;
	136	next if $method eq uc($method);
	137	$seen{$method}++;
	138	}
	139	}
	140
	141	my $who = $self->_caller;
	142	foreach my $name ( sort keys %seen ) {
	143	*{"${who}::$name"} = sub {
	144	${"${who}::AUTOLOAD"} = "${who}::$name";
	145	goto &{"${who}::AUTOLOAD"};
	146	};
	147	}
187	148	}
188	149
189	150	sub new {
190		my ($class, %args) = @_;
191
192		# ignore the prefix on extension modules built from top level.
193		my $base_path = Cwd::abs_path($FindBin::Bin);
194		unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) {
195		delete $args{prefix};
196		}
197
198		return $args{_self} if $args{_self};
199
200		$args{dispatch} \|\|= 'Admin';
201		$args{prefix} \|\|= 'inc';
202		$args{author} \|\|= ($^O eq 'VMS' ? '_author' : '.author');
203		$args{bundle} \|\|= 'inc/BUNDLES';
204		$args{base} \|\|= $base_path;
205		$class =~ s/^\Q$args{prefix}\E:://;
206		$args{name} \|\|= $class;
207		$args{version} \|\|= $class->VERSION;
208		unless ( $args{path} ) {
209		$args{path} = $args{name};
210		$args{path} =~ s!::!/!g;
211		}
212		$args{file} \|\|= "$args{base}/$args{prefix}/$args{path}.pm";
213		$args{wrote} = 0;
214
215		bless( \%args, $class );
	151	my ($class, %args) = @_;
	152
	153	# ignore the prefix on extension modules built from top level.
	154	my $base_path = Cwd::abs_path($FindBin::Bin);
	155	unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) {
	156	delete $args{prefix};
	157	}
	158
	159	return $args{_self} if $args{_self};
	160
	161	$args{dispatch} \|\|= 'Admin';
	162	$args{prefix} \|\|= 'inc';
	163	$args{author} \|\|= ($^O eq 'VMS' ? '_author' : '.author');
	164	$args{bundle} \|\|= 'inc/BUNDLES';
	165	$args{base} \|\|= $base_path;
	166	$class =~ s/^\Q$args{prefix}\E:://;
	167	$args{name} \|\|= $class;
	168	$args{version} \|\|= $class->VERSION;
	169	unless ( $args{path} ) {
	170	$args{path} = $args{name};
	171	$args{path} =~ s!::!/!g;
	172	}
	173	$args{file} \|\|= "$args{base}/$args{prefix}/$args{path}.pm";
	174
	175	bless( \%args, $class );
216	176	}
217	177
218	178	sub call {

223	183	}
224	184
225	185	sub load {
226		my ($self, $method) = @_;
227
228		$self->load_extensions(
229		"$self->{prefix}/$self->{path}", $self
230		) unless $self->{extensions};
231
232		foreach my $obj (@{$self->{extensions}}) {
233		return $obj if $obj->can($method);
234		}
235
236		my $admin = $self->{admin} or die <<"END_DIE";
	186	my ($self, $method) = @_;
	187
	188	$self->load_extensions(
	189	"$self->{prefix}/$self->{path}", $self
	190	) unless $self->{extensions};
	191
	192	foreach my $obj (@{$self->{extensions}}) {
	193	return $obj if $obj->can($method);
	194	}
	195
	196	my $admin = $self->{admin} or die <<"END_DIE";
237	197	The '$method' method does not exist in the '$self->{prefix}' path!
238	198	Please remove the '$self->{prefix}' directory and run $0 again to load it.
239	199	END_DIE
240	200
241		my $obj = $admin->load($method, 1);
242		push @{$self->{extensions}}, $obj;
243
244		$obj;
	201	my $obj = $admin->load($method, 1);
	202	push @{$self->{extensions}}, $obj;
	203
	204	$obj;
245	205	}
246	206
247	207	sub load_extensions {
248		my ($self, $path, $top) = @_;
249
250		unless ( grep { lc $_ eq lc $self->{prefix} } @INC ) {
251		unshift @INC, $self->{prefix};
252		}
253
254		foreach my $rv ( $self->find_extensions($path) ) {
255		my ($file, $pkg) = @{$rv};
256		next if $self->{pathnames}{$pkg};
257
258		local $@;
259		my $new = eval { require $file; $pkg->can('new') };
260		unless ( $new ) {
261		warn $@ if $@;
262		next;
263		}
264		$self->{pathnames}{$pkg} = delete $INC{$file};
265		push @{$self->{extensions}}, &{$new}($pkg, _top => $top );
266		}
267
268		$self->{extensions} \|\|= [];
	208	my ($self, $path, $top) = @_;
	209
	210	unless ( grep { lc $_ eq lc $self->{prefix} } @INC ) {
	211	unshift @INC, $self->{prefix};
	212	}
	213
	214	foreach my $rv ( $self->find_extensions($path) ) {
	215	my ($file, $pkg) = @{$rv};
	216	next if $self->{pathnames}{$pkg};
	217
	218	local $@;
	219	my $new = eval { require $file; $pkg->can('new') };
	220	unless ( $new ) {
	221	warn $@ if $@;
	222	next;
	223	}
	224	$self->{pathnames}{$pkg} = delete $INC{$file};
	225	push @{$self->{extensions}}, &{$new}($pkg, _top => $top );
	226	}
	227
	228	$self->{extensions} \|\|= [];
269	229	}
270	230
271	231	sub find_extensions {
272		my ($self, $path) = @_;
273
274		my @found;
275		File::Find::find( sub {
276		my $file = $File::Find::name;
277		return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is;
278		my $subpath = $1;
279		return if lc($subpath) eq lc($self->{dispatch});
280
281		$file = "$self->{path}/$subpath.pm";
282		my $pkg = "$self->{name}::$subpath";
283		$pkg =~ s!/!::!g;
284
285		# If we have a mixed-case package name, assume case has been preserved
286		# correctly. Otherwise, root through the file to locate the case-preserved
287		# version of the package name.
288		if ( $subpath eq lc($subpath) \|\| $subpath eq uc($subpath) ) {
289		my $content = Module::Install::_read($subpath . '.pm');
290		my $in_pod = 0;
291		foreach ( split //, $content ) {
292		$in_pod = 1 if /^=\w/;
293		$in_pod = 0 if /^=cut/;
294		next if ($in_pod \|\| /^=cut/); # skip pod text
295		next if /^\s*#/; # and comments
296		if ( m/^\spackage\s+($pkg)\s;/i ) {
297		$pkg = $1;
298		last;
299		}
300		}
301		}
302
303		push @found, [ $file, $pkg ];
304		}, $path ) if -d $path;
305
306		@found;
307		}
308
309
310
311
312
313		#####################################################################
314		# Utility Functions
	232	my ($self, $path) = @_;
	233
	234	my @found;
	235	File::Find::find( sub {
	236	my $file = $File::Find::name;
	237	return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is;
	238	my $subpath = $1;
	239	return if lc($subpath) eq lc($self->{dispatch});
	240
	241	$file = "$self->{path}/$subpath.pm";
	242	my $pkg = "$self->{name}::$subpath";
	243	$pkg =~ s!/!::!g;
	244
	245	# If we have a mixed-case package name, assume case has been preserved
	246	# correctly. Otherwise, root through the file to locate the case-preserved
	247	# version of the package name.
	248	if ( $subpath eq lc($subpath) \|\| $subpath eq uc($subpath) ) {
	249	open PKGFILE, "<$subpath.pm" or die "find_extensions: Can't open $subpath.pm: $!";
	250	my $in_pod = 0;
	251	while ( <PKGFILE> ) {
	252	$in_pod = 1 if /^=\w/;
	253	$in_pod = 0 if /^=cut/;
	254	next if ($in_pod \|\| /^=cut/); # skip pod text
	255	next if /^\s*#/; # and comments
	256	if ( m/^\spackage\s+($pkg)\s;/i ) {
	257	$pkg = $1;
	258	last;
	259	}
	260	}
	261	close PKGFILE;
	262	}
	263
	264	push @found, [ $file, $pkg ];
	265	}, $path ) if -d $path;
	266
	267	@found;
	268	}
315	269
316	270	sub _caller {
317		my $depth = 0;
318		my $call = caller($depth);
319		while ( $call eq __PACKAGE__ ) {
320		$depth++;
321		$call = caller($depth);
322		}
323		return $call;
324		}
325
326		sub _read {
327		local *FH;
328		open FH, "< $_[0]" or die "open($_[0]): $!";
329		my $str = do { local $/; <FH> };
330		close FH or die "close($_[0]): $!";
331		return $str;
332		}
333
334		sub _write {
335		local *FH;
336		open FH, "> $_[0]" or die "open($_[0]): $!";
337		foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!" }
338		close FH or die "close($_[0]): $!";
339		}
340
341		sub _version {
342		my $s = shift \|\| 0;
343		$s =~ s/^(\d+)\.?//;
344		my $l = $1 \|\| 0;
345		my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g;
346		$l = $l . '.' . join '', @v if @v;
347		return $l + 0;
	271	my $depth = 0;
	272	my $call = caller($depth);
	273	while ( $call eq __PACKAGE__ ) {
	274	$depth++;
	275	$call = caller($depth);
	276	}
	277	return $call;
348	278	}
349	279
350	280	1;
351
352		# Copyright 2008 Adam Kennedy.

+237

-0

lib/Moose/Cookbook/Basics/Recipe1.pod less more

	0
	1	=pod
	2
	3	=head1 NAME
	4
	5	Moose::Cookbook::Basics::Recipe1 - The (always classic) B<Point> example.
	6
	7	=head1 SYNOPSIS
	8
	9	package Point;
	10	use Moose;
	11
	12	has 'x' => (isa => 'Int', is => 'ro');
	13	has 'y' => (isa => 'Int', is => 'rw');
	14
	15	sub clear {
	16	my $self = shift;
	17	$self->{x} = 0;
	18	$self->y(0);
	19	}
	20
	21	package Point3D;
	22	use Moose;
	23
	24	extends 'Point';
	25
	26	has 'z' => (isa => 'Int');
	27
	28	after 'clear' => sub {
	29	my $self = shift;
	30	$self->{z} = 0;
	31	};
	32
	33	=head1 DESCRIPTION
	34
	35	This is the classic Point example. This one in particular I took
	36	from the Perl 6 Apocalypse 12 document, but it is similar to the
	37	example found in the classic K&R C book as well, and many other
	38	places. And now, onto the code:
	39
	40	As with all Perl 5 classes, a Moose class is defined in a package.
	41	Moose now handles turning on C<strict> and C<warnings> for you, so
	42	all you need to do is say C<use Moose>, and no kittens will die.
	43
	44	By loading Moose, we are enabling the loading of the Moose
	45	"environment" into our package. This means that we import some
	46	functions which serve as Moose "keywords". These aren't anything
	47	fancy, just plain old exported functions.
	48
	49	Another important thing happens at this stage as well. Moose will
	50	automatically set your package's superclass to be L<Moose::Object>.
	51	The reason we do this, is so that we can be sure that your class
	52	will inherit from L<Moose::Object> and get the benefits that
	53	provides (such as a constructor; see L<Moose::Object> for details).
	54	However, you don't actually I<have> to inherit from L<Moose::Object>
	55	if you don't want to. All Moose features will still be accessible to
	56	you.
	57
	58	Now, onto the keywords. The first one we see here is C<has>, which
	59	defines an instance attribute in your class:
	60
	61	has 'x' => (isa => 'Int', is => 'ro');
	62
	63	This will create an attribute named C<x>, which will expect the
	64	value stored in the attribute to pass the type constraint C<Int> (1),
	65	and the accessor generated for this attribute will be read-only
	66	(abbreviated as C<ro>).
	67
	68	The next C<has> line is very similar, with only one difference:
	69
	70	has 'y' => (isa => 'Int', is => 'rw');
	71
	72	A read/write (abbreviated as C<rw>) accessor will be generated for
	73	the C<y> attribute.
	74
	75	At this point the attributes have been defined, and it is time to
	76	define our methods. In Moose, as with regular Perl 5 OO, a method
	77	is just a subroutine defined within the package. So here we create
	78	the C<clear> method.
	79
	80	sub clear {
	81	my $self = shift;
	82	$self->{x} = 0;
	83	$self->y(0);
	84	}
	85
	86	It is pretty standard, the only thing to note is that we are directly
	87	accessing the C<x> slot in the instance L<(2)>. This is because the
	88	value was created with a read-only accessor. This also shows that Moose
	89	objects are not anything out of the ordinary, but just regular old
	90	blessed HASH references. This means they are very compatible with
	91	other Perl 5 (non-Moose) classes as well.
	92
	93	The next part of the code to review is the B<Point> subclass,
	94	B<Point3D>. The first item you might notice is that we do not use
	95	the standard C<use base> declaration here. Instead we use the Moose
	96	keyword C<extends> like so:
	97
	98	extends 'Point';
	99
	100	This keyword will function very much like C<use base> does in that
	101	it will make an attempt to load your class if it has not already been
	102	loaded. However, it differs on one important point. The C<extends>
	103	keyword will overwrite any previous values in your package's C<@ISA>,
	104	where C<use base> will C<push> values onto the package's C<@ISA>. It
	105	is my opinion that the behavior of C<extends> is more intuitive in
	106	that it is more explicit about defining the superclass relationship.
	107
	108	A small digression here: both Moose and C<extends> support multiple
	109	inheritance. You simply pass all the superclasses to C<extends>,
	110	like so:
	111
	112	extends 'Foo', 'Bar', 'Baz';
	113
	114	Now, back to our B<Point3D> class. The next thing we do is to create
	115	a new attribute for B<Point3D> called C<z>.
	116
	117	has 'z' => (isa => 'Int');
	118
	119	As with B<Point>'s C<x> and C<y> attributes, this attribute has a
	120	type constraint of C<Int>, but it differs in that it does B<not>
	121	ask for any autogenerated accessors. The result being (aside from
	122	broken object encapsulation) that C<z> is a private attribute.
	123
	124	Next comes another Moose feature which we call method "modifiers"
	125	(or method "advice" for the AOP inclined). The modifier used here
	126	is the C<after> modifier, and looks like this:
	127
	128	after 'clear' => sub {
	129	my $self = shift;
	130	$self->{z} = 0;
	131	};
	132
	133	This modifier tells Moose to install a C<clear> method for
	134	B<Point3D> that will first run the C<clear> method for the
	135	superclass (in this case C<Point::clear>), and then run this
	136	method I<after> it (passing in the same arguments as the original
	137	method).
	138
	139	Now, of course using the C<after> modifier is not the only way to
	140	accomplish this. I mean, after all, this B<is> Perl right? You
	141	would get the same results with this code:
	142
	143	sub clear {
	144	my $self = shift;
	145	$self->SUPER::clear();
	146	$self->{z} = 0;
	147	}
	148
	149	You could also use another Moose method modifier, C<override> here,
	150	and get the same results again. Here is how that would look:
	151
	152	override 'clear' => sub {
	153	my $self = shift;
	154	super();
	155	$self->{z} = 0;
	156	};
	157
	158	The C<override> modifier allows you to use the C<super> keyword
	159	within it to dispatch to the superclass's method in a very Ruby-ish
	160	style.
	161
	162	Now, of course, what use is a class if you can't instantiate objects
	163	with it? Since B<Point> inherits from L<Moose::Object>, it will also
	164	inherit the default L<Moose::Object> constructor: C<new>. Here
	165	are two examples of how that is used:
	166
	167	my $point = Point->new(x => 1, y => 2);
	168	my $point3d = Point3D->new(x => 1, y => 2, z => 3);
	169
	170	As you can see, C<new> accepts named argument pairs for any of the
	171	attributes. It does not I<require> that you pass in the all the
	172	attributes, and it will politely ignore any named arguments it does
	173	not recognize.
	174
	175	From here on, you can use C<$point> and C<$point3d> just as you would
	176	any other Perl 5 object. For a more detailed example of what can be
	177	done, you can refer to the F<t/000_recipes/001_recipe.t> test file.
	178
	179	=head1 CONCLUSION
	180
	181	I hope this recipe has given you some explanation of how to use
	182	Moose to build your Perl 5 classes. The next recipe will build upon
	183	the basics shown here with more complex attributes and methods.
	184	Please read on :)
	185
	186	=head1 FOOTNOTES
	187
	188	=over 4
	189
	190	=item (1)
	191
	192	Several default type constraints are provided by Moose, of which
	193	C<Int> is one. For more information on the builtin type constraints
	194	and the type constraint system in general, see the
	195	L<Moose::Util::TypeConstraints> documentation.
	196
	197	=item (2)
	198
	199	Moose supports using instance structures other than blessed hash
	200	references (such as in a glob reference -- see
	201	L<MooseX::GlobRef::Object>). If you want your Moose classes to
	202	be interchangeable, it is advisable to avoid direct instance
	203	access, like that shown above. Moose does let you get and set
	204	attributes directly without exposing the instance structure, but
	205	that's an advanced topic (intrepid readers should refer to the
	206	L<Moose::Meta::Attribute documentation>).
	207
	208	=back
	209
	210	=head1 SEE ALSO
	211
	212	=over 4
	213
	214	=item Method Modifiers
	215
	216	The concept of method modifiers is directly ripped off from CLOS. A
	217	great explanation of them can be found by following this link.
	218
	219	L<http://www.gigamonkeys.com/book/object-reorientation-generic-functions.html>
	220
	221	=back
	222
	223	=head1 AUTHOR
	224
	225	Stevan Little E<lt>stevan@iinteractive.comE<gt>
	226
	227	=head1 COPYRIGHT AND LICENSE
	228
	229	Copyright 2006-2008 by Infinity Interactive, Inc.
	230
	231	L<http://www.iinteractive.com>
	232
	233	This library is free software; you can redistribute it and/or modify
	234	it under the same terms as Perl itself.
	235
	236	=cut⏎

+308

-0

lib/Moose/Cookbook/Basics/Recipe10.pod less more

	0
	1	=pod
	2
	3	=head1 NAME
	4
	5	Moose::Cookbook::Basics::Recipe10 - Operator overloading, subtypes, and coercion
	6
	7	=head1 SYNOPSIS
	8
	9	package Human;
	10
	11	use Moose;
	12	use Moose::Util::TypeConstraints;
	13
	14	subtype 'Gender'
	15	=> as 'Str'
	16	=> where { $_ =~ m{^[mf]$}s };
	17
	18	has 'gender' => ( is => 'ro', isa => 'Gender', required => 1 );
	19
	20	has 'mother' => ( is => 'ro', isa => 'Human' );
	21	has 'father' => ( is => 'ro', isa => 'Human' );
	22
	23	use overload '+' => \&_overload_add, fallback => 1;
	24
	25	sub _overload_add {
	26	my ($one, $two) = @_;
	27
	28	die('Only male and female humans may create children')
	29	if ($one->gender() eq $two->gender());
	30
	31	my ( $mother, $father ) = ( $one->gender eq 'f' ? ($one, $two) : ($two, $one) );
	32
	33	my $gender = 'f';
	34	$gender = 'm' if (rand() >= 0.5);
	35
	36	return Human->new(
	37	gender => $gender,
	38	mother => $mother,
	39	father => $father,
	40	);
	41	}
	42
	43	=head1 DESCRIPTION
	44
	45	This Moose cookbook recipe shows how operator overloading, coercion,
	46	and sub types can be used to mimic the human reproductive system
	47	(well, the selection of genes at least). Assumes a basic
	48	understanding of Moose.
	49
	50	=head1 INTRODUCTION
	51
	52	The example in the SYNOPSIS outlines a very basic use of
	53	operator overloading and Moose. The example creates a class
	54	that allows you to add together two humans and produce a
	55	child from them.
	56
	57	The two parents must be of the opposite gender, as to do
	58	otherwise wouldn't be biologically possible no matter how much
	59	I might want to allow it.
	60
	61	While this example works and gets the job done, it really isn't
	62	all that useful. To take this a step further let's play around
	63	with genes. Particularly the genes that dictate eye color. Why
	64	eye color? Because it is simple. There are two genes that have
	65	the most affect on eye color and each person carries two of each
	66	gene. Now that will be useful!
	67
	68	Oh, and don't forget that you were promised some coercion goodness.
	69
	70	=head1 TECHNIQUES
	71
	72	First, let's quickly define the techniques that will be used.
	73
	74	=head2 Operator Overloading
	75
	76	Overloading operators takes a simple declaration of which operator
	77	you want to overload and what method to call. See the perldoc for
	78	overload to see some good, basic, examples.
	79
	80	=head2 Subtypes
	81
	82	Moose comes with 21 default type constraints, as documented in
	83	L<Moose::Util::TypeConstraints>. Int, Str, and CodeRef are
	84	all examples. Subtypes give you the ability to inherit the
	85	constraints of an existing type, and adding additional
	86	constraints on that type. An introduction to type constraints
	87	is available in the L<Moose::Cookbook::Basics::Recipe4>.
	88
	89	=head2 Coercion
	90
	91	When an attribute is assigned a value its type constraint
	92	is checked to validate the value. Normally, if the value
	93	does not pass the constraint, an exception will be thrown.
	94	But, it is possible with Moose to define the rules to coerce
	95	values from one type to another. A good introduction to
	96	this can be found in L<Moose::Cookbook::Basics::Recipe5>.
	97
	98	=head1 GENES
	99
	100	As I alluded to in the introduction, there are many different
	101	genes that affect eye color. But, there are 2 genes that play
	102	the most prominent role: gey and bey2. To get started let us
	103	make classes for these genes.
	104
	105	=head2 bey2
	106
	107	package Human::Gene::bey2;
	108
	109	use Moose;
	110	use Moose::Util::TypeConstraints;
	111
	112	type 'bey2Color' => where { $_ =~ m{^(?:brown\|blue)$}s };
	113
	114	has 'color' => ( is => 'ro', isa => 'bey2Color' );
	115
	116	This class is really simple. All we need to know about the bey2
	117	gene is whether it is of the blue or brown variety. As you can
	118	see a type constraint for the color attribute has been created
	119	which validates for the two possible colors.
	120
	121	=head2 gey
	122
	123	package Human::Gene::gey;
	124
	125	use Moose;
	126	use Moose::Util::TypeConstraints;
	127
	128	type 'geyColor' => where { $_ =~ m{^(?:green\|blue)$}s };
	129
	130	has 'color' => ( is => 'ro', isa => 'geyColor' );
	131
	132	The gey gene is nearly identical to the bey2, except that it
	133	has a green or blue variety.
	134
	135	=head1 EYE COLOR
	136
	137	Rather than throwing the 4 gene object (2xbey, 2xgey2) straight
	138	on to the Human class, let's create an intermediate class that
	139	abstracts the logic behind eye color. This way the Human class
	140	won't get all cluttered up with the details behind the different
	141	characteristics that makes up a Human.
	142
	143	package Human::EyeColor;
	144
	145	use Moose;
	146	use Moose::Util::TypeConstraints;
	147
	148	subtype 'bey2Gene'
	149	=> as 'Object'
	150	=> where { $_->isa('Human::Gene::bey2') };
	151
	152	coerce 'bey2Gene'
	153	=> from 'Str'
	154	=> via { Human::Gene::bey2->new( color => $_ ) };
	155
	156	subtype 'geyGene'
	157	=> as 'Object'
	158	=> where { $_->isa('Human::Gene::gey') };
	159
	160	coerce 'geyGene'
	161	=> from 'Str'
	162	=> via { Human::Gene::gey->new( color => $_ ) };
	163
	164	has 'bey2_1' => ( is => 'ro', isa => 'bey2Gene', coerce => 1 );
	165	has 'bey2_2' => ( is => 'ro', isa => 'bey2Gene', coerce => 1 );
	166
	167	has 'gey_1' => ( is => 'ro', isa => 'geyGene', coerce => 1 );
	168	has 'gey_2' => ( is => 'ro', isa => 'geyGene', coerce => 1 );
	169
	170	So, we now have a class that can hold the four genes that dictate
	171	eye color. This isn't quite enough, as we also need to calculate
	172	what the human's actual eye color is as a result of the genes.
	173
	174	As with most genes there are recessive and dominant genes. The bey2
	175	brown gene is dominant to both blue and green. The gey green gene is
	176	recessive to the brown bey gene and dominant to the blues. Finally,
	177	the bey and gey2 blue genes are recessive to both brown and green.
	178
	179	sub color {
	180	my ( $self ) = @_;
	181
	182	return 'brown' if ($self->bey2_1->color() eq 'brown' or $self->bey2_2->color() eq 'brown');
	183	return 'green' if ($self->gey_1->color() eq 'green' or $self->gey_2->color() eq 'green');
	184	return 'blue';
	185	}
	186
	187	To top it off, if I want to access color(), I want to be really lazy
	188	about it. Perl overloading supports the ability to overload the
	189	stringification of an object. So, normally if I did "$eye_color"
	190	I'd get something like "Human::EyeColor=HASH(0xba9348)". What I
	191	really want is "brown", "green", or "blue". To do this you overload
	192	the stringification of the object.
	193
	194	use overload '""' => \&color, fallback => 1;
	195
	196	That's all and good, but don't forget the spawn! Our
	197	humans have to have children, and those children need to inherit
	198	genes from their parents. Let's use operator overloading so
	199	that we can add (+) together two EyeColor characteristics to
	200	create a new EyeColor that is derived in a similar manner as
	201	the gene selection in human reproduction.
	202
	203	use overload '+' => \&_overload_add, fallback => 1;
	204
	205	sub _overload_add {
	206	my ($one, $two) = @_;
	207
	208	my $one_bey2 = 'bey2_' . _rand2();
	209	my $two_bey2 = 'bey2_' . _rand2();
	210
	211	my $one_gey = 'gey_' . _rand2();
	212	my $two_gey = 'gey_' . _rand2();
	213
	214	return Human::EyeColor->new(
	215	bey2_1 => $one->$one_bey2->color(),
	216	bey2_2 => $two->$two_bey2->color(),
	217	gey_1 => $one->$one_gey->color(),
	218	gey_2 => $two->$two_gey->color(),
	219	);
	220	}
	221
	222	sub _rand2 {
	223	return 1 + int( rand(2) );
	224	}
	225
	226	What is happening here is we are overloading the addition
	227	operator. When two eye color objects are added together
	228	the _overload_add() method will be called with the two
	229	objects on the left and right side of the + as arguments.
	230	The return value of this method should be the expected
	231	result of the addition. I'm not going to go in to the
	232	details of how the gene's are selected as it should be
	233	fairly self-explanatory.
	234
	235	=head1 HUMAN EVOLUTION
	236
	237	Our original human class in the SYNOPSIS requires very little
	238	change to support the new EyeColor characteristic. All we
	239	need to do is define a new subtype called EyeColor, a new
	240	attribute called eye_color, and just for the sake of simple code
	241	we'll coerce an arrayref of colors in to an EyeColor object.
	242
	243	use List::MoreUtils qw( zip );
	244
	245	subtype 'EyeColor'
	246	=> as 'Object'
	247	=> where { $_->isa('Human::EyeColor') };
	248
	249	coerce 'EyeColor'
	250	=> from 'ArrayRef'
	251	=> via {
	252	my @genes = qw( bey2_1 bey2_2 gey_1 gey_2 );
	253	return Human::EyeColor->new( zip( @genes, @$_ ) );
	254	};
	255
	256	has 'eye_color' => ( is => 'ro', isa => 'EyeColor', coerce => 1, required => 1 );
	257
	258	And then in the _overload_add() of the Human class we modify
	259	the creation of the child object to include the addition of
	260	the mother and father's eye colors.
	261
	262	return Human->new(
	263	gender => $gender,
	264	eye_color => ( $one->eye_color() + $two->eye_color() ),
	265	mother => $mother,
	266	father => $father,
	267	);
	268
	269	=head1 CONCLUSION
	270
	271	The three techniques used in this article - overloading, subtypes,
	272	and coercion - provide the power to produce simple, flexible, powerful,
	273	explicit, inheritable, and enjoyable interfaces.
	274
	275	If you want to get your hands on this code all combined together, and
	276	working, download the Moose tarball and look at "t/000_recipes/012_genes.t".
	277
	278	=head1 NEXT STEPS
	279
	280	Has this been a real project we'd probably want to:
	281
	282	=over 4
	283
	284	=item Better Randomization with Crypt::Random
	285
	286	=item Characteristic Base Class
	287
	288	=item Mutating Genes
	289
	290	=item More Characteristics
	291
	292	=item Artificial Life
	293
	294	=back
	295
	296	=head1 AUTHOR
	297
	298	Aran Clary Deltac <bluefeet@cpan.org>
	299
	300	=head1 LICENSE
	301
	302	This work is licensed under a Creative Commons Attribution 3.0 Unported License.
	303
	304	License details are at: L<http://creativecommons.org/licenses/by/3.0/>
	305
	306	=cut
	307

+211

-0

lib/Moose/Cookbook/Basics/Recipe2.pod less more

	0
	1	=pod
	2
	3	=head1 NAME
	4
	5	Moose::Cookbook::Basics::Recipe2 - A simple B<BankAccount> example
	6
	7	=head1 SYNOPSIS
	8
	9	package BankAccount;
	10	use Moose;
	11
	12	has 'balance' => (isa => 'Int', is => 'rw', default => 0);
	13
	14	sub deposit {
	15	my ($self, $amount) = @_;
	16	$self->balance($self->balance + $amount);
	17	}
	18
	19	sub withdraw {
	20	my ($self, $amount) = @_;
	21	my $current_balance = $self->balance();
	22	($current_balance >= $amount)
	23	\|\| confess "Account overdrawn";
	24	$self->balance($current_balance - $amount);
	25	}
	26
	27	package CheckingAccount;
	28	use Moose;
	29
	30	extends 'BankAccount';
	31
	32	has 'overdraft_account' => (isa => 'BankAccount', is => 'rw');
	33
	34	before 'withdraw' => sub {
	35	my ($self, $amount) = @_;
	36	my $overdraft_amount = $amount - $self->balance();
	37	if ($self->overdraft_account && $overdraft_amount > 0) {
	38	$self->overdraft_account->withdraw($overdraft_amount);
	39	$self->deposit($overdraft_amount);
	40	}
	41	};
	42
	43	=head1 DESCRIPTION
	44
	45	In the first recipe we demonstrated the construction of basic
	46	Moose classes whose attributes had various accessor schemes and
	47	builtin type constraints. However, our objects were very data-
	48	oriented, and did not have many behavioral aspects (i.e. methods)
	49	to them. In this recipe, we will expand upon the concepts from
	50	the first recipe and give a more realistic scenario of more
	51	behavior oriented classes.
	52
	53	We are using the example of a bank account, which has a standard
	54	account (you can deposit money, withdraw money and check your
	55	current balance), and a checking account which has optional
	56	overdraft protection. The overdraft protection will protect the
	57	owner of the checking account by automatically withdrawing the
	58	needed funds from the overdraft account to ensure that a check
	59	will not bounce.
	60
	61	Now, onto the code. The first class, B<BankAccount>, introduces a
	62	new attribute feature: a default value.
	63
	64	has 'balance' => (isa => 'Int', is => 'rw', default => 0);
	65
	66	This tells us that a B<BankAccount> has a C<balance> attribute,
	67	which has the C<Int> type constraint, a read/write accessor,
	68	and a default value of C<0>. This means that every instance of
	69	B<BankAccount> that is created will have its C<balance> slot
	70	initialized to C<0>. Very simple really :)
	71
	72	Next come the methods. The C<deposit> and C<withdraw> methods
	73	should be fairly self-explanatory; they are nothing specific to
	74	Moose, just your standard Perl 5 OO.
	75
	76	Now, onto the B<CheckingAccount> class. As you know from the
	77	first recipe, the keyword C<extends> sets a class's superclass
	78	relationship. Here we see that B<CheckingAccount> is a
	79	B<BankAccount>. The next line introduces yet another new aspect
	80	of Moose, that of class-based type-constraints:
	81
	82	has 'overdraft_account' => (isa => 'BankAccount', is => 'rw');
	83
	84	Up until now, we have only had C<Int> type constraints, which
	85	(as I said in the first recipe) is a builtin type constraint
	86	that Moose provides for you. The C<BankAccount> type constraint
	87	is new, and was actually defined the moment we created the
	88	B<BankAccount> class itself. In fact, for every class in
	89	your program, a corresponding type constraint will be created. This
	90	means that in the first recipe, both C<Point> and C<Point3D> type
	91	constraints were created, and in this recipe, both C<BankAccount>
	92	and C<CheckingAccount> type constraints were created. Moose does
	93	this as a convenience so that your class model and the type
	94	constraint model can be kept in sync with one another. In short,
	95	Moose makes sure that it will just DWIM (1).
	96
	97	Next, we come to the behavioral part of B<CheckingAccount>, and
	98	again we see a method modifier, but this time it is a C<before>
	99	modifier.
	100
	101	before 'withdraw' => sub {
	102	my ($self, $amount) = @_;
	103	my $overdraft_amount = $amount - $self->balance();
	104	if ($self->overdraft_account && $overdraft_amount > 0) {
	105	$self->overdraft_account->withdraw($overdraft_amount);
	106	$self->deposit($overdraft_amount);
	107	}
	108	};
	109
	110	Just as with the C<after> modifier from the first recipe, Moose
	111	will handle calling the superclass method (in this case the
	112	C<BankAccount::withdraw> method). The C<before> modifier shown
	113	above will run (obviously) I<before> the code from the superclass
	114	with run. The C<before> modifier here implements the overdraft
	115	protection by first checking if there are enough available
	116	funds in the checking account and if not (and if there is an overdraft
	117	account available), it transfers the appropriate funds into the
	118	checking account.
	119
	120	As with the method modifier in the first recipe, there is another
	121	way to accomplish this same thing using the built in C<SUPER::>
	122	pseudo-package. So the above method is equivalent to the one here.
	123
	124	sub withdraw {
	125	my ($self, $amount) = @_;
	126	my $overdraft_amount = $amount - $self->balance();
	127	if ($self->overdraft_account && $overdraft_amount > 0) {
	128	$self->overdraft_account->withdraw($overdraft_amount);
	129	$self->deposit($overdraft_amount);
	130	}
	131	$self->SUPER::withdraw($amount);
	132	}
	133
	134	The benefits of taking the method modifier approach is that the
	135	author of the B<BankAccount> subclass does not need to remember
	136	to call C<SUPER::withdraw> and to pass it the C<$amount> argument.
	137	Instead the method modifier ensures that all arguments make it
	138	to the superclass method correctly. But this is actually more
	139	than just a convenience for forgetful programmers, it also helps
	140	isolate subclasses from changes in the superclasses. For instance,
	141	if B<BankAccount::withdraw> were to add an additional argument
	142	of some kind, the version of B<CheckingAccount::withdraw> which
	143	uses C<SUPER::withdraw> would not pass that extra argument
	144	correctly, whereas the method modifier version would automatically
	145	pass along all arguments correctly.
	146
	147	Just as with the first recipe, object instantiation is a fairly
	148	normal process, here is an example:
	149
	150	my $savings_account = BankAccount->new(balance => 250);
	151	my $checking_account = CheckingAccount->new(
	152	balance => 100,
	153	overdraft_account => $savings_account
	154	);
	155
	156	And as with the first recipe, a more in-depth example of using
	157	these classes can be found in the F<t/000_recipes/002_recipe.t> test file.
	158
	159	=head1 CONCLUSION
	160
	161	The aim of this recipe was to take the knowledge gained in the
	162	first recipe and expand upon it with a more realistic use case. I
	163	hope that this recipe has accomplished this goal. The next recipe
	164	will expand even more upon the capabilities of attributes in Moose
	165	to create a behaviorally sophisticated class almost entirely
	166	defined by attributes.
	167
	168	=head1 FOOTNOTES
	169
	170	=over 4
	171
	172	=item (1)
	173
	174	Moose does not attempt to encode a class's is-a relationships
	175	within the type constraint hierarchy. Instead, Moose just
	176	considers the class type constraint to be a subtype of C<Object>,
	177	and specializes the constraint check to allow for subclasses. This
	178	means that an instance of B<CheckingAccount> will pass a
	179	C<BankAccount> type constraint successfully. For more details,
	180	please refer to the L<Moose::Util::TypeConstraints> documentation.
	181
	182	=back
	183
	184	=head1 SEE ALSO
	185
	186	=over 4
	187
	188	=item Acknowledgment
	189
	190	The BankAccount example in this recipe is directly taken from the
	191	examples in this chapter of "Practical Common Lisp":
	192
	193	L<http://www.gigamonkeys.com/book/object-reorientation-generic-functions.html>
	194
	195	=back
	196
	197	=head1 AUTHOR
	198
	199	Stevan Little E<lt>stevan@iinteractive.comE<gt>
	200
	201	=head1 COPYRIGHT AND LICENSE
	202
	203	Copyright 2006-2008 by Infinity Interactive, Inc.
	204
	205	L<http://www.iinteractive.com>
	206
	207	This library is free software; you can redistribute it and/or modify
	208	it under the same terms as Perl itself.
	209
	210	=cut

+240

-0

lib/Moose/Cookbook/Basics/Recipe3.pod less more

	0
	1	=pod
	2
	3	=head1 NAME
	4
	5	Moose::Cookbook::Basics::Recipe3 - A lazy B<BinaryTree> example
	6
	7	=head1 SYNOPSIS
	8
	9	package BinaryTree;
	10	use Moose;
	11
	12	has 'node' => (is => 'rw', isa => 'Any');
	13
	14	has 'parent' => (
	15	is => 'rw',
	16	isa => 'BinaryTree',
	17	predicate => 'has_parent',
	18	weak_ref => 1,
	19	);
	20
	21	has 'left' => (
	22	is => 'rw',
	23	isa => 'BinaryTree',
	24	predicate => 'has_left',
	25	lazy => 1,
	26	default => sub { BinaryTree->new(parent => $_[0]) },
	27	);
	28
	29	has 'right' => (
	30	is => 'rw',
	31	isa => 'BinaryTree',
	32	predicate => 'has_right',
	33	lazy => 1,
	34	default => sub { BinaryTree->new(parent => $_[0]) },
	35	);
	36
	37	before 'right', 'left' => sub {
	38	my ($self, $tree) = @_;
	39	$tree->parent($self) if defined $tree;
	40	};
	41
	42	=head1 DESCRIPTION
	43
	44	In this recipe we take a closer look at attributes, and see how
	45	some of their more advanced features can be used to create fairly
	46	complex behaviors.
	47
	48	The class in this recipe is a classic binary tree, each node in the
	49	tree is represented by an instance of the B<BinaryTree> class. Each
	50	instance has a C<node> slot to hold an arbitrary value, a C<right>
	51	slot to hold the right node, a C<left> slot to hold the left node,
	52	and finally a C<parent> slot to hold a reference back up the tree.
	53
	54	Now, let's start with the code. Our first attribute is the C<node>
	55	slot, defined as such:
	56
	57	has 'node' => (is => 'rw', isa => 'Any');
	58
	59	If you recall from the previous recipes, this slot will have a read/write
	60	accessor generated for it, and has a type constraint on it. The new item here is
	61	the type constraint of C<Any>. C<Any> is the "root" of the
	62	L<Moose::Util::TypeConstraints> type hierarchy. It means exactly what it says:
	63	I<any> value passes the constraint. Now, you could just as easily have left out
	64	the C<isa>, leaving the C<node> slot unconstrained and retaining this
	65	behavior. But in this case, we are really including the type constraint for the
	66	benefit of other programmers, not the computer. It makes clear my intent that
	67	the C<node> attribute can be of any type, and that the class is a polymorphic
	68	container.
	69
	70	Next, let's move on to the C<parent> slot:
	71
	72	has 'parent' => (
	73	is => 'rw',
	74	isa => 'BinaryTree',
	75	predicate => 'has_parent',
	76	weak_ref => 1,
	77	);
	78
	79	As you already know, this code tells you that C<parent> gets a read/write
	80	accessor and is constrained to only accept instances of B<BinaryTree>. You will
	81	of course remember from the second recipe that the C<BinaryTree> type constraint
	82	is automatically created for us by Moose.
	83
	84	The next attribute option is new, though: the C<predicate> option.
	85	This option creates a method which can be used to check whether
	86	a given slot (in this case C<parent>) has been initialized. In
	87	this case it will create a method called C<has_parent>. Quite simple,
	88	and quite handy too.
	89
	90	This brings us to our last attribute option, also a new one. Since C<parent> is
	91	a circular reference (the tree in C<parent> should already have a reference to
	92	this one, in its C<left> or C<right> node), we want to make sure that it is also
	93	a weakened reference to avoid memory leaks. The C<weak_ref> attribute option
	94	will do just that, C<weak_ref> simply takes a boolean value (C<1> or C<0>) and
	95	then alters the accessor function to weaken the reference to any value stored in
	96	the C<parent> slot (1).
	97
	98	Now, onto the C<left> and C<right> attributes. They are essentially identical,
	99	save for different names, so I will just describe one here:
	100
	101	has 'left' => (
	102	is => 'rw',
	103	isa => 'BinaryTree',
	104	predicate => 'has_left',
	105	lazy => 1,
	106	default => sub { BinaryTree->new(parent => $_[0]) },
	107	);
	108
	109	You already know what the C<is>, C<isa> and C<predicate> options do, but now we
	110	have two new options. These two options are actually linked together, in fact:
	111	you cannot use the C<lazy> option unless you have set the C<default> option.
	112	Class creation will fail with an exception (2).
	113
	114	Before I go into detail about how C<lazy> works, let me first
	115	explain how C<default> works, and in particular why it is wrapped
	116	in a CODE ref.
	117
	118	In the second recipe the B<BankAccount>'s C<balance> slot had a
	119	default value of C<0>. Since Perl will copy strings and numbers
	120	by value, this was all we had to say. But for any other item
	121	(ARRAY ref, HASH ref, object instance, etc) you would need to
	122	wrap it in a CODE reference, so this:
	123
	124	has 'foo' => (is => 'rw', default => []);
	125
	126	is actually illegal in Moose. Instead, what you really want is this:
	127
	128	has 'foo' => (is => 'rw', default => sub { [] });
	129
	130	This ensures that each instance of this class will get its own ARRAY ref in the
	131	C<foo> slot.
	132
	133	One other feature of the CODE ref version of the C<default> option is that when
	134	the subroutine is executed (to get the default value), we pass in the instance
	135	where the slot will be stored. This can come in quite handy at times, as
	136	illustrated above, with this code:
	137
	138	default => sub { BinaryTree->new(parent => $_[0]) },
	139
	140	The default value being generated is a new C<BinaryTree> instance for the
	141	C<left> (or C<right>) slot. Here we set up the correct relationship by passing
	142	the current instance as the C<parent> argument to the constructor.
	143
	144	Now, before we go on to the C<lazy> option, I want you to think
	145	for a moment. When an instance of this class is created, and the
	146	slots are being initialized, the "normal" behavior would be for
	147	the C<left> and C<right> slots to be populated with a new instance
	148	of B<BinaryTree>. In creating that instance of the C<left> or
	149	C<right> slots, we would need to create new instances to populate
	150	the C<left> and C<right> slots of I<those> instances. This would
	151	continue in an I<infinitely recursive spiral of death> until you had
	152	exhausted all available memory on your machine.
	153
	154	This is, of course, not good :)
	155
	156	Which brings us to the C<lazy> attribute option. The C<lazy> option does just
	157	what it says: it lazily initializes the slot within the instance. This means
	158	that it waits till absolutely the I<latest> possible moment to populate the
	159	slot. So if you, the user, store a value in the slot, everything works normally,
	160	and what you pass in is stored. However, if you I<read> the slot I<before>
	161	storing a value in it, then at that I<exact> moment (and no sooner), the slot
	162	will be populated with the value of the C<default> option.
	163
	164	This option is what allows the B<BinaryTree> class to instantiate
	165	objects without fear of the I<infinitely recursive spiral of death>
	166	mentioned earlier.
	167
	168	So, we have described a quite complex set of behaviors here, and not one method
	169	had to be written. But wait, we aren't quite done yet; the autogenerated
	170	C<right> and C<left> accessors are not completely correct. They will not install
	171	the parental relationships that we need. We could write our own accessors, but
	172	that would require us to implement all those features we got automatically (type
	173	constraints, lazy initialization, and so on). Instead, we use method modifiers
	174	again:
	175
	176	before 'right', 'left' => sub {
	177	my ($self, $tree) = @_;
	178	$tree->parent($self) if defined $tree;
	179	};
	180
	181	This is a C<before> modifier, just like we saw in the second recipe, but with
	182	two slight differences. First, we are applying this to more than one method at a
	183	time. Since both the C<left> and C<right> methods need the same feature, it
	184	makes sense. The second difference is that we are not wrapping an inherited
	185	method anymore, but instead a method of our own local class. Wrapping local
	186	methods is no different, the only requirement is that the wrappee be created
	187	before the wrapper (after all, you cannot wrap something which doesn't exist,
	188	right?).
	189
	190	Now, as with all the other recipes, you can go about using
	191	B<BinaryTree> like any other Perl 5 class. A more detailed example of its
	192	usage can be found in F<t/000_recipes/003_recipe.t>.
	193
	194	=head1 CONCLUSION
	195
	196	This recipe introduced you to some of the more advanced behavioral
	197	possibilities of Moose's attribute mechanism. I hope that it has
	198	opened your mind to the powerful possibilities of Moose. In the next
	199	recipe we explore how we can create custom subtypes and take
	200	advantage of the plethora of useful modules out on CPAN with Moose.
	201
	202	=head1 FOOTNOTES
	203
	204	=over 4
	205
	206	=item (1)
	207
	208	Weak references are tricky things, and should be used sparingly
	209	and appropriately (such as in the case of circular refs). If you
	210	are not careful, you will have slot values disappear "mysteriously"
	211	because perls reference counting garbage collector has gone and
	212	removed the item you are weak-referencing.
	213
	214	In short, don't use them unless you know what you are doing :)
	215
	216	=item (2)
	217
	218	You I<can> use the C<default> option without the C<lazy> option if
	219	you like, as we showed in the second recipe.
	220
	221	And actually, you can use C<builder> instead of C<default>. See
	222	L<Moose::Cookbook::Basics::Recipe9> for details.
	223
	224	=back
	225
	226	=head1 AUTHOR
	227
	228	Stevan Little E<lt>stevan@iinteractive.comE<gt>
	229
	230	=head1 COPYRIGHT AND LICENSE
	231
	232	Copyright 2006-2008 by Infinity Interactive, Inc.
	233
	234	L<http://www.iinteractive.com>
	235
	236	This library is free software; you can redistribute it and/or modify
	237	it under the same terms as Perl itself.
	238
	239	=cut

+295

-0

lib/Moose/Cookbook/Basics/Recipe4.pod less more

	0
	1	=pod
	2
	3	=head1 NAME
	4
	5	Moose::Cookbook::Basics::Recipe4 - Subtypes, and modeling a simple B<Company> class hierarchy
	6
	7	=head1 SYNOPSIS
	8
	9	package Address;
	10	use Moose;
	11	use Moose::Util::TypeConstraints;
	12
	13	use Locale::US;
	14	use Regexp::Common 'zip';
	15
	16	my $STATES = Locale::US->new;
	17
	18	subtype USState
	19	=> as Str
	20	=> where {
	21	(exists $STATES->{code2state}{uc($_)} \|\|
	22	exists $STATES->{state2code}{uc($_)})
	23	};
	24
	25	subtype USZipCode
	26	=> as Value
	27	=> where {
	28	/^$RE{zip}{US}{-extended => 'allow'}$/
	29	};
	30
	31	has 'street' => (is => 'rw', isa => 'Str');
	32	has 'city' => (is => 'rw', isa => 'Str');
	33	has 'state' => (is => 'rw', isa => 'USState');
	34	has 'zip_code' => (is => 'rw', isa => 'USZipCode');
	35
	36	package Company;
	37	use Moose;
	38	use Moose::Util::TypeConstraints;
	39
	40	has 'name' => (is => 'rw', isa => 'Str', required => 1);
	41	has 'address' => (is => 'rw', isa => 'Address');
	42	has 'employees' => (is => 'rw', isa => 'ArrayRef[Employee]');
	43
	44	sub BUILD {
	45	my ($self, $params) = @_;
	46	if ($params->{employees}) {
	47	foreach my $employee (@{$params->{employees}}) {
	48	$employee->company($self);
	49	}
	50	}
	51	}
	52
	53	after 'employees' => sub {
	54	my ($self, $employees) = @_;
	55	if (defined $employees) {
	56	foreach my $employee (@{$employees}) {
	57	$employee->company($self);
	58	}
	59	}
	60	};
	61
	62	package Person;
	63	use Moose;
	64
	65	has 'first_name' => (is => 'rw', isa => 'Str', required => 1);
	66	has 'last_name' => (is => 'rw', isa => 'Str', required => 1);
	67	has 'middle_initial' => (is => 'rw', isa => 'Str',
	68	predicate => 'has_middle_initial');
	69	has 'address' => (is => 'rw', isa => 'Address');
	70
	71	sub full_name {
	72	my $self = shift;
	73	return $self->first_name .
	74	($self->has_middle_initial ?
	75	' ' . $self->middle_initial . '. '
	76	:
	77	' ') .
	78	$self->last_name;
	79	}
	80
	81	package Employee;
	82	use Moose;
	83
	84	extends 'Person';
	85
	86	has 'title' => (is => 'rw', isa => 'Str', required => 1);
	87	has 'company' => (is => 'rw', isa => 'Company', weak_ref => 1);
	88
	89	override 'full_name' => sub {
	90	my $self = shift;
	91	super() . ', ' . $self->title
	92	};
	93
	94	=head1 DESCRIPTION
	95
	96	In this recipe we introduce the C<subtype> keyword, and show
	97	how it can be useful for specifying type constraints
	98	without building an entire class to represent them. We
	99	will also show how this feature can be used to leverage the
	100	usefulness of CPAN modules. In addition to this, we will
	101	introduce another attribute option.
	102
	103	Let's first look at the C<subtype> feature. In the B<Address> class we have
	104	defined two subtypes. The first C<subtype> uses the L<Locale::US> module, which
	105	provides two hashes which can be used to perform existential checks for state
	106	names and their two letter state codes. It is a very simple and very useful
	107	module, and perfect for use in a C<subtype> constraint.
	108
	109	my $STATES = Locale::US->new;
	110	subtype USState
	111	=> as Str
	112	=> where {
	113	(exists $STATES->{code2state}{uc($_)} \|\|
	114	exists $STATES->{state2code}{uc($_)})
	115	};
	116
	117	Because we know that states will be passed to us as strings, we
	118	can make C<USState> a subtype of the built-in type constraint
	119	C<Str>. This will ensure that anything which is a C<USState> will
	120	also pass as a C<Str>. Next, we create a constraint specializer
	121	using the C<where> keyword. The value being checked against in
	122	the C<where> clause can be found in the C<$_> variable (1). Our
	123	constraint specializer will then check whether the given string
	124	is either a state name or a state code. If the string meets this
	125	criteria, then the constraint will pass, otherwise it will fail.
	126	We can now use this as we would any built-in constraint, like so:
	127
	128	has 'state' => (is => 'rw', isa => 'USState');
	129
	130	The C<state> accessor will now check all values against the
	131	C<USState> constraint, thereby only allowing valid state names or
	132	state codes to be stored in the C<state> slot.
	133
	134	The next C<subtype> does pretty much the same thing using the L<Regexp::Common>
	135	module, and is used as the constraint for the C<zip_code> slot.
	136
	137	subtype USZipCode
	138	=> as Value
	139	=> where {
	140	/^$RE{zip}{US}{-extended => 'allow'}$/
	141	};
	142
	143	Using subtypes can save a lot of unnecessary abstraction by not requiring you to
	144	create many small classes for these relatively simple values. They also allow
	145	you to reuse the same constraints in a number of classes (thereby avoiding
	146	duplication), since all type constraints are stored in a global registry and
	147	always accessible to C<has>.
	148
	149	With these two subtypes and some attributes, we have defined
	150	as much as we need for a basic B<Address> class. Next, we define
	151	a basic B<Company> class, which itself has an address. As we saw in
	152	earlier recipes, we can use the C<Address> type constraint that
	153	Moose automatically created for us:
	154
	155	has 'address' => (is => 'rw', isa => 'Address');
	156
	157	A company also needs a name, so we define that as well:
	158
	159	has 'name' => (is => 'rw', isa => 'Str', required => 1);
	160
	161	Here we introduce another attribute option, the C<required> option.
	162	This option tells Moose that C<name> is a required parameter in
	163	the B<Company> constructor, and that the C<name> accessor cannot
	164	accept an undefined value for the slot. The result is that C<name>
	165	will always have a value.
	166
	167	The next attribute option is not actually new, but a new variant
	168	of options we have already introduced:
	169
	170	has 'employees' => (is => 'rw', isa => 'ArrayRef[Employee]');
	171
	172	Here, we are passing a more complex string to the C<isa> option, we
	173	are passing a container type constraint. Container type constraints
	174	can either be C<ArrayRef> or C<HashRef> with a contained type given
	175	inside the square brackets. This basically checks that all the values
	176	in the ARRAY ref are instances of the B<Employee> class.
	177
	178	This will ensure that our employees will all be of the correct type. However,
	179	the B<Employee> object (which we will see in a moment) also maintains a
	180	reference to its associated B<Company>. In order to maintain this relationship
	181	(and preserve the referential integrity of our objects), we need to perform some
	182	processing of the employees over and above that of the type constraint check.
	183	This is accomplished in two places. First we need to be sure that any employees
	184	array passed to the constructor is properly initialized. For this we can use the
	185	C<BUILD> method (2):
	186
	187	sub BUILD {
	188	my ($self, $params) = @_;
	189	if ($params->{employees}) {
	190	foreach my $employee (@{$params->{employees}}) {
	191	$employee->company($self);
	192	}
	193	}
	194	}
	195
	196	The C<BUILD> method will be executed after the initial type constraint
	197	check, so we can simply perform a basic existential check on the C<employees>
	198	param here, and assume that if it does exist, it is both an ARRAY ref
	199	and contains I<only> instances of B<Employee>.
	200
	201	The next aspect we need to address is the C<employees> read/write
	202	accessor (see the C<employees> attribute declaration above). This
	203	accessor will correctly check the type constraint, but we need to extend it
	204	with some additional processing. For this we use an C<after> method modifier,
	205	like so:
	206
	207	after 'employees' => sub {
	208	my ($self, $employees) = @_;
	209	if (defined $employees) {
	210	foreach my $employee (@{$employees}) {
	211	$employee->company($self);
	212	}
	213	}
	214	};
	215
	216	Again, as with the C<BUILD> method, we know that the type constraint
	217	check has already happened, so we can just check for defined-ness on the
	218	C<$employees> argument.
	219
	220	At this point, our B<Company> class is complete. Next comes our B<Person>
	221	class and its subclass, the previously mentioned B<Employee> class.
	222
	223	The B<Person> class should be obvious to you at this point. It has a few
	224	C<required> attributes, and the C<middle_initial> slot has an additional
	225	C<predicate> method (which we saw in the previous recipe with the
	226	B<BinaryTree> class).
	227
	228	Next, the B<Employee> class, which should also be pretty obvious at this
	229	point. It requires a C<title>, and maintains a weakened reference to a
	230	B<Company> instance. The only new item, which we have seen before in
	231	examples, but never in the recipe itself, is the C<override> method
	232	modifier:
	233
	234	override 'full_name' => sub {
	235	my $self = shift;
	236	super() . ', ' . $self->title
	237	};
	238
	239	This just tells Moose that I am intentionally overriding the superclass
	240	C<full_name> method here, and adding the value of the C<title> slot at
	241	the end of the employee's full name.
	242
	243	And that's about it.
	244
	245	Once again, as with all the other recipes, you can go about using
	246	these classes like any other Perl 5 class. A more detailed example of
	247	usage can be found in F<t/000_recipes/004_recipe.t>.
	248
	249	=head1 CONCLUSION
	250
	251	This recipe was intentionally longer and more complex to illustrate both
	252	how easily Moose classes can interact (using class type constraints, etc.)
	253	and the sheer density of information and behaviors which Moose can pack
	254	into a relatively small amount of typing. Ponder for a moment how much
	255	more code a non-Moose plain old Perl 5 version of this recipe would have
	256	been (including all the type constraint checks, weak references, and so on).
	257
	258	And of course, this recipe also introduced the C<subtype> keyword, and
	259	its usefulness within the Moose toolkit. In the next recipe we will
	260	focus more on subtypes, and introduce the idea of type coercion as well.
	261
	262	=head1 FOOTNOTES
	263
	264	=over 4
	265
	266	=item (1)
	267
	268	The value being checked is also passed as the first argument to
	269	the C<where> block as well, so it can also be accessed as C<$_[0]>
	270	as well.
	271
	272	=item (2)
	273
	274	The C<BUILD> method is called by C<Moose::Object::BUILDALL>, which is
	275	called by C<Moose::Object::new>. C<BUILDALL> will climb the object
	276	inheritance graph and call the appropriate C<BUILD> methods in the
	277	correct order.
	278
	279	=back
	280
	281	=head1 AUTHOR
	282
	283	Stevan Little E<lt>stevan@iinteractive.comE<gt>
	284
	285	=head1 COPYRIGHT AND LICENSE
	286
	287	Copyright 2006-2008 by Infinity Interactive, Inc.
	288
	289	L<http://www.iinteractive.com>
	290
	291	This library is free software; you can redistribute it and/or modify
	292	it under the same terms as Perl itself.
	293
	294	=cut

+198

-0

lib/Moose/Cookbook/Basics/Recipe5.pod less more

	0
	1	=pod
	2
	3	=head1 NAME
	4
	5	Moose::Cookbook::Basics::Recipe5 - More subtypes, coercion in a B<Request> class
	6
	7	=head1 SYNOPSIS
	8
	9	package Request;
	10	use Moose;
	11	use Moose::Util::TypeConstraints;
	12
	13	use HTTP::Headers ();
	14	use Params::Coerce ();
	15	use URI ();
	16
	17	subtype 'Header'
	18	=> as 'Object'
	19	=> where { $_->isa('HTTP::Headers') };
	20
	21	coerce 'Header'
	22	=> from 'ArrayRef'
	23	=> via { HTTP::Headers->new( @{ $_ } ) }
	24	=> from 'HashRef'
	25	=> via { HTTP::Headers->new( %{ $_ } ) };
	26
	27	subtype 'Uri'
	28	=> as 'Object'
	29	=> where { $_->isa('URI') };
	30
	31	coerce 'Uri'
	32	=> from 'Object'
	33	=> via { $_->isa('URI')
	34	? $_
	35	: Params::Coerce::coerce( 'URI', $_ ) }
	36	=> from 'Str'
	37	=> via { URI->new( $_, 'http' ) };
	38
	39	subtype 'Protocol'
	40	=> as Str
	41	=> where { /^HTTP\/[0-9]\.[0-9]$/ };
	42
	43	has 'base' => (is => 'rw', isa => 'Uri', coerce => 1);
	44	has 'uri' => (is => 'rw', isa => 'Uri', coerce => 1);
	45	has 'method' => (is => 'rw', isa => 'Str');
	46	has 'protocol' => (is => 'rw', isa => 'Protocol');
	47	has 'headers' => (
	48	is => 'rw',
	49	isa => 'Header',
	50	coerce => 1,
	51	default => sub { HTTP::Headers->new }
	52	);
	53
	54	=head1 DESCRIPTION
	55
	56	This recipe introduces the idea of type coercions, and the C<coerce>
	57	keyword. Coercions can be attached to existing type constraints,
	58	and can be used to transform input of one type into input of another
	59	type. This can be an extremely powerful tool if used correctly, which
	60	is why it is off by default. If you want your accessor to attempt
	61	a coercion, you must specifically ask for it with the B<coerce> option.
	62
	63	Now, onto the coercions.
	64
	65	First we need to create a subtype to attach our coercion to. Here we
	66	create a basic I<Header> subtype, which matches any instance of the
	67	class B<HTTP::Headers>:
	68
	69	subtype 'Header'
	70	=> as 'Object'
	71	=> where { $_->isa('HTTP::Headers') };
	72
	73	The simplest thing from here would be create an accessor declaration
	74	like this:
	75
	76	has 'headers' => (
	77	is => 'rw',
	78	isa => 'Header',
	79	default => sub { HTTP::Headers->new }
	80	);
	81
	82	We would then have a self-validating accessor whose default value is
	83	an empty instance of B<HTTP::Headers>. This is nice, but it is not
	84	ideal.
	85
	86	The constructor for B<HTTP::Headers> accepts a list of key-value pairs
	87	representing the HTTP header fields. In Perl, such a list could
	88	easily be stored in an ARRAY or HASH reference. We would like our
	89	class's interface to be able to accept this list of key-value pairs
	90	in place of the B<HTTP::Headers> instance, and just DWIM. This is where
	91	coercion can help. First, let's declare our coercion:
	92
	93	coerce 'Header'
	94	=> from 'ArrayRef'
	95	=> via { HTTP::Headers->new( @{ $_ } ) }
	96	=> from 'HashRef'
	97	=> via { HTTP::Headers->new( %{ $_ } ) };
	98
	99	We first tell it that we are attaching the coercion to the 'Header'
	100	subtype. We then give it a set of C<from> clauses which map other
	101	subtypes to coercion routines (through the C<via> keyword). Fairly
	102	simple really; however, this alone does nothing. We have to tell
	103	our attribute declaration to actually use the coercion, like so:
	104
	105	has 'headers' => (
	106	is => 'rw',
	107	isa => 'Header',
	108	coerce => 1,
	109	default => sub { HTTP::Headers->new }
	110	);
	111
	112	This will coerce any B<ArrayRef> or B<HashRef> which is passed into
	113	the C<headers> accessor into an instance of B<HTTP::Headers>. So the
	114	the following lines of code are all equivalent:
	115
	116	$foo->headers(HTTP::Headers->new(bar => 1, baz => 2));
	117	$foo->headers([ 'bar', 1, 'baz', 2 ]);
	118	$foo->headers({ bar => 1, baz => 2 });
	119
	120	As you can see, careful use of coercions can produce a very open
	121	interface for your class, while still retaining the "safety" of
	122	your type constraint checks.
	123
	124	Our next coercion takes advantage of the power of CPAN to handle
	125	the details of our coercion. In this particular case it uses the
	126	L<Params::Coerce> module, which fits in rather nicely with L<Moose>.
	127
	128	Again, we create a simple subtype to represent instances of the
	129	B<URI> class:
	130
	131	subtype 'Uri'
	132	=> as 'Object'
	133	=> where { $_->isa('URI') };
	134
	135	Then we add the coercion:
	136
	137	coerce 'Uri'
	138	=> from 'Object'
	139	=> via { $_->isa('URI')
	140	? $_
	141	: Params::Coerce::coerce( 'URI', $_ ) }
	142	=> from 'Str'
	143	=> via { URI->new( $_, 'http' ) };
	144
	145	The first C<from> clause we introduce is for the 'Object' subtype. An 'Object'
	146	is simply any C<bless>ed value. This means that if the coercion encounters
	147	another object, it should use this clause. Now we look at the C<via> block.
	148	First it checks to see if the object is a B<URI> instance. Since the coercion
	149	process occurs prior to any type constraint checking, it is entirely possible
	150	for this to happen, and if it does happen, we simply want to pass the instance
	151	on through. However, if it is not an instance of B<URI>, then we need to coerce
	152	it. This is where L<Params::Coerce> can do its magic, and we can just use its
	153	return value. Simple really, and much less work since we used a module from CPAN
	154	:)
	155
	156	The second C<from> clause is attached to the 'Str' subtype, and
	157	illustrates how coercions can also be used to handle certain
	158	'default' behaviors. In this coercion, we simple take any string
	159	and pass it to the B<URI> constructor along with the default
	160	'http' scheme type.
	161
	162	And of course, our coercions do nothing unless they are told to,
	163	like so:
	164
	165	has 'base' => (is => 'rw', isa => 'Uri', coerce => 1);
	166	has 'uri' => (is => 'rw', isa => 'Uri', coerce => 1);
	167
	168	As you can see, re-using the coercion allows us to enforce a
	169	consistent and very flexible API across multiple accessors.
	170
	171	=head1 CONCLUSION
	172
	173	This recipe illustrated the power of coercions to build a more
	174	flexible and open API for your accessors, while still retaining
	175	all the safety that comes from using Moose's type constraints.
	176	Using coercions it becomes simple to manage (from a single
	177	location) a consistent API not only across multiple accessors,
	178	but across multiple classes as well.
	179
	180	In the next recipe, we will introduce roles, a concept originally
	181	borrowed from Smalltalk, which made it's way into Perl 6, and
	182	now into Moose.
	183
	184	=head1 AUTHOR
	185
	186	Stevan Little E<lt>stevan@iinteractive.comE<gt>
	187
	188	=head1 COPYRIGHT AND LICENSE
	189
	190	Copyright 2006-2008 by Infinity Interactive, Inc.
	191
	192	L<http://www.iinteractive.com>
	193
	194	This library is free software; you can redistribute it and/or modify
	195	it under the same terms as Perl itself.
	196
	197	=cut⏎

+86

-0

lib/Moose/Cookbook/Basics/Recipe6.pod less more

	0
	1	=pod
	2
	3	=head1 NAME
	4
	5	Moose::Cookbook::Basics::Recipe6 - The augment/inner example
	6
	7	=head1 SYNOPSIS
	8
	9	package Document::Page;
	10	use Moose;
	11
	12	has 'body' => (is => 'rw', isa => 'Str', default => sub {''});
	13
	14	sub create {
	15	my $self = shift;
	16	$self->open_page;
	17	inner();
	18	$self->close_page;
	19	}
	20
	21	sub append_body {
	22	my ($self, $appendage) = @_;
	23	$self->body($self->body . $appendage);
	24	}
	25
	26	sub open_page { (shift)->append_body('<page>') }
	27	sub close_page { (shift)->append_body('</page>') }
	28
	29	package Document::PageWithHeadersAndFooters;
	30	use Moose;
	31
	32	extends 'Document::Page';
	33
	34	augment 'create' => sub {
	35	my $self = shift;
	36	$self->create_header;
	37	inner();
	38	$self->create_footer;
	39	};
	40
	41	sub create_header { (shift)->append_body('<header/>') }
	42	sub create_footer { (shift)->append_body('<footer/>') }
	43
	44	package TPSReport;
	45	use Moose;
	46
	47	extends 'Document::PageWithHeadersAndFooters';
	48
	49	augment 'create' => sub {
	50	my $self = shift;
	51	$self->create_tps_report;
	52	};
	53
	54	sub create_tps_report {
	55	(shift)->append_body('<report type="tps"/>')
	56	}
	57
	58	print TPSReport->new->create # <page><header/><report type="tps"/><footer/></page>
	59
	60	=head1 DESCRIPTION
	61
	62	Coming Soon.
	63
	64	=head1 CONCLUSION
	65
	66	=head1 FOOTNOTES
	67
	68	=over 4
	69
	70	=back
	71
	72	=head1 AUTHOR
	73
	74	Stevan Little E<lt>stevan@iinteractive.comE<gt>
	75
	76	=head1 COPYRIGHT AND LICENSE
	77
	78	Copyright 2007 by Infinity Interactive, Inc.
	79
	80	L<http://www.iinteractive.com>
	81
	82	This library is free software; you can redistribute it and/or modify
	83	it under the same terms as Perl itself.
	84
	85	=cut

+61

-0

lib/Moose/Cookbook/Basics/Recipe7.pod less more

	0
	1	=pod
	2
	3	=head1 NAME
	4
	5	Moose::Cookbook::Basics::Recipe7 - Making Moose fast with immutable
	6
	7	=head1 SYNOPSIS
	8
	9	package Point;
	10	use Moose;
	11
	12	has 'x' => (isa => 'Int', is => 'ro');
	13	has 'y' => (isa => 'Int', is => 'rw');
	14
	15	__PACKAGE__->meta->make_immutable;
	16
	17	=head1 DESCRIPTION
	18
	19	The Moose metaclass API provides a method C<make_immutable()>. At a
	20	high level, this calling this method does two things to your
	21	class. One, it makes it faster. In particular, object construction and
	22	accessors are effectively "inlined" in your class, and no longer go
	23	through the meta-object system.
	24
	25	Second, you can no longer make changes via the metaclass API such as
	26	adding attributes. In practice, this won't be a problem, as you don't
	27	usually need to do this at runtime after first loading the class.
	28
	29	=head2 Immutabilization and C<new()>
	30
	31	If you override C<new()> in your class, then the immutabilization code
	32	will not be able to provide an optimized constructor for your
	33	class. Instead, consider providing a C<BUILD()> method. You can
	34	probably do the same thing in a C<BUILD()> method.
	35
	36	Alternately, if you really need to provide a different C<new()>, you
	37	can also provide your own immutabilization method.
	38
	39	Discussing this is beyond the scope of this recipe, however.
	40
	41	=head1 CONCLUSION
	42
	43	We strongly recommend you make your classes immutable. It makes your
	44	code much faster, basically for free. This will be especially
	45	noticeable when creating many objects or calling accessors frequently.
	46
	47	=head1 AUTHOR
	48
	49	Dave Rolsky E<lt>autarch@urth.orgE<gt>
	50
	51	=head1 COPYRIGHT AND LICENSE
	52
	53	Copyright 2006-2008 by Infinity Interactive, Inc.
	54
	55	L<http://www.iinteractive.com>
	56
	57	This library is free software; you can redistribute it and/or modify
	58	it under the same terms as Perl itself.
	59
	60	=cut

+210

-0

lib/Moose/Cookbook/Basics/Recipe9.pod less more

	0
	1	=pod
	2
	3	=head1 NAME
	4
	5	Moose::Cookbook::Basics::Recipe9 - Builder methods and lazy_build
	6
	7	=head1 SYNOPSIS
	8
	9	package BinaryTree;
	10	use Moose;
	11
	12	has 'node' => (is => 'rw', isa => 'Any');
	13
	14	has 'parent' => (
	15	is => 'rw',
	16	isa => 'BinaryTree',
	17	predicate => 'has_parent',
	18	weak_ref => 1,
	19	);
	20
	21	has 'left' => (
	22	is => 'rw',
	23	isa => 'BinaryTree',
	24	predicate => 'has_left',
	25	lazy => 1,
	26	builder => '_build_child_tree',
	27	);
	28
	29	has 'right' => (
	30	is => 'rw',
	31	isa => 'BinaryTree',
	32	predicate => 'has_right',
	33	lazy => 1,
	34	builder => '_build_child_tree',
	35	);
	36
	37	before 'right', 'left' => sub {
	38	my ($self, $tree) = @_;
	39	$tree->parent($self) if defined $tree;
	40	};
	41
	42	sub _build_child_tree {
	43	my $self = shift;
	44
	45	return BinaryTree->new( parent => $self );
	46	}
	47
	48	=head1 DESCRIPTION
	49
	50	If you've already read L<Moose::Cookbook::Basics::Recipe3>, then this example
	51	should look awfully familiar. In fact, all we've done here is replace
	52	the attribute C<default> with a C<builder> method.
	53
	54	In this particular case, the C<default> and C<builder> options act in
	55	exactly the same way. When the C<left> or C<right> attribute get
	56	method is called, Moose will call the builder method to initialize the
	57	attribute.
	58
	59	Note that Moose calls the builder method I<on the object which has the
	60	attribute>. Here's an example in code:
	61
	62	my $tree = BinaryTree->new();
	63
	64	my $left = $tree->left();
	65
	66	At this point, Moose will call C<< $tree->_build_child_tree() >> in
	67	order to populate the C<left> attribute. If we had passed C<left> to
	68	the original constructor, the builer would not be called.
	69
	70	=head2 Subclassable
	71
	72	There are some differences between C<default> and C<builder>. Because
	73	C<builder> is called I<by name>, it goes through Perl's normal
	74	inheritance system. This means that builder methods are both
	75	inheritable and overrideable.
	76
	77	For example, we might make a C<BinaryTree> subclass:
	78
	79	package TrinaryTree;
	80	use Moose;
	81
	82	extends 'BinaryTree';
	83
	84	has 'middle' => (
	85	is => 'rw',
	86	isa => 'BinaryTree',
	87	predicate => 'has_middle',
	88	lazy => 1,
	89	builder => '_build_child_tree',
	90	);
	91
	92	This doesn't quite work though. If you look closely at the
	93	C<_build_child_tree> method defined in C<BinaryTree>, you'll notice
	94	that it hard-codes a class name. Naughty us!
	95
	96	Also, as a bonus, we'll pass C<@_> through, so subclasses can override
	97	the method to pass additional options to the constructor.
	98
	99	Good object-oriented code should allow itself to be subclassed
	100	gracefully. Let's tweak C<_build_child_tree>:
	101
	102	sub _build_child_tree {
	103	my $self = shift;
	104
	105	return (ref $self)->new( parent => $self, @_ );
	106	}
	107
	108	Now C<_build_child_tree> can be gracefully inherited and overridden.
	109
	110	=head2 Composable
	111
	112	There's more to builders than just subclassing, though. The fact that
	113	builders are called by name also makes them suitable for use in a
	114	role.
	115
	116	package HasAnimal;
	117	use Moose::Role;
	118
	119	requires '_build_animal';
	120
	121	has 'animal' => (
	122	is => 'ro',
	123	isa => 'Animal',
	124	lazy => 1,
	125	builder => '_build_animal',
	126	);
	127
	128	This role provides an animal attribute, but requires that the consumer
	129	of the role provide a builder method it.
	130
	131	package CatLover;
	132	use Moose;
	133
	134	with 'HasAnimal';
	135
	136	sub _build_animal {
	137	return Cat->new();
	138	}
	139
	140	=head2 The lazy_build shortcut
	141
	142	The C<lazy_build> attribute parameter can be used as sugar to specify
	143	a whole bunch of options at once.
	144
	145	has 'animal' => (
	146	is => 'ro',
	147	isa => 'Animal',
	148	lazy_build => 1,
	149	);
	150
	151	This is a shorthand for this:
	152
	153	has 'animal' => (
	154	is => 'ro',
	155	isa => 'Animal',
	156	required => 1,
	157	lazy => 1,
	158	builder => '_build_animal',
	159	predicate => 'has_animal',
	160	clearer => 'clear_animal',
	161	);
	162
	163	If your attribute starts with an underscore, Moose is smart and will
	164	do the right thing with the C<predicate> and C<clearer>, making them
	165	both start with an underscore. The C<builder> method I<always> starts
	166	with an underscore, since you will want this to be private the vast
	167	majority of the time.
	168
	169	Note that the C<builder> method name is created by simply taking
	170	"_build_" and appending the attribute name. This means that attributes
	171	with a leading underscore like C<_animal> end up with a builder named
	172	C<_build__animal>.
	173
	174	=head1 CONCLUSION
	175
	176	The C<builder> option is a more OO-friendly version of the C<default>
	177	functionality. It also has the property of separating out the code
	178	into a separate well-defined method. This alone makes it valuable. It
	179	is quite ugly to jam a long default code reference into your attribute
	180	definition.
	181
	182	Here are some good rules for determining when to use C<builder> vs
	183	C<default>.
	184
	185	If the default value is a simple scalar that only needs to be
	186	calculated once (or a constant), use C<default>.
	187
	188	If the default value is an empty reference that needs to be wrapped in
	189	a coderef like C<sub { [] }>, use C<default>.
	190
	191	Otherwise, use C<builder>.
	192
	193	This ensures that your classes are easily subclassable, and also helps
	194	keep crufty code out of your attribute definition blocks.
	195
	196	=head1 AUTHOR
	197
	198	Dave Rolsky E<lt>autarch@urth.orgE<gt>
	199
	200	=head1 COPYRIGHT AND LICENSE
	201
	202	Copyright 2006-2008 by Infinity Interactive, Inc.
	203
	204	L<http://www.iinteractive.com>
	205
	206	This library is free software; you can redistribute it and/or modify
	207	it under the same terms as Perl itself.
	208
	209	=cut

+69

-0

lib/Moose/Cookbook/Extending/Recipe1.pod less more

	0
	1	=pod
	2
	3	=head1 NAME
	4
	5	Moose::Cookbook::Extending::Recipe1 - Providing an alternate base object class
	6
	7	=head1 SYNOPSIS
	8
	9	package MyApp::Base;
	10	use Moose;
	11
	12	extends 'Moose::Object';
	13
	14	before 'new' => sub { warn "Making a new " . $_[0] };
	15
	16	no Moose;
	17
	18	package MyApp::UseMyBase;
	19	use Moose ();
	20
	21	sub import {
	22	my $caller = caller();
	23
	24	return if $caller eq 'main';
	25
	26	Moose::init_meta( $caller,
	27	'MyApp::Object',
	28	);
	29
	30	Moose->import( { into => $caller }, @_ );
	31	}
	32
	33	sub unimport {
	34	my $caller = caller();
	35
	36	Moose->unimport( { into => $caller }, @_ );
	37	}
	38
	39	=head1 DESCRIPTION
	40
	41	Often you find that you want to share some behavior between all your
	42	classes. One way to do that is to make a base class and simply add
	43	C<S<extends 'MyApp::Base'>> to every class in your
	44	application. However, that can get tedious. Instead, you can simply
	45	create your Moose-alike module that sets the base object class to
	46	C<MyApp::Base> for you.
	47
	48	Then, instead of writing C<S<use Moose>> you can write C<S<use
	49	MyApp::UseMyBase>>.
	50
	51	In this particular example, our base class issues some debugging
	52	output every time a new object is created, but you can surely think of
	53	some more interesting things to do with your own base class.
	54
	55	=head1 AUTHOR
	56
	57	Dave Rolsky E<lt>autarch@urth.orgE<gt>
	58
	59	=head1 COPYRIGHT AND LICENSE
	60
	61	Copyright 2006-2008 by Infinity Interactive, Inc.
	62
	63	L<http://www.iinteractive.com>
	64
	65	This library is free software; you can redistribute it and/or modify
	66	it under the same terms as Perl itself.
	67
	68	=cut

+152

-0

lib/Moose/Cookbook/Extending/Recipe2.pod less more

	0
	1	=pod
	2
	3	=head1 NAME
	4
	5	Moose::Cookbook::Extending::Recipe2 - Acting like Moose.pm and providing sugar Moose-style
	6
	7	=head1 SYNOPSIS
	8
	9	package MyApp::Mooseish;
	10
	11	use strict;
	12	use warnings;
	13
	14	our @EXPORT = qw( has_table );
	15
	16	use base 'Exporter';
	17	use Class::MOP;
	18	use Moose ();
	19
	20	sub import {
	21	my $caller = caller();
	22
	23	return if $caller eq 'main';
	24
	25	Moose::init_meta( $caller,
	26	undef, # object base class
	27	'MyApp::Meta::Class',
	28	);
	29
	30	Moose->import( { into => $caller }, @_ );
	31
	32	__PACKAGE__->export_to_level( 1, @_ );
	33	}
	34
	35	sub unimport {
	36	my $caller = caller();
	37
	38	no strict 'refs';
	39	foreach my $name (@EXPORT) {
	40	if ( defined &{ $caller . '::' . $name } ) {
	41	my $keyword = \&{ $caller . '::' . $name };
	42
	43	my ($pkg_name) = Class::MOP::get_code_info($keyword);
	44
	45	next if $pkg_name ne __PACKAGE__;
	46
	47	delete ${ $caller . '::' }{$name};
	48	}
	49	}
	50
	51	Moose::unimport( { into_level => 1 } );
	52	}
	53
	54	sub has_table {
	55	my $caller = caller();
	56
	57	$caller->meta()->table(shift);
	58	}
	59
	60	=head1 DESCRIPTION
	61
	62	The code above shows what it takes to provide an import-based
	63	interface just like C<Moose.pm>. This recipe builds on
	64	L<Moose::Cookbook::Extending::Recipe1>. Instead of providing our own
	65	object base class, we provide our own metaclass class, and we also
	66	export a sugar subroutine C<has_table()>.
	67
	68	Given the above code, you can now replace all instances of C<use
	69	Moose> with C<use MyApp::Mooseish>. Similarly, C<no Moose> is now
	70	replaced with C<no MyApp::Mooseish>.
	71
	72	=head1 WARNING
	73
	74	This recipe covers a fairly undocumented and ugly part of Moose, and
	75	the techniques described here may be deprecated in a future
	76	release. If this happens, there will be plenty of warning, as a number
	77	of C<MooseX> modules on CPAN already use these techniques.
	78
	79	=head1 HOW IT IS USED
	80
	81	The purpose of all this code is to provide a Moose-like
	82	interface. Here's what it would look like in actual use:
	83
	84	package MyApp::User;
	85
	86	use MyApp::Mooseish;
	87
	88	has_table 'User';
	89
	90	has 'username';
	91	has 'password';
	92
	93	sub login { ... }
	94
	95	no MyApp::Mooseish;
	96
	97	All of the normal Moose sugar (C<has()>, C<with()>, etc) is available
	98	when you C<use MyApp::Mooseish>.
	99
	100	=head1 DISSECTION
	101
	102	The first bit of magic is the call to C<Moose::init_meta()>. What this
	103	does is create a metaclass for the specified class. Normally, this is
	104	called by C<Moose.pm> in its own C<import()> method. However, we can
	105	call it first in order to provide an alternate metaclass class. We
	106	could also provide an alternate base object class to replace
	107	C<Moose::Object> (see L<Moose::Cookbook::Extending::Recipe1> for an
	108	example).
	109
	110	The C<Moose::init_meta()> call takes three parameters. The first is
	111	the class for which we are initializing a metaclass object. The second
	112	is the base object, which is L<Moose::Object> by default. The third
	113	argument is the metaclass class, which is C<Moose::Meta::Class> by
	114	default.
	115
	116	The next bit of magic is this:
	117
	118	Moose->import( { into => $caller } );
	119
	120	This use of "into" is actually part of the C<Sub::Exporter> API, which
	121	C<Moose.pm> uses internally to export things like C<has()> and
	122	C<extends()>.
	123
	124	Finally, we call C<< __PACKAGE__->export_to_level() >>. This method
	125	actually comes from C<Exporter>.
	126
	127	This is all a bit fragile since it doesn't stack terribly well. You
	128	can basically only have one Moose-alike module. This may be fixed in
	129	the still-notional C<MooseX::Exporter> module someday.
	130
	131	The C<unimport()> subroutine is basically a copy of the C<unimport()>
	132	from C<Moose.pm>. You can copy this verbatim into your code. Again,
	133	this doesn't stack well.
	134
	135	Finally, we have our C<has_table()> subroutine. This provides a bit of
	136	sugar that looks a lot like C<has()>.
	137
	138	=head1 AUTHOR
	139
	140	Dave Rolsky E<lt>autarch@urth.orgE<gt>
	141
	142	=head1 COPYRIGHT AND LICENSE
	143
	144	Copyright 2006-2008 by Infinity Interactive, Inc.
	145
	146	L<http://www.iinteractive.com>
	147
	148	This library is free software; you can redistribute it and/or modify
	149	it under the same terms as Perl itself.
	150
	151	=pod

+3

-3

lib/Moose/Cookbook/FAQ.pod less more

83	83	or any other format
84	84
85	85	To change the handling of individual parameters, there are I<coercions>
86		(See the L<Moose::Cookbook::Recipe5> for a complete example and
	86	(See the L<Moose::Cookbook::Basics::Recipe5> for a complete example and
87	87	explaination of coercions). With coercions it is possible to morph
88	88	argument values into the correct expected types. This approach is the
89	89	most flexible and robust, but does have a slightly higher learning

96	96	coercions, and C<lazy_build>, so subclassing is often not the
97	97	ideal route.
98	98
99		That said, the default Moose constructors is inherited from
	99	That said, the default Moose constructor is inherited from
100	100	L<Moose::Object>. When inheriting from a non-Moose class, the
101	101	inheritance chain to L<Moose::Object> is broken. The simplest way
102	102	to fix this is to simply explicitly inherit from L<Moose::Object>

203	203	in the C<via> block.
204	204
205	205	For a more comprehensive example of using coercions, see the
206		L<Moose::Cookbook::Recipe5>.
	206	L<Moose::Cookbook::Basics::Recipe5>.
207	207
208	208	If you need to deflate your attribute, the current best practice is to
209	209	add an C<around> modifier to your accessor. Here is some example code:

+67

-0

lib/Moose/Cookbook/Meta/Recipe1.pod less more

	0
	1	=pod
	2
	3	=head1 NAME
	4
	5	Moose::Cookbook::Meta::Recipe1 - Welcome to the meta world (Why Go Meta?)
	6
	7	=head1 SUMMARY
	8
	9	If you've ever found yourself thinking "Moose is great, but I wish it
	10	did X differently", then you've gone meta. The meta recipes are all
	11	about how to change and extend the way Moose does its thing, by
	12	changing how the various meta classes (C<Moose::Meta::Class>,
	13	C<Moose::Meta::Attribute>, etc) work.
	14
	15	The metaclass system is a set of classes that describe classes, roles,
	16	attributes, etc. The metaclass API lets you ask questions about a
	17	class, like "what attributes does it have?", or "what roles does the
	18	class do?"
	19
	20	The metaclass system also lets you actively make changes to a class,
	21	for example by adding new methods.
	22
	23	The interface with which you normally use Moose (C<has>, C<with>,
	24	C<extends>) is just a thin layer of syntactic sugar over the
	25	underlying metaclass system.
	26
	27	By extending and changing how this metaclass system works, you can in
	28	effect create a modified object implementation for your classes.
	29
	30	=head2 Examples
	31
	32	Let's say that you want to additional properties to
	33	attributes. Specifically, we want to add a "label" property to each
	34	attribute, so we can write C<<
	35	My::Class->meta()->get_attribute('size')->label() >>. The first two
	36	recipes show two different ways to do this, one with a full
	37	meta-attribute subclass, and the other with an attribute trait.
	38
	39	You might also want to add additional properties to your
	40	metaclass. For example, if you were writing an ORM based on Moose, you
	41	could associate a table name with each class via the class's metaclass
	42	object, letting you write C<< My::Class->meta()->table_name() >>.
	43
	44	=head1 SEE ALSO
	45
	46	Many of the MooseX modules on CPAN implement metaclass extensions. A
	47	couple good examples include C<MooseX::Singleton> and
	48	C<MooseX::AttributeHelpers>. For a more complex example see
	49	C<Fey::ORM>.
	50
	51	=head1 AUTHOR
	52
	53	Dave Rolsky E<lt>autarch@urth.org<gt>
	54
	55	=head1 COPYRIGHT AND LICENSE
	56
	57	Copyright 2008 by Infinity Interactive, Inc.
	58
	59	L<http://www.iinteractive.com>
	60
	61	This library is free software; you can redistribute it and/or modify
	62	it under the same terms as Perl itself.
	63
	64	=cut
	65
	66

+309

-0

lib/Moose/Cookbook/Meta/Recipe2.pod less more

	0
	1	=pod
	2
	3	=head1 NAME
	4
	5	Moose::Cookbook::Meta::Recipe2 - A meta-attribute, attributes with labels
	6
	7	=head1 SYNOPSIS
	8
	9	package MyApp::Meta::Attribute::Labeled;
	10	use Moose;
	11	extends 'Moose::Meta::Attribute';
	12
	13	has label => (
	14	is => 'rw',
	15	isa => 'Str',
	16	predicate => 'has_label',
	17	);
	18
	19	package Moose::Meta::Attribute::Custom::Labeled;
	20	sub register_implementation { 'MyApp::Meta::Attribute::Labeled' }
	21
	22	package MyApp::Website;
	23	use Moose;
	24	use MyApp::Meta::Attribute::Labeled;
	25
	26	has url => (
	27	metaclass => 'Labeled',
	28	is => 'rw',
	29	isa => 'Str',
	30	label => "The site's URL",
	31	);
	32
	33	has name => (
	34	is => 'rw',
	35	isa => 'Str',
	36	);
	37
	38	sub dump {
	39	my $self = shift;
	40
	41	# iterate over all the attributes in $self
	42	my %attributes = %{ $self->meta->get_attribute_map };
	43	while (my ($name, $attribute) = each %attributes) {
	44
	45	# print the label if available
	46	if ($attribute->isa('MyApp::Meta::Attribute::Labeled')
	47	&& $attribute->has_label) {
	48	print $attribute->label;
	49	}
	50	# otherwise print the name
	51	else {
	52	print $name;
	53	}
	54
	55	# print the attribute's value
	56	my $reader = $attribute->get_read_method;
	57	print ": " . $self->$reader . "\n";
	58	}
	59	}
	60
	61	package main;
	62	my $app = MyApp::Website->new(url => "http://google.com", name => "Google");
	63	$app->dump;
	64
	65	=head1 SUMMARY
	66
	67	In this recipe, we begin to really delve into the wonder of meta-programming.
	68	Some readers may scoff and claim that this is the arena only of the most
	69	twisted Moose developers. Absolutely not! Any sufficiently twisted developer
	70	can benefit greatly from going more meta.
	71
	72	The high-level goal of this recipe's code is to allow each attribute to have a
	73	human-readable "label" attached to it. Such labels would be used when showing
	74	data to an end user. In this recipe we label the "url" attribute with "The
	75	site's URL" and create a simple method to demonstrate how to use that label.
	76
	77	=head1 REAL ATTRIBUTES 101
	78
	79	All the attributes of a Moose-based object are actually objects themselves.
	80	These objects have methods and (surprisingly) attributes. Let's look at a
	81	concrete example.
	82
	83	has 'x' => (isa => 'Int', is => 'ro');
	84	has 'y' => (isa => 'Int', is => 'rw');
	85
	86	Ahh, the veritable x and y of the Point example. Internally, every Point has an
	87	x object and a y object. They have methods (such as "get_value") and attributes
	88	(such as "is_lazy"). What class are they instances of?
	89	L<Moose::Meta::Attribute>. You don't normally see the objects lurking behind
	90	the scenes, because you usually just use C<< $point->x >> and C<< $point->y >>
	91	and forget that there's a lot of machinery lying in such methods.
	92
	93	So you have a C<$point> object, which has C<x> and C<y> methods. How can you
	94	actually access the objects behind these attributes? Here's one way:
	95
	96	$point->meta->get_attribute_map()
	97
	98	C<get_attribute_map> returns a hash reference that maps attribute names to
	99	their objects. In our case, C<get_attribute_map> might return something that
	100	looks like the following:
	101
	102	{
	103	x => Moose::Meta::Attribute=HASH(0x196c23c),
	104	y => Moose::Meta::Attribute=HASH(0x18d1690),
	105	}
	106
	107	Another way to get a handle on an attribute's object is
	108	C<< $self->meta->get_attribute('name') >>. Here's one thing you can do now that
	109	you can interact with the attribute's object directly:
	110
	111	print $point->meta->get_attribute('x')->type_constraint;
	112	=> Int
	113
	114	(As an aside, it's not called C<< ->isa >> because C<< $obj->isa >> is already
	115	taken)
	116
	117	So to actually beef up attributes, what we need to do is:
	118
	119	=over 4
	120
	121	=item Create a new attribute metaclass
	122
	123	=item Create attributes using that new metaclass
	124
	125	=back
	126
	127	Moose makes both of these easy!
	128
	129	Let's start dissecting the recipe's code.
	130
	131	=head1 DISSECTION
	132
	133	We get the ball rolling by creating a new attribute metaclass. It starts off
	134	somewhat ungloriously.
	135
	136	package MyApp::Meta::Attribute::Labeled;
	137	use Moose;
	138	extends 'Moose::Meta::Attribute';
	139
	140	You subclass metaclasses the same way you subclass regular classes. (Extra
	141	credit: how in the actual hell can you use the MOP to extend itself?)
	142
	143	has label => (
	144	is => 'rw',
	145	isa => 'Str',
	146	predicate => 'has_label',
	147	);
	148
	149	Hey, this looks pretty reasonable! This is plain jane Moose code. Recipe 1
	150	fare. This is merely making a new attribute. An attribute that attributes have.
	151	A meta-attribute. It may sound scary, but it really isn't! Reread
	152	L<REAL ATTRIBUTES 101> if this really is terrifying.
	153
	154	The name is "label", it will have a regular accessor, and is a string.
	155	C<predicate> is a standard part of C<has>. It just creates a method that asks
	156	the question "Does this attribute have a value?"
	157
	158	package Moose::Meta::Attribute::Custom::Labeled;
	159	sub register_implementation { 'MyApp::Meta::Attribute::Labeled' }
	160
	161	This lets Moose discover our new metaclass. That way attributes can actually
	162	use it. More on what this is doing in a moment.
	163
	164	Note that we're done defining the new metaclass! Only nine lines of code, and
	165	not particularly difficult lines, either. Now to start using the metaclass.
	166
	167	package MyApp::Website;
	168	use Moose;
	169	use MyApp::Meta::Attribute::Labeled;
	170
	171	Nothing new here. We do have to actually load our metaclass to be able to use
	172	it.
	173
	174	has url => (
	175	metaclass => 'Labeled',
	176	is => 'rw',
	177	isa => 'Str',
	178	label => "The site's URL",
	179	);
	180
	181	Ah ha! Now we're using the metaclass. We're adding a new attribute, C<url>, to
	182	C<MyApp::Website>. C<has> lets you set the metaclass of the attribute.
	183	Ordinarily (as we've seen), the metaclass is C<Moose::Meta::Attribute>.
	184
	185	When C<has> sees that you're using a new metaclass, it will take the
	186	metaclass's name, prepend C<Moose::Meta::Attribute::Custom::>, and call the
	187	C<register_implementation> function in that package. So here Moose calls
	188	C<Moose::Meta::Attribute::Custom::Labeled::register_implementation>. We defined
	189	that function in the beginning -- it just returns our "real" metaclass'
	190	package, C<MyApp::Meta::Attribute::Labeled>. So Moose uses that metaclass for
	191	the attribute. It may seem a bit convoluted, but the alternative would be to
	192	use C<< metaclass => 'MyApp::Meta::Attribute::Labeled' >> on every attribute.
	193	As usual, Moose optimizes in favor of the end user, not the metaprogrammer. :)
	194	We also could have just defined the metaclass in
	195	C<Moose::Meta::Attribute::Custom::Labeled>, but it's probably better to keep to
	196	your own namespaces.
	197
	198	Finally, we see that C<has> is setting our new meta-attribute, C<label>, to
	199	C<"The site's URL">. We can access this meta-attribute with:
	200
	201	$website->meta->get_attribute('url')->label()
	202
	203	Well, back to the code.
	204
	205	has name => (
	206	is => 'rw',
	207	isa => 'Str',
	208	);
	209
	210	Of course, you don't have to use the new metaclass for B<all> new attributes.
	211
	212	Now we begin defining a method that will dump the C<MyApp::Website> instance
	213	for human readers.
	214
	215	sub dump {
	216	my $self = shift;
	217
	218	# iterate over all the attributes in $self
	219	my %attributes = %{ $self->meta->get_attribute_map };
	220	while (my ($name, $attribute) = each %attributes) {
	221
	222	Recall that C<get_attribute_map> returns a hashref of attribute names and their
	223	associated objects.
	224
	225	# print the label if available
	226	if ($attribute->isa('MyApp::Meta::Attribute::Labeled')
	227	&& $attribute->has_label) {
	228	print $attribute->label;
	229	}
	230
	231	We have two checks here. The first is "is this attribute an instance of
	232	C<MyApp::Meta::Attribute::Labeled>?". It's good to code defensively. Even if
	233	all of your attributes have this metaclass, you never know when someone is
	234	going to subclass your work of art. Poorly. In other words, it's likely that
	235	there will still be (many) attributes that are instances of the default
	236	C<Moose::Meta::Attribute>.
	237
	238	The second check is "does this attribute have a label?". This method was
	239	defined in the new metaclass as the "predicate". If we pass both checks, we
	240	print the attribute's label.
	241
	242	# otherwise print the name
	243	else {
	244	print $name;
	245	}
	246
	247	Another good, defensive coding practice: Provide reasonable defaults.
	248
	249	# print the attribute's value
	250	my $reader = $attribute->get_read_method;
	251	print ": " . $self->$reader . "\n";
	252	}
	253	}
	254
	255	Here's another example of using the attribute metaclass.
	256	C<< $attribute->get_read_method >> returns the name of the method that can
	257	be invoked on the original object to read the attribute's value.
	258	C<< $self->$reader >> is an example of "reflection" -- instead of using the
	259	name of the method, we're using a variable with the name of the method in it.
	260	Perl doesn't mind. Another way to write this would be
	261	C<< $self->can($reader)->($self) >>. Yuck. :)
	262
	263	package main;
	264	my $app = MyApp::Website->new(url => "http://google.com", name => "Google");
	265	$app->dump;
	266
	267	And we wrap up the example with a script to show off our newfound magic.
	268
	269	=head1 CONCLUSION
	270
	271	Why oh why would you want to go through all of these contortions when you can
	272	just print "The site's URL" directly in the C<dump> method? For one, the DRY
	273	(Don't Repeat Yourself) principle. If you have it in the C<dump> method, you'll
	274	probably also have it in the C<as_form> method, and C<to_file>, and so on. So
	275	why not have a method that maps attribute names to labels? That could work, but
	276	why not include the label where it belongs, in the attribute's definition?
	277	That way you're also less likely to forget to add the label.
	278
	279	More importantly, this was a very simple example. Your metaclasses aren't
	280	limited to just adding new meta-attributes. For example, you could implement
	281	a metaclass that expires attributes after a certain amount of time. You
	282	might use it as such:
	283
	284	has site_cache => (
	285	metaclass => 'TimedExpiry',
	286	expires_after => { hours => 1 },
	287	refresh_with => sub { get($_->url) },
	288	isa => 'Str',
	289	is => 'ro',
	290	);
	291
	292	The sky's the limit!
	293
	294	=head1 AUTHOR
	295
	296	Shawn M Moore E<lt>sartak@gmail.comE<gt>
	297
	298	=head1 COPYRIGHT AND LICENSE
	299
	300	Copyright 2006-2008 by Infinity Interactive, Inc.
	301
	302	L<http://www.iinteractive.com>
	303
	304	This library is free software; you can redistribute it and/or modify
	305	it under the same terms as Perl itself.
	306
	307	=cut
	308

+208

-0

lib/Moose/Cookbook/Meta/Recipe3.pod less more

	0
	1	=pod
	2
	3	=head1 NAME
	4
	5	Moose::Cookbook::Meta::Recipe3 - Labels implemented via attribute traits
	6
	7	=head1 SYNOPSIS
	8
	9	package MyApp::Meta::Attribute::Trait::Labeled;
	10	use Moose::Role;
	11
	12	has label => (
	13	is => 'rw',
	14	isa => 'Str',
	15	predicate => 'has_label',
	16	);
	17
	18	package Moose::Meta::Attribute::Custom::Trait::Labeled;
	19	sub register_implementation { 'MyApp::Meta::Attribute::Trait::Labeled' }
	20
	21	package MyApp::Website;
	22	use Moose;
	23	use MyApp::Meta::Attribute::Trait::Labeled;
	24
	25	has url => (
	26	traits => [qw/Labeled/],
	27	is => 'rw',
	28	isa => 'Str',
	29	label => "The site's URL",
	30	);
	31
	32	has name => (
	33	is => 'rw',
	34	isa => 'Str',
	35	);
	36
	37	sub dump {
	38	my $self = shift;
	39
	40	# iterate over all the attributes in $self
	41	my %attributes = %{ $self->meta->get_attribute_map };
	42	while (my ($name, $attribute) = each %attributes) {
	43
	44	# print the label if available
	45	if ($attribute->does('MyApp::Meta::Attribute::Trait::Labeled')
	46	&& $attribute->has_label) {
	47	print $attribute->label;
	48	}
	49	# otherwise print the name
	50	else {
	51	print $name;
	52	}
	53
	54	# print the attribute's value
	55	my $reader = $attribute->get_read_method;
	56	print ": " . $self->$reader . "\n";
	57	}
	58	}
	59
	60	package main;
	61	my $app = MyApp::Website->new(url => "http://google.com", name => "Google");
	62	$app->dump;
	63
	64	=head1 BUT FIRST
	65
	66	This recipe is a continuation of
	67	L<Moose::Cookbook::Meta::Recipe2>. Please read that recipe first.
	68
	69	=head1 MOTIVATION
	70
	71	In L<Moose::Cookbook::Meta::Recipe2>, we created an attribute
	72	metaclass that gives attributes a "label" that can be set in
	73	L<Moose/has>. That works well until you want a second meta-attribute,
	74	or until you want to adjust the behavior of the attribute. You could
	75	define a specialized attribute metaclass to use in every attribute.
	76	However, you may want different attributes to have different
	77	behaviors. You might end up with a unique attribute metaclass for
	78	B<every single attribute>, with a lot of code copying and pasting!
	79
	80	Or, if you've been drinking deeply of the Moose kool-aid, you'll have a role
	81	for each of the behaviors. One role would give a label meta-attribute. Another
	82	role would signify that this attribute is not directly modifiable via the
	83	REST interface. Another role would write to a logfile when this attribute
	84	was read.
	85
	86	Unfortunately, you'd still be left with a bunch of attribute metaclasses that
	87	do nothing but compose a bunch of roles. If only there were some way to specify
	88	in L<Moose/has> a list of roles to apply to the attribute metaclass...
	89
	90	=head1 TRAITS
	91
	92	Roles that apply to metaclasses have a special name: traits. Don't let the
	93	change in nomenclature fool you, B<traits are just roles>.
	94
	95	L<Moose/has> provides a C<traits> option. It takes a list of trait names to
	96	compose into an anonymous metaclass. That means you do still have a bunch of
	97	attribute metaclasses that do nothing but compose a bunch of roles, but they're
	98	managed automatically by Moose. You don't need to declare them in advance, or
	99	worry whether changing one will affect some other attribute.
	100
	101	What can traits do? Anything roles can do. They can add or refine attributes,
	102	wrap methods, provide more methods, define an interface, etc. The only
	103	difference is that you're now changing the attribute metaclass instead of a
	104	user-level class.
	105
	106	=head1 DISSECTION
	107
	108	A side-by-side look of the code examples in this recipe and recipe 2 should
	109	indicate that defining and using a trait is very similar to defining and using
	110	a new attribute metaclass.
	111
	112	package MyApp::Meta::Attribute::Trait::Labeled;
	113	use Moose::Role;
	114
	115	has label => (
	116	is => 'rw',
	117	isa => 'Str',
	118	predicate => 'has_label',
	119	);
	120
	121	Instead of subclassing L<Moose::Meta::Attribute>, we define a role. Traits
	122	don't need any special methods or attributes. You just focus on whatever it is
	123	you actually need to get done. Here we're adding a new meta-attribute for use
	124	in our application.
	125
	126	package Moose::Meta::Attribute::Custom::Trait::Labeled;
	127	sub register_implementation { 'MyApp::Meta::Attribute::Trait::Labeled' }
	128
	129	Much like when we define a new attribute metaclass, we can provide a shorthand
	130	name for the trait. Moose looks at the C<register_implementation> method in
	131	C<Moose::Meta::Attribute::Custom::Trait::$TRAIT_NAME> to find the full
	132	name of the trait.
	133
	134	Now we begin writing our application logic. I'll only cover what has changed
	135	since recipe 2.
	136
	137	has url => (
	138	traits => [qw/Labeled/],
	139	is => 'rw',
	140	isa => 'Str',
	141	label => "The site's URL",
	142	);
	143
	144	L<Moose/has> provides a C<traits> option. Just pass the list of trait names and
	145	it will compose them together to form the (anonymous) attribute metaclass used
	146	by the attribute. We provide a label for the attribute in the same way.
	147
	148	# print the label if available
	149	if ($attribute->does('MyApp::Meta::Attribute::Trait::Labeled')
	150	&& $attribute->has_label) {
	151	print $attribute->label;
	152	}
	153
	154	Previously, this code asked the question "Does this attribute use our attribute
	155	metaclass?" Since we're now using a trait, we ask "Does this attribute's
	156	metaclass do the C<Labeled> role?" If not, the attribute metaclass won't have
	157	the C<has_label> method, and so it would be an error to blindly call
	158	C<< $attribute->has_label >>.
	159
	160	That's all. Everything else is the same!
	161
	162	=head1 METACLASS + TRAIT
	163
	164	"But wait!" you protest. "I've already written all of my extensions as
	165	attribute metaclasses. I don't want to break all that code out there."
	166
	167	All is not lost. If you rewrite your extension as a trait, then you can
	168	easily get a regular metaclass extension out of it. You just compose the trait
	169	in the attribute metaclass, as normal.
	170
	171	package MyApp::Meta::Attribute::Labeled;
	172	use Moose;
	173	extends 'Moose::Meta::Attribute';
	174	with 'MyApp::Meta::Attribute::Trait::Labeled';
	175
	176	package Moose::Meta::Attribute::Custom::Labeled;
	177	sub register_implementation { 'MyApp::Meta::Attribute::Labeled' }
	178
	179	Unfortunately, going the other way (providing a trait created from a metaclass)
	180	is more tricky. Thus, defining your extensions as traits is just plain better
	181	than defining them as subclassed metaclasses.
	182
	183	=head1 CONCLUSION
	184
	185	If you're extending your attributes, it's easier and more flexible to provide
	186	composable bits of behavior than to subclass L<Moose::Meta::Attribute>.
	187	Using traits (which are just roles applied to a metaclass!) let you choose
	188	exactly which behaviors each attribute will have. Moose makes it easy to create
	189	attribute metaclasses on the fly by providing a list of trait names to
	190	L<Moose/has>.
	191
	192	=head1 AUTHOR
	193
	194	Shawn M Moore E<lt>sartak@gmail.comE<gt>
	195
	196	=head1 COPYRIGHT AND LICENSE
	197
	198	Copyright 2006-2008 by Infinity Interactive, Inc.
	199
	200	L<http://www.iinteractive.com>
	201
	202	This library is free software; you can redistribute it and/or modify
	203	it under the same terms as Perl itself.
	204
	205	=cut
	206
	207

+64

-0

lib/Moose/Cookbook/Meta/Recipe4.pod less more

	0
	1	=pod
	2
	3	=head1 NAME
	4
	5	Moose::Cookbook::Meta::Recipe4 - Adding a "table" attribute to the metaclass
	6
	7	=head1 SYNOPSIS
	8
	9	package MyApp::Meta::Class;
	10	use Moose;
	11	extends 'Moose::Meta::Class';
	12
	13	has table =>
	14	( is => 'rw',
	15	isa => 'Str',
	16	);
	17
	18	=head1 DESCRIPTION
	19
	20	In this recipe, we'll create a new metaclass which has a "table"
	21	attribute. This metaclass is for classes associated with a DBMS table,
	22	as one might do for an ORM.
	23
	24	In this example, the table name is just a string, but in a real ORM
	25	the table might be an object describing the table.
	26
	27	=head1 THE METACLASS
	28
	29	The metaclass example really is as simple as the one in the
	30	synopsis. The trick is getting your classes to use this metaclass, and
	31	providing some sort of sugar for declaring the table. This is covered
	32	in L<Moose::Cookbook::Extending::Recipe2>, which shows how to make a
	33	module like C<Moose.pm> itself, with sugar like C<has_table()>.
	34
	35	=head2 Using It
	36
	37	Using this new "table" attribute is quite simple. Let's say we have a
	38	class named C<MyApp::User>, we could simply write the following:
	39
	40	my $table = MyApp::User->meta()->table();
	41
	42	As long as MyApp::User has arranged to use C<MyApp::Meta::Class> as
	43	its metaclass, this method call just works.
	44
	45	=head1 SEE ALSO
	46
	47	L<Moose::Cookbook::Meta::Recipe5> - The "table" attribute implemented
	48	via a metaclass trait
	49
	50	=head1 AUTHOR
	51
	52	Dave Rolsky E<lt>autarch@urth.orgE<gt>
	53
	54	=head1 COPYRIGHT AND LICENSE
	55
	56	Copyright 2006-2008 by Infinity Interactive, Inc.
	57
	58	L<http://www.iinteractive.com>
	59
	60	This library is free software; you can redistribute it and/or modify
	61	it under the same terms as Perl itself.
	62
	63	=pod

+0

-237

~~lib/Moose/Cookbook/Recipe1.pod~~ less more

0
1		=pod
2
3		=head1 NAME
4
5		Moose::Cookbook::Recipe1 - The (always classic) B<Point> example.
6
7		=head1 SYNOPSIS
8
9		package Point;
10		use Moose;
11
12		has 'x' => (isa => 'Int', is => 'ro');
13		has 'y' => (isa => 'Int', is => 'rw');
14
15		sub clear {
16		my $self = shift;
17		$self->{x} = 0;
18		$self->y(0);
19		}
20
21		package Point3D;
22		use Moose;
23
24		extends 'Point';
25
26		has 'z' => (isa => 'Int');
27
28		after 'clear' => sub {
29		my $self = shift;
30		$self->{z} = 0;
31		};
32
33		=head1 DESCRIPTION
34
35		This is the classic Point example. This one in particular I took
36		from the Perl 6 Apocalypse 12 document, but it is similar to the
37		example found in the classic K&R C book as well, and many other
38		places. And now, onto the code:
39
40		As with all Perl 5 classes, a Moose class is defined in a package.
41		Moose now handles turning on C<strict> and C<warnings> for you, so
42		all you need to do is say C<use Moose>, and no kittens will die.
43
44		By loading Moose, we are enabling the loading of the Moose
45		"environment" into our package. This means that we import some
46		functions which serve as Moose "keywords". These aren't anything
47		fancy, just plain old exported functions.
48
49		Another important thing happens at this stage as well. Moose will
50		automatically set your package's superclass to be L<Moose::Object>.
51		The reason we do this, is so that we can be sure that your class
52		will inherit from L<Moose::Object> and get the benefits that
53		provides (such as a constructor; see L<Moose::Object> for details).
54		However, you don't actually I<have> to inherit from L<Moose::Object>
55		if you don't want to. All Moose features will still be accessible to
56		you.
57
58		Now, onto the keywords. The first one we see here is C<has>, which
59		defines an instance attribute in your class:
60
61		has 'x' => (isa => 'Int', is => 'ro');
62
63		This will create an attribute named C<x>, which will expect the
64		value stored in the attribute to pass the type constraint C<Int> (1),
65		and the accessor generated for this attribute will be read-only
66		(abbreviated as C<ro>).
67
68		The next C<has> line is very similar, with only one difference:
69
70		has 'y' => (isa => 'Int', is => 'rw');
71
72		A read/write (abbreviated as C<rw>) accessor will be generated for
73		the C<y> attribute.
74
75		At this point the attributes have been defined, and it is time to
76		define our methods. In Moose, as with regular Perl 5 OO, a method
77		is just a subroutine defined within the package. So here we create
78		the C<clear> method.
79
80		sub clear {
81		my $self = shift;
82		$self->{x} = 0;
83		$self->y(0);
84		}
85
86		It is pretty standard, the only thing to note is that we are directly
87		accessing the C<x> slot in the instance L<(2)>. This is because the
88		value was created with a read-only accessor. This also shows that Moose
89		objects are not anything out of the ordinary, but just regular old
90		blessed HASH references. This means they are very compatible with
91		other Perl 5 (non-Moose) classes as well.
92
93		The next part of the code to review is the B<Point> subclass,
94		B<Point3D>. The first item you might notice is that we do not use
95		the standard C<use base> declaration here. Instead we use the Moose
96		keyword C<extends> like so:
97
98		extends 'Point';
99
100		This keyword will function very much like C<use base> does in that
101		it will make an attempt to load your class if it has not already been
102		loaded. However, it differs on one important point. The C<extends>
103		keyword will overwrite any previous values in your package's C<@ISA>,
104		where C<use base> will C<push> values onto the package's C<@ISA>. It
105		is my opinion that the behavior of C<extends> is more intuitive in
106		that it is more explicit about defining the superclass relationship.
107
108		A small digression here: both Moose and C<extends> support multiple
109		inheritance. You simply pass all the superclasses to C<extends>,
110		like so:
111
112		extends 'Foo', 'Bar', 'Baz';
113
114		Now, back to our B<Point3D> class. The next thing we do is to create
115		a new attribute for B<Point3D> called C<z>.
116
117		has 'z' => (isa => 'Int');
118
119		As with B<Point>'s C<x> and C<y> attributes, this attribute has a
120		type constraint of C<Int>, but it differs in that it does B<not>
121		ask for any autogenerated accessors. The result being (aside from
122		broken object encapsulation) that C<z> is a private attribute.
123
124		Next comes another Moose feature which we call method "modifiers"
125		(or method "advice" for the AOP inclined). The modifier used here
126		is the C<after> modifier, and looks like this:
127
128		after 'clear' => sub {
129		my $self = shift;
130		$self->{z} = 0;
131		};
132
133		This modifier tells Moose to install a C<clear> method for
134		B<Point3D> that will first run the C<clear> method for the
135		superclass (in this case C<Point::clear>), and then run this
136		method I<after> it (passing in the same arguments as the original
137		method).
138
139		Now, of course using the C<after> modifier is not the only way to
140		accomplish this. I mean, after all, this B<is> Perl right? You
141		would get the same results with this code:
142
143		sub clear {
144		my $self = shift;
145		$self->SUPER::clear();
146		$self->{z} = 0;
147		}
148
149		You could also use another Moose method modifier, C<override> here,
150		and get the same results again. Here is how that would look:
151
152		override 'clear' => sub {
153		my $self = shift;
154		super();
155		$self->{z} = 0;
156		};
157
158		The C<override> modifier allows you to use the C<super> keyword
159		within it to dispatch to the superclass's method in a very Ruby-ish
160		style.
161
162		Now, of course, what use is a class if you can't instantiate objects
163		with it? Since B<Point> inherits from L<Moose::Object>, it will also
164		inherit the default L<Moose::Object> constructor: C<new>. Here
165		are two examples of how that is used:
166
167		my $point = Point->new(x => 1, y => 2);
168		my $point3d = Point3D->new(x => 1, y => 2, z => 3);
169
170		As you can see, C<new> accepts named argument pairs for any of the
171		attributes. It does not I<require> that you pass in the all the
172		attributes, and it will politely ignore any named arguments it does
173		not recognize.
174
175		From here on, you can use C<$point> and C<$point3d> just as you would
176		any other Perl 5 object. For a more detailed example of what can be
177		done, you can refer to the F<t/000_recipes/001_recipe.t> test file.
178
179		=head1 CONCLUSION
180
181		I hope this recipe has given you some explanation of how to use
182		Moose to build your Perl 5 classes. The next recipe will build upon
183		the basics shown here with more complex attributes and methods.
184		Please read on :)
185
186		=head1 FOOTNOTES
187
188		=over 4
189
190		=item (1)
191
192		Several default type constraints are provided by Moose, of which
193		C<Int> is one. For more information on the builtin type constraints
194		and the type constraint system in general, see the
195		L<Moose::Util::TypeConstraints> documentation.
196
197		=item (2)
198
199		Moose supports using instance structures other than blessed hash
200		references (such as in a glob reference -- see
201		L<MooseX::GlobRef::Object>). If you want your Moose classes to
202		be interchangeable, it is advisable to avoid direct instance
203		access, like that shown above. Moose does let you get and set
204		attributes directly without exposing the instance structure, but
205		that's an advanced topic (intrepid readers should refer to the
206		L<Moose::Meta::Attribute documentation>).
207
208		=back
209
210		=head1 SEE ALSO
211
212		=over 4
213
214		=item Method Modifiers
215
216		The concept of method modifiers is directly ripped off from CLOS. A
217		great explanation of them can be found by following this link.
218
219		L<http://www.gigamonkeys.com/book/object-reorientation-generic-functions.html>
220
221		=back
222
223		=head1 AUTHOR
224
225		Stevan Little E<lt>stevan@iinteractive.comE<gt>
226
227		=head1 COPYRIGHT AND LICENSE
228
229		Copyright 2006-2008 by Infinity Interactive, Inc.
230
231		L<http://www.iinteractive.com>
232
233		This library is free software; you can redistribute it and/or modify
234		it under the same terms as Perl itself.
235
236		=cut⏎

+0

-212

~~lib/Moose/Cookbook/Recipe10.pod~~ less more

0
1		=pod
2
3		=head1 NAME
4
5		Moose::Cookbook::Recipe10 - The Moose::Role example
6
7		=head1 SYNOPSIS
8
9		package Eq;
10		use Moose::Role;
11
12		requires 'equal_to';
13
14		sub not_equal_to {
15		my ($self, $other) = @_;
16		not $self->equal_to($other);
17		}
18
19		package Comparable;
20		use Moose::Role;
21
22		with 'Eq';
23
24		requires 'compare';
25
26		sub equal_to {
27		my ($self, $other) = @_;
28		$self->compare($other) == 0;
29		}
30
31		sub greater_than {
32		my ($self, $other) = @_;
33		$self->compare($other) == 1;
34		}
35
36		sub less_than {
37		my ($self, $other) = @_;
38		$self->compare($other) == -1;
39		}
40
41		sub greater_than_or_equal_to {
42		my ($self, $other) = @_;
43		$self->greater_than($other) \|\| $self->equal_to($other);
44		}
45
46		sub less_than_or_equal_to {
47		my ($self, $other) = @_;
48		$self->less_than($other) \|\| $self->equal_to($other);
49		}
50
51		package Printable;
52		use Moose::Role;
53
54		requires 'to_string';
55
56		package US::Currency;
57		use Moose;
58
59		with 'Comparable', 'Printable';
60
61		has 'amount' => (is => 'rw', isa => 'Num', default => 0);
62
63		sub compare {
64		my ($self, $other) = @_;
65		$self->amount <=> $other->amount;
66		}
67
68		sub to_string {
69		my $self = shift;
70		sprintf '$%0.2f USD' => $self->amount
71		}
72
73		=head1 DESCRIPTION
74
75		In this recipe we examine the role support provided in Moose. "Roles" may be
76		described in many ways, but there are two main ways in which they are used: as
77		interfaces, and as a means of code reuse. This recipe demonstrates the
78		construction and incorporation of roles that define comparison and display of
79		objects.
80
81		Let's start by examining B<Eq>. You'll notice that instead of the familiar C<use
82		Moose> you might be expecting, here we use C<Moose::Role> to make it clear that
83		this is a role. We encounter a new keyword, C<requires>:
84
85		requires 'equal_to';
86
87		What this does is to indicate that any class which "consumes" (that is to say,
88		"includes using C<with>", as we'll see a little later) the B<Eq> role I<must>
89		include an C<equal_to> method, whether this is provided by the class itself, one
90		of its superclasses, or another role consumed by the class (1).
91
92		In addition to requiring an C<equal_to> method, B<Eq> defines a C<not_equal_to>
93		method, which simply inverts the result of C<equal_to>. Defining additional
94		methods in this way, by using only a few base methods that target classes must
95		define, is a useful pattern to provide maximum functionality with minimum
96		effort.
97
98		After the minimal B<Eq>, we next move on to B<Comparable>. The first thing you
99		will notice is another new keyword, C<with>:
100
101		with 'Eq';
102
103		C<with> is used to provide a list of roles which this class (or role) consumes.
104		Here, B<Comparable> only consumes one role (B<Eq>). In effect, it is as if we
105		defined a C<not_equal_to> method within Comparable, and also promised to fulfill
106		the requirement of an C<equal_to> method.
107
108		B<Comparable> itself states that it requires C<compare>. Again, it means that
109		any classes consuming this role must implement a C<compare> method.
110
111		requires 'compare';
112
113		B<Comparable> defines an C<equal_to> method which satisfies the B<Eq> role's
114		requirements. This, along with a number of other methods (C<greater_than>,
115		C<less_than>, C<greater_than_or_equal_to>, and C<less_than_or_equal_to>) is
116		simply defined in terms of C<compare>, once again demonstrating the pattern of
117		defining a number of utility methods in terms of only a single method that the
118		target class need implement.
119
120		sub equal_to {
121		my ($self, $other) = @_;
122		$self->compare($other) == 0;
123		}
124
125		sub greater_than {
126		my ($self, $other) = @_;
127		$self->compare($other) == 1;
128		}
129
130		sub less_than {
131		my ($self, $other) = @_;
132		$self->compare($other) == -1;
133		}
134
135		sub greater_than_or_equal_to {
136		my ($self, $other) = @_;
137		$self->greater_than($other) \|\| $self->equal_to($other);
138		}
139
140		sub less_than_or_equal_to {
141		my ($self, $other) = @_;
142		$self->less_than($other) \|\| $self->equal_to($other);
143		}
144
145		Next up is B<Printable>. This is a very simple role, akin to B<Eq>. It merely
146		requires a C<to_string> method.
147
148		Finally, we come to B<US::Currency>, a class that allows us to reap the benefits
149		of our hard work. This is a regular Moose class, so we include the normal C<use
150		Moose>. It consumes both B<Comparable> and B<Printable>, as the following line
151		shows:
152
153		with 'Comparable', 'Printable';
154
155		It also defines a regular Moose attribute, C<amount>, with a type constraint of
156		C<Num> and a default of C<0>:
157
158		has 'amount' => (is => 'rw', isa => 'Num', default => 0);
159
160		Now we come to the core of the class. First up, we define a C<compare> method:
161
162		sub compare {
163		my ($self, $other) = @_;
164		$self->amount <=> $other->amount;
165		}
166
167		As you can see, it simply compares the C<amount> attribute of this object with
168		the C<amount> attribute of the other object passed to it. With the single
169		definition of this method, we gain the following methods for free: C<equal_to>,
170		C<greater_than>, C<less_than>, C<greater_than_or_equal_to> and
171		C<less_than_or_equal_to>.
172
173		We end the class with a definition of the C<to_string> method, which formats the
174		C<amount> attribute for display:
175
176		sub to_string {
177		my $self = shift;
178		sprintf '$%0.2f USD' => $self->amount
179		}
180
181		=head1 CONCLUSION
182
183		This recipe has shown that roles can be very powerful and immensely useful, and
184		save a great deal of repetition.
185
186		=head1 FOOTNOTES
187
188		=over 4
189
190		=item (1)
191
192		At present, method requirements from roles cannot be satisfied by attribute
193		accessors. This is a limitation of Moose, and will most likely be rectified in a
194		future release.
195
196		=back
197
198		=head1 AUTHOR
199
200		Stevan Little E<lt>stevan@iinteractive.comE<gt>
201
202		=head1 COPYRIGHT AND LICENSE
203
204		Copyright 2006-2008 by Infinity Interactive, Inc.
205
206		L<http://www.iinteractive.com>
207
208		This library is free software; you can redistribute it and/or modify
209		it under the same terms as Perl itself.
210
211		=cut

+0

-121

~~lib/Moose/Cookbook/Recipe11.pod~~ less more

0
1		=pod
2
3		=head1 NAME
4
5		Moose::Cookbook::Recipe11 - Advanced Role Composition - method exclusion and aliasing
6
7		=head1 SYNOPSIS
8
9		package Restartable;
10		use Moose::Role;
11
12		has 'is_paused' => (
13		is => 'rw',
14		isa => 'Bool',
15		default => 0,
16		);
17
18		requires 'save_state', 'load_state';
19
20		sub stop { ... }
21
22		sub start { ... }
23
24		package Restartable::ButUnreliable;
25		use Moose::Role;
26
27		with 'Restartable' => { alias => { stop => '_stop',
28		start => '_start' } };
29
30		sub stop {
31		my $self = shift;
32
33		$self->explode() if rand(1) > .5;
34
35		$self->_stop();
36		}
37
38		sub start {
39		my $self = shift;
40
41		$self->explode() if rand(1) > .5;
42
43		$self->_start();
44		}
45
46		package Restartable::ButBroken;
47		use Moose::Role;
48
49		with 'Restartable' => { excludes => [ 'stop', 'start' ] };
50
51		sub stop {
52		my $self = shift;
53
54		$self->explode();
55		}
56
57		sub start {
58		my $self = shift;
59
60		$self->explode();
61		}
62
63		=head1 DESCRIPTION
64
65		Sometimes when you include a role in a class, you may want to leave
66		out some of its methods. In this example, we have a role C<Restartable>
67		which provides an C<is_paused> attribute, and two methods, C<stop> and
68		C<start>. The implementation of those two methods is irrelevant.
69
70		Then we have two more roles which also implement the same interface,
71		each putting their own spin on the C<stop> and C<start> method.
72
73		In the C<Restartable::ButUnreliable> role, we want to provide a new
74		implementation of C<stop> and C<start>, but still have access to the
75		original implementation. To do this, we alias the methods from
76		C<Restartable> to private methods, and provide wrappers around the
77		originals (1).
78
79		In the C<Restartable::ButBroken> role, we want to provide an entirely
80		new behavior for C<stop> and C<start>, so we exclude them when
81		composing the C<Restartable> role into C<Restartable::ButBroken>.
82
83		It's worth noting that the C<excludes> parameter also accepts a single
84		string as an argument if you just want to exclude one method.
85
86		=head1 CONCLUSION
87
88		Method exclusion and renaming can come in handy, especially when
89		building roles out of other roles. In this example, all of our roles
90		implement the C<Restartable> role. Each role provides same API, but
91		each has a different implementation under the hood.
92
93		You can also use the method aliasing and excluding features when
94		composing a role into a class.
95
96		=head1 FOOTNOTES
97
98		=over 4
99
100		=item (1)
101
102		The mention of wrapper should tell you that we could do the same thing
103		using method modifiers, but for the sake of this example, we don't.
104
105		=back
106
107		=head1 AUTHOR
108
109		Dave Rolsky E<lt>autarch@urth.orgE<gt>
110
111		=head1 COPYRIGHT AND LICENSE
112
113		Copyright 2006-2008 by Infinity Interactive, Inc.
114
115		L<http://www.iinteractive.com>
116
117		This library is free software; you can redistribute it and/or modify
118		it under the same terms as Perl itself.
119
120		=cut

+0

-211

~~lib/Moose/Cookbook/Recipe2.pod~~ less more

0
1		=pod
2
3		=head1 NAME
4
5		Moose::Cookbook::Recipe2 - A simple B<BankAccount> example
6
7		=head1 SYNOPSIS
8
9		package BankAccount;
10		use Moose;
11
12		has 'balance' => (isa => 'Int', is => 'rw', default => 0);
13
14		sub deposit {
15		my ($self, $amount) = @_;
16		$self->balance($self->balance + $amount);
17		}
18
19		sub withdraw {
20		my ($self, $amount) = @_;
21		my $current_balance = $self->balance();
22		($current_balance >= $amount)
23		\|\| confess "Account overdrawn";
24		$self->balance($current_balance - $amount);
25		}
26
27		package CheckingAccount;
28		use Moose;
29
30		extends 'BankAccount';
31
32		has 'overdraft_account' => (isa => 'BankAccount', is => 'rw');
33
34		before 'withdraw' => sub {
35		my ($self, $amount) = @_;
36		my $overdraft_amount = $amount - $self->balance();
37		if ($self->overdraft_account && $overdraft_amount > 0) {
38		$self->overdraft_account->withdraw($overdraft_amount);
39		$self->deposit($overdraft_amount);
40		}
41		};
42
43		=head1 DESCRIPTION
44
45		In the first recipe we demonstrated the construction of basic
46		Moose classes whose attributes had various accessor schemes and
47		builtin type constraints. However, our objects were very data-
48		oriented, and did not have many behavioral aspects (i.e. methods)
49		to them. In this recipe, we will expand upon the concepts from
50		the first recipe and give a more realistic scenario of more
51		behavior oriented classes.
52
53		We are using the example of a bank account, which has a standard
54		account (you can deposit money, withdraw money and check your
55		current balance), and a checking account which has optional
56		overdraft protection. The overdraft protection will protect the
57		owner of the checking account by automatically withdrawing the
58		needed funds from the overdraft account to ensure that a check
59		will not bounce.
60
61		Now, onto the code. The first class, B<BankAccount>, introduces a
62		new attribute feature: a default value.
63
64		has 'balance' => (isa => 'Int', is => 'rw', default => 0);
65
66		This tells us that a B<BankAccount> has a C<balance> attribute,
67		which has the C<Int> type constraint, a read/write accessor,
68		and a default value of C<0>. This means that every instance of
69		B<BankAccount> that is created will have its C<balance> slot
70		initialized to C<0>. Very simple really :)
71
72		Next come the methods. The C<deposit> and C<withdraw> methods
73		should be fairly self-explanatory; they are nothing specific to
74		Moose, just your standard Perl 5 OO.
75
76		Now, onto the B<CheckingAccount> class. As you know from the
77		first recipe, the keyword C<extends> sets a class's superclass
78		relationship. Here we see that B<CheckingAccount> is a
79		B<BankAccount>. The next line introduces yet another new aspect
80		of Moose, that of class-based type-constraints:
81
82		has 'overdraft_account' => (isa => 'BankAccount', is => 'rw');
83
84		Up until now, we have only had C<Int> type constraints, which
85		(as I said in the first recipe) is a builtin type constraint
86		that Moose provides for you. The C<BankAccount> type constraint
87		is new, and was actually defined the moment we created the
88		B<BankAccount> class itself. In fact, for every class in
89		your program, a corresponding type constraint will be created. This
90		means that in the first recipe, both C<Point> and C<Point3D> type
91		constraints were created, and in this recipe, both C<BankAccount>
92		and C<CheckingAccount> type constraints were created. Moose does
93		this as a convenience so that your class model and the type
94		constraint model can be kept in sync with one another. In short,
95		Moose makes sure that it will just DWIM (1).
96
97		Next, we come to the behavioral part of B<CheckingAccount>, and
98		again we see a method modifier, but this time it is a C<before>
99		modifier.
100
101		before 'withdraw' => sub {
102		my ($self, $amount) = @_;
103		my $overdraft_amount = $amount - $self->balance();
104		if ($self->overdraft_account && $overdraft_amount > 0) {
105		$self->overdraft_account->withdraw($overdraft_amount);
106		$self->deposit($overdraft_amount);
107		}
108		};
109
110		Just as with the C<after> modifier from the first recipe, Moose
111		will handle calling the superclass method (in this case the
112		C<BankAccount::withdraw> method). The C<before> modifier shown
113		above will run (obviously) I<before> the code from the superclass
114		with run. The C<before> modifier here implements the overdraft
115		protection by first checking if there are enough available
116		funds in the checking account and if not (and if there is an overdraft
117		account available), it transfers the appropriate funds into the
118		checking account.
119
120		As with the method modifier in the first recipe, there is another
121		way to accomplish this same thing using the built in C<SUPER::>
122		pseudo-package. So the above method is equivalent to the one here.
123
124		sub withdraw {
125		my ($self, $amount) = @_;
126		my $overdraft_amount = $amount - $self->balance();
127		if ($self->overdraft_account && $overdraft_amount > 0) {
128		$self->overdraft_account->withdraw($overdraft_amount);
129		$self->deposit($overdraft_amount);
130		}
131		$self->SUPER::withdraw($amount);
132		}
133
134		The benefits of taking the method modifier approach is that the
135		author of the B<BankAccount> subclass does not need to remember
136		to call C<SUPER::withdraw> and to pass it the C<$amount> argument.
137		Instead the method modifier ensures that all arguments make it
138		to the superclass method correctly. But this is actually more
139		than just a convenience for forgetful programmers, it also helps
140		isolate subclasses from changes in the superclasses. For instance,
141		if B<BankAccount::withdraw> were to add an additional argument
142		of some kind, the version of B<CheckingAccount::withdraw> which
143		uses C<SUPER::withdraw> would not pass that extra argument
144		correctly, whereas the method modifier version would automatically
145		pass along all arguments correctly.
146
147		Just as with the first recipe, object instantiation is a fairly
148		normal process, here is an example:
149
150		my $savings_account = BankAccount->new(balance => 250);
151		my $checking_account = CheckingAccount->new(
152		balance => 100,
153		overdraft_account => $savings_account
154		);
155
156		And as with the first recipe, a more in-depth example of using
157		these classes can be found in the F<t/000_recipes/002_recipe.t> test file.
158
159		=head1 CONCLUSION
160
161		The aim of this recipe was to take the knowledge gained in the
162		first recipe and expand upon it with a more realistic use case. I
163		hope that this recipe has accomplished this goal. The next recipe
164		will expand even more upon the capabilities of attributes in Moose
165		to create a behaviorally sophisticated class almost entirely
166		defined by attributes.
167
168		=head1 FOOTNOTES
169
170		=over 4
171
172		=item (1)
173
174		Moose does not attempt to encode a class's is-a relationships
175		within the type constraint hierarchy. Instead, Moose just
176		considers the class type constraint to be a subtype of C<Object>,
177		and specializes the constraint check to allow for subclasses. This
178		means that an instance of B<CheckingAccount> will pass a
179		C<BankAccount> type constraint successfully. For more details,
180		please refer to the L<Moose::Util::TypeConstraints> documentation.
181
182		=back
183
184		=head1 SEE ALSO
185
186		=over 4
187
188		=item Acknowledgment
189
190		The BankAccount example in this recipe is directly taken from the
191		examples in this chapter of "Practical Common Lisp":
192
193		L<http://www.gigamonkeys.com/book/object-reorientation-generic-functions.html>
194
195		=back
196
197		=head1 AUTHOR
198
199		Stevan Little E<lt>stevan@iinteractive.comE<gt>
200
201		=head1 COPYRIGHT AND LICENSE
202
203		Copyright 2006-2008 by Infinity Interactive, Inc.
204
205		L<http://www.iinteractive.com>
206
207		This library is free software; you can redistribute it and/or modify
208		it under the same terms as Perl itself.
209
210		=cut

+0

-309

~~lib/Moose/Cookbook/Recipe21.pod~~ less more

0
1		=pod
2
3		=head1 NAME
4
5		Moose::Cookbook::Recipe21 - The meta-attribute example
6
7		=head1 SYNOPSIS
8
9		package MyApp::Meta::Attribute::Labeled;
10		use Moose;
11		extends 'Moose::Meta::Attribute';
12
13		has label => (
14		is => 'rw',
15		isa => 'Str',
16		predicate => 'has_label',
17		);
18
19		package Moose::Meta::Attribute::Custom::Labeled;
20		sub register_implementation { 'MyApp::Meta::Attribute::Labeled' }
21
22		package MyApp::Website;
23		use Moose;
24		use MyApp::Meta::Attribute::Labeled;
25
26		has url => (
27		metaclass => 'Labeled',
28		is => 'rw',
29		isa => 'Str',
30		label => "The site's URL",
31		);
32
33		has name => (
34		is => 'rw',
35		isa => 'Str',
36		);
37
38		sub dump {
39		my $self = shift;
40
41		# iterate over all the attributes in $self
42		my %attributes = %{ $self->meta->get_attribute_map };
43		while (my ($name, $attribute) = each %attributes) {
44
45		# print the label if available
46		if ($attribute->isa('MyApp::Meta::Attribute::Labeled')
47		&& $attribute->has_label) {
48		print $attribute->label;
49		}
50		# otherwise print the name
51		else {
52		print $name;
53		}
54
55		# print the attribute's value
56		my $reader = $attribute->get_read_method;
57		print ": " . $self->$reader . "\n";
58		}
59		}
60
61		package main;
62		my $app = MyApp::Website->new(url => "http://google.com", name => "Google");
63		$app->dump;
64
65		=head1 SUMMARY
66
67		In this recipe, we begin to really delve into the wonder of meta-programming.
68		Some readers may scoff and claim that this is the arena only of the most
69		twisted Moose developers. Absolutely not! Any sufficiently twisted developer
70		can benefit greatly from going more meta.
71
72		The high-level goal of this recipe's code is to allow each attribute to have a
73		human-readable "label" attached to it. Such labels would be used when showing
74		data to an end user. In this recipe we label the "url" attribute with "The
75		site's URL" and create a simple method to demonstrate how to use that label.
76
77		=head1 REAL ATTRIBUTES 101
78
79		All the attributes of a Moose-based object are actually objects themselves.
80		These objects have methods and (surprisingly) attributes. Let's look at a
81		concrete example.
82
83		has 'x' => (isa => 'Int', is => 'ro');
84		has 'y' => (isa => 'Int', is => 'rw');
85
86		Ahh, the veritable x and y of the Point example. Internally, every Point has an
87		x object and a y object. They have methods (such as "get_value") and attributes
88		(such as "is_lazy"). What class are they instances of?
89		L<Moose::Meta::Attribute>. You don't normally see the objects lurking behind
90		the scenes, because you usually just use C<< $point->x >> and C<< $point->y >>
91		and forget that there's a lot of machinery lying in such methods.
92
93		So you have a C<$point> object, which has C<x> and C<y> methods. How can you
94		actually access the objects behind these attributes? Here's one way:
95
96		$point->meta->get_attribute_map()
97
98		C<get_attribute_map> returns a hash reference that maps attribute names to
99		their objects. In our case, C<get_attribute_map> might return something that
100		looks like the following:
101
102		{
103		x => Moose::Meta::Attribute=HASH(0x196c23c),
104		y => Moose::Meta::Attribute=HASH(0x18d1690),
105		}
106
107		Another way to get a handle on an attribute's object is
108		C<< $self->meta->get_attribute('name') >>. Here's one thing you can do now that
109		you can interact with the attribute's object directly:
110
111		print $point->meta->get_attribute('x')->type_constraint;
112		=> Int
113
114		(As an aside, it's not called C<< ->isa >> because C<< $obj->isa >> is already
115		taken)
116
117		So to actually beef up attributes, what we need to do is:
118
119		=over 4
120
121		=item Create a new attribute metaclass
122
123		=item Create attributes using that new metaclass
124
125		=back
126
127		Moose makes both of these easy!
128
129		Let's start dissecting the recipe's code.
130
131		=head1 DISSECTION
132
133		We get the ball rolling by creating a new attribute metaclass. It starts off
134		somewhat ungloriously.
135
136		package MyApp::Meta::Attribute::Labeled;
137		use Moose;
138		extends 'Moose::Meta::Attribute';
139
140		You subclass metaclasses the same way you subclass regular classes. (Extra
141		credit: how in the actual hell can you use the MOP to extend itself?)
142
143		has label => (
144		is => 'rw',
145		isa => 'Str',
146		predicate => 'has_label',
147		);
148
149		Hey, this looks pretty reasonable! This is plain jane Moose code. Recipe 1
150		fare. This is merely making a new attribute. An attribute that attributes have.
151		A meta-attribute. It may sound scary, but it really isn't! Reread
152		L<REAL ATTRIBUTES 101> if this really is terrifying.
153
154		The name is "label", it will have a regular accessor, and is a string.
155		C<predicate> is a standard part of C<has>. It just creates a method that asks
156		the question "Does this attribute have a value?"
157
158		package Moose::Meta::Attribute::Custom::Labeled;
159		sub register_implementation { 'MyApp::Meta::Attribute::Labeled' }
160
161		This lets Moose discover our new metaclass. That way attributes can actually
162		use it. More on what this is doing in a moment.
163
164		Note that we're done defining the new metaclass! Only nine lines of code, and
165		not particularly difficult lines, either. Now to start using the metaclass.
166
167		package MyApp::Website;
168		use Moose;
169		use MyApp::Meta::Attribute::Labeled;
170
171		Nothing new here. We do have to actually load our metaclass to be able to use
172		it.
173
174		has url => (
175		metaclass => 'Labeled',
176		is => 'rw',
177		isa => 'Str',
178		label => "The site's URL",
179		);
180
181		Ah ha! Now we're using the metaclass. We're adding a new attribute, C<url>, to
182		C<MyApp::Website>. C<has> lets you set the metaclass of the attribute.
183		Ordinarily (as we've seen), the metaclass is C<Moose::Meta::Attribute>.
184
185		When C<has> sees that you're using a new metaclass, it will take the
186		metaclass's name, prepend C<Moose::Meta::Attribute::Custom::>, and call the
187		C<register_implementation> function in that package. So here Moose calls
188		C<Moose::Meta::Attribute::Custom::Labeled::register_implementation>. We defined
189		that function in the beginning -- it just returns our "real" metaclass'
190		package, C<MyApp::Meta::Attribute::Labeled>. So Moose uses that metaclass for
191		the attribute. It may seem a bit convoluted, but the alternative would be to
192		use C<< metaclass => 'MyApp::Meta::Attribute::Labeled' >> on every attribute.
193		As usual, Moose optimizes in favor of the end user, not the metaprogrammer. :)
194		We also could have just defined the metaclass in
195		C<Moose::Meta::Attribute::Custom::Labeled>, but it's probably better to keep to
196		your own namespaces.
197
198		Finally, we see that C<has> is setting our new meta-attribute, C<label>, to
199		C<"The site's URL">. We can access this meta-attribute with:
200
201		$website->meta->get_attribute('url')->label()
202
203		Well, back to the code.
204
205		has name => (
206		is => 'rw',
207		isa => 'Str',
208		);
209
210		Of course, you don't have to use the new metaclass for B<all> new attributes.
211
212		Now we begin defining a method that will dump the C<MyApp::Website> instance
213		for human readers.
214
215		sub dump {
216		my $self = shift;
217
218		# iterate over all the attributes in $self
219		my %attributes = %{ $self->meta->get_attribute_map };
220		while (my ($name, $attribute) = each %attributes) {
221
222		Recall that C<get_attribute_map> returns a hashref of attribute names and their
223		associated objects.
224
225		# print the label if available
226		if ($attribute->isa('MyApp::Meta::Attribute::Labeled')
227		&& $attribute->has_label) {
228		print $attribute->label;
229		}
230
231		We have two checks here. The first is "is this attribute an instance of
232		C<MyApp::Meta::Attribute::Labeled>?". It's good to code defensively. Even if
233		all of your attributes have this metaclass, you never know when someone is
234		going to subclass your work of art. Poorly. In other words, it's likely that
235		there will still be (many) attributes that are instances of the default
236		C<Moose::Meta::Attribute>.
237
238		The second check is "does this attribute have a label?". This method was
239		defined in the new metaclass as the "predicate". If we pass both checks, we
240		print the attribute's label.
241
242		# otherwise print the name
243		else {
244		print $name;
245		}
246
247		Another good, defensive coding practice: Provide reasonable defaults.
248
249		# print the attribute's value
250		my $reader = $attribute->get_read_method;
251		print ": " . $self->$reader . "\n";
252		}
253		}
254
255		Here's another example of using the attribute metaclass.
256		C<< $attribute->get_read_method >> returns the name of the method that can
257		be invoked on the original object to read the attribute's value.
258		C<< $self->$reader >> is an example of "reflection" -- instead of using the
259		name of the method, we're using a variable with the name of the method in it.
260		Perl doesn't mind. Another way to write this would be
261		C<< $self->can($reader)->($self) >>. Yuck. :)
262
263		package main;
264		my $app = MyApp::Website->new(url => "http://google.com", name => "Google");
265		$app->dump;
266
267		And we wrap up the example with a script to show off our newfound magic.
268
269		=head1 CONCLUSION
270
271		Why oh why would you want to go through all of these contortions when you can
272		just print "The site's URL" directly in the C<dump> method? For one, the DRY
273		(Don't Repeat Yourself) principle. If you have it in the C<dump> method, you'll
274		probably also have it in the C<as_form> method, and C<to_file>, and so on. So
275		why not have a method that maps attribute names to labels? That could work, but
276		why not include the label where it belongs, in the attribute's definition?
277		That way you're also less likely to forget to add the label.
278
279		More importantly, this was a very simple example. Your metaclasses aren't
280		limited to just adding new meta-attributes. For example, you could implement
281		a metaclass that expires attributes after a certain amount of time. You
282		might use it as such:
283
284		has site_cache => (
285		metaclass => 'TimedExpiry',
286		expires_after => { hours => 1 },
287		refresh_with => sub { get($_->url) },
288		isa => 'Str',
289		is => 'ro',
290		);
291
292		The sky's the limit!
293
294		=head1 AUTHOR
295
296		Shawn M Moore E<lt>sartak@gmail.comE<gt>
297
298		=head1 COPYRIGHT AND LICENSE
299
300		Copyright 2006-2008 by Infinity Interactive, Inc.
301
302		L<http://www.iinteractive.com>
303
304		This library is free software; you can redistribute it and/or modify
305		it under the same terms as Perl itself.
306
307		=cut
308

+0

-207

~~lib/Moose/Cookbook/Recipe22.pod~~ less more

0
1		=pod
2
3		=head1 NAME
4
5		Moose::Cookbook::Recipe22 - The attribute trait example
6
7		=head1 SYNOPSIS
8
9		package MyApp::Meta::Attribute::Trait::Labeled;
10		use Moose::Role;
11
12		has label => (
13		is => 'rw',
14		isa => 'Str',
15		predicate => 'has_label',
16		);
17
18		package Moose::Meta::Attribute::Custom::Trait::Labeled;
19		sub register_implementation { 'MyApp::Meta::Attribute::Trait::Labeled' }
20
21		package MyApp::Website;
22		use Moose;
23		use MyApp::Meta::Attribute::Trait::Labeled;
24
25		has url => (
26		traits => [qw/Labeled/],
27		is => 'rw',
28		isa => 'Str',
29		label => "The site's URL",
30		);
31
32		has name => (
33		is => 'rw',
34		isa => 'Str',
35		);
36
37		sub dump {
38		my $self = shift;
39
40		# iterate over all the attributes in $self
41		my %attributes = %{ $self->meta->get_attribute_map };
42		while (my ($name, $attribute) = each %attributes) {
43
44		# print the label if available
45		if ($attribute->does('MyApp::Meta::Attribute::Trait::Labeled')
46		&& $attribute->has_label) {
47		print $attribute->label;
48		}
49		# otherwise print the name
50		else {
51		print $name;
52		}
53
54		# print the attribute's value
55		my $reader = $attribute->get_read_method;
56		print ": " . $self->$reader . "\n";
57		}
58		}
59
60		package main;
61		my $app = MyApp::Website->new(url => "http://google.com", name => "Google");
62		$app->dump;
63
64		=head1 BUT FIRST
65
66		This recipe is a continuation of L<Moose::Cookbook::Recipe21>. Please read that
67		first.
68
69		=head1 MOTIVATION
70
71		In Recipe 21, we created an attribute metaclass that gives attributes a "label"
72		that can be set in L<Moose/has>. That works well until you want a second
73		meta-attribute, or until you want to adjust the behavior of the attribute. You
74		could define a specialized attribute metaclass to use in every attribute.
75		However, you may want different attributes to have different behaviors. You
76		might end up with a unique attribute metaclass for B<every single attribute>,
77		with a lot of code copying and pasting!
78
79		Or, if you've been drinking deeply of the Moose kool-aid, you'll have a role
80		for each of the behaviors. One role would give a label meta-attribute. Another
81		role would signify that this attribute is not directly modifiable via the
82		REST interface. Another role would write to a logfile when this attribute
83		was read.
84
85		Unfortunately, you'd still be left with a bunch of attribute metaclasses that
86		do nothing but compose a bunch of roles. If only there were some way to specify
87		in L<Moose/has> a list of roles to apply to the attribute metaclass...
88
89		=head1 TRAITS
90
91		Roles that apply to metaclasses have a special name: traits. Don't let the
92		change in nomenclature fool you, B<traits are just roles>.
93
94		L<Moose/has> provides a C<traits> option. It takes a list of trait names to
95		compose into an anonymous metaclass. That means you do still have a bunch of
96		attribute metaclasses that do nothing but compose a bunch of roles, but they're
97		managed automatically by Moose. You don't need to declare them in advance, or
98		worry whether changing one will affect some other attribute.
99
100		What can traits do? Anything roles can do. They can add or refine attributes,
101		wrap methods, provide more methods, define an interface, etc. The only
102		difference is that you're now changing the attribute metaclass instead of a
103		user-level class.
104
105		=head1 DISSECTION
106
107		A side-by-side look of the code examples in this recipe and recipe 21 should
108		indicate that defining and using a trait is very similar to defining and using
109		a new attribute metaclass.
110
111		package MyApp::Meta::Attribute::Trait::Labeled;
112		use Moose::Role;
113
114		has label => (
115		is => 'rw',
116		isa => 'Str',
117		predicate => 'has_label',
118		);
119
120		Instead of subclassing L<Moose::Meta::Attribute>, we define a role. Traits
121		don't need any special methods or attributes. You just focus on whatever it is
122		you actually need to get done. Here we're adding a new meta-attribute for use
123		in our application.
124
125		package Moose::Meta::Attribute::Custom::Trait::Labeled;
126		sub register_implementation { 'MyApp::Meta::Attribute::Trait::Labeled' }
127
128		Much like when we define a new attribute metaclass, we can provide a shorthand
129		name for the trait. Moose looks at the C<register_implementation> method in
130		C<Moose::Meta::Attribute::Custom::Trait::$TRAIT_NAME> to find the full
131		name of the trait.
132
133		Now we begin writing our application logic. I'll only cover what has changed
134		since recipe 21.
135
136		has url => (
137		traits => [qw/Labeled/],
138		is => 'rw',
139		isa => 'Str',
140		label => "The site's URL",
141		);
142
143		L<Moose/has> provides a C<traits> option. Just pass the list of trait names and
144		it will compose them together to form the (anonymous) attribute metaclass used
145		by the attribute. We provide a label for the attribute in the same way.
146
147		# print the label if available
148		if ($attribute->does('MyApp::Meta::Attribute::Trait::Labeled')
149		&& $attribute->has_label) {
150		print $attribute->label;
151		}
152
153		Previously, this code asked the question "Does this attribute use our attribute
154		metaclass?" Since we're now using a trait, we ask "Does this attribute's
155		metaclass do the C<Labeled> role?" If not, the attribute metaclass won't have
156		the C<has_label> method, and so it would be an error to blindly call
157		C<< $attribute->has_label >>.
158
159		That's all. Everything else is the same!
160
161		=head1 METACLASS + TRAIT
162
163		"But wait!" you protest. "I've already written all of my extensions as
164		attribute metaclasses. I don't want to break all that code out there."
165
166		All is not lost. If you rewrite your extension as a trait, then you can
167		easily get a regular metaclass extension out of it. You just compose the trait
168		in the attribute metaclass, as normal.
169
170		package MyApp::Meta::Attribute::Labeled;
171		use Moose;
172		extends 'Moose::Meta::Attribute';
173		with 'MyApp::Meta::Attribute::Trait::Labeled';
174
175		package Moose::Meta::Attribute::Custom::Labeled;
176		sub register_implementation { 'MyApp::Meta::Attribute::Labeled' }
177
178		Unfortunately, going the other way (providing a trait created from a metaclass)
179		is more tricky. Thus, defining your extensions as traits is just plain better
180		than defining them as subclassed metaclasses.
181
182		=head1 CONCLUSION
183
184		If you're extending your attributes, it's easier and more flexible to provide
185		composable bits of behavior than to subclass L<Moose::Meta::Attribute>.
186		Using traits (which are just roles applied to a metaclass!) let you choose
187		exactly which behaviors each attribute will have. Moose makes it easy to create
188		attribute metaclasses on the fly by providing a list of trait names to
189		L<Moose/has>.
190
191		=head1 AUTHOR
192
193		Shawn M Moore E<lt>sartak@gmail.comE<gt>
194
195		=head1 COPYRIGHT AND LICENSE
196
197		Copyright 2006-2008 by Infinity Interactive, Inc.
198
199		L<http://www.iinteractive.com>
200
201		This library is free software; you can redistribute it and/or modify
202		it under the same terms as Perl itself.
203
204		=cut
205
206

+0

-240

~~lib/Moose/Cookbook/Recipe3.pod~~ less more

0
1		=pod
2
3		=head1 NAME
4
5		Moose::Cookbook::Recipe3 - A lazy B<BinaryTree> example
6
7		=head1 SYNOPSIS
8
9		package BinaryTree;
10		use Moose;
11
12		has 'node' => (is => 'rw', isa => 'Any');
13
14		has 'parent' => (
15		is => 'rw',
16		isa => 'BinaryTree',
17		predicate => 'has_parent',
18		weak_ref => 1,
19		);
20
21		has 'left' => (
22		is => 'rw',
23		isa => 'BinaryTree',
24		predicate => 'has_left',
25		lazy => 1,
26		default => sub { BinaryTree->new(parent => $_[0]) },
27		);
28
29		has 'right' => (
30		is => 'rw',
31		isa => 'BinaryTree',
32		predicate => 'has_right',
33		lazy => 1,
34		default => sub { BinaryTree->new(parent => $_[0]) },
35		);
36
37		before 'right', 'left' => sub {
38		my ($self, $tree) = @_;
39		$tree->parent($self) if defined $tree;
40		};
41
42		=head1 DESCRIPTION
43
44		In this recipe we take a closer look at attributes, and see how
45		some of their more advanced features can be used to create fairly
46		complex behaviors.
47
48		The class in this recipe is a classic binary tree, each node in the
49		tree is represented by an instance of the B<BinaryTree> class. Each
50		instance has a C<node> slot to hold an arbitrary value, a C<right>
51		slot to hold the right node, a C<left> slot to hold the left node,
52		and finally a C<parent> slot to hold a reference back up the tree.
53
54		Now, let's start with the code. Our first attribute is the C<node>
55		slot, defined as such:
56
57		has 'node' => (is => 'rw', isa => 'Any');
58
59		If you recall from the previous recipes, this slot will have a read/write
60		accessor generated for it, and has a type constraint on it. The new item here is
61		the type constraint of C<Any>. C<Any> is the "root" of the
62		L<Moose::Util::TypeConstraints> type hierarchy. It means exactly what it says:
63		I<any> value passes the constraint. Now, you could just as easily have left out
64		the C<isa>, leaving the C<node> slot unconstrained and retaining this
65		behavior. But in this case, we are really including the type constraint for the
66		benefit of other programmers, not the computer. It makes clear my intent that
67		the C<node> attribute can be of any type, and that the class is a polymorphic
68		container.
69
70		Next, let's move on to the C<parent> slot:
71
72		has 'parent' => (
73		is => 'rw',
74		isa => 'BinaryTree',
75		predicate => 'has_parent',
76		weak_ref => 1,
77		);
78
79		As you already know, this code tells you that C<parent> gets a read/write
80		accessor and is constrained to only accept instances of B<BinaryTree>. You will
81		of course remember from the second recipe that the C<BinaryTree> type constraint
82		is automatically created for us by Moose.
83
84		The next attribute option is new, though: the C<predicate> option.
85		This option creates a method which can be used to check whether
86		a given slot (in this case C<parent>) has been initialized. In
87		this case it will create a method called C<has_parent>. Quite simple,
88		and quite handy too.
89
90		This brings us to our last attribute option, also a new one. Since C<parent> is
91		a circular reference (the tree in C<parent> should already have a reference to
92		this one, in its C<left> or C<right> node), we want to make sure that it is also
93		a weakened reference to avoid memory leaks. The C<weak_ref> attribute option
94		will do just that, C<weak_ref> simply takes a boolean value (C<1> or C<0>) and
95		then alters the accessor function to weaken the reference to any value stored in
96		the C<parent> slot (1).
97
98		Now, onto the C<left> and C<right> attributes. They are essentially identical,
99		save for different names, so I will just describe one here:
100
101		has 'left' => (
102		is => 'rw',
103		isa => 'BinaryTree',
104		predicate => 'has_left',
105		lazy => 1,
106		default => sub { BinaryTree->new(parent => $_[0]) },
107		);
108
109		You already know what the C<is>, C<isa> and C<predicate> options do, but now we
110		have two new options. These two options are actually linked together, in fact:
111		you cannot use the C<lazy> option unless you have set the C<default> option.
112		Class creation will fail with an exception (2).
113
114		Before I go into detail about how C<lazy> works, let me first
115		explain how C<default> works, and in particular why it is wrapped
116		in a CODE ref.
117
118		In the second recipe the B<BankAccount>'s C<balance> slot had a
119		default value of C<0>. Since Perl will copy strings and numbers
120		by value, this was all we had to say. But for any other item
121		(ARRAY ref, HASH ref, object instance, etc) you would need to
122		wrap it in a CODE reference, so this:
123
124		has 'foo' => (is => 'rw', default => []);
125
126		is actually illegal in Moose. Instead, what you really want is this:
127
128		has 'foo' => (is => 'rw', default => sub { [] });
129
130		This ensures that each instance of this class will get its own ARRAY ref in the
131		C<foo> slot.
132
133		One other feature of the CODE ref version of the C<default> option is that when
134		the subroutine is executed (to get the default value), we pass in the instance
135		where the slot will be stored. This can come in quite handy at times, as
136		illustrated above, with this code:
137
138		default => sub { BinaryTree->new(parent => $_[0]) },
139
140		The default value being generated is a new C<BinaryTree> instance for the
141		C<left> (or C<right>) slot. Here we set up the correct relationship by passing
142		the current instance as the C<parent> argument to the constructor.
143
144		Now, before we go on to the C<lazy> option, I want you to think
145		for a moment. When an instance of this class is created, and the
146		slots are being initialized, the "normal" behavior would be for
147		the C<left> and C<right> slots to be populated with a new instance
148		of B<BinaryTree>. In creating that instance of the C<left> or
149		C<right> slots, we would need to create new instances to populate
150		the C<left> and C<right> slots of I<those> instances. This would
151		continue in an I<infinitely recursive spiral of death> until you had
152		exhausted all available memory on your machine.
153
154		This is, of course, not good :)
155
156		Which brings us to the C<lazy> attribute option. The C<lazy> option does just
157		what it says: it lazily initializes the slot within the instance. This means
158		that it waits till absolutely the I<latest> possible moment to populate the
159		slot. So if you, the user, store a value in the slot, everything works normally,
160		and what you pass in is stored. However, if you I<read> the slot I<before>
161		storing a value in it, then at that I<exact> moment (and no sooner), the slot
162		will be populated with the value of the C<default> option.
163
164		This option is what allows the B<BinaryTree> class to instantiate
165		objects without fear of the I<infinitely recursive spiral of death>
166		mentioned earlier.
167
168		So, we have described a quite complex set of behaviors here, and not one method
169		had to be written. But wait, we aren't quite done yet; the autogenerated
170		C<right> and C<left> accessors are not completely correct. They will not install
171		the parental relationships that we need. We could write our own accessors, but
172		that would require us to implement all those features we got automatically (type
173		constraints, lazy initialization, and so on). Instead, we use method modifiers
174		again:
175
176		before 'right', 'left' => sub {
177		my ($self, $tree) = @_;
178		$tree->parent($self) if defined $tree;
179		};
180
181		This is a C<before> modifier, just like we saw in the second recipe, but with
182		two slight differences. First, we are applying this to more than one method at a
183		time. Since both the C<left> and C<right> methods need the same feature, it
184		makes sense. The second difference is that we are not wrapping an inherited
185		method anymore, but instead a method of our own local class. Wrapping local
186		methods is no different, the only requirement is that the wrappee be created
187		before the wrapper (after all, you cannot wrap something which doesn't exist,
188		right?).
189
190		Now, as with all the other recipes, you can go about using
191		B<BinaryTree> like any other Perl 5 class. A more detailed example of its
192		usage can be found in F<t/000_recipes/003_recipe.t>.
193
194		=head1 CONCLUSION
195
196		This recipe introduced you to some of the more advanced behavioral
197		possibilities of Moose's attribute mechanism. I hope that it has
198		opened your mind to the powerful possibilities of Moose. In the next
199		recipe we explore how we can create custom subtypes and take
200		advantage of the plethora of useful modules out on CPAN with Moose.
201
202		=head1 FOOTNOTES
203
204		=over 4
205
206		=item (1)
207
208		Weak references are tricky things, and should be used sparingly
209		and appropriately (such as in the case of circular refs). If you
210		are not careful, you will have slot values disappear "mysteriously"
211		because perls reference counting garbage collector has gone and
212		removed the item you are weak-referencing.
213
214		In short, don't use them unless you know what you are doing :)
215
216		=item (2)
217
218		You I<can> use the C<default> option without the C<lazy> option if
219		you like, as we showed in the second recipe.
220
221		And actually, you can use C<builder> instead of C<default>. See
222		L<Moose::Cookbook::Recipe9> for details.
223
224		=back
225
226		=head1 AUTHOR
227
228		Stevan Little E<lt>stevan@iinteractive.comE<gt>
229
230		=head1 COPYRIGHT AND LICENSE
231
232		Copyright 2006-2008 by Infinity Interactive, Inc.
233
234		L<http://www.iinteractive.com>
235
236		This library is free software; you can redistribute it and/or modify
237		it under the same terms as Perl itself.
238
239		=cut

+0

-295

~~lib/Moose/Cookbook/Recipe4.pod~~ less more

0
1		=pod
2
3		=head1 NAME
4
5		Moose::Cookbook::Recipe4 - Subtypes, and modeling a simple B<Company> class hierarchy
6
7		=head1 SYNOPSIS
8
9		package Address;
10		use Moose;
11		use Moose::Util::TypeConstraints;
12
13		use Locale::US;
14		use Regexp::Common 'zip';
15
16		my $STATES = Locale::US->new;
17
18		subtype USState
19		=> as Str
20		=> where {
21		(exists $STATES->{code2state}{uc($_)} \|\|
22		exists $STATES->{state2code}{uc($_)})
23		};
24
25		subtype USZipCode
26		=> as Value
27		=> where {
28		/^$RE{zip}{US}{-extended => 'allow'}$/
29		};
30
31		has 'street' => (is => 'rw', isa => 'Str');
32		has 'city' => (is => 'rw', isa => 'Str');
33		has 'state' => (is => 'rw', isa => 'USState');
34		has 'zip_code' => (is => 'rw', isa => 'USZipCode');
35
36		package Company;
37		use Moose;
38		use Moose::Util::TypeConstraints;
39
40		has 'name' => (is => 'rw', isa => 'Str', required => 1);
41		has 'address' => (is => 'rw', isa => 'Address');
42		has 'employees' => (is => 'rw', isa => 'ArrayRef[Employee]');
43
44		sub BUILD {
45		my ($self, $params) = @_;
46		if ($params->{employees}) {
47		foreach my $employee (@{$params->{employees}}) {
48		$employee->company($self);
49		}
50		}
51		}
52
53		after 'employees' => sub {
54		my ($self, $employees) = @_;
55		if (defined $employees) {
56		foreach my $employee (@{$employees}) {
57		$employee->company($self);
58		}
59		}
60		};
61
62		package Person;
63		use Moose;
64
65		has 'first_name' => (is => 'rw', isa => 'Str', required => 1);
66		has 'last_name' => (is => 'rw', isa => 'Str', required => 1);
67		has 'middle_initial' => (is => 'rw', isa => 'Str',
68		predicate => 'has_middle_initial');
69		has 'address' => (is => 'rw', isa => 'Address');
70
71		sub full_name {
72		my $self = shift;
73		return $self->first_name .
74		($self->has_middle_initial ?
75		' ' . $self->middle_initial . '. '
76		:
77		' ') .
78		$self->last_name;
79		}
80
81		package Employee;
82		use Moose;
83
84		extends 'Person';
85
86		has 'title' => (is => 'rw', isa => 'Str', required => 1);
87		has 'company' => (is => 'rw', isa => 'Company', weak_ref => 1);
88
89		override 'full_name' => sub {
90		my $self = shift;
91		super() . ', ' . $self->title
92		};
93
94		=head1 DESCRIPTION
95
96		In this recipe we introduce the C<subtype> keyword, and show
97		how it can be useful for specifying type constraints
98		without building an entire class to represent them. We
99		will also show how this feature can be used to leverage the
100		usefulness of CPAN modules. In addition to this, we will
101		introduce another attribute option.
102
103		Let's first look at the C<subtype> feature. In the B<Address> class we have
104		defined two subtypes. The first C<subtype> uses the L<Locale::US> module, which
105		provides two hashes which can be used to perform existential checks for state
106		names and their two letter state codes. It is a very simple and very useful
107		module, and perfect for use in a C<subtype> constraint.
108
109		my $STATES = Locale::US->new;
110		subtype USState
111		=> as Str
112		=> where {
113		(exists $STATES->{code2state}{uc($_)} \|\|
114		exists $STATES->{state2code}{uc($_)})
115		};
116
117		Because we know that states will be passed to us as strings, we
118		can make C<USState> a subtype of the built-in type constraint
119		C<Str>. This will ensure that anything which is a C<USState> will
120		also pass as a C<Str>. Next, we create a constraint specializer
121		using the C<where> keyword. The value being checked against in
122		the C<where> clause can be found in the C<$_> variable (1). Our
123		constraint specializer will then check whether the given string
124		is either a state name or a state code. If the string meets this
125		criteria, then the constraint will pass, otherwise it will fail.
126		We can now use this as we would any built-in constraint, like so:
127
128		has 'state' => (is => 'rw', isa => 'USState');
129
130		The C<state> accessor will now check all values against the
131		C<USState> constraint, thereby only allowing valid state names or
132		state codes to be stored in the C<state> slot.
133
134		The next C<subtype> does pretty much the same thing using the L<Regexp::Common>
135		module, and is used as the constraint for the C<zip_code> slot.
136
137		subtype USZipCode
138		=> as Value
139		=> where {
140		/^$RE{zip}{US}{-extended => 'allow'}$/
141		};
142
143		Using subtypes can save a lot of unnecessary abstraction by not requiring you to
144		create many small classes for these relatively simple values. They also allow
145		you to reuse the same constraints in a number of classes (thereby avoiding
146		duplication), since all type constraints are stored in a global registry and
147		always accessible to C<has>.
148
149		With these two subtypes and some attributes, we have defined
150		as much as we need for a basic B<Address> class. Next, we define
151		a basic B<Company> class, which itself has an address. As we saw in
152		earlier recipes, we can use the C<Address> type constraint that
153		Moose automatically created for us:
154
155		has 'address' => (is => 'rw', isa => 'Address');
156
157		A company also needs a name, so we define that as well:
158
159		has 'name' => (is => 'rw', isa => 'Str', required => 1);
160
161		Here we introduce another attribute option, the C<required> option.
162		This option tells Moose that C<name> is a required parameter in
163		the B<Company> constructor, and that the C<name> accessor cannot
164		accept an undefined value for the slot. The result is that C<name>
165		will always have a value.
166
167		The next attribute option is not actually new, but a new variant
168		of options we have already introduced:
169
170		has 'employees' => (is => 'rw', isa => 'ArrayRef[Employee]');
171
172		Here, we are passing a more complex string to the C<isa> option, we
173		are passing a container type constraint. Container type constraints
174		can either be C<ArrayRef> or C<HashRef> with a contained type given
175		inside the square brackets. This basically checks that all the values
176		in the ARRAY ref are instances of the B<Employee> class.
177
178		This will ensure that our employees will all be of the correct type. However,
179		the B<Employee> object (which we will see in a moment) also maintains a
180		reference to its associated B<Company>. In order to maintain this relationship
181		(and preserve the referential integrity of our objects), we need to perform some
182		processing of the employees over and above that of the type constraint check.
183		This is accomplished in two places. First we need to be sure that any employees
184		array passed to the constructor is properly initialized. For this we can use the
185		C<BUILD> method (2):
186
187		sub BUILD {
188		my ($self, $params) = @_;
189		if ($params->{employees}) {
190		foreach my $employee (@{$params->{employees}}) {
191		$employee->company($self);
192		}
193		}
194		}
195
196		The C<BUILD> method will be executed after the initial type constraint
197		check, so we can simply perform a basic existential check on the C<employees>
198		param here, and assume that if it does exist, it is both an ARRAY ref
199		and contains I<only> instances of B<Employee>.
200
201		The next aspect we need to address is the C<employees> read/write
202		accessor (see the C<employees> attribute declaration above). This
203		accessor will correctly check the type constraint, but we need to extend it
204		with some additional processing. For this we use an C<after> method modifier,
205		like so:
206
207		after 'employees' => sub {
208		my ($self, $employees) = @_;
209		if (defined $employees) {
210		foreach my $employee (@{$employees}) {
211		$employee->company($self);
212		}
213		}
214		};
215
216		Again, as with the C<BUILD> method, we know that the type constraint
217		check has already happened, so we can just check for defined-ness on the
218		C<$employees> argument.
219
220		At this point, our B<Company> class is complete. Next comes our B<Person>
221		class and its subclass, the previously mentioned B<Employee> class.
222
223		The B<Person> class should be obvious to you at this point. It has a few
224		C<required> attributes, and the C<middle_initial> slot has an additional
225		C<predicate> method (which we saw in the previous recipe with the
226		B<BinaryTree> class).
227
228		Next, the B<Employee> class, which should also be pretty obvious at this
229		point. It requires a C<title>, and maintains a weakened reference to a
230		B<Company> instance. The only new item, which we have seen before in
231		examples, but never in the recipe itself, is the C<override> method
232		modifier:
233
234		override 'full_name' => sub {
235		my $self = shift;
236		super() . ', ' . $self->title
237		};
238
239		This just tells Moose that I am intentionally overriding the superclass
240		C<full_name> method here, and adding the value of the C<title> slot at
241		the end of the employee's full name.
242
243		And that's about it.
244
245		Once again, as with all the other recipes, you can go about using
246		these classes like any other Perl 5 class. A more detailed example of
247		usage can be found in F<t/000_recipes/004_recipe.t>.
248
249		=head1 CONCLUSION
250
251		This recipe was intentionally longer and more complex to illustrate both
252		how easily Moose classes can interact (using class type constraints, etc.)
253		and the sheer density of information and behaviors which Moose can pack
254		into a relatively small amount of typing. Ponder for a moment how much
255		more code a non-Moose plain old Perl 5 version of this recipe would have
256		been (including all the type constraint checks, weak references, and so on).
257
258		And of course, this recipe also introduced the C<subtype> keyword, and
259		its usefulness within the Moose toolkit. In the next recipe we will
260		focus more on subtypes, and introduce the idea of type coercion as well.
261
262		=head1 FOOTNOTES
263
264		=over 4
265
266		=item (1)
267
268		The value being checked is also passed as the first argument to
269		the C<where> block as well, so it can also be accessed as C<$_[0]>
270		as well.
271
272		=item (2)
273
274		The C<BUILD> method is called by C<Moose::Object::BUILDALL>, which is
275		called by C<Moose::Object::new>. C<BUILDALL> will climb the object
276		inheritance graph and call the appropriate C<BUILD> methods in the
277		correct order.
278
279		=back
280
281		=head1 AUTHOR
282
283		Stevan Little E<lt>stevan@iinteractive.comE<gt>
284
285		=head1 COPYRIGHT AND LICENSE
286
287		Copyright 2006-2008 by Infinity Interactive, Inc.
288
289		L<http://www.iinteractive.com>
290
291		This library is free software; you can redistribute it and/or modify
292		it under the same terms as Perl itself.
293
294		=cut

+0

-198

~~lib/Moose/Cookbook/Recipe5.pod~~ less more

0
1		=pod
2
3		=head1 NAME
4
5		Moose::Cookbook::Recipe5 - More subtypes, coercion in a B<Request> class
6
7		=head1 SYNOPSIS
8
9		package Request;
10		use Moose;
11		use Moose::Util::TypeConstraints;
12
13		use HTTP::Headers ();
14		use Params::Coerce ();
15		use URI ();
16
17		subtype 'Header'
18		=> as 'Object'
19		=> where { $_->isa('HTTP::Headers') };
20
21		coerce 'Header'
22		=> from 'ArrayRef'
23		=> via { HTTP::Headers->new( @{ $_ } ) }
24		=> from 'HashRef'
25		=> via { HTTP::Headers->new( %{ $_ } ) };
26
27		subtype 'Uri'
28		=> as 'Object'
29		=> where { $_->isa('URI') };
30
31		coerce 'Uri'
32		=> from 'Object'
33		=> via { $_->isa('URI')
34		? $_
35		: Params::Coerce::coerce( 'URI', $_ ) }
36		=> from 'Str'
37		=> via { URI->new( $_, 'http' ) };
38
39		subtype 'Protocol'
40		=> as Str
41		=> where { /^HTTP\/[0-9]\.[0-9]$/ };
42
43		has 'base' => (is => 'rw', isa => 'Uri', coerce => 1);
44		has 'uri' => (is => 'rw', isa => 'Uri', coerce => 1);
45		has 'method' => (is => 'rw', isa => 'Str');
46		has 'protocol' => (is => 'rw', isa => 'Protocol');
47		has 'headers' => (
48		is => 'rw',
49		isa => 'Header',
50		coerce => 1,
51		default => sub { HTTP::Headers->new }
52		);
53
54		=head1 DESCRIPTION
55
56		This recipe introduces the idea of type coercions, and the C<coerce>
57		keyword. Coercions can be attached to existing type constraints,
58		and can be used to transform input of one type into input of another
59		type. This can be an extremely powerful tool if used correctly, which
60		is why it is off by default. If you want your accessor to attempt
61		a coercion, you must specifically ask for it with the B<coerce> option.
62
63		Now, onto the coercions.
64
65		First we need to create a subtype to attach our coercion to. Here we
66		create a basic I<Header> subtype, which matches any instance of the
67		class B<HTTP::Headers>:
68
69		subtype 'Header'
70		=> as 'Object'
71		=> where { $_->isa('HTTP::Headers') };
72
73		The simplest thing from here would be create an accessor declaration
74		like this:
75
76		has 'headers' => (
77		is => 'rw',
78		isa => 'Header',
79		default => sub { HTTP::Headers->new }
80		);
81
82		We would then have a self-validating accessor whose default value is
83		an empty instance of B<HTTP::Headers>. This is nice, but it is not
84		ideal.
85
86		The constructor for B<HTTP::Headers> accepts a list of key-value pairs
87		representing the HTTP header fields. In Perl, such a list could
88		easily be stored in an ARRAY or HASH reference. We would like our
89		class's interface to be able to accept this list of key-value pairs
90		in place of the B<HTTP::Headers> instance, and just DWIM. This is where
91		coercion can help. First, let's declare our coercion:
92
93		coerce 'Header'
94		=> from 'ArrayRef'
95		=> via { HTTP::Headers->new( @{ $_ } ) }
96		=> from 'HashRef'
97		=> via { HTTP::Headers->new( %{ $_ } ) };
98
99		We first tell it that we are attaching the coercion to the 'Header'
100		subtype. We then give it a set of C<from> clauses which map other
101		subtypes to coercion routines (through the C<via> keyword). Fairly
102		simple really; however, this alone does nothing. We have to tell
103		our attribute declaration to actually use the coercion, like so:
104
105		has 'headers' => (
106		is => 'rw',
107		isa => 'Header',
108		coerce => 1,
109		default => sub { HTTP::Headers->new }
110		);
111
112		This will coerce any B<ArrayRef> or B<HashRef> which is passed into
113		the C<headers> accessor into an instance of B<HTTP::Headers>. So the
114		the following lines of code are all equivalent:
115
116		$foo->headers(HTTP::Headers->new(bar => 1, baz => 2));
117		$foo->headers([ 'bar', 1, 'baz', 2 ]);
118		$foo->headers({ bar => 1, baz => 2 });
119
120		As you can see, careful use of coercions can produce a very open
121		interface for your class, while still retaining the "safety" of
122		your type constraint checks.
123
124		Our next coercion takes advantage of the power of CPAN to handle
125		the details of our coercion. In this particular case it uses the
126		L<Params::Coerce> module, which fits in rather nicely with L<Moose>.
127
128		Again, we create a simple subtype to represent instances of the
129		B<URI> class:
130
131		subtype 'Uri'
132		=> as 'Object'
133		=> where { $_->isa('URI') };
134
135		Then we add the coercion:
136
137		coerce 'Uri'
138		=> from 'Object'
139		=> via { $_->isa('URI')
140		? $_
141		: Params::Coerce::coerce( 'URI', $_ ) }
142		=> from 'Str'
143		=> via { URI->new( $_, 'http' ) };
144
145		The first C<from> clause we introduce is for the 'Object' subtype. An 'Object'
146		is simply any C<bless>ed value. This means that if the coercion encounters
147		another object, it should use this clause. Now we look at the C<via> block.
148		First it checks to see if the object is a B<URI> instance. Since the coercion
149		process occurs prior to any type constraint checking, it is entirely possible
150		for this to happen, and if it does happen, we simply want to pass the instance
151		on through. However, if it is not an instance of B<URI>, then we need to coerce
152		it. This is where L<Params::Coerce> can do its magic, and we can just use its
153		return value. Simple really, and much less work since we used a module from CPAN
154		:)
155
156		The second C<from> clause is attached to the 'Str' subtype, and
157		illustrates how coercions can also be used to handle certain
158		'default' behaviors. In this coercion, we simple take any string
159		and pass it to the B<URI> constructor along with the default
160		'http' scheme type.
161
162		And of course, our coercions do nothing unless they are told to,
163		like so:
164
165		has 'base' => (is => 'rw', isa => 'Uri', coerce => 1);
166		has 'uri' => (is => 'rw', isa => 'Uri', coerce => 1);
167
168		As you can see, re-using the coercion allows us to enforce a
169		consistent and very flexible API across multiple accessors.
170
171		=head1 CONCLUSION
172
173		This recipe illustrated the power of coercions to build a more
174		flexible and open API for your accessors, while still retaining
175		all the safety that comes from using Moose's type constraints.
176		Using coercions it becomes simple to manage (from a single
177		location) a consistent API not only across multiple accessors,
178		but across multiple classes as well.
179
180		In the next recipe, we will introduce roles, a concept originally
181		borrowed from Smalltalk, which made it's way into Perl 6, and
182		now into Moose.
183
184		=head1 AUTHOR
185
186		Stevan Little E<lt>stevan@iinteractive.comE<gt>
187
188		=head1 COPYRIGHT AND LICENSE
189
190		Copyright 2006-2008 by Infinity Interactive, Inc.
191
192		L<http://www.iinteractive.com>
193
194		This library is free software; you can redistribute it and/or modify
195		it under the same terms as Perl itself.
196
197		=cut⏎

+0

-86

~~lib/Moose/Cookbook/Recipe6.pod~~ less more

0
1		=pod
2
3		=head1 NAME
4
5		Moose::Cookbook::Recipe6 - The augment/inner example
6
7		=head1 SYNOPSIS
8
9		package Document::Page;
10		use Moose;
11
12		has 'body' => (is => 'rw', isa => 'Str', default => sub {''});
13
14		sub create {
15		my $self = shift;
16		$self->open_page;
17		inner();
18		$self->close_page;
19		}
20
21		sub append_body {
22		my ($self, $appendage) = @_;
23		$self->body($self->body . $appendage);
24		}
25
26		sub open_page { (shift)->append_body('<page>') }
27		sub close_page { (shift)->append_body('</page>') }
28
29		package Document::PageWithHeadersAndFooters;
30		use Moose;
31
32		extends 'Document::Page';
33
34		augment 'create' => sub {
35		my $self = shift;
36		$self->create_header;
37		inner();
38		$self->create_footer;
39		};
40
41		sub create_header { (shift)->append_body('<header/>') }
42		sub create_footer { (shift)->append_body('<footer/>') }
43
44		package TPSReport;
45		use Moose;
46
47		extends 'Document::PageWithHeadersAndFooters';
48
49		augment 'create' => sub {
50		my $self = shift;
51		$self->create_tps_report;
52		};
53
54		sub create_tps_report {
55		(shift)->append_body('<report type="tps"/>')
56		}
57
58		print TPSReport->new->create # <page><header/><report type="tps"/><footer/></page>
59
60		=head1 DESCRIPTION
61
62		Coming Soon.
63
64		=head1 CONCLUSION
65
66		=head1 FOOTNOTES
67
68		=over 4
69
70		=back
71
72		=head1 AUTHOR
73
74		Stevan Little E<lt>stevan@iinteractive.comE<gt>
75
76		=head1 COPYRIGHT AND LICENSE
77
78		Copyright 2007 by Infinity Interactive, Inc.
79
80		L<http://www.iinteractive.com>
81
82		This library is free software; you can redistribute it and/or modify
83		it under the same terms as Perl itself.
84
85		=cut

+0

-61

~~lib/Moose/Cookbook/Recipe7.pod~~ less more

0
1		=pod
2
3		=head1 NAME
4
5		Moose::Cookbook::Recipe7 - Making Moose fast with immutable
6
7		=head1 SYNOPSIS
8
9		package Point;
10		use Moose;
11
12		has 'x' => (isa => 'Int', is => 'ro');
13		has 'y' => (isa => 'Int', is => 'rw');
14
15		__PACKAGE__->meta->make_immutable;
16
17		=head1 DESCRIPTION
18
19		The Moose metaclass API provides a method C<make_immutable()>. At a
20		high level, this calling this method does two things to your
21		class. One, it makes it faster. In particular, object construction and
22		accessors are effectively "inlined" in your class, and no longer go
23		through the meta-object system.
24
25		Second, you can no longer make changes via the metaclass API such as
26		adding attributes. In practice, this won't be a problem, as you don't
27		usually need to do this at runtime after first loading the class.
28
29		=head2 Immutabilization and C<new()>
30
31		If you override C<new()> in your class, then the immutabilization code
32		will not be able to provide an optimized constructor for your
33		class. Instead, consider providing a C<BUILD()> method. You can
34		probably do the same thing in a C<BUILD()> method.
35
36		Alternately, if you really need to provide a different C<new()>, you
37		can also provide your own immutabilization method.
38
39		Discussing this is beyond the scope of this recipe, however.
40
41		=head1 CONCLUSION
42
43		We strongly recommend you make your classes immutable. It makes your
44		code much faster, basically for free. This will be especially
45		noticeable when creating many objects or calling accessors frequently.
46
47		=head1 AUTHOR
48
49		Dave Rolsky E<lt>autarch@urth.orgE<gt>
50
51		=head1 COPYRIGHT AND LICENSE
52
53		Copyright 2006-2008 by Infinity Interactive, Inc.
54
55		L<http://www.iinteractive.com>
56
57		This library is free software; you can redistribute it and/or modify
58		it under the same terms as Perl itself.
59
60		=cut

+0

-210

~~lib/Moose/Cookbook/Recipe9.pod~~ less more

0
1		=pod
2
3		=head1 NAME
4
5		Moose::Cookbook::Recipe9 - Builder methods and lazy_build
6
7		=head1 SYNOPSIS
8
9		package BinaryTree;
10		use Moose;
11
12		has 'node' => (is => 'rw', isa => 'Any');
13
14		has 'parent' => (
15		is => 'rw',
16		isa => 'BinaryTree',
17		predicate => 'has_parent',
18		weak_ref => 1,
19		);
20
21		has 'left' => (
22		is => 'rw',
23		isa => 'BinaryTree',
24		predicate => 'has_left',
25		lazy => 1,
26		builder => '_build_child_tree',
27		);
28
29		has 'right' => (
30		is => 'rw',
31		isa => 'BinaryTree',
32		predicate => 'has_right',
33		lazy => 1,
34		builder => '_build_child_tree',
35		);
36
37		before 'right', 'left' => sub {
38		my ($self, $tree) = @_;
39		$tree->parent($self) if defined $tree;
40		};
41
42		sub _build_child_tree {
43		my $self = shift;
44
45		return BinaryTree->new( parent => $self );
46		}
47
48		=head1 DESCRIPTION
49
50		If you've already read L<Moose::Cookbook::Recipe3>, then this example
51		should look awfully familiar. In fact, all we've done here is replace
52		the attribute C<default> with a C<builder> method.
53
54		In this particular case, the C<default> and C<builder> options act in
55		exactly the same way. When the C<left> or C<right> attribute get
56		method is called, Moose will call the builder method to initialize the
57		attribute.
58
59		Note that Moose calls the builder method I<on the object which has the
60		attribute>. Here's an example in code:
61
62		my $tree = BinaryTree->new();
63
64		my $left = $tree->left();
65
66		At this point, Moose will call C<< $tree->_build_child_tree() >> in
67		order to populate the C<left> attribute. If we had passed C<left> to
68		the original constructor, the builer would not be called.
69
70		=head2 Subclassable
71
72		There are some differences between C<default> and C<builder>. Because
73		C<builder> is called I<by name>, it goes through Perl's normal
74		inheritance system. This means that builder methods are both
75		inheritable and overrideable.
76
77		For example, we might make a C<BinaryTree> subclass:
78
79		package TrinaryTree;
80		use Moose;
81
82		extends 'BinaryTree';
83
84		has 'middle' => (
85		is => 'rw',
86		isa => 'BinaryTree',
87		predicate => 'has_middle',
88		lazy => 1,
89		builder => '_build_child_tree',
90		);
91
92		This doesn't quite work though. If you look closely at the
93		C<_build_child_tree> method defined in C<BinaryTree>, you'll notice
94		that it hard-codes a class name. Naughty us!
95
96		Also, as a bonus, we'll pass C<@_> through, so subclasses can override
97		the method to pass additional options to the constructor.
98
99		Good object-oriented code should allow itself to be subclassed
100		gracefully. Let's tweak C<_build_child_tree>:
101
102		sub _build_child_tree {
103		my $self = shift;
104
105		return (ref $self)->new( parent => $self, @_ );
106		}
107
108		Now C<_build_child_tree> can be gracefully inherited and overridden.
109
110		=head2 Composable
111
112		There's more to builders than just subclassing, though. The fact that
113		builders are called by name also makes them suitable for use in a
114		role.
115
116		package HasAnimal;
117		use Moose::Role;
118
119		requires '_build_animal';
120
121		has 'animal' => (
122		is => 'ro',
123		isa => 'Animal',
124		lazy => 1,
125		builder => '_build_animal',
126		);
127
128		This role provides an animal attribute, but requires that the consumer
129		of the role provide a builder method it.
130
131		package CatLover;
132		use Moose;
133
134		with 'HasAnimal';
135
136		sub _build_animal {
137		return Cat->new();
138		}
139
140		=head2 The lazy_build shortcut
141
142		The C<lazy_build> attribute parameter can be used as sugar to specify
143		a whole bunch of options at once.
144
145		has 'animal' => (
146		is => 'ro',
147		isa => 'Animal',
148		lazy_build => 1,
149		);
150
151		This is a shorthand for this:
152
153		has 'animal' => (
154		is => 'ro',
155		isa => 'Animal',
156		required => 1,
157		lazy => 1,
158		builder => '_build_animal',
159		predicate => 'has_animal',
160		clearer => 'clear_animal',
161		);
162
163		If your attribute starts with an underscore, Moose is smart and will
164		do the right thing with the C<predicate> and C<clearer>, making them
165		both start with an underscore. The C<builder> method I<always> starts
166		with an underscore, since you will want this to be private the vast
167		majority of the time.
168
169		Note that the C<builder> method name is created by simply taking
170		"_build_" and appending the attribute name. This means that attributes
171		with a leading underscore like C<_animal> end up with a builder named
172		C<_build__animal>.
173
174		=head1 CONCLUSION
175
176		The C<builder> option is a more OO-friendly version of the C<default>
177		functionality. It also has the property of separating out the code
178		into a separate well-defined method. This alone makes it valuable. It
179		is quite ugly to jam a long default code reference into your attribute
180		definition.
181
182		Here are some good rules for determining when to use C<builder> vs
183		C<default>.
184
185		If the default value is a simple scalar that only needs to be
186		calculated once (or a constant), use C<default>.
187
188		If the default value is an empty reference that needs to be wrapped in
189		a coderef like C<sub { [] }>, use C<default>.
190
191		Otherwise, use C<builder>.
192
193		This ensures that your classes are easily subclassable, and also helps
194		keep crufty code out of your attribute definition blocks.
195
196		=head1 AUTHOR
197
198		Dave Rolsky E<lt>autarch@urth.orgE<gt>
199
200		=head1 COPYRIGHT AND LICENSE
201
202		Copyright 2006-2008 by Infinity Interactive, Inc.
203
204		L<http://www.iinteractive.com>
205
206		This library is free software; you can redistribute it and/or modify
207		it under the same terms as Perl itself.
208
209		=cut

+212

-0

lib/Moose/Cookbook/Roles/Recipe1.pod less more

	0
	1	=pod
	2
	3	=head1 NAME
	4
	5	Moose::Cookbook::Roles::Recipe1 - The Moose::Role example
	6
	7	=head1 SYNOPSIS
	8
	9	package Eq;
	10	use Moose::Role;
	11
	12	requires 'equal_to';
	13
	14	sub not_equal_to {
	15	my ($self, $other) = @_;
	16	not $self->equal_to($other);
	17	}
	18
	19	package Comparable;
	20	use Moose::Role;
	21
	22	with 'Eq';
	23
	24	requires 'compare';
	25
	26	sub equal_to {
	27	my ($self, $other) = @_;
	28	$self->compare($other) == 0;
	29	}
	30
	31	sub greater_than {
	32	my ($self, $other) = @_;
	33	$self->compare($other) == 1;
	34	}
	35
	36	sub less_than {
	37	my ($self, $other) = @_;
	38	$self->compare($other) == -1;
	39	}
	40
	41	sub greater_than_or_equal_to {
	42	my ($self, $other) = @_;
	43	$self->greater_than($other) \|\| $self->equal_to($other);
	44	}
	45
	46	sub less_than_or_equal_to {
	47	my ($self, $other) = @_;
	48	$self->less_than($other) \|\| $self->equal_to($other);
	49	}
	50
	51	package Printable;
	52	use Moose::Role;
	53
	54	requires 'to_string';
	55
	56	package US::Currency;
	57	use Moose;
	58
	59	with 'Comparable', 'Printable';
	60
	61	has 'amount' => (is => 'rw', isa => 'Num', default => 0);
	62
	63	sub compare {
	64	my ($self, $other) = @_;
	65	$self->amount <=> $other->amount;
	66	}
	67
	68	sub to_string {
	69	my $self = shift;
	70	sprintf '$%0.2f USD' => $self->amount
	71	}
	72
	73	=head1 DESCRIPTION
	74
	75	In this recipe we examine the role support provided in Moose. "Roles" may be
	76	described in many ways, but there are two main ways in which they are used: as
	77	interfaces, and as a means of code reuse. This recipe demonstrates the
	78	construction and incorporation of roles that define comparison and display of
	79	objects.
	80
	81	Let's start by examining B<Eq>. You'll notice that instead of the familiar C<use
	82	Moose> you might be expecting, here we use C<Moose::Role> to make it clear that
	83	this is a role. We encounter a new keyword, C<requires>:
	84
	85	requires 'equal_to';
	86
	87	What this does is to indicate that any class which "consumes" (that is to say,
	88	"includes using C<with>", as we'll see a little later) the B<Eq> role I<must>
	89	include an C<equal_to> method, whether this is provided by the class itself, one
	90	of its superclasses, or another role consumed by the class (1).
	91
	92	In addition to requiring an C<equal_to> method, B<Eq> defines a C<not_equal_to>
	93	method, which simply inverts the result of C<equal_to>. Defining additional
	94	methods in this way, by using only a few base methods that target classes must
	95	define, is a useful pattern to provide maximum functionality with minimum
	96	effort.
	97
	98	After the minimal B<Eq>, we next move on to B<Comparable>. The first thing you
	99	will notice is another new keyword, C<with>:
	100
	101	with 'Eq';
	102
	103	C<with> is used to provide a list of roles which this class (or role) consumes.
	104	Here, B<Comparable> only consumes one role (B<Eq>). In effect, it is as if we
	105	defined a C<not_equal_to> method within Comparable, and also promised to fulfill
	106	the requirement of an C<equal_to> method.
	107
	108	B<Comparable> itself states that it requires C<compare>. Again, it means that
	109	any classes consuming this role must implement a C<compare> method.
	110
	111	requires 'compare';
	112
	113	B<Comparable> defines an C<equal_to> method which satisfies the B<Eq> role's
	114	requirements. This, along with a number of other methods (C<greater_than>,
	115	C<less_than>, C<greater_than_or_equal_to>, and C<less_than_or_equal_to>) is
	116	simply defined in terms of C<compare>, once again demonstrating the pattern of
	117	defining a number of utility methods in terms of only a single method that the
	118	target class need implement.
	119
	120	sub equal_to {
	121	my ($self, $other) = @_;
	122	$self->compare($other) == 0;
	123	}
	124
	125	sub greater_than {
	126	my ($self, $other) = @_;
	127	$self->compare($other) == 1;
	128	}
	129
	130	sub less_than {
	131	my ($self, $other) = @_;
	132	$self->compare($other) == -1;
	133	}
	134
	135	sub greater_than_or_equal_to {
	136	my ($self, $other) = @_;
	137	$self->greater_than($other) \|\| $self->equal_to($other);
	138	}
	139
	140	sub less_than_or_equal_to {
	141	my ($self, $other) = @_;
	142	$self->less_than($other) \|\| $self->equal_to($other);
	143	}
	144
	145	Next up is B<Printable>. This is a very simple role, akin to B<Eq>. It merely
	146	requires a C<to_string> method.
	147
	148	Finally, we come to B<US::Currency>, a class that allows us to reap the benefits
	149	of our hard work. This is a regular Moose class, so we include the normal C<use
	150	Moose>. It consumes both B<Comparable> and B<Printable>, as the following line
	151	shows:
	152
	153	with 'Comparable', 'Printable';
	154
	155	It also defines a regular Moose attribute, C<amount>, with a type constraint of
	156	C<Num> and a default of C<0>:
	157
	158	has 'amount' => (is => 'rw', isa => 'Num', default => 0);
	159
	160	Now we come to the core of the class. First up, we define a C<compare> method:
	161
	162	sub compare {
	163	my ($self, $other) = @_;
	164	$self->amount <=> $other->amount;
	165	}
	166
	167	As you can see, it simply compares the C<amount> attribute of this object with
	168	the C<amount> attribute of the other object passed to it. With the single
	169	definition of this method, we gain the following methods for free: C<equal_to>,
	170	C<greater_than>, C<less_than>, C<greater_than_or_equal_to> and
	171	C<less_than_or_equal_to>.
	172
	173	We end the class with a definition of the C<to_string> method, which formats the
	174	C<amount> attribute for display:
	175
	176	sub to_string {
	177	my $self = shift;
	178	sprintf '$%0.2f USD' => $self->amount
	179	}
	180
	181	=head1 CONCLUSION
	182
	183	This recipe has shown that roles can be very powerful and immensely useful, and
	184	save a great deal of repetition.
	185
	186	=head1 FOOTNOTES
	187
	188	=over 4
	189
	190	=item (1)
	191
	192	At present, method requirements from roles cannot be satisfied by attribute
	193	accessors. This is a limitation of Moose, and will most likely be rectified in a
	194	future release.
	195
	196	=back
	197
	198	=head1 AUTHOR
	199
	200	Stevan Little E<lt>stevan@iinteractive.comE<gt>
	201
	202	=head1 COPYRIGHT AND LICENSE
	203
	204	Copyright 2006-2008 by Infinity Interactive, Inc.
	205
	206	L<http://www.iinteractive.com>
	207
	208	This library is free software; you can redistribute it and/or modify
	209	it under the same terms as Perl itself.
	210
	211	=cut

+121

-0

lib/Moose/Cookbook/Roles/Recipe2.pod less more

	0
	1	=pod
	2
	3	=head1 NAME
	4
	5	Moose::Cookbook::Roles::Recipe2 - Advanced Role Composition - method exclusion and aliasing
	6
	7	=head1 SYNOPSIS
	8
	9	package Restartable;
	10	use Moose::Role;
	11
	12	has 'is_paused' => (
	13	is => 'rw',
	14	isa => 'Bool',
	15	default => 0,
	16	);
	17
	18	requires 'save_state', 'load_state';
	19
	20	sub stop { ... }
	21
	22	sub start { ... }
	23
	24	package Restartable::ButUnreliable;
	25	use Moose::Role;
	26
	27	with 'Restartable' => { alias => { stop => '_stop',
	28	start => '_start' } };
	29
	30	sub stop {
	31	my $self = shift;
	32
	33	$self->explode() if rand(1) > .5;
	34
	35	$self->_stop();
	36	}
	37
	38	sub start {
	39	my $self = shift;
	40
	41	$self->explode() if rand(1) > .5;
	42
	43	$self->_start();
	44	}
	45
	46	package Restartable::ButBroken;
	47	use Moose::Role;
	48
	49	with 'Restartable' => { excludes => [ 'stop', 'start' ] };
	50
	51	sub stop {
	52	my $self = shift;
	53
	54	$self->explode();
	55	}
	56
	57	sub start {
	58	my $self = shift;
	59
	60	$self->explode();
	61	}
	62
	63	=head1 DESCRIPTION
	64
	65	Sometimes when you include a role in a class, you may want to leave
	66	out some of its methods. In this example, we have a role C<Restartable>
	67	which provides an C<is_paused> attribute, and two methods, C<stop> and
	68	C<start>. The implementation of those two methods is irrelevant.
	69
	70	Then we have two more roles which also implement the same interface,
	71	each putting their own spin on the C<stop> and C<start> method.
	72
	73	In the C<Restartable::ButUnreliable> role, we want to provide a new
	74	implementation of C<stop> and C<start>, but still have access to the
	75	original implementation. To do this, we alias the methods from
	76	C<Restartable> to private methods, and provide wrappers around the
	77	originals (1).
	78
	79	In the C<Restartable::ButBroken> role, we want to provide an entirely
	80	new behavior for C<stop> and C<start>, so we exclude them when
	81	composing the C<Restartable> role into C<Restartable::ButBroken>.
	82
	83	It's worth noting that the C<excludes> parameter also accepts a single
	84	string as an argument if you just want to exclude one method.
	85
	86	=head1 CONCLUSION
	87
	88	Method exclusion and renaming can come in handy, especially when
	89	building roles out of other roles. In this example, all of our roles
	90	implement the C<Restartable> role. Each role provides same API, but
	91	each has a different implementation under the hood.
	92
	93	You can also use the method aliasing and excluding features when
	94	composing a role into a class.
	95
	96	=head1 FOOTNOTES
	97
	98	=over 4
	99
	100	=item (1)
	101
	102	The mention of wrapper should tell you that we could do the same thing
	103	using method modifiers, but for the sake of this example, we don't.
	104
	105	=back
	106
	107	=head1 AUTHOR
	108
	109	Dave Rolsky E<lt>autarch@urth.orgE<gt>
	110
	111	=head1 COPYRIGHT AND LICENSE
	112
	113	Copyright 2006-2008 by Infinity Interactive, Inc.
	114
	115	L<http://www.iinteractive.com>
	116
	117	This library is free software; you can redistribute it and/or modify
	118	it under the same terms as Perl itself.
	119
	120	=cut

+0

-2

lib/Moose/Cookbook/Snack/Keywords.pod less more

41	41	=item inner
42	42
43	43	=item augment
44
45		=item make_immutable
46	44
47	45	=item confess
48	46

+3

-3

lib/Moose/Cookbook/Snack/Types.pod less more

35	35
36	36	=head1 DESCRIPTION
37	37
38		This is the Point example from (L<Moose::Cookbook::Recipe1>) with added
	38	This is the Point example from (L<Moose::Cookbook::Basics::Recipe1>) with added
39	39	type checking.
40	40
41	41	If we try to assign a string value to an attribute that is defined as

50	50
51	51	=over 4
52	52
53		=item L<Moose::Cookbook::Recipe1>
	53	=item L<Moose::Cookbook::Basics::Recipe1>
54	54
55	55	=item L<Moose::Utils::TypeConstraints>
56	56

71	71	This library is free software; you can redistribute it and/or modify
72	72	it under the same terms as Perl itself.
73	73
74		=cut⏎
	74	=cut

+8

-6

lib/Moose/Cookbook/Style.pod less more

5	5
6	6	=for authors
7	7
8		Please annotate all bad examples with comments so that they won't be copied by accodent
	8	Please annotate all bad examples with comments so that they won't be copied by
	9	accident
9	10
10	11	=cut
11	12

92	93
93	94	=head2 Use C<BUILDARGS> to alter C<@_> processing
94	95
95		If you need to change the way L<@_> is processed, use C<BUILDARGS>, instead of
96		wrapping C<new>. This ensures the behavior is subclassible, it keeps this logic
	96	If you need to change the way C<@_> is processed, for example for
	97	C<< Class->new( $single_param ) >>, use C<BUILDARGS> instead of wrapping
	98	C<new>. This ensures the behavior is subclassible, it keeps this logic
97	99	independent of the other aspects of construction, and can be made efficient
98	100	using C<make_immutable>.
99	101

158	160	coerce => 1,
159	161	);
160	162
161		in a specific way.
	163	when the actual coercion applies only to your specific cases.
162	164
163	165	=head1 Clean up your package
164	166

195	197
196	198	L<http://www.iinteractive.com>
197	199
198		This library is free software; you can redistribute it and/or modify
199		it under the same terms as Perl itself.
	200	This library is free software; you can redistribute it and/or modify it under
	201	the same terms as Perl itself.
200	202
201	203	=cut

+96

-33

lib/Moose/Cookbook.pod less more

18	18
19	19	=head2 Basic Moose
20	20
21		=over 4
22
23		=item L<Moose::Cookbook::Recipe1> - The (always classic) B<Point> example
	21	These recipes will give you a good idea of what Moose is capable,
	22	starting with simple attribute declaration, and moving on to more
	23	powerful features like laziness, types, type coercion, method
	24	modifiers, and more.
	25
	26	=over 4
	27
	28	=item L<Moose::Cookbook::Basics::Recipe1> - The (always classic) B<Point> example
24	29
25	30	A simple Moose-based class. Demonstrated Moose attributes and subclassing.
26	31
27		=item L<Moose::Cookbook::Recipe2> - A simple B<BankAccount> example
	32	=item L<Moose::Cookbook::Basics::Recipe2> - A simple B<BankAccount> example
28	33
29	34	A slightly more complex Moose class. Demonstrates using a method
30	35	modifier in a subclass.
31	36
32		=item L<Moose::Cookbook::Recipe3> - A lazy B<BinaryTree> example
	37	=item L<Moose::Cookbook::Basics::Recipe3> - A lazy B<BinaryTree> example
33	38
34	39	Demonstrates several attribute features, including types, weak
35	40	references, predicates ("does this object have a foo?"), defaults, and
36		lazy attribute construction.
37
38		=item L<Moose::Cookbook::Recipe4> - Subtypes, and modeling a simple B<Company> class hierarchy
	41	lazy attribute uction.
	42
	43	=item L<Moose::Cookbook::Basics::Recipe4> - Subtypes, and modeling a simple B<Company> class hierarchy
39	44
40	45	Introduces the creation and use of custom types, a C<BUILD> method,
41	46	and the use of C<override> in a subclass.
42	47
43		=item L<Moose::Cookbook::Recipe5> - More subtypes, coercion in a B<Request> class
	48	=item L<Moose::Cookbook::Basics::Recipe5> - More subtypes, coercion in a B<Request> class
44	49
45	50	More type examples, including the use of type coercions.
46	51
47		=item L<Moose::Cookbook::Recipe6> - The augment/inner example
	52	=item L<Moose::Cookbook::Basics::Recipe6> - The augment/inner example
48	53
49	54	Demonstrates the use of C<augment> method modifiers, a way of turning
50	55	the usual method overriding style "inside-out".
51	56
52		=item L<Moose::Cookbook::Recipe7> - Making Moose fast with immutable
	57	=item L<Moose::Cookbook::Basics::Recipe7> - Making Moose fast with immutable
53	58
54	59	Making a class immutable greatly increases the speed of accessors and
55	60	object construction.
56	61
57		=item L<Moose::Cookbook::Recipe8> - Managing complex relations with trigger (TODO)
	62	=item L<Moose::Cookbook::Basics::Recipe8> - Managing complex relations with trigger (TODO)
58	63
59	64	I<abstract goes here>
60	65
61	66	Work off of this http://code2.0beta.co.uk/moose/svn/Moose/trunk/t/200_examples/007_Child_Parent_attr_inherit.t
62	67
63		=item L<Moose::Cookbook::Recipe9> - Builder methods and lazy_build
	68	=item L<Moose::Cookbook::Basics::Recipe9> - Builder methods and lazy_build
64	69
65	70	The builder feature provides an inheritable and role-composable way to
66	71	provide a default attribute value.
67	72
	73	=item L<Moose::Cookbook::Basics::Recipe10> - Operator overloading, subtypes, and coercion
	74
	75	Demonstrates using operator overloading, coercion, and subtypes to
	76	model how eye color is determined during reproduction.
	77
68	78	=back
69	79
70	80	=head2 Moose Roles
71	81
72		=over 4
73
74		=item L<Moose::Cookbook::Recipe10> - The Moose::Role example
	82	These recipes will show you how to use Moose roles.
	83
	84	=over 4
	85
	86	=item L<Moose::Cookbook::Role::Recipe1> - The Moose::Role example
75	87
76	88	Demonstrates roles, which are also sometimes known as traits or
77	89	mix-ins. Roles provide a method of code re-use which is orthogonal to
78	90	subclassing.
79	91
80		=item L<Moose::Cookbook::Recipe11> - Advanced Role Composition - method exclusion and aliasing
	92	=item L<Moose::Cookbook::Role::Recipe2> - Advanced Role Composition - method exclusion and aliasing
81	93
82	94	Sometimes you just want to include part of a role in your
83	95	class. Sometimes you want the whole role but one if its methods
84	96	conflicts with one in your class. With method exclusion and aliasing,
85	97	you can work around these problems.
86	98
87		=item L<Moose::Cookbook::Recipe12> - Runtime Role Composition (TODO)
	99	=item L<Moose::Cookbook::Role::Recipe3> - Runtime Role Composition (TODO)
88	100
89	101	I<abstract goes here>
90	102

92	104
93	105	=head2 Meta Moose
94	106
95		=over 4
96
97		=item L<Moose::Cookbook::Recipe20> - Welcome to the meta-world (TODO)
98
99		I<abstract goes here>
100
101		=item L<Moose::Cookbook::Recipe21> - The meta-attribute example
	107	These recipes show you how to write your own meta classes, which lets
	108	you extend the object system provide by Moose.
	109
	110	=over 4
	111
	112	=item L<Moose::Cookbook::Meta::Recipe1> - Welcome to the meta-world (Why Go Meta?)
	113
	114	If you're wondering what all this "meta" stuff is, and why you should
	115	care about it, read this "recipe".
	116
	117	=item L<Moose::Cookbook::Meta::Recipe2> - A meta-attribute, attributes with labels
102	118
103	119	One way to extend Moose is to provide your own attribute
104	120	metaclasses. Attribute metaclasses let you extend attribute
105	121	declarations (with C<has>) and behavior to provide additional
106	122	attribute functionality.
107	123
108		=item L<Moose::Cookbook::Recipe22> - The meta-attribute trait example
	124	=item L<Moose::Cookbook::Meta::Recipe3> - Labels implemented via attribute traits
109	125
110	126	Extending Moose's attribute metaclass is a great way to add
111	127	functionality. However, attributes can only have one metaclass.
112	128	Applying roles to the attribute metaclass lets you provide
113	129	composable attribute functionality.
114	130
115		=item L<Moose::Cookbook::Recipe23> - The meta-instance example (TODO)
116
117		I<abstract goes here>
118
119		=item L<Moose::Cookbook::Recipe24> - The meta-class example (TODO)
120
121		I<abstract goes here>
	131	=item L<Moose::Cookbook::Meta::Recipe4> - Adding a "table" attribute to the metaclass
	132
	133	If you want to store more information about your classes, you'll have
	134	to extend C<Moose::Meta::Class>. Doing so is simple, but you'll
	135	probably also want to provide some sugar, so see
	136	L<Moose::Cookbook::Meta::Recipe6> as well.
	137
	138	=item L<Moose::Cookbook::Meta::Recipe5> - The "table" attribute implemented via a metaclass trait
	139
	140	I<abstract goes here>
	141
	142	=item L<Moose::Cookbook::Meta::Recipe6> - Hooking into the immutabilization system (TODO)
	143
	144	Moose has a feature known as "immutabilization". By calling C<<
	145	__PACKAGE__->meta()->make_immutable() >> after defining your class
	146	(attributes, roles, etc), you tell Moose to optimize things like
	147	object creation, attribute access, and so on.
	148
	149	If you are creating your own metaclasses, you may need to hook into
	150	the immutabilization system. This cuts across a number of spots,
	151	including the metaclass class, meta method classes, and possibly the
	152	meta-instance class as well.
	153
	154	This recipe shows you how to write extensions which immutabilize
	155	properly.
	156
	157	=item L<Moose::Cookbook::Meta::Recipe7> - I<meta-instance> (TODO)
	158
	159	I<abstract goes here>
	160
	161	=back
	162
	163	=head2 Extending Moose
	164
	165	These recipes cover some more ways to extend Moose, and will be useful
	166	if you plan to write your own C<MooseX> module.
	167
	168	=over 4
	169
	170	=item L<Moose::Cookbook::Extending::Recipe1> - Providing an alternate base object class
	171
	172	You may find that you want to provide an alternate base object class
	173	along with a meta extension, or maybe you just want to add some
	174	functionality to all your classes without typing C<extends
	175	'MyApp::Base'> over and over.
	176
	177	=item L<Moose::Cookbook::Extending::Recipe2> - Acting like Moose.pm and providing sugar Moose-style
	178
	179	This recipe shows how to provide a replacement for C<Moose.pm>. This
	180	is something that you may want to do as part of a C<MooseX> module,
	181	especially if you want to default to a new metaclass class or base
	182	object class.
122	183
123	184	=back
124	185
125	186	=head1 SNACKS
126	187
127	188	=over 4
	189
	190	=item L<Moose::Cookbook::Snack::Keywords>
128	191
129	192	=item L<Moose::Cookbook::Snack::Types>
130	193

+16

-8

lib/Moose/Meta/Attribute.pm less more

7	7	use Carp 'confess';
8	8	use overload ();
9	9
10		our $VERSION = '0.54';
	10	our $VERSION = '0.55';
11	11	our $AUTHORITY = 'cpan:STEVAN';
12	12
13	13	use Moose::Meta::Method::Accessor;

554	554	# this will sort out any details and always
555	555	# return an hash of methods which we want
556	556	# to delagate to, see that method for details
557		my %handles = $self->_canonicalize_handles();
	557	my %handles = $self->_canonicalize_handles;
558	558
559	559	# find the accessor method for this attribute
560		my $accessor = $self->get_read_method_ref;
561		# then unpack it if we need too ...
562		$accessor = $accessor->body if blessed $accessor;
	560	my $accessor = $self->_get_delegate_accessor;
563	561
564	562	# install the delegation ...
565	563	my $associated_class = $self->associated_class;

608	606
609	607	# private methods to help delegation ...
610	608
	609	sub _get_delegate_accessor {
	610	my $self = shift;
	611	# find the accessor method for this attribute
	612	my $accessor = $self->get_read_method_ref;
	613	# then unpack it if we need too ...
	614	$accessor = $accessor->body if blessed $accessor;
	615	# return the accessor
	616	return $accessor;
	617	}
	618
611	619	sub _canonicalize_handles {
612	620	my $self = shift;
613	621	my $handles = $self->handles;

752	760	To check a value against a type constraint before setting it, fetch the
753	761	attribute instance using L<Class::MOP::Class/find_attribute_by_name>,
754	762	fetch the type_constraint from the attribute using L<Moose::Meta::Attribute/type_constraint>
755		and call L<Moose::Meta::TypeConstraint/check>. See L<Moose::Cookbook::RecipeX>
	763	and call L<Moose::Meta::TypeConstraint/check>. See L<Moose::Cookbook::Basics::Recipe4>
756	764	for an example.
757	765
758	766	=back

824	832	#If your attribute name starts with an underscore:
825	833	has '_foo' => (lazy_build => 1);
826	834	#is the same as
827		has '_foo' => (lazy => 1, required => 1, predicate => '_has_foo', clearer => '_clear_foo', builder => '_build__foo);
	835	has '_foo' => (lazy => 1, required => 1, predicate => '_has_foo', clearer => '_clear_foo', builder => '_build__foo');
828	836	# or
829	837	has '_foo' => (lazy => 1, required => 1, predicate => '_has_foo', clearer => '_clear_foo', default => sub{shift->_build__foo});
830	838
831	839	#If your attribute name does not start with an underscore:
832	840	has 'foo' => (lazy_build => 1);
833	841	#is the same as
834		has 'foo' => (lazy => 1, required => 1, predicate => 'has_foo', clearer => 'clear_foo', builder => '_build_foo);
	842	has 'foo' => (lazy => 1, required => 1, predicate => 'has_foo', clearer => 'clear_foo', builder => '_build_foo');
835	843	# or
836	844	has 'foo' => (lazy => 1, required => 1, predicate => 'has_foo', clearer => 'clear_foo', default => sub{shift->_build_foo});
837	845

+2

-1

lib/Moose/Meta/Class.pm less more

8	8	use Carp 'confess';
9	9	use Scalar::Util 'weaken', 'blessed';
10	10
11		our $VERSION = '0.54';
	11	our $VERSION = '0.55';
12	12	our $AUTHORITY = 'cpan:STEVAN';
13	13
14	14	use Moose::Meta::Method::Overriden;

281	281	foreach my $super (@superclasses) {
282	282	# don't bother if it does not have a meta.
283	283	next unless $super->can('meta');
	284	next unless $super->meta->isa("Class::MOP::Class");
284	285	# get the name, make sure we take
285	286	# immutable classes into account
286	287	my $super_meta_name = ($super->meta->is_immutable

+1

-1

lib/Moose/Meta/Instance.pm less more

3	3	use strict;
4	4	use warnings;
5	5
6		our $VERSION = '0.54';
	6	our $VERSION = '0.55';
7	7	our $AUTHORITY = 'cpan:STEVAN';
8	8
9	9	use base "Class::MOP::Instance";

+1

-1

lib/Moose/Meta/Method/Accessor.pm less more

5	5
6	6	use Carp 'confess';
7	7
8		our $VERSION = '0.54';
	8	our $VERSION = '0.55';
9	9	our $AUTHORITY = 'cpan:STEVAN';
10	10
11	11	use base 'Moose::Meta::Method',

+1

-1

lib/Moose/Meta/Method/Augmented.pm less more

4	4
5	5	use Carp 'confess';
6	6
7		our $VERSION = '0.54';
	7	our $VERSION = '0.55';
8	8	our $AUTHORITY = 'cpan:STEVAN';
9	9
10	10	use base 'Moose::Meta::Method';

+1

-1

lib/Moose/Meta/Method/Constructor.pm less more

6	6	use Carp 'confess';
7	7	use Scalar::Util 'blessed', 'weaken', 'looks_like_number';
8	8
9		our $VERSION = '0.54';
	9	our $VERSION = '0.55';
10	10	our $AUTHORITY = 'cpan:STEVAN';
11	11
12	12	use base 'Moose::Meta::Method',

+1

-1

lib/Moose/Meta/Method/Destructor.pm less more

6	6	use Carp 'confess';
7	7	use Scalar::Util 'blessed', 'weaken';
8	8
9		our $VERSION = '0.54';
	9	our $VERSION = '0.55';
10	10	our $AUTHORITY = 'cpan:STEVAN';
11	11
12	12	use base 'Moose::Meta::Method',

+1

-1

lib/Moose/Meta/Method/Overriden.pm less more

4	4
5	5	use Carp 'confess';
6	6
7		our $VERSION = '0.54';
	7	our $VERSION = '0.55';
8	8	our $AUTHORITY = 'cpan:STEVAN';
9	9
10	10	use base 'Moose::Meta::Method';

+1

-1

lib/Moose/Meta/Method.pm less more

2	2	use strict;
3	3	use warnings;
4	4
5		our $VERSION = '0.54';
	5	our $VERSION = '0.55';
6	6	our $AUTHORITY = 'cpan:STEVAN';
7	7
8	8	use base 'Class::MOP::Method';

+1

-1

lib/Moose/Meta/Role/Application/RoleSummation.pm less more

9	9
10	10	use Moose::Meta::Role::Composite;
11	11
12		our $VERSION = '0.54';
	12	our $VERSION = '0.55';
13	13	our $AUTHORITY = 'cpan:STEVAN';
14	14
15	15	use base 'Moose::Meta::Role::Application';

+1

-1

lib/Moose/Meta/Role/Application/ToClass.pm less more

8	8
9	9	use Data::Dumper;
10	10
11		our $VERSION = '0.54';
	11	our $VERSION = '0.55';
12	12	our $AUTHORITY = 'cpan:STEVAN';
13	13
14	14	use base 'Moose::Meta::Role::Application';

+1

-1

lib/Moose/Meta/Role/Application/ToInstance.pm less more

6	6	use Carp 'confess';
7	7	use Scalar::Util 'blessed';
8	8
9		our $VERSION = '0.54';
	9	our $VERSION = '0.55';
10	10	our $AUTHORITY = 'cpan:STEVAN';
11	11
12	12	use base 'Moose::Meta::Role::Application::ToClass';

+1

-1

lib/Moose/Meta/Role/Application/ToRole.pm less more

8	8
9	9	use Data::Dumper;
10	10
11		our $VERSION = '0.54';
	11	our $VERSION = '0.55';
12	12	our $AUTHORITY = 'cpan:STEVAN';
13	13
14	14	use base 'Moose::Meta::Role::Application';

+1

-1

lib/Moose/Meta/Role/Application.pm less more

3	3	use warnings;
4	4	use metaclass;
5	5
6		our $VERSION = '0.54';
	6	our $VERSION = '0.55';
7	7	our $AUTHORITY = 'cpan:STEVAN';
8	8
9	9	__PACKAGE__->meta->add_attribute('method_exclusions' => (

+1

-1

lib/Moose/Meta/Role/Composite.pm less more

6	6	use Carp 'confess';
7	7	use Scalar::Util 'blessed';
8	8
9		our $VERSION = '0.54';
	9	our $VERSION = '0.55';
10	10	our $AUTHORITY = 'cpan:STEVAN';
11	11
12	12	use base 'Moose::Meta::Role';

+1

-1

lib/Moose/Meta/Role/Method/Required.pm less more

3	3	use strict;
4	4	use warnings;
5	5
6		our $VERSION = '0.54';
	6	our $VERSION = '0.55';
7	7	our $AUTHORITY = 'cpan:STEVAN';
8	8
9	9	use base 'Moose::Meta::Role::Method';

+1

-1

lib/Moose/Meta/Role/Method.pm less more

3	3	use strict;
4	4	use warnings;
5	5
6		our $VERSION = '0.54';
	6	our $VERSION = '0.55';
7	7	our $AUTHORITY = 'cpan:STEVAN';
8	8
9	9	use base 'Class::MOP::Method';

+1

-1

lib/Moose/Meta/Role.pm less more

7	7	use Carp 'confess';
8	8	use Scalar::Util 'blessed';
9	9
10		our $VERSION = '0.54';
	10	our $VERSION = '0.55';
11	11	our $AUTHORITY = 'cpan:STEVAN';
12	12
13	13	use Moose::Meta::Class;

+1

-1

lib/Moose/Meta/TypeCoercion/Union.pm less more

7	7	use Carp 'confess';
8	8	use Scalar::Util 'blessed';
9	9
10		our $VERSION = '0.54';
	10	our $VERSION = '0.55';
11	11	our $AUTHORITY = 'cpan:STEVAN';
12	12
13	13	use base 'Moose::Meta::TypeCoercion';

+1

-1

lib/Moose/Meta/TypeCoercion.pm less more

9	9	use Moose::Meta::Attribute;
10	10	use Moose::Util::TypeConstraints ();
11	11
12		our $VERSION = '0.54';
	12	our $VERSION = '0.55';
13	13	our $AUTHORITY = 'cpan:STEVAN';
14	14
15	15	__PACKAGE__->meta->add_attribute('type_coercion_map' => (

+1

-1

lib/Moose/Meta/TypeConstraint/Class.pm less more

6	6	use Scalar::Util 'blessed';
7	7	use Moose::Util::TypeConstraints ();
8	8
9		our $VERSION = '0.54';
	9	our $VERSION = '0.55';
10	10	our $AUTHORITY = 'cpan:STEVAN';
11	11
12	12	use base 'Moose::Meta::TypeConstraint';

+1

-1

lib/Moose/Meta/TypeConstraint/Enum.pm less more

5	5
6	6	use Moose::Util::TypeConstraints ();
7	7
8		our $VERSION = '0.54';
	8	our $VERSION = '0.55';
9	9	our $AUTHORITY = 'cpan:STEVAN';
10	10
11	11	use base 'Moose::Meta::TypeConstraint';

+1

-1

lib/Moose/Meta/TypeConstraint/Parameterizable.pm less more

3	3	use warnings;
4	4	use metaclass;
5	5
6		our $VERSION = '0.54';
	6	our $VERSION = '0.55';
7	7	our $AUTHORITY = 'cpan:STEVAN';
8	8
9	9	use base 'Moose::Meta::TypeConstraint';

+1

-1

lib/Moose/Meta/TypeConstraint/Parameterized.pm less more

7	7	use Carp 'confess';
8	8	use Moose::Util::TypeConstraints;
9	9
10		our $VERSION = '0.54';
	10	our $VERSION = '0.55';
11	11	our $AUTHORITY = 'cpan:STEVAN';
12	12
13	13	use base 'Moose::Meta::TypeConstraint';

+1

-1

lib/Moose/Meta/TypeConstraint/Registry.pm less more

7	7	use Scalar::Util 'blessed';
8	8	use Carp 'confess';
9	9
10		our $VERSION = '0.54';
	10	our $VERSION = '0.55';
11	11	our $AUTHORITY = 'cpan:STEVAN';
12	12
13	13	use base 'Class::MOP::Object';

+1

-1

lib/Moose/Meta/TypeConstraint/Role.pm less more

6	6	use Scalar::Util 'blessed';
7	7	use Moose::Util::TypeConstraints ();
8	8
9		our $VERSION = '0.54';
	9	our $VERSION = '0.55';
10	10	our $AUTHORITY = 'cpan:STEVAN';
11	11
12	12	use base 'Moose::Meta::TypeConstraint';

+2

-2

lib/Moose/Meta/TypeConstraint/Union.pm less more

6	6
7	7	use Moose::Meta::TypeCoercion::Union;
8	8
9		our $VERSION = '0.54';
	9	our $VERSION = '0.55';
10	10	our $AUTHORITY = 'cpan:STEVAN';
11	11
12	12	use base 'Moose::Meta::TypeConstraint';

110	110	=head1 DESCRIPTION
111	111
112	112	This metaclass represents a union of Moose type constraints. More
113		details to be explained later (possibly in a Cookbook::Recipe).
	113	details to be explained later (possibly in a Cookbook recipe).
114	114
115	115	This actually used to be part of Moose::Meta::TypeConstraint, but it
116	116	is now better off in it's own file.

+2

-2

lib/Moose/Meta/TypeConstraint.pm less more

10	10	use Carp 'confess';
11	11	use Scalar::Util qw(blessed refaddr);
12	12
13		our $VERSION = '0.54';
	13	our $VERSION = '0.55';
14	14	our $AUTHORITY = 'cpan:STEVAN';
15	15
16	16	__PACKAGE__->meta->add_attribute('name' => (reader => 'name'));

76	76
77	77	sub get_message {
78	78	my ($self, $value) = @_;
79		$value = (defined $value ? overload::StrVal($value) : 'undef');
80	79	if (my $msg = $self->message) {
81	80	local $_ = $value;
82	81	return $msg->($value);
83	82	}
84	83	else {
	84	$value = (defined $value ? overload::StrVal($value) : 'undef');
85	85	return "Validation failed for '" . $self->name . "' failed with value $value";
86	86	}
87	87	}

+1

-1

lib/Moose/Object.pm less more

8	8
9	9	use Carp 'confess';
10	10
11		our $VERSION = '0.54';
	11	our $VERSION = '0.55';
12	12	our $AUTHORITY = 'cpan:STEVAN';
13	13
14	14	sub new {

+1

-1

lib/Moose/Role.pm less more

9	9	use Data::OptList;
10	10	use Sub::Exporter;
11	11
12		our $VERSION = '0.54';
	12	our $VERSION = '0.55';
13	13	our $AUTHORITY = 'cpan:STEVAN';
14	14
15	15	use Moose ();

+1

-1

lib/Moose/Util/TypeConstraints/OptimizedConstraints.pm less more

4	4
5	5	use Scalar::Util 'blessed', 'looks_like_number';
6	6
7		our $VERSION = '0.54';
	7	our $VERSION = '0.55';
8	8	our $AUTHORITY = 'cpan:STEVAN';
9	9
10	10	sub Value { defined($_[0]) && !ref($_[0]) }

+2

-2

lib/Moose/Util/TypeConstraints.pm less more

7	7	use Scalar::Util 'blessed';
8	8	use Sub::Exporter;
9	9
10		our $VERSION = '0.54';
	10	our $VERSION = '0.55';
11	11	our $AUTHORITY = 'cpan:STEVAN';
12	12
13	13	## --------------------------------------------------------

423	423
424	424	sub _install_type_coercions ($$) {
425	425	my ($type_name, $coercion_map) = @_;
426		my $type = $REGISTRY->get_type_constraint($type_name);
	426	my $type = find_type_constraint($type_name);
427	427	(defined $type)
428	428	\|\| confess "Cannot find type '$type_name', perhaps you forgot to load it.";
429	429	if ($type->has_coercion) {

+1

-1

lib/Moose/Util.pm less more

7	7	use Carp 'confess';
8	8	use Class::MOP 0.56;
9	9
10		our $VERSION = '0.54';
	10	our $VERSION = '0.55';
11	11	our $AUTHORITY = 'cpan:STEVAN';
12	12
13	13	my @exports = qw[

+75

-63

lib/Moose.pm less more

3	3	use strict;
4	4	use warnings;
5	5
6		our $VERSION = '0.54';
	6	our $VERSION = '0.55';
7	7	our $AUTHORITY = 'cpan:STEVAN';
8	8
9	9	use Scalar::Util 'blessed';

11	11
12	12	use Sub::Exporter;
13	13
14		use Class::MOP;
	14	use Class::MOP 0.64;
15	15
16	16	use Moose::Meta::Class;
17	17	use Moose::Meta::TypeConstraint;

27	27
28	28	{
29	29	my $CALLER;
30
31		sub init_meta {
32		my ( $class, $base_class, $metaclass ) = @_;
33		$base_class = 'Moose::Object' unless defined $base_class;
34		$metaclass = 'Moose::Meta::Class' unless defined $metaclass;
35
36		confess
37		"The Metaclass $metaclass must be a subclass of Moose::Meta::Class."
38		unless $metaclass->isa('Moose::Meta::Class');
39
40		# make a subtype for each Moose class
41		class_type($class)
42		unless find_type_constraint($class);
43
44		my $meta;
45		if ( $class->can('meta') ) {
46		# NOTE:
47		# this is the case where the metaclass pragma
48		# was used before the 'use Moose' statement to
49		# override a specific class
50		$meta = $class->meta();
51		( blessed($meta) && $meta->isa('Moose::Meta::Class') )
52		\|\| confess "You already have a &meta function, but it does not return a Moose::Meta::Class";
53		}
54		else {
55		# NOTE:
56		# this is broken currently, we actually need
57		# to allow the possiblity of an inherited
58		# meta, which will not be visible until the
59		# user 'extends' first. This needs to have
60		# more intelligence to it
61		$meta = $metaclass->initialize($class);
62		$meta->add_method(
63		'meta' => sub {
64		# re-initialize so it inherits properly
65		$metaclass->initialize( blessed( $_[0] ) \|\| $_[0] );
66		}
67		);
68		}
69
70		# make sure they inherit from Moose::Object
71		$meta->superclasses($base_class)
72		unless $meta->superclasses();
73
74		return $meta;
75		}
76	30
77	31	my %exports = (
78	32	extends => sub {

257	211
258	212	}
259	213
	214	sub init_meta {
	215	my ( $class, $base_class, $metaclass ) = @_;
	216	$base_class = 'Moose::Object' unless defined $base_class;
	217	$metaclass = 'Moose::Meta::Class' unless defined $metaclass;
	218
	219	confess
	220	"The Metaclass $metaclass must be a subclass of Moose::Meta::Class."
	221	unless $metaclass->isa('Moose::Meta::Class');
	222
	223	# make a subtype for each Moose class
	224	class_type($class)
	225	unless find_type_constraint($class);
	226
	227	my $meta;
	228	if ( $class->can('meta') ) {
	229	# NOTE:
	230	# this is the case where the metaclass pragma
	231	# was used before the 'use Moose' statement to
	232	# override a specific class
	233	$meta = $class->meta();
	234	( blessed($meta) && $meta->isa('Moose::Meta::Class') )
	235	\|\| confess "You already have a &meta function, but it does not return a Moose::Meta::Class";
	236	}
	237	else {
	238	# NOTE:
	239	# this is broken currently, we actually need
	240	# to allow the possiblity of an inherited
	241	# meta, which will not be visible until the
	242	# user 'extends' first. This needs to have
	243	# more intelligence to it
	244	$meta = $metaclass->initialize($class);
	245	$meta->add_method(
	246	'meta' => sub {
	247	# re-initialize so it inherits properly
	248	$metaclass->initialize( blessed( $_[0] ) \|\| $_[0] );
	249	}
	250	);
	251	}
	252
	253	# make sure they inherit from Moose::Object
	254	$meta->superclasses($base_class)
	255	unless $meta->superclasses();
	256
	257	return $meta;
	258	}
	259
260	260	## make 'em all immutable
261	261
262	262	$_->meta->make_immutable(

335	335
336	336	=head2 Moose Extensions
337	337
338		The L<MooseX::> namespace is the official place to find Moose extensions.
339		There are a number of these modules out on CPAN right now the best way to
340		find them is to search for MooseX:: on search.cpan.org or to look at the
341		latest version of L<Task::Moose> which aims to keep an up to date, easily
342		installable list of these extensions.
	338	The C<MooseX::> namespace is the official place to find Moose extensions.
	339	These extensions can be found on the CPAN. The easiest way to find them
	340	is to search for them (L<http://search.cpan.org/search?query=MooseX::>),
	341	or to examine L<Task::Moose> which aims to keep an up-to-date, easily
	342	installable list of Moose extensions.
343	343
344	344	=head1 BUILDING CLASSES WITH MOOSE
345	345

423	423
424	424	This will attempt to use coercion with the supplied type constraint to change
425	425	the value passed into any accessors or constructors. You B<must> have supplied
426		a type constraint in order for this to work. See L<Moose::Cookbook::Recipe5>
	426	a type constraint in order for this to work. See L<Moose::Cookbook::Basics::Recipe5>
427	427	for an example.
428	428
429	429	=item I<does =E<gt> $role_name>

508	508	in the class being delegated to.
509	509
510	510	This can be very useful for recursive classes like trees. Here is a
511		quick example (soon to be expanded into a Moose::Cookbook::Recipe):
	511	quick example (soon to be expanded into a Moose::Cookbook recipe):
512	512
513	513	package Tree;
514	514	use Moose;

572	572	attribute. Custom attribute metaclasses are useful for extending the
573	573	capabilities of the I<has> keyword: they are the simplest way to extend the MOP,
574	574	but they are still a fairly advanced topic and too much to cover here, see
575		L<Moose::Cookbook::Recipe11> for more information.
	575	L<Moose::Cookbook::Meta::Recipe1> for more information.
576	576
577	577	The default behavior here is to just load C<$metaclass_name>; however, we also
578	578	have a way to alias to a shorter name. This will first look to see if

629	629
630	630	package Foo::Role;
631	631	use Moose::Role;
632
	632
633	633	has 'message' => (
634	634	is => 'rw',
635	635	isa => 'Str',
636	636	default => 'Hello, I am a Foo'
637	637	);
638
	638
639	639	package My::Foo;
640	640	use Moose;
641
	641
642	642	with 'Foo::Role';
643
	643
644	644	has '+message' => (default => 'Hello I am My::Foo');
645	645
646	646	In this case, we are basically taking the attribute which the role supplied

734	734	The keyword C<inner>, much like C<super>, is a no-op outside of the context of
735	735	an C<augment> method. You can think of C<inner> as being the inverse of
736	736	C<super>; the details of how C<inner> and C<augment> work is best described in
737		the L<Moose::Cookbook::Recipe6>.
	737	the L<Moose::Cookbook::Basics::Recipe6>.
738	738
739	739	=item B<augment ($name, &sub)>
740	740
741	741	An C<augment> method, is a way of explicitly saying "I am augmenting this
742	742	method from my superclass". Once again, the details of how C<inner> and
743		C<augment> work is best described in the L<Moose::Cookbook::Recipe6>.
	743	C<augment> work is best described in the L<Moose::Cookbook::Basics::Recipe6>.
744	744
745	745	=item B<confess>
746	746

814	814	sets your baseclass to Moose::Object or the value you pass in unless you already
815	815	have one. This is all done via C<init_meta> which takes the name of your class
816	816	and optionally a baseclass and a metaclass as arguments.
	817
	818	For more detail on this topic, see L<Moose::Cookbook::Extending::Recipe2>.
817	819
818	820	=head1 CAVEATS
819	821

937	939	as well as links to a number of talks and articles on Moose and Moose related
938	940	technologies.
939	941
	942	=item L<Moose::Cookbook> - How to cook a Moose
	943
	944	=item The Moose is flying, a tutorial by Randal Schwartz
	945
	946	Part 1 - L<http://www.stonehenge.com/merlyn/LinuxMag/col94.html>
	947
	948	Part 2 - L<http://www.stonehenge.com/merlyn/LinuxMag/col95.html>
	949
940	950	=item L<Class::MOP> documentation
941	951
942	952	=item The #moose channel on irc.perl.org

945	955
946	956	=item Moose stats on ohloh.net - L<http://www.ohloh.net/projects/moose>
947	957
948		=item Several Moose extension modules in the L<MooseX::> namespace.
	958	=item Several Moose extension modules in the C<MooseX::> namespace.
	959
	960	See L<http://search.cpan.org/search?query=MooseX::> for extensions.
949	961
950	962	=back
951	963

+1

-1

lib/Test/Moose.pm less more

7	7
8	8	use Moose::Util 'does_role', 'find_meta';
9	9
10		our $VERSION = '0.54';
	10	our $VERSION = '0.55';
11	11	our $AUTHORITY = 'cpan:STEVAN';
12	12
13	13	my @exports = qw[

+1

-1

lib/oose.pm less more

4	4
5	5	use Class::MOP;
6	6
7		our $VERSION = '0.54';
	7	our $VERSION = '0.55';
8	8	our $AUTHORITY = 'cpan:STEVAN';
9	9
10	10	BEGIN {

+0

-186

~~t/000_recipes/001_point.t~~ less more

0		#!/usr/bin/perl
1
2		use strict;
3		use warnings;
4
5		use Test::More tests => 58;
6		use Test::Exception;
7
8		BEGIN {
9		use_ok('Moose');
10		}
11
12		{
13		package Point;
14		use Moose;
15
16		has 'x' => (isa => 'Int', is => 'ro');
17		has 'y' => (isa => 'Int', is => 'rw');
18
19		sub clear {
20		my $self = shift;
21		$self->{x} = 0;
22		$self->y(0);
23		}
24
25		__PACKAGE__->meta->make_immutable(debug => 0);
26		}{
27		package Point3D;
28		use Moose;
29
30		extends 'Point';
31
32		has 'z' => (isa => 'Int');
33
34		after 'clear' => sub {
35		my $self = shift;
36		$self->{z} = 0;
37		};
38
39		__PACKAGE__->meta->make_immutable(debug => 0);
40		}
41
42		my $point = Point->new(x => 1, y => 2);
43		isa_ok($point, 'Point');
44		isa_ok($point, 'Moose::Object');
45
46		is($point->x, 1, '... got the right value for x');
47		is($point->y, 2, '... got the right value for y');
48
49		$point->y(10);
50		is($point->y, 10, '... got the right (changed) value for y');
51
52		dies_ok {
53		$point->y('Foo');
54		} '... cannot assign a non-Int to y';
55
56		dies_ok {
57		$point->x(1000);
58		} '... cannot assign to a read-only method';
59		is($point->x, 1, '... got the right (un-changed) value for x');
60
61		$point->clear();
62
63		is($point->x, 0, '... got the right (cleared) value for x');
64		is($point->y, 0, '... got the right (cleared) value for y');
65
66		# check the type constraints on the constructor
67
68		lives_ok {
69		Point->new(x => 0, y => 0);
70		} '... can assign a 0 to x and y';
71
72		dies_ok {
73		Point->new(x => 10, y => 'Foo');
74		} '... cannot assign a non-Int to y';
75
76		dies_ok {
77		Point->new(x => 'Foo', y => 10);
78		} '... cannot assign a non-Int to x';
79
80		# Point3D
81
82		my $point3d = Point3D->new({ x => 10, y => 15, z => 3 });
83		isa_ok($point3d, 'Point3D');
84		isa_ok($point3d, 'Point');
85		isa_ok($point3d, 'Moose::Object');
86
87		is($point3d->x, 10, '... got the right value for x');
88		is($point3d->y, 15, '... got the right value for y');
89		is($point3d->{'z'}, 3, '... got the right value for z');
90
91		dies_ok {
92		$point3d->z;
93		} '... there is no method for z';
94
95		$point3d->clear();
96
97		is($point3d->x, 0, '... got the right (cleared) value for x');
98		is($point3d->y, 0, '... got the right (cleared) value for y');
99		is($point3d->{'z'}, 0, '... got the right (cleared) value for z');
100
101		dies_ok {
102		Point3D->new(x => 10, y => 'Foo', z => 3);
103		} '... cannot assign a non-Int to y';
104
105		dies_ok {
106		Point3D->new(x => 'Foo', y => 10, z => 3);
107		} '... cannot assign a non-Int to x';
108
109		dies_ok {
110		Point3D->new(x => 0, y => 10, z => 'Bar');
111		} '... cannot assign a non-Int to z';
112
113		# test some class introspection
114
115		can_ok('Point', 'meta');
116		isa_ok(Point->meta, 'Moose::Meta::Class');
117
118		can_ok('Point3D', 'meta');
119		isa_ok(Point3D->meta, 'Moose::Meta::Class');
120
121		isnt(Point->meta, Point3D->meta, '... they are different metaclasses as well');
122
123		# poke at Point
124
125		is_deeply(
126		[ Point->meta->superclasses ],
127		[ 'Moose::Object' ],
128		'... Point got the automagic base class');
129
130		my @Point_methods = qw(meta new x y clear);
131		my @Point_attrs = ('x', 'y');
132
133		is_deeply(
134		[ sort @Point_methods ],
135		[ sort Point->meta->get_method_list() ],
136		'... we match the method list for Point');
137
138		is_deeply(
139		[ sort @Point_attrs ],
140		[ sort Point->meta->get_attribute_list() ],
141		'... we match the attribute list for Point');
142
143		foreach my $method (@Point_methods) {
144		ok(Point->meta->has_method($method), '... Point has the method "' . $method . '"');
145		}
146
147		foreach my $attr_name (@Point_attrs ) {
148		ok(Point->meta->has_attribute($attr_name), '... Point has the attribute "' . $attr_name . '"');
149		my $attr = Point->meta->get_attribute($attr_name);
150		ok($attr->has_type_constraint, '... Attribute ' . $attr_name . ' has a type constraint');
151		isa_ok($attr->type_constraint, 'Moose::Meta::TypeConstraint');
152		is($attr->type_constraint->name, 'Int', '... Attribute ' . $attr_name . ' has an Int type constraint');
153		}
154
155		# poke at Point3D
156
157		is_deeply(
158		[ Point3D->meta->superclasses ],
159		[ 'Point' ],
160		'... Point3D gets the parent given to it');
161
162		my @Point3D_methods = qw(new meta clear);
163		my @Point3D_attrs = ('z');
164
165		is_deeply(
166		[ sort @Point3D_methods ],
167		[ sort Point3D->meta->get_method_list() ],
168		'... we match the method list for Point3D');
169
170		is_deeply(
171		[ sort @Point3D_attrs ],
172		[ sort Point3D->meta->get_attribute_list() ],
173		'... we match the attribute list for Point3D');
174
175		foreach my $method (@Point3D_methods) {
176		ok(Point3D->meta->has_method($method), '... Point3D has the method "' . $method . '"');
177		}
178
179		foreach my $attr_name (@Point3D_attrs ) {
180		ok(Point3D->meta->has_attribute($attr_name), '... Point3D has the attribute "' . $attr_name . '"');
181		my $attr = Point3D->meta->get_attribute($attr_name);
182		ok($attr->has_type_constraint, '... Attribute ' . $attr_name . ' has a type constraint');
183		isa_ok($attr->type_constraint, 'Moose::Meta::TypeConstraint');
184		is($attr->type_constraint->name, 'Int', '... Attribute ' . $attr_name . ' has an Int type constraint');
185		}

+0

-113

~~t/000_recipes/002_bank_account.t~~ less more

0		#!/usr/bin/perl
1
2		use strict;
3		use warnings;
4
5		use Test::More tests => 24;
6		use Test::Exception;
7
8		BEGIN {
9		use_ok('Moose');
10		}
11
12		{
13		package BankAccount;
14		use Moose;
15
16		has 'balance' => (isa => 'Num', is => 'rw', default => 0);
17
18		sub deposit {
19		my ($self, $amount) = @_;
20		$self->balance($self->balance + $amount);
21		}
22
23		sub withdraw {
24		my ($self, $amount) = @_;
25		my $current_balance = $self->balance();
26		($current_balance >= $amount)
27		\|\| confess "Account overdrawn";
28		$self->balance($current_balance - $amount);
29		}
30
31		__PACKAGE__->meta->make_immutable(debug => 0);
32		}{
33		package CheckingAccount;
34		use Moose;
35
36		extends 'BankAccount';
37
38		has 'overdraft_account' => (isa => 'BankAccount', is => 'rw');
39
40		before 'withdraw' => sub {
41		my ($self, $amount) = @_;
42		my $overdraft_amount = $amount - $self->balance();
43		if ($self->overdraft_account && $overdraft_amount > 0) {
44		$self->overdraft_account->withdraw($overdraft_amount);
45		$self->deposit($overdraft_amount);
46		}
47		};
48
49		__PACKAGE__->meta->make_immutable(debug => 0);
50		}
51
52		my $savings_account = BankAccount->new(balance => 250);
53		isa_ok($savings_account, 'BankAccount');
54
55		is($savings_account->balance, 250, '... got the right savings balance');
56		lives_ok {
57		$savings_account->withdraw(50);
58		} '... withdrew from savings successfully';
59		is($savings_account->balance, 200, '... got the right savings balance after withdrawl');
60
61		$savings_account->deposit(150);
62		is($savings_account->balance, 350, '... got the right savings balance after deposit');
63
64		{
65		my $checking_account = CheckingAccount->new(
66		balance => 100,
67		overdraft_account => $savings_account
68		);
69		isa_ok($checking_account, 'CheckingAccount');
70		isa_ok($checking_account, 'BankAccount');
71
72		is($checking_account->overdraft_account, $savings_account, '... got the right overdraft account');
73
74		is($checking_account->balance, 100, '... got the right checkings balance');
75
76		lives_ok {
77		$checking_account->withdraw(50);
78		} '... withdrew from checking successfully';
79		is($checking_account->balance, 50, '... got the right checkings balance after withdrawl');
80		is($savings_account->balance, 350, '... got the right savings balance after checking withdrawl (no overdraft)');
81
82		lives_ok {
83		$checking_account->withdraw(200);
84		} '... withdrew from checking successfully';
85		is($checking_account->balance, 0, '... got the right checkings balance after withdrawl');
86		is($savings_account->balance, 200, '... got the right savings balance after overdraft withdrawl');
87		}
88
89		{
90		my $checking_account = CheckingAccount->new(
91		balance => 100
92		# no overdraft account
93		);
94		isa_ok($checking_account, 'CheckingAccount');
95		isa_ok($checking_account, 'BankAccount');
96
97		is($checking_account->overdraft_account, undef, '... no overdraft account');
98
99		is($checking_account->balance, 100, '... got the right checkings balance');
100
101		lives_ok {
102		$checking_account->withdraw(50);
103		} '... withdrew from checking successfully';
104		is($checking_account->balance, 50, '... got the right checkings balance after withdrawl');
105
106		dies_ok {
107		$checking_account->withdraw(200);
108		} '... withdrawl failed due to attempted overdraft';
109		is($checking_account->balance, 50, '... got the right checkings balance after withdrawl failure');
110		}
111
112

+0

-121

~~t/000_recipes/003_binary_tree.t~~ less more

0		#!/usr/bin/perl
1
2		use strict;
3		use warnings;
4
5		use Test::More tests => 34;
6		use Test::Exception;
7
8		use Scalar::Util 'isweak';
9
10		BEGIN {
11		use_ok('Moose');
12		}
13
14		{
15		package BinaryTree;
16		use Moose;
17
18		has 'node' => (is => 'rw', isa => 'Any');
19
20		has 'parent' => (
21		is => 'rw',
22		isa => 'BinaryTree',
23		predicate => 'has_parent',
24		weak_ref => 1,
25		);
26
27		has 'left' => (
28		is => 'rw',
29		isa => 'BinaryTree',
30		predicate => 'has_left',
31		lazy => 1,
32		default => sub { BinaryTree->new(parent => $_[0]) },
33		);
34
35		has 'right' => (
36		is => 'rw',
37		isa => 'BinaryTree',
38		predicate => 'has_right',
39		lazy => 1,
40		default => sub { BinaryTree->new(parent => $_[0]) },
41		);
42
43		before 'right', 'left' => sub {
44		my ($self, $tree) = @_;
45		$tree->parent($self) if defined $tree;
46		};
47
48		__PACKAGE__->meta->make_immutable(debug => 0);
49		}
50
51		my $root = BinaryTree->new(node => 'root');
52		isa_ok($root, 'BinaryTree');
53
54		is($root->node, 'root', '... got the right node value');
55
56		ok(!$root->has_left, '... no left node yet');
57		ok(!$root->has_right, '... no right node yet');
58
59		ok(!$root->has_parent, '... no parent for root node');
60
61		# make a left node
62
63		my $left = $root->left;
64		isa_ok($left, 'BinaryTree');
65
66		is($root->left, $left, '... got the same node (and it is $left)');
67		ok($root->has_left, '... we have a left node now');
68
69		ok($left->has_parent, '... lefts has a parent');
70		is($left->parent, $root, '... lefts parent is the root');
71
72		ok(isweak($left->{parent}), '... parent is a weakened ref');
73
74		ok(!$left->has_left, '... $left no left node yet');
75		ok(!$left->has_right, '... $left no right node yet');
76
77		is($left->node, undef, '... left has got no node value');
78
79		lives_ok {
80		$left->node('left')
81		} '... assign to lefts node';
82
83		is($left->node, 'left', '... left now has a node value');
84
85		# make a right node
86
87		ok(!$root->has_right, '... still no right node yet');
88
89		is($root->right->node, undef, '... right has got no node value');
90
91		ok($root->has_right, '... now we have a right node');
92
93		my $right = $root->right;
94		isa_ok($right, 'BinaryTree');
95
96		lives_ok {
97		$right->node('right')
98		} '... assign to rights node';
99
100		is($right->node, 'right', '... left now has a node value');
101
102		is($root->right, $right, '... got the same node (and it is $right)');
103		ok($root->has_right, '... we have a right node now');
104
105		ok($right->has_parent, '... rights has a parent');
106		is($right->parent, $root, '... rights parent is the root');
107
108		ok(isweak($right->{parent}), '... parent is a weakened ref');
109
110		my $left_left = $left->left;
111		isa_ok($left_left, 'BinaryTree');
112
113		ok($left_left->has_parent, '... left does have a parent');
114
115		is($left_left->parent, $left, '... got a parent node (and it is $left)');
116		ok($left->has_left, '... we have a left node now');
117		is($left->left, $left_left, '... got a left node (and it is $left_left)');
118
119		ok(isweak($left_left->{parent}), '... parent is a weakened ref');
120

+0

-276

~~t/000_recipes/004_company.t~~ less more

0		#!/usr/bin/perl
1
2		use strict;
3		use warnings;
4
5		use Test::More;
6
7		BEGIN {
8		eval "use Regexp::Common; use Locale::US;";
9		plan skip_all => "Regexp::Common & Locale::US required for this test" if $@;
10		plan tests => 66;
11		}
12
13		use Test::Exception;
14		use Scalar::Util 'isweak';
15
16		BEGIN {
17		use_ok('Moose');
18		}
19
20		{
21		package Address;
22		use Moose;
23		use Moose::Util::TypeConstraints;
24
25		use Locale::US;
26		use Regexp::Common 'zip';
27
28		my $STATES = Locale::US->new;
29
30		subtype USState
31		=> as Str
32		=> where {
33		(exists $STATES->{code2state}{uc($_)} \|\| exists $STATES->{state2code}{uc($_)})
34		};
35
36		subtype USZipCode
37		=> as Value
38		=> where {
39		/^$RE{zip}{US}{-extended => 'allow'}$/
40		};
41
42		has 'street' => (is => 'rw', isa => 'Str');
43		has 'city' => (is => 'rw', isa => 'Str');
44		has 'state' => (is => 'rw', isa => 'USState');
45		has 'zip_code' => (is => 'rw', isa => 'USZipCode');
46
47		__PACKAGE__->meta->make_immutable(debug => 0);
48		}{
49
50		package Company;
51		use Moose;
52		use Moose::Util::TypeConstraints;
53
54		has 'name' => (is => 'rw', isa => 'Str', required => 1);
55		has 'address' => (is => 'rw', isa => 'Address');
56		has 'employees' => (is => 'rw', isa => 'ArrayRef[Employee]');
57
58		sub BUILD {
59		my ($self, $params) = @_;
60		if ($params->{employees}) {
61		foreach my $employee (@{$params->{employees}}) {
62		$employee->company($self);
63		}
64		}
65		}
66
67		sub get_employee_count { scalar @{(shift)->employees} }
68
69		after 'employees' => sub {
70		my ($self, $employees) = @_;
71		# if employees is defined, it
72		# has already been type checked
73		if (defined $employees) {
74		# make sure each gets the
75		# weak ref to the company
76		foreach my $employee (@{$employees}) {
77		$employee->company($self);
78		}
79		}
80		};
81
82		__PACKAGE__->meta->make_immutable(debug => 0);
83		}{
84
85		package Person;
86		use Moose;
87
88		has 'first_name' => (is => 'rw', isa => 'Str', required => 1);
89		has 'last_name' => (is => 'rw', isa => 'Str', required => 1);
90		has 'middle_initial' => (is => 'rw', isa => 'Str', predicate => 'has_middle_initial');
91		has 'address' => (is => 'rw', isa => 'Address');
92
93		sub full_name {
94		my $self = shift;
95		return $self->first_name .
96		($self->has_middle_initial ? ' ' . $self->middle_initial . '. ' : ' ') .
97		$self->last_name;
98		}
99
100		__PACKAGE__->meta->make_immutable(debug => 0);
101		}{
102
103		package Employee;
104		use Moose;
105
106		extends 'Person';
107
108		has 'title' => (is => 'rw', isa => 'Str', required => 1);
109		has 'company' => (is => 'rw', isa => 'Company', weak_ref => 1);
110
111		override 'full_name' => sub {
112		my $self = shift;
113		super() . ', ' . $self->title
114		};
115
116		__PACKAGE__->meta->make_immutable(debug => 0);
117		}
118
119		my $ii;
120		lives_ok {
121		$ii = Company->new({
122		name => 'Infinity Interactive',
123		address => Address->new(
124		street => '565 Plandome Rd., Suite 307',
125		city => 'Manhasset',
126		state => 'NY',
127		zip_code => '11030'
128		),
129		employees => [
130		Employee->new(
131		first_name => 'Jeremy',
132		last_name => 'Shao',
133		title => 'President / Senior Consultant',
134		address => Address->new(city => 'Manhasset', state => 'NY')
135		),
136		Employee->new(
137		first_name => 'Tommy',
138		last_name => 'Lee',
139		title => 'Vice President / Senior Developer',
140		address => Address->new(city => 'New York', state => 'NY')
141		),
142		Employee->new(
143		first_name => 'Stevan',
144		middle_initial => 'C',
145		last_name => 'Little',
146		title => 'Senior Developer',
147		address => Address->new(city => 'Madison', state => 'CT')
148		),
149		]
150		});
151		} '... created the entire company successfully';
152		isa_ok($ii, 'Company');
153
154		is($ii->name, 'Infinity Interactive', '... got the right name for the company');
155
156		isa_ok($ii->address, 'Address');
157		is($ii->address->street, '565 Plandome Rd., Suite 307', '... got the right street address');
158		is($ii->address->city, 'Manhasset', '... got the right city');
159		is($ii->address->state, 'NY', '... got the right state');
160		is($ii->address->zip_code, 11030, '... got the zip code');
161
162		is($ii->get_employee_count, 3, '... got the right employee count');
163
164		# employee #1
165
166		isa_ok($ii->employees->[0], 'Employee');
167		isa_ok($ii->employees->[0], 'Person');
168
169		is($ii->employees->[0]->first_name, 'Jeremy', '... got the right first name');
170		is($ii->employees->[0]->last_name, 'Shao', '... got the right last name');
171		ok(!$ii->employees->[0]->has_middle_initial, '... no middle initial');
172		is($ii->employees->[0]->middle_initial, undef, '... got the right middle initial value');
173		is($ii->employees->[0]->full_name, 'Jeremy Shao, President / Senior Consultant', '... got the right full name');
174		is($ii->employees->[0]->title, 'President / Senior Consultant', '... got the right title');
175		is($ii->employees->[0]->company, $ii, '... got the right company');
176		ok(isweak($ii->employees->[0]->{company}), '... the company is a weak-ref');
177
178		isa_ok($ii->employees->[0]->address, 'Address');
179		is($ii->employees->[0]->address->city, 'Manhasset', '... got the right city');
180		is($ii->employees->[0]->address->state, 'NY', '... got the right state');
181
182		# employee #2
183
184		isa_ok($ii->employees->[1], 'Employee');
185		isa_ok($ii->employees->[1], 'Person');
186
187		is($ii->employees->[1]->first_name, 'Tommy', '... got the right first name');
188		is($ii->employees->[1]->last_name, 'Lee', '... got the right last name');
189		ok(!$ii->employees->[1]->has_middle_initial, '... no middle initial');
190		is($ii->employees->[1]->middle_initial, undef, '... got the right middle initial value');
191		is($ii->employees->[1]->full_name, 'Tommy Lee, Vice President / Senior Developer', '... got the right full name');
192		is($ii->employees->[1]->title, 'Vice President / Senior Developer', '... got the right title');
193		is($ii->employees->[1]->company, $ii, '... got the right company');
194		ok(isweak($ii->employees->[1]->{company}), '... the company is a weak-ref');
195
196		isa_ok($ii->employees->[1]->address, 'Address');
197		is($ii->employees->[1]->address->city, 'New York', '... got the right city');
198		is($ii->employees->[1]->address->state, 'NY', '... got the right state');
199
200		# employee #3
201
202		isa_ok($ii->employees->[2], 'Employee');
203		isa_ok($ii->employees->[2], 'Person');
204
205		is($ii->employees->[2]->first_name, 'Stevan', '... got the right first name');
206		is($ii->employees->[2]->last_name, 'Little', '... got the right last name');
207		ok($ii->employees->[2]->has_middle_initial, '... got middle initial');
208		is($ii->employees->[2]->middle_initial, 'C', '... got the right middle initial value');
209		is($ii->employees->[2]->full_name, 'Stevan C. Little, Senior Developer', '... got the right full name');
210		is($ii->employees->[2]->title, 'Senior Developer', '... got the right title');
211		is($ii->employees->[2]->company, $ii, '... got the right company');
212		ok(isweak($ii->employees->[2]->{company}), '... the company is a weak-ref');
213
214		isa_ok($ii->employees->[2]->address, 'Address');
215		is($ii->employees->[2]->address->city, 'Madison', '... got the right city');
216		is($ii->employees->[2]->address->state, 'CT', '... got the right state');
217
218		# create new company
219
220		my $new_company = Company->new(name => 'Infinity Interactive International');
221		isa_ok($new_company, 'Company');
222
223		my $ii_employees = $ii->employees;
224		foreach my $employee (@$ii_employees) {
225		is($employee->company, $ii, '... has the ii company');
226		}
227
228		$new_company->employees($ii_employees);
229
230		foreach my $employee (@{$new_company->employees}) {
231		is($employee->company, $new_company, '... has the different company now');
232		}
233
234		## check some error conditions for the subtypes
235
236		dies_ok {
237		Address->new(street => {}),
238		} '... we die correctly with bad args';
239
240		dies_ok {
241		Address->new(city => {}),
242		} '... we die correctly with bad args';
243
244		dies_ok {
245		Address->new(state => 'British Columbia'),
246		} '... we die correctly with bad args';
247
248		lives_ok {
249		Address->new(state => 'Connecticut'),
250		} '... we live correctly with good args';
251
252		dies_ok {
253		Address->new(zip_code => 'AF5J6$'),
254		} '... we die correctly with bad args';
255
256		lives_ok {
257		Address->new(zip_code => '06443'),
258		} '... we live correctly with good args';
259
260		dies_ok {
261		Company->new(),
262		} '... we die correctly without good args';
263
264		lives_ok {
265		Company->new(name => 'Foo'),
266		} '... we live correctly without good args';
267
268		dies_ok {
269		Company->new(name => 'Foo', employees => [ Person->new ]),
270		} '... we die correctly with good args';
271
272		lives_ok {
273		Company->new(name => 'Foo', employees => []),
274		} '... we live correctly with good args';
275

+0

-118

~~t/000_recipes/005_coercion.t~~ less more

0		#!/usr/bin/perl
1
2		use strict;
3		use warnings;
4
5		use Test::More;
6
7		BEGIN {
8		eval "use HTTP::Headers; use Params::Coerce; use URI;";
9		plan skip_all => "HTTP::Headers & Params::Coerce & URI required for this test" if $@;
10		plan tests => 18;
11		}
12
13		use Test::Exception;
14
15		BEGIN {
16		use_ok('Moose');
17		}
18
19		{
20		package Request;
21		use Moose;
22		use Moose::Util::TypeConstraints;
23
24		use HTTP::Headers ();
25		use Params::Coerce ();
26		use URI ();
27
28		subtype Header
29		=> as Object
30		=> where { $_->isa('HTTP::Headers') };
31
32		coerce Header
33		=> from ArrayRef
34		=> via { HTTP::Headers->new( @{ $_ } ) }
35		=> from HashRef
36		=> via { HTTP::Headers->new( %{ $_ } ) };
37
38		subtype Uri
39		=> as Object
40		=> where { $_->isa('URI') };
41
42		coerce Uri
43		=> from Object
44		=> via { $_->isa('URI') ? $_ : Params::Coerce::coerce( 'URI', $_ ) }
45		=> from Str
46		=> via { URI->new( $_, 'http' ) };
47
48		subtype Protocol
49		=> as Str
50		=> where { /^HTTP\/[0-9]\.[0-9]$/ };
51
52
53		has 'base' => (is => 'rw', isa => 'Uri', coerce => 1);
54		has 'url' => (is => 'rw', isa => 'Uri', coerce => 1);
55		has 'method' => (is => 'rw', isa => 'Str');
56		has 'protocol' => (is => 'rw', isa => 'Protocol');
57		has 'headers' => (
58		is => 'rw',
59		isa => 'Header',
60		coerce => 1,
61		default => sub { HTTP::Headers->new }
62		);
63
64		__PACKAGE__->meta->make_immutable(debug => 0);
65		}
66
67		my $r = Request->new;
68		isa_ok($r, 'Request');
69
70		{
71		my $header = $r->headers;
72		isa_ok($header, 'HTTP::Headers');
73
74		is($r->headers->content_type, '', '... got no content type in the header');
75
76		$r->headers( { content_type => 'text/plain' } );
77
78		my $header2 = $r->headers;
79		isa_ok($header2, 'HTTP::Headers');
80		isnt($header, $header2, '... created a new HTTP::Header object');
81
82		is($header2->content_type, 'text/plain', '... got the right content type in the header');
83
84		$r->headers( [ content_type => 'text/html' ] );
85
86		my $header3 = $r->headers;
87		isa_ok($header3, 'HTTP::Headers');
88		isnt($header2, $header3, '... created a new HTTP::Header object');
89
90		is($header3->content_type, 'text/html', '... got the right content type in the header');
91
92		$r->headers( HTTP::Headers->new(content_type => 'application/pdf') );
93
94		my $header4 = $r->headers;
95		isa_ok($header4, 'HTTP::Headers');
96		isnt($header3, $header4, '... created a new HTTP::Header object');
97
98		is($header4->content_type, 'application/pdf', '... got the right content type in the header');
99
100		dies_ok {
101		$r->headers('Foo')
102		} '... dies when it gets bad params';
103		}
104
105		{
106		is($r->protocol, undef, '... got nothing by default');
107
108		lives_ok {
109		$r->protocol('HTTP/1.0');
110		} '... set the protocol correctly';
111		is($r->protocol, 'HTTP/1.0', '... got nothing by default');
112
113		dies_ok {
114		$r->protocol('http/1.0');
115		} '... the protocol died with bar params correctly';
116		}
117

+0

-76

~~t/000_recipes/006_augment_inner.t~~ less more

0		#!/usr/bin/perl
1
2		use strict;
3		use warnings;
4
5		use Test::More tests => 3;
6		use Test::Exception;
7
8		BEGIN {
9		use_ok('Moose');
10		}
11
12		## Augment/Inner
13
14		{
15		package Document::Page;
16		use Moose;
17
18		has 'body' => (is => 'rw', isa => 'Str', default => sub {''});
19
20		sub create {
21		my $self = shift;
22		$self->open_page;
23		inner();
24		$self->close_page;
25		}
26
27		sub append_body {
28		my ($self, $appendage) = @_;
29		$self->body($self->body . $appendage);
30		}
31
32		sub open_page { (shift)->append_body('<page>') }
33		sub close_page { (shift)->append_body('</page>') }
34
35		package Document::PageWithHeadersAndFooters;
36		use Moose;
37
38		extends 'Document::Page';
39
40		augment 'create' => sub {
41		my $self = shift;
42		$self->create_header;
43		inner();
44		$self->create_footer;
45		};
46
47		sub create_header { (shift)->append_body('<header/>') }
48		sub create_footer { (shift)->append_body('<footer/>') }
49
50		package TPSReport;
51		use Moose;
52
53		extends 'Document::PageWithHeadersAndFooters';
54
55		augment 'create' => sub {
56		my $self = shift;
57		$self->create_tps_report;
58		};
59
60		sub create_tps_report {
61		(shift)->append_body('<report type="tps"/>')
62		}
63		}
64
65		my $tps_report = TPSReport->new;
66		isa_ok($tps_report, 'TPSReport');
67
68		is(
69		$tps_report->create,
70		q{<page><header/><report type="tps"/><footer/></page>},
71		'... got the right TPS report');
72
73
74
75

+0

-190

~~t/000_recipes/010_roles.t~~ less more

0		#!/usr/bin/perl
1
2		use strict;
3		use warnings;
4
5		use Test::More tests => 64;
6		use Test::Exception;
7
8		BEGIN {
9		use_ok('Moose');
10		}
11
12		## Roles
13
14		{
15		package Eq;
16		use Moose::Role;
17
18		requires 'equal_to';
19
20		sub not_equal_to {
21		my ($self, $other) = @_;
22		not $self->equal_to($other);
23		}
24
25		package Comparable;
26		use Moose::Role;
27
28		with 'Eq';
29
30		requires 'compare';
31
32		sub equal_to {
33		my ($self, $other) = @_;
34		$self->compare($other) == 0;
35		}
36
37		sub greater_than {
38		my ($self, $other) = @_;
39		$self->compare($other) == 1;
40		}
41
42		sub less_than {
43		my ($self, $other) = @_;
44		$self->compare($other) == -1;
45		}
46
47		sub greater_than_or_equal_to {
48		my ($self, $other) = @_;
49		$self->greater_than($other) \|\| $self->equal_to($other);
50		}
51
52		sub less_than_or_equal_to {
53		my ($self, $other) = @_;
54		$self->less_than($other) \|\| $self->equal_to($other);
55		}
56
57		package Printable;
58		use Moose::Role;
59
60		requires 'to_string';
61		}
62
63		## Classes
64
65		{
66		package US::Currency;
67		use Moose;
68
69		with 'Comparable', 'Printable';
70
71		has 'amount' => (is => 'rw', isa => 'Num', default => 0);
72
73		sub compare {
74		my ($self, $other) = @_;
75		$self->amount <=> $other->amount;
76		}
77
78		sub to_string {
79		my $self = shift;
80		sprintf '$%0.2f USD' => $self->amount
81		}
82
83		__PACKAGE__->meta->make_immutable(debug => 0);
84		}
85
86		ok(US::Currency->does('Comparable'), '... US::Currency does Comparable');
87		ok(US::Currency->does('Eq'), '... US::Currency does Eq');
88		ok(US::Currency->does('Printable'), '... US::Currency does Printable');
89
90		my $hundred = US::Currency->new(amount => 100.00);
91		isa_ok($hundred, 'US::Currency');
92
93		ok( $hundred->DOES("US::Currency"), "UNIVERSAL::DOES for class" );
94		ok( $hundred->DOES("Comparable"), "UNIVERSAL::DOES for role" );
95
96		can_ok($hundred, 'amount');
97		is($hundred->amount, 100, '... got the right amount');
98
99		can_ok($hundred, 'to_string');
100		is($hundred->to_string, '$100.00 USD', '... got the right stringified value');
101
102		ok($hundred->does('Comparable'), '... US::Currency does Comparable');
103		ok($hundred->does('Eq'), '... US::Currency does Eq');
104		ok($hundred->does('Printable'), '... US::Currency does Printable');
105
106		my $fifty = US::Currency->new(amount => 50.00);
107		isa_ok($fifty, 'US::Currency');
108
109		can_ok($fifty, 'amount');
110		is($fifty->amount, 50, '... got the right amount');
111
112		can_ok($fifty, 'to_string');
113		is($fifty->to_string, '$50.00 USD', '... got the right stringified value');
114
115		ok($hundred->greater_than($fifty), '... 100 gt 50');
116		ok($hundred->greater_than_or_equal_to($fifty), '... 100 ge 50');
117		ok(!$hundred->less_than($fifty), '... !100 lt 50');
118		ok(!$hundred->less_than_or_equal_to($fifty), '... !100 le 50');
119		ok(!$hundred->equal_to($fifty), '... !100 eq 50');
120		ok($hundred->not_equal_to($fifty), '... 100 ne 50');
121
122		ok(!$fifty->greater_than($hundred), '... !50 gt 100');
123		ok(!$fifty->greater_than_or_equal_to($hundred), '... !50 ge 100');
124		ok($fifty->less_than($hundred), '... 50 lt 100');
125		ok($fifty->less_than_or_equal_to($hundred), '... 50 le 100');
126		ok(!$fifty->equal_to($hundred), '... !50 eq 100');
127		ok($fifty->not_equal_to($hundred), '... 50 ne 100');
128
129		ok(!$fifty->greater_than($fifty), '... !50 gt 50');
130		ok($fifty->greater_than_or_equal_to($fifty), '... !50 ge 50');
131		ok(!$fifty->less_than($fifty), '... 50 lt 50');
132		ok($fifty->less_than_or_equal_to($fifty), '... 50 le 50');
133		ok($fifty->equal_to($fifty), '... 50 eq 50');
134		ok(!$fifty->not_equal_to($fifty), '... !50 ne 50');
135
136		## ... check some meta-stuff
137
138		# Eq
139
140		my $eq_meta = Eq->meta;
141		isa_ok($eq_meta, 'Moose::Meta::Role');
142
143		ok($eq_meta->has_method('not_equal_to'), '... Eq has_method not_equal_to');
144		ok($eq_meta->requires_method('equal_to'), '... Eq requires_method not_equal_to');
145
146		# Comparable
147
148		my $comparable_meta = Comparable->meta;
149		isa_ok($comparable_meta, 'Moose::Meta::Role');
150
151		ok($comparable_meta->does_role('Eq'), '... Comparable does Eq');
152
153		foreach my $method_name (qw(
154		equal_to not_equal_to
155		greater_than greater_than_or_equal_to
156		less_than less_than_or_equal_to
157		)) {
158		ok($comparable_meta->has_method($method_name), '... Comparable has_method ' . $method_name);
159		}
160
161		ok($comparable_meta->requires_method('compare'), '... Comparable requires_method compare');
162
163		# Printable
164
165		my $printable_meta = Printable->meta;
166		isa_ok($printable_meta, 'Moose::Meta::Role');
167
168		ok($printable_meta->requires_method('to_string'), '... Printable requires_method to_string');
169
170		# US::Currency
171
172		my $currency_meta = US::Currency->meta;
173		isa_ok($currency_meta, 'Moose::Meta::Class');
174
175		ok($currency_meta->does_role('Comparable'), '... US::Currency does Comparable');
176		ok($currency_meta->does_role('Eq'), '... US::Currency does Eq');
177		ok($currency_meta->does_role('Printable'), '... US::Currency does Printable');
178
179		foreach my $method_name (qw(
180		amount
181		equal_to not_equal_to
182		compare
183		greater_than greater_than_or_equal_to
184		less_than less_than_or_equal_to
185		to_string
186		)) {
187		ok($currency_meta->has_method($method_name), '... US::Currency has_method ' . $method_name);
188		}
189

+0

-98

~~t/000_recipes/011_advanced_role_composition.t~~ less more

0		use strict;
1		use warnings;
2		use Test::More tests => 5;
3		use Class::MOP;
4
5		# This is copied directly from recipe 11
6		{
7		package Restartable;
8		use Moose::Role;
9
10		has 'is_paused' => (
11		is => 'rw',
12		isa => 'Bool',
13		default => 0,
14		);
15
16		requires 'save_state', 'load_state';
17
18		sub stop { }
19
20		sub start { }
21
22		package Restartable::ButUnreliable;
23		use Moose::Role;
24
25		with 'Restartable' => {
26		alias => {
27		stop => '_stop',
28		start => '_start'
29		}
30		};
31
32		sub stop {
33		my $self = shift;
34
35		$self->explode() if rand(1) > .5;
36
37		$self->_stop();
38		}
39
40		sub start {
41		my $self = shift;
42
43		$self->explode() if rand(1) > .5;
44
45		$self->_start();
46		}
47
48		package Restartable::ButBroken;
49		use Moose::Role;
50
51		with 'Restartable' => { excludes => [ 'stop', 'start' ] };
52
53		sub stop {
54		my $self = shift;
55
56		$self->explode();
57		}
58
59		sub start {
60		my $self = shift;
61
62		$self->explode();
63		}
64		}
65
66		# This is the actual tests
67		{
68		my $unreliable = Moose::Meta::Class->create_anon_class(
69		superclasses => [],
70		roles => [qw/Restartable::ButUnreliable/],
71		methods => {
72		explode => sub { }, # nop.
73		'save_state' => sub { },
74		'load_state' => sub { },
75		},
76		)->new_object();
77		ok $unreliable, 'made anon class with Restartable::ButUnreliable role';
78		can_ok $unreliable, qw/start stop/;
79		}
80
81		{
82		my $cnt = 0;
83		my $broken = Moose::Meta::Class->create_anon_class(
84		superclasses => [],
85		roles => [qw/Restartable::ButBroken/],
86		methods => {
87		explode => sub { $cnt++ },
88		'save_state' => sub { },
89		'load_state' => sub { },
90		},
91		)->new_object();
92		ok $broken, 'made anon class with Restartable::ButBroken role';
93		$broken->start();
94		is $cnt, 1, '... start called explode';
95		$broken->stop();
96		is $cnt, 2, '... stop also called explode';
97		}

+0

-80

~~t/000_recipes/021_meta_attribute.t~~ less more

0		#!/usr/bin/perl
1
2		use strict;
3		use warnings;
4
5		use Test::More tests => 2;
6		use Test::Exception;
7
8		BEGIN {
9		use_ok('Moose');
10		}
11
12		## meta-attribute example
13		{
14
15		package MyApp::Meta::Attribute::Labeled;
16		use Moose;
17		extends 'Moose::Meta::Attribute';
18
19		has label => (
20		is => 'rw',
21		isa => 'Str',
22		predicate => 'has_label',
23		);
24
25		package Moose::Meta::Attribute::Custom::Labeled;
26		sub register_implementation { 'MyApp::Meta::Attribute::Labeled' }
27
28		package MyApp::Website;
29		use Moose;
30
31		has url => (
32		metaclass => 'Labeled',
33		isa => 'Str',
34		is => 'rw',
35		label => "The site's URL",
36		);
37
38		has name => (
39		is => 'rw',
40		isa => 'Str',
41		);
42
43		sub dump {
44		my $self = shift;
45
46		my $dump_value = '';
47
48		# iterate over all the attributes in $self
49		my %attributes = %{ $self->meta->get_attribute_map };
50		foreach my $name (sort keys %attributes) {
51
52		my $attribute = $attributes{$name};
53
54		# print the label if available
55		if ($attribute->isa('MyApp::Meta::Attribute::Labeled')
56		&& $attribute->has_label) {
57		$dump_value .= $attribute->label;
58		}
59		# otherwise print the name
60		else {
61		$dump_value .= $name;
62		}
63
64		# print the attribute's value
65		my $reader = $attribute->get_read_method;
66		$dump_value .= ": " . $self->$reader . "\n";
67		}
68
69		return $dump_value;
70		}
71
72		}
73
74		my $app = MyApp::Website->new(url => "http://google.com", name => "Google");
75		is($app->dump, q{name: Google
76		The site's URL: http://google.com
77		}, '... got the expected dump value');
78
79

+0

-139

~~t/000_recipes/022_attribute_trait.t~~ less more

0		#!/usr/bin/perl
1
2		use strict;
3		use warnings;
4
5		use Test::More tests => 3;
6		use Test::Exception;
7
8		BEGIN {
9		use_ok('Moose');
10		}
11
12		## attribute trait example
13		{
14
15		package MyApp::Meta::Attribute::Trait::Labeled;
16		use Moose::Role;
17
18		has label => (
19		is => 'rw',
20		isa => 'Str',
21		predicate => 'has_label',
22		);
23
24		package Moose::Meta::Attribute::Custom::Trait::Labeled;
25		sub register_implementation { 'MyApp::Meta::Attribute::Trait::Labeled' }
26
27		package MyApp::Website;
28		use Moose;
29
30		has url => (
31		traits => [qw/Labeled/],
32		isa => 'Str',
33		is => 'rw',
34		label => "The site's URL",
35		);
36
37		has name => (
38		is => 'rw',
39		isa => 'Str',
40		);
41
42		sub dump {
43		my $self = shift;
44
45		my $dump_value = '';
46
47		# iterate over all the attributes in $self
48		my %attributes = %{ $self->meta->get_attribute_map };
49		foreach my $name (sort keys %attributes) {
50
51		my $attribute = $attributes{$name};
52
53		# print the label if available
54		if ($attribute->does('MyApp::Meta::Attribute::Trait::Labeled')
55		&& $attribute->has_label) {
56		$dump_value .= $attribute->label;
57		}
58		# otherwise print the name
59		else {
60		$dump_value .= $name;
61		}
62
63		# print the attribute's value
64		my $reader = $attribute->get_read_method;
65		$dump_value .= ": " . $self->$reader . "\n";
66		}
67
68		return $dump_value;
69		}
70
71		}
72
73		my $app = MyApp::Website->new(url => "http://google.com", name => "Google");
74		is($app->dump, q{name: Google
75		The site's URL: http://google.com
76		}, '... got the expected dump value');
77
78		# using the trait directly in a regular metaclass
79		{
80		package MyApp::Meta::Attribute::Labeled;
81		use Moose;
82		extends 'Moose::Meta::Attribute';
83		with 'MyApp::Meta::Attribute::Trait::Labeled';
84
85		package Moose::Meta::Attribute::Custom::Labeled;
86		sub register_implementation { 'MyApp::Meta::Attribute::Labeled' }
87
88		package MyApp::Website2;
89		use Moose;
90
91		has url => (
92		metaclass => 'Labeled',
93		isa => 'Str',
94		is => 'rw',
95		label => "The site's URL",
96		);
97
98		has name => (
99		is => 'rw',
100		isa => 'Str',
101		);
102
103		sub dump {
104		my $self = shift;
105
106		my $dump_value = '';
107
108		# iterate over all the attributes in $self
109		my %attributes = %{ $self->meta->get_attribute_map };
110		foreach my $name (sort keys %attributes) {
111
112		my $attribute = $attributes{$name};
113
114		# print the label if available
115		if ($attribute->isa('MyApp::Meta::Attribute::Labeled')
116		&& $attribute->has_label) {
117		$dump_value .= $attribute->label;
118		}
119		# otherwise print the name
120		else {
121		$dump_value .= $name;
122		}
123
124		# print the attribute's value
125		my $reader = $attribute->get_read_method;
126		$dump_value .= ": " . $self->$reader . "\n";
127		}
128
129		return $dump_value;
130		}
131
132		}
133
134		my $app2 = MyApp::Website2->new(url => "http://google.com", name => "Google");
135		is($app2->dump, q{name: Google
136		The site's URL: http://google.com
137		}, '... got the expected dump value');
138

+186

-0

t/000_recipes/basics/001_point.t less more

	0	#!/usr/bin/perl
	1
	2	use strict;
	3	use warnings;
	4
	5	use Test::More tests => 58;
	6	use Test::Exception;
	7
	8	BEGIN {
	9	use_ok('Moose');
	10	}
	11
	12	{
	13	package Point;
	14	use Moose;
	15
	16	has 'x' => (isa => 'Int', is => 'ro');
	17	has 'y' => (isa => 'Int', is => 'rw');
	18
	19	sub clear {
	20	my $self = shift;
	21	$self->{x} = 0;
	22	$self->y(0);
	23	}
	24
	25	__PACKAGE__->meta->make_immutable(debug => 0);
	26	}{
	27	package Point3D;
	28	use Moose;
	29
	30	extends 'Point';
	31
	32	has 'z' => (isa => 'Int');
	33
	34	after 'clear' => sub {
	35	my $self = shift;
	36	$self->{z} = 0;
	37	};
	38
	39	__PACKAGE__->meta->make_immutable(debug => 0);
	40	}
	41
	42	my $point = Point->new(x => 1, y => 2);
	43	isa_ok($point, 'Point');
	44	isa_ok($point, 'Moose::Object');
	45
	46	is($point->x, 1, '... got the right value for x');
	47	is($point->y, 2, '... got the right value for y');
	48
	49	$point->y(10);
	50	is($point->y, 10, '... got the right (changed) value for y');
	51
	52	dies_ok {
	53	$point->y('Foo');
	54	} '... cannot assign a non-Int to y';
	55
	56	dies_ok {
	57	$point->x(1000);
	58	} '... cannot assign to a read-only method';
	59	is($point->x, 1, '... got the right (un-changed) value for x');
	60
	61	$point->clear();
	62
	63	is($point->x, 0, '... got the right (cleared) value for x');
	64	is($point->y, 0, '... got the right (cleared) value for y');
	65
	66	# check the type constraints on the constructor
	67
	68	lives_ok {
	69	Point->new(x => 0, y => 0);
	70	} '... can assign a 0 to x and y';
	71
	72	dies_ok {
	73	Point->new(x => 10, y => 'Foo');
	74	} '... cannot assign a non-Int to y';
	75
	76	dies_ok {
	77	Point->new(x => 'Foo', y => 10);
	78	} '... cannot assign a non-Int to x';
	79
	80	# Point3D
	81
	82	my $point3d = Point3D->new({ x => 10, y => 15, z => 3 });
	83	isa_ok($point3d, 'Point3D');
	84	isa_ok($point3d, 'Point');
	85	isa_ok($point3d, 'Moose::Object');
	86
	87	is($point3d->x, 10, '... got the right value for x');
	88	is($point3d->y, 15, '... got the right value for y');
	89	is($point3d->{'z'}, 3, '... got the right value for z');
	90
	91	dies_ok {
	92	$point3d->z;
	93	} '... there is no method for z';
	94
	95	$point3d->clear();
	96
	97	is($point3d->x, 0, '... got the right (cleared) value for x');
	98	is($point3d->y, 0, '... got the right (cleared) value for y');
	99	is($point3d->{'z'}, 0, '... got the right (cleared) value for z');
	100
	101	dies_ok {
	102	Point3D->new(x => 10, y => 'Foo', z => 3);
	103	} '... cannot assign a non-Int to y';
	104
	105	dies_ok {
	106	Point3D->new(x => 'Foo', y => 10, z => 3);
	107	} '... cannot assign a non-Int to x';
	108
	109	dies_ok {
	110	Point3D->new(x => 0, y => 10, z => 'Bar');
	111	} '... cannot assign a non-Int to z';
	112
	113	# test some class introspection
	114
	115	can_ok('Point', 'meta');
	116	isa_ok(Point->meta, 'Moose::Meta::Class');
	117
	118	can_ok('Point3D', 'meta');
	119	isa_ok(Point3D->meta, 'Moose::Meta::Class');
	120
	121	isnt(Point->meta, Point3D->meta, '... they are different metaclasses as well');
	122
	123	# poke at Point
	124
	125	is_deeply(
	126	[ Point->meta->superclasses ],
	127	[ 'Moose::Object' ],
	128	'... Point got the automagic base class');
	129
	130	my @Point_methods = qw(meta new x y clear);
	131	my @Point_attrs = ('x', 'y');
	132
	133	is_deeply(
	134	[ sort @Point_methods ],
	135	[ sort Point->meta->get_method_list() ],
	136	'... we match the method list for Point');
	137
	138	is_deeply(
	139	[ sort @Point_attrs ],
	140	[ sort Point->meta->get_attribute_list() ],
	141	'... we match the attribute list for Point');
	142
	143	foreach my $method (@Point_methods) {
	144	ok(Point->meta->has_method($method), '... Point has the method "' . $method . '"');
	145	}
	146
	147	foreach my $attr_name (@Point_attrs ) {
	148	ok(Point->meta->has_attribute($attr_name), '... Point has the attribute "' . $attr_name . '"');
	149	my $attr = Point->meta->get_attribute($attr_name);
	150	ok($attr->has_type_constraint, '... Attribute ' . $attr_name . ' has a type constraint');
	151	isa_ok($attr->type_constraint, 'Moose::Meta::TypeConstraint');
	152	is($attr->type_constraint->name, 'Int', '... Attribute ' . $attr_name . ' has an Int type constraint');
	153	}
	154
	155	# poke at Point3D
	156
	157	is_deeply(
	158	[ Point3D->meta->superclasses ],
	159	[ 'Point' ],
	160	'... Point3D gets the parent given to it');
	161
	162	my @Point3D_methods = qw(new meta clear);
	163	my @Point3D_attrs = ('z');
	164
	165	is_deeply(
	166	[ sort @Point3D_methods ],
	167	[ sort Point3D->meta->get_method_list() ],
	168	'... we match the method list for Point3D');
	169
	170	is_deeply(
	171	[ sort @Point3D_attrs ],
	172	[ sort Point3D->meta->get_attribute_list() ],
	173	'... we match the attribute list for Point3D');
	174
	175	foreach my $method (@Point3D_methods) {
	176	ok(Point3D->meta->has_method($method), '... Point3D has the method "' . $method . '"');
	177	}
	178
	179	foreach my $attr_name (@Point3D_attrs ) {
	180	ok(Point3D->meta->has_attribute($attr_name), '... Point3D has the attribute "' . $attr_name . '"');
	181	my $attr = Point3D->meta->get_attribute($attr_name);
	182	ok($attr->has_type_constraint, '... Attribute ' . $attr_name . ' has a type constraint');
	183	isa_ok($attr->type_constraint, 'Moose::Meta::TypeConstraint');
	184	is($attr->type_constraint->name, 'Int', '... Attribute ' . $attr_name . ' has an Int type constraint');
	185	}

+113

-0

t/000_recipes/basics/002_bank_account.t less more

	0	#!/usr/bin/perl
	1
	2	use strict;
	3	use warnings;
	4
	5	use Test::More tests => 24;
	6	use Test::Exception;
	7
	8	BEGIN {
	9	use_ok('Moose');
	10	}
	11
	12	{
	13	package BankAccount;
	14	use Moose;
	15
	16	has 'balance' => (isa => 'Num', is => 'rw', default => 0);
	17
	18	sub deposit {
	19	my ($self, $amount) = @_;
	20	$self->balance($self->balance + $amount);
	21	}
	22
	23	sub withdraw {
	24	my ($self, $amount) = @_;
	25	my $current_balance = $self->balance();
	26	($current_balance >= $amount)
	27	\|\| confess "Account overdrawn";
	28	$self->balance($current_balance - $amount);
	29	}
	30
	31	__PACKAGE__->meta->make_immutable(debug => 0);
	32	}{
	33	package CheckingAccount;
	34	use Moose;
	35
	36	extends 'BankAccount';
	37
	38	has 'overdraft_account' => (isa => 'BankAccount', is => 'rw');
	39
	40	before 'withdraw' => sub {
	41	my ($self, $amount) = @_;
	42	my $overdraft_amount = $amount - $self->balance();
	43	if ($self->overdraft_account && $overdraft_amount > 0) {
	44	$self->overdraft_account->withdraw($overdraft_amount);
	45	$self->deposit($overdraft_amount);
	46	}
	47	};
	48
	49	__PACKAGE__->meta->make_immutable(debug => 0);
	50	}
	51
	52	my $savings_account = BankAccount->new(balance => 250);
	53	isa_ok($savings_account, 'BankAccount');
	54
	55	is($savings_account->balance, 250, '... got the right savings balance');
	56	lives_ok {
	57	$savings_account->withdraw(50);
	58	} '... withdrew from savings successfully';
	59	is($savings_account->balance, 200, '... got the right savings balance after withdrawl');
	60
	61	$savings_account->deposit(150);
	62	is($savings_account->balance, 350, '... got the right savings balance after deposit');
	63
	64	{
	65	my $checking_account = CheckingAccount->new(
	66	balance => 100,
	67	overdraft_account => $savings_account
	68	);
	69	isa_ok($checking_account, 'CheckingAccount');
	70	isa_ok($checking_account, 'BankAccount');
	71
	72	is($checking_account->overdraft_account, $savings_account, '... got the right overdraft account');
	73
	74	is($checking_account->balance, 100, '... got the right checkings balance');
	75
	76	lives_ok {
	77	$checking_account->withdraw(50);
	78	} '... withdrew from checking successfully';
	79	is($checking_account->balance, 50, '... got the right checkings balance after withdrawl');
	80	is($savings_account->balance, 350, '... got the right savings balance after checking withdrawl (no overdraft)');
	81
	82	lives_ok {
	83	$checking_account->withdraw(200);
	84	} '... withdrew from checking successfully';
	85	is($checking_account->balance, 0, '... got the right checkings balance after withdrawl');
	86	is($savings_account->balance, 200, '... got the right savings balance after overdraft withdrawl');
	87	}
	88
	89	{
	90	my $checking_account = CheckingAccount->new(
	91	balance => 100
	92	# no overdraft account
	93	);
	94	isa_ok($checking_account, 'CheckingAccount');
	95	isa_ok($checking_account, 'BankAccount');
	96
	97	is($checking_account->overdraft_account, undef, '... no overdraft account');
	98
	99	is($checking_account->balance, 100, '... got the right checkings balance');
	100
	101	lives_ok {
	102	$checking_account->withdraw(50);
	103	} '... withdrew from checking successfully';
	104	is($checking_account->balance, 50, '... got the right checkings balance after withdrawl');
	105
	106	dies_ok {
	107	$checking_account->withdraw(200);
	108	} '... withdrawl failed due to attempted overdraft';
	109	is($checking_account->balance, 50, '... got the right checkings balance after withdrawl failure');
	110	}
	111
	112

+121

-0

t/000_recipes/basics/003_binary_tree.t less more

	0	#!/usr/bin/perl
	1
	2	use strict;
	3	use warnings;
	4
	5	use Test::More tests => 34;
	6	use Test::Exception;
	7
	8	use Scalar::Util 'isweak';
	9
	10	BEGIN {
	11	use_ok('Moose');
	12	}
	13
	14	{
	15	package BinaryTree;
	16	use Moose;
	17
	18	has 'node' => (is => 'rw', isa => 'Any');
	19
	20	has 'parent' => (
	21	is => 'rw',
	22	isa => 'BinaryTree',
	23	predicate => 'has_parent',
	24	weak_ref => 1,
	25	);
	26
	27	has 'left' => (
	28	is => 'rw',
	29	isa => 'BinaryTree',
	30	predicate => 'has_left',
	31	lazy => 1,
	32	default => sub { BinaryTree->new(parent => $_[0]) },
	33	);
	34
	35	has 'right' => (
	36	is => 'rw',
	37	isa => 'BinaryTree',
	38	predicate => 'has_right',
	39	lazy => 1,
	40	default => sub { BinaryTree->new(parent => $_[0]) },
	41	);
	42
	43	before 'right', 'left' => sub {
	44	my ($self, $tree) = @_;
	45	$tree->parent($self) if defined $tree;
	46	};
	47
	48	__PACKAGE__->meta->make_immutable(debug => 0);
	49	}
	50
	51	my $root = BinaryTree->new(node => 'root');
	52	isa_ok($root, 'BinaryTree');
	53
	54	is($root->node, 'root', '... got the right node value');
	55
	56	ok(!$root->has_left, '... no left node yet');
	57	ok(!$root->has_right, '... no right node yet');
	58
	59	ok(!$root->has_parent, '... no parent for root node');
	60
	61	# make a left node
	62
	63	my $left = $root->left;
	64	isa_ok($left, 'BinaryTree');
	65
	66	is($root->left, $left, '... got the same node (and it is $left)');
	67	ok($root->has_left, '... we have a left node now');
	68
	69	ok($left->has_parent, '... lefts has a parent');
	70	is($left->parent, $root, '... lefts parent is the root');
	71
	72	ok(isweak($left->{parent}), '... parent is a weakened ref');
	73
	74	ok(!$left->has_left, '... $left no left node yet');
	75	ok(!$left->has_right, '... $left no right node yet');
	76
	77	is($left->node, undef, '... left has got no node value');
	78
	79	lives_ok {
	80	$left->node('left')
	81	} '... assign to lefts node';
	82
	83	is($left->node, 'left', '... left now has a node value');
	84
	85	# make a right node
	86
	87	ok(!$root->has_right, '... still no right node yet');
	88
	89	is($root->right->node, undef, '... right has got no node value');
	90
	91	ok($root->has_right, '... now we have a right node');
	92
	93	my $right = $root->right;
	94	isa_ok($right, 'BinaryTree');
	95
	96	lives_ok {
	97	$right->node('right')
	98	} '... assign to rights node';
	99
	100	is($right->node, 'right', '... left now has a node value');
	101
	102	is($root->right, $right, '... got the same node (and it is $right)');
	103	ok($root->has_right, '... we have a right node now');
	104
	105	ok($right->has_parent, '... rights has a parent');
	106	is($right->parent, $root, '... rights parent is the root');
	107
	108	ok(isweak($right->{parent}), '... parent is a weakened ref');
	109
	110	my $left_left = $left->left;
	111	isa_ok($left_left, 'BinaryTree');
	112
	113	ok($left_left->has_parent, '... left does have a parent');
	114
	115	is($left_left->parent, $left, '... got a parent node (and it is $left)');
	116	ok($left->has_left, '... we have a left node now');
	117	is($left->left, $left_left, '... got a left node (and it is $left_left)');
	118
	119	ok(isweak($left_left->{parent}), '... parent is a weakened ref');
	120

+276

-0

t/000_recipes/basics/004_company.t less more

	0	#!/usr/bin/perl
	1
	2	use strict;
	3	use warnings;
	4
	5	use Test::More;
	6
	7	BEGIN {
	8	eval "use Regexp::Common; use Locale::US;";
	9	plan skip_all => "Regexp::Common & Locale::US required for this test" if $@;
	10	plan tests => 66;
	11	}
	12
	13	use Test::Exception;
	14	use Scalar::Util 'isweak';
	15
	16	BEGIN {
	17	use_ok('Moose');
	18	}
	19
	20	{
	21	package Address;
	22	use Moose;
	23	use Moose::Util::TypeConstraints;
	24
	25	use Locale::US;
	26	use Regexp::Common 'zip';
	27
	28	my $STATES = Locale::US->new;
	29
	30	subtype USState
	31	=> as Str
	32	=> where {
	33	(exists $STATES->{code2state}{uc($_)} \|\| exists $STATES->{state2code}{uc($_)})
	34	};
	35
	36	subtype USZipCode
	37	=> as Value
	38	=> where {
	39	/^$RE{zip}{US}{-extended => 'allow'}$/
	40	};
	41
	42	has 'street' => (is => 'rw', isa => 'Str');
	43	has 'city' => (is => 'rw', isa => 'Str');
	44	has 'state' => (is => 'rw', isa => 'USState');
	45	has 'zip_code' => (is => 'rw', isa => 'USZipCode');
	46
	47	__PACKAGE__->meta->make_immutable(debug => 0);
	48	}{
	49
	50	package Company;
	51	use Moose;
	52	use Moose::Util::TypeConstraints;
	53
	54	has 'name' => (is => 'rw', isa => 'Str', required => 1);
	55	has 'address' => (is => 'rw', isa => 'Address');
	56	has 'employees' => (is => 'rw', isa => 'ArrayRef[Employee]');
	57
	58	sub BUILD {
	59	my ($self, $params) = @_;
	60	if ($params->{employees}) {
	61	foreach my $employee (@{$params->{employees}}) {
	62	$employee->company($self);
	63	}
	64	}
	65	}
	66
	67	sub get_employee_count { scalar @{(shift)->employees} }
	68
	69	after 'employees' => sub {
	70	my ($self, $employees) = @_;
	71	# if employees is defined, it
	72	# has already been type checked
	73	if (defined $employees) {
	74	# make sure each gets the
	75	# weak ref to the company
	76	foreach my $employee (@{$employees}) {
	77	$employee->company($self);
	78	}
	79	}
	80	};
	81
	82	__PACKAGE__->meta->make_immutable(debug => 0);
	83	}{
	84
	85	package Person;
	86	use Moose;
	87
	88	has 'first_name' => (is => 'rw', isa => 'Str', required => 1);
	89	has 'last_name' => (is => 'rw', isa => 'Str', required => 1);
	90	has 'middle_initial' => (is => 'rw', isa => 'Str', predicate => 'has_middle_initial');
	91	has 'address' => (is => 'rw', isa => 'Address');
	92
	93	sub full_name {
	94	my $self = shift;
	95	return $self->first_name .
	96	($self->has_middle_initial ? ' ' . $self->middle_initial . '. ' : ' ') .
	97	$self->last_name;
	98	}
	99
	100	__PACKAGE__->meta->make_immutable(debug => 0);
	101	}{
	102
	103	package Employee;
	104	use Moose;
	105
	106	extends 'Person';
	107
	108	has 'title' => (is => 'rw', isa => 'Str', required => 1);
	109	has 'company' => (is => 'rw', isa => 'Company', weak_ref => 1);
	110
	111	override 'full_name' => sub {
	112	my $self = shift;
	113	super() . ', ' . $self->title
	114	};
	115
	116	__PACKAGE__->meta->make_immutable(debug => 0);
	117	}
	118
	119	my $ii;
	120	lives_ok {
	121	$ii = Company->new({
	122	name => 'Infinity Interactive',
	123	address => Address->new(
	124	street => '565 Plandome Rd., Suite 307',
	125	city => 'Manhasset',
	126	state => 'NY',
	127	zip_code => '11030'
	128	),
	129	employees => [
	130	Employee->new(
	131	first_name => 'Jeremy',
	132	last_name => 'Shao',
	133	title => 'President / Senior Consultant',
	134	address => Address->new(city => 'Manhasset', state => 'NY')
	135	),
	136	Employee->new(
	137	first_name => 'Tommy',
	138	last_name => 'Lee',
	139	title => 'Vice President / Senior Developer',
	140	address => Address->new(city => 'New York', state => 'NY')
	141	),
	142	Employee->new(
	143	first_name => 'Stevan',
	144	middle_initial => 'C',
	145	last_name => 'Little',
	146	title => 'Senior Developer',
	147	address => Address->new(city => 'Madison', state => 'CT')
	148	),
	149	]
	150	});
	151	} '... created the entire company successfully';
	152	isa_ok($ii, 'Company');
	153
	154	is($ii->name, 'Infinity Interactive', '... got the right name for the company');
	155
	156	isa_ok($ii->address, 'Address');
	157	is($ii->address->street, '565 Plandome Rd., Suite 307', '... got the right street address');
	158	is($ii->address->city, 'Manhasset', '... got the right city');
	159	is($ii->address->state, 'NY', '... got the right state');
	160	is($ii->address->zip_code, 11030, '... got the zip code');
	161
	162	is($ii->get_employee_count, 3, '... got the right employee count');
	163
	164	# employee #1
	165
	166	isa_ok($ii->employees->[0], 'Employee');
	167	isa_ok($ii->employees->[0], 'Person');
	168
	169	is($ii->employees->[0]->first_name, 'Jeremy', '... got the right first name');
	170	is($ii->employees->[0]->last_name, 'Shao', '... got the right last name');
	171	ok(!$ii->employees->[0]->has_middle_initial, '... no middle initial');
	172	is($ii->employees->[0]->middle_initial, undef, '... got the right middle initial value');
	173	is($ii->employees->[0]->full_name, 'Jeremy Shao, President / Senior Consultant', '... got the right full name');
	174	is($ii->employees->[0]->title, 'President / Senior Consultant', '... got the right title');
	175	is($ii->employees->[0]->company, $ii, '... got the right company');
	176	ok(isweak($ii->employees->[0]->{company}), '... the company is a weak-ref');
	177
	178	isa_ok($ii->employees->[0]->address, 'Address');
	179	is($ii->employees->[0]->address->city, 'Manhasset', '... got the right city');
	180	is($ii->employees->[0]->address->state, 'NY', '... got the right state');
	181
	182	# employee #2
	183
	184	isa_ok($ii->employees->[1], 'Employee');
	185	isa_ok($ii->employees->[1], 'Person');
	186
	187	is($ii->employees->[1]->first_name, 'Tommy', '... got the right first name');
	188	is($ii->employees->[1]->last_name, 'Lee', '... got the right last name');
	189	ok(!$ii->employees->[1]->has_middle_initial, '... no middle initial');
	190	is($ii->employees->[1]->middle_initial, undef, '... got the right middle initial value');
	191	is($ii->employees->[1]->full_name, 'Tommy Lee, Vice President / Senior Developer', '... got the right full name');
	192	is($ii->employees->[1]->title, 'Vice President / Senior Developer', '... got the right title');
	193	is($ii->employees->[1]->company, $ii, '... got the right company');
	194	ok(isweak($ii->employees->[1]->{company}), '... the company is a weak-ref');
	195
	196	isa_ok($ii->employees->[1]->address, 'Address');
	197	is($ii->employees->[1]->address->city, 'New York', '... got the right city');
	198	is($ii->employees->[1]->address->state, 'NY', '... got the right state');
	199
	200	# employee #3
	201
	202	isa_ok($ii->employees->[2], 'Employee');
	203	isa_ok($ii->employees->[2], 'Person');
	204
	205	is($ii->employees->[2]->first_name, 'Stevan', '... got the right first name');
	206	is($ii->employees->[2]->last_name, 'Little', '... got the right last name');
	207	ok($ii->employees->[2]->has_middle_initial, '... got middle initial');
	208	is($ii->employees->[2]->middle_initial, 'C', '... got the right middle initial value');
	209	is($ii->employees->[2]->full_name, 'Stevan C. Little, Senior Developer', '... got the right full name');
	210	is($ii->employees->[2]->title, 'Senior Developer', '... got the right title');
	211	is($ii->employees->[2]->company, $ii, '... got the right company');
	212	ok(isweak($ii->employees->[2]->{company}), '... the company is a weak-ref');
	213
	214	isa_ok($ii->employees->[2]->address, 'Address');
	215	is($ii->employees->[2]->address->city, 'Madison', '... got the right city');
	216	is($ii->employees->[2]->address->state, 'CT', '... got the right state');
	217
	218	# create new company
	219
	220	my $new_company = Company->new(name => 'Infinity Interactive International');
	221	isa_ok($new_company, 'Company');
	222
	223	my $ii_employees = $ii->employees;
	224	foreach my $employee (@$ii_employees) {
	225	is($employee->company, $ii, '... has the ii company');
	226	}
	227
	228	$new_company->employees($ii_employees);
	229
	230	foreach my $employee (@{$new_company->employees}) {
	231	is($employee->company, $new_company, '... has the different company now');
	232	}
	233
	234	## check some error conditions for the subtypes
	235
	236	dies_ok {
	237	Address->new(street => {}),
	238	} '... we die correctly with bad args';
	239
	240	dies_ok {
	241	Address->new(city => {}),
	242	} '... we die correctly with bad args';
	243
	244	dies_ok {
	245	Address->new(state => 'British Columbia'),
	246	} '... we die correctly with bad args';
	247
	248	lives_ok {
	249	Address->new(state => 'Connecticut'),
	250	} '... we live correctly with good args';
	251
	252	dies_ok {
	253	Address->new(zip_code => 'AF5J6$'),
	254	} '... we die correctly with bad args';
	255
	256	lives_ok {
	257	Address->new(zip_code => '06443'),
	258	} '... we live correctly with good args';
	259
	260	dies_ok {
	261	Company->new(),
	262	} '... we die correctly without good args';
	263
	264	lives_ok {
	265	Company->new(name => 'Foo'),
	266	} '... we live correctly without good args';
	267
	268	dies_ok {
	269	Company->new(name => 'Foo', employees => [ Person->new ]),
	270	} '... we die correctly with good args';
	271
	272	lives_ok {
	273	Company->new(name => 'Foo', employees => []),
	274	} '... we live correctly with good args';
	275

+118

-0

t/000_recipes/basics/005_coercion.t less more

	0	#!/usr/bin/perl
	1
	2	use strict;
	3	use warnings;
	4
	5	use Test::More;
	6
	7	BEGIN {
	8	eval "use HTTP::Headers; use Params::Coerce; use URI;";
	9	plan skip_all => "HTTP::Headers & Params::Coerce & URI required for this test" if $@;
	10	plan tests => 18;
	11	}
	12
	13	use Test::Exception;
	14
	15	BEGIN {
	16	use_ok('Moose');
	17	}
	18
	19	{
	20	package Request;
	21	use Moose;
	22	use Moose::Util::TypeConstraints;
	23
	24	use HTTP::Headers ();
	25	use Params::Coerce ();
	26	use URI ();
	27
	28	subtype Header
	29	=> as Object
	30	=> where { $_->isa('HTTP::Headers') };
	31
	32	coerce Header
	33	=> from ArrayRef
	34	=> via { HTTP::Headers->new( @{ $_ } ) }
	35	=> from HashRef
	36	=> via { HTTP::Headers->new( %{ $_ } ) };
	37
	38	subtype Uri
	39	=> as Object
	40	=> where { $_->isa('URI') };
	41
	42	coerce Uri
	43	=> from Object
	44	=> via { $_->isa('URI') ? $_ : Params::Coerce::coerce( 'URI', $_ ) }
	45	=> from Str
	46	=> via { URI->new( $_, 'http' ) };
	47
	48	subtype Protocol
	49	=> as Str
	50	=> where { /^HTTP\/[0-9]\.[0-9]$/ };
	51
	52
	53	has 'base' => (is => 'rw', isa => 'Uri', coerce => 1);
	54	has 'url' => (is => 'rw', isa => 'Uri', coerce => 1);
	55	has 'method' => (is => 'rw', isa => 'Str');
	56	has 'protocol' => (is => 'rw', isa => 'Protocol');
	57	has 'headers' => (
	58	is => 'rw',
	59	isa => 'Header',
	60	coerce => 1,
	61	default => sub { HTTP::Headers->new }
	62	);
	63
	64	__PACKAGE__->meta->make_immutable(debug => 0);
	65	}
	66
	67	my $r = Request->new;
	68	isa_ok($r, 'Request');
	69
	70	{
	71	my $header = $r->headers;
	72	isa_ok($header, 'HTTP::Headers');
	73
	74	is($r->headers->content_type, '', '... got no content type in the header');
	75
	76	$r->headers( { content_type => 'text/plain' } );
	77
	78	my $header2 = $r->headers;
	79	isa_ok($header2, 'HTTP::Headers');
	80	isnt($header, $header2, '... created a new HTTP::Header object');
	81
	82	is($header2->content_type, 'text/plain', '... got the right content type in the header');
	83
	84	$r->headers( [ content_type => 'text/html' ] );
	85
	86	my $header3 = $r->headers;
	87	isa_ok($header3, 'HTTP::Headers');
	88	isnt($header2, $header3, '... created a new HTTP::Header object');
	89
	90	is($header3->content_type, 'text/html', '... got the right content type in the header');
	91
	92	$r->headers( HTTP::Headers->new(content_type => 'application/pdf') );
	93
	94	my $header4 = $r->headers;
	95	isa_ok($header4, 'HTTP::Headers');
	96	isnt($header3, $header4, '... created a new HTTP::Header object');
	97
	98	is($header4->content_type, 'application/pdf', '... got the right content type in the header');
	99
	100	dies_ok {
	101	$r->headers('Foo')
	102	} '... dies when it gets bad params';
	103	}
	104
	105	{
	106	is($r->protocol, undef, '... got nothing by default');
	107
	108	lives_ok {
	109	$r->protocol('HTTP/1.0');
	110	} '... set the protocol correctly';
	111	is($r->protocol, 'HTTP/1.0', '... got nothing by default');
	112
	113	dies_ok {
	114	$r->protocol('http/1.0');
	115	} '... the protocol died with bar params correctly';
	116	}
	117

+76

-0

t/000_recipes/basics/006_augment_inner.t less more

	0	#!/usr/bin/perl
	1
	2	use strict;
	3	use warnings;
	4
	5	use Test::More tests => 3;
	6	use Test::Exception;
	7
	8	BEGIN {
	9	use_ok('Moose');
	10	}
	11
	12	## Augment/Inner
	13
	14	{
	15	package Document::Page;
	16	use Moose;
	17
	18	has 'body' => (is => 'rw', isa => 'Str', default => sub {''});
	19
	20	sub create {
	21	my $self = shift;
	22	$self->open_page;
	23	inner();
	24	$self->close_page;
	25	}
	26
	27	sub append_body {
	28	my ($self, $appendage) = @_;
	29	$self->body($self->body . $appendage);
	30	}
	31
	32	sub open_page { (shift)->append_body('<page>') }
	33	sub close_page { (shift)->append_body('</page>') }
	34
	35	package Document::PageWithHeadersAndFooters;
	36	use Moose;
	37
	38	extends 'Document::Page';
	39
	40	augment 'create' => sub {
	41	my $self = shift;
	42	$self->create_header;
	43	inner();
	44	$self->create_footer;
	45	};
	46
	47	sub create_header { (shift)->append_body('<header/>') }
	48	sub create_footer { (shift)->append_body('<footer/>') }
	49
	50	package TPSReport;
	51	use Moose;
	52
	53	extends 'Document::PageWithHeadersAndFooters';
	54
	55	augment 'create' => sub {
	56	my $self = shift;
	57	$self->create_tps_report;
	58	};
	59
	60	sub create_tps_report {
	61	(shift)->append_body('<report type="tps"/>')
	62	}
	63	}
	64
	65	my $tps_report = TPSReport->new;
	66	isa_ok($tps_report, 'TPSReport');
	67
	68	is(
	69	$tps_report->create,
	70	q{<page><header/><report type="tps"/><footer/></page>},
	71	'... got the right TPS report');
	72
	73
	74
	75

+204

-0

t/000_recipes/basics/010_genes.t less more

	0	#!/usr/bin/perl
	1
	2	use strict;
	3	use warnings;
	4
	5	{
	6	package Human;
	7
	8	use Moose;
	9	use Moose::Util::TypeConstraints;
	10
	11	subtype 'EyeColor'
	12	=> as 'Object'
	13	=> where { $_->isa('Human::EyeColor') };
	14
	15	coerce 'EyeColor'
	16	=> from 'ArrayRef'
	17	=> via {
	18	return Human::EyeColor->new(
	19	bey2_1 => $_->[0],
	20	bey2_2 => $_->[1],
	21	gey_1 => $_->[2],
	22	gey_2 => $_->[3],
	23	);
	24	};
	25
	26	subtype 'Gender'
	27	=> as 'Str'
	28	=> where { $_ =~ m{^[mf]$}s };
	29
	30	has 'gender' => ( is => 'ro', isa => 'Gender', required => 1 );
	31
	32	has 'eye_color' => ( is => 'ro', isa => 'EyeColor', coerce => 1, required => 1 );
	33
	34	has 'mother' => ( is => 'ro', isa => 'Human' );
	35	has 'father' => ( is => 'ro', isa => 'Human' );
	36
	37	use overload '+' => \&_overload_add, fallback => 1;
	38
	39	sub _overload_add {
	40	my ($one, $two) = @_;
	41
	42	die('Only male and female humans may have children')
	43	if ($one->gender() eq $two->gender());
	44
	45	my ( $mother, $father ) = ( $one->gender eq 'f' ? ($one, $two) : ($two, $one) );
	46
	47	my $gender = 'f';
	48	$gender = 'm' if (rand() >= 0.5);
	49
	50	# Would be better to use Crypt::Random.
	51	#use Crypt::Random qw( makerandom );
	52	#$gender = 'm' if (makerandom( Size => 1, Strength => 1, Uniform => 1 ));
	53
	54	return Human->new(
	55	gender => $gender,
	56	eye_color => ( $one->eye_color() + $two->eye_color() ),
	57	mother => $mother,
	58	father => $father,
	59	);
	60	}
	61	}
	62
	63	{
	64	package Human::EyeColor;
	65
	66	use Moose;
	67	use Moose::Util::TypeConstraints;
	68
	69	subtype 'bey2Gene'
	70	=> as 'Object'
	71	=> where { $_->isa('Human::Gene::bey2') };
	72
	73	coerce 'bey2Gene'
	74	=> from 'Str'
	75	=> via { Human::Gene::bey2->new( color => $_ ) };
	76
	77	subtype 'geyGene'
	78	=> as 'Object'
	79	=> where { $_->isa('Human::Gene::gey') };
	80
	81	coerce 'geyGene'
	82	=> from 'Str'
	83	=> via { Human::Gene::gey->new( color => $_ ) };
	84
	85	has 'bey2_1' => ( is => 'ro', isa => 'bey2Gene', coerce => 1 );
	86	has 'bey2_2' => ( is => 'ro', isa => 'bey2Gene', coerce => 1 );
	87
	88	has 'gey_1' => ( is => 'ro', isa => 'geyGene', coerce => 1 );
	89	has 'gey_2' => ( is => 'ro', isa => 'geyGene', coerce => 1 );
	90
	91	use overload '+' => \&_overload_add, fallback => 1;
	92	use overload '""' => \&color, fallback => 1;
	93
	94	sub color {
	95	my ( $self ) = @_;
	96
	97	return 'brown' if ($self->bey2_1->color() eq 'brown' or $self->bey2_2->color() eq 'brown');
	98	return 'green' if ($self->gey_1->color() eq 'green' or $self->gey_2->color() eq 'green');
	99	return 'blue';
	100	}
	101
	102	sub _overload_add {
	103	my ($one, $two) = @_;
	104
	105	my $one_bey2 = 'bey2_' . _rand2();
	106	my $two_bey2 = 'bey2_' . _rand2();
	107
	108	my $one_gey = 'gey_' . _rand2();
	109	my $two_gey = 'gey_' . _rand2();
	110
	111	return Human::EyeColor->new(
	112	bey2_1 => $one->$one_bey2->color(),
	113	bey2_2 => $two->$two_bey2->color(),
	114	gey_1 => $one->$one_gey->color(),
	115	gey_2 => $two->$two_gey->color(),
	116	);
	117	}
	118
	119	sub _rand2 {
	120	# Would be better to use Crypt::Random.
	121	#use Crypt::Random qw( makerandom );
	122	#return 1 + makerandom( Size => 1, Strength => 1, Uniform => 1 );
	123	return 1 + int( rand(2) );
	124	}
	125	}
	126
	127	{
	128	package Human::Gene::bey2;
	129
	130	use Moose;
	131	use Moose::Util::TypeConstraints;
	132
	133	type 'bey2Color' => where { $_ =~ m{^(?:brown\|blue)$}s };
	134
	135	has 'color' => ( is => 'ro', isa => 'bey2Color' );
	136	}
	137
	138	{
	139	package Human::Gene::gey;
	140
	141	use Moose;
	142	use Moose::Util::TypeConstraints;
	143
	144	type 'geyColor' => where { $_ =~ m{^(?:green\|blue)$}s };
	145
	146	has 'color' => ( is => 'ro', isa => 'geyColor' );
	147	}
	148
	149	use Test::More tests => 10;
	150
	151	my $gene_color_sets = [
	152	[qw( blue blue blue blue ) => 'blue'],
	153	[qw( blue blue green blue ) => 'green'],
	154	[qw( blue blue blue green ) => 'green'],
	155	[qw( blue blue green green ) => 'green'],
	156	[qw( brown blue blue blue ) => 'brown'],
	157	[qw( brown brown green green ) => 'brown'],
	158	[qw( blue brown green blue ) => 'brown'],
	159	];
	160
	161	foreach my $set (@$gene_color_sets) {
	162	my $expected_color = pop( @$set );
	163	my $person = Human->new(
	164	gender => 'f',
	165	eye_color => $set,
	166	);
	167	is(
	168	$person->eye_color(),
	169	$expected_color,
	170	'gene combination '.join(',',@$set).' produces '.$expected_color.' eye color',
	171	);
	172	}
	173
	174	my $parent_sets = [
	175	[ [qw( blue blue blue blue )], [qw( blue blue blue blue )] => 'blue' ],
	176	[ [qw( blue blue blue blue )], [qw( brown brown green blue )] => 'brown' ],
	177	[ [qw( blue blue green green )], [qw( blue blue green green )] => 'green' ],
	178	];
	179
	180	foreach my $set (@$parent_sets) {
	181	my $expected_color = pop( @$set );
	182	my $mother = Human->new(
	183	gender => 'f',
	184	eye_color => shift(@$set),
	185	);
	186	my $father = Human->new(
	187	gender => 'm',
	188	eye_color => shift(@$set),
	189	);
	190	my $child = $mother + $father;
	191	is(
	192	$child->eye_color(),
	193	$expected_color,
	194	'mother '.$mother->eye_color().' + father '.$father->eye_color().' = child '.$expected_color,
	195	);
	196	}
	197
	198	# Hmm, not sure how to test for random selection of genes since
	199	# I could theoretically run an infinite number of iterations and
	200	# never find proof that a child has inherited a particular gene.
	201
	202	# AUTHOR: Aran Clary Deltac <bluefeet@cpan.org>
	203

+80

-0

t/000_recipes/meta/002_meta_attribute.t less more

	0	#!/usr/bin/perl
	1
	2	use strict;
	3	use warnings;
	4
	5	use Test::More tests => 2;
	6	use Test::Exception;
	7
	8	BEGIN {
	9	use_ok('Moose');
	10	}
	11
	12	## meta-attribute example
	13	{
	14
	15	package MyApp::Meta::Attribute::Labeled;
	16	use Moose;
	17	extends 'Moose::Meta::Attribute';
	18
	19	has label => (
	20	is => 'rw',
	21	isa => 'Str',
	22	predicate => 'has_label',
	23	);
	24
	25	package Moose::Meta::Attribute::Custom::Labeled;
	26	sub register_implementation { 'MyApp::Meta::Attribute::Labeled' }
	27
	28	package MyApp::Website;
	29	use Moose;
	30
	31	has url => (
	32	metaclass => 'Labeled',
	33	isa => 'Str',
	34	is => 'rw',
	35	label => "The site's URL",
	36	);
	37
	38	has name => (
	39	is => 'rw',
	40	isa => 'Str',
	41	);
	42
	43	sub dump {
	44	my $self = shift;
	45
	46	my $dump_value = '';
	47
	48	# iterate over all the attributes in $self
	49	my %attributes = %{ $self->meta->get_attribute_map };
	50	foreach my $name (sort keys %attributes) {
	51
	52	my $attribute = $attributes{$name};
	53
	54	# print the label if available
	55	if ($attribute->isa('MyApp::Meta::Attribute::Labeled')
	56	&& $attribute->has_label) {
	57	$dump_value .= $attribute->label;
	58	}
	59	# otherwise print the name
	60	else {
	61	$dump_value .= $name;
	62	}
	63
	64	# print the attribute's value
	65	my $reader = $attribute->get_read_method;
	66	$dump_value .= ": " . $self->$reader . "\n";
	67	}
	68
	69	return $dump_value;
	70	}
	71
	72	}
	73
	74	my $app = MyApp::Website->new(url => "http://google.com", name => "Google");
	75	is($app->dump, q{name: Google
	76	The site's URL: http://google.com
	77	}, '... got the expected dump value');
	78
	79

+139

-0

t/000_recipes/meta/003_attribute_trait.t less more

	0	#!/usr/bin/perl
	1
	2	use strict;
	3	use warnings;
	4
	5	use Test::More tests => 3;
	6	use Test::Exception;
	7
	8	BEGIN {
	9	use_ok('Moose');
	10	}
	11
	12	## attribute trait example
	13	{
	14
	15	package MyApp::Meta::Attribute::Trait::Labeled;
	16	use Moose::Role;
	17
	18	has label => (
	19	is => 'rw',
	20	isa => 'Str',
	21	predicate => 'has_label',
	22	);
	23
	24	package Moose::Meta::Attribute::Custom::Trait::Labeled;
	25	sub register_implementation { 'MyApp::Meta::Attribute::Trait::Labeled' }
	26
	27	package MyApp::Website;
	28	use Moose;
	29
	30	has url => (
	31	traits => [qw/Labeled/],
	32	isa => 'Str',
	33	is => 'rw',
	34	label => "The site's URL",
	35	);
	36
	37	has name => (
	38	is => 'rw',
	39	isa => 'Str',
	40	);
	41
	42	sub dump {
	43	my $self = shift;
	44
	45	my $dump_value = '';
	46
	47	# iterate over all the attributes in $self
	48	my %attributes = %{ $self->meta->get_attribute_map };
	49	foreach my $name (sort keys %attributes) {
	50
	51	my $attribute = $attributes{$name};
	52
	53	# print the label if available
	54	if ($attribute->does('MyApp::Meta::Attribute::Trait::Labeled')
	55	&& $attribute->has_label) {
	56	$dump_value .= $attribute->label;
	57	}
	58	# otherwise print the name
	59	else {
	60	$dump_value .= $name;
	61	}
	62
	63	# print the attribute's value
	64	my $reader = $attribute->get_read_method;
	65	$dump_value .= ": " . $self->$reader . "\n";
	66	}
	67
	68	return $dump_value;
	69	}
	70
	71	}
	72
	73	my $app = MyApp::Website->new(url => "http://google.com", name => "Google");
	74	is($app->dump, q{name: Google
	75	The site's URL: http://google.com
	76	}, '... got the expected dump value');
	77
	78	# using the trait directly in a regular metaclass
	79	{
	80	package MyApp::Meta::Attribute::Labeled;
	81	use Moose;
	82	extends 'Moose::Meta::Attribute';
	83	with 'MyApp::Meta::Attribute::Trait::Labeled';
	84
	85	package Moose::Meta::Attribute::Custom::Labeled;
	86	sub register_implementation { 'MyApp::Meta::Attribute::Labeled' }
	87
	88	package MyApp::Website2;
	89	use Moose;
	90
	91	has url => (
	92	metaclass => 'Labeled',
	93	isa => 'Str',
	94	is => 'rw',
	95	label => "The site's URL",
	96	);
	97
	98	has name => (
	99	is => 'rw',
	100	isa => 'Str',
	101	);
	102
	103	sub dump {
	104	my $self = shift;
	105
	106	my $dump_value = '';
	107
	108	# iterate over all the attributes in $self
	109	my %attributes = %{ $self->meta->get_attribute_map };
	110	foreach my $name (sort keys %attributes) {
	111
	112	my $attribute = $attributes{$name};
	113
	114	# print the label if available
	115	if ($attribute->isa('MyApp::Meta::Attribute::Labeled')
	116	&& $attribute->has_label) {
	117	$dump_value .= $attribute->label;
	118	}
	119	# otherwise print the name
	120	else {
	121	$dump_value .= $name;
	122	}
	123
	124	# print the attribute's value
	125	my $reader = $attribute->get_read_method;
	126	$dump_value .= ": " . $self->$reader . "\n";
	127	}
	128
	129	return $dump_value;
	130	}
	131
	132	}
	133
	134	my $app2 = MyApp::Website2->new(url => "http://google.com", name => "Google");
	135	is($app2->dump, q{name: Google
	136	The site's URL: http://google.com
	137	}, '... got the expected dump value');
	138

+190

-0

t/000_recipes/roles/001_roles.t less more

	0	#!/usr/bin/perl
	1
	2	use strict;
	3	use warnings;
	4
	5	use Test::More tests => 64;
	6	use Test::Exception;
	7
	8	BEGIN {
	9	use_ok('Moose');
	10	}
	11
	12	## Roles
	13
	14	{
	15	package Eq;
	16	use Moose::Role;
	17
	18	requires 'equal_to';
	19
	20	sub not_equal_to {
	21	my ($self, $other) = @_;
	22	not $self->equal_to($other);
	23	}
	24
	25	package Comparable;
	26	use Moose::Role;
	27
	28	with 'Eq';
	29
	30	requires 'compare';
	31
	32	sub equal_to {
	33	my ($self, $other) = @_;
	34	$self->compare($other) == 0;
	35	}
	36
	37	sub greater_than {
	38	my ($self, $other) = @_;
	39	$self->compare($other) == 1;
	40	}
	41
	42	sub less_than {
	43	my ($self, $other) = @_;
	44	$self->compare($other) == -1;
	45	}
	46
	47	sub greater_than_or_equal_to {
	48	my ($self, $other) = @_;
	49	$self->greater_than($other) \|\| $self->equal_to($other);
	50	}
	51
	52	sub less_than_or_equal_to {
	53	my ($self, $other) = @_;
	54	$self->less_than($other) \|\| $self->equal_to($other);
	55	}
	56
	57	package Printable;
	58	use Moose::Role;
	59
	60	requires 'to_string';
	61	}
	62
	63	## Classes
	64
	65	{
	66	package US::Currency;
	67	use Moose;
	68
	69	with 'Comparable', 'Printable';
	70
	71	has 'amount' => (is => 'rw', isa => 'Num', default => 0);
	72
	73	sub compare {
	74	my ($self, $other) = @_;
	75	$self->amount <=> $other->amount;
	76	}
	77
	78	sub to_string {
	79	my $self = shift;
	80	sprintf '$%0.2f USD' => $self->amount
	81	}
	82
	83	__PACKAGE__->meta->make_immutable(debug => 0);
	84	}
	85
	86	ok(US::Currency->does('Comparable'), '... US::Currency does Comparable');
	87	ok(US::Currency->does('Eq'), '... US::Currency does Eq');
	88	ok(US::Currency->does('Printable'), '... US::Currency does Printable');
	89
	90	my $hundred = US::Currency->new(amount => 100.00);
	91	isa_ok($hundred, 'US::Currency');
	92
	93	ok( $hundred->DOES("US::Currency"), "UNIVERSAL::DOES for class" );
	94	ok( $hundred->DOES("Comparable"), "UNIVERSAL::DOES for role" );
	95
	96	can_ok($hundred, 'amount');
	97	is($hundred->amount, 100, '... got the right amount');
	98
	99	can_ok($hundred, 'to_string');
	100	is($hundred->to_string, '$100.00 USD', '... got the right stringified value');
	101
	102	ok($hundred->does('Comparable'), '... US::Currency does Comparable');
	103	ok($hundred->does('Eq'), '... US::Currency does Eq');
	104	ok($hundred->does('Printable'), '... US::Currency does Printable');
	105
	106	my $fifty = US::Currency->new(amount => 50.00);
	107	isa_ok($fifty, 'US::Currency');
	108
	109	can_ok($fifty, 'amount');
	110	is($fifty->amount, 50, '... got the right amount');
	111
	112	can_ok($fifty, 'to_string');
	113	is($fifty->to_string, '$50.00 USD', '... got the right stringified value');
	114
	115	ok($hundred->greater_than($fifty), '... 100 gt 50');
	116	ok($hundred->greater_than_or_equal_to($fifty), '... 100 ge 50');
	117	ok(!$hundred->less_than($fifty), '... !100 lt 50');
	118	ok(!$hundred->less_than_or_equal_to($fifty), '... !100 le 50');
	119	ok(!$hundred->equal_to($fifty), '... !100 eq 50');
	120	ok($hundred->not_equal_to($fifty), '... 100 ne 50');
	121
	122	ok(!$fifty->greater_than($hundred), '... !50 gt 100');
	123	ok(!$fifty->greater_than_or_equal_to($hundred), '... !50 ge 100');
	124	ok($fifty->less_than($hundred), '... 50 lt 100');
	125	ok($fifty->less_than_or_equal_to($hundred), '... 50 le 100');
	126	ok(!$fifty->equal_to($hundred), '... !50 eq 100');
	127	ok($fifty->not_equal_to($hundred), '... 50 ne 100');
	128
	129	ok(!$fifty->greater_than($fifty), '... !50 gt 50');
	130	ok($fifty->greater_than_or_equal_to($fifty), '... !50 ge 50');
	131	ok(!$fifty->less_than($fifty), '... 50 lt 50');
	132	ok($fifty->less_than_or_equal_to($fifty), '... 50 le 50');
	133	ok($fifty->equal_to($fifty), '... 50 eq 50');
	134	ok(!$fifty->not_equal_to($fifty), '... !50 ne 50');
	135
	136	## ... check some meta-stuff
	137
	138	# Eq
	139
	140	my $eq_meta = Eq->meta;
	141	isa_ok($eq_meta, 'Moose::Meta::Role');
	142
	143	ok($eq_meta->has_method('not_equal_to'), '... Eq has_method not_equal_to');
	144	ok($eq_meta->requires_method('equal_to'), '... Eq requires_method not_equal_to');
	145
	146	# Comparable
	147
	148	my $comparable_meta = Comparable->meta;
	149	isa_ok($comparable_meta, 'Moose::Meta::Role');
	150
	151	ok($comparable_meta->does_role('Eq'), '... Comparable does Eq');
	152
	153	foreach my $method_name (qw(
	154	equal_to not_equal_to
	155	greater_than greater_than_or_equal_to
	156	less_than less_than_or_equal_to
	157	)) {
	158	ok($comparable_meta->has_method($method_name), '... Comparable has_method ' . $method_name);
	159	}
	160
	161	ok($comparable_meta->requires_method('compare'), '... Comparable requires_method compare');
	162
	163	# Printable
	164
	165	my $printable_meta = Printable->meta;
	166	isa_ok($printable_meta, 'Moose::Meta::Role');
	167
	168	ok($printable_meta->requires_method('to_string'), '... Printable requires_method to_string');
	169
	170	# US::Currency
	171
	172	my $currency_meta = US::Currency->meta;
	173	isa_ok($currency_meta, 'Moose::Meta::Class');
	174
	175	ok($currency_meta->does_role('Comparable'), '... US::Currency does Comparable');
	176	ok($currency_meta->does_role('Eq'), '... US::Currency does Eq');
	177	ok($currency_meta->does_role('Printable'), '... US::Currency does Printable');
	178
	179	foreach my $method_name (qw(
	180	amount
	181	equal_to not_equal_to
	182	compare
	183	greater_than greater_than_or_equal_to
	184	less_than less_than_or_equal_to
	185	to_string
	186	)) {
	187	ok($currency_meta->has_method($method_name), '... US::Currency has_method ' . $method_name);
	188	}
	189

+98

-0

t/000_recipes/roles/002_advanced_role_composition.t less more

	0	use strict;
	1	use warnings;
	2	use Test::More tests => 5;
	3	use Class::MOP;
	4
	5	# This is copied directly from recipe 11
	6	{
	7	package Restartable;
	8	use Moose::Role;
	9
	10	has 'is_paused' => (
	11	is => 'rw',
	12	isa => 'Bool',
	13	default => 0,
	14	);
	15
	16	requires 'save_state', 'load_state';
	17
	18	sub stop { }
	19
	20	sub start { }
	21
	22	package Restartable::ButUnreliable;
	23	use Moose::Role;
	24
	25	with 'Restartable' => {
	26	alias => {
	27	stop => '_stop',
	28	start => '_start'
	29	}
	30	};
	31
	32	sub stop {
	33	my $self = shift;
	34
	35	$self->explode() if rand(1) > .5;
	36
	37	$self->_stop();
	38	}
	39
	40	sub start {
	41	my $self = shift;
	42
	43	$self->explode() if rand(1) > .5;
	44
	45	$self->_start();
	46	}
	47
	48	package Restartable::ButBroken;
	49	use Moose::Role;
	50
	51	with 'Restartable' => { excludes => [ 'stop', 'start' ] };
	52
	53	sub stop {
	54	my $self = shift;
	55
	56	$self->explode();
	57	}
	58
	59	sub start {
	60	my $self = shift;
	61
	62	$self->explode();
	63	}
	64	}
	65
	66	# This is the actual tests
	67	{
	68	my $unreliable = Moose::Meta::Class->create_anon_class(
	69	superclasses => [],
	70	roles => [qw/Restartable::ButUnreliable/],
	71	methods => {
	72	explode => sub { }, # nop.
	73	'save_state' => sub { },
	74	'load_state' => sub { },
	75	},
	76	)->new_object();
	77	ok $unreliable, 'made anon class with Restartable::ButUnreliable role';
	78	can_ok $unreliable, qw/start stop/;
	79	}
	80
	81	{
	82	my $cnt = 0;
	83	my $broken = Moose::Meta::Class->create_anon_class(
	84	superclasses => [],
	85	roles => [qw/Restartable::ButBroken/],
	86	methods => {
	87	explode => sub { $cnt++ },
	88	'save_state' => sub { },
	89	'load_state' => sub { },
	90	},
	91	)->new_object();
	92	ok $broken, 'made anon class with Restartable::ButBroken role';
	93	$broken->start();
	94	is $cnt, 1, '... start called explode';
	95	$broken->stop();
	96	is $cnt, 2, '... stop also called explode';
	97	}

+78

-0

t/030_roles/019_build.t less more

	0	#!/usr/bin/env perl
	1	use strict;
	2	use warnings;
	3	use Test::More tests => 7;
	4
	5	# this test script ensures that my idiom of:
	6	# role: sub BUILD, after BUILD
	7	# continues to work to run code after object initialization, whether the class
	8	# has a BUILD method or not
	9
	10	BEGIN {
	11	use_ok('Moose::Role');
	12	}
	13
	14	my @CALLS;
	15
	16	do {
	17	package TestRole;
	18	use Moose::Role;
	19
	20	sub BUILD { push @CALLS, 'TestRole::BUILD' }
	21	before BUILD => sub { push @CALLS, 'TestRole::BUILD:before' };
	22	after BUILD => sub { push @CALLS, 'TestRole::BUILD:after' };
	23	};
	24
	25	do {
	26	package ClassWithBUILD;
	27	use Moose;
	28	with 'TestRole';
	29
	30	sub BUILD { push @CALLS, 'ClassWithBUILD::BUILD' }
	31	};
	32
	33	do {
	34	package ClassWithoutBUILD;
	35	use Moose;
	36	with 'TestRole';
	37	};
	38
	39	is_deeply([splice @CALLS], [], "no calls to BUILD yet");
	40
	41	ClassWithBUILD->new;
	42
	43	is_deeply([splice @CALLS], [
	44	'TestRole::BUILD:before',
	45	'ClassWithBUILD::BUILD',
	46	'TestRole::BUILD:after',
	47	]);
	48
	49	ClassWithoutBUILD->new;
	50
	51	is_deeply([splice @CALLS], [
	52	'TestRole::BUILD:before',
	53	'TestRole::BUILD',
	54	'TestRole::BUILD:after',
	55	]);
	56
	57	ClassWithBUILD->meta->make_immutable;
	58	ClassWithoutBUILD->meta->make_immutable;
	59
	60	is_deeply([splice @CALLS], [], "no calls to BUILD yet");
	61
	62	ClassWithBUILD->new;
	63
	64	is_deeply([splice @CALLS], [
	65	'TestRole::BUILD:before',
	66	'ClassWithBUILD::BUILD',
	67	'TestRole::BUILD:after',
	68	]);
	69
	70	ClassWithoutBUILD->new;
	71
	72	is_deeply([splice @CALLS], [
	73	'TestRole::BUILD:before',
	74	'TestRole::BUILD',
	75	'TestRole::BUILD:after',
	76	]);
	77

+49

-34

t/040_type_constraints/005_util_type_coercion.t less more

2	2	use strict;
3	3	use warnings;
4	4
5		use Test::More tests => 14;
	5	use Test::More tests => 24;
6	6	use Test::Exception;
7	7
8	8	BEGIN {

37	37	ok(!Header([]), '... this did not pass the type test');
38	38	ok(!Header({}), '... this did not pass the type test');
39	39
40		my $coercion = find_type_constraint('Header')->coercion;
41		isa_ok($coercion, 'Moose::Meta::TypeCoercion');
	40	my $anon_type = subtype Object => where { $_->isa('HTTPHeader') };
42	41
43		{
44		my $coerced = $coercion->coerce([ 1, 2, 3 ]);
45		isa_ok($coerced, 'HTTPHeader');
	42	lives_ok {
	43	coerce $anon_type
	44	=> from ArrayRef
	45	=> via { HTTPHeader->new(array => $_[0]) }
	46	=> from HashRef
	47	=> via { HTTPHeader->new(hash => $_[0]) };
	48	} 'coercion of anonymous subtype succeeds';
46	49
47		is_deeply(
48		$coerced->array(),
49		[ 1, 2, 3 ],
50		'... got the right array');
51		is($coerced->hash(), undef, '... nothing assigned to the hash');
	50	foreach my $coercion (
	51	find_type_constraint('Header')->coercion,
	52	$anon_type->coercion
	53	) {
	54
	55	my $coercion = find_type_constraint('Header')->coercion;
	56	isa_ok($coercion, 'Moose::Meta::TypeCoercion');
	57
	58	{
	59	my $coerced = $coercion->coerce([ 1, 2, 3 ]);
	60	isa_ok($coerced, 'HTTPHeader');
	61
	62	is_deeply(
	63	$coerced->array(),
	64	[ 1, 2, 3 ],
	65	'... got the right array');
	66	is($coerced->hash(), undef, '... nothing assigned to the hash');
	67	}
	68
	69	{
	70	my $coerced = $coercion->coerce({ one => 1, two => 2, three => 3 });
	71	isa_ok($coerced, 'HTTPHeader');
	72
	73	is_deeply(
	74	$coerced->hash(),
	75	{ one => 1, two => 2, three => 3 },
	76	'... got the right hash');
	77	is($coerced->array(), undef, '... nothing assigned to the array');
	78	}
	79
	80	{
	81	my $scalar_ref = \(my $var);
	82	my $coerced = $coercion->coerce($scalar_ref);
	83	is($coerced, $scalar_ref, '... got back what we put in');
	84	}
	85
	86	{
	87	my $coerced = $coercion->coerce("Foo");
	88	is($coerced, "Foo", '... got back what we put in');
	89	}
52	90	}
53
54		{
55		my $coerced = $coercion->coerce({ one => 1, two => 2, three => 3 });
56		isa_ok($coerced, 'HTTPHeader');
57
58		is_deeply(
59		$coerced->hash(),
60		{ one => 1, two => 2, three => 3 },
61		'... got the right hash');
62		is($coerced->array(), undef, '... nothing assigned to the array');
63		}
64
65		{
66		my $scalar_ref = \(my $var);
67		my $coerced = $coercion->coerce($scalar_ref);
68		is($coerced, $scalar_ref, '... got back what we put in');
69		}
70
71		{
72		my $coerced = $coercion->coerce("Foo");
73		is($coerced, "Foo", '... got back what we put in');
74		}
75

+70

-0

t/100_bugs/017_type_constraint_messages.t less more

	0	#!/usr/bin/perl
	1
	2	use strict;
	3	use warnings;
	4
	5	use Test::More no_plan => 1;
	6	use Test::Exception;
	7
	8	BEGIN {
	9	use_ok('Moose');
	10	}
	11
	12	# RT #37569
	13
	14	{
	15	package MyObject;
	16	use Moose;
	17
	18	package Foo;
	19	use Moose;
	20	use Moose::Util::TypeConstraints;
	21
	22	subtype 'MyArrayRef'
	23	=> as 'ArrayRef'
	24	=> where { defined $_->[0] }
	25	=> message { ref $_ ? "ref: ". ref $_ : 'scalar' } # stringy
	26	;
	27
	28	subtype 'MyObjectType'
	29	=> as 'Object'
	30	=> where { $_->isa('MyObject') }
	31	=> message {
	32	if ( $_->isa('SomeObject') ) {
	33	return 'More detailed error message';
	34	}
	35	elsif ( blessed $_ ) {
	36	return 'Well it is an object';
	37	}
	38	else {
	39	return 'Doh!';
	40	}
	41	}
	42	;
	43
	44	type 'NewType'
	45	=> where { $_->isa('MyObject') }
	46	=> message { blessed $_ ? 'blessed' : 'scalar' }
	47	;
	48
	49	has 'obj' => ( is => 'rw', isa => 'MyObjectType' );
	50	has 'ar' => ( is => 'rw', isa => 'MyArrayRef' );
	51	has 'nt' => ( is => 'rw', isa => 'NewType' );
	52	}
	53
	54	my $foo = Foo->new;
	55	my $obj = MyObject->new;
	56
	57	throws_ok {
	58	$foo->ar([]);
	59	} qr/Attribute $ar$ does not pass the type constraint because: ref: ARRAY/, '... got the right error message';
	60
	61	throws_ok {
	62	$foo->obj($foo); # Doh!
	63	} qr/Attribute $obj$ does not pass the type constraint because: Well it is an object/, '... got the right error message';
	64
	65	throws_ok {
	66	$foo->nt($foo); # scalar
	67	} qr/Attribute $nt$ does not pass the type constraint because: blessed/, '... got the right error message';
	68
	69

+94

-0

t/100_bugs/018_immutable_metaclass_does_role.t less more

	0	#!/usr/bin/perl
	1
	2	use strict;
	3	use warnings;
	4
	5	use Test::More tests => 37;
	6	use Test::Exception;
	7
	8	BEGIN {
	9	use_ok('Moose');
	10	}
	11
	12	BEGIN {
	13	package MyRole;
	14	use Moose::Role;
	15
	16	requires 'foo';
	17
	18	package MyMetaclass;
	19	use Moose qw(extends with);
	20	extends 'Moose::Meta::Class';
	21	with 'MyRole';
	22
	23	sub foo { 'i am foo' }
	24	}
	25
	26	{
	27	package MyClass;
	28	use metaclass ('MyMetaclass');
	29	use Moose;
	30	}
	31
	32	my $mc = MyMetaclass->initialize('MyClass');
	33	isa_ok($mc, 'MyMetaclass');
	34
	35	ok($mc->meta->does_role('MyRole'), '... the metaclass does the role');
	36
	37	is(MyClass->meta, $mc, '... these metas are the same thing');
	38	is(MyClass->meta->meta, $mc->meta, '... these meta-metas are the same thing');
	39
	40	my $a = MyClass->new;
	41	ok( $a->meta->meta->does_role('MyRole'), 'metaclass does MyRole' );
	42	is( $a->meta->foo, 'i am foo', '... foo method returns expected value' );
	43	ok( MyClass->meta->meta->does_role('MyRole'), 'metaclass does MyRole' );
	44	is( MyClass->meta->foo, 'i am foo', '... foo method returns expected value' );
	45
	46	lives_ok {
	47	MyClass->meta->make_immutable;
	48	} '... make MyClass immutable okay';
	49
	50	is(MyClass->meta, $mc, '... these metas are still the same thing');
	51	is(MyClass->meta->meta, $mc->meta, '... these meta-metas are the same thing');
	52
	53	ok( $a->meta->meta->does_role('MyRole'), 'metaclass does MyRole' );
	54	is( $a->meta->foo, 'i am foo', '... foo method returns expected value' );
	55	ok( MyClass->meta->meta->does_role('MyRole'), 'metaclass does MyRole' );
	56	is( MyClass->meta->foo, 'i am foo', '... foo method returns expected value' );
	57
	58	lives_ok {
	59	MyClass->meta->make_mutable;
	60	} '... make MyClass mutable okay';
	61
	62	is(MyClass->meta, $mc, '... these metas are still the same thing');
	63	is(MyClass->meta->meta, $mc->meta, '... these meta-metas are the same thing');
	64
	65	ok( $a->meta->meta->does_role('MyRole'), 'metaclass does MyRole' );
	66	is( $a->meta->foo, 'i am foo', '... foo method returns expected value' );
	67	ok( MyClass->meta->meta->does_role('MyRole'), 'metaclass does MyRole' );
	68	is( MyClass->meta->foo, 'i am foo', '... foo method returns expected value' );
	69
	70	lives_ok {
	71	MyMetaclass->meta->make_immutable;
	72	} '... make MyClass immutable okay';
	73
	74	is(MyClass->meta, $mc, '... these metas are still the same thing');
	75	is(MyClass->meta->meta, $mc->meta, '... these meta-metas are the same thing');
	76
	77	ok( $a->meta->meta->does_role('MyRole'), 'metaclass does MyRole' );
	78	is( $a->meta->foo, 'i am foo', '... foo method returns expected value' );
	79	ok( MyClass->meta->meta->does_role('MyRole'), 'metaclass does MyRole' );
	80	is( MyClass->meta->foo, 'i am foo', '... foo method returns expected value' );
	81
	82	lives_ok {
	83	MyClass->meta->make_immutable;
	84	} '... make MyClass immutable okay';
	85
	86	is(MyClass->meta, $mc, '... these metas are still the same thing');
	87	is(MyClass->meta->meta, $mc->meta, '... these meta-metas are the same thing');
	88
	89	ok( $a->meta->meta->does_role('MyRole'), 'metaclass does MyRole' );
	90	is( $a->meta->foo, 'i am foo', '... foo method returns expected value' );
	91	ok( MyClass->meta->meta->does_role('MyRole'), 'metaclass does MyRole' );
	92	is( MyClass->meta->foo, 'i am foo', '... foo method returns expected value' );
	93

+33

-0

t/600_todo_tests/001_exception_reflects_failed_constraint.t less more

	0	#!/usr/bin/perl
	1
	2	# In the case where a child type constraint's parent constraint fails,
	3	# the exception should reference the parent type constraint that actually
	4	# failed instead of always referencing the child'd type constraint
	5
	6	use strict;
	7	use warnings;
	8
	9	use Test::More tests => 4;
	10	use Test::Exception;
	11
	12	BEGIN {
	13	use_ok('Moose::Util::TypeConstraints');
	14	}
	15
	16	lives_ok {
	17	subtype 'ParentConstraint' => as 'Str' => where {0};
	18	} 'specified parent type constraint';
	19
	20	my $tc;
	21	lives_ok {
	22	$tc = subtype 'ChildConstraint' => as 'ParentConstraint' => where {1};
	23	} 'specified child type constraint';
	24
	25	{
	26	my $errmsg = $tc->validate();
	27
	28	TODO: {
	29	local $TODO = 'Not yet supported';
	30	ok($errmsg !~ /Validation failed for 'ChildConstraint'/, 'exception references failing parent constraint');
	31	};
	32	}

+286

-0

t/600_todo_tests/002_various_role_shit.t less more

	0	#!/usr/bin/perl
	1
	2	use strict;
	3	use warnings;
	4
	5	use Test::More 'no_plan';
	6	use Test::Exception;
	7
	8	sub req_or_has ($$) {
	9	my ( $role, $method ) = @_;
	10	local $Test::Builder::Level = $Test::Builder::Level + 1;
	11	if ( $role ) {
	12	ok(
	13	$role->has_method($method) \|\| $role->requires_method($method),
	14	$role->name . " has or requires method $method"
	15	);
	16	} else {
	17	fail("role has or requires method $method");
	18	}
	19	}
	20
	21	{
	22	package Bar;
	23	use Moose::Role;
	24
	25	# this role eventually adds three methods, qw(foo bar xxy), but only one is
	26	# known when it's still a role
	27
	28	has foo => ( is => "rw" );
	29
	30	has gorch => ( reader => "bar" );
	31
	32	sub xxy { "BAAAD" }
	33
	34	package Gorch;
	35	use Moose::Role;
	36
	37	# similarly this role gives attr and gorch_method
	38
	39	has attr => ( is => "rw" );
	40
	41	sub gorch_method { "gorch method" }
	42
	43	around dandy => sub { shift->(@_) . "bar" };
	44
	45	package Quxx;
	46	use Moose;
	47
	48	sub dandy { "foo" }
	49
	50	# this object will be used in an attr of Foo to test that Foo can do the
	51	# Gorch interface
	52
	53	with qw(Gorch);
	54
	55	package Dancer;
	56	use Moose::Role;
	57
	58	requires "twist";
	59
	60	package Dancer::Ballerina;
	61	use Moose;
	62
	63	with qw(Dancer);
	64
	65	sub twist { }
	66
	67	sub pirouette { }
	68
	69	package Dancer::Robot;
	70	use Moose::Role;
	71
	72	# this doesn't fail but it produces a requires in the role
	73	# the order doesn't matter
	74	has twist => ( is => "rw" );
	75	::lives_ok { with qw(Dancer) };
	76
	77	package Dancer::Something;
	78	use Moose;
	79
	80	# this fail even though the method already exists
	81
	82	has twist => ( is => "rw" );
	83
	84	{
	85	local our $TODO = "accessors don't satisfy role requires";
	86	::lives_ok { with qw(Dancer) };
	87	}
	88
	89	package Dancer::80s;
	90	use Moose;
	91
	92	# this should pass because ::Robot has the attribute to fill in the requires
	93	# but due to the deferrence logic that doesn't actually work
	94	{
	95	local our $TODO = "attribute accessor in role doesn't satisfy role requires";
	96	::lives_ok { with qw(Dancer::Robot) };
	97	}
	98
	99	package Foo;
	100	use Moose;
	101
	102	with qw(Bar);
	103
	104	has oink => (
	105	is => "rw",
	106	handles => "Gorch", # should handles take the same arguments as 'with'? Meta::Role::Application::Delegation?
	107	default => sub { Quxx->new },
	108	);
	109
	110	has dancer => (
	111	is => "rw",
	112	does => "Dancer",
	113	handles => "Dancer",
	114	default => sub { Dancer::Ballerina->new },
	115	);
	116
	117	sub foo { 42 }
	118
	119	sub bar { 33 }
	120
	121	sub xxy { 7 }
	122
	123	package Tree;
	124	use Moose::Role;
	125
	126	has bark => ( is => "rw" );
	127
	128	package Dog;
	129	use Moose::Role;
	130
	131	sub bark { warn "woof!" };
	132
	133	package EntPuppy;
	134	use Moose;
	135
	136	{
	137	local our $TODO = "attrs and methods from a role should clash";
	138	::dies_ok { with qw(Tree Dog) }
	139	}
	140	}
	141
	142	# these fail because of the deferral logic winning over actual methods
	143	# this might be tricky to fix due to the 'sub foo {}; has foo => ( )' hack
	144	# we've been doing for a long while, though I doubt people relied on it for
	145	# anything other than fulfilling 'requires'
	146	{
	147	local $TODO = "attributes from role overwrite class methods";
	148	is( Foo->new->foo, 42, "attr did not zap overriding method" );
	149	is( Foo->new->bar, 33, "attr did not zap overriding method" );
	150	}
	151	is( Foo->new->xxy, 7, "method did not zap overriding method" ); # duh
	152
	153	# these pass, simple delegate
	154	# mostly they are here to contrast the next blck
	155	can_ok( Foo->new->oink, "dandy" );
	156	can_ok( Foo->new->oink, "attr" );
	157	can_ok( Foo->new->oink, "gorch_method" );
	158
	159	ok( Foo->new->oink->does("Gorch"), "Quxx does Gorch" );
	160
	161
	162	# these are broken because 'attr' is not technically part of the interface
	163	can_ok( Foo->new, "gorch_method" );
	164	{
	165	local $TODO = "accessor methods from a role are omitted in handles role";
	166	can_ok( Foo->new, "attr" );
	167	}
	168
	169	{
	170	local $TODO = "handles role doesn't add the role to the ->does of the delegate's parent class";
	171	ok( Foo->new->does("Gorch"), "Foo does Gorch" );
	172	}
	173
	174
	175	# these work
	176	can_ok( Foo->new->dancer, "pirouette" );
	177	can_ok( Foo->new->dancer, "twist" );
	178
	179	can_ok( Foo->new, "twist" );
	180	ok( !Foo->new->can("pirouette"), "can't pirouette, not part of the iface" );
	181
	182	{
	183	local $TODO = "handles role doesn't add the role to the ->does of the delegate's parent class";
	184	ok( Foo->new->does("Dancer") );
	185	}
	186
	187
	188
	189
	190	my $gorch = Gorch->meta;
	191
	192	isa_ok( $gorch, "Moose::Meta::Role" );
	193
	194	ok( $gorch->has_attribute("attr"), "has attribute 'attr'" );
	195
	196	{
	197	local $TODO = "role attribute isn't a meta attribute yet";
	198	isa_ok( $gorch->get_attribute("attr"), "Moose::Meta::Attribute" );
	199	}
	200
	201	req_or_has($gorch, "gorch_method");
	202	ok( $gorch->has_method("gorch_method"), "has_method gorch_method" );
	203	ok( !$gorch->requires_method("gorch_method"), "requires gorch method" );
	204
	205	{
	206	local $TODO = "role method isn't a meta object yet";
	207	isa_ok( $gorch->get_method("gorch_method"), "Moose::Meta::Method" );
	208	}
	209
	210	{
	211	local $TODO = "method modifier doesn't yet create a method requirement or meta object";
	212	req_or_has($gorch, "dandy" );
	213
	214	# this specific test is maybe not backwards compat, but in theory it does
	215	# require that method to exist
	216	ok( $gorch->requires_method("dandy"), "requires the dandy method for the modifier" );
	217	}
	218
	219	{
	220	local $TODO = "attribute related methods are not yet known by the role";
	221	# we want this to be a part of the interface, somehow
	222	req_or_has($gorch, "attr");
	223	ok( $gorch->has_method("attr"), "has_method attr" );
	224	isa_ok( $gorch->get_method("attr"), "Moose::Meta::Method" );
	225	isa_ok( $gorch->get_method("attr"), "Moose::Meta::Method::Accessor" );
	226	}
	227
	228	my $robot = Dancer::Robot->meta;
	229
	230	isa_ok( $robot, "Moose::Meta::Role" );
	231
	232	ok( $robot->has_attribute("twist"), "has attr 'twist'" );
	233
	234	{
	235	local $TODO = "role attribute isn't a meta attribute yet";
	236	isa_ok( $robot->get_attribute("twist"), "Moose::Meta::Attribute" );
	237	}
	238
	239	{
	240	req_or_has($robot, "twist");
	241
	242	local $TODO = "attribute related methods are not yet known by the role";
	243	ok( $robot->has_method("twist"), "has twist method" );
	244	isa_ok( $robot->get_method("twist"), "Moose::Meta::Method" );
	245	isa_ok( $robot->get_method("twist"), "Moose::Meta::Method::Accessor" );
	246	}
	247
	248	__END__
	249
	250	I think Attribute needs to be refactored in some way to better support roles.
	251
	252	There are several possible ways to do this, all of them seem plausible to me.
	253
	254	The first approach would be to change the attribute class to allow it to be
	255	queried about the methods it would install.
	256
	257	Then we instantiate the attribute in the role, and instead of deferring the
	258	arguments, we just make an C<unpack>ish method.
	259
	260	Then we can interrogate the attr when adding it to the role, and generate stub
	261	methods for all the methods it would produce.
	262
	263	A second approach is kinda like the Immutable hack: wrap the attr in an
	264	anonmyous class that disables part of its interface.
	265
	266	A third method would be to create an Attribute::Partial object that would
	267	provide a more role-ish behavior, and to do this independently of the actual
	268	Attribute class.
	269
	270	Something similar can be done for method modifiers, but I think that's even simpler.
	271
	272
	273
	274	The benefits of doing this are:
	275
	276	* Much better introspection of roles
	277
	278	* More correctness in many cases (in my opinion anyway)
	279
	280	* More roles are more usable as interface declarations, without having to split
	281	them into two pieces (one for the interface with a bunch of requires(), and
	282	another for the actual impl with the problematic attrs (and stub methods to
	283	fix the accessors) and method modifiers (dunno if this can even work at all)
	284
	285

+54

-0

t/600_todo_tests/003_immutable_n_around.t less more

	0	#!/usr/bin/perl
	1
	2	use strict;
	3	use warnings;
	4
	5	use Test::More 'no_plan';
	6
	7	# if make_immutable is removed from the following code the tests pass
	8
	9	{
	10	package Foo;
	11	use Moose;
	12
	13	has foo => ( is => "ro" );
	14
	15	package Bar;
	16	use Moose;
	17
	18	extends qw(Foo);
	19
	20	around new => sub {
	21	my $next = shift;
	22	my ( $self, @args ) = @_;
	23	$self->$next( foo => 42 );
	24	};
	25
	26	package Gorch;
	27	use Moose;
	28
	29	extends qw(Bar);
	30
	31	package Zoink;
	32	use Moose;
	33
	34	extends qw(Gorch);
	35
	36	}
	37
	38	my @classes = qw(Foo Bar Gorch Zoink);
	39
	40	tests: {
	41	TODO: {
	42	is( Foo->new->foo, undef, "base class (" . (Foo->meta->is_immutable ? "immutable" : "mutable") . ")" );
	43	is( Bar->new->foo, 42, "around new called on Bar->new (" . (Bar->meta->is_immutable ? "immutable" : "mutable") . ")" );
	44	local $TODO = 'these tests fail once Gorch is immutable' if Gorch->meta->is_immutable;
	45	is( Gorch->new->foo, 42, "around new called on Gorch->new (" . (Gorch->meta->is_immutable ? "immutable" : "mutable") . ")" );
	46	is( Zoink->new->foo, 42, "around new called Zoink->new (" . (Zoink->meta->is_immutable ? "immutable" : "mutable") . ")" );
	47	}
	48
	49	if ( @classes ) {
	50	( shift @classes )->meta->make_immutable;
	51	redo tests;
	52	}
	53	}

+48

-0

t/600_todo_tests/004_inlined_constructor_modified_new.t less more

	0	#!/usr/bin/perl
	1
	2	use strict;
	3	use warnings;
	4
	5	use Test::More tests => 6;
	6
	7	my ($around_new);
	8	{
	9	package Foo;
	10	use Moose;
	11
	12	around new => sub { my $o = shift; $around_new = 1; $o->(@_); };
	13	has 'foo' => (is => 'rw', isa => 'Int');
	14
	15	package Bar;
	16	use Moose;
	17	extends 'Foo';
	18	Bar->meta->make_immutable;
	19	}
	20
	21	my $orig_new = Foo->meta->find_method_by_name('new');
	22	isa_ok($orig_new, 'Class::MOP::Method::Wrapped');
	23	$orig_new = $orig_new->get_original_method;
	24	isa_ok($orig_new, 'Moose::Meta::Method');
	25
	26	Foo->meta->make_immutable(debug => 0);
	27	my $inlined_new = Foo->meta->find_method_by_name('new');
	28	isa_ok($inlined_new, 'Class::MOP::Method::Wrapped');
	29	$inlined_new = $inlined_new->get_original_method;
	30
	31	TODO:
	32	{
	33	local $TODO = 'but it isa Moose::Meta::Method instead';
	34	isa_ok($inlined_new, 'Moose::Meta::Method::Constructor');
	35	}
	36
	37	Foo->new(foo => 100);
	38	ok($around_new, 'around new called');
	39
	40	$around_new = 0;
	41	Bar->new(foo => 100);
	42
	43	TODO:
	44	{
	45	local $TODO = 'but it is not called';
	46	ok($around_new, 'around new called');
	47	}

+46

-0

t/600_todo_tests/005_moose_and_threads.t less more

	0	#!/usr/bin/perl
	1
	2	use strict;
	3	use warnings;
	4
	5	use Test::More no_plan => 1;
	6	use Test::Exception;
	7
	8	BEGIN {
	9	use_ok('Moose');
	10	}
	11
	12	=pod
	13
	14	See this for some details:
	15
	16	http://bugs.debian.org/cgi-bin/bugreport.cgi?bug=476579
	17
	18	Here is the basic test case, it segfaults, so I am going
	19	to leave it commented out. Basically it seems that there
	20	is some bad interaction between the ??{} construct that
	21	is used in the "parser" for type definitions and threading
	22	so probably the fix would involve removing the ??{} usage
	23	for something else.
	24
	25	use threads;
	26
	27	{
	28	package Foo;
	29	use Moose;
	30	has "bar" => (is => 'rw', isa => "Str \| Num");
	31	}
	32
	33	my $thr = threads->create(sub {});
	34	$thr->join();
	35
	36	=cut
	37
	38	{
	39	local $TODO = 'This is just a stub for the test, see the POD';
	40	fail('Moose type constraints and threads dont get along');
	41	}
	42
	43
	44
	45