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.04';
  11 our $AUTHORITY = 'cpan:STEVAN';
  12
  13 use base 'Class::MOP::Object';
  14
  15 # introspection
  16
  17 sub meta {
  18     require Class::MOP::Class;
  19     Class::MOP::Class->initialize(blessed($_[0]) || $_[0]);
  20 }
  21
  22 # creation ...
  23
  24 sub initialize {
  25     my $class        = shift;
  26     my $package_name = shift;
  27     # we hand-construct the class
  28     # until we can bootstrap it
  29     no strict 'refs';
  30     return bless {
  31         '$:package'   => $package_name,
  32         # NOTE:
  33         # because of issues with the Perl API
  34         # to the typeglob in some versions, we
  35         # need to just always grab a new
  36         # reference to the hash in the accessor.
  37         # Ideally we could just store a ref and
  38         # it would Just Work, but oh well :\
  39         '%:namespace' => \undef,
  40     } => $class;
  41 }
  42
  43 # Attributes
  44
  45 # NOTE:
  46 # all these attribute readers will be bootstrapped
  47 # away in the Class::MOP bootstrap section
  48
  49 sub name      { $_[0]->{'$:package'}   }
  50 sub namespace {
  51     # NOTE:
  52     # because of issues with the Perl API
  53     # to the typeglob in some versions, we
  54     # need to just always grab a new
  55     # reference to the hash here. Ideally
  56     # we could just store a ref and it would
  57     # Just Work, but oh well :\
  58     no strict 'refs';
  59     \%{$_[0]->name . '::'}
  60 }
  61
  62 # utility methods
  63
  64 {
  65     my %SIGIL_MAP = (
  66         '$' => 'SCALAR',
  67         '@' => 'ARRAY',
  68         '%' => 'HASH',
  69         '&' => 'CODE',
  70     );
  71
  72     sub _deconstruct_variable_name {
  73         my ($self, $variable) = @_;
  74
  75         (defined $variable)
  76             || confess "You must pass a variable name";
  77
  78         my ($sigil, $name) = ($variable =~ /^(.)(.*)$/);
  79
  80         (defined $sigil)
  81             || confess "The variable name must include a sigil";
  82
  83         (exists $SIGIL_MAP{$sigil})
  84             || confess "I do not recognize that sigil '$sigil'";
  85
  86         return ($name, $sigil, $SIGIL_MAP{$sigil});
  87     }
  88 }
  89
  90 # Class attributes
  91
  92 # ... these functions have to touch the symbol table itself,.. yuk
  93
  94 sub add_package_symbol {
  95     my ($self, $variable, $initial_value) = @_;
  96
  97     my ($name, $sigil, $type) = $self->_deconstruct_variable_name($variable);
  98
  99     no strict 'refs';
 100     no warnings 'redefine', 'misc';
 101     *{$self->name . '::' . $name} = ref $initial_value ? $initial_value : \$initial_value;
 102 }
 103
 104 sub remove_package_glob {
 105     my ($self, $name) = @_;
 106     no strict 'refs';
 107     delete ${$self->name . '::'}{$name};
 108 }
 109
 110 # ... these functions deal with stuff on the namespace level
 111
 112 sub has_package_symbol {
 113     my ($self, $variable) = @_;
 114
 115     my ($name, $sigil, $type) = $self->_deconstruct_variable_name($variable);
 116
 117     return 0 unless exists $self->namespace->{$name};
 118
 119     # FIXME:
 120     # For some really stupid reason
 121     # a typeglob will have a default
 122     # value of \undef in the SCALAR
 123     # slot, so we need to work around
 124     # this. Which of course means that
 125     # if you put \undef in your scalar
 126     # then this is broken.
 127
 128     if ($type eq 'SCALAR') {
 129         my $val = *{$self->namespace->{$name}}{$type};
 130         defined(${$val}) ? 1 : 0;
 131     }
 132     else {
 133         defined(*{$self->namespace->{$name}}{$type}) ? 1 : 0;
 134     }
 135 }
 136
 137 sub get_package_symbol {
 138     my ($self, $variable) = @_;
 139
 140     my ($name, $sigil, $type) = $self->_deconstruct_variable_name($variable);
 141
 142     $self->add_package_symbol($variable)
 143         unless exists $self->namespace->{$name};
 144     return *{$self->namespace->{$name}}{$type};
 145 }
 146
 147 sub remove_package_symbol {
 148     my ($self, $variable) = @_;
 149
 150     my ($name, $sigil, $type) = $self->_deconstruct_variable_name($variable);
 151
 152     # FIXME:
 153     # no doubt this is grossly inefficient and
 154     # could be done much easier and faster in XS
 155
 156     my ($scalar, $array, $hash, $code);
 157     if ($type eq 'SCALAR') {
 158         $array  = $self->get_package_symbol('@' . $name) if $self->has_package_symbol('@' . $name);
 159         $hash   = $self->get_package_symbol('%' . $name) if $self->has_package_symbol('%' . $name);
 160         $code   = $self->get_package_symbol('&' . $name) if $self->has_package_symbol('&' . $name);
 161     }
 162     elsif ($type eq 'ARRAY') {
 163         $scalar = $self->get_package_symbol('$' . $name) if $self->has_package_symbol('$' . $name);
 164         $hash   = $self->get_package_symbol('%' . $name) if $self->has_package_symbol('%' . $name);
 165         $code   = $self->get_package_symbol('&' . $name) if $self->has_package_symbol('&' . $name);
 166     }
 167     elsif ($type eq 'HASH') {
 168         $scalar = $self->get_package_symbol('$' . $name) if $self->has_package_symbol('$' . $name);
 169         $array  = $self->get_package_symbol('@' . $name) if $self->has_package_symbol('@' . $name);
 170         $code   = $self->get_package_symbol('&' . $name) if $self->has_package_symbol('&' . $name);
 171     }
 172     elsif ($type eq 'CODE') {
 173         $scalar = $self->get_package_symbol('$' . $name) if $self->has_package_symbol('$' . $name);
 174         $array  = $self->get_package_symbol('@' . $name) if $self->has_package_symbol('@' . $name);
 175         $hash   = $self->get_package_symbol('%' . $name) if $self->has_package_symbol('%' . $name);
 176     }
 177     else {
 178         confess "This should never ever ever happen";
 179     }
 180
 181     $self->remove_package_glob($name);
 182
 183     $self->add_package_symbol(('$' . $name) => $scalar) if defined $scalar;
 184     $self->add_package_symbol(('@' . $name) => $array)  if defined $array;
 185     $self->add_package_symbol(('%' . $name) => $hash)   if defined $hash;
 186     $self->add_package_symbol(('&' . $name) => $code)   if defined $code;
 187 }
 188
 189 sub list_all_package_symbols {
 190     my ($self, $type_filter) = @_;
 191     return keys %{$self->namespace} unless defined $type_filter;
 192     # or we can filter based on
 193     # type (SCALAR|ARRAY|HASH|CODE)
 194     my $namespace = $self->namespace;
 195     return grep { defined(*{$namespace->{$_}}{$type_filter}) } keys %{$namespace};
 196 }
 197
 198 1;
 199
 200 __END__
 201
 202 =pod
 203
 204 =head1 NAME
 205
 206 Class::MOP::Package - Package Meta Object
 207
 208 =head1 SYNOPSIS
 209
 210 =head1 DESCRIPTION
 211
 212 =head1 METHODS
 213
 214 =over 4
 215
 216 =item B<meta>
 217
 218 =item B<initialize ($package_name)>
 219
 220 =item B<name>
 221
 222 This is a read-only attribute which returns the package name for the
 223 given instance.
 224
 225 =item B<namespace>
 226
 227 This returns a HASH reference to the symbol table. The keys of the
 228 HASH are the symbol names, and the values are typeglob references.
 229
 230 =item B<add_package_symbol ($variable_name, ?$initial_value)>
 231
 232 Given a C<$variable_name>, which must contain a leading sigil, this
 233 method will create that variable within the package which houses the
 234 class. It also takes an optional C<$initial_value>, which must be a
 235 reference of the same type as the sigil of the C<$variable_name>
 236 implies.
 237
 238 =item B<get_package_symbol ($variable_name)>
 239
 240 This will return a reference to the package variable in
 241 C<$variable_name>.
 242
 243 =item B<has_package_symbol ($variable_name)>
 244
 245 Returns true (C<1>) if there is a package variable defined for
 246 C<$variable_name>, and false (C<0>) otherwise.
 247
 248 =item B<remove_package_symbol ($variable_name)>
 249
 250 This will attempt to remove the package variable at C<$variable_name>.
 251
 252 =item B<remove_package_glob ($glob_name)>
 253
 254 This will attempt to remove the entire typeglob associated with
 255 C<$glob_name> from the package.
 256
 257 =item B<list_all_package_symbols (?$type_filter)>
 258
 259 This will list all the glob names associated with the current package.
 260 By inspecting the globs returned you can discern all the variables in
 261 the package.
 262
 263 By passing a C<$type_filter>, you can limit the list to only those
 264 which match the filter (either SCALAR, ARRAY, HASH or CODE).
 265
 266 =back
 267
 268 =head1 AUTHORS
 269
 270 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 271
 272 Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
 273
 274 =head1 COPYRIGHT AND LICENSE
 275
 276 Copyright 2006 by Infinity Interactive, Inc.
 277
 278 L<http://www.iinteractive.com>
 279
 280 This library is free software; you can redistribute it and/or modify
 281 it under the same terms as Perl itself.
 282
 283 =cut