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