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