File Coverage

blib/lib/SPOPSx/Ginsu.pm

Criterion	Covered	Total	%
statement	11	11	100.0
branch			n/a
condition			n/a
subroutine	4	4	100.0
pod			n/a
total	15	15	100.0

package SPOPSx::Ginsu;

use strict;
use vars qw($VERSION $Revision);

BEGIN {
	$Revision = sprintf "%d.%03d", q$Revision: 1.60 $ =~ /: (\d+)\.(\d+)/;
	$VERSION = '0.58';
}

use base qw( SPOPSx::Ginsu::DBI );
use SPOPSx::Ginsu::DBI;
use SPOPS::ClassFactory;
use SPOPS::DBI;
use DBI qw( :sql_types );
use Log::Log4perl    qw( get_logger );

my $log = get_logger();

sub ROOT_OBJ_CLASS { die "Must be overridden by a root base class."; }

sub e_has_a { return { }; }

##-----  Public Class Methods  -----
sub new {
    my $class = shift;
    my $p     = shift;
# 	my $self = $class->SUPER::new($p);

	## Since SUPER::new($p) ignores keys in $p that are defined as fields
	## in the CONFIG of a parent object, we have to do the assigning of
	## these parameters manually (or fix SPOPS to handle this internally).
	my $self = $class->SUPER::new;

	foreach my $field ( @{$class->all_fields} ) {
	    $self->{$field} = defined $p->{$field} ? $p->{$field} : undef;
	}

	$self->{class} = ref($self);

	return $self;
}

sub isa_classes {
	my $self	= shift;
	my $isa		= $self->_isa_classes;

	return [ sort { $isa->{$a} <=> $isa->{$b} } keys %$isa ];
}

sub inherited_fields {
	my $class	= shift;
	$class = ref($class)	if ref($class);	## get class if passed an object

	my $fields = [];
	foreach my $c ( @{$class->isa_classes} ) {
		next if $c eq $class;
		foreach my $field ( @{$c->field_list} ) {
			push @$fields, $field	unless $field eq $c->id_field;
		}
	}

	return $fields;
}

sub all_fields { return [ @{$_[0]->field_list}, @{$_[0]->inherited_fields} ]; }

sub all_field_types {
	my $class	= shift;
	my $p		= shift;
	$class = ref($class)	if ref($class);	## get class if passed an object

	my $type_info = {};
	foreach my $c ( @{$class->isa_classes} ) {
		my $c_types = { $c->db_discover_types( $c->base_table, $p )->as_hash };
		foreach my $field ( @{$c->field_list} ) {
			$type_info->{$field} = $c_types->{$field}
				unless $field eq $c->id_field && $c ne $class; ## skip parent table ids
		}
	}

	return $type_info;
}

sub config_and_init {
	my $class = shift;

	SPOPS::ClassFactory->create( $class->_build_conf )
		unless $class->_config_processed;

	$class->class_initialize;
}

## copied straight from SPOPS::DBI, with the modifications as noted
sub fetch {
    my ( $class, $id, $p ) = @_;
    $p ||= {};

    $log->is_debug &&
        $log->debug( "Trying to fetch an item of $class with ID $id and params ",
                     join( " // ", map { sprintf( "%s -> %s", $_, defined $p->{$_} ? $p->{$_} : '' )  }
                                        grep { defined $_ } keys %{ $p } ) );

    # No ID, no object

    return undef  unless ( defined( $id ) and $id ne '' and $id !~ /^tmp/ );

    # Security violations bubble up to caller

    my $level = $p->{security_level};
    unless ( $p->{skip_security} ) {
        $level ||= $class->check_action_security({ id       => $id,
                                                   required => SPOPS::Secure::SEC_LEVEL_READ });
    }

    # Do any actions the class wants before fetching -- note that if
    # any of the actions returns undef (false), we bail.

    return undef unless ( $class->pre_fetch_action( { %{ $p }, id => $id } ) );

    my $obj = undef;

    # If we were passed the data for an object, go ahead and create
    # it; if not, check to see if we can whip up a cached object

    if ( ref $p->{data} eq 'HASH' ) {
        $obj = $class->new({ %{ $p->{data} }, skip_default_values => 1 });
    }
    else {
        $obj = $class->get_cached_object({ %{ $p }, id => $id });
        $p->{skip_cache}++;         # Set so we don't re-cache it later
    }

    unless ( ref $obj eq $class ) {
##-----  REPLACE THIS ORIGINAL CODE  -----
#         my ( $raw_fields, $select_fields ) = $class->_fetch_select_fields( $p );
##-----  WITH THIS OVERRIDING CODE  -----
		## Note: this code skips the column group and alter field stuff
		my $table_name		= $class->base_table;
		my $my_id_field		= $class->id_field;
		my $raw_fields		= [];
		my $select_fields	= [];
		my $sqltables		= [];
		my $sqlwhere		= [];
		foreach my $parent_class ( @{$class->isa_classes} ) {
			my $table		= $parent_class->table_name;
			my $id_field	= $parent_class->id_field;

			push @$sqltables, $table;	## list of tables for "FROM" clause

			## join tables by id field (set all equal to id field of this class)
			push @$sqlwhere,	$table . '.' . $id_field . ' = ' .
								$table_name . '.' . $my_id_field
									unless($table_name eq $table);

			## all fields, except id of inherited tables
			foreach my $field ( keys %{$parent_class->field} ) {
				next if $parent_class ne $class && $field eq $id_field;
				push @$select_fields, $table . '.' . $field;
				push @$raw_fields, $field;
			}
		}
		push @$sqlwhere, $class->id_clause( $id, undef, $p );
##-----  END OVERRIDING CODE  -----
        $log->is_info &&
            $log->info( "SELECTing: ", join( "//", @{ $select_fields } ) );

        # Put all the arguments into a hash (so we can reuse them simply
        # later) and grab the record

##-----  REPLACE THIS ORIGINAL CODE  -----
#         my %args = (
#             from   => [ $class->table_name ],
#             select => $select_fields,
#             where  => $class->id_clause( $id, undef, $p ),
##-----  WITH THIS OVERRIDING CODE  -----
		my %args = (
			from   => $sqltables,
			select => $select_fields,
			where  => join(' AND ', @$sqlwhere),
##-----  END OVERRIDING CODE  -----
			db     => $p->{db},
			return => 'single',
        );
        my $row = eval { $class->db_select( \%args ) };
        if ( $@ ) {
            $class->fail_fetch( \%args );
            die $@;
        }

        # If the row isn't found, return nothing; just as if an incorrect
        # (or nonexistent) ID were passed in

        return undef unless ( $row );

        # Note that we pass $p along to the ->new() method, in case
        # other information was passed in needed by it -- however, we
        # need to be careful that certain parameters used by this
        # method (e.g., the optional 'field_alter') is not the same as
        # a parameter of an object -- THAT would be fun to debug...

        $obj = $class->new({ id => $id, skip_default_values => 1, %{ $p } });
        $obj->_fetch_assign_row( $raw_fields, $row, $p );
    }
    return $obj->_fetch_post_process( $p, $level );
}

## copied straight from SPOPS::DBI, with the modifications as noted
sub fetch_group {
    my ( $class, $p ) = @_;
##-----  REPLACE THIS ORIGINAL CODE  -----
#     ( $p->{raw_fields}, $p->{select} ) = $class->_construct_group_select( $p );
##-----  WITH THIS OVERRIDING CODE  -----
	## Note: this code skips the column group and alter field stuff
	my $table_name = $class->table_name;
	my $p_original = $p ? { %$p } : {};
	my $my_id_field		= $class->id_field;
	my $raw_fields		= [];
	my $select_fields	= [];
	my $sqltables		= [];
	my $sqlwhere		= [];

	foreach my $parent_class ( @{$class->isa_classes} ) {
		my $table		= $parent_class->table_name;
		my $id_field	= $parent_class->id_field;

		push @$sqltables, $table;	## list of tables for "FROM" clause

		## join tables by id field (set all equal to id field of this class)
		push @$sqlwhere,	$table . '.' . $id_field . ' = ' .
							$table_name . '.' . $my_id_field
								unless($table_name eq $table);

		## all fields, except id of inherited tables
		foreach my $field ( keys %{$parent_class->field} ) {
			next if $parent_class ne $class && $field eq $id_field;
			push @$select_fields, $table . '.' . $field;
			push @$raw_fields, $field;
		}
	}

	## original table list and WHERE clause
	push @$sqltables, @{ $p->{from} }	if $p->{from};
	push @$sqlwhere, $p->{where}		if $p->{where};

	$p->{where}			= join(' AND ', @$sqlwhere);
	$p->{from}   		= $sqltables;
	$p->{select} 		= $select_fields;
	$p->{raw_fields}	= $raw_fields;

	## get indices into rows of class name and object id
	my ($classname_idx) = grep $raw_fields->[$_] eq 'class', (0..$#{$raw_fields});
	my ($id_field_idx)  = grep $raw_fields->[$_] eq $class->id_field, (0..$#{$raw_fields});
##-----  END OVERRIDING CODE  -----
    my $sth              = $class->_execute_multiple_record_query( $p );
    my ( $offset, $max ) = SPOPS::Utility->determine_limit( $p->{limit} );
    my @obj_list = ();

    my $row_count = 0;
ROW:
    while ( my $row = $sth->fetchrow_arrayref ) {
##-----  BEGIN ADDITIONAL CODE  -----
		my $newclass = $row->[ $classname_idx ];
		if ($newclass eq $class) {
##-----  END ADDITIONAL CODE  -----
        my $obj = $class->new({ skip_default_values => 1 });
        $obj->_fetch_assign_row( $p->{raw_fields}, $row, $p );

        next ROW unless ( $obj ); # How could this ever be true?

        # Check security on the row unless overridden by
        # 'skip_security'. If the security check fails that's ok, just
        # skip the row and move on

        my $sec_level = SPOPS::Secure::SEC_LEVEL_WRITE;
        unless ( $p->{skip_security} ) {
            $log->is_debug &&
                $log->debug( "Checking security for [", ref( $obj ), ": ", $obj->id, "]" );
            $sec_level = eval {
                $obj->check_action_security({ required => SPOPS::Secure::SEC_LEVEL_READ })
            };
            if ( $@ ) {
                $log->is_info &&
                    $log->info( "Security check for object in ",
                                          "fetch_group() failed, skipping." );
                next ROW;
            }
        }

        # Not to the offset yet, so go to the next row but still increment
        # the counter so we calculate limits properly

        if ( $offset and ( $row_count < $offset ) ) {
            $row_count++;
            next ROW;
        }
        last ROW if ( $max and ( $row_count >= $max ) );
        $row_count++;

        # If we've made it down to here, we're home free; just call the
        # post_fetch callback

        next ROW unless ( $obj->_fetch_post_process( $p, $sec_level ) );
        push @obj_list, $obj;
##-----  BEGIN ADDITIONAL CODE  -----
		} else {
			next ROW unless UNIVERSAL::isa($newclass, $class);
			my $obj = $newclass->fetch( $row->[ $id_field_idx ], $p_original);
        next ROW unless ( $obj );

		## deleted security check (done by fetch)

        # Not to the offset yet, so go to the next row but still increment
        # the counter so we calculate limits properly

        if ( $offset and ( $row_count < $offset ) ) {
            $row_count++;
            next ROW;
        }
        last ROW if ( $max and ( $row_count >= $max ) );
        $row_count++;

		## deleted _post_fetch_process (done by fetch)
        push @obj_list, $obj;
		}
##-----  END ADDITIONAL CODE  -----
    }
    $sth->finish;
    return \@obj_list;
}

## copied straight from SPOPS::DBI, with the modifications as noted
sub fetch_count {
    my ( $class, $p ) = @_;
    my $row_count = 0;
##-----  REPLACE THIS ORIGINAL CODE  -----
#   if ( $p->{skip_security} ) {
#       $p->{select} = [ 'COUNT(*)' ];
#       my $db = $p->{db}
#                || $class->global_datasource_handle( $p->{connect_key} );
#       my $row_count_rec = eval {
#           $class->db_select({ select => [ 'COUNT(*)' ],
#                               where  => $p->{where},
#                               value  => $p->{value},
#                               from   => $class->table_name,
#                               return => 'single',
#                               db     => $db })
#       };
#       $row_count = $row_count_rec->[0];
#       if ( $@ ) {
#           $log->warn( "Caught error running SELECT COUNT(*): $@" );
#       }
#   }
#   else {
#       $p->{select} = [ $class->id_field_select( $p ) ];
##-----  WITH THIS OVERRIDING CODE  -----
		## should be fine if the class has a table,
		## except we can't use inherited fields in WHERE clause
		## without doing explicit join
		return $class->SUPER::fetch_count($p) if $class->_config_processed;

		my $obj_table = $class->ROOT_OBJ_CLASS->table_name;
		my $my_table  = $class->table_name;
		$p->{select} = [ $class->id_field_select( $p ), "$obj_table.class" ];
		if ($my_table ne $obj_table) {
			push @{$p->{from}}, $obj_table;
			my @where = $obj_table . '.' . $class->ROOT_OBJ_CLASS->id_field . ' = ' .
						$my_table . '.' . $class->id_field;
			push @where, $p->{where}	if $p->{where};
			$p->{where} = join(' AND ', @where);
		}
##-----  END OVERRIDING CODE  -----
        my $sth = $class->_execute_multiple_record_query( $p );
        while ( my $row = $sth->fetch ) {
            eval {
                $class->check_action_security({ id       => $row->[0],
                                                required => SPOPS::Secure::SEC_LEVEL_READ })
            };
            next if ( $@ );
##-----  BEGIN ADDITIONAL CODE  -----
			next unless UNIVERSAL::isa($row->[1], $class);
##-----  END ADDITIONAL CODE  -----
            $row_count++;
        }
##-----  BEGIN REMOVE CODE  -----
#     }
##-----  END REMOVE CODE  -----
    return $row_count;
}

sub pm_fetch {
	my ( $class, $id, $p ) = @_;

	$p->{where} = $class->id_clause( $id );
	my $obj = $class->fetch_group( $p )->[0];

	return $obj;
}

sub fetch_group_by_field {
	my ( $class, $field, $vals, $p ) = @_;
	return []	unless @$vals;

	my $where = $class->base_table . ".$field" .
				' IN (' . join(',', map('?', @$vals)) . ')';
	$where .= ' AND (' . $p->{where} . ')'	if $p->{where};
	$p->{where} = $where;
	unshift @{$p->{value}}, @$vals;

	my $objs = $class->fetch_group( $p );

	return $objs;
}

sub fetch_group_by_ids {
	my ( $class, $ids, $p ) = @_;

	my $unordered = $class->fetch_group_by_field( $class->id_field, $ids, $p );

	## order by id list
	my %obj_by_id	= map { $_->id => $_ } @$unordered;
	my @ordered		= grep { $_ } map { $obj_by_id{$_} } @$ids;

	return \@ordered;
}

##-----  Public Object Methods  -----
## copied straight from SPOPS::DBI, with the modifications as noted
sub save {
    my ( $self, $p ) = @_;
    $log->is_info &&
        $log->info( "Trying to save a (", ref $self, ")" );

    # We can force save() to be an INSERT by passing in a true value
    # for the is_add parameter; otherwise, we rely on the flag within
    # SPOPS::Tie to reflect whether an object has been saved or not.

    my $is_add = ( $p->{is_add} or ! $self->saved );

    # If this is an update and it hasn't changed, we don't need to do
    # anything.

    unless ( $is_add or $self->changed ) {
        $log->is_info &&
            $log->info( "This object exists and has not changed. Exiting." );
        return $self;
    }

    # Check security for create/update

    my $action = ( $is_add ) ? 'create' : 'update';
    my ( $level );
    unless ( $p->{skip_security} ) {
        $level = $self->check_action_security({ required => SPOPS::Secure::SEC_LEVEL_WRITE,
                                                is_add   => $is_add });
    }
    $log->is_info &&
        $log->info( "Security check passed ok. Continuing." );

    # Callback for objects to do something before they're saved

    return undef unless ( $self->pre_save_action({ %{ $p },
                                                   is_add => $is_add }) );

##-----  BEGIN ADDITIONAL CODE  -----
	## get list of classes which need to be saved
	## (put ROOT_OBJ_CLASS first, and this class last)
	my $no_insert = $p->{no_insert};	## this gets converted to an empty hash
										## which causes problems the 2nd time through
	my @classes = reverse @{ $self->isa_classes };
	foreach my $class (@classes) {
		bless $self, $class;
		$p->{field} = [];
		$p->{value} = [];
		$p->{no_insert} = $no_insert;
##-----  END ADDITIONAL CODE  -----
    # Do not include these fields in the insert/update at all. Allow
    # user to override even with an empty arrayref.

    my ( %not_included );
    if ( $is_add ) {
        my ( @no_insert_items );
        if ( $p->{no_insert} ) {
            @no_insert_items = ( ref $p->{no_insert} eq 'ARRAY' )
                                 ? @{ $p->{no_insert} } : ( $p->{no_insert} );
        }
        elsif ( my $no_insert_config = $self->no_insert ) {
            @no_insert_items = keys %{ $no_insert_config };
        }
        %not_included = map { $_ => 1 } @no_insert_items;
    }
    else {
        my ( @no_update_items );
        if ( $p->{no_update} ) {
            @no_update_items = ( ref $p->{no_update} eq 'ARRAY' )
                                 ? @{ $p->{no_update} } : ( $p->{no_update} );
        }
        elsif ( my $no_update_config = $self->no_update ) {
            @no_update_items = keys %{ $no_update_config };
        }
        %not_included = map { $_ => 1 } @no_update_items;
    }

    # Do not include these fields in the insert/update if they're not defined
    # (note that this includes blank/empty)

    $p->{skip_undef} ||= [];
    my $skip_undef = $self->skip_undef || {};
    $skip_undef->{ $_ }++ for ( @{ $p->{skip_undef} } );

    $p->{field} = [];
    $p->{value} = [];

FIELD:
    foreach my $field ( keys %{ $self->field } ) {
        next FIELD if ( $not_included{ $field } );
        my $value = $self->{ $field };
        next FIELD if ( ! defined $value and $skip_undef->{ $field } );
        push @{ $p->{field} }, $field;
        push @{ $p->{value} }, $value;
    }

    # Do the insert/update based on whether the object is new; don't
    # catch the die() that might be thrown -- let that percolate

##-----  REPLACE THIS ORIGINAL CODE  -----
#   if ( $is_add ) { $self->_save_insert( $p, \%not_included )  }
##-----  WITH THIS OVERRIDING CODE  -----
	if ( $is_add ) {
		eval { $self->_save_insert( $p, \%not_included ) };
		## clean up partial saves if there is a duplicate entry error
		if (my $error = $@) {		## save $@ from getting overwritten
									## in remove_from_parent_tables()
			$self->_remove_from_parent_tables if $error =~ /Duplicate entry/;
			die $error;
		}
	}
##-----  END OVERRIDING CODE  -----
    else           { $self->_save_update( $p, \%not_included )  }
##-----  BEGIN ADDITIONAL CODE  -----
	}
##-----  END ADDITIONAL CODE  -----

    # Set the 'has_save' flag so that any saved changes to the object
    # in the post_save will be an update rather than another insert;
    # clear the changed fields for the same reason

    $self->has_save;
    $self->clear_change;

    # Do any actions that need to happen after you save the object

    return undef unless ( $self->post_save_action({ %{ $p },
                                                    is_add => $is_add }) );

    # Save the newly-created/updated object to the cache

    $self->set_cached_object( $p );

    # Note the action that we've just taken (opportunity for subclasses)

    unless ( $p->{skip_log} ) {
        $self->log_action( $action, scalar $self->id );
    }

    return $self;
}

sub compare {
	my $self	= shift;
	my $twin	= shift;
	my $p		= shift;

	## must be objects of the same type
	return 0 unless ref($self) eq ref($twin);

	## and their fields must all have the same values
	my $type_info = $self->all_field_types($p);
	foreach my $field ( @{$self->all_fields} ) {
		next if $field eq $self->id_field;
		next unless defined $self->{$field} || defined $twin->{$field};
		return 0 unless defined $self->{$field} && $twin->{$field};
		if ( ref($self->{$field}) ) {
			return 0 unless $self->{$field}->compare($twin->{$field});
		} else {
			if ( $self->_is_numeric_type($type_info->{$field}) ) {
				return 0 unless $self->{$field} == $twin->{$field};
			} else {
				return 0 unless $self->{$field} eq $twin->{$field};
			}
		}
	}

	return 1;
}

sub as_string {
	my $self = shift;
	my $tab = shift || '';
	my $fields = $self->CONFIG->{as_string_order} || $self->all_fields;
	my $msg = '';
	foreach my $field (@$fields){
		$msg .= $tab.sprintf( "%-20s: %s\n", $field, defined $self->{$field} ? $self->{$field} : '');
		my $ref = ref $self->{$field};
		next unless ($ref  && $ref ne 'HASH' && $ref ne 'ARRAY');
		$msg .= $self->{$field}->as_string("\t");
	}
	return $msg;
}

##-----  Private Class Methods  -----
## overrides method in SPOPS
sub _get_definitive_fields {	return $_[0]->all_fields; }

sub _build_conf {
	my $class = shift;
	my $conf  = shift || {};

	# get the conf variable for the class.
	my $class_conf = $class->_get_CONF;
	# get the alias for the class
	my $alias = $class->_get_main_alias;

	unless (exists ($conf->{$alias})) {
		$conf->{$alias} = $class_conf->{$alias};
	}
	my $class_links = $class->_get_links_to || '';
	if ($class_links) {
		foreach my $key (keys %$class_links) {
			next if ($key->_config_processed ||
			         exists $conf->{$key->_get_main_alias});
			$conf = $key->_build_conf($conf);
		}
	}#end if
	return $conf;
}

sub _get_main_alias {
	## This method can be used to find the main alias even
	## before the class's configuration has been processed.
	my $class = shift;
	my $conf = eval '$' . $class . '::CONF';
	my ($alias) = grep $conf->{$_}->{class} eq $class, keys %$conf;

	return $alias;
}

sub _get_CONF 		 { return eval '$' . $_[0] . '::CONF'; }
sub _get_links_to	 { return $_[0]->_get_CONF->{$_[0]->_get_main_alias}->{links_to}; }

sub _config_processed {
	no strict 'refs';
	my $CONFIG_method = *{$_[0]."::CONFIG"}{CODE};
	return ref($CONFIG_method) eq 'CODE';
}

sub _is_numeric_type {
	my $self		= shift;
	my $type_info	= shift;

	return grep $type_info == $_, (	SQL_NUMERIC,
									SQL_DECIMAL,
									SQL_INTEGER,
									SQL_SMALLINT,
									SQL_FLOAT,
									SQL_REAL,
									SQL_DOUBLE,
# (no longer in DBI)				SQL_BIGINT,
									SQL_TINYINT	);
}

sub _isa_classes {
	my $class	= shift;
	my $href	= shift || {};
	my $depth	= shift || 1;

	$class = ref($class)	if ref($class);	## get class if passed an object
	$href->{$class} = $depth;				## stick it as a key in the hash

	foreach my $parent ( @{$class->CONFIG->{isa}} ) {
		next unless $parent->isa($class->ROOT_OBJ_CLASS);
		$href = $parent->_isa_classes($href, $depth+1)
			unless $href->{$parent} && $href->{$parent} > $depth+1;
	}
	return $href;
}

##-----  Private Object Methods  -----
sub _remove_from_parent_tables {
	my $self = shift;
	my $p    = shift || {};

	foreach my $class (@{ $self->isa_classes }) {
		next if $class eq ref($self);
		eval {
			$class->db_delete({
					table => $class->table_name,
					where => $class->id_clause($self->id, 'noqualify', {%$p}),
					db	  => $p->{db},
				})
		};
		warn "Unable to remove row from ". $class->table_name if $@;
	}

	return 1;
}

##-----  Callback Methods  -----
sub post_fetch_action {
	my $self	= shift;
	my $orig_p	= shift || {};

	## call the overridden post_fetch_action to handle rulesets
	$self->SUPER::post_fetch_action( $orig_p );

	foreach my $field ( keys %{ $self->e_has_a } ) {
		my $h = $self->e_has_a->{$field};
		if ( $h->{fetch} && $h->{fetch}{type} eq 'auto' ) {
			if ( my $val = $self->{$field} ) {
				my %p;
				$p{db} = $orig_p->{db} if defined $orig_p->{db};
				$self->{$field} = $h->{class}->pm_fetch($val, \%p ) ||
					die "Could not auto-fetch '$field' ($h->{class}) id: $val";
			}
		}
	}

	return $self;
}

sub pre_save_action {
	my $self	= shift;
	my $orig_p	= shift || {};

	## call the overridden pre_save_action to handle rulesets
	$self->SUPER::pre_save_action( $orig_p );

	foreach my $field ( keys %{ $self->e_has_a } ) {
		my $h = $self->e_has_a->{ $field };
		my $val = $self->{$field};
		if ( $val && ref $val ) {
			## save if indicated
			my %p;
			$p{db} = $orig_p->{db} if defined $orig_p->{db};
			$val->save( \%p )	if $h->{fetch} && !$h->{fetch}{nosave};

			## move object to a temp field during save
			$self->{'tmp_' . $field . '_'} = $val;
			$self->{$field} = $self->{$field}->id;
		}
	}

	return $self;
}

sub post_save_action {
	my $self	= shift;
	my $orig_p	= shift || {};

	## call the overridden post_save_action to handle rulesets
	$self->SUPER::post_save_action( $orig_p );;

	foreach my $field ( keys %{ $self->e_has_a } ) {
		my $h = $self->e_has_a->{$field};
		my $val = $self->{'tmp_' . $field . '_'};
		if ( $val && ref $val ) {
			$self->{$field} = $val;
			$self->{'tmp_' . $field . '_'} = undef;
		} elsif ( $h->{fetch} && $h->{fetch}{type} eq 'auto' ) {
			if ( my $val = $self->{$field} ) {
				my %p;
				$p{db} = $orig_p->{db} if defined $orig_p->{db};
				$self->{$field} = $h->{class}->pm_fetch($val, \%p ) ||
					die "Could not auto-fetch '$field' ($h->{class}) id: $val";
			}
		}
	}

	return $self;
}

sub pre_remove_action {
	my $self	= shift;
	my $orig_p	= shift || {};
	my $class	= ref($self);

	## call the overridden pre_remove_action to handle rulesets
	$self->SUPER::pre_remove_action( $orig_p );

	## auto-remove specified secondary objects
	foreach my $field ( keys %{ $self->e_has_a } ) {
		my $h = $self->e_has_a->{$field};
		if ( $h->{remove} && $h->{remove}{type} eq 'auto' && $self->{$field} ) {
			my %p;
			$p{db} = $orig_p->{db} if defined $orig_p->{db};
			$self->{$field} = $h->{class}->pm_fetch($self->{$field}, \%p )
				unless ref $self->{$field};
			$self->{$field}->remove( $orig_p )	if $self->{$field};
		}
	}

	## remove all corresponding rows in 'links_to' tables
	my ($table, $where);
	foreach $table ( values %{$self->CONFIG->{links_to}} ) {
		$where = $self->id_clause(undef, 'noqualify', $orig_p);
		eval { $self->db_delete( {	table => $table,
									where => $where,
									db	  => $orig_p->{db}  }) };
		if ( $@ ) {
			warn "Unable to remove links.";
		}
	}

	## remove corresponding row in each parent table
	$self->_remove_from_parent_tables;

	return $self;
}

1;
__END__