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