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.