return 0 if ref($class) || !defined($class) || !length($class);
# walk the symbol table tree to avoid autovififying
- # \*{${main::}{"Foo::"}} == \*main::Foo::
+ # \*{${main::}{"Foo::"}{"Bar::"}} == \*main::Foo::Bar::
my $pack = \%::;
foreach my $part (split('::', $class)) {
- my $entry = \$pack->{$part . '::'};
+ $part .= '::';
+ return 0 if !exists $pack->{$part};
+
+ my $entry = \$pack->{$part};
return 0 if ref($entry) ne 'GLOB';
- $pack = *{$entry}{HASH} or return 0;
+ $pack = *{$entry}{HASH};
}
+ return 0 if !%{$pack};
+
# check for $VERSION or @ISA
return 1 if exists $pack->{VERSION}
&& defined *{$pack->{VERSION}}{SCALAR} && defined ${ $pack->{VERSION} };
return;
}
+my %SIGIL_MAP = (
+ '$' => 'SCALAR',
+ '@' => 'ARRAY',
+ '%' => 'HASH',
+ '&' => 'CODE',
+ '*' => 'GLOB',
+);
+
+sub _deconstruct_variable_name {
+ my($self, $variable) = @_;
+
+ (defined $variable)
+ || $self->throw_error("You must pass a variable name");
+
+ my $sigil = substr($variable, 0, 1, '');
+
+ (defined $sigil)
+ || $self->throw_error("The variable name must include a sigil");
+
+ (exists $SIGIL_MAP{$sigil})
+ || $self->throw_error("I do not recognize that sigil '$sigil'");
+
+ return ($variable, $SIGIL_MAP{$sigil});
+}
+
+sub has_package_symbol {
+ my($self, $variable) = @_;
+
+ my($name, $type) = $self->_deconstruct_variable_name($variable);
+
+ my $namespace = $self->namespace;
+
+ return 0 unless exists $namespace->{$name};
+
+ my $entry_ref = \$namespace->{$name};
+ if ( ref($entry_ref) eq 'GLOB' ) {
+ return defined( *{$entry_ref}{$type} );
+ }
+ else {
+ # a symbol table entry can be -1 (stub), string (stub with prototype),
+ # or reference (constant)
+ return $type eq 'CODE';
+ }
+}
+
+sub get_package_symbol {
+ my ($self, $variable) = @_;
+
+ my($name, $type) = $self->_deconstruct_variable_name($variable);
+
+ my $namespace = $self->namespace;
+
+ return undef
+ unless exists $namespace->{$name};
+
+ my $entry_ref = \$namespace->{$name};
+
+ if ( ref($entry_ref) eq 'GLOB' ) {
+ return *{$entry_ref}{$type};
+ }
+ else {
+ if ( $type eq 'CODE' ) {
+ no strict 'refs';
+ return \&{ $self->name . '::' . $name };
+ }
+ else {
+ return undef;
+ }
+ }
+}
+
package
Mouse::Meta::Class;
-sub constructor_class() { 'Mouse::Meta::Method::Constructor' }
-sub destructor_class() { 'Mouse::Meta::Method::Destructor' }
+sub method_metaclass { $_[0]->{method_metaclass} || 'Mouse::Meta::Method' }
+sub attribute_metaclass { $_[0]->{attribute_metaclass} || 'Mouse::Meta::Attribute' }
+
+sub constructor_class { $_[0]->{constructor_class} || 'Mouse::Meta::Method::Constructor' }
+sub destructor_class { $_[0]->{destructor_class} || 'Mouse::Meta::Method::Destructor' }
sub is_anon_class{
return exists $_[0]->{anon_serial_id};
return values %attrs;
}
+sub new_object {
+ my $self = shift;
+ my %args = (@_ == 1 ? %{$_[0]} : @_);
+
+ my $object = bless {}, $self->name;
+
+ $self->_initialize_object($object, \%args);
+ return $object;
+}
+
sub _initialize_object{
my($self, $object, $args, $ignore_triggers) = @_;
package
Mouse::Meta::Role;
+sub method_metaclass{ $_[0]->{method_metaclass} || 'Mouse::Meta::Role::Method' }
+
sub is_anon_role{
return exists $_[0]->{anon_serial_id};
}
package
Mouse::Meta::Attribute;
-use Mouse::Meta::Method::Accessor;
+require Mouse::Meta::Method::Accessor;
+
+sub accessor_metaclass{ $_[0]->{accessor_metaclass} || 'Mouse::Meta::Method::Accessor' }
# readers
sub has_documentation { exists $_[0]->{documentation} }
-sub accessor_metaclass(){ 'Mouse::Meta::Method::Accessor' }
-
package
Mouse::Meta::TypeConstraint;
=head1 VERSION
-This document describes Mouse version 0.40_05
+This document describes Mouse version 0.40_08
=head1 SEE ALSO