2 package Class::MOP::Package;
7 use Scalar::Util 'blessed', 'reftype';
10 our $VERSION = '0.97';
11 $VERSION = eval $VERSION;
12 our $AUTHORITY = 'cpan:STEVAN';
14 use base 'Class::MOP::HasMethods';
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,
36 Class::MOP::store_metaclass_by_name($package_name, $meta);
43 my ( $class, @args ) = @_;
45 unshift @args, "package" if @args % 2;
48 my $package_name = delete $options{package};
50 (defined $package_name && $package_name
51 && (!blessed $package_name || $package_name->isa('Class::MOP::Package')))
52 || confess "You must pass a package name or an existing Class::MOP::Package instance";
54 $package_name = $package_name->name
55 if blessed $package_name;
57 Class::MOP::remove_metaclass_by_name($package_name);
59 $class->initialize($package_name, %options); # call with first arg form for compat
65 return Class::MOP::Class->initialize($class)->new_object(@_)
66 if $class ne __PACKAGE__;
68 my $params = @_ == 1 ? $_[0] : {@_};
71 package => $params->{package},
74 # because of issues with the Perl API
75 # to the typeglob in some versions, we
76 # need to just always grab a new
77 # reference to the hash in the accessor.
78 # Ideally we could just store a ref and
79 # it would Just Work, but oh well :\
89 # all these attribute readers will be bootstrapped
90 # away in the Class::MOP bootstrap section
94 # because of issues with the Perl API
95 # to the typeglob in some versions, we
96 # need to just always grab a new
97 # reference to the hash here. Ideally
98 # we could just store a ref and it would
99 # Just Work, but oh well :\
101 \%{$_[0]->{'package'} . '::'}
114 sub _deconstruct_variable_name {
115 my ($self, $variable) = @_;
118 || confess "You must pass a variable name";
120 my $sigil = substr($variable, 0, 1, '');
123 || confess "The variable name must include a sigil";
125 (exists $SIGIL_MAP{$sigil})
126 || confess "I do not recognize that sigil '$sigil'";
128 return ($variable, $sigil, $SIGIL_MAP{$sigil});
134 # ... these functions have to touch the symbol table itself,.. yuk
136 sub add_package_symbol {
137 my ($self, $variable, $initial_value) = @_;
139 my ($name, $sigil, $type) = ref $variable eq 'HASH'
140 ? @{$variable}{qw[name sigil type]}
141 : $self->_deconstruct_variable_name($variable);
143 my $pkg = $self->{'package'};
146 no warnings 'redefine', 'misc', 'prototype';
147 *{$pkg . '::' . $name} = ref $initial_value ? $initial_value : \$initial_value;
150 sub remove_package_glob {
151 my ($self, $name) = @_;
153 delete ${$self->name . '::'}{$name};
156 # ... these functions deal with stuff on the namespace level
158 sub has_package_symbol {
159 my ( $self, $variable ) = @_;
161 my ( $name, $sigil, $type )
162 = ref $variable eq 'HASH'
163 ? @{$variable}{qw[name sigil type]}
164 : $self->_deconstruct_variable_name($variable);
166 my $namespace = $self->namespace;
168 return 0 unless exists $namespace->{$name};
170 my $entry_ref = \$namespace->{$name};
171 if ( reftype($entry_ref) eq 'GLOB' ) {
172 if ( $type eq 'SCALAR' ) {
173 return defined( ${ *{$entry_ref}{SCALAR} } );
176 return defined( *{$entry_ref}{$type} );
181 # a symbol table entry can be -1 (stub), string (stub with prototype),
182 # or reference (constant)
183 return $type eq 'CODE';
187 sub get_package_symbol {
188 my ($self, $variable) = @_;
190 my ($name, $sigil, $type) = ref $variable eq 'HASH'
191 ? @{$variable}{qw[name sigil type]}
192 : $self->_deconstruct_variable_name($variable);
194 my $namespace = $self->namespace;
197 $self->add_package_symbol($variable)
198 unless exists $namespace->{$name};
200 my $entry_ref = \$namespace->{$name};
202 if ( ref($entry_ref) eq 'GLOB' ) {
203 return *{$entry_ref}{$type};
206 if ( $type eq 'CODE' ) {
208 return \&{ $self->name . '::' . $name };
216 sub remove_package_symbol {
217 my ($self, $variable) = @_;
219 my ($name, $sigil, $type) = ref $variable eq 'HASH'
220 ? @{$variable}{qw[name sigil type]}
221 : $self->_deconstruct_variable_name($variable);
224 # no doubt this is grossly inefficient and
225 # could be done much easier and faster in XS
227 my ($scalar_desc, $array_desc, $hash_desc, $code_desc) = (
228 { sigil => '$', type => 'SCALAR', name => $name },
229 { sigil => '@', type => 'ARRAY', name => $name },
230 { sigil => '%', type => 'HASH', name => $name },
231 { sigil => '&', type => 'CODE', name => $name },
234 my ($scalar, $array, $hash, $code);
235 if ($type eq 'SCALAR') {
236 $array = $self->get_package_symbol($array_desc) if $self->has_package_symbol($array_desc);
237 $hash = $self->get_package_symbol($hash_desc) if $self->has_package_symbol($hash_desc);
238 $code = $self->get_package_symbol($code_desc) if $self->has_package_symbol($code_desc);
240 elsif ($type eq 'ARRAY') {
241 $scalar = $self->get_package_symbol($scalar_desc) if $self->has_package_symbol($scalar_desc);
242 $hash = $self->get_package_symbol($hash_desc) if $self->has_package_symbol($hash_desc);
243 $code = $self->get_package_symbol($code_desc) if $self->has_package_symbol($code_desc);
245 elsif ($type eq 'HASH') {
246 $scalar = $self->get_package_symbol($scalar_desc) if $self->has_package_symbol($scalar_desc);
247 $array = $self->get_package_symbol($array_desc) if $self->has_package_symbol($array_desc);
248 $code = $self->get_package_symbol($code_desc) if $self->has_package_symbol($code_desc);
250 elsif ($type eq 'CODE') {
251 $scalar = $self->get_package_symbol($scalar_desc) if $self->has_package_symbol($scalar_desc);
252 $array = $self->get_package_symbol($array_desc) if $self->has_package_symbol($array_desc);
253 $hash = $self->get_package_symbol($hash_desc) if $self->has_package_symbol($hash_desc);
256 confess "This should never ever ever happen";
259 $self->remove_package_glob($name);
261 $self->add_package_symbol($scalar_desc => $scalar) if defined $scalar;
262 $self->add_package_symbol($array_desc => $array) if defined $array;
263 $self->add_package_symbol($hash_desc => $hash) if defined $hash;
264 $self->add_package_symbol($code_desc => $code) if defined $code;
267 sub list_all_package_symbols {
268 my ($self, $type_filter) = @_;
270 my $namespace = $self->namespace;
271 return keys %{$namespace} unless defined $type_filter;
274 # or we can filter based on
275 # type (SCALAR|ARRAY|HASH|CODE)
276 if ( $type_filter eq 'CODE' ) {
278 (ref($namespace->{$_})
279 ? (ref($namespace->{$_}) eq 'SCALAR')
280 : (ref(\$namespace->{$_}) eq 'GLOB'
281 && defined(*{$namespace->{$_}}{CODE})));
282 } keys %{$namespace};
284 return grep { *{$namespace->{$_}}{$type_filter} } keys %{$namespace};
296 Class::MOP::Package - Package Meta Object
300 The Package Protocol provides an abstraction of a Perl 5 package. A
301 package is basically namespace, and this module provides methods for
302 looking at and changing that namespace's symbol table.
308 =item B<< Class::MOP::Package->initialize($package_name) >>
310 This method creates a new C<Class::MOP::Package> instance which
311 represents specified package. If an existing metaclass object exists
312 for the package, that will be returned instead.
314 =item B<< Class::MOP::Package->reinitialize($package) >>
316 This method forcibly removes any existing metaclass for the package
317 before calling C<initialize>. In contrast to C<initialize>, you may
318 also pass an existing C<Class::MOP::Package> instance instead of just
319 a package name as C<$package>.
321 Do not call this unless you know what you are doing.
323 =item B<< $metapackage->name >>
325 This is returns the package's name, as passed to the constructor.
327 =item B<< $metapackage->namespace >>
329 This returns a hash reference to the package's symbol table. The keys
330 are symbol names and the values are typeglob references.
332 =item B<< $metapackage->add_package_symbol($variable_name, $initial_value) >>
334 This method accepts a variable name and an optional initial value. The
335 C<$variable_name> must contain a leading sigil.
337 This method creates the variable in the package's symbol table, and
338 sets it to the initial value if one was provided.
340 =item B<< $metapackage->get_package_symbol($variable_name) >>
342 Given a variable name, this method returns the variable as a reference
343 or undef if it does not exist. The C<$variable_name> must contain a
346 =item B<< $metapackage->has_package_symbol($variable_name) >>
348 Returns true if there is a package variable defined for
349 C<$variable_name>. The C<$variable_name> must contain a leading sigil.
351 =item B<< $metapackage->remove_package_symbol($variable_name) >>
353 This will remove the package variable specified C<$variable_name>. The
354 C<$variable_name> must contain a leading sigil.
356 =item B<< $metapackage->remove_package_glob($glob_name) >>
358 Given the name of a glob, this will remove that glob from the
359 package's symbol table. Glob names do not include a sigil. Removing
360 the glob removes all variables and subroutines with the specified
363 =item B<< $metapackage->list_all_package_symbols($type_filter) >>
365 This will list all the glob names associated with the current
366 package. These names do not have leading sigils.
368 You can provide an optional type filter, which should be one of
369 'SCALAR', 'ARRAY', 'HASH', or 'CODE'.
371 =item B<< $metapackage->get_all_package_symbols($type_filter) >>
373 This works much like C<list_all_package_symbols>, but it returns a
374 hash reference. The keys are glob names and the values are references
375 to the value for that name.
379 =head2 Method introspection and creation
381 These methods allow you to introspect a class's methods, as well as
382 add, remove, or change methods.
384 Determining what is truly a method in a Perl 5 class requires some
385 heuristics (aka guessing).
387 Methods defined outside the package with a fully qualified name (C<sub
388 Package::name { ... }>) will be included. Similarly, methods named
389 with a fully qualified name using L<Sub::Name> are also included.
391 However, we attempt to ignore imported functions.
393 Ultimately, we are using heuristics to determine what truly is a
394 method in a class, and these heuristics may get the wrong answer in
395 some edge cases. However, for most "normal" cases the heuristics work
400 =item B<< $metapackage->get_method($method_name) >>
402 This will return a L<Class::MOP::Method> for the specified
403 C<$method_name>. If the class does not have the specified method, it
406 =item B<< $metapackage->has_method($method_name) >>
408 Returns a boolean indicating whether or not the class defines the
409 named method. It does not include methods inherited from parent
412 =item B<< $metapackage->get_method_list >>
414 This will return a list of method I<names> for all methods defined in
417 =item B<< $metapackage->add_method($method_name, $method) >>
419 This method takes a method name and a subroutine reference, and adds
420 the method to the class.
422 The subroutine reference can be a L<Class::MOP::Method>, and you are
423 strongly encouraged to pass a meta method object instead of a code
424 reference. If you do so, that object gets stored as part of the
425 class's method map directly. If not, the meta information will have to
426 be recreated later, and may be incorrect.
428 If you provide a method object, this method will clone that object if
429 the object's package name does not match the class name. This lets us
430 track the original source of any methods added from other classes
431 (notably Moose roles).
433 =item B<< $metapackage->remove_method($method_name) >>
435 Remove the named method from the class. This method returns the
436 L<Class::MOP::Method> object for the method.
438 =item B<< $metapackage->method_metaclass >>
440 Returns the class name of the method metaclass, see
441 L<Class::MOP::Method> for more information on the method metaclass.
443 =item B<< $metapackage->wrapped_method_metaclass >>
445 Returns the class name of the wrapped method metaclass, see
446 L<Class::MOP::Method::Wrapped> for more information on the wrapped
449 =item B<< Class::MOP::Package->meta >>
451 This will return a L<Class::MOP::Class> instance for this class.
457 Stevan Little E<lt>stevan@iinteractive.comE<gt>
459 =head1 COPYRIGHT AND LICENSE
461 Copyright 2006-2009 by Infinity Interactive, Inc.
463 L<http://www.iinteractive.com>
465 This library is free software; you can redistribute it and/or modify
466 it under the same terms as Perl itself.