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