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