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