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