add a .shipit file for my sake
[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.64_01';
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        });
35
36        Class::MOP::store_metaclass_by_name($package_name, $meta);
37
38        return $meta;
39     }
40 }
41
42 sub reinitialize {
43     my ( $class, @args ) = @_;
44
45     unshift @args, "package" if @args % 2;
46
47     my %options = @args;
48     my $package_name = delete $options{package};
49
50     (defined $package_name && $package_name && !blessed($package_name))
51         || confess "You must pass a package name and it cannot be blessed";
52
53     Class::MOP::remove_metaclass_by_name($package_name);
54
55     $class->initialize($package_name, %options); # call with first arg form for compat
56 }
57
58 sub _new {
59     my $class = shift;
60     my $options = @_ == 1 ? $_[0] : {@_};
61
62     # NOTE:
63     # because of issues with the Perl API 
64     # to the typeglob in some versions, we 
65     # need to just always grab a new 
66     # reference to the hash in the accessor. 
67     # Ideally we could just store a ref and 
68     # it would Just Work, but oh well :\
69     $options->{namespace} ||= \undef;
70
71     bless $options, $class;
72 }
73
74 # Attributes
75
76 # NOTE:
77 # all these attribute readers will be bootstrapped 
78 # away in the Class::MOP bootstrap section
79
80 sub name      { $_[0]->{'package'} }
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';    
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 sub get_all_package_symbols {
278     my ($self, $type_filter) = @_;
279     my $namespace = $self->namespace;
280
281     return %$namespace unless defined $type_filter;
282
283     # for some reason this nasty impl is orders of magnitude aster than a clean version
284     if ( $type_filter eq 'CODE' ) {
285         my $pkg;
286         no strict 'refs';
287         return map {
288             (ref($namespace->{$_})
289                 ? ( $_ => \&{$pkg ||= $self->name . "::$_"} )
290                 : ( *{$namespace->{$_}}{CODE}
291                     ? ( $_ => *{$namespace->{$_}}{$type_filter} )
292                     : ()))
293         } keys %$namespace;
294     } else {
295         return map {
296             $_ => *{$namespace->{$_}}{$type_filter}
297         } grep {
298             !ref($namespace->{$_}) && *{$namespace->{$_}}{$type_filter}
299         } keys %$namespace;
300     }
301 }
302
303 1;
304
305 __END__
306
307 =pod
308
309 =head1 NAME 
310
311 Class::MOP::Package - Package Meta Object
312
313 =head1 DESCRIPTION
314
315 This is an abstraction of a Perl 5 package, it is a superclass of
316 L<Class::MOP::Class> and provides all of the symbol table 
317 introspection methods.
318
319 =head1 METHODS
320
321 =over 4
322
323 =item B<meta>
324
325 Returns a metaclass for this package.
326
327 =item B<initialize ($package_name)>
328
329 This will initialize a Class::MOP::Package instance which represents 
330 the package of C<$package_name>.
331
332 =item B<reinitialize ($package_name, %options)>
333
334 This removes the old metaclass, and creates a new one in it's place.
335 Do B<not> use this unless you really know what you are doing, it could
336 very easily make a very large mess of your program.
337
338 =item B<name>
339
340 This is a read-only attribute which returns the package name for the 
341 given instance.
342
343 =item B<namespace>
344
345 This returns a HASH reference to the symbol table. The keys of the 
346 HASH are the symbol names, and the values are typeglob references.
347
348 =item B<add_package_symbol ($variable_name, ?$initial_value)>
349
350 Given a C<$variable_name>, which must contain a leading sigil, this 
351 method will create that variable within the package which houses the 
352 class. It also takes an optional C<$initial_value>, which must be a 
353 reference of the same type as the sigil of the C<$variable_name> 
354 implies.
355
356 =item B<get_package_symbol ($variable_name)>
357
358 This will return a reference to the package variable in 
359 C<$variable_name>. 
360
361 =item B<has_package_symbol ($variable_name)>
362
363 Returns true (C<1>) if there is a package variable defined for 
364 C<$variable_name>, and false (C<0>) otherwise.
365
366 =item B<remove_package_symbol ($variable_name)>
367
368 This will attempt to remove the package variable at C<$variable_name>.
369
370 =item B<remove_package_glob ($glob_name)>
371
372 This will attempt to remove the entire typeglob associated with 
373 C<$glob_name> from the package. 
374
375 =item B<list_all_package_symbols (?$type_filter)>
376
377 This will list all the glob names associated with the current package. 
378 By inspecting the globs returned you can discern all the variables in 
379 the package.
380
381 By passing a C<$type_filter>, you can limit the list to only those 
382 which match the filter (either SCALAR, ARRAY, HASH or CODE).
383
384 =item B<get_all_package_symbols (?$type_filter)>
385
386 Works exactly like C<list_all_package_symbols> but returns a HASH of 
387 name => thing mapping instead of just an ARRAY of names.
388
389 =back
390
391 =head1 AUTHORS
392
393 Stevan Little E<lt>stevan@iinteractive.comE<gt>
394
395 =head1 COPYRIGHT AND LICENSE
396
397 Copyright 2006-2008 by Infinity Interactive, Inc.
398
399 L<http://www.iinteractive.com>
400
401 This library is free software; you can redistribute it and/or modify
402 it under the same terms as Perl itself.
403
404 =cut