一个进程间同步和通信的工具单元，改进的，
同样可以用于线程
unit USync;
interface
uses
SysUtils, Classes, Windows;
type
TSync = class(TObject)
protected
FHandle: THandle;
public
destructor Destroy;
override;
property Handle: THandle read FHandle;
end;
TMutex = class(TSync)
public
constructor Create(const Name: string);
function Get(TimeOut: Integer): Boolean;
function Release: Boolean;
end;
TEvent = class(TSync)
public
constructor Create(const Name: string;
Manual: Boolean);
function Wait(TimeOut: Integer): Boolean;
procedure Signal;
procedure Reset;
end;
TSemaphore = class(TSync)
public
constructor Create(const Name: string;
Initial, Maxinum: Integer);
function Release(Count: Integer;
var PreviousCount: Integer): Boolean;
overload;
function Release(Count: Integer): Boolean;
overload;
function Get(TimeOut: Integer): Boolean;
end;
TFileMap = class(TSync)
private
FCreated: Boolean;
FSize: Integer;
FFileView: Pointer;
FName: string;
public
constructor Create(const Name: string;
Size: Integer);
constructor Open(const Name: string);
destructor Destroy;
override;
property Name: string read FName;
property Size: Integer read FSize;
property Buffer: Pointer read FFileView;
property Created: Boolean read FCreated;
end;
TMemStream = class(TCustomMemoryStream)
private
Owned: Boolean;
public
destructor Destroy;
override;
procedure Clear;
procedure Attach(PBuff: Pointer;
BuffSize: Integer);
procedure AttachOwnFree(PBuff: Pointer;
BuffSize: Integer);
procedure LoadFromStream(Stream: TStream);
function Write(const Buffer;
Count: Longint): Longint;
override;
function WriteString(const S: String): Longint;
function ReadString(const Count: Integer): String;
end;
implementation
procedure Error(const Msg: string);
begin
raise Exception.Create(Msg);
end;
{ TSync }
destructor TSync.Destroy;
begin
if FHandle <> 0 then
CloseHandle(FHandle);
end;
{ TMutex }
constructor TMutex.Create(const Name: string);
begin
FHandle := CreateMutex(nil, False, PChar(Name));
if FHandle = 0 then
abort;
end;
function TMutex.Get(TimeOut: Integer): Boolean;
begin
Result := WaitForSingleObject(FHandle, TimeOut) = WAIT_OBJECT_0;
end;
function TMutex.Release: Boolean;
begin
Result := ReleaseMutex(FHandle);
end;
{ TEvent }
constructor TEvent.Create(const Name: string;
Manual: Boolean);
begin
FHandle := CreateEvent(nil, Manual, False, PChar(Name));
if FHandle = 0 then
abort;
end;
function TEvent.Wait(TimeOut: Integer): Boolean;
begin
Result := WaitForSingleObject(FHandle, TimeOut) = WAIT_OBJECT_0;
end;
procedure TEvent.Signal;
begin
SetEvent(FHandle);
end;
procedure TEvent.Reset;
begin
ResetEvent(FHandle);
end;
{ TSemaphore }
constructor TSemaphore.Create(const Name: string;
Initial,
Maxinum: Integer);
begin
FHandle := CreateSemaphore(nil, Initial, Maxinum, PChar(Name));
if FHandle = 0 then
abort;
end;
function TSemaphore.Get(TimeOut: Integer): Boolean;
begin
Result := WaitForSingleObject(FHandle, TimeOut) = WAIT_OBJECT_0;
end;
function TSemaphore.Release(Count: Integer): Boolean;
begin
Result := ReleaseSemaphore(Handle, Count, nil);
end;
function TSemaphore.Release(Count: Integer;
var PreviousCount: Integer): Boolean;
begin
Result := ReleaseSemaphore(Handle, Count, @PreviousCount);
end;
{ TFileMap }
constructor TFileMap.Create(const Name: string;
Size: Integer);
begin
try
FName := Name;
FSize := Size;
{ CreateFileMapping, when called with $FFFFFFFF for the hanlde value,
creates a region of shared memory }
FHandle := CreateFileMapping($FFFFFFFF, nil, PAGE_READWRITE, 0,
Size, PChar(Name));
if FHandle = 0 then
abort;
FCreated := GetLastError = 0;
{ We still need to map a pointer to the handle of the shared memory region }
FFileView := MapViewOfFile(FHandle, FILE_MAP_WRITE, 0, 0, Size);
if FFileView = nil then
abort;
except
Error(Format('创建内存映射文件失败， %s (%d)', [Name, GetLastError]));
end;
end;
destructor TFileMap.Destroy;
begin
if FFileView <> nil then
UnmapViewOfFile(FFileView);
inherited;
end;
constructor TFileMap.Open(const Name: string);
begin
try
FName := Name;
FSize := -1;
{ CreateFileMapping, when called with $FFFFFFFF for the hanlde value,
creates a region of shared memory }
FHandle := OpenFileMapping(0, True, PChar(Name));
if FHandle = 0 then
abort;
FCreated := GetLastError = 0;
{ We still need to map a pointer to the handle of the shared memory region }
FFileView := MapViewOfFile(FHandle, FILE_MAP_WRITE, 0, 0, Size);
if FFileView = nil then
abort;
except
Error(Format('创建内存映射文件失败， %s (%d)', [Name, GetLastError]));
end;
end;
{ TMemStream }
procedure TMemStream.Attach(PBuff: Pointer;
BuffSize: Integer);
begin
Clear;
SetPointer(PBuff, BuffSize);
Owned := False;
end;
procedure TMemStream.AttachOwnFree(PBuff: Pointer;
BuffSize: Integer);
begin
Clear;
SetPointer(PBuff, BuffSize);
Owned := True;
end;
procedure TMemStream.Clear;
begin
if Owned then
FreeMem(Memory);
end;
destructor TMemStream.Destroy;
begin
Clear;
inherited;
end;
procedure TMemStream.LoadFromStream(Stream: TStream);
var
Count: Longint;
begin
Stream.Position := 0;
Count := Size;
if Count <> 0 then
Stream.ReadBuffer(Memory^, Count);
end;
function TMemStream.ReadString(const Count: Integer): String;
var
ts: String;
Len: Integer;
begin
if Count > 0 then
begin
SetLength(ts, Count);
Len := Read(ts[1], Count);
Result := Copy(ts, 1, Len);
end else
Result := '';
end;
function TMemStream.Write(const Buffer;
Count: Integer): Longint;
var
Pos: Longint;
Num: Longint;
begin
if (Position >= 0) and (Count >= 0) then
begin
Pos := Position + Count;
if Pos > 0 then
begin
if Pos > Size then
Pos := Size;
Num := Pos - Position;
if Num > 0 then
begin
System.Move(Buffer, Pointer(Longint(Memory) + Position)^, Num);
Position := Pos;
Result := Num;
Exit;
end;
end;
end;
Result := 0;
end;
function TMemStream.WriteString(const S: String): Longint;
begin
if Length(S) > 0 then
Result := Write(S[1], Length(S))
else
Result := 0;
end;
end.
