|
@@ -0,0 +1,857 @@
|
|
|
+{
|
|
|
+ $Id$
|
|
|
+ This file is part of the Free Pascal run time library.
|
|
|
+ Copyright (c) 1999-2000 by the Free Pascal development team.
|
|
|
+
|
|
|
+ Dos unit for BP7 compatible RTL (novell netware)
|
|
|
+
|
|
|
+ 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.
|
|
|
+
|
|
|
+ **********************************************************************}
|
|
|
+
|
|
|
+{ 2000/09/03 armin: first version
|
|
|
+ 2001/03/08 armin: implemented more functions
|
|
|
+ OK: Implemented and tested
|
|
|
+ NI: not implemented
|
|
|
+}
|
|
|
+
|
|
|
+unit dos;
|
|
|
+interface
|
|
|
+
|
|
|
+CONST LFNSupport = FALSE;
|
|
|
+
|
|
|
+Const
|
|
|
+ {Bitmasks for CPU Flags}
|
|
|
+ fcarry = $0001;
|
|
|
+ fparity = $0004;
|
|
|
+ fauxiliary = $0010;
|
|
|
+ fzero = $0040;
|
|
|
+ fsign = $0080;
|
|
|
+ foverflow = $0800;
|
|
|
+
|
|
|
+ {Bitmasks for file attribute}
|
|
|
+ readonly = $01;
|
|
|
+ hidden = $02;
|
|
|
+ sysfile = $04;
|
|
|
+ volumeid = $08;
|
|
|
+ nwexeconly= $08;
|
|
|
+ directory = $10;
|
|
|
+ archive = $20;
|
|
|
+ sharable = $80;
|
|
|
+ anyfile = $3F;
|
|
|
+
|
|
|
+ {File Status}
|
|
|
+ fmclosed = $D7B0;
|
|
|
+ fminput = $D7B1;
|
|
|
+ fmoutput = $D7B2;
|
|
|
+ fminout = $D7B3;
|
|
|
+
|
|
|
+
|
|
|
+Type
|
|
|
+{ Needed for LFN Support }
|
|
|
+ ComStr = String[255];
|
|
|
+ PathStr = String[255];
|
|
|
+ DirStr = String[255];
|
|
|
+ NameStr = String[255];
|
|
|
+ ExtStr = String[255];
|
|
|
+
|
|
|
+{
|
|
|
+ filerec.inc contains the definition of the filerec.
|
|
|
+ textrec.inc contains the definition of the textrec.
|
|
|
+ It is in a separate file to make it available in other units without
|
|
|
+ having to use the DOS unit for it.
|
|
|
+}
|
|
|
+{$i filerec.inc}
|
|
|
+{$i textrec.inc}
|
|
|
+
|
|
|
+ DateTime = packed record
|
|
|
+ Year,
|
|
|
+ Month,
|
|
|
+ Day,
|
|
|
+ Hour,
|
|
|
+ Min,
|
|
|
+ Sec : word;
|
|
|
+ End;
|
|
|
+
|
|
|
+ searchrec = packed record
|
|
|
+ DirP : POINTER; { used for opendir }
|
|
|
+ EntryP: POINTER; { and readdir }
|
|
|
+ Magic : WORD;
|
|
|
+ fill : array[1..11] of byte;
|
|
|
+ attr : byte;
|
|
|
+ time : longint;
|
|
|
+ { reserved : word; not in DJGPP V2 }
|
|
|
+ size : longint;
|
|
|
+ name : string[255]; { NW uses only [12] but more can't hurt }
|
|
|
+ end;
|
|
|
+
|
|
|
+ registers = packed record
|
|
|
+ case i : integer of
|
|
|
+ 0 : (ax,f1,bx,f2,cx,f3,dx,f4,bp,f5,si,f51,di,f6,ds,f7,es,f8,flags,fs,gs : word);
|
|
|
+ 1 : (al,ah,f9,f10,bl,bh,f11,f12,cl,ch,f13,f14,dl,dh : byte);
|
|
|
+ 2 : (eax, ebx, ecx, edx, ebp, esi, edi : longint);
|
|
|
+ end;
|
|
|
+
|
|
|
+
|
|
|
+Var
|
|
|
+ DosError : integer;
|
|
|
+
|
|
|
+
|
|
|
+
|
|
|
+{Info/Date/Time}
|
|
|
+Function DosVersion: Word; {ok}
|
|
|
+Procedure GetDate(var year, month, mday, wday: word); {ok}
|
|
|
+Procedure GetTime(var hour, minute, second, sec100: word); {ok}
|
|
|
+procedure SetDate(year,month,day: word); {ok}
|
|
|
+Procedure SetTime(hour,minute,second,sec100: word); {ok}
|
|
|
+Procedure UnpackTime(p: longint; var t: datetime); {ok}
|
|
|
+Procedure PackTime(var t: datetime; var p: longint); {ok}
|
|
|
+
|
|
|
+{Exec}
|
|
|
+Procedure Exec(const path: pathstr; const comline: comstr); {ni}
|
|
|
+Function DosExitCode: word; {ni}
|
|
|
+
|
|
|
+{Disk}
|
|
|
+{$ifdef Int64}
|
|
|
+ Function DiskFree(drive: byte) : int64; {ok}
|
|
|
+ Function DiskSize(drive: byte) : int64; {ok}
|
|
|
+{$else}
|
|
|
+ Function DiskFree(drive: byte) : longint; {ok}
|
|
|
+ Function DiskSize(drive: byte) : longint; {ok}
|
|
|
+{$endif}
|
|
|
+
|
|
|
+{FincClose has to be called to avoid memory leaks}
|
|
|
+Procedure FindFirst(const path: pathstr; attr: word; {ok}
|
|
|
+ var f: searchRec);
|
|
|
+Procedure FindNext(var f: searchRec); {ok}
|
|
|
+Procedure FindClose(Var f: SearchRec); {ok}
|
|
|
+
|
|
|
+{File}
|
|
|
+Procedure GetFAttr(var f; var attr: word); {ok}
|
|
|
+Procedure GetFTime(var f; var time: longint); {ok}
|
|
|
+Function FSearch(path: pathstr; dirlist: string): pathstr; {untested}
|
|
|
+Function FExpand(const path: pathstr): pathstr; {untested}
|
|
|
+Procedure FSplit(path: pathstr; var dir: dirstr; var name: {untested}
|
|
|
+ namestr; var ext: extstr);
|
|
|
+
|
|
|
+{Environment}
|
|
|
+Function EnvCount: longint; {ni}
|
|
|
+Function EnvStr(index: integer): string; {ni}
|
|
|
+Function GetEnv(envvar: string): string; {ok}
|
|
|
+
|
|
|
+{Misc}
|
|
|
+Procedure SetFAttr(var f; attr: word); {ni}
|
|
|
+Procedure SetFTime(var f; time: longint); {ni}
|
|
|
+Procedure GetCBreak(var breakvalue: boolean); {ni}
|
|
|
+Procedure SetCBreak(breakvalue: boolean); {ni}
|
|
|
+Procedure GetVerify(var verify: boolean); {ni}
|
|
|
+Procedure SetVerify(verify: boolean); {ni}
|
|
|
+
|
|
|
+{Do Nothing Functions}
|
|
|
+Procedure SwapVectors; {ni}
|
|
|
+Procedure GetIntVec(intno: byte; var vector: pointer); {ni}
|
|
|
+Procedure SetIntVec(intno: byte; vector: pointer); {ni}
|
|
|
+Procedure Keep(exitcode: word); {ni}
|
|
|
+
|
|
|
+Procedure Intr(intno: byte; var regs: registers); {ni}
|
|
|
+Procedure MSDos(var regs: registers); {ni}
|
|
|
+
|
|
|
+
|
|
|
+implementation
|
|
|
+
|
|
|
+uses
|
|
|
+ strings;
|
|
|
+
|
|
|
+{$ASMMODE ATT}
|
|
|
+{$I nwsys.inc }
|
|
|
+
|
|
|
+{*****************************************************************************
|
|
|
+ --- Info / Date / Time ---
|
|
|
+******************************************************************************}
|
|
|
+{$PACKRECORDS 4}
|
|
|
+
|
|
|
+
|
|
|
+function dosversion : word;
|
|
|
+VAR F : FILE_SERV_INFO;
|
|
|
+begin
|
|
|
+ IF GetServerInformation(SIZEOF(F),@F) = 0 THEN
|
|
|
+ dosversion := WORD (F.netwareVersion) SHL 8 + F.netwareSubVersion;
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+procedure getdate(var year,month,mday,wday : word);
|
|
|
+VAR N : NWdateAndTime;
|
|
|
+begin
|
|
|
+ GetFileServerDateAndTime (N);
|
|
|
+ wday:=N.DayOfWeek;
|
|
|
+ year:=1900 + N.Year;
|
|
|
+ month:=N.Month;
|
|
|
+ mday:=N.Day;
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+procedure setdate(year,month,day : word);
|
|
|
+VAR N : NWdateAndTime;
|
|
|
+begin
|
|
|
+ GetFileServerDateAndTime (N);
|
|
|
+ SetFileServerDateAndTime(year,month,day,N.Hour,N.Minute,N.Second);
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+procedure gettime(var hour,minute,second,sec100 : word);
|
|
|
+VAR N : NWdateAndTime;
|
|
|
+begin
|
|
|
+ GetFileServerDateAndTime (N);
|
|
|
+ hour := N.Hour;
|
|
|
+ Minute:= N.Minute;
|
|
|
+ Second := N.Second;
|
|
|
+ sec100 := 0;
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+procedure settime(hour,minute,second,sec100 : word);
|
|
|
+VAR N : NWdateAndTime;
|
|
|
+begin
|
|
|
+ GetFileServerDateAndTime (N);
|
|
|
+ SetFileServerDateAndTime(N.year,N.month,N.day,hour,minute,second);
|
|
|
+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
|
|
|
+ with t do
|
|
|
+ begin
|
|
|
+ sec:=(p and 31) shl 1;
|
|
|
+ min:=(p shr 5) and 63;
|
|
|
+ hour:=(p shr 11) and 31;
|
|
|
+ day:=(p shr 16) and 31;
|
|
|
+ month:=(p shr 21) and 15;
|
|
|
+ year:=(p shr 25)+1980;
|
|
|
+ end;
|
|
|
+End;
|
|
|
+
|
|
|
+
|
|
|
+{******************************************************************************
|
|
|
+ --- Exec ---
|
|
|
+******************************************************************************}
|
|
|
+
|
|
|
+var
|
|
|
+ lastdosexitcode : word;
|
|
|
+
|
|
|
+procedure exec(const path : pathstr;const comline : comstr);
|
|
|
+begin
|
|
|
+ ConsolePrintf ('warning: fpc dos.exec not implemented'#13#10,0);
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+function dosexitcode : word;
|
|
|
+begin
|
|
|
+ dosexitcode:=lastdosexitcode;
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+procedure getcbreak(var breakvalue : boolean);
|
|
|
+begin
|
|
|
+ breakvalue := true;
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+procedure setcbreak(breakvalue : boolean);
|
|
|
+begin
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+procedure getverify(var verify : boolean);
|
|
|
+begin
|
|
|
+ verify := true;
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+procedure setverify(verify : boolean);
|
|
|
+begin
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+{******************************************************************************
|
|
|
+ --- Disk ---
|
|
|
+******************************************************************************}
|
|
|
+
|
|
|
+function getvolnum (drive : byte) : longint;
|
|
|
+var dir : STRING[255];
|
|
|
+ P,PS: BYTE;
|
|
|
+ V : LONGINT;
|
|
|
+begin
|
|
|
+ if drive = 0 then
|
|
|
+ begin // get volume name from current directory (i.e. SERVER-NAME/VOL2:TEST)
|
|
|
+ getdir (0,dir);
|
|
|
+ p := pos (':', dir);
|
|
|
+ if p = 0 then
|
|
|
+ begin
|
|
|
+ getvolnum := -1;
|
|
|
+ exit;
|
|
|
+ end;
|
|
|
+ byte (dir[0]) := p-1;
|
|
|
+ dir[p] := #0;
|
|
|
+ PS := pos ('/', dir);
|
|
|
+ INC (PS);
|
|
|
+ if _GetVolumeNumber (@dir[PS], V) <> 0 then
|
|
|
+ getvolnum := -1
|
|
|
+ else
|
|
|
+ getvolnum := V;
|
|
|
+ end else
|
|
|
+ getvolnum := drive-1;
|
|
|
+end;
|
|
|
+
|
|
|
+{$ifdef Int64}
|
|
|
+
|
|
|
+function diskfree(drive : byte) : int64;
|
|
|
+VAR Buf : ARRAY [0..255] OF CHAR;
|
|
|
+ TotalBlocks : WORD;
|
|
|
+ SectorsPerBlock : WORD;
|
|
|
+ availableBlocks : WORD;
|
|
|
+ totalDirectorySlots : WORD;
|
|
|
+ availableDirSlots : WORD;
|
|
|
+ volumeisRemovable : WORD;
|
|
|
+ volumeNumber : LONGINT;
|
|
|
+begin
|
|
|
+ volumeNumber := getvolnum (drive);
|
|
|
+ if volumeNumber >= 0 then
|
|
|
+ begin
|
|
|
+ {i think thats not the right function but for others i need a connection handle}
|
|
|
+ if _GetVolumeInfoWithNumber (volumeNumber,@Buf,
|
|
|
+ TotalBlocks,
|
|
|
+ SectorsPerBlock,
|
|
|
+ availableBlocks,
|
|
|
+ totalDirectorySlots,
|
|
|
+ availableDirSlots,
|
|
|
+ volumeisRemovable) = 0 THEN
|
|
|
+ begin
|
|
|
+ diskfree := int64 (availableBlocks) * int64 (SectorsPerBlock) * 512;
|
|
|
+ end else
|
|
|
+ diskfree := 0;
|
|
|
+ end else
|
|
|
+ diskfree := 0;
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+function disksize(drive : byte) : int64;
|
|
|
+VAR Buf : ARRAY [0..255] OF CHAR;
|
|
|
+ TotalBlocks : WORD;
|
|
|
+ SectorsPerBlock : WORD;
|
|
|
+ availableBlocks : WORD;
|
|
|
+ totalDirectorySlots : WORD;
|
|
|
+ availableDirSlots : WORD;
|
|
|
+ volumeisRemovable : WORD;
|
|
|
+ volumeNumber : LONGINT;
|
|
|
+begin
|
|
|
+ volumeNumber := getvolnum (drive);
|
|
|
+ if volumeNumber >= 0 then
|
|
|
+ begin
|
|
|
+ {i think thats not the right function but for others i need a connection handle}
|
|
|
+ if _GetVolumeInfoWithNumber (volumeNumber,@Buf,
|
|
|
+ TotalBlocks,
|
|
|
+ SectorsPerBlock,
|
|
|
+ availableBlocks,
|
|
|
+ totalDirectorySlots,
|
|
|
+ availableDirSlots,
|
|
|
+ volumeisRemovable) = 0 THEN
|
|
|
+ begin
|
|
|
+ disksize := int64 (TotalBlocks) * int64 (SectorsPerBlock) * 512;
|
|
|
+ end else
|
|
|
+ disksize := 0;
|
|
|
+ end else
|
|
|
+ disksize := 0;
|
|
|
+end;
|
|
|
+{$else}
|
|
|
+
|
|
|
+function diskfree(drive : byte) : longint;
|
|
|
+VAR Buf : ARRAY [0..255] OF CHAR;
|
|
|
+ TotalBlocks : WORD;
|
|
|
+ SectorsPerBlock : WORD;
|
|
|
+ availableBlocks : WORD;
|
|
|
+ totalDirectorySlots : WORD;
|
|
|
+ availableDirSlots : WORD;
|
|
|
+ volumeisRemovable : WORD;
|
|
|
+ volumeNumber : LONGINT;
|
|
|
+begin
|
|
|
+ volumeNumber := getvolnum (drive);
|
|
|
+ if volumeNumber >= 0 then
|
|
|
+ begin
|
|
|
+ {i think thats not the right function but for others i need a connection handle}
|
|
|
+ if _GetVolumeInfoWithNumber (volumeNumber,@Buf,
|
|
|
+ TotalBlocks,
|
|
|
+ SectorsPerBlock,
|
|
|
+ availableBlocks,
|
|
|
+ totalDirectorySlots,
|
|
|
+ availableDirSlots,
|
|
|
+ volumeisRemovable) = 0 THEN
|
|
|
+ begin
|
|
|
+ diskfree := availableBlocks * SectorsPerBlock * 512;
|
|
|
+ end else
|
|
|
+ diskfree := 0;
|
|
|
+ end else
|
|
|
+ diskfree := 0;
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+function disksize(drive : byte) : longint;
|
|
|
+VAR Buf : ARRAY [0..255] OF CHAR;
|
|
|
+ TotalBlocks : WORD;
|
|
|
+ SectorsPerBlock : WORD;
|
|
|
+ availableBlocks : WORD;
|
|
|
+ totalDirectorySlots : WORD;
|
|
|
+ availableDirSlots : WORD;
|
|
|
+ volumeisRemovable : WORD;
|
|
|
+ volumeNumber : LONGINT;
|
|
|
+begin
|
|
|
+ volumeNumber := getvolnum (drive);
|
|
|
+ if volumeNumber >= 0 then
|
|
|
+ begin
|
|
|
+ {i think thats not the right function but for others i need a connection handle}
|
|
|
+ if _GetVolumeInfoWithNumber (volumeNumber,@Buf,
|
|
|
+ TotalBlocks,
|
|
|
+ SectorsPerBlock,
|
|
|
+ availableBlocks,
|
|
|
+ totalDirectorySlots,
|
|
|
+ availableDirSlots,
|
|
|
+ volumeisRemovable) = 0 THEN
|
|
|
+ begin
|
|
|
+ disksize := TotalBlocks * SectorsPerBlock * 512;
|
|
|
+ end else
|
|
|
+ disksize := 0;
|
|
|
+ end else
|
|
|
+ disksize := 0;
|
|
|
+end;
|
|
|
+
|
|
|
+{$endif}
|
|
|
+
|
|
|
+
|
|
|
+{******************************************************************************
|
|
|
+ --- Findfirst FindNext ---
|
|
|
+******************************************************************************}
|
|
|
+
|
|
|
+
|
|
|
+PROCEDURE find_setfields (VAR f : searchRec);
|
|
|
+BEGIN
|
|
|
+ WITH F DO
|
|
|
+ BEGIN
|
|
|
+ IF Magic = $AD01 THEN
|
|
|
+ BEGIN
|
|
|
+ attr := WORD (PNWDirEnt(EntryP)^.d_attr); // lowest 16 bit -> same as dos
|
|
|
+ time := PNWDirEnt(EntryP)^.d_time + (LONGINT (PNWDirEnt(EntryP)^.d_date) SHL 16);
|
|
|
+ size := PNWDirEnt(EntryP)^.d_size;
|
|
|
+ name := strpas (PNWDirEnt(EntryP)^.d_nameDOS);
|
|
|
+ END ELSE
|
|
|
+ BEGIN
|
|
|
+ FillChar (f,SIZEOF(f),0);
|
|
|
+ END;
|
|
|
+ END;
|
|
|
+END;
|
|
|
+
|
|
|
+
|
|
|
+procedure findfirst(const path : pathstr;attr : word;var f : searchRec);
|
|
|
+var
|
|
|
+ path0 : array[0..256] of char;
|
|
|
+begin
|
|
|
+ IF path = '' then
|
|
|
+ begin
|
|
|
+ doserror := 18;
|
|
|
+ exit;
|
|
|
+ end;
|
|
|
+ strpcopy(path0,path);
|
|
|
+ PNWDirEnt(f.DirP) := _opendir (path0);
|
|
|
+ IF f.DirP = NIL THEN
|
|
|
+ doserror := 18
|
|
|
+ ELSE
|
|
|
+ BEGIN
|
|
|
+ IF attr <> anyfile THEN
|
|
|
+ _SetReaddirAttribute (PNWDirEnt(f.DirP), attr);
|
|
|
+ F.Magic := $AD01;
|
|
|
+ PNWDirEnt(f.EntryP) := _readdir (PNWDirEnt(f.DirP));
|
|
|
+ IF F.EntryP = NIL THEN
|
|
|
+ doserror := 18
|
|
|
+ ELSE
|
|
|
+ find_setfields (f);
|
|
|
+ END;
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+procedure findnext(var f : searchRec);
|
|
|
+begin
|
|
|
+ IF F.Magic <> $AD01 THEN
|
|
|
+ BEGIN
|
|
|
+ doserror := 18;
|
|
|
+ EXIT;
|
|
|
+ END;
|
|
|
+ doserror:=0;
|
|
|
+ PNWDirEnt(f.EntryP) := _readdir (PNWDirEnt(f.DirP));
|
|
|
+ IF F.EntryP = NIL THEN
|
|
|
+ doserror := 18
|
|
|
+ ELSE
|
|
|
+ find_setfields (f);
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+Procedure FindClose(Var f: SearchRec);
|
|
|
+begin
|
|
|
+ IF F.Magic <> $AD01 THEN
|
|
|
+ BEGIN
|
|
|
+ doserror := 18;
|
|
|
+ EXIT;
|
|
|
+ END;
|
|
|
+ doserror:=0;
|
|
|
+ _closedir (PNWDirEnt(f.DirP));
|
|
|
+ f.Magic := 0;
|
|
|
+ f.DirP := NIL;
|
|
|
+ f.EntryP := NIL;
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+procedure swapvectors;
|
|
|
+begin
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+{******************************************************************************
|
|
|
+ --- File ---
|
|
|
+******************************************************************************}
|
|
|
+
|
|
|
+procedure fsplit(path : pathstr;var dir : dirstr;var name : namestr;var ext : extstr);
|
|
|
+var
|
|
|
+ dotpos,p1,i : longint;
|
|
|
+begin
|
|
|
+ { allow slash as backslash }
|
|
|
+ for i:=1 to length(path) do
|
|
|
+ if path[i]='/' then path[i]:='\';
|
|
|
+ { get drive name }
|
|
|
+ p1:=pos(':',path);
|
|
|
+ if p1>0 then
|
|
|
+ begin
|
|
|
+ dir:=path[1]+':';
|
|
|
+ delete(path,1,p1);
|
|
|
+ end
|
|
|
+ else
|
|
|
+ dir:='';
|
|
|
+ { split the path and the name, there are no more path informtions }
|
|
|
+ { if path contains no backslashes }
|
|
|
+ while true do
|
|
|
+ begin
|
|
|
+ p1:=pos('\',path);
|
|
|
+ if p1=0 then
|
|
|
+ break;
|
|
|
+ dir:=dir+copy(path,1,p1);
|
|
|
+ delete(path,1,p1);
|
|
|
+ end;
|
|
|
+ { try to find out a extension }
|
|
|
+ if LFNSupport then
|
|
|
+ begin
|
|
|
+ Ext:='';
|
|
|
+ i:=Length(Path);
|
|
|
+ DotPos:=256;
|
|
|
+ While (i>0) Do
|
|
|
+ Begin
|
|
|
+ If (Path[i]='.') Then
|
|
|
+ begin
|
|
|
+ DotPos:=i;
|
|
|
+ break;
|
|
|
+ end;
|
|
|
+ Dec(i);
|
|
|
+ end;
|
|
|
+ Ext:=Copy(Path,DotPos,255);
|
|
|
+ Name:=Copy(Path,1,DotPos - 1);
|
|
|
+ end
|
|
|
+ else
|
|
|
+ begin
|
|
|
+ p1:=pos('.',path);
|
|
|
+ if p1>0 then
|
|
|
+ begin
|
|
|
+ ext:=copy(path,p1,4);
|
|
|
+ delete(path,p1,length(path)-p1+1);
|
|
|
+ end
|
|
|
+ else
|
|
|
+ ext:='';
|
|
|
+ name:=path;
|
|
|
+ end;
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+function fexpand(const path : pathstr) : pathstr;
|
|
|
+var
|
|
|
+ s,pa : pathstr;
|
|
|
+ i,j : longint;
|
|
|
+begin
|
|
|
+ getdir(0,s);
|
|
|
+ i:=ioresult;
|
|
|
+ if LFNSupport then
|
|
|
+ begin
|
|
|
+ pa:=path;
|
|
|
+ end
|
|
|
+ else
|
|
|
+ if FileNameCaseSensitive then
|
|
|
+ pa:=path
|
|
|
+ else
|
|
|
+ pa:=upcase(path);
|
|
|
+
|
|
|
+ { allow slash as backslash }
|
|
|
+ for i:=1 to length(pa) do
|
|
|
+ if pa[i]='/' then
|
|
|
+ pa[i]:='\';
|
|
|
+
|
|
|
+ if (length(pa)>1) and (pa[2]=':') and (pa[1] in ['A'..'Z','a'..'z']) then
|
|
|
+ begin
|
|
|
+ { Always uppercase driveletter }
|
|
|
+ if (pa[1] in ['a'..'z']) then
|
|
|
+ pa[1]:=Chr(Ord(Pa[1])-32);
|
|
|
+ { we must get the right directory }
|
|
|
+ getdir(ord(pa[1])-ord('A')+1,s);
|
|
|
+ i:=ioresult;
|
|
|
+ if (ord(pa[0])>2) and (pa[3]<>'\') then
|
|
|
+ if pa[1]=s[1] then
|
|
|
+ begin
|
|
|
+ { remove ending slash if it already exists }
|
|
|
+ if s[length(s)]='\' then
|
|
|
+ dec(s[0]);
|
|
|
+ pa:=s+'\'+copy (pa,3,length(pa));
|
|
|
+ end
|
|
|
+ else
|
|
|
+ pa:=pa[1]+':\'+copy (pa,3,length(pa))
|
|
|
+ end
|
|
|
+ else
|
|
|
+ if pa[1]='\' then
|
|
|
+ begin
|
|
|
+ { Do not touch Network drive names if LFNSupport is true }
|
|
|
+ if not ((Length(pa)>1) and (pa[2]='\') and LFNSupport) then
|
|
|
+ pa:=s[1]+':'+pa;
|
|
|
+ end
|
|
|
+ else if s[0]=#3 then
|
|
|
+ pa:=s+pa
|
|
|
+ else
|
|
|
+ pa:=s+'\'+pa;
|
|
|
+
|
|
|
+{ Turbo Pascal gives current dir on drive if only drive given as parameter! }
|
|
|
+if length(pa) = 2 then
|
|
|
+ begin
|
|
|
+ getdir(byte(pa[1])-64,s);
|
|
|
+ pa := s;
|
|
|
+ end;
|
|
|
+
|
|
|
+{First remove all references to '\.\'}
|
|
|
+ while pos ('\.\',pa)<>0 do
|
|
|
+ delete (pa,pos('\.\',pa),2);
|
|
|
+{Now remove also all references to '\..\' + of course previous dirs..}
|
|
|
+ repeat
|
|
|
+ i:=pos('\..\',pa);
|
|
|
+ if i<>0 then
|
|
|
+ begin
|
|
|
+ j:=i-1;
|
|
|
+ while (j>1) and (pa[j]<>'\') do
|
|
|
+ dec (j);
|
|
|
+ if pa[j+1] = ':' then j := 3;
|
|
|
+ delete (pa,j,i-j+3);
|
|
|
+ end;
|
|
|
+ until i=0;
|
|
|
+
|
|
|
+ { Turbo Pascal gets rid of a \.. at the end of the path }
|
|
|
+ { Now remove also any reference to '\..' at end of line
|
|
|
+ + of course previous dir.. }
|
|
|
+ i:=pos('\..',pa);
|
|
|
+ if i<>0 then
|
|
|
+ begin
|
|
|
+ if i = length(pa) - 2 then
|
|
|
+ begin
|
|
|
+ j:=i-1;
|
|
|
+ while (j>1) and (pa[j]<>'\') do
|
|
|
+ dec (j);
|
|
|
+ delete (pa,j,i-j+3);
|
|
|
+ end;
|
|
|
+ pa := pa + '\';
|
|
|
+ end;
|
|
|
+ { Remove End . and \}
|
|
|
+ if (length(pa)>0) and (pa[length(pa)]='.') then
|
|
|
+ dec(byte(pa[0]));
|
|
|
+ { if only the drive + a '\' is left then the '\' should be left to prevtn the program
|
|
|
+ accessing the current directory on the drive rather than the root!}
|
|
|
+ { if the last char of path = '\' then leave it in as this is what TP does! }
|
|
|
+ if ((length(pa)>3) and (pa[length(pa)]='\')) and (path[length(path)] <> '\') then
|
|
|
+ dec(byte(pa[0]));
|
|
|
+ { if only a drive is given in path then there should be a '\' at the
|
|
|
+ end of the string given back }
|
|
|
+ if length(pa) = 2 then pa := pa + '\';
|
|
|
+ fexpand:=pa;
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+Function FSearch(path: pathstr; dirlist: string): pathstr;
|
|
|
+var
|
|
|
+ i,p1 : longint;
|
|
|
+ s : searchrec;
|
|
|
+ newdir : pathstr;
|
|
|
+begin
|
|
|
+{ check if the file specified exists }
|
|
|
+ findfirst(path,anyfile,s);
|
|
|
+ if doserror=0 then
|
|
|
+ begin
|
|
|
+ findclose(s);
|
|
|
+ fsearch:=path;
|
|
|
+ exit;
|
|
|
+ end;
|
|
|
+{ No wildcards allowed in these things }
|
|
|
+ if (pos('?',path)<>0) or (pos('*',path)<>0) then
|
|
|
+ fsearch:=''
|
|
|
+ else
|
|
|
+ begin
|
|
|
+ { allow slash as backslash }
|
|
|
+ for i:=1 to length(dirlist) do
|
|
|
+ if dirlist[i]='/' then dirlist[i]:='\';
|
|
|
+ repeat
|
|
|
+ p1:=pos(';',dirlist);
|
|
|
+ if p1<>0 then
|
|
|
+ begin
|
|
|
+ newdir:=copy(dirlist,1,p1-1);
|
|
|
+ delete(dirlist,1,p1);
|
|
|
+ end
|
|
|
+ else
|
|
|
+ begin
|
|
|
+ newdir:=dirlist;
|
|
|
+ dirlist:='';
|
|
|
+ end;
|
|
|
+ if (newdir<>'') and (not (newdir[length(newdir)] in ['\',':'])) then
|
|
|
+ newdir:=newdir+'\';
|
|
|
+ findfirst(newdir+path,anyfile,s);
|
|
|
+ if doserror=0 then
|
|
|
+ newdir:=newdir+path
|
|
|
+ else
|
|
|
+ newdir:='';
|
|
|
+ until (dirlist='') or (newdir<>'');
|
|
|
+ fsearch:=newdir;
|
|
|
+ end;
|
|
|
+ findclose(s);
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+{******************************************************************************
|
|
|
+ --- Get/Set File Time,Attr ---
|
|
|
+******************************************************************************}
|
|
|
+
|
|
|
+procedure getftime(var f;var time : longint);
|
|
|
+VAR StatBuf : NWStatBufT;
|
|
|
+ T : DateTime;
|
|
|
+ DosDate,
|
|
|
+ DosTime : WORD;
|
|
|
+begin
|
|
|
+ IF _fstat (FileRec (f).Handle, StatBuf) = 0 THEN
|
|
|
+ BEGIN
|
|
|
+ _ConvertTimeToDos (StatBuf.st_mtime, DosDate, DosTime);
|
|
|
+ time := DosTime + (LONGINT (DosDate) SHL 16);
|
|
|
+ END ELSE
|
|
|
+ time := 0;
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+procedure setftime(var f;time : longint);
|
|
|
+begin
|
|
|
+ {is there a netware function to do that ?????}
|
|
|
+ ConsolePrintf ('warning: fpc dos.setftime not implemented'#13#10,0);
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+procedure getfattr(var f;var attr : word);
|
|
|
+VAR StatBuf : NWStatBufT;
|
|
|
+begin
|
|
|
+ IF _fstat (FileRec (f).Handle, StatBuf) = 0 THEN
|
|
|
+ BEGIN
|
|
|
+ attr := word (StatBuf.st_attr);
|
|
|
+ END ELSE
|
|
|
+ attr := 0;
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+procedure setfattr(var f;attr : word);
|
|
|
+begin
|
|
|
+ {is there a netware function to do that ?????}
|
|
|
+ ConsolePrintf ('warning: fpc dos.setfattr not implemented'#13#10,0);
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+{******************************************************************************
|
|
|
+ --- Environment ---
|
|
|
+******************************************************************************}
|
|
|
+
|
|
|
+function envcount : longint;
|
|
|
+begin
|
|
|
+ envcount := 0; {is there a netware function to do that ?????}
|
|
|
+ ConsolePrintf ('warning: fpc dos.envcount not implemented'#13#10,0);
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+function envstr(index : integer) : string;
|
|
|
+begin
|
|
|
+ envstr := ''; {is there a netware function to do that ?????}
|
|
|
+ ConsolePrintf ('warning: fpc dos.envstr not implemented'#13#10,0);
|
|
|
+end;
|
|
|
+
|
|
|
+{ the function exists in clib but i dont know how to set environment vars.
|
|
|
+ may be it's only a dummy in clib }
|
|
|
+Function GetEnv(envvar: string): string;
|
|
|
+var
|
|
|
+ envvar0 : array[0..256] of char;
|
|
|
+ p : pchar;
|
|
|
+begin
|
|
|
+ strpcopy(envvar0,envvar);
|
|
|
+ p := _getenv (envvar0);
|
|
|
+ if p = NIL then
|
|
|
+ GetEnv := ''
|
|
|
+ else
|
|
|
+ GetEnv := strpas (p);
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+{******************************************************************************
|
|
|
+ --- Not Supported ---
|
|
|
+******************************************************************************}
|
|
|
+
|
|
|
+Procedure keep(exitcode : word);
|
|
|
+Begin
|
|
|
+ { no netware equivalent }
|
|
|
+End;
|
|
|
+
|
|
|
+Procedure getintvec(intno : byte;var vector : pointer);
|
|
|
+Begin
|
|
|
+ { no netware equivalent }
|
|
|
+End;
|
|
|
+
|
|
|
+Procedure setintvec(intno : byte;vector : pointer);
|
|
|
+Begin
|
|
|
+ { no netware equivalent }
|
|
|
+End;
|
|
|
+
|
|
|
+procedure intr(intno : byte;var regs : registers);
|
|
|
+begin
|
|
|
+ { no netware equivalent }
|
|
|
+end;
|
|
|
+
|
|
|
+procedure msdos(var regs : registers);
|
|
|
+begin
|
|
|
+ { no netware equivalent }
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+end.
|
|
|
+{
|
|
|
+ $Log$
|
|
|
+ Revision 1.1 2001-04-11 14:14:12 florian
|
|
|
+ * initial commit, thanks to Armin Diehl (diehl@nordrhein)
|
|
|
+
|
|
|
+
|
|
|
+}
|