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