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