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