2 package Class::MOP::Package;
7 use Scalar::Util 'blessed', 'reftype';
9 use Sub::Name 'subname';
11 our $VERSION = '0.90';
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 && !blessed($package_name))
53 || confess "You must pass a package name and it cannot be blessed";
55 Class::MOP::remove_metaclass_by_name($package_name);
57 $class->initialize($package_name, %options); # call with first arg form for compat
63 return Class::MOP::Class->initialize($class)->new_object(@_)
64 if $class ne __PACKAGE__;
66 my $params = @_ == 1 ? $_[0] : {@_};
69 package => $params->{package},
72 # because of issues with the Perl API
73 # to the typeglob in some versions, we
74 # need to just always grab a new
75 # reference to the hash in the accessor.
76 # Ideally we could just store a ref and
77 # it would Just Work, but oh well :\
87 # all these attribute readers will be bootstrapped
88 # away in the Class::MOP bootstrap section
92 # because of issues with the Perl API
93 # to the typeglob in some versions, we
94 # need to just always grab a new
95 # reference to the hash here. Ideally
96 # we could just store a ref and it would
97 # Just Work, but oh well :\
99 \%{$_[0]->{'package'} . '::'}
102 sub method_metaclass { $_[0]->{'method_metaclass'} }
103 sub wrapped_method_metaclass { $_[0]->{'wrapped_method_metaclass'} }
105 sub _method_map { $_[0]->{'methods'} }
117 sub _deconstruct_variable_name {
118 my ($self, $variable) = @_;
121 || confess "You must pass a variable name";
123 my $sigil = substr($variable, 0, 1, '');
126 || confess "The variable name must include a sigil";
128 (exists $SIGIL_MAP{$sigil})
129 || confess "I do not recognize that sigil '$sigil'";
131 return ($variable, $sigil, $SIGIL_MAP{$sigil});
137 # ... these functions have to touch the symbol table itself,.. yuk
139 sub add_package_symbol {
140 my ($self, $variable, $initial_value) = @_;
142 my ($name, $sigil, $type) = ref $variable eq 'HASH'
143 ? @{$variable}{qw[name sigil type]}
144 : $self->_deconstruct_variable_name($variable);
146 my $pkg = $self->{'package'};
149 no warnings 'redefine', 'misc', 'prototype';
150 *{$pkg . '::' . $name} = ref $initial_value ? $initial_value : \$initial_value;
153 sub remove_package_glob {
154 my ($self, $name) = @_;
156 delete ${$self->name . '::'}{$name};
159 # ... these functions deal with stuff on the namespace level
161 sub has_package_symbol {
162 my ( $self, $variable ) = @_;
164 my ( $name, $sigil, $type )
165 = ref $variable eq 'HASH'
166 ? @{$variable}{qw[name sigil type]}
167 : $self->_deconstruct_variable_name($variable);
169 my $namespace = $self->namespace;
171 return 0 unless exists $namespace->{$name};
173 my $entry_ref = \$namespace->{$name};
174 if ( reftype($entry_ref) eq 'GLOB' ) {
175 if ( $type eq 'SCALAR' ) {
176 return defined( ${ *{$entry_ref}{SCALAR} } );
179 return defined( *{$entry_ref}{$type} );
184 # a symbol table entry can be -1 (stub), string (stub with prototype),
185 # or reference (constant)
186 return $type eq 'CODE';
190 sub get_package_symbol {
191 my ($self, $variable) = @_;
193 my ($name, $sigil, $type) = ref $variable eq 'HASH'
194 ? @{$variable}{qw[name sigil type]}
195 : $self->_deconstruct_variable_name($variable);
197 my $namespace = $self->namespace;
200 $self->add_package_symbol($variable)
201 unless exists $namespace->{$name};
203 my $entry_ref = \$namespace->{$name};
205 if ( ref($entry_ref) eq 'GLOB' ) {
206 return *{$entry_ref}{$type};
209 if ( $type eq 'CODE' ) {
211 return \&{ $self->name . '::' . $name };
219 sub remove_package_symbol {
220 my ($self, $variable) = @_;
222 my ($name, $sigil, $type) = ref $variable eq 'HASH'
223 ? @{$variable}{qw[name sigil type]}
224 : $self->_deconstruct_variable_name($variable);
227 # no doubt this is grossly inefficient and
228 # could be done much easier and faster in XS
230 my ($scalar_desc, $array_desc, $hash_desc, $code_desc) = (
231 { sigil => '$', type => 'SCALAR', name => $name },
232 { sigil => '@', type => 'ARRAY', name => $name },
233 { sigil => '%', type => 'HASH', name => $name },
234 { sigil => '&', type => 'CODE', name => $name },
237 my ($scalar, $array, $hash, $code);
238 if ($type eq 'SCALAR') {
239 $array = $self->get_package_symbol($array_desc) if $self->has_package_symbol($array_desc);
240 $hash = $self->get_package_symbol($hash_desc) if $self->has_package_symbol($hash_desc);
241 $code = $self->get_package_symbol($code_desc) if $self->has_package_symbol($code_desc);
243 elsif ($type eq 'ARRAY') {
244 $scalar = $self->get_package_symbol($scalar_desc) if $self->has_package_symbol($scalar_desc);
245 $hash = $self->get_package_symbol($hash_desc) if $self->has_package_symbol($hash_desc);
246 $code = $self->get_package_symbol($code_desc) if $self->has_package_symbol($code_desc);
248 elsif ($type eq 'HASH') {
249 $scalar = $self->get_package_symbol($scalar_desc) if $self->has_package_symbol($scalar_desc);
250 $array = $self->get_package_symbol($array_desc) if $self->has_package_symbol($array_desc);
251 $code = $self->get_package_symbol($code_desc) if $self->has_package_symbol($code_desc);
253 elsif ($type eq 'CODE') {
254 $scalar = $self->get_package_symbol($scalar_desc) if $self->has_package_symbol($scalar_desc);
255 $array = $self->get_package_symbol($array_desc) if $self->has_package_symbol($array_desc);
256 $hash = $self->get_package_symbol($hash_desc) if $self->has_package_symbol($hash_desc);
259 confess "This should never ever ever happen";
262 $self->remove_package_glob($name);
264 $self->add_package_symbol($scalar_desc => $scalar) if defined $scalar;
265 $self->add_package_symbol($array_desc => $array) if defined $array;
266 $self->add_package_symbol($hash_desc => $hash) if defined $hash;
267 $self->add_package_symbol($code_desc => $code) if defined $code;
270 sub list_all_package_symbols {
271 my ($self, $type_filter) = @_;
273 my $namespace = $self->namespace;
274 return keys %{$namespace} unless defined $type_filter;
277 # or we can filter based on
278 # type (SCALAR|ARRAY|HASH|CODE)
279 if ( $type_filter eq 'CODE' ) {
281 (ref($namespace->{$_})
282 ? (ref($namespace->{$_}) eq 'SCALAR')
283 : (ref(\$namespace->{$_}) eq 'GLOB'
284 && defined(*{$namespace->{$_}}{CODE})));
285 } keys %{$namespace};
287 return grep { *{$namespace->{$_}}{$type_filter} } keys %{$namespace};
293 sub wrap_method_body {
294 my ( $self, %args ) = @_;
296 ('CODE' eq ref $args{body})
297 || confess "Your code block must be a CODE reference";
299 $self->method_metaclass->wrap(
300 package_name => $self->name,
306 my ($self, $method_name, $method) = @_;
307 (defined $method_name && $method_name)
308 || confess "You must define a method name";
311 if (blessed($method)) {
312 $body = $method->body;
313 if ($method->package_name ne $self->name) {
314 $method = $method->clone(
315 package_name => $self->name,
317 ) if $method->can('clone');
320 $method->attach_to_class($self);
321 $self->_method_map->{$method_name} = $method;
324 # If a raw code reference is supplied, its method object is not created.
325 # The method object won't be created until required.
330 my ( $current_package, $current_name ) = Class::MOP::get_code_info($body);
332 if ( !defined $current_name || $current_name eq '__ANON__' ) {
333 my $full_method_name = ($self->name . '::' . $method_name);
334 subname($full_method_name => $body);
337 $self->add_package_symbol(
338 { sigil => '&', type => 'CODE', name => $method_name },
344 my ( $self, $code ) = @_;
346 my ( $code_package, $code_name ) = Class::MOP::get_code_info($code);
348 return $code_package && $code_package eq $self->name
349 || ( $code_package eq 'constant' && $code_name eq '__ANON__' );
353 my ($self, $method_name) = @_;
354 (defined $method_name && $method_name)
355 || confess "You must define a method name";
357 return defined($self->get_method($method_name));
361 my ($self, $method_name) = @_;
362 (defined $method_name && $method_name)
363 || confess "You must define a method name";
365 my $method_map = $self->_method_map;
366 my $method_object = $method_map->{$method_name};
367 my $code = $self->get_package_symbol({
368 name => $method_name,
373 unless ( $method_object && $method_object->body == ( $code || 0 ) ) {
374 if ( $code && $self->_code_is_mine($code) ) {
375 $method_object = $method_map->{$method_name}
376 = $self->wrap_method_body(
378 name => $method_name,
379 associated_metaclass => $self,
383 delete $method_map->{$method_name};
388 return $method_object;
392 my ($self, $method_name) = @_;
393 (defined $method_name && $method_name)
394 || confess "You must define a method name";
396 my $removed_method = delete $self->get_method_map->{$method_name};
398 $self->remove_package_symbol(
399 { sigil => '&', type => 'CODE', name => $method_name }
402 $removed_method->detach_from_class if $removed_method;
404 $self->update_package_cache_flag; # still valid, since we just removed the method from the map
406 return $removed_method;
409 sub get_method_list {
411 return grep { $self->has_method($_) } keys %{ $self->namespace };
422 Class::MOP::Package - Package Meta Object
426 The Package Protocol provides an abstraction of a Perl 5 package. A
427 package is basically namespace, and this module provides methods for
428 looking at and changing that namespace's symbol table.
434 =item B<< Class::MOP::Package->initialize($package_name) >>
436 This method creates a new C<Class::MOP::Package> instance which
437 represents specified package. If an existing metaclass object exists
438 for the package, that will be returned instead.
440 =item B<< Class::MOP::Package->reinitialize($package_name) >>
442 This method forcibly removes any existing metaclass for the package
443 before calling C<initialize>
445 Do not call this unless you know what you are doing.
447 =item B<< $metapackage->name >>
449 This is returns the package's name, as passed to the constructor.
451 =item B<< $metapackage->namespace >>
453 This returns a hash reference to the package's symbol table. The keys
454 are symbol names and the values are typeglob references.
456 =item B<< $metapackage->add_package_symbol($variable_name, $initial_value) >>
458 This method accepts a variable name and an optional initial value. The
459 C<$variable_name> must contain a leading sigil.
461 This method creates the variable in the package's symbol table, and
462 sets it to the initial value if one was provided.
464 =item B<< $metapackage->get_package_symbol($variable_name) >>
466 Given a variable name, this method returns the variable as a reference
467 or undef if it does not exist. The C<$variable_name> must contain a
470 =item B<< $metapackage->has_package_symbol($variable_name) >>
472 Returns true if there is a package variable defined for
473 C<$variable_name>. The C<$variable_name> must contain a leading sigil.
475 =item B<< $metapackage->remove_package_symbol($variable_name) >>
477 This will remove the package variable specified C<$variable_name>. The
478 C<$variable_name> must contain a leading sigil.
480 =item B<< $metapackage->remove_package_glob($glob_name) >>
482 Given the name of a glob, this will remove that glob from the
483 package's symbol table. Glob names do not include a sigil. Removing
484 the glob removes all variables and subroutines with the specified
487 =item B<< $metapackage->list_all_package_symbols($type_filter) >>
489 This will list all the glob names associated with the current
490 package. These names do not have leading sigils.
492 You can provide an optional type filter, which should be one of
493 'SCALAR', 'ARRAY', 'HASH', or 'CODE'.
495 =item B<< $metapackage->get_all_package_symbols($type_filter) >>
497 This works much like C<list_all_package_symbols>, but it returns a
498 hash reference. The keys are glob names and the values are references
499 to the value for that name.
503 =head2 Method introspection and creation
505 These methods allow you to introspect a class's methods, as well as
506 add, remove, or change methods.
508 Determining what is truly a method in a Perl 5 class requires some
509 heuristics (aka guessing).
511 Methods defined outside the package with a fully qualified name (C<sub
512 Package::name { ... }>) will be included. Similarly, methods named
513 with a fully qualified name using L<Sub::Name> are also included.
515 However, we attempt to ignore imported functions.
517 Ultimately, we are using heuristics to determine what truly is a
518 method in a class, and these heuristics may get the wrong answer in
519 some edge cases. However, for most "normal" cases the heuristics work
524 =item B<< $metapackage->get_method($method_name) >>
526 This will return a L<Class::MOP::Method> for the specified
527 C<$method_name>. If the class does not have the specified method, it
530 =item B<< $metapackage->has_method($method_name) >>
532 Returns a boolean indicating whether or not the class defines the
533 named method. It does not include methods inherited from parent
536 =item B<< $metapackage->get_method_map >>
538 Returns a hash reference representing the methods defined in this
539 class. The keys are method names and the values are
540 L<Class::MOP::Method> objects.
542 =item B<< $metapackage->get_method_list >>
544 This will return a list of method I<names> for all methods defined in
547 =item B<< $metapackage->add_method($method_name, $method) >>
549 This method takes a method name and a subroutine reference, and adds
550 the method to the class.
552 The subroutine reference can be a L<Class::MOP::Method>, and you are
553 strongly encouraged to pass a meta method object instead of a code
554 reference. If you do so, that object gets stored as part of the
555 class's method map directly. If not, the meta information will have to
556 be recreated later, and may be incorrect.
558 If you provide a method object, this method will clone that object if
559 the object's package name does not match the class name. This lets us
560 track the original source of any methods added from other classes
561 (notably Moose roles).
563 =item B<< $metapackage->remove_method($method_name) >>
565 Remove the named method from the class. This method returns the
566 L<Class::MOP::Method> object for the method.
568 =item B<< $metapackage->method_metaclass >>
570 Returns the class name of the method metaclass, see
571 L<Class::MOP::Method> for more information on the method metaclass.
573 =item B<< $metapackage->wrapped_method_metaclass >>
575 Returns the class name of the wrapped method metaclass, see
576 L<Class::MOP::Method::Wrapped> for more information on the wrapped
579 =item B<< Class::MOP::Package->meta >>
581 This will return a L<Class::MOP::Class> instance for this class.
587 Stevan Little E<lt>stevan@iinteractive.comE<gt>
589 =head1 COPYRIGHT AND LICENSE
591 Copyright 2006-2009 by Infinity Interactive, Inc.
593 L<http://www.iinteractive.com>
595 This library is free software; you can redistribute it and/or modify
596 it under the same terms as Perl itself.