source upload
This commit is contained in:
Razor12911
@@ -0,0 +1,48 @@
|
||||
// JCL_DEBUG_EXPERT_GENERATEJDBG OFF
|
||||
// JCL_DEBUG_EXPERT_DELETEMAPFILE ON
|
||||
// JCL_DEBUG_EXPERT_INSERTJDBG OFF
|
||||
|
||||
program Project1;
|
||||
|
||||
{$I Synopse.inc} // define HASINLINE CPU32 CPU64 OWNNORMTOUPPER
|
||||
|
||||
// first line of uses clause must be {$I SynDprUses.inc}
|
||||
uses
|
||||
{$I SynDprUses.inc}
|
||||
Forms,
|
||||
Controls,
|
||||
Unit1 in 'Unit1.pas' {Form1},
|
||||
uCustomer in 'uCustomer.pas',
|
||||
uQueryHistory in 'uQueryHistory.pas',
|
||||
uLoginForm in 'uLoginForm.pas' {LoginForm};
|
||||
|
||||
const
|
||||
AppName = 'Synopse mORMot Demo';
|
||||
|
||||
{$R *.res}
|
||||
begin
|
||||
Application.Initialize;
|
||||
// init the database client
|
||||
InitClient();
|
||||
LoginForm:= TLoginForm.Create(Application);
|
||||
|
||||
// when no users defined, just let in ...
|
||||
if globalClient.TableRowCount(TSQLUser) <= 0 then
|
||||
begin
|
||||
TSQLUserRole.CreateStandardRoles(globalClient);
|
||||
LoginForm.LoginOk:= true
|
||||
end
|
||||
else
|
||||
begin
|
||||
LoginForm.Caption:= AppName + ' - ' + LoginForm.Caption;
|
||||
LoginForm.ShowModal;
|
||||
end;
|
||||
|
||||
if LoginForm.LoginOk then
|
||||
begin
|
||||
Application.CreateForm(TForm1, Form1);
|
||||
Form1.Caption:= AppName;
|
||||
Form1.Label4.Caption:= AppName;
|
||||
end;
|
||||
Application.Run;
|
||||
end.
|
||||
Binary file not shown.
@@ -0,0 +1,29 @@
|
||||
# Scope
|
||||
|
||||
The amazing Synopse *mORMot* Framework is a powerful piece of code, but it's missing examples. Thus I found it a good idea to write my own demo, and allow others to improve it.
|
||||
|
||||
# Presentation
|
||||
|
||||
I decided to build a very trivial yet closer to real life demo of the *mORmot* Framework.
|
||||
|
||||
The main reason behind this decision was to learn the Framework a bit smile
|
||||
|
||||
Currently the application is just a list of Customers with Tasks assigned to them (the relation type is "HAS MANY AND BELONGS TO MANY"). In my case, TCustomer publishes TTasks list.
|
||||
|
||||
I've also decided to share the code in hope that if anybody knows the better way for solving any of the "tasks", he might edit & share.
|
||||
|
||||
# Source Code Repository
|
||||
|
||||
The original code is available at http://code.google.com/p/synopse-sqlite-demo/
|
||||
|
||||
*AB note*: I've enhanced the code to compile and work with the 1.18 revision of the framework. Also made it Delphi 2010+ friendly.
|
||||
|
||||
# Forum Thread
|
||||
|
||||
See http://synopse.info/forum/viewtopic.php?id=164
|
||||
|
||||
|
||||
**enjoy!**
|
||||
|
||||
Michal *migajek* Gajek
|
||||
http://migajek.com migajek@gmail.com
|
||||
@@ -0,0 +1,311 @@
|
||||
object Form1: TForm1
|
||||
Left = 192
|
||||
Top = 107
|
||||
AutoSize = True
|
||||
BorderIcons = [biSystemMenu, biMinimize]
|
||||
BorderStyle = bsSingle
|
||||
Caption = 'Form1'
|
||||
ClientHeight = 329
|
||||
ClientWidth = 529
|
||||
Color = clBtnFace
|
||||
Font.Charset = DEFAULT_CHARSET
|
||||
Font.Color = clWindowText
|
||||
Font.Height = -11
|
||||
Font.Name = 'MS Sans Serif'
|
||||
Font.Style = []
|
||||
OldCreateOrder = False
|
||||
OnCreate = FormCreate
|
||||
PixelsPerInch = 96
|
||||
TextHeight = 13
|
||||
object PageControl1: TPageControl
|
||||
Left = 0
|
||||
Top = 0
|
||||
Width = 529
|
||||
Height = 329
|
||||
ActivePage = TabSheet1
|
||||
TabOrder = 0
|
||||
OnChange = PageControl1Change
|
||||
object TabSheet1: TTabSheet
|
||||
Caption = 'Customers'
|
||||
object Label8: TLabel
|
||||
Left = 8
|
||||
Top = 8
|
||||
Width = 161
|
||||
Height = 13
|
||||
Caption = 'This is a list of customers we have'
|
||||
end
|
||||
object lbCustomers: TListBox
|
||||
Left = 8
|
||||
Top = 24
|
||||
Width = 241
|
||||
Height = 265
|
||||
ItemHeight = 13
|
||||
TabOrder = 0
|
||||
OnClick = lbCustomersClick
|
||||
end
|
||||
object GroupBox1: TGroupBox
|
||||
Left = 256
|
||||
Top = 24
|
||||
Width = 249
|
||||
Height = 233
|
||||
Caption = 'Details'
|
||||
TabOrder = 1
|
||||
object Label1: TLabel
|
||||
Left = 16
|
||||
Top = 16
|
||||
Width = 31
|
||||
Height = 13
|
||||
Caption = 'Name:'
|
||||
end
|
||||
object Label2: TLabel
|
||||
Left = 16
|
||||
Top = 32
|
||||
Width = 45
|
||||
Height = 13
|
||||
Caption = 'Surname:'
|
||||
end
|
||||
object lblName: TLabel
|
||||
Left = 80
|
||||
Top = 16
|
||||
Width = 3
|
||||
Height = 13
|
||||
end
|
||||
object lblSurname: TLabel
|
||||
Left = 80
|
||||
Top = 32
|
||||
Width = 3
|
||||
Height = 13
|
||||
end
|
||||
object Label3: TLabel
|
||||
Left = 16
|
||||
Top = 64
|
||||
Width = 32
|
||||
Height = 13
|
||||
Caption = 'Tasks:'
|
||||
end
|
||||
object lbCustomerTasks: TListBox
|
||||
Left = 16
|
||||
Top = 80
|
||||
Width = 217
|
||||
Height = 137
|
||||
ItemHeight = 13
|
||||
TabOrder = 0
|
||||
end
|
||||
end
|
||||
object btnAddCustomer: TButton
|
||||
Left = 256
|
||||
Top = 264
|
||||
Width = 75
|
||||
Height = 25
|
||||
Caption = 'Add'
|
||||
TabOrder = 2
|
||||
OnClick = btnAddCustomerClick
|
||||
end
|
||||
end
|
||||
object TabSheet2: TTabSheet
|
||||
Caption = 'Tasks'
|
||||
ImageIndex = 1
|
||||
object lbTasks: TListBox
|
||||
Left = 8
|
||||
Top = 32
|
||||
Width = 241
|
||||
Height = 257
|
||||
ItemHeight = 13
|
||||
TabOrder = 0
|
||||
OnClick = lbTasksClick
|
||||
end
|
||||
object btnNewTask: TButton
|
||||
Left = 256
|
||||
Top = 264
|
||||
Width = 75
|
||||
Height = 25
|
||||
Caption = 'New Task'
|
||||
TabOrder = 1
|
||||
OnClick = btnNewTaskClick
|
||||
end
|
||||
object cbCustomers: TComboBox
|
||||
Left = 8
|
||||
Top = 8
|
||||
Width = 241
|
||||
Height = 21
|
||||
Style = csDropDownList
|
||||
ItemHeight = 0
|
||||
TabOrder = 2
|
||||
OnClick = cbCustomersClick
|
||||
end
|
||||
object gbEditTask: TGroupBox
|
||||
Left = 256
|
||||
Top = 8
|
||||
Width = 241
|
||||
Height = 249
|
||||
Caption = 'Edit task'
|
||||
TabOrder = 3
|
||||
Visible = False
|
||||
object cbTaskPriority: TComboBox
|
||||
Left = 16
|
||||
Top = 24
|
||||
Width = 209
|
||||
Height = 21
|
||||
Style = csDropDownList
|
||||
ItemHeight = 13
|
||||
TabOrder = 0
|
||||
OnChange = cbTaskPriorityChange
|
||||
Items.Strings = (
|
||||
'Low'
|
||||
'Normal'
|
||||
'High')
|
||||
end
|
||||
object CheckListBox1: TCheckListBox
|
||||
Left = 16
|
||||
Top = 72
|
||||
Width = 209
|
||||
Height = 161
|
||||
OnClickCheck = CheckListBox1ClickCheck
|
||||
ItemHeight = 13
|
||||
TabOrder = 1
|
||||
end
|
||||
end
|
||||
end
|
||||
object TabSheet4: TTabSheet
|
||||
Caption = 'SQL'
|
||||
ImageIndex = 3
|
||||
object dgTable: TDrawGrid
|
||||
Left = 8
|
||||
Top = 32
|
||||
Width = 505
|
||||
Height = 265
|
||||
ColCount = 1
|
||||
FixedCols = 0
|
||||
RowCount = 1
|
||||
FixedRows = 0
|
||||
TabOrder = 0
|
||||
end
|
||||
object edtQuery: TComboBox
|
||||
Left = 8
|
||||
Top = 8
|
||||
Width = 505
|
||||
Height = 21
|
||||
ItemHeight = 0
|
||||
TabOrder = 1
|
||||
OnKeyDown = edtQueryKeyDown
|
||||
end
|
||||
end
|
||||
object tbUsers: TTabSheet
|
||||
Caption = 'Users'
|
||||
ImageIndex = 4
|
||||
object lbUsers: TListBox
|
||||
Left = 8
|
||||
Top = 16
|
||||
Width = 241
|
||||
Height = 273
|
||||
ItemHeight = 13
|
||||
TabOrder = 0
|
||||
OnClick = lbUsersClick
|
||||
end
|
||||
object GroupBox2: TGroupBox
|
||||
Left = 264
|
||||
Top = 16
|
||||
Width = 241
|
||||
Height = 129
|
||||
Caption = 'Roles'
|
||||
TabOrder = 1
|
||||
object Label9: TLabel
|
||||
Left = 16
|
||||
Top = 100
|
||||
Width = 45
|
||||
Height = 13
|
||||
Caption = 'Valid until'
|
||||
end
|
||||
object clbRoles: TCheckListBox
|
||||
Left = 16
|
||||
Top = 24
|
||||
Width = 209
|
||||
Height = 65
|
||||
OnClickCheck = clbRolesClickCheck
|
||||
Enabled = False
|
||||
ItemHeight = 13
|
||||
TabOrder = 0
|
||||
OnClick = clbRolesClick
|
||||
end
|
||||
object dtRoleExpires: TDateTimePicker
|
||||
Left = 112
|
||||
Top = 96
|
||||
Width = 113
|
||||
Height = 21
|
||||
Date = 40514.921962129630000000
|
||||
Time = 40514.921962129630000000
|
||||
TabOrder = 1
|
||||
OnChange = dtRoleExpiresChange
|
||||
end
|
||||
end
|
||||
object btnAddUser: TButton
|
||||
Left = 256
|
||||
Top = 264
|
||||
Width = 75
|
||||
Height = 25
|
||||
Caption = 'Add User'
|
||||
TabOrder = 2
|
||||
OnClick = btnAddUserClick
|
||||
end
|
||||
end
|
||||
object TabSheet3: TTabSheet
|
||||
Caption = 'About'
|
||||
ImageIndex = 2
|
||||
DesignSize = (
|
||||
521
|
||||
301)
|
||||
object Label4: TLabel
|
||||
Left = 8
|
||||
Top = 8
|
||||
Width = 21
|
||||
Height = 13
|
||||
Caption = '****'
|
||||
Font.Charset = DEFAULT_CHARSET
|
||||
Font.Color = clWindowText
|
||||
Font.Height = -11
|
||||
Font.Name = 'MS Sans Serif'
|
||||
Font.Style = [fsBold]
|
||||
ParentFont = False
|
||||
end
|
||||
object Label5: TLabel
|
||||
Left = 16
|
||||
Top = 32
|
||||
Width = 489
|
||||
Height = 65
|
||||
AutoSize = False
|
||||
Caption =
|
||||
'I hope this example is closer to '#39'real-life'#39' cases than the demo' +
|
||||
's provided with the Framework itself. '#13#10'If you improve that exam' +
|
||||
'ple in any way, or know the better way for solving any of the pr' +
|
||||
'oblems, please share it!'
|
||||
WordWrap = True
|
||||
end
|
||||
object Label6: TLabel
|
||||
Left = 8
|
||||
Top = 248
|
||||
Width = 156
|
||||
Height = 39
|
||||
Anchors = [akLeft, akBottom]
|
||||
Caption =
|
||||
'Written by Michal '#39'migajek'#39' Gajek'#13#10'migajek@gmail.com'#13#10'http://mig' +
|
||||
'ajek.com/'
|
||||
end
|
||||
object Label7: TLabel
|
||||
Left = 288
|
||||
Top = 272
|
||||
Width = 229
|
||||
Height = 13
|
||||
Cursor = crHandPoint
|
||||
Anchors = [akRight]
|
||||
Caption = 'http://code.google.com/p/synopse-sqlite-demo/'
|
||||
Font.Charset = DEFAULT_CHARSET
|
||||
Font.Color = clBlue
|
||||
Font.Height = -11
|
||||
Font.Name = 'MS Sans Serif'
|
||||
Font.Style = [fsUnderline]
|
||||
ParentFont = False
|
||||
OnClick = Label7Click
|
||||
end
|
||||
end
|
||||
end
|
||||
end
|
||||
@@ -0,0 +1,611 @@
|
||||
(*
|
||||
Simple Almost-Real-Life example of the Synopse mORMot Framework.
|
||||
Written by Michal Gajek, http://migajek.com/
|
||||
|
||||
The demo doesn't depend on any 3rd party libraries nor components.
|
||||
|
||||
ToDO:
|
||||
[ ] in each ListBox / ComboBox "Object", instead of ID, keep RecordRef ?
|
||||
*)
|
||||
|
||||
unit Unit1;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
|
||||
Dialogs, ComCtrls, StdCtrls, CheckLst, Grids,
|
||||
|
||||
SynCommons, mORMotUI, mORMot,
|
||||
SynSQLite3Static,
|
||||
|
||||
uCustomer;
|
||||
|
||||
type
|
||||
TForm1 = class(TForm)
|
||||
PageControl1: TPageControl;
|
||||
TabSheet1: TTabSheet;
|
||||
TabSheet2: TTabSheet;
|
||||
lbCustomers: TListBox;
|
||||
GroupBox1: TGroupBox;
|
||||
Label1: TLabel;
|
||||
Label2: TLabel;
|
||||
lblName: TLabel;
|
||||
lblSurname: TLabel;
|
||||
btnAddCustomer: TButton;
|
||||
lbTasks: TListBox;
|
||||
btnNewTask: TButton;
|
||||
cbCustomers: TComboBox;
|
||||
lbCustomerTasks: TListBox;
|
||||
Label3: TLabel;
|
||||
gbEditTask: TGroupBox;
|
||||
cbTaskPriority: TComboBox;
|
||||
CheckListBox1: TCheckListBox;
|
||||
TabSheet3: TTabSheet;
|
||||
Label4: TLabel;
|
||||
Label5: TLabel;
|
||||
Label6: TLabel;
|
||||
Label7: TLabel;
|
||||
TabSheet4: TTabSheet;
|
||||
dgTable: TDrawGrid;
|
||||
edtQuery: TComboBox;
|
||||
tbUsers: TTabSheet;
|
||||
Label8: TLabel;
|
||||
lbUsers: TListBox;
|
||||
GroupBox2: TGroupBox;
|
||||
clbRoles: TCheckListBox;
|
||||
btnAddUser: TButton;
|
||||
dtRoleExpires: TDateTimePicker;
|
||||
Label9: TLabel;
|
||||
procedure FormCreate(Sender: TObject);
|
||||
procedure btnAddCustomerClick(Sender: TObject);
|
||||
procedure lbCustomersClick(Sender: TObject);
|
||||
procedure btnNewTaskClick(Sender: TObject);
|
||||
procedure cbCustomersClick(Sender: TObject);
|
||||
procedure lbTasksClick(Sender: TObject);
|
||||
procedure cbTaskPriorityChange(Sender: TObject);
|
||||
procedure CheckListBox1ClickCheck(Sender: TObject);
|
||||
procedure Label7Click(Sender: TObject);
|
||||
procedure edtQueryKeyDown(Sender: TObject; var Key: Word;
|
||||
Shift: TShiftState);
|
||||
procedure btnAddUserClick(Sender: TObject);
|
||||
procedure lbUsersClick(Sender: TObject);
|
||||
procedure clbRolesClickCheck(Sender: TObject);
|
||||
procedure clbRolesClick(Sender: TObject);
|
||||
procedure dtRoleExpiresChange(Sender: TObject);
|
||||
procedure PageControl1Change(Sender: TObject);
|
||||
private
|
||||
{ Private declarations }
|
||||
function LoadCustomer(const ACustomerID: integer): TSQLCustomer;
|
||||
procedure DisplayCustomerInfo(const ACustomer: TSQLCustomer); overload;
|
||||
procedure DisplayCustomerInfo(const ACustomerID: integer); overload;
|
||||
procedure FillCustomersList(const AList: TStrings; const AClear: boolean = true);
|
||||
|
||||
function LoadTask(const ATaskID: integer): TSQLTask;
|
||||
procedure FillTasksList(const AList: TStrings; ATasks: TSQLTask);
|
||||
procedure LoadTasksForCustomer(const ACustomer: TSQLCustomer; const AList: TStrings);
|
||||
|
||||
procedure LoadQueryHistory();
|
||||
|
||||
procedure FillRolesList(const AList: TStrings);
|
||||
procedure FillUsersList(const AList: TStrings; const AClear: boolean = true);
|
||||
public
|
||||
{ Public declarations }
|
||||
end;
|
||||
|
||||
var
|
||||
Form1: TForm1;
|
||||
|
||||
implementation
|
||||
|
||||
uses ShellApi, DateUtils, uQueryHistory, Math;
|
||||
|
||||
{$R *.dfm}
|
||||
|
||||
// loads customer data into "Details" box. Pass nil in order to clear the box.
|
||||
procedure TForm1.DisplayCustomerInfo(const ACustomer: TSQLCustomer);
|
||||
begin
|
||||
if ACustomer <> nil then
|
||||
begin
|
||||
lblName.Caption:= UTF8ToString(ACustomer.Firstname);
|
||||
lblSurname.Caption:= UTF8ToString(ACustomer.Surname);
|
||||
LoadTasksForCustomer(ACustomer, lbCustomerTasks.Items);
|
||||
end
|
||||
else
|
||||
begin
|
||||
lblName.Caption:= '';
|
||||
lblSurname.Caption:= '';
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TForm1.DisplayCustomerInfo(const ACustomerID: integer);
|
||||
var
|
||||
cust: TSQLCustomer;
|
||||
begin
|
||||
cust:= LoadCustomer(ACustomerID);
|
||||
try
|
||||
DisplayCustomerInfo(cust);
|
||||
finally
|
||||
FreeAndNil(cust);
|
||||
end;
|
||||
end;
|
||||
|
||||
function TForm1.LoadCustomer(const ACustomerID: integer): TSQLCustomer;
|
||||
begin
|
||||
result:= TSQLCustomer.Create(globalClient, ACustomerID);
|
||||
end;
|
||||
|
||||
// loads a list of customers to a AList
|
||||
procedure TForm1.FillCustomersList(const AList: TStrings; const AClear: boolean = true);
|
||||
var
|
||||
cust: TSQLCustomer;
|
||||
begin
|
||||
// load all the customers
|
||||
try
|
||||
AList.BeginUpdate();
|
||||
if AClear then
|
||||
AList.Clear();
|
||||
cust:= TSQLCustomer.CreateAndFillPrepare(globalClient, '');
|
||||
while cust.FillOne do
|
||||
AList.AddObject(Format('%s, %s', [UTF8ToString(cust.Surname), UTF8ToString(cust.Firstname)]), Pointer(cust.ID)); // we keep integer ID as "Data" object
|
||||
|
||||
finally
|
||||
AList.EndUpdate();
|
||||
FreeAndNil(cust);
|
||||
end;
|
||||
|
||||
end;
|
||||
|
||||
procedure TForm1.FillTasksList(const AList: TStrings; ATasks: TSQLTask);
|
||||
var
|
||||
freeAfter: boolean;
|
||||
begin
|
||||
freeAfter:= ATasks = nil;
|
||||
if freeAfter then
|
||||
ATasks:= TSQLTask.CreateAndFillPrepare(globalClient, '');
|
||||
|
||||
try
|
||||
AList.BeginUpdate();
|
||||
AList.Clear();
|
||||
while ATasks.FillOne do
|
||||
AList.AddObject(Format('%s', [UTF8ToString(ATasks.Text)]), Pointer(ATasks.ID));
|
||||
finally
|
||||
AList.EndUpdate();
|
||||
if freeAfter then
|
||||
FreeAndNil(ATasks);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TForm1.LoadTasksForCustomer(const ACustomer: TSQLCustomer; const AList: TStrings);
|
||||
var
|
||||
task: TSQLTask;
|
||||
fIds: TIDDynArray;
|
||||
begin
|
||||
ACustomer.Tasks.DestGet(globalClient, ACustomer.ID, fIds);
|
||||
task:= TSQLTask.CreateAndFillPrepare(globalClient, TInt64DynArray(fIds));
|
||||
AList.BeginUpdate();
|
||||
AList.Clear();
|
||||
try
|
||||
while task.FillOne do
|
||||
AList.AddObject(Format('%s', [UTF8ToString(task.Text)]), Pointer(task.id));
|
||||
finally
|
||||
AList.EndUpdate();
|
||||
FreeAndNil(task);
|
||||
end;
|
||||
end;
|
||||
|
||||
function TForm1.LoadTask(const ATaskID: integer): TSQLTask;
|
||||
begin
|
||||
result:= TSQLTask.Create(globalClient, ATaskID);
|
||||
end;
|
||||
|
||||
procedure TForm1.FormCreate(Sender: TObject);
|
||||
begin
|
||||
// clear all the fields.
|
||||
DisplayCustomerInfo(nil);
|
||||
FillCustomersList(lbCustomers.Items);
|
||||
cbCustomers.AddItem('<Any customer>', nil);
|
||||
cbCustomers.ItemIndex:= 0;
|
||||
FillCustomersList(cbCustomers.Items, false);
|
||||
cbCustomersClick(nil);
|
||||
|
||||
LoadQueryHistory();
|
||||
|
||||
FillRolesList(clbRoles.Items);
|
||||
FillUsersList(lbUsers.Items);
|
||||
|
||||
dtRoleExpires.DateTime:= IncMonth(Now(), 1);
|
||||
end;
|
||||
|
||||
procedure TForm1.btnAddCustomerClick(Sender: TObject);
|
||||
var
|
||||
cust: TSQLCustomer;
|
||||
begin
|
||||
|
||||
cust:= TSQLCustomer.Create;
|
||||
try
|
||||
cust.Firstname:= StringToUTF8(InputBox('First name', 'Customer first name', 'John'));
|
||||
cust.Surname:= StringToUTF8(InputBox('Surname', 'Customer surname', 'Doe'));
|
||||
if (cust.Firstname <> '') and (cust.Surname <> '') then
|
||||
globalClient.Add(cust, true);
|
||||
finally
|
||||
FreeAndNil(cust);
|
||||
FillCustomersList(lbCustomers.Items);
|
||||
end;
|
||||
|
||||
end;
|
||||
|
||||
procedure TForm1.lbCustomersClick(Sender: TObject);
|
||||
var
|
||||
cust: TSQLCustomer;
|
||||
begin
|
||||
if lbCustomers.ItemIndex <> -1 then
|
||||
begin
|
||||
// since we store record ID as object, now we can load it
|
||||
if lbCustomers.Items.Objects[lbCustomers.ItemIndex] <> nil then
|
||||
begin
|
||||
cust:= LoadCustomer( Integer(lbCustomers.Items.Objects[lbCustomers.ItemIndex]) );
|
||||
DisplayCustomerInfo(cust);
|
||||
FreeAndNil(cust);
|
||||
end
|
||||
end
|
||||
else
|
||||
DisplayCustomerInfo(nil);
|
||||
|
||||
end;
|
||||
|
||||
procedure TForm1.btnNewTaskClick(Sender: TObject);
|
||||
var
|
||||
task: TSQLTask;
|
||||
begin
|
||||
|
||||
task:= TSQLTask.Create();
|
||||
try
|
||||
task.Text:= StringToUTF8(InputBox('Text', 'Task description', ''));
|
||||
task.Priority:= tpNormal;
|
||||
if (task.Text <> '') then
|
||||
globalClient.Add(task, true);
|
||||
finally
|
||||
FreeAndNil(task);
|
||||
FillTasksList(lbTasks.Items, nil);
|
||||
end;
|
||||
|
||||
end;
|
||||
|
||||
procedure TForm1.cbCustomersClick(Sender: TObject);
|
||||
var
|
||||
cust: TSQLCustomer;
|
||||
begin
|
||||
gbEditTask.Visible:= false;
|
||||
if cbCustomers.ItemIndex <> -1 then
|
||||
begin
|
||||
// since we store record ID as object, now we can load it
|
||||
if cbCustomers.Items.Objects[cbCustomers.ItemIndex] <> nil then
|
||||
begin
|
||||
cust:= LoadCustomer( Integer(cbCustomers.Items.Objects[cbCustomers.ItemIndex]) );
|
||||
LoadTasksForCustomer(cust, lbTasks.Items);
|
||||
FreeAndNil(cust);
|
||||
end
|
||||
else
|
||||
FillTasksList(lbTasks.Items, nil);
|
||||
end
|
||||
else
|
||||
FillTasksList(lbTasks.Items, nil);
|
||||
end;
|
||||
|
||||
procedure TForm1.lbTasksClick(Sender: TObject);
|
||||
var
|
||||
task: TSQLTask;
|
||||
cust: TSQLCustomer;
|
||||
clientsIds: TIDDynArray;
|
||||
i, j: integer;
|
||||
begin
|
||||
gbEditTask.Visible:= lbTasks.ItemIndex <> -1;
|
||||
if not gbEditTask.Visible then
|
||||
exit;
|
||||
|
||||
gbEditTask.Visible:= lbTasks.Items.Objects[lbTasks.ItemIndex] <> nil;
|
||||
if not gbEditTask.Visible then
|
||||
exit;
|
||||
|
||||
task:= LoadTask(integer(lbTasks.Items.Objects[lbTasks.ItemIndex]));
|
||||
cbTaskPriority.ItemIndex:= Ord(task.Priority);
|
||||
cbTaskPriority.Tag:= task.ID;
|
||||
|
||||
FillCustomersList(CheckListBox1.Items, true);
|
||||
CheckListBox1.Tag:= task.ID;
|
||||
// load list of customers assigned to the given task
|
||||
cust:= TSQLCustomer.Create();
|
||||
try
|
||||
cust.Tasks.SourceGet(globalClient, task.ID, clientsIds);
|
||||
for i:= low(clientsIds) to high(clientsIds) do
|
||||
begin
|
||||
|
||||
// find the client on the list (by ID)
|
||||
for j:= 0 to CheckListBox1.Count -1 do
|
||||
if Integer(CheckListBox1.Items.Objects[j]) = clientsIds[i] then
|
||||
CheckListBox1.Checked[j]:= true;
|
||||
end;
|
||||
finally
|
||||
cust.Free();
|
||||
FreeAndNil(task);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TForm1.cbTaskPriorityChange(Sender: TObject);
|
||||
var
|
||||
task: TSQLTask;
|
||||
begin
|
||||
if cbTaskPriority.Tag > 0 then
|
||||
begin
|
||||
task:= LoadTask(cbTaskPriority.Tag);
|
||||
if task <> nil then
|
||||
begin
|
||||
task.Priority:= TSQLTaskPriority(cbTaskPriority.ItemIndex);
|
||||
globalClient.Update(task);
|
||||
task.Free;
|
||||
end;
|
||||
end
|
||||
end;
|
||||
|
||||
procedure TForm1.CheckListBox1ClickCheck(Sender: TObject);
|
||||
var
|
||||
task: TSQLTask;
|
||||
cust: TSQLCustomer;
|
||||
begin
|
||||
// first, load the Task based on ID (stored in TAG property)
|
||||
if (sender as TComponent).Tag > 0 then
|
||||
begin
|
||||
task:= LoadTask((sender as TComponent).Tag);
|
||||
if task <> nil then
|
||||
begin
|
||||
|
||||
// now load the customer from the list
|
||||
if CheckListBox1.ItemIndex > - 1 then
|
||||
begin
|
||||
cust:= LoadCustomer(Integer(CheckListBox1.Items.Objects[CheckListBox1.ItemIndex]));
|
||||
if cust <> nil then
|
||||
begin
|
||||
if CheckListBox1.Checked[CheckListBox1.ItemIndex] then
|
||||
cust.Tasks.ManyAdd(globalClient, cust.ID, task.ID, true)
|
||||
else
|
||||
cust.Tasks.ManyDelete(globalClient, cust.ID, task.ID);
|
||||
|
||||
FreeAndNil(cust);
|
||||
end;
|
||||
end;
|
||||
FreeAndNil(task);
|
||||
end;
|
||||
end
|
||||
|
||||
end;
|
||||
|
||||
procedure TForm1.Label7Click(Sender: TObject);
|
||||
begin
|
||||
ShellExecute(0, 'open', 'http://code.google.com/p/synopse-sqlite-demo/', '', '', SW_SHOWNORMAL);
|
||||
end;
|
||||
|
||||
procedure TForm1.edtQueryKeyDown(Sender: TObject; var Key: Word;
|
||||
Shift: TShiftState);
|
||||
var
|
||||
data: TSQLTable;
|
||||
hist: TSQLQueryHistory;
|
||||
begin
|
||||
if Key = VK_RETURN then
|
||||
begin
|
||||
Key:= 0;
|
||||
|
||||
// we don't have to worry for freeing the data nor the "previously" created instance of TSQLTableToGrid
|
||||
// as the Framework takes care of everything.
|
||||
data:= globalClient.ExecuteList([], StringToUTF8(edtQuery.Text));
|
||||
TSQLTableToGrid.Create(dgTable, data, globalClient);
|
||||
|
||||
hist:= TSQLQueryHistory.Create(globalClient, 'SQL = ?', [edtQuery.Text]);
|
||||
try
|
||||
if hist.ID = 0 then
|
||||
hist.SQL:= StringToUTF8(edtQuery.Text);
|
||||
hist.LastUsed:= Now();
|
||||
if hist.ID > 0 then
|
||||
globalClient.Update(hist)
|
||||
else
|
||||
globalClient.Add(hist, true);
|
||||
finally
|
||||
FreeAndNil(hist);
|
||||
LoadQueryHistory();
|
||||
end;
|
||||
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TForm1.LoadQueryHistory();
|
||||
var
|
||||
hist: TSQLQueryHistory;
|
||||
begin
|
||||
hist:= TSQLQueryHistory.Create();
|
||||
edtQuery.Items.BeginUpdate();
|
||||
edtQuery.Items.Clear();
|
||||
try
|
||||
hist.FillHistory();
|
||||
while hist.FillOne do
|
||||
edtQuery.AddItem(UTF8ToString(hist.SQL), nil);
|
||||
finally
|
||||
edtQuery.Items.EndUpdate();
|
||||
FreeAndNil(hist);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TForm1.FillRolesList(const AList: TStrings);
|
||||
var
|
||||
role: TSQLUserRole;
|
||||
begin
|
||||
role:= TSQLUserRole.CreateAndFillPrepare(globalClient, '');
|
||||
AList.BeginUpdate();
|
||||
AList.Clear();
|
||||
try
|
||||
while role.FillOne do
|
||||
AList.AddObject(UTF8ToString(role.RoleName), Pointer(role.id));
|
||||
finally
|
||||
FreeAndNil(role);
|
||||
AList.EndUpdate();
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TForm1.FillUsersList(const AList: TStrings; const AClear: boolean = true);
|
||||
var
|
||||
user: TSQLUser;
|
||||
begin
|
||||
// load all the customers
|
||||
try
|
||||
AList.BeginUpdate();
|
||||
if AClear then
|
||||
AList.Clear();
|
||||
user:= TSQLUser.CreateAndFillPrepare(globalClient, '');
|
||||
while user.FillOne do
|
||||
AList.AddObject(Format('%s (%s, %s)', [UTF8ToString(user.login), UTF8ToString(user.Surname), UTF8ToString(user.Firstname)]), Pointer(user.ID)); // we keep integer ID as "Data" object
|
||||
|
||||
finally
|
||||
AList.EndUpdate();
|
||||
FreeAndNil(user);
|
||||
end;
|
||||
|
||||
end;
|
||||
|
||||
|
||||
procedure TForm1.btnAddUserClick(Sender: TObject);
|
||||
var
|
||||
user: TSQLUser;
|
||||
begin
|
||||
|
||||
user:= TSQLUser.Create;
|
||||
try
|
||||
user.Firstname:= StringToUTF8( InputBox('First name', 'User first name', '') );
|
||||
user.Surname:= StringToUTF8( InputBox('Surname', 'User surname', '') );
|
||||
user.Login:= StringToUTF8( InputBox('Login', 'User login', '') );
|
||||
user.Password:= StringToUTF8( InputBox('Password', 'User password', '') );
|
||||
if (user.Firstname <> '') and (user.Surname <> '') and (user.Password <> '') and (user.Login <> '') then
|
||||
globalClient.Add(user, true)
|
||||
else
|
||||
MessageBox(handle, 'None of the data can be empty!', 'Wrong', MB_ICONEXCLAMATION);
|
||||
finally
|
||||
FreeAndNil(user);
|
||||
FillUsersList(lbUsers.Items);
|
||||
end;
|
||||
|
||||
|
||||
end;
|
||||
|
||||
procedure TForm1.lbUsersClick(Sender: TObject);
|
||||
var
|
||||
i, rowID: integer;
|
||||
user: TSQLUser;
|
||||
roles: TSQLUserRoles;
|
||||
date: TTimeLog;
|
||||
begin
|
||||
clbRoles.Enabled:= (lbUsers.ItemIndex > -1) and (lbUsers.Items.Objects[lbUsers.ItemIndex] <> nil);
|
||||
FillRolesList(clbRoles.Items); // clear names, dates and selections
|
||||
|
||||
if clbRoles.Enabled then
|
||||
begin
|
||||
user:= TSQLUser.Create(globalClient, integer(lbUsers.Items.Objects[lbUsers.ItemIndex]));
|
||||
|
||||
try
|
||||
for i:= 0 to clbRoles.Items.Count -1 do
|
||||
if user.HasRole('', integer(clbRoles.Items.Objects[i]), rowID) then
|
||||
begin
|
||||
clbRoles.Checked[i]:= true;
|
||||
try
|
||||
roles:= TSQLUserRoles.Create();
|
||||
// load the actual data (ValidUntil field)
|
||||
globalClient.Retrieve(rowID, roles);
|
||||
date := roles.ValidUntil;
|
||||
clbRoles.Items.Strings[i]:= clbRoles.Items.Strings[i] + Format(' [valid until %s]',
|
||||
[TTimeLogBits(date).Text(true)]);
|
||||
finally
|
||||
FreeAndNil(roles);
|
||||
end;
|
||||
end;
|
||||
finally
|
||||
FreeAndNil(user);
|
||||
end;
|
||||
end
|
||||
end;
|
||||
|
||||
procedure TForm1.clbRolesClickCheck(Sender: TObject);
|
||||
var
|
||||
user: TSQLUser;
|
||||
roleID: integer;
|
||||
begin
|
||||
if clbRoles.ItemIndex = -1 then
|
||||
exit;
|
||||
|
||||
user:= TSQLUser.Create(globalClient, integer(lbUsers.Items.Objects[lbUsers.ItemIndex]));
|
||||
|
||||
try
|
||||
roleID:= Integer(clbRoles.Items.Objects[clbRoles.ItemIndex]);
|
||||
user.Roles.ValidUntil:= TimeLogFromDateTime( IncMonth(Now(), 1) );
|
||||
if user.HasRole('', roleID) then
|
||||
user.Roles.ManyDelete(globalClient, user.ID, roleID)
|
||||
else
|
||||
user.Roles.ManyAdd(globalClient, user.ID, roleID, true);
|
||||
finally
|
||||
FreeAndNil(user);
|
||||
end;
|
||||
|
||||
end;
|
||||
|
||||
procedure TForm1.clbRolesClick(Sender: TObject);
|
||||
var
|
||||
roles: TSQLUserRoles;
|
||||
roleID: integer;
|
||||
begin
|
||||
if clbRoles.ItemIndex = -1 then
|
||||
exit;
|
||||
|
||||
roleID:= integer(clbRoles.Items.Objects[clbRoles.ItemIndex]);
|
||||
roles:= TSQLUserRoles.Create();
|
||||
try
|
||||
//globalClient.Retrieve(rolesID, roles);
|
||||
roles.ManySelect(globalClient, integer(lbUsers.Items.Objects[lbUsers.ItemIndex]),roleID);
|
||||
if roles.id <> 0 then
|
||||
dtRoleExpires.DateTime:= TTimeLogBits(roles.ValidUntil).ToDate;
|
||||
finally
|
||||
FreeAndNil(roles);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TForm1.dtRoleExpiresChange(Sender: TObject);
|
||||
var
|
||||
roles: TSQLUserRoles;
|
||||
roleID: integer;
|
||||
begin
|
||||
if clbRoles.ItemIndex = -1 then
|
||||
exit;
|
||||
|
||||
roleID:= integer(clbRoles.Items.Objects[clbRoles.ItemIndex]);
|
||||
roles:= TSQLUserRoles.Create();
|
||||
try
|
||||
// select the record which associates currently selected user with currently selected role
|
||||
roles.ManySelect(globalClient, integer(lbUsers.Items.Objects[lbUsers.ItemIndex]), roleID);
|
||||
if roles.id <> 0 then
|
||||
begin
|
||||
roles.ValidUntil:= TimeLogFromDateTime(dtRoleExpires.DateTime);
|
||||
globalClient.Update(roles)
|
||||
end;
|
||||
finally
|
||||
FreeAndNil(roles);
|
||||
end;
|
||||
|
||||
end;
|
||||
|
||||
procedure TForm1.PageControl1Change(Sender: TObject);
|
||||
begin
|
||||
if PageControl1.ActivePage = tbUsers then
|
||||
if currentUser <> nil then
|
||||
if not currentUser.HasRole('admin') then
|
||||
begin
|
||||
PageControl1.ActivePage:= TabSheet3;
|
||||
MessageBox(handle, 'You are not allowed to edit this content', 'Please sign-in as admin!', MB_ICONEXCLAMATION)
|
||||
end;
|
||||
end;
|
||||
|
||||
end.
|
||||
@@ -0,0 +1,210 @@
|
||||
unit uCustomer;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
SynCommons,
|
||||
mORMot;
|
||||
|
||||
type
|
||||
TSQLTasks = class;
|
||||
|
||||
TSQLPerson = class(TSQLRecord)
|
||||
private
|
||||
fFirstname, fSurname: RawUTF8;
|
||||
published
|
||||
property FirstName: RawUTF8 read fFirstname write fFirstname;
|
||||
property Surname: RawUTF8 read fSurname write fSurname;
|
||||
end;
|
||||
|
||||
TSQLCustomer = class(TSQLPerson)
|
||||
private
|
||||
fTasks: TSQLTasks;
|
||||
published
|
||||
property Tasks: TSQLTasks read fTasks;
|
||||
end;
|
||||
|
||||
TSQLTaskPriority = (tpLow, tpNormal, tpHigh);
|
||||
TSQLTask = class(TSQLRecord)
|
||||
private
|
||||
fPriority: TSQLTaskPriority;
|
||||
fText: RawUTF8;
|
||||
published
|
||||
property Priority: TSQLTaskPriority read fPriority write fPriority;
|
||||
property Text: RawUTF8 read fText write fText;
|
||||
end;
|
||||
|
||||
TSQLTasks = class(TSQLRecordMany)
|
||||
private
|
||||
fSource: TSQLCustomer;
|
||||
fDest: TSQLTask;
|
||||
published
|
||||
property Source: TSQLCustomer read fSource;
|
||||
property Dest: TSQLTask read fDest;
|
||||
end;
|
||||
|
||||
TSQLUser = class;
|
||||
TSQLUserRole = class(TSQLRecord)
|
||||
private
|
||||
fRoleName: RawUTF8;
|
||||
public
|
||||
// create standard roles: admin & user
|
||||
class procedure CreateStandardRoles(const ADatabase: TSQLRest);
|
||||
published
|
||||
property RoleName: RawUTF8 read fRoleName write fRoleName;
|
||||
end;
|
||||
|
||||
TSQLUserRoles = class(TSQLRecordMany)
|
||||
private
|
||||
fValidUntil: TTimeLog;
|
||||
fSource: TSQLUser;
|
||||
fDest: TSQLUserRole;
|
||||
published
|
||||
property ValidUntil: TTimeLog read fValidUntil write fValidUntil;
|
||||
property Dest: TSQLUserRole read fDest;
|
||||
property Source: TSQLUser read fSource;
|
||||
end;
|
||||
|
||||
// user of our system
|
||||
TSQLUser = class(TSQLPerson)
|
||||
private
|
||||
fRoles: TSQLUserRoles;
|
||||
fLogin, fPassword: RawUTF8;
|
||||
procedure SetPassword(const APwd: RawUTF8);
|
||||
public
|
||||
function HasRole(const ARoleName: RawUTF8; const ARoleID: integer = -1): boolean; overload;
|
||||
// returned aRowID is an ID of row in PIVOT TABLE !!!
|
||||
// so that we can access additional data stored in pivot connection
|
||||
function HasRole(const ARoleName: RawUTF8; const ARoleID: integer; var ARowID: integer): boolean; overload;
|
||||
// returns 0 on fail, UserID on success
|
||||
class function SignIn(const ALogin, APassword: RawUTF8): Integer;
|
||||
published
|
||||
property Roles: TSQLUserRoles read fRoles write fRoles;
|
||||
property Login: RawUTF8 read fLogin write fLogin;
|
||||
property Password: RawUTF8 read fPassword write SetPassword;
|
||||
end;
|
||||
|
||||
function CreateSampleModel: TSQLModel;
|
||||
procedure InitClient();
|
||||
|
||||
var
|
||||
globalClient: TSQLRestClientURI;
|
||||
currentUser: TSQLUser;
|
||||
model: TSQLModel;
|
||||
|
||||
implementation
|
||||
|
||||
uses SysUtils, uQueryHistory, SynCrypto, mORMotSQLite3, Forms;
|
||||
|
||||
|
||||
procedure InitClient();
|
||||
begin
|
||||
Model:= CreateSampleModel;
|
||||
globalClient:= TSQLRestClientDB.Create(Model, CreateSampleModel, ChangeFileExt(Application.ExeName,'.db3'), TSQLRestServerDB);
|
||||
TSQLRestClientDB(globalClient).Server.CreateMissingTables;
|
||||
end;
|
||||
|
||||
function CreateSampleModel: TSQLModel;
|
||||
begin
|
||||
result := TSQLModel.Create([TSQLCustomer, TSQLTask, TSQLTasks, TSQLQueryHistory, TSQLUser, TSQLUserRole, TSQLUserRoles]);
|
||||
end;
|
||||
|
||||
|
||||
|
||||
class procedure TSQLUserRole.CreateStandardRoles(const ADatabase: TSQLRest);
|
||||
const
|
||||
names: array [0..1] of RawUTF8 = ( 'user', 'admin' );
|
||||
var
|
||||
i: integer;
|
||||
role: TSQLUserRole;
|
||||
begin
|
||||
for i:= low(names) to high(names) do
|
||||
begin
|
||||
role:= TSQLUserRole.Create(ADatabase, 'RoleName = ?', [names[i]]);
|
||||
try
|
||||
// if the role isn't present yet
|
||||
if role.ID = 0 then
|
||||
begin
|
||||
role.RoleName:= names[i];
|
||||
ADatabase.Add(role, true);
|
||||
end
|
||||
finally
|
||||
FreeAndNil(role);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure TSQLUser.SetPassword(const APwd: RawUTF8);
|
||||
begin
|
||||
fPassword:= SynCrypto.MD5(APwd);
|
||||
end;
|
||||
|
||||
|
||||
class function TSQLUser.SignIn(const ALogin, APassword: RawUTF8): Integer;
|
||||
var
|
||||
usr: TSQLUser;
|
||||
begin
|
||||
result:= 0;
|
||||
usr:= TSQLUser.Create(globalClient, '(User.Login = ? AND User.Password = ?)', [ALogin, SynCrypto.MD5(APassword)]);
|
||||
try
|
||||
result:= usr.ID;
|
||||
// check if is not expired
|
||||
if not usr.HasRole('user') then
|
||||
result:= 0
|
||||
else
|
||||
currentUser:= usr;
|
||||
finally
|
||||
if result = 0 then // if no valid user found, free it. otherwise we'll keep it until application end.
|
||||
FreeAndNil(usr);
|
||||
end;
|
||||
end;
|
||||
|
||||
function TSQLUser.HasRole(const ARoleName: RawUTF8; const ARoleID: integer = -1): boolean;
|
||||
var
|
||||
dummy: integer;
|
||||
begin
|
||||
result:= HasRole(ARoleName, ARoleID, dummy);
|
||||
end;
|
||||
|
||||
|
||||
|
||||
function TSQLUser.HasRole(const ARoleName: RawUTF8; const ARoleID: integer; var ARowID: integer): boolean;
|
||||
var
|
||||
role: TSQLUserRole;
|
||||
begin
|
||||
result:= false;
|
||||
ARowID:= -1;
|
||||
// we want the RowID anyway, so skip that part: 'UserRoles.ValidUntil <= date(''now'')'
|
||||
fRoles.FillMany(globalClient, fID);
|
||||
|
||||
// loop through the roles
|
||||
while fRoles.FillOne do
|
||||
begin
|
||||
if fRoles.Dest <> nil then
|
||||
try
|
||||
role:= TSQLUserRole.Create(globalClient, fRoles.Dest.ID);
|
||||
if ((ARoleID = -1) and (role.RoleName = ARoleName)) or ((ARoleID > -1) and (role.ID = ARoleID) ) then
|
||||
begin
|
||||
// if using "admin" account, role validity doesn't expire.
|
||||
if fLogin <> 'admin' then
|
||||
result:= fRoles.ValidUntil >= TimeLogNow()
|
||||
else
|
||||
result:= true;
|
||||
ARowID:= fRoles.ID;
|
||||
break;
|
||||
end;
|
||||
finally
|
||||
FreeAndNil(role);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
initialization
|
||||
currentUser:= nil;
|
||||
finalization
|
||||
FreeAndNil(globalClient);
|
||||
FreeAndNil(model);
|
||||
FreeAndNil(currentUser);
|
||||
|
||||
end.
|
||||
@@ -0,0 +1,79 @@
|
||||
object LoginForm: TLoginForm
|
||||
Left = 251
|
||||
Top = 104
|
||||
Width = 249
|
||||
Height = 196
|
||||
AutoSize = True
|
||||
BorderStyle = bsSizeToolWin
|
||||
Caption = 'Log-in'
|
||||
Color = clBtnFace
|
||||
Font.Charset = DEFAULT_CHARSET
|
||||
Font.Color = clWindowText
|
||||
Font.Height = -11
|
||||
Font.Name = 'MS Sans Serif'
|
||||
Font.Style = []
|
||||
OldCreateOrder = False
|
||||
Position = poScreenCenter
|
||||
OnCreate = FormCreate
|
||||
PixelsPerInch = 96
|
||||
TextHeight = 13
|
||||
object Panel1: TPanel
|
||||
Left = 0
|
||||
Top = 0
|
||||
Width = 241
|
||||
Height = 169
|
||||
TabOrder = 0
|
||||
object Label1: TLabel
|
||||
Left = 24
|
||||
Top = 88
|
||||
Width = 191
|
||||
Height = 33
|
||||
AutoSize = False
|
||||
Caption =
|
||||
'Try admin / admin or demo / demo if you don'#39't have an own accoun' +
|
||||
't yet'
|
||||
Font.Charset = DEFAULT_CHARSET
|
||||
Font.Color = 4934475
|
||||
Font.Height = -11
|
||||
Font.Name = 'MS Sans Serif'
|
||||
Font.Style = []
|
||||
ParentFont = False
|
||||
WordWrap = True
|
||||
end
|
||||
object LabeledEdit1: TLabeledEdit
|
||||
Left = 80
|
||||
Top = 32
|
||||
Width = 121
|
||||
Height = 21
|
||||
EditLabel.Width = 52
|
||||
EditLabel.Height = 13
|
||||
EditLabel.Caption = 'username: '
|
||||
LabelPosition = lpLeft
|
||||
TabOrder = 0
|
||||
OnKeyDown = LabeledEdit2KeyDown
|
||||
end
|
||||
object LabeledEdit2: TLabeledEdit
|
||||
Left = 80
|
||||
Top = 56
|
||||
Width = 121
|
||||
Height = 21
|
||||
EditLabel.Width = 51
|
||||
EditLabel.Height = 13
|
||||
EditLabel.Caption = 'password: '
|
||||
LabelPosition = lpLeft
|
||||
PasswordChar = '*'
|
||||
TabOrder = 1
|
||||
OnKeyDown = LabeledEdit2KeyDown
|
||||
end
|
||||
object Button1: TButton
|
||||
Left = 128
|
||||
Top = 128
|
||||
Width = 75
|
||||
Height = 25
|
||||
Caption = 'OK'
|
||||
ModalResult = 1
|
||||
TabOrder = 2
|
||||
OnClick = Button1Click
|
||||
end
|
||||
end
|
||||
end
|
||||
@@ -0,0 +1,59 @@
|
||||
unit uLoginForm;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
|
||||
Dialogs, StdCtrls, ExtCtrls;
|
||||
|
||||
type
|
||||
TLoginForm = class(TForm)
|
||||
Panel1: TPanel;
|
||||
LabeledEdit1: TLabeledEdit;
|
||||
LabeledEdit2: TLabeledEdit;
|
||||
Label1: TLabel;
|
||||
Button1: TButton;
|
||||
procedure Button1Click(Sender: TObject);
|
||||
procedure LabeledEdit2KeyDown(Sender: TObject; var Key: Word;
|
||||
Shift: TShiftState);
|
||||
procedure FormCreate(Sender: TObject);
|
||||
private
|
||||
{ Private declarations }
|
||||
public
|
||||
{ Public declarations }
|
||||
LoginOk: boolean;
|
||||
end;
|
||||
|
||||
var
|
||||
LoginForm: TLoginForm;
|
||||
|
||||
implementation
|
||||
|
||||
uses SynCommons, uCustomer;
|
||||
|
||||
{$R *.dfm}
|
||||
|
||||
procedure TLoginForm.Button1Click(Sender: TObject);
|
||||
begin
|
||||
if (TSQLUser.SignIn(StringToUTF8(LabeledEdit1.Text), StringToUTF8(LabeledEdit2.Text)) > 0) then
|
||||
begin
|
||||
LoginOk:= true;
|
||||
Close();
|
||||
end
|
||||
else
|
||||
MessageBox(0, 'Invalid login or password provided, or the account has expired', 'Login error', MB_ICONEXCLAMATION);
|
||||
end;
|
||||
|
||||
procedure TLoginForm.LabeledEdit2KeyDown(Sender: TObject; var Key: Word;
|
||||
Shift: TShiftState);
|
||||
begin
|
||||
if Key = VK_RETURN then
|
||||
Button1Click(nil);
|
||||
end;
|
||||
|
||||
procedure TLoginForm.FormCreate(Sender: TObject);
|
||||
begin
|
||||
LoginOk:= false;
|
||||
end;
|
||||
|
||||
end.
|
||||
@@ -0,0 +1,40 @@
|
||||
unit uQueryHistory;
|
||||
|
||||
interface
|
||||
uses
|
||||
SynCommons,
|
||||
mORMot;
|
||||
|
||||
type
|
||||
TSQLQueryHistory = class(TSQLRecord)
|
||||
private
|
||||
fSQL: RawUTF8;
|
||||
fLastUsed: TDateTime;
|
||||
published
|
||||
property SQL: RawUTF8 read fSQL write fSQL;
|
||||
property LastUsed: TDateTime read fLastUsed write fLastUsed;
|
||||
public
|
||||
procedure FillHistory();
|
||||
end;
|
||||
|
||||
|
||||
implementation
|
||||
|
||||
uses SysUtils, uCustomer;
|
||||
|
||||
procedure TSQLQueryHistory.FillHistory();
|
||||
var
|
||||
fData: TSQLTable;
|
||||
begin
|
||||
if globalClient = nil then
|
||||
exit;
|
||||
|
||||
fData:= globalClient.MultiFieldValues(RecordClass, '');
|
||||
fData.SortFields(fData.FieldIndex('LastUsed'), false, nil, sftDateTime);
|
||||
fData.OwnerMustFree:= true;
|
||||
FillPrepare(fData);
|
||||
end;
|
||||
|
||||
|
||||
|
||||
end.
|
||||
@@ -0,0 +1,16 @@
|
||||
// JCL_DEBUG_EXPERT_GENERATEJDBG OFF
|
||||
// JCL_DEBUG_EXPERT_INSERTJDBG OFF
|
||||
// JCL_DEBUG_EXPERT_DELETEMAPFILE OFF
|
||||
program Project2;
|
||||
|
||||
uses
|
||||
Forms,
|
||||
Unit1 in 'Unit1.pas' {Form1};
|
||||
|
||||
{$R *.res}
|
||||
|
||||
begin
|
||||
Application.Initialize;
|
||||
Application.CreateForm(TForm1, Form1);
|
||||
Application.Run;
|
||||
end.
|
||||
Binary file not shown.
@@ -0,0 +1,33 @@
|
||||
# Scope
|
||||
|
||||
This simple application speeds up defining SQL Records classes for the Synopse *mORMot* Framework.
|
||||
|
||||
Since some versions of Delphi (including mine) does not have class completion, declaring properties, their setters / getters and so on is a huge waste of time.
|
||||
|
||||
Thus I've written this simple tool which introduces so-called meta-language for defining SQL Records which is later converted to Delphi code.
|
||||
|
||||
It is simply list of field declarations we want to have in our SQL Record.
|
||||
|
||||
# Syntax
|
||||
|
||||
Each line is a declaration of one field.
|
||||
|
||||
It consists of field name and it's type the type might be shortened using aliases (see below).
|
||||
|
||||
Additionally, each field can be marked with `;r` and/or `;w` flags which will make the code generator to use respectively getter and/or setter for the specific field.
|
||||
|
||||
# Reverse
|
||||
|
||||
The tool also makes it possible to parse back from Delphi class declaration to meta-code.
|
||||
|
||||
Please note this will only work if the Delphi class follows naming pattern used in `meta2pas` generation.
|
||||
|
||||
# List of available aliases
|
||||
|
||||
* str <-> `RawUTF8`
|
||||
* int <-> `integer`
|
||||
|
||||
**enjoy!**
|
||||
|
||||
Michal *migajek* Gajek
|
||||
http://migajek.com migajek@gmail.com
|
||||
File diff suppressed because it is too large
Load Diff
@@ -0,0 +1,104 @@
|
||||
object Form1: TForm1
|
||||
Left = 192
|
||||
Top = 107
|
||||
Width = 696
|
||||
Height = 380
|
||||
Caption = 'Synopse SQLite Record tool'
|
||||
Color = clBtnFace
|
||||
Font.Charset = DEFAULT_CHARSET
|
||||
Font.Color = clWindowText
|
||||
Font.Height = -11
|
||||
Font.Name = 'MS Sans Serif'
|
||||
Font.Style = []
|
||||
OldCreateOrder = False
|
||||
DesignSize = (
|
||||
680
|
||||
342)
|
||||
PixelsPerInch = 96
|
||||
TextHeight = 13
|
||||
object Label1: TLabel
|
||||
Left = 632
|
||||
Top = 16
|
||||
Width = 27
|
||||
Height = 16
|
||||
Caption = 'pas'
|
||||
Font.Charset = DEFAULT_CHARSET
|
||||
Font.Color = clWindowText
|
||||
Font.Height = -13
|
||||
Font.Name = 'MS Sans Serif'
|
||||
Font.Style = [fsBold]
|
||||
ParentFont = False
|
||||
end
|
||||
object Label2: TLabel
|
||||
Left = 344
|
||||
Top = 16
|
||||
Width = 35
|
||||
Height = 16
|
||||
Caption = 'meta'
|
||||
Font.Charset = DEFAULT_CHARSET
|
||||
Font.Color = clWindowText
|
||||
Font.Height = -13
|
||||
Font.Name = 'MS Sans Serif'
|
||||
Font.Style = [fsBold]
|
||||
ParentFont = False
|
||||
end
|
||||
object Memo1: TMemo
|
||||
Left = 8
|
||||
Top = 40
|
||||
Width = 369
|
||||
Height = 265
|
||||
Anchors = [akLeft, akTop, akBottom]
|
||||
Lines.Strings = (
|
||||
'Name:str'
|
||||
'Surname:str'
|
||||
'Phone:str;r;w'
|
||||
'Age:int;r')
|
||||
TabOrder = 0
|
||||
end
|
||||
object generate: TButton
|
||||
Left = 8
|
||||
Top = 312
|
||||
Width = 75
|
||||
Height = 25
|
||||
Anchors = [akLeft, akBottom]
|
||||
Caption = 'meta2pas'
|
||||
TabOrder = 1
|
||||
OnClick = generateClick
|
||||
end
|
||||
object Edit1: TEdit
|
||||
Left = 8
|
||||
Top = 16
|
||||
Width = 121
|
||||
Height = 21
|
||||
TabOrder = 2
|
||||
Text = 'Person'
|
||||
end
|
||||
object Memo2: TMemo
|
||||
Left = 400
|
||||
Top = 40
|
||||
Width = 257
|
||||
Height = 270
|
||||
Anchors = [akLeft, akTop, akRight, akBottom]
|
||||
TabOrder = 3
|
||||
end
|
||||
object parse: TButton
|
||||
Left = 88
|
||||
Top = 312
|
||||
Width = 75
|
||||
Height = 25
|
||||
Anchors = [akLeft, akBottom]
|
||||
Caption = 'pas2meta'
|
||||
TabOrder = 4
|
||||
OnClick = parseClick
|
||||
end
|
||||
object Button1: TButton
|
||||
Left = 584
|
||||
Top = 317
|
||||
Width = 75
|
||||
Height = 25
|
||||
Anchors = [akRight, akBottom]
|
||||
Caption = 'info'
|
||||
TabOrder = 5
|
||||
OnClick = Button1Click
|
||||
end
|
||||
end
|
||||
@@ -0,0 +1,180 @@
|
||||
unit Unit1;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
|
||||
Dialogs, StdCtrls,
|
||||
regexpr;
|
||||
|
||||
type
|
||||
TForm1 = class(TForm)
|
||||
Memo1: TMemo;
|
||||
generate: TButton;
|
||||
Edit1: TEdit;
|
||||
Memo2: TMemo;
|
||||
parse: TButton;
|
||||
Label1: TLabel;
|
||||
Label2: TLabel;
|
||||
Button1: TButton;
|
||||
procedure generateClick(Sender: TObject);
|
||||
procedure parseClick(Sender: TObject);
|
||||
procedure Button1Click(Sender: TObject);
|
||||
private
|
||||
{ Private declarations }
|
||||
public
|
||||
{ Public declarations }
|
||||
end;
|
||||
|
||||
var
|
||||
Form1: TForm1;
|
||||
|
||||
implementation
|
||||
|
||||
{$R *.dfm}
|
||||
|
||||
type
|
||||
tstrpair = record
|
||||
sFrom: string;
|
||||
sTo: string;
|
||||
end;
|
||||
|
||||
const
|
||||
conversionTypes: array [0..1] of tstrpair = (
|
||||
(sFrom: 'str'; sTo: 'RawUTF8'),
|
||||
(sFrom: 'int'; sTo: 'integer')
|
||||
);
|
||||
|
||||
function aliasToType(s: string) : string ;
|
||||
var i: integer;
|
||||
begin
|
||||
result:= s;
|
||||
s:= lowercase(s);
|
||||
for i:= low(conversionTypes) to high(conversionTypes) do
|
||||
if conversionTypes[i].sFrom = s then
|
||||
begin
|
||||
result:= conversionTypes[i].sTo;
|
||||
break;
|
||||
end;
|
||||
end;
|
||||
|
||||
function typeToAlias(s: string) : string ;
|
||||
var i: integer;
|
||||
begin
|
||||
result:= s;
|
||||
s:= lowercase(s);
|
||||
for i:= low(conversionTypes) to high(conversionTypes) do
|
||||
if lowercase(conversionTypes[i].sTo) = s then
|
||||
begin
|
||||
result:= conversionTypes[i].sFrom;
|
||||
break;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TForm1.generateClick(Sender: TObject);
|
||||
var
|
||||
r: TRegExpr;
|
||||
clsname,
|
||||
priv, publ,
|
||||
functs, impl,
|
||||
stype, sname,
|
||||
fwrite, fread: string;
|
||||
begin
|
||||
clsname:= 'TSQL'+edit1.Text;
|
||||
|
||||
r:= TRegExpr.Create;
|
||||
r.Expression:= '(\s+)?(\w+)(\s+)?:(\s+)?(\w+)(\s+)?(\;r)?(\;w)?';
|
||||
if r.Exec(memo1.Text) then
|
||||
repeat
|
||||
stype:= aliasToType( r.match[5] );
|
||||
sname:= r.match[2];
|
||||
|
||||
if (length(r.Match[7]) > 0) then
|
||||
begin
|
||||
fread := 'Get'+sname;
|
||||
functs:= functs + #13#10#9#9 + format('function Get%s():%s;'#13#10, [sname, stype]);
|
||||
impl:= impl + #13#10 + format('function %s.Get%s():%s;'#13#10'begin'#13#10#9'result:= f%s;'#13#10'end;'#13#10, [clsname, sname, stype, sname]);
|
||||
end
|
||||
else
|
||||
fRead:= 'f'+sname;
|
||||
|
||||
if (length(r.Match[8]) > 0) then
|
||||
begin
|
||||
fwrite := 'Set'+sname;
|
||||
functs:= functs + #13#10#9#9 + format('procedure Set%s(const AValue: %s);'#13#10, [sname, stype]);
|
||||
impl:= impl + #13#10 + format('procedure %s.Set%s(const AValue: %s);'#13#10'begin'#13#10#9'f%s:= AValue;'#13#10'end;'#13#10, [clsname, sname, stype, sname]);
|
||||
end
|
||||
else
|
||||
fWrite:= 'f'+sname;
|
||||
|
||||
priv:= priv + #9#9 + format('f%s: %s;'#13#10, [sname, stype]);
|
||||
publ:= publ + #9#9 + format('property %s: %s read %s write %s;'#13#10, [sname, stype, fread, fwrite]);
|
||||
until not r.ExecNext;
|
||||
memo2.Text:=
|
||||
format(
|
||||
#9'%s = class(TSQLRecord)'#13#10 +
|
||||
#9'private'#13#10'%s'#13#10'%s'+
|
||||
#9'published'#13#10'%s'#13#10+
|
||||
#9'end;'#13#10#13#10#13#10'%s',
|
||||
[clsname, priv, functs, publ, impl]);
|
||||
end;
|
||||
|
||||
procedure TForm1.parseClick(Sender: TObject);
|
||||
var
|
||||
r: TRegExpr;
|
||||
def: string;
|
||||
begin
|
||||
r:= TRegExpr.Create;
|
||||
|
||||
r.Expression:= '\s+?TSQL(\w+)\s*=\s*class';
|
||||
if r.Exec(memo2.Text) then
|
||||
edit1.Text:= r.Match[1];
|
||||
|
||||
r.Expression:= 'property\s+(\w+)(\s+)?:(\s+)?(\w+)\s*(read (\w+))?\s*(write (\w+))?';
|
||||
//r.Expression:= '(\w+):(\w+)';
|
||||
//r.ModifierM
|
||||
if r.Exec(memo2.Text) then
|
||||
repeat
|
||||
def:= def + r.Match[1] + ':'+ typeToAlias( r.Match[4] );
|
||||
//showmessage(r.Match[6]);
|
||||
if Copy(r.match[6], 1, 3) = 'Get' then
|
||||
def:= def + ';r';
|
||||
if Copy(r.match[8], 1, 3) = 'Set' then
|
||||
def:= def + ';w';
|
||||
|
||||
def:= def + #13#10;
|
||||
until not r.ExecNext;
|
||||
memo1.Text:=def;
|
||||
end;
|
||||
|
||||
procedure TForm1.Button1Click(Sender: TObject);
|
||||
const
|
||||
sHelp =
|
||||
'This simple application speeds up defining SQL Records classes for Synopse mORMot Framework'#13#10+
|
||||
'Since some versions of Delphi (including mine) does not have class completion, declaring properties,'#13#10+
|
||||
'their setters / getters and so on is a huge waste of time.'#13#10+
|
||||
'Thus I''ve written this simple tool which introduces so-called meta-language for defining SQL Records'#13#10+
|
||||
'which is later converted to Delphi code.'#13#10+
|
||||
'It is simply list of field declarations we want to have in our SQL Record.'#13#10#13#10+
|
||||
'Syntax:'#13#10+
|
||||
'each line is a declaration of one field. It consists of field name and it''s type'#13#10+
|
||||
'the type might be shortened using aliases (see below).'#13#10+
|
||||
'additionally, each field can be marked with ";r" and/or ";w" flags'#13#10+
|
||||
'which will make the code generator to use respectively getter and/or setter for the specific field'#13#10+
|
||||
'The tool also makes it possible to parse back from Delphi class declaration to meta-code'#13#10+
|
||||
'Please note this will only work if the Delphi class follows naming pattern used in meta2pas generatorion'#13#10+
|
||||
#13#10'List of available aliases:'#13#10'%s'#13#10+
|
||||
'================'#13#10+
|
||||
'enjoy!'#13#10+
|
||||
'Michal migajek Gajek'#13#10'http://migajek.com'#13#10'migajek@gmail.com';
|
||||
var
|
||||
i: integer;
|
||||
tmp: string;
|
||||
begin
|
||||
for i:= low(conversionTypes) to high(conversionTypes) do
|
||||
tmp:= tmp + conversionTypes[i].sFrom + ' = ' + conversionTypes[i].sTo + #13#10;
|
||||
|
||||
MessageBox(handle, PChar(Format(sHelp, [tmp])), 'Help', MB_ICONINFORMATION);
|
||||
end;
|
||||
|
||||
end.
|
||||
Reference in New Issue
Block a user