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