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