2 package Class::MOP::Package;
7 use Scalar::Util 'blessed', 'reftype';
9 use Sub::Name 'subname';
11 our $VERSION = '0.94';
12 $VERSION = eval $VERSION;
13 our $AUTHORITY = 'cpan:STEVAN';
15 use base 'Class::MOP::Object';
20 my ( $class, @args ) = @_;
22 unshift @args, "package" if @args % 2;
25 my $package_name = $options{package};
28 # we hand-construct the class
29 # until we can bootstrap it
30 if ( my $meta = Class::MOP::get_metaclass_by_name($package_name) ) {
33 my $meta = ( ref $class || $class )->_new({
34 '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
52 && (!blessed $package_name || $package_name->isa('Class::MOP::Package')))
53 || confess "You must pass a package name or an existing Class::MOP::Package instance";
55 $package_name = $package_name->name
56 if blessed $package_name;
58 Class::MOP::remove_metaclass_by_name($package_name);
60 $class->initialize($package_name, %options); # call with first arg form for compat
66 return Class::MOP::Class->initialize($class)->new_object(@_)
67 if $class ne __PACKAGE__;
69 my $params = @_ == 1 ? $_[0] : {@_};
72 package => $params->{package},
75 # because of issues with the Perl API
76 # to the typeglob in some versions, we
77 # need to just always grab a new
78 # reference to the hash in the accessor.
79 # Ideally we could just store a ref and
80 # it would Just Work, but oh well :\
90 # all these attribute readers will be bootstrapped
91 # away in the Class::MOP bootstrap section
95 # because of issues with the Perl API
96 # to the typeglob in some versions, we
97 # need to just always grab a new
98 # reference to the hash here. Ideally
99 # we could just store a ref and it would
100 # Just Work, but oh well :\
102 \%{$_[0]->{'package'} . '::'}
105 sub method_metaclass { $_[0]->{'method_metaclass'} }
106 sub wrapped_method_metaclass { $_[0]->{'wrapped_method_metaclass'} }
108 # This doesn't always get initialized in a constructor because there is a
109 # weird object construction path for subclasses of Class::MOP::Class. At one
110 # point, this always got initialized by calling into the XS code first, but
111 # that is no longer guaranteed to happen.
112 sub _method_map { $_[0]->{'methods'} ||= {} }
124 sub _deconstruct_variable_name {
125 my ($self, $variable) = @_;
128 || confess "You must pass a variable name";
130 my $sigil = substr($variable, 0, 1, '');
133 || confess "The variable name must include a sigil";
135 (exists $SIGIL_MAP{$sigil})
136 || confess "I do not recognize that sigil '$sigil'";
138 return ($variable, $sigil, $SIGIL_MAP{$sigil});
144 # ... these functions have to touch the symbol table itself,.. yuk
146 sub add_package_symbol {
147 my ($self, $variable, $initial_value) = @_;
149 my ($name, $sigil, $type) = ref $variable eq 'HASH'
150 ? @{$variable}{qw[name sigil type]}
151 : $self->_deconstruct_variable_name($variable);
153 my $pkg = $self->{'package'};
156 no warnings 'redefine', 'misc', 'prototype';
157 *{$pkg . '::' . $name} = ref $initial_value ? $initial_value : \$initial_value;
160 sub remove_package_glob {
161 my ($self, $name) = @_;
163 delete ${$self->name . '::'}{$name};
166 # ... these functions deal with stuff on the namespace level
168 sub has_package_symbol {
169 my ( $self, $variable ) = @_;
171 my ( $name, $sigil, $type )
172 = ref $variable eq 'HASH'
173 ? @{$variable}{qw[name sigil type]}
174 : $self->_deconstruct_variable_name($variable);
176 my $namespace = $self->namespace;
178 return 0 unless exists $namespace->{$name};
180 my $entry_ref = \$namespace->{$name};
181 if ( reftype($entry_ref) eq 'GLOB' ) {
182 if ( $type eq 'SCALAR' ) {
183 return defined( ${ *{$entry_ref}{SCALAR} } );
186 return defined( *{$entry_ref}{$type} );
191 # a symbol table entry can be -1 (stub), string (stub with prototype),
192 # or reference (constant)
193 return $type eq 'CODE';
197 sub get_package_symbol {
198 my ($self, $variable) = @_;
200 my ($name, $sigil, $type) = ref $variable eq 'HASH'
201 ? @{$variable}{qw[name sigil type]}
202 : $self->_deconstruct_variable_name($variable);
204 my $namespace = $self->namespace;
207 $self->add_package_symbol($variable)
208 unless exists $namespace->{$name};
210 my $entry_ref = \$namespace->{$name};
212 if ( ref($entry_ref) eq 'GLOB' ) {
213 return *{$entry_ref}{$type};
216 if ( $type eq 'CODE' ) {
218 return \&{ $self->name . '::' . $name };
226 sub remove_package_symbol {
227 my ($self, $variable) = @_;
229 my ($name, $sigil, $type) = ref $variable eq 'HASH'
230 ? @{$variable}{qw[name sigil type]}
231 : $self->_deconstruct_variable_name($variable);
234 # no doubt this is grossly inefficient and
235 # could be done much easier and faster in XS
237 my ($scalar_desc, $array_desc, $hash_desc, $code_desc) = (
238 { sigil => '$', type => 'SCALAR', name => $name },
239 { sigil => '@', type => 'ARRAY', name => $name },
240 { sigil => '%', type => 'HASH', name => $name },
241 { sigil => '&', type => 'CODE', name => $name },
244 my ($scalar, $array, $hash, $code);
245 if ($type eq 'SCALAR') {
246 $array = $self->get_package_symbol($array_desc) if $self->has_package_symbol($array_desc);
247 $hash = $self->get_package_symbol($hash_desc) if $self->has_package_symbol($hash_desc);
248 $code = $self->get_package_symbol($code_desc) if $self->has_package_symbol($code_desc);
250 elsif ($type eq 'ARRAY') {
251 $scalar = $self->get_package_symbol($scalar_desc) if $self->has_package_symbol($scalar_desc);
252 $hash = $self->get_package_symbol($hash_desc) if $self->has_package_symbol($hash_desc);
253 $code = $self->get_package_symbol($code_desc) if $self->has_package_symbol($code_desc);
255 elsif ($type eq 'HASH') {
256 $scalar = $self->get_package_symbol($scalar_desc) if $self->has_package_symbol($scalar_desc);
257 $array = $self->get_package_symbol($array_desc) if $self->has_package_symbol($array_desc);
258 $code = $self->get_package_symbol($code_desc) if $self->has_package_symbol($code_desc);
260 elsif ($type eq 'CODE') {
261 $scalar = $self->get_package_symbol($scalar_desc) if $self->has_package_symbol($scalar_desc);
262 $array = $self->get_package_symbol($array_desc) if $self->has_package_symbol($array_desc);
263 $hash = $self->get_package_symbol($hash_desc) if $self->has_package_symbol($hash_desc);
266 confess "This should never ever ever happen";
269 $self->remove_package_glob($name);
271 $self->add_package_symbol($scalar_desc => $scalar) if defined $scalar;
272 $self->add_package_symbol($array_desc => $array) if defined $array;
273 $self->add_package_symbol($hash_desc => $hash) if defined $hash;
274 $self->add_package_symbol($code_desc => $code) if defined $code;
277 sub list_all_package_symbols {
278 my ($self, $type_filter) = @_;
280 my $namespace = $self->namespace;
281 return keys %{$namespace} unless defined $type_filter;
284 # or we can filter based on
285 # type (SCALAR|ARRAY|HASH|CODE)
286 if ( $type_filter eq 'CODE' ) {
288 (ref($namespace->{$_})
289 ? (ref($namespace->{$_}) eq 'SCALAR')
290 : (ref(\$namespace->{$_}) eq 'GLOB'
291 && defined(*{$namespace->{$_}}{CODE})));
292 } keys %{$namespace};
294 return grep { *{$namespace->{$_}}{$type_filter} } keys %{$namespace};
300 sub wrap_method_body {
301 my ( $self, %args ) = @_;
303 ('CODE' eq ref $args{body})
304 || confess "Your code block must be a CODE reference";
306 $self->method_metaclass->wrap(
307 package_name => $self->name,
313 my ($self, $method_name, $method) = @_;
314 (defined $method_name && $method_name)
315 || confess "You must define a method name";
318 if (blessed($method)) {
319 $body = $method->body;
320 if ($method->package_name ne $self->name) {
321 $method = $method->clone(
322 package_name => $self->name,
324 ) if $method->can('clone');
327 $method->attach_to_class($self);
330 # If a raw code reference is supplied, its method object is not created.
331 # The method object won't be created until required.
335 $self->_method_map->{$method_name} = $method;
337 my ( $current_package, $current_name ) = Class::MOP::get_code_info($body);
339 if ( !defined $current_name || $current_name eq '__ANON__' ) {
340 my $full_method_name = ($self->name . '::' . $method_name);
341 subname($full_method_name => $body);
344 $self->add_package_symbol(
345 { sigil => '&', type => 'CODE', name => $method_name },
351 my ( $self, $code ) = @_;
353 my ( $code_package, $code_name ) = Class::MOP::get_code_info($code);
355 return $code_package && $code_package eq $self->name
356 || ( $code_package eq 'constant' && $code_name eq '__ANON__' );
360 my ($self, $method_name) = @_;
361 (defined $method_name && $method_name)
362 || confess "You must define a method name";
364 return defined($self->get_method($method_name));
368 my ( $self, $method_name ) = @_;
369 ( defined $method_name && $method_name )
370 || confess "You must define a method name";
372 my $method_map = $self->_method_map;
373 my $map_entry = $method_map->{$method_name};
374 my $code = $self->get_package_symbol(
376 name => $method_name,
382 # This seems to happen in some weird cases where methods modifiers are
383 # added via roles or some other such bizareness. Honestly, I don't totally
384 # understand this, but returning the entry works, and keeps various MX
385 # modules from blowing up. - DR
386 return $map_entry if blessed $map_entry && !$code;
388 return $map_entry if blessed $map_entry && $map_entry->body == $code;
390 unless ($map_entry) {
391 return unless $code && $self->_code_is_mine($code);
394 $code ||= $map_entry;
396 return $method_map->{$method_name} = $self->wrap_method_body(
398 name => $method_name,
399 associated_metaclass => $self,
404 my ($self, $method_name) = @_;
405 (defined $method_name && $method_name)
406 || confess "You must define a method name";
408 my $removed_method = delete $self->_full_method_map->{$method_name};
410 $self->remove_package_symbol(
411 { sigil => '&', type => 'CODE', name => $method_name }
414 $removed_method->detach_from_class if $removed_method && blessed $removed_method;
416 $self->update_package_cache_flag; # still valid, since we just removed the method from the map
418 return $removed_method;
421 sub get_method_list {
423 return grep { $self->has_method($_) } keys %{ $self->namespace };
434 Class::MOP::Package - Package Meta Object
438 The Package Protocol provides an abstraction of a Perl 5 package. A
439 package is basically namespace, and this module provides methods for
440 looking at and changing that namespace's symbol table.
446 =item B<< Class::MOP::Package->initialize($package_name) >>
448 This method creates a new C<Class::MOP::Package> instance which
449 represents specified package. If an existing metaclass object exists
450 for the package, that will be returned instead.
452 =item B<< Class::MOP::Package->reinitialize($package) >>
454 This method forcibly removes any existing metaclass for the package
455 before calling C<initialize>. In contrast to C<initialize>, you may
456 also pass an existing C<Class::MOP::Package> instance instead of just
457 a package name as C<$package>.
459 Do not call this unless you know what you are doing.
461 =item B<< $metapackage->name >>
463 This is returns the package's name, as passed to the constructor.
465 =item B<< $metapackage->namespace >>
467 This returns a hash reference to the package's symbol table. The keys
468 are symbol names and the values are typeglob references.
470 =item B<< $metapackage->add_package_symbol($variable_name, $initial_value) >>
472 This method accepts a variable name and an optional initial value. The
473 C<$variable_name> must contain a leading sigil.
475 This method creates the variable in the package's symbol table, and
476 sets it to the initial value if one was provided.
478 =item B<< $metapackage->get_package_symbol($variable_name) >>
480 Given a variable name, this method returns the variable as a reference
481 or undef if it does not exist. The C<$variable_name> must contain a
484 =item B<< $metapackage->has_package_symbol($variable_name) >>
486 Returns true if there is a package variable defined for
487 C<$variable_name>. The C<$variable_name> must contain a leading sigil.
489 =item B<< $metapackage->remove_package_symbol($variable_name) >>
491 This will remove the package variable specified C<$variable_name>. The
492 C<$variable_name> must contain a leading sigil.
494 =item B<< $metapackage->remove_package_glob($glob_name) >>
496 Given the name of a glob, this will remove that glob from the
497 package's symbol table. Glob names do not include a sigil. Removing
498 the glob removes all variables and subroutines with the specified
501 =item B<< $metapackage->list_all_package_symbols($type_filter) >>
503 This will list all the glob names associated with the current
504 package. These names do not have leading sigils.
506 You can provide an optional type filter, which should be one of
507 'SCALAR', 'ARRAY', 'HASH', or 'CODE'.
509 =item B<< $metapackage->get_all_package_symbols($type_filter) >>
511 This works much like C<list_all_package_symbols>, but it returns a
512 hash reference. The keys are glob names and the values are references
513 to the value for that name.
517 =head2 Method introspection and creation
519 These methods allow you to introspect a class's methods, as well as
520 add, remove, or change methods.
522 Determining what is truly a method in a Perl 5 class requires some
523 heuristics (aka guessing).
525 Methods defined outside the package with a fully qualified name (C<sub
526 Package::name { ... }>) will be included. Similarly, methods named
527 with a fully qualified name using L<Sub::Name> are also included.
529 However, we attempt to ignore imported functions.
531 Ultimately, we are using heuristics to determine what truly is a
532 method in a class, and these heuristics may get the wrong answer in
533 some edge cases. However, for most "normal" cases the heuristics work
538 =item B<< $metapackage->get_method($method_name) >>
540 This will return a L<Class::MOP::Method> for the specified
541 C<$method_name>. If the class does not have the specified method, it
544 =item B<< $metapackage->has_method($method_name) >>
546 Returns a boolean indicating whether or not the class defines the
547 named method. It does not include methods inherited from parent
550 =item B<< $metapackage->get_method_list >>
552 This will return a list of method I<names> for all methods defined in
555 =item B<< $metapackage->add_method($method_name, $method) >>
557 This method takes a method name and a subroutine reference, and adds
558 the method to the class.
560 The subroutine reference can be a L<Class::MOP::Method>, and you are
561 strongly encouraged to pass a meta method object instead of a code
562 reference. If you do so, that object gets stored as part of the
563 class's method map directly. If not, the meta information will have to
564 be recreated later, and may be incorrect.
566 If you provide a method object, this method will clone that object if
567 the object's package name does not match the class name. This lets us
568 track the original source of any methods added from other classes
569 (notably Moose roles).
571 =item B<< $metapackage->remove_method($method_name) >>
573 Remove the named method from the class. This method returns the
574 L<Class::MOP::Method> object for the method.
576 =item B<< $metapackage->method_metaclass >>
578 Returns the class name of the method metaclass, see
579 L<Class::MOP::Method> for more information on the method metaclass.
581 =item B<< $metapackage->wrapped_method_metaclass >>
583 Returns the class name of the wrapped method metaclass, see
584 L<Class::MOP::Method::Wrapped> for more information on the wrapped
587 =item B<< Class::MOP::Package->meta >>
589 This will return a L<Class::MOP::Class> instance for this class.
595 Stevan Little E<lt>stevan@iinteractive.comE<gt>
597 =head1 COPYRIGHT AND LICENSE
599 Copyright 2006-2009 by Infinity Interactive, Inc.
601 L<http://www.iinteractive.com>
603 This library is free software; you can redistribute it and/or modify
604 it under the same terms as Perl itself.