jclunitversioning.pas

East make Tray Icon in delphi

  for I := FModules.Count - 1 downto 0 do
    if Modules[I].Instance = Instance then
    begin
      FModules.Delete(I);
      Break;
    end;
  for I := 0 to FProviders.Count -1 do
    TCustomUnitVersioningProvider(FProviders[I]).ReleaseModuleUnitVersioningInfo(Instance);
end;

procedure TUnitVersioning.UnregisterModule(Module: TUnitVersioningModule);
begin
  FModules.Remove(Module);
end;

function TUnitVersioning.GetCount: Integer;
var
  I: Integer;
begin
  Result := 0;
  ValidateModules;
  for I := 0 to FModules.Count - 1 do
    Inc(Result, Modules[I].Count);
end;

function TUnitVersioning.GetItems(Index: Integer): TUnitVersion;
var
  Cnt, I: Integer;
begin
  Result := nil;
  ValidateModules;
  Cnt := 0;
  for I := 0 to FModules.Count - 1 do
  begin
    if Index < Cnt + Modules[I].Count then
    begin
      Result := Modules[I].Items[Index - Cnt];
      Break;
    end;
    Inc(Cnt, Modules[I].Count);
  end;
end;

function TUnitVersioning.GetModuleCount: Integer;
begin
  ValidateModules;
  Result := FModules.Count;
end;

function TUnitVersioning.GetModules(Index: Integer): TUnitVersioningModule;
begin
  Result := TUnitVersioningModule(FModules[Index]);
end;

procedure TUnitVersioning.ValidateModules;
var
  I: Integer;
  Buffer: string;
begin
  for I := FModules.Count - 1 downto 0 do
  begin
    SetLength(Buffer, 1024);
    if GetModuleFileName(Modules[I].Instance, PChar(Buffer), 1024) = 0 then
      // This module is no more in memory but has not unregistered itself so
      // unregister it here.
      UnregisterModule(Modules[I]);
  end;
end;

function TUnitVersioning.FindUnit(const RCSfile: string; const LogPath: string): TUnitVersion;
var
  I: Integer;
begin
  for I := 0 to FModules.Count - 1 do
  begin
    Result := Modules[I].FindUnit(RCSfile, LogPath);
    if Result <> nil then
      Exit;
  end;
  Result := nil;
end;

function TUnitVersioning.IndexOf(const RCSfile: string; const LogPath: string): Integer;
var
  I, Cnt, Index: Integer;
begin
  Result := -1;
  Cnt := 0;
  for I := 0 to FModules.Count - 1 do
  begin
    Index := Modules[I].IndexOf(RCSfile, LogPath);
    if Index <> -1 then
    begin
      Result := Cnt + Index;
      Break;
    end;
    Inc(Cnt, Modules[I].Count);
  end;
end;

procedure TUnitVersioning.RegisterProvider(AProviderClass: TUnitVersioningProviderClass);
var
  I, Idx: Integer;
begin
  Idx := -1;
  for I := 0 to FProviders.Count - 1 do
    if TObject(FProviders[I]).ClassType = AProviderClass then
    begin
      Idx := I;
      Break;
    end;
  if Idx = -1 then
    FProviders.Add(AProviderClass.Create);
end;

procedure TUnitVersioning.LoadModuleUnitVersioningInfo(Instance: THandle);
var
  I: Integer;
begin
  for I := 0 to FProviders.Count - 1 do
    TCustomUnitVersioningProvider(FProviders[I]).LoadModuleUnitVersioningInfo(Instance);
end;

function GetNamedProcessAddress(const Id: ShortString; out RefCount: Integer): Pointer; forward;
  // Returns a 3820 Bytes large block [= 4096 - 276 = 4096 - (8+256+4+8)]
  // max 20 blocks can be allocated
function ReleaseNamedProcessAddress(P: Pointer): Integer; forward;

// (rom) PAGE_OFFSET is clearly Linux specific
{$IFDEF LINUX}
const
  PAGE_OFFSET = $C0000000; // from linux/include/asm-i386/page.h
{$ENDIF LINUX}

const
  Signature1 = $ABCDEF0123456789;
  Signature2 = $9876543210FEDCBA;

type
  PNPARecord = ^TNPARecord;
  TNPARecord = record
    Signature1: Int64;
    Id: ShortString;
    RefCount: Integer;
    Signature2: Int64;
    Data: record end;
  end;

function GetNamedProcessAddress(const Id: ShortString; out RefCount: Integer): Pointer;
const
  MaxPages = 20;
var
  {$IFDEF MSWINDOWS}
  SysInfo: TSystemInfo;
  MemInfo: TMemoryBasicInformation;
  {$ENDIF MSWINDOWS}
  Requested, Allocated: PNPARecord;
  Pages: Integer;
  pid: Integer;
  PageSize: Cardinal;
  MaximumApplicationAddress: Pointer;
begin
  RefCount := 0;
  {$IFDEF MSWINDOWS}
  GetSystemInfo(SysInfo);
  PageSize := SysInfo.dwPageSize;
  pid := GetCurrentProcessId;
  MaximumApplicationAddress := SysInfo.lpMaximumApplicationAddress;
  {$ENDIF MSWINDOWS}
  {$IFDEF UNIX}
  PageSize := getpagesize;
  pid := getpid;
  MaximumApplicationAddress := Pointer(PAGE_OFFSET - 1);
  {$ENDIF UNIX}
  Pages := 0;
  repeat
    Requested := MaximumApplicationAddress;
    Requested := Pointer((Cardinal(Requested) div $10000) * $10000);
    Dec(Cardinal(Requested), Pages * $10000);
    Requested := Pointer((Cardinal(Requested) div PageSize) * PageSize);
    {$IFDEF MSWINDOWS}
    Allocated := VirtualAlloc(Requested, PageSize, MEM_RESERVE or MEM_COMMIT, PAGE_READWRITE);
    if Assigned(Allocated) and (Requested <> Allocated) then
    begin
      // We got relocated (should not happen at all)
      VirtualFree(Allocated, 0, MEM_RELEASE);
      Inc(Pages);
      Continue;
    end;
    {$ENDIF MSWINDOWS}
    {$IFDEF UNIX}
    // Do not use MAP_FIXED because it replaces the already allocated map by a
    // new map.
    Allocated := mmap(Requested, PageSize, PROT_READ or PROT_WRITE,
      MAP_PRIVATE or MAP_ANONYMOUS, 0, 0);
    if Allocated = MAP_FAILED then
    begin
      // Prevent SEGV by signature-test code and try the next memory page.
      Inc(Pages);
      Continue;
    end
    else
    if Allocated <> Requested then
    begin
      // It was relocated, means the requested address is already allocated
      munmap(Allocated, PageSize);
      Allocated := nil;
    end;
    {$ENDIF UNIX}

    if Assigned(Allocated) then
      Break // new block allocated
    else
    begin
      {$IFDEF MSWINDOWS}
      VirtualQuery(Requested, MemInfo, SizeOf(MemInfo));
      if (MemInfo.RegionSize >= SizeOf(TNPARecord)) and
        (MemInfo.Protect and PAGE_READWRITE = PAGE_READWRITE) then
      {$ENDIF MSWINDOWS}
      {$IFDEF UNIX}
      try
      {$ENDIF UNIX}
        if (Requested.Signature1 = Signature1 xor pid) and
          (Requested.Signature2 = Signature2 xor pid) and
          (Requested.Id = Id) then
          Break; // Found correct, already existing block.
      {$IFDEF UNIX}
      except
        // ignore
      end;
      {$ENDIF UNIX}
    end;

    Inc(Pages);
    Requested := nil;
  until Pages > MaxPages;

  Result := nil;
  if Allocated <> nil then
  begin
    if Requested = Allocated then
    begin
      // initialize the block
      Requested.Signature1 := Signature1 xor pid;
      Requested.Id := Id;
      Requested.Signature2 := Signature2 xor pid;
      Requested.RefCount := 1;
      Result := @Requested.Data;
      RefCount := 1;
    end;
  end
  else
  if Requested <> nil then
  begin
    Inc(Requested.RefCount);
    Result := @Requested.Data;
    RefCount := Requested.RefCount;
  end;
end;

function ReleaseNamedProcessAddress(P: Pointer): Integer;
var
  Requested: PNPARecord;
begin
  Result := 0;
  if P <> nil then
  begin
    Requested := PNPARecord(Cardinal(P) - SizeOf(TNPARecord));
    Dec(Requested.RefCount);
    Result := Requested.RefCount;
    if Requested.RefCount = 0 then
      {$IFDEF MSWINDOWS}
      VirtualFree(Requested, 0, MEM_RELEASE);
      {$ENDIF MSWINDOWS}
      {$IFDEF UNIX}
      munmap(Requested, getpagesize);
      {$ENDIF UNIX}
  end;
end;

type
  PUnitVersioning = ^TUnitVersioning;

var
  UnitVersioningOwner: Boolean = False;
  GlobalUnitVersioning: TUnitVersioning = nil;
  UnitVersioningNPA: PUnitVersioning = nil;

function GetUnitVersioning: TUnitVersioning;
var
  RefCount: Integer;
begin
  if GlobalUnitVersioning = nil then
  begin
    UnitVersioningNPA := GetNamedProcessAddress('UnitVersioning', RefCount);
    if UnitVersioningNPA <> nil then
    begin
      GlobalUnitVersioning := UnitVersioningNPA^;
      if (GlobalUnitVersioning = nil) or (RefCount = 1) then
      begin
        GlobalUnitVersioning := TUnitVersioning.Create;
        UnitVersioningNPA^ := GlobalUnitVersioning;
        UnitVersioningOwner := True;
      end;
    end
    else
    begin
      GlobalUnitVersioning := TUnitVersioning.Create;
      UnitVersioningOwner := True;
    end;
  end
  else
  if UnitVersioningNPA <> nil then
    GlobalUnitVersioning := UnitVersioningNPA^; // update (maybe the owner has destroyed the instance)
  Result := GlobalUnitVersioning;
end;

procedure FinalizeUnitVersioning;
var
  RefCount: Integer;
begin
  try
    if GlobalUnitVersioning <> nil then
    begin
      RefCount := ReleaseNamedProcessAddress(UnitVersioningNPA);
      if UnitVersioningOwner then
      begin
        if RefCount > 0 then
          UnitVersioningNPA^ := nil;
        GlobalUnitVersioning.Free;
      end;
      GlobalUnitVersioning := nil;
    end;
  except
    // ignore - should never happen
  end;
end;

procedure RegisterUnitVersion(Instance: THandle; const Info: TUnitVersionInfo);
var
  UnitVersioning: TUnitVersioning;
begin
  UnitVersioning := GetUnitVersioning;
  if Assigned(UnitVersioning) then
    UnitVersioning.Add(Instance, @Info);
end;

procedure UnregisterUnitVersion(Instance: THandle);
var
  UnitVersioning: TUnitVersioning;
begin
  UnitVersioning := GetUnitVersioning;
  if Assigned(UnitVersioning) then
    UnitVersioning.UnregisterModule(Instance);
end;

const
  UnitVersioning: TUnitVersionInfo = (
    RCSfile: '$RCSfile: JclUnitVersioning.pas,v $';
    Revision: '$Revision: 1.10 $';
    Date: '$Date: 2005/02/24 16:34:40 $';
    LogPath: 'JCL\common';
  );

initialization
  RegisterUnitVersion(HInstance, UnitVersioning);

finalization
  FinalizeUnitVersioning;

// History:

// $Log: JclUnitVersioning.pas,v $
// Revision 1.10  2005/02/24 16:34:40  marquardt
// remove divider lines, add section lines (unfinished)
//
// Revision 1.9  2005/02/22 07:28:08  uschuster
// added unit versioning provider solution from donations\source\common
//
// (donations) Revision 1.2  2005/01/31 06:47:33  marquardt
// cleanup and simplifications
//
// (donations) Revision 1.1  2005/01/30 13:51:02  uschuster
// initial checkin (modified JclUnitVersioning 1.8)
//
// Revision 1.8  2004/10/28 22:42:33  ahuser
// Fixed Mantis 2270 and 2260 (Access Violation with activated UnitVersioning)
//
// Revision 1.7  2004/10/27 15:54:47  ahuser
// Update
//
// Revision 1.6  2004/10/17 11:01:03  ahuser
// Fixed memory leak
//
// Revision 1.5  2004/09/05 12:46:02  uschuster
// fixed TUnitVersioning.IndexOf
// changed the module handle parameter name in (Un)registerUnitVersion to Instance to avoid scope confusion
//
// Revision 1.4  2004/09/02 16:16:13  marquardt
// fixed a bug from style cleaning
//
// Revision 1.3  2004/09/02 06:16:09  marquardt
// style cleaning
//
// Revision 1.2  2004/09/01 23:24:53  ahuser
// Replaced single linked list by TObjectList
// New methods FindUnit, IndexOf
// TUnitVersionInfo is now a record that is completly hidden by TUnitVersion class
//
// Revision 1.1  2004/09/01 14:56:16  ahuser
// Added common/JclUnitVersioning.pas
//

end.