eric
/
Renegade-1.19
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Reorganized and got BP compiling

This commit is contained in:
Rick Parrish 2013-02-05 10:02:07 -05:00
parent 6923bf0c27
commit 24b63b3b6a
390 changed files with 8369 additions and 185 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
.gitattributes vendored
View File

@ -1,22 +0,0 @@
# Auto detect text files and perform LF normalization
* text=auto
# Custom for Visual Studio
*.cs diff=csharp
*.sln merge=union
*.csproj merge=union
*.vbproj merge=union
*.fsproj merge=union
*.dbproj merge=union
# Standard to msysgit
*.doc diff=astextplain
*.DOC diff=astextplain
*.docx diff=astextplain
*.DOCX diff=astextplain
*.dot diff=astextplain
*.DOT diff=astextplain
*.pdf diff=astextplain
*.PDF diff=astextplain
*.rtf diff=astextplain
*.RTF diff=astextplain

165
.gitignore vendored
View File

@ -1,163 +1,2 @@
#################
## Eclipse
#################
*.pydevproject
.project
.metadata
bin/
tmp/
*.tmp
*.bak
*.swp
*~.nib
local.properties
.classpath
.settings/
.loadpath
# External tool builders
.externalToolBuilders/
# Locally stored "Eclipse launch configurations"
*.launch
# CDT-specific
.cproject
# PDT-specific
.buildpath
#################
## Visual Studio
#################
## Ignore Visual Studio temporary files, build results, and
## files generated by popular Visual Studio add-ons.
# User-specific files
*.suo
*.user
*.sln.docstates
# Build results
[Dd]ebug/
[Rr]elease/
*_i.c
*_p.c
*.ilk
*.meta
*.obj
*.pch
*.pdb
*.pgc
*.pgd
*.rsp
*.sbr
*.tlb
*.tli
*.tlh
*.tmp
*.vspscc
.builds
*.dotCover
## TODO: If you have NuGet Package Restore enabled, uncomment this
#packages/
# Visual C++ cache files
ipch/
*.aps
*.ncb
*.opensdf
*.sdf
# Visual Studio profiler
*.psess
*.vsp
# ReSharper is a .NET coding add-in
_ReSharper*
# Installshield output folder
[Ee]xpress
# DocProject is a documentation generator add-in
DocProject/buildhelp/
DocProject/Help/*.HxT
DocProject/Help/*.HxC
DocProject/Help/*.hhc
DocProject/Help/*.hhk
DocProject/Help/*.hhp
DocProject/Help/Html2
DocProject/Help/html
# Click-Once directory
publish
# Others
[Bb]in
[Oo]bj
sql
TestResults
*.Cache
ClientBin
stylecop.*
~$*
*.dbmdl
Generated_Code #added for RIA/Silverlight projects
# Backup & report files from converting an old project file to a newer
# Visual Studio version. Backup files are not needed, because we have git ;-)
_UpgradeReport_Files/
Backup*/
UpgradeLog*.XML
############
## Windows
############
# Windows image file caches
Thumbs.db
# Folder config file
Desktop.ini
#############
## Python
#############
*.py[co]
# Packages
*.egg
*.egg-info
dist
build
eggs
parts
bin
var
sdist
develop-eggs
.installed.cfg
# Installer logs
pip-log.txt
# Unit test / coverage reports
.coverage
.tox
#Translations
*.mo
#Mr Developer
.mr.developer.cfg
# Mac crap
.DS_Store
EXE/
ORIGINAL ARCHIVES/

27
BPC.CFG Normal file
View File

@ -0,0 +1,27 @@
/EZ:\PROGRA~1\RG119SRC\EXE\BP
/IZ:\BP\UNITS;
/OZ:\BP\UNITS;
/UZ:\BP\UNITS;
/R
/$MD64000,0,655360
/$MP64000
/$A+
/$B-
/$D+
/$E+
/$F+
/$G+
/$I-
/$L+
/$N-
/$O+
/$P-
/$Q-
/$R-
/$S-
/$T-
/$V-
/$X+
/$Y+
/B
/GD

63
BUILDBP.CMD Normal file
View File

@ -0,0 +1,63 @@
@ECHO OFF
Z:
ECHO CLEAING UP OUTPUT DIRECTORY
DEL /Q Z:\PROGRAMMING\RG119SRC\EXE\BP\*.*
ECHO COPYING BPC.CFG TO BP DIRECTORY
COPY Z:\PROGRAMMING\RG119SRC\BPC.CFG Z:\BP\BIN
CD Z:\PROGRAMMING\RG119SRC\SOURCE
ECHO.
ECHO COMPILING RENEGADE.EXE
Z:\BP\BIN\BPC.EXE RENEGADE.PAS
IF NOT %ERRORLEVEL% == 0 GOTO END
ECHO.
ECHO COMPILING RENEMAIL.EXE
Z:\BP\BIN\BPC.EXE RENEMAIL.PAS
IF NOT %ERRORLEVEL% == 0 GOTO END
ECHO.
ECHO COMPILING RGLNG.EXE
Z:\BP\BIN\BPC.EXE RGLNG.PAS
IF NOT %ERRORLEVEL% == 0 GOTO END
ECHO.
ECHO COMPILING RGMAIN.EXE
Z:\BP\BIN\BPC.EXE RGMAIN.PAS
IF NOT %ERRORLEVEL% == 0 GOTO END
ECHO.
ECHO COMPILING RGNOTE.EXE
Z:\BP\BIN\BPC.EXE RGNOTE.PAS
IF NOT %ERRORLEVEL% == 0 GOTO END
ECHO.
ECHO COMPILING RGQUOTE.EXE
Z:\BP\BIN\BPC.EXE RGQUOTE.PAS
IF NOT %ERRORLEVEL% == 0 GOTO END
ECHO.
ECHO COMPILING RGSCFG.EXE
Z:\BP\BIN\BPC.EXE RGSCFG.PAS
IF NOT %ERRORLEVEL% == 0 GOTO END
ECHO.
ECHO COMPILING TAGLINE.EXE
Z:\BP\BIN\BPC.EXE TAGLINE.PAS
IF NOT %ERRORLEVEL% == 0 GOTO END
:COPY
ECHO.
ECHO BUILD COMPLETE! HIT A KEY TO COPY EXE FILES OR CTRL-C TO SKIP
PAUSE
CD Z:\PROGRAMMING\RG119SRC
CALL COPYEXEBP
GOTO END
:END
PAUSE

63
BUILDVP.CMD Normal file
View File

@ -0,0 +1,63 @@
@ECHO OFF
Z:
ECHO CLEAING UP OUTPUT DIRECTORY
DEL /Q Z:\PROGRAMMING\RG119SRC\EXE\VP\*.*
ECHO COPYING VPC.CFG TO VP21 DIRECTORY
COPY Z:\PROGRAMMING\RG119SRC\VPC.CFG Z:\VP21\BIN.W32
CD Z:\PROGRAMMING\RG119SRC\SOURCE
ECHO.
ECHO COMPILING RENEGADE.EXE
Z:\VP21\BIN.W32\VPC RENEGADE.PAS
IF NOT %ERRORLEVEL% == 0 GOTO END
ECHO.
ECHO COMPILING RENEMAIL.EXE
Z:\VP21\BIN.W32\VPC RENEMAIL.PAS
IF NOT %ERRORLEVEL% == 0 GOTO END
ECHO.
ECHO COMPILING RGLNG.EXE
Z:\VP21\BIN.W32\VPC RGLNG.PAS
IF NOT %ERRORLEVEL% == 0 GOTO END
ECHO.
ECHO COMPILING RGMAIN.EXE
Z:\VP21\BIN.W32\VPC RGMAIN.PAS
IF NOT %ERRORLEVEL% == 0 GOTO END
ECHO.
ECHO COMPILING RGNOTE.EXE
Z:\VP21\BIN.W32\VPC RGNOTE.PAS
IF NOT %ERRORLEVEL% == 0 GOTO END
ECHO.
ECHO COMPILING RGQUOTE.EXE
Z:\VP21\BIN.W32\VPC RGQUOTE.PAS
IF NOT %ERRORLEVEL% == 0 GOTO END
ECHO.
ECHO COMPILING RGSCFG.EXE
Z:\VP21\BIN.W32\VPC RGSCFG.PAS
IF NOT %ERRORLEVEL% == 0 GOTO END
ECHO.
ECHO COMPILING TAGLINE.EXE
Z:\VP21\BIN.W32\VPC TAGLINE.PAS
IF NOT %ERRORLEVEL% == 0 GOTO END
:COPY
ECHO.
ECHO BUILD COMPLETE! HIT A KEY TO COPY EXE FILES OR CTRL-C TO SKIP
PAUSE
CD Z:\PROGRAMMING\RG119SRC
CALL COPYEXEVP
GOTO END
:END
PAUSE

55
COMPILE.TXT Normal file
View File

@ -0,0 +1,55 @@
Step 0) Assumptions:
The first assumption is that you have Borland Pascal installed in Z:\BP.
If you don't, you'll have to update the BUILDBP.CMD file
The second assumption is that you have Virtual Pascal installed in Z:\vp21.
If you don't, you'll have to update the BUILDVP.CMD file
*NOTE* The BUILD*.CMD files will copy a BPC.CFG or VPC.CFG into the relevant bin directory, meaning
if you have cusomized the .CFG file in the bin directory, it will be lost. Make a backup!
Step 1) Create directories to hold everything:
Z:\RG119
Z:\Programming\RG119SRC
Z:\Programming\RG119SRC\EXE\BP
Z:\Programming\RG119SRC\EXE\VP
If you don't have a Z: drive, you can use SUBST or map a network drive to fake one
You can also put the files in an alternate location if you want, you'll just have to update the BUILD*.CMD scripts
Step 2) Get the source
Check out the GIT contents into Z:\Programming\RG119SRC
Step 3) Edit Z:\vp21\source\rtl\vpsysw32.pas
For some reason the cursor position isn't always updated in the background thread in the Win32 version. I'm guessing
it's a race condition with the CurXPos and CurYPos variables, so the thread doesn't think an update is needed when
one really is. So I've updated my copy of CursorThreadFunc to take the return value of the SemWaitEvent() call into
account, so the update will also happen if the event is signaled. Can't think of a reason why they wouldn't have done
this in the first place. Here's the entire function to copy/paste into place:
function CursorThreadFunc(P: Pointer): Longint;
var
LastX, LastY: Longint;
begin
LastX := -1;
LastY := -1;
repeat
if SemWaitEvent(semCursor, 300) or (CurXPos <> LastX) or (CurYPos <> LastY) then
begin
DoSetCursorPosition;
LastX := CurXPos;
LastY := CurYPos;
end;
until tidCursor = -2;
tidCursor := -1;
end;
Step 4) Build new EXEs
Run BUILDBP.CMD to build the DOS EXEs and have them copied to Z:\RG119
Run BUILDVP.CMD to build the WIN32 EXEs and have them copied to Z:\RG119

10
COPYEXEBP.CMD Normal file
View File

@ -0,0 +1,10 @@
@ECHO OFF
COPY Z:\PROGRAMMING\RG119SRC\EXE\BP\RENEGADE.EXE Z:\RG119\
COPY Z:\PROGRAMMING\RG119SRC\EXE\BP\RENEGADE.OVR Z:\RG119\
COPY Z:\PROGRAMMING\RG119SRC\EXE\BP\RENEMAIL.EXE Z:\RG119\
COPY Z:\PROGRAMMING\RG119SRC\EXE\BP\RGLNG.EXE Z:\RG119\DATA\
COPY Z:\PROGRAMMING\RG119SRC\EXE\BP\RGMAIN.EXE Z:\RG119\DATA\
COPY Z:\PROGRAMMING\RG119SRC\EXE\BP\RGNOTE.EXE Z:\RG119\DATA\
COPY Z:\PROGRAMMING\RG119SRC\EXE\BP\RGQUOTE.EXE Z:\RG119\DATA\
COPY Z:\PROGRAMMING\RG119SRC\EXE\BP\RGSCFG.EXE Z:\RG119\DATA\
COPY Z:\PROGRAMMING\RG119SRC\EXE\BP\TAGLINE.EXE Z:\RG119\DATA\

9
COPYEXEVP.CMD Normal file
View File

@ -0,0 +1,9 @@
@ECHO OFF
COPY Z:\PROGRAMMING\RG119SRC\EXE\VP\RENEGADE.EXE Z:\RG119\RENEGADE32.EXE
COPY Z:\PROGRAMMING\RG119SRC\EXE\VP\RENEMAIL.EXE Z:\RG119\RENEMAIL32.EXE
COPY Z:\PROGRAMMING\RG119SRC\EXE\VP\RGLNG.EXE Z:\RG119\DATA\RGLNG32.EXE
COPY Z:\PROGRAMMING\RG119SRC\EXE\VP\RGMAIN.EXE Z:\RG119\DATA\RGMAIN32.EXE
COPY Z:\PROGRAMMING\RG119SRC\EXE\VP\RGNOTE.EXE Z:\RG119\DATA\RGNOTE32.EXE
COPY Z:\PROGRAMMING\RG119SRC\EXE\VP\RGQUOTE.EXE Z:\RG119\DATA\RGQUOTE32.EXE
COPY Z:\PROGRAMMING\RG119SRC\EXE\VP\RGSCFG.EXE Z:\RG119\DATA\RGSCFG32.EXE
COPY Z:\PROGRAMMING\RG119SRC\EXE\VP\TAGLINE.EXE Z:\RG119\DATA\TAGLINE32.EXE

30
README.md Normal file
View File

@ -0,0 +1,30 @@
Renegade v1.19
==============
This is a port of the current version of Renegade: v1.19. My port of the older Y2Ka2 version can be found here: https://github.com/rickparrish/Renegade<br />
<br />
This is a fork of the official v1.19 release, which can be found here: https://github.com/Renegade-Exodus/RG119SRC<br />
==============================
Copyright Cott Lang, Patrick Spence, Gary Hall, Jeff Herrings, T.J. McMillen, Chris Hoppman, and Lee Palmer<br />
Ported to Win32 by Rick Parrish<br />
<hr />
TODO list:<br />
<ul>
<li>IFDEF out anything that doesn't compile and make a WIN32 placeholder that does a "WriteLn('REETODO UNIT FUNCTION'); Halt;" (then you can grep the executables for REETODO to see which REETODOs actually need to be implemented)</li>
<li>IFDEF out any ASM code blocks and handle the same as above</li>
<li>WORD in RECORD to SMALLWORD</li>
<li>INTEGER in RECORD to SMALLINT</li>
<li>TYPEs of OF WORD to OF SMALLWORD (just in case they're used in a RECORD)</li>
<li>TYPEs of OF INTEGER to OF SMALLINT (just in case they're used in a RECORD)</li>
<li>Implement any REETODOs that appear in compiled executables</li>
<li>Anything passing 0 for the Attr parameter to FindFirst should pass AnyFile instead (VP returns no files when 0 is passed for Attr)</li>
<li>Investigate FILEMODE usage to see if FILEMODEREADWRITE, TEXTMODEREAD or TEXTMODEREADWRITE should be used</li>
<li>Find/correct any usage of FOR loop variables after the loop (since they are 1 greater in VP than in BP</li>
</ul>
Completed list<br />
<ul>
</ul>

0
ARCHIVE1.PAS → SOURCE/ARCHIVE1.PAS
View File

0
ARCHIVE2.PAS → SOURCE/ARCHIVE2.PAS
View File

0
ARCHIVE3.PAS → SOURCE/ARCHIVE3.PAS
View File

0
ARCVIEW.PAS → SOURCE/ARCVIEW.PAS
View File

0
AUTOMSG.PAS → SOURCE/AUTOMSG.PAS
View File

0
BBSLIST.PAS → SOURCE/BBSLIST.PAS
View File

0
BOOT.PAS → SOURCE/BOOT.PAS
View File

0
BULLETIN.PAS → SOURCE/BULLETIN.PAS
View File

0
COMMON.PAS → SOURCE/COMMON.PAS
View File

0
COMMON1.PAS → SOURCE/COMMON1.PAS
View File

0
COMMON2.PAS → SOURCE/COMMON2.PAS
View File

0
COMMON3.PAS → SOURCE/COMMON3.PAS
View File

0
COMMON4.PAS → SOURCE/COMMON4.PAS
View File

0
COMMON5.PAS → SOURCE/COMMON5.PAS
View File

0
CUSER.PAS → SOURCE/CUSER.PAS
View File

0
DOORS.PAS → SOURCE/DOORS.PAS
View File

140
SOURCE/ELECOM/BUFUNIT.PAS Normal file
View File

@ -0,0 +1,140 @@
unit BufUnit;
{$I-,R-,S-,Q-}
(*
**
** Large char-buffer handling routines for EleCOM
**
** Copyright (c) 1998-2002 by Maarten Bekers
**
** Version : 1.03
** Created : 05-Jan-1999
** Last update : 12-Jan-2003
**
**
*)
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
INTERFACE
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
Type CharBufType = Array[0..65520] of Char;
type BufArrayObj = Object
TxtArr : CharBufType;
TxtMaxLen : Longint;
TxtStartPtr: Longint; { Start of buffer ptr }
CurTxtPtr : Longint; { Maximum data entered yet }
TmpBuf : CharBufType;
constructor Init(TxtSize: Longint);
destructor Done;
function BufRoom: Longint;
function BufUsed: Longint;
function Put(var Buf; Size: Longint): Longint;
function Get(var Buf; Size: Longint; Remove: Boolean): Longint;
procedure Clear;
end; { BufArrayObj }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
IMPLEMENTATION
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
constructor BufArrayObj.Init(TxtSize: Longint);
begin
TxtMaxLen := TxtSize;
CurTxtPtr := -1;
TxtStartPtr := 0;
FillChar(TxtArr, TxtMaxLen, #00);
FillChar(TmpBuf, TxtMaxLen, #00);
end; { constructor Init }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
destructor BufArrayObj.Done;
begin
end; { destructor Done }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function BufArrayObj.BufRoom: Longint;
begin
BufRoom := (TxtMaxLen - (CurTxtPtr + 1));
end; { func. BufRoom }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function BufArrayObj.BufUsed: Longint;
begin
BufUsed := (CurTxtPtr + 01);
end; { func. BufUsed }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function BufArrayObj.Put(var Buf; Size: Longint): Longint;
var RetSize: Longint;
begin
Put := 0;
if Size < 0 then EXIT;
if TxtStartPtr > 0 then
if (CurTxtPtr + TxtStartPtr) > TxtMaxLen then
begin
Move(TxtArr[TxtStartPtr], TxtArr[0], Succ(CurTxtPtr));
TxtStartPtr := 0;
end; { if }
if Size > BufRoom then RetSize := BufRoom
else RetSize := Size;
Move(Buf, TxtArr[TxtStartPtr + BufUsed], RetSize);
Inc(CurTxtPtr, RetSize);
TxtArr[TxtStartPtr + BufUsed + 1] := #0;
Put := RetSize;
end; { func. Put }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function BufArrayObj.Get(var Buf; Size: Longint; Remove: Boolean): Longint;
var RetSize: Longint;
begin
Get := 0;
if Size < 0 then EXIT;
if Size > BufUsed then RetSize := BufUsed
else RetSize := Size;
Move(TxtArr[TxtStartPtr], Buf, RetSize);
Get := RetSize;
if Remove then
begin
if RetSize = BufUsed then
begin
CurTxtPtr := -1;
TxtStartPtr := 0;
TxtArr[0] := #0;
end
else begin
Inc(TxtStartPtr, RetSize);
Dec(CurTxtPtr, RetSize);
TxtArr[CurTxtPtr + TxtStartPtr + 1] := #0;
end; { if }
end; { if }
end; { func. Get }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure BufArrayObj.Clear;
begin
CurTxtPtr := -1;
end; { proc. Clear }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
end.

309
SOURCE/ELECOM/COMBASE.PAS Normal file
View File

@ -0,0 +1,309 @@
unit ComBase;
(*
**
** Serial and TCP/IP communication routines for DOS, OS/2 and Win9x/NT.
** Tested with: TurboPascal v7.0, (DOS)
** VirtualPascal v2.1, (OS/2, Win32)
** FreePascal v0.99.12 (DOS, Win32)
** Delphi v4.0. (Win32)
**
** Version : 1.01
** Created : 21-May-1998
** Last update : 14-May-1999
**
** Note: (c)1998-2003 by Maarten Bekers
**
*)
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
INTERFACE
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
{$IFDEF VirtualPascal}
uses Use32;
{$ENDIF}
{$IFDEF MSDOS}
Type ShortString = String;
{$ENDIF}
type SliceProc = procedure;
type TCommObj = Object
DontClose : Boolean;
InitFailed : Boolean;
ErrorStr : ShortString;
BlockAll : Boolean;
constructor Init;
destructor Done;
procedure Com_OpenQuick(Handle: Longint); virtual;
function Com_Open(Comport: Byte; BaudRate: Longint; DataBits: Byte;
Parity: Char; StopBits: Byte): Boolean; virtual;
function Com_OpenKeep(Comport: Byte): Boolean; virtual;
procedure Com_GetModemStatus(var LineStatus, ModemStatus: Byte); virtual;
procedure Com_SetLine(BpsRate: longint; Parity: Char; DataBits, Stopbits: Byte); virtual;
function Com_GetBPSrate: Longint; virtual;
procedure Com_GetBufferStatus(var InFree, OutFree, InUsed, OutUsed: Longint); virtual;
procedure Com_SetDtr(State: Boolean); virtual;
function Com_CharAvail: Boolean; virtual;
function Com_Carrier: Boolean; virtual;
function Com_ReadyToSend(BlockLen: Longint): Boolean; virtual;
function Com_GetChar: Char; virtual;
function Com_PeekChar: Char; virtual;
function Com_SendChar(C: Char): Boolean; virtual;
function Com_GetDriverInfo: String; virtual;
function Com_GetHandle: Longint; virtual;
function Com_InitSucceeded: Boolean; virtual;
procedure Com_Close; virtual;
procedure Com_SendBlock(var Block; BlockLen: Longint; var Written: Longint); virtual;
procedure Com_SendWait(var Block; BlockLen: Longint; var Written: Longint; Slice: SliceProc); virtual;
procedure Com_ReadBlock(var Block; BlockLen: Longint; var Reads: Longint); virtual;
procedure Com_PurgeOutBuffer; virtual;
procedure Com_PurgeInBuffer; virtual;
procedure Com_PauseCom(CloseCom: Boolean); virtual;
procedure Com_ResumeCom(OpenCom: Boolean); virtual;
procedure Com_FlushOutBuffer(Slice: SliceProc); virtual;
procedure Com_SendString(Temp: ShortString); virtual;
procedure Com_SetFlow(SoftTX, SoftRX, Hard: Boolean); virtual;
procedure Com_SetDataProc(ReadPtr, WritePtr: Pointer); virtual;
end; { object TCommObj }
Type PCommObj = ^TCommObj;
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
IMPLEMENTATION
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
{-- We disable warnings as this is just an abstract -}
constructor TCommObj.Init;
begin
DontClose := false;
InitFailed := false;
BlockAll := false;
ErrorStr := '';
end; { constructor Init }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
destructor TCommObj.Done;
begin
end; { destructor Done }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function TCommObj.Com_Open(Comport: Byte; BaudRate: Longint; DataBits: Byte;
Parity: Char; StopBits: Byte): Boolean;
begin
Com_Open := FALSE;
end; { func. Com_Open }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TCommObj.Com_OpenQuick(Handle: Longint);
begin
end; { proc. TCommObj.Com_OpenQuick }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TCommObj.Com_Close;
begin
end; { proc. TCommObj.Com_Close }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function TCommObj.Com_GetChar: Char;
begin
Com_GetChar := #0;
end; { func. TCommObj.Com_GetChar }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function TCommObj.Com_PeekChar: Char;
begin
Com_PeekChar := #0;
end; { func. TCommObj.Com_GetChar }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function TCommObj.Com_SendChar(C: Char): Boolean;
begin
Com_SendChar := FALSE;
end; { proc. TCommObj.Com_SendChar }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TCommObj.Com_SendBlock(var Block; BlockLen: Longint; var Written: Longint);
begin
end; { proc. TCommObj.Com_SendBlock }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TCommObj.Com_ReadBlock(var Block; BlockLen: Longint; var Reads: Longint);
begin
end; { proc. TCommObj.Com_ReadBlock }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function TCommObj.Com_CharAvail: Boolean;
begin
Com_CharAvail := FALSE;
end; { func. TCommObj.Com_CharAvail }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function TCommObj.Com_Carrier: Boolean;
begin
Com_Carrier := FALSE;
end; { func. Comm_Carrier }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TCommObj.Com_SetDtr(State: Boolean);
begin
end; { proc. TCommObj.Com_SetDtr }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function TCommObj.Com_OpenKeep(Comport: Byte): Boolean;
begin
Com_OpenKeep := FALSE;
end; { func. TCommObj.Com_OpenKeep }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function TCommObj.Com_ReadyToSend(BlockLen: Longint): Boolean;
begin
Com_ReadyToSend := FALSE;
end; { func. TCommObj.Com_ReadyToSend }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TCommObj.Com_GetModemStatus(var LineStatus, ModemStatus: Byte);
begin
end; { proc. TCommObj.Com_GetModemStatus }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function TCommObj.Com_GetBPSrate: Longint;
begin
Com_GetBpsRate := -1;
end; { func. TCommObj.Com_GetBPSrate }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TCommObj.Com_SetLine(BpsRate: longint; Parity: Char; DataBits, Stopbits: Byte);
begin
end; { proc. TCommObj.Com_SetLine }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TCommObj.Com_GetBufferStatus(var InFree, OutFree, InUsed, OutUsed: Longint);
begin
end; { proc. TCommObj.Com_GetBufferStatus }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TCommObj.Com_PurgeInBuffer;
begin
end; { proc. TCommObj.Com_PurgeInBuffer }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TCommObj.Com_PurgeOutBuffer;
begin
end; { proc. TCommObj.Com_PurgeOutBuffer }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function TCommObj.Com_GetDriverInfo: String;
begin
Com_GetDriverInfo := '';
end; { func. Com_GetDriverInfo }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function TCommObj.Com_GetHandle: Longint;
begin
Com_GetHandle := -1;
end; { func. Com_GetHandle }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TCommObj.Com_PauseCom(CloseCom: Boolean);
begin
end; { proc. Com_PauseCom }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TCommObj.Com_ResumeCom(OpenCom: Boolean);
begin
end; { proc. Com_ResumeCom }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function TCommObj.Com_InitSucceeded: Boolean;
begin
Com_InitSucceeded := NOT InitFailed;
end; { func. Com_InitFailed }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TCommObj.Com_FlushOutBuffer(Slice: SliceProc);
var InFree,
OutFree,
InUsed,
OutUsed : Longint;
begin
Com_GetBufferStatus(InFree, OutFree, InUsed, OutUsed);
while (OutUsed > 1) AND (Com_Carrier) do
{ X00 (fossil) will never go below 1 ! }
begin
Com_GetBufferStatus(InFree, OutFree, InUsed, OutUsed);
if @Slice <> nil then
begin
Slice;
Slice;
end; { if }
end; { while }
end; { proc. Com_FlushOutBuffer }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TCommObj.Com_SendWait(var Block; BlockLen: Longint; var Written: Longint; Slice: SliceProc);
begin
Com_SendBlock(Block, BlockLen, Written);
end; { proc. Com_SendWait }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TCommObj.Com_SendString(Temp: ShortString);
var Written: Longint;
begin
Com_SendBlock(Temp[1], Length(Temp), Written);
end; { proc. Com_SendString }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TCommObj.Com_SetFlow(SoftTX, SoftRX, Hard: Boolean);
begin
end; { proc. Com_Setflow }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TCommObj.Com_SetDataProc(ReadPtr, WritePtr: Pointer);
begin
end; { Com_SetDataProc }
end.

350
SOURCE/ELECOM/ELECOM13.PAS Normal file
View File

@ -0,0 +1,350 @@
library ELECOM13;
{$H-} { important, turn off Ansi-Strings }
(*
**
** Serial and TCP/IP communication routines for DOS, OS/2 and Win9x/NT.
** Tested with: TurboPascal v7.0, (DOS)
** VirtualPascal v2.1, (OS/2, Win32)
** FreePascal v0.99.12 (DOS, Win32)
** Delphi v4.0. (Win32)
**
** Version : 1.02
** Created : 13-Jun-1999
** Last update : 28-Jun-2000
**
** Note: (c)1998-1999 by Maarten Bekers.
** If you have any suggestions, please let me know.
**
*)
uses ComBase,
{$IFDEF WIN32}
W32SNGL,
{$ENDIF}
{$IFDEF OS2}
Os2Com,
{$ENDIF}
Telnet;
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
var ComObj : pCommObj;
ComSystem: Longint;
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure Int_ComReadProc(var TempPtr: Pointer); stdcall;
begin
{$IFDEF WIN32}
Case ComSystem of
1 : PWin32Obj(ComObj)^.Com_DataProc(TempPtr);
2 : PTelnetObj(ComObj)^.Com_ReadProc(TempPtr);
end; { case }
{$ENDIF}
{$IFDEF OS2}
Case ComSystem of
1 : POs2Obj(ComObj)^.Com_ReadProc(TempPtr);
2 : PTelnetObj(ComObj)^.Com_ReadProc(TempPtr);
end; { case }
{$ENDIF}
end; { proc. Int_ComReadProc }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure Int_ComWriteProc(var TempPtr: Pointer); stdcall;
begin
{$IFDEF WIN32}
Case ComSystem of
1 : PWin32Obj(ComObj)^.Com_DataProc(TempPtr);
2 : PTelnetObj(ComObj)^.Com_WriteProc(TempPtr);
end; { case }
{$ENDIF}
{$IFDEF OS2}
Case ComSystem of
1 : POs2Obj(ComObj)^.Com_WriteProc(TempPtr);
2 : PTelnetObj(ComObj)^.Com_WriteProc(TempPtr);
end; { case }
{$ENDIF}
end; { proc. Int_ComWriteProc }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure Com_Startup(ObjectType: Longint); stdcall;
begin
ComSystem := ObjectType;
Case Objecttype of
{$IFDEF WIN32}
01 : ComObj := New(pWin32Obj, Init);
{$ENDIF}
{$IFDEF OS2}
01 : ComObj := New(pOs2Obj, Init);
{$ENDIF}
02 : ComObj := New(pTelnetObj, Init);
end; { case }
ComObj^.Com_SetDataProc(@Int_ComReadProc, @Int_ComWriteProc);
end; { proc. Com_Startup }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure Com_OpenQuick(Handle: Longint); stdcall;
begin
ComObj^.Com_OpenQuick(Handle);
end; { proc. Com_OpenQuick }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function Com_Open(Comport: Byte; BaudRate: Longint; DataBits: Byte;
Parity: Char; StopBits: Byte): Boolean; stdcall;
begin
Result := ComObj^.Com_Open(Comport, BaudRate, DataBits, Parity, StopBits);
end; { func. Com_Open }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function Com_OpenKeep(Comport: Byte): Boolean; stdcall;
begin
Result := ComObj^.Com_OpenKeep(Comport);
end; { func. Com_OpenKeep }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure Com_GetModemStatus(var LineStatus, ModemStatus: Byte); stdcall;
begin
ComObj^.Com_GetModemStatus(LineStatus, ModemStatus);
end; { proc. Com_GetModemStatus }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure Com_SetLine(BpsRate: longint; Parity: Char; DataBits, Stopbits: Byte); stdcall;
begin
ComObj^.Com_SetLine(BpsRate, Parity, DataBits, StopBits);
end; { proc. Com_SetLine }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function Com_GetBPSrate: Longint; stdcall;
begin
Result := ComObj^.Com_GetBpsRate;
end; { func. Com_GetBpsRate }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure Com_GetBufferStatus(var InFree, OutFree, InUsed, OutUsed: Longint); stdcall;
begin
ComObj^.Com_GetBufferStatus(InFree, OutFree, InUsed, OutUsed);
end; { proc. Com_GetBufferStatus }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure Com_SetDtr(State: Boolean); stdcall;
begin
ComObj^.Com_SetDtr(State);
end; { proc. Com_SetDtr }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function Com_CharAvail: Boolean; stdcall;
begin
Result := ComObj^.Com_CharAvail;
end; { func. Com_CharAvail }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function Com_Carrier: Boolean; stdcall;
begin
Result := ComObj^.Com_Carrier;
end; { func. Com_Carrier }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function Com_ReadyToSend(BlockLen: Longint): Boolean; stdcall;
begin
Result := ComObj^.Com_ReadyToSend(BlockLen);
end; { func. Com_ReadyToSend }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function Com_GetChar: Char; stdcall;
begin
Result := ComObj^.Com_GetChar;
end; { func. Com_GetChar }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function Com_SendChar(C: Char): Boolean; stdcall;
begin
Result := ComObj^.Com_SendChar(C);
end; { func. Com_SendChar }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function Com_GetDriverInfo: String; stdcall;
begin
Result := ComObj^.Com_GetDriverInfo;
end; { func. Com_GetDriverInfo }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function Com_GetHandle: Longint; stdcall;
begin
Result := ComObj^.Com_GetHandle;
end; { func. Com_GetHandle }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function Com_InitSucceeded: Boolean; stdcall;
begin
Result := ComObj^.Com_InitSucceeded;
end; { func. Com_InitSucceeded }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure Com_Close; stdcall;
begin
ComObj^.Com_Close;
end; { proc. Com_Close }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure Com_SendBlock(var Block; BlockLen: Longint; var Written: Longint); stdcall;
begin
ComObj^.Com_SendBlock(Block, BlockLen, Written);
end; { proc. Com_SendBlock }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure Com_SendWait(var Block; BlockLen: Longint; var Written: Longint; Slice: SliceProc); stdcall;
begin
ComObj^.Com_SendWait(Block, BlockLen, Written, Slice);
end; { proc. Com_SendWait }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure Com_ReadBlock(var Block; BlockLen: Longint; var Reads: Longint); stdcall;
begin
ComObj^.Com_ReadBlock(Block, BlockLen, Reads);
end; { proc. Com_ReadBlock }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure Com_PurgeOutBuffer; stdcall;
begin
ComObj^.Com_PurgeOutBuffer;
end; { proc. Com_PurgeOutBuffer }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure Com_PurgeInBuffer; stdcall;
begin
ComObj^.Com_PurgeInBuffer;
end; { proc. Com_PurgeInBuffer }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure Com_PauseCom(CloseCom: Boolean); stdcall;
begin
ComObj^.Com_PauseCom(CloseCom);
end; { proc. Com_PauseCom }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure Com_ResumeCom(OpenCom: Boolean); stdcall;
begin
ComObj^.Com_ResumeCom(OpenCom);
end; { proc. Com_ResumeCom }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure Com_FlushOutBuffer(Slice: SliceProc); stdcall;
begin
ComObj^.Com_FlushOutBuffer(Slice);
end; { proc. Com_FlushOutBuffer }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure Com_SendString(Temp: String); stdcall;
begin
ComObj^.Com_SendString(Temp);
end; { Com_SendString }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure Com_SetDontClose(Value: Boolean); stdcall;
begin
ComObj^.DontClose := Value;
end; { proc. Com_SetDontClose }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure Com_SetFlow(SoftTX, SoftRX, Hard: Boolean); stdcall;
begin
ComObj^.Com_SetFlow(SoftTX, SoftRX, Hard);
end; { proc. Com_Setflow }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure Com_ShutDown; stdcall;
begin
Dispose(ComObj, Done);
end; { proc. Com_ShutDown }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function Com_InitFailed: Boolean; stdcall;
begin
Result := ComObj^.InitFailed;
end; { func. Com_Initfailed }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function Com_ErrorStr: String; stdcall;
begin
Result := ComObj^.ErrorStr;
end; { func. Com_ErrorStr }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
exports
Com_Startup index 1 name 'Com_Startup',
Com_Open index 2 name 'Com_Open',
Com_OpenQuick index 3 name 'Com_OpenQuick',
Com_OpenKeep index 4 name 'Com_OpenKeep',
Com_GetModemStatus index 5 name 'Com_GetModemStatus',
Com_SetLine index 6 name 'Com_SetLine',
Com_GetBPSrate index 7 name 'Com_GetBPSrate',
Com_GetBufferStatus index 8 name 'Com_GetBufferStatus',
Com_SetDtr index 09 name 'Com_SetDtr',
Com_CharAvail index 10 name 'Com_CharAvail',
Com_Carrier index 11 name 'Com_Carrier',
Com_ReadyToSend index 12 name 'Com_ReadyToSend',
Com_GetChar index 13 name 'Com_GetChar',
Com_SendChar index 14 name 'Com_SendChar',
Com_GetDriverInfo index 15 name 'Com_GetDriverInfo',
Com_GetHandle index 16 name 'Com_GetHandle',
Com_InitSucceeded index 17 name 'Com_InitSucceeded',
Com_Close index 18 name 'Com_Close',
Com_SendBlock index 19 name 'Com_SendBlock',
Com_SendWait index 20 name 'Com_SendWait',
Com_ReadBlock index 21 name 'Com_ReadBlock',
Com_PurgeOutBuffer index 22 name 'Com_PurgeOutBuffer',
Com_PurgeInBuffer index 23 name 'Com_PurgeInBuffer',
Com_PauseCom index 24 name 'Com_PauseCom',
Com_ResumeCom index 25 name 'Com_ResumeCom',
Com_FlushOutBuffer index 26 name 'Com_FlushOutBuffer',
Com_SendString index 27 name 'Com_SendString',
Com_ShutDown index 28 name 'Com_ShutDown',
Com_SetDontClose index 29 name 'Com_SetDontClose',
Com_SetFlow index 30 name 'Com_SetFlow',
Com_InitFailed index 31 name 'Com_InitFailed',
Com_ErrorStr index 32 name 'Com_ErrorStr';
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
begin
ComObj := nil;
end.

101
SOURCE/ELECOM/ELEDEF.PAS Normal file
View File

@ -0,0 +1,101 @@
unit ELEDEF;
(*
**
** Serial and TCP/IP communication routines for DOS, OS/2 and Win9x/NT.
** Tested with: TurboPascal v7.0, (DOS)
** VirtualPascal v2.1, (OS/2, Win32)
** FreePascal v0.99.12 (DOS, Win32)
** Delphi v4.0. (Win32)
**
** Version : 1.03
** Created : 13-Jun-1999
** Last update : 05-Aug-2000
**
** Note: (c)1998-1999 by Maarten Bekers.
** If you have any suggestions, please let me know.
**
*)
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
INTERFACE
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
Const
ComNameDLL = 'elecom13.dll';
type SliceProc = procedure;
procedure Com_Startup(ObjectType: Longint); stdcall;
function Com_Open(Comport: Byte; BaudRate: Longint; DataBits: Byte;
Parity: Char; StopBits: Byte): Boolean; stdcall;
procedure Com_OpenQuick(Handle: Longint); stdcall;
function Com_OpenKeep(Comport: Byte): Boolean; stdcall;
procedure Com_GetModemStatus(var LineStatus, ModemStatus: Byte); stdcall;
procedure Com_SetLine(BpsRate: longint; Parity: Char; DataBits, Stopbits: Byte); stdcall;
function Com_GetBPSrate: Longint; stdcall;
procedure Com_GetBufferStatus(var InFree, OutFree, InUsed, OutUsed: Longint); stdcall;
procedure Com_SetDtr(State: Boolean); stdcall;
function Com_CharAvail: Boolean; stdcall;
function Com_Carrier: Boolean; stdcall;
function Com_ReadyToSend(BlockLen: Longint): Boolean;
function Com_GetChar: Char; stdcall;
function Com_SendChar(C: Char): Boolean; stdcall;
function Com_GetDriverInfo: String; stdcall;
function Com_GetHandle: Longint; stdcall;
function Com_InitSucceeded: Boolean; stdcall;
procedure Com_Close; stdcall;
procedure Com_SendBlock(var Block; BlockLen: Longint; var Written: Longint); stdcall;
procedure Com_SendWait(var Block; BlockLen: Longint; var Written: Longint; Slice: SliceProc); stdcall;
procedure Com_ReadBlock(var Block; BlockLen: Longint; var Reads: Longint); stdcall;
procedure Com_PurgeOutBuffer; stdcall;
procedure Com_PurgeInBuffer; stdcall;
procedure Com_PauseCom(CloseCom: Boolean); stdcall;
procedure Com_ResumeCom(OpenCom: Boolean); stdcall;
procedure Com_FlushOutBuffer(Slice: SliceProc); stdcall;
procedure Com_SendString(Temp: String); stdcall;
procedure Com_ShutDown; stdcall;
procedure Com_SetDontClose(Value: Boolean); stdcall;
procedure Com_SetFlow(SoftTX, SoftRX, Hard: Boolean); stdcall;
function Com_InitFailed: Boolean; stdcall;
function Com_ErrorStr: String; stdcall;
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
IMPLEMENTATION
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure Com_Startup(ObjectType: Longint); external ComNameDLL index 1;
function Com_Open(Comport: Byte; BaudRate: Longint; DataBits: Byte;
Parity: Char; StopBits: Byte): Boolean; external ComNameDLL index 2;
procedure Com_OpenQuick(Handle: Longint); external ComNameDLL index 3;
function Com_OpenKeep(Comport: Byte): Boolean; external ComNameDLL index 4;
procedure Com_GetModemStatus(var LineStatus, ModemStatus: Byte); external ComNameDLL index 5;
procedure Com_SetLine(BpsRate: longint; Parity: Char; DataBits, Stopbits: Byte); external ComNameDLL index 6;
function Com_GetBPSrate: Longint; external ComNameDLL index 7;
procedure Com_GetBufferStatus(var InFree, OutFree, InUsed, OutUsed: Longint); external ComNameDLL index 8;
procedure Com_SetDtr(State: Boolean); external ComNameDLL index 9;
function Com_CharAvail: Boolean; external ComNameDLL index 10;
function Com_Carrier: Boolean; external ComNameDLL index 11;
function Com_ReadyToSend(BlockLen: Longint): Boolean; external ComNameDLL index 12;
function Com_GetChar: Char; external ComNameDLL index 13;
function Com_SendChar(C: Char): Boolean; external ComNameDLL index 14;
function Com_GetDriverInfo: String; external ComNameDLL index 15;
function Com_GetHandle: Longint; external ComNameDLL index 16;
function Com_InitSucceeded: Boolean; external ComNameDLL index 17;
procedure Com_Close; external ComNameDLL index 18;
procedure Com_SendBlock(var Block; BlockLen: Longint; var Written: Longint); external ComNameDLL index 19;
procedure Com_SendWait(var Block; BlockLen: Longint; var Written: Longint; Slice: SliceProc); external ComNameDLL index 20;
procedure Com_ReadBlock(var Block; BlockLen: Longint; var Reads: Longint); external ComNameDLL index 21;
procedure Com_PurgeOutBuffer; external ComNameDLL index 22;
procedure Com_PurgeInBuffer; external ComNameDLL index 23;
procedure Com_PauseCom(CloseCom: Boolean); external ComNameDLL index 24;
procedure Com_ResumeCom(OpenCom: Boolean); external ComNameDLL index 25;
procedure Com_FlushOutBuffer(Slice: SliceProc); external ComNameDLL index 26;
procedure Com_SendString(Temp: String); external ComNameDLL index 27;
procedure Com_ShutDown; external ComNameDLL index 28;
procedure Com_SetDontClose(Value: Boolean); external ComNameDLL index 29;
procedure Com_SetFlow(SoftTX, SoftRX, Hard: Boolean); external ComNameDLL index 30;
function Com_InitFailed: Boolean; external ComNameDLL index 31;
function Com_ErrorStr: String; external ComNameDLL index 32;
end.

376
SOURCE/ELECOM/ELENORM.PAS Normal file
View File

@ -0,0 +1,376 @@
unit EleNORM;
(*
**
** Serial and TCP/IP communication routines for DOS, OS/2 and Win9x/NT.
** Tested with: TurboPascal v7.0, (DOS)
** VirtualPascal v2.1, (OS/2, Win32)
** FreePascal v0.99.12 (DOS, Win32)
** Delphi v4.0. (Win32)
**
** Version : 1.01
** Created : 13-Jun-1999
** Last update : 28-Jun-2000
**
** Note: (c)1998 - 2000 by Maarten Bekers. This unit tries to make it easier
** to use EleCOM.
**
** Usage:
** Before calling any of these routines, first call Com_StartUp:
** Pass the following number to it:
** 01 - Use the "modem" communications (OS/2, Win32 or FOSSIL)
** 02 - Use the TELNET type (OS/2 or Win32 only).
**
*)
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
INTERFACE
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
uses ComBase
{$IFDEF WIN32}
, W32SNGL
, Telnet
{$ENDIF}
{$IFDEF OS2}
, Telnet
, Os2com
{$ENDIF}
{$IFDEF GO32V2}
, Fos_Com
{$ENDIF}
{$IFDEF MSDOS}
, Fos_com
{$ENDIF} ;
function Com_Open(Comport: Byte; BaudRate: Longint; DataBits: Byte;
Parity: Char; StopBits: Byte): Boolean;
function Com_OpenKeep(Comport: Byte): Boolean;
function Com_CharAvail: Boolean;
function Com_Carrier: Boolean;
function Com_ReadyToSend(BlockLen: Longint): Boolean;
function Com_GetChar: Char;
function Com_PeekChar: Char;
function Com_SendChar(C: Char): Boolean;
function Com_GetDriverInfo: String;
function Com_GetHandle: Longint;
function Com_InitSucceeded: Boolean;
procedure Com_Startup(ObjectType: Longint);
procedure Com_OpenQuick(Handle: Longint);
procedure Com_GetModemStatus(var LineStatus, ModemStatus: Byte);
procedure Com_SetLine(BpsRate: longint; Parity: Char; DataBits, Stopbits: Byte);
procedure Com_GetBufferStatus(var InFree, OutFree, InUsed, OutUsed: Longint);
procedure Com_SetDtr(State: Boolean);
procedure Com_Close;
procedure Com_SendBlock(var Block; BlockLen: Longint; var Written: Longint);
procedure Com_SendWait(var Block; BlockLen: Longint; var Written: Longint; Slice: SliceProc);
procedure Com_ReadBlock(var Block; BlockLen: Longint; var Reads: Longint);
procedure Com_PurgeOutBuffer;
procedure Com_PurgeInBuffer;
procedure Com_PauseCom(CloseCom: Boolean);
procedure Com_ResumeCom(OpenCom: Boolean);
procedure Com_FlushOutBuffer(Slice: SliceProc);
procedure Com_SendString(Temp: String);
procedure Com_SetDontClose(Value: Boolean);
procedure Com_ShutDown;
procedure Com_SetFlow(SoftTX, SoftRX, Hard: Boolean);
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
var ComObj : pCommObj;
ComSystem: Longint;
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
IMPLEMENTATION
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure Int_ComReadProc(var TempPtr: Pointer);
begin
{$IFDEF WIN32}
Case ComSystem of
1 : PWin32Obj(ComObj)^.Com_DataProc(TempPtr);
2 : PTelnetObj(ComObj)^.Com_ReadProc(TempPtr);
end; { case }
{$ENDIF}
{$IFDEF OS2}
Case ComSystem of
1 : POs2Obj(ComObj)^.Com_ReadProc(TempPtr);
2 : PTelnetObj(ComObj)^.Com_ReadProc(TempPtr);
end; { case }
{$ENDIF}
end; { proc. Int_ComReadProc }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure Int_ComWriteProc(var TempPtr: Pointer);
begin
{$IFDEF WIN32}
Case ComSystem of
1 : PWin32Obj(ComObj)^.Com_DataProc(TempPtr);
2 : PTelnetObj(ComObj)^.Com_WriteProc(TempPtr);
end; { case }
{$ENDIF}
{$IFDEF OS2}
Case ComSystem of
1 : POs2Obj(ComObj)^.Com_WriteProc(TempPtr);
2 : PTelnetObj(ComObj)^.Com_WriteProc(TempPtr);
end; { case }
{$ENDIF}
end; { proc. Int_ComWriteProc }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure Com_Startup(ObjectType: Longint);
begin
ComSystem := ObjectType;
Case Objecttype of
{$IFDEF WIN32}
01 : ComObj := New(pWin32Obj, Init);
02 : ComObj := New(pTelnetObj, Init);
{$ENDIF}
{$IFDEF OS2}
01 : ComObj := New(pOs2Obj, Init);
02 : ComObj := New(pTelnetObj, Init);
{$ENDIF}
{$IFDEF MSDOS}
01 : ComObj := New(pFossilObj, Init);
{$ENDIF}
{$IFDEF GO32V2}
01 : ComObj := New(pFossilObj, Init);
{$ENDIF}
end; { case }
{$IFDEF WIN32}
ComObj^.Com_SetDataProc(@Int_ComReadProc, @Int_ComWriteProc);
{$ENDIF}
{$IFDEF OS2}
ComObj^.Com_SetDataProc(@Int_ComReadProc, @Int_ComWriteProc);
{$ENDIF}
end; { proc. Com_Startup }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure Com_OpenQuick(Handle: Longint);
begin
ComObj^.Com_OpenQuick(Handle);
end; { proc. Com_OpenQuick }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function Com_Open(Comport: Byte; BaudRate: Longint; DataBits: Byte;
Parity: Char; StopBits: Byte): Boolean;
begin
Com_Open := ComObj^.Com_Open(Comport, BaudRate, DataBits, Parity, StopBits);
end; { func. Com_Open }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function Com_OpenKeep(Comport: Byte): Boolean;
begin
Com_OpenKeep := ComObj^.Com_OpenKeep(Comport);
end; { func. Com_OpenKeep }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure Com_GetModemStatus(var LineStatus, ModemStatus: Byte);
begin
ComObj^.Com_GetModemStatus(LineStatus, ModemStatus);
end; { proc. Com_GetModemStatus }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure Com_SetLine(BpsRate: longint; Parity: Char; DataBits, Stopbits: Byte);
begin
ComObj^.Com_SetLine(BpsRate, Parity, DataBits, StopBits);
end; { proc. Com_SetLine }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function Com_GetBPSrate: Longint;
begin
Com_GetBpsRate := ComObj^.Com_GetBpsRate;
end; { func. Com_GetBpsRate }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure Com_GetBufferStatus(var InFree, OutFree, InUsed, OutUsed: Longint);
begin
ComObj^.Com_GetBufferStatus(InFree, OutFree, InUsed, OutUsed);
end; { proc. Com_GetBufferStatus }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure Com_SetDtr(State: Boolean);
begin
ComObj^.Com_SetDtr(State);
end; { proc. Com_SetDtr }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function Com_CharAvail: Boolean;
begin
Com_CharAvail := ComObj^.Com_CharAvail;
end; { func. Com_CharAvail }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function Com_Carrier: Boolean;
begin
Com_Carrier := ComObj^.Com_Carrier;
end; { func. Com_Carrier }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function Com_ReadyToSend(BlockLen: Longint): Boolean;
begin
Com_ReadyToSend := ComObj^.Com_ReadyToSend(BlockLen);
end; { func. Com_ReadyToSend }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function Com_GetChar: Char;
begin
Com_GetChar := ComObj^.Com_GetChar;
end; { func. Com_GetChar }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function Com_PeekChar: Char;
begin
Com_PeekChar := ComObj^.Com_PeekChar;
end; { func. Com_GetChar }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function Com_SendChar(C: Char): Boolean;
begin
Com_SendChar := ComObj^.Com_SendChar(C);
end; { func. Com_SendChar }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function Com_GetDriverInfo: String;
begin
Com_GetDriverInfo := ComObj^.Com_GetDriverInfo;
end; { func. Com_GetDriverInfo }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function Com_GetHandle: Longint;
begin
Com_GetHandle := ComObj^.Com_GetHandle;
end; { func. Com_GetHandle }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function Com_InitSucceeded: Boolean;
begin
Com_InitSucceeded := ComObj^.Com_InitSucceeded;
end; { func. Com_InitSucceeded }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure Com_Close;
begin
ComObj^.Com_Close;
end; { proc. Com_Close }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure Com_SendBlock(var Block; BlockLen: Longint; var Written: Longint);
begin
ComObj^.Com_SendBlock(Block, BlockLen, Written);
end; { proc. Com_SendBlock }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure Com_SendWait(var Block; BlockLen: Longint; var Written: Longint; Slice: SliceProc);
begin
ComObj^.Com_SendWait(Block, BlockLen, Written, Slice);
end; { proc. Com_SendWait }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure Com_ReadBlock(var Block; BlockLen: Longint; var Reads: Longint);
begin
ComObj^.Com_ReadBlock(Block, BlockLen, Reads);
end; { proc. Com_ReadBlock }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure Com_PurgeOutBuffer;
begin
ComObj^.Com_PurgeOutBuffer;
end; { proc. Com_PurgeOutBuffer }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure Com_PurgeInBuffer;
begin
ComObj^.Com_PurgeInBuffer;
end; { proc. Com_PurgeInBuffer }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure Com_PauseCom(CloseCom: Boolean);
begin
ComObj^.Com_PauseCom(CloseCom);
end; { proc. Com_PauseCom }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure Com_ResumeCom(OpenCom: Boolean);
begin
ComObj^.Com_ResumeCom(OpenCom);
end; { proc. Com_ResumeCom }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure Com_FlushOutBuffer(Slice: SliceProc);
begin
ComObj^.Com_FlushOutBuffer(Slice);
end; { proc. Com_FlushOutBuffer }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure Com_SendString(Temp: String);
begin
ComObj^.Com_SendString(Temp);
end; { Com_SendString }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure Com_SetDontClose(Value: Boolean);
begin
ComObj^.DontClose := Value;
end; { proc. Com_SetDontClose }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure Com_ShutDown;
begin
Dispose(ComObj, Done);
end; { proc. Com_ShutDown }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure Com_SetFlow(SoftTX, SoftRX, Hard: Boolean);
begin
ComObj^.Com_SetFlow(SoftTX, SoftRX, Hard);
end; { proc. Com_SetFlow }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
begin
ComObj := nil;
end.

150
SOURCE/ELECOM/EXAM2.PAS Normal file
View File

@ -0,0 +1,150 @@
program Exam2;
(*
**
** EXAMPLE how to use communications
** This is only an example of how to use EleCOM independently of a BBS program,
** to see an example how to use EleCOM as a door from a BBS program, see
** EXAMPLE.PAS
** TELNET is not supported as we dont have a telnet server
**
** version: 1.01
** Created: 30-Sep-1999
**
** Fire up line: EXAM2.EXE -C<comport>
** eg: EXAM2.EXE -C4
**
*)
{.DEFINE FOSSIL}
{.DEFINE OS2COM}
{$DEFINE W32COM}
{$IFNDEF FOSSIL}
{$IFNDEF OS2COM}
{$IFNDEF W32COM}
You need to define one of these..
{$ENDIF}
{$ENDIF}
{$ENDIF}
uses Combase,
{$IFDEF FOSSIL}
Fos_Com
{$ENDIF}
{$IFDEF OS2COM}
Os2Com
{$ENDIF}
{$IFDEF W32COM}
W32SNGL
{$ENDIF} ;
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
var ComObj : PCommObj;
ComPort : Longint;
ReadCH : Char;
IsTelnet : Boolean;
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure Int_ComReadProc(var TempPtr: Pointer);
begin
{$IFDEF WIN32}
Case IsTelnet of
FALSE : PWin32Obj(ComObj)^.Com_DataProc(TempPtr);
end; { case }
{$ENDIF}
{$IFDEF OS2}
Case IsTelnet of
FALSE : POs2Obj(ComObj)^.Com_ReadProc(TempPtr);
end; { case }
{$ENDIF}
end; { proc. Int_ComReadProc }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure Int_ComWriteProc(var TempPtr: Pointer);
begin
{$IFDEF WIN32}
Case IsTelnet of
FALSE : PWin32Obj(ComObj)^.Com_DataProc(TempPtr);
end; { case }
{$ENDIF}
{$IFDEF OS2}
Case IsTelnet of
FALSE : POs2Obj(ComObj)^.Com_WriteProc(TempPtr);
end; { case }
{$ENDIF}
end; { proc. Int_ComWriteProc }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure ParseCommandLine;
var Counter: Longint;
TempStr: String;
{$IFDEF MSDOS}
Code : Integer;
{$ELSE}
Code : Longint;
{$ENDIF}
begin
for Counter := 01 to ParamCount do
begin
TempStr := ParamStr(Counter);
if TempStr[1] in ['/', '-'] then
Case UpCase(TempStr[2]) of
'C' : begin
TempStr := Copy(TempStr, 3, Length(TempStr) - 2);
Val(TempStr, ComPort, Code);
end; { 'C' }
end; { case }
end; { for }
end; { proc. ParseCommandLine }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
begin
IsTelnet := false;
ParseCommandLine;
{$IFDEF W32COM}
ComObj := New(PWin32Obj, Init);
{$ENDIF}
{$IFDEF FOSSIL}
ComObj := New(PFossilObj, Init);
{$ENDIF}
{$IFDEF OS2COM}
ComObj := New(POs2Obj, Init);
{$ENDIF}
{$IFDEF WIN32}
ComObj^.Com_SetDataProc(@Int_ComReadProc, @Int_ComWriteProc);
{$ENDIF}
{$IFDEF OS2}
ComObj^.Com_SetDataProc(@Int_ComReadProc, @Int_ComWriteProc);
{$ENDIF}
ComObj^.Com_OpenKeep(Comport); { Dont change any comport settings }
ComObj^.Com_SendString('Hello there!' + #13#10);
repeat
ReadCH := ComObj^.Com_GetChar;
if ReadCH <> #13 then
Writeln('Other..');
until (ReadCH = #13) OR (NOT ComObj^.Com_Carrier);
Dispose(ComObj, Done); { Dispose the communications object }
end.

550
SOURCE/ELECOM/FOS_COM.PAS Normal file
View File

@ -0,0 +1,550 @@
unit FOS_COM;
(*
**
** Serial and TCP/IP communication routines for DOS, OS/2 and Win9x/NT.
** Tested with: TurboPascal v7.0, (DOS)
** VirtualPascal v2.1, (OS/2, Win32)
** FreePascal v0.99.12 (DOS, Win32)
** Delphi v4.0. (Win32)
**
** Version : 1.01
** Created : 21-May-1998
** Last update : 07-Apr-1999
**
** Note: (c) 1998-1999 by Maarten Bekers
**
*)
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
INTERFACE
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
uses Dos, Combase;
type TFossilObj = Object(TCommObj)
Regs : Registers;
FosPort: Byte;
constructor Init;
destructor Done;
function Com_Open(Comport: Byte; BaudRate: Longint; DataBits: Byte;
Parity: Char; StopBits: Byte): Boolean; virtual;
function Com_OpenKeep(Comport: Byte): Boolean; virtual;
function Com_GetChar: Char; virtual;
function Com_CharAvail: Boolean; virtual;
function Com_Carrier: Boolean; virtual;
function Com_SendChar(C: Char): Boolean; virtual;
function Com_ReadyToSend(BlockLen: Longint): Boolean; virtual;
function Com_GetBPSrate: Longint; virtual;
function Com_GetDriverInfo: String; virtual;
function Com_GetHandle: longint; virtual;
procedure Com_OpenQuick(Handle: Longint); virtual;
procedure Com_Close; virtual;
procedure Com_SendBlock(var Block; BlockLen: Longint; var Written: Longint); virtual;
procedure Com_SendWait(var Block; BlockLen: Longint; var Written: Longint; Slice: SliceProc); virtual;
procedure Com_ReadBlock(var Block; BlockLen: Longint; var Reads: Longint); virtual;
procedure Com_GetBufferStatus(var InFree, OutFree, InUsed, OutUsed: Longint); virtual;
procedure Com_SetDtr(State: Boolean); virtual;
procedure Com_GetModemStatus(var LineStatus, ModemStatus: Byte); virtual;
procedure Com_SetLine(BpsRate: longint; Parity: Char; DataBits, Stopbits: Byte); virtual;
procedure Com_PurgeInBuffer; virtual;
procedure Com_PurgeOutBuffer; virtual;
procedure Com_SetFlow(SoftTX, SoftRX, Hard: Boolean); virtual;
end; { object TFossilObj }
Type PFossilObj = ^TFossilObj;
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
IMPLEMENTATION
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
uses Strings
{$IFDEF GO32V2}
,Go32
{$ENDIF} ;
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure DosAlloc(var Selector: Word; var SegMent: Word; Size: Longint);
var Res: Longint;
begin
{$IFDEF GO32V2}
Res := Global_DOS_Alloc(Size);
Selector := Word(Res);
Segment := Word(RES SHR 16);
{$ENDIF}
end; { proc. DosAlloc }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure DosFree(Selector: Word);
begin
{$IFDEF GO32V2}
Global_DOS_Free(Selector);
{$ENDIF}
end; { proc. DosFree }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
constructor TFossilObj.Init;
begin
inherited Init;
end; { constructor Init }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
destructor TFossilObj.Done;
begin
inherited Done;
end; { destructor Done }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure FossilIntr(var Regs: Registers);
begin
Intr($14, Regs);
end; { proc. FossilIntr }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function TFossilObj.Com_Open(Comport: Byte; BaudRate: Longint; DataBits: Byte;
Parity: Char; StopBits: Byte): Boolean;
begin
{-------------------------- Open the comport -----------------------------}
FosPort := (ComPort - 01);
Regs.AH := $04;
Regs.DX := FosPort;
Regs.BX := $4F50;
FossilIntr(Regs);
Com_Open := (Regs.AX = $1954);
InitFailed := (Regs.AX <> $1954);
Com_SetLine(BaudRate, Parity, DataBits, StopBits);
end; { func. TFossilObj.Com_OpenCom }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function TFossilObj.Com_OpenKeep(Comport: Byte): Boolean;
begin
FosPort := (ComPort - 01);
Regs.AH := $04;
Regs.DX := FosPort;
Regs.BX := $4F50;
FossilIntr(Regs);
Com_OpenKeep := (Regs.AX = $1954);
InitFailed := (Regs.AX <> $1954);
end; { func. Com_OpenKeep }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TFossilObj.Com_OpenQuick(Handle: Longint);
begin
{-------------------------- Open the comport -----------------------------}
FosPort := (Handle - 01);
Regs.AH := $04;
Regs.DX := FosPort;
Regs.BX := $4F50;
FossilIntr(Regs);
InitFailed := (Regs.AX <> $1954);
end; { proc. Com_OpenQuick }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TFossilObj.Com_SetLine(BpsRate: longint; Parity: Char; DataBits, Stopbits: Byte);
var BPS: Byte;
begin
if BpsRate > 65534 then
BpsRate := 65534;
Case Word(BpsRate) of { have to typecast to word, else will rte201 in dos }
1200 : BPS := 128;
2400 : BPS := 160;
4800 : BPS := 192;
9600 : BPS := 224;
19200 : BPS := 0
else BPS := 32;
end; { case }
if DataBits in [6..8] then
BPS := BPS + (DataBits - 5);
if Parity = 'O' then BPS := BPS + 8 else
If Parity = 'E' then BPS := BPS + 24;
if StopBits = 2 then BPS := BPS + 04;
Regs.AH := $00;
Regs.AL := BPS;
Regs.DX := FosPort;
FossilIntr(Regs);
end; { proc. TFossilObj.Com_SetLine }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function TFossilObj.Com_GetBPSrate: Longint;
begin
Com_GetBpsRate := 115200;
end; { func. TFossilObj.Com_GetBpsRate }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TFossilObj.Com_Close;
begin
if Dontclose then EXIT;
Regs.AH := $05;
Regs.DX := FosPort;
FossilIntr(Regs);
end; { proc. TFossilObj.Com_Close }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function TFossilObj.Com_SendChar(C: Char): Boolean;
var Written: Longint;
begin
Com_SendWait(C, SizeOf(c), Written, nil);
Com_SendChar := (Written >= SizeOf(c));
end; { proc. TFossilObj.Com_SendChar }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function TFossilObj.Com_GetChar: Char;
begin
Regs.AH := $02;
Regs.DX := FosPort;
FossilIntr(Regs);
Com_GetChar := Chr(Regs.AL);
end; { proc. TFossilObj.Com_ReadChar }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TFossilObj.Com_ReadBlock(var Block; BlockLen: Longint; var Reads: Longint);
{$IFDEF GO32V2}
var Selector,
Segment : Word;
{$ENDIF}
begin
{$IFDEF MSDOS}
Regs.AH := $18;
Regs.DX := FosPort;
Regs.CX := Blocklen;
Regs.ES := Seg(Block);
Regs.DI := Ofs(Block);
FossilIntr(Regs);
Reads := Regs.AX;
{$ENDIF}
{$IFDEF GO32V2}
DosAlloc(Selector, Segment, BlockLen);
if Int31Error <> 0 then EXIT;
DosmemPut(Segment, 0, Block, BlockLen);
Regs.AH := $18;
Regs.DX := FosPort;
Regs.CX := Blocklen;
Regs.ES := Segment;
Regs.DI := 0;
FossilIntr(Regs);
Reads := Regs.AX;
DosMemGet(Segment, 0, Block, BlockLen);
DosFree(Selector);
{$ENDIF}
end; { proc. TFossilObj.Com_ReadBlock }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TFossilObj.Com_SendBlock(var Block; BlockLen: Longint; var Written: Longint);
{$IFDEF GO32V2}
var Selector,
Segment : Word;
{$ENDIF}
begin
{$IFDEF MSDOS}
Regs.AH := $19;
Regs.DX := FosPort;
Regs.CX := Blocklen;
Regs.ES := Seg(Block);
Regs.DI := Ofs(Block);
FossilIntr(Regs);
Written := Regs.AX;
{$ENDIF}
{$IFDEF GO32V2}
DosAlloc(Selector, Segment, BlockLen);
if Int31Error <> 0 then EXIT;
DosmemPut(Segment, 0, Block, BlockLen);
Regs.AH := $19;
Regs.DX := FosPort;
Regs.CX := Blocklen;
Regs.ES := Segment;
Regs.DI := 0;
FossilIntr(Regs);
Written := Regs.AX;
DosMemGet(Segment, 0, Block, BlockLen);
DosFree(Selector);
{$ENDIF}
end; { proc. TFossilObj.Com_SendBlock }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function TFossilObj.Com_CharAvail: Boolean;
begin
Regs.AH := $03;
Regs.DX := FosPort;
FossilIntr(Regs);
Com_CharAvail := (Regs.AH AND 01) <> 00;
end; { func. TFossilObj.Com_CharAvail }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function TFossilObj.Com_ReadyToSend(BlockLen: Longint): Boolean;
begin
Regs.AH := $03;
Regs.DX := FosPort;
FossilIntr(Regs);
Com_ReadyToSend := (Regs.AH AND $20) = $20;
end; { func. TFossilObj.Com_ReadyToSend }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function TFossilObj.Com_Carrier: Boolean;
begin
Regs.AH := $03;
Regs.DX := FosPort;
FossilIntr(Regs);
Com_Carrier := (Regs.AL AND 128) <> 00;
end; { func. TFossilObj.Com_Carrier }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TFossilObj.Com_SetDtr(State: Boolean);
begin
Regs.AH := $06;
Regs.AL := Byte(State);
Regs.DX := Fosport;
FossilIntr(Regs);
end; { proc. TFossilObj.Com_SetDtr }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TFossilObj.Com_GetModemStatus(var LineStatus, ModemStatus: Byte);
begin
Regs.AH := $03;
Regs.DX := FosPort;
FossilIntr(Regs);
ModemStatus := Regs.AL;
LineStatus := Regs.AH;
end; { proc. TFossilObj.Com_GetModemStatus }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TFossilObj.Com_GetBufferStatus(var InFree, OutFree, InUsed, OutUsed: Longint);
type
FosRec = record
Size : Word;
Spec : Byte;
Rev : Byte;
ID : Pointer;
InSize : Word;
InFree : Word;
OutSize : Word;
OutFree : Word;
SWidth : Byte;
SHeight : Byte;
BaudMask : Byte;
Junk : Word;
end;
var Com_Info: FosRec;
Selector,
Segment : Word;
begin
{$IFDEF MSDOS}
Regs.AH := $1B;
Regs.DX := FosPort;
Regs.ES := Seg(Com_Info);
Regs.DI := Ofs(Com_Info);
Regs.CX := SizeOf(Com_Info);
{$ENDIF}
{$IFDEF GO32V2}
DosAlloc(Selector, Segment, SizeOf(Com_Info));
if Int31Error <> 0 then EXIT;
DosmemPut(Segment, 0, Com_Info, SizeOf(Com_Info));
Regs.AH := $1B;
Regs.DX := FosPort;
Regs.ES := Segment;
Regs.DI := 0;
Regs.CX := SizeOf(Com_Info);
FossilIntr(Regs);
DosMemGet(Segment, 0, Com_Info, SizeOf(Com_Info));
DosFree(Selector);
{$ENDIF}
FossilIntr(Regs);
InFree := Com_Info.InFree;
InUsed := Com_Info.InSize - Com_Info.InFree;
OutFree := Com_Info.OutFree;
OutUsed := Com_Info.OutSize - Com_Info.OutFree;
end; { proc. TFossilObj.Com_GetBufferStatus }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function TFossilObj.Com_GetDriverInfo: String;
type
FosRec = record
Size : Word;
Spec : Byte;
Rev : Byte;
ID : PChar;
InSize : Word;
InFree : Word;
OutSize : Word;
OutFree : Word;
SWidth : Byte;
SHeight : Byte;
BaudMask : Byte;
Junk : Word;
end;
var Com_Info: FosRec;
Segment,
Selector: Word;
begin
FillChar(Com_Info, SizeOf(FosRec), #00);
{$IFDEF MSDOS}
Regs.AH := $1B;
Regs.DX := FosPort;
Regs.ES := Seg(Com_Info);
Regs.DI := Ofs(Com_Info);
Regs.CX := SizeOf(Com_Info);
{$ENDIF}
{$IFDEF GO32V2}
DosAlloc(Selector, Segment, SizeOf(Com_Info));
if Int31Error <> 0 then EXIT;
DosmemPut(Segment, 0, Com_Info, SizeOf(Com_Info));
Regs.AH := $1B;
Regs.DX := FosPort;
Regs.ES := Segment;
Regs.DI := 0;
Regs.CX := SizeOf(Com_Info);
FossilIntr(Regs);
DosMemGet(Segment, 0, Com_Info, SizeOf(Com_Info));
DosFree(Selector);
{$ENDIF}
FossilIntr(Regs);
Com_GetDriverInfo := StrPas(Com_Info.ID);
end; { proc. TFossilObj.Com_GetDriverInfo }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TFossilObj.Com_PurgeInBuffer;
begin
Regs.AH := $0A;
Regs.DX := FosPort;
FossilIntr(Regs);
end; { proc. TFossilObj.Com_PurgeInBuffer }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TFossilObj.Com_PurgeOutBuffer;
begin
Regs.AH := $09;
Regs.DX := FosPort;
FossilIntr(Regs);
end; { proc. TFossilObj.Com_PurgeOutBuffer }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function TFossilObj.Com_GetHandle: longint;
begin
Com_GetHandle := FosPort;
end; { func. Com_GetHandle }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TFossilObj.Com_SendWait(var Block; BlockLen: Longint; var Written: Longint; Slice: SliceProc);
var RestLen : Longint;
Temp : Array[0..(1024 * 50)] of Char ABSOLUTE Block;
MaxTries: Longint;
begin
RestLen := BlockLen;
MaxTries := (Com_GetBpsRate div 8);
repeat
Com_SendBlock(Temp[BlockLen - RestLen], RestLen, Written);
Dec(RestLen, Written);
Dec(MaxTries);
if RestLen <> 0 then
if @Slice <> nil then
Slice;
until (RestLen <= 0) OR (NOT COM_Carrier) OR (MaxTries < 0);
Written := (BlockLen - RestLen);
end; { proc. Com_SendWait }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TFossilObj.Com_SetFlow(SoftTX, SoftRX, Hard: Boolean);
begin
Regs.AH := $0F;
if SoftTX then
Regs.AL := $01
else Regs.AL := $00;
if SoftRX then
Regs.AL := Regs.AL OR $08;
if Hard then
Regs.AL := Regs.AL OR $02;
Regs.DX := FosPort;
FossilIntr(Regs);
end; { proc. Com_SetFlow }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
end.

19
SOURCE/ELECOM/HISTORY.102 Normal file
View File

@ -0,0 +1,19 @@
WHATSNEW
========
30 July 2000 : Initial DoRxEvent and DoTxEvent were set in true state
which could cause initial very high CPU usage.
18 June 2000 : Changed the way EleCOM calls it threaded functions, making
EleCOM useful for applications where more than one comport
has to be controlled at a time.
20 February 2000 : W32SNGL.PAS or WIN32COM.PAS now include WINDEF.FPC if
compiled with the FPC compiler. This include file redefines
(some) of the Win32 API calls to make sure they are the
correct calling format for us (= the same as with Delphi
and VirtualPascal)
09 September 1999: W32SNGL.PAS - Reduced the number of threads used by this
engine. This one works better on Win9x systems.
05 September 1999: TELNET.PAS added some extra error information to make sure
errors can be more easily diagnosed.
29 August 1999 : ELENORM.PAS - "Plain, vanilly" Pascal version you can use
as a wrapper around the OOP code.

24
SOURCE/ELECOM/HISTORY.103 Normal file
View File

@ -0,0 +1,24 @@
WHATSNEW
========
16 June 2002 : Added a very small state machine to the IAC parser of the
telnet code, to prevent misses of IAC's on the last
character of the buffer.
23 December 2000 : Increased buffersizes that Win32 allocates for in/out
communications. It now uses 3k, instead of 256 bytes.
30 July 2000 : Initial DoRxEvent and DoTxEvent were set in true state
which could cause initial very high CPU usage.
18 June 2000 : Changed the way EleCOM calls it threaded functions, making
EleCOM useful for applications where more than one comport
has to be controlled at a time.
20 February 2000 : W32SNGL.PAS or WIN32COM.PAS now include WINDEF.FPC if
compiled with the FPC compiler. This include file redefines
(some) of the Win32 API calls to make sure they are the
correct calling format for us (= the same as with Delphi
and VirtualPascal)
09 September 1999: W32SNGL.PAS - Reduced the number of threads used by this
engine. This one works better on Win9x systems.
05 September 1999: TELNET.PAS added some extra error information to make sure
errors can be more easily diagnosed.
29 August 1999 : ELENORM.PAS - "Plain, vanilly" Pascal version you can use
as a wrapper around the OOP code.

113
SOURCE/ELECOM/IBMSO32.PAS Normal file
View File

@ -0,0 +1,113 @@
unit IBMSO32;
{$OrgName+ }
interface
uses OS2Def;
{$CDECL+}
(****************************************************************************)
function IBM_accept(SFamily: ULong;
SAddr: pointer;
SAddrL: pointer): APIRET;
(****************************************************************************)
function IBM_bind(SSocket: ULong;
SAddr: pointer;
SAddrLen: ULong): APIRET;
(****************************************************************************)
function IBM_connect(SSocket: ULong;
SAddr: pointer;
SAddrLen:ULong): APIRET;
(****************************************************************************)
function IBM_gethostid: APIRET;
(****************************************************************************)
function IBM_select( Sockets: pointer;
noreads, nowrites, noexcepts: longint;
timeout: longint ): ApiRet;
(****************************************************************************)
function IBM_getsockname(SSocket: ULong;
SName: pointer;
SLength: pointer): APIRET;
(****************************************************************************)
function IBM_ioctl(SSocket: ULong;
SRequest: longint;
SArgp: pointer;
ArgSize: longint): APIRET;
(****************************************************************************)
function IBM_listen(SSocket: ULong;
SQueue: ULong): APIRET;
(****************************************************************************)
function IBM_getsockopt(SSocket: uLong;
sLevel: LongInt;
sOptname: LongInt;
sOptVal: pchar;
var sOptLen: LongInt ): ApiRet;
(****************************************************************************)
FUNCTION IBM_setsockopt(sSocket: ulong;
sLevel: uLong;
sOptName: uLong;
sOptVal: pointer;
sOptLen: uLong ): ApiRet;
(****************************************************************************)
function IBM_recv(SSocket: ULong;
SBuffer: pointer;
SLength: ULong;
SFlags: ULong): APIRET;
(****************************************************************************)
function IBM_send(SSocket: ULong;
SBuffer: pointer;
SLength: ULong;
SFlags: ULong): APIRET;
(****************************************************************************)
function IBM_socket(SDomain: ULong;
SType: ULong;
SProtocol: ULong): APIRET;
(****************************************************************************)
function IBM_soclose(SProtocol: ULong): APIRET;
(****************************************************************************)
function IBM_sock_errno: APIRET;
(****************************************************************************)
function IBM_shutdown(SSocket: ULong;
SFlags: ULong): APIRET;
(****************************************************************************)
function IBM_sock_init: APIRET;
(****************************************************************************)
function IBM_so_cancel(SProtocol: ULong): APIRET;
(****************************************************************************)
{$CDECL-}
implementation
const
Version = '00.90';
UseString: string = '@(#)import interface unit for IBM TCP/IP so32dll.dll'+#0;
CopyRight1: string = '@(#)ibmso32dll Version '+Version+' - 10.10.96'+#0;
CopyRight2: string = '@(#)(C) Chr.Hohmann BfS ST2.2 1996'+#0;
const
sockets = 'SO32DLL';
network = 'TCP32DLL';
{$CDECL+}
function IBM_accept; external sockets index 1;
function IBM_bind; external sockets index 2;
function IBM_connect; external sockets index 3;
function IBM_gethostid; external sockets index 4;
function IBM_getsockname; external sockets index 6;
function IBM_ioctl; external sockets index 8;
function IBM_listen; external sockets index 9;
function IBM_recv; external sockets index 10;
function IBM_send; external sockets index 13;
function IBM_socket; external sockets index 16;
function IBM_soclose; external sockets index 17;
function IBM_sock_errno; external sockets index 20;
function IBM_shutdown; external sockets index 25;
function IBM_sock_init; external sockets index 26;
function IBM_so_cancel; external sockets index 18;
function IBM_getsockopt; external sockets index 7;
function IBM_setsockopt; external sockets index 15;
function IBM_select; external sockets index 12;
{$CDECL-}
end.

53
SOURCE/ELECOM/IBMTCP32.PAS Normal file
View File

@ -0,0 +1,53 @@
unit IBMTCP32;
{$OrgName+ }
interface
uses OS2Def, SockDef;
{$CDECL+}
(****************************************************************************)
function IBM_gethostbyname(HName: pointer): pointer;
(****************************************************************************)
function IBM_gethostbyaddr(HAddr: pointer;
HAddrLen: longint;
HAddrType: ULong): pointer;
(****************************************************************************)
function IBM_gethostname(HName: pointer;
HLength:ULong): APIRET;
(****************************************************************************)
function IBM_getservbyname(_Name, _Proto: pChar): pServEnt;
function inet_addr(_s: pChar): ULONG;
function getprotobyname(_Name: pChar): pProtoEnt;
function htonl(_a: LongInt): LongInt;
function ntohl(_a: LongInt): LongInt;
{ function htons(_a: LongInt): LongInt; }
{ function ntohs(_a: SmallInt): SmallInt; }
{$CDECL-}
implementation
const
Version = '00.90';
UseString: string = '@(#)import interface unit for IBM TCP/IP tcp32dll.dll'+#0;
CopyRight1: string = '@(#)ibmTCP32 Version '+Version+' - 10.10.96'+#0;
CopyRight2: string = '@(#)(C) Chr.Hohmann BfS ST2.2 1996'+#0;
const
sockets = 'SO32DLL';
network = 'TCP32DLL';
{$CDECL+}
function inet_addr; external network index 5;
function IBM_gethostbyname; external network index 11;
function IBM_gethostbyaddr; external network index 12;
function IBM_gethostname; external network index 44;
function getprotobyname; external network index 21;
function IBM_getservbyname; external network index 24;
function htonl; external network index 3;
function ntohl; external network index 3;
{$CDECL-}
end.

786
SOURCE/ELECOM/OS2COM.PAS Normal file
View File

@ -0,0 +1,786 @@
unit OS2COM;
(*
**
** Serial and TCP/IP communication routines for DOS, OS/2 and Win9x/NT.
** Tested with: TurboPascal v7.0, (DOS)
** VirtualPascal v2.1, (OS/2, Win32)
** FreePascal v0.99.12 (DOS, Win32)
** Delphi v4.0. (Win32)
**
** Version : 1.01
** Created : 21-May-1998
** Last update : 12-May-1999
**
** Note: (c) 1998-1999 by Maarten Bekers
**
*)
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
INTERFACE
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
uses Combase, BufUnit, Threads,
{$IFDEF OS2}
Os2Base
{$ENDIF}
{$IFDEF VirtualPascal}
,Use32
{$ENDIF};
Const WriteTimeout = 20000; { Wait max. 20 secs }
ReadTimeOut = 5000; { General event, 5 secs max }
InBufSize = 1024 * 32;
OutBufSize = 1024 * 32;
type TOs2Obj = Object(TCommObj)
ReadProcPtr: Pointer; { Pointer to TX/RX handler (thread) }
WriteProcPtr: Pointer; { Pointer to TX/RX handler (thread) }
ThreadsInitted: Boolean; { Are the thread(s) up and running? }
ClientHandle : Longint;
InBuffer : ^BufArrayObj; { Buffer system internally used }
OutBuffer : ^BufArrayObj;
DoTxEvent : PSysEventObj; { Event manually set when we have to transmit }
DoRxEvent : PSysEventObj; { Event manually set when we need data }
TxClosedEvent : PSysEventObj; { Event set when the Tx thread is closed }
RxClosedEvent : PSysEventObj; { Event set when the Rx thread is closed }
CriticalTx : PExclusiveObj; { Critical sections }
CriticalRx : PExclusiveObj;
TxThread : PThreadsObj; { The Transmit and Receive threads }
RxThread : PThreadsObj;
EndThreads : Boolean; { Set to true when we have to end the threads }
constructor Init;
destructor Done;
function Com_Open(Comport: Byte; BaudRate: Longint; DataBits: Byte;
Parity: Char; StopBits: Byte): Boolean; virtual;
function Com_OpenKeep(Comport: Byte): Boolean; virtual;
function Com_GetChar: Char; virtual;
function Com_CharAvail: Boolean; virtual;
function Com_Carrier: Boolean; virtual;
function Com_SendChar(C: Char): Boolean; virtual;
function Com_ReadyToSend(BlockLen: Longint): Boolean; virtual;
function Com_GetBPSrate: Longint; virtual;
function Com_GetHandle: Longint; virtual;
procedure Com_OpenQuick(Handle: Longint); virtual;
procedure Com_Close; virtual;
procedure Com_SendBlock(var Block; BlockLen: Longint; var Written: Longint); virtual;
procedure Com_ReadBlock(var Block; BlockLen: Longint; var Reads: Longint); virtual;
procedure Com_GetBufferStatus(var InFree, OutFree, InUsed, OutUsed: Longint); virtual;
procedure Com_SetDtr(State: Boolean); virtual;
procedure Com_GetModemStatus(var LineStatus, ModemStatus: Byte); virtual;
procedure Com_SetLine(BpsRate: longint; Parity: Char; DataBits, Stopbits: Byte); virtual;
procedure Com_PurgeInBuffer; virtual;
procedure Com_PurgeOutBuffer; virtual;
procedure Com_FlushOutBuffer(Slice: SliceProc); virtual;
procedure Com_PauseCom(CloseCom: Boolean); virtual;
procedure Com_ResumeCom(OpenCom: Boolean); virtual;
procedure Com_SetFlow(SoftTX, SoftRX, Hard: Boolean); virtual;
procedure Com_SetDataProc(ReadPtr, WritePtr: Pointer); virtual;
procedure Com_ReadProc(var TempPtr: Pointer);
procedure Com_WriteProc(var TempPtr: Pointer);
function Com_StartThread: Boolean;
procedure Com_InitVars;
procedure Com_StopThread;
end; { object TOs2Obj }
Type POs2Obj = ^TOs2Obj;
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
IMPLEMENTATION
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
uses SysUtils;
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
constructor TOs2Obj.Init;
begin
inherited Init;
Com_InitVars;
ThreadsInitted := FALSE;
end; { constructor Init }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
destructor TOs2Obj.Done;
begin
inherited done;
end; { destructor Done }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TOs2Obj.Com_ReadProc(var TempPtr: Pointer);
Type TBuffRec = Record
BytesIn : SmallWord; { Number of bytes in the buffer }
MaxSize : SmallWord; { Full size of the buffer }
end; { TBuffRec }
var Available : Boolean;
BytesRead : Longint;
BlockLen : Longint;
ReturnCode: Longint;
BufferRec : TBuffRec;
begin
repeat
if DoRxEvent.WaitForEvent(ReadTimeOut) then
if NOT EndThreads then
begin
CriticalRx.EnterExclusive;
ReturnCode := 0;
DosDevIoCtl(ClientHandle, { File-handle }
ioctl_Async, { Category }
async_GetInQueCount, { Function }
nil, { Params }
ReturnCode, { Max param length }
@ReturnCode, { Param Length }
@BufferRec, { Returned data }
SizeOf(TBuffRec), { Max data length }
@ReturnCode); { Data length }
Available := (BufferRec.BytesIn > 00);
DoRxEvent.ResetEvent;
if Available then
begin
{----------- Start reading the gathered date -------------------}
if InBuffer^.BufRoom > 0 then
begin
BlockLen := BufferRec.BytesIn;
if BlockLen > InBuffer^.BufRoom then
BlockLen := InBuffer^.BufRoom;
if BlockLen > 1024 then
BlockLen := 1024;
if BlockLen > 00 then
begin
DosRead(ClientHandle,
InBuffer^.TmpBuf,
BlockLen,
BytesRead);
InBuffer^.Put(InBuffer^.TmpBuf, BytesRead);
end; { if }
end; { if }
end; { if available }
CriticalRx.LeaveExclusive;
end; { if RxEvent }
until EndThreads;
RxClosedEvent.SignalEvent;
ExitThisThread;
end; { proc. ComReadProc }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TOs2Obj.Com_WriteProc(var TempPtr: Pointer);
var BlockLen : Longint;
Written : Longint;
ReturnCode : Longint;
TempBuf : ^CharBufType;
begin
New(TempBuf);
repeat
if DoTxEvent.WaitForEvent(WriteTimeOut) then
if NOT EndThreads then
begin
CriticalTx.EnterExclusive;
DoTxEvent.ResetEvent;
if OutBuffer^.BufUsed > 00 then
begin
Written := 00;
BlockLen := OutBuffer^.Get(OutBuffer^.TmpBuf, OutBuffer^.BufUsed, false);
DosWrite(ClientHandle,
OutBuffer^.TmpBuf,
BlockLen,
Written);
ReturnCode := OutBuffer^.Get(OutBuffer^.TmpBuf, Written, true);
if Written <> BlockLen then
DoTxEvent.SignalEvent;
end; { if }
CriticalTx.LeaveExclusive;
end; { if }
until EndThreads;
Dispose(TempBuf);
TxClosedEvent.SignalEvent;
ExitThisThread;
end; { proc. ComWriteProc }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function TOs2Obj.Com_StartThread: Boolean;
begin
Result := false;
EndThreads := false;
if ThreadsInitted then EXIT;
ThreadsInitted := true;
{----------------------- Create all the events ----------------------------}
New(DoTxEvent, Init);
if NOT DoTxEvent.CreateEvent(false) then EXIT;
New(DoRxEvent, Init);
if NOT DoRxEvent.CreateEvent(false) then EXIT;
New(RxClosedEvent, Init);
if NOT RxClosedEvent.CreateEvent(false) then EXIT;
New(TxClosedEvent, Init);
if NOT TxClosedEvent.CreateEvent(false) then EXIT;
{-------------- Startup the buffers and overlapped events -----------------}
New(InBuffer, Init(InBufSize));
New(OutBuffer, Init(OutBufSize));
{-------------------- Startup a seperate write thread ---------------------}
New(CriticalTx, Init);
CriticalTx.CreateExclusive;
New(TxThread, Init);
if NOT TxThread.CreateThread(16384, { Stack size }
WriteProcPtr, { Actual procedure }
nil, { Parameters }
0) { Creation flags }
then EXIT;
{-------------------- Startup a seperate read thread ----------------------}
New(CriticalRx, Init);
CriticalRx.CreateExclusive;
New(RxThread, Init);
if NOT RxThread.CreateThread(16384, { Stack size }
ReadProcPtr, { Actual procedure }
nil, { Parameters }
0) { Creation flags }
then EXIT;
Result := true;
end; { proc. Com_StartThread }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TOs2Obj.Com_InitVars;
begin
DoTxEvent := nil;
DoRxEvent := nil;
RxClosedEvent := nil;
TxClosedEvent := nil;
TxThread := nil;
RxThread := nil;
InBuffer := nil;
OutBuffer := nil;
CriticalRx := nil;
CriticalTx := nil;
end; { proc. Com_InitVars }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TOs2Obj.Com_StopThread;
begin
EndThreads := true;
ThreadsInitted := false;
if DoTxEvent <> nil then DoTxEvent.SignalEvent;
if DoTxEvent <> nil then DoRxEvent.SignalEvent;
if TxThread <> nil then TxThread.CloseThread;
if RxThread <> nil then RxThread.CloseThread;
if TxClosedEvent <> nil then
if NOT TxClosedEvent^.WaitForEvent(1000) then
TxThread.TerminateThread(0);
if RxClosedEvent <> nil then
if NOT RxClosedEvent^.WaitForEvent(1000) then
RxThread.TerminateThread(0);
if TxThread <> nil then TxThread.Done;
if RxThread <> nil then RxThread.Done;
if DoTxEvent <> nil then Dispose(DoTxEvent, Done);
if DoRxEvent <> nil then Dispose(DoRxEvent, Done);
if RxClosedEvent <> nil then Dispose(RxClosedEvent, Done);
if TxClosedEvent <> nil then Dispose(TxClosedEvent, Done);
if CriticalTx <> nil then Dispose(CriticalTx, Done);
if CriticalRx <> nil then Dispose(CriticalRx, Done);
if InBuffer <> nil then Dispose(InBuffer, Done);
if OutBuffer <> nil then Dispose(OutBuffer, Done);
Com_InitVars;
end; { proc. Com_StopThread }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function TOs2Obj.Com_GetHandle: Longint;
begin
Result := ClientHandle;
end; { func. Com_GetHandle }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TOs2Obj.Com_OpenQuick(Handle: Longint);
begin
ClientHandle := Handle;
InitFailed := NOT Com_StartThread;
end; { proc. TOs2Obj.Com_OpenQuick }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function TOs2Obj.Com_OpenKeep(Comport: Byte): Boolean;
var ReturnCode: Longint;
OpenAction: Longint;
Temp : Array[0..15] of Char;
begin
InitFailed := NOT Com_StartThread;
if NOT InitFailed then
begin
OpenAction := file_Open;
StrpCopy(Temp, 'COM' + IntToStr(ComPort));
ReturnCode :=
DosOpen(Temp, { Filename, eg: COM2 }
ClientHandle,
OpenAction,
0, { Filesize }
0, { Attributes }
FILE_OPEN or OPEN_ACTION_OPEN_IF_EXISTS, { Open flags }
OPEN_ACCESS_READWRITE or OPEN_SHARE_DENYNONE or { OpenMode }
OPEN_FLAGS_FAIL_ON_ERROR,
nil); { Extended attributes }
InitFailed := (ReturnCode <> 0);
end; { if }
Com_OpenKeep := NOT InitFailed;
end; { func. Com_OpenKeep }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function TOs2Obj.Com_Open(Comport: Byte; BaudRate: Longint; DataBits: Byte;
Parity: Char; StopBits: Byte): Boolean;
begin
InitFailed := true;
if Com_OpenKeep(Comport) then
begin
Com_SetLine(BaudRate, Parity, DataBits, StopBits);
InitFailed := false;
end; { if }
Com_Open := NOT InitFailed;
end; { func. TOs2Obj.Com_OpenCom }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TOs2Obj.Com_SetLine(BpsRate: longint; Parity: Char; DataBits, Stopbits: Byte);
type TBpsRec = Record
Rate : Longint;
Frac : Byte;
end; { record }
var TempRec : Array[1..3] of Byte;
BpsRec : TBpsRec;
RetLength : Longint;
Temp_Parity : Byte;
Temp_StopBits: Byte;
begin
if NOT (DataBits in [5,7,8]) then DataBits := 8;
if NOT (Parity in ['O', 'E', 'N', 'M', 'S']) then Parity := 'N';
if NOT (StopBits in [0..2]) then StopBits := 1;
Temp_Parity := 00;
Case Parity of
'N' : Temp_Parity := 00;
'O' : Temp_Parity := 01;
'E' : Temp_Parity := 02;
'M' : Temp_Parity := 03;
'S' : Temp_Parity := 04;
end; { case }
Temp_Stopbits := 00;
Case StopBits of
1 : StopBits := 0;
2 : StopBits := 2;
end; { case }
Fillchar(TempRec, SizeOf(TempRec), 00);
TempRec[01] := DataBits;
TempRec[02] := Temp_Parity;
TempRec[03] := Temp_StopBits;
{------------------------- Set line parameters ----------------------------}
DosDevIoCtl(ClientHandle, { File-handle }
ioctl_Async, { Category }
async_SetLineCtrl, { Function }
@TempRec, { Params }
SizeOf(TempRec), { Max param length }
@RetLength, { Param Length }
@TempRec, { Returned data }
SizeOf(TempRec), { Max data length }
@RetLength); { Data length }
{------------------------- Set speed parameters ---------------------------}
BpsRec.Rate := BpsRate;
BpsRec.Frac := 00;
DosDevIoCtl(ClientHandle, { File-handle }
ioctl_Async, { Category }
async_ExtSetBaudRate, { Function }
@BpsRec, { Params }
SizeOf(BpsRec), { Max param length }
@RetLength, { Param Length }
@BpsRec, { Returned data }
SizeOf(BpsRec), { Max data length }
@RetLength); { Data length }
end; { proc. TOs2Obj.Com_SetLine }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TOs2Obj.Com_Close;
begin
if DontClose then EXIT;
if ClientHandle <> -1 then
begin
Com_StopThread;
DosClose(ClientHandle);
ClientHandle := -1;
end; { if }
end; { func. TOs2Obj.Com_CloseCom }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function TOs2Obj.Com_SendChar(C: Char): Boolean;
var Written: Longint;
begin
Com_SendBlock(C, SizeOf(C), Written);
Com_SendChar := (Written = SizeOf(c));
end; { proc. TOs2Obj.Com_SendChar }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function TOs2Obj.Com_GetChar: Char;
var Reads: Longint;
begin
Com_ReadBlock(Result, SizeOf(Result), Reads);
end; { func. TOs2Obj.Com_GetChar }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TOs2Obj.Com_SendBlock(var Block; BlockLen: Longint; var Written: Longint);
begin
if OutBuffer^.BufRoom < BlockLen then
repeat
{$IFDEF OS2}
DosSleep(1);
{$ENDIF}
until (OutBuffer^.BufRoom >= BlockLen) OR (NOT Com_Carrier);
CriticalTx.EnterExclusive;
Written := OutBuffer^.Put(Block, BlockLen);
CriticalTx.LeaveExclusive;
DoTxEvent.SignalEvent;
end; { proc. TOs2Obj.Com_SendBlock }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TOs2Obj.Com_ReadBlock(var Block; BlockLen: Longint; var Reads: Longint);
begin
if InBuffer^.BufUsed < BlockLen then
begin
repeat
if Com_CharAvail then
DoRxEvent.SignalEvent;
DosSleep(1);
until (InBuffer^.BufUsed >= BlockLen) OR (NOT Com_Carrier);
end; { if }
CriticalRx.EnterExclusive;
Reads := InBuffer^.Get(Block, BlockLen, true);
CriticalRx.LeaveExclusive;
end; { proc. TOs2Obj.Com_ReadBlock }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function TOs2Obj.Com_CharAvail: Boolean;
Type TBuffRec = Record
BytesIn : SmallWord; { Number of bytes in the buffer }
MaxSize : SmallWord; { Full size of the buffer }
end; { TBuffRec }
var ReturnCode: Longint;
BufferRec : TBuffRec;
begin
if InBuffer^.BufUsed < 1 then
begin
ReturnCode := 0;
DosDevIoCtl(ClientHandle, { File-handle }
ioctl_Async, { Category }
async_GetInQueCount, { Function }
nil, { Params }
ReturnCode, { Max param length }
@ReturnCode, { Param Length }
@BufferRec, { Returned data }
SizeOf(TBuffRec), { Max data length }
@ReturnCode); { Data length }
if (BufferRec.BytesIn > 0) then
DoRxEvent.SignalEvent;
end; { if }
Result := (InBuffer^.BufUsed > 0);
end; { func. TOs2Obj.Com_CharAvail }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function TOs2Obj.Com_Carrier: Boolean;
var Status : Byte;
RetLength : Longint;
begin
DosDevIoCtl(ClientHandle, { File-handle }
ioctl_Async, { Category }
async_GetModemInput, { Function }
nil, { Params }
00, { Max param length }
@RetLength, { Param Length }
@Status, { Returned data }
SizeOf(Status), { Max data length }
@RetLength); { Data length }
Com_Carrier := Status AND 128 <> 00;
end; { func. TOs2Obj.Com_Carrier }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TOs2Obj.Com_GetModemStatus(var LineStatus, ModemStatus: Byte);
begin
LineStatus := 00;
ModemStatus := 08;
if Com_Carrier then ModemStatus := ModemStatus OR (1 SHL 7);
end; { proc. TOs2Obj.Com_GetModemStatus }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TOs2Obj.Com_SetDtr(State: Boolean);
type
TRtsDtrRec = record
Onmask,
Offmask : Byte;
end; { record }
var MaskRec : TRtsDtrRec;
RetLength : Longint;
begin
if State then
begin
MaskRec.OnMask := $01;
MaskRec.OffMask := $FF;
end
else begin
MaskRec.OnMask := $00;
MaskRec.OffMask := $FE;
end; { if }
DosDevIoCtl(ClientHandle, { File-handle }
ioctl_Async, { Category }
async_SetModemCtrl, { Function }
@MaskRec, { Params }
SizeOf(MaskRec), { Max param length }
@RetLength, { Param Length }
@MaskRec, { Returned data }
SizeOf(MaskRec), { Max data length }
@RetLength); { Data length }
end; { proc. TOs2Obj.Com_SetDtr }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function TOs2Obj.Com_GetBpsRate: Longint;
type
TBpsRec = record
CurBaud : Longint; { Current BaudRate }
CurFrac : Byte; { Current Fraction }
MinBaud : Longint; { Minimum BaudRate }
MinFrac : Byte; { Minimum Fraction }
MaxBaud : Longint; { Maximum BaudRate }
MaxFrac : Byte; { Maximum Fraction }
end; { TBpsRec }
var BpsRec : TBpsRec;
Status : Byte;
RetLength: Longint;
begin
DosDevIoCtl(ClientHandle, { File-handle }
ioctl_Async, { Category }
async_ExtGetBaudRate, { Function }
nil, { Params }
00, { Max param length }
@RetLength, { Param Length }
@BpsRec, { Returned data }
SizeOf(BpsRec), { Max data length }
@RetLength); { Data length }
Com_GetBpsRate := BpsRec.CurBaud;
end; { func. TOs2Obj.Com_GetBpsRate }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TOs2Obj.Com_GetBufferStatus(var InFree, OutFree, InUsed, OutUsed: Longint);
begin
DoRxEvent.SignalEvent;
DoTxEvent.SignalEvent;
InFree := InBuffer^.BufRoom;
OutFree := OutBuffer^.BufRoom;
InUsed := InBuffer^.BufUsed;
OutUsed := OutBuffer^.BufUsed;
end; { proc. TOs2Obj.Com_GetBufferStatus }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TOs2Obj.Com_PurgeInBuffer;
begin
CriticalRx.EnterExclusive;
InBuffer^.Clear;
CriticalRx.LeaveExclusive;
end; { proc. TOs2Obj.Com_PurgeInBuffer }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TOs2Obj.Com_PurgeOutBuffer;
begin
CriticalTx.EnterExclusive;
OutBuffer^.Clear;
CriticalTx.LeaveExclusive;
end; { proc. TOs2Obj.Com_PurgeInBuffer }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TOs2Obj.Com_FlushOutBuffer(Slice: SliceProc);
begin
DosResetBuffer(ClientHandle);
inherited Com_FlushOutBuffer(Slice);
end; { proc. Com_FlushOutBuffer }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function TOs2Obj.Com_ReadyToSend(BlockLen: Longint): Boolean;
begin
Result := OutBuffer^.BufRoom >= BlockLen;
end; { func. ReadyToSend }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TOs2Obj.Com_PauseCom(CloseCom: Boolean);
begin
if CloseCom then Com_Close
else Com_StopThread;
end; { proc. Com_PauseCom }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TOs2Obj.Com_ResumeCom(OpenCom: Boolean);
begin
if OpenCom then Com_OpenKeep(0)
else Com_StartThread;
end; { proc. Com_ResumeCom }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TOs2Obj.Com_SetFlow(SoftTX, SoftRX, Hard: Boolean);
var Dcb : DCBINFO;
RetLength: Longint;
begin
FillChar(Dcb, SizeOF(Dcb), 0);
DosDevIoCtl(ClientHandle, { File-handle }
ioctl_Async, { Category }
async_GetDcbInfo, { Function }
nil, { Params }
00, { Max param length }
@RetLength, { Param Length }
@Dcb, { Returned data }
SizeOf(DcbInfo), { Max data length }
@RetLength); { Data length }
if (SoftTX) or (SoftRX) then
begin
dcb.fbFlowReplace := dcb.fbFlowReplace + MODE_AUTO_RECEIVE + MODE_AUTO_TRANSMIT;
end
else begin
dcb.fbFlowReplace := MODE_RTS_HANDSHAKE;
dcb.fbCtlHndShake := dcb.fbCtlHndShake + MODE_CTS_HANDSHAKE;
end; { if }
dcb.fbTimeout := MODE_NO_WRITE_TIMEOUT + MODE_WAIT_READ_TIMEOUT;
dcb.bXONChar := $11;
dcb.bXOFFChar := $13;
RetLength := SizeOf(DcbInfo);
DosDevIoCtl(ClientHandle, { File-handle }
ioctl_Async, { Category }
async_SetDcbInfo, { Function }
@Dcb, { Params }
SizeOf(DcbInfo), { Max param length }
@RetLength, { Param Length }
nil, { Returned data }
RetLength, { Max data length }
@RetLength); { Data length }
end; { proc. Com_SetFlow }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TOs2Obj.Com_SetDataProc(ReadPtr, WritePtr: Pointer);
begin
ReadProcPtr := ReadPtr;
WriteProcPtr := WritePtr;
end; { proc. Com_SetDataProc }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
end.

109
SOURCE/ELECOM/PROCS.TXT Normal file
View File

@ -0,0 +1,109 @@
Procedure overview
==================
+---------------------+---------------+----------------------------------------+
| Name | Parameters | Explanation |
+---------------------+---------------+----------------------------------------+
| Com_OpenQuick | | Open the comport without init. |
| | Handle | Use these two handles for quickinit |
+------------------------------------------------------------------------------+
| Com_Open | | Opens the connection and set params |
| | Comport | Comport to open (COM1 = 1) |
| | BaudRate | |
| | DataBits, | |
| | Parity | |
| | StopBits | |
+------------------------------------------------------------------------------+
| Com_Openkeep | | Open the comport without setting params|
| | Comport | |
+------------------------------------------------------------------------------+
| Com_GetModemStatus | | Get the line/modem parameters |
| | LineStatus | |
| | ModemStatus | |
+------------------------------------------------------------------------------+
| Com_SetLine | | Set the comm. parameters |
| | BPSrate | |
| | Parity | |
| | DataBits | |
| | StopBits | |
+------------------------------------------------------------------------------+
| Com_GetBPSrate | | Returns the current line-speed |
| | | |
+------------------------------------------------------------------------------+
| Com_GetBufferStatus | | Get the current buffer statusses |
| | InFree | Bytes free in input buffer |
| | OutFree | Bytes free in output buffer |
| | InUsed | Bytes currently used in input buffer |
| | OutUsed | Bytes currently used in output buffer |
+------------------------------------------------------------------------------+
| Com_SetDTR | | Set DTR setting |
| | State |
+------------------------------------------------------------------------------+
| Com_CharAvail | | Returns TRUE if there's a char avail. |
| | | |
+------------------------------------------------------------------------------+
| Com_Carrier | | Returns TRUE if the DTR signal is high |
| | | |
+------------------------------------------------------------------------------+
| Com_ReadyToSend | | Room enough for this block? |
| | Blocklen | Number of bytes we want to send |
+------------------------------------------------------------------------------+
| Com_GetChar | | Get one character from the input buffer|
| | | |
+------------------------------------------------------------------------------+
| Com_SendChar | | Send one character to the remote |
| | | |
+------------------------------------------------------------------------------+
| Com_GetDriverInfo | | Returns the driver info (FOSSIL only) |
| | | |
+------------------------------------------------------------------------------+
| Com_GetHandle | | Get the current used handle |
| | | |
+------------------------------------------------------------------------------+
| Com_InitSucceeded | | Returns TRUE if the initialization |
| | | succeeded |
+------------------------------------------------------------------------------+
| Com_Close | | Closes the comport and stop the |
| | | threads |
+------------------------------------------------------------------------------+
| Com_SendBlock | | Sends a block to the remote. |
| | Block | Warning: Make sure that the block you |
| | BlockLen | send isn't larger than the |
| | Written | available buffer size, else |
| | | this routine will block |
| | | indefinitaly |
+------------------------------------------------------------------------------+
| Com_SendWait | | Sends a block to the remote, this |
| | Block | routine will wait till all the size is |
| | BlockLen | sent under FOSSIL, else it's the same |
| | Written | as Com_SendBlock. |
| | Slice | Slice is called when waiting for all to|
| | | get out. |
+------------------------------------------------------------------------------+
| Com_ReadBlock | | Gets a block from the remote |
| | Block | Block to read into |
| | BlockLen | Amount of bytes we want (will block!) |
| | Reads | Amount of bytes we actually gotten |
+------------------------------------------------------------------------------+
| Com_PurgeOutBuffer | | Kill all the pending output |
| | | |
+------------------------------------------------------------------------------+
| Com_PurgeInBuffer | | Kill all the pending input |
| | | |
+------------------------------------------------------------------------------+
| Com_PauseCom | | Pause the communications. Stop threads |
| | CloseCom |
+------------------------------------------------------------------------------+
| Com_ResumeCom | | Resums communications. Start threads |
| | CloseCom | |
+------------------------------------------------------------------------------+
| Com_FlushOutBuffer | | Wait till all pending output is done |
| | SliceProc | Procedure is called while waiting.. |
+------------------------------------------------------------------------------+
| Com_SendString | | Send this string to the remote |
| | Temp | String to send |
+------------------------------------------------------------------------------+
| Com_SetDataProc | | Set read/write thread handlers |
| | ReadPtr | Pointer to read thread procedure |
| | WritePtr | Pointer to write thread procedure |
+----------------------------------------------------(c)2000 by Maarten Bekers-+

17
SOURCE/ELECOM/README.TXT Normal file
View File

@ -0,0 +1,17 @@
ELECOM v1.03 - release notes
============================
These communication routines are released as freeware. You are free to do with
these routines whatever you want, but please give me proper credit when you do
use them (a small email to me mentioning that you are using them would be
great as well).
When you make any changes, enhancements or additions, please send me a copy
of the changes so I can include them in the next release.
Have fun,
groeten, Maarten Bekers
website: www.elebbs.com
email : maarten@elebbs.com

606
SOURCE/ELECOM/SOCKDEF.PAS Normal file
View File

@ -0,0 +1,606 @@
unit SockDef;
(*
**
** SOCKDEF routines
**
** Copyright (c) 1998 by Thomas W. Mueller
**
** Created : 24-Oct-1998
** Last update : 24-Oct-1998
**
**
*)
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
INTERFACE
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
uses
Sysutils,
{$IFDEF OS2}
Os2def;
{$ENDIF}
{$IFDEF LINUX}
Linux;
{$ENDIF}
{$IFDEF WIN32}
Windows;
{$ENDIF}
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
{$IFDEF VER0_99_13}
type pInteger = ^Integer;
tFarProc = pointer;
SmallInt = System.Integer;
{$ENDIF}
{$IFDEF LINUX}
type ULONG = longint;
{$ENDIF}
type
tSockDesc = LongInt;
SmallWord = System.Word;
type
eSocketErr = class(Exception);
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
const
MaxHostNameLen = 120;
(*
** Option flags per-socket.
*)
{$IFNDEF LINUX}
(*
** Level number for (get/set)sockopt() to apply to socket itself.
*)
SOL_SOCKET =$ffff; // options for socket level
SO_DEBUG =$0001; // turn on debugging info recording
SO_ACCEPTCONN =$0002; // socket has had listen()
SO_REUSEADDR =$0004; // allow local address reuse
SO_KEEPALIVE =$0008; // keep connections alive
SO_DONTROUTE =$0010; // just use interface addresses
SO_BROADCAST =$0020; // permit sending of broadcast msgs
SO_USELOOPBACK =$0040; // bypass hardware when possible
SO_LINGER =$0080; // linger on close if data present
SO_OOBINLINE =$0100; // leave received OOB data in line
(*
** Additional options, not kept in so_options.
*)
SO_SNDBUF =$1001; // send buffer size
SO_RCVBUF =$1002; // receive buffer size
SO_SNDLOWAT =$1003; // send low-water mark
SO_RCVLOWAT =$1004; // receive low-water mark
SO_SNDTIMEO =$1005; // send timeout
SO_RCVTIMEO =$1006; // receive timeout
SO_ERROR =$1007; // get error status and clear
SO_TYPE =$1008; // get socket type
{$ELSE}
SOL_SOCKET = 1;
SO_DEBUG = 1;
SO_REUSEADDR = 2;
SO_TYPE = 3;
SO_ERROR = 4;
SO_DONTROUTE = 5;
SO_BROADCAST = 6;
SO_SNDBUF = 7;
SO_RCVBUF = 8;
SO_KEEPALIVE = 9;
SO_OOBINLINE = 10;
SO_NO_CHECK = 11;
SO_PRIORITY = 12;
SO_LINGER = 13;
SO_BSDCOMPAT = 14;
{$ENDIF}
(*
** Address families.
*)
AF_UNSPEC = 0; // unspecified
AF_UNIX = 1; // local to host (pipes, portals)
AF_INET = 2; // internetwork: UDP, TCP, etc.
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_NBS = 7; // nbs protocols
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; // Direct data link interface
AF_LAT = 14; // LAT
AF_HYLINK = 15; // NSC Hyperchannel
AF_APPLETALK = 16; // Apple Talk
AF_OS2 = AF_UNIX;
AF_NB = 17; // Netbios
AF_NETBIOS = AF_NB;
AF_MAX = 18;
(*
** Protocol families, same as address families for now.
*)
PF_UNSPEC = AF_UNSPEC;
PF_UNIX = AF_UNIX;
PF_INET = AF_INET;
PF_IMPLINK = AF_IMPLINK;
PF_PUP = AF_PUP;
PF_CHAOS = AF_CHAOS;
PF_NS = AF_NS;
PF_NBS = AF_NBS;
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_NETBIOS = AF_NB;
PF_NB = AF_NB;
PF_OS2 = PF_UNIX;
PF_MAX = AF_MAX;
(*
** Maximum queue length specifiable by listen.
*)
SOMAXCONN = 5;
FREAD =1;
FWRITE =2;
MSG_OOB =$1; // process out-of-band data
MSG_PEEK =$2; // peek at incoming message
MSG_DONTROUTE =$4; // send without using routing tables
MSG_FULLREAD =$8; // send without using routing tables
MSG_MAXIOVLEN =16;
const
{ All Windows Sockets error constants are biased by WSABASEERR from the "normal" }
WSABASEERR = 10000;
{ Windows Sockets definitions of regular Microsoft C error constants }
WSAEINTR = (WSABASEERR+4);
WSAEBADF = (WSABASEERR+9);
WSAEACCES = (WSABASEERR+13);
WSAEFAULT = (WSABASEERR+14);
WSAEINVAL = (WSABASEERR+22);
WSAEMFILE = (WSABASEERR+24);
{ Windows Sockets definitions of regular Berkeley error constants }
{$IFNDEF LINUX}
WSAEWOULDBLOCK = (WSABASEERR+35);
WSAEINPROGRESS = (WSABASEERR+36);
WSAEALREADY = (WSABASEERR+37);
WSAENOTSOCK = (WSABASEERR+38);
WSAEDESTADDRREQ = (WSABASEERR+39);
WSAEMSGSIZE = (WSABASEERR+40);
WSAEPROTOTYPE = (WSABASEERR+41);
WSAENOPROTOOPT = (WSABASEERR+42);
WSAEPROTONOSUPPORT = (WSABASEERR+43);
WSAESOCKTNOSUPPORT = (WSABASEERR+44);
WSAEOPNOTSUPP = (WSABASEERR+45);
WSAEPFNOSUPPORT = (WSABASEERR+46);
WSAEAFNOSUPPORT = (WSABASEERR+47);
WSAEADDRINUSE = (WSABASEERR+48);
WSAEADDRNOTAVAIL = (WSABASEERR+49);
WSAENETDOWN = (WSABASEERR+50);
WSAENETUNREACH = (WSABASEERR+51);
WSAENETRESET = (WSABASEERR+52);
WSAECONNABORTED = (WSABASEERR+53);
WSAECONNRESET = (WSABASEERR+54);
WSAENOBUFS = (WSABASEERR+55);
WSAEISCONN = (WSABASEERR+56);
WSAENOTCONN = (WSABASEERR+57);
WSAESHUTDOWN = (WSABASEERR+58);
WSAETOOMANYREFS = (WSABASEERR+59);
WSAETIMEDOUT = (WSABASEERR+60);
WSAECONNREFUSED = (WSABASEERR+61);
WSAELOOP = (WSABASEERR+62);
WSAENAMETOOLONG = (WSABASEERR+63);
WSAEHOSTDOWN = (WSABASEERR+64);
WSAEHOSTUNREACH = (WSABASEERR+65);
WSAENOTEMPTY = (WSABASEERR+66);
WSAEPROCLIM = (WSABASEERR+67);
WSAEUSERS = (WSABASEERR+68);
WSAEDQUOT = (WSABASEERR+69);
WSAESTALE = (WSABASEERR+70);
WSAEREMOTE = (WSABASEERR+71);
WSAEDISCON = (WSABASEERR+101);
{$ENDIF}
{$IFDEF LINUX}
WSAEWOULDBLOCK = 11;
WSAEINPROGRESS = 115;
WSAEALREADY = 114;
WSAENOTSOCK = 88;
WSAEDESTADDRREQ = 89;
WSAEMSGSIZE = 90;
WSAEPROTOTYPE = 91;
WSAENOPROTOOPT = 92;
WSAEPROTONOSUPPORT = 93;
WSAESOCKTNOSUPPORT = 94;
WSAEOPNOTSUPP = 95;
WSAEPFNOSUPPORT = 96;
WSAEAFNOSUPPORT = 97;
WSAEADDRINUSE = 98;
WSAEADDRNOTAVAIL = 99;
WSAENETDOWN = 100;
WSAENETUNREACH = 101;
WSAENETRESET = 102;
WSAECONNABORTED = 103;
WSAECONNRESET = 104;
WSAENOBUFS = 105;
WSAEISCONN = 106;
WSAENOTCONN = 107;
WSAESHUTDOWN = 108;
WSAETOOMANYREFS = 109;
WSAETIMEDOUT = 110;
WSAECONNREFUSED = 111;
WSAELOOP = 40;
WSAENAMETOOLONG = 36;
WSAEHOSTDOWN = 112;
WSAEHOSTUNREACH = 113;
WSAENOTEMPTY = 39;
WSAEPROCLIM = 00;
WSAEUSERS = 87;
WSAEDQUOT = 122;
WSAESTALE = 116;
WSAEREMOTE = 66;
{$ENDIF}
{ Extended Windows Sockets error constant definitions }
WSASYSNOTREADY = (WSABASEERR+91);
WSAVERNOTSUPPORTED = (WSABASEERR+92);
WSANOTINITIALISED = (WSABASEERR+93);
{ Error return codes from gethostbyname() and gethostbyaddr()
(when using the resolver). Note that these errors are
retrieved via WSAGetLastError() and must therefore follow
the rules for avoiding clashes with error numbers from
specific implementations or language run-time systems.
For this reason the codes are based at WSABASEERR+1001.
Note also that [WSA]NO_ADDRESS is defined only for
compatibility purposes. }
{ Authoritative Answer: Host not found }
WSAHOST_NOT_FOUND = (WSABASEERR+1001);
HOST_NOT_FOUND = WSAHOST_NOT_FOUND;
{ Non-Authoritative: Host not found, or SERVERFAIL }
WSATRY_AGAIN = (WSABASEERR+1002);
TRY_AGAIN = WSATRY_AGAIN;
{ Non recoverable errors, FORMERR, REFUSED, NOTIMP }
WSANO_RECOVERY = (WSABASEERR+1003);
NO_RECOVERY = WSANO_RECOVERY;
{ Valid name, no data record of requested type }
WSANO_DATA = (WSABASEERR+1004);
NO_DATA = WSANO_DATA;
{ no address, look for MX record }
WSANO_ADDRESS = WSANO_DATA;
NO_ADDRESS = WSANO_ADDRESS;
{ Windows Sockets errors redefined as regular Berkeley error constants.
These are commented out in Windows NT to avoid conflicts with errno.h.
Use the WSA constants instead. }
EWOULDBLOCK = WSAEWOULDBLOCK;
EINPROGRESS = WSAEINPROGRESS;
EALREADY = WSAEALREADY;
ENOTSOCK = WSAENOTSOCK;
EDESTADDRREQ = WSAEDESTADDRREQ;
EMSGSIZE = WSAEMSGSIZE;
EPROTOTYPE = WSAEPROTOTYPE;
ENOPROTOOPT = WSAENOPROTOOPT;
EPROTONOSUPPORT = WSAEPROTONOSUPPORT;
ESOCKTNOSUPPORT = WSAESOCKTNOSUPPORT;
EOPNOTSUPP = WSAEOPNOTSUPP;
EPFNOSUPPORT = WSAEPFNOSUPPORT;
EAFNOSUPPORT = WSAEAFNOSUPPORT;
EADDRINUSE = WSAEADDRINUSE;
EADDRNOTAVAIL = WSAEADDRNOTAVAIL;
ENETDOWN = WSAENETDOWN;
ENETUNREACH = WSAENETUNREACH;
ENETRESET = WSAENETRESET;
ECONNABORTED = WSAECONNABORTED;
ECONNRESET = WSAECONNRESET;
ENOBUFS = WSAENOBUFS;
EISCONN = WSAEISCONN;
ENOTCONN = WSAENOTCONN;
ESHUTDOWN = WSAESHUTDOWN;
ETOOMANYREFS = WSAETOOMANYREFS;
ETIMEDOUT = WSAETIMEDOUT;
ECONNREFUSED = WSAECONNREFUSED;
ELOOP = WSAELOOP;
ENAMETOOLONG = WSAENAMETOOLONG;
EHOSTDOWN = WSAEHOSTDOWN;
EHOSTUNREACH = WSAEHOSTUNREACH;
ENOTEMPTY = WSAENOTEMPTY;
EPROCLIM = WSAEPROCLIM;
EUSERS = WSAEUSERS;
EDQUOT = WSAEDQUOT;
ESTALE = WSAESTALE;
EREMOTE = WSAEREMOTE;
SockAddr_Len = 16;
In_Addr_Len = 4;
InAddr_Any = 0;
InAddr_Loopback = $7F000001;
InAddr_Broadcast = $FFFFFFFF;
InAddr_None = $FFFFFFFF;
SOCK_NULL = 0;
SOCK_STREAM = 1; // stream socket
SOCK_DGRAM = 2; // datagram socket
SOCK_RAW = 3; // raw-protocol interface
SOCK_RDM = 4; // reliably-delivered message
SOCK_SEQPACKET = 5; // sequenced packet stream
IPPROTO_NULL = 0;
IPPROTO_UDP = 17;
IPPROTO_TCP = 6;
const
IOCPARM_MASK = $7f;
IOC_VOID = $20000000;
IOC_OUT = $40000000;
IOC_IN = $80000000;
IOC_INOUT = (IOC_IN or IOC_OUT);
{$IFNDEF LINUX}
FIONREAD = IOC_OUT or { get # bytes to read }
((Longint(SizeOf(Longint)) and IOCPARM_MASK) shl 16) or
(Longint(Byte('f')) shl 8) or 127;
FIONBIO = IOC_IN or { set/clear non-blocking i/o }
((Longint(SizeOf(Longint)) and IOCPARM_MASK) shl 16) or
(Longint(Byte('f')) shl 8) or 126;
FIOASYNC = IOC_IN or { set/clear async i/o }
((Longint(SizeOf(Longint)) and IOCPARM_MASK) shl 16) or
(Longint(Byte('f')) shl 8) or 125;
{$ENDIF}
type
pLongInt = ^LongInt;
pIoVec = ^tIoVec;
tIoVec = packed record
iov_base: POINTER;
iov_len: LongInt;
end;
(*
** Structure used for manipulating linger option.
*)
tLinger = packed record
l_onoff: LongInt; // option on/off
l_linger: LongInt; // linger time
END;
(*
** Structure used by kernel to pass protocol
** information in raw sockets.
*)
tSockProto = packed record
sp_family: WORD; // address family
sp_protocol: WORD; // protocol
END;
off_t = LongInt;
tuio = packed record
uio_iov: pIoVec;
uio_iovcnt: LongInt;
uio_offset: off_t;
uio_segflg: LongInt;
uio_resid: LongInt;
END;
pIn_Addr = ^tIn_Addr;
tIn_Addr = packed record
case integer of
0: (IPAddr: ULong);
1: (ClassA: byte;
ClassB: byte;
ClassC: byte;
ClassD: byte)
end;
(*
** Structure used by kernel to store most
** addresses.
*)
pSockAddr=^tSockAddr;
tSockAddr=packed record
case integer of
0: (Sin_Family: SmallWord;
Sin_Port: SmallWord;
Sin_Addr: tIn_Addr;
Sin_Zero: array[1.. 8] of byte);
1: (Sa_Family: SmallWord;
Sa_Addr: array[1..14] of byte);
end;
(*
** Message header for recvmsg and sendmsg calls.
*)
pMsgHdr = ^tMsgHdr;
tMsgHdr = packed record
msg_name: pChar; // optional address
msg_namelen: LongInt; // size of address
msg_iov: pIoVec; // scatter/gather array
msg_iovlen: LongInt; // # elements in msg_iov
msg_accrights: pChar; // access rights sent/received
msg_accrightslen: LongInt;
END;
uio_rw = ( UIO_READ, UIO_WRITE );
pHostEnt = ^tHostEnt;
tHostEnt = packed record
H_Name: ^string;
H_Alias: pointer;
{$IFNDEF WIN32}
H_AddrType: longint;
H_Length: longint;
{$ELSE}
h_addrtype: Smallint;
h_length: Smallint;
{$ENDIF}
H_Addr_List: ^pIn_Addr;
END;
pProtoEnt = ^tProtoEnt;
TProtoEnt = packed record
p_name: pChar; (* official protocol name *)
p_aliases: ^pChar; (* alias list *)
p_proto: SmallInt; (* protocol # *)
end;
pServEnt = ^tServEnt;
tServEnt = packed record
s_name: pChar; // official service name
s_aliases: ^pChar; // alias list
s_port: SmallInt; // port #
s_proto: pChar; // protocol to use
END;
// these types are only used in windows version
const
FD_SETSIZE = 64;
type
PFDSet = ^TFDSet;
TFDSet = packed record
fd_count: ULONG;
fd_array: array[0..FD_SETSIZE-1] of ULONG;
end;
PTimeVal = ^TTimeVal;
TTimeVal = packed record
tv_sec: Longint;
tv_usec: Longint;
end;
const
WSADESCRIPTION_LEN = 256;
WSASYS_STATUS_LEN = 128;
type
PWSAData = ^TWSAData;
TWSAData = packed record
wVersion: Word;
wHighVersion: Word;
szDescription: array[0..WSADESCRIPTION_LEN] of Char;
szSystemStatus: array[0..WSASYS_STATUS_LEN] of Char;
iMaxSockets: Word;
iMaxUdpDg: Word;
lpVendorInfo: PChar;
end;
(*
** The re-defination of error constants are necessary to avoid conflict with
** standard IBM C Set/2 V1.0 error constants.
**
** All OS/2 SOCKET API error constants are biased by SOCBASEERR from the "normal"
**
*)
const
SOCBASEERR = 10000;
(*
** OS/2 SOCKET API definitions of regular Microsoft C 6.0 error constants
*)
const
SOCEPERM = (SOCBASEERR+1); (* Not owner *)
SOCESRCH = (SOCBASEERR+3); (* No such process *)
SOCEINTR = (SOCBASEERR+4); (* Interrupted system call *)
SOCENXIO = (SOCBASEERR+6); (* No such device or address *)
SOCEBADF = (SOCBASEERR+9); (* Bad file number *)
SOCEACCES = (SOCBASEERR+13); (* Permission denied *)
SOCEFAULT = (SOCBASEERR+14); (* Bad address *)
SOCEINVAL = (SOCBASEERR+22); (* Invalid argument *)
SOCEMFILE = (SOCBASEERR+24); (* Too many open files *)
SOCEPIPE = (SOCBASEERR+32); (* Broken pipe *)
SOCEOS2ERR = (SOCBASEERR+100); (* OS/2 Error *)
(*
** OS/2 SOCKET API definitions of regular BSD error constants
*)
const
SOCEWOULDBLOCK = (SOCBASEERR+35); (* Operation would block *)
SOCEINPROGRESS = (SOCBASEERR+36); (* Operation now in progress *)
SOCEALREADY = (SOCBASEERR+37); (* Operation already in progress *)
SOCENOTSOCK = (SOCBASEERR+38); (* Socket operation on non-socket *)
SOCEDESTADDRREQ = (SOCBASEERR+39); (* Destination address required *)
SOCEMSGSIZE = (SOCBASEERR+40); (* Message too long *)
SOCEPROTOTYPE = (SOCBASEERR+41); (* Protocol wrong type for socket *)
SOCENOPROTOOPT = (SOCBASEERR+42); (* Protocol not available *)
SOCEPROTONOSUPPORT = (SOCBASEERR+43); (* Protocol not supported *)
SOCESOCKTNOSUPPORT = (SOCBASEERR+44); (* Socket type not supported *)
SOCEOPNOTSUPP = (SOCBASEERR+45); (* Operation not supported on socket *)
SOCEPFNOSUPPORT = (SOCBASEERR+46); (* Protocol family not supported *)
SOCEAFNOSUPPORT = (SOCBASEERR+47); (* Address family not supported by protocol family *)
SOCEADDRINUSE = (SOCBASEERR+48); (* Address already in use *)
SOCEADDRNOTAVAIL = (SOCBASEERR+49); (* Can't assign requested address *)
SOCENETDOWN = (SOCBASEERR+50); (* Network is down *)
SOCENETUNREACH = (SOCBASEERR+51); (* Network is unreachable *)
SOCENETRESET = (SOCBASEERR+52); (* Network dropped connection on reset *)
SOCECONNABORTED = (SOCBASEERR+53); (* Software caused connection abort *)
SOCECONNRESET = (SOCBASEERR+54); (* Connection reset by peer *)
SOCENOBUFS = (SOCBASEERR+55); (* No buffer space available *)
SOCEISCONN = (SOCBASEERR+56); (* Socket is already connected *)
SOCENOTCONN = (SOCBASEERR+57); (* Socket is not connected *)
SOCESHUTDOWN = (SOCBASEERR+58); (* Can't send after socket shutdown *)
SOCETOOMANYREFS = (SOCBASEERR+59); (* Too many references: can't splice *)
SOCETIMEDOUT = (SOCBASEERR+60); (* Connection timed out *)
SOCECONNREFUSED = (SOCBASEERR+61); (* Connection refused *)
SOCELOOP = (SOCBASEERR+62); (* Too many levels of symbolic links *)
SOCENAMETOOLONG = (SOCBASEERR+63); (* File name too long *)
SOCEHOSTDOWN = (SOCBASEERR+64); (* Host is down *)
SOCEHOSTUNREACH = (SOCBASEERR+65); (* No route to host *)
SOCENOTEMPTY = (SOCBASEERR+66); (* Directory not empty *)
(*
** OS/2 SOCKET API errors redefined as regular BSD error constants
*)
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
IMPLEMENTATION
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
end. { unit SockDef }

831
SOURCE/ELECOM/SOCKFUNC.PAS Normal file
View File

@ -0,0 +1,831 @@
unit SockFunc;
(*
**
** SOCKFUNC routines
**
** Copyright (c) 1998 by Thomas W. Mueller
** Linux additions (c)1999 by Maarten Bekers
**
** Created : 24-Oct-1998
** Last update : 24-Oct-1998
**
**
*)
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
INTERFACE
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-
** Copyright (c) 1982, 1985, 1986 Regents of the University of California.
** All rights reserved.
**
** Redistribution and use in source and binary forms are permitted
** provided that this notice is preserved and that due credit is given
** to the University of California at Berkeley. The name of the University
** may not be used to endorse or promote products derived from this
** software without specific prior written permission. This software
** is provided ``as is'' without express or implied warranty.
s**
** @(#)socket.h 7.2 (Berkeley) 12/30/87
-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
uses
{$IFDEF OS2}
OS2Def,
IBMSO32,
IBMTCP32,
{$ENDIF}
{$IFDEF WIN32}
windows,
W32Sock,
{$ENDIF}
{$IFDEF LINUX}
linux,
Linsock,
{$ENDIF}
Sysutils,
SockDef;
Const SockInitted : Boolean = false;
function SockErrorNo: Longint;
function SockGetErrStr(_ErrNo: integer): ShortString;
procedure SockRaiseError(const _prefix: String; _ErrNo: integer);
procedure SockRaiseLastError(const _prefix: String);
function SockAccept(_SockDesc: tSockDesc; _SockAddr: pSockAddr;
var _SockAddrLen: Longint): tSockDesc;
function SockBind(_SockDesc: tSockDesc; var _SockAddr: tSockAddr): Longint;
function SockCancel(_SockDesc: tSockDesc): Longint;
function SockConnect(_SockDesc: tSockDesc; var _SockAddr: tSockAddr): Longint;
function SockGetHostByName(Hostname: ShortString): phostent;
function SockShutdown(_SockDesc: tSockDesc; _how: ULong): Longint;
function SockGetSockAddr(_SockDesc: tSockDesc; var _SockAddr: tSockAddr): Longint;
function SockGetSockOpt(_SockDesc: tSockDesc; _Level, _OptName: Integer;
_OptVal: PChar; var _OptLen: Integer): Longint;
function SockSetSockOpt(_SockDesc: tSockDesc; _Level: uLong; _OptName: Ulong;
_OptVal: pChar; _OptLen: uLong ): Longint;
function SockSetBlockingIO(_SockDesc: tSockDesc; _BlockingIO: boolean): Longint;
function SockIoCtlSocket(_SockDesc: tSockDesc; Func: Longint): Longint;
function SockListen(_SockDesc: tSockDesc; _SockQueue: ULong): Longint;
function SockRecv(_SockDesc: tSockDesc; _SockBuffer: pointer;
_SockBufLen: ULong; _SockFlags: ULong): Longint;
function SockSend(_SockDesc: tSockDesc; _SockBuffer: pointer;
_SockBufLen: ULong; _SockFlags: ULong ): Longint;
function SockSocket(_SockFamily: word; _SockType: word;
_SockProtocol: word ): tSockDesc;
function SockClose(_SockDesc: tSockDesc): Longint;
function SockInit: Longint;
function SockClientAlive(_SockDesc: tSockDesc): Boolean;
function SockGetHostAddrByName(_HostName: ShortString): ULONG;
function SockGetHostNameByAddr(_HostAddr: pIn_Addr): ShortString;
function SockGetHostname: ShortString;
function SockGetServByName(_Name, _Proto: ShortString): pServEnt;
function SockGetServPortByName(_Name, _Proto: ShortString): Longint;
function SockHtonl(_Input: LongInt): longint;
function SockHtons(_Input: SmallWord): SmallWord;
function SockNtohl(_Input: LongInt): longint;
function SockNtohs(_Input: SmallWord): longint;
function SockDataAvail(_SockDesc: tSockDesc): Boolean;
function SockSelect(_SockDesc: tSockDesc): Longint;
function SockInetAddr(_s: ShortString):tIn_Addr;
{$IFNDEF LINUX}
{$IFNDEF FPC}
{$R SOCKFUNC.RES}
{$ENDIF}
{$ENDIF}
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
IMPLEMENTATION
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
Const
Version = '1.00';
UseString: ShortString = '@(#)socket interface unit for IBM TCP/IP and WinSock'#0;
CopyRight1: ShortString = '@(#)socket Version '+Version+' - 26.08.1998'#0;
CopyRight2: ShortString = '@(#}(C) Thomas Mueller 1998'#0;
CopyRight3: ShortString = '@(#)(C) Chr.Hohmann BfS ST2.2 1996'#0;
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function SockErrorNo: Longint;
begin
{$IFDEF OS2}
Result := IBM_sock_errno;
{$ENDIF}
{$IFDEF WIN32}
Result := WsaGetLastError;
{$ENDIF}
{$IFDEF LINUX}
Result := SocketError;
{$ENDIF}
end; { func. SockErrorNo }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function SockGetErrStr(_ErrNo: integer): ShortString;
begin
Result:=LoadStr(_ErrNo);
end; { func. SockGetErrStr }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure SockRaiseError(const _prefix: String; _ErrNo: integer);
begin
raise eSocketErr.CreateFmt('%s: %s (%d)',
[_prefix, SockGetErrStr(_ErrNo), _ErrNo]);
end; { proc. SockRaiseError }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure SockRaiseLastError(const _prefix: String);
begin
SockRaiseError(_Prefix, SockErrorNo);
end; { proc. SockRaiseLastError }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function SockGetServByName(_Name, _Proto: ShortString): pServEnt;
begin
_Name := _Name + #00;
_Proto := _Proto + #00;
{$IFDEF WIN32}
Result := getservbyname(@_Name[01], @_Proto[01]);
{$ENDIF}
{$IFDEF OS2}
Result := ibm_getservbyname(@_Name[01], @_Proto[01]);
{$ENDIF}
{$IFDEF LINUX}
Result := getservbyname(@_Name[1], @_Proto[01]);
{$ENDIF}
end; { func. SockGetServByName }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function SockGetServPortByName(_Name, _Proto: ShortString): longint;
var ServEnt: pServEnt;
begin
ServEnt := SockGetServByName(_Name, _Proto);
if Assigned(ServEnt) then
Result := ServEnt^.s_Port
else Result := -01;
end; { func. SockGetServPortByName }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function SockHtonl( _Input: longint): longint;
type SwapLong = packed record
case integer of
0: (SLong: longint);
1: (SArray: packed array[1..4] of byte);
end;
var Inp,
Tmp: SwapLong;
begin
Inp.SLong := _Input;
Tmp.SArray[1] := Inp.SArray[4];
Tmp.SArray[2] := Inp.SArray[3];
Tmp.SArray[3] := Inp.SArray[2];
Tmp.SArray[4] := Inp.SArray[1];
result := Tmp.SLong;
end;
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function SockHtons( _Input: SmallWord): SmallWord;
type SwapWord = packed record
case integer of
0: (SWord: SmallWord);
1: (SArray: packed array[1..2] of byte);
end;
var Inp,Tmp: SwapWord;
begin
Inp.SWord := _Input;
Tmp.SArray[1] := Inp.SArray[2];
Tmp.SArray[2] := Inp.SArray[1];
Result := Tmp.SWord;
end; { func. SockhToNl }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function SockNtohl( _Input: longint): longint;
begin
{$IFNDEF LINUX}
Result:=ntohl(_Input);
{$ELSE}
{!!!!!!!!!!!!!!!!!!!!!!!}
Result := _Input;
{$ENDIF}
end; { func. sockNToHl }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function SockNtohs( _Input: SmallWord): longint;
begin
{$IFDEF WIN32}
Result := ntohs( _input);
{$ENDIF}
{$IFDEF OS2}
{!!!!! Result := ntohs( _input);}
Result := Lo(_Input) * 256 + Hi(_Input);
{$ENDIF}
{$IFDEF LINUX}
Result := ntohs(_input);
{$ENDIF}
end; { func. SockNToHs }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function SockAccept(_SockDesc: tSockDesc;
_SockAddr: pSockAddr;
var _SockAddrLen: Longint): longint;
begin
{$IFDEF WIN32}
Result := Accept(_SockDesc, _SockAddr, @_SockAddrLen);
{$ENDIF}
{$IFDEF OS2}
Result := IBM_Accept(_SockDesc, _SockAddr, @_SockAddrLen);
{$ENDIF}
{$IFDEF LINUX}
Result := Accept(_SockDesc, _SockAddr^, _SockAddrLen);
{$ENDIF}
end; { func. SockAccept }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function SockBind(_SockDesc: tSockDesc;
var _SockAddr: tSockAddr ): Longint;
begin
{$IFDEF WIN32}
SockBind := Bind(_SockDesc, @_SockAddr, SockAddr_Len);
{$ENDIF}
{$IFDEF OS2}
SockBind := IBM_Bind(_SockDesc, @_SockAddr, SockAddr_Len);
{$ENDIF}
{$IFDEF LINUX}
SockBind := Longint(Bind(_SockDesc, _SockAddr, SockAddr_Len));
{$ENDIF}
end; { func. SockBind }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function SockConnect(_SockDesc: tSockDesc;
var _SockAddr: tSockAddr): Longint;
begin
{$IFDEF WIN32}
SockConnect := connect(_SockDesc, @_SockAddr, SockAddr_Len);
{$ENDIF}
{$IFDEF OS2}
SockConnect := ibm_connect(_SockDesc, @_SockAddr, SockAddr_Len);
{$ENDIF}
{$IFDEF LINUX}
SockConnect := connect(_SockDesc, _SockAddr, sockAddr_Len);
{$ENDIF}
end; { func. SockConnect }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function SockCancel(_SockDesc: tSockDesc): Longint;
begin
{$IFDEF WIN32}
Result := SockCancel(_SockDesc);
{$ENDIF}
{$IFDEF OS2}
Result := IBM_So_Cancel(_SockDesc);
{$ENDIF}
{$IFDEF LINUX}
Result := longint(true);
if _SockDesc=0 then ;
{$WARNING SockCancel function not implemented }
{!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!}
{$ENDIF}
end; { func. SockCancel }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function SockShutdown(_SockDesc: tSockDesc;
_how: ULong): Longint;
begin
{$IFDEF WIN32}
SockShutdown := ShutDown(_SockDesc, _How);
{$ENDIF}
{$IFDEF OS2}
SockShutDown := IBM_ShutDown(_SockDesc, _How);
{$ENDIF}
{$IFDEF LINUX}
SockShutDown := ShutDown(_SockDesc, _How);
{$ENDIF}
end; { func. SockShutDown }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function SockGetSockAddr(_SockDesc: tSockDesc; var _SockAddr: tSockAddr): Longint;
var sLength: Integer;
begin
FillChar(_SockAddr, SizeOf(_SockAddr), #00);
sLength := SizeOf(_SockAddr);
{$IFDEF WIN32}
Result := GetSockName(_SockDesc, @_SockAddr, sLength);
{$ENDIF}
{$IFDEF OS2}
Result := IBM_GetSockName(_SockDesc, @_SockAddr, @sLength);
{$ENDIF}
{$IFDEF LINUX}
Result := GetSocketName(_SockDesc, _SockAddr, sLength);
{$ENDIF}
end; { func. sockGetSockAddr }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function SockSetBlockingIO(_SockDesc: tSockDesc;
_BlockingIO: boolean): Longint;
var Arg: ULONG;
begin
{$IFDEF OS2}
if _BlockingIO then Arg := 00
else Arg := 01;
Result := IBM_IOCtl(_SockDesc, FIONBIO, @Arg, SizeOf(Arg));
{$ENDIF}
{$IFDEF WIN32}
if _BlockingIO then Arg := 00
else Arg := 01;
Result := IOCtlSocket(_SockDesc, FIONBIO, Arg);
{$ENDIF}
{$IFDEF LINUX}
if _BlockingIO then Arg := 00
else Arg := 01;
Result := Longint(ioctl(_SockDesc, Linux.FIONBIO, @Arg));
{$ENDIF}
end; { func. SockSetBlockingIO }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function SockIoCtlSocket(_SockDesc: tSockDesc; Func: Longint): Longint;
var Arg: ULONG;
begin
Arg := 0;
{$IFDEF OS2}
Result := IBM_IOCtl(_SockDesc, FUNC, @Arg, SizeOf(Arg));
{$ENDIF}
{$IFDEF WIN32}
Result := IOCtlSocket(_SockDesc, FUNC, Arg);
{$ENDIF}
{$IFDEF LINUX}
Result := Longint(IoCtl(_SockDesc, Func, @Arg));
{$ENDIF}
end; { func. SockIoCtlSocket }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function SockGetSockOpt(_SockDesc: tSockDesc; _Level, _OptName: Integer;
_OptVal: PChar; var _OptLen: Integer): Longint;
begin
{$IFDEF WIN32}
Result := GetSockOpt(_SockDesc, _Level, _OptName, _OptVal, _OptLen);
{$ENDIF}
{$IFDEF OS2}
Result := IBM_GetSockOpt(_SockDesc, _Level, _OptName, _OptVal, _OptLen);
{$ENDIF}
{$IFDEF LINUX}
Result := SetSocketOptions(_SockDesc, _Level, _OptName, _OptVal, _OptLen);
{$ENDIF}
end; { func. SockGetSockOpt }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function SockSetSockOpt(_SockDesc: tSockDesc; _Level: uLong; _OptName: Ulong;
_OptVal: pChar; _OptLen: uLong ): Longint;
begin
{$IFDEF WIN32}
Result := SetSockOpt(_SockDesc, _Level, _OptName, _OptVal, _OptLen);
{$ENDIF}
{$IFDEF OS2}
Result := IBM_SetSockOpt(_SockDesc, _Level, _OptName, _OptVal, _OptLen);
{$ENDIF}
{$IFDEF LINUX}
Result := SetSocketOptions(_SockDesc, _Level, _OptName, _OptVal, _OptLen);
{$ENDIF}
end; { func. SockSetSockOpt }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function SockDataAvail(_SockDesc: tSockDesc): Boolean;
{$IFDEF LINUX}
var ReadFDS : FDSet;
Temp : Longint;
{$ENDIF}
begin
{$IFNDEF LINUX}
Result := (SockSelect(_SockDesc) > 00);
{$ELSE}
fd_Zero(ReadFDS);
fd_Set(_SockDesc, ReadFDS);
Temp := Select(_SockDesc + 01, @ReadFDS, nil, nil, 0);
if (Temp > 0) then
begin
SockDataAvail := FD_ISSET(_SockDesc, ReadFDS);
end { if }
else SockDataAvail := false;
{$ENDIF}
(*
{$IFDEF OS2}
Arg := 00;
Result := IBM_IOCTL(_SockDesc, FIONREAD, @Arg, SizeOf(Arg));
if Arg > 00 then Result := Arg
else Result := $FFFFFFFF;
{$ENDIF}
{$IFDEF WIN32}
Result := IOCtlSocket(_SockDesc, FIONREAD, Arg);
if Arg > 00 then Result := Arg
else Result := $FFFFFFFF;
{$ENDIF}
*)
end; { func. SockDataAvail }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function SockListen(_SockDesc: tSockDesc;
_SockQueue: ULong): Longint;
begin
{$IFDEF WIN32}
SockListen := listen(_SockDesc, _SockQueue);
{$ENDIF}
{$IFDEF OS2}
SockListen := ibm_listen(_SockDesc, _SockQueue);
{$ENDIF}
{$IFDEF LINUX}
SockListen := Longint(Listen(_SockDesc, _SockQueue));
{$ENDIF}
end; { func. SockListen }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function SockSelect(_SockDesc: tSockDesc ): Longint;
{$IFDEF OS2}
var SockCopy: ULONG;
{$ENDIF}
{$IFDEF WIN32}
var SockArr : TFDSet;
Timeout : TTimeVal;
{$ENDIF}
{$IFDEF LINUX}
var ReadFDS : FDSet;
{$ENDIF}
begin
{$IFDEF OS2}
SockCopy := _SockDesc;
Result := IBM_Select(@SockCopy, 1, 0, 0, 0);
{$ENDIF}
{$IFDEF WIN32}
SockArr.fd_Count := 01;
SockArr.fd_Array[00] := _SockDesc;
Timeout.tv_sec := 00;
Timeout.tv_usec := 00;
Result := Select(00, @SockArr, NIL, NIL, @Timeout);
{$ENDIF}
{$IFDEF LINUX}
fd_Zero(ReadFDS);
fd_Set(_SockDesc, ReadFDS);
SockSelect := Select(_SockDesc + 01, @ReadFDS, nil, nil, 0);
{$ENDIF}
end; { func. SockSelect }
(*-+-*-+-*-+-*-+-*-+-*-+ -*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function SockRecv(_SockDesc: tSockDesc;
_SockBuffer: pointer;
_SockBufLen: ULong;
_SockFlags: ULong): Longint;
var Counter: Longint;
begin
{$IFDEF WIN32}
SockRecv := recv(_SockDesc,
_SockBuffer,
_SockBufLen,
_SockFlags);
{$ENDIF}
{$IFDEF OS2}
SockRecv := ibm_recv(_SockDesc,
_SockBuffer,
_SockBufLen,
_SockFlags);
{$ENDIF}
{$IFDEF LINUX}
SockRecv := Recv(_SockDesc,
_SockBuffer^,
_SockBufLen,
_SockFlags);
{$ENDIF}
end; { func. SockRecv }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function SockSend(_SockDesc: tSockDesc;
_SockBuffer: pointer;
_SockBufLen: ULong;
_SockFlags: ULong): Longint;
begin
{$IFDEF WIN32}
SockSend := Send(_SockDesc,
_SockBuffer,
_SockBufLen,
_SockFlags);
{$ENDIF}
{$IFDEF OS2}
SockSend := IBM_Send(_SockDesc,
_SockBuffer,
_SockBufLen,
_SockFlags);
{$ENDIF}
{$IFDEF LINUX}
SockSend := Send(_SockDesc,
_SockBuffer^,
_SockBufLen,
_SockFlags);
{$ENDIF}
end; { func. SockSend }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function SockSocket(_SockFamily: word;
_SockType: word;
_SockProtocol: word): tSockDesc;
begin
{$IFDEF WIN32}
SockSocket := Socket(_SockFamily, _SockType, _SockProtocol);
{$ENDIF}
{$IFDEF OS2}
SockSocket := ibm_Socket(_SockFamily, _SockType, _SockProtocol);
{$ENDIF}
{$IFDEF LINUX}
SockSocket := Socket(_SockFamily, _SockType, _SockProtocol);
{$ENDIF}
end; { func. SockSocket }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function SockClose(_SockDesc: tSockDesc): Longint;
begin
{$IFDEF OS2}
Result := IBM_soclose(_SockDesc);
{$ENDIF}
{$IFDEF WIN32}
Result := Closesocket(_SockDesc);
{$ENDIF}
{$IFDEF LINUX}
Result := Longint(fdClose(_SockDesc));
{$ENDIF}
end; { func. SockClose }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function SockInit: Longint;
{$IFDEF WIN32}
var Data: TWSAData;
{$ENDIF}
begin
if SockInitted then EXIT;
SockInitted := true;
{$IFDEF OS2}
SockInit := IBM_Sock_Init;
{$ENDIF}
{$IFDEF WIN32}
SockInit := WsaStartup($0101, Data);
{$ENDIF}
{$IFDEF LINUX}
SockInit := 0;
{$ENDIF}
end; { func. SockInit }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function SockGetHostByName(Hostname: ShortString): phostent;
begin
HostName := HostName + #00;
{$IFDEF WIN32}
Result := GetHostByName(@HostName[01]);
{$ENDIF}
{$IFDEF OS2}
Result := IBM_GetHostByName(@HostName[01]);
{$ENDIF}
{$IFDEF LINUX}
Result := GetHostByName(@HostName[1]);
{$ENDIF}
end; { func. SockGetHostByName }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function SockGetHostAddrByName(_HostName: ShortString): ULong;
var ReturnCode: pHostEnt;
InAddr : tIn_Addr;
begin
ReturnCode := SockGetHostbyName(_HostName);
if Assigned(ReturnCode) then
begin
InAddr := ReturnCode^.H_Addr_List^^;
Result := InAddr.IpAddr;
end
else Result:=$FFFFFFFF;
end; { func. SockGetHostAddrByName }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function SockGetHostByAddr(HostAddr: pIn_Addr;
HostAddrLen: ULong;
HostAddrType: ULong): pointer;
begin
{$IFDEF WIN32}
SockGetHostByAddr := GetHostbyAddr(HostAddr,
HostAddrLen,
HostAddrType);
{$ENDIF}
{$IFDEF OS2}
SockGetHostByAddr := IBM_GetHostbyAddr(HostAddr,
HostAddrLen,
HostAddrType);
{$ENDIF}
{$IFDEF LINUX}
Result := GetHostByAddr(HostAddr, HostAddrLen, HostAddrtype);
{$ENDIF}
end; { func. SockGetHostbyAddr }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function SockGetHostNameByAddr(_HostAddr: pIn_Addr): ShortString;
var Counter : Integer;
ReturnCode: pHostEnt;
HName : ShortString;
begin
ReturnCode := SockGetHostByAddr(_HostAddr,
In_Addr_Len,
AF_INET);
if (ULong(ReturnCode) <> 00) then
begin
HName := '';
Counter := 00;
While ReturnCode^.H_Name^[Counter] <> #00 do
begin
HName := HName + ReturnCode^.H_Name^[Counter];
Inc(Counter);
end; { while }
end
else HName := 'Hostname not found';
SockGetHostNameByAddr := HName;
end; { func. SockGetHostNameByAddr }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function SockGetHostname: ShortString;
var Counter : Longint;
sResult : Longint;
HostName : ShortString;
InAddr : TIn_Addr;
begin
FillChar(HostName, SizeOf(HostName), #00);
{$IFDEF WIN32}
sResult := GetHostName(@HostName[01], SizeOf(HostName));
{$ENDIF}
{$IFDEF OS2}
sResult := IBM_GetHostName(@HostName[01], SizeOf(HostName));
{$ENDIF}
{$IFDEF LINUX}
{!!!!!!!!!!!!!!!!!!!}
InAddr.ClassA := 127;
InAddr.ClassB := 0;
InAddr.ClassC := 0;
InAddr.ClassD := 1;
HostName := SockGetHostNameByAddr(@InAddr) + #00;
sResult := Length(HostName);
{$ENDIF}
Counter := 01;
While (Counter < SizeOf(HostName)) AND (HostName[Counter] <> #00) do
Inc(Counter);
if (Counter > 01) then
SetLength(HostName, Counter)
else HostName := 'amnesiac';
SockGetHostname := HostName;
end; { func. SockGetHostName }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function SockInetAddr(_s: ShortString): tIn_Addr;
begin
_s := _s + #00;
{$IFNDEF LINUX}
Result.IpAddr := INet_Addr(@_S[01]);
{$ELSE}
{$WARNING SockInetAddr function not implemented! }
Result.IpAddr := INADDR_NONE;
{$ENDIF}
end; { func. SockInetAddr }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function SockClientAlive(_SockDesc: tSockDesc): Boolean;
var TempCH : Char;
Returncode : Longint;
TempError : Longint;
TempStr : String;
begin
Result := true;
ReturnCode := SockRecv(_SockDesc, @TempCH, SizeOf(TempCH), MSG_PEEK);
TempError := SockErrorNo;
TempStr := SockGetErrStr(TempError);
if ReturnCode = 0 then Result := false; { was: = 0 }
if (TempError <> WSAEWOULDBLOCK) AND (TempError <> 00) then
Result := false;
end; { func. SockClientAlive }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
initialization
{!! SockInit; }
finalization
{$IFDEF WIN32}
//WsaCleanUp;
{$ENDIF}
end. { unit SockFunc }

92
SOURCE/ELECOM/SOCKFUNC.RC Normal file
View File

@ -0,0 +1,92 @@
#define SOCEPERM 10001
#define SOCESRCH 10003
#define SOCEINTR 10004
#define SOCENXIO 10006
#define SOCEBADF 10009
#define SOCEACCES 10013
#define SOCEFAULT 10014
#define SOCEINVAL 10022
#define SOCEMFILE 10024
#define SOCEPIPE 10032
#define SOCEOS2ERR 10100
#define SOCEWOULDBLOCK 10035
#define SOCEINPROGRESS 10036
#define SOCEALREADY 10037
#define SOCENOTSOCK 10038
#define SOCEDESTADDRREQ 10039
#define SOCEMSGSIZE 10040
#define SOCEPROTOTYPE 10041
#define SOCENOPROTOOPT 10042
#define SOCEPROTONOSUPPORT 10043
#define SOCESOCKTNOSUPPORT 10044
#define SOCEOPNOTSUPP 10045
#define SOCEPFNOSUPPORT 10046
#define SOCEAFNOSUPPORT 10047
#define SOCEADDRINUSE 10048
#define SOCEADDRNOTAVAIL 10049
#define SOCENETDOWN 10050
#define SOCENETUNREACH 10051
#define SOCENETRESET 10052
#define SOCECONNABORTED 10053
#define SOCECONNRESET 10054
#define SOCENOBUFS 10055
#define SOCEISCONN 10056
#define SOCENOTCONN 10057
#define SOCESHUTDOWN 10058
#define SOCETOOMANYREFS 10059
#define SOCETIMEDOUT 10060
#define SOCECONNREFUSED 10061
#define SOCELOOP 10062
#define SOCENAMETOOLONG 10063
#define SOCEHOSTDOWN 10064
#define SOCEHOSTUNREACH 10065
#define SOCENOTEMPTY 10066
STRINGTABLE
{
SOCEPERM, "Not owner"
SOCESRCH, "No such process"
SOCEINTR, "Interrupted system call"
SOCENXIO, "No such device or address"
SOCEBADF, "Bad file number"
SOCEACCES, "Permission denied"
SOCEFAULT, "Bad address"
SOCEINVAL, "Invalid argument"
SOCEMFILE, "Too many open files"
SOCEPIPE, "Broken pipe"
SOCEOS2ERR, "OS/2 Error"
SOCEWOULDBLOCK, "Operation would block"
SOCEINPROGRESS, "Operation now in progress"
SOCEALREADY, "Operation already in progress"
SOCENOTSOCK, "Socket operation on non-socket"
SOCEDESTADDRREQ, "Destination address required"
SOCEMSGSIZE, "Message too long"
SOCEPROTOTYPE, "Protocol wrong type for socket"
SOCENOPROTOOPT, "Protocol not available"
SOCEPROTONOSUPPORT, "Protocol not supported"
SOCESOCKTNOSUPPORT, "Socket type not supported"
SOCEOPNOTSUPP, "Operation not supported on socket"
SOCEPFNOSUPPORT, "Protocol family not supported"
SOCEAFNOSUPPORT, "Address family not supported by protocol family"
SOCEADDRINUSE, "Address already in use"
SOCEADDRNOTAVAIL, "Can't assign requested address"
SOCENETDOWN, "Network is down"
SOCENETUNREACH, "Network is unreachable"
SOCENETRESET, "Network dropped connection on reset"
SOCECONNABORTED, "Software caused connection abort"
SOCECONNRESET, "Connection reset by peer"
SOCENOBUFS, "No buffer space available"
SOCEISCONN, "Socket is already connected"
SOCENOTCONN, "Socket is not connected"
SOCESHUTDOWN, "Can't send after socket shutdown"
SOCETOOMANYREFS, "Too many references: can't splice"
SOCETIMEDOUT, "Connection timed out"
SOCECONNREFUSED, "Connection refused"
SOCELOOP, "Too many levels of symbolic links"
SOCENAMETOOLONG, "File name too long"
SOCEHOSTDOWN, "Host is down"
SOCEHOSTUNREACH, "No route to host"
SOCENOTEMPTY, "Directory not empty"
}

BIN
SOURCE/ELECOM/SOCKFUNC.RES Normal file
View File

Binary file not shown.

863
SOURCE/ELECOM/TELNET.PAS Normal file
View File

@ -0,0 +1,863 @@
unit TELNET;
{$h-}
(*
**
** Serial and TCP/IP communication routines for DOS, OS/2 and Win9x/NT.
** Tested with: TurboPascal v7.0, (DOS)
** VirtualPascal v2.1, (OS/2, Win32)
** FreePascal v0.99.12 (DOS, Win32)
** Delphi v4.0. (Win32)
**
** Version : 1.01
** Created : 21-May-1998
** Last update : 04-Apr-1999
**
** Note: (c) 1998-1999 by Maarten Bekers
**
** Note: Same story of what we said in Win32, only we have here 2 seperate
** threads. The Write-thread has no problems, the read-thread is run
** max every 5 seconds, or whenever a carrier-check is performed. This
** carrier check is run on most BBS programs each second. You can
** optimize this by making the ReadThread a blocking select() call on
** the fd_read socket, but this can have other issues. A better approach
** on Win32 would be to call the WsaAsyncSelect() call, but this is
** non portable.
**
*)
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
INTERFACE
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
uses SockFunc, SockDef, Combase, BufUnit, Threads
{$IFDEF WIN32}
,Windows
{$ENDIF}
{$IFDEF OS2}
,Os2Base
{$ENDIF}
{$IFDEF VirtualPascal}
,Use32
{$ENDIF};
Const WriteTimeout = 5000; { Wait max. 5 secs }
ReadTimeOut = 5000; { General event, 5 secs max }
InBufSize = 1024 * 32;
OutBufSize = 1024 * 32;
type TTelnetObj = Object(TCommObj)
ReadProcPtr: Pointer; { Pointer to TX/RX handler (thread) }
WriteProcPtr: Pointer; { Pointer to TX/RX handler (thread) }
ThreadsInitted : Boolean;
NeedNewCarrier : Boolean;
TelnetCarrier : Boolean;
IacDontDo : Longint; { ugly hack to prevent missed IACs }
IacState : Longint; { 0 = nothing }
{ 1 = received IAC }
{ 2 = handing the IAC }
ClientRC : Longint;
InBuffer : ^BufArrayObj; { Buffer system internally used }
OutBuffer : ^BufArrayObj;
DoTxEvent : PSysEventObj; { Event manually set when we have to transmit }
DoRxEvent : PSysEventObj; { Event manually set when we need data }
TxClosedEvent : PSysEventObj; { Event set when the Tx thread is closed }
RxClosedEvent : PSysEventObj; { Event set when the Rx thread is closed }
CriticalTx : PExclusiveObj; { Critical sections }
CriticalRx : PExclusiveObj;
TxThread : PThreadsObj; { The Transmit and Receive threads }
RxThread : PThreadsObj;
EndThreads : Boolean; { Set to true when we have to end the threads }
constructor Init;
destructor Done;
function Com_Open(Comport: Byte; BaudRate: Longint; DataBits: Byte;
Parity: Char; StopBits: Byte): Boolean; virtual;
function Com_OpenKeep(Comport: Byte): Boolean; virtual;
function Com_GetChar: Char; virtual;
function Com_PeekChar: Char; virtual;
function Com_CharAvail: Boolean; virtual;
function Com_Carrier: Boolean; virtual;
function Com_SendChar(C: Char): Boolean; virtual;
function Com_ReadyToSend(BlockLen: Longint): Boolean; virtual;
function Com_GetBPSrate: Longint; virtual;
function Com_GetHandle: Longint; virtual;
procedure Com_OpenQuick(Handle: Longint); virtual;
procedure Com_Close; virtual;
procedure Com_SendBlock(var Block; BlockLen: Longint; var Written: Longint); virtual;
procedure Com_ReadBlock(var Block; BlockLen: Longint; var Reads: Longint); virtual;
procedure Com_PeekBlock(var Block; BlockLen: Longint; var Reads: Longint); virtual;
procedure Com_GetBufferStatus(var InFree, OutFree, InUsed, OutUsed: Longint); virtual;
procedure Com_SetDtr(State: Boolean); virtual;
procedure Com_GetModemStatus(var LineStatus, ModemStatus: Byte); virtual;
procedure Com_SetLine(BpsRate: longint; Parity: Char; DataBits, Stopbits: Byte); virtual;
procedure Com_PurgeInBuffer; virtual;
procedure Com_PurgeOutBuffer; virtual;
procedure Com_PauseCom(CloseCom: Boolean); virtual;
procedure Com_ResumeCom(OpenCom: Boolean); virtual;
procedure Com_ReadProc(var TempPtr: Pointer);
procedure Com_WriteProc(var TempPtr: Pointer);
procedure Com_SetDataProc(ReadPtr, WritePtr: Pointer); virtual;
function Com_StartThread: Boolean;
procedure Com_InitVars;
procedure Com_StopThread;
function Com_SendWill(Option: Char): String;
function Com_SendWont(Option: Char): String;
function Com_SendDo(Option: Char): String;
procedure Com_SendRawStr(TempStr: String);
procedure Com_PrepareBufferRead(var CurBuffer: CharBufType; var TempOut: BufArrayObj; BlockLen: Longint);
procedure Com_PrepareBufferWrite(var CurBuffer, TmpOutBuffer: CharBufType; var BlockLen: Longint);
end; { object TTelnetObj }
Type PTelnetObj = ^TTelnetObj;
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
IMPLEMENTATION
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
uses SysUtils;
{$IFDEF FPC}
{$I WINDEF.FPC}
{$ENDIF}
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
Const
{ Telnet Options }
TELNET_IAC = #255; { Interpret as Command }
TELNET_DONT = #254; { Stop performing, or not expecting him to perform }
TELNET_DO = #253; { Perform, or expect him to perform }
TELNET_WONT = #252; { Refusal to perform }
TELNET_WILL = #251; { Desire to perform }
TELNET_SB = #250; { What follow is sub-negotiation of indicated option }
TELNET_GA = #249; { Go ahead signal }
TELNET_EL = #248; { Erase Line function }
TELNET_EC = #247; { Erase Character function }
TELNET_AYT = #246; { Are You There function }
TELNET_AO = #245; { Abort Output function }
TELNET_IP = #244; { Interrupt Process function }
TELNET_BRK = #243; { NVT break character }
TELNET_DM = #242; { Data stream portion of a Synch }
TELNET_NOP = #241; { No operation }
TELNET_SE = #240; { End of sub-negotiation parameters }
TELNET_EOR = #239; { End of record }
TELNET_ABORT = #238; { Abort process }
TELNET_SUSP = #237; { Suspend current process }
TELNET_EOF = #236; { End of file }
TELNETOPT_BINARY = #0; { Transmit binary }
TELNETOPT_ECHO = #1; { Echo mode }
TELNETOPT_SUPGA = #3; { Suppress Go-Ahead }
TELNETOPT_TERM = #24; { Terminal Type }
TELNETOPT_SPEED = #32; { Terminal Speed }
TELNETOPT_FLOWCNT= #33; { Toggle flow-control }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
constructor TTelnetObj.Init;
begin
inherited Init;
ThreadsInitted := false;
NeedNewCarrier := true;
TelnetCarrier := TRUE;
IacState := 0; { default to none }
Com_InitVars;
end; { constructor Init }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
destructor TTelnetObj.Done;
begin
inherited done;
end; { destructor Done }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TTelnetObj.Com_SendRawStr(TempStr: String);
var BytesSnt: Longint;
TmpByte : Longint;
BufFlag : Longint;
TmpError: Longint;
begin
BufFlag := 00;
TmpByte := 01;
REPEAT
BytesSnt := SockSend(ClientRC,
@TempStr[TmpByte],
Length(TempStr),
BufFlag);
if BytesSnt > 0 then
Inc(TmpByte, BytesSnt)
else begin
TmpError := SockErrorNo;
if TmpError <> WSAEWOULDBLOCK then EXIT;
end; { else }
UNTIL (TmpByte > Length(TempStr));
end; { proc. Com_SendRawStr }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function TTelnetObj.Com_SendWill(Option: Char): String;
begin
Result[1] := TELNET_IAC;
Result[2] := TELNET_WILL;
Result[3] := Option;
SetLength(Result, 3);
end; { func. Com_SendWill }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function TTelnetObj.Com_SendWont(Option: Char): String;
begin
Result[1] := TELNET_IAC;
Result[2] := TELNET_WONT;
Result[3] := Option;
SetLength(Result, 3);
end; { func. Com_SendWont }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function TTelnetObj.Com_SendDo(Option: Char): String;
begin
Result[1] := TELNET_IAC;
Result[2] := TELNET_DO;
Result[3] := Option;
SetLength(Result, 3);
end; { func. Com_SendDo }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TTelnetObj.Com_PrepareBufferRead(var CurBuffer: CharBufType; var TempOut: BufArrayObj; BlockLen: Longint);
var Counter : Longint;
begin
Counter := 00;
if BlockLen = 0 then EXIT;
While Counter <= (Blocklen - 01) do
begin
{-- and now handle the IAC state ---------------------------------------}
Case IacState of
1 : begin { DO / DONT }
{-- we received an IAC, and this is the next char --------------}
if CurBuffer[Counter] = TELNET_IAC then
begin
TempOut.Put(CurBuffer[Counter], 1);
IacState := 0; { reset parser state }
end
else begin
IacState := 2;
Case CurBuffer[Counter] of
TELNET_DONT,
TELNET_DO : IacDontDo := 1;
else IacDontDo := 0;
end; { case }
end; { else }
end; { DO/DONT }
2 : begin { WHAT }
{ if IacDontDo = 1 then }
begin
Case CurBuffer[Counter] of
TELNETOPT_BINARY,
TELNETOPT_SUPGA,
TELNETOPT_ECHO : begin
Com_SendRawStr(Com_SendWill(CurBuffer[Counter]));
end
else begin
Com_SendRawStr(Com_SendWont(CurBuffer[Counter]));
end; { if }
end; { case }
end; { if this is a state we will reply to }
IacState := 0; { reset IAC state machine }
end; { WHAT }
else begin
if CurBuffer[Counter] = TELNET_IAC then
begin
IacState := 1
end
else TempOut.Put(CurBuffer[Counter], 1);
end; { else }
end; { case }
{-- and loop through the buffer ----------------------------------------}
Inc(Counter);
end; { while }
end; { proc. Com_PrepareBufferRead }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TTelnetObj.Com_PrepareBufferWrite(var CurBuffer, TmpOutBuffer: CharBufType; var BlockLen: Longint);
var Counter : Longint;
NewCounter: Longint;
begin
Counter := 00;
NewCounter := 00;
if BlockLen = 0 then EXIT;
While Counter <= Blocklen do
begin
Case CurBuffer[Counter] of
TELNET_IAC : begin { Escape command character }
TmpOutBuffer[NewCounter] := TELNET_IAC;
Inc(NewCounter);
TmpOutBuffer[NewCounter] := TELNET_IAC;
Inc(NewCounter);
end; { if }
else begin
TmpOutBuffer[NewCounter] := CurBuffer[Counter];
Inc(NewCounter);
end; { if }
end; { case }
Inc(Counter);
end; { while }
BlockLen := NewCounter - 1;
end; { proc. Com_PrepareBufferWrite }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TTelnetObj.Com_ReadProc(var TempPtr: Pointer);
var Available : Boolean;
BytesRead : Longint;
BlockLen : Longint;
ReturnCode: Longint;
begin
repeat
if DoRxEvent^.WaitForEvent(ReadTimeOut) then
if NOT EndThreads then
begin
CriticalRx^.EnterExclusive;
Available := (SockSelect(ClientRC) > 00);
DoRxEvent^.ResetEvent;
if (Available) OR (NeedNewCarrier) then
begin
{----------- Start reading the gathered date -------------------}
NeedNewCarrier := false;
if InBuffer^.BufRoom > 0 then
begin
BlockLen := InBuffer^.BufRoom;
if BlockLen > 1024 then
BlockLen := 1024;
if BlockLen > 00 then
begin
BytesRead := SockRecv(ClientRC,
@InBuffer^.TmpBuf,
BlockLen,
0);
if BytesRead = 0 then
begin
TelnetCarrier := false;
ReturnCode := SockErrorNo;
ErrorStr := 'Error in communications(1), #'+IntToStr(Returncode)+ ' / '+SysErrorMessage(Returncode);
end; { if }
if BytesRead = -1 then
begin
ReturnCode := SockErrorNo;
if ReturnCode <> WSAEWOULDBLOCK then
begin
TelnetCarrier := false;
ErrorStr := 'Error in communications(2), #'+IntToStr(ReturnCode)+ ' / '+SysErrorMessage(ReturnCode);
EndThreads := true;
end; { if }
end; { error }
if BytesRead > 00 then
begin
Com_PrepareBufferRead(InBuffer^.TmpBuf, InBuffer^, BytesRead);
end; { if }
end; { if }
end; { if }
end; { if available }
CriticalRx^.LeaveExclusive;
end; { if RxEvent }
until EndThreads;
RxClosedEvent^.SignalEvent;
ExitThisThread;
end; { proc. Com_ReadProc }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TTelnetObj.Com_WriteProc(var TempPtr: Pointer);
var BlockLen : Longint;
Written : Longint;
ReturnCode : Longint;
TempBuf : ^CharBufType;
begin
New(TempBuf);
repeat
if DoTxEvent^.WaitForEvent(WriteTimeOut) then
if NOT EndThreads then
begin
CriticalTx^.EnterExclusive;
DoTxEvent^.ResetEvent;
if OutBuffer^.BufUsed > 00 then
begin
BlockLen := OutBuffer^.Get(OutBuffer^.TmpBuf, OutBuffer^.BufUsed, false);
Com_PrepareBufferWrite(OutBuffer^.TmpBuf, TempBuf^, BlockLen);
Written := SockSend(ClientRC,
TempBuf,
BlockLen,
0);
{-- remove the data from the buffer, but only remove the data ---}
{-- thats actually written --------------------------------------}
ReturnCode := OutBuffer^.Get(OutBuffer^.TmpBuf, Written, true);
if ReturnCode <> Longint(Written) then
begin
{ not everything is removed! }
end; { if }
{-- if theres data in the buffer left, run this event again -----}
if Written <> BlockLen then
begin
DoTxEvent^.SignalEvent;
end; { if }
end; { if }
CriticalTx^.LeaveExclusive;
end; { if }
until EndThreads;
Dispose(TempBuf);
TxClosedEvent^.SignalEvent;
ExitThisThread;
end; { proc. Com_WriteProc }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function TTelnetObj.Com_StartThread: Boolean;
begin
Result := false;
EndThreads := false;
if ThreadsInitted then EXIT;
ThreadsInitted := true;
{----------------------- Create all the events ----------------------------}
New(DoTxEvent, Init);
if NOT DoTxEvent^.CreateEvent(false) then EXIT;
New(DoRxEvent, Init);
if NOT DoRxEvent^.CreateEvent(false) then EXIT;
New(RxClosedEvent, Init);
if NOT RxClosedEvent^.CreateEvent(false) then EXIT;
New(TxClosedEvent, Init);
if NOT TxClosedEvent^.CreateEvent(false) then EXIT;
{-------------- Startup the buffers and overlapped events -----------------}
New(InBuffer, Init(InBufSize));
New(OutBuffer, Init(OutBufSize));
{-------------------- Startup a seperate write thread ---------------------}
New(CriticalTx, Init);
CriticalTx^.CreateExclusive;
New(TxThread, Init);
if NOT TxThread^.CreateThread(16384, { Stack size }
WriteProcPtr, { Actual procedure }
nil, { Parameters }
0) { Creation flags }
then EXIT;
{-------------------- Startup a seperate read thread ----------------------}
New(CriticalRx, Init);
CriticalRx^.CreateExclusive;
New(RxThread, Init);
if NOT RxThread^.CreateThread(16384, { Stack size }
ReadProcPtr, { Actual procedure }
nil, { Parameters }
0) { Creation flags }
then EXIT;
Result := true;
end; { proc. Com_StartThread }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TTelnetObj.Com_InitVars;
begin
DoTxEvent := nil;
DoRxEvent := nil;
RxClosedEvent := nil;
TxClosedEvent := nil;
TxThread := nil;
RxThread := nil;
InBuffer := nil;
OutBuffer := nil;
CriticalRx := nil;
CriticalTx := nil;
end; { proc. Com_InitVars }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TTelnetObj.Com_StopThread;
begin
EndThreads := true;
ThreadsInitted := false;
if DoTxEvent <> nil then DoTxEvent^.SignalEvent;
if DoTxEvent <> nil then DoRxEvent^.SignalEvent;
if TxThread <> nil then TxThread^.CloseThread;
if RxThread <> nil then RxThread^.CloseThread;
if TxClosedEvent <> nil then
if NOT TxClosedEvent^.WaitForEvent(1000) then
TxThread^.TerminateThread(0);
if RxClosedEvent <> nil then
if NOT RxClosedEvent^.WaitForEvent(1000) then
RxThread^.TerminateThread(0);
if TxThread <> nil then Dispose(TxThread, Done);
if RxThread <> nil then Dispose(RxThread, Done);
if DoTxEvent <> nil then Dispose(DoTxEvent, Done);
if DoRxEvent <> nil then Dispose(DoRxEvent, Done);
if RxClosedEvent <> nil then Dispose(RxClosedEvent, Done);
if TxClosedEvent <> nil then Dispose(TxClosedEvent, Done);
if CriticalTx <> nil then Dispose(CriticalTx, Done);
if CriticalRx <> nil then Dispose(CriticalRx, Done);
if InBuffer <> nil then Dispose(InBuffer, Done);
if OutBuffer <> nil then Dispose(OutBuffer, Done);
Com_InitVars;
end; { proc. Com_StopThread }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function TTelnetObj.Com_GetHandle: Longint;
begin
Result := ClientRC;
end; { func. Com_GetHandle }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TTelnetObj.Com_OpenQuick(Handle: Longint);
var ReturnCode: Longint;
begin
ClientRC := Handle;
if (NOT (SockInit=0)) then
begin
ReturnCode := SockErrorNo;
ErrorStr := 'Error in initializing socket, #'+IntToStr(Returncode)+ ' / '+SysErrorMessage(Returncode);
InitFailed := true;
end
else InitFailed := NOT Com_StartThread;
{ Set the telnet to binary transmission }
Com_SendRawStr(Com_SendWill(TELNETOPT_ECHO));
Com_SendRawStr(Com_SendWill(TELNETOPT_BINARY));
end; { proc. TTelnetObj.Com_OpenQuick }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function TTelnetObj.Com_OpenKeep(Comport: Byte): Boolean;
begin
InitFailed := NOT Com_StartThread;
Com_OpenKeep := InitFailed;
end; { func. Com_OpenKeep }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function TTelnetObj.Com_Open(Comport: Byte; BaudRate: Longint; DataBits: Byte;
Parity: Char; StopBits: Byte): Boolean;
begin
Com_Open := true;
end; { func. TTelnetObj.Com_OpenCom }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TTelnetObj.Com_SetLine(BpsRate: longint; Parity: Char; DataBits, Stopbits: Byte);
begin
// Duhhh ;)
end; { proc. TTelnetObj.Com_SetLine }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TTelnetObj.Com_Close;
begin
if DontClose then EXIT;
if ClientRC <> -1 then
begin
Com_StopThread;
SockShutdown(ClientRC, 02);
SockClose(ClientRC);
ClientRC := -1;
end; { if }
end; { func. TTelnetObj.Com_CloseCom }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function TTelnetObj.Com_SendChar(C: Char): Boolean;
var Written: Longint;
begin
Com_SendBlock(C, SizeOf(C), Written);
Com_SendChar := (Written = SizeOf(c));
end; { proc. TTelnetObj.Com_SendChar }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function TTelnetObj.Com_GetChar: Char;
var Reads: Longint;
begin
Com_ReadBlock(Result, SizeOf(Result), Reads);
end; { func. TTelnetObj.Com_GetChar }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function TTelnetObj.Com_PeekChar: Char;
var Reads: Longint;
begin
Com_PeekBlock(Result, SizeOf(Result), Reads);
end; { func. TTelnetObj.Com_GetChar }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TTelnetObj.Com_SendBlock(var Block; BlockLen: Longint; var Written: Longint);
begin
if OutBuffer^.BufRoom < BlockLen then
repeat
{$IFDEF WIN32}
Sleep(1);
{$ENDIF}
{$IFDEF OS2}
DosSleep(1);
{$ENDIF}
until (OutBuffer^.BufRoom >= BlockLen) OR (NOT Com_Carrier);
CriticalTx^.EnterExclusive;
Written := OutBuffer^.Put(Block, BlockLen);
CriticalTx^.LeaveExclusive;
DoTxEvent^.SignalEvent;
end; { proc. TTelnetObj.Com_SendBlock }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TTelnetObj.Com_ReadBlock(var Block; BlockLen: Longint; var Reads: Longint);
begin
if InBuffer^.BufUsed < BlockLen then
begin
DoRxEvent^.SignalEvent;
repeat
{$IFDEF OS2}
DosSleep(1);
{$ENDIF}
{$IFDEF WIN32}
Sleep(1);
{$ENDIF}
if Com_CharAvail then
DoRxEvent^.SignalEvent;
until (InBuffer^.BufUsed >= BlockLen) OR (NOT Com_Carrier);
end; { if }
Reads := InBuffer^.Get(Block, BlockLen, true);
end; { proc. TTelnetObj.Com_ReadBlock }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TTelnetObj.Com_PeekBlock(var Block; BlockLen: Longint; var Reads: Longint);
begin
if InBuffer^.BufUsed < BlockLen then
begin
DoRxEvent^.SignalEvent;
repeat
{$IFDEF OS2}
DosSleep(1);
{$ENDIF}
{$IFDEF WIN32}
Sleep(1);
{$ENDIF}
if Com_CharAvail then
DoRxEvent^.SignalEvent;
until (InBuffer^.BufUsed >= BlockLen) OR (NOT Com_Carrier);
end; { if }
Reads := InBuffer^.Get(Block, BlockLen, false);
end; { proc. TTelnetObj.Com_PeekBlock }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function TTelnetObj.Com_CharAvail: Boolean;
begin
if InBuffer^.BufUsed < 1 then
begin
if (SockSelect(ClientRC) > 0) then
DoRxEvent^.SignalEvent;
end; { if }
Result := (InBuffer^.BufUsed > 0);
end; { func. TTelnetObj.Com_CharAvail }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function TTelnetObj.Com_Carrier: Boolean;
begin
if TelnetCarrier then { Carrier is only lost in 'read' sections }
begin
DoRxEvent^.SignalEvent;
NeedNewCarrier := true;
end; { if }
Result := TelnetCarrier;
end; { func. TTelnetObj.Com_Carrier }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TTelnetObj.Com_GetModemStatus(var LineStatus, ModemStatus: Byte);
begin
LineStatus := 00;
ModemStatus := 08;
if Com_Carrier then ModemStatus := ModemStatus OR (1 SHL 7);
end; { proc. TTelnetObj.Com_GetModemStatus }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TTelnetObj.Com_SetDtr(State: Boolean);
begin
if NOT State then
begin
Com_Close;
end; { if }
end; { proc. TTelnetObj.Com_SetDtr }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function TTelnetObj.Com_GetBpsRate: Longint;
begin
Com_GetBpsRate := 115200;
end; { func. TTelnetObj.Com_GetBpsRate }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TTelnetObj.Com_GetBufferStatus(var InFree, OutFree, InUsed, OutUsed: Longint);
begin
DoRxEvent^.SignalEvent;
DoTxEvent^.SignalEvent;
InFree := InBuffer^.BufRoom;
OutFree := OutBuffer^.BufRoom;
InUsed := InBuffer^.BufUsed;
OutUsed := OutBuffer^.BufUsed;
end; { proc. TTelnetObj.Com_GetBufferStatus }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TTelnetObj.Com_PurgeInBuffer;
begin
CriticalRx^.EnterExclusive;
InBuffer^.Clear;
CriticalRx^.LeaveExclusive;
end; { proc. TTelnetObj.Com_PurgeInBuffer }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TTelnetObj.Com_PurgeOutBuffer;
begin
CriticalTx^.EnterExclusive;
OutBuffer^.Clear;
CriticalTx^.LeaveExclusive;
end; { proc. TTelnetObj.Com_PurgeInBuffer }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function TTelnetObj.Com_ReadyToSend(BlockLen: Longint): Boolean;
begin
Result := OutBuffer^.BufRoom >= BlockLen;
end; { func. ReadyToSend }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TTelnetObj.Com_PauseCom(CloseCom: Boolean);
begin
if CloseCom then Com_Close
else Com_StopThread;
end; { proc. Com_PauseCom }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TTelnetObj.Com_ResumeCom(OpenCom: Boolean);
begin
if OpenCom then Com_OpenKeep(0)
else Com_StartThread;
end; { proc. Com_ResumeCom }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TTelnetObj.Com_SetDataProc(ReadPtr, WritePtr: Pointer);
begin
ReadProcPtr := ReadPtr;
WriteProcPtr := WritePtr;
end; { proc. Com_SetDataProc }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
end.

421
SOURCE/ELECOM/THREADS.PAS Normal file
View File

@ -0,0 +1,421 @@
unit THREADS;
(*
**
** Serial and TCP/IP communication routines for DOS, OS/2 and Win9x/NT.
** Tested with: TurboPascal v7.0, (DOS)
** VirtualPascal v2.1, (OS/2, Win32)
** FreePascal v0.99.12 (DOS, Win32)
** Delphi v4.0. (Win32)
**
** Version : 1.01
** Created : 07-Mar-1999
** Last update : 26-Sep-1999
**
** Note: (c) 1998-1999 by Maarten Bekers
**
*)
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
INTERFACE
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
{$IFDEF OS2}
uses Os2Base;
{$ENDIF}
{$IFDEF WIN32}
uses Windows;
{$ENDIF}
{$IFDEF OS2}
Type THandle = Longint;
DWORD = Longint;
{$ENDIF}
{$IFDEF WIN32}
{$IFDEF FPC}
Type THandle = Handle;
{$ENDIF}
{$ENDIF}
type TSysEventObj = Object
{$IFDEF OS2}
SemHandle: HEV;
{$ENDIF}
{$IFDEF WIN32}
SemHandle: THandle;
{$ENDIF}
constructor init;
destructor done;
procedure DisposeEvent;
procedure SignalEvent;
procedure ResetEvent;
function CreateEvent(InitialState: Boolean): Boolean;
function WaitForEvent(TimeOut: Longint): Boolean;
end; { TSysEventObj }
Type PSysEventObj = ^TSysEventObj;
type TExclusiveObj = Object
{$IFDEF OS2}
Exclusive: PHMtx;
{$ENDIF}
{$IFDEF WIN32}
Exclusive: PRTLCriticalSection;
{$ENDIF}
constructor Init;
destructor Done;
procedure CreateExclusive;
procedure DisposeExclusive;
procedure EnterExclusive;
procedure LeaveExclusive;
end; { TExclusiveObj }
Type PExclusiveObj = ^TExclusiveObj;
type TThreadsObj = Object
ThreadHandle : THandle;
ThreadID : DWORD;
ThreadClosed : Boolean;
constructor Init;
destructor Done;
function CreateThread(StackSize : Longint;
CallProc,
Parameters : Pointer;
CreationFlags: Longint): Boolean;
procedure CloseThread;
procedure TerminateThread(ExitCode: Longint);
end; { TThreadsObj }
Type PThreadsObj = ^TThreadsObj;
procedure ExitThisThread;
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
IMPLEMENTATION
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
constructor TSysEventObj.Init;
begin
SemHandle := 0;
end; { constructor Init }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
destructor TSysEventObj.Done;
begin
if Longint(SemHandle) <> -1 then
begin
SignalEvent;
DisposeEvent;
end; { if }
end; { destructor Done }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function TSysEventObj.CreateEvent(InitialState: Boolean): Boolean;
{$IFDEF OS2}
var Returncode: longint;
{$ENDIF}
begin
CreateEvent := true;
{$IFDEF WIN32}
SemHandle := Windows.CreateEvent(nil, true, InitialState, nil);
if Longint(SemHandle) = -1 then CreateEvent := false;
{$ENDIF}
{$IFDEF OS2}
returncode := DosCreateEventSem(nil, SemHandle, 0, InitialState);
CreateEvent := (returncode=0);
{$ENDIF}
end; { func. CreateEvent }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TSysEventObj.SignalEvent;
{$IFDEF OS2}
var RC: Longint;
{$ENDIF}
begin
{$IFDEF WIN32}
if Longint(SemHandle) <> -1 then
SetEvent(SemHandle);
{$ENDIF}
{$IFDEF OS2}
if SemHandle <> -1 then
RC := DosPostEventSem(SemHandle);
{$ENDIF}
end; { proc. SignalEvent }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TSysEventObj.ResetEvent;
{$IFDEF OS2}
var Flag: Longint;
RC : Longint;
{$ENDIF}
begin
{$IFDEF WIN32}
if SemHandle <> THandle(-1) then
Windows.ResetEvent(SemHandle);
{$ENDIF}
{$IFDEF OS2}
Flag := 0;
if SemHandle <> -1 then
RC := DosResetEventSem(SemHandle, Flag);
{$ENDIF}
end; { proc. ResetEvent }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function TSysEventObj.WaitForEvent(TimeOut: Longint): Boolean;
var ReturnCode: Longint;
{$IFDEF OS2}
Flag : Longint;
{$ENDIF}
begin
{$IFDEF WIN32}
if SemHandle <> THandle(-1) then
ReturnCode := WaitForSingleObject(SemHandle, Timeout)
else ReturnCode := 0;
WaitForEvent := (ReturnCode = WAIT_OBJECT_0);
{$ENDIF}
{$IFDEF OS2}
if SemHandle <> -1 then
ReturnCode := DosWaitEventSem(SemHandle, TimeOut);
Flag := 0;
DosResetEventSem(SemHandle, Flag);
WaitForEvent := (ReturnCode = 0);
{$ENDIF}
end; { func. WaitForEvent }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TSysEventObj.DisposeEvent;
{$IFDEF OS2}
var Flag: Longint;
{$ENDIF}
begin
{$IFDEF WIN32}
if SemHandle <> THandle(-1) then CloseHandle(SemHandle);
SemHandle := 0;
{$ENDIF}
{$IFDEF OS2}
Flag := 0;
if SemHandle <> -1 then DosCloseEventSem(SemHandle);
SemHandle := -1;
{$ENDIF}
end; { proc. DisposeEvent }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
constructor TExclusiveObj.Init;
begin
Exclusive := nil;
end; { constructor Init }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
destructor TExclusiveObj.Done;
begin
if Exclusive <> nil then
DisposeExclusive;
end; { destructor Done }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TExclusiveObj.CreateExclusive;
begin
{$IFDEF WIN32}
New(Exclusive);
InitializeCriticalSection(Exclusive^);
{$ENDIF}
{$IFDEF OS2}
New(Exclusive);
DosCreateMutexSem(nil, Exclusive^, dcmw_Wait_All, false);
{$ENDIF}
end; { proc. CreateExclusive }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TExclusiveObj.DisposeExclusive;
begin
{$IFDEF WIN32}
if Exclusive <> nil then
begin
DeleteCriticalSection(Exclusive^);
Dispose(Exclusive);
end; { if }
Exclusive := nil;
{$ENDIF}
{$IFDEF OS2}
if Exclusive <> nil then
begin
DosCloseMutexSem(Exclusive^);
Dispose(Exclusive);
end; { if }
Exclusive := nil;
{$ENDIF}
end; { proc. DisposeExclusive }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TExclusiveObj.EnterExclusive;
begin
{$IFDEF WIN32}
EnterCriticalSection(Exclusive^);
{$ENDIF}
{$IFDEF OS2}
DosRequestMutexSem(Exclusive^, sem_Indefinite_Wait);
{$ENDIF}
end; { proc. EnterExclusive }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TExclusiveObj.LeaveExclusive;
begin
{$IFDEF WIN32}
LeaveCriticalSection(Exclusive^);
{$ENDIF}
{$IFDEF OS2}
DosReleaseMutexSem(Exclusive^);
{$ENDIF}
end; { proc. LeaveExclusive }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
constructor TThreadsObj.Init;
begin
ThreadHandle := 0;
ThreadId := 0;
end; { constructor Init }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
destructor TThreadsObj.Done;
begin
CloseThread;
ThreadHandle := 0;
end; { destructor Done }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function TThreadsObj.CreateThread(StackSize : Longint;
CallProc,
Parameters : Pointer;
CreationFlags: Longint): Boolean;
var ReturnCode: Longint;
begin
ThreadClosed := FALSE;
{$IFNDEF VirtualPascal}
{$IFDEF WIN32}
ThreadHandle := Windows.CreateThread(nil, { Security attrs }
StackSize, { Stack size }
CallProc, { Actual procedure }
Parameters, { Parameters }
CreationFlags, { Creation flags }
ThreadID); { Thread ID ?? }
CreateThread := (ThreadHandle <> THandle(-1));
{$ENDIF}
{$IFDEF OS2}
ReturnCode :=
DosCreateThread(ThreadHandle, { ThreadHandle }
CallProc, { Actual procedure }
Longint(Parameters), { Parameters }
CreationFlags, { Creation flags }
StackSize); { Stacksize }
CreateThread := (ReturnCode = 0);
if ReturnCode <> 0 then ThreadHandle := -1;
{$ENDIF}
{$IFDEF LINUX}
{$ENDIF}
{$ELSE}
ThreadHandle := BeginThread(nil, StackSize, CallProc, Parameters, 0, ReturnCode);
CreateThread := (ThreadHandle > THandle(-1));
{$ENDIF}
end; { proc. CreateThread }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TThreadsObj.CloseThread;
begin
ThreadClosed := TRUE;
{$IFDEF WIN32}
if ThreadHandle <> Thandle(-1) then CloseHandle(ThreadHandle);
ThreadHandle := 0;
{$ENDIF}
{$IFDEF OS2}
{!! DosClose() on a ThreadHandle doesn't work - will eventually close }
{!! other handles ... }
{ if ThreadHandle <> -1 then DosClose(ThreadHandle); }
ThreadHandle := -1;
{$ENDIF}
end; { proc. CloseThread }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TThreadsObj.TerminateThread(ExitCode: Longint);
begin
ThreadClosed := TRUE;
{$IFDEF WIN32}
if ThreadHandle <> Thandle(-1) then
Windows.TerminateThread(ThreadHandle, ExitCode);
ThreadHandle := 00;
{$ENDIF}
{$IFDEF OS2}
if ThreadHandle <> -1 then DosKillThread(ThreadHandle);
ThreadHandle := -1;
{$ENDIF}
end; { proc. TerminateThread }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure ExitThisThread;
begin
{$IFDEF WIN32}
Windows.ExitThread(0);
{$ENDIF}
{$IFDEF OS2}
Os2Base.DosExit(exit_Thread, 0);
{$ENDIF}
end; { proc. ExitThread }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
end.

824
SOURCE/ELECOM/W32SNGL.PAS Normal file
View File

@ -0,0 +1,824 @@
unit W32SNGL;
(*
**
** Serial and TCP/IP communication routines for DOS, OS/2 and Win9x/NT.
** Tested with: TurboPascal v7.0, (DOS)
** VirtualPascal v2.1, (OS/2, Win32)
** FreePascal v0.99.15 (DOS, Win32)
** Delphi v4.0. (Win32)
**
** Version : 1.02
** Created : 09-Sep-1999
** Last update : 21-Jul-2001
**
** Note: (c) 1998-2000 by Maarten Bekers
**
** Note2: The problem with this approach that we only retrieve the data when
** we want to. If data arrives and we dont call either Com_ReadBlock(),
** Com_CharAvail or Com_GetBufferStatus() we dont receive the data.
** Therefore, we rely on Windows to actually buffer the data. We do this
** by calling SetupComm() with the buffer-sizes as defined by
** Win32OutBufSize and Win32InBufSize.
** If you want to avoid this, you can implement another mutex that you
** let set by Win32's API calls SetEventMask() and WaitCommEvent().
** That way, you can also monitor other events which would eliminate
** some overhead. In general, this approach will suffice.
**
*)
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
INTERFACE
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
uses Windows, Combase, BufUnit, Threads
{$IFDEF VirtualPascal}
,Use32
{$ENDIF};
Const DataTimeout = 20000; { Wait max. 20 secs }
InBufSize = 1024 * 32;
OutBufSize = 1024 * 32;
Win32OutBufSize = 1024 * 3;
Win32InBufSize = 1024 * 3;
type TWin32Obj = Object(TCommObj)
DataProcPtr: Pointer; { Pointer to TX/RX handler (thread) }
ThreadsInitted: Boolean; { Are the thread(s) up and running? }
SaveHandle : THandle;
InitPortNr : Longint;
InitHandle : Longint;
ReadOL : TOverLapped; { Overlapped structure for ReadFile }
WriteOL : TOverLapped; { Overlapped structure for WriteFile }
InBuffer : ^BufArrayObj; { Buffer system internally used }
OutBuffer : ^BufArrayObj;
ReadEvent : PSysEventObj; { Event set by ReadFile overlapped routine }
WriteEvent : PSysEventObj; { Event set by WriteFile overlapped routine }
DoTxEvent : PSysEventObj;{ Event manually set when we have to transmit }
DoRxEvent : PSysEventObj; { Event manually set when we want data }
DataClosedEvent: PSysEventObj; { Event set when the Tx thread is closed }
CriticalTx : PExclusiveObj; { Critical sections }
CriticalRx : PExclusiveObj;
DataThread : PThreadsObj;
EndThreads : Boolean; { Set to true when we have to end the threads }
constructor Init;
destructor Done;
function Com_Open(Comport: Byte; BaudRate: Longint; DataBits: Byte;
Parity: Char; StopBits: Byte): Boolean; virtual;
function Com_OpenKeep(Comport: Byte): Boolean; virtual;
function Com_GetChar: Char; virtual;
function Com_CharAvail: Boolean; virtual;
function Com_Carrier: Boolean; virtual;
function Com_SendChar(C: Char): Boolean; virtual;
function Com_ReadyToSend(BlockLen: Longint): Boolean; virtual;
function Com_GetBPSrate: Longint; virtual;
function Com_GetHandle: Longint; virtual;
procedure Com_OpenQuick(Handle: Longint); virtual;
procedure Com_Close; virtual;
procedure Com_SendBlock(var Block; BlockLen: Longint; var Written: Longint); virtual;
procedure Com_ReadBlock(var Block; BlockLen: Longint; var Reads: Longint); virtual;
procedure Com_GetBufferStatus(var InFree, OutFree, InUsed, OutUsed: Longint); virtual;
procedure Com_SetDtr(State: Boolean); virtual;
procedure Com_GetModemStatus(var LineStatus, ModemStatus: Byte); virtual;
procedure Com_SetLine(BpsRate: longint; Parity: Char; DataBits, Stopbits: Byte); virtual;
procedure Com_PurgeInBuffer; virtual;
procedure Com_PurgeOutBuffer; virtual;
procedure Com_FlushOutBuffer(Slice: SliceProc); virtual;
procedure Com_PauseCom(CloseCom: Boolean); virtual;
procedure Com_ResumeCom(OpenCom: Boolean); virtual;
procedure Com_SetFlow(SoftTX, SoftRX, Hard: Boolean); virtual;
procedure Com_SetDataProc(ReadPtr, WritePtr: Pointer); virtual;
procedure Com_DataProc(var TempPtr: Pointer); virtual;
function Com_StartThread: Boolean;
procedure Com_InitVars;
procedure Com_StopThread;
procedure Com_InitDelayTimes;
end; { object TWin32Obj }
type PWin32Obj = ^TWin32Obj;
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
IMPLEMENTATION
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
uses SysUtils;
{$IFDEF FPC}
{$I WINDEF.FPC}
{$ENDIF}
const
dcb_Binary = $00000001;
dcb_ParityCheck = $00000002;
dcb_OutxCtsFlow = $00000004;
dcb_OutxDsrFlow = $00000008;
dcb_DtrControlMask = $00000030;
dcb_DtrControlDisable = $00000000;
dcb_DtrControlEnable = $00000010;
dcb_DtrControlHandshake = $00000020;
dcb_DsrSensivity = $00000040;
dcb_TXContinueOnXoff = $00000080;
dcb_OutX = $00000100;
dcb_InX = $00000200;
dcb_ErrorChar = $00000400;
dcb_NullStrip = $00000800;
dcb_RtsControlMask = $00003000;
dcb_RtsControlDisable = $00000000;
dcb_RtsControlEnable = $00001000;
dcb_RtsControlHandshake = $00002000;
dcb_RtsControlToggle = $00003000;
dcb_AbortOnError = $00004000;
dcb_Reserveds = $FFFF8000;
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
constructor TWin32Obj.Init;
begin
inherited Init;
InitPortNr := -1;
InitHandle := -1;
ThreadsInitted := false;
Com_Initvars;
end; { constructor Init }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
destructor TWin32Obj.Done;
begin
inherited done;
end; { destructor Done }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TWin32Obj.Com_DataProc(var TempPtr: Pointer);
var Success : Boolean;
Props : TCommProp;
ObjectCode : Longint;
ReturnCode : Longint;
DidRead : DWORD;
Written : DWORD;
BlockLen : DWORD;
ObjectArray : Array[0..1] of THandle;
TryReading : Boolean;
Stats : TComStat;
ErrMask : DWORD;
begin
ObjectArray[0] := DoTxEvent^.SemHandle;
ObjectArray[1] := DoRxEvent^.SemHandle;
repeat
ObjectCode := WaitForMultipleObjects(2,
@ObjectArray,
false,
DataTimeOut);
if EndThreads then EXIT;
{-----------------------------------------------------------------------}
{-------------------------- Receive signalled --------------------------}
{-----------------------------------------------------------------------}
if (ObjectCode - WAIT_OBJECT_0) = 1 then { DoReceive }
begin
DidRead := 00;
if (EndThreads) then EXIT;
{-- Make sure there is something to be read ------------------------}
ErrMask := 0;
TryReading := FALSE;
if ClearCommError(SaveHandle, ErrMask, @Stats) then
if Stats.cbInQue > 0 then
TryReading := TRUE;
{----------------- Start reading the gathered date -----------------}
if TryReading then
begin
CriticalRx^.EnterExclusive;
FillChar(Props, SizeOf(TCommProp), 0);
if GetCommProperties(SaveHandle, Props) then
if InBuffer^.BufRoom > 0 then
begin
BlockLen := Props.dwCurrentRxQueue;
{ We want the complete BUFFER size, and not }
{ the actual queue size. The queue may have }
{ grown since last query, and we always }
{ want as much data as possible }
if Longint(BlockLen) > InBuffer^.BufRoom then
BlockLen := InBuffer^.BufRoom;
Success := ReadFile(SaveHandle,
InBuffer^.TmpBuf,
BlockLen,
DidRead,
@ReadOL);
if NOT Success then
begin
ReturnCode := GetLastError;
if ReturnCode = ERROR_IO_PENDING then
begin
ReturnCode := WaitForSingleObject(ReadOL.hEvent, DataTimeOut);
if ReturnCode = WAIT_OBJECT_0 then
begin
GetOverLappedResult(SaveHandle, ReadOL, DidRead, false);
end; { if }
end; { if }
end
else GetOverlappedResult(SaveHandle, ReadOL, DidRead, false);
if DidRead > 00 then
begin
InBuffer^.Put(InBuffer^.TmpBuf, DidRead);
DoRxEvent^.ResetEvent;
end; { if }
end; { if }
CriticalRx^.LeaveExclusive;
end; { try reading }
end; { DoReceive call }
{-----------------------------------------------------------------------}
{-------------------------- Transmit signalled -------------------------}
{-----------------------------------------------------------------------}
if (ObjectCode - WAIT_OBJECT_0) = 0 then { DoTransmit }
begin
CriticalTx^.EnterExclusive;
DoTxEvent^.ResetEvent;
if OutBuffer^.BufUsed > 00 then
begin
Written := 00;
BlockLen := OutBuffer^.Get(OutBuffer^.TmpBuf, OutBuffer^.BufUsed, false);
Success := WriteFile(SaveHandle,
OutBuffer^.TmpBuf,
BlockLen,
Written,
@WriteOL);
if NOT Success then
begin
ReturnCode := GetLastError;
if ReturnCode = ERROR_IO_PENDING then
begin
ReturnCode := WaitForSingleObject(WriteOL.hEvent, DataTimeOut);
if ReturnCode = WAIT_OBJECT_0 then
begin
if GetOverLappedResult(SaveHandle, WriteOL, Written, false) then
begin
ResetEvent(WriteOL.hEvent);
end; { if }
end; { if }
end; { result is pending }
end { if }
else begin
if GetOverLappedResult(SaveHandle, WriteOL, Written, false) then
begin
ResetEvent(WriteOL.hEvent);
end; { if }
end; { if (did succeed) }
{-- remove the data from the buffer, but only remove the data ---}
{-- thats actually written --------------------------------------}
ReturnCode := OutBuffer^.Get(OutBuffer^.TmpBuf, Written, true);
if ReturnCode <> Longint(Written) then
begin
{ not everything is removed! }
end; { if }
{-- if theres data in the buffer left, run this event again -----}
if Written <> BlockLen then
DoTxEvent^.SignalEvent;
end; { if }
CriticalTx^.LeaveExclusive;
end; { DoTransmit call }
until EndThreads;
DataClosedEvent^.SignalEvent;
ExitThisThread;
end; { proc. ComDataProc }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function TWin32Obj.Com_StartThread: Boolean;
begin
Result := false;
EndThreads := false;
if ThreadsInitted then EXIT;
ThreadsInitted := true;
{----------------------- Create all the events ----------------------------}
New(ReadEvent, Init);
if NOT ReadEvent^.CreateEvent(true) then EXIT;
New(WriteEvent, Init);
if NOT WriteEvent^.CreateEvent(true) then EXIT;
New(DoTxEvent, Init);
if NOT DoTxEvent^.CreateEvent(false) then EXIT;
New(DoRxEvent, Init);
if NOT DoRxEvent^.CreateEvent(false) then EXIT;
New(DataClosedEvent, Init);
if NOT DataClosedEvent^.CreateEvent(false) then EXIT;
{-------------- Startup the buffers and overlapped events -----------------}
FillChar(WriteOL, SizeOf(tOverLapped), 0);
FillChar(ReadOL, SizeOf(tOverLapped), 0);
WriteOl.hEvent := WriteEvent^.SemHandle;
ReadOl.hEvent := ReadEvent^.SemHandle;
New(InBuffer, Init(InBufSize));
New(OutBuffer, Init(OutBufSize));
{-------------------- Startup the critical section objects ----------------}
New(CriticalTx, Init);
CriticalTx^.CreateExclusive;
New(CriticalRx, Init);
CriticalRx^.CreateExclusive;
{-------------------- Startup a seperate tx / rx thread -------------------}
New(DataThread, Init);
if NOT DataThread^.CreateThread(16384, { Stack size }
DataProcPtr, { Actual procedure }
nil, { Parameters }
0) { Creation flags }
then EXIT;
Result := true;
end; { proc. Com_StartThread }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TWin32Obj.Com_InitVars;
begin
DoTxEvent := nil;
DoRxEvent := nil;
DataClosedEvent := nil;
DataThread := nil;
ReadEvent := nil;
WriteEvent := nil;
InBuffer := nil;
OutBuffer := nil;
CriticalRx := nil;
CriticalTx := nil;
end; { proc. Com_InitVars }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TWin32Obj.Com_StopThread;
begin
EndThreads := true;
ThreadsInitted := false;
if DoTxEvent <> nil then DoTxEvent^.SignalEvent;
if DoTxEvent <> nil then DoRxEvent^.SignalEvent;
if DataThread <> nil then DataThread^.CloseThread;
if DataClosedEvent <> nil then
if NOT DataClosedEvent^.WaitForEvent(1000) then
DataThread^.TerminateThread(0);
if DataThread <> nil then Dispose(DataThread, Done);
if DoTxEvent <> nil then Dispose(DoTxEvent, Done);
if DoRxEvent <> nil then Dispose(DoRxEvent, Done);
if DataClosedEvent <> nil then Dispose(DataClosedEvent, Done);
if ReadEvent <> nil then Dispose(ReadEvent, Done);
if WriteEvent <> nil then Dispose(WriteEvent, Done);
if CriticalTx <> nil then Dispose(CriticalTx, Done);
if CriticalRx <> nil then Dispose(CriticalRx, Done);
if InBuffer <> nil then Dispose(InBuffer, Done);
if OutBuffer <> nil then Dispose(OutBuffer, Done);
Com_InitVars;
end; { proc. Com_StopThread }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TWin32Obj.Com_InitDelayTimes;
var CommTimeOut: TCommTimeouts;
RC : Longint;
begin
FillChar(CommTimeOut, SizeOf(TCommTimeOuts), 00);
CommTimeOut.ReadIntervalTimeout := MAXDWORD;
if NOT SetCommTimeOuts(SaveHandle, CommTimeOut) then
begin
RC := GetLastError;
ErrorStr := 'Error setting communications timeout: #'+IntToStr(RC) + ' / ' + SysErrorMessage(rc);
end; { if }
end; { proc. InitDelayTimes }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function TWin32Obj.Com_GetHandle: Longint;
begin
Result := SaveHandle;
end; { func. Com_GetHandle }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TWin32Obj.Com_OpenQuick(Handle: Longint);
var LastError: Longint;
begin
SaveHandle := Handle;
InitHandle := Handle;
FillChar(ReadOl, SizeOf(ReadOl), 00);
FillChar(WriteOl, SizeOf(WriteOl), 00);
if NOT SetupComm(Com_GetHandle, Win32InBufSize, Win32OutBufSize) then
begin
LastError := GetLastError;
ErrorStr := 'Error setting up communications buffer: #'+IntToStr(LastError) + ' / '+SysErrorMessage(LastError);
end; { if }
Com_InitDelayTimes;
InitFailed := NOT Com_StartThread;
Com_SetLine(-1, 'N', 8, 1);
end; { proc. TWin32Obj.Com_OpenQuick }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function TWin32Obj.Com_OpenKeep(Comport: Byte): Boolean;
var TempSave : THandle;
Security : TSECURITYATTRIBUTES;
LastError : Longint;
begin
InitPortNr := Comport;
FillChar(ReadOl, SizeOf(ReadOl), 00);
FillChar(WriteOl, SizeOf(WriteOl), 00);
FillChar(Security, SizeOf(TSECURITYATTRIBUTES), 0);
Security.nLength := SizeOf(TSECURITYATTRIBUTES);
Security.lpSecurityDescriptor := nil;
Security.bInheritHandle := true;
TempSave := CreateFile(PChar('\\.\COM' + IntToStr(ComPort)),
GENERIC_READ or GENERIC_WRITE,
0,
@Security, { No Security }
OPEN_EXISTING, { Creation action }
FILE_ATTRIBUTE_NORMAL or FILE_FLAG_OVERLAPPED,
0); { No template }
LastError := GetLastError;
if LastError <> 0 then
ErrorStr := 'Unable to open communications port';
SaveHandle := TempSave;
Result := (TempSave <> INVALID_HANDLE_VALUE);
if Result then { Make sure that "CharAvail" isn't going to wait }
begin
Com_InitDelayTimes;
end; { if }
if NOT SetupComm(Com_GetHandle, Win32InBufSize, Win32OutBufSize) then
begin
LastError := GetLastError;
ErrorStr := 'Error setting up communications buffer: #'+IntToStr(LastError) + ' / '+SysErrorMessage(LastError);
end; { if }
InitFailed := NOT Com_StartThread;
end; { func. Com_OpenKeep }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function TWin32Obj.Com_Open(Comport: Byte; BaudRate: Longint; DataBits: Byte;
Parity: Char; StopBits: Byte): Boolean;
begin
Com_Open := Com_OpenKeep(Comport);
Com_SetLine(Baudrate, Parity, DataBits, StopBits);
end; { func. TWin32Obj.Com_OpenCom }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TWin32Obj.Com_SetLine(BpsRate: longint; Parity: Char; DataBits, Stopbits: Byte);
var DCB : TDCB;
BPSID : Longint;
begin
if BpsRate = 11520 then { small fix for EleBBS inability to store the bps }
BpsRate := 115200; { rate in anything larger than a 16-bit integer }
GetCommState(Com_GetHandle, DCB);
if NOT (Parity in ['N', 'E', 'O', 'M']) then Parity := 'N';
if BpsRate >= 0 then dcb.BaudRate := BpsRate;
dcb.StopBits := ONESTOPBIT;
Case Parity of
'N' : dcb.Parity := NOPARITY;
'E' : dcb.Parity := EVENPARITY;
'O' : dcb.Parity := ODDPARITY;
'M' : dcb.Parity := MARKPARITY;
end; { case }
Case StopBits of
1 : dcb.StopBits := ONESTOPBIT;
2 : dcb.StopBits := TWOSTOPBITS;
3 : dcb.StopBits := ONE5STOPBITS;
end; { case }
dcb.ByteSize := DataBits;
dcb.Flags := dcb.Flags OR dcb_Binary OR Dcb_DtrControlEnable;
if not SetCommState (Com_GetHandle, DCB) then
begin
BPSId := GetLastError;
ErrorStr := 'Error setting up communications parameters: #'+IntToStr(BpsId) + ' / '+SysErrorMessage(BpsId);
end; { if }
end; { proc. TWin32Obj.Com_SetLine }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TWin32Obj.Com_Close;
begin
if DontClose then EXIT;
if DWORD(Com_GetHandle) <> INVALID_HANDLE_VALUE then
begin
Com_StopThread;
CloseHandle(Com_GetHandle);
SaveHandle := INVALID_HANDLE_VALUE;
end;
end; { func. TWin32Obj.Com_CloseCom }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function TWin32Obj.Com_SendChar(C: Char): Boolean;
var Written: Longint;
begin
Com_SendBlock(C, SizeOf(C), Written);
Com_SendChar := (Written = SizeOf(c));
end; { proc. TWin32Obj.Com_SendChar }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function TWin32Obj.Com_GetChar: Char;
var Reads: Longint;
begin
Com_ReadBlock(Result, SizeOf(Result), Reads);
end; { func. TWin32Obj.Com_GetChar }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TWin32Obj.Com_SendBlock(var Block; BlockLen: Longint; var Written: Longint);
begin
if OutBuffer^.BufRoom < BlockLen then
repeat
{$IFDEF WIN32}
Sleep(1);
{$ENDIF}
until (OutBuffer^.BufRoom >= BlockLen) OR (NOT Com_Carrier);
CriticalTx^.EnterExclusive;
Written := OutBuffer^.Put(Block, BlockLen);
CriticalTx^.LeaveExclusive;
DoTxEvent^.SignalEvent;
end; { proc. TWin32Obj.Com_SendBlock }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TWin32Obj.Com_ReadBlock(var Block; BlockLen: Longint; var Reads: Longint);
begin
if InBuffer^.BufUsed < BlockLen then
begin
DoRxEvent^.SignalEvent;
while (InBuffer^.BufUsed < BlockLen) AND (Com_Carrier) do
begin
Sleep(1);
if Com_CharAvail then
DoRxEvent^.SignalEvent;
end; { while }
end; { if }
CriticalRx^.EnterExclusive;
Reads := InBuffer^.Get(Block, BlockLen, true);
CriticalRx^.LeaveExclusive;
end; { proc. TWin32Obj.Com_ReadBlock }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function TWin32Obj.Com_CharAvail: Boolean;
var Props : TComStat;
ErrMask : DWORD;
begin
if InBuffer^.BufUsed < 1 then
begin
ErrMask := 0;
if ClearCommError(Com_GetHandle, ErrMask, @Props) then
if Props.cbInQue > 0 then
DoRxEvent^.SignalEvent;
end; { if }
Result := (InBuffer^.BufUsed > 0);
end; { func. TWin32Obj.Com_CharAvail }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function TWin32Obj.Com_Carrier: Boolean;
var Status: DWORD;
begin
if Com_GetHandle <> INVALID_HANDLE_VALUE then
begin
GetCommModemStatus(Com_GetHandle,
Status);
Result := (Status AND MS_RLSD_ON) <> 00;
end
else Result := FALSE;
end; { func. TWin32Obj.Com_Carrier }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TWin32Obj.Com_GetModemStatus(var LineStatus, ModemStatus: Byte);
var Data: DWORD;
begin
GetCommModemStatus(Com_GetHandle, Data);
ModemStatus := ModemStatus and $0F;
ModemStatus := ModemStatus or Byte(Data);
end; { proc. TWin32Obj.Com_GetModemStatus }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TWin32Obj.Com_SetDtr(State: Boolean);
begin
if State then
EscapeCommFunction(Com_GetHandle, SETDTR)
else EscapeCommFunction(Com_GetHandle, CLRDTR);
end; { proc. TWin32Obj.Com_SetDtr }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function TWin32Obj.Com_GetBpsRate: Longint;
var DCB : TDCB;
begin
GetCommState(Com_GetHandle, DCB);
Com_GetBpsRate := dcb.Baudrate;
end; { func. TWin32Obj.Com_GetBpsRate }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TWin32Obj.Com_GetBufferStatus(var InFree, OutFree, InUsed, OutUsed: Longint);
var Stats : TComStat;
ErrMask : DWORD;
begin
if ClearCommError(Com_GetHandle, ErrMask, @Stats) then
begin
if Stats.cbInQue > 0 then
begin
DoRxEvent^.SignalEvent;
Sleep(1);
end; { if }
end; { if }
InFree := InBuffer^.BufRoom;
OutFree := OutBuffer^.BufRoom;
InUsed := InBuffer^.BufUsed;
OutUsed := OutBuffer^.BufUsed;
end; { proc. TWin32Obj.Com_GetBufferStatus }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TWin32Obj.Com_PurgeInBuffer;
begin
CriticalRx^.EnterExclusive;
InBuffer^.Clear;
PurgeComm(Com_GetHandle, PURGE_RXCLEAR);
CriticalRx^.LeaveExclusive;
end; { proc. TWin32Obj.Com_PurgeInBuffer }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TWin32Obj.Com_PurgeOutBuffer;
begin
CriticalTx^.EnterExclusive;
OutBuffer^.Clear;
PurgeComm(Com_GetHandle, PURGE_TXCLEAR);
CriticalTx^.LeaveExclusive;
end; { proc. TWin32Obj.Com_PurgeInBuffer }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function TWin32Obj.Com_ReadyToSend(BlockLen: Longint): Boolean;
begin
Result := OutBuffer^.BufRoom >= BlockLen;
end; { func. ReadyToSend }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TWin32Obj.Com_PauseCom(CloseCom: Boolean);
begin
if CloseCom then Com_Close
else Com_StopThread;
end; { proc. Com_PauseCom }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TWin32Obj.Com_ResumeCom(OpenCom: Boolean);
begin
if OpenCom then
begin
if InitPortNr <> -1 then Com_OpenKeep(InitPortNr)
else Com_OpenQuick(InitHandle);
end
else InitFailed := NOT Com_StartThread;
end; { proc. Com_ResumeCom }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TWin32Obj.Com_FlushOutBuffer(Slice: SliceProc);
begin
Windows.FlushFileBuffers(Com_GetHandle);
inherited Com_FlushOutBuffer(Slice);
end; { proc. Com_FlushOutBuffer }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TWin32Obj.Com_SetFlow(SoftTX, SoftRX, Hard: Boolean);
var DCB : TDCB;
BPSID : Longint;
begin
GetCommState(Com_GetHandle, DCB);
if Hard then
dcb.Flags := dcb.Flags OR NOT dcb_OutxCtsFlow OR NOT dcb_RtsControlHandshake;
if SoftTX then
dcb.Flags := dcb.Flags OR NOT dcb_OutX;
if SoftRX then
dcb.Flags := dcb.Flags OR NOT dcb_InX;
if not SetCommState(Com_GetHandle, DCB) then
begin
BPSId := GetLastError;
ErrorStr := 'Error setting up communications parameters: #'+IntToStr(BpsId) + ' / '+SysErrorMessage(BpsId);
end; { if }
Com_InitDelayTimes;
end; { proc. Com_SetFlow }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TWin32Obj.Com_SetDataProc(ReadPtr, WritePtr: Pointer);
begin
DataProcPtr := ReadPtr;
end; { proc. Com_SetDataProc }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
end.

205
SOURCE/ELECOM/W32SOCK.PAS Normal file
View File

@ -0,0 +1,205 @@
unit W32sock;
{&Orgname+}
(*
**
** WINDOWS TCP/IP routines
**
** Copyright (c) 1998 by Thomas W. Mueller
**
** Created : 24-Oct-1998
** Last update : 20-Feb-2000
**
**
*)
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
INTERFACE
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
uses
Windows,
SockDef;
type
u_char = Char;
u_short = Word;
u_int = Integer;
u_long = Longint;
{$IFDEF FPC}
type pInteger = ^Integer;
{$ENDIF}
{ Socket function prototypes }
function accept(_s: ULONG; _addr: pSockAddr; _addrlen: PInteger): ULONG; {$IFNDEF FPC} stdcall; {$ENDIF}
function bind(_s: ULONG; _addr: pSockAddr; _namelen: Integer): Integer; {$IFNDEF FPC} stdcall; {$ENDIF}
function connect(_s: ULONG; _name: pSockAddr; _namelen: Integer): Integer; {$IFNDEF FPC} stdcall; {$ENDIF}
function closesocket(s: ULONG): Integer; {$IFNDEF FPC} stdcall; {$ENDIF}
function select(nfds: Integer; readfds, writefds, exceptfds: PFDSet;
timeout: PTimeVal): Longint; {$IFNDEF FPC} stdcall; {$ENDIF}
function ioctlsocket(_s: ULONG; _cmd: Longint; var _arg: ULONG): Integer; {$IFNDEF FPC} stdcall; {$ENDIF}
function getpeername(_s: ULONG; _name: pSockAddr; var _namelen: Integer): Integer; {$IFNDEF FPC} stdcall; {$ENDIF}
function getsockname(_s: ULONG; _name: pSockAddr; var _namelen: Integer): Integer; {$IFNDEF FPC} stdcall; {$ENDIF}
function getsockopt(_s: ULONG; _level, _optname: Integer; _optval: PChar; var _optlen: Integer): Integer; {$IFNDEF FPC} stdcall; {$ENDIF}
function htonl(_hostlong: ULONG): ULONG; {$IFNDEF FPC} stdcall; {$ENDIF}
function htons(_hostshort: Integer): Integer; {$IFNDEF FPC} stdcall; {$ENDIF}
function inet_addr(_cp: PChar): ULONG; {$IFNDEF FPC} stdcall; {$ENDIF}
function inet_ntoa(_inaddr: tIn_Addr): PChar; {$IFNDEF FPC} stdcall; {$ENDIF}
function listen(_s: ULONG; _backlog: Integer): Integer; {$IFNDEF FPC} stdcall; {$ENDIF}
function ntohl(_netlong: ULONG): ULONG; {$IFNDEF FPC} stdcall; {$ENDIF}
function ntohs(_netshort: Integer): Integer; {$IFNDEF FPC} stdcall; {$ENDIF}
function recv(_s: ULONG; _Buf: pointer; _len, _flags: Integer): Integer; {$IFNDEF FPC} stdcall; {$ENDIF}
function recvfrom(s: ULONG; _Buf: pointer; _len, _flags: Integer;
var _from: TSockAddr; var _fromlen: Integer): Integer; {$IFNDEF FPC} stdcall; {$ENDIF}
function send(_s: ULONG; _Buf: pointer; _len, _flags: Integer): Integer; {$IFNDEF FPC} stdcall; {$ENDIF}
function sendto(_s: ULONG; _Buf: pointer; _len, _flags: Integer; var _addrto: TSockAddr;
_tolen: Integer): Integer; {$IFNDEF FPC} stdcall; {$ENDIF}
function setsockopt(_s: ULONG; _level, _optname: Integer; _optval: PChar;
_optlen: Integer): Integer; {$IFNDEF FPC} stdcall; {$ENDIF}
function shutdown(_s: ULONG; _how: Integer): Integer; {$IFNDEF FPC} stdcall; {$ENDIF}
function socket(_af, _struct, _protocol: Integer): ULONG; {$IFNDEF FPC} stdcall; {$ENDIF}
function gethostbyaddr(_addr: Pointer; _len, _struct: Integer): PHostEnt; {$IFNDEF FPC} stdcall; {$ENDIF}
function gethostbyname(_name: PChar): PHostEnt; {$IFNDEF FPC} stdcall; {$ENDIF}
function gethostname(_name: PChar; _len: Integer): Integer; {$IFNDEF FPC} stdcall; {$ENDIF}
function getservbyport(_port: Integer; _proto: PChar): PServEnt; {$IFNDEF FPC} stdcall; {$ENDIF}
function getservbyname(_name, _proto: PChar): PServEnt; {$IFNDEF FPC} stdcall; {$ENDIF}
function getprotobynumber(_proto: Integer): PProtoEnt; {$IFNDEF FPC} stdcall; {$ENDIF}
function getprotobyname(_name: PChar): PProtoEnt; {$IFNDEF FPC} stdcall; {$ENDIF}
function WSAStartup(wVersionRequired: word; var WSData: TWSAData): Integer; {$IFNDEF FPC} stdcall; {$ENDIF}
function WSACleanup: Integer; {$IFNDEF FPC} stdcall; {$ENDIF}
procedure WSASetLastError(iError: Integer); {$IFNDEF FPC} stdcall; {$ENDIF}
function WSAGetLastError: Integer; {$IFNDEF FPC} stdcall; {$ENDIF}
function WSAIsBlocking: BOOL; {$IFNDEF FPC} stdcall; {$ENDIF}
function WSAUnhookBlockingHook: Integer; {$IFNDEF FPC} stdcall; {$ENDIF}
function WSASetBlockingHook(lpBlockFunc: TFarProc): TFarProc; {$IFNDEF FPC} stdcall; {$ENDIF}
function WSACancelBlockingCall: Integer; {$IFNDEF FPC} stdcall; {$ENDIF}
function WSAAsyncGetServByName(HWindow: HWND; wMsg: u_int;
name, proto, buf: PChar; buflen: Integer): THandle; {$IFNDEF FPC} stdcall; {$ENDIF}
function WSAAsyncGetServByPort( HWindow: HWND; wMsg, port: u_int;
proto, buf: PChar; buflen: Integer): THandle; {$IFNDEF FPC} stdcall; {$ENDIF}
function WSAAsyncGetProtoByName(HWindow: HWND; wMsg: u_int;
name, buf: PChar; buflen: Integer): THandle; {$IFNDEF FPC} stdcall; {$ENDIF}
function WSAAsyncGetProtoByNumber(HWindow: HWND; wMsg: u_int; number: Integer;
buf: PChar; buflen: Integer): THandle; {$IFNDEF FPC} stdcall; {$ENDIF}
function WSAAsyncGetHostByName(HWindow: HWND; wMsg: u_int;
name, buf: PChar; buflen: Integer): THandle; {$IFNDEF FPC} stdcall; {$ENDIF}
function WSAAsyncGetHostByAddr(HWindow: HWND; wMsg: u_int; addr: PChar;
len, struct: Integer; buf: PChar; buflen: Integer): THandle; {$IFNDEF FPC} stdcall; {$ENDIF}
function WSACancelAsyncRequest(hAsyncTaskHandle: THandle): Integer; {$IFNDEF FPC} stdcall; {$ENDIF}
function WSAAsyncSelect(s: ULONG; HWindow: HWND; wMsg: u_int; lEvent: Longint): Integer; {$IFNDEF FPC} stdcall; {$ENDIF}
function WSARecvEx(s: ULONG; var buf; len: Integer; var flags: Integer): Integer; {$IFNDEF FPC} stdcall; {$ENDIF}
function WSAMakeSyncReply(Buflen, Error: Word): Longint;
function WSAMakeSelectReply(Event, Error: Word): Longint;
function WSAGetAsyncBuflen(Param: Longint): Word;
function WSAGetAsyncError(Param: Longint): Word;
function WSAGetSelectEvent(Param: Longint): Word;
function WSAGetSelectError(Param: Longint): Word;
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
IMPLEMENTATION
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
const
winsocket = 'wsock32.dll';
function WSAMakeSyncReply(Buflen, Error: Word): Longint;
begin
WSAMakeSyncReply:= MakeLong(Buflen, Error);
end;
function WSAMakeSelectReply(Event, Error: Word): Longint;
begin
WSAMakeSelectReply:= MakeLong(Event, Error);
end;
function WSAGetAsyncBuflen(Param: Longint): Word;
begin
WSAGetAsyncBuflen:= LOWORD(Param);
end;
function WSAGetAsyncError(Param: Longint): Word;
begin
WSAGetAsyncError:= HIWORD(Param);
end;
function WSAGetSelectEvent(Param: Longint): Word;
begin
WSAGetSelectEvent:= LOWORD(Param);
end;
function WSAGetSelectError(Param: Longint): Word;
begin
WSAGetSelectError:= HIWORD(Param);
end;
function accept(_s: ULONG; _addr: pSockAddr; _addrlen: PInteger): ULONG; external winsocket name 'accept';
function bind(_s: ULONG; _addr: pSockAddr; _namelen: Integer): Integer; external winsocket name 'bind';
function connect(_s: ULONG; _name: pSockAddr; _namelen: Integer): Integer; external winsocket name 'connect';
function closesocket(s: ULONG): Integer; external winsocket name 'closesocket';
function select(nfds: Integer; readfds, writefds, exceptfds: PFDSet;
timeout: PTimeVal): Longint; external winsocket name 'select';
function ioctlsocket(_s: ULONG; _cmd: Longint; var _arg: ULONG): Integer; external winsocket name 'ioctlsocket';
function getpeername(_s: ULONG; _name: pSockAddr; var _namelen: Integer): Integer; external winsocket name 'getpeername';
function getsockname(_s: ULONG; _name: pSockAddr; var _namelen: Integer): Integer; external winsocket name 'getsockname';
function getsockopt(_s: ULONG; _level, _optname: Integer; _optval: PChar; var _optlen: Integer): Integer; external winsocket name 'getsockopt';
function htonl(_hostlong: ULONG): ULONG; external winsocket name 'htonl';
function htons(_hostshort: Integer): Integer; external winsocket name 'htons';
function inet_addr(_cp: PChar): ULONG; external winsocket name 'inet_addr';
function inet_ntoa(_inaddr: tIn_Addr): PChar; external winsocket name 'inet_ntoa';
function listen(_s: ULONG; _backlog: Integer): Integer; external winsocket name 'listen';
function ntohl(_netlong: ULONG): ULONG; external winsocket name 'ntohl';
function ntohs(_netshort: Integer): Integer; external winsocket name 'ntohs';
function recv(_s: ULONG; _Buf: pointer; _len, _flags: Integer): Integer; external winsocket name 'recv';
function recvfrom(s: ULONG; _Buf: pointer; _len, _flags: Integer;
var _from: TSockAddr; var _fromlen: Integer): Integer; external winsocket name 'recvfrom';
function send(_s: ULONG; _Buf: pointer; _len, _flags: Integer): Integer; external winsocket name 'send';
function sendto(_s: ULONG; _Buf: pointer; _len, _flags: Integer; var _addrto: TSockAddr;
_tolen: Integer): Integer; external winsocket name 'sendto';
function setsockopt(_s: ULONG; _level, _optname: Integer; _optval: PChar;
_optlen: Integer): Integer; external winsocket name 'setsockopt';
function shutdown(_s: ULONG; _how: Integer): Integer; external winsocket name 'shutdown';
function socket(_af, _struct, _protocol: Integer): ULONG; external winsocket name 'socket';
function gethostbyaddr(_addr: Pointer; _len, _struct: Integer): PHostEnt; external winsocket name 'gethostbyaddr';
function gethostbyname(_name: PChar): PHostEnt; external winsocket name 'gethostbyname';
function gethostname(_name: PChar; _len: Integer): Integer; external winsocket name 'gethostname';
function getservbyport(_port: Integer; _proto: PChar): PServEnt; external winsocket name 'getservbyport';
function getservbyname(_name, _proto: PChar): PServEnt; external winsocket name 'getservbyname';
function getprotobynumber(_proto: Integer): PProtoEnt; external winsocket name 'getprotobynumber';
function getprotobyname(_name: PChar): PProtoEnt; external winsocket name 'getprotobyname';
function WSAStartup(wVersionRequired: word; var WSData: TWSAData): Integer; external winsocket name 'WSAStartup';
function WSACleanup: Integer; external winsocket name 'WSACleanup';
procedure WSASetLastError(iError: Integer); external winsocket name 'WSASetLastError';
function WSAGetLastError: Integer; external winsocket name 'WSAGetLastError';
function WSAIsBlocking: BOOL; external winsocket name 'WSAIsBlocking';
function WSAUnhookBlockingHook: Integer; external winsocket name 'WSAUnhookBlockingHook';
function WSASetBlockingHook(lpBlockFunc: TFarProc): TFarProc; external winsocket name 'WSASetBlockingHook';
function WSACancelBlockingCall: Integer; external winsocket name 'WSACancelBlockingCall';
function WSAAsyncGetServByName(HWindow: HWND; wMsg: u_int;
name, proto, buf: PChar; buflen: Integer): THandle; external winsocket name 'WSAAsyncGetServByName';
function WSAAsyncGetServByPort( HWindow: HWND; wMsg, port: u_int;
proto, buf: PChar; buflen: Integer): THandle; external winsocket name 'WSAAsyncGetServByPort';
function WSAAsyncGetProtoByName(HWindow: HWND; wMsg: u_int;
name, buf: PChar; buflen: Integer): THandle; external winsocket name 'WSAAsyncGetProtoByName';
function WSAAsyncGetProtoByNumber(HWindow: HWND; wMsg: u_int; number: Integer;
buf: PChar; buflen: Integer): THandle; external winsocket name 'WSAAsyncGetProtoByNumber';
function WSAAsyncGetHostByName(HWindow: HWND; wMsg: u_int;
name, buf: PChar; buflen: Integer): THandle; external winsocket name 'WSAAsyncGetHostByName';
function WSAAsyncGetHostByAddr(HWindow: HWND; wMsg: u_int; addr: PChar;
len, struct: Integer; buf: PChar; buflen: Integer): THandle; external winsocket name 'WSAAsyncGetHostByAddr';
function WSACancelAsyncRequest(hAsyncTaskHandle: THandle): Integer; external winsocket name 'WSACancelAsyncRequest';
function WSAAsyncSelect(s: ULONG; HWindow: HWND; wMsg: u_int; lEvent: Longint): Integer; external winsocket name 'WSAAsyncSelect';
function WSARecvEx(s: ULONG; var buf; len: Integer; var flags: Integer): Integer; external winsocket name 'WSARecvEx';
end. { unit. W32SOCK }

790
SOURCE/ELECOM/WIN32COM.PAS Normal file
View File

@ -0,0 +1,790 @@
unit WIN32COM;
(*
**
** Serial and TCP/IP communication routines for DOS, OS/2 and Win9x/NT.
** Tested with: TurboPascal v7.0, (DOS)
** VirtualPascal v2.0, (OS/2, Win32)
** FreePascal v0.99.15 (DOS, Win32)
** Delphi v4.0. (Win32)
**
** Version : 1.01
** Created : 21-May-1998
** Last update : 20-Feb-2000
**
** Note: (c) 1998-2000 by Maarten Bekers
**
*)
This unit is not supported anymore.
Remove this in order to be compiled anyway. The next release of EleCOM will
not include WIN32COM.PAS anymore. W32SNGL.PAS is the replacement unit.
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
INTERFACE
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
uses Windows, Combase, BufUnit, Threads
{$IFDEF VirtualPascal}
,Use32
{$ENDIF};
Const WriteTimeout = 20000; { Wait max. 20 secs }
ReadTimeOut = 20000; { General event, 20 secs max }
InBufSize = 1024 * 32;
OutBufSize = 1024 * 32;
type TWin32Obj = Object(TCommObj)
ReadProcPtr: Pointer; { Pointer to TX/RX handler (thread) }
WriteProcPtr: Pointer; { Pointer to TX/RX handler (thread) }
ThreadsInitted: Boolean; { Are the thread(s) up and running? }
SaveHandle : THandle;
InitPortNr : Longint;
InitHandle : Longint;
ReadOL : TOverLapped; { Overlapped structure for ReadFile }
WriteOL : TOverLapped; { Overlapped structure for WriteFile }
InBuffer : ^BufArrayObj; { Buffer system internally used }
OutBuffer : ^BufArrayObj;
ReadEvent : PSysEventObj; { Event set by ReadFile overlapped routine }
WriteEvent : PSysEventObj; { Event set by WriteFile overlapped routine }
RecvEvent : PSysEventObj;
DoTxEvent : PSysEventObj;{ Event manually set when we have to transmit }
TxClosedEvent : PSysEventObj; { Event set when the Tx thread is closed }
RxClosedEvent : PSysEventObj; { Event set when the Rx thread is closed }
CriticalTx : PExclusiveObj; { Critical sections }
CriticalRx : PExclusiveObj;
TxThread : PThreadsObj; { The Transmit and Receive threads }
RxThread : PThreadsObj;
EndThreads : Boolean; { Set to true when we have to end the threads }
constructor Init;
destructor Done;
function Com_Open(Comport: Byte; BaudRate: Longint; DataBits: Byte;
Parity: Char; StopBits: Byte): Boolean; virtual;
function Com_OpenKeep(Comport: Byte): Boolean; virtual;
function Com_GetChar: Char; virtual;
function Com_CharAvail: Boolean; virtual;
function Com_Carrier: Boolean; virtual;
function Com_SendChar(C: Char): Boolean; virtual;
function Com_ReadyToSend(BlockLen: Longint): Boolean; virtual;
function Com_GetBPSrate: Longint; virtual;
function Com_GetHandle: Longint; virtual;
procedure Com_OpenQuick(Handle: Longint); virtual;
procedure Com_Close; virtual;
procedure Com_SendBlock(var Block; BlockLen: Longint; var Written: Longint); virtual;
procedure Com_ReadBlock(var Block; BlockLen: Longint; var Reads: Longint); virtual;
procedure Com_GetBufferStatus(var InFree, OutFree, InUsed, OutUsed: Longint); virtual;
procedure Com_SetDtr(State: Boolean); virtual;
procedure Com_GetModemStatus(var LineStatus, ModemStatus: Byte); virtual;
procedure Com_SetLine(BpsRate: longint; Parity: Char; DataBits, Stopbits: Byte); virtual;
procedure Com_PurgeInBuffer; virtual;
procedure Com_PurgeOutBuffer; virtual;
procedure Com_PauseCom(CloseCom: Boolean); virtual;
procedure Com_ResumeCom(OpenCom: Boolean); virtual;
procedure Com_SetFlow(SoftTX, SoftRX, Hard: Boolean); virtual;
procedure Com_SetDataProc(ReadPtr, WritePtr: Pointer); virtual;
procedure Com_ReadProc(var TempPtr: Pointer);
procedure Com_WriteProc(var TempPtr: Pointer);
function Com_StartThread: Boolean;
procedure Com_InitVars;
procedure Com_StopThread;
procedure Com_InitDelayTimes;
end; { object TWin32Obj }
type PWin32Obj = ^TWin32Obj;
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
IMPLEMENTATION
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
uses SysUtils;
{$IFDEF FPC}
{$I WINDEF.FPC}
{$ENDIF}
const
dcb_Binary = $00000001;
dcb_ParityCheck = $00000002;
dcb_OutxCtsFlow = $00000004;
dcb_OutxDsrFlow = $00000008;
dcb_DtrControlMask = $00000030;
dcb_DtrControlDisable = $00000000;
dcb_DtrControlEnable = $00000010;
dcb_DtrControlHandshake = $00000020;
dcb_DsrSensivity = $00000040;
dcb_TXContinueOnXoff = $00000080;
dcb_OutX = $00000100;
dcb_InX = $00000200;
dcb_ErrorChar = $00000400;
dcb_NullStrip = $00000800;
dcb_RtsControlMask = $00003000;
dcb_RtsControlDisable = $00000000;
dcb_RtsControlEnable = $00001000;
dcb_RtsControlHandshake = $00002000;
dcb_RtsControlToggle = $00003000;
dcb_AbortOnError = $00004000;
dcb_Reserveds = $FFFF8000;
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
constructor TWin32Obj.Init;
begin
inherited Init;
InitPortNr := -1;
InitHandle := -1;
ThreadsInitted := false;
Com_InitVars;
end; { constructor Init }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
destructor TWin32Obj.Done;
begin
inherited done;
end; { destructor Done }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TWin32Obj.Com_ReadProc(var TempPtr: Pointer);
var EventMask : DWORD;
Success : Boolean;
Props : TCommProp;
ReturnCode: Longint;
DidRead : DWORD;
BlockLen : Longint;
RecvOL : tOverlapped;
begin
New(RecvEvent, Init);
if NOT RecvEvent^.CreateEvent(true) then EXIT;
FillChar(RecvOL, SizeOf(tOverLapped), 0);
RecvOL.hEvent := RecvEvent^.SemHandle;
EventMask := EV_RXCHAR;
SetCommMask(SaveHandle, EventMask); { Signal us if anything is received }
repeat
WaitCommEvent(SaveHandle, EventMask, @RecvOL);
if EndThreads then EXIT;
repeat
ReturnCode := WaitForSingleObject(RecvOL.hEvent, 500);
if ReturnCode = WAIT_OBJECT_0 then
begin
Success := true
end { if }
else Success := false;
if EndThreads then BREAK;
until (Success);
DidRead := 00;
if (NOT Success) OR (EventMask = 0) then EXIT;
if (EndThreads) then EXIT;
{----------------- Start reading the gathered date ---------------------}
CriticalRx^.EnterExclusive;
FillChar(Props, SizeOf(TCommProp), 0);
if GetCommProperties(SaveHandle, Props) then
if InBuffer^.BufRoom > 0 then
begin
BlockLen := Props.dwCurrentRxQueue;
if BlockLen > InBuffer^.BufRoom then
BlockLen := InBuffer^.BufRoom;
Success := ReadFile(SaveHandle,
InBuffer^.TmpBuf^,
BlockLen,
DidRead,
@ReadOL);
if NOT Success then
begin
ReturnCode := GetLastError;
if ReturnCode = ERROR_IO_PENDING then
begin
ReturnCode := WaitForSingleObject(ReadOL.hEvent, ReadTimeOut);
if ReturnCode = WAIT_OBJECT_0 then
begin
GetOverLappedResult(SaveHandle, ReadOL, DidRead, false);
end; { if }
end; { if }
end
else GetOverlappedResult(SaveHandle, ReadOL, DidRead, false);
if DidRead > 00 then
InBuffer^.Put(InBuffer^.TmpBuf^, DidRead);
end; { if }
CriticalRx^.LeaveExclusive;
until EndThreads;
RxClosedEvent^.SignalEvent;
ExitThisThread;
end; { proc. ComReadProc }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TWin32Obj.Com_WriteProc(var TempPtr: Pointer);
var BlockLen : Longint;
Written : DWORD;
ReturnCode: Longint;
Success : Boolean;
begin
repeat
if DoTxEvent^.WaitForEvent(WriteTimeOut) then
if NOT EndThreads then
begin
CriticalTx^.EnterExclusive;
DoTxEvent^.ResetEvent;
if OutBuffer^.BufUsed > 00 then
begin
Written := 00;
BlockLen := OutBuffer^.Get(OutBuffer^.TmpBuf^, OutBuffer^.BufUsed, false);
Success := WriteFile(SaveHandle,
OutBuffer^.TmpBuf^,
BlockLen,
Written,
@WriteOL);
if NOT Success then
begin
ReturnCode := GetLastError;
if ReturnCode = ERROR_IO_PENDING then
begin
ReturnCode := WaitForSingleObject(WriteOL.hEvent, WriteTimeOut);
if ReturnCode = WAIT_OBJECT_0 then
begin
if GetOverLappedResult(SaveHandle, WriteOL, Written, false) then
begin
ResetEvent(WriteOL.hEvent);
end; { if }
end; { if }
end; { result is pending }
end { if }
else begin
if GetOverLappedResult(SaveHandle, WriteOL, Written, false) then
begin
ResetEvent(WriteOL.hEvent);
end; { if }
end; { if (did succeed) }
ReturnCode := OutBuffer^.Get(OutBuffer^.TmpBuf^, Written, true);
if Written <> BlockLen then
DoTxEvent^.SignalEvent;
end; { if }
CriticalTx^.LeaveExclusive;
end; { if }
until EndThreads;
TxClosedEvent^.SignalEvent;
ExitThisThread;
end; { proc. ComWriteProc }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function TWin32Obj.Com_StartThread: Boolean;
begin
Result := false;
EndThreads := false;
if ThreadsInitted then EXIT;
ThreadsInitted := true;
{----------------------- Create all the events ----------------------------}
New(ReadEvent, Init);
if NOT ReadEvent^.CreateEvent(true) then EXIT;
New(WriteEvent, Init);
if NOT WriteEvent^.CreateEvent(true) then EXIT;
New(DoTxEvent, Init);
if NOT DoTxEvent^.CreateEvent(false) then EXIT;
New(RxClosedEvent, Init);
if NOT RxClosedEvent^.CreateEvent(false) then EXIT;
New(TxClosedEvent, Init);
if NOT TxClosedEvent^.CreateEvent(false) then EXIT;
{-------------- Startup the buffers and overlapped events -----------------}
FillChar(WriteOL, SizeOf(tOverLapped), 0);
FillChar(ReadOL, SizeOf(tOverLapped), 0);
WriteOl.hEvent := WriteEvent^.SemHandle;
ReadOl.hEvent := ReadEvent^.SemHandle;
New(InBuffer, Init(InBufSize));
New(OutBuffer, Init(OutBufSize));
if (InBuffer^.TxtArr=nil) OR (InBuffer^.TmpBuf=nil) then EXIT;
if (OutBuffer^.TxtArr=nil) OR (OutBuffer^.TmpBuf=nil) then EXIT;
{-------------------- Startup a seperate write thread ---------------------}
New(CriticalTx, Init);
CriticalTx^.CreateExclusive;
New(TxThread, Init);
if NOT TxThread^.CreateThread(16384, { Stack size }
@WriteProcPtr, { Actual procedure }
nil, { Parameters }
0) { Creation flags }
then EXIT;
{-------------------- Startup a seperate read thread ----------------------}
New(CriticalRx, Init);
CriticalRx^.CreateExclusive;
New(RxThread, Init);
if NOT RxThread^.CreateThread(16384, { Stack size }
@ReadProcPtr, { Actual procedure }
nil, { Parameters }
0) { Creation flags }
then EXIT;
Result := true;
end; { proc. Com_StartThread }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TWin32Obj.Com_InitVars;
begin
DoTxEvent := nil;
RxClosedEvent := nil;
TxClosedEvent := nil;
RecvEvent := nil;
ReadEvent := nil;
WriteEvent := nil;
TxThread := nil;
RxThread := nil;
InBuffer := nil;
OutBuffer := nil;
CriticalRx := nil;
CriticalTx := nil;
end; { proc. Com_InitVars }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TWin32Obj.Com_StopThread;
begin
EndThreads := true;
ThreadsInitted := false;
if DoTxEvent <> nil then DoTxEvent^.SignalEvent;
if TxThread <> nil then TxThread^.CloseThread;
if RxThread <> nil then RxThread^.CloseThread;
if TxClosedEvent <> nil then
if NOT TxClosedEvent^.WaitForEvent(1000) then
TxThread^.TerminateThread(0);
if RxClosedEvent <> nil then
if NOT RxClosedEvent^.WaitForEvent(1000) then
RxThread^.TerminateThread(0);
if TxThread <> nil then Dispose(TxThread, Done);
if RxThread <> nil then Dispose(RxThread, Done);
if DoTxEvent <> nil then Dispose(DoTxEvent, Done);
if RxClosedEvent <> nil then Dispose(RxClosedEvent, Done);
if TxClosedEvent <> nil then Dispose(TxClosedEvent, Done);
if CriticalTx <> nil then Dispose(CriticalTx, Done);
if CriticalRx <> nil then Dispose(CriticalRx, Done);
if InBuffer <> nil then Dispose(InBuffer, Done);
if OutBuffer <> nil then Dispose(OutBuffer, Done);
if RecvEvent <> nil then Dispose(RecvEvent, Done);
if ReadEvent <> nil then Dispose(ReadEvent, Done);
if WriteEvent <> nil then Dispose(WriteEvent, Done);
Com_InitVars;
end; { proc. Com_StopThread }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TWin32Obj.Com_InitDelayTimes;
var CommTimeOut: TCommTimeouts;
RC : Longint;
begin
FillChar(CommTimeOut, SizeOf(TCommTimeOuts), 00);
CommTimeOut.ReadIntervalTimeout := MAXDWORD;
if NOT SetCommTimeOuts(SaveHandle, CommTimeOut) then
begin
RC := GetLastError;
{ ErrorStr := 'Error setting communications timeout: #'+IntToStr(RC) + ' / ' + SysErrorMessage(rc)); }
end; { if }
end; { proc. InitDelayTimes }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function TWin32Obj.Com_GetHandle: Longint;
begin
Result := SaveHandle;
end; { func. Com_GetHandle }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TWin32Obj.Com_OpenQuick(Handle: Longint);
var LastError: Longint;
begin
SaveHandle := Handle;
InitHandle := Handle;
FillChar(ReadOl, SizeOf(ReadOl), 00);
FillChar(WriteOl, SizeOf(WriteOl), 00);
Com_InitDelayTimes;
if NOT SetupComm(Com_GetHandle, 1024, 1024) then
begin
LastError := GetLastError;
{ ErrorStr := 'Error setting up communications buffer: #'+IntToStr(LastError) + ' / '+SysErrorMessage(LastError); }
end; { if }
InitFailed := NOT Com_StartThread;
Com_SetLine(-1, 'N', 8, 1);
end; { proc. TWin32Obj.Com_OpenQuick }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function TWin32Obj.Com_OpenKeep(Comport: Byte): Boolean;
var TempSave : THandle;
Security : TSECURITYATTRIBUTES;
LastError : Longint;
begin
InitPortNr := Comport;
FillChar(ReadOl, SizeOf(ReadOl), 00);
FillChar(WriteOl, SizeOf(WriteOl), 00);
FillChar(Security, SizeOf(TSECURITYATTRIBUTES), 0);
Security.nLength := SizeOf(TSECURITYATTRIBUTES);
Security.lpSecurityDescriptor := nil;
Security.bInheritHandle := true;
TempSave := CreateFile(PChar('\\.\COM' + IntToStr(ComPort)),
GENERIC_READ or GENERIC_WRITE,
0,
@Security, { No Security }
OPEN_EXISTING, { Creation action }
FILE_ATTRIBUTE_NORMAL or FILE_FLAG_OVERLAPPED,
0); { No template }
LastError := GetLastError;
if LastError <> 0 then
ErrorStr := 'Unable to open communications port';
SaveHandle := TempSave;
Result := (TempSave <> INVALID_HANDLE_VALUE);
if Result then { Make sure that "CharAvail" isn't going to wait }
begin
Com_InitDelayTimes;
end; { if }
if NOT SetupComm(Com_GetHandle, 1024, 1024) then
begin
LastError := GetLastError;
{ ErrorStr := 'Error setting up communications buffer: #'+IntToStr(LastError) + ' / '+SysErrorMessage(LastError); }
end; { if }
InitFailed := NOT Com_StartThread;
end; { func. Com_OpenKeep }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function TWin32Obj.Com_Open(Comport: Byte; BaudRate: Longint; DataBits: Byte;
Parity: Char; StopBits: Byte): Boolean;
begin
Com_Open := Com_OpenKeep(Comport);
Com_SetLine(Baudrate, Parity, DataBits, StopBits);
end; { func. TWin32Obj.Com_OpenCom }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TWin32Obj.Com_SetLine(BpsRate: longint; Parity: Char; DataBits, Stopbits: Byte);
var DCB : TDCB;
BPSID : Longint;
begin
if BpsRate = 11520 then
BpsRate := 115200;
GetCommState(Com_GetHandle, DCB);
if NOT (Parity in ['N', 'E', 'O', 'M']) then Parity := 'N';
if BpsRate >= 0 then dcb.BaudRate := BpsRate;
dcb.StopBits := ONESTOPBIT;
Case Parity of
'N' : dcb.Parity := NOPARITY;
'E' : dcb.Parity := EVENPARITY;
'O' : dcb.Parity := ODDPARITY;
'M' : dcb.Parity := MARKPARITY;
end; { case }
if StopBits = 1 then
dcb.StopBits := ONESTOPBIT;
dcb.ByteSize := DataBits;
dcb.Flags := dcb.Flags OR dcb_Binary or Dcb_DtrControlEnable;
if not SetCommState (Com_GetHandle, DCB) then
begin
BPSId := GetLastError;
{ ErrorStr := 'Error setting up communications parameters: #'+IntToStr(BpsId) + ' / '+SysErrorMessage(BpsId); }
end; { if }
end; { proc. TWin32Obj.Com_SetLine }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TWin32Obj.Com_Close;
begin
if DontClose then EXIT;
if Com_GetHandle <> INVALID_HANDLE_VALUE then
begin
Com_StopThread;
CloseHandle(Com_GetHandle);
SaveHandle := INVALID_HANDLE_VALUE;
end;
end; { func. TWin32Obj.Com_CloseCom }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function TWin32Obj.Com_SendChar(C: Char): Boolean;
var Written: Longint;
begin
Com_SendBlock(C, SizeOf(C), Written);
Com_SendChar := (Written = SizeOf(c));
end; { proc. TWin32Obj.Com_SendChar }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function TWin32Obj.Com_GetChar: Char;
var Reads: Longint;
begin
Com_ReadBlock(Result, SizeOf(Result), Reads);
end; { func. TWin32Obj.Com_GetChar }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TWin32Obj.Com_SendBlock(var Block; BlockLen: Longint; var Written: Longint);
begin
if OutBuffer^.BufRoom < BlockLen then
repeat
{$IFDEF WIN32}
Sleep(1);
{$ENDIF}
{$IFDEF OS2}
DosSleep(1);
{$ENDIF}
until (OutBuffer^.BufRoom >= BlockLen) OR (NOT Com_Carrier);
CriticalTx^.EnterExclusive;
Written := OutBuffer^.Put(Block, BlockLen);
CriticalTx^.LeaveExclusive;
DoTxEvent^.SignalEvent;
end; { proc. TWin32Obj.Com_SendBlock }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TWin32Obj.Com_ReadBlock(var Block; BlockLen: Longint; var Reads: Longint);
begin
if InBuffer^.BufUsed < BlockLen then
begin
repeat
Sleep(1);
until (InBuffer^.BufUsed >= BlockLen) OR (NOT Com_Carrier);
end; { if }
CriticalRx^.EnterExclusive;
Reads := InBuffer^.Get(Block, BlockLen, true);
CriticalRx^.LeaveExclusive;
end; { proc. TWin32Obj.Com_ReadBlock }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function TWin32Obj.Com_CharAvail: Boolean;
begin
Result := (InBuffer^.BufUsed > 0);
end; { func. TWin32Obj.Com_CharAvail }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function TWin32Obj.Com_Carrier: Boolean;
var Status: DWORD;
begin
GetCommModemStatus(Com_GetHandle,
Status);
Result := (Status AND MS_RLSD_ON) <> 00;
end; { func. TWin32Obj.Com_Carrier }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TWin32Obj.Com_GetModemStatus(var LineStatus, ModemStatus: Byte);
var Data: DWORD;
begin
GetCommModemStatus(Com_GetHandle, Data);
ModemStatus := ModemStatus and $0F;
ModemStatus := ModemStatus or Byte(Data);
end; { proc. TWin32Obj.Com_GetModemStatus }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TWin32Obj.Com_SetDtr(State: Boolean);
begin
if State then
EscapeCommFunction(Com_GetHandle, SETDTR)
else EscapeCommFunction(Com_GetHandle, CLRDTR);
end; { proc. TWin32Obj.Com_SetDtr }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function TWin32Obj.Com_GetBpsRate: Longint;
var DCB : TDCB;
BPSID : Longint;
begin
GetCommState(Com_GetHandle, DCB);
Com_GetBpsRate := dcb.Baudrate;
end; { func. TWin32Obj.Com_GetBpsRate }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TWin32Obj.Com_GetBufferStatus(var InFree, OutFree, InUsed, OutUsed: Longint);
begin
InFree := InBuffer^.BufRoom;
OutFree := OutBuffer^.BufRoom;
InUsed := InBuffer^.BufUsed;
OutUsed := OutBuffer^.BufUsed;
end; { proc. TWin32Obj.Com_GetBufferStatus }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TWin32Obj.Com_PurgeInBuffer;
begin
CriticalRx^.EnterExclusive;
InBuffer^.Clear;
PurgeComm(Com_GetHandle, PURGE_RXCLEAR);
CriticalRx^.LeaveExclusive;
end; { proc. TWin32Obj.Com_PurgeInBuffer }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TWin32Obj.Com_PurgeOutBuffer;
begin
CriticalTx^.EnterExclusive;
OutBuffer^.Clear;
PurgeComm(Com_GetHandle, PURGE_TXCLEAR);
CriticalTx^.LeaveExclusive;
end; { proc. TWin32Obj.Com_PurgeInBuffer }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
function TWin32Obj.Com_ReadyToSend(BlockLen: Longint): Boolean;
begin
Result := OutBuffer^.BufRoom >= BlockLen;
end; { func. ReadyToSend }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TWin32Obj.Com_PauseCom(CloseCom: Boolean);
begin
if CloseCom then Com_Close
else Com_StopThread;
end; { proc. Com_PauseCom }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TWin32Obj.Com_ResumeCom(OpenCom: Boolean);
begin
if OpenCom then
begin
if InitPortNr <> -1 then Com_OpenKeep(InitPortNr)
else Com_OpenQuick(InitHandle);
end
else InitFailed := NOT Com_StartThread;
end; { proc. Com_ResumeCom }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TWin32Obj.Com_SetFlow(SoftTX, SoftRX, Hard: Boolean);
var DCB : TDCB;
BPSID : Longint;
begin
GetCommState(Com_GetHandle, DCB);
if Hard then
dcb.Flags := dcb.Flags OR dcb_OutxCtsFlow OR dcb_RtsControlHandshake;
if SoftTX then
dcb.Flags := dcb.Flags OR dcb_OutX;
if SoftRX then
dcb.Flags := dcb.Flags OR dcb_InX;
if not SetCommState (Com_GetHandle, DCB) then
begin
BPSId := GetLastError;
{ ErrorStr := 'Error setting up communications parameters: #'+IntToStr(BpsId) + ' / '+SysErrorMessage(BpsId); }
end; { if }
end; { proc. Com_SetFlow }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure TWin32Obj.Com_SetDataProc(ReadPtr, WritePtr: Pointer);
begin
ReadProcPtr := ReadPtr;
WriteProcPtr := WritePtr;
end; { proc. Com_SetDataProc }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
end.

79
SOURCE/ELECOM/WINDEF.FPC Normal file
View File

@ -0,0 +1,79 @@
(*
**
** Include file to make FPC more Delphi compatible
**
*)
{$IFDEF FPC}
type DCB = record
DCBlength : DWORD;
BaudRate : DWORD;
flags : longint;
wReserved : WORD;
XonLim : WORD;
XoffLim : WORD;
ByteSize : BYTE;
Parity : BYTE;
StopBits : BYTE;
XonChar : char;
XoffChar : char;
ErrorChar : char;
EofChar : char;
EvtChar : char;
wReserved1 : WORD;
end;
TDcb = DCB;
pInteger = ^Integer;
PSecurityAttributes = ^TSecurityAttributes;
TSecurityAttributes = record
nLength: Longint;
lpSecurityDescriptor: Pointer;
bInheritHandle: Bool;
end;
function GetCommState(hFile:HANDLE; var lpDCB:TDCB):WINBOOL; external 'kernel32' name 'GetCommState';
function SetCommState(hFile:HANDLE; var lpDCB:TDCB):WINBOOL; external 'kernel32' name 'SetCommState';
function WaitForMultipleObjects(nCount:DWORD; lpHandles:Pointer; bWaitAll:WINBOOL; dwMilliseconds:DWORD):DWORD; external 'kernel32' name 'WaitForMultipleObjects';
{-- Apparently, FPC 1.0 doesnt have the "SysErrorMessage" defined in its ------}
{-- SYSUTILS unit. We create this function here. ------------------------------}
function FormatMessageA(dwFlags : DWORD;
lpSource : Pointer;
dwMessageId : DWORD;
dwLanguageId: DWORD;
lpBuffer : PCHAR;
nSize : DWORD;
Arguments : Pointer): DWORD; external 'kernel32' name 'FormatMessageA';
function SysErrorMessage(ErrorCode: Integer): String;
const
MaxMsgSize = Format_Message_Max_Width_Mask;
var MsgBuffer: pChar;
begin
{-- Allocate memory for error message ---------------------------------------}
GetMem(MsgBuffer, MaxMsgSize);
FillChar(MsgBuffer^, MaxMsgSize, #0);
{-- Retrieve the message ----------------------------------------------------}
FormatMessageA(FORMAT_MESSAGE_FROM_SYSTEM,
nil,
ErrorCode,
MakeLangId(LANG_NEUTRAL, SUBLANG_DEFAULT),
MsgBuffer, { This function allocs the memory }
MaxMsgSize, { Maximum message size }
nil);
{-- Return the string and release the memory --------------------------------}
SysErrorMessage := StrPas(MsgBuffer);
FreeMem(MsgBuffer, MaxMsgSize);
end; { func. SysErrorMessage }
{$ENDIF}

86
SOURCE/ELECOM/dllexam.pas Normal file
View File

@ -0,0 +1,86 @@
program DLLEXAM;
{$H-} { important, turn off Ansi-Strings }
(*
**
** Example how to use communications with the DLL file
** You can install this program from within EleBBS and test how it works :)
**
** version: 1.02
** Created: 13-Jun-1999
**
** EleBBS install lines:
**
** DOS install line: DLLEXAM.EXE -H*P
** Win32 install line: DLLEXAM.EXE -H*W
** Win32 (telnet) install line: DLLEXAM.EXE -H*W -XT
** OS/2 install line: DLLEXAM.EXE -H*W
** OS/2 (telnet) install line: DLLEXAM.EXE -H*W -XT
**
*)
uses EleDEF;
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
var IsTelnet : Boolean;
ComHandle : Longint;
ReadCH : Char;
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure ParseCommandLine;
var Counter: Longint;
TempStr: String;
{$IFDEF MSDOS}
Code : Integer;
{$ELSE}
Code : Longint;
{$ENDIF}
begin
for Counter := 01 to ParamCount do
begin
TempStr := ParamStr(Counter);
if TempStr[1] in ['/', '-'] then
Case UpCase(TempStr[2]) of
'H' : begin
TempStr := Copy(TempStr, 3, Length(TempStr) - 2);
Val(TempStr, ComHandle, Code);
end; { 'H' }
'X' : begin
if UpCase(TempStr[3]) = 'T' then { XT }
IsTelnet := true;
end; { 'X' }
end; { case }
end; { for }
end; { proc. ParseCommandLine }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
begin
IsTelnet := false;
ParseCommandLine;
Case IsTelnet of
FALSE : Com_StartUp(1);
TRUE : Com_StartUp(2);
end; { case }
Com_SetDontClose(true); { We use an inherited handle, never close it! }
Com_OpenQuick(ComHandle); { Open the comport using the handle }
Com_SendString('Hello there!' + #13#10);
Com_SendString('Press [ENTER]');
repeat
ReadCH := Com_GetChar;
until (ReadCH = #13) OR (NOT Com_Carrier);
Com_ShutDown;
end.

181
SOURCE/ELECOM/example.pas Normal file
View File

@ -0,0 +1,181 @@
program Example;
(*
**
** EXAMPLE how to use communications
** You can install this program from within EleBBS and test how it works :)
** This is only an example of how to use EleCOM for writing so-called "doors",
** to see an example how to use EleCOM independent off a BBS program, see
** EXAM2.PAS
**
** version: 1.01
** Created: 08-Apr-1999
**
** EleBBS install lines:
**
** DOS install line: EXAMPLE.EXE -H*P
** Win32 install line: EXAMPLE.EXE -H*W
** Win32 (telnet) install line: EXAMPLE.EXE -H*W -XT
** OS/2 install line: EXAMPLE.EXE -H*W
** OS/2 (telnet) install line: EXAMPLE.EXE -H*W -XT
**
*)
{.DEFINE FOSSIL}
{.DEFINE OS2COM}
{$DEFINE W32COM}
{$IFNDEF FOSSIL}
{$IFNDEF OS2COM}
{$IFNDEF W32COM}
You need to define one of these..
{$ENDIF}
{$ENDIF}
{$ENDIF}
uses Combase,
{$IFDEF FOSSIL}
Fos_Com
{$ENDIF}
{$IFDEF OS2COM}
Os2Com,
Telnet
{$ENDIF}
{$IFDEF W32COM}
W32SNGL,
Telnet
{$ENDIF} ;
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
var ComObj : PCommObj;
IsTelnet : Boolean;
ComHandle : Longint;
ReadCH : Char;
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure Int_ComReadProc(var TempPtr: Pointer);
begin
{$IFDEF WIN32}
Case IsTelnet of
FALSE : PWin32Obj(ComObj)^.Com_DataProc(TempPtr);
TRUE : PTelnetObj(ComObj)^.Com_ReadProc(TempPtr);
end; { case }
{$ENDIF}
{$IFDEF OS2}
Case IsTelnet of
FALSE : POs2Obj(ComObj)^.Com_ReadProc(TempPtr);
TRUE : PTelnetObj(ComObj)^.Com_ReadProc(TempPtr);
end; { case }
{$ENDIF}
end; { proc. Int_ComReadProc }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure Int_ComWriteProc(var TempPtr: Pointer);
begin
{$IFDEF WIN32}
Case IsTelnet of
FALSE : PWin32Obj(ComObj)^.Com_DataProc(TempPtr);
TRUE : PTelnetObj(ComObj)^.Com_WriteProc(TempPtr);
end; { case }
{$ENDIF}
{$IFDEF OS2}
Case IsTelnet of
FALSE : POs2Obj(ComObj)^.Com_WriteProc(TempPtr);
TRUE : PTelnetObj(ComObj)^.Com_WriteProc(TempPtr);
end; { case }
{$ENDIF}
end; { proc. Int_ComWriteProc }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
procedure ParseCommandLine;
var Counter: Longint;
TempStr: String;
{$IFDEF MSDOS}
Code : Integer;
{$ELSE}
Code : Longint;
{$ENDIF}
begin
for Counter := 01 to ParamCount do
begin
TempStr := ParamStr(Counter);
if TempStr[1] in ['/', '-'] then
Case UpCase(TempStr[2]) of
'H' : begin
TempStr := Copy(TempStr, 3, Length(TempStr) - 2);
Val(TempStr, ComHandle, Code);
end; { 'H' }
'X' : begin
if UpCase(TempStr[3]) = 'T' then { XT }
IsTelnet := true;
end; { 'X' }
end; { case }
end; { for }
end; { proc. ParseCommandLine }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
Function FStr (N : LongInt) : String; { Convert integer to string }
var Temp: String;
begin
Str(n,temp);
FStr:=Temp;
end; { func. FStr }
(*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-+-*-*)
begin
IsTelnet := false;
ParseCommandLine;
{$IFDEF W32COM}
if IsTelnet then ComObj := New(PTelnetObj, Init)
else ComObj := New(PWin32Obj, Init);
{$ENDIF}
{$IFDEF FOSSIL}
ComObj := New(PFossilObj, Init);
{$ENDIF}
{$IFDEF OS2COM}
if IsTelnet then ComObj := New(PTelnetObj, Init)
else ComObj := New(POs2Obj, Init);
{$ENDIF}
{$IFDEF WIN32}
ComObj^.Com_SetDataProc(@Int_ComReadProc, @Int_ComWriteProc);
{$ENDIF}
{$IFDEF OS2}
ComObj^.Com_SetDataProc(@Int_ComReadProc, @Int_ComWriteProc);
{$ENDIF}
ComObj^.DontClose := true; { We use an inherited handle, never close it! }
ComObj^.Com_OpenQuick(ComHandle); { Open the comport using the handle }
ComObj^.Com_SendString('Hello there!' + #13#10);
ComObj^.Com_SendString('We are using handle #' + FStr(ComHandle) + #13#10);
repeat
ReadCH := ComObj^.Com_GetChar;
if ReadCH <> #13 then
Writeln('Other..');
until (ReadCH = #13) OR (NOT ComObj^.Com_Carrier);
Dispose(ComObj, Done); { Dispose the communications object }
end.

0
EMAIL.PAS → SOURCE/EMAIL.PAS
View File

0
EVENTS.PAS → SOURCE/EVENTS.PAS
View File

0
EXECBAT.PAS → SOURCE/EXECBAT.PAS
View File

0
FILE0.PAS → SOURCE/FILE0.PAS
View File

0
FILE1.PAS → SOURCE/FILE1.PAS
View File

0
FILE10.PAS → SOURCE/FILE10.PAS
View File

0
FILE11.PAS → SOURCE/FILE11.PAS
View File

0
FILE12.PAS → SOURCE/FILE12.PAS
View File

0
FILE13.PAS → SOURCE/FILE13.PAS
View File

0
FILE14.PAS → SOURCE/FILE14.PAS
View File

0
FILE2.PAS → SOURCE/FILE2.PAS
View File

0
FILE3.PAS → SOURCE/FILE3.PAS
View File

0
FILE4.PAS → SOURCE/FILE4.PAS
View File

0
FILE5.PAS → SOURCE/FILE5.PAS
View File

0
FILE6.PAS → SOURCE/FILE6.PAS
View File

0
FILE7.PAS → SOURCE/FILE7.PAS
View File

0
FILE8.PAS → SOURCE/FILE8.PAS
View File

0
FILE9.PAS → SOURCE/FILE9.PAS
View File

0
LINECHAT.PAS → SOURCE/LINECHAT.PAS
View File

0
LOGON.PAS → SOURCE/LOGON.PAS
View File

0
MAIL0.PAS → SOURCE/MAIL0.PAS
View File

0
MAIL1.PAS → SOURCE/MAIL1.PAS
View File

0
MAIL2.PAS → SOURCE/MAIL2.PAS
View File

0
MAIL3.PAS → SOURCE/MAIL3.PAS
View File

0
MAIL4.PAS → SOURCE/MAIL4.PAS
View File

0
MAINT.PAS → SOURCE/MAINT.PAS
View File

0
MENUS.PAS → SOURCE/MENUS.PAS
View File

0
MENUS2.PAS → SOURCE/MENUS2.PAS
View File

0
MENUS3.PAS → SOURCE/MENUS3.PAS
View File

0
MISCUSER.PAS → SOURCE/MISCUSER.PAS
View File

0
MSGPACK.PAS → SOURCE/MSGPACK.PAS
View File

0
MULTNODE.PAS → SOURCE/MULTNODE.PAS
View File

0
MYIO.PAS → SOURCE/MYIO.PAS
View File

0
NEWUSERS.PAS → SOURCE/NEWUSERS.PAS
View File

0
NODELIST.PAS → SOURCE/NODELIST.PAS
View File

0
OFFLINE.PAS → SOURCE/OFFLINE.PAS
View File

0
RECORDS.PAS → SOURCE/RECORDS.PAS
View File

0
RENEGADE.PAS → SOURCE/RENEGADE.PAS
View File

0
RENEMAIL.PAS → SOURCE/RENEMAIL.PAS
View File

0
RGLNG.PAS → SOURCE/RGLNG.PAS
View File

0
RGMAIN.PAS → SOURCE/RGMAIN.PAS
View File

0
RGNOTE.PAS → SOURCE/RGNOTE.PAS
View File

0
RGQUOTE.PAS → SOURCE/RGQUOTE.PAS
View File

0
RGSCFG.PAS → SOURCE/RGSCFG.PAS
View File

0
SCRIPT.PAS → SOURCE/SCRIPT.PAS
View File

0
SHORTMSG.PAS → SOURCE/SHORTMSG.PAS
View File

0
SPAWNO.PAS → SOURCE/SPAWNO.PAS
View File

0
SPLITCHA.PAS → SOURCE/SPLITCHA.PAS
View File

0
STATS.PAS → SOURCE/STATS.PAS
View File

Some files were not shown because too many files have changed in this diff Show More