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