|
@@ -0,0 +1,917 @@
|
|
|
+{
|
|
|
+ $Id$
|
|
|
+ This file is part of the Free Pascal run time library.
|
|
|
+ Copyright (c) 2004 by Olle Raab and
|
|
|
+ members of the Free Pascal development team
|
|
|
+
|
|
|
+ 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 Dos;
|
|
|
+Interface
|
|
|
+
|
|
|
+Uses
|
|
|
+ macostp;
|
|
|
+
|
|
|
+
|
|
|
+Const
|
|
|
+ {Max PathName Length for files}
|
|
|
+ FileNameLen=255;
|
|
|
+
|
|
|
+Type
|
|
|
+ SearchRec = packed record
|
|
|
+ Attr: Byte; {attribute of found file}
|
|
|
+ Time: LongInt; {last modify date of found file}
|
|
|
+ Size: LongInt; {file size of found file}
|
|
|
+ Reserved: Word; {future use}
|
|
|
+ Name: string[FileNameLen]; {name of foundfile}
|
|
|
+ SearchSpec: string[FileNameLen]; {search pattern}
|
|
|
+ NamePos: Word; {end of path,start of name position}
|
|
|
+
|
|
|
+ {MacOS specific params, private, do not use:}
|
|
|
+ paramBlock: CInfoPBRec;
|
|
|
+ searchFSSpec: FSSpec;
|
|
|
+ searchAttr: Byte; {attribute we are searching for}
|
|
|
+ exactMatch: Boolean;
|
|
|
+ end;
|
|
|
+
|
|
|
+{$i dosh.inc}
|
|
|
+
|
|
|
+Implementation
|
|
|
+
|
|
|
+{TODO Obtain disk size and disk free values for volumes > 2 GB.
|
|
|
+ For this, PBXGetVolInfoSync can be used. However, this function
|
|
|
+ is not available on older versions of Mac OS, so the function has
|
|
|
+ to be weak linked. An alternative is to directly look into the VCB
|
|
|
+ (Volume Control Block), but since this is on low leveel it is a
|
|
|
+ compatibility risque.}
|
|
|
+
|
|
|
+{TODO Perhaps make SearchRec.paramBlock opaque, so that uses macostp;
|
|
|
+ is not needed in the interface part.}
|
|
|
+
|
|
|
+{TODO Perhaps add some kind of "Procedure AddDisk" for accessing other
|
|
|
+ volumes. At lest accessing the possible disk drives with
|
|
|
+ driver number 1 and 2 should be easy.}
|
|
|
+
|
|
|
+{TODO Perhaps implement Exec with Apple Events, calling ToolServer.}
|
|
|
+
|
|
|
+
|
|
|
+{TODO Perhaps use LongDateTime for time functions. But the function
|
|
|
+ calls must then be weak linked.}
|
|
|
+
|
|
|
+Uses
|
|
|
+ macutils,
|
|
|
+ unixutil {for FNMatch};
|
|
|
+
|
|
|
+function MacTimeToDosPackedTime(macfiletime: UInt32): Longint;
|
|
|
+var
|
|
|
+ mdt: DateTimeRec; {Mac OS datastructure}
|
|
|
+ ddt: Datetime; {Dos OS datastructure}
|
|
|
+ dospackedtime: Longint;
|
|
|
+
|
|
|
+begin
|
|
|
+ SecondsToDate(macfiletime, mdt);
|
|
|
+ with ddt do
|
|
|
+ begin
|
|
|
+ year := mdt.year;
|
|
|
+ month := mdt.month;
|
|
|
+ day := mdt.day;
|
|
|
+ hour := mdt.hour;
|
|
|
+ min := mdt.minute;
|
|
|
+ sec := mdt.second;
|
|
|
+ end;
|
|
|
+ Packtime(ddt, dospackedtime);
|
|
|
+ MacTimeToDosPackedTime:= dospackedtime;
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+{******************************************************************************
|
|
|
+ --- Info / Date / Time ---
|
|
|
+******************************************************************************}
|
|
|
+
|
|
|
+function DosVersion:Word;
|
|
|
+
|
|
|
+begin
|
|
|
+ DosVersion:=
|
|
|
+ (macosSystemVersion and $FF00) or
|
|
|
+ ((macosSystemVersion and $00F0) shr 4);
|
|
|
+end;
|
|
|
+
|
|
|
+procedure GetDate (var year, month, mday, wday: word);
|
|
|
+
|
|
|
+ var
|
|
|
+ d: DateTimeRec;
|
|
|
+
|
|
|
+begin
|
|
|
+ Macostp.GetTime(d);
|
|
|
+ year := d.year;
|
|
|
+ month := d.month;
|
|
|
+ mday := d.day;
|
|
|
+ wday := d.dayOfWeek - 1; {1-based on mac}
|
|
|
+end;
|
|
|
+
|
|
|
+procedure GetTime (var hour, minute, second, sec100: word);
|
|
|
+
|
|
|
+ var
|
|
|
+ d: DateTimeRec;
|
|
|
+
|
|
|
+begin
|
|
|
+ Macostp.GetTime(d);
|
|
|
+ hour := d.hour;
|
|
|
+ minute := d.minute;
|
|
|
+ second := d.second;
|
|
|
+ sec100 := 0;
|
|
|
+end;
|
|
|
+
|
|
|
+procedure Packtime(var t : datetime;var p : longint);
|
|
|
+Begin
|
|
|
+ p:=(t.sec shr 1)+(t.min shl 5)+(t.hour shl 11)+(t.day shl 16)+(t.month shl 21)+((t.year-1980) shl 25);
|
|
|
+End;
|
|
|
+
|
|
|
+procedure Unpacktime(p : longint;var t : datetime);
|
|
|
+Begin
|
|
|
+ t.sec:=(p and 31) shl 1;
|
|
|
+ t.min:=(p shr 5) and 63;
|
|
|
+ t.hour:=(p shr 11) and 31;
|
|
|
+ t.day:=(p shr 16) and 31;
|
|
|
+ t.month:=(p shr 21) and 15;
|
|
|
+ t.year:=(p shr 25)+1980;
|
|
|
+End;
|
|
|
+
|
|
|
+Procedure SetDate(Year, Month, Day: Word);
|
|
|
+
|
|
|
+ var
|
|
|
+ d: DateTimeRec;
|
|
|
+
|
|
|
+Begin
|
|
|
+ Macostp.GetTime(d);
|
|
|
+ d.year := year;
|
|
|
+ d.month := month;
|
|
|
+ d.day := day;
|
|
|
+ Macostp.SetTime(d)
|
|
|
+End;
|
|
|
+
|
|
|
+Procedure SetTime(Hour, Minute, Second, Sec100: Word);
|
|
|
+
|
|
|
+ var
|
|
|
+ d: DateTimeRec;
|
|
|
+
|
|
|
+Begin
|
|
|
+ Macostp.GetTime(d);
|
|
|
+ d.hour := hour;
|
|
|
+ d.minute := minute;
|
|
|
+ d.second := second;
|
|
|
+ Macostp.SetTime(d)
|
|
|
+End;
|
|
|
+
|
|
|
+{******************************************************************************
|
|
|
+ --- Exec ---
|
|
|
+******************************************************************************}
|
|
|
+
|
|
|
+Procedure Exec (Const Path: PathStr; Const ComLine: ComStr);
|
|
|
+Begin
|
|
|
+ DosError:=8; //TODO A better error sometime
|
|
|
+End;
|
|
|
+
|
|
|
+Function DosExitCode: Word;
|
|
|
+Begin
|
|
|
+ DosExitCode := 3; //Indicate failure TODO a better error sometime.
|
|
|
+End;
|
|
|
+
|
|
|
+{******************************************************************************
|
|
|
+ --- Disk ---
|
|
|
+******************************************************************************}
|
|
|
+
|
|
|
+{If drive is 0 the free space on the volume of the working directory is returned.
|
|
|
+ If drive is 1 or 2, the free space on the first or second floppy disk is returned.
|
|
|
+ If drive is 3 the free space on the boot volume is returned.
|
|
|
+ If the free space is > 2 GB, then 2 GB is reported.}
|
|
|
+Function DiskFree(drive: Byte): Int64;
|
|
|
+
|
|
|
+var
|
|
|
+ myHPB: HParamBlockRec;
|
|
|
+ myErr: OSErr;
|
|
|
+
|
|
|
+begin
|
|
|
+ myHPB.ioNamePtr := NIL;
|
|
|
+ myHPB.ioVolIndex := 0;
|
|
|
+ case drive of
|
|
|
+ 0: myHPB.ioVRefNum := GetWorkingDirectoryVRefNum;
|
|
|
+ 1: myHPB.ioVRefNum := 1;
|
|
|
+ 2: myHPB.ioVRefNum := 2;
|
|
|
+ 3: myHPB.ioVRefNum := macosBootVolumeVRefNum;
|
|
|
+ else
|
|
|
+ begin
|
|
|
+ Diskfree:= -1;
|
|
|
+ Exit;
|
|
|
+ end;
|
|
|
+ end;
|
|
|
+
|
|
|
+ myErr := PBHGetVInfoSync(@myHPB);
|
|
|
+
|
|
|
+ if myErr = noErr then
|
|
|
+ Diskfree := myHPB.ioVAlBlkSiz * myHPB.ioVFrBlk
|
|
|
+ else
|
|
|
+ Diskfree:= -1;
|
|
|
+End;
|
|
|
+
|
|
|
+{If drive is 0 the size of the volume of the working directory is returned.
|
|
|
+ If drive is 1 or 2, the size of the first or second floppy disk is returned.
|
|
|
+ If drive is 3 the size of the boot volume is returned.
|
|
|
+ If the actual size is > 2 GB, then 2 GB is reported.}
|
|
|
+Function DiskSize(drive: Byte): Int64;
|
|
|
+
|
|
|
+var
|
|
|
+ myHPB: HParamBlockRec;
|
|
|
+ myErr: OSErr;
|
|
|
+
|
|
|
+Begin
|
|
|
+ myHPB.ioNamePtr := NIL;
|
|
|
+ myHPB.ioVolIndex := 0;
|
|
|
+ case drive of
|
|
|
+ 0: myHPB.ioVRefNum := GetWorkingDirectoryVRefNum;
|
|
|
+ 1: myHPB.ioVRefNum := 1;
|
|
|
+ 2: myHPB.ioVRefNum := 2;
|
|
|
+ 3: myHPB.ioVRefNum := macosBootVolumeVRefNum;
|
|
|
+ else
|
|
|
+ begin
|
|
|
+ DiskSize:= -1;
|
|
|
+ Exit;
|
|
|
+ end;
|
|
|
+ end;
|
|
|
+
|
|
|
+ myErr := PBHGetVInfoSync(@myHPB);
|
|
|
+
|
|
|
+ if myErr = noErr then
|
|
|
+ DiskSize := myHPB.ioVAlBlkSiz * myHPB.ioVNmAlBlks
|
|
|
+ else
|
|
|
+ DiskSize:=-1;
|
|
|
+End;
|
|
|
+
|
|
|
+{******************************************************************************
|
|
|
+ --- Findfirst FindNext ---
|
|
|
+******************************************************************************}
|
|
|
+
|
|
|
+(*
|
|
|
+ {The one defined in Unixutils.pp is used instead}
|
|
|
+
|
|
|
+ function FNMatch (const Pattern, Name: string): Boolean;
|
|
|
+
|
|
|
+ var
|
|
|
+ LenPat, LenName: longint;
|
|
|
+
|
|
|
+ function DoFNMatch (i, j: longint): Boolean;
|
|
|
+
|
|
|
+ var
|
|
|
+ Found: boolean;
|
|
|
+
|
|
|
+ begin
|
|
|
+ Found := true;
|
|
|
+ while Found and (i <= LenPat) do
|
|
|
+ begin
|
|
|
+ case Pattern[i] of
|
|
|
+ '?':
|
|
|
+ Found := (j <= LenName);
|
|
|
+ '*':
|
|
|
+ begin
|
|
|
+ {find the next character in pattern, different of ? and *}
|
|
|
+ while Found and (i < LenPat) do
|
|
|
+ begin
|
|
|
+ i := i + 1;
|
|
|
+ case Pattern[i] of
|
|
|
+ '*':
|
|
|
+ ;
|
|
|
+ '?':
|
|
|
+ begin
|
|
|
+ j := j + 1;
|
|
|
+ Found := (j <= LenName);
|
|
|
+ end;
|
|
|
+ otherwise
|
|
|
+ Found := false;
|
|
|
+ end;
|
|
|
+ end;
|
|
|
+ {Now, find in name the character which i points to, if the * or ?}
|
|
|
+ {wasn 't the last character in the pattern, else, use up all the}
|
|
|
+ {chars in name }
|
|
|
+ Found := true;
|
|
|
+ if (i <= LenPat) then
|
|
|
+ begin
|
|
|
+ repeat
|
|
|
+ {find a letter (not only first !) which maches pattern[i]}
|
|
|
+ while (j <= LenName) and (name[j] <> pattern[i]) do
|
|
|
+ j := j + 1;
|
|
|
+ if (j < LenName) then
|
|
|
+ begin
|
|
|
+ if DoFnMatch(i + 1, j + 1) then
|
|
|
+ begin
|
|
|
+ i := LenPat;
|
|
|
+ j := LenName;{we can stop}
|
|
|
+ Found := true;
|
|
|
+ end
|
|
|
+ else
|
|
|
+ j := j + 1;{We didn't find one, need to look further}
|
|
|
+ end;
|
|
|
+ until (j >= LenName);
|
|
|
+ end
|
|
|
+ else
|
|
|
+ j := LenName;{we can stop}
|
|
|
+ end;
|
|
|
+ otherwise {not a wildcard character in pattern}
|
|
|
+ Found := (j <= LenName) and (pattern[i] = name[j]);
|
|
|
+ end;
|
|
|
+ i := i + 1;
|
|
|
+ j := j + 1;
|
|
|
+ end;
|
|
|
+ DoFnMatch := Found and (j > LenName);
|
|
|
+ end;
|
|
|
+
|
|
|
+ begin {start FNMatch}
|
|
|
+ LenPat := Length(Pattern);
|
|
|
+ LenName := Length(Name);
|
|
|
+ FNMatch := DoFNMatch(1, 1);
|
|
|
+ end;
|
|
|
+
|
|
|
+*)
|
|
|
+
|
|
|
+ function GetFileAttrFromPB (var paramBlock: CInfoPBRec): Word;
|
|
|
+
|
|
|
+ var
|
|
|
+ isLocked, isInvisible, isDirectory, isNameLocked: Boolean;
|
|
|
+ attr: Word;
|
|
|
+
|
|
|
+ {NOTE "nameLocked" was in pre-System 7 called "isSystem".
|
|
|
+ It is used for files whose name and icon cannot be changed by the user,
|
|
|
+ that is essentially system files. However in System 9 the folder
|
|
|
+ "Applications (Mac OS 9)" also has this attribute, and since this is
|
|
|
+ not a system file in traditional meaning, we will not use this attribute
|
|
|
+ as the "sysfile" attribute.}
|
|
|
+
|
|
|
+ begin
|
|
|
+ with paramBlock do
|
|
|
+ begin
|
|
|
+ attr := 0;
|
|
|
+
|
|
|
+ isDirectory := (ioFlAttrib and $10) <> 0;
|
|
|
+ if isDirectory then
|
|
|
+ attr := (attr or directory);
|
|
|
+
|
|
|
+ isLocked := (ioFlAttrib and $01) <> 0;
|
|
|
+ if isLocked then
|
|
|
+ attr := (attr or readonly);
|
|
|
+
|
|
|
+ if not isDirectory then
|
|
|
+ begin
|
|
|
+ isInvisible := (ioFlFndrInfo.fdFlags and 16384) <> 0;
|
|
|
+ (* isNameLocked := (ioFlFndrInfo.fdFlags and 4096) <> 0; *)
|
|
|
+ end
|
|
|
+ else
|
|
|
+ begin
|
|
|
+ isInvisible := (ioDrUsrWds.frFlags and 16384) <> 0;
|
|
|
+ (* isNameLocked := (ioDrUsrWds.frFlags and 4096) <> 0; *)
|
|
|
+ end;
|
|
|
+
|
|
|
+ if isInvisible then
|
|
|
+ attr := (attr or hidden);
|
|
|
+
|
|
|
+ (*
|
|
|
+ if isNameLocked then
|
|
|
+ attr := (attr or sysfile);
|
|
|
+ *)
|
|
|
+
|
|
|
+ GetFileAttrFromPB := attr;
|
|
|
+ end;
|
|
|
+ end;
|
|
|
+
|
|
|
+ procedure SetPBFromFileAttr (var paramBlock: CInfoPBRec; attr: Word);
|
|
|
+
|
|
|
+ begin
|
|
|
+ with paramBlock do
|
|
|
+ begin
|
|
|
+ (*
|
|
|
+ {Doesn't seem to work, despite the documentation.}
|
|
|
+ {Can instead be set by FSpSetFLock/FSpRstFLock}
|
|
|
+ if (attr and readonly) <> 0 then
|
|
|
+ ioFlAttrib := (ioFlAttrib or $01)
|
|
|
+ else
|
|
|
+ ioFlAttrib := (ioFlAttrib and not($01));
|
|
|
+ *)
|
|
|
+
|
|
|
+ if (attr and hidden) <> 0 then
|
|
|
+ ioFlFndrInfo.fdFlags := (ioFlFndrInfo.fdFlags or 16384)
|
|
|
+ else
|
|
|
+ ioFlFndrInfo.fdFlags := (ioFlFndrInfo.fdFlags and not(16384))
|
|
|
+ end;
|
|
|
+ end;
|
|
|
+
|
|
|
+ function GetFileSizeFromPB (var paramBlock: CInfoPBRec): Longint;
|
|
|
+
|
|
|
+ begin
|
|
|
+ with paramBlock do
|
|
|
+ if ((ioFlAttrib and $10) <> 0) then {if directory}
|
|
|
+ GetFileSizeFromPB := 0
|
|
|
+ else
|
|
|
+ GetFileSizeFromPB := ioFlLgLen + ioFlRLgLen; {Add length of both forks}
|
|
|
+ end;
|
|
|
+
|
|
|
+ function DoFindOne (var spec: FSSpec; var paramBlock: CInfoPBRec): Integer;
|
|
|
+
|
|
|
+ var
|
|
|
+ err: OSErr;
|
|
|
+
|
|
|
+ begin
|
|
|
+ with paramBlock do
|
|
|
+ begin
|
|
|
+ ioVRefNum := spec.vRefNum;
|
|
|
+ ioDirID := spec.parID;
|
|
|
+ ioNamePtr := @spec.name;
|
|
|
+ ioFDirIndex := 0;
|
|
|
+
|
|
|
+ err := PBGetCatInfoSync(@paramBlock);
|
|
|
+
|
|
|
+ DoFindOne := MacOSErr2RTEerr(err);
|
|
|
+ end;
|
|
|
+ end;
|
|
|
+
|
|
|
+ {To be used after a call to DoFindOne, with the same spec and paramBlock.}
|
|
|
+ {Change those parameters in paramBlock, which is to be changed.}
|
|
|
+ function DoSetOne (var spec: FSSpec; var paramBlock: CInfoPBRec): Integer;
|
|
|
+
|
|
|
+ var
|
|
|
+ err: OSErr;
|
|
|
+
|
|
|
+ begin
|
|
|
+ with paramBlock do
|
|
|
+ begin
|
|
|
+ ioVRefNum := spec.vRefNum;
|
|
|
+ ioDirID := spec.parID;
|
|
|
+ ioNamePtr := @spec.name;
|
|
|
+
|
|
|
+ err := PBSetCatInfoSync(@paramBlock);
|
|
|
+
|
|
|
+ DoSetOne := MacOSErr2RTEerr(err);
|
|
|
+ end;
|
|
|
+ end;
|
|
|
+
|
|
|
+ procedure DoFind (var F: SearchRec; firstTime: Boolean);
|
|
|
+
|
|
|
+ var
|
|
|
+ err: OSErr;
|
|
|
+ s: Str255;
|
|
|
+
|
|
|
+ begin
|
|
|
+ with F, 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(f.paramBlock);
|
|
|
+ if ((Attr and not(searchAttr)) = 0) then
|
|
|
+ begin
|
|
|
+ name := s;
|
|
|
+ UpperString(s, true);
|
|
|
+
|
|
|
+ if FNMatch(F.searchFSSpec.name, s) then
|
|
|
+ begin
|
|
|
+ size := GetFileSizeFromPB(paramBlock);
|
|
|
+ time := MacTimeToDosPackedTime(ioFlMdDat);
|
|
|
+ DosError := 0;
|
|
|
+ break;
|
|
|
+ end;
|
|
|
+ end;
|
|
|
+ end;
|
|
|
+ end;
|
|
|
+ end;
|
|
|
+
|
|
|
+ procedure FindFirst (const path: pathstr; Attr: Word; var F: SearchRec);
|
|
|
+ var
|
|
|
+ s: Str255;
|
|
|
+
|
|
|
+ begin
|
|
|
+ fillchar(f, sizeof(f), 0);
|
|
|
+
|
|
|
+ if path = '' then
|
|
|
+ begin
|
|
|
+ DosError := 3;
|
|
|
+ Exit;
|
|
|
+ end;
|
|
|
+
|
|
|
+ {We always also search for readonly and archive, regardless of Attr.}
|
|
|
+ F.searchAttr := (Attr or (archive or readonly));
|
|
|
+
|
|
|
+ DosError := PathArgToFSSpec(path, F.searchFSSpec);
|
|
|
+ with F do
|
|
|
+ if (DosError = 0) or (DosError = 2) then
|
|
|
+ begin
|
|
|
+ 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;
|
|
|
+ DosError := DoFindOne(searchFSSpec, paramBlock);
|
|
|
+ if DosError = 0 then
|
|
|
+ begin
|
|
|
+ Attr := GetFileAttrFromPB(paramBlock);
|
|
|
+ if ((Attr and not(searchAttr)) = 0) then
|
|
|
+ begin
|
|
|
+ name := searchFSSpec.name;
|
|
|
+ size := GetFileSizeFromPB(paramBlock);
|
|
|
+ time := MacTimeToDosPackedTime(paramBlock.ioFlMdDat);
|
|
|
+ end
|
|
|
+ else
|
|
|
+ DosError := 18;
|
|
|
+ end
|
|
|
+ else if DosError = 2 then
|
|
|
+ DosError := 18;
|
|
|
+ end
|
|
|
+ else
|
|
|
+ begin
|
|
|
+ exactMatch := false;
|
|
|
+
|
|
|
+ s := searchFSSpec.name;
|
|
|
+ UpperString(s, true);
|
|
|
+ F.searchFSSpec.name := s;
|
|
|
+
|
|
|
+ DoFind(F, true);
|
|
|
+ end;
|
|
|
+ end;
|
|
|
+ end;
|
|
|
+
|
|
|
+ procedure FindNext (var f: searchRec);
|
|
|
+
|
|
|
+ begin
|
|
|
+ if F.exactMatch then
|
|
|
+ DosError := 18
|
|
|
+ else
|
|
|
+ DoFind(F, false);
|
|
|
+ end;
|
|
|
+
|
|
|
+ procedure FindClose (var f: searchRec);
|
|
|
+ {Note: Even if this routine is empty, this doesn't mean it will}
|
|
|
+ {be empty in the future. Please use it.}
|
|
|
+ begin
|
|
|
+ end;
|
|
|
+
|
|
|
+
|
|
|
+
|
|
|
+{******************************************************************************
|
|
|
+ --- File ---
|
|
|
+******************************************************************************}
|
|
|
+
|
|
|
+ function FSearch (path: pathstr; dirlist: string): pathstr;
|
|
|
+ {Searches for a file 'path' in the working directory and then in the list of }
|
|
|
+ {directories in 'dirlist' . Returns a valid (possibly relative) path or an }
|
|
|
+ {empty string if not found . Wildcards are NOT allowed }
|
|
|
+ {The dirlist can be separated with ; or , but not :}
|
|
|
+
|
|
|
+ var
|
|
|
+ NewDir: string[255];
|
|
|
+ p1: Longint;
|
|
|
+ spec: FSSpec;
|
|
|
+ fpcerr: Integer;
|
|
|
+
|
|
|
+ begin
|
|
|
+ FSearch := '';
|
|
|
+ if (Length(path) = 0) then
|
|
|
+ Exit;
|
|
|
+
|
|
|
+ {Check for Wild Cards}
|
|
|
+ if (Pos('?', Path) <> 0) or (Pos('*', Path) <> 0) then
|
|
|
+ Exit;
|
|
|
+
|
|
|
+ path := TranslatePathToMac(path, false);
|
|
|
+
|
|
|
+ {Search in working directory, or as full path}
|
|
|
+ fpcerr := PathArgToFSSpec(path, spec);
|
|
|
+ if (fpcerr = 0) and not IsDirectory(spec) then
|
|
|
+ begin
|
|
|
+ FSearch := path;
|
|
|
+ Exit;
|
|
|
+ end
|
|
|
+ else if not IsMacFullPath(path) then {If full path, we do not need to continue.}
|
|
|
+ begin
|
|
|
+ {Replace ';' with native mac PathSeparator (',').}
|
|
|
+ {Note: we cannot support unix style ':', because it is used as dir separator in MacOS}
|
|
|
+ for p1 := 1 to length(dirlist) do
|
|
|
+ if dirlist[p1] = ';' then
|
|
|
+ dirlist[p1] := PathSeparator;
|
|
|
+
|
|
|
+ repeat
|
|
|
+ p1 := Pos(PathSeparator, DirList);
|
|
|
+ if p1 = 0 then
|
|
|
+ p1 := 255;
|
|
|
+ NewDir := TranslatePathToMac(Copy(DirList, 1, P1 - 1), false);
|
|
|
+
|
|
|
+ NewDir := ConcatMacPath(NewDir, Path);
|
|
|
+
|
|
|
+ Delete(DirList, 1, p1);
|
|
|
+
|
|
|
+ fpcerr := PathArgToFSSpec(NewDir, spec);
|
|
|
+ if fpcerr = 0 then
|
|
|
+ begin
|
|
|
+ if IsDirectory(spec) then
|
|
|
+ NewDir := '';
|
|
|
+ end
|
|
|
+ else
|
|
|
+ NewDir := '';
|
|
|
+ until (DirList = '') or (Length(NewDir) > 0);
|
|
|
+ FSearch := NewDir;
|
|
|
+ end;
|
|
|
+ end;
|
|
|
+
|
|
|
+
|
|
|
+{$UNDEF USE_FEXPAND_INC}
|
|
|
+
|
|
|
+{$IFDEF USE_FEXPAND_INC}
|
|
|
+
|
|
|
+
|
|
|
+{$DEFINE FPC_FEXPAND_VOLUMES}
|
|
|
+{$DEFINE FPC_FEXPAND_NO_DEFAULT_PATHS}
|
|
|
+
|
|
|
+{ TODO A lot of issues before this works}
|
|
|
+
|
|
|
+{$I fexpand.inc}
|
|
|
+
|
|
|
+{$UNDEF FPC_FEXPAND_VOLUMES}
|
|
|
+{$UNDEF FPC_FEXPAND_NO_DEFAULT_PATHS}
|
|
|
+
|
|
|
+
|
|
|
+{$ELSE}
|
|
|
+
|
|
|
+{ TODO nonexisting dirs in path's doesnt work (nonexisting files do work)
|
|
|
+ example: Writeln('FExpand on :nisse:kalle : ', FExpand(':nisse:kalle')); }
|
|
|
+
|
|
|
+ function FExpand (const path: pathstr): pathstr;
|
|
|
+ var
|
|
|
+ fullpath: AnsiString;
|
|
|
+ begin
|
|
|
+ DosError:= PathArgToFullPath(path, fullpath);
|
|
|
+ FExpand:= fullpath;
|
|
|
+ end;
|
|
|
+
|
|
|
+{$ENDIF}
|
|
|
+
|
|
|
+ procedure FSplit (path: pathstr; var dir: dirstr; var name: namestr; var ext: extstr);
|
|
|
+
|
|
|
+ var
|
|
|
+ dotPos,colonPos,i : longint;
|
|
|
+
|
|
|
+ begin
|
|
|
+ colonPos:=0;
|
|
|
+ dotPos:=256;
|
|
|
+ i:=Length(path);
|
|
|
+ while (i>0) and (colonPos=0) Do
|
|
|
+ begin
|
|
|
+ If (dotPos=256) and (path[i]='.') Then
|
|
|
+ dotPos:=i;
|
|
|
+ If (path[i]=':') Then
|
|
|
+ colonPos:=i;
|
|
|
+ Dec(i);
|
|
|
+ end;
|
|
|
+ ext:=Copy(path,dotPos,255);
|
|
|
+ dir:=Copy(path,1,colonPos);
|
|
|
+ name:=Copy(path,colonPos + 1,dotPos - colonPos - 1);
|
|
|
+ end;
|
|
|
+
|
|
|
+ procedure GetFTime (var f ; var time: longint);
|
|
|
+
|
|
|
+ var
|
|
|
+ spec: FSSpec;
|
|
|
+ paramBlock: CInfoPBRec;
|
|
|
+
|
|
|
+ begin
|
|
|
+ DosError := PathArgToFSSpec(filerec(f).name, spec);
|
|
|
+ if (DosError = 0) or (DosError = 2) then
|
|
|
+ begin
|
|
|
+ DosError := DoFindOne(spec, paramBlock);
|
|
|
+ if DosError = 0 then
|
|
|
+ time := MacTimeToDosPackedTime(paramBlock.ioFlMdDat);
|
|
|
+ end;
|
|
|
+ end;
|
|
|
+
|
|
|
+ procedure SetFTime (var f ; time: longint);
|
|
|
+
|
|
|
+ var
|
|
|
+ spec: FSSpec;
|
|
|
+ paramBlock: CInfoPBRec;
|
|
|
+ d: DateTimeRec; {Mac OS datastructure}
|
|
|
+ t: datetime;
|
|
|
+ macfiletime: UInt32;
|
|
|
+
|
|
|
+ begin
|
|
|
+ DosError := PathArgToFSSpec(filerec(f).name, spec);
|
|
|
+ if (DosError = 0) or (DosError = 2) then
|
|
|
+ begin
|
|
|
+ DosError := DoFindOne(spec, paramBlock);
|
|
|
+ if DosError = 0 then
|
|
|
+ begin
|
|
|
+ Unpacktime(time, t);
|
|
|
+ with t do
|
|
|
+ begin
|
|
|
+ d.year := year;
|
|
|
+ d.month := month;
|
|
|
+ d.day := day;
|
|
|
+ d.hour := hour;
|
|
|
+ d.minute := min;
|
|
|
+ d.second := sec;
|
|
|
+ end;
|
|
|
+ DateToSeconds(d, macfiletime);
|
|
|
+ paramBlock.ioFlMdDat := macfiletime;
|
|
|
+ DosError := DoSetOne(spec, paramBlock);
|
|
|
+ end;
|
|
|
+ end;
|
|
|
+ end;
|
|
|
+
|
|
|
+ procedure GetFAttr (var f ; var attr: word);
|
|
|
+
|
|
|
+ var
|
|
|
+ spec: FSSpec;
|
|
|
+ paramBlock: CInfoPBRec;
|
|
|
+
|
|
|
+ begin
|
|
|
+ DosError := PathArgToFSSpec(filerec(f).name, spec);
|
|
|
+ if (DosError = 0) or (DosError = 2) then
|
|
|
+ begin
|
|
|
+ DosError := DoFindOne(spec, paramBlock);
|
|
|
+ if DosError = 0 then
|
|
|
+ attr := GetFileAttrFromPB(paramBlock);
|
|
|
+ end;
|
|
|
+ end;
|
|
|
+
|
|
|
+ procedure SetFAttr (var f ; attr: word);
|
|
|
+
|
|
|
+ var
|
|
|
+ spec: FSSpec;
|
|
|
+ paramBlock: CInfoPBRec;
|
|
|
+
|
|
|
+ begin
|
|
|
+ if (attr and VolumeID) <> 0 then
|
|
|
+ begin
|
|
|
+ Doserror := 5;
|
|
|
+ end;
|
|
|
+
|
|
|
+ DosError := PathArgToFSSpec(filerec(f).name, spec);
|
|
|
+ if (DosError = 0) or (DosError = 2) then
|
|
|
+ begin
|
|
|
+ DosError := DoFindOne(spec, paramBlock);
|
|
|
+ if DosError = 0 then
|
|
|
+ begin
|
|
|
+ SetPBFromFileAttr(paramBlock, attr);
|
|
|
+ DosError := DoSetOne(spec, paramBlock);
|
|
|
+
|
|
|
+ if (paramBlock.ioFlAttrib and $10) = 0 then {check not directory}
|
|
|
+ if DosError = 0 then
|
|
|
+ if (attr and readonly) <> 0 then
|
|
|
+ DosError := MacOSErr2RTEerr(FSpSetFLock(spec))
|
|
|
+ else
|
|
|
+ DosError := MacOSErr2RTEerr(FSpRstFLock(spec));
|
|
|
+ end;
|
|
|
+ end;
|
|
|
+ end;
|
|
|
+
|
|
|
+{******************************************************************************
|
|
|
+ --- Environment ---
|
|
|
+******************************************************************************}
|
|
|
+
|
|
|
+Function EnvCount: Longint;
|
|
|
+var
|
|
|
+ envcnt : longint;
|
|
|
+ p : ppchar;
|
|
|
+Begin
|
|
|
+ envcnt:=0;
|
|
|
+ p:=envp; {defined in system}
|
|
|
+ while (p^<>nil) do
|
|
|
+ begin
|
|
|
+ inc(envcnt);
|
|
|
+ inc(p);
|
|
|
+ end;
|
|
|
+ EnvCount := envcnt
|
|
|
+End;
|
|
|
+
|
|
|
+
|
|
|
+Function EnvStr (Index: longint): String;
|
|
|
+
|
|
|
+Var
|
|
|
+ i : longint;
|
|
|
+ p : ppchar;
|
|
|
+Begin
|
|
|
+ p:=envp; {defined in system}
|
|
|
+ i:=1;
|
|
|
+ while (i<Index) and (p^<>nil) do
|
|
|
+ begin
|
|
|
+ inc(i);
|
|
|
+ inc(p);
|
|
|
+ end;
|
|
|
+ if p=nil then
|
|
|
+ envstr:=''
|
|
|
+ else
|
|
|
+ begin
|
|
|
+ envstr:=strpas(p^) + '=' + strpas(p^+strlen(p^)+1)
|
|
|
+ end;
|
|
|
+End;
|
|
|
+
|
|
|
+
|
|
|
+function c_getenv(varname: PChar): PChar; {TODO perhaps move to a separate inc file.}
|
|
|
+ external 'StdCLib' name 'getenv';
|
|
|
+
|
|
|
+Function GetEnv(EnvVar: String): String;
|
|
|
+var
|
|
|
+ p: PChar;
|
|
|
+ name: String;
|
|
|
+Begin
|
|
|
+ name:= EnvVar+#0;
|
|
|
+ p:= c_getenv(@name[1]);
|
|
|
+ if p=nil then
|
|
|
+ GetEnv:=''
|
|
|
+ else
|
|
|
+ GetEnv:=StrPas(p);
|
|
|
+End;
|
|
|
+
|
|
|
+{******************************************************************************
|
|
|
+ --- Do Nothing Procedures/Functions ---
|
|
|
+******************************************************************************}
|
|
|
+
|
|
|
+Procedure getintvec(intno : byte;var vector : pointer);
|
|
|
+Begin
|
|
|
+ {! No MacOS equivalent !}
|
|
|
+End;
|
|
|
+
|
|
|
+Procedure setintvec(intno : byte;vector : pointer);
|
|
|
+Begin
|
|
|
+ {! No MacOS equivalent !}
|
|
|
+End;
|
|
|
+
|
|
|
+Procedure SwapVectors;
|
|
|
+Begin
|
|
|
+ {! No MacOS equivalent !}
|
|
|
+End;
|
|
|
+
|
|
|
+Procedure Keep(exitcode : word);
|
|
|
+Begin
|
|
|
+ {! No MacOS equivalent !}
|
|
|
+End;
|
|
|
+
|
|
|
+Procedure GetCBreak(Var BreakValue: Boolean);
|
|
|
+Begin
|
|
|
+ {! Might be implemented in future on MacOS to handle Cmd-. (period) key press}
|
|
|
+ breakvalue:=true
|
|
|
+End;
|
|
|
+
|
|
|
+Procedure SetCBreak(BreakValue: Boolean);
|
|
|
+Begin
|
|
|
+ {! Might be implemented in future on MacOS to handle Cmd-. (period) key press}
|
|
|
+End;
|
|
|
+
|
|
|
+Procedure GetVerify(Var Verify: Boolean);
|
|
|
+Begin
|
|
|
+ {! Might be implemented in future on MacOS}
|
|
|
+ Verify:=true;
|
|
|
+End;
|
|
|
+
|
|
|
+Procedure SetVerify(Verify: Boolean);
|
|
|
+Begin
|
|
|
+ {! Might be implemented in future on MacOS}
|
|
|
+End;
|
|
|
+
|
|
|
+function GetShortName(var p : String) : boolean;
|
|
|
+
|
|
|
+begin
|
|
|
+ { short=long under MacOS}
|
|
|
+ GetShortName:=True;
|
|
|
+end;
|
|
|
+
|
|
|
+function GetLongName(var p : String) : boolean;
|
|
|
+begin
|
|
|
+ { short=long under MacOS}
|
|
|
+ GetLongName:=True;
|
|
|
+end;
|
|
|
+
|
|
|
+{******************************************************************************
|
|
|
+ --- Initialization ---
|
|
|
+******************************************************************************}
|
|
|
+
|
|
|
+End.
|