Singelton.

In one of my projects many years ago there was a need to create a COM server that would create COM objects only once when several application require them. Such servers called singletons. Here I will describe how to do that on Delphi.

Using abstract singleton.

One of the examples when you need to use singletons is a logfile. Imagine you need a logfile in form of simple text file and you have several applications (or processes), which require dumping the log to the logfile. To do this, let's create a singleton. Open Delphi and create a type library. Add the following objects:

ILogManager = interface(IDispatch)
  ['{20D3CAC2-2117-11D4-94DE-00A0C9786542}']
  function CreateLogFile(const ID: WideString; out ALogFileIntf: IDispatch): HResult; stdcall;
end;

ILogFile = interface(IDispatch)
  ['{20D3CAC6-2117-11D4-94DE-00A0C9786542}']
  function LogMessage(const Msg: WideString): HResult; stdcall;
end;

ILogManager would be a singleton. This object will be created only once and serve all applications. Users of this object have to create ILogFile objects through CreateLogFile calls. Inside ILogManager object we are going to store a list of ILogFile objects.

type
  TLogManager = class(TSingletonAutoObject, ILogManager)
  private
    FList: TStringList;
    procedure DeleteObj(Obj: TObject);
  protected
    function CreateLogFile(const ID: WideString; out ALogFileIntf: IDispatch): HResult; stdcall;
  public
    procedure Initialize; override;
    destructor Destroy; override;
  end;

  TLogFile = class(TAutoObject, ILogFile)
  private
    FLogManager: TLogManager;
    FLogManagerIntf: ILogManager;
    FFile: Text;
    FFileOpened: Boolean;
  protected
    function LogMessage(const Msg: WideString): HResult; stdcall;
  public
    constructor Create(const AManager: TLogManager;  const AFileName: string);
    destructor Destroy; override;
  end;

Let's assume that logfiles located in System32\LogFiles directory. Also, let's assume that logfiles are divided by days. Then we need to implement two functions:

function GetLogFilePath(const LogID: string): string;
begin
  Result := GetSystem32Path + '\LogFiles\' + LogID;
  Result := IncludeTrailingPathDelimiter(Result);
end;

function GetLogFileName: string;
begin
  Result := FormatDateTime('yyyymmdd', Now) + '.log';
end;

Now we can start implementing ILogManager. The basic functionality is inside CreateLogFile method. The class is searching ILogFile by ID . If the object is not found then it's created and added to the list.

{ TLogManager }
function TLogManager.CreateLogFile(const ID: WideString;
  out ALogFileIntf: IDispatch): HResult;
var ResultFile: TLogFile;
  FileName: string;
  FoundIdx: Integer;
begin
  try
    FileName := GetLogFilePath(ID) + GetLogFileName;
    if FList.Find(FileName, FoundIdx) then begin
      ResultFile := FList.Objects[FoundIdx] as TLogFile;
    end else begin
      ResultFile := TLogFile.Create(Self, FileName);
      FList.AddObject(FileName, ResultFile);
    end;
    ALogFileIntf := ResultFile as ILogFile;
    Result := S_OK;
  except
    Result := E_FAIL;
  end;
end;

procedure TLogManager.DeleteObj(Obj: TObject);
var FoundIdx: Integer;
begin
  FoundIdx := FList.IndexOfObject(Obj);
  if FoundIdx >= 0 then begin
    FList.Delete(FoundIdx);
  end;
end;

destructor TLogManager.Destroy;
begin
  FList.Free;
  inherited;
end;

In TLogFile class will create or open a simple text file. When destroying the class it will close the file and delete itself from the list of TLogFile classes.

{ TLogFile }
constructor TLogFile.Create(
  const AManager: TLogManager; AFileName: string);
begin
  inherited Create;
  FLogManager := AManager;
  FLogManagerIntf := FLogManager as ILogManager;
  try
    AssignFile(FFile, AFileName);
    if FileExists(AFileName) then begin
      Append(FFile);
    end else begin
      Rewrite(FFile);
    end;
    FFileOpened := True;
  except
    FFileOpened := False;
    raise;
  end;
end;

destructor TLogFile.Destroy;
begin
  if FFileOpened then begin
    CloseFile(FFile);
  end;
  if FLogManager <> nil then begin
    FLogManager.DeleteObj(Self);
  end;
  FLogManager := nil;
  FLogManagerIntf := nil;
  inherited;
end;

function TLogFile.LogMessage(
  const Msg: WideString): HResult;
begin
  try
    if not FFileOpened then Abort;
    Writeln(FFile, Format('"%s", "%s"', [DateTimeToStr(Now), string(Msg)]);
    Flush(FFile);
    Result := S_OK;
  except
    Result := E_FAIL;
  end;
end;

And finally, the initialization part of the unit. Here two class factories are registered:

initialization
  // create LogManager factory
  TSingletonFactory.Create(ComServer, TLogManager,
    Class_LogManager, ciMultiInstance, tmApartment);

  // create LogFile factory
  TAutoObjectFactory.Create(ComServer, TLogFile,
    Class_LogFile, ciMultiInstance, tmApartment);

Now we can implement the program itself - i.e. DPR file. We don't need a UI so the program would look very simple:

{$R *.res}
{$R *.TLB}

procedure Initialize;
begin
  if InitProc <> nil then TProcedure(InitProc);
end;

var Msg: TMsg;

begin
  Initialize;
  while GetMessage(Msg, 0, 0, 0) do begin
    DispatchMessage(Msg);
  end;
  Sleep(1000);
end.

To register the COM server compile the program (let's name it 'myserver') and put in the command-line the following:

myserver.exe /REGSERVER

Examples.

First, a Delphi example:

var LogMngr: ILogManager;
  LogFil: ILogFile;
  DspLogFil: IDispatch;
{...}
begin
  {...}
  LogMngr := CoLogManager.Create;
  try
    if LogMngr.CreateLogFile('Log1', DspLogFil) <> S_OK
    then begin
      { do something on error }
    end else begin
      LogFil := DspLogFil as ILogFile;
    end;
    { do something with logfile }
    LogFil.LogMessage('Message log');
  finally
    LogMngr := nil;
  end;
  {...}
end;

VB example:

Private Sub Command1_Click()
  REM-- do something
  Dim LogMngr As New LogManager
  Dim LogFil As LogFile
  Call LogMngr.CreateLogFile("Log1", LogFil)
  Call LogFil.LogMessage("Message1")
  REM-- do something
End Sub