unit fs02iopSrv_01_main; interface uses fs02iop_00_lib, fs02iopSrv_00_FS_lib, //----------------- //FastScript fs_synmemo, fs_ipascal, fs_iinterpreter, fs_iclassesrtti, //----------------- Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.ExtCtrls, Vcl.StdCtrls, FireDAC.Stan.Intf, FireDAC.Stan.Option, FireDAC.Stan.Error, FireDAC.UI.Intf, FireDAC.Phys.Intf, FireDAC.Stan.Def, FireDAC.Stan.Pool, FireDAC.Stan.Async, FireDAC.Phys, FireDAC.Phys.SQLite, FireDAC.Phys.SQLiteDef, FireDAC.Stan.ExprFuncs, FireDAC.VCLUI.Wait, FireDAC.Stan.Param, FireDAC.DatS, FireDAC.DApt.Intf, FireDAC.DApt, Data.DB, FireDAC.Comp.DataSet, FireDAC.Comp.Client, Vcl.Grids, Vcl.DBGrids, Vcl.DBCtrls, Vcl.Buttons, Vcl.ComCtrls, FireDAC.Phys.SQLiteWrapper.Stat; type TfMain = class(TForm) Panel_Bottom: TPanel; LabelDT: TLabel; LabelPath: TLabel; Panel_Top: TPanel; Label_ActorName: TLabel; FDConn: TFDConnection; qTMP: TFDQuery; qScr: TFDQuery; dsScr: TDataSource; Timer1: TTimer; Panel_Main: TPanel; GroupBox1: TGroupBox; Panel2: TPanel; Label1: TLabel; sb_Refresh: TSpeedButton; sb_Del: TSpeedButton; Label3: TLabel; Label4: TLabel; sb_Add: TSpeedButton; Label48: TLabel; sb_Renum: TSpeedButton; DBNavigator_Scr: TDBNavigator; DBGrid_Scr: TDBGrid; Splitter1: TSplitter; Splitter2: TSplitter; GroupBox2: TGroupBox; DBMemo_Info: TDBMemo; qScrid: TFDAutoIncField; qScrnpp: TIntegerField; qScrmnemocode: TStringField; qScrmnemocode_lower: TStringField; qScrcomment: TStringField; qScrfs_script: TWideMemoField; qScrparams_in: TWideMemoField; qScrparams_out: TWideMemoField; qScrinfo: TWideMemoField; GroupBox3: TGroupBox; pcScr: TPageControl; tsScrText: TTabSheet; tsScrIn: TTabSheet; tsScrOut: TTabSheet; Panel_Scr: TPanel; DBMemoParamIn: TDBMemo; DBMemoParamOut: TDBMemo; fsScript1: TfsScript; fsPascal1: TfsPascal; Panel1: TPanel; sbCompile: TSpeedButton; Label2: TLabel; Label5: TLabel; sbExec: TSpeedButton; qTMPrt: TFDQuery; fsClassesRTTI1: TfsClassesRTTI; fsSyntaxMemo1: TfsSyntaxMemo; procedure FormCreate(Sender: TObject); procedure FDConnAfterConnect(Sender: TObject); procedure FDConnBeforeDisconnect(Sender: TObject); procedure FDConnBeforeConnect(Sender: TObject); procedure qScrBeforePost(DataSet: TDataSet); procedure Timer1Timer(Sender: TObject); procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean); procedure qScrBeforeInsert(DataSet: TDataSet); procedure qScrBeforeDelete(DataSet: TDataSet); procedure sb_RefreshClick(Sender: TObject); procedure sb_AddClick(Sender: TObject); procedure sb_RenumClick(Sender: TObject); procedure sb_DelClick(Sender: TObject); procedure qScrBeforeClose(DataSet: TDataSet); procedure qScrAfterScroll(DataSet: TDataSet); procedure fsSyntaxMemo1Change(Sender: TObject); procedure fsSyntaxMemo1Exit(Sender: TObject); procedure DBMemoParamInExit(Sender: TObject); procedure DBMemoParamOutExit(Sender: TObject); procedure DBMemo_InfoExit(Sender: TObject); procedure pcScrChange(Sender: TObject); procedure sbCompileClick(Sender: TObject); procedure sbExecClick(Sender: TObject); private { Private declarations } fItsFirst:boolean; fYesIns:boolean; fYesDel:boolean; public { Public declarations } function fsiScript_Execute_RT(sMnemo:string; sParamsIn:string; sParamsOut:string ):string; //Сохранить изменения в Б.Д. procedure Make_Post; //функция (метод) формы, где реализована обработка вызова функции/процедуры function fsCallMethod(Instance: TObject; ClassType: TClass; const MethodName: String; var Params: Variant): Variant; end; var fMain: TfMain; implementation {$R *.dfm} procedure TfMain.FormCreate(Sender: TObject); begin MainDir:=ExtractFilePath(ParamStr(0)); fItsFirst:=true; LabelPath.Caption:=MainDir; fsSyntaxMemo1.Parent := Panel_Scr; fsSyntaxMemo1.Align := alClient; pcScr.ActivePage:=tsScrText; Timer1.Enabled:=true; end; procedure TfMain.FormCloseQuery(Sender: TObject; var CanClose: Boolean); begin CanClose:=true; FDConn.Connected:=false; end; procedure TfMain.sbCompileClick(Sender: TObject); Var nLine,nCol : integer; TP : TPoint; List:TStrings; begin Application.ProcessMessages; Make_Post; Screen.Cursor := crHourGlass; List:=TStringList.Create; TRY List.Text:=fsSyntaxMemo1.Lines.Text; TP:=fsSyntaxMemo1.GetPos; if fsiScript_Compile(fsScript1, List, DBMemoParamIn.Lines, DBMemoParamOut.Lines, fsCallMethod ) then begin fsSyntaxMemo1.UpdateView; fsSyntaxMemo1.SetPos(TP.X,TP.Y); ShowMessage('Компиляция - OK'); end else begin fsSyntaxMemo1.UpdateView; nLine:=fs02iopSrv_00_FS_lib.fErr_nLine; nCol:=fs02iopSrv_00_FS_lib.fErr_nCol; fsSyntaxMemo1.SetPos(nCol,nLine); ShowMessage('Error in '+fs02iopSrv_00_FS_lib.fErr_Msg); end; FINALLY FreeAndNil(List); fsSyntaxMemo1.SetFocus; Screen.Cursor := crDefault; END; end; procedure TfMain.sbExecClick(Sender: TObject); Var nLine,nCol : integer; TP : TPoint; ListScr:TStrings; ListOutParam:TStrings; begin Application.ProcessMessages; Make_Post; Screen.Cursor := crHourGlass; ListScr:=TStringList.Create; ListOutParam:=TStringList.Create; TRY ListScr.Text:=fsSyntaxMemo1.Lines.Text; ListOutParam.Text:=DBMemoParamOut.Lines.Text; TP:=fsSyntaxMemo1.GetPos; if fsiScript_Run(fsScript1, ListScr, DBMemoParamIn.Lines, ListOutParam, fsCallMethod ) then begin qScr.Edit; DBMemoParamOut.Lines.Text:=ListOutParam.Text; qScr.Post; fsSyntaxMemo1.UpdateView; fsSyntaxMemo1.SetPos(TP.X,TP.Y); ShowMessage('Выполнение - OK'); end else begin fsSyntaxMemo1.UpdateView; nLine:=fs02iopSrv_00_FS_lib.fErr_nLine; nCol:=fs02iopSrv_00_FS_lib.fErr_nCol; fsSyntaxMemo1.SetPos(nCol,nLine); ShowMessage('Error in '+fs02iopSrv_00_FS_lib.fErr_Msg); end; FINALLY FreeAndNil(ListScr); FreeAndNil(ListOutParam); fsSyntaxMemo1.SetFocus; Screen.Cursor := crDefault; END; end; function TfMain.fsiScript_Execute_RT(sMnemo:string; sParamsIn:string; sParamsOut:string ):string; Var ListParamIn, ListParamOut, ListScr:TStrings; begin Result:='Ошибка!'; sMnemo:=trim(sMnemo); if sMnemo<>'' then begin sMnemo:=PrepareForSQL(AnsiLowerCase(sMnemo)); ListParamOut:=TStringList.Create; ListParamIn:=TStringList.Create; ListScr:=TStringList.Create; TRY ListScr.Text:=DB_Table_Field_AsString( qTMPrt, 'fs_scripts', 'fs_script', 'mnemocode_lower='+#39+sMnemo+#39 ); if ListScr.Count>2 then begin ListParamIn.Text:=sParamsIn; ListParamOut.Text:=sParamsOut; if fsiScript_Run_RT(fsScript1, ListScr, ListParamIn, ListParamOut, fsCallMethod ) then begin Result:=ListParamOut.Text; end; end; FINALLY FreeAndNil(ListScr); FreeAndNil(ListParamOut); FreeAndNil(ListParamIn); END; end; end; procedure TfMain.Timer1Timer(Sender: TObject); begin Timer1.Enabled:=false; LabelDT.Caption:=DateTimeToStr(NOW); if fItsFirst then begin Timer1.Interval:=1000; FDConn.Connected:=true; fItsFirst:=false; end; Timer1.Enabled:=true; end; function TfMain.fsCallMethod(Instance: TObject; ClassType: TClass; const MethodName: String; var Params: Variant): Variant; //функция (метод) формы, где реализована обработка вызова функции/процедуры Var B:boolean; begin Result:=0; //------------------------------- if POS(AnsiUpperCase(';'+MethodName+';'), AnsiUpperCase(';'+'ОкруглитьДо;RoundTo'+';'))>0 then begin Result:=RoundTo(Params[0]*1.0, Params[1]*1); Application.ProcessMessages; end; //------------------------------- //------------------------------- if POS(AnsiUpperCase(';'+MethodName+';'), AnsiUpperCase(';'+'Строка_в_ВеществЧисло;String_to_Float'+';'))>0 then begin Result:=StrToFloatDef(trim(Params[0]), 1.0*Params[1]); Application.ProcessMessages; end; //------------------------------- //------------------------------- if POS(AnsiUpperCase(';'+MethodName+';'), AnsiUpperCase(';'+'Файлы_Список_Получить;Files_List_Get'+';') )>0 then begin B:=Params[2]; Result:=Files_ToStrings( POINTER(Integer(Params[0])), //List:TStrings trim(Params[1]), //FullNameMask B //YesFileNamesOnly ); Application.ProcessMessages; end; //------------------------------- end; procedure TfMain.FDConnBeforeConnect(Sender: TObject); begin FDConn.Params.Values['Database'] := MainDir+'FS_02_io_param.db'; end; procedure TfMain.Make_Post; //Сохранить изменения в Б.Д. begin Query_MakePOST(qScr); end; procedure TfMain.fsSyntaxMemo1Change(Sender: TObject); begin if qScrid.AsInteger>0 then begin if fsSyntaxMemo1.Focused then begin qScr.Edit; end; end; end; procedure TfMain.fsSyntaxMemo1Exit(Sender: TObject); begin Make_Post; end; procedure TfMain.DBMemoParamInExit(Sender: TObject); begin Make_Post; end; procedure TfMain.DBMemoParamOutExit(Sender: TObject); begin Make_Post; end; procedure TfMain.DBMemo_InfoExit(Sender: TObject); begin Make_Post; end; procedure TfMain.FDConnAfterConnect(Sender: TObject); begin sb_Refresh.Click; end; procedure TfMain.pcScrChange(Sender: TObject); begin Make_Post; end; procedure TfMain.FDConnBeforeDisconnect(Sender: TObject); begin Make_Post; end; procedure TfMain.qScrAfterScroll(DataSet: TDataSet); begin fsSyntaxMemo1.Lines.Clear; if qScrid.AsInteger>0 then begin fsSyntaxMemo1.Lines.Text:=qScrfs_script.AsString; end; end; procedure TfMain.qScrBeforeClose(DataSet: TDataSet); begin fsSyntaxMemo1.Lines.Clear; end; procedure TfMain.qScrBeforeDelete(DataSet: TDataSet); begin if not fYesDel then begin raise EMyError.create('Для удаления Скрипта - воспользуйтесь соотв. кнопкой'); end; end; procedure TfMain.qScrBeforeInsert(DataSet: TDataSet); begin if not fYesIns then begin raise EMyError.create('Для создания нового Скрипта - воспользуйтесь соотв. кнопкой'); end; end; procedure TfMain.qScrBeforePost(DataSet: TDataSet); begin qScrmnemocode.AsString:=trim(MnemoCode_Normalize(qScrmnemocode.AsString)); qScrmnemocode_lower.AsString:=AnsiLowerCase(qScrmnemocode.AsString); qScrcomment.AsString:=trim(String_ExcessSpace_Delete(qScrcomment.AsString)); qScrfs_script.AsString:=fsSyntaxMemo1.Lines.Text; end; procedure TfMain.sb_AddClick(Sender: TObject); Var id, npp:integer; sMnemo:string; begin Application.ProcessMessages; Make_Post; if qScr.Active then begin id:=DB_Table_Field_Max_Get(qTMP, 'fs_scripts', 'id'); id:=id+1; sMnemo:='Скрипт_'+IntToStr(id); if InputQuery('Мнемокод скрипта','Введите уникальное имя',sMnemo) then begin sMnemo:=MnemoCode_Normalize(sMnemo); if sMnemo<>'' then begin if DB_Table_Field_AsInteger(qTMP, 'fs_scripts', 'id', 'mnemocode_lower='+#39+AnsiLowerCase(sMnemo)+#39 ) <=0 then begin TRY fYesIns:=true; fsSyntaxMemo1.Lines.Clear; qScrid.ReadOnly:=false; npp:=DB_Table_Field_Max_Get(qTMP, 'fs_scripts', 'npp'); npp:=npp+10; qScr.Append; qScr.Edit; fsSyntaxMemo1.Lines.Clear; fsSyntaxMemo1.Lines.Text:='#language PascalScript'+#10+#10+#10+'BEGIN'+#10+#10+#10+'END.'; qScrid.AsInteger:=id; qScrnpp.AsInteger:=npp; qScrmnemocode.AsString:=sMnemo; qScrmnemocode_lower.AsString:=AnsiLowerCase(sMnemo); qScrcomment.AsString:='???'; qScrparams_out.AsString:='Результат_выполнения= '; qScrfs_script.AsString:='#language PascalScript'+#10+#10+#10+'BEGIN'+#10+#10+#10+'END.'; qScr.Post; FINALLY qScrid.ReadOnly:=true; fYesIns:=false; fsSyntaxMemo1.UpdateView; END; end else begin ShowMessage('Ошибка! Такой мнемокод уже есть'); end; end; end; end; end; procedure TfMain.sb_DelClick(Sender: TObject); begin Application.ProcessMessages; Make_Post; if qScr.Active then begin if qScrid.AsInteger>0 then begin if MessageDlg('Желаете удалить выбранный Скрипт?', mtConfirmation, mbOkCancel,0) = mrOk then begin Screen.Cursor := crHourGlass; TRY fYesDel:=true; fsSyntaxMemo1.Lines.Clear; qScr.Delete; Screen.Cursor := crDefault; ShowMessage('Готово!'); FINALLY fYesDel:=false; sb_Refresh.Click; Screen.Cursor := crDefault; END; end; end; end; end; procedure TfMain.sb_RefreshClick(Sender: TObject); begin Application.ProcessMessages; Make_Post; qScr.Close; qScr.Open; end; procedure TfMain.sb_RenumClick(Sender: TObject); begin Application.ProcessMessages; Make_Post; if qScr.Active then begin sb_Refresh.Click; Screen.Cursor := crDefault; TRY dsScr.DataSet:=nil; Query_Renum(qScr, 10, 'npp', 'id'); FINALLY dsScr.DataSet:=qScr; sb_Refresh.Click; DBGrid_Scr.SetFocus; Screen.Cursor := crHourGlass; END; end; end; end.