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>
 198
 199 =item B<name>
 200
 201 =item B<namespace>
 202
 203 =item B<add_package_symbol>
 204
 205 =item B<get_package_symbol>
 206
 207 =item B<has_package_symbol>
 208
 209 =item B<remove_package_symbol>
 210
 211 =item B<remove_package_glob>
 212
 213 =item B<list_all_package_symbols>
 214
 215 =back
 216
 217 =head1 AUTHORS
 218
 219 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 220
 221 Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
 222
 223 =head1 COPYRIGHT AND LICENSE
 224
 225 Copyright 2006 by Infinity Interactive, Inc.
 226
 227 L<http://www.iinteractive.com>
 228
 229 This library is free software; you can redistribute it and/or modify
 230 it under the same terms as Perl itself.
 231
 232 =cut