blah
[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
2e5c1a3f 10our $VERSION = '0.65';
f0480c45 11our $AUTHORITY = 'cpan:STEVAN';
2243a22b 12
6e57504d 13use base 'Class::MOP::Object';
14
6d5355c3 15# creation ...
16
17sub initialize {
9d6dce77 18 my $class = shift;
19 my $package_name = shift;
20 # we hand-construct the class
21 # until we can bootstrap it
a5e51f0b 22 no strict 'refs';
23 return bless {
8683db0e 24 'package' => $package_name,
56dcfc1a 25 # NOTE:
26 # because of issues with the Perl API
27 # to the typeglob in some versions, we
28 # need to just always grab a new
29 # reference to the hash in the accessor.
30 # Ideally we could just store a ref and
31 # it would Just Work, but oh well :\
8683db0e 32 'namespace' => \undef,
a5e51f0b 33 } => $class;
6d5355c3 34}
35
36# Attributes
37
38# NOTE:
39# all these attribute readers will be bootstrapped
40# away in the Class::MOP bootstrap section
41
8683db0e 42sub name { $_[0]->{'package'} }
56dcfc1a 43sub namespace {
44 # NOTE:
45 # because of issues with the Perl API
46 # to the typeglob in some versions, we
47 # need to just always grab a new
48 # reference to the hash here. Ideally
49 # we could just store a ref and it would
50 # Just Work, but oh well :\
51 no strict 'refs';
8683db0e 52 \%{$_[0]->{'package'} . '::'}
56dcfc1a 53}
6d5355c3 54
a5e51f0b 55# utility methods
6d5355c3 56
c0cbf4d9 57{
58 my %SIGIL_MAP = (
59 '$' => 'SCALAR',
60 '@' => 'ARRAY',
61 '%' => 'HASH',
62 '&' => 'CODE',
63 );
6d5355c3 64
a5e51f0b 65 sub _deconstruct_variable_name {
66 my ($self, $variable) = @_;
67
c0cbf4d9 68 (defined $variable)
69 || confess "You must pass a variable name";
a5e51f0b 70
f430cfa4 71 my $sigil = substr($variable, 0, 1, '');
a5e51f0b 72
c0cbf4d9 73 (defined $sigil)
74 || confess "The variable name must include a sigil";
a5e51f0b 75
c0cbf4d9 76 (exists $SIGIL_MAP{$sigil})
a5e51f0b 77 || confess "I do not recognize that sigil '$sigil'";
78
f430cfa4 79 return ($variable, $sigil, $SIGIL_MAP{$sigil});
c0cbf4d9 80 }
a5e51f0b 81}
6d5355c3 82
a5e51f0b 83# Class attributes
6d5355c3 84
c46b802b 85# ... these functions have to touch the symbol table itself,.. yuk
86
a5e51f0b 87sub add_package_symbol {
88 my ($self, $variable, $initial_value) = @_;
6d5355c3 89
8b49a472 90 my ($name, $sigil, $type) = ref $variable eq 'HASH'
91 ? @{$variable}{qw[name sigil type]}
92 : $self->_deconstruct_variable_name($variable);
6d5355c3 93
8683db0e 94 my $pkg = $self->{'package'};
9a8bbfc9 95
a5e51f0b 96 no strict 'refs';
56dcfc1a 97 no warnings 'redefine', 'misc';
9a8bbfc9 98 *{$pkg . '::' . $name} = ref $initial_value ? $initial_value : \$initial_value;
c46b802b 99}
100
101sub remove_package_glob {
102 my ($self, $name) = @_;
103 no strict 'refs';
104 delete ${$self->name . '::'}{$name};
a5e51f0b 105}
6d5355c3 106
c46b802b 107# ... these functions deal with stuff on the namespace level
108
a5e51f0b 109sub has_package_symbol {
110 my ($self, $variable) = @_;
111
8b49a472 112 my ($name, $sigil, $type) = ref $variable eq 'HASH'
113 ? @{$variable}{qw[name sigil type]}
114 : $self->_deconstruct_variable_name($variable);
56dcfc1a 115
ae234dc6 116 my $namespace = $self->namespace;
117
118 return 0 unless exists $namespace->{$name};
d852f4d2 119
120 # FIXME:
121 # For some really stupid reason
122 # a typeglob will have a default
123 # value of \undef in the SCALAR
124 # slot, so we need to work around
125 # this. Which of course means that
126 # if you put \undef in your scalar
127 # then this is broken.
92af7fdf 128
ae234dc6 129 if (ref($namespace->{$name}) eq 'SCALAR') {
92af7fdf 130 return ($type eq 'CODE' ? 1 : 0);
131 }
132 elsif ($type eq 'SCALAR') {
ae234dc6 133 my $val = *{$namespace->{$name}}{$type};
92af7fdf 134 return defined(${$val}) ? 1 : 0;
d852f4d2 135 }
136 else {
ae234dc6 137 defined(*{$namespace->{$name}}{$type}) ? 1 : 0;
d852f4d2 138 }
a5e51f0b 139}
140
141sub get_package_symbol {
142 my ($self, $variable) = @_;
143
8b49a472 144 my ($name, $sigil, $type) = ref $variable eq 'HASH'
145 ? @{$variable}{qw[name sigil type]}
146 : $self->_deconstruct_variable_name($variable);
a5e51f0b 147
ae234dc6 148 my $namespace = $self->namespace;
149
c20522bd 150 $self->add_package_symbol($variable)
ae234dc6 151 unless exists $namespace->{$name};
92af7fdf 152
ae234dc6 153 if (ref($namespace->{$name}) eq 'SCALAR') {
92af7fdf 154 if ($type eq 'CODE') {
155 no strict 'refs';
156 return \&{$self->name.'::'.$name};
157 }
158 else {
159 return undef;
160 }
161 }
162 else {
ae234dc6 163 return *{$namespace->{$name}}{$type};
92af7fdf 164 }
a5e51f0b 165}
166
167sub remove_package_symbol {
168 my ($self, $variable) = @_;
169
8b49a472 170 my ($name, $sigil, $type) = ref $variable eq 'HASH'
171 ? @{$variable}{qw[name sigil type]}
172 : $self->_deconstruct_variable_name($variable);
a5e51f0b 173
c46b802b 174 # FIXME:
175 # no doubt this is grossly inefficient and
176 # could be done much easier and faster in XS
177
8b49a472 178 my ($scalar_desc, $array_desc, $hash_desc, $code_desc) = (
179 { sigil => '$', type => 'SCALAR', name => $name },
180 { sigil => '@', type => 'ARRAY', name => $name },
181 { sigil => '%', type => 'HASH', name => $name },
182 { sigil => '&', type => 'CODE', name => $name },
183 );
184
c46b802b 185 my ($scalar, $array, $hash, $code);
a5e51f0b 186 if ($type eq 'SCALAR') {
8b49a472 187 $array = $self->get_package_symbol($array_desc) if $self->has_package_symbol($array_desc);
188 $hash = $self->get_package_symbol($hash_desc) if $self->has_package_symbol($hash_desc);
189 $code = $self->get_package_symbol($code_desc) if $self->has_package_symbol($code_desc);
a5e51f0b 190 }
191 elsif ($type eq 'ARRAY') {
8b49a472 192 $scalar = $self->get_package_symbol($scalar_desc) if $self->has_package_symbol($scalar_desc);
193 $hash = $self->get_package_symbol($hash_desc) if $self->has_package_symbol($hash_desc);
194 $code = $self->get_package_symbol($code_desc) if $self->has_package_symbol($code_desc);
a5e51f0b 195 }
196 elsif ($type eq 'HASH') {
8b49a472 197 $scalar = $self->get_package_symbol($scalar_desc) if $self->has_package_symbol($scalar_desc);
198 $array = $self->get_package_symbol($array_desc) if $self->has_package_symbol($array_desc);
199 $code = $self->get_package_symbol($code_desc) if $self->has_package_symbol($code_desc);
a5e51f0b 200 }
201 elsif ($type eq 'CODE') {
8b49a472 202 $scalar = $self->get_package_symbol($scalar_desc) if $self->has_package_symbol($scalar_desc);
203 $array = $self->get_package_symbol($array_desc) if $self->has_package_symbol($array_desc);
204 $hash = $self->get_package_symbol($hash_desc) if $self->has_package_symbol($hash_desc);
a5e51f0b 205 }
206 else {
207 confess "This should never ever ever happen";
7f436b8c 208 }
c46b802b 209
210 $self->remove_package_glob($name);
211
8b49a472 212 $self->add_package_symbol($scalar_desc => $scalar) if defined $scalar;
213 $self->add_package_symbol($array_desc => $array) if defined $array;
214 $self->add_package_symbol($hash_desc => $hash) if defined $hash;
215 $self->add_package_symbol($code_desc => $code) if defined $code;
9d6dce77 216}
c0cbf4d9 217
9d6dce77 218sub list_all_package_symbols {
92330ee2 219 my ($self, $type_filter) = @_;
a38e4d1a 220
221 my $namespace = $self->namespace;
222 return keys %{$namespace} unless defined $type_filter;
223
91e0eb4a 224 # NOTE:
92330ee2 225 # or we can filter based on
226 # type (SCALAR|ARRAY|HASH|CODE)
3609af79 227 if ( $type_filter eq 'CODE' ) {
228 return grep {
92af7fdf 229 (ref($namespace->{$_})
3609af79 230 ? (ref($namespace->{$_}) eq 'SCALAR')
231 : (ref(\$namespace->{$_}) eq 'GLOB'
232 && defined(*{$namespace->{$_}}{CODE})));
233 } keys %{$namespace};
234 } else {
235 return grep { *{$namespace->{$_}}{$type_filter} } keys %{$namespace};
236 }
6d5355c3 237}
238
ae234dc6 239sub get_all_package_symbols {
240 my ($self, $type_filter) = @_;
a38e4d1a 241 my $namespace = $self->namespace;
b16217dd 242 return %$namespace unless defined $type_filter;
243
3609af79 244 # for some reason this nasty impl is orders of magnitude aster than a clean version
b16217dd 245 if ( $type_filter eq 'CODE' ) {
2f1f7e5a 246 my $pkg;
3609af79 247 no strict 'refs';
248 return map {
249 (ref($namespace->{$_})
2f1f7e5a 250 ? ( $_ => \&{$pkg ||= $self->name . "::$_"} )
3609af79 251 : ( *{$namespace->{$_}}{CODE}
252 ? ( $_ => *{$namespace->{$_}}{$type_filter} )
253 : ()))
254 } keys %$namespace;
b16217dd 255 } else {
3609af79 256 return map {
257 $_ => *{$namespace->{$_}}{$type_filter}
258 } grep {
259 !ref($namespace->{$_}) && *{$namespace->{$_}}{$type_filter}
260 } keys %$namespace;
b16217dd 261 }
ae234dc6 262}
263
2243a22b 2641;
265
266__END__
267
268=pod
269
270=head1 NAME
271
272Class::MOP::Package - Package Meta Object
273
2243a22b 274=head1 DESCRIPTION
275
127d39a7 276This is an abstraction of a Perl 5 package, it is a superclass of
277L<Class::MOP::Class> and provides all of the symbol table
278introspection methods.
279
2243a22b 280=head1 METHODS
281
282=over 4
283
284=item B<meta>
285
127d39a7 286Returns a metaclass for this package.
287
b9d9fc0b 288=item B<initialize ($package_name)>
6d5355c3 289
127d39a7 290This will initialize a Class::MOP::Package instance which represents
291the package of C<$package_name>.
292
6d5355c3 293=item B<name>
294
b9d9fc0b 295This is a read-only attribute which returns the package name for the
296given instance.
297
a5e51f0b 298=item B<namespace>
299
b9d9fc0b 300This returns a HASH reference to the symbol table. The keys of the
301HASH are the symbol names, and the values are typeglob references.
302
303=item B<add_package_symbol ($variable_name, ?$initial_value)>
304
305Given a C<$variable_name>, which must contain a leading sigil, this
306method will create that variable within the package which houses the
307class. It also takes an optional C<$initial_value>, which must be a
308reference of the same type as the sigil of the C<$variable_name>
309implies.
310
311=item B<get_package_symbol ($variable_name)>
6d5355c3 312
b9d9fc0b 313This will return a reference to the package variable in
314C<$variable_name>.
6d5355c3 315
b9d9fc0b 316=item B<has_package_symbol ($variable_name)>
6d5355c3 317
b9d9fc0b 318Returns true (C<1>) if there is a package variable defined for
319C<$variable_name>, and false (C<0>) otherwise.
6d5355c3 320
b9d9fc0b 321=item B<remove_package_symbol ($variable_name)>
322
323This will attempt to remove the package variable at C<$variable_name>.
324
325=item B<remove_package_glob ($glob_name)>
326
327This will attempt to remove the entire typeglob associated with
328C<$glob_name> from the package.
c46b802b 329
92330ee2 330=item B<list_all_package_symbols (?$type_filter)>
9d6dce77 331
b9d9fc0b 332This will list all the glob names associated with the current package.
333By inspecting the globs returned you can discern all the variables in
334the package.
335
92330ee2 336By passing a C<$type_filter>, you can limit the list to only those
337which match the filter (either SCALAR, ARRAY, HASH or CODE).
338
ae234dc6 339=item B<get_all_package_symbols (?$type_filter)>
340
341Works exactly like C<list_all_package_symbols> but returns a HASH of
342name => thing mapping instead of just an ARRAY of names.
343
2243a22b 344=back
345
1a09d9cc 346=head1 AUTHORS
2243a22b 347
348Stevan Little E<lt>stevan@iinteractive.comE<gt>
349
350=head1 COPYRIGHT AND LICENSE
351
69e3ab0a 352Copyright 2006-2008 by Infinity Interactive, Inc.
2243a22b 353
354L<http://www.iinteractive.com>
355
356This library is free software; you can redistribute it and/or modify
357it under the same terms as Perl itself.
358
92af7fdf 359=cut