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