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