diff --git a/rtl/macos/macutils.inc b/rtl/macos/macutils.inc new file mode 100644 index 0000000000..a4ed35cff6 --- /dev/null +++ b/rtl/macos/macutils.inc @@ -0,0 +1,459 @@ +{ + $Id$ + This file is part of the Free Pascal run time library. + Copyright (c) 2004 by Olle Raab + + Some utilities specific for Mac OS + + 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. + + **********************************************************************} + +{NOTE: This file requires the following global variables to be declared: + workingDirectorySpec: FSSpec;} + +function FourCharCodeToLongword(fourcharcode: Shortstring): Longword; + +begin + FourCharCodeToLongword:= + (ord(fourcharcode[1]) shl 24) or + (ord(fourcharcode[2]) shl 16) or + (ord(fourcharcode[3]) shl 8) or + (ord(fourcharcode[4])) +end; + +function BitIsSet(arg: Longint; bitnr: Integer): Boolean; + +begin + BitIsSet:= (arg and (1 shl bitnr)) <> 0; +end; + +{ Converts MacOS specific error codes to the correct FPC error code. + All non zero MacOS errors corresponds to a nonzero FPC error.} +Function MacOSErr2RTEerr(err: OSErr): Integer; + +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; + + {Translates a unix or dos path to a mac path. Even a mac path can be input, } + {then it is returned as is. A trailing directory separator in input} + {will result in a trailing mac directory separator. For absolute paths, the } + {parameter mpw affects how the root volume is denoted. If mpw is true, } + {the path is intended for use in MPW, and the environment variable Boot is} + {prepended. Otherwise the actual boot volume name is appended.} + {All kinds of paths are attempted to be translated, except the unusal } + {dos construct: a relative path on a certain drive like : C:xxx\yyy} + + function TranslatePathToMac (const path: string; mpw: Boolean): string; + + function GetVolumeIdentifier: string; + + var + s: Str255; + dummy: Integer; + err: OSErr; + + begin + if mpw then + GetVolumeIdentifier := '{Boot}' + else + GetVolumeIdentifier := macosBootVolumeName; + end; + + var + slashPos, oldpos, newpos, oldlen, maxpos: Longint; + + begin + oldpos := 1; + slashPos := Pos('/', path); + if (slashPos <> 0) then {its a unix path} + begin + if slashPos = 1 then + begin {its a full path} + oldpos := 2; + TranslatePathToMac := GetVolumeIdentifier; + end + else {its a partial path} + TranslatePathToMac := ':'; + end + else + begin + slashPos := Pos('\', path); + if (slashPos <> 0) then {its a dos path} + begin + if slashPos = 1 then + begin {its a full path, without drive letter} + oldpos := 2; + TranslatePathToMac := GetVolumeIdentifier; + end + else if (Length(path) >= 2) and (path[2] = ':') then {its a full path, with drive letter} + begin + oldpos := 4; + TranslatePathToMac := GetVolumeIdentifier; + end + else {its a partial path} + TranslatePathToMac := ':'; + end; + end; + + if (slashPos <> 0) then {its a unix or dos path} + begin + {Translate "/../" to "::" , "/./" to ":" and "/" to ":" } + newpos := Length(TranslatePathToMac); + oldlen := Length(path); + SetLength(TranslatePathToMac, newpos + oldlen); {It will be no longer than what is already} + {prepended plus length of path.} + maxpos := Length(TranslatePathToMac); {Get real maxpos, can be short if String is ShortString} + + {There is never a slash in the beginning, because either it was an absolute path, and then the} + {drive and slash was removed, or it was a relative path without a preceding slash.} + while oldpos <= oldlen do + begin + {Check if special dirs, ./ or ../ } + if path[oldPos] = '.' then + if (oldpos + 1 <= oldlen) and (path[oldPos + 1] = '.') then + begin + if (oldpos + 2 > oldlen) or (path[oldPos + 2] in ['/', '\']) then + begin + {It is "../" or ".." translates to ":" } + if newPos = maxPos then + begin {Shouldn't actually happen, but..} + Exit(''); + end; + newPos := newPos + 1; + TranslatePathToMac[newPos] := ':'; + oldPos := oldPos + 3; + continue; {Start over again} + end; + end + else if (oldpos + 1 > oldlen) or (path[oldPos + 1] in ['/', '\']) then + begin + {It is "./" or "." ignor it } + oldPos := oldPos + 2; + continue; {Start over again} + end; + + {Collect file or dir name} + while (oldpos <= oldlen) and not (path[oldPos] in ['/', '\']) do + begin + if newPos = maxPos then + begin {Shouldn't actually happen, but..} + Exit(''); + end; + newPos := newPos + 1; + TranslatePathToMac[newPos] := path[oldPos]; + oldPos := oldPos + 1; + end; + + {When we come here there is either a slash or we are at the end.} + if (oldpos <= oldlen) then + begin + if newPos = maxPos then + begin {Shouldn't actually happen, but..} + Exit(''); + end; + newPos := newPos + 1; + TranslatePathToMac[newPos] := ':'; + oldPos := oldPos + 1; + end; + end; + + SetLength(TranslatePathToMac, newpos); + end + else if (path = '.') then + TranslatePathToMac := ':' + else if (path = '..') then + TranslatePathToMac := '::' + else + TranslatePathToMac := path; {its a mac path} + end; + + {Concats the relative or full path path1 and the relative path path2.} + function ConcatMacPath (path1, path2: string): string; + + begin + if Pos(':', path1) = 0 then {its partial} + Insert(':', path1, 1); {because otherwise it would be interpreted} + {as a full path, when path2 is appended.} + + if path1[Length(path1)] = ':' then + begin + if path2[1] = ':' then + begin + Delete(path1, Length(path1), 1); + ConcatMacPath := Concat(path1, path2) + end + else + ConcatMacPath := Concat(path1, path2) + end + else + begin + if path2[1] = ':' then + ConcatMacPath := Concat(path1, path2) + else + ConcatMacPath := Concat(path1, ':', path2) + end; + end; + + function IsMacFullPath (const path: string): Boolean; + + begin + if Pos(':', path) = 0 then {its partial} + IsMacFullPath := false + else if path[1] = ':' then + IsMacFullPath := false + else + IsMacFullPath := true + end; + + function IsDirectory (var spec: FSSpec): Boolean; + + var + err: OSErr; + paramBlock: CInfoPBRec; + + begin + with paramBlock do + begin + ioVRefNum := spec.vRefNum; + ioDirID := spec.parID; + ioNamePtr := @spec.name; + ioFDirIndex := 0; + + err := PBGetCatInfoSync(@paramBlock); + + if err = noErr then + IsDirectory := (paramBlock.ioFlAttrib and $10) <> 0 + else + IsDirectory := false; + 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. + TODO use AnsiString instead of Mac_Handle} +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; + +function PathArgToFSSpec(s: string; var spec: FSSpec): Integer; +var + err: OSErr; +begin + err:= FSMakeFSSpec(workingDirectorySpec.vRefNum, + workingDirectorySpec.parID, s, spec); + PathArgToFSSpec := MacOSErr2RTEerr(err); +end; + +function PathArgToFullPath(s: string; var fullpath: AnsiString): Integer; + +var + err: OSErr; + res: Integer; + spec: FSSpec; + pathHandle: Mac_Handle; + +begin + res:= PathArgToFSSpec(s, spec); + if (res = 0) or (res = 2) then + begin + err:= FSpGetFullPath(spec, pathHandle, false); + if err = noErr then + begin + HLock(pathHandle); + SetString(fullpath, pathHandle^, GetHandleSize(pathHandle)); + DisposeHandle(pathHandle); + PathArgToFullPath:= 0; + end + else + PathArgToFullPath:= MacOSErr2RTEerr(err); + end + else + PathArgToFullPath:=res; +end; + +function GetVolumeName(vRefNum: Integer; var volName: String): OSErr; + +var + pb: HParamBlockRec; + +begin + pb.ioNamePtr := @volName; + pb.ioVRefNum := vRefNum; + pb.ioVolIndex := 0; + PBHGetVInfoSync(@pb); + volName:= volName + ':'; + GetVolumeName:= pb.ioResult; +end; + +function GetWorkingDirectoryVRefNum: Integer; + +begin + GetWorkingDirectoryVRefNum:= workingDirectorySpec.vRefNum; +end; diff --git a/rtl/macos/macutils.pp b/rtl/macos/macutils.pp new file mode 100644 index 0000000000..bea3fc39cf --- /dev/null +++ b/rtl/macos/macutils.pp @@ -0,0 +1,72 @@ +{ + $Id$ + This file is part of the Free Pascal run time library. + Copyright (c) 2004 by Olle Raab + + Some utilities specific for Mac OS + + 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 macutils; + +interface + +uses + macostp; + +function FourCharCodeToLongword(fourcharcode: Shortstring): Longword; + +function BitIsSet(arg: Longint; bitnr: Integer): Boolean; + +{ Converts MacOS specific error codes to the correct FPC error code. + All non zero MacOS errors corresponds to a nonzero FPC error.} +function MacOSErr2RTEerr(err: OSErr): Integer; + + +{Translates a unix or dos path to a mac path. Even a mac path can be input, } +{then it is returned as is. A trailing directory separator in input} +{will result in a trailing mac directory separator. For absolute paths, the } +{parameter mpw affects how the root volume is denoted. If mpw is true, } +{the path is intended for use in MPW, and the environment variable Boot is} +{prepended. Otherwise the actual boot volume name is appended.} +{All kinds of paths are attempted to be translated, except relative path on} +{a certion drive: C:xxx\yyy, are atteted to } + +function TranslatePathToMac (const path: string; mpw: Boolean): string; + + +{Concats the relative or full path1 to the relative path2.} +function ConcatMacPath (path1, path2: string): string; + + +function IsMacFullPath (const path: string): Boolean; + + +function IsDirectory (var spec: FSSpec): Boolean; + +function PathArgToFSSpec(s: string; var spec: FSSpec): Integer; + +function PathArgToFullPath(s: string; var fullpath: AnsiString): Integer; + +{Gives the volume name (with appended colon) for a given volume reference number.} +function GetVolumeName(vRefNum: Integer; var volName: String): OSErr; + +function GetWorkingDirectoryVRefNum: Integer; + +implementation + +var + {emulated working directory} + workingDirectorySpec: FSSpec; cvar; external; + {Actually defined in system.pp. Declared here to be used in macutils.inc } + +{$I macutils.inc} + +end. \ No newline at end of file