2 package Class::MOP::Package;
7 use Scalar::Util 'blessed';
10 our $VERSION = '0.89';
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
61 my $options = @_ == 1 ? $_[0] : {@_};
64 # because of issues with the Perl API
65 # to the typeglob in some versions, we
66 # need to just always grab a new
67 # reference to the hash in the accessor.
68 # Ideally we could just store a ref and
69 # it would Just Work, but oh well :\
70 $options->{namespace} ||= \undef;
72 bless $options, $class;
78 # all these attribute readers will be bootstrapped
79 # away in the Class::MOP bootstrap section
83 # because of issues with the Perl API
84 # to the typeglob in some versions, we
85 # need to just always grab a new
86 # reference to the hash here. Ideally
87 # we could just store a ref and it would
88 # Just Work, but oh well :\
90 \%{$_[0]->{'package'} . '::'}
103 sub _deconstruct_variable_name {
104 my ($self, $variable) = @_;
107 || confess "You must pass a variable name";
109 my $sigil = substr($variable, 0, 1, '');
112 || confess "The variable name must include a sigil";
114 (exists $SIGIL_MAP{$sigil})
115 || confess "I do not recognize that sigil '$sigil'";
117 return ($variable, $sigil, $SIGIL_MAP{$sigil});
123 # ... these functions have to touch the symbol table itself,.. yuk
125 sub add_package_symbol {
126 my ($self, $variable, $initial_value) = @_;
128 my ($name, $sigil, $type) = ref $variable eq 'HASH'
129 ? @{$variable}{qw[name sigil type]}
130 : $self->_deconstruct_variable_name($variable);
132 my $pkg = $self->{'package'};
135 no warnings 'redefine', 'misc', 'prototype';
136 *{$pkg . '::' . $name} = ref $initial_value ? $initial_value : \$initial_value;
139 sub remove_package_glob {
140 my ($self, $name) = @_;
142 delete ${$self->name . '::'}{$name};
145 # ... these functions deal with stuff on the namespace level
147 sub has_package_symbol {
148 my ($self, $variable) = @_;
150 my ($name, $sigil, $type) = ref $variable eq 'HASH'
151 ? @{$variable}{qw[name sigil type]}
152 : $self->_deconstruct_variable_name($variable);
154 my $namespace = $self->namespace;
156 return 0 unless exists $namespace->{$name};
158 my $entry_ref = \$namespace->{$name};
159 if (ref($entry_ref) eq 'GLOB') {
160 if ($type eq 'SCALAR') {
161 return defined(${ *{$entry_ref}{SCALAR} });
164 return defined(*{$entry_ref}{$type});
168 # a symbol table entry can be -1 (stub), string (stub with prototype),
169 # or reference (constant)
170 return $type eq 'CODE';
174 sub get_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);
181 my $namespace = $self->namespace;
184 $self->add_package_symbol($variable)
185 unless exists $namespace->{$name};
187 my $entry_ref = \$namespace->{$name};
189 if (ref($entry_ref) eq 'GLOB') {
190 return *{$entry_ref}{$type};
195 return \&{$self->name . '::' . $name};
203 sub remove_package_symbol {
204 my ($self, $variable) = @_;
206 my ($name, $sigil, $type) = ref $variable eq 'HASH'
207 ? @{$variable}{qw[name sigil type]}
208 : $self->_deconstruct_variable_name($variable);
211 # no doubt this is grossly inefficient and
212 # could be done much easier and faster in XS
214 my ($scalar_desc, $array_desc, $hash_desc, $code_desc) = (
215 { sigil => '$', type => 'SCALAR', name => $name },
216 { sigil => '@', type => 'ARRAY', name => $name },
217 { sigil => '%', type => 'HASH', name => $name },
218 { sigil => '&', type => 'CODE', name => $name },
221 my ($scalar, $array, $hash, $code);
222 if ($type eq 'SCALAR') {
223 $array = $self->get_package_symbol($array_desc) if $self->has_package_symbol($array_desc);
224 $hash = $self->get_package_symbol($hash_desc) if $self->has_package_symbol($hash_desc);
225 $code = $self->get_package_symbol($code_desc) if $self->has_package_symbol($code_desc);
227 elsif ($type eq 'ARRAY') {
228 $scalar = $self->get_package_symbol($scalar_desc) if $self->has_package_symbol($scalar_desc);
229 $hash = $self->get_package_symbol($hash_desc) if $self->has_package_symbol($hash_desc);
230 $code = $self->get_package_symbol($code_desc) if $self->has_package_symbol($code_desc);
232 elsif ($type eq 'HASH') {
233 $scalar = $self->get_package_symbol($scalar_desc) if $self->has_package_symbol($scalar_desc);
234 $array = $self->get_package_symbol($array_desc) if $self->has_package_symbol($array_desc);
235 $code = $self->get_package_symbol($code_desc) if $self->has_package_symbol($code_desc);
237 elsif ($type eq 'CODE') {
238 $scalar = $self->get_package_symbol($scalar_desc) if $self->has_package_symbol($scalar_desc);
239 $array = $self->get_package_symbol($array_desc) if $self->has_package_symbol($array_desc);
240 $hash = $self->get_package_symbol($hash_desc) if $self->has_package_symbol($hash_desc);
243 confess "This should never ever ever happen";
246 $self->remove_package_glob($name);
248 $self->add_package_symbol($scalar_desc => $scalar) if defined $scalar;
249 $self->add_package_symbol($array_desc => $array) if defined $array;
250 $self->add_package_symbol($hash_desc => $hash) if defined $hash;
251 $self->add_package_symbol($code_desc => $code) if defined $code;
254 sub list_all_package_symbols {
255 my ($self, $type_filter) = @_;
257 my $namespace = $self->namespace;
258 return keys %{$namespace} unless defined $type_filter;
261 # or we can filter based on
262 # type (SCALAR|ARRAY|HASH|CODE)
263 if ( $type_filter eq 'CODE' ) {
265 (ref($namespace->{$_})
266 ? (ref($namespace->{$_}) eq 'SCALAR')
267 : (ref(\$namespace->{$_}) eq 'GLOB'
268 && defined(*{$namespace->{$_}}{CODE})));
269 } keys %{$namespace};
271 return grep { *{$namespace->{$_}}{$type_filter} } keys %{$namespace};
283 Class::MOP::Package - Package Meta Object
287 The Package Protocol provides an abstraction of a Perl 5 package. A
288 package is basically namespace, and this module provides methods for
289 looking at and changing that namespace's symbol table.
295 =item B<< Class::MOP::Package->initialize($package_name) >>
297 This method creates a new C<Class::MOP::Package> instance which
298 represents specified package. If an existing metaclass object exists
299 for the package, that will be returned instead.
301 =item B<< Class::MOP::Package->reinitialize($package_name) >>
303 This method forcibly removes any existing metaclass for the package
304 before calling C<initialize>
306 Do not call this unless you know what you are doing.
308 =item B<< $metapackage->name >>
310 This is returns the package's name, as passed to the constructor.
312 =item B<< $metapackage->namespace >>
314 This returns a hash reference to the package's symbol table. The keys
315 are symbol names and the values are typeglob references.
317 =item B<< $metapackage->add_package_symbol($variable_name, $initial_value) >>
319 This method accepts a variable name and an optional initial value. The
320 C<$variable_name> must contain a leading sigil.
322 This method creates the variable in the package's symbol table, and
323 sets it to the initial value if one was provided.
325 =item B<< $metapackage->get_package_symbol($variable_name) >>
327 Given a variable name, this method returns the variable as a reference
328 or undef if it does not exist. The C<$variable_name> must contain a
331 =item B<< $metapackage->has_package_symbol($variable_name) >>
333 Returns true if there is a package variable defined for
334 C<$variable_name>. The C<$variable_name> must contain a leading sigil.
336 =item B<< $metapackage->remove_package_symbol($variable_name) >>
338 This will remove the package variable specified C<$variable_name>. The
339 C<$variable_name> must contain a leading sigil.
341 =item B<< $metapackage->remove_package_glob($glob_name) >>
343 Given the name of a glob, this will remove that glob from the
344 package's symbol table. Glob names do not include a sigil. Removing
345 the glob removes all variables and subroutines with the specified
348 =item B<< $metapackage->list_all_package_symbols($type_filter) >>
350 This will list all the glob names associated with the current
351 package. These names do not have leading sigils.
353 You can provide an optional type filter, which should be one of
354 'SCALAR', 'ARRAY', 'HASH', or 'CODE'.
356 =item B<< $metapackage->get_all_package_symbols($type_filter) >>
358 This works much like C<list_all_package_symbols>, but it returns a
359 hash reference. The keys are glob names and the values are references
360 to the value for that name.
362 =item B<< Class::MOP::Package->meta >>
364 This will return a L<Class::MOP::Class> instance for this class.
370 Stevan Little E<lt>stevan@iinteractive.comE<gt>
372 =head1 COPYRIGHT AND LICENSE
374 Copyright 2006-2009 by Infinity Interactive, Inc.
376 L<http://www.iinteractive.com>
378 This library is free software; you can redistribute it and/or modify
379 it under the same terms as Perl itself.