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');