lib/Class/MOP/Package.pm

   1
   2 package Class::MOP::Package;
   3
   4 use strict;
   5 use warnings;
   6
   7 use Scalar::Util 'blessed', 'reftype', 'weaken';
   8 use Carp         'confess';
   9 use Devel::GlobalDestruction 'in_global_destruction';
  10 use Package::Stash;
  11
  12 use base 'Class::MOP::Object';
  13
  14 # creation ...
  15
  16 sub initialize {
  17     my ( $class, @args ) = @_;
  18
  19     unshift @args, "package" if @args % 2;
  20
  21     my %options = @args;
  22     my $package_name = delete $options{package};
  23
  24
  25     # we hand-construct the class
  26     # until we can bootstrap it
  27     if ( my $meta = Class::MOP::get_metaclass_by_name($package_name) ) {
  28         return $meta;
  29     } else {
  30         my $meta = ( ref $class || $class )->_new({
  31             'package'   => $package_name,
  32             %options,
  33         });
  34         Class::MOP::store_metaclass_by_name($package_name, $meta);
  35
  36         Class::MOP::weaken_metaclass($package_name) if $options{weaken};
  37
  38
  39         return $meta;
  40     }
  41 }
  42
  43 sub reinitialize {
  44     my ( $class, @args ) = @_;
  45
  46     unshift @args, "package" if @args % 2;
  47
  48     my %options = @args;
  49     my $package_name = delete $options{package};
  50
  51     (defined $package_name && $package_name
  52       && (!blessed $package_name || $package_name->isa('Class::MOP::Package')))
  53         || confess "You must pass a package name or an existing Class::MOP::Package instance";
  54
  55     $package_name = $package_name->name
  56         if blessed $package_name;
  57
  58     Class::MOP::remove_metaclass_by_name($package_name);
  59
  60     $class->initialize($package_name, %options); # call with first arg form for compat
  61 }
  62
  63 sub create {
  64     my $class = shift;
  65     my @args = @_;
  66
  67     return $class->initialize(@args);
  68 }
  69
  70 ## ANON packages
  71
  72 {
  73     # NOTE:
  74     # this should be sufficient, if you have a
  75     # use case where it is not, write a test and
  76     # I will change it.
  77     my $ANON_SERIAL = 0;
  78
  79     my %ANON_PACKAGE_CACHE;
  80
  81     # NOTE:
  82     # we need a sufficiently annoying prefix
  83     # this should suffice for now, this is
  84     # used in a couple of places below, so
  85     # need to put it up here for now.
  86     sub _anon_package_prefix { 'Class::MOP::Package::__ANON__::SERIAL::' }
  87
  88     sub is_anon {
  89         my $self = shift;
  90         no warnings 'uninitialized';
  91         my $prefix = $self->_anon_package_prefix;
  92         $self->name =~ /^\Q$prefix/;
  93     }
  94
  95     sub create_anon {
  96         my ($class, %options) = @_;
  97
  98         my $cache_ok = delete $options{cache};
  99         $options{weaken} = !$cache_ok unless exists $options{weaken};
 100
 101         my $cache_key;
 102         if ($cache_ok) {
 103             $cache_key = $class->_anon_cache_key(%options);
 104             undef $cache_ok if !defined($cache_key);
 105         }
 106
 107         if ($cache_ok) {
 108             if (defined $ANON_PACKAGE_CACHE{$cache_key}) {
 109                 return $ANON_PACKAGE_CACHE{$cache_key};
 110             }
 111         }
 112
 113         my $package_name = $class->_anon_package_prefix . ++$ANON_SERIAL;
 114
 115         my $meta = $class->create($package_name, %options);
 116
 117         if ($cache_ok) {
 118             $ANON_PACKAGE_CACHE{$cache_key} = $meta;
 119             weaken($ANON_PACKAGE_CACHE{$cache_key});
 120         }
 121
 122         return $meta;
 123     }
 124
 125     sub _anon_cache_key { confess "Packages are not cacheable" }
 126
 127     sub DESTROY {
 128         my $self = shift;
 129
 130         return if in_global_destruction(); # it'll happen soon anyway and this just makes things more complicated
 131
 132         $self->_free_anon
 133             if $self->is_anon;
 134     }
 135
 136     sub _free_anon {
 137         my $self = shift;
 138         my $name = $self->name;
 139
 140         # Moose does a weird thing where it replaces the metaclass for
 141         # class when fixing metaclass incompatibility. In that case,
 142         # we don't want to clean out the namespace now. We can detect
 143         # that because Moose will explicitly update the singleton
 144         # cache in Class::MOP.
 145         no warnings 'uninitialized';
 146         my $current_meta = Class::MOP::get_metaclass_by_name($name);
 147         return if $current_meta ne $self;
 148
 149         my ($first_fragments, $last_fragment) = ($name =~ /^(.*)::(.*)$/);
 150
 151         no strict 'refs';
 152         @{$name . '::ISA'} = ();
 153         %{$name . '::'}    = ();
 154         delete ${$first_fragments . '::'}{$last_fragment . '::'};
 155
 156         Class::MOP::remove_metaclass_by_name($name);
 157     }
 158
 159 }
 160
 161 sub _new {
 162     my $class = shift;
 163
 164     return Class::MOP::Class->initialize($class)->new_object(@_)
 165         if $class ne __PACKAGE__;
 166
 167     my $params = @_ == 1 ? $_[0] : {@_};
 168
 169     return bless {
 170         # Need to quote package to avoid a problem with PPI mis-parsing this
 171         # as a package statement.
 172         'package' => $params->{package},
 173
 174         # NOTE:
 175         # because of issues with the Perl API
 176         # to the typeglob in some versions, we
 177         # need to just always grab a new
 178         # reference to the hash in the accessor.
 179         # Ideally we could just store a ref and
 180         # it would Just Work, but oh well :\
 181
 182         namespace => \undef,
 183
 184     } => $class;
 185 }
 186
 187 # Attributes
 188
 189 # NOTE:
 190 # all these attribute readers will be bootstrapped
 191 # away in the Class::MOP bootstrap section
 192
 193 sub _package_stash {
 194     $_[0]->{_package_stash} ||= Package::Stash->new($_[0]->name)
 195 }
 196 sub namespace {
 197     $_[0]->_package_stash->namespace
 198 }
 199
 200 # Class attributes
 201
 202 # ... these functions have to touch the symbol table itself,.. yuk
 203
 204 sub add_package_symbol {
 205     my $self = shift;
 206     $self->_package_stash->add_symbol(@_);
 207 }
 208
 209 sub remove_package_glob {
 210     my $self = shift;
 211     $self->_package_stash->remove_glob(@_);
 212 }
 213
 214 # ... these functions deal with stuff on the namespace level
 215
 216 sub has_package_symbol {
 217     my $self = shift;
 218     $self->_package_stash->has_symbol(@_);
 219 }
 220
 221 sub get_package_symbol {
 222     my $self = shift;
 223     $self->_package_stash->get_symbol(@_);
 224 }
 225
 226 sub get_or_add_package_symbol {
 227     my $self = shift;
 228     $self->_package_stash->get_or_add_symbol(@_);
 229 }
 230
 231 sub remove_package_symbol {
 232     my $self = shift;
 233     $self->_package_stash->remove_symbol(@_);
 234 }
 235
 236 sub list_all_package_symbols {
 237     my $self = shift;
 238     $self->_package_stash->list_all_symbols(@_);
 239 }
 240
 241 sub get_all_package_symbols {
 242     my $self = shift;
 243     $self->_package_stash->get_all_symbols(@_);
 244 }
 245
 246 1;
 247
 248 # ABSTRACT: Package Meta Object
 249
 250 __END__
 251
 252 =pod
 253
 254 =head1 DESCRIPTION
 255
 256 The Package Protocol provides an abstraction of a Perl 5 package. A
 257 package is basically namespace, and this module provides methods for
 258 looking at and changing that namespace's symbol table.
 259
 260 =head1 METHODS
 261
 262 =over 4
 263
 264 =item B<< Class::MOP::Package->initialize($package_name, %options) >>
 265
 266 This method creates a new C<Class::MOP::Package> instance which
 267 represents specified package. If an existing metaclass object exists
 268 for the package, that will be returned instead. No options are valid at the
 269 package level.
 270
 271 =item B<< Class::MOP::Package->reinitialize($package, %options) >>
 272
 273 This method forcibly removes any existing metaclass for the package
 274 before calling C<initialize>. In contrast to C<initialize>, you may
 275 also pass an existing C<Class::MOP::Package> instance instead of just
 276 a package name as C<$package>.
 277
 278 Do not call this unless you know what you are doing.
 279
 280 =item B<< Class::MOP::Package->create($package, %options) >>
 281
 282 Creates a new C<Class::MOP::Package> instance which represents the specified
 283 package, and also does some initialization of that package. Currently, this
 284 just does the same thing as C<initialize>, but is overridden in subclasses,
 285 such as C<Class::MOP::Class>.
 286
 287 =item B<< Class::MOP::Package->create_anon(%options) >>
 288
 289 Creates a new anonymous package. Valid keys for C<%options> are:
 290
 291 =over 4
 292
 293 =item C<weaken>
 294
 295 If this is true (the default), the instance stored in C<Class::MOP>'s metaclass
 296 cache will be weakened, so that the anonymous package will be garbage collected
 297 when the returned instance goes out of scope.
 298
 299 =back
 300
 301 =item B<< $metapackage->is_anon >>
 302
 303 Returns true if the package is an anonymous package.
 304
 305 =item B<< $metapackage->name >>
 306
 307 This is returns the package's name, as passed to the constructor.
 308
 309 =item B<< $metapackage->namespace >>
 310
 311 This returns a hash reference to the package's symbol table. The keys
 312 are symbol names and the values are typeglob references.
 313
 314 =item B<< $metapackage->add_package_symbol($variable_name, $initial_value) >>
 315
 316 This method accepts a variable name and an optional initial value. The
 317 C<$variable_name> must contain a leading sigil.
 318
 319 This method creates the variable in the package's symbol table, and
 320 sets it to the initial value if one was provided.
 321
 322 =item B<< $metapackage->get_package_symbol($variable_name) >>
 323
 324 Given a variable name, this method returns the variable as a reference
 325 or undef if it does not exist. The C<$variable_name> must contain a
 326 leading sigil.
 327
 328 =item B<< $metapackage->get_or_add_package_symbol($variable_name) >>
 329
 330 Given a variable name, this method returns the variable as a reference.
 331 If it does not exist, a default value will be generated if possible. The
 332 C<$variable_name> must contain a leading sigil.
 333
 334 =item B<< $metapackage->has_package_symbol($variable_name) >>
 335
 336 Returns true if there is a package variable defined for
 337 C<$variable_name>. The C<$variable_name> must contain a leading sigil.
 338
 339 =item B<< $metapackage->remove_package_symbol($variable_name) >>
 340
 341 This will remove the package variable specified C<$variable_name>. The
 342 C<$variable_name> must contain a leading sigil.
 343
 344 =item B<< $metapackage->remove_package_glob($glob_name) >>
 345
 346 Given the name of a glob, this will remove that glob from the
 347 package's symbol table. Glob names do not include a sigil. Removing
 348 the glob removes all variables and subroutines with the specified
 349 name.
 350
 351 =item B<< $metapackage->list_all_package_symbols($type_filter) >>
 352
 353 This will list all the glob names associated with the current
 354 package. These names do not have leading sigils.
 355
 356 You can provide an optional type filter, which should be one of
 357 'SCALAR', 'ARRAY', 'HASH', or 'CODE'.
 358
 359 =item B<< $metapackage->get_all_package_symbols($type_filter) >>
 360
 361 This works much like C<list_all_package_symbols>, but it returns a
 362 hash reference. The keys are glob names and the values are references
 363 to the value for that name.
 364
 365 =item B<< Class::MOP::Package->meta >>
 366
 367 This will return a L<Class::MOP::Class> instance for this class.
 368
 369 =back
 370
 371 =cut