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