File Coverage

blib/lib/SPOPS/Tie.pm

Criterion	Covered	Total	%
statement	57	92	61.9
branch	0	26	0.0
condition	0	11	0.0
subroutine	19	23	82.6
pod			n/a
total	76	152	50.0

package SPOPS::Tie;

# $Id: Tie.pm,v 3.8 2004/06/02 00:48:22 lachoy Exp $

use strict;
use base  qw( Exporter );
use vars  qw( $PREFIX_TEMP $PREFIX_INTERNAL );
use Data::Dumper     qw( Dumper );
use Log::Log4perl    qw( get_logger );
use SPOPS::Exception qw( spops_error );

@SPOPS::Tie::EXPORT_OK = qw( IDX_DATA IDX_CHANGE IDX_SAVE IDX_INTERNAL IDX_TEMP
                             IDX_CHECK_FIELDS IDX_LAZY_LOADED
                             $PREFIX_TEMP $PREFIX_INTERNAL );
$SPOPS::Tie::VERSION   = sprintf("%d.%02d", q$Revision: 3.8 $ =~ /(\d+)\.(\d+)/);

use constant IDX_DATA          => '_dat';
use constant IDX_CHANGE        => '_chg';
use constant IDX_SAVE          => '_svd';
use constant IDX_INTERNAL      => '_int';
use constant IDX_TEMP          => '_tmp';
use constant IDX_IS_LAZY_LOAD  => '_ill';
use constant IDX_LAZY_LOADED   => '_ll';
use constant IDX_LAZY_LOAD_SUB => '_lls';
use constant IDX_CHECK_FIELDS  => '_chk';
use constant IDX_IS_MULTIVALUE => '_imv';
use constant IDX_MULTIVALUE    => '_mv';
use constant IDX_IS_FIELD_MAP  => '_ifm';
use constant IDX_FIELD_MAP     => '_fm';

my $log = get_logger();

$PREFIX_TEMP       = 'tmp_';
$PREFIX_INTERNAL   = '_internal';

# Tie interface stuff below here; see 'perldoc perltie' for what
# each method does. (Or better yet, read Damian Conway's discussion
# of tie in 'Object Oriented Perl'.)


# First activate the callback for the field check, then return the
# object. The object always keeps track of the actual properties, the
# class, whether the object's properties have been changed and keeps
# any temporary data that lives only for the object's lifetime.

sub TIEHASH {
    my ( $class, $base_class, $p ) = @_;
    $p ||= {};

    # See if we're supposed to do any field checking

    my $HAS_FIELD = $class->_field_check( $base_class, $p );

    # Be able to deal with either an arrayref or a hashref of multivalue fields

    if ( ref $p->{multivalue} eq 'HASH' ) {
        $p->{multivalue} = { map { lc $_ => lc $p->{multivalue}{ $_ } } keys %{ $p->{multivalue} } };
    }

    if ( ref $p->{multivalue} eq 'ARRAY' ) {
        $p->{multivalue} = { map { lc $_ => 1 } @{ $p->{multivalue} } };
    }

    # Be sure all field map fields are lower-cased
    if ( ref $p->{field_map} eq 'HASH' ) {
        $p->{field_map} = { map { lc $_ => lc $p->{field_map}{ $_ } } keys %{ $p->{field_map} } };
    }

    return bless ({ class              => $base_class,
                    IDX_TEMP()         => {},
                    IDX_INTERNAL()     => {},
                    IDX_CHANGE()       => 0,
                    IDX_SAVE()         => 0,
                    IDX_DATA()         => {},
                    IDX_IS_LAZY_LOAD() => $p->{is_lazy_load},
                    IDX_LAZY_LOADED()  => {},
                    IDX_LAZY_LOAD_SUB()=> $p->{lazy_load_sub},
                    IDX_IS_MULTIVALUE()=> ( ref $p->{multivalue} eq 'HASH' ),
                    IDX_MULTIVALUE()   => $p->{multivalue},
                    IDX_IS_FIELD_MAP() => ( ref $p->{field_map} eq 'HASH' ),
                    IDX_FIELD_MAP()    => $p->{field_map},
                    IDX_CHECK_FIELDS() => $HAS_FIELD }, $class );
}

sub _field_check { return undef; }

# Just go through each of the possible things that could be
# set and do the appropriate action.

sub FETCH {
    my ( $self, $key ) = @_;
    return unless ( $key );
    my $cmp_key = lc $key;
    $log->is_debug &&
        $log->debug( " tie: Trying to retrieve value for ($key)" );
    return $self->{ IDX_CHANGE() }                 if ( $key eq IDX_CHANGE );
    return $self->{ IDX_SAVE() }                   if ( $key eq IDX_SAVE );
    return $self->{ IDX_TEMP() }{ $cmp_key }     if ( $key =~ /^$PREFIX_TEMP/ );
    return $self->{ IDX_INTERNAL() }{ $cmp_key } if ( $key =~ /^$PREFIX_INTERNAL/ );
    return undef unless ( $self->_can_fetch( $key ) );
    if ( $self->{ IDX_IS_FIELD_MAP() } and
         $self->{ IDX_FIELD_MAP() }{ $cmp_key } ) {
        #warn "(FETCH) using field map: old value ($cmp_key) new ($self->{ IDX_FIELD_MAP() }{ $cmp_key })";
        $cmp_key = $self->{ IDX_FIELD_MAP() }{ $cmp_key };
    }
    if ( $self->{ IDX_IS_LAZY_LOAD() } and
         ! $self->{ IDX_LAZY_LOADED() }{ $cmp_key } ) {
        $self->_lazy_load( $key );
    }
    if ( $self->{ IDX_IS_MULTIVALUE() } and $self->{ IDX_MULTIVALUE() }{ $cmp_key } ) {
        #warn "(FETCH) using multivalue for key $cmp_key";
        return [ keys %{ $self->{ IDX_DATA() }{ $cmp_key } } ];
    }
    return $self->{ IDX_DATA() }{ $cmp_key };
}


sub _can_fetch { return 1 }


sub _lazy_load {
    my ( $self, $key ) = @_;
    my $cmp_key = lc $key;
    unless ( ref $self->{ IDX_LAZY_LOAD_SUB() } eq 'CODE' ) {
        spops_error "Lazy loading activated but no load function specified!";
    }
    $log->is_info &&
        $log->info( "Lazy loading [$key]; is-loaded marker empty" );
    $self->{ IDX_DATA() }{ $cmp_key } =
                    $self->{ IDX_LAZY_LOAD_SUB() }->( $self->{class},
                                                      $self->{ IDX_DATA() },
                                                      $key );
    $self->{ IDX_LAZY_LOADED() }{ $cmp_key }++;
}


# Similar to FETCH

sub STORE {
    my ( $self, $key, $value ) = @_;
    my $cmp_key = lc $key;
    $log->is_debug &&
        $log->debug( " tie: Storing [$key] => [", ( defined $value ) ? $value : 'undef', "]" );
    return $self->{ IDX_CHANGE() } = $value                 if ( $key eq IDX_CHANGE );
    return $self->{ IDX_SAVE() } = $value                   if ( $key eq IDX_SAVE );
    return $self->{ IDX_TEMP() }{ $cmp_key } = $value     if ( $key =~ /^$PREFIX_TEMP/ );
    return $self->{ IDX_INTERNAL() }{ $cmp_key } = $value if ( $key =~ /^$PREFIX_INTERNAL/ );
    return undef unless ( $self->_can_store( $key, $value ) );
    $self->{ IDX_CHANGE() }++;

    if ( $self->{ IDX_IS_FIELD_MAP() } and
         $self->{ IDX_FIELD_MAP() }{ $cmp_key } ) {
        #warn "(STORE) using field map: old value ($cmp_key) new ($self->{ IDX_FIELD_MAP() }{ $cmp_key })";
        $cmp_key = $self->{ IDX_FIELD_MAP() }{ $cmp_key };
    }

    # Non-multivalue properties just return the newly stored value

    unless ( $self->{ IDX_IS_MULTIVALUE() } and $self->{ IDX_MULTIVALUE() }{ $cmp_key } ) {
        $self->{ IDX_IS_LAZY_LOAD() } && $self->{ IDX_LAZY_LOADED() }{ $cmp_key }++;
        return $self->{ IDX_DATA() }{ $cmp_key } = $value;
    }

    #warn "(STORE) using multivalue for key $cmp_key";

    # If we're using multiple values we need to see what type of
    # $value we've got

    # If $value is undef, we clear out all values in the object

    unless ( defined $value ) {
        $self->{ IDX_DATA() }{ $cmp_key } = {};
        return undef;
    }

    my $typeof = ref $value;

    # If a scalar, just set it

    unless ( $typeof ) {
        $self->{ IDX_DATA() }{ $cmp_key }{ $value } = 1;
        return $value;
    }

    # If array, set it (if the array is empty, then we're
    # resetting the values)

    if ( $typeof eq 'ARRAY' ) {
        #warn "(STORE) Current value of ($cmp_key)", Dumper( $self->{ IDX_DATA() }{ $cmp_key } ), "";
        $self->{ IDX_DATA() }{ $cmp_key } = { map { $_ => 1 } @{ $value } };
        #warn "(STORE) Value after set of ($cmp_key)", Dumper( $self->{ IDX_DATA() }{ $cmp_key } ), "";
        return undef;
    }

    # If hash, go through each of the potential options and
    # perform the action; everything else is ignored

    if ( $typeof eq 'HASH' ) {
        my $remove_fields =  ( ref $value->{remove} eq 'ARRAY' ) ? $value->{remove} : [ $value->{remove} ];
        foreach my $rmv ( @{ $remove_fields } ) {
            next unless ( $rmv );
            delete $self->{ IDX_DATA() }{ $cmp_key }{ $rmv };
        }

        my $modify_fields = $value->{modify} || {};
        foreach my $mdfy ( keys %{ $modify_fields } ) {
            delete $self->{ IDX_DATA() }{ $cmp_key }{ $mdfy };
            $self->{ IDX_DATA() }{ $cmp_key }{ $modify_fields->{ $mdfy } } = 1
        }
        return undef;
    }

    # We don't know how to handle anything else

    spops_error "Cannot handle a value type of [$typeof] with multivalues";
}

sub _can_store { return 1 }


# For EXISTS and DELETE, We can only do these actions on the actual
# data; use the object methods for the other information.

sub EXISTS {
    my ( $self, $key ) = @_;
    $log->is_debug &&
        $log->debug( " tie: Checking for existence of ($key)" );
    return exists $self->{ IDX_DATA() }{ lc $key };
    $log->error( "Field '$key' is not valid, cannot check existence" );
}


sub DELETE {
    my ( $self, $key ) = @_;
    $log->is_debug &&
        $log->debug( " tie: Clearing value for ($key)" );
    delete $self->{ IDX_DATA() }{ lc $key };
    $self->{ IDX_CHANGE() }++;
}


# We've disabled the ability to do: $object = {} or %{ $object } = ();
# nothing bad happens, it's just a no-op

sub CLEAR {
    my ( $self ) = @_;
    $log->error( "Trying to clear object through hash means failed; use object interface" );
}


# Note that you only see the data when you cycle through the keys
# or even do a Data::Dumper::Dumper( $object ); you do not see
# the meta-data being tracked. This is a feature.

sub FIRSTKEY {
    my ( $self ) = @_;
    $log->is_debug &&
        $log->debug( " tie: Finding first key in data object" );
    keys %{ $self->{ IDX_DATA() } };
    my $first_key = each %{ $self->{ IDX_DATA() } };
    return undef unless defined $first_key;
    return $first_key;
}


sub NEXTKEY {
    my ( $self ) = @_;
    $log->is_debug &&
        $log->debug( " tie: Finding next key in data object" );
    my $next_key = each %{ $self->{ IDX_DATA() } };
    return undef unless defined $next_key;
    return $next_key;
}

1;

__END__