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.98';
  11 $VERSION = eval $VERSION;
  12 our $AUTHORITY = 'cpan:STEVAN';
  13
  14 use base 'Class::MOP::Object', 'Class::MOP::Mixin::HasMethods';
  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         Class::MOP::store_metaclass_by_name($package_name, $meta);
  37
  38         return $meta;
  39     }
  40 }
  41
  42 sub reinitialize {
  43     my ( $class, @args ) = @_;
  44
  45     unshift @args, "package" if @args % 2;
  46
  47     my %options = @args;
  48     my $package_name = delete $options{package};
  49
  50     (defined $package_name && $package_name
  51       && (!blessed $package_name || $package_name->isa('Class::MOP::Package')))
  52         || confess "You must pass a package name or an existing Class::MOP::Package instance";
  53
  54     $package_name = $package_name->name
  55         if blessed $package_name;
  56
  57     Class::MOP::remove_metaclass_by_name($package_name);
  58
  59     $class->initialize($package_name, %options); # call with first arg form for compat
  60 }
  61
  62 sub _new {
  63     my $class = shift;
  64
  65     return Class::MOP::Class->initialize($class)->new_object(@_)
  66         if $class ne __PACKAGE__;
  67
  68     my $params = @_ == 1 ? $_[0] : {@_};
  69
  70     return bless {
  71         package   => $params->{package},
  72
  73         # NOTE:
  74         # because of issues with the Perl API
  75         # to the typeglob in some versions, we
  76         # need to just always grab a new
  77         # reference to the hash in the accessor.
  78         # Ideally we could just store a ref and
  79         # it would Just Work, but oh well :\
  80
  81         namespace => \undef,
  82
  83     } => $class;
  84 }
  85
  86 # Attributes
  87
  88 # NOTE:
  89 # all these attribute readers will be bootstrapped
  90 # away in the Class::MOP bootstrap section
  91
  92 sub namespace {
  93     # NOTE:
  94     # because of issues with the Perl API
  95     # to the typeglob in some versions, we
  96     # need to just always grab a new
  97     # reference to the hash here. Ideally
  98     # we could just store a ref and it would
  99     # Just Work, but oh well :\
 100     no strict 'refs';
 101     \%{$_[0]->{'package'} . '::'}
 102 }
 103
 104 # utility methods
 105
 106 {
 107     my %SIGIL_MAP = (
 108         '$' => 'SCALAR',
 109         '@' => 'ARRAY',
 110         '%' => 'HASH',
 111         '&' => 'CODE',
 112     );
 113
 114     sub _deconstruct_variable_name {
 115         my ($self, $variable) = @_;
 116
 117         (defined $variable)
 118             || confess "You must pass a variable name";
 119
 120         my $sigil = substr($variable, 0, 1, '');
 121
 122         (defined $sigil)
 123             || confess "The variable name must include a sigil";
 124
 125         (exists $SIGIL_MAP{$sigil})
 126             || confess "I do not recognize that sigil '$sigil'";
 127
 128         return ($variable, $sigil, $SIGIL_MAP{$sigil});
 129     }
 130 }
 131
 132 # Class attributes
 133
 134 # ... these functions have to touch the symbol table itself,.. yuk
 135
 136 sub add_package_symbol {
 137     my ($self, $variable, $initial_value) = @_;
 138
 139     my ($name, $sigil, $type) = ref $variable eq 'HASH'
 140         ? @{$variable}{qw[name sigil type]}
 141         : $self->_deconstruct_variable_name($variable);
 142
 143     my $pkg = $self->{'package'};
 144
 145     no strict 'refs';
 146     no warnings 'redefine', 'misc', 'prototype';
 147     *{$pkg . '::' . $name} = ref $initial_value ? $initial_value : \$initial_value;
 148 }
 149
 150 sub remove_package_glob {
 151     my ($self, $name) = @_;
 152     no strict 'refs';
 153     delete ${$self->name . '::'}{$name};
 154 }
 155
 156 # ... these functions deal with stuff on the namespace level
 157
 158 sub has_package_symbol {
 159     my ( $self, $variable ) = @_;
 160
 161     my ( $name, $sigil, $type )
 162         = ref $variable eq 'HASH'
 163         ? @{$variable}{qw[name sigil type]}
 164         : $self->_deconstruct_variable_name($variable);
 165
 166     my $namespace = $self->namespace;
 167
 168     return 0 unless exists $namespace->{$name};
 169
 170     my $entry_ref = \$namespace->{$name};
 171     if ( reftype($entry_ref) eq 'GLOB' ) {
 172         if ( $type eq 'SCALAR' ) {
 173             return defined( ${ *{$entry_ref}{SCALAR} } );
 174         }
 175         else {
 176             return defined( *{$entry_ref}{$type} );
 177         }
 178     }
 179     else {
 180
 181         # a symbol table entry can be -1 (stub), string (stub with prototype),
 182         # or reference (constant)
 183         return $type eq 'CODE';
 184     }
 185 }
 186
 187 sub get_package_symbol {
 188     my ($self, $variable) = @_;
 189
 190     my ($name, $sigil, $type) = ref $variable eq 'HASH'
 191         ? @{$variable}{qw[name sigil type]}
 192         : $self->_deconstruct_variable_name($variable);
 193
 194     my $namespace = $self->namespace;
 195
 196     # FIXME
 197     $self->add_package_symbol($variable)
 198         unless exists $namespace->{$name};
 199
 200     my $entry_ref = \$namespace->{$name};
 201
 202     if ( ref($entry_ref) eq 'GLOB' ) {
 203         return *{$entry_ref}{$type};
 204     }
 205     else {
 206         if ( $type eq 'CODE' ) {
 207             no strict 'refs';
 208             return \&{ $self->name . '::' . $name };
 209         }
 210         else {
 211             return undef;
 212         }
 213     }
 214 }
 215
 216 sub remove_package_symbol {
 217     my ($self, $variable) = @_;
 218
 219     my ($name, $sigil, $type) = ref $variable eq 'HASH'
 220         ? @{$variable}{qw[name sigil type]}
 221         : $self->_deconstruct_variable_name($variable);
 222
 223     # FIXME:
 224     # no doubt this is grossly inefficient and
 225     # could be done much easier and faster in XS
 226
 227     my ($scalar_desc, $array_desc, $hash_desc, $code_desc) = (
 228         { sigil => '$', type => 'SCALAR', name => $name },
 229         { sigil => '@', type => 'ARRAY',  name => $name },
 230         { sigil => '%', type => 'HASH',   name => $name },
 231         { sigil => '&', type => 'CODE',   name => $name },
 232     );
 233
 234     my ($scalar, $array, $hash, $code);
 235     if ($type eq 'SCALAR') {
 236         $array  = $self->get_package_symbol($array_desc)  if $self->has_package_symbol($array_desc);
 237         $hash   = $self->get_package_symbol($hash_desc)   if $self->has_package_symbol($hash_desc);
 238         $code   = $self->get_package_symbol($code_desc)   if $self->has_package_symbol($code_desc);
 239     }
 240     elsif ($type eq 'ARRAY') {
 241         $scalar = $self->get_package_symbol($scalar_desc) if $self->has_package_symbol($scalar_desc);
 242         $hash   = $self->get_package_symbol($hash_desc)   if $self->has_package_symbol($hash_desc);
 243         $code   = $self->get_package_symbol($code_desc)   if $self->has_package_symbol($code_desc);
 244     }
 245     elsif ($type eq 'HASH') {
 246         $scalar = $self->get_package_symbol($scalar_desc) if $self->has_package_symbol($scalar_desc);
 247         $array  = $self->get_package_symbol($array_desc)  if $self->has_package_symbol($array_desc);
 248         $code   = $self->get_package_symbol($code_desc)   if $self->has_package_symbol($code_desc);
 249     }
 250     elsif ($type eq 'CODE') {
 251         $scalar = $self->get_package_symbol($scalar_desc) if $self->has_package_symbol($scalar_desc);
 252         $array  = $self->get_package_symbol($array_desc)  if $self->has_package_symbol($array_desc);
 253         $hash   = $self->get_package_symbol($hash_desc)   if $self->has_package_symbol($hash_desc);
 254     }
 255     else {
 256         confess "This should never ever ever happen";
 257     }
 258
 259     $self->remove_package_glob($name);
 260
 261     $self->add_package_symbol($scalar_desc => $scalar) if defined $scalar;
 262     $self->add_package_symbol($array_desc  => $array)  if defined $array;
 263     $self->add_package_symbol($hash_desc   => $hash)   if defined $hash;
 264     $self->add_package_symbol($code_desc   => $code)   if defined $code;
 265 }
 266
 267 sub list_all_package_symbols {
 268     my ($self, $type_filter) = @_;
 269
 270     my $namespace = $self->namespace;
 271     return keys %{$namespace} unless defined $type_filter;
 272
 273     # NOTE:
 274     # or we can filter based on
 275     # type (SCALAR|ARRAY|HASH|CODE)
 276     if ( $type_filter eq 'CODE' ) {
 277         return grep {
 278         (ref($namespace->{$_})
 279                 ? (ref($namespace->{$_}) eq 'SCALAR')
 280                 : (ref(\$namespace->{$_}) eq 'GLOB'
 281                    && defined(*{$namespace->{$_}}{CODE})));
 282         } keys %{$namespace};
 283     } else {
 284         return grep { *{$namespace->{$_}}{$type_filter} } keys %{$namespace};
 285     }
 286 }
 287
 288 1;
 289
 290 __END__
 291
 292 =pod
 293
 294 =head1 NAME
 295
 296 Class::MOP::Package - Package Meta Object
 297
 298 =head1 DESCRIPTION
 299
 300 The Package Protocol provides an abstraction of a Perl 5 package. A
 301 package is basically namespace, and this module provides methods for
 302 looking at and changing that namespace's symbol table.
 303
 304 =head1 METHODS
 305
 306 =over 4
 307
 308 =item B<< Class::MOP::Package->initialize($package_name) >>
 309
 310 This method creates a new C<Class::MOP::Package> instance which
 311 represents specified package. If an existing metaclass object exists
 312 for the package, that will be returned instead.
 313
 314 =item B<< Class::MOP::Package->reinitialize($package) >>
 315
 316 This method forcibly removes any existing metaclass for the package
 317 before calling C<initialize>. In contrast to C<initialize>, you may
 318 also pass an existing C<Class::MOP::Package> instance instead of just
 319 a package name as C<$package>.
 320
 321 Do not call this unless you know what you are doing.
 322
 323 =item B<< $metapackage->name >>
 324
 325 This is returns the package's name, as passed to the constructor.
 326
 327 =item B<< $metapackage->namespace >>
 328
 329 This returns a hash reference to the package's symbol table. The keys
 330 are symbol names and the values are typeglob references.
 331
 332 =item B<< $metapackage->add_package_symbol($variable_name, $initial_value) >>
 333
 334 This method accepts a variable name and an optional initial value. The
 335 C<$variable_name> must contain a leading sigil.
 336
 337 This method creates the variable in the package's symbol table, and
 338 sets it to the initial value if one was provided.
 339
 340 =item B<< $metapackage->get_package_symbol($variable_name) >>
 341
 342 Given a variable name, this method returns the variable as a reference
 343 or undef if it does not exist. The C<$variable_name> must contain a
 344 leading sigil.
 345
 346 =item B<< $metapackage->has_package_symbol($variable_name) >>
 347
 348 Returns true if there is a package variable defined for
 349 C<$variable_name>. The C<$variable_name> must contain a leading sigil.
 350
 351 =item B<< $metapackage->remove_package_symbol($variable_name) >>
 352
 353 This will remove the package variable specified C<$variable_name>. The
 354 C<$variable_name> must contain a leading sigil.
 355
 356 =item B<< $metapackage->remove_package_glob($glob_name) >>
 357
 358 Given the name of a glob, this will remove that glob from the
 359 package's symbol table. Glob names do not include a sigil. Removing
 360 the glob removes all variables and subroutines with the specified
 361 name.
 362
 363 =item B<< $metapackage->list_all_package_symbols($type_filter) >>
 364
 365 This will list all the glob names associated with the current
 366 package. These names do not have leading sigils.
 367
 368 You can provide an optional type filter, which should be one of
 369 'SCALAR', 'ARRAY', 'HASH', or 'CODE'.
 370
 371 =item B<< $metapackage->get_all_package_symbols($type_filter) >>
 372
 373 This works much like C<list_all_package_symbols>, but it returns a
 374 hash reference. The keys are glob names and the values are references
 375 to the value for that name.
 376
 377 =back
 378
 379 =head2 Method introspection and creation
 380
 381 These methods allow you to introspect a class's methods, as well as
 382 add, remove, or change methods.
 383
 384 Determining what is truly a method in a Perl 5 class requires some
 385 heuristics (aka guessing).
 386
 387 Methods defined outside the package with a fully qualified name (C<sub
 388 Package::name { ... }>) will be included. Similarly, methods named
 389 with a fully qualified name using L<Sub::Name> are also included.
 390
 391 However, we attempt to ignore imported functions.
 392
 393 Ultimately, we are using heuristics to determine what truly is a
 394 method in a class, and these heuristics may get the wrong answer in
 395 some edge cases. However, for most "normal" cases the heuristics work
 396 correctly.
 397
 398 =over 4
 399
 400 =item B<< $metapackage->get_method($method_name) >>
 401
 402 This will return a L<Class::MOP::Method> for the specified
 403 C<$method_name>. If the class does not have the specified method, it
 404 returns C<undef>
 405
 406 =item B<< $metapackage->has_method($method_name) >>
 407
 408 Returns a boolean indicating whether or not the class defines the
 409 named method. It does not include methods inherited from parent
 410 classes.
 411
 412 =item B<< $metapackage->get_method_list >>
 413
 414 This will return a list of method I<names> for all methods defined in
 415 this class.
 416
 417 =item B<< $metapackage->add_method($method_name, $method) >>
 418
 419 This method takes a method name and a subroutine reference, and adds
 420 the method to the class.
 421
 422 The subroutine reference can be a L<Class::MOP::Method>, and you are
 423 strongly encouraged to pass a meta method object instead of a code
 424 reference. If you do so, that object gets stored as part of the
 425 class's method map directly. If not, the meta information will have to
 426 be recreated later, and may be incorrect.
 427
 428 If you provide a method object, this method will clone that object if
 429 the object's package name does not match the class name. This lets us
 430 track the original source of any methods added from other classes
 431 (notably Moose roles).
 432
 433 =item B<< $metapackage->remove_method($method_name) >>
 434
 435 Remove the named method from the class. This method returns the
 436 L<Class::MOP::Method> object for the method.
 437
 438 =item B<< $metapackage->method_metaclass >>
 439
 440 Returns the class name of the method metaclass, see
 441 L<Class::MOP::Method> for more information on the method metaclass.
 442
 443 =item B<< $metapackage->wrapped_method_metaclass >>
 444
 445 Returns the class name of the wrapped method metaclass, see
 446 L<Class::MOP::Method::Wrapped> for more information on the wrapped
 447 method metaclass.
 448
 449 =item B<< Class::MOP::Package->meta >>
 450
 451 This will return a L<Class::MOP::Class> instance for this class.
 452
 453 =back
 454
 455 =head1 AUTHORS
 456
 457 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 458
 459 =head1 COPYRIGHT AND LICENSE
 460
 461 Copyright 2006-2010 by Infinity Interactive, Inc.
 462
 463 L<http://www.iinteractive.com>
 464
 465 This library is free software; you can redistribute it and/or modify
 466 it under the same terms as Perl itself.
 467
 468 =cut