File Coverage

lib/Class/Factory.pm

Criterion	Covered	Total	%
statement	94	109	86.2
branch	28	42	66.6
condition	13	36	36.1
subroutine	15	18	83.3
pod	0	17	0.0
total	150	222	67.5

package Class::Factory;

# $Id: Factory.pm 46 2007-11-07 00:06:38Z cwinters $

use strict;

$Class::Factory::VERSION = '1.06';

my %CLASS_BY_FACTORY_AND_TYPE  = ();
my %FACTORY_INFO_BY_CLASS      = ();
my %REGISTER                   = ();

# Simple constructor -- override as needed

sub new {
    my ( $pkg, $type, @params ) = @_;
    my $class = $pkg->get_factory_class( $type );
    return undef unless ( $class );
    my $self = bless( {}, $class );
    return $self->init( @params );
}


# Subclasses should override, but if they don't they shouldn't be
# penalized...

sub init { return $_[0] }

# Find the class associated with $object_type

sub get_factory_class {
    my ( $item, $object_type ) = @_;
    my $class = ref $item || $item;
    my $factory_class =
        $CLASS_BY_FACTORY_AND_TYPE{ $class }->{ $object_type };
    return $factory_class if ( $factory_class );

    $factory_class = $REGISTER{ $class }->{ $object_type };
    if ( $factory_class ) {
        my $added_class =
            $class->add_factory_type( $object_type, $factory_class );
        return $added_class;
    }
    $item->factory_error( "Factory type '$object_type' is not defined ",
                          "in '$class'" );
    return undef;
}


# Associate $object_type with $object_class

sub add_factory_type {
    my ( $item, $object_type, $object_class ) = @_;
    my $class = ref $item || $item;
    unless ( $object_type )  {
        $item->factory_error( "Cannot add factory type to '$class': no ",
                              "type defined");
    }
    unless ( $object_class ) {
        $item->factory_error( "Cannot add factory type '$object_type' to ",
                              "'$class': no class defined" );
    }

    my $set_object_class =
        $CLASS_BY_FACTORY_AND_TYPE{ $class }->{ $object_type };
    if ( $set_object_class ) {
        $item->factory_log( "Attempt to add type '$object_type' to '$class' ",
                            "redundant; type already exists with class ",
                            "'$set_object_class'" );
        return;
    }

    # Make sure the object class looks like a perl module/script
    # Acceptable formats:
    #   Module.pm  Module.ph  Module.pl  Module
    $object_class =~ m/^([\w:-]+(?:\.(?:pm|ph|pl))?)$/;
    $object_class = $1;

    if ( $INC{ $object_class } ) {
        $item->factory_log( "Looks like class '$object_class' was already ",
                            "included; no further work necessary" );
    }
    else {
        eval "require $object_class";
        if ( $@ ) {
            $item->factory_error( "Cannot add factory type '$object_type' to ",
                                  "class '$class': factory class '$object_class' ",
                                  "cannot be required: $@" );
            return undef;
        }
    }

    # keep track of what classes have been included so far...
    $CLASS_BY_FACTORY_AND_TYPE{ $class }->{ $object_type } = $object_class;

    # keep track of what factory and type are associated with a loaded
    # class...
    $FACTORY_INFO_BY_CLASS{ $object_class } = [ $class, $object_type ];

    return $object_class;
}

sub register_factory_type {
    my ( $item, $object_type, $object_class ) = @_;
    my $class = ref $item || $item;
    unless ( $object_type )  {
        $item->factory_error( "Cannot add factory type to '$class': no type ",
                              "defined" );
    }
    unless ( $object_class ) {
        $item->factory_error( "Cannot add factory type '$object_type' to ",
                              "'$class': no class defined" );
    }

    my $set_object_class = $REGISTER{ $class }->{ $object_type };
    if ( $set_object_class ) {
        $item->factory_log( "Attempt to register type '$object_type' with ",
                            "'$class' is redundant; type registered with ",
                            "class '$set_object_class'" );
        return;
    }
    return $REGISTER{ $class }->{ $object_type } = $object_class;
}


sub remove_factory_type {
    my ( $item, @object_types ) = @_;
    my $class = ref $item || $item;

    for my $object_type (@object_types) {
        unless ( $object_type )  {
            $item->factory_error(
                "Cannot remove factory type from '$class': no type defined"
            );
        }

        delete $CLASS_BY_FACTORY_AND_TYPE{ $class }->{ $object_type };
    }
}


sub unregister_factory_type {
    my ( $item, @object_types ) = @_;
    my $class = ref $item || $item;

    for my $object_type (@object_types) {
        unless ( $object_type )  {
            $item->factory_error(
                "Cannot remove factory type from '$class': no type defined"
            );
        }

        delete $REGISTER{ $class }->{ $object_type };

        # Also delete from $CLASS_BY_FACTORY_AND_TYPE because if the object
        # type has already been instantiated, then it will have been processed
        # by add_factory_type(), thus creating an entry in
        # $CLASS_BY_FACTORY_AND_TYPE. We can call register_factory_type()
        # again, but when we try to instantiate an object via
        # get_factory_class(), it will find the old entry in
        # $CLASS_BY_FACTORY_AND_TYPE and use that.

        delete $CLASS_BY_FACTORY_AND_TYPE{ $class }->{ $object_type };
    }
}


sub get_loaded_classes {
    my ( $item ) = @_;
    my $class = ref $item || $item;
    return () unless ( ref $CLASS_BY_FACTORY_AND_TYPE{ $class } eq 'HASH' );
    return sort values %{ $CLASS_BY_FACTORY_AND_TYPE{ $class } };
}

sub get_loaded_types {
    my ( $item ) = @_;
    my $class = ref $item || $item;
    return () unless ( ref $CLASS_BY_FACTORY_AND_TYPE{ $class } eq 'HASH' );
    return sort keys %{ $CLASS_BY_FACTORY_AND_TYPE{ $class } };
}

sub get_registered_classes {
    my ( $item ) = @_;
    my $class = ref $item || $item;
    return () unless ( ref $REGISTER{ $class } eq 'HASH' );
    return sort values %{ $REGISTER{ $class } };
}

sub get_registered_class {
	my ( $item, $type ) = @_;
	unless ( $type ) {
	    warn("No factory type passed");
		return undef;
	}
    my $class = ref $item || $item;
    return undef unless ( ref $REGISTER{ $class } eq 'HASH' );
	return $REGISTER{ $class }{ $type };
}

sub get_registered_types {
    my ( $item ) = @_;
    my $class = ref $item || $item;
    return () unless ( ref $REGISTER{ $class } eq 'HASH' );
    return sort keys %{ $REGISTER{ $class } };
}

# Return the factory class that created $item (which can be an object
# or class)

sub get_my_factory {
    my ( $item ) = @_;
    my $impl_class = ref( $item ) || $item;
    my $impl_info = $FACTORY_INFO_BY_CLASS{ $impl_class };
    if ( ref( $impl_info ) eq 'ARRAY' ) {
        return $impl_info->[0];
    }
    return undef;
}

# Return the type that the factory used to create $item (which can be
# an object or class)

sub get_my_factory_type {
    my ( $item ) = @_;
    $item->get_factory_type_for($item);
}


# Return the type that the factory uses to create a given object or class.

sub get_factory_type_for {
    my ( $self, $item ) = @_;
    my $impl_class = ref( $item ) || $item;
    my $impl_info = $FACTORY_INFO_BY_CLASS{ $impl_class };
    if ( ref( $impl_info ) eq 'ARRAY' ) {
        return $impl_info->[1];
    }
    return undef;
}

########################################
# Overridable Log / Error

sub factory_log   { shift; warn @_, "\n" }
sub factory_error { shift; die @_, "\n" }

1;

__END__