SPOPS::Tool::DBI::MaintainLinkedList - Support objects that automatically maintain a link to the previous and next objects

SPOPS documentation Contained in the SPOPS distribution.

Index

Code Index:

NAME

Top

SPOPS::Tool::DBI::MaintainLinkedList - Support objects that automatically maintain a link to the previous and next objects

SYNOPSIS

Top

 $spops = {
    'my' => {
      class             => 'My::Object',
      isa               => [ qw/ SPOPS::DBI::MySQL  SPOPS::DBI / ],
      field             => [ qw/ object_id name next_object_id previous_object_id / ],
      skip_undef        => [ qw/ next_object_id previous_object_id / ],
      rules_from        => [ 'SPOPS::Tool::DBI::MaintainLinkedList' ],
      linklist_previous => 'next_object_id',
      linklist_next     => 'previous_object_id',
      ...
    },
 };

 # Create some objects; new links are maintained along the way

 My::Object->new({ object_id => 1, name => 'first' })->save();
 My::Object->new({ object_id => 2, name => 'second' })->save();
 My::Object->new({ object_id => 3, name => 'third' })->save();

 my $object2 = My::Object->fetch(2);
 print "This object: ", $object2->name, "\n",
       "Previous object: ", $object2->previous_in_list->name, "\n",
       "Next object: ", $object2->next_in_list->name, "\n";
 # This object: second
 # Previous object: first
 # Next object: third

 # Remove the middle object to shuffle the links
 $object2->remove;

 my $object1 = My::Object->fetch(1);
 print "This object: ", $object1->name, "\n",
       "Previous object: ", ( $object1->previous_in_list )
                              ? "n/a" : $object1->previous_in_list->name ), "\n",
       "Next object: ", $object1->next_in_list->name, "\n";
 # This object: first
 # Previous object: n/a
 # Next object: third

DESCRIPTION

Top

This package supports an SPOPS ruleset to maintain a linked list of next/previous IDs. Adding a new object will set its the 'next' link to the previous head to the new object and the 'previous' link of the new object to the previous head.

Configuration

The following configuration entries are defined:

linklist_previous ($)

Name of the field that holds the ID for the previous object.

linklist_next ($)

Name of the field that holds the ID for the next object.

linklist_head ($)

Method to use for finding the head object. Options are defined below in Finding the Head.

linklist_head_order ($) (optional)

Used if the linklist_head is 'order'. The ORDER BY clause to use to find the head. This can be any valid SQL clause, so something like posted_on_date DESC would work fine.

linklist_head_value ($) (optional)

Used if the linklist_head is 'value'. Set to the value of linklist_next for the head object. This can be useful if your database uses 0 instead of NULL for numeric fields, or if you want to set a default for linklist_next to a known value rather than relying on NULL.

Finding the Head

The previous head can be found in a few ways, controlled by the configuration option 'linklist_head':

null (default)

Find the object with the linklist_next field as NULL. If you have not setup the objects properly so that there is more than one object with a NULL value you will probably get a surprise: we just take the first object returned with a NULL value in the field.

value

Find the object with the linklist_next field as linklist_head_value. Same conditions apply for the null option.

order

Fetch the objects ordered by a certain field and assume the first is the head. Requires you to set linklist_head_order to the relevant SQL ORDER BY clause.

METHODS

Top

post_save_action

When a new object is created, it updates the linklist_next field of the previous object (found in the manner described above) with the ID of the object just created and the linklist_previous field of the saved object with the ID of the previous object.

Performs no action on an update or if the option 'skip_linklist' is passed to save():

 my $object = My::Object->new({ id => 1 })->save({ skip_linklist => 1 });

The latter option can be useful if you are creating new objects which do not belong at the head of the list. (See BUGS for an example of how to do this.)

post_remove_action

Relink the previous and next objects to point to each other rather than the object just removed.

BUGS

Top

Non-head inserts

You need to manually manipulate inserts not at the head of the list using something like:

 # do not use automatic linking for this save...

 my $object = My::Object->new({ id => 1 })->save({ skip_linklist => 1 });

 my $field_previous = My::Object->CONFIG->{linklist_previous};
 my $field_next     = My::Object->CONFIG->{linklist_next};

 # ...find place to insert your object (find_[previous|next]_object()
 # are defined by you)...

 my $previous = find_previous_object( ... );
 my $next     = find_next_object( ... );

 # ...shuffle the IDs and save...

 $previous->{ $field_next }   = $object->id;
 $object->{ $field_previous } = $previous->id;
 $object->{ $field_next }     = $next->id;
 $next->{ $field_previous }   = $object->id;
 eval {
     $previous->save();
     $object->save();
     $next->save();
 };

TO DO

Top

None known.

SEE ALSO

Top

SPOPS::Manual::ObjectRules (SPOPS::Manual::ObjectRules)

SPOPS::ClassFactory

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::Tool::DBI::MaintainLinkedList;

# $Id: MaintainLinkedList.pm,v 1.5 2004/06/02 00:48:24 lachoy Exp $

use strict;
use Log::Log4perl qw( get_logger );
use Data::Dumper qw( Dumper );
use SPOPS;
use SPOPS::ClassFactory qw( OK DONE ERROR RULESET_METHOD );

use constant HEAD_DEFAULT => 'null';

my $log = get_logger();

$SPOPS::Tool::DBI::MaintainLinkedList::VERSION = sprintf("%d.%02d", q$Revision: 1.5 $ =~ /(\d+)\.(\d+)/);

########################################
# CODE GENERATION BEHAVIOR
########################################

sub behavior_factory {
     my ( $class ) = @_;
     return { read_code => \&generate_link_methods };
}

#
# Create previous_in_list(), next_in_list() methods

my $LINK_METHODS = <<'METHODS';

       # Generate the previous/next links

       sub %%CLASS%%::previous_in_list {
          my ( $self, $p ) = @_;
          my $previous_id = $self->{ %%PREVIOUS_ID_FIELD%% };
          return $self->fetch( $previous_id, $p );
       }

       sub %%CLASS%%::next_in_list {
          my ( $self, $p ) = @_;
          my $next_id = $self->{ %%NEXT_ID_FIELD%% };
          return $self->fetch( $next_id, $p );
       }

METHODS

sub generate_link_methods {
    my ( $class ) = @_;
    my $CONFIG = $class->CONFIG;
    my $field_prev = $CONFIG->{linklist_previous};
    my $field_next = $CONFIG->{linklist_next};
    my $methods = $LINK_METHODS;
    $methods =~ s/%%CLASS%%/$class/g;
    $methods =~ s/%%PREVIOUS_ID_FIELD%%/$field_prev/g;
    $methods =~ s/%%NEXT_ID_FIELD%%/$field_next/g;
    {
        local $SIG{__WARN__} = sub { return undef };
        eval $methods;
        if ( $@ ) {
            return ( ERROR, "Cannot generate 'previous_in_list()' and " .
                            "'next_in_list()' methods for object linked " .
                            "list in class [$class]. Error: $@" );
        }
    }
    return ( OK, undef );
}


########################################
# RUNTIME RULES
########################################

sub ruleset_factory {
    my ( $class, $rs_table ) = @_;
    push @{ $rs_table->{post_save_action} },   \&update_links;
    push @{ $rs_table->{post_remove_action} }, \&remove_links;
    $log->is_debug &&
        $log->debug( "Adding rules to [$class] from [", __PACKAGE__, "]" );
    return __PACKAGE__;
}

sub update_links {
    my ( $self, $p ) = @_;
    return 1 unless ( $p->{is_add} );
    return 1 if ( $p->{skip_linklist} );

    my @bad_params = ();
    my $field_prev = $self->CONFIG->{linklist_previous};
    my $field_next = $self->CONFIG->{linklist_next};
    unless ( $field_prev ) {
        push @bad_params, "[linklist_previous: $field_prev]";
    }
    unless ( $field_next ) {
        push @bad_params, "[linklist_next: $field_next]";
    }

    my $head_type = $self->CONFIG->{linklist_head} || HEAD_DEFAULT;
    my ( $order_by, $head_value );
    if ( $head_type eq 'order' ) {
        $order_by = $self->CONFIG->{linklist_head_order};
        unless ( $order_by ) {
            push @bad_params, "[linklist_head_order: $order_by]";
        }
    }
    if ( $head_type eq 'value' ) {
        $head_value = $self->CONFIG->{linklist_head_value};
        unless ( $head_value ) {
            push @bad_params, "[linklist_head_value: $head_value]";
        }
    }


    if ( scalar @bad_params ) {
        $log->warn( "Cannot automatically maintain linked list because field\n",
               "configuration variables are not available:\n",
               join( "\n", @bad_params ) );
        return 1;
    }

    # Add framework parameters (resources, etc) that need to be passed
    # into the save() commands here (this is dirty)

    my %temp_params = ( db => $p->{db} );

    my $this_id = $self->id;
    my ( $previous );
    if ( $head_type eq 'null' ) {
        $previous = _linklist_fetch_previous_null( $self, $field_next, \%temp_params );
    }
    elsif ( $head_type eq 'order' ) {
        $previous = _linklist_fetch_previous_order( $self, $order_by, \%temp_params );
    }
    elsif ( $head_type eq 'value' ) {
        $previous = _linklist_fetch_previous_value( $self, $field_next, $head_value, \%temp_params );
    }
    return 1 unless ( $previous );
    my $previous_id = $previous->id;

    $log->is_debug &&
        $log->debug( "Creating linked list entries for [", ref( $self ), "]",
                    "with ID [$this_id] to previous [$previous_id]" );

    $previous->{ $field_next } = $this_id;
    $self->{ $field_prev }     = $previous_id;
    eval {
        $previous->save( \%temp_params );
        $self->save( \%temp_params );
    };
    if ( $@ ) {
        $log->warn( "Error maintaining linked list: $@" );
        return undef;
    }
    $log->is_debug &&
        $log->debug( "Created links ok" );
    return 1;
}

sub _linklist_fetch_previous_null {
    my ( $self, $head_field, $p ) = @_;
    my $id_field = $self->id_field;
    return ( $self->fetch_group({ %{ $p },
                                  where => "$id_field != ? and $head_field IS NULL",
                                  value => [ $self->id ],
                                  limit => 1 }) )->[0];
}

sub _linklist_fetch_previous_order {
    my ( $self, $order_by, $p ) = @_;
    my $id_field = $self->id_field;
    return ( $self->fetch_group({ %{ $p },
                                  where => "$id_field != ?",
                                  value => [ $self->id ],
                                  order => $order_by,
                                  limit => 1 }) )->[0];
}

sub _linklist_fetch_previous_value {
    my ( $self, $head_field, $head_value, $p ) = @_;
    my $id_field = $self->id_field;
    return ( $self->fetch_group({ %{ $p },
                                  where => "$id_field != ? AND $head_field = ?",
                                  value => [ $self->id, $head_value ],
                                  limit => 1 }) )->[0];
}


sub remove_links {
    my ( $self, $p ) = @_;
    return 1 if ( $p->{skip_linklist} );

    my $field_prev = $self->CONFIG->{linklist_previous};
    my $field_next = $self->CONFIG->{linklist_next};
    unless ( $field_prev and $field_next ) {
        $log->warn( "Cannot automatically maintain linked list because certain\n",
               "configuration variables are not available:\n",
               "[linklist_previous: $field_prev]\n",
               "[linklist_next: $field_next]" );
        return 1;
    }

    my $previous = $self->fetch( $self->{ $field_prev }, $p );
    my $next     = $self->fetch( $self->{ $field_next }, $p );
    if ( $previous and $next ) {
        $previous->{ $field_next } = $next->id;
        $next->{ $field_prev }     = $previous->id;
        $log->is_debug &&
            $log->debug( "Linking [", ref( $self ), "] ",
                        "[previous: ", $previous->id, "] ",
                        "[next: ", $next->id, "]" );
    }
    elsif ( $previous ) {
        $previous->{ $field_next } = undef;
        $log->is_debug &&
            $log->debug( "Linking [", ref( $self ), "] ",
                        "[previous: ", $previous->id, "] ",
                        "[next: n/a]" );
    }
    elsif ( $next ) {
        $next->{ $field_prev }     = undef;
        $log->is_debug &&
            $log->debug( "Linking [", ref( $self ), "] ",
                        "[previous: n/a] ",
                        "[next: ", $next->id, "]" );
    }
    else {
        $log->is_debug &&
            $log->debug( "Linking [", ref( $self ), "] ",
                        "[previous: n/a] ",
                        "[next: n/a]" );
    }
    eval {
        $previous->save( $p ) if ( $previous );
        $next->save( $p )     if ( $next );;
    };
    if ( $@ ) {
        warn "Error maintaining linked list: $@\n";
        return undef;
    }
    return 1;
}

1;

__END__