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     defined *{$self->namespace->{$name}}{$type} ? 1 : 0;
  99 }
 100
 101 sub get_package_symbol {
 102     my ($self, $variable) = @_;
 103
 104     my ($name, $sigil, $type) = $self->_deconstruct_variable_name($variable);
 105
 106     $self->add_package_symbol($variable)
 107         unless exists $self->namespace->{$name};
 108     return *{$self->namespace->{$name}}{$type};
 109 }
 110
 111 sub remove_package_symbol {
 112     my ($self, $variable) = @_;
 113
 114     my ($name, $sigil, $type) = $self->_deconstruct_variable_name($variable);
 115
 116     # FIXME:
 117     # no doubt this is grossly inefficient and
 118     # could be done much easier and faster in XS
 119
 120     my ($scalar, $array, $hash, $code);
 121     if ($type eq 'SCALAR') {
 122         $array  = $self->get_package_symbol('@' . $name) if $self->has_package_symbol('@' . $name);
 123         $hash   = $self->get_package_symbol('%' . $name) if $self->has_package_symbol('%' . $name);
 124         $code   = $self->get_package_symbol('&' . $name) if $self->has_package_symbol('&' . $name);
 125     }
 126     elsif ($type eq 'ARRAY') {
 127         $scalar = $self->get_package_symbol('$' . $name) if $self->has_package_symbol('$' . $name);
 128         $hash   = $self->get_package_symbol('%' . $name) if $self->has_package_symbol('%' . $name);
 129         $code   = $self->get_package_symbol('&' . $name) if $self->has_package_symbol('&' . $name);
 130     }
 131     elsif ($type eq 'HASH') {
 132         $scalar = $self->get_package_symbol('$' . $name) if $self->has_package_symbol('$' . $name);
 133         $array  = $self->get_package_symbol('@' . $name) if $self->has_package_symbol('@' . $name);
 134         $code   = $self->get_package_symbol('&' . $name) if $self->has_package_symbol('&' . $name);
 135     }
 136     elsif ($type eq 'CODE') {
 137         $scalar = $self->get_package_symbol('$' . $name) if $self->has_package_symbol('$' . $name);
 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     }
 141     else {
 142         confess "This should never ever ever happen";
 143     }
 144
 145     $self->remove_package_glob($name);
 146
 147     $self->add_package_symbol(('$' . $name) => $scalar) if defined $scalar;
 148     $self->add_package_symbol(('@' . $name) => $array)  if defined $array;
 149     $self->add_package_symbol(('%' . $name) => $hash)   if defined $hash;
 150     $self->add_package_symbol(('&' . $name) => $code)   if defined $code;
 151 }
 152
 153 sub list_all_package_symbols {
 154     my ($self) = @_;
 155     return keys %{$self->namespace};
 156 }
 157
 158 1;
 159
 160 __END__
 161
 162 =pod
 163
 164 =head1 NAME
 165
 166 Class::MOP::Package - Package Meta Object
 167
 168 =head1 SYNOPSIS
 169
 170 =head1 DESCRIPTION
 171
 172 =head1 METHODS
 173
 174 =over 4
 175
 176 =item B<meta>
 177
 178 =item B<initialize>
 179
 180 =item B<name>
 181
 182 =item B<namespace>
 183
 184 =item B<add_package_symbol>
 185
 186 =item B<get_package_symbol>
 187
 188 =item B<has_package_symbol>
 189
 190 =item B<remove_package_symbol>
 191
 192 =item B<remove_package_glob>
 193
 194 =item B<list_all_package_symbols>
 195
 196 =back
 197
 198 =head1 AUTHORS
 199
 200 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 201
 202 Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
 203
 204 =head1 COPYRIGHT AND LICENSE
 205
 206 Copyright 2006 by Infinity Interactive, Inc.
 207
 208 L<http://www.iinteractive.com>
 209
 210 This library is free software; you can redistribute it and/or modify
 211 it under the same terms as Perl itself.
 212
 213 =cut