2 package Class::MOP::Package;
7 use Scalar::Util 'blessed', 'reftype';
9 use Sub::Name 'subname';
11 our $VERSION = '0.92';
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,
38 Class::MOP::store_metaclass_by_name($package_name, $meta);
45 my ( $class, @args ) = @_;
47 unshift @args, "package" if @args % 2;
50 my $package_name = delete $options{package};
52 (defined $package_name && $package_name
53 && (!blessed $package_name || $package_name->isa('Class::MOP::Package')))
54 || confess "You must pass a package name or an existing Class::MOP::Package instance";
56 $package_name = $package_name->name
57 if blessed $package_name;
59 Class::MOP::remove_metaclass_by_name($package_name);
61 $class->initialize($package_name, %options); # call with first arg form for compat
67 return Class::MOP::Class->initialize($class)->new_object(@_)
68 if $class ne __PACKAGE__;
70 my $params = @_ == 1 ? $_[0] : {@_};
73 package => $params->{package},
76 # because of issues with the Perl API
77 # to the typeglob in some versions, we
78 # need to just always grab a new
79 # reference to the hash in the accessor.
80 # Ideally we could just store a ref and
81 # it would Just Work, but oh well :\
91 # all these attribute readers will be bootstrapped
92 # away in the Class::MOP bootstrap section
96 # because of issues with the Perl API
97 # to the typeglob in some versions, we
98 # need to just always grab a new
99 # reference to the hash here. Ideally
100 # we could just store a ref and it would
101 # Just Work, but oh well :\
103 \%{$_[0]->{'package'} . '::'}
106 sub method_metaclass { $_[0]->{'method_metaclass'} }
107 sub wrapped_method_metaclass { $_[0]->{'wrapped_method_metaclass'} }
109 sub _method_map { $_[0]->{'methods'} }
121 sub _deconstruct_variable_name {
122 my ($self, $variable) = @_;
125 || confess "You must pass a variable name";
127 my $sigil = substr($variable, 0, 1, '');
130 || confess "The variable name must include a sigil";
132 (exists $SIGIL_MAP{$sigil})
133 || confess "I do not recognize that sigil '$sigil'";
135 return ($variable, $sigil, $SIGIL_MAP{$sigil});
141 # ... these functions have to touch the symbol table itself,.. yuk
143 sub add_package_symbol {
144 my ($self, $variable, $initial_value) = @_;
146 my ($name, $sigil, $type) = ref $variable eq 'HASH'
147 ? @{$variable}{qw[name sigil type]}
148 : $self->_deconstruct_variable_name($variable);
150 my $pkg = $self->{'package'};
153 no warnings 'redefine', 'misc', 'prototype';
154 *{$pkg . '::' . $name} = ref $initial_value ? $initial_value : \$initial_value;
157 sub remove_package_glob {
158 my ($self, $name) = @_;
160 delete ${$self->name . '::'}{$name};
163 # ... these functions deal with stuff on the namespace level
165 sub has_package_symbol {
166 my ( $self, $variable ) = @_;
168 my ( $name, $sigil, $type )
169 = ref $variable eq 'HASH'
170 ? @{$variable}{qw[name sigil type]}
171 : $self->_deconstruct_variable_name($variable);
173 my $namespace = $self->namespace;
175 return 0 unless exists $namespace->{$name};
177 my $entry_ref = \$namespace->{$name};
178 if ( reftype($entry_ref) eq 'GLOB' ) {
179 if ( $type eq 'SCALAR' ) {
180 return defined( ${ *{$entry_ref}{SCALAR} } );
183 return defined( *{$entry_ref}{$type} );
188 # a symbol table entry can be -1 (stub), string (stub with prototype),
189 # or reference (constant)
190 return $type eq 'CODE';
194 sub get_package_symbol {
195 my ($self, $variable) = @_;
197 my ($name, $sigil, $type) = ref $variable eq 'HASH'
198 ? @{$variable}{qw[name sigil type]}
199 : $self->_deconstruct_variable_name($variable);
201 my $namespace = $self->namespace;
204 $self->add_package_symbol($variable)
205 unless exists $namespace->{$name};
207 my $entry_ref = \$namespace->{$name};
209 if ( ref($entry_ref) eq 'GLOB' ) {
210 return *{$entry_ref}{$type};
213 if ( $type eq 'CODE' ) {
215 return \&{ $self->name . '::' . $name };
223 sub remove_package_symbol {
224 my ($self, $variable) = @_;
226 my ($name, $sigil, $type) = ref $variable eq 'HASH'
227 ? @{$variable}{qw[name sigil type]}
228 : $self->_deconstruct_variable_name($variable);
231 # no doubt this is grossly inefficient and
232 # could be done much easier and faster in XS
234 my ($scalar_desc, $array_desc, $hash_desc, $code_desc) = (
235 { sigil => '$', type => 'SCALAR', name => $name },
236 { sigil => '@', type => 'ARRAY', name => $name },
237 { sigil => '%', type => 'HASH', name => $name },
238 { sigil => '&', type => 'CODE', name => $name },
241 my ($scalar, $array, $hash, $code);
242 if ($type eq 'SCALAR') {
243 $array = $self->get_package_symbol($array_desc) if $self->has_package_symbol($array_desc);
244 $hash = $self->get_package_symbol($hash_desc) if $self->has_package_symbol($hash_desc);
245 $code = $self->get_package_symbol($code_desc) if $self->has_package_symbol($code_desc);
247 elsif ($type eq 'ARRAY') {
248 $scalar = $self->get_package_symbol($scalar_desc) if $self->has_package_symbol($scalar_desc);
249 $hash = $self->get_package_symbol($hash_desc) if $self->has_package_symbol($hash_desc);
250 $code = $self->get_package_symbol($code_desc) if $self->has_package_symbol($code_desc);
252 elsif ($type eq 'HASH') {
253 $scalar = $self->get_package_symbol($scalar_desc) if $self->has_package_symbol($scalar_desc);
254 $array = $self->get_package_symbol($array_desc) if $self->has_package_symbol($array_desc);
255 $code = $self->get_package_symbol($code_desc) if $self->has_package_symbol($code_desc);
257 elsif ($type eq 'CODE') {
258 $scalar = $self->get_package_symbol($scalar_desc) if $self->has_package_symbol($scalar_desc);
259 $array = $self->get_package_symbol($array_desc) if $self->has_package_symbol($array_desc);
260 $hash = $self->get_package_symbol($hash_desc) if $self->has_package_symbol($hash_desc);
263 confess "This should never ever ever happen";
266 $self->remove_package_glob($name);
268 $self->add_package_symbol($scalar_desc => $scalar) if defined $scalar;
269 $self->add_package_symbol($array_desc => $array) if defined $array;
270 $self->add_package_symbol($hash_desc => $hash) if defined $hash;
271 $self->add_package_symbol($code_desc => $code) if defined $code;
274 sub list_all_package_symbols {
275 my ($self, $type_filter) = @_;
277 my $namespace = $self->namespace;
278 return keys %{$namespace} unless defined $type_filter;
281 # or we can filter based on
282 # type (SCALAR|ARRAY|HASH|CODE)
283 if ( $type_filter eq 'CODE' ) {
285 (ref($namespace->{$_})
286 ? (ref($namespace->{$_}) eq 'SCALAR')
287 : (ref(\$namespace->{$_}) eq 'GLOB'
288 && defined(*{$namespace->{$_}}{CODE})));
289 } keys %{$namespace};
291 return grep { *{$namespace->{$_}}{$type_filter} } keys %{$namespace};
297 sub wrap_method_body {
298 my ( $self, %args ) = @_;
300 ('CODE' eq ref $args{body})
301 || confess "Your code block must be a CODE reference";
303 $self->method_metaclass->wrap(
304 package_name => $self->name,
310 my ($self, $method_name, $method) = @_;
311 (defined $method_name && $method_name)
312 || confess "You must define a method name";
315 if (blessed($method)) {
316 $body = $method->body;
317 if ($method->package_name ne $self->name) {
318 $method = $method->clone(
319 package_name => $self->name,
321 ) if $method->can('clone');
324 $method->attach_to_class($self);
325 $self->_method_map->{$method_name} = $method;
328 # If a raw code reference is supplied, its method object is not created.
329 # The method object won't be created until required.
333 $self->add_package_symbol(
334 { sigil => '&', type => 'CODE', name => $method_name },
340 my ( $self, $code ) = @_;
342 my ( $code_package, $code_name ) = Class::MOP::get_code_info($code);
344 return $code_package && $code_package eq $self->name
345 || ( $code_package eq 'constant' && $code_name eq '__ANON__' );
349 my ($self, $method_name) = @_;
350 (defined $method_name && $method_name)
351 || confess "You must define a method name";
353 return defined($self->get_method($method_name));
357 my ($self, $method_name) = @_;
358 (defined $method_name && $method_name)
359 || confess "You must define a method name";
361 my $method_map = $self->_method_map;
362 my $method_object = $method_map->{$method_name};
363 my $code = $self->get_package_symbol({
364 name => $method_name,
369 unless ( $method_object && $method_object->body == ( $code || 0 ) ) {
370 if ( $code && $self->_code_is_mine($code) ) {
371 $method_object = $method_map->{$method_name}
372 = $self->wrap_method_body(
374 name => $method_name,
375 associated_metaclass => $self,
379 delete $method_map->{$method_name};
384 return $method_object;
388 my ($self, $method_name) = @_;
389 (defined $method_name && $method_name)
390 || confess "You must define a method name";
392 my $removed_method = delete $self->get_method_map->{$method_name};
394 $self->remove_package_symbol(
395 { sigil => '&', type => 'CODE', name => $method_name }
398 $removed_method->detach_from_class if $removed_method;
400 $self->update_package_cache_flag; # still valid, since we just removed the method from the map
402 return $removed_method;
405 sub get_method_list {
407 return grep { $self->has_method($_) } keys %{ $self->namespace };
418 Class::MOP::Package - Package Meta Object
422 The Package Protocol provides an abstraction of a Perl 5 package. A
423 package is basically namespace, and this module provides methods for
424 looking at and changing that namespace's symbol table.
430 =item B<< Class::MOP::Package->initialize($package_name) >>
432 This method creates a new C<Class::MOP::Package> instance which
433 represents specified package. If an existing metaclass object exists
434 for the package, that will be returned instead.
436 =item B<< Class::MOP::Package->reinitialize($package) >>
438 This method forcibly removes any existing metaclass for the package
439 before calling C<initialize>. In contrast to C<initialize>, you may
440 also pass an existing C<Class::MOP::Package> instance instead of just
441 a package name as C<$package>.
443 Do not call this unless you know what you are doing.
445 =item B<< $metapackage->name >>
447 This is returns the package's name, as passed to the constructor.
449 =item B<< $metapackage->namespace >>
451 This returns a hash reference to the package's symbol table. The keys
452 are symbol names and the values are typeglob references.
454 =item B<< $metapackage->add_package_symbol($variable_name, $initial_value) >>
456 This method accepts a variable name and an optional initial value. The
457 C<$variable_name> must contain a leading sigil.
459 This method creates the variable in the package's symbol table, and
460 sets it to the initial value if one was provided.
462 =item B<< $metapackage->get_package_symbol($variable_name) >>
464 Given a variable name, this method returns the variable as a reference
465 or undef if it does not exist. The C<$variable_name> must contain a
468 =item B<< $metapackage->has_package_symbol($variable_name) >>
470 Returns true if there is a package variable defined for
471 C<$variable_name>. The C<$variable_name> must contain a leading sigil.
473 =item B<< $metapackage->remove_package_symbol($variable_name) >>
475 This will remove the package variable specified C<$variable_name>. The
476 C<$variable_name> must contain a leading sigil.
478 =item B<< $metapackage->remove_package_glob($glob_name) >>
480 Given the name of a glob, this will remove that glob from the
481 package's symbol table. Glob names do not include a sigil. Removing
482 the glob removes all variables and subroutines with the specified
485 =item B<< $metapackage->list_all_package_symbols($type_filter) >>
487 This will list all the glob names associated with the current
488 package. These names do not have leading sigils.
490 You can provide an optional type filter, which should be one of
491 'SCALAR', 'ARRAY', 'HASH', or 'CODE'.
493 =item B<< $metapackage->get_all_package_symbols($type_filter) >>
495 This works much like C<list_all_package_symbols>, but it returns a
496 hash reference. The keys are glob names and the values are references
497 to the value for that name.
501 =head2 Method introspection and creation
503 These methods allow you to introspect a class's methods, as well as
504 add, remove, or change methods.
506 Determining what is truly a method in a Perl 5 class requires some
507 heuristics (aka guessing).
509 Methods defined outside the package with a fully qualified name (C<sub
510 Package::name { ... }>) will be included. Similarly, methods named
511 with a fully qualified name using L<Sub::Name> are also included.
513 However, we attempt to ignore imported functions.
515 Ultimately, we are using heuristics to determine what truly is a
516 method in a class, and these heuristics may get the wrong answer in
517 some edge cases. However, for most "normal" cases the heuristics work
522 =item B<< $metapackage->get_method($method_name) >>
524 This will return a L<Class::MOP::Method> for the specified
525 C<$method_name>. If the class does not have the specified method, it
528 =item B<< $metapackage->has_method($method_name) >>
530 Returns a boolean indicating whether or not the class defines the
531 named method. It does not include methods inherited from parent
534 =item B<< $metapackage->get_method_map >>
536 Returns a hash reference representing the methods defined in this
537 class. The keys are method names and the values are
538 L<Class::MOP::Method> objects.
540 =item B<< $metapackage->get_method_list >>
542 This will return a list of method I<names> for all methods defined in
545 =item B<< $metapackage->add_method($method_name, $method) >>
547 This method takes a method name and a subroutine reference, and adds
548 the method to the class.
550 The subroutine reference can be a L<Class::MOP::Method>, and you are
551 strongly encouraged to pass a meta method object instead of a code
552 reference. If you do so, that object gets stored as part of the
553 class's method map directly. If not, the meta information will have to
554 be recreated later, and may be incorrect.
556 If you provide a method object, this method will clone that object if
557 the object's package name does not match the class name. This lets us
558 track the original source of any methods added from other classes
559 (notably Moose roles).
561 =item B<< $metapackage->remove_method($method_name) >>
563 Remove the named method from the class. This method returns the
564 L<Class::MOP::Method> object for the method.
566 =item B<< $metapackage->method_metaclass >>
568 Returns the class name of the method metaclass, see
569 L<Class::MOP::Method> for more information on the method metaclass.
571 =item B<< $metapackage->wrapped_method_metaclass >>
573 Returns the class name of the wrapped method metaclass, see
574 L<Class::MOP::Method::Wrapped> for more information on the wrapped
577 =item B<< Class::MOP::Package->meta >>
579 This will return a L<Class::MOP::Class> instance for this class.
585 Stevan Little E<lt>stevan@iinteractive.comE<gt>
587 =head1 COPYRIGHT AND LICENSE
589 Copyright 2006-2009 by Infinity Interactive, Inc.
591 L<http://www.iinteractive.com>
593 This library is free software; you can redistribute it and/or modify
594 it under the same terms as Perl itself.