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