062706fb32fb68e2e54e77f360033f8908f7626b
[gitmo/Moose.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', 'weaken';
8 use Carp         'confess';
9 use Devel::GlobalDestruction 'in_global_destruction';
10 use Package::Stash;
11
12 use base 'Class::MOP::Object';
13
14 # creation ...
15
16 sub initialize {
17     my ( $class, @args ) = @_;
18
19     unshift @args, "package" if @args % 2;
20
21     my %options = @args;
22     my $package_name = delete $options{package};
23
24
25     # we hand-construct the class 
26     # until we can bootstrap it
27     if ( my $meta = Class::MOP::get_metaclass_by_name($package_name) ) {
28         return $meta;
29     } else {
30         my $meta = ( ref $class || $class )->_new({
31             'package'   => $package_name,
32             %options,
33         });
34         Class::MOP::store_metaclass_by_name($package_name, $meta);
35
36         Class::MOP::weaken_metaclass($package_name) if $options{weaken};
37
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 create {
64     my $class = shift;
65     my @args = @_;
66
67     return $class->initialize(@args);
68 }
69
70 ## ANON packages
71
72 {
73     # NOTE:
74     # this should be sufficient, if you have a
75     # use case where it is not, write a test and
76     # I will change it.
77     my $ANON_SERIAL = 0;
78
79     my %ANON_PACKAGE_CACHE;
80
81     # NOTE:
82     # we need a sufficiently annoying prefix
83     # this should suffice for now, this is
84     # used in a couple of places below, so
85     # need to put it up here for now.
86     sub _anon_package_prefix { 'Class::MOP::Package::__ANON__::SERIAL::' }
87
88     sub is_anon {
89         my $self = shift;
90         no warnings 'uninitialized';
91         my $prefix = $self->_anon_package_prefix;
92         $self->name =~ /^\Q$prefix/;
93     }
94
95     sub create_anon {
96         my ($class, %options) = @_;
97
98         my $cache_ok = delete $options{cache};
99         $options{weaken} = !$cache_ok unless exists $options{weaken};
100
101         my $cache_key;
102         if ($cache_ok) {
103             $cache_key = $class->_anon_cache_key(%options);
104             undef $cache_ok if !defined($cache_key);
105         }
106
107         if ($cache_ok) {
108             if (defined $ANON_PACKAGE_CACHE{$cache_key}) {
109                 return $ANON_PACKAGE_CACHE{$cache_key};
110             }
111         }
112
113         my $package_name = $class->_anon_package_prefix . ++$ANON_SERIAL;
114
115         my $meta = $class->create($package_name, %options);
116
117         if ($cache_ok) {
118             $ANON_PACKAGE_CACHE{$cache_key} = $meta;
119             weaken($ANON_PACKAGE_CACHE{$cache_key});
120         }
121
122         return $meta;
123     }
124
125     sub _anon_cache_key { confess "Packages are not cacheable" }
126
127     sub DESTROY {
128         my $self = shift;
129
130         return if in_global_destruction(); # it'll happen soon anyway and this just makes things more complicated
131
132         $self->_free_anon
133             if $self->is_anon;
134     }
135
136     sub _free_anon {
137         my $self = shift;
138         my $name = $self->name;
139
140         # Moose does a weird thing where it replaces the metaclass for
141         # class when fixing metaclass incompatibility. In that case,
142         # we don't want to clean out the namespace now. We can detect
143         # that because Moose will explicitly update the singleton
144         # cache in Class::MOP.
145         no warnings 'uninitialized';
146         my $current_meta = Class::MOP::get_metaclass_by_name($name);
147         return if $current_meta ne $self;
148
149         my ($first_fragments, $last_fragment) = ($name =~ /^(.*)::(.*)$/);
150
151         no strict 'refs';
152         @{$name . '::ISA'} = ();
153         %{$name . '::'}    = ();
154         delete ${$first_fragments . '::'}{$last_fragment . '::'};
155
156         Class::MOP::remove_metaclass_by_name($name);
157     }
158
159 }
160
161 sub _new {
162     my $class = shift;
163
164     return Class::MOP::Class->initialize($class)->new_object(@_)
165         if $class ne __PACKAGE__;
166
167     my $params = @_ == 1 ? $_[0] : {@_};
168
169     return bless {
170         # Need to quote package to avoid a problem with PPI mis-parsing this
171         # as a package statement.
172         'package' => $params->{package},
173
174         # NOTE:
175         # because of issues with the Perl API
176         # to the typeglob in some versions, we
177         # need to just always grab a new
178         # reference to the hash in the accessor.
179         # Ideally we could just store a ref and
180         # it would Just Work, but oh well :\
181
182         namespace => \undef,
183
184     } => $class;
185 }
186
187 # Attributes
188
189 # NOTE:
190 # all these attribute readers will be bootstrapped 
191 # away in the Class::MOP bootstrap section
192
193 sub _package_stash {
194     $_[0]->{_package_stash} ||= Package::Stash->new($_[0]->name)
195 }
196 sub namespace {
197     $_[0]->_package_stash->namespace
198 }
199
200 # Class attributes
201
202 # ... these functions have to touch the symbol table itself,.. yuk
203
204 sub add_package_symbol {
205     my $self = shift;
206     $self->_package_stash->add_symbol(@_);
207 }
208
209 sub remove_package_glob {
210     my $self = shift;
211     $self->_package_stash->remove_glob(@_);
212 }
213
214 # ... these functions deal with stuff on the namespace level
215
216 sub has_package_symbol {
217     my $self = shift;
218     $self->_package_stash->has_symbol(@_);
219 }
220
221 sub get_package_symbol {
222     my $self = shift;
223     $self->_package_stash->get_symbol(@_);
224 }
225
226 sub get_or_add_package_symbol {
227     my $self = shift;
228     $self->_package_stash->get_or_add_symbol(@_);
229 }
230
231 sub remove_package_symbol {
232     my $self = shift;
233     $self->_package_stash->remove_symbol(@_);
234 }
235
236 sub list_all_package_symbols {
237     my $self = shift;
238     $self->_package_stash->list_all_symbols(@_);
239 }
240
241 sub get_all_package_symbols {
242     my $self = shift;
243     $self->_package_stash->get_all_symbols(@_);
244 }
245
246 1;
247
248 # ABSTRACT: Package Meta Object
249
250 __END__
251
252 =pod
253
254 =head1 DESCRIPTION
255
256 The Package Protocol provides an abstraction of a Perl 5 package. A
257 package is basically namespace, and this module provides methods for
258 looking at and changing that namespace's symbol table.
259
260 =head1 METHODS
261
262 =over 4
263
264 =item B<< Class::MOP::Package->initialize($package_name, %options) >>
265
266 This method creates a new C<Class::MOP::Package> instance which
267 represents specified package. If an existing metaclass object exists
268 for the package, that will be returned instead. No options are valid at the
269 package level.
270
271 =item B<< Class::MOP::Package->reinitialize($package, %options) >>
272
273 This method forcibly removes any existing metaclass for the package
274 before calling C<initialize>. In contrast to C<initialize>, you may
275 also pass an existing C<Class::MOP::Package> instance instead of just
276 a package name as C<$package>.
277
278 Do not call this unless you know what you are doing.
279
280 =item B<< Class::MOP::Package->create($package, %options) >>
281
282 Creates a new C<Class::MOP::Package> instance which represents the specified
283 package, and also does some initialization of that package. Currently, this
284 just does the same thing as C<initialize>, but is overridden in subclasses,
285 such as C<Class::MOP::Class>.
286
287 =item B<< Class::MOP::Package->create_anon(%options) >>
288
289 Creates a new anonymous package. Valid keys for C<%options> are:
290
291 =over 4
292
293 =item C<weaken>
294
295 If this is true (the default), the instance stored in C<Class::MOP>'s metaclass
296 cache will be weakened, so that the anonymous package will be garbage collected
297 when the returned instance goes out of scope.
298
299 =back
300
301 =item B<< $metapackage->is_anon >>
302
303 Returns true if the package is an anonymous package.
304
305 =item B<< $metapackage->name >>
306
307 This is returns the package's name, as passed to the constructor.
308
309 =item B<< $metapackage->namespace >>
310
311 This returns a hash reference to the package's symbol table. The keys
312 are symbol names and the values are typeglob references.
313
314 =item B<< $metapackage->add_package_symbol($variable_name, $initial_value) >>
315
316 This method accepts a variable name and an optional initial value. The
317 C<$variable_name> must contain a leading sigil.
318
319 This method creates the variable in the package's symbol table, and
320 sets it to the initial value if one was provided.
321
322 =item B<< $metapackage->get_package_symbol($variable_name) >>
323
324 Given a variable name, this method returns the variable as a reference
325 or undef if it does not exist. The C<$variable_name> must contain a
326 leading sigil.
327
328 =item B<< $metapackage->get_or_add_package_symbol($variable_name) >>
329
330 Given a variable name, this method returns the variable as a reference.
331 If it does not exist, a default value will be generated if possible. The
332 C<$variable_name> must contain a 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 =cut