2 package Class::MOP::Package;
7 use Scalar::Util 'blessed', 'reftype';
9 use Sub::Name 'subname';
11 our $VERSION = '0.93';
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 # we should never have a blessed map entry but no $code in the package
383 if ( blessed( $map_entry ) && !$code ) {
384 my $method = sprintf '%s::%s', $self->name, $method_name;
385 confess "Found a meta method object in the method map but no"
386 . " corresponding code entry in the symbol table for $method";
389 return $map_entry if blessed $map_entry && $map_entry->body == $code;
391 unless ($map_entry) {
392 return unless $code && $self->_code_is_mine($code);
395 $code ||= $map_entry;
397 return $method_map->{$method_name} = $self->wrap_method_body(
399 name => $method_name,
400 associated_metaclass => $self,
405 my ($self, $method_name) = @_;
406 (defined $method_name && $method_name)
407 || confess "You must define a method name";
409 my $removed_method = delete $self->_full_method_map->{$method_name};
411 $self->remove_package_symbol(
412 { sigil => '&', type => 'CODE', name => $method_name }
415 $removed_method->detach_from_class if $removed_method && blessed $removed_method;
417 $self->update_package_cache_flag; # still valid, since we just removed the method from the map
419 return $removed_method;
422 sub get_method_list {
424 return grep { $self->has_method($_) } keys %{ $self->namespace };
435 Class::MOP::Package - Package Meta Object
439 The Package Protocol provides an abstraction of a Perl 5 package. A
440 package is basically namespace, and this module provides methods for
441 looking at and changing that namespace's symbol table.
447 =item B<< Class::MOP::Package->initialize($package_name) >>
449 This method creates a new C<Class::MOP::Package> instance which
450 represents specified package. If an existing metaclass object exists
451 for the package, that will be returned instead.
453 =item B<< Class::MOP::Package->reinitialize($package) >>
455 This method forcibly removes any existing metaclass for the package
456 before calling C<initialize>. In contrast to C<initialize>, you may
457 also pass an existing C<Class::MOP::Package> instance instead of just
458 a package name as C<$package>.
460 Do not call this unless you know what you are doing.
462 =item B<< $metapackage->name >>
464 This is returns the package's name, as passed to the constructor.
466 =item B<< $metapackage->namespace >>
468 This returns a hash reference to the package's symbol table. The keys
469 are symbol names and the values are typeglob references.
471 =item B<< $metapackage->add_package_symbol($variable_name, $initial_value) >>
473 This method accepts a variable name and an optional initial value. The
474 C<$variable_name> must contain a leading sigil.
476 This method creates the variable in the package's symbol table, and
477 sets it to the initial value if one was provided.
479 =item B<< $metapackage->get_package_symbol($variable_name) >>
481 Given a variable name, this method returns the variable as a reference
482 or undef if it does not exist. The C<$variable_name> must contain a
485 =item B<< $metapackage->has_package_symbol($variable_name) >>
487 Returns true if there is a package variable defined for
488 C<$variable_name>. The C<$variable_name> must contain a leading sigil.
490 =item B<< $metapackage->remove_package_symbol($variable_name) >>
492 This will remove the package variable specified C<$variable_name>. The
493 C<$variable_name> must contain a leading sigil.
495 =item B<< $metapackage->remove_package_glob($glob_name) >>
497 Given the name of a glob, this will remove that glob from the
498 package's symbol table. Glob names do not include a sigil. Removing
499 the glob removes all variables and subroutines with the specified
502 =item B<< $metapackage->list_all_package_symbols($type_filter) >>
504 This will list all the glob names associated with the current
505 package. These names do not have leading sigils.
507 You can provide an optional type filter, which should be one of
508 'SCALAR', 'ARRAY', 'HASH', or 'CODE'.
510 =item B<< $metapackage->get_all_package_symbols($type_filter) >>
512 This works much like C<list_all_package_symbols>, but it returns a
513 hash reference. The keys are glob names and the values are references
514 to the value for that name.
518 =head2 Method introspection and creation
520 These methods allow you to introspect a class's methods, as well as
521 add, remove, or change methods.
523 Determining what is truly a method in a Perl 5 class requires some
524 heuristics (aka guessing).
526 Methods defined outside the package with a fully qualified name (C<sub
527 Package::name { ... }>) will be included. Similarly, methods named
528 with a fully qualified name using L<Sub::Name> are also included.
530 However, we attempt to ignore imported functions.
532 Ultimately, we are using heuristics to determine what truly is a
533 method in a class, and these heuristics may get the wrong answer in
534 some edge cases. However, for most "normal" cases the heuristics work
539 =item B<< $metapackage->get_method($method_name) >>
541 This will return a L<Class::MOP::Method> for the specified
542 C<$method_name>. If the class does not have the specified method, it
545 =item B<< $metapackage->has_method($method_name) >>
547 Returns a boolean indicating whether or not the class defines the
548 named method. It does not include methods inherited from parent
551 =item B<< $metapackage->get_method_list >>
553 This will return a list of method I<names> for all methods defined in
556 =item B<< $metapackage->add_method($method_name, $method) >>
558 This method takes a method name and a subroutine reference, and adds
559 the method to the class.
561 The subroutine reference can be a L<Class::MOP::Method>, and you are
562 strongly encouraged to pass a meta method object instead of a code
563 reference. If you do so, that object gets stored as part of the
564 class's method map directly. If not, the meta information will have to
565 be recreated later, and may be incorrect.
567 If you provide a method object, this method will clone that object if
568 the object's package name does not match the class name. This lets us
569 track the original source of any methods added from other classes
570 (notably Moose roles).
572 =item B<< $metapackage->remove_method($method_name) >>
574 Remove the named method from the class. This method returns the
575 L<Class::MOP::Method> object for the method.
577 =item B<< $metapackage->method_metaclass >>
579 Returns the class name of the method metaclass, see
580 L<Class::MOP::Method> for more information on the method metaclass.
582 =item B<< $metapackage->wrapped_method_metaclass >>
584 Returns the class name of the wrapped method metaclass, see
585 L<Class::MOP::Method::Wrapped> for more information on the wrapped
588 =item B<< Class::MOP::Package->meta >>
590 This will return a L<Class::MOP::Class> instance for this class.
596 Stevan Little E<lt>stevan@iinteractive.comE<gt>
598 =head1 COPYRIGHT AND LICENSE
600 Copyright 2006-2009 by Infinity Interactive, Inc.
602 L<http://www.iinteractive.com>
604 This library is free software; you can redistribute it and/or modify
605 it under the same terms as Perl itself.