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