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