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';
   8 use Carp         'confess';
   9 use Package::Stash;
  10
  11 our $AUTHORITY = 'cpan:STEVAN';
  12
  13 use base 'Class::MOP::Object';
  14
  15 # creation ...
  16
  17 sub initialize {
  18     my ( $class, @args ) = @_;
  19
  20     unshift @args, "package" if @args % 2;
  21
  22     my %options = @args;
  23     my $package_name = $options{package};
  24
  25
  26     # we hand-construct the class
  27     # until we can bootstrap it
  28     if ( my $meta = Class::MOP::get_metaclass_by_name($package_name) ) {
  29         return $meta;
  30     } else {
  31         my $meta = ( ref $class || $class )->_new({
  32             'package'   => $package_name,
  33             %options,
  34         });
  35         Class::MOP::store_metaclass_by_name($package_name, $meta);
  36
  37         return $meta;
  38     }
  39 }
  40
  41 sub reinitialize {
  42     my ( $class, @args ) = @_;
  43
  44     unshift @args, "package" if @args % 2;
  45
  46     my %options = @args;
  47     my $package_name = delete $options{package};
  48
  49     (defined $package_name && $package_name
  50       && (!blessed $package_name || $package_name->isa('Class::MOP::Package')))
  51         || confess "You must pass a package name or an existing Class::MOP::Package instance";
  52
  53     $package_name = $package_name->name
  54         if blessed $package_name;
  55
  56     Class::MOP::remove_metaclass_by_name($package_name);
  57
  58     $class->initialize($package_name, %options); # call with first arg form for compat
  59 }
  60
  61 sub _new {
  62     my $class = shift;
  63
  64     return Class::MOP::Class->initialize($class)->new_object(@_)
  65         if $class ne __PACKAGE__;
  66
  67     my $params = @_ == 1 ? $_[0] : {@_};
  68
  69     return bless {
  70         package   => $params->{package},
  71
  72         # NOTE:
  73         # because of issues with the Perl API
  74         # to the typeglob in some versions, we
  75         # need to just always grab a new
  76         # reference to the hash in the accessor.
  77         # Ideally we could just store a ref and
  78         # it would Just Work, but oh well :\
  79
  80         namespace => \undef,
  81
  82     } => $class;
  83 }
  84
  85 # Attributes
  86
  87 # NOTE:
  88 # all these attribute readers will be bootstrapped
  89 # away in the Class::MOP bootstrap section
  90
  91 sub _package_stash {
  92     $_[0]->{_package_stash} ||= Package::Stash->new($_[0]->name)
  93 }
  94 sub namespace {
  95     $_[0]->_package_stash->namespace
  96 }
  97
  98 # Class attributes
  99
 100 # ... these functions have to touch the symbol table itself,.. yuk
 101
 102 sub add_package_symbol {
 103     my $self = shift;
 104     $self->_package_stash->add_symbol(@_);
 105 }
 106
 107 sub remove_package_glob {
 108     my $self = shift;
 109     $self->_package_stash->remove_glob(@_);
 110 }
 111
 112 # ... these functions deal with stuff on the namespace level
 113
 114 sub has_package_symbol {
 115     my $self = shift;
 116     $self->_package_stash->has_symbol(@_);
 117 }
 118
 119 sub get_package_symbol {
 120     my $self = shift;
 121     $self->_package_stash->get_symbol(@_);
 122 }
 123
 124 sub get_or_add_package_symbol {
 125     my $self = shift;
 126     $self->_package_stash->get_or_add_symbol(@_);
 127 }
 128
 129 sub remove_package_symbol {
 130     my $self = shift;
 131     $self->_package_stash->remove_symbol(@_);
 132 }
 133
 134 sub list_all_package_symbols {
 135     my $self = shift;
 136     $self->_package_stash->list_all_symbols(@_);
 137 }
 138
 139 sub get_all_package_symbols {
 140     my $self = shift;
 141     $self->_package_stash->get_all_symbols(@_);
 142 }
 143
 144 1;
 145
 146 # ABSTRACT: Package Meta Object
 147
 148 __END__
 149
 150 =pod
 151
 152 =head1 DESCRIPTION
 153
 154 The Package Protocol provides an abstraction of a Perl 5 package. A
 155 package is basically namespace, and this module provides methods for
 156 looking at and changing that namespace's symbol table.
 157
 158 =head1 METHODS
 159
 160 =over 4
 161
 162 =item B<< Class::MOP::Package->initialize($package_name) >>
 163
 164 This method creates a new C<Class::MOP::Package> instance which
 165 represents specified package. If an existing metaclass object exists
 166 for the package, that will be returned instead.
 167
 168 =item B<< Class::MOP::Package->reinitialize($package) >>
 169
 170 This method forcibly removes any existing metaclass for the package
 171 before calling C<initialize>. In contrast to C<initialize>, you may
 172 also pass an existing C<Class::MOP::Package> instance instead of just
 173 a package name as C<$package>.
 174
 175 Do not call this unless you know what you are doing.
 176
 177 =item B<< $metapackage->name >>
 178
 179 This is returns the package's name, as passed to the constructor.
 180
 181 =item B<< $metapackage->namespace >>
 182
 183 This returns a hash reference to the package's symbol table. The keys
 184 are symbol names and the values are typeglob references.
 185
 186 =item B<< $metapackage->add_package_symbol($variable_name, $initial_value) >>
 187
 188 This method accepts a variable name and an optional initial value. The
 189 C<$variable_name> must contain a leading sigil.
 190
 191 This method creates the variable in the package's symbol table, and
 192 sets it to the initial value if one was provided.
 193
 194 =item B<< $metapackage->get_package_symbol($variable_name) >>
 195
 196 Given a variable name, this method returns the variable as a reference
 197 or undef if it does not exist. The C<$variable_name> must contain a
 198 leading sigil.
 199
 200 =item B<< $metapackage->get_or_add_package_symbol($variable_name) >>
 201
 202 Given a variable name, this method returns the variable as a reference.
 203 If it does not exist, a default value will be generated if possible. The
 204 C<$variable_name> must contain a leading sigil.
 205
 206 =item B<< $metapackage->has_package_symbol($variable_name) >>
 207
 208 Returns true if there is a package variable defined for
 209 C<$variable_name>. The C<$variable_name> must contain a leading sigil.
 210
 211 =item B<< $metapackage->remove_package_symbol($variable_name) >>
 212
 213 This will remove the package variable specified C<$variable_name>. The
 214 C<$variable_name> must contain a leading sigil.
 215
 216 =item B<< $metapackage->remove_package_glob($glob_name) >>
 217
 218 Given the name of a glob, this will remove that glob from the
 219 package's symbol table. Glob names do not include a sigil. Removing
 220 the glob removes all variables and subroutines with the specified
 221 name.
 222
 223 =item B<< $metapackage->list_all_package_symbols($type_filter) >>
 224
 225 This will list all the glob names associated with the current
 226 package. These names do not have leading sigils.
 227
 228 You can provide an optional type filter, which should be one of
 229 'SCALAR', 'ARRAY', 'HASH', or 'CODE'.
 230
 231 =item B<< $metapackage->get_all_package_symbols($type_filter) >>
 232
 233 This works much like C<list_all_package_symbols>, but it returns a
 234 hash reference. The keys are glob names and the values are references
 235 to the value for that name.
 236
 237 =item B<< Class::MOP::Package->meta >>
 238
 239 This will return a L<Class::MOP::Class> instance for this class.
 240
 241 =back
 242
 243 =cut