2 package Class::MOP::Package;
7 use Scalar::Util 'blessed', 'reftype';
9 use Sub::Name 'subname';
11 our $VERSION = '0.92';
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 no warnings 'uninitialized';
104 \%{$_[0]->{'package'} . '::'}
107 sub method_metaclass { $_[0]->{'method_metaclass'} }
108 sub wrapped_method_metaclass { $_[0]->{'wrapped_method_metaclass'} }
110 sub _method_map { $_[0]->{'methods'} }
122 sub _deconstruct_variable_name {
123 my ($self, $variable) = @_;
126 || confess "You must pass a variable name";
128 my $sigil = substr($variable, 0, 1, '');
131 || confess "The variable name must include a sigil";
133 (exists $SIGIL_MAP{$sigil})
134 || confess "I do not recognize that sigil '$sigil'";
136 return ($variable, $sigil, $SIGIL_MAP{$sigil});
142 # ... these functions have to touch the symbol table itself,.. yuk
144 sub remove_package_glob {
145 my ($self, $name) = @_;
146 delete $self->namespace->{$name};
149 sub remove_package_symbol {
150 my ($self, $variable) = @_;
152 my ($name, $sigil, $type) = ref $variable eq 'HASH'
153 ? @{$variable}{qw[name sigil type]}
154 : $self->_deconstruct_variable_name($variable);
157 # no doubt this is grossly inefficient and
158 # could be done much easier and faster in XS
160 my ($scalar_desc, $array_desc, $hash_desc, $code_desc) = (
161 { sigil => '$', type => 'SCALAR', name => $name },
162 { sigil => '@', type => 'ARRAY', name => $name },
163 { sigil => '%', type => 'HASH', name => $name },
164 { sigil => '&', type => 'CODE', name => $name },
167 my ($scalar, $array, $hash, $code);
168 if ($type eq 'SCALAR') {
169 $array = $self->get_package_symbol($array_desc) if $self->has_package_symbol($array_desc);
170 $hash = $self->get_package_symbol($hash_desc) if $self->has_package_symbol($hash_desc);
171 $code = $self->get_package_symbol($code_desc) if $self->has_package_symbol($code_desc);
173 elsif ($type eq 'ARRAY') {
174 $scalar = $self->get_package_symbol($scalar_desc) if $self->has_package_symbol($scalar_desc);
175 $hash = $self->get_package_symbol($hash_desc) if $self->has_package_symbol($hash_desc);
176 $code = $self->get_package_symbol($code_desc) if $self->has_package_symbol($code_desc);
178 elsif ($type eq 'HASH') {
179 $scalar = $self->get_package_symbol($scalar_desc) if $self->has_package_symbol($scalar_desc);
180 $array = $self->get_package_symbol($array_desc) if $self->has_package_symbol($array_desc);
181 $code = $self->get_package_symbol($code_desc) if $self->has_package_symbol($code_desc);
183 elsif ($type eq 'CODE') {
184 $scalar = $self->get_package_symbol($scalar_desc) if $self->has_package_symbol($scalar_desc);
185 $array = $self->get_package_symbol($array_desc) if $self->has_package_symbol($array_desc);
186 $hash = $self->get_package_symbol($hash_desc) if $self->has_package_symbol($hash_desc);
189 confess "This should never ever ever happen";
192 $self->remove_package_glob($name);
194 $self->add_package_symbol($scalar_desc => $scalar) if defined $scalar;
195 $self->add_package_symbol($array_desc => $array) if defined $array;
196 $self->add_package_symbol($hash_desc => $hash) if defined $hash;
197 $self->add_package_symbol($code_desc => $code) if defined $code;
200 sub list_all_package_symbols {
201 my ($self, $type_filter) = @_;
203 my $namespace = $self->namespace;
204 return keys %{$namespace} unless defined $type_filter;
207 # or we can filter based on
208 # type (SCALAR|ARRAY|HASH|CODE)
209 if ( $type_filter eq 'CODE' ) {
211 (ref($namespace->{$_})
212 ? (ref($namespace->{$_}) eq 'SCALAR')
213 : (ref(\$namespace->{$_}) eq 'GLOB'
214 && defined(*{$namespace->{$_}}{CODE})));
215 } keys %{$namespace};
217 return grep { *{$namespace->{$_}}{$type_filter} } keys %{$namespace};
223 sub wrap_method_body {
224 my ( $self, %args ) = @_;
226 ('CODE' eq ref $args{body})
227 || confess "Your code block must be a CODE reference";
229 $self->method_metaclass->wrap(
230 package_name => $self->name,
236 my ($self, $method_name, $method) = @_;
237 (defined $method_name && $method_name)
238 || confess "You must define a method name";
241 if (blessed($method)) {
242 $body = $method->body;
243 if ($method->package_name ne $self->name) {
244 $method = $method->clone(
245 package_name => $self->name,
247 ) if $method->can('clone');
250 $method->attach_to_class($self);
251 $self->_method_map->{$method_name} = $method;
254 # If a raw code reference is supplied, its method object is not created.
255 # The method object won't be created until required.
260 my ( $current_package, $current_name ) = Class::MOP::get_code_info($body);
262 if ( !defined $current_name || $current_name eq '__ANON__' ) {
263 my $full_method_name = ($self->name . '::' . $method_name);
264 subname($full_method_name => $body);
267 $self->add_package_symbol(
268 { sigil => '&', type => 'CODE', name => $method_name },
274 my ( $self, $code ) = @_;
276 my ( $code_package, $code_name ) = Class::MOP::get_code_info($code);
278 return $code_package && $code_package eq $self->name
279 || ( $code_package eq 'constant' && $code_name eq '__ANON__' );
283 my ($self, $method_name) = @_;
284 (defined $method_name && $method_name)
285 || confess "You must define a method name";
287 return defined($self->get_method($method_name));
291 my ($self, $method_name) = @_;
292 (defined $method_name && $method_name)
293 || confess "You must define a method name";
295 my $method_map = $self->_method_map;
296 my $method_object = $method_map->{$method_name};
297 my $code = $self->get_package_symbol({
298 name => $method_name,
303 unless ( $method_object && $method_object->body == ( $code || 0 ) ) {
304 if ( $code && $self->_code_is_mine($code) ) {
305 $method_object = $method_map->{$method_name}
306 = $self->wrap_method_body(
308 name => $method_name,
309 associated_metaclass => $self,
313 delete $method_map->{$method_name};
318 return $method_object;
322 my ($self, $method_name) = @_;
323 (defined $method_name && $method_name)
324 || confess "You must define a method name";
326 my $removed_method = delete $self->get_method_map->{$method_name};
328 $self->remove_package_symbol(
329 { sigil => '&', type => 'CODE', name => $method_name }
332 $removed_method->detach_from_class if $removed_method;
334 $self->update_package_cache_flag; # still valid, since we just removed the method from the map
336 return $removed_method;
339 sub get_method_list {
341 return grep { $self->has_method($_) } keys %{ $self->namespace };
352 Class::MOP::Package - Package Meta Object
356 The Package Protocol provides an abstraction of a Perl 5 package. A
357 package is basically namespace, and this module provides methods for
358 looking at and changing that namespace's symbol table.
364 =item B<< Class::MOP::Package->initialize($package_name) >>
366 This method creates a new C<Class::MOP::Package> instance which
367 represents specified package. If an existing metaclass object exists
368 for the package, that will be returned instead.
370 =item B<< Class::MOP::Package->reinitialize($package) >>
372 This method forcibly removes any existing metaclass for the package
373 before calling C<initialize>. In contrast to C<initialize>, you may
374 also pass an existing C<Class::MOP::Package> instance instead of just
375 a package name as C<$package>.
377 Do not call this unless you know what you are doing.
379 =item B<< $metapackage->name >>
381 This is returns the package's name, as passed to the constructor.
383 =item B<< $metapackage->namespace >>
385 This returns a hash reference to the package's symbol table. The keys
386 are symbol names and the values are typeglob references.
388 =item B<< $metapackage->add_package_symbol($variable_name, $initial_value) >>
390 This method accepts a variable name and an optional initial value. The
391 C<$variable_name> must contain a leading sigil.
393 This method creates the variable in the package's symbol table, and
394 sets it to the initial value if one was provided.
396 =item B<< $metapackage->get_package_symbol($variable_name) >>
398 Given a variable name, this method returns the variable as a reference
399 or undef if it does not exist. The C<$variable_name> must contain a
402 =item B<< $metapackage->has_package_symbol($variable_name) >>
404 Returns true if there is a package variable defined for
405 C<$variable_name>. The C<$variable_name> must contain a leading sigil.
407 =item B<< $metapackage->remove_package_symbol($variable_name) >>
409 This will remove the package variable specified C<$variable_name>. The
410 C<$variable_name> must contain a leading sigil.
412 =item B<< $metapackage->remove_package_glob($glob_name) >>
414 Given the name of a glob, this will remove that glob from the
415 package's symbol table. Glob names do not include a sigil. Removing
416 the glob removes all variables and subroutines with the specified
419 =item B<< $metapackage->list_all_package_symbols($type_filter) >>
421 This will list all the glob names associated with the current
422 package. These names do not have leading sigils.
424 You can provide an optional type filter, which should be one of
425 'SCALAR', 'ARRAY', 'HASH', or 'CODE'.
427 =item B<< $metapackage->get_all_package_symbols($type_filter) >>
429 This works much like C<list_all_package_symbols>, but it returns a
430 hash reference. The keys are glob names and the values are references
431 to the value for that name.
435 =head2 Method introspection and creation
437 These methods allow you to introspect a class's methods, as well as
438 add, remove, or change methods.
440 Determining what is truly a method in a Perl 5 class requires some
441 heuristics (aka guessing).
443 Methods defined outside the package with a fully qualified name (C<sub
444 Package::name { ... }>) will be included. Similarly, methods named
445 with a fully qualified name using L<Sub::Name> are also included.
447 However, we attempt to ignore imported functions.
449 Ultimately, we are using heuristics to determine what truly is a
450 method in a class, and these heuristics may get the wrong answer in
451 some edge cases. However, for most "normal" cases the heuristics work
456 =item B<< $metapackage->get_method($method_name) >>
458 This will return a L<Class::MOP::Method> for the specified
459 C<$method_name>. If the class does not have the specified method, it
462 =item B<< $metapackage->has_method($method_name) >>
464 Returns a boolean indicating whether or not the class defines the
465 named method. It does not include methods inherited from parent
468 =item B<< $metapackage->get_method_map >>
470 Returns a hash reference representing the methods defined in this
471 class. The keys are method names and the values are
472 L<Class::MOP::Method> objects.
474 =item B<< $metapackage->get_method_list >>
476 This will return a list of method I<names> for all methods defined in
479 =item B<< $metapackage->add_method($method_name, $method) >>
481 This method takes a method name and a subroutine reference, and adds
482 the method to the class.
484 The subroutine reference can be a L<Class::MOP::Method>, and you are
485 strongly encouraged to pass a meta method object instead of a code
486 reference. If you do so, that object gets stored as part of the
487 class's method map directly. If not, the meta information will have to
488 be recreated later, and may be incorrect.
490 If you provide a method object, this method will clone that object if
491 the object's package name does not match the class name. This lets us
492 track the original source of any methods added from other classes
493 (notably Moose roles).
495 =item B<< $metapackage->remove_method($method_name) >>
497 Remove the named method from the class. This method returns the
498 L<Class::MOP::Method> object for the method.
500 =item B<< $metapackage->method_metaclass >>
502 Returns the class name of the method metaclass, see
503 L<Class::MOP::Method> for more information on the method metaclass.
505 =item B<< $metapackage->wrapped_method_metaclass >>
507 Returns the class name of the wrapped method metaclass, see
508 L<Class::MOP::Method::Wrapped> for more information on the wrapped
511 =item B<< Class::MOP::Package->meta >>
513 This will return a L<Class::MOP::Class> instance for this class.
519 Stevan Little E<lt>stevan@iinteractive.comE<gt>
521 =head1 COPYRIGHT AND LICENSE
523 Copyright 2006-2009 by Infinity Interactive, Inc.
525 L<http://www.iinteractive.com>
527 This library is free software; you can redistribute it and/or modify
528 it under the same terms as Perl itself.