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