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