Selasa, 16 Desember 2025

Creating Expert System for Database Application Development

 

In the year 2016, my friend show me he create a desktop application using Delphi that he create very fast. I think I cannot compete with him with that software development skill. I am thinking what if I create an expert system to help create desktop application for me. Then I create this application and name it Gampang Builder.

The design of Gampang Builder is very simple, it get input from the user about the application design and generate softwaer project for it, not a complete software but only:

  1. Main form and main menu of the application.
  2. Navigation system to access facilities in the application and limiting access by application user. 
  3. Data service for create, edit and delete for entities and relations.
  4. Editing form for the entites and relations.
  5. Printable report for the entities.

 

When we create an application first we have to define the backgroud of the problem to solve and the target to be achieved by the application.

Then we choose the technology for the to be generated application.

To make our code more reusable I split the code into few modules.

In each module we can define the class name for the data service and access right than can be used to limit user access because not every user will have the same access level.

After we define the modules we can define the entities by the data table and relations between entities in the applications.

 

In the data tabel we can define field name, data type, its characteristic, and relation with other table such as look up or master-detail.


If we need the printed design for documentation, Gampang Builder can print it.

The last thing to do is generate the application but because this application is too old and many changes to the library change the package file reader, I will repair the code and update when it completed. I created a few application with this program, one of the application is a medical laboratory database application and is still running today from 2016. I dont have time yet to improve this program but maybe someday.


 That's all in this article, I hope it's usefull.

 


Creating Simple Web Server Daemon with Lazarus

 

Web server is a program or sub program that provide data to client program not limited to web browser using HTTP or HTTPS (HTTP over SSL) protocol. HTTP is a simple, fast and robust protocol for client-server application. The HTTP protocol works by having the client send a request to the server, then the server processes the request and sends back a response to the client.

Example of HTTP Client's Request:

GET / HTTP/1.1 Host: www.example.com

The first line of a HTTP request consist of a command, a url and the protocol version. Followed by header lines and terminated by empty line. Each header line consist of header name and value separated by colon and one space. After the header data is the content data that contain n bytes where n is the value of Content-Length header.

Example of HTTP Server's Response:

HTTP/1.1 200 OK Date: Mon, 23 May 2005 22:38:34 GMT Content-Type: text/html; charset=UTF-8 Content-Length: 155 Last-Modified: Wed, 08 Jan 2003 23:11:55 GMT Server: Apache/1.3.3.7 (Unix) (Red-Hat/Linux) ETag: "3f80f-1b6-3e1cb03b" Accept-Ranges: bytes Connection: close <html> <head> <title>An Example Page</title> </head> <body> <p>Hello World, this is a very simple HTML document.</p> </body> </html>

The first line of a HTTP response consist of protocol version and result code followed by error message. Followed by header lines and terminated by empty line. Each header line consist of header name and value separated by colon and one space. After the header data is the content data that contain n bytes where n is the value of Content-Length header.

Free Pascal, Delphi and Lazarus share the same programming language the Object Pascal with little differentiation. So many Delphi component can be used in Lazarus and vice versa because it only requires minor changes in the source code to support both programming. If you don't want to use visual component you can use operating system API like winsock (Windows Socket) for Windows or unisock (Unix Socket) for Linux. I will use synapse for Free Pascal library in this example.

To help parsing input data I create TStringSplitter :

  1.      type
  2.       { TStringSplitter }
  3.       TStringSplitter = class(TObject)
  4.       private
  5.         FLine: String;
  6.         FCol: Integer;
  7.         procedure SetCol(AValue: Integer);
  8.         procedure SetLine(AValue: String);
  9.       public
  10.         constructor Create;
  11.         function Fetch(const ATerminator: String=''): String;
  12.         property Line: String read FLine write SetLine;
  13.         property Col: Integer read FCol write SetCol;
  14.       end;

  15.     function PosAfter(const SubText, Text: String; StartAt: Integer): Integer;
  16.     var
  17.       I, L1, L2: Integer;
  18.     begin
  19.       Result := -1;
  20.       L1 := Length(SubText);
  21.       L2 := Length(Text);
  22.       if ((L1 > L2) or (StartAt < 1)) then exit;
  23.       for I := StartAt to L2-L1+1 do
  24.         if (CompareMem(@SubText[1], @Text[I], L1)) then
  25.         begin
  26.           Result := I;
  27.           exit;
  28.         end;
  29.     end;
  30.  
  31.     procedure TStringSplitter.SetCol(AValue: Integer);
  32.     begin
  33.       FCol := AValue;
  34.     end;
  35.  
  36.     procedure TStringSplitter.SetLine(AValue: String);
  37.     begin
  38.       FLine := AValue;
  39.       FCol := 1;
  40.     end;
  41.  
  42.     constructor TStringSplitter.Create;
  43.     begin
  44.       FLine := '';
  45.       FCol := 1;
  46.     end;
  47.  
  48.     function TStringSplitter.Fetch(const ATerminator: String): String;
  49.     var
  50.       I, J: Integer;
  51.     begin
  52.       Result := '';
  53.       I := FCol;
  54.       if (I > Length(FLine)) then exit;
  55.       if (ATerminator <> '') then
  56.       begin
  57.         J := PosAfter(ATerminator, FLine, I);
  58.         if (J > 0) then
  59.         begin
  60.           Result := Copy(FLine, I, J-I);
  61.           FCol := J + Length(ATerminator);
  62.           exit;
  63.         end;
  64.       end;
  65.       Result := Copy(FLine, FCol, MaxInt);
  66.       FCol := Length(FLine) + 1;
  67.     end;

When the server is started it initialize the socket to listen to the specified port. Then it repeatly check for incoming connection and start HTTP handler worker thread until the server is terminated. 

  1. procedure TDaemon1.WorkServerListener(Thread: TWorkerThread);
  2. var
  3.   sock: TTCPBlockSocket;
  4.   h: TSocket;
  5. begin
  6.   try
  7.     sock := TTCPBlockSocket.Create;
  8.     try
  9.       sock.Bind('0.0.0.0',IntToStr(Port));
  10.       if (sock.LastError <> 0) then
  11.         raise ENetworkError.Create('Cannot bind to port '+IntToStr(Port));
  12.       sock.Listen;
  13.       if (sock.LastError <> 0) then
  14.         raise ENetworkError.Create('Cannot listen to port '+IntToStr(Port));
  15.       while (not Thread.Terminated) do
  16.       begin
  17.         if (sock.CanRead(0)) then
  18.         begin
  19.           h := sock.Accept;
  20.           {$HINTS OFF}
  21.           if (h <> INVALID_SOCKET) then
  22.             WorkerThreads.AddNew(@WorkRequestHandler,Pointer(h));
  23.           {$HINTS ON}
  24.         end
  25.         else
  26.           Sleep(1);
  27.       end;
  28.     finally
  29.       sock.Free; // close and free socket object
  30.     end;
  31.   except
  32.     on E: Exception do
  33.       // DebugLog('HTTP Server terminated by error '+E.ClassName+': '+
  34.       //   E.Message);
  35.   end;
  36. end;

The HTTP handler worker thread read HTTP request from incoming connection and send back HTTP Respond.

  1. procedure TDaemon1.WorkRequestHandler(Thread: TWorkerThread);
  2. var
  3.   sock: TTCPBlockSocket;
  4.   S1: TStringSplitter;
  5.   s, cmd, url, http_ver, nm, vl, error_msg, respond_text, respond_data: AnsiString;
  6.   I, result_code: Integer;
  7.   close_socket, can_read: Boolean;
  8.   headers, gets, respond_headers: TStrings;
  9. begin
  10.   result_code := 500;
  11.   close_socket := True;
  12.   sock := TTCPBlockSocket.Create;
  13.   S1 := TStringSplitter.Create;
  14.   headers := TStringList.Create;
  15.   gets := TStringList.Create; 
  16.   respond_headers := TStringList.Create;
  17.   try
  18.     {$HINTS OFF}
  19.     sock.Socket := TSocket(Thread.Param);
  20.     {$HINTS ON}
  21.     repeat
  22.       can_read := sock.CanRead(0);
  23.       if (sock.LastError <> 0) then exit;
  24.       if (can_read) then
  25.       begin
  26.         I := Pos('?',url);
  27.         if (I >= 1) then
  28.         begin
  29.          S1.Line := Copy(url, I+1, MaxInt);
  30.          repeat
  31.             nm := S1.Fetch('=');
  32.             if (nm <> '') then
  33.             begin
  34.               vl := S1.Fetch('&');
  35.               gets.Values[nm] := vl;  
  36.             end;
  37.           until (nm = '');
  38.           Delete(url,I,MaxInt); 
  39.         end;  
  40.         S1.Line := sock.RecvString(ReadTimeout);
  41.         if (sock.LastError <> 0) then exit;
  42.         cmd := S1.Fetch(' ');
  43.         url := S1.Fetch(' ');
  44.         http_ver := S1.Fetch;
  45.         if ((cmd = 'GET') or (cmd = 'POST')) then
  46.         begin
  47.           close_socket := (http_ver = 'HTTP/0.9') or (http_ver = 'HTTP/1.0');
  48.           S1.Line := sock.RecvString(ReadTimeout);
  49.           if (sock.LastError <> 0) then exit;
  50.           while (S1.Line <> '') do
  51.           begin
  52.             nm := S1.Fetch(': ');
  53.             vl := S1.Fetch;
  54.             headers.Values[nm] := vl;
  55.           end;
  56.           //
  57.           // .. do some processing here
  58.           //
  59.           respond_data :=
  60.             '<head><title>Welcome</title></head><body><h1>Welcome to my Web Server</h1><p>You are in here: '+HttpEncode(url)+'</body>';
  61.           respond_headers.Values['Content-Type'] := 'html/text';
  62.           respond_headers.Values['Content-Length'] := IntToStr(Length(respond_data));
  63.           result_code := 200;
  64.         end
  65.         else begin
  66.           result_code := 501;
  67.           close_socket := True; 
  68.         end;
  69.        if((result_code < 200) or (result_code > 499)) then close_socket := True;
  70.         case result_code of
  71.         200: error_msg := 'OK';
  72.         400: error_msg := 'Bad Reqeust';
  73.         500: error_msg := 'Internal Server Error'; 
  74.         501: error_msg := 'Not Implemented';   
  75.         end;  
  76.         respond_text :=
  77.           http_ver + ' ' + IntToStr(result_code) + ' ' + error_msg + #13#10;
  78.         for I := 0 to respond_headers.Count do
  79.           respond_text := respond_text + respond_headers.Names[I] + ': ' +
  80.             respond_headers.ValueFromIndex[I] + #13#10;
  81.         respond_text := respond_text + #13#10 + respond_data;
  82.         sock.SendBuffer(@respond_text[1], Length(respond_text));
  83.         headers.Clear;
  84.         respond_headers.Clear;
  85.         respond_text := '';
  86.       end
  87.       else
  88.         Sleep(1);
  89.     until (Thread.Terminated or close_socket);
  90.   finally
  91.     respond_headers.Free;
  92.     gets.Free;
  93.     headers.Free;
  94.     S1.Free;
  95.     sock.Free;
  96.   end;
  97. end;

You can send and receive data using easy to parse data like JSON, XML, BSON or binary data for data service, it is very flexible.

That's all for this article and I hope it's useful.  

Kamis, 04 Desember 2025

Creating Thread from Procedure to simplify thread programming in Free Pascal and Delphi

 

Thread in Free Pascal and Delphi is a process that run simutanously with main program. This is very useful when we need to process data in background while user doing his own work. And is needed to maximize processing in multicore processor because a process including main process can only use 1 core and a quad core processor require a minimum of 4 threads to use all 4 cores.

Basically to create a thread we need to create the thread class and override the execute procedure with the thread code. To minimize work I create WorkerThreadList class, a very simple class to run a procedure of object as a thread.

First the class definition: 

  1. type 
  2.   { TSemaphore }
  3.   TSemaphore = class(TObject) 
  4.   private
  5.     FSem: Integer;
  6.   public
  7.     constructor Create;
  8.     destructor Destroy; override;
  9.     procedure Lock;
  10.     procedure Unlock;
  11.   end;
  12.  
  13.   { WorkerThreads Routines }
  14.   TWorkerThread = class;
  15.   TWorkerThreadList = class;
  16.  
  17.   TWorkEvent = procedure(WT: TWorkerThread) of object;
  18.  
  19.   { TWorkerThread }
  20.   TWorkerThread = class(TThread)
  21.   private
  22.     FOwner: TWorkerThreadList;
  23.     FOnWork: TWorkEvent;
  24.     FParam: Pointer;
  25.   protected
  26.     procedure Execute; override;
  27.   public
  28.     constructor Create(AOwner: TWorkerThreadList; AOnWork: TWorkEvent;
  29.       AParam: Pointer);
  30.     destructor Destroy; override;
  31.     property OnWork: TWorkEvent read FOnWork write FOnWork;
  32.     property Param: Pointer read FParam;
  33.     property Terminated;
  34.   end;
  35.  
  36.   { TWorkerThreadList }
  37.   TWorkerThreadList = class(TObject)
  38.   private
  39.     FWorkers: TObjectList;
  40.     FSem: TSemaphore;
  41.     function GetItems(Index: Integer): TWorkerThread;
  42.   public
  43.     constructor Create;
  44.     destructor Destroy; override;
  45.     function AddNew(AOnWork: TWorkEvent; AParam: Pointer=nil): TWorkerThread;
  46.     procedure TerminateWait(Thread: TWorkerThread);
  47.     procedure UnregisterWorkerThread(AThread: TWorkerThread);
  48.     procedure TerminateWorkerThreads(Wait: Boolean);
  49.     property Items[Index: Integer]: TWorkerThread read GetItems; default;
  50.   end;

Then I create the class definition like this:

  1. { TWorkerThreadList }
  2.  
  3. function TWorkerThreadList.GetItems(Index: Integer): TWorkerThread;
  4. begin
  5.   Result := TWorkerThread(FWorkers[Index]);
  6. end;
  7.  
  8. constructor TWorkerThreadList.Create;
  9. begin
  10.   inherited;
  11.   FWorkers := TObjectList.Create(False);
  12.   FSem := TSemaphore.Create;
  13. end;
  14.  
  15. destructor TWorkerThreadList.Destroy;
  16. begin
  17.   TerminateWorkerThreads(True);
  18.   FWorkers.Free;
  19.   FSem.Free;
  20.   inherited Destroy;
  21. end;
  22.  
  23. function TWorkerThreadList.AddNew(AOnWork: TWorkEvent;
  24.   AParam: Pointer): TWorkerThread;
  25. var
  26.   N: TWorkerThread;
  27. begin
  28.   N := TWorkerThread.Create(Self, AOnWork, AParam);
  29.   try
  30.     FSem.Lock;
  31.     try
  32.       FWorkers.Add(N);
  33.     finally
  34.       FSem.Unlock;
  35.     end;
  36.     Result := N;
  37.     N.Start;
  38.   except
  39.     N.Free;
  40.     raise;
  41.   end;
  42. end;
  43.  
  44. procedure TWorkerThreadList.TerminateWait(Thread: TWorkerThread);
  45. begin
  46.   if (Thread = nil) then exit;
  47.   FSem.Lock;
  48.   try
  49.     if (FWorkers.IndexOf(Thread) < 0) then
  50.       exit
  51.     else begin
  52.       if (not Thread.Terminated) then Thread.Terminate;
  53.       if (Thread.Suspended) then Thread.Start;
  54.     end;
  55.   finally
  56.     FSem.Unlock;
  57.   end;
  58.   repeat
  59.     FSem.Lock;
  60.     try
  61.       if (FWorkers.IndexOf(Thread) < 0) then exit;
  62.     finally
  63.       FSem.Unlock;
  64.     end;
  65.     Sleep(1);
  66.   until (False);
  67. end;
  68.  
  69. procedure TWorkerThreadList.UnregisterWorkerThread(AThread: TWorkerThread);
  70. begin
  71.   if ((AThread = nil) or (AThread.FOwner <> Self)) then
  72.     exit;
  73.   FSem.Lock;
  74.   try
  75.     FWorkers.Remove(AThread);
  76.     AThread.FOwner := nil;
  77.   finally
  78.     FSem.Unlock;
  79.   end;
  80. end;
  81.  
  82. procedure TWorkerThreadList.TerminateWorkerThreads(Wait: Boolean);
  83. var
  84.   I, J: Integer;
  85. begin
  86.   repeat
  87.     FSem.Lock;
  88.     try
  89.       J := FWorkers.Count;
  90.       for I := 0 to J-1 do
  91.       begin
  92.         with TWorkerThread(FWorkers[I]) do
  93.         begin
  94.           if (not Terminated) then Terminate;
  95.           if (Suspended) then Start;
  96.         end;
  97.       end;
  98.     finally
  99.       FSem.Unlock;
  100.     end;
  101.     Sleep(1);
  102.   until ((J = 0) or not Wait);
  103. end;
  104.  
  105. { TWorkerThread }
  106.  
  107. procedure TWorkerThread.Execute;
  108. begin
  109.   try
  110.     if (Assigned(FOnWork)) then FOnWork(Self);
  111.   except
  112.   end;
  113.   if (FOwner <> nil) then FOwner.UnregisterWorkerThread(Self);
  114. end;
  115.  
  116. constructor TWorkerThread.Create(AOwner: TWorkerThreadList; AOnWork: TWorkEvent;
  117.   AParam: Pointer);
  118. begin
  119.   inherited Create(True);
  120.   FreeOnTerminate := True;
  121.   Priority := tpIdle;
  122.   FOwner := AOwner;
  123.   FOnWork := AOnWork;
  124.   FParam := AParam;
  125. end;
  126.  
  127. destructor TWorkerThread.Destroy;
  128. begin
  129.   if (FOwner <> nil) then FOwner.UnregisterWorkerThread(Self);
  130.   inherited Destroy;
  131. end;
  132.  
  133. { TSemaphore }
  134. constructor TSemaphore.Create;
  135. begin
  136.   FSem := 0;
  137. end;
  138. destructor TSemaphore.Destroy;
  139. begin
  140.   Unlock;
  141.   inherited Destroy;
  142. end;
  143. procedure TSemaphore.Lock;
  144. begin
  145.   while (InterLockedExchange(FSem, 1) = 1) do Sleep(1);
  146. end;
  147.  
  148. procedure TSemaphore.Unlock;
  149. begin
  150.   InterLockedExchange(FSem, 0);
  151. end; 

Using this class I can run a procedure of object with this parameter using TWorkerThreadList object:

  TWorkEvent = procedure(WT: TWorkerThread) of object;

How to use the TWorkerThreadList class:

  • Define WorkerThreads variable as global variable or in the data module:

        WorkerThreads: TWorkerThreadList;

  •  Add object create and free for the WorkerThreads object in the data module on create and on destroy:
    1. procedure TDaemon1.DataModuleCreate(Sender: TObject);
    2. begin
    3.   WorkerThreads := TWorkerThreadList.Create;
    4. end;
    5.  
    6. procedure TDaemon1.DataModuleDestroy(Sender: TObject);
    7. begin
    8.   WorkerThreads.Free;
    9. end;
  • Create the thread procedure:
    1. procedure TDaemon1.WorkServerListener(Thread: TWorkerThread);
    2. begin
    3.   try
    4.     { do something } 
    5.   except
    6.     { do handle exceptions }
    7.   end;
    8. end;
  •  Create thread for the procedure:
    1. procedure TDaemon1.DataModuleStart(Sender: TCustomDaemon; var OK: Boolean
    2.   );
    3. begin
    4.   WorkerThreads.AddNew(@WorkServerListener, nil);
    5.   OK := True; 
    6. end;

WorkerThreadList object can be created and destroyed as needed. A WorkerThreadList object can run alot of procedures.

Working with thread can be tricky, You have to be carefull with race condition, some objects that is not thread safe you need to put semaphore so that only one thread can access it at a time. Memory leak is not the only bugs.

Thats all for the WorkerThreadList object, and I hope this article can be useful.

Kamis, 25 Januari 2024

Creating Linux Daemon or Windows Service with Lazarus

Daemon Application in Linux or Service Application in Windows is an application that running in the background, usually automatically started when the operating system started even if user is not logged in. In Windows Service Application you cannot access Windows GUI library.

To create Daemon with Lazarus, first you need to create new project and select Daemon (service) application. After you click the OK button the IDE will create a new lazarus project with a daemon mapper unit dan a daemon class unit. Then save the project to the specified project name and folder.

Then you need to give the daemon class name. In this example the daemon class is named FirebirdRelayDaemon and the unit file saved as uFirebirdRelayDaemon.pas. 

The daemon class will never be registered to the operating system or started unless you register it in the Daemon Mapper. To register the daemon class you need to open the daemonmapperunit1.pas.

Then click the object inspector and then click the ellipsis button in the DaemonDefs property to open the daemon definitions editor. Then click Add button in the daemon definitions editor to add new daemon definition.


After you click Add button the object inspector will display the new daemon definition. You need to edit DaemonClassName, Display and Name properties. 

  • DaemonClassName: TFirebirdRelayDaemon.
  • DisplayName: Firebird Relay Server.
  • Name: firebirdrelayd.

After the daemon class is registered, you can place the code for your daemon in the daemon class. You can place objects initialization in the OnCreate event and objects finalization in the OnDestroy event. The code to start the daemon thread is placed in the OnStart event and code to terminate daemon thread is placed in the OnStop event. 


This is the example of the daemon class declaration:

  1. type

  2.   { TFirebirdRelayDaemon }

  3.   TFirebirdRelayDaemon = class(TDaemon)
  4.     procedure DataModuleCreate(Sender: TObject);
  5.     procedure DataModuleDestroy(Sender: TObject);
  6.     procedure DataModuleStart(Sender: TCustomDaemon; var OK: Boolean);
  7.     procedure DataModuleStop(Sender: TCustomDaemon; var OK: Boolean);
  8.   private
  9.     { private declarations }
  10.     FirebirdRelayServer: TFirebirdRelayServer;
  11.   public
  12.     { public declarations }
  13.   end;

This is the example of the daemon class definition:

  1. { TFirebirdRelayDaemon }

  2. procedure TFirebirdRelayDaemon.DataModuleCreate(Sender: TObject);
  3. begin
  4.   FirebirdRelayServer := TFirebirdRelayServer.Create;
  5. end;

  6. procedure TFirebirdRelayDaemon.DataModuleDestroy(Sender: TObject);
  7. begin
  8.   FirebirdRelayServer.Free;
  9. end;

  10. procedure TFirebirdRelayDaemon.DataModuleStart(Sender: TCustomDaemon;
  11.   var OK: Boolean);
  12. begin
  13.   FirebirdRelayServer.LoadFromIniFile(ExtractFilePath(ParamStr(0))+'konfig.ini',
  14.     'FirebirdRelayServer');
  15.   FirebirdRelayServer.StartThread;
  16.   OK := True;
  17. end;

  18. procedure TFirebirdRelayDaemon.DataModuleStop(Sender: TCustomDaemon;
  19.   var OK: Boolean);
  20. begin
  21.   FirebirdRelayServer.TerminateThread;
  22.   OK := True;
  23. end;

Output of the compiled daemon:

The daemon is installed in the windows services list:

You can start the service from command line using "net start firebirdrelayd" and stop the service using "net stop firebirdrelayd".

Thankyou for reading this article and I hope this article can be useful.

Compress and Decompress Text or File using ZLib in Delphi or Free Pascal Lazarus

When I was in my college I work as part time programmer in a software house. I got a task to create a software updater. The software updater work by copying new files to the already installed application in the client's computers. To make update file easier to distribute I need to compress the new files and combine them into a file.

In Delphi or Lazarus we can use TFileStream class to access files and using TCompressionStream in the zstream unit to compress data from memory buffer to output stream that can be any TStream object including TFileStream or TMemoryStream. To decompress later you can use TDecompressionStream class.

If ZLib compression is not enough you can use BZip2 library for stronger compression.

Bellow is an example of using ZLib TCompressionStream and TDecompressionStream class:

  1. program TestCompressAndDecompress;
  2. {$MODE DELPHI}
  3. uses SysUtils, Classes, zstream;
  4. var
  5.   F: TMemoryStream;
  6.   Comp: TCompressionStream;
  7.   Decomp: TDecompressionStream;
  8.   X, Y: AnsiString;
  9. begin
  10.   F := TMemoryStream.Create;
  11.   try
  12.     Comp := TCompressionStream.Create(clMax, F);
  13.    try
  14.       X := 'Compress and Decompress array of bytes or a file using ZLib in Delphi or Free Pascal Lazarus';
  15.       Comp.Write(X[1], Length(X));
  16.     finally
  17.       Comp.Free;
  18.     end;
  19.     WriteLn('Original Text: "',X,'"');
  20.     WriteLn('Original Size: ',Length(X),' bytes.');
  21.     WriteLn('Compressed Size: ',F.Size,' bytes.');
  22.     F.Position := 0;
  23.     Decomp := TDecompressionStream.Create(F);
  24.     try
  25.        SetLength(Y, Length(X));
  26.        Decomp.Read(Y[1], Length(Y));
  27.     finally
  28.       Decomp.Free;
  29.     end;
  30.     WriteLn('Decompressed Text: "',Y,'"');
  31.   finally
  32.     F.Free;
  33.   end;
  34. end.

Selasa, 14 November 2023

Creating A Thread Safe Database Connection Pool for Delphi and Free Pascal based Lazarus

One day I got a software project to create an application that need to be accessed from many computer with one data server. I decided to create a three-tier application, a client application for the client computer and a middle application that connect directly to database server that is a Firebird Database Server for this project. After a few weeks the project is finished and I realized that the response time of every client request is very slow caused by database connection time. Because every time client request arrived the middle application create new thread to handle the request and create new database connection and doing database query and then send the respond data back to the requester client and finally close database connection and free database connection, transaction and queries objects before the thread is destroyed.

Then I begin researching to reduce the database connection time in the request handler thread. I become pesimistic after I read in delphi manual book that every thread must create and use its own database connection. But I'm still not giving up because other programming like PHP and MySQL can do that. Then I try to isolate every parts of the database connection and database query in part by part, and finally I'm able to reuse database connection, transcation and query object with many threads by isolating creation and desctruction of database connection object and transaction object and also commit and rollback process, everything else is no problem with multithread.

  1. procedure TSimpleQuery.Commit;
  2. begin
  3.   if ((FQuery.Connection = nil) or not FQuery.Connection.Connected or
  4.     FQuery.Connection.AutoCommit) then exit;
  5.   EnterCriticalSection(FConnectionManager.GetCriticalSection^);
  6.   try
  7.     try
  8.       FQuery.Connection.Commit;
  9.     except
  10.       LogExceptionMessage;
  11.       raise;
  12.     end;
  13.   finally
  14.     LeaveCriticalSection(FConnectionManager.GetCriticalSection^);
  15.   end;
  16.   ConnectionManager.SetAllowFailover(FQuery, True);
  17. end;

  18. procedure TSimpleQuery.Rollback;
  19. begin
  20.   if ((FQuery.Connection = nil) or not FQuery.Connection.Connected or
  21.     FQuery.Connection.AutoCommit) then exit;
  22.   EnterCriticalSection(FConnectionManager.GetCriticalSection^);
  23.   try
  24.     try
  25.       FQuery.Connection.Rollback;
  26.     except
  27.       LogExceptionMessage;
  28.       raise;
  29.     end;
  30.   finally
  31.     LeaveCriticalSection(FConnectionManager.GetCriticalSection^);
  32.   end;
  33.   ConnectionManager.SetAllowFailover(FQuery, True);
  34. end;

After succeeded creating reusable database connection object accross multiple threads then I create wrapper component for the database connection, transaction dan query object like this:
  1.   ISimpleQuery = interface
  2.     ['{1C1949E4-C472-45BA-8638-5A14545592F8}']
  3.     function GetConnection: TZConnection;
  4.     function GetConnectionManager: IConnectionManager;
  5.     function GetParentQuery: ISimpleQuery;
  6.     function GetQueryObject: TZReadOnlyQuery;
  7.     function GetPrepared: Boolean;
  8.     function GetRecordCount: Integer;
  9.     function GetRowsAffected: Integer;
  10.     function GetActive: Boolean;
  11.     procedure SetActive(AValue: Boolean);
  12.     function GetName: String;
  13.     procedure SetName(const AValue: String);
  14.     function GetFieldDefs: TFieldDefs;
  15.     function GetFields: TFields;
  16.     function GetSQL: TStrings;
  17.     function GetBOF: Boolean;
  18.     function GetEOF: Boolean;
  19.     function GetParams: TParams;
  20.     function GetParamCheck: Boolean;
  21.     procedure SetParamCheck(Value: Boolean);
  22.     function GetConnected: Boolean;
  23.     function GetAutoCommit: Boolean;
  24.     procedure SetAutoCommit(const Value: Boolean);
  25.     function GetRecordAccess: TRecordAccess;
  26.     function GetPost: ITransportVar;
  27.     function GetWhere: ITransportVar;

  28.     procedure Open;
  29.     procedure OpenQuery(const ASQL: String);
  30.     procedure ExecSQL;
  31.     procedure ExecuteQuery(const ASQL: String);
  32.     procedure Close;
  33.     procedure First;
  34.     procedure Next;
  35.     procedure Prior;
  36.     procedure Last;
  37.     procedure Commit;
  38.     procedure Rollback;
  39.     procedure Prepare;
  40.     procedure Unprepare;
  41.     function CreateQuery: ISimpleQuery;
  42.     function FieldByName(const AFieldName: String): TField;
  43.     function FindField(const AFieldName: String): TField;
  44.     function ParamByName(const AParamName: String): TParam;
  45.     procedure Select(const SelectedCols: String);
  46.     procedure Group(const GroupBy: String);
  47.     procedure Order(const OrderBy: String);
  48.     procedure Get(const Table: String);
  49.     procedure Insert(const Table: String);
  50.     procedure Update(const Table: String);
  51.     procedure Delete(const Table: String);
  52.     function GetSQLWhere(AWhere: ITransportVar): String;
  53.     procedure AllowPost(const Columns: String);

  54.     property ConnectionManager: IConnectionManager read GetConnectionManager;
  55.     property ParentQuery: ISimpleQuery read GetParentQuery;
  56.     property Active: Boolean read GetActive write SetActive;
  57.     property Connection: TZConnection read GetConnection;
  58.     property QueryObject: TZReadOnlyQuery read GetQueryObject;
  59.     property FieldDefs: TFieldDefs read GetFieldDefs;
  60.     property Fields: TFields read GetFields;
  61.     property QueryFields[const AFieldName: String]: TField read FieldByName; default;
  62.     property SQL: TStrings read GetSQL;
  63.     property BOF: Boolean read GetBOF;
  64.     property EOF: Boolean read GetEOF;
  65.     property RowsAffected: Integer read GetRowsAffected;
  66.     property RecordCount: Integer read GetRecordCount;
  67.     property Prepared: Boolean read GetPrepared;
  68.     property Params: TParams read GetParams;
  69.     property ParamCheck: Boolean read GetParamCheck write SetParamCheck;
  70.     property Connected: Boolean read GetConnected;
  71.     property AutoCommit: Boolean read GetAutoCommit write SetAutoCommit;
  72.     property Name: String read GetName write SetName;
  73.     property RecordAccess: TRecordAccess read GetRecordAccess;
  74.     property Post: ITransportVar read GetPost;
  75.     property Where: ITransportVar read GetWhere;
  76.   end;

I'm using reference counter in the Interface type to make coding faster by creating query interface object and after the interface object is unused then it's automatically freed and the database connection object, transaction object, the wrapped query object is deallocated and waiting for next use.

I develop two version one with ZeosDBO component and another one with SQLDb component  and both working and very stable.

After I upgraded my application with this database connection pool the client request handling is faster than before.

I'm sorry about my bad english this is the first time i write article in english because maybe alot programmer outside of my country require this knowledge.

Rabu, 30 Agustus 2023

Alasan menggunakan Lazarus dan Delphi di zaman sekarang

Zaman sekarang development tools yang bagus dan sangat maju dan sedang berkembang pesat banyak seperti Java, Java Script, PHP, C#, Go, Dart, Kotlin, C++, Python dan masih banyak lainnya. Diantara banyaknya development tools yang ada dalam keseharian saya masih sering menggunakan aplikasi Lazarus dan Delphi untuk mendevelop aplikasi. Lazarus sendiri merupakan IDE (Integrated Development and Environment) yang memanfaatkan compiler Free Pascal.

Beberapa alasan saya untuk menggunakan Lazarus dan Delphi antara lain sebagai berikut:

  1. Karena sudah sangat nyaman karena terbiasa jadi begitu ada kebutuhan untuk mendevelop aplikasi pakenya ya itu-itu saja.
  2. Menggunakan resource processor dan memori yang kecil sehingga orang-orang seperti saya yang tidak memiliki hardware komputer highend terbaru dengan processor terbaru dan ram yang besar tetap bisa menjalankan aplikasi ini. Zaman saya kuliah dulu cuma menggunakan komputer AMD Sempron 2,1 GHz dengan RAM 1 GB saja masih bisa menjalankan program Delphi 2007 dengan lancar jaya.
  3. Menghasilkan file executable native code dengan optimalisasi yang bagus sehingga bisa berjalan dengan cepat dengan hardware seadanya. Khusus untuk Lazarus dan Delphi yang baru sudah mendukung prosesor 64-bit dengan optimal, sedangkan Delphi 2010 ke bawah masih terbatas pada processor 32-bit.
  4. File executable yang dihasilkan tidak bergantung pada file library yang lain sehingga cukup mendistribusikan satu file executable saja, kecuali memang menggunakan library khusus misal untuk modulasi program atau driver untuk koneksi ke database sehingga memerlukan file library lain tapi terbatas pada library yang dibutuhkan saja. Karena cukup mendistribusikan satu file executable saja sehingga mempermudah deployment dan meminimalkan penggunaan space hard disk maupun ram.
  5. Mungkin karena masih turunan Delphi 1.0 yang dulunya didesain untuk Windows 3.1 yang masih mendukung komputer dengan RAM sekecil 4 MB sehingga standar library bawaan Lazarus dan Delphi didesain agar sangat efisien dalam menggunakan RAM.
  6. Sangat mudah untuk membuat daemon atau windows service sehingga cocok untuk membuat sebuah aplikasi server kecil-kecilan.
  7. Bisa mengakses hardware yang bisa digunakan misalnya untuk membuat SMS Gateway dengan modem GSM.
  8. Khusus untuk Free Pascal, Lazarus dan Delphi terbaru bisa untuk mendevelop multiplatform misal bisa jalan di Windows dan Linux sehingga sangat membantu sekali misalnya ketika harus mendevelop aplikasi server yang dijalankan di VPS Linux yang lebih murah. 

Bagaimanapun juga sebagai development tool tetaplah hanya sebuah tool saja yang membutuhkan programmer untuk memanfaatkannya sehingga menghasilkan produk yang bagus dan bermanfaat. Saya percaya sebuah tool yang bisa memberikan manfaat bagi penggunanya tidak akan pernah punah dan menghilang.

Sekian artikel ini semoga bermanfaat.

Creating Expert System for Database Application Development

  In the year 2016, my friend show me he create a desktop application using Delphi that he create very fast. I think I cannot compete with h...