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.09';
  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) = $self->_deconstruct_variable_name($variable);
  91
  92     my $pkg = $self->{'$!package'};
  93
  94     no strict 'refs';
  95     no warnings 'redefine', 'misc';
  96     *{$pkg . '::' . $name} = ref $initial_value ? $initial_value : \$initial_value;
  97 }
  98
  99 sub remove_package_glob {
 100     my ($self, $name) = @_;
 101     no strict 'refs';
 102     delete ${$self->name . '::'}{$name};
 103 }
 104
 105 # ... these functions deal with stuff on the namespace level
 106
 107 sub has_package_symbol {
 108     my ($self, $variable) = @_;
 109
 110     my ($name, $sigil, $type) = $self->_deconstruct_variable_name($variable);
 111
 112     my $namespace = $self->namespace;
 113
 114     return 0 unless exists $namespace->{$name};
 115
 116     # FIXME:
 117     # For some really stupid reason
 118     # a typeglob will have a default
 119     # value of \undef in the SCALAR
 120     # slot, so we need to work around
 121     # this. Which of course means that
 122     # if you put \undef in your scalar
 123     # then this is broken.
 124
 125     if (ref($namespace->{$name}) eq 'SCALAR') {
 126         return ($type eq 'CODE' ? 1 : 0);
 127     }
 128     elsif ($type eq 'SCALAR') {
 129         my $val = *{$namespace->{$name}}{$type};
 130         return defined(${$val}) ? 1 : 0;
 131     }
 132     else {
 133         defined(*{$namespace->{$name}}{$type}) ? 1 : 0;
 134     }
 135 }
 136
 137 sub get_package_symbol {
 138     my ($self, $variable) = @_;
 139
 140     my ($name, $sigil, $type) = $self->_deconstruct_variable_name($variable);
 141
 142     my $namespace = $self->namespace;
 143
 144     $self->add_package_symbol($variable)
 145         unless exists $namespace->{$name};
 146
 147     if (ref($namespace->{$name}) eq 'SCALAR') {
 148         if ($type eq 'CODE') {
 149             no strict 'refs';
 150             return \&{$self->name.'::'.$name};
 151         }
 152         else {
 153             return undef;
 154         }
 155     }
 156     else {
 157         return *{$namespace->{$name}}{$type};
 158     }
 159 }
 160
 161 sub remove_package_symbol {
 162     my ($self, $variable) = @_;
 163
 164     my ($name, $sigil, $type) = $self->_deconstruct_variable_name($variable);
 165
 166     # FIXME:
 167     # no doubt this is grossly inefficient and
 168     # could be done much easier and faster in XS
 169
 170     my ($scalar, $array, $hash, $code);
 171     if ($type eq 'SCALAR') {
 172         $array  = $self->get_package_symbol('@' . $name) if $self->has_package_symbol('@' . $name);
 173         $hash   = $self->get_package_symbol('%' . $name) if $self->has_package_symbol('%' . $name);
 174         $code   = $self->get_package_symbol('&' . $name) if $self->has_package_symbol('&' . $name);
 175     }
 176     elsif ($type eq 'ARRAY') {
 177         $scalar = $self->get_package_symbol('$' . $name) if $self->has_package_symbol('$' . $name);
 178         $hash   = $self->get_package_symbol('%' . $name) if $self->has_package_symbol('%' . $name);
 179         $code   = $self->get_package_symbol('&' . $name) if $self->has_package_symbol('&' . $name);
 180     }
 181     elsif ($type eq 'HASH') {
 182         $scalar = $self->get_package_symbol('$' . $name) if $self->has_package_symbol('$' . $name);
 183         $array  = $self->get_package_symbol('@' . $name) if $self->has_package_symbol('@' . $name);
 184         $code   = $self->get_package_symbol('&' . $name) if $self->has_package_symbol('&' . $name);
 185     }
 186     elsif ($type eq 'CODE') {
 187         $scalar = $self->get_package_symbol('$' . $name) if $self->has_package_symbol('$' . $name);
 188         $array  = $self->get_package_symbol('@' . $name) if $self->has_package_symbol('@' . $name);
 189         $hash   = $self->get_package_symbol('%' . $name) if $self->has_package_symbol('%' . $name);
 190     }
 191     else {
 192         confess "This should never ever ever happen";
 193     }
 194
 195     $self->remove_package_glob($name);
 196
 197     $self->add_package_symbol(('$' . $name) => $scalar) if defined $scalar;
 198     $self->add_package_symbol(('@' . $name) => $array)  if defined $array;
 199     $self->add_package_symbol(('%' . $name) => $hash)   if defined $hash;
 200     $self->add_package_symbol(('&' . $name) => $code)   if defined $code;
 201 }
 202
 203 sub list_all_package_symbols {
 204     my ($self, $type_filter) = @_;
 205
 206     my $namespace = $self->namespace;
 207     return keys %{$namespace} unless defined $type_filter;
 208
 209     # NOTE:
 210     # or we can filter based on
 211     # type (SCALAR|ARRAY|HASH|CODE)
 212     return grep {
 213         (ref($namespace->{$_})
 214             ? (ref($namespace->{$_}) eq 'SCALAR' && $type_filter eq 'CODE')
 215             : (ref(\$namespace->{$_}) eq 'GLOB'
 216                && defined(*{$namespace->{$_}}{$type_filter})));
 217     } keys %{$namespace};
 218 }
 219
 220 sub get_all_package_symbols {
 221     my ($self, $type_filter) = @_;
 222     my $namespace = $self->namespace;
 223     return %{$namespace} unless defined $type_filter;
 224
 225     # NOTE:
 226     # or we can filter based on
 227     # type (SCALAR|ARRAY|HASH|CODE)
 228     no strict 'refs';
 229     return map {
 230         $_ => (ref($namespace->{$_}) eq 'SCALAR'
 231                     ? ($type_filter eq 'CODE' ? \&{$self->name . '::' . $_} : undef)
 232                     : *{$namespace->{$_}}{$type_filter})
 233     } grep {
 234         (ref($namespace->{$_})
 235             ? (ref($namespace->{$_}) eq 'SCALAR' && $type_filter eq 'CODE')
 236             : (ref(\$namespace->{$_}) eq 'GLOB'
 237                && defined(*{$namespace->{$_}}{$type_filter})));
 238     } keys %{$namespace};
 239 }
 240
 241 1;
 242
 243 __END__
 244
 245 =pod
 246
 247 =head1 NAME
 248
 249 Class::MOP::Package - Package Meta Object
 250
 251 =head1 DESCRIPTION
 252
 253 This is an abstraction of a Perl 5 package, it is a superclass of
 254 L<Class::MOP::Class> and provides all of the symbol table
 255 introspection methods.
 256
 257 =head1 METHODS
 258
 259 =over 4
 260
 261 =item B<meta>
 262
 263 Returns a metaclass for this package.
 264
 265 =item B<initialize ($package_name)>
 266
 267 This will initialize a Class::MOP::Package instance which represents
 268 the package of C<$package_name>.
 269
 270 =item B<name>
 271
 272 This is a read-only attribute which returns the package name for the
 273 given instance.
 274
 275 =item B<namespace>
 276
 277 This returns a HASH reference to the symbol table. The keys of the
 278 HASH are the symbol names, and the values are typeglob references.
 279
 280 =item B<add_package_symbol ($variable_name, ?$initial_value)>
 281
 282 Given a C<$variable_name>, which must contain a leading sigil, this
 283 method will create that variable within the package which houses the
 284 class. It also takes an optional C<$initial_value>, which must be a
 285 reference of the same type as the sigil of the C<$variable_name>
 286 implies.
 287
 288 =item B<get_package_symbol ($variable_name)>
 289
 290 This will return a reference to the package variable in
 291 C<$variable_name>.
 292
 293 =item B<has_package_symbol ($variable_name)>
 294
 295 Returns true (C<1>) if there is a package variable defined for
 296 C<$variable_name>, and false (C<0>) otherwise.
 297
 298 =item B<remove_package_symbol ($variable_name)>
 299
 300 This will attempt to remove the package variable at C<$variable_name>.
 301
 302 =item B<remove_package_glob ($glob_name)>
 303
 304 This will attempt to remove the entire typeglob associated with
 305 C<$glob_name> from the package.
 306
 307 =item B<list_all_package_symbols (?$type_filter)>
 308
 309 This will list all the glob names associated with the current package.
 310 By inspecting the globs returned you can discern all the variables in
 311 the package.
 312
 313 By passing a C<$type_filter>, you can limit the list to only those
 314 which match the filter (either SCALAR, ARRAY, HASH or CODE).
 315
 316 =item B<get_all_package_symbols (?$type_filter)>
 317
 318 Works exactly like C<list_all_package_symbols> but returns a HASH of
 319 name => thing mapping instead of just an ARRAY of names.
 320
 321 =back
 322
 323 =head1 AUTHORS
 324
 325 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 326
 327 =head1 COPYRIGHT AND LICENSE
 328
 329 Copyright 2006-2008 by Infinity Interactive, Inc.
 330
 331 L<http://www.iinteractive.com>
 332
 333 This library is free software; you can redistribute it and/or modify
 334 it under the same terms as Perl itself.
 335
 336 =cut