File Coverage

blib/lib/SPOPS/ClassFactory.pm

Criterion	Covered	Total	%
statement	48	241	19.9
branch	0	94	0.0
condition	0	28	0.0
subroutine	16	32	50.0
pod	0	14	0.0
total	64	409	15.6

package SPOPS::ClassFactory;

# $Id: ClassFactory.pm,v 3.6 2004/06/02 00:48:21 lachoy Exp $

use strict;
use base  qw( Exporter );
use Log::Log4perl qw( get_logger );

use Class::ISA;
use Data::Dumper  qw( Dumper );
use SPOPS;
use SPOPS::Exception;

$SPOPS::ClassFactory::VERSION   = sprintf("%d.%02d", q$Revision: 3.6 $ =~ /(\d+)\.(\d+)/);
@SPOPS::ClassFactory::EXPORT_OK = qw( OK DONE NOTIFY ERROR RESTART
                                      FACTORY_METHOD RULESET_METHOD );

use constant OK             => 'OK';
use constant DONE           => 'DONE';
use constant NOTIFY         => 'NOTIFY';
use constant ERROR          => 'ERROR';
use constant RESTART        => 'RESTART';
use constant FACTORY_METHOD => 'behavior_factory';
use constant RULESET_METHOD => 'ruleset_factory';

my $log = get_logger();

my %REQ_CLASSES = ();

my $PK = '__private__'; # Save typing...

# TODO: Export constants with the names of these slots -- the order
# doesn't matter to anyone except us, so we shouldn't need to export
# order and be able to keep the variable a lexical

my @SLOTS = qw(
  manipulate_configuration id_method read_code
  fetch_by has_a links_to add_rule
);

my %SLOT_NUM = map { $SLOTS[ $_ ] => $_ } ( 0 .. ( scalar @SLOTS - 1 ) );


########################################
# MAIN INTERFACE
########################################

# TODO: Will $config ever be an object? Also, is 'create' the best
# name?

sub create {
    my ( $class, $all_config, $p ) = @_;
    return [] unless ( ref $all_config eq 'HASH' );
    $p ||= {};

    $class->create_all_stubs( $all_config, $p );
    $class->find_all_behavior( $all_config, $p );
    $class->exec_all_behavior( $all_config, $p );
    $class->clean_all_behavior( $all_config, $p );

    my $alias_list = $class->get_alias_list( $all_config, $p );
    return [ map { $all_config->{ $_ }->{class} }
                 grep { defined $all_config->{ $_ }->{class} }
                      @{ $alias_list } ];
}


########################################
# MULTI-CONFIG METHODS
########################################

# These methods operate on $all_config, a hashref of SPOPS
# configuration hashrefs


# First, we need to create the class so we can have an inheritance
# tree to walk -- think of this as the ur-behavior, or the beginning
# of the chicken-and-egg, or...

sub create_all_stubs {
    my ( $class, $all_config, $p ) = @_;
    my $alias_list = $class->get_alias_list( $all_config, $p );
    foreach my $alias ( @{ $alias_list } ) {
        my $this_class = $all_config->{ $alias }{class};
        $all_config->{ $alias }->{main_alias} ||= $alias;
        my ( $status, $msg ) = $class->create_stub( $all_config->{ $alias } );
        if ( $status eq ERROR )     { SPOPS::Exception->throw( $msg ) }
        my ( $cfg_status, $cfg_msg ) = $class->install_configuration( $this_class, $all_config->{ $alias } );
        if ( $cfg_status eq ERROR ) { SPOPS::Exception->throw( $cfg_msg ) }
    }
}


# Now that the class is created with at least @ISA defined, we can
# walk through @ISA for each class and install all the behaviors

sub find_all_behavior {
    my ( $class, $all_config, $p ) = @_;
    my $alias_list = $class->get_alias_list( $all_config, $p );
    foreach my $alias ( @{ $alias_list } ) {
        my $this_class = $all_config->{ $alias }{class};
        my $this_config = $this_class->CONFIG;
        $this_config->{ $PK }{behavior_table} = {};
        $this_config->{ $PK }{behavior_run}   = {};
        $this_config->{ $PK }{behavior_map}   = $class->find_behavior( $this_class );
    }
}


# Now execute the behavior for each slot-and-alias. Note that we
# cannot do this in reverse order (alias-and-slot) because some later
# slots (particularly the relationship ones) may depend on earlier
# slots being executed for other classes.

sub exec_all_behavior {
    my ( $class, $all_config, $p ) = @_;
    my $alias_list = $class->get_alias_list( $all_config, $p );
    foreach my $slot_name ( @SLOTS ) {
        foreach my $alias ( @{ $alias_list } ) {
            my $this_class = $all_config->{ $alias }{class};
            $class->exec_behavior( $slot_name, $this_class );
        }
    }
}


# Remove all evidence of behaviors, tracking, etc. -- nobody should
# need this information once the class has been created.

sub clean_all_behavior {
    my ( $class, $all_config, $p ) = @_;
    my $alias_list = $class->get_alias_list( $all_config, $p );
    foreach my $alias ( @{ $alias_list } ) {
        my $this_class = $all_config->{ $alias }{class};
        delete $this_class->CONFIG->{ $PK };
    }
}


########################################
# CREATE CLASS
########################################

# EVAL'ABLE PACKAGE/SUBROUTINES

# Here's our template for a module on the fly. Super easy.

my $GENERIC_TEMPLATE = <<'PACKAGE';
       @%%CLASS%%::ISA     = qw( %%ISA%% );
       $%%CLASS%%::C       = {};
       sub %%CLASS%%::CONFIG  { return $%%CLASS%%::C; }
PACKAGE

sub create_stub {
    my ( $class, $config ) = @_;

    my $this_class = $config->{class};
    $log->is_debug &&
        $log->debug( "Creating stub ($this_class) with main alias ($config->{main_alias})");

    # Create the barest information forming the class; just substitute our
    # keywords (currently only the class name) for the items in the
    # generic template above.

    my $module      = $GENERIC_TEMPLATE;
    $module        =~ s/%%CLASS%%/$this_class/g;
    my $isa_listing = join( ' ', @{ $config->{isa} } );
    $module        =~ s/%%ISA%%/$isa_listing/g;

    $log->is_debug &&
        $log->debug( "Trying to create class with the code:\n$module\n" );

    # Capture 'warn' calls that get triggered as a result of warnings,
    # redefined subroutines or whatnot; these get dumped to STDERR and
    # we want to be as quiet as possible -- or at least control our
    # noise!

    {
        local $SIG{__WARN__} = sub { return undef };
        eval $module;
        if ( $@ ) {
            return ( ERROR, "Error creating stub class [$this_class] with " .
                            "code\n$module\nError: $@" );
        }
    }
    return $class->require_config_classes( $config );
}


# Just step through @{ $config->{isa} } and 'require' each entry
# unless it's already been; also require everything in
# @{ $config->{rules_from} }

sub require_config_classes {
    my ( $class, $config ) = @_;
    my $this_class = $config->{class};
    my $rules_from = $config->{rules_from} || [];
    foreach my $req_class ( @{ $config->{isa} }, @{ $rules_from } ) {
        next unless ( $req_class );
        next if ( $REQ_CLASSES{ $req_class } );
        eval "require $req_class";
        if ( $@ ) {
            return ( ERROR, "Error requiring class [$req_class] from ISA " .
                            "or 'rules_from' in [$this_class]: $@" );
        }
        $log->is_debug &&
            $log->debug( "Class [$req_class] require'd by [$this_class] ok." );
        $REQ_CLASSES{ $req_class }++;
    }
    return ( OK, undef );
}


########################################
# INSTALL CONFIGURATION
########################################

# Just take the config from the $all_config (or wherever) and install
# it to the class -- we aren't doing any manipulation or anything,
# just copying over the original config key by key. Manipulation comes later.

sub install_configuration {
    my ( $class, $this_class, $config ) = @_;
    $log->is_info &&
        $log->info( "Installing configuration to class ($this_class)" );
    $log->is_debug &&
        $log->debug( "Config ($this_class)\n", Dumper( $config ) );
    my $class_config = $this_class->CONFIG;
    while ( my ( $k, $v ) = each %{ $config } ) {
        $class_config->{ $k } = $v;
    }
    return ( OK, undef );
}


########################################
# FIND BEHAVIOR
########################################

# Find all the factory method-generators in all members of a class's
# ISA, then run each of the generators and keep track of the slots
# each generator uses (behavior map)

sub find_behavior {
    my ( $class, $this_class ) = @_;
    my $this_config = $this_class->CONFIG;

    # Allow config to specify ClassFactory-only classes in
    # 'rules_from' configuration key.

    my $rule_classes = $this_config->{rules_from} || [];
    my $subs = $class->find_parent_methods( $this_class, $rule_classes, FACTORY_METHOD );
    my %behavior_map = ();
    foreach my $sub_info ( @{ $subs } ) {
        my $behavior_gen_class = $sub_info->[0];
        my $behavior_gen_sub   = $sub_info->[1];
        next if ( defined $behavior_map{ $behavior_gen_class } );

        # Execute the behavior factory and map the returned
        # information (slot => coderef or slot => \@( coderef )) into
        # the class config.

        my $behaviors = $behavior_gen_sub->( $this_class ) || {};
        $log->is_debug &&
            $log->debug( "Behaviors returned for ($this_class): ",
                          join( ', ', keys %{ $behaviors } ) );
        foreach my $slot_name ( keys %{ $behaviors } ) {
            my $typeof = ref $behaviors->{ $slot_name };
            next unless ( $typeof eq 'CODE' or $typeof eq 'ARRAY' );
            $log->is_debug &&
                $log->debug( "Adding slot behaviors for ($slot_name)" );
            if ( $typeof eq 'CODE' ) {
                push @{ $this_config->{ $PK }{behavior_table}{ $slot_name } },
                            $behaviors->{ $slot_name };
            }
            elsif ( $typeof eq 'ARRAY' ) {
                next unless ( scalar @{ $behaviors->{ $slot_name } } );
                push @{ $this_config->{ $PK }{behavior_table}{ $slot_name } },
                            @{ $behaviors->{ $slot_name } };
            }
            $behavior_map{ $behavior_gen_class }->{ $slot_name }++;
        }
    }
    return \%behavior_map;
}


# Find all instances of method $method supported by classes in the ISA
# of $class as well as in \@added_classes. Hooray for Class::ISA!

sub find_parent_methods {
    my ( $class, $this_class, $added_classes, @method_list ) = @_;
    return [] unless ( $this_class );
    unless ( ref $added_classes eq 'ARRAY' ) {
        $added_classes = [];
    }
    my @all_classes = ( @{ $added_classes },
                        Class::ISA::self_and_super_path( $this_class ) );
    my @subs = ();
    foreach my $check_class ( @all_classes ) {
        no strict 'refs';
        my $src = \%{ $check_class . '::' };
METHOD:
        foreach my $method ( @method_list ) {
            if ( defined( $src->{ $method } ) and
                 defined( my $sub = *{ $src->{ $method } }{CODE} ) ) {
                push @subs, [ $check_class, $sub ];
                $log->is_debug &&
                    $log->debug( "($this_class): Found ($method) in class ($check_class)" );
                last METHOD;
            }
        }
    }
    return \@subs;
}


########################################
# EXECUTE BEHAVIOR
########################################


# Execute behavior rules for a particular SPOPS class and slot configuration

sub exec_behavior {
    my ( $class, $slot_name, $this_class ) = @_;
    my $this_config = $this_class->CONFIG;

    # Grab the behavior list and see how many there are to execute; if
    # none, then we're all done with this slot

    my $behavior_list = $this_config->{ $PK }{behavior_table}{ $slot_name };
    return 1 unless ( ref $behavior_list eq 'ARRAY' );
    my $num_behaviors = scalar @{ $behavior_list };
    return 1 unless ( $num_behaviors > 0 );
    $log->is_debug &&
        $log->debug( "# behaviors in ($this_class)($slot_name): $num_behaviors" );

    # Cycle through the behaviors for this slot. Note that they are
    # currently unordered -- that is, the order shouldn't
    # matter. (Whether this is true remains to be seen...)

BEHAVIOR:
    foreach my $behavior ( @{ $behavior_list } ) {

        $log->is_debug &&
            $log->debug( "Running behavior for slot ($slot_name) and class ($this_class)" );

        # If this behavior has already been run, then skip it. This
        # becomes relevant when we get a RESTART status from one of
        # the behaviors (below)

        if ( $this_config->{ $PK }{behavior_run}{ $behavior } ) {
            $log->is_debug &&
                $log->debug( "Skipping behavior, already run." );
            next BEHAVIOR;
        }
        # Every behavior should return a two-element list with the
        # status and (potentially empty) message

        my ( $status, $msg ) = $behavior->( $this_class );
        $log->is_info &&
            $log->info( "Status returned from behavior: ($status)" );

        if ( $status eq ERROR ) {
            SPOPS::Exception->throw( "Cannot run behavior in [$slot_name] [$this_class]: $msg" );
        }

        # If anything but an error, go ahead and mark this behavior as
        # run. Note that we rely on coderefs always stringifying to
        # the same memory location. (This is a safe assumption, I think.)

        $this_config->{ $PK }{behavior_run}{ $behavior }++;

        # A 'DONE' means the behavior has decreed that no more
        # processing should be done in this slot

        return 1       if ( $status eq DONE );

        # An 'OK' is normal -- either the behavior declined to do
        # anything or did what it was supposed to do without issue

        next BEHAVIOR  if ( $status eq OK );

        if ( $status eq NOTIFY ) {
            warn join( "\n", "WARNING executing $slot_name for $this_config->{class}",
                             "$msg",
                             'Process will continue' ), "\n";
            next BEHAVIOR;
        }

        # RESTART is a little tricky. A 'RESTART' means that we need
        # to re-check this class for new behaviors. If we don't find
        # any new ones, no problem. If we do find new ones, then we
        # need to then re-run all behavior slots before this one. Note
        # that we will *NOT* re-run behaviors that have already been
        # run -- we're tracking them in 'behavior_run'

        if ( $status eq RESTART ) {
            $class->sync_isa( $this_class );
            my $new_behavior_map = $class->find_behavior( $this_class );
            my $behaviors_same   = $class->compare_behavior_map(
                                                     $new_behavior_map,
                                                     $this_config->{ $PK }{behavior_map} );
            next BEHAVIOR if ( $behaviors_same );
            $log->is_debug &&
                $log->debug( "Behaviors changed after receiving RESTART; re-running",
                              "from slot ($SLOTS[0]) to ($slot_name)" );
            $this_config->{ $PK }{behavior_map} = $new_behavior_map;
            for ( my $i = 0; $i <= $SLOT_NUM{ $slot_name }; $i++ ) {
                $class->exec_behavior( $SLOTS[ $i ], $this_class );
            }
        }
    }
    return 1;
}


# Sync $this_class::ISA with $this_class->CONFIG->{isa}

sub sync_isa {
    my ( $class, $this_class ) = @_;
    my $config_isa = $this_class->CONFIG->{isa};
    no strict 'refs';
    @{ $this_class . '::ISA' } = @{ $config_isa };
    $log->is_debug &&
        $log->debug( "ISA for ($this_class) synched, now: ", join( ', ', @{ $config_isa } ) );
    my ( $status, $msg ) = $class->require_config_classes( $this_class->CONFIG );
    if ( $status eq ERROR ) { SPOPS::Exception->throw( $msg ) }
    return 1;
}


# Return false if the two behavior maps don't compare (in both
# directions), true if they do

sub compare_behavior_map {
    my ( $class, $b1, $b2 ) = @_;
    return undef unless ( $class->_compare_behaviors( $b1, $b2 ) );
    return undef unless ( $class->_compare_behaviors( $b2, $b1 ) );
    return 1;
}


# Return false if all classes and slot names of behavior-1 are not in
# behavior-2

sub _compare_behaviors {
    my ( $class, $b1, $b2 ) = @_;
    return undef unless ( ref $b1 eq 'HASH' and ref $b2 eq 'HASH' );
    foreach my $b1_class ( keys %{ $b1 } ) {
        return undef unless ( $b2->{ $b1_class } );
        next if ( ! $b1->{ $b1_class } and ! $b2->{ $b1_class } );
        return undef if ( ref $b1->{ $b1_class } ne 'HASH' or ref $b2->{ $b1_class } ne 'HASH' );
        foreach my $b1_slot_name ( keys %{ $b1->{ $b1_class } } ) {
            return undef unless ( $b2->{ $b1_class }{ $b1_slot_name } );
        }
    }
    return 1;
}


########################################
# UTILITY METHODS
########################################

sub get_alias_list {
    my ( $class, $all_config, $p ) = @_;
    return [ grep ! /^_/,
                  ( ref $p->{alias_list} eq 'ARRAY' and scalar @{ $p->{alias_list} } )
                    ? @{ $p->{alias_list} }
                    : keys %{ $all_config } ];
}

1;

__END__