lib/Class/MOP/Package.pm

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