Friday, December 05, 2008

Windows: Get Reference Count of DLL in a process

Background

Windows Dynamic Link Library (DLL) or Delphi Runtime Package (BPL) are both shared library for Windows OS.  As stated in MSDN:

The system maintains a per-process reference count on all loaded modules. Calling LoadLibrary increments the reference count. Calling the FreeLibrary or FreeLibraryAndExitThread function decrements the reference count. The system unloads a module when its reference count reaches zero or when the process terminates (regardless of the reference count).

If a DLL has been loaded for more than one time, Windows OS doesn't maintain separate copies of DLL image in the OS system.  Only one DLL image is loaded and Windows OS use reference counting strategy to maintain the status.  Once the reference count of a DLL has dropped to zero, the DLL image is completely remove from the process.

A bad news is there isn't any documented Windows API to allow us to retrieve the current reference count of a DLL.

But why I need to know the reference count of a DLL?  It is very rare for us to know this information.  Someone use this technique to kill spyware DLL.

I design my application with runtime packages.  For example, I keep forms in runtime package and load the form from package when I open the form.  The runtime package is not bind to my executable image statically but it will be invoked dynamically via LoadPackage.

I want to achieve these:

  1. The package isn't loaded when there isn't any form instance in the process.
  2. We may instantiate more than one form instance from same package in the process at the same time.
  3. Once all form instances has been destroyed, the runtime package image will remove from the process.

To get it done. I declare an export procedure that return a new form instance everytime it is invoked.  Each form instance created will invoke LoadPackage(HInstance) to increase the reference count.

The most complex part is the 3rd point.  An exception will raise If I invoke UnloadPackage before all code in package has been executed completely.  I not even allow to invoke UnloadPackage in form's destructor.  To overcome this problem, I create an notifier for each form instance.  When the form instance is destroying, it will alert the notifier.  The notifier will send a message using PostMessage to notify a controller to unload the package.  The PostMessage will get execute only when the process is in idle state. This method has work so well.

Until then I encounter a situation where I have this coding:

var i: integer;
    F: TForm;
    H: THandle;
    NewForm: function: TForm;
begin
  H := LoadPackage('MyPackage.bpl');
  @NewForm := GetProcAddress(H, 'NewForm');
  for i := 1 to 10 do begin
    F := NewForm;
    F.Free;
  end;
  UnloadPackage(H);
end;

The above code works fine not until I increase the for loop count to 10000.  I will be prompted

000101c95520$d53ae3d0$_CDOSYS2.0

The reason is simple, each call to F.Free will invoke PostMessage to queue the message to the associated thread of the process.  If I run the above code to 10000 times continuously, the system just doesn't has a free moment to perform the messages in queue.  It will certainly reach a limit until the message prompt out.

I have revise the strategy to overcome such situation but I am not confident enough to state that the new strategy will not having other problems in future.  I use unit testing to write test cases for all known situations, one of the test case will perform 10000 loops and I will then check the reference count of the runtime packages to make sure it falls into a suitable range.

After writing such a long description, I finally manage the deliver the situations I face in words and paragraphs.

Solution

After spending a day digging on Internet about retrieving the reference count of a DLL, I found the solution.  I have coding it in Delphi:

windows.PEB.pas

unit Windows.PEB;

interface

uses Windows{,
     untSttUnhooker}; // WinAPI UnHooker - by StTwister

type
  PNtAnsiString = ^TNtAnsiString;
  TNtAnsiString = packed record
    Length: Word;
    MaximumLength: Word;
    Buffer: PAnsiChar;
  end;

type
  PNtUnicodeString = ^TNtUnicodeString;
  TNtUnicodeString = packed record
    Length: Word;
    MaximumLength: Word;
    Buffer: PWideChar;
  end;

type
  PClientId = ^TClientId;
  TClientId = record
    UniqueProcess: THandle;
    UniqueThread: THandle;
  end;

type
  PCurDir = ^TCurDir;
  TCurDir = packed record
    DosPath: TNtUnicodeString;
    Handle : THandle;
  end;

type
  PRtlDriveLetterCurDir = ^TRtlDriveLetterCurDir;
  TRtlDriveLetterCurDir = packed record
    Flags    : Word;
    Length   : Word;
    TimeStamp: Cardinal;
    DosPath  : TNtAnsiString;
  end;

type
  PRtlUserProcessParameters = ^TRtlUserProcessParameters;
  TRtlUserProcessParameters = record
    MaximumLength    : Cardinal;
    Length           : Cardinal;
    Flags            : Cardinal;
    DebugFlags       : Cardinal;
    ConsoleHandle    : THandle;
    ConsoleFlags     : Cardinal;
    StandardInput    : THandle;
    StandardOutput   : THandle;
    StandardError    : THandle;
    CurrentDirectory : TCurDir;
    DllPath          : TNtUnicodeString;
    ImagePathName    : TNtUnicodeString;
    CommandLine      : TNtUnicodeString;
    Environment      : Pointer;
    StartingX        : Cardinal;
    StartingY        : Cardinal;
    CountX           : Cardinal;
    CountY           : Cardinal;
    CountCharsX      : Cardinal;
    CountCharsY      : Cardinal;
    FillAttribute    : Cardinal;
    WindowFlags      : Cardinal;
    ShowWindowFlags  : Cardinal;
    WindowTitle      : TNtUnicodeString;
    DesktopInfo      : TNtUnicodeString;
    ShellInfo        : TNtUnicodeString;
    RuntimeData      : TNtUnicodeString;
    CurrentDirectores: Array [0..31] of TRtlDriveLetterCurDir;
  end;

type
  PPebFreeBlock = ^TPebFreeBlock;
  TPebFreeBlock = record
    Next: PPebFreeBlock;
    Size: Cardinal;
  end;

type
  PLdrModule = ^TLdrModule;
  TLdrModule = packed record
    InLoadOrderModuleList          : TListEntry;      // 0h
    InMemoryOrderModuleList        : TListEntry;      // 8h
    InInitializationOrderModuleList: TListEntry;      // 10h
    BaseAddress                    : THandle;         // 18h
    EntryPoint                     : THandle;         // 1Ch
    SizeOfImage                    : Cardinal;        // 20h
    FullDllName                    : TNtUnicodeString;// 24h
                                   // Length (2)         24h
                                   // MaximumLength (2)  26h
                                   // Buffer (4)         28h
    BaseDllName                    : TNtUnicodeString;// 2Ch
    Flags                          : ULONG;           // 34h
    LoadCount                      : SHORT;           // 38h
    TlsIndex                       : SHORT;           // 3Ah
    HashTableEntry                 : TListEntry;      // 3Ch
    TimeDataStamp                  : ULONG;           // 44h
  end;

type
  PPebLdrData = ^TPebLdrData;
  TPebLdrData = packed record
    Length                         : Cardinal;        // 0h
    Initialized                    : LongBool;        // 4h
    SsHandle                       : THandle;         // 8h
    InLoadOrderModuleList          : TListEntry;      // 0Ch
    InMemoryOrderModuleList        : TListEntry;      // 14h
    InInitializationOrderModuleList: TListEntry;      // 1Ch
  end;

type
  PPeb = ^TPeb;
  TPeb = packed record
    InheritedAddressSpace         : Boolean;
    ReadImageFileExecOptions      : Boolean;
    BeingDebugged                 : Boolean;
    SpareBool                     : Boolean;
    Mutant                        : Pointer;
    ImageBaseAddress              : Pointer;
    Ldr                           : PPebLdrData;
    ProcessParameters             : PRtlUserProcessParameters;
    SubSystemData                 : Pointer;
    ProcessHeap                   : Pointer;
    FastPebLock                   : Pointer;
    FastPebLockRoutine            : Pointer;
    FastPebUnlockRoutine          : Pointer;
    EnvironmentUpdateCount        : Cardinal;
    KernelCallbackTable           : Pointer;
    case Integer of
      4: (
        EventLogSection           : Pointer;
        EventLog                  : Pointer);
      5: (
        SystemReserved            : Array [0..1] of Cardinal;
  { end; }
    FreeList                      : PPebFreeBlock;
    TlsExpansionCounter           : Cardinal;
    TlsBitmap                     : Pointer;
    TlsBitmapBits                 : Array [0..1] of Cardinal;
    ReadOnlySharedMemoryBase      : Pointer;
    ReadOnlySharedMemoryHeap      : Pointer;
    ReadOnlyStaticServerData      : ^Pointer;
    AnsiCodePageData              : Pointer;
    OemCodePageData               : Pointer;
    UnicodeCaseTableData          : Pointer;
    NumberOfProcessors            : Cardinal;
    NtGlobalFlag                  : Cardinal;
    Unknown                       : Cardinal;
    CriticalSectionTimeout        : TLargeInteger;
    HeapSegmentReserve            : Cardinal;
    HeapSegmentCommit             : Cardinal;
    HeapDeCommitTotalFreeThreshold: Cardinal;
    HeapDeCommitFreeBlockThreshold: Cardinal;
    NumberOfHeaps                 : Cardinal;
    MaximumNumberOfHeaps          : Cardinal;
    ProcessHeaps                  : ^Pointer;
    GdiSharedHandleTable          : Pointer;
    ProcessStarterHelper          : Pointer;
    GdiDCAttributeList            : Cardinal;
    LoaderLock                    : Pointer;
    OSMajorVersion                : Cardinal;
    OSMinorVersion                : Cardinal;
    OSBuildNumber                 : Word;
    OSCSDVersion                  : Word;
    OSPlatformId                  : Cardinal;
    ImageSubsystem                : Cardinal;
    ImageSubsystemMajorVersion    : Cardinal;
    ImageSubsystemMinorVersion    : Cardinal;
    ImageProcessAffinityMask      : Cardinal;
    GdiHandleBuffer               : Array [0..33] of Cardinal;
    PostProcessInitRoutine        : ^Pointer;
    TlsExpansionBitmap            : Pointer;
    TlsExpansionBitmapBits        : Array [0..31] of Cardinal;
    SessionId                     : Cardinal;
    AppCompatInfo                 : Pointer;
    CSDVersion                    : TNtUnicodeString);
  end;

type
  PNtTib = ^TNtTib;
  TNtTib = record
    ExceptionList       : Pointer;  // ^_EXCEPTION_REGISTRATION_RECORD
    StackBase           : Pointer;
    StackLimit          : Pointer;
    SubSystemTib        : Pointer;
    case Integer of
      0: (FiberData     : Pointer);
      1: (Version       : ULONG;
    ArbitraryUserPointer: Pointer;
    Self                : PNtTib);
  end;

type
  PTeb = ^TTeb;
  TTeb = record
    Tib               : TNtTib;
    Environment       : PWideChar;
    ClientId          : TClientId;
    RpcHandle         : THandle;
    ThreadLocalStorage: PPointer;
    Peb               : PPeb;
    LastErrorValue    : DWORD;
  end;

implementation

end.

Windows.ntdll.pas

unit Windows.ntdll;

interface

uses Windows;

const
  ntdll = 'ntdll.dll';

type
  NTSTATUS = LongInt;

  TProcessInfoClass = (
    ProcessBasicInformation, ProcessQuotaLimits,
    ProcessIoCounters, ProcessVmCounters,
    ProcessTimes, ProcessBasePriority, ProcessRaisePriority,
    ProcessDebugPort, ProcessExceptionPort,
    ProcessAccessToken, ProcessLdtInformation,
    ProcessLdtSize, ProcessDefaultHardErrorMode,
    ProcessIoPortHandlers, ProcessPooledUsageAndLimits,
    ProcessWorkingSetWatch, ProcessUserModeIOPL,
    ProcessEnableAlignmentFaultFixup, ProcessPriorityClass,
    ProcessWx86Information, ProcessHandleCount,
    ProcessAffinityMask, ProcessPriorityBoost,
    ProcessDeviceMap, ProcessSessionInformation,
    ProcessForegroundInformation, ProcessWow64Information,
    MaxProcessInfoClass
  );
  PROCESSINFOCLASS = TProcessInfoClass;

  PPROCESS_BASIC_INFORMATION = ^PROCESS_BASIC_INFORMATION;

  PROCESS_BASIC_INFORMATION = packed record
    ExitStatus:         DWORD;
    PebBaseAddress:     Pointer;
    AffinityMask:       DWORD;
    BasePriority:       DWORD;
    UniqueProcessId:    DWORD;
    InheritedUniquePID: DWORD;
  end;

  TZwQueryInformationProcess = function(ProcessHandle: THandle;
                                   ProcessInformationClass: PROCESSINFOCLASS;
                                   var ProcessInformation: PROCESS_BASIC_INFORMATION;
                                   ProcessInformationLength: ULONG;
                                   var ReturnLength: ULONG): NTSTATUS; stdcall;

implementation

end.

WindowsEx.pas

unit WindowsEx;

interface

uses Windows, Windows.PEB;

type
  TProcessModules = class
  private
    FPebLDrData: TPebLdrData;
    FReady: boolean;
    FProcessHandle: THandle;
    FCurrentIndex: Pointer;
    FCurrentModule: TLdrModule;
    procedure CheckReady;
  public
    constructor Create(const aProcessHandle: THandle = 4294967295);
    procedure Reset;
    function HasNext: boolean;
    function CurrentModule: TLdrModule;
  end;

implementation

uses SysUtils, Windows.ntdll;

procedure TProcessModules.CheckReady;
begin
  if not FReady then
    raise Exception.Create('PEB Loader Data is not ready');
end;

constructor TProcessModules.Create(const aProcessHandle: THandle = 4294967295);
var H: THandle;
    Proc: TZwQueryInformationProcess;
    PBI: PROCESS_BASIC_INFORMATION;
    i: ULONG;
    PEB: TPeb;
begin
  FProcessHandle := aProcessHandle;
  if FProcessHandle = THandle(-1) then
    FProcessHandle := GetCurrentProcess;

  H := LoadLibrary(ntdll);
  if H = 0 then RaiseLastOSError;
  try

    @Proc := GetProcAddress(H, 'ZwQueryInformationProcess');
    if @Proc = nil then RaiseLastOSError;

    ZeroMemory(@PBI, SizeOf(PBI));
    FReady := Proc(FProcessHandle, ProcessBasicInformation, PBI, SizeOf(PBI), i) = 0;
    if FReady then begin
      ReadProcessMemory(FProcessHandle, PBI.PebBaseAddress, @PEB, 16, i);
      ReadProcessMemory(FProcessHandle, PEB.Ldr, @FPebLDrData, sizeof(FPebLDrData), i);

      Reset;
    end;
  finally
    FreeLibrary(H);
  end;
end;

function TProcessModules.CurrentModule: TLdrModule;
begin
  Result := FCurrentModule;
end;

function TProcessModules.HasNext: boolean;
var i: ULONG;
begin
  CheckReady;

  Result := ReadProcessMemory(GetCurrentProcess, FCurrentIndex, @FCurrentModule, SizeOf(FCurrentModule), i);
  if Result then begin
    Result := FCurrentModule.BaseAddress <> 0;
    if Result then
      FCurrentIndex := FCurrentModule.InLoadOrderModuleList.Flink;
  end;

  if not Result then
    FCurrentIndex := nil;
end;

procedure TProcessModules.Reset;
begin
  CheckReady;
  ZeroMemory(@FCurrentModule, SizeOf(FCurrentModule));
  FCurrentIndex := FPebLDrData.InLoadOrderModuleList.Flink;
end;

end.

Example:

var Proc: TProcessModules;
    S: string;
begin
  Proc := TProcessModules.Create;
  try
    while Proc.HasNext do begin
      S := Format('%6d : %s', [Proc.CurrentModule.LoadCount, Proc.CurrentModule.FullDllName.Buffer]);
      Memo1.Lines.Add(S);
    end;
  finally
    Proc.Free;
  end;
end;

Reference

  1. 0×04 Reference count of DLL
  2. Reference Count of DLL in a Process

Wednesday, November 12, 2008

Windows: String Comparison and Sorting

The most common sorting style is code point sorting that is culture insensitive.  This type of sorting doesn't respect the radical order of cultural aspect but it is the fastest sorting order.

For example:

Character 'E' has code point 0x45 and character 'a' has code point 0x61. If we compare or sort the character according to code point, 'E' will show before 'a'.  But this contradict to our knowledge that 'a' should always show before 'E'.

Another example is the Chinese character where it's sorting order depending on phonetics or number of pen strokes.  Sort order according to code point doesn't make much sense for Chinese characters.

The following chart show some Chinese characters sorted by unicode code point that is culture insensitive:

Ideograph 汉语拼音
(Phonetic)
笔划
(Key strokes)
Unicode Code Point
yi 1 0x4E00
ding 2 0x4E01
shang 3 0x4E0A
qie 5 0x4E14
ren 2 0x4EBA

We may use Windows API function CompareString to perform comparison for sorting operation.

var L: DWORD;
    R: integer;
    Str1, Str2: string;
begin
  ...
  // For Stroke Count Order
  L := MAKELCID(MAKELANGID(LANG_CHINESE, SUBLANG_CHINESE_SIMPLIFIED), SORT_CHINESE_PRC);
  R := CompareString(L, 0, PChar(Str1), Length(Str1), PChar(Str2), Length(Str2));

  // For Phonetic Order
  L := MAKELCID(MAKELANGID(LANG_CHINESE, SUBLANG_CHINESE_SIMPLIFIED), SORT_CHINESE_PRCP);
  R := CompareString(L, 0, PChar(Str1), Length(Str1), PChar(Str2), Length(Str2));
  ...

  // For Ordinal Comparison (Code point comparison, culture insensitive)
  R := StrComp(PChar(Str1), PChar(Str2));
end;

Stroke Count Order:

Ideograph 汉语拼音
(Phonetic)
笔划
(Key strokes)
Unicode Code Point
yi 1 0x4E00
ding 2 0x4E01
ren 2 0x4EBA
shang 3 0x4E0A
qie 5 0x4E14

Phonetic Order:

Ideograph 汉语拼音
(Phonetic)
笔划
(Key strokes)
Unicode Code Point
ding 2 0x4E01
qie 5 0x4E14
ren 2 0x4EBA
shang 3 0x4E0A
yi 1 0x4E00

Reference:

  1. Sort Order Identifiers
  2. Globalization Step-by-Step
  3. Where is the locale? "Its Invariant." In <i>where</i>?
  4. Comparison confusion: INVARIANT vs. ORDINAL

Saturday, November 08, 2008

Hack into Delphi class

The techniques introduce here against the design of Object Oriented Programming.  As the title implied, OOP rules are not enforce here.  I am hacking into the object and class to access the private or protected fields and methods.  There is only one reason to do so: To patch a buggy class without changing the original source.

Access a protected field

TMyClass = class
protected
  FValue: integer;
end;

The most easy  way to access FValue is write a helper class:

TMyClassHelper = class helper for TMyClass
public
  procedure SetValue(const aValue: integer);
end;

procedure TMyClassHelper.SetValue(const aValue: integer);
begin
  FValue := aValue;
end;

Example:

var o: TMyClass;
begin
  o := TMyClass.Create;
  o.SetValue(100);
end;

Access a private field

type
  TMyClass = class
  strict private
    {$Hint Off} 
    FValue: integer;

    {$Hint On}
  end;

TMyClassAccessor = class
public
  FValue: integer;
end;

Example:

var o: TMyClass;
begin
  o := TMyClass.Create;
  TMyClassAccessor(o).FValue := 100;
  o.Free;
end;

Access a private class var field

This is particularly hard.  My solution only work if the class is compiled into package.

type
  TMyClass = class
  strict private
    class var FValue: integer;
  end;

I found no way to access the static class var.  If you are lucky that the class is compiled into a Delphi package (.bpl), then you are lucky.

  1. Google for any PE Viewer that can view the information of Windows executables files (EXE/DLL/BPL).
  2. Use the PE Viewer to open the Delphi package
  3. Locate the Exports section and search for the exported name for the static class var.  For example: @MyUnit@TMyClass@FValue
  4. Delphi package mangle the name as something like @<unit-name>@<class-name>@<method-name>

Next, you may use GetProcAddress to get the field:

var H: THandle;
    P: PInteger;
begin
  H := LoadPackage('MyPackage.bpl');
  P := GetProcAddress(H,
'@MyUnit@TMyClass@FValue');
  P^ := 1234;
  UnloadPackage(P);
end;

Patching a method in class

Delphi VCL source may have problems or bugs.  A famous solution is to fix the VCL source directly and include the source file into the project.  This is fine if you release your application in single .EXE without using runtime package.

Delphi doesn’t include the project file to build the VCL runtime packages.  We are not able to re-compile VCL runtime packages.

A better solution is using TCodeRedirect class to patch the methods or functions that has problem without changing the VCL source.  You may remove the patch from your project if the problem has fixed in later version of Delphi release.

{$WEAKPACKAGEUNIT ON}
unit CodeRedirect;

interface

type
  TCodeRedirect = class(TObject)
  private
    type
      TInjectRec = packed record
        Jump: Byte;
        Offset: Integer;
      end;

      PWin9xDebugThunk = ^TWin9xDebugThunk;
      TWin9xDebugThunk = packed record
        PUSH: Byte;
        Addr: Pointer;
        JMP: Byte;
        Offset: Integer;
      end;

      PAbsoluteIndirectJmp = ^TAbsoluteIndirectJmp;
      TAbsoluteIndirectJmp = packed record
        OpCode: Word;   //$FF25(Jmp, FF /4)
        Addr: ^Pointer;
      end;
  private
    FSourceProc: Pointer;
    FNewProc: Pointer;
    FInjectRec: TInjectRec;
  public
    constructor Create(const aProc, aNewProc: Pointer);
    procedure BeforeDestruction; override;
    procedure Disable;
    procedure Enable;
    class function GetActualAddr(Proc: Pointer): Pointer;
    class function GetAddressOf(aMethodAddr: pointer; aSignature: array of byte): Pointer;
  end;

implementation

uses SysUtils, Windows;

class function TCodeRedirect.GetActualAddr(Proc: Pointer): Pointer;

  function IsWin9xDebugThunk(AAddr: Pointer): Boolean;
  begin
    Result := (AAddr <> nil) and
              (PWin9xDebugThunk(AAddr).PUSH = $68) and
              (PWin9xDebugThunk(AAddr).JMP = $E9);
  end;

begin
  if Proc <> nil then begin
    if (Win32Platform <> VER_PLATFORM_WIN32_NT) and IsWin9xDebugThunk(Proc) then
      Proc := PWin9xDebugThunk(Proc).Addr;
    if (PAbsoluteIndirectJmp(Proc).OpCode = $25FF) then
      Result := PAbsoluteIndirectJmp(Proc).Addr^
    else
      Result := Proc;
  end else
    Result := nil;
end;

procedure TCodeRedirect.BeforeDestruction;
begin
  inherited;
  Disable;
end;

constructor TCodeRedirect.Create(const aProc, aNewProc: Pointer);
begin
  inherited Create;
  FSourceProc := aProc;
  FNewProc := aNewProc;
  Enable;
end;

procedure TCodeRedirect.Disable;
var n: DWORD;
begin
  if FInjectRec.Jump <> 0 then
    WriteProcessMemory(GetCurrentProcess, GetActualAddr(FSourceProc), @FInjectRec, SizeOf(FInjectRec), n);
end;

procedure TCodeRedirect.Enable;
var OldProtect: Cardinal;
    P: pointer;
begin
  if Assigned(FSourceProc)then begin
    P := GetActualAddr(FSourceProc);
    if VirtualProtect(P, SizeOf(TInjectRec), PAGE_EXECUTE_READWRITE, OldProtect) then begin
      FInjectRec := TInjectRec(P^);
      TInjectRec(P^).Jump := $E9;
      TInjectRec(P^).Offset := Integer(FNewProc) - (Integer(P) + SizeOf(TInjectRec));
      VirtualProtect(P, SizeOf(TInjectRec), OldProtect, @OldProtect);
      FlushInstructionCache(GetCurrentProcess, P, SizeOf(TInjectRec));
    end;
  end;
end;

class function TCodeRedirect.GetAddressOf(aMethodAddr: pointer;
  aSignature: array of byte): Pointer;
var P: PByteArray;
begin
  P := GetActualAddr(aMethodAddr);
  while not CompareMem(P, @aSignature, Length(aSignature)) do
    Inc(PByte(P));
  Result := Pointer(Integer(@P[5]) + PInteger(@P[1])^);
end;

end.

Example: Patching public method

This example shows how to patch a public method TForm.Close.  Assume that TForm.Close has an error and you want to patch it.  Here is a patch:

type
  TFormPatch = class helper for TForm
  public
    procedure ClosePatch;
  end;

procedure TFormPatch.ClosePatch;
var
  CloseAction: TCloseAction;
begin
  ShowMessage('TForm.Close has been patched');

  if fsModal in FFormState then
    ModalResult := mrCancel
  else
    if CloseQuery then
    begin
      if FormStyle = fsMDIChild then
        if biMinimize in BorderIcons then
          CloseAction := caMinimize else
          CloseAction := caNone
      else
        CloseAction := caHide;
      DoClose(CloseAction);
      if CloseAction <> caNone then
        if Application.MainForm = Self then Application.Terminate
        else if CloseAction = caHide then Hide
        else if CloseAction = caMinimize then WindowState := wsMinimized
        else Release;
    end;
end;

var P: TCodeRedirect;

initialization
  P := TCodeRedirect.Create(@TForm.Close, @TForm.ClosePatch);
finalization
  P.Free;
end.

ClosePatch method is a new method to replace Close method.  In this example, I copy from TCustomForm.Close method and add a new line ShowMessage at top.  You are freely to write any code in ClosePatch method.  The initialization and finalization part activate and deactivate the patch respectively.

Once this code has been injected into your project, all code that trigger TForm.Close method will show a message before closing the form.

Example: Patching protected method

Access to protected method is prohibit unless the code is in same unit as the class.  This example attempt to patch a protected method TStringList.GetCount.

TStringListAccess = class(TStringList)
protected
  function GetCountPatch: Integer;
end;

function TStringListAccess.GetCountPatch: Integer;
begin
  Result := 100;
end;

var P: TCodeRedirect;

initialization
  P := TCodeRedirect.Create(@TStringListAccess.GetCount, @TStringListAccess.GetCountPatch);
finalization
  P.Free;
end.

The above example using class inheritance to access protected method GetCount.

If we execute the following code with TStringList.GetCountPatch injected, invoke Count method will always return 100 regardless of how many string has been added into instance s:

var S: TStringList;
begin
  S := TStringList.Create;
  try
    ShowMessage(IntToStr(S.Count));
    S.Add('1');
    ShowMessage(IntToStr(S.Count));
    S.Add('2');
    ShowMessage(IntToStr(S.Count));
  finally
    S.Free;
  end;
end;

Example: Patching private method

Patching a private method requires more effort as private method is not visible by any means unless access it in same unit.  A clue is to find a way to obtain the address of the private method.

The following example shows how to patch a private method TWinControl.UpdateShowing. 

TWinControlPatch = class helper for TWinControl
public
  procedure UpdateShowingPatch;
end;

const
  Controls_6988 : array[boolean, 0..4] of byte = (
    ($E8, $61, $DE, $FF, $FF),
    ($E8, $31, $DD, $FF, $FF)
  );

var P: TCodeRedirect;

initialization
  P := TCodeRedirect.Create(
         TCodeRedirect.GetAddressOf(@TWinControl.SetDesignVisible, Controls_6988[False]),
         @TWinControl.UpdateShowingPatch
       );
finalization
  P.Free;
end.

Firstly, we need to search in source code of the class for code we can access that invoke TWinControl.UpdateShowing. TWinControl.SetDesignVisible is such method that we after:

procedure TWinControl.SetDesignVisible(Value: Boolean);
begin
  if (csDesigning in ComponentState) and (Value <> not (csDesignerHide in ControlState)) then
  begin
    if not Value then
      Include(FControlState, csDesignerHide)
    else
      Exclude(FControlState, csDesignerHide);
    UpdateShowing;
  end;
end;

We then run our application with debugger to track the address of TWinControl.UpdateShowing.  We may set a breakpoint in TWinControl.SetDesignVisible method and view the code in assembly language (Accessed via Delphi IDE: View | Debug Windows | CPU Windows | Entire CPU).

Assembly code of TWinControl.SetDesignVisible for applicationbuilt without runtime packages (Delphi 2007 11.0.2902.10471):

Controls.pas.8006: begin
00443900 53               push ebx
00443901 8BD8             mov ebx,eax
Controls.pas.8007: if (csDesigning in ComponentState) and (Value <> not (csDesignerHide in ControlState)) then
00443903 F6431C10         test byte ptr [ebx+$1c],$10
00443907 7426             jz $0044392f
00443909 F6435508         test byte ptr [ebx+$55],$08
0044390D 0F95C0           setnz al
00443910 3401             xor al,$01
00443912 3AD0             cmp dl,al
00443914 7419             jz $0044392f
Controls.pas.8009: if not Value then
00443916 84D2             test dl,dl
00443918 7508             jnz $00443922
Controls.pas.8010: Include(FControlState, csDesignerHide)
0044391A 66814B540008     or word ptr [ebx+$54],$0800
00443920 EB06             jmp $00443928
Controls.pas.8012: Exclude(FControlState, csDesignerHide);
00443922 66816354FFF7     and word ptr [ebx+$54],$f7ff
Controls.pas.8013: UpdateShowing;
00443928 8BC3             mov eax,ebx
0044392A E861DEFFFF       call TWinControl.UpdateShowing
Controls.pas.8015: end;
0044392F 5B               pop ebx
00443930 C3               ret

The instruction code E861DEFFFF is the machine code of invoke TWinControl.UpdateShowing.  We may then use

TCodeRedirect.GetAddressOf(@TWinControl.SetDesignVisible, Controls_6988[False])

to match the machine code and obtain the address of the method.

Once we got the address, we may use TCodeRedirect to patch UpdateShowing as usual.

Please note the address of a method may vary if application is built with runtime package.  Also, different version of Delphi VCL or any update in between will make the address vary too.

The following show assembly code of TWinControl.SetDesignVisible for application built with runtime packages (Delphi 2007 11.0.2902.10471):

TWinControl.SetDesignVisible:
005628CC 53               push ebx
005628CD 8BD8             mov ebx,eax
Controls.pas.8007:
005628CF F6431C10         test byte ptr [ebx+$1c],$10
005628D3 7426             jz $005628fb
005628D5 F6435508         test byte ptr [ebx+$55],$08
005628D9 0F95C0           setnz al
005628DC 3401             xor al,$01
005628DE 3AD0             cmp dl,al
005628E0 7419             jz $005628fb
Controls.pas.8009:
005628E2 84D2             test dl,dl
005628E4 7508             jnz $005628ee
Controls.pas.8010:
005628E6 66814B540008     or word ptr [ebx+$54],$0800
005628EC EB06             jmp $005628f4
Controls.pas.8012:
005628EE 66816354FFF7     and word ptr [ebx+$54],$f7ff
Controls.pas.8013:
005628F4 8BC3             mov eax,ebx
005628F6 E831DDFFFF       call $0056062c
Controls.pas.8015:
005628FB 5B               pop ebx
005628FC C3               ret

You may see the machine code for both application built with and without runtime package is different.

Reference:

  1. Hack #5: Access to private fields
  2. How to patch private function and private method
  3. http://opensvn.csie.org/historypp/3rdparty/RtlVclOptimize.pas

Saturday, November 01, 2008

Linux: Download files in background

We may use wget to download files from HTTP or FTP services in background without user intervention.  wget supports resume and retry features as well.

Download a file

wget http://server/file

Download a file in background

wget -b http://server/file

Download a file in background and turn off Wgets Output

wget -b -q http://server/file

Download a file in background with infinite retrying

wget -b -t0 -q http://server/file

Wednesday, October 29, 2008

Linux: Install HP LaserJet 1020 on CUPS

First, I thought all printers configure on CUPS as local raw printer should works for windows workstation as long as I use correct printer driver to render the printing image.  The CUPS will just re-route the raw printing image received to the printer.

I have follow this rule to configure two other printers: Panasonic KX-1121 dot matrix printer and Samsung ML-1450 Laser Jet Printer.  Both works flawlessly for years.

I receive a HP LaserJet 1020 printer last night and try to configure it for CUPS.  The printer has only one USB port.  I plug the printer to the Linux machine's USB port and CUPS detect the printer well.  I then install the latest HP LaserJet 1020 printer downloaded from HP web site and configure the printer as usual.  I send a test page to printer.  CUPS receive the printing image and report print job completed successfully but the printer doesn't print anything.  The printer doesn't feed the paper.

I thought it was printer's problem.  To re-confirm the problem again, I attach the printer to my Windows Vista machine directly.  It print perfectly.

I found some interesting things with HP LaserJet 1020 after Google for solutions.

It is a Host-Based Printer

As defined by HP:

The host-based software uses the computer's resources to process print commands and rasterizing data, taking advantage of the computer's memory and processing power. Host-Based printing is a cost-effective printing technology that enables printers to utilize the processing power and memory resources of the PC (or the Host). In comparison, PDL-based printers use the processor and memory resources of the printer.

It utilize the power and resources of PC to render the printing images.  It print much faster than those PDL printer since newer computers process at much faster speeds than most PDL printers processors.

The disadvantages of Host-Based Printers is it no longer accept ASCII text directly from computer as all print images are generated by host operating system's print engine.

This however, is a good news as it reduce the manufacturing cost of the printer.  It also doesn't seems to be a problem for my RAW printer for CUPS service.

It always requires firmware download else it won't print

The printer is one of the cost-reduced HP printers that requires a firmware download before it will operate.  It means every time you switch on the printer, you need to send the firmware image to printer first before you start feeding the printing images.  The HP LJ1020 doesn't has a flash ROM to persist the firmware permanently.  This is the main reason why the printer works well when attach to windows vista machine but not Linux machine.  The HP LJ1010 printer drivers for windows OS take care of the firmware uploading well.

You may only get the N series of HP 1000 printers that has flash ROM equipped for firmware.  For example, HP LaserJet 1020n printer.

Solution: foo2zjs

I only need foo2zjs to upload the firmware to printer when the HP LJ1020 first attach to my Linux box.

  1. Logon to root account.
  2. Download foo2zjs tarball:

    $ wget -O foo2zjs.tar.gz http://foo2zjs.rkkda.com/foo2zjs.tar.gz
  3. Untar it:

    $ tar zxf foo2zjs.tar.gz
  4. Configure foo2zjs:

    $ cd foo2zjs
    $ make

  5. Download HP LaserJet 1020 firmware file:

    $ ./getweb 1020
  6. Install driver, foomatic XML files, and extra files:

    $ make install
  7. Configure hotplug

    $ make install-hotplug
  8. Configure CUPS:

    $ make cups
  9. You may need to switch off and on the HP LJ 1020 printer to activate hot plug upload the firmware.
  10. To check if firmware uploaded:

    $ usb_printerid /dev/usb/lp1
    GET_DEVICE_ID string:
    MFG:Hewlett-Packard;MDL:HP LaserJet 1020;CMD:ACL;CLS:PRINTER;DES:HP LaserJet 1020;FWVER:20050309;

    If you see a string "FWVER:xxxxxxx". it means the firmware has uploaded successfully.

You may now start feeding the raw printing images from your windows workstation to HP Laser Jet 1020.

Saturday, October 11, 2008

Delphi 2009: Array is dead. Long live Array

I start learn the concept of array in high school mathematic subject.  The array has dimensions, 1D, 2D and so on.  The first programming language BASIC I learned also has array.  The concept of mathematic array and programming array match perfectly.  However, there is always a memory restriction using array in 8-bits and 16-bits world.

I start ignore array after I learn object oriented programming and design patterns.  There is always ready classes like TList or TCollection for me to use in OO world.  The OOP concept has poisoned me for years that I should always coding in OO way.  The TList class can do more than array and I almost forget that Object Pascal still has array.

I migrate my Delphi 2007 code to Delphi 2009 when it was launched.  In the migration stage, the most headache part is unicode conversion.  Due to several reasons below:

  1. Some 3rd party components aren't ready for Delphi 2009 yet and some in beta stage.  Even the component makers claim they already ready but it is still new and I don't have confident yet.
  2. My current application persistent storage (database or resource) is in ANSI format.  I need some buffer duration before I port to Unicode.

I will still stay in Delphi 2007 for a while before I am ready to release application compiled in Delphi 2009.

At this stage, I will revise all my code that aren't compatible with Delphi 2009 and amend it to compatible for both Delphi 2007 and Delphi 2009.

I have some classes perform Base16 and Base64 encoding.  These classes using string to as internal storage.  It become a problem in Delphi 2009 as it use WideChar (2 bytes) and the effect is avalanche as other part of source use the encoding classes.  I revise the code and use TBytes (array of byte) as internal storage.

A new problem raise, the lack of solid array knowledge has slow down my day to day coding practice.  My knowledge of array is still stay in high school.  I re-study the array construct in Delphi documentation to strengthen my understanding about it.  Some I already know but some don't.  Below are the result of my study.

Static Array

Static array has fixed memory allocated at compiled time.  For example,

var A, B: array[1..10] of integer;

define A and B as byte array of 10 element.

To initialize a static array:

var C: array[1..3] of integer = (1, 2, 3);

  • Length(A) return 10
  • SizeOf(A) return 40
  • Low(A) return 1
  • High(A) return 10
  • FillChar(A, Length(A), 77) or
    FillChar(A[1], Length(A), 77)
    will fill all elements with value 77
  • Move(A, B, Length(A)) or
    Move(A[1], B[1], Length(A))
    will copy all elements from A to B

Dynamic Array

As it name implied, the size of dynamic array is not fixed at compile time.  It is determine at runtime.  Thus, there are some operations distinct to static array:

var A: array of integer;

A is of type pointer to an array memory storage.  Thus, when we apply any operation against dynamic array, always treat it as pointer to reduce any confusions for operation like FillChar or Move.

Use SetLength to allocate memory storage for dynamic array:

SetLength(A, 10)

A good news is the system will manage the dynamic array storage area.  there is no need to free the storage size allocated via SetLength.

To initialize a dynamic array (undocumented feature):

type
  TDynIntegerArray = array of integer;

var C: TDynByteArray;
begin
  C := TDynByteArray.Create(1, 2, 3, 4);
end;

  • Length(A) return 10
  • SizeOf(A) return 4, same as SizeOf(Pointer).  To get the array physical storage size, use Length(A) * SizeOf(Integer)
  • Low(A) return 0 (Dynamic array always starting from 0)
  • High(A) return 9
  • FillChar(A[0], Length(A), 77)
    will fill all elements with value 77 but
    FillChar(A, Length(A), 77)
    will lead to unexpected result.
  • Move(A[0], B[0], Length(A))
    will copy all elements from A to B but
    Move(A, B, Length(A))
    will lead to unexpected result.

Array assignment

Arrays are assignment-compatible only if they are of the same type. Because the Delphi language uses name-equivalence for types, the following code will not compile:

var A: array[1..10] of integer;
    B: array[1..10] of integer;
    C: array of integer;
    D: array of integer;

begin
  B := A;
  D := C;
end;

To make it works, either do this:

var A, B: array[1..10] of integer;
    C, D: array of integer;
begin
  B := A;
  D := C;

end;

or

type TIntegerArray = array[1..10] of integer;
     TDynIntegerArray = array of integer;

var A: TIntegerArray;
    B: TIntegerArray;
    C: TDynIntegerArray;
    D: TDynIntegerArray;
begin
  B := A;
  D := C;
end;

As static arrays has pre-allocated memory storage, copy-on-write is not employed on static array assignment.  In the above example, B will copy of all elements' value from A.  Changing any value in B[i] will has no effect on A.  A and B has 2 independent storage area.

Unlike static array, dynamic array reference is a pointer.  Thus, B := A will make B point to A's storage area.  The storage area for A is also storage area for B now.  Changing value in A[i] will be reflected immediately on B[i] and vice versa.  Both A and B share same storage area.  To practice copy-on-write for dynamic array, use Copy function

B := Copy(A, 0, Length(A)):

It is not need to allocate storage for B using SetLength prior to Copy.  Now A and B has two distinct storage area. Changing B[i] or A[i] do not affect each other.

Open Array Parameters

Open Array is not static or dynamic array.  It is use as parameters in procedures or functions.

Unfortunately, it has same syntax as dynamic array and always confuse us.  Open array parameter must always declares as "array of <baseType>".  If we declare a type for it, it is not an open array.

This is open array parameter:

procedure MyProc(A: array of integer);
begin
end;

This is not open array parameter:

type
  TIntegerArray = array of integer;

procedure MyProc(A: TIntegerArray);
begin
end;

Open array has several rules:

  • They are always zero-based. The first element is 0, the second element is 1, and so forth. The standard Low and High functions return 0 and Length1, respectively. The SizeOf function returns the size of the actual array passed to the routine.
  • They can be accessed by element only. Assignments to an entire open array parameter are not allowed.
  • They can be passed to other procedures and functions only as open array parameters or untyped var parameters. They cannot be passed to SetLength.
  • Instead of an array, you can pass a variable of the open array parameter's base type. It will be treated as an array of length 1.

For example,

procedure MyProc(A: array of integer);
begin
  WriteLn('SizeOf(A)=', SizeOf(A));
  WriteLn('Length(A)=', Length(A));
end;

var A: array[0..9] of integer;
begin
  MyProc(A);
end;

The output is

  • SizeOf(A)=40
  • Length(A)=10

We can pass variable to open array parameter of a routine, it will be treated as a single element array:

var i: integer;
begin
  MyProc(i);
end;

The output is

  • SizeOf(A)=4
  • Length(A)=1

Conclusion

For simple construct, using array is efficient and easy.  It consume less system resources than collection classes.

Thursday, October 09, 2008

Delphi 2009: SizeOf and Length

SizeOf and Length always confuse me.  Some time both function return same result but not always.  There are situations they have same behaviors but not always.

In Delphi 2009 documentation:

SizeOf

function SizeOf(X): Integer;

Returns the number of bytes occupied by a variable or type.

Length

function Length(S): Integer;

Returns the number of characters in a string or elements in an array.

Case 1: Apply on Static Array

For static array, the size of array is statically reserved by compiler.  Thus, SizeOf know the total number of bytes allocated for the array. 

Length will always behave as defined regardless of the element size of array, that is return the number of element in the array.

var A: array[0..9] of byte;

  • SizeOf(A) return 10
  • Length(A) return 10

var B: array[0..9] of char;

  • SizeOf(B) return 20 (in Delphi 2009, char is WideChar of 2 bytes in size)
  • Length(B) return 10

Case 2: Apply on Dynamic Array

Unlike static array, a variable reference dynamic array is of pointer type.  Thus, apply SizeOf on a dynamic array point always return 4, that is same as SizeOf(Pointer) no matter how much memory allocated to the dynamic array at runtime.

Length as always, return the number of elements in array.

var A: array of byte;  // or TBytes
begin
  SetLength(A, 10);
end;

  • SizeOf(A) return 4
  • Length(A) return 10

var C: array of char;  // or TBytes
begin
  SetLength(C, 10);
end;

  • SizeOf(C) return 4
  • Length(C) return 10
  • To get the total number of bytes allocated for a dynamic array, use Length(C) * SizeOf(Char) and it return 20.

Case 3: Apply on Open Array

Open array parameters allow arrays of different sizes to be passed to the same procedure or function. To define a routine with an open array parameter, use the syntax array of type (rather than array[X..Y] of type) in the parameter declaration. For example,

procedure MyProc(A: array of integer);
begin
  WriteLn('SizeOf(A)=', SizeOf(A));

  WriteLn('Length(A)=', Length(A));
end;

declares a procedure called MyProc that takes a integer array of any size.

We may pass either a static or dynamic array to MyProc but not limited to that.

Example 1: Dynamic array

var A: array of integer;
begin
  SetLength(A, 10);
  MyProc(A);
end;

The output is

  • SizeOf(A)=40
  • Length(A)=10

Example 2: Static array

var A: array[0..9] of integer;
begin
  MyProc(A);
end;

The output is

  • SizeOf(A)=40
  • Length(A)=10

Example 3: Static array

begin
  MyProc([0,1,2,3,4,5,6,7,8,9]);
end;

The output is

  • SizeOf(A)=40
  • Length(A)=10

Example 4: Integer variable

Instead of an array, you can pass a variable of the open array parameter's base type. It will be treated as an array of length 1.

var i: integer;
begin
  MyProc(i);
end;

The output is

  • SizeOf(A)=4
  • Length(A)=1

Example 5: Open Array or Dynamic Array

It is easy to confuse about the array syntax.  The syntax of open array parameters resembles that of dynamic array types, but they do not mean the same thing.  If you declare a type identifier for an array, it will be treated as dynamic array:

type
  TIntegerArray = array of integer;

procedure MyProc(A: TIntegerArray);
begin
  WriteLn('SizeOf(A)=', SizeOf(A));
  WriteLn('Length(A)=', Length(A));
end;

var A: TIntegerArray;
begin
  SetLength(A, 10);
  MyProc(A);
end;

The output is

  • SizeOf(A)=4
  • Length(A)=10

Reference:

  1. Open array parameters and array of const

Friday, October 03, 2008

Delphi 2009: Unicode

W1050 WideChar reduced to byte char in set expressions.  Consider using 'CharInSet' function in 'SysUtils' unit

This compiler warning is commonly encounter in Delphi 2009.  We should change all coding using characters set with CharInSet.

For example:

Delphi 2007: A in ['a', 'b']

Delphi 2009: CharInSet(A, ['a', 'b'])

However, doing such changes will make the code not compatible with Delphi 2007.  We may construct a CharInSet function for Delphi 2007:

unit D2009_to_D2007;

interface

{$if CompilerVersion <= 18.5}
function CharInSet(C: AnsiChar; const CharSet: TSysCharSet): Boolean; inline;
{$ifend}

implementation

{$if CompilerVersion <= 18.5}
function CharInSet(C: AnsiChar; const CharSet: TSysCharSet): Boolean;
begin
  Result := C in CharSet;
end;
{$ifend}

end.

The $if directive will restrict the code available for Delphi 2007 or older only.

W1057 Implicit string cast from 'ShortString' to 'string'

The following code will raise a famous W1057 compiler warning in Delphi 2009:

var s: ShortString;
    t: string;
begin
  t := s;
end;

To eliminate the warning, just cast the ShortString variable as String and it is compatible with both Delphi 2007 and 2009:

var s: ShortString;
    t: string;
begin
  t := string(s);
end;

W1057 Implicit string cast from 'AnsiString' to 'string'

The following code will raise a famous W1057 compiler warning in Delphi 2009:

var s: AnsiString;
    t: string;
begin
  t := s;
end;

To eliminate the warning, just cast the AnsiString variable as String and it is compatible with both Delphi 2007 and 2009:

var s: AnsiString;
    t: string;
begin
  t := string(s);
end;

W1058 Implicit string cast with potential data loss from 'string' to 'AnsiString'

We must take extra care for this warning.  Although using the famous cast method may solve the problem, we should only use it only if we understand what we are doing.

For example:

var s: AnsiString;
    t: string;
begin
  s := t;
end;

If we are very sure that t will contain only ansi string value, then we can perform the cast as follow safely:

var s: AnsiString;
    t: string;
begin
  s := AnsiString(t);
end;

This warning is usually happens in code invoke legacy external library (*.DLL) that supports PAnsiChar data type only.

Delphi 2009: Project Management

  1. In Delphi 2007,if we compile our application with runtime package that has dot in the package file name (eg: SQL.patch.vcl.dcp), an exception EPackageError will prompt. This issue no longer exist in Delphi 2009. (Reference: QC#48394, Package naming cause problem in runtime)
  2. Project file (.dproj) always turn to modifed state when first open. (Reference: QC#66781, https://forums.codegear.com/thread.jspa?threadID=2818&tstart=0)
  3. Dot (.) is not allow in LIB Prefix. (Reference: QC#66782, https://forums.codegear.com/thread.jspa?threadID=2819&tstart=0)
  4. Incorrect status of inherited value in Build configuration after upgrade D2007 Project file (*.dproj) (Reference: QC#66786, https://forums.codegear.com/thread.jspa?threadID=2829&tstart=0)
  5. Build Configuration:
    1. New Build configuration implement new Option Set introduced in Delphi 2009.
    2. For our development environment, we define build configuration as below:
      1. Base (..\build\optset\Base.optset)
        1. Debug (..\build\optset\Debug.optset)
        2. Profile (..\build\optset\Profile.optset)
        3. Release (..\build\optset\Release.optset)

          Capture_thumb51
  6. RC Files
    1. Remove library.rc file from Project Manager
    2. Add "..\build\rc\library.rc" into Project
    3. Remove "{$R 'rc\library.res' 'rc\library.rc'}" on first line of *.dpk files
    4. Add "{$R 'library.res'}" below "{$R *.res}"

      Capture_thumb6
    5. Build and Compile
    6. You should see "library.res" appears in Contains node of Project Manager when you re-open the project again next time.

      Capture_thumb7

Saturday, September 27, 2008

Linux: Upload files in background

We may use curl to upload files to a FTP server in background without user intervention.  curl supports resume and retry features as well.

Upload a file to ftp server (-T / --upload-file <file>)

curl -T <file> ftp://server/path/

Upload a file to ftp server that require authentication (-u /-user <user:password>)

curl -u <user>:<password> -T <file> ftp://server/path/

Upload with Retry (--retry <num>) for non stable network connection

curl --retry 50 -u <user>:<password> -T <file> "ftp://server/path/"

Upload with Resuming

curl -C - -u <user>:<password> -T <file> "ftp://server/path/"

Friday, September 26, 2008

Delphi 2009: Using DBX4 Framework

Delphi 2009 DBX4 has some behavioral changes compare to Delphi 2007 DBX4.  I blog all my study and research against DBX4 here so that I may continue working next time when there are new DBX updates in later official updates from CodeGear.

My first experience on Delphi 2009 DBX4 is not good and full of glitches while I working on it.  After spending few days study the DBX4 source (documentation doesn't help much here).  I finally come out with my own solution for Delphi 2009 DBX4 in order to make my Delphi 2007 application able to migrate over.

Case 1: dbxdrivers.ini and dbxconnections.ini

Note: This problem has resolved in Delphi build 12.0.3250.18309.

Deploy DBX4 application on a new machine will always fail at runtime if dbxdrivers.ini and dbxconnections.ini do not exist in folder "%public%\Documents\RAD Studio\dbExpress".

I have post this issue to CodeGear discussion forum and receive pretty good response here: https://forums.codegear.com/message.jspa?messageID=20783#20783

Bob Swart who help me confirm the problem has file a QC report: http://qc.codegear.com/wc/qcmain.aspx?d=67210 

Case 1: Solution

The cause of this problem to related to the design of static method TDBXConnectionFactory.GetConnectionFactory in unit DBXCommon.pas. This method is design using singleton pattern that return a TDBXConnectionFactory instance.  However, the default instance returned is instantiated from class TDBXIniFileConnectionFactory.  This class always return loaded drivers and connections from the 2 *.ini files.

TDBXMemoryConnectionFactory is only used by TSQLConnection.DoConnect in a try...except...end block.  I think it's purpose is to create TDBXIniFileConnectionFactory factory first, and if fail due to missing two *.ini files or whatever reason, it will use a TDBXMemoryConnectionFactory instance.  However, there are many other DBX operations invoke TDBXMemoryConnectionFactory.GetConnectionFactory too (e.g.: TSQLConnection.SetDriverName).  This is not a good design to cover all the holes by try...except...end as in TSQLConnection.DoConnect.

To provide a workaround solution for this problem, I create a TDBXMemoryConnectionFactory instance explicitly and inject it into TDBXConnectionFactory before TDBXConnectionFactory.GetConnectionFactory was invoked.  Since it behave as singleton, it won't instantiate the default TDBXIniFileConnectionFactory class any more for it's life time process:

var C: TDBXConnectionFactory;
begin
  C := TDBXMemoryConnectionFactory.Create;
  C.Open;
  TDBXConnectionFactory.SetConnectionFactory(C);
end;

Case 2: TSQLConnection.DriverName must have value

In my DBX application, I create a TSQLConnection instance on the fly as my application may work with many type of database server (e.g.: Firebird, MSSQL or MySQL).  I couldn't decide the DriverName at design time.  It is up to the end user to state which database server to connect.

As GetDriverFunc, LibraryName and VendorLib property in TSQLConnection seems to provide enough parameters for a database connection, I tend to left TSQLConnection.DriverName empty as it serve no purpose for the connection except filling the 3 properties value mention retrieve from TDBXConnectionFactory.FDrivers collection.

However, an empty DriverName will fail in procedure TSQLConnection.CheckLoginParams invoked by TSQLConnection.DoConnect:

procedure TSQLConnection.CheckLoginParams;
var
  I: Integer;
  DriverProps: TDBXProperties;
begin
  ...
  if FDriverName = '' then DataBaseError(SMissingDriverName);
  ...
end;

I personally feel this is an unnecessary checking if I don't rely on two *.ini files to initiate a connection.  In order to avoid spending time doing source code patch for this issue, I rather specify a non-empty DriverName value for TSQLConnection:

begin
  ...
  sqlconnection1.DriverName := 'Firebird';
  ...
end;

Another issue float on now.  As I use a workaround solution mentioned in Case 1 to avoid deploying 2 *.ini files, I have no driver instance store in TDBXConnectionFactory.FDrivers collection.  When I try to set a value for DriverName, a "TDBXErrorCodes.DriverInitFailed" exception will occurs in SQLConnection.SetDriverName method.

Case 2: Solution

I should register a Firebird dynalink driver to DBX4 framework in order to make DriverName setting work.  The code is copy from DBXInterbase.pas and some changes has made allow it work as expected:

unit DBXFirebird;

...

const
  sDriverName = 'Firebird';

...
initialization
  TDBXDriverRegistry.RegisterDriverClass(sDriverName, TDBXFirebirdDriver);
finalization
  TDBXDriverRegistry.UnregisterDriverClass(sDriverName);
end.

You should able to to connect to firebird database with DBX4 now.

Case 3: Custom value for GetDriverFunc, LibraryName and VendorLib in property TSQLConnection is not functioning

No matter what value you set for GetDriverFunc, LibraryName and VendorLib, TSQLConnection will not respect these values.  It will only follow the initial values specify in dynalink driver (DBXInterbase.pas).

After tracing the dynalink driver source, I found out the problem occurs in the following method:

constructor TDBXInterBaseDriver.Create(DBXDriverDef: TDBXDriverDef);
begin
  inherited Create(DBXDriverDef, TDBXDynalinkDriverLoader);
  rpr;
  InitDriverProperties(TDBXInterBaseProperties.Create(DBXDriverDef.FDBXContext));
end;

Invoke InitDriverProperties will set a default properties instance into TDBXInterbaseDriver.  When the following method is invoke:

procedure TDBXDynalinkDriver.LoadDriver(DBXContext: TDBXContext);
var
  Loader: TDBXDynalinkDriverCommonLoader;
begin
  if not Assigned(FMethodTable) then
  begin
  ...
      Loader.LoadDriverLibraryAndMethodTable(DBXContext, GetDriverProperties);
  ...
  end;
end;

The Loader.LoadDriverLibraryAndMethodTable will always get the default TDBXProperties instance from InitDriverProperties.

I have reported this problem to QC: http://qc.codegear.com/wc/qcmain.aspx?d=67139

Case 3: Solution

After study the source, I found out the problem happens in the following method:

function TDBXDynalinkDriverNative.CreateConnection(ConnectionBuilder: TDBXConnectionBuilder): TDBXConnection;
var
  ConnectionHandle: TDBXConnectionHandle;
  ErrorResult:  TDBXErrorCode;
begin
  LoadDriver(ConnectionBuilder.DbxContext);
  ErrorResult := FMethodTable.FDBXDriver_CreateConnection(FDriverHandle, ConnectionHandle);
  CheckResult(ErrorResult);
  Result := TDBXDynalinkConnection.Create(ConnectionBuilder, ConnectionHandle, FMethodTable);
end;

The ConnectionBuilder.ConnectionProperties contain the all the custom setting from TSQLConnection.  Unfortunately, it never be used in CreateConnection.  Instead, it use the initial properties stored in TDBXDriver.FDriverProperties.

My solution is override the CreateConnection method to make it consume the custom value in ConnectionBuilder.ConnectionProperties:

function TDBXFirebirdDriver.CreateConnection(ConnectionBuilder:
    TDBXConnectionBuilder): TDBXConnection;
var
  ConnectionHandle: TDBXConnectionHandle;
  ErrorResult:  TDBXErrorCode;
begin
  LoadDriverWithConnectionBuilder(ConnectionBuilder);
  ErrorResult := FMethodTable.FDBXDriver_CreateConnection(FDriverHandle, ConnectionHandle);
  CheckResult(ErrorResult);
  Result := TDBXDynalinkConnection.Create(ConnectionBuilder, ConnectionHandle, FMethodTable);
end;

procedure TDBXFirebirdDriver.LoadDriverWithConnectionBuilder(ConnectionBuilder:
    TDBXConnectionBuilder);
var
  Loader: TDBXDynalinkDriverLoader_Enhance;
begin
  if not Assigned(FMethodTable) then
  begin
    Loader := FDriverLoaderClass.Create as TDBXDynalinkDriverLoader_Enhance;
    try
      Loader.LoadDriverLibraryAndMethodTable(ConnectionBuilder.DbxContext, ConnectionBuilder.ConnectionProperties);
      FMethodTable := Loader.FMethodTable;
      Loader.FMethodTable := nil;
      FDriverHandle := Loader.FDriverHandle;
      Loader.FreeOldLibrary;
    finally
      FreeAndNil(Loader.FMethodTable);
      Loader.Free;
    end;
  end;
end;

The loader class TDBXDynalinkDriverLoader_Enhance is duplicated and inherited from TDBXDynalinkDriverLoader as I can't access 2 private methods: FreeOldLibrary and LoadDriverLibraryAndMethodTable:

TDBXDynalinkDriverLoader_Enhance = class(TDBXDynalinkDriverLoader)
private
  procedure FreeOldLibrary;
  procedure LoadDriverLibraryAndMethodTable(DBXContext: TDBXContext; Properties:
      TDBXProperties);
end;

Case 4: AutoUnloadDriver doesn't work as is

AutoUnloadDriver is a new connection parameter property for Delphi 2009.  As stated in DBXCommon.pas for AutoUnloadDriver:

If set to true, dynalink drivers will automatically unload their dll, when there are no longer any open connections that use the driver.

I love this feature as it will release the related DLL if no connection is active.

However, none of the Delphi DBX driver provide this as default setting and there is no way to make AutoUnloadDriver activate.

I have report this problem: QC#67233.

Case 4: Solution

The Dynalink Driver class has the following constructor:

constructor TDBXDynalinkDriver.Create(DBXDriverDef: TDBXDriverDef; DBXDriverLoader: TDBXDynalinkDriverCommonLoaderClass);
begin
  inherited Create(DBXDriverDef);
  FDriverLoaderClass := DBXDriverLoader;
  // '' makes this the default command factory.
  //
  AddCommandFactory('', CreateDynalinkCommand);
  if (DriverProperties = nil) or not DriverProperties.GetBoolean(TDBXPropertyNames.AutoUnloadDriver) then
    CacheUntilFinalization;
end;

To make AutoUnloadDriver work as it should, the clue is to avoid invoke CacheUntilFinalization in the constructor.  In order to do that, we must make sure DriverProperties is not nil and AutoUnloadDriver property has value "True":

constructor TDBXFirebirdDriver.Create(DBXDriverDef: TDBXDriverDef);
var P: TDBXProperties;
begin
  P := TDBXProperties.Create(DBXDriverDef.FDBXContext);
  P.Values[TDBXpropertyNames.AutoUnloadDriver] := 'True';
  InitDriverProperties(P);
  inherited Create(DBXDriverDef, TDBXDynalinkDriverLoader_Enhance);
end;