unit fs04_up_01_main; interface uses fs04_up_00_lib, Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.ExtCtrls, Vcl.StdCtrls, Vcl.ComCtrls, Vcl.Buttons, fs_synmemo, 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.Menus, Vcl.Grids, Vcl.DBGrids, FireDAC.Phys.SQLiteWrapper.Stat; type TfMain = class(TForm) Panel1: TPanel; Labelr55: TLabel; pcMain: TPageControl; tsFiles: TTabSheet; GroupBox1: TGroupBox; Panel2: TPanel; Splitter1: TSplitter; Memo_EV: TMemo; GroupBox2: TGroupBox; fsSyntaxMemo1: TfsSyntaxMemo; Splitter2: TSplitter; Panel3: TPanel; SpeedButton1: TSpeedButton; Panel4: TPanel; GroupBox3: TGroupBox; fsSyntaxMemo2: TfsSyntaxMemo; tsDB: TTabSheet; FDConn: TFDConnection; qTMP: TFDQuery; qScr: TFDQuery; qScrnpp: TIntegerField; qScrmnemocode: TStringField; qScrid: TFDAutoIncField; qScrfs_script: TWideMemoField; dsScr: TDataSource; qScrits_lib: TBooleanField; qScrmnemocode_lc: TStringField; GroupBox4: TGroupBox; DBGrid_Scr: TDBGrid; Splitter3: TSplitter; Panel5: TPanel; Splitter4: TSplitter; GroupBox5: TGroupBox; fsSyntaxMemo3: TfsSyntaxMemo; Panel6: TPanel; sbFS_Parsing_from_DB: TSpeedButton; Panel7: TPanel; GroupBox6: TGroupBox; fsSyntaxMemo4: TfsSyntaxMemo; Panel8: TPanel; procedure FormShow(Sender: TObject); procedure FormCreate(Sender: TObject); procedure SpeedButton1Click(Sender: TObject); procedure FDConnBeforeConnect(Sender: TObject); procedure pcMainChange(Sender: TObject); procedure qScrAfterOpen(DataSet: TDataSet); procedure qScrBeforeClose(DataSet: TDataSet); procedure qScrAfterScroll(DataSet: TDataSet); procedure sbFS_Parsing_from_DBClick(Sender: TObject); private { Private declarations } public { Public declarations } end; var fMain: TfMain; //Выгрузка скриптов из БД. Парсинг скрипта function fsiBase_Main_Script_Mnemo_Prepare(Q:TFDQuery; scrText:TStrings; List_EnvVars:TStrings ):boolean; //Переменные окружения. Парсинг скрипта function fsiBase_Main_Script_EnvVars_Prepare( scrText:TStrings; List_EnvVars:TStrings ):boolean; overload; //Переменные окружения. Парсинг скрипта function fsiBase_Main_Script_EnvVars_Prepare( sScript:string; List_EnvVars:TStrings ):string;overload; //Выделить мнемокод из строки function Mnemo_Extract(Sx:string):string; //замена подстроки в строке function Replace_In_String(const S, Srch, Replace: string; CaseIgnore:boolean=true): string; //Удалить окончание строки, начиная с заданой позиции function Delete_end_String(Sx : string; Index:integer) : string; //Удалить начало строки, начиная с 1-й позиции и до заданной (включая заданную) function Delete_start_String(Sx : string; Index:integer) : string; //Получить значение заданного поля (как строка) заданной таблицы Б.Д. по заданному фильтру function DB_Table_Field_AsString(Q:TFDQuery; tndb:string; fntn:string; sFilter:string; sValDef:string=''; sOrderBy:string=''; YesTrim:boolean=true):string; //Загрузить FS-скрипт по МнемоКоду function FS_LoadFromDB(Q:TFDQuery; ScrMnemo:string; ItsLibOnly:boolean=true ):string; //Создать папку (каталог) function Dir_Create(DirName: String): boolean; //Удалить файлы по маске function Files_Delete(NameMask: String): integer; //Получить полное имя папки для библиотечных файлов function DirName_from_List_EnvVars(List_EnvVars:TStrings):string; implementation {$R *.dfm} procedure TfMain.FormCreate(Sender: TObject); begin MainDir:=ExtractFilePath(ParamStr(0)); //Папка программы Memo_EV.Lines.Values['App_Dir']:=MainDir; //Создать папку для сохранения библиотечных файлов из БД Dir_Create(DirName_from_List_EnvVars(Memo_EV.Lines)); end; procedure TfMain.FormShow(Sender: TObject); begin pcMain.ActivePage:=tsFiles; if DirectoryExists(DirName_from_List_EnvVars(Memo_EV.Lines)) then begin //Удалить все PAS-файлы из папки (если требуется) //Files_Delete(DirName_from_List_EnvVars(Memo_EV.Lines)+'*.pas'); end; end; procedure TfMain.FDConnBeforeConnect(Sender: TObject); begin FDConn.Params.Values['Database'] := MainDir+'FS_04_uses_parsing.db'; end; procedure TfMain.pcMainChange(Sender: TObject); begin Application.ProcessMessages; qScr.Close; fsSyntaxMemo3.Lines.Clear; fsSyntaxMemo4.Lines.Clear; if pcMain.ActivePage=tsDB then begin qScr.Open; end; end; procedure TfMain.qScrAfterOpen(DataSet: TDataSet); begin fsSyntaxMemo3.Lines.Clear; fsSyntaxMemo4.Lines.Clear; if qScrid.AsInteger>0 then begin fsSyntaxMemo3.Lines.Text:=qScrfs_script.AsString; end; end; procedure TfMain.qScrAfterScroll(DataSet: TDataSet); begin fsSyntaxMemo3.Lines.Clear; fsSyntaxMemo4.Lines.Clear; if qScrid.AsInteger>0 then begin fsSyntaxMemo3.Lines.Text:=qScrfs_script.AsString; end; end; procedure TfMain.qScrBeforeClose(DataSet: TDataSet); begin fsSyntaxMemo3.Lines.Clear; fsSyntaxMemo4.Lines.Clear; end; procedure TfMain.SpeedButton1Click(Sender: TObject); begin Application.ProcessMessages; fsSyntaxMemo2.Lines.Text:=fsSyntaxMemo1.Lines.Text; fsiBase_Main_Script_EnvVars_Prepare( fsSyntaxMemo2.Lines, Memo_EV.Lines ); end; procedure TfMain.sbFS_Parsing_from_DBClick(Sender: TObject); begin Application.ProcessMessages; fsSyntaxMemo4.Lines.Clear; if DirectoryExists(DirName_from_List_EnvVars(Memo_EV.Lines)) then begin //удалить все PAS-файлы из папки (если требуется) //Files_Delete(DirName_from_List_EnvVars(Memo_EV.Lines)+'*.pas'); if qScrid.AsInteger>0 then begin fsSyntaxMemo4.Lines.Text:=fsSyntaxMemo3.Lines.Text; //........................................... //Парсинг раздела Uses скрипта и выгрузка //соответствующих библиотечных скриптов из БД //в файлы fsiBase_Main_Script_Mnemo_Prepare(qTMP, fsSyntaxMemo4.Lines, Memo_EV.Lines ); //........................................... //........................................... //Парсинг скрипта. Переменные окружения fsiBase_Main_Script_EnvVars_Prepare( fsSyntaxMemo4.Lines, Memo_EV.Lines ); //........................................... end; end else begin ShowMessage('Ошибка! Не найдена папка для выгрузки библиотечных скриптов из БД'); end; end; function fsiBase_Main_Script_Mnemo_Prepare(Q:TFDQuery; scrText:TStrings; List_EnvVars:TStrings ):boolean; //Выгрузка библиотечных скриптов из БД. Парсинг скрипта Var ListScr:TStrings; sDir, sMnemo:string; Sx:string; InUses:boolean; N,i:integer; begin Result:=false; if Assigned(Q) then begin if Assigned(List_EnvVars) then begin if List_EnvVars.Count>0 then begin //Получить имя папки для сохранения библиотечных файлов из БД sDir:=DirName_from_List_EnvVars(List_EnvVars); if DirectoryExists(sDir) then begin //удалить все PAS-файлы из папки (если требуется) //Files_Delete(sDir+'*.pas'); if Assigned(scrText) then begin if scrText.Count>0 then begin Result:=true; end; end; end; end; end; end; if Result then begin //--------------------------------------------------- //Поиск раздела USES и его парсинг ListScr:=TStringList.Create; TRY InUses:=false; i:=-1; while i<(scrText.Count-1) do begin i:=i+1; Sx:=trim(scrText[i]); sMnemo:=''; if InUses then begin if Sx<>'' then begin //................................ //Выделить мнемокод из строки FS-скрипта //если он там присутствует sMnemo:=Mnemo_Extract(Sx); //................................ if sMnemo<>'' then begin //................................ //Загрузить скрипт из БД ListScr.Text:=FS_LoadFromDB(Q, sMnemo, true); //................................ if ListScr.Count>0 then begin //Сохранить срипт в папку ListScr.SaveToFile(sDir+sMnemo+'.pas'); end; ListScr.Text:=''; //................................ //Заменить строку в скрипте Sx:=Replace_In_String(scrText[i], '${'+sMnemo+'}', sMnemo+'.pas', true); scrText[i]:=Sx; //................................ end; end; end; //................................ //................................ //Определение начала раздела Uses FS-Скрипта if AnsiUpperCase(Sx) = 'USES' then InUses:=true; //................................ if InUses then begin //................................ //Оценка: это конец раздела USES? if Sx<>'' then begin if Sx[length(Sx)]=';' then begin InUses:=false; i:=(scrText.Count+1); //Выход из парсинга end; end; //................................ end; end; FINALLY FreeAndNil(ListScr); END; //--------------------------------------------------- end; end; function fsiBase_Main_Script_EnvVars_Prepare( scrText:TStrings; List_EnvVars:TStrings ):boolean; //Переменные окружения. Парсинг скрипта // scrText - текст скрипта (TStrings) // List_EnvVars - список значений преременных окружения begin Result:=false; if Assigned(scrText) then begin if scrText.Count>0 then begin Result:=true; if Assigned(List_EnvVars) then begin if List_EnvVars.Count>0 then begin scrText.Text := fsiBase_Main_Script_EnvVars_Prepare( scrText.Text, List_EnvVars ); end; end; end; end; end; function fsiBase_Main_Script_EnvVars_Prepare( sScript:string; List_EnvVars:TStrings ):string; //Переменные окружения. Парсинг скрипта // sScript - текст скрипта // List_EnvVars - список значений преременных окружения Var vn,vv:string; i:integer; begin Result:=''; if Assigned(List_EnvVars) then begin if List_EnvVars.Count>0 then begin Result:=sScript; i:=-1; while i<(List_EnvVars.Count-1) do begin i:=i+1; vn:=trim(List_EnvVars.Names[i]); if length(vn)>0 then begin vv:=trim(List_EnvVars.Values[vn]); if length(vv)>0 then begin Result:=Replace_In_String(Result, '$('+vn+')', vv, true); end; end; end; end; end; end; function DirName_from_List_EnvVars(List_EnvVars:TStrings):string; //Получить полное имя папки для библиотечных файлов begin Result:=''; if Assigned(List_EnvVars) then begin if List_EnvVars.Count>0 then begin Result:=trim(List_EnvVars.Values['App_Dir']); Result:=Result+trim(List_EnvVars.Values['Scr_Dir']); Result:=Result+trim(List_EnvVars.Values['Lib_Dir']); end; end; end; function Replace_In_String(const S, Srch, Replace: string; CaseIgnore:boolean=true): string; //замена подстроки в строке var N:Integer; Source:string; begin Source:= S; Result:= ''; repeat if CaseIgnore then begin N:=Pos(AnsiUpperCase(Srch), AnsiUpperCase(Source)); end else begin N:=Pos(Srch, Source); end; if N>0 then begin Result:=Result+Copy(Source,1,N-1)+Replace; Source:=Copy(Source,N+Length(Srch),MaxInt); end else begin Result:=Result+Source; end; until N<=0; end; function Mnemo_Extract(Sx:string):string; //Выделить мнемокод из строки Var N:integer; begin Result:=''; Sx:=trim(Sx); N:=POS('${',Sx); if N>0 then begin Sx:=trim(Delete_start_String(Sx, N+1)); N:=POS('}',Sx); if N>0 then begin Result:=trim(Delete_end_String(Sx, N)); end; end; end; function Delete_end_String(Sx : string; Index:integer) : string; //Удалить окончание строки, начиная с заданой позиции begin Result:=Sx; if length(Sx)>0 then begin if Index>0 then begin System.Delete(Result, Index, length(Result)+1); end; end; end; function Delete_start_String(Sx : string; Index:integer) : string; //Удалить начало строки, начиная с 1-й позиции и до заданной (включая заданную) begin Result:=Sx; if length(Sx)>0 then begin if Index>0 then begin System.Delete(Result, 1, Index); end; 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 FS_LoadFromDB(Q:TFDQuery; ScrMnemo:string; ItsLibOnly:boolean=true ):string; //Загрузить FS-скрипт по МнемоКоду Var sFilter:string; begin Result:=''; ScrMnemo:=trim(ScrMnemo); if ScrMnemo<>'' then begin sFilter:='(mnemocode_lc='+#39+AnsiLowerCase(ScrMnemo)+#39+')'; if ItsLibOnly then begin sFilter:=sFilter+' and (its_lib=1)'; end; Result:=DB_Table_Field_AsString(Q, 'fs_scripts', 'fs_script', sFilter ); end; end; function Dir_Create(DirName: String): boolean; //Создать папку (каталог) begin Result := false; DirName := trim(DirName); if length(DirName) > 0 then begin if DirName[length(DirName)] <> '\' then DirName := DirName + '\'; Result := ForceDirectories(DirName); if Result then begin Result := DirectoryExists(DirName); end; end; end; function Files_Delete(NameMask: String): integer; //Удалить файлы по маске Var DirInfo: TSearchRec; Err: integer; begin Result := 0; Err := 0; Err := FindFirst(NameMask, faArchive, DirInfo); while Err = 0 do begin if DeleteFile(ExtractFilePath(NameMask) + DirInfo.Name) then begin Result := Result + 1; end; Err := FindNext(DirInfo); end; FindClose(DirInfo); end; end.