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