mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-06-08 04:40:51 +02:00
bd9e93087c
* long namespace by default
* dos.exec implemented
* getenv ('PATH') is now supported
* changed FExpand to global version
* fixed heaplist growth error
* support SysOSFree
* stackcheck was without saveregisters
* fpc can compile itself on netware
682 lines
16 KiB
ObjectPascal
682 lines
16 KiB
ObjectPascal
{
|
|
$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.
|
|
|
|
**********************************************************************}
|
|
|
|
unit dos;
|
|
interface
|
|
|
|
Const
|
|
FileNameLen = 255;
|
|
|
|
Type
|
|
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;
|
|
|
|
{$i dosh.inc}
|
|
|
|
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 ---
|
|
******************************************************************************}
|
|
|
|
{$ifdef HASTHREADVAR}
|
|
threadvar
|
|
{$else HASTHREADVAR}
|
|
var
|
|
{$endif HASTHREADVAR}
|
|
lastdosexitcode : word;
|
|
|
|
const maxargs=256;
|
|
procedure exec(const path : pathstr;const comline : comstr);
|
|
var c : comstr;
|
|
i : integer;
|
|
args : array[0..maxargs] of pchar;
|
|
arg0 : pathstr;
|
|
numargs : integer;
|
|
begin
|
|
//writeln ('dos.exec (',path,',',comline,')');
|
|
arg0 := fexpand (path)+#0;
|
|
args[0] := @arg0[1];
|
|
numargs := 0;
|
|
c:=comline;
|
|
i:=1;
|
|
while i<=length(c) do
|
|
begin
|
|
if c[i]<>' ' then
|
|
begin
|
|
{Commandline argument found. append #0 and set pointer in args }
|
|
inc(numargs);
|
|
args[numargs]:=@c[i];
|
|
while (i<=length(c)) and (c[i]<>' ') do
|
|
inc(i);
|
|
c[i] := #0;
|
|
end;
|
|
inc(i);
|
|
end;
|
|
args[numargs+1] := nil;
|
|
i := spawnvp (P_WAIT,args[0],@args);
|
|
if i >= 0 then
|
|
begin
|
|
doserror := 0;
|
|
lastdosexitcode := i;
|
|
end else
|
|
begin
|
|
doserror := 8; // for now, what about errno ?
|
|
end;
|
|
end;
|
|
|
|
|
|
|
|
function dosexitcode : word;
|
|
begin
|
|
dosexitcode:=lastdosexitcode;
|
|
end;
|
|
|
|
|
|
procedure getcbreak(var breakvalue : boolean);
|
|
begin
|
|
breakvalue := _SetCtrlCharCheckMode (false); { get current setting }
|
|
if breakvalue then
|
|
_SetCtrlCharCheckMode (breakvalue); { and restore old setting }
|
|
end;
|
|
|
|
|
|
procedure setcbreak(breakvalue : boolean);
|
|
begin
|
|
_SetCtrlCharCheckMode (breakvalue);
|
|
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,
|
|
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;
|
|
|
|
|
|
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 (byte(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 (byte(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;
|
|
|
|
{******************************************************************************
|
|
--- 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_name);
|
|
if name = '' then
|
|
name := strpas (PNWDirEnt(EntryP)^.d_nameDOS);
|
|
doserror := 0;
|
|
END ELSE
|
|
BEGIN
|
|
FillChar (f,SIZEOF(f),0);
|
|
doserror := 18;
|
|
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
|
|
BEGIN
|
|
_closedir (PNWDirEnt(f.DirP));
|
|
f.Magic := 0;
|
|
doserror := 18;
|
|
END 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 backslash as slash }
|
|
for i:=1 to length(path) do
|
|
if path[i]='\' then path[i]:='/';
|
|
{ get volume name }
|
|
p1:=pos(':',path);
|
|
if p1>0 then
|
|
begin
|
|
dir:=copy(path,1,p1);
|
|
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 GetShortName(var p : String) : boolean;
|
|
begin
|
|
GetShortName := false;
|
|
end;
|
|
|
|
function GetLongName(var p : String) : boolean;
|
|
begin
|
|
GetLongName := false;
|
|
end;
|
|
|
|
|
|
{$define FPC_FEXPAND_DRIVES}
|
|
{$define FPC_FEXPAND_VOLUMES}
|
|
{$define FPC_FEXPAND_NO_DEFAULT_PATHS}
|
|
{$i fexpand.inc}
|
|
|
|
Function FSearch(path: pathstr; dirlist: string): pathstr;
|
|
var
|
|
i,p1 : longint;
|
|
s : searchrec;
|
|
newdir : pathstr;
|
|
begin
|
|
write ('FSearch ("',path,'","',dirlist,'"');
|
|
{ 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 backslash as slash }
|
|
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: longint) : string;
|
|
begin
|
|
envstr := ''; {is there a netware function to do that ?????}
|
|
ConsolePrintf ('warning: fpc dos.envstr not implemented'#13#10,0);
|
|
end;
|
|
|
|
{ works fine (at least with netware 6.5) }
|
|
Function GetEnv(envvar: string): string;
|
|
var envvar0 : array[0..512] of char;
|
|
p : pchar;
|
|
i,isDosPath,res : longint;
|
|
begin
|
|
if upcase(envvar) = 'PATH' then
|
|
begin // netware does not have search paths in the environment var PATH
|
|
// return it here (needed for the compiler)
|
|
GetEnv := '';
|
|
i := 1;
|
|
res := _NWGetSearchPathElement (i, isdosPath, @envvar0[0]);
|
|
while res = 0 do
|
|
begin
|
|
if GetEnv <> '' then GetEnv := GetEnv + ';';
|
|
GetEnv := GetEnv + envvar0;
|
|
inc (i);
|
|
res := _NWGetSearchPathElement (i, isdosPath, @envvar0[0]);
|
|
end;
|
|
for i := 1 to length(GetEnv) do
|
|
if GetEnv[i] = '\' then
|
|
GetEnv[i] := '/';
|
|
end else
|
|
begin
|
|
strpcopy(envvar0,envvar);
|
|
p := _getenv (envvar0);
|
|
if p = NIL then
|
|
GetEnv := ''
|
|
else
|
|
GetEnv := strpas (p);
|
|
end;
|
|
end;
|
|
|
|
|
|
{******************************************************************************
|
|
--- Not Supported ---
|
|
******************************************************************************}
|
|
|
|
Procedure keep(exitcode : word);
|
|
Begin
|
|
{ simply wait until nlm will be unloaded }
|
|
while true do _delay (60000);
|
|
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.11 2004-08-01 20:02:48 armin
|
|
* changed dir separator from \ to /
|
|
* long namespace by default
|
|
* dos.exec implemented
|
|
* getenv ('PATH') is now supported
|
|
* changed FExpand to global version
|
|
* fixed heaplist growth error
|
|
* support SysOSFree
|
|
* stackcheck was without saveregisters
|
|
* fpc can compile itself on netware
|
|
|
|
Revision 1.10 2004/02/17 17:37:26 daniel
|
|
* Enable threadvars again
|
|
|
|
Revision 1.9 2004/02/16 22:16:59 hajny
|
|
* LastDosExitCode changed back from threadvar temporarily
|
|
|
|
Revision 1.8 2004/02/15 21:34:06 hajny
|
|
* overloaded ExecuteProcess added, EnvStr param changed to longint
|
|
|
|
Revision 1.7 2004/02/09 12:03:16 michael
|
|
+ Switched to single interface in dosh.inc
|
|
|
|
Revision 1.6 2003/03/25 18:17:54 armin
|
|
* support for fcl, support for linking without debug info
|
|
* renamed winsock2 to winsock for win32 compatinility
|
|
* new sockets unit for netware
|
|
* changes for compiler warnings
|
|
|
|
Revision 1.5 2002/09/07 16:01:20 peter
|
|
* old logs removed and tabs fixed
|
|
|
|
}
|
|
|