+ New unit, utility functions extracted from System.pp

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;

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.