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,
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.
334 my ( $current_package, $current_name ) = Class::MOP::get_code_info($body);
336 if ( !defined $current_name || $current_name eq '__ANON__' ) {
337 my $full_method_name = ($self->name . '::' . $method_name);
338 subname($full_method_name => $body);
341 $self->add_package_symbol(
342 { sigil => '&', type => 'CODE', name => $method_name },
348 my ( $self, $code ) = @_;
350 my ( $code_package, $code_name ) = Class::MOP::get_code_info($code);
352 return $code_package && $code_package eq $self->name
353 || ( $code_package eq 'constant' && $code_name eq '__ANON__' );
357 my ($self, $method_name) = @_;
358 (defined $method_name && $method_name)
359 || confess "You must define a method name";
361 return defined($self->get_method($method_name));
365 my ($self, $method_name) = @_;
366 (defined $method_name && $method_name)
367 || confess "You must define a method name";
369 my $method_map = $self->_method_map;
370 my $method_object = $method_map->{$method_name};
371 my $code = $self->get_package_symbol({
372 name => $method_name,
377 unless ( $method_object && $method_object->body == ( $code || 0 ) ) {
378 if ( $code && $self->_code_is_mine($code) ) {
379 $method_object = $method_map->{$method_name}
380 = $self->wrap_method_body(
382 name => $method_name,
383 associated_metaclass => $self,
387 delete $method_map->{$method_name};
392 return $method_object;
396 my ($self, $method_name) = @_;
397 (defined $method_name && $method_name)
398 || confess "You must define a method name";
400 my $removed_method = delete $self->get_method_map->{$method_name};
402 $self->remove_package_symbol(
403 { sigil => '&', type => 'CODE', name => $method_name }
406 $removed_method->detach_from_class if $removed_method;
408 $self->update_package_cache_flag; # still valid, since we just removed the method from the map
410 return $removed_method;
413 sub get_method_list {
415 return grep { $self->has_method($_) } keys %{ $self->namespace };
426 Class::MOP::Package - Package Meta Object
430 The Package Protocol provides an abstraction of a Perl 5 package. A
431 package is basically namespace, and this module provides methods for
432 looking at and changing that namespace's symbol table.
438 =item B<< Class::MOP::Package->initialize($package_name) >>
440 This method creates a new C<Class::MOP::Package> instance which
441 represents specified package. If an existing metaclass object exists
442 for the package, that will be returned instead.
444 =item B<< Class::MOP::Package->reinitialize($package) >>
446 This method forcibly removes any existing metaclass for the package
447 before calling C<initialize>. In contrast to C<initialize>, you may
448 also pass an existing C<Class::MOP::Package> instance instead of just
449 a package name as C<$package>.
451 Do not call this unless you know what you are doing.
453 =item B<< $metapackage->name >>
455 This is returns the package's name, as passed to the constructor.
457 =item B<< $metapackage->namespace >>
459 This returns a hash reference to the package's symbol table. The keys
460 are symbol names and the values are typeglob references.
462 =item B<< $metapackage->add_package_symbol($variable_name, $initial_value) >>
464 This method accepts a variable name and an optional initial value. The
465 C<$variable_name> must contain a leading sigil.
467 This method creates the variable in the package's symbol table, and
468 sets it to the initial value if one was provided.
470 =item B<< $metapackage->get_package_symbol($variable_name) >>
472 Given a variable name, this method returns the variable as a reference
473 or undef if it does not exist. The C<$variable_name> must contain a
476 =item B<< $metapackage->has_package_symbol($variable_name) >>
478 Returns true if there is a package variable defined for
479 C<$variable_name>. The C<$variable_name> must contain a leading sigil.
481 =item B<< $metapackage->remove_package_symbol($variable_name) >>
483 This will remove the package variable specified C<$variable_name>. The
484 C<$variable_name> must contain a leading sigil.
486 =item B<< $metapackage->remove_package_glob($glob_name) >>
488 Given the name of a glob, this will remove that glob from the
489 package's symbol table. Glob names do not include a sigil. Removing
490 the glob removes all variables and subroutines with the specified
493 =item B<< $metapackage->list_all_package_symbols($type_filter) >>
495 This will list all the glob names associated with the current
496 package. These names do not have leading sigils.
498 You can provide an optional type filter, which should be one of
499 'SCALAR', 'ARRAY', 'HASH', or 'CODE'.
501 =item B<< $metapackage->get_all_package_symbols($type_filter) >>
503 This works much like C<list_all_package_symbols>, but it returns a
504 hash reference. The keys are glob names and the values are references
505 to the value for that name.
509 =head2 Method introspection and creation
511 These methods allow you to introspect a class's methods, as well as
512 add, remove, or change methods.
514 Determining what is truly a method in a Perl 5 class requires some
515 heuristics (aka guessing).
517 Methods defined outside the package with a fully qualified name (C<sub
518 Package::name { ... }>) will be included. Similarly, methods named
519 with a fully qualified name using L<Sub::Name> are also included.
521 However, we attempt to ignore imported functions.
523 Ultimately, we are using heuristics to determine what truly is a
524 method in a class, and these heuristics may get the wrong answer in
525 some edge cases. However, for most "normal" cases the heuristics work
530 =item B<< $metapackage->get_method($method_name) >>
532 This will return a L<Class::MOP::Method> for the specified
533 C<$method_name>. If the class does not have the specified method, it
536 =item B<< $metapackage->has_method($method_name) >>
538 Returns a boolean indicating whether or not the class defines the
539 named method. It does not include methods inherited from parent
542 =item B<< $metapackage->get_method_map >>
544 Returns a hash reference representing the methods defined in this
545 class. The keys are method names and the values are
546 L<Class::MOP::Method> objects.
548 =item B<< $metapackage->get_method_list >>
550 This will return a list of method I<names> for all methods defined in
553 =item B<< $metapackage->add_method($method_name, $method) >>
555 This method takes a method name and a subroutine reference, and adds
556 the method to the class.
558 The subroutine reference can be a L<Class::MOP::Method>, and you are
559 strongly encouraged to pass a meta method object instead of a code
560 reference. If you do so, that object gets stored as part of the
561 class's method map directly. If not, the meta information will have to
562 be recreated later, and may be incorrect.
564 If you provide a method object, this method will clone that object if
565 the object's package name does not match the class name. This lets us
566 track the original source of any methods added from other classes
567 (notably Moose roles).
569 =item B<< $metapackage->remove_method($method_name) >>
571 Remove the named method from the class. This method returns the
572 L<Class::MOP::Method> object for the method.
574 =item B<< $metapackage->method_metaclass >>
576 Returns the class name of the method metaclass, see
577 L<Class::MOP::Method> for more information on the method metaclass.
579 =item B<< $metapackage->wrapped_method_metaclass >>
581 Returns the class name of the wrapped method metaclass, see
582 L<Class::MOP::Method::Wrapped> for more information on the wrapped
585 =item B<< Class::MOP::Package->meta >>
587 This will return a L<Class::MOP::Class> instance for this class.
593 Stevan Little E<lt>stevan@iinteractive.comE<gt>
595 =head1 COPYRIGHT AND LICENSE
597 Copyright 2006-2009 by Infinity Interactive, Inc.
599 L<http://www.iinteractive.com>
601 This library is free software; you can redistribute it and/or modify
602 it under the same terms as Perl itself.