2 package Class::MOP::Package;
7 use Scalar::Util 'blessed', 'reftype';
9 use Sub::Name 'subname';
11 our $VERSION = '0.92_01';
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.
334 Carp::cluck('wtf') unless defined $self->_method_map;
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 return $map_entry if blessed $map_entry && $map_entry->body == $code;
384 # we should never have a blessed map entry but no $code in the package
385 die 'WTF' if blessed $map_entry && ! $code;
387 unless ($map_entry) {
388 return unless $code && $self->_code_is_mine($code);
391 $code ||= $map_entry;
393 return $method_map->{$method_name} = $self->wrap_method_body(
395 name => $method_name,
396 associated_metaclass => $self,
401 my ($self, $method_name) = @_;
402 (defined $method_name && $method_name)
403 || confess "You must define a method name";
405 my $removed_method = delete $self->_full_method_map->{$method_name};
407 $self->remove_package_symbol(
408 { sigil => '&', type => 'CODE', name => $method_name }
411 $removed_method->detach_from_class if $removed_method && blessed $removed_method;
413 $self->update_package_cache_flag; # still valid, since we just removed the method from the map
415 return $removed_method;
418 sub get_method_list {
420 return grep { $self->has_method($_) } keys %{ $self->namespace };
431 Class::MOP::Package - Package Meta Object
435 The Package Protocol provides an abstraction of a Perl 5 package. A
436 package is basically namespace, and this module provides methods for
437 looking at and changing that namespace's symbol table.
443 =item B<< Class::MOP::Package->initialize($package_name) >>
445 This method creates a new C<Class::MOP::Package> instance which
446 represents specified package. If an existing metaclass object exists
447 for the package, that will be returned instead.
449 =item B<< Class::MOP::Package->reinitialize($package) >>
451 This method forcibly removes any existing metaclass for the package
452 before calling C<initialize>. In contrast to C<initialize>, you may
453 also pass an existing C<Class::MOP::Package> instance instead of just
454 a package name as C<$package>.
456 Do not call this unless you know what you are doing.
458 =item B<< $metapackage->name >>
460 This is returns the package's name, as passed to the constructor.
462 =item B<< $metapackage->namespace >>
464 This returns a hash reference to the package's symbol table. The keys
465 are symbol names and the values are typeglob references.
467 =item B<< $metapackage->add_package_symbol($variable_name, $initial_value) >>
469 This method accepts a variable name and an optional initial value. The
470 C<$variable_name> must contain a leading sigil.
472 This method creates the variable in the package's symbol table, and
473 sets it to the initial value if one was provided.
475 =item B<< $metapackage->get_package_symbol($variable_name) >>
477 Given a variable name, this method returns the variable as a reference
478 or undef if it does not exist. The C<$variable_name> must contain a
481 =item B<< $metapackage->has_package_symbol($variable_name) >>
483 Returns true if there is a package variable defined for
484 C<$variable_name>. The C<$variable_name> must contain a leading sigil.
486 =item B<< $metapackage->remove_package_symbol($variable_name) >>
488 This will remove the package variable specified C<$variable_name>. The
489 C<$variable_name> must contain a leading sigil.
491 =item B<< $metapackage->remove_package_glob($glob_name) >>
493 Given the name of a glob, this will remove that glob from the
494 package's symbol table. Glob names do not include a sigil. Removing
495 the glob removes all variables and subroutines with the specified
498 =item B<< $metapackage->list_all_package_symbols($type_filter) >>
500 This will list all the glob names associated with the current
501 package. These names do not have leading sigils.
503 You can provide an optional type filter, which should be one of
504 'SCALAR', 'ARRAY', 'HASH', or 'CODE'.
506 =item B<< $metapackage->get_all_package_symbols($type_filter) >>
508 This works much like C<list_all_package_symbols>, but it returns a
509 hash reference. The keys are glob names and the values are references
510 to the value for that name.
514 =head2 Method introspection and creation
516 These methods allow you to introspect a class's methods, as well as
517 add, remove, or change methods.
519 Determining what is truly a method in a Perl 5 class requires some
520 heuristics (aka guessing).
522 Methods defined outside the package with a fully qualified name (C<sub
523 Package::name { ... }>) will be included. Similarly, methods named
524 with a fully qualified name using L<Sub::Name> are also included.
526 However, we attempt to ignore imported functions.
528 Ultimately, we are using heuristics to determine what truly is a
529 method in a class, and these heuristics may get the wrong answer in
530 some edge cases. However, for most "normal" cases the heuristics work
535 =item B<< $metapackage->get_method($method_name) >>
537 This will return a L<Class::MOP::Method> for the specified
538 C<$method_name>. If the class does not have the specified method, it
541 =item B<< $metapackage->has_method($method_name) >>
543 Returns a boolean indicating whether or not the class defines the
544 named method. It does not include methods inherited from parent
547 =item B<< $metapackage->get_method_list >>
549 This will return a list of method I<names> for all methods defined in
552 =item B<< $metapackage->add_method($method_name, $method) >>
554 This method takes a method name and a subroutine reference, and adds
555 the method to the class.
557 The subroutine reference can be a L<Class::MOP::Method>, and you are
558 strongly encouraged to pass a meta method object instead of a code
559 reference. If you do so, that object gets stored as part of the
560 class's method map directly. If not, the meta information will have to
561 be recreated later, and may be incorrect.
563 If you provide a method object, this method will clone that object if
564 the object's package name does not match the class name. This lets us
565 track the original source of any methods added from other classes
566 (notably Moose roles).
568 =item B<< $metapackage->remove_method($method_name) >>
570 Remove the named method from the class. This method returns the
571 L<Class::MOP::Method> object for the method.
573 =item B<< $metapackage->method_metaclass >>
575 Returns the class name of the method metaclass, see
576 L<Class::MOP::Method> for more information on the method metaclass.
578 =item B<< $metapackage->wrapped_method_metaclass >>
580 Returns the class name of the wrapped method metaclass, see
581 L<Class::MOP::Method::Wrapped> for more information on the wrapped
584 =item B<< Class::MOP::Package->meta >>
586 This will return a L<Class::MOP::Class> instance for this class.
592 Stevan Little E<lt>stevan@iinteractive.comE<gt>
594 =head1 COPYRIGHT AND LICENSE
596 Copyright 2006-2009 by Infinity Interactive, Inc.
598 L<http://www.iinteractive.com>
600 This library is free software; you can redistribute it and/or modify
601 it under the same terms as Perl itself.