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.89';
  11 $VERSION = eval $VERSION;
  12 our $AUTHORITY = 'cpan:STEVAN';
  13
  14 use base 'Class::MOP::Object';
  15
  16 # creation ...
  17
  18 sub initialize {
  19     my ( $class, @args ) = @_;
  20
  21     unshift @args, "package" if @args % 2;
  22
  23     my %options = @args;
  24     my $package_name = $options{package};
  25
  26
  27     # we hand-construct the class
  28     # until we can bootstrap it
  29     if ( my $meta = Class::MOP::get_metaclass_by_name($package_name) ) {
  30         return $meta;
  31     } else {
  32         my $meta = ( ref $class || $class )->_new({
  33             'package'   => $package_name,
  34             %options,
  35         });
  36
  37         Class::MOP::store_metaclass_by_name($package_name, $meta);
  38
  39         return $meta;
  40     }
  41 }
  42
  43 sub reinitialize {
  44     my ( $class, @args ) = @_;
  45
  46     unshift @args, "package" if @args % 2;
  47
  48     my %options = @args;
  49     my $package_name = delete $options{package};
  50
  51     (defined $package_name && $package_name && !blessed($package_name))
  52         || confess "You must pass a package name and it cannot be blessed";
  53
  54     Class::MOP::remove_metaclass_by_name($package_name);
  55
  56     $class->initialize($package_name, %options); # call with first arg form for compat
  57 }
  58
  59 sub _new {
  60     my $class = shift;
  61     return Class::MOP::Class->initialize($class)->new_object(@_)
  62       if $class ne __PACKAGE__;
  63
  64     my $params = @_ == 1 ? $_[0] : {@_};
  65
  66     return bless {
  67         package   => $params->{package},
  68
  69         # NOTE:
  70         # because of issues with the Perl API
  71         # to the typeglob in some versions, we
  72         # need to just always grab a new
  73         # reference to the hash in the accessor.
  74         # Ideally we could just store a ref and
  75         # it would Just Work, but oh well :\
  76
  77         namespace => \undef,
  78
  79     } => $class;
  80 }
  81
  82 # Attributes
  83
  84 # NOTE:
  85 # all these attribute readers will be bootstrapped
  86 # away in the Class::MOP bootstrap section
  87
  88 sub namespace {
  89     # NOTE:
  90     # because of issues with the Perl API
  91     # to the typeglob in some versions, we
  92     # need to just always grab a new
  93     # reference to the hash here. Ideally
  94     # we could just store a ref and it would
  95     # Just Work, but oh well :\
  96     no strict 'refs';
  97     \%{$_[0]->{'package'} . '::'}
  98 }
  99
 100 # utility methods
 101
 102 {
 103     my %SIGIL_MAP = (
 104         '$' => 'SCALAR',
 105         '@' => 'ARRAY',
 106         '%' => 'HASH',
 107         '&' => 'CODE',
 108     );
 109
 110     sub _deconstruct_variable_name {
 111         my ($self, $variable) = @_;
 112
 113         (defined $variable)
 114             || confess "You must pass a variable name";
 115
 116         my $sigil = substr($variable, 0, 1, '');
 117
 118         (defined $sigil)
 119             || confess "The variable name must include a sigil";
 120
 121         (exists $SIGIL_MAP{$sigil})
 122             || confess "I do not recognize that sigil '$sigil'";
 123
 124         return ($variable, $sigil, $SIGIL_MAP{$sigil});
 125     }
 126 }
 127
 128 # Class attributes
 129
 130 # ... these functions have to touch the symbol table itself,.. yuk
 131
 132 sub add_package_symbol {
 133     my ($self, $variable, $initial_value) = @_;
 134
 135     my ($name, $sigil, $type) = ref $variable eq 'HASH'
 136         ? @{$variable}{qw[name sigil type]}
 137         : $self->_deconstruct_variable_name($variable);
 138
 139     my $pkg = $self->{'package'};
 140
 141     no strict 'refs';
 142     no warnings 'redefine', 'misc', 'prototype';
 143     *{$pkg . '::' . $name} = ref $initial_value ? $initial_value : \$initial_value;
 144 }
 145
 146 sub remove_package_glob {
 147     my ($self, $name) = @_;
 148     no strict 'refs';
 149     delete ${$self->name . '::'}{$name};
 150 }
 151
 152 # ... these functions deal with stuff on the namespace level
 153
 154 sub has_package_symbol {
 155     my ($self, $variable) = @_;
 156
 157     my ($name, $sigil, $type) = ref $variable eq 'HASH'
 158         ? @{$variable}{qw[name sigil type]}
 159         : $self->_deconstruct_variable_name($variable);
 160
 161     my $namespace = $self->namespace;
 162
 163     return 0 unless exists $namespace->{$name};
 164
 165     my $entry_ref = \$namespace->{$name};
 166     if (ref($entry_ref) eq 'GLOB') {
 167         if ($type eq 'SCALAR') {
 168             return defined(${ *{$entry_ref}{SCALAR} });
 169         }
 170         else {
 171             return defined(*{$entry_ref}{$type});
 172         }
 173      }
 174      else {
 175          # a symbol table entry can be -1 (stub), string (stub with prototype),
 176          # or reference (constant)
 177          return $type eq 'CODE';
 178     }
 179 }
 180
 181 sub get_package_symbol {
 182     my ($self, $variable) = @_;
 183
 184     my ($name, $sigil, $type) = ref $variable eq 'HASH'
 185         ? @{$variable}{qw[name sigil type]}
 186         : $self->_deconstruct_variable_name($variable);
 187
 188     my $namespace = $self->namespace;
 189
 190     # FIXME
 191     $self->add_package_symbol($variable)
 192         unless exists $namespace->{$name};
 193
 194     my $entry_ref = \$namespace->{$name};
 195
 196     if (ref($entry_ref) eq 'GLOB') {
 197         return *{$entry_ref}{$type};
 198     }
 199     else{
 200         if($type eq 'CODE'){
 201             no strict 'refs';
 202             return \&{$self->name . '::' . $name};
 203         }
 204         else{
 205             return undef;
 206         }
 207     }
 208 }
 209
 210 sub remove_package_symbol {
 211     my ($self, $variable) = @_;
 212
 213     my ($name, $sigil, $type) = ref $variable eq 'HASH'
 214         ? @{$variable}{qw[name sigil type]}
 215         : $self->_deconstruct_variable_name($variable);
 216
 217     # FIXME:
 218     # no doubt this is grossly inefficient and
 219     # could be done much easier and faster in XS
 220
 221     my ($scalar_desc, $array_desc, $hash_desc, $code_desc) = (
 222         { sigil => '$', type => 'SCALAR', name => $name },
 223         { sigil => '@', type => 'ARRAY',  name => $name },
 224         { sigil => '%', type => 'HASH',   name => $name },
 225         { sigil => '&', type => 'CODE',   name => $name },
 226     );
 227
 228     my ($scalar, $array, $hash, $code);
 229     if ($type eq 'SCALAR') {
 230         $array  = $self->get_package_symbol($array_desc)  if $self->has_package_symbol($array_desc);
 231         $hash   = $self->get_package_symbol($hash_desc)   if $self->has_package_symbol($hash_desc);
 232         $code   = $self->get_package_symbol($code_desc)   if $self->has_package_symbol($code_desc);
 233     }
 234     elsif ($type eq 'ARRAY') {
 235         $scalar = $self->get_package_symbol($scalar_desc) if $self->has_package_symbol($scalar_desc);
 236         $hash   = $self->get_package_symbol($hash_desc)   if $self->has_package_symbol($hash_desc);
 237         $code   = $self->get_package_symbol($code_desc)   if $self->has_package_symbol($code_desc);
 238     }
 239     elsif ($type eq 'HASH') {
 240         $scalar = $self->get_package_symbol($scalar_desc) if $self->has_package_symbol($scalar_desc);
 241         $array  = $self->get_package_symbol($array_desc)  if $self->has_package_symbol($array_desc);
 242         $code   = $self->get_package_symbol($code_desc)   if $self->has_package_symbol($code_desc);
 243     }
 244     elsif ($type eq 'CODE') {
 245         $scalar = $self->get_package_symbol($scalar_desc) if $self->has_package_symbol($scalar_desc);
 246         $array  = $self->get_package_symbol($array_desc)  if $self->has_package_symbol($array_desc);
 247         $hash   = $self->get_package_symbol($hash_desc)   if $self->has_package_symbol($hash_desc);
 248     }
 249     else {
 250         confess "This should never ever ever happen";
 251     }
 252
 253     $self->remove_package_glob($name);
 254
 255     $self->add_package_symbol($scalar_desc => $scalar) if defined $scalar;
 256     $self->add_package_symbol($array_desc  => $array)  if defined $array;
 257     $self->add_package_symbol($hash_desc   => $hash)   if defined $hash;
 258     $self->add_package_symbol($code_desc   => $code)   if defined $code;
 259 }
 260
 261 sub list_all_package_symbols {
 262     my ($self, $type_filter) = @_;
 263
 264     my $namespace = $self->namespace;
 265     return keys %{$namespace} unless defined $type_filter;
 266
 267     # NOTE:
 268     # or we can filter based on
 269     # type (SCALAR|ARRAY|HASH|CODE)
 270     if ( $type_filter eq 'CODE' ) {
 271         return grep {
 272         (ref($namespace->{$_})
 273                 ? (ref($namespace->{$_}) eq 'SCALAR')
 274                 : (ref(\$namespace->{$_}) eq 'GLOB'
 275                    && defined(*{$namespace->{$_}}{CODE})));
 276         } keys %{$namespace};
 277     } else {
 278         return grep { *{$namespace->{$_}}{$type_filter} } keys %{$namespace};
 279     }
 280 }
 281
 282 1;
 283
 284 __END__
 285
 286 =pod
 287
 288 =head1 NAME
 289
 290 Class::MOP::Package - Package Meta Object
 291
 292 =head1 DESCRIPTION
 293
 294 The Package Protocol provides an abstraction of a Perl 5 package. A
 295 package is basically namespace, and this module provides methods for
 296 looking at and changing that namespace's symbol table.
 297
 298 =head1 METHODS
 299
 300 =over 4
 301
 302 =item B<< Class::MOP::Package->initialize($package_name) >>
 303
 304 This method creates a new C<Class::MOP::Package> instance which
 305 represents specified package. If an existing metaclass object exists
 306 for the package, that will be returned instead.
 307
 308 =item B<< Class::MOP::Package->reinitialize($package_name) >>
 309
 310 This method forcibly removes any existing metaclass for the package
 311 before calling C<initialize>
 312
 313 Do not call this unless you know what you are doing.
 314
 315 =item B<< $metapackage->name >>
 316
 317 This is returns the package's name, as passed to the constructor.
 318
 319 =item B<< $metapackage->namespace >>
 320
 321 This returns a hash reference to the package's symbol table. The keys
 322 are symbol names and the values are typeglob references.
 323
 324 =item B<< $metapackage->add_package_symbol($variable_name, $initial_value) >>
 325
 326 This method accepts a variable name and an optional initial value. The
 327 C<$variable_name> must contain a leading sigil.
 328
 329 This method creates the variable in the package's symbol table, and
 330 sets it to the initial value if one was provided.
 331
 332 =item B<< $metapackage->get_package_symbol($variable_name) >>
 333
 334 Given a variable name, this method returns the variable as a reference
 335 or undef if it does not exist. The C<$variable_name> must contain a
 336 leading sigil.
 337
 338 =item B<< $metapackage->has_package_symbol($variable_name) >>
 339
 340 Returns true if there is a package variable defined for
 341 C<$variable_name>. The C<$variable_name> must contain a leading sigil.
 342
 343 =item B<< $metapackage->remove_package_symbol($variable_name) >>
 344
 345 This will remove the package variable specified C<$variable_name>. The
 346 C<$variable_name> must contain a leading sigil.
 347
 348 =item B<< $metapackage->remove_package_glob($glob_name) >>
 349
 350 Given the name of a glob, this will remove that glob from the
 351 package's symbol table. Glob names do not include a sigil. Removing
 352 the glob removes all variables and subroutines with the specified
 353 name.
 354
 355 =item B<< $metapackage->list_all_package_symbols($type_filter) >>
 356
 357 This will list all the glob names associated with the current
 358 package. These names do not have leading sigils.
 359
 360 You can provide an optional type filter, which should be one of
 361 'SCALAR', 'ARRAY', 'HASH', or 'CODE'.
 362
 363 =item B<< $metapackage->get_all_package_symbols($type_filter) >>
 364
 365 This works much like C<list_all_package_symbols>, but it returns a
 366 hash reference. The keys are glob names and the values are references
 367 to the value for that name.
 368
 369 =item B<< Class::MOP::Package->meta >>
 370
 371 This will return a L<Class::MOP::Class> instance for this class.
 372
 373 =back
 374
 375 =head1 AUTHORS
 376
 377 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 378
 379 =head1 COPYRIGHT AND LICENSE
 380
 381 Copyright 2006-2009 by Infinity Interactive, Inc.
 382
 383 L<http://www.iinteractive.com>
 384
 385 This library is free software; you can redistribute it and/or modify
 386 it under the same terms as Perl itself.
 387
 388 =cut