Remove unnecessary calls of has_method()
[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
10 our $VERSION   = '0.89';
11 $VERSION = eval $VERSION;
12 our $AUTHORITY = 'cpan:STEVAN';
13
14 use base 'Class::MOP::Object';
15
16 # creation ...
17
18 sub initialize {
19     my ( $class, @args ) = @_;
20
21     unshift @args, "package" if @args % 2;
22
23     my %options = @args;
24     my $package_name = $options{package};
25
26
27     # we hand-construct the class 
28     # until we can bootstrap it
29     if ( my $meta = Class::MOP::get_metaclass_by_name($package_name) ) {
30         return $meta;
31     } else {
32         my $meta = ( ref $class || $class )->_new({
33             'package'   => $package_name,
34             %options,
35         });
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 && !blessed($package_name))
52         || confess "You must pass a package name and it cannot be blessed";
53
54     Class::MOP::remove_metaclass_by_name($package_name);
55
56     $class->initialize($package_name, %options); # call with first arg form for compat
57 }
58
59 sub _new {
60     my $class = shift;
61
62     return Class::MOP::Class->initialize($class)->new_object(@_)
63         if $class ne __PACKAGE__;
64
65     my $params = @_ == 1 ? $_[0] : {@_};
66
67     return bless {
68         package   => $params->{package},
69
70         # NOTE:
71         # because of issues with the Perl API
72         # to the typeglob in some versions, we
73         # need to just always grab a new
74         # reference to the hash in the accessor.
75         # Ideally we could just store a ref and
76         # it would Just Work, but oh well :\
77
78         namespace => \undef,
79
80     } => $class;
81 }
82
83 # Attributes
84
85 # NOTE:
86 # all these attribute readers will be bootstrapped 
87 # away in the Class::MOP bootstrap section
88
89 sub namespace { 
90     # NOTE:
91     # because of issues with the Perl API 
92     # to the typeglob in some versions, we 
93     # need to just always grab a new 
94     # reference to the hash here. Ideally 
95     # we could just store a ref and it would
96     # Just Work, but oh well :\    
97     no strict 'refs';    
98     \%{$_[0]->{'package'} . '::'} 
99 }
100
101 # utility methods
102
103 {
104     my %SIGIL_MAP = (
105         '$' => 'SCALAR',
106         '@' => 'ARRAY',
107         '%' => 'HASH',
108         '&' => 'CODE',
109     );
110     
111     sub _deconstruct_variable_name {
112         my ($self, $variable) = @_;
113
114         (defined $variable)
115             || confess "You must pass a variable name";    
116
117         my $sigil = substr($variable, 0, 1, '');
118
119         (defined $sigil)
120             || confess "The variable name must include a sigil";    
121
122         (exists $SIGIL_MAP{$sigil})
123             || confess "I do not recognize that sigil '$sigil'";    
124         
125         return ($variable, $sigil, $SIGIL_MAP{$sigil});
126     }
127 }
128
129 # Class attributes
130
131 # ... these functions have to touch the symbol table itself,.. yuk
132
133 sub add_package_symbol {
134     my ($self, $variable, $initial_value) = @_;
135
136     my ($name, $sigil, $type) = ref $variable eq 'HASH'
137         ? @{$variable}{qw[name sigil type]}
138         : $self->_deconstruct_variable_name($variable);
139
140     my $pkg = $self->{'package'};
141
142     no strict 'refs';
143     no warnings 'redefine', 'misc', 'prototype';
144     *{$pkg . '::' . $name} = ref $initial_value ? $initial_value : \$initial_value;
145 }
146
147 sub remove_package_glob {
148     my ($self, $name) = @_;
149     no strict 'refs';        
150     delete ${$self->name . '::'}{$name};     
151 }
152
153 # ... these functions deal with stuff on the namespace level
154
155 sub has_package_symbol {
156     my ( $self, $variable ) = @_;
157
158     my ( $name, $sigil, $type )
159         = ref $variable eq 'HASH'
160         ? @{$variable}{qw[name sigil type]}
161         : $self->_deconstruct_variable_name($variable);
162
163     my $namespace = $self->namespace;
164
165     return 0 unless exists $namespace->{$name};
166
167     my $entry_ref = \$namespace->{$name};
168     if ( reftype($entry_ref) eq 'GLOB' ) {
169         if ( $type eq 'SCALAR' ) {
170             return defined( ${ *{$entry_ref}{SCALAR} } );
171         }
172         else {
173             return defined( *{$entry_ref}{$type} );
174         }
175     }
176     else {
177
178         # a symbol table entry can be -1 (stub), string (stub with prototype),
179         # or reference (constant)
180         return $type eq 'CODE';
181     }
182 }
183
184 sub get_package_symbol {
185     my ($self, $variable) = @_;    
186
187     my ($name, $sigil, $type) = ref $variable eq 'HASH'
188         ? @{$variable}{qw[name sigil type]}
189         : $self->_deconstruct_variable_name($variable);
190
191     my $namespace = $self->namespace;
192
193     # FIXME
194     $self->add_package_symbol($variable)
195         unless exists $namespace->{$name};
196
197     my $entry_ref = \$namespace->{$name};
198
199     if ( ref($entry_ref) eq 'GLOB' ) {
200         return *{$entry_ref}{$type};
201     }
202     else {
203         if ( $type eq 'CODE' ) {
204             no strict 'refs';
205             return \&{ $self->name . '::' . $name };
206         }
207         else {
208             return undef;
209         }
210     }
211 }
212
213 sub remove_package_symbol {
214     my ($self, $variable) = @_;
215
216     my ($name, $sigil, $type) = ref $variable eq 'HASH'
217         ? @{$variable}{qw[name sigil type]}
218         : $self->_deconstruct_variable_name($variable);
219
220     # FIXME:
221     # no doubt this is grossly inefficient and 
222     # could be done much easier and faster in XS
223
224     my ($scalar_desc, $array_desc, $hash_desc, $code_desc) = (
225         { sigil => '$', type => 'SCALAR', name => $name },
226         { sigil => '@', type => 'ARRAY',  name => $name },
227         { sigil => '%', type => 'HASH',   name => $name },
228         { sigil => '&', type => 'CODE',   name => $name },
229     );
230
231     my ($scalar, $array, $hash, $code);
232     if ($type eq 'SCALAR') {
233         $array  = $self->get_package_symbol($array_desc)  if $self->has_package_symbol($array_desc);
234         $hash   = $self->get_package_symbol($hash_desc)   if $self->has_package_symbol($hash_desc);     
235         $code   = $self->get_package_symbol($code_desc)   if $self->has_package_symbol($code_desc);     
236     }
237     elsif ($type eq 'ARRAY') {
238         $scalar = $self->get_package_symbol($scalar_desc) if $self->has_package_symbol($scalar_desc);
239         $hash   = $self->get_package_symbol($hash_desc)   if $self->has_package_symbol($hash_desc);     
240         $code   = $self->get_package_symbol($code_desc)   if $self->has_package_symbol($code_desc);
241     }
242     elsif ($type eq 'HASH') {
243         $scalar = $self->get_package_symbol($scalar_desc) if $self->has_package_symbol($scalar_desc);
244         $array  = $self->get_package_symbol($array_desc)  if $self->has_package_symbol($array_desc);        
245         $code   = $self->get_package_symbol($code_desc)   if $self->has_package_symbol($code_desc);      
246     }
247     elsif ($type eq 'CODE') {
248         $scalar = $self->get_package_symbol($scalar_desc) if $self->has_package_symbol($scalar_desc);
249         $array  = $self->get_package_symbol($array_desc)  if $self->has_package_symbol($array_desc);        
250         $hash   = $self->get_package_symbol($hash_desc)   if $self->has_package_symbol($hash_desc);        
251     }    
252     else {
253         confess "This should never ever ever happen";
254     }
255         
256     $self->remove_package_glob($name);
257     
258     $self->add_package_symbol($scalar_desc => $scalar) if defined $scalar;      
259     $self->add_package_symbol($array_desc  => $array)  if defined $array;    
260     $self->add_package_symbol($hash_desc   => $hash)   if defined $hash;
261     $self->add_package_symbol($code_desc   => $code)   if defined $code;            
262 }
263
264 sub list_all_package_symbols {
265     my ($self, $type_filter) = @_;
266
267     my $namespace = $self->namespace;
268     return keys %{$namespace} unless defined $type_filter;
269     
270     # NOTE:
271     # or we can filter based on 
272     # type (SCALAR|ARRAY|HASH|CODE)
273     if ( $type_filter eq 'CODE' ) {
274         return grep { 
275         (ref($namespace->{$_})
276                 ? (ref($namespace->{$_}) eq 'SCALAR')
277                 : (ref(\$namespace->{$_}) eq 'GLOB'
278                    && defined(*{$namespace->{$_}}{CODE})));
279         } keys %{$namespace};
280     } else {
281         return grep { *{$namespace->{$_}}{$type_filter} } keys %{$namespace};
282     }
283 }
284
285 1;
286
287 __END__
288
289 =pod
290
291 =head1 NAME 
292
293 Class::MOP::Package - Package Meta Object
294
295 =head1 DESCRIPTION
296
297 The Package Protocol provides an abstraction of a Perl 5 package. A
298 package is basically namespace, and this module provides methods for
299 looking at and changing that namespace's symbol table.
300
301 =head1 METHODS
302
303 =over 4
304
305 =item B<< Class::MOP::Package->initialize($package_name) >>
306
307 This method creates a new C<Class::MOP::Package> instance which
308 represents specified package. If an existing metaclass object exists
309 for the package, that will be returned instead.
310
311 =item B<< Class::MOP::Package->reinitialize($package_name) >>
312
313 This method forcibly removes any existing metaclass for the package
314 before calling C<initialize>
315
316 Do not call this unless you know what you are doing.
317
318 =item B<< $metapackage->name >>
319
320 This is returns the package's name, as passed to the constructor.
321
322 =item B<< $metapackage->namespace >>
323
324 This returns a hash reference to the package's symbol table. The keys
325 are symbol names and the values are typeglob references.
326
327 =item B<< $metapackage->add_package_symbol($variable_name, $initial_value) >>
328
329 This method accepts a variable name and an optional initial value. The
330 C<$variable_name> must contain a leading sigil.
331
332 This method creates the variable in the package's symbol table, and
333 sets it to the initial value if one was provided.
334
335 =item B<< $metapackage->get_package_symbol($variable_name) >>
336
337 Given a variable name, this method returns the variable as a reference
338 or undef if it does not exist. The C<$variable_name> must contain a
339 leading sigil.
340
341 =item B<< $metapackage->has_package_symbol($variable_name) >>
342
343 Returns true if there is a package variable defined for
344 C<$variable_name>. The C<$variable_name> must contain a leading sigil.
345
346 =item B<< $metapackage->remove_package_symbol($variable_name) >>
347
348 This will remove the package variable specified C<$variable_name>. The
349 C<$variable_name> must contain a leading sigil.
350
351 =item B<< $metapackage->remove_package_glob($glob_name) >>
352
353 Given the name of a glob, this will remove that glob from the
354 package's symbol table. Glob names do not include a sigil. Removing
355 the glob removes all variables and subroutines with the specified
356 name.
357
358 =item B<< $metapackage->list_all_package_symbols($type_filter) >>
359
360 This will list all the glob names associated with the current
361 package. These names do not have leading sigils.
362
363 You can provide an optional type filter, which should be one of
364 'SCALAR', 'ARRAY', 'HASH', or 'CODE'.
365
366 =item B<< $metapackage->get_all_package_symbols($type_filter) >>
367
368 This works much like C<list_all_package_symbols>, but it returns a
369 hash reference. The keys are glob names and the values are references
370 to the value for that name.
371
372 =item B<< Class::MOP::Package->meta >>
373
374 This will return a L<Class::MOP::Class> instance for this class.
375
376 =back
377
378 =head1 AUTHORS
379
380 Stevan Little E<lt>stevan@iinteractive.comE<gt>
381
382 =head1 COPYRIGHT AND LICENSE
383
384 Copyright 2006-2009 by Infinity Interactive, Inc.
385
386 L<http://www.iinteractive.com>
387
388 This library is free software; you can redistribute it and/or modify
389 it under the same terms as Perl itself.
390
391 =cut