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 |