package Contenido::Keeper;

# ----------------------------------------------------------------------------
# Класс базы данных
# ----------------------------------------------------------------------------
use strict;
use warnings;
use locale;

use vars qw($VERSION $AUTOLOAD);
$VERSION = '5.0';

use base qw(Contenido::DB::PostgreSQL);

use Data::Dumper;
use Time::HiRes;

use Contenido::Globals;
use Contenido::Msg;

# TODO
# побить на 2-4 модуля вменяемого размера....!  

use constant DATA_SOURCE_LOCAL      => 10;
use constant DATA_SOURCE_MEMCACHED  => 20;
use constant DATA_SOURCE_DATABASE   => 30;

# # ------------------------------------------------------------------------------------------------
# Конструктор объекта базы данных.
#  Обязательный параметр - объект класса Contenido::State из которого
#  конструктор возьмет необходимые параметры для доступа к БД и т.д.
#
# Формат вызова:
#  Contenido::Keeper->new($state)
# ------------------------------------------------------------------------------------------------
sub new {
    my ($proto, $local_state) = @_;

    unless ( ref $local_state ) {
        $log->error("Неправильный вызов конструктора объекта базы данных. В параметрах нет объекта класса Contenido::State");
        die;
    }

    my $class = ref($proto) || $proto;
    my $self = {};
    bless($self, $class);


    # Заполним собственные свойства конкретными данными...
    $self->{db_host} = $local_state->db_host();
    $self->{db_name} = $local_state->db_name();
    $self->{db_user} = $local_state->db_user();
    $self->{db_password} = $local_state->db_password();
    $self->{db_port} = $local_state->db_port();
    # AUTOLOAD method, can не работает
    $self->{db_client_encoding} = $local_state->{attributes}{db_client_encoding} ? $local_state->db_client_encoding() : '';
    $self->{db_enable_utf8}	= $local_state->{attributes}{db_enable_utf8} ? $local_state->db_enable_utf8() : 0;

    $self->{data_dir} = $self->{data_directory} = $local_state->data_directory();
    $self->{images_dir} = $self->{images_directory} = $local_state->images_directory();
    $self->{binary_dir} = $self->{binary_directory} = $local_state->binary_directory();
    $self->{preview} = $local_state->preview();
    $self->{convert_binary} = $local_state->can('convert_binary') ? $local_state->convert_binary : undef;
    
    $self->{debug} = $local_state->debug();
    $self->{store_method} = $local_state->store_method();
    $self->{cascade} = $local_state->cascade();

    $self->{default_status} = [
        [0, 'Скрытый'],
        [1, 'Активный'],
        [2, 'Принято'],
        [3, 'Отложено'],
    ];

    $self->{state} = $local_state;
    $self->_init_();

    # соединяемся с базой если используется постоянное соединение
    $self->db_connect() if $local_state->db_type ne 'none' && $local_state->db_keepalive();
    # соединяемся с memcached
    $self->MEMD()       if $local_state->memcached_enable();

    return $self;
}

# ----------------------------------------------------------------------------
# Инициализация.
#  - Создает внутри объекта хэш с типами полей - это нужно для быстрой
#   работы метода AUTOLOAD...
# ----------------------------------------------------------------------------
sub _init_ {
    my $self = shift;

    foreach my $attribute ( qw(
            db_host db_name db_user db_password db_port

            data_directory data_dir
            images_directory images_dir
            binary_directory binary_dir

            store_method cascade

            default_status

            debug
            state
            )    )
    {
        $self->{attributes}->{ $attribute } = 'SCALAR';
    }
}

sub get_items {
    my ($self, $proto, %opts) = @_;

    $log->info("get_items($proto) called with opts: ".Data::Dumper::Dumper(\%opts)) if $DEBUG;

    #установка доп опций
    $opts{all_childs} = $self->_all_childs($opts{s}) if ($opts{dive} and $opts{s});

    # -------------------------------------------------------------------------------------------
    # выставляем режим возвращаемых данных (array|array_ref|hash|hash_ref|count)
    # default array for compatibility reasons
    # hash/hash_ref хешируют по умолчанию по полю id...
    # hash_by параметр может установить произвольное поле обьекта для построения хеша
    # return_mode => 'count' эквивалентно count=>1
    # return_mode имеет более высокий приоритет чем count

    if ($opts{count} and $opts{return_mode} and ($opts{return_mode} ne 'count')) {
        $log->warning("get_items($proto) have count=>1 and return_mode=>$opts{return_mode} set... using $opts{return_mode} mode"); delete $opts{count};
    } elsif ($opts{count}) {
        $opts{return_mode} = 'count';
    } elsif (defined($opts{return_mode}) and $opts{return_mode} eq 'count') {
        $opts{count} = 1;
    }

    # выставляем совместимое значение return_mode если не указанно обратного
    my $mode = $opts{return_mode} || 'array';
    # ----------------------------------------------------------------------------------------

        #-----------------------------------------------------------------------------------------
        # убираем возможную сортировку если указано in_id_sort
        # и проставляем sort_list если он не стоит
        #-----------------------------------------------------------------------------------------
        if ($opts{in_id_sort} && $opts{in_id}) {
        $opts{sort_list} = $opts{in_id};
    }

    #-----------------------------------------------------------------------------------------
    # если есть sort_list и return_mode не array или array_ref ругаемся и сбрасываем sort_list
    #-----------------------------------------------------------------------------------------
    if ($opts{sort_list} and ($mode ne 'array') and ($mode ne 'array_ref')) {
        delete $opts{sort_list};
        $log->warning("sort_list set with incompatible return_mode: '$mode'");
    }

    # -----------------------------------------------------------------------------------------
    # убираем все order_by если у нас hash или hash_ref return_mode или стоит in_id_sort
    # тоесть режим возвращаемых данных не предполагает сортировки базой чего либо
    # можно руками выставить если очень хочется в opts
    # todo добавить некий warns если при этот order или order_by в параметрах есть
    # ----------------------------------------------------------------------------------------
    if ( (($mode eq 'hash' or $mode eq 'hash_ref') && !(exists $opts{limit} || exists $opts{offset})) or ($mode eq 'count') or $opts{sort_list}) {
        $opts{no_order} = 1;
        if ($opts{order} or $opts{order_by}) {
            my $mason_comp = ref($HTML::Mason::Commands::m) ? $HTML::Mason::Commands::m->current_comp() : undef;
            my $mason_file = ref($mason_comp) ? $mason_comp->path : undef;
            $log->warning("Указание сортировки проигнорировано так как указан несовместимый режим. ".($mason_file ? "called from $mason_file" : ''));
            delete $opts{order};
            delete $opts{order_by};
        }
    }

    # ----------------------------------------------------------------------------------------
    # Формируем запрос
    # ToDo: добавить механизм кеширования полученных запросов
    #-----------------------------------------------------------------------------------------
    my ($query, $binds) = $proto->_get_sql(%opts);
    return unless ($query);


    my $start = Time::HiRes::time() if ($DEBUG);
    # ---------------------------------------------------------------------------------------
    # Подготавливаем запрос и кешируем полученные prepared запросы (см докуметацию DBI на счет prepare_cached)
    # действительно работает на pgsql 8.0+ и новых версиях DBD (и помогает!)
    # ----------------------------------------------------------------------------------------
    my $sth;
    if ($opts{no_prepare_cached}) {
        unless ($sth = $self->SQL->prepare($$query)) {
           $self->error;
           $log->error("DBI prepare error on $$query\ncalled with opts: ".Data::Dumper::Dumper(\%opts));
           return;
        }
    } else {
        unless ($sth = $self->SQL->prepare_cached($$query, {}, 1)) {
           $self->error;
           $log->error("DBI prepare error on $$query\ncalled with opts: ".Data::Dumper::Dumper(\%opts));
           return;
        }
    }

    # ----------------------------------------------------------------------------------------
    # Выполняем
    # ----------------------------------------------------------------------------------------
    unless ($sth->execute(@$binds)) {
       $self->error;
       $log->error("DBI execute error on $$query\n".Data::Dumper::Dumper($binds)."\ncalled with opts:\n".Data::Dumper::Dumper(\%opts));
       return;
    }
    my $finish1 = Time::HiRes::time() if ($DEBUG);

    #-----------------------------------------------------------------------------------------
    # подготавливаем результаты в нужном формате
    #-----------------------------------------------------------------------------------------
    my ($res, $total);
    ($res, $total) = $self->_prepare_array_results($sth, \%opts) if ($mode eq 'array' or $mode eq 'array_ref');
    ($res, $total) = $self->_prepare_hash_results($sth,  \%opts) if ($mode eq 'hash'  or $mode eq 'hash_ref');
    ($res, $total) = $self->_prepare_count_results($sth, \%opts) if ($mode eq 'count');
    $sth->finish();
    my $finish2 = Time::HiRes::time() if ($DEBUG);

    if ($DEBUG) {
        my $mason_comp = ref($HTML::Mason::Commands::m) ? $HTML::Mason::Commands::m->current_comp() : undef;
        my $mason_file = ref($mason_comp) ? $mason_comp->path : undef;
        my $db_time    = int(10000*($finish1-$start))/10;
        my $core_time  = int(10000*($finish2-$finish1))/10;
        my $total_time = int(10000*($finish2-$start))/10;

        $Contenido::Globals::DB_TIME   += $finish1-$start;
        $Contenido::Globals::CORE_TIME += $finish2-$finish1;
        $Contenido::Globals::DB_COUNT++;

        $log->info("get_items($proto) ".($mason_file ? "called from $mason_file" : '')." SQL: '$$query' with binds: '".join("', '", @$binds)."' fetched: $total records (total work time: $total_time ms, database time $db_time ms, core time $core_time ms)");
    }

    #выдает предупреждение если полученно более 500 обьектов но не выставлен no_limit
    if ($total>999 and !($opts{no_limit} or $opts{limit})) {
        my $mason_comp = ref($HTML::Mason::Commands::m) ? $HTML::Mason::Commands::m->current_comp() : undef;
        my $mason_file = ref($mason_comp) ? $mason_comp->path : undef;
        $log->error("get_items($proto) ".($mason_file ? "called from $mason_file" : '')." SQL: '$$query' with binds: '".join("', '", @$binds)."' fetched 1000 records... гарантированно часть записей не получена из базы... или добавьте no_limit=>1 или разберитесь почему так много данных получаете");
    } elsif ($total>500 and !($opts{no_limit} or $opts{limit})) {
        my $mason_comp = ref($HTML::Mason::Commands::m) ? $HTML::Mason::Commands::m->current_comp() : undef;
        my $mason_file = ref($mason_comp) ? $mason_comp->path : undef;
        $log->warning("get_items($proto) ".($mason_file ? "called from $mason_file" : '')." SQL: '$$query' with binds: '".join("', '", @$binds)."' fetched over 500 ($total) records... или добавьте no_limit=>1 или разберитесь почему так много данных получаете");
    }

    # -----------------------------------------------------------------------------------------
    # возвращаем разные результаты в зависимости от того какой return_mode просят
    # -----------------------------------------------------------------------------------------
    if ($mode eq 'array') {
        return @$res;
    } elsif ($mode eq 'array_ref') {
        return $res;
    } elsif ($mode eq 'hash') {
        return %$res;
    } elsif ($mode eq 'hash_ref') {
        return $res;
    } elsif ($mode eq 'count') {
        return $res;
    } else {
        $log->error("get_items($proto) unsupported return_mode called with opts: ".Data::Dumper::Dumper(\%opts));
        return;
    }
}

#internal only method
sub _prepare_count_results {
    my ($self, $sth, $opts) = @_;
    my ($count) = $sth->fetchrow_array();
    return ($count, 1);
}

#internal only method
sub _prepare_hash_results {
    my ($self, $sth, $opts) = @_;

    #To Do вывод warnings при использование ключей несовместимых с hash режимами... как то: in_id_sort 
    #To Do доделать hash mode для $opts{names} и для $opts{ids}

    # выставляем умолчательное значение hash_by
    my $hash_by = $opts->{hash_by} || 'id';
        # выставляем умолчательное значение hash_index
        my $hash_index = $opts->{hash_index} || 0;

    my %items;
    my $total = 0;

    if ($opts->{names}) {
        while (my $row = $sth->fetch) {
            $items{$row->[0]} = $row->[1];
        }
    } elsif ($opts->{ids} || $opts->{field}) {
        if (ref($opts->{field})) {
                        #hashing by first field by default
                        while (my $row = $sth->fetch) {
                                $items{$row->[$hash_index]} = [@$row]; 
                        }
        } else {
            while (my $row = $sth->fetch) {
                $items{$row->[0]} = 1;
            }
        }
    } else {
        my $item;
        while (my $row = $sth->fetch) {
            eval { $item=$row->[0]->init_from_db($row, $self, $opts->{light}); };
            if ($@) {
                $log->error("Сannot init item from database for $row->[0] because '$@'");
            } else {
                $item->post_init($opts);
                $self->set_object_to_cache($item, 30, $opts) if ($opts->{with_cache});
                $total++;
		if ( exists $item->{$hash_by} && defined $item->{$hash_by} ) {
	                $items{$item->{$hash_by}} = $item;
		} else {
                        $log->warning( "Can not HASH BY parameter [$hash_by]. It doesn't exists in row or the field is empty");
		}
            }
        }
    }
    return (\%items, $total);
}

#internal only method
sub _prepare_array_results {
    my ($self, $sth, $opts) = @_;

    my @items;

    if ($opts->{names} || (ref($opts->{field}) eq 'ARRAY')) {
        @items = @{$sth->fetchall_arrayref()};
    } elsif ($opts->{ids} || $opts->{field}) {
        while (my $row = $sth->fetch) {
            push @items, $row->[0];
        }
    } else {
        my $item;
        while (my $row = $sth->fetch) {
            eval { $item=$row->[0]->init_from_db($row, $self, $opts->{light}); };
            if ($@) {
                $log->error("Cannot init item from database for $row->[0] because '$@'");
            } else {
                $item->post_init($opts);
                $self->set_object_to_cache($item, 30, $opts) if ($opts->{with_cache});
                push @items, $item;
            }
        }
    }

    return (\@items, scalar(@items));
}

#понять бы зачем этот метод нужен
sub get_objects {
    return shift->get_items('Contenido::Object', @_);
}

# ------------------------------------------------------------------------------------------------
# Получение документов, подходящих под условия отбора:
#   @documents = $keeper->get_documents( %search_options )
#
# Параметры отбора:
#   s - номер секции (если задан параметр dive, то s может содержать только один номер секции, в противном случае s
#   может содержать ссылку на массив номеров секций);
#   sfilter - секция-фильтр. В конечную выборку включаются только документы, попадающие в sfilter (если та задана).
#   Может быть задан массив секций (с помощью ссылки на массив);
#   dive - если установлен в истину, то отбор будет производиться по все ее детям;
#   intersect - флаг "пересечение секций". Если установлен, то будут отобраны документы, привязанные ко всем
#   перечисленным в s секциям, если не установлен - к любой из перечисленных секций.
#   include_parent - если этот параметр задан, то отбор будет происходить и из самой секции. По умолчанию - задан;
#   date_equal - точное соответствие даты (YYYY-MM-DD);
#   date - ссылка на массив с двумя датами (началом и концом интервала);
#   previous_days - запрос за ... последних дней;
#   datetime    - custom dtime filters допустимые значения 'future','past','today' 
#
#   use_mtime   - использовать во всех выборках по времени mtime вместо dtime (!)
#   use_ctime   - использовать во всех выборках по времени ctime вместо dtime (!)
#
#   status - заданный идентификатор статуса (или ссылка на массив со статусами);
#   class - заданный класс объекта (--"--);
#   order - порядок выборки:
#   ['date','direct'] - по дате в прямом порядке;
#   ['date','reverse'] - по дате в обратном порядке;
#   ['name','direct'/'reverse'] - по имени в прямом или обратном порядке;
#   [] - без сортировки
#
#   in_id [id,id,id,...] - выборка по идентификаторам (по целой пачке - ссылка на массив идентификаторов)
#   name - поиск по названию;
#   excludes - ссылка на массив всех идентификаторов, которые надо исключить из отбора
#   class_excludes - ссылка на массив классов, исключенных для выборки
#   count - если задан в единицу, то вернет число - количество элементов
#   ids - если задан в единицу, то вернет только идентификаторы объектов...
#   names - если задан в единицу, то вернет набор пар [идентификатор, имя]
#   offset - возможность задать оффсет для выборки документов...
#
#   like - выборка с помощью like (должно быть задано name)
#   ilike - выборка с помощью ilike (должно быть задано name)
#
#   light - если установить в 1, то вернет объекты без выполнения restore()
#   limit - ограничение на количество возвращаемых элементов
#
#   Три параметра, которые требуются для построения join-запросов. Рекомендуется использовать их
#   для выборок документов связанных с каким-то конкретным документом какой-то конкретной связью:
#   lclass - класс связи
#   ldest - идентификатор dest_id
#   lsource - идентификатор source_id
#   lstatus - статус в таблице связей
#   id - выборка 1 документа по id
# ------------------------------------------------------------------------------------------------
sub get_documents {
    return shift->get_items('Contenido::Document', @_);
}



# ------------------------------------------------------------------------------------------------
# Получение связей, подходящих под условия отбора:
#   @links = $keeper->get_links( %search_options )
#
# Параметры отбора:
#   status - заданный идентификатор статуса (или ссылка на массив идентификаторов);
#   class - заданный класс объекта (--"--);
#
#   dest_id - идентификатор (или ссылка на массив идентификаторов)
#   source_id - идентификатор (или ссылка на массив идентификаторов)
#
#   excludes - ссылка на массив всех идентификаторов, которые надо исключить из отбора
#   class_excludes - ссылка на массив классов, исключенных для выборки
#
#   count - если задан в единицу, то вернет число - количество элементов
#   ids - если задан в единицу, то вернет только идентификаторы связей...
#
#   offset - возможность задать оффсет для выборки документов...
#
#   light - если установить в 1, то вернет объекты без выполнения restore()
#   limit - ограничение на количество возвращаемых элементов
# ------------------------------------------------------------------------------------------------
sub get_links {
    return shift->get_items('Contenido::Link', @_);
}



# ------------------------------------------------------------------------------------------------
# Получение секций, подходящих под условия отбора:
#   @sections = $keeper->get_sections( %search_options )
#
# Параметры отбора:
#   s - номер родительской;
#
#   status - заданный идентификатор статуса (или ссылка на массив);
#   class - заданный класс секции (--"--);
#   order - порядок выборки:
#   ['name','direct'/'reverse'] - по имени в прямом или обратном порядке;
#   [] - без сортировки
#   name - поиск по названию;
#
#   in_id [id,id,id,...] - выборка по идентификаторам (по целой пачке)
#   ids - если задан в единицу, то вернет только идентификаторы секций...
#   names - если задан в единицу, то вернет набор пар [идентификатор, имя]
#
#   light - если установить в 1, то вернет объекты без выполнения restore()
#   limit - ограничение на размер выборки
# ------------------------------------------------------------------------------------------------
sub get_sections {
    return shift->get_items('Contenido::Section', @_);
}

# ----------------------------------------------------------------------------
# Метод для получения списка пользователей системы
#   @users = $keeper->_get_users( %search_options )
#
# Параметры отбора:
#   s - номер секции (s может содержать ссылку на массив номеров секций);
#   intersect - флаг "пересечение секций". Если установлен, то будут отобраны документы, привязанные ко всем
#   перечисленным в s секциям, если не установлен - к любой из перечисленных секций.
#   class - заданный класс объекта (--"--);
# ----------------------------------------------------------------------------
sub _get_users {
    return shift->get_items('Contenido::User', @_);
}
# XXX Не использовать - будет удалена в следующих версиях. Использовать _get_users()
sub get_users {
    return shift->_get_users(@_);
}


# -------------------------------------------------------------------------------------------------
# Получение деревца...
# Параметры:
#   light => облегченная версия
#   root => корень дерева (по умолчанию - 1)
# -------------------------------------------------------------------------------------------------
sub get_tree {
	my $self = shift;
    return Contenido::Section->new($self)->get_tree(@_);
}

sub get_section_tree {
    my $self = shift;
    my ( %opts ) = @_;

    delete $opts{return_mode}		if exists $opts{return_mode};
    delete $opts{order_by}		if exists $opts{order_by};
    delete $opts{no_limit}		if exists $opts{no_limit};
    my $root_id = delete $opts{root_id};
    $opts{light} = exists $opts{light} ? $opts{light} : 1;
    my $sections = $self->get_sections (
		%opts,
		return_mode	=> 'array_ref',
		order_by	=> 'sorder',
		no_limit	=> 1,
	);
    my %section_hash = map { $_->id => $_ } @$sections	if ref $sections eq 'ARRAY';
    my %tree;
    if ( ref $sections eq 'ARRAY' ) {
	foreach my $sect ( @$sections ) {
		if ( !$sect->pid || $sect->id == 1 ) {
			$tree{0} = $sect;
		} else {
			if ( exists $tree{$sect->pid} ) {
				if ( exists $tree{$sect->pid}{children} ) {
					push @{ $tree{$sect->pid}{children} }, $sect;
				} else {
					$tree{$sect->pid}{children} = [$sect];
				}
			} elsif ( exists $section_hash{$sect->pid} ) {
				$tree{$sect->pid} = $section_hash{$sect->pid};
				$tree{$sect->pid}{children} = [$sect];
			}
			if ( $root_id && $sect->id == $root_id ) {
				$tree{root} = $sect;
			}
		}
	}
	if ( (!$root_id || !exists $tree{root}) && exists $tree{0} ) {
		$tree{root} = $tree{0};
	}
    }
    return \%tree;
}

# -------------------------------------------------------------------------------------------------
# Получаем объект по идентификатору. А зачем вообще нужен этот метод? А! Потому что мы
#  еще не знаем имени класса.
#
# Этот метод получает тип того, что мы извлекаем (секция, документ, связь)
# -------------------------------------------------------------------------------------------------
sub __get_by_id__ {
    my ($self, $proto, %opts) = @_;
    return unless ($opts{id});
    #на всякий случай устанавливаем возврат только 1 значения из базы
    $opts{limit} = 1;
    #отключаем сортировку как бессмысленную
    $opts{no_order} = 1;
    my ($item)=$self->get_items($proto, %opts);
    return $item;
}

sub get_document_by_id {
    my ($self, $id, %opts) = @_;
    return unless $id;
    $opts{id} = $id;
    return $self->__get_by_id__('Contenido::Document', %opts);
}

sub get_section_by_id {
    my ($self, $id, %opts) = @_;
    return unless $id;
    $opts{id} = $id;
    return $self->__get_by_id__('Contenido::Section', %opts);
}

sub get_link_by_id {
    my ($self, $id, %opts) = @_;
    return unless $id;
    $opts{id}=$id;
    return $self->__get_by_id__('Contenido::Link', %opts);
}

sub get_user_by_id {
    my ($self, $id, %opts) = @_;
    return unless $id;
    $opts{id}=$id;
    return $self->__get_by_id__('Contenido::User', %opts);
}


# -------------------------------------------------------------------
# Умный метод. Сначала ищет объект в $request->{_cache_},
# потом в memcached (если включена поддержка, конечно), и только потом уже идёт в базу.
# Полученные из базы данные складывает в $request и в memcached.
# $level это с кеша какого уровня мы все это достали (10 уровень локальный кеш, 20 уровень memcached, 30 база)
sub get_object_by_id {
    my ($self, $id, %opts) = @_;

    my ($object, $level) = $self->get_object_from_cache($id, \%opts) unless ($opts{expire});

    #не нашли в кешах идем в базу
    unless ($object) {
        $object = $self->__get_by_id__($opts{proto}||'Contenido::Document', %opts, id=>$id);
        $level = DATA_SOURCE_DATABASE;
    }
    
    #ну не шмогла я нешмогла... aka нет такого на белом свете объекта
    unless ($object) {
        return;
    }

    #если с 10 уровня достали то ничего более кешировать всеравно нет смысла
    $self->set_object_to_cache($object, $level, \%opts, $state->{memcached_set_mode})
        if $level > DATA_SOURCE_LOCAL;

    return $object;
}

# -------------------------------------------------------------------
# Тоже умный метод. Зачастую в таблицах id является суррогатным ключом,
# а некоторое символическое имя - настоящим, например, login в таблицах
# users. Данная функция кеширует соответствие уникального символического
# имени объекта и его id, позволяя не обращаться к базе всякий раз при
# получении данных таким образом.
# -------------------------------------------------------------------
sub get_object_by_unique_key {
    my ($self, $unique, %opts) = @_;

    return undef unless defined $unique;

    my ($id, $level) = (undef, DATA_SOURCE_DATABASE);
    my %key_list = ();

    my $class = $opts{class};
    return undef unless defined $class;

    my $key = $class->get_object_unique_key($unique);
    return undef unless $key;

    my $object = undef;

    unless ($opts{expire}) {
        if (exists $request->{_cache_}->{$key}) {
            ($id, $level) = $request->{_cache_}->{$key};
            $level = DATA_SOURCE_LOCAL;
        } elsif (($self->{state}->{memcached_enable}) &&
                 (defined ($id = $self->MEMD->get($key)))) {
            $level = DATA_SOURCE_MEMCACHED;
        }

        # Соответствие в кеше имеется, ищем объект по id
        if (defined $id) {
            $object = $self->get_object_by_id($id, %opts);
            # Если какая-то скотина умудрилась грохнуть объект в обход зависимостей
            unless (defined $object) {
                $self->MEMD->delete($key);
            }
        }
    }

    # Соответствие не найдено или найдено неверное.
    unless (defined $object) {
        my $attr = $class->class_table->unique_attr;
        ($object) =
            $self->get_items(
                $class,
                'limit' => 1,
                'no_order' => 1,
                $attr => $unique,
                'class' => $class
            );
    }

    # Объект с таким уникальным ключем не найден.
    return undef unless defined $object;

    $self->set_object_unique_key_to_cache($object, $level, \%opts)
        if $level > DATA_SOURCE_LOCAL;

    return $object;
}

sub set_object_unique_key_to_cache {
    my ($self, $object, $level, $opts) = @_;

    my $key = $object->get_object_unique_key;

    if (defined $key) {
        if ($level > DATA_SOURCE_LOCAL) {
            $request->{_cache_}->{$key} = $object->id;
        }
        if (($level > DATA_SOURCE_MEMCACHED) and ($self->state->{memcached_enable})) {
            my $expire =
                exists $opts->{'expire_in'}
                    ? $opts->{'expire_in'}
                    : $object->memcached_expire;
            if ($self->state->{memcached_delayed}) {
                $request->{_to_memcache}{$key} = [$object->id, $expire, 'set'];
            } else {
                $self->MEMD->set($key, $object->id, $expire);
            }
        }
    }

    return $object;
}

#достает обьект из кеша по его id
sub get_object_from_cache {
    my ($self, $id, $opts) = @_;

    my $object;
    my %key_list = ();

    #определяем по какому классу работаем (надо для определения ключа кеширования)
    my @classes;
    if (ref($opts->{class}) eq 'ARRAY') {
            foreach my $class (@{$opts->{class}}) {
                    $key_list{$class->get_object_key($id, $opts)} = $class;
            }
    } elsif ($opts->{class}) {
        $key_list{$opts->{class}->get_object_key($id, $opts)} = $opts->{class};
    } elsif ($opts->{table}) {
        $key_list{$opts->{table}->_get_object_key(undef, $id, $opts)} = $opts->{table};
    } else {
        my $class = $opts->{proto} || 'Contenido::Document';
        $key_list{$class->get_object_key($id, $opts)} = $class;
    }

    while (my ($object_key, $class) = each(%key_list)) {
        if (defined($request->{_cache_}->{$object_key})) {
            return ($request->{_cache_}->{$object_key}, DATA_SOURCE_LOCAL);
        } elsif ($self->MEMD) {
            if ($object = $self->MEMD->get($object_key)) {
                $object->recover_from_cache($self, $opts) if $object->can('recover_from_cache');
                return ($object, DATA_SOURCE_MEMCACHED);
            } else {
                return;
            }
        }
    }
    return;
}

#может кешировать любой обьект поддерживающий метод set_to_cache (не обязательно производное Contenido::Object)
#$level это с кеша какого уровня мы все это достали (10 уровень локальный кеш, 20 уровень memcached, 30 база)
#$mode => set|add (default set)
sub set_object_to_cache {
    my ($self, $object, $level, $opts, $mode) = @_;

    #выставляем ключ по обьекту
    my $object_key = $object->can('get_object_key') ? $object->get_object_key($opts) : ref($object).'|'.$object->id();

    if ($level > DATA_SOURCE_LOCAL) {
        $request->{_cache_}->{$object_key} = $object;
    }
    if ($level > DATA_SOURCE_MEMCACHED and $self->state->{memcached_enable}) {
        my $value = $object->can('prepare_for_cache') ? $object->prepare_for_cache($opts) : $object;
        my $expire = exists $opts->{'expire_in'} ? $opts->{'expire_in'} : $object->memcached_expire;
        if ($self->state->{memcached_delayed}) {
            $request->{_to_memcache}{$object_key} = [$value, $expire, $mode];
        } else {
            if ($mode && $mode eq 'add') {
                $self->MEMD->add($object_key, $value, $expire);
            } else {
                $self->MEMD->set($object_key, $value, $expire);
            }
        }
    }
    return $object;
}

sub get_user_by_login {
    my ($self, $login, %opts) = @_;
    return unless $login;
    $opts{login}=$login;
    my ($item)=$self->get_items('Contenido::User', %opts);
    return $item;
}

############################## DIFFERENT TRASH CODE #######################################################################
# ----------------------------------------------------------------------------
# Обработчик ошибки. Очень важная функция, именно в ней мы будем
#  хранить все возможные коды ошибок и так далее...
# надо ли это вообще вот в чем вопрос
# ----------------------------------------------------------------------------
sub error {
    my $self = shift;

    $self->{last_error} = shift || $self->SQL->errstr();
    chomp($self->{last_error});

    my $mason_comp = ref($HTML::Mason::Commands::m) ? $HTML::Mason::Commands::m->current_comp() : undef;
    my $mason_file = ref($mason_comp) ? $mason_comp->path : undef;

    $log->error(($mason_file ? "Called from $mason_file" : '')."$self->{last_error}");
}


sub minimize_image {
    my $self = shift;
    my $IMAGE = shift;
    my $PREVIEW = shift;

    my $SLINE = $self->{convert_binary};
    my $PREVIEWLINE = " -geometry '".($PREVIEW || $self->{preview})."' -quality 80";
    my $SFILE = $IMAGE->{filename};
    my $DFILE = $SFILE;
    $DFILE =~ s/\.([^\.]*)$/\.mini\.$1/;
    $SLINE = $SLINE.' '.$PREVIEWLINE.' '.$self->{state}->{images_directory}.'/'.$SFILE.' '.$self->{state}->{images_directory}.'/'.$DFILE;

    my $RESULT = `$SLINE`;
    if (length($RESULT) > 0)
    {
        $log->error("При вызове '$SLINE' произошла ошибка '$RESULT' ($@)");
        return undef;
    }
    
    $IMAGE->{mini}->{filename} = $DFILE;
    ($IMAGE->{mini}->{width}, $IMAGE->{mini}->{height}) = Image::Size::imgsize($self->{state}->{images_directory}.'/'.$DFILE);

    return $IMAGE;
}

sub get_sorted_documents {
    my ($self, %opts) = @_;
    unless ($opts{s}) {
        my $mason_comp = ref($HTML::Mason::Commands::m) ? $HTML::Mason::Commands::m->current_comp() : undef;
        my $mason_file = ref($mason_comp) ? $mason_comp->path : undef;
        $log->warning("Method $keeper->get_sorted_documents(...) called without required param s=>".($mason_file ? "called from $mason_file":"")."\ncalled with opts:\n".Data::Dumper::Dumper(\%opts));
        return;
    }
    my $section = $self->get_section_by_id($opts{s});
    if ($section->{_sorted}) {
        $opts{sort_list} = [split(',', $section->_sorted_order())];
    } else {
        $log->warning("Method $keeper->get_sorted_documents(...) called with s=>$opts{s} but section have _sorted disabled\n");
    }
    return $self->get_documents(%opts);
}

sub _all_childs {
    my ($self, $s)=@_;
    return [] unless $s;
    # Получаем всех детишек от данной секции и вглубь...
    my $tree = $self->get_section_tree( root_id => $s );
    return []	unless ref $tree && exists $tree->{root} && ref $tree->{root} && $tree->{root}->id == $s;
    my @all_childs;
    my $root = $tree->{root};
    my @stack = exists $root->{children} ? @{$root->{children}} : ();
    while ( @stack ) {
	my $sect = shift @stack;
	push @all_childs, $sect->id;
	if ( exists $sect->{children} ) {
		push @stack, @{$sect->{children}};
	}
    }
    return \@all_childs;
}

# -------------------------------------------------------------------
# Инициализирует $keeper->{MEMD}
#--------------------------------------------------------------------
sub MEMD {
    my $self = shift;

    return undef unless $self->{state}->{memcached_enable};

    unless ( $self->{MEMD} && ref $self->{MEMD} &&  ref $self->{MEMD}->server_versions eq 'HASH' && keys %{$self->{MEMD}->server_versions} ) {
        my $implementation = $self->state()->memcached_backend();
        $self->{MEMD} = $implementation->new({
            servers => $self->state()->memcached_servers(),
            compress_threshold => 10_000,
            namespace => $self->state()->memcached_namespace,
            enable_compress => $self->state()->memcached_enable_compress(),
            connect_timeout => 0.1,
            io_timeout => $self->state()->memcached_select_timeout(),
            check_args => 'skip'
        });
        $self->{MEMD}->enable_compress( $self->state()->memcached_enable_compress() );
    }
    return $self->{MEMD};
}

# ----------------------------------------------------------------------------
# Это умный AUTOLOAD. Ловит методов для установки/чтения полей...
# Версия 0.2
# ----------------------------------------------------------------------------
sub AUTOLOAD {
    my $self = shift;
    my $attribute = $AUTOLOAD;

    $attribute =~ s/.*:://;
    return undef    unless  $attribute =~ /[^A-Z]/;     # Отключаем методы типа DESTROY

    unless (ref $self) { 
        $log->error("Прямой вызов неизвестной функции $AUTOLOAD()");
        return undef;
    } elsif (! exists($self->{attributes}->{$attribute})) {
        $log->error("Вызов метода, для которого не существует обрабатываемого свойства: ->$attribute()");
        return undef;
    }

    $self->{ $attribute } = shift @_  if scalar @_ > 0;
    return $self->{ $attribute };
}


1;