mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-12 18:49:46 +02:00
855 lines
21 KiB
ObjectPascal
855 lines
21 KiB
ObjectPascal
{
|
|
|
|
This file is part of the Free Pascal run time library.
|
|
Copyright (c) 2004-2005 by Olle Raab
|
|
|
|
Sysutils unit for Mac OS.
|
|
|
|
NOTE !!! THIS FILE IS UNDER CONSTRUCTION AND DOES NOT WORK CURRENLY.
|
|
|
|
THUS IT IS NOT BUILT BY THE MAKEFILES
|
|
|
|
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 sysutils;
|
|
interface
|
|
|
|
{$MODE objfpc}
|
|
{$modeswitch out}
|
|
{ force ansistrings }
|
|
{$H+}
|
|
{$modeswitch typehelpers}
|
|
{$modeswitch advancedrecords}
|
|
|
|
{OS has only 1 byte version for ExecuteProcess}
|
|
{$define executeprocuni}
|
|
|
|
uses
|
|
MacOSTP;
|
|
|
|
{$DEFINE HAS_SLEEP} {Dummy implementation: TODO }
|
|
//{$DEFINE HAS_OSERROR} TODO
|
|
//{$DEFINE HAS_OSCONFIG} TODO
|
|
|
|
type
|
|
//TODO Check pad and size
|
|
//TODO unify with Dos.SearchRec
|
|
PMacOSFindData = ^TMacOSFindData;
|
|
TMacOSFindData = record
|
|
{MacOS specific params, private, do not use:}
|
|
paramBlock: CInfoPBRec;
|
|
searchFSSpec: FSSpec;
|
|
searchAttr: Byte; {attribute we are searching for}
|
|
exactMatch: Boolean;
|
|
end;
|
|
|
|
{ used OS file system APIs use ansistring }
|
|
{$define SYSUTILS_HAS_ANSISTR_FILEUTIL_IMPL}
|
|
{ OS has an ansistring/single byte environment variable API }
|
|
{$define SYSUTILS_HAS_ANSISTR_ENVVAR_IMPL}
|
|
|
|
{ Include platform independent interface part }
|
|
{$i sysutilh.inc}
|
|
|
|
implementation
|
|
|
|
uses
|
|
Dos, Sysconst, macutils; // For some included files.
|
|
|
|
{$DEFINE FPC_FEXPAND_VOLUMES}
|
|
{$DEFINE FPC_FEXPAND_NO_DEFAULT_PATHS}
|
|
{$DEFINE FPC_FEXPAND_DRIVESEP_IS_ROOT}
|
|
{$DEFINE FPC_FEXPAND_NO_DOTS_UPDIR}
|
|
{$DEFINE FPC_FEXPAND_NO_CURDIR}
|
|
|
|
{ Include platform independent implementation part }
|
|
{$i sysutils.inc}
|
|
|
|
|
|
{****************************************************************************
|
|
File Functions
|
|
****************************************************************************}
|
|
|
|
Function FileOpen (Const FileName : rawbytestring; Mode : Integer) : Longint;
|
|
|
|
Var LinuxFlags : longint;
|
|
SystemFileName: RawByteString;
|
|
begin
|
|
(* TODO fix
|
|
SystemFileName:=ToSingleByteFileSystemEncodedFileName(FileName);
|
|
LinuxFlags:=0;
|
|
Case (Mode and 3) of
|
|
0 : LinuxFlags:=LinuxFlags or Open_RdOnly;
|
|
1 : LinuxFlags:=LinuxFlags or Open_WrOnly;
|
|
2 : LinuxFlags:=LinuxFlags or Open_RdWr;
|
|
end;
|
|
FileOpen:=fdOpen (FileName,LinuxFlags);
|
|
//!! We need to set locking based on Mode !!
|
|
*)
|
|
end;
|
|
|
|
|
|
Function FileCreate (Const FileName : RawByteString) : Longint;
|
|
|
|
begin
|
|
(* TODO fix
|
|
FileCreate:=fdOpen(FileName,Open_RdWr or Open_Creat or Open_Trunc);
|
|
*)
|
|
end;
|
|
|
|
|
|
Function FileCreate (Const FileName : RawByteString;Rights : Longint) : Longint;
|
|
|
|
Var LinuxFlags : longint;
|
|
|
|
BEGIN
|
|
(* TODO fix
|
|
LinuxFlags:=0;
|
|
Case (Mode and 3) of
|
|
0 : LinuxFlags:=LinuxFlags or Open_RdOnly;
|
|
1 : LinuxFlags:=LinuxFlags or Open_WrOnly;
|
|
2 : LinuxFlags:=LinuxFlags or Open_RdWr;
|
|
end;
|
|
FileCreate:=fdOpen(FileName,LinuxFlags or Open_Creat or Open_Trunc);
|
|
*)
|
|
end;
|
|
|
|
Function FileCreate (Const FileName : RawByteString;ShareMode : Longint; Rights : Longint) : Longint;
|
|
|
|
Var LinuxFlags : longint;
|
|
|
|
BEGIN
|
|
(* TODO fix
|
|
LinuxFlags:=0;
|
|
Case (Mode and 3) of
|
|
0 : LinuxFlags:=LinuxFlags or Open_RdOnly;
|
|
1 : LinuxFlags:=LinuxFlags or Open_WrOnly;
|
|
2 : LinuxFlags:=LinuxFlags or Open_RdWr;
|
|
end;
|
|
FileCreate:=fdOpen(FileName,LinuxFlags or Open_Creat or Open_Trunc);
|
|
*)
|
|
end;
|
|
|
|
|
|
Function FileRead (Handle : Longint; out Buffer; Count : longint) : Longint;
|
|
|
|
begin
|
|
(* TODO fix
|
|
FileRead:=fdRead (Handle,Buffer,Count);
|
|
*)
|
|
end;
|
|
|
|
|
|
Function FileWrite (Handle : Longint; const Buffer; Count : Longint) : Longint;
|
|
|
|
begin
|
|
(* TODO fix
|
|
FileWrite:=fdWrite (Handle,Buffer,Count);
|
|
*)
|
|
end;
|
|
|
|
|
|
Function FileSeek (Handle,FOffset,Origin : Longint) : Longint;
|
|
|
|
begin
|
|
(* TODO fix
|
|
FileSeek:=fdSeek (Handle,FOffset,Origin);
|
|
*)
|
|
end;
|
|
|
|
|
|
Function FileSeek (Handle : Longint; FOffset: Int64; Origin : Longint) : Int64;
|
|
|
|
begin
|
|
(* TODO fix
|
|
{$warning need to add 64bit call }
|
|
FileSeek:=fdSeek (Handle,FOffset,Origin);
|
|
*)
|
|
end;
|
|
|
|
|
|
Procedure FileClose (Handle : Longint);
|
|
|
|
begin
|
|
(* TODO fix
|
|
fdclose(Handle);
|
|
*)
|
|
end;
|
|
|
|
Function FileTruncate (Handle: THandle; Size: Int64) : boolean;
|
|
|
|
begin
|
|
(* TODO fix
|
|
FileTruncate:=fdtruncate(Handle,Size);
|
|
*)
|
|
end;
|
|
|
|
Function FileAge (Const FileName : RawByteString): Longint;
|
|
|
|
(*
|
|
Var Info : Stat;
|
|
Y,M,D,hh,mm,ss : word;
|
|
*)
|
|
|
|
begin
|
|
(* TODO fix
|
|
If not fstat (FileName,Info) then
|
|
exit(-1)
|
|
else
|
|
begin
|
|
EpochToLocal(info.mtime,y,m,d,hh,mm,ss);
|
|
Result:=DateTimeToFileDate(EncodeDate(y,m,d)+EncodeTime(hh,mm,ss,0));
|
|
end;
|
|
*)
|
|
end;
|
|
|
|
|
|
function FileGetSymLinkTarget(const FileName: RawByteString; out SymLinkRec: TRawbyteSymLinkRec): Boolean;
|
|
begin
|
|
Result := False;
|
|
end;
|
|
|
|
|
|
Function FileExists (Const FileName : RawByteString; FollowLink : Boolean) : Boolean;
|
|
|
|
(*
|
|
Var Info : Stat;
|
|
*)
|
|
|
|
begin
|
|
(* TODO fix
|
|
FileExists:=fstat(filename,Info);
|
|
*)
|
|
end;
|
|
|
|
|
|
Function DirectoryExists (Const Directory : RawByteString; FollowLink : Boolean) : Boolean;
|
|
|
|
(*
|
|
Var Info : Stat;
|
|
*)
|
|
|
|
begin
|
|
(* TODO fix
|
|
DirectoryExists:=fstat(Directory,Info) and
|
|
((info.mode and STAT_IFMT)=STAT_IFDIR);
|
|
*)
|
|
end;
|
|
|
|
(*
|
|
Function LinuxToWinAttr (FN : Pchar; Const Info : Stat) : Longint;
|
|
|
|
begin
|
|
Result:=faArchive;
|
|
If (Info.Mode and STAT_IFDIR)=STAT_IFDIR then
|
|
Result:=Result or faDirectory;
|
|
If (FN[0]='.') and (not (FN[1] in [#0,'.'])) then
|
|
Result:=Result or faHidden;
|
|
If (Info.Mode and STAT_IWUSR)=0 Then
|
|
Result:=Result or faReadOnly;
|
|
If (Info.Mode and
|
|
(STAT_IFSOCK or STAT_IFBLK or STAT_IFCHR or STAT_IFIFO))<>0 then
|
|
Result:=Result or faSysFile;
|
|
end;
|
|
|
|
{
|
|
GlobToSearch takes a glob entry, stats the file.
|
|
The glob entry is removed.
|
|
If FileAttributes match, the entry is reused
|
|
}
|
|
|
|
Type
|
|
TGlobSearchRec = Record
|
|
Path : String;
|
|
GlobHandle : PGlob;
|
|
end;
|
|
PGlobSearchRec = ^TGlobSearchRec;
|
|
|
|
Function GlobToTSearchRec (Var Info : TSearchRec) : Boolean;
|
|
|
|
Var SInfo : Stat;
|
|
p : Pglob;
|
|
GlobSearchRec : PGlobSearchrec;
|
|
|
|
begin
|
|
GlobSearchRec:=PGlobSearchrec(Info.FindHandle);
|
|
P:=GlobSearchRec^.GlobHandle;
|
|
Result:=P<>Nil;
|
|
If Result then
|
|
begin
|
|
GlobSearchRec^.GlobHandle:=P^.Next;
|
|
Result:=Fstat(GlobSearchRec^.Path+StrPas(p^.name),SInfo);
|
|
If Result then
|
|
begin
|
|
Info.Attr:=LinuxToWinAttr(p^.name,SInfo);
|
|
Result:=(Info.ExcludeAttr and Info.Attr)=0;
|
|
If Result Then
|
|
With Info do
|
|
begin
|
|
Attr:=Info.Attr;
|
|
If P^.Name<>Nil then
|
|
Name:=strpas(p^.name);
|
|
Time:=Sinfo.mtime;
|
|
Size:=Sinfo.Size;
|
|
end;
|
|
end;
|
|
P^.Next:=Nil;
|
|
GlobFree(P);
|
|
end;
|
|
end;
|
|
*)
|
|
|
|
|
|
procedure DoFind (var F: TSearchRec; var retname: RawByteString; firstTime: Boolean);
|
|
|
|
var
|
|
err: OSErr;
|
|
s: Str255;
|
|
|
|
begin
|
|
(* TODO fix
|
|
with Rslt, findData, paramBlock do
|
|
begin
|
|
ioVRefNum := searchFSSpec.vRefNum;
|
|
if firstTime then
|
|
ioFDirIndex := 0;
|
|
|
|
while true do
|
|
begin
|
|
s := '';
|
|
ioDirID := searchFSSpec.parID;
|
|
ioFDirIndex := ioFDirIndex + 1;
|
|
ioNamePtr := @s;
|
|
|
|
err := PBGetCatInfoSync(@paramBlock);
|
|
|
|
if err <> noErr then
|
|
begin
|
|
if err = fnfErr then
|
|
DosError := 18
|
|
else
|
|
DosError := MacOSErr2RTEerr(err);
|
|
break;
|
|
end;
|
|
|
|
attr := GetFileAttrFromPB(Rslt.paramBlock);
|
|
if ((Attr and not(searchAttr)) = 0) then
|
|
begin
|
|
retname := s;
|
|
SetCodePage(retname, DefaultFileSystemCodePage, false);
|
|
UpperString(s, true);
|
|
|
|
if FNMatch(Rslt.searchFSSpec.name, s) then
|
|
begin
|
|
size := GetFileSizeFromPB(paramBlock);
|
|
time := MacTimeToDosPackedTime(ioFlMdDat);
|
|
Result := 0;
|
|
break;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
*)
|
|
end;
|
|
|
|
|
|
Function InternalFindFirst (Const Path : RawByteString; Attr : Longint; out Rslt : TAbstractSearchRec; var Name: RawByteString) : Longint;
|
|
var
|
|
s: Str255;
|
|
|
|
begin
|
|
(* TODO fix
|
|
if path = '' then
|
|
begin
|
|
Result := 3;
|
|
Exit;
|
|
end;
|
|
|
|
{We always also search for readonly and archive, regardless of Attr.}
|
|
Rslt.searchAttr := (Attr or (archive or readonly));
|
|
|
|
{ TODO: convert PathArgToFSSpec (and the routines it calls) to rawbytestring }
|
|
Result := PathArgToFSSpec(path, Rslt.searchFSSpec);
|
|
with Rslt do
|
|
if (Result = 0) or (Result = 2) then
|
|
begin
|
|
{ FIXME: SearchSpec is a shortstring -> ignores encoding }
|
|
SearchSpec := path;
|
|
NamePos := Length(path) - Length(searchFSSpec.name);
|
|
|
|
if (Pos('?', searchFSSpec.name) = 0) and (Pos('*', searchFSSpec.name) = 0) then {No wildcards}
|
|
begin {If exact match, we don't have to scan the directory}
|
|
exactMatch := true;
|
|
Result := DoFindOne(searchFSSpec, paramBlock);
|
|
if Result = 0 then
|
|
begin
|
|
Attr := GetFileAttrFromPB(paramBlock);
|
|
if ((Attr and not(searchAttr)) = 0) then
|
|
begin
|
|
name := searchFSSpec.name;
|
|
SetCodePage(name, DefaultFileSystemCodePage, false);
|
|
size := GetFileSizeFromPB(paramBlock);
|
|
time := MacTimeToDosPackedTime(paramBlock.ioFlMdDat);
|
|
end
|
|
else
|
|
Result := 18;
|
|
end
|
|
else if Result = 2 then
|
|
Result := 18;
|
|
end
|
|
else
|
|
begin
|
|
exactMatch := false;
|
|
|
|
s := searchFSSpec.name;
|
|
UpperString(s, true);
|
|
Rslt.searchFSSpec.name := s;
|
|
|
|
DoFind(Rslt, name, true);
|
|
end;
|
|
end;
|
|
*)
|
|
end;
|
|
|
|
|
|
Function InternalFindNext (var Rslt : TAbstractSearchRec; var Name : RawByteString) : Longint;
|
|
|
|
begin
|
|
(* TODO fix
|
|
if F.exactMatch then
|
|
Result := 18
|
|
else
|
|
Result:=DoFind (Rslt, Name, false);
|
|
*)
|
|
end;
|
|
|
|
|
|
Procedure InternalFindClose (var Handle: THandle; var FindData: TFindData);
|
|
|
|
(*
|
|
Var
|
|
GlobSearchRec : PGlobSearchRec;
|
|
*)
|
|
|
|
begin
|
|
(* TODO fix
|
|
GlobSearchRec:=PGlobSearchRec(Handle);
|
|
GlobFree (GlobSearchRec^.GlobHandle);
|
|
Dispose(GlobSearchRec);
|
|
*)
|
|
end;
|
|
|
|
|
|
Function FileGetDate (Handle : Longint) : Longint;
|
|
|
|
(*
|
|
Var Info : Stat;
|
|
*)
|
|
|
|
begin
|
|
(* TODO fix
|
|
If Not(FStat(Handle,Info)) then
|
|
Result:=-1
|
|
else
|
|
Result:=Info.Mtime;
|
|
*)
|
|
end;
|
|
|
|
|
|
Function FileSetDate (Handle,Age : Longint) : Longint;
|
|
|
|
begin
|
|
// TODO fix
|
|
// Impossible under Linux from FileHandle !!
|
|
FileSetDate:=-1;
|
|
end;
|
|
|
|
|
|
Function FileGetAttr (Const FileName : RawByteString) : Longint;
|
|
|
|
(*
|
|
Var Info : Stat;
|
|
*)
|
|
|
|
begin
|
|
(* TODO fix
|
|
If Not FStat (FileName,Info) then
|
|
Result:=-1
|
|
Else
|
|
Result:=LinuxToWinAttr(Pchar(FileName),Info);
|
|
*)
|
|
end;
|
|
|
|
|
|
Function FileSetAttr (Const Filename : RawByteString; Attr: longint) : Longint;
|
|
|
|
begin
|
|
Result:=-1;
|
|
end;
|
|
|
|
|
|
Function DeleteFile (Const FileName : RawByteString) : Boolean;
|
|
|
|
begin
|
|
(* TODO fix
|
|
Result:=UnLink (FileName);
|
|
*)
|
|
end;
|
|
|
|
|
|
Function RenameFile (Const OldName, NewName : RawByteString) : Boolean;
|
|
|
|
begin
|
|
(* TODO fix
|
|
RenameFile:=Unix.FRename(OldNAme,NewName);
|
|
*)
|
|
end;
|
|
|
|
|
|
{****************************************************************************
|
|
Disk Functions
|
|
****************************************************************************}
|
|
|
|
{
|
|
The Diskfree and Disksize functions need a file on the specified drive, since this
|
|
is required for the statfs system call.
|
|
These filenames are set in drivestr[0..26], and have been preset to :
|
|
0 - '.' (default drive - hence current dir is ok.)
|
|
1 - '/fd0/.' (floppy drive 1 - should be adapted to local system )
|
|
2 - '/fd1/.' (floppy drive 2 - should be adapted to local system )
|
|
3 - '/' (C: equivalent of dos is the root partition)
|
|
4..26 (can be set by you're own applications)
|
|
! Use AddDisk() to Add new drives !
|
|
They both return -1 when a failure occurs.
|
|
}
|
|
Const
|
|
FixDriveStr : array[0..3] of pchar=(
|
|
'.',
|
|
'/fd0/.',
|
|
'/fd1/.',
|
|
'/.'
|
|
);
|
|
var
|
|
Drives : byte;
|
|
DriveStr : array[4..26] of pchar;
|
|
|
|
Procedure AddDisk(const path:string);
|
|
begin
|
|
if not (DriveStr[Drives]=nil) then
|
|
FreeMem(DriveStr[Drives],StrLen(DriveStr[Drives])+1);
|
|
GetMem(DriveStr[Drives],length(Path)+1);
|
|
StrPCopy(DriveStr[Drives],path);
|
|
inc(Drives);
|
|
if Drives>26 then
|
|
Drives:=4;
|
|
end;
|
|
|
|
|
|
Function DiskFree(Drive: Byte): int64;
|
|
(*
|
|
var
|
|
fs : tstatfs;
|
|
*)
|
|
Begin
|
|
(* TODO fix
|
|
if ((Drive<4) and (not (fixdrivestr[Drive]=nil)) and statfs(StrPas(fixdrivestr[drive]),fs)) or
|
|
((not (drivestr[Drive]=nil)) and statfs(StrPas(drivestr[drive]),fs)) then
|
|
Diskfree:=int64(fs.bavail)*int64(fs.bsize)
|
|
else
|
|
Diskfree:=-1;
|
|
*)
|
|
End;
|
|
|
|
|
|
|
|
Function DiskSize(Drive: Byte): int64;
|
|
(*
|
|
var
|
|
fs : tstatfs;
|
|
*)
|
|
Begin
|
|
(* TODO fix
|
|
if ((Drive<4) and (not (fixdrivestr[Drive]=nil)) and statfs(StrPas(fixdrivestr[drive]),fs)) or
|
|
((not (drivestr[Drive]=nil)) and statfs(StrPas(drivestr[drive]),fs)) then
|
|
DiskSize:=int64(fs.blocks)*int64(fs.bsize)
|
|
else
|
|
DiskSize:=-1;
|
|
*)
|
|
End;
|
|
|
|
|
|
{****************************************************************************
|
|
Locale Functions
|
|
****************************************************************************}
|
|
|
|
Procedure GetLocalTime(var SystemTime: TSystemTime);
|
|
begin
|
|
(* TODO fix
|
|
Unix.GetTime(SystemTime.Hour, SystemTime.Minute, SystemTime.Second);
|
|
Unix.GetDate(SystemTime.Year, SystemTime.Month, SystemTime.Day);
|
|
SystemTime.MilliSecond := 0;
|
|
*)
|
|
end ;
|
|
|
|
|
|
Procedure InitAnsi;
|
|
Var
|
|
i : longint;
|
|
begin
|
|
{ Fill table entries 0 to 127 }
|
|
for i := 0 to 96 do
|
|
UpperCaseTable[i] := chr(i);
|
|
for i := 97 to 122 do
|
|
UpperCaseTable[i] := chr(i - 32);
|
|
for i := 123 to 191 do
|
|
UpperCaseTable[i] := chr(i);
|
|
Move (CPISO88591UCT,UpperCaseTable[192],SizeOf(CPISO88591UCT));
|
|
|
|
for i := 0 to 64 do
|
|
LowerCaseTable[i] := chr(i);
|
|
for i := 65 to 90 do
|
|
LowerCaseTable[i] := chr(i + 32);
|
|
for i := 91 to 191 do
|
|
LowerCaseTable[i] := chr(i);
|
|
Move (CPISO88591LCT,UpperCaseTable[192],SizeOf(CPISO88591UCT));
|
|
end;
|
|
|
|
|
|
Procedure InitInternational;
|
|
begin
|
|
InitInternationalGeneric;
|
|
InitAnsi;
|
|
end;
|
|
|
|
function SysErrorMessage(ErrorCode: Integer): String;
|
|
|
|
begin
|
|
(* TODO fix
|
|
Result:=StrError(ErrorCode);
|
|
*)
|
|
end;
|
|
|
|
{****************************************************************************
|
|
OS utility functions
|
|
****************************************************************************}
|
|
|
|
Function GetEnvironmentVariable(Const EnvVar : String) : String;
|
|
|
|
begin
|
|
(* TODO fix
|
|
Result:=Unix.Getenv(PChar(EnvVar));
|
|
*)
|
|
end;
|
|
|
|
Function GetEnvironmentVariableCount : Integer;
|
|
|
|
begin
|
|
// Result:=FPCCountEnvVar(EnvP);
|
|
Result:=0;
|
|
end;
|
|
|
|
Function GetEnvironmentString(Index : Integer) : {$ifdef FPC_RTL_UNICODE}UnicodeString{$else}AnsiString{$endif};
|
|
|
|
begin
|
|
// Result:=FPCGetEnvStrFromP(Envp,Index);
|
|
Result:='';
|
|
end;
|
|
|
|
{ Create a DoScript AppleEvent that targets the given application with text as the direct object. }
|
|
function CreateDoScriptEvent (applCreator: OSType; scriptText: PChar; var theEvent: AppleEvent): OSErr;
|
|
|
|
var
|
|
err: OSErr;
|
|
targetAddress: AEDesc;
|
|
s: signedByte;
|
|
|
|
begin
|
|
err := AECreateDesc(FourCharCodeToLongword(typeApplSignature), @applCreator, sizeof(applCreator), targetAddress);
|
|
if err = noErr then
|
|
begin
|
|
err := AECreateAppleEvent(FourCharCodeToLongword('misc'), FourCharCodeToLongword('dosc'),
|
|
targetAddress, kAutoGenerateReturnID, kAnyTransactionID, theEvent);
|
|
|
|
if err = noErr then
|
|
{ Add script text as the direct object parameter. }
|
|
err := AEPutParamPtr(theEvent, FourCharCodeToLongword('----'),
|
|
FourCharCodeToLongword('TEXT'), scriptText, Length(scriptText));
|
|
|
|
if err <> noErr then
|
|
AEDisposeDesc(theEvent);
|
|
AEDisposeDesc(targetAddress);
|
|
end;
|
|
|
|
CreateDoScriptEvent := err;
|
|
end;
|
|
|
|
Procedure Fpc_WriteBuffer(var f:Text;const b;len:longint);[external name 'FPC_WRITEBUFFER'];
|
|
{declared in text.inc}
|
|
|
|
procedure WriteAEDescTypeCharToFile(desc: AEDesc; var f: Text);
|
|
|
|
begin
|
|
if desc.descriptorType = FourCharCodeToLongword(typeChar) then
|
|
begin
|
|
HLock(desc.dataHandle);
|
|
Fpc_WriteBuffer(f, PChar(desc.dataHandle^)^, GetHandleSize(desc.dataHandle));
|
|
Flush(f);
|
|
HUnLock(desc.dataHandle);
|
|
end;
|
|
end;
|
|
|
|
function ExecuteToolserverScript(scriptText: PChar; var statusCode: Longint): OSErr;
|
|
|
|
var
|
|
err: OSErr;
|
|
err2: OSErr; {Non serious error}
|
|
theEvent: AppleEvent;
|
|
reply: AppleEvent;
|
|
aresult: AEDesc;
|
|
applFileSpec: FSSpec;
|
|
p: SignedByte;
|
|
|
|
const
|
|
applCreator = 'MPSX'; {Toolserver}
|
|
|
|
begin
|
|
statusCode:= 3; //3 according to MPW.
|
|
err:= CreateDoScriptEvent (FourCharCodeToLongword(applCreator), scriptText, theEvent);
|
|
if err = noErr then
|
|
begin
|
|
err := AESend(theEvent, reply, kAEWaitReply, kAENormalPriority, kAEDefaultTimeOut, nil, nil);
|
|
|
|
if err = connectionInvalid then { Toolserver not available }
|
|
begin
|
|
err := FindApplication(FourCharCodeToLongword(applCreator), applFileSpec);
|
|
if err = noErr then
|
|
err := LaunchFSSpec(false, applFileSpec);
|
|
if err = noErr then
|
|
err := AESend(theEvent, reply, kAEWaitReply, kAENormalPriority, kAEDefaultTimeOut, nil, nil);
|
|
end;
|
|
|
|
if err = noErr then
|
|
begin
|
|
err:= AEGetParamDesc(reply, FourCharCodeToLongword('stat'),
|
|
FourCharCodeToLongword(typeLongInteger), aresult);
|
|
|
|
if err = noErr then
|
|
if aresult.descriptorType = FourCharCodeToLongword(typeLongInteger) then
|
|
statusCode:= LongintPtr(aresult.dataHandle^)^;
|
|
|
|
{If there is no output below, we get a non zero error code}
|
|
|
|
err2:= AEGetParamDesc(reply, FourCharCodeToLongword('----'),
|
|
FourCharCodeToLongword(typeChar), aresult);
|
|
if err2 = noErr then
|
|
WriteAEDescTypeCharToFile(aresult, stdout);
|
|
|
|
err2:= AEGetParamDesc(reply, FourCharCodeToLongword('diag'),
|
|
FourCharCodeToLongword(typeChar), aresult);
|
|
if err2 = noErr then
|
|
WriteAEDescTypeCharToFile(aresult, stderr);
|
|
|
|
AEDisposeDesc(reply);
|
|
|
|
{$IFDEF TARGET_API_MAC_CARBON }
|
|
{$ERROR FIXME AEDesc data is not allowed to be directly accessed}
|
|
{$ENDIF}
|
|
end;
|
|
|
|
AEDisposeDesc(theEvent);
|
|
end;
|
|
|
|
ExecuteToolserverScript:= err;
|
|
end;
|
|
|
|
|
|
function ExecuteProcess (const Path: RawByteString; const ComLine: RawByteString;Flags:TExecuteFlags=[]):
|
|
integer;
|
|
var
|
|
s: AnsiString;
|
|
wdpath: RawByteString;
|
|
laststatuscode : longint;
|
|
E: EOSError;
|
|
Begin
|
|
{Make ToolServers working directory in sync with our working directory}
|
|
PathArgToFullPath(':', wdpath);
|
|
wdpath:= 'Directory ' + wdpath;
|
|
Result := ExecuteToolserverScript(PChar(wdpath), laststatuscode);
|
|
{TODO Only change path when actually needed. But this requires some
|
|
change counter to be incremented each time wd is changed. }
|
|
|
|
s:= path + ' ' + comline;
|
|
|
|
Result := ExecuteToolserverScript(PChar(s), laststatuscode);
|
|
if Result = afpItemNotFound then
|
|
Result := 900
|
|
else
|
|
Result := MacOSErr2RTEerr(Result);
|
|
if Result <> 0 then
|
|
begin
|
|
E := EOSError.CreateFmt (SExecuteProcessFailed, [Comline, DosError]);
|
|
E.ErrorCode := DosError;
|
|
raise E;
|
|
end;
|
|
//TODO Better dos error codes
|
|
if laststatuscode <> 0 then
|
|
begin
|
|
{MPW status might be 24 bits}
|
|
Result := laststatuscode and $ffff;
|
|
if Result = 0 then
|
|
Result := 1;
|
|
end
|
|
else
|
|
Result := 0;
|
|
End;
|
|
|
|
|
|
function ExecuteProcess (const Path: RawByteString;
|
|
const ComLine: array of RawByteString;Flags:TExecuteFlags=[]): integer;
|
|
var
|
|
CommandLine: RawByteString;
|
|
I: integer;
|
|
|
|
begin
|
|
Commandline := '';
|
|
for I := 0 to High (ComLine) do
|
|
if Pos (' ', ComLine [I]) <> 0 then
|
|
CommandLine := CommandLine + ' ' + '"' + ToSingleByteFileSystemEncodedFileName(ComLine [I]) + '"'
|
|
else
|
|
CommandLine := CommandLine + ' ' + ToSingleByteFileSystemEncodedFileName(Comline [I]);
|
|
ExecuteProcess := ExecuteProcess (Path, CommandLine);
|
|
end;
|
|
|
|
|
|
procedure C_usleep(val : uint32); external 'StdCLib' name 'usleep';
|
|
|
|
procedure Sleep(milliseconds: Cardinal);
|
|
begin
|
|
C_usleep(milliseconds*1000);
|
|
end;
|
|
|
|
(*
|
|
Function GetLastOSError : Integer;
|
|
|
|
begin
|
|
end;
|
|
*)
|
|
|
|
{****************************************************************************
|
|
Initialization code
|
|
****************************************************************************}
|
|
|
|
Initialization
|
|
InitExceptions; { Initialize exceptions. OS independent }
|
|
InitInternational; { Initialize internationalization settings }
|
|
Finalization
|
|
FreeTerminateProcs;
|
|
DoneExceptions;
|
|
end.
|