Задача
Да уж, собрал ты катер, что бы кататься по водоемам и наслаждаться жизнью. Поехал на очередное озеро отдохнуть, а тебе говорят, что мол с собаками и катерами вход воспрещен, и вообще у нас озеро вечно замерзшее, вот вам коньки — наслаждайтесь. «Welcome to the Virtual Hosting lake».Как-то совсем не обратил внимание, что триггеры в MySQL может создавать только SUPER пользователь, что несколько удивляет, но оставим это на совести разработчиков. Триггеры, конечно, хороши, но пока положим их на полку.Решение для Perl в общем-то у меня есть, но когда я его создавал, стояли совершенно другие задачи и требования. Поэтому данная статья никак не отменяет предыдущих наработок, а только предлагает дополнительное решение.Итак, что есть и что требуется сделать. У меня есть некий набор объектов и некая «обертка» для работы с базой данных. В эту «обертку» я и буду включать этот модуль, как расширение её функционала. Обертка самописная. Заранее оговорюсь, я не противник DBIx::Class и других готовых решений, я их использую в своей работе и доволен. Вопрос же упирается в Virtual Hosting иже с ним: отсутствие mod_perl и геморрой установки дополнительных модулей. Решение для того же DBIx::Class в разработке, но не очень быстрой ввиду того, что нет надобности, мне и триггеров хватает.Посему требуется только три процедуры: insert, update и delete. Именно процедуры, которые в свою очередь пронаследуются как методы объекта «обертки». Впрочем, в данной статье, сделаю его практически самодостаточным. Транзакции в этот модуль не включил, ввиду того, что у меня их использование предусматривается на уровень выше, включить их в код самостоятельно, я думаю, не составит труда.Баги и неточности возможны, так как модуль свежий и не прошел еще «боевого крещения», хотя небольшое тестирование функционала было проведено.
Базовые процедуры и переменные
Процедуры подключения к базе данных, естественно, зато есть объект пакета $dbh, которой определяем извне. Так же, для обеспечения универсальности, создадим массив, в котором будем определять для каждой таблицы свой набор полей, отвечающих за структуру дерева, мало ли, кто как захочет их назвать.
Perl код (1)
package MY::NestedSets;
# Все по взрослому, без компромиссов ;-)
use strict;
use warnings;
our $VERSION = '0.0.1';
# Определяем переменные, которые будем использовать внутри пакета
our $dbh = undef;
our $tables = {
default => { # Название таблицы
fields => { # Поля таблицы
id => 'id', # Собственно ID, мало ли, кто как назовет
left_key => 'left_key', # Левый ключ
right_key => 'right_key', # Правый ключ
level => 'level', # Уровень
parent_id => 'parent_id', # ID родителя
tree => 'tree' # идентификатор дерева
},
multi => 1, # Говорит нам о том, что в таблице несколько деревьев
},
};
sub dbh {
# Первым значением может прийти название пакета или класс пакета, если мы таки умудримся его создать
# поэтому отрезаем его сейчас и потом, у нас таки не класс.
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__));
# Устанавливаем свои поля для определенной таблицы
my ($table_name, $params) = @_;
$tables->{$table_name} = $params;
return $tables;
}
Параллельно буду писать сам скрипт использования, он же тестовый. Итак, юзаем наш модуль и определяем его основные данные.
Perl код (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});
...
Вставка узла
Логика работы такая же, как и у триггера.
Perl код (3)
sub insert {
# Распределяем входящие данные по местам, ну и соответственно проверяем, всего ли нам хватает
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';
# Находим, что за таблица и берем её дополнительные атрибуты и синонимы полей
my $table = $tables->{$table_name} || $tables->{default};
my $f = $table->{fields};
my $result_flags = {is_last_unit => undef};
# Определяем начальные данные ключе�� дерева
$new->{$f->{left_key}} ||= 0;
$new->{$f->{right_key}} = undef;
$new->{$f->{level}} = undef;
$new->{$f->{parent_id}} ||= 0;
# Определяем ключи, если у нас задан или изменен родительский узел
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}};
# Что бы было понятно, это запрос (в квадратных скобках не обязательное выражение):
# 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;
# Родительский узел найден, значит переопределяем значния ключей
if ($row) {
$new->{$f->{tree}} = $row->{tree} || undef;
$new->{$f->{left_key}} = $row->{left_key};
$new->{$f->{level}} = $row->{level};
} else {
# Родительский узел не найден, значит, parent_id - левый, сбрасываем его
$new->{$f->{parent_id}} = 0;
$new->{$f->{level}} = 0;
}
}
# Определяем ключи если у нас задан левый ключ, но при этом, родительский узел не указан, либо не найден
if (!$new->{$f->{parent_id}} && $new->{$f->{left_key}}) {
# Это важно! параметр $tree нужен обязательно если мультидеревья
return {success => 0, error => 'No tree value!'} unless $new->{$f->{tree}} && $table->{multi};
# Сначала я хотел использовать SQL::Abstract, но он мне не понравился, описывать сложные запросы сложнее и дольше
# Находим, узел по левому или правому ключу
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';
# Запрос читабельно:
# 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;
# Узел нашли по левому ключу, следовательно, новый узел у нас будет стоять перед найденным
if ($row && $row->{left_key} == $new->{$f->{left_key}}) {
$new->{$f->{parent_id}} = $row->{parent_id};
$new->{$f->{level}} = $row->{level};
# Узел нашли по правому ключу, следовательно, новый узел у нас будет стоять под найденным
} elsif ($row) {
$new->{$f->{parent_id}} = $row->{id};
$new->{$f->{level}} = $row->{level} + 1;
} else {
# Опять такая-то лажа, указали совершенно левые данные. Хорошо бы ругнуться, но пока игнорируем эти косяки,
# так как можем справится сами и без этих данных
$new->{$f->{left_key}} = undef;
}
}
# Собственно, получить точку вставки мы не смогли, или же просто она была не указана.
# Будем вставлять в конец дерева, поэтому обновления существующих узлов не требуется, посему сделаем соответствующий флаг:
unless ($new->{$f->{left_key}}) {
$result_flags->{is_last_unit} = 1;
# Это опять же важно! параметр $tree нужен обязательно если мультидеревья.
# Вообще, можно было проверить это и самом начале, но этот параметр не обязателен, если мы указали parent_id,
# тогда значение ключа tree определяем по нему.
return {success => 0, error => 'No tree value!'} unless $new->{$f->{tree}} && $table->{multi};
# Тут все просто, определяем максимальный правый ключ и радуемся
my $sql = 'SELECT MAX('.$f->{right_key}.') + 1 AS left_key
FROM '.$table_name.
($table->{multi} ? ' WHERE '.$f->{tree}.' = '.$new->{$f->{tree}} : '');
# Запрос читабельно:
# 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} || 1;
$new->{$f->{parent_id}} = 0;
$new->{$f->{level}} = 0;
}
# Ну вот, с местоназначением мы определились, можно делать разрыв ключей в дереве:
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}};
# Запрос читабельно:
# 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};
}
# Теперь, собственно, зачем мы сюда пришли:
# Правый ключ вычисляем
$new->{$f->{right_key}} = $new->{$f->{left_key}} + 1;
# Проставляем ключики
$new->{$f->{tree}} = $new->{$f->{tree}} if $table->{multi};
# Надо бы поля в определенном порядке выводить
my @fields = keys %{$new};
# тут как бе квотируем не числовые и пустые строки и запихиваем в порядке @fields
# и да, их таки надо проверить до того как они сюда попали, хотя бы на предмет наличия двойных кавычек
my @values = map {defined $new->{$_} && $new->{$_} =~ /^\d+$/ ? $new->{$_} : '"'.$new->{$_}.'"'} @fields;
# Собственно INSERT
my $query = 'INSERT INTO '.$table_name.' ('.( join ',', @fields ).') VALUES ('.( join ',', @values ).')';
$dbh->do($query) || return {success => 0, error => $dbh->errstr};
# А вот что возвращать - вопрос отдельный, вернуть вставленную строку без выборки мы, увы, не можем,
# так как в таблице могут быть умолчательные значения полей, а мы их в INSERT не указали.
# Сделаем таки 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};
}
Получилось много кода, да… Но если комментарии убрать то будет в два раза меньше строк ;-), зато понятно, я надеюсь. По существу: опять же, приоритетным является установка родителя. Если указан родитель и указан левый ключ, то последний будет игнорироваться при валидном дереве. Так что имейте ввиду, если вы хотите создать узел в подчинении чему-то, и при этом указать его место в списке детей, то parent_id передавать не надо.Применение:
Perl код (4)
...
my $tree = 1;
#-----------------------------------------------------------------------------------------------------------------------
# INSERT
# Запись без координат
my $insert = MY::NestedSets->insert($table_name, {field1 => 'row1-'.$tree, tr => $tree});
warn Dumper $insert;
# Запись с родителем
$insert = MY::NestedSets->insert($table_name, {field1 => 'row2-'.$tree, pi => $insert->{row}->{ids}, tr => $tree});
warn Dumper $insert;
# Записи с 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;
# Неправильные параметры
$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;
...
Изменение узла
Кроме изменения непосредственно структуры дерева (если надо), еще будут применяться и изменения других полей, по надобности.
Perl код (5)
sub update {
# Распределяем входящие данные по местам, ну и, соответственно, проверяем, всего ли нам хватает
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';
# Находим, что за таблица и берем её дополнительные атрибуты и синонимы полей
my $table = $tables->{$table_name} || $tables->{default};
my $f = $table->{fields};
return {success => 0, error => 'Bad income data!'} unless $new->{$f->{id}};
# Убираем поля, которые менять самостоятельно нельзя
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};
# Дальше дилемма. Что бы принять изменения, нам нужно иметь исходные данные
# В данном случае, мы не знаем какие у нас были исходные данные, и какие поля реально менялись,
# поэтому делаем выборку нашего изменяемого узла
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;
# Вычисляем новую координаты узла
# Определяем ключи если у нас изменен родительский узел
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}};
# Что бы было понятно, это запрос (в квадратных скобках не обязательное выражение):
# 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;
# Родительский узел найден, значит переопределяем значения ключей
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_id - левый, сбрасываем его
$new->{$f->{parent_id}} = $old->{$f->{parent_id}};
}
} else {
# Переносим на самый верхний уровень
# Тут все просто, определяем максимальный правый ключ и радуемся
my $sql = 'SELECT MAX('.$f->{right_key}.') + 1 AS left_key
FROM '.$table_name.
($table->{multi} ? ' WHERE '.$f->{tree}.' = '.$old->{$f->{tree}} : '');
# Запрос читабельно:
# 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;
}
}
# Определяем ключи если у нас задан левый ключ но при этом родительский узел не указал, либо не найден
if ($tmp_left_key && $new->{$f->{left_key}} && # left_key был указан
$new->{$f->{left_key}} == $tmp_left_key && # parent_id не менялся
$tmp_left_key != $old->{$f->{left_key}}) { # left_key изменился
# Сначала я хотел использовать SQL::Abstract, но он мне не понравился, описывать сложные запросы сложнее и дольше
# Находим, узел по левому или правому ключу
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';
# Запрос читабельно:
# 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;
# Узел нашли по левому ключу, следовательно, новый узел у нас будет стоять перед найденным
if ($row && $row->{left_key} == $new->{$f->{left_key}}) {
$new->{$f->{parent_id}} = $row->{parent_id};
$new->{$f->{level}} = $row->{level};
# Узел нашли по правому ключу, следовательно, новый узел у нас будет стоять под найденным
} elsif ($row) {
$new->{$f->{parent_id}} = $row->{id};
$new->{$f->{level}} = $row->{level} + 1;
} else {
# Опять такая-то лажа, указали совершенно левые данные. Хотя есть вариант, что ставим узел самым первым,
# тогда, это не ошибка. Но в других случаях, просто игнорируем перемещение
$new->{$f->{left_key}} = $new->{$f->{left_key}} && $new->{$f->{left_key}} == 1 ? 1 : $old->{$f->{left_key}};
}
}
# Теперь, когда мы знаем, какой у нас левый ключ, мы можем проверить, а не во внутрь ли мы отправляем
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'};
}
# С координатами разобрались, единственно, Смотрим, а есть ли у нас вообще изменения по дереву
if ($new->{$f->{left_key}} && $new->{$f->{left_key}} != $old->{$f->{left_key}}) {
# Определяем смещения уровня и дерева
my $skew_level = $new->{$f->{level}} - $old->{$f->{level}};
my $skew_tree = $old->{$f->{right_key}} - $old->{$f->{left_key}} + 1;
# Перемещение вниз по дереву
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 {
# Перемещение вверх по дереву
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};
}
}
# Для начала, оставим в $new только те поля которые реально изменились, и которые вообще у нас есть:
my @sets = ();
foreach my $key (keys %{$new}) {
# Такого поля вообще нет
delete $new->{$key}, next unless exists $old->{$key};
# Поле с контентом и не менялось
delete $new->{$key}, next if $old->{$key} && $new->{$key} && $new->{$key} eq $old->{$key};
# Поле без контента и не менялось
delete $new->{$key}, next if !$old->{$key} && !$new->{$key};
# ID менять не будем, но удалим на всякий случай
delete $new->{$key}, next if $key eq $f->{id};
# то же самое, проверки значения нет
push @sets, $key . ' = '. (defined $new->{$key} && $new->{$key} =~ /^\d+$/ ? $new->{$key} : '"'.$new->{$key}.'"');
}
# Обновлем измененные поля
my $query = 'UPDATE '.$table_name.
' SET '.(join ', ', @sets).
' WHERE '.$f->{id}.' = '.$old->{$f->{id}};
$dbh->do($query) || return {success => 0, error => $dbh->errstr};
# Опять же запрашиваем строку поcле UPDATE, мало ли какие триггеры что наобновляли
$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};
}
Те же приоритеты что и во время вставки. Ну и еще то, что ходящие данные так же не проверяются на валидность, имейте ввиду.Использование:
Perl код (6)
#-----------------------------------------------------------------------------------------------------------------------
# UPDATE
# Перемещение вниз по дереву
my $update = MY::NestedSets->update($table_name, {field1 => 'row-u-1-'.$tree, ids => 1, lk => 10, tr => $tree});
warn Dumper $update;
# Перем��щение вверх по дереву
$update = MY::NestedSets->update($table_name, {field1 => 'row-u-4-'.$tree, ids => 6, lk => 1, tr => $tree});
warn Dumper $update;
# Меняем родителя
$update = MY::NestedSets->update($table_name, {field1 => 'row-u-8-'.$tree, ids => 2, pi => 5, tr => $tree});
warn Dumper $update;
Удаление узла
Сразу код, комментарии внутри:
Perl код (7)
sub delete {
# Распределяем входящие данные по местам, ну и соответственно проверяем, всего ли нам хватает
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;
# Находим, что за таблица и берем её дополнительные атрибуты и синонимы полей
my $table = $tables->{$table_name} || $tables->{default};
my $f = $table->{fields};
# Так как мы не ограничены как в триггерах в количестве и объеме передаваемых параметров,
# реализация удаления будет двойная: удаление ветки целиком и удаление одного узла дерева
# по умолчанию, удаляем всю ветку
$flag = {cascade => 'cascade', one => 'one'}->{$flag || 'cascade'} || 'cascade';
# Выбираем удаляемый узел, причем нам потребуется только 3 поля: tree, left_key и right_key
# Хотя мы можем его передать как параметр, но мало ли что, могли же до этого изменить ключи,
# а дерево от этого рассыплется.
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') {
# Удаляем ветку
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};
# Убираем разрыв в ключах:
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}.';';
# Запрос в читаемом виде:
# 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 {
# Удаляем узел
my $query = 'DELETE FROM '.$table_name.' WHERE '.$f->{id}.' = '.$id.' LIMIT 1'; # мало ли
$dbh->do($query) || return {success => 0, error => $dbh->errstr};
# Удаляем разрыв и перестраиваем подчиненную ветку
$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}.'));';
# Запрос в читаемом виде:
# 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};
}
Если честно, я еще не придумал, что бы было правильно возвращать в качестве результата, хотя просто флага удачного завершения, мне кажется, более чем достаточно.Применение:
Perl код (8)
my $delete = MY::NestedSets->delete($table_name, 2);
$delete = MY::NestedSets->delete($table_name, 3, 'one');
$delete = MY::NestedSets->delete($table_name, 4);
Собственно и все. Протереть фланелевой тряпочкой, что бы блестело, и в путь.
