Vichingo455-RePacks/xtool
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases 1 Wiki Activity

source upload

Browse Source
This commit is contained in:
Razor12911
2022-01-17 22:16:47 +02:00
parent 12936d065b
commit 098e8c48de
1778 changed files with 1206749 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

170
contrib/mORMot/SQLite3/DDD/tools/dddToolsAdminDB.dfm Normal file
View File

@@ -0,0 +1,170 @@
object DBFrame: TDBFrame
Left = 0
Top = 0
Width = 689
Height = 339
TabOrder = 0
object spl2: TSplitter
Left = 169
Top = 0
Height = 339
end
object pnlRight: TPanel
Left = 172
Top = 0
Width = 517
Height = 339
Align = alClient
TabOrder = 0
object spl1: TSplitter
Left = 1
Top = 113
Width = 515
Height = 3
Cursor = crVSplit
Align = alTop
end
object pnlTop: TPanel
Left = 1
Top = 1
Width = 515
Height = 112
Align = alTop
Constraints.MinHeight = 100
TabOrder = 0
DesignSize = (
515
112)
object mmoSQL: TMemo
Left = 0
Top = 0
Width = 454
Height = 111
Anchors = [akLeft, akTop, akRight, akBottom]
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -12
Font.Name = 'Consolas'
Font.Style = []
ParentFont = False
TabOrder = 0
end
object btnExec: TButton
Left = 461
Top = 8
Width = 43
Height = 25
Hint = 'Execute the SQL statement (F9)'
Anchors = [akTop, akRight]
Caption = 'Exec'
ParentShowHint = False
ShowHint = True
TabOrder = 1
OnClick = btnExecClick
end
object btnHistory: TButton
Left = 461
Top = 40
Width = 43
Height = 25
Hint = 'View SQL log history (Ctrl+H)'
Anchors = [akTop, akRight]
Caption = 'History'
ParentShowHint = False
ShowHint = True
TabOrder = 2
OnClick = btnHistoryClick
end
object btnCmd: TButton
Left = 461
Top = 72
Width = 43
Height = 25
Hint = 'Launch a pseudo-command (F5)'
Anchors = [akTop, akRight]
Caption = '#cmd'
ParentShowHint = False
PopupMenu = pmCmd
ShowHint = True
TabOrder = 3
OnClick = btnCmdClick
end
end
object drwgrdResult: TDrawGrid
Left = 1
Top = 116
Width = 515
Height = 117
Align = alTop
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -12
Font.Name = 'Tahoma'
Font.Style = []
ParentFont = False
TabOrder = 1
Visible = False
OnClick = drwgrdResultClick
end
end
object pnlLeft: TPanel
Left = 0
Top = 0
Width = 169
Height = 339
Align = alLeft
TabOrder = 1
object lstTables: TListBox
Left = 1
Top = 45
Width = 167
Height = 293
Align = alClient
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -12
Font.Name = 'Tahoma'
Font.Style = []
ItemHeight = 14
ParentFont = False
TabOrder = 0
OnDblClick = lstTablesDblClick
end
object pnlLeftTop: TPanel
Left = 1
Top = 1
Width = 167
Height = 44
Align = alTop
TabOrder = 1
DesignSize = (
167
44)
object edtLabels: TEdit
Left = 5
Top = 4
Width = 156
Height = 21
Hint = 'Incremental Search'
Anchors = [akLeft, akTop, akRight]
ParentShowHint = False
ShowHint = True
TabOrder = 0
OnChange = edtLabelsChange
end
object chkTables: TCheckBox
Left = 8
Top = 26
Width = 156
Height = 17
Caption = 'chkTables'
TabOrder = 1
Visible = False
end
end
end
object pmCmd: TPopupMenu
Left = 648
Top = 80
end
end

695
contrib/mORMot/SQLite3/DDD/tools/dddToolsAdminDB.pas Normal file
View File

@@ -0,0 +1,695 @@
unit dddToolsAdminDB;
interface
uses
Windows,
Messages,
SysUtils,
Variants,
Classes,
Graphics,
Controls,
Forms,
Dialogs,
Grids,
StdCtrls,
ExtCtrls,
Menus,
SynMemoEx,
SynCommons,
mORMot,
mORMotDDD,
mORMotHttpClient,
mORMotUI,
SynMustache;
type
TDBFrame = class;
TOnExecute = function(Sender: TDBFrame; const SQL, Content: RawUTF8): boolean of object;
TDBFrame = class(TFrame)
pnlRight: TPanel;
pnlTop: TPanel;
mmoSQL: TMemo;
btnExec: TButton;
drwgrdResult: TDrawGrid;
spl1: TSplitter;
spl2: TSplitter;
btnHistory: TButton;
btnCmd: TButton;
pmCmd: TPopupMenu;
pnlLeft: TPanel;
lstTables: TListBox;
pnlLeftTop: TPanel;
edtLabels: TEdit;
chkTables: TCheckBox;
procedure lstTablesDblClick(Sender: TObject); virtual;
procedure btnExecClick(Sender: TObject); virtual;
procedure drwgrdResultClick(Sender: TObject); virtual;
procedure btnHistoryClick(Sender: TObject); virtual;
procedure btnCmdClick(Sender: TObject); virtual;
procedure edtLabelsChange(Sender: TObject);
protected
fGridToCellRow: integer;
fGridToCellVariant: variant;
fJson: RawJSON;
fSQL, fPreviousSQL: RawUTF8;
fSQLLogFile: TFileName;
function ExecSQL(const SQL: RawUTF8): RawUTF8;
function OnText(Sender: TSQLTable; FieldIndex, RowIndex: Integer;
var Text: string): boolean;
procedure OnCommandsToGridAdd(const Item: TSynNameValueItem; Index: PtrInt);
function OnGridToCell(Sender: TSQLTable; Row, Field: integer;
HumanFriendly: boolean): RawJSON;
procedure LogClick(Sender: TObject);
procedure LogDblClick(Sender: TObject);
procedure LogSearch(Sender: TObject);
public
DatabaseName: RawUTF8;
mmoResult: TMemoEx; // initialized by code from SynMemoEx.pas
Grid: TSQLTableToGrid;
GridLastTableName: RawUTF8;
Client: TSQLHttpClientWebsockets;
Admin: IAdministratedDaemon;
Tables: TStringList;
AssociatedModel: TSQLModel;
AssociatedServices: TInterfaceFactoryObjArray;
// Add(cmdline/table,nestedobject,-1=text/0..N=nestedarray#)
CommandsToGrid: TSynNameValue;
TableDblClickSelect: TSynNameValue;
TableDblClickOrderByIdDesc: boolean;
TableDblClickOrderByIdDescCSV: string;
SavePrefix: TFileName;
OnBeforeExecute: TOnExecute;
OnAfterExecute: TOnExecute;
constructor Create(AOwner: TComponent); override;
procedure EnableChkTables(const aCaption: string);
procedure Open; virtual;
procedure FillTables(const customcode: string); virtual;
procedure AddSQL(SQL: string; AndExec: boolean);
procedure SetResult(const JSON: RawUTF8); virtual;
function NewCmdPopup(const c: string; NoCmdTrim: boolean): TMenuItem;
destructor Destroy; override;
end;
TDBFrameClass = class of TDBFrame;
TDBFrameDynArray = array of TDBFrame;
implementation
{$R *.dfm}
const
WRAPPER_TEMPLATE = '{{#soa.services}}'#13#10'{{#methods}}'#13#10 +
'#get {{uri}}/{{methodName}}{{#hasInParams}}?{{#args}}{{#dirInput}}{{argName}}={{typeSource}}' +
'{{#commaInSingle}}&{{/commaInSingle}}{{/dirInput}}{{/args}}{{/hasInParams}}'#13#10 +
'{{#hasOutParams}}'#13#10' { {{#args}}{{#dirOutput}}{{jsonQuote argName}}: {{typeSource}}' +
'{{#commaOutResult}},{{/commaOutResult}} {{/dirOutput}}{{/args}} }'#13#10 +
'{{/hasOutParams}}{{/methods}}'#13#10'{{/soa.services}}'#13#10'{{#enumerates}}{{name}}: ' +
'{{#values}}{{EnumTrim .}}={{-index0}}{{^-last}}, {{/-last}}{{/values}}'#13#10'{{/enumerates}}';
{ TDBFrame }
constructor TDBFrame.Create(AOwner: TComponent);
begin
inherited;
fSQLLogFile := ChangeFileExt(ExeVersion.ProgramFileName, '.history');
mmoResult := TMemoEx.Create(self);
mmoResult.Name := 'mmoResult';
mmoResult.Parent := pnlRight;
mmoResult.Align := alClient;
mmoResult.Font.Height := -11;
mmoResult.Font.Name := 'Consolas';
mmoResult.ReadOnly := true;
mmoResult.ScrollBars := ssVertical;
mmoResult.Text := '';
mmoResult.RightMargin := 130;
mmoResult.RightMarginVisible := true;
mmoResult.OnGetLineAttr := mmoResult.JSONLineAttr;
pnlLeftTop.Height := 30;
Tables := TStringList.Create;
TableDblClickSelect.Init(false);
CommandsToGrid.Init(false);
CommandsToGrid.OnAfterAdd := OnCommandsToGridAdd;
end;
procedure TDBFrame.Open;
begin
FillTables('');
edtLabelsChange(nil);
mmoSQL.Text := '#help';
btnExecClick(nil);
mmoSQL.Text := '';
mmoResult.Text := '';
end;
procedure TDBFrame.FillTables(const customcode: string);
var
i: integer;
aTables: TRawUTF8DynArray;
begin
drwgrdResult.Align := alClient;
aTables := Admin.DatabaseTables(DatabaseName);
Tables.Clear;
Tables.BeginUpdate;
try
for i := 0 to high(aTables) do
Tables.Add(UTF8ToString(aTables[i]));
finally
Tables.EndUpdate;
end;
end;
procedure TDBFrame.lstTablesDblClick(Sender: TObject);
var
i: integer;
table, fields, sql, orderby: string;
begin
i := lstTables.ItemIndex;
if i < 0 then
exit;
table := lstTables.Items[i];
fields := string(TableDblClickSelect.Value(RawUTF8(table)));
if fields='' then
fields := '*' else begin
i := Pos(' order by ', fields);
if i > 0 then begin
orderby := copy(fields, i, maxInt);
Setlength(fields, i - 1);
end;
end;
sql := 'select '+fields+' from ' + table;
if orderby <> '' then
sql := sql + orderby
else begin
if TableDblClickOrderByIdDesc or ((TableDblClickOrderByIdDescCSV <> '') and
(Pos(table + ',', TableDblClickOrderByIdDescCSV + ',') > 0)) then
sql := sql + ' order by id desc';
sql := sql + ' limit 1000';
end;
AddSQL(sql, true);
end;
procedure TDBFrame.SetResult(const JSON: RawUTF8);
begin
FreeAndNil(Grid);
drwgrdResult.Hide;
mmoResult.Align := alClient;
mmoResult.WordWrap := false;
mmoResult.ScrollBars := ssBoth;
mmoResult.RightMarginVisible := false;
if (JSON = '') or (JSON[1] in ['A'..'Z', '#']) then
mmoResult.OnGetLineAttr := nil
else
mmoResult.OnGetLineAttr := mmoResult.JSONLineAttr;
mmoResult.Text := UTF8ToString(StringReplaceTabs(JSON, ' '));
mmoResult.SetCaret(0, 0);
mmoResult.TopRow := 0;
fJson := '';
end;
procedure TDBFrame.OnCommandsToGridAdd(const Item: TSynNameValueItem;
Index: PtrInt);
begin
pmCmd.Items.Insert(0, NewCmdPopup(UTF8ToString(Item.Name), true));
end;
function TDBFrame.NewCmdPopup(const c: string; NoCmdTrim: boolean): TMenuItem;
var
cmd, name, lastname: string;
i, ext, num: integer;
res: TDocVariantData;
sub, subpar, subarch: TMenuItem;
begin
result := TMenuItem.Create(self);
if length(c) > 40 then
result.Caption := copy(c, 1, 37) + '...'
else
result.Caption := c;
if NoCmdTrim then
cmd := c
else begin
i := Pos(' ', c);
if i > 0 then
cmd := copy(c, 1, i) + '*'
else begin
i := Pos('(', c);
if i > 0 then
cmd := copy(c, 1, i) + '*)'
else
cmd := c;
end;
end;
result.Hint := cmd;
if (cmd = '#log *') or (cmd = '#db *') then begin // log/db files in sub-menus
res.InitJSON(ExecSQL(StringToUTF8(cmd)), JSON_OPTIONS_FAST);
SetLength(cmd, length(cmd) - 1);
subpar := result;
subarch := nil;
if res.Kind = dvArray then
for i := 0 to res.Count - 1 do begin
name := res.Values[i].Name;
if name = lastname then
continue; // circumvent FindFiles() bug with *.dbs including *.dbsynlz
lastname := name;
case GetFileNameExtIndex(name, 'dbs,dbsynlz') of
0: begin // group sharded database files by 20 in sub-menus
ext := Pos('.dbs', name);
if (ext > 4) and TryStrToInt(Copy(name, ext - 4, 4), num) then
if (subpar = result) or (num mod 20 = 0) then begin
subpar := NewCmdPopup(cmd + name + ' ...', true);
subpar.OnClick := nil;
result.Add(subpar);
end;
end;
1: begin // group database backup files in a dedicated sub-menu
if subarch = nil then begin
subarch := NewCmdPopup(cmd + '*.dbsynlz ...', true);
subarch.OnClick := nil;
result.Add(subarch);
end;
subpar := subarch;
end;
else
subpar := result;
end;
sub := NewCmdPopup(cmd + name, true);
if cmd = '#log ' then
sub.Caption := sub.Caption + ' ' + res.Values[i].TimeStamp
else
sub.Caption := FormatString('% %', [sub.Caption, KB(res.Values[i].Size)]);
subpar.Add(sub);
end;
end
else
result.OnClick := btnExecClick;
end;
procedure TDBFrame.btnExecClick(Sender: TObject);
var
res, ctyp, execTime: RawUTF8;
mmo, cmd, fn, local: string;
SelStart, SelLength, cmdToGrid, i: integer;
table: TSQLTable;
tables: TSQLRecordClassDynArray;
P: PUTF8Char;
exec: TServiceCustomAnswer;
ctxt: variant;
timer: TPrecisionTimer;
begin
if (Sender <> nil) and Sender.InheritsFrom(TMenuItem) then begin
mmo := TMenuItem(Sender).Hint;
mmoSQL.Text := mmo;
i := Pos('*', mmo);
if (i > 0) and (mmo[1] = '#') then begin
mmoSQL.SelStart := i - 1;
mmoSQL.SelLength := 1;
mmoSQL.SetFocus;
exit;
end;
end;
SelStart := mmoSQL.SelStart;
SelLength := mmoSQL.SelLength;
if SelLength > 10 then
mmo := mmoSQL.SelText
else
mmo := mmoSQL.Lines.Text;
fSQL := Trim(StringToUTF8(mmo));
if fSQL = '' then
exit;
if IdemPropNameU(fSQL, '#client') then begin
fJson := ObjectToJSON(Client);
end
else if Assigned(OnBeforeExecute) and not OnBeforeExecute(self, fSQL, '') then
fJson := '"You are not allowed to execute this command for security reasons"'
else begin
Screen.Cursor := crHourGlass;
try
try
timer.Start;
exec := Admin.DatabaseExecute(DatabaseName, fSQL);
execTime := timer.Stop;
ctyp := FindIniNameValue(pointer(exec.Header), HEADER_CONTENT_TYPE_UPPER);
if IdemPChar(pointer(exec.Content), '<HEAD>') then begin // HTML in disguise
i := PosI('<BODY>', exec.content);
if i = 0 then
fJson := exec.Content
else
fJson := copy(exec.Content, i, maxInt);
end
else
if (ctyp = '') or IdemPChar(pointer(ctyp), JSON_CONTENT_TYPE_UPPER) then
fJson := exec.Content
else
if IdemPropNameU(ctyp, BINARY_CONTENT_TYPE) then begin
fn := UTF8ToString(trim(FindIniNameValue(pointer(exec.Header), 'FILENAME:')));
if (fn <> '') and (exec.Content <> '') then
with TSaveDialog.Create(self) do
try
Options := [ofOverwritePrompt, ofHideReadOnly, ofPathMustExist, ofEnableSizing];
InitialDir := GetShellFolderPath(CSIDL_DOCUMENTS);
FileName := SavePrefix + fn;
if Execute then begin
local := FileName;
FileFromString(exec.Content, local);
end;
finally
Free;
end;
fJson := JSONEncode(['file', fn, 'size', length(exec.Content),
'type', ctyp, 'localfile', local]);
end
else
fJson := FormatUTF8('"Unknown content-type: %"', [ctyp]);
except
on E: Exception do
fJson := ObjectToJSON(E);
end;
finally
Screen.Cursor := crDefault;
end;
end;
FreeAndNil(Grid);
GridLastTableName := '';
fGridToCellRow := 0;
cmdToGrid := CommandsToGrid.Find(fSQL);
if (fSQL[1] = '#') and
((cmdToGrid < 0) or (CommandsToGrid.List[cmdToGrid].Tag < 0)) then begin
if fJson <> '' then
if IdemPropNameU(fSQL, '#help') then begin
fJson := Trim(UnQuoteSQLString(fJson)) + '|#client'#13#10;
res := StringReplaceAll(fJson, '|', #13#10' ');
if pmCmd.Items.Count = 0 then begin
P := pointer(res);
while P <> nil do begin
cmd := UTF8ToString(Trim(GetNextLine(P, P)));
if (cmd <> '') and (cmd[1] = '#') then
pmCmd.Items.Add(NewCmdPopup(cmd, false));
end;
end;
end
else if IdemPropNameU(fSQL, '#wrapper') then begin
_Json(fJson,ctxt,JSON_OPTIONS_FAST);
res := TSynMustache.Parse(WRAPPER_TEMPLATE).Render(ctxt, nil,
TSynMustache.HelpersGetStandardList, nil, true);
end
else begin
JSONBufferReformat(pointer(fJson), res, jsonUnquotedPropName);
if (res = '') or (res = 'null') then
res := fJson;
end;
if Assigned(OnAfterExecute) then
OnAfterExecute(self,fSQL,res);
SetResult(res);
end
else begin
mmoResult.Text := '';
mmoResult.SetCaret(0, 0);
mmoResult.TopRow := 0;
mmoResult.Align := alBottom;
mmoResult.WordWrap := true;
mmoResult.ScrollBars := ssVertical;
mmoResult.Height := 100;
if AssociatedModel <> nil then
tables := AssociatedModel.Tables;
if cmdToGrid >= 0 then begin
GridLastTableName := CommandsToGrid.List[cmdToGrid].Name;
if isSelect(pointer(GridLastTableName)) then
GridLastTableName := GetTableNameFromSQLSelect(GridLastTableName,false);
if CommandsToGrid.List[cmdToGrid].Value <> '' then begin
// display a nested object in the grid
P := JsonObjectItem(pointer(fJson), CommandsToGrid.List[cmdToGrid].Value);
if CommandsToGrid.List[cmdToGrid].Tag > 0 then
P := JSONArrayItem(P, CommandsToGrid.List[cmdToGrid].Tag - 1);
if P <> nil then
GetJSONItemAsRawJSON(P, RawJSON(fJSON));
end;
end
else
GridLastTableName := GetTableNameFromSQLSelect(fSQL, false);
table := TSQLTableJSON.CreateFromTables(tables, fSQL, pointer(fJson), length(fJson));
Grid := TSQLTableToGrid.Create(drwgrdResult, table, nil);
Grid.SetAlignedByType(sftCurrency, alRight);
Grid.SetFieldFixedWidth(100);
Grid.FieldTitleTruncatedNotShownAsHint := true;
Grid.OnValueText := OnText;
Grid.Table.OnExportValue := OnGridToCell;
if Assigned(OnAfterExecute) then
OnAfterExecute(self, fSQL, fJSON);
drwgrdResult.Options := drwgrdResult.Options - [goRowSelect];
drwgrdResult.Show;
mmoResult.OnGetLineAttr := mmoResult.JSONLineAttr;
mmoResult.Text := FormatString(#13#10' Returned % row(s), as % in %',
[table.RowCount, KB(fJson), execTime]);
end;
if Sender <> nil then begin
mmoSQL.SelStart := SelStart;
mmoSQL.SelLength := SelLength;
mmoSQL.SetFocus;
end;
if ((fJson <> '') or ((fSQL[1] = '#') and (PosEx(' ', fSQL) > 0))) and
(fSQL <> fPreviousSQL) then begin
AppendToTextFile(fSQL, fSQLLogFile);
fPreviousSQL := fSQL;
end;
end;
destructor TDBFrame.Destroy;
begin
FreeAndNil(Grid);
FreeAndNil(AssociatedModel);
FreeAndNil(Tables);
inherited;
end;
function TDBFrame.OnText(Sender: TSQLTable; FieldIndex, RowIndex: Integer;
var Text: string): boolean;
begin
if Sender.FieldType(FieldIndex) in [sftBoolean] then
result := false
else begin
Text := Sender.GetString(RowIndex, FieldIndex); // display the value as such
result := true;
end;
end;
function TDBFrame.OnGridToCell(Sender: TSQLTable; Row, Field: integer;
HumanFriendly: boolean): RawJSON;
var
methodName: RawUTF8;
serv, m: integer;
begin
if fGridToCellRow <> Row then begin
Sender.ToDocVariant(Row, fGridToCellVariant, JSON_OPTIONS_FAST, true, true, true);
fGridToCellRow := Row;
if AssociatedServices <> nil then
with _Safe(fGridToCellVariant)^ do
if GetAsRawUTF8('Method', methodName) then
for serv := 0 to high(AssociatedServices) do begin
m := AssociatedServices[serv].FindFullMethodIndex(methodName, true);
if m >= 0 then
with AssociatedServices[serv].Methods[m] do begin
ArgsAsDocVariantFix(GetAsDocVariantSafe('Input')^, true);
ArgsAsDocVariantFix(GetAsDocVariantSafe('Output')^, false);
break;
end;
end;
end;
with _Safe(fGridToCellVariant)^ do
if cardinal(Field)>=cardinal(Count) then
result := '' else
if HumanFriendly and (_Safe(Values[Field])^.Kind = dvUndefined) then
VariantToUTF8(Values[field], RawUTF8(result))
else
result := VariantSaveJSON(Values[Field]);
end;
procedure TDBFrame.drwgrdResultClick(Sender: TObject);
var
R: integer;
json: RawUTF8;
begin
R := drwgrdResult.Row;
if (R > 0) and (R <> fGridToCellRow) and (Grid <> nil) then begin
OnGridToCell(Grid.Table,R,0,false);
JSONBufferReformat(pointer(VariantToUTF8(fGridToCellVariant)), json, jsonUnquotedPropNameCompact);
mmoResult.OnGetLineAttr := mmoResult.JSONLineAttr;
mmoResult.Text := UTF8ToString(json);
mmoResult.SetCaret(0, 0);
mmoResult.TopRow := 0;
end;
end;
procedure TDBFrame.btnHistoryClick(Sender: TObject);
var
F: TForm;
List: TListBox;
Search: TEdit;
Details: TMemo;
begin
F := TForm.Create(Application);
try
F.Caption := ' ' + btnHistory.Hint;
F.Font := Font;
F.Width := 800;
F.Height := 600;
F.Position := poMainFormCenter;
Search := TEdit.Create(F);
Search.Parent := F;
Search.Align := alTop;
Search.Height := 24;
Search.OnChange := LogSearch;
Details := TMemo.Create(F);
Details.Parent := F;
Details.Align := alBottom;
Details.Height := 200;
Details.readonly := true;
Details.Font.Name := 'Consolas';
List := TListBox.Create(F);
with List do begin
Parent := F;
Align := alClient;
Tag := PtrInt(Details);
OnClick := LogClick;
OnDblClick := LogDblClick;
end;
Search.Tag := PtrInt(List);
LogSearch(Search);
F.ShowModal;
finally
F.Free;
end;
end;
procedure TDBFrame.LogClick(Sender: TObject);
var
List: TListBox absolute Sender;
ndx: integer;
begin
ndx := cardinal(List.ItemIndex);
if ndx >= 0 then
TMemo(List.Tag).Text := copy(List.Items[ndx], 21, maxInt)
else
TMemo(List.Tag).Clear;
end;
procedure TDBFrame.LogDblClick(Sender: TObject);
var
List: TListBox absolute Sender;
SQL: string;
ndx: integer;
begin
ndx := cardinal(List.ItemIndex);
if ndx >= 0 then begin
SQL := copy(List.Items[ndx], 21, maxInt);
AddSQL(SQL, IsSelect(pointer(StringToAnsi7(SQL))));
TForm(List.Owner).Close;
end;
end;
procedure TDBFrame.LogSearch(Sender: TObject);
const
MAX_LINES_IN_HISTORY = 500;
var
Edit: TEdit absolute Sender;
List: TListBox;
i: integer;
s: RawUTF8;
begin
s := SynCommons.UpperCase(StringToUTF8(Edit.Text));
List := pointer(Edit.Tag);
with TMemoryMapText.Create(fSQLLogFile) do
try
List.Items.BeginUpdate;
List.Items.Clear;
for i := Count - 1 downto 0 do
if (s = '') or LineContains(s, i) then
if List.Items.Add(Strings[i]) > MAX_LINES_IN_HISTORY then
break; // read last 500 lines from UTF-8 file
finally
Free;
List.Items.EndUpdate;
end;
List.ItemIndex := 0;
LogClick(List);
end;
procedure TDBFrame.AddSQL(SQL: string; AndExec: boolean);
var
len: integer;
orig: string;
begin
SQL := SysUtils.Trim(SQL);
len := Length(SQL);
if len = 0 then
exit;
orig := mmoSQL.Lines.Text;
if orig <> '' then
SQL := #13#10#13#10 + SQL;
SQL := orig + SQL;
mmoSQL.Lines.Text := SQL;
mmoSQL.SelStart := length(SQL) - len;
mmoSQL.SelLength := len;
if AndExec then
btnExecClick(btnExec)
else
mmoSQL.SetFocus;
end;
procedure TDBFrame.btnCmdClick(Sender: TObject);
begin
with ClientToScreen(btnCmd.BoundsRect.TopLeft) do
pmCmd.Popup(X, Y + btnCmd.Height);
end;
function TDBFrame.ExecSQL(const SQL: RawUTF8): RawUTF8;
var
exec: TServiceCustomAnswer;
begin
exec := Admin.DatabaseExecute(DatabaseName, sql);
result := exec.Content;
end;
procedure TDBFrame.EnableChkTables(const aCaption: string);
begin
pnlLeftTop.Height := 44;
chkTables.Show;
chkTables.Caption := aCaption;
end;
procedure TDBFrame.edtLabelsChange(Sender: TObject);
var
i, index: integer;
match, previous: string;
begin
i := lstTables.ItemIndex;
if i >= 0 then
previous := lstTables.Items[i];
index := -1;
match := SysUtils.Trim(SysUtils.UpperCase(edtLabels.Text));
if (length(match) > 5) and (match[1] = '%') then begin
FillTables(match);
match := '';
end;
with lstTables.Items do
try
BeginUpdate;
Clear;
for i := 0 to Tables.Count - 1 do
if (match = '') or (Pos(match, SysUtils.UpperCase(Tables[i])) > 0) then begin
AddObject(Tables[i], Tables.Objects[i]);
if previous = Tables[i] then
index := Count - 1;
end;
finally
EndUpdate;
end;
if index >= 0 then
lstTables.ItemIndex := index;
end;
end.

176
contrib/mORMot/SQLite3/DDD/tools/dddToolsAdminLog.dfm Normal file
View File

@@ -0,0 +1,176 @@
object LogFrame: TLogFrame
Left = 0
Top = 0
Width = 516
Height = 367
TabOrder = 0
object spl2: TSplitter
Left = 0
Top = 275
Width = 516
Height = 3
Cursor = crVSplit
Align = alBottom
end
object pnlLeft: TPanel
Left = 0
Top = 0
Width = 145
Height = 275
Align = alLeft
TabOrder = 0
DesignSize = (
145
275)
object lblExistingLogKB: TLabel
Left = 12
Top = 34
Width = 56
Height = 13
Caption = 'Existing KB:'
end
object edtSearch: TEdit
Left = 5
Top = 8
Width = 98
Height = 21
Hint = 'Search (Ctrl+F, F3 for next) '
Anchors = [akLeft, akTop, akRight]
ParentShowHint = False
ShowHint = True
TabOrder = 0
Visible = False
OnChange = btnSearchNextClick
end
object chklstEvents: TCheckListBox
Left = 8
Top = 56
Width = 129
Height = 105
OnClickCheck = chklstEventsClickCheck
ItemHeight = 13
PopupMenu = pmFilter
Style = lbOwnerDrawFixed
TabOrder = 3
OnDblClick = chklstEventsDblClick
OnDrawItem = chklstEventsDrawItem
end
object btnStartLog: TButton
Left = 16
Top = 6
Width = 113
Height = 25
Caption = 'Start Logging'
TabOrder = 4
OnClick = btnStartLogClick
end
object edtExistingLogKB: TEdit
Left = 72
Top = 32
Width = 57
Height = 21
Hint = 'How many KB of log text should be transmitted at Start'
ParentShowHint = False
ShowHint = True
TabOrder = 5
Text = '512'
end
object btnStopLog: TButton
Left = 16
Top = 168
Width = 113
Height = 25
Caption = 'Stop Logging'
TabOrder = 6
Visible = False
OnClick = btnStopLogClick
end
object BtnSearchNext: TButton
Left = 103
Top = 6
Width = 20
Height = 23
Hint = 'Search Next (F3)'
Anchors = [akTop, akRight]
Caption = '?'
ParentShowHint = False
ShowHint = True
TabOrder = 1
Visible = False
OnClick = btnSearchNextClick
end
object BtnSearchPrevious: TButton
Left = 123
Top = 6
Width = 20
Height = 23
Hint = 'Search Previous (Shift F3)'
Anchors = [akTop, akRight]
Caption = '^'
ParentShowHint = False
ShowHint = True
TabOrder = 2
Visible = False
OnClick = btnSearchNextClick
end
end
object pnlRight: TPanel
Left = 145
Top = 0
Width = 371
Height = 275
Align = alClient
TabOrder = 1
object spl1: TSplitter
Left = 1
Top = 1
Height = 273
end
object drwgrdEvents: TDrawGrid
Left = 4
Top = 1
Width = 366
Height = 273
Align = alClient
ColCount = 3
DefaultColWidth = 100
DefaultRowHeight = 14
FixedCols = 0
RowCount = 1
FixedRows = 0
Options = [goFixedVertLine, goFixedHorzLine, goVertLine, goHorzLine, goRangeSelect, goDrawFocusSelected, goRowSelect, goThumbTracking]
TabOrder = 0
Visible = False
OnClick = drwgrdEventsClick
OnDblClick = drwgrdEventsDblClick
OnDrawCell = drwgrdEventsDrawCell
end
end
object mmoBottom: TMemo
Left = 0
Top = 278
Width = 516
Height = 89
Align = alBottom
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Consolas'
Font.Style = []
ParentFont = False
ReadOnly = True
ScrollBars = ssVertical
TabOrder = 2
end
object pmFilter: TPopupMenu
Left = 96
Top = 112
end
object tmrRefresh: TTimer
Enabled = False
Interval = 200
OnTimer = tmrRefreshTimer
Left = 153
Top = 32
end
end

525
contrib/mORMot/SQLite3/DDD/tools/dddToolsAdminLog.pas Normal file
View File

@@ -0,0 +1,525 @@
unit dddToolsAdminLog;
interface
uses
Windows,
Messages,
SysUtils,
Variants,
Classes,
Graphics,
Controls,
Forms,
Dialogs,
ExtCtrls,
StdCtrls,
CheckLst,
Menus,
Grids,
SynCommons,
SynLog,
mORMot,
mORMotDDD;
type
TLogFrame = class(TFrame)
pnlLeft: TPanel;
pnlRight: TPanel;
spl1: TSplitter;
edtSearch: TEdit;
chklstEvents: TCheckListBox;
pmFilter: TPopupMenu;
mmoBottom: TMemo;
drwgrdEvents: TDrawGrid;
btnStartLog: TButton;
tmrRefresh: TTimer;
edtExistingLogKB: TEdit;
lblExistingLogKB: TLabel;
btnStopLog: TButton;
spl2: TSplitter;
BtnSearchNext: TButton;
BtnSearchPrevious: TButton;
procedure chklstEventsDrawItem(Control: TWinControl; Index: Integer; Rect:
TRect; State: TOwnerDrawState);
procedure btnStartLogClick(Sender: TObject);
procedure tmrRefreshTimer(Sender: TObject);
procedure drwgrdEventsDrawCell(Sender: TObject; ACol, ARow: Integer; Rect:
TRect; State: TGridDrawState);
procedure drwgrdEventsClick(Sender: TObject); virtual;
procedure btnSearchNextClick(Sender: TObject);
procedure chklstEventsDblClick(Sender: TObject);
procedure btnStopLogClick(Sender: TObject);
procedure chklstEventsClickCheck(Sender: TObject);
procedure drwgrdEventsDblClick(Sender: TObject);
protected
FLog: TSynLogFileView;
FMenuFilterAll, FMenuFilterNone: TMenuItem;
FCallbackPattern: RawUTF8;
FLogSafe: TSynLocker;
procedure EventsCheckToLogEvents;
procedure pmFilterClick(Sender: Tobject);
procedure ReceivedOne(const Text: RawUTF8);
procedure SetListItem(Index: integer; const search: RawUTF8 = '');
public
Admin: IAdministratedDaemon;
Callback: ISynLogCallback;
OnLogReceived: function(Sender: TLogFrame; Level: TSynLogInfo;
const Text: RawUTF8): boolean of object;
constructor Create(Owner: TComponent; const aAdmin: IAdministratedDaemon); reintroduce;
constructor CreateCustom(Owner: TComponent; const aAdmin: IAdministratedDaemon;
const aEvents, aPattern: RawUTF8); virtual;
destructor Destroy; override;
procedure LogFilter(F: TSynLogInfos);
procedure Closing;
end;
TLogFrameClass = class of TLogFrame;
TLogFrameDynArray = array of TLogFrame;
TLogFrameChat = class(TLogFrame)
protected
procedure mmoChatKeyPress(Sender: TObject; var Key: Char);
public
mmoChat: TMemo;
constructor CreateCustom(Owner: TComponent; const aAdmin:
IAdministratedDaemon; const aEvents, aPattern: RawUTF8); override;
end;
implementation
uses
dddToolsAdminMain;
{$R *.dfm}
{ TLogFrameCallback }
type
TLogFrameCallback = class(TInterfacedObject, ISynLogCallback)
public
Owner: TLogFrame;
Pattern: RawUTF8;
procedure Log(Level: TSynLogInfo; const Text: RawUTF8);
end;
procedure TLogFrameCallback.Log(Level: TSynLogInfo; const Text: RawUTF8);
begin
if (Pattern <> '') and (Level <> sllNone) then
if PosI(pointer(Pattern), Text) = 0 then
exit;
Owner.ReceivedOne(Text);
if Assigned(Owner.OnLogReceived) then
Owner.OnLogReceived(Owner, Level, Text);
end;
procedure TLogFrame.chklstEventsDrawItem(Control: TWinControl; Index: Integer;
Rect: TRect; State: TOwnerDrawState);
var
E: TSynLogInfo;
begin
if Index < 0 then
exit;
E := TSynLogInfo(chklstEvents.Items.Objects[Index]);
with chklstEvents.Canvas do begin
Brush.Color := LOG_LEVEL_COLORS[false, E];
Font.Color := LOG_LEVEL_COLORS[true, E];
TextRect(Rect, Rect.Left + 4, Rect.Top, ToCaption(E));
end;
end;
var
LogFrameCount: integer;
constructor TLogFrame.Create(Owner: TComponent; const aAdmin: IAdministratedDaemon);
var
F: TSynLogFilter;
M: TMenuItem;
begin
inherited Create(Owner);
FLogSafe.Init;
Admin := aAdmin;
Name := 'LogFrame' + IntToStr(LogFrameCount);
inc(LogFrameCount);
for F := low(F) to high(F) do begin
M := TMenuItem.Create(self);
M.Caption := ToCaption(F);
M.Tag := ord(F);
M.OnClick := pmFilterClick;
if F = lfAll then
FMenuFilterAll := M
else if F = lfNone then
FMenuFilterNone := M;
pmFilter.Items.Add(M);
end;
btnStopLogClick(nil);
end;
constructor TLogFrame.CreateCustom(Owner: TComponent;
const aAdmin: IAdministratedDaemon; const aEvents, aPattern: RawUTF8);
var
P: PUTF8Char;
e: integer;
begin
Create(Owner, aAdmin);
pmFilterClick(FMenuFilterNone);
P := pointer(aEvents);
while P <> nil do begin
e := PTypeInfo(TypeInfo(TSynLogInfo))^.EnumBaseType.GetEnumNameValue(
pointer(GetNextItem(P)));
if e > 0 then // ignore e=0=sllNone
chklstEvents.Checked[e - 1] := True;
end;
FCallbackPattern := UpperCase(aPattern);
btnStartLogClick(self);
btnStopLog.Hide; { TODO: allow event log closing }
end;
destructor TLogFrame.Destroy;
begin
FLogSafe.Done;
inherited;
end;
procedure TLogFrame.btnStopLogClick(Sender: TObject);
var
E: TSynLogInfo;
begin
chklstEvents.Top := 56;
chklstEvents.Items.Clear;
for E := succ(sllNone) to high(E) do begin
if (Sender = Self) and not (E in FLog.Events) then
continue; // from TLogFrame.CreateCustom()
chklstEvents.Items.AddObject(ToCaption(E), pointer(ord(E)));
end;
chklstEvents.Height := 8 + chklstEvents.Count * chklstEvents.ItemHeight;
pmFilterClick(FMenuFilterAll);
if Sender = nil then
exit;
btnStartLog.Show;
btnStopLog.Hide;
edtExistingLogKB.Show;
lblExistingLogKB.Show;
edtSearch.Hide;
btnSearchNext.Hide;
BtnSearchPrevious.Hide;
mmoBottom.Text := '';
drwgrdEvents.Row := 0;
drwgrdEvents.RowCount := 0;
drwgrdEvents.Tag := 0;
tmrRefresh.Enabled := false;
(Owner as TAdminControl).EndLog(self);
end;
procedure TLogFrame.LogFilter(F: TSynLogInfos);
var
i: integer;
begin
for i := 0 to chklstEvents.Count - 1 do
chklstEvents.Checked[i] := TSynLogInfo(chklstEvents.Items.Objects[i]) in F;
chklstEventsClickCheck(nil);
end;
procedure TLogFrame.pmFilterClick(Sender: Tobject);
begin
if Sender.InheritsFrom(TMenuItem) then
LogFilter(LOG_FILTER[TSynLogFilter(TMenuItem(Sender).Tag)]);
end;
procedure TLogFrame.EventsCheckToLogEvents;
var
i: integer;
events: TSynLogInfos;
begin
integer(events) := 0;
for i := 0 to chklstEvents.Count - 1 do
if chklstEvents.Checked[i] then
Include(events, TSynLogInfo(chklstEvents.Items.Objects[i]));
FLog.Events := events;
end;
procedure TLogFrame.btnStartLogClick(Sender: TObject);
var
cb: TLogFrameCallback;
kb, i: integer;
begin
cb := TLogFrameCallback.Create;
cb.Owner := Self;
cb.Pattern := FCallbackPattern;
Callback := cb;
FLogSafe.Lock;
try
try
FLog := TSynLogFileView.Create;
drwgrdEvents.DoubleBuffered := true;
drwgrdEvents.ColCount := 4;
drwgrdEvents.ColWidths[0] := 70;
drwgrdEvents.ColWidths[1] := 60;
drwgrdEvents.ColWidths[2] := 24;
drwgrdEvents.ColWidths[3] := 2000;
if Sender = self then
kb := 64 // from TLogFrame.CreateCustom
else
kb := StrToIntDef(edtExistingLogKB.Text, 0);
EventsCheckToLogEvents; // fill FLog.Events
Admin.SubscribeLog(FLog.Events, Callback, kb);
chklstEvents.Top := lblExistingLogKB.Top;
for i := chklstEvents.Count - 1 downto 0 do
if not chklstEvents.Checked[i] then
chklstEvents.Items.Delete(i);
chklstEvents.Height := 8 + chklstEvents.Count * chklstEvents.ItemHeight;
btnStopLog.Top := chklstEvents.Top + chklstEvents.Height + 8;
btnStartLog.Hide;
btnStopLog.Show;
edtExistingLogKB.Hide;
lblExistingLogKB.Hide;
edtSearch.Show;
btnSearchNext.Show;
BtnSearchPrevious.Show;
drwgrdEvents.Show;
tmrRefresh.Enabled := true;
except
Callback := nil;
FreeAndNil(FLog);
end;
finally
fLogSafe.UnLock;
end;
end;
const
TAG_NONE = 0;
TAG_REFRESH = 1;
procedure TLogFrame.ReceivedOne(const Text: RawUTF8);
var
P: PUTF8Char;
line: RawUTF8;
begin
// warning: this method is called from WebSockets thread, not UI thread
if Callback = nil then
exit;
FLogSafe.Lock;
try
if (FLog = nil) or (Text = '') then
exit;
P := pointer(Text);
repeat // handle multiple log rows in the incoming text
line := GetNextLine(P, P);
if length(line) < 24 then
continue;
FLog.AddInMemoryLine(line);
tmrRefresh.Tag := TAG_REFRESH; // notify tmrRefreshTimer()
until P = nil;
finally
FLogSafe.UnLock;
end;
end;
procedure TLogFrame.tmrRefreshTimer(Sender: TObject);
var
moveToLast: boolean;
begin
FLogSafe.Lock; // to protect tmrRefresh.Tag access from ReceivedOne()
try
if (tmrRefresh.Tag = TAG_NONE) or (fLog = nil) then
exit;
moveToLast := drwgrdEvents.Row = drwgrdEvents.RowCount - 1;
drwgrdEvents.RowCount := FLog.SelectedCount;
if FLog.SelectedCount > 0 then
if (drwgrdEvents.Tag = 0) or moveToLast then begin
drwgrdEvents.Row := FLog.SelectedCount - 1;
drwgrdEvents.Tag := 1;
end;
drwgrdEvents.Invalidate;
tmrRefresh.Tag := TAG_NONE;
finally
FLogSafe.UnLock;
end;
end;
procedure TLogFrame.drwgrdEventsDrawCell(Sender: TObject; ACol, ARow: Integer;
Rect: TRect; State: TGridDrawState);
var
txt: string;
inverted: boolean;
level: TSynLogInfo;
begin
with drwgrdEvents.Canvas do begin
Brush.Style := bsClear;
FLogSafe.Lock;
try
txt := FLog.GetCell(ACol,ARow,level);
finally
FLogSafe.UnLock;
end;
if level=sllNone then
Brush.Color := clLtGray else begin
inverted := (gdFocused in State) or (gdSelected in State);
if inverted then
Brush.Color := clBlack else
Brush.Color := LOG_LEVEL_COLORS[inverted,level];
Font.Color := LOG_LEVEL_COLORS[not inverted,level];
end;
FillRect(Rect);
TextRect(Rect,Rect.Left+4,Rect.Top,txt);
end;
end;
procedure TLogFrame.drwgrdEventsClick(Sender: TObject);
var
row: integer;
s: string;
sel: TGridRect;
begin
row := drwgrdEvents.Row;
sel := drwgrdEvents.Selection;
FLogSafe.Lock;
try
s := FLog.GetLineForMemo(row,sel.Top,sel.Bottom);
finally
FLogSafe.UnLock;
end;
mmoBottom.Text := s;
end;
procedure TLogFrame.btnSearchNextClick(Sender: TObject);
var
s: RawUTF8;
ndx: integer;
begin
s := UpperCase(StringToUTF8(edtSearch.Text));
FLogSafe.Lock;
Screen.Cursor := crHourGlass;
try
if Sender=BtnSearchPrevious then
ndx := FLog.SearchPreviousText(s,drwgrdEvents.Row) else
if Sender=edtSearch then
ndx := FLog.SearchNextText(s,drwgrdEvents.Row,0) else
ndx := FLog.SearchNextText(s,drwgrdEvents.Row,1); // e.g. BtnSearchNext
if ndx>=0 then
SetListItem(ndx,s);
finally
FLogSafe.UnLock;
Screen.Cursor := crDefault;
end;
end;
procedure TLogFrame.SetListItem(Index: integer; const search: RawUTF8);
var
i: integer;
s, ss: string;
begin
if (FLog = nil) or (cardinal(Index) >= cardinal(FLog.SelectedCount)) then
mmoBottom.Text := ''
else begin
drwgrdEvents.Row := Index;
if (search = '') and drwgrdEvents.Visible then
drwgrdEvents.SetFocus;
s := FLog.EventString(FLog.Selected[Index], '', 0, true);
mmoBottom.Text := s;
if search <> '' then begin
ss := UTF8ToString(search);
i := Pos(ss, SysUtils.UpperCase(s));
if i > 0 then begin
mmoBottom.SelStart := i - 1;
mmoBottom.SelLength := length(ss);
mmoBottom.SetFocus;
end;
end;
end;
end;
procedure TLogFrame.Closing;
begin
Callback := nil;
FLogSafe.Lock;
try
FreeAndNil(fLog);
finally
FLogSafe.UnLock;
end;
end;
procedure TLogFrame.chklstEventsDblClick(Sender: TObject);
var
i: integer;
E: TSynLogInfo;
begin
if FLog.EventLevel = nil then // plain text file does not handle this
exit;
i := chklstEvents.ItemIndex;
if i < 0 then
exit;
E := TSynLogInfo(chklstEvents.Items.Objects[i]);
FLogSafe.Lock;
try
i := FLog.SearchNextEvent(E,drwgrdEvents.Row);
if i>=0 then
SetListItem(i);
finally
FLogSafe.UnLock;
end;
end;
procedure TLogFrame.chklstEventsClickCheck(Sender: TObject);
var
selected: integer;
begin
if FLog = nil then
exit;
EventsCheckToLogEvents; // fill FLog.Events
FLogSafe.Lock;
try
selected := FLog.Select(drwgrdEvents.Row);
if cardinal(selected) < cardinal(FLog.SelectedCount) then
drwgrdEvents.Row := 0; // avoid "Grid Out Of Range" when setting RowCount
drwgrdEvents.RowCount := FLog.SelectedCount;
if selected>=0 then
SetListItem(selected);
finally
FLogSafe.UnLock;
end;
if drwgrdEvents.Visible then begin
drwgrdEvents.Repaint;
drwgrdEventsClick(nil);
end;
end;
procedure TLogFrame.drwgrdEventsDblClick(Sender: TObject);
var ndx: integer;
begin
ndx := fLog.SearchEnterLeave(drwgrdEvents.Row);
if ndx>=0 then
SetListItem(ndx);
end;
{ TLogFrameChat }
constructor TLogFrameChat.CreateCustom(Owner: TComponent; const aAdmin:
IAdministratedDaemon; const aEvents, aPattern: RawUTF8);
begin
inherited;
chklstEvents.Enabled := false;
mmoChat := TMemo.Create(self);
mmoChat.Parent := self;
mmoChat.Height := 40;
mmoChat.Align := alTop;
mmoChat.OnKeyPress := mmoChatKeyPress;
end;
procedure TLogFrameChat.mmoChatKeyPress(Sender: TObject; var Key: Char);
begin
if Key = #13 then begin
if Assigned(Admin) then
Admin.DatabaseExecute('', FormatUTF8('#chat % %',
[ExeVersion.User, StringToUTF8(mmoChat.Text)]));
mmoChat.Clear;
Key := #0;
end;
end;
end.

20
contrib/mORMot/SQLite3/DDD/tools/dddToolsAdminMain.dfm Normal file
View File

@@ -0,0 +1,20 @@
object AdminForm: TAdminForm
Left = 379
Top = 162
Width = 697
Height = 478
Caption = ' Tools Administrator'
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Tahoma'
Font.Style = []
KeyPreview = True
OldCreateOrder = False
Position = poDefaultSizeOnly
OnCreate = FormCreate
OnShow = FormShow
PixelsPerInch = 96
TextHeight = 13
end

505
contrib/mORMot/SQLite3/DDD/tools/dddToolsAdminMain.pas Normal file
View File

@@ -0,0 +1,505 @@
unit dddToolsAdminMain;
{$I Synopse.inc} // define HASINLINE CPU32 CPU64 OWNNORMTOUPPER
interface
uses
Windows,
Messages,
SysUtils,
Variants,
Classes,
Graphics,
Controls,
Forms,
Dialogs,
Clipbrd,
mORMotUI,
mORMotUILogin,
mORMotToolbar,
SynTaskDialog,
SynCommons,
mORMot,
mORMotHttpClient,
mORMotDDD,
dddInfraApps,
dddToolsAdminDB,
dddToolsAdminLog;
type
TAdminSaveOrExport = (expSaveGrid, expCopyGrid, expCopyRow);
TAdminControl = class(TWinControl)
protected
fClient: TSQLHttpClientWebsockets;
fAdmin: IAdministratedDaemon;
fDatabases: TRawUTF8DynArray;
fPage: TSynPager;
fPages: array of TSynPage;
fLogFrame: TLogFrame;
fLogFrames: TLogFrameDynArray;
fChatPage: TSynPage;
fChatFrame: TLogFrame;
fDBFrame: TDBFrameDynArray;
fDefinition: TDDDRestClientSettings;
fDlgSave: TSaveDialog;
public
LogFrameClass: TLogFrameClass;
DBFrameClass: TDBFrameClass;
State: record
raw: TDocVariantData;
daemon: RawUTF8;
version: RawUTF8;
mem: RawUTF8;
clients: integer;
exceptions: TRawUTF8DynArray;
lasttix: Int64;
end;
SavePrefix: TFileName;
OnBeforeExecute: TOnExecute;
OnAfterExecute: TOnExecute;
OnAfterGetState: TNotifyEvent;
destructor Destroy; override;
function Open(Definition: TDDDRestClientSettings; Model: TSQLModel = nil): boolean; virtual;
procedure Show; virtual;
procedure GetState;
function AddPage(const aCaption: RawUTF8): TSynPage; virtual;
function AddDBFrame(const aCaption, aDatabaseName: RawUTF8; aClass:
TDBFrameClass): TDBFrame; virtual;
function AddLogFrame(page: TSynPage; const aCaption, aEvents, aPattern: RawUTF8;
aClass: TLogFrameClass): TLogFrame; virtual;
procedure EndLog(aLogFrame: TLogFrame); virtual;
procedure OnPageChange(Sender: TObject); virtual;
function CurrentDBFrame: TDBFrame;
function FindDBFrame(const aDatabaseName: RawUTF8): TDBFrame;
procedure FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); virtual;
procedure SaveOrExport(Fmt: TAdminSaveOrExport; const ContextName: string = '';
DB: TDBFrame = nil);
property Client: TSQLHttpClientWebsockets read fClient;
property Page: TSynPager read fPage;
property LogFrame: TLogFrame read fLogFrame;
property DBFrame: TDBFrameDynArray read fDBFrame;
property ChatPage: TSynPage read fChatPage;
property ChatFrame: TLogFrame read fChatFrame;
property Admin: IAdministratedDaemon read fAdmin;
end;
TAdminForm = class(TSynForm)
procedure FormCreate(Sender: TObject);
procedure FormShow(Sender: TObject);
protected
fFrame: TAdminControl;
public
property Frame: TAdminControl read fFrame;
end;
var
AdminForm: TAdminForm;
function AskForUserIfVoid(Definition: TDDDRestClientSettings): boolean;
implementation
{$R *.dfm}
function AskForUserIfVoid(Definition: TDDDRestClientSettings): boolean;
var
U, P: string;
begin
result := false;
if Definition.ORM.User = '' then
if TLoginForm.Login(Application.Mainform.Caption, FormatString(
'Credentials for %', [Definition.ORM.ServerName]), U, P, true, '') then begin
Definition.ORM.User := StringToUTF8(U);
Definition.ORM.PasswordPlain := StringToUTF8(P);
end
else
exit;
result := true;
end;
var
AdminControlConnecting: TForm; // only one Open() attempt at once
function TAdminControl.Open(Definition: TDDDRestClientSettings; Model: TSQLModel): boolean;
begin
result := false;
if Assigned(fAdmin) or (Definition.Orm.User = '') or Assigned(AdminControlConnecting) then
exit;
try
AdminControlConnecting := CreateTempForm('Connecting to ' + string(Definition.ORM.ServerName));
try
Application.ProcessMessages;
if Model = nil then
Model := TSQLModel.Create([], '');
Model.OnClientIdle := TLoginForm.OnIdleProcess; // allow basic UI interactivity
fClient := AdministratedDaemonClient(Definition, Model);
if not fClient.Services.Resolve(IAdministratedDaemon, fAdmin) then
raise EDDDRestClient.CreateUTF8('Resolve(IAdministratedDaemon)=false: check % version',
[Definition.ORM.ServerName]);
GetState;
fDefinition := Definition;
result := true;
finally
FreeAndNil(AdminControlConnecting);
if fClient <> nil then
fClient.OnIdle := nil; // back to default blocking behavior (safer UI)
end;
except
on E: Exception do begin
ShowException(E);
FreeAndNil(fClient);
end;
end;
end;
procedure TAdminControl.GetState;
var
exec: TServiceCustomAnswer;
begin
if self = nil then
exit;
try
if fAdmin <> nil then begin
State.raw.Clear;
exec := fAdmin.DatabaseExecute('', '#info');
if (exec.Content = '') or (exec.Content[1] <> '{') then
exec := fAdmin.DatabaseExecute('', '#state'); // backward compatibility
State.raw.InitJSONInPlace(pointer(exec.Content), JSON_OPTIONS_FAST);
State.raw.GetAsRawUTF8('daemon', State.daemon);
if not State.raw.GetAsRawUTF8('version', State.version) then
State.version := fClient.SessionVersion;
State.mem := State.raw.U['memused'];
if State.mem = '' then
KBU(state.Raw.O['SystemMemory'].O['Allocated'].I['Used'] shl 10, State.mem);
State.clients := State.raw.I['clients'];
State.raw.GetAsDocVariantSafe('exception')^.ToRawUTF8DynArray(State.exceptions);
State.raw.AddValue('remoteip', fClient.Server + ':' + fClient.Port);
State.lasttix := GetTickCount64;
end;
if Assigned(OnAfterGetState) then
OnAfterGetState(self);
except
Finalize(State);
end;
end;
procedure TAdminControl.Show;
var
i, n: integer;
f: TDBFrame;
begin
if (fClient = nil) or (fAdmin = nil) or (fPage <> nil) then
exit; // show again after hide
if LogFrameClass = nil then
LogFrameClass := TLogFrame;
if DBFrameClass = nil then
DBFrameClass := TDBFrame;
fDatabases := fAdmin.DatabaseList;
fPage := TSynPager.Create(self);
fPage.ControlStyle := fPage.ControlStyle + [csClickEvents]; // enable OnDblClick
fPage.Parent := self;
fPage.Align := alClient;
fPage.OnChange := OnPageChange;
n := length(fDatabases);
fLogFrame := AddLogFrame(nil, 'log', '', '', LogFrameClass);
if n > 0 then begin
for i := 0 to n - 1 do begin
f := AddDBFrame(fDatabases[i], fDatabases[i], DBFrameClass);
f.Open;
if i = 0 then begin
fPage.ActivePageIndex := 1;
f.SetResult(State.raw.ToJSON('', '', jsonUnquotedPropName));
end;
end;
Application.ProcessMessages;
fDBFrame[0].mmoSQL.SetFocus;
end;
fChatPage := AddPage('Chat');
fChatPage.TabVisible := false;
end;
procedure TAdminControl.EndLog(aLogFrame: TLogFrame);
begin
if aLogFrame <> nil then
try
Screen.Cursor := crHourGlass;
if aLogFrame.Callback <> nil then begin
fClient.Services.CallBackUnRegister(aLogFrame.Callback);
aLogFrame.Callback := nil;
Sleep(10);
end;
aLogFrame.Closing;
finally
Screen.Cursor := crDefault;
end;
end;
destructor TAdminControl.Destroy;
var
i: integer;
begin
if fClient <> nil then
fClient.OnIdle := TLoginForm.OnIdleProcess; // allow basic UI interactivity
for i := 0 to high(fLogFrames) do begin
EndLog(fLogFrames[i]);
fLogFrames[i].Admin := nil;
fLogFrames[i] := nil;
end;
Finalize(fLogFrames);
for i := 0 to high(fDBFrame) do
fDBFrame[i].Admin := nil;
fDBFrame := nil;
fAdmin := nil;
fDefinition.Free;
if fClient <> nil then begin
for i := 1 to 5 do begin
Sleep(50); // leave some time to flush all pending CallBackUnRegister()
Application.ProcessMessages;
end;
FreeAndNil(fClient);
end;
inherited Destroy;
end;
procedure TAdminControl.FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
procedure LogKeys(aLogFrame: TLogFrame);
var ch: char;
begin
if aLogFrame <> nil then
case Key of
VK_F3:
if Shift = [] then
aLogFrame.btnSearchNextClick(aLogFrame.btnSearchNext)
else
aLogFrame.btnSearchNextClick(aLogFrame.btnSearchPrevious);
ord('A')..ord('Z'), ord('0')..ord('9'), 32:
if (Shift = []) and (aLogFrame.ClassType <> TLogFrameChat) and not
aLogFrame.edtSearch.Focused then begin
ch := Char(Key);
if (Key in [ord('A')..ord('Z')]) and (GetKeyState(VK_CAPITAL) and 1=0) then
inc(ch,32); // emulate capslock behavior
aLogFrame.edtSearch.Text := aLogFrame.edtSearch.Text + string(ch);
end
else if (key = ord('F')) and (ssCtrl in Shift) then begin
aLogFrame.edtSearch.SelectAll;
aLogFrame.edtSearch.SetFocus;
end;
end;
end;
var
page: TControl;
ndx: integer;
begin
page := fPage.ActivePage;
if page = nil then
exit;
ndx := page.Tag;
if ndx > 0 then begin
ndx := ndx - 1; // see AddDBFrame()
if cardinal(ndx) < cardinal(length(fDBFrame)) then
with fDBFrame[ndx] do
case Key of
VK_F5:
btnCmdClick(btnCmd);
VK_F9:
btnExecClick(btnExec);
ord('A'):
if ssCtrl in Shift then begin
mmoSQL.SelectAll;
mmoSQL.SetFocus;
end;
ord('H'):
if ssCtrl in Shift then
btnHistoryClick(btnHistory);
end
end
else if ndx < 0 then begin
ndx := -(ndx + 1); // see AddLogFrame()
if cardinal(ndx) < cardinal(length(fLogFrames)) then
LogKeys(fLogFrames[ndx]);
end;
end;
function TAdminControl.AddPage(const aCaption: RawUTF8): TSynPage;
var
n: integer;
begin
n := length(fPages);
SetLength(fPages, n + 1);
result := TSynPage.Create(self);
result.Caption := UTF8ToString(aCaption);
result.PageControl := fPage;
fPages[n] := result;
end;
function TAdminControl.AddDBFrame(const aCaption, aDatabaseName: RawUTF8;
aClass: TDBFrameClass): TDBFrame;
var
page: TSynPage;
n: integer;
begin
page := AddPage(aCaption);
n := length(fDBFrame);
SetLength(fDBFrame, n + 1);
result := aClass.Create(self);
result.Name := FormatString('DBFrame%', [aCaption]);
result.Parent := page;
result.Align := alClient;
result.Client := fClient;
result.Admin := fAdmin;
result.DatabaseName := aDatabaseName;
result.OnBeforeExecute := OnBeforeExecute;
result.OnAfterExecute := OnAfterExecute;
result.SavePrefix := SavePrefix;
fDBFrame[n] := result;
page.Tag := n + 1; // Tag>0 -> index in fDBFrame[Tag-1] -> used in FormKeyDown
end;
function TAdminControl.AddLogFrame(page: TSynPage; const aCaption, aEvents,
aPattern: RawUTF8; aClass: TLogFrameClass): TLogFrame;
var
n: integer;
begin
if page = nil then begin
page := AddPage(aCaption);
fPage.ActivePageIndex := fPage.PageCount - 1;
end;
if aEvents = '' then
result := aClass.Create(self, fAdmin)
else
result := aClass.CreateCustom(self, fAdmin, aEvents, aPattern);
result.Parent := page;
result.Align := alClient;
n := length(fLogFrames);
SetLength(fLogFrames, n + 1);
fLogFrames[n] := result;
page.Tag := -(n + 1); // Tag<0 -> index in fLogFrames[-(Tag+1)] -> used in FormKeyDown
end;
procedure TAdminControl.OnPageChange(Sender: TObject);
var
ndx: cardinal;
begin
if fPage.ActivePage = fChatPage then begin
if fChatFrame = nil then
fChatFrame := AddLogFrame(fChatPage, '', 'Monitoring', '[CHAT] ', TLogFrameChat);
exit;
end;
ndx := fPage.ActivePageIndex - 1;
if ndx >= cardinal(Length(fDBFrame)) then
exit;
end;
function TAdminControl.CurrentDBFrame: TDBFrame;
var
ndx: cardinal;
begin
ndx := fPage.ActivePageIndex - 1;
if ndx >= cardinal(Length(fDBFrame)) then
result := nil
else
result := fDBFrame[ndx];
end;
function TAdminControl.FindDBFrame(const aDatabaseName: RawUTF8): TDBFrame;
var
i: Integer;
begin
for i := 0 to high(fDBFrame) do
if IdemPropNameU(fDBFrame[i].DatabaseName, aDatabaseName) then begin
result := fDBFrame[i];
exit;
end;
result := nil;
end;
procedure TAdminControl.SaveOrExport(Fmt: TAdminSaveOrExport;
const ContextName: string; DB: TDBFrame);
var
grid: TSQLTable;
row: integer;
name, table: RawUTF8;
begin
if DB = nil then
DB := CurrentDBFrame;
if DB = nil then
exit;
grid := DB.Grid.Table;
if (grid = nil) or (grid.RowCount = 0) then
exit;
if Fmt = expSaveGrid then begin
if fDlgSave = nil then begin
fDlgSave := TSaveDialog.Create(Owner);
fDlgSave.Options := [ofOverwritePrompt, ofHideReadOnly, ofPathMustExist,
ofEnableSizing];
fDlgSave.Filter :=
'JSON (human readable)|*.json|JSON (small)|*.json|CSV (text)|*.txt|Excel/Office (.ods)|*.ods|HTML|*.html';
fDlgSave.DefaultExt := '.html';
fDlgSave.FilterIndex := 5;
fDlgSave.InitialDir := GetShellFolderPath(CSIDL_DOCUMENTS);
end;
if PropNameValid(pointer(db.GridLastTableName)) then
name := db.GridLastTableName;
fDlgSave.FileName := SysUtils.Trim(FormatString('% % %',
[ContextName, name, NowToString(false)]));
if not fDlgSave.Execute then
exit;
case fDlgSave.FilterIndex of
1:
JSONBufferReformat(pointer(grid.GetJSONValues(true)), table);
2:
table := grid.GetJSONValues(true);
3:
table := grid.GetCSVValues(true);
4:
table := grid.GetODSDocument;
5:
table := grid.GetHtmlTable;
end;
if table <> '' then
FileFromString(table, fDlgSave.FileName);
end
else begin
case Fmt of
expCopyGrid:
table := grid.GetCSVValues(true);
expCopyRow:
begin
row := db.drwgrdResult.Row;
if row < 0 then
exit;
table := grid.GetCSVValues(true, ',', false, row, row);
end;
end;
if table <> '' then
Clipboard.AsText := UTF8ToString(table);
end;
end;
{ TAdminForm }
procedure TAdminForm.FormCreate(Sender: TObject);
begin
DefaultFont.Name := 'Tahoma';
DefaultFont.Size := 9;
Caption := FormatString('% %', [ExeVersion.ProgramName, ExeVersion.Version.Detailed]);
fFrame := TAdminControl.Create(self);
fFrame.Parent := self;
fFrame.Align := alClient;
OnKeyDown := fFrame.FormKeyDown;
end;
procedure TAdminForm.FormShow(Sender: TObject);
begin
fFrame.Show;
Caption := FormatString('% - % % via %', [ExeVersion.ProgramName,
fFrame.State.daemon, fFrame.State.version, fFrame.fDefinition.ORM.ServerName]);
end;
end.