File Coverage

blib/lib/Acme/UNIVERSAL/new.pm

Criterion	Covered	Total	%
statement	9	42	21.4
branch	0	16	0.0
condition	0	3	0.0
subroutine	3	9	33.3
pod	4	5	80.0
total	16	75	21.3

package Acme::UNIVERSAL::new;

use strict;
use warnings;

use vars '$VERSION';
$VERSION = '0.01';

sub UNIVERSAL::new
{
	my $class = get_class();
	my $ref   = get_ref();
	bless $ref, $class;
}

sub get_class
{
	my ($root, $prefix) = @_;

	unless ($root)
	{
		$root   = \%main::;
		$prefix = '';
	}

	my %symbols = get_symbols( $root );

	my @candidates;

	while ( my ($namespace, $name) = each %symbols )
	{
		next if $namespace eq 'main::';
		next if $namespace eq '::';
		my $fullname = $prefix . $name;
		push @candidates, $fullname if has_constructor( $fullname );
		push @candidates, get_class( $root->{ $namespace }, $fullname . '::' );
	}

	return $candidates[ rand( @candidates ) ] unless $prefix;
	return @candidates;
}

sub has_constructor
{
	my $symbol              = shift;
	return unless $symbol && $symbol =~ /^[A-Za-z]/;
	return unless my $ctor  = $symbol->can( 'new' );
	return if        $ctor == \&UNIVERSAL::new;
	return 1;
}

sub get_symbols
{
	my $table = shift;
	return map  { my $name = $_; s/::$//; $name => $_ }
	       grep { /::$/ }
		   keys %$table;
}

sub get_ref
{
	my @refs = ( \(my $foo), {}, [], sub {}, do { local *FOO; \*FOO } );
	return $refs[ rand( @refs ) ];
}

1; # End of Acme::UNIVERSAL::new

__END__