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