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
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');
132 elsif ($type eq 'SCALAR') {
133 my $val = *{$namespace->{$name}}{$type};
134 return defined(${$val});
137 defined(*{$namespace->{$name}}{$type});
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)
227 if ( $type_filter eq 'CODE' ) {
229 (ref($namespace->{$_})
230 ? (ref($namespace->{$_}) eq 'SCALAR')
231 : (ref(\$namespace->{$_}) eq 'GLOB'
232 && defined(*{$namespace->{$_}}{CODE})));
233 } keys %{$namespace};
235 return grep { *{$namespace->{$_}}{$type_filter} } keys %{$namespace};
239 sub get_all_package_symbols {
240 my ($self, $type_filter) = @_;
241 my $namespace = $self->namespace;
243 return %$namespace unless defined $type_filter;
245 # for some reason this nasty impl is orders of magnitude aster than a clean version
246 if ( $type_filter eq 'CODE' ) {
250 (ref($namespace->{$_})
251 ? ( $_ => \&{$pkg ||= $self->name . "::$_"} )
252 : ( *{$namespace->{$_}}{CODE}
253 ? ( $_ => *{$namespace->{$_}}{$type_filter} )
258 $_ => *{$namespace->{$_}}{$type_filter}
260 !ref($namespace->{$_}) && *{$namespace->{$_}}{$type_filter}
273 Class::MOP::Package - Package Meta Object
277 This is an abstraction of a Perl 5 package, it is a superclass of
278 L<Class::MOP::Class> and provides all of the symbol table
279 introspection methods.
287 Returns a metaclass for this package.
289 =item B<initialize ($package_name)>
291 This will initialize a Class::MOP::Package instance which represents
292 the package of C<$package_name>.
296 This is a read-only attribute which returns the package name for the
301 This returns a HASH reference to the symbol table. The keys of the
302 HASH are the symbol names, and the values are typeglob references.
304 =item B<add_package_symbol ($variable_name, ?$initial_value)>
306 Given a C<$variable_name>, which must contain a leading sigil, this
307 method will create that variable within the package which houses the
308 class. It also takes an optional C<$initial_value>, which must be a
309 reference of the same type as the sigil of the C<$variable_name>
312 =item B<get_package_symbol ($variable_name)>
314 This will return a reference to the package variable in
317 =item B<has_package_symbol ($variable_name)>
319 Returns true (C<1>) if there is a package variable defined for
320 C<$variable_name>, and false (C<0>) otherwise.
322 =item B<remove_package_symbol ($variable_name)>
324 This will attempt to remove the package variable at C<$variable_name>.
326 =item B<remove_package_glob ($glob_name)>
328 This will attempt to remove the entire typeglob associated with
329 C<$glob_name> from the package.
331 =item B<list_all_package_symbols (?$type_filter)>
333 This will list all the glob names associated with the current package.
334 By inspecting the globs returned you can discern all the variables in
337 By passing a C<$type_filter>, you can limit the list to only those
338 which match the filter (either SCALAR, ARRAY, HASH or CODE).
340 =item B<get_all_package_symbols (?$type_filter)>
342 Works exactly like C<list_all_package_symbols> but returns a HASH of
343 name => thing mapping instead of just an ARRAY of names.
349 Stevan Little E<lt>stevan@iinteractive.comE<gt>
351 =head1 COPYRIGHT AND LICENSE
353 Copyright 2006-2008 by Infinity Interactive, Inc.
355 L<http://www.iinteractive.com>
357 This library is free software; you can redistribute it and/or modify
358 it under the same terms as Perl itself.