SPOPS::Tie - Simple class implementing tied hash with some goodies

SPOPS documentation Contained in the SPOPS distribution.

Index

Code Index:

NAME

Top

SPOPS::Tie - Simple class implementing tied hash with some goodies

SYNOPSIS

Top

 # Create the tied hash
 use SPOPS::Tie;
 my ( %data );
 my @fields = qw( first_name last_name login birth_date );
 tie %data, 'SPOPS::Tie', $class, \@fields;

 # Store some simple properties
 $data{first_name} = 'Charles';
 $data{last_name}  = 'Barkley';
 $data{login}      = 'cb';
 $data{birth_date} = '1957-01-19';

 # Store a temporary property
 $data{tmp_rebound_avg} = 11.3;

 while ( my ( $prop, $val ) = each %data ) {
   printf( "%-15s: %s\n", $prop, $val );
 }

 # Note that output does not include 'tmp_rebound_avg'
 >first_name     : Charles
 >login          : cb
 >last_name      : Barkley
 >birth_date     : 1957-01-19

 print "Rebounding Average: $data{tmp_rebound_avg}\n";

 # But you can access it still the same
 >Rebounding Average: 11.3

DESCRIPTION

Top

Stores data for a SPOPS object, and also some accompanying materials such as whether the object has been changed and any temporary variables.

Checking Changed State

You can check whether the data have changed since the last fetch by either calling the method of the SPOPS object (recommended) or asking for the '_changed' key from the tied() object:

 # See if this object has changed
 if (tied %data){_changed} ) {;
  ...do stuff...
 } 

 # Tell the object that it has changed (force)
 (tied %data){_changed} = 1;

Note that this state is automatically tracked based on whether you set any property of the object, so you should never need to do this. See SPOPS for more information about the changed methods.

Tracking Temporary Variables

Note that this section only holds true if you have field-checking turned on (by passing an arrayref of fields in the 'field' key of the hashref passed as the second parameter in the tie call).

At times you might wish to keep information with the object that is only temporary and not supposed to be serialized with the object. However, the 'valid property' nature of the tied hash prevents you from storing information in properties with names other than those you pass into the initial call to tie(). What to do?

Have no fear! Simply prefix the property with 'tmp_' (or something else, see below) and SPOPS::Tie will keep the information at the ready for you:

 my ( %data );
 my $class = 'SPOPS::User';
 tie %data, 'SPOPS::Tie', $class, [ qw/ first_name last_name login / ];
 $data{first_name} = 'Chucky';
 $data{last_name}  = 'Gordon';
 $data{login}      = 'chuckg';
 $data{tmp_inoculation} = 'Jan 16, 1981';

For as long as the hash %data is in scope, you can reference the property 'tmp_inoculation'. However, you can only reference it directly. You will not see the property if you iterate through hash using keys or each.

Lazy Loading

You can specify you want your object to be lazy loaded when creating the tie interface:

  my $fields = [ qw/ first_name last_name login life_history / ];
  my $params = { is_lazy_load  => 1,
                 lazy_load_sub => \&load_my_variables,
                 field         => $fields };
  tie %data, 'SPOPS::Tie', $class, $params;

Storing Information for Internal Use

The final kind of information that can be stored in a SPOPS object is 'internal' information. This is similar to temporary variables, but is typically only used in the internal SPOPS mechanisms -- temporary variables are often used to store computed results or other information for display rather than internal use.

For example, the SPOPS::DBI module could allow you to create validating subroutines to ensure that your data conform to some sort of specification:

 push @{ $obj->{_internal_validate} }, \&ensure_consistent_date;

Most of the time you will not need to deal with this, but check the documentation for the object you are using.

Field Mapping

You can setup a mapping of fields to make an SPOPS object look like another SPOPS object even though its storage is completely different. For instance, say we were tying a legacy data management of system of book data to a website. Our web designers do not like to see FLDNMS LK THS since they are used to the more robust capabilities of modern data systems.

So we can use the field mapping capabilities of SPOPS::Tie to make the objects more palatable:

 my $obj = tie %data, 'SPOPS::Tie', 'My::Book',
                      { field_map => { author         => 'AUTH',
                                       title          => 'TTL',
                                       printing       => 'PNUM',
                                       classification => 'CLSF' } };

(See the SPOPS documentation for how to declare this in your SPOPS configuration.)

So your web designers can use the objects:

 print "Book author: $book->{author}\n",
       "Title: $book->{title}\n";

But the data are actually stored in the object (and retrieved by an each query on the object -- be careful) using the old, ugly names 'AUTH', 'TTL', 'PNUM' and 'CLSF'.

This can be extremely helpful not only to rename fields for aesthetic reasons, but also to make objects conform to the same interface.

Multivalue Fields

Some data storage backends -- such as LDAP -- can store multiple values for a single field, and SPOPS::Tie can represent it.

Three basic rules when dealing with multivalue fields:

1.

No duplicate values allowed.

2.

Values are not sorted. If you need sorted values, use the tools perl provides you.

3.

Values are always retrieved from a multivalue field as an array reference.

The interface for setting values is somewhat different, so sit up straight and pay attention.

(0) Telling SPOPS::Tie

 my $obj = tie %data, 'SPOPS::Tie', 'My::LDAP::Person',
                      { multivalue => [ 'objectclass' ] };

This means only the field 'objectclass' will be treated as a multivalue field.

(1) Creating a new object

 my $person = My::LDAP::Person->new();
 $person->{objectclass} = [ 'inetOrgPerson', 'organizationalPerson',
                            'person' ];
 $person->{sn}          = 'Winters';
 $person->{givenname}   = 'Chris';
 $person->{mail}        = 'chris@cwinters.com';
 $person->save;

The property 'objectclass' here is multivalued and currently has three values: 'inetOrgPerson', 'organizationalPerson', and 'person'.

(2) Fetching and displaying an object

 my $person = My::LDAP::Person->fetch( 'chris@cwinters.com' );
 print "Person info: $person->{givenname} $person->{sn} ",
       "(mail: $person->{mail})\n";
 print "Classes: ", join( ', ', @{ $person->{objectclass} } ), "\n";

Displays:

 > Person info: Chris Winters (mail: chris@cwinters.com)
 > Classes: inetOrgPerson, organizationalPerson, person

Note that if there were no values for defined for objectclass, the value retrieval would return an arrayref. Value retrievals always return an array reference, even if there are no values. This is to provide consistency of interface, and so you can always use the value as an array reference without cumbersome checking to see if the value is undef.

(3) Setting a single value

 my $person = My::LDAP::Person->fetch( 'chris@cwinters.com' );
 $person->{objectclass} = 'newSchemaPerson';
 $person->save;

The property 'objectclass' now has four values: 'inetOrgPerson', 'organizationalPerson', 'person', and 'newSchemaPerson'.

(4) Setting all values

 my $person = My::LDAP::Person->fetch( 'chris@cwinters.com' );
 $person->{objectclass} = [ 'newSchemaPerson', 'reallyNewPerson' ];
 $person->save;

The property 'objectclass' now has two values: 'newSchemaPerson', 'reallyNewPerson'.

(5) Removing one value

 my $person = My::LDAP::Person->fetch( 'chris@cwinters.com' );
 $person->{objectclass} = { remove => 'newSchemaPerson' };
 $person->save;

The property 'objectclass' now has one value: 'reallyNewPerson'.

 my $object_class_thingy = $person->{objectclass};
 print "Object class return is a: ", ref $object_class_thingy, "\n";

Displays:

 > Object class return is a: ARRAY

Again: when a multivalued property is retrieved it always returns an arrayref, even if there is only one value.

(6) Modifying one value

 my $person = My::LDAP::Person->fetch( 'chris@cwinters.com' );
 $person->{objectclass} =
      { modify => { reallyNewPerson => 'totallyNewPerson' } };
 $person->save;

The property 'objectclass' still has one value, but it has been changed to: 'totallyNewPerson'.

Note: you could have gotten the same result in this example by doing:

 $person->{objectclass} = [ 'totallyNewPerson' ];
 $person->save;

(7) Removing all values

 my $person = My::LDAP::Person->fetch( 'chris@cwinters.com' );
 $person->{objectclass} = undef;
 $person->save;

The property 'objectclass' now has no values.

You can also get the same result with:

 $person->{objectclass} = [];
 $person->save;

METHODS

Top

See Tie::Hash (Tie::Hash) or perltie for details of what the different methods do.

TO DO

Top

Benchmarking

We should probably benchmark this thing to see what it can do

BUGS

Top

None known.

SEE ALSO

Top

perltie (perltie)

COPYRIGHT

Top

Copyright (c) 2001-2004 intes.net, inc.. All rights reserved.

This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself.

AUTHORS

Top

Chris Winters <chris@cwinters.com>

SPOPS documentation Contained in the SPOPS distribution. 
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__