Checking in changes prior to tagging of version 0.45. Changelog diff is:
[gitmo/Mouse.git] / lib / Mouse / PurePerl.pm
CommitLineData
ccb38d0b 1package Mouse::PurePerl;
2
a52cca04 3require Mouse::Util;
4
df6dd016 5package
6 Mouse::Util;
7
8use strict;
9use warnings;
10
11use warnings FATAL => 'redefine'; # to avoid to load Mouse::PurePerl
12
13use B ();
14
15sub is_class_loaded {
16 my $class = shift;
17
18 return 0 if ref($class) || !defined($class) || !length($class);
19
20 # walk the symbol table tree to avoid autovififying
3bb9e54e 21 # \*{${main::}{"Foo::"}{"Bar::"}} == \*main::Foo::Bar::
df6dd016 22
23 my $pack = \%::;
24 foreach my $part (split('::', $class)) {
3bb9e54e 25 $part .= '::';
26 return 0 if !exists $pack->{$part};
27
28 my $entry = \$pack->{$part};
df6dd016 29 return 0 if ref($entry) ne 'GLOB';
3bb9e54e 30 $pack = *{$entry}{HASH};
df6dd016 31 }
32
3bb9e54e 33 return 0 if !%{$pack};
34
df6dd016 35 # check for $VERSION or @ISA
36 return 1 if exists $pack->{VERSION}
37 && defined *{$pack->{VERSION}}{SCALAR} && defined ${ $pack->{VERSION} };
38 return 1 if exists $pack->{ISA}
39 && defined *{$pack->{ISA}}{ARRAY} && @{ $pack->{ISA} } != 0;
40
41 # check for any method
42 foreach my $name( keys %{$pack} ) {
43 my $entry = \$pack->{$name};
44 return 1 if ref($entry) ne 'GLOB' || defined *{$entry}{CODE};
45 }
46
47 # fail
48 return 0;
49}
50
51
52# taken from Sub::Identify
53sub get_code_info {
54 my ($coderef) = @_;
55 ref($coderef) or return;
56
57 my $cv = B::svref_2object($coderef);
58 $cv->isa('B::CV') or return;
59
60 my $gv = $cv->GV;
61 $gv->isa('B::GV') or return;
62
63 return ($gv->STASH->NAME, $gv->NAME);
64}
65
66sub get_code_package{
67 my($coderef) = @_;
68
69 my $cv = B::svref_2object($coderef);
70 $cv->isa('B::CV') or return '';
71
72 my $gv = $cv->GV;
73 $gv->isa('B::GV') or return '';
74
75 return $gv->STASH->NAME;
76}
77
7d96ae4d 78sub get_code_ref{
79 my($package, $name) = @_;
80 no strict 'refs';
81 no warnings 'once';
82 use warnings FATAL => 'uninitialized';
83 return *{$package . '::' . $name}{CODE};
84}
85
e3540312 86sub generate_isa_predicate_for {
1d5ecd5f 87 my($for_class, $name) = @_;
88
f48920c1 89 my $predicate = sub{ Scalar::Util::blessed($_[0]) && $_[0]->isa($for_class) };
1d5ecd5f 90
91 if(defined $name){
92 no strict 'refs';
93 *{ caller() . '::' . $name } = $predicate;
94 return;
95 }
96
97 return $predicate;
98}
99
ebe91068 100sub generate_can_predicate_for {
101 my($methods_ref, $name) = @_;
102
103 my @methods = @{$methods_ref};
104
105 my $predicate = sub{
106 my($instance) = @_;
107 if(Scalar::Util::blessed($instance)){
108 foreach my $method(@methods){
109 if(!$instance->can($method)){
110 return 0;
111 }
112 }
113 return 1;
114 }
115 return 0;
116 };
117
118 if(defined $name){
119 no strict 'refs';
120 *{ caller() . '::' . $name } = $predicate;
121 return;
122 }
123
124 return $predicate;
125}
1d5ecd5f 126
f48920c1 127package
128 Mouse::Util::TypeConstraints;
129
130use Scalar::Util qw(blessed looks_like_number openhandle);
131
7d96ae4d 132sub Any { 1 }
133sub Item { 1 }
7d96ae4d 134
135sub Bool { $_[0] ? $_[0] eq '1' : 1 }
136sub Undef { !defined($_[0]) }
137sub Defined { defined($_[0]) }
138sub Value { defined($_[0]) && !ref($_[0]) }
139sub Num { !ref($_[0]) && looks_like_number($_[0]) }
140sub Int { defined($_[0]) && !ref($_[0]) && $_[0] =~ /^-?[0-9]+$/ }
141sub Str { defined($_[0]) && !ref($_[0]) }
142
143sub Ref { ref($_[0]) }
144sub ScalarRef { ref($_[0]) eq 'SCALAR' }
145sub ArrayRef { ref($_[0]) eq 'ARRAY' }
146sub HashRef { ref($_[0]) eq 'HASH' }
147sub CodeRef { ref($_[0]) eq 'CODE' }
148sub RegexpRef { ref($_[0]) eq 'Regexp' }
149sub GlobRef { ref($_[0]) eq 'GLOB' }
150
151sub FileHandle {
152 openhandle($_[0]) || (blessed($_[0]) && $_[0]->isa("IO::Handle"))
153}
154
155sub Object { blessed($_[0]) && blessed($_[0]) ne 'Regexp' }
156
157sub ClassName { Mouse::Util::is_class_loaded($_[0]) }
158sub RoleName { (Mouse::Util::class_of($_[0]) || return 0)->isa('Mouse::Meta::Role') }
159
619338ac 160sub _parameterize_ArrayRef_for {
161 my($type_parameter) = @_;
162 my $check = $type_parameter->_compiled_type_constraint;
163
164 return sub {
165 foreach my $value (@{$_}) {
166 return undef unless $check->($value);
167 }
168 return 1;
169 }
170}
171
172sub _parameterize_HashRef_for {
173 my($type_parameter) = @_;
174 my $check = $type_parameter->_compiled_type_constraint;
175
176 return sub {
177 foreach my $value(values %{$_}){
178 return undef unless $check->($value);
179 }
180 return 1;
181 };
182}
183
184# 'Maybe' type accepts 'Any', so it requires parameters
185sub _parameterize_Maybe_for {
186 my($type_parameter) = @_;
187 my $check = $type_parameter->_compiled_type_constraint;
188
189 return sub{
190 return !defined($_) || $check->($_);
191 };
192};
193
194
7d96ae4d 195
43165725 196package
197 Mouse::Meta::Module;
198
926404f2 199sub name { $_[0]->{package} }
200
201sub _method_map { $_[0]->{methods} }
c5f6ad05 202sub _attribute_map{ $_[0]->{attributes} }
43165725 203
2591e962 204sub namespace{
205 my $name = $_[0]->{package};
206 no strict 'refs';
207 return \%{ $name . '::' };
208}
209
3e44140b 210sub add_method {
211 my($self, $name, $code) = @_;
212
213 if(!defined $name){
214 $self->throw_error('You must pass a defined name');
215 }
216 if(!defined $code){
217 $self->throw_error('You must pass a defined code');
218 }
219
220 if(ref($code) ne 'CODE'){
221 $code = \&{$code}; # coerce
222 }
223
224 $self->{methods}->{$name} = $code; # Moose stores meta object here.
225
226 my $pkg = $self->name;
227 no strict 'refs';
228 no warnings 'redefine', 'once';
229 *{ $pkg . '::' . $name } = $code;
230 return;
231}
232
43165725 233package
234 Mouse::Meta::Class;
235
e058b279 236sub method_metaclass { $_[0]->{method_metaclass} || 'Mouse::Meta::Method' }
237sub attribute_metaclass { $_[0]->{attribute_metaclass} || 'Mouse::Meta::Attribute' }
238
239sub constructor_class { $_[0]->{constructor_class} || 'Mouse::Meta::Method::Constructor' }
240sub destructor_class { $_[0]->{destructor_class} || 'Mouse::Meta::Method::Destructor' }
4e7e3250 241
43165725 242sub is_anon_class{
243 return exists $_[0]->{anon_serial_id};
244}
245
246sub roles { $_[0]->{roles} }
247
cccb83de 248sub linearized_isa { @{ get_linear_isa($_[0]->{package}) } }
249
da4432f3 250sub get_all_attributes {
251 my($self) = @_;
047d7af0 252 my %attrs = map { %{ $self->initialize($_)->{attributes} } } reverse $self->linearized_isa;
da4432f3 253 return values %attrs;
254}
255
ba153b33 256sub new_object {
257 my $self = shift;
258 my %args = (@_ == 1 ? %{$_[0]} : @_);
259
260 my $object = bless {}, $self->name;
261
262 $self->_initialize_object($object, \%args);
263 return $object;
264}
265
4e7e3250 266sub _initialize_object{
267 my($self, $object, $args, $ignore_triggers) = @_;
268
269 my @triggers_queue;
270
271 foreach my $attribute ($self->get_all_attributes) {
272 my $init_arg = $attribute->init_arg;
273 my $slot = $attribute->name;
274
275 if (defined($init_arg) && exists($args->{$init_arg})) {
276 $object->{$slot} = $attribute->_coerce_and_verify($args->{$init_arg}, $object);
277
278 weaken($object->{$slot})
279 if ref($object->{$slot}) && $attribute->is_weak_ref;
280
281 if ($attribute->has_trigger) {
282 push @triggers_queue, [ $attribute->trigger, $object->{$slot} ];
283 }
284 }
285 else { # no init arg
286 if ($attribute->has_default || $attribute->has_builder) {
287 if (!$attribute->is_lazy) {
288 my $default = $attribute->default;
289 my $builder = $attribute->builder;
290 my $value = $builder ? $object->$builder()
291 : ref($default) eq 'CODE' ? $object->$default()
292 : $default;
293
294 $object->{$slot} = $attribute->_coerce_and_verify($value, $object);
295
296 weaken($object->{$slot})
297 if ref($object->{$slot}) && $attribute->is_weak_ref;
298 }
299 }
300 elsif($attribute->is_required) {
301 $self->throw_error("Attribute (".$attribute->name.") is required");
302 }
303 }
304 }
305
306 if(!$ignore_triggers){
307 foreach my $trigger_and_value(@triggers_queue){
308 my($trigger, $value) = @{$trigger_and_value};
309 $trigger->($object, $value);
310 }
311 }
312
313 if($self->is_anon_class){
314 $object->{__METACLASS__} = $self;
315 }
316
317 return;
318}
319
80efe911 320sub is_immutable { $_[0]->{is_immutable} }
4e7e3250 321
43165725 322package
323 Mouse::Meta::Role;
324
e058b279 325sub method_metaclass{ $_[0]->{method_metaclass} || 'Mouse::Meta::Role::Method' }
326
43165725 327sub is_anon_role{
328 return exists $_[0]->{anon_serial_id};
329}
330
331sub get_roles { $_[0]->{roles} }
332
333package
334 Mouse::Meta::Attribute;
335
e058b279 336require Mouse::Meta::Method::Accessor;
337
338sub accessor_metaclass{ $_[0]->{accessor_metaclass} || 'Mouse::Meta::Method::Accessor' }
43165725 339
340# readers
341
342sub name { $_[0]->{name} }
343sub associated_class { $_[0]->{associated_class} }
344
345sub accessor { $_[0]->{accessor} }
346sub reader { $_[0]->{reader} }
347sub writer { $_[0]->{writer} }
348sub predicate { $_[0]->{predicate} }
349sub clearer { $_[0]->{clearer} }
350sub handles { $_[0]->{handles} }
351
352sub _is_metadata { $_[0]->{is} }
353sub is_required { $_[0]->{required} }
354sub default { $_[0]->{default} }
355sub is_lazy { $_[0]->{lazy} }
356sub is_lazy_build { $_[0]->{lazy_build} }
357sub is_weak_ref { $_[0]->{weak_ref} }
358sub init_arg { $_[0]->{init_arg} }
359sub type_constraint { $_[0]->{type_constraint} }
360
361sub trigger { $_[0]->{trigger} }
362sub builder { $_[0]->{builder} }
363sub should_auto_deref { $_[0]->{auto_deref} }
364sub should_coerce { $_[0]->{coerce} }
365
d899d3e7 366sub documentation { $_[0]->{documentation} }
367
43165725 368# predicates
369
370sub has_accessor { exists $_[0]->{accessor} }
371sub has_reader { exists $_[0]->{reader} }
372sub has_writer { exists $_[0]->{writer} }
373sub has_predicate { exists $_[0]->{predicate} }
374sub has_clearer { exists $_[0]->{clearer} }
375sub has_handles { exists $_[0]->{handles} }
376
377sub has_default { exists $_[0]->{default} }
378sub has_type_constraint { exists $_[0]->{type_constraint} }
379sub has_trigger { exists $_[0]->{trigger} }
380sub has_builder { exists $_[0]->{builder} }
381
d899d3e7 382sub has_documentation { exists $_[0]->{documentation} }
383
43165725 384package
385 Mouse::Meta::TypeConstraint;
386
387sub name { $_[0]->{name} }
388sub parent { $_[0]->{parent} }
389sub message { $_[0]->{message} }
390
391sub _compiled_type_constraint{ $_[0]->{compiled_type_constraint} }
392
93540011 393sub _compiled_type_coercion { $_[0]->{_compiled_type_coercion} }
df6dd016 394
93540011 395sub has_coercion{ exists $_[0]->{_compiled_type_coercion} }
df6dd016 396
f790c46b 397
398sub compile_type_constraint{
399 my($self) = @_;
400
401 # add parents first
402 my @checks;
403 for(my $parent = $self->{parent}; defined $parent; $parent = $parent->{parent}){
404 if($parent->{hand_optimized_type_constraint}){
405 unshift @checks, $parent->{hand_optimized_type_constraint};
406 last; # a hand optimized constraint must include all the parents
407 }
408 elsif($parent->{constraint}){
409 unshift @checks, $parent->{constraint};
410 }
411 }
412
413 # then add child
414 if($self->{constraint}){
415 push @checks, $self->{constraint};
416 }
417
418 if($self->{type_constraints}){ # Union
419 my @types = map{ $_->{compiled_type_constraint} } @{ $self->{type_constraints} };
420 push @checks, sub{
421 foreach my $c(@types){
422 return 1 if $c->($_[0]);
423 }
424 return 0;
425 };
426 }
427
428 if(@checks == 0){
429 $self->{compiled_type_constraint} = \&Mouse::Util::TypeConstraints::Any;
430 }
431 else{
432 $self->{compiled_type_constraint} = sub{
433 my(@args) = @_;
434 local $_ = $args[0];
435 foreach my $c(@checks){
436 return undef if !$c->(@args);
437 }
438 return 1;
439 };
440 }
441 return;
442}
443
aa2d2e2c 444package
445 Mouse::Object;
446
447
448sub BUILDARGS {
449 my $class = shift;
f790c46b 450
aa2d2e2c 451 if (scalar @_ == 1) {
452 (ref($_[0]) eq 'HASH')
453 || $class->meta->throw_error("Single parameters to new() must be a HASH ref");
454
455 return {%{$_[0]}};
456 }
457 else {
458 return {@_};
459 }
460}
f790c46b 461
af04626d 462sub new {
463 my $class = shift;
464
465 $class->meta->throw_error('Cannot call new() on an instance') if ref $class;
466
467 my $args = $class->BUILDARGS(@_);
468
469 my $meta = Mouse::Meta::Class->initialize($class);
470 my $self = $meta->new_object($args);
471
472 # BUILDALL
473 if( $self->can('BUILD') ) {
474 for my $class (reverse $meta->linearized_isa) {
475 my $build = Mouse::Util::get_code_ref($class, 'BUILD')
476 || next;
477
478 $self->$build($args);
479 }
480 }
481
482 return $self;
483}
484
a5c683f6 485sub DESTROY {
486 my $self = shift;
487
488 return unless $self->can('DEMOLISH'); # short circuit
489
490 local $?;
491
492 my $e = do{
493 local $@;
494 eval{
495
496 # DEMOLISHALL
497
498 # We cannot count on being able to retrieve a previously made
499 # metaclass, _or_ being able to make a new one during global
500 # destruction. However, we should still be able to use mro at
501 # that time (at least tests suggest so ;)
502
503 foreach my $class (@{ Mouse::Util::get_linear_isa(ref $self) }) {
504 my $demolish = Mouse::Util::get_code_ref($class, 'DEMOLISH')
505 || next;
506
507 $self->$demolish();
508 }
509 };
510 $@;
511 };
512
513 no warnings 'misc';
514 die $e if $e; # rethrow
515}
516
adb5eb76 517sub BUILDALL {
518 my $self = shift;
519
520 # short circuit
521 return unless $self->can('BUILD');
522
523 for my $class (reverse $self->meta->linearized_isa) {
524 my $build = Mouse::Util::get_code_ref($class, 'BUILD')
525 || next;
526
527 $self->$build(@_);
528 }
529 return;
530}
531
532sub DEMOLISHALL;
533*DEMOLISHALL = \&DESTROY;
534
df6dd016 5351;
536__END__
ccb38d0b 537
538=head1 NAME
539
540Mouse::PurePerl - A Mouse guts in pure Perl
541
542=head1 VERSION
543
81fd550d 544This document describes Mouse version 0.45
ccb38d0b 545
546=head1 SEE ALSO
547
548L<Mouse::XS>
549
550=cut