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.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
  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
 134
 135 sub add_package_symbol {
 136     my ($self, $variable, $initial_value) = @_;
 137
 138     my ($name, $sigil, $type) = ref $variable eq 'HASH'
 139         ? @{$variable}{qw[name sigil type]}
 140         : $self->_deconstruct_variable_name($variable);
 141
 142     my $pkg = $self->{'package'};
 143
 144     no strict 'refs';
 145     no warnings 'redefine', 'misc', 'prototype';
 146     *{$pkg . '::' . $name} = ref $initial_value ? $initial_value : \$initial_value;
 147 }
 148
 149 sub remove_package_glob {
 150     my ($self, $name) = @_;
 151     no strict 'refs';
 152     delete ${$self->name . '::'}{$name};
 153 }
 154
 155 # ... these functions deal with stuff on the namespace level
 156
 157 sub has_package_symbol {
 158     my ( $self, $variable ) = @_;
 159
 160     my ( $name, $sigil, $type )
 161         = ref $variable eq 'HASH'
 162         ? @{$variable}{qw[name sigil type]}
 163         : $self->_deconstruct_variable_name($variable);
 164
 165     my $namespace = $self->namespace;
 166
 167     return 0 unless exists $namespace->{$name};
 168
 169     my $entry_ref = \$namespace->{$name};
 170     if ( reftype($entry_ref) eq 'GLOB' ) {
 171         if ( $type eq 'SCALAR' ) {
 172             return defined( ${ *{$entry_ref}{SCALAR} } );
 173         }
 174         else {
 175             return defined( *{$entry_ref}{$type} );
 176         }
 177     }
 178     else {
 179
 180         # a symbol table entry can be -1 (stub), string (stub with prototype),
 181         # or reference (constant)
 182         return $type eq 'CODE';
 183     }
 184 }
 185
 186 sub get_package_symbol {
 187     my ($self, $variable) = @_;
 188
 189     my ($name, $sigil, $type) = ref $variable eq 'HASH'
 190         ? @{$variable}{qw[name sigil type]}
 191         : $self->_deconstruct_variable_name($variable);
 192
 193     my $namespace = $self->namespace;
 194
 195     # FIXME
 196     $self->add_package_symbol($variable)
 197         unless exists $namespace->{$name};
 198
 199     my $entry_ref = \$namespace->{$name};
 200
 201     if ( ref($entry_ref) eq 'GLOB' ) {
 202         return *{$entry_ref}{$type};
 203     }
 204     else {
 205         if ( $type eq 'CODE' ) {
 206             no strict 'refs';
 207             return \&{ $self->name . '::' . $name };
 208         }
 209         else {
 210             return undef;
 211         }
 212     }
 213 }
 214
 215 sub remove_package_symbol {
 216     my ($self, $variable) = @_;
 217
 218     my ($name, $sigil, $type) = ref $variable eq 'HASH'
 219         ? @{$variable}{qw[name sigil type]}
 220         : $self->_deconstruct_variable_name($variable);
 221
 222     # FIXME:
 223     # no doubt this is grossly inefficient and
 224     # could be done much easier and faster in XS
 225
 226     my ($scalar_desc, $array_desc, $hash_desc, $code_desc) = (
 227         { sigil => '$', type => 'SCALAR', name => $name },
 228         { sigil => '@', type => 'ARRAY',  name => $name },
 229         { sigil => '%', type => 'HASH',   name => $name },
 230         { sigil => '&', type => 'CODE',   name => $name },
 231     );
 232
 233     my ($scalar, $array, $hash, $code);
 234     if ($type eq 'SCALAR') {
 235         $array  = $self->get_package_symbol($array_desc)  if $self->has_package_symbol($array_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 'ARRAY') {
 240         $scalar = $self->get_package_symbol($scalar_desc) if $self->has_package_symbol($scalar_desc);
 241         $hash   = $self->get_package_symbol($hash_desc)   if $self->has_package_symbol($hash_desc);
 242         $code   = $self->get_package_symbol($code_desc)   if $self->has_package_symbol($code_desc);
 243     }
 244     elsif ($type eq 'HASH') {
 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         $code   = $self->get_package_symbol($code_desc)   if $self->has_package_symbol($code_desc);
 248     }
 249     elsif ($type eq 'CODE') {
 250         $scalar = $self->get_package_symbol($scalar_desc) if $self->has_package_symbol($scalar_desc);
 251         $array  = $self->get_package_symbol($array_desc)  if $self->has_package_symbol($array_desc);
 252         $hash   = $self->get_package_symbol($hash_desc)   if $self->has_package_symbol($hash_desc);
 253     }
 254     else {
 255         confess "This should never ever ever happen";
 256     }
 257
 258     $self->remove_package_glob($name);
 259
 260     $self->add_package_symbol($scalar_desc => $scalar) if defined $scalar;
 261     $self->add_package_symbol($array_desc  => $array)  if defined $array;
 262     $self->add_package_symbol($hash_desc   => $hash)   if defined $hash;
 263     $self->add_package_symbol($code_desc   => $code)   if defined $code;
 264 }
 265
 266 sub list_all_package_symbols {
 267     my ($self, $type_filter) = @_;
 268
 269     my $namespace = $self->namespace;
 270     return keys %{$namespace} unless defined $type_filter;
 271
 272     # NOTE:
 273     # or we can filter based on
 274     # type (SCALAR|ARRAY|HASH|CODE)
 275     if ( $type_filter eq 'CODE' ) {
 276         return grep {
 277         (ref($namespace->{$_})
 278                 ? (ref($namespace->{$_}) eq 'SCALAR')
 279                 : (ref(\$namespace->{$_}) eq 'GLOB'
 280                    && defined(*{$namespace->{$_}}{CODE})));
 281         } keys %{$namespace};
 282     } else {
 283         return grep { *{$namespace->{$_}}{$type_filter} } keys %{$namespace};
 284     }
 285 }
 286
 287 1;
 288
 289 __END__
 290
 291 =pod
 292
 293 =head1 NAME
 294
 295 Class::MOP::Package - Package Meta Object
 296
 297 =head1 DESCRIPTION
 298
 299 The Package Protocol provides an abstraction of a Perl 5 package. A
 300 package is basically namespace, and this module provides methods for
 301 looking at and changing that namespace's symbol table.
 302
 303 =head1 METHODS
 304
 305 =over 4
 306
 307 =item B<< Class::MOP::Package->initialize($package_name) >>
 308
 309 This method creates a new C<Class::MOP::Package> instance which
 310 represents specified package. If an existing metaclass object exists
 311 for the package, that will be returned instead.
 312
 313 =item B<< Class::MOP::Package->reinitialize($package_name) >>
 314
 315 This method forcibly removes any existing metaclass for the package
 316 before calling C<initialize>
 317
 318 Do not call this unless you know what you are doing.
 319
 320 =item B<< $metapackage->name >>
 321
 322 This is returns the package's name, as passed to the constructor.
 323
 324 =item B<< $metapackage->namespace >>
 325
 326 This returns a hash reference to the package's symbol table. The keys
 327 are symbol names and the values are typeglob references.
 328
 329 =item B<< $metapackage->add_package_symbol($variable_name, $initial_value) >>
 330
 331 This method accepts a variable name and an optional initial value. The
 332 C<$variable_name> must contain a leading sigil.
 333
 334 This method creates the variable in the package's symbol table, and
 335 sets it to the initial value if one was provided.
 336
 337 =item B<< $metapackage->get_package_symbol($variable_name) >>
 338
 339 Given a variable name, this method returns the variable as a reference
 340 or undef if it does not exist. The C<$variable_name> must contain a
 341 leading sigil.
 342
 343 =item B<< $metapackage->has_package_symbol($variable_name) >>
 344
 345 Returns true if there is a package variable defined for
 346 C<$variable_name>. The C<$variable_name> must contain a leading sigil.
 347
 348 =item B<< $metapackage->remove_package_symbol($variable_name) >>
 349
 350 This will remove the package variable specified C<$variable_name>. The
 351 C<$variable_name> must contain a leading sigil.
 352
 353 =item B<< $metapackage->remove_package_glob($glob_name) >>
 354
 355 Given the name of a glob, this will remove that glob from the
 356 package's symbol table. Glob names do not include a sigil. Removing
 357 the glob removes all variables and subroutines with the specified
 358 name.
 359
 360 =item B<< $metapackage->list_all_package_symbols($type_filter) >>
 361
 362 This will list all the glob names associated with the current
 363 package. These names do not have leading sigils.
 364
 365 You can provide an optional type filter, which should be one of
 366 'SCALAR', 'ARRAY', 'HASH', or 'CODE'.
 367
 368 =item B<< $metapackage->get_all_package_symbols($type_filter) >>
 369
 370 This works much like C<list_all_package_symbols>, but it returns a
 371 hash reference. The keys are glob names and the values are references
 372 to the value for that name.
 373
 374 =item B<< Class::MOP::Package->meta >>
 375
 376 This will return a L<Class::MOP::Class> instance for this class.
 377
 378 =back
 379
 380 =head1 AUTHORS
 381
 382 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 383
 384 =head1 COPYRIGHT AND LICENSE
 385
 386 Copyright 2006-2009 by Infinity Interactive, Inc.
 387
 388 L<http://www.iinteractive.com>
 389
 390 This library is free software; you can redistribute it and/or modify
 391 it under the same terms as Perl itself.
 392
 393 =cut