File Coverage

blib/lib/SPOPS.pm

Criterion	Covered	Total	%
statement	19	21	90.4
branch			n/a
condition			n/a
subroutine	7	7	100.0
pod			n/a
total	26	28	92.8

package SPOPS;

# $Id: SPOPS.pm,v 3.39 2004/06/02 00:48:20 lachoy Exp $

use strict;
use base  qw( Exporter ); # Class::Observable
use Data::Dumper    qw( Dumper );
use Log::Log4perl   qw( get_logger );
use SPOPS::ClassFactory::DefaultBehavior;
use SPOPS::Exception;
use SPOPS::Tie      qw( IDX_CHANGE IDX_SAVE IDX_CHECK_FIELDS IDX_LAZY_LOADED );
use SPOPS::Tie::StrictField;
use SPOPS::Secure   qw( SEC_LEVEL_WRITE );

my $log = get_logger();

$SPOPS::AUTOLOAD  = '';
$SPOPS::VERSION   = '0.87';
$SPOPS::Revision  = sprintf("%d.%02d", q$Revision: 3.39 $ =~ /(\d+)\.(\d+)/);

# DEPRECATED

sub DEBUG                { return 1 }
sub set_global_debug     { warn "Global debugging not supported -- use log4perl instead!\n" }

my ( $USE_CACHE );
sub USE_CACHE            { return $USE_CACHE }
sub set_global_use_cache { $USE_CACHE = $_[1] }

@SPOPS::EXPORT_OK = qw( _w _wm DEBUG );

require SPOPS::Utility;

########################################
# CLASS CONFIGURATION
########################################

# These are default configuration behaviors -- all SPOPS classes have
# the option of using them or of halting behavior before they're
# called

sub behavior_factory {
    my ( $class ) = @_;

    $log->is_info &&
        $log->info( "Installing SPOPS default behaviors for ($class)" );
    return { manipulate_configuration =>
                    \&SPOPS::ClassFactory::DefaultBehavior::conf_modify_config,
             read_code                =>
                    \&SPOPS::ClassFactory::DefaultBehavior::conf_read_code,
             id_method                =>
                    \&SPOPS::ClassFactory::DefaultBehavior::conf_id_method,
             has_a                    =>
                    \&SPOPS::ClassFactory::DefaultBehavior::conf_relate_hasa,
             fetch_by                 =>
                    \&SPOPS::ClassFactory::DefaultBehavior::conf_relate_fetchby,
             add_rule                 =>
                    \&SPOPS::ClassFactory::DefaultBehavior::conf_add_rules, };
}


########################################
# CLASS INITIALIZATION
########################################

# Subclasses should almost certainly define some behavior here by
# overriding this method

sub class_initialize {}


########################################
# OBJECT CREATION/DESTRUCTION
########################################

# Constructor

sub new {
    my ( $pkg, $p ) = @_;
    my $class = ref $pkg || $pkg;
    my $params = {};
    my $tie_class = 'SPOPS::Tie';

    my $CONFIG = $class->CONFIG;

    # Setup field checking if specified

    if ( $CONFIG->{strict_field} || $p->{strict_field} ) {
        my $fields = $class->field;
        if ( keys %{ $fields } ) {
            $params->{field} = [ keys %{ $fields } ];
            $tie_class = 'SPOPS::Tie::StrictField'
        }
    }

    # Setup lazy loading if specified

    if ( ref $CONFIG->{column_group} eq 'HASH' and
         keys %{ $CONFIG->{column_group} } ) {
        $params->{is_lazy_load}  = 1;
        $params->{lazy_load_sub} = $class->get_lazy_load_sub;
    }

    # Setup field mapping if specified

    if ( ref $CONFIG->{field_map} eq 'HASH' and
         scalar keys %{ $CONFIG->{field_map} } ) {
        $params->{is_field_map} = 1;
        $params->{field_map} = \%{ $CONFIG->{field_map} };
    }

    # Setup multivalue fields if specified

    my $multivalue_ref = ref $CONFIG->{multivalue};
    if ( $multivalue_ref eq 'HASH' or $multivalue_ref eq 'ARRAY' ) {
        my $num = ( $multivalue_ref eq 'HASH' )
                    ? scalar keys %{ $CONFIG->{multivalue} }
                    : scalar @{ $CONFIG->{multivalue} };
        if ( $num > 0 ) {
            $params->{is_multivalue} = 1;
            $params->{multivalue} = ( $multivalue_ref eq 'HASH' )
                                      ? \%{ $CONFIG->{multivalue} }
                                      : \@{ $CONFIG->{multivalue} };
        }
    }

    $params->{is_lazy_load} ||= 0;
    $params->{is_field_map} ||= 0;

    $log->is_info &&
        $log->info( "Creating new object of class ($class) with tie class ",
                    "($tie_class); lazy loading ($params->{is_lazy_load});",
                    "field mapping ($params->{is_field_map})" );

    my ( %data );
    my $internal = tie %data, $tie_class, $class, $params;
    $log->is_debug &&
        $log->debug( "Internal tie structure of new object: ", Dumper( $internal ) );
    my $self = bless( \%data, $class );

    # Set defaults if set, unless NOT specified

    my $defaults = $p->{default_values} || $CONFIG->{default_values};
    if ( ref $defaults eq 'HASH' and ! $p->{skip_default_values} ) {
        foreach my $field ( keys %{ $defaults } ) {
            if ( ref $defaults->{ $field } eq 'HASH' ) {
                my $default_class  = $defaults->{ $field }{class};
                my $default_method = $defaults->{ $field }{method};
                unless ( $default_class and $default_method ) {
                    $log->warn( "Cannot set default for ($field) without a class ",
                                "AND method being defined." );
                    next;
                }
                $self->{ $field } = eval { $default_class->$default_method( $field ) };
                if ( $@ ) {
                    $log->warn( "Cannot set default for ($field) in ($class) using",
                           "($default_class) ($default_method): $@" );
                }
            }
            elsif ( $defaults->{ $field } eq 'NOW' ) {
                $self->{ $field } = SPOPS::Utility->now;
            }
            else {
                $self->{ $field } = $defaults->{ $field };
            }
        }
    }

    $self->initialize( $p );
    $self->has_change;
    $self->clear_save;
    $self->initialize_custom( $p );
    return $self;
}


sub DESTROY {
    my ( $self ) = @_;

    # Need to check that $log exists because sometimes it gets
    # destroyed before our SPOPS objects do

    if ( $log ) {
        $log->is_debug &&
            $log->debug( "Destroying SPOPS object '", ref( $self ), "' ID: " .
                         "'", $self->id, "' at time: ", scalar localtime );
    }
}


# Create a new object from an old one, allowing any passed-in
# values to override the ones from the old object

sub clone {
    my ( $self, $p ) = @_;
    my $class = $p->{_class} || ref $self;
    $log->is_info &&
        $log->info( "Cloning new object of class '$class' from old ",
                    "object of class '", ref( $self ), "'" );
    my %initial_data = ();

    my $id_field = $class->id_field;
    if ( $id_field ) {
        $initial_data{ $id_field } = $p->{ $id_field } || $p->{id};
    }

    my $fields = $self->_get_definitive_fields;
    foreach my $field ( @{ $fields } ) {
        next if ( $id_field and $field eq $id_field );
        $initial_data{ $field } =
            exists $p->{ $field } ? $p->{ $field } : $self->{ $field };
    }

    return $class->new({ %initial_data, skip_default_values => 1 });
}


# Simple initialization: subclasses can override for
# field validation or whatever.

sub initialize {
    my ( $self, $p ) = @_;
    $p ||= {};

    # Creating a new object, all fields are set to 'loaded' so we don't
    # try to lazy-load a field when the object hasn't even been saved

    $self->set_all_loaded();

    # We allow the user to substitute id => value instead for the
    # specific fieldname.

    $self->id( $p->{id} )  if ( $p->{id} );
    #$p->{ $self->id_field } ||= $p->{id};

    # Go through the data passed in and set data for fields used by
    # this class

    my $class_fields = $self->field || {};
    while ( my ( $field, $value ) = each %{ $p } ) {
        next unless ( $class_fields->{ $field } );
        $self->{ $field } = $value;
    }
}

# subclasses can override...
sub initialize_custom { return }

########################################
# CONFIGURATION
########################################

# If a class doesn't define a config method then something is seriously wrong

sub CONFIG {
    require Carp;
    Carp::croak "SPOPS class not created properly, since CONFIG being called ",
                "from SPOPS.pm rather than your object class.";
}


# Some default configuration methods that all SPOPS classes use

sub field               { return $_[0]->CONFIG->{field} || {}              }
sub field_list          { return $_[0]->CONFIG->{field_list} || []         }
sub field_raw           { return $_[0]->CONFIG->{field_raw} || []          }
sub field_all_map {
    return { map { $_ => 1 } ( @{ $_[0]->field_list }, @{ $_[0]->field_raw } ) }
}
sub id_field            { return $_[0]->CONFIG->{id_field}                 }
sub creation_security   { return $_[0]->CONFIG->{creation_security} || {}  }
sub no_security         { return $_[0]->CONFIG->{no_security}              }

# if 'field_raw' defined use that, otherwise just return 'field_list'

sub _get_definitive_fields {
    my ( $self ) = @_;
    my $fields = $self->field_raw;
    unless ( ref $fields eq 'ARRAY' and scalar @{ $fields } > 0 ) {
        $fields = $self->field_list;
    }
    return $fields;
}

########################################
# STORABLE SERIALIZATION

sub store {
    my ( $self, @params ) = @_;
    die "Not an object!" unless ( ref $self and $self->isa( 'SPOPS' ) );
    require Storable;
    return Storable::store( $self, @params );
}

sub nstore {
    my ( $self, @params ) = @_;
    die "Not an object!" unless ( ref $self and $self->isa( 'SPOPS' ) );
    require Storable;
    return Storable::nstore( $self, @params );
}

sub retrieve {
    my ( $class, @params ) = @_;
    require Storable;
    return Storable::retrieve( @params );
}

sub fd_retrieve {
    my ( $class, @params ) = @_;
    require Storable;
    return Storable::fd_retrieve( @params );
}


########################################
# RULESET METHODS
########################################

# So all SPOPS classes have a ruleset_add in their lineage

sub ruleset_add     { return __PACKAGE__ }
sub ruleset_factory {}

# These are actions to do before/after a fetch, save and remove; note
# that overridden methods must return a 1 on success or the
# fetch/save/remove will fail; this allows any of a number of rules to
# short-circuit an operation; see RULESETS in POD
#
# clarification: $_[0] in the following can be *either* a class or an
# object; $_[1] is the (optional) hashref passed as the only argument

sub pre_fetch_action    { return $_[0]->ruleset_process_action( 'pre_fetch_action', $_[1]   ) }
sub post_fetch_action   { return $_[0]->ruleset_process_action( 'post_fetch_action', $_[1] ) }
sub pre_save_action     { return $_[0]->ruleset_process_action( 'pre_save_action', $_[1] ) }
sub post_save_action    { return $_[0]->ruleset_process_action( 'post_save_action', $_[1] ) }
sub pre_remove_action   { return $_[0]->ruleset_process_action( 'pre_remove_action', $_[1] ) }
sub post_remove_action  { return $_[0]->ruleset_process_action( 'post_remove_action', $_[1] ) }

#sub pre_fetch_action    { return shift->notify_observers( 'pre_fetch_action', @_   ) }
#sub post_fetch_action   { return shift->notify_observers( 'post_fetch_action', @_ ) }
#sub pre_save_action     { return shift->notify_observers( 'pre_save_action', @_ ) }
#sub post_save_action    { return shift->notify_observers( 'post_save_action', @_ ) }
#sub pre_remove_action   { return shift->notify_observers( 'pre_remove_action', @_ ) }
#sub post_remove_action  { return shift->notify_observers( 'post_remove_action', @_ ) }

# Go through all of the subroutines found in a particular class
# relating to a particular action

sub ruleset_process_action {
    my ( $item, $action, $p ) = @_;
    #die "This method is no longer used. Please see SPOPS::Manual::ObjectRules.\n";

    my $class = ref $item || $item;

    $action = lc $action;
    $log->is_info &&
        $log->info( "Trying to process $action for a '$class' object" );

    # Grab the ruleset table for this class and immediately
    # return if the list of rules to apply for this action is empty

    my $rs_table = $item->RULESET;
    unless ( ref $rs_table->{ $action } eq 'ARRAY'
                 and scalar @{ $rs_table->{ $action } } > 0 ) {
        $log->is_debug &&
            $log->debug( "No rules to process for [$action]" );
        return 1;
    }
    $log->is_info &&
        $log->info( "Ruleset exists in class." );

    # Cycle through the rules -- the only return value can be true or false,
    # and false short-circuits the entire operation

    my $count_rules = 0;
    foreach my $rule_sub ( @{ $rs_table->{ $action } } ) {
        $count_rules++;
        unless ( $rule_sub->( $item, $p ) ) {
            $log->warn( "Rule $count_rules of '$action' for class '$class' failed" );
            return undef;
        }
    }
    $log->is_info &&
        $log->info( "$action processed ($count_rules rules successful) without error" );
    return 1;
}


########################################
# SERIALIZATION
########################################

# Routines for subclases to override

sub save        { die "Subclass must implement save()\n" }
sub fetch       { die "Subclass must implement fetch()\n" }
sub remove      { die "Subclass must implement remove()\n" }
sub log_action  { return 1 }

# Define methods for implementors to override to do something in case
# a fetch / save / remove fails

sub fail_fetch  {}
sub fail_save   {}
sub fail_remove {}


########################################
# SERIALIZATION SUPPORT
########################################

sub fetch_determine_limit { return SPOPS::Utility->determine_limit( $_[1] ) }


########################################
# LAZY LOADING
########################################

sub get_lazy_load_sub { return \&perform_lazy_load }
sub perform_lazy_load { return undef }

sub is_loaded         { return tied( %{ $_[0] } )->{ IDX_LAZY_LOADED() }{ lc $_[1] } }

sub set_loaded        { return tied( %{ $_[0] } )->{ IDX_LAZY_LOADED() }{ lc $_[1] }++ }

sub set_all_loaded {
    my ( $self ) = @_;
    $log->is_info &&
        $log->info( "Setting all fields to loaded for object class", ref $self );
    $self->set_loaded( $_ ) for ( @{ $self->field_list } );
}

sub clear_loaded { tied( %{ $_[0] } )->{ IDX_LAZY_LOADED() }{ lc $_[1] } = undef }

sub clear_all_loaded {
    $log->is_info &&
        $log->info( "Clearing all fields to unloaded for object class", ref $_[0] );
    tied( %{ $_[0] } )->{ IDX_LAZY_LOADED() } = {};
}


########################################
# FIELD CHECKING
########################################

# Is this object doing field checking?

sub is_checking_fields { return tied( %{ $_[0] } )->{ IDX_CHECK_FIELDS() }; }


########################################
# MODIFICATION STATE
########################################

# Track whether this object has changed (keep 'changed()' for backward
# compatibility)

sub changed      { is_changed( @_ ) }
sub is_changed   { return $_[0]->{ IDX_CHANGE() } }
sub has_change   { $_[0]->{ IDX_CHANGE() } = 1 }
sub clear_change { $_[0]->{ IDX_CHANGE() } = 0 }


########################################
# SERIALIZATION STATE
########################################

# Track whether this object has been saved (keep 'saved()' for
# backward compatibility)

sub saved        { is_saved( @_ ) }
sub is_saved     { return $_[0]->{ IDX_SAVE() } }
sub has_save     { $_[0]->{ IDX_SAVE() } = 1 }
sub clear_save   { $_[0]->{ IDX_SAVE() } = 0 }


########################################
# OBJECT INFORMATION
########################################

# Return the name of this object (what type it is), title of the
# object and url (in a hashref) to be used to make a link, or whatnot.

sub object_description {
    my ( $self ) = @_;
    my $object_type = $self->CONFIG->{object_name};
    my $title_info  = $self->CONFIG->{name};
    my $title = '';
    if ( ref $title_info eq 'CODE' ) {
        warn "NOTE: Setting a coderef for the 'name' configuration ",
             "key in [$object_type] is deprecated. It will be phased ",
             "out.\n";
        $title = eval { $title_info->( $self ) };
    }
    elsif ( exists $self->{ $title_info } ) {
        $title = $self->{ $title_info };
    }
    else {
        $title = eval { $self->$title_info() };
    }
    $title ||= 'Cannot find name';
    my $oid       = $self->id;
    my $id_field  = $self->id_field;
    my $link_info = $self->CONFIG->{display};
    my ( $url, $url_edit );
    if ( $link_info->{url} ) {
        $url       = "$link_info->{url}?" . $id_field . '=' . $oid;
    }
    if ( $link_info->{url_edit} ) {
        $url_edit  = "$link_info->{url_edit}?" . $id_field . '=' . $oid;
    }
    else {
        $url_edit  = "$link_info->{url}?edit=1;" . $id_field . '=' . $oid;
    }
    return { class     => ref $self,
             object_id => $oid,
             oid       => $oid,
             id_field  => $id_field,
             name      => $object_type,
             title     => $title,
             security  => $self->{tmp_security_level},
             url       => $url,
             url_edit  => $url_edit };
}


# This is very primitive, but objects that want something more
# fancy/complicated can implement it for themselves

sub as_string {
    my ( $self ) = @_;
    my $msg = '';
    my $fields = $self->CONFIG->{as_string_order} || $self->field_list;
    my $labels = $self->CONFIG->{as_string_label} || { map { $_ => $_ } @{ $fields } };
    foreach my $field ( @{ $fields } ) {
        $msg .= sprintf( "%-20s: %s\n", $labels->{ $field }, $self->{ $field } );
    }
    return $msg;
}


# This is even more primitive, but again, we're just providing the
# basics :-)

sub as_html {
    my ( $self ) = @_;
    return "" . $self->as_string . "\n\n";
}


########################################
# SECURITY
########################################

# These are the default methods that classes not using security
# inherit. Default action is WRITE, so everything is allowed

sub check_security          { return SEC_LEVEL_WRITE }
sub check_action_security   { return SEC_LEVEL_WRITE }
sub create_initial_security { return 1 }


########################################
# CACHING
########################################

# NOTE: CACHING IS NOT FUNCTIONAL AND THESE MAY RADICALLY CHANGE

# All objects are by default cached; set the key 'no_cache'
# to a true value to *not* cache this object

sub no_cache            { return $_[0]->CONFIG->{no_cache} || 0 }

# Your class should determine how to get to the cache -- the normal
# way is to have all your objects inherit from a common base class
# which deals with caching, datasource handling, etc.

sub global_cache        { return undef }

# Actions to do before/after retrieving/saving/removing
# an item from the cache

sub pre_cache_fetch     { return 1 }
sub post_cache_fetch    { return 1 }
sub pre_cache_save      { return 1 }
sub post_cache_save     { return 1 }
sub pre_cache_remove    { return 1 }
sub post_cache_remove   { return 1 }


sub get_cached_object {
    my ( $class, $p ) = @_;
    return undef unless ( $p->{id} );
    return undef unless ( $class->use_cache( $p ) );

    # If we can retrieve an item from the cache, then create a new object
    # and assign the values from the cache to it.
    my $item_data = $class->global_cache->get({ class     => $class,
                                                object_id => $p->{id} });
    if ( $item_data ) {
        $log->is_info &&
            $log->info( "Retrieving from cache..." );
        return $class->new( $item_data );
    }
    $log->is_info &&
        $log->info( "Cached data not found." );
    return undef;
}


sub set_cached_object {
    my ( $self, $p ) = @_;
    return undef unless ( ref $self );
    return undef unless ( $self->id );
    return undef unless ( $self->use_cache( $p ) );
    return $self->global_cache->set({ data => $self });
}


# Return 1 if we're using the cache; undef if not -- right now we
# always return undef since caching isn't enabled

sub use_cache {
    return undef unless ( $USE_CACHE );
    my ( $class, $p ) = @_;
    return undef if ( $p->{skip_cache} );
    return undef if ( $class->no_cache );
    return undef unless ( $class->global_cache );
    return 1;
}


########################################
# ACCESSORS/MUTATORS
########################################

# We should probably deprecate these...

sub get { return $_[0]->{ $_[1] } }
sub set { return $_[0]->{ $_[1] } = $_[2] }


# return a simple hashref of this object's data -- not tied, not as an
# object

sub as_data_only {
    my ( $self ) = @_;
    my $fields = $self->_get_definitive_fields;
    return { map { $_ => $self->{ $_ } } grep ! /^(tmp|_)/, @{ $fields } };
}

# Backward compatible...

sub data { return as_data_only( @_ ) }

sub AUTOLOAD {
    my ( $item, @params ) = @_;
    my $request = $SPOPS::AUTOLOAD;
    $request =~ s/.*://;

    # First, give a nice warning and return undef if $item is just a
    # class rather than an object

    my $class = ref $item;
    unless ( $class ) {
        $log->warn( "Cannot fill class method '$request' from class '$item'" );
        return undef;
    }

    $log->is_info &&
        $log->info( "AUTOLOAD caught '$request' from '$class'" );

    if ( ref $item and $item->is_checking_fields ) {
        my $fields = $item->field_all_map || {};
        my ( $field_name ) = $request =~ /^(\w+)_clear/;
        if ( exists $fields->{ $request } ) {
            $log->is_debug &&
                $log->debug( "$class to fill param '$request'; returning data." );
            # TODO: make these internal methods inheritable?
            $item->_internal_create_field_methods( $class, $request );
            return $item->$request( @params );
        }
        elsif ( $field_name and exists $fields->{ $field_name } ) {
            $log->is_debug &&
                $log->debug( "$class to fill param clear '$request'; ",
                              "creating '$field_name' methods" );
            $item->_internal_create_field_methods( $class, $field_name );
            return $item->$request( @params );
        }
        elsif ( my $value = $item->{ $request } ) {
            $log->is_debug &&
                $log->debug( " $request must be a temp or something, returning value." );
            return $value;
        }
        elsif ( $request =~ /^tmp_/ ) {
            $log->is_debug &&
                $log->debug( "$request is a temp var, but no value saved. Returning undef." );
            return undef;
        }
        elsif ( $request =~ /^_internal/ ) {
            $log->is_debug &&
                $log->debug( "$request is an internal request, but no value",
                              "saved. Returning undef." );
            return undef;
        }
        $log->warn( "AUTOLOAD Error: Cannot access the method $request via <<$class>>",
               "with the parameters ", join( ' ', @_ ) );
        return undef;
    }
    my ( $field_name ) = $request =~ /^(\w+)_clear/;
    if ( $field_name ) {
        $log->is_debug &&
            $log->debug( "$class is not checking fields, so create sub and return ",
                         "data for '$field_name'" );
        $item->_internal_create_field_methods( $class, $field_name );
    }
    else {
        $log->is_debug &&
            $log->debug( "$class is not checking fields, so create sub and return ",
                         "data for '$request'" );
        $item->_internal_create_field_methods( $class, $request );
    }
    return $item->$request( @params );
}

sub _internal_create_field_methods {
    my ( $item, $class, $field_name ) = @_;

    no strict 'refs';

    # First do the accessor/mutator...
    *{ $class . '::' . $field_name } = sub {
        my ( $self, $value ) = @_;
        if ( defined $value ) {
            $self->{ $field_name } = $value;
        }
        return $self->{ $field_name };
    };

    # Now the mutator to clear the field value
    *{ $class . '::' . $field_name . '_clear' } = sub {
        my ( $self ) = @_;
        delete $self->{ $field_name };
        return undef;
    };

    return;
}


########################################
# DEBUGGING

# DEPRECATED! Use log4perl instead!

sub _w {
    my $lev   = shift || 0;
    if ( $lev == 0 ) {
        $log->warn( @_ );
    }
    elsif ( $lev == 1 ) {
        $log->is_info &&
            $log->info( @_ );
    }
    else {
        $log->is_debug &&
            $log->debug( @_ );
    }
}


sub _wm {
    my ( $lev, $check, @msg ) = @_;
    return _w( $lev, @msg );
}

1;

__END__