lib/Class/MOP/Package.pm

   1
   2 package Class::MOP::Package;
   3
   4 use strict;
   5 use warnings;
   6
   7 use Scalar::Util 'blessed';
   8 use Carp         'confess';
   9
  10 our $VERSION   = '0.02';
  11 our $AUTHORITY = 'cpan:STEVAN';
  12
  13 use base 'Class::MOP::Object';
  14
  15 # introspection
  16
  17 sub meta {
  18     require Class::MOP::Class;
  19     Class::MOP::Class->initialize(blessed($_[0]) || $_[0]);
  20 }
  21
  22 # creation ...
  23
  24 sub initialize {
  25     my $class        = shift;
  26     my $package_name = shift;
  27     # we hand-construct the class
  28     # until we can bootstrap it
  29     no strict 'refs';
  30     return bless {
  31         '$:package'   => $package_name,
  32         '%:namespace' => \%{$package_name . '::'},
  33     } => $class;
  34 }
  35
  36 # Attributes
  37
  38 # NOTE:
  39 # all these attribute readers will be bootstrapped
  40 # away in the Class::MOP bootstrap section
  41
  42 sub name      { $_[0]->{'$:package'}   }
  43 sub namespace { $_[0]->{'%:namespace'} }
  44
  45 # utility methods
  46
  47 {
  48     my %SIGIL_MAP = (
  49         '$' => 'SCALAR',
  50         '@' => 'ARRAY',
  51         '%' => 'HASH',
  52         '&' => 'CODE',
  53     );
  54
  55     sub _deconstruct_variable_name {
  56         my ($self, $variable) = @_;
  57
  58         (defined $variable)
  59             || confess "You must pass a variable name";
  60
  61         my ($sigil, $name) = ($variable =~ /^(.)(.*)$/);
  62
  63         (defined $sigil)
  64             || confess "The variable name must include a sigil";
  65
  66         (exists $SIGIL_MAP{$sigil})
  67             || confess "I do not recognize that sigil '$sigil'";
  68
  69         return ($name, $sigil, $SIGIL_MAP{$sigil});
  70     }
  71 }
  72
  73 # Class attributes
  74
  75 # ... these functions have to touch the symbol table itself,.. yuk
  76
  77 sub add_package_symbol {
  78     my ($self, $variable, $initial_value) = @_;
  79
  80     my ($name, $sigil, $type) = $self->_deconstruct_variable_name($variable);
  81
  82     no strict 'refs';
  83     no warnings 'redefine', 'misc';
  84     *{$self->name . '::' . $name} = ref $initial_value ? $initial_value : \$initial_value;
  85 }
  86
  87 sub remove_package_glob {
  88     my ($self, $name) = @_;
  89     no strict 'refs';
  90     delete ${$self->name . '::'}{$name};
  91 }
  92
  93 # ... these functions deal with stuff on the namespace level
  94
  95 sub has_package_symbol {
  96     my ($self, $variable) = @_;
  97
  98     my ($name, $sigil, $type) = $self->_deconstruct_variable_name($variable);
  99
 100     return 0 unless exists $self->namespace->{$name};
 101
 102     # FIXME:
 103     # For some really stupid reason
 104     # a typeglob will have a default
 105     # value of \undef in the SCALAR
 106     # slot, so we need to work around
 107     # this. Which of course means that
 108     # if you put \undef in your scalar
 109     # then this is broken.
 110
 111     if ($type eq 'SCALAR') {
 112         my $val = *{$self->namespace->{$name}}{$type};
 113         defined $$val ? 1 : 0;
 114     }
 115     else {
 116         defined *{$self->namespace->{$name}}{$type} ? 1 : 0;
 117     }
 118 }
 119
 120 sub get_package_symbol {
 121     my ($self, $variable) = @_;
 122
 123     my ($name, $sigil, $type) = $self->_deconstruct_variable_name($variable);
 124
 125     $self->add_package_symbol($variable)
 126         unless exists $self->namespace->{$name};
 127     return *{$self->namespace->{$name}}{$type};
 128 }
 129
 130 sub remove_package_symbol {
 131     my ($self, $variable) = @_;
 132
 133     my ($name, $sigil, $type) = $self->_deconstruct_variable_name($variable);
 134
 135     # FIXME:
 136     # no doubt this is grossly inefficient and
 137     # could be done much easier and faster in XS
 138
 139     my ($scalar, $array, $hash, $code);
 140     if ($type eq 'SCALAR') {
 141         $array  = $self->get_package_symbol('@' . $name) if $self->has_package_symbol('@' . $name);
 142         $hash   = $self->get_package_symbol('%' . $name) if $self->has_package_symbol('%' . $name);
 143         $code   = $self->get_package_symbol('&' . $name) if $self->has_package_symbol('&' . $name);
 144     }
 145     elsif ($type eq 'ARRAY') {
 146         $scalar = $self->get_package_symbol('$' . $name) if $self->has_package_symbol('$' . $name);
 147         $hash   = $self->get_package_symbol('%' . $name) if $self->has_package_symbol('%' . $name);
 148         $code   = $self->get_package_symbol('&' . $name) if $self->has_package_symbol('&' . $name);
 149     }
 150     elsif ($type eq 'HASH') {
 151         $scalar = $self->get_package_symbol('$' . $name) if $self->has_package_symbol('$' . $name);
 152         $array  = $self->get_package_symbol('@' . $name) if $self->has_package_symbol('@' . $name);
 153         $code   = $self->get_package_symbol('&' . $name) if $self->has_package_symbol('&' . $name);
 154     }
 155     elsif ($type eq 'CODE') {
 156         $scalar = $self->get_package_symbol('$' . $name) if $self->has_package_symbol('$' . $name);
 157         $array  = $self->get_package_symbol('@' . $name) if $self->has_package_symbol('@' . $name);
 158         $hash   = $self->get_package_symbol('%' . $name) if $self->has_package_symbol('%' . $name);
 159     }
 160     else {
 161         confess "This should never ever ever happen";
 162     }
 163
 164     $self->remove_package_glob($name);
 165
 166     $self->add_package_symbol(('$' . $name) => $scalar) if defined $scalar;
 167     $self->add_package_symbol(('@' . $name) => $array)  if defined $array;
 168     $self->add_package_symbol(('%' . $name) => $hash)   if defined $hash;
 169     $self->add_package_symbol(('&' . $name) => $code)   if defined $code;
 170 }
 171
 172 sub list_all_package_symbols {
 173     my ($self) = @_;
 174     return keys %{$self->namespace};
 175 }
 176
 177 1;
 178
 179 __END__
 180
 181 =pod
 182
 183 =head1 NAME
 184
 185 Class::MOP::Package - Package Meta Object
 186
 187 =head1 SYNOPSIS
 188
 189 =head1 DESCRIPTION
 190
 191 =head1 METHODS
 192
 193 =over 4
 194
 195 =item B<meta>
 196
 197 =item B<initialize ($package_name)>
 198
 199 =item B<name>
 200
 201 This is a read-only attribute which returns the package name for the
 202 given instance.
 203
 204 =item B<namespace>
 205
 206 This returns a HASH reference to the symbol table. The keys of the
 207 HASH are the symbol names, and the values are typeglob references.
 208
 209 =item B<add_package_symbol ($variable_name, ?$initial_value)>
 210
 211 Given a C<$variable_name>, which must contain a leading sigil, this
 212 method will create that variable within the package which houses the
 213 class. It also takes an optional C<$initial_value>, which must be a
 214 reference of the same type as the sigil of the C<$variable_name>
 215 implies.
 216
 217 =item B<get_package_symbol ($variable_name)>
 218
 219 This will return a reference to the package variable in
 220 C<$variable_name>.
 221
 222 =item B<has_package_symbol ($variable_name)>
 223
 224 Returns true (C<1>) if there is a package variable defined for
 225 C<$variable_name>, and false (C<0>) otherwise.
 226
 227 =item B<remove_package_symbol ($variable_name)>
 228
 229 This will attempt to remove the package variable at C<$variable_name>.
 230
 231 =item B<remove_package_glob ($glob_name)>
 232
 233 This will attempt to remove the entire typeglob associated with
 234 C<$glob_name> from the package.
 235
 236 =item B<list_all_package_symbols>
 237
 238 This will list all the glob names associated with the current package.
 239 By inspecting the globs returned you can discern all the variables in
 240 the package.
 241
 242 =back
 243
 244 =head1 AUTHORS
 245
 246 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 247
 248 Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
 249
 250 =head1 COPYRIGHT AND LICENSE
 251
 252 Copyright 2006 by Infinity Interactive, Inc.
 253
 254 L<http://www.iinteractive.com>
 255
 256 This library is free software; you can redistribute it and/or modify
 257 it under the same terms as Perl itself.
 258
 259 =cut