From 76400e6c0532504445b72ccfed59e58808f772c2 Mon Sep 17 00:00:00 2001 From: armin Date: Sun, 12 Sep 2004 20:51:22 +0000 Subject: [PATCH] * added keyboard and video * a lot of fixes --- rtl/netwlibc/Makefile | 8 +- rtl/netwlibc/Makefile.fpc | 14 ++- rtl/netwlibc/dos.pp | 174 +++++++++++++++++++------- rtl/netwlibc/keyboard.pp | 150 +++++++++++++++++++++++ rtl/netwlibc/libc.pp | 56 +++++---- rtl/netwlibc/system.pp | 142 ++++++++++++---------- rtl/netwlibc/sysutils.pp | 248 +++++++++++++++++++++++++++++--------- rtl/netwlibc/video.pp | 199 ++++++++++++++++++++++++++++++ 8 files changed, 799 insertions(+), 192 deletions(-) create mode 100644 rtl/netwlibc/keyboard.pp create mode 100644 rtl/netwlibc/video.pp diff --git a/rtl/netwlibc/Makefile b/rtl/netwlibc/Makefile index 5353dd0486..4f590e94ef 100644 --- a/rtl/netwlibc/Makefile +++ b/rtl/netwlibc/Makefile @@ -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 \ diff --git a/rtl/netwlibc/Makefile.fpc b/rtl/netwlibc/Makefile.fpc index 44650f26be..064d7e535c 100644 --- a/rtl/netwlibc/Makefile.fpc +++ b/rtl/netwlibc/Makefile.fpc @@ -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 diff --git a/rtl/netwlibc/dos.pp b/rtl/netwlibc/dos.pp index 4d24f72343..f2343bfe9c 100644 --- a/rtl/netwlibc/dos.pp +++ b/rtl/netwlibc/dos.pp @@ -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 } diff --git a/rtl/netwlibc/keyboard.pp b/rtl/netwlibc/keyboard.pp new file mode 100644 index 0000000000..dfffdbd895 --- /dev/null +++ b/rtl/netwlibc/keyboard.pp @@ -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) + + +} diff --git a/rtl/netwlibc/libc.pp b/rtl/netwlibc/libc.pp index 2bf9dfc11b..3892e4a766 100644 --- a/rtl/netwlibc/libc.pp +++ b/rtl/netwlibc/libc.pp @@ -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()*) diff --git a/rtl/netwlibc/system.pp b/rtl/netwlibc/system.pp index a017cd622d..f0d5461ea4 100644 --- a/rtl/netwlibc/system.pp +++ b/rtl/netwlibc/system.pp @@ -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 } diff --git a/rtl/netwlibc/sysutils.pp b/rtl/netwlibc/sysutils.pp index f3846644cf..b881c0e47a 100644 --- a/rtl/netwlibc/sysutils.pp +++ b/rtl/netwlibc/sysutils.pp @@ -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 } diff --git a/rtl/netwlibc/video.pp b/rtl/netwlibc/video.pp new file mode 100644 index 0000000000..024f643d17 --- /dev/null +++ b/rtl/netwlibc/video.pp @@ -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. +