2 package Class::MOP::Package;
8 use Scalar::Util 'blessed';
11 our $VERSION = '0.78';
12 $VERSION = eval $VERSION;
13 our $AUTHORITY = 'cpan:STEVAN';
15 use base 'Class::MOP::Object';
20 my ( $class, @args ) = @_;
22 unshift @args, "package" if @args % 2;
25 my $package_name = $options{package};
28 # we hand-construct the class
29 # until we can bootstrap it
30 if ( my $meta = Class::MOP::get_metaclass_by_name($package_name) ) {
33 my $meta = ( ref $class || $class )->_new({
34 'package' => $package_name,
38 Class::MOP::store_metaclass_by_name($package_name, $meta);
45 my ( $class, @args ) = @_;
47 unshift @args, "package" if @args % 2;
50 my $package_name = delete $options{package};
52 (defined $package_name && $package_name && !blessed($package_name))
53 || confess "You must pass a package name and it cannot be blessed";
55 Class::MOP::remove_metaclass_by_name($package_name);
57 $class->initialize($package_name, %options); # call with first arg form for compat
62 my $options = @_ == 1 ? $_[0] : {@_};
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;
73 bless $options, $class;
79 # all these attribute readers will be bootstrapped
80 # away in the Class::MOP bootstrap section
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 :\
91 \%{$_[0]->{'package'} . '::'}
104 sub _deconstruct_variable_name {
105 my ($self, $variable) = @_;
108 || confess "You must pass a variable name";
110 my $sigil = substr($variable, 0, 1, '');
113 || confess "The variable name must include a sigil";
115 (exists $SIGIL_MAP{$sigil})
116 || confess "I do not recognize that sigil '$sigil'";
118 return ($variable, $sigil, $SIGIL_MAP{$sigil});
124 # ... these functions have to touch the symbol table itself,.. yuk
126 sub add_package_symbol {
127 my ($self, $variable, $initial_value) = @_;
129 my ($name, $sigil, $type) = ref $variable eq 'HASH'
130 ? @{$variable}{qw[name sigil type]}
131 : $self->_deconstruct_variable_name($variable);
133 my $pkg = $self->{'package'};
136 no warnings 'redefine', 'misc';
137 *{$pkg . '::' . $name} = ref $initial_value ? $initial_value : \$initial_value;
140 sub remove_package_glob {
141 my ($self, $name) = @_;
143 delete ${$self->name . '::'}{$name};
146 # ... these functions deal with stuff on the namespace level
148 sub has_package_symbol {
149 my ($self, $variable) = @_;
151 my ($name, $sigil, $type) = ref $variable eq 'HASH'
152 ? @{$variable}{qw[name sigil type]}
153 : $self->_deconstruct_variable_name($variable);
155 my $namespace = $self->namespace;
157 return 0 unless exists $namespace->{$name};
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.
168 if (ref($namespace->{$name}) eq 'SCALAR') {
169 return ($type eq 'CODE');
171 elsif ($type eq 'SCALAR') {
172 my $val = *{$namespace->{$name}}{$type};
173 return defined(${$val});
176 defined(*{$namespace->{$name}}{$type});
180 sub get_package_symbol {
181 my ($self, $variable) = @_;
183 my ($name, $sigil, $type) = ref $variable eq 'HASH'
184 ? @{$variable}{qw[name sigil type]}
185 : $self->_deconstruct_variable_name($variable);
187 my $namespace = $self->namespace;
189 $self->add_package_symbol($variable)
190 unless exists $namespace->{$name};
192 if (ref($namespace->{$name}) eq 'SCALAR') {
193 if ($type eq 'CODE') {
195 return \&{$self->name.'::'.$name};
202 return *{$namespace->{$name}}{$type};
206 sub remove_package_symbol {
207 my ($self, $variable) = @_;
209 my ($name, $sigil, $type) = ref $variable eq 'HASH'
210 ? @{$variable}{qw[name sigil type]}
211 : $self->_deconstruct_variable_name($variable);
214 # no doubt this is grossly inefficient and
215 # could be done much easier and faster in XS
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 },
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);
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);
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);
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);
246 confess "This should never ever ever happen";
249 $self->remove_package_glob($name);
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;
257 sub list_all_package_symbols {
258 my ($self, $type_filter) = @_;
260 my $namespace = $self->namespace;
261 return keys %{$namespace} unless defined $type_filter;
264 # or we can filter based on
265 # type (SCALAR|ARRAY|HASH|CODE)
266 if ( $type_filter eq 'CODE' ) {
268 (ref($namespace->{$_})
269 ? (ref($namespace->{$_}) eq 'SCALAR')
270 : (ref(\$namespace->{$_}) eq 'GLOB'
271 && defined(*{$namespace->{$_}}{CODE})));
272 } keys %{$namespace};
274 return grep { *{$namespace->{$_}}{$type_filter} } keys %{$namespace};
286 Class::MOP::Package - Package Meta Object
290 This is an abstraction of a Perl 5 package, it is a superclass of
291 L<Class::MOP::Class> and provides all of the symbol table
292 introspection methods.
296 B<Class::MOP::Package> is a subclass of L<Class::MOP::Object>
304 Returns a metaclass for this package.
306 =item B<initialize ($package_name)>
308 This will initialize a Class::MOP::Package instance which represents
309 the package of C<$package_name>.
311 =item B<reinitialize ($package_name, %options)>
313 This removes the old metaclass, and creates a new one in it's place.
314 Do B<not> use this unless you really know what you are doing, it could
315 very easily make a very large mess of your program.
319 This is a read-only attribute which returns the package name for the
324 This returns a HASH reference to the symbol table. The keys of the
325 HASH are the symbol names, and the values are typeglob references.
327 =item B<add_package_symbol ($variable_name, ?$initial_value)>
329 Given a C<$variable_name>, which must contain a leading sigil, this
330 method will create that variable within the package which houses the
331 class. It also takes an optional C<$initial_value>, which must be a
332 reference of the same type as the sigil of the C<$variable_name>
335 =item B<get_package_symbol ($variable_name)>
337 This will return a reference to the package variable in
340 =item B<has_package_symbol ($variable_name)>
342 Returns true (C<1>) if there is a package variable defined for
343 C<$variable_name>, and false (C<0>) otherwise.
345 =item B<remove_package_symbol ($variable_name)>
347 This will attempt to remove the package variable at C<$variable_name>.
349 =item B<remove_package_glob ($glob_name)>
351 This will attempt to remove the entire typeglob associated with
352 C<$glob_name> from the package.
354 =item B<list_all_package_symbols (?$type_filter)>
356 This will list all the glob names associated with the current package.
357 By inspecting the globs returned you can discern all the variables in
360 By passing a C<$type_filter>, you can limit the list to only those
361 which match the filter (either SCALAR, ARRAY, HASH or CODE).
363 =item B<get_all_package_symbols (?$type_filter)>
365 Works exactly like C<list_all_package_symbols> but returns a HASH of
366 name => thing mapping instead of just an ARRAY of names.
372 Stevan Little E<lt>stevan@iinteractive.comE<gt>
374 =head1 COPYRIGHT AND LICENSE
376 Copyright 2006-2009 by Infinity Interactive, Inc.
378 L<http://www.iinteractive.com>
380 This library is free software; you can redistribute it and/or modify
381 it under the same terms as Perl itself.