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