2 package Class::MOP::Package;
7 use Scalar::Util 'blessed', 'reftype';
10 our $VERSION = '0.91';
11 $VERSION = eval $VERSION;
12 our $AUTHORITY = 'cpan:STEVAN';
14 use base 'Class::MOP::Object';
19 my ( $class, @args ) = @_;
21 unshift @args, "package" if @args % 2;
24 my $package_name = $options{package};
27 # we hand-construct the class
28 # until we can bootstrap it
29 if ( my $meta = Class::MOP::get_metaclass_by_name($package_name) ) {
32 my $meta = ( ref $class || $class )->_new({
33 'package' => $package_name,
37 Class::MOP::store_metaclass_by_name($package_name, $meta);
44 my ( $class, @args ) = @_;
46 unshift @args, "package" if @args % 2;
49 my $package_name = delete $options{package};
51 (defined $package_name && $package_name && !blessed($package_name))
52 || confess "You must pass a package name and it cannot be blessed";
54 Class::MOP::remove_metaclass_by_name($package_name);
56 $class->initialize($package_name, %options); # call with first arg form for compat
62 return Class::MOP::Class->initialize($class)->new_object(@_)
63 if $class ne __PACKAGE__;
65 my $params = @_ == 1 ? $_[0] : {@_};
68 package => $params->{package},
71 # because of issues with the Perl API
72 # to the typeglob in some versions, we
73 # need to just always grab a new
74 # reference to the hash in the accessor.
75 # Ideally we could just store a ref and
76 # it would Just Work, but oh well :\
86 # all these attribute readers will be bootstrapped
87 # away in the Class::MOP bootstrap section
91 # because of issues with the Perl API
92 # to the typeglob in some versions, we
93 # need to just always grab a new
94 # reference to the hash here. Ideally
95 # we could just store a ref and it would
96 # Just Work, but oh well :\
98 \%{$_[0]->{'package'} . '::'}
111 sub _deconstruct_variable_name {
112 my ($self, $variable) = @_;
115 || confess "You must pass a variable name";
117 my $sigil = substr($variable, 0, 1, '');
120 || confess "The variable name must include a sigil";
122 (exists $SIGIL_MAP{$sigil})
123 || confess "I do not recognize that sigil '$sigil'";
125 return ($variable, $sigil, $SIGIL_MAP{$sigil});
131 # ... these functions have to touch the symbol table itself,.. yuk
133 sub add_package_symbol {
134 my ($self, $variable, $initial_value) = @_;
136 my ($name, $sigil, $type) = ref $variable eq 'HASH'
137 ? @{$variable}{qw[name sigil type]}
138 : $self->_deconstruct_variable_name($variable);
140 my $pkg = $self->{'package'};
143 no warnings 'redefine', 'misc', 'prototype';
144 *{$pkg . '::' . $name} = ref $initial_value ? $initial_value : \$initial_value;
147 sub remove_package_glob {
148 my ($self, $name) = @_;
150 delete ${$self->name . '::'}{$name};
153 # ... these functions deal with stuff on the namespace level
155 sub has_package_symbol {
156 my ( $self, $variable ) = @_;
158 my ( $name, $sigil, $type )
159 = ref $variable eq 'HASH'
160 ? @{$variable}{qw[name sigil type]}
161 : $self->_deconstruct_variable_name($variable);
163 my $namespace = $self->namespace;
165 return 0 unless exists $namespace->{$name};
167 my $entry_ref = \$namespace->{$name};
168 if ( reftype($entry_ref) eq 'GLOB' ) {
169 if ( $type eq 'SCALAR' ) {
170 return defined( ${ *{$entry_ref}{SCALAR} } );
173 return defined( *{$entry_ref}{$type} );
178 # a symbol table entry can be -1 (stub), string (stub with prototype),
179 # or reference (constant)
180 return $type eq 'CODE';
184 sub get_package_symbol {
185 my ($self, $variable) = @_;
187 my ($name, $sigil, $type) = ref $variable eq 'HASH'
188 ? @{$variable}{qw[name sigil type]}
189 : $self->_deconstruct_variable_name($variable);
191 my $namespace = $self->namespace;
194 $self->add_package_symbol($variable)
195 unless exists $namespace->{$name};
197 my $entry_ref = \$namespace->{$name};
199 if ( ref($entry_ref) eq 'GLOB' ) {
200 return *{$entry_ref}{$type};
203 if ( $type eq 'CODE' ) {
205 return \&{ $self->name . '::' . $name };
213 sub remove_package_symbol {
214 my ($self, $variable) = @_;
216 my ($name, $sigil, $type) = ref $variable eq 'HASH'
217 ? @{$variable}{qw[name sigil type]}
218 : $self->_deconstruct_variable_name($variable);
221 # no doubt this is grossly inefficient and
222 # could be done much easier and faster in XS
224 my ($scalar_desc, $array_desc, $hash_desc, $code_desc) = (
225 { sigil => '$', type => 'SCALAR', name => $name },
226 { sigil => '@', type => 'ARRAY', name => $name },
227 { sigil => '%', type => 'HASH', name => $name },
228 { sigil => '&', type => 'CODE', name => $name },
231 my ($scalar, $array, $hash, $code);
232 if ($type eq 'SCALAR') {
233 $array = $self->get_package_symbol($array_desc) if $self->has_package_symbol($array_desc);
234 $hash = $self->get_package_symbol($hash_desc) if $self->has_package_symbol($hash_desc);
235 $code = $self->get_package_symbol($code_desc) if $self->has_package_symbol($code_desc);
237 elsif ($type eq 'ARRAY') {
238 $scalar = $self->get_package_symbol($scalar_desc) if $self->has_package_symbol($scalar_desc);
239 $hash = $self->get_package_symbol($hash_desc) if $self->has_package_symbol($hash_desc);
240 $code = $self->get_package_symbol($code_desc) if $self->has_package_symbol($code_desc);
242 elsif ($type eq 'HASH') {
243 $scalar = $self->get_package_symbol($scalar_desc) if $self->has_package_symbol($scalar_desc);
244 $array = $self->get_package_symbol($array_desc) if $self->has_package_symbol($array_desc);
245 $code = $self->get_package_symbol($code_desc) if $self->has_package_symbol($code_desc);
247 elsif ($type eq 'CODE') {
248 $scalar = $self->get_package_symbol($scalar_desc) if $self->has_package_symbol($scalar_desc);
249 $array = $self->get_package_symbol($array_desc) if $self->has_package_symbol($array_desc);
250 $hash = $self->get_package_symbol($hash_desc) if $self->has_package_symbol($hash_desc);
253 confess "This should never ever ever happen";
256 $self->remove_package_glob($name);
258 $self->add_package_symbol($scalar_desc => $scalar) if defined $scalar;
259 $self->add_package_symbol($array_desc => $array) if defined $array;
260 $self->add_package_symbol($hash_desc => $hash) if defined $hash;
261 $self->add_package_symbol($code_desc => $code) if defined $code;
264 sub list_all_package_symbols {
265 my ($self, $type_filter) = @_;
267 my $namespace = $self->namespace;
268 return keys %{$namespace} unless defined $type_filter;
271 # or we can filter based on
272 # type (SCALAR|ARRAY|HASH|CODE)
273 if ( $type_filter eq 'CODE' ) {
275 (ref($namespace->{$_})
276 ? (ref($namespace->{$_}) eq 'SCALAR')
277 : (ref(\$namespace->{$_}) eq 'GLOB'
278 && defined(*{$namespace->{$_}}{CODE})));
279 } keys %{$namespace};
281 return grep { *{$namespace->{$_}}{$type_filter} } keys %{$namespace};
294 Class::MOP::Package - Package Meta Object
298 The Package Protocol provides an abstraction of a Perl 5 package. A
299 package is basically namespace, and this module provides methods for
300 looking at and changing that namespace's symbol table.
306 =item B<< Class::MOP::Package->initialize($package_name) >>
308 This method creates a new C<Class::MOP::Package> instance which
309 represents specified package. If an existing metaclass object exists
310 for the package, that will be returned instead.
312 =item B<< Class::MOP::Package->reinitialize($package_name) >>
314 This method forcibly removes any existing metaclass for the package
315 before calling C<initialize>
317 Do not call this unless you know what you are doing.
319 =item B<< $metapackage->name >>
321 This is returns the package's name, as passed to the constructor.
323 =item B<< $metapackage->namespace >>
325 This returns a hash reference to the package's symbol table. The keys
326 are symbol names and the values are typeglob references.
328 =item B<< $metapackage->add_package_symbol($variable_name, $initial_value) >>
330 This method accepts a variable name and an optional initial value. The
331 C<$variable_name> must contain a leading sigil.
333 This method creates the variable in the package's symbol table, and
334 sets it to the initial value if one was provided.
336 =item B<< $metapackage->get_package_symbol($variable_name) >>
338 Given a variable name, this method returns the variable as a reference
339 or undef if it does not exist. The C<$variable_name> must contain a
342 =item B<< $metapackage->has_package_symbol($variable_name) >>
344 Returns true if there is a package variable defined for
345 C<$variable_name>. The C<$variable_name> must contain a leading sigil.
347 =item B<< $metapackage->remove_package_symbol($variable_name) >>
349 This will remove the package variable specified C<$variable_name>. The
350 C<$variable_name> must contain a leading sigil.
352 =item B<< $metapackage->remove_package_glob($glob_name) >>
354 Given the name of a glob, this will remove that glob from the
355 package's symbol table. Glob names do not include a sigil. Removing
356 the glob removes all variables and subroutines with the specified
359 =item B<< $metapackage->list_all_package_symbols($type_filter) >>
361 This will list all the glob names associated with the current
362 package. These names do not have leading sigils.
364 You can provide an optional type filter, which should be one of
365 'SCALAR', 'ARRAY', 'HASH', or 'CODE'.
367 =item B<< $metapackage->get_all_package_symbols($type_filter) >>
369 This works much like C<list_all_package_symbols>, but it returns a
370 hash reference. The keys are glob names and the values are references
371 to the value for that name.
373 =item B<< Class::MOP::Package->meta >>
375 This will return a L<Class::MOP::Class> instance for this class.
381 Stevan Little E<lt>stevan@iinteractive.comE<gt>
383 =head1 COPYRIGHT AND LICENSE
385 Copyright 2006-2009 by Infinity Interactive, Inc.
387 L<http://www.iinteractive.com>
389 This library is free software; you can redistribute it and/or modify
390 it under the same terms as Perl itself.