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