2 package Class::MOP::Package;
7 use Scalar::Util 'blessed';
10 our $VERSION = '0.64';
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
24 '$!package' => $package_name,
26 # because of issues with the Perl API
27 # to the typeglob in some versions, we
28 # need to just always grab a new
29 # reference to the hash in the accessor.
30 # Ideally we could just store a ref and
31 # it would Just Work, but oh well :\
32 '%!namespace' => \undef,
39 # all these attribute readers will be bootstrapped
40 # away in the Class::MOP bootstrap section
42 sub name { $_[0]->{'$!package'} }
45 # because of issues with the Perl API
46 # to the typeglob in some versions, we
47 # need to just always grab a new
48 # reference to the hash here. Ideally
49 # we could just store a ref and it would
50 # Just Work, but oh well :\
52 \%{$_[0]->{'$!package'} . '::'}
65 sub _deconstruct_variable_name {
66 my ($self, $variable) = @_;
69 || confess "You must pass a variable name";
71 my $sigil = substr($variable, 0, 1, '');
74 || confess "The variable name must include a sigil";
76 (exists $SIGIL_MAP{$sigil})
77 || confess "I do not recognize that sigil '$sigil'";
79 return ($variable, $sigil, $SIGIL_MAP{$sigil});
85 # ... these functions have to touch the symbol table itself,.. yuk
87 sub add_package_symbol {
88 my ($self, $variable, $initial_value) = @_;
90 my ($name, $sigil, $type) = ref $variable eq 'HASH'
91 ? @{$variable}{qw[name sigil type]}
92 : $self->_deconstruct_variable_name($variable);
94 my $pkg = $self->{'$!package'};
97 no warnings 'redefine', 'misc';
98 *{$pkg . '::' . $name} = ref $initial_value ? $initial_value : \$initial_value;
101 sub remove_package_glob {
102 my ($self, $name) = @_;
104 delete ${$self->name . '::'}{$name};
107 # ... these functions deal with stuff on the namespace level
109 sub has_package_symbol {
110 my ($self, $variable) = @_;
112 my ($name, $sigil, $type) = ref $variable eq 'HASH'
113 ? @{$variable}{qw[name sigil type]}
114 : $self->_deconstruct_variable_name($variable);
116 my $namespace = $self->namespace;
118 return 0 unless exists $namespace->{$name};
121 # For some really stupid reason
122 # a typeglob will have a default
123 # value of \undef in the SCALAR
124 # slot, so we need to work around
125 # this. Which of course means that
126 # if you put \undef in your scalar
127 # then this is broken.
129 if (ref($namespace->{$name}) eq 'SCALAR') {
130 return ($type eq 'CODE' ? 1 : 0);
132 elsif ($type eq 'SCALAR') {
133 my $val = *{$namespace->{$name}}{$type};
134 return defined(${$val}) ? 1 : 0;
137 defined(*{$namespace->{$name}}{$type}) ? 1 : 0;
141 sub get_package_symbol {
142 my ($self, $variable) = @_;
144 my ($name, $sigil, $type) = ref $variable eq 'HASH'
145 ? @{$variable}{qw[name sigil type]}
146 : $self->_deconstruct_variable_name($variable);
148 my $namespace = $self->namespace;
150 $self->add_package_symbol($variable)
151 unless exists $namespace->{$name};
153 if (ref($namespace->{$name}) eq 'SCALAR') {
154 if ($type eq 'CODE') {
156 return \&{$self->name.'::'.$name};
163 return *{$namespace->{$name}}{$type};
167 sub remove_package_symbol {
168 my ($self, $variable) = @_;
170 my ($name, $sigil, $type) = ref $variable eq 'HASH'
171 ? @{$variable}{qw[name sigil type]}
172 : $self->_deconstruct_variable_name($variable);
175 # no doubt this is grossly inefficient and
176 # could be done much easier and faster in XS
178 my ($scalar_desc, $array_desc, $hash_desc, $code_desc) = (
179 { sigil => '$', type => 'SCALAR', name => $name },
180 { sigil => '@', type => 'ARRAY', name => $name },
181 { sigil => '%', type => 'HASH', name => $name },
182 { sigil => '&', type => 'CODE', name => $name },
185 my ($scalar, $array, $hash, $code);
186 if ($type eq 'SCALAR') {
187 $array = $self->get_package_symbol($array_desc) if $self->has_package_symbol($array_desc);
188 $hash = $self->get_package_symbol($hash_desc) if $self->has_package_symbol($hash_desc);
189 $code = $self->get_package_symbol($code_desc) if $self->has_package_symbol($code_desc);
191 elsif ($type eq 'ARRAY') {
192 $scalar = $self->get_package_symbol($scalar_desc) if $self->has_package_symbol($scalar_desc);
193 $hash = $self->get_package_symbol($hash_desc) if $self->has_package_symbol($hash_desc);
194 $code = $self->get_package_symbol($code_desc) if $self->has_package_symbol($code_desc);
196 elsif ($type eq 'HASH') {
197 $scalar = $self->get_package_symbol($scalar_desc) if $self->has_package_symbol($scalar_desc);
198 $array = $self->get_package_symbol($array_desc) if $self->has_package_symbol($array_desc);
199 $code = $self->get_package_symbol($code_desc) if $self->has_package_symbol($code_desc);
201 elsif ($type eq 'CODE') {
202 $scalar = $self->get_package_symbol($scalar_desc) if $self->has_package_symbol($scalar_desc);
203 $array = $self->get_package_symbol($array_desc) if $self->has_package_symbol($array_desc);
204 $hash = $self->get_package_symbol($hash_desc) if $self->has_package_symbol($hash_desc);
207 confess "This should never ever ever happen";
210 $self->remove_package_glob($name);
212 $self->add_package_symbol($scalar_desc => $scalar) if defined $scalar;
213 $self->add_package_symbol($array_desc => $array) if defined $array;
214 $self->add_package_symbol($hash_desc => $hash) if defined $hash;
215 $self->add_package_symbol($code_desc => $code) if defined $code;
218 sub list_all_package_symbols {
219 my ($self, $type_filter) = @_;
221 my $namespace = $self->namespace;
222 return keys %{$namespace} unless defined $type_filter;
225 # or we can filter based on
226 # type (SCALAR|ARRAY|HASH|CODE)
228 (ref($namespace->{$_})
229 ? (ref($namespace->{$_}) eq 'SCALAR' && $type_filter eq 'CODE')
230 : (ref(\$namespace->{$_}) eq 'GLOB'
231 && defined(*{$namespace->{$_}}{$type_filter})));
232 } keys %{$namespace};
235 sub get_all_package_symbols {
236 my ($self, $type_filter) = @_;
237 my $namespace = $self->namespace;
238 return %{$namespace} unless defined $type_filter;
241 # or we can filter based on
242 # type (SCALAR|ARRAY|HASH|CODE)
245 $_ => (ref($namespace->{$_}) eq 'SCALAR'
246 ? ($type_filter eq 'CODE' ? \&{$self->name . '::' . $_} : undef)
247 : *{$namespace->{$_}}{$type_filter})
249 (ref($namespace->{$_})
250 ? (ref($namespace->{$_}) eq 'SCALAR' && $type_filter eq 'CODE')
251 : (ref(\$namespace->{$_}) eq 'GLOB'
252 && defined(*{$namespace->{$_}}{$type_filter})));
253 } keys %{$namespace};
264 Class::MOP::Package - Package Meta Object
268 This is an abstraction of a Perl 5 package, it is a superclass of
269 L<Class::MOP::Class> and provides all of the symbol table
270 introspection methods.
278 Returns a metaclass for this package.
280 =item B<initialize ($package_name)>
282 This will initialize a Class::MOP::Package instance which represents
283 the package of C<$package_name>.
287 This is a read-only attribute which returns the package name for the
292 This returns a HASH reference to the symbol table. The keys of the
293 HASH are the symbol names, and the values are typeglob references.
295 =item B<add_package_symbol ($variable_name, ?$initial_value)>
297 Given a C<$variable_name>, which must contain a leading sigil, this
298 method will create that variable within the package which houses the
299 class. It also takes an optional C<$initial_value>, which must be a
300 reference of the same type as the sigil of the C<$variable_name>
303 =item B<get_package_symbol ($variable_name)>
305 This will return a reference to the package variable in
308 =item B<has_package_symbol ($variable_name)>
310 Returns true (C<1>) if there is a package variable defined for
311 C<$variable_name>, and false (C<0>) otherwise.
313 =item B<remove_package_symbol ($variable_name)>
315 This will attempt to remove the package variable at C<$variable_name>.
317 =item B<remove_package_glob ($glob_name)>
319 This will attempt to remove the entire typeglob associated with
320 C<$glob_name> from the package.
322 =item B<list_all_package_symbols (?$type_filter)>
324 This will list all the glob names associated with the current package.
325 By inspecting the globs returned you can discern all the variables in
328 By passing a C<$type_filter>, you can limit the list to only those
329 which match the filter (either SCALAR, ARRAY, HASH or CODE).
331 =item B<get_all_package_symbols (?$type_filter)>
333 Works exactly like C<list_all_package_symbols> but returns a HASH of
334 name => thing mapping instead of just an ARRAY of names.
340 Stevan Little E<lt>stevan@iinteractive.comE<gt>
342 =head1 COPYRIGHT AND LICENSE
344 Copyright 2006-2008 by Infinity Interactive, Inc.
346 L<http://www.iinteractive.com>
348 This library is free software; you can redistribute it and/or modify
349 it under the same terms as Perl itself.