view release on metacpan or  search on metacpan

lib/Class/Maker.pm  view on Meta::CPAN

	sub definition : method
	{
		my $this = shift;

	return $this->{def};
	}
	
	sub parents : method
	{
		my $this = shift;

		return unless exists $this->{isa};	
				
	return Class::Maker::Reflection::inheritance_isa( @{ $this->{isa} } );
	}

package Class::Maker::Reflection;

	no warnings 'once';

	our $DEBUG = $Class::Maker::DEBUG;

	use Data::Dump qw(dump);

        sub DEBUG : lvalue { $DEBUG }
	
	
		# DEEP : Whether reflect should traverse the @ISA tree and return all parent reflex's
	
	our $DEEP = 0;
	
	our $DEFINITION = 'CLASS';
	
	sub _get_definition
	{
		my $class = shift;
	
			no warnings;
	
			no strict 'refs';
	
	return \${ "${class}::".$Class::Maker::Reflection::DEFINITION };
	}
	
	sub _get_isa
	{
		no strict 'refs';
	
	return @{ $_[0].'::ISA'};
	}
	
	sub install
	{
		${ Class::Maker::Reflection::_get_definition( $pkg ) } = $_[0];
	}
	
	sub reflect
	{
		my $class = ref( $_[0] ) || $_[0] || die;
	
			my $rfx = bless {  name => $class  }, 'Class::Maker::Reflex';
	
				# - First get the "${$DEFINITION}" href containing the class definition
				# - find the functions of that class declerated with ': method'
				# - catch up the parent class reflection if DEEP is activated
				# - update "${$DEFINITION}"->{isa} with its real @ISA
	
			$rfx->{def} = ${ Class::Maker::Reflection::_get_definition( $class ) };
	
			$rfx->{methods} = find_methods( $rfx->{name} );
	
			no strict 'refs';
	
			if( $DEEP && defined *{ "${class}::ISA" }{ARRAY} )
			{
				$rfx->{isa} = \@{ *{ "${class}::ISA" }{ARRAY} };
	
				$rfx->{parents}->{$_} = reflect( $_ ) for @{ $rfx->{isa} };
			}
	
	return $rfx;
	}
	
	sub classes
	{
		no strict 'refs';
	
		my @found;
	
		my $path = shift if @_ > 1;
	
		foreach my $pkg ( @_ )
		{
			next unless $pkg =~ /::$/;
	
			$path .= $pkg;
	
			if( $path =~ /(.*)::$/ )
			{
				my $clean_path = $1;
	
				if( $path ne 'main::' )
				{
					if( my $href_cls = reflect( $clean_path ) )
					{
						push @found, { $clean_path => $href_cls };
					}
				}
	
				foreach my $symbol ( sort keys %{$path} )
				{
					if( $symbol =~ /::$/ && $symbol ne 'main::' )
					{
						push @found,  classes( $path, $symbol );
					}
				}
			}
		}
	
	return @found;
	}