paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-20 21:09:24 +02:00
Code Issues Packages Projects Releases Wiki Activity

* initial commit, thanks to Armin Diehl (diehl@nordrhein)

Browse Source
This commit is contained in:
florian 2001-04-11 14:14:12 +00:00
parent b669be6c60
commit 3143b484c4
6 changed files with 2436 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

857
rtl/netware/dos.pp Normal file
View File

@ -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)
}

138
rtl/netware/errno.inc Normal file
View File

@ -0,0 +1,138 @@
{ -------------------------- Base POSIX-mandated constants --------------- }
{ no such file or directory }
const
SYS_ENOENT = 1; // arg list too big
SYS_E2BIG = 2; // arg list too big
SYS_ENOEXEC = 3; // exec format error
SYS_EBADF = 4; // bad file number
SYS_ENOMEM = 5; // not enough memory
SYS_EACCES = 6; // permission denied
SYS_EEXIST = 7; // file exists
SYS_EXDEV = 8; // cross-device link
SYS_EINVAL = 9; // invalid argument
SYS_ENFILE = 10; // file table overflow
SYS_EMFILE = 11; // too many open files
SYS_ENOSPC = 12; // no space left on device
SYS_EDOM = 13; // argument too large
SYS_ERANGE = 14; // result too large
SYS_EDEADLK = 15; // resource deadlock would occur
{ -------------------------- Miscellaneous NLM Library constants --------- }
SYS_EINUSE = 16; // resource(s) in use
SYS_ESERVER = 17; // server error (memory out, I/O error, etc.)
SYS_ENOSERVR = 18; // no server (queue server, file server, etc.)
SYS_EWRNGKND = 19; // wrong kind--an operation is being...
// ...attempted on the wrong kind of object
SYS_ETRNREST = 20; // transaction restarted
SYS_ERESOURCE = 21; // resources unavailable (maybe permanently)
SYS_EBADHNDL = 22; // bad non-file handle (screen, semaphore, etc)
SYS_ENO_SCRNS = 23; // screen I/O attempted when no screens
{ -------------------------- Additional POSIX / traditional UNIX constants }
SYS_EAGAIN = 24; // resource temporarily unavailable
SYS_ENXIO = 25; // no such device or address
SYS_EBADMSG = 26; // not a data message
SYS_EFAULT = 27; // bad address
SYS_EIO = 28; // physical I/O error
SYS_ENODATA = 29; // no data
SYS_ENOSTRMS = 30; // streams not available
{ Berkeley sockets constants ------------------ }
SYS_EPROTO = 31; // fatal protocol error
SYS_EPIPE = 32; // broken pipe
SYS_ESPIPE = 33; // illegal seek
{ Non-blocking and interrupt I/O constants ---- }
SYS_ETIME = 34; // ioctl acknowledge timeout
{ operation would block }
SYS_EWOULDBLOCK=35; // operation would block
SYS_EINPROGRESS=36; // operation now in progress
SYS_EALREADY = 37; // operation already in progress
{ IPC network argument constants -------------- }
SYS_ENOTSOCK = 38; // socket operation on non-socket
SYS_EDESTADDRREQ=39; // destination address required
SYS_EMSGSIZE = 40; // message too long
SYS_EPROTOTYPE= 41; // protocol wrong type for socket
SYS_ENOPROTOOPT=42; // protocol not available
SYS_EPROTONOSUPPORT = 43; // protocol not supported
SYS_ESOCKTNOSUPPORT = 44; // socket type not supported
SYS_EOPNOTSUPP = 45; // operation not supported on socket
SYS_EPFNOSUPPORT = 46; // protocol family not supported
SYS_EAFNOSUPPORT = 47; // address family unsupported by protocol family
SYS_EADDRINUSE = 48; // address already in use
SYS_EADDRNOTAVAIL = 49; // can't assign requested address
{ Operational constants ----------------------- }
SYS_ENETDOWN = 50; // Network is down
{ network is unreachable }
SYS_ENETUNREACH = 51;
{ network dropped connection on reset }
SYS_ENETRESET = 52;
{ software caused connection abort }
SYS_ECONNABORTED = 53;
{ connection reset by peer }
SYS_ECONNRESET = 54;
{ no buffer space available }
SYS_ENOBUFS = 55;
{ socket is already connected }
SYS_EISCONN = 56;
{ socket is not connected }
SYS_ENOTCONN = 57;
{ can't send after socket shutdown }
SYS_ESHUTDOWN = 58;
{ too many references: can't splice }
SYS_ETOOMANYREFS = 59;
{ connection timed out }
SYS_ETIMEDOUT = 60;
{ connection refused }
SYS_ECONNREFUSED = 61;
{ -------------------------- Additional POSIX-mandated constants --------- }
{ resource busy }
SYS_EBUSY = 62;
{ interrupted function call }
SYS_EINTR = 63;
{ is a directory }
SYS_EISDIR = 64;
{ filename too long }
SYS_ENAMETOOLONG = 65;
{ function not implemented }
SYS_ENOSYS = 66;
{ not a directory }
SYS_ENOTDIR = 67;
{ directory not empty }
SYS_ENOTEMPTY = 68;
{ operation not permitted }
SYS_EPERM = 69;
{ no child process }
SYS_ECHILD = 70;
{ file too large }
SYS_EFBIG = 71;
{ too many links }
SYS_EMLINK = 72;
SYS_ELOOP = SYS_EMLINK;
{ no such device }
SYS_ENODEV = 73;
{ no locks available }
SYS_ENOLCK = 74;
{ inappropriate I/O control operation }
SYS_ENOTTY = 75;
{ inappropriate operation for file type }
SYS_EFTYPE = SYS_ENOTTY;
{ read-only file system }
SYS_EROFS = 76;
{ no such process }
SYS_ESRCH = 77;
{ operation was cancelled }
SYS_ECANCELED = 78;
{ this optional functionality not supported }
SYS_ENOTSUP = 79;
{ -------------------------- CLib-implementation-specific constants ------ }
SYS_ECANCELLED = SYS_ECANCELED;
{ anomaly in NLM data structure }
SYS_ENLMDATA = 100;
{ illegal character sequence in multibyte }
SYS_EILSEQ = 101;
{ internal library inconsistency }
SYS_EINCONSIS = 102;
{ DOS-text file inconsistency--no newline... }
SYS_EDOSTEXTEOL = 103;
{ ...after carriage return }
{ object doesn't exist }
SYS_ENONEXTANT = 104;
SYS_ENOCONTEXT = 105; // no thread library context present
SYS_ELASTERR = SYS_ENOCONTEXT;

125
rtl/netware/nwpre.pp Normal file
View File

@ -0,0 +1,125 @@
unit nwpre;
interface
// AD 02.09.2000: Dont know why its not working with kNLMInfo...
// It always abends in TerminateNLM, so i am using the old style
{$DEFINE OldPrelude}
FUNCTION _Prelude (NLMHandle : LONGINT;
initErrorScreenID : LONGINT;
cmdLineP : PCHAR;
loadDirectoryPath : PCHAR;
uninitializedDataLength : LONGINT;
NLMFileHandle : LONGINT;
readRoutineP : POINTER;
customDataOffset : LONGINT;
customDataSize : LONGINT) : LONGINT; CDECL;
implementation
FUNCTION _TerminateNLM (NLMInformation : POINTER; threadID, status : LONGINT) : LONGINT; CDECL; EXTERNAL;
FUNCTION _SetupArgV_411 (MainProc : POINTER) : LONGINT; CDECL; EXTERNAL;
FUNCTION _StartNLM (NLMHandle : LONGINT;
initErrorScreenID : LONGINT;
cmdLineP : PCHAR;
loadDirectoryPath : PCHAR;
uninitializedDataLength : LONGINT;
NLMFileHandle : LONGINT;
readRoutineP : POINTER;
customDataOffset : LONGINT;
customDataSize : LONGINT;
NLMInformation : POINTER;
userStartFunc : POINTER) : LONGINT; CDECL; EXTERNAL;
//PROCEDURE _exit (x : LONGINT); CDECL; EXTERNAL;
(*****************************************************************************)
CONST TRADINIONAL_NLM_INFO_SIGNATURE = 0;
TRADINIONAL_FLAVOR = 0;
TRADINIONAL_VERSION = 0;
LIBERTY_VERSION = 1;
TERMINATE_BY_EXTERNAL_THREAD = 0;
TERMINATE_BY_UNLOAD = 5;
{$IFDEF OldPrelude}
CONST NLMID : LONGINT = 0;
{$ELSE}
TYPE
kNLMInfoT =
PACKED RECORD
Signature : ARRAY [0..3] OF CHAR; // LONG
Flavor : LONGINT;
Version : LONGINT;
LongDoubleSize : LONGINT;
wchar_tSize : LONGINT;
END;
CONST NLM_INFO_SIGNATURE = 'NLMI'; // $494d3c3e; // NLMI
kNLMInfo : kNLMInfoT =
(Signature : NLM_INFO_SIGNATURE;
Flavor : TRADINIONAL_FLAVOR; // 0
Version : LIBERTY_VERSION; // 1
LongDoubleSize : 8;
wchar_tSize : 2);
{$ENDIF}
(*****************************************************************************)
FUNCTION _nlm_main (Argc : LONGINT; ArgV : ARRAY OF PCHAR) : LONGINT; CDECL;
EXTERNAL;
FUNCTION _Stop : LONGINT; CDECL;
BEGIN
{$IFDEF OldPrelude}
_Stop := _TerminateNLM (POINTER(NLMID),0,TERMINATE_BY_UNLOAD);
{$ELSE}
_Stop := _TerminateNLM (@kNLMInfo,0,TERMINATE_BY_UNLOAD);
{$ENDIF}
END;
FUNCTION _cstart_ : LONGINT; CDECL;
BEGIN
_cstart_ := _SetupArgV_411 (@_nlm_main);
END;
FUNCTION _Prelude (NLMHandle : LONGINT;
initErrorScreenID : LONGINT;
cmdLineP : PCHAR;
loadDirectoryPath : PCHAR;
uninitializedDataLength : LONGINT;
NLMFileHandle : LONGINT;
readRoutineP : POINTER;
customDataOffset : LONGINT;
customDataSize : LONGINT) : LONGINT; CDECL;
BEGIN
_Prelude := _StartNLM
(NLMHandle,
initErrorScreenID,
cmdLineP,
loadDirectoryPath,
uninitializedDataLength,
NLMFileHandle,
readRoutineP,
customDataOffset,
customDataSize,
{$IFDEF OldPrelude}
@NLMID,
{$ELSE}
@kNLMInfo,
{$ENDIF}
@_cstart_);
END;
end.

253
rtl/netware/nwsys.inc Normal file
View File

@ -0,0 +1,253 @@
{
$Id$
This file is part of the Free Pascal run time library.
Copyright (c) 1999-2000 by the Free Pascal development team
Interface to netware clib
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/08/27 armin: first version
2001/03/08 armin: additional functions
}
CONST Clib = 'clib.nlm';
NlmLib = 'nlmlib.nlm';
Threads= 'threads.nlm';
CalNlm = 'calnlm32.nlm';
ClxNlm = 'clxnlm32.nlm';
NitNlm = 'nit.nlm';
TYPE
dev_t = LONGINT;
ino_t = LONGINT;
unsignedshort = WORD;
unsignedlong = LONGINT;
unsignedint = LONGINT;
off_t = LONGINT;
size_t = LONGINT;
time_t = LONGINT;
NWStatBufT = PACKED RECORD
st_dev : dev_t; (* volume number *)
st_ino : ino_t; (* directory entry number of the st_name *)
st_mode : unsignedshort; (* emulated file mode *)
st_nlink : unsignedshort; (* count of hard links (always 1) *)
st_uid : unsignedlong; (* object id of owner *)
st_gid : unsignedshort; (* group-id (always 0) *)
st_rdev : dev_t; (* device type (always 0) *)
st_size : off_t; (* total file size--files only *)
st_atime : time_t; (* last access date--files only *)
st_mtime : time_t; (* last modify date and time *)
st_ctime : time_t; (* POSIX: last status change time... *)
(* ...NetWare: creation date/time *)
st_btime : time_t; (* last archived date and time *)
st_attr : unsignedlong; (* file attributes *)
st_archivedID : unsignedlong; (* user/object ID of last archive *)
st_updatedID : unsignedlong; (* user/object ID of last update *)
st_inheritedRightsMask
: unsignedshort; (* inherited rights mask *)
st_originatingNameSpace
: BYTE; (* namespace of creation *)
st_name : ARRAY [0..255] OF CHAR;
(* TARGET_NAMESPACE name *)
st_blksize : LONGINT;
st_blocks : LONGINT;
st_flags : LONGINT;
st_spare : ARRAY [0..3] OF LONGINT;
END;
FUNCTION _stat (path : PCHAR; VAR buf : NWStatBufT) : LONGINT; CDECL; EXTERNAL NlmLib NAME 'stat_411';
FUNCTION _fstat (Fileno : LONGINT; VAR buf : NWStatBufT) : LONGINT; CDECL; EXTERNAL NlmLib NAME 'fstat_411';
PROCEDURE NWFree (P : POINTER); CDECL; EXTERNAL Clib NAME 'free';
PROCEDURE PressAnyKeyToContinue; CDecl; EXTERNAL 'CLib.NLM';
PROCEDURE ExitThread (action_code, termination_code : LONGINT); CDecl; EXTERNAL 'CLib.NLM';
PROCEDURE _exit (ExitCode : LONGINT); CDecl; EXTERNAL 'CLib.NLM';
PROCEDURE ConsolePrintf (FormatStr : PCHAR; Param : LONGINT); CDecl; EXTERNAL ('CLib.NLM');
PROCEDURE printf (FormatStr : PCHAR; Param : LONGINT); CDecl; EXTERNAL ('CLib.NLM');
//PROCEDURE printf (FormatStr : PCHAR; Param : PCHAR); CDecl; EXTERNAL ('CLib.NLM');
PROCEDURE ConsolePrintf3 (FormatStr : PCHAR; P1,P2,P3 : LONGINT); CDecl; EXTERNAL ('CLib.NLM') NAME 'ConsolePrintf';
//FUNCTION strlen(lpString: PChar): LONGINT; CDECL; EXTERNAL Clib;
// values for __action_code used with ExitThread()
CONST
TSR_THREAD = -1;
EXIT_THREAD = 0;
EXIT_NLM = 1;
FUNCTION _GetStdIn : POINTER; CDECL; EXTERNAL Clib NAME '__get_stdin'; // result: **FILE
FUNCTION _GetStdOut : POINTER; CDECL; EXTERNAL Clib NAME '__get_stdout';
FUNCTION _GetStdErr : POINTER; CDECL; EXTERNAL Clib NAME '__get_stderr';
// Stream FileIO
//FUNCTION _fopen (filename, mode : PCHAR) : LONGINT; CDECL; EXTERNAL Clib NAME 'fopen';
//FUNCTION _fclose (hFile : LONGINT) : LONGINT; CDECL; EXTERNAL Clib NAME 'fclose';
//FUNCTION _fwrite (Buffer : POINTER; S1,S2,hFile : LONGINT) : LONGINT; CDECL; EXTERNAL Clib NAME 'fwrite';
//FUNCTION _fread (Buffer : POINTER; S1,S2,hFile : LONGINT) : LONGINT; CDECL; EXTERNAL Clib NAME 'fread';
//FUNCTION _fseek (hFile, Offset, Where : LONGINT) : LONGINT; CDECL; EXTERNAL Clib NAME 'fseek';
//FUNCTION _ftell (hFile : LONGINT) : LONGINT; CDECL; EXTERNAL Clib NAME 'ftell';
// FileIO by Fileno
FUNCTION _open (FileName : PCHAR; access, mode : LONGINT) : LONGINT; CDECL; EXTERNAL NlmLib NAME 'open';
FUNCTION _close (FileNo : LONGINT) : LONGINT; CDECL; EXTERNAL NlmLib NAME 'close';
FUNCTION _lseek (FileNo,Pos,whence :LONGINT) : LONGINT; CDECL; EXTERNAL NlmLib NAME 'lseek';
FUNCTION _chsize (FileNo,Pos : LONGINT) : LONGINT; CDECL; EXTERNAL NlmLib NAME 'chsize';
FUNCTION _tell (FileNo : LONGINT) : LONGINT; CDECL; EXTERNAL NlmLib NAME 'tell';
FUNCTION _write (FileNo : LONGINT; BufP : POINTER; Len : LONGINT) : LONGINT; CDECL; EXTERNAL NlmLib NAME 'write';
FUNCTION _read (FileNo : LONGINT; BufP : POINTER; Len : LONGINT) : LONGINT; CDECL; EXTERNAL NlmLib NAME 'read';
FUNCTION _filelength (filedes : LONGINT) : LONGINT; CDECL; EXTERNAL NlmLib NAME 'filelength';
// Directory
FUNCTION _chdir (path : PCHAR) : LONGINT; CDECL; EXTERNAL NlmLib NAME 'chdir';
FUNCTION _getcwd (path : PCHAR; pathlen : LONGINT) : PCHAR; CDECL; EXTERNAL NlmLib NAME 'getcwd';
FUNCTION _mkdir (path : PCHAR) : LONGINT; CDECL; EXTERNAL NlmLib NAME 'mkdir';
FUNCTION _rmdir (path : PCHAR) : LONGINT; CDECL; EXTERNAL NlmLib NAME 'rmdir';
// get fileno from stream
FUNCTION _fileno (Handle : LONGINT) : LONGINT; CDECL; EXTERNAL Clib NAME 'fileno';
FUNCTION _isatty (FileNo : LONGINT) : LONGINT; CDECL; EXTERNAL NlmLib NAME 'isatty';
(* values for 'o_flag' in open()... *)
CONST O_RDONLY = $0000; (* open for read only *)
O_WRONLY = $0001; (* open for write only *)
O_RDWR = $0002; (* open for read and write *)
O_ACCMODE = $0003; (* AND with value to extract access flags *)
O_APPEND = $0010; (* writes done at end of file *)
O_CREAT = $0020; (* create new file *)
O_TRUNC = $0040; (* truncate existing file *)
O_EXCL = $0080; (* exclusive open *)
O_TEXT = $0100; (* text file--unsupported *)
O_BINARY = $0200; (* binary file *)
O_NDELAY = $0400; (* nonblocking flag *)
O_NOCTTY = $0800; (* currently unsupported *)
O_NONBLOCK = O_NDELAY;
// File Utils
FUNCTION _unlink (FileName : PCHAR) : LONGINT; CDECL; EXTERNAL NlmLib NAME 'unlink';
FUNCTION _rename (oldpath, newpath : PCHAR) : LONGINT; CDECL; EXTERNAL Clib NAME 'rename';
// Error
TYPE _PLONGINT = ^LONGINT;
FUNCTION __get_errno_ptr : _PLONGINT; CDECL; EXTERNAL Clib;
// Memory
FUNCTION _malloc (size : LONGINT) : POINTER; CDECL; EXTERNAL Threads NAME 'malloc';
PROCEDURE _free (what : POINTER); CDECL; EXTERNAL Threads NAME 'free';
FUNCTION _stackavail : LONGINT; CDECL; EXTERNAL Threads NAME 'stackavail';
// Debug
PROCEDURE _EnterDebugger; CDECL; EXTERNAL Clib NAME 'EnterDebugger';
// String
FUNCTION _strlen (P : PCHAR) : LONGINT; CDECL; EXTERNAL Clib NAME 'strlen';
// Time/Date
TYPE NWTM = RECORD
tm_sec, tm_min, tm_hour,
tm_mday, tm_mon, tm_year,
tm_wday, tm_yday, tm_isdst : LONGINT;
END;
PNWTM = ^NWTM;
FUNCTION _localtime (VAR time : time_t) : PNWTM; CDECL; EXTERNAL Clib NAME 'localtime';
FUNCTION _time (tloc : POINTER) : LONGINT; CDECL; EXTERNAL Clib NAME 'time';
PROCEDURE _ConvertTimeToDOS (time : time_t; VAR DosDate, DosTime : WORD); CDECL; EXTERNAL Clib NAME '_ConvertTimeToDOS';
PROCEDURE _tzset; CDECL; EXTERNAL Clib NAME 'tzset';
//-----------------------------------------------------------------------
CONST NWDEFCONN_HANDLE = 0;
TYPE NWCONN_HANDLE = LONGINT;
NWRCODE = LONGINT;
NWDateAndTime = PACKED RECORD
Year,Month,Day,
Hour,Minute,Second,DayOfWeek : BYTE;
END;
PROCEDURE GetFileServerDateAndTime (VAR TimeBuf : NWDateAndTime); CDECL; EXTERNAL NitNlm NAME 'GetFileServerDateAndTime';
FUNCTION SetFileServerDateAndTime(year:WORD; month:WORD; day:WORD; hour:WORD; minute:WORD;
second:WORD):longint;cdecl; EXTERNAL NitNlm Name 'SetFileServerDateAndTime';
TYPE FILE_SERV_INFO = record
serverName : array[0..47] of char;
netwareVersion : BYTE;
netwareSubVersion : BYTE;
maxConnectionsSupported : WORD;
connectionsInUse : WORD;
maxVolumesSupported : WORD;
revisionLevel : BYTE;
SFTLevel : BYTE;
TTSLevel : BYTE;
peakConnectionsUsed : WORD;
accountingVersion : BYTE;
VAPversion : BYTE;
queingVersion : BYTE;
printServerVersion : BYTE;
virtualConsoleVersion : BYTE;
securityRestrictionLevel: BYTE;
internetBridgeSupport : BYTE;
reserved : array[0..59] of BYTE;
CLibMajorVersion : BYTE;
CLibMinorVersion : BYTE;
CLibRevision : BYTE;
end;
pFILE_SERV_INFO = ^FILE_SERV_INFO;
FUNCTION GetServerInformation(returnSize:longint; serverInfo:pFILE_SERV_INFO):longint;cdecl; EXTERNAL NitNlm NAME 'GetServerInformation';
// Directory
TYPE NWDirEnt =
PACKED RECORD
d_attr : LONGINT;
d_time : WORD;
d_date : WORD;
d_size : LONGINT;
d_ino : LONGINT;
d_dev : LONGINT;
d_cdatetime : LONGINT;
d_adatetime : LONGINT;
d_bdatetime : LONGINT;
d_uid : LONGINT;
d_archivedID: LONGINT;
d_updatedID : LONGINT;
d_nameDOS : ARRAY [0..12] OF CHAR;
d_inheritedRightsMask : WORD;
d_originatingNameSpace: BYTE;
d_ddatetime : LONGINT;
d_deletedID : LONGINT;
{---- new fields starting in v4.11 ----}
d_name : ARRAY [0..255] OF CHAR; { enty's namespace name }
END;
PNWDirEnt = ^NWDirEnt;
FUNCTION _opendir (pathname : PCHAR) : PNWDirEnt; CDECL; EXTERNAL NlmLib NAME 'opendir_411';
FUNCTION _closedir (dirH : PNWDirEnt) : LONGINT; CDECL; EXTERNAL NlmLib NAME 'closedir';
FUNCTION _readdir (dirH : PNWDirEnt) : PNWDirEnt; CDECL; EXTERNAL NlmLib NAME 'readdir';
FUNCTION _SetReaddirAttribute (dirH : PNWDirEnt; Attribute : LONGINT) : LONGINT; EXTERNAL NlmLib NAME 'SetReaddirAttribute';
// Environment
FUNCTION _getenv (name : PCHAR) : PCHAR; CDECL; EXTERNAL NlmLib NAME 'getenv';
// Volumes
FUNCTION _GetVolumeName (volumeNumber : LONGINT; volumeName : PCHAR) : LONGINT; CDECL; EXTERNAL NitNlm NAME 'GetVolumeName';
FUNCTION _GetVolumeNumber (volumeName : PCHAR; VAR volumeNumber : LONGINT) : LONGINT; CDECL; EXTERNAL NitNlm NAME 'GetVolumeNumber';
FUNCTION _GetVolumeInfoWithNumber (VolumeNumber : BYTE;
VolumeName : PCHAR;
VAR TotalBlocks : WORD;
VAR SectorsPerBlock : WORD;
VAR availableBlocks : WORD;
VAR totalDirectorySlots : WORD;
VAR availableDirSlots : WORD;
VAR volumeisRemovable : WORD) : LONGINT; CDECL; EXTERNAL NitNlm NAME 'GetVolumeInfoWithNumber';
FUNCTION _GetNumberOfVolumes : LONGINT; CDECL; EXTERNAL NitNlm NAME 'GetNumberOfVolumes';

557
rtl/netware/system.pp Normal file
View File

@ -0,0 +1,557 @@
{
$Id$
This file is part of the Free Pascal run time library.
Copyright (c) 1999-2000 by 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.
**********************************************************************}
{ no stack check in system }
{$S-}
unit system;
{ 2000/09/03 armin: first version
2001/03/08 armin: changes for fpc 1.1
}
interface
{$ifdef SYSTEMDEBUG}
{$define SYSTEMEXCEPTIONDEBUG}
{$endif SYSTEMDEBUG}
{$ifdef i386}
{$define Set_i386_Exception_handler}
{$endif i386}
{ include system-independent routine headers }
{$I systemh.inc}
{ include heap support headers }
{Why the hell do i have to define that ???
otherwise FPC_FREEMEM expects 2 parameters but the compiler only
puhes the address}
{$DEFINE NEWMM}
{$I heaph.inc}
CONST
{ Default filehandles }
UnusedHandle : longint = -1;
StdInputHandle : longint = 0;
StdOutputHandle : longint = 0;
StdErrorHandle : longint = 0;
FileNameCaseSensitive : boolean = false;
sLineBreak : STRING [2] = #13#10;
DefaultTextLineBreakStyle : TTextLineBreakStyle = tlbsCRLF;
VAR
ArgC : INTEGER;
ArgV : ppchar;
implementation
{ include system independent routines }
{$I system.inc}
{$I nwsys.inc}
{$I errno.inc}
procedure setup_arguments;
begin
end;
procedure setup_environment;
begin
end;
procedure PascalMain;external name 'PASCALMAIN';
procedure fpc_do_exit;external name 'FPC_DO_EXIT';
{*****************************************************************************
Startup
*****************************************************************************}
PROCEDURE _nlm_main (_ArgC : LONGINT; _ArgV : ppchar); CDECL; [public,alias: '_nlm_main'];
BEGIN
ArgC := _ArgC;
ArgV := _ArgV;
PASCALMAIN;
END;
{*****************************************************************************
System Dependent Exit code
*****************************************************************************}
Procedure system_exit;
begin
_exit (ExitCode);
end;
{*****************************************************************************
Stack check code
*****************************************************************************}
procedure int_stackcheck(stack_size:longint);[public,alias:'FPC_STACKCHECK'];
{
called when trying to get local stack if the compiler directive $S
is set this function must preserve esi !!!! because esi is set by
the calling proc for methods it must preserve all registers !!
With a 2048 byte safe area used to write to StdIo without crossing
the stack boundary
}
begin
IF _stackavail > stack_size + 2048 THEN EXIT;
HandleError (202);
end;
{*****************************************************************************
ParamStr/Randomize
*****************************************************************************}
{ number of args }
function paramcount : longint;
begin
paramcount := argc - 1;
end;
{ argument number l }
function paramstr(l : longint) : string;
begin
if (l>=0) and (l+1<=argc) then
paramstr:=strpas(argv[l])
else
paramstr:='';
end;
{ set randseed to a new pseudo random value }
procedure randomize;
begin
randseed := _time (NIL);
end;
{*****************************************************************************
Heap Management
*****************************************************************************}
{ first address of heap }
function getheapstart:pointer;
assembler;
asm
leal HEAP,%eax
end ['EAX'];
{ current length of heap }
function getheapsize:longint;
assembler;
asm
movl HEAPSIZE,%eax
end ['EAX'];
{ function to allocate size bytes more for the program }
{ must return the first address of new data space or -1 if fail }
FUNCTION Sbrk(size : longint):longint;
VAR P : POINTER;
BEGIN
P := _malloc (size);
IF P = NIL THEN
Sbrk := -1
ELSE
Sbrk := LONGINT (P);
END;
{ include standard heap management }
{$I heap.inc}
{****************************************************************************
Low level File Routines
All these functions can set InOutRes on errors
****************************************************************************}
PROCEDURE NW2PASErr (Err : LONGINT);
BEGIN
if Err = 0 then { Else it will go through all the cases }
exit;
case Err of
Sys_ENFILE,
Sys_EMFILE : Inoutres:=4;
Sys_ENOENT : Inoutres:=2;
Sys_EBADF : Inoutres:=6;
Sys_ENOMEM,
Sys_EFAULT : Inoutres:=217;
Sys_EINVAL : Inoutres:=218;
Sys_EPIPE,
Sys_EINTR,
Sys_EIO,
Sys_EAGAIN,
Sys_ENOSPC : Inoutres:=101;
Sys_ENAMETOOLONG,
Sys_ELOOP,
Sys_ENOTDIR : Inoutres:=3;
Sys_EROFS,
Sys_EEXIST,
Sys_EACCES : Inoutres:=5;
Sys_EBUSY : Inoutres:=162;
end;
END;
FUNCTION errno : LONGINT;
BEGIN
errno := __get_errno_ptr^;
END;
PROCEDURE Errno2Inoutres;
BEGIN
NW2PASErr (errno);
END;
PROCEDURE SetFileError (VAR Err : LONGINT);
BEGIN
IF Err >= 0 THEN
InOutRes := 0
ELSE
BEGIN
Err := errno;
NW2PASErr (Err);
Err := 0;
END;
END;
{ close a file from the handle value }
procedure do_close(handle : longint);
VAR res : LONGINT;
begin
res := _close (handle);
IF res <> 0 THEN
SetFileError (res)
ELSE
InOutRes := 0;
end;
procedure do_erase(p : pchar);
VAR res : LONGINT;
begin
res := _unlink (p);
IF Res < 0 THEN
SetFileError (res)
ELSE
InOutRes := 0;
end;
procedure do_rename(p1,p2 : pchar);
VAR res : LONGINT;
begin
res := _rename (p1,p2);
IF Res < 0 THEN
SetFileError (res)
ELSE
InOutRes := 0
end;
function do_write(h,addr,len : longint) : longint;
VAR res : LONGINT;
begin
res := _write (h,POINTER(addr),len);
IF res > 0 THEN
InOutRes := 0
ELSE
SetFileError (res);
do_write := res;
end;
function do_read(h,addr,len : longint) : longint;
VAR res : LONGINT;
begin
res := _read (h,POINTER(addr),len);
IF res > 0 THEN
InOutRes := 0
ELSE
SetFileError (res);
do_read := res;
end;
function do_filepos(handle : longint) : longint;
VAR res : LONGINT;
begin
InOutRes:=1;
res := _tell (handle);
IF res < 0 THEN
SetFileError (res)
ELSE
InOutRes := 0;
do_filepos := res;
end;
CONST SEEK_SET = 0; // Seek from beginning of file.
SEEK_CUR = 1; // Seek from current position.
SEEK_END = 2; // Seek from end of file.
procedure do_seek(handle,pos : longint);
VAR res : LONGINT;
begin
res := _lseek (handle,pos, SEEK_SET);
IF res >= 0 THEN
InOutRes := 0
ELSE
SetFileError (res);
end;
function do_seekend(handle:longint):longint;
VAR res : LONGINT;
begin
res := _lseek (handle,0, SEEK_END);
IF res >= 0 THEN
InOutRes := 0
ELSE
SetFileError (res);
do_seekend := res;
end;
function do_filesize(handle : longint) : longint;
VAR res : LONGINT;
begin
res := _filelength (handle);
IF res < 0 THEN
BEGIN
SetFileError (Res);
do_filesize := -1;
END ELSE
BEGIN
InOutRes := 0;
do_filesize := res;
END;
end;
{ truncate at a given position }
procedure do_truncate (handle,pos:longint);
VAR res : LONGINT;
begin
res := _chsize (handle,pos);
IF res <> 0 THEN
SetFileError (res)
ELSE
InOutRes := 0;
end;
// mostly stolen from syslinux
procedure do_open(var f;p:pchar;flags:longint);
{
filerec and textrec have both handle and mode as the first items so
they could use the same routine for opening/creating.
when (flags and $10) the file will be append
when (flags and $100) the file will be truncate/rewritten
when (flags and $1000) there is no check for close (needed for textfiles)
}
var
oflags : longint;
Begin
{ close first if opened }
if ((flags and $10000)=0) then
begin
case FileRec(f).mode of
fminput,fmoutput,fminout : Do_Close(FileRec(f).Handle);
fmclosed : ;
else
begin
inoutres:=102; {not assigned}
exit;
end;
end;
end;
{ reset file Handle }
FileRec(f).Handle:=UnusedHandle;
{ We do the conversion of filemodes here, concentrated on 1 place }
case (flags and 3) of
0 : begin
oflags := O_RDONLY;
filerec(f).mode := fminput;
end;
1 : begin
oflags := O_WRONLY;
filerec(f).mode := fmoutput;
end;
2 : begin
oflags := O_RDWR;
filerec(f).mode := fminout;
end;
end;
if (flags and $1000)=$1000 then
oflags:=oflags or (O_CREAT or O_TRUNC)
else
if (flags and $100)=$100 then
oflags:=oflags or (O_APPEND);
{ empty name is special }
if p[0]=#0 then
begin
case FileRec(f).mode of
fminput :
FileRec(f).Handle:=StdInputHandle;
fminout, { this is set by rewrite }
fmoutput :
FileRec(f).Handle:=StdOutputHandle;
fmappend :
begin
FileRec(f).Handle:=StdOutputHandle;
FileRec(f).mode:=fmoutput; {fool fmappend}
end;
end;
exit;
end;
{ real open call }
FileRec(f).Handle := _open(p,oflags,438);
//WriteLn ('_open (',p,') liefert ',ErrNo, 'Handle: ',FileRec(f).Handle);
// errno does not seem to be set on succsess ??
IF FileRec(f).Handle < 0 THEN
if (ErrNo=Sys_EROFS) and ((OFlags and O_RDWR)<>0) then
begin // i.e. for cd-rom
Oflags:=Oflags and not(O_RDWR);
FileRec(f).Handle := _open(p,oflags,438);
end;
IF FileRec(f).Handle < 0 THEN
Errno2Inoutres
ELSE
InOutRes := 0;
End;
function do_isdevice(handle:longint):boolean;
begin
do_isdevice := (_isatty (handle) > 0);
end;
{*****************************************************************************
UnTyped File Handling
*****************************************************************************}
{$i file.inc}
{*****************************************************************************
Typed File Handling
*****************************************************************************}
{$i typefile.inc}
{*****************************************************************************
Text File Handling
*****************************************************************************}
{ should we consider #26 as the end of a file ? }
{?? $DEFINE EOF_CTRLZ}
{$i text.inc}
{*****************************************************************************
Directory Handling
*****************************************************************************}
procedure mkdir(const s : string);[IOCheck];
VAR S2 : STRING;
Res: LONGINT;
BEGIN
S2 := S;
IF Length (S2) = 255 THEN DEC (BYTE(S2[0]));
S2 := S2 + #0;
Res := _mkdir (@S2[1]);
IF Res = 0 THEN
InOutRes:=0
ELSE
SetFileError (Res);
END;
procedure rmdir(const s : string);[IOCheck];
VAR S2 : STRING;
Res: LONGINT;
BEGIN
S2 := S;
IF Length (S2) = 255 THEN DEC (BYTE(S2[0]));
S2 := S2 + #0;
Res := _rmdir (@S2[1]);
IF Res = 0 THEN
InOutRes:=0
ELSE
SetFileError (Res);
end;
procedure chdir(const s : string);[IOCheck];
VAR S2 : STRING;
Res: LONGINT;
begin
S2 := S;
IF Length (S2) = 255 THEN DEC (BYTE(S2[0]));
S2 := S2 + #0;
Res := _chdir (@S2[1]);
IF Res = 0 THEN
InOutRes:=0
ELSE
SetFileError (Res);
end;
procedure getdir(drivenr : byte;var dir : shortstring);
VAR P : ARRAY [0..255] OF CHAR;
Len: LONGINT;
begin
P[0] := #0;
_getcwd (@P, SIZEOF (P));
Len := _strlen (P);
IF Len > 0 THEN
BEGIN
Move (P, dir[1], Len);
BYTE(dir[0]) := Len;
END ELSE
InOutRes := 1;
end;
{*****************************************************************************
SystemUnit Initialization
*****************************************************************************}
Begin
{ Setup heap }
InitHeap;
{ Setup stdin, stdout and stderr }
StdInputHandle := _fileno (LONGINT (_GetStdIn^)); // GetStd** returns **FILE !
StdOutputHandle:= _fileno (LONGINT (_GetStdOut^));
StdErrorHandle := _fileno (LONGINT (_GetStdErr^));
InitExceptions;
OpenStdIO(Input,fmInput,StdInputHandle);
OpenStdIO(Output,fmOutput,StdOutputHandle);
OpenStdIO(StdOut,fmOutput,StdOutputHandle);
OpenStdIO(StdErr,fmOutput,StdErrorHandle);
{ Setup environment and arguments }
Setup_Environment;
Setup_Arguments;
{ Reset IO Error }
InOutRes:=0;
End.
{
$Log$
Revision 1.1 2001-04-11 14:14:12 florian
* initial commit, thanks to Armin Diehl (diehl@nordrhein)
Revision 1.2 2000/07/13 11:33:56 michael
+ removed logs
}

506
rtl/netware/sysutils.pp Normal file
View File

@ -0,0 +1,506 @@
{
$Id$
This file is part of the Free Pascal run time library.
Copyright (c) 1999-2000 by Florian Klaempfl
member of the Free Pascal development team
Sysutils unit for 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.
**********************************************************************}
{currently nothing is implemented !}
unit sysutils;
interface
{$MODE objfpc}
{ force ansistrings }
{$H+}
uses DOS;
// Unix,errors;
{$I nwsys.inc}
{$I errno.inc}
{ Include platform independent interface part }
{$i sysutilh.inc}
implementation
{ Include platform independent implementation part }
{$i sysutils.inc}
{****************************************************************************
File Functions
****************************************************************************}
Function FileOpen (Const FileName : string; Mode : Integer) : Longint;
Var LinuxFlags : longint;
BEGIN
{LinuxFlags:=0;
Case (Mode and 3) of
0 : LinuxFlags:=LinuxFlags or Open_RdOnly;
1 : LinuxFlags:=LinuxFlags or Open_WrOnly;
2 : LinuxFlags:=LinuxFlags or Open_RdWr;
end;
FileOpen:=fdOpen (FileName,LinuxFlags);
}
//!! We need to set locking based on Mode !!
end;
Function FileCreate (Const FileName : String) : Longint;
begin
//FileCreate:=fdOpen(FileName,Open_RdWr or Open_Creat or Open_Trunc);
end;
Function FileRead (Handle : Longint; Var Buffer; Count : longint) : Longint;
begin
//FileRead:=fdRead (Handle,Buffer,Count);
end;
Function FileWrite (Handle : Longint; const Buffer; Count : Longint) : Longint;
begin
//FileWrite:=fdWrite (Handle,Buffer,Count);
end;
Function FileSeek (Handle,FOffset,Origin : Longint) : Longint;
begin
//FileSeek:=fdSeek (Handle,FOffset,Origin);
end;
Procedure FileClose (Handle : Longint);
begin
//fdclose(Handle);
end;
Function FileTruncate (Handle,Size: Longint) : boolean;
begin
//FileTruncate:=fdtruncate(Handle,Size);
end;
Function FileAge (Const FileName : String): Longint;
//Var Info : Stat;
// Y,M,D,hh,mm,ss : word;
begin
{ If not fstat (FileName,Info) then
exit(-1)
else
begin
EpochToLocal(info.mtime,y,m,d,hh,mm,ss);
Result:=DateTimeToFileDate(EncodeDate(y,m,d)+EncodeTime(hh,mm,ss,0));
end;}
end;
Function FileExists (Const FileName : String) : Boolean;
//Var Info : Stat;
begin
//FileExists:=fstat(filename,Info);
end;
{
Function LinuxToWinAttr (FN : Pchar; Const Info : Stat) : Longint;
begin
Result:=faArchive;
If (Info.Mode and STAT_IFDIR)=STAT_IFDIR then
Result:=Result or faDirectory;
If (FN[0]='.') and (not (FN[1] in [#0,'.'])) then
Result:=Result or faHidden;
If (Info.Mode and STAT_IWUSR)=0 Then
Result:=Result or faReadOnly;
If (Info.Mode and
(STAT_IFSOCK or STAT_IFBLK or STAT_IFCHR or STAT_IFIFO))<>0 then
Result:=Result or faSysFile;
end;
}
{
GlobToSearch takes a glob entry, stats the file.
The glob entry is removed.
If FileAttributes match, the entry is reused
}
{Type
TGlobSearchRec = Record
Path : String;
GlobHandle : PGlob;
end;
PGlobSearchRec = ^TGlobSearchRec;}
{Function GlobToTSearchRec (Var Info : TSearchRec) : Boolean;
Var SInfo : Stat;
p : Pglob;
GlobSearchRec : PGlobSearchrec;
begin
GlobSearchRec:=PGlobSearchrec(Info.FindHandle);
P:=GlobSearchRec^.GlobHandle;
Result:=P<>Nil;
If Result then
begin
GlobSearchRec^.GlobHandle:=P^.Next;
Result:=Fstat(GlobSearchRec^.Path+StrPas(p^.name),SInfo);
If Result then
begin
Info.Attr:=LinuxToWinAttr(p^.name,SInfo);
Result:=(Info.ExcludeAttr and Info.Attr)=0;
If Result Then
With Info do
begin
Attr:=Info.Attr;
If P^.Name<>Nil then
Name:=strpas(p^.name);
Time:=Sinfo.mtime;
Size:=Sinfo.Size;
end;
end;
P^.Next:=Nil;
GlobFree(P);
end;
end;}
Function DoFind(Var Rslt : TSearchRec) : Longint;
//Var GlobSearchRec : PGlobSearchRec;
begin
Result:=-1;
{ GlobSearchRec:=PGlobSearchRec(Rslt.FindHandle);
If (GlobSearchRec^.GlobHandle<>Nil) then
While (GlobSearchRec^.GlobHandle<>Nil) and not (Result=0) do
If GlobToTSearchRec(Rslt) Then Result:=0;}
end;
Function FindFirst (Const Path : String; Attr : Longint; Var Rslt : TSearchRec) : Longint;
//Var GlobSearchRec : PGlobSearchRec;
begin
{New(GlobSearchRec);
GlobSearchRec^.Path:=ExpandFileName(ExtractFilePath(Path));
GlobSearchRec^.GlobHandle:=Glob(Path);
Rslt.ExcludeAttr:=Not Attr; //!! Not correct !!
Rslt.FindHandle:=Longint(GlobSearchRec);
Result:=DoFind (Rslt);}
end;
Function FindNext (Var Rslt : TSearchRec) : Longint;
begin
// Result:=DoFind (Rslt);
end;
Procedure FindClose (Var F : TSearchrec);
//Var GlobSearchRec : PGlobSearchRec;
begin
{GlobSearchRec:=PGlobSearchRec(F.FindHandle);
GlobFree (GlobSearchRec^.GlobHandle);
Dispose(GlobSearchRec);}
end;
Function FileGetDate (Handle : Longint) : Longint;
//Var Info : Stat;
begin
{If Not(FStat(Handle,Info)) then
Result:=-1
else
Result:=Info.Mtime;}
end;
Function FileSetDate (Handle,Age : Longint) : Longint;
begin
// Impossible under Linux from FileHandle !!
FileSetDate:=-1;
end;
Function FileGetAttr (Const FileName : String) : Longint;
//Var Info : Stat;
begin
{ If Not FStat (FileName,Info) then
Result:=-1
Else
Result:=LinuxToWinAttr(Pchar(FileName),Info);}
end;
Function FileSetAttr (Const Filename : String; Attr: longint) : Longint;
begin
Result:=-1;
end;
Function DeleteFile (Const FileName : String) : Boolean;
begin
Result:= (_UnLink (pchar(FileName)) = 0);
end;
Function RenameFile (Const OldName, NewName : String) : Boolean;
begin
// RenameFile:=Unix.FRename(OldNAme,NewName);
end;
Function FileSearch (Const Name, DirList : String) : String;
begin
FileSearch:=Dos.FSearch(Name,Dirlist);
end;
{****************************************************************************
Disk Functions
****************************************************************************}
{
The Diskfree and Disksize functions need a file on the specified drive, since this
is required for the statfs system call.
These filenames are set in drivestr[0..26], and have been preset to :
0 - '.' (default drive - hence current dir is ok.)
1 - '/fd0/.' (floppy drive 1 - should be adapted to local system )
2 - '/fd1/.' (floppy drive 2 - should be adapted to local system )
3 - '/' (C: equivalent of dos is the root partition)
4..26 (can be set by you're own applications)
! Use AddDisk() to Add new drives !
They both return -1 when a failure occurs.
}
Const
FixDriveStr : array[0..3] of pchar=(
'.',
'/fd0/.',
'/fd1/.',
'/.'
);
var
Drives : byte;
DriveStr : array[4..26] of pchar;
Procedure AddDisk(const path:string);
begin
if not (DriveStr[Drives]=nil) then
FreeMem(DriveStr[Drives],StrLen(DriveStr[Drives])+1);
GetMem(DriveStr[Drives],length(Path)+1);
StrPCopy(DriveStr[Drives],path);
inc(Drives);
if Drives>26 then
Drives:=4;
end;
Function DiskFree(Drive: Byte): int64;
//var fs : statfs;
Begin
{ if ((Drive<4) and (not (fixdrivestr[Drive]=nil)) and fsstat(StrPas(fixdrivestr[drive]),fs)) or
((not (drivestr[Drive]=nil)) and fsstat(StrPas(drivestr[drive]),fs)) then
Diskfree:=int64(fs.bavail)*int64(fs.bsize)
else
Diskfree:=-1;}
End;
Function DiskSize(Drive: Byte): int64;
//var fs : statfs;
Begin
{ if ((Drive<4) and (not (fixdrivestr[Drive]=nil)) and fsstat(StrPas(fixdrivestr[drive]),fs)) or
((not (drivestr[Drive]=nil)) and fsstat(StrPas(drivestr[drive]),fs)) then
DiskSize:=int64(fs.blocks)*int64(fs.bsize)
else
DiskSize:=-1;}
End;
Function GetCurrentDir : String;
begin
GetDir (0,Result);
end;
Function SetCurrentDir (Const NewDir : String) : Boolean;
begin
{$I-}
ChDir(NewDir);
{$I+}
result := (IOResult = 0);
end;
Function CreateDir (Const NewDir : String) : Boolean;
begin
{$I-}
MkDir(NewDir);
{$I+}
result := (IOResult = 0);
end;
Function RemoveDir (Const Dir : String) : Boolean;
begin
{$I-}
RmDir(Dir);
{$I+}
result := (IOResult = 0);
end;
{****************************************************************************
Misc Functions
****************************************************************************}
procedure Beep;
begin
end;
{****************************************************************************
Locale Functions
****************************************************************************}
Procedure GetLocalTime(var SystemTime: TSystemTime);
var xx : word;
begin
Dos.GetTime(SystemTime.Hour, SystemTime.Minute, SystemTime.Second, xx);
Dos.GetDate(SystemTime.Year, SystemTime.Month, SystemTime.Day, xx);
SystemTime.MilliSecond := 0;
end;
Procedure InitAnsi;
Var i : longint;
begin
{ Fill table entries 0 to 127 }
for i := 0 to 96 do
UpperCaseTable[i] := chr(i);
for i := 97 to 122 do
UpperCaseTable[i] := chr(i - 32);
for i := 123 to 191 do
UpperCaseTable[i] := chr(i);
Move (CPISO88591UCT,UpperCaseTable[192],SizeOf(CPISO88591UCT));
for i := 0 to 64 do
LowerCaseTable[i] := chr(i);
for i := 65 to 90 do
LowerCaseTable[i] := chr(i + 32);
for i := 91 to 191 do
LowerCaseTable[i] := chr(i);
Move (CPISO88591LCT,UpperCaseTable[192],SizeOf(CPISO88591UCT));
end;
Procedure InitInternational;
begin
InitAnsi;
end;
function SysErrorMessage(ErrorCode: Integer): String;
begin
Result:=''; // StrError(ErrorCode);
end;
{****************************************************************************
OS utility functions
****************************************************************************}
Function GetEnvironmentVariable(Const EnvVar : String) : String;
begin
// Result:=StrPas(Unix.Getenv(PChar(EnvVar)));
end;
{****************************************************************************
Initialization code
****************************************************************************}
Initialization
InitExceptions; { Initialize exceptions. OS independent }
InitInternational; { Initialize internationalization settings }
Finalization
OutOfMemory.Free;
InValidPointer.Free;
end.
{
$Log$
Revision 1.1 2001-04-11 14:14:12 florian
* initial commit, thanks to Armin Diehl (diehl@nordrhein)
Revision 1.8 2001/02/20 22:19:38 peter
* always test before commiting after merging, linux -> unix change
Revision 1.7 2001/02/20 22:14:19 peter
* merged getenvironmentvariable
Revision 1.6 2001/01/21 20:21:40 marco
* Rename fest II. Rtl OK
Revision 1.5 2000/12/28 20:50:04 peter
* merged fixes from 1.0.x
Revision 1.4 2000/12/18 14:01:42 jonas
* fixed constant range error
Revision 1.3 2000/11/28 20:06:12 michael
+ merged fix for findfirst/findnext/findclose
Revision 1.2 2000/09/18 13:14:51 marco
* Global Linux +bsd to (rtl/freebsd rtl/unix rtl/linux structure)
Revision 1.3 2000/08/29 17:58:13 michael
Merged syserrormsg fix
Revision 1.2 2000/08/20 15:46:46 peter
* sysutils.pp moved to target and merged with disk.inc, filutil.inc
Revision 1.1.2.2 2000/11/28 20:01:22 michael
+ Fixed findfirst/findnext/findclose
Revision 1.1.2.1 2000/09/14 13:38:26 marco
* Moved from Linux dir. now start of generic unix dir, from which the
really exotic features should be moved to the target specific dirs.
}