Delphi Shared Memory

Shared Memory Win32

unit SharedMemory;



interface



uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;



type



TfisSharedMemory = class(TComponent)

private

{ Private declarations }

FShareName: String;

FSize: integer;

FHandle, FMutex: THandle;

FReadOnly: boolean;

FTimeout: integer;



protected

procedure SetName(const aValue: TComponentName );override;

{ Protected declarations }

public

constructor Create(AOwner: TComponent);override;

destructor Destroy;override;

function MemoryExist: boolean;

function MapMemory: pointer;    { Public declarations }

function UnMapMemory(aMapPtr: pointer):boolean;

function CreateMemory: boolean;

function CloseMemory: boolean;

function OpenMemory: boolean;

function RequestOwnership: boolean;

function ReleaseOwnership: boolean;

property Handle: THandle read FHandle;

property Mutex: THandle read FMutex;



published

{ Published declarations }

property ReadOnly: boolean read FReadOnly write FReadOnly default false;

property ShareName: String read FShareName write FShareName;

property Size: integer read FSize write FSize;

property Timeout: integer read FTimeout write FTimeout default -1;



end;



const

MUTEX_NAME = '_SMMutex';



procedure Register;



implementation



procedure TfisSharedMemory.SetName(const aValue: TComponentName );

var

lChange: boolean;

begin

lChange := (csDesigning in ComponentState) and

((Name = FShareName) or (Length(FShareName) = 0));

inherited;

if lChange then

begin

FShareName := Name;

end;

end;

//---------------------------------------------------------------------------

function TfisSharedMemory.MapMemory:pointer;

var

lMapping: DWord;

begin

if FHandle = 0 then

begin

Result := nil;

exit;

end;



if(FReadOnly)then

begin

lMapping := FILE_MAP_READ;

end

else

begin

lMapping := File_Map_All_Access;

end;

Result := MapViewOfFile(FHandle, lMapping, 0, 0, FSize);

if(Result = nil)then

begin

ReleaseMutex(FMutex);

end;

end;

//---------------------------------------------------------------------------

function TfisSharedMemory.UnMapMemory(aMapPtr: pointer): boolean;

begin

if FHandle <> 0 then

begin

UnmapViewOfFile(aMapPtr);

result := true;

end

else

begin

result := false;

end;

end;

//---------------------------------------------------------------------------

function TfisSharedMemory.CreateMemory: boolean;

var

lMutexName: string;

begin

Result := true;

if FHandle <> 0 then CreateMemory := false;

FHandle := CreateFileMapping(THANDLE($FFFFFFFF), nil, PAGE_READWRITE, 0,

FSize, pchar(FShareName));

if (FHandle = 0) or ((FHandle <> 0) and (GetLastError = ERROR_ALREADY_EXISTS)) then

begin

CloseMemory;

Result := false;

end;

lMutexName := FShareName + MUTEX_NAME;

FMutex := CreateMutex(nil, false, pchar(lMutexName));

if(FMutex = 0) then

begin

CloseMemory;

Result := false;

end;

end;

//---------------------------------------------------------------------------

function TfisSharedMemory.CloseMemory: boolean;

begin

if(FHandle <> 0) then

begin

CloseHandle(FHandle);

FHandle := 0;

end;

if(FMutex <> 0) then

begin

CloseHandle(FMutex);

FMutex := 0;

end;

Result := true;

end;

//---------------------------------------------------------------------------

function TfisSharedMemory.OpenMemory: boolean;

var

lMutexName: string;

begin

Result := false;

if(FHandle = 0) then

begin

FHandle := OpenFileMapping(FILE_MAP_ALL_ACCESS, true, pchar(FShareName));

if(FHandle <> 0) then

begin

lMutexName := FShareName + MUTEX_NAME;

FMutex := OpenMutex(MUTEX_ALL_ACCESS, true, pchar(lMutexName));

if(FMutex <> 0 ) then

begin

Result := true;

end

else

begin

CloseMemory;

end;

end;

end;

end;

//---------------------------------------------------------------------------

function TfisSharedMemory.RequestOwnership: boolean;

var

lTimeout: DWord;

begin

Result := false;

if(FHandle <> 0) then

begin

if(FTimeout <> 0) then

begin

Result := ReleaseMutex(FMutex);

end;

end;

//---------------------------------------------------------------------------

constructor TfisSharedMemory.Create(AOwner: TComponent);

begin

inherited;

FShareName := '';

FTimeout := -1;

FSize := 0;

FReadOnly := false;

FHandle := 0;

FMutex := 0;

end;

//---------------------------------------------------------------------------

destructor TfisSharedMemory.Destroy;

begin

CloseMemory;

inherited;

end;

//---------------------------------------------------------------------------

procedure Register;

begin

RegisterComponents('FISH', [TfisSharedMemory]);

end;

//---------------------------------------------------------------------------

function TfisSharedMemory.MemoryExist: boolean;

var PVHandle:THandle;

begin

Result := false;

PVHandle := CreateFileMapping(THANDLE($FFFFFFFF), nil, PAGE_READWRITE, 0,

FSize, pchar(FShareName));

if (PVHandle <> 0) and (GetLastError = ERROR_ALREADY_EXISTS)

then Result:=true

else CloseHandle(PVHandle);

end;



end.

Multithreading - The Delphi Way

This is an excellent tutorial on Delphi multi threading programming, see http://www.eonclash.com/Tutorials/Multithreading/MartinHarvey1.1/ToC.html

Online Borland Delphi 5 Developer's Guide

See here: http://info.borland.com/techpubs/delphi/delphi5/

Notes on Installation of Turbo C++ Explorer

When starting Turbo C++ Explorer, you may get an error message stating:

1. acces violation at adress 51F515BE rtl100.bpl....
2. error with coreide100.bpl
3. designeide100.bpl

The workaround is running "regasm" from .NET v1.1 to register the missing .NET assemblies used by Turbo C++ Explorer IDE. Go to the C:\Program Files\Borland\BDS\4.0\Bin directory and run

regasm Borland.Studio.Toolsets.dll

Now you should start the IDE successfully. If you still see an error message box, saying that a ClassId is missing or similar errors, you can solve this by registering all possible assemblies manually.

To do this, navigate to the BDS \Bin directory in the command line and type "dir Borland.Studio.*.tlb" to list all relevant .tlb files. Then, run "regasm" on the corresponding .dll file for each.(see http://support.borland.com/entry.jspa?externalID=4102&categoryID=39)

OK, then you start a new project from the menu File->New..., if you are unlucky to get an exception Class not registered, ClassID {17CD2E5A-9D11-4BB4-8030-1092F6645714}, here is a way to fix it:

Save the fix_turbo_cpp.reg file into your hard disk, and double click it to import itself into the Registry.(thanks Tim Lichtenberg, see http://qc.borland.com/wc/qcmain.aspx?d=25744)

Delphi2006 editor shortcuts

CTRL+J : Invoke code templates
CTRL+T : Delete current word
CTRL+E : Incremental search
CTRL+Y : Delete current line
CTRL+SHIFT+G : Insert a new GUID at the cursor position
CTRL+SHIFT+I : Indent the current selected block
CTRL+SHIFT+U : outdent the current selected block
CTRL+SHIFT+Y : delete to the end of line
CTRL+SHIFT+J : Invoke syncedit
ALT+[ : match pair forward
ALT+] : match pair backward
ALT+RightArrow : browse forward (hotlink history)
ALT+LeftArrow : browse backward (hotlink history)
ALT+UpArrow : browse to symbol under editor cursor (invoke a hotlink and add it to the hotlink history)
F4 : Run program to current cursor position
F5 : Toggle breakpoint
F7 : Debugger step into
F8 : Debugger step over
F9 : Run program under debugger
CTRL+F12 : View units
ALT+G : Goto line number in editor
CTRL+SHIFT+R : Start/Stop recording editor macro
CTRL+SHIFT+P : Play editor macro
CTRL+SPACE : Invoke code completion
CTRL+SHIFT+SPACE : Invoke code parameter hints
CTRL+ENTER : Open file at cursor
CTRL+SHIFT+C : Invoke class completion for the class that currently contains the cursor
CTRL+SHIFT+UpArrow : Navigate to method implementation/declaration
CTRL+SHIFT+DownArrow : Navigate to method implementation/declaration
CTRL+ALT+UpArrow : Navigate to previous method implementation in lexical order
CTRL+ALT+DownArrow : Navigate to next method implementation in lexical order
CTRL+ALT+Home : Navigate to the lexically first method implementation in this source unit
CTRL+ALT+End : Navigate to the lexically last method implementation in this source unit
CTRL+/ : Toggle comment per line or selected block