* added keyboard and video

* a lot of fixes

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 \

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

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
-    begin
-      find_setfields (f);
-      exit;
-    end else
-    if fnmatch(@f._mask[1],Pdirent(f.EntryP)^.d_name,FNM_CASEFOLD) = 0 then
+    if find_setfields (f) 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
 
 }

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

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()*)
 

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
 
 }

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
 
 }

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.
+