Amiga, AROS, MorphOS: SimpleIPC implementation

git-svn-id: trunk@30790 -

.gitattributes

@@ -2579,6 +2579,9 @@ packages/fcl-process/Makefile svneol=native#text/plain
 packages/fcl-process/Makefile.fpc svneol=native#text/plain
 packages/fcl-process/Makefile.fpc.fpcmake svneol=native#text/plain
 packages/fcl-process/fpmake.pp svneol=native#text/plain
+packages/fcl-process/src/amicommon/pipes.inc svneol=native#text/plain
+packages/fcl-process/src/amicommon/process.inc svneol=native#text/plain
+packages/fcl-process/src/amicommon/simpleipc.inc svneol=native#text/plain
 packages/fcl-process/src/dbugintf.pp svneol=native#text/plain
 packages/fcl-process/src/dbugmsg.pp svneol=native#text/plain
 packages/fcl-process/src/dummy/pipes.inc svneol=native#text/plain

packages/fcl-process/fpmake.pp

@@ -30,8 +30,13 @@ begin
     P.SourcePath.Add('src');
     P.IncludePath.Add('src/unix',AllUnixOSes);
     P.IncludePath.Add('src/win',[win32,win64]);
-    P.IncludePath.Add('src/$(OS)',AllOSes-[win32,win64]-AllUnixOSes);
-    P.IncludePath.Add('src/dummy',AllOSes-[win32,win64]-AllUnixOSes);
+    P.IncludePath.Add('src/amicommon',AllAmigaLikeOSes);
+    P.IncludePath.Add('src/$(OS)',AllOSes-[win32,win64]-AllUnixOSes-AllAmigaLikeOSes);
+    P.IncludePath.Add('src/dummy',AllOSes-[win32,win64]-AllUnixOSes-AllAmigaLikeOSes);
+    
+    P.Dependencies.add('morphunits',[morphos]);
+    P.Dependencies.add('arosunits',[aros]);
+    P.Dependencies.add('amunits',[amiga]);
 
     T:=P.Targets.AddUnit('pipes.pp');
       T.Dependencies.AddInclude('pipes.inc');

packages/fcl-process/src/amicommon/pipes.inc

@@ -0,0 +1,47 @@
+{
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 1999-2000 by Michael Van Canneyt
+
+    DOS/go32v2 specific part of pipe stream.
+
+    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.
+
+ **********************************************************************}
+
+// No pipes under dos, sorry...
+
+Function CreatePipeHandles (Var Inhandle,OutHandle : THandle; APipeBufferSize : Cardinal = 1024) : Boolean;
+
+begin
+  InHandle := THandle (UnusedHandle);
+  OutHandle := THandle (UnusedHandle);
+  Result := False;
+end;
+
+
+Function TInputPipeStream.GetNumBytesAvailable: DWord;
+
+begin
+  Result := 0;
+end;
+
+function TInputPipeStream.GetPosition: Int64;
+begin
+  Result:=FPos;
+end;
+
+procedure TInputPipeStream.InvalidSeek;
+begin
+  Raise EPipeSeek.Create (ENoSeekMsg);
+end;
+
+procedure PipeClose (const FHandle: THandle); inline;
+begin
+  if FHandle <> UnusedHandle then
+   FileClose (FHandle);
+end;

packages/fcl-process/src/amicommon/process.inc

@@ -0,0 +1,148 @@
+{
+  Dummy process.inc - the simplest version based on SysUtils.ExecuteProcess
+}
+
+
+Resourcestring
+  SNoCommandLine        = 'Cannot execute empty command-line';
+  SErrCannotExecute     = 'Failed to execute %s : %d';
+  SErrNoSuchProgram     = 'Executable not found: "%s"';
+
+
+procedure TProcess.CloseProcessHandles;
+begin
+end;
+
+Function TProcess.PeekExitStatus : Boolean;
+begin
+  Result := true; (* Dummy version assumes always synchronous execution *)
+end;
+
+function GetNextWordPos (const S: string): integer;
+const
+  WhiteSpace = [' ', #9, #10, #13];
+  Literals = ['"', ''''];
+var
+  WStart: integer;
+  InLiteral: boolean;
+  LastLiteral: char;
+begin
+  WStart := 1;
+(* Skip whitespaces at the beginning *)
+  while (WStart <= Length (S)) and (S [WStart] in WhiteSpace) do
+   Inc (WStart);
+  InLiteral := false;
+  LastLiteral := #0;
+  while (WStart <= Length (S)) and
+                               (not (S [WStart] in WhiteSpace) or InLiteral) do
+   begin
+    if S [WStart] in Literals then
+     if InLiteral then
+      InLiteral := not (S [WStart] = LastLiteral)
+     else
+      begin
+       InLiteral := true;
+       LastLiteral := S [WStart];
+      end;
+     Inc (WStart);
+    end;
+(* Skip whitespaces at the end *)
+  while (WStart <= Length (S)) and (S [WStart] in WhiteSpace) do
+   Inc (WStart);
+  Result := WStart;
+end;
+
+function MaybeQuote (const S: string): string;
+begin
+  if (Pos (' ', S) <> 0) then
+   Result := '"' + S + '"'
+  else
+   Result := S;
+end;
+
+Procedure TProcess.Execute;
+var
+  I: integer;
+  ExecName, FoundName: string;
+  E2: EProcess;
+  OrigDir: string;
+  Params: string;
+begin
+  if (ApplicationName = '') and (CommandLine = '') and (Executable = '') then
+   raise EProcess.Create (SNoCommandline);
+  if (FApplicationName <> '') then
+   ExecName := FApplicationName;
+  if (FCommandLine <> '') then
+   begin
+    Params := FCommandLine;
+    if ExecName = '' then
+     begin
+      I := GetNextWordPos (Params);
+      ExecName := Copy (Params, 1, Pred (I));
+      Trim (ExecName);
+      Delete (Params, 1, Pred (I));
+     end
+    else if Copy (FCommandLine, 1, Length (ExecName)) = ExecName then
+     Delete (Params, 1, Succ (Length (ExecName)))
+    else
+     Delete (Params, 1, Pred (GetNextWordPos (Params)));
+    Trim (Params);
+   end
+  else
+   for I := 1 to Pred (Parameters.Count) do
+    Params := Params + ' ' + MaybeQuote (Parameters [I]);
+  if (FExecutable <> '') and (ExecName = '') then
+   ExecName := Executable;
+  if not FileExists (ExecName) then
+   begin
+    FoundName := ExeSearch (ExecName, '');
+    if FoundName <> '' then
+     ExecName := FoundName
+    else
+     raise EProcess.CreateFmt (SErrNoSuchProgram, [ExecName]);
+   end;
+  if (FCurrentDirectory <> '') then
+   begin
+    GetDir (0, OrigDir);
+    ChDir (FCurrentDirectory);
+   end;
+  try
+   FExitCode := ExecuteProcess (ExecName, Params);
+  except
+(* Normalize the raised exception so that it is aligned to other platforms. *)
+    On E: EOSError do
+     begin
+      raise EProcess.CreateFmt (SErrCannotExecute, [FCommandLine, E.ErrorCode]);
+      if (FCurrentDirectory <> '') then
+       ChDir (OrigDir);
+      end;
+  end;
+  if (FCurrentDirectory <> '') then
+   ChDir (OrigDir);
+end;
+
+Function TProcess.WaitOnExit : Boolean;
+begin
+  Result:=True;
+end;
+
+Function TProcess.Suspend : Longint;
+begin
+  Result:=0;
+end;
+
+Function TProcess.Resume : LongInt;
+begin
+  Result:=0;
+end;
+
+Function TProcess.Terminate(AExitCode : Integer) : Boolean;
+begin
+  Result:=False;
+end;
+
+Procedure TProcess.SetShowWindow (Value : TShowWindowOptions);
+begin
+end;
+
+

packages/fcl-process/src/amicommon/simpleipc.inc

@@ -0,0 +1,200 @@
+{
+  Amiga style simpleipc.inc
+}
+
+uses
+  Exec, dos;
+
+const
+  PORTNAMESTART = 'fpc_';
+
+Type
+  TAmigaClientComm = Class(TIPCClientComm)
+  Private
+    FMsgPort: PMsgPort;
+    FPortName: String;
+  Public
+    Constructor Create(AOwner: TSimpleIPCClient); override;
+    Procedure Connect; override;
+    Procedure Disconnect; override;
+    Procedure SendMessage(MsgType : TMessageType; AStream : TStream); override;
+    //Function  ServerRunning : Boolean; override;
+  end;
+
+  TAmigaServerComm = Class(TIPCServerComm)
+  Private
+    FMsgPort: PMsgPort;
+    FPortName: String;
+    MsgBody: PMessage;
+  Public
+    Constructor Create(AOwner: TSimpleIPCServer); override;
+    destructor Destroy; override;
+    Procedure StartServer; override;
+    Procedure StopServer; override;
+    Function  PeekMessage(TimeOut : Integer) : Boolean; override;
+    Procedure ReadMessage ; override;
+    Function GetInstanceID : String;override;
+  end;
+  
+// ####### CLIENT  
+  
+function SafePutToPort(Msg: PMessage; Portname: string): Integer;
+ var
+   Port: PMsgPort;
+   PName: PChar;
+ begin
+   Result := -1;
+   PName := PChar(Portname + #0);
+   Forbid();
+   Port := FindPort(PName);
+   if Assigned(Port) then
+   begin
+     PutMsg(Port, Msg);
+     Result := 0;
+   end;
+   Permit();
+ end;
+
+Constructor TAmigaClientComm.Create(AOwner: TSimpleIPCClient);
+begin
+  inherited;
+end;
+
+Procedure TAmigaClientComm.Connect;
+begin
+ 
+end;
+
+Procedure TAmigaClientComm.Disconnect;
+begin
+  
+end;
+
+Procedure TAmigaClientComm.SendMessage(MsgType : TMessageType; AStream : TStream);
+var
+  Size: Integer;
+  FullSize: Integer;
+  Memory: Pointer;
+  Temp: PByte;
+  MsgHead: Exec.PMessage;
+  MP: PMsgPort;
+  PortName: string;
+begin
+  Size := AStream.Size - AStream.Position;
+  FullSize := Size + Sizeof(Exec.TMessage);
+  PortName := PORTNAMESTART + Owner.ServerID;
+  Memory := System.AllocMem(FullSize);
+  MP := CreateMsgPort;
+  try
+    MsgHead := Memory;
+    MsgHead^.mn_ReplyPort := MP;
+    MsgHead^.mn_Length := Size;
+    Temp := Memory;
+    Inc(Temp, SizeOf(Exec.TMessage));
+    AStream.Read(Temp^, Size);
+    if SafePutToPort(MsgHead, PortName) = 0 then
+      WaitPort(MP);
+  finally
+    System.FreeMem(Memory);
+    DeleteMsgPort(MP);
+  end;
+end;
+
+// ###### SERVER
+
+Constructor TAmigaServerComm.Create(AOwner: TSimpleIPCServer);
+begin
+  inherited;
+  FMsgPort := CreateMsgPort;
+  MsgBody := nil;
+end;
+
+destructor TAmigaServerComm.Destroy;
+begin
+  if Assigned(MsgBody) then
+    System.FreeMem(MsgBody);
+  DeleteMsgPort(FMsgPort);
+  inherited;
+end;
+
+Procedure TAmigaServerComm.StartServer;
+begin
+  FPortName := PORTNAMESTART + Owner.ServerID + #0;
+  FMsgPort^.mp_Node.ln_Name := PChar(FPortName);
+  FMsgPort^.mp_Node.ln_Pri := 0;
+  AddPort(FMsgPort);
+  if Assigned(MsgBody) then
+    System.FreeMem(MsgBody); 
+  MsgBody := nil;
+end;
+
+Procedure TAmigaServerComm.StopServer;
+begin
+  RemPort(FMsgPort);
+  if Assigned(MsgBody) then
+    System.FreeMem(MsgBody);
+  MsgBody := nil;
+end;
+
+Function TAmigaServerComm.PeekMessage(TimeOut : Integer) : Boolean;
+var
+  Msg: PMessage;
+  Temp: PByte;
+  StartTime: Int64;
+begin
+  StartTime := GetMsCount;
+  Result := False;
+  if TimeOut < 0 then
+    TimeOut := MaxInt;
+  repeat
+    Msg := GetMsg(FMsgPort);
+    if Assigned(Msg) then
+    begin
+      Result := True;
+      Temp := PByte(Msg);
+      Inc(Temp, SizeOf(Exec.TMessage));
+      if Assigned(MsgBody) then
+        System.FreeMem(MsgBody);
+      MsgBody := System.AllocMem(SizeOf(Exec.TMessage) + Msg^.mn_Length);
+      Move(Msg^, MsgBody^, SizeOf(Exec.TMessage) + Msg^.mn_Length);
+      ReplyMsg(Msg);
+      break;
+    end;
+    Sleep(25);
+  until GetMsCount - StartTime >= TimeOut;
+end;
+
+Procedure TAmigaServerComm.ReadMessage;
+var
+  Temp: PByte;
+begin
+  if Assigned(MsgBody) then
+  begin
+    Temp := Pointer(MsgBody);
+    Inc(Temp, SizeOf(Exec.TMessage));
+    Owner.FMsgType := mtString;
+    Owner.FMsgData.Size := 0;
+    Owner.FMsgData.Seek(0, soFrombeginning);
+    Owner.FMsgData.WriteBuffer(temp^, MsgBody^.mn_Length);
+    System.FreeMem(MsgBody);
+    MsgBody := nil;
+  end;
+end;
+
+Function TAmigaServerComm.GetInstanceID: String;
+begin
+  Result := HexStr(FindTask(nil));
+end;
+
+// ###### Register
+
+Function TSimpleIPCServer.CommClass : TIPCServerCommClass;
+begin
+  Result:=TAmigaServerComm;
+end;
+
+function TSimpleIPCClient.CommClass: TIPCClientCommClass;
+begin
+  Result:=TAmigaClientComm;
+end;
+