Remove unnecessary calls of has_method()
[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';
2243a22b 9
074ec38f 10our $VERSION = '0.89';
d519662a 11$VERSION = eval $VERSION;
f0480c45 12our $AUTHORITY = 'cpan:STEVAN';
2243a22b 13
6e57504d 14use base 'Class::MOP::Object';
15
6d5355c3 16# creation ...
17
18sub initialize {
3be6bc1c 19 my ( $class, @args ) = @_;
20
21 unshift @args, "package" if @args % 2;
22
23 my %options = @args;
24 my $package_name = $options{package};
25
26
9d6dce77 27 # we hand-construct the class
28 # until we can bootstrap it
a19fcb5b 29 if ( my $meta = Class::MOP::get_metaclass_by_name($package_name) ) {
973de492 30 return $meta;
a19fcb5b 31 } else {
973de492 32 my $meta = ( ref $class || $class )->_new({
33 'package' => $package_name,
11ac821d 34 %options,
973de492 35 });
a19fcb5b 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
a19fcb5b 51 (defined $package_name && $package_name && !blessed($package_name))
52 || confess "You must pass a package name and it cannot be blessed";
3be6bc1c 53
a19fcb5b 54 Class::MOP::remove_metaclass_by_name($package_name);
3be6bc1c 55
3eda22f8 56 $class->initialize($package_name, %options); # call with first arg form for compat
682655a3 57}
58
59sub _new {
0bfc85b8 60 my $class = shift;
812d58f9 61
ec9e38e5 62 return Class::MOP::Class->initialize($class)->new_object(@_)
812d58f9 63 if $class ne __PACKAGE__;
682655a3 64
ec9e38e5 65 my $params = @_ == 1 ? $_[0] : {@_};
66
67 return bless {
68 package => $params->{package},
69
70 # NOTE:
71 # because of issues with the Perl API
72 # to the typeglob in some versions, we
73 # need to just always grab a new
74 # reference to the hash in the accessor.
75 # Ideally we could just store a ref and
76 # it would Just Work, but oh well :\
77
78 namespace => \undef,
0bfc85b8 79
ec9e38e5 80 } => $class;
6d5355c3 81}
82
83# Attributes
84
85# NOTE:
86# all these attribute readers will be bootstrapped
87# away in the Class::MOP bootstrap section
88
56dcfc1a 89sub namespace {
90 # NOTE:
91 # because of issues with the Perl API
92 # to the typeglob in some versions, we
93 # need to just always grab a new
94 # reference to the hash here. Ideally
95 # we could just store a ref and it would
96 # Just Work, but oh well :\
97 no strict 'refs';
8683db0e 98 \%{$_[0]->{'package'} . '::'}
56dcfc1a 99}
6d5355c3 100
a5e51f0b 101# utility methods
6d5355c3 102
c0cbf4d9 103{
104 my %SIGIL_MAP = (
105 '$' => 'SCALAR',
106 '@' => 'ARRAY',
107 '%' => 'HASH',
108 '&' => 'CODE',
109 );
6d5355c3 110
a5e51f0b 111 sub _deconstruct_variable_name {
112 my ($self, $variable) = @_;
113
c0cbf4d9 114 (defined $variable)
115 || confess "You must pass a variable name";
a5e51f0b 116
f430cfa4 117 my $sigil = substr($variable, 0, 1, '');
a5e51f0b 118
c0cbf4d9 119 (defined $sigil)
120 || confess "The variable name must include a sigil";
a5e51f0b 121
c0cbf4d9 122 (exists $SIGIL_MAP{$sigil})
a5e51f0b 123 || confess "I do not recognize that sigil '$sigil'";
124
f430cfa4 125 return ($variable, $sigil, $SIGIL_MAP{$sigil});
c0cbf4d9 126 }
a5e51f0b 127}
6d5355c3 128
a5e51f0b 129# Class attributes
6d5355c3 130
c46b802b 131# ... these functions have to touch the symbol table itself,.. yuk
132
a5e51f0b 133sub add_package_symbol {
134 my ($self, $variable, $initial_value) = @_;
6d5355c3 135
8b49a472 136 my ($name, $sigil, $type) = ref $variable eq 'HASH'
137 ? @{$variable}{qw[name sigil type]}
26159d55 138 : $self->_deconstruct_variable_name($variable);
6d5355c3 139
8683db0e 140 my $pkg = $self->{'package'};
9a8bbfc9 141
a5e51f0b 142 no strict 'refs';
26159d55 143 no warnings 'redefine', 'misc', 'prototype';
144 *{$pkg . '::' . $name} = ref $initial_value ? $initial_value : \$initial_value;
c46b802b 145}
146
147sub remove_package_glob {
148 my ($self, $name) = @_;
149 no strict 'refs';
150 delete ${$self->name . '::'}{$name};
a5e51f0b 151}
6d5355c3 152
c46b802b 153# ... these functions deal with stuff on the namespace level
154
a5e51f0b 155sub has_package_symbol {
812d58f9 156 my ( $self, $variable ) = @_;
a5e51f0b 157
812d58f9 158 my ( $name, $sigil, $type )
159 = ref $variable eq 'HASH'
8b49a472 160 ? @{$variable}{qw[name sigil type]}
161 : $self->_deconstruct_variable_name($variable);
812d58f9 162
ae234dc6 163 my $namespace = $self->namespace;
812d58f9 164
165 return 0 unless exists $namespace->{$name};
166
55039f82 167 my $entry_ref = \$namespace->{$name};
812d58f9 168 if ( reftype($entry_ref) eq 'GLOB' ) {
169 if ( $type eq 'SCALAR' ) {
170 return defined( ${ *{$entry_ref}{SCALAR} } );
55039f82 171 }
172 else {
812d58f9 173 return defined( *{$entry_ref}{$type} );
55039f82 174 }
812d58f9 175 }
176 else {
177
178 # a symbol table entry can be -1 (stub), string (stub with prototype),
179 # or reference (constant)
180 return $type eq 'CODE';
d852f4d2 181 }
a5e51f0b 182}
183
184sub get_package_symbol {
185 my ($self, $variable) = @_;
186
8b49a472 187 my ($name, $sigil, $type) = ref $variable eq 'HASH'
188 ? @{$variable}{qw[name sigil type]}
189 : $self->_deconstruct_variable_name($variable);
a5e51f0b 190
ae234dc6 191 my $namespace = $self->namespace;
192
55039f82 193 # FIXME
c20522bd 194 $self->add_package_symbol($variable)
ae234dc6 195 unless exists $namespace->{$name};
92af7fdf 196
55039f82 197 my $entry_ref = \$namespace->{$name};
198
812d58f9 199 if ( ref($entry_ref) eq 'GLOB' ) {
55039f82 200 return *{$entry_ref}{$type};
201 }
812d58f9 202 else {
203 if ( $type eq 'CODE' ) {
92af7fdf 204 no strict 'refs';
812d58f9 205 return \&{ $self->name . '::' . $name };
92af7fdf 206 }
812d58f9 207 else {
92af7fdf 208 return undef;
209 }
210 }
a5e51f0b 211}
212
213sub remove_package_symbol {
214 my ($self, $variable) = @_;
215
8b49a472 216 my ($name, $sigil, $type) = ref $variable eq 'HASH'
217 ? @{$variable}{qw[name sigil type]}
218 : $self->_deconstruct_variable_name($variable);
a5e51f0b 219
c46b802b 220 # FIXME:
221 # no doubt this is grossly inefficient and
222 # could be done much easier and faster in XS
223
8b49a472 224 my ($scalar_desc, $array_desc, $hash_desc, $code_desc) = (
225 { sigil => '$', type => 'SCALAR', name => $name },
226 { sigil => '@', type => 'ARRAY', name => $name },
227 { sigil => '%', type => 'HASH', name => $name },
228 { sigil => '&', type => 'CODE', name => $name },
229 );
230
c46b802b 231 my ($scalar, $array, $hash, $code);
a5e51f0b 232 if ($type eq 'SCALAR') {
8b49a472 233 $array = $self->get_package_symbol($array_desc) if $self->has_package_symbol($array_desc);
234 $hash = $self->get_package_symbol($hash_desc) if $self->has_package_symbol($hash_desc);
235 $code = $self->get_package_symbol($code_desc) if $self->has_package_symbol($code_desc);
a5e51f0b 236 }
237 elsif ($type eq 'ARRAY') {
8b49a472 238 $scalar = $self->get_package_symbol($scalar_desc) if $self->has_package_symbol($scalar_desc);
239 $hash = $self->get_package_symbol($hash_desc) if $self->has_package_symbol($hash_desc);
240 $code = $self->get_package_symbol($code_desc) if $self->has_package_symbol($code_desc);
a5e51f0b 241 }
242 elsif ($type eq 'HASH') {
8b49a472 243 $scalar = $self->get_package_symbol($scalar_desc) if $self->has_package_symbol($scalar_desc);
244 $array = $self->get_package_symbol($array_desc) if $self->has_package_symbol($array_desc);
245 $code = $self->get_package_symbol($code_desc) if $self->has_package_symbol($code_desc);
a5e51f0b 246 }
247 elsif ($type eq 'CODE') {
8b49a472 248 $scalar = $self->get_package_symbol($scalar_desc) if $self->has_package_symbol($scalar_desc);
249 $array = $self->get_package_symbol($array_desc) if $self->has_package_symbol($array_desc);
250 $hash = $self->get_package_symbol($hash_desc) if $self->has_package_symbol($hash_desc);
a5e51f0b 251 }
252 else {
253 confess "This should never ever ever happen";
7f436b8c 254 }
c46b802b 255
256 $self->remove_package_glob($name);
257
8b49a472 258 $self->add_package_symbol($scalar_desc => $scalar) if defined $scalar;
259 $self->add_package_symbol($array_desc => $array) if defined $array;
260 $self->add_package_symbol($hash_desc => $hash) if defined $hash;
261 $self->add_package_symbol($code_desc => $code) if defined $code;
9d6dce77 262}
c0cbf4d9 263
9d6dce77 264sub list_all_package_symbols {
92330ee2 265 my ($self, $type_filter) = @_;
a38e4d1a 266
267 my $namespace = $self->namespace;
268 return keys %{$namespace} unless defined $type_filter;
269
91e0eb4a 270 # NOTE:
92330ee2 271 # or we can filter based on
272 # type (SCALAR|ARRAY|HASH|CODE)
3609af79 273 if ( $type_filter eq 'CODE' ) {
274 return grep {
92af7fdf 275 (ref($namespace->{$_})
3609af79 276 ? (ref($namespace->{$_}) eq 'SCALAR')
277 : (ref(\$namespace->{$_}) eq 'GLOB'
278 && defined(*{$namespace->{$_}}{CODE})));
279 } keys %{$namespace};
280 } else {
281 return grep { *{$namespace->{$_}}{$type_filter} } keys %{$namespace};
282 }
6d5355c3 283}
284
2243a22b 2851;
286
287__END__
288
289=pod
290
291=head1 NAME
292
293Class::MOP::Package - Package Meta Object
294
2243a22b 295=head1 DESCRIPTION
296
116a9f45 297The Package Protocol provides an abstraction of a Perl 5 package. A
298package is basically namespace, and this module provides methods for
299looking at and changing that namespace's symbol table.
121991f6 300
2243a22b 301=head1 METHODS
302
303=over 4
304
116a9f45 305=item B<< Class::MOP::Package->initialize($package_name) >>
306
307This method creates a new C<Class::MOP::Package> instance which
308represents specified package. If an existing metaclass object exists
309for the package, that will be returned instead.
310
311=item B<< Class::MOP::Package->reinitialize($package_name) >>
2243a22b 312
116a9f45 313This method forcibly removes any existing metaclass for the package
314before calling C<initialize>
127d39a7 315
116a9f45 316Do not call this unless you know what you are doing.
6d5355c3 317
116a9f45 318=item B<< $metapackage->name >>
127d39a7 319
116a9f45 320This is returns the package's name, as passed to the constructor.
a19fcb5b 321
116a9f45 322=item B<< $metapackage->namespace >>
a19fcb5b 323
116a9f45 324This returns a hash reference to the package's symbol table. The keys
325are symbol names and the values are typeglob references.
6d5355c3 326
116a9f45 327=item B<< $metapackage->add_package_symbol($variable_name, $initial_value) >>
b9d9fc0b 328
116a9f45 329This method accepts a variable name and an optional initial value. The
330C<$variable_name> must contain a leading sigil.
a5e51f0b 331
116a9f45 332This method creates the variable in the package's symbol table, and
333sets it to the initial value if one was provided.
b9d9fc0b 334
116a9f45 335=item B<< $metapackage->get_package_symbol($variable_name) >>
b9d9fc0b 336
116a9f45 337Given a variable name, this method returns the variable as a reference
338or undef if it does not exist. The C<$variable_name> must contain a
339leading sigil.
b9d9fc0b 340
116a9f45 341=item B<< $metapackage->has_package_symbol($variable_name) >>
6d5355c3 342
116a9f45 343Returns true if there is a package variable defined for
344C<$variable_name>. The C<$variable_name> must contain a leading sigil.
6d5355c3 345
116a9f45 346=item B<< $metapackage->remove_package_symbol($variable_name) >>
6d5355c3 347
116a9f45 348This will remove the package variable specified C<$variable_name>. The
349C<$variable_name> must contain a leading sigil.
6d5355c3 350
116a9f45 351=item B<< $metapackage->remove_package_glob($glob_name) >>
b9d9fc0b 352
116a9f45 353Given the name of a glob, this will remove that glob from the
354package's symbol table. Glob names do not include a sigil. Removing
355the glob removes all variables and subroutines with the specified
356name.
b9d9fc0b 357
116a9f45 358=item B<< $metapackage->list_all_package_symbols($type_filter) >>
b9d9fc0b 359
116a9f45 360This will list all the glob names associated with the current
361package. These names do not have leading sigils.
c46b802b 362
116a9f45 363You can provide an optional type filter, which should be one of
364'SCALAR', 'ARRAY', 'HASH', or 'CODE'.
9d6dce77 365
116a9f45 366=item B<< $metapackage->get_all_package_symbols($type_filter) >>
b9d9fc0b 367
116a9f45 368This works much like C<list_all_package_symbols>, but it returns a
369hash reference. The keys are glob names and the values are references
370to the value for that name.
92330ee2 371
116a9f45 372=item B<< Class::MOP::Package->meta >>
ae234dc6 373
116a9f45 374This will return a L<Class::MOP::Class> instance for this class.
ae234dc6 375
2243a22b 376=back
377
1a09d9cc 378=head1 AUTHORS
2243a22b 379
380Stevan Little E<lt>stevan@iinteractive.comE<gt>
381
382=head1 COPYRIGHT AND LICENSE
383
070bb6c9 384Copyright 2006-2009 by Infinity Interactive, Inc.
2243a22b 385
386L<http://www.iinteractive.com>
387
388This library is free software; you can redistribute it and/or modify
389it under the same terms as Perl itself.
390
92af7fdf 391=cut