2 package Class::MOP::Package;
7 use Scalar::Util 'blessed', 'reftype';
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
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 no warnings 'uninitialized';
99 \%{$_[0]->{'package'} . '::'}
112 sub _deconstruct_variable_name {
113 my ($self, $variable) = @_;
116 || confess "You must pass a variable name";
118 my $sigil = substr($variable, 0, 1, '');
121 || confess "The variable name must include a sigil";
123 (exists $SIGIL_MAP{$sigil})
124 || confess "I do not recognize that sigil '$sigil'";
126 return ($variable, $sigil, $SIGIL_MAP{$sigil});
132 # ... these functions have to touch the symbol table itself,.. yuk
134 sub remove_package_glob {
135 my ($self, $name) = @_;
136 delete $self->namespace->{$name};
139 sub remove_package_symbol {
140 my ($self, $variable) = @_;
142 my ($name, $sigil, $type) = ref $variable eq 'HASH'
143 ? @{$variable}{qw[name sigil type]}
144 : $self->_deconstruct_variable_name($variable);
147 # no doubt this is grossly inefficient and
148 # could be done much easier and faster in XS
150 my ($scalar_desc, $array_desc, $hash_desc, $code_desc) = (
151 { sigil => '$', type => 'SCALAR', name => $name },
152 { sigil => '@', type => 'ARRAY', name => $name },
153 { sigil => '%', type => 'HASH', name => $name },
154 { sigil => '&', type => 'CODE', name => $name },
157 my ($scalar, $array, $hash, $code);
158 if ($type eq 'SCALAR') {
159 $array = $self->get_package_symbol($array_desc) if $self->has_package_symbol($array_desc);
160 $hash = $self->get_package_symbol($hash_desc) if $self->has_package_symbol($hash_desc);
161 $code = $self->get_package_symbol($code_desc) if $self->has_package_symbol($code_desc);
163 elsif ($type eq 'ARRAY') {
164 $scalar = $self->get_package_symbol($scalar_desc) if $self->has_package_symbol($scalar_desc);
165 $hash = $self->get_package_symbol($hash_desc) if $self->has_package_symbol($hash_desc);
166 $code = $self->get_package_symbol($code_desc) if $self->has_package_symbol($code_desc);
168 elsif ($type eq 'HASH') {
169 $scalar = $self->get_package_symbol($scalar_desc) if $self->has_package_symbol($scalar_desc);
170 $array = $self->get_package_symbol($array_desc) if $self->has_package_symbol($array_desc);
171 $code = $self->get_package_symbol($code_desc) if $self->has_package_symbol($code_desc);
173 elsif ($type eq 'CODE') {
174 $scalar = $self->get_package_symbol($scalar_desc) if $self->has_package_symbol($scalar_desc);
175 $array = $self->get_package_symbol($array_desc) if $self->has_package_symbol($array_desc);
176 $hash = $self->get_package_symbol($hash_desc) if $self->has_package_symbol($hash_desc);
179 confess "This should never ever ever happen";
182 $self->remove_package_glob($name);
184 $self->add_package_symbol($scalar_desc => $scalar) if defined $scalar;
185 $self->add_package_symbol($array_desc => $array) if defined $array;
186 $self->add_package_symbol($hash_desc => $hash) if defined $hash;
187 $self->add_package_symbol($code_desc => $code) if defined $code;
190 sub list_all_package_symbols {
191 my ($self, $type_filter) = @_;
193 my $namespace = $self->namespace;
194 return keys %{$namespace} unless defined $type_filter;
197 # or we can filter based on
198 # type (SCALAR|ARRAY|HASH|CODE)
199 if ( $type_filter eq 'CODE' ) {
201 (ref($namespace->{$_})
202 ? (ref($namespace->{$_}) eq 'SCALAR')
203 : (ref(\$namespace->{$_}) eq 'GLOB'
204 && defined(*{$namespace->{$_}}{CODE})));
205 } keys %{$namespace};
207 return grep { *{$namespace->{$_}}{$type_filter} } keys %{$namespace};
219 Class::MOP::Package - Package Meta Object
223 The Package Protocol provides an abstraction of a Perl 5 package. A
224 package is basically namespace, and this module provides methods for
225 looking at and changing that namespace's symbol table.
231 =item B<< Class::MOP::Package->initialize($package_name) >>
233 This method creates a new C<Class::MOP::Package> instance which
234 represents specified package. If an existing metaclass object exists
235 for the package, that will be returned instead.
237 =item B<< Class::MOP::Package->reinitialize($package_name) >>
239 This method forcibly removes any existing metaclass for the package
240 before calling C<initialize>
242 Do not call this unless you know what you are doing.
244 =item B<< $metapackage->name >>
246 This is returns the package's name, as passed to the constructor.
248 =item B<< $metapackage->namespace >>
250 This returns a hash reference to the package's symbol table. The keys
251 are symbol names and the values are typeglob references.
253 =item B<< $metapackage->add_package_symbol($variable_name, $initial_value) >>
255 This method accepts a variable name and an optional initial value. The
256 C<$variable_name> must contain a leading sigil.
258 This method creates the variable in the package's symbol table, and
259 sets it to the initial value if one was provided.
261 =item B<< $metapackage->get_package_symbol($variable_name) >>
263 Given a variable name, this method returns the variable as a reference
264 or undef if it does not exist. The C<$variable_name> must contain a
267 =item B<< $metapackage->has_package_symbol($variable_name) >>
269 Returns true if there is a package variable defined for
270 C<$variable_name>. The C<$variable_name> must contain a leading sigil.
272 =item B<< $metapackage->remove_package_symbol($variable_name) >>
274 This will remove the package variable specified C<$variable_name>. The
275 C<$variable_name> must contain a leading sigil.
277 =item B<< $metapackage->remove_package_glob($glob_name) >>
279 Given the name of a glob, this will remove that glob from the
280 package's symbol table. Glob names do not include a sigil. Removing
281 the glob removes all variables and subroutines with the specified
284 =item B<< $metapackage->list_all_package_symbols($type_filter) >>
286 This will list all the glob names associated with the current
287 package. These names do not have leading sigils.
289 You can provide an optional type filter, which should be one of
290 'SCALAR', 'ARRAY', 'HASH', or 'CODE'.
292 =item B<< $metapackage->get_all_package_symbols($type_filter) >>
294 This works much like C<list_all_package_symbols>, but it returns a
295 hash reference. The keys are glob names and the values are references
296 to the value for that name.
298 =item B<< Class::MOP::Package->meta >>
300 This will return a L<Class::MOP::Class> instance for this class.
306 Stevan Little E<lt>stevan@iinteractive.comE<gt>
308 =head1 COPYRIGHT AND LICENSE
310 Copyright 2006-2009 by Infinity Interactive, Inc.
312 L<http://www.iinteractive.com>
314 This library is free software; you can redistribute it and/or modify
315 it under the same terms as Perl itself.