unit fs02iopSrv_00_FS_lib;

interface

Uses

  fs02iop_00_lib,

  fs_iinterpreter,

  Dialogs,
  Forms,
  FireDAC.Comp.Client,
  Data.DB,
  Classes,
  SysUTILS;


//========================================
//Добавить дополнительные функции в FastScript
function fsiScript_MyFuncs_Add(fsScr: TfsScript;
                               fsCallMethod: TfsCallMethodEvent
                              ):boolean;
//Добавить функцию/процедуру в FastScript
function MyFunc_AddToFS(fsScr: TfsScript;
                        sWhat: string;
                        sFuncRes: string;
                        sListFuncNames: string;
                        sFuncScript: string;
                        fsCallMethod: TfsCallMethodEvent
                       ):boolean;
//Добавить в FastScript новую константу
function MyConst_AddToFS(fsScr: TfsScript;
                         sListConstNames:string;
                         sConstType:string;
                         sConstVal:string
                        ):boolean;
//Добавить входные или выходные параметры FSI, как константы/переменные в FastScript
function MyParams_AddToFS(fsScr: TfsScript; ItsVar:boolean; ListParams:TStrings):boolean;
//Прочитать значения переменных FastScript в выходные параметры FSI
function MyParams_VarFromFS(fsScr: TfsScript; ListParams:TStrings):boolean;
//Добавить константу или переменную в FastScript
function fs_VarConst_Add(fsScr: TfsScript; sName : string; ItsVar:boolean; sType:string; sVal:string=''): boolean;
//Получить индекс константы/переменной по идентификатору (имени)
function fs_GetIndex(fsScr: TfsScript; sName : string): Integer;
//Инициализация TfsScript
function fsiScript_Init(fsScr: TfsScript;
                        ListInParam:TStrings;
                        ListOutParam:TStrings;
                        fsCallMethod: TfsCallMethodEvent
                        ):boolean;
//Компиляция FS-скрипта
function fsiScript_Compile(fsScr: TfsScript;
                           ListScr:TStrings;
                           ListInParam:TStrings;
                           ListOutParam:TStrings;
                           fsCallMethod: TfsCallMethodEvent
                          ):boolean;
//Выполнение FS-скрипта (в режиме разработки)
function fsiScript_Run(fsScr: TfsScript;
                       ListScr:TStrings;
                       ListInParam:TStrings;
                       ListOutParam:TStrings;
                       fsCallMethod: TfsCallMethodEvent
                      ):boolean;
//Выполнение FS-скрипта в режиме реального времени
//(при обращении внешнего инициатора информационного обмена)
function fsiScript_Run_RT(fsScr: TfsScript;
                          ListScr:TStrings;
                          ListInParam:TStrings;
                          ListOutParam:TStrings;
                          fsCallMethod: TfsCallMethodEvent
                         ):boolean;
//Получить список FS-скриптов
function fsScr_List_Get(Q:TFDQuery;
                        List:TStrings
                       ):integer;
//========================================
//========================================
//Сохранить изменения в Б.Д.
procedure Query_MakePOST(Tbl : TFDQuery);
//Перенумеровать строки таблицы БД с заданным шагом
function Query_Renum(Tbl:TFDQuery; Delta:integer=10; fn_NPP:string='npp'; fn_id_guid:string='id'):boolean;
//Выполнить MAX() по заданному полю заданной таблиы Б.Д.
function DB_Table_Field_Max_Get(Q:TFDQuery;
                            tndb:string;
                            fntn:string;
                            sFilter:string='';
                            sValDef:integer=0
                            ):integer;
//Получить значение заданного поля (как целое число) заданной таблицы Б.Д. по заданному фильтру
function DB_Table_Field_AsInteger(Q:TFDQuery;
                                 tndb:string;
                                 fntn:string;
                                 sFilter:string;
                                 sValDef:integer=0;
                                 sOrderBy:string=''
                                 ):integer;
//Получить значение заданного поля (как строка) заданной таблицы Б.Д. по заданному фильтру
function DB_Table_Field_AsString(Q:TFDQuery;
                                 tndb:string;
                                 fntn:string;
                                 sFilter:string;
                                 sValDef:string='';
                                 sOrderBy:string='';
                                 YesTrim:boolean=true):string;
//========================================
//========================================
//Прочитать список файлов по маске в TStrings
function Files_ToStrings(List: TStrings;
                         FullNameMask:string = '*.*';
                         YesFileNamesOnly:boolean=true
                        ):integer;
//Удалить пустые строки из TStrings
function TStrings_DeleteEmptyLine(List: TStrings) : integer;
//========================================

//-----------------------------
//Используются для отображения информации об ошибке в тексте FS-скрипта
//при его компиляции
Var
  fErr_nLine: integer;
  fErr_nCol: integer;
  fErr_Msg: string;
//-----------------------------

implementation

//*****************************************************
function MyFunc_AddToFS(fsScr: TfsScript;
                        sWhat: string;
                        sFuncRes: string;
                        sListFuncNames: string;
                        sFuncScript: string;
                        fsCallMethod: TfsCallMethodEvent
                       ):boolean;
//Добавить функцию/процедуру в FastScript
Var
 sNameFunc:string;
 i,c:integer;
 Sx:string;
 s222:string;
begin
  Result:=false;
  if Assigned(fsScr) then begin
     if Assigned(fsCallMethod) then begin
        sWhat:=trim(sWhat);
        if length(sWhat)>0 then begin
           sListFuncNames:=trim(sListFuncNames);
           if length(sListFuncNames)>0 then begin
              s222:='';
              sFuncRes:=trim(sFuncRes);
              if AnsiUpperCase(sWhat)='PROCEDURE' then sFuncRes:='';
              if sFuncRes<>'' then begin
                 s222:=':';
                 if sFuncRes[length(sFuncRes)]<>';' then begin
                    sFuncRes:=sFuncRes+';';
                 end;
              end
              else begin
                 sFuncRes:=';';
              end;
              sFuncScript:=trim(sFuncScript);
              s222:='';
              if sFuncScript<>'' then begin
                 if sFuncScript[length(sFuncScript)]=';' then begin
                    sFuncScript[length(sFuncScript)]:=' ';
                 end;
              end;
              sFuncScript:=trim(sFuncScript);
              c:=Get_CountWords_In_String(
                                          sListFuncNames,
                                          #32+#9+';'
                                         );
              if c>0 then begin
                 Result:=true;
                 i:=0;
                 while i<c do
                  begin
                   i:=i+1;
                   sNameFunc:=trim(Get_Word_From_String(
                                                        sListFuncNames,
                                                        i,
                                                        #32+#9+';'
                                                       ));
                   if length(sNameFunc)>0 then begin
                      if length(sFuncScript)>0 then begin
                         Sx:=sWhat+' '+sNameFunc+'('+sFuncScript+')'+s222+sFuncRes;
                      end
                      else begin
                         Sx:=sWhat+' '+sNameFunc+s222+sFuncRes;
                      end;
                      fsScr.AddMethod(Sx, fsCallMethod);
                   end
                   else begin
                      Result:=false;
                      i:=c+1;
                   end;
                 end;
              end;
           end;
        end;
     end;
  end;
end;

function MyConst_AddToFS(fsScr: TfsScript;
                         sListConstNames:string;
                         sConstType:string;
                         sConstVal:string
                        ):boolean;
//Добавить в FastScript новую константу
Var
 sNameConst:string;
 i,c:integer;
begin
  Result:=false;
  if Assigned(fsScr) then begin
     sListConstNames:=trim(sListConstNames);
     sConstType:=trim(sConstType);
     sConstVal:=trim(sConstVal);
     if (sListConstNames<>'') and (sConstType<>'') and (sConstVal<>'') then begin
         c:=Get_CountWords_In_String(sListConstNames, #32+#9+';');
         if c>0 then begin
            Result:=true;
            i:=0;
            while i<c do
             begin
              i:=i+1;
              sNameConst:=trim(Get_Word_From_String(sListConstNames, i, #32+#9+';'));
              if sNameConst<>'' then begin
                 fsScr.AddConst(sNameConst, sConstType, sConstVal);
              end
              else begin
                 Result:=false;
                 i:=c+1;
              end;
            end;
         end;
     end;
  end;
end;

function MyParams_VarFromFS(fsScr: TfsScript; ListParams:TStrings):boolean;
//Прочитать значения переменных FastScript в выходные параметры FSI
Var
  i:integer;
  Sx, sName : string;
  sType:string;
  sVal:string;
begin
  Result:=false;
  if Assigned(fsScr) then begin
     if Assigned(ListParams) then begin
        Result:=true;
        i:=-1;
        while i<(ListParams.Count-1) do
         begin
           i:=i+1;
           sName:=trim(ListParams.Names[i]);
           if sName<>'' then begin
              ListParams.Values[sName]:=trim(fsScr.Variables[sName]);
           end
           else begin
              ListParams[i]:='';
           end;
        end;
        TStrings_DeleteEmptyLine(ListParams);
     end;
  end;
end;

function MyParams_AddToFS(fsScr: TfsScript; ItsVar:boolean; ListParams:TStrings):boolean;
//Добавить входные или выходные параметры FSI, как константы/переменные в FastScript
Var
  i:integer;
  Sx, sName : string;
  sType:string;
  sVal:string;
begin
  Result:=false;
  if Assigned(fsScr) then begin
     if Assigned(ListParams) then begin
        Result:=true;
        TStrings_DeleteEmptyLine(ListParams);
        i:=-1;
        while i<(ListParams.Count-1) do
         begin
           i:=i+1;
           sName:=trim(ListParams.Names[i]);
           if sName<>'' then begin
              sType:='string';
              sVal:=trim(ListParams.Values[sName]);
              if not fs_VarConst_Add(fsScr, sName, ItsVar, sType, sVal) then begin
                 Result:=false;
                 i:=(ListParams.Count+1);
              end;
           end;
        end;
     end;
  end;
end;

function fs_VarConst_Add(fsScr: TfsScript; sName : string; ItsVar:boolean; sType:string; sVal:string=''): boolean;
//Добавить константу или переменную в FastScript
begin
  Result:=false;
  if Assigned(fsScr) then begin
     sName:=trim(sName);
     sType:=trim(sType);
     if (sName<>'') and (sType<>'') then begin
        if sName[1]<>'*' then begin
           if fs_GetIndex(fsScr, sName)<0 then begin
              if ItsVar then begin
                 sVal:='';
                 if AnsiUpperCase(sType)=AnsiUpperCase('String') then begin
                    fsScr.AddVariable(sName, sType,  sVal);
                    Result:=true;
                 end;
                 if AnsiUpperCase(sType)=AnsiUpperCase('Boolean') then begin
                    fsScr.AddVariable(sName, sType,  spStrToBool(trim(sVal),false));
                    Result:=true;
                 end;
                 if AnsiUpperCase(sType)=AnsiUpperCase('Integer') then begin
                    fsScr.AddVariable(sName, sType,  StrToIntDef(trim(sVal),0));
                    Result:=true;
                 end;
                 if AnsiUpperCase(sType)=AnsiUpperCase('Extended') then begin
                    fsScr.AddVariable(sName, sType,  StrToFloatDef(trim(sVal),0.0));
                    Result:=true;
                 end;
              end
              else begin
                 if AnsiUpperCase(sType)=AnsiUpperCase('String') then begin
                    fsScr.AddConst(sName, sType,  sVal);
                    Result:=true;
                 end;
                 if AnsiUpperCase(sType)=AnsiUpperCase('Boolean') then begin
                    fsScr.AddConst(sName, sType,  spStrToBool(trim(sVal),false));
                    Result:=true;
                 end;
                 if AnsiUpperCase(sType)=AnsiUpperCase('Integer') then begin
                    fsScr.AddConst(sName, sType,  StrToIntDef(trim(sVal),0));
                    Result:=true;
                 end;
                 if AnsiUpperCase(sType)=AnsiUpperCase('Extended') then begin
                    fsScr.AddConst(sName, sType,  StrToFloatDef(trim(sVal),0.0));
                    Result:=true;
                 end;
              end;
           end;
        end
        else begin
           Result:=true;
        end;
     end;
  end;
end;

function fs_GetIndex(fsScr: TfsScript; sName : string): Integer;
//Получить индекс константы/переменной по идентификатору (имени)
Var
  Count99, i : integer;
begin
  Result:=-1;
  if Assigned(fsScr) then begin
     sName:=trim(sName);
     if length(sName)>0 then begin
        sName:=AnsiUpperCase(sName);
        Count99:=fsScr.Count*1;
        if Count99>0 then begin
           i:=-1;
           while i<(Count99-1) do
            begin
              i:=i+1;
              if sName = AnsiUpperCase(fsScr.Items[i].Name) then begin
                 Result:=i;
                 i:=(Count99+1);
              end;
           end;
        end;
     end;
  end;
end;

function fsScr_List_Get(Q:TFDQuery;
                        List:TStrings
                       ):integer;
//Получить список FS-скриптов
Var
  Yes:boolean;
begin
  Result:=0;
  if Assigned(List) then begin
     List.Clear;
     if Assigned(Q) then begin
        Q.Close;
        Q.SQL.Clear;
        TRY
          Q.SQL.Add('select mnemocode, comment from fs_scripts order by npp');
          Q.Open;
          Q.First;
          while not Q.EOF do
           begin
            List.Values[Q.FieldByName('mnemocode').AsString]:=Q.FieldByName('comment').AsString;
            Q.Next;
          end;
          Result:=List.Count;
        FINALLY
          Q.Close;
          Q.SQL.Clear;
        END;
     end;
  end;
end;

function fsiScript_MyFuncs_Add(fsScr: TfsScript;
                               fsCallMethod: TfsCallMethodEvent
                              ):boolean;
//Добавить дополнительные функции в FastScript
begin
  Result:=false;
  if Assigned(fsScr) then begin
     if Assigned(fsCallMethod) then begin
        Result:=true;
        MyFunc_AddToFS(fsScr, 'function','extended',
                       'Строка_в_ВеществЧисло;String_to_Float',
                       'Sx:string;'
                      +'vDef:extended=0.0'
                       ,
                       fsCallMethod);
        MyFunc_AddToFS(fsScr,'function', 'extended',
                       'ОкруглитьДо;RoundTo',
                       'V:extended;iRoundTo:integer=2'
                       ,
                        fsCallMethod);
        MyFunc_AddToFS(fsScr,
                       'function', 'integer',
                       'Файлы_Список_Получить;Files_List_Get',
                       'List: TStrings;'
                      +' FullNameMask: string='+#39+'*.*'+#39+';'
                      +' YesFileNamesOnly: boolean=true'
                       ,
                       fsCallMethod);
     end;
  end;
end;

function fsiScript_Init(fsScr: TfsScript;
                        ListInParam:TStrings;
                        ListOutParam:TStrings;
                        fsCallMethod: TfsCallMethodEvent
                        ):boolean;
//Инициализация TfsScript
begin
  Result:=false;
  fErr_nLine:=0;
  fErr_nCol:=0;
  fErr_Msg:='';
  if Assigned(fsScr) then begin
     fsScr.Clear;
     fsScr.Lines.Clear;
     fsScr.Parent := fsGlobalUnit;
     fsScr.SyntaxType := 'PascalScript';
     Result:=fsiScript_MyFuncs_Add(fsScr, fsCallMethod);
     if Result then begin
        Result:=MyParams_AddToFS(fsScr, true, ListOutParam);
        if Result then begin
           Result:=MyParams_AddToFS(fsScr, false, ListInParam);
        end;
     end;
  end;
end;

function fsiScript_Compile(fsScr: TfsScript;
                           ListScr:TStrings;
                           ListInParam:TStrings;
                           ListOutParam:TStrings;
                           fsCallMethod: TfsCallMethodEvent
                          ):boolean;
//Компиляция FS-скрипта
Var
  S : string;
begin
  Result:=false;
  if fsiScript_Init(fsScr, ListInParam, ListOutParam, fsCallMethod) then begin
     if Assigned(ListScr) then begin
        if ListScr.Count>0 then begin
           fsScr.Lines.Assign(ListScr);
           if fsScr.Compile then begin
              Result:=true;
           end
           else begin
             fErr_Msg:=fsScr.ErrorPos+' -> '+fsScr.ErrorMsg;
             S:=trim(Get_Word_From_String(fsScr.ErrorPos,1, ':',true));
             fErr_nLine:=StrToIntDef(S,0);
             S:=trim(Get_Word_From_String(fsScr.ErrorPos,2, ':',true));
             fErr_nCol:=StrToIntDef(S,0);
           end;
        end;
     end;
  end;
end;

function fsiScript_Run(fsScr: TfsScript;
                       ListScr:TStrings;
                       ListInParam:TStrings;
                       ListOutParam:TStrings;
                       fsCallMethod: TfsCallMethodEvent
                      ):boolean;
//Выполнение FS-скрипта (в режиме разработки)
begin
  Result := fsiScript_Compile(fsScr,
                              ListScr,
                              ListInParam,
                              ListOutParam,
                              fsCallMethod
                             );
  if Result then begin
     fsScr.Execute;
     MyParams_VarFromFS(fsScr, ListOutParam);
  end;
end;

function fsiScript_Run_RT(fsScr: TfsScript;
                          ListScr:TStrings;
                          ListInParam:TStrings;
                          ListOutParam:TStrings;
                          fsCallMethod: TfsCallMethodEvent
                         ):boolean;
//Выполнение FS-скрипта в режиме реального времени
//(при обращении внешнего инициатора информационного обмена)
Var
  ItsOk:boolean;
begin
  Result := false;
  ItsOk:=false;
  TRY
    Result := fsiScript_Compile(fsScr,
                                ListScr,
                                ListInParam,
                                ListOutParam,
                                fsCallMethod
                               );

    if Result then begin
       Result := false;
       fsScr.Execute;
       MyParams_VarFromFS(fsScr, ListOutParam);
       ItsOk:=true;
       Result := true;
    end;
  EXCEPT
    if not ItsOk then begin
       //FS вывалился в Exception...
       ListOutParam.Values['КритическаяОшибка']:='Критическая ошибка! Скрипт НЕ выполнен';
    end;
  END;
end;
//*****************************************************


//*****************************************************
procedure Query_MakePOST(Tbl : TFDQuery);
//Сохранить изменения в Б.Д.
begin
  if Assigned(Tbl) then begin
     if Tbl.Active then begin
        TRY
          if (Tbl.State<>dsBrowse) then begin
             Tbl.POST;
          end;
        FINALLY

        END;
     end;
  end;
end;

function Query_Renum(Tbl:TFDQuery; Delta:integer=10; fn_NPP:string='npp'; fn_id_guid:string='id'):boolean;
//Перенумеровать строки таблицы БД с заданным шагом
Var
  N,Id:integer;
  fnSortNow:string;
  List:TStrings;
begin
  Result:=false;
  if Assigned(Tbl) then begin
     if Tbl.Active then begin
        fn_NPP:=trim(fn_NPP);
        if length(fn_NPP)>0 then begin
           fn_id_guid:=trim(fn_id_guid);
           if length(fn_id_guid)>0 then begin
              if Delta<=0 then Delta:=1;
              if Delta>1000 then Delta:=1000;
              fnSortNow:=Tbl.IndexFieldNames;
              List:=TStringList.Create;
              TRY
                N:=0;
                Tbl.First;
                while not Tbl.EOF do
                 begin
                  N:=N+Delta;
                  List.Values[Tbl.FieldByName(fn_id_guid).AsString]:=IntToStr(N);
                  Tbl.Next;
                end;
                Tbl.IndexFieldNames:=trim(fn_id_guid);
                Tbl.Close;
                Tbl.Open;
                Tbl.First;
                while not Tbl.EOF do
                 begin
                  N:=StrToIntDef(List.Values[Tbl.FieldByName(fn_id_guid).AsString],0);
                  if N>0 then begin
                     Tbl.Edit;
                     Tbl.FieldByName(fn_NPP).AsInteger:=N;
                     Tbl.Post;
                  end;
                  Tbl.Next;
                end;
                Result:=true;
              FINALLY
                Tbl.IndexFieldNames:=fnSortNow;
                Tbl.Close;
                Tbl.Open;
                FreeAndNil(List);
              END;
           end;
        end;
     end;
  end;
end;

function DB_Table_Field_AsInteger(Q:TFDQuery;
                                 tndb:string;
                                 fntn:string;
                                 sFilter:string;
                                 sValDef:integer=0;
                                 sOrderBy:string=''
                                 ):integer;
//Получить значение заданного поля (как целое число) заданной таблицы Б.Д. по заданному фильтру
Var
  Sx:string;
begin
  Result:=sValDef;
  Sx:=trim(DB_Table_Field_AsString(Q,tndb,fntn,sFilter,IntToStr(sValDef),sOrderBy,true));
  Result:=StrToIntDef(Sx, sValDef);
end;


function DB_Table_Field_Max_Get(Q:TFDQuery;
                            tndb:string;
                            fntn:string;
                            sFilter:string='';
                            sValDef:integer=0
                            ):integer;
//Выполнить MAX() по заданному полю заданной таблиы Б.Д.
begin
  Result:=sValDef;
  fntn:=trim(fntn);
  if length(fntn)>0 then begin
     fntn:='max('+fntn+')';
     Result:=DB_Table_Field_AsInteger(Q, tndb, fntn, sFilter, sValDef, '');
  end;
end;

function DB_Table_Field_AsString(Q:TFDQuery;
                                 tndb:string;
                                 fntn:string;
                                 sFilter:string;
                                 sValDef:string='';
                                 sOrderBy:string='';
                                 YesTrim:boolean=true):string;
//Получить значение заданного поля (как строка) заданной таблицы Б.Д. по заданному фильтру
Var
  Yes:boolean;
begin
  Result:=sValDef;
  tndb:=trim(tndb);
  fntn:=trim(fntn);
  if (length(tndb)>0) and (length(fntn)>0) then begin
      if Assigned(Q) then begin
         sFilter:=trim(sFilter);
         sOrderBy:=trim(sOrderBy);
         Yes:=false;
         Q.Close;
         Q.SQL.Clear;
         TRY
           Q.SQL.Add('select');
           Q.SQL.Add(fntn);
           Q.SQL.Add('from');
           Q.SQL.Add(tndb);
           if length(sFilter)>0 then begin
              Q.SQL.Add('where');
              Q.SQL.Add(sFilter);
           end;
           if length(sOrderBy)>0 then begin
              Q.SQL.Add('order by');
              Q.SQL.Add(sOrderBy);
           end;
           //Q.SQL.Add('limit 1');
           Q.Open;
           if Q.RecordCount>0 then begin
              if not Q.Fields[0].IsNull then begin
                 Result:=Q.Fields[0].AsString;
              end;
           end;
           Yes:=true;
         FINALLY
           Q.Close;
           if not Yes then begin
              ShowMessage(Q.SQL.Text);
           end;
           Q.SQL.Clear;
         END;
      end;
  end;
  if YesTrim then Result:=trim(Result);
end;
//*****************************************************

//*****************************************************
function Files_ToStrings(List: TStrings;
                         FullNameMask:string = '*.*';
                         YesFileNamesOnly:boolean=true
                        ):integer;
//Прочитать список файлов по маске в TStrings
Var
 sDir,sMask,NameF: string;
 DirInfo: TSearchRec;
 Err: integer;
begin
  Result := 0;
  if Assigned(List) then begin
     List.Clear;
     FullNameMask := trim(FullNameMask);
     if FullNameMask<>'' then begin
        sDir:=trim(ExtractFilePath(FullNameMask));
        if DirectoryExists(sDir) then begin
           sMask := trim(ExtractFileName(FullNameMask));
           if sMask='' then sMask := '*.*';
           Err := 0;
           Err := FindFirst(sDir + sMask, { faArchive } faAnyFile, DirInfo);
           while Err = 0 do
            begin
              NameF := DirInfo.Name;
              if FileExists(sDir + NameF) then begin
                 if YesFileNamesOnly then begin
                    List.Add(NameF);
                 end
                 else begin
                    List.Add(sDir+NameF);
                 end;
              end;
              Err := FindNext(DirInfo);
              Application.ProcessMessages;
           end;
           FindClose(DirInfo);
           Result := List.Count;
        end;
     end;
  end;
end;
function TStrings_DeleteEmptyLine(List: TStrings) : integer;
//Удалить пустые строки из TStrings
Var
  i : integer;
  ListBuf:TStrings;
begin
  Result:=0;
  if List<>NIL then begin
     if List.Count>0 then begin
        ListBuf:=TStringList.Create;
        TRY
          i:=-1;
          while i<(List.Count-1) do
           begin
            i:=i+1;
            if Length(Trim(List[i]))>0 then begin
               ListBuf.Add(List[i]);
            end;
          end;
          List.Text:=ListBuf.Text;
          Result:=List.Count;
        FINALLY
          FreeAndNil(ListBuf);
        END;
     end;
  end;
end;
//*****************************************************

end.