unit sDB;

{$mode objfpc}

interface

uses
  Classes, SysUtils, FileUtil, ShlepsUtils, uanycommand;

Type
  TsDB=Class(TObject)
    sDBPath:String;
    Name:String;
    CtxList:TStringList;
    Constructor Create;
    Destructor Destroy; override;
  End;

  // контекст знает свое имя, но не знает в какой DB он находится
  // Если
  // объект знает свое ID, но не знает в каком контексте он находится
  // это дает переносимость между единицами хранения
  // но при переносе объекта между контекстами надо исправлять ссылки, чтобы показывали в другой контекст (а это вообще возможно?)
  // контекст можно перенести целиком, например для бэкапа

  TDataTree=Class(TObject)
    Path:String;
    Module:Longint;
    Depth:Longint;
    CacheSize:Longint;
    CacheProtected:Boolean;
    CachePolicy:String;    // возможные значения write-back+least  отсустствие этих флагов трактуется, как write-through+last
    Cache:TStringList;
    DirtyCache:TStringList; //список строк с номерами объектов
    NextFree:Longint;
    FreeList:TStringList;
    Constructor Create;
    Destructor Destroy; override;
  end;

  TsDBCtx=Class(TObject)
    DB:TsDB;
    Name:String; //знает ли контекст свое имя?
    Path:String;
    NameTree:TDataTree;
    ConceptTree:TDataTree;
    Constructor Create;
    Destructor Destroy; override;
  End;

  TCacheObject=Class(TObject)
    Ctx:TsDBCtx;
    Tree:TDataTree;
    ObjectID:Longint;
    InternalName:String;
    Path:String;
    LinkKeys:TStringList;
    LinkTypes:TStringList;
    LinkAddrTypes:TStringList;
    LinkAddrs:TStringList;
    Constructor Create;
    Destructor Destroy; override;
  End;

  TsDBCursor=Class(TObject)
    Name:String;
    DBName:String;
    DB:TsDB;
    CtxName:String;
    Ctx:TsDBCtx;
    ConceptID:String;
//    CacheObject:TCacheObject;
    SearchResults:TStringList;
    Constructor Create;
    Destructor Destroy; override;
  End;

Var
  sDBList:TStringList;
  CursorList:TStringList;
  ActiveCursorName:String;
  ActiveCursor:TsDBCursor;

Function GetCursorByName(Name:String):TsDBCursor;
Function FlushCacheObject(Var CacheObject:TCacheObject):String;
Function LookupFQ(DBName,CtxName:String;Var DB:TsDB;Var Ctx:TsDBCtx):String;
Function Read2Cache(Var CacheObject:TCacheObject;var Error:String):String;
Procedure TryDecreaseCache(Var Tree:TDataTree);
Function CreateNode(Var Ctx:TSDBCtx;Var Tree:TDataTree;InternalName:String;Var Error:String):TCacheObject;
Function Read2CacheByID(Var Error:String;Var Ctx:TsDBCtx;Var Tree:TDataTree;ID:String):TCacheObject;
Function BranchByKey(Source:TCacheObject;Key:String;Var List:TStringList;Var EvalResult:TStringList):String;
Function WriteValuePlus(CacheObject:TCacheObject;Key,Value:String):String;

Function sDB_CreateCursor(Name:String):String;
Function sDB_SetCursor(CursorName,DBName,Addr:String):String;
Function sDB_DeleteCursor(Name:String):String;
Function sDB_CopyCursor(Name1,Name2:String):String;
Function sDB_AddToCursor(Name1,Name2:String):String;
Function CursorIsEmpty(CursorName:String):Boolean;

Function sDB_CreateDB(DBName,Path:String):String;
Function sDB_OpenDB(Path:String):String;
Function sDB_CloseDB(DBName:String):String;
Function sDB_DeleteDB(Path:String):String;
Function sDB_CreateCtx(DBName,CtxName,Module,Depth,CacheSize,CachePolicy,NModule,NDepth,NCacheSize,NCachePolicy:String):String;
Function sDB_DeleteCtx(DBName,CtxName:String):String;
Function sDB_FQFlushCacheObject(DBName,CtxName,ObjectID:String):String;
Function sDB_FQWriteName(DBName,CtxName,Name,ConceptID:String):String;
Function sDB_FQDeleteConcept(DBName,CtxName,ConceptID:String):String;
Function sDB_FQGetConceptHandleByID(DBName,CtxName,ConceptID:String):TCacheObject;
Function sDB_FQFindConceptByName(DBName,CtxName,Name:String):String;

Function sDB_CRCreateConcept(CursorName,InternalName:String):String;
Function sDB_CACreateSLink(CursorName,SourceAddr,Key,AddrType,Addr:String):String;
Function sDB_CACreateALink(CursorName,SourceAddr,Key,AddrType,Addr:String):String;
Function sDB_CRCreateRelation(CursorName,InternalName:String):String;
Function sDB_CACreateBinRel(CursorName,Addr1,Addr2,RelIntName,Aspect1,Aspect2:String):String;
Function sDB_CRCreateBinRel(CursorName1,CursorName2,RelIntName,Aspect1,Aspect2:String):String;
Function sDB_CAFindConcept(CursorName,Addr:String):String;
Function sDB_CRSearchByName(CursorName,Name:String):String;
Function sDB_CRSearchByChain(CursorName,Chain:String):String;
Function sDB_CRFilterOutByChain(CursorName,Chain:String):String;
Function sDB_CRFilterKeepByChain(CursorName,Chain:String):String;
Function sDB_CAWriteValue(CursorName,SourceAddr,Key,Value:String;List:TStringList):String;
Function sDB_CAWriteValuePlus(CursorName,SourceAddr,Key,Value:String):String;
Function sDB_CRWriteValuePlus(CursorName,Key,Value:String):String;
Function sDB_CAEvalByChain(CursorName,Addr,Chain:String;Var Value:TStringList):String;
Function sDB_CASetAttrValue(CursorName,ConceptAddr,AttrName,Value:String):String;
Function sDB_CAImportObject(CursorName,Addr,FileName:String):String;
//Function sDB_CRExportObject(CursorName,Addr,FileName:String):String;
Function sDB_CAAddToGroup(CursorName,GroupAddr:String):String;
Function sDB_CRAddToGroup(ElementCursor,GroupCursor:String):String;
Function sDB_CRActivateMethod(CursorName,Name:String):String;
Function sDB_CAEnumAttrs(CursorName,Addr:String;Var AttrList:TStringList):String;
Function sDB_CRActivatePrototypeMethod(CursorName,Name:String):String;
{ TODO :

}

implementation

Uses Dispatcher;

Constructor TsDB.Create;
Begin
  Inherited Create;
  CtxList:=TStringList.Create;
End;

Destructor TsDB.Destroy;
Var CTX:TsDBCTX; I:Longint;
Begin
  //освобождаем каждый из контекстов
  If CtxList.Count>0 Then Begin
    For I:=CtxList.Count-1 DownTo 0 Do Begin
      CTX:=CtxList.Objects[I] As TsDBCtx;
      Ctx.Free;
      CtxList.Delete(I);
    end;
  end;
  CtxList.Free;
  Inherited Destroy;
End;

Constructor TsDBCtx.Create;
Begin
  Inherited Create;
  Name:='';
  Path:='';
  NameTree:=TDataTree.Create;
  ConceptTree:=TDataTree.Create;
End;

Destructor TsDBCtx.Destroy;
Begin
  NameTree.Free;
  ConceptTree.Free;
  Inherited Destroy;
End;

Constructor TDataTree.Create;
Begin
  Inherited Create;
  Path:='';
  Module:=10;
  Depth:=2;
  NextFree:=0;
  CacheSize:=1;
  CacheProtected:=False;
  FreeList:=TStringList.Create;
  Cache:=TStringList.Create;
  DirtyCache:=TStringList.Create;
End;

Destructor TDataTree.Destroy;
Var I,J:Longint;ClassDesc,LongValue:TStringList;
    CacheObject:TCacheObject;
Begin
  //сбросить грязный кэш
  If DirtyCache.Count>0 Then
    For I:=DirtyCache.Count-1 DownTo 0 Do Begin
      CacheObject:=Cache.Objects[Cache.IndexOf(DirtyCache[I])] As TCacheObject;
      FlushCacheObject(CacheObject);
    end;
  //освободить весь кэш
  If Cache.Count>0 Then
    For I:=Cache.Count-1 DownTo 0 Do Begin
      CacheObject:=Cache.Objects[I] As TCacheObject;
      CacheObject.Free;
    End;
  Cache.Free;
  DirtyCache.Free;
  FreeList.Free;
  Inherited Destroy;
End;

Constructor TCacheObject.Create;
Begin
  Inherited Create;
  ObjectID:=0;
  InternalName:='';
  Tree:=Nil;
  Ctx:=Nil;
  LinkKeys:=TStringList.Create;
  LinkTypes:=TStringList.Create;
  LinkAddrTypes:=TStringList.Create;
  LinkAddrs:=TStringList.Create;
end;

Destructor TCacheObject.Destroy;
Var I:Longint;LongValue:TStringList;
Begin
  //Если я в грязном кэше - то флушнуться
  If Tree<>Nil Then
    If Tree.DirtyCache.IndexOf(IntToStr(ObjectID))<>-1 Then FlushCacheObject(Self);
  LinkKeys.Free;
  LinkTypes.Free;
  LinkAddrTypes.Free;
  //освобождение "длинных" значений
  // проверить!
  If LinkAddrs.Count>0 Then
    For I:=LinkAddrs.Count-1 DownTo 0 Do
      If LinkAddrs[I]='_sDBList_' Then Begin
        LongValue:=LinkAddrs.Objects[I] As TStringList;
        LongValue.Free;
      end;
  LinkAddrs.Free;
  Inherited Destroy;
End;

Constructor TsDBCursor.Create;
Begin
  Inherited Create;
  Name:='';
  DBName:='';DB:=Nil;
  CtxName:='';Ctx:=Nil;
  ConceptID:='';//CacheObject:=Nil;
  SearchResults:=TStringList.Create;
End;

Destructor TsDBCursor.Destroy;
Begin
  SearchResults.Free;
  Inherited Destroy;
End;

//=====================  вспомогательные функции  ================================

Function MkSubDir(Path:String;Module,Sub:Longint):String;
Var I:Longint;  D:String;
Begin
  For I:=0 To Module-1 Do Begin
    D:=OSPath(Path+'/'+IntToStr(I));
    MkDir(D);
    If Sub>1 Then MkSubDir(OSPath(Path+'/'+IntToStr(I)),Module,Sub-1);
  end;
  Result:='';
end;

Function ParseAddr(Cursor:TsDBCursor;Addr:String;Var CtxName,NodeID:String):String;
//Возвращает текст ошибки
Var N,I,Error:Longint;
Begin
  Result:='Ok';
  N:=Pos('/',Addr);
  If N=0 Then Begin
    //Нет контекстной части - в вызывающей процедуре будет использоваться контекст из курсора
    CtxName:=Cursor.CtxName;
    NodeID:=Addr;
  End Else Begin
    CtxName:=Copy(Addr,1,N-1);
    NodeID:=Copy(Addr,N+1,Length(Addr)-N);
  End;
  If CtxName='' Then Begin Result:='Error: empty context name in address "'+Addr+'"';Exit;End; //
  If NodeID='' Then Begin Result:='Error: empty node ID in address "'+Addr+'"';Exit;End;
  If Pos('@',NodeID)<>0 Then Begin
    //не адрес, а имя
    //что делать если одному имени соответствуют несколько объектов - непонятно
    NodeID:=sDB_FQFindConceptByName(Cursor.DBName,CtxName,Copy(NodeID,2,Length(NodeID)-1));
    If NodeID='Not found' Then Begin Result:='Error: not found "'+Addr+'"'; End;
  End Else Begin
    Val(NodeID, I, Error);
    If Error=0 Then Result:='Ok'
    Else Result:='Error: address is not integer "'+Addr+'"';
  End;
End;

Function LookupFQ(DBName,CtxName:String;Var DB:TsDB;Var Ctx:TsDBCtx):String;
// рутина по переводу имен БД и контекста в хэндлы
Var CacheObject:TCacheObject;
    M,N,I:Longint;
Begin
  M:=sDBList.IndexOf(DBName);
  If M<0 Then Begin Result:='Error: sDB with name "'+DBName+'" not found';Exit; End;
  DB:=(sDBList.Objects[M]) As TsDB;
  N:=DB.CtxList.IndexOf(CTXName);
  If N<0 Then Begin Result:='Error: Ctx with name "'+CtxName+'" not found';Exit; End;
  Ctx:=(DB.CtxList.Objects[N]) As TsDBCtx;
  Result:='Ok';
End;

Function IDToPath(ID,Module,Depth:Longint):String;
Var I,ID2,digit:Longint;P:String;
    Divs:Array[1..30] Of Longint;
Begin
 // Divs[1]:=1;
  Divs[1]:=Module;
  If Depth>1 Then
    For I:=2 To Depth Do
      Divs[I]:=Divs[I-1]*Module;
  P:='';
  ID2:=ID;
  If ID2 Div Divs[Depth]=0 Then Begin
  End Else Begin
    ID2:=ID2 Mod Divs[Depth];
  End;
  For I:=Depth Downto 1 Do Begin
    Digit:=ID2 Mod Module;
    ID2:=ID2 Div Module;
    P:=IntToStr(Digit)+'/'+P;
  end;
  Result:=P;
End;

Function sDB_CreateCursor(Name:String):String;
Var Cursor:TsDBCursor;
Begin
  If CursorList.IndexOf(Name)>-1 Then Begin
    Result:='Error: cursor with name '+Name+' already exists';
    Exit;
  End;
  Cursor:=TsDBCursor.Create;
  Cursor.Name:=Name;
  CursorList.AddObject(Name,Cursor);
  Result:='Ok';
End;

Function GetCursorByName(Name:String):TsDBCursor;
Var I:Longint;
Begin
  If Name='' Then Name:='system';
  I:=CursorList.IndexOf(Name);
  If I<0 Then Begin Result:=Nil;Exit;End;
  Result:=CursorList.Objects[I] As TsDBCursor;
End;

Function sDB_SetCursor(CursorName,DBName,Addr:String):String;
Var Cursor:TsDBCursor;CtxName,ConceptID,Error:String;
    CacheObject:TCacheObject;
Begin
  Cursor:=GetCursorByName(CursorName);
  If Cursor=Nil Then Begin
    Result:='Error: cursor with name "'+CursorName+'" not found';
    Exit;
  End;
  Cursor.DBName:=DBName;
  ParseAddr(Cursor,Addr,CtxName,ConceptID);
  If CtxName='' Then Begin Result:='Error: empty context name in address "'+Addr+'"';Exit;End;
  Cursor.CtxName:=CTXName;
  Result:=LookupFQ(DBName,CtxName,Cursor.DB,Cursor.Ctx);
  If ConceptID<>'' Then Begin
///    Cursor.CacheObject:=Read2CacheByID(Error,Cursor.Ctx,Cursor.Ctx.ConceptTree,ConceptID);
    CacheObject:=Read2CacheByID(Error,Cursor.Ctx,Cursor.Ctx.ConceptTree,ConceptID);
    Cursor.SearchResults.Clear;
    Cursor.SearchResults.AddObject(CacheObject.Ctx.Name+'/'+IntToStr(CacheObject.ObjectID),CacheObject);
    Cursor.ConceptID:=ConceptID;
    Result:=Error;
  end Else Begin
///    Cursor.CacheObject:=Nil;
    Cursor.SearchResults.Clear;
    Result:='Ok';
  End;
End;

Function sDB_DeleteCursor(Name:String):String;
Var Cursor:TsDBCursor; I:Longint;
Begin
  If (Name='')Or(LowerCase(Name)='system') Then Begin Result:='Error: can''t delete system cursor';Exit;End;
  I:=CursorList.IndexOf(Name);
  If I<0 Then Begin
    Result:='Error: cursor with name '+Name+' not exists';
    Exit;
  End;
  Cursor:=CursorList.Objects[I] As TsDBCursor;
  CursorList.Delete(I);
  Cursor.Free;
  Result:='Ok';
End;

Function sDB_CopyCursor(Name1,Name2:String):String;
Var Cr1,Cr2:TsDBCursor; I:Longint;
Begin
  If Name1='' Then Name1:='system';
  If Name2='' Then Name2:='system';
  If Name1=Name2 Then Begin Result:='Error: can''t copy cursor '+Name1+' to itself';Exit;End;
  I:=CursorList.IndexOf(Name1);
  If I<0 Then Begin Result:='Error: cursor with name '+Name1+' not exists';Exit;End;
  Cr1:=CursorList.Objects[I] As TsDBCursor;
  I:=CursorList.IndexOf(Name2);
  If I<0 Then Begin Result:='Error: cursor with name '+Name2+' not exists';Exit;End;
  Cr2:=CursorList.Objects[I] As TsDBCursor;
  Cr2.DB:=Cr1.DB;
  Cr2.DBName:=Cr1.DBName;
  Cr2.Ctx:=Cr1.Ctx;
  Cr2.CtxName:=Cr1.CtxName;
  Cr2.ConceptID:=Cr1.ConceptID;
  Cr2.SearchResults.Clear;
  If Cr1.SearchResults.Count>0 Then
    For I:=0 To Cr1.SearchResults.Count-1 Do
      Cr2.SearchResults.AddObject(Cr1.SearchResults[I],Cr1.SearchResults.Objects[I]);
end;

Function sDB_AddToCursor(Name1,Name2:String):String;
// добавляет элементы первого курсора во второй
Var Cr1,Cr2:TsDBCursor; I:Longint;
Begin
  If Name1='' Then Name1:='system';
  If Name2='' Then Name2:='system';
  If Name1=Name2 Then Begin Result:='Error: can''t add cursor '+Name1+' to itself';Exit;End;
  I:=CursorList.IndexOf(Name1);
  If I<0 Then Begin Result:='Error: cursor with name '+Name1+' not exists';Exit;End;
  Cr1:=CursorList.Objects[I] As TsDBCursor;
  I:=CursorList.IndexOf(Name2);
  If I<0 Then Begin Result:='Error: cursor with name '+Name2+' not exists';Exit;End;
  Cr2:=CursorList.Objects[I] As TsDBCursor;
  Cr2.DB:=Cr1.DB;  //а вот это вопрос - тут должна быть защита от работы в разных бд! возвращать ошибку
  Cr2.DBName:=Cr1.DBName;
  Cr2.Ctx:=Cr1.Ctx; //и тут вопрос
  Cr2.CtxName:=Cr1.CtxName;
  If Cr1.SearchResults.Count>0 Then
    For I:=0 To Cr1.SearchResults.Count-1 Do
      Cr2.SearchResults.AddObject(Cr1.SearchResults[I],Cr1.SearchResults.Objects[I]);
end;

Function CursorIsEmpty(CursorName:String):Boolean;
Var Cr:TsDBCursor;
Begin
  CR:=GetCursorByName(CursorName);
  If CR=Nil Then Begin LogMessage(1,'Error: cursor "'+CursorName+'" doesn''t exists.');Exit;End;
  Result:=Cr.SearchResults.Count=0;
end;

Function Read2Cache(Var CacheObject:TCacheObject;var Error:String):String;    //а не может ли здесь тоже мгновенно устаревать кэш?
// отвечает за чтение узла дерева с диска в кэш
// требует, чтобы элемент кэша был частично инициализирован
// возвращает текст ошибки либо internal Name
Var Rest,InternalName,LinkKey,LinkType,LinkAddrType,LinkAddr:String;
    Desc,LongValue:TStringList;
    N,I:Longint;ReadSuccess:Boolean;
Begin
  Result:='';
  Desc:=TStringList.Create;
  Error:='';//а надо ли обнулять ошибку?
  Try
    Desc.LoadFromFile(OSPath(CacheObject.Path+'/.description'));
  Except
    Error:=Error+'Error: can''t read object from'+OSPath(CacheObject.Path+'/.description');
    Desc.Free;
    Exit;
  end;
  If Desc.Count=0 Then Begin
    Error:=Error+'Error: empty object description file '+OSPath(CacheObject.Path+'/.description');
    Desc.Free;
    Exit;
  End;
  For I:=0 To Desc.Count-1 Do Begin
    If Pos('InternalName=',Desc[I])=1 Then Begin
      InternalName:=Desc.ValueFromIndex[I];
      Continue;
    End;
    N:=Pos(' ',Desc[I]);
    If N=0 Then Begin Error:=Error+'File format error: '+OSPath(CacheObject.Path+'/.description')+' 1st " " not found in line '+IntToStr(I); End;
    LinkType:='s';//из основной части
    LinkAddrType:=Copy(Desc[I],1,N-1);
    Rest:=Copy(Desc[I],N+1,Length(Desc[I])-N);
    N:=Pos(' ',Rest);
    If N=0 Then Begin Error:=Error+'File format error: '+OSPath(CacheObject.Path+'/.description')+' 2nd " " not found in line '+IntToStr(I); End;
    LinkKey:=Copy(Rest,1,N-1);
    LinkAddr:=Copy(Rest,N+1,Length(Rest)-N);
    CacheObject.LinkTypes.Add(LinkType);
    CacheObject.LinkKeys.Add(LinkKey);
    CacheObject.LinkAddrTypes.Add(LinkAddrType);
    CacheObject.LinkAddrs.Add(LinkAddr);
    If LinkAddr='_sDBList_' Then Begin
      LongValue:=TStringList.Create;
      Try
        LongValue.LoadFromFile(OSPath(CacheObject.Path+'/'+LinkKey));
      Except
        Error:=Error+'Error: can''t read long value from '+OSPath(CacheObject.Path+'/'+LinkKey);
      End;
        CacheObject.LinkAddrs.Objects[I]:=LongValue;
    end;
  end;
  CacheObject.InternalName:=InternalName;
  If Error='' Then Result:=InternalName Else Result:=Error;
  Desc.Free;
end;

Function Read2CacheByID(Var Error:String;Var Ctx:TsDBCtx;Var Tree:TDataTree;ID:String):TCacheObject;
// зачитывает узел в кеш, если его там еще нет путем создания и инициализации объекта, затем вызова чтения из файлов
// возвращает хэндл элемента кэша
Var I,nID:Longint;Err:String;
    CacheObject:TCacheObject;
Begin
  Err:='';
  Val(ID, nID, I);
  If I<>0 Then Begin
    Error:='Error: address is not integer "'+ID+'"';
    Result:=Nil; Exit;
  end;
  If (nID>=Tree.NextFree)Or(Tree.FreeList.IndexOf(ID)>=0) Then Begin Err:='Error: concept with ID "'+ID+'" not found';Error:=Err;Result:=Nil;Exit; End;
  I:=Tree.Cache.IndexOf(ID);
  If I<0 Then Begin //объект не в кеше - зачитать объект в кэш
  //удалить что-нибудь из кеша
    TryDecreaseCache(Tree);
    CacheObject:=TCacheObject.Create;
    Tree.Cache.AddObject(ID,CacheObject);
    CacheObject.ObjectID:=nID;
    CacheObject.Ctx:=Ctx;
    CacheObject.Tree:=Tree;
    CacheObject.Path:=OSPath(Tree.Path+'/'+IDToPath(nID,Tree.Module,Tree.Depth)+ID);
    Read2Cache(CacheObject,Err);
  End Else Begin     //объект уже в кеше
    CacheObject:=Tree.Cache.Objects[I] As TCacheObject;
  End;
  If Err='' Then Begin
    Error:='Ok';
    Result:=CacheObject;
  End Else Begin
    Result:=Nil;
    Error:=Err;
  End;
End;

Function FlushCacheObject(Var CacheObject:TCacheObject):String;
// возвращает Ок или текст ошибки
Var Tree:TDataTree;
    I,N,ID:Longint; ObjectID:String;
    LongValue,Desc:TStringList;
Begin
  Result:='';
  Desc:=TStringList.Create;
  Desc.Clear;
  Desc.Add('InternalName='+CacheObject.InternalName);
  For I:=0 To CacheObject.LinkKeys.Count-1 Do Begin
      //важные связи - в .description
      If CacheObject.LinkTypes[I]='s' Then Desc.Add(CacheObject.LinkAddrTypes[I]+' '+CacheObject.LinkKeys[I]+' '+CacheObject.LinkAddrs[I]);
      If CacheObject.LinkAddrs[I]='_sDBList_' Then Begin
        LongValue:=CacheObject.LinkAddrs.Objects[I] As TStringList;
        Try
          LongValue.SaveToFile(OSPath(CacheObject.Path+'/'+CacheObject.LinkKeys[I]));
        Except
          Result:=Result+'Error: can''t write long value to '+OSPath(CacheObject.Path+'/'+CacheObject.LinkKeys[I])+' ';
          Break;
        end;
      End Else Begin
      //ассоциативные связи - отдельно
      End;
  end;
  Try
    Desc.SaveToFile(OSPath(CacheObject.Path+'/.description'));
  Except
    Result:=Result+'Error: can''t write cached object to '+OSPath(CacheObject.Path+'/.description');
  end;
  Desc.Free;
  If Result='' Then Result:='Ok';
  //удаление из списка Dirty
  Tree:=CacheObject.Tree;
  ObjectID:=IntToStr(CacheObject.ObjectID);
  N:=Tree.DirtyCache.IndexOf(ObjectID);
  If N<0 Then Begin Result:=Result+'Warning: node "'+CacheObject.InternalName+'" with ID '+IntToStr(CacheObject.ObjectID)+' not found in dirty list';End
  Else CacheObject.Tree.DirtyCache.Delete(N);
End;

Procedure TryDecreaseCache(Var Tree:TDataTree);
Var N,I:Longint;SkipThis:Boolean;
    CacheObject:TCacheObject;
    CurrentCursor:TsDBCursor;
Begin //уменьшаем кеш на 1 объект
  If Tree.CacheProtected Then Exit;
  While (Tree.Cache.Count>=Tree.CacheSize) Do Begin
    If Pos('least',Tree.CachePolicy)<>0 Then
      N:=Tree.Cache.Count-1
    Else N:=0;
    Repeat
      CacheObject:=Tree.Cache.Objects[N] As TCacheObject;
      //Проверяем, не стоит ли какой-либо из курсоров на этот объект
      SkipThis:=False;
      For I:=0 To CursorList.Count-1 Do Begin
        CurrentCursor:=CursorList.Objects[I] As TsDBCursor;
///      If CurrentCursor.CacheObject=CacheObject Then Begin SkipThis:=True;Break;end; {непроверенный кусок}
        If CurrentCursor.SearchResults.IndexOfObject(CacheObject)<>-1 Then Begin SkipThis:=True;Break;end; {непроверенный кусок}
      end;
    If SkipThis Then
      If Pos('least',Tree.CachePolicy)<>0 Then Dec(N) Else Inc(N);
    Until Not(SkipThis)Or(N<0)Or(N>=Tree.Cache.Count);
    If SkipThis Then Exit;
    //Если собираемся дропнуть объект из кеша, а он грязный - сперва флушнем его
    If Tree.DirtyCache.IndexOf(IntToStr(CacheObject.ObjectID))>=0 Then
      FlushCacheObject(CacheObject);
    CacheObject.Free;
    Tree.Cache.Delete(N);
  end;
end;

Function CreateNode(Var Ctx:TSDBCtx;Var Tree:TDataTree;InternalName:String;Var Error:String):TCacheObject;
Var CacheObject:TCacheObject;
    M,N,I,ID:Longint;Desc:TStringList;
  Begin
    Error:='';
    CacheObject:=TCacheObject.Create;
    CacheObject.Ctx:=Ctx;
    CacheObject.Tree:=Tree;
    If Tree.FreeList.Count>0 Then Begin //заполняем дыру в адресном пространстве
      ID:=StrToInt(Tree.FreeList[Tree.FreeList.Count-1]);
      Tree.FreeList.Delete(Tree.FreeList.Count-1);
      Tree.FreeList.SaveToFile(OSPath(Tree.Path+'/FreeList'));
    End Else Begin // дыр нет - выделяем следующий номер
      ID:=Tree.NextFree;
      Inc(Tree.NextFree);
      Desc:=TStringList.Create;
      Desc.Add(IntToStr(Tree.NextFree));
      Desc.SaveToFile(OSPath(Tree.Path+'/NextFree'));
      Desc.Free;
    End;
    CacheObject.ObjectID:=ID;
    If InternalName='' Then Begin
      CacheObject.InternalName:=IntToStr(ID);
    End Else Begin
      CacheObject.InternalName:=InternalName;
    End;
    CacheObject.Path:=OSPath(Tree.Path+'/'+IDToPath(ID,Tree.Module,Tree.Depth)+IntToStr(ID));
    Desc:=TStringList.Create;
    Try
      Desc.Add('InternalName='+CacheObject.InternalName);
      ForceDirectories(OSPath(CacheObject.Path));
      Desc.SaveToFile(OSPath(CacheObject.Path+'/.description'));
    Except
      Error:='Error: can''t write object to '+OSPath(CacheObject.Path+'/.description');
      Result:=Nil;
      Desc.Free;
      Exit;
    end;
    Desc.Free;
    //удалить что-нибудь из кеша
    TryDecreaseCache(Tree);
    Tree.Cache.AddObject(IntToStr(ID),CacheObject);
    //и добавить в Dirty
    If Tree.DirtyCache.IndexOf(IntToStr(ID))<0 Then
      Tree.DirtyCache.Add(IntToStr(ID));
    Result:=CacheObject;
    Error:='Ok';
  End;

Function WriteValue(CacheObject:TCacheObject;Key,Value:String;List:TStringList):String;
Var I,N:Longint;Buf:TStringList;
Begin
  N:=CacheObject.LinkKeys.IndexOf(Key);
  If N<0 Then Begin //такого ключа еще не было - добавляем
    CacheObject.LinkTypes.Add('s');
    CacheObject.LinkKeys.Add(Key);
    CacheObject.LinkAddrTypes.Add('#');
    If List=Nil Then CacheObject.LinkAddrs.Add(Value)
    Else
      If List.Count>0 Then Begin
        Buf:=TStringList.Create;
        Buf.Assign(List);
        CacheObject.LinkAddrs.AddObject('_sDBList_',Buf);
      End Else
        CacheObject.LinkAddrs.Add(List[0]);
  End Else Begin //такой ключ уже есть - заменяем значение (потенциальные ошибки из за многократного вхождения ключа и отличного типа связи игнорируются)
    //стираем старое значение с освобождением памяти
    If CacheObject.LinkAddrs[N]='_sDBList_' Then Begin Buf:=CacheObject.LinkAddrs.Objects[N] As TStringList;Buf.Free;End;
    If List=Nil Then Begin
      CacheObject.LinkAddrs[N]:=Value;
    End Else
      If List.Count>0 Then Begin
        Buf:=TStringList.Create;
        Buf.Assign(List);
        CacheObject.LinkAddrs.AddObject('_sDBList_',Buf);
      End Else
        CacheObject.LinkAddrs[N]:=List[0];
  End;
  //Запись на диск
    If Pos('write-back',CacheObject.Tree.CachePolicy)>0 Then Begin
      // запись на диск через DirtyCache
      If CacheObject.Tree.DirtyCache.IndexOf(IntToStr(CacheObject.ObjectID))<0 Then
        CacheObject.Tree.DirtyCache.Add(IntToStr(CacheObject.ObjectID));
      Result:='Ok';
    End Else Begin
        // запись на диск сразу, без кэша
        Result:=FlushCacheObject(CacheObject);
    End;
    //при интеллектуальном кэше тут надо обновить время или счетчик доступа
    If Pos('least',CacheObject.Tree.CachePolicy)<>0 Then Begin
      I:=CacheObject.Tree.Cache.IndexOf(IntToStr(CacheObject.ObjectID));
      CacheObject.Tree.Cache.Move(I,0); //объект, к которому произошел доступ - перемещается в начало
    end;
end;

Function WriteValuePlus(CacheObject:TCacheObject;Key,Value:String):String;
Var I,N:Longint;Buf,List,EvalResult:TStringList;
Begin
  N:=CacheObject.LinkKeys.IndexOf(Key);
  If N<0 Then Begin //такого ключа еще не было - добавляем
    CacheObject.LinkTypes.Add('s');
    CacheObject.LinkKeys.Add(Key);
    CacheObject.LinkAddrTypes.Add('#');
    Buf:=TStringList.Create;
    Buf.Add(Value);
    CacheObject.LinkAddrs.AddObject('_sDBList_',Buf);
  End Else Begin //такой ключ уже есть - дописываем значение (потенциальные ошибки из за многократного вхождения ключа и отличного типа связи игнорируются)
    //стираем старое значение с освобождением памяти
    If CacheObject.LinkAddrs[N]='_sDBList_' Then Begin
      Buf:=CacheObject.LinkAddrs.Objects[N] As TStringList;
      Buf.Add(Value);
    End Else Begin // была строка - будет список
       Buf:=TStringList.Create;
       If CacheObject.LinkAddrTypes[N]='#' Then Buf.Add(CacheObject.LinkAddrs[N])
       Else Begin
         EvalResult:=TStringList.Create;
         List:=TStringList.Create;
         BranchByKey(CacheObject,Key,List,EvalResult);
         Buf.Add(EvalResult[0]);
         List.Free;
         EvalResult.Free;
       End;
       Buf.Add(Value);
       CacheObject.LinkAddrs[N]:='_sDBList_';
       CacheObject.LinkAddrs.AddObject('_sDBList_',Buf);
       CacheObject.LinkAddrs.Delete(N);
       CacheObject.LinkTypes.Add('s');
       CacheObject.LinkTypes.Delete(N);
       CacheObject.LinkKeys.Add(Key);
       CacheObject.LinkKeys.Delete(N);
       CacheObject.LinkAddrTypes.Add('#');
       CacheObject.LinkAddrTypes.Delete(N);
    End;
  End;
  //Запись на диск
    If Pos('write-back',CacheObject.Tree.CachePolicy)>0 Then Begin
      // запись на диск через DirtyCache
      If CacheObject.Tree.DirtyCache.IndexOf(IntToStr(CacheObject.ObjectID))<0 Then
        CacheObject.Tree.DirtyCache.Add(IntToStr(CacheObject.ObjectID));
      Result:='Ok';
    End Else Begin
        // запись на диск сразу, без кэша
        Result:=FlushCacheObject(CacheObject);
    End;
    //при интеллектуальном кэше тут надо обновить время или счетчик доступа
    If Pos('least',CacheObject.Tree.CachePolicy)<>0 Then Begin
      I:=CacheObject.Tree.Cache.IndexOf(IntToStr(CacheObject.ObjectID));
      CacheObject.Tree.Cache.Move(I,0); //объект, к которому произошел доступ - перемещается в начало
    end;
end;


Function CreateSLink(Var CacheObject:TCacheObject;Key,AddrType,Addr:String):String;
// возвращает Ок или текст ошибки
Var I:Longint;
Begin
    //собственно добавление связи
    CacheObject.LinkTypes.Add('s');
    CacheObject.LinkKeys.Add(Key);
    CacheObject.LinkAddrTypes.Add(AddrType);
    CacheObject.LinkAddrs.Add(Addr);
    //Запись на диск
    If Pos('write-back',CacheObject.Tree.CachePolicy)>0 Then Begin
      // запись на диск через DirtyCache
      If CacheObject.Tree.DirtyCache.IndexOf(IntToStr(CacheObject.ObjectID))<0 Then
        CacheObject.Tree.DirtyCache.Add(IntToStr(CacheObject.ObjectID));
      Result:='Ok';
    End Else Begin
        // запись на диск сразу, без кэша
        Result:=FlushCacheObject(CacheObject);
    End;
    //при интеллектуальном кэше тут надо обновить время или счетчик доступа
    If Pos('least',CacheObject.Tree.CachePolicy)<>0 Then Begin
      I:=CacheObject.Tree.Cache.IndexOf(IntToStr(CacheObject.ObjectID));
      CacheObject.Tree.Cache.Move(I,0); //объект, к которому произошел доступ - перемещается в начало
    end;
End;

Function SlideByKey(Source:TCacheObject;Key:String):TCacheObject;
// возвращает хэндл объекта или Nil
Var I,N:Longint;Ctx:TsDBCtx;Tree:TDataTree;
    CacheObject:TCacheObject;
    Error,CtxName,ObjectID,Addr:String;
Begin
  CacheObject:=Nil;
  If Source.LinkAddrs.Count>0 Then
    For I:=0 To Source.LinkAddrs.Count-1 Do
      If Source.LinkKeys[I]=Key Then Begin
        If Source.LinkAddrTypes[I]='.' Then Begin
          If Pos('/',Source.LinkAddrs[I])=0 Then Begin
            // в тот же самый контекст
            Ctx:=Source.Ctx;
            If Key='concept' Then Tree:=Ctx.ConceptTree
            Else Tree:=Source.Tree; //остаемся в том же дереве. надо понять когда возвращаться из именного на смысловое
            ObjectID:=Source.LinkAddrs[I];
          End Else Begin
          // в другой контекст
            Addr:=Source.LinkAddrs[I];
            CtxName:=Copy(Addr,1,Pos('/',Addr)-1);
            ObjectID:=Copy(Addr,Pos('/',Addr)+1,Length(Addr)-Pos('/',Addr));
            N:=Ctx.DB.CtxList.IndexOf(CTXName);
            If N<0 Then Begin LogMessage(1,'Error: Ctx with name "'+CtxName+'" not found');Result:=Nil;Exit; End;
            Ctx:=(Ctx.DB.CtxList.Objects[N]) As TsDBCtx;
            Tree:=Ctx.ConceptTree; //при переходе на другой контекст автоматически переходим на смысловое дерево
          End;
          CacheObject:=Read2CacheByID(Error,Ctx,Tree,ObjectID);
        end;
        Break; //проходим по первой же попавшейся ссылке
      End;
  Result:=CacheObject;
end;

Function BranchBySingleKey(Source:TCacheObject;Key:String;Var List:TStringList;Var EvalResult:TStringList):String;
// ровно то же, что и slide, но не выходит после первого же сработавшего ключа, а строит список подходящих адресов
// возвращает текст ошибки
Var I,N:Longint;Ctx:TsDBCtx;Tree:TDataTree;
    CacheObject:TCacheObject;
    Error,CtxName,ObjectID,Addr:String;
Begin
  CacheObject:=Nil;
  If Source.LinkAddrs.Count>0 Then
    For I:=0 To Source.LinkAddrs.Count-1 Do
      If Source.LinkKeys[I]=Key Then Begin
        If Source.LinkAddrTypes[I]='.' Then Begin
          If Pos('/',Source.LinkAddrs[I])=0 Then Begin
            // в тот же самый контекст
            Ctx:=Source.Ctx;
            If Key='concept' Then Tree:=Ctx.ConceptTree
            Else Tree:=Source.Tree; //остаемся в том же дереве. надо понять когда возвращаться из именного на смысловое
            ObjectID:=Source.LinkAddrs[I];
          End Else Begin
          // в другой контекст
            Addr:=Source.LinkAddrs[I];
            CtxName:=Copy(Addr,1,Pos('/',Addr)-1);
            ObjectID:=Copy(Addr,Pos('/',Addr)+1,Length(Addr)-Pos('/',Addr));
            N:=Source.Ctx.DB.CtxList.IndexOf(CTXName);
            If N<0 Then Begin LogMessage(2,'Warning: Ctx with name "'+CtxName+'" not found'); End;
            Ctx:=(Source.Ctx.DB.CtxList.Objects[N]) As TsDBCtx;
            Tree:=Ctx.ConceptTree; //при переходе на другой контекст автоматически переходим на смысловое дерево
          End;
          CacheObject:=Read2CacheByID(Error,Ctx,Tree,ObjectID); //в принципе можно и не зачитывать в кэш, но при дальнейшем проходе или отображении все равно понадобится
          List.AddObject(CacheObject.Ctx.Name+'/'+IntToStr(CacheObject.ObjectID),CacheObject);
        end;
        If Source.LinkAddrTypes[I]='#' Then Begin
          // А что делать, если ключ совпал, но по нему лежат конкретные данные?
          // slide делать некуда, а вычислить выражение можно
          // В комбинированных Eval и SearchByChain - если полная цепочка еще не пройдена, а по укороченной цепочке уже что-то вычислилось
          // то оно должно быть выброшено. Как определить, что пройдена именно полная цепочка, если мы получаем только текущий ключ?
          // В дальнейшем стоит откусывать по одному ключу от цепочки и перевставлять команду с укороченной цепочкой, пока не останется цепочка из 1 ключа
          // Пока считаем, что из #-значения некуда идти, а остальные ветви должны погаснуть, поэтому List должен быть пустым
          If List.Count=0 Then Begin
            If Source.LinkAddrs[I]='_sDBList_' Then EvalResult.AddStrings(Source.LinkAddrs.Objects[I] As TStringList)
            Else EvalResult.Add(Source.LinkAddrs[I]);
          end;
        end;
      End;
  Result:='Ok';
end;

Function BranchByKey(Source:TCacheObject;Key:String;Var List:TStringList;Var EvalResult:TStringList):String;
// ровно то же, что и slide, но не выходит после первого же сработавшего ключа, а строит список подходящих адресов
// возвращает текст ошибки
Var I:Longint;
    Error:String;
    TempList:TStringList;
Begin
  TempList:=TStringList.Create;
  BranchBySingleKey(Source,Key,TempList,EvalResult);
  If TempList.Count>0 Then Begin
    For I:=0 To TempList.Count-1 Do
      BranchBySingleKey(TempList.Objects[I] As TCacheObject,Key,List,EvalResult);//это не курсор - нет защиты от вытеснения TempList.Objects[I] из кеша
  end Else List.Clear;
  TempList.Free;
End;


{Function FilterByKey(Source:TCacheObject;Key:String;Var List:TStringList):String;
// ровно то же, что и slide, но не выходит после первого же сработавшего ключа, а строит список подходящих адресов
// возвращает текст ошибки
Var I:Longint;
    Error:String;
    TempList:TStringList;
Begin
  TempList:=TStringList.Create;
  BranchBySingleKey(Source,Key,TempList);
  If TempList.Count>0 Then Begin
    For I:=0 To TempList.Count-1 Do
      BranchBySingleKey(TempList.Objects[I] As TCacheObject,Key,List);//это не курсор - нет защиты от вытеснения TempList.Objects[I] из кеша
  end Else List.Clear;
  TempList.Free;
End;
 }
Function sDB_FQWriteName(DBName,CtxName,Name,ConceptID:String):String;
Var CacheObject,Link1,Link2:TCacheObject;
    DB:TsDB;Ctx:TsDBCtx;
    Error,Head,Tail,Word,CurrentSymbol:String;
Begin
  Result:='Ok';
  If Name='' Then Exit;
  Error:=LookupFQ(DBName,CtxName,DB,Ctx);
  If Error<>'Ok' Then Begin LogMessage(1,Error);Result:=Error;Exit;End;
  Ctx.NameTree.CacheProtected:=True;
  CacheObject:=Read2CacheByID(Error,Ctx,Ctx.NameTree,'0'); // встали на корень дерева
  If Error<>'Ok' Then Begin// нету даже корня - создаем
    CacheObject:=CreateNode(Ctx,Ctx.NameTree,'_root_',Error);
  End;
  Tail:=Name;Head:='';
  Repeat
    CurrentSymbol:=Copy(Tail,1,1);Head:=Head+CurrentSymbol;Tail:=Copy(Tail,2,Length(Tail)-1);
    Link1:=SlideByKey(CacheObject,CurrentSymbol);
    If Link1=Nil Then Begin
      // прохода по текущей букве нет - надо записать (как createbinRel) и пройти
      Link1:=CreateNode(Ctx,Ctx.NameTree,'next ('+Head+','+Tail+')',Error);
      Link2:=CreateNode(Ctx,Ctx.NameTree,Head,Error);
      CreateSLink(CacheObject,CurrentSymbol,'.',IntToStr(Link1.ObjectID));
      CreateSLink(Link1,CurrentSymbol,'.',IntToStr(Link2.ObjectID));
      CreateSLink(Link1,'-1('+CurrentSymbol+')','.',IntToStr(CacheObject.ObjectID));
      CreateSLink(Link2,'-1('+CurrentSymbol+')','.',IntToStr(Link1.ObjectID)); // а надо ли обратное?
      CacheObject:=Link2;
    End Else Begin
      // проход  по текущей букве есть - надо пройти
      CacheObject:=SlideByKey(Link1,CurrentSymbol);
    End;
  Until Length(Tail)=0;
  //И записать связь на смысл
  CreateSLink(CacheObject,'concept','.',ConceptID);  //а может ALink?
  Ctx.NameTree.CacheProtected:=False;
  Result:='Ok';
End;

//=====================  работа с БД  ===========================================

Function sDB_CreateDB(DBName,Path:String):String;
Var Desc:TStringList;
Begin
  ForceDirectories(OSPath(Path));
  Desc:=TStringList.Create;
  Desc.Add('DBName='+DBName);
  Desc.SaveToFile(OSPath(Path+'/.description'));
  Desc.Free;
  Result:='Ok';
End;

Function sDB_DeleteDB(Path:String):String;
Var DB:TsDB;
    N:Longint;
Begin
  If sDBList.Count>0 Then
    For N:=sDBList.Count-1 DownTo 0 Do Begin
        DB:=(sDBList.Objects[N]) As TsDB;
        If DB.sDBPath=Path Then Begin
          Result:='Can''t delete opened sDB:'+DB.Name;
          Exit;
        end;
    End;
  If Not DeleteDirectory(Path,False) Then Begin Result:='Error deleting directory '+Path;Exit;End;
  Result:='Ok';
End;

Function sDB_OpenDB(Path:String):String;
Var DB:TsDB;Ctx:TsDBCtx;
    Desc:TStringList;
    sDBName,SPath,Buf:String;
    SearchRec:TSearchRec;SResult,N,Count:Longint;
Begin
  Desc:=TStringList.Create;
  Desc.LoadFromFile(OSPath(Path+'/.description'));
  sDBName:='';
  sDBName:=Desc.Values['DBName'];
  DB:=TsDB.Create;
  DB.sDBPath:=Path;
  DB.Name:=sDBName;
  sDBList.AddObject(DB.Name,DB);
  SPath:=OSPath(Path);
  Buf:=Path+'/*';
  SResult:=FindFirst(OSPath(Buf),faAnyFile,SearchRec);     // найти все контексты и загрузить их описания
  While SResult=0 Do Begin
    If (SearchRec.Attr And faDirectory)<>0 Then Begin
      If (SearchRec.Name<>'.') And (SearchRec.Name<>'..') Then Begin
        Desc.LoadFromFile(OSPath(Path+'/'+SearchRec.Name+'/.description'));
        Ctx:=TsDBCtx.Create;
        Ctx.DB:=DB;
        Ctx.Name:=Desc.Values['CTXName'];
        Ctx.Path:=OSPath(DB.sDBPath+'/'+Ctx.Name);
        Ctx.ConceptTree.Path:=OSPath(Ctx.Path+'/objects');
        Ctx.ConceptTree.Depth:=StrToInt(Desc.Values['Depth']);
        Ctx.ConceptTree.Module:=StrToInt(Desc.Values['Module']);
        Ctx.ConceptTree.CacheSize:=StrToInt(Desc.Values['CacheSize']);
        Ctx.ConceptTree.CachePolicy:=Desc.Values['CachePolicy'];
        Ctx.ConceptTree.FreeList.LoadFromFile(OSPath(Ctx.ConceptTree.Path+'/FreeList'));
        Ctx.NameTree.Path:=OSPath(Ctx.Path+'/nametree');
        Ctx.NameTree.Depth:=StrToInt(Desc.Values['NameDepth']);
        Ctx.NameTree.Module:=StrToInt(Desc.Values['NameModule']);
        Ctx.NameTree.CacheSize:=StrToInt(Desc.Values['NameCacheSize']);
        Ctx.NameTree.CachePolicy:=Desc.Values['NameCachePolicy'];
        Ctx.NameTree.FreeList.LoadFromFile(OSPath(Ctx.NameTree.Path+'/FreeList'));
        Desc.LoadFromFile(OSPath(Ctx.ConceptTree.Path+'/NextFree'));
        Ctx.ConceptTree.NextFree:=StrToInt(Desc[0]);
        Desc.LoadFromFile(OSPath(Ctx.NameTree.Path+'/NextFree'));
        Ctx.NameTree.NextFree:=StrToInt(Desc[0]);
        DB.CtxList.AddObject(Ctx.Name,Ctx);
      End;
    End Else Begin
    End;
    SResult:=FindNext(SearchRec);
  End;
  FindClose(SearchRec);
  Desc.Free;
  Result:=DB.Name;
//  ActiveCursor.DBName:=DB.Name;
//  ActiveCursor.DB:=DB;
End;

Function sDB_CloseDB(DBName:String):String;
Var sDB:TsDB;Desc:TStringList;
    sDBName:String;I,N:Longint;
Begin
  N:=sDBList.IndexOf(DBName);
  If N<>-1 Then Begin
    sDB:=(sDBList.Objects[N]) As TsDB;
    sDB.Free;
    sDBList.Delete(N);
 //   ActiveCursor.DBName:=DBName;
    Result:='Ok';
  end Else Begin
    Result:='sDB with name "'+DBName+'" not found';
  end;
End;

Function sDB_CreateCtx(DBName,CTXName,Module,Depth,CacheSize,CachePolicy,NModule,NDepth,NCacheSize,NCachePolicy:String):String;
Var DB:TsDB;Ctx:TsDBCtx;
    N,I:Longint;Desc:TStringList;
Begin
  { TODO : проверка правильности входных параметров, чтобы не вываливалось }
  N:=sDBList.IndexOf(DBName);
  If N=-1 Then Begin
    Result:='Error: sDB with name "'+DBName+'" not found';
    Exit;
  End;
  DB:=(sDBList.Objects[N]) As TsDB;
  If DB.CtxList.IndexOf(CTXName)>-1 Then Begin
    Result:='Error: CTX with name "'+CTXName+'" already exists';
    Exit;
  end;
  Ctx:=TsDBCtx.Create;
  Ctx.DB:=DB;
  Ctx.Name:=CtxName;
  Ctx.Path:=OSPath(DB.sDBPath+'/'+CtxName);
  MkDir(Ctx.Path);
  Ctx.ConceptTree.NextFree:=0;
  Ctx.ConceptTree.Depth:=StrToInt(Depth);
  Ctx.ConceptTree.Module:=StrToInt(Module);
  Ctx.ConceptTree.CacheSize:=StrToInt(CacheSize);
  Ctx.ConceptTree.CachePolicy:=CachePolicy;
  Ctx.ConceptTree.Path:=OSPath(Ctx.Path+'/objects');
  MkDir(Ctx.ConceptTree.Path);
  MkSubDir(Ctx.ConceptTree.Path,Ctx.ConceptTree.Module,Ctx.ConceptTree.Depth);
  Ctx.NameTree.NextFree:=0;
  Ctx.NameTree.Depth:=StrToInt(NDepth);
  Ctx.NameTree.Module:=StrToInt(NModule);
  Ctx.NameTree.CacheSize:=StrToInt(NCacheSize);
  Ctx.NameTree.CachePolicy:=NCachePolicy;
  Ctx.NameTree.Path:=OSPath(Ctx.Path+'/nametree');
  MkDir(Ctx.NameTree.Path);
  MkSubDir(Ctx.NameTree.Path,Ctx.NameTree.Module,Ctx.NameTree.Depth);
  DB.CtxList.AddObject(CtxName,Ctx);
  Desc:=TStringList.Create;
  Desc.Add('CTXName='+CtxName);
  Desc.Add('Module='+Module);
  Desc.Add('Depth='+Depth);
  Desc.Add('CacheSize='+CacheSize);
  Desc.Add('CachePolicy='+CachePolicy);
  Desc.Add('NameModule='+NModule);
  Desc.Add('NameDepth='+NDepth);
  Desc.Add('NameCacheSize='+NCacheSize);
  Desc.Add('NameCachePolicy='+NCachePolicy);
  Desc.SaveToFile(OSPath(Ctx.Path)+'/.description');
  Desc.Clear;
  Desc.SaveToFile(OSPath(Ctx.ConceptTree.Path+'/FreeList'));
  Desc.SaveToFile(OSPath(Ctx.NameTree.Path+'/FreeList'));
  Desc.Add('0');
  Desc.SaveToFile(OSPath(Ctx.ConceptTree.Path+'/NextFree'));
  Desc.SaveToFile(OSPath(Ctx.NameTree.Path+'/NextFree'));
  Desc.Free;
//  ActiveCursor.CtxName:=CtxName;
//  ActiveCursor.Ctx:=Ctx;
  Result:='Ok';
End;

Function sDB_DeleteCtx(DBName,CtxName:String):String;
Var DB:TsDB;Ctx:TsDBCtx;
    M,N,I,ID:Longint;Desc:TStringList;
    Dir:String;
Begin
  M:=sDBList.IndexOf(DBName);
  If M<0 Then Begin Result:='Error: sDB with name "'+DBName+'" not found';Exit; End;
  DB:=(sDBList.Objects[M]) As TsDB;
  N:=DB.CtxList.IndexOf(CtxName);
  If N<0 Then Begin Result:='Error: Ctx with name "'+CtxName+'" not found';Exit; End;
  Ctx:=(DB.CtxList.Objects[N]) As TsDBCtx;
  DB.CtxList.Delete(N);
  Dir:=OSPath(Ctx.Path);
  //Сброс кеша ?   А зачем, все равно стирать. Надо только память освободить, но это встроено в деструктор
  Ctx.Free;
  If Not DeleteDirectory(Dir,False) Then Begin Result:='Error deleting directory '+Dir;Exit;End;
//  ActiveCursor.CtxName:='';
//  ActiveCursor.Ctx:=Nil;
  Result:='Ok';
End;

Function sDB_FQFlushCacheObject(DBName,CtxName,ObjectID:String):String;
// возвращает текст ошибки
Var CacheObject:TCacheObject;
    DB:TsDB;Ctx:TsDBCtx;AttrName,AttrType,AttrValue,Error:String;
    M,N,I,ID:Longint;ClassDesc,Desc:TStringList;
Begin
  Error:=LookupFQ(DBName,CtxName,DB,Ctx);
  If Error<>'Ok' Then Begin LogMessage(1,Error);Result:=Error;Exit;End;
  ID:=StrToInt(ObjectID);
  If (ID>=Ctx.ConceptTree.NextFree)Or(Ctx.ConceptTree.FreeList.IndexOf(ObjectID)>=0) Then Begin Result:='Error: object with ID "'+ObjectID+'" not found';Exit; End;
  I:=Ctx.ConceptTree.Cache.IndexOf(ObjectID);
  If I<0 Then Begin //объект не в кеше
    Result:='Error: object with ID "'+ObjectID+'" not cached';
  End Else Begin
    CacheObject:=Ctx.ConceptTree.Cache.Objects[I] As TCacheObject;
    Result:=FlushCacheObject(CacheObject);
  end;
End;

{Function sDB_FQCreateConcept(DBName,CtxName,InternalName:String):String;
Var CacheObject:TCacheObject;
    DB:TsDB;Ctx:TsDBCtx;
    Error:String;
Begin
  Error:=LookupFQ(DBName,CtxName,DB,Ctx);
  If Error<>'Ok' Then Begin LogMessage(1,Error);Result:=Error;Exit;End;
  CacheObject:=CreateNode(Ctx,Ctx.ConceptTree,InternalName,Error);
  If Error='Ok' Then Begin
    Result:=IntToStr(CacheObject.ObjectID);
    sDB_FQWriteName(DBName,CtxName,InternalName,Result);
    ActiveCursor.ConceptID:=Result;
  end Else Result:=Error;
End;}

Function sDB_CRCreateConcept(CursorName,InternalName:String):String;
//  возврашает objectid созданного объекта
//  сохраняет хэндл свежесозданного в курсоре
Var CacheObject:TCacheObject;
    Cursor:TsDBCursor;
    DB:TsDB;Ctx:TsDBCtx;
    Error:String;
Begin
  Cursor:=GetCursorByName(CursorName);
  If Cursor=Nil Then Begin Result:='Error: cursor with name "'+CursorName+'" doesn''t exists';Exit;End;
  DB:=Cursor.DB;Ctx:=Cursor.Ctx;
  CacheObject:=CreateNode(Ctx,Ctx.ConceptTree,InternalName,Error);
  If Error='Ok' Then Begin
    Result:=IntToStr(CacheObject.ObjectID);
    sDB_FQWriteName(Cursor.DBName,Cursor.CtxName,InternalName,Result);
//    Cursor.ConceptID:=Result;
    Cursor.SearchResults.Clear;
    Cursor.SearchResults.AddObject(Cursor.CtxName+'/'+Cursor.ConceptID,CacheObject);
  end Else Result:=Error;
End;

Function sDB_CRCreateRelation(CursorName,InternalName:String):String;
// То же, что CRCreateConcept, но не пишет имя в дерево и не меняет курсор
//   возврашает objectid созданного отношения
Var CacheObject:TCacheObject;
    Cursor:TsDBCursor;
    DB:TsDB;Ctx:TsDBCtx;
    Error:String;
Begin
  Cursor:=GetCursorByName(CursorName);
  If Cursor=Nil Then Begin Result:='Error: cursor with name "'+CursorName+'" doesn''t exists';Exit;End;
  DB:=Cursor.DB;Ctx:=Cursor.Ctx;
  CacheObject:=CreateNode(Ctx,Ctx.ConceptTree,InternalName,Error);
  If Error='Ok' Then Begin
    Result:=IntToStr(CacheObject.ObjectID);
//    sDB_FQWriteName(DBName,CtxName,InternalName,Result);
    Cursor.SearchResults.Clear;
    Cursor.SearchResults.AddObject(Cursor.CtxName+'/'+Cursor.ConceptID,CacheObject);
  end Else Result:=Error;
End;

Function sDB_FQDeleteConcept(DBName,CtxName,ConceptID:String):String;
// удаляет объект с диска, из кеша и грязного кэша.
// непонятно, что будет, если объект ещё и в курсорах
Var CacheObject:TCacheObject;
    DB:TsDB;Ctx:TsDBCtx;
    M,N,I,ID:Longint;Desc:TStringList;Dir,Error:String;
Begin
  Error:=LookupFQ(DBName,CtxName,DB,Ctx);
  If Error<>'Ok' Then Begin LogMessage(1,Error);Result:=Error;Exit;End;
  ID:=StrToInt(ConceptID);
  If ID>=Ctx.ConceptTree.NextFree Then Begin Result:='Error: object with ID "'+ConceptID+'" not found';Exit; End;
  I:=Ctx.ConceptTree.Cache.IndexOf(ConceptID);
  Result:='';
  If I>=0 Then Begin //объект в кеше - освободить память
    CacheObject:=Ctx.ConceptTree.Cache.Objects[I] As TCacheObject;
    CacheObject.Free;
  end;
  I:=Ctx.ConceptTree.DirtyCache.IndexOf(ConceptID);
  If I>=0 Then Ctx.ConceptTree.DirtyCache.Delete(I); //объект в грязном кеше - убрать из списка
  //объект не в кеше или только что оттуда удален - просто стереть с диска и внести в список дыр
  Dir:=OSPath(Ctx.ConceptTree.Path+'/'+IDToPath(ID,Ctx.ConceptTree.Module,Ctx.ConceptTree.Depth)+IntToStr(ID));
  If Not DeleteDirectory(Dir,False) Then Begin Result:='Error deleting directory '+Dir;Exit;End;
  If ID=Ctx.ConceptTree.NextFree-1 Then Begin //Удаляемый объект впритык к границе - дыры не образуется
    Dec(Ctx.ConceptTree.NextFree);
    Desc:=TStringList.Create;
    Desc.Add(IntToStr(Ctx.ConceptTree.NextFree));
    Desc.SaveToFile(OSPath(Ctx.ConceptTree.Path+'/NextFree'));
    Desc.Free;
  end Else Begin //Образуется дыра
    Ctx.ConceptTree.FreeList.Add(ConceptID);
    Ctx.ConceptTree.FreeList.SaveToFile(OSPath(Ctx.ConceptTree.Path+'/FreeList'));
  End;
  If Result='' Then Result:='Ok';
//  ActiveCursor.ConceptID:='';
End;

Function sDB_FQGetConceptHandleByID(DBName,CtxName,ConceptID:String):TCacheObject;
Var CacheObject:TCacheObject;
    DB:TsDB;Ctx:TsDBCtx;Error:String;
    I:Longint;
Begin
  Error:=LookupFQ(DBName,CtxName,DB,Ctx);
  If Error<>'Ok' Then Begin LogMessage(1,Error);Result:=Nil;Exit;End;
  CacheObject:=Read2CacheByID(Error,Ctx,Ctx.ConceptTree,ConceptID);
  Result:=CacheObject;
end;

Function sDB_CAWriteValue(CursorName,SourceAddr,Key,Value:String;List:TStringList):String;
// возвращает Ок или текст ошибки
Var CacheObject:TCacheObject;
    Cursor:TsDBCursor;
    DB:TsDB;Ctx:TsDBCtx;Error:String;
    M,N,I:Longint;Desc:TStringList;
    DBName,CTXName,ConceptID:String;
Begin
  Cursor:=GetCursorByName(CursorName);
  If Cursor=Nil Then Begin Result:='Error: cursor with name "'+CursorName+'" doesn''t exists';Exit;End;
  DB:=Cursor.DB;Ctx:=Cursor.Ctx;
  ParseAddr(Cursor,SourceAddr,CtxName,ConceptID);
//  If CtxName='' Then CtxName:=Cursor.CtxName; вроде, больше не нужно, надо проверить
  Error:=LookupFQ(Cursor.DBName,CtxName,DB,Ctx);
  If Error<>'Ok' Then Begin LogMessage(1,Error);Result:=Error;Exit;End;
  CacheObject:=Read2CacheByID(Error,Ctx,Ctx.ConceptTree,ConceptID);
  If Error='Ok' Then
    Result:=WriteValue(CacheObject,Key,Value,List)
  Else Result:=Error;
End;

Function sDB_CAWriteValuePlus(CursorName,SourceAddr,Key,Value:String):String;
// возвращает Ок или текст ошибки
Var CacheObject:TCacheObject;
    Cursor:TsDBCursor;
    DB:TsDB;Ctx:TsDBCtx;Error:String;
    M,N,I:Longint;Desc:TStringList;
    DBName,CTXName,ConceptID:String;
Begin
  Cursor:=GetCursorByName(CursorName);
  If Cursor=Nil Then Begin Result:='Error: cursor with name "'+CursorName+'" doesn''t exists';Exit;End;
  DB:=Cursor.DB;Ctx:=Cursor.Ctx;
  ParseAddr(Cursor,SourceAddr,CtxName,ConceptID);
//  If CtxName='' Then CtxName:=Cursor.CtxName; вроде, больше не нужно, надо проверить
  Error:=LookupFQ(Cursor.DBName,CtxName,DB,Ctx);
  If Error<>'Ok' Then Begin LogMessage(1,Error);Result:=Error;Exit;End;
  CacheObject:=Read2CacheByID(Error,Ctx,Ctx.ConceptTree,ConceptID);
  If Error='Ok' Then
    Result:=WriteValuePlus(CacheObject,Key,Value)
  Else Result:=Error;
End;

Function sDB_CRWriteValuePlus(CursorName,Key,Value:String):String;
// возвращает Ок или текст ошибки
Var CacheObject:TCacheObject;
    Cursor:TsDBCursor;
    DB:TsDB;Ctx:TsDBCtx;Error:String;
    M,N,I:Longint;Desc:TStringList;
    DBName,CTXName,ConceptID:String;
Begin
  Cursor:=GetCursorByName(CursorName);
  If Cursor=Nil Then Begin Result:='Error: cursor with name "'+CursorName+'" doesn''t exists';Exit;End;
  If Cursor.SearchResults.Count=0 then Begin Error:='Ok';Exit;End;
  For I:=0 To Cursor.SearchResults.Count-1 Do Begin
    CacheObject:=Cursor.SearchResults.Objects[I] As TCacheObject;
    Result:=WriteValuePlus(CacheObject,Key,Value)
  End;
End;


Function sDB_CACreateSLink(CursorName,SourceAddr,Key,AddrType,Addr:String):String;
// возвращает Ок или текст ошибки
Var CacheObject:TCacheObject;
    Cursor:TsDBCursor;
    DB:TsDB;Ctx:TsDBCtx;Error:String;
    M,N,I:Longint;Desc:TStringList;
    DBName,CTXName,ConceptID:String;
Begin
  Cursor:=GetCursorByName(CursorName);
  If Cursor=Nil Then Begin Result:='Error: cursor with name "'+CursorName+'" doesn''t exists';Exit;End;
  DB:=Cursor.DB;Ctx:=Cursor.Ctx;
  ParseAddr(Cursor,SourceAddr,CtxName,ConceptID);
//  If CtxName='' Then CtxName:=Cursor.CtxName; вроде, больше не нужно, надо проверить
  Error:=LookupFQ(Cursor.DBName,CtxName,DB,Ctx);
  If Error<>'Ok' Then Begin LogMessage(1,Error);Result:=Error;Exit;End;
  CacheObject:=Read2CacheByID(Error,Ctx,Ctx.ConceptTree,ConceptID);
  If Error='Ok' Then
    Result:=CreateSLink(CacheObject,Key,AddrType,Addr)
  Else Result:=Error;
End;

Function sDB_CACreateALink(CursorName,SourceAddr,Key,AddrType,Addr:String):String;
// возвращает Ок или текст ошибки
// ЗАГЛУШКА !!! пока создает s-линки вместо А-линков
Var CacheObject:TCacheObject;
    Cursor:TsDBCursor;
    DB:TsDB;Ctx:TsDBCtx;Error:String;
    M,N,I:Longint;Desc:TStringList;
    DBName,CTXName,ConceptID:String;
Begin
  Cursor:=GetCursorByName(CursorName);
  If Cursor=Nil Then Begin Result:='Error: cursor with name "'+CursorName+'" doesn''t exists';Exit;End;
  DB:=Cursor.DB;Ctx:=Cursor.Ctx;
  ParseAddr(Cursor,SourceAddr,CtxName,ConceptID);
//  If CtxName='' Then CtxName:=Cursor.CtxName; вроде, больше не нужно, надо проверить
  Error:=LookupFQ(Cursor.DBName,CtxName,DB,Ctx);
  If Error<>'Ok' Then Begin LogMessage(1,Error);Result:=Error;Exit;End;
  CacheObject:=Read2CacheByID(Error,Ctx,Ctx.ConceptTree,ConceptID);
  If Error='Ok' Then
    Result:=CreateSLink(CacheObject,Key,AddrType,Addr)
  Else Result:=Error;
End;


Function sDB_CACreateBinRel(CursorName,Addr1,Addr2,RelIntName,Aspect1,Aspect2:String):String;
//Возвращает текст ошибки
Var CacheObject1,CacheObject2:TCacheObject;
    DB:TsDB;Ctx1,Ctx2:TsDBCtx;RelAddr,Error:String;
    CTXName1,CTXName2,ConceptID1,ConceptID2:String;
    M,N1,N2,I,ID1,ID2:Longint;Desc:TStringList;
    Cursor:TsDBCursor;
Begin
  Result:='';Error:='';
  Cursor:=GetCursorByName(CursorName);
  If Cursor=Nil Then Begin Result:='Error: cursor with name "'+CursorName+'" doesn''t exists';Exit;End;
  DB:=Cursor.DB;Ctx1:=Cursor.Ctx;
  RelAddr:=sDB_CRCreateRelation(CursorName,RelIntName+' '+Addr1+' '+Addr2);
  Result:=Result+sDB_CACreateSLink(CursorName,Addr1,Aspect2,'.',RelAddr); //связь на отношение
  ParseAddr(Cursor,Addr1,CtxName1,ConceptID1);
  ParseAddr(Cursor,Addr2,CtxName2,ConceptID2);
  If Cursor.CTXName=CtxName2 Then Begin
    Result:=Result+sDB_CACreateSLink(CursorName,RelAddr,Aspect2,'.',ConceptID2); //от отношения на второго участника
    Result:=Result+sDB_CACreateSLink(CursorName,RelAddr,Aspect1,'.',ConceptID1); //обратная связь на себя
    Result:=Result+sDB_CACreateALink(CursorName,Addr2,Aspect1,'.',RelAddr); //ассоциативная связь обратно
  End Else Begin
    Result:=Result+sDB_CACreateSLink(CursorName,RelAddr,Aspect2,'.',CTXName2+'/'+ConceptID2); //от отношения на второго участника
    Result:=Result+sDB_CACreateSLink(CursorName,RelAddr,Aspect1,'.',ConceptID1); //обратная связь на себя
    Result:=Result+sDB_CACreateALink(CursorName,Addr2,Aspect1,'.',CTX1.Name+'/'+RelAddr); //ассоциативная связь обратно
  End;
End;

Function sDB_CRCreateBinRel(CursorName1,CursorName2,RelIntName,Aspect1,Aspect2:String):String;
// устанавливает двусторонние связи "каждый с каждым" между элементами курсоров
// Возвращает текст ошибки
Var CacheObject1,CacheObject2:TCacheObject;
    DB:TsDB;Ctx1,Ctx2:TsDBCtx;RelAddr,Error:String;
    CTXName1,CTXName2,ConceptID1,ConceptID2:String;
    M,N1,N2,I,J,ID1,ID2:Longint;Desc:TStringList;
    Cursor1,Cursor2:TsDBCursor;
Begin
  Result:='';Error:='';
  Cursor1:=GetCursorByName(CursorName1);
  If Cursor1=Nil Then Begin Result:='Error: cursor with name "'+CursorName1+'" doesn''t exists';Exit;End;
  Cursor2:=GetCursorByName(CursorName2);
  If Cursor2=Nil Then Begin Result:='Error: cursor with name "'+CursorName2+'" doesn''t exists';Exit;End;
  If Cursor1.SearchResults.Count=0 Then Begin Result:='Ok';Exit;End;
  If Cursor2.SearchResults.Count=0 Then Begin Result:='Ok';Exit;End;
  For I:=0 To Cursor1.SearchResults.Count-1 Do
    For J:=0 To Cursor2.SearchResults.Count-1 Do Begin
      Result:=sDB_CACreateBinRel(CursorName1,Cursor1.SearchResults[I],Cursor2.SearchResults[J],RelIntName,Aspect1,Aspect2);
    End;
End;

{
Function sDB_FQFindConceptByID(DBName,CtxName,ConceptID:String):String;
// возвращает номер объекта в кеше -
// нет защиты от изменения положения в кэше и вытеснения из кеуа до использования результатов!
{ TODO : 1 заменить на Lookup
 2) выкинуть вообще }

Var CacheObject:TCacheObject;
    DB:TsDB;Ctx:TsDBCtx;Error,AttrName,AttrType,AttrValue:String;
    M,N,I,ID:Longint;ClassDesc,Desc:TStringList;
Begin
  M:=sDBList.IndexOf(DBName);
  If M<0 Then Begin Result:='Error: sDB with name "'+DBName+'" not found';Exit; End;
  DB:=(sDBList.Objects[M]) As TsDB;
  N:=DB.CtxList.IndexOf(CTXName);
  If N<0 Then Begin Result:='Error: Ctx with name "'+CtxName+'" not found';Exit; End;
  Ctx:=(DB.CtxList.Objects[N]) As TsDBCtx;
  ID:=StrToInt(ConceptID);
  If (ID>=Ctx.ConceptTree.NextFree)Or(Ctx.ConceptTree.FreeList.IndexOf(ConceptID)>=0) Then Begin Result:='Error: concept with ID "'+ConceptID+'" not found';Exit; End;
  I:=Ctx.ConceptTree.Cache.IndexOf(ConceptID);
  If I<0 Then Begin //объект не в кеше - зачитать объект в кэш
  //удалить что-нибудь из кеша
    TryDecreaseCache(cTX.ConceptTree);
    CacheObject:=TCacheObject.Create;
    Ctx.ConceptTree.Cache.AddObject(ConceptID,CacheObject);
    CacheObject.ObjectID:=ID;
    CacheObject.Path:=OSPath(Ctx.ConceptTree.Path+'/'+IDToPath(ID,Ctx.ConceptTree.Module,Ctx.ConceptTree.Depth)+IntToStr(ID));
    CacheObject.Ctx:=Ctx;
    Read2Cache(CacheObject,error);
    Result:=IntToStr(Ctx.ConceptTree.Cache.IndexOf(ConceptID));
  End Else Begin     //объект уже в кеше
    CacheObject:=Ctx.ConceptTree.Cache.Objects[I] As TCacheObject;
    Result:=IntToStr(I);
  End;
end;}

Function sDB_FQFindConceptByName(DBName,CtxName,Name:String):String;
// возвращает ObjectID первого concept'a
Var CacheObject,Link1,Link2:TCacheObject;
    DB:TsDB;Ctx:TsDBCtx;
    Error,Head,Tail,Word,CurrentSymbol:String;
Begin
  Result:='Error: empty name';
  If Name='' Then Exit;
  Error:=LookupFQ(DBName,CtxName,DB,Ctx);
  If Error<>'Ok' Then Begin LogMessage(1,Error);Result:=Error;Exit;End;
  CacheObject:=Read2CacheByID(Error,Ctx,Ctx.NameTree,'0'); // встали на корень дерева
  If Error<>'Ok' Then Begin // нету даже корня - создаем
    CacheObject:=CreateNode(Ctx,Ctx.NameTree,'_root_',Error);
  End;
  Tail:=Name;Head:='';
  Repeat
    CurrentSymbol:=Copy(Tail,1,1);Head:=Head+CurrentSymbol;Tail:=Copy(Tail,2,Length(Tail)-1);
    Link1:=SlideByKey(CacheObject,CurrentSymbol);
    If Link1=Nil Then Begin
      // прохода по текущей букве нет - не найдено
      Result:='Not found';
      Exit;
    End Else Begin
      // проход по текущей букве есть - надо пройти
      CacheObject:=SlideByKey(Link1,CurrentSymbol);
    End;
  Until Length(Tail)=0;
  CacheObject:=SlideByKey(CacheObject,'concept');
  Result:=IntToStr(CacheObject.ObjectID);
End;

Function sDB_CAFindConcept(CursorName,Addr:String):String;
//возвращает полный адрес ObjectID или текст ошибки
//сохраняет в курсор результат поиска
//пользуется ParseAddr(), который при обращении по имени подразумевает, что все концепты имеют уникальные имена и возвращает только один результат
Var CacheObject:TCacheObject;
    DB:TsDB;Ctx:TsDBCtx;
    CtxName,ConceptID:String;
    Error,Head,Tail,Word,CurrentSymbol:String;
    Cursor:TsDBCursor;
Begin
  Result:='';Error:='';
  Cursor:=GetCursorByName(CursorName);
  If Cursor=Nil Then Begin Result:='Error: cursor with name "'+CursorName+'" doesn''t exists';Exit;End;
  DB:=Cursor.DB;Ctx:=Cursor.Ctx;
  Error:=ParseAddr(Cursor,Addr,CtxName,ConceptID);
  If Error<>'Ok' Then Begin Result:=Error;Cursor.SearchResults.Clear;Exit;End;
  Error:=LookupFQ(Cursor.DBName,CtxName,DB,Ctx);
  If Error<>'Ok' Then Begin LogMessage(1,Error);Result:=Error;Cursor.SearchResults.Clear;Exit;End;
  CacheObject:=Read2CacheByID(Error,Ctx,Ctx.ConceptTree,ConceptID);
  If Pos('Error',Error)<>0 Then Begin LogMessage(1,Error);Result:=Error;Cursor.SearchResults.Clear;Exit;End;
///  Cursor.CacheObject:=CacheObject;
  Cursor.SearchResults.Clear;
  Cursor.SearchResults.AddObject(CacheObject.Ctx.Name+'/'+IntToStr(CacheObject.ObjectID),CacheObject);
  Result:=CacheObject.Ctx.Name+'/'+IntToStr(CacheObject.ObjectID);
End;

Function sDB_CRSearchByName(CursorName,Name:String):String;
// возвращает текст ошибки
// сохраняет в курсор множественные результаты поиска
Var CacheObject,Link1,Link2:TCacheObject;
    Cursor:TsDBCursor;
    DB:TsDB;Ctx:TsDBCtx;I:Longint;
    Error,Head,Tail,Word,CurrentSymbol:String;
    ResultList,EvalList:TStringList;
Begin
  If Name='' Then Begin Result:='Error: empty name';Exit; End;
  Result:='';Error:='';
  Cursor:=GetCursorByName(CursorName);
  If Cursor=Nil Then Begin Result:='Error: cursor with name "'+CursorName+'" doesn''t exists';Exit;End;
  DB:=Cursor.DB;Ctx:=Cursor.Ctx;
  If (CTX=Nil) Or (DB=Nil) Then Begin Result:='Error: cursor "'+CursorName+'" is not set anywhere';Exit;End;
  CacheObject:=Read2CacheByID(Error,Ctx,Ctx.NameTree,'0'); // встали на корень дерева
  If Error<>'Ok' Then Begin // нету даже корня - создаем
    CacheObject:=CreateNode(Ctx,Ctx.NameTree,'_root_',Error);
  End;
  Tail:=Name;Head:='';
  Repeat
    CurrentSymbol:=Copy(Tail,1,1);Head:=Head+CurrentSymbol;Tail:=Copy(Tail,2,Length(Tail)-1);
    Link1:=SlideByKey(CacheObject,CurrentSymbol);
    If Link1=Nil Then Begin
      // прохода по текущей букве нет - не найдено
      Result:='Not found';
      Cursor.SearchResults.Clear;
      Exit;
    End Else Begin
      // проход по текущей букве есть - надо пройти
      CacheObject:=SlideByKey(Link1,CurrentSymbol);
    End;
  Until Length(Tail)=0;
  ResultList:=TStringList.Create;
  EvalList:=TStringList.Create;
  Result:=BranchBySingleKey(CacheObject,'concept',ResultList,EvalList);
  Cursor.SearchResults.Clear;
  If Result<>'Ok' Then Begin ResultList.Free;Exit;End;
  If ResultList.Count>0 Then
    For I:=0 To ResultList.Count-1 Do Begin
      CacheObject:=ResultList.Objects[I] As TCacheObject;
      Cursor.SearchResults.AddObject(ResultList[I],CacheObject);
  End;
  ResultList.Free;
  EvalList.Free;
  Result:='Ok';
End;

Function sDB_CRSearchByChain(CursorName,Chain:String):String;
//для каждого адреса из курсора применяет цепочку ключей,
// возвращает ошибку, список адресов записывает в курсор
Var SourceCacheObject:TCacheObject;
    SourceList,ResultList,KeyList,EvalResult:TStringList;
    DB:TsDB;Ctx:TsDBCtx;Error:String;
    I,J:Longint;Cursor:TsDBCursor;
Begin
  Error:='';
  Cursor:=GetCursorByName(CursorName);
  If Cursor=Nil Then Begin Result:='Error: cursor with name "'+CursorName+'" doesn''t exists';Exit;End;
  DB:=Cursor.DB;Ctx:=Cursor.Ctx;
  If Cursor.SearchResults.Count=0 Then Begin Result:='Ok';Exit;End;
  SourceList:=TStringList.Create;
  ResultList:=TStringList.Create;
  EvalResult:=TStringList.Create;
  KeyList:=TStringList.Create;
  KeyList.Delimiter:='.';
  KeyList.DelimitedText:=Chain;
  For I:=0 To Cursor.SearchResults.Count-1 Do Begin
    SourceCacheObject:=Cursor.SearchResults.Objects[I] As TCacheObject;
    SourceList.AddObject(SourceCacheObject.Ctx.Name+'/'+IntToStr(SourceCacheObject.ObjectID),SourceCacheObject);
  End;
  For J:=0 To KeyList.Count-1 Do Begin
    ResultList.Clear;
    If SourceList.Count>0 Then
      For I:=0 To SourceList.Count-1 Do Begin
        SourceCacheObject:=SourceList.Objects[I] As TCacheObject;
        BranchByKey(SourceCacheObject,KeyList[J],ResultList,EvalResult);
      end;
    SourceList.Clear;
    If ResultList.Count>0 Then
      For I:=0 To ResultList.Count-1 Do Begin
        SourceCacheObject:=ResultList.Objects[I] As TCacheObject;
        SourceList.AddObject(ResultList[I],SourceCacheObject);
      End;
  End;
  Cursor.SearchResults.Clear;
  For I:=0 To ResultList.Count-1 Do Begin
    SourceCacheObject:=ResultList.Objects[I] As TCacheObject;
    Cursor.SearchResults.AddObject(ResultList[I],SourceCacheObject);
  End;
  KeyList.Free;
  ResultList.Free;
  SourceList.Free;
  EvalResult.Free;
  Result:='Ok';
End;

Function sDB_CAEvalByChain(CursorName,Addr,Chain:String;Var Value:TStringList):String;
// возвращает ошибку
// сохраняет значение курсора без изменений
Var SourceCacheObject:TCacheObject;
    SourceList,ResultList,KeyList,EvalResult,BackupList:TStringList;
    DB:TsDB;Ctx:TsDBCtx;Error,DBName,CTXName,ConceptID:String;
    I,J:Longint;Cursor:TsDBCursor;
Begin
  Error:='';
  Cursor:=GetCursorByName(CursorName);
  If Cursor=Nil Then Begin Result:='Error: cursor with name "'+CursorName+'" doesn''t exists';Exit;End;
  DB:=Cursor.DB;Ctx:=Cursor.Ctx;
//  If Cursor.SearchResults.Count=0 Then Begin Result:='Ok';Exit;End;
  Error:=ParseAddr(Cursor,Addr,CtxName,ConceptID);
  If Error<>'Ok' Then Begin Result:=Error;Cursor.SearchResults.Clear;Exit;End;
  Error:=LookupFQ(Cursor.DBName,CtxName,DB,Ctx);
  If Error<>'Ok' Then Begin LogMessage(1,Error);Result:=Error;Cursor.SearchResults.Clear;Exit;End;
  SourceCacheObject:=Read2CacheByID(Error,Ctx,Ctx.ConceptTree,ConceptID);
  SourceList:=TStringList.Create;
  SourceList.AddObject(SourceCacheObject.Ctx.Name+'/'+IntToStr(SourceCacheObject.ObjectID),SourceCacheObject);
  ResultList:=TStringList.Create;
  EvalResult:=TStringList.Create;
  KeyList:=TStringList.Create;
  KeyList.Delimiter:='.';
  KeyList.DelimitedText:=Chain;
  For J:=0 To KeyList.Count-1 Do Begin
    ResultList.Clear;
    If SourceList.Count>0 Then
      For I:=0 To SourceList.Count-1 Do Begin
        SourceCacheObject:=SourceList.Objects[I] As TCacheObject;
        BranchByKey(SourceCacheObject,KeyList[J],ResultList,EvalResult);
      end;
    SourceList.Clear;
    If ResultList.Count>0 Then
      For I:=0 To ResultList.Count-1 Do Begin
        SourceCacheObject:=ResultList.Objects[I] As TCacheObject;
        SourceList.AddObject(ResultList[I],SourceCacheObject);
      End;
  End;
  If EvalResult.Count=0 Then Begin
    If ResultList.Count>0 Then
     Value.Add((ResultList.Objects[0] As TCacheObject).InternalName)
    Else Begin Result:='Error: can''t evaluate '+Addr+'.'+Chain;LogMessage(1,Result);End;
  end Else Value.Assign(EvalResult);
  KeyList.Free;
  ResultList.Free;
  SourceList.Free;
  EvalResult.Free;
End;

Function sDB_CRFilterOutByChain(CursorName,Chain:String):String;
// удаляет из курсора элементы, от которых _можно_ пройти по цепочке ключей,
// возвращает ошибку, список адресов записывает в курсор
Var SourceCacheObject:TCacheObject;
    SourceList,ResultList:TStringList;
    DB:TsDB;Ctx:TsDBCtx;Error:String;
    I,J:Longint;Cursor:TsDBCursor;
Begin
  Error:='';
  Cursor:=GetCursorByName(CursorName);
  If Cursor=Nil Then Begin Result:='Error: cursor with name "'+CursorName+'" doesn''t exists';Exit;End;
  DB:=Cursor.DB;Ctx:=Cursor.Ctx;
  If Cursor.SearchResults.Count=0 Then Begin Result:='Ok';Exit;End;
  ResultList:=TStringList.Create;
  ResultList.Assign(Cursor.SearchResults); //может, считать в другом курсоре?
  For I:=ResultList.Count-1 DownTo 0 Do Begin
    Cursor.SearchResults.Clear;
    Cursor.SearchResults.AddObject(ResultList[I],ResultList.Objects[I]);
    sDB_CRSearchByChain(CursorName,Chain);
    If Cursor.SearchResults.Count>0 Then
      ResultList.Delete(I);
  End;
  If ResultList.Count>0 Then
  Cursor.SearchResults.Assign(ResultList);
  ResultList.Free;
  Result:='Ok';
End;

Function sDB_CRFilterKeepByChain(CursorName,Chain:String):String;
// сщхраняет в курсоре элементы, от которых _можно_ пройти по цепочке ключей,
// возвращает ошибку, список адресов записывает в курсор
Var SourceCacheObject:TCacheObject;
    SourceList,ResultList:TStringList;
    DB:TsDB;Ctx:TsDBCtx;Error:String;
    I,J:Longint;Cursor:TsDBCursor;
Begin
  Error:='';
  Cursor:=GetCursorByName(CursorName);
  If Cursor=Nil Then Begin Result:='Error: cursor with name "'+CursorName+'" doesn''t exists';Exit;End;
  DB:=Cursor.DB;Ctx:=Cursor.Ctx;
  If Cursor.SearchResults.Count=0 Then Begin Result:='Ok';Exit;End;
  ResultList:=TStringList.Create;
  ResultList.Assign(Cursor.SearchResults); //может, считать в другом курсоре?
  For I:=ResultList.Count-1 DownTo 0 Do Begin
    Cursor.SearchResults.Clear;
    Cursor.SearchResults.AddObject(ResultList[I],ResultList.Objects[I]);
    sDB_CRSearchByChain(CursorName,Chain);
    If Cursor.SearchResults.Count=0 Then
      ResultList.Delete(I);
  End;
  If ResultList.Count>0 Then
  Cursor.SearchResults.Assign(ResultList);
  ResultList.Free;
  Result:='Ok';
End;


Function sDB_CASetAttrValue(CursorName,ConceptAddr,AttrName,Value:String):String;
//Возвращает текст ошибки
// Obj->attr->attr-ATTR-value-o-value
Var SourceCacheObject,Link1,Link2:TCacheObject;
    ResultList,KeyList:TStringList;
    DB:TsDB;Ctx:TsDBCtx;
    Error,ValueNode,ConceptID:String;
    I:Longint;
    Cursor:TsDBCursor;
Begin
  Result:='';Error:='';
  Cursor:=GetCursorByName(CursorName);
  If Cursor=Nil Then Begin Result:='Error: cursor with name "'+CursorName+'" doesn''t exists';Exit;End;
  DB:=Cursor.DB;Ctx:=Cursor.Ctx;
  ConceptID:=sDB_CAFindConcept(CursorName,ConceptAddr);
  If Cursor.SearchResults.Count<0 Then Begin Result:='Error: concept with address '+ConceptAddr+' not found';Exit;End;//
  // должен быть проход по всем найденным результатам
  SourceCacheObject:=Cursor.SearchResults.Objects[0] As TCacheObject;
  Link1:=SlideByKey(SourceCacheObject,AttrName);
  If Link1<>Nil Then Begin
    Link2:=SlideByKey(Link1,AttrName);
    Link2.InternalName:=Value;
    FlushCacheObject(Link2);
    Result:='Ok';
  End Else Begin
    ValueNode:=sDB_CRCreateConcept(CursorName,Value);
    Result:=sDB_CACreateBinRel(CursorName,ConceptAddr,ValueNode,AttrName+'<->'+SourceCacheObject.InternalName,'owner_of_value',AttrName);
  End;
End;

Function sDB_CAImportObject(CursorName,Addr,FileName:String):String;
//возвращает текст ощибки
Var Desc:TStringList;
    Error,EffectiveAddr:String;
    Convertor,C1,C2:ANSIString;
    I,N:Longint;
    Cursor:TsDBCursor;
Begin
  Result:='';Error:='';
  EffectiveAddr:=Addr;
  Cursor:=GetCursorByName(CursorName);
  If Cursor=Nil Then Begin Result:='Error: cursor with name "'+CursorName+'" doesn''t exists';Exit;End;
  If EffectiveAddr='' Then Begin
    EffectiveAddr:=sDB_CRCreateConcept(CursorName,ExtractFileName(FileName));
  End Else Begin
    EffectiveAddr:=sDB_CAFindConcept(CursorName,EffectiveAddr);
    If Cursor.SearchResults.Count<0 Then
    //создаем новый объект
      EffectiveAddr:=sDB_CRCreateConcept(CursorName,FileName);
  End;
  // Прочитать значения атрибутов из файла (а что делать с пустыми атрибутами?
  // они действительно пустые?
  // А неуказанные в файле, но существующие в реальности надо ли удалять)
  Desc:=TStringList.Create;
  Try
    Desc.LoadFromFile(OSPath(FileName));
    Result:='Ok';
  Except
    Result:='Error: can''t read from file '+OSPath(FileName);
    Desc.Free;
    Exit;
  end;
  If Desc.Count>0 Then
    For I:=0 To Desc.Count-1 Do Begin
      Convertor:=ANSIString(Desc.Names[I]);
      AnyCommandString.Windows1251ToUTF8(Convertor);
      C1:=Convertor;
      Convertor:=ANSIString(Desc.ValueFromIndex[I]);
      AnyCommandString.Windows1251ToUTF8(Convertor);
      C2:=Convertor;
      Dispatcher.QueueCommand('self::sdb_crsetattrvalue:'+CursorName+':'+EffectiveAddr+':'+C1+':'+C2);
 //     Dispatcher.ExecCommand('self::sdb_crsetattrvalue:'+CursorName+':'+EffectiveAddr+':'+Desc.Names[I]+':'+Desc.ValueFromIndex[I]);
 //   sDB_CRSetAttrValue(CursorName,EffectiveAddr,Desc.Names[I],Desc.ValueFromIndex[I]);
  End;
  Desc.Free;
End;

Function sDB_CAAddToGroup(CursorName,GroupAddr:String):String;
//Возвращает Ок или текст ошибки
Var Error,Addr:String;
    I:Longint;
    Cursor:TsDBCursor;
Begin
  Result:='';Error:='';
  Cursor:=GetCursorByName(CursorName);
  If Cursor=Nil Then Begin Result:='Error: cursor with name "'+CursorName+'" doesn''t exists';Exit;End;
  If Cursor.SearchResults.Count=0 Then Begin Result:='Ok';Exit;End;
  For I:=0 To Cursor.SearchResults.Count-1 Do Begin
    Addr:=Cursor.SearchResults[I];
    Result:=sDB_CACreateBinRel(CursorName,Addr,GroupAddr,'element<->group '+Addr+' '+GroupAddr,'element','group');
  end;
End;

Function sDB_CRAddToGroup(ElementCursor,GroupCursor:String):String;
//Возвращает Ок или текст ошибки
Var Error,EAddr,GAddr:String;
    I,J:Longint;
    ECursor,GCursor:TsDBCursor;
Begin
  Result:='';Error:='';
  ECursor:=GetCursorByName(ElementCursor);
  GCursor:=GetCursorByName(GroupCursor);
  If ECursor=Nil Then Begin Result:='Error: cursor with name "'+ElementCursor+'" doesn''t exists';Exit;End;
  If GCursor=Nil Then Begin Result:='Error: cursor with name "'+GroupCursor+'" doesn''t exists';Exit;End;
  If ECursor.SearchResults.Count=0 Then Begin Result:='Ok';Exit;End;
  If GCursor.SearchResults.Count=0 Then Begin Result:='Ok';Exit;End;
  For I:=0 To ECursor.SearchResults.Count-1 Do Begin
    For J:=0 To GCursor.SearchResults.Count-1 Do Begin
      EAddr:=ECursor.SearchResults[I];
      GAddr:=GCursor.SearchResults[J];
      Result:=sDB_CACreateBinRel(ElementCursor,EAddr,GAddr,'element<->group '+EAddr+' '+GAddr,'element','group');
    end;
  end;
End;

Function sDB_CAEnumAttrs(CursorName,Addr:String;Var AttrList:TStringList):String;
//Строит список атрибутов объекта или таксона, наследуя по иерархии
Var I:Longint;Error:String;
    Cursor,TmpCursor:TsDBCursor;
    EffectiveAddr,TaxonChain:String;
Begin
  Result:='';Error:='';EffectiveAddr:=Addr;
  Cursor:=GetCursorByName(CursorName);
  If Cursor=Nil Then Begin Result:='Error: cursor with name "'+CursorName+'" doesn''t exists';Exit;End;
  If Cursor.SearchResults.Count=0 Then Begin Result:='Ok';Exit;End;
  EffectiveAddr:=sDB_CAFindConcept(CursorName,EffectiveAddr);
  sDB_CreateCursor(Cursor.Name+'tmp');
  sDB_CreateCursor(Cursor.Name+'result');
  sDB_CopyCursor(Cursor.Name,Cursor.Name+'tmp');
  sDB_CRSearchByChain(Cursor.Name+'tmp','attribute');//все локально описанные атрибуты
  sDB_AddToCursor(Cursor.Name+'tmp',Cursor.Name+'result'); //добавить все найденное в результат
  sDB_CopyCursor(Cursor.Name,Cursor.Name+'tmp');
  sDB_CRSearchByChain(Cursor.Name+'tmp','taxon');
  If CursorIsEmpty(Cursor.Name+'tmp') Then Begin
    // по ссылке taxon ничего не найдено - значит это не экземпляр объекта, а класс
    // и надо подниматься по иерархии ссылками parent_taxon
    sDB_CopyCursor(Cursor.Name,Cursor.Name+'tmp');
//    sDB_CRSearchByChain(Cursor.Name+'tmp','taxon.attribute');//все локально описанные атрибуты прямого таксона
//    sDB_AddToCursor(Cursor.Name+'tmp',Cursor.Name+'result'); //добавить все найденное в результат
    TaxonChain:='';
    Repeat      //цикл восхождения по уровням классификации до корневого
      TaxonChain:=TaxonChain+'parent_taxon.';
      sDB_CopyCursor(Cursor.Name,Cursor.Name+'tmp');
      sDB_CRSearchByChain(Cursor.Name+'tmp',TaxonChain+'attribute');
      sDB_AddToCursor(Cursor.Name+'tmp',Cursor.Name+'result'); //добавить все найденное в результат
    Until CursorIsEmpty(Cursor.Name+'tmp'); // родитель родителя ... родителя не найден
  End Else Begin
    // по ссылке taxon что-то найдено - значит это это был экземпляр объекта
    // и по иерархии надо подниматься ссылками taxon.parent_taxon
    sDB_CopyCursor(Cursor.Name,Cursor.Name+'tmp');
    sDB_CRSearchByChain(Cursor.Name+'tmp','taxon.attribute');//все локально описанные атрибуты прямого таксона
    sDB_AddToCursor(Cursor.Name+'tmp',Cursor.Name+'result'); //добавить все найденное в результат
    TaxonChain:='taxon';
    Repeat      //цикл восхождения по уровням классификации до корневого
      TaxonChain:=TaxonChain+'.parent_taxon';
      sDB_CopyCursor(Cursor.Name,Cursor.Name+'tmp');
      sDB_CRSearchByChain(Cursor.Name+'tmp',TaxonChain+'.attribute');
      sDB_AddToCursor(Cursor.Name+'tmp',Cursor.Name+'result'); //добавить все найденное в результат
    Until CursorIsEmpty(Cursor.Name+'tmp'); // родитель родителя ... родителя не найден
  End;
  sDB_DeleteCursor(Cursor.Name+'tmp');
  sDB_CopyCursor(Cursor.Name+'result',Cursor.Name);
  sDB_DeleteCursor(Cursor.Name+'result');
end;

Function sDB_CRActivateMethod(CursorName,Name:String):String;
//Возвращает Ок или текст ошибки
Var Error,Addr,Taxonchain:String;
    I,J,K,M,N:Longint;
    Cursor,TmpCursor:TsDBCursor;
    SourceObject:TCacheObject;
    CommandList:TStringList;
    Value:TStringList;
    Bufer,Bufer2,Alias:String;
    IsAlias:Boolean;
Begin
  Result:='';Error:='';
  Cursor:=GetCursorByName(CursorName);
  If Cursor=Nil Then Begin Result:='Error: cursor with name "'+CursorName+'" doesn''t exists';Exit;End;
  If Cursor.SearchResults.Count=0 Then Begin Result:='Ok';Exit;End;
  For I:=0 To Cursor.SearchResults.Count-1 Do Begin
    Addr:=Cursor.SearchResults[I];
    SourceObject:=Cursor.SearchResults.Objects[I] As TCacheObject;
    CommandList:=TStringList.Create;
    sDB_CAEvalByChain(CursorName,Addr,Name,CommandList);
    If CommandList.Count=0 Then Begin //описания метода прямо в объекте нет - ищем в таксоне
      sDB_CAEvalByChain(CursorName,Addr,'taxon.'+Name,CommandList);
    end;
    If CommandList.Count=0 Then Begin //описания метода в таксоне нет - ищем в родительских таксонах
      TaxonChain:='taxon.';
      sDB_CreateCursor(Cursor.Name+'tmp1');
      Repeat      //цикл восхождения по уровням классификации до корневого
        TaxonChain:=TaxonChain+'parent_taxon.';
        sDB_CopyCursor(Cursor.Name,Cursor.Name+'tmp1');
        sDB_CRSearchByChain(Cursor.Name+'tmp1',TaxonChain);
        sDB_CAEvalByChain(CursorName,Addr,TaxonChain+Name,CommandList);
        TmpCursor:=GetCursorByName(Cursor.Name+'tmp1');
      Until (TmpCursor.SearchResults.Count=0)Or(CommandList.Count>0);
      sDB_DeleteCursor(Cursor.Name+'tmp1');
    end;
    //вычисление выражений внутри команд
    Value:=TStringList.Create;
    If CommandList.Count>0 Then
      For J:=0 To CommandList.Count-1 Do Begin
        Bufer:=CommandList[J];
        Bufer2:='';
        K:=1;
        Alias:='';
        IsAlias:=False;
        Value.Clear;
        While K<=Length(Bufer) Do Begin
          If IsAlias Then Begin
            If Bufer[K]='%' Then Begin //обнаружен закрывающий %
              IsAlias:=False;
              If Alias='' Then Value.Add('%') //было два % подряд
              Else sDB_CAEvalByChain(CursorName,Addr,Alias,Value);
              If Value.Count>0 Then Bufer2:=Bufer2+Value[0];
              Value.Clear;
            End Else Alias:=Alias+Bufer[K];
          End Else Begin
            If Bufer[K]='%' Then Begin //обнаружен открывающий %
              IsAlias:=True;
            end Else
              Bufer2:=Bufer2+Bufer[K];
          end;
          Inc(K);
        End;
        If IsAlias Then Begin LogMessage(1,'Error finding closing % in '+Bufer+' while running method '+Name);Exit;End;
        CommandList[J]:=Bufer2;
      End;
    Value.Free;
    //постановка команд в очередь
    If CommandList.Count>0 Then
      For J:=0 To CommandList.Count-1 Do
        QueueCommand(CommandList[J]);
    CommandList.Free;
  end;
End;

Function sDB_CRActivatePrototypeMethod(CursorName,Name:String):String;
//Возвращает Ок или текст ошибки
Var Error,Addr,Taxonchain:String;
    I,J,K,M,N:Longint;
    Cursor,TmpCursor:TsDBCursor;
    SourceObject:TCacheObject;
    CommandList:TStringList;
    Value:TStringList;
    Bufer,Bufer2,Alias:String;
    IsAlias:Boolean;
Begin
  Result:='';Error:='';
  Cursor:=GetCursorByName(CursorName);
  If Cursor=Nil Then Begin Result:='Error: cursor with name "'+CursorName+'" doesn''t exists';Exit;End;
  If Cursor.SearchResults.Count=0 Then Begin Result:='Ok';Exit;End;
  For I:=0 To Cursor.SearchResults.Count-1 Do Begin
    Addr:=Cursor.SearchResults[I];
    SourceObject:=Cursor.SearchResults.Objects[I] As TCacheObject;
    CommandList:=TStringList.Create;
    sDB_CAEvalByChain(CursorName,Addr,Name,CommandList);
    //вычисление выражений внутри команд
    Value:=TStringList.Create;
    If CommandList.Count>0 Then
      For J:=0 To CommandList.Count-1 Do Begin
        Bufer:=CommandList[J];
        Bufer2:='';
        K:=1;
        Alias:='';
        IsAlias:=False;
        Value.Clear;
        While K<=Length(Bufer) Do Begin
          If IsAlias Then Begin
            If Bufer[K]='%' Then Begin //обнаружен закрывающий %
              IsAlias:=False;
              If Alias='' Then Value.Add('%') //было два % подряд
              Else sDB_CAEvalByChain(CursorName,Addr,Alias,Value);
              If Value.Count>0 Then Bufer2:=Bufer2+Value[0];
              Value.Clear;
            End Else Alias:=Alias+Bufer[K];
          End Else Begin
            If Bufer[K]='%' Then Begin //обнаружен открывающий %
              IsAlias:=True;
            end Else
              Bufer2:=Bufer2+Bufer[K];
          end;
          Inc(K);
        End;
        If IsAlias Then Begin LogMessage(1,'Error finding closing % in '+Bufer+' while running method '+Name);Exit;End;
        CommandList[J]:=Bufer2;
      End;
    Value.Free;
    //постановка команд в очередь
    If CommandList.Count>0 Then
      For J:=0 To CommandList.Count-1 Do
        QueueCommand(CommandList[J]);
    CommandList.Free;
  end;
End;

begin
  sDBList:=TStringList.Create;
  CursorList:=TStringList.Create;
  sDB_CreateCursor('system');
end.

