mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-08 16:28:24 +02:00
* added keyboard and video
* a lot of fixes
This commit is contained in:
armin
parent
bb684d007d
commit
76400e6c05
@ -228,7 +228,7 @@ override FPCOPT+=-Ur
|
||||
override FPCOPT+=-dMT -dDEBUG_MT
|
||||
CREATESMART=0
|
||||
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_RSTS+=math varutils variants convutils typinfo systhrds classes dateutils sysconst rtlconst
|
||||
override INSTALL_FPCPACKAGE=y
|
||||
@ -1434,8 +1434,9 @@ gettext$(PPUEXT): $(OBJPASDIR)/gettext.pp objpas$(PPUEXT) sysutils$(PPUEXT)
|
||||
varutils$(PPUEXT) : varutils.pp $(OBJPASDIR)/cvarutil.inc \
|
||||
objpas$(PPUEXT) $(OBJPASDIR)/varutilh.inc
|
||||
$(COMPILER) -I$(OBJPASDIR) varutils.pp
|
||||
freebidi$(PPUEXT) : $(OBJPASDIR)/freebidi.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)
|
||||
types$(PPUEXT) : $(OBJPASDIR)/types.pp objpas$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT)
|
||||
$(COMPILER) $(OBJPASDIR)/types.pp
|
||||
@ -1459,6 +1460,9 @@ heaptrc$(PPUEXT) : $(INC)/heaptrc.pp $(SYSTEMUNIT)$(PPUEXT)
|
||||
lineinfo$(PPUEXT) : $(INC)/lineinfo.pp $(SYSTEMUNIT)$(PPUEXT)
|
||||
charset$(PPUEXT) : $(INC)/charset.pp $(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)
|
||||
aio$(PPUEXT) : aio.pp $(SYSTEMUNIT)$(PPUEXT)
|
||||
override INSTALLPPUFILES+=nwsnut.imp ws2_32.imp ws2nlm.imp libc.imp netware.imp \
|
||||
|
||||
@ -14,8 +14,8 @@ units=$(SYSTEMUNIT) objpas macpas strings \
|
||||
cpu mmx getopts \
|
||||
dateutils strutils convutils \
|
||||
charset ucomplex variants \
|
||||
rtlconst math varutils utf8bidi \
|
||||
mouse
|
||||
rtlconst math varutils freebidi utf8bidi \
|
||||
mouse video keyboard
|
||||
|
||||
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
|
||||
$(COMPILER) -I$(OBJPASDIR) varutils.pp
|
||||
|
||||
freebidi$(PPUEXT) : $(OBJPASDIR)/freebidi.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)
|
||||
@ -223,6 +225,12 @@ charset$(PPUEXT) : $(INC)/charset.pp $(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
|
||||
|
||||
@ -35,6 +35,7 @@ Type
|
||||
{ Internals used by netware port only: }
|
||||
_mask : string[255];
|
||||
_dir : string[255];
|
||||
_attr : word;
|
||||
end;
|
||||
|
||||
registers = packed record
|
||||
@ -45,6 +46,9 @@ Type
|
||||
end;
|
||||
|
||||
{$i dosh.inc}
|
||||
{Extra Utils}
|
||||
function weekday(y,m,d : longint) : longint;
|
||||
|
||||
|
||||
implementation
|
||||
|
||||
@ -63,10 +67,34 @@ function dosversion : word;
|
||||
var i : Tutsname;
|
||||
begin
|
||||
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;
|
||||
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);
|
||||
var
|
||||
@ -148,9 +176,12 @@ var c : comstr;
|
||||
args : array[0..maxargs] of pchar;
|
||||
arg0 : pathstr;
|
||||
numargs,wstat : integer;
|
||||
Wiring : TWiring;
|
||||
begin
|
||||
//writeln ('dos.exec (',path,',',comline,')');
|
||||
arg0 := fexpand (path)+#0;
|
||||
if pos ('.',path) = 0 then
|
||||
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];
|
||||
numargs := 0;
|
||||
c:=comline;
|
||||
@ -170,7 +201,20 @@ begin
|
||||
end;
|
||||
args[numargs+1] := nil;
|
||||
// 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
|
||||
begin
|
||||
waitpid(i,@wstat,0);
|
||||
@ -330,12 +374,13 @@ end;
|
||||
--- Findfirst FindNext ---
|
||||
******************************************************************************}
|
||||
|
||||
|
||||
procedure find_setfields (var f : searchRec);
|
||||
{returns true if attributes match}
|
||||
function find_setfields (var f : searchRec) : boolean;
|
||||
var
|
||||
StatBuf : TStat;
|
||||
fname : string[255];
|
||||
begin
|
||||
find_setfields := false;
|
||||
with F do
|
||||
begin
|
||||
if Magic = $AD01 then
|
||||
@ -351,6 +396,13 @@ begin
|
||||
timet2dostime (StatBuf.st_mtim.tv_sec, time)
|
||||
else
|
||||
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
|
||||
begin
|
||||
FillChar (f,sizeof(f),0);
|
||||
@ -370,25 +422,26 @@ begin
|
||||
doserror := 18;
|
||||
exit;
|
||||
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
|
||||
p := length (path);
|
||||
while (p > 0) and (not (path[p] in ['\','/'])) do
|
||||
dec (p);
|
||||
if p > 0 then
|
||||
begin
|
||||
f._mask := copy (path,p+1,255);
|
||||
f._dir := copy (path,1,p);
|
||||
strpcopy(path0,f._dir);
|
||||
end else
|
||||
begin
|
||||
f._mask := path;
|
||||
getdir (0,f._dir);
|
||||
if (f._dir[length(f._dir)] <> '/') and
|
||||
(f._dir[length(f._dir)] <> '\') then
|
||||
f._dir := f._dir + '/';
|
||||
end;
|
||||
f._mask := copy (path,p+1,255);
|
||||
f._dir := copy (path,1,p);
|
||||
strpcopy(path0,f._dir);
|
||||
end else
|
||||
begin
|
||||
f._mask := path;
|
||||
getdir (0,f._dir);
|
||||
if (f._dir[length(f._dir)] <> '/') and
|
||||
(f._dir[length(f._dir)] <> '\') then
|
||||
f._dir := f._dir + '/';
|
||||
strpcopy(path0,f._dir);
|
||||
end;
|
||||
if f._mask = '*' then f._mask := '';
|
||||
if f._mask = '*.*' then f._mask := '';
|
||||
//writeln (stderr,'mask: "',f._mask,'" dir:"',path0,'"');
|
||||
f._mask := f._mask + #0;
|
||||
Pdirent(f.DirP) := opendir (path0);
|
||||
@ -414,15 +467,11 @@ begin
|
||||
if F.EntryP = nil then
|
||||
doserror := 18
|
||||
else
|
||||
if f._mask = #0 then
|
||||
if find_setfields (f) then
|
||||
begin
|
||||
find_setfields (f);
|
||||
exit;
|
||||
end else
|
||||
if fnmatch(@f._mask[1],Pdirent(f.EntryP)^.d_name,FNM_CASEFOLD) = 0 then
|
||||
begin
|
||||
find_setfields (f);
|
||||
exit;
|
||||
if f._mask = #0 then exit;
|
||||
if fnmatch(@f._mask[1],Pdirent(f.EntryP)^.d_name,FNM_CASEFOLD) = 0 then
|
||||
exit;
|
||||
end;
|
||||
until doserror <> 0;
|
||||
end;
|
||||
@ -574,7 +623,7 @@ var
|
||||
StatBuf : TStat;
|
||||
begin
|
||||
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)
|
||||
else begin
|
||||
time := 0;
|
||||
@ -584,9 +633,36 @@ 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);
|
||||
Var
|
||||
utim: utimbuf;
|
||||
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;
|
||||
|
||||
|
||||
@ -594,7 +670,7 @@ procedure getfattr(var f;var attr : word);
|
||||
VAR StatBuf : TStat;
|
||||
begin
|
||||
doserror := 0;
|
||||
if fstat (FileRec (f).Handle, StatBuf) = 0 then
|
||||
if stat (@textrec(f).name, StatBuf) = 0 then
|
||||
attr := nwattr2dosattr (StatBuf.st_mode)
|
||||
else
|
||||
begin
|
||||
@ -609,10 +685,10 @@ var
|
||||
StatBuf : TStat;
|
||||
newMode : longint;
|
||||
begin
|
||||
if fstat (FileRec(f).Handle,StatBuf) = 0 then
|
||||
if stat (@textrec(f).name,StatBuf) = 0 then
|
||||
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 := newmode and M_A_BITS_SIGNIFICANT; {set netware attributes}
|
||||
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 or M_A_BITS_SIGNIFICANT; {set netware attributes}
|
||||
if attr and readonly > 0 then
|
||||
newmode := newmode or M_A_RDONLY;
|
||||
if attr and hidden > 0 then
|
||||
@ -621,7 +697,7 @@ begin
|
||||
newmode := newmode or M_A_SYSTEM;
|
||||
if attr and archive > 0 then
|
||||
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 := 0;
|
||||
end else
|
||||
@ -677,6 +753,7 @@ end;
|
||||
Function GetEnv(envvar: string): string;
|
||||
var envvar0 : array[0..512] of char;
|
||||
p : pchar;
|
||||
SearchElement : string[255];
|
||||
i,isDosPath,res : longint;
|
||||
begin
|
||||
if upcase(envvar) = 'PATH' then
|
||||
@ -684,13 +761,16 @@ begin
|
||||
// return it here (needed for the compiler)
|
||||
GetEnv := '';
|
||||
i := 1;
|
||||
res := GetSearchPathElement (i, isdosPath, @envvar0[0]);
|
||||
res := GetSearchPathElement (i, isdosPath, @SearchElement[0]);
|
||||
while res = 0 do
|
||||
begin
|
||||
if GetEnv <> '' then GetEnv := GetEnv + ';';
|
||||
GetEnv := GetEnv + envvar0;
|
||||
if isDosPath = 0 then
|
||||
begin
|
||||
if GetEnv <> '' then GetEnv := GetEnv + ';';
|
||||
GetEnv := GetEnv + SearchElement;
|
||||
end;
|
||||
inc (i);
|
||||
res := GetSearchPathElement (i, isdosPath, @envvar0[0]);
|
||||
res := GetSearchPathElement (i, isdosPath, @SearchElement[0]);
|
||||
end;
|
||||
for i := 1 to length(GetEnv) do
|
||||
if GetEnv[i] = '\' then
|
||||
@ -741,7 +821,11 @@ end;
|
||||
end.
|
||||
{
|
||||
$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
|
||||
|
||||
}
|
||||
|
||||
150
rtl/netwlibc/keyboard.pp
Normal file
150
rtl/netwlibc/keyboard.pp
Normal 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)
|
||||
|
||||
|
||||
}
|
||||
@ -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';
|
||||
{$endif}
|
||||
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 lseek(fildes:longint; offset:off_t; whence:longint):off_t;cdecl;external libc_nlm name 'lseek';
|
||||
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 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';
|
||||
@ -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 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; var buf; nbytes:size_t):ssize_t;cdecl;external libc_nlm name 'write';
|
||||
{ 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';
|
||||
{ nonstandard (transitional) addtions for 64-bit file I/O... }
|
||||
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 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 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 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 Fptell64(fildes:longint):off64_t;cdecl;external libc_nlm name 'tell64';
|
||||
function ____environ:PPPchar;cdecl;external libc_nlm name '____environ';
|
||||
function ___optarg:PPchar;cdecl;external libc_nlm name '___optarg';
|
||||
function ___optind:Plongint;cdecl;external libc_nlm name '___optind';
|
||||
@ -1179,7 +1183,7 @@ type
|
||||
tm_year : longint; // years since 1900 [0..ì]
|
||||
tm_wday : longint; // days since Sunday [0..6]
|
||||
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;
|
||||
|
||||
Ptimespec = ^Ttimespec;
|
||||
@ -1384,10 +1388,14 @@ type
|
||||
{ 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 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 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 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... }
|
||||
@ -1875,7 +1883,8 @@ type
|
||||
(** 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; var buf:Tstatfs):longint;cdecl;external libc_nlm name 'fstatfs';
|
||||
|
||||
@ -3432,11 +3441,11 @@ type
|
||||
BACKSPACE = $08;
|
||||
{ modifier code constituents... }
|
||||
SHIFT_KEY_HELD = $01;
|
||||
CTRL_KEY_HELD = $02;
|
||||
ALT_KEY_HELD = $04;
|
||||
CAPS_LOCK_IS_ON = $10;
|
||||
CTRL_KEY_HELD = $04;
|
||||
ALT_KEY_HELD = $08;
|
||||
CAPS_LOCK_IS_ON = $40;
|
||||
NUM_LOCK_IS_ON = $20;
|
||||
SCROLL_LOCK_IS_ON = $40;
|
||||
SCROLL_LOCK_IS_ON = $10;
|
||||
{ suggested 'maxlen' argument for getpassword()... }
|
||||
_PASSWORD_LEN = 128;
|
||||
{ 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 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; 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 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';
|
||||
@ -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 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;
|
||||
buffer:pointer):longint;cdecl;external system_nlm name 'RestoreScreenArea';
|
||||
procedure ReturnScreenType(_type:Pdword; colorFlag:Pdword);cdecl;external system_nlm name 'ReturnScreenType';
|
||||
function RestoreScreenArea(scrID:scr_t; line,col,height,width:dword; buffer:pointer):longint;cdecl;external system_nlm name 'RestoreScreenArea';
|
||||
procedure ReturnScreenType(_type,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';
|
||||
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;
|
||||
buffer:pointer):longint;cdecl;external system_nlm name 'SaveScreenArea';
|
||||
function SaveScreenArea(scrID:scr_t; line,col,height,width:dword; buffer:pointer):longint;cdecl;external system_nlm name 'SaveScreenArea';
|
||||
procedure SetConsoleSecuredFlag(value:byte);cdecl;external system_nlm name 'SetConsoleSecuredFlag';
|
||||
procedure SetCursorStyle(scrID:scr_t; newStyle:word);cdecl;external system_nlm name 'SetCursorStyle';
|
||||
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 setcwd2(pathCtx:NXPathCtx_t):longint;cdecl;external libc_nlm name 'setcwd2';
|
||||
{ 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 Fptell(fildes:longint):off_t;cdecl;external libc_nlm name 'tell';
|
||||
{ extensions of sys/stat.h functions... }
|
||||
function fgetstat(fildes:longint; buf:Pstat; requestmap:dword):longint;cdecl;external libc_nlm name 'fgetstat';
|
||||
|
||||
@ -8275,18 +8285,21 @@ type
|
||||
outfd : longint;
|
||||
errfd : longint;
|
||||
end;
|
||||
TWiring = wiring_t;
|
||||
PWiring = Pwiring_t;
|
||||
|
||||
{$ifndef DisableArrayOfConst}
|
||||
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';
|
||||
//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';
|
||||
{$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';
|
||||
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;
|
||||
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
|
||||
// sched.h
|
||||
@ -9096,6 +9109,7 @@ type
|
||||
actime : time_t;
|
||||
modtime : time_t;
|
||||
end;
|
||||
utimbuf = Tutimbuf;
|
||||
|
||||
(** unsupported pragma#pragma pack()*)
|
||||
|
||||
|
||||
@ -92,6 +92,8 @@ procedure NWSysSetThreadFunctions (crs:TSysCloseAllRemainingSemaphores;
|
||||
stdata:TSysSetThreadDataAreaPtr);
|
||||
}
|
||||
|
||||
procedure __ConsolePrintf (s :string);
|
||||
|
||||
implementation
|
||||
{ Indicate that stack checking is taken care by OS}
|
||||
{$DEFINE NO_GENERIC_STACK_CHECK}
|
||||
@ -126,8 +128,6 @@ begin
|
||||
end;}
|
||||
|
||||
|
||||
|
||||
|
||||
procedure PASCALMAIN;external name 'PASCALMAIN';
|
||||
procedure fpc_do_exit;external name 'FPC_DO_EXIT';
|
||||
|
||||
@ -144,12 +144,14 @@ var SigTermHandlerActive : boolean;
|
||||
|
||||
Procedure system_exit;
|
||||
begin
|
||||
__ConsolePrintf ('system_exit');
|
||||
//if assigned (CloseAllRemainingSemaphores) then CloseAllRemainingSemaphores;
|
||||
//if assigned (ReleaseThreadVars) then ReleaseThreadVars;
|
||||
|
||||
{$ifdef autoHeapRelease}
|
||||
FreeSbrkMem; { free memory allocated by heapmanager }
|
||||
{$endif}
|
||||
__ConsolePrintf ('Heap mem released');
|
||||
|
||||
if not SigTermHandlerActive then
|
||||
begin
|
||||
@ -216,22 +218,20 @@ end;
|
||||
*****************************************************************************}
|
||||
|
||||
var
|
||||
heap : longint;external name 'HEAP';
|
||||
intern_heapsize : longint;external name 'HEAPSIZE';
|
||||
int_heap : pointer;external name 'HEAP';
|
||||
int_heapsize : longint;external name 'HEAPSIZE';
|
||||
|
||||
{ first address of heap }
|
||||
function getheapstart:pointer;
|
||||
assembler;
|
||||
asm
|
||||
leal HEAP,%eax
|
||||
end ['EAX'];
|
||||
begin
|
||||
getheapstart := int_heap;
|
||||
end;
|
||||
|
||||
{ current length of heap }
|
||||
function getheapsize:longint;
|
||||
assembler;
|
||||
asm
|
||||
movl intern_HEAPSIZE,%eax
|
||||
end ['EAX'];
|
||||
begin
|
||||
getheapsize := int_heapsize;
|
||||
end;
|
||||
|
||||
{$ifdef autoHeapRelease}
|
||||
|
||||
@ -240,6 +240,7 @@ type THeapSbrkBlockList = array [1.. HeapInitialMaxBlocks] of pointer;
|
||||
var HeapSbrkBlockList : ^THeapSbrkBlockList = nil;
|
||||
HeapSbrkLastUsed : dword = 0;
|
||||
HeapSbrkAllocated : dword = 0;
|
||||
HeapSbrkReleased : boolean = false;
|
||||
|
||||
{ function to allocate size bytes more for the program }
|
||||
{ must return the first address of new data space or nil if fail }
|
||||
@ -250,6 +251,11 @@ var P2 : POINTER;
|
||||
i : longint;
|
||||
Slept : longint;
|
||||
begin
|
||||
if HeapSbrkReleased then
|
||||
begin
|
||||
__ConsolePrintf ('Error: SysOSFree called after all heap memory was released');
|
||||
exit(nil);
|
||||
end;
|
||||
SysOSAlloc := _Alloc (size,HeapAllocResourceTag);
|
||||
if SysOSAlloc <> nil then begin
|
||||
if HeapSbrkBlockList = nil then
|
||||
@ -303,6 +309,9 @@ begin
|
||||
HeapSbrkLastUsed := 0;
|
||||
HeapSbrkBlockList := nil;
|
||||
end;
|
||||
HeapSbrkReleased := true;
|
||||
{ReturnResourceTag(HeapAllocResourceTag,1);
|
||||
ReturnResourceTag(HeapListAllocResourceTag,1); not in netware.imp, seems to be not needed}
|
||||
end;
|
||||
|
||||
{*****************************************************************************
|
||||
@ -314,7 +323,10 @@ end;
|
||||
procedure SysOSFree(p: pointer; size: ptrint);
|
||||
var i : longint;
|
||||
begin
|
||||
//fpmunmap(p, size);
|
||||
if HeapSbrkReleased then
|
||||
begin
|
||||
__ConsolePrintf ('Error: SysOSFree called after all heap memory was released');
|
||||
end else
|
||||
if (HeapSbrkLastUsed > 0) then
|
||||
for i := 1 to HeapSbrkLastUsed do
|
||||
if (HeapSbrkBlockList^[i] = p) then
|
||||
@ -380,28 +392,27 @@ BEGIN
|
||||
end;
|
||||
END;
|
||||
|
||||
FUNCTION errno : LONGINT;
|
||||
{FUNCTION errno : LONGINT;
|
||||
BEGIN
|
||||
errno := ___errno^;
|
||||
END;
|
||||
END;}
|
||||
|
||||
PROCEDURE Errno2Inoutres;
|
||||
BEGIN
|
||||
NW2PASErr (errno);
|
||||
END;
|
||||
procedure Errno2Inoutres;
|
||||
begin
|
||||
NW2PASErr (___errno^);
|
||||
end;
|
||||
|
||||
PROCEDURE SetFileError (VAR Err : LONGINT);
|
||||
BEGIN
|
||||
IF Err >= 0 THEN
|
||||
procedure SetFileError (VAR Err : LONGINT);
|
||||
begin
|
||||
if Err >= 0 then
|
||||
InOutRes := 0
|
||||
ELSE
|
||||
BEGIN
|
||||
libc_perror ('SetFileError');
|
||||
Err := errno;
|
||||
else begin
|
||||
// libc_perror ('SetFileError');
|
||||
Err := ___errno^;
|
||||
NW2PASErr (Err);
|
||||
Err := 0;
|
||||
END;
|
||||
END;
|
||||
end;
|
||||
end;
|
||||
|
||||
{ close a file from the handle value }
|
||||
procedure do_close(handle : thandle);
|
||||
@ -442,7 +453,7 @@ function do_write(h:thandle;addr:pointer;len : longint) : longint;
|
||||
var res : LONGINT;
|
||||
begin
|
||||
{$ifdef IOpossix}
|
||||
res := libc_write (h,addr,len);
|
||||
res := Fpwrite (h,addr,len);
|
||||
{$else}
|
||||
res := _fwrite (addr,1,len,_TFILE(h));
|
||||
{$endif}
|
||||
@ -457,7 +468,7 @@ function do_read(h:thandle;addr:pointer;len : longint) : longint;
|
||||
VAR res : LONGINT;
|
||||
begin
|
||||
{$ifdef IOpossix}
|
||||
res := libc_write (h,addr,len);
|
||||
res := Fpread (h,addr,len);
|
||||
{$else}
|
||||
res := _fread (addr,1,len,_TFILE(h));
|
||||
{$endif}
|
||||
@ -474,7 +485,7 @@ var res : LONGINT;
|
||||
begin
|
||||
InOutRes:=1;
|
||||
{$ifdef IOpossix}
|
||||
res := tell (handle);
|
||||
res := Fptell (handle);
|
||||
{$else}
|
||||
res := _ftell (_TFILE(handle));
|
||||
{$endif}
|
||||
@ -490,7 +501,7 @@ procedure do_seek(handle:thandle;pos : longint);
|
||||
VAR res : LONGINT;
|
||||
begin
|
||||
{$ifdef IOpossix}
|
||||
res := lseek (handle,pos, SEEK_SET);
|
||||
res := Fplseek (handle,pos, SEEK_SET);
|
||||
{$else}
|
||||
res := _fseek (_TFILE(handle),pos, SEEK_SET);
|
||||
{$endif}
|
||||
@ -504,7 +515,7 @@ function do_seekend(handle:thandle):longint;
|
||||
VAR res : LONGINT;
|
||||
begin
|
||||
{$ifdef IOpossix}
|
||||
res := lseek (handle,0, SEEK_END);
|
||||
res := Fplseek (handle,0, SEEK_END);
|
||||
{$else}
|
||||
res := _fseek (_TFILE(handle),0, SEEK_END);
|
||||
{$endif}
|
||||
@ -619,19 +630,17 @@ Begin
|
||||
end;
|
||||
{ real open call }
|
||||
FileRec(f).Handle := open(p,oflags,438);
|
||||
//WriteLn ('_open (',p,') returned ',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
|
||||
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
|
||||
if FileRec(f).Handle < 0 then
|
||||
Errno2Inoutres
|
||||
ELSE
|
||||
else
|
||||
InOutRes := 0;
|
||||
End;
|
||||
end;
|
||||
|
||||
|
||||
{$else}
|
||||
@ -723,7 +732,7 @@ End;
|
||||
function do_isdevice(handle:THandle):boolean;
|
||||
begin
|
||||
{$ifdef IOpossix}
|
||||
do_isdevice := (isatty (handle) > 0);
|
||||
do_isdevice := (Fpisatty (handle) > 0);
|
||||
{$else}
|
||||
do_isdevice := (isatty (_fileno(_TFILE(handle))) > 0);
|
||||
{$endif}
|
||||
@ -755,18 +764,18 @@ end;
|
||||
Directory Handling
|
||||
*****************************************************************************}
|
||||
procedure mkdir(const s : string);[IOCheck];
|
||||
VAR S2 : STRING;
|
||||
var S2 : STRING;
|
||||
Res: LONGINT;
|
||||
BEGIN
|
||||
S2 := S;
|
||||
IF Length (S2) = 255 THEN DEC (BYTE(S2[0]));
|
||||
S2 := S2 + #0;
|
||||
Res := FpMkdir (@S2[1],0);
|
||||
IF Res = 0 THEN
|
||||
Res := FpMkdir (@S2[1],S_IRWXU);
|
||||
if Res = 0 then
|
||||
InOutRes:=0
|
||||
ELSE
|
||||
else
|
||||
SetFileError (Res);
|
||||
END;
|
||||
end;
|
||||
|
||||
procedure rmdir(const s : string);[IOCheck];
|
||||
VAR S2 : STRING;
|
||||
@ -801,7 +810,8 @@ VAR P : ARRAY [0..255] OF CHAR;
|
||||
i : LONGINT;
|
||||
begin
|
||||
P[0] := #0;
|
||||
getcwd (@P, SIZEOF (P));
|
||||
//getcwd (@P, SIZEOF (P));
|
||||
getcwdpath(@P,nil,0);
|
||||
i := libc_strlen (P);
|
||||
if i > 0 then
|
||||
begin
|
||||
@ -837,11 +847,10 @@ procedure InitFPU;assembler;
|
||||
Unload Anyway ?
|
||||
To Disable unload at all, SetNLMDontUnloadFlag can be used on
|
||||
Netware >= 4.0 }
|
||||
(*
|
||||
function CheckFunction : longint; CDECL; [public,alias: 'FPC_NW_CHECKFUNCTION'];
|
||||
var oldTG:longint;
|
||||
oldPtr: pointer;
|
||||
|
||||
function CheckFunction : longint; CDECL; [public,alias: '_NonAppCheckUnload'];
|
||||
begin
|
||||
__ConsolePrintf ('CheckFunction');
|
||||
if assigned (NetwareCheckFunction) then
|
||||
begin
|
||||
{ this function is called without clib context, to allow clib
|
||||
@ -854,14 +863,22 @@ begin
|
||||
// oldPtr := SetThreadDataAreaPtr (NIL); { nil means main threadvars }
|
||||
result := 0;
|
||||
NetwareCheckFunction (result);
|
||||
if assigned (SetThreadDataAreaPtr) then
|
||||
SetThreadDataAreaPtr (oldPtr);
|
||||
// if assigned (SetThreadDataAreaPtr) then
|
||||
// SetThreadDataAreaPtr (oldPtr);
|
||||
|
||||
_SetThreadGroupID (oldTG);
|
||||
// _SetThreadGroupID (oldTG);
|
||||
end else
|
||||
result := 0;
|
||||
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}
|
||||
@ -915,14 +932,8 @@ end;
|
||||
Halt (or _exit) can not be called from this callback procedure }
|
||||
procedure TermSigHandler (Sig:longint); CDecl;
|
||||
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 }
|
||||
do_exit; { calls finalize units }
|
||||
writeln ('TermSigHandler end ');
|
||||
end;
|
||||
|
||||
|
||||
@ -969,8 +980,9 @@ Begin
|
||||
{$ifdef StdErrToConsole}
|
||||
NWLoggerScreen := getnetwarelogger;
|
||||
{$endif}
|
||||
CheckFunction; // avoid check function to be removed by the linker
|
||||
|
||||
envp := nxGetEnviron;
|
||||
envp := ____environ^; // nxGetEnviron;
|
||||
NLMHandle := getnlmhandle;
|
||||
HeapAllocResourceTag :=
|
||||
AllocateResourceTag(NLMHandle,'Heap Memory',AllocSignature);
|
||||
@ -1001,7 +1013,11 @@ Begin
|
||||
End.
|
||||
{
|
||||
$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
|
||||
|
||||
}
|
||||
|
||||
@ -27,9 +27,13 @@ uses Libc,DOS;
|
||||
TYPE
|
||||
TNetwareLibcFindData =
|
||||
RECORD
|
||||
DirP : Pdirent; { used for opendir }
|
||||
EntryP: Pdirent; { and readdir }
|
||||
Magic : WORD; { to avoid abends with uninitialized TSearchRec }
|
||||
DirP : Pdirent; { used for opendir }
|
||||
EntryP: Pdirent; { and readdir }
|
||||
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;
|
||||
|
||||
{ Include platform independent interface part }
|
||||
@ -39,27 +43,28 @@ TYPE
|
||||
|
||||
{ additional NetWare file flags}
|
||||
CONST
|
||||
faSHARE = $00000080; { Sharable file }
|
||||
faSHARE = M_A_SHARE shr 16; // Sharable file
|
||||
|
||||
faNO_SUBALLOC = $00000800; { Don't sub alloc. this file }
|
||||
faTRANS = $00001000; { Transactional file (TTS usable) }
|
||||
faREADAUD = $00004000; { Read audit }
|
||||
faWRITAUD = $00008000; { Write audit }
|
||||
//faNO_SUBALLOC = $00000800; // Don't sub alloc. this file
|
||||
faTRANS = M_A_TRANS shr 16; // Transactional file (TTS usable)
|
||||
//faREADAUD = $00004000; // clib only: Read audit
|
||||
//faWRITAUD = $00008000; // clib only: Write audit
|
||||
|
||||
faIMMPURG = $00010000; { Immediate purge }
|
||||
faNORENAM = $00020000; { Rename inhibit }
|
||||
faNODELET = $00040000; { Delete inhibit }
|
||||
faNOCOPY = $00080000; { Copy inhibit }
|
||||
faIMMPURG = M_A_IMMPURG shr 16; // Immediate purge
|
||||
faNORENAM = M_A_NORENAM shr 16; // Rename inhibit
|
||||
faNODELET = M_A_NODELET shr 16; // Delete inhibit
|
||||
faNOCOPY = M_A_NOCOPY shr 16; // Copy inhibit
|
||||
|
||||
faFILE_MIGRATED = $00400000; { File has been migrated }
|
||||
faDONT_MIGRATE = $00800000; { Don't migrate this file }
|
||||
faIMMEDIATE_COMPRESS = $02000000; { Compress this file immediately }
|
||||
faFILE_COMPRESSED = $04000000; { File is compressed }
|
||||
faDONT_COMPRESS = $08000000; { Don't compress this file }
|
||||
faCANT_COMPRESS = $20000000; { Can't compress this file }
|
||||
faATTR_ARCHIVE = $40000000; { Entry has had an EA modified, }
|
||||
{ an ownerID changed, or trustee }
|
||||
{ info changed, etc. }
|
||||
//faFILE_MIGRATED = $00400000; // clib only: File has been migrated
|
||||
//faDONT_MIGRATE = $00800000; // clib only: Don't migrate this file
|
||||
faIMMEDIATE_COMPRESS = M_A_IMMCOMPRESS shr 16; // Compress this file immediately
|
||||
faFILE_COMPRESSED = M_A_FILE_COMPRESSED shr 16; // File is compressed
|
||||
faDONT_COMPRESS = M_A_DONT_COMPRESS shr 16; // Don't compress this file
|
||||
faCANT_COMPRESS = M_A_CANT_COMPRESS shr 16; // Can't compress this file
|
||||
//faATTR_ARCHIVE = $40000000; // clib only: Entry has had an EA modified,
|
||||
// an ownerID changed, or trustee
|
||||
// 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;
|
||||
2 : NWOpenFlags:=NWOpenFlags or O_RDWR;
|
||||
end;
|
||||
FileOpen := open (pchar(FileName),NWOpenFlags);
|
||||
FileOpen := Fpopen (pchar(FileName),NWOpenFlags);
|
||||
|
||||
//!! We need to set locking based on Mode !!
|
||||
end;
|
||||
|
||||
|
||||
Function FileCreate (Const FileName : String) : Longint;
|
||||
|
||||
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;
|
||||
|
||||
Function FileCreate (Const FileName : String; mode:longint) : Longint;
|
||||
|
||||
begin
|
||||
FileCreate:=FileCreate (FileName);
|
||||
end;
|
||||
|
||||
|
||||
Function FileRead (Handle : Longint; Var Buffer; Count : longint) : Longint;
|
||||
|
||||
begin
|
||||
FileRead:=libc.fpread (Handle,@Buffer,Count);
|
||||
end;
|
||||
|
||||
|
||||
Function FileWrite (Handle : Longint; const Buffer; Count : Longint) : Longint;
|
||||
|
||||
begin
|
||||
FileWrite:=libc.fpwrite (Handle,@Buffer,Count);
|
||||
end;
|
||||
|
||||
|
||||
Function FileSeek (Handle,FOffset,Origin : Longint) : Longint;
|
||||
|
||||
begin
|
||||
FileSeek:=libc.fplseek (Handle,FOffset,Origin);
|
||||
end;
|
||||
@ -127,18 +129,16 @@ end;
|
||||
|
||||
Function FileSeek (Handle : Longint; FOffset,Origin : Int64) : Int64;
|
||||
begin
|
||||
FileSeek:=libc.fplseek (Handle,FOffset,Origin);
|
||||
FileSeek:=libc.fplseek64 (Handle,FOffset,Origin);
|
||||
end;
|
||||
|
||||
|
||||
Procedure FileClose (Handle : Longint);
|
||||
|
||||
begin
|
||||
libc.fpclose(Handle);
|
||||
end;
|
||||
|
||||
Function FileTruncate (Handle,Size: Longint) : boolean;
|
||||
|
||||
begin
|
||||
FileTruncate:=(libc.fpchsize(Handle,Size) = 0);
|
||||
end;
|
||||
@ -168,20 +168,16 @@ begin
|
||||
end;
|
||||
|
||||
Function FileAge (Const FileName : String): Longint;
|
||||
|
||||
VAR Info : TStat;
|
||||
_PTM : PTM;
|
||||
var Info : TStat;
|
||||
TM : TTM;
|
||||
begin
|
||||
If stat (pchar(FileName),Info) <> 0 then
|
||||
exit(-1)
|
||||
else
|
||||
begin
|
||||
_PTM := localtime (Info.st_mtim.tv_sec);
|
||||
IF _PTM = NIL THEN
|
||||
exit(-1)
|
||||
else
|
||||
WITH _PTM^ DO
|
||||
Result:=DateTimeToFileDate(EncodeDate(tm_year+1900,tm_mon+1,tm_mday)+EncodeTime(tm_hour,tm_min,tm_sec,0));
|
||||
localtime_r (Info.st_mtim.tv_sec,tm);
|
||||
with TM do
|
||||
result:=DateTimeToFileDate(EncodeDate(tm_year+1900,tm_mon+1,tm_mday)+EncodeTime(tm_hour,tm_min,tm_sec,0));
|
||||
end;
|
||||
end;
|
||||
|
||||
@ -193,7 +189,7 @@ begin
|
||||
end;
|
||||
|
||||
|
||||
|
||||
(*
|
||||
PROCEDURE find_setfields (VAR f : TsearchRec);
|
||||
VAR T : Dos.DateTime;
|
||||
BEGIN
|
||||
@ -212,10 +208,56 @@ BEGIN
|
||||
FillChar (f,SIZEOF(f),0);
|
||||
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;
|
||||
begin
|
||||
IF path = '' then
|
||||
@ -263,9 +305,81 @@ begin
|
||||
F.FindData.DirP := NIL;
|
||||
F.FindData.EntryP := NIL;
|
||||
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;
|
||||
|
||||
|
||||
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;
|
||||
Var Info : TStat;
|
||||
_PTM : PTM;
|
||||
@ -285,12 +399,9 @@ end;
|
||||
|
||||
|
||||
Function FileSetDate (Handle,Age : Longint) : Longint;
|
||||
begin
|
||||
{ i think its impossible under netware from FileHandle. I dident found a way to get the
|
||||
complete pathname of a filehandle, that would be needed for ChangeDirectoryEntry }
|
||||
FileSetDate:=-1;
|
||||
ConsolePrintf ('warning: fpc sysutils.FileSetDate not implemented'#13#10);
|
||||
{$warning FileSetDate not implemented (i think is impossible) }
|
||||
Begin
|
||||
{dont know how to do that, utime needs filename}
|
||||
result := -1;
|
||||
end;
|
||||
|
||||
|
||||
@ -300,19 +411,36 @@ begin
|
||||
If stat (pchar(FileName),Info) <> 0 then
|
||||
Result:=-1
|
||||
Else
|
||||
Result := Info.st_flags AND $FFFF;
|
||||
Result := (Info.st_mode shr 16) and $ffff;
|
||||
end;
|
||||
|
||||
|
||||
Function FileSetAttr (Const Filename : String; Attr: longint) : Longint;
|
||||
//VAR MS : NWModifyStructure;
|
||||
var
|
||||
StatBuf : TStat;
|
||||
newMode : longint;
|
||||
begin
|
||||
{FillChar (MS, SIZEOF (MS), 0);
|
||||
if _ChangeDirectoryEntry (PChar (Filename), MS, MFileAtrributesBit, 0) <> 0 then
|
||||
result := -1
|
||||
else
|
||||
result := 0;}
|
||||
{$warning FileSetAttr needs implementation}
|
||||
if stat (pchar(Filename),StatBuf) = 0 then
|
||||
begin
|
||||
{what should i do here ?
|
||||
only support sysutils-standard attributes or also support the extensions defined
|
||||
only for netware libc ?
|
||||
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;
|
||||
|
||||
|
||||
@ -370,7 +498,7 @@ end;
|
||||
|
||||
|
||||
Function DiskFree(Drive: Byte): int64;
|
||||
//var fs : statfs;
|
||||
//var fs : Tstatfs;
|
||||
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
|
||||
@ -557,7 +685,11 @@ end.
|
||||
{
|
||||
|
||||
$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
|
||||
|
||||
}
|
||||
|
||||
199
rtl/netwlibc/video.pp
Normal file
199
rtl/netwlibc/video.pp
Normal 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.
|
||||
|
||||
Loading…
Reference in New Issue
Block a user