Wednesday, December 22, 2010

Dynamic web pages with DWScript and IdHTTPServer

I've finally found some time in my busy schedule to write a new post, this post is about generating dynamic web pages using DWScript(http://www.delphitools.info -- if you find DWScript useful please do not hesitate to donate to Eric, he is doing a wonderful job with DWScript) as script interpreter and IdHTTPServer as HTTP server.
But first let's understand the difference between static and dynamic web pages:
1. Static web pages:
- static web pages are just plain HTML files which will be manually updated by the developer or website owner whenever he wants;
Here's a drawing of the process that takes place in the case of static web pages



2. Dynamic web pages:
- dynamic web pages are similar to static HTML files, however this HTML files also contain script which is interpreted by a script interpreter which can be almost any script interpreter out there, i.e. perl, php, python, ruby, etc. for this example I've used DWScript;
Here's a drawing of the process that takes place in the case of dynamic web pages



as you can see the noticeable difference between static and dynamic web pages is the script interpreter which comes into play just before serving the HTML to the client.

In this post I won't cover the benefits of using dynamic web pages and the possible exploits.

For this post I've modified the HTTP server which I've created for a video tutorial, so here's the updated source of the uClientContext.pas file:
unit uClientContext;

interface

uses
  SysUtils,
  Classes,
  IdBaseComponent,
  IdComponent,
  IdCustomTCPServer,
  IdCustomHTTPServer,
  IdHTTPServer,
  IdContext,
  dwsComp,
  dwsCompiler,
  dwsExprs,
  dwsClassesLibModule,
  dwsMathFunctions,
  dwsStringFunctions,
  dwsStringResult,
  dwsTimeFunctions,
  dwsVariantFunctions,
  dwsHtmlFilter;

type
  TClientContext = class(TIdServerContext)
  private
    FLogStrings: TStrings;
    procedure Log(const s: string);
  public
    procedure HandleRequest(ARequestInfo: TIdHTTPRequestInfo;
      AResponseInfo: TIdHTTPResponseInfo);
    procedure ServeHTMLFile(const AFileName: string;
      ARequestInfo: TIdHTTPRequestInfo;
      AResponseInfo: TIdHTTPResponseInfo);
  public
    property LogStrings: TStrings read FLogStrings write FLogStrings;
  end;

implementation

var
  WebDir: string;

{ TClientContext }

procedure TClientContext.HandleRequest(ARequestInfo: TIdHTTPRequestInfo;
  AResponseInfo: TIdHTTPResponseInfo);
const
  SERROR_404 = 'Error 404 page not found "%s"';
var
  LLocation: string;
begin
  try
    LLocation := ARequestInfo.Document;
    if LLocation <> EmptyStr then begin
      if (LLocation = '/') or (LLocation = '/*') or SameText(LLocation, '/index.html') then
        ServeHTMLFile(WebDir + 'index.html', ARequestInfo, AResponseInfo)
      else begin
        LLocation := WebDir + Copy(LLocation, 2, MaxInt);
        if NOT SameText(ExtractFileExt(LLocation), '.html') then
          LLocation := LLocation + '.html';
        if FileExists(LLocation) then
          ServeHTMLFile(LLocation, ARequestInfo, AResponseInfo)
        else
          AResponseInfo.ContentText := Format(SERROR_404, [LLocation]);
      end;
    end else
      AResponseInfo.ContentText := Format(SERROR_404, [LLocation]);
  except
    on E: Exception do
      Log('Exception occured from IP ' + Connection.Socket.Binding.PeerIP +
        sLineBreak + E.Message);
  end; // trye
end;

procedure TClientContext.ServeHTMLFile(const AFileName: string;
  ARequestInfo: TIdHTTPRequestInfo; AResponseInfo: TIdHTTPResponseInfo);
var
  LHTMLFile: TStringList;
  LScript: TDelphiWebScript;
  LHTMLFilter: TdwsHtmlFilter;
  LClasses: TdwsClassesLib;
  LProgram: TdwsProgram;
begin
  LScript := TDelphiWebScript.Create(NIL);
  LScript.Config.ScriptPaths.Add(WebDir);
  LClasses := TdwsClassesLib.Create(NIL);
  LHTMLFilter := TdwsHtmlFilter.Create(NIL);
  LScript.Config.Filter := LHTMLFilter;
  LScript.AddUnit(TdwsHtmlUnit.Create(LScript));
  LScript.AddUnit(Tdws2StringsUnit.Create(LScript));
  LHTMLFile := TStringList.Create;
  try
    LClasses.Script := LScript;
    LHTMLFile.LoadFromFile(AFileName);
    LProgram := LScript.Compile(LHTMLFile.Text);
    try
      if NOT LProgram.Msgs.HasErrors then begin
        LProgram.Execute;
        AResponseInfo.ContentText := (LProgram.Result as TdwsDefaultResult).Text;
      end else
        AResponseInfo.ContentText := LProgram.Msgs.AsInfo
    finally
      FreeAndNil(LProgram);
    end; // tryf
  finally
    FreeAndNil(LHTMLFile);
    FreeAndNil(LClasses);
    FreeAndNil(LScript);
    FreeAndNil(LHTMLFilter);
  end; // tryf
end;

procedure TClientContext.Log(const s: string);
begin
  if Assigned(FLogStrings) then
    FLogStrings.Add(s);
end;

initialization
  WebDir := IncludeTrailingPathDelimiter(ExtractFilePath(ParamStr(0)) + 'www');

end.
as you can see the source code is pretty similar to the initial code, just that I've added a new method called ServeHTMLFile -- this method is called only if the requested HTML file is found in the www directory.
Technique: we don't create the interpreter instance unless the requested file is found in the www directory -- the reason is pretty obvious, we try to avoid memory allocation if it's not necessary, we could also improve the efficiency by caching the files in memory in order to serve them faster(RAM IO is faster than disk IO therefore this will give a significant speed improvement when server has thousands requests per second) however this will be covered in a future post hopefully.
In order to provide a proof of concept I've created a fairly simple "website" which has 3 buttons, each button redirects the client to a new web page:
index.html file
<HTML>
  <BODY>
    Hello world!!<BR>
    <BUTTON ONCLICK="window.location.href='/primes100.html'">show me primes up to 100</BUTTON> <BR>
    <BUTTON ONCLICK="window.location.href='/primes200.html'">show me primes up to 200</BUTTON> <BR>
    <BUTTON ONCLICK="window.location.href='/primes300.html'">show me primes up to 300</BUTTON> <BR>            
  </BODY>
</HTML>
very simple, right?
we also have a utils.inc file in which we have a method which checks if a number is prime, this file is also located in www directory
function IsPrime(Value: integer): boolean;
var
  Index: Integer;
begin
  Result := False;
  if Value <= 0 then
    Exit;
  for Index := 2 to Round(Sqrt(Value)) do
    if (Value mod Index) = 0 then
      Exit;
  Result := True;
end;
here are the other 3 HTML files primes100.html
<HTML>
  <BODY>
    <%
      {$I 'utils.inc'}
      var
        Index: Integer;
      for Index := 1 to 100 do
        if IsPrime(Index) then
          Send('<BR>' + IntToStr(Index)); 
    %>
  </BODY>  
</HTML>
primes200.html
<HTML>
  <BODY>
    <%
      {$I 'utils.inc'}
      var
        Index: Integer;
      for Index := 1 to 200 do
        if IsPrime(Index) then
          Send('<BR>' + IntToStr(Index)); 
    %>
  </BODY>  
</HTML>
primes300.html
<HTML>
  <BODY>
    <%
      {$I 'utils.inc'}
      var
        Index: Integer;
      for Index := 1 to 300 do
        if IsPrime(Index) then
          Send('<BR>' + IntToStr(Index)); 
    %>
  </BODY>  
</HTML>
Now, this is an extremely simple example, but as you can see it can be used as a template for a real hardcore web server. Unfortunately I don't have enough time these days for more in depth details, but you can download binary + source code or just the source code and enjoy the power and simplicity of DWScript.
The application is created in Delphi 2010.

Tuesday, November 30, 2010

Computing power: how much is enough?!

I see almost every day someone showing off with their new hardcore computer with lots of Gigahertz and lots of RAM, etc. but is that system fast enough to find the first 100 mil. or 1 billion prime numbers in under 10 minutes?! well... it depends on the algorithms and the system configuration.
Time showed us that there's never enough computing power(I'm NOT talking about browsing the Internet or writing a text file here...), but what can we do in order to achieve our goals using computers as fast as possible?! there are a few options(off the top of my head):

1. buy better computers
2. use any computer you can get you're hands on

1. We always buy better computers in order to do stuff faster but there are a lot of limitations:
a. budget: we can buy STA(state of the art) computers with 4, 6, etc. cores that will make our life easier, but is this really a good idea?! the answer is NO, buying a i7 at 3 GHz with 4 cores it's about $ 3-400 depending in which country you live, now 3 Ghz with 4 cores is not the fastest you can get, Intel has way better CPU's than that -- extreme series, they also try to get as many cores as they can into a CPU but let's just stop at the extreme series which costs about $ 1.000/CPU(of course it worths the price, but it depends on your needs) -- now this is a lot just for a processor but depending on you're budget you can buy or skip.

b. operating system: some OS's are better than others -- depending on your needs of course -- let's take Windows for example, it is a very good OS for entertainment and office, but when you need to do some tasks that takes hours/days/weeks to complete is it good?! I honestly can't give a definitive answer on this because for tasks that needs a lot of time to complete I turn to my geek friend Linux -- it is very stable, it manages resources very well and if you don't need GUI(graphical user interface) it's pretty much rock-solid.

2. What do I mean by "use any computer you can get you're hands on"?!
It's not a secret that a lot of companies connect a bunch of computers together through a communication protocol and use each computer as a thread -- WAIT!! how does this work?!!
Basically it depends on the developers... you can have a system that is the Master on which you execute special programs and sends task execute request to 2 or more Slaves, when a slave completed it's task, it sends back the result to the master and waits for another request from the master -- pretty simple ey?! in essence yes, in practice NOT!!
Here is the basic idea:
step 1. Master => send request => slave(s)(1..N computers) -- usually at least 2!!
step 2. Master waits for all slaves to complete the tasks
step 3. when a slave completes the task it sends result back to the Master
step 4. Master processes result(s)
Fairly simplistic right?! but why do I say "at least 2 computers"?!
Over time we have been Witness hardware failure(I'm proud that I haven't had too many -- yet!!) let's say we got a highly intensive task that we believe that it will take "forever" to complete a matter of days, WHAT IF in this time one of the slaves has a hardware failure?! you've lost shit-load of time and we all know the equation:
time = money -> lose time => lose money another way to see this is: the less time you spend on doing something, the more money you earn.
Sooo... let's review what is one of the best approaches you can take when you need huge computing power:
1. get as many systems as you can -- no matter how powerful the CPU is or how much RAM the system has
2. implement the logic and the communication protocol(avoid using hard disks as much as possible <-- slowest part in the computer) 3. start using you're new hardcore computer network 4...N. always improve the idea!!

Now, let's try to throw some ideas of a possible implementation:
- create a flexible communication protocol(I prefer using TCP/IP because you can have GB's of data transfered in second(s)) maybe use XML?!
- choose the cleanest Linux distribution you can think of -- avoid using GUI for better performance(on slave side)
- implement integer(huge integers -- that can grow up to trillion digits long), string(huge strings that can be concated from 2 or more slaves), object(which has it's own methods which will be transfered along with it from master-slave, slave-master, slave-slave), etc.
- use some kind of ping mechanism so that the Master is automatically "knows" when a slave is dead and take appropriate actions(send task to another slave, e-mail tech department, etc.)
- Master CAN NOT execute task -- it needs only to assign tasks to slaves and communicate with them
- if you try hard enough you can also make the slaves "know" when the Master has a failure and another "free of task" slave can take it's place
- you will have to use a very fast interpreter

What do we get out of this?! well some of you know that you can buy good old Pentium 4 computers at 2.x-3 Ghz with 512 mb or 1 GB RAM for ~$ 100) -- WAIT!! so I can have 10 cores at $ 1.000?!?! yup...
You can also use implement this in such a away that you can use virtually any OS -- YES you can have 2 slaves on Windows 2000, 5 slaves on Windows XP, 20 slaves on Linux, 8 slaves on OSX, etc.
Sooo... the "hardcore" system can have a lot of slaves, running on multiple platforms AND you can always ADD more slaves on the network, OK but where's the drawback, I know there must be at least one -- yes there are plenty, but it basically depends on the developer(s):
- the system can take anywhere between a few seconds to a few minutes(depending on the initialization implementation -- needs to be ran at the beginning of the program execution) -- this can be tunned!!
- you will have to take care of the synchronization -- it's normal in a multithreaded environment
- if master dies the whole program progress can be lost -- this depends entirely on the implementation of the "main executor" or Mr. X ;-)
- you also need to take into consideration each system's configuration -- depending on this you can execute small tasks on Pentium 3 systems and others on P4 or i3/5/7's

As you can see the most important piece of the puzzle is the developer's skills.

But sometimes you need tens of thousands of computers -- WHAT can you do then?!
We all know that there are hundreds of millions of computers out there that are used only for Internet browsing, multimedia download, how can we use that to our advantage?! well a lot of hackers and companies uses/d zombie computers by uploading torrent clients and or multimedia programs for users to freely download and use, but while a lot of computers spend hours a day just downloading, the CPU and a lot of memory is available to be freely used legally or illegally depending on the EULA they provided with the software.
Take Skype for example, it uses your CPU and bandwidth in order to provide you with "free" service:
4.1 Permission to utilize Your computer. In order to receive the benefits provided by the Skype Software, You hereby grant permission for the Skype Software to utilize the processor and bandwidth of Your computer for the limited purpose of facilitating the communication between Skype Software users.

4.2 Protection of Your computer (resources). You understand that the Skype Software will use its commercially reasonable efforts to protect the privacy and integrity of Your computer resources and Your communication, however, You acknowledge and agree that Skype cannot give any warranties in this respect.

You hereby grant permission for the Skype Software to utilize the processor and bandwidth of Your computer for the limited purpose of facilitating the communication between Skype Software users.
This is a legal way of using your system, however others are JUST using your system because you got some illegal software from a torrent or warez website and you can't really complain about this in court, if you know what I mean -- it's your full responsibility.

As a Delphi/Pascal developer, what can you use in order to target as many platforms as you can and implement this? HELLO?!?! Freepascal and Lazarus is a good starting point and DO NOT forget that as a developer you should NOT be limited to a single programming language, you can also use C++ and/or Java as well if you implement your protocol flexible enough!!

Friday, November 5, 2010

DGTV: IdHTTPServer

A new video tutorial is available, in this tutorial I'm explaining how to create a very basic HTTP server application, please watch it in HD for best experience, any comments are welcomed.
Part 1


Part 2

Wednesday, November 3, 2010

DGTV: VirtualStringTree

I've created my first Delphi video tutorial which covers the basic use of VirtualStringTree component, please see it @ 720p for best experience.
Leave comments of what subject should I cover in a future video.

Tuesday, November 2, 2010

Delphi 2010 or XE?!

OK, so we had a Delphi 2010 release and a couple of months later a Delphi XE(cool name huh?) release, your confused, what's the logic behind that? no cross platform, no 64 bit compiler nothing new actually besides the XE suffix, some IDE fixes and some light versions of third party tools.
All this still doesn't make sense... let's try a different approach: we know that the end goal of a company is to maximize their profits right?! if they have released Delphi 2010 without the IDE glitches it would have taken them a few months more to release Delphi 2010, that means that they would have "lost" money, what they(management) choose to do is release a Delphi 2010(I really hate this kind of names with suffix "year of release" sounds really gay!!) and after the IDE fixes a new version would be released(in this case XE) — sweet, the only problem is that people who have already purchased 2010 version have spent some money on a product which is NOT, I REPEAT NOT really good for big projects which involves thousands and thousands of lines of code — takes way too many freaking minutes or tens of minutes to build in order to test.
Does now make sense?! of course it does, but if your a customer, you're not "so" happy about this approach, Visual Studio has better releases as I've seen the last couple of years — this really bugs me!!
When I've tested XE(for a couple of minutes), I've seen faster IDE, less glitches, overall XE is a bit better than 2010, the only issue is that you have to spend more freaking money, what was my response to this?! invested $ 1.000 in a i7, memory and a good mother board — why?! well.. instead of giving them a couple of hundred Euros for something they should have giving in the 2010 release, I've upgraded my system which is a 2 years investment at least and give them s**t. Delphi 2010 runs smoothly now, I got a faster system, Intel, ASUS and Kingston got some money from me, problem solved!
---
Now I know what some of you might say: if you're a developer who makes money out of this, why NOT buy the latest releases since it's just a few hundred Euros/Dollars?! well the response is simple, while a company tries to maximize their profits, you as a developer(in this case customer) need to minimize your expenses — learn from your clients!!

Friday, October 22, 2010

Sooo you got your first milion, now what?!

Let's just say that you just won € 1.7 mil. in lottery(tax free). What would you do with that much money in the current economy state?!
There are lots of things you can do with it, but the million euro question is: What's the best thing you can do with it, for you and MAYBE for others as well.
Let's just list a few possibilities:
- quit the job and waste the money;
- give the money to homeless people and help them start a fresh new life;
- give it to charity;
- start your own company(what kind of company, most of you that read this blog are developers, would you start a software company or do you think you can squeeze more money in other fields?!);
- buy the company in which you currently work(I'm sure it applies to many of you out there);
- buy a bigger house, bigger car, lots of bling-blings and biaches(I'm sure some of you want that -smile-);
- hold on to the money since there's no certain future coming;
- keep the money until pension, waste it then;
The above list is just off the top of my head — I disagree with at least half of the list — BUT I'm curious what other people would do with that much money.

No matter what you would do, consider this: money come and go, you're current job(if applies) is most likely pretty steady, you should take a deep breath before starting to think about how would you spend it and on what.
P.S. Don't forget, you also lose money(inflation which is a pretty big percent, let's say about 2%/year in Germany's or USA's case) by keeping it „safe¯ with each year.

Thursday, October 14, 2010

Message dialogs: you're doing it wrong...

No matter what you say or think, end-users are beasts, they will always find a way to make their life more complicated instead of reading messages or instructions...
I'm pretty sure AT least once in your life you pressed the wrong button on a message dialog, because you „thought¯ you know what it will ask you OR because you was in a hurry...
The main problem with the end-user is that (s)he will do this most of the times, let's suppose that you're asking the user if (s)he is sure to wipe a file or discard changes that are very important to him/her, even if the user should be blamed because (s)he didn't read the message, you're still the one that will be sweared.
So what can we do to overcome such a situation?! well not much without stressing the user BUT we can use a timed message dialog with which the user cannot interact for a amount of time — this will probably force the user to read the freaking message!
So here's my implementation of a timed message dialog:
unit uTimedMessageDlg;

interface

uses
  SysUtils,
  Windows,
  Classes,
  Forms,
  Dialogs,
  Controls,
  ExtCtrls;

const
  CDEFAULT_WAIT_SEC = 10;
  CSECOND = 1000;
  CTIMED_MESSAGE = '%s (%d seconds)';

type
  TTimedMessageDlg = class(TObject)
  private
    FTimer: TTimer;
    FSeconds: Cardinal;
    FMessageForm: TForm;
    FCountDown: Integer;
    FCaption: string;
    procedure OnTimer(Sender: TObject);
    procedure OnDialogShow(Sender: TObject);
  public
    constructor Create;
    destructor Destroy; override;
  public
    function DisplayDialog(const Msg: string; const Args: array of const;
      DlgType: TMsgDlgType; Buttons: TMsgDlgButtons;
      const SecondsToWait: Cardinal = 10): Integer;
  public
    property Seconds: Cardinal
      read FSeconds write FSeconds;
  end;
  
function TimedMessageDlg(const Msg: string; const Args: array of const ;
  DlgType: TMsgDlgType; Buttons: TMsgDlgButtons;
  const SecondsToWait: Cardinal): Integer;

implementation

{ TTimedMessageDlg }

constructor TTimedMessageDlg.Create;
begin
  FTimer := TTimer.Create(NIL);
  FTimer.Enabled := False;
  FTimer.Interval := 1000;
  FTimer.OnTimer := OnTimer;
  FSeconds := 10;
end;

function TTimedMessageDlg.DisplayDialog(const Msg: string;
  const Args: array of const;
  DlgType: TMsgDlgType; Buttons: TMsgDlgButtons;
  const SecondsToWait: Cardinal = 10): Integer;
begin
  FMessageForm := CreateMessageDialog(Format(Msg, Args), DlgType, Buttons);
  FMessageForm.OnShow := OnDialogShow;
  FCountDown := SecondsToWait -1;
  FCaption := FMessageForm.Caption;
  FMessageForm.Caption := Format(CTIMED_MESSAGE, [FCaption, FCountDown]);
  FTimer.Interval := 1000;
  FTimer.Enabled := True;
  Result := FMessageForm.ShowModal;
  FreeAndNil(FMessageForm);
end;

destructor TTimedMessageDlg.Destroy;
begin
  FreeAndNil(FTimer);
  inherited;
end;

procedure TTimedMessageDlg.OnTimer(Sender: TObject);
begin
  Dec(FCountDown);
  FMessageForm.Caption := Format(CTIMED_MESSAGE, [FCaption, FCountDown]);
  if FCountDown <= 0 then begin
    FMessageForm.Caption := FCaption;
    FTimer.Enabled := False;
    FMessageForm.Enabled := True;
  end; // if FCountDown <= 0 then begin
end;

procedure TTimedMessageDlg.OnDialogShow(Sender: TObject);
begin
  FMessageForm.Enabled := False;
end;

function TimedMessageDlg(const Msg: string; const Args: array of const ;
  DlgType: TMsgDlgType; Buttons: TMsgDlgButtons;
  const SecondsToWait: Cardinal): Integer;
var
  TimedMessage: TTimedMessageDlg;
begin
  TimedMessage := TTimedMessageDlg.Create;
  Result := TimedMessage.DisplayDialog(Msg, Args, DlgType, Buttons,
    SecondsToWait);
  FreeAndNil(TimedMessage);
end;

end.
Sooo... what's the difference between normal and this custom message dialog?! nothing much, just that it can also format your message if you wish to AND the user cannot close or press any button on the message for the specified amount of time — I suggest to keep the time-out value somewhere between 3 to 7 seconds max.

Tuesday, October 12, 2010

Fun with callbacks and progress form

Some time ago I needed to display a progress form in order to give feedback to the user on current state of the task, therefore the „challenge¯ is pretty simple: a secondary form that will have a label — to display some info on current task — and two progress bars — for visual feedback — 1 progress bar for the „overall progress¯ and the other one for „current progress¯, this means that we have a task which is composed of few steps and each step has it's own progress.
Sooo... the MAIN idea is that the progress form needs to be displayed as modal while also calling a method(procedure) from another unit — this is where callbacks come into play.
What are callbacks?!

A callback is a reference to executable code, or a piece of executable code, that is passed as an argument to other code. This allows a lower-level software layer to call a subroutine (or function) defined in a higher-level layer.
For a better understanding of this article click this text to download the source code.
Let's achieve the same thing in a new project:
- add a button to this form
- add a new form to this application, remove it from auto-create forms(Project->Options->Forms)
- add two labels and two progress bars to the second form
- set the caption of one label to „Overall progress¯ and to the other label „Current progress¯
- name one progress bar „pbOverall¯ and the other „pbCurrent¯
Now let's write some code, first define the callback method as
type
  TProgressCallback = procedure (InProgressOverall, InProgressCurrent: TProgressBar) of Object;
we will pass „pbOverall¯ and „pbCurrent¯ as parameters in the callback method.
It's time to define a generic method that will create a new instance of our progress form in order to display a modal progress
procedure ShowProgress(InCallback: TProgressCallback);
var
  LWindowList: TTaskWindowList;
  LSaveFocusState: TFocusState;
  LProgressForm: TfrmProgressForm;
begin
  // create the instance
  LProgressForm := TfrmProgressForm.Create(NIL);
  try
    // save the focus state
    LSaveFocusState := SaveFocusState;
    // save the focused form
    Screen.SaveFocusedList.Insert(0, Screen.FocusedForm);
    // notify that a form will be displayed as modal
    Application.ModalStarted;
    // disable all other forms
    LWindowList := DisableTaskWindows(0);
    // set the progress form instance as the screen focused form 
    Screen.FocusedForm := LProgressForm;
    // send a active message
    SendMessage(LProgressForm.Handle, CM_ACTIVATE, 0, 0);
    // show the form
    LProgressForm.Show;
    // InCallback is our callback method to which we pass pbOverall and pbCurrent
    // as parameters so we can play with them later
    InCallback(LProgressForm.pbOverall, LProgressForm.pbCurrent);
    // after the callback is executed enable windows
    EnableTaskWindows(LWindowList);
    // restore focus state
    RestoreFocusState(LSaveFocusState);
  finally
    // notify that we're leaving a modal state
    Application.ModalFinished;
    // free and nil the progress form instance
    FreeAndNil(LProgressForm);
  end;
end;
all we have left to do now is to define a (private or public)method in main form with same parameters as the callback method like so:
type
  TForm1 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    // this is our callback method
    procedure ProgressCallback(InProgressOverall, InProgressCurrent: TProgressBar);
  public
    { Public declarations }
  end;
in the implementation section copy-paste this code
procedure TForm1.ProgressCallback(InProgressOverall,
  InProgressCurrent: TProgressBar);
var
  Index: Integer;
  kIndex: Integer;
begin
  MessageDlg('Press OK to start a long task...', mtInformation, [mbOK], 0);
  // 10 steps
  InProgressOverall.Max := 10;
  // 3000 updates per step
  InProgressCurrent.Max := 3000;
  for Index := 1 to InProgressOverall.Max do begin
    for kIndex := 1 to InProgressCurrent.Max do begin
      InProgressCurrent.Position := kIndex;
      // force application to process messages
      Application.ProcessMessages;
    end; // for kIndex := 1 to InProgressCurrent.Max do begin
    InProgressOverall.Position := Index;
    // force application to process messages
    Application.ProcessMessages;
  end; // for Index := 1 to InProgressOverall.Max do begin
  MessageDlg('Task completed!', mtInformation, [mbOK], 0);
end;
on the main form you have a button, in it's OnClick event add the following code:
ShowProgress(Self.ProgressCallback);
Any ideas on how to achieve the same effect in less code or more elegant?! please leave comment.

Tuesday, September 28, 2010

How to save a report as PDF to a stream with FastReport

Recently I needed to save a report to a stream as PDF, I'm using FastReport for my reports.
I've searched a lot for a way to do this, but unfortunately I only found comments like „you can't export a report to a stream in PDF format with FastReport¯ and similar comments... so I started browsing the source code of the PDF exporter and 2 minutes later I saw that the exporter checks if property „Stream¯ is assigned, otherwise it will create a TFileStream instance using the report's „FileName¯ property — therefore assigning a TStream descendant to PDFExporter.Stream will make the exporter write the PDF data to THAT stream in stead of the file, without further chit-chat, let's see some code:
I took „PrintStringList¯ example from the Demo folder and modified it to show you how it's done, I've added a new button on the form and a save dialog, in the OnClick event of the button I've added the following code:
procedure TForm1.Button2Click(Sender: TObject);
var
  // we use a file stream for example, but you can replace this
  // with a memory stream or any type of stream which is a
  // descendant of abstract class TStream
  LFileStream: TFileStream;
begin
  // allow the user to choose a file name
  if SaveDialog1.Execute then begin
    // create the file stream object
    LFileStream := TFileStream.Create(SaveDialog1.FileName, fmCreate or fmShareDenyNone);
    try
      // set the range properties
      StringDS.RangeEnd := reCount;
      StringDS.RangeEndCount := sl.Count;
      // THIS IS THE MAGIC
      // assign the stream for the TfrxPDFExport component
      frxPDFExport1.Stream := LFileStream;
      // prepare the report
      frxReport1.PrepareReport(True);
      // export calls the PDFExport component in this case
      frxReport1.Export(frxPDFExport1);
    finally
      // free the file stream object
      FreeAndNil(LFileStream);
      // NIL reference to the stream
      frxPDFExport1.Stream := NIL;
    end; // tryf
  end; // if SaveDialog1.Execute then begin
end;
NOTE: you need FastReport installed!!
You can download the entire project source code by clicking on this text.

Sunday, September 19, 2010

File/Stream compression/decompression class

Tired of searching for zip libraries just to compress/decompress a file/stream?!
Why not use zlib shipped with Delphi?! it's lightweight, super fast, very good compression and above all it's very easy to use!!
( uDGCompressor.pas )
unit uDGCompressor;

interface

//  Author: Dorin Duminica
//
//  Scope: file/stream compression/decompression and encryption/decryption
//
//  License: free for commercial or private use

uses
  SysUtils,
  Windows,
  Classes,
  zlib;

const
  CKILO_BYTE = 1024;
  //  default buffer //
  CBUFFER_SIZE = 35 * CKILO_BYTE;

//  cipher base class //
//  the child classes will HAVE to implement the Encrypt/Decrypt  //
//  methods based on the parameters defined bellow  //
type
  TDGCipherBase = class(TObject)
  public
    procedure EncryptData(const InData: Pointer; const InSize: Integer;
      out OutData: Pointer; out OutSize: Integer); virtual; abstract;
    procedure DecryptData(const InData: Pointer; const InSize: Integer;
      out OutData: Pointer; out OutSize: Integer); virtual; abstract;
  end;

//  before each compressed block the following structure will be written  //
type
  TDGBlockDesc = record
    //  initial size of the block, before compresstion  //
    InitialSize: Integer;
    //  size of the compressed block in stream  //
    Size: Integer;
  end; // TDGBlockDesc = record

const
  szDGBlockDesc = SizeOf(TDGBlockDesc);

type
  //  each time a block of data is processed  //
  TDGProgressEvent = procedure (const Progress, ProgressMax: Integer) of Object;

  //  before/after compress/decompress events //
  TDGCompressorEvent = procedure (const InFileName, OutFileName: string;
    const InSize, OutSize: Int64) of Object;

  //  when a block's decompressed size is different than initial size //
  //  this type of event will be fired if assigned  //
  TDGDecompressFailEvent = procedure (const BlockDesc: TDGBlockDesc;
    const InBuffer, OutBuffer: Pointer; const InSize, OutSize: Integer) of Object;

//  the compress/decompress class //s
type
  TDGCompressor = class(TObject)
  private
    FInStreamSize: Int64;
    FOutStreamSize: Int64;
    FBufferSize: Integer;
    FCipher: TDGCipherBase;
    FOnProgress: TDGProgressEvent;
    FOnAfterCompress: TDGCompressorEvent;
    FOnBeforeCompress: TDGCompressorEvent;
    FOnAfterDecompress: TDGCompressorEvent;
    FOnBeforeDecompress: TDGCompressorEvent;
    FOnDecompressFail: TDGDecompressFailEvent;
  public
    constructor Create;
  public
    procedure CompressFile(const InFileName, OutFileName: string);
    procedure DecompressFile(const InFileName, OutFileName: string);
    procedure CompressStream(const InStream, OutStream: TStream);
    procedure DecompressStream(const InStream, OutStream: TStream);
  published
    //  properties  //
    property BufferSize: Integer read FBufferSize write FBufferSize;
    property Cipher: TDGCipherBase read FCipher write FCipher;
    property InStreamSize: Int64 read FInStreamSize;
    property OutStreamSize: Int64 read FOutStreamSize;
    //  events  //
    property OnAfterCompress: TDGCompressorEvent read FOnAfterCompress write FOnAfterCompress;
    property OnBeforeCompress: TDGCompressorEvent read FOnBeforeCompress write FOnBeforeCompress;
    property OnAfterDecompress: TDGCompressorEvent read FOnAfterDecompress write FOnAfterDecompress;
    property OnBeforeDecompresss: TDGCompressorEvent read FOnBeforeDecompress write FOnBeforeDecompress;
    property OnDecompressFail: TDGDecompressFailEvent read FOnDecompressFail write FOnDecompressFail;
    property OnProgress: TDGProgressEvent read FOnProgress write FOnProgress;
  end;

implementation

{ TDGCompressor }

procedure TDGCompressor.CompressFile(const InFileName, OutFileName: string);
var
  LInFileStream: TFileStream;
  LOutFileStream: TFileStream;
begin
  //  create TFileStream instances  //
  LInFileStream := TFileStream.Create(InFileName, fmOpenRead or fmShareDenyNone);
  LOutFileStream := TFileStream.Create(OutFileName, fmCreate or fmShareDenyNone);
  //  set the position of LInFileStream to the begining
  LInFileStream.Position := 0;
  //  call OnBeforeCompress event if assigned //
  if Assigned(FOnBeforeCompress) then
    FOnBeforeCompress(InFileName, OutFileName, LInFileStream.Size, LOutFileStream.Size);
  try
    //  attempt to compress stream  //
    CompressStream(LInFileStream, LOutFileStream);
  finally
    //  free objects  //
    FreeAndNil(LInFileStream);
    FreeAndNil(LOutFileStream);
  end; // tryf
  //  call OnAfterCompress event if assigned  //
  if Assigned(FOnAfterCompress) then
    FOnAfterCompress(InFileName, OutFileName, LInFileStream.Size, LOutFileStream.Size);
end;

procedure TDGCompressor.CompressStream(const InStream, OutStream: TStream);

    function ThereAreBytes: Boolean;
    begin
      Result := (InStream.Position < InStream.Size) and
        ((InStream.Size - InStream.Position) > 0);
    end; // function ThereAreBytes: Boolean;

var
  LInBuffer: Pointer;
  LOutBuffer: Pointer;
  LWriteBuffer: Pointer;
  LBlockDesc: TDGBlockDesc;
  LProgress: Integer;
  LWriteSize: Integer;
  LReadBytes: Integer;
  LProgressMax: Integer;
  LCompressedSize: Integer;
begin
  //  store the size of the InStream
  FInStreamSize := InStream.Size;
  //  allocate memory for the read buffer //
  LInBuffer := AllocMem(BufferSize);
  //  initalize progress  //
  LProgress := 0;
  //  set the max progress  //
  LProgressMax := InStream.Size;
  //  while we have bytes in InStream that are not compressed //
  while ThereAreBytes do begin
    //  attempt to read the BufferSize number of bytes from InStream  //
    LReadBytes := InStream.Read(LInBuffer^, BufferSize);
    //  compress the read bytes based on LReadBytes variable which holds
    //  the actual number of read bytes from InStream
    ZCompress(LInBuffer, LReadBytes, LOutBuffer, LCompressedSize);
    //  if we don't have a cipher assigned
    if NOT Assigned(FCipher) then begin
      //  set the reference to LOutBuffer
      LWriteBuffer := LOutBuffer;
      //  copy the size of the buffer
      LWriteSize := LCompressedSize;
    end else
      //  we have a cipher assigned, this means that we need to
      //  call the default EncryptData method which will encrypt our
      //  compressed data
      FCipher.EncryptData(LOutBuffer, LCompressedSize, LWriteBuffer, LWriteSize);
    //  set the inital size of the block, we check it on decompress
    LBlockDesc.InitialSize := LReadBytes;
    //  set the number of bytes that we have compressed and/or encrypted
    LBlockDesc.Size := LWriteSize;
    //  write the block descriptor
    OutStream.WriteBuffer(LBlockDesc, szDGBlockDesc);
    //  write the block data
    OutStream.WriteBuffer(LWriteBuffer^, LWriteSize);
    //  free memory from LOutBuffer
    FreeMem(LOutBuffer);
    //  free memory from LWriteBuffer only if a cipher is assigned
    if Assigned(FCipher) then
      FreeMem(LWriteBuffer);
    //  increment the progress by the number of read bytes
    Inc(LProgress, LReadBytes);
    // update the size of the OutStream
    FOutStreamSize := OutStream.Size;
    //  if the OnProgress event is assigned then call it by passing
    //  the current progress and the maximum progress
    if Assigned(FOnProgress) then
      FOnProgress(LProgress, LProgressMax);
  end; // while ThereAreBytes do begin
  //  free memory from LInBuffer
  FreeMem(LInBuffer, BufferSize);
end;

constructor TDGCompressor.Create;
begin
  //  initialize default values //
  FBufferSize := CBUFFER_SIZE;
  FInStreamSize := 0;
  FOutStreamSize := 0;
end;

procedure TDGCompressor.DecompressFile(const InFileName, OutFileName: string);
var
  LInFileStream: TFileStream;
  LOutFileStream: TFileStream;
begin
  //  create TFileStream instances  //
  LInFileStream := TFileStream.Create(InFileName, fmOpenRead or fmShareDenyNone);
  LOutFileStream := TFileStream.Create(OutFileName, fmCreate or fmShareDenyNone);
  //  call OnBeforeDecompress event if assigned //
  if Assigned(FOnBeforeDecompress) then
    FOnBeforeDecompress(InFileName, OutFileName, LInFileStream.Size, LOutFileStream.Size);
  //  attempt to decompress stream  //
  try
    DecompressStream(LInFileStream, LOutFileStream);
  finally
    //  free objects  //
    FreeAndNil(LInFileStream);
    FreeAndNil(LOutFileStream);
  end; // tryf
  //  call OnAfterDecompress event if assigned  //
  if Assigned(FOnAfterDecompress) then
    FOnAfterDecompress(InFileName, OutFileName, LInFileStream.Size, LOutFileStream.Size);
end;

procedure TDGCompressor.DecompressStream(const InStream, OutStream: TStream);

    function ThereAreBytes: Boolean;
    begin
      Result := (InStream.Position < InStream.Size) and
        ((InStream.Size - InStream.Position) > 0);
    end; // function ThereAreBytes: Boolean;

var
  LInBuffer: Pointer;
  LOutBuffer: Pointer;
  LWriteBuffer: Pointer;
  LBlockDesc: TDGBlockDesc;
  LProgress: Integer;
  LWriteSize: Integer;
  LReadBytes: Integer;
  LProgressMax: Integer;
  LDecompressedSize: Integer;
begin
  //  store the size of the InStream
  FInStreamSize := InStream.Size;
  //  allocate memory for the read buffer //
  LInBuffer := AllocMem(BufferSize);
  //  initalize progress  //
  LProgress := 0;
  //  set the max progress  //
  LProgressMax := InStream.Size;
  //  while we have bytes in InStream ... //
  while ThereAreBytes do begin
    //  read the block descriptor from stream
    InStream.ReadBuffer(LBlockDesc, szDGBlockDesc);
    //  attempt to read the number of bytes in the block descriptor
    LReadBytes := InStream.Read(LInBuffer^, LBlockDesc.Size);
    //  if we don't have a cipher assigned  ///
    if NOT Assigned(FCipher) then begin
      //  decompress the buffer //
      ZDecompress(LInBuffer, LReadBytes, LOutBuffer, LDecompressedSize);
      //  set reference to LOutBuffer //
      LWriteBuffer := LOutBuffer;
      //  copy the number of bytes  //
      LWriteSize := LDecompressedSize;
    end else begin
      //  we have a cipher assigned, we first decrypt data  //
      FCipher.DecryptData(LInBuffer, LReadBytes, LOutBuffer, LDecompressedSize);
      //  and then decompress it  //
      ZDecompress(LOutBuffer, LDecompressedSize, LWriteBuffer, LWriteSize);
    end; // if NOT Assigned(FCipher) then begin
    //  check if initial size is equal to current (decrypted and) decompressed size //
    if LBlockDesc.InitialSize <> LWriteSize then
      if Assigned(FOnDecompressFail) then
        FOnDecompressFail(LBlockDesc, LInBuffer, LWriteBuffer, LReadBytes, LWriteSize);
    OutStream.WriteBuffer(LWriteBuffer^, LWriteSize);
    FreeMem(LOutBuffer);
    if Assigned(FCipher) then
      FreeMem(LWriteBuffer);
    Inc(LProgress, LReadBytes + szDGBlockDesc);
    //  update the size of the OutStream
    FOutStreamSize := OutStream.Size;
    //  if the OnProgress event is assigned then call it by passing
    //  the current progress and the maximum progress
    if Assigned(FOnProgress) then
      FOnProgress(LProgress, LProgressMax);
  end; // while ThereAreBytes do begin
  //  free memory from LInBuffer
  FreeMem(LInBuffer, BufferSize);
end;

end.

You can download:
- only the source code
- source code + binary

As always any comments are welcomed.

Thursday, September 9, 2010

Delphigeist group is available on Facebook

I've been thinking of creating Delphigeist group on Facebook so here's the link http://www.facebook.com/group.php?gid=159341794080763

Custom Client-Server application with Delphi 2010 and Indy 10


I'm pretty sure you've tried and failed at least one time to implement a custom protocol with Indy, am I right?! of course you did...
I'm glad I caught your attention, now let's start creating our client-server application using Indy.
In order to implement a protocol we need to think what we want to achieve, therefore we need to define the protocol commands so that the client can communicate with server and vice-versa.
Create a new unit and save it as "uDGProtocol.pas"
We define the commands as
type
  TCommand = (
    cmdConnect,
    cmdDisconnect,
    cmdMessageBroadcast,
    cmdMessagePrivate,
    cmdScreenShotGet,
    cmdScreenShotData);
Now we need to define the client information holder, basically a structure which holds the client user name & a ID
type
  TClient = record
    UserName: string[50];
    ID: TDateTime;
  end; // TClient = record
The protocol will be defined as a structure which contains the following members: "Command", "Sender", "Receiver" and "DataSize"
type
  TProtocol = record
    // the command
    Command: TCommand;
    // sender information
    Sender: TClient;
    // receiver
    Receiver: TClient;
    // additional data
    DataSize: Integer;
  end; // TProtocol = record
TIdTCPServer has a event called "OnExecute"(we use this event to process commands) which passes a parameter called "AContext" of type "TIdContext" we will define our custom client context which will do most of the work for us
type
  TClientContext = class(TIdServerContext)
  private
    // we use critical section to ensure a single access on the connection
    // at a time
    FCriticalSection: TCriticalSection;
    // client information
    FClient: TClient;
  public
    constructor Create(AConnection: TIdTCPConnection; AYarn: TIdYarn;
      AList: TThreadList = nil); override;
    destructor Destroy; override;
  public
    // enter critical section
    procedure Lock;
    // leave critical section
    procedure Unlock;
    // broadcast a buffer to connected clients
    procedure BroadcastBuffer(const ABuffer: TBytes);
    // send a buffer to a specific client
    procedure SendBuffer(const ABuffer: TBytes; const AReceiverID: TDateTime);
    // send all clients data to this client when he connects
    procedure SendClientList;
  public
    property Client: TClient read FClient write FClient;
  end;
On the client side we need three to define three custom events and a listener thread which will read from the InputBuffer of the TIdTCPClient constantly and whenever we have some data the listener thread will process it and act accordingly
type
  // connect/disconnect event
  TClientStatus = procedure (const AClient: TClient) of Object;

  // on message event
  TClientMessage = procedure (const AClient: TClient; const AMessage: string) of Object;

  // on screen shot receive event
  TClientScreenShot = procedure (const AClient: TClient; AImage: TPngImage) of Object;

// our custom listener thread for the client
type
  TClientThread = class(TThread)
  private
    // the TCP client
    FTCPClient: TIdTCPClient;
    // our client information
    FClient: TClient;
    // temporary client data holder
    FClientSender: TClient;
    // temporary buffer for message or screen shot
    FTempBuffer: TBytes;
    // temporary message holder
    FTempMessage: string;
    // a critical section
    FCriticalSection: TCriticalSection;
    // a client is connected
    FOnClientConnect: TClientStatus;
    // a client is disconnected
    FOnClientDisconnect: TClientStatus;
    // receive a message
    FOnClientMessage: TClientMessage;
    // receive a screen shot
    FOnClientScreenShotGet: TClientScreenShot;
    // procedures that will be executed in synchronization with main thread
    procedure DoClientConnect;
    procedure DoClientDisconnect;
    procedure DoClientMessage;
    procedure DoClientScreenShotSend;
    procedure DoClientScreenShotGet;
  public
    // constructor and destructor
    constructor Create(ATCPClient: TIdTCPClient);
    destructor Destroy; override;
  protected
    procedure Execute; override;
  public
    // enter critical section
    procedure Lock;
    // leave critical section
    procedure Unlock;
    // notify clients that we're connected
    procedure SendConnected;
    // notify clients that we disconnect
    procedure SendDisconnected;
    // broadcast a message
    procedure SendMessageBroadcast(const AMessage: string);
    // send a private message
    procedure SendMessagePrivate(const AReceiver: TClient; const AMessage: string);
    // send a screen shot request to a client
    procedure SendScreenShotReq(const AReceiver: TClient);
  public
    property ClientData: TClient read FClient write FClient;
    // events
    property OnClientConnect: TClientStatus read FOnClientConnect write FOnClientConnect;
    property OnClientDisconnect: TClientStatus read FOnClientDisconnect write FOnClientDisconnect;
    property OnClientMessage: TClientMessage read FOnClientMessage write FOnClientMessage;
    property OnClientScreenShotGet: TClientScreenShot read FOnClientScreenShotGet write FOnClientScreenShotGet;
  end;
Since Indy 10 is writing array of bytes on connection we need to define some helper methods like
// converts the protocol structure to an array of bytes
function ProtocolToBytes(const AProtocol: TProtocol): TBytes;
begin
  // set the length of result to the length of the protocol
  SetLength(Result, szProtocol);
  // move a block of memory from AProtocol to Result
  Move(AProtocol, Result[0], szProtocol);
end;

// converts a array of bytes to our protocol
function BytesToProtocol(const ABytes: TBytes): TProtocol;
begin
  // move a block of memory from ABytes to Result
  Move(ABytes[0], Result, szProtocol);
end;

// fills the memory with zero
procedure InitProtocol(var AProtocol: TProtocol);
begin
  FillChar(AProtocol, szProtocol, 0);
end;

// sets the length of the array of bytes to zero
procedure ClearBuffer(var ABuffer: TBytes);
begin
  // set the length to zero
  SetLength(ABuffer, 0);
end;
In the implementation section of "uDGProtocol.pas" unit we implement TClientContext class
{ TClientContext }

procedure TClientContext.BroadcastBuffer(const ABuffer: TBytes);
var
  // loop variable
  Index: Integer;
  // client list, holds TClientContext objects
  LClients: TList;
  // temporary client context reference
  LClientContext: TClientContext;
begin
  // lock the client list
  LClients := FContextList.LockList;
  try
    // for each client
    for Index := 0 to LClients.Count -1 do begin
      // store locally the current client in the list
      LClientContext := TClientContext(LClients[Index]);
      // lock it
      LClientContext.Lock;
      try
        // write the buffer
        LClientContext.Connection.IOHandler.Write(ABuffer);
      finally
        // unlock
        LClientContext.Unlock;
      end; // tryf
    end; // for Index := 0 to LClients.Count -1 do begin
  finally
    // unlock client list
    FContextList.UnlockList;
  end; // tryf
end;

constructor TClientContext.Create(AConnection: TIdTCPConnection; AYarn: TIdYarn;
  AList: TThreadList);
begin
  inherited Create(AConnection, AYarn, AList);
  // create the critical section
  FCriticalSection := TCriticalSection.Create;
end;

destructor TClientContext.Destroy;
begin
  // free and nil critical section
  FreeAndNil(FCriticalSection);
  inherited;
end;

procedure TClientContext.Lock;
begin
  FCriticalSection.Enter;
end;

procedure TClientContext.SendBuffer(const ABuffer: TBytes;
  const AReceiverID: TDateTime);
var
  // loop variable
  Index: Integer;
  // client list, holds TClientContext objects
  LClients: TList;
  // temporary client context reference
  LClientContext: TClientContext;
begin
  // lock client list
  LClients := FContextList.LockList;
  try
    // search for the target client by ID
    for Index := 0 to LClients.Count -1 do begin
      LClientContext := TClientContext(LClients[Index]);
      if LClientContext.Client.ID = AReceiverID then begin
        // we found our target client, lock it
        LClientContext.Lock;
        try
          // write the buffer
          LClientContext.Connection.IOHandler.Write(ABuffer);
        finally
          // unlock client
          LClientContext.Unlock;
        end; // tryf
        // break loop, we've found our target client
        Break;
      end; // if LClientContext.Client.ID = AReceiverID then begin
    end; // for Index := 0 to LClients.Count -1 do begin
  finally
    // unlock client list
    FContextList.UnlockList;
  end; // tryf
end;

procedure TClientContext.SendClientList;
var
  // loop variable
  Index: Integer;
  // a buffer
  LBuffer: TBytes;
  // client list
  LClients: TList;
  // protocol structure
  LProtocol: TProtocol;
  // temporary client context reference
  LClientContext: TClientContext;
begin
  // clear the protocol structure
  InitProtocol(LProtocol);
  // set command
  LProtocol.Command := cmdConnect;
  // lock client list
  LClients := FContextList.LockList;
  try
    // for each connected client
    for Index := 0 to LClients.Count -1 do begin
      // store it temporarly
      LClientContext := TClientContext(LClients[Index]);
      // if the client is not this client
      if LClientContext.Client.ID <> Self.Client.ID then begin
        // set the sender
        LProtocol.Sender := LClientContext.Client;
        // covert protocol to array of bytes
        LBuffer := ProtocolToBytes(LProtocol);
        Lock;
        try
          // write the buffer
          Self.Connection.IOHandler.Write(LBuffer);
        finally
          Unlock;
        end; // tryf
      end;
    end; // for Index := 0 to LClients.Count -1 do begin
  finally
    // unlock client list
    FContextList.UnlockList;
    ClearBuffer(LBuffer);
  end; // tryf
end;

procedure TClientContext.Unlock;
begin
  FCriticalSection.Leave;
end;
and the listener thread
{ TClientThread }

constructor TClientThread.Create(ATCPClient: TIdTCPClient);
begin
  // set reference to the TCP client
  FTCPClient := ATCPClient;
  // create a critical section instance
  FCriticalSection := TCriticalSection.Create;
  inherited Create(True);
end;

destructor TClientThread.Destroy;
begin
  // free and nil the critical section
  FreeAndNil(FCriticalSection);
  // clear the temporary message
  FTempMessage := '';
  inherited;
end;

procedure TClientThread.DoClientConnect;
begin
  // check if the event is assign
  if Assigned(FOnClientConnect) then
    // call it
    FOnClientConnect(FClientSender);
end;

procedure TClientThread.DoClientDisconnect;
begin
  // check if the event is assign
  if Assigned(FOnClientDisconnect) then
    // call it
    FOnClientDisconnect(FClientSender);
end;

procedure TClientThread.DoClientMessage;
begin
  // check if the event is assign
  if Assigned(FOnClientMessage) then
    // call it
    FOnClientMessage(FClientSender, FTempMessage);
end;

procedure TClientThread.DoClientScreenShotGet;
var
  // temporary memory stream
  LStream: TMemoryStream;
  // we send, receive PNG images
  LPngImage: TPngImage;
begin
  // create a memory strema instance
  LStream := TMemoryStream.Create;
  // create a png image instance
  LPngImage := TPngImage.Create;
  Lock;
  try
    // the screen shot is saved in FTempBuffer, write it to stream
    LStream.Write(FTempBuffer[0], Length(FTempBuffer));
    // reset the position of the stream to the begining
    LStream.Position := 0;
    // load the png image from the stream
    LPngImage.LoadFromStream(LStream);
    // if the event is assigned
    if Assigned(FOnClientScreenShotGet) then
      // call it
      FOnClientScreenShotGet(FClientSender, LPngImage);
  finally
    Unlock;
    FreeAndNil(LStream);
    FreeAndNil(LPngImage);
    ClearBuffer(FTempBuffer);
  end; // tryf
end;

procedure TClientThread.DoClientScreenShotSend;
var
  LBuffer: TBytes;
  // screen shot holder
  LBitmap: TBitmap;
  // the protocol
  LProtocol: TProtocol;
  // in memory bytes stream
  LBytesStream: TBytesStream;
  // the png image, we assign LBitmap to LPngImage so we send less data
  LPngImage: TPngImage;
  // handle to the desktop canvas
  LDesktopCanvasHandle: HDC;
begin
  // fill protocol variable with zero's
  InitProtocol(LProtocol);
  // set the command
  LProtocol.Command := cmdScreenShotData;
  // set the sender
  LProtocol.Sender := FClient;
  // set the receiver, the client who requested the screen shot
  LProtocol.Receiver := FClientSender;
  // create object instances
  LBitmap := TBitmap.Create;
  LPngImage := TPngImage.Create;
  LBytesStream := TBytesStream.Create;
  Lock;
  try
    // get handle to desktop canvas
    LDesktopCanvasHandle := GetWindowDC(GetDesktopWindow);
    // set the bitmap height and width
    LBitmap.Height := Screen.Height;
    LBitmap.Width := Screen.Width;
    // copy the screen data from desktop to LBitmap
    BitBlt(
      LBitmap.Canvas.Handle,
      0, 0,
      Screen.Width, Screen.Height,
      LDesktopCanvasHandle,
      0, 0,
      SRCCOPY);
    // convert from bitmap to png image
    LPngImage.Assign(LBitmap);
    // save the png image to stream
    LPngImage.SaveToStream(LBytesStream);
    // set the data size in protocol structure
    LProtocol.DataSize := LBytesStream.Size;
    // convert protocol to array of bytes
    LBuffer := ProtocolToBytes(LProtocol);
    // increase the size of the buffer to  + 
    SetLength(LBuffer, szProtocol + LProtocol.DataSize);
    // move screen shot data from the stream to the buffer that we send
    Move(LBytesStream.Bytes[0], LBuffer[szProtocol], LProtocol.DataSize);
    // send buffer to the server
    FTCPClient.IOHandler.Write(LBuffer);
  finally
    Unlock;
    ClearBuffer(LBuffer);
    FreeAndNil(LBitmap);
    FreeAndNil(LPngImage);
    FreeAndNil(LBytesStream);
  end; // tryf
end;

procedure TClientThread.Execute;
var
  LBuffer: TBytes;
  LMessage: TBytes;
  LDataSize: Integer;
  LProtocol: TProtocol;
begin
  inherited;
  // while the thread is not terminated and the client is connected
  while NOT Terminated and FTCPClient.Connected do begin
    // store the size of the InputBuffer in LDataSize
    LDataSize := FTCPClient.IOHandler.InputBuffer.Size;
    // if we have some data in the InputBuffer, at least the size of the Protocol structure
    if LDataSize >= szProtocol then
      try
        // then read from InputBuffer the size of the protocol structure
        FTCPClient.IOHandler.ReadBytes(LBuffer, szProtocol);
        // convert array of bytes to protocol
        LProtocol := BytesToProtocol(LBuffer);
        // store the sender to private variable
        FClientSender := LProtocol.Sender;
        // check the command
        case LProtocol.Command of
          cmdConnect: begin
            // sync with main thread
            Synchronize(Self.DoClientConnect);
          end; // cmdConnect: begin
          cmdDisconnect: begin
            // sync with main thread
            Synchronize(Self.DoClientDisconnect);
          end; // cmdDisconnect: begin
          cmdMessageBroadcast, cmdMessagePrivate: begin
            // when we get a message after the protoocl we also get additional
            // data which is the message in this case
            // read the message data, the size of the message is in LProtocol.DataSize
            FTCPClient.IOHandler.ReadBytes(LMessage, LProtocol.DataSize);
            // decompress the message and store it in private variable
            FTempMessage := ZDecompressStr(LMessage);
            // sync with main thread
            Synchronize(Self.DoClientMessage);
          end; // cmdMessageBroadcast, cmdMessagePrivate: begin
          cmdScreenShotGet: begin
            // a client requested a screen shot
            // sync with main thread
            Synchronize(Self.DoClientScreenShotSend);
          end; // cmdScreenShotGet: begin
          cmdScreenShotData: begin
            // we received a screen shot on request
            // read the screen shot data
            FTCPClient.IOHandler.ReadBytes(FTempBuffer, LProtocol.DataSize);
            // sync with main thread
            Synchronize(Self.DoClientScreenShotGet);
          end; // cmdScreenShotData: begin
        end; // case LProtocol.Command of
      finally
        // clear buffer and message
        ClearBuffer(LBuffer);
        ClearBuffer(LMessage);
      end; // tryf
    // we needs to call Sleep so that this thread will not eat too much CPU
    // 50 miliseconds should be perfect
    // NOTE: we do NOT lose data, we just create a small latency
    Sleep(50);
  end; // while NOT Terminated and FTCPClient.Connected do begin
end;

procedure TClientThread.Lock;
begin
  FCriticalSection.Enter;
end;

procedure TClientThread.SendConnected;
var
  LBuffer: TBytes;
  LProtocol: TProtocol;
begin
  // fill protocol memory with zero's
  InitProtocol(LProtocol);
  // set the command
  LProtocol.Command := cmdConnect;
  // set the sender
  LProtocol.Sender := FClient;
  // convert protocol to array of bytes
  LBuffer := ProtocolToBytes(LProtocol);
  Lock;
  try
    // send command to server
    FTCPClient.IOHandler.Write(LBuffer);
  finally
    Unlock;
    ClearBuffer(LBuffer);
  end; // tryf
end;

procedure TClientThread.SendDisconnected;
var
  LBuffer: TBytes;
  LProtocol: TProtocol;
begin
  // fill protocol memory with zero's
  InitProtocol(LProtocol);
  // set the command
  LProtocol.Command := cmdDisconnect;
  // set the sender
  LProtocol.Sender := FClient;
  // convert protocol to array of bytes
  LBuffer := ProtocolToBytes(LProtocol);
  Lock;
  try
    // send command to server
    FTCPClient.IOHandler.Write(LBuffer);
  finally
    Unlock;
    ClearBuffer(LBuffer);
  end; // tryf
end;

procedure TClientThread.SendMessageBroadcast(const AMessage: string);
var
  LBuffer: TBytes;
  LProtocol: TProtocol;
  LMessage: TBytes;
begin
  // fill protocol memory with zero's
  InitProtocol(LProtocol);
  // compress the message
  LMessage := ZCompressStr(AMessage);
  // set the command
  LProtocol.Command := cmdMessageBroadcast;
  // set the sender
  LProtocol.Sender := FClient;
  // set the DataSize to the number of bytes that the message contains
  LProtocol.DataSize := Length(LMessage);
  // convert protocol to bytes
  LBuffer := ProtocolToBytes(LProtocol);
  // set the length of the buffer to  + 
  SetLength(LBuffer, szProtocol + LProtocol.DataSize);
  // move message to buffer
  Move(LMessage[0], LBuffer[szProtocol], LProtocol.DataSize);
  Lock;
  try
    // send message to server
    FTCPClient.IOHandler.Write(LBuffer);
  finally
    Unlock;
    ClearBuffer(LBuffer);
    ClearBuffer(LMessage);
  end; // tryf
end;

procedure TClientThread.SendMessagePrivate(const AReceiver: TClient;
  const AMessage: string);
var
  LBuffer: TBytes;
  LProtocol: TProtocol;
  LMessage: TBytes;
begin
  // fill protocol memory with zero's
  InitProtocol(LProtocol);
  // compress the message
  LMessage := ZCompressStr(AMessage);
  // set the command
  LProtocol.Command := cmdMessagePrivate;
  // set the sender
  LProtocol.Sender := FClient;
  // set the receiver
  LProtocol.Receiver := AReceiver;
  // set the DataSize to the number of bytes the message contains
  LProtocol.DataSize := Length(LMessage);
  // convert protocol to bytes
  LBuffer := ProtocolToBytes(LProtocol);
  // set the length of the buffer to  + 
  SetLength(LBuffer, szProtocol + LProtocol.DataSize);
  // move message to buffer
  Move(LMessage[0], LBuffer[szProtocol], LProtocol.DataSize);
  Lock;
  try
    // send message to server
    FTCPClient.IOHandler.Write(LBuffer);
  finally
    Unlock;
    ClearBuffer(LBuffer);
    ClearBuffer(LMessage);
  end; // tryf
end;

procedure TClientThread.SendScreenShotReq(const AReceiver: TClient);
var
  LBuffer: TBytes;
  LProtocol: TProtocol;
begin
  // fill protocol memory with zero's
  InitProtocol(LProtocol);
  // set the command
  LProtocol.Command := cmdScreenShotGet;
  // set the sender
  LProtocol.Sender := FClient;
  // set the receiver
  LProtocol.Receiver := AReceiver;
  // convert protocol to bytes
  LBuffer := ProtocolToBytes(LProtocol);
  Lock;
  try
    // send request to server
    FTCPClient.IOHandler.Write(LBuffer);
  finally
    Unlock;
    ClearBuffer(LBuffer);
  end; // tryf
end;

procedure TClientThread.Unlock;
begin
  FCriticalSection.Leave;
end;
In the "OnExecute" event of the TIdTCPServer component we need to handle client requests like so
procedure TfrmMain.ServerExecute(AContext: TIdContext);
var
  // temporary buffer
  LBuffer: TBytes;
  // temporary message buffer
  LMessageBuffer: TBytes;
  // data size in InputBuffer
  LDataSize: Integer;
  // protocol structure
  LProtocol: TProtocol;
  // we need to HARD CAST AContext to TClientContext
  // in order to access our custom methods(procedures)
  LClientContext: TClientContext;
begin
  // hard cast AContext to TClientContext
  LClientContext := TClientContext(AContext);
  // store the size of the InputBuffer of the client
  LDataSize := LClientContext.Connection.IOHandler.InputBuffer.Size;
  // in order to prevent spams or to make sure that we have at least
  // the protocol structure sent we check the size of the InputBuffer
  if LDataSize >= szProtocol then
    try
      // read the protocol structure from the client so we can handle
      // the client's request
      LClientContext.Connection.IOHandler.ReadBytes(LBuffer, szProtocol);
      // convert the buffer to protocol structure
      LProtocol := BytesToProtocol(LBuffer);
      // check client command and act accordingly
      case LProtocol.Command of
        cmdConnect: begin
          // the client just connected
          AddFmtLog(' %s', [LProtocol.Sender.UserName]);
          // set the client information in client context
          LClientContext.Client := LProtocol.Sender;
          // send the client list to this client so he knows who's connected
          LClientContext.SendClientList;
          // notify other clients that this client is connected
          LClientContext.BroadcastBuffer(LBuffer);
        end; // cmdConnect: begin
        cmdDisconnect: begin
          // client is disconnecting
          AddFmtLog(' %s', [LProtocol.Sender.UserName]);
          // notify other clients that this client is diconnecting
          LClientContext.BroadcastBuffer(LBuffer);
        end; // cmdDisconnect: begin
        cmdMessageBroadcast: begin
          // client is broadcasting a message
          // read the message from the sender client, the size of the mssages is
          // stored in DataSize member of the protocol structure
          LClientContext.Connection.IOHandler.ReadBytes(LBuffer, LProtocol.DataSize);
          // set the length of the temporary message buffer
          SetLength(LMessageBuffer, LProtocol.DataSize);
          // move the message data from the buffer to message buffer
          Move(LBuffer[szProtocol], LMessageBuffer[0], LProtocol.DataSize);
          AddFmtLog('<%s> %s', [
            LProtocol.Sender.UserName,
            ZDecompressStr(LMessageBuffer)]);
          // broadcast the message
          LClientContext.BroadcastBuffer(LBuffer);
        end; // cmdMessageBroadcast: begin
        cmdMessagePrivate: begin
          // client is sending a private message
          // read the message from the sender client
          LClientContext.Connection.IOHandler.ReadBytes(LBuffer, LProtocol.DataSize);
          // set the length of the temporary message buffer
          SetLength(LMessageBuffer, LProtocol.DataSize);
          // move the message data from the buffer to message buffer
          Move(LBuffer[szProtocol], LMessageBuffer[0], LProtocol.DataSize);
          AddFmtLog(' %s> %s', [
            LProtocol.Sender.UserName,
            LProtocol.Receiver.UserName,
            ZDecompressStr(LMessageBuffer)]);
          // send the message to the receiver client
          LClientContext.SendBuffer(LBuffer, LProtocol.Receiver.ID);
        end; // cmdMessagePrivate: begin
        cmdScreenShotGet: begin
          // client is requesting a screen shot
          AddFmtLog(' %s from %s', [
            LProtocol.Sender.UserName,
            LProtocol.Receiver.UserName]);
          // forward the request to target client
          LClientContext.SendBuffer(LBuffer, LProtocol.Receiver.ID);
        end; // cmdScreenShotGet: begin
        cmdScreenShotData: begin
          // client is sending screen shot data to the client that requested
          // read the screen shot data from the sender client
          LClientContext.Connection.IOHandler.ReadBytes(LBuffer, LProtocol.DataSize);
          AddFmtLog(' %s to %s', [
            (LProtocol.DataSize / 1024),
            LProtocol.Sender.UserName,
            LProtocol.Receiver.UserName]);
          // forward the screen shot data to the target client
          LClientContext.SendBuffer(LBuffer, LProtocol.Receiver.ID);
        end; // cmdScreenShotData: begin
      end; // case LProtocol.Command of
    finally
      ClearBuffer(LBuffer);
      ClearBuffer(LMessageBuffer);
    end; // tryf
end;
In the form's "OnCreate" event you needs to set the context class of the server to our custom TClientContext so that the server will create our client context instance when a client is connected
procedure TfrmMain.FormCreate(Sender: TObject);
begin
  Server.ContextClass := TClientContext;
end;
The above code is just a overview of the application and protocol implementation, if your curious to see the rest of the code and test the application then
- get the source code
- get the source code + binary
Any comments highly appreciated.

Monday, September 6, 2010

OSD component

I bet a lot of you guys needed at least one time a OSD(On screen display) component and you searched for hours and eventually created one yourself or dumped the idea... well here's my OSD implementation
—Copy-Paste and save as uOnScreenDisplay.pas—
unit uOnScreenDisplay;

// Author Dorin Duminica
// Free to use for personal and/or commercial purpose

interface

uses
  Windows,
  SysUtils,
  Messages,
  Classes,
  Graphics,
  StdCtrls,
  ExtCtrls,
  Controls,
  Forms;

type
  TOnScreenDisplay = class(TComponent)
  private
    FOSDForm: TForm;
    FOSDText: TLabel;
    FTimer: TTimer;
    FOnShow: TNotifyEvent;
    FOnHide: TNotifyEvent;
    procedure OnTimer(Sender: TObject);
    function GetHeight: Integer;
    procedure SetHeight(const Value: Integer);
    function GetFont: TFont;
    procedure SetFont(const Value: TFont);
    function GetColor: TColor;
    procedure SetColor(const Value: TColor);
    function GetOnHide: TNotifyEvent;
    function GetOnShow: TNotifyEvent;
    procedure SetOnHide(const Value: TNotifyEvent);
    procedure SetOnShow(const Value: TNotifyEvent);
    function GetAlphaBlendValue: Byte;
    procedure SetAlphaBlendValue(const Value: Byte);
  public
    constructor Create;
    destructor Destroy; override;
  public
    function OSDForm: TForm;
    function OSDText: TLabel;
    procedure Show(const AMessage: string; const TimeOut: Cardinal = 2500);
    procedure ShowFmt(const AMessage: string; const Args: array of const;
      const TimeOut: Cardinal = 2500);
  published
    property AlphaBlendValue: Byte read GetAlphaBlendValue write SetAlphaBlendValue;
    property Color: TColor read GetColor write SetColor;
    property Height: Integer read GetHeight write SetHeight;
    property Font: TFont read GetFont write SetFont;
    // events
    property OnShow: TNotifyEvent read GetOnShow write SetOnShow;
    property OnHide: TNotifyEvent read GetOnHide write SetOnHide;
  end;

var
  GlobalOSD: TOnScreenDisplay;

implementation

{ TOnScreenDisplay }

constructor TOnScreenDisplay.Create;
begin
  // OSDForm
  FOSDForm := TForm.Create(NIL);
  FOSDForm.AlphaBlend := True;
  FOSDForm.AlphaBlendValue := 150;
  FOSDForm.Color := clBlack;
  FOSDForm.Align := alTop;
  FOSDForm.Height := 55;
  FOSDForm.BorderStyle := bsNone;
  FOSDForm.FormStyle := fsStayOnTop;
  SetWindowLong(FOSDForm.Handle, GWL_EXSTYLE, WS_EX_TRANSPARENT or WS_EX_LAYERED);
  // if AlphaBlending is not available uncomment the next line
  // SetLayeredWindowAttributes(FOSDForm.Handle, 0, 150{transparent value}, LWA_ALPHA);
  // OSDText
  FOSDText := TLabel.Create(FOSDForm);
  FOSDText.Parent := FOSDForm;
  FOSDText.Align := alClient;
  FOSDText.AlignWithMargins := True;
  FOSDText.Margins.SetBounds(10, 10, 10, 10);
  FOSDText.Font.Size := 20;
  FOSDText.Font.Name := 'Verdana';
  FOSDText.Font.Style := [fsBold];
  FOSDText.Font.Color := clInfoBk;
  FOSDText.Alignment := taCenter;
  FOSDText.WordWrap := True;
  // timer
  FTimer := TTimer.Create(FOSDForm);
  FTimer.Enabled := False;
  FTimer.OnTimer := Self.OnTimer;
end;

destructor TOnScreenDisplay.Destroy;
begin
  FreeAndNil(FOSDForm);
  inherited;
end;

function TOnScreenDisplay.GetAlphaBlendValue: Byte;
begin
  Result := FOSDForm.AlphaBlendValue;
end;

function TOnScreenDisplay.GetColor: TColor;
begin
  Result := FOSDForm.Color;
end;

function TOnScreenDisplay.GetFont: TFont;
begin
  Result := FOSDText.Font;
end;

function TOnScreenDisplay.GetHeight: Integer;
begin
  Result := FOSDForm.Height;
end;

function TOnScreenDisplay.GetOnHide: TNotifyEvent;
begin
  Result := FOSDForm.OnHide;
end;

function TOnScreenDisplay.GetOnShow: TNotifyEvent;
begin
  Result := FOSDForm.OnShow;
end;

procedure TOnScreenDisplay.OnTimer(Sender: TObject);
begin
  FTimer.Enabled := False;
  FOSDForm.Close;
end;

function TOnScreenDisplay.OSDForm: TForm;
begin
  Result := FOSDForm;
end;

function TOnScreenDisplay.OSDText: TLabel;
begin
  Result := FOSDText;
end;

procedure TOnScreenDisplay.SetAlphaBlendValue(const Value: Byte);
begin
  FOSDForm.AlphaBlendValue := Value;
end;

procedure TOnScreenDisplay.SetColor(const Value: TColor);
begin
  FOSDForm.Color := Value;
end;

procedure TOnScreenDisplay.SetFont(const Value: TFont);
begin
  FOSDText.Font := Value;
end;

procedure TOnScreenDisplay.SetHeight(const Value: Integer);
begin
  FOSDForm.Height := Value;
end;

procedure TOnScreenDisplay.SetOnHide(const Value: TNotifyEvent);
begin
  FOSDForm.OnHide := Value;
end;

procedure TOnScreenDisplay.SetOnShow(const Value: TNotifyEvent);
begin
  FOSDForm.OnShow := Value;
end;

procedure TOnScreenDisplay.Show(const AMessage: string; const TimeOut: Cardinal);
begin
  FTimer.Enabled := False;
  FOSDText.Caption := AMessage;
  FTimer.Interval := TimeOut;
  FTimer.Enabled := True;
  FOSDForm.Show;
end;

procedure TOnScreenDisplay.ShowFmt(const AMessage: string;
  const Args: array of const; const TimeOut: Cardinal);
begin
  Show(Format(AMessage, Args), TimeOut);
end;

initialization
  GlobalOSD := TOnScreenDisplay.Create;

finalization
  FreeAndNil(GlobalOSD);

end.
If you wish you can register the component into the IDE, but I really don't see any need for that, your choice...

Usage: GlobalOSD.Show('I love delphigeist!!', 4000);
the message will be displayed for 4 seconds on the screen.

NOTE: If you call GlobalOSD.Show before the previous OSD message disappears then the text will be changed and the Time out timer will be reseted.

Sunday, August 15, 2010

Generic method to invoke a save dialog

There are many times when you need to invoke a Save dialog(TSaveDialog) and more likely you do NOT wish to add another component on the form... here's what I came up with:
(add "Dialogs" to uses clause)
function SaveFileExecute(const Filter: string;
  var FileName: string): Boolean;
var
  SaveDialog: TSaveDialog;
  // variable used to let us know that the user is intending to save
  // it will cover the "Overwrite file" prompt
  bExecuted: Boolean;
  // label used to retry the save process
label
  lRetry;
begin
// label!!
lRetry:
  // initialize variable and result
  bExecuted := False;
  Result := False;
  // create a TSaveDialog instance
  SaveDialog := TSaveDialog.Create(NIL);
  try
    // set the filter
    SaveDialog.Filter := Filter;
    // execute the dialog
    Result := SaveDialog.Execute;
    // store the result
    bExecuted := Result;
    if Result then begin
      // set the file name WARNING it's a OUT VARIABLE
      FileName := SaveDialog.FileName;
      // check if the user tries to overwrite file
      if FileExists(FileName) then
        // user is attempting to overwrite a file, prompt with
        // Yes, No and Cancel, some users feel more comfortable to click Cancel
        Result := (MessageDlg(
          Format('File "%s" already exists, overwrite?', [FileName]),
          mtConfirmation, mbYesNoCancel, 0) = mrYes);
    end; // if Result then begin
  finally
    // free allocated memory
    FreeAndNil(SaveDialog);
  end; // tryf
  if (NOT Result) and bExecuted then
    // user selected No or Cancel in file overwrite, restart the process
    goto lRetry;
end;

Thursday, August 5, 2010

Create ambient color

There are times when you have to display charts with statistical data such as year to date sales, quarter sales, etc.
That's fine until your chart data changes every X period of time, let's say each 5 minutes, in this case the customer needs to somehow know that from last time he saw the statistical information has changed(or refreshed), you can do this by changing the background color of the chart, does not really matter if you choose to make the background gradient(it will look better tho) or not.
Changing the background color will make the user know the data has been changed(refreshed) without him having to think about it(the power of mind...).
We create a array of web colors because most users surf the web daily and they are very familiar with this colors...

Add Graphics and Math to uses clause, add Randomize to initialization section, copy-paste the following code:
const
  CAMBIENT_COLORS: array[0..WebColorsCount -1] of TColor = (
    clWebSnow, clWebFloralWhite, clWebLavenderBlush, clWebOldLace,
    clWebIvory, clWebCornSilk, clWebBeige, clWebAntiqueWhite,
    clWebWheat, clWebAliceBlue, clWebGhostWhite, clWebLavender,
    clWebSeashell, clWebLightYellow, clWebPapayaWhip, clWebNavajoWhite,
    clWebMoccasin, clWebBurlywood, clWebAzure, clWebMintcream,
    clWebHoneydew, clWebLinen, clWebLemonChiffon, clWebBlanchedAlmond,
    clWebBisque, clWebPeachPuff, clWebTan, clWebYellow,
    clWebDarkOrange, clWebRed, clWebDarkRed, clWebMaroon,
    clWebIndianRed, clWebSalmon, clWebCoral, clWebGold,
    clWebTomato, clWebCrimson, clWebBrown, clWebChocolate,
    clWebSandyBrown, clWebLightSalmon, clWebLightCoral, clWebOrange,
    clWebOrangeRed, clWebFirebrick, clWebSaddleBrown, clWebSienna,
    clWebPeru, clWebDarkSalmon, clWebRosyBrown, clWebPaleGoldenrod,
    clWebLightGoldenrodYellow, clWebOlive, clWebForestGreen, clWebGreenYellow,
    clWebChartreuse, clWebLightGreen, clWebAquamarine, clWebSeaGreen,
    clWebGoldenRod, clWebKhaki, clWebOliveDrab, clWebGreen,
    clWebYellowGreen, clWebLawnGreen, clWebPaleGreen, clWebMediumAquamarine,
    clWebMediumSeaGreen, clWebDarkGoldenRod, clWebDarkKhaki, clWebDarkOliveGreen,
    clWebDarkgreen, clWebLimeGreen, clWebLime, clWebSpringGreen,
    clWebMediumSpringGreen, clWebDarkSeaGreen, clWebLightSeaGreen, clWebPaleTurquoise,
    clWebLightCyan, clWebLightBlue, clWebLightSkyBlue, clWebCornFlowerBlue,
    clWebDarkBlue, clWebIndigo, clWebMediumTurquoise, clWebTurquoise,
    clWebCyan, clWebAqua, clWebPowderBlue, clWebSkyBlue,
    clWebRoyalBlue, clWebMediumBlue, clWebMidnightBlue, clWebDarkTurquoise,
    clWebCadetBlue, clWebDarkCyan, clWebTeal, clWebDeepskyBlue,
    clWebDodgerBlue, clWebBlue, clWebNavy, clWebDarkViolet,
    clWebDarkOrchid, clWebMagenta, clWebFuchsia, clWebDarkMagenta,
    clWebMediumVioletRed, clWebPaleVioletRed, clWebBlueViolet, clWebMediumOrchid,
    clWebMediumPurple, clWebPurple, clWebDeepPink, clWebLightPink,
    clWebViolet, clWebOrchid, clWebPlum, clWebThistle,
    clWebHotPink, clWebPink, clWebLightSteelBlue, clWebMediumSlateBlue,
    clWebLightSlateGray, clWebWhite, clWebLightgrey, clWebGray,
    clWebSteelBlue, clWebSlateBlue, clWebSlateGray, clWebWhiteSmoke,
    clWebSilver, clWebDimGray, clWebMistyRose, clWebDarkSlateBlue,
    clWebDarkSlategray, clWebGainsboro, clWebDarkGray, clWebBlack
  );

function GetAmbientRandomColor: TColor;

    // makes the color lighter by Percent
   // the higher the value of Percent the closer to white
    function LighterColor(Color: TColor; Percent: Byte): TColor;
    var
      vRed: Byte;
      vGreen: Byte;
      vBlue: Byte;
    begin
      Color := ColorToRGB(Color);
      vRed := GetRValue(Color);
      vGreen := GetGValue(Color);
      vBlue := GetBValue(Color);
      vRed := vRed + MulDiv(255 - vRed, Percent, 100);
      vGreen := vGreen + MulDiv(255 - vGreen, Percent, 100);
      vBlue := vBlue + MulDiv(255 - vBlue, Percent, 100);
      // generate the LighterColor color
      Result := RGB(vRed, vGreen, vBlue);
    end; // function LighterColor(Color: TColor; Percent: Byte): TColor;

var
  Index: Integer;
begin
  // generate a random Index
  Index := RandomRange(Low(CAMBIENT_COLORS), High(CAMBIENT_COLORS));
  Result := LighterColor(CAMBIENT_COLORS[Index], 70);
end;

Monday, August 2, 2010

CREATORS ADMIT UNIX, C HOAX

I always knew there's something fishy related to C/C++, but this is hilarious!
Now here's a interesting article(stolen from: https://forums.embarcadero.com/thread.jspa?threadID=40821):

Was it a parody? If so then maybe this one I've had a copy of for at least
15 years:

CREATORS ADMIT UNIX, C HOAX

In an announcement that has stunned the computer industry, Ken Thompson,
Dennis Ritchie and Brian Kernighan admitted that the Unix operating system
and C programming language created by them is an elaborate prank kept alive
for over 20 years. Speaking at the recent UnixWorld Software Development
Forum, Thompson revealed the following:

"In 1969, AT&T had just terminated their work with the GE/Honeywell/AT&T
Multics project. Brian and I had started work with an early release of
Pascal from Professor Nichlaus Wirth's ETH labs in Switzerland and we were
impressed with its elegant simplicity and power. Dennis had just finished
reading 'Bored of the Rings', a National Lampoon parody of the Tolkien's
'Lord of the Rings' trilogy. As a lark, we decided to do parodies of the
Multics environment and Pascal. Dennis and I were responsible for the
operating environment. We looked at Multics and designed the new OS to be as
complex and cryptic as possible to maximize casual users' frustration
levels, calling it Unix as a parody of Multics, as well as other more risque
allusions. We sold the terse command language to novitiates by telling them
that it saved them typing.

Then Dennis and Brian worked on a warped version of Pascal, called 'A'.

'A' looked a lot like Pascal, but elevated the notion of the direct memory
address (which Wirth had banished) to the central concept of the language.
This was Dennis's contribution, and he in fact coined the term "pointer" as
an innocuous sounding name for a truly malevolent construct. Brian must be
credited with the idea of having absolutely no standard I/O specification:
this ensured that at least 50% of the typical commercial program would have
to be re-coded when changing hardware platforms. Brian was also responsible
for pitching this lack of I/O as a feature: it allowed us to describe the
language as "truly portable".

When we found others were actually creating real programs with A, we removed
compulsory type-checking on function arguments. Later, we added a notion we
called "casting": this allowed the programmer to treat an integer as though
it were a 50kb user-defined structure. When we found that some programmers
were simply not using pointers, we eliminated the ability to pass structures
to functions, enforcing their use in even the simplest applications. We
sold this, and many other features, as enhancements to the efficiency of the
language. In this way, our prank evolved into B, BCPL, and finally C.

We stopped when we got a clean compile on the following syntax:

for(;P("\n"),R-;P("|"))for(e=C;e-;P("_"+(*u++/8)%2))P("| "+(*u/4)%2);

At one time, we joked about selling this to the Soviets to set their
computer science progress back 20 or more years.

Unfortunately, AT&T and other US corporations actually began using Unix and
C. We decided we'd better keep mum, assuming it was just a passing phase.

In fact, it's taken US companies over 20 years to develop enough expertise
to generate useful applications using this 1960's technological parody. We
are impressed with the tenacity of the general Unix and C programmer. In
fact, Brian, Dennis and I have never ourselves attempted to write a
commercial application in this environment.

We feel really guilty about the chaos, confusion and truly awesome
programming projects that have resulted from our silly prank so long ago."

Dennis Ritchie said: "What really tore it (just when AIDA was catching on),
was that Bjarne Stroustrup caught onto our joke. He extended it to further
parody Smalltalk. Like us, he was caught by surprise when nobody laughed.
So he added multiple inheritance, virtual base classes, and later ...
templates. All to no avail. So we now have compilers that can compile
100,000 lines per second, but need to process header files for 25 minutes
before they get to the meat of "Hello, World".

Major Unix and C vendors and customers, including AT&T, Microsoft,
Hewlett-Packard, GTE, NCR, and DEC have refused comment at this time.

Saturday, July 31, 2010

You got 25% chance of success, do you feel lucky?

I remember few years ago playing a game called Silkroad(which stolen 2 years of my life – that's another story), in this game when you do alchemy, in some situations, you have a X percent chance of success, I had a lot of successes but also failures, anyways... I was wondering how do they calculate the success? You can implement an idea in many ways...
This morning I thought of an algorithm that does just that, it returns True or False with a certain percent chance of success.
I've started the theory(in my head...) like so:
- we need a chance resolution(in this case 5%)
- we need to have an array of boolean with the number of elements equal to 100 divided by resolution(5)

Implementation:
- initialize the array of chances to false
- calculate how many 5% chances are there(if you give 20% chance, then we have to set to True 4 elements in ChanceArray
- for each 5% chance set to True a element in ChanceArray that is NOT already set to true, starting at a random index in the array
- pick a random element from the array and return it's state(True or False) as the result of the chance

Here it is, my implementation:
(add "Math" to uses clause)
function CheckSuccess(const PercentChance: Integer): Boolean;
var
  // 5% resolution
  // can give chances like 10%, 50% or 15%, 55%, 35%, etc.
  ChanceArray: array[0..19] of Boolean;
  ChanceCount: Integer;
  ChanceIndex: Integer;
  Index: Integer;

    procedure AddChance;
    begin
      ChanceIndex := RandomRange(Low(ChanceArray), High(ChanceArray));
      while ChanceArray[ChanceIndex] do begin
        Inc(ChanceIndex);
        if ChanceIndex > High(ChanceArray) then
          ChanceIndex := Low(ChanceArray);
      end; // while ChanceArray[ChanceIndex] do begin
      ChanceArray[ChanceIndex] := True;
    end; // procedure AddChance;

begin
  // you should probably call this once per application startup
  Randomize;
  // initialize chance array to false
  for Index := Low(ChanceArray) to High(ChanceArray) do
    ChanceArray[Index] := False;
  // how many 5% chances we got?
  if PercentChance > 100 then
    ChanceCount := 20
  else
    ChanceCount := (PercentChance div 5); // 5% resolution
  for Index := 1 to ChanceCount do
    AddChance;
  ChanceIndex := RandomRange(Low(ChanceArray), High(ChanceArray));
  Result := ChanceArray[ChanceIndex];
end;
Usage:
(we give the player a 25% chance of success – you can increase or decrease chance but replacing 25 with another value)
ShowMessage(BoolToStr(CheckSuccess(25), True));
P.S. Please drop me a comment with how would you implement a similar algorithm.

Friday, July 30, 2010

Delphigeist got a new skin

I've been searching for sometime now for a good blogger template and this is the best I managed to find so far, please let me know if you're happy with the load time of the page and the new layout, thank you.

Wednesday, July 28, 2010

High-Speed Laser Chips Move Data at 50 Gbps

Yes, I know... this is a programming blog, but this is something that you might want to know.
I'm not going to repost the post from wired.com so here's the link High-Speed Laser Chips Move Data at 50 Gbps.

Monday, July 12, 2010

Google App Inventor for Android

Did you know that Google has recently released a beat application called „App Inventor¯?
It allows people with now programming knowledge to develop nice and fast application for the Android platform.
All you need is your mobile phone which runs Android, a PC with Internet connection, a GMail account and some ideas.
Homepage http://appinventor.googlelabs.com

Wednesday, July 7, 2010

How to read/write a string from/to file fast

When I'm debugging large SQL inserts/updates I tend to use the following two functions
const
  szChar = SizeOf(Char);
/// 
///   saves a string to a file
/// 
procedure StringToFile(const s: string; const FileName: string);
var
  FileStream: TFileStream;
begin
  FileStream := TFileStream.Create(FileName, fmCreate);
  try
    FileStream.WriteBuffer(Pointer(s)^, (Length(s) * szChar));
  finally
    FreeAndNil(FileStream);
  end; // try
end;

/// 
///   returns the content of the file as a string
/// 
function StringFromFile(const FileName: string): string;
var
  FileStream: TFileStream;
begin
  FileStream := TFileStream.Create(FileName, fmOpenRead);
  try
    SetLength(Result, (FileStream.Size div szChar));
    FileStream.ReadBuffer(Pointer(Result)^, FileStream.Size);
  finally
    FreeAndNil(FileStream);
  end; // try
end;
this functions are pretty fast and you can easily find other usage for them.

How to capitalize a string

Ever needed to capitalize a string and keep the rest lower case? here's my implementation...
I use this function when the OnExit event is triggered in a edit control – usually in user name/password fields etc.
function CapitalizeString(const s: string; const CapitalizeFirst: Boolean = True): string;
const
  ALLOWEDCHARS = ['a'..'z', '_'];
var
  Index: Integer;
  bCapitalizeNext: Boolean;
begin
  bCapitalizeNext := CapitalizeFirst;
  Result := LowerCase(s);
  if Result <> EmptyStr then
    for Index := 1 to Length(Result) do
      if bCapitalizeNext then begin
        Result[Index] := UpCase(Result[Index]);
        bCapitalizeNext := False;
      end else
      if NOT CharInSet(Result[Index], ALLOWEDCHARS) then
        bCapitalizeNext := True;
end;

Saturday, May 29, 2010

ShellExecute, WinExec failing in Delphi 2010/2009?

Here's a interesting store from which we can learn something, few days ago I've started upgrading projects from Delphi 7 to 2010, the transition was smooth enough, the Delphi team did a pretty good job in making this possible without too much complications, everything is fine until I was getting some errors from applications that where calling external application using ShellExecute/WinExec, I was getting errors from IDE but not if the application is ran without IDE, that's interesting, right?
How to fix it: press F6 from IDE, type "debug spawned" hit Enter(Return) key and un-check "Debug spawned processes", press OK and your done.
Easy huh? but still very problematic if your application depends on other being started and if the third party application is not started, then your application is responsible in starting it.

Monday, April 26, 2010

How to compare two streams byte by byte

If you wish to check for differences between two files but you don't want to "see" them, just to know the percent of differences, here's a utility function that does just that.
function CompareStreams(Stream1, Stream2: TStream): Extended;
type
  TCompareBuffer = array[0..8191] of Byte;

const
  // store the buffer's size
  szCompareBuffer = SizeOf(TCompareBuffer);

var
  // buffer variables, one for each stream
  Buffer1: TCompareBuffer;
  Buffer2: TCompareBuffer;
  // variables that will store the actual read bytes from streams
  ReadBytes1: Integer;
  ReadBytes2: Integer;
  // declare a variable that will store the number of different bytes in streams
  DifferenceCount: Int64;
  // loop variable
  Index: Integer;
  // max difference check loop's per buffer
  MaxCount: Integer;
begin
  // set stream position to 0
  Stream1.Position := 0;
  Stream2.Position := 0;
  // initialize difference count
  DifferenceCount := 0;
  // start a loop
  while True do begin
    // read from both streams
    ReadBytes1 := Stream1.Read(Buffer1, szCompareBuffer);
    ReadBytes2 := Stream2.Read(Buffer2, szCompareBuffer);
    // set the max count to the smaller value of read bytes
    MaxCount := Min(ReadBytes1, ReadBytes2);
    // check differences byte by byte
    for Index := 0 to MaxCount -1 do
      if Buffer1[Index] <> Buffer2[Index] then
        // difference found! increment DifferenceCount variable
        Inc(DifferenceCount);
    // if the number of read bytes from Stream1 is different than the
    // number of read bytes from Stream or we haven't read any bytes from
    // a stream, then break the loop, we're done comparing
    if (ReadBytes1 <> ReadBytes2) or (ReadBytes1 = 0) or (ReadBytes2 = 0) then
      Break;
  end; // while True do begin
  // return the number of differences 
  Result := (DifferenceCount * 100) / Max(Stream1.Size, Stream2.Size);
end;
For a quick and dirty testing, create a new VCL application, drop a open dialog, set the open dialog's options to allow multi select(ofAllowMultiSelect), drop a button on the form, double-click the button and paste this code:
var
  Stream1: TFileStream;
  Stream2: TFileStream;
  Differences: Extended;
begin
  Differences := 0.0000;
  if OpenDialog1.Execute and (OpenDialog1.Files.Count = 2) then
    try
      Stream1 := TFileStream.Create(OpenDialog1.Files[0], fmOpenRead);
      Stream2 := TFileStream.Create(OpenDialog1.Files[1], fmOpenRead);
      Differences := CompareStreams(Stream1, Stream2);
    finally
      FreeAndNil(Stream1);
      FreeAndNil(Stream2);
    end;
  ShowMessageFmt('%.4f', [Differences]);
end;
Now click the button, select two files and wait for the compare to finish.
WARNING: do not open big files i.e. movies or somewhere around/over 700 Mb or you'll spend a few mins waiting for the process to complete.

Tuesday, April 20, 2010

TurboHashedStringList at version 1.2

Thanks to SportsGuy, TurboHashedStringList is updated to version 1.2.
There are two new properties added to the class:
- Objects
- ObjectsByName

here are their definition:
property Objects[Index: Integer]: TObject
      read GetObject write PutObject;
    property ObjectsByName[Name: String; bCaseSensitive: Boolean]: TObject
      read GetObjectByName write PutObjectByName;
and implementation if you wish to update manually:
function TurboHashedStringList.GetObject(Index: Integer): TObject;
begin
  if (Index < 0) or (Index >= Self.Count) then
    Result := NIL;
  Result := PStringRec(FList[Index])^.ObjectRef;
end; // function TurboHashedStringList.GetObject(Index: Integer): TObject;

procedure TurboHashedStringList.PutObject(Index: Integer;
  AObject: TObject);
begin
  if (Index < 0) or (Index >= Self.Count) then
    Exit;
  PStringRec(FList[Index])^.ObjectRef := AObject;
end; // procedure TurboHashedStringList.PutObject(Index: Integer;

function TurboHashedStringList.GetObjectByName(Name: String;
  bCaseSensitive: Boolean): TObject;
var
  Index: Integer;
begin
  Index := IndexOfName(Name, bCaseSensitive);
  if Index >= 0 then
    Result := Objects[Index]
  else
    Result := NIL;
end; // function TurboHashedStringList.GetObjectByName(Name: String;

procedure TurboHashedStringList.PutObjectByName(Name: String;
  bCaseSensitive: Boolean; const Value: TObject);
var
  Index: Integer;
begin
  Index := IndexOfName(Name, bCaseSensitive);
  if Index >= 0 then
    PStringRec(FList[Index])^.ObjectRef := Value;
end; // procedure TurboHashedStringList.PutObjectByName(Name: String;
Alternatively you can download the class as a tiny zip file by clicking on this sentance.

Blogroll(General programming and Delphi feeds)