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.
259 $self->add_package_symbol(
260 { sigil => '&', type => 'CODE', name => $method_name },
266 my ( $self, $code ) = @_;
268 my ( $code_package, $code_name ) = Class::MOP::get_code_info($code);
270 return $code_package && $code_package eq $self->name
271 || ( $code_package eq 'constant' && $code_name eq '__ANON__' );
275 my ($self, $method_name) = @_;
276 (defined $method_name && $method_name)
277 || confess "You must define a method name";
279 return defined($self->get_method($method_name));
283 my ($self, $method_name) = @_;
284 (defined $method_name && $method_name)
285 || confess "You must define a method name";
287 my $method_map = $self->_method_map;
288 my $method_object = $method_map->{$method_name};
289 my $code = $self->get_package_symbol({
290 name => $method_name,
295 unless ( $method_object && $method_object->body == ( $code || 0 ) ) {
296 if ( $code && $self->_code_is_mine($code) ) {
297 $method_object = $method_map->{$method_name}
298 = $self->wrap_method_body(
300 name => $method_name,
301 associated_metaclass => $self,
305 delete $method_map->{$method_name};
310 return $method_object;
314 my ($self, $method_name) = @_;
315 (defined $method_name && $method_name)
316 || confess "You must define a method name";
318 my $removed_method = delete $self->get_method_map->{$method_name};
320 $self->remove_package_symbol(
321 { sigil => '&', type => 'CODE', name => $method_name }
324 $removed_method->detach_from_class if $removed_method;
326 $self->update_package_cache_flag; # still valid, since we just removed the method from the map
328 return $removed_method;
331 sub get_method_list {
333 return grep { $self->has_method($_) } keys %{ $self->namespace };
344 Class::MOP::Package - Package Meta Object
348 The Package Protocol provides an abstraction of a Perl 5 package. A
349 package is basically namespace, and this module provides methods for
350 looking at and changing that namespace's symbol table.
356 =item B<< Class::MOP::Package->initialize($package_name) >>
358 This method creates a new C<Class::MOP::Package> instance which
359 represents specified package. If an existing metaclass object exists
360 for the package, that will be returned instead.
362 =item B<< Class::MOP::Package->reinitialize($package) >>
364 This method forcibly removes any existing metaclass for the package
365 before calling C<initialize>. In contrast to C<initialize>, you may
366 also pass an existing C<Class::MOP::Package> instance instead of just
367 a package name as C<$package>.
369 Do not call this unless you know what you are doing.
371 =item B<< $metapackage->name >>
373 This is returns the package's name, as passed to the constructor.
375 =item B<< $metapackage->namespace >>
377 This returns a hash reference to the package's symbol table. The keys
378 are symbol names and the values are typeglob references.
380 =item B<< $metapackage->add_package_symbol($variable_name, $initial_value) >>
382 This method accepts a variable name and an optional initial value. The
383 C<$variable_name> must contain a leading sigil.
385 This method creates the variable in the package's symbol table, and
386 sets it to the initial value if one was provided.
388 =item B<< $metapackage->get_package_symbol($variable_name) >>
390 Given a variable name, this method returns the variable as a reference
391 or undef if it does not exist. The C<$variable_name> must contain a
394 =item B<< $metapackage->has_package_symbol($variable_name) >>
396 Returns true if there is a package variable defined for
397 C<$variable_name>. The C<$variable_name> must contain a leading sigil.
399 =item B<< $metapackage->remove_package_symbol($variable_name) >>
401 This will remove the package variable specified C<$variable_name>. The
402 C<$variable_name> must contain a leading sigil.
404 =item B<< $metapackage->remove_package_glob($glob_name) >>
406 Given the name of a glob, this will remove that glob from the
407 package's symbol table. Glob names do not include a sigil. Removing
408 the glob removes all variables and subroutines with the specified
411 =item B<< $metapackage->list_all_package_symbols($type_filter) >>
413 This will list all the glob names associated with the current
414 package. These names do not have leading sigils.
416 You can provide an optional type filter, which should be one of
417 'SCALAR', 'ARRAY', 'HASH', or 'CODE'.
419 =item B<< $metapackage->get_all_package_symbols($type_filter) >>
421 This works much like C<list_all_package_symbols>, but it returns a
422 hash reference. The keys are glob names and the values are references
423 to the value for that name.
427 =head2 Method introspection and creation
429 These methods allow you to introspect a class's methods, as well as
430 add, remove, or change methods.
432 Determining what is truly a method in a Perl 5 class requires some
433 heuristics (aka guessing).
435 Methods defined outside the package with a fully qualified name (C<sub
436 Package::name { ... }>) will be included. Similarly, methods named
437 with a fully qualified name using L<Sub::Name> are also included.
439 However, we attempt to ignore imported functions.
441 Ultimately, we are using heuristics to determine what truly is a
442 method in a class, and these heuristics may get the wrong answer in
443 some edge cases. However, for most "normal" cases the heuristics work
448 =item B<< $metapackage->get_method($method_name) >>
450 This will return a L<Class::MOP::Method> for the specified
451 C<$method_name>. If the class does not have the specified method, it
454 =item B<< $metapackage->has_method($method_name) >>
456 Returns a boolean indicating whether or not the class defines the
457 named method. It does not include methods inherited from parent
460 =item B<< $metapackage->get_method_map >>
462 Returns a hash reference representing the methods defined in this
463 class. The keys are method names and the values are
464 L<Class::MOP::Method> objects.
466 =item B<< $metapackage->get_method_list >>
468 This will return a list of method I<names> for all methods defined in
471 =item B<< $metapackage->add_method($method_name, $method) >>
473 This method takes a method name and a subroutine reference, and adds
474 the method to the class.
476 The subroutine reference can be a L<Class::MOP::Method>, and you are
477 strongly encouraged to pass a meta method object instead of a code
478 reference. If you do so, that object gets stored as part of the
479 class's method map directly. If not, the meta information will have to
480 be recreated later, and may be incorrect.
482 If you provide a method object, this method will clone that object if
483 the object's package name does not match the class name. This lets us
484 track the original source of any methods added from other classes
485 (notably Moose roles).
487 =item B<< $metapackage->remove_method($method_name) >>
489 Remove the named method from the class. This method returns the
490 L<Class::MOP::Method> object for the method.
492 =item B<< $metapackage->method_metaclass >>
494 Returns the class name of the method metaclass, see
495 L<Class::MOP::Method> for more information on the method metaclass.
497 =item B<< $metapackage->wrapped_method_metaclass >>
499 Returns the class name of the wrapped method metaclass, see
500 L<Class::MOP::Method::Wrapped> for more information on the wrapped
503 =item B<< Class::MOP::Package->meta >>
505 This will return a L<Class::MOP::Class> instance for this class.
511 Stevan Little E<lt>stevan@iinteractive.comE<gt>
513 =head1 COPYRIGHT AND LICENSE
515 Copyright 2006-2009 by Infinity Interactive, Inc.
517 L<http://www.iinteractive.com>
519 This library is free software; you can redistribute it and/or modify
520 it under the same terms as Perl itself.