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