July 27, 2009 at 17:57Nested Sets Tree Management Module
Task
Да уж, собрал ты катер, что бы кататься по водоемам и наслаждаться жизнью. Поехал на очередное озеро отдохнуть, а тебе говорят, что мол с собаками и катерами вход воспрещен, и вообще у нас озеро вечно замерзшее, вот вам коньки — наслаждайтесь. «Welcome to the Virtual Hosting lake».Как-то совсем не обратил внимание, что триггеры в MySQL может создавать только SUPER пользователь, что несколько удивляет, но оставим это на совести разработчиков. Триггеры, конечно, хороши, но пока положим их на полку.Решение для Perl в общем-то у меня есть, but when I created it, there were completely different tasks and requirements. Therefore, this article does not cancel the previous developments, but only offers an additional solution. So what is and what needs to be done. I have a certain set of objects and a certain “wrapper” for working with the database. In this "wrapper" I will include this module as an extension of its functionality. The wrapper is self-written. I will make a reservation in advance, I am not an opponent of DBIx :: Class and other ready-made solutions, I use them in my work and am satisfied. The question rests on Virtual Hosting and others like it: the lack of mod_perl and the hemorrhoids of installing additional modules. Solution for the same DBIx :: Classin development, but not very fast due to the fact that there is no need, I have enough triggers. Therefore, only three procedures are required: insert , update and delete . It is the procedures, which in turn are inherited as methods of the object of the “wrapper”. However, in this article, I will make it almost self-sufficient. I didn’t include transactions in this module, due to the fact that I’m using them one level higher, I’ll think it’s not difficult to include them in the code myself. Bugs and inaccuracies are possible, since the module is fresh and has not yet passed “baptism of fire” , although a little testing of the functionality was carried out.
Basic procedures and variables
Procedures for connecting to the database, of course, but there is an object of the package $ dbh, which is defined from the outside. Also, to ensure universality, we will create an array in which for each table we will define our own set of fields responsible for the structure of the tree, you never know who wants to name them.
Perl code (1)
package MY :: NestedSets;
# All as an adult, without compromise ;-)
use strict;
use warnings;
our $ VERSION = '0.0.1';
# Define the variables that we will use inside the package
our $ dbh = undef;
our $ tables = {
default => {# Table name
fields => {# Table fields
id => 'id', # Actually ID, you never know how anyone calls
left_key => 'left_key', # Left key
right_key => 'right_key', # Right key
level => 'level', # Level
parent_id => 'parent_id', # parent ID
tree => 'tree' # tree identifier
},
multi => 1, # Tells us that there are several trees in the table
},
};
sub dbh {
# The first value may come the name of the package or the class of the package, if we still manage to create it
# so we cut it off now and then, we don’t have a class.
shift if $ _ [0] && ($ _ [0] eq __PACKAGE__ || (ref $ _ [0] && ref $ _ [0] eq __PACKAGE__));
$ dbh = $ _ [0] if $ _ [0];
return $ dbh;
}
sub set_table_params {
shift if $ _ [0] && ($ _ [0] eq __PACKAGE__ || (ref $ _ [0] && ref $ _ [0] eq __PACKAGE__));
# Set our fields for a specific table
my ($ table_name, $ params) = @_;
$ tables -> {$ table_name} = $ params;
return $ tables;
}
In parallel, I will write the use script itself, it is also a test one. So, we use our module and determine its main data.
Perl code (2)
#! / usr / bin / perl
use strict; use warnings;
use lib '../lib';
use MY :: NestedSets;
use DBI;
use Data :: Dumper;
# ------------------------------------------------- -------------------------------------------------- -----
# INIT
my $ dbh = DBI-> connect ('dbi: mysql: database = test; host = localhost; port = 3306', 'user', 'pass');
my $ table_name = 'test_nested_sets';
my% f = (
id => 'ids',
left_key => 'lk',
right_key => 'rk',
level => 'lv',
parent_id => 'pi',
tree => 'tr',
);
$ dbh-> do ("DROP TABLE` $ table_name`; ");
my $ query = "CREATE TABLE` $ table_name` (
`$ f {id}` int (11) NOT NULL auto_increment,
`$ f {left_key}` int (11) NOT NULL default '0',
`$ f {right_key}` int (11) NOT NULL default '0',
`$ f {level}` int (11) NOT NULL default '0',
`$ f {parent_id}` int (11) NOT NULL default '0',
`$ f {tree}` int (11) NOT NULL default '1',
`field1` VARCHAR (100),
PRIMARY KEY (`$ f {id}`)
) ENGINE = MyISAM; ";
$ dbh-> do ($ query);
MY :: NestedSets-> dbh ($ dbh);
MY :: NestedSets-> set_table_params ($ table_name => {fields => \% f, multi => 1});
...
Insert node
The logic of the work is the same as that of the trigger.
Perl Code (3)
sub insert {
# We distribute the incoming data into places, well, and accordingly check whether we have enough
shift if $ _ [0] && ($ _ [0] eq __PACKAGE__ || (ref $ _ [0] && ref $ _ [0] eq __PACKAGE__));
my ($ table_name, $ new) = @_;
return {success => 0, error => 'Bad income data!'} unless $ dbh && $ table_name && $ new && ref $ new && ref $ new eq 'HASH';
# Find what kind of table and take its additional attributes and field synonyms
my $ table = $ tables -> {$ table_name} || $ tables -> {default};
my $ f = $ table -> {fields};
my $ result_flags = {is_last_unit => undef};
# Determine the initial data of the tree keys
$ new -> {$ f -> {left_key}} || = 0;
$ new -> {$ f -> {right_key}} = undef;
$ new -> {$ f -> {level}} = undef;
$ new -> {$ f -> {parent_id}} || = 0;
# We determine the keys, if we have given or changed the parent node
if ($ new -> {$ f -> {parent_id}}) {
my $ sql = 'SELECT'.
($ table -> {multi}? $ f -> {tree}. 'AS tree,': '').
$ f -> {right_key}. ' AS left_key, '.
$ f -> {level}. ' + 1 AS level '.
'FROM'. $ Table_name.
'WHERE'. $ F -> {id}. ' = '. $ new -> {$ f -> {parent_id}};
# To make it clear, this is a query (in square brackets is an optional expression):
# SELECT [tree AS tree,] right_key AS left_key, level + 1 AS level FROM $ table_name WHERE id = $ parent_id;
my $ sth = $ dbh-> prepare ($ sql); $ sth-> execute || return {success => 0, error => $ dbh-> errstr};
my $ row = $ sth-> fetchrow_hashref ();
$ sth-> finish;
# Parent node found, so redefine key values
if ($ row) {
$ new -> {$ f -> {tree}} = $ row -> {tree} || undef
$ new -> {$ f -> {left_key}} = $ row -> {left_key};
$ new -> {$ f -> {level}} = $ row -> {level};
} else {
# Parent node not found, so parent_id is left, reset it
$ new -> {$ f -> {parent_id}} = 0;
$ new -> {$ f -> {level}} = 0;
}
}
# We determine the keys if we have the left key set, but at the same time, the parent node is not specified, or not found
if (! $ new -> {$ f -> {parent_id}} && $ new -> {$ f -> {left_key}}) {
# It is important! the $ tree parameter is required if multi-trees
return {success => 0, error => 'No tree value!'} unless $ new -> {$ f -> {tree}} && $ table -> {multi};
# At first I wanted to use SQL :: Abstract, but I didn’t like it, describing complex queries is more difficult and longer
# Find the node on the left or right key
my $ sql = 'SELECT'.
$ f -> {id}. ' AS id, '.
$ f -> {left_key}. ' AS left_key, '.
$ f -> {right_key}. ' AS right_key, '.
$ f -> {level}. ' AS level, '.
$ f -> {parent_id}. ' AS parent_id '.
'FROM'. $ Table_name.
'WHERE'.
($ table -> {multi}? $ f -> {tree}. '='. $ new -> {$ f -> {tree}}. 'AND': '').
'('. $ f -> {left_key}. '='. $ new -> {$ f -> {left_key}}. 'OR'.
$ f -> {right_key}. ' = '. $ new -> {$ f -> {left_key}}.') LIMIT 1 ';
# Request readable:
# SELECT
# id AS id,
# left_key AS left_key,
# right_key AS right_key,
# level AS level,
# parent_id AS parent_id
# FROM $ table_name
# WHERE
# [tree = $ tree AND]
# (left_key = $ left_key OR right_key = $ left_key)
# LIMIT 1;
my $ sth = $ dbh-> prepare ($ sql); $ sth-> execute || return {success => 0, error => $ dbh-> errstr};
my $ row = $ sth-> fetchrow_hashref ();
$ sth-> finish;
# The node was found using the left key, therefore, the new node we will face found
if ($ row && $ row -> {left_key} == $ new -> {$ f -> {left_key}}) {
$ new -> {$ f -> {parent_id}} = $ row -> {parent_id};
$ new -> {$ f -> {level}} = $ row -> {level};
# The node was found on the right key, therefore, the new node will be under the found one
} elsif ($ row) {
$ new -> {$ f -> {parent_id}} = $ row -> {id};
$ new -> {$ f -> {level}} = $ row -> {level} + 1;
} else {
# Again such and such crap, indicated completely left data. It’s good to swear, but for now, ignore these shoals,
# as we can handle ourselves without this data
$ new -> {$ f -> {left_key}} = undef;
}
}
# Actually, we could not get the insertion point, or simply it was not indicated.
# We will insert at the end of the tree, therefore, updating existing nodes is not required, therefore, we will make the corresponding flag:
unless ($ new -> {$ f -> {left_key}}) {
$ result_flags -> {is_last_unit} = 1;
# This is again important! the $ tree parameter is necessary if multi-trees.
# In general, you could check this at the very beginning, but this parameter is optional if we specified parent_id,
# then the value of the tree key is determined by it.
return {success => 0, error => 'No tree value!'} unless $ new -> {$ f -> {tree}} && $ table -> {multi};
# Everything is simple here, we determine the maximum right key and rejoice
my $ sql = 'SELECT MAX ('. $ f -> {right_key}. ') + 1 AS left_key
FROM '. $ Table_name.
($ table -> {multi}? 'WHERE'. $ f -> {tree}. '='. $ new -> {$ f -> {tree}}: '');
# Request readable:
# SELECT MAX (right_key) + 1 AS left_key,
# FROM $ table_name
# [WHERE tree = $ tree];
my $ sth = $ dbh-> prepare ($ sql); $ sth-> execute || return {success => 0, error => $ dbh-> errstr};
my $ row = $ sth-> fetchrow_hashref ();
$ sth-> finish;
# But the joy may not be complete, as nodes may not be at all
$ new -> {$ f -> {left_key}} = $ row -> {left_key} || 1;
$ new -> {$ f -> {parent_id}} = 0;
$ new -> {$ f -> {level}} = 0;
}
# Well, with the location, we decided, you can break the keys in the tree:
unless ($ result_flags -> {is_last_unit}) {
my $ query = 'UPDATE'. $ table_name.
'SET'. $ F -> {left_key}. ' = CASE
WHEN '. $ F -> {left_key}.' > = '. $ new -> {$ f -> {left_key}}.'
THEN '. $ F -> {left_key}.' + 2 ELSE '. $ F -> {left_key}.' END,
'. $ f -> {right_key}.' = '. $ f -> {right_key}.' + 2
WHERE '.
($ table -> {multi}? $ f -> {tree}. '='. $ new -> {$ f -> {tree}}. 'AND': '').
$ f -> {right_key}. ' > = '. $ new -> {$ f -> {left_key}};
# Request readable:
# UPDATE $ table_name
# SET
# left_key = CASE WHEN left_key> = $ left_key
# THEN left_key + 2
# ELSE left_key
# END,
# right_key = right_key + 2
# WHERE [tree = $ tree AND] right_key> = $ left_key;
$ dbh-> do ($ query) || return {success => 0, error => $ dbh-> errstr};
}
# Now, in fact, why did we come here:
# The right key is calculated
$ new -> {$ f -> {right_key}} = $ new -> {$ f -> {left_key}} + 1;
# We put down the keys
$ new -> {$ f -> {tree}} = $ new -> {$ f -> {tree}} if $ table -> {multi};
# It would be necessary to display the fields in a certain order
my @fields = keys% {$ new};
# here we are quoting non-numeric and empty lines and stuffing in the order @fields
# and yes, they still need to be checked before they get here, at least for double quotes
my @values = map {defined $ new -> {$ _} && $ new -> {$ _} = ~ / ^ \ d + $ /? $ new -> {$ _}: '"'. $ new -> {$ _}. '"'} @fields;
# Actually INSERT
my $ query = 'INSERT INTO'. $ table_name. ' ('. (join', ', @fields).') VALUES ('. (join', ', @values).') ';
$ dbh-> do ($ query) || return {success => 0, error => $ dbh-> errstr};
# But what to return is a separate question, we, alas, cannot, return the inserted row without fetching,
# since the table may have default field values, but we did not specify them in INSERT.
# Let's do the same SELECT
my $ sql = 'SELECT * FROM'. $ table_name. ' ORDER BY '. $ F -> {id}.' DESC LIMIT 1 ';
my $ sth = $ dbh-> prepare ($ sql); $ sth-> execute || return {success => 0, error => $ dbh-> errstr};
my $ row = $ sth-> fetchrow_hashref;
$ sth-> finish;
return {success => 1, row => $ row};
}
It turned out a lot of code, yes ... But if you remove the comments, there will be half as many lines ;-), but it is clear, I hope. Essentially: again, setting the parent is priority. If a parent is specified and a left key is specified, the latter will be ignored in the valid tree. So keep in mind that if you want to create a node subordinate to something, and at the same time indicate its place in the list of children, then parent_id should not be passed. Application:
Perl code (4)
...
my $ tree = 1;
# ------------------------------------------------- -------------------------------------------------- --------------------
# INSERT
# Record without coordinates
my $ insert = MY :: NestedSets-> insert ($ table_name, {field1 => 'row1 -'. $ tree, tr => $ tree});
warn Dumper $ insert;
# Record with parent
$ insert = MY :: NestedSets-> insert ($ table_name, {field1 => 'row2 -'. $ tree, pi => $ insert -> {row} -> {ids}, tr => $ tree});
warn Dumper $ insert;
# Entries with left_key
$ insert = MY :: NestedSets-> insert ($ table_name, {field1 => 'row3 -'. $ tree, lk => 1, tr => $ tree});
warn Dumper $ insert;
$ insert = MY :: NestedSets-> insert ($ table_name, {field1 => 'row4 -'. $ tree, lk => 4, tr => $ tree});
warn Dumper $ insert;
# Wrong parameters
$ insert = MY :: NestedSets-> insert ($ table_name, {field1 => 'row5 -'. $ tree, pi => 1000, tr => $ tree});
warn Dumper $ insert;
$ insert = MY :: NestedSets-> insert ($ table_name, {field1 => 'row6 -'. $ tree, lk => 100, tr => $ tree});
warn Dumper $ insert;
...
Node change
In addition to directly changing the tree structure (if necessary), changes will also be applied to other fields, as needed.
Perl Code (5)
sub update {
# We distribute the incoming data into places, and, accordingly, we check whether we have enough
shift if $ _ [0] && ($ _ [0] eq __PACKAGE__ || (ref $ _ [0] && ref $ _ [0] eq __PACKAGE__));
my ($ table_name, $ new) = @_;
return {success => 0, error => 'Bad income data!'} unless $ dbh && $ table_name && $ new && ref $ new && ref $ new eq 'HASH';
# Find what kind of table and take its additional attributes and field synonyms
my $ table = $ tables -> {$ table_name} || $ tables -> {default};
my $ f = $ table -> {fields};
return {success => 0, error => 'Bad income data!'} unless $ new -> {$ f -> {id}};
# We remove the fields that cannot be changed independently
delete $ new -> {$ f -> {right_key}};
delete $ new -> {$ f -> {tree}};
delete $ new -> {$ f -> {level}};
my $ tmp_left_key = $ new -> {$ f -> {left_key}};
my $ result_flags = {it_is_moving => undef};
# Further dilemma. To accept the changes, we need to have the source data
# In this case, we don’t know what initial data we had, and what fields really changed,
# so we sample our mutable node
my $ sql = 'SELECT * FROM'. $ table_name. ' WHERE '. $ F -> {id}.' = '. $ new -> {$ f -> {id}};
my $ sth = $ dbh-> prepare ($ sql); $ sth-> execute || return {success => 0, error => $ dbh-> errstr};
my $ old = $ sth-> fetchrow_hashref;
$ sth-> finish;
return {success => 0, error => 'No old unit!'} unless $ old;
# Calculate the new node coordinates
# We determine the keys if we have changed the parent node
if (defined $ new -> {$ f -> {parent_id}} && $ new -> {$ f -> {parent_id}}! = $ old -> {$ f -> {parent_id}}) {
if ($ new -> {$ f -> {parent_id}}> 0) {
my $ sql = 'SELECT'.
($ table -> {multi}? $ f -> {tree}. 'AS tree,': '').
$ f -> {right_key}. ' AS left_key, '.
$ f -> {level}. ' + 1 AS level '.
'FROM'. $ Table_name.
'WHERE'. $ F -> {id}. ' = '. $ new -> {$ f -> {parent_id}};
# To make it clear, this is a query (in square brackets is an optional expression):
# SELECT [tree AS tree,] right_key AS left_key, level + 1 AS level FROM $ table_name WHERE id = $ parent_id;
my $ sth = $ dbh-> prepare ($ sql); $ sth-> execute || return {success => 0, error => $ dbh-> errstr};
my $ row = $ sth-> fetchrow_hashref ();
$ sth-> finish;
# Parent node found, then redefine key values
if ($ row) {
$ new -> {$ f -> {tree}} = $ row -> {tree} if $ table -> {multi};
$ new -> {$ f -> {left_key}} = $ row -> {left_key};
$ new -> {$ f -> {level}} = $ row -> {level};
$ result_flags -> {it_is_moving} = 1;
} else {
# Parent node not found, so parent_id is left, reset it
$ new -> {$ f -> {parent_id}} = $ old -> {$ f -> {parent_id}};
}
} else {
# We transfer to the highest level
# Everything is simple here, we determine the maximum right key and rejoice
my $ sql = 'SELECT MAX ('. $ f -> {right_key}. ') + 1 AS left_key
FROM '. $ Table_name.
($ table -> {multi}? 'WHERE'. $ f -> {tree}. '='. $ old -> {$ f -> {tree}}: '');
# Request readable:
# SELECT MAX (right_key) + 1 AS left_key,
# FROM $ table_name
# [WHERE tree = $ tree];
my $ sth = $ dbh-> prepare ($ sql); $ sth-> execute || return {success => 0, error => $ dbh-> errstr};
my $ row = $ sth-> fetchrow_hashref ();
$ sth-> finish;
$ new -> {$ f -> {left_key}} = $ row -> {left_key};
$ new -> {$ f -> {parent_id}} = 0;
$ new -> {$ f -> {level}} = 0;
}
}
# We determine the keys if we have the left key set but the parent node is not specified or not found
if ($ tmp_left_key && $ new -> {$ f -> {left_key}} && # left_key was specified
$ new -> {$ f -> {left_key}} == $ tmp_left_key && # parent_id has not changed
$ tmp_left_key! = $ old -> {$ f -> {left_key}}) {# left_key changed
# At first I wanted to use SQL :: Abstract, but I didn’t like it, describing complex queries is more difficult and longer
# Find the node on the left or right key
my $ sql = 'SELECT'.
$ f -> {id}. ' AS id, '.
$ f -> {left_key}. ' AS left_key, '.
$ f -> {right_key}. ' AS right_key, '.
$ f -> {level}. ' AS level, '.
$ f -> {parent_id}. ' AS parent_id '.
'FROM'. $ Table_name.
'WHERE'.
($ table -> {multi}? $ f -> {tree}. '='. $ old -> {$ f -> {tree}}. 'AND': '').
'('. $ f -> {left_key}. '='. $ new -> {$ f -> {left_key}}. 'OR'.
$ f -> {right_key}. ' = '. $ new -> {$ f -> {left_key}}.') LIMIT 1 ';
# Request readable:
# SELECT
# id AS id,
# left_key AS left_key,
# right_key AS right_key,
# level AS level,
# parent_id AS parent_id
# FROM $ table_name
# WHERE
# [tree = $ tree AND]
# (left_key = $ left_key OR right_key = $ left_key)
# LIMIT 1;
my $ sth = $ dbh-> prepare ($ sql); $ sth-> execute || return {success => 0, error => $ dbh-> errstr};
my $ row = $ sth-> fetchrow_hashref ();
$ sth-> finish;
# The node was found using the left key, therefore, the new node we will face found
if ($ row && $ row -> {left_key} == $ new -> {$ f -> {left_key}}) {
$ new -> {$ f -> {parent_id}} = $ row -> {parent_id};
$ new -> {$ f -> {level}} = $ row -> {level};
# The node was found on the right key, therefore, the new node will be under the found one
} elsif ($ row) {
$ new -> {$ f -> {parent_id}} = $ row -> {id};
$ new -> {$ f -> {level}} = $ row -> {level} + 1;
} else {
# Again such and such crap, indicated completely left data. Although there is an option that we put the node first,
# then, this is not a mistake. But in other cases, just ignore the move
$ new -> {$ f -> {left_key}} = $ new -> {$ f -> {left_key}} && $ new -> {$ f -> {left_key}} == 1? 1: $ old -> {$ f -> {left_key}};
}
}
# Now that we know what our left key is, we can check if we send inward
if ($ new -> {$ f -> {left_key}}> $ old -> {$ f -> {left_key}} && $ new -> {$ f -> {left_key}} <$ old -> {$ f -> {right_key}}) {
return {success => 0, error => 'Can not move unit inside'};
}
# We figured out the coordinates, the only thing is, we look, and do we have any changes in the tree
if ($ new -> {$ f -> {left_key}} && $ new -> {$ f -> {left_key}}! = $ old -> {$ f -> {left_key}}) {
# Define level and tree offsets
my $ skew_level = $ new -> {$ f -> {level}} - $ old -> {$ f -> {level}};
my $ skew_tree = $ old -> {$ f -> {right_key}} - $ old -> {$ f -> {left_key}} + 1;
# Move down the tree
if ($ new -> {$ f -> {left_key}}> $ old -> {$ f -> {left_key}}) {
my $ skew_edit = $ new -> {$ f -> {left_key}} - $ old -> {$ f -> {left_key}} - $ skew_tree;
my $ query = 'UPDATE'. $ table_name.
'SET'. $ F -> {left_key}. ' = CASE WHEN '. $ F -> {right_key}.' <= '. $ old -> {$ f -> {right_key}}.'
THEN '. $ F -> {left_key}.' + '. $ skew_edit.'
ELSE CASE WHEN '. $ F -> {left_key}.' > '. $ old -> {$ f -> {right_key}}.'
THEN '. $ F -> {left_key}.' - '. $ skew_tree.'
ELSE '. $ F -> {left_key}.'
End
END,
'. $ f -> {level}.' = CASE WHEN '. $ F -> {right_key}.' <= '. $ old -> {$ f -> {right_key}}.'
THEN '. $ F -> {level}.' + '. $ skew_level.'
ELSE '. $ F -> {level}.'
END,
'. $ f -> {right_key}.' = CASE WHEN '. $ F -> {right_key}.' <= '. $ old -> {$ f -> {right_key}}.'
THEN '. $ F -> {right_key}.' + '. $ skew_edit.'
ELSE CASE WHEN '. $ F -> {right_key}.' <'. $ new -> {$ f -> {left_key}}.'
THEN '. $ F -> {right_key}.' - '. $ skew_tree.'
ELSE '. $ F -> {right_key}.'
End
End
WHERE
'. ($ table -> {multi}? $ f -> {tree}.' = '. $ old -> {$ f -> {tree}}.' AND ':' ').
$ f -> {right_key}. ' > '. $ old -> {$ f -> {left_key}}.' AND '.
$ f -> {left_key}. ' <'. $ new -> {$ f -> {left_key}}.'; ';
$ dbh-> do ($ query) || return {success => 0, error => $ dbh-> errstr};
$ new -> {$ f -> {left_key}} = $ new -> {$ f -> {left_key}} - $ skew_tree;
} else {
# Move up the tree
my $ skew_edit = $ new -> {$ f -> {left_key}} - $ old -> {$ f -> {left_key}};
my $ query = 'UPDATE'. $ table_name. '
SET
'. $ f -> {right_key}.' = CASE WHEN '. $ F -> {left_key}.' > = '. $ old -> {$ f -> {left_key}}.'
THEN '. $ F -> {right_key}.' + '. $ skew_edit.'
ELSE CASE WHEN '. $ F -> {right_key}.' <'. $ old -> {$ f -> {left_key}}.'
THEN '. $ F -> {right_key}.' + '. $ skew_tree.'
ELSE '. $ F -> {right_key}.'
End
END,
'. $ f -> {level}.' = CASE WHEN '. $ F -> {left_key}.' > = '. $ old -> {$ f -> {left_key}}.'
THEN '. $ F -> {level}.' + '. $ skew_level.'
ELSE '. $ F -> {level}.'
END,
'. $ f -> {left_key}.' = CASE WHEN '. $ F -> {left_key}.' > = '. $ old -> {$ f -> {left_key}}.'
THEN '. $ F -> {left_key}.' + '. $ skew_edit.'
ELSE CASE WHEN '. $ F -> {left_key}.' > = '. $ new -> {$ f -> {left_key}}.'
THEN '. $ F -> {left_key}.' + '. $ skew_tree.'
ELSE '. $ F -> {left_key}.'
End
End
WHERE
'. ($ table -> {multi}? $ f -> {tree}.' = '. $ old -> {$ f -> {tree}}.' AND ':' ').
$ f -> {right_key}. ' > = '. $ new -> {$ f -> {left_key}}.' AND '.
$ f -> {left_key}. ' <'. $ old -> {$ f -> {right_key}}.'; ';
$ dbh-> do ($ query) || return {success => 0, error => $ dbh-> errstr};
}
}
# For starters, leave in $ new only those fields that have really changed, and which we generally have:
my @sets = ();
foreach my $ key (keys% {$ new}) {
# There is no such field at all
delete $ new -> {$ key}, next unless exists $ old -> {$ key};
# The content field has not changed
delete $ new -> {$ key}, next if $ old -> {$ key} && $ new -> {$ key} && $ new -> {$ key} eq $ old -> {$ key};
# Field without content has not changed
delete $ new -> {$ key}, next if! $ old -> {$ key} &&! $ new -> {$ key};
# We’ll not change the ID, but just in case
delete $ new -> {$ key}, next if $ key eq $ f -> {id};
# same thing, no value check
push @sets, $ key. '='. (defined $ new -> {$ key} && $ new -> {$ key} = ~ / ^ \ d + $ /? $ new -> {$ key}: '"'. $ new -> {$ key}. '"');
}
# Update modified fields
my $ query = 'UPDATE'. $ table_name.
'SET'. (Join ',', @sets).
'WHERE'. $ F -> {id}. ' = '. $ old -> {$ f -> {id}};
$ dbh-> do ($ query) || return {success => 0, error => $ dbh-> errstr};
# Again, we request a line after UPDATE, do you know which triggers have updated
$ sql = 'SELECT * FROM'. $ table_name. ' WHERE '. $ F -> {id}.' = '. $ old -> {$ f -> {id}}.' LIMIT 1 ';
$ sth = $ dbh-> prepare ($ sql); $ sth-> execute || return {success => 0, error => $ dbh-> errstr};
my $ row = $ sth-> fetchrow_hashref;
$ sth-> finish;
return {success => 1, row => $ row};
}
The same priorities as during insertion. Well and the fact that the incoming data is also not checked for validity, keep in mind. Usage:
Perl code (6)
# ------------------------------------------------- -------------------------------------------------- --------------------
# UPDATE
# Move down the tree
my $ update = MY :: NestedSets-> update ($ table_name, {field1 => 'row-u-1 -'. $ tree, ids => 1, lk => 10, tr => $ tree});
warn Dumper $ update;
# Move up the tree
$ update = MY :: NestedSets-> update ($ table_name, {field1 => 'row-u-4 -'. $ tree, ids => 6, lk => 1, tr => $ tree});
warn Dumper $ update;
# Change parent
$ update = MY :: NestedSets-> update ($ table_name, {field1 => 'row-u-8 -'. $ tree, ids => 2, pi => 5, tr => $ tree});
warn Dumper $ update;
Delete node
Direct code, comments inside:
Perl code (7)
sub delete {
# We distribute the incoming data into places, well, and accordingly check whether we have enough
shift if $ _ [0] && ($ _ [0] eq __PACKAGE__ || (ref $ _ [0] && ref $ _ [0] eq __PACKAGE__));
my ($ table_name, $ id, $ flag) = @_;
return {success => 0, error => 'Bad income data!'} unless $ dbh && $ table_name && $ id;
# Find what kind of table and take its additional attributes and field synonyms
my $ table = $ tables -> {$ table_name} || $ tables -> {default};
my $ f = $ table -> {fields};
# Since we are not limited as in triggers in the number and volume of parameters passed,
# the implementation of the deletion will be double: deleting the entire branch and deleting one node of the tree
# by default, delete the entire branch
$ flag = {cascade => 'cascade', one => 'one'} -> {$ flag || 'cascade'} || 'cascade';
# Select the node to be deleted, and we need only 3 fields: tree, left_key and right_key
# Although we can pass it as a parameter, but you never know what, we could change the keys before that,
# and the tree will crumble from this.
my $ sql = 'SELECT'.
($ table -> {multi}? $ f -> {tree}. 'AS tree,': '').
$ f -> {parent_id}. ' AS parent_id, '.
$ f -> {level}. ' AS level, '.
$ f -> {left_key}. ' AS left_key, '.
$ f -> {right_key}. ' AS right_key '.
'FROM'. $ Table_name.
'WHERE'. $ F -> {id}. ' = '. $ id;
my $ sth = $ dbh-> prepare ($ sql); $ sth-> execute || return {success => 0, error => $ dbh-> errstr};
my $ old = $ sth-> fetchrow_hashref ();
$ sth-> finish;
return {success => 0, error => 'No old unit!'} unless $ old;
if ($ flag eq 'cascade') {
# Delete the branch
my $ query = 'DELETE FROM'. $ table_name.
'WHERE'.
($ table -> {multi}? $ f -> {tree}. '='. $ old -> {tree}. 'AND': '').
$ f -> {left_key}. ' > = '. $ old -> {left_key}.' AND '.
$ f -> {right_key}. ' <= '. $ old -> {right_key};
$ dbh-> do ($ query) || return {success => 0, error => $ dbh-> errstr};
# Remove the key gap:
my $ skew_tree = $ old -> {right_key} - $ old -> {left_key} + 1;
$ query = 'UPDATE'. $ table_name.
'SET'. $ F -> {left_key}. ' = CASE WHEN '. $ F -> {left_key}.' > '. $ old -> {left_key}.'
THEN '. $ F -> {left_key}.' - '. $ skew_tree.'
ELSE '. $ F -> {left_key}.'
END, '.
$ f -> {right_key}. ' = '. $ f -> {right_key}.' - '. $ skew_tree.
'WHERE'.
($ table -> {multi}? $ f -> {tree}. '='. $ old -> {tree}. 'AND': '').
$ f -> {right_key}. ' > '. $ old -> {right_key}.'; ';
# Request in readable form:
# UPDATE $ table_name
# SET left_key = CASE WHEN left_key> OLD.left_key
# THEN left_key - $ skew_tree
# ELSE left_key
# END,
# right_key = right_key - $ skew_tree
# WHERE
# [tree = OLD.tree AND]
# right_key> OLD.right_key;
$ dbh-> do ($ query) || return {success => 0, error => $ dbh-> errstr};
} else {
# Delete the node
my $ query = 'DELETE FROM'. $ table_name. ' WHERE '. $ F -> {id}.' = '. $ id.' LIMIT 1 '; # you never know
$ dbh-> do ($ query) || return {success => 0, error => $ dbh-> errstr};
# Remove the gap and rebuild the subordinate branch
$ query = 'UPDATE'. $ table_name.
'SET'. $ F -> {left_key}. ' = CASE WHEN '. $ F -> {left_key}.' <'. $ old -> {left_key}.'
THEN '. $ F -> {left_key}.'
ELSE CASE WHEN '. $ F -> {right_key}.' <'. $ old -> {right_key}.'
THEN '. $ F -> {left_key}.' - 1
ELSE '. $ F -> {left_key}.' - 2
End
END, '.
$ f -> {parent_id}. ' = CASE WHEN '. $ F -> {right_key}.' <'. $ old -> {right_key}.
'AND'. $ F -> {level}. ' = '. $ old -> {level}.' + 1
THEN '. $ Old -> {parent_id}.'
ELSE '. $ F -> {parent_id}.'
END, '.
$ f -> {level}. ' = CASE WHEN '. $ F -> {right_key}.' <'. $ old -> {right_key}.'
THEN '. $ F -> {level}.' - 1
ELSE '. $ F -> {level}.'
END, '.
$ f -> {right_key}. ' = CASE WHEN '. $ F -> {right_key}.' <'. $ old -> {right_key}.'
THEN '. $ F -> {right_key}.' - 1
ELSE '. $ F -> {right_key}.' - 2
End
WHERE '.
($ table -> {multi}? $ f -> {tree}. '='. $ old -> {tree}. 'AND': '').
'('. $ f -> {right_key}. '>'. $ old -> {right_key}. 'OR
('. $ f -> {left_key}.'> '. $ old -> {left_key}.' AND '. $ f -> {right_key}.' <'. $ old -> {right_key}.')) ; ';
# Request in readable form:
# UPDATE $ table_name
# SET left_key = CASE WHEN left_key <OLD.left_key
# THEN left_key
# ELSE CASE WHEN right_key <OLD.right_key
# THEN left_key - 1
# ELSE left_key - 2
# END
# END,
# parent_id = CASE WHEN right_key <OLD.right_key AND `level` = OLD.level + 1
# THEN OLD.parent_id
# ELSE parent_id
# END,
# `level` = CASE WHEN right_key <OLD.right_key
# THEN `level` - 1
# ELSE `level`
# END,
# right_key = CASE WHEN right_key <OLD.right_key
# THEN right_key - 1
# ELSE right_key - 2
# END
# WHERE
# [tree = OLD.tree AND]
# (right_key> OLD.right_key OR
# (left_key> OLD.left_key AND right_key <OLD.right_key));
$ dbh-> do ($ query) || return {success => 0, error => $ dbh-> errstr};
}
return {sucess => 1};
}
To be honest, I haven't figured out what it would be right to return as a result, although just a flag of successful completion seems to me more than enough.
Application : Perl code (8)
my $ delete = MY :: NestedSets-> delete ($ table_name, 2);
$ delete = MY :: NestedSets-> delete ($ table_name, 3, 'one');
$ delete = MY :: NestedSets-> delete ($ table_name, 4);
Actually that's all. Wipe with a flannel cloth that would shine, and go.