paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-31 17:30:38 +02:00
Code Issues Packages Projects Releases Wiki Activity

* added keyboard and video

Browse Source 
* a lot of fixes
This commit is contained in:
armin 2004-09-12 20:51:22 +00:00
parent bb684d007d
commit 76400e6c05
8 changed files with 799 additions and 192 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
rtl/netwlibc/Makefile
View File

@ -228,7 +228,7 @@ override FPCOPT+=-Ur
override FPCOPT+=-dMT -dDEBUG_MT override FPCOPT+=-dMT -dDEBUG_MT
CREATESMART=0 CREATESMART=0
OBJPASDIR=$(RTL)/objpas OBJPASDIR=$(RTL)/objpas
override TARGET_UNITS+=$(SYSTEMUNIT) objpas macpas strings lineinfo winsock heaptrc matrix nwsnut libc dos crt objects sysconst dynlibs initc sysutils types typinfo systhrds classes cpu mmx getopts dateutils strutils convutils charset ucomplex variants rtlconst math varutils utf8bidi mouse override TARGET_UNITS+=$(SYSTEMUNIT) objpas macpas strings lineinfo winsock heaptrc matrix nwsnut libc dos crt objects sysconst dynlibs initc sysutils types typinfo systhrds classes cpu mmx getopts dateutils strutils convutils charset ucomplex variants rtlconst math varutils freebidi utf8bidi mouse video keyboard
override TARGET_LOADERS+=nwplibc override TARGET_LOADERS+=nwplibc
override TARGET_RSTS+=math varutils variants convutils typinfo systhrds classes dateutils sysconst rtlconst override TARGET_RSTS+=math varutils variants convutils typinfo systhrds classes dateutils sysconst rtlconst
override INSTALL_FPCPACKAGE=y override INSTALL_FPCPACKAGE=y
@ -1434,8 +1434,9 @@ gettext$(PPUEXT): $(OBJPASDIR)/gettext.pp objpas$(PPUEXT) sysutils$(PPUEXT)
varutils$(PPUEXT) : varutils.pp $(OBJPASDIR)/cvarutil.inc \ varutils$(PPUEXT) : varutils.pp $(OBJPASDIR)/cvarutil.inc \
objpas$(PPUEXT) $(OBJPASDIR)/varutilh.inc objpas$(PPUEXT) $(OBJPASDIR)/varutilh.inc
$(COMPILER) -I$(OBJPASDIR) varutils.pp $(COMPILER) -I$(OBJPASDIR) varutils.pp
freebidi$(PPUEXT) : $(OBJPASDIR)/freebidi.pp
utf8bidi$(PPUEXT) : $(OBJPASDIR)/utf8bidi.pp utf8bidi$(PPUEXT) : $(OBJPASDIR)/utf8bidi.pp
$(COMPILER) -Sc $(OBJPASDIR)/utf8bidi.pp $(COMPILER) -Sc $(OBJPASDIR)/utf8bidi.pp freebidi.ppu
variants$(PPUEXT) : $(INC)/variants.pp varutils$(PPUEXT) variants$(PPUEXT) : $(INC)/variants.pp varutils$(PPUEXT)
types$(PPUEXT) : $(OBJPASDIR)/types.pp objpas$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT) types$(PPUEXT) : $(OBJPASDIR)/types.pp objpas$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT)
$(COMPILER) $(OBJPASDIR)/types.pp $(COMPILER) $(OBJPASDIR)/types.pp
@ -1459,6 +1460,9 @@ heaptrc$(PPUEXT) : $(INC)/heaptrc.pp $(SYSTEMUNIT)$(PPUEXT)
lineinfo$(PPUEXT) : $(INC)/lineinfo.pp $(SYSTEMUNIT)$(PPUEXT) lineinfo$(PPUEXT) : $(INC)/lineinfo.pp $(SYSTEMUNIT)$(PPUEXT)
charset$(PPUEXT) : $(INC)/charset.pp $(SYSTEMUNIT)$(PPUEXT) charset$(PPUEXT) : $(INC)/charset.pp $(SYSTEMUNIT)$(PPUEXT)
ucomplex$(PPUEXT) : $(INC)/ucomplex.pp math$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT) ucomplex$(PPUEXT) : $(INC)/ucomplex.pp math$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT)
mouse$(PPUEXT) : $(INC)/mouseh.inc $(SYSTEMUNIT)$(PPUEXT)
video$(PPUEXT) : $(INC)/video.inc $(SYSTEMUNIT)$(PPUEXT)
keyboard$(PPUEXT) : $(INC)/keyboard.inc $(INC)/keybrdh.inc $(SYSTEMUNIT)$(PPUEXT)
callspec$(PPUEXT) : $(INC)/callspec.pp $(SYSTEMUNIT)$(PPUEXT) callspec$(PPUEXT) : $(INC)/callspec.pp $(SYSTEMUNIT)$(PPUEXT)
aio$(PPUEXT) : aio.pp $(SYSTEMUNIT)$(PPUEXT) aio$(PPUEXT) : aio.pp $(SYSTEMUNIT)$(PPUEXT)
override INSTALLPPUFILES+=nwsnut.imp ws2_32.imp ws2nlm.imp libc.imp netware.imp \ override INSTALLPPUFILES+=nwsnut.imp ws2_32.imp ws2nlm.imp libc.imp netware.imp \

14
rtl/netwlibc/Makefile.fpc
View File

@ -14,8 +14,8 @@ units=$(SYSTEMUNIT) objpas macpas strings \
cpu mmx getopts \ cpu mmx getopts \
dateutils strutils convutils \ dateutils strutils convutils \
charset ucomplex variants \ charset ucomplex variants \
rtlconst math varutils utf8bidi \ rtlconst math varutils freebidi utf8bidi \
mouse mouse video keyboard
rsts=math varutils variants convutils typinfo systhrds classes dateutils sysconst rtlconst rsts=math varutils variants convutils typinfo systhrds classes dateutils sysconst rtlconst
@ -173,8 +173,10 @@ varutils$(PPUEXT) : varutils.pp $(OBJPASDIR)/cvarutil.inc \
objpas$(PPUEXT) $(OBJPASDIR)/varutilh.inc objpas$(PPUEXT) $(OBJPASDIR)/varutilh.inc
$(COMPILER) -I$(OBJPASDIR) varutils.pp $(COMPILER) -I$(OBJPASDIR) varutils.pp
freebidi$(PPUEXT) : $(OBJPASDIR)/freebidi.pp
utf8bidi$(PPUEXT) : $(OBJPASDIR)/utf8bidi.pp utf8bidi$(PPUEXT) : $(OBJPASDIR)/utf8bidi.pp
$(COMPILER) -Sc $(OBJPASDIR)/utf8bidi.pp $(COMPILER) -Sc $(OBJPASDIR)/utf8bidi.pp freebidi.ppu
variants$(PPUEXT) : $(INC)/variants.pp varutils$(PPUEXT) variants$(PPUEXT) : $(INC)/variants.pp varutils$(PPUEXT)
@ -223,6 +225,12 @@ charset$(PPUEXT) : $(INC)/charset.pp $(SYSTEMUNIT)$(PPUEXT)
ucomplex$(PPUEXT) : $(INC)/ucomplex.pp math$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT) ucomplex$(PPUEXT) : $(INC)/ucomplex.pp math$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT)
mouse$(PPUEXT) : $(INC)/mouseh.inc $(SYSTEMUNIT)$(PPUEXT)
video$(PPUEXT) : $(INC)/video.inc $(SYSTEMUNIT)$(PPUEXT)
keyboard$(PPUEXT) : $(INC)/keyboard.inc $(INC)/keybrdh.inc $(SYSTEMUNIT)$(PPUEXT)
# #
# Other system-dependent RTL Units # Other system-dependent RTL Units

174
rtl/netwlibc/dos.pp
View File

@ -35,6 +35,7 @@ Type
{ Internals used by netware port only: } { Internals used by netware port only: }
_mask : string[255]; _mask : string[255];
_dir : string[255]; _dir : string[255];
_attr : word;
end; end;
registers = packed record registers = packed record
@ -45,6 +46,9 @@ Type
end; end;
{$i dosh.inc} {$i dosh.inc}
{Extra Utils}
function weekday(y,m,d : longint) : longint;
implementation implementation
@ -63,10 +67,34 @@ function dosversion : word;
var i : Tutsname; var i : Tutsname;
begin begin
if uname (i) >= 0 then if uname (i) >= 0 then
dosversion := WORD (i.netware_major) SHL 8 + i.netware_minor dosversion := WORD (i.netware_minor) SHL 8 + i.netware_major
else dosversion := $0005; else dosversion := $0005;
end; end;
function WeekDay (y,m,d:longint):longint;
{
Calculates th day of the week. returns -1 on error
}
var
u,v : longint;
begin
if (m<1) or (m>12) or (y<1600) or (y>4000) or
(d<1) or (d>30+((m+ord(m>7)) and 1)-ord(m=2)) or
((m*d=58) and (((y mod 4>0) or (y mod 100=0)) and (y mod 400>0))) then
WeekDay:=-1
else
begin
u:=m;
v:=y;
if m<3 then
begin
inc(u,12);
dec(v);
end;
WeekDay:=(d+2*u+((3*(u+1)) div 5)+v+(v div 4)-(v div 100)+(v div 400)+1) mod 7;
end;
end;
procedure getdate(var year,month,mday,wday : word); procedure getdate(var year,month,mday,wday : word);
var var
@ -148,9 +176,12 @@ var c : comstr;
args : array[0..maxargs] of pchar; args : array[0..maxargs] of pchar;
arg0 : pathstr; arg0 : pathstr;
numargs,wstat : integer; numargs,wstat : integer;
Wiring : TWiring;
begin begin
//writeln ('dos.exec (',path,',',comline,')'); if pos ('.',path) = 0 then
arg0 := fexpand (path)+#0; arg0 := fexpand(path+'.nlm'#0) else
arg0 := fexpand (path)+#0;
//writeln (stderr,'dos.exec (',path,',',comline,') arg0:"',copy(arg0,1,length(arg0)-1),'"');
args[0] := @arg0[1]; args[0] := @arg0[1];
numargs := 0; numargs := 0;
c:=comline; c:=comline;
@ -170,7 +201,20 @@ begin
end; end;
args[numargs+1] := nil; args[numargs+1] := nil;
// i := spawnvp (P_WAIT,args[0],@args); // i := spawnvp (P_WAIT,args[0],@args);
i := procve(args[0], PROC_CURRENT_SPACE+PROC_INHERIT_CWD,nil,nil,nil,nil,0,nil,args); Wiring.infd := StdInputHandle; //textrec(Stdin).Handle;
Wiring.outfd:= textrec(stdout).Handle;
Wiring.errfd:= textrec(stderr).Handle;
//writeln (stderr,'calling procve');
i := procve(args[0],
PROC_CURRENT_SPACE+PROC_INHERIT_CWD,
envP, // const char * env[] If passed as NULL, the child process inherits the parent.s environment at the time of the call.
@Wiring, // wiring_t *wiring, Pass NULL to inherit system defaults for wiring.
nil, // struct fd_set *fds, Not currently implemented. Pass in NULL.
nil, // void *appdata, Not currently implemented. Pass in NULL.
0, // size_t appdata_size, Not currently implemented. Pass in 0
nil, // void *reserved, Reserved. Pass NULL.
@args); // const char *argv[]
//writeln (stderr,'Ok');
if i <> -1 then if i <> -1 then
begin begin
waitpid(i,@wstat,0); waitpid(i,@wstat,0);
@ -330,12 +374,13 @@ end;
--- Findfirst FindNext --- --- Findfirst FindNext ---
******************************************************************************} ******************************************************************************}
{returns true if attributes match}
procedure find_setfields (var f : searchRec); function find_setfields (var f : searchRec) : boolean;
var var
StatBuf : TStat; StatBuf : TStat;
fname : string[255]; fname : string[255];
begin begin
find_setfields := false;
with F do with F do
begin begin
if Magic = $AD01 then if Magic = $AD01 then
@ -351,6 +396,13 @@ begin
timet2dostime (StatBuf.st_mtim.tv_sec, time) timet2dostime (StatBuf.st_mtim.tv_sec, time)
else else
time := 0; time := 0;
if (f._attr and hidden) = 0 then
if attr and hidden > 0 then exit;
if (f._attr and Directory) = 0 then
if attr and Directory > 0 then exit;
if (f._attr and SysFile) = 0 then
if attr and SysFile > 0 then exit;
find_setfields := true;
end else end else
begin begin
FillChar (f,sizeof(f),0); FillChar (f,sizeof(f),0);
@ -370,25 +422,26 @@ begin
doserror := 18; doserror := 18;
exit; exit;
end; end;
if (pos ('?',path) > 0) or (pos ('*',path) > 0) then f._attr := attr;
p := length (path);
while (p > 0) and (not (path[p] in ['\','/'])) do
dec (p);
if p > 0 then
begin begin
p := length (path); f._mask := copy (path,p+1,255);
while (p > 0) and (not (path[p] in ['\','/'])) do f._dir := copy (path,1,p);
dec (p); strpcopy(path0,f._dir);
if p > 0 then end else
begin begin
f._mask := copy (path,p+1,255); f._mask := path;
f._dir := copy (path,1,p); getdir (0,f._dir);
strpcopy(path0,f._dir); if (f._dir[length(f._dir)] <> '/') and
end else (f._dir[length(f._dir)] <> '\') then
begin f._dir := f._dir + '/';
f._mask := path; strpcopy(path0,f._dir);
getdir (0,f._dir);
if (f._dir[length(f._dir)] <> '/') and
(f._dir[length(f._dir)] <> '\') then
f._dir := f._dir + '/';
end;
end; end;
if f._mask = '*' then f._mask := '';
if f._mask = '*.*' then f._mask := '';
//writeln (stderr,'mask: "',f._mask,'" dir:"',path0,'"'); //writeln (stderr,'mask: "',f._mask,'" dir:"',path0,'"');
f._mask := f._mask + #0; f._mask := f._mask + #0;
Pdirent(f.DirP) := opendir (path0); Pdirent(f.DirP) := opendir (path0);
@ -414,15 +467,11 @@ begin
if F.EntryP = nil then if F.EntryP = nil then
doserror := 18 doserror := 18
else else
if f._mask = #0 then if find_setfields (f) then
begin begin
find_setfields (f); if f._mask = #0 then exit;
exit; if fnmatch(@f._mask[1],Pdirent(f.EntryP)^.d_name,FNM_CASEFOLD) = 0 then
end else exit;
if fnmatch(@f._mask[1],Pdirent(f.EntryP)^.d_name,FNM_CASEFOLD) = 0 then
begin
find_setfields (f);
exit;
end; end;
until doserror <> 0; until doserror <> 0;
end; end;
@ -574,7 +623,7 @@ var
StatBuf : TStat; StatBuf : TStat;
begin begin
doserror := 0; doserror := 0;
if fstat (FileRec (f).Handle, StatBuf) = 0 then if fstat (filerec (f).handle, StatBuf) = 0 then
timet2dostime (StatBuf.st_mtim.tv_sec,time) timet2dostime (StatBuf.st_mtim.tv_sec,time)
else begin else begin
time := 0; time := 0;
@ -584,9 +633,36 @@ end;
procedure setftime(var f;time : longint); procedure setftime(var f;time : longint);
begin Var
{is there a netware function to do that ?????} utim: utimbuf;
ConsolePrintf ('warning: fpc dos.setftime not implemented'#13#10); DT: DateTime;
path: pathstr;
tm : TTm;
Begin
doserror:=0;
with utim do
begin
actime:=libc.time(nil); // getepochtime;
UnPackTime(Time,DT);
with tm do
begin
tm_sec := DT.Sec; // seconds after the minute [0..59]
tm_min := DT.Min; // minutes after the hour [0..59]
tm_hour := DT.hour; // hours since midnight [0..23]
tm_mday := DT.Day; // days of the month [1..31]
tm_mon := DT.month-1; // months since January [0..11]
tm_year := DT.year-1900;
tm_wday := -1;
tm_yday := -1;
tm_isdst := -1;
end;
modtime:=mktime(tm);
end;
if utime(@filerec(f).name,utim)<0 then
begin
Time:=0;
doserror:=3;
end;
end; end;
@ -594,7 +670,7 @@ procedure getfattr(var f;var attr : word);
VAR StatBuf : TStat; VAR StatBuf : TStat;
begin begin
doserror := 0; doserror := 0;
if fstat (FileRec (f).Handle, StatBuf) = 0 then if stat (@textrec(f).name, StatBuf) = 0 then
attr := nwattr2dosattr (StatBuf.st_mode) attr := nwattr2dosattr (StatBuf.st_mode)
else else
begin begin
@ -609,10 +685,10 @@ var
StatBuf : TStat; StatBuf : TStat;
newMode : longint; newMode : longint;
begin begin
if fstat (FileRec(f).Handle,StatBuf) = 0 then if stat (@textrec(f).name,StatBuf) = 0 then
begin begin
newmode := StatBuf.st_mode and ($FFFFFFFF - M_A_RDONLY-M_A_HIDDEN-M_A_SYSTEM-M_A_ARCH); {only this can be set by dos unit} newmode := StatBuf.st_mode and ($FFFF0000 - M_A_RDONLY-M_A_HIDDEN-M_A_SYSTEM-M_A_ARCH); {only this can be set by dos unit}
newmode := newmode and M_A_BITS_SIGNIFICANT; {set netware attributes} newmode := newmode or M_A_BITS_SIGNIFICANT; {set netware attributes}
if attr and readonly > 0 then if attr and readonly > 0 then
newmode := newmode or M_A_RDONLY; newmode := newmode or M_A_RDONLY;
if attr and hidden > 0 then if attr and hidden > 0 then
@ -621,7 +697,7 @@ begin
newmode := newmode or M_A_SYSTEM; newmode := newmode or M_A_SYSTEM;
if attr and archive > 0 then if attr and archive > 0 then
newmode := newmode or M_A_ARCH; newmode := newmode or M_A_ARCH;
if fchmod (FileRec(f).Handle,newMode) < 0 then if chmod (@textrec(f).name,newMode) < 0 then
doserror := ___errno^ else doserror := ___errno^ else
doserror := 0; doserror := 0;
end else end else
@ -677,6 +753,7 @@ end;
Function GetEnv(envvar: string): string; Function GetEnv(envvar: string): string;
var envvar0 : array[0..512] of char; var envvar0 : array[0..512] of char;
p : pchar; p : pchar;
SearchElement : string[255];
i,isDosPath,res : longint; i,isDosPath,res : longint;
begin begin
if upcase(envvar) = 'PATH' then if upcase(envvar) = 'PATH' then
@ -684,13 +761,16 @@ begin
// return it here (needed for the compiler) // return it here (needed for the compiler)
GetEnv := ''; GetEnv := '';
i := 1; i := 1;
res := GetSearchPathElement (i, isdosPath, @envvar0[0]); res := GetSearchPathElement (i, isdosPath, @SearchElement[0]);
while res = 0 do while res = 0 do
begin begin
if GetEnv <> '' then GetEnv := GetEnv + ';'; if isDosPath = 0 then
GetEnv := GetEnv + envvar0; begin
if GetEnv <> '' then GetEnv := GetEnv + ';';
GetEnv := GetEnv + SearchElement;
end;
inc (i); inc (i);
res := GetSearchPathElement (i, isdosPath, @envvar0[0]); res := GetSearchPathElement (i, isdosPath, @SearchElement[0]);
end; end;
for i := 1 to length(GetEnv) do for i := 1 to length(GetEnv) do
if GetEnv[i] = '\' then if GetEnv[i] = '\' then
@ -741,7 +821,11 @@ end;
end. end.
{ {
$Log$ $Log$
Revision 1.1 2004-09-05 20:58:47 armin Revision 1.2 2004-09-12 20:51:22 armin
* added keyboard and video
* a lot of fixes
Revision 1.1 2004/09/05 20:58:47 armin
* first rtl version for netwlibc * first rtl version for netwlibc
} }

150
rtl/netwlibc/keyboard.pp Normal file
View File

@ -0,0 +1,150 @@
{
$Id$
This file is part of the Free Pascal run time library.
Copyright (c) 1999-2004 by the Free Pascal development team.
Keyboard unit for netware libc
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 Keyboard;
interface
{$i keybrdh.inc}
implementation
uses Libc;
{$i keyboard.inc}
procedure SysInitKeyboard;
begin
PendingKeyEvent := 0;
end;
function SysGetKeyEvent: TKeyEvent;
var Ktype,Kvalue,Kstatus,Kscancode : byte;
begin
if PendingKeyEvent<>0 then
begin
SysGetKeyEvent:=PendingKeyEvent;
PendingKeyEvent:=0;
exit;
end;
Libc.GetKey(Libc.GetScreenHandle,Ktype,Kvalue,Kstatus,Kscancode,0{ ??? linesToProtect:size_t});
with TKeyRecord (SysGetKeyEvent) do
begin
Case Ktype of
ENTER_KEY : begin
KeyCode := $1c0d; Flags := 3;
end;
ESCAPE_KEY : begin
KeyCode := $011b; Flags := 3;
end;
BACKSPACE_KEY : begin
KeyCode := $0e08; Flags := 3;
end;
NORMAL_KEY : begin
if KStatus AND ALT_KEY_HELD > 0 then KValue := 0;
IF (KValue = 9) and ((KStatus and SHIFT_KEY_HELD) > 0) then KValue := 0;
KeyCode := (Kscancode shl 8) + KValue;
Flags := 3;
end;
FUNCTION_KEY,
DELETE_KEY,
INSERT_KEY,
CURSOR_DOWN_KEY,
CURSOR_UP_KEY,
CURSOR_RIGHT_KEY,
CURSOR_LEFT_KEY,
CURSOR_HOME_KEY,
CURSOR_END_KEY,
CURSOR_PUP_KEY,
CURSOR_PDOWN_KEY : begin
KeyCode := KScancode shl 8;
Flags := 3;
end;
end;
ShiftState := 0;
if KStatus AND SHIFT_KEY_HELD > 0 then ShiftState := ShiftState or kbShift;
if KStatus AND CTRL_KEY_HELD > 0 then ShiftState := ShiftState or kbCtrl;
if KStatus AND ALT_KEY_HELD > 0 then ShiftState := ShiftState or kbAlt;
end;
end;
function SysPollKeyEvent: TKeyEvent;
begin
if PendingKeyEvent<>0 then
exit(PendingKeyEvent);
if Libc.CheckKeyStatus (Libc.GetScreenHandle) <> 0 then
begin
PendingKeyEvent := SysGetKeyEvent;
SysPollKeyEvent := PendingKeyEvent;
end else
begin
SysPollKeyEvent := 0;
//NXThreadYield;
Delay(50);
end;
end;
function SysPollShiftStateEvent: TKeyEvent;
begin
SysPollShiftStateEvent:=0;
end;
function SysGetShiftState: Byte;
begin
SysGetShiftState:=0;
end;
function SysTranslateKeyEvent(KeyEvent: TKeyEvent): TKeyEvent;
begin
{if KeyEvent and $03000000 = $03000000 then
KeyEvent := KeyEvent - $03000000;}
SysTranslateKeyEvent := KeyEvent;
end;
Const
SysKeyboardDriver : TKeyboardDriver = (
InitDriver : Nil;
DoneDriver : Nil;
GetKeyevent : @SysGetKeyEvent;
PollKeyEvent : @SysPollKeyEvent;
GetShiftState : @SysGetShiftState;
TranslateKeyEvent : nil; //@SysTranslateKeyEvent;
TranslateKeyEventUnicode : Nil;
);
begin
KeyboardInitialized := false;
PendingKeyEvent := 0;
SetKeyBoardDriver(SysKeyBoardDriver);
end.
{
$Log$
Revision 1.1 2004-09-12 20:51:22 armin
* added keyboard and video
* a lot of fixes
Revision 1.4 2002/09/07 16:01:20 peter
* old logs removed and tabs fixed
Revision 1.3 2002/03/08 19:02:59 armin
Changes for new style (TKeyboardDriver record)
}

56
rtl/netwlibc/libc.pp
View File

@ -807,8 +807,8 @@ function getopt(argc:longint; argv:array of Pchar; optstr:Pchar):longint;cdecl;e
function Fpioctl(_para1:longint; _para2:longint; args:array of const):longint;cdecl;external libc_nlm name 'ioctl'; function Fpioctl(_para1:longint; _para2:longint; args:array of const):longint;cdecl;external libc_nlm name 'ioctl';
{$endif} {$endif}
function Fpioctl(_para1:longint; _para2:longint):longint;cdecl;external libc_nlm name 'ioctl'; function Fpioctl(_para1:longint; _para2:longint):longint;cdecl;external libc_nlm name 'ioctl';
function isatty(fildes:longint):longint;cdecl;external libc_nlm name 'isatty'; function Fpisatty(fildes:longint):longint;cdecl;external libc_nlm name 'isatty';
function lseek(fildes:longint; offset:off_t; whence:longint):off_t;cdecl;external libc_nlm name 'lseek'; //function lseek(fildes:longint; offset:off_t; whence:longint):off_t;cdecl;external libc_nlm name 'lseek';
function fplseek(fildes:longint; offset:off_t; whence:longint):off_t;cdecl;external libc_nlm name 'lseek'; function fplseek(fildes:longint; offset:off_t; whence:longint):off_t;cdecl;external libc_nlm name 'lseek';
function pathconf(path:Pchar; name:longint):longint;cdecl;external libc_nlm name 'pathconf'; function pathconf(path:Pchar; name:longint):longint;cdecl;external libc_nlm name 'pathconf';
@ -827,7 +827,6 @@ function sysconf(name:longint):longint;cdecl;external libc_nlm name 'sysconf';
function unlink(path:Pchar):longint;cdecl;external libc_nlm name 'unlink'; function unlink(path:Pchar):longint;cdecl;external libc_nlm name 'unlink';
function FpUnlink(path:Pchar):longint;cdecl;external libc_nlm name 'unlink'; function FpUnlink(path:Pchar):longint;cdecl;external libc_nlm name 'unlink';
function {$ifdef INCLUDED_FROM_SYSTEM}libc_write{$else}_write{$endif}(fildes:longint; buf:pointer; nbytes:size_t):ssize_t;cdecl;external libc_nlm name 'write';
function FpWrite(fildes:longint; buf:pointer; nbytes:size_t):ssize_t;cdecl;external libc_nlm name 'write'; function FpWrite(fildes:longint; buf:pointer; nbytes:size_t):ssize_t;cdecl;external libc_nlm name 'write';
function FpWrite(fildes:longint; var buf; nbytes:size_t):ssize_t;cdecl;external libc_nlm name 'write'; function FpWrite(fildes:longint; var buf; nbytes:size_t):ssize_t;cdecl;external libc_nlm name 'write';
{ appeared in BSD... } { appeared in BSD... }
@ -850,12 +849,17 @@ function FpSleep(seconds:dword):dword;cdecl;external libc_nlm name 'sleep';
function usleep(useconds:useconds_t):longint;cdecl;external libc_nlm name 'usleep'; function usleep(useconds:useconds_t):longint;cdecl;external libc_nlm name 'usleep';
{ nonstandard (transitional) addtions for 64-bit file I/O... } { nonstandard (transitional) addtions for 64-bit file I/O... }
function chsize64(fildes:longint; size:size64_t):longint;cdecl;external libc_nlm name 'chsize64'; function chsize64(fildes:longint; size:size64_t):longint;cdecl;external libc_nlm name 'chsize64';
function Fpchsize64(fildes:longint; size:size64_t):longint;cdecl;external libc_nlm name 'chsize64';
function ftruncate64(fildes:longint; len:off64_t):longint;cdecl;external libc_nlm name 'ftruncate64'; function ftruncate64(fildes:longint; len:off64_t):longint;cdecl;external libc_nlm name 'ftruncate64';
function Fpftruncate64(fildes:longint; len:off64_t):longint;cdecl;external libc_nlm name 'ftruncate64';
function lseek64(fildes:longint; offset:off64_t; whence:longint):off64_t;cdecl;external libc_nlm name 'lseek64'; function lseek64(fildes:longint; offset:off64_t; whence:longint):off64_t;cdecl;external libc_nlm name 'lseek64';
function Fplseek64(fildes:longint; offset:off64_t; whence:longint):off64_t;cdecl;external libc_nlm name 'lseek64';
function pread64(fildes:longint; buf:pointer; nbytes:size_t; off:off64_t):ssize_t;cdecl;external libc_nlm name 'pread64'; function pread64(fildes:longint; buf:pointer; nbytes:size_t; off:off64_t):ssize_t;cdecl;external libc_nlm name 'pread64';
function pwrite64(fildes:longint; buf:pointer; nbytes:size_t; off:off64_t):ssize_t;cdecl;external libc_nlm name 'pwrite64'; function pwrite64(fildes:longint; buf:pointer; nbytes:size_t; off:off64_t):ssize_t;cdecl;external libc_nlm name 'pwrite64';
function tell64(fildes:longint):off64_t;cdecl;external libc_nlm name 'tell64'; function tell64(fildes:longint):off64_t;cdecl;external libc_nlm name 'tell64';
function Fptell64(fildes:longint):off64_t;cdecl;external libc_nlm name 'tell64';
function ____environ:PPPchar;cdecl;external libc_nlm name '____environ'; function ____environ:PPPchar;cdecl;external libc_nlm name '____environ';
function ___optarg:PPchar;cdecl;external libc_nlm name '___optarg'; function ___optarg:PPchar;cdecl;external libc_nlm name '___optarg';
function ___optind:Plongint;cdecl;external libc_nlm name '___optind'; function ___optind:Plongint;cdecl;external libc_nlm name '___optind';
@ -1179,7 +1183,7 @@ type
tm_year : longint; // years since 1900 [0..ì] tm_year : longint; // years since 1900 [0..ì]
tm_wday : longint; // days since Sunday [0..6] tm_wday : longint; // days since Sunday [0..6]
tm_yday : longint; // days since first of January [0..365] tm_yday : longint; // days since first of January [0..365]
tm_isdst : longint; // on summer time (-1 unknown, 0 no, !0 yes) tm_isdst: longint; // on summer time (-1 unknown, 0 no, !0 yes)
end; end;
Ptimespec = ^Ttimespec; Ptimespec = ^Ttimespec;
@ -1384,10 +1388,14 @@ type
{ operations on struct timeval; note timercmp() does not work for >= or <= } { operations on struct timeval; note timercmp() does not work for >= or <= }
function gettimeofday(tp:Ptimeval; tpz:Ptimezone):longint;cdecl;external libc_nlm name 'gettimeofday'; function gettimeofday(tp:Ptimeval; tpz:Ptimezone):longint;cdecl;external libc_nlm name 'gettimeofday';
function Fpgettimeofday(tp:Ptimeval; tpz:Ptimezone):longint;cdecl;external libc_nlm name 'gettimeofday';
function settimeofday(tp:Ptimeval; tpz:Ptimezone):longint;cdecl;external libc_nlm name 'settimeofday'; function settimeofday(tp:Ptimeval; tpz:Ptimezone):longint;cdecl;external libc_nlm name 'settimeofday';
function gettimeofday(var tp:Ttimeval; var tpz:Ttimezone):longint;cdecl;external libc_nlm name 'gettimeofday'; function gettimeofday(var tp:Ttimeval; var tpz:Ttimezone):longint;cdecl;external libc_nlm name 'gettimeofday';
function settimeofday(var tp:Ttimeval; var tpz:Ttimezone):longint;cdecl;external libc_nlm name 'settimeofday'; function settimeofday(var tp:Ttimeval; var tpz:Ttimezone):longint;cdecl;external libc_nlm name 'settimeofday';
function Fpgettimeofday(var tp:Ttimeval; var tpz:Ttimezone):longint;cdecl;external libc_nlm name 'gettimeofday';
function Fpsettimeofday(var tp:Ttimeval; var tpz:Ttimezone):longint;cdecl;external libc_nlm name 'settimeofday';
{ turn on 1-byte packing... } { turn on 1-byte packing... }
@ -1875,7 +1883,8 @@ type
(** unsupported pragma#pragma pack()*) (** unsupported pragma#pragma pack()*)
//!! function statfs(path:Pchar; buf:Pstatfs):longint;cdecl;external libc_nlm name 'statfs'; function statfs(path:Pchar; buf:Pstatfs):longint;cdecl;external libc_nlm name 'statfs';
function statfs(path:Pchar; var buf:Tstatfs):longint;cdecl;external libc_nlm name 'statfs';
function fstatfs(fildes:longint; buf:Pstatfs):longint;cdecl;external libc_nlm name 'fstatfs'; function fstatfs(fildes:longint; buf:Pstatfs):longint;cdecl;external libc_nlm name 'fstatfs';
function fstatfs(fildes:longint; var buf:Tstatfs):longint;cdecl;external libc_nlm name 'fstatfs'; function fstatfs(fildes:longint; var buf:Tstatfs):longint;cdecl;external libc_nlm name 'fstatfs';
@ -3432,11 +3441,11 @@ type
BACKSPACE = $08; BACKSPACE = $08;
{ modifier code constituents... } { modifier code constituents... }
SHIFT_KEY_HELD = $01; SHIFT_KEY_HELD = $01;
CTRL_KEY_HELD = $02; CTRL_KEY_HELD = $04;
ALT_KEY_HELD = $04; ALT_KEY_HELD = $08;
CAPS_LOCK_IS_ON = $10; CAPS_LOCK_IS_ON = $40;
NUM_LOCK_IS_ON = $20; NUM_LOCK_IS_ON = $20;
SCROLL_LOCK_IS_ON = $40; SCROLL_LOCK_IS_ON = $10;
{ suggested 'maxlen' argument for getpassword()... } { suggested 'maxlen' argument for getpassword()... }
_PASSWORD_LEN = 128; _PASSWORD_LEN = 128;
{ string-embeddable color representations... } { string-embeddable color representations... }
@ -3611,6 +3620,7 @@ function GetActiveScreen:scr_t;cdecl;external system_nlm name 'GetActiveScreen';
function GetActualScreenSize(scrID:scr_t; height:Pdword; width:Pdword; bufferSize:Psize_t):longint;cdecl;external system_nlm name 'GetActualScreenSize'; function GetActualScreenSize(scrID:scr_t; height:Pdword; width:Pdword; bufferSize:Psize_t):longint;cdecl;external system_nlm name 'GetActualScreenSize';
function GetConsoleSecuredFlag:longint;cdecl;external libc_nlm name 'GetConsoleSecuredFlag'; function GetConsoleSecuredFlag:longint;cdecl;external libc_nlm name 'GetConsoleSecuredFlag';
procedure GetCursorStyle(scrID:scr_t; cursorStyle:Pword);cdecl;external system_nlm name 'GetCursorStyle'; procedure GetCursorStyle(scrID:scr_t; cursorStyle:Pword);cdecl;external system_nlm name 'GetCursorStyle';
procedure GetCursorStyle(scrID:scr_t; var cursorStyle:word);cdecl;external system_nlm name 'GetCursorStyle';
procedure GetInputCursorPosition(scrID:scr_t; row:Pword; col:Pword);cdecl;external system_nlm name 'GetInputCursorPosition'; procedure GetInputCursorPosition(scrID:scr_t; row:Pword; col:Pword);cdecl;external system_nlm name 'GetInputCursorPosition';
procedure GetKey(scrID:scr_t; _type,value,status,scancode:Pbyte;linesToProtect:size_t);cdecl;external system_nlm name 'GetKey'; procedure GetKey(scrID:scr_t; _type,value,status,scancode:Pbyte;linesToProtect:size_t);cdecl;external system_nlm name 'GetKey';
procedure GetKey(scrID:scr_t; var _type,value,status,scancode:byte;linesToProtect:size_t);cdecl;external system_nlm name 'GetKey'; procedure GetKey(scrID:scr_t; var _type,value,status,scancode:byte;linesToProtect:size_t);cdecl;external system_nlm name 'GetKey';
@ -3680,13 +3690,12 @@ function ReadScreenCharacter(scrID:scr_t; line,col:dword; character:Pchar):longi
function RenameScreen(scrID:scr_t; name:Pchar):longint;cdecl;external system_nlm name 'RenameScreen'; function RenameScreen(scrID:scr_t; name:Pchar):longint;cdecl;external system_nlm name 'RenameScreen';
function RestoreFullScreen(scrID:scr_t; buffer:pointer):longint;cdecl;external system_nlm name 'RestoreFullScreen'; function RestoreFullScreen(scrID:scr_t; buffer:pointer):longint;cdecl;external system_nlm name 'RestoreFullScreen';
function RestoreScreenArea(scrID:scr_t; line:dword; col:dword; height:dword; width:dword; function RestoreScreenArea(scrID:scr_t; line,col,height,width:dword; buffer:pointer):longint;cdecl;external system_nlm name 'RestoreScreenArea';
buffer:pointer):longint;cdecl;external system_nlm name 'RestoreScreenArea'; procedure ReturnScreenType(_type,colorFlag:Pdword);cdecl;external system_nlm name 'ReturnScreenType';
procedure ReturnScreenType(_type:Pdword; colorFlag:Pdword);cdecl;external system_nlm name 'ReturnScreenType'; procedure ReturnScreenType(var _type,colorFlag:dword);cdecl;external system_nlm name 'ReturnScreenType';
procedure RingTheBell;cdecl;external system_nlm name 'RingTheBell'; procedure RingTheBell;cdecl;external system_nlm name 'RingTheBell';
function SaveFullScreen(scrID:scr_t; buffer:pointer):longint;cdecl;external system_nlm name 'SaveFullScreen'; function SaveFullScreen(scrID:scr_t; buffer:pointer):longint;cdecl;external system_nlm name 'SaveFullScreen';
function SaveScreenArea(scrID:scr_t; line:dword; col:dword; height:dword; width:dword; function SaveScreenArea(scrID:scr_t; line,col,height,width:dword; buffer:pointer):longint;cdecl;external system_nlm name 'SaveScreenArea';
buffer:pointer):longint;cdecl;external system_nlm name 'SaveScreenArea';
procedure SetConsoleSecuredFlag(value:byte);cdecl;external system_nlm name 'SetConsoleSecuredFlag'; procedure SetConsoleSecuredFlag(value:byte);cdecl;external system_nlm name 'SetConsoleSecuredFlag';
procedure SetCursorStyle(scrID:scr_t; newStyle:word);cdecl;external system_nlm name 'SetCursorStyle'; procedure SetCursorStyle(scrID:scr_t; newStyle:word);cdecl;external system_nlm name 'SetCursorStyle';
procedure SetInputToOutputCursorPosition(scrID:scr_t);cdecl;external system_nlm name 'SetInputToOutputCursorPosition'; procedure SetInputToOutputCursorPosition(scrID:scr_t);cdecl;external system_nlm name 'SetInputToOutputCursorPosition';
@ -5023,8 +5032,9 @@ function chdir2(path:Pchar):longint;cdecl;external libc_nlm name 'chdir2';
function setcwd(pathCtx:NXPathCtx_t):longint;cdecl;external libc_nlm name 'setcwd'; function setcwd(pathCtx:NXPathCtx_t):longint;cdecl;external libc_nlm name 'setcwd';
function setcwd2(pathCtx:NXPathCtx_t):longint;cdecl;external libc_nlm name 'setcwd2'; function setcwd2(pathCtx:NXPathCtx_t):longint;cdecl;external libc_nlm name 'setcwd2';
{ extensions of unistd.h file I/O functions... } { extensions of unistd.h file I/O functions... }
function eof(fildes:longint):longint;cdecl;external libc_nlm name 'eof'; function Fpeof(fildes:longint):longint;cdecl;external libc_nlm name 'eof';
function tell(fildes:longint):off_t;cdecl;external libc_nlm name 'tell'; function tell(fildes:longint):off_t;cdecl;external libc_nlm name 'tell';
function Fptell(fildes:longint):off_t;cdecl;external libc_nlm name 'tell';
{ extensions of sys/stat.h functions... } { extensions of sys/stat.h functions... }
function fgetstat(fildes:longint; buf:Pstat; requestmap:dword):longint;cdecl;external libc_nlm name 'fgetstat'; function fgetstat(fildes:longint; buf:Pstat; requestmap:dword):longint;cdecl;external libc_nlm name 'fgetstat';
@ -8275,18 +8285,21 @@ type
outfd : longint; outfd : longint;
errfd : longint; errfd : longint;
end; end;
TWiring = wiring_t;
PWiring = Pwiring_t;
{$ifndef DisableArrayOfConst} {$ifndef DisableArrayOfConst}
function procle(path:Pchar; flags:dword; env:array of Pchar; wiring:Pwiring_t; fds:Pfd_set; //function procle(path:Pchar; flags:dword; env:array of Pchar; wiring:Pwiring_t; fds:Pfd_set;
appdata:pointer; appdata_size:size_t; reserved:pointer; arg0:Pchar; args:array of const):pid_t;cdecl;external libc_nlm name 'procle'; // appdata:pointer; appdata_size:size_t; reserved:pointer; arg0:Pchar; args:array of const):pid_t;cdecl;external libc_nlm name 'procle';
{$endif} {$endif}
function procle(path:Pchar; flags:dword; env:array of Pchar; wiring:Pwiring_t; fds:Pfd_set; {function procle(path:Pchar; flags:dword; env:array of Pchar; wiring:Pwiring_t; fds:Pfd_set;
appdata:pointer; appdata_size:size_t; reserved:pointer; arg0:Pchar):pid_t;cdecl;external libc_nlm name 'procle'; appdata:pointer; appdata_size:size_t; reserved:pointer; arg0:Pchar):pid_t;cdecl;external libc_nlm name 'procle';
function procve(path:Pchar; flags:dword; env:array of Pchar; wiring:Pwiring_t; fds:Pfd_set; function procve(path:Pchar; flags:dword; env:array of Pchar; wiring:Pwiring_t; fds:Pfd_set;
appdata:pointer; appdata_size:size_t; reserved:pointer; argv:array of Pchar):pid_t;cdecl;external libc_nlm name 'procve'; appdata:pointer; appdata_size:size_t; reserved:pointer; argv:array of Pchar):pid_t;cdecl;external libc_nlm name 'procve';}
function procve(path:Pchar; flags:dword; env:pointer; wiring:Pwiring_t; fds:Pfd_set; function procve(path:Pchar; flags:dword; env:pointer; wiring:Pwiring_t; fds:Pfd_set;
appdata:pointer; appdata_size:size_t; reserved:pointer; argv:array of Pchar):pid_t;cdecl;external libc_nlm name 'procve'; appdata:pointer; appdata_size:size_t; reserved:pointer; argv:ppchar):pid_t;cdecl;external libc_nlm name 'procve';
function procle(path:Pchar; flags:dword; env:pointer; wiring:Pwiring_t; fds:Pfd_set;
appdata:pointer; appdata_size:size_t; reserved:pointer; arg0:Pchar; args:ppchar):pid_t;cdecl;external libc_nlm name 'procle';
// pthread.h // pthread.h
// sched.h // sched.h
@ -9096,6 +9109,7 @@ type
actime : time_t; actime : time_t;
modtime : time_t; modtime : time_t;
end; end;
utimbuf = Tutimbuf;
(** unsupported pragma#pragma pack()*) (** unsupported pragma#pragma pack()*)

142
rtl/netwlibc/system.pp
View File

@ -92,6 +92,8 @@ procedure NWSysSetThreadFunctions (crs:TSysCloseAllRemainingSemaphores;
stdata:TSysSetThreadDataAreaPtr); stdata:TSysSetThreadDataAreaPtr);
} }
procedure __ConsolePrintf (s :string);
implementation implementation
{ Indicate that stack checking is taken care by OS} { Indicate that stack checking is taken care by OS}
{$DEFINE NO_GENERIC_STACK_CHECK} {$DEFINE NO_GENERIC_STACK_CHECK}
@ -126,8 +128,6 @@ begin
end;} end;}
procedure PASCALMAIN;external name 'PASCALMAIN'; procedure PASCALMAIN;external name 'PASCALMAIN';
procedure fpc_do_exit;external name 'FPC_DO_EXIT'; procedure fpc_do_exit;external name 'FPC_DO_EXIT';
@ -144,12 +144,14 @@ var SigTermHandlerActive : boolean;
Procedure system_exit; Procedure system_exit;
begin begin
__ConsolePrintf ('system_exit');
//if assigned (CloseAllRemainingSemaphores) then CloseAllRemainingSemaphores; //if assigned (CloseAllRemainingSemaphores) then CloseAllRemainingSemaphores;
//if assigned (ReleaseThreadVars) then ReleaseThreadVars; //if assigned (ReleaseThreadVars) then ReleaseThreadVars;
{$ifdef autoHeapRelease} {$ifdef autoHeapRelease}
FreeSbrkMem; { free memory allocated by heapmanager } FreeSbrkMem; { free memory allocated by heapmanager }
{$endif} {$endif}
__ConsolePrintf ('Heap mem released');
if not SigTermHandlerActive then if not SigTermHandlerActive then
begin begin
@ -216,22 +218,20 @@ end;
*****************************************************************************} *****************************************************************************}
var var
heap : longint;external name 'HEAP'; int_heap : pointer;external name 'HEAP';
intern_heapsize : longint;external name 'HEAPSIZE'; int_heapsize : longint;external name 'HEAPSIZE';
{ first address of heap } { first address of heap }
function getheapstart:pointer; function getheapstart:pointer;
assembler; begin
asm getheapstart := int_heap;
leal HEAP,%eax end;
end ['EAX'];
{ current length of heap } { current length of heap }
function getheapsize:longint; function getheapsize:longint;
assembler; begin
asm getheapsize := int_heapsize;
movl intern_HEAPSIZE,%eax end;
end ['EAX'];
{$ifdef autoHeapRelease} {$ifdef autoHeapRelease}
@ -240,6 +240,7 @@ type THeapSbrkBlockList = array [1.. HeapInitialMaxBlocks] of pointer;
var HeapSbrkBlockList : ^THeapSbrkBlockList = nil; var HeapSbrkBlockList : ^THeapSbrkBlockList = nil;
HeapSbrkLastUsed : dword = 0; HeapSbrkLastUsed : dword = 0;
HeapSbrkAllocated : dword = 0; HeapSbrkAllocated : dword = 0;
HeapSbrkReleased : boolean = false;
{ function to allocate size bytes more for the program } { function to allocate size bytes more for the program }
{ must return the first address of new data space or nil if fail } { must return the first address of new data space or nil if fail }
@ -250,6 +251,11 @@ var P2 : POINTER;
i : longint; i : longint;
Slept : longint; Slept : longint;
begin begin
if HeapSbrkReleased then
begin
__ConsolePrintf ('Error: SysOSFree called after all heap memory was released');
exit(nil);
end;
SysOSAlloc := _Alloc (size,HeapAllocResourceTag); SysOSAlloc := _Alloc (size,HeapAllocResourceTag);
if SysOSAlloc <> nil then begin if SysOSAlloc <> nil then begin
if HeapSbrkBlockList = nil then if HeapSbrkBlockList = nil then
@ -303,6 +309,9 @@ begin
HeapSbrkLastUsed := 0; HeapSbrkLastUsed := 0;
HeapSbrkBlockList := nil; HeapSbrkBlockList := nil;
end; end;
HeapSbrkReleased := true;
{ReturnResourceTag(HeapAllocResourceTag,1);
ReturnResourceTag(HeapListAllocResourceTag,1); not in netware.imp, seems to be not needed}
end; end;
{***************************************************************************** {*****************************************************************************
@ -314,7 +323,10 @@ end;
procedure SysOSFree(p: pointer; size: ptrint); procedure SysOSFree(p: pointer; size: ptrint);
var i : longint; var i : longint;
begin begin
//fpmunmap(p, size); if HeapSbrkReleased then
begin
__ConsolePrintf ('Error: SysOSFree called after all heap memory was released');
end else
if (HeapSbrkLastUsed > 0) then if (HeapSbrkLastUsed > 0) then
for i := 1 to HeapSbrkLastUsed do for i := 1 to HeapSbrkLastUsed do
if (HeapSbrkBlockList^[i] = p) then if (HeapSbrkBlockList^[i] = p) then
@ -380,28 +392,27 @@ BEGIN
end; end;
END; END;
FUNCTION errno : LONGINT; {FUNCTION errno : LONGINT;
BEGIN BEGIN
errno := ___errno^; errno := ___errno^;
END; END;}
PROCEDURE Errno2Inoutres; procedure Errno2Inoutres;
BEGIN begin
NW2PASErr (errno); NW2PASErr (___errno^);
END; end;
PROCEDURE SetFileError (VAR Err : LONGINT); procedure SetFileError (VAR Err : LONGINT);
BEGIN begin
IF Err >= 0 THEN if Err >= 0 then
InOutRes := 0 InOutRes := 0
ELSE else begin
BEGIN // libc_perror ('SetFileError');
libc_perror ('SetFileError'); Err := ___errno^;
Err := errno;
NW2PASErr (Err); NW2PASErr (Err);
Err := 0; Err := 0;
END; end;
END; end;
{ close a file from the handle value } { close a file from the handle value }
procedure do_close(handle : thandle); procedure do_close(handle : thandle);
@ -442,7 +453,7 @@ function do_write(h:thandle;addr:pointer;len : longint) : longint;
var res : LONGINT; var res : LONGINT;
begin begin
{$ifdef IOpossix} {$ifdef IOpossix}
res := libc_write (h,addr,len); res := Fpwrite (h,addr,len);
{$else} {$else}
res := _fwrite (addr,1,len,_TFILE(h)); res := _fwrite (addr,1,len,_TFILE(h));
{$endif} {$endif}
@ -457,7 +468,7 @@ function do_read(h:thandle;addr:pointer;len : longint) : longint;
VAR res : LONGINT; VAR res : LONGINT;
begin begin
{$ifdef IOpossix} {$ifdef IOpossix}
res := libc_write (h,addr,len); res := Fpread (h,addr,len);
{$else} {$else}
res := _fread (addr,1,len,_TFILE(h)); res := _fread (addr,1,len,_TFILE(h));
{$endif} {$endif}
@ -474,7 +485,7 @@ var res : LONGINT;
begin begin
InOutRes:=1; InOutRes:=1;
{$ifdef IOpossix} {$ifdef IOpossix}
res := tell (handle); res := Fptell (handle);
{$else} {$else}
res := _ftell (_TFILE(handle)); res := _ftell (_TFILE(handle));
{$endif} {$endif}
@ -490,7 +501,7 @@ procedure do_seek(handle:thandle;pos : longint);
VAR res : LONGINT; VAR res : LONGINT;
begin begin
{$ifdef IOpossix} {$ifdef IOpossix}
res := lseek (handle,pos, SEEK_SET); res := Fplseek (handle,pos, SEEK_SET);
{$else} {$else}
res := _fseek (_TFILE(handle),pos, SEEK_SET); res := _fseek (_TFILE(handle),pos, SEEK_SET);
{$endif} {$endif}
@ -504,7 +515,7 @@ function do_seekend(handle:thandle):longint;
VAR res : LONGINT; VAR res : LONGINT;
begin begin
{$ifdef IOpossix} {$ifdef IOpossix}
res := lseek (handle,0, SEEK_END); res := Fplseek (handle,0, SEEK_END);
{$else} {$else}
res := _fseek (_TFILE(handle),0, SEEK_END); res := _fseek (_TFILE(handle),0, SEEK_END);
{$endif} {$endif}
@ -619,19 +630,17 @@ Begin
end; end;
{ real open call } { real open call }
FileRec(f).Handle := open(p,oflags,438); FileRec(f).Handle := open(p,oflags,438);
//WriteLn ('_open (',p,') returned ',ErrNo, 'Handle: ',FileRec(f).Handle); if FileRec(f).Handle < 0 then
// errno does not seem to be set on succsess ?? if (___errno^=Sys_EROFS) and ((OFlags and O_RDWR)<>0) then
IF FileRec(f).Handle < 0 THEN
if (ErrNo=Sys_EROFS) and ((OFlags and O_RDWR)<>0) then
begin // i.e. for cd-rom begin // i.e. for cd-rom
Oflags:=Oflags and not(O_RDWR); Oflags:=Oflags and not(O_RDWR);
FileRec(f).Handle := open(p,oflags,438); FileRec(f).Handle := open(p,oflags,438);
end; end;
IF FileRec(f).Handle < 0 THEN if FileRec(f).Handle < 0 then
Errno2Inoutres Errno2Inoutres
ELSE else
InOutRes := 0; InOutRes := 0;
End; end;
{$else} {$else}
@ -723,7 +732,7 @@ End;
function do_isdevice(handle:THandle):boolean; function do_isdevice(handle:THandle):boolean;
begin begin
{$ifdef IOpossix} {$ifdef IOpossix}
do_isdevice := (isatty (handle) > 0); do_isdevice := (Fpisatty (handle) > 0);
{$else} {$else}
do_isdevice := (isatty (_fileno(_TFILE(handle))) > 0); do_isdevice := (isatty (_fileno(_TFILE(handle))) > 0);
{$endif} {$endif}
@ -755,18 +764,18 @@ end;
Directory Handling Directory Handling
*****************************************************************************} *****************************************************************************}
procedure mkdir(const s : string);[IOCheck]; procedure mkdir(const s : string);[IOCheck];
VAR S2 : STRING; var S2 : STRING;
Res: LONGINT; Res: LONGINT;
BEGIN BEGIN
S2 := S; S2 := S;
IF Length (S2) = 255 THEN DEC (BYTE(S2[0])); IF Length (S2) = 255 THEN DEC (BYTE(S2[0]));
S2 := S2 + #0; S2 := S2 + #0;
Res := FpMkdir (@S2[1],0); Res := FpMkdir (@S2[1],S_IRWXU);
IF Res = 0 THEN if Res = 0 then
InOutRes:=0 InOutRes:=0
ELSE else
SetFileError (Res); SetFileError (Res);
END; end;
procedure rmdir(const s : string);[IOCheck]; procedure rmdir(const s : string);[IOCheck];
VAR S2 : STRING; VAR S2 : STRING;
@ -801,7 +810,8 @@ VAR P : ARRAY [0..255] OF CHAR;
i : LONGINT; i : LONGINT;
begin begin
P[0] := #0; P[0] := #0;
getcwd (@P, SIZEOF (P)); //getcwd (@P, SIZEOF (P));
getcwdpath(@P,nil,0);
i := libc_strlen (P); i := libc_strlen (P);
if i > 0 then if i > 0 then
begin begin
@ -837,11 +847,10 @@ procedure InitFPU;assembler;
Unload Anyway ? Unload Anyway ?
To Disable unload at all, SetNLMDontUnloadFlag can be used on To Disable unload at all, SetNLMDontUnloadFlag can be used on
Netware >= 4.0 } Netware >= 4.0 }
(*
function CheckFunction : longint; CDECL; [public,alias: 'FPC_NW_CHECKFUNCTION']; function CheckFunction : longint; CDECL; [public,alias: '_NonAppCheckUnload'];
var oldTG:longint;
oldPtr: pointer;
begin begin
__ConsolePrintf ('CheckFunction');
if assigned (NetwareCheckFunction) then if assigned (NetwareCheckFunction) then
begin begin
{ this function is called without clib context, to allow clib { this function is called without clib context, to allow clib
@ -854,14 +863,22 @@ begin
// oldPtr := SetThreadDataAreaPtr (NIL); { nil means main threadvars } // oldPtr := SetThreadDataAreaPtr (NIL); { nil means main threadvars }
result := 0; result := 0;
NetwareCheckFunction (result); NetwareCheckFunction (result);
if assigned (SetThreadDataAreaPtr) then // if assigned (SetThreadDataAreaPtr) then
SetThreadDataAreaPtr (oldPtr); // SetThreadDataAreaPtr (oldPtr);
_SetThreadGroupID (oldTG); // _SetThreadGroupID (oldTG);
end else end else
result := 0; result := 0;
end; end;
*)
procedure __ConsolePrintf (s : string);
begin
if length(s) > 252 then
byte(s[0]) := 252;
s := s + #13#10#0;
screenprintf (NWLoggerScreen,@s[1]);
end;
{$ifdef StdErrToConsole} {$ifdef StdErrToConsole}
@ -915,14 +932,8 @@ end;
Halt (or _exit) can not be called from this callback procedure } Halt (or _exit) can not be called from this callback procedure }
procedure TermSigHandler (Sig:longint); CDecl; procedure TermSigHandler (Sig:longint); CDecl;
begin begin
writeln ('TermSigHandler start ');
{ _GetThreadDataAreaPtr will not be valid because the signal
handler is called by netware with a differnt thread. To avoid
problems in the exit routines, we set the data of the main thread
here }
SigTermHandlerActive := true; { to avoid that system_exit calls _exit } SigTermHandlerActive := true; { to avoid that system_exit calls _exit }
do_exit; { calls finalize units } do_exit; { calls finalize units }
writeln ('TermSigHandler end ');
end; end;
@ -969,8 +980,9 @@ Begin
{$ifdef StdErrToConsole} {$ifdef StdErrToConsole}
NWLoggerScreen := getnetwarelogger; NWLoggerScreen := getnetwarelogger;
{$endif} {$endif}
CheckFunction; // avoid check function to be removed by the linker
envp := nxGetEnviron; envp := ____environ^; // nxGetEnviron;
NLMHandle := getnlmhandle; NLMHandle := getnlmhandle;
HeapAllocResourceTag := HeapAllocResourceTag :=
AllocateResourceTag(NLMHandle,'Heap Memory',AllocSignature); AllocateResourceTag(NLMHandle,'Heap Memory',AllocSignature);
@ -1001,7 +1013,11 @@ Begin
End. End.
{ {
$Log$ $Log$
Revision 1.1 2004-09-05 20:58:47 armin Revision 1.2 2004-09-12 20:51:22 armin
* added keyboard and video
* a lot of fixes
Revision 1.1 2004/09/05 20:58:47 armin
* first rtl version for netwlibc * first rtl version for netwlibc
} }

248
rtl/netwlibc/sysutils.pp
View File

@ -27,9 +27,13 @@ uses Libc,DOS;
TYPE TYPE
TNetwareLibcFindData = TNetwareLibcFindData =
RECORD RECORD
DirP : Pdirent; { used for opendir } DirP : Pdirent; { used for opendir }
EntryP: Pdirent; { and readdir } EntryP: Pdirent; { and readdir }
Magic : WORD; { to avoid abends with uninitialized TSearchRec } Magic : longint; { to avoid abends with uninitialized TSearchRec }
_mask : string; { search mask i.e. *.* }
_dir : string; { directory where to search }
_attr : longint; { specified attribute }
fname : string; { full pathname of found file }
END; END;
{ Include platform independent interface part } { Include platform independent interface part }
@ -39,27 +43,28 @@ TYPE
{ additional NetWare file flags} { additional NetWare file flags}
CONST CONST
faSHARE = $00000080; { Sharable file } faSHARE = M_A_SHARE shr 16; // Sharable file
faNO_SUBALLOC = $00000800; { Don't sub alloc. this file } //faNO_SUBALLOC = $00000800; // Don't sub alloc. this file
faTRANS = $00001000; { Transactional file (TTS usable) } faTRANS = M_A_TRANS shr 16; // Transactional file (TTS usable)
faREADAUD = $00004000; { Read audit } //faREADAUD = $00004000; // clib only: Read audit
faWRITAUD = $00008000; { Write audit } //faWRITAUD = $00008000; // clib only: Write audit
faIMMPURG = $00010000; { Immediate purge } faIMMPURG = M_A_IMMPURG shr 16; // Immediate purge
faNORENAM = $00020000; { Rename inhibit } faNORENAM = M_A_NORENAM shr 16; // Rename inhibit
faNODELET = $00040000; { Delete inhibit } faNODELET = M_A_NODELET shr 16; // Delete inhibit
faNOCOPY = $00080000; { Copy inhibit } faNOCOPY = M_A_NOCOPY shr 16; // Copy inhibit
faFILE_MIGRATED = $00400000; { File has been migrated } //faFILE_MIGRATED = $00400000; // clib only: File has been migrated
faDONT_MIGRATE = $00800000; { Don't migrate this file } //faDONT_MIGRATE = $00800000; // clib only: Don't migrate this file
faIMMEDIATE_COMPRESS = $02000000; { Compress this file immediately } faIMMEDIATE_COMPRESS = M_A_IMMCOMPRESS shr 16; // Compress this file immediately
faFILE_COMPRESSED = $04000000; { File is compressed } faFILE_COMPRESSED = M_A_FILE_COMPRESSED shr 16; // File is compressed
faDONT_COMPRESS = $08000000; { Don't compress this file } faDONT_COMPRESS = M_A_DONT_COMPRESS shr 16; // Don't compress this file
faCANT_COMPRESS = $20000000; { Can't compress this file } faCANT_COMPRESS = M_A_CANT_COMPRESS shr 16; // Can't compress this file
faATTR_ARCHIVE = $40000000; { Entry has had an EA modified, } //faATTR_ARCHIVE = $40000000; // clib only: Entry has had an EA modified,
{ an ownerID changed, or trustee } // an ownerID changed, or trustee
{ info changed, etc. } // info changed, etc.
faSetNetwareAttrs = M_A_BITS_SIGNIFICANT; // if this is set, netware flags are changed also
@ -85,41 +90,38 @@ BEGIN
1 : NWOpenFlags:=NWOpenFlags or O_WRONLY; 1 : NWOpenFlags:=NWOpenFlags or O_WRONLY;
2 : NWOpenFlags:=NWOpenFlags or O_RDWR; 2 : NWOpenFlags:=NWOpenFlags or O_RDWR;
end; end;
FileOpen := open (pchar(FileName),NWOpenFlags); FileOpen := Fpopen (pchar(FileName),NWOpenFlags);
//!! We need to set locking based on Mode !! //!! We need to set locking based on Mode !!
end; end;
Function FileCreate (Const FileName : String) : Longint; Function FileCreate (Const FileName : String) : Longint;
begin begin
FileCreate:=open(Pchar(FileName),O_RdWr or O_Creat or O_Trunc); FileCreate:=Fpopen(Pchar(FileName),O_RdWr or O_Creat or O_Trunc or O_Binary);
if FileCreate >= 0 then
FileSetAttr (Filename, 0); // dont know why but open always sets ReadOnly flag
end; end;
Function FileCreate (Const FileName : String; mode:longint) : Longint; Function FileCreate (Const FileName : String; mode:longint) : Longint;
begin begin
FileCreate:=FileCreate (FileName); FileCreate:=FileCreate (FileName);
end; end;
Function FileRead (Handle : Longint; Var Buffer; Count : longint) : Longint; Function FileRead (Handle : Longint; Var Buffer; Count : longint) : Longint;
begin begin
FileRead:=libc.fpread (Handle,@Buffer,Count); FileRead:=libc.fpread (Handle,@Buffer,Count);
end; end;
Function FileWrite (Handle : Longint; const Buffer; Count : Longint) : Longint; Function FileWrite (Handle : Longint; const Buffer; Count : Longint) : Longint;
begin begin
FileWrite:=libc.fpwrite (Handle,@Buffer,Count); FileWrite:=libc.fpwrite (Handle,@Buffer,Count);
end; end;
Function FileSeek (Handle,FOffset,Origin : Longint) : Longint; Function FileSeek (Handle,FOffset,Origin : Longint) : Longint;
begin begin
FileSeek:=libc.fplseek (Handle,FOffset,Origin); FileSeek:=libc.fplseek (Handle,FOffset,Origin);
end; end;
@ -127,18 +129,16 @@ end;
Function FileSeek (Handle : Longint; FOffset,Origin : Int64) : Int64; Function FileSeek (Handle : Longint; FOffset,Origin : Int64) : Int64;
begin begin
FileSeek:=libc.fplseek (Handle,FOffset,Origin); FileSeek:=libc.fplseek64 (Handle,FOffset,Origin);
end; end;
Procedure FileClose (Handle : Longint); Procedure FileClose (Handle : Longint);
begin begin
libc.fpclose(Handle); libc.fpclose(Handle);
end; end;
Function FileTruncate (Handle,Size: Longint) : boolean; Function FileTruncate (Handle,Size: Longint) : boolean;
begin begin
FileTruncate:=(libc.fpchsize(Handle,Size) = 0); FileTruncate:=(libc.fpchsize(Handle,Size) = 0);
end; end;
@ -168,20 +168,16 @@ begin
end; end;
Function FileAge (Const FileName : String): Longint; Function FileAge (Const FileName : String): Longint;
var Info : TStat;
VAR Info : TStat; TM : TTM;
_PTM : PTM;
begin begin
If stat (pchar(FileName),Info) <> 0 then If stat (pchar(FileName),Info) <> 0 then
exit(-1) exit(-1)
else else
begin begin
_PTM := localtime (Info.st_mtim.tv_sec); localtime_r (Info.st_mtim.tv_sec,tm);
IF _PTM = NIL THEN with TM do
exit(-1) result:=DateTimeToFileDate(EncodeDate(tm_year+1900,tm_mon+1,tm_mday)+EncodeTime(tm_hour,tm_min,tm_sec,0));
else
WITH _PTM^ DO
Result:=DateTimeToFileDate(EncodeDate(tm_year+1900,tm_mon+1,tm_mday)+EncodeTime(tm_hour,tm_min,tm_sec,0));
end; end;
end; end;
@ -193,7 +189,7 @@ begin
end; end;
(*
PROCEDURE find_setfields (VAR f : TsearchRec); PROCEDURE find_setfields (VAR f : TsearchRec);
VAR T : Dos.DateTime; VAR T : Dos.DateTime;
BEGIN BEGIN
@ -212,10 +208,56 @@ BEGIN
FillChar (f,SIZEOF(f),0); FillChar (f,SIZEOF(f),0);
END; END;
END; END;
END; END;*)
Function UnixToWinAge(UnixAge : time_t): Longint;
Var tm : TTm;
begin
libc.localtime_r (UnixAge, tm);
with tm do
Result:=DateTimeToFileDate(EncodeDate(tm_year+1900,tm_mon+1,tm_mday)+EncodeTime(tm_hour,tm_min,tm_sec,0));
end;
{returns true if attributes match}
function find_setfields (var f : TsearchRec; var AttrsOk : boolean) : longint;
var
StatBuf : TStat;
fname : string;
begin
result := 0;
with F do
begin
if FindData.Magic = $AD02 then
begin
attr := (Pdirent(FindData.EntryP)^.d_mode shr 16) and $ffff;
size := Pdirent(FindData.EntryP)^.d_size;
name := strpas (Pdirent(FindData.EntryP)^.d_name);
fname := FindData._dir + name;
if stat (pchar(fname),StatBuf) = 0 then
time := UnixToWinAge (StatBuf.st_mtim.tv_sec)
else
time := 0;
AttrsOk := false;
if (f.FindData._attr and faHidden) = 0 then
if attr and faHidden > 0 then exit;
if (f.FindData._attr and faDirectory) = 0 then
if attr and faDirectory > 0 then exit;
if (f.FindData._attr and faSysFile) = 0 then
if attr and faSysFile > 0 then exit;
AttrsOk := true;
end else
begin
FillChar (f,sizeof(f),0);
result := 18;
end;
end;
end;
(*
Function FindFirst (Const Path : String; Attr : Longint; Var Rslt : TSearchRec) : Longint; Function FindFirst (Const Path : String; Attr : Longint; Var Rslt : TSearchRec) : Longint;
begin begin
IF path = '' then IF path = '' then
@ -263,9 +305,81 @@ begin
F.FindData.DirP := NIL; F.FindData.DirP := NIL;
F.FindData.EntryP := NIL; F.FindData.EntryP := NIL;
end; end;
end;*)
function findfirst(const path : string;attr : longint;var Rslt : TsearchRec) : longint;
var
path0 : string;
p : longint;
begin
IF path = '' then
begin
result := 18;
exit;
end;
Rslt.FindData._attr := attr;
p := length (path);
while (p > 0) and (not (path[p] in ['\','/'])) do
dec (p);
if p > 0 then
begin
Rslt.FindData._mask := copy (path,p+1,255);
Rslt.FindData._dir := copy (path,1,p);
end else
begin
Rslt.FindData._mask := path;
Rslt.FindData._dir := GetCurrentDir;
if (Rslt.FindData._dir[length(Rslt.FindData._dir)] <> '/') and
(Rslt.FindData._dir[length(Rslt.FindData._dir)] <> '\') then
Rslt.FindData._dir := Rslt.FindData._dir + '/';
end;
if Rslt.FindData._mask = '*' then Rslt.FindData._mask := '';
if Rslt.FindData._mask = '*.*' then Rslt.FindData._mask := '';
//writeln (stderr,'mask: "',Rslt._mask,'" dir:"',path0,'"');
Pdirent(Rslt.FindData.DirP) := opendir (pchar(Rslt.FindData._dir));
if Rslt.FindData.DirP = nil then
result := 18
else begin
Rslt.FindData.Magic := $AD02;
result := findnext (Rslt);
end;
end; end;
function findnext(var Rslt : TsearchRec) : longint;
var attrsOk : boolean;
begin
if Rslt.FindData.Magic <> $AD02 then
begin
result := 18;
exit;
end;
result:=0;
repeat
Pdirent(Rslt.FindData.EntryP) := readdir (Pdirent(Rslt.FindData.DirP));
if Rslt.FindData.EntryP = nil then
result := 18
else
result := find_setfields (Rslt,attrsOk);
if (result = 0) and (attrsOk) then
begin
if Rslt.FindData._mask = #0 then exit;
if fnmatch(@Rslt.FindData._mask[1],Pdirent(Rslt.FindData.EntryP)^.d_name,FNM_CASEFOLD) = 0 then
exit;
end;
until result <> 0;
end;
Procedure FindClose(Var f: TSearchRec);
begin
if F.FindData.Magic <> $AD02 then exit;
doserror:=0;
closedir (Pdirent(f.FindData.DirP));
FillChar (f,sizeof(f),0);
end;
Function FileGetDate (Handle : Longint) : Longint; Function FileGetDate (Handle : Longint) : Longint;
Var Info : TStat; Var Info : TStat;
_PTM : PTM; _PTM : PTM;
@ -285,12 +399,9 @@ end;
Function FileSetDate (Handle,Age : Longint) : Longint; Function FileSetDate (Handle,Age : Longint) : Longint;
begin Begin
{ i think its impossible under netware from FileHandle. I dident found a way to get the {dont know how to do that, utime needs filename}
complete pathname of a filehandle, that would be needed for ChangeDirectoryEntry } result := -1;
FileSetDate:=-1;
ConsolePrintf ('warning: fpc sysutils.FileSetDate not implemented'#13#10);
{$warning FileSetDate not implemented (i think is impossible) }
end; end;
@ -300,19 +411,36 @@ begin
If stat (pchar(FileName),Info) <> 0 then If stat (pchar(FileName),Info) <> 0 then
Result:=-1 Result:=-1
Else Else
Result := Info.st_flags AND $FFFF; Result := (Info.st_mode shr 16) and $ffff;
end; end;
Function FileSetAttr (Const Filename : String; Attr: longint) : Longint; Function FileSetAttr (Const Filename : String; Attr: longint) : Longint;
//VAR MS : NWModifyStructure; var
StatBuf : TStat;
newMode : longint;
begin begin
{FillChar (MS, SIZEOF (MS), 0); if stat (pchar(Filename),StatBuf) = 0 then
if _ChangeDirectoryEntry (PChar (Filename), MS, MFileAtrributesBit, 0) <> 0 then begin
result := -1 {what should i do here ?
else only support sysutils-standard attributes or also support the extensions defined
result := 0;} only for netware libc ?
{$warning FileSetAttr needs implementation} For now i allow the complete attributes if the bit faSetNetwareAttrs is set. Otherwise
only the standard attributes can be modified}
if attr and faSetNetwareAttrs > 0 then
begin
newmode := ((attr shl 16) and $ffff0000) or M_A_BITS_SIGNIFICANT;
end else
begin
attr := (attr and $2f) shl 16;
newmode := StatBuf.st_mode and ($ffff0000-M_A_RDONLY-M_A_HIDDEN- M_A_SYSTEM-M_A_SUBDIR-M_A_ARCH);
newmode := newmode or (attr shl 16) or M_A_BITS_SIGNIFICANT;
end;
if chmod (pchar(Filename),newMode) < 0 then
result := ___errno^ else
result := 0;
end else
result := ___errno^;
end; end;
@ -370,7 +498,7 @@ end;
Function DiskFree(Drive: Byte): int64; Function DiskFree(Drive: Byte): int64;
//var fs : statfs; //var fs : Tstatfs;
Begin Begin
{ if ((Drive<4) and (not (fixdrivestr[Drive]=nil)) and fsstat(StrPas(fixdrivestr[drive]),fs)) or { 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 ((not (drivestr[Drive]=nil)) and fsstat(StrPas(drivestr[drive]),fs)) then
@ -557,7 +685,11 @@ end.
{ {
$Log$ $Log$
Revision 1.1 2004-09-05 20:58:47 armin Revision 1.2 2004-09-12 20:51:22 armin
* added keyboard and video
* a lot of fixes
Revision 1.1 2004/09/05 20:58:47 armin
* first rtl version for netwlibc * first rtl version for netwlibc
} }

199
rtl/netwlibc/video.pp Normal file
View File

@ -0,0 +1,199 @@
{
$Id$
This file is part of the Free Pascal run time library.
Copyright (c) 2004 by Armin Diehl
member of the Free Pascal development team
Video unit for netware libc
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 Video;
interface
{$i videoh.inc}
implementation
uses
Libc;
{$i video.inc}
var
MaxVideoBufSize : DWord;
VideoBufAllocated: boolean;
ScreenHandle : scr_t;
procedure SysInitVideo;
VAR height,width,x,y : WORD;
startline, endline : BYTE;
sType,sColorFlag : dword;
begin
DoneVideo;
Libc.ReturnScreenType (sType,sColorFlag);
ScreenColor:= (sColorFlag > 0);
Libc.GetScreenSize(height,width);
ScreenWidth := width;
ScreenHeight:= height;
{ TDrawBuffer only has FVMaxWidth elements
larger values lead to crashes }
if ScreenWidth> FVMaxWidth then
ScreenWidth:=FVMaxWidth;
GetOutputCursorPosition(ScreenHandle,y,x);
CursorX := x;
CursorY := y;
//_GetCursorShape (startline,endline);
{if not ConsoleCursorInfo.bvisible then
CursorLines:=0
else
CursorLines:=ConsoleCursorInfo.dwSize;}
{ allocate back buffer }
MaxVideoBufSize:= ScreenWidth * ScreenHeight * 2;
VideoBufSize := ScreenWidth * ScreenHeight * 2;
GetMem(VideoBuf,MaxVideoBufSize);
GetMem(OldVideoBuf,MaxVideoBufSize);
VideoBufAllocated := true;
{grab current screen contents}
Libc.SaveFullScreen (ScreenHandle,VideoBuf);
Move (VideoBuf^, OldVideoBuf^, MaxVideoBufSize);
LockUpdateScreen := 0;
end;
procedure SysDoneVideo;
begin
SetCursorType(crUnderLine);
if videoBufAllocated then
begin
FreeMem(VideoBuf,MaxVideoBufSize);
FreeMem(OldVideoBuf,MaxVideoBufSize);
videoBufAllocated := false;
end;
VideoBufSize:=0;
end;
function SysGetCapabilities: Word;
begin
SysGetCapabilities:=cpColor or cpChangeCursor;
end;
procedure SysSetCursorPos(NewCursorX, NewCursorY: Word);
begin
Libc.GetOutputCursorPosition(ScreenHandle,NewCursorY,NewCursorX);
end;
function SysGetCursorType: Word;
var style : word;
begin
Libc.GetCursorStyle (ScreenHandle,style);
case style of
//CURSOR_NORMAL : SysGetCursorType := crUnderline;
CURSOR_THICK : SysGetCursorType := crBlock;
CURSOR_BLOCK : SysGetCursorType := crBlock;
CURSOR_TOP : SysGetCursorType := crHalfBlock
else
SysGetCursorType := crUnderline;
end;
{crHidden ?}
end;
procedure SysSetCursorType(NewType: Word);
begin
if newType=crHidden then
Libc.DisableInputCursor (ScreenHandle)
else
begin
case NewType of
crUnderline: Libc.SetCursorStyle (ScreenHandle,CURSOR_NORMAL);
crHalfBlock: Libc.SetCursorStyle (ScreenHandle,CURSOR_TOP);
crBlock : Libc.SetCursorStyle (ScreenHandle,CURSOR_BLOCK);
end;
Libc.EnableInputCursor (ScreenHandle);
end;
end;
procedure SysUpdateScreen(Force: Boolean);
begin
if (LockUpdateScreen<>0) or (VideoBufSize = 0) then
exit;
if not force then
begin
asm
movl VideoBuf,%esi
movl OldVideoBuf,%edi
movl VideoBufSize,%ecx
shrl $2,%ecx
repe
cmpsl
setne force
end;
end;
if Force then
Libc.RestoreScreenArea(ScreenHandle,0,0,ScreenHeight,ScreenWidth,VideoBuf);
end;
Const
SysVideoModeCount = 1;
SysVMD : Array[0..SysVideoModeCount-1] of TVideoMode = (
(Col: 80; Row : 25; Color : True));
Function SysSetVideoMode (Const Mode : TVideoMode) : Boolean;
begin
SysSetVideoMode := ((Mode.Col = 80) AND (Mode.Row = 25) AND (Mode.Color));
end;
Function SysGetVideoModeData (Index : Word; Var Data : TVideoMode) : boolean;
begin
SysGetVideoModeData:=(Index<=SysVideoModeCount);
If SysGetVideoModeData then
Data:=SysVMD[Index];
end;
Function SysGetVideoModeCount : Word;
begin
SysGetVideoModeCount:=SysVideoModeCount;
end;
Const
SysVideoDriver : TVideoDriver = (
InitDriver : @SysInitVideo;
DoneDriver : @SysDoneVideo;
UpdateScreen : @SysUpdateScreen;
ClearScreen : Nil;
SetVideoMode : @SysSetVideoMode;
GetVideoModeCount : @SysGetVideoModeCount;
GetVideoModeData : @SysGetVideoModedata;
SetCursorPos : @SysSetCursorPos;
GetCursorType : @SysGetCursorType;
SetCursorType : @SysSetCursorType;
GetCapabilities : @SysGetCapabilities
);
initialization
VideoBufAllocated := false;
VideoBufSize := 0;
ScreenHandle := Libc.getscreenhandle;
SetVideoDriver (SysVideoDriver);
end.