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     return bless { '$:package' => $package_name } => $class;
  27 }
  28
  29 # Attributes
  30
  31 # NOTE:
  32 # all these attribute readers will be bootstrapped
  33 # away in the Class::MOP bootstrap section
  34
  35 sub name { $_[0]->{'$:package'} }
  36
  37 # Class attributes
  38
  39 {
  40     my %SIGIL_MAP = (
  41         '$' => 'SCALAR',
  42         '@' => 'ARRAY',
  43         '%' => 'HASH',
  44         '&' => 'CODE',
  45     );
  46
  47     sub add_package_symbol {
  48         my ($self, $variable, $initial_value) = @_;
  49
  50         (defined $variable)
  51             || confess "You must pass a variable name";
  52
  53         my ($sigil, $name) = ($variable =~ /^(.)(.*)$/);
  54
  55         (defined $sigil)
  56             || confess "The variable name must include a sigil";
  57
  58         (exists $SIGIL_MAP{$sigil})
  59             || confess "I do not recognize that sigil '$sigil'";
  60
  61         no strict 'refs';
  62         no warnings 'misc', 'redefine';
  63         *{$self->name . '::' . $name} = $initial_value;
  64     }
  65
  66     sub has_package_symbol {
  67         my ($self, $variable) = @_;
  68         (defined $variable)
  69             || confess "You must pass a variable name";
  70
  71         my ($sigil, $name) = ($variable =~ /^(.)(.*)$/);
  72
  73         (defined $sigil)
  74             || confess "The variable name must include a sigil";
  75
  76         (exists $SIGIL_MAP{$sigil})
  77             || confess "I do not recognize that sigil '$sigil'";
  78
  79         no strict 'refs';
  80         defined *{$self->name . '::' . $name}{$SIGIL_MAP{$sigil}} ? 1 : 0;
  81
  82     }
  83
  84     sub get_package_symbol {
  85         my ($self, $variable) = @_;
  86         (defined $variable)
  87             || confess "You must pass a variable name";
  88
  89         my ($sigil, $name) = ($variable =~ /^(.)(.*)$/);
  90
  91         (defined $sigil)
  92             || confess "The variable name must include a sigil";
  93
  94         (exists $SIGIL_MAP{$sigil})
  95             || confess "I do not recognize that sigil '$sigil'";
  96
  97         no strict 'refs';
  98         return *{$self->name . '::' . $name}{$SIGIL_MAP{$sigil}};
  99
 100     }
 101
 102     sub remove_package_symbol {
 103         my ($self, $variable) = @_;
 104
 105         (defined $variable)
 106             || confess "You must pass a variable name";
 107
 108         my ($sigil, $name) = ($variable =~ /^(.)(.*)$/);
 109
 110         (defined $sigil)
 111             || confess "The variable name must include a sigil";
 112
 113         (exists $SIGIL_MAP{$sigil})
 114             || confess "I do not recognize that sigil '$sigil'";
 115
 116         no strict 'refs';
 117         if ($SIGIL_MAP{$sigil} eq 'SCALAR') {
 118             undef ${$self->name . '::' . $name};
 119         }
 120         elsif ($SIGIL_MAP{$sigil} eq 'ARRAY') {
 121             undef @{$self->name . '::' . $name};
 122         }
 123         elsif ($SIGIL_MAP{$sigil} eq 'HASH') {
 124             undef %{$self->name . '::' . $name};
 125         }
 126         elsif ($SIGIL_MAP{$sigil} eq 'CODE') {
 127             # FIXME:
 128             # this is crap, it is probably much
 129             # easier to write this in XS.
 130             my ($scalar, @array, %hash);
 131             $scalar = ${$self->name . '::' . $name} if defined *{$self->name . '::' . $name}{SCALAR};
 132             @array  = @{$self->name . '::' . $name} if defined *{$self->name . '::' . $name}{ARRAY};
 133             %hash   = %{$self->name . '::' . $name} if defined *{$self->name . '::' . $name}{HASH};
 134             delete ${$self->name . '::'}{$name};
 135             ${$self->name . '::' . $name} = $scalar if defined $scalar;
 136             @{$self->name . '::' . $name} = @array  if scalar  @array;
 137             %{$self->name . '::' . $name} = %hash   if keys    %hash;
 138         }
 139         else {
 140             confess "This should never ever ever happen";
 141         }
 142     }
 143
 144 }
 145
 146 sub list_all_package_symbols {
 147     my ($self) = @_;
 148     no strict 'refs';
 149     return keys %{$self->name . '::'};
 150 }
 151
 152 1;
 153
 154 __END__
 155
 156 =pod
 157
 158 =head1 NAME
 159
 160 Class::MOP::Package - Package Meta Object
 161
 162 =head1 SYNOPSIS
 163
 164 =head1 DESCRIPTION
 165
 166 =head1 METHODS
 167
 168 =over 4
 169
 170 =item B<meta>
 171
 172 =item B<initialize>
 173
 174 =item B<name>
 175
 176 =item B<add_package_symbol>
 177
 178 =item B<get_package_symbol>
 179
 180 =item B<has_package_symbol>
 181
 182 =item B<remove_package_symbol>
 183
 184 =item B<list_all_package_symbols>
 185
 186 =back
 187
 188 =head1 AUTHORS
 189
 190 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 191
 192 Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
 193
 194 =head1 COPYRIGHT AND LICENSE
 195
 196 Copyright 2006 by Infinity Interactive, Inc.
 197
 198 L<http://www.iinteractive.com>
 199
 200 This library is free software; you can redistribute it and/or modify
 201 it under the same terms as Perl itself.
 202
 203 =cut