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 use Symbol       'gensym';
  10
  11 our $VERSION = '0.02';
  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 sub add_package_symbol {
  74     my ($self, $variable, $initial_value) = @_;
  75
  76     my ($name, $sigil, $type) = $self->_deconstruct_variable_name($variable);
  77
  78
  79     no strict 'refs';
  80     no warnings 'redefine', 'misc';
  81     *{$self->name . '::' . $name} = $initial_value;
  82 }
  83
  84 sub has_package_symbol {
  85     my ($self, $variable) = @_;
  86
  87     my ($name, $sigil, $type) = $self->_deconstruct_variable_name($variable);
  88
  89     return 0 unless exists $self->namespace->{$name};
  90     defined *{$self->namespace->{$name}}{$type} ? 1 : 0;
  91 }
  92
  93 sub get_package_symbol {
  94     my ($self, $variable) = @_;
  95
  96     my ($name, $sigil, $type) = $self->_deconstruct_variable_name($variable);
  97
  98     $self->add_package_symbol($variable)
  99         unless exists $self->namespace->{$name};
 100     return *{$self->namespace->{$name}}{$type};
 101 }
 102
 103 sub remove_package_symbol {
 104     my ($self, $variable) = @_;
 105
 106     my ($name, $sigil, $type) = $self->_deconstruct_variable_name($variable);
 107
 108     no strict 'refs';
 109     if ($type eq 'SCALAR') {
 110         undef ${$self->name . '::' . $name};
 111     }
 112     elsif ($type eq 'ARRAY') {
 113         undef @{$self->name . '::' . $name};
 114     }
 115     elsif ($type eq 'HASH') {
 116         undef %{$self->name . '::' . $name};
 117     }
 118     elsif ($type eq 'CODE') {
 119         # FIXME:
 120         # this is crap, it is probably much
 121         # easier to write this in XS.
 122         my ($scalar, @array, %hash);
 123         $scalar = ${$self->name . '::' . $name} if defined *{$self->namespace->{$name}}{SCALAR};
 124         @array  = @{$self->name . '::' . $name} if defined *{$self->namespace->{$name}}{ARRAY};
 125         %hash   = %{$self->name . '::' . $name} if defined *{$self->namespace->{$name}}{HASH};
 126
 127         delete ${$self->name . '::'}{$name};
 128
 129         ${$self->name . '::' . $name} = $scalar if defined $scalar;
 130         @{$self->name . '::' . $name} = @array  if scalar  @array;
 131         %{$self->name . '::' . $name} = %hash   if keys    %hash;
 132     }
 133     else {
 134         confess "This should never ever ever happen";
 135     }
 136 }
 137
 138 sub list_all_package_symbols {
 139     my ($self) = @_;
 140     return keys %{$self->namespace};
 141 }
 142
 143 1;
 144
 145 __END__
 146
 147 =pod
 148
 149 =head1 NAME
 150
 151 Class::MOP::Package - Package Meta Object
 152
 153 =head1 SYNOPSIS
 154
 155 =head1 DESCRIPTION
 156
 157 =head1 METHODS
 158
 159 =over 4
 160
 161 =item B<meta>
 162
 163 =item B<initialize>
 164
 165 =item B<name>
 166
 167 =item B<namespace>
 168
 169 =item B<add_package_symbol>
 170
 171 =item B<get_package_symbol>
 172
 173 =item B<has_package_symbol>
 174
 175 =item B<remove_package_symbol>
 176
 177 =item B<list_all_package_symbols>
 178
 179 =back
 180
 181 =head1 AUTHORS
 182
 183 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 184
 185 Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
 186
 187 =head1 COPYRIGHT AND LICENSE
 188
 189 Copyright 2006 by Infinity Interactive, Inc.
 190
 191 L<http://www.iinteractive.com>
 192
 193 This library is free software; you can redistribute it and/or modify
 194 it under the same terms as Perl itself.
 195
 196 =cut