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