lib/Class/MOP/Package.pm

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