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.67';
  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
 280     die "Cannot call get_all_package_symbols as a class method"
 281         unless ref $self;
 282
 283     my $namespace = $self->namespace;
 284
 285     return %$namespace unless defined $type_filter;
 286
 287     # for some reason this nasty impl is orders of magnitude faster than a clean version
 288     if ( $type_filter eq 'CODE' ) {
 289         my $pkg;
 290         no strict 'refs';
 291         return map {
 292             (ref($namespace->{$_})
 293                 ? ( $_ => \&{$pkg ||= $self->name . "::$_"} )
 294                 : ( (*{$namespace->{$_}}{CODE}) # the extra parents prevent breakage on 5.8.2
 295                     ? ( $_ => *{$namespace->{$_}}{CODE} )
 296                     : () ) )
 297         } keys %$namespace;
 298     } else {
 299         return map {
 300             $_ => *{$namespace->{$_}}{$type_filter}
 301         } grep {
 302             !ref($namespace->{$_}) && *{$namespace->{$_}}{$type_filter}
 303         } keys %$namespace;
 304     }
 305 }
 306
 307 1;
 308
 309 __END__
 310
 311 =pod
 312
 313 =head1 NAME
 314
 315 Class::MOP::Package - Package Meta Object
 316
 317 =head1 DESCRIPTION
 318
 319 This is an abstraction of a Perl 5 package, it is a superclass of
 320 L<Class::MOP::Class> and provides all of the symbol table
 321 introspection methods.
 322
 323 =head1 METHODS
 324
 325 =over 4
 326
 327 =item B<meta>
 328
 329 Returns a metaclass for this package.
 330
 331 =item B<initialize ($package_name)>
 332
 333 This will initialize a Class::MOP::Package instance which represents
 334 the package of C<$package_name>.
 335
 336 =item B<reinitialize ($package_name, %options)>
 337
 338 This removes the old metaclass, and creates a new one in it's place.
 339 Do B<not> use this unless you really know what you are doing, it could
 340 very easily make a very large mess of your program.
 341
 342 =item B<name>
 343
 344 This is a read-only attribute which returns the package name for the
 345 given instance.
 346
 347 =item B<namespace>
 348
 349 This returns a HASH reference to the symbol table. The keys of the
 350 HASH are the symbol names, and the values are typeglob references.
 351
 352 =item B<add_package_symbol ($variable_name, ?$initial_value)>
 353
 354 Given a C<$variable_name>, which must contain a leading sigil, this
 355 method will create that variable within the package which houses the
 356 class. It also takes an optional C<$initial_value>, which must be a
 357 reference of the same type as the sigil of the C<$variable_name>
 358 implies.
 359
 360 =item B<get_package_symbol ($variable_name)>
 361
 362 This will return a reference to the package variable in
 363 C<$variable_name>.
 364
 365 =item B<has_package_symbol ($variable_name)>
 366
 367 Returns true (C<1>) if there is a package variable defined for
 368 C<$variable_name>, and false (C<0>) otherwise.
 369
 370 =item B<remove_package_symbol ($variable_name)>
 371
 372 This will attempt to remove the package variable at C<$variable_name>.
 373
 374 =item B<remove_package_glob ($glob_name)>
 375
 376 This will attempt to remove the entire typeglob associated with
 377 C<$glob_name> from the package.
 378
 379 =item B<list_all_package_symbols (?$type_filter)>
 380
 381 This will list all the glob names associated with the current package.
 382 By inspecting the globs returned you can discern all the variables in
 383 the package.
 384
 385 By passing a C<$type_filter>, you can limit the list to only those
 386 which match the filter (either SCALAR, ARRAY, HASH or CODE).
 387
 388 =item B<get_all_package_symbols (?$type_filter)>
 389
 390 Works exactly like C<list_all_package_symbols> but returns a HASH of
 391 name => thing mapping instead of just an ARRAY of names.
 392
 393 =back
 394
 395 =head1 AUTHORS
 396
 397 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 398
 399 =head1 COPYRIGHT AND LICENSE
 400
 401 Copyright 2006-2008 by Infinity Interactive, Inc.
 402
 403 L<http://www.iinteractive.com>
 404
 405 This library is free software; you can redistribute it and/or modify
 406 it under the same terms as Perl itself.
 407
 408 =cut