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