refactor load_first_existing_class
[gitmo/Class-MOP.git] / lib / Class / MOP / Package.pm
1
2 package Class::MOP::Package;
3
4 use strict;
5 use warnings;
6
7 use Scalar::Util 'blessed', 'reftype';
8 use Carp         'confess';
9 use Sub::Name    'subname';
10
11 our $VERSION   = '0.94';
12 $VERSION = eval $VERSION;
13 our $AUTHORITY = 'cpan:STEVAN';
14
15 use base 'Class::MOP::Object';
16
17 # creation ...
18
19 sub initialize {
20     my ( $class, @args ) = @_;
21
22     unshift @args, "package" if @args % 2;
23
24     my %options = @args;
25     my $package_name = $options{package};
26
27
28     # we hand-construct the class 
29     # until we can bootstrap it
30     if ( my $meta = Class::MOP::get_metaclass_by_name($package_name) ) {
31         return $meta;
32     } else {
33         my $meta = ( ref $class || $class )->_new({
34             'package'   => $package_name,
35             %options,
36         });
37         Class::MOP::store_metaclass_by_name($package_name, $meta);
38
39         return $meta;
40     }
41 }
42
43 sub reinitialize {
44     my ( $class, @args ) = @_;
45
46     unshift @args, "package" if @args % 2;
47
48     my %options = @args;
49     my $package_name = delete $options{package};
50
51     (defined $package_name && $package_name
52       && (!blessed $package_name || $package_name->isa('Class::MOP::Package')))
53         || confess "You must pass a package name or an existing Class::MOP::Package instance";
54
55     $package_name = $package_name->name
56         if blessed $package_name;
57
58     Class::MOP::remove_metaclass_by_name($package_name);
59
60     $class->initialize($package_name, %options); # call with first arg form for compat
61 }
62
63 sub _new {
64     my $class = shift;
65
66     return Class::MOP::Class->initialize($class)->new_object(@_)
67         if $class ne __PACKAGE__;
68
69     my $params = @_ == 1 ? $_[0] : {@_};
70
71     return bless {
72         package   => $params->{package},
73
74         # NOTE:
75         # because of issues with the Perl API
76         # to the typeglob in some versions, we
77         # need to just always grab a new
78         # reference to the hash in the accessor.
79         # Ideally we could just store a ref and
80         # it would Just Work, but oh well :\
81
82         namespace => \undef,
83
84     } => $class;
85 }
86
87 # Attributes
88
89 # NOTE:
90 # all these attribute readers will be bootstrapped 
91 # away in the Class::MOP bootstrap section
92
93 sub namespace { 
94     # NOTE:
95     # because of issues with the Perl API 
96     # to the typeglob in some versions, we 
97     # need to just always grab a new 
98     # reference to the hash here. Ideally 
99     # we could just store a ref and it would
100     # Just Work, but oh well :\    
101     no strict 'refs';    
102     \%{$_[0]->{'package'} . '::'} 
103 }
104
105 sub method_metaclass         { $_[0]->{'method_metaclass'}            }
106 sub wrapped_method_metaclass { $_[0]->{'wrapped_method_metaclass'}    }
107
108 # This doesn't always get initialized in a constructor because there is a
109 # weird object construction path for subclasses of Class::MOP::Class. At one
110 # point, this always got initialized by calling into the XS code first, but
111 # that is no longer guaranteed to happen.
112 sub _method_map { $_[0]->{'methods'} ||= {} }
113
114 # utility methods
115
116 {
117     my %SIGIL_MAP = (
118         '$' => 'SCALAR',
119         '@' => 'ARRAY',
120         '%' => 'HASH',
121         '&' => 'CODE',
122     );
123     
124     sub _deconstruct_variable_name {
125         my ($self, $variable) = @_;
126
127         (defined $variable)
128             || confess "You must pass a variable name";    
129
130         my $sigil = substr($variable, 0, 1, '');
131
132         (defined $sigil)
133             || confess "The variable name must include a sigil";    
134
135         (exists $SIGIL_MAP{$sigil})
136             || confess "I do not recognize that sigil '$sigil'";    
137         
138         return ($variable, $sigil, $SIGIL_MAP{$sigil});
139     }
140 }
141
142 # Class attributes
143
144 # ... these functions have to touch the symbol table itself,.. yuk
145
146 sub add_package_symbol {
147     my ($self, $variable, $initial_value) = @_;
148
149     my ($name, $sigil, $type) = ref $variable eq 'HASH'
150         ? @{$variable}{qw[name sigil type]}
151         : $self->_deconstruct_variable_name($variable);
152
153     my $pkg = $self->{'package'};
154
155     no strict 'refs';
156     no warnings 'redefine', 'misc', 'prototype';
157     *{$pkg . '::' . $name} = ref $initial_value ? $initial_value : \$initial_value;
158 }
159
160 sub remove_package_glob {
161     my ($self, $name) = @_;
162     no strict 'refs';        
163     delete ${$self->name . '::'}{$name};     
164 }
165
166 # ... these functions deal with stuff on the namespace level
167
168 sub has_package_symbol {
169     my ( $self, $variable ) = @_;
170
171     my ( $name, $sigil, $type )
172         = ref $variable eq 'HASH'
173         ? @{$variable}{qw[name sigil type]}
174         : $self->_deconstruct_variable_name($variable);
175
176     my $namespace = $self->namespace;
177
178     return 0 unless exists $namespace->{$name};
179
180     my $entry_ref = \$namespace->{$name};
181     if ( reftype($entry_ref) eq 'GLOB' ) {
182         if ( $type eq 'SCALAR' ) {
183             return defined( ${ *{$entry_ref}{SCALAR} } );
184         }
185         else {
186             return defined( *{$entry_ref}{$type} );
187         }
188     }
189     else {
190
191         # a symbol table entry can be -1 (stub), string (stub with prototype),
192         # or reference (constant)
193         return $type eq 'CODE';
194     }
195 }
196
197 sub get_package_symbol {
198     my ($self, $variable) = @_;    
199
200     my ($name, $sigil, $type) = ref $variable eq 'HASH'
201         ? @{$variable}{qw[name sigil type]}
202         : $self->_deconstruct_variable_name($variable);
203
204     my $namespace = $self->namespace;
205
206     # FIXME
207     $self->add_package_symbol($variable)
208         unless exists $namespace->{$name};
209
210     my $entry_ref = \$namespace->{$name};
211
212     if ( ref($entry_ref) eq 'GLOB' ) {
213         return *{$entry_ref}{$type};
214     }
215     else {
216         if ( $type eq 'CODE' ) {
217             no strict 'refs';
218             return \&{ $self->name . '::' . $name };
219         }
220         else {
221             return undef;
222         }
223     }
224 }
225
226 sub remove_package_symbol {
227     my ($self, $variable) = @_;
228
229     my ($name, $sigil, $type) = ref $variable eq 'HASH'
230         ? @{$variable}{qw[name sigil type]}
231         : $self->_deconstruct_variable_name($variable);
232
233     # FIXME:
234     # no doubt this is grossly inefficient and 
235     # could be done much easier and faster in XS
236
237     my ($scalar_desc, $array_desc, $hash_desc, $code_desc) = (
238         { sigil => '$', type => 'SCALAR', name => $name },
239         { sigil => '@', type => 'ARRAY',  name => $name },
240         { sigil => '%', type => 'HASH',   name => $name },
241         { sigil => '&', type => 'CODE',   name => $name },
242     );
243
244     my ($scalar, $array, $hash, $code);
245     if ($type eq 'SCALAR') {
246         $array  = $self->get_package_symbol($array_desc)  if $self->has_package_symbol($array_desc);
247         $hash   = $self->get_package_symbol($hash_desc)   if $self->has_package_symbol($hash_desc);     
248         $code   = $self->get_package_symbol($code_desc)   if $self->has_package_symbol($code_desc);     
249     }
250     elsif ($type eq 'ARRAY') {
251         $scalar = $self->get_package_symbol($scalar_desc) if $self->has_package_symbol($scalar_desc);
252         $hash   = $self->get_package_symbol($hash_desc)   if $self->has_package_symbol($hash_desc);     
253         $code   = $self->get_package_symbol($code_desc)   if $self->has_package_symbol($code_desc);
254     }
255     elsif ($type eq 'HASH') {
256         $scalar = $self->get_package_symbol($scalar_desc) if $self->has_package_symbol($scalar_desc);
257         $array  = $self->get_package_symbol($array_desc)  if $self->has_package_symbol($array_desc);        
258         $code   = $self->get_package_symbol($code_desc)   if $self->has_package_symbol($code_desc);      
259     }
260     elsif ($type eq 'CODE') {
261         $scalar = $self->get_package_symbol($scalar_desc) if $self->has_package_symbol($scalar_desc);
262         $array  = $self->get_package_symbol($array_desc)  if $self->has_package_symbol($array_desc);        
263         $hash   = $self->get_package_symbol($hash_desc)   if $self->has_package_symbol($hash_desc);        
264     }    
265     else {
266         confess "This should never ever ever happen";
267     }
268         
269     $self->remove_package_glob($name);
270     
271     $self->add_package_symbol($scalar_desc => $scalar) if defined $scalar;      
272     $self->add_package_symbol($array_desc  => $array)  if defined $array;    
273     $self->add_package_symbol($hash_desc   => $hash)   if defined $hash;
274     $self->add_package_symbol($code_desc   => $code)   if defined $code;            
275 }
276
277 sub list_all_package_symbols {
278     my ($self, $type_filter) = @_;
279
280     my $namespace = $self->namespace;
281     return keys %{$namespace} unless defined $type_filter;
282     
283     # NOTE:
284     # or we can filter based on 
285     # type (SCALAR|ARRAY|HASH|CODE)
286     if ( $type_filter eq 'CODE' ) {
287         return grep { 
288         (ref($namespace->{$_})
289                 ? (ref($namespace->{$_}) eq 'SCALAR')
290                 : (ref(\$namespace->{$_}) eq 'GLOB'
291                    && defined(*{$namespace->{$_}}{CODE})));
292         } keys %{$namespace};
293     } else {
294         return grep { *{$namespace->{$_}}{$type_filter} } keys %{$namespace};
295     }
296 }
297
298 ## Methods
299
300 sub wrap_method_body {
301     my ( $self, %args ) = @_;
302
303     ('CODE' eq ref $args{body})
304         || confess "Your code block must be a CODE reference";
305
306     $self->method_metaclass->wrap(
307         package_name => $self->name,
308         %args,
309     );
310 }
311
312 sub add_method {
313     my ($self, $method_name, $method) = @_;
314     (defined $method_name && $method_name)
315         || confess "You must define a method name";
316
317     my $body;
318     if (blessed($method)) {
319         $body = $method->body;
320         if ($method->package_name ne $self->name) {
321             $method = $method->clone(
322                 package_name => $self->name,
323                 name         => $method_name            
324             ) if $method->can('clone');
325         }
326
327         $method->attach_to_class($self);
328     }
329     else {
330         # If a raw code reference is supplied, its method object is not created.
331         # The method object won't be created until required.
332         $body = $method;
333     }
334
335     $self->_method_map->{$method_name} = $method;
336
337     my ( $current_package, $current_name ) = Class::MOP::get_code_info($body);
338
339     if ( !defined $current_name || $current_name eq '__ANON__' ) {
340         my $full_method_name = ($self->name . '::' . $method_name);
341         subname($full_method_name => $body);
342     }
343
344     $self->add_package_symbol(
345         { sigil => '&', type => 'CODE', name => $method_name },
346         $body,
347     );
348 }
349
350 sub _code_is_mine {
351     my ( $self, $code ) = @_;
352
353     my ( $code_package, $code_name ) = Class::MOP::get_code_info($code);
354
355     return $code_package && $code_package eq $self->name
356         || ( $code_package eq 'constant' && $code_name eq '__ANON__' );
357 }
358
359 sub has_method {
360     my ($self, $method_name) = @_;
361
362     defined($method_name)
363         || confess "You must define a method name";
364
365     return defined($self->get_method($method_name));
366 }
367
368 sub get_method {
369     my ( $self, $method_name ) = @_;
370
371     defined($method_name)
372         || confess "You must define a method name";
373
374     my $method_map = $self->_method_map;
375     my $map_entry  = $method_map->{$method_name};
376     my $code = $self->get_package_symbol(
377         {
378             name  => $method_name,
379             sigil => '&',
380             type  => 'CODE',
381         }
382     );
383
384     # This seems to happen in some weird cases where methods modifiers are
385     # added via roles or some other such bizareness. Honestly, I don't totally
386     # understand this, but returning the entry works, and keeps various MX
387     # modules from blowing up. - DR
388     return $map_entry if blessed $map_entry && !$code;
389
390     return $map_entry if blessed $map_entry && $map_entry->body == $code;
391
392     unless ($map_entry) {
393         return unless $code && $self->_code_is_mine($code);
394     }
395
396     $code ||= $map_entry;
397
398     return $method_map->{$method_name} = $self->wrap_method_body(
399         body                 => $code,
400         name                 => $method_name,
401         associated_metaclass => $self,
402     );
403 }
404
405 sub remove_method {
406     my ($self, $method_name) = @_;
407     (defined $method_name && $method_name)
408         || confess "You must define a method name";
409
410     my $removed_method = delete $self->_full_method_map->{$method_name};
411     
412     $self->remove_package_symbol(
413         { sigil => '&', type => 'CODE', name => $method_name }
414     );
415
416     $removed_method->detach_from_class if $removed_method && blessed $removed_method;
417
418     $self->update_package_cache_flag; # still valid, since we just removed the method from the map
419
420     return $removed_method;
421 }
422
423 sub get_method_list {
424     my $self = shift;
425     return grep { $self->has_method($_) } keys %{ $self->namespace };
426 }
427
428 1;
429
430 __END__
431
432 =pod
433
434 =head1 NAME 
435
436 Class::MOP::Package - Package Meta Object
437
438 =head1 DESCRIPTION
439
440 The Package Protocol provides an abstraction of a Perl 5 package. A
441 package is basically namespace, and this module provides methods for
442 looking at and changing that namespace's symbol table.
443
444 =head1 METHODS
445
446 =over 4
447
448 =item B<< Class::MOP::Package->initialize($package_name) >>
449
450 This method creates a new C<Class::MOP::Package> instance which
451 represents specified package. If an existing metaclass object exists
452 for the package, that will be returned instead.
453
454 =item B<< Class::MOP::Package->reinitialize($package) >>
455
456 This method forcibly removes any existing metaclass for the package
457 before calling C<initialize>. In contrast to C<initialize>, you may
458 also pass an existing C<Class::MOP::Package> instance instead of just
459 a package name as C<$package>.
460
461 Do not call this unless you know what you are doing.
462
463 =item B<< $metapackage->name >>
464
465 This is returns the package's name, as passed to the constructor.
466
467 =item B<< $metapackage->namespace >>
468
469 This returns a hash reference to the package's symbol table. The keys
470 are symbol names and the values are typeglob references.
471
472 =item B<< $metapackage->add_package_symbol($variable_name, $initial_value) >>
473
474 This method accepts a variable name and an optional initial value. The
475 C<$variable_name> must contain a leading sigil.
476
477 This method creates the variable in the package's symbol table, and
478 sets it to the initial value if one was provided.
479
480 =item B<< $metapackage->get_package_symbol($variable_name) >>
481
482 Given a variable name, this method returns the variable as a reference
483 or undef if it does not exist. The C<$variable_name> must contain a
484 leading sigil.
485
486 =item B<< $metapackage->has_package_symbol($variable_name) >>
487
488 Returns true if there is a package variable defined for
489 C<$variable_name>. The C<$variable_name> must contain a leading sigil.
490
491 =item B<< $metapackage->remove_package_symbol($variable_name) >>
492
493 This will remove the package variable specified C<$variable_name>. The
494 C<$variable_name> must contain a leading sigil.
495
496 =item B<< $metapackage->remove_package_glob($glob_name) >>
497
498 Given the name of a glob, this will remove that glob from the
499 package's symbol table. Glob names do not include a sigil. Removing
500 the glob removes all variables and subroutines with the specified
501 name.
502
503 =item B<< $metapackage->list_all_package_symbols($type_filter) >>
504
505 This will list all the glob names associated with the current
506 package. These names do not have leading sigils.
507
508 You can provide an optional type filter, which should be one of
509 'SCALAR', 'ARRAY', 'HASH', or 'CODE'.
510
511 =item B<< $metapackage->get_all_package_symbols($type_filter) >>
512
513 This works much like C<list_all_package_symbols>, but it returns a
514 hash reference. The keys are glob names and the values are references
515 to the value for that name.
516
517 =back
518
519 =head2 Method introspection and creation
520
521 These methods allow you to introspect a class's methods, as well as
522 add, remove, or change methods.
523
524 Determining what is truly a method in a Perl 5 class requires some
525 heuristics (aka guessing).
526
527 Methods defined outside the package with a fully qualified name (C<sub
528 Package::name { ... }>) will be included. Similarly, methods named
529 with a fully qualified name using L<Sub::Name> are also included.
530
531 However, we attempt to ignore imported functions.
532
533 Ultimately, we are using heuristics to determine what truly is a
534 method in a class, and these heuristics may get the wrong answer in
535 some edge cases. However, for most "normal" cases the heuristics work
536 correctly.
537
538 =over 4
539
540 =item B<< $metapackage->get_method($method_name) >>
541
542 This will return a L<Class::MOP::Method> for the specified
543 C<$method_name>. If the class does not have the specified method, it
544 returns C<undef>
545
546 =item B<< $metapackage->has_method($method_name) >>
547
548 Returns a boolean indicating whether or not the class defines the
549 named method. It does not include methods inherited from parent
550 classes.
551
552 =item B<< $metapackage->get_method_list >>
553
554 This will return a list of method I<names> for all methods defined in
555 this class.
556
557 =item B<< $metapackage->add_method($method_name, $method) >>
558
559 This method takes a method name and a subroutine reference, and adds
560 the method to the class.
561
562 The subroutine reference can be a L<Class::MOP::Method>, and you are
563 strongly encouraged to pass a meta method object instead of a code
564 reference. If you do so, that object gets stored as part of the
565 class's method map directly. If not, the meta information will have to
566 be recreated later, and may be incorrect.
567
568 If you provide a method object, this method will clone that object if
569 the object's package name does not match the class name. This lets us
570 track the original source of any methods added from other classes
571 (notably Moose roles).
572
573 =item B<< $metapackage->remove_method($method_name) >>
574
575 Remove the named method from the class. This method returns the
576 L<Class::MOP::Method> object for the method.
577
578 =item B<< $metapackage->method_metaclass >>
579
580 Returns the class name of the method metaclass, see
581 L<Class::MOP::Method> for more information on the method metaclass.
582
583 =item B<< $metapackage->wrapped_method_metaclass >>
584
585 Returns the class name of the wrapped method metaclass, see
586 L<Class::MOP::Method::Wrapped> for more information on the wrapped
587 method metaclass.
588
589 =item B<< Class::MOP::Package->meta >>
590
591 This will return a L<Class::MOP::Class> instance for this class.
592
593 =back
594
595 =head1 AUTHORS
596
597 Stevan Little E<lt>stevan@iinteractive.comE<gt>
598
599 =head1 COPYRIGHT AND LICENSE
600
601 Copyright 2006-2009 by Infinity Interactive, Inc.
602
603 L<http://www.iinteractive.com>
604
605 This library is free software; you can redistribute it and/or modify
606 it under the same terms as Perl itself.
607
608 =cut