lib/Class/MOP/Package.pm

   1
   2 package Class::MOP::Package;
   3
   4 use strict;
   5 use warnings;
   6
   7 use B;
   8 use Scalar::Util 'blessed';
   9 use Carp         'confess';
  10
  11 our $VERSION   = '0.71_02';
  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         });
  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 && !blessed($package_name))
  52         || confess "You must pass a package name and it cannot be blessed";
  53
  54     Class::MOP::remove_metaclass_by_name($package_name);
  55
  56     $class->initialize($package_name, %options); # call with first arg form for compat
  57 }
  58
  59 sub _new {
  60     my $class = shift;
  61     my $options = @_ == 1 ? $_[0] : {@_};
  62
  63     # NOTE:
  64     # because of issues with the Perl API
  65     # to the typeglob in some versions, we
  66     # need to just always grab a new
  67     # reference to the hash in the accessor.
  68     # Ideally we could just store a ref and
  69     # it would Just Work, but oh well :\
  70     $options->{namespace} ||= \undef;
  71
  72     bless $options, $class;
  73 }
  74
  75 # Attributes
  76
  77 # NOTE:
  78 # all these attribute readers will be bootstrapped
  79 # away in the Class::MOP bootstrap section
  80
  81 sub name      { $_[0]->{'package'} }
  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 # utility methods
  95
  96 {
  97     my %SIGIL_MAP = (
  98         '$' => 'SCALAR',
  99         '@' => 'ARRAY',
 100         '%' => 'HASH',
 101         '&' => 'CODE',
 102     );
 103
 104     sub _deconstruct_variable_name {
 105         my ($self, $variable) = @_;
 106
 107         (defined $variable)
 108             || confess "You must pass a variable name";
 109
 110         my $sigil = substr($variable, 0, 1, '');
 111
 112         (defined $sigil)
 113             || confess "The variable name must include a sigil";
 114
 115         (exists $SIGIL_MAP{$sigil})
 116             || confess "I do not recognize that sigil '$sigil'";
 117
 118         return ($variable, $sigil, $SIGIL_MAP{$sigil});
 119     }
 120 }
 121
 122 # Class attributes
 123
 124 # ... these functions have to touch the symbol table itself,.. yuk
 125
 126 sub add_package_symbol {
 127     my ($self, $variable, $initial_value) = @_;
 128
 129     my ($name, $sigil, $type) = ref $variable eq 'HASH'
 130         ? @{$variable}{qw[name sigil type]}
 131         : $self->_deconstruct_variable_name($variable);
 132
 133     my $pkg = $self->{'package'};
 134
 135     no strict 'refs';
 136     no warnings 'redefine', 'misc';
 137     *{$pkg . '::' . $name} = ref $initial_value ? $initial_value : \$initial_value;
 138 }
 139
 140 sub remove_package_glob {
 141     my ($self, $name) = @_;
 142     no strict 'refs';
 143     delete ${$self->name . '::'}{$name};
 144 }
 145
 146 # ... these functions deal with stuff on the namespace level
 147
 148 sub has_package_symbol {
 149     my ($self, $variable) = @_;
 150
 151     my ($name, $sigil, $type) = ref $variable eq 'HASH'
 152         ? @{$variable}{qw[name sigil type]}
 153         : $self->_deconstruct_variable_name($variable);
 154
 155     my $namespace = $self->namespace;
 156
 157     return 0 unless exists $namespace->{$name};
 158
 159     # FIXME:
 160     # For some really stupid reason
 161     # a typeglob will have a default
 162     # value of \undef in the SCALAR
 163     # slot, so we need to work around
 164     # this. Which of course means that
 165     # if you put \undef in your scalar
 166     # then this is broken.
 167
 168     if (ref($namespace->{$name}) eq 'SCALAR') {
 169         return ($type eq 'CODE');
 170     }
 171     elsif ($type eq 'SCALAR') {
 172         my $val = *{$namespace->{$name}}{$type};
 173         return defined(${$val});
 174     }
 175     else {
 176         defined(*{$namespace->{$name}}{$type});
 177     }
 178 }
 179
 180 sub get_package_symbol {
 181     my ($self, $variable) = @_;
 182
 183     my ($name, $sigil, $type) = ref $variable eq 'HASH'
 184         ? @{$variable}{qw[name sigil type]}
 185         : $self->_deconstruct_variable_name($variable);
 186
 187     my $namespace = $self->namespace;
 188
 189     $self->add_package_symbol($variable)
 190         unless exists $namespace->{$name};
 191
 192     if (ref($namespace->{$name}) eq 'SCALAR') {
 193         if ($type eq 'CODE') {
 194             no strict 'refs';
 195             return \&{$self->name.'::'.$name};
 196         }
 197         else {
 198             return undef;
 199         }
 200     }
 201     else {
 202         return *{$namespace->{$name}}{$type};
 203     }
 204 }
 205
 206 sub remove_package_symbol {
 207     my ($self, $variable) = @_;
 208
 209     my ($name, $sigil, $type) = ref $variable eq 'HASH'
 210         ? @{$variable}{qw[name sigil type]}
 211         : $self->_deconstruct_variable_name($variable);
 212
 213     # FIXME:
 214     # no doubt this is grossly inefficient and
 215     # could be done much easier and faster in XS
 216
 217     my ($scalar_desc, $array_desc, $hash_desc, $code_desc) = (
 218         { sigil => '$', type => 'SCALAR', name => $name },
 219         { sigil => '@', type => 'ARRAY',  name => $name },
 220         { sigil => '%', type => 'HASH',   name => $name },
 221         { sigil => '&', type => 'CODE',   name => $name },
 222     );
 223
 224     my ($scalar, $array, $hash, $code);
 225     if ($type eq 'SCALAR') {
 226         $array  = $self->get_package_symbol($array_desc)  if $self->has_package_symbol($array_desc);
 227         $hash   = $self->get_package_symbol($hash_desc)   if $self->has_package_symbol($hash_desc);
 228         $code   = $self->get_package_symbol($code_desc)   if $self->has_package_symbol($code_desc);
 229     }
 230     elsif ($type eq 'ARRAY') {
 231         $scalar = $self->get_package_symbol($scalar_desc) if $self->has_package_symbol($scalar_desc);
 232         $hash   = $self->get_package_symbol($hash_desc)   if $self->has_package_symbol($hash_desc);
 233         $code   = $self->get_package_symbol($code_desc)   if $self->has_package_symbol($code_desc);
 234     }
 235     elsif ($type eq 'HASH') {
 236         $scalar = $self->get_package_symbol($scalar_desc) if $self->has_package_symbol($scalar_desc);
 237         $array  = $self->get_package_symbol($array_desc)  if $self->has_package_symbol($array_desc);
 238         $code   = $self->get_package_symbol($code_desc)   if $self->has_package_symbol($code_desc);
 239     }
 240     elsif ($type eq 'CODE') {
 241         $scalar = $self->get_package_symbol($scalar_desc) if $self->has_package_symbol($scalar_desc);
 242         $array  = $self->get_package_symbol($array_desc)  if $self->has_package_symbol($array_desc);
 243         $hash   = $self->get_package_symbol($hash_desc)   if $self->has_package_symbol($hash_desc);
 244     }
 245     else {
 246         confess "This should never ever ever happen";
 247     }
 248
 249     $self->remove_package_glob($name);
 250
 251     $self->add_package_symbol($scalar_desc => $scalar) if defined $scalar;
 252     $self->add_package_symbol($array_desc  => $array)  if defined $array;
 253     $self->add_package_symbol($hash_desc   => $hash)   if defined $hash;
 254     $self->add_package_symbol($code_desc   => $code)   if defined $code;
 255 }
 256
 257 sub list_all_package_symbols {
 258     my ($self, $type_filter) = @_;
 259
 260     my $namespace = $self->namespace;
 261     return keys %{$namespace} unless defined $type_filter;
 262
 263     # NOTE:
 264     # or we can filter based on
 265     # type (SCALAR|ARRAY|HASH|CODE)
 266     if ( $type_filter eq 'CODE' ) {
 267         return grep {
 268         (ref($namespace->{$_})
 269                 ? (ref($namespace->{$_}) eq 'SCALAR')
 270                 : (ref(\$namespace->{$_}) eq 'GLOB'
 271                    && defined(*{$namespace->{$_}}{CODE})));
 272         } keys %{$namespace};
 273     } else {
 274         return grep { *{$namespace->{$_}}{$type_filter} } keys %{$namespace};
 275     }
 276 }
 277
 278 sub get_all_package_symbols {
 279     my ($self, $type_filter) = @_;
 280
 281     die "Cannot call get_all_package_symbols as a class method"
 282         unless ref $self;
 283
 284     my $namespace = $self->namespace;
 285
 286     if (wantarray) {
 287         warn 'Class::MOP::Package::get_all_package_symbols in list context is deprecated. use scalar context instead.';
 288     }
 289
 290     return (wantarray ? %$namespace : $namespace) unless defined $type_filter;
 291
 292     my %ret;
 293     # for some reason this nasty impl is orders of magnitude faster than a clean version
 294     if ( $type_filter eq 'CODE' ) {
 295         my $pkg;
 296         no strict 'refs';
 297         %ret = map {
 298             (ref($namespace->{$_})
 299                 ? ( $_ => \&{$pkg ||= $self->name . "::$_"} )
 300                 : ( ref \$namespace->{$_} eq 'GLOB' # don't use {CODE} unless it's really a glob to prevent stringification of stubs
 301                     && (*{$namespace->{$_}}{CODE})  # the extra parents prevent breakage on 5.8.2
 302                     ? ( $_ => *{$namespace->{$_}}{CODE} )
 303                     : (do {
 304                         my $sym = B::svref_2object(\$namespace->{$_});
 305                         my $svt = ref $sym if $sym;
 306                         ($sym && ($svt eq 'B::PV' || $svt eq 'B::IV'))
 307                             ? ($_ => ($pkg ||= $self->name)->can($_))
 308                             : () }) ) )
 309         } keys %$namespace;
 310     } else {
 311         %ret = map {
 312             $_ => *{$namespace->{$_}}{$type_filter}
 313         } grep {
 314             !ref($namespace->{$_}) && *{$namespace->{$_}}{$type_filter}
 315         } keys %$namespace;
 316     }
 317
 318     return wantarray ? %ret : \%ret;
 319 }
 320
 321 1;
 322
 323 __END__
 324
 325 =pod
 326
 327 =head1 NAME
 328
 329 Class::MOP::Package - Package Meta Object
 330
 331 =head1 DESCRIPTION
 332
 333 This is an abstraction of a Perl 5 package, it is a superclass of
 334 L<Class::MOP::Class> and provides all of the symbol table
 335 introspection methods.
 336
 337 =head1 METHODS
 338
 339 =over 4
 340
 341 =item B<meta>
 342
 343 Returns a metaclass for this package.
 344
 345 =item B<initialize ($package_name)>
 346
 347 This will initialize a Class::MOP::Package instance which represents
 348 the package of C<$package_name>.
 349
 350 =item B<reinitialize ($package_name, %options)>
 351
 352 This removes the old metaclass, and creates a new one in it's place.
 353 Do B<not> use this unless you really know what you are doing, it could
 354 very easily make a very large mess of your program.
 355
 356 =item B<name>
 357
 358 This is a read-only attribute which returns the package name for the
 359 given instance.
 360
 361 =item B<namespace>
 362
 363 This returns a HASH reference to the symbol table. The keys of the
 364 HASH are the symbol names, and the values are typeglob references.
 365
 366 =item B<add_package_symbol ($variable_name, ?$initial_value)>
 367
 368 Given a C<$variable_name>, which must contain a leading sigil, this
 369 method will create that variable within the package which houses the
 370 class. It also takes an optional C<$initial_value>, which must be a
 371 reference of the same type as the sigil of the C<$variable_name>
 372 implies.
 373
 374 =item B<get_package_symbol ($variable_name)>
 375
 376 This will return a reference to the package variable in
 377 C<$variable_name>.
 378
 379 =item B<has_package_symbol ($variable_name)>
 380
 381 Returns true (C<1>) if there is a package variable defined for
 382 C<$variable_name>, and false (C<0>) otherwise.
 383
 384 =item B<remove_package_symbol ($variable_name)>
 385
 386 This will attempt to remove the package variable at C<$variable_name>.
 387
 388 =item B<remove_package_glob ($glob_name)>
 389
 390 This will attempt to remove the entire typeglob associated with
 391 C<$glob_name> from the package.
 392
 393 =item B<list_all_package_symbols (?$type_filter)>
 394
 395 This will list all the glob names associated with the current package.
 396 By inspecting the globs returned you can discern all the variables in
 397 the package.
 398
 399 By passing a C<$type_filter>, you can limit the list to only those
 400 which match the filter (either SCALAR, ARRAY, HASH or CODE).
 401
 402 =item B<get_all_package_symbols (?$type_filter)>
 403
 404 Works exactly like C<list_all_package_symbols> but returns a HASH of
 405 name => thing mapping instead of just an ARRAY of names.
 406
 407 =back
 408
 409 =head1 AUTHORS
 410
 411 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 412
 413 =head1 COPYRIGHT AND LICENSE
 414
 415 Copyright 2006-2008 by Infinity Interactive, Inc.
 416
 417 L<http://www.iinteractive.com>
 418
 419 This library is free software; you can redistribute it and/or modify
 420 it under the same terms as Perl itself.
 421
 422 =cut