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