|
@@ -54,6 +54,43 @@ var
|
|
|
argv : ppchar;
|
|
|
envp : ppchar;
|
|
|
|
|
|
+{*********************************}
|
|
|
+{** MacOS specific functions **}
|
|
|
+{*********************************}
|
|
|
+
|
|
|
+
|
|
|
+{*********************************}
|
|
|
+{** Available features on macos **}
|
|
|
+{*********************************}
|
|
|
+
|
|
|
+
|
|
|
+ var
|
|
|
+ macosHasGestalt: Boolean;
|
|
|
+ macosHasWaitNextEvent: Boolean;
|
|
|
+ macosHasColorQD: Boolean;
|
|
|
+ macosHasFPU: Boolean;
|
|
|
+ macosSystemVersion: Integer;
|
|
|
+ macosHasSysDebugger: Boolean = false;
|
|
|
+ macosHasCFM: Boolean;
|
|
|
+
|
|
|
+ macosHasAppleEvents: Boolean;
|
|
|
+ macosHasAliasMgr: Boolean;
|
|
|
+
|
|
|
+
|
|
|
+ macosHasFSSpec: Boolean;
|
|
|
+ macosHasFindFolder: Boolean;
|
|
|
+
|
|
|
+
|
|
|
+ macosHasScriptMgr: Boolean;
|
|
|
+ macosNrOfScriptsInstalled: Integer;
|
|
|
+
|
|
|
+ macosHasAppearance: Boolean;
|
|
|
+ macosHasAppearance101: Boolean;
|
|
|
+ macosHasAppearance11: Boolean;
|
|
|
+
|
|
|
+ macosBootVolumeVRefNum: Integer;
|
|
|
+ macosBootVolumeName: String[31];
|
|
|
+
|
|
|
{
|
|
|
MacOS paths
|
|
|
===========
|
|
@@ -81,7 +118,8 @@ A MacOS application is assembled and linked by MPW (Macintosh
|
|
|
Programmers Workshop), which nowadays is free to use. For info
|
|
|
and download of MPW and MacOS api, see www.apple.com
|
|
|
|
|
|
-It can be linked to either a standalone application (using SIOW) or
|
|
|
+It can be linked to either a graphical user interface application,
|
|
|
+a standalone text only application (using SIOW) or
|
|
|
to an MPW tool, this is entirely controlled by the linking step.
|
|
|
|
|
|
It requires system 7 and CFM, which is always the case for PowerPC.
|
|
@@ -91,16 +129,18 @@ of efforts if it also uses CFM. This System.pp should, with
|
|
|
minor modifications, probably work with m68k.
|
|
|
|
|
|
Initial working directory is the directory of the application,
|
|
|
-or for an MPWTool, the MPW directory.
|
|
|
+or for an MPWTool, the working directory as set by the
|
|
|
+Directory command in MPW.
|
|
|
|
|
|
Note about working directory. There is a facility in MacOS which
|
|
|
manages a working directory for an application, initially set to
|
|
|
-the applictaions directory, or for an MPWTool, the tool's directory.
|
|
|
+the applications directory, or for an MPWTool, the tool's directory.
|
|
|
However, this requires the application to have a unique application
|
|
|
signature (creator code), to distinguish its working directory
|
|
|
from working directories of other applications. Due to the fact
|
|
|
that casual applications are anonymous in this sense (without an
|
|
|
-application signature), this facility will not work. Hence we
|
|
|
+application signature), this facility will not work. Also, this
|
|
|
+working directory facility is not present in Carbon. Hence we
|
|
|
will manage a working directory by our self.
|
|
|
|
|
|
|
|
@@ -114,7 +154,7 @@ Then the path to the wd suddenly changes. This is AFAIK not in
|
|
|
accordance with other OS's. Although this is a minor caveat,
|
|
|
it is mentioned here. To overcome this the wd could be stored
|
|
|
as a path instead, but this imposes translations from fullpath
|
|
|
-to directory id each time the filesystem is accessed.
|
|
|
+to directory ID each time the filesystem is accessed.
|
|
|
|
|
|
The initial working directory for an MPWTool, as considered by
|
|
|
FPC, is different from the MacOS working directory facility,
|
|
@@ -123,14 +163,9 @@ see above.
|
|
|
|
|
|
Possible improvements:
|
|
|
=====================
|
|
|
-TODO: Add check so that working directory cannot be removed. Alt ensure
|
|
|
-the nothing crashes if wd is removed.
|
|
|
|
|
|
-TODO: rmdir and erase does not differentiate between files and directories
|
|
|
-thus removing both of them.
|
|
|
+Perhaps handle readonly filesystems, as in sysunix.inc
|
|
|
|
|
|
-TODO: Check of the MacOS version (and prescence of CFM) to
|
|
|
-ensure it is a supported version. only needed for m68k.
|
|
|
}
|
|
|
|
|
|
{This implementation uses StdCLib, which is included in the MPW.}
|
|
@@ -283,11 +318,19 @@ Sys_ERANGE = 34; { Math result not representable }
|
|
|
{$endif}
|
|
|
|
|
|
|
|
|
-{******************************************************}
|
|
|
+{*********************** Macutils *********************}
|
|
|
+
|
|
|
+{And also include the same utilities as in the macutils.pp unit.}
|
|
|
|
|
|
var
|
|
|
- {working directory}
|
|
|
- curDirectorySpec: FSSpec;
|
|
|
+ {emulated working directory}
|
|
|
+ workingDirectorySpec: FSSpec; cvar;
|
|
|
+ {Also declared in macutils.pp as external. Declared here to be available
|
|
|
+ to macutils.inc and below in this file.}
|
|
|
+
|
|
|
+{$I macutils.inc}
|
|
|
+
|
|
|
+{******************************************************}
|
|
|
|
|
|
function GetAppFileLocation (var spec: FSSpec): Boolean;
|
|
|
{Requires >= System 7}
|
|
@@ -316,77 +359,6 @@ begin
|
|
|
end
|
|
|
end;
|
|
|
|
|
|
-{Gives the path for a given file or directory. If parent is true,
|
|
|
- a path to the directory, where the file or directory is located,
|
|
|
- is returned. Functioning even with System 6}
|
|
|
-function FSpGetFullPath (spec: FSSpec; var fullPathHandle: Mac_Handle;
|
|
|
- parent: Boolean): OSErr;
|
|
|
-
|
|
|
- var
|
|
|
- res: OSErr;
|
|
|
- pb: CInfoPBRec;
|
|
|
-
|
|
|
-begin
|
|
|
- fullPathHandle:= NewHandle(0); { Allocate a zero-length handle }
|
|
|
- if fullPathHandle = nil then
|
|
|
- begin
|
|
|
- FSpGetFullPath:= MemError;
|
|
|
- Exit;
|
|
|
- end;
|
|
|
-
|
|
|
- if spec.parID = fsRtParID then { The object is a volume }
|
|
|
- begin
|
|
|
- if not parent then
|
|
|
- begin
|
|
|
- { Add a colon to make it a full pathname }
|
|
|
- spec.name := Concat(spec.name, ':');
|
|
|
-
|
|
|
- { We're done }
|
|
|
- Munger(fullPathHandle, 0, nil, 0, @spec.name[1], Length(spec.name));
|
|
|
- res := MemError;
|
|
|
- end
|
|
|
- else
|
|
|
- res := noErr;
|
|
|
- end
|
|
|
- else
|
|
|
- begin
|
|
|
- { The object isn't a volume }
|
|
|
-
|
|
|
- { Add the object name }
|
|
|
- if not parent then
|
|
|
- Munger(fullPathHandle, 0, nil, 0, @spec.name[1], Length(spec.name));
|
|
|
-
|
|
|
- { Get the ancestor directory names }
|
|
|
- pb.ioNamePtr := @spec.name;
|
|
|
- pb.ioVRefNum := spec.vRefNum;
|
|
|
- pb.ioDrParID := spec.parID;
|
|
|
- repeat { loop until we have an error or find the root directory }
|
|
|
- begin
|
|
|
- pb.ioFDirIndex := -1;
|
|
|
- pb.ioDrDirID := pb.ioDrParID;
|
|
|
- res := PBGetCatInfoSync(@pb);
|
|
|
- if res = noErr then
|
|
|
- begin
|
|
|
- { Append colon to directory name }
|
|
|
- spec.name := Concat(spec.name, ':');
|
|
|
-
|
|
|
- { Add directory name to fullPathHandle }
|
|
|
- Munger(fullPathHandle, 0, nil, 0, @spec.name[1], Length(spec.name));
|
|
|
- res := MemError;
|
|
|
- end
|
|
|
- end
|
|
|
- until not ((res = noErr) and (pb.ioDrDirID <> fsRtDirID));
|
|
|
- end;
|
|
|
-
|
|
|
- if res <> noErr then
|
|
|
- begin
|
|
|
- DisposeHandle(fullPathHandle);
|
|
|
- fullPathHandle:= nil;
|
|
|
- end;
|
|
|
-
|
|
|
- FSpGetFullPath := res;
|
|
|
-end;
|
|
|
-
|
|
|
Procedure Errno2InOutRes;
|
|
|
{
|
|
|
Convert ErrNo error to the correct InOutRes value.
|
|
@@ -424,149 +396,11 @@ begin
|
|
|
errno:=0;
|
|
|
end;
|
|
|
|
|
|
-Function MacOSErr2RTEerr(err: OSErr): Integer;
|
|
|
-{ Converts MacOS specific error codes to the correct FPC error code.
|
|
|
- All non zero MacOS errors shall correspond to a nonzero FPC error.}
|
|
|
-var
|
|
|
- res: Integer;
|
|
|
-begin
|
|
|
- if err = noErr then { Else it will go through all the cases }
|
|
|
- res:= 0
|
|
|
- else case err of
|
|
|
- dirFulErr, { Directory full }
|
|
|
- dskFulErr { disk full }
|
|
|
- :res:=101;
|
|
|
- nsvErr { no such volume }
|
|
|
- :res:=3;
|
|
|
- ioErr, { I/O error (bummers) }
|
|
|
- bdNamErr { there may be no bad names in the final system! }
|
|
|
- :res:=1; //TODO Exchange to something better
|
|
|
- fnOpnErr { File not open }
|
|
|
- :res:=103;
|
|
|
- eofErr, { End of file }
|
|
|
- posErr { tried to position to before start of file (r/w) }
|
|
|
- :res:=100;
|
|
|
- mFulErr { memory full (open) or file won't fit (load) }
|
|
|
- :res:=1; //TODO Exchange to something better
|
|
|
- tmfoErr { too many files open}
|
|
|
- :res:=4;
|
|
|
- fnfErr { File not found }
|
|
|
- :res:=2;
|
|
|
- wPrErr { diskette is write protected. }
|
|
|
- :res:=150;
|
|
|
- fLckdErr { file is locked }
|
|
|
- :res:=5;
|
|
|
- vLckdErr { volume is locked }
|
|
|
- :res:=150;
|
|
|
- fBsyErr { File is busy (delete) }
|
|
|
- :res:=5;
|
|
|
- dupFNErr { duplicate filename (rename) }
|
|
|
- :res:=5;
|
|
|
- opWrErr { file already open with with write permission }
|
|
|
- :res:=5;
|
|
|
- rfNumErr, { refnum error }
|
|
|
- gfpErr { get file position error }
|
|
|
- :res:=1; //TODO Exchange to something better
|
|
|
- volOffLinErr { volume not on line error (was Ejected) }
|
|
|
- :res:=152;
|
|
|
- permErr { permissions error (on file open) }
|
|
|
- :res:=5;
|
|
|
- volOnLinErr{ drive volume already on-line at MountVol }
|
|
|
- :res:=1; //TODO Exchange to something other
|
|
|
- nsDrvErr { no such drive (tried to mount a bad drive num) }
|
|
|
- :res:=1; //TODO Perhaps exchange to something better
|
|
|
- noMacDskErr, { not a mac diskette (sig bytes are wrong) }
|
|
|
- extFSErr { volume in question belongs to an external fs }
|
|
|
- :res:=157; //TODO Perhaps exchange to something better
|
|
|
- fsRnErr, { file system internal error:during rename the old
|
|
|
- entry was deleted but could not be restored. }
|
|
|
- badMDBErr { bad master directory block }
|
|
|
- :res:=1; //TODO Exchange to something better
|
|
|
- wrPermErr { write permissions error }
|
|
|
- :res:=5;
|
|
|
- dirNFErr { Directory not found }
|
|
|
- :res:=3;
|
|
|
- tmwdoErr { No free WDCB available }
|
|
|
- :res:=1; //TODO Exchange to something better
|
|
|
- badMovErr { Move into offspring error }
|
|
|
- :res:=5;
|
|
|
- wrgVolTypErr { Wrong volume type error [operation not
|
|
|
- supported for MFS] }
|
|
|
- :res:=1; //TODO Exchange to something better
|
|
|
- volGoneErr { Server volume has been disconnected. }
|
|
|
- :res:=152;
|
|
|
-
|
|
|
- diffVolErr { files on different volumes }
|
|
|
- :res:=17;
|
|
|
- catChangedErr { the catalog has been modified }
|
|
|
- { OR comment: when searching with PBCatSearch }
|
|
|
- :res:=1; //TODO Exchange to something other
|
|
|
- afpAccessDenied, { Insufficient access privileges for operation }
|
|
|
- afpDenyConflict { Specified open/deny modes conflict with current open modes }
|
|
|
- :res:=5;
|
|
|
- afpNoMoreLocks { Maximum lock limit reached }
|
|
|
- :res:=5;
|
|
|
- afpRangeNotLocked, { Tried to unlock range that was not locked by user }
|
|
|
- afpRangeOverlap { Some or all of range already locked by same user }
|
|
|
- :res:=1; //TODO Exchange to something better
|
|
|
- afpObjectTypeErr { File/Directory specified where Directory/File expected }
|
|
|
- :res:=3;
|
|
|
- afpCatalogChanged { OR comment: when searching with PBCatSearch }
|
|
|
- :res:=1; //TODO Exchange to something other
|
|
|
- afpSameObjectErr
|
|
|
- :res:=5; //TODO Exchange to something better
|
|
|
-
|
|
|
- memFullErr { Not enough room in heap zone }
|
|
|
- :res:=203;
|
|
|
- else
|
|
|
- res := 1; //TODO Exchange to something better
|
|
|
- end;
|
|
|
- MacOSErr2RTEerr:= res;
|
|
|
-end;
|
|
|
-
|
|
|
Procedure OSErr2InOutRes(err: OSErr);
|
|
|
begin
|
|
|
InOutRes:= MacOSErr2RTEerr(err);
|
|
|
end;
|
|
|
|
|
|
-function PathArgToFSSpec(s: string; var spec: FSSpec): Integer;
|
|
|
-var
|
|
|
- err: OSErr;
|
|
|
-begin
|
|
|
- err:= FSMakeFSSpec(curDirectorySpec.vRefNum,
|
|
|
- curDirectorySpec.parID, s, spec);
|
|
|
-
|
|
|
- if err in [ noErr, fnfErr] then
|
|
|
- PathArgToFSSpec:= 0
|
|
|
- else
|
|
|
- PathArgToFSSpec:= MacOSErr2RTEerr(err);
|
|
|
-end;
|
|
|
-
|
|
|
-function PathArgToFullPath(s: string; var fullpath: AnsiString): Boolean;
|
|
|
-var
|
|
|
- err: OSErr;
|
|
|
- res: Integer;
|
|
|
- spec: FSSpec;
|
|
|
- pathHandle: Mac_Handle;
|
|
|
-begin
|
|
|
- PathArgToFullPath:= false;
|
|
|
- res:= PathArgToFSSpec(s, spec);
|
|
|
- if res = 0 then
|
|
|
- begin
|
|
|
- err:= FSpGetFullPath(spec, pathHandle, false);
|
|
|
- if err = noErr then
|
|
|
- begin
|
|
|
- SetString(fullpath, pathHandle^, GetHandleSize(pathHandle));
|
|
|
- DisposeHandle(pathHandle);
|
|
|
- PathArgToFullPath:= true;
|
|
|
- end
|
|
|
- else
|
|
|
- OSErr2InOutRes(err);
|
|
|
- end
|
|
|
- else
|
|
|
- InOutRes:=res;
|
|
|
-end;
|
|
|
-
|
|
|
function FSpLocationFromFullPath(fullPathLength: Integer;
|
|
|
fullPath: Mac_Ptr; var spec: FSSpec ):OSErr;
|
|
|
|
|
@@ -636,25 +470,22 @@ begin
|
|
|
getheapsize:= intern_heapsize ;
|
|
|
end;
|
|
|
|
|
|
-{ function to allocate size bytes more for the program }
|
|
|
-{ must return the first address of new data space or nil if failed }
|
|
|
-function Sbrk(logicalSize: Longint): Mac_Ptr ;
|
|
|
-external 'InterfaceLib' name 'NewPtr'; {Directly mapped to NewPtr}
|
|
|
-
|
|
|
{*****************************************************************************
|
|
|
OS Memory allocation / deallocation
|
|
|
****************************************************************************}
|
|
|
|
|
|
+{ function to allocate size bytes more for the program }
|
|
|
+{ must return the first address of new data space or nil if failed }
|
|
|
function SysOSAlloc(size: ptrint): pointer;
|
|
|
begin
|
|
|
- result := sbrk(size);
|
|
|
+ result := NewPtr(size);
|
|
|
end;
|
|
|
|
|
|
{$define HAS_SYSOSFREE}
|
|
|
|
|
|
procedure SysOSFree(p: pointer; size: ptrint);
|
|
|
begin
|
|
|
- fpmunmap(p, size);
|
|
|
+ DisposePtr(p);
|
|
|
end;
|
|
|
|
|
|
|
|
@@ -687,18 +518,27 @@ begin
|
|
|
end;
|
|
|
|
|
|
procedure do_erase(p : pchar);
|
|
|
-{this implementation cannot distinguish between directories and files}
|
|
|
+
|
|
|
var
|
|
|
- s: AnsiString;
|
|
|
+ spec: FSSpec;
|
|
|
+ err: OSErr;
|
|
|
+ res: Integer;
|
|
|
+
|
|
|
begin
|
|
|
- {$ifdef MACOS_USE_STDCLIB}
|
|
|
- if not PathArgToFullPath(p, s) then
|
|
|
- exit;
|
|
|
- remove(PChar(s));
|
|
|
- Errno2InoutRes;
|
|
|
- {$else}
|
|
|
- InOutRes:=1;
|
|
|
- {$endif}
|
|
|
+ res:= PathArgToFSSpec(p, spec);
|
|
|
+
|
|
|
+ if (res = 0) then
|
|
|
+ begin
|
|
|
+ if not IsDirectory(spec) then
|
|
|
+ begin
|
|
|
+ err:= FSpDelete(spec);
|
|
|
+ OSErr2InOutRes(err);
|
|
|
+ end
|
|
|
+ else
|
|
|
+ InOutRes:= 2;
|
|
|
+ end
|
|
|
+ else
|
|
|
+ InOutRes:=res;
|
|
|
end;
|
|
|
|
|
|
procedure do_rename(p1,p2 : pchar);
|
|
@@ -706,9 +546,11 @@ var
|
|
|
s1,s2: AnsiString;
|
|
|
begin
|
|
|
{$ifdef MACOS_USE_STDCLIB}
|
|
|
- if not PathArgToFullPath(p1, s1) then
|
|
|
+ InOutRes:= PathArgToFullPath(p1, s1);
|
|
|
+ if InOutRes <> 0 then
|
|
|
exit;
|
|
|
- if not PathArgToFullPath(p2, s2) then
|
|
|
+ InOutRes:= PathArgToFullPath(p2, s2);
|
|
|
+ if InOutRes <> 0 then
|
|
|
exit;
|
|
|
c_rename(PChar(s1),PChar(s2));
|
|
|
Errno2InoutRes;
|
|
@@ -740,11 +582,6 @@ begin
|
|
|
len:= c_read(h, addr, len);
|
|
|
Errno2InoutRes;
|
|
|
|
|
|
- // TEMP BUGFIX Exchange CR to LF.
|
|
|
- for i:= 0 to len-1 do
|
|
|
- if SignedBytePtr(addr + i)^ = 13 then
|
|
|
- SignedBytePtr(addr + i)^ := 10;
|
|
|
-
|
|
|
do_read:= len;
|
|
|
|
|
|
{$else}
|
|
@@ -788,12 +625,13 @@ end;
|
|
|
function do_seekend(handle:longint):longint;
|
|
|
begin
|
|
|
{$ifdef MACOS_USE_STDCLIB}
|
|
|
- lseek(handle, 0, SEEK_END);
|
|
|
+ do_seekend:= lseek(handle, 0, SEEK_END);
|
|
|
Errno2InoutRes;
|
|
|
{$else}
|
|
|
InOutRes:=1;
|
|
|
if SetFPos(handle, fsFromLEOF, 0) = noErr then
|
|
|
InOutRes:=0;
|
|
|
+ {TODO Resulting file position is to be returned.}
|
|
|
{$endif}
|
|
|
end;
|
|
|
|
|
@@ -919,16 +757,20 @@ begin
|
|
|
end
|
|
|
else
|
|
|
begin
|
|
|
- if not PathArgToFullPath(p, s) then
|
|
|
+ InOutRes:= PathArgToFullPath(p, s);
|
|
|
+ if InOutRes <> 0 then
|
|
|
exit;
|
|
|
p:= PChar(s);
|
|
|
end;
|
|
|
|
|
|
- //TODO Perhaps handle readonly filesystems, as in sysunix.inc
|
|
|
|
|
|
fh:= c_open(p, oflags);
|
|
|
+ if (fh = -1) and (errno = Sys_EROFS) and ((oflags and O_RDWR)<>0) then
|
|
|
+ begin
|
|
|
+ oflags:=oflags and not(O_RDWR);
|
|
|
+ fh:= c_open(p, oflags);
|
|
|
+ end;
|
|
|
Errno2InOutRes;
|
|
|
-
|
|
|
if fh <> -1 then
|
|
|
filerec(f).handle:= fh
|
|
|
else
|
|
@@ -1001,7 +843,7 @@ begin
|
|
|
exit;
|
|
|
|
|
|
res:= PathArgToFSSpec(s, spec);
|
|
|
- if res = 0 then
|
|
|
+ if (res = 0) or (res = 2) then
|
|
|
begin
|
|
|
err:= FSpDirCreate(spec, smSystemScript, createdDirID);
|
|
|
OSErr2InOutRes(err);
|
|
@@ -1011,20 +853,27 @@ begin
|
|
|
end;
|
|
|
|
|
|
procedure rmdir(const s:string);[IOCheck];
|
|
|
-{this implementation cannot distinguish between directories and files}
|
|
|
+
|
|
|
var
|
|
|
spec: FSSpec;
|
|
|
err: OSErr;
|
|
|
res: Integer;
|
|
|
+
|
|
|
begin
|
|
|
If (s='') or (InOutRes <> 0) then
|
|
|
exit;
|
|
|
|
|
|
- res:= PathArgToFSSpec(s, spec);
|
|
|
- if res = 0 then
|
|
|
+ res:= PathArgToFSSpec(s, spec);
|
|
|
+
|
|
|
+ if (res = 0) then
|
|
|
begin
|
|
|
- err:= FSpDelete(spec);
|
|
|
- OSErr2InOutRes(err);
|
|
|
+ if IsDirectory(spec) then
|
|
|
+ begin
|
|
|
+ err:= FSpDelete(spec);
|
|
|
+ OSErr2InOutRes(err);
|
|
|
+ end
|
|
|
+ else
|
|
|
+ InOutRes:= 20;
|
|
|
end
|
|
|
else
|
|
|
InOutRes:=res;
|
|
@@ -1040,17 +889,17 @@ begin
|
|
|
exit;
|
|
|
|
|
|
res:= PathArgToFSSpec(s, spec);
|
|
|
- if res = 0 then
|
|
|
+ if (res = 0) or (res = 2) then
|
|
|
begin
|
|
|
{ The fictive file x is appended to the directory name to make
|
|
|
FSMakeFSSpec return a FSSpec to a file in the directory.
|
|
|
Then by clearing the name, the FSSpec then
|
|
|
points to the directory. It doesn't matter whether x exists or not.}
|
|
|
err:= FSMakeFSSpec (spec.vRefNum, spec.parID, ':'+spec.name+':x', newDirSpec);
|
|
|
- if err in [ noErr, fnfErr] then
|
|
|
+ if (err = noErr) or (err = fnfErr) then
|
|
|
begin
|
|
|
- curDirectorySpec:= newDirSpec;
|
|
|
- curDirectorySpec.name:='';
|
|
|
+ workingDirectorySpec:= newDirSpec;
|
|
|
+ workingDirectorySpec.name:='';
|
|
|
InOutRes:= 0;
|
|
|
end
|
|
|
else
|
|
@@ -1064,11 +913,13 @@ begin
|
|
|
end;
|
|
|
|
|
|
procedure getDir (DriveNr: byte; var Dir: ShortString);
|
|
|
+
|
|
|
var
|
|
|
pathHandle: Mac_Handle;
|
|
|
pathHandleSize: Longint;
|
|
|
+
|
|
|
begin
|
|
|
- if FSpGetFullPath(curDirectorySpec, pathHandle, false) <> noErr then
|
|
|
+ if FSpGetFullPath(workingDirectorySpec, pathHandle, false) <> noErr then
|
|
|
Halt(3); {exit code 3 according to MPW}
|
|
|
|
|
|
pathHandleSize:= GetHandleSize(pathHandle);
|
|
@@ -1107,13 +958,215 @@ procedure setup_arguments;
|
|
|
procedure setup_environment;
|
|
|
begin
|
|
|
end;
|
|
|
+
|
|
|
+
|
|
|
+{ FindSysFolder returns the (real) vRefNum, and the DirID of the current
|
|
|
+system folder. It uses the Folder Manager if present, otherwise it falls
|
|
|
+back to SysEnvirons. It returns zero on success, otherwise a standard
|
|
|
+system error. }
|
|
|
+
|
|
|
+function FindSysFolder(var foundVRefNum: Integer; var foundDirID: Longint): OSErr;
|
|
|
+
|
|
|
+var
|
|
|
+ gesResponse: Longint;
|
|
|
+ envRec: SysEnvRec;
|
|
|
+ myWDPB: WDPBRec;
|
|
|
+ volName: String[34];
|
|
|
+ err: OSErr;
|
|
|
+
|
|
|
+begin
|
|
|
+ foundVRefNum := 0;
|
|
|
+ foundDirID := 0;
|
|
|
+ if macosHasGestalt
|
|
|
+ and (Gestalt (FourCharCodeToLongword(gestaltFindFolderAttr), gesResponse) = noErr)
|
|
|
+ and BitIsSet (gesResponse, gestaltFindFolderPresent) then
|
|
|
+ begin { Does Folder Manager exist? }
|
|
|
+ err := FindFolder (kOnSystemDisk, FourCharCodeToLongword(kSystemFolderType),
|
|
|
+ kDontCreateFolder, foundVRefNum, foundDirID);
|
|
|
+ end
|
|
|
+ else
|
|
|
+ begin
|
|
|
+ { Gestalt can't give us the answer, so we resort to SysEnvirons }
|
|
|
+ err := SysEnvirons (curSysEnvVers, envRec);
|
|
|
+ if (err = noErr) then
|
|
|
+ begin
|
|
|
+ myWDPB.ioVRefNum := envRec.sysVRefNum;
|
|
|
+ volName := '';
|
|
|
+ myWDPB.ioNamePtr := @volName;
|
|
|
+ myWDPB.ioWDIndex := 0;
|
|
|
+ myWDPB.ioWDProcID := 0;
|
|
|
+ err := PBGetWDInfoSync (@myWDPB);
|
|
|
+ if (err = noErr) then
|
|
|
+ begin
|
|
|
+ foundVRefNum := myWDPB.ioWDVRefNum;
|
|
|
+ foundDirID := myWDPB.ioWDDirID;
|
|
|
+ end;
|
|
|
+ end;
|
|
|
+ end;
|
|
|
+ FindSysFolder:= err;
|
|
|
+end;
|
|
|
+
|
|
|
+procedure InvestigateSystem;
|
|
|
+
|
|
|
+ {$IFDEF CPUM68K}
|
|
|
+ const
|
|
|
+ _GestaltDispatch = $A0AD;
|
|
|
+ _WaitNextEvent = $A860;
|
|
|
+ _ScriptUtil = $A8B5;
|
|
|
+
|
|
|
+ qdOffscreenTrap = $AB1D;
|
|
|
+ {$ENDIF}
|
|
|
+
|
|
|
+ var
|
|
|
+ err: Integer;
|
|
|
+ response: Longint;
|
|
|
+ {$IFDEF CPUM68K}
|
|
|
+ environs: SysEnvRec;
|
|
|
+ {$ENDIF}
|
|
|
+
|
|
|
+ {Vi rŠknar med att man kšr pŒ minst system 6.0.5. DŒ finns bŒde Gestalt och GDevice med.}
|
|
|
+ {Enligt Change Histrory Šr MacOS 6.0.5 mera konsistent mellan maskinmodellerna Šn fšregŒende system}
|
|
|
+
|
|
|
+begin
|
|
|
+ {$IFDEF CPUM68K}
|
|
|
+ macosHasGestalt := TrapAvailable(_GestaltDispatch);
|
|
|
+ {$ELSE}
|
|
|
+ macosHasGestalt := true; {There is always Gestalt on PowerPC}
|
|
|
+ {$ENDIF}
|
|
|
+
|
|
|
+ if not macosHasGestalt then (* If we don't have Gestalt, then we can't have any System 7 features *)
|
|
|
+ begin
|
|
|
+ {$IFDEF CPUM68K}
|
|
|
+ { Detta kan endast gŠlla pŒ en 68K maskin.}
|
|
|
+ macosHasScriptMgr := TrapAvailable(_ScriptUtil);
|
|
|
+
|
|
|
+ macosNrOfScriptsInstalled := 1; (* assume only Roman script, to start with *)
|
|
|
+
|
|
|
+ err := SysEnvirons(1, environs);
|
|
|
+ if err = noErr then
|
|
|
+ begin
|
|
|
+ if environs.machineType < 0 then { gammalt ROM}
|
|
|
+ macosHasWaitNextEvent := FALSE
|
|
|
+ else
|
|
|
+ macosHasWaitNextEvent := TrapAvailable(_WaitNextEvent);
|
|
|
+ macosHasColorQD := environs.hasColorQD;
|
|
|
+ macosHasFPU := environs.hasFPU;
|
|
|
+ macosSystemVersion := environs.systemVersion;
|
|
|
+ end
|
|
|
+ else
|
|
|
+ begin
|
|
|
+ macosHasWaitNextEvent := FALSE;
|
|
|
+ macosHasColorQD := FALSE;
|
|
|
+ macosHasFPU := FALSE;
|
|
|
+ macosSystemVersion := 0;
|
|
|
+ end;
|
|
|
+
|
|
|
+ macosHasSysDebugger := (LongintPtr(MacJmp)^ <> 0);
|
|
|
+
|
|
|
+ macosHasCFM := false;
|
|
|
+ macosHasAppleEvents := false;
|
|
|
+ macosHasAliasMgr := false;
|
|
|
+
|
|
|
+ macosHasFSSpec := false;
|
|
|
+ macosHasFindFolder := false;
|
|
|
+
|
|
|
+ macosHasAppearance := false;
|
|
|
+ macosHasAppearance101 := false;
|
|
|
+ macosHasAppearance11 := false;
|
|
|
+ {$IFDEF THINK_PASCAL}
|
|
|
+ if (macosHasScriptMgr) then
|
|
|
+ macosNrOfScriptsInstalled := GetEnvirons(smEnabled);
|
|
|
+ {$ELSE}
|
|
|
+ if (macosHasScriptMgr) then
|
|
|
+ macosNrOfScriptsInstalled := GetScriptManagerVariable(smEnabled); {Gamla rutinnamnet var GetEnvirons.}
|
|
|
+ {$ENDIF}
|
|
|
+ {$ENDIF}
|
|
|
+ end
|
|
|
+ else
|
|
|
+ begin
|
|
|
+ macosHasScriptMgr := Gestalt(FourCharCodeToLongword(gestaltScriptMgrVersion), response) = noErr; {Fšr att ta reda pŒ om script mgr finns.}
|
|
|
+ macosNrOfScriptsInstalled := 1; (* assume only Roman script, to start with *)
|
|
|
+ macosHasWaitNextEvent := true;
|
|
|
+
|
|
|
+ if Gestalt(FourCharCodeToLongword(gestaltSystemVersion), response) = noErr then
|
|
|
+ macosSystemVersion := response
|
|
|
+ else
|
|
|
+ macosSystemVersion := 0; {Borde inte kunna hŠnda.}
|
|
|
+
|
|
|
+ if Gestalt(FourCharCodeToLongword(gestaltOSAttr), response) = noErr then
|
|
|
+ macosHasSysDebugger := BitIsSet(response, gestaltSysDebuggerSupport)
|
|
|
+ else
|
|
|
+ macosHasSysDebugger := false;
|
|
|
+
|
|
|
+ if Gestalt(FourCharCodeToLongword(gestaltQuickdrawVersion), response) = noErr then
|
|
|
+ macosHasColorQD := (response >= $0100)
|
|
|
+ else
|
|
|
+ macosHasColorQD := false;
|
|
|
+
|
|
|
+ if Gestalt(FourCharCodeToLongword(gestaltFPUType), response) = noErr then
|
|
|
+ macosHasFPU := (response <> gestaltNoFPU)
|
|
|
+ else
|
|
|
+ macosHasFPU := false;
|
|
|
+
|
|
|
+ if Gestalt(FourCharCodeToLongword(gestaltCFMAttr), response) = noErr then
|
|
|
+ macosHasCFM := BitIsSet(response, gestaltCFMPresent)
|
|
|
+ else
|
|
|
+ macosHasCFM := false;
|
|
|
+
|
|
|
+ macosHasAppleEvents := Gestalt(FourCharCodeToLongword(gestaltAppleEventsAttr), response) = noErr;
|
|
|
+ macosHasAliasMgr := Gestalt(FourCharCodeToLongword(gestaltAliasMgrAttr), response) = noErr;
|
|
|
+
|
|
|
+ if Gestalt(FourCharCodeToLongword(gestaltFSAttr), response) = noErr then
|
|
|
+ macosHasFSSpec := BitIsSet(response, gestaltHasFSSpecCalls)
|
|
|
+ else
|
|
|
+ macosHasFSSpec := false;
|
|
|
+ macosHasFindFolder := Gestalt(FourCharCodeToLongword(gestaltFindFolderAttr), response) = noErr;
|
|
|
+
|
|
|
+ if macosHasScriptMgr then
|
|
|
+ begin
|
|
|
+ err := Gestalt(FourCharCodeToLongword(gestaltScriptCount), response);
|
|
|
+ if (err = noErr) then
|
|
|
+ macosNrOfScriptsInstalled := Integer(response);
|
|
|
+ end;
|
|
|
+
|
|
|
+ if (Gestalt(FourCharCodeToLongword(gestaltAppearanceAttr), response) = noErr) then
|
|
|
+ begin
|
|
|
+ macosHasAppearance := BitIsSet(response, gestaltAppearanceExists);
|
|
|
+ if Gestalt(FourCharCodeToLongword(gestaltAppearanceVersion), response) = noErr then
|
|
|
+ begin
|
|
|
+ macosHasAppearance101 := (response >= $101);
|
|
|
+ macosHasAppearance11 := (response >= $110);
|
|
|
+ end
|
|
|
+ end
|
|
|
+ else
|
|
|
+ begin
|
|
|
+ macosHasAppearance := false;
|
|
|
+ macosHasAppearance101 := false;
|
|
|
+ macosHasAppearance11 := false;
|
|
|
+ end;
|
|
|
+ end;
|
|
|
+end;
|
|
|
|
|
|
{*****************************************************************************
|
|
|
System Dependent Exit code
|
|
|
*****************************************************************************}
|
|
|
|
|
|
Procedure system_exit;
|
|
|
+var
|
|
|
+ s: ShortString;
|
|
|
begin
|
|
|
+ if StandAlone <> 0 then
|
|
|
+ if exitcode <> 0 then
|
|
|
+ begin
|
|
|
+ Str(exitcode,s);
|
|
|
+ if IsConsole then
|
|
|
+ Writeln( '### Program exited with exit code ' + s)
|
|
|
+ else if macosHasSysDebugger then
|
|
|
+ DebugStr('A possible error occured, exit code: ' + s + '. Type "g" and return to continue.')
|
|
|
+ else
|
|
|
+ {Be quiet}
|
|
|
+ end;
|
|
|
+
|
|
|
{$ifndef MACOS_USE_STDCLIB}
|
|
|
if StandAlone <> 0 then
|
|
|
ExitToShell;
|
|
@@ -1134,17 +1187,35 @@ begin
|
|
|
end;
|
|
|
|
|
|
var
|
|
|
- pathHandle: Mac_Handle;
|
|
|
-
|
|
|
+ resHdl: Mac_Handle;
|
|
|
+ isFolder, hadAlias, leafIsAlias: Boolean;
|
|
|
+ dirStr: string[2];
|
|
|
+ err: OSErr;
|
|
|
+ dummySysFolderDirID: Longint;
|
|
|
+
|
|
|
begin
|
|
|
- if false then //To save it from the dead code stripper
|
|
|
+ InvestigateSystem; {Must be first}
|
|
|
+
|
|
|
+ {Check requred features for system.pp to work.}
|
|
|
+ if not macosHasFSSpec then
|
|
|
+ Halt(3); //exit code 3 according to MPW
|
|
|
+
|
|
|
+ if FindSysFolder(macosBootVolumeVRefNum, dummySysFolderDirID) <> noErr then
|
|
|
+ Halt(3); //exit code 3 according to MPW
|
|
|
+
|
|
|
+ if GetVolumeName(macosBootVolumeVRefNum, macosBootVolumeName) <> noErr then
|
|
|
+ Halt(3); //exit code 3 according to MPW
|
|
|
+
|
|
|
+ { To be set if this is a GUI or console application }
|
|
|
+ if StandAlone = 0 then
|
|
|
+ IsConsole := true {Its an MPW tool}
|
|
|
+ else
|
|
|
begin
|
|
|
- //Included only to make them available for debugging in asm.
|
|
|
- Debugger;
|
|
|
- DebugStr('');
|
|
|
+ resHdl:= Get1Resource(FourCharCodeToLongword('siow'),0);
|
|
|
+ IsConsole := (resHdl <> nil); {A SIOW app is also a console}
|
|
|
+ ReleaseResource(resHdl);
|
|
|
end;
|
|
|
- { To be set if this is a GUI or console application }
|
|
|
- IsConsole := TRUE;
|
|
|
+
|
|
|
{ To be set if this is a library and not a program }
|
|
|
IsLibrary := FALSE;
|
|
|
|
|
@@ -1152,14 +1223,30 @@ begin
|
|
|
StackBottom := SPtr - StackLength;
|
|
|
|
|
|
{ Setup working directory }
|
|
|
- if not GetAppFileLocation(curDirectorySpec) then
|
|
|
- Halt(3); //exit code 3 according to MPW
|
|
|
-
|
|
|
+ if StandAlone <> 0 then
|
|
|
+ begin
|
|
|
+ if not GetAppFileLocation(workingDirectorySpec) then
|
|
|
+ Halt(3); //exit code 3 according to MPW
|
|
|
+ end
|
|
|
+ else
|
|
|
+ begin
|
|
|
+ { The fictive file x is used to make
|
|
|
+ FSMakeFSSpec return a FSSpec to a file in the directory.
|
|
|
+ Then by clearing the name, the FSSpec then
|
|
|
+ points to the directory. It doesn't matter whether x exists or not.}
|
|
|
+ dirStr:= ':x';
|
|
|
+ err:= ResolveFolderAliases(0, 0, @dirStr, true,
|
|
|
+ workingDirectorySpec, isFolder, hadAlias, leafIsAlias);
|
|
|
+ if (err <> noErr) and (err <> fnfErr) then
|
|
|
+ Halt(3); //exit code 3 according to MPW
|
|
|
+ end;
|
|
|
+
|
|
|
{ Setup heap }
|
|
|
- MaxApplZone;
|
|
|
+ if StandAlone <> 0 then
|
|
|
+ MaxApplZone;
|
|
|
if Mac_FreeMem - intern_heapsize < 30000 then
|
|
|
Halt(3); //exit code 3 according to MPW
|
|
|
- theHeap:= Sbrk(intern_heapsize);
|
|
|
+ theHeap:= SysOSAlloc(intern_heapsize);
|
|
|
if theHeap = nil then
|
|
|
Halt(3); //exit code 3 according to MPW
|
|
|
|
|
@@ -1184,7 +1271,14 @@ end.
|
|
|
|
|
|
{
|
|
|
$Log$
|
|
|
- Revision 1.16 2004-06-17 16:16:13 peter
|
|
|
+ Revision 1.17 2004-06-21 19:23:34 olle
|
|
|
+ + Variables describing misc OS features added
|
|
|
+ + Detection of GUI app
|
|
|
+ * Working directory for APPTYPE TOOL correct now
|
|
|
+ + Exit code <> 0 written to, console for console apps, to system debugger (if installed) for GUI apps.
|
|
|
+ * Misc fixes
|
|
|
+
|
|
|
+ Revision 1.16 2004/06/17 16:16:13 peter
|
|
|
* New heapmanager that releases memory back to the OS, donated
|
|
|
by Micha Nelissen
|
|
|
|