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