lib/Class/MOP/Package.pm

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