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

* updates from Armin commited

Browse Source
This commit is contained in:
florian 2001-04-16 18:33:14 +00:00
parent 73a59b9ca3
commit a33a06ce5d
20 changed files with 3115 additions and 209 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
rtl/inc/objects.pp
View File

@ -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

71
rtl/netware/Makefile Normal file
View File

@ -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

181
rtl/netware/README Normal file
View File

@ -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

723
rtl/netware/crt.pp Normal file
View File

@ -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<WinMaxX then
begin
rowlen := WinMaxX-x+1;
GetMem (p, rowlen * 2);
FillWord (p^, rowlen, fil);
_CopyToScreenMemory (1,rowlen,p,x-1,y-1);
FreeMem (p, rowlen * 2);
end;
End;
Function WhereX: Byte;
{
Return current X-position of cursor.
}
var
x,y : longint;
Begin
GetScreenCursor(x,y);
WhereX:=x-WinMinX+1;
End;
Function WhereY: Byte;
{
Return current Y-position of cursor.
}
var
x,y : longint;
Begin
GetScreenCursor(x,y);
WhereY:=y-WinMinY+1;
End;
{*************************************************************************
Keyboard
*************************************************************************}
var
is_last : boolean;
function readkey : char;
var
char1 : char;
begin
if is_last then
begin
is_last:=false;
readkey:=_getch;
end else
begin
_SetCtrlCharCheckMode (CheckBreak);
char1 := _getch;
if char1 = #0 then is_last := true;
readkey:=char1;
end;
end;
function keypressed : boolean;
begin
if is_last then
begin
keypressed:=true;
exit;
end else
keypressed := (_kbhit <> 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.bufpos<f.bufend then
begin
WriteChar(f.bufptr^[f.bufpos]);
inc(f.bufpos);
end;
#79 : while f.bufpos<f.bufend do
begin
WriteChar(f.bufptr^[f.bufpos]);
inc(f.bufpos);
end;
end;
^S,
#8 : BackSpace;
^Y,
#27 : begin
f.bufpos:=f.bufend;
while f.bufend>0 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.bufpos<f.bufsize-2 then
begin
f.buffer[f.bufpos]:=ch;
inc(f.bufpos);
WriteChar(ch);
end;
end;
end;
until false;
f.bufpos:=0;
_GotoXY (CurrX-1,CurrY-1);
CrtRead:=0;
End;
Function CrtReturn(Var F: TextRec): Integer;
Begin
CrtReturn:=0;
end;
Function CrtClose(Var F: TextRec): Integer;
Begin
F.Mode:=fmClosed;
CrtClose:=0;
End;
Function CrtOpen(Var F: TextRec): Integer;
Begin
If F.Mode=fmOutput Then
begin
TextRec(F).InOutFunc:=@CrtWrite;
TextRec(F).FlushFunc:=@CrtWrite;
end
Else
begin
F.Mode:=fmInput;
TextRec(F).InOutFunc:=@CrtRead;
TextRec(F).FlushFunc:=@CrtReturn;
end;
TextRec(F).CloseFunc:=@CrtClose;
CrtOpen:=0;
End;
procedure AssignCrt(var F: Text);
begin
Assign(F,'');
TextRec(F).OpenFunc:=@CrtOpen;
end;
var
x,y : longint;
begin
{ Load startup values }
ScreenWidth:=GetScreenWidth;
ScreenHeight:=GetScreenHeight;
lastmode := CO80;
TextMode (lastmode);
GetScreenCursor(x,y);
if screenheight>25 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.

31
rtl/netware/dos.pp
View File

@ -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

134
rtl/netware/keyboard.pp Normal file
View File

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

117
rtl/netware/mouse.pp Normal file
View File

@ -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
}

176
rtl/netware/netware.pp Normal file
View File

@ -0,0 +1,176 @@
{
$Id$
<partof>
Copyright (c) 1998 by <yourname>
<infoline>
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
}

70
rtl/netware/nwpre.pp
View File

@ -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

213
rtl/netware/nwsock.inc Normal file
View File

@ -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;

134
rtl/netware/nwsys.inc
View File

@ -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

87
rtl/netware/objinc.inc Normal file
View File

@ -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;

178
rtl/netware/sockets.pp Normal file
View File

@ -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
}

20
rtl/netware/system.pp
View File

@ -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

284
rtl/netware/sysutils.pp
View File

@ -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

33
rtl/netware/tests/Makefile Normal file
View File

@ -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

604
rtl/netware/tests/test.pas Normal file
View File

@ -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 := '<DIR>'
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.

53
rtl/netware/varutils.pp Normal file
View File

@ -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
}

185
rtl/netware/video.pp Normal file
View File

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

16
rtl/objpas/filutilh.inc
View File

@ -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