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