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