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