2 package Class::MOP::Package;
7 use Scalar::Util 'blessed';
10 our $VERSION = '0.65';
11 our $AUTHORITY = 'cpan:STEVAN';
13 use base 'Class::MOP::Object';
19 my $package_name = shift;
20 # we hand-construct the class
21 # until we can bootstrap it
23 'package' => $package_name,
28 my ( $class, @args ) = @_;
32 # because of issues with the Perl API
33 # to the typeglob in some versions, we
34 # need to just always grab a new
35 # reference to the hash in the accessor.
36 # Ideally we could just store a ref and
37 # it would Just Work, but oh well :\
38 'namespace' => \undef,
46 # all these attribute readers will be bootstrapped
47 # away in the Class::MOP bootstrap section
49 sub name { $_[0]->{'package'} }
52 # because of issues with the Perl API
53 # to the typeglob in some versions, we
54 # need to just always grab a new
55 # reference to the hash here. Ideally
56 # we could just store a ref and it would
57 # Just Work, but oh well :\
59 \%{$_[0]->{'package'} . '::'}
72 sub _deconstruct_variable_name {
73 my ($self, $variable) = @_;
76 || confess "You must pass a variable name";
78 my $sigil = substr($variable, 0, 1, '');
81 || confess "The variable name must include a sigil";
83 (exists $SIGIL_MAP{$sigil})
84 || confess "I do not recognize that sigil '$sigil'";
86 return ($variable, $sigil, $SIGIL_MAP{$sigil});
92 # ... these functions have to touch the symbol table itself,.. yuk
94 sub add_package_symbol {
95 my ($self, $variable, $initial_value) = @_;
97 my ($name, $sigil, $type) = ref $variable eq 'HASH'
98 ? @{$variable}{qw[name sigil type]}
99 : $self->_deconstruct_variable_name($variable);
101 my $pkg = $self->{'package'};
104 no warnings 'redefine', 'misc';
105 *{$pkg . '::' . $name} = ref $initial_value ? $initial_value : \$initial_value;
108 sub remove_package_glob {
109 my ($self, $name) = @_;
111 delete ${$self->name . '::'}{$name};
114 # ... these functions deal with stuff on the namespace level
116 sub has_package_symbol {
117 my ($self, $variable) = @_;
119 my ($name, $sigil, $type) = ref $variable eq 'HASH'
120 ? @{$variable}{qw[name sigil type]}
121 : $self->_deconstruct_variable_name($variable);
123 my $namespace = $self->namespace;
125 return 0 unless exists $namespace->{$name};
128 # For some really stupid reason
129 # a typeglob will have a default
130 # value of \undef in the SCALAR
131 # slot, so we need to work around
132 # this. Which of course means that
133 # if you put \undef in your scalar
134 # then this is broken.
136 if (ref($namespace->{$name}) eq 'SCALAR') {
137 return ($type eq 'CODE');
139 elsif ($type eq 'SCALAR') {
140 my $val = *{$namespace->{$name}}{$type};
141 return defined(${$val});
144 defined(*{$namespace->{$name}}{$type});
148 sub get_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 $self->add_package_symbol($variable)
158 unless exists $namespace->{$name};
160 if (ref($namespace->{$name}) eq 'SCALAR') {
161 if ($type eq 'CODE') {
163 return \&{$self->name.'::'.$name};
170 return *{$namespace->{$name}}{$type};
174 sub remove_package_symbol {
175 my ($self, $variable) = @_;
177 my ($name, $sigil, $type) = ref $variable eq 'HASH'
178 ? @{$variable}{qw[name sigil type]}
179 : $self->_deconstruct_variable_name($variable);
182 # no doubt this is grossly inefficient and
183 # could be done much easier and faster in XS
185 my ($scalar_desc, $array_desc, $hash_desc, $code_desc) = (
186 { sigil => '$', type => 'SCALAR', name => $name },
187 { sigil => '@', type => 'ARRAY', name => $name },
188 { sigil => '%', type => 'HASH', name => $name },
189 { sigil => '&', type => 'CODE', name => $name },
192 my ($scalar, $array, $hash, $code);
193 if ($type eq 'SCALAR') {
194 $array = $self->get_package_symbol($array_desc) if $self->has_package_symbol($array_desc);
195 $hash = $self->get_package_symbol($hash_desc) if $self->has_package_symbol($hash_desc);
196 $code = $self->get_package_symbol($code_desc) if $self->has_package_symbol($code_desc);
198 elsif ($type eq 'ARRAY') {
199 $scalar = $self->get_package_symbol($scalar_desc) if $self->has_package_symbol($scalar_desc);
200 $hash = $self->get_package_symbol($hash_desc) if $self->has_package_symbol($hash_desc);
201 $code = $self->get_package_symbol($code_desc) if $self->has_package_symbol($code_desc);
203 elsif ($type eq 'HASH') {
204 $scalar = $self->get_package_symbol($scalar_desc) if $self->has_package_symbol($scalar_desc);
205 $array = $self->get_package_symbol($array_desc) if $self->has_package_symbol($array_desc);
206 $code = $self->get_package_symbol($code_desc) if $self->has_package_symbol($code_desc);
208 elsif ($type eq 'CODE') {
209 $scalar = $self->get_package_symbol($scalar_desc) if $self->has_package_symbol($scalar_desc);
210 $array = $self->get_package_symbol($array_desc) if $self->has_package_symbol($array_desc);
211 $hash = $self->get_package_symbol($hash_desc) if $self->has_package_symbol($hash_desc);
214 confess "This should never ever ever happen";
217 $self->remove_package_glob($name);
219 $self->add_package_symbol($scalar_desc => $scalar) if defined $scalar;
220 $self->add_package_symbol($array_desc => $array) if defined $array;
221 $self->add_package_symbol($hash_desc => $hash) if defined $hash;
222 $self->add_package_symbol($code_desc => $code) if defined $code;
225 sub list_all_package_symbols {
226 my ($self, $type_filter) = @_;
228 my $namespace = $self->namespace;
229 return keys %{$namespace} unless defined $type_filter;
232 # or we can filter based on
233 # type (SCALAR|ARRAY|HASH|CODE)
234 if ( $type_filter eq 'CODE' ) {
236 (ref($namespace->{$_})
237 ? (ref($namespace->{$_}) eq 'SCALAR')
238 : (ref(\$namespace->{$_}) eq 'GLOB'
239 && defined(*{$namespace->{$_}}{CODE})));
240 } keys %{$namespace};
242 return grep { *{$namespace->{$_}}{$type_filter} } keys %{$namespace};
246 sub get_all_package_symbols {
247 my ($self, $type_filter) = @_;
248 my $namespace = $self->namespace;
250 return %$namespace unless defined $type_filter;
252 # for some reason this nasty impl is orders of magnitude aster than a clean version
253 if ( $type_filter eq 'CODE' ) {
257 (ref($namespace->{$_})
258 ? ( $_ => \&{$pkg ||= $self->name . "::$_"} )
259 : ( *{$namespace->{$_}}{CODE}
260 ? ( $_ => *{$namespace->{$_}}{$type_filter} )
265 $_ => *{$namespace->{$_}}{$type_filter}
267 !ref($namespace->{$_}) && *{$namespace->{$_}}{$type_filter}
280 Class::MOP::Package - Package Meta Object
284 This is an abstraction of a Perl 5 package, it is a superclass of
285 L<Class::MOP::Class> and provides all of the symbol table
286 introspection methods.
294 Returns a metaclass for this package.
296 =item B<initialize ($package_name)>
298 This will initialize a Class::MOP::Package instance which represents
299 the package of C<$package_name>.
303 This is a read-only attribute which returns the package name for the
308 This returns a HASH reference to the symbol table. The keys of the
309 HASH are the symbol names, and the values are typeglob references.
311 =item B<add_package_symbol ($variable_name, ?$initial_value)>
313 Given a C<$variable_name>, which must contain a leading sigil, this
314 method will create that variable within the package which houses the
315 class. It also takes an optional C<$initial_value>, which must be a
316 reference of the same type as the sigil of the C<$variable_name>
319 =item B<get_package_symbol ($variable_name)>
321 This will return a reference to the package variable in
324 =item B<has_package_symbol ($variable_name)>
326 Returns true (C<1>) if there is a package variable defined for
327 C<$variable_name>, and false (C<0>) otherwise.
329 =item B<remove_package_symbol ($variable_name)>
331 This will attempt to remove the package variable at C<$variable_name>.
333 =item B<remove_package_glob ($glob_name)>
335 This will attempt to remove the entire typeglob associated with
336 C<$glob_name> from the package.
338 =item B<list_all_package_symbols (?$type_filter)>
340 This will list all the glob names associated with the current package.
341 By inspecting the globs returned you can discern all the variables in
344 By passing a C<$type_filter>, you can limit the list to only those
345 which match the filter (either SCALAR, ARRAY, HASH or CODE).
347 =item B<get_all_package_symbols (?$type_filter)>
349 Works exactly like C<list_all_package_symbols> but returns a HASH of
350 name => thing mapping instead of just an ARRAY of names.
356 Stevan Little E<lt>stevan@iinteractive.comE<gt>
358 =head1 COPYRIGHT AND LICENSE
360 Copyright 2006-2008 by Infinity Interactive, Inc.
362 L<http://www.iinteractive.com>
364 This library is free software; you can redistribute it and/or modify
365 it under the same terms as Perl itself.