2 package Class::MOP::Package;
7 use Scalar::Util 'blessed';
9 use Sub::Name 'subname';
11 our $VERSION = '0.89';
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
62 my $options = @_ == 1 ? $_[0] : {@_};
65 # because of issues with the Perl API
66 # to the typeglob in some versions, we
67 # need to just always grab a new
68 # reference to the hash in the accessor.
69 # Ideally we could just store a ref and
70 # it would Just Work, but oh well :\
71 $options->{namespace} ||= \undef;
73 bless $options, $class;
79 # all these attribute readers will be bootstrapped
80 # away in the Class::MOP bootstrap section
84 # because of issues with the Perl API
85 # to the typeglob in some versions, we
86 # need to just always grab a new
87 # reference to the hash here. Ideally
88 # we could just store a ref and it would
89 # Just Work, but oh well :\
91 \%{$_[0]->{'package'} . '::'}
94 sub method_metaclass { $_[0]->{'method_metaclass'} }
95 sub wrapped_method_metaclass { $_[0]->{'wrapped_method_metaclass'} }
107 sub _deconstruct_variable_name {
108 my ($self, $variable) = @_;
111 || confess "You must pass a variable name";
113 my $sigil = substr($variable, 0, 1, '');
116 || confess "The variable name must include a sigil";
118 (exists $SIGIL_MAP{$sigil})
119 || confess "I do not recognize that sigil '$sigil'";
121 return ($variable, $sigil, $SIGIL_MAP{$sigil});
127 # ... these functions have to touch the symbol table itself,.. yuk
129 sub add_package_symbol {
130 my ($self, $variable, $initial_value) = @_;
132 my ($name, $sigil, $type) = ref $variable eq 'HASH'
133 ? @{$variable}{qw[name sigil type]}
134 : $self->_deconstruct_variable_name($variable);
136 my $pkg = $self->{'package'};
139 no warnings 'redefine', 'misc', 'prototype';
140 *{$pkg . '::' . $name} = ref $initial_value ? $initial_value : \$initial_value;
143 sub remove_package_glob {
144 my ($self, $name) = @_;
146 delete ${$self->name . '::'}{$name};
149 # ... these functions deal with stuff on the namespace level
151 sub has_package_symbol {
152 my ($self, $variable) = @_;
154 my ($name, $sigil, $type) = ref $variable eq 'HASH'
155 ? @{$variable}{qw[name sigil type]}
156 : $self->_deconstruct_variable_name($variable);
158 my $namespace = $self->namespace;
160 return 0 unless exists $namespace->{$name};
163 # For some really stupid reason
164 # a typeglob will have a default
165 # value of \undef in the SCALAR
166 # slot, so we need to work around
167 # this. Which of course means that
168 # if you put \undef in your scalar
169 # then this is broken.
171 if (ref($namespace->{$name}) eq 'SCALAR') {
172 return ($type eq 'CODE');
174 elsif ($type eq 'SCALAR') {
175 my $val = *{$namespace->{$name}}{$type};
176 return defined(${$val});
179 defined(*{$namespace->{$name}}{$type});
183 sub get_package_symbol {
184 my ($self, $variable) = @_;
186 my ($name, $sigil, $type) = ref $variable eq 'HASH'
187 ? @{$variable}{qw[name sigil type]}
188 : $self->_deconstruct_variable_name($variable);
190 my $namespace = $self->namespace;
192 $self->add_package_symbol($variable)
193 unless exists $namespace->{$name};
195 if (ref($namespace->{$name}) eq 'SCALAR') {
196 if ($type eq 'CODE') {
198 return \&{$self->name.'::'.$name};
205 return *{$namespace->{$name}}{$type};
209 sub remove_package_symbol {
210 my ($self, $variable) = @_;
212 my ($name, $sigil, $type) = ref $variable eq 'HASH'
213 ? @{$variable}{qw[name sigil type]}
214 : $self->_deconstruct_variable_name($variable);
217 # no doubt this is grossly inefficient and
218 # could be done much easier and faster in XS
220 my ($scalar_desc, $array_desc, $hash_desc, $code_desc) = (
221 { sigil => '$', type => 'SCALAR', name => $name },
222 { sigil => '@', type => 'ARRAY', name => $name },
223 { sigil => '%', type => 'HASH', name => $name },
224 { sigil => '&', type => 'CODE', name => $name },
227 my ($scalar, $array, $hash, $code);
228 if ($type eq 'SCALAR') {
229 $array = $self->get_package_symbol($array_desc) if $self->has_package_symbol($array_desc);
230 $hash = $self->get_package_symbol($hash_desc) if $self->has_package_symbol($hash_desc);
231 $code = $self->get_package_symbol($code_desc) if $self->has_package_symbol($code_desc);
233 elsif ($type eq 'ARRAY') {
234 $scalar = $self->get_package_symbol($scalar_desc) if $self->has_package_symbol($scalar_desc);
235 $hash = $self->get_package_symbol($hash_desc) if $self->has_package_symbol($hash_desc);
236 $code = $self->get_package_symbol($code_desc) if $self->has_package_symbol($code_desc);
238 elsif ($type eq 'HASH') {
239 $scalar = $self->get_package_symbol($scalar_desc) if $self->has_package_symbol($scalar_desc);
240 $array = $self->get_package_symbol($array_desc) if $self->has_package_symbol($array_desc);
241 $code = $self->get_package_symbol($code_desc) if $self->has_package_symbol($code_desc);
243 elsif ($type eq 'CODE') {
244 $scalar = $self->get_package_symbol($scalar_desc) if $self->has_package_symbol($scalar_desc);
245 $array = $self->get_package_symbol($array_desc) if $self->has_package_symbol($array_desc);
246 $hash = $self->get_package_symbol($hash_desc) if $self->has_package_symbol($hash_desc);
249 confess "This should never ever ever happen";
252 $self->remove_package_glob($name);
254 $self->add_package_symbol($scalar_desc => $scalar) if defined $scalar;
255 $self->add_package_symbol($array_desc => $array) if defined $array;
256 $self->add_package_symbol($hash_desc => $hash) if defined $hash;
257 $self->add_package_symbol($code_desc => $code) if defined $code;
260 sub list_all_package_symbols {
261 my ($self, $type_filter) = @_;
263 my $namespace = $self->namespace;
264 return keys %{$namespace} unless defined $type_filter;
267 # or we can filter based on
268 # type (SCALAR|ARRAY|HASH|CODE)
269 if ( $type_filter eq 'CODE' ) {
271 (ref($namespace->{$_})
272 ? (ref($namespace->{$_}) eq 'SCALAR')
273 : (ref(\$namespace->{$_}) eq 'GLOB'
274 && defined(*{$namespace->{$_}}{CODE})));
275 } keys %{$namespace};
277 return grep { *{$namespace->{$_}}{$type_filter} } keys %{$namespace};
283 sub wrap_method_body {
284 my ( $self, %args ) = @_;
286 ('CODE' eq ref $args{body})
287 || confess "Your code block must be a CODE reference";
289 $self->method_metaclass->wrap(
290 package_name => $self->name,
296 my ($self, $method_name, $method) = @_;
297 (defined $method_name && $method_name)
298 || confess "You must define a method name";
301 if (blessed($method)) {
302 $body = $method->body;
303 if ($method->package_name ne $self->name) {
304 $method = $method->clone(
305 package_name => $self->name,
307 ) if $method->can('clone');
312 $method = $self->wrap_method_body( body => $body, name => $method_name );
315 $method->attach_to_class($self);
317 $self->get_method_map->{$method_name} = $method;
319 my ( $current_package, $current_name ) = Class::MOP::get_code_info($body);
321 if ( !defined $current_name || $current_name eq '__ANON__' ) {
322 my $full_method_name = ($self->name . '::' . $method_name);
323 subname($full_method_name => $body);
326 $self->add_package_symbol(
327 { sigil => '&', type => 'CODE', name => $method_name },
333 my ($self, $method_name) = @_;
334 (defined $method_name && $method_name)
335 || confess "You must define a method name";
337 exists $self->get_method_map->{$method_name};
341 my ($self, $method_name) = @_;
342 (defined $method_name && $method_name)
343 || confess "You must define a method name";
345 return $self->get_method_map->{$method_name};
349 my ($self, $method_name) = @_;
350 (defined $method_name && $method_name)
351 || confess "You must define a method name";
353 my $removed_method = delete $self->get_method_map->{$method_name};
355 $self->remove_package_symbol(
356 { sigil => '&', type => 'CODE', name => $method_name }
359 $removed_method->detach_from_class if $removed_method;
361 $self->update_package_cache_flag; # still valid, since we just removed the method from the map
363 return $removed_method;
366 sub get_method_list {
368 keys %{$self->get_method_map};
380 Class::MOP::Package - Package Meta Object
384 The Package Protocol provides an abstraction of a Perl 5 package. A
385 package is basically namespace, and this module provides methods for
386 looking at and changing that namespace's symbol table.
392 =item B<< Class::MOP::Package->initialize($package_name) >>
394 This method creates a new C<Class::MOP::Package> instance which
395 represents specified package. If an existing metaclass object exists
396 for the package, that will be returned instead.
398 =item B<< Class::MOP::Package->reinitialize($package_name) >>
400 This method forcibly removes any existing metaclass for the package
401 before calling C<initialize>
403 Do not call this unless you know what you are doing.
405 =item B<< $metapackage->name >>
407 This is returns the package's name, as passed to the constructor.
409 =item B<< $metapackage->namespace >>
411 This returns a hash reference to the package's symbol table. The keys
412 are symbol names and the values are typeglob references.
414 =item B<< $metapackage->add_package_symbol($variable_name, $initial_value) >>
416 This method accepts a variable name and an optional initial value. The
417 C<$variable_name> must contain a leading sigil.
419 This method creates the variable in the package's symbol table, and
420 sets it to the initial value if one was provided.
422 =item B<< $metapackage->get_package_symbol($variable_name) >>
424 Given a variable name, this method returns the variable as a reference
425 or undef if it does not exist. The C<$variable_name> must contain a
428 =item B<< $metapackage->has_package_symbol($variable_name) >>
430 Returns true if there is a package variable defined for
431 C<$variable_name>. The C<$variable_name> must contain a leading sigil.
433 =item B<< $metapackage->remove_package_symbol($variable_name) >>
435 This will remove the package variable specified C<$variable_name>. The
436 C<$variable_name> must contain a leading sigil.
438 =item B<< $metapackage->remove_package_glob($glob_name) >>
440 Given the name of a glob, this will remove that glob from the
441 package's symbol table. Glob names do not include a sigil. Removing
442 the glob removes all variables and subroutines with the specified
445 =item B<< $metapackage->list_all_package_symbols($type_filter) >>
447 This will list all the glob names associated with the current
448 package. These names do not have leading sigils.
450 You can provide an optional type filter, which should be one of
451 'SCALAR', 'ARRAY', 'HASH', or 'CODE'.
453 =item B<< $metapackage->get_all_package_symbols($type_filter) >>
455 This works much like C<list_all_package_symbols>, but it returns a
456 hash reference. The keys are glob names and the values are references
457 to the value for that name.
461 =head2 Method introspection and creation
463 These methods allow you to introspect a class's methods, as well as
464 add, remove, or change methods.
466 Determining what is truly a method in a Perl 5 class requires some
467 heuristics (aka guessing).
469 Methods defined outside the package with a fully qualified name (C<sub
470 Package::name { ... }>) will be included. Similarly, methods named
471 with a fully qualified name using L<Sub::Name> are also included.
473 However, we attempt to ignore imported functions.
475 Ultimately, we are using heuristics to determine what truly is a
476 method in a class, and these heuristics may get the wrong answer in
477 some edge cases. However, for most "normal" cases the heuristics work
482 =item B<< $metapackage->get_method($method_name) >>
484 This will return a L<Class::MOP::Method> for the specified
485 C<$method_name>. If the class does not have the specified method, it
488 =item B<< $metapackage->has_method($method_name) >>
490 Returns a boolean indicating whether or not the class defines the
491 named method. It does not include methods inherited from parent
494 =item B<< $metapackage->get_method_map >>
496 Returns a hash reference representing the methods defined in this
497 class. The keys are method names and the values are
498 L<Class::MOP::Method> objects.
500 =item B<< $metapackage->get_method_list >>
502 This will return a list of method I<names> for all methods defined in
505 =item B<< $metapackage->add_method($method_name, $method) >>
507 This method takes a method name and a subroutine reference, and adds
508 the method to the class.
510 The subroutine reference can be a L<Class::MOP::Method>, and you are
511 strongly encouraged to pass a meta method object instead of a code
512 reference. If you do so, that object gets stored as part of the
513 class's method map directly. If not, the meta information will have to
514 be recreated later, and may be incorrect.
516 If you provide a method object, this method will clone that object if
517 the object's package name does not match the class name. This lets us
518 track the original source of any methods added from other classes
519 (notably Moose roles).
521 =item B<< $metapackage->remove_method($method_name) >>
523 Remove the named method from the class. This method returns the
524 L<Class::MOP::Method> object for the method.
526 =item B<< $metapackage->method_metaclass >>
528 Returns the class name of the method metaclass, see
529 L<Class::MOP::Method> for more information on the method metaclass.
531 =item B<< $metapackage->wrapped_method_metaclass >>
533 Returns the class name of the wrapped method metaclass, see
534 L<Class::MOP::Method::Wrapped> for more information on the wrapped
537 =item B<< Class::MOP::Package->meta >>
539 This will return a L<Class::MOP::Class> instance for this class.
545 Stevan Little E<lt>stevan@iinteractive.comE<gt>
547 =head1 COPYRIGHT AND LICENSE
549 Copyright 2006-2009 by Infinity Interactive, Inc.
551 L<http://www.iinteractive.com>
553 This library is free software; you can redistribute it and/or modify
554 it under the same terms as Perl itself.