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