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