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