diff --git a/rtl/inc/objects.pp b/rtl/inc/objects.pp index 93ccaed8fe..75049890d2 100644 --- a/rtl/inc/objects.pp +++ b/rtl/inc/objects.pp @@ -215,6 +215,15 @@ const MaxReadBytes = $fffe; invalidhandle = -1; {$ENDIF} +{$IFDEF Netware} +type + FNameStr = String; + THandle = Longint; +const + MaxReadBytes = $7fffffff; + invalidhandle = -1; +{$ENDIF} + {---------------------------------------------------------------------------} { DOS ASCIIZ FILENAME } @@ -2800,7 +2809,10 @@ END; END. { $Log$ - Revision 1.3 2000-11-13 13:40:04 marco + Revision 1.4 2001-04-16 18:36:41 florian + * updates from Armin commited + + Revision 1.3 2000/11/13 13:40:04 marco * Renamefest Revision 1.2 2000/07/13 11:33:44 michael diff --git a/rtl/netware/Makefile b/rtl/netware/Makefile new file mode 100644 index 0000000000..2aab91ebfe --- /dev/null +++ b/rtl/netware/Makefile @@ -0,0 +1,71 @@ +# Makefile for freepascal rtl for netware +# Needs working nlmconv + i386-netware-ld + +UNITDIR = /usr/lib/fpc/1.1/units/netware/rtl +PPC386OPT = -n -di386 -dSYSTEMDEBUG -O3 -Sg -Tnetware -Aelf -a -al -FE. +INCLUDES = -I../inc -I../i386 -I../objpas + +SYSUNIT=system +OBJEXT=on +PPUEXT=ppn +ASMEXT=s +OBJS = $(SYSUNIT).$(OBJEXT) ../inc/strings.$(OBJEXT) dos.$(OBJEXT) nwpre.$(OBJEXT) ../objpas/objpas.$(OBJEXT) sysutils.$(OBJEXT) crt.$(OBJEXT) sockets.$(OBJEXT) mouse.$(OBJEXT) netware.$(OBJEXT) video.$(OBJEXT) keyboard.$(OBJEXT) ../objpas/math.$(OBJEXT) ../objpas/typinfo.$(OBJEXT) ../inc/objects.$(OBJEXT) ../inc/getopts.$(OBJEXT) ../inc/heaptrc.$(OBJEXT) varutils.$(OBJEXT) ../i386/cpu.$(OBJEXT) ../i386/mmx.$(OBJEXT) + + +all: $(OBJS) + +$(SYSUNIT).$(OBJEXT): $(SYSUNIT).pp nwsys.inc + ppc386 -Us $(PPC386OPT) $(INCLUDES) $(SYSUNIT).pp + +%.$(OBJEXT): %.pp nwsys.inc + ppc386 $(PPC386OPT) $(INCLUDES) $*.pp + +install: $(OBJS) + + cp -f $(SYSUNIT).$(OBJEXT) $(UNITDIR) + cp -f $(SYSUNIT).$(PPUEXT) $(UNITDIR) + cp -f dos.$(OBJEXT) $(UNITDIR) + cp -f dos.$(PPUEXT) $(UNITDIR) + cp -f strings.$(OBJEXT) $(UNITDIR) + cp -f strings.$(PPUEXT) $(UNITDIR) + cp -f nwpre.$(OBJEXT) $(UNITDIR) + cp -f nwpre.$(PPUEXT) $(UNITDIR) + cp -f sysutils.$(OBJEXT) $(UNITDIR) + cp -f sysutils.$(PPUEXT) $(UNITDIR) + cp -f objpas.$(OBJEXT) $(UNITDIR) + cp -f objpas.$(PPUEXT) $(UNITDIR) + cp -f crt.$(OBJEXT) $(UNITDIR) + cp -f crt.$(PPUEXT) $(UNITDIR) + cp -f sockets.$(OBJEXT) $(UNITDIR) + cp -f sockets.$(PPUEXT) $(UNITDIR) + cp -f mouse.$(OBJEXT) $(UNITDIR) + cp -f mouse.$(PPUEXT) $(UNITDIR) + cp -f netware.$(OBJEXT) $(UNITDIR) + cp -f netware.$(PPUEXT) $(UNITDIR) + cp -f video.$(OBJEXT) $(UNITDIR) + cp -f video.$(PPUEXT) $(UNITDIR) + cp -f keyboard.$(OBJEXT) $(UNITDIR) + cp -f keyboard.$(PPUEXT) $(UNITDIR) + cp -f math.$(OBJEXT) $(UNITDIR) + cp -f math.$(PPUEXT) $(UNITDIR) + cp -f typinfo.$(OBJEXT) $(UNITDIR) + cp -f typinfo.$(PPUEXT) $(UNITDIR) + cp -f objects.$(OBJEXT) $(UNITDIR) + cp -f objects.$(PPUEXT) $(UNITDIR) + cp -f getopts.$(OBJEXT) $(UNITDIR) + cp -f getopts.$(PPUEXT) $(UNITDIR) + cp -f heaptrc.$(OBJEXT) $(UNITDIR) + cp -f heaptrc.$(PPUEXT) $(UNITDIR) + cp -f varutils.$(OBJEXT) $(UNITDIR) + cp -f varutils.$(PPUEXT) $(UNITDIR) + cp -f cpu.$(OBJEXT) $(UNITDIR) + cp -f cpu.$(PPUEXT) $(UNITDIR) + cp -f mmx.$(OBJEXT) $(UNITDIR) + cp -f mmx.$(PPUEXT) $(UNITDIR) + cp -f nwimp/*.imp $(UNITDIR) + +clean: + rm -f *.$(OBJEXT) *.$(PPUEXT) *.$(ASMEXT) *.bak + +dist: + clean diff --git a/rtl/netware/README b/rtl/netware/README new file mode 100644 index 0000000000..a3ec2248b8 --- /dev/null +++ b/rtl/netware/README @@ -0,0 +1,181 @@ + News + ==== + + 2001/04/16 armin: + - implemented CRT and SYSUTILS + - nwimp/convertimp to convert .imp files to unix + + + + General + ======= + + Currently generating NetWare-NLM's only work under Linux. (may be under bsd also) + This is because nlmconv from binutils does not work with i.e. win32 coff object files. + It works fine with ELF-Objects. + + + Binutils with netware-support needed + ==================================== + + You need a version of binutils compiled with netware-support. (nlmconv has to be present) + Unfortunately in the Linux distibutions this component of the binutils is not included + so you have to compile it. So download the latest stable binutils package from your + favourite GNU mirror, decompress it ('tar xfz binutils-x.yy.z.tar.gz' on unices + with GNU tar), change to the binutils-x.yy.z directory and configure: + + ./configure --prefix=/usr --enable-shared --enable-targets=i386-netware,i386-linux + + I used the prefix /usr because thats the default location on redhat (thats what I'm using) + + and use + + make + make install + + to build and install binutils. To check that netware is supported by the version of binutils + installed, use ld --version. The emulation 'i386nw' must be present. Also check that nlmconv + is present and can be started without specifying the complete path of nlmconv. + + You can find more information and a binary version of binutils with netware-support for + linux on: + http://home.sch.bme.hu/~keresztg/novell/howto/NLM-Linux-HOWTO.html. + + + Building the freepascal runtime-library for netware + =================================================== + + Install the current fpc sources from ftp.freepascal.org and change to the directory + rtl/netware under the freepascal sourcetree. Verify the path of your units in + Makefile. The default is /usr/lib/fpc/1.1/units/netware/rtl. + Compile and install the rtl with + + make install + + Settings and needed files to compile for netware + ================================================ + + Edit your /etc/ppc386.cfg and add the rtl source path for netware. This are my settings, + you may paste it to your ppc386.cfg: + +#IFDEF Netware + -Fu/usr/lib/fpc/1.1/units/netware/rtl + -Fl/usr/lib/fpc/1.1/units/netware/rtl +#ENDIF + + This adds the search path for the rtl-units as well as for the needed import-files. + You can use the import files from the rtl/netware directory, they are automaticly + installed. If you want to use import files from novell, be aware that you have to + convert the files to unix format (i.e. with dos2unix). + + Building the first nlm + ====================== + + Ok, now you have installed all needed files, try the following program and compile it + with + + ppc386 -Tnetware hello.pas + + PROGRAM Hello; + {$Description The FreePascal HelloWorld for Netware} + {$Version 1.0.0} + + BEGIN + WriteLn ('This is open source ! FreePascal for netware'); + END. + + Hints on using freepascal for nlm's + =================================== + + - Compiler Switches + ----------------- + The following compiler-swiches are supported for NetWare: + $DESCRIPTION : NLM-Description, will be displayed at load-time + $M : For Stack-Size. Heap-Size will be ignored + $VERSION x.x.x : Sets Major, Minor and Revision, Revision 0 is nothing, 1=a, 2=b ... + + Sorry, Displaying copyright does not work with nlmconv from gnu bunutils. There is a patch + available for nlmconv but currently there is no compiler switch in fpc. Implementing the + compiler switch is on my todo list. This is also valid for the screen-name. + + - Exports + ------- + + Exports will be handled like in win32: + procedure bla; CDECL; EXPORT; + begin + end; + + exports bla name 'bla'; + + Be aware that without Name 'bla' this will be exported in upper-case. + + - Netware import (.imp) files + --------------------------- + + Import files are needed by nlmconv as with other netware linkers. FreePascal is + searching import files via the specified library path (-Fl). If you plan to use + import files from novell be aware that they have to be converted from CR/LF to + LF only. The script 'convertimp' in rtl/netware/nwimp will do that. + If a module name is specified in an import, the module is automaticly + declared as autoload by FreePascal. + + I.e. the following declaration needs nlmlib.imp and sets nlmlib.nlm as autoload: + + FUNCTION rmdir (path : PCHAR) : LONGINT; CDECL; EXTERNAL 'nlmlib.nlm' NAME 'rmdir'; + + while the following declaration only imports the symbol without autoloading: + + FUNCTION rmdir (path : PCHAR) : LONGINT; CDECL; EXTERNAL; + + If nlmlib.nlm is not loaded while loading yout nlm, you will get an error abount + unknown symbols. + + + - Debugging + --------- + + Thats currently a problem. There is no source level debugger available. The only way + to debug is using the netware internal debugger or nwdbg. nwdbg is a debugger on + assembler level written by Jan Beulich. Symbols are supported. You can get nwdbg for + netware 4.11,5.0 or 5.1 at developer.novell.com. + + I read about plans to adapt gdb to current netware versions. As soon as i have news + about gdb i will change this document. + + - Netware SDK + ----------- + + Delphi declarations for the multiplattform api is available at + http://developer.novell.com. You can download the sdk after registering as a developer. + The files are designed for win32 so they will not work off the box. I think changing + the dll-name to the corrosponding nlm-name will work. + i.e. in calwin32.imp the following declaration: + + function NWAbortServicingQueueJob2; StdCall; external 'calwin32.dll' index 231; + + has to be changed to + + function NWAbortServicingQueueJob2; CDecl; external 'calwin32.nlm'; + + - FreePascal RTL + -------------- + + Currently the following units are available for netware: + + - SYSTEM + - CRT + - DOS + - SYSUTILS + - STRINGS + - KEYBOARD + - VIDEO + - MATH + - TYPINFO + - OBJECTS + - GETOPTS + - HEAPTRC + - VARUTILS + - CPU + - MMX + diff --git a/rtl/netware/crt.pp b/rtl/netware/crt.pp new file mode 100644 index 0000000000..a3e86182b6 --- /dev/null +++ b/rtl/netware/crt.pp @@ -0,0 +1,723 @@ +{ + $Id$ + Copyright (c) 1999-2001 by the Free Pascal development team. + + Borland Pascal 7 Compatible CRT Unit for Netware, tested with + Netware 4.11 and 5.1 + + 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. + + **********************************************************************} +{At initialization time, AutoScreenDestructionMode is set to true so after program termination + no "press any key to close screen" is displayed. Also check for ctrl-c in readkey is disabled. + To enable ctrl-c check, set CheckBreak to true before calling ReadKey. + + 2001/04/13 armin: first version for netware, compilable, completely untested + 2001/04/14 armin: tested, seems to work + TextMode, Sound and NoSound are dummys, don't know how to + implement that for netware +} +unit crt; +interface + +const +{ CRT modes } + BW40 = 0; { 40x25 B/W on Color Adapter } + CO40 = 1; { 40x25 Color on Color Adapter } + BW80 = 2; { 80x25 B/W on Color Adapter } + CO80 = 3; { 80x25 Color on Color Adapter } + Mono = 7; { 80x25 on Monochrome Adapter } + Font8x8 = 256; { Add-in for ROM font } + +{ Mode constants for 3.0 compatibility } + C40 = CO40; + C80 = CO80; + +{ Foreground and background color constants } + Black = 0; + Blue = 1; + Green = 2; + Cyan = 3; + Red = 4; + Magenta = 5; + Brown = 6; + LightGray = 7; + +{ Foreground color constants } + DarkGray = 8; + LightBlue = 9; + LightGreen = 10; + LightCyan = 11; + LightRed = 12; + LightMagenta = 13; + Yellow = 14; + White = 15; + +{ Add-in for blinking } + Blink = 128; + +var + +{ Interface variables } + CheckBreak: Boolean; { Enable Ctrl-Break, supported on Netware } + CheckEOF: Boolean; { Enable Ctrl-Z, supported on Netware } + DirectVideo: Boolean; { Enable direct video addressing } + CheckSnow: Boolean; { Enable snow filtering } + LastMode: Word; { Current text mode } + TextAttr: Byte; { Current text attribute } + WindMin: Word; { Window upper left coordinates } + WindMax: Word; { Window lower right coordinates } + +{ Interface procedures } +procedure AssignCrt(var F: Text); +function KeyPressed: Boolean; +function ReadKey: Char; +procedure TextMode(Mode: Integer); {dummy function} +procedure Window(X1,Y1,X2,Y2: Byte); +procedure GotoXY(X,Y: Byte); +function WhereX: Byte; +function WhereY: Byte; +procedure ClrScr; +procedure ClrEol; +procedure InsLine; +procedure DelLine; +procedure TextColor(Color: Byte); +procedure TextBackground(Color: Byte); +procedure LowVideo; +procedure HighVideo; +procedure NormVideo; +procedure Delay(MS: Word); +procedure Sound(Hz: Word); {dummy function} +procedure NoSound; {dummy function} + +{Extra Functions} +procedure cursoron; +procedure cursoroff; +procedure cursorbig; + + +implementation + +{$I nwsys.inc} + + +{$ASMMODE ATT} + +var + DelayCnt, + ScreenWidth, + ScreenHeight : longint; + VidSeg : Word; + +{ + definition of textrec is in textrec.inc +} +{$i textrec.inc} + + +{**************************************************************************** + Low level Routines +****************************************************************************} + +procedure setscreenmode(mode : byte); +begin +end; + + +function GetScreenHeight : longint; +VAR Height, Width : WORD; +begin + _GetSizeOfScreen (Height,Width); + GetScreenHeight := Height; +end; + + +function GetScreenWidth : longint; +VAR Height, Width : WORD; +begin + _GetSizeOfScreen (Height,Width); + GetScreenWidth := Width; +end; + + +procedure GetScreenCursor(var x,y : longint); +begin + x := _wherex+1; + y := _wherey+1; +end; + + +{**************************************************************************** + Helper Routines +****************************************************************************} + +Function WinMinX: Longint; +{ + Current Minimum X coordinate +} +Begin + WinMinX:=(WindMin and $ff)+1; +End; + + + +Function WinMinY: Longint; +{ + Current Minimum Y Coordinate +} +Begin + WinMinY:=(WindMin shr 8)+1; +End; + + + +Function WinMaxX: Longint; +{ + Current Maximum X coordinate +} +Begin + WinMaxX:=(WindMax and $ff)+1; +End; + + + +Function WinMaxY: Longint; +{ + Current Maximum Y coordinate; +} +Begin + WinMaxY:=(WindMax shr 8) + 1; +End; + + +Function FullWin:boolean; +{ + Full Screen 80x25? Window(1,1,80,25) is used, allows faster routines +} +begin + FullWin:=(WinMinX=1) and (WinMinY=1) and + (WinMaxX=ScreenWidth) and (WinMaxY=ScreenHeight); +end; + + +{**************************************************************************** + Public Crt Functions +****************************************************************************} + + +procedure textmode(mode : integer); +begin + Window (1,1,ScreenWidth,ScreenHeight); + ClrScr; +end; + + +Procedure TextColor(Color: Byte); +{ + Switch foregroundcolor +} +Begin + TextAttr:=(Color and $f) or (TextAttr and $70); + If (Color>15) Then TextAttr:=TextAttr Or Blink; +End; + + + +Procedure TextBackground(Color: Byte); +{ + Switch backgroundcolor +} +Begin + TextAttr:=((Color shl 4) and ($f0 and not Blink)) or (TextAttr and ($0f OR Blink) ); +End; + + + +Procedure HighVideo; +{ + Set highlighted output. +} +Begin + TextColor(TextAttr Or $08); +End; + + + +Procedure LowVideo; +{ + Set normal output +} +Begin + TextColor(TextAttr And $77); +End; + + + +Procedure NormVideo; +{ + Set normal back and foregroundcolors. +} +Begin + TextColor(7); + TextBackGround(0); +End; + + +Procedure GotoXy(X: Byte; Y: Byte); +{ + Go to coordinates X,Y in the current window. +} +Begin + If (X>0) and (X<=WinMaxX- WinMinX+1) and + (Y>0) and (Y<=WinMaxY-WinMinY+1) Then + Begin + X := X + WinMinX - 1; + Y := Y + WinMinY - 1; + _GotoXY (x-1,y-1); + End; +End; + + +Procedure Window(X1, Y1, X2, Y2: Byte); +{ + Set screen window to the specified coordinates. +} +Begin + if (X1>X2) or (X2>ScreenWidth) or + (Y1>Y2) or (Y2>ScreenHeight) then + exit; + WindMin:=((Y1-1) Shl 8)+(X1-1); + WindMax:=((Y2-1) Shl 8)+(X2-1); + GoToXY(1,1); +End; + + +Procedure ClrScr; +{ + Clear the current window, and set the cursor on 1,1 +} +var + fil : word; + y : longint; + p : pointer; + rowlen,rows: longint; +begin + fil:=32 or (textattr shl 8); + if FullWin then + begin + _clrscr; {seems to swich cursor off} + _DisplayInputCursor; + end else + begin + rowlen := WinMaxX-WinMinX+1; + rows := WinMaxY-WinMinY+1; + GetMem (p, rows * rowlen * 2); + FillWord (p^, rows * rowlen, fil); + _CopyToScreenMemory (rows,rowlen,p,WinMinX-1,WinMinY-1); + FreeMem (p, rows * rowlen * 2); + end; + Gotoxy(1,1); +end; + + +Procedure ClrEol; +{ + Clear from current position to end of line. +} +var + x,y : longint; + fil : word; + rowlen : word; + p : pointer; +Begin + GetScreenCursor(x,y); + fil:=32 or (textattr shl 8); + if x 0); +end; + + +{************************************************************************* + Delay +*************************************************************************} + +procedure Delay(MS: Word); +begin + _delay (MS); +end; + + +procedure sound(hz : word); +begin + _RingTheBell; +end; + + +procedure nosound; +begin +end; + + + +{**************************************************************************** + HighLevel Crt Functions +****************************************************************************} + +procedure removeline(y : longint); +var + fil : word; + rowlen : word; + p : pointer; +begin + fil:=32 or (textattr shl 8); + rowlen:=WinMaxX-WinMinX+1; + GetMem (p, rowlen*2); + y:=WinMinY+y-1; + While (y<=WinMaxY) do + begin + _CopyFromScreenMemory (1,rowlen,p,WinMinX-1,y); + _CopyToScreenMemory (1,rowlen,p,WinMinX-1,y-1); + inc(y); + end; + FillWord (p^,rowlen,fil); + _CopyToScreenMemory (1,rowlen,p,WinMinX-1,WinMaxY-1); + FreeMem (p, rowlen*2); +end; + + +procedure delline; +begin + removeline(wherey); +end; + + +procedure insline; +var + my,y : longint; + fil : word; + rowlen,x : word; + p : pointer; +begin + fil:=32 or (textattr shl 8); + y:=WhereY-1; + my:=WinMaxY-WinMinY; + rowlen := WinMaxX-WinMinX+1; + GetMem (p, rowlen*2); + while (my>=y) do + begin + _CopyFromScreenMemory (1,rowlen,p,WinMinX-1,my); + _CopyToScreenMemory (1,rowlen,p,WinMinX-1,my+1); + dec(my); + end; + FillWord (p^,rowlen,fil); + _CopyToScreenMemory (1,rowlen,p,x,y); + FreeMem (p, rowlen*2); +end; + + + + +{**************************************************************************** + Extra Crt Functions +****************************************************************************} + +procedure cursoron; +begin + if _IsColorMonitor <> 0 then + _SetCursorShape (9,$A) + else + _SetCursorShape ($B,$D); + _DisplayInputCursor; +end; + + +procedure cursoroff; +begin + _HideInputCursor; +end; + + +procedure cursorbig; +begin + _SetCursorShape (1,$A); + _DisplayInputCursor; +end; + + +{***************************************************************************** + Read and Write routines +*****************************************************************************} + +var + CurrX,CurrY : longint; + +Procedure WriteChar(c:char); +var + w : word; +begin + case c of + #10 : inc(CurrY); + #13 : CurrX:=WinMinX; + #8 : begin + if CurrX>WinMinX then + dec(CurrX); + end; + #7 : begin { beep } + _RingTheBell; + end; + else + begin + w:=(textattr shl 8) or byte(c); + _CopyToScreenMemory (1,1,@w,CurrX-1,CurrY-1); + inc(CurrX); + end; + end; + if CurrX>WinMaxX then + begin + CurrX:=WinMinX; + inc(CurrY); + end; + while CurrY>WinMaxY do + begin + removeline(1); + dec(CurrY); + end; +end; + + +Function CrtWrite(var f : textrec):integer; +var + i : longint; +begin + GetScreenCursor(CurrX,CurrY); + for i:=0 to f.bufpos-1 do + WriteChar(f.buffer[i]); { ad: may be better to use a buffer but i think it's fast enough } + _GotoXY (CurrX-1,CurrY-1); + f.bufpos:=0; + CrtWrite:=0; +end; + + +Function CrtRead(Var F: TextRec): Integer; + + procedure BackSpace; + begin + if (f.bufpos>0) and (f.bufpos=f.bufend) then + begin + WriteChar(#8); + WriteChar(' '); + WriteChar(#8); + dec(f.bufpos); + dec(f.bufend); + end; + end; + +var + ch : Char; +Begin + GetScreenCursor(CurrX,CurrY); + f.bufpos:=0; + f.bufend:=0; + repeat + if f.bufpos>f.bufend then + f.bufend:=f.bufpos; + _GotoXY (CurrX-1,CurrY-1); + ch:=readkey; + case ch of + #0 : case readkey of + #71 : while f.bufpos>0 do + begin + dec(f.bufpos); + WriteChar(#8); + end; + #75 : if f.bufpos>0 then + begin + dec(f.bufpos); + WriteChar(#8); + end; + #77 : if f.bufpos0 do + BackSpace; + end; + #13 : begin + WriteChar(#13); + WriteChar(#10); + f.bufptr^[f.bufend]:=#13; + f.bufptr^[f.bufend+1]:=#10; + inc(f.bufend,2); + break; + end; + #26 : if CheckEOF then + begin + f.bufptr^[f.bufend]:=#26; + inc(f.bufend); + break; + end; + else + begin + if f.bufpos25 then + lastmode:=lastmode or $100; + TextColor (LightGray); + TextBackground (Black); +{ Redirect the standard output } + assigncrt(Output); + Rewrite(Output); + TextRec(Output).Handle:=StdOutputHandle; + assigncrt(Input); + Reset(Input); + TextRec(Input).Handle:=StdInputHandle; + CheckBreak := FALSE; + CheckEOF := FALSE; + _SetCtrlCharCheckMode (CheckBreak); + _SetAutoScreenDestructionMode (TRUE); +end. + diff --git a/rtl/netware/dos.pp b/rtl/netware/dos.pp index ccdcc202ce..74d5778433 100644 --- a/rtl/netware/dos.pp +++ b/rtl/netware/dos.pp @@ -15,9 +15,11 @@ **********************************************************************} { 2000/09/03 armin: first version - 2001/03/08 armin: implemented more functions + 2001/04/08 armin: implemented more functions OK: Implemented and tested NI: not implemented + 2001/04/15 armin: FindFirst bug corrected, FExpand and FSearch tested, GetCBreak, SetCBreak + implemented } unit dos; @@ -79,8 +81,8 @@ Type End; searchrec = packed record - DirP : POINTER; { used for opendir } - EntryP: POINTER; { and readdir } + DirP : POINTER; { used for opendir } + EntryP: POINTER; { and readdir } Magic : WORD; fill : array[1..11] of byte; attr : byte; @@ -134,8 +136,8 @@ Procedure FindClose(Var f: SearchRec); {ok} {File} Procedure GetFAttr(var f; var attr: word); {ok} Procedure GetFTime(var f; var time: longint); {ok} -Function FSearch(path: pathstr; dirlist: string): pathstr; {untested} -Function FExpand(const path: pathstr): pathstr; {untested} +Function FSearch(path: pathstr; dirlist: string): pathstr; {ok} +Function FExpand(const path: pathstr): pathstr; {ok} Procedure FSplit(path: pathstr; var dir: dirstr; var name: {untested} namestr; var ext: extstr); @@ -263,12 +265,15 @@ end; procedure getcbreak(var breakvalue : boolean); begin - breakvalue := true; + breakvalue := _SetCtrlCharCheckMode (false); { get current setting } + if breakvalue then + _SetCtrlCharCheckMode (breakvalue); { and restore old setting } end; procedure setcbreak(breakvalue : boolean); begin + _SetCtrlCharCheckMode (breakvalue); end; @@ -452,9 +457,11 @@ BEGIN time := PNWDirEnt(EntryP)^.d_time + (LONGINT (PNWDirEnt(EntryP)^.d_date) SHL 16); size := PNWDirEnt(EntryP)^.d_size; name := strpas (PNWDirEnt(EntryP)^.d_nameDOS); + doserror := 0; END ELSE BEGIN FillChar (f,SIZEOF(f),0); + doserror := 18; END; END; END; @@ -480,8 +487,11 @@ begin F.Magic := $AD01; PNWDirEnt(f.EntryP) := _readdir (PNWDirEnt(f.DirP)); IF F.EntryP = NIL THEN - doserror := 18 - ELSE + BEGIN + _closedir (PNWDirEnt(f.DirP)); + f.Magic := 0; + doserror := 18; + END ELSE find_setfields (f); END; end; @@ -850,7 +860,10 @@ end; end. { $Log$ - Revision 1.2 2001-04-11 14:17:00 florian + Revision 1.3 2001-04-16 18:39:50 florian + * updates from Armin commited + + Revision 1.2 2001/04/11 14:17:00 florian * added logs, fixed email address of Armin, it is diehl@nordrhein.de diff --git a/rtl/netware/keyboard.pp b/rtl/netware/keyboard.pp new file mode 100644 index 0000000000..d35a99fdfc --- /dev/null +++ b/rtl/netware/keyboard.pp @@ -0,0 +1,134 @@ +{ + $Id$ + This file is part of the Free Pascal run time library. + Copyright (c) 1999-2001 by the Free Pascal development team. + + Keyboard unit for netware + + See the file COPYING.FPC, included in this distribution, + for details about the copyright. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + + **********************************************************************} +{ 2001/04/16 armin: first version for netware } +unit Keyboard; +interface + +{$i keybrdh.inc} + +implementation + +{$i keyboard.inc} +{$i nwsys.inc} + +procedure InitKeyboard; +begin + PendingKeyEvent := 0; +end; + +procedure DoneKeyboard; +begin +end; + +function GetKeyEvent: TKeyEvent; +var T : TKeyEvent; +begin + if PendingKeyEvent<>0 then + begin + GetKeyEvent:=PendingKeyEvent; + PendingKeyEvent:=0; + exit; + end; + T := byte(_getch); + if T = 0 then + T := word(_getch) shl 8; + GetKeyEvent := $03000000 OR T; +end; + + +function PollKeyEvent: TKeyEvent; +begin + if PendingKeyEvent<>0 then + exit(PendingKeyEvent); + if _kbhit <> 0 then + begin + PendingKeyEvent := byte(_getch); + if PendingKeyEvent = 0 then + PendingKeyEvent := word(_getch) shl 8; + PendingKeyEvent := PendingKeyEvent OR $03000000; + PollKeyEvent := PendingKeyEvent; + end else + PollKeyEvent := 0; +end; + + +function PollShiftStateEvent: TKeyEvent; +begin + PollShiftStateEvent:=0; +end; + + +{ Function key translation } +type + TTranslationEntry = packed record + Min, Max: Byte; + Offset: Word; + end; +const + TranslationTableEntries = 12; + TranslationTable: array [1..TranslationTableEntries] of TTranslationEntry = + ((Min: $3B; Max: $44; Offset: kbdF1), { function keys F1-F10 } + (Min: $54; Max: $5D; Offset: kbdF1), { Shift fn keys F1-F10 } + (Min: $5E; Max: $67; Offset: kbdF1), { Ctrl fn keys F1-F10 } + (Min: $68; Max: $71; Offset: kbdF1), { Alt fn keys F1-F10 } + (Min: $85; Max: $86; Offset: kbdF11), { function keys F11-F12 } + (Min: $87; Max: $88; Offset: kbdF11), { Shift+function keys F11-F12 } + (Min: $89; Max: $8A; Offset: kbdF11), { Ctrl+function keys F11-F12 } + (Min: $8B; Max: $8C; Offset: kbdF11), { Alt+function keys F11-F12 } + (Min: 71; Max: 73; Offset: kbdHome), { Keypad keys kbdHome-kbdPgUp } + (Min: 75; Max: 77; Offset: kbdLeft), { Keypad keys kbdLeft-kbdRight } + (Min: 79; Max: 81; Offset: kbdEnd), { Keypad keys kbdEnd-kbdPgDn } + (Min: $52; Max: $53; Offset: kbdInsert)); + + +function TranslateKeyEvent(KeyEvent: TKeyEvent): TKeyEvent; +var + I: Integer; + ScanCode: Byte; +begin + if KeyEvent and $03000000 = $03000000 then + begin + if KeyEvent and $000000FF <> 0 then + begin + TranslateKeyEvent := KeyEvent and $00FFFFFF; + exit; + end + else + begin + { This is a function key } + ScanCode := (KeyEvent and $0000FF00) shr 8; + for I := 1 to TranslationTableEntries do + begin + if (TranslationTable[I].Min <= ScanCode) and (ScanCode <= TranslationTable[I].Max) then + begin + TranslateKeyEvent := $02000000 + (KeyEvent and $00FF0000) + + (ScanCode - TranslationTable[I].Min) + TranslationTable[I].Offset; + exit; + end; + end; + end; + end; + TranslateKeyEvent := KeyEvent; +end; + + +function TranslateKeyEventUniCode(KeyEvent: TKeyEvent): TKeyEvent; +begin + TranslateKeyEventUniCode := KeyEvent; + ErrorCode:=errKbdNotImplemented; +end; + +end. diff --git a/rtl/netware/mouse.pp b/rtl/netware/mouse.pp new file mode 100644 index 0000000000..1bbe0fe165 --- /dev/null +++ b/rtl/netware/mouse.pp @@ -0,0 +1,117 @@ +{ + $Id$ + This file is part of the Free Pascal run time library. + Copyright (c) 1999-2000 by Florian Klaempfl + member of the Free Pascal development team + + Dummy Mouse unit for netware + + See the file COPYING.FPC, included in this distribution, + for details about the copyright. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + + **********************************************************************} +{2001/04/14 armin: first version, only a dummy, i think there is no 'official' way to support + a mouse under netware } +unit Mouse; +interface + +{$ifdef NOMOUSE} +{$DEFINE NOGPM} +{$ENDIF} + +const + MouseEventBufSize = 16; + +{$i mouseh.inc} + +implementation + + +procedure PlaceMouseCur(ofs:longint); +begin +end; + + +procedure InitMouse; +begin +end; + + +procedure DoneMouse; +begin +end; + + +function DetectMouse:byte; +begin + DetectMouse:=0; +end; + + +procedure ShowMouse; +begin +end; + + +procedure HideMouse; +begin +end; + + +function GetMouseX:word; +begin + GetMouseX:=0; +end; + + +function GetMouseY:word; +begin + GetMouseY:=0; +end; + + +function GetMouseButtons:word; +begin + GetMouseButtons:=0; +end; + + +procedure SetMouseXY(x,y:word); +begin +end; + + +procedure GetMouseEvent(var MouseEvent: TMouseEvent); +begin + fillchar(MouseEvent,SizeOf(TMouseEvent),#0); +end; + + +procedure PutMouseEvent(const MouseEvent: TMouseEvent); +begin +end; + + +function PollMouseEvent(var MouseEvent: TMouseEvent):boolean; +begin + fillchar(MouseEvent,SizeOf(TMouseEvent),#0); + exit(false); +end; + +end. +{ + $Log$ + Revision 1.1 2001-04-16 18:39:50 florian + * updates from Armin commited + + Revision 1.2 2001/01/21 20:21:40 marco + * Rename fest II. Rtl OK + + Revision 1.1 2001/01/13 11:03:58 peter + * API 2 RTL commit + +} diff --git a/rtl/netware/netware.pp b/rtl/netware/netware.pp new file mode 100644 index 0000000000..4640c07597 --- /dev/null +++ b/rtl/netware/netware.pp @@ -0,0 +1,176 @@ +{ + $Id$ + + Copyright (c) 1998 by + + + + 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 netware; + +interface + +const + NlmLib = 'nlmlib.nlm'; + +type + fdSet=array[0..7] of longint;{=256 bits} + pfdset=^fdset; + TFDSet=fdset; + + timeval = packed record + sec,usec:longint + end; + ptimeval=^timeval; + TTimeVal=timeval; + +Function Select(N:longint;readfds,writefds,exceptfds:PFDSet;TimeOut:PTimeVal):longint; CDECL; EXTERNAL NlmLib NAME 'select'; +Function Select(N:longint;readfds,writefds,exceptfds:PFDSet;TimeOut:Longint):longint; +Function SelectText(var T:Text;TimeOut :PTimeVal):Longint; + +Procedure FD_Zero(var fds:fdSet); +Procedure FD_Clr(fd:longint;var fds:fdSet); +Procedure FD_Set(fd:longint;var fds:fdSet); +Function FD_IsSet(fd:longint;var fds:fdSet):boolean; +Function GetFS (var T:Text):longint; +Function GetFS(Var F:File):longint; + + +implementation + +{ Get the definitions of textrec and filerec } +{$i textrec.inc} +{$i filerec.inc} + + +Function Select(N:longint;readfds,writefds,exceptfds:PFDSet;TimeOut:Longint):longint; +{ + Select checks whether the file descriptor sets in readfs/writefs/exceptfs + have changed. + This function allows specification of a timeout as a longint. +} +var + p : PTimeVal; + tv : TimeVal; +begin + if TimeOut=-1 then + p:=nil + else + begin + tv.Sec:=Timeout div 1000; + tv.Usec:=(Timeout mod 1000)*1000; + p:=@tv; + end; + Select:=Select(N,Readfds,WriteFds,ExceptFds,p); +end; + + + +Function SelectText(var T:Text;TimeOut :PTimeval):Longint; +Var + F:FDSet; +begin + if textrec(t).mode=fmclosed then + begin + {LinuxError:=Sys_EBADF;} + exit(-1); + end; + FD_Zero(f); + FD_Set(textrec(T).handle,f); + if textrec(T).mode=fminput then + SelectText:=select(textrec(T).handle+1,@f,nil,nil,TimeOut) + else + SelectText:=select(textrec(T).handle+1,nil,@f,nil,TimeOut); +end; + + +{-------------------------------- + FiledescriptorSets +--------------------------------} + +Procedure FD_Zero(var fds:fdSet); +{ + Clear the set of filedescriptors +} +begin + FillChar(fds,sizeof(fdSet),0); +end; + + + +Procedure FD_Clr(fd:longint;var fds:fdSet); +{ + Remove fd from the set of filedescriptors +} +begin + fds[fd shr 5]:=fds[fd shr 5] and (not (1 shl (fd and 31))); +end; + + + +Procedure FD_Set(fd:longint;var fds:fdSet); +{ + Add fd to the set of filedescriptors +} +begin + fds[fd shr 5]:=fds[fd shr 5] or (1 shl (fd and 31)); +end; + + + +Function FD_IsSet(fd:longint;var fds:fdSet):boolean; +{ + Test if fd is part of the set of filedescriptors +} +begin + FD_IsSet:=((fds[fd shr 5] and (1 shl (fd and 31)))<>0); +end; + + + +Function GetFS (var T:Text):longint; +{ + Get File Descriptor of a text file. +} +begin + if textrec(t).mode=fmclosed then + exit(-1) + else + GETFS:=textrec(t).Handle +end; + + + +Function GetFS(Var F:File):longint; +{ + Get File Descriptor of an unTyped file. +} +begin + { Handle and mode are on the same place in textrec and filerec. } + if filerec(f).mode=fmclosed then + exit(-1) + else + GETFS:=filerec(f).Handle +end; + + + +end. +{ + $Log$ + Revision 1.1 2001-04-16 18:39:50 florian + * updates from Armin commited + + Revision 1.1 1999/02/19 15:37:26 peter + + init + +} + + diff --git a/rtl/netware/nwpre.pp b/rtl/netware/nwpre.pp index 67d08e4d8f..1cbdc37454 100644 --- a/rtl/netware/nwpre.pp +++ b/rtl/netware/nwpre.pp @@ -1,9 +1,32 @@ +{ + $Id$ + This file is part of the Free Pascal run time library. + Copyright (c) 1999-2000 by the Free Pascal development team + Copyright (c) 2001 Armin Diehl + + This unit implements the startup code for a netware nlm. It must be the first object file + linked. Currently the 'old-style', similar to novell's prelude.obj is used. With the newer + way (novells nwpre.obj) i only got abends. Dont know what's different in novells nwpre. + + 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 nwpre; interface -// AD 02.09.2000: Dont know why its not working with kNLMInfo... -// It always abends in TerminateNLM, so i am using the old style +{ 2000/08/29 armin: first version, untested + 2000/09/02 armin: Dont know why its not working with kNLMInfo... + It always abends in TerminateNLM, so i am using the old style + 2001/04/15 armin: Added comments, S- + Removed dead code } + {$DEFINE OldPrelude} FUNCTION _Prelude (NLMHandle : LONGINT; @@ -19,24 +42,27 @@ FUNCTION _Prelude (NLMHandle : LONGINT; implementation +{$S-} -FUNCTION _TerminateNLM (NLMInformation : POINTER; threadID, status : LONGINT) : LONGINT; CDECL; EXTERNAL; -FUNCTION _SetupArgV_411 (MainProc : POINTER) : LONGINT; CDECL; EXTERNAL; -FUNCTION _StartNLM (NLMHandle : LONGINT; - initErrorScreenID : LONGINT; - cmdLineP : PCHAR; - loadDirectoryPath : PCHAR; - uninitializedDataLength : LONGINT; - NLMFileHandle : LONGINT; - readRoutineP : POINTER; - customDataOffset : LONGINT; - customDataSize : LONGINT; - NLMInformation : POINTER; - userStartFunc : POINTER) : LONGINT; CDECL; EXTERNAL; -//PROCEDURE _exit (x : LONGINT); CDECL; EXTERNAL; +FUNCTION _TerminateNLM (NLMInformation : POINTER; + threadID, status : LONGINT) : LONGINT; CDECL; EXTERNAL; + +FUNCTION _SetupArgV_411 (MainProc : POINTER) : LONGINT; CDECL; EXTERNAL; + +FUNCTION _StartNLM (NLMHandle : LONGINT; + initErrorScreenID : LONGINT; + cmdLineP : PCHAR; + loadDirectoryPath : PCHAR; + uninitializedDataLength : LONGINT; + NLMFileHandle : LONGINT; + readRoutineP : POINTER; + customDataOffset : LONGINT; + customDataSize : LONGINT; + NLMInformation : POINTER; + userStartFunc : POINTER) : LONGINT; CDECL; EXTERNAL; -(*****************************************************************************) +{**************************************************************************************************} CONST TRADINIONAL_NLM_INFO_SIGNATURE = 0; TRADINIONAL_FLAVOR = 0; @@ -59,7 +85,7 @@ TYPE wchar_tSize : LONGINT; END; -CONST NLM_INFO_SIGNATURE = 'NLMI'; // $494d3c3e; // NLMI +CONST NLM_INFO_SIGNATURE = 'NLMI'; // $494d3c3e; kNLMInfo : kNLMInfoT = (Signature : NLM_INFO_SIGNATURE; @@ -69,8 +95,9 @@ CONST NLM_INFO_SIGNATURE = 'NLMI'; // $494d3c3e; // NLMI wchar_tSize : 2); {$ENDIF} -(*****************************************************************************) +{**************************************************************************************************} +{ _nlm_main is defined in system.pp. It sets command line parameters and calls PASCALMAIN } FUNCTION _nlm_main (Argc : LONGINT; ArgV : ARRAY OF PCHAR) : LONGINT; CDECL; EXTERNAL; @@ -125,7 +152,10 @@ END; end. { $Log$ - Revision 1.2 2001-04-11 14:17:00 florian + Revision 1.3 2001-04-16 18:39:50 florian + * updates from Armin commited + + Revision 1.2 2001/04/11 14:17:00 florian * added logs, fixed email address of Armin, it is diehl@nordrhein.de diff --git a/rtl/netware/nwsock.inc b/rtl/netware/nwsock.inc new file mode 100644 index 0000000000..59851d1724 --- /dev/null +++ b/rtl/netware/nwsock.inc @@ -0,0 +1,213 @@ +{! completely untested !} + + +{****************************************************************************** + Import Socket Functions from nlmlib +******************************************************************************} + +CONST SockLib = 'nlmlib.nlm'; + +Function _NWsocket(Domain,SocketType,Protocol:Longint):Longint; CDECL; EXTERNAL SockLib NAME 'socket'; +Function _NWSend(Sock:Longint;Var Addr;AddrLen,Flags:Longint):Longint; CDECL; EXTERNAL SockLib NAME 'send'; +Function _NWRecv(Sock:Longint;Var Addr;AddrLen,Flags:Longint):Longint; CDECL; EXTERNAL SockLib NAME 'recv'; +Function _NWBind(Sock:Longint;Var Addr;AddrLen:Longint):Longint; CDECL; EXTERNAL SockLib NAME 'bind'; +Function _NWListen(Sock,MaxConnect:Longint):Longint; CDECL; EXTERNAL SockLib NAME 'listen'; +Function _NWAccept(Sock:Longint;Var Addr;Var Addrlen:Longint):Longint; CDECL; EXTERNAL SockLib NAME 'accept'; +Function _NWConnect(Sock:Longint;Var Addr;Addrlen:Longint): longint; CDECL; EXTERNAL SockLib NAME 'connect'; +Function _NWShutdown(Sock:Longint;How:Longint):Longint; CDECL; EXTERNAL SockLib NAME 'shutdown'; +Function _NWGetSocketName(Sock:Longint;Var Addr;Var Addrlen:Longint):Longint; CDECL; EXTERNAL SockLib NAME 'getsocketname'; +Function _NWGetPeerName(Sock:Longint;Var Addr;Var Addrlen:Longint):Longint; CDECL; EXTERNAL SockLib NAME 'getpeername'; +Function _NWSetSockOpt(Sock,Level,OptName:Longint;Var OptVal;optlen:longint):Longint; CDECL; EXTERNAL SockLib NAME 'setsockopt'; +Function _NWGetSockOpt(Sock,Level,OptName:Longint;Var OptVal;Var optlen:longint):Longint; CDECL; EXTERNAL SockLib NAME 'getsockopt'; + + +{****************************************************************************** + Basic Socket Functions +******************************************************************************} + +Function socket(Domain,SocketType,Protocol:Longint):Longint; +begin + Socket:=_NWSocket(Domain,SocketType,Protocol); +end; + +Function Send(Sock:Longint;Var Addr;AddrLen,Flags:Longint):Longint; +begin + Send:=_NWSend(Sock,Addr,AddrLen,Flags); +end; + +Function Recv(Sock:Longint;Var Addr;AddrLen,Flags:Longint):Longint; +begin + Recv:=_NWRecv(Sock,Addr,AddrLen,Flags); +end; + +Function Bind(Sock:Longint;Var Addr;AddrLen:Longint):Boolean; +begin + Bind:=(_NWBind(Sock,Addr,AddrLen)=0); +end; + +Function Listen(Sock,MaxConnect:Longint):Boolean; +begin + Listen:=(_NWListen(Sock,MaxConnect)=0); +end; + +Function Accept(Sock:Longint;Var Addr;Var Addrlen:Longint):Longint; +begin + Accept:=_NWAccept(Sock,Addr,AddrLen); + If Accept<0 Then + Accept:=-1; +end; + +Function Connect(Sock:Longint;Var Addr;Addrlen:Longint): boolean; +begin + Connect:=_NWConnect(Sock,Addr,AddrLen)=0; +end; + + +Function Shutdown(Sock:Longint;How:Longint):Longint; +begin + ShutDown:=_NWShutdown(Sock,How); +end; + + +Function GetSocketName(Sock:Longint;Var Addr;Var Addrlen:Longint):Longint; +begin + GetSocketName:=_NWGetSocketName(Sock,Addr,AddrLen); +end; + + + +Function GetPeerName(Sock:Longint;Var Addr;Var Addrlen:Longint):Longint; +begin + GetPeerName:=_NWGetPeerName(Sock,Addr,AddrLen); +end; + + + +Function SetSocketOptions(Sock,Level,OptName:Longint;Var OptVal;optlen:longint):Longint; +begin + SetSocketOptions:=_NWSetsockopt(Sock,Level,OptName,OptVal,OptLen); +end; + + + +Function GetSocketOptions(Sock,Level,OptName:Longint;Var OptVal;Var optlen:longint):Longint; +begin + GetSocketOptions:=_NWGetsockopt(Sock,Level,OptName,OptVal,OptLen); +end; + + + +Function SocketPair(Domain,SocketType,Protocol:Longint;var Pair:TSockArray):Longint; +begin + //SocketPair:=do_syscall(syscall_nr_SocketPair,Domain,SocketType,Protocol,longint(@Pair),0,0); + Socketpair := -1; +end; + +{****************************************************************************** + UnixSock +******************************************************************************} + +Procedure Str2UnixSockAddr(const addr:string;var t:TUnixSockAddr;var len:longint); +begin + Move(Addr[1],t.Path,length(Addr)); + t.Family:=AF_UNIX; + t.Path[length(Addr)]:=#0; + Len:=Length(Addr)+3; +end; + + +Function Bind(Sock:longint;const addr:string):boolean; +var + UnixAddr : TUnixSockAddr; + AddrLen : longint; +begin + Str2UnixSockAddr(addr,UnixAddr,AddrLen); + Bind(Sock,UnixAddr,AddrLen); + Bind:=(SocketError=0); +end; + + + +Function DoAccept(Sock:longint;var addr:string):longint; +var + UnixAddr : TUnixSockAddr; + AddrLen : longint; +begin + AddrLen:=length(addr)+3; + DoAccept:=Accept(Sock,UnixAddr,AddrLen); + Move(UnixAddr.Path,Addr[1],AddrLen); + SetLength(Addr,AddrLen); +end; + + + +Function DoConnect(Sock:longint;const addr:string):Boolean; +var + UnixAddr : TUnixSockAddr; + AddrLen : longint; +begin + Str2UnixSockAddr(addr,UnixAddr,AddrLen); + DoConnect:=Connect(Sock,UnixAddr,AddrLen); +end; + +Function Accept(Sock:longint;var addr:string;var SockIn,SockOut:text):Boolean; +var + s : longint; +begin + S:=DoAccept(Sock,addr); + if S>0 then + begin + Sock2Text(S,SockIn,SockOut); + Accept:=true; + end + else + Accept:=false; +end; + + + +Function Accept(Sock:longint;var addr:string;var SockIn,SockOut:File):Boolean; +var + s : longint; +begin + S:=DoAccept(Sock,addr); + if S>0 then + begin + Sock2File(S,SockIn,SockOut); + Accept:=true; + end + else + Accept:=false; +end; + + + +Function Connect(Sock:longint;const addr:string;var SockIn,SockOut:text):Boolean; +begin + Connect:=DoConnect(Sock,addr); + If Connect then + Sock2Text(Sock,SockIn,SockOut); +end; + + + +Function Connect(Sock:longint;const addr:string;var SockIn,SockOut:file):Boolean; +begin + Connect:=DoConnect(Sock,addr); + if Connect then + Sock2File(Sock,SockIn,SockOut); +end; + + +// fsread and fswrite are used in socket.inc +procedure fdwrite (Handle:longint; VAR Data; Len : LONGINT); +begin + { this has to be checked: } + _NWSend(Handle,Data,Len,0); +end; + +function fdread (Handle:longint; VAR Data; Len : LONGINT) : LONGINT; +begin + { this has to be checked: } + fdread := _NWRecv(Handle,Data,Len,0); +end; diff --git a/rtl/netware/nwsys.inc b/rtl/netware/nwsys.inc index 718e7ce692..a857a104b0 100644 --- a/rtl/netware/nwsys.inc +++ b/rtl/netware/nwsys.inc @@ -2,6 +2,7 @@ $Id$ This file is part of the Free Pascal run time library. Copyright (c) 1999-2000 by the Free Pascal development team + Copyright (c) 2001 Armin Diehl Interface to netware clib @@ -16,14 +17,16 @@ { 2000/08/27 armin: first version 2001/03/08 armin: additional functions + 2001/04/14 armin: additional functions for crt-unit } -CONST Clib = 'clib.nlm'; - NlmLib = 'nlmlib.nlm'; - Threads= 'threads.nlm'; - CalNlm = 'calnlm32.nlm'; - ClxNlm = 'clxnlm32.nlm'; - NitNlm = 'nit.nlm'; +CONST Clib = 'clib.nlm'; + NlmLib = 'nlmlib.nlm'; + Threads = 'threads.nlm'; + CalNlm = 'calnlm32.nlm'; + ClxNlm = 'clxnlm32.nlm'; + NitNlm = 'nit.nlm'; + ThreadsNlm = 'threads.nlm'; TYPE dev_t = LONGINT; @@ -68,14 +71,12 @@ FUNCTION _fstat (Fileno : LONGINT; VAR buf : NWStatBufT) : LONGINT; CDECL; EXTE PROCEDURE NWFree (P : POINTER); CDECL; EXTERNAL Clib NAME 'free'; -PROCEDURE PressAnyKeyToContinue; CDecl; EXTERNAL 'CLib.NLM'; -PROCEDURE ExitThread (action_code, termination_code : LONGINT); CDecl; EXTERNAL 'CLib.NLM'; -PROCEDURE _exit (ExitCode : LONGINT); CDecl; EXTERNAL 'CLib.NLM'; -PROCEDURE ConsolePrintf (FormatStr : PCHAR; Param : LONGINT); CDecl; EXTERNAL ('CLib.NLM'); -PROCEDURE printf (FormatStr : PCHAR; Param : LONGINT); CDecl; EXTERNAL ('CLib.NLM'); -//PROCEDURE printf (FormatStr : PCHAR; Param : PCHAR); CDecl; EXTERNAL ('CLib.NLM'); -PROCEDURE ConsolePrintf3 (FormatStr : PCHAR; P1,P2,P3 : LONGINT); CDecl; EXTERNAL ('CLib.NLM') NAME 'ConsolePrintf'; -//FUNCTION strlen(lpString: PChar): LONGINT; CDECL; EXTERNAL Clib; +PROCEDURE PressAnyKeyToContinue; CDecl; EXTERNAL; // Clib; +PROCEDURE ExitThread (action_code, termination_code : LONGINT); CDecl; EXTERNAL CLib; +PROCEDURE _exit (ExitCode : LONGINT); CDecl; EXTERNAL CLib; +PROCEDURE ConsolePrintf (FormatStr : PCHAR; Param : LONGINT); CDecl; EXTERNAL CLib; +PROCEDURE printf (FormatStr : PCHAR; Param : LONGINT); CDecl; EXTERNAL CLib; +PROCEDURE ConsolePrintf3 (FormatStr : PCHAR; P1,P2,P3 : LONGINT); CDecl; EXTERNAL CLib NAME 'ConsolePrintf'; // values for __action_code used with ExitThread() CONST @@ -87,15 +88,6 @@ FUNCTION _GetStdIn : POINTER; CDECL; EXTERNAL Clib NAME '__get_stdin'; // resu FUNCTION _GetStdOut : POINTER; CDECL; EXTERNAL Clib NAME '__get_stdout'; FUNCTION _GetStdErr : POINTER; CDECL; EXTERNAL Clib NAME '__get_stderr'; -// Stream FileIO -//FUNCTION _fopen (filename, mode : PCHAR) : LONGINT; CDECL; EXTERNAL Clib NAME 'fopen'; -//FUNCTION _fclose (hFile : LONGINT) : LONGINT; CDECL; EXTERNAL Clib NAME 'fclose'; -//FUNCTION _fwrite (Buffer : POINTER; S1,S2,hFile : LONGINT) : LONGINT; CDECL; EXTERNAL Clib NAME 'fwrite'; -//FUNCTION _fread (Buffer : POINTER; S1,S2,hFile : LONGINT) : LONGINT; CDECL; EXTERNAL Clib NAME 'fread'; -//FUNCTION _fseek (hFile, Offset, Where : LONGINT) : LONGINT; CDECL; EXTERNAL Clib NAME 'fseek'; -//FUNCTION _ftell (hFile : LONGINT) : LONGINT; CDECL; EXTERNAL Clib NAME 'ftell'; - - // FileIO by Fileno FUNCTION _open (FileName : PCHAR; access, mode : LONGINT) : LONGINT; CDECL; EXTERNAL NlmLib NAME 'open'; FUNCTION _close (FileNo : LONGINT) : LONGINT; CDECL; EXTERNAL NlmLib NAME 'close'; @@ -106,11 +98,50 @@ FUNCTION _write (FileNo : LONGINT; BufP : POINTER; Len : LONGINT) : LONGINT; CD FUNCTION _read (FileNo : LONGINT; BufP : POINTER; Len : LONGINT) : LONGINT; CDECL; EXTERNAL NlmLib NAME 'read'; FUNCTION _filelength (filedes : LONGINT) : LONGINT; CDECL; EXTERNAL NlmLib NAME 'filelength'; +TYPE + NWModifyStructure = + RECORD + MModifyName : PCHAR; + MFileAttributes : LONGINT; + MFileAttributesMask : LONGINT; + MCreateDate : WORD; + MCreateTime : WORD; + MOwnerID : LONGINT; + MLastArchivedDate : WORD; + MLastArchivedTime : WORD; + MLastArchivedID : LONGINT; + MLastUpdatedDate : WORD; + MLastUpdatedTime : WORD; + MLastUpdatedID : LONGINT; + MLastAccessedDate : WORD; + MInheritanceGrantMask : WORD; + MInheritanceRevokeMask : WORD; + MMaximumSpace : LONGINT; + MLastUpdatedInSeconds : LONGINT + END; + +CONST MModifyNameBit = $0001; + MFileAtrributesBit = $0002; + MCreateDateBit = $0004; + MCreateTimeBit = $0008; + MOwnerIDBit = $0010; + MLastArchivedDateBit = $0020; + MLastArchivedTimeBit = $0040; + MLastArchivedIDBit = $0080; + MLastUpdatedDateBit = $0100; + MLastUpdatedTimeBit = $0200; + MLastUpdatedIDBit = $0400; + MLastAccessedDateBit = $0800; + MInheritanceRestrictionMaskBit = $1000; + MMaximumSpaceBit = $2000; + MLastUpdatedInSecondsBit = $4000; + // Directory FUNCTION _chdir (path : PCHAR) : LONGINT; CDECL; EXTERNAL NlmLib NAME 'chdir'; FUNCTION _getcwd (path : PCHAR; pathlen : LONGINT) : PCHAR; CDECL; EXTERNAL NlmLib NAME 'getcwd'; FUNCTION _mkdir (path : PCHAR) : LONGINT; CDECL; EXTERNAL NlmLib NAME 'mkdir'; FUNCTION _rmdir (path : PCHAR) : LONGINT; CDECL; EXTERNAL NlmLib NAME 'rmdir'; +FUNCTION _ChangeDirectoryEntry (PathName : PCHAR; VAR ModyStruct : NWModifyStructure; ModifyBits, AllowWildcard : LONGINT) : LONGINT; CDECL; EXTERNAL NitNlm NAME 'ChangeDirectoryEntry'; // get fileno from stream FUNCTION _fileno (Handle : LONGINT) : LONGINT; CDECL; EXTERNAL Clib NAME 'fileno'; @@ -209,22 +240,22 @@ FUNCTION GetServerInformation(returnSize:longint; serverInfo:pFILE_SERV_INFO):lo // Directory TYPE NWDirEnt = PACKED RECORD - d_attr : LONGINT; - d_time : WORD; - d_date : WORD; - d_size : LONGINT; - d_ino : LONGINT; - d_dev : LONGINT; - d_cdatetime : LONGINT; - d_adatetime : LONGINT; - d_bdatetime : LONGINT; - d_uid : LONGINT; - d_archivedID: LONGINT; - d_updatedID : LONGINT; - d_nameDOS : ARRAY [0..12] OF CHAR; + d_attr : LONGINT; + d_time : WORD; {modification time} + d_date : WORD; {modification date} + d_size : LONGINT; {filesize} + d_ino : LONGINT; {serial number} + d_dev : LONGINT; {volume number} + d_cdatetime : time_t; {creation date and time} + d_adatetime : time_t; {last access - files only} + d_bdatetime : time_t; {last archive date and time} + d_uid : LONGINT; {owner id (object id) } + d_archivedID : LONGINT; + d_updatedID : LONGINT; + d_nameDOS : ARRAY [0..12] OF CHAR; d_inheritedRightsMask : WORD; d_originatingNameSpace: BYTE; - d_ddatetime : LONGINT; + d_ddatetime : time_t; {deleted date time} d_deletedID : LONGINT; {---- new fields starting in v4.11 ----} d_name : ARRAY [0..255] OF CHAR; { enty's namespace name } @@ -252,9 +283,36 @@ TYPE NWDirEnt = VAR volumeisRemovable : WORD) : LONGINT; CDECL; EXTERNAL NitNlm NAME 'GetVolumeInfoWithNumber'; FUNCTION _GetNumberOfVolumes : LONGINT; CDECL; EXTERNAL NitNlm NAME 'GetNumberOfVolumes'; +// Screen/Keyboad +PROCEDURE _CopyToScreenMemory (Height, Width : WORD; Data : POINTER; x, y : WORD); CDECL; EXTERNAL ThreadsNlm NAME 'CopyToScreenMemory'; +PROCEDURE _CopyFromScreenMemory (Height, Width : WORD; Data : POINTER; x, y : WORD); CDECL; EXTERNAL ThreadsNlm NAME 'CopyFromScreenMemory'; +FUNCTION _DisplayInputCursor : LONGINT; CDECL; EXTERNAL ThreadsNlm NAME 'DisplayInputCursor'; +FUNCTION _HideInputCursor : LONGINT; CDECL; EXTERNAL ThreadsNlm NAME 'HideInputCursor'; +FUNCTION _SetPositionOfInputCursor (row,col : WORD): LONGINT; CDECL; EXTERNAL ThreadsNlm NAME 'SetPositionOfInputCursor'; +PROCEDURE _GotoXY (col, row : WORD); CDECL; EXTERNAL ThreadsNlm NAME 'gotoxy'; +FUNCTION _GetSizeOfScreen (VAR height,width : WORD): LONGINT; CDECL; EXTERNAL ThreadsNlm NAME 'GetSizeOfScreen'; +FUNCTION _IsColorMonitor : LONGINT; CDECL; EXTERNAL ThreadsNlm NAME 'IsColorMonitor'; +PROCEDURE _RingTheBell; CDECL; EXTERNAL ThreadsNlm NAME 'RingTheBell'; +FUNCTION _SetCursorShape (startline,endline : BYTE) : WORD; CDECL; EXTERNAL ThreadsNlm NAME 'SetCursorShape'; +FUNCTION _GetCursorShape (VAR startline,endline : BYTE) : WORD; CDECL; EXTERNAL ThreadsNlm NAME 'GetCursorShape'; +FUNCTION _wherex : WORD; CDECL; EXTERNAL ThreadsNlm NAME 'wherex'; +FUNCTION _wherey : WORD; CDECL; EXTERNAL ThreadsNlm NAME 'wherey'; +PROCEDURE _clrscr; CDECL; EXTERNAL ThreadsNlm NAME 'clrscr'; +FUNCTION _kbhit : LONGINT; CDECL; EXTERNAL ThreadsNlm NAME 'kbhit'; +FUNCTION _getch : CHAR; CDECL; EXTERNAL ThreadsNlm NAME 'getch'; +PROCEDURE _delay (miliseconds : longint); CDECL; EXTERNAL ThreadsNlm NAME 'delay'; +FUNCTION _SetCtrlCharCheckMode (Enabled : BOOLEAN) : BOOLEAN; CDECL; EXTERNAL ThreadsNlm NAME 'SetCtrlCharCheckMode'; +FUNCTION _SetAutoScreenDestructionMode (Enabled : BOOLEAN) : BOOLEAN; CDECL; EXTERNAL ThreadsNlm NAME 'SetAutoScreenDestructionMode'; + +// Misc +FUNCTION _memcpy (Dest, Src : POINTER; Len : LONGINT) : POINTER; CDECL; EXTERNAL ThreadsNlm NAME 'memcpy'; + { $Log$ - Revision 1.2 2001-04-11 14:17:00 florian + Revision 1.3 2001-04-16 18:39:50 florian + * updates from Armin commited + + Revision 1.2 2001/04/11 14:17:00 florian * added logs, fixed email address of Armin, it is diehl@nordrhein.de diff --git a/rtl/netware/objinc.inc b/rtl/netware/objinc.inc new file mode 100644 index 0000000000..ef97881d89 --- /dev/null +++ b/rtl/netware/objinc.inc @@ -0,0 +1,87 @@ +{ 2001/04/16 armin: first version for netware } + +{$i errno.inc} +{$i nwsys.inc} + +FUNCTION errno : LONGINT; +BEGIN + errno := __get_errno_ptr^; +END; + +FUNCTION FileOpen (Var FileName: AsciiZ; Mode: Word): THandle; +VAR NWMode : longint; +BEGIN + NWMode:=0; + if Mode=stCreate then + Begin + NWMode:=O_Creat; + NWMode:=NWMode or O_RdWr; + end + else + Begin + Case (Mode and 3) of + 0 : NWMode:=NWMode or O_RdOnly; + 1 : NWMode:=NWMode or O_WrOnly; + 2 : NWMode:=NWMode or O_RdWr; + end; + end; + FileOpen:=_open (pchar(@FileName[0]),NWMode,0); + If FileOpen=-1 then FileOpen:=0; + DosStreamError:=Errno; +END; + +FUNCTION FileRead (Handle: THandle; Var BufferArea; BufferLength: Sw_Word; +Var BytesMoved: Sw_Word): Word; +BEGIN + BytesMoved:=_read (Handle,@BufferArea,BufferLength); + IF BytesMoved = -1 THEN + BEGIN + DosStreamError:=Errno; + FileRead:=Errno; + END ELSE + BEGIN + DosStreamError:=0; + FileRead:=0; + END; +END; + +FUNCTION FileWrite (Handle: THandle; Var BufferArea; BufferLength: Sw_Word; +Var BytesMoved: Sw_Word): Word; +BEGIN + BytesMoved:=_write (Handle,@BufferArea,BufferLength); + IF BytesMoved = -1 THEN + BEGIN + DosStreamError:=Errno; + FileWrite:=Errno; + END ELSE + BEGIN + DosStreamError:=0; + FileWrite:=0; + END; +END; + +FUNCTION SetFilePos (Handle: THandle; Pos: LongInt; MoveType: Word; +VAR NewPos: LongInt): Word; + +BEGIN + NewPos:=_lseek (Handle,Pos,MoveType); + IF NewPos = -1 THEN + SetFilePos:=Errno + ELSE + SetFilePos := 0; +END; + +FUNCTION FileClose (Handle: THandle): Word; +BEGIN + _Close (Handle); + DosStreamError:=Errno; + FileClose := Errno; +END; + +FUNCTION SetFileSize (Handle: THandle; FileSize: LongInt): Word; +BEGIN + if _chsize (Handle, FileSize) = -1 then + SetFileSize := Errno + else + SetFileSize := 0; +END; diff --git a/rtl/netware/sockets.pp b/rtl/netware/sockets.pp new file mode 100644 index 0000000000..57107e21b5 --- /dev/null +++ b/rtl/netware/sockets.pp @@ -0,0 +1,178 @@ +{ Netware:UNTESTED !! + $Id$ + This file is part of the Free Pascal run time library. + Copyright (c) 1999-2000 by the Free Pascal development team + + See the file COPYING.FPC, included in this distribution, + for details about the copyright. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + + **********************************************************************} +unit Sockets; +Interface + +const + {$Ifndef BSD} + { Adress families, Linux specific } + AF_AX25 = 3; { Amateur Radio AX.25 } + AF_IPX = 4; { Novell IPX } + AF_APPLETALK = 5; { Appletalk DDP } + AF_NETROM = 6; { Amateur radio NetROM } + AF_BRIDGE = 7; { Multiprotocol bridge } + AF_AAL5 = 8; { Reserved for Werner's ATM } + AF_X25 = 9; { Reserved for X.25 project } + AF_INET6 = 10; { IP version 6 } + AF_MAX = 12; + + SOCK_PACKET = 10; + + PF_AX25 = AF_AX25; + PF_IPX = AF_IPX; + PF_APPLETALK = AF_APPLETALK; + PF_NETROM = AF_NETROM; + PF_BRIDGE = AF_BRIDGE; + PF_AAL5 = AF_AAL5; + PF_X25 = AF_X25; + PF_INET6 = AF_INET6; + + PF_MAX = AF_MAX; + {$ELSE} + {BSD} + AF_LOCAL =1; { local to host (pipes, portals) } + AF_IMPLINK =3; { arpanet imp addresses } + AF_PUP =4; { pup protocols: e.g. BSP } + AF_CHAOS =5; { mit CHAOS protocols } + AF_NS =6; { XEROX NS protocols } + AF_ISO =7; { ISO protocols } + AF_OSI =AF_ISO; + AF_ECMA =8; { European computer manufacturers } + AF_DATAKIT =9; { datakit protocols } + AF_CCITT =10; { CCITT protocols, X.25 etc } + AF_SNA =11; { IBM SNA } + AF_DECnet =12; { DECnet } + AF_DLI =13; { DEC Direct data link interface } + AF_LAT =14; { LAT } + AF_HYLINK =15; { NSC Hyperchannel } + AF_APPLETALK =16; { Apple Talk } + AF_ROUTE =17; { Internal Routing Protocol } + AF_LINK =18; { Link layer interface } + pseudo_AF_XTP =19; { eXpress Transfer Protocol (no AF) } + AF_COIP =20; { connection-oriented IP, aka ST II } + AF_CNT =21; { Computer Network Technology } + pseudo_AF_RTIP =22; { Help Identify RTIP packets } + AF_IPX =23; { Novell Internet Protocol } + AF_SIP =24; { Simple Internet Protocol } + pseudo_AF_PIP =25; { Help Identify PIP packets } + AF_ISDN =26; { Integrated Services Digital Network} + AF_E164 =AF_ISDN; { CCITT E.164 recommendation } + pseudo_AF_KEY =27; { Internal key-management function } + AF_INET6 =28; { IPv6 } + AF_NATM =29; { native ATM access } + AF_ATM =30; { ATM } + pseudo_AF_HDRCMPLT=31; { Used by BPF to not rewrite headers + in interface output routine} + AF_NETGRAPH =32; { Netgraph sockets } + AF_MAX =33; + + SOCK_MAXADDRLEN =255; { longest possible addresses } + +{ +* Protocol families, same as address families for now. +} + PF_LOCAL =AF_LOCAL; + PF_IMPLINK =AF_IMPLINK; + PF_PUP =AF_PUP; + PF_CHAOS =AF_CHAOS; + PF_NS =AF_NS; + PF_ISO =AF_ISO; + PF_OSI =AF_ISO; + PF_ECMA =AF_ECMA; + PF_DATAKIT =AF_DATAKIT; + PF_CCITT =AF_CCITT; + PF_SNA =AF_SNA; + PF_DECnet =AF_DECnet; + PF_DLI =AF_DLI; + PF_LAT =AF_LAT; + PF_HYLINK =AF_HYLINK; + PF_APPLETALK =AF_APPLETALK; + PF_ROUTE =AF_ROUTE; + PF_LINK =AF_LINK; + PF_XTP =pseudo_AF_XTP; { really just proto family, no AF } + PF_COIP =AF_COIP; + PF_CNT =AF_CNT; + PF_SIP =AF_SIP; + PF_IPX =AF_IPX; { same format as AF_NS } + PF_RTIP =pseudo_AF_RTIP; { same format as AF_INET } + PF_PIP =pseudo_AF_PIP; + PF_ISDN =AF_ISDN; + PF_KEY =pseudo_AF_KEY; + PF_INET6 =AF_INET6; + PF_NATM =AF_NATM; + PF_ATM =AF_ATM; + PF_NETGRAPH =AF_NETGRAPH; + PF_MAX =AF_MAX; +{$ENDIF} + +type + TUnixSockAddr = packed Record + family:word; { was byte, fixed } + path:array[0..108] of char; + end; + +{$i socketsh.inc} + +{ unix socket specific functions } +Procedure Str2UnixSockAddr(const addr:string;var t:TUnixSockAddr;var len:longint); +Function Bind(Sock:longint;const addr:string):boolean; +Function Connect(Sock:longint;const addr:string;var SockIn,SockOut:text):Boolean; +Function Connect(Sock:longint;const addr:string;var SockIn,SockOut:file):Boolean; +Function Accept(Sock:longint;var addr:string;var SockIn,SockOut:text):Boolean; +Function Accept(Sock:longint;var addr:string;var SockIn,SockOut:File):Boolean; + +Implementation +{$ifndef netware} +Uses Unix; +{$endif} + +{ Include filerec and textrec structures } +{$i filerec.inc} +{$i textrec.inc} +{****************************************************************************** + Kernel Socket Callings +******************************************************************************} + +{$ifdef BSD} + {$I bsdsock.inc} +{$else} + {$ifdef netware} + {$I nwsock.inc} + {$else} + {$I linsock.inc} + {$endif} +{$endif} + +{$i sockets.inc} + +end. + +{ + $Log$ + Revision 1.1 2001-04-16 18:39:50 florian + * updates from Armin commited + + Revision 1.3 2001/01/21 20:21:40 marco + * Rename fest II. Rtl OK + + Revision 1.2 2000/09/18 13:14:51 marco + * Global Linux +bsd to (rtl/freebsd rtl/unix rtl/linux structure) + + Revision 1.3 2000/09/11 14:05:31 marco + * FreeBSD support and removed old signalhandling + + Revision 1.2 2000/07/13 11:33:49 michael + + removed logs + +} diff --git a/rtl/netware/system.pp b/rtl/netware/system.pp index a2d8d87714..00b36f189f 100644 --- a/rtl/netware/system.pp +++ b/rtl/netware/system.pp @@ -17,6 +17,7 @@ unit system; { 2000/09/03 armin: first version 2001/03/08 armin: changes for fpc 1.1 + 2001/04/16 armin: dummy envp for heaptrc-unit } interface @@ -57,9 +58,18 @@ VAR ArgC : INTEGER; ArgV : ppchar; +CONST + envp : ppchar = nil; {dummy to make heaptrc happy} + implementation +{ ?? why does this not work ?? DEFINE FPC_SYSTEM_HAS_MOVE} +{procedure move (const source; var dest; count : longint); +begin + _memcpy (@dest, @source, count); +end;} + { include system independent routines } {$I system.inc} @@ -76,7 +86,7 @@ end; -procedure PascalMain;external name 'PASCALMAIN'; +procedure PASCALMAIN;external name 'PASCALMAIN'; procedure fpc_do_exit;external name 'FPC_DO_EXIT'; @@ -545,10 +555,16 @@ Begin Setup_Arguments; { Reset IO Error } InOutRes:=0; + {Delphi Compatible} + IsLibrary := FALSE; + IsConsole := TRUE; End. { $Log$ - Revision 1.2 2001-04-11 14:17:00 florian + Revision 1.3 2001-04-16 18:39:50 florian + * updates from Armin commited + + Revision 1.2 2001/04/11 14:17:00 florian * added logs, fixed email address of Armin, it is diehl@nordrhein.de diff --git a/rtl/netware/sysutils.pp b/rtl/netware/sysutils.pp index 00b99999be..19c7f71ec5 100644 --- a/rtl/netware/sysutils.pp +++ b/rtl/netware/sysutils.pp @@ -15,8 +15,6 @@ **********************************************************************} -{currently nothing is implemented !} - unit sysutils; interface @@ -25,14 +23,48 @@ interface {$H+} uses DOS; -// Unix,errors; {$I nwsys.inc} {$I errno.inc} +TYPE + TNetwareFindData = + RECORD + DirP : PNWDirEnt; { used for opendir } + EntryP: PNWDirEnt; { and readdir } + Magic : WORD; { to avoid abends with uninitialized TSearchRec } + END; + + + { Include platform independent interface part } {$i sysutilh.inc} +{ additional NetWare file flags} +CONST + faSHARE = $00000080; { 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 } + + faIMMPURG = $00010000; { Immediate purge } + faNORENAM = $00020000; { Rename inhibit } + faNODELET = $00040000; { Delete inhibit } + faNOCOPY = $00080000; { 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. } + + implementation @@ -45,18 +77,16 @@ implementation ****************************************************************************} Function FileOpen (Const FileName : string; Mode : Integer) : Longint; - -Var LinuxFlags : longint; - +VAR NWOpenFlags : longint; BEGIN - {LinuxFlags:=0; + NWOpenFlags:=0; Case (Mode and 3) of - 0 : LinuxFlags:=LinuxFlags or Open_RdOnly; - 1 : LinuxFlags:=LinuxFlags or Open_WrOnly; - 2 : LinuxFlags:=LinuxFlags or Open_RdWr; + 0 : NWOpenFlags:=NWOpenFlags or O_RDONLY; + 1 : NWOpenFlags:=NWOpenFlags or O_WRONLY; + 2 : NWOpenFlags:=NWOpenFlags or O_RDWR; end; - FileOpen:=fdOpen (FileName,LinuxFlags); - } + FileOpen := _open (pchar(FileName),NWOpenFlags,0); + //!! We need to set locking based on Mode !! end; @@ -64,211 +94,190 @@ end; Function FileCreate (Const FileName : String) : Longint; begin - //FileCreate:=fdOpen(FileName,Open_RdWr or Open_Creat or Open_Trunc); + FileCreate:=_open(Pchar(FileName),O_RdWr or O_Creat or O_Trunc,0); end; Function FileRead (Handle : Longint; Var Buffer; Count : longint) : Longint; begin - //FileRead:=fdRead (Handle,Buffer,Count); + FileRead:=_read (Handle,@Buffer,Count); end; Function FileWrite (Handle : Longint; const Buffer; Count : Longint) : Longint; begin - //FileWrite:=fdWrite (Handle,Buffer,Count); + FileWrite:=_write (Handle,@Buffer,Count); end; Function FileSeek (Handle,FOffset,Origin : Longint) : Longint; begin - //FileSeek:=fdSeek (Handle,FOffset,Origin); + FileSeek:=_lseek (Handle,FOffset,Origin); end; Procedure FileClose (Handle : Longint); begin - //fdclose(Handle); + _close(Handle); end; Function FileTruncate (Handle,Size: Longint) : boolean; begin - //FileTruncate:=fdtruncate(Handle,Size); + FileTruncate:=(_chsize(Handle,Size) = 0); end; Function FileAge (Const FileName : String): Longint; -//Var Info : Stat; -// Y,M,D,hh,mm,ss : word; - +VAR Info : NWStatBufT; + PTM : PNWTM; begin -{ If not fstat (FileName,Info) then + If _stat (pchar(FileName),Info) <> 0 then exit(-1) else begin - EpochToLocal(info.mtime,y,m,d,hh,mm,ss); - Result:=DateTimeToFileDate(EncodeDate(y,m,d)+EncodeTime(hh,mm,ss,0)); - end;} + PTM := _localtime (Info.st_mtime); + 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)); + end; end; Function FileExists (Const FileName : String) : Boolean; - -//Var Info : Stat; - +VAR Info : NWStatBufT; begin - //FileExists:=fstat(filename,Info); + FileExists:=(_stat(pchar(filename),Info) = 0); end; -{ -Function LinuxToWinAttr (FN : Pchar; Const Info : Stat) : Longint; -begin - Result:=faArchive; - If (Info.Mode and STAT_IFDIR)=STAT_IFDIR then - Result:=Result or faDirectory; - If (FN[0]='.') and (not (FN[1] in [#0,'.'])) then - Result:=Result or faHidden; - If (Info.Mode and STAT_IWUSR)=0 Then - Result:=Result or faReadOnly; - If (Info.Mode and - (STAT_IFSOCK or STAT_IFBLK or STAT_IFCHR or STAT_IFIFO))<>0 then - Result:=Result or faSysFile; -end; -} -{ - GlobToSearch takes a glob entry, stats the file. - The glob entry is removed. - If FileAttributes match, the entry is reused -} -{Type - TGlobSearchRec = Record - Path : String; - GlobHandle : PGlob; - end; - PGlobSearchRec = ^TGlobSearchRec;} - -{Function GlobToTSearchRec (Var Info : TSearchRec) : Boolean; - -Var SInfo : Stat; - p : Pglob; - GlobSearchRec : PGlobSearchrec; - -begin - GlobSearchRec:=PGlobSearchrec(Info.FindHandle); - P:=GlobSearchRec^.GlobHandle; - Result:=P<>Nil; - If Result then - begin - GlobSearchRec^.GlobHandle:=P^.Next; - Result:=Fstat(GlobSearchRec^.Path+StrPas(p^.name),SInfo); - If Result then - begin - Info.Attr:=LinuxToWinAttr(p^.name,SInfo); - Result:=(Info.ExcludeAttr and Info.Attr)=0; - If Result Then - With Info do - begin - Attr:=Info.Attr; - If P^.Name<>Nil then - Name:=strpas(p^.name); - Time:=Sinfo.mtime; - Size:=Sinfo.Size; - end; - end; - P^.Next:=Nil; - GlobFree(P); - end; -end;} - -Function DoFind(Var Rslt : TSearchRec) : Longint; - -//Var GlobSearchRec : PGlobSearchRec; - -begin - Result:=-1; -{ GlobSearchRec:=PGlobSearchRec(Rslt.FindHandle); - If (GlobSearchRec^.GlobHandle<>Nil) then - While (GlobSearchRec^.GlobHandle<>Nil) and not (Result=0) do - If GlobToTSearchRec(Rslt) Then Result:=0;} -end; +PROCEDURE find_setfields (VAR f : TsearchRec); +VAR T : Dos.DateTime; +BEGIN + WITH F DO + BEGIN + IF FindData.Magic = $AD01 THEN + BEGIN + {attr := FindData.EntryP^.d_attr AND $FF;} // lowest 8 bit -> same as dos + attr := FindData.EntryP^.d_attr; { return complete netware attributes } + UnpackTime(FindData.EntryP^.d_time + (LONGINT (FindData.EntryP^.d_date) SHL 16), T); + time := DateTimeToFileDate(EncodeDate(T.Year,T.Month,T.day)+EncodeTime(T.Hour,T.Min,T.Sec,0)); + size := FindData.EntryP^.d_size; + name := strpas (FindData.EntryP^.d_nameDOS); + END ELSE + BEGIN + FillChar (f,SIZEOF(f),0); + END; + END; +END; Function FindFirst (Const Path : String; Attr : Longint; Var Rslt : TSearchRec) : Longint; - -//Var GlobSearchRec : PGlobSearchRec; - begin - {New(GlobSearchRec); - GlobSearchRec^.Path:=ExpandFileName(ExtractFilePath(Path)); - GlobSearchRec^.GlobHandle:=Glob(Path); - Rslt.ExcludeAttr:=Not Attr; //!! Not correct !! - Rslt.FindHandle:=Longint(GlobSearchRec); - Result:=DoFind (Rslt);} + IF path = '' then + exit (18); + Rslt.FindData.DirP := _opendir (pchar(Path)); + IF Rslt.FindData.DirP = NIL THEN + exit (18); + IF attr <> faAnyFile THEN + _SetReaddirAttribute (Rslt.FindData.DirP, attr); + Rslt.FindData.Magic := $AD01; + Rslt.FindData.EntryP := _readdir (Rslt.FindData.DirP); + IF Rslt.FindData.EntryP = NIL THEN + BEGIN + _closedir (Rslt.FindData.DirP); + Rslt.FindData.DirP := NIL; + exit (18); + END ELSE + BEGIN + find_setfields (Rslt); + exit (0); + END; end; Function FindNext (Var Rslt : TSearchRec) : Longint; begin -// Result:=DoFind (Rslt); + IF Rslt.FindData.Magic <> $AD01 THEN + exit (18); + Rslt.FindData.EntryP := _readdir (Rslt.FindData.DirP); + IF Rslt.FindData.EntryP = NIL THEN + exit (18) + ELSE + BEGIN + find_setfields (Rslt); + exit (0); + END; end; Procedure FindClose (Var F : TSearchrec); - -//Var GlobSearchRec : PGlobSearchRec; - begin - {GlobSearchRec:=PGlobSearchRec(F.FindHandle); - GlobFree (GlobSearchRec^.GlobHandle); - Dispose(GlobSearchRec);} + IF F.FindData.Magic = $AD01 THEN + BEGIN + IF F.FindData.DirP <> NIL THEN + _closedir (F.FindData.DirP); + F.FindData.Magic := 0; + F.FindData.DirP := NIL; + F.FindData.EntryP := NIL; + END; end; Function FileGetDate (Handle : Longint) : Longint; - -//Var Info : Stat; - +Var Info : NWStatBufT; + PTM : PNWTM; begin - {If Not(FStat(Handle,Info)) then + If _fstat(Handle,Info) <> 0 then Result:=-1 else - Result:=Info.Mtime;} + begin + PTM := _localtime (Info.st_mtime); + 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)); + end; end; Function FileSetDate (Handle,Age : Longint) : Longint; - begin - // Impossible under Linux from FileHandle !! + { 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,0); end; Function FileGetAttr (Const FileName : String) : Longint; - -//Var Info : Stat; - +Var Info : NWStatBufT; begin -{ If Not FStat (FileName,Info) then + If _stat (pchar(FileName),Info) <> 0 then Result:=-1 Else - Result:=LinuxToWinAttr(Pchar(FileName),Info);} + Result := Info.st_attr AND $FFFF; end; Function FileSetAttr (Const Filename : String; Attr: longint) : Longint; - +VAR MS : NWModifyStructure; begin - Result:=-1; + FillChar (MS, SIZEOF (MS), 0); + if _ChangeDirectoryEntry (PChar (Filename), MS, MFileAtrributesBit, 0) <> 0 then + exit (-1) + else + exit (0); end; @@ -282,12 +291,11 @@ end; Function RenameFile (Const OldName, NewName : String) : Boolean; begin -// RenameFile:=Unix.FRename(OldNAme,NewName); + RenameFile:=(_rename(pchar(OldName),pchar(NewName)) = 0); end; Function FileSearch (Const Name, DirList : String) : String; - begin FileSearch:=Dos.FSearch(Name,Dirlist); end; @@ -340,6 +348,8 @@ Begin Diskfree:=int64(fs.bavail)*int64(fs.bsize) else Diskfree:=-1;} + DiskFree := -1; + ConsolePrintf ('warning: fpc sysutils.diskfree not implemented'#13#10,0); End; @@ -352,6 +362,8 @@ Begin DiskSize:=int64(fs.blocks)*int64(fs.bsize) else DiskSize:=-1;} + DiskSize := -1; + ConsolePrintf ('warning: fpc sysutils.disksize not implemented'#13#10,0); End; @@ -394,6 +406,7 @@ end; procedure Beep; begin + _RingTheBell; end; @@ -450,7 +463,7 @@ end; Function GetEnvironmentVariable(Const EnvVar : String) : String; begin -// Result:=StrPas(Unix.Getenv(PChar(EnvVar))); + Result:=StrPas(_getenv(PChar(EnvVar))); end; @@ -468,7 +481,10 @@ end. { $Log$ - Revision 1.2 2001-04-11 14:17:00 florian + Revision 1.3 2001-04-16 18:39:50 florian + * updates from Armin commited + + Revision 1.2 2001/04/11 14:17:00 florian * added logs, fixed email address of Armin, it is diehl@nordrhein.de diff --git a/rtl/netware/tests/Makefile b/rtl/netware/tests/Makefile new file mode 100644 index 0000000000..aae7722c21 --- /dev/null +++ b/rtl/netware/tests/Makefile @@ -0,0 +1,33 @@ +# Makefile for freepascal nlm-test +# Needs working nlmconv + i386-netware-ld +# AD 8/2000 + +UNITDIR = /usr/lib/fpc/1.1/units/netware/rtl +PPC386OPT = -a -al -Or -O3 -XX -Tnetware -Fi$(UNITDIR) +INCLUDES = -Fo$(UNITDIR) -Fu$(UNITDIR) + +OBJS = test.on + +%.on: %.pas + ppc386 $(PPC386OPT) $(INCLUDES) $*.pas + +all: $(OBJS) + +#test.nlm: $(OBJS) +# nlmconv -Ttest.def + +# mount netware and copy test.nlm to sys:test on 4.11 and 5.1 server +install: all + [ -d nw ] || mkdir nw + ncpmount -S FS-DEVELOP -U linux.home.ad -V sys -n nw + cp -f test.nlm nw/test/test.nlm + umount nw + ncpmount -S FS-AD -U linux.home.ad -V sys -n nw + cp -f test.nlm nw/test/test.nlm + umount nw + +clean: + rm -f *.on *.nlm *.ppn *.s *.bak *.o + [ -d nw ] && rmdir nw + +dist: clean diff --git a/rtl/netware/tests/test.pas b/rtl/netware/tests/test.pas new file mode 100644 index 0000000000..07080d5124 --- /dev/null +++ b/rtl/netware/tests/test.pas @@ -0,0 +1,604 @@ +Program Test; +{$Description Test for FreePascal Netware-RTL} +{$Version 1.1.0} + +{$I-} +{$Mode Delphi} + +USES Strings, Dos, SysUtils, CRT, Video, Keyboard; + +TYPE Str255 = STRING [255]; + +PROCEDURE ErrorCheck (Action,FN : STRING); +VAR Err : INTEGER; +BEGIN + Err := IOResult; + IF Err = 0 THEN + BEGIN + WriteLn (' OK'); + EXIT; + END; + WriteLn (' ! Error (',Action,' in ',FN,'), IOResult: ',Err); + HALT; +END; + +PROCEDURE FileTest; +CONST TestFN = 'SYS:TEST/TEST.DAT'; + NumBlocks = 100; + BlockSize = 1024; +VAR F : FILE; + Err : LONGINT; + Buffer : ARRAY [0..BlockSize-1] OF BYTE; + Written: LONGINT; + I : BYTE; + J : LONGINT; +BEGIN + Write ('Creating ',TestFN); + Assign (F,TestFN); + ReWrite (F,1); + ErrorCheck ('Create',TestFN); + FOR I := 1 TO NumBlocks DO + BEGIN + FillChar (Buffer, SIZEOF (Buffer), CHAR(I)); + Write ('BlockWrite'); + BlockWrite (F,Buffer,SIZEOF(Buffer)); + ErrorCheck ('BlockWrite',TestFN); + END; + Write ('Seek'); + Seek (F,0); + ErrorCheck ('Seek',TestFN); + FOR I := 1 TO NumBlocks DO + BEGIN + Write ('BlockRead'); + BlockRead (F,Buffer,SIZEOF(Buffer)); + ErrorCheck ('BlockRead',TestFN); + FOR J := LOW (Buffer) TO HIGH (Buffer) DO + IF Buffer[J] <> I THEN + BEGIN + WriteLn ('Verify-Error'); + HALT; + END; + END; + Write ('Close'); + Close (F); + ErrorCheck ('Close',TestFN); + Write ('Erase'); + Erase (F); + ErrorCheck ('Erase',TestFN); +END; + +PROCEDURE TextFileTest; +CONST NumLines = 100; + FN = 'SYS:TEST/TEST.TXT'; +VAR I : LONGINT; + S,S1 : STRING; + T : TEXT; +BEGIN + Assign (T,FN); + ReWrite (T); + ErrorCheck ('ReWrite',FN); + FOR I := 1 TO NumLines DO + BEGIN + Str (I, S); + Write ('WriteLn'); + WriteLn (T, S); + ErrorCheck ('WriteLn',FN); + END; + Write ('Close'); Close (T); ErrorCheck ('Close',FN); + Assign (T,FN); + Reset (T); + ErrorCheck ('Reset',FN); + FOR I := 1 TO NumLines DO + BEGIN + Str (I, S1); + Write ('ReadLn'); + ReadLn (T, S); + ErrorCheck ('ReadLn',FN); + IF (S <> S1) THEN + BEGIN + WriteLn ('Verify-Error "',S,'" <> "',S1,'"'); + HALT; + END; + END; + Write ('Close'); Close (T); ErrorCheck ('Close',FN); + Write ('Erase'); Erase (T); ErrorCheck ('Erase',FN); +END; + + +PROCEDURE MemTest; +CONST NumBlocks = 1000; + BlockSize = 1024; +VAR I : LONGINT; + P : ARRAY [0..NumBlocks-1] OF POINTER; +BEGIN + Write ('GetMem/FreeMem Test'); + FillChar (P, SIZEOF(P), 0); + FOR I := 0 TO NumBlocks-1 DO + BEGIN + Write ('g'); + GetMem (P[I],BlockSize); + FillChar (P[I]^,BlockSize,$FF); + END; + FOR I := 0 TO NumBlocks-1 DO + BEGIN + Write ('f'); + FreeMem (P[I],BlockSize); + END; + WriteLn (' Ok'); +END; + +PROCEDURE DosTest; +VAR Year, Month, Day, DayVal, hour, Minute, Second, Sec100 : WORD; +BEGIN + GetDate (Year,Month, Day, DayVal); + WriteLn ('GetDate: ',Year,'/',Month,'/',Day); + GetTime (hour, Minute, Second, Sec100); + WriteLn ('GetTime: ',Hour,':',Minute,':',Second,':',Sec100); +END; + +PROCEDURE ExceptTest; +BEGIN + TRY + WriteLn ('Raising Exception'); + Raise (Exception.Create ('')); + EXCEPT + WriteLn ('Fine, Except-Handler called'); + END; +END; + +{PROCEDURE ReadDirTest; +VAR EntryH, DirH : PNWDirEnt; + T : DateTime; +BEGIN + DirH := _opendir ('SYS:TEST/*.*'); + IF DirH <> NIL THEN + BEGIN + EntryH := _readdir (DirH); + WHILE (EntryH <> NIL) DO + BEGIN + unpacktime (EntryH^.d_time + (LONGINT (EntryH^.d_date) SHL 16),T); + WriteLn ('Name: "', EntryH^.d_nameDOS,'" size:',EntryH^.d_size,' namespace-name: "',EntryH^.d_name,'" ',T.Day,'.',T.Month,'.',T.Year,' ',T.Hour,':',T.Min,':',T.Sec); + EntryH := _readdir (DirH); + END; + _closedir (DirH); + END ELSE + WriteLn ('opendir failed'); +END;} + + +PROCEDURE FindTest; +VAR f : Dos.SearchRec; + t : Dos.DateTime; + s : string [5]; + fh: FILE; + time: LONGINT; + attr: word; +BEGIN + Dos.FindFirst ('SYS:TEST\*.*',anyfile,f); + WHILE Dos.DosError = 0 DO + BEGIN + unpacktime (f.time,t); + IF f.attr AND directory <> 0 THEN + S := '' + ELSE + S := ''; + WriteLn (f.Name:15,f.attr:6,S:6,f.size:6,' ',t.Month:2,'/',t.day:2,'/',t.year,' ',t.hour:2,':',t.min:2,':',t.sec:2); + Dos.FindNext (f); + END; + Dos.FindClose (f); + {WriteLn ('Directories:'); + Dos.FindFirst ('SYS:SYSTEM\*.*',directory,f); + WHILE Dos.DosError = 0 DO + BEGIN + WriteLn (f.Name:15); + Dos.FindNext (f); + END; + Dos.FindClose (f);} + WriteLn; + Assign (FH,ParamStr(0)); + Reset (FH,1); + ErrorCheck ('Reset',ParamStr(0)); + Getftime (FH, time); + Getfattr (FH, attr); + Close (FH); + unpacktime (time,t); + WriteLn (ParamStr(0),attr:6,' ',t.Month:2,'/',t.day:2,'/',t.year,' ',t.hour:2,':',t.min:2,':',t.sec:2); + WriteLn ('GetEnv (XX): "',GetEnv ('XX'),'"'); +END; + +{PROCEDURE VolInfo; +VAR I : LONGINT; + Buf: ARRAY [0..255] OF CHAR; + TotalBlocks : WORD; + SectorsPerBlock : WORD; + availableBlocks : WORD; + totalDirectorySlots : WORD; + availableDirSlots : WORD; + volumeisRemovable : WORD; + Err : LONGINT; +BEGIN + WriteLn ('Number of Volumes: ',_GetNumberOfVolumes); + FOR I := 0 TO _GetNumberOfVolumes-1 DO + BEGIN + _GetVolumeName (I,@Buf); + WriteLn (I,': "',Buf,'"'); + Err := _GetVolumeInfoWithNumber (I,@Buf, + TotalBlocks, + SectorsPerBlock, + availableBlocks, + totalDirectorySlots, + availableDirSlots, + volumeisRemovable); + IF Err = 0 THEN + BEGIN + WriteLn ('TotalBlocks: ',TotalBlocks,' Sectors/Block: ',SectorsPerBlock,' avail: ',availableBlocks); + END ELSE + WriteLn ('Err: ',Err); + END; + FOR I := 0 TO 5 DO + BEGIN + WriteLn ('DiskFree(',I,'): ',Dos.DiskFree(I)); + WriteLn ('DiskSize(',I,'): ',Dos.DiskSize(I)); + END; + +END;} + +PROCEDURE CrtTest; +VAR C : CHAR; + I : INTEGER; + + PROCEDURE KeyTest; + VAR C : CHAR; + BEGIN + WriteLn ('Key-Test, CR will be converted to ausgegeben, End with ESC'); + Repeat + C := ReadKey; + CASE C OF + #0 : Write ('#0'); + #13: Write (#13#10) + ELSE Write (C); + END; + Until C = #27; + END; + + PROCEDURE FillScreen; + VAR I : INTEGER; + BEGIN + ClrScr; + TextColor (Green); + FOR I := 1 TO 24 DO + Write ('12345678901234567890123456789012345678901234567890123456789012345678901234567890'); + TextColor (Yellow); + FOR I := 1 TO 25 DO + BEGIN + GotoXY (76,I); Write (' ',I,' '); + END; + TextColor (LightGray); + END; + +BEGIN + {GotoXY (1,1); writeln ('Text @ 1,1'); + GotoXY (2,2); writeln ('Text @ 2,2'); + GotoXY (3,3); writeln ('Text @ 3,3'); + GotoXY (4,4); writeln ('Text @ 4,4, Delay 5 Secs'); + GotoXY (1,1); + IF WhereX <> 1 THEN + BEGIN + GotoXY (1,10); Write ('WhereX - ERROR'); + END; + GotoXY (1,1); + IF WhereY <> 1 THEN + BEGIN + GotoXY (1,11); Write ('WhereY - ERROR'); + END; + + Delay (1000); + } + ClrScr; + + WriteLn ('Empty Screen '); + Delay (1000); + WriteLn ('Cursoroff '); CursorOff; + Delay (1000); + WriteLn ('Cursorbig '); CursorBig; + Delay (1000); + WriteLn ('Cursoron '); CursorOn; + LowVideo; Write ('Low '); HighVideo; Write ('High '); LowVideo; Write ('Low '); + Delay (1000); + KeyTest; + FillScreen; + Window (10,10,40,15); + ClrScr; Write ('Window 10,10,20,15'); + KeyTest; + Window (1,1,80,25); + FillScreen; + GotoXY (10,10); ClrEol; + GotoXY (1,21); Write (' ClrEol @ 10,10 '); + ReadKey; + FillScreen; + GotoXY (10,10); InsLine; + GotoXY (1,21); Write (' Insline @ 10,10 '); + ReadKey; + Write ('Waiting for keypress: '); + WHILE NOT Keypressed DO + BEGIN + Delay (500); + END; + Write ('OK'); ReadKey; + FOR I := 1 TO 5 DO + BEGIN + Write (^G); Delay (200); + END; + + + Delay (1000); + GotoXY (1,25); ClrEol; +END; + +{ +Function FileSetDate (Handle,Age : Longint) : Longint; +Function FileSetAttr (Const Filename : String; Attr: longint) : Longint; +} +PROCEDURE SysUtilsTest; +VAR H,I,Attr : LONGINT; + X : ARRAY [0..255] OF CHAR; + TD: TDateTime; + SR: TSearchRec; + ST1,ST2: STRING; +BEGIN + WriteLn ('FileExists SYS:SYSTEM/CLIB.NLM: ',FileExists ('SYS:SYSTEM/CLIB.NLM')); + WriteLn ('FileExists SYS:SYSTEM\CLIB.NLM: ',FileExists ('SYS:SYSTEM\CLIB.NLM')); + WriteLn ('FileExists SYS:SYSTEM/CLIB.N: ',FileExists ('SYS:SYSTEM/CLIB.N')); + WriteLn ('FileExists SYS:SYSTEM\CLIB.N: ',FileExists ('SYS:SYSTEM\CLIB.N')); + WriteLn ('FileExists SYS:SYSTEM: ',FileExists ('SYS:SYSTEM\CLIB.N')); + + H := FileOpen ('SYS:TEST/Autoexec.ncf',0); + IF H >= 0 THEN + BEGIN + I := FileRead (H, X, 20); X[20] := #0; + WriteLn ('FileRead returned ',I,' Buffer: "',X,'"'); + END ELSE + WriteLn ('FileOpen failed'); + FileClose (H); + + H := FileAge ('SYS:SYSTEM/CLIB.NLM'); + TD := FileDateToDateTime (H); + WriteLn ('CLIBs file date: ',DateTimeToStr (TD)); + H := FileAge ('SYS:SYSTEM/DSREPAIR.LOG'); + TD := FileDateToDateTime (H); + WriteLn ('DSREPAIR.LOGs file date: ',DateTimeToStr (TD)); + H := SysUtils.FindFirst ('SYS:SYSTEM/CLIB.nlm',faAnyFile,SR); + IF H = 0 THEN + BEGIN + WriteLn (SR.Name:20,SR.Size:6,' ',DateTimeToStr (FileDateToDateTime (SR.time)):20,' ',hexstr (SR.attr,8)); + END ELSE WriteLn ('FindFirst failed'); + FindClose (SR); + + H := SysUtils.FindFirst ('SYS:SYSTEM/CLIB.N',faAnyFile,SR); + IF H = 0 THEN + WriteLn ('FindFirst on non existing file returned 0 !'); + FindClose (SR); + + H := SysUtils.FindFirst ('SYS:SYSTEM/DSREPAIR.LOG',faAnyFile,SR); + IF H = 0 THEN + BEGIN + WriteLn (SR.Name:20,SR.Size:6,' ',DateTimeToStr (FileDateToDateTime (SR.time)):20,' ',hexstr (SR.attr,8)); + END ELSE WriteLn ('FindFirst failed'); + FindClose (SR); + + H := FileOpen ('SYS:SYSTEM/DSRepair.log',0); + IF H >= 0 THEN + BEGIN + I := FileGetDate (H); + FileClose (H); + TD := FileDateToDateTime (I); + WriteLn ('DSREPAIR.LOGs file date via FileGetDate: ',DateTimeToStr (TD)); + END ELSE WriteLn ('FileOpen failed'); + Attr := FileGetAttr ('SYS:SYSTEM/CLIB.NLM'); + WriteLn ('Attr of clib: ',hexstr (Attr,8)); + + chdir ('sys:test'); + H := FileCreate ('TEST12.DAT'); + IF H >= 0 THEN + BEGIN + IF NOT FileExists ('SYS:TEST/TEST12.DAT') THEN + WriteLn ('FileCreate returned ok but FileExists returned false !'); + FillChar (X,SIZEOF(X),BYTE('X')); + I := FileWrite (H,X,SIZEOF(X)); + WriteLn ('FileWrite returned ',I); + IF I = SIZEOF (X) THEN + BEGIN + IF NOT FileTruncate (H,SIZEOF(X) DIV 2) THEN + WriteLn ('FileTruncate failed'); + END; + FileClose (H); + + I := SysUtils.FindFirst ('TEST12.DAT',faAnyFile,SR); + IF I <> 0 THEN + WriteLn ('FindFirst failed') + ELSE + IF SR.Size <> (SIZEOF (X) DIV 2) THEN + WriteLn ('FileTruncate: wrong FileSize after truncate (',SR.Size,')'); + FindClose (SR); + + IF NOT RenameFile ('TEST12.DAT','TEST12.BAK') THEN + WriteLn ('RenameFile failed') + ELSE + BEGIN + IF NOT FileExists ('SYS:TEST/TEST12.BAK') THEN + WriteLn ('FileRename returned ok but FileExists returned false'); + IF NOT DeleteFile ('TEST12.BAK') THEN + WriteLn ('DeleteFile failed') + ELSE + IF FileExists ('SYS:TEST/TEST12.BAK') THEN + WriteLn ('DeleteFile returned ok but FileExists returned true'); + END; + + END ELSE WriteLn ('FileCreate failed'); + + H := FileCreate ('TEST12.DAT'); + IF H >= 0 THEN + BEGIN + FillChar (X,SIZEOF(X),BYTE('X')); + FileWrite (H,X,SIZEOF(X)); + I := FileSeek (H,10,fsFromBeginning); + X[0] := '0'; + FileWrite (H,X,1); + IF I <> 10 THEN WriteLn ('FileSeek returned wrong result at 10 (',I,')'); + I := FileSeek (H,10,fsFromCurrent); + X[0] := '1'; + FileWrite (H,X,1); + IF I <> 21 THEN WriteLn ('FileSeek returned wrong result at 21 (',I,')'); + I := FileSeek (H,-10,fsFromEnd); + X[0] := '2'; + FileWrite (H,X,1); + IF I <> SIZEOF(X)-10 THEN WriteLn ('FileSeek returned wrong result at End-10 (',I,')'); + FileClose (H); + END ELSE WriteLn ('FileCreate failed'); + + ST1 := 'SYS:ETC;SYS:TEST;SYS:SYSTEM/;SYS:PUBLIC'; + ST2 := FileSearch ('clib.nlm',ST1); + WriteLn ('FileSearch (clib.nlm,',ST1,') returned "',ST2,'"'); + WriteLn ('FExpand (TEST12.DAT): "',FExpand ('TEST12.DAT')); + WriteLn ('FExpand (.\TEST12.DAT): "',FExpand ('.\TEST12.DAT')); + WriteLn ('FExpand (..\SYSTEM\CLIB.NLM): "',FExpand ('..\SYSTEM\CLIB.NLM')); + +END; + + +PROCEDURE VideoTest; + + PROCEDURE WriteString (S : STRING; X,Y : WORD; Fore,Back: BYTE); + VAR I : INTEGER; + W : WORD; + P : POINTER; + Textattr : WORD; + BEGIN + W := X + (Y * Video.ScreenWidth); + P := Pointer (@VideoBuf^[W]); + TextAttr := (Fore and $f) or (Back shl 4); + FOR I := 1 TO Length (S) DO + BEGIN + W := (TextAttr SHL 8) or byte (S[I]); + PWord(P)^ := w; + INC (PChar(P),2); + END; + END; + +BEGIN + InitVideo; + Video.ClearScreen; + WriteString ('Test @ 0,0, LightGray on Black',0,0,LightGray,Black); + UpdateScreen (false); + WriteString ('Test @ 10,1, Yellow on Blue',1,1,Yellow,Blue); + UpdateScreen (false); + ReadKey; + Video.ClearScreen; + WriteString ('Cursor crHidden',0,0,Yellow,Blue); + SetCursorPos (0,0); + SetCursorType (crHidden); + UpdateScreen (false); + ReadKey; + + Video.ClearScreen; + WriteString ('Cursor crUnderLine',0,0,Yellow,Blue); + SetCursorPos (0,0); + SetCursorType (crUnderLine); + UpdateScreen (false); + ReadKey; + + Video.ClearScreen; + WriteString ('Cursor crBlock',0,0,Yellow,Blue); + SetCursorPos (0,0); + SetCursorType (crBlock); + UpdateScreen (false); + ReadKey; + + Video.ClearScreen; + WriteString ('Cursor crHalfBlock',0,0,Yellow,Blue); + SetCursorPos (0,0); + SetCursorType (crHalfBlock); + UpdateScreen (false); + ReadKey; + + CRT.ClrScr; + SetCursorType (crUnderLine); +END; + +PROCEDURE KeyboardTest; +VAR T : TKeyEvent; +BEGIN + InitKeyboard; + WriteLn ('Keyboard-Test, ESC Ends'); + REPEAT + T := GetKeyEvent; + WriteLn (' Event: ',HexStr (T,8),' EventChar: "',GetKeyEventChar(T),'" KeyEventCode: ',HexStr (GetKeyEventCode(T),8)); + T := TranslateKeyEvent (T); + WriteLn ('Translated Event: ',HexStr (T,8),' EventChar: "',GetKeyEventChar(T),'" KeyEventCode: ',HexStr (GetKeyEventCode(T),8)); + WriteLn; + UNTIL GetKeyEventChar (T) = #27; +END; + + +VAR I : LONGINT; + S : STRING [255]; + C : CHAR; + P : ^Str255; +BEGIN + New (P); + Dispose (P); + // WriteLn ('Test'); + //__ConsolePrintf ('Ok, this is PASCALMAIN'#13#10,0); + WriteLn ('Test via WriteLn'); + WriteLn ('No of params: ', ParamCount); + //__EnterDebugger; + WriteLn ('ParamStr(0): "', ParamStr(0),'"'); + IF ParamCount > 0 THEN + FOR I := 1 TO ParamCount DO + WriteLn (I:6,': "',ParamStr(I),'"'); + GetDir (0, S); + WriteLn ('Current Directory: "',S,'"'); +// ChDir ('TEST'); +// GetDir (0, S); +// WriteLn ('Current Directory: "',S,'"'); +// MkDir ('SYS:TEST'); +// IF IOResult <> 0 THEN WriteLn ('MkDir SYS:TEST failed (Ok)'); +// Write ('MkDir'); MkDir ('SYS:TEST/TESTDIR'); +// ErrorCheck ('MkDir','SYS:TEST/TESTDIR'); +// Write ('RmDir'); RmDir ('SYS:TEST/TESTDIR'); +// ErrorCheck ('RmDir','SYS:TEST/TESTDIR'); + + REPEAT + WriteLn; + WriteLn ('1 : File-Test'); + WriteLn ('2 : Textfile-Test'); + WriteLn ('3 : GetMem/FreeMem Test'); + WriteLn ('4 : DosTest'); + WriteLn ('5 : ExceptTest'); + WriteLn ('6 : Video-Test'); + WriteLn ('7 : Find-Test'); + WriteLn ('8 : SysUtils-Test'); + WriteLn ('9 : CrtTest'); + WriteLn ('K : Keyboard-Test'); + WriteLn ('E : Ende'); + WriteLn; + Write ('?: '); + C := Crt.ReadKey; + WriteLn (C); + CASE upcase(C) OF + '1' : FileTest; + '2' : TextfileTest; + '3' : MemTest; + '4' : DosTest; + '5' : ExceptTest; + '6' : VideoTest; + '7' : FindTest; + '8' : SysUtilsTest; + '9' : CrtTest; + 'K' : KeyboardTest; + END; + UNTIL UpCase (C) = 'E'; + (*$IFDEF Netware*) + PressAnyKeyToContinue; + (*$ENDIF*) +END. diff --git a/rtl/netware/varutils.pp b/rtl/netware/varutils.pp new file mode 100644 index 0000000000..c59bc89608 --- /dev/null +++ b/rtl/netware/varutils.pp @@ -0,0 +1,53 @@ +{ + $Id$ + This file is part of the Free Pascal run time library. + Copyright (c) 1999-2000 by the Free Pascal development team + + Interface and OS-dependent part of variant support + + 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. + + **********************************************************************} + +{$MODE ObjFPC} + +Unit varutils; + +Interface + +Uses sysutils; + +// Read definitions. + +{$i varutilh.inc} + +Implementation + +// Code common to all platforms. + +{$i cvarutil.inc} + +// Code common to non-win32 platforms. + +{$i varutils.inc} + +end. + +{ + $Log$ + Revision 1.1 2001-04-16 18:39:50 florian + * updates from Armin commited + + Revision 1.1 2000/08/29 18:21:58 michael + + new include files + + Revision 1.1 2000/08/29 18:20:13 michael + + new include files + +} + diff --git a/rtl/netware/video.pp b/rtl/netware/video.pp new file mode 100644 index 0000000000..b0c1aa83b5 --- /dev/null +++ b/rtl/netware/video.pp @@ -0,0 +1,185 @@ +{ + $Id$ + This file is part of the Free Pascal run time library. + Copyright (c) 1999-2000 by Florian Klaempfl + member of the Free Pascal development team + + Video unit for netware + + See the file COPYING.FPC, included in this distribution, + for details about the copyright. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + + **********************************************************************} +{ 2001/04/16 armin: first version for netware } +unit Video; +interface + +{$i videoh.inc} + +implementation + +uses + dos; + +{$i video.inc} +{$i nwsys.inc} + +var + OldVideoBuf : PVideoBuf; + MaxVideoBufSize : DWord; + VideoBufAllocated: boolean; + + +procedure InitVideo; +VAR height,width : WORD; + startline, endline : BYTE; +begin + DoneVideo; + ScreenColor:= (_IsColorMonitor <> 0); + _GetSizeOfScreen (height, width); + ScreenWidth := width; + ScreenHeight:= height; + + { TDrawBuffer only has FVMaxWidth elements + larger values lead to crashes } + if ScreenWidth> FVMaxWidth then + ScreenWidth:=FVMaxWidth; + + CursorX := _wherex; + CursorY := _wherey; + _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} + _CopyFromScreenMemory (ScreenHeight, ScreenWidth, VideoBuf, 0, 0); + Move (VideoBuf^, OldVideoBuf^, MaxVideoBufSize); + LockUpdateScreen := 0; + + {ClearScreen; not needed PM } +end; + + +procedure DoneVideo; +begin + { ClearScreen; also not needed PM } + SetCursorType(crUnderLine); + { SetCursorPos(0,0); also not needed PM } + if videoBufAllocated then + begin + FreeMem(VideoBuf,MaxVideoBufSize); + FreeMem(OldVideoBuf,MaxVideoBufSize); + videoBufAllocated := false; + end; + VideoBufSize:=0; +end; + + +function GetCapabilities: Word; +begin + GetCapabilities:=cpColor or cpChangeCursor; +end; + + +procedure SetCursorPos(NewCursorX, NewCursorY: Word); +begin + _GotoXY (NewCursorX, NewCursorY); +end; + + +function GetCursorType: Word; +var startline, endline : byte; +begin + _GetCursorShape (startline, endline); + CASE startline of + 1 : GetCursorType := crBlock; + 5 : GetCursorType := crHalfBlock + ELSE + GetCursorType := crUnderline; + END; + {crHidden ?} +end; + + +procedure SetCursorType(NewType: Word); +begin + if newType=crHidden then + _HideInputCursor + else + begin + case NewType of + crUnderline: + _SetCursorShape (9,$A); + crHalfBlock: + _SetCursorShape (5,$A); + crBlock: + _SetCursorShape (1,$A); + end; + _DisplayInputCursor; + end; +end; + + +function DefaultVideoModeSelector(const VideoMode: TVideoMode; Params: Longint): Boolean; +begin + DefaultVideoModeSelector:=true; +end; + + +procedure ClearScreen; +begin + FillWord(VideoBuf^,VideoBufSize div 2,$0720); + UpdateScreen(true); +end; + + +procedure UpdateScreen(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 + _CopyToScreenMemory (ScreenHeight, ScreenWidth, VideoBuf, 0, 0); +end; + +procedure RegisterVideoModes; +begin + { don't know what to do for netware } + RegisterVideoMode(80, 25, True, @DefaultVideoModeSelector, $00000003); +end; + + +initialization + VideoBufAllocated := false; + VideoBufSize := 0; + RegisterVideoModes; + +finalization + UnRegisterVideoModes; +end. + diff --git a/rtl/objpas/filutilh.inc b/rtl/objpas/filutilh.inc index f44e3d6703..ac44136a0d 100644 --- a/rtl/objpas/filutilh.inc +++ b/rtl/objpas/filutilh.inc @@ -23,10 +23,13 @@ Type Name : TFileName; ExcludeAttr : Longint; FindHandle : THandle; - {$ifdef Win32} - FindData : TWin32FindData; - {$endif} - end; +{$ifdef Win32} + FindData : TWin32FindData; +{$endif} +{$ifdef netware} + FindData : TNetwareFindData; +{$endif} + end; Const { File attributes } @@ -77,7 +80,10 @@ Function FileSearch (Const Name, DirList : String) : String; { $Log$ - Revision 1.3 2001-01-18 22:09:09 michael + Revision 1.4 2001-04-16 18:34:46 florian + * updates from Armin commited + + Revision 1.3 2001/01/18 22:09:09 michael + Merged fixes from fixbranch - file modes Revision 1.2 2000/07/13 11:33:51 michael