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

Merge pull request #1 from rickparrish/master 

Updated code
This commit is contained in:
Renegade-Exodus 2013-02-18 12:24:24 -08:00
parent 6923bf0c27 860bf057e1
commit 640391347e
392 changed files with 9825 additions and 393 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

48
BUILDBP.CMD Normal file
View File

@ -0,0 +1,48 @@
@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 RGQUOTE.EXE
Z:\BP\BIN\BPC.EXE RGQUOTE.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

48
BUILDVP.CMD Normal file
View File

@ -0,0 +1,48 @@
@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 RGQUOTE.EXE
Z:\VP21\BIN.W32\VPC RGQUOTE.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

7
COPYEXEBP.CMD Normal file
View File

@ -0,0 +1,7 @@
@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\RGQUOTE.EXE Z:\RG119\DATA\
COPY Z:\PROGRAMMING\RG119SRC\EXE\BP\TAGLINE.EXE Z:\RG119\DATA\

6
COPYEXEVP.CMD Normal file
View File

@ -0,0 +1,6 @@
@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\RGQUOTE.EXE Z:\RG119\DATA\RGQUOTE32.EXE
COPY Z:\PROGRAMMING\RG119SRC\EXE\VP\TAGLINE.EXE Z:\RG119\DATA\TAGLINE32.EXE

31
README.md Normal file
View File

@ -0,0 +1,31 @@
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>Find/correct any usage of FOR loop variables after the loop (since they are 1 greater in VP than in BP</li>
<li>Find/correct any file i/o on untyped files where Words or Integers are being read</li>
</ul>
Completed 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>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>WORD in RECORD to SMALLWORD</li>
<li>INTEGER in RECORD to SMALLINT</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>Implement any REETODOs that appear in compiled executables</li>
</ul>

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

@ -1,3 +1,7 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S+,V-}
UNIT Archive1;
@ -186,7 +190,7 @@ END;
PROCEDURE ExtractToTemp;
TYPE
TotalsRecordType = RECORD
TotalFiles: Integer;
TotalFiles: SmallInt;
TotalSize: LongInt;
END;
VAR

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

@ -1,3 +1,7 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S+,V-}
UNIT Archive2;

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

@ -1,3 +1,7 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D-,E-,F+,I-,L-,N-,O+,R-,S+,V-}
UNIT Archive3;
@ -17,7 +21,7 @@ USES
File11,
TimeFunc;
PROCEDURE CvtFiles(FArea: Integer; FileName,ReZipCmd: AStr; VAR TotalFiles: Integer; VAR TotalOldSize,TotalNewSize: LongInt);
PROCEDURE CvtFiles(FArea: Integer; FileName,ReZipCmd: AStr; VAR TotalFiles: SmallInt; VAR TotalOldSize,TotalNewSize: LongInt);
VAR
S: AStr;
DS: DirStr;
@ -157,7 +161,7 @@ END;
PROCEDURE ReZipStuff;
TYPE
TotalsRecordType = RECORD
TotalFiles: Integer;
TotalFiles: SmallInt;
TotalOldSize,
TotalNewSize: LongInt
END;

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

@ -1,3 +1,7 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S+,V-}
UNIT ArcView;
@ -48,23 +52,23 @@ TYPE
ArcRecordType = RECORD {* structure of ARC archive file header *}
FileName: ARRAY [0..12] OF Char; {* FileName *}
C_Size: LongInt; {* compressed size *}
Mod_Date: Integer; {* last mod file Date *}
Mod_Time: Integer; {* last mod file Time *}
CRC: Integer; {* CRC *}
Mod_Date: SmallInt; {* last mod file Date *}
Mod_Time: SmallInt; {* last mod file Time *}
CRC: SmallInt; {* CRC *}
U_Size: LongInt; {* uncompressed size *}
END;
ZipRecordType = RECORD {* structure of ZIP archive file header *}
Version: Integer; {* Version needed to extract *}
Bit_Flag: Integer; {* General purpose bit flag *}
Method: Integer; {* compression Method *}
Mod_Time: Integer; {* last mod file Time *}
Mod_Date: Integer; {* last mod file Date *}
Version: SmallInt; {* Version needed to extract *}
Bit_Flag: SmallInt; {* General purpose bit flag *}
Method: SmallInt; {* compression Method *}
Mod_Time: SmallInt; {* last mod file Time *}
Mod_Date: SmallInt; {* last mod file Date *}
CRC: LongInt; {* CRC-32 *}
C_Size: LongInt; {* compressed size *}
U_Size: LongInt; {* uncompressed size *}
F_Length: Integer; {* FileName Length *}
E_Length: Integer; {* extra field Length *}
F_Length: SmallInt; {* FileName Length *}
E_Length: SmallInt; {* extra field Length *}
END;
ZooRecordType = RECORD {* structure of ZOO archive file header *}
@ -73,9 +77,9 @@ TYPE
Method: Byte; {* 0 = Stored, 1 = Crunched *}
Next: LongInt; {* position of Next directory entry *}
Offset: LongInt; {* position of this file *}
Mod_Date: Word; {* modification Date (DOS format) *}
Mod_Time: Word; {* modification Time (DOS format) *}
CRC: Word; {* CRC *}
Mod_Date: SmallWord; {* modification Date (DOS format) *}
Mod_Time: SmallWord; {* modification Time (DOS format) *}
CRC: SmallWord; {* CRC *}
U_Size: LongInt; {* uncompressed size *}
C_Size: LongInt; {* compressed size *}
Major_V: Char; {* major Version number *}
@ -83,11 +87,11 @@ TYPE
Deleted: Byte; {* 0 = active, 1 = Deleted *}
Struc: Char; {* file structure if any *}
Comment: LongInt; {* location of file Comment (0 = none) *}
Cmt_Size: Word; {* Length of Comment (0 = none) *}
Cmt_Size: SmallWord; {* Length of Comment (0 = none) *}
FName: ARRAY [0..12] OF Char; {* FileName *}
Var_DirLen: Integer; {* Length of variable part of dir entry *}
Var_DirLen: SmallInt; {* Length of variable part of dir entry *}
TZ: Char; {* timezone where file was archived *}
Dir_Crc: Word; {* CRC of directory entry *}
Dir_Crc: SmallWord; {* CRC of directory entry *}
END;
LZHRecordType = RECORD {* structure of LZH archive file header *}
@ -96,11 +100,11 @@ TYPE
Method: ARRAY [1..5] OF Char; {* compression TYPE "-lh#-" *}
C_Size: LongInt; {* compressed size *}
U_Size: LongInt; {* uncompressed size *}
Mod_Time: Integer;{* last mod file Time *}
Mod_Date: Integer;{* last mod file Date *}
Attrib: Integer; {* file attributes *}
Mod_Time: SmallInt;{* last mod file Time *}
Mod_Date: SmallInt;{* last mod file Date *}
Attrib: SmallInt; {* file attributes *}
F_Length: Byte; {* Length of FileName *}
CRC: Integer; {* CRC *}
CRC: SmallInt; {* CRC *}
END;
ARJRecordType = RECORD
@ -113,20 +117,20 @@ TYPE
FileType: Byte;
GarbleMod: Byte;
Time,
Date: Integer;
Date: SmallInt;
CompSize: LongInt;
OrigSize: LongInt;
OrigCRC: ARRAY[1..4] OF Byte;
EntryName: Word;
AccessMode: Word;
HostData: Word;
EntryName: SmallWord;
AccessMode: SmallWord;
HostData: SmallWord;
END;
OutRec = RECORD {* output information structure *}
FileName: AStr; {* output file name *}
Date, {* output Date *}
Time, {* output Time *}
Method: Integer; {* output storage type *}
Method: SmallInt; {* output storage type *}
CSize, {* output compressed size *}
USize: LongInt; {* output uncompressed size *}
END;
@ -312,8 +316,8 @@ PROCEDURE ARJ_Proc(VAR ArjFile: FILE;
VAR Aborted: Boolean);
TYPE
ARJSignature = RECORD
MagicNumber: Word;
BasicHdrSiz: Word;
MagicNumber: SmallWord;
BasicHdrSiz: SmallWord;
END;
VAR
Hdr: ARJRecordType;

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

@ -1,3 +1,7 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S+,V-}
UNIT AutoMsg;

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

@ -1,3 +1,7 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D-,E-,F+,I-,L-,N-,O+,R-,S+,V-}
UNIT BBSList;

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

@ -1,3 +1,7 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S+,V-}
UNIT Boot;
@ -813,12 +817,17 @@ FUNCTION SchareLoaded: Boolean;
VAR
T_Al: Byte;
BEGIN
{$IFDEF MSDOS}
ASM
Mov Ah,10h
Mov Al,0h
Int 2fh
Mov T_Al,Al
END;
{$ENDIF}
{$IFDEF WIN32}
T_Al := $FF;
{$ENDIF}
SchareLoaded := (T_Al = $FF);
END;
@ -833,6 +842,7 @@ VAR
WinOk,
WinNTOk: Boolean;
{$IFDEF MSDOS}
FUNCTION TrueDosVer(VAR WinNTOk: Boolean): Word;
VAR
Regs: Registers;
@ -848,7 +858,16 @@ VAR
TrueDosVer := Bl;
END;
END;
{$ENDIF}
{$IFDEF WIN32}
FUNCTION TrueDosVer(VAR WinNTOk: Boolean): Word;
BEGIN
WinNtOK := TRUE;
TrueDosVer := 5;
END;
{$ENDIF}
{$IFDEF MSDOS}
FUNCTION DosVer(VAR Minor,OS2Ver: Word): Word;
VAR
Regs: Registers;
@ -866,7 +885,17 @@ VAR
OS2Ver := 2;
END;
END;
{$ENDIF}
{$IFDEF WIN32}
FUNCTION DosVer(VAR Minor,OS2Ver: Word): Word;
BEGIN
Minor := 0;
OS2Ver := 0;
DosVer := 5;
END;
{$ENDIF}
{$IFDEF MSDOS}
FUNCTION Win3_Check_On: Boolean;
VAR
Regs: Registers;
@ -881,7 +910,15 @@ VAR
Win3_Check_On := TRUE;
END;
END;
{$ENDIF}
{$IFDEF WIN32}
FUNCTION Win3_Check_On: Boolean;
BEGIN
Win3_Check_On := FALSE;
END;
{$ENDIF}
{$IFDEF MSDOS}
FUNCTION DV_Check_On: Boolean;
VAR
Regs: Registers;
@ -899,6 +936,13 @@ VAR
ELSE
DV_Check_On := TRUE;
END;
{$ENDIF}
{$IFDEF WIN32}
FUNCTION DV_Check_On: Boolean;
BEGIN
DV_Check_On := FALSE;
END;
{$ENDIF}
BEGIN
D5 := 0;

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

@ -1,3 +1,7 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D-,E-,F+,I-,L-,N-,O+,R-,S+,V-}
UNIT Bulletin;

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

@ -1,3 +1,7 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D-,E-,F+,I-,L-,N+,O-,R-,S-,V-}
UNIT Common;
@ -48,7 +52,7 @@ TYPE
LightBarRecordType = RECORD
XPos,
YPos: Byte;
CmdToExec: Integer;
CmdToExec: SmallInt;
CmdToShow: STRING[40];
END;
@ -95,7 +99,7 @@ TYPE
BDLUserNum,
BDLSection,
BDLPoints,
BDLUploader: Integer;
BDLUploader: SmallInt;
BDLFSize,
BDLTime: LongInt;
BDLFlags: TransferFlagSet;
@ -104,10 +108,10 @@ TYPE
BatchULRecordType = RECORD
BULFileName: Str12;
BULUserNum,
BULSection: Integer;
BULSection: SmallInt;
BULDescription: Str50;
BULVPointer: LongInt;
BULVTextSize: Integer;
BULVTextSize: SmallInt;
END;
ExtendedDescriptionArray = ARRAY [1..99] OF Str50;
@ -157,7 +161,7 @@ TYPE
ConferenceKeyType = SET OF '@'..'Z';
CompArrayType = ARRAY[0..1] OF INTEGER;
CompArrayType = ARRAY[0..1] OF SMALLINT;
CONST
MCIBuffer: MCIBufferPtr = NIL;
@ -272,7 +276,9 @@ VAR
DatFilePath: STRING[40];
Interrupt14: Pointer; { far ptr TO interrupt 14 }
{$IFDEF MSDOS}
Ticks: LongInt ABSOLUTE $0040:$006C;
{$ENDIF}
IEMSIRec: IEMSIRecord;
FossilPort: Word;
SockHandle: STRING; { Telnet Handle }
@ -460,6 +466,10 @@ VAR
MQArea,
VQArea: Boolean;
{$IFDEF WIN32}
procedure Sound(hz: Word; duration: Word);
function Ticks: LongInt;
{$ENDIF}
FUNCTION GetC(c: Byte): STRING;
PROCEDURE ShowColors;
FUNCTION CheckDriveSpace(S,Path: AStr; MinSpace: Integer): Boolean;
@ -606,10 +616,10 @@ FUNCTION YN(Len: Byte; DYNY: Boolean): Boolean;
FUNCTION PYNQ(CONST InString: AStr; MaxLen: Byte; DYNY: Boolean): Boolean;
PROCEDURE InputLongIntWC(S: AStr; VAR L: LongInt; InputFlags: InputFlagSet; LowNum,HighNum: LongInt; VAR Changed: Boolean);
PROCEDURE InputLongIntWOC(S: AStr; VAR L: LongInt; InputFlags: InputFlagSet; LowNum,HighNum: LongInt);
PROCEDURE InputWordWC(S: AStr; VAR W: Word; InputFlags: InputFlagSet; LowNum,HighNum: Word; VAR Changed: Boolean);
PROCEDURE InputWordWOC(S: AStr; VAR W: Word; InputFlags: InputFlagSet; LowNum,HighNum: Word);
PROCEDURE InputIntegerWC(S: AStr; VAR I: Integer; InputFlags: InputFlagSet; LowNum,HighNum: Integer; VAR Changed: Boolean);
PROCEDURE InputIntegerWOC(S: AStr; VAR I: Integer; InputFlags: InputFlagSet; LowNum,HighNum: Integer);
PROCEDURE InputWordWC(S: AStr; VAR W: SmallWord; InputFlags: InputFlagSet; LowNum,HighNum: Word; VAR Changed: Boolean);
PROCEDURE InputWordWOC(S: AStr; VAR W: SmallWord; InputFlags: InputFlagSet; LowNum,HighNum: Word);
PROCEDURE InputIntegerWC(S: AStr; VAR I: SmallInt; InputFlags: InputFlagSet; LowNum,HighNum: Integer; VAR Changed: Boolean);
PROCEDURE InputIntegerWOC(S: AStr; VAR I: SmallInt; InputFlags: InputFlagSet; LowNum,HighNum: Integer);
PROCEDURE InputByteWC(S: AStr; VAR B: Byte; InputFlags: InputFlagSet; LowNum,HighNum: Byte; VAR Changed: Boolean);
PROCEDURE InputByteWOC(S: AStr; VAR B: Byte; InputFlags: InputFlagSet; LowNum,HighNum: Byte);
PROCEDURE InputDefault(VAR S: STRING; v: STRING; MaxLen: Byte; InputFlags: InputFlagSet; LineFeed: Boolean);
@ -658,12 +668,103 @@ USES
File11,
Mail0,
MultNode,
{$IFDEF MSDOS}
SpawnO,
{$ENDIF}
SysOp12,
Vote;
Vote
{$IFDEF WIN32}
,VPSysLow
,VPUtils
,Windows
{$ENDIF}
;
{$IFDEF WIN32}
procedure Sound(hz: Word; duration: Word);
begin
Windows.Beep(hz, duration);
end;
function Ticks: LongInt;
begin
Ticks := GetTimeMSec div 55;
end;
{$ENDIF}
{$IFDEF MSDOS}
FUNCTION UpdateCRC32(CRC: LongInt; VAR Buffer; Len: Word): LongInt; EXTERNAL;
{$L CRC32.OBJ }
{$ENDIF}
{$IFDEF WIN32}
CONST
CRC_32_TAB : array[0..255] of LongInt = (
$00000000, $77073096, $ee0e612c, $990951ba, $076dc419,
$706af48f, $e963a535, $9e6495a3, $0edb8832, $79dcb8a4,
$e0d5e91e, $97d2d988, $09b64c2b, $7eb17cbd, $e7b82d07,
$90bf1d91, $1db71064, $6ab020f2, $f3b97148, $84be41de,
$1adad47d, $6ddde4eb, $f4d4b551, $83d385c7, $136c9856,
$646ba8c0, $fd62f97a, $8a65c9ec, $14015c4f, $63066cd9,
$fa0f3d63, $8d080df5, $3b6e20c8, $4c69105e, $d56041e4,
$a2677172, $3c03e4d1, $4b04d447, $d20d85fd, $a50ab56b,
$35b5a8fa, $42b2986c, $dbbbc9d6, $acbcf940, $32d86ce3,
$45df5c75, $dcd60dcf, $abd13d59, $26d930ac, $51de003a,
$c8d75180, $bfd06116, $21b4f4b5, $56b3c423, $cfba9599,
$b8bda50f, $2802b89e, $5f058808, $c60cd9b2, $b10be924,
$2f6f7c87, $58684c11, $c1611dab, $b6662d3d, $76dc4190,
$01db7106, $98d220bc, $efd5102a, $71b18589, $06b6b51f,
$9fbfe4a5, $e8b8d433, $7807c9a2, $0f00f934, $9609a88e,
$e10e9818, $7f6a0dbb, $086d3d2d, $91646c97, $e6635c01,
$6b6b51f4, $1c6c6162, $856530d8, $f262004e, $6c0695ed,
$1b01a57b, $8208f4c1, $f50fc457, $65b0d9c6, $12b7e950,
$8bbeb8ea, $fcb9887c, $62dd1ddf, $15da2d49, $8cd37cf3,
$fbd44c65, $4db26158, $3ab551ce, $a3bc0074, $d4bb30e2,
$4adfa541, $3dd895d7, $a4d1c46d, $d3d6f4fb, $4369e96a,
$346ed9fc, $ad678846, $da60b8d0, $44042d73, $33031de5,
$aa0a4c5f, $dd0d7cc9, $5005713c, $270241aa, $be0b1010,
$c90c2086, $5768b525, $206f85b3, $b966d409, $ce61e49f,
$5edef90e, $29d9c998, $b0d09822, $c7d7a8b4, $59b33d17,
$2eb40d81, $b7bd5c3b, $c0ba6cad, $edb88320, $9abfb3b6,
$03b6e20c, $74b1d29a, $ead54739, $9dd277af, $04db2615,
$73dc1683, $e3630b12, $94643b84, $0d6d6a3e, $7a6a5aa8,
$e40ecf0b, $9309ff9d, $0a00ae27, $7d079eb1, $f00f9344,
$8708a3d2, $1e01f268, $6906c2fe, $f762575d, $806567cb,
$196c3671, $6e6b06e7, $fed41b76, $89d32be0, $10da7a5a,
$67dd4acc, $f9b9df6f, $8ebeeff9, $17b7be43, $60b08ed5,
$d6d6a3e8, $a1d1937e, $38d8c2c4, $4fdff252, $d1bb67f1,
$a6bc5767, $3fb506dd, $48b2364b, $d80d2bda, $af0a1b4c,
$36034af6, $41047a60, $df60efc3, $a867df55, $316e8eef,
$4669be79, $cb61b38c, $bc66831a, $256fd2a0, $5268e236,
$cc0c7795, $bb0b4703, $220216b9, $5505262f, $c5ba3bbe,
$b2bd0b28, $2bb45a92, $5cb36a04, $c2d7ffa7, $b5d0cf31,
$2cd99e8b, $5bdeae1d, $9b64c2b0, $ec63f226, $756aa39c,
$026d930a, $9c0906a9, $eb0e363f, $72076785, $05005713,
$95bf4a82, $e2b87a14, $7bb12bae, $0cb61b38, $92d28e9b,
$e5d5be0d, $7cdcefb7, $0bdbdf21, $86d3d2d4, $f1d4e242,
$68ddb3f8, $1fda836e, $81be16cd, $f6b9265b, $6fb077e1,
$18b74777, $88085ae6, $ff0f6a70, $66063bca, $11010b5c,
$8f659eff, $f862ae69, $616bffd3, $166ccf45, $a00ae278,
$d70dd2ee, $4e048354, $3903b3c2, $a7672661, $d06016f7,
$4969474d, $3e6e77db, $aed16a4a, $d9d65adc, $40df0b66,
$37d83bf0, $a9bcae53, $debb9ec5, $47b2cf7f, $30b5ffe9,
$bdbdf21c, $cabac28a, $53b39330, $24b4a3a6, $bad03605,
$cdd70693, $54de5729, $23d967bf, $b3667a2e, $c4614ab8,
$5d681b02, $2a6f2b94, $b40bbe37, $c30c8ea1, $5a05df1b,
$2d02ef8d);
FUNCTION UpdateCRC32(CRC: LongInt; VAR Buffer; Len: Word): LongInt;
VAR
i: Integer;
Octet: ^Byte;
BEGIN
Octet := @buffer;
for i := 1 to Len do
begin
CRC := CRC_32_TAB[Byte(Crc XOR LongInt(Octet^))] XOR ((Crc SHR 8) AND $00FFFFFF);
Inc(Octet);
end;
UpdateCRC32 := CRC;
END;
{$ENDIF}
FUNCTION CheckPW: Boolean;
BEGIN
@ -750,22 +851,22 @@ BEGIN
Common3.InputLongIntWOC(S,L,InputFlags,LowNum,HighNum);
END;
PROCEDURE InputWordWC(S: AStr; VAR W: Word; InputFlags: InputFlagSet; LowNum,HighNum: Word; VAR Changed: Boolean);
PROCEDURE InputWordWC(S: AStr; VAR W: SmallWord; InputFlags: InputFlagSet; LowNum,HighNum: Word; VAR Changed: Boolean);
BEGIN
Common3.InputWordWC(S,W,InputFlags,LowNum,HighNum,Changed);
END;
PROCEDURE InputWordWOC(S: AStr; VAR W: Word; InputFlags: InputFlagSet; LowNum,HighNum: Word);
PROCEDURE InputWordWOC(S: AStr; VAR W: SmallWord; InputFlags: InputFlagSet; LowNum,HighNum: Word);
BEGIN
Common3.InputWordWOC(S,W,InputFlags,LowNum,HighNum);
END;
PROCEDURE InputIntegerWC(S: AStr; VAR I: Integer; InputFlags: InputFlagSet; LowNum,HighNum: Integer; VAR Changed: Boolean);
PROCEDURE InputIntegerWC(S: AStr; VAR I: SmallInt; InputFlags: InputFlagSet; LowNum,HighNum: Integer; VAR Changed: Boolean);
BEGIN
Common3.InputIntegerWC(S,I,InputFlags,LowNum,HighNum,Changed);
END;
PROCEDURE InputIntegerWOC(S: AStr; VAR I: Integer; InputFlags: InputFlagSet; LowNum,HighNum: Integer);
PROCEDURE InputIntegerWOC(S: AStr; VAR I: SmallInt; InputFlags: InputFlagSet; LowNum,HighNum: Integer);
BEGIN
Common3.InputIntegerWOC(S,I,Inputflags,LowNum,HighNum);
END;
@ -2008,6 +2109,7 @@ BEGIN
SwapVectors;
{$IFDEF MSDOS}
IF (General.SwapShell) THEN
BEGIN
s := GetEnv('TEMP');
@ -2016,6 +2118,10 @@ BEGIN
Init_SpawNo(s,General.SwapTo,20,10);
ResultCode := Spawn(GetEnv('COMSPEC'),FName,0);
END;
{$ENDIF}
{$IFDEF WIN32}
ResultCode := -1;
{$ENDIF}
IF (NOT General.SwapShell) OR (ResultCode = -1) THEN
BEGIN
@ -2688,16 +2794,23 @@ CONST
LastTimeSlice: LongInt = 0;
LastCheckTimeSlice: LongInt = 0;
VAR
{$IFDEF MSDOS}
Killme: Pointer ABSOLUTE $0040 :$F000;
{$ENDIF}
Tf: Boolean;
I: Integer;
C: Word;
TempTimer: LongInt;
BEGIN
IF (DieLater) THEN
{$IFDEF MSDOS}
ASM
Call Killme
END;
{$ENDIF}
{$IFDEF WIN32}
Halt;
{$ENDIF}
LIL := 1;
IF (Buf <> '') THEN
BEGIN
@ -2737,11 +2850,17 @@ BEGIN
BEGIN
FOR I := 1 TO 100 DO
BEGIN
{$IFDEF MSDOS}
Sound(500 + (I * 10));
Delay(2);
Sound(100 + (I * 10));
Delay(2);
NoSound;
{$ENDIF}
{$IFDEF WIN32}
Sound(500, 200);
Sound(1500, 200);
{$ENDIF}
END;
LastBeep := TempTimer;
END;
@ -2770,6 +2889,7 @@ BEGIN
BEGIN
IF (ABS((Ticks - LastTimeSlice)) >= General.Slicetimer) THEN
BEGIN
{$IFDEF MSDOS}
CASE Tasker OF
None : ASM
int 28h
@ -2792,6 +2912,10 @@ BEGIN
Pop dx
END;
END;
{$ENDIF}
{$IFDEF WIN32}
Sleep(1);
{$ENDIF}
LastTimeSlice := Ticks;
END
ELSE IF (MultiNodeChat) AND (NOT InChat) AND (ABS(Ticks - LastCheckTimeSlice) > 9) THEN
@ -2956,6 +3080,7 @@ BEGIN
END;
END;
{$IFDEF MSDOS}
FUNCTION AOnOff(b: Boolean; CONST s1,s2:AStr): STRING; ASSEMBLER;
ASM
PUSH ds
@ -2974,6 +3099,16 @@ ASM
REP MOVSB
POP ds
END;
{$ENDIF}
{$IFDEF WIN32}
FUNCTION AOnOff(b: Boolean; CONST s1,s2:AStr): STRING;
BEGIN
if (b) then
AOnOff := s1
else
AOnOff := s2;
END;
{$ENDIF}
FUNCTION ShowOnOff(b: Boolean): STRING;
BEGIN
@ -3803,7 +3938,7 @@ FUNCTION MaxChatRec: LongInt;
VAR
DirInfo1: SearchRec;
BEGIN
FindFirst(General.TempPath+'MSG'+IntToStr(ThisNode)+'.TMP',0,DirInfo1);
FindFirst(General.TempPath+'MSG'+IntToStr(ThisNode)+'.TMP',AnyFile,DirInfo1);
IF (DOSError = 0) THEN
MaxChatRec := DirInfo1.Size
ELSE
@ -3814,7 +3949,7 @@ FUNCTION MaxNodes: Byte;
VAR
DirInfo1: SearchRec;
BEGIN
FindFirst(General.DataPath+'MULTNODE.DAT',0,DirInfo1);
FindFirst(General.DataPath+'MULTNODE.DAT',AnyFile,DirInfo1);
IF (DOSError = 0) THEN
MaxNodes := (DirInfo1.Size DIV SizeOf(NodeRecordType))
ELSE
@ -3909,7 +4044,7 @@ FUNCTION MaxUsers: Integer;
VAR
DirInfo1: SearchRec;
BEGIN
FindFirst(General.DataPath+'USERS.DAT',0,DirInfo1);
FindFirst(General.DataPath+'USERS.DAT',AnyFile,DirInfo1);
IF (DOSError = 0) THEN
MaxUsers := (DirInfo1.Size DIV SizeOf(UserRecordType))
ELSE
@ -3920,7 +4055,7 @@ FUNCTION MaxIDXRec: Integer;
VAR
DirInfo1: SearchRec;
BEGIN
FindFirst(General.DataPath+'USERS.IDX',0,DirInfo1);
FindFirst(General.DataPath+'USERS.IDX',AnyFile,DirInfo1);
IF (DOSError = 0) THEN
MaxIDXRec := (DirInfo1.Size DIV SizeOf(UserIDXRec))
ELSE
@ -3933,7 +4068,7 @@ FUNCTION HiMsg: Word;
VAR
DirInfo1: SearchRec;
BEGIN
FindFirst(General.MsgPath+MemMsgArea.FileName+'.HDR',0,DirInfo1);
FindFirst(General.MsgPath+MemMsgArea.FileName+'.HDR',AnyFile,DirInfo1);
IF (DOSError = 0) THEN
HiMsg := (DirInfo1.Size DIV SizeOf(MHeaderRec))
ELSE
@ -4004,7 +4139,12 @@ BEGIN
TempStr := '';
FOR XPos := 1 TO MaxDisplayCols DO
BEGIN
{$IFDEF MSDOS}
c := Chr(Mem[VidSeg:(160 * (YPos - 1) + 2 * (XPos - 1))]);
{$ENDIF}
{$IFDEF WIN32}
c := SysReadCharAt(XPos - 1, YPos - 1);
{$ENDIF}
IF (c = #0) THEN
c := #32;
IF ((XPos = WhereX) AND (YPos = WhereY)) THEN
@ -4334,7 +4474,9 @@ BEGIN
SaveCurCo := CurrentColor;
SaveMCIAllowed := MCIAllowed;
MCIAllowed := TRUE;
{$IFDEF MSDOS}
NoSound;
{$ENDIF}
IF (NOT AllowContinue) AND NOT (PrintingFile AND AllowAbort) THEN
IsCont := FALSE;
IF (IsCont) THEN
@ -4800,7 +4942,9 @@ END;
FUNCTION DiskKBFree(DrivePath: AStr): LongInt;
VAR
F: TEXT;
{$IFDEF MSDOS}
Regs: Registers;
{$ENDIF}
S,
S1: STRING;
Counter: Integer;
@ -4839,6 +4983,7 @@ BEGIN
END
ELSE
BEGIN
{$IFDEF MSDOS}
FillChar(Regs,SizeOf(Regs),#0);
Regs.Ah := $36;
Regs.Dl := ExtractDriveNumber(DrivePath);
@ -4846,6 +4991,10 @@ BEGIN
C := (1.0 * Regs.Ax);
C1 := ((1.0 * Regs.Cx) * C);
C2 := ((1.0 * Regs.Bx) * C1);
{$ENDIF}
{$IFDEF WIN32}
C2 := DiskFree(ExtractDriveNumber(DrivePath));
{$ENDIF}
END;
DiskKBFree := Round(C2 / 1024.0);
END;

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

@ -1,3 +1,7 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S-,V-}
UNIT Common1;

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

@ -1,3 +1,7 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S-,V-}
UNIT Common2;
@ -25,7 +29,12 @@ USES
LineChat,
SysOp2G,
SysOp3,
SplitCha;
SplitCha
{$IFDEF WIN32}
,VPSysLow
,Windows
{$ENDIF}
;
CONST
SYSKEY_LENGTH = 1269;
@ -151,6 +160,7 @@ CONST
'H','o','u','r','s',':',#25,#6 ,'M','a','i','l',' ',':',#25,#6 ,'O',
'v','e','r','l','a','y','s',':',#25,#7 ,#24);
{$IFDEF MSDOS}
PROCEDURE BiosScroll(up: Boolean); ASSEMBLER;
ASM
Mov cx,0
@ -167,6 +177,19 @@ ASM
@Go:
Int 10h
END;
{$ENDIF}
{$IFDEF WIN32}
PROCEDURE BiosScroll(up: Boolean);
BEGIN
if (up) then
begin
SysScrollUp(0, 0, MaxDisplayCols-1, MaxDisplayRows-1, 2, 7);
end else
begin
SysScrollDn(0, 0, MaxDisplayCols-1, MaxDisplayRows-1, 2, 7);
end;
END;
{$ENDIF}
PROCEDURE CPR(c1,c2: Byte);
VAR
@ -276,7 +299,12 @@ BEGIN
CASE WhichScreen OF
1 : WITH ThisUser DO
BEGIN
{$IFDEF MSDOS}
Update_Logo(Win1,ScreenAddr[(FirstRow - 1) * 160],WIN1_LENGTH);
{$ENDIF}
{$IFDEF WIN32}
Update_Logo(Win1, 1, FirstRow, WIN1_LENGTH);
{$ENDIF}
GoToXY(02,FirstRow);
Write(Caps(Name));
GoToXY(33,FirstRow);
@ -321,7 +349,12 @@ BEGIN
END;
2 : WITH ThisUser DO
BEGIN
{$IFDEF MSDOS}
Update_Logo(Win2,ScreenAddr[(FirstRow - 1) * 160],WIN2_LENGTH);
{$ENDIF}
{$IFDEF WIN32}
Update_Logo(Win2, 1, FirstRow, WIN2_LENGTH);
{$ENDIF}
GoToXY(02,FirstRow);
Write(Street);
GoToXY(33,FirstRow);
@ -354,7 +387,12 @@ BEGIN
END;
3 : WITH ThisUser DO
BEGIN
{$IFDEF MSDOS}
Update_Logo(Win3,ScreenAddr[(FirstRow - 1) * 160],WIN3_LENGTH);
{$ENDIF}
{$IFDEF WIN32}
Update_Logo(Win3, 1, FirstRow, WIN3_LENGTH);
{$ENDIF}
GoToXY(06,FirstRow);
Write(Loggedon);
GoToXY(16,FirstRow);
@ -403,7 +441,12 @@ BEGIN
Close(HistoryFile);
WITH History DO
BEGIN
{$IFDEF MSDOS}
Update_Logo(Win4,ScreenAddr[(FirstRow - 1) * 160],WIN4_LENGTH);
{$ENDIF}
{$IFDEF WIN32}
Update_Logo(Win4, 1, FirstRow, WIN4_LENGTH);
{$ENDIF}
GoToXY(20,FirstRow);
Write(Callers);
GoToXY(34,FirstRow);
@ -426,7 +469,12 @@ BEGIN
END;
5 : WITH History DO
BEGIN
{$IFDEF MSDOS}
Update_Logo(Win5,ScreenAddr[(FirstRow - 1) * 160],WIN5_LENGTH);
{$ENDIF}
{$IFDEF WIN32}
Update_Logo(Win5, 1, FirstRow, WIN5_LENGTH);
{$ENDIF}
GoToXY(20,FirstRow);
Write(General.CallerNum);
GoToXY(31,FirstRow);
@ -551,7 +599,12 @@ BEGIN
CASE Ord(C) OF
119 : BEGIN { CTRL-HOME }
SaveScreen(Wind);
{$IFDEF MSDOS}
Update_Logo(SYSKEY,ScreenAddr[0],SYSKEY_LENGTH);
{$ENDIF}
{$IFDEF WIN32}
Update_Logo(SYSKEY, 1, 1, SYSKEY_LENGTH);
{$ENDIF}
CursorOn(FALSE);
C := ReadKey;
IF (C = #0) THEN
@ -811,9 +864,14 @@ BEGIN
REPEAT
OutKey(^G);
Delay(500);
{$IFDEF MSDOS}
ASM
Int 28h
END;
{$ENDIF}
{$IFDEF WIN32}
Sleep(1);
{$ENDIF}
CheckHangUp;
UNTIL ((NOT Empty) OR (HangUp));
Update_Screen;

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

@ -1,3 +1,7 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S-,V-,X-}
UNIT Common3;
@ -11,10 +15,10 @@ PROCEDURE InputDefault(VAR S: STRING; v: STRING; MaxLen: Byte; InputFlags: Input
PROCEDURE InputFormatted(DisplayStr: AStr; VAR InputStr: STRING; Format: STRING; Abortable: Boolean);
PROCEDURE InputLongIntWC(S: AStr; VAR L: LongInt; InputFlags: InputFlagSet; LowNum,HighNum: LongInt; VAR Changed: Boolean);
PROCEDURE InputLongIntWOC(S: AStr; VAR L: LongInt; InputFlags: InputFlagSet; LowNum,HighNum: LongInt);
PROCEDURE InputWordWC(S: AStr; VAR W: Word; InputFlags: InputFlagSet; LowNum,HighNum: Word; VAR Changed: Boolean);
PROCEDURE InputWordWOC(S: AStr; VAR W: Word; InputFlags: InputFlagSet; LowNum,HighNum: Word);
PROCEDURE InputIntegerWC(S: AStr; VAR I: Integer; InputFlags: InputFlagSet; LowNum,HighNum: Integer; VAR Changed: Boolean);
PROCEDURE InputIntegerWOC(S: AStr; VAR I: Integer; InputFlags: InputFlagSet; LowNum,HighNum: Integer);
PROCEDURE InputWordWC(S: AStr; VAR W: SmallWord; InputFlags: InputFlagSet; LowNum,HighNum: Word; VAR Changed: Boolean);
PROCEDURE InputWordWOC(S: AStr; VAR W: SmallWord; InputFlags: InputFlagSet; LowNum,HighNum: Word);
PROCEDURE InputIntegerWC(S: AStr; VAR I: SmallInt; InputFlags: InputFlagSet; LowNum,HighNum: Integer; VAR Changed: Boolean);
PROCEDURE InputIntegerWOC(S: AStr; VAR I: SmallInt; InputFlags: InputFlagSet; LowNum,HighNum: Integer);
PROCEDURE InputByteWC(S: AStr; VAR B: Byte; InputFlags: InputFlagSet; LowNum,HighNum: Byte; VAR Changed: Boolean);
PROCEDURE InputByteWOC(S: AStr; VAR B: Byte; InputFlags: InputFlagSet; LowNum,HighNum: Byte);
PROCEDURE InputWN1(DisplayStr: AStr; VAR InputStr: AStr; MaxLen: Byte; InputFlags: InputFlagSet; VAR Changed: Boolean);
@ -28,7 +32,11 @@ PROCEDURE InputCaps(VAR S: STRING; MaxLen: Byte);
IMPLEMENTATION
USES
Crt;
Crt
{$IFDEF WIN32}
,RPScreen
{$ENDIF}
;
PROCEDURE InputDefault(VAR S: STRING; v: STRING; MaxLen: Byte; InputFlags: InputFlagSet; LineFeed: Boolean);
VAR
@ -161,7 +169,7 @@ BEGIN
InputLongIntWC(S,L,InputFlags,LowNum,HighNum,Changed);
END;
PROCEDURE InputWordWC(S: AStr; VAR W: Word; InputFlags: InputFlagSet; LowNum,HighNum: Word; VAR Changed: Boolean);
PROCEDURE InputWordWC(S: AStr; VAR W: SmallWord; InputFlags: InputFlagSet; LowNum,HighNum: Word; VAR Changed: Boolean);
VAR
TempStr: Str5;
SaveW: Word;
@ -191,7 +199,7 @@ BEGIN
Changed := TRUE;
END;
PROCEDURE InputWordWOC(S: AStr; VAR W: Word; InputFlags: InputFlagSet; LowNum,HighNum: Word);
PROCEDURE InputWordWOC(S: AStr; VAR W: SmallWord; InputFlags: InputFlagSet; LowNum,HighNum: Word);
VAR
Changed: Boolean;
BEGIN
@ -199,7 +207,7 @@ BEGIN
InputWordWC(S,W,InputFlags,LowNum,HighNum,Changed);
END;
PROCEDURE InputIntegerWC(S: AStr; VAR I: Integer; InputFlags: InputFlagSet; LowNum,HighNum: Integer; VAR Changed: Boolean);
PROCEDURE InputIntegerWC(S: AStr; VAR I: SmallInt; InputFlags: InputFlagSet; LowNum,HighNum: Integer; VAR Changed: Boolean);
VAR
TempStr: Str5;
SaveI: Integer;
@ -229,7 +237,7 @@ BEGIN
Changed := TRUE;
END;
PROCEDURE InputIntegerWOC(S: AStr; VAR I: Integer; InputFlags: InputFlagSet; LowNum,HighNum: Integer);
PROCEDURE InputIntegerWOC(S: AStr; VAR I: SmallInt; InputFlags: InputFlagSet; LowNum,HighNum: Integer);
VAR
Changed: Boolean;
BEGIN
@ -336,6 +344,7 @@ VAR
Inc(Cp);
END;
{$IFDEF MSDOS}
PROCEDURE SetCursor(InsertMode: Boolean); ASSEMBLER;
ASM
cmp InsertMode,0
@ -350,6 +359,19 @@ VAR
mov ah,1
int 10h
END;
{$ENDIF}
{$IFDEF WIN32}
PROCEDURE SetCursor(InsertMode: Boolean);
BEGIN
if (InsertMode) then
begin
RPInsertCursor;
end else
begin
RPBlockCursor;
end;
END;
{$ENDIF}
BEGIN
FirstKey := FALSE;

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

@ -1,3 +1,7 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S-,V-}
(*
@ -348,7 +352,17 @@ IMPLEMENTATION
USES
Crt,
Common;
Common
{$IFDEF WIN32}
,EleNorm
{$ENDIF}
;
{$IFDEF WIN32}
VAR
DidClose: Boolean = false;
DidInit: Boolean = false;
{$ENDIF}
(*
AH = 0Ah Purge input buffer
@ -363,6 +377,7 @@ PROCEDURE Com_Flush_Recv;
BEGIN
IF (NOT LocalIOOnly) THEN
BEGIN
{$IFDEF MSDOS}
ASM
Cmp InWfcMenu,1
Je @TheEnd
@ -371,6 +386,14 @@ BEGIN
Int 14h
@TheEnd:
END;
{$ENDIF}
{$IFDEF WIN32}
if (InWfcMenu) then Exit;
if Not(DidInit) then Exit;
if (DidClose) then Exit;
if Not(EleNorm.Com_Carrier) then Exit;
EleNorm.Com_PurgeInBuffer; // REENOTE Is this right? Function says flush not purge
{$ENDIF}
END
ELSE WHILE NOT (Com_IsRecv_Empty) DO
WriteWFC(CInKey);
@ -395,6 +418,7 @@ the output buffer (not transmitted yet) is discarded.
PROCEDURE Com_Purge_Send;
BEGIN
{$IFDEF MSDOS}
ASM
Cmp LocalIOOnly,1
Je @TheEnd
@ -403,6 +427,14 @@ BEGIN
Int 14h
@TheEnd:
END;
{$ENDIF}
{$IFDEF WIN32}
if (LocalIOOnly) then Exit;
if Not(DidInit) then Exit;
if (DidClose) then Exit;
if Not(EleNorm.Com_Carrier) then Exit;
EleNorm.Com_PurgeOutBuffer;
{$ENDIF}
END;
(*
@ -432,6 +464,7 @@ VAR
Dummy: Byte;
BEGIN
Dummy := 0; (* New *)
{$IFDEF MSDOS}
ASM
Cmp LocalIOOnly,1
Je @TheEnd
@ -442,6 +475,14 @@ BEGIN
@TheEnd:
END;
Com_Carrier := (Dummy AND $80) = $80;
{$ENDIF}
{$IFDEF WIN32}
Com_Carrier := false;
if (LocalIOOnly) then Exit;
if Not(DidInit) then Exit;
if (DidClose) then Exit;
Com_Carrier := EleNorm.Com_Carrier;
{$ENDIF}
END;
(*
@ -471,9 +512,13 @@ CONST
VAR
Dummy: Byte;
T_RecvChar: Boolean;
{$IFDEF WIN32}
Ch: Char;
{$ENDIF}
BEGIN
Com_Recv := #0;
T_RecvChar := FALSE;
{$IFDEF MSDOS}
ASM
Cmp LocalIOOnly,1
Je @TheEnd
@ -491,6 +536,32 @@ BEGIN
END;
IF (T_RecvChar) THEN
Com_Recv := Char(Dummy);
{$ENDIF}
{$IFDEF WIN32}
if (LocalIOOnly) then Exit;
if Not(DidInit) then Exit;
if (DidClose) then Exit;
if Not(EleNorm.Com_Carrier) then Exit;
if Not(EleNorm.Com_CharAvail) then Exit;
// Get character from buffer
Ch := EleNorm.Com_GetChar;
if (Ch = #10) then
begin
// Translate bare LF to CR
Com_Recv := #13;
end else
begin
Com_Recv := Ch;
end;
// If this char is CR, check if the next char is LF (so we can discard it)
if (Ch = #13) and (EleNorm.Com_CharAvail) then
begin
Ch := EleNorm.Com_PeekChar;
if (Ch = #10) then EleNorm.Com_GetChar; // Discard that LF
end;
{$ENDIF}
END;
(*
@ -520,6 +591,7 @@ VAR
Dummy: Byte;
BEGIN
Dummy := 0; (* New *)
{$IFDEF MSDOS}
ASM
Cmp LocalIOOnly,1
Je @TheEnd
@ -530,6 +602,15 @@ BEGIN
@TheEnd:
END;
Com_IsRecv_Empty := NOT ((Dummy AND $01) = $01);
{$ENDIF}
{$IFDEF WIN32}
Com_IsRecv_Empty := true;
if (LocalIOOnly) then Exit;
if Not(DidInit) then Exit;
if (DidClose) then Exit;
if Not(EleNorm.Com_Carrier) then Exit;
Com_IsRecv_Empty := Not(EleNorm.Com_CharAvail);
{$ENDIF}
END;
(*
@ -557,8 +638,12 @@ bit on hardwired (null modem) links.
FUNCTION Com_IsSend_Empty: Boolean;
VAR
Dummy: Byte;
{$IFDEF WIN32}
InFree, OutFree, InUsed, OutUsed: LongInt;
{$ENDIF}
BEGIN
Dummy := 0; (* New *)
{$IFDEF MSDOS}
ASM
Cmp LocalIOOnly,1
Je @TheEnd
@ -569,6 +654,16 @@ BEGIN
@TheEnd:
END;
Com_IsSend_Empty := ((Dummy AND $40) = $40);
{$ENDIF}
{$IFDEF WIN32}
Com_IsSend_Empty := false;
if (LocalIOOnly) then Exit;
if Not(DidInit) then Exit;
if (DidClose) then Exit;
if Not(EleNorm.Com_Carrier) then Exit;
EleNorm.Com_GetBufferStatus(InFree, OutFree, InUsed, OutUsed);
Com_IsSend_Empty := (OutUsed = 0);
{$ENDIF}
END;
(*
@ -585,6 +680,7 @@ value of 0000h is returned in AX. If the driver accepts the character
PROCEDURE Com_Send(C: Char);
BEGIN
{$IFDEF MSDOS}
ASM
Cmp LocalIOOnly,1
Je @TheEnd
@ -594,6 +690,14 @@ BEGIN
Int 14h
@TheEnd:
END;
{$ENDIF}
{$IFDEF WIN32}
if (LocalIOOnly) then Exit;
if Not(DidInit) then Exit;
if (DidClose) then Exit;
if Not(EleNorm.Com_Carrier) then Exit;
EleNorm.Com_SendChar(C);
{$ENDIF}
END;
(*
@ -669,12 +773,17 @@ BEGIN
T_AL := 32;
END;
Inc(T_AL,3);
{$IFDEF MSDOS}
ASM
Mov AH,00h
Mov AL,T_AL
Mov DX,FossilPort
Int 14h
END;
{$ENDIF}
{$IFDEF WIN32}
// REENOTE Telnet can't set speed
{$ENDIF}
END;
END;
@ -692,16 +801,28 @@ PROCEDURE Com_DeInstall;
BEGIN
IF (NOT LocalIOOnly) THEN
BEGIN
{$IFDEF MSDOS}
ASM
Mov AH,05h
Mov DX,FossilPort
Int 14h
END;
{$ENDIF}
{$IFDEF WIN32}
if Not(DidInit) then Exit;
if Not(DidClose) then
begin
EleNorm.Com_Close;
DidClose := true;
end;
EleNorm.Com_ShutDown;
{$ENDIF}
END;
END;
PROCEDURE Com_Install;
{$IFDEF MSDOS}
FUNCTION DriverInstalled: Word; ASSEMBLER;
ASM
Mov AH,5
@ -712,11 +833,19 @@ PROCEDURE Com_Install;
PushF
Call Interrupt14
END;
{$ENDIF}
{$IFDEF WIN32}
FUNCTION DriverInstalled: Word;
BEGIN
// REENOTE Never gets called in Win32
END;
{$ENDIF}
BEGIN
FossilPort := (Liner.Comport - 1);
IF (LocalIOOnly) THEN
Exit;
{$IFDEF MSDOS}
IF (DriverInstalled <> $1954) THEN
BEGIN
ClrScr;
@ -740,9 +869,19 @@ BEGIN
PushF
Call Interrupt14
END;
{$ENDIF}
{$IFDEF WIN32}
if (DidInit) then Exit;
if (DidClose) then Exit;
DidInit := true;
EleNorm.Com_StartUp(2);
EleNorm.Com_SetDontClose(false);
EleNorm.Com_OpenQuick(answerbaud); // REENOTE Should come up with a better solution, this works for now though
{$ENDIF}
Com_Set_Speed(Liner.InitBaud);
END;
{$IFDEF MSDOS}
PROCEDURE CheckHangup; ASSEMBLER;
ASM
Cmp LocalIOOnly,1
@ -758,6 +897,20 @@ ASM
Mov HangUp,1
@GetOut:
END;
{$ENDIF}
{$IFDEF WIN32}
PROCEDURE CheckHangup;
BEGIN
if (LocalIOOnly) then Exit;
if Not(OutCom) then Exit;
if Not(Com_Carrier) then
begin
HangUp := true;
HungUp := true;
end;
END;
{$ENDIF}
(*
AH = 19h Write block (transfer from user buffer to FOSSIL)
@ -782,6 +935,7 @@ VAR
BEGIN
IF (OutCom) THEN
BEGIN
{$IFDEF MSDOS}
REPEAT
T_DI := OFS(S[1]);
T_CX := Length(S);
@ -798,6 +952,13 @@ BEGIN
Move(S[T_AX + 1],S[1],Length(S) - T_AX);
Dec(S[0],T_AX);
UNTIL (S = '');
{$ENDIF}
{$IFDEF WIN32}
if Not(DidInit) then Exit;
if (DidClose) then Exit;
if Not(EleNorm.Com_Carrier) then Exit;
EleNorm.Com_SendString(S);
{$ENDIF}
END;
END;
@ -830,6 +991,7 @@ BEGIN
Empty := NOT KeyPressed;
IF (InCom) AND (NOT KeyPressed) THEN
BEGIN
{$IFDEF MSDOS}
ASM
Mov DX,FossilPort
Mov AH,03h
@ -837,6 +999,13 @@ BEGIN
Mov T_AH,AH
END;
Empty := NOT (T_AH AND 1 = 1);
{$ENDIF}
{$IFDEF WIN32}
if Not(DidInit) then Exit;
if (DidClose) then Exit;
if Not(EleNorm.Com_Carrier) then Exit;
Empty := Not(EleNorm.Com_CharAvail);
{$ENDIF}
END;
END;
@ -858,12 +1027,24 @@ BEGIN
IF (NOT LocalIOOnly) THEN
BEGIN
T_AL := Byte(Status);
{$IFDEF MSDOS}
ASM
Mov AH,06h
Mov DX,FossilPort
Mov AL,T_AL
Int 14h
END;
{$ENDIF}
{$IFDEF WIN32}
if Not(DidInit) then Exit;
if (DidClose) then Exit;
if Not(EleNorm.Com_Carrier) then Exit;
if Not(Status) then
begin
EleNorm.Com_Close;
DidClose := true;
end;
{$ENDIF}
END;
END;

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

@ -1,3 +1,7 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S-,V-}
UNIT Common5;

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

@ -1,3 +1,7 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S+,V-}
UNIT CUser;
@ -892,7 +896,7 @@ VAR
VAR
AScheme: SchemeRec;
i,
Onlin: Integer;
Onlin: SmallInt;
BEGIN
Reset(SchemeFile);
CLS;

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

@ -1,3 +1,7 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S+,V-}
UNIT Doors;

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.

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

@ -1,3 +1,7 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S+,V-}
UNIT EMail;
@ -667,7 +671,7 @@ END;
PROCEDURE ReadMail;
TYPE
MessageArrayType = ARRAY [1..255] OF Word;
MessageArrayType = ARRAY [1..255] OF SmallWord;
VAR
MessageArray: MessageArrayType;
User: UserRecordType;

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

@ -1,3 +1,7 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S+,V-}
UNIT Events;
@ -15,7 +19,11 @@ IMPLEMENTATION
USES
Dos,
Common,
TimeFunc;
TimeFunc
{$IFDEF WIN32}
,Windows
{$ENDIF}
;
FUNCTION InTime(Tim,Tim1,Tim2: LongInt): Boolean;
BEGIN
@ -222,11 +230,19 @@ END;
FUNCTION SysOpAvailable: Boolean;
VAR
{$IFDEF MSDOS}
A: Byte ABSOLUTE $0000:$0417;
{$ENDIF}
EventNum: Integer;
ChatOk: Boolean;
BEGIN
{$IFDEF MSDOS}
ChatOk := ((A AND 16) = 0);
{$ENDIF}
{$IFDEF WIN32}
// Availability is togged with scroll lock key
ChatOk := (GetKeyState($91) and $ffff) <> 0;
{$ENDIF}
IF (RChat IN ThisUser.Flags) THEN
ChatOk := FALSE;

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

@ -1,3 +1,7 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S+,V-}
UNIT ExecBat;
@ -39,10 +43,12 @@ VAR
SaveY: Byte;
SavCurWind: Integer;
{$IFDEF MSDOS}
{$L EXECWIN}
PROCEDURE SetCsInts; EXTERNAL;
PROCEDURE NewInt21; EXTERNAL;
{$ENDIF}
PROCEDURE ExecWindow(VAR Ok: Boolean;
CONST Dir,
@ -79,6 +85,7 @@ BEGIN
WindLo := WindMin;
WindHi := WindMax;
{$IFDEF MSDOS}
{Assure cursor is in Window}
INLINE
(
@ -115,6 +122,7 @@ BEGIN
GetIntVec($21,CurInt21);
SetCsInts;
SetIntVec($21,@NewInt21);
{$ENDIF}
{$IFDEF Ver70}
{Prevent SwapVectors from undoing our int21 change}
@ -132,8 +140,10 @@ BEGIN
Window(1,1,MaxDisplayCols,MaxDisplayRows);
RemoveWindow(Wind);
{$IFDEF MSDOS}
{Restore interrupt}
SetIntVec($21,CurInt21);
{$ENDIF}
General.CurWindow := SaveCurWindow;
General.WindowOn := SaveWindowOn;
LastScreenSwap := (Timer - 5);

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

@ -1,3 +1,7 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S+,V-}
UNIT File0;
@ -37,7 +41,11 @@ USES
Dos,
File1,
ShortMsg,
TimeFunc;
TimeFunc
{$IFDEF WIN32}
,Windows
{$ENDIF}
;
FUNCTION CompFileArea(FArea,ArrayNum: Integer): Integer;
VAR
@ -581,9 +589,14 @@ BEGIN
SaveTimer := Timer;
END
ELSE
{$IFDEF MSDOS}
ASM
Int 28h
END;
{$ENDIF}
{$IFDEF WIN32}
Sleep(1);
{$ENDIF}
END;
IF (Cmd <> #27) THEN
BEGIN

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

@ -1,3 +1,7 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S+,V-}
UNIT File1;

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

@ -1,3 +1,7 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S+,V-}
UNIT File10;

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

@ -1,3 +1,7 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S+,V-}
UNIT File11;
@ -10,7 +14,7 @@ USES
TYPE
FileRecType = RECORD
FArrayFileArea,
FArrayDirFileRecNum: Integer;
FArrayDirFileRecNum: SmallInt;
END;
FileArrayType = ARRAY [0..99] OF FileRecType;
@ -46,7 +50,7 @@ USES
TimeFunc;
TYPE
DownLoadArrayType = ARRAY [0..99] OF Integer;
DownLoadArrayType = ARRAY [0..99] OF SmallInt;
VAR
DLArray: DownloadArrayType;

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

@ -1,3 +1,7 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S+,V-}
UNIT File12;

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

@ -1,3 +1,7 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S+,V-}
UNIT File13;

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

@ -1,3 +1,7 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S+,V-}
UNIT File14;

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

@ -1,3 +1,7 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S+,V-}
UNIT File2;

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

@ -1,3 +1,7 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S+,V-}
UNIT File3;

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

@ -1,3 +1,7 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S+,V-}
UNIT File4;

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

@ -1,3 +1,7 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S+,V-}
UNIT File5;

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

@ -1,3 +1,7 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S+,V-}
UNIT File6;

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

@ -1,3 +1,7 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S+,V-}
UNIT File7;

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

@ -1,3 +1,7 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S+,V-}
UNIT File8;

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

@ -1,3 +1,7 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S+,V-}
UNIT File9;

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

@ -1,3 +1,7 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S+,V-}
UNIT LineChat;
@ -70,6 +74,7 @@ BEGIN
Delay(600)
ELSE
BEGIN
{$IFDEF MSDOS}
FOR Counter1 := 300 DOWNTO 2 DO
BEGIN
Delay(1);
@ -80,8 +85,14 @@ BEGIN
Delay(1);
Sound(Counter1 * 10);
END;
END;
NoSound;
{$ENDIF}
{$IFDEF WIN32}
Sound(3000, 200);
Sound(1000, 200);
Sound(3000, 200);
{$ENDIF}
END;
IF (KeyPressed) THEN
BEGIN
Cmd := ReadKey;
@ -360,6 +371,7 @@ BEGIN
CLS
ELSE IF (S = '/PAGE') THEN
BEGIN
{$IFDEF MSDOS}
FOR Counter := 650 TO 700 DO
BEGIN
Sound(Counter);
@ -372,6 +384,15 @@ BEGIN
Delay(2);
NoSound;
UNTIL (Counter = 200);
{$ENDIF}
{$IFDEF WIN32}
Sound(650, 200);
Sound(700, 200);
Sound(600, 200);
Sound(500, 200);
Sound(400, 200);
Sound(300, 200);
{$ENDIF}
Prompt(^G^G);
END
ELSE IF (S = '/BYE') THEN

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

@ -1,3 +1,7 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S+,V-}
UNIT Logon;
@ -740,7 +744,7 @@ VAR
S,
ACSReq: AStr;
OverridePW: Str20;
Lng: Integer;
Lng: SmallInt;
Tries,
I,
TTimes,

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

@ -1,3 +1,7 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S+,V-}
UNIT Mail0;

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

@ -1,3 +1,7 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S+,V-}
UNIT Mail1;
@ -1219,7 +1223,7 @@ VAR
Insert_Char(Char(GKey));
127 :
Delete_Char;
32..254 :
32..46, 48..126, 128..254 :
Insert_Char(Char(GKey));
8 : BEGIN
IF (CCol = 1) THEN
@ -1334,7 +1338,7 @@ VAR
HelpCounter: Byte;
Counter,
LineNum1,
LineNum2: Integer;
LineNum2: SmallInt;
ShowCont,
ExitMsg,
SaveLine,

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

@ -1,3 +1,7 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S+,V-}
UNIT Mail2;

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

@ -1,3 +1,7 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S+,V-}
UNIT Mail3;

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

@ -1,3 +1,7 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S+,V-}
UNIT Mail4;

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

@ -1,3 +1,7 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S+,V-}
UNIT Maint;

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

@ -1,3 +1,7 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D+,E-,F+,I-,L+,N-,O-,R-,S+,V-}
UNIT Menus;

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

@ -1,3 +1,7 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S+,V-}
UNIT Menus2;

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

@ -1,3 +1,7 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D-,E-,F+,I-,L-,N-,O+,R-,S+,V-}
UNIT Menus3;

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

@ -1,3 +1,7 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S+,V-}
UNIT MiscUser;

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

@ -1,3 +1,7 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D-,E-,F+,I-,L-,N-,O+,R-,S+,V-}
UNIT MsgPack;

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

@ -1,3 +1,7 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D-,E-,F+,I-,L-,N-,O+,R-,S+,V-}
UNIT Multnode;

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

@ -1,3 +1,7 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R+,S-,V-}
UNIT MyIO;
@ -24,8 +28,13 @@ CONST
VAR
Wind: WindowRec;
{$IFDEF MSDOS}
MonitorType: Byte ABSOLUTE $0000:$0449;
ScreenAddr: ScreenType ABSOLUTE $B800:$0000;
{$ENDIF}
{$IFDEF WIN32}
MonitorType: Byte = 3; // REENOTE 3=CO80, a safe assumption I think
{$ENDIF}
ScreenSize: Integer;
MaxDisplayRows,
MaxDisplayCols,
@ -41,7 +50,12 @@ VAR
Infield_Arrow_Exit_Types,
Infield_Normal_Exit_Keys: STRING;
{$IFDEF MSDOS}
PROCEDURE Update_Logo(VAR Addr1,Addr2; BlkLen: Integer);
{$ENDIF}
{$IFDEF WIN32}
procedure Update_Logo(Data: Array of Char; OriginX, OriginY, DataLength: integer);
{$ENDIF}
PROCEDURE CursorOn(b: BOOLEAN);
PROCEDURE infield1(x,y: Byte; VAR s: AStr; Len: Byte);
PROCEDURE Infielde(VAR s: AStr; Len: Byte);
@ -60,8 +74,19 @@ PROCEDURE SetWindow(VAR Wind: WindowRec; TLX,TLY,BRX,BRY,TColr,BColr,BoxType: In
IMPLEMENTATION
USES
Crt;
Crt
{$IFDEF WIN32}
,RPScreen
,VpSysLow
{$ENDIF}
;
{$IFDEF WIN32}
VAR
SavedScreen: TScreenBuf;
{$ENDIF}
{$IFDEF MSDOS}
PROCEDURE CursorOn(b: BOOLEAN); ASSEMBLER;
ASM
cmp b, 1
@ -76,6 +101,19 @@ ASM
mov ah,1
int 10h
END;
{$ENDIF}
{$IFDEF WIN32}
PROCEDURE CursorOn(b: BOOLEAN);
BEGIN
if (b) then
begin
RPShowCursor;
end else
begin
RPHideCursor;
end;
END;
{$ENDIF}
PROCEDURE infield1(x,y: Byte; VAR s: AStr; Len: Byte);
VAR
@ -525,12 +563,22 @@ END;
PROCEDURE SaveScreen(VAR Wind: WindowRec);
BEGIN
{$IFDEF MSDOS}
Move(ScreenAddr[0],Wind[0],ScreenSize);
{$ENDIF}
{$IFDEF WIN32}
RPSaveScreen(SavedScreen);
{$ENDIF}
END;
PROCEDURE RemoveWindow(VAR Wind: WindowRec);
BEGIN
{$IFDEF MSDOS}
Move(Wind[0],ScreenAddr[0],ScreenSize);
{$ENDIF}
{$IFDEF WIN32}
RPRestoreScreen(SavedScreen);
{$ENDIF}
END;
PROCEDURE SetWindow(VAR Wind: WindowRec; TLX,TLY,BRX,BRY,TColr,BColr,BoxType:Integer);
@ -543,6 +591,7 @@ BEGIN
Box(BoxType,TLX,TLY,BRX,BRY); { Set the border }
END;
{$IFDEF MSDOS}
PROCEDURE Update_Logo(VAR Addr1,Addr2; BlkLen: Integer);
BEGIN
INLINE (
@ -600,5 +649,60 @@ BEGIN
$E0/$AA/
$1F);
END;
{$ENDIF}
{$IFDEF WIN32}
procedure Update_Logo(Data: Array of Char; OriginX, OriginY, DataLength: integer);
var
i, x, y, count, counter: Integer;
character: Char;
spaces: String;
begin
i := 0;
x := OriginX;
y := OriginY;
spaces := ' '; // 80 spaces
while (i < DataLength) do
begin
case Data[i] of
#0..#15: begin
TextColor(Ord(Data[i]));
end;
#16..#23: begin
TextBackground(Ord(Data[i]) - 16);
end;
#24: begin
x := OriginX;
Inc(y);
end;
#25: begin
Inc(i);
count := Ord(Data[i])+1;
SysWrtCharStrAtt(@spaces[1], count, x-1, y-1, TextAttr);
Inc(x, count);
end;
#26: begin
Inc(i);
count := Ord(Data[i])+1;
Inc(i);
character := Data[i];
for counter := 1 to count do
begin
SysWrtCharStrAtt(@Data[i], 1, x-1, y-1, TextAttr);
Inc(x);
end;
end;
#27: begin
TextAttr := TextAttr XOR $80; // Invert blink flag
end;
#32..#255: begin
SysWrtCharStrAtt(@Data[i], 1, x-1, y-1, TextAttr);
Inc(x);
end;
end;
Inc(i);
end;
end;
{$ENDIF}
END.

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

@ -1,3 +1,7 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S+,V-}
UNIT NewUsers;

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

@ -1,3 +1,7 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D-,E-,F+,I-,L-,N-,O+,R-,S+,V-}
UNIT Nodelist;
@ -9,8 +13,8 @@ USES
PROCEDURE ToggleNetAttr(NetAttrT: NetAttr; VAR NetAttrS: NetAttribs);
PROCEDURE ToggleNetAttrs(C: CHAR; VAR NetAttrS: NetAttribs);
FUNCTION GetNewAddr(DisplayStr: AStr; MaxLen: Byte; VAR Zone,Net,Node,Point: Word): Boolean;
PROCEDURE GetNetAddress(VAR SysOpName: AStr; VAR Zone,Net,Node,Point,Fee: Word; GetFee: Boolean);
FUNCTION GetNewAddr(DisplayStr: AStr; MaxLen: Byte; VAR Zone,Net,Node,Point: SmallWord): Boolean;
PROCEDURE GetNetAddress(VAR SysOpName: AStr; VAR Zone,Net,Node,Point: SmallWord; var Fee: Word; GetFee: Boolean);
PROCEDURE ChangeFlags(VAR MsgHeader: MHeaderRec);
FUNCTION NetMail_Attr(NetAttribute: NetAttribs): AStr;
@ -26,10 +30,10 @@ TYPE
Zone, { Zone of board }
Net, { Net Address of board }
Node, { Node Address of board }
Point: Integer; { Either Point number OR 0 }
Point: SmallInt; { Either Point number OR 0 }
CallCost, { Cost to sysop to send }
MsgFee, { Cost to user to send }
NodeFlags: Word; { Node flags }
NodeFlags: SmallWord; { Node flags }
ModemType, { Modem TYPE }
PassWord: STRING[9];
Phone,
@ -42,34 +46,34 @@ TYPE
IndxRefBlk = RECORD
IndxOfs, { Offset of STRING into block }
IndxLen: Word; { Length of STRING }
IndxLen: SmallWord; { Length of STRING }
IndxData, { RECORD number of STRING }
IndxPtr: LongInt; { Block number of lower index }
END; { IndxRef }
LeafRefBlk = RECORD
KeyOfs, { Offset of STRING into block }
KeyLen: Word; { Length of STRING }
KeyLen: SmallWord; { Length of STRING }
KeyVal: LongInt; { Pointer to Data block }
END; { LeafRef }
CtlBlk = RECORD
CtlBlkSize: Word; { blocksize of Index blocks }
CtlBlkSize: SmallWord; { blocksize of Index blocks }
CtlRoot, { Block number of Root }
CtlHiBlk, { Block number of last block }
CtlLoLeaf, { Block number of first leaf }
CtlHiLeaf, { Block number of last leaf }
CtlFree: LongInt; { Head of freelist }
CtlLvls, { Number of index levels }
CtlParity: Word; { XOR of above fields }
CtlParity: SmallWord; { XOR of above fields }
END;
INodeBlk = RECORD
IndxFirst, { Pointer to next lower level }
IndxBLink, { Pointer to previous link }
IndxFLink: LongInt; { Pointer to next link }
IndxCnt: Integer; { Count of Items IN block }
IndxStr: Word; { Offset IN block of 1st str }
IndxCnt: SmallInt; { Count of Items IN block }
IndxStr: SmallWord; { Offset IN block of 1st str }
{ IF IndxFirst is NOT -1, this is INode: }
IndxRef: ARRAY [0..49] OF IndxRefBlk;
END;
@ -78,8 +82,8 @@ TYPE
IndxFirst, { Pointer to next lower level }
IndxBLink, { Pointer to previous link }
IndxFLink: LongInt; { Pointer to next link }
IndxCnt: Integer; { Count of Items IN block }
IndxStr: Word; { Offset IN block of 1st str }
IndxCnt: SmallInt; { Count of Items IN block }
IndxStr: SmallWord; { Offset IN block of 1st str }
LeafRef: ARRAY [0..49] OF LeafRefBlk;
END;
@ -103,7 +107,7 @@ BEGIN
END;
END;
FUNCTION GetNewAddr(DisplayStr: AStr; MaxLen: Byte; VAR Zone,Net,Node,Point: Word): Boolean;
FUNCTION GetNewAddr(DisplayStr: AStr; MaxLen: Byte; VAR Zone,Net,Node,Point: SmallWord): Boolean;
BEGIN
GetNewAddr := FALSE;
Prt(DisplayStr);
@ -180,7 +184,7 @@ TYPE
Zone,
Net,
Node,
Point: Word;
Point: SmallWord;
END;
VAR
Key: NodeType ABSOLUTE ALine;
@ -205,7 +209,7 @@ BEGIN
Compaddress := K;
END;
PROCEDURE GetNetAddress(VAR SysOpName:AStr; VAR Zone,Net,Node,Point,Fee:Word; GetFee:Boolean);
PROCEDURE GetNetAddress(VAR SysOpName: AStr; VAR Zone,Net,Node,Point: SmallWord; var Fee: Word; GetFee: Boolean);
VAR
DataFile,
NDXFile: FILE;
@ -249,7 +253,7 @@ VAR
Zone,
Net,
Node,
Point: Word;
Point: SmallWord;
END;
VAR
Address: NodeType;
@ -325,10 +329,10 @@ VAR
Zone, { Zone of board }
Net, { Net Address of board }
Node, { Node Address of board }
Point: Integer; { Either Point number OR 0 }
Point: SmallInt; { Either Point number OR 0 }
CallCost, { Cost to sysop to send }
MsgFee, { Cost to user to send }
NodeFlags: Word; { Node flags }
NodeFlags: SmallWord; { Node flags }
ModemType, { Modem TYPE }
PhoneLen, { Length of Phone Number }
PassWordLen, { Length of Password }

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

@ -1,3 +1,7 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S-,V-}
UNIT OffLine;
@ -48,7 +52,7 @@ TYPE
RNum: STRING[7];
NumBlocks: ARRAY [1..6] OF Char;
Status: Byte;
MBase: Word;
MBase: SmallWord;
Crap: STRING[3];
END;

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

@ -46,6 +46,10 @@ CONST
User_Phone_None = ''; {None for user phone fields}
TYPE
{$IFDEF MSDOS}
SmallInt = Integer;
SmallWord = Word;
{$ENDIF}
AStr = STRING[160];
Str1 = STRING[1];
Str2 = STRING[2];
@ -165,7 +169,7 @@ TYPE
Name: STRING[36]; { the user's name }
Number, { user number }
Left, { Left node }
Right: Integer; { Right node }
Right: SmallInt; { Right node }
RealName, { User's real name? }
Deleted: Boolean; { deleted or not }
END;
@ -229,11 +233,11 @@ TYPE
LastMsgArea, { # last msg area }
LastFileArea, { # last file area }
UnUsedInteger1,
UnUsedInteger2: Integer;
UnUsedInteger2: SmallInt;
PasswordChanged, { Numeric date pw changed - was UnixTime }
UnUsedWord1,
UnUsedWord2: Word;
UnUsedWord2: SmallWord;
lCredit, { Amount OF credit }
Debit, { Amount OF debit }
@ -283,14 +287,14 @@ TYPE
FromToInfo = { from/to information for mheaderrec }
{$IFDEF WIN32} PACKED {$ENDIF} RECORD
Anon: Byte;
UserNum: Word; { user number }
UserNum: SmallWord; { user number }
A1S: STRING[36]; { posted as }
Real: STRING[36]; { real name }
Name: STRING[36]; { system name }
Zone,
Net,
Node,
Point: Word;
Point: SmallWord;
END;
MHeaderRec =
@ -298,12 +302,12 @@ TYPE
From,
MTO: FromToInfo; { message from/to info }
Pointer: LongInt; { starting record OF text }
TextSize: Word; { size OF text }
ReplyTo: Word; { ORIGINAL + REPLYTO = CURRENT }
TextSize: SmallWord; { size OF text }
ReplyTo: SmallWord; { ORIGINAL + REPLYTO = CURRENT }
Date: UnixTime; { date/time PACKED STRING }
DayOfWeek: Byte; { message day OF week }
Status: SET OF MsgStatusR; { message status flags }
Replies: Word; { times replied to }
Replies: SmallWord; { times replied to }
Subject: STRING[40]; { subject OF message }
OriginDate: STRING[19]; { date OF echo/group msgs }
FileAttached: Byte; { 0=No, 1=Yes&Del, 2=Yes&Save }
@ -337,7 +341,7 @@ TYPE
UnArcLine, { de-compression cmdline }
TestLine, { integrity test cmdline }
CmtLine: STRING[25]; { comment cmdline }
SuccLevel: Integer; { success errorlevel, -1=ignore results }
SuccLevel: SmallInt; { success errorlevel, -1=ignore results }
END;
ModemFlagType = { MODEM.DAT status flags }
@ -391,7 +395,7 @@ TYPE
NewSL, { new SL }
NewDSL, { new DSL }
NewMenu: Byte; { User start out menu }
Expiration: Word; { days until expiration }
Expiration: SmallWord; { days until expiration }
NewFP, { nothing }
NewCredit: LongInt; { new credit }
SoftAR, { TRUE=AR added to current, else replaces }
@ -526,13 +530,13 @@ TYPE
CreditInternetMail, { cost for Internet mail }
BirthDateCheck, { check user's birthdate every xx logons }
UnUsedInteger1,
UnUsedInteger2: Integer;
UnUsedInteger2: SmallInt;
MaxQWKTotal, { max msgs in a packet, period }
MaxQWKBase, { max msgs in a area }
DaysOnline, { days online }
UnUsedWord1,
UnUsedWord2: Word;
UnUsedWord2: SmallWord;
MinimumBaud, { minimum baud rate to logon }
MinimumDLBaud, { minimum baud rate to download }
@ -614,7 +618,7 @@ TYPE
Zone, { 21st is for UUCP address }
Net,
Node,
Point: Word;
Point: SmallWord;
END;
NewUserToggles: ARRAY [1..20] OF Byte;
@ -635,7 +639,7 @@ TYPE
ShortMessageRecordType = { SHORTMSG.DAT : One-line messages }
{$IFDEF WIN32} PACKED {$ENDIF} RECORD
Msg: AStr;
Destin: Integer;
Destin: SmallInt;
END;
VotingRecordType = { VOTING.DAT : Voting records }
@ -644,14 +648,14 @@ TYPE
Question2: STRING[60]; { Voting Question 2 }
ACS: ACString; { ACS required to vote on this }
ChoiceNumber: Byte; { number OF choices }
NumVotedQuestion: Integer; { number OF votes on it }
NumVotedQuestion: SmallInt; { number OF votes on it }
CreatedBy: STRING[36]; { who created it }
AddAnswersACS: ACString; { ACS required to add choices }
Answers: ARRAY [1..25] OF
{$IFDEF WIN32} PACKED {$ENDIF} RECORD
Answer1, { answer description }
Answer2: STRING[65]; { answer description #2 }
NumVotedAnswer: Integer; { # user's who picked this answer }
NumVotedAnswer: SmallInt; { # user's who picked this answer }
END;
END;
@ -680,11 +684,11 @@ TYPE
PostACS, { post access requirement }
MCIACS, { MCI usage requirement }
SysOpACS: ACString; { Message area sysop requirement }
MaxMsgs: Word; { max message count }
MaxMsgs: SmallWord; { max message count }
Anonymous: AnonTyp; { anonymous type }
Password: STRING[20]; { area password }
MAFlags: MAFlagSet; { message area status vars }
MAType: Integer; { Area type (0=Local,1=Echo, 3=Qwk) }
MAType: SmallInt; { Area type (0=Local,1=Echo, 3=Qwk) }
Origin: STRING[50]; { origin line }
Text_Color, { color OF standard text }
Quote_Color, { color OF quoted text }
@ -695,7 +699,7 @@ TYPE
QuoteEnd: STRING[70];
PrePostFile: STRING[8];
AKA: Byte; { alternate address }
QWKIndex: Word; { QWK indexing number }
QWKIndex: SmallWord; { QWK indexing number }
END;
FileAreaFlagType =
@ -716,7 +720,7 @@ TYPE
FileName: STRING[8]; { filename + ".DIR" }
DLPath, { download path }
ULPath: STRING[40]; { upload path }
MaxFiles: Integer; { max files allowed - VerbRec Limit would allow up to LongInt Value or Maximum 433835}
MaxFiles: SmallInt; { max files allowed - VerbRec Limit would allow up to LongInt Value or Maximum 433835}
Password: STRING[20]; { password required }
ArcType, { wanted archive type (1..max,0=inactive) }
CmtType: Byte; { wanted comment type (1..3,0=inactive) }
@ -742,14 +746,14 @@ TYPE
{$IFDEF WIN32} PACKED {$ENDIF} RECORD
FileName: STRING[12]; { Filename }
Description: STRING[50]; { File description }
FilePoints: Integer; { File points }
FilePoints: SmallInt; { File points }
Downloaded: LongInt; { Number DLs }
FileSize: LongInt; { File size in Bytes }
OwnerNum: Integer; { ULer OF file }
OwnerNum: SmallInt; { ULer OF file }
OwnerName: STRING[36]; { ULer's name }
FileDate: UnixTime; { Date ULed }
VPointer: LongInt; { Pointer to verbose descr, -1 if none }
VTextSize: Integer; { Verbose descr textsize - 50 Bytes x 99 Lines = 4950 max }
VTextSize: SmallInt; { Verbose descr textsize - 50 Bytes x 99 Lines = 4950 max }
FIFlags: FIFlagSet; { File status }
END;
@ -770,7 +774,7 @@ TYPE
MsgRead, { Messages Read }
MsgPost, { Messages Posted }
EmailSent, { Email sent }
FeedbackSent: Word; { Feedback sent }
FeedbackSent: SmallWord; { Feedback sent }
UK, { Upload/Download kbytes during call }
DK: LongInt;
Reserved: ARRAY [1..17] OF Byte; { Reserved }
@ -809,7 +813,7 @@ TYPE
EventDayOfMonth: BYTE; {If monthly, the Day of Month}
EventDays: EventDaysType; {If Daily, the Days Active}
EventStartTime, {Start Time in Min from Mid.}
EventFinishTime: WORD; {Finish Time}
EventFinishTime: SmallWord; {Finish Time}
EventQualMsg, {Msg/Path if he qualifies}
EventNotQualMsg: STRING[64]; {Msg/Path if he doesn't}
EventPreTime: BYTE; {Min. B4 event to rest. Call}
@ -820,7 +824,7 @@ TYPE
LoBaud, {Low baud rate limit}
HiBaud: LongInt; {High baud rate limit}
EventACS: ACString; {Event ACS}
MaxTimeAllowed: WORD; {Max Time per user this event}
MaxTimeAllowed: SmallWord; {Max Time per user this event}
SetARflag, {AR Flag to Set}
ClearARflag: CHAR; {AR Flag to Clear}
EFlags: EFlagSet; {Kinds of Events Supported} { Changed }
@ -877,7 +881,7 @@ TYPE
NodeRecordType = { MULTNODE.DAT }
{$IFDEF WIN32} PACKED {$ENDIF} RECORD
User: Word; { What user number }
User: SmallWord; { What user number }
UserName: STRING[36]; { User's name }
CityState: STRING[30]; { User's location }
Sex: Char; { User's sex }
@ -887,7 +891,7 @@ TYPE
ActivityDesc: STRING[50]; { Activity STRING }
Status: NodeFlagSet;
Room: Byte; { What room are they in? }
Channel: Word; { What channel are they in? }
Channel: SmallWord; { What channel are they in? }
Invited, { Have they been invited ? }
Booted, { Have they been kicked off ? }
Forget: ARRAY [0..31] OF SET OF 0..7; { Who are they forgetting? }
@ -899,7 +903,7 @@ TYPE
Anonymous: Boolean; { Is Room anonymous ? }
Private: Boolean; { Is Room private ? }
Occupied: Boolean; { Is anyone in here? }
Moderator: Word; { Who's the moderator? }
Moderator: SmallWord; { Who's the moderator? }
END;
ScanRec = { *.SCN files / MESSAGES }

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

@ -1,4 +1,10 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$IFDEF MSDOS}
{$M 35500,0,131072}
{$ENDIF}
{ R E N E G A D E }
{ =============== }
@ -226,8 +232,13 @@ END;
BEGIN
ClrScr;
TextColor(Yellow);
{$IFDEF MSDOS}
GetIntVec($14,Interrupt14);
{$ENDIF}
FileMode := 66;
{$IFDEF WIN32}
FileModeReadWrite := FileMode;
{$ENDIF}
ExitSave := ExitProc;
ExitProc := @ErrorHandle;
@ -262,6 +273,7 @@ BEGIN
ReadP;
{$IFDEF MSDOS}
OvrFileMode := 0;
Write('Initializing RENEGADE.OVR ... ');
OvrInit('RENEGADE.OVR');
@ -312,6 +324,7 @@ BEGIN
END;
END;
WriteLn('Initial size of the overlay buffer is '+FormatNumber(OvrGetBuf)+' bytes.');
{$ENDIF}
Init;

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

@ -1,4 +1,10 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$IFDEF MSDOS}
{$M 49152,0,65536}
{$ENDIF}
{$A+,I-,E-,F+}
PROGRAM ReneMail;
@ -14,7 +20,12 @@ CONST
Activity_Log: Boolean = FALSE;
NetMailOnly: Boolean = FALSE;
IsNetMail: Boolean = FALSE;
{$IFDEF MSDOS}
FastPurge: Boolean = TRUE;
{$ENDIF}
{$IFDEF WIN32}
FastPurge: Boolean = FALSE;
{$ENDIF}
Process_NetMail: Boolean = TRUE;
Purge_NetMail: Boolean = TRUE;
Absolute_Scan: Boolean = FALSE;
@ -29,16 +40,16 @@ TYPE
ToUserName: STRING[35];
Subject: STRING[71];
DateTime: STRING[19];
TimesRead: Word;
DestNode: Word;
OrigNode: Word;
Cost: Word;
OrigNet: Word;
DestNet: Word;
TimesRead: SmallWord;
DestNode: SmallWord;
OrigNode: SmallWord;
Cost: SmallWord;
OrigNet: SmallWord;
DestNet: SmallWord;
Filler: ARRAY[1..8] OF Char;
ReplyTo: Word;
Attribute: Word;
NextReply: Word;
ReplyTo: SmallWord;
Attribute: SmallWord;
NextReply: SmallWord;
END;
BufferArrayType = ARRAY[1..32767] OF Char;
@ -62,7 +73,7 @@ VAR
FidoFile: FILE;
HiWaterF: FILE OF Word;
HiWaterF: FILE OF SmallWord;
General: GeneralRecordType;
@ -76,7 +87,9 @@ VAR
FidoMsgHdr: FidoRecordType;
{$IFDEF MSDOS}
Regs: Registers;
{$ENDIF}
DirInfo: SearchRec;
@ -89,6 +102,51 @@ VAR
ParamFound: Boolean;
{$IFDEF WIN32}
(* REENOTE
In BP/TP you can do this:
var
MySet: NetAttribs;
MyWord: Word;
begin
MySet := [Private, Crash];
MyWord := Word(MySet);
{ MyWord now contains the value 3 in BP/TP }
{ but VP refuses to compile the code due to Word(MySet) }
end;
In VP this typecast isn't allowed (maybe there's a compiler setting to allow it, didn't look actually)
so this function converts from a set to a word type.
While this function should work for both BP/TP and for VP, I'm only using it for VP and using the
original cast for BP/TP, since there's no need to change what isn't broken
*)
function NetAttribsToWord(inSet: NetAttribs): Word;
var
Result: Word;
begin
Result := 0;
if (Private in inSet) then result := result + 1;
if (Crash in inSet) then result := result + 2;
if (Recd in inSet) then result := result + 4;
if (NSent in inSet) then result := result + 8;
if (FileAttach in inSet) then result := result + 16;
if (Intransit in inSet) then result := result + 32;
if (Orphan in inSet) then result := result + 64;
if (KillSent in inSet) then result := result + 128;
if (Local in inSet) then result := result + 256;
if (Hold in inSet) then result := result + 512;
if (Unused in inSet) then result := result + 1024;
if (FileRequest in inSet) then result := result + 2048;
if (ReturnReceiptRequest in inSet) then result := result + 4096;
if (IsReturnReceipt in inSet) then result := result + 8192;
if (AuditRequest in inSet) then result := result + 16384;
if (FileUpdateRequest in inSet) then result := result + 32768;
NetAttribsToWord := Result;
end;
{$ENDIF}
FUNCTION CenterStr(S: STRING): STRING;
VAR
Counter1: Byte;
@ -360,6 +418,7 @@ BEGIN
END;
*)
{$IFDEF MSDOS}
FUNCTION AOnOff(B: Boolean; S1,S2: STRING): STRING; ASSEMBLER;
ASM
PUSH ds
@ -378,6 +437,16 @@ ASM
REP MOVSB
POP ds
END;
{$ENDIF}
{$IFDEF WIN32}
FUNCTION AOnOff(B: Boolean; S1,S2: STRING): STRING;
BEGIN
if (B) then
AOnOff := S1
else
AOnOff := S2;
END;
{$ENDIF}
FUNCTION StripName(S: STRING): STRING;
VAR
@ -703,7 +772,7 @@ END;
PROCEDURE GetMsgLst(MemMsgPath: STRING; VAR LowMsg,HighMsg: Word);
VAR
FidoMsgNum,
HiWater: Word;
HiWater: SmallWord;
BEGIN
HiWater := 1;
IF (NOT IsNetMail) THEN
@ -746,7 +815,7 @@ BEGIN
LogError(MemMsgPath+'HI_WATER.MRK/Read Record 0 Error - '+IntToStr(LastError)+' (Proc: GetMsgList)');
Exit;
END;
FindFirst(MemMsgPath+IntToStr(HiWater)+'.MSG',0,DirInfo);
FindFirst(MemMsgPath+IntToStr(HiWater)+'.MSG',AnyFile,DirInfo);
IF (DOSError <> 0) THEN
HiWater := 1;
END;
@ -763,7 +832,7 @@ BEGIN
END;
HighMsg := 1;
LowMsg := 65535;
FindFirst(MemMsgPath+'*.MSG',0,DirInfo);
FindFirst(MemMsgPath+'*.MSG',AnyFile,DirInfo);
WHILE (DOSError = 0) DO
BEGIN
FidoMsgNum := StrToInt(DirInfo.Name);
@ -781,7 +850,7 @@ BEGIN
LowMsg := 2;
END;
PROCEDURE UpdateHiWater(MemMsgPath: STRING; HighWater: Word);
PROCEDURE UpdateHiWater(MemMsgPath: STRING; HighWater: SmallWord);
BEGIN
Assign(HiWaterF,MemMsgPath+'HI_WATER.MRK');
{$I-} ReWrite(HiWaterF); {$I+}
@ -838,16 +907,21 @@ BEGIN
FCB[1] := Chr(Ord(MemMsgPath[1]) - 64)
ELSE
FCB[1] := Chr(Ord(StartDir[1]) - 64);
{$IFDEF MSDOS}
Regs.DS := Seg(FCB);
Regs.DX := Ofs(FCB);
Regs.AX := $1300;
MSDOS(Regs);
Purged := (Lo(Regs.AX) = 0);
{$ENDIF}
{$IFDEF WIN32}
// We ensure FastPurge is false in Win32, so this is never called
{$ENDIF}
END
ELSE
BEGIN
Purged := TRUE;
FindFirst(MemMsgPath+'*.MSG',0,DirInfo);
FindFirst(MemMsgPath+'*.MSG',AnyFile,DirInfo);
IF (DOSError <> 0) THEN
Purged := FALSE
ELSE
@ -1675,7 +1749,12 @@ BEGIN
END;
IF (IsNetMail) THEN
{$IFDEF MSDOS}
FidoMsgHdr.Attribute := Word(RGMsgHdr.NetAttribute)
{$ENDIF}
{$IFDEF WIN32}
FidoMsgHdr.Attribute := NetAttribsToWord(RGMsgHdr.NetAttribute)
{$ENDIF}
ELSE IF (Prvt IN RGMsgHdr.Status) THEN
FidoMsgHdr.Attribute := 257
ELSE
@ -1967,6 +2046,9 @@ BEGIN
GetDir(0,StartDir);
FileMode := 66;
{$IFDEF WIN32}
FileModeReadWrite := FileMode;
{$ENDIF}
GetGeneral(General);

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

@ -1,3 +1,7 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
PROGRAM RGLNG;
USES

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

@ -1,3 +1,7 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
PROGRAM RGQUOTE;
USES

157
SOURCE/RPSCREEN.PAS Normal file
View File

@ -0,0 +1,157 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
unit RPScreen;
interface
{$IFDEF WIN32}
uses
Windows;
type
TScreenBuf = Array[1..25, 1..80] of TCharInfo; // REETODO Don't hardcode to 80x25
{$ENDIF}
procedure RPBlockCursor;
procedure RPGotoXY(xy: SmallWord);
procedure RPHideCursor;
procedure RPInsertCursor;
procedure RPRestoreScreen(var screenBuf: TScreenBuf);
procedure RPSaveScreen(var screenBuf: TScreenBuf);
function RPScreenSizeX: Word;
function RPScreenSizeY: Word;
procedure RPSetAttrAt(x, y, attr: SmallWord);
procedure RPShowCursor;
function RPWhereXY: SmallWord;
implementation
{$IFDEF WIN32}
var
StdOut: THandle;
{$ENDIF}
{$IFDEF WIN32}
procedure RPBlockCursor;
var
CCI: TConsoleCursorInfo;
begin
CCI.bVisible := true;
CCI.dwSize := 15;
SetConsoleCursorInfo(StdOut, CCI);
end;
procedure RPGotoXY(xy: SmallWord);
var
Coord: TCoord;
begin
Coord.x := xy AND $00FF;
Coord.y := xy AND $FF00 SHR 8;
SetConsoleCursorPosition(StdOut, Coord);
end;
procedure RPHideCursor;
var
CCI: TConsoleCursorInfo;
begin
GetConsoleCursorInfo(StdOut, CCI);
CCI.bVisible := false;
SetConsoleCursorInfo(StdOut, CCI);
end;
procedure RPInsertCursor;
var
CCI: TConsoleCursorInfo;
begin
CCI.bVisible := true;
CCI.dwSize := 99;
SetConsoleCursorInfo(StdOut, CCI);
end;
{ REETODO Should detect screen size }
procedure RPRestoreScreen(var screenBuf: TScreenBuf);
var
BufSize : TCoord;
WritePos : TCoord;
DestRect : TSmallRect;
begin
BufSize.X := 80;
BufSize.Y := 25;
WritePos.X := 0;
WritePos.Y := 0;
DestRect.Left := 0;
DestRect.Top := 0;
DestRect.Right := 79;
DestRect.Bottom := 24;
WriteConsoleOutput(StdOut, @screenBuf[1][1], BufSize, WritePos, DestRect);
end;
{ REETODO Should detect screen size }
procedure RPSaveScreen(var screenBuf: TScreenBuf);
var
BufSize : TCoord;
ReadPos : TCoord;
SourceRect : TSmallRect;
begin
BufSize.X := 80;
BufSize.Y := 25;
ReadPos.X := 0;
ReadPos.Y := 0;
SourceRect.Left := 0;
SourceRect.Top := 0;
SourceRect.Right := 79;
SourceRect.Bottom := 24;
ReadConsoleOutput(StdOut, @screenBuf[1][1], BufSize, ReadPos, SourceRect);
end;
function RPScreenSizeX: Word;
var
CSBI: TConsoleScreenBufferInfo;
begin
GetConsoleScreenBufferInfo(StdOut, CSBI);
RPScreenSizeX := CSBI.srWindow.Right - CSBI.srWindow.Left + 1;
end;
function RPScreenSizeY: Word;
var
CSBI: TConsoleScreenBufferInfo;
begin
GetConsoleScreenBufferInfo(StdOut, CSBI);
RPScreenSizeY := CSBI.srWindow.Bottom - CSBI.srWindow.Top + 1;
end;
procedure RPSetAttrAt(x, y, attr: SmallWord);
var
NumWritten: Longint;
WriteCoord: TCoord;
begin
WriteCoord.X := x;
WriteCoord.Y := y;
WriteConsoleOutputAttribute(StdOut, @attr, 1, WriteCoord, NumWritten);
end;
procedure RPShowCursor;
var
CCI: TConsoleCursorInfo;
begin
GetConsoleCursorInfo(StdOut, CCI);
CCI.bVisible := true;
SetConsoleCursorInfo(StdOut, CCI);
end;
function RPWhereXY: SmallWord;
var
CSBI: TConsoleScreenBufferInfo;
begin
GetConsoleScreenBufferInfo(StdOut, CSBI);
RPWhereXY := CSBI.dwCursorPosition.x + (CSBI.dwCursorPosition.y SHL 8);
end;
{$ENDIF}
{$IFDEF WIN32}
BEGIN
StdOut := GetStdHandle(STD_OUTPUT_HANDLE);
{$ENDIF}
END.

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

@ -1,3 +1,7 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D-,E-,F+,I-,L-,N-,O+,R-,S+,V-}
UNIT Script;

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

@ -1,3 +1,7 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S+,V-}
UNIT ShortMsg;

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

@ -1,3 +1,7 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
UNIT SPAWNO;
INTERFACE
@ -32,11 +36,24 @@ FUNCTION Spawn(ProgName: STRING; Arguments: STRING; EnvSeg: Integer): Integer;
IMPLEMENTATION
{$IFDEF MSDOS}
{$L SPAWNTP.OBJ}
PROCEDURE Init_Spawno(Swap_Dirs: STRING; Swap_Types: Integer; Min_Res: Integer; Res_Stack: Integer); EXTERNAL;
FUNCTION Spawn(ProgName: STRING; Arguments: STRING; EnvSeg: Integer): Integer; EXTERNAL;
{$ENDIF}
{$IFDEF WIN32}
PROCEDURE Init_Spawno(Swap_Dirs: STRING; Swap_Types: Integer; Min_Res: Integer; Res_Stack: Integer);
BEGIN
WriteLn('REETODO SPAWNO Init_Spawno'); Halt;
END;
FUNCTION Spawn(ProgName: STRING; Arguments: STRING; EnvSeg: Integer): Integer;
BEGIN
WriteLn('REETODO SPAWNO Spawn'); Halt;
END;
{$ENDIF}
END.

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

@ -1,3 +1,7 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D-,E-,F+,I-,L-,N-,O+,R-,S+,V-}
UNIT SplitCha;
@ -82,6 +86,7 @@ BEGIN
Delay(600)
ELSE
BEGIN
{$IFDEF MSDOS}
FOR Counter1 := 300 DOWNTO 2 DO
BEGIN
Delay(1);
@ -92,8 +97,12 @@ BEGIN
Delay(1);
Sound(Counter1 * 10);
END;
END;
NoSound;
{$ENDIF}
{$IFDEF WIN32}
WriteLn('REETODO SPLITCHA RequestSysOpChat'); Halt;
{$ENDIF}
END;
IF (KeyPressed) THEN
BEGIN
Cmd := ReadKey;

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

@ -1,3 +1,7 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S+,V-}
UNIT STATS;
@ -8,13 +12,13 @@ USES
TYPE
Top10UserRecordArray = RECORD
UNum: Integer;
UNum: SmallInt;
Info: Real;
END;
Top20FileRecordArray = RECORD
DirNum,
DirRecNum: Integer;
DirRecNum: SmallInt;
Downloaded: LongInt;
END;

18
SYSOP1.PAS → SOURCE/SYSOP1.PAS
View File

@ -1,3 +1,7 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S+,V-}
UNIT SysOp1;
@ -72,7 +76,7 @@ VAR
END;
END;
PROCEDURE DeleteProtocol(TempProtocol1: ProtocolRecordType; RecNumToDelete: Integer);
PROCEDURE DeleteProtocol(TempProtocol1: ProtocolRecordType; RecNumToDelete: SmallInt);
VAR
RecNum: Integer;
BEGIN
@ -239,7 +243,7 @@ VAR
END;
PROCEDURE EditProtocol(TempProtocol1: ProtocolRecordType; VAR Protocol: ProtocolRecordType; VAR Cmd1: Char;
VAR RecNumToEdit: Integer; VAR Changed: Boolean; Editing: Boolean);
VAR RecNumToEdit: SmallInt; VAR Changed: Boolean; Editing: Boolean);
VAR
TempStr,
CmdStr: AStr;
@ -596,11 +600,11 @@ VAR
UNTIL (Pos(Cmd1,'Q[]FJL') <> 0) OR (HangUp);
END;
PROCEDURE InsertProtocol(TempProtocol1: ProtocolRecordType; RecNumToInsertBefore: Integer);
PROCEDURE InsertProtocol(TempProtocol1: ProtocolRecordType; RecNumToInsertBefore: SmallInt);
VAR
Cmd1: Char;
RecNum,
RecNumToEdit: Integer;
RecNumToEdit: SmallInt;
Ok,
Changed: Boolean;
BEGIN
@ -655,7 +659,7 @@ VAR
END;
END;
PROCEDURE ModifyProtocol(TempProtocol1: ProtocolRecordType; Cmd1: Char; RecNumToEdit: Integer);
PROCEDURE ModifyProtocol(TempProtocol1: ProtocolRecordType; Cmd1: Char; RecNumToEdit: SmallInt);
VAR
SaveRecNumToEdit: Integer;
Ok,
@ -706,11 +710,11 @@ VAR
END;
END;
PROCEDURE PositionProtocol(TempProtocol1: ProtocolRecordType; RecNumToPosition: Integer);
PROCEDURE PositionProtocol(TempProtocol1: ProtocolRecordType; RecNumToPosition: SmallInt);
VAR
RecNumToPositionBefore,
RecNum1,
RecNum2: Integer;
RecNum2: SmallInt;
BEGIN
IF (NumProtocols = 0) THEN
Messages(4,0,'protocols')

4
SYSOP10.PAS → SOURCE/SYSOP10.PAS
View File

@ -1,3 +1,7 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S+,V-}
UNIT SysOp10;

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