refactor load_first_existing_class
[gitmo/Class-MOP.git] / lib / Class / MOP / Package.pm
CommitLineData
2243a22b 1
2package Class::MOP::Package;
3
4use strict;
5use warnings;
6
812d58f9 7use Scalar::Util 'blessed', 'reftype';
6d5355c3 8use Carp 'confess';
b1ff395f 9use Sub::Name 'subname';
2243a22b 10
f6ca0704 11our $VERSION = '0.94';
d519662a 12$VERSION = eval $VERSION;
f0480c45 13our $AUTHORITY = 'cpan:STEVAN';
2243a22b 14
6e57504d 15use base 'Class::MOP::Object';
16
6d5355c3 17# creation ...
18
19sub initialize {
3be6bc1c 20 my ( $class, @args ) = @_;
21
22 unshift @args, "package" if @args % 2;
23
24 my %options = @args;
25 my $package_name = $options{package};
26
27
9d6dce77 28 # we hand-construct the class
29 # until we can bootstrap it
a19fcb5b 30 if ( my $meta = Class::MOP::get_metaclass_by_name($package_name) ) {
973de492 31 return $meta;
a19fcb5b 32 } else {
973de492 33 my $meta = ( ref $class || $class )->_new({
34 'package' => $package_name,
11ac821d 35 %options,
973de492 36 });
973de492 37 Class::MOP::store_metaclass_by_name($package_name, $meta);
a19fcb5b 38
973de492 39 return $meta;
a19fcb5b 40 }
41}
42
43sub reinitialize {
3be6bc1c 44 my ( $class, @args ) = @_;
45
46 unshift @args, "package" if @args % 2;
47
48 my %options = @args;
3eda22f8 49 my $package_name = delete $options{package};
3be6bc1c 50
7975280a 51 (defined $package_name && $package_name
52 && (!blessed $package_name || $package_name->isa('Class::MOP::Package')))
53 || confess "You must pass a package name or an existing Class::MOP::Package instance";
54
55 $package_name = $package_name->name
56 if blessed $package_name;
3be6bc1c 57
a19fcb5b 58 Class::MOP::remove_metaclass_by_name($package_name);
3be6bc1c 59
3eda22f8 60 $class->initialize($package_name, %options); # call with first arg form for compat
682655a3 61}
62
63sub _new {
0bfc85b8 64 my $class = shift;
812d58f9 65
ec9e38e5 66 return Class::MOP::Class->initialize($class)->new_object(@_)
812d58f9 67 if $class ne __PACKAGE__;
682655a3 68
ec9e38e5 69 my $params = @_ == 1 ? $_[0] : {@_};
70
71 return bless {
72 package => $params->{package},
73
74 # NOTE:
75 # because of issues with the Perl API
76 # to the typeglob in some versions, we
77 # need to just always grab a new
78 # reference to the hash in the accessor.
79 # Ideally we could just store a ref and
80 # it would Just Work, but oh well :\
81
82 namespace => \undef,
0bfc85b8 83
ec9e38e5 84 } => $class;
6d5355c3 85}
86
87# Attributes
88
89# NOTE:
90# all these attribute readers will be bootstrapped
91# away in the Class::MOP bootstrap section
92
56dcfc1a 93sub namespace {
94 # NOTE:
95 # because of issues with the Perl API
96 # to the typeglob in some versions, we
97 # need to just always grab a new
98 # reference to the hash here. Ideally
99 # we could just store a ref and it would
100 # Just Work, but oh well :\
101 no strict 'refs';
8683db0e 102 \%{$_[0]->{'package'} . '::'}
56dcfc1a 103}
6d5355c3 104
b1ff395f 105sub method_metaclass { $_[0]->{'method_metaclass'} }
106sub wrapped_method_metaclass { $_[0]->{'wrapped_method_metaclass'} }
107
241646a3 108# This doesn't always get initialized in a constructor because there is a
109# weird object construction path for subclasses of Class::MOP::Class. At one
110# point, this always got initialized by calling into the XS code first, but
111# that is no longer guaranteed to happen.
112sub _method_map { $_[0]->{'methods'} ||= {} }
4eb970b2 113
a5e51f0b 114# utility methods
6d5355c3 115
c0cbf4d9 116{
117 my %SIGIL_MAP = (
118 '$' => 'SCALAR',
119 '@' => 'ARRAY',
120 '%' => 'HASH',
121 '&' => 'CODE',
122 );
6d5355c3 123
a5e51f0b 124 sub _deconstruct_variable_name {
125 my ($self, $variable) = @_;
126
c0cbf4d9 127 (defined $variable)
128 || confess "You must pass a variable name";
a5e51f0b 129
f430cfa4 130 my $sigil = substr($variable, 0, 1, '');
a5e51f0b 131
c0cbf4d9 132 (defined $sigil)
133 || confess "The variable name must include a sigil";
a5e51f0b 134
c0cbf4d9 135 (exists $SIGIL_MAP{$sigil})
a5e51f0b 136 || confess "I do not recognize that sigil '$sigil'";
137
f430cfa4 138 return ($variable, $sigil, $SIGIL_MAP{$sigil});
c0cbf4d9 139 }
a5e51f0b 140}
6d5355c3 141
a5e51f0b 142# Class attributes
6d5355c3 143
c46b802b 144# ... these functions have to touch the symbol table itself,.. yuk
145
86e1c8d8 146sub add_package_symbol {
147 my ($self, $variable, $initial_value) = @_;
148
149 my ($name, $sigil, $type) = ref $variable eq 'HASH'
150 ? @{$variable}{qw[name sigil type]}
151 : $self->_deconstruct_variable_name($variable);
152
153 my $pkg = $self->{'package'};
154
155 no strict 'refs';
156 no warnings 'redefine', 'misc', 'prototype';
157 *{$pkg . '::' . $name} = ref $initial_value ? $initial_value : \$initial_value;
158}
159
c46b802b 160sub remove_package_glob {
161 my ($self, $name) = @_;
86e1c8d8 162 no strict 'refs';
163 delete ${$self->name . '::'}{$name};
164}
165
166# ... these functions deal with stuff on the namespace level
167
168sub has_package_symbol {
169 my ( $self, $variable ) = @_;
170
171 my ( $name, $sigil, $type )
172 = ref $variable eq 'HASH'
173 ? @{$variable}{qw[name sigil type]}
174 : $self->_deconstruct_variable_name($variable);
175
176 my $namespace = $self->namespace;
177
178 return 0 unless exists $namespace->{$name};
179
180 my $entry_ref = \$namespace->{$name};
181 if ( reftype($entry_ref) eq 'GLOB' ) {
182 if ( $type eq 'SCALAR' ) {
183 return defined( ${ *{$entry_ref}{SCALAR} } );
184 }
185 else {
186 return defined( *{$entry_ref}{$type} );
187 }
188 }
189 else {
190
191 # a symbol table entry can be -1 (stub), string (stub with prototype),
192 # or reference (constant)
193 return $type eq 'CODE';
194 }
195}
196
197sub get_package_symbol {
198 my ($self, $variable) = @_;
199
200 my ($name, $sigil, $type) = ref $variable eq 'HASH'
201 ? @{$variable}{qw[name sigil type]}
202 : $self->_deconstruct_variable_name($variable);
203
204 my $namespace = $self->namespace;
205
206 # FIXME
207 $self->add_package_symbol($variable)
208 unless exists $namespace->{$name};
209
210 my $entry_ref = \$namespace->{$name};
211
212 if ( ref($entry_ref) eq 'GLOB' ) {
213 return *{$entry_ref}{$type};
214 }
215 else {
216 if ( $type eq 'CODE' ) {
217 no strict 'refs';
218 return \&{ $self->name . '::' . $name };
219 }
220 else {
221 return undef;
222 }
223 }
a5e51f0b 224}
6d5355c3 225
a5e51f0b 226sub remove_package_symbol {
227 my ($self, $variable) = @_;
228
8b49a472 229 my ($name, $sigil, $type) = ref $variable eq 'HASH'
230 ? @{$variable}{qw[name sigil type]}
231 : $self->_deconstruct_variable_name($variable);
a5e51f0b 232
c46b802b 233 # FIXME:
234 # no doubt this is grossly inefficient and
235 # could be done much easier and faster in XS
236
8b49a472 237 my ($scalar_desc, $array_desc, $hash_desc, $code_desc) = (
238 { sigil => '$', type => 'SCALAR', name => $name },
239 { sigil => '@', type => 'ARRAY', name => $name },
240 { sigil => '%', type => 'HASH', name => $name },
241 { sigil => '&', type => 'CODE', name => $name },
242 );
243
c46b802b 244 my ($scalar, $array, $hash, $code);
a5e51f0b 245 if ($type eq 'SCALAR') {
8b49a472 246 $array = $self->get_package_symbol($array_desc) if $self->has_package_symbol($array_desc);
247 $hash = $self->get_package_symbol($hash_desc) if $self->has_package_symbol($hash_desc);
248 $code = $self->get_package_symbol($code_desc) if $self->has_package_symbol($code_desc);
a5e51f0b 249 }
250 elsif ($type eq 'ARRAY') {
8b49a472 251 $scalar = $self->get_package_symbol($scalar_desc) if $self->has_package_symbol($scalar_desc);
252 $hash = $self->get_package_symbol($hash_desc) if $self->has_package_symbol($hash_desc);
253 $code = $self->get_package_symbol($code_desc) if $self->has_package_symbol($code_desc);
a5e51f0b 254 }
255 elsif ($type eq 'HASH') {
8b49a472 256 $scalar = $self->get_package_symbol($scalar_desc) if $self->has_package_symbol($scalar_desc);
257 $array = $self->get_package_symbol($array_desc) if $self->has_package_symbol($array_desc);
258 $code = $self->get_package_symbol($code_desc) if $self->has_package_symbol($code_desc);
a5e51f0b 259 }
260 elsif ($type eq 'CODE') {
8b49a472 261 $scalar = $self->get_package_symbol($scalar_desc) if $self->has_package_symbol($scalar_desc);
262 $array = $self->get_package_symbol($array_desc) if $self->has_package_symbol($array_desc);
263 $hash = $self->get_package_symbol($hash_desc) if $self->has_package_symbol($hash_desc);
a5e51f0b 264 }
265 else {
266 confess "This should never ever ever happen";
7f436b8c 267 }
c46b802b 268
269 $self->remove_package_glob($name);
270
8b49a472 271 $self->add_package_symbol($scalar_desc => $scalar) if defined $scalar;
272 $self->add_package_symbol($array_desc => $array) if defined $array;
273 $self->add_package_symbol($hash_desc => $hash) if defined $hash;
274 $self->add_package_symbol($code_desc => $code) if defined $code;
9d6dce77 275}
c0cbf4d9 276
9d6dce77 277sub list_all_package_symbols {
92330ee2 278 my ($self, $type_filter) = @_;
a38e4d1a 279
280 my $namespace = $self->namespace;
281 return keys %{$namespace} unless defined $type_filter;
282
91e0eb4a 283 # NOTE:
92330ee2 284 # or we can filter based on
285 # type (SCALAR|ARRAY|HASH|CODE)
3609af79 286 if ( $type_filter eq 'CODE' ) {
287 return grep {
92af7fdf 288 (ref($namespace->{$_})
3609af79 289 ? (ref($namespace->{$_}) eq 'SCALAR')
290 : (ref(\$namespace->{$_}) eq 'GLOB'
291 && defined(*{$namespace->{$_}}{CODE})));
292 } keys %{$namespace};
293 } else {
294 return grep { *{$namespace->{$_}}{$type_filter} } keys %{$namespace};
295 }
6d5355c3 296}
297
b1ff395f 298## Methods
299
300sub wrap_method_body {
301 my ( $self, %args ) = @_;
302
303 ('CODE' eq ref $args{body})
304 || confess "Your code block must be a CODE reference";
305
306 $self->method_metaclass->wrap(
307 package_name => $self->name,
308 %args,
309 );
310}
311
312sub add_method {
313 my ($self, $method_name, $method) = @_;
314 (defined $method_name && $method_name)
315 || confess "You must define a method name";
316
317 my $body;
318 if (blessed($method)) {
319 $body = $method->body;
320 if ($method->package_name ne $self->name) {
321 $method = $method->clone(
322 package_name => $self->name,
4eb970b2 323 name => $method_name
b1ff395f 324 ) if $method->can('clone');
325 }
4eb970b2 326
327 $method->attach_to_class($self);
b1ff395f 328 }
329 else {
4eb970b2 330 # If a raw code reference is supplied, its method object is not created.
331 # The method object won't be created until required.
b1ff395f 332 $body = $method;
b1ff395f 333 }
47219b29 334
5327fc78 335 $self->_method_map->{$method_name} = $method;
6eefe0df 336
337 my ( $current_package, $current_name ) = Class::MOP::get_code_info($body);
338
339 if ( !defined $current_name || $current_name eq '__ANON__' ) {
340 my $full_method_name = ($self->name . '::' . $method_name);
341 subname($full_method_name => $body);
342 }
343
b1ff395f 344 $self->add_package_symbol(
345 { sigil => '&', type => 'CODE', name => $method_name },
346 $body,
347 );
348}
349
4eb970b2 350sub _code_is_mine {
351 my ( $self, $code ) = @_;
352
353 my ( $code_package, $code_name ) = Class::MOP::get_code_info($code);
354
355 return $code_package && $code_package eq $self->name
356 || ( $code_package eq 'constant' && $code_name eq '__ANON__' );
357}
358
b1ff395f 359sub has_method {
360 my ($self, $method_name) = @_;
b89a595f 361
362 defined($method_name)
b1ff395f 363 || confess "You must define a method name";
364
4eb970b2 365 return defined($self->get_method($method_name));
b1ff395f 366}
367
368sub get_method {
5327fc78 369 my ( $self, $method_name ) = @_;
b89a595f 370
371 defined($method_name)
b1ff395f 372 || confess "You must define a method name";
373
5327fc78 374 my $method_map = $self->_method_map;
375 my $map_entry = $method_map->{$method_name};
376 my $code = $self->get_package_symbol(
377 {
378 name => $method_name,
379 sigil => '&',
380 type => 'CODE',
4eb970b2 381 }
5327fc78 382 );
383
018cba1d 384 # This seems to happen in some weird cases where methods modifiers are
385 # added via roles or some other such bizareness. Honestly, I don't totally
386 # understand this, but returning the entry works, and keeps various MX
387 # modules from blowing up. - DR
388 return $map_entry if blessed $map_entry && !$code;
8885b924 389
390 return $map_entry if blessed $map_entry && $map_entry->body == $code;
5327fc78 391
392 unless ($map_entry) {
393 return unless $code && $self->_code_is_mine($code);
4eb970b2 394 }
395
5327fc78 396 $code ||= $map_entry;
397
398 return $method_map->{$method_name} = $self->wrap_method_body(
399 body => $code,
400 name => $method_name,
401 associated_metaclass => $self,
402 );
b1ff395f 403}
404
405sub remove_method {
406 my ($self, $method_name) = @_;
407 (defined $method_name && $method_name)
408 || confess "You must define a method name";
409
241646a3 410 my $removed_method = delete $self->_full_method_map->{$method_name};
4eb970b2 411
b1ff395f 412 $self->remove_package_symbol(
413 { sigil => '&', type => 'CODE', name => $method_name }
414 );
415
5327fc78 416 $removed_method->detach_from_class if $removed_method && blessed $removed_method;
b1ff395f 417
418 $self->update_package_cache_flag; # still valid, since we just removed the method from the map
419
420 return $removed_method;
421}
422
423sub get_method_list {
424 my $self = shift;
4eb970b2 425 return grep { $self->has_method($_) } keys %{ $self->namespace };
b1ff395f 426}
427
2243a22b 4281;
429
430__END__
431
432=pod
433
434=head1 NAME
435
436Class::MOP::Package - Package Meta Object
437
2243a22b 438=head1 DESCRIPTION
439
116a9f45 440The Package Protocol provides an abstraction of a Perl 5 package. A
441package is basically namespace, and this module provides methods for
442looking at and changing that namespace's symbol table.
121991f6 443
2243a22b 444=head1 METHODS
445
446=over 4
447
116a9f45 448=item B<< Class::MOP::Package->initialize($package_name) >>
449
450This method creates a new C<Class::MOP::Package> instance which
451represents specified package. If an existing metaclass object exists
452for the package, that will be returned instead.
453
7975280a 454=item B<< Class::MOP::Package->reinitialize($package) >>
2243a22b 455
116a9f45 456This method forcibly removes any existing metaclass for the package
7975280a 457before calling C<initialize>. In contrast to C<initialize>, you may
458also pass an existing C<Class::MOP::Package> instance instead of just
459a package name as C<$package>.
127d39a7 460
116a9f45 461Do not call this unless you know what you are doing.
6d5355c3 462
116a9f45 463=item B<< $metapackage->name >>
127d39a7 464
116a9f45 465This is returns the package's name, as passed to the constructor.
a19fcb5b 466
116a9f45 467=item B<< $metapackage->namespace >>
a19fcb5b 468
116a9f45 469This returns a hash reference to the package's symbol table. The keys
470are symbol names and the values are typeglob references.
6d5355c3 471
116a9f45 472=item B<< $metapackage->add_package_symbol($variable_name, $initial_value) >>
b9d9fc0b 473
116a9f45 474This method accepts a variable name and an optional initial value. The
475C<$variable_name> must contain a leading sigil.
a5e51f0b 476
116a9f45 477This method creates the variable in the package's symbol table, and
478sets it to the initial value if one was provided.
b9d9fc0b 479
116a9f45 480=item B<< $metapackage->get_package_symbol($variable_name) >>
b9d9fc0b 481
116a9f45 482Given a variable name, this method returns the variable as a reference
483or undef if it does not exist. The C<$variable_name> must contain a
484leading sigil.
b9d9fc0b 485
116a9f45 486=item B<< $metapackage->has_package_symbol($variable_name) >>
6d5355c3 487
116a9f45 488Returns true if there is a package variable defined for
489C<$variable_name>. The C<$variable_name> must contain a leading sigil.
6d5355c3 490
116a9f45 491=item B<< $metapackage->remove_package_symbol($variable_name) >>
6d5355c3 492
116a9f45 493This will remove the package variable specified C<$variable_name>. The
494C<$variable_name> must contain a leading sigil.
6d5355c3 495
116a9f45 496=item B<< $metapackage->remove_package_glob($glob_name) >>
b9d9fc0b 497
116a9f45 498Given the name of a glob, this will remove that glob from the
499package's symbol table. Glob names do not include a sigil. Removing
500the glob removes all variables and subroutines with the specified
501name.
b9d9fc0b 502
116a9f45 503=item B<< $metapackage->list_all_package_symbols($type_filter) >>
b9d9fc0b 504
116a9f45 505This will list all the glob names associated with the current
506package. These names do not have leading sigils.
c46b802b 507
116a9f45 508You can provide an optional type filter, which should be one of
509'SCALAR', 'ARRAY', 'HASH', or 'CODE'.
9d6dce77 510
116a9f45 511=item B<< $metapackage->get_all_package_symbols($type_filter) >>
b9d9fc0b 512
116a9f45 513This works much like C<list_all_package_symbols>, but it returns a
514hash reference. The keys are glob names and the values are references
515to the value for that name.
92330ee2 516
b1ff395f 517=back
518
519=head2 Method introspection and creation
520
521These methods allow you to introspect a class's methods, as well as
522add, remove, or change methods.
523
524Determining what is truly a method in a Perl 5 class requires some
525heuristics (aka guessing).
526
527Methods defined outside the package with a fully qualified name (C<sub
528Package::name { ... }>) will be included. Similarly, methods named
529with a fully qualified name using L<Sub::Name> are also included.
530
531However, we attempt to ignore imported functions.
532
533Ultimately, we are using heuristics to determine what truly is a
534method in a class, and these heuristics may get the wrong answer in
535some edge cases. However, for most "normal" cases the heuristics work
536correctly.
537
538=over 4
539
540=item B<< $metapackage->get_method($method_name) >>
541
542This will return a L<Class::MOP::Method> for the specified
543C<$method_name>. If the class does not have the specified method, it
544returns C<undef>
545
546=item B<< $metapackage->has_method($method_name) >>
547
548Returns a boolean indicating whether or not the class defines the
549named method. It does not include methods inherited from parent
550classes.
551
b1ff395f 552=item B<< $metapackage->get_method_list >>
553
554This will return a list of method I<names> for all methods defined in
555this class.
556
557=item B<< $metapackage->add_method($method_name, $method) >>
558
559This method takes a method name and a subroutine reference, and adds
560the method to the class.
561
562The subroutine reference can be a L<Class::MOP::Method>, and you are
563strongly encouraged to pass a meta method object instead of a code
564reference. If you do so, that object gets stored as part of the
565class's method map directly. If not, the meta information will have to
566be recreated later, and may be incorrect.
567
568If you provide a method object, this method will clone that object if
569the object's package name does not match the class name. This lets us
570track the original source of any methods added from other classes
571(notably Moose roles).
572
573=item B<< $metapackage->remove_method($method_name) >>
574
575Remove the named method from the class. This method returns the
576L<Class::MOP::Method> object for the method.
577
578=item B<< $metapackage->method_metaclass >>
579
580Returns the class name of the method metaclass, see
581L<Class::MOP::Method> for more information on the method metaclass.
582
583=item B<< $metapackage->wrapped_method_metaclass >>
584
585Returns the class name of the wrapped method metaclass, see
586L<Class::MOP::Method::Wrapped> for more information on the wrapped
587method metaclass.
588
116a9f45 589=item B<< Class::MOP::Package->meta >>
ae234dc6 590
116a9f45 591This will return a L<Class::MOP::Class> instance for this class.
ae234dc6 592
2243a22b 593=back
594
1a09d9cc 595=head1 AUTHORS
2243a22b 596
597Stevan Little E<lt>stevan@iinteractive.comE<gt>
598
599=head1 COPYRIGHT AND LICENSE
600
070bb6c9 601Copyright 2006-2009 by Infinity Interactive, Inc.
2243a22b 602
603L<http://www.iinteractive.com>
604
605This library is free software; you can redistribute it and/or modify
606it under the same terms as Perl itself.
607
92af7fdf 608=cut