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.65';
  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     if ( $type_filter eq 'CODE' ) {
 228         return grep {
 229         (ref($namespace->{$_})
 230                 ? (ref($namespace->{$_}) eq 'SCALAR')
 231                 : (ref(\$namespace->{$_}) eq 'GLOB'
 232                    && defined(*{$namespace->{$_}}{CODE})));
 233         } keys %{$namespace};
 234     } else {
 235         return grep { *{$namespace->{$_}}{$type_filter} } keys %{$namespace};
 236     }
 237 }
 238
 239 sub get_all_package_symbols {
 240     my ($self, $type_filter) = @_;
 241     my $namespace = $self->namespace;
 242     return %$namespace unless defined $type_filter;
 243
 244     # for some reason this nasty impl is orders of magnitude aster than a clean version
 245     if ( $type_filter eq 'CODE' ) {
 246         my $pkg = $self->name;
 247         no strict 'refs';
 248         return map {
 249             (ref($namespace->{$_})
 250                  ? ( $_ => \&{"${pkg}::$_"} )
 251                  : ( *{$namespace->{$_}}{CODE}
 252                     ? ( $_ => *{$namespace->{$_}}{$type_filter} )
 253                     : ()))
 254         } keys %$namespace;
 255     } else {
 256         return map {
 257             $_ => *{$namespace->{$_}}{$type_filter}
 258         } grep {
 259             !ref($namespace->{$_}) && *{$namespace->{$_}}{$type_filter}
 260         } keys %$namespace;
 261     }
 262 }
 263
 264 1;
 265
 266 __END__
 267
 268 =pod
 269
 270 =head1 NAME
 271
 272 Class::MOP::Package - Package Meta Object
 273
 274 =head1 DESCRIPTION
 275
 276 This is an abstraction of a Perl 5 package, it is a superclass of
 277 L<Class::MOP::Class> and provides all of the symbol table
 278 introspection methods.
 279
 280 =head1 METHODS
 281
 282 =over 4
 283
 284 =item B<meta>
 285
 286 Returns a metaclass for this package.
 287
 288 =item B<initialize ($package_name)>
 289
 290 This will initialize a Class::MOP::Package instance which represents
 291 the package of C<$package_name>.
 292
 293 =item B<name>
 294
 295 This is a read-only attribute which returns the package name for the
 296 given instance.
 297
 298 =item B<namespace>
 299
 300 This returns a HASH reference to the symbol table. The keys of the
 301 HASH are the symbol names, and the values are typeglob references.
 302
 303 =item B<add_package_symbol ($variable_name, ?$initial_value)>
 304
 305 Given a C<$variable_name>, which must contain a leading sigil, this
 306 method will create that variable within the package which houses the
 307 class. It also takes an optional C<$initial_value>, which must be a
 308 reference of the same type as the sigil of the C<$variable_name>
 309 implies.
 310
 311 =item B<get_package_symbol ($variable_name)>
 312
 313 This will return a reference to the package variable in
 314 C<$variable_name>.
 315
 316 =item B<has_package_symbol ($variable_name)>
 317
 318 Returns true (C<1>) if there is a package variable defined for
 319 C<$variable_name>, and false (C<0>) otherwise.
 320
 321 =item B<remove_package_symbol ($variable_name)>
 322
 323 This will attempt to remove the package variable at C<$variable_name>.
 324
 325 =item B<remove_package_glob ($glob_name)>
 326
 327 This will attempt to remove the entire typeglob associated with
 328 C<$glob_name> from the package.
 329
 330 =item B<list_all_package_symbols (?$type_filter)>
 331
 332 This will list all the glob names associated with the current package.
 333 By inspecting the globs returned you can discern all the variables in
 334 the package.
 335
 336 By passing a C<$type_filter>, you can limit the list to only those
 337 which match the filter (either SCALAR, ARRAY, HASH or CODE).
 338
 339 =item B<get_all_package_symbols (?$type_filter)>
 340
 341 Works exactly like C<list_all_package_symbols> but returns a HASH of
 342 name => thing mapping instead of just an ARRAY of names.
 343
 344 =back
 345
 346 =head1 AUTHORS
 347
 348 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 349
 350 =head1 COPYRIGHT AND LICENSE
 351
 352 Copyright 2006-2008 by Infinity Interactive, Inc.
 353
 354 L<http://www.iinteractive.com>
 355
 356 This library is free software; you can redistribute it and/or modify
 357 it under the same terms as Perl itself.
 358
 359 =cut