View Issue Details
| ID | Project | Category | View Status | Date Submitted | Last Update |
|---|---|---|---|---|---|
| 0001681 | Double Commander | Default | public | 2017-01-02 16:22 | 2020-06-19 21:50 |
| Reporter | fedan | Assigned To | Alexx2000 | ||
| Priority | normal | Severity | tweak | Reproducibility | always |
| Status | closed | Resolution | fixed | ||
| Projection | none | ETA | none | ||
| Platform | Linux | OS | Calculate | ||
| Product Version | 1.0.0 (trunk) | ||||
| Target Version | 0.7.8 | Fixed in Version | 0.7.8 | ||
| Summary | 0001681: Support free pascal >= 3.0.1 | ||||
| Description | Патч поддержки сборки для fpc fixes_3_0. | ||||
| Tags | No tags attached. | ||||
| Attached Files | udcutils.diff (1,439 bytes)
Index: src/udcutils.pas
===================================================================
--- src/udcutils.pas (revision 7296)
+++ src/udcutils.pas (working copy)
@@ -931,6 +931,24 @@
Result := ord(pstr1[counter]) - ord(pstr2[counter]);
end;
+function LocalCompareTextWideString(const s1, s2 : WideString): PtrInt;
+begin
+{$if fpc_fullversion >= 30001}
+ Result := WideStringManager.CompareWideStringProc(s1, s2, [coIgnoreCase]);
+{$else fpc_fullversion}
+ Result := WideStringManager.CompareTextWideStringProc(s1, s2);
+{$endif}
+end;
+
+function LocalCompareWideString(const s1, s2 : WideString): PtrInt;
+begin
+{$if fpc_fullversion >= 30001}
+ Result := WideStringManager.CompareWideStringProc(s1, s2, []);
+{$else fpc_fullversion}
+ Result := WideStringManager.CompareTextWideStringProc(s1, s2);
+{$endif}
+end;
+
function StrFloatCmpW(str1, str2: PWideChar; CaseSensitivity: TCaseSensitivity): PtrInt;
var
is_digit1, is_digit2: boolean;
@@ -953,8 +971,8 @@
begin
// Set up compare function
case CaseSensitivity of
- cstNotSensitive: str_cmp:= WideStringManager.CompareTextWideStringProc;
- cstLocale: str_cmp:= WideStringManager.CompareWideStringProc;
+ cstNotSensitive: str_cmp:= @LocalCompareTextWideString;
+ cstLocale: str_cmp:= @LocalCompareWideString;
cstCharValue: str_cmp:= @WideStrComp;
else
raise Exception.Create('Invalid CaseSensitivity parameter');
upipeserver+udcutils.diff (32,037 bytes)
Index: src/platform/unix/simpleipc.inc
===================================================================
--- src/platform/unix/simpleipc.inc (nonexistent)
+++ src/platform/unix/simpleipc.inc (working copy)
@@ -0,0 +1,243 @@
+{
+ This file is part of the Free Component library.
+ Copyright (c) 2005 by Michael Van Canneyt, member of
+ the Free Pascal development team
+
+ Unix implementation of one-way IPC between 2 processes
+
+ See the file COPYING.FPC, included in this distribution,
+ for details about the copyright.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+
+{$ifdef ipcunit}
+unit pipesipc;
+
+interface
+
+uses sysutils, classes, simpleipc, baseunix;
+
+{$else}
+
+uses baseunix;
+{$endif}
+
+
+ResourceString
+ SErrFailedToCreatePipe = 'Failed to create named pipe: %s';
+ SErrFailedToRemovePipe = 'Failed to remove named pipe: %s';
+
+{ ---------------------------------------------------------------------
+ TPipeClientComm
+ ---------------------------------------------------------------------}
+
+Type
+ TPipeClientComm = Class(TIPCClientComm)
+ Private
+ FFileName: String;
+ FStream: TFileStream;
+ Public
+ Constructor Create(AOWner : TSimpleIPCClient); override;
+ Procedure Connect; override;
+ Procedure Disconnect; override;
+ Procedure SendMessage(MsgType : TMessageType; AStream : TStream); override;
+ Function ServerRunning : Boolean; override;
+ Property FileName : String Read FFileName;
+ Property Stream : TFileStream Read FStream;
+ end;
+
+{$ifdef ipcunit}
+implementation
+{$endif}
+
+constructor TPipeClientComm.Create(AOWner: TSimpleIPCClient);
+begin
+ inherited Create(AOWner);
+ FFileName:=Owner.ServerID;
+ If (Owner.ServerInstance<>'') then
+ FFileName:=FFileName+'-'+Owner.ServerInstance;
+ if FFileName[1]<>'/' then
+ FFileName:=GetTempDir(true)+FFileName;
+end;
+
+
+procedure TPipeClientComm.Connect;
+begin
+ If Not ServerRunning then
+ DoError(SErrServerNotActive,[Owner.ServerID]);
+ // Use the sharedenynone line to allow more then one client
+ // communicating with one server at the same time
+ // see also mantis 15219
+ FStream:=TFileStream.Create(FFileName,fmOpenWrite+fmShareDenyNone);
+ // FStream:=TFileStream.Create(FFileName,fmOpenWrite);
+end;
+
+procedure TPipeClientComm.Disconnect;
+begin
+ FreeAndNil(FStream);
+end;
+
+procedure TPipeClientComm.SendMessage(MsgType : TMessagetype; AStream: TStream);
+
+Var
+ Hdr : TMsgHeader;
+
+begin
+ Hdr.Version:=MsgVersion;
+ Hdr.msgType:=MsgType;
+ Hdr.MsgLen:=AStream.Size;
+ FStream.WriteBuffer(hdr,SizeOf(hdr));
+ FStream.CopyFrom(AStream,0);
+end;
+
+function TPipeClientComm.ServerRunning: Boolean;
+var
+ fd: cint;
+begin
+ Result:=FileExists(FFileName);
+ // it's possible to have a stale file that is not open for reading which will
+ // cause fpOpen to hang/block later when .Active is set to true while it
+ // wait's for the pipe to be opened on the other end
+ if Result then
+ begin
+ // O_WRONLY | O_NONBLOCK causes fpOpen to return -1 if the file is not open for reading
+ // so in fact the 'server' is not running
+ fd := FpOpen(FFileName, O_WRONLY or O_NONBLOCK);
+ if fd = -1 then
+ begin
+ Result := False;
+ // delete the named pipe since it's orphaned
+ FpUnlink(FFileName);
+ end
+ else
+ FpClose(fd);
+ end;
+end;
+
+
+{ ---------------------------------------------------------------------
+ TPipeServerComm
+ ---------------------------------------------------------------------}
+
+Type
+
+ { TPipeServerComm }
+
+ TPipeServerComm = Class(TIPCServerComm)
+ Private
+ FFileName: String;
+ FStream: TFileStream;
+ Protected
+ Procedure DoReadMessage; virtual;
+ Public
+ Constructor Create(AOWner : TSimpleIPCServer); override;
+ Procedure StartServer; override;
+ Procedure StopServer; override;
+ Function PeekMessage(TimeOut : Integer) : Boolean; override;
+ Procedure ReadMessage ; override;
+ Function GetInstanceID : String;override;
+ Property FileName : String Read FFileName;
+ Property Stream : TFileStream Read FStream;
+ end;
+
+procedure TPipeServerComm.DoReadMessage;
+
+Var
+ Hdr : TMsgHeader;
+
+begin
+ FStream.ReadBuffer(Hdr,SizeOf(Hdr));
+ PushMessage(Hdr,FStream);
+end;
+
+constructor TPipeServerComm.Create(AOWner: TSimpleIPCServer);
+begin
+ inherited Create(AOWner);
+ FFileName:=Owner.ServerID;
+ If Not Owner.Global then
+ FFileName:=FFileName+'-'+IntToStr(fpGetPID);
+ if FFileName[1]<>'/' then
+ FFileName:=GetTempDir(Owner.Global)+FFileName;
+end;
+
+
+procedure TPipeServerComm.StartServer;
+
+const
+ PrivateRights = S_IRUSR or S_IWUSR;
+ GlobalRights = PrivateRights or S_IRGRP or S_IWGRP or S_IROTH or S_IWOTH;
+ Rights : Array [Boolean] of Integer = (PrivateRights,GlobalRights);
+
+begin
+ If not FileExists(FFileName) then
+ If (fpmkFifo(FFileName,438)<>0) then
+ DoError(SErrFailedToCreatePipe,[FFileName]);
+ FStream:=TFileStream.Create(FFileName,fmOpenReadWrite+fmShareDenyNone,Rights[Owner.Global]);
+end;
+
+procedure TPipeServerComm.StopServer;
+begin
+ FreeAndNil(FStream);
+ if Not DeleteFile(FFileName) then
+ DoError(SErrFailedtoRemovePipe,[FFileName]);
+end;
+
+function TPipeServerComm.PeekMessage(TimeOut: Integer): Boolean;
+
+Var
+ FDS : TFDSet;
+
+begin
+ fpfd_zero(FDS);
+ fpfd_set(FStream.Handle,FDS);
+ Result:=False;
+ While fpSelect(FStream.Handle+1,@FDS,Nil,Nil,TimeOut)>0 do
+ begin
+ DoReadMessage;
+ Result:=True;
+ end;
+end;
+
+procedure TPipeServerComm.ReadMessage;
+
+begin
+ DoReadMessage;
+end;
+
+
+function TPipeServerComm.GetInstanceID: String;
+begin
+ Result:=IntToStr(fpGetPID);
+end;
+
+
+{ ---------------------------------------------------------------------
+ Set TSimpleIPCClient / TSimpleIPCServer defaults.
+ ---------------------------------------------------------------------}
+
+{$ifndef ipcunit}
+function TSimpleIPCServer.CommClass: TIPCServerCommClass;
+
+begin
+ if (DefaultIPCServerClass<>Nil) then
+ Result:=DefaultIPCServerClass
+ else
+ Result:=TPipeServerComm;
+end;
+
+function TSimpleIPCClient.CommClass: TIPCClientCommClass;
+begin
+ if (DefaultIPCClientClass<>Nil) then
+ Result:=DefaultIPCClientClass
+ else
+ Result:=TPipeClientComm;
+end;
+
+{$else ipcunit}
+
+end.
+{$endif}
Index: src/platform/unix/simpleipc.pp
===================================================================
--- src/platform/unix/simpleipc.pp (nonexistent)
+++ src/platform/unix/simpleipc.pp (working copy)
@@ -0,0 +1,872 @@
+{
+ This file is part of the Free Component library.
+ Copyright (c) 2005 by Michael Van Canneyt, member of
+ the Free Pascal development team
+
+ Unit implementing one-way IPC between 2 processes
+
+ See the file COPYING.FPC, included in this distribution,
+ for details about the copyright.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+unit simpleipc;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+ Contnrs, Classes, SysUtils;
+
+Const
+ MsgVersion = 1;
+ DefaultThreadTimeOut = 50;
+
+ //Message types
+ mtUnknown = 0;
+ mtString = 1;
+
+type
+ TIPCMessageOverflowAction = (ipcmoaNone, ipcmoaDiscardOld, ipcmoaDiscardNew, ipcmoaError);
+
+var
+ DefaultIPCMessageOverflowAction: TIPCMessageOverflowAction = ipcmoaNone;
+ DefaultIPCMessageQueueLimit: Integer = 0;
+
+Type
+
+ TMessageType = LongInt;
+ TMsgHeader = Packed record
+ Version : Byte;
+ MsgType : TMessageType;
+ MsgLen : Integer;
+ end;
+
+ TSimpleIPCServer = class;
+ TSimpleIPCClient = class;
+
+ TIPCServerMsg = class
+ strict private
+ FStream: TStream;
+ FMsgType: TMessageType;
+ public
+ constructor Create;
+ destructor Destroy; override;
+ property Stream: TStream read FStream;
+ property MsgType: TMessageType read FMsgType write FMsgType;
+ end;
+
+ TIPCServerMsgQueue = class
+ strict private
+ FList: TFPObjectList;
+ FMaxCount: Integer;
+ FMaxAction: TIPCMessageOverflowAction;
+ function GetCount: Integer;
+ procedure DeleteAndFree(Index: Integer);
+ function PrepareToPush: Boolean;
+ public
+ constructor Create;
+ destructor Destroy; override;
+ procedure Clear;
+ procedure Push(AItem: TIPCServerMsg);
+ function Pop: TIPCServerMsg;
+ property Count: Integer read GetCount;
+ property MaxCount: Integer read FMaxCount write FMaxCount;
+ property MaxAction: TIPCMessageOverflowAction read FMaxAction write FMaxAction;
+ end;
+
+ { TIPCServerComm }
+
+ TIPCServerComm = Class(TObject)
+ Private
+ FOwner : TSimpleIPCServer;
+ Protected
+ Function GetInstanceID : String; virtual; abstract;
+ Procedure DoError(const Msg : String; const Args : Array of const);
+ Procedure PushMessage(Const Hdr : TMsgHeader; AStream : TStream);
+ Procedure PushMessage(Msg : TIPCServerMsg);
+ Public
+ Constructor Create(AOwner : TSimpleIPCServer); virtual;
+ Property Owner : TSimpleIPCServer read FOwner;
+ Procedure StartServer; virtual; Abstract;
+ Procedure StopServer;virtual; Abstract;
+ // May push messages on the queue
+ Function PeekMessage(TimeOut : Integer) : Boolean;virtual; Abstract;
+ // Must put message on the queue.
+ Procedure ReadMessage ;virtual; Abstract;
+ Property InstanceID : String read GetInstanceID;
+ end;
+ TIPCServerCommClass = Class of TIPCServerComm;
+
+ { TSimpleIPC }
+ TSimpleIPC = Class(TComponent)
+ Private
+ procedure SetActive(const AValue: Boolean);
+ procedure SetServerID(const AValue: String);
+ Protected
+ FBusy: Boolean;
+ FActive : Boolean;
+ FServerID : String;
+ Procedure DoError(const Msg: String; const Args: array of const);
+ Procedure CheckInactive;
+ Procedure CheckActive;
+ Procedure Activate; virtual; abstract;
+ Procedure Deactivate; virtual; abstract;
+ Procedure Loaded; override;
+ Property Busy : Boolean Read FBusy;
+ Published
+ Property Active : Boolean Read FActive Write SetActive;
+ Property ServerID : String Read FServerID Write SetServerID;
+ end;
+
+ { TSimpleIPCServer }
+
+ TMessageQueueEvent = Procedure(Sender : TObject; Msg : TIPCServerMsg) of object;
+
+ TSimpleIPCServer = Class(TSimpleIPC)
+ protected
+ Private
+ FOnMessageError: TMessageQueueEvent;
+ FOnMessageQueued: TNotifyEvent;
+ FQueue : TIPCServerMsgQueue;
+ FGlobal: Boolean;
+ FOnMessage: TNotifyEvent;
+ FMsgType: TMessageType;
+ FMsgData : TStream;
+ FThreadTimeOut: Integer;
+ FThread : TThread;
+ FLock : TRTLCriticalSection;
+ FErrMsg : TIPCServerMsg;
+ procedure DoMessageQueued;
+ procedure DoMessageError;
+ function GetInstanceID: String;
+ function GetMaxAction: TIPCMessageOverflowAction;
+ function GetMaxQueue: Integer;
+ function GetStringMessage: String;
+ procedure SetGlobal(const AValue: Boolean);
+ procedure SetMaxAction(AValue: TIPCMessageOverflowAction);
+ procedure SetMaxQueue(AValue: Integer);
+ Protected
+ FIPCComm: TIPCServerComm;
+ procedure StartThread; virtual;
+ procedure StopThread; virtual;
+ Function CommClass : TIPCServerCommClass; virtual;
+ Procedure PushMessage(Msg : TIPCServerMsg); virtual;
+ function PopMessage: Boolean; virtual;
+ Procedure Activate; override;
+ Procedure Deactivate; override;
+ Property Queue : TIPCServerMsgQueue Read FQueue;
+ Property Thread : TThread Read FThread;
+ Public
+ Constructor Create(AOwner : TComponent); override;
+ Destructor Destroy; override;
+ Procedure StartServer(Threaded : Boolean = False);
+ Procedure StopServer;
+ Function PeekMessage(TimeOut : Integer; DoReadMessage : Boolean): Boolean;
+ Procedure ReadMessage;
+ Property StringMessage : String Read GetStringMessage;
+ Procedure GetMessageData(Stream : TStream);
+ Property MsgType: TMessageType Read FMsgType;
+ Property MsgData : TStream Read FMsgData;
+ Property InstanceID : String Read GetInstanceID;
+ Published
+ Property ThreadTimeOut : Integer Read FThreadTimeOut Write FThreadTimeOut;
+ Property Global : Boolean Read FGlobal Write SetGlobal;
+ // Called during ReadMessage
+ Property OnMessage : TNotifyEvent Read FOnMessage Write FOnMessage;
+ // Called when a message is pushed on the queue.
+ Property OnMessageQueued : TNotifyEvent Read FOnMessageQueued Write FOnMessageQueued;
+ // Called when the queue overflows and MaxAction = ipcmoaError.
+ Property OnMessageError : TMessageQueueEvent Read FOnMessageError Write FOnMessageError;
+ // Maximum number of messages to keep in the queue
+ property MaxQueue: Integer read GetMaxQueue write SetMaxQueue;
+ // What to do when the queue overflows
+ property MaxAction: TIPCMessageOverflowAction read GetMaxAction write SetMaxAction;
+ end;
+
+
+ { TIPCClientComm}
+ TIPCClientComm = Class(TObject)
+ private
+ FOwner: TSimpleIPCClient;
+ protected
+ Procedure DoError(const Msg : String; const Args : Array of const);
+ Public
+ Constructor Create(AOwner : TSimpleIPCClient); virtual;
+ Property Owner : TSimpleIPCClient read FOwner;
+ Procedure Connect; virtual; abstract;
+ Procedure Disconnect; virtual; abstract;
+ Function ServerRunning : Boolean; virtual; abstract;
+ Procedure SendMessage(MsgType : TMessageType; Stream : TStream);virtual;Abstract;
+ end;
+ TIPCClientCommClass = Class of TIPCClientComm;
+
+ { TSimpleIPCClient }
+ TSimpleIPCClient = Class(TSimpleIPC)
+ Private
+ FServerInstance: String;
+ procedure SetServerInstance(const AValue: String);
+ Protected
+ FIPCComm : TIPCClientComm;
+ Procedure Activate; override;
+ Procedure Deactivate; override;
+ Function CommClass : TIPCClientCommClass; virtual;
+ Public
+ Constructor Create(AOwner : TComponent); override;
+ Destructor Destroy; override;
+ Procedure Connect;
+ Procedure Disconnect;
+ Function ServerRunning : Boolean;
+ Procedure SendMessage(MsgType : TMessageType; Stream: TStream);
+ Procedure SendStringMessage(const Msg : String);
+ Procedure SendStringMessage(MsgType : TMessageType; const Msg : String);
+ Procedure SendStringMessageFmt(const Msg : String; Args : Array of const);
+ Procedure SendStringMessageFmt(MsgType : TMessageType; const Msg : String; Args : Array of const);
+ Property ServerInstance : String Read FServerInstance Write SetServerInstance;
+ end;
+
+
+ EIPCError = Class(Exception);
+
+Var
+ DefaultIPCServerClass : TIPCServerCommClass = Nil;
+ DefaultIPCClientClass : TIPCClientCommClass = Nil;
+
+resourcestring
+ SErrServerNotActive = 'Server with ID %s is not active.';
+ SErrActive = 'This operation is illegal when the server is active.';
+ SErrInActive = 'This operation is illegal when the server is inactive.';
+
+
+implementation
+
+{ ---------------------------------------------------------------------
+ Include platform specific implementation.
+ Should implement the CommClass method of both server and client component,
+ as well as the communication class itself.
+
+ This comes first, to allow the uses clause to be set.
+ If the include file defines OSNEEDIPCINITDONE then the unit will
+ call IPCInit and IPCDone in the initialization/finalization code.
+
+ --------------------------------------------------------------------- }
+{$UNDEF OSNEEDIPCINITDONE}
+
+{$i simpleipc.inc}
+
+Resourcestring
+ SErrMessageQueueOverflow = 'Message queue overflow (limit %s)';
+
+{ ---------------------------------------------------------------------
+ TIPCServerMsg
+ ---------------------------------------------------------------------}
+
+
+constructor TIPCServerMsg.Create;
+begin
+ FMsgType := 0;
+ FStream := TMemoryStream.Create;
+end;
+
+destructor TIPCServerMsg.Destroy;
+begin
+ FStream.Free;
+end;
+
+{ ---------------------------------------------------------------------
+ TIPCServerMsgQueue
+ ---------------------------------------------------------------------}
+
+constructor TIPCServerMsgQueue.Create;
+begin
+ FMaxCount := DefaultIPCMessageQueueLimit;
+ FMaxAction := DefaultIPCMessageOverflowAction;
+ FList := TFPObjectList.Create(False); // FreeObjects = False!
+end;
+
+destructor TIPCServerMsgQueue.Destroy;
+begin
+ Clear;
+ FList.Free;
+end;
+
+procedure TIPCServerMsgQueue.Clear;
+begin
+ while FList.Count > 0 do
+ DeleteAndFree(FList.Count - 1);
+end;
+
+procedure TIPCServerMsgQueue.DeleteAndFree(Index: Integer);
+begin
+ FList[Index].Free; // Free objects manually!
+ FList.Delete(Index);
+end;
+
+function TIPCServerMsgQueue.GetCount: Integer;
+begin
+ Result := FList.Count;
+end;
+
+function TIPCServerMsgQueue.PrepareToPush: Boolean;
+begin
+ Result := True;
+ case FMaxAction of
+ ipcmoaDiscardOld:
+ begin
+ while (FList.Count >= FMaxCount) do
+ DeleteAndFree(FList.Count - 1);
+ end;
+ ipcmoaDiscardNew:
+ begin
+ Result := (FList.Count < FMaxCount);
+ end;
+ ipcmoaError:
+ begin
+ if (FList.Count >= FMaxCount) then
+ // Caller is expected to catch this exception, so not using Owner.DoError()
+ raise EIPCError.CreateFmt(SErrMessageQueueOverflow, [IntToStr(FMaxCount)]);
+ end;
+ end;
+end;
+
+procedure TIPCServerMsgQueue.Push(AItem: TIPCServerMsg);
+begin
+ if PrepareToPush then
+ FList.Insert(0, AItem);
+end;
+
+function TIPCServerMsgQueue.Pop: TIPCServerMsg;
+var
+ Index: Integer;
+begin
+ Index := FList.Count - 1;
+ if Index >= 0 then
+ begin
+ // Caller is responsible for freeing the object.
+ Result := TIPCServerMsg(FList[Index]);
+ FList.Delete(Index);
+ end
+ else
+ Result := nil;
+end;
+
+
+{ ---------------------------------------------------------------------
+ TIPCServerComm
+ ---------------------------------------------------------------------}
+
+constructor TIPCServerComm.Create(AOwner: TSimpleIPCServer);
+begin
+ FOwner:=AOWner;
+end;
+
+procedure TIPCServerComm.DoError(const Msg: String; const Args: array of const);
+
+begin
+ FOwner.DoError(Msg,Args);
+end;
+
+procedure TIPCServerComm.PushMessage(const Hdr: TMsgHeader; AStream: TStream);
+
+Var
+ M : TIPCServerMsg;
+
+begin
+ M:=TIPCServerMsg.Create;
+ try
+ M.MsgType:=Hdr.MsgType;
+ if Hdr.MsgLen>0 then
+ M.Stream.CopyFrom(AStream,Hdr.MsgLen);
+ except
+ M.Free;
+ Raise;
+ end;
+ PushMessage(M);
+end;
+
+procedure TIPCServerComm.PushMessage(Msg: TIPCServerMsg);
+begin
+ FOwner.PushMessage(Msg);
+end;
+
+{ ---------------------------------------------------------------------
+ TIPCClientComm
+ ---------------------------------------------------------------------}
+
+constructor TIPCClientComm.Create(AOwner: TSimpleIPCClient);
+begin
+ FOwner:=AOwner;
+end;
+
+Procedure TIPCClientComm.DoError(const Msg : String; const Args : Array of const);
+
+begin
+ FOwner.DoError(Msg,Args);
+end;
+
+{ ---------------------------------------------------------------------
+ TSimpleIPC
+ ---------------------------------------------------------------------}
+
+Procedure TSimpleIPC.DoError(const Msg: String; const Args: array of const);
+var
+ FullMsg: String;
+begin
+ if Length(Name) > 0
+ then FullMsg := Name + ': '
+ else FullMsg := '';
+ FullMsg := FullMsg + Format(Msg, Args);
+ raise EIPCError.Create(FullMsg);
+end;
+
+procedure TSimpleIPC.CheckInactive;
+begin
+ if not (csLoading in ComponentState) then
+ If Active then
+ DoError(SErrActive,[]);
+end;
+
+procedure TSimpleIPC.CheckActive;
+begin
+ if not (csLoading in ComponentState) then
+ If Not Active then
+ DoError(SErrInActive,[]);
+end;
+
+procedure TSimpleIPC.SetActive(const AValue: Boolean);
+begin
+ if (FActive<>AValue) then
+ begin
+ if ([]<>([csLoading,csDesigning]*ComponentState)) then
+ FActive:=AValue
+ else
+ If AValue then
+ Activate
+ else
+ Deactivate;
+ end;
+end;
+
+procedure TSimpleIPC.SetServerID(const AValue: String);
+begin
+ if (FServerID<>AValue) then
+ begin
+ CheckInactive;
+ FServerID:=AValue
+ end;
+end;
+
+Procedure TSimpleIPC.Loaded;
+
+Var
+ B : Boolean;
+
+begin
+ Inherited;
+ B:=FActive;
+ if B then
+ begin
+ Factive:=False;
+ Activate;
+ end;
+end;
+
+{ ---------------------------------------------------------------------
+ TSimpleIPCServer
+ ---------------------------------------------------------------------}
+
+constructor TSimpleIPCServer.Create(AOwner: TComponent);
+begin
+ inherited Create(AOwner);
+ FGlobal:=False;
+ FActive:=False;
+ FBusy:=False;
+ FMsgData:=TStringStream.Create('');
+ FQueue:=TIPCServerMsgQueue.Create;
+ FThreadTimeOut:=DefaultThreadTimeOut;
+end;
+
+destructor TSimpleIPCServer.Destroy;
+begin
+ Active:=False;
+ FreeAndNil(FQueue);
+ FreeAndNil(FMsgData);
+ inherited Destroy;
+end;
+
+procedure TSimpleIPCServer.SetGlobal(const AValue: Boolean);
+begin
+ if (FGlobal<>AValue) then
+ begin
+ CheckInactive;
+ FGlobal:=AValue;
+ end;
+end;
+
+procedure TSimpleIPCServer.SetMaxAction(AValue: TIPCMessageOverflowAction);
+begin
+ FQueue.MaxAction:=AValue;
+end;
+
+procedure TSimpleIPCServer.SetMaxQueue(AValue: Integer);
+begin
+ FQueue.MaxCount:=AValue;
+end;
+
+function TSimpleIPCServer.GetInstanceID: String;
+begin
+ Result:=FIPCComm.InstanceID;
+end;
+
+function TSimpleIPCServer.GetMaxAction: TIPCMessageOverflowAction;
+begin
+ Result:=FQueue.MaxAction;
+end;
+
+function TSimpleIPCServer.GetMaxQueue: Integer;
+begin
+ Result:=FQueue.MaxCount;
+end;
+
+
+function TSimpleIPCServer.GetStringMessage: String;
+begin
+ Result:=TStringStream(FMsgData).DataString;
+end;
+
+
+procedure TSimpleIPCServer.StartServer(Threaded : Boolean = False);
+begin
+ if Not Assigned(FIPCComm) then
+ begin
+ If (FServerID='') then
+ FServerID:=ApplicationName;
+ FIPCComm:=CommClass.Create(Self);
+ FIPCComm.StartServer;
+ end;
+ FActive:=True;
+ If Threaded then
+ StartThread;
+end;
+
+Type
+
+ { TServerThread }
+
+ TServerThread = Class(TThread)
+ private
+ FServer: TSimpleIPCServer;
+ FThreadTimeout: Integer;
+ Public
+ Constructor Create(AServer : TSimpleIPCServer; ATimeout : integer);
+ procedure Execute; override;
+ Property Server : TSimpleIPCServer Read FServer;
+ Property ThreadTimeout : Integer Read FThreadTimeout;
+ end;
+
+{ TServerThread }
+
+constructor TServerThread.Create(AServer: TSimpleIPCServer; ATimeout: integer);
+begin
+ FServer:=AServer;
+ FThreadTimeout:=ATimeOut;
+ Inherited Create(False);
+end;
+
+procedure TServerThread.Execute;
+begin
+ While Not Terminated do
+ FServer.PeekMessage(ThreadTimeout,False);
+end;
+
+procedure TSimpleIPCServer.StartThread;
+
+begin
+ InitCriticalSection(FLock);
+ FThread:=TServerThread.Create(Self,ThreadTimeOut);
+end;
+
+procedure TSimpleIPCServer.StopThread;
+
+begin
+ if Assigned(FThread) then
+ begin
+ FThread.Terminate;
+ FThread.WaitFor;
+ FreeAndNil(FThread);
+ DoneCriticalSection(FLock);
+ end;
+end;
+
+procedure TSimpleIPCServer.StopServer;
+begin
+ StopThread;
+ If Assigned(FIPCComm) then
+ begin
+ FIPCComm.StopServer;
+ FreeAndNil(FIPCComm);
+ end;
+ FQueue.Clear;
+ FActive:=False;
+end;
+
+// TimeOut values:
+// > 0 -- Number of milliseconds to wait
+// = 0 -- return immediately
+// = -1 -- wait infinitely
+// < -1 -- wait infinitely (force to -1)
+function TSimpleIPCServer.PeekMessage(TimeOut: Integer; DoReadMessage: Boolean): Boolean;
+begin
+ CheckActive;
+ Result:=Queue.Count>0;
+ If Not Result then
+ begin
+ if TimeOut < -1 then
+ TimeOut := -1;
+ FBusy:=True;
+ Try
+ Result:=FIPCComm.PeekMessage(Timeout);
+ Finally
+ FBusy:=False;
+ end;
+ end;
+ If Result then
+ If DoReadMessage then
+ Readmessage;
+end;
+
+function TSimpleIPCServer.PopMessage: Boolean;
+
+var
+ MsgItem: TIPCServerMsg;
+ DoLock : Boolean;
+
+begin
+ DoLock:=Assigned(FThread);
+ if DoLock then
+ EnterCriticalsection(Flock);
+ try
+ MsgItem:=FQueue.Pop;
+ finally
+ LeaveCriticalsection(FLock);
+ end;
+ Result:=Assigned(MsgItem);
+ if Result then
+ try
+ FMsgType := MsgItem.MsgType;
+ MsgItem.Stream.Position := 0;
+ FMsgData.Size := 0;
+ FMsgData.CopyFrom(MsgItem.Stream, MsgItem.Stream.Size);
+ finally
+ MsgItem.Free;
+ end;
+end;
+
+procedure TSimpleIPCServer.ReadMessage;
+
+begin
+ CheckActive;
+ FBusy:=True;
+ Try
+ if (FQueue.Count=0) then
+ // Readmessage pushes a message to the queue
+ FIPCComm.ReadMessage;
+ if PopMessage then
+ If Assigned(FOnMessage) then
+ FOnMessage(Self);
+ Finally
+ FBusy:=False;
+ end;
+end;
+
+procedure TSimpleIPCServer.GetMessageData(Stream: TStream);
+begin
+ Stream.CopyFrom(FMsgData,0);
+end;
+
+procedure TSimpleIPCServer.Activate;
+begin
+ StartServer;
+end;
+
+procedure TSimpleIPCServer.Deactivate;
+begin
+ StopServer;
+end;
+
+
+procedure TSimpleIPCServer.DoMessageQueued;
+
+begin
+ if Assigned(FOnMessageQueued) then
+ FOnMessageQueued(Self);
+end;
+
+procedure TSimpleIPCServer.DoMessageError;
+begin
+ try
+ if Assigned(FOnMessageQueued) then
+ FOnMessageError(Self,FErrMsg);
+ finally
+ FreeAndNil(FErrMsg)
+ end;
+end;
+
+procedure TSimpleIPCServer.PushMessage(Msg: TIPCServerMsg);
+
+Var
+ DoLock : Boolean;
+
+begin
+ try
+ DoLock:=Assigned(FThread);
+ If DoLock then
+ EnterCriticalsection(FLock);
+ try
+ Queue.Push(Msg);
+ finally
+ If DoLock then
+ LeaveCriticalsection(FLock);
+ end;
+ if DoLock then
+ TThread.Synchronize(FThread,@DoMessageQueued)
+ else
+ DoMessageQueued;
+ except
+ On E : Exception do
+ FErrMsg:=Msg;
+ end;
+ if Assigned(FErrMsg) then
+ if DoLock then
+ TThread.Synchronize(FThread,@DoMessageError)
+ else
+ DoMessageQueued;
+
+end;
+
+
+
+{ ---------------------------------------------------------------------
+ TSimpleIPCClient
+ ---------------------------------------------------------------------}
+
+procedure TSimpleIPCClient.SetServerInstance(const AValue: String);
+begin
+ CheckInactive;
+ FServerInstance:=AVAlue;
+end;
+
+procedure TSimpleIPCClient.Activate;
+begin
+ Connect;
+end;
+
+procedure TSimpleIPCClient.Deactivate;
+begin
+ DisConnect;
+end;
+constructor TSimpleIPCClient.Create(AOwner: TComponent);
+begin
+ inherited Create(AOwner);
+end;
+
+destructor TSimpleIPCClient.destroy;
+begin
+ Active:=False;
+ Inherited;
+end;
+
+procedure TSimpleIPCClient.Connect;
+begin
+ If Not assigned(FIPCComm) then
+ begin
+ FIPCComm:=CommClass.Create(Self);
+ Try
+ FIPCComm.Connect;
+ Except
+ FreeAndNil(FIPCComm);
+ Raise;
+ end;
+ FActive:=True;
+ end;
+end;
+
+procedure TSimpleIPCClient.Disconnect;
+begin
+ If Assigned(FIPCComm) then
+ Try
+ FIPCComm.DisConnect;
+ Finally
+ FActive:=False;
+ FreeAndNil(FIPCComm);
+ end;
+end;
+
+function TSimpleIPCClient.ServerRunning: Boolean;
+
+begin
+ If Assigned(FIPCComm) then
+ Result:=FIPCComm.ServerRunning
+ else
+ With CommClass.Create(Self) do
+ Try
+ Result:=ServerRunning;
+ finally
+ Free;
+ end;
+end;
+
+procedure TSimpleIPCClient.SendMessage(MsgType : TMessageType; Stream: TStream);
+
+begin
+ CheckActive;
+ FBusy:=True;
+ Try
+ FIPCComm.SendMessage(MsgType,Stream);
+ Finally
+ FBusy:=False;
+ end;
+end;
+
+procedure TSimpleIPCClient.SendStringMessage(const Msg: String);
+begin
+ SendStringMessage(mtString,Msg);
+end;
+
+procedure TSimpleIPCClient.SendStringMessage(MsgType: TMessageType; const Msg: String
+ );
+Var
+ S : TStringStream;
+begin
+ S:=TStringStream.Create(Msg);
+ try
+ SendMessage(MsgType,S);
+ finally
+ S.free;
+ end;
+end;
+
+procedure TSimpleIPCClient.SendStringMessageFmt(const Msg: String;
+ Args: array of const);
+begin
+ SendStringMessageFmt(mtString,Msg,Args);
+end;
+
+procedure TSimpleIPCClient.SendStringMessageFmt(MsgType: TMessageType;
+ const Msg: String; Args: array of const);
+begin
+ SendStringMessage(MsgType, Format(Msg,Args));
+end;
+
+{$IFDEF OSNEEDIPCINITDONE}
+initialization
+ IPCInit;
+finalization
+ IPCDone;
+{$ENDIF}
+end.
+
Index: src/platform/unix/upipeserver.pas
===================================================================
--- src/platform/unix/upipeserver.pas (revision 7296)
+++ src/platform/unix/upipeserver.pas (working copy)
@@ -36,6 +36,8 @@
FStream: TFileStream;
private
procedure Handler(Sender: TObject);
+ Protected
+ Procedure DoReadMessage; virtual;
Public
Constructor Create(AOWner : TSimpleIPCServer); override;
Procedure StartServer; override;
@@ -65,20 +67,25 @@
end;
constructor TPipeServerComm.Create(AOWner: TSimpleIPCServer);
-
-Var
- D : String;
-
begin
inherited Create(AOWner);
FFileName:=Owner.ServerID;
If Not Owner.Global then
FFileName:=FFileName+'-'+IntToStr(fpGetPID);
- D:='/tmp/'; // Change to something better later
- FFileName:=D+FFileName;
+ if FFileName[1]<>'/' then
+ FFileName:=GetTempDir(Owner.Global)+FFileName;
end;
+procedure TPipeServerComm.DoReadMessage;
+Var
+ Hdr : TMsgHeader;
+
+begin
+ FStream.ReadBuffer(Hdr,SizeOf(Hdr));
+ PushMessage(Hdr,FStream);
+end;
+
procedure TPipeServerComm.StartServer;
const
@@ -110,27 +117,18 @@
begin
fpfd_zero(FDS);
fpfd_set(FStream.Handle,FDS);
- Result:=fpSelect(FStream.Handle+1,@FDS,Nil,Nil,TimeOut)>0;
+ Result:=False;
+ While fpSelect(FStream.Handle+1,@FDS,Nil,Nil,TimeOut)>0 do
+ begin
+ DoReadMessage;
+ Result:=True;
+ end;
end;
procedure TPipeServerComm.ReadMessage;
-Var
- Count : Integer;
- Hdr : TMsgHeader;
- M : TStream;
begin
- FStream.ReadBuffer(Hdr,SizeOf(Hdr));
- SetMsgType(Hdr.MsgType);
- Count:=Hdr.MsgLen;
- M:=MsgData;
- if count > 0 then
- begin
- M.Seek(0,soFrombeginning);
- M.CopyFrom(FStream,Count);
- end
- else
- M.Size := 0;
+ DoReadMessage;
end;
function TPipeServerComm.GetInstanceID: String;
Index: src/udcutils.pas
===================================================================
--- src/udcutils.pas (revision 7296)
+++ src/udcutils.pas (working copy)
@@ -931,6 +931,24 @@
Result := ord(pstr1[counter]) - ord(pstr2[counter]);
end;
+function LocalCompareTextWideString(const s1, s2 : WideString): PtrInt;
+begin
+{$if fpc_fullversion >= 30001}
+ Result := WideStringManager.CompareWideStringProc(s1, s2, [coIgnoreCase]);
+{$else fpc_fullversion}
+ Result := WideStringManager.CompareTextWideStringProc(s1, s2);
+{$endif}
+end;
+
+function LocalCompareWideString(const s1, s2 : WideString): PtrInt;
+begin
+{$if fpc_fullversion >= 30001}
+ Result := WideStringManager.CompareWideStringProc(s1, s2, []);
+{$else fpc_fullversion}
+ Result := WideStringManager.CompareTextWideStringProc(s1, s2);
+{$endif}
+end;
+
function StrFloatCmpW(str1, str2: PWideChar; CaseSensitivity: TCaseSensitivity): PtrInt;
var
is_digit1, is_digit2: boolean;
@@ -953,8 +971,8 @@
begin
// Set up compare function
case CaseSensitivity of
- cstNotSensitive: str_cmp:= WideStringManager.CompareTextWideStringProc;
- cstLocale: str_cmp:= WideStringManager.CompareWideStringProc;
+ cstNotSensitive: str_cmp:= @LocalCompareTextWideString;
+ cstLocale: str_cmp:= @LocalCompareWideString;
cstCharValue: str_cmp:= @WideStrComp;
else
raise Exception.Create('Invalid CaseSensitivity parameter');
upipeserver+udcutils_v2.diff (21,705 bytes)
Index: src/platform/unix/simpleipc.inc
===================================================================
--- src/platform/unix/simpleipc.inc (nonexistent)
+++ src/platform/unix/simpleipc.inc (working copy)
@@ -0,0 +1,304 @@
+{
+ This file is part of the Free Component library.
+ Copyright (c) 2005 by Michael Van Canneyt, member of
+ the Free Pascal development team
+
+ Unix implementation of one-way IPC between 2 processes
+
+ See the file COPYING.FPC, included in this distribution,
+ for details about the copyright.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+
+{$ifdef ipcunit}
+unit pipesipc;
+
+interface
+
+uses sysutils, classes, simpleipc, baseunix;
+
+{$else}
+
+uses baseunix;
+{$endif}
+
+{$DEFINE OSNEEDIPCINITDONE}
+
+
+
+
+ResourceString
+ SErrFailedToCreatePipe = 'Failed to create named pipe: %s';
+ SErrFailedToRemovePipe = 'Failed to remove named pipe: %s';
+
+{ ---------------------------------------------------------------------
+ TPipeClientComm
+ ---------------------------------------------------------------------}
+
+Type
+ TPipeClientComm = Class(TIPCClientComm)
+ Private
+ FFileName: String;
+ FStream: TFileStream;
+ Public
+ Constructor Create(AOWner : TSimpleIPCClient); override;
+ Procedure Connect; override;
+ Procedure Disconnect; override;
+ Procedure SendMessage(MsgType : TMessageType; AStream : TStream); override;
+ Function ServerRunning : Boolean; override;
+ Property FileName : String Read FFileName;
+ Property Stream : TFileStream Read FStream;
+ end;
+
+{$ifdef ipcunit}
+implementation
+{$endif}
+
+Var
+ SocketFiles : TStringList;
+
+Procedure IPCInit;
+
+begin
+end;
+
+Procedure IPCDone;
+
+Var
+ I : integer;
+
+begin
+ if Assigned(SocketFiles) then
+ try
+ For I:=0 to SocketFiles.Count-1 do
+ DeleteFile(SocketFiles[i]);
+ finally
+ FreeAndNil(SocketFiles);
+ end;
+end;
+
+
+Procedure RegisterSocketFile(Const AFileName : String);
+
+begin
+ If Not Assigned(SocketFiles) then
+ begin
+ SocketFiles:=TStringList.Create;
+ SocketFiles.Sorted:=True;
+ end;
+ SocketFiles.Add(AFileName);
+end;
+
+Procedure UnRegisterSocketFile(Const AFileName : String);
+
+Var
+ I : Integer;
+begin
+ If Assigned(SocketFiles) then
+ begin
+ I:=SocketFiles.IndexOf(AFileName);
+ If (I<>-1) then
+ SocketFiles.Delete(I);
+ If (SocketFiles.Count=0) then
+ FreeAndNil(SocketFiles);
+ end;
+end;
+
+
+constructor TPipeClientComm.Create(AOWner: TSimpleIPCClient);
+
+Var
+ D : String;
+
+begin
+ inherited Create(AOWner);
+ FFileName:=Owner.ServerID;
+ If (Owner.ServerInstance<>'') then
+ FFileName:=FFileName+'-'+Owner.ServerInstance;
+ D:='/tmp/'; // Change to something better later
+ FFileName:=D+FFileName;
+end;
+
+
+procedure TPipeClientComm.Connect;
+begin
+ If Not ServerRunning then
+ DoError(SErrServerNotActive,[Owner.ServerID]);
+ // Use the sharedenynone line to allow more then one client
+ // communicating with one server at the same time
+ // see also mantis 15219
+ FStream:=TFileStream.Create(FFileName,fmOpenWrite+fmShareDenyNone);
+ // FStream:=TFileStream.Create(FFileName,fmOpenWrite);
+end;
+
+procedure TPipeClientComm.Disconnect;
+begin
+ FreeAndNil(FStream);
+end;
+
+procedure TPipeClientComm.SendMessage(MsgType : TMessagetype; AStream: TStream);
+
+Var
+ Hdr : TMsgHeader;
+ P,L,Count : Integer;
+
+begin
+ Hdr.Version:=MsgVersion;
+ Hdr.msgType:=MsgType;
+ Hdr.MsgLen:=AStream.Size;
+ FStream.WriteBuffer(hdr,SizeOf(hdr));
+ FStream.CopyFrom(AStream,0);
+end;
+
+function TPipeClientComm.ServerRunning: Boolean;
+var
+ fd: cint;
+begin
+ Result:=FileExists(FFileName);
+ // it's possible to have a stale file that is not open for reading which will
+ // cause fpOpen to hang/block later when .Active is set to true while it
+ // wait's for the pipe to be opened on the other end
+ if Result then
+ begin
+ // O_WRONLY | O_NONBLOCK causes fpOpen to return -1 if the file is not open for reading
+ // so in fact the 'server' is not running
+ fd := FpOpen(FFileName, O_WRONLY or O_NONBLOCK);
+ if fd = -1 then
+ begin
+ Result := False;
+ // delete the named pipe since it's orphaned
+ FpUnlink(FFileName);
+ end
+ else
+ FpClose(fd);
+ end;
+end;
+
+
+{ ---------------------------------------------------------------------
+ TPipeServerComm
+ ---------------------------------------------------------------------}
+
+Type
+ TPipeServerComm = Class(TIPCServerComm)
+ Private
+ FFileName: String;
+ FStream: TFileStream;
+ Public
+ Constructor Create(AOWner : TSimpleIPCServer); override;
+ Procedure StartServer; override;
+ Procedure StopServer; override;
+ Function PeekMessage(TimeOut : Integer) : Boolean; override;
+ Procedure ReadMessage ; override;
+ Function GetInstanceID : String;override;
+ Property FileName : String Read FFileName;
+ Property Stream : TFileStream Read FStream;
+ end;
+
+constructor TPipeServerComm.Create(AOWner: TSimpleIPCServer);
+
+Var
+ D : String;
+
+begin
+ inherited Create(AOWner);
+ FFileName:=Owner.ServerID;
+ If Not Owner.Global then
+ FFileName:=FFileName+'-'+IntToStr(fpGetPID);
+ D:='/tmp/'; // Change to something better later
+ FFileName:=D+FFileName;
+end;
+
+
+procedure TPipeServerComm.StartServer;
+
+const
+ PrivateRights = S_IRUSR or S_IWUSR;
+ GlobalRights = PrivateRights or S_IRGRP or S_IWGRP or S_IROTH or S_IWOTH;
+ Rights : Array [Boolean] of Integer = (PrivateRights,GlobalRights);
+
+begin
+ If not FileExists(FFileName) then
+ If (fpmkFifo(FFileName,438)<>0) then
+ DoError(SErrFailedToCreatePipe,[FFileName]);
+ FStream:=TFileStream.Create(FFileName,fmOpenReadWrite+fmShareDenyNone,Rights[Owner.Global]);
+ RegisterSocketFile(FFileName);
+end;
+
+procedure TPipeServerComm.StopServer;
+begin
+ UnregisterSocketFile(FFileName);
+ FreeAndNil(FStream);
+ if Not DeleteFile(FFileName) then
+ DoError(SErrFailedtoRemovePipe,[FFileName]);
+end;
+
+function TPipeServerComm.PeekMessage(TimeOut: Integer): Boolean;
+
+Var
+ FDS : TFDSet;
+
+begin
+ fpfd_zero(FDS);
+ fpfd_set(FStream.Handle,FDS);
+ Result:=fpSelect(FStream.Handle+1,@FDS,Nil,Nil,TimeOut)>0;
+end;
+
+procedure TPipeServerComm.ReadMessage;
+
+Var
+ L,P,Count : Integer;
+ Hdr : TMsgHeader;
+ M : TStream;
+begin
+ FStream.ReadBuffer(Hdr,SizeOf(Hdr));
+ SetMsgType(Hdr.MsgType);
+ Count:=Hdr.MsgLen;
+ M:=MsgData;
+ if count > 0 then
+ begin
+ M.Seek(0,soFrombeginning);
+ M.CopyFrom(FStream,Count);
+ end
+ else
+ M.Size := 0;
+end;
+
+function TPipeServerComm.GetInstanceID: String;
+begin
+ Result:=IntToStr(fpGetPID);
+end;
+
+{ ---------------------------------------------------------------------
+ Set TSimpleIPCClient / TSimpleIPCServer defaults.
+ ---------------------------------------------------------------------}
+{$ifndef ipcunit}
+Function TSimpleIPCServer.CommClass : TIPCServerCommClass;
+
+begin
+ if (DefaultIPCServerClass<>Nil) then
+ Result:=DefaultIPCServerClass
+ else
+ Result:=TPipeServerComm;
+end;
+
+function TSimpleIPCClient.CommClass: TIPCClientCommClass;
+begin
+ if (DefaultIPCClientClass<>Nil) then
+ Result:=DefaultIPCClientClass
+ else
+ Result:=TPipeClientComm;
+end;
+
+{$else ipcunit}
+initialization
+ IPCInit;
+
+Finalization
+ IPCDone;
+end.
+{$endif}
Index: src/platform/unix/simpleipc.pp
===================================================================
--- src/platform/unix/simpleipc.pp (nonexistent)
+++ src/platform/unix/simpleipc.pp (working copy)
@@ -0,0 +1,496 @@
+{
+ This file is part of the Free Component library.
+ Copyright (c) 2005 by Michael Van Canneyt, member of
+ the Free Pascal development team
+
+ Unit implementing one-way IPC between 2 processes
+
+ See the file COPYING.FPC, included in this distribution,
+ for details about the copyright.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+unit simpleipc;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+ Classes, SysUtils;
+
+Const
+ MsgVersion = 1;
+
+ //Message types
+ mtUnknown = 0;
+ mtString = 1;
+
+Type
+
+ TMessageType = LongInt;
+ TMsgHeader = Packed record
+ Version : Byte;
+ MsgType : TMessageType;
+ MsgLen : Integer;
+ end;
+
+ TSimpleIPCServer = class;
+ TSimpleIPCClient = class;
+
+ { TIPCServerComm }
+
+ TIPCServerComm = Class(TObject)
+ Private
+ FOwner : TSimpleIPCServer;
+ Protected
+ Function GetInstanceID : String; virtual; abstract;
+ Procedure DoError(Msg : String; Args : Array of const);
+ Procedure SetMsgType(AMsgType: TMessageType);
+ Function MsgData : TStream;
+ Public
+ Constructor Create(AOwner : TSimpleIPCServer); virtual;
+ Property Owner : TSimpleIPCServer read FOwner;
+ Procedure StartServer; virtual; Abstract;
+ Procedure StopServer;virtual; Abstract;
+ Function PeekMessage(TimeOut : Integer) : Boolean;virtual; Abstract;
+ Procedure ReadMessage ;virtual; Abstract;
+ Property InstanceID : String read GetInstanceID;
+ end;
+ TIPCServerCommClass = Class of TIPCServerComm;
+
+ { TSimpleIPC }
+ TSimpleIPC = Class(TComponent)
+ Private
+ procedure SetActive(const AValue: Boolean);
+ procedure SetServerID(const AValue: String);
+ Protected
+ FBusy: Boolean;
+ FActive : Boolean;
+ FServerID : String;
+ Procedure DoError(Msg : String; Args : Array of const);
+ Procedure CheckInactive;
+ Procedure CheckActive;
+ Procedure Activate; virtual; abstract;
+ Procedure Deactivate; virtual; abstract;
+ Property Busy : Boolean Read FBusy;
+ Published
+ Property Active : Boolean Read FActive Write SetActive;
+ Property ServerID : String Read FServerID Write SetServerID;
+ end;
+
+ { TSimpleIPCServer }
+
+ TSimpleIPCServer = Class(TSimpleIPC)
+ private
+ FGlobal: Boolean;
+ FOnMessage: TNotifyEvent;
+ FMsgType: TMessageType;
+ FMsgData : TStream;
+ function GetInstanceID: String;
+ function GetStringMessage: String;
+ procedure SetGlobal(const AValue: Boolean);
+ Protected
+ FIPCComm: TIPCServerComm;
+ Function CommClass : TIPCServerCommClass; virtual;
+ Procedure Activate; override;
+ Procedure Deactivate; override;
+ Procedure ReadMessage;
+ Public
+ Constructor Create(AOwner : TComponent); override;
+ Destructor Destroy; override;
+ Procedure StartServer;
+ Procedure StopServer;
+ Function PeekMessage(TimeOut : Integer; DoReadMessage : Boolean): Boolean;
+ Property StringMessage : String Read GetStringMessage;
+ Procedure GetMessageData(Stream : TStream);
+ Property MsgType: TMessageType Read FMsgType;
+ Property MsgData : TStream Read FMsgData;
+ Property InstanceID : String Read GetInstanceID;
+ Published
+ Property Global : Boolean Read FGlobal Write SetGlobal;
+ Property OnMessage : TNotifyEvent Read FOnMessage Write FOnMessage;
+ end;
+
+
+ { TIPCClientComm}
+ TIPCClientComm = Class(TObject)
+ private
+ FOwner: TSimpleIPCClient;
+ protected
+ Procedure DoError(Msg : String; Args : Array of const);
+ Public
+ Constructor Create(AOwner : TSimpleIPCClient); virtual;
+ Property Owner : TSimpleIPCClient read FOwner;
+ Procedure Connect; virtual; abstract;
+ Procedure Disconnect; virtual; abstract;
+ Function ServerRunning : Boolean; virtual; abstract;
+ Procedure SendMessage(MsgType : TMessageType; Stream : TStream);virtual;Abstract;
+ end;
+ TIPCClientCommClass = Class of TIPCClientComm;
+
+ { TSimpleIPCClient }
+ TSimpleIPCClient = Class(TSimpleIPC)
+ Private
+ FServerInstance: String;
+ procedure SetServerInstance(const AValue: String);
+ Protected
+ FIPCComm : TIPCClientComm;
+ Procedure Activate; override;
+ Procedure Deactivate; override;
+ Function CommClass : TIPCClientCommClass; virtual;
+ Public
+ Constructor Create(AOwner : TComponent); override;
+ Destructor Destroy; override;
+ Procedure Connect;
+ Procedure Disconnect;
+ Function ServerRunning : Boolean;
+ Procedure SendMessage(MsgType : TMessageType; Stream: TStream);
+ Procedure SendStringMessage(const Msg : String);
+ Procedure SendStringMessage(MsgType : TMessageType; const Msg : String);
+ Procedure SendStringMessageFmt(const Msg : String; Args : Array of const);
+ Procedure SendStringMessageFmt(MsgType : TMessageType; const Msg : String; Args : Array of const);
+ Property ServerInstance : String Read FServerInstance Write SetServerInstance;
+ end;
+
+
+ EIPCError = Class(Exception);
+
+Var
+ DefaultIPCServerClass : TIPCServerCommClass = Nil;
+ DefaultIPCClientClass : TIPCClientCommClass = Nil;
+
+resourcestring
+ SErrServerNotActive = 'Server with ID %s is not active.';
+ SErrActive = 'This operation is illegal when the server is active.';
+ SErrInActive = 'This operation is illegal when the server is inactive.';
+
+
+implementation
+
+{ ---------------------------------------------------------------------
+ Include platform specific implementation.
+ Should implement the CommClass method of both server and client component,
+ as well as the communication class itself.
+
+ This comes first, to allow the uses clause to be set.
+ If the include file defines OSNEEDIPCINITDONE then the unit will
+ call IPCInit and IPCDone in the initialization/finalization code.
+
+ --------------------------------------------------------------------- }
+{$UNDEF OSNEEDIPCINITDONE}
+
+{$i simpleipc.inc}
+
+{ ---------------------------------------------------------------------
+ TIPCServerComm
+ ---------------------------------------------------------------------}
+
+constructor TIPCServerComm.Create(AOwner: TSimpleIPCServer);
+begin
+ FOwner:=AOWner;
+end;
+
+Procedure TIPCServerComm.DoError(Msg : String; Args : Array of const);
+
+begin
+ FOwner.DoError(Msg,Args);
+end;
+
+Function TIPCServerComm.MsgData : TStream;
+
+begin
+ Result:=FOwner.FMsgData;
+end;
+
+Procedure TIPCServerComm.SetMsgType(AMsgType: TMessageType);
+
+begin
+ Fowner.FMsgType:=AMsgType;
+end;
+
+{ ---------------------------------------------------------------------
+ TIPCClientComm
+ ---------------------------------------------------------------------}
+
+constructor TIPCClientComm.Create(AOwner: TSimpleIPCClient);
+begin
+ FOwner:=AOwner;
+end;
+
+Procedure TIPCClientComm.DoError(Msg : String; Args : Array of const);
+
+begin
+ FOwner.DoError(Msg,Args);
+end;
+
+{ ---------------------------------------------------------------------
+ TSimpleIPC
+ ---------------------------------------------------------------------}
+
+procedure TSimpleIPC.DoError(Msg: String; Args: array of const);
+begin
+ Raise EIPCError.Create(Name+': '+Format(Msg,Args));
+end;
+
+procedure TSimpleIPC.CheckInactive;
+begin
+ If Active then
+ DoError(SErrActive,[]);
+end;
+
+procedure TSimpleIPC.CheckActive;
+begin
+ If Not Active then
+ DoError(SErrInActive,[]);
+end;
+
+procedure TSimpleIPC.SetActive(const AValue: Boolean);
+begin
+ if (FActive<>AValue) then
+ begin
+ If AValue then
+ Activate
+ else
+ Deactivate;
+ end;
+end;
+
+procedure TSimpleIPC.SetServerID(const AValue: String);
+begin
+ if (FServerID<>AValue) then
+ begin
+ CheckInactive;
+ FServerID:=AValue
+ end;
+end;
+
+{ ---------------------------------------------------------------------
+ TSimpleIPCServer
+ ---------------------------------------------------------------------}
+
+constructor TSimpleIPCServer.Create(AOwner: TComponent);
+begin
+ inherited Create(AOwner);
+ FGlobal:=False;
+ FActive:=False;
+ FBusy:=False;
+ FMsgData:=TStringStream.Create('');
+end;
+
+destructor TSimpleIPCServer.Destroy;
+begin
+ Active:=False;
+ FreeAndNil(FMsgData);
+ inherited Destroy;
+end;
+
+procedure TSimpleIPCServer.SetGlobal(const AValue: Boolean);
+begin
+ if (FGlobal<>AValue) then
+ begin
+ CheckInactive;
+ FGlobal:=AValue;
+ end;
+end;
+
+function TSimpleIPCServer.GetInstanceID: String;
+begin
+ Result:=FIPCComm.InstanceID;
+end;
+
+
+function TSimpleIPCServer.GetStringMessage: String;
+begin
+ Result:=TStringStream(FMsgData).DataString;
+end;
+
+
+procedure TSimpleIPCServer.StartServer;
+begin
+ if Not Assigned(FIPCComm) then
+ begin
+ If (FServerID='') then
+ FServerID:=ApplicationName;
+ FIPCComm:=CommClass.Create(Self);
+ FIPCComm.StartServer;
+ end;
+ FActive:=True;
+end;
+
+procedure TSimpleIPCServer.StopServer;
+begin
+ If Assigned(FIPCComm) then
+ begin
+ FIPCComm.StopServer;
+ FreeAndNil(FIPCComm);
+ end;
+ FActive:=False;
+end;
+
+function TSimpleIPCServer.PeekMessage(TimeOut: Integer; DoReadMessage: Boolean
+ ): Boolean;
+begin
+ CheckActive;
+ FBusy:=True;
+ Try
+ Result:=FIPCComm.PeekMessage(Timeout);
+ Finally
+ FBusy:=False;
+ end;
+ If Result then
+ If DoReadMessage then
+ Readmessage;
+end;
+
+procedure TSimpleIPCServer.ReadMessage;
+begin
+ CheckActive;
+ FBusy:=True;
+ Try
+ FIPCComm.ReadMessage;
+ If Assigned(FOnMessage) then
+ FOnMessage(Self);
+ Finally
+ FBusy:=False;
+ end;
+end;
+
+procedure TSimpleIPCServer.GetMessageData(Stream: TStream);
+begin
+ Stream.CopyFrom(FMsgData,0);
+end;
+
+procedure TSimpleIPCServer.Activate;
+begin
+ StartServer;
+end;
+
+procedure TSimpleIPCServer.Deactivate;
+begin
+ StopServer;
+end;
+
+{ ---------------------------------------------------------------------
+ TSimpleIPCClient
+ ---------------------------------------------------------------------}
+
+procedure TSimpleIPCClient.SetServerInstance(const AValue: String);
+begin
+ CheckInactive;
+ FServerInstance:=AVAlue;
+end;
+
+procedure TSimpleIPCClient.Activate;
+begin
+ Connect;
+end;
+
+procedure TSimpleIPCClient.Deactivate;
+begin
+ DisConnect;
+end;
+constructor TSimpleIPCClient.Create(AOwner: TComponent);
+begin
+ inherited Create(AOwner);
+end;
+
+destructor TSimpleIPCClient.destroy;
+begin
+ Active:=False;
+ Inherited;
+end;
+
+procedure TSimpleIPCClient.Connect;
+begin
+ If Not assigned(FIPCComm) then
+ begin
+ FIPCComm:=CommClass.Create(Self);
+ Try
+ FIPCComm.Connect;
+ Except
+ FreeAndNil(FIPCComm);
+ Raise;
+ end;
+ FActive:=True;
+ end;
+end;
+
+procedure TSimpleIPCClient.Disconnect;
+begin
+ If Assigned(FIPCComm) then
+ Try
+ FIPCComm.DisConnect;
+ Finally
+ FActive:=False;
+ FreeAndNil(FIPCComm);
+ end;
+end;
+
+function TSimpleIPCClient.ServerRunning: Boolean;
+
+begin
+ If Assigned(FIPCComm) then
+ Result:=FIPCComm.ServerRunning
+ else
+ With CommClass.Create(Self) do
+ Try
+ Result:=ServerRunning;
+ finally
+ Free;
+ end;
+end;
+
+procedure TSimpleIPCClient.SendMessage(MsgType : TMessageType; Stream: TStream);
+
+begin
+ CheckActive;
+ FBusy:=True;
+ Try
+ FIPCComm.SendMessage(MsgType,Stream);
+ Finally
+ FBusy:=False;
+ end;
+end;
+
+procedure TSimpleIPCClient.SendStringMessage(const Msg: String);
+begin
+ SendStringMessage(mtString,Msg);
+end;
+
+procedure TSimpleIPCClient.SendStringMessage(MsgType: TMessageType; const Msg: String
+ );
+Var
+ S : TStringStream;
+begin
+ S:=TStringStream.Create(Msg);
+ try
+ SendMessage(MsgType,S);
+ finally
+ S.free;
+ end;
+end;
+
+procedure TSimpleIPCClient.SendStringMessageFmt(const Msg: String;
+ Args: array of const);
+begin
+ SendStringMessageFmt(mtString,Msg,Args);
+end;
+
+procedure TSimpleIPCClient.SendStringMessageFmt(MsgType: TMessageType;
+ const Msg: String; Args: array of const);
+begin
+ SendStringMessage(MsgType, Format(Msg,Args));
+end;
+
+{$IFDEF OSNEEDIPCINITDONE}
+initialization
+ IPCInit;
+finalization
+ IPCDone;
+{$ENDIF}
+end.
+
Index: src/udcutils.pas
===================================================================
--- src/udcutils.pas (revision 7296)
+++ src/udcutils.pas (working copy)
@@ -931,6 +931,24 @@
Result := ord(pstr1[counter]) - ord(pstr2[counter]);
end;
+function LocalCompareTextWideString(const s1, s2 : WideString): PtrInt;
+begin
+{$if fpc_fullversion >= 30001}
+ Result := WideStringManager.CompareWideStringProc(s1, s2, [coIgnoreCase]);
+{$else fpc_fullversion}
+ Result := WideStringManager.CompareTextWideStringProc(s1, s2);
+{$endif}
+end;
+
+function LocalCompareWideString(const s1, s2 : WideString): PtrInt;
+begin
+{$if fpc_fullversion >= 30001}
+ Result := WideStringManager.CompareWideStringProc(s1, s2, []);
+{$else fpc_fullversion}
+ Result := WideStringManager.CompareTextWideStringProc(s1, s2);
+{$endif}
+end;
+
function StrFloatCmpW(str1, str2: PWideChar; CaseSensitivity: TCaseSensitivity): PtrInt;
var
is_digit1, is_digit2: boolean;
@@ -953,8 +971,8 @@
begin
// Set up compare function
case CaseSensitivity of
- cstNotSensitive: str_cmp:= WideStringManager.CompareTextWideStringProc;
- cstLocale: str_cmp:= WideStringManager.CompareWideStringProc;
+ cstNotSensitive: str_cmp:= @LocalCompareTextWideString;
+ cstLocale: str_cmp:= @LocalCompareWideString;
cstCharValue: str_cmp:= @WideStrComp;
else
raise Exception.Create('Invalid CaseSensitivity parameter');
| ||||
| Fixed in Revision | 7308-7311,7360 | ||||
| Operating system | Linux | ||||
| Widgetset | GTK2, QT4 | ||||
| Architecture | 32-bit, 64-bit | ||||
|
|
simpleipc.{pp,inc} взят из fpc 3.0.1. upipeserver приведён в соответствие uniqueinstance не работает с ним (больше одной копии, независимо от настроек, создаётся), хотя канал /tmp/doublecmd--${UID} создаёт. |
|
|
Вернул upipeserver в исходное состояние, заменил simpleipc.{pp,inc} из fpc 2.6.5, теперь всё нормально. upipeserver+udcutils_v2.diff |
|
|
Сделал более красивый вариант, вроде работает (fpc 3.0.2rc1). |
|
|
собрал: Double Commander Version: 0.8.0 alpha Revision: 7310 Build date: 2017/01/13 Lazarus: 1.7-53936 FPC: 3.0.1 Platform: x86_64-Linux-qt4 OS version: "Gentoo" Widgetset library: Qt 4.8.6, libQt4Pas 4.5.3 ############################################ Double Commander Version: 0.8.0 alpha Revision: 7310 Build date: 2017/01/14 Lazarus: 1.7-53936 FPC: 3.0.1 Platform: x86_64-Linux-gtk2 OS version: "Gentoo" Widgetset library: GTK 2.24.31 ############################################ PS: Нашёл реализацию single instance в fixes_3_0/fpcsrc/packages/fcl-base/src/advancedsingleinstance.pas И пример fixes_3_0/fpcsrc/packages/fcl-base/examples/sitest.pp |
| Date Modified | Username | Field | Change |
|---|---|---|---|
| 2017-01-02 16:22 | fedan | New Issue | |
| 2017-01-02 16:22 | fedan | File Added: udcutils.diff | |
| 2017-01-02 16:23 | fedan | File Added: upipeserver+udcutils.diff | |
| 2017-01-02 16:35 | fedan | Note Added: 0002042 | |
| 2017-01-02 16:38 | fedan | Note Edited: 0002042 | |
| 2017-01-02 16:51 | fedan | Note Edited: 0002042 | |
| 2017-01-02 17:16 | fedan | File Added: upipeserver+udcutils_v2.diff | |
| 2017-01-02 17:18 | fedan | Note Added: 0002043 | |
| 2017-01-02 17:18 | fedan | Note Edited: 0002043 | |
| 2017-01-02 18:53 | fedan | Note Edited: 0002043 | |
| 2017-01-02 18:53 | fedan | Note Edited: 0002042 | |
| 2017-01-13 22:58 | Alexx2000 | Fixed in Revision | => 7309 |
| 2017-01-13 22:58 | Alexx2000 | Note Added: 0002045 | |
| 2017-01-13 22:58 | Alexx2000 | Assigned To | => Alexx2000 |
| 2017-01-13 22:58 | Alexx2000 | Status | new => resolved |
| 2017-01-13 22:58 | Alexx2000 | Resolution | open => fixed |
| 2017-01-13 22:58 | Alexx2000 | Target Version | => 0.7.8 |
| 2017-01-13 22:59 | Alexx2000 | Note Edited: 0002045 | |
| 2017-01-13 23:01 | Alexx2000 | Fixed in Revision | 7309 => 7308,7309 |
| 2017-01-13 23:17 | Alexx2000 | Fixed in Revision | 7308,7309 => 7308-7310 |
| 2017-01-13 23:55 | fedan | Note Added: 0002046 | |
| 2017-01-14 00:20 | fedan | Note Edited: 0002046 | |
| 2017-01-14 10:23 | Alexx2000 | Fixed in Revision | 7308-7310 => 7308-7311 |
| 2017-01-29 17:18 | Alexx2000 | Fixed in Revision | 7308-7311 => 7308-7311,7360 |
| 2017-01-29 17:18 | Alexx2000 | Fixed in Version | => 0.7.8 |
| 2020-06-19 21:50 | Alexx2000 | Status | resolved => closed |