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