[gitmo/Class-MOP.git] / lib / Class / MOP / Package.pm


package Class::MOP::Package;

use strict;
use warnings;

use B;
use Scalar::Util 'blessed';
use Carp         'confess';

our $VERSION   = '0.71_02';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';

use base 'Class::MOP::Object';

# creation ...

sub initialize {
    my ( $class, @args ) = @_;

    unshift @args, "package" if @args % 2;

    my %options = @args;
    my $package_name = $options{package};


    # we hand-construct the class 
    # until we can bootstrap it
    if ( my $meta = Class::MOP::get_metaclass_by_name($package_name) ) {
        return $meta;
    } else {
        my $meta = ( ref $class || $class )->_new({
            'package'   => $package_name,
        });

        Class::MOP::store_metaclass_by_name($package_name, $meta);

        return $meta;
    }
}

sub reinitialize {
    my ( $class, @args ) = @_;

    unshift @args, "package" if @args % 2;

    my %options = @args;
    my $package_name = delete $options{package};

    (defined $package_name && $package_name && !blessed($package_name))
        || confess "You must pass a package name and it cannot be blessed";

    Class::MOP::remove_metaclass_by_name($package_name);

    $class->initialize($package_name, %options); # call with first arg form for compat
}

sub _new {
    my $class = shift;
    my $options = @_ == 1 ? $_[0] : {@_};

    # NOTE:
    # because of issues with the Perl API 
    # to the typeglob in some versions, we 
    # need to just always grab a new 
    # reference to the hash in the accessor. 
    # Ideally we could just store a ref and 
    # it would Just Work, but oh well :\
    $options->{namespace} ||= \undef;

    bless $options, $class;
}

# Attributes

# NOTE:
# all these attribute readers will be bootstrapped 
# away in the Class::MOP bootstrap section

sub name      { $_[0]->{'package'} }
sub namespace { 
    # NOTE:
    # because of issues with the Perl API 
    # to the typeglob in some versions, we 
    # need to just always grab a new 
    # reference to the hash here. Ideally 
    # we could just store a ref and it would
    # Just Work, but oh well :\    
    no strict 'refs';    
    \%{$_[0]->{'package'} . '::'} 
}

# utility methods

{
    my %SIGIL_MAP = (
        '$' => 'SCALAR',
        '@' => 'ARRAY',
        '%' => 'HASH',
        '&' => 'CODE',
    );
    
    sub _deconstruct_variable_name {
        my ($self, $variable) = @_;

        (defined $variable)
            || confess "You must pass a variable name";    

        my $sigil = substr($variable, 0, 1, '');

        (defined $sigil)
            || confess "The variable name must include a sigil";    

        (exists $SIGIL_MAP{$sigil})
            || confess "I do not recognize that sigil '$sigil'";    
        
        return ($variable, $sigil, $SIGIL_MAP{$sigil});
    }
}

# Class attributes

# ... these functions have to touch the symbol table itself,.. yuk

sub add_package_symbol {
    my ($self, $variable, $initial_value) = @_;

    my ($name, $sigil, $type) = ref $variable eq 'HASH'
        ? @{$variable}{qw[name sigil type]}
        : $self->_deconstruct_variable_name($variable); 

    my $pkg = $self->{'package'};

    no strict 'refs';
    no warnings 'redefine', 'misc';    
    *{$pkg . '::' . $name} = ref $initial_value ? $initial_value : \$initial_value;      
}

sub remove_package_glob {
    my ($self, $name) = @_;
    no strict 'refs';        
    delete ${$self->name . '::'}{$name};     
}

# ... these functions deal with stuff on the namespace level

sub has_package_symbol {
    my ($self, $variable) = @_;

    my ($name, $sigil, $type) = ref $variable eq 'HASH'
        ? @{$variable}{qw[name sigil type]}
        : $self->_deconstruct_variable_name($variable);
    
    my $namespace = $self->namespace;
    
    return 0 unless exists $namespace->{$name};   
    
    # FIXME:
    # For some really stupid reason 
    # a typeglob will have a default
    # value of \undef in the SCALAR 
    # slot, so we need to work around
    # this. Which of course means that 
    # if you put \undef in your scalar
    # then this is broken.

    if (ref($namespace->{$name}) eq 'SCALAR') {
        return ($type eq 'CODE');
    }
    elsif ($type eq 'SCALAR') {    
        my $val = *{$namespace->{$name}}{$type};
        return defined(${$val});
    }
    else {
        defined(*{$namespace->{$name}}{$type});
    }
}

sub get_package_symbol {
    my ($self, $variable) = @_;    

    my ($name, $sigil, $type) = ref $variable eq 'HASH'
        ? @{$variable}{qw[name sigil type]}
        : $self->_deconstruct_variable_name($variable);

    my $namespace = $self->namespace;

    $self->add_package_symbol($variable)
        unless exists $namespace->{$name};

    if (ref($namespace->{$name}) eq 'SCALAR') {
        if ($type eq 'CODE') {
            no strict 'refs';
            return \&{$self->name.'::'.$name};
        }
        else {
            return undef;
        }
    }
    else {
        return *{$namespace->{$name}}{$type};
    }
}

sub remove_package_symbol {
    my ($self, $variable) = @_;

    my ($name, $sigil, $type) = ref $variable eq 'HASH'
        ? @{$variable}{qw[name sigil type]}
        : $self->_deconstruct_variable_name($variable);

    # FIXME:
    # no doubt this is grossly inefficient and 
    # could be done much easier and faster in XS

    my ($scalar_desc, $array_desc, $hash_desc, $code_desc) = (
        { sigil => '$', type => 'SCALAR', name => $name },
        { sigil => '@', type => 'ARRAY',  name => $name },
        { sigil => '%', type => 'HASH',   name => $name },
        { sigil => '&', type => 'CODE',   name => $name },
    );

    my ($scalar, $array, $hash, $code);
    if ($type eq 'SCALAR') {
        $array  = $self->get_package_symbol($array_desc)  if $self->has_package_symbol($array_desc);
        $hash   = $self->get_package_symbol($hash_desc)   if $self->has_package_symbol($hash_desc);     
        $code   = $self->get_package_symbol($code_desc)   if $self->has_package_symbol($code_desc);     
    }
    elsif ($type eq 'ARRAY') {
        $scalar = $self->get_package_symbol($scalar_desc) if $self->has_package_symbol($scalar_desc);
        $hash   = $self->get_package_symbol($hash_desc)   if $self->has_package_symbol($hash_desc);     
        $code   = $self->get_package_symbol($code_desc)   if $self->has_package_symbol($code_desc);
    }
    elsif ($type eq 'HASH') {
        $scalar = $self->get_package_symbol($scalar_desc) if $self->has_package_symbol($scalar_desc);
        $array  = $self->get_package_symbol($array_desc)  if $self->has_package_symbol($array_desc);        
        $code   = $self->get_package_symbol($code_desc)   if $self->has_package_symbol($code_desc);      
    }
    elsif ($type eq 'CODE') {
        $scalar = $self->get_package_symbol($scalar_desc) if $self->has_package_symbol($scalar_desc);
        $array  = $self->get_package_symbol($array_desc)  if $self->has_package_symbol($array_desc);        
        $hash   = $self->get_package_symbol($hash_desc)   if $self->has_package_symbol($hash_desc);        
    }    
    else {
        confess "This should never ever ever happen";
    }
        
    $self->remove_package_glob($name);
    
    $self->add_package_symbol($scalar_desc => $scalar) if defined $scalar;      
    $self->add_package_symbol($array_desc  => $array)  if defined $array;    
    $self->add_package_symbol($hash_desc   => $hash)   if defined $hash;
    $self->add_package_symbol($code_desc   => $code)   if defined $code;            
}

sub list_all_package_symbols {
    my ($self, $type_filter) = @_;

    my $namespace = $self->namespace;
    return keys %{$namespace} unless defined $type_filter;
    
    # NOTE:
    # or we can filter based on 
    # type (SCALAR|ARRAY|HASH|CODE)
    if ( $type_filter eq 'CODE' ) {
        return grep { 
        (ref($namespace->{$_})
                ? (ref($namespace->{$_}) eq 'SCALAR')
                : (ref(\$namespace->{$_}) eq 'GLOB'
                   && defined(*{$namespace->{$_}}{CODE})));
        } keys %{$namespace};
    } else {
        return grep { *{$namespace->{$_}}{$type_filter} } keys %{$namespace};
    }
}

sub get_all_package_symbols {
    my ($self, $type_filter) = @_;

    die "Cannot call get_all_package_symbols as a class method"
        unless ref $self;

    my $namespace = $self->namespace;

    if (wantarray) {
        warn 'Class::MOP::Package::get_all_package_symbols in list context is deprecated. use scalar context instead.';
    }

    return (wantarray ? %$namespace : $namespace) unless defined $type_filter;

    my %ret;
    # for some reason this nasty impl is orders of magnitude faster than a clean version
    if ( $type_filter eq 'CODE' ) {
        my $pkg;
        no strict 'refs';
        %ret = map {
            (ref($namespace->{$_})
                ? ( $_ => \&{$pkg ||= $self->name . "::$_"} )
                : ( ref \$namespace->{$_} eq 'GLOB' # don't use {CODE} unless it's really a glob to prevent stringification of stubs
                    && (*{$namespace->{$_}}{CODE})  # the extra parents prevent breakage on 5.8.2
                    ? ( $_ => *{$namespace->{$_}}{CODE} )
                    : (do {
                        my $sym = B::svref_2object(\$namespace->{$_});
                        my $svt = ref $sym if $sym;
                        ($sym && ($svt eq 'B::PV' || $svt eq 'B::IV'))
                            ? ($_ => ($pkg ||= $self->name)->can($_))
                            : () }) ) )
        } keys %$namespace;
    } else {
        %ret = map {
            $_ => *{$namespace->{$_}}{$type_filter}
        } grep {
            !ref($namespace->{$_}) && *{$namespace->{$_}}{$type_filter}
        } keys %$namespace;
    }

    return wantarray ? %ret : \%ret;
}

1;

__END__

=pod

=head1 NAME 

Class::MOP::Package - Package Meta Object

=head1 DESCRIPTION

This is an abstraction of a Perl 5 package, it is a superclass of
L<Class::MOP::Class> and provides all of the symbol table 
introspection methods.

=head1 METHODS

=over 4

=item B<meta>

Returns a metaclass for this package.

=item B<initialize ($package_name)>

This will initialize a Class::MOP::Package instance which represents 
the package of C<$package_name>.

=item B<reinitialize ($package_name, %options)>

This removes the old metaclass, and creates a new one in it's place.
Do B<not> use this unless you really know what you are doing, it could
very easily make a very large mess of your program.

=item B<name>

This is a read-only attribute which returns the package name for the 
given instance.

=item B<namespace>

This returns a HASH reference to the symbol table. The keys of the 
HASH are the symbol names, and the values are typeglob references.

=item B<add_package_symbol ($variable_name, ?$initial_value)>

Given a C<$variable_name>, which must contain a leading sigil, this 
method will create that variable within the package which houses the 
class. It also takes an optional C<$initial_value>, which must be a 
reference of the same type as the sigil of the C<$variable_name> 
implies.

=item B<get_package_symbol ($variable_name)>

This will return a reference to the package variable in 
C<$variable_name>. 

=item B<has_package_symbol ($variable_name)>

Returns true (C<1>) if there is a package variable defined for 
C<$variable_name>, and false (C<0>) otherwise.

=item B<remove_package_symbol ($variable_name)>

This will attempt to remove the package variable at C<$variable_name>.

=item B<remove_package_glob ($glob_name)>

This will attempt to remove the entire typeglob associated with 
C<$glob_name> from the package. 

=item B<list_all_package_symbols (?$type_filter)>

This will list all the glob names associated with the current package. 
By inspecting the globs returned you can discern all the variables in 
the package.

By passing a C<$type_filter>, you can limit the list to only those 
which match the filter (either SCALAR, ARRAY, HASH or CODE).

=item B<get_all_package_symbols (?$type_filter)>

Works exactly like C<list_all_package_symbols> but returns a HASH of 
name => thing mapping instead of just an ARRAY of names.

=back

=head1 AUTHORS

Stevan Little E<lt>stevan@iinteractive.comE<gt>

=head1 COPYRIGHT AND LICENSE

Copyright 2006-2008 by Infinity Interactive, Inc.

L<http://www.iinteractive.com>

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

=cut
Commit	Line	Data
2243a22b	1
	2	package Class::MOP::Package;
	3
	4	use strict;
	5	use warnings;
	6
b1cd37c2	7	use B;
2243a22b	8	use Scalar::Util 'blessed';
6d5355c3	9	use Carp 'confess';
2243a22b	10
6b5ac420	11	our $VERSION = '0.71_02';
d519662a	12	$VERSION = eval $VERSION;
f0480c45	13	our $AUTHORITY = 'cpan:STEVAN';
2243a22b	14
6e57504d	15	use base 'Class::MOP::Object';
6e57504d	16
6d5355c3	17	# creation ...
	18
	19	sub initialize {
3be6bc1c	20	my ( $class, @args ) = @_;
	21
	22	unshift @args, "package" if @args % 2;
	23
	24	my %options = @args;
	25	my $package_name = $options{package};
	26
	27
9d6dce77	28	# we hand-construct the class
9d6dce77	29	# until we can bootstrap it
a19fcb5b	30	if ( my $meta = Class::MOP::get_metaclass_by_name($package_name) ) {
973de492	31	return $meta;
a19fcb5b	32	} else {
973de492	33	my $meta = ( ref $class \|\| $class )->_new({
	34	'package' => $package_name,
	35	});
a19fcb5b	36
973de492	37	Class::MOP::store_metaclass_by_name($package_name, $meta);
a19fcb5b	38
973de492	39	return $meta;
a19fcb5b	40	}
	41	}
	42
	43	sub reinitialize {
3be6bc1c	44	my ( $class, @args ) = @_;
	45
	46	unshift @args, "package" if @args % 2;
	47
	48	my %options = @args;
3eda22f8	49	my $package_name = delete $options{package};
3be6bc1c	50
a19fcb5b	51	(defined $package_name && $package_name && !blessed($package_name))
a19fcb5b	52	\|\| confess "You must pass a package name and it cannot be blessed";
3be6bc1c	53
a19fcb5b	54	Class::MOP::remove_metaclass_by_name($package_name);
3be6bc1c	55
3eda22f8	56	$class->initialize($package_name, %options); # call with first arg form for compat
682655a3	57	}
	58
	59	sub _new {
0bfc85b8	60	my $class = shift;
0bfc85b8	61	my $options = @_ == 1 ? $_[0] : {@_};
682655a3	62
0bfc85b8	63	# NOTE:
	64	# because of issues with the Perl API
	65	# to the typeglob in some versions, we
	66	# need to just always grab a new
	67	# reference to the hash in the accessor.
	68	# Ideally we could just store a ref and
	69	# it would Just Work, but oh well :\
	70	$options->{namespace} \|\|= \undef;
	71
	72	bless $options, $class;
6d5355c3	73	}
	74
	75	# Attributes
	76
	77	# NOTE:
	78	# all these attribute readers will be bootstrapped
	79	# away in the Class::MOP bootstrap section
	80
8683db0e	81	sub name { $_[0]->{'package'} }
56dcfc1a	82	sub namespace {
	83	# NOTE:
	84	# because of issues with the Perl API
	85	# to the typeglob in some versions, we
	86	# need to just always grab a new
	87	# reference to the hash here. Ideally
	88	# we could just store a ref and it would
	89	# Just Work, but oh well :\
	90	no strict 'refs';
8683db0e	91	\%{$_[0]->{'package'} . '::'}
56dcfc1a	92	}
6d5355c3	93
a5e51f0b	94	# utility methods
6d5355c3	95
c0cbf4d9	96	{
	97	my %SIGIL_MAP = (
	98	'$' => 'SCALAR',
	99	'@' => 'ARRAY',
	100	'%' => 'HASH',
	101	'&' => 'CODE',
	102	);
6d5355c3	103
a5e51f0b	104	sub _deconstruct_variable_name {
	105	my ($self, $variable) = @_;
	106
c0cbf4d9	107	(defined $variable)
c0cbf4d9	108	\|\| confess "You must pass a variable name";
a5e51f0b	109
f430cfa4	110	my $sigil = substr($variable, 0, 1, '');
a5e51f0b	111
c0cbf4d9	112	(defined $sigil)
c0cbf4d9	113	\|\| confess "The variable name must include a sigil";
a5e51f0b	114
c0cbf4d9	115	(exists $SIGIL_MAP{$sigil})
a5e51f0b	116	\|\| confess "I do not recognize that sigil '$sigil'";
a5e51f0b	117
f430cfa4	118	return ($variable, $sigil, $SIGIL_MAP{$sigil});
c0cbf4d9	119	}
a5e51f0b	120	}
6d5355c3	121
a5e51f0b	122	# Class attributes
6d5355c3	123
c46b802b	124	# ... these functions have to touch the symbol table itself,.. yuk
c46b802b	125
a5e51f0b	126	sub add_package_symbol {
a5e51f0b	127	my ($self, $variable, $initial_value) = @_;
6d5355c3	128
8b49a472	129	my ($name, $sigil, $type) = ref $variable eq 'HASH'
	130	? @{$variable}{qw[name sigil type]}
	131	: $self->_deconstruct_variable_name($variable);
6d5355c3	132
8683db0e	133	my $pkg = $self->{'package'};
9a8bbfc9	134
a5e51f0b	135	no strict 'refs';
56dcfc1a	136	no warnings 'redefine', 'misc';
9a8bbfc9	137	*{$pkg . '::' . $name} = ref $initial_value ? $initial_value : \$initial_value;
c46b802b	138	}
	139
	140	sub remove_package_glob {
	141	my ($self, $name) = @_;
	142	no strict 'refs';
	143	delete ${$self->name . '::'}{$name};
a5e51f0b	144	}
6d5355c3	145
c46b802b	146	# ... these functions deal with stuff on the namespace level
c46b802b	147
a5e51f0b	148	sub has_package_symbol {
	149	my ($self, $variable) = @_;
	150
8b49a472	151	my ($name, $sigil, $type) = ref $variable eq 'HASH'
	152	? @{$variable}{qw[name sigil type]}
	153	: $self->_deconstruct_variable_name($variable);
56dcfc1a	154
ae234dc6	155	my $namespace = $self->namespace;
	156
	157	return 0 unless exists $namespace->{$name};
d852f4d2	158
	159	# FIXME:
	160	# For some really stupid reason
	161	# a typeglob will have a default
	162	# value of \undef in the SCALAR
	163	# slot, so we need to work around
	164	# this. Which of course means that
	165	# if you put \undef in your scalar
	166	# then this is broken.
92af7fdf	167
ae234dc6	168	if (ref($namespace->{$name}) eq 'SCALAR') {
b3fa93c7	169	return ($type eq 'CODE');
92af7fdf	170	}
92af7fdf	171	elsif ($type eq 'SCALAR') {
ae234dc6	172	my $val = *{$namespace->{$name}}{$type};
b3fa93c7	173	return defined(${$val});
d852f4d2	174	}
d852f4d2	175	else {
b3fa93c7	176	defined(*{$namespace->{$name}}{$type});
d852f4d2	177	}
a5e51f0b	178	}
	179
	180	sub get_package_symbol {
	181	my ($self, $variable) = @_;
	182
8b49a472	183	my ($name, $sigil, $type) = ref $variable eq 'HASH'
	184	? @{$variable}{qw[name sigil type]}
	185	: $self->_deconstruct_variable_name($variable);
a5e51f0b	186
ae234dc6	187	my $namespace = $self->namespace;
ae234dc6	188
c20522bd	189	$self->add_package_symbol($variable)
ae234dc6	190	unless exists $namespace->{$name};
92af7fdf	191
ae234dc6	192	if (ref($namespace->{$name}) eq 'SCALAR') {
92af7fdf	193	if ($type eq 'CODE') {
	194	no strict 'refs';
	195	return \&{$self->name.'::'.$name};
	196	}
	197	else {
	198	return undef;
	199	}
	200	}
	201	else {
ae234dc6	202	return *{$namespace->{$name}}{$type};
92af7fdf	203	}
a5e51f0b	204	}
	205
	206	sub remove_package_symbol {
	207	my ($self, $variable) = @_;
	208
8b49a472	209	my ($name, $sigil, $type) = ref $variable eq 'HASH'
	210	? @{$variable}{qw[name sigil type]}
	211	: $self->_deconstruct_variable_name($variable);
a5e51f0b	212
c46b802b	213	# FIXME:
	214	# no doubt this is grossly inefficient and
	215	# could be done much easier and faster in XS
	216
8b49a472	217	my ($scalar_desc, $array_desc, $hash_desc, $code_desc) = (
	218	{ sigil => '$', type => 'SCALAR', name => $name },
	219	{ sigil => '@', type => 'ARRAY', name => $name },
	220	{ sigil => '%', type => 'HASH', name => $name },
	221	{ sigil => '&', type => 'CODE', name => $name },
	222	);
	223
c46b802b	224	my ($scalar, $array, $hash, $code);
a5e51f0b	225	if ($type eq 'SCALAR') {
8b49a472	226	$array = $self->get_package_symbol($array_desc) if $self->has_package_symbol($array_desc);
	227	$hash = $self->get_package_symbol($hash_desc) if $self->has_package_symbol($hash_desc);
	228	$code = $self->get_package_symbol($code_desc) if $self->has_package_symbol($code_desc);
a5e51f0b	229	}
a5e51f0b	230	elsif ($type eq 'ARRAY') {
8b49a472	231	$scalar = $self->get_package_symbol($scalar_desc) if $self->has_package_symbol($scalar_desc);
	232	$hash = $self->get_package_symbol($hash_desc) if $self->has_package_symbol($hash_desc);
	233	$code = $self->get_package_symbol($code_desc) if $self->has_package_symbol($code_desc);
a5e51f0b	234	}
a5e51f0b	235	elsif ($type eq 'HASH') {
8b49a472	236	$scalar = $self->get_package_symbol($scalar_desc) if $self->has_package_symbol($scalar_desc);
	237	$array = $self->get_package_symbol($array_desc) if $self->has_package_symbol($array_desc);
	238	$code = $self->get_package_symbol($code_desc) if $self->has_package_symbol($code_desc);
a5e51f0b	239	}
a5e51f0b	240	elsif ($type eq 'CODE') {
8b49a472	241	$scalar = $self->get_package_symbol($scalar_desc) if $self->has_package_symbol($scalar_desc);
	242	$array = $self->get_package_symbol($array_desc) if $self->has_package_symbol($array_desc);
	243	$hash = $self->get_package_symbol($hash_desc) if $self->has_package_symbol($hash_desc);
a5e51f0b	244	}
	245	else {
	246	confess "This should never ever ever happen";
7f436b8c	247	}
c46b802b	248
	249	$self->remove_package_glob($name);
	250
8b49a472	251	$self->add_package_symbol($scalar_desc => $scalar) if defined $scalar;
	252	$self->add_package_symbol($array_desc => $array) if defined $array;
	253	$self->add_package_symbol($hash_desc => $hash) if defined $hash;
	254	$self->add_package_symbol($code_desc => $code) if defined $code;
9d6dce77	255	}
c0cbf4d9	256
9d6dce77	257	sub list_all_package_symbols {
92330ee2	258	my ($self, $type_filter) = @_;
a38e4d1a	259
	260	my $namespace = $self->namespace;
	261	return keys %{$namespace} unless defined $type_filter;
	262
91e0eb4a	263	# NOTE:
92330ee2	264	# or we can filter based on
92330ee2	265	# type (SCALAR\|ARRAY\|HASH\|CODE)
3609af79	266	if ( $type_filter eq 'CODE' ) {
3609af79	267	return grep {
92af7fdf	268	(ref($namespace->{$_})
3609af79	269	? (ref($namespace->{$_}) eq 'SCALAR')
	270	: (ref(\$namespace->{$_}) eq 'GLOB'
	271	&& defined(*{$namespace->{$_}}{CODE})));
	272	} keys %{$namespace};
	273	} else {
	274	return grep { *{$namespace->{$_}}{$type_filter} } keys %{$namespace};
	275	}
6d5355c3	276	}
6d5355c3	277
0531f510	278	sub get_all_package_symbols {
0531f510	279	my ($self, $type_filter) = @_;
87b69f58	280
	281	die "Cannot call get_all_package_symbols as a class method"
	282	unless ref $self;
	283
0531f510	284	my $namespace = $self->namespace;
15273f3c	285
6ccb3af5	286	if (wantarray) {
	287	warn 'Class::MOP::Package::get_all_package_symbols in list context is deprecated. use scalar context instead.';
	288	}
	289
	290	return (wantarray ? %$namespace : $namespace) unless defined $type_filter;
0531f510	291
6ccb3af5	292	my %ret;
e5ebdca9	293	# for some reason this nasty impl is orders of magnitude faster than a clean version
0531f510	294	if ( $type_filter eq 'CODE' ) {
	295	my $pkg;
	296	no strict 'refs';
6ccb3af5	297	%ret = map {
0531f510	298	(ref($namespace->{$_})
0531f510	299	? ( $_ => \&{$pkg \|\|= $self->name . "::$_"} )
361c0e55	300	: ( ref \$namespace->{$_} eq 'GLOB' # don't use {CODE} unless it's really a glob to prevent stringification of stubs
361c0e55	301	&& (*{$namespace->{$_}}{CODE}) # the extra parents prevent breakage on 5.8.2
33f5d8ec	302	? ( $_ => *{$namespace->{$_}}{CODE} )
b1cd37c2	303	: (do {
	304	my $sym = B::svref_2object(\$namespace->{$_});
	305	my $svt = ref $sym if $sym;
361c0e55	306	($sym && ($svt eq 'B::PV' \|\| $svt eq 'B::IV'))
b1cd37c2	307	? ($_ => ($pkg \|\|= $self->name)->can($_))
b1cd37c2	308	: () }) ) )
0531f510	309	} keys %$namespace;
0531f510	310	} else {
6ccb3af5	311	%ret = map {
0531f510	312	$_ => *{$namespace->{$_}}{$type_filter}
	313	} grep {
	314	!ref($namespace->{$_}) && *{$namespace->{$_}}{$type_filter}
	315	} keys %$namespace;
	316	}
6ccb3af5	317
6ccb3af5	318	return wantarray ? %ret : \%ret;
ae234dc6	319	}
ae234dc6	320
2243a22b	321	1;
	322
	323	__END__
	324
	325	=pod
	326
	327	=head1 NAME
	328
	329	Class::MOP::Package - Package Meta Object
	330
2243a22b	331	=head1 DESCRIPTION
2243a22b	332
127d39a7	333	This is an abstraction of a Perl 5 package, it is a superclass of
	334	L<Class::MOP::Class> and provides all of the symbol table
	335	introspection methods.
	336
2243a22b	337	=head1 METHODS
	338
	339	=over 4
	340
	341	=item B<meta>
	342
127d39a7	343	Returns a metaclass for this package.
127d39a7	344
b9d9fc0b	345	=item B<initialize ($package_name)>
6d5355c3	346
127d39a7	347	This will initialize a Class::MOP::Package instance which represents
	348	the package of C<$package_name>.
	349
a19fcb5b	350	=item B<reinitialize ($package_name, %options)>
	351
	352	This removes the old metaclass, and creates a new one in it's place.
	353	Do B<not> use this unless you really know what you are doing, it could
	354	very easily make a very large mess of your program.
	355
6d5355c3	356	=item B<name>
6d5355c3	357
b9d9fc0b	358	This is a read-only attribute which returns the package name for the
	359	given instance.
	360
a5e51f0b	361	=item B<namespace>
a5e51f0b	362
b9d9fc0b	363	This returns a HASH reference to the symbol table. The keys of the
	364	HASH are the symbol names, and the values are typeglob references.
	365
	366	=item B<add_package_symbol ($variable_name, ?$initial_value)>
	367
	368	Given a C<$variable_name>, which must contain a leading sigil, this
	369	method will create that variable within the package which houses the
	370	class. It also takes an optional C<$initial_value>, which must be a
	371	reference of the same type as the sigil of the C<$variable_name>
	372	implies.
	373
	374	=item B<get_package_symbol ($variable_name)>
6d5355c3	375
b9d9fc0b	376	This will return a reference to the package variable in
b9d9fc0b	377	C<$variable_name>.
6d5355c3	378
b9d9fc0b	379	=item B<has_package_symbol ($variable_name)>
6d5355c3	380
b9d9fc0b	381	Returns true (C<1>) if there is a package variable defined for
b9d9fc0b	382	C<$variable_name>, and false (C<0>) otherwise.
6d5355c3	383
b9d9fc0b	384	=item B<remove_package_symbol ($variable_name)>
	385
	386	This will attempt to remove the package variable at C<$variable_name>.
	387
	388	=item B<remove_package_glob ($glob_name)>
	389
	390	This will attempt to remove the entire typeglob associated with
	391	C<$glob_name> from the package.
c46b802b	392
92330ee2	393	=item B<list_all_package_symbols (?$type_filter)>
9d6dce77	394
b9d9fc0b	395	This will list all the glob names associated with the current package.
	396	By inspecting the globs returned you can discern all the variables in
	397	the package.
	398
92330ee2	399	By passing a C<$type_filter>, you can limit the list to only those
	400	which match the filter (either SCALAR, ARRAY, HASH or CODE).
	401
ae234dc6	402	=item B<get_all_package_symbols (?$type_filter)>
	403
	404	Works exactly like C<list_all_package_symbols> but returns a HASH of
	405	name => thing mapping instead of just an ARRAY of names.
	406
2243a22b	407	=back
2243a22b	408
1a09d9cc	409	=head1 AUTHORS
2243a22b	410
	411	Stevan Little E<lt>stevan@iinteractive.comE<gt>
	412
	413	=head1 COPYRIGHT AND LICENSE
	414
69e3ab0a	415	Copyright 2006-2008 by Infinity Interactive, Inc.
2243a22b	416
	417	L<http://www.iinteractive.com>
	418
	419	This library is free software; you can redistribute it and/or modify
	420	it under the same terms as Perl itself.
	421
92af7fdf	422	=cut