mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-08-16 10:19:17 +02:00
--- Merging r30653 into '.':
U rtl/inc/fexpand.inc --- Recording mergeinfo for merge of r30653 into '.': U . --- Merging r30654 into '.': U tests/test/units/dos/tfexpand.pp --- Recording mergeinfo for merge of r30654 into '.': G . --- Merging r30774 into '.': G tests/test/units/dos/tfexpand.pp --- Recording mergeinfo for merge of r30774 into '.': G . --- Merging r30788 into '.': U rtl/amiga/system.pp --- Recording mergeinfo for merge of r30788 into '.': G . --- Merging r30789 into '.': U rtl/morphos/system.pp --- Recording mergeinfo for merge of r30789 into '.': G . --- Merging r30790 into '.': U packages/fcl-process/fpmake.pp A packages/fcl-process/src/amicommon A packages/fcl-process/src/amicommon/process.inc A packages/fcl-process/src/amicommon/pipes.inc A packages/fcl-process/src/amicommon/simpleipc.inc --- Recording mergeinfo for merge of r30790 into '.': G . --- Merging r30803 into '.': U packages/fcl-process/src/amicommon/simpleipc.inc --- Recording mergeinfo for merge of r30803 into '.': G . --- Merging r30805 into '.': U packages/fcl-process/src/amicommon/process.inc U packages/fcl-process/src/amicommon/pipes.inc --- Recording mergeinfo for merge of r30805 into '.': G . --- Merging r30806 into '.': G packages/fcl-process/src/amicommon/process.inc G packages/fcl-process/src/amicommon/pipes.inc --- Recording mergeinfo for merge of r30806 into '.': G . --- Merging r30812 into '.': U packages/morphunits/src/amigados.pas U packages/amunits/src/coreunits/amigados.pas G packages/fcl-process/src/amicommon/process.inc G packages/fcl-process/src/amicommon/pipes.inc U packages/arosunits/src/amigados.pas --- Recording mergeinfo for merge of r30812 into '.': G . --- Merging r30813 into '.': U rtl/aros/system.pp --- Recording mergeinfo for merge of r30813 into '.': G . # revisions: 30653,30654,30774,30788,30789,30790,30803,30805,30806,30812,30813 git-svn-id: branches/fixes_3_0@31082 -
This commit is contained in:
marco
parent
e58f7faae9
commit
3605c0655a
3
.gitattributes
vendored
3
.gitattributes
vendored
@ -2529,6 +2529,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
|
||||
|
||||
@ -1598,7 +1598,7 @@ FUNCTION CreateProc(const name : pCHAR location 'd1'; pri : LONGINT location 'd2
|
||||
FUNCTION CurrentDir(lock : LONGINT location 'd1') : LONGINT; syscall _DOSBase 126;
|
||||
PROCEDURE DateStamp(date : pDateStamp location 'd1'); syscall _DOSBase 192;
|
||||
FUNCTION DateToStr(datetime : pDateTime location 'd1') : LongBool; syscall _DOSBase 744;
|
||||
FUNCTION DeleteFile(const name : pCHAR location 'd1') : LongBool; syscall _DOSBase 072;
|
||||
FUNCTION DOSDeleteFile(const name : pCHAR location 'd1') : LongBool; syscall _DOSBase 072;
|
||||
FUNCTION DeleteVar(const name : pCHAR location 'd1'; flags : ULONG location 'd2') : LongBool; syscall _DOSBase 912;
|
||||
FUNCTION DeviceProc(const name : pCHAR location 'd1') : pMsgPort; syscall _DOSBase 174;
|
||||
FUNCTION DoPkt(port : pMsgPort location 'd1'; action : LONGINT location 'd2'; arg1 : LONGINT location 'd3'; arg2 : LONGINT location 'd4'; arg3 : LONGINT location 'd5'; arg4 : LONGINT location 'd6'; arg5 : LONGINT location 'd7') : LONGINT; syscall _DOSBase 240;
|
||||
@ -1756,7 +1756,7 @@ FUNCTION AssignPath(const name : pCHAR;const path : string) : BOOLEAN;
|
||||
FUNCTION AssignPath(const name : string;const path : string) : BOOLEAN;
|
||||
FUNCTION CreateDir(const name : string) : LONGINT;
|
||||
FUNCTION CreateProc(const name : string; pri : LONGINT; segList : LONGINT; stackSize : LONGINT) : pMsgPort;
|
||||
FUNCTION DeleteFile(const name : string) : BOOLEAN;
|
||||
FUNCTION DOSDeleteFile(const name : string) : BOOLEAN;
|
||||
FUNCTION DeleteVar(const name : string; flags : ULONG) : BOOLEAN;
|
||||
FUNCTION DeviceProc(const name : string) : pMsgPort;
|
||||
FUNCTION DOSOpen(const name : string; accessMode : LONGINT) : LONGINT;
|
||||
@ -1904,9 +1904,9 @@ begin
|
||||
CreateProc := CreateProc(pas2c(name),pri,segList,stackSize);
|
||||
end;
|
||||
|
||||
FUNCTION DeleteFile(const name : string) : BOOLEAN;
|
||||
FUNCTION DOSDeleteFile(const name : string) : BOOLEAN;
|
||||
begin
|
||||
DeleteFile := DeleteFile(pas2c(name));
|
||||
DOSDeleteFile := DOSDeleteFile(pas2c(name));
|
||||
end;
|
||||
|
||||
FUNCTION DeleteVar(const name : string; flags : ULONG) : BOOLEAN;
|
||||
|
||||
@ -2265,14 +2265,14 @@ function Cli: PCommandLineInterface; syscall AOS_DOSBase 82;
|
||||
function CliInitNewcli(Dp: PDosPacket): IPTR; syscall AOS_DOSBase 155;
|
||||
function CliInitRun(Dp: PDosPacket): IPTR; syscall AOS_DOSBase 156;
|
||||
function CompareDates(const Date1: PDateStamp; const Date2: PDateStamp): LongInt; syscall AOS_DOSBase 123;
|
||||
function CreateDir(const Name: STRPTR): BPTR; syscall AOS_DOSBase 20;
|
||||
function DOSCreateDir(const Name: STRPTR): BPTR; syscall AOS_DOSBase 20;
|
||||
function CreateNewProc(const Tags: PTagItem): PProcess; syscall AOS_DOSBase 83;
|
||||
//function CreateNewProcTagList(const Tags : PTagItem) : pProcess;
|
||||
function CreateProc(const Name: STRPTR; Pri: LongInt; SegList: BPTR; StackSize: LongInt): PMsgPort; syscall AOS_DOSBase 23;
|
||||
function CurrentDir(Lock: BPTR): BPTR; syscall AOS_DOSBase 21;
|
||||
function DateStamp(Date: PDateStamp): PDateStamp; syscall AOS_DOSBase 32;
|
||||
function DateToStr(Datetime: PDateTime): LongBool; syscall AOS_DOSBase 124;
|
||||
function DeleteFile(const Name: STRPTR): LongBool; syscall AOS_DOSBase 12;
|
||||
function DOSDeleteFile(const Name: STRPTR): LongBool; syscall AOS_DOSBase 12;
|
||||
function DeleteVar(const Name: STRPTR; Flags: LongWord): LongInt; syscall AOS_DOSBase 152;
|
||||
function DeviceProc(const Name: STRPTR): PMsgPort; syscall AOS_DOSBase 29;
|
||||
function DisplayError(FormstStr: STRPTR; Flags: LongWord; Args: APTR): LongInt; syscall AOS_DOSBase 81;
|
||||
|
||||
@ -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');
|
||||
|
||||
57
packages/fcl-process/src/amicommon/pipes.inc
Normal file
57
packages/fcl-process/src/amicommon/pipes.inc
Normal file
@ -0,0 +1,57 @@
|
||||
{
|
||||
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.
|
||||
|
||||
**********************************************************************}
|
||||
|
||||
uses
|
||||
exec, AmigaDos;
|
||||
|
||||
// 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);
|
||||
var
|
||||
Filename: array[0..255] of Char;
|
||||
DeleteIt: Boolean;
|
||||
begin
|
||||
if (FHandle <> UnusedHandle) and (FHandle <> 0) then
|
||||
begin
|
||||
DeleteIt := NameFromFH(BPTR(FHandle), @(Filename[0]), 255);
|
||||
FileClose(FHandle);
|
||||
if DeleteIt then
|
||||
AmigaDos.dosDeleteFile(@(Filename[0]));
|
||||
end;
|
||||
end;
|
||||
165
packages/fcl-process/src/amicommon/process.inc
Normal file
165
packages/fcl-process/src/amicommon/process.inc
Normal file
@ -0,0 +1,165 @@
|
||||
{
|
||||
Dummy process.inc - the simplest version based on SysUtils.ExecuteProcess
|
||||
}
|
||||
|
||||
uses
|
||||
Exec, AmigaDos, Utility;
|
||||
|
||||
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;
|
||||
|
||||
var
|
||||
UID: Integer = 0;
|
||||
|
||||
Procedure TProcess.Execute;
|
||||
var
|
||||
I: integer;
|
||||
ExecName, FoundName: string;
|
||||
E2: EProcess;
|
||||
OrigDir: string;
|
||||
Params: string;
|
||||
TempName: string;
|
||||
cos: BPTR;
|
||||
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 := 0 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
|
||||
cos := BPTR(0);
|
||||
repeat
|
||||
Inc(UID);
|
||||
TempName := 'T:'+HexStr(FindTask(nil)) + '_' + HexStr(Self) + '_'+ IntToStr(UID) + '_Starter.tmp';
|
||||
until not FileExists(TempName);
|
||||
//sysdebugln('TProcess start: "' + ExecName + ' ' + Params+'" >' + TempName);
|
||||
cos := AmigaDos.DosOpen(PChar(TempName), MODE_READWRITE);
|
||||
FExitCode := LongInt(amigados.Execute(PChar(ExecName + ' ' + Params), BPTR(0), cos));
|
||||
DosSeek(cos, 0, OFFSET_BEGINNING);
|
||||
CreateStreams(0, THandle(cos),0);
|
||||
//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;
|
||||
|
||||
|
||||
258
packages/fcl-process/src/amicommon/simpleipc.inc
Normal file
258
packages/fcl-process/src/amicommon/simpleipc.inc
Normal file
@ -0,0 +1,258 @@
|
||||
{
|
||||
Amiga style simpleipc.inc
|
||||
}
|
||||
|
||||
{$DEFINE OSNEEDIPCINITDONE}
|
||||
|
||||
uses
|
||||
Exec, dos;
|
||||
|
||||
ResourceString
|
||||
SErrMsgPortExists = 'MsgPort already exists: %s';
|
||||
|
||||
const
|
||||
PORTNAMESTART = 'fpc_';
|
||||
|
||||
Var
|
||||
MsgPorts: Classes.TList;
|
||||
|
||||
procedure AddMsgPort(AMsgPort: PMsgPort);
|
||||
begin
|
||||
if Assigned(MsgPorts) then
|
||||
begin
|
||||
MsgPorts.Add(AMsgPort);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure RemoveMsgPort(AMsgPort: PMsgPort);
|
||||
var
|
||||
Idx: Integer;
|
||||
begin
|
||||
if Assigned(MsgPorts) then
|
||||
begin
|
||||
Idx := MsgPorts.IndexOf(AMsgPort);
|
||||
if Idx >= 0 then
|
||||
begin
|
||||
MsgPorts.Delete(Idx);
|
||||
if Assigned(AMsgPort^.mp_Node.ln_Name) and (string(AMsgPort^.mp_Node.ln_Name) <> '') and Assigned(FindPort(AMsgPort^.mp_Node.ln_Name)) then
|
||||
RemPort(AMsgPort);
|
||||
DeleteMsgPort(AMsgPort);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure IPCInit;
|
||||
begin
|
||||
MsgPorts := Classes.TList.Create;
|
||||
end;
|
||||
|
||||
procedure IPCDone;
|
||||
var
|
||||
I: integer;
|
||||
begin
|
||||
try
|
||||
for i := 0 to MsgPorts.Count - 1 do
|
||||
RemoveMsgPort(PMsgPort(MsgPorts[i]));
|
||||
finally
|
||||
FreeAndNil(MsgPorts);
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
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;
|
||||
AddMsgPort(FMsgPort);
|
||||
MsgBody := nil;
|
||||
end;
|
||||
|
||||
destructor TAmigaServerComm.Destroy;
|
||||
begin
|
||||
if Assigned(MsgBody) then
|
||||
System.FreeMem(MsgBody);
|
||||
RemoveMsgPort(FMsgPort);
|
||||
inherited;
|
||||
end;
|
||||
|
||||
Procedure TAmigaServerComm.StartServer;
|
||||
begin
|
||||
FPortName := PORTNAMESTART + Owner.ServerID + #0;
|
||||
if Assigned(FindPort(PChar(FPortName))) then
|
||||
begin
|
||||
DoError(SErrMsgPortExists,[FPortName]);
|
||||
Exit;
|
||||
end;
|
||||
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;
|
||||
|
||||
@ -1392,7 +1392,7 @@ type
|
||||
|
||||
{ dos.library functions }
|
||||
|
||||
function Open(fname : PChar location 'd1';
|
||||
function dosOpen(fname : PChar location 'd1';
|
||||
accessMode: LongInt location 'd2'): LongInt;
|
||||
SysCall MOS_DOSBase 30;
|
||||
|
||||
|
||||
@ -360,11 +360,13 @@ begin
|
||||
if AOS_wbMsg=nil then begin
|
||||
StdInputHandle:=dosInput;
|
||||
StdOutputHandle:=dosOutput;
|
||||
StdErrorHandle:=StdOutputHandle;
|
||||
end else begin
|
||||
AOS_ConHandle:=Open(AOS_ConName,MODE_OLDFILE);
|
||||
if AOS_ConHandle<>0 then begin
|
||||
StdInputHandle:=AOS_ConHandle;
|
||||
StdOutputHandle:=AOS_ConHandle;
|
||||
StdErrorHandle:=AOS_ConHandle;
|
||||
end else
|
||||
Halt(1);
|
||||
end;
|
||||
@ -377,11 +379,8 @@ begin
|
||||
OpenStdIO(Output,fmOutput,StdOutputHandle);
|
||||
OpenStdIO(StdOut,fmOutput,StdOutputHandle);
|
||||
|
||||
{ * AmigaOS doesn't have a separate stderr * }
|
||||
|
||||
StdErrorHandle:=StdOutputHandle;
|
||||
//OpenStdIO(StdErr,fmOutput,StdErrorHandle);
|
||||
//OpenStdIO(ErrOutput,fmOutput,StdErrorHandle);
|
||||
OpenStdIO(StdErr,fmOutput,StdErrorHandle);
|
||||
OpenStdIO(ErrOutput,fmOutput,StdErrorHandle);
|
||||
end;
|
||||
|
||||
function GetProcessID: SizeUInt;
|
||||
|
||||
@ -121,9 +121,6 @@ begin
|
||||
Killed := True;
|
||||
{ Closing opened files }
|
||||
CloseList(ASYS_fileList);
|
||||
//
|
||||
if AOS_wbMsg <> nil then
|
||||
ReplyMsg(AOS_wbMsg);
|
||||
{ Changing back to original directory if changed }
|
||||
if ASYS_OrigDir <> 0 then begin
|
||||
oldDirLock:=CurrentDir(ASYS_origDir);
|
||||
@ -142,6 +139,14 @@ begin
|
||||
CloseLibrary(AOS_DOSBase);
|
||||
AOS_DOSBase := nil;
|
||||
//
|
||||
if AOS_wbMsg <> nil then
|
||||
begin
|
||||
// forbid -> Amiga RKM Libraries Manual
|
||||
Forbid();
|
||||
// Reply WBStartupMessage
|
||||
ReplyMsg(AOS_wbMsg);
|
||||
end;
|
||||
//
|
||||
HaltProc(ExitCode);
|
||||
end;
|
||||
|
||||
|
||||
@ -479,7 +479,7 @@ begin
|
||||
{$ENDIF FPC_FEXPAND_NO_DOTS_UPDIR}
|
||||
|
||||
{$IFDEF FPC_FEXPAND_UPDIR_HELPER}
|
||||
(* Now remove all references to '//' plus previous directories... *)
|
||||
{ Now remove all references to '//' or '::' plus previous directories... }
|
||||
I := Pos (DirectorySeparator + DirectorySeparator, Dirs);
|
||||
while I <> 0 do
|
||||
begin
|
||||
@ -507,22 +507,6 @@ begin
|
||||
end;
|
||||
{$ENDIF FPC_FEXPAND_NO_DOTS_UPDIR}
|
||||
|
||||
{$IFDEF FPC_FEXPAND_DIRSEP_IS_UPDIR}
|
||||
(* Remove a possible reference to '/' at the *)
|
||||
(* end of line plus the previous directory. *)
|
||||
I := Length (Dirs);
|
||||
if (I > 0) and (Dirs [I] = DirectorySeparator) then
|
||||
begin
|
||||
J := Pred (I);
|
||||
while (J > 0) and (Dirs [J] <> DirectorySeparator) do
|
||||
Dec (J);
|
||||
if (J = 0) then
|
||||
Dirs := ''
|
||||
else
|
||||
Delete (Dirs, J, Succ (I - J));
|
||||
end;
|
||||
{$ENDIF FPC_FEXPAND_DIRSEP_IS_UPDIR}
|
||||
|
||||
{$IFNDEF FPC_FEXPAND_NO_CURDIR}
|
||||
{$IFNDEF FPC_FEXPAND_DIRSEP_IS_CURDIR}
|
||||
{...and also a possible reference to '\.'}
|
||||
@ -666,7 +650,7 @@ end;
|
||||
parent directory and so on (Amiga). Please, note that you can decide
|
||||
to support both '..' and DirectorySeparator as references to the parent
|
||||
directory at the same time for compatibility reasons - however this
|
||||
support makes it impossible to use anotherwise possibly valid name
|
||||
support makes it impossible to use otherwise possibly valid name
|
||||
of '..'.
|
||||
|
||||
FPC_FEXPAND_DIRSEP_IS_CURDIR - DirectorySeparator at the beginning of
|
||||
|
||||
@ -372,11 +372,13 @@ begin
|
||||
MOS_ConHandle:=0;
|
||||
StdInputHandle:=dosInput;
|
||||
StdOutputHandle:=dosOutput;
|
||||
StdErrorHandle:=StdOutputHandle;
|
||||
end else begin
|
||||
MOS_ConHandle:=Open(MOS_ConName,MODE_OLDFILE);
|
||||
if MOS_ConHandle<>0 then begin
|
||||
StdInputHandle:=MOS_ConHandle;
|
||||
StdOutputHandle:=MOS_ConHandle;
|
||||
StdErrorHandle:=MOS_ConHandle;
|
||||
end else
|
||||
Halt(1);
|
||||
end;
|
||||
@ -389,10 +391,8 @@ begin
|
||||
OpenStdIO(Output,fmOutput,StdOutputHandle);
|
||||
OpenStdIO(StdOut,fmOutput,StdOutputHandle);
|
||||
|
||||
{ * MorphOS doesn't have a separate stderr, just like AmigaOS (???) * }
|
||||
StdErrorHandle:=StdOutputHandle;
|
||||
// OpenStdIO(StdErr,fmOutput,StdErrorHandle);
|
||||
// OpenStdIO(ErrOutput,fmOutput,StdErrorHandle);
|
||||
OpenStdIO(StdErr,fmOutput,StdErrorHandle);
|
||||
OpenStdIO(ErrOutput,fmOutput,StdErrorHandle);
|
||||
end;
|
||||
|
||||
function GetProcessID: SizeUInt;
|
||||
|
||||
@ -59,9 +59,16 @@ uses
|
||||
{$ENDIF LINUX}
|
||||
|
||||
{$IFDEF AMIGA}
|
||||
{$IFNDEF HASAMIGA}
|
||||
{$DEFINE HASAMIGA}
|
||||
{$ENDIF HASAMIGA}
|
||||
{$ENDIF AMIGA}
|
||||
|
||||
{$IFDEF HASAMIGA}
|
||||
{$DEFINE VOLUMES}
|
||||
{$DEFINE NODRIVEC}
|
||||
{$ENDIF AMIGA}
|
||||
{$DEFINE NODOTS}
|
||||
{$ENDIF HASAMIGA}
|
||||
|
||||
{$IFDEF NETWARE}
|
||||
{$DEFINE VOLUMES}
|
||||
@ -103,13 +110,13 @@ const
|
||||
DriveSeparator = '/';
|
||||
FileNameCasePreserving = true;
|
||||
{$ELSE UNIX}
|
||||
{$IFDEF AMIGA}
|
||||
DirectorySeparator = ':';
|
||||
{$IFDEF HASAMIGA}
|
||||
DirectorySeparator = '/';
|
||||
FileNameCasePreserving = true;
|
||||
{$ELSE AMIGA}
|
||||
{$ELSE HASAMIGA}
|
||||
DirectorySeparator = '\';
|
||||
FileNameCasePreserving = false;
|
||||
{$ENDIF AMIGA}
|
||||
{$ENDIF HASAMIGA}
|
||||
{$ENDIF UNIX}
|
||||
{$ENDIF MACOS}
|
||||
{$ENDIF DIRECT}
|
||||
@ -117,11 +124,7 @@ const
|
||||
{$IFDEF MACOS}
|
||||
DriveSep = '';
|
||||
{$ELSE MACOS}
|
||||
{$IFDEF AMIGA}
|
||||
DriveSep = '';
|
||||
{$ELSE AMIGA}
|
||||
DriveSep = DriveSeparator;
|
||||
{$ENDIF AMIGA}
|
||||
{$ENDIF MACOS}
|
||||
{$IFDEF UNIX}
|
||||
CDrive = '';
|
||||
@ -129,11 +132,11 @@ const
|
||||
{$IFDEF MACOS}
|
||||
CDrive = 'C';
|
||||
{$ELSE MACOS}
|
||||
{$IFDEF AMIGA}
|
||||
{$IFDEF HASAMIGA}
|
||||
CDrive = 'C';
|
||||
{$ELSE AMIGA}
|
||||
{$ELSE HASAMIGA}
|
||||
CDrive = 'C:';
|
||||
{$ENDIF AMIGA}
|
||||
{$ENDIF HASAMIGA}
|
||||
{$ENDIF MACOS}
|
||||
{$ENDIF UNIX}
|
||||
{$ENDIF FPC}
|
||||
@ -289,11 +292,11 @@ begin
|
||||
GetDir (3, CDir);
|
||||
{$ENDIF NODRIVEC}
|
||||
Check (' ', CurDir + DirSep + ' ');
|
||||
{$IFDEF AMIGA}
|
||||
{$IFDEF HASAMIGA}
|
||||
Check ('', CurDir);
|
||||
{$ELSE AMIGA}
|
||||
{$ELSE HASAMIGA}
|
||||
Check ('', CurDir + DirSep);
|
||||
{$ENDIF AMIGA}
|
||||
{$ENDIF HASAMIGA}
|
||||
{$IFDEF MACOS}
|
||||
Check (':', CurDir + DirSep);
|
||||
{$ELSE MACOS}
|
||||
@ -304,26 +307,26 @@ begin
|
||||
if CDir [Length (CDir)] = DirSep then Check ('c:anything', CDir + 'anything')
|
||||
else Check ('c:anything', CDir + DirSep + 'anything');
|
||||
Check (CC + DirSep, CDrive + DirSep);
|
||||
{$IFDEF NODOTS}
|
||||
{$IFDEF NODOTS}
|
||||
Check ('C:.', 'C:.');
|
||||
Check (CC + DirSep + '.', CDrive + DirSep + '.');
|
||||
Check (CC + DirSep + '..', CDrive + DirSep + '..');
|
||||
{$ELSE NODOTS}
|
||||
{$ELSE NODOTS}
|
||||
Check ('C:.', CDir);
|
||||
Check (CC + DirSep + '.', CDrive + DirSep);
|
||||
Check (CC + DirSep + '..', CDrive + DirSep);
|
||||
{$ENDIF NODOTS}
|
||||
{$ENDIF NODOTS}
|
||||
Check (CC + DirSep + 'DOS', CDrive + DirSep + 'DOS');
|
||||
{$IFNDEF NODOTS}
|
||||
{$IFNDEF NODOTS}
|
||||
Check (CC + DirSep + '..' + DirSep + 'DOS', CDrive + DirSep + 'DOS');
|
||||
{$ENDIF NODOTS}
|
||||
{$ENDIF NODOTS}
|
||||
Check (CC + DirSep + 'DOS.', CDrive + DirSep + 'DOS.');
|
||||
{$IFDEF AMIGA}
|
||||
{$IFDEF HASAMIGA} (* This has no effect - AMIGA has NODRIVEC defined... *)
|
||||
Check (CC + DirSep + 'DOS' + DirSep, CDrive + DirSep);
|
||||
{$ELSE AMIGA}
|
||||
{$ELSE HASAMIGA}
|
||||
Check (CC + DirSep + 'DOS' + DirSep, CDrive + DirSep + 'DOS' + DirSep);
|
||||
{$ENDIF AMIGA}
|
||||
{$IFNDEF NODOTS}
|
||||
{$ENDIF HASAMIGA}
|
||||
{$IFNDEF NODOTS}
|
||||
Check (CC + DirSep + 'DOS' + DirSep + '.', CDrive + DirSep + 'DOS');
|
||||
Check (CC + DirSep + 'DOS' + DirSep + '..', CDrive + DirSep);
|
||||
Check (CC + DirSep + 'DOS' + DirSep + '..' + DirSep, CDrive + DirSep);
|
||||
@ -331,14 +334,20 @@ if CDir [Length (CDir)] = DirSep then Check ('c:anything', CDir + 'anything')
|
||||
DirSep + 'DOS');
|
||||
Check ('C:' + DirSep + 'DOS' + DirSep + 'TEST' + DirSep + '..' + DirSep,
|
||||
CDrive + DirSep + 'DOS' + DirSep);
|
||||
{$ENDIF NODOTS}
|
||||
{$ENDIF NODOTS}
|
||||
{$ENDIF NODRIVEC}
|
||||
|
||||
{$IFNDEF MACOS}
|
||||
{$IFDEF HASAMIGA}
|
||||
Check (DirSep, TestDir + TestDir1Name);
|
||||
Check (DirSep + DirSep + TestFileName, TestDir + TestFileName);
|
||||
Check (DirSep + 'DOS', TestDir + TestDir1Name + DirSep + 'DOS');
|
||||
{$ELSE HASAMIGA}
|
||||
Check (DirSep, TestDrive + DirSep);
|
||||
Check (DirSep + '.', TestDrive + DirSep);
|
||||
Check (DirSep + '..', TestDrive + DirSep);
|
||||
Check (DirSep + 'DOS', TestDrive + DirSep + 'DOS');
|
||||
{$ENDIF HASAMIGA}
|
||||
{$ENDIF MACOS}
|
||||
Check ('d', CurDir + DirSep + 'd');
|
||||
{$IFDEF MACOS}
|
||||
@ -367,15 +376,15 @@ if CDir [Length (CDir)] = DirSep then Check ('c:anything', CDir + 'anything')
|
||||
Check ('.special', CurDir + DirSep + '.special');
|
||||
Check ('..special', CurDir + DirSep + '..special');
|
||||
Check ('special..', CurDir + DirSep + 'special..');
|
||||
{$IFDEF AMIGA}
|
||||
Check ('special.' + DirSep, CurDir);
|
||||
{$ELSE AMIGA}
|
||||
{$IFDEF HASAMIGA}
|
||||
Check ('special.' + DirSep, CurDir + DirSep + 'special.' + DirSep);
|
||||
{$ELSE HASAMIGA}
|
||||
{$IFDEF MACOS}
|
||||
Check ('special.' + DirSep, 'special.' + DirSep);
|
||||
{$ELSE MACOS}
|
||||
Check ('special.' + DirSep, CurDir + DirSep + 'special.' + DirSep);
|
||||
{$ENDIF MACOS}
|
||||
{$ENDIF AMIGA}
|
||||
{$ENDIF HASAMIGA}
|
||||
{$IFDEF MACOS}
|
||||
Check (DirSep + DirSep, TestDir + TestDir1Name + DirSep);
|
||||
Check (DirSep + DirSep + TestFileName, TestDir + TestDir1Name + DirSep
|
||||
@ -481,7 +490,11 @@ if CDir [Length (CDir)] = DirSep then Check ('c:anything', CDir + 'anything')
|
||||
{$ENDIF NODRIVEC}
|
||||
{$ENDIF UNIX}
|
||||
{$IFDEF VOLUMES}
|
||||
{$IFDEF HASAMIGA}
|
||||
Check ('VolName' + DriveSep + 'DIR1', 'VolName' + DriveSep + 'DIR1');
|
||||
{$ELSE HASAMIGA}
|
||||
Check ('VolName' + DriveSep + DirSep + 'DIR1', 'VolName' + DriveSep + DirSep + 'DIR1');
|
||||
{$ENDIF HASAMIGA}
|
||||
{$IFNDEF NODOTS}
|
||||
Check ('VolName' + DriveSep + DirSep + 'DIR1' + DirSep + '..', 'VolName' + DriveSep + DirSep);
|
||||
Check ('VolName' + DriveSep + DirSep + 'DIR1' + DirSep + '..' + DirSep + '..',
|
||||
@ -496,13 +509,13 @@ if CDir [Length (CDir)] = DirSep then Check ('c:anything', CDir + 'anything')
|
||||
Check ('SrvName/VolName' + DriveSep + DirSep + 'TEST', 'SrvName' + DirSep + 'VolName' +
|
||||
DriveSep + DirSep + 'TEST');
|
||||
{$ENDIF NETWARE}
|
||||
{$IFDEF AMIGA}
|
||||
{$IFDEF HASAMIGA}
|
||||
{$IFDEF NODOTS}
|
||||
Check ('.', CurDir + DirSep + '.');
|
||||
{$ELSE NODOTS}
|
||||
Check ('.', CurDir);
|
||||
{$ENDIF NODOTS}
|
||||
{$ENDIF AMIGA}
|
||||
{$ENDIF HASAMIGA}
|
||||
{$ENDIF VOLUMES}
|
||||
Erase (F);
|
||||
{$IFNDEF NODRIVEC}
|
||||
|
||||
Loading…
Reference in New Issue
Block a user