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