lib/Class/MOP/Package.pm

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