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.