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

Reset

This commit is contained in:
R. Eric Wheeler 2022-06-21 17:11:35 -07:00
parent d8f979cd46
commit 1d848aed98
402 changed files with 108979 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.gitignore vendored Normal file
View File

@ -0,0 +1,2 @@
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

29
README.md
View File

@ -1 +1,28 @@
Renegade BBS Source Code For v1.19/DOS was removed. This code is MANY years out of date, plus it can more than likely be found on countless forks. No one seemed interested in more than forking a copy over, so it was worthless to leave on here. - Please see the current non-source builds are located @ http://www.rgbbs.info and happy BBSing!
Renegade BBS Source Code http://rgbbs.info
==============
==============================
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>

723
SOURCE/ARCHIVE1.PAS Normal file
View File

@ -0,0 +1,723 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S+,V-}
UNIT Archive1;
INTERFACE
USES
Common;
PROCEDURE ArcDeComp(VAR Ok: Boolean; AType: Byte; CONST FileName,FSpec: AStr);
PROCEDURE ArcComp(VAR Ok: Boolean; AType: Byte; CONST FileName,FSpec: AStr);
PROCEDURE ArcComment(VAR Ok: Boolean; AType: Byte; CommentNum: Byte; CONST FileName: AStr);
PROCEDURE ArcIntegrityTest(VAR Ok: Boolean; AType: Byte; CONST FileName: AStr);
PROCEDURE ConvA(VAR Ok: Boolean; OldAType,NewAType: Byte; CONST OldFN,NewFN: AStr);
FUNCTION ArcType(FileName: AStr): Byte;
PROCEDURE ListArcTypes;
PROCEDURE InvArc;
PROCEDURE ExtractToTemp;
PROCEDURE UserArchive;
IMPLEMENTATION
USES
Dos,
ArcView,
ExecBat,
File0,
File1,
File2,
File9,
TimeFunc;
PROCEDURE ArcDeComp(VAR Ok: Boolean; AType: Byte; CONST FileName,FSpec: AStr);
VAR
ResultCode: Integer;
BEGIN
PurgeDir(TempDir+'ARC\',FALSE);
ExecBatch(Ok,TempDir+'ARC\',General.ArcsPath+
FunctionalMCI(General.FileArcInfo[AType].UnArcLine,FileName,FSpec),
General.FileArcInfo[AType].SuccLevel,ResultCode,FALSE);
IF (NOT Ok) AND (Pos('.DIZ',FSpec) = 0) THEN
SysOpLog(FileName+': errors during de-compression');
END;
PROCEDURE ArcComp(VAR Ok: Boolean; AType: Byte; CONST FileName,FSpec: AStr);
VAR
ResultCode: Integer;
BEGIN
IF (General.FileArcInfo[AType].ArcLine = '') THEN
Ok := TRUE
ELSE
ExecBatch(Ok,TempDir+'ARC\',General.ArcsPath+
FunctionalMCI(General.FileArcInfo[AType].ArcLine,FileName,FSpec),
General.FileArcInfo[AType].SuccLevel,ResultCode,FALSE);
IF (NOT Ok) THEN
SysOpLog(FileName+': errors during compression');
END;
PROCEDURE ArcComment(VAR Ok: Boolean; AType: Byte; CommentNum: Byte; CONST FileName: AStr);
VAR
TempStr: AStr;
ResultCode: Integer;
SaveSwapShell: Boolean;
BEGIN
IF (CommentNum > 0) AND (General.FileArcComment[CommentNum] <> '') THEN
BEGIN
SaveSwapShell := General.SwapShell;
General.SwapShell := FALSE;
TempStr := Substitute(General.FileArcInfo[AType].CmtLine,'%C',General.FileArcComment[CommentNum]);
TempStr := Substitute(TempStr,'%C',General.FileArcComment[CommentNum]);
ExecBatch(Ok,TempDir+'ARC\',General.ArcsPath+FunctionalMCI(TempStr,FileName,''),
General.FileArcInfo[AType].SuccLevel,ResultCode,FALSE);
General.SwapShell := SaveSwapShell;
END;
END;
PROCEDURE ArcIntegrityTest(VAR Ok: Boolean; AType: Byte; CONST FileName: AStr);
VAR
ResultCode: Integer;
BEGIN
IF (General.FileArcInfo[AType].TestLine <> '') THEN
ExecBatch(Ok,TempDir+'ARC\',General.ArcsPath+
FunctionalMCI(General.FileArcInfo[AType].TestLine,FileName,''),
General.FileArcInfo[AType].SuccLevel,ResultCode,FALSE);
END;
PROCEDURE ConvA(VAR Ok: Boolean; OldAType,NewAType: Byte; CONST OldFN,NewFN: AStr);
VAR
NoFN: AStr;
PS: PathStr;
NS: NameStr;
ES: ExtStr;
FileTime: LongInt;
Match: Boolean;
BEGIN
Star('Converting archive - stage one.');
Match := (OldAType = NewAType);
IF (Match) THEN
BEGIN
FSplit(OldFN,PS,NS,ES);
NoFN := PS+NS+'.#$%';
END;
GetFileDateTime(OldFN,FileTime);
ArcDeComp(Ok,OldAType,OldFN,'*.*');
IF (NOT Ok) THEN
Star('Errors in decompression!')
ELSE
BEGIN
Star('Converting archive - stage two.');
IF (Match) THEN
RenameFile('',OldFN,NoFN,Ok);
ArcComp(Ok,NewAType,NewFN,'*.*');
IF (NOT Ok) THEN
BEGIN
Star('Errors in compression!');
IF (Match) THEN
RenameFile('',NoFN,OldFN,Ok);
END
ELSE
SetFileDateTime(NewFN,FileTime);
IF (NOT Exist(SQOutSp(NewFN))) THEN
Ok := FALSE;
END;
IF (Exist(NoFN)) THEN
Kill(NoFN);
END;
FUNCTION ArcType(FileName: AStr): Byte;
VAR
AType,
Counter: Byte;
BEGIN
AType := 0;
Counter := 1;
WHILE (Counter <= MaxArcs) AND (AType = 0) DO
BEGIN
IF (General.FileArcInfo[Counter].Active) THEN
IF (General.FileArcInfo[Counter].Ext <> '') THEN
IF (General.FileArcInfo[Counter].Ext = Copy(FileName,(Length(FileName) - 2),3)) THEN
AType := Counter;
Inc(Counter);
END;
ArcType := AType;
END;
PROCEDURE ListArcTypes;
VAR
RecNum,
RecNum1: Byte;
BEGIN
RecNum1 := 0;
RecNum := 1;
WHILE (RecNum <= MaxArcs) AND (General.FileArcInfo[RecNum].Ext <> '') DO
BEGIN
IF (General.FileArcInfo[RecNum].Active) THEN
BEGIN
Inc(RecNum1);
IF (RecNum1 = 1) THEN
Prompt('^1Available archive formats: ')
ELSE
Prompt('^1,');
Prompt('^5'+General.FileArcInfo[RecNum].Ext+'^1');
END;
Inc(RecNum);
END;
IF (RecNum1 = 0) THEN
Prompt('No archive formats available.');
NL;
END;
PROCEDURE InvArc;
BEGIN
NL;
Print('Unsupported archive format.');
NL;
ListArcTypes;
END;
PROCEDURE ExtractToTemp;
TYPE
TotalsRecordType = RECORD
TotalFiles: SmallInt;
TotalSize: LongInt;
END;
VAR
Totals: TotalsRecordType;
FileName,
ArcFileName: AStr;
(*
DirInfo: SearchRec;
*)
DS: DirStr;
NS: NameStr;
ES: ExtStr;
Cmd: Char;
AType: Byte;
ReturnCode,
DirFileRecNum: Integer;
DidSomething,
Ok: Boolean;
BEGIN
NL;
Print('Extract to temporary directory -');
NL;
Prompt('^1Already in TEMP: ');
FillChar(Totals,SizeOf(Totals),0);
FindFirst(TempDir+'ARC\*.*',AnyFile - Directory - VolumeID - Hidden - SysFile,DirInfo);
WHILE (DOSError = 0) DO
BEGIN
Inc(Totals.TotalFiles);
Inc(Totals.TotalSize,DirInfo.Size);
FindNext(DirInfo);
END;
IF (Totals.TotalFiles = 0) THEN
Print('^5Nothing.^1')
ELSE
Print('^5'+FormatNumber(Totals.TotalFiles)+
' '+Plural('file',Totals.TotalFiles)+
', '+ConvertBytes(Totals.TotalSize,FALSE)+'.^1');
IF (NOT FileSysOp) THEN
BEGIN
NL;
Print('The limit is '+FormatNumber(General.MaxInTemp)+'k bytes.');
IF (Totals.TotalSize > (General.MaxInTemp * 1024)) THEN
BEGIN
NL;
Print('You have exceeded this limit.');
NL;
Print('Please remove some files with the user-archive command.');
Exit;
END;
END;
NL;
Prt('File name: ');
IF (FileSysOp) THEN
BEGIN
MPL(52);
Input(FileName,52);
END
ELSE
BEGIN
MPL(12);
Input(FileName,12);
END;
FileName := SQOutSp(FileName);
IF (FileName = '') THEN
BEGIN
NL;
Print('Aborted!');
Exit;
END;
IF (IsUL(FileName)) AND (NOT FileSysOp) THEN
BEGIN
NL;
Print('^7Invalid file name!^1');
Exit;
END;
IF (Pos('.',FileName) = 0) THEN
FileName := FileName + '*.*';
Ok := TRUE;
IF (NOT IsUL(FileName)) THEN
BEGIN
RecNo(FileInfo,FileName,DirFileRecNum);
IF (BadDownloadPath) THEN
Exit;
IF (NOT AACS(MemFileArea.DLACS)) THEN
BEGIN
NL;
Print('^7You do not have access to manipulate that file!^1');
Exit;
END
ELSE IF (DirFileRecNum = -1) THEN
BEGIN
NL;
Print('^7File not found!^1');
Exit;
END
ELSE
BEGIN
Seek(FileInfoFile,DirFileRecNum);
Read(FileInfoFile,FileInfo);
IF Exist(MemFileArea.DLPath+FileInfo.FileName) THEN
ArcFileName := MemFileArea.DLPath+SQOutSp(FileInfo.FileName)
ELSE
ArcFileName := MemFileArea.ULPath+SQOutSp(FileInfo.FileName);
END;
END
ELSE
BEGIN
ArcFileName := FExpand(FileName);
IF (NOT Exist(ArcFileName)) THEN
BEGIN
NL;
Print('^7File not found!^1');
Exit;
END
ELSE
BEGIN
FillChar(FileInfo,SizeOf(FileInfo),0);
WITH FileInfo DO
BEGIN
FileName := Align(StripName(ArcFileName));
Description := 'Unlisted file';
FilePoints := 0;
Downloaded := 0;
FileSize := GetFileSize(ArcFileName);
OwnerNum := UserNum;
OwnerName := Caps(ThisUser.Name);
FileDate := Date2PD(DateStr);
VPointer := -1;
VTextSize := 0;
FIFlags := [];
END;
END;
END;
IF (Ok) THEN
BEGIN
DidSomething := FALSE;
Abort := FALSE;
Next := FALSE;
AType := ArcType(ArcFileName);
IF (AType = 0) THEN
InvArc;
NL;
Print('You can (^5C^1)opy this file into the TEMP Directory,');
IF (AType <> 0) THEN
Print('or (^5E^1)xtract files from it into the TEMP Directory.')
ELSE
Print('but you can''t extract files from it.');
NL;
Prt('Which? (^5C^4=^5Copy'+AOnOff((AType <> 0),'^4,^5E^4=^5Extract','')+'^4,^5Q^4=^5Quit^4): ');
OneK(Cmd,'QC'+AOnOff((AType <> 0),'E',''),TRUE,TRUE);
CASE Cmd OF
'C' : BEGIN
FSplit(ArcFileName,DS,NS,ES);
NL;
IF CopyMoveFile(TRUE,'^5Progress: ',ArcFileName,TempDir+'ARC\'+NS+ES,TRUE) THEN
DidSomething := TRUE;
END;
'E' : BEGIN
NL;
DisplayFileInfo(FileInfo,TRUE);
REPEAT
NL;
Prt('Extract files (^5E^4=^5Extract^4,^5V^4=^5View^4,^5Q^4=^5Quit^4): ');
OneK(Cmd,'QEV',TRUE,TRUE);
CASE Cmd OF
'E' : BEGIN
NL;
IF PYNQ('Extract all files? ',0,FALSE) THEN
FileName := '*.*'
ELSE
BEGIN
NL;
Prt('File name: ');
MPL(12);
Input(FileName,12);
FileName := SQOutSp(FileName);
IF (FileName = '') THEN
BEGIN
NL;
Print('Aborted!');
END
ELSE IF IsUL(FileName) THEN
BEGIN
NL;
Print('^7Illegal filespec!^1');
FileName := '';
END;
END;
IF (FileName <> '') THEN
BEGIN
Ok := FALSE;
ExecBatch(Ok,TempDir+'ARC\',General.ArcsPath+
FunctionalMCI(General.FileArcInfo[AType].UnArcLine,ArcFileName,FileName),
General.FileArcInfo[AType].SuccLevel,ReturnCode,FALSE);
IF (Ok) THEN
BEGIN
NL;
Star('Decompressed '+FileName+' into TEMP from '+StripName(ArcFileName));
SysOpLog('Decompressed '+FileName+' into '+TempDir+'ARC\ from '+StripName(ArcFileName));
DidSomething := TRUE;
END
ELSE
BEGIN
NL;
Star('Error decompressing '+FileName+' into TEMP from '+StripName(ArcFileName));
SysOpLog('Error decompressing '+FileName+' into '+TempDir+'ARC\ from '+StripName(ArcFileName));
END;
END;
END;
'V' : IF (IsUL(ArcFileName)) THEN
ViewInternalArchive(ArcFileName)
ELSE
BEGIN
IF Exist(MemFileArea.DLPath+FileInfo.FileName) THEN
ViewInternalArchive(MemFileArea.DLPath+FileInfo.FileName)
ELSE
ViewInternalArchive(MemFileArea.ULPath+FileInfo.FileName);
END;
END;
UNTIL (Cmd = 'Q') OR (HangUp);
END;
END;
IF (DidSomething) THEN
BEGIN
NL;
Print('^5NOTE: ^1Use the user archive menu command to access');
Print(' files in the TEMP directory.^1');
END;
END;
LastError := IOResult;
END;
PROCEDURE UserArchive;
VAR
User: UserRecordType;
(*
DirInfo: SearchRec;
*)
TransferFlags: TransferFlagSet;
ArcFileName,
FName: Str12;
Cmd: Char;
AType,
SaveNumBatchDLFiles: Byte;
ReturnCode,
GotPts,
SaveFileArea: Integer;
Ok,
SaveFileCreditRatio: Boolean;
FUNCTION OkName(FileName1: AStr): Boolean;
BEGIN
OkName := TRUE;
OkName := NOT IsWildCard(FileName1);
IF (IsUL(FileName1)) THEN
OkName := FALSE;
END;
BEGIN
REPEAT
NL;
Prt('Temp archive menu [^5?^4=^5Help^4]: ');
OneK(Cmd,'QADLRVT?',TRUE,TRUE);
CASE Cmd OF
'A' : BEGIN
NL;
Prt('Archive name: ');
MPL(12);
Input(ArcFileName,12);
IF (ArcFileName = '') THEN
BEGIN
NL;
Print('Aborted!');
END
ELSE
BEGIN
LoadFileArea(FileArea);
IF (Pos('.',ArcFileName) = 0) AND (MemFileArea.ArcType <> 0) THEN
ArcFileName := ArcFileName+'.'+General.FileArcInfo[MemFileArea.ArcType].Ext;
AType := ArcType(ArcFileName);
IF (AType = 0) THEN
InvArc
ELSE
BEGIN
NL;
Prt('File name: ');
MPL(12);
Input(FName,12);
IF (FName = '') THEN
BEGIN
NL;
Print('Aborted!');
END
ELSE IF (IsUL(FName)) OR (Pos('@',FName) > 0) THEN
BEGIN
NL;
Print('^7Illegal file name!^1');
END
ELSE IF (NOT Exist(TempDir+'ARC\'+FName)) THEN
BEGIN
NL;
Print('^7File not found!^1');
END
ELSE
BEGIN
Ok := FALSE;
ExecBatch(Ok,TempDir+'ARC\',General.ArcsPath+
FunctionalMCI(General.FileArcInfo[AType].ArcLine,TempDir+'ARC\'+ArcFileName,FName),
General.FileArcInfo[AType].SuccLevel,ReturnCode,FALSE);
IF (Ok) THEN
BEGIN
NL;
Star('Compressed "^5'+FName+'^3" into "^5'+ArcFileName+'^3"');
SysOpLog('Compressed "^5'+FName+'^1" into "^5'+TempDir+'ARC\'+ArcFileName+'^1"')
END
ELSE
BEGIN
NL;
Star('Error compressing "^5'+FName+'^3" into "^5'+ArcFileName+'^3"');
SysOpLog('Error compressing "^5'+FName+'^1" into "^5'+TempDir+'ARC\'+ArcFileName+'^1"');
END;
END;
END;
END;
END;
'D' : BEGIN
NL;
Prt('File name: ');
MPL(12);
Input(FName,12);
IF (FName = '') THEN
BEGIN
NL;
Print('Aborted!');
END
ELSE IF (NOT OkName(FName)) THEN
BEGIN
NL;
Print('^7Illegal file name!^1');
END
ELSE
BEGIN
FindFirst(TempDir+'ARC\'+FName,AnyFile - Directory - VolumeID - Hidden - SysFile,DirInfo);
IF (DOSError <> 0) THEN
BEGIN
NL;
Print('^7File not found!^1');
END
ELSE
BEGIN
SaveFileArea := FileArea;
FileArea := -1;
WITH MemFileArea DO
BEGIN
AreaName := 'Temp Archive';
DLPath := TempDir+'ARC\';
ULPath := TempDir+'ARC\';
FAFlags := [];
END;
(* Consider charging points, ext. *)
LoadURec(User,1);
WITH FileInfo DO
BEGIN
FileName := Align(FName);
Description := 'Temporary Archive';
FilePoints := 0;
Downloaded := 0;
FileSize := GetFileSize(TempDir+'ARC\'+FileName);;
OwnerNum := 1;
OwnerName := Caps(User.Name);
FileDate := Date2PD(DateStr);
VPointer := -1;
VTextSize := 0;
FIFlags := [];
END;
TransferFlags := [IsTempArc,IsCheckRatio];
SaveNumBatchDLFiles := NumBatchDLFiles;
DLX(FileInfo,-1,TransferFlags);
FileArea := SaveFileArea;
LoadFileArea(FileArea);
IF (NumBatchDLFiles <> SaveNumBatchDLFiles) THEN
BEGIN
NL;
Print('^5REMEMBER: ^1If you delete this file from the temporary directory,');
Print(' you will not be able to download it in your batch queue.');
END;
END;
END;
END;
'L' : BEGIN
AllowContinue := TRUE;
NL;
DosDir(TempDir+'ARC\','*.*',TRUE);
AllowContinue := FALSE;
SysOpLog('Listed temporary directory: "^5'+TempDir+'ARC\*.*^1"');
END;
'R' : BEGIN
NL;
Prt('File mask: ');
MPL(12);
Input(FName,12);
IF (FName = '') THEN
BEGIN
NL;
Print('Aborted!');
END
ELSE IF (IsUL(FName)) THEN
BEGIN
NL;
Print('^7Illegal file name!^1');
END
ELSE
BEGIN
FindFirst(TempDir+'ARC\'+FName,AnyFile - Directory - VolumeID - Hidden - SysFile,DirInfo);
IF (DOSError <> 0) THEN
BEGIN
NL;
Print('^7File not found!^1');
END
ELSE
BEGIN
NL;
REPEAT
Kill(TempDir+'ARC\'+DirInfo.Name);
Star('Removed temporary archive file: "^5'+DirInfo.Name+'^3"');
SysOpLog('^1Removed temp arc file: "^5'+TempDir+'ARC\'+DirInfo.Name+'^1"');
FindNext(DirInfo);
UNTIL (DOSError <> 0) OR (HangUp);
END;
END;
END;
'T' : BEGIN
NL;
Prt('File name: ');
MPL(12);
Input(FName,12);
IF (FName = '') THEN
BEGIN
NL;
Print('Aborted!');
END
ELSE IF (NOT OkName(FName)) THEN
BEGIN
NL;
Print('^7Illegal file name!^1');
END
ELSE
BEGIN
FindFirst(TempDir+'ARC\'+FName,AnyFile - Directory - VolumeID - Hidden - SysFile,DirInfo);
IF (DOSError <> 0) THEN
BEGIN
NL;
Print('^7File not found!^1');
END
ELSE
BEGIN
NL;
PrintF(TempDir+'ARC\'+DirInfo.Name);
SysOpLog('Displayed temp arc file: "^5'+TempDir+'ARC\'+DirInfo.Name+'^1"');
END;
END;
END;
'V' : BEGIN
NL;
Prt('File mask: ');
MPL(12);
Input(FName,12);
IF (FName = '') THEN
BEGIN
NL;
Print('Aborted!');
END
ELSE IF (NOT ValidIntArcType(FName)) THEN
BEGIN
NL;
Print('^7Not a valid archive type or not supported!^1')
END
ELSE
BEGIN
FindFirst(TempDir+'ARC\'+FName,AnyFile - Directory - VolumeID - Hidden - SysFile,DirInfo);
IF (DOSError <> 0) THEN
BEGIN
NL;
Print('^7File not found!^1');
END
ELSE
BEGIN
Abort := FALSE;
Next := FALSE;
REPEAT
ViewInternalArchive(TempDir+'ARC\'+DirInfo.Name);
SysOpLog('Viewed temp arc file: "^5'+TempDir+'ARC\'+DirInfo.Name+'^1"');
FindNext(DirInfo);
UNTIL (DOSError <> 0) OR (Abort) OR (HangUp);
END;
END;
END;
'?' : BEGIN
NL;
ListArcTypes;
NL;
LCmds(30,3,'Add to archive','');
LCmds(30,3,'Download files','');
LCmds(30,3,'List files in directory','');
LCmds(30,3,'Remove files','');
LCmds(30,3,'Text view file','');
LCmds(30,3,'View archive','');
LCmds(30,3,'Quit','');
END;
END;
UNTIL (Cmd = 'Q') OR (HangUp);
LastCommandOvr := TRUE;
LastError := IOResult;
END;
END.

919
SOURCE/ARCHIVE2.PAS Normal file
View File

@ -0,0 +1,919 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S+,V-}
UNIT Archive2;
INTERFACE
PROCEDURE DOArcCommand(Cmd: Char);
IMPLEMENTATION
USES
Dos,
Archive1,
Archive3,
Arcview,
Common,
ExecBat,
File0,
File1,
File9,
File11,
TimeFunc;
CONST
MaxDOSChrLine = 127;
PROCEDURE DOArcCommand(Cmd: Char);
CONST
MaxFiles = 100;
VAR
FI: FILE OF Byte;
FileListArray: ARRAY [1..MaxFiles] OF AStr;
F: FileInfoRecordType;
(*
DirInfo: SearchRec;
*)
FileName,
S,
S1,
S2,
OS1: AStr;
DS: DirStr;
NS: NameStr;
ES: ExtStr;
AType,
BB,
NumExtDesc,
NumFiles,
RecNum,
Counter: Byte;
Junk,
RN,
FArea,
SaveFileArea,
C_Files: Integer;
C_OldSiz,
C_NewSiz,
OldSiz,
NewSiz: LongInt;
Ok,
Ok1,
FNX,
WentToSysOp,
DelBad: Boolean;
PROCEDURE AddFL(F1: FileInfoRecordType; FN1: AStr; VAR NumFiles1: Byte; b: Boolean);
VAR
DirInfo1: SearchRec;
DS1: DirStr;
NS1: NameStr;
ES1: ExtStr;
SaveNumFiles: Byte;
RN1: Integer;
BEGIN
SaveNumFiles := NumFiles1;
IF (NOT b) THEN
BEGIN
RecNo(F1,FN1,RN1);
IF (BadDownloadPath) THEN
Exit;
WHILE (RN1 <> -1) AND (NumFiles1 < MaxFiles) DO
BEGIN
Seek(FileInfoFile,RN1);
Read(FileInfoFile,F1);
Inc(NumFiles1);
FileListArray[NumFiles1] := F1.FileName;
NRecNo(F1,RN1);
END;
END
ELSE
BEGIN
FSplit(FN1,DS1,NS1,ES1);
ChDir(BSlash(DS1,FALSE));
IF (IOResult <> 0) THEN
Print('Path not found.')
ELSE
BEGIN
FindFirst(FN1,AnyFile - Directory - VolumeID - Dos.Hidden - SysFile,DirInfo1);
WHILE (DOSError = 0) AND (NumFiles1 < MaxFiles) DO
BEGIN
Inc(NumFiles1);
FileListArray[NumFiles1] := FExpand(DS1+DirInfo1.Name);
FindNext(DirInfo1);
END;
END;
ChDir(StartDir);
END;
IF (NumFiles1 = SaveNumFiles) THEN
Print('No matching files.')
ELSE IF (NumFiles1 >= MaxFiles) THEN
Print('File records filled.');
END;
PROCEDURE TestFiles(F1: FileInfoRecordType; FArea1: Integer; FN1: AStr; DelBad1: Boolean);
VAR
AType1: Byte;
RN1: Integer;
Ok2: Boolean;
BEGIN
IF (FileArea <> FArea1) THEN
ChangeFileArea(FArea1);
IF (FileArea = FArea1) THEN
BEGIN
RecNo(F1,FN1,RN1);
IF (BadDownloadPath) THEN
Exit;
WHILE (RN1 <> -1) AND (NOT Abort) AND (NOT HangUp) DO
BEGIN
Seek(FileInfoFile,RN1);
Read(FileInfoFile,F1);
IF Exist(MemFileArea.DLPath+F1.FileName) THEN
FN1 := MemFileArea.DLPath+F1.FileName
ELSE
FN1 := MemFileArea.ULPath+F1.FileName;
AType1 := ArcType(FN1);
IF (AType1 <> 0) THEN
BEGIN
DisplayFileAreaHeader;
Star('Testing "'+SQOutSP(FN1)+'"');
IF (NOT Exist(FN1)) THEN
Star('File "'+SQOutSP(FN1)+'" does not exist.')
ELSE
BEGIN
Ok2 := TRUE;
ArcIntegrityTest(Ok2,AType1,SQOutSP(FN1));
IF (NOT Ok2) THEN
BEGIN
Star('File "'+SQOutSP(FN1)+'" did not pass integrity test.');
IF (DelBad1) THEN
BEGIN
DeleteFF(F1,RN1);
Kill(FN1);
END;
END;
END;
END;
WKey;
NRecNo(F1,RN1);
END;
Close(FileInfoFile);
Close(ExtInfoFile);
END;
LastError := IOResult;
END;
PROCEDURE CmtFiles(F1: FileInfoRecordType; FArea1: Integer; FN1: AStr);
VAR
AType1: Byte;
RN1: Integer;
Ok2: Boolean;
BEGIN
IF (FileArea <> FArea1) THEN
ChangeFileArea(FArea1);
IF (FileArea = FArea1) THEN
BEGIN
RecNo(F1,FN1,RN1);
IF (BadDownloadPath) THEN
Exit;
WHILE (RN1 <> -1) AND (NOT Abort) AND (NOT HangUp) DO
BEGIN
Seek(FileInfoFile,RN1);
Read(FileInfoFile,F1);
IF Exist(MemFileArea.DLPath+F1.FileName) THEN
FN1 := MemFileArea.DLPath+F1.FileName
ELSE
FN1 := MemFileArea.ULPath+F1.FileName;
AType1 := ArcType(FN1);
IF (AType1 <> 0) THEN
BEGIN
DisplayFileAreaHeader;
NL;
Star('Commenting "'+SQOutSP(FN1)+'"');
IF (NOT Exist(FN1)) THEN
Star('File "'+SQOutSP(FN1)+'" does not exist.')
ELSE
BEGIN
Ok2 := TRUE;
ArcComment(Ok2,AType1,MemFileArea.CmtType,SQOutSP(FN1));
(* If NOT Ok *)
END;
END;
WKey;
NRecNo(F1,RN1);
END;
Close(FileInfoFile);
Close(ExtInfoFile);
END;
LastError := IOResult;
END;
PROCEDURE CvtFiles(F1: FileInfoRecordType;
FArea1: Integer;
FN1: AStr;
Toa: Integer;
VAR C_Files1: Integer;
VAR C_OldSiz1,
C_NewSiz1: LongInt);
VAR
FI: FILE OF Byte;
S3: AStr;
AType1: Byte;
RN1: Integer;
Ok2: Boolean;
BEGIN
IF (FileArea <> FArea1) THEN
ChangeFileArea(FArea1);
IF (FileArea = FArea1) THEN
BEGIN
RecNo(F1,FN1,RN1);
IF (BadDownloadPath) THEN
Exit;
WHILE (RN1 <> -1) AND (NOT Abort) AND (NOT HangUp) DO
BEGIN
Seek(FileInfoFile,RN1);
Read(FileInfoFile,F1);
IF Exist(MemFileArea.DLPath+F1.FileName) THEN
FN1 := MemFileArea.DLPath+F1.FileName
ELSE
FN1 := MemFileArea.ULPath+F1.FileName;
AType1 := ArcType(FN1);
IF (AType1 <> 0) AND (AType1 <> Toa) THEN
BEGIN
DisplayFileAreaHeader;
NL;
Star('Converting "'+SQOutSP(FN1)+'"');
Ok2 := FALSE;
IF (NOT Exist(FN1)) THEN
BEGIN
Star('File "'+SQOutSP(FN1)+'" does not exist - changing extension.');
S3 := Copy(FN1,1,Pos('.',FN1))+General.FileArcInfo[Toa].Ext;
F1.FileName := Align(StripName(SQOutSP(S3)));
Seek(FileInfoFile,RN1);
Write(FileInfoFile,F1);
END
ELSE
BEGIN
Ok2 := TRUE;
S3 := Copy(FN1,1,Pos('.',FN1))+General.FileArcInfo[Toa].Ext;
ConvA(Ok2,AType1,BB,SQOutSP(FN1),SQOutSP(S3));
IF (Ok2) THEN
BEGIN
Assign(FI,SQOutSP(FN1));
Reset(FI);
Ok2 := (IOResult = 0);
IF (Ok2) THEN
BEGIN
OldSiz := FileSize(FI);
Close(FI);
END
ELSE
Star('Unable to access "'+SQOutSP(FN1)+'"');
IF (Ok2) THEN
IF (NOT Exist(SQOutSP(S3))) THEN
BEGIN
Star('Unable to access "'+SQOutSP(S3)+'"');
SysOpLog('Unable to access '+SQOutSP(S3));
Ok2 := FALSE;
END;
END;
IF (Ok2) THEN
BEGIN
F1.FileName := Align(StripName(SQOutSP(S3)));
Seek(FileInfoFile,RN1);
Write(FileInfoFile,F1);
Kill(SQOutSP(FN1));
Assign(FI,SQOutSP(S3));
Reset(FI);
Ok2 := (IOResult = 0);
IF (NOT Ok2) THEN
BEGIN
Star('Unable to access '+SQOutSP(S3));
SysOpLog('Unable to access '+SQOutSP(S3));
END
ELSE
BEGIN
NewSiz := FileSize(FI);
F1.FileSize := NewSiz;
Close(FI);
Seek(FileInfoFile,RN1);
Write(FileInfoFile,F1);
END;
IF (Ok2) THEN
BEGIN
Inc(C_OldSiz1,OldSiz);
Inc(C_NewSiz1,NewSiz);
Inc(C_Files1);
Star('Old total space took up : '+ConvertBytes(OldSiz,FALSE));
Star('New total space taken up : '+ConvertBytes(NewSiz,FALSE));
IF (OldSiz - NewSiz > 0) THEN
Star('Space saved : '+ConvertBytes(OldSiz-NewSiz,FALSE))
ELSE
Star('Space wasted : '+ConvertBytes(NewSiz-OldSiz,FALSE));
END;
END
ELSE
BEGIN
SysOpLog('Unable to convert '+SQOutSP(FN1));
Star('Unable to convert '+SQOutSP(FN1));
END;
END;
END;
WKey;
NRecNo(F,RN1);
END;
Close(FileInfoFile);
Close(ExtInfoFile);
END;
LastError := IOResult;
END;
BEGIN
TempPause := FALSE;
SaveFileArea := FileArea;
InitFileArea(FileArea);
IF (BadDownloadPath) THEN
Exit;
CASE Cmd OF
'A' : BEGIN
NL;
Print('Add file(s) to archive (up to '+IntToStr(MaxFiles)+') -');
NL;
Print('Archive file name: ');
Prt(':');
MPL(78);
Input(FileName,78);
IF IsUL(FileName) AND (NOT FileSysOp) THEN
FileName := '';
IF (FileName = '') THEN
BEGIN
NL;
Print('Aborted!');
END
ELSE
BEGIN
NumFiles := 0;
IF (Pos('.',FileName) = 0) AND (MemFileArea.ArcType <> 0) THEN
FileName := FileName+'.'+General.FileArcInfo[MemFileArea.ArcType].Ext;
FNX := ISUL(FileName);
IF (NOT FNX) THEN
BEGIN
IF Exist(MemFileArea.DLPath+FileName) THEN
FileName := MemFileArea.DLPath+FileName
ELSE
FileName := MemFileArea.ULPath+FileName
END;
FileName := FExpand(FileName);
AType := ArcType(FileName);
IF (AType = 0) THEN
InvArc
ELSE
BEGIN
Cmd := 'A';
REPEAT
IF (Cmd = 'A') THEN
REPEAT
NL;
Print('Add files to list - <CR> to end');
Prt(IntToStr(NumFiles + 1)+':');
MPL(70);
Input(S,70);
IF (S <> '') AND (NOT IsUL(S) OR FileSysOp) THEN
BEGIN
IF (Pos('.',S) = 0) THEN
S := S + '*.*';
AddFL(F,S,NumFiles,IsUL(S));
END;
UNTIL (S = '') OR (NumFiles >= MaxFiles) OR (HangUp);
NL;
Prt('Add files to list [^5?^4=^5Help^4]: ');
OneK(Cmd,'QADLR?',TRUE,TRUE);
NL;
CASE Cmd OF
'?' : BEGIN
LCmds(19,3,'Add more to list','Do it!');
LCmds(19,3,'List files in list','Remove files from list');
LCmds(19,3,'Quit','');
END;
'D' : BEGIN
RecNum := 0;
REPEAT
Inc(RecNum);
Counter := 1;
S2 := SQOutSP(FileListArray[RecNum]);
IF (NOT IsUL(S2)) THEN
S2 := MemFileArea.DLPath+S2;
S1 := FunctionalMCI(General.FileArcInfo[AType].ArcLine,FileName,S2);
OS1 := S1;
WHILE (Length(S1) <= MaxDOSChrLine) AND (RecNum < NumFiles) DO
BEGIN
Inc(RecNum);
Inc(Counter);
S2 := SQOutSP(FileListArray[RecNum]);
IF (NOT IsUL(S2)) THEN
S2 := MemFileArea.DLPath+S2;
OS1 := S1;
S1 := S1+' '+S2;
END;
IF (Length(S1) > MaxDOSChrLine) THEN
BEGIN
Dec(RecNum);
Dec(Counter);
S1 := OS1;
END;
Ok := TRUE;
Star('Adding '+IntToStr(Counter)+' files to archive...');
ExecBatch(Ok,
TempDir+'UP\',General.ArcsPath+S1,
General.FileArcInfo[AType].SuccLevel,Junk,FALSE);
IF (NOT Ok) THEN
BEGIN
Star('errors in adding files');
Ok := PYNQ('Continue anyway? ',0,FALSE);
IF (HangUp) THEN
Ok := FALSE;
END;
UNTIL (RecNum >= NumFiles) OR (NOT Ok);
ArcComment(Ok,AType,MemFileArea.CmtType,FileName);
NL;
IF (NOT FNX) THEN
BEGIN
S1 := StripName(FileName);
RecNo(F,S1,RN);
IF (BadDownloadPath) THEN
Exit;
IF (RN <> -1) THEN
Print('^5NOTE: File already exists in listing!');
IF PYNQ('Add archive to listing? ',0,FALSE) THEN
BEGIN
Assign(FI,FileName);
Reset(FI);
IF (IOResult = 0) THEN
BEGIN
F.fileSize := FileSize(FI);
Close(FI);
END;
F.FileName := Align(S1);
Ok1 := TRUE;
IF PYNQ('Replace a file in directory? ',0,FALSE) THEN
BEGIN
REPEAT
NL;
Prt('Enter file name: ');
MPL(12);
Input(S2,12);
IF (S2 = '') THEN
BEGIN
NL;
Print('Aborted!');
END
ELSE
BEGIN
RecNo(F,S2,RN);
IF (BadDownloadPath) THEN
Exit;
IF (RN = -1) THEN
Print('File not found!');
END;
UNTIL (RN <> -1) OR (S2 = '') OR (HangUp);
IF (S2 <> '') THEN
BEGIN
Seek(FileInfoFile,RN);
Read(FileInfoFile,F);
Kill(MemFileArea.ULPath+SQOutSP(F.FileName));
F.FileName := Align(S1);
Seek(FileInfoFile,RN);
Write(FileInfoFile,F);
END
ELSE
Ok1 := FALSE;
END
ELSE
Ok1 := FALSE;
IF (NOT Ok1) THEN
BEGIN
WentToSysOp := FALSE;
GetFileDescription(F,ExtendedArray,NumExtDesc,WentToSysOp);
F.FilePoints := 0;
F.Downloaded := 0;
F.OwnerNum := UserNum;
F.OwnerName := AllCaps(ThisUser.Name);
F.FileDate := Date2PD(DateStr);
F.VPointer := -1;
F.VTextSize := 0;
END;
F.FIFlags := [];
IF (NOT AACS(General.ULValReq)) AND (NOT General.ValidateAllFiles) THEN
Include(F.FIFlags,FINotVal);
IF (NOT General.FileCreditRatio) THEN
F.FilePoints := 0
ELSE
F.FilePoints := ((F.FileSize DIV 1024) DIV General.FileCreditCompBaseSize);
IF (RN = -1) THEN
WriteFV(F,FileSize(FileInfoFile),ExtendedArray)
ELSE
WriteFV(F,RN,ExtendedArray);
END;
END;
IF PYNQ('Delete original files? ',0,FALSE) THEN
FOR RecNum := 1 TO NumFiles DO
BEGIN
S2 := SQOutSP(FileListArray[RecNum]);
IF (NOT IsUL(FileListArray[RecNum])) THEN
BEGIN
RecNo(F,S2,RN);
IF (BadDownloadPath) THEN
Exit;
IF (RN <> -1) THEN
DeleteFF(F,RN);
S2 := MemFileArea.DLPath+S2;
END;
Kill(S2);
END;
IF (Ok) THEN
Cmd := 'Q';
END;
'L' : IF (NumFiles = 0) THEN
Print('No files in list!')
ELSE
BEGIN
Abort := FALSE;
Next := FALSE;
S := '';
Counter := 0;
RecNum := 0;
REPEAT
Inc(RecNum);
IF IsUL(FileListArray[RecNum]) THEN
S := S + '^3'
ELSE
S := S + '^1';
S := S + Align(StripName(FileListArray[RecNum]));
Inc(Counter);
IF (Counter < 5) THEN
S := S + ' '
ELSE
BEGIN
PrintACR(S);
S := '';
Counter := 0;
END;
UNTIL (RecNum = NumFiles) OR (Abort) OR (HangUp);
IF (Counter in [1..4]) AND (NOT Abort) THEN
PrintACR(S);
END;
'R' : IF (NumFiles = 0) THEN
Print('No files in list!')
ELSE
BEGIN
Prt('Remove file name: ');
MPL(12);
Input(S,12);
IF (S = '') THEN
BEGIN
NL;
Print('Aborted!');
END
ELSE
BEGIN
RecNum := 0;
REPEAT
Inc(RecNum);
IF Align(StripName(FileListArray[RecNum])) = Align(S) THEN
BEGIN
Prompt('^3'+SQOutSP(FileListArray[RecNum]));
IF PYNQ(' Remove it? ',0,FALSE) THEN
BEGIN
FOR Counter := RecNum TO (NumFiles - 1) DO
FileListArray[Counter] := FileListArray[Counter + 1];
Dec(NumFiles);
Dec(RecNum);
END;
END;
UNTIL (RecNum >= NumFiles);
END;
END;
END;
UNTIL (Cmd = 'Q') OR (HangUp);
Cmd := #0;
END;
END;
END;
'C' : BEGIN
NL;
Print('Convert archive formats -');
NL;
Print('Filespec:');
Prt(':');
MPL(78);
Input(FileName,78);
IF (FileName = '') THEN
BEGIN
NL;
Print('Aborted!');
END
ELSE
BEGIN
NL;
REPEAT
Prt('Archive type to use? (?=List): ');
MPL(3);
Input(S,3);
IF (S = '?') THEN
BEGIN
NL;
ListArcTypes;
NL;
END;
UNTIL (S <> '?');
IF (StrToInt(S) <> 0) THEN
BB := StrToInt(S)
ELSE
BB := ArcType('F.'+S);
IF (BB <> 0) THEN
BEGIN
C_Files := 0;
C_OldSiz := 0;
C_NewSiz := 0;
Abort := FALSE;
Next := FALSE;
SysOpLog('Conversion process initiated at '+DateStr+' '+TimeStr+'.');
IF (IsUL(FileName)) THEN
BEGIN
FSplit(FileName,DS,NS,ES);
FindFirst(FileName,AnyFile - Directory - VolumeID - Dos.Hidden - SysFile,DirInfo);
WHILE (DOSError = 0) AND (NOT Abort) AND (NOT HangUp) DO
BEGIN
FileName := FExpand(SQOutSP(DS+DirInfo.Name));
AType := ArcType(FileName);
IF (AType <> 0) AND (AType <> BB) THEN
BEGIN
Star('Converting "'+FileName+'"');
Ok := TRUE;
S := Copy(FileName,1,Pos('.',FileName))+General.FileArcInfo[BB].Ext;
ConvA(Ok,AType,BB,FileName,S);
IF (Ok) THEN
BEGIN
Assign(FI,SQOutSP(FileName));
Reset(FI);
Ok := (IOResult = 0);
IF (Ok) THEN
BEGIN
OldSiz := FileSize(FI);
Close(FI);
END
ELSE
Star('Unable to access '+SQOutSP(FileName));
IF (Ok) THEN
IF (NOT Exist(SQOutSP(S))) THEN
BEGIN
Star('Unable to access '+SQOutSP(S));
SysOpLog('Unable to access '+SQOutSP(S));
Ok := FALSE;
END;
END;
IF (Ok) THEN
BEGIN
Kill(SQOutSP(FileName));
Assign(FI,SQOutSP(S));
Reset(FI);
Ok := (IOResult = 0);
IF (Ok) THEN
BEGIN
NewSiz := FileSize(FI);
Close(FI);
END
ELSE
Star('Unable to access "'+SQOutSP(S)+'"');
IF (Ok) THEN
BEGIN
Inc(C_OldSiz,OldSiz);
Inc(C_NewSiz,NewSiz);
Inc(C_Files);
Star('Old total space took up : '+ConvertBytes(OldSiz,FALSE));
Star('New total space taken up : '+ConvertBytes(NewSiz,FALSE));
IF (OldSiz - NewSiz > 0) THEN
Star('Space saved : '+ConvertBytes(OldSiz-NewSiz,FALSE))
ELSE
Star('Space wasted : '+ConvertBytes(NewSiz-OldSiz,FALSE));
END;
END
ELSE
BEGIN
SysOpLog('Unable to convert '+SQOutSP(FileName));
Star('Unable to convert '+SQOutSP(FileName));
END;
END;
WKey;
FindNext(DirInfo);
END;
END
ELSE
BEGIN
NL;
IF (NOT PYNQ('Search all file areas? ',0,FALSE)) THEN
CvtFiles(F,FileArea,FileName,BB,C_Files,C_OldSiz,C_NewSiz)
ELSE
BEGIN
FArea := 1;
WHILE (FArea >= 1) AND (FArea <= NumFileAreas) AND (NOT Abort) AND (NOT HangUp) DO
BEGIN
CvtFiles(F,FArea,FileName,BB,C_Files,C_OldSiz,C_NewSiz);
WKey;
Inc(FArea);
END;
END;
END;
SysOpLog('Conversion process completed at '+DateStr+' '+TimeStr+'.');
NL;
Star('Total archives converted : '+IntToStr(C_Files));
Star('Old total space took up : '+ConvertBytes(C_OldSiz,FALSE));
Star('New total space taken up : '+ConvertBytes(C_NewSiz,FALSE));
IF ((C_OldSiz - C_NewSiz) > 0) THEN
Star('Space saved : '+ConvertBytes((C_OldSiz - C_NewSiz),FALSE))
ELSE
Star('Space wasted : '+ConvertBytes((C_NewSiz - C_OldSiz),FALSE));
SysOpLog('Converted '+IntToStr(C_Files)+' archives; old size='+
ConvertBytes(C_OldSiz,FALSE)+' , new size='+ConvertBytes(C_NewSiz,FALSE));
END;
END;
END;
'M' : BEGIN
Ok := FALSE;
FOR Counter := 1 TO 3 DO
IF (General.FileArcComment[Counter] <> '') THEN
Ok := TRUE;
IF (NOT Ok) THEN
BEGIN
NL;
Print('No comment''s are available.');
PauseScr(FALSE);
Exit;
END;
NL;
Print('Comment field update -');
NL;
Print('Filespec:');
Prt(':');
MPL(78);
Input(FileName,78);
IF (FileName = '') THEN
BEGIN
NL;
Print('Aborted!');
END
ELSE
BEGIN
Abort := FALSE;
Next := FALSE;
IF (IsUL(FileName)) THEN
BEGIN
S := '';
NL;
FOR Counter := 1 TO 3 DO
IF (General.FileArcComment[Counter] <> '') THEN
BEGIN
S := S + IntToStr(Counter);
Print('^1'+IntToStr(Counter)+'. Archive comment file: ^5'+General.FileArcComment[Counter]);
END;
NL;
Prt('Comment to use [0=Quit]: ');
OneK(Cmd,'0'+S,TRUE,TRUE);
IF (Cmd IN ['1'..'3']) THEN
BEGIN
FSplit(FileName,DS,NS,ES);
FindFirst(FileName,AnyFile - Directory - VolumeID - Dos.Hidden - SysFile,DirInfo);
WHILE (DOSError = 0) AND (NOT Abort) AND (NOT HangUp) DO
BEGIN
FileName := FExpand(SQOutSP(DS+DirInfo.Name));
AType := ArcType(FileName);
IF (AType <> 0) THEN
BEGIN
Star('Commenting "'+FileName+'"');
Ok := TRUE;
ArcComment(Ok,AType,(Ord(Cmd) - 48),FileName);
END;
WKey;
FindNext(DirInfo);
END;
END;
END
ELSE
BEGIN
NL;
IF (NOT PYNQ('Search all file areas? ',0,FALSE)) THEN
CmtFiles(F,FileArea,FileName)
ELSE
BEGIN
FArea := 1;
WHILE (FArea >= 1) AND (FArea <= NumFileAreas) AND (NOT Abort) AND (NOT HangUp) DO
BEGIN
CmtFiles(F,FArea,FileName);
WKey;
Inc(FArea);
END;
END;
END;
END;
Cmd := #0;
END;
'T' : BEGIN
NL;
Print('File integrity testing -');
NL;
Print('Filespec:');
Prt(':');
MPL(78);
Input(FileName,78);
IF (FileName = '') THEN
BEGIN
NL;
Print('Aborted!');
END
ELSE
BEGIN
NL;
DelBad := PYNQ('Delete files that don''t pass the test? ',0,FALSE);
NL;
Abort := FALSE;
Next := FALSE;
IF (IsUL(FileName)) THEN
BEGIN
FSplit(FileName,DS,NS,ES);
FindFirst(FileName,AnyFile - Directory - VolumeID - DOS.Hidden - SysFile,DirInfo);
WHILE (DOSError = 0) AND (NOT Abort) AND (NOT HangUp) DO
BEGIN
FileName := FExpand(SQOutSP(DS+DirInfo.Name));
AType := ArcType(FileName);
IF (AType <> 0) THEN
BEGIN
Star('Testing "'+FileName+'"');
Ok := TRUE;
ArcIntegrityTest(Ok,AType,FileName);
IF (Ok) THEN
Star('Passed integrity test.')
ELSE
BEGIN
Star('File "'+FileName+'" didn''t pass integrity test.');
IF (DelBad) THEN
Kill(FileName);
END;
END;
WKey;
FindNext(DirInfo);
END;
END
ELSE
BEGIN
NL;
IF (NOT PYNQ('Search all file areas? ',0,FALSE)) THEN
TestFiles(F,FileArea,FileName,DelBad)
ELSE
BEGIN
FArea := 1;
WHILE (FArea >= 1) AND (FArea <= NumFileAreas) AND (NOT Abort) AND (NOT HangUp) DO
BEGIN
TestFiles(F,FArea,FileName,DelBad);
WKey;
Inc(FArea);
END;
END;
END;
END;
END;
END;
FileArea := SaveFileArea;
LoadFileArea(FileArea);
LastError := IOResult;
END;
END.

244
SOURCE/ARCHIVE3.PAS Normal file
View File

@ -0,0 +1,244 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D-,E-,F+,I-,L-,N-,O+,R-,S+,V-}
UNIT Archive3;
INTERFACE
PROCEDURE ReZipStuff;
IMPLEMENTATION
USES
Dos,
Archive1,
Common,
Execbat,
File0,
File11,
TimeFunc;
PROCEDURE CvtFiles(FArea: Integer; FileName,ReZipCmd: AStr; VAR TotalFiles: SmallInt; VAR TotalOldSize,TotalNewSize: LongInt);
VAR
S: AStr;
DS: DirStr;
NS: NameStr;
ES: ExtStr;
AType: Byte;
ReturnCode,
DirFileRecNum: Integer;
OldSiz,
NewSiz: LongInt;
Ok: Boolean;
BEGIN
IF (FileArea <> FArea) THEN
ChangeFileArea(FArea);
IF (FileArea = FArea) AND (NOT (FACDROM IN MemFileArea.FAFlags)) THEN
BEGIN
RecNo(FileInfo,FileName,DirFileRecNum);
IF (BadDownloadPath) THEN
Exit;
WHILE (DirFileRecNum <> -1) AND (NOT Abort) AND (NOT HangUp) DO
BEGIN
Seek(FileInfoFile,DirFileRecNum);
Read(FileInfoFile,FileInfo);
IF Exist(MemFileArea.DLPath+FileInfo.FileName) THEN
FileName := MemFileArea.DLPath+FileInfo.FileName
ELSE
FileName := MemFileArea.ULPath+FileInfo.FileName;
AType := ArcType(FileName);
IF (AType <> 0) THEN
BEGIN
DisplayFileAreaHeader;
NL;
Star('Converting "'+SQOutSp(FileName)+'"');
Ok := FALSE;
IF (NOT Exist(FileName)) THEN
Star('File "'+SQOutSp(FileName)+'" doesn''t exist.')
ELSE
BEGIN
IF (ReZipCmd <> '') THEN
BEGIN
OldSiz := GetFileSize(FileName);
ExecBatch(Ok,TempDir+'ARC\',ReZipCmd+' '+SQOutSp(FileName),-1,ReturnCode,FALSE);
NewSiz := GetFileSize(FileName);
FileInfo.FileSize := NewSiz;
Seek(FileInfoFile,DirFileRecNum);
Write(FileInfoFile,FileInfo);
END
ELSE
BEGIN
Ok := TRUE;
S := FileName;
OldSiz := GetFileSize(FileName);
ConvA(Ok,AType,AType,SQOutSp(FileName),SQOutSp(S));
IF (Ok) THEN
IF (NOT Exist(SQOutSp(S))) THEN
BEGIN
Star('Unable to access "'+SQOutSp(S)+'"');
SysOpLog('Unable to access '+SQOutSp(S));
Ok := FALSE;
END;
IF (Ok) THEN
BEGIN
FileInfo.FileName := Align(StripName(SQOutSp(S)));
Seek(FileInfoFile,DirFileRecNum);
Write(FileInfoFile,FileInfo);
FSplit(FileName,DS,NS,ES);
FileName := DS+NS+'.#$%';
Kill(FileName);
IF (IOResult <> 0) THEN
BEGIN
Star('Unable to erase '+SQOutSp(FileName));
SysOpLog('Unable to erase '+SQOutSp(FileName));
END;
Ok := Exist(SQOutSp(S));
IF (NOT Ok) THEN
BEGIN
Star('Unable to access '+SQOutSp(S));
SysOpLog('Unable to access '+SQOutSp(S));
END
ELSE
BEGIN
NewSiz := GetFileSize(S);
FileInfo.FileSize := NewSiz;
Seek(FileInfoFile,DirFileRecNum);
Write(FileInfoFile,FileInfo);
ArcComment(Ok,AType,MemFileArea.CmtType,SQOutSp(S));
END;
END
ELSE
BEGIN
SysOpLog('Unable to convert '+SQOutSp(FileName));
Star('Unable to convert '+SQOutSp(FileName));
END;
END;
IF (Ok) THEN
BEGIN
Inc(TotalOldSize,OldSiz);
Inc(TotalNewSize,NewSiz);
Inc(TotalFiles);
Star('Old total space took up : '+ConvertBytes(OldSiz,FALSE));
Star('New total space taken up : '+ConvertBytes(NewSiz,FALSE));
IF ((OldSiz - NewSiz) > 0) THEN
Star('Space saved : '+ConvertBytes(OldSiz - NewSiz,FALSE))
ELSE
Star('Space wasted : '+ConvertBytes(NewSiz - OldSiz,FALSE));
END;
END;
END;
WKey;
NRecNo(FileInfo,DirFileRecNum);
END;
Close(FileInfoFile);
Close(ExtInfoFile);
END;
LastError := IOResult;
END;
PROCEDURE ReZipStuff;
TYPE
TotalsRecordType = RECORD
TotalFiles: SmallInt;
TotalOldSize,
TotalNewSize: LongInt
END;
VAR
TotalsRecord: TotalsRecordType;
FileName: Str12;
ReZipCmd: Str78;
FArea,
SaveFileArea: Integer;
BEGIN
FillChar(TotalsRecord,SizeOf(TotalsRecord),0);
NL;
Print('Re-compress archives -');
NL;
Print('Filespec:');
Prt(':');
MPL(12);
Input(FileName,12);
IF (FileName = '') THEN
BEGIN
NL;
Print('Aborted!');
Exit;
END;
ReZipCmd := '';
NL;
Print('^7Do you wish to use a REZIP external utility?');
IF PYNQ('(such as REZIP.EXE)? (Y/N): ',0,FALSE) THEN
BEGIN
NL;
Print('Enter commandline (example: "REZIP"): ');
Prt(':');
Input(ReZipCmd,78);
IF (ReZipCmd = '') THEN
BEGIN
NL;
Print('Aborted.');
Exit;
END;
END;
NL;
Print('Conversion process initiated: '+DateStr+' '+TimeStr+'.');
SysOpLog('Conversion process initiated: '+DateStr+' '+TimeStr+'.');
NL;
Abort := FALSE;
Next := FALSE;
IF NOT PYNQ('Search all file areas? ',0,FALSE) THEN
CvtFiles(FileArea,FileName,ReZipCmd,TotalsRecord.TotalFiles,TotalsRecord.TotalOldSize,TotalsRecord.TotalNewSize)
ELSE
BEGIN
SaveFileArea := FileArea;
FArea := 1;
WHILE (FArea >= 1) AND (FArea <= NumFileAreas) AND (NOT Abort) AND (NOT HangUp) DO
BEGIN
CvtFiles(FArea,FileName,ReZipCmd,TotalsRecord.TotalFiles,TotalsRecord.TotalOldSize,TotalsRecord.TotalNewSize);
WKey;
Inc(FArea);
END;
FileArea := SaveFileArea;
LoadFileArea(FileArea);
END;
NL;
Print('Conversion process complete at '+DateStr+' '+TimeStr+'.');
SysOpLog('Conversion process complete at '+DateStr+' '+TimeStr+'.');
NL;
Star('Total archives converted : '+IntToStr(TotalsRecord.TotalFiles));
Star('Old total space took up : '+ConvertBytes(TotalsRecord.TotalOldSize,FALSE));
Star('New total space taken up : '+ConvertBytes(TotalsRecord.TotalNewSize,FALSE));
IF ((TotalsRecord.TotalOldSize - TotalsRecord.TotalNewSize) > 0) THEN
Star('Space saved : '+ConvertBytes(TotalsRecord.TotalOldSize - TotalsRecord.TotalNewSize,FALSE))
ELSE
Star('Space wasted : '+ConvertBytes(TotalsRecord.TotalNewSize - TotalsRecord.TotalOldSize,FALSE));
SysOpLog('Converted '+IntToStr(TotalsRecord.TotalFiles)+' archives; old size='+
ConvertBytes(TotalsRecord.TotalOldSize,FALSE)+' , new size='+ConvertBytes(TotalsRecord.TotalNewSize,FALSE));
END;
END.

852
SOURCE/ARCVIEW.PAS Normal file
View File

@ -0,0 +1,852 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S+,V-}
UNIT ArcView;
INTERFACE
USES
Common;
FUNCTION ValidIntArcType(FileName: Str12): Boolean;
PROCEDURE ViewInternalArchive(FileName: AStr);
PROCEDURE ViewDirInternalArchive;
IMPLEMENTATION
USES
Dos,
File0,
File14,
TimeFunc;
CONST
MethodType: ARRAY [0..21] OF STRING[10] =
('Directory ', {* Directory marker *}
'Unknown! ', {* Unknown compression type *}
'Stored ', {* No compression *}
'Packed ', {* Repeat-Byte compression *}
'Squeezed ', {* Huffman with repeat-Byte compression *}
'crunched ', {* Obsolete LZW compression *}
'Crunched ', {* LZW 9-12 bit with repeat-Byte compression *}
'Squashed ', {* LZW 9-13 bit compression *}
'Crushed ', {* LZW 2-13 bit compression *}
'Shrunk ', {* LZW 9-13 bit compression *}
'Reduced 1 ', {* Probabilistic factor 1 compression *}
'Reduced 2 ', {* Probabilistic factor 2 compression *}
'Reduced 3 ', {* Probabilistic factor 3 compression *}
'Reduced 4 ', {* Probabilistic factor 4 compression *}
'Frozen ', {* Modified LZW/Huffman compression *}
'Imploded ', {* Shannon-Fano tree compression *}
'Compressed',
'Method 1 ',
'Method 2 ',
'Method 3 ',
'Method 4 ',
'Deflated ');
TYPE
ArcRecordType = RECORD {* structure of ARC archive file header *}
FileName: ARRAY [0..12] OF Char; {* FileName *}
C_Size: LongInt; {* compressed size *}
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: 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: SmallInt; {* FileName Length *}
E_Length: SmallInt; {* extra field Length *}
END;
ZooRecordType = RECORD {* structure of ZOO archive file header *}
Tag: LongInt; {* Tag -- redundancy check *}
Typ: Byte; {* TYPE of directory entry (always 1 for now) *}
Method: Byte; {* 0 = Stored, 1 = Crunched *}
Next: LongInt; {* position of Next directory entry *}
Offset: LongInt; {* position of this file *}
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 *}
Minor_V: Char; {* minor Version number *}
Deleted: Byte; {* 0 = active, 1 = Deleted *}
Struc: Char; {* file structure if any *}
Comment: LongInt; {* location of file Comment (0 = none) *}
Cmt_Size: SmallWord; {* Length of Comment (0 = none) *}
FName: ARRAY [0..12] OF Char; {* FileName *}
Var_DirLen: SmallInt; {* Length of variable part of dir entry *}
TZ: Char; {* timezone where file was archived *}
Dir_Crc: SmallWord; {* CRC of directory entry *}
END;
LZHRecordType = RECORD {* structure of LZH archive file header *}
H_Length: Byte; {* Length of header *}
H_Cksum: Byte; {* checksum of header bytes *}
Method: ARRAY [1..5] OF Char; {* compression TYPE "-lh#-" *}
C_Size: LongInt; {* compressed size *}
U_Size: LongInt; {* uncompressed size *}
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: SmallInt; {* CRC *}
END;
ARJRecordType = RECORD
FirstHdrSize: Byte;
ARJVersion: Byte;
ARJRequired: Byte;
HostOS: Byte;
Flags: Byte;
Method: Byte;
FileType: Byte;
GarbleMod: Byte;
Time,
Date: SmallInt;
CompSize: LongInt;
OrigSize: LongInt;
OrigCRC: ARRAY[1..4] OF Byte;
EntryName: SmallWord;
AccessMode: SmallWord;
HostData: SmallWord;
END;
OutRec = RECORD {* output information structure *}
FileName: AStr; {* output file name *}
Date, {* output Date *}
Time, {* output Time *}
Method: SmallInt; {* output storage type *}
CSize, {* output compressed size *}
USize: LongInt; {* output uncompressed size *}
END;
PROCEDURE AbEnd(VAR Aborted: Boolean);
BEGIN
NL;
Print('^7** ^5Error processing archive^7 **');
Aborted := TRUE;
Abort := TRUE;
Next := TRUE;
END;
PROCEDURE Details(Out: OutRec;
VAR Level,
NumFiles: Integer;
VAR TotalCompSize,
TotalUnCompSize: LongInt);
VAR
OutP: AStr;
AMPM: Str2;
DT: DateTime;
Ratio: LongInt;
BEGIN
Out.FileName := AllCaps(Out.FileName);
DT.Day := Out.Date AND $1f; {* Day = bits 4-0 *}
DT.Month := (Out.Date SHR 5) AND $0f; {* Month = bits 8-5 *}
DT.Year := ((Out.Date SHR 9) AND $7f) + 80; {* Year = bits 15-9 *}
DT.Min := (Out.Time SHR 5) AND $3f; {* Minute = bits 10-5 *}
DT.Hour := (Out.Time SHR 11) AND $1f; {* Hour = bits 15-11 *}
IF (DT.Month > 12) THEN
Dec(DT.Month,12); {* adjust for Month > 12 *}
IF (DT.Year > 99) THEN
Dec(DT.Year,100); {* adjust for Year > 1999 *}
IF (DT.Hour > 23) THEN
Dec(DT.Hour,24); {* adjust for Hour > 23 *}
IF (DT.Min > 59) THEN
Dec(DT.Min,60); {* adjust for Minute > 59 *}
ConvertAmPm(DT.Hour,AmPm);
IF (Out.USize = 0) THEN
Ratio := 0
ELSE {* Ratio is 0% for null-Length file *}
Ratio := (100 - ((Out.CSize * 100) DIV Out.USize));
IF (Ratio > 99) THEN
Ratio := 99;
OutP := '^4'+PadRightStr(FormatNumber(Out.USize),13)+
' '+PadRightStr(FormatNumber(Out.CSize),13)+
' '+PadRightInt(Ratio,2)+'%'+
' ^9'+MethodType[Out.Method]+
' ^7'+ZeroPad(IntToStr(DT.Month))+
'/'+ZeroPad(IntToStr(DT.Day))+
'/'+ZeroPad(IntToStr(DT.Year))+
' '+ZeroPad(IntToStr(DT.Hour))+
':'+ZeroPad(IntToStr(DT.Min))+
AMPM[1]+' ^5';
IF (Level > 0) THEN
OutP := OutP + PadRightStr('',Level); {* spaces for dirs (ARC only)*}
OutP := OutP + Out.FileName;
PrintACR(OutP);
IF (Out.Method = 0) THEN
Inc(Level) {* bump dir Level (ARC only) *}
ELSE
BEGIN
Inc(TotalCompSize,Out.CSize); {* adjust accumulators and counter *}
Inc(TotalUnCompSize,Out.USize);
Inc(NumFiles);
END;
END;
PROCEDURE Final(NumFiles: Integer;
TotalCompSize,
TotalUnCompSize: LongInt);
VAR
OutP: AStr;
Ratio: LongInt;
BEGIN
IF (TotalUnCompSize = 0) THEN
Ratio := 0
ELSE
Ratio := (100 - ((TotalCompSize * 100) DIV TotalUnCompSize));
IF (Ratio > 99) THEN
Ratio := 99;
OutP := '^4'+PadRightStr(FormatNumber(TotalUnCompSize),13)+
' '+PadRightStr(FormatNumber(TotalCompSize),13)+
' '+PadRightInt(Ratio,2)+
'% ^5'+IntToStr(NumFiles)+' '+Plural('file',NumFiles);
PrintACR('^4------------- ------------- --- ------------');
PrintACR(OutP);
END;
FUNCTION GetByte(VAR F: FILE; VAR Aborted: Boolean): Char;
VAR
C: Char;
NumRead: Word;
BEGIN
IF (NOT Aborted) THEN
BEGIN
BlockRead(F,C,1,NumRead);
IF (NumRead = 0) THEN
BEGIN
Close(F);
AbEnd(Aborted);
END;
GetByte := C;
END;
END;
PROCEDURE ZIP_Proc(VAR F: FILE;
VAR Out: OutRec;
VAR Level,
NumFiles: Integer;
VAR TotalCompSize,
TotalUnCompSize: LongInt;
VAR Aborted: Boolean);
VAR
ZIP: ZipRecordType;
C: Char;
Counter: Integer;
NumRead: Word;
Signature: LongInt;
BEGIN
WHILE (NOT Aborted) DO
BEGIN
BlockRead(F,Signature,4,NumRead);
IF (Signature = $02014b50) OR (Signature = $06054b50) THEN
Exit;
IF (NumRead <> 4) OR (Signature <> $04034b50) THEN
BEGIN
AbEnd(Aborted);
Exit;
END;
BlockRead(F,ZIP,26,NumRead);
IF (NumRead <> 26) THEN
BEGIN
AbEnd(Aborted);
Exit;
END;
FOR Counter := 1 TO ZIP.F_Length DO
Out.FileName[Counter] := GetByte(F,Aborted);
Out.FileName[0] := Chr(ZIP.F_Length);
FOR Counter := 1 TO ZIP.E_Length DO
C := GetByte(F,Aborted);
Out.Date := ZIP.Mod_Date;
Out.Time := ZIP.Mod_Time;
Out.CSize := ZIP.C_Size;
Out.USize := ZIP.U_Size;
CASE ZIP.Method OF
0 : Out.Method := 2;
1 : Out.Method := 9;
2,3,4,5 :
Out.Method := (ZIP.Method + 8);
6 : Out.Method := 15;
8 : Out.Method := 21;
ELSE
Out.Method := 1;
END;
Details(Out,Level,NumFiles,TotalCompSize,TotalUnCompSize);
IF (Abort) THEN
Exit;
Seek(F,(FilePos(F) + ZIP.C_Size));
IF (IOResult <> 0) THEN
AbEnd(Aborted);
IF (Abort) THEN
Exit;
END;
END;
PROCEDURE ARJ_Proc(VAR ArjFile: FILE;
VAR Out: OutRec;
VAR Level,
NumFiles: Integer;
VAR TotalCompSize,
TotalUnCompSize: LongInt;
VAR Aborted: Boolean);
TYPE
ARJSignature = RECORD
MagicNumber: SmallWord;
BasicHdrSiz: SmallWord;
END;
VAR
Hdr: ARJRecordType;
Sig: ARJSignature;
FileName,
FileTitle: AStr;
JunkByte: Byte;
Counter: Integer;
NumRead,
ExtSize: Word;
HeaderCrc: LongInt;
BEGIN
BlockRead(ArjFile,Sig,SizeOf(Sig));
IF (IOResult <> 0) OR (Sig.MagicNumber <> $EA60) THEN
Exit
ELSE
BEGIN
BlockRead(ArjFile,Hdr,SizeOf(Hdr),NumRead);
Counter := 0;
REPEAT
Inc(Counter);
BlockRead(ArjFile,FileName[Counter],1);
UNTIL (FileName[Counter] = #0);
FileName[0] := Chr(Counter - 1);
REPEAT
BlockRead(ArjFile,JunkByte,1);
UNTIL (JunkByte = 0);
BlockRead(ArjFile,HeaderCRC,4);
BlockRead(ArjFile,ExtSize,2);
IF (ExtSize > 0) THEN
Seek(ArjFile,FilePos(ArjFile) + ExtSize + 4);
BlockRead(ArjFile,Sig,SizeOf(Sig));
WHILE (Sig.BasicHdrSiz > 0) AND (NOT Abort) AND (IOResult = 0) DO
BEGIN
BlockRead(ArjFile,Hdr,SizeOf(Hdr),NumRead);
Counter := 0;
REPEAT
Inc(Counter);
BlockRead(ArjFile,FileName[Counter],1);
UNTIL (FileName[Counter] = #0);
FileName[0] := Chr(Counter - 1);
Out.FileName := FileName;
Out.Date := Hdr.Date;
Out.Time := Hdr.Time;
IF (Hdr.Method = 0) THEN
Out.Method := 2
ELSE
Out.Method := (Hdr.Method + 16);
Out.CSize := Hdr.CompSize;
Out.USize := Hdr.OrigSize;
Details(Out,Level,NumFiles,TotalCompSize,TotalUnCompSize);
IF (Abort) THEN
Exit;
REPEAT
BlockRead(ArjFile,JunkByte,1);
UNTIL (JunkByte = 0);
BlockRead(ArjFile,HeaderCRC,4);
BlockRead(ArjFile,ExtSize,2);
Seek(ArjFile,(FilePos(ArjFile) + Hdr.CompSize));
BlockRead(ArjFile,Sig,SizeOf(Sig));
END;
END;
END;
PROCEDURE ARC_Proc(VAR F: FILE;
VAR Out: OutRec;
VAR Level,
NumFiles: Integer;
VAR TotalCompSize,
TotalUnCompSize: LongInt;
VAR Aborted: Boolean);
VAR
Arc: ArcRecordType;
C: Char;
Counter,
Method: Integer;
NumRead: Word;
BEGIN
REPEAT
C := GetByte(F,Aborted);
Method := Ord(GetByte(F,Aborted));
CASE Method OF
0 : Exit;
1,2 :
Out.Method := 2;
3,4,5,6,7 :
Out.Method := Method;
8,9,10 :
Out.Method := (Method - 2);
30 : Out.Method := 0;
31 : Dec(Level);
ELSE
Out.Method := 1;
END;
IF (Method <> 31) THEN
BEGIN
BlockRead(F,Arc,23,NumRead);
IF (NumRead <> 23) THEN
BEGIN
AbEnd(Aborted);
Exit;
END;
IF (Method = 1) THEN
Arc.U_Size := Arc.C_Size
ELSE
BEGIN
BlockRead(F,Arc.U_Size,4,NumRead);
IF (NumRead <> 4) THEN
BEGIN
AbEnd(Aborted);
Exit;
END;
END;
Counter := 0;
REPEAT
Inc(Counter);
Out.FileName[Counter] := Arc.FileName[Counter - 1];
UNTIL (Arc.FileName[Counter] = #0) OR (Counter = 13);
Out.FileName[0] := Chr(Counter);
Out.Date := Arc.Mod_Date;
Out.Time := Arc.Mod_Time;
IF (Method = 30) THEN
BEGIN
Arc.C_Size := 0;
Arc.U_Size := 0;
END;
Out.CSize := Arc.C_Size;
Out.USize := Arc.U_Size;
Details(Out,Level,NumFiles,TotalCompSize,TotalUnCompSize);
IF (Abort) THEN
Exit;
IF (Method <> 30) THEN
BEGIN
Seek(F,(FilePos(F) + Arc.C_Size));
IF (IOResult <> 0) THEN
BEGIN
AbEnd(Aborted);
Exit;
END;
END;
END;
UNTIL (C <> #$1a) OR (Aborted);
IF (NOT Aborted) THEN
AbEnd(Aborted);
END;
PROCEDURE ZOO_Proc(VAR F: FILE;
VAR Out: OutRec;
VAR Level,
NumFiles: Integer;
VAR TotalCompSize,
TotalUnCompSize: LongInt;
VAR Aborted: Boolean);
VAR
ZOO: ZooRecordType;
ZOO_LongName,
ZOO_DirName: AStr;
C: Char;
NamLen,
DirLen: Byte;
Counter,
Method: Integer;
NumRead: Word;
ZOO_Temp,
ZOO_Tag: LongInt;
BEGIN
FOR Counter := 0 TO 19 DO
C := GetByte(F,Aborted);
BlockRead(F,ZOO_Tag,4,NumRead);
IF (NumRead <> 4) THEN
AbEnd(Aborted);
IF (ZOO_Tag <> $fdc4a7dc) THEN
AbEnd(Aborted);
BlockRead(F,ZOO_Temp,4,NumRead);
IF (NumRead <> 4) THEN
AbEnd(Aborted);
Seek(F,ZOO_Temp);
IF (IOResult <> 0) THEN
AbEnd(Aborted);
WHILE (NOT Aborted) DO
BEGIN
BlockRead(F,ZOO,56,NumRead);
IF (NumRead <> 56) THEN
BEGIN
AbEnd(Aborted);
Exit;
END;
IF (ZOO.Tag <> $fdc4a7dc) THEN
AbEnd(Aborted);
IF (Abort) OR (ZOO.Next = 0) THEN
Exit;
NamLen := Ord(GetByte(F,Aborted));
DirLen := Ord(GetByte(F,Aborted));
ZOO_LongName := '';
ZOO_DirName := '';
IF (NamLen > 0) THEN
FOR Counter := 1 TO NamLen DO
ZOO_LongName := ZOO_LongName + GetByte(F,Aborted);
IF (DirLen > 0) THEN
BEGIN
FOR Counter := 1 TO DirLen DO
ZOO_DirName := ZOO_DirName + GetByte(F,Aborted);
IF (ZOO_DirName[Length(ZOO_DirName)] <> '/') THEN
ZOO_DirName := ZOO_DirName + '/';
END;
IF (ZOO_LongName <> '') THEN
Out.FileName := ZOO_LongName
ELSE
BEGIN
Counter := 0;
REPEAT
Inc(Counter);
Out.FileName[Counter] := ZOO.FName[Counter - 1];
UNTIL (ZOO.FName[Counter] = #0) OR (Counter = 13);
Out.FileName[0] := Chr(Counter);
Out.FileName := ZOO_DirName+Out.FileName;
END;
Out.Date := ZOO.Mod_Date;
Out.Time := ZOO.Mod_Time;
Out.CSize := ZOO.C_Size;
Out.USize := ZOO.U_Size;
Method := ZOO.Method;
CASE Method OF
0 : Out.Method := 2;
1 : Out.Method := 6;
ELSE
Out.Method := 1;
END;
IF NOT (ZOO.Deleted = 1) THEN
Details(Out,Level,NumFiles,TotalCompSize,TotalUnCompSize);
IF (Abort) THEN
Exit;
Seek(F,ZOO.Next);
IF (IOResult <> 0) THEN
BEGIN
AbEnd(Aborted);
Exit;
END;
END;
END;
PROCEDURE LZH_Proc(VAR F: FILE;
VAR Out: OutRec;
VAR Level,
NumFiles: Integer;
VAR TotalCompSize,
TotalUnCompSize: LongInt;
VAR Aborted: Boolean);
VAR
LZH: LZHRecordType;
C,
Method: Char;
Counter: Integer;
NumRead: Word;
BEGIN
WHILE (NOT Aborted) DO
BEGIN
C := GetByte(F,Aborted);
IF (C = #0) THEN
Exit
ELSE
LZH.H_Length := Ord(C);
C := GetByte(F,Aborted);
LZH.H_Cksum := Ord(C);
BlockRead(F,LZH.Method,5,NumRead);
IF (NumRead <> 5) THEN
BEGIN
AbEnd(Aborted);
Exit;
END;
IF ((LZH.Method[1] <> '-') OR (LZH.Method[2] <> 'l') OR (LZH.Method[3] <> 'h')) THEN
BEGIN
AbEnd(Aborted);
Exit;
END;
BlockRead(F,LZH.C_Size,15,NumRead);
IF (NumRead <> 15) THEN
BEGIN
AbEnd(Aborted);
Exit;
END;
FOR Counter := 1 TO LZH.F_Length DO
Out.FileName[Counter] := GetByte(F,Aborted);
Out.FileName[0] := Chr(LZH.F_Length);
IF ((LZH.H_Length - LZH.F_Length) = 22) THEN
BEGIN
BlockRead(F,LZH.CRC,2,NumRead);
IF (NumRead <> 2) THEN
BEGIN
AbEnd(Aborted);
Exit;
END;
END;
Out.Date := LZH.Mod_Date;
Out.Time := LZH.Mod_Time;
Out.CSize := LZH.C_Size;
Out.USize := LZH.U_Size;
Method := LZH.Method[4];
CASE Method OF
'0' : Out.Method := 2;
'1' : Out.Method := 14;
ELSE
Out.Method := 1;
END;
Details(Out,Level,NumFiles,TotalCompSize,TotalUnCompSize);
Seek(F,(FilePos(F) + LZH.C_Size));
IF (IOResult <> 0) THEN
AbEnd(Aborted);
IF (Abort) THEN
Exit;
END;
END;
FUNCTION ValidIntArcType(FileName: Str12): Boolean;
CONST
ArcTypes: ARRAY [1..7] OF Str3 = ('ZIP','ARC','PAK','ZOO','LZH','ARK','ARJ');
VAR
Counter: Byte;
BEGIN
ValidIntArcType := FALSE;
FOR Counter := 1 TO 7 DO
IF (ArcTypes[Counter] = AllCaps(Copy(FileName,(Pos('.',FileName) + 1),3))) THEN
ValidIntArcType := TRUE;
END;
PROCEDURE ViewInternalArchive(FileName: AStr);
VAR
LZH_Method: ARRAY [1..5] OF Char;
F: FILE;
(*
DirInfo: SearchRec;
*)
Out: OutRec;
C: Char;
LZH_H_Length,
Counter,
ArcType: Byte;
RCode,
FileType,
Level,
NumFiles: Integer;
NumRead: Word;
TotalUnCompSize,
TotalCompSize: LongInt;
Aborted: Boolean;
BEGIN
FileName := SQOutSp(FileName);
IF (Pos('*',FileName) <> 0) OR (Pos('?',FileName) <> 0) THEN
BEGIN
FindFirst(FileName,AnyFile - Directory - VolumeID - Hidden - SysFile,DirInfo);
IF (DOSError = 0) THEN
FileName := DirInfo.Name;
END;
IF ((Exist(FileName)) AND (NOT Abort) AND (NOT HangUp)) THEN
BEGIN
ArcType := 1;
WHILE (General.FileArcInfo[ArcType].Ext <> '') AND
(General.FileArcInfo[ArcType].Ext <> Copy(FileName,(Length(FileName) - 2),3)) AND
(ArcType < MaxArcs + 1) DO
Inc(ArcType);
IF NOT ((General.FileArcInfo[ArcType].Ext = '') OR (ArcType = 7)) THEN
BEGIN
IF (General.FileArcInfo[ArcType].ListLine[1] = '/') AND
(General.FileArcInfo[ArcType].ListLine[2] IN ['1'..'5']) AND
(Length(General.FileArcInfo[ArcType].ListLine) = 2) THEN
BEGIN
Aborted := FALSE;
Abort := FALSE;
Next := FALSE;
NL;
PrintACR('^3'+StripName(FileName)+':');
NL;
IF (NOT Abort) THEN
BEGIN
Assign(F,FileName);
Reset(F,1);
C := GetByte(F,Aborted);
CASE C OF
#$1a : FileType := 1;
'P' : BEGIN
IF (GetByte(F,Aborted) <> 'K') THEN
AbEnd(Aborted);
FileType := 2;
END;
'Z' : BEGIN
FOR Counter := 0 TO 1 DO
IF (GetByte(F,Aborted) <> 'O') THEN
AbEnd(Aborted);
FileType := 3;
END;
#96 : BEGIN
IF (GetByte(F,Aborted) <> #234) THEN
AbEnd(Aborted);
FileType := 5;
END;
ELSE
BEGIN
LZH_H_Length := Ord(C);
C := GetByte(F,Aborted);
FOR Counter := 1 TO 5 DO
LZH_Method[Counter] := GetByte(F,Aborted);
IF ((LZH_Method[1] = '-') AND (LZH_Method[2] = 'l') AND (LZH_Method[3] = 'h')) THEN
FileType := 4
ELSE
AbEnd(Aborted);
END;
END;
Reset(F,1);
Level := 0;
NumFiles := 0;
TotalCompSize := 0;
TotalUnCompSize := 0;
AllowContinue := TRUE;
PrintACR('^3 Length Size Now % Method Date Time FileName');
PrintACR('^4------------- ------------- --- ---------- -------- ------ ------------');
CASE FileType OF
1 : ARC_Proc(F,Out,Level,NumFiles,TotalCompSize,TotalUnCompSize,Aborted);
2 : ZIP_Proc(F,Out,Level,NumFiles,TotalCompSize,TotalUnCompSize,Aborted);
3 : ZOO_Proc(F,Out,Level,NumFiles,TotalCompSize,TotalUnCompSize,Aborted);
4 : LZH_Proc(F,Out,Level,NumFiles,TotalCompSize,TotalUnCompSize,Aborted);
5 : ARJ_Proc(F,Out,Level,NumFiles,TotalCompSize,TotalUnCompSize,Aborted);
END;
Final(NumFiles,TotalCompSize,TotalUnCompSize);
Close(F);
AllowContinue := FALSE;
END;
END
ELSE
BEGIN
NL;
Prompt('^3Archive '+FileName+': ^4Please wait....');
ShellDOS(FALSE,FunctionalMCI(General.FileArcInfo[ArcType].ListLine,FileName,'')+' >shell.$$$',RCode);
BackErase(15);
PFL('SHELL.$$$');
Kill('SHELL.$$$');
END;
END;
END;
END;
PROCEDURE ViewDirInternalArchive;
VAR
FileName: Str12;
DirFileRecNum: Integer;
Found,
LastArc,
LastGif: Boolean;
BEGIN
{
NL;
Print('^9Enter the name of the archive(s) you would like to view:');
}
lRGLngStr(25,FALSE);
FileName := '';
{ Print(FString.lGFNLine1); }
lRGLngStr(28,FALSE);
{ Prt(FString.GFNLine2); }
lRGLngStr(29,FALSE);
GetFileName(FileName);
LastArc := FALSE;
LastGif := FALSE;
AllowContinue := TRUE;
Found := FALSE;
Abort := FALSE;
Next := FALSE;
RecNo(FileInfo,FileName,DirFileRecNum);
IF (BadDownloadPath) THEN
Exit;
WHILE (DirFileRecNum <> -1) AND (NOT Abort) AND (NOT HangUp) DO
BEGIN
Seek(FileInfoFile,DirFileRecNum);
Read(FileInfoFile,FileInfo);
IF IsGIFExt(FileInfo.FileName) THEN
BEGIN
LastArc := FALSE;
IF (NOT LastGif) THEN
BEGIN
LastGif := TRUE;
NL;
PrintACR('^3Filename.Ext^4:^3Resolution ^4:^3Num Colors^4:^3Signature');
PrintACR('^4============:===========:==========:===============');
END;
IF Exist(MemFileArea.DLPath+FileInfo.FileName) THEN
BEGIN
PrintACR(GetGIFSpecs(MemFileArea.DLPath+SQOutSp(FileInfo.FileName),FileInfo.Description,1));
Found := TRUE;
END
ELSE
BEGIN
PrintACR(GetGIFSpecs(MemFileArea.ULPath+SQOutSp(FileInfo.FileName),FileInfo.Description,1));
Found := TRUE;
END;
END
ELSE IF ValidIntArcType(FileInfo.FileName) THEN
BEGIN
LastGif := FALSE;
IF (NOT LastArc) THEN
LastArc := TRUE;
IF Exist(MemFileArea.DLPath+FileInfo.FileName) THEN
BEGIN
ViewInternalArchive(MemFileArea.DLPath+FileInfo.FileName);
Found := TRUE;
END
ELSE
BEGIN
ViewInternalArchive(MemFileArea.ULPath+FileInfo.FileName);
Found := TRUE;
END;
END;
WKey;
NRecNo(FileInfo,DirFileRecNum);
END;
Close(FileInfoFile);
Close(ExtInfoFile);
AllowContinue := FALSE;
IF (NOT Found) THEN
BEGIN
NL;
Print('File not found.');
END;
LastError := IOResult;
END;
END.

163
SOURCE/AUTOMSG.PAS Normal file
View File

@ -0,0 +1,163 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S+,V-}
UNIT AutoMsg;
INTERFACE
PROCEDURE ReadAutoMsg;
PROCEDURE WriteAutoMsg;
PROCEDURE ReplyAutoMsg;
IMPLEMENTATION
USES
Common,
Email,
Mail0,
Mail1;
PROCEDURE ReadAutoMsg;
VAR
AutoMsgFile: Text;
TempStr: AStr;
Counter,
LenTempStr: Byte;
BEGIN
Assign(AutoMsgFile,General.MiscPath+'AUTO.ASC');
Reset(AutoMsgFile);
IF (IOResult <> 0) THEN
Print('%LFNo auto-message available.')
ELSE
BEGIN
ReadLn(AutoMsgFile,TempStr);
CASE TempStr[1] OF
'@' : IF (AACS(General.AnonPubRead)) THEN
TempStr := Copy(TempStr,2,Length(TempStr))+' (Posted Anonymously)'
ELSE
TempStr := 'Anonymous';
'!' : IF (CoSysOp) THEN
TempStr := Copy(TempStr,2,Length(TempStr))+' (Posted Anonymously)'
ELSE
TempStr := 'Anonymous';
END;
NL;
Print(lRGLngStr(10,TRUE){FString.AutoMsgT}+TempStr);
LenTempStr := 0;
REPEAT
ReadLn(AutoMsgFile,TempStr);
IF (LennMCI(TempStr) > LenTempStr) THEN
LenTempStr := LennMCI(TempStr);
UNTIL (EOF(AutoMsgFile));
IF (LenTempStr >= ThisUser.LineLen) THEN
LenTempStr := (ThisUser.LineLen - 1);
Reset(AutoMsgFile);
ReadLn(AutoMsgFile,TempStr);
TempStr := lRGLngStr(11,TRUE);
UserColor(0);
IF ((NOT OkANSI) AND (NOT OkAvatar) AND (Ord(TempStr[1]{FString.AutoM}) > 128) OR (TempStr[1]{FString.AutoM} = #32)) THEN
NL
ELSE
BEGIN
FOR Counter := 1 TO LenTempStr DO
OutKey(TempStr[1]{FString.AutoM});
NL;
END;
REPEAT
ReadLn(AutoMsgFile,TempStr);
PrintACR('^3'+TempStr);
UNTIL EOF(AutoMsgFile) OR (Abort) OR (HangUp);
Close(AutoMsgFile);
TempStr := lRGLngStr(11,TRUE);
UserColor(0);
IF ((NOT OkANSI) AND (NOT OkAvatar) AND (Ord(TempStr[1]{FString.AutoM}) > 128) OR (TempStr[1]{FString.AutoM} = #32)) THEN
NL
ELSE
BEGIN
FOR Counter := 1 TO LenTempStr DO
OutKey(TempStr[1]{FString.AutoM});
NL;
END;
PauseScr(FALSE);
END;
LastError := IOResult;
END;
PROCEDURE WriteAutoMsg;
VAR
AutoMsgFile1,
AutoMsgFile2: Text;
MHeader: MHeaderRec;
TempStr: AStr;
BEGIN
IF (RAMsg IN ThisUser.Flags) THEN
Print('%LFYou are restricted from writing auto-messages.')
ELSE
BEGIN
InResponseTo := '';
MHeader.Status := [];
IF (InputMessage(TRUE,FALSE,'Auto-Message',MHeader,General.MiscPath+'AUTO'+IntToStr(ThisNode)+'.TMP',78,500)) THEN
IF Exist(General.MiscPath+'AUTO'+IntToStr(ThisNode)+'.TMP') THEN
BEGIN
Assign(AutoMsgFile1,General.MiscPath+'AUTO.ASC');
ReWrite(AutoMsgFile1);
Assign(AutoMsgFile2,General.MiscPath+'AUTO'+IntToStr(ThisNode)+'.TMP');
Reset(AutoMsgFile2);
IF (IOResult <> 0) THEN
Exit;
IF (AACS(General.AnonPubPost)) AND PYNQ('Post Anonymously? ',0,FALSE) THEN
IF (CoSysOp) THEN
WriteLn(AutoMsgFile1,'!'+Caps(ThisUser.Name))
ELSE
WriteLn(AutoMsgFile1,'@'+Caps(ThisUser.Name))
ELSE
WriteLn(AutoMsgFile1,Caps(ThisUser.Name));
WHILE (NOT EOF(AutoMsgFile2)) DO
BEGIN
ReadLn(AutoMsgFile2,TempStr);
WriteLn(AutoMsgFile1,TempStr);
END;
Close(AutoMsgFile1);
Close(AutoMsgFile2);
Kill(General.MiscPath+'AUTO'+IntToStr(ThisNode)+'.TMP');
END;
END;
END;
PROCEDURE ReplyAutoMsg;
VAR
AutoMsgFile: Text;
MHeader: MHeaderRec;
TempStr: AStr;
BEGIN
Assign(AutoMsgFile,General.MiscPath+'AUTO.ASC');
Reset(AutoMsgFile);
IF (IOResult <> 0) THEN
Print('%LFNo auto-message to reply to.')
ELSE
BEGIN
ReadLn(AutoMsgFile,TempStr);
Close(AutoMsgFile);
IF (TempStr[1] IN ['!','@']) THEN
BEGIN
LastAuthor := SearchUser(Copy(TempStr,2,Length(TempStr)),CoSysOp);
IF (NOT AACS(General.AnonPrivRead)) THEN
LastAuthor := 0;
END
ELSE
LastAuthor := SearchUser(TempStr,CoSysOp);
IF (LastAuthor = 0) THEN
Print('%LFUnable to reply to an anonymous message!')
ELSE
BEGIN
InResponseTo := 'Your auto-message';
MHeader.Status := [];
AutoReply(MHeader);
END;
END;
END;
END.

779
SOURCE/BBSLIST.PAS Normal file
View File

@ -0,0 +1,779 @@
{$A+,B-,D-,E-,F+,I-,L-,N-,O+,R-,S+,V-}
UNIT BBSList;
INTERFACE
PROCEDURE BBSList_Add;
PROCEDURE BBSList_Delete;
PROCEDURE BBSList_Edit;
PROCEDURE BBSList_View;
PROCEDURE BBSList_xView;
IMPLEMENTATION
USES
Common,
TimeFunc;
FUNCTION BBSListMCI(CONST S: ASTR; Data1,Data2: Pointer): STRING;
VAR
BBSListPtr: ^BBSListRecordType;
User: UserRecordType;
TmpStr : String;
BEGIN
BBSListPtr := Data1;
BBSListMCI := S;
CASE S[1] OF
'X' : CASE S[2] OF
'A' : BBSListMCI := BBSListPtr^.SDA;
'B' : BBSListMCI := BBSListPtr^.SDB;
'C' : BBSListMCI := BBSListPtr^.SDC;
'D' : BBSListMCI := BBSListPtr^.SDD;
'E' : BBSListMCI := BBSListPtr^.SDE;
'F' : BBSListMCI := BBSListPtr^.SDF;
END;
'A' : CASE S[2] OF
'C' :
Begin
If (Length(BBSListPtr^.PhoneNumber) > 0) Then
Begin
TmpStr := BBSListPtr^.PhoneNumber;
Delete(TmpStr,4,Length(TmpStr));
BBSListMCI := TmpStr;
End
Else
Begin
BBSListMCI := 'N/A';
End;
End;
END;
'B' : CASE S[2] OF
'N' : BBSListMCI := BBSListPtr^.BBSName;
'P' : BBSListMCI := IntToStr(BBSListPtr^.Port);
END;
'D' : CASE S[2] OF
'A' : BBSListMCI := Pd2Date(BBSListPtr^.DateAdded);
'E' : BBSListMCI := Pd2Date(BBSListPtr^.DateEdited);
'S' : BBSListMCI := BBSListPtr^.Description;
'2' : BBSListMCI := BBSListPtr^.Description2
END;
'L' : CASE S[2] OF
'O' : BBSListMCI := BBSListPtr^.Location;
END;
'H' : CASE S[2] OF
'R' : BBSListMCI := BBSListPtr^.Hours;
END;
'M' : CASE S[2] OF
'N' : BBSListMCI := IntToStr(BBSListPtr^.MaxNodes);
END;
'O' : CASE S[2] OF
'S' : Begin
If (Length(BBSListPtr^.OS) > 0) Then
BBSListMCI := BBSListPtr^.OS
Else
BBSListMCI := 'Unknown';
End;
END;
'P' : CASE S[2] OF
'N' : Begin
If (Length(BBSListPtr^.PhoneNumber) > 0) Then
BBSListMCI := BBSListPtr^.PhoneNumber
Else
BBSListMCI := 'None';
End;
END;
'R' : CASE S[2] OF
'N' : BBSListMCI := IntToStr(BBSListPtr^.RecordNum);
END;
'S' : CASE S[2] OF
'A' : BBSListMCI := BBSListPtr^.SDA;
'B' : BBSListMCI := BBSListPtr^.SDB;
'C' : BBSListMCI := BBSListPtr^.SDC;
'D' : BBSListMCI := BBSListPtr^.SDD;
'E' : BBSListMCI := BBSListPtr^.SDE;
'F' : BBSListMCI := BBSListPtr^.SDF;
'G' : BBSListMCI := IntToStr(BBSListPtr^.SDG);
'H' : BBSListMCI := ShowYesNo(BBSListPtr^.SDH);
'I' : BBSListMCI := ShowYesNo(BBSListPtr^.SDI);
'N' : BBSListMCI := BBSListPtr^.SysOpName;
'P' : BBSListMCI := BBSListPtr^.Speed;
'T' : Begin
IF (Length(BBSListPtr^.Birth) > 0) THEN
BBSListMCI := BBSListPtr^.Birth
ELSE
BBSListMCI := 'Unknown';
End;
'V' : Begin
If (Length(BBSListPtr^.SoftwareVersion) > 0) Then
Begin
BBSListMCI := BBSListPtr^.SoftwareVersion;
End
Else
Begin
BBSListMCI := 'Unknown';
End;
End;
'W' : BBSListMCI := BBSListPtr^.Software;
END;
'T' : CASE S[2] OF
'N' : BBSListMCI := BBSListPtr^.TelnetUrl;
END;
'U' : CASE S[2] OF
'N' : BEGIN
LoadURec(User,BBSListPtr^.UserID);
BBSListMCI := User.Name;
END;
END;
'W' : CASE S[2] OF
'S' : BBSListMCI := BBSListPtr^.WebSiteUrl;
END;
END;
END;
PROCEDURE BBSListScriptFile(VAR BBSList: BBSListRecordType);
VAR
BBSScriptText: TEXT;
Question: STRING;
WhichOne: String;
TmpBirth: String[10];
BEGIN
Assign(BBSScriptText,General.MiscPath+'BBSLIST.SCR');
Reset(BBSScriptText);
WHILE NOT EOF(BBSScriptText) AND (NOT Abort) AND (NOT HangUp) DO
BEGIN
ReadLn(BBSScriptText,Question);
IF (Question[1] = '[') THEN
BEGIN
WhichOne := AllCaps(Copy(Question, Pos('[',Question)+1, Pos(']',Question)-2));
Question := Copy(Question,(Pos(':',Question) + 1),Length(Question));
IF (WhichOne = 'BBSNAME') THEN
BEGIN
NL;
PRT(Question+' ');
MPL(SizeOf(BBSList.BBSName) - 1);
InputMain(BBSList.BBSName,(SizeOf(BBSList.BBSName) - 1),[InterActiveEdit,ColorsAllowed]);
Abort := (BBSList.BBSName = '');
END
ELSE IF WhichOne = 'SYSOPNAME' THEN
BEGIN
PRT(Question+' ');
MPL(SizeOf(BBSList.SysOpName) - 1);
InputMain(BBSList.SysOpName,(SizeOf(BBSList.SysOpName) - 1),[ColorsAllowed,InterActiveEdit]);
Abort := (BBSList.SysOpName = '');
END
ELSE IF WhichOne = 'TELNETURL' THEN
BEGIN
Prt(Question+' ');
MPL(SizeOf(BBSList.TelnetUrl) - 1);
InputMain(BBSList.TelnetUrl,(SizeOf(BBSList.TelnetUrl) - 1),[ColorsAllowed,InterActiveEdit]);
Abort := (BBSList.TelnetUrl = '');
END
ELSE IF WhichOne = 'WEBSITEURL' THEN
BEGIN
Prt(Question+' ');
MPL(SizeOf(BBSList.WebSiteUrl) - 1);
InputMain(BBSList.WebSiteUrl,(SizeOf(BBSList.WebSiteUrl) - 1),[ColorsAllowed,InterActiveEdit]);
{Abort := (BBSList.WebSiteUrl = '');}
END
ELSE IF WhichOne = 'PHONENUMBER' THEN
BEGIN
PRT(Question+' ');
MPL(SizeOf(BBSList.PhoneNumber) - 1);
InputMain(BBSList.PhoneNumber,(SizeOf(BBSList.PhoneNumber) - 1),[ColorsAllowed,InterActiveEdit]);
{Abort := (BBSList.PhoneNumber = '');}
END
ELSE IF WhichOne = 'SOFTWARE' THEN
BEGIN
PRT(Question+' ');
MPL(SizeOf(BBSList.Software) - 1);
InputMain(BBSList.Software,(SizeOf(BBSList.Software) - 1),[ColorsAllowed,InterActiveEdit]);
{Abort := (BBSList.Software = '');}
END
ELSE IF WhichOne = 'SOFTWAREVERSION' THEN
BEGIN
Prt(Question+' ');
MPL(SizeOf(BBSList.SoftwareVersion) - 1);
InputMain(BBSList.SoftwareVersion,(SizeOf(BBSList.SoftwareVersion) - 1),[ColorsAllowed,InterActiveEdit]);
END
ELSE IF WhichOne = 'OS' THEN
BEGIN
Prt(Question+' ');
MPL(SizeOf(BBSList.OS) - 1);
InputMain(BBSList.OS,(SizeOf(BBSList.OS) - 1),[ColorsAllowed,InterActiveEdit]);
END
ELSE IF WhichOne = 'SPEED' THEN
BEGIN
PRT(Question+' ');
MPL(SizeOf(BBSList.Speed) - 1);
InputMain(BBSList.Speed,(SizeOf(BBSList.Speed) - 1),[ColorsAllowed,InterActiveEdit]);
{Abort := (BBSList.Speed = '');}
END
ELSE IF WhichOne = 'HOURS' THEN
BEGIN
PRT(Question+' ');
MPL(SizeOf(BBSList.Hours) - 1);
InputMain(BBSList.Hours,(SizeOf(BBSList.Hours) - 1),[ColorsAllowed,InterActiveEdit]);
{Abort := (BBSList.Speed = '');}
END
ELSE IF WhichOne = 'DESCRIPTION' THEN
BEGIN
Prt(Question);
MPL(SizeOf(BBSList.Description) - 1);
InputMain(BBSList.Description,(SizeOf(BBSList.Description) - 1),[ColorsAllowed,InterActiveEdit]);
{Abort := (BBSList.Description = '');}
END
ELSE IF WhichOne = 'DESCRIPTION2' THEN
BEGIN
Prt(Question);
MPL(SizeOf(BBSList.Description2) - 1);
InputMain(BBSList.Description2,(SizeOf(BBSList.Description2) - 1),[ColorsAllowed,InterActiveEdit]);
{Abort := (BBSList.Description2 = '');}
END
ELSE IF WhichOne = 'MAXNODES' THEN
BEGIN
MPL(SizeOf(BBSList.MaxNodes) - 1);
IF (BBSList.MaxNodes = 0) THEN
BBSList.MaxNodes := 5;
InputLongIntWoc(Question,BBSList.MaxNodes,[NumbersOnly,InteractiveEdit],1,1000);
END
ELSE IF WhichOne = 'PORT' THEN
BEGIN
IF (BBSList.Port = 0) THEN
BBSList.Port := 23;
MPL(SizeOf(BBSList.Port) - 1);
InputWordWoc(Question,BBSList.Port,[NumbersOnly,InterActiveEdit],1,65535);
END
ELSE IF WhichOne = 'LOCATION' THEN
BEGIN
Prt(Question+' ');
MPL(SizeOf(BBSList.Location) - 1);
InputMain(BBSList.Location,(SizeOf(BBSList.Location) - 1),[ColorsAllowed,InterActiveEdit]);
END
ELSE IF WhichOne = 'BIRTH' THEN
BEGIN
TmpBirth := BBSList.Birth;
IF (Length(TmpBirth) < 10) THEN
TmpBirth := '12/31/1969';
MPL(10);
InputFormatted(Question+' |08(|07'+TmpBirth+'|08) |15: ',BBSList.Birth,'##/##/####',TRUE);
IF (Length(BBSList.Birth) <= 0) THEN
BBSList.Birth := TmpBirth;
END
ELSE IF WhichOne = 'SDA' THEN
BEGIN
Prt(Question+' ');
MPL(SizeOf(BBSList.SDA) - 1);
InputMain(BBSList.SDA,(SizeOf(BBSList.SDA) - 1),[ColorsAllowed,InterActiveEdit]);
{Abort := (BBSList.xA = '');}
END
ELSE IF WhichOne = 'SDB' THEN
BEGIN
Prt(Question+' ');
MPL(SizeOf(BBSList.SDB) - 1);
InputMain(BBSList.SDB,(SizeOf(BBSList.SDB) - 1),[ColorsAllowed,InterActiveEdit]);
{Abort := (BBSList.xB = '');}
END
ELSE IF WhichOne = 'SDC' THEN
BEGIN
Prt(Question+' ');
MPL(SizeOf(BBSList.SDC) - 1);
InputMain(BBSList.SDC,(SizeOf(BBSList.SDC) - 1),[ColorsAllowed,InterActiveEdit]);
{ Abort := (BBSList.xC = ''); }
END
ELSE IF WhichOne = 'SDD' THEN BEGIN
Prt(Question+' ');
MPL(SizeOf(BBSList.SDD) - 1);
InputMain(BBSList.SDD,(SizeOf(BBSList.SDD) - 1),[ColorsAllowed,InterActiveEdit]);
{ Abort := (BBSList.xD = '');}
END
ELSE IF WhichOne = 'SDE' THEN
BEGIN
Print(Question);
MPL(SizeOf(BBSList.SDE) - 1);
InputMain(BBSList.SDE,(SizeOf(BBSList.SDE) - 1),[ColorsAllowed,InterActiveEdit]);
{Abort := (BBSList.xE = '');}
END
ELSE IF WhichOne = 'SDF' THEN
BEGIN
Print(Question);
MPL(SizeOf(BBSList.SDF) - 1);
InputMain(BBSList.SDF,(SizeOf(BBSList.SDF) - 1),[ColorsAllowed,InterActiveEdit]);
{Abort := (BBSList.xF = '');}
END
ELSE IF WhichOne = 'SDG' THEN
BEGIN
MPL(SizeOf(BBSList.SDG) - 1);
InputWordWoc(Question,BBSList.SDG,[NumbersOnly,InterActiveEdit],1,65535);
{Abort := (BBSList.xE = '');}
END
ELSE IF WhichOne = 'SDH' THEN
BEGIN
BBSList.SDH := PYNQ(Question+' ',0,TRUE);
END
ELSE IF WhichOne = 'SDI' THEN
BEGIN
BBSList.SDI := PYNQ(Question+' ',6,FALSE);
END;
END;
END;
Close(BBSScriptText);
LastError := IOResult;
END;
FUNCTION BBSList_Exists: Boolean;
VAR
BBSListFile: FILE OF BBSListRecordType;
FSize: Longint;
FExist: Boolean;
BEGIN
FSize := 0;
FExist := Exist(General.DataPath+'BBSLIST.DAT');
IF (FExist) THEN
BEGIN
Assign(BBSListFile,General.DataPath+'BBSLIST.DAT');
Reset(BBSListFile);
FSize := FileSize(BBSListFile);
Close(BBSListFile);
END;
IF (NOT FExist) OR (FSize = 0) THEN
BEGIN
NL;
Print('There are currently no entries in the BBS List.');
SysOpLog('The BBSLIST.DAT file is missing.');
END;
BBSList_Exists := (FExist) AND (FSize <> 0);
END;
PROCEDURE DisplayError(FName: ASTR; VAR FExists: Boolean);
BEGIN
NL;
PrintACR('|12ú |09The '+FName+'.* File is missing.');
PrintACR('|12ú |09Please, inform the Sysop!');
SysOpLog('The '+FName+'.* file is missing.');
FExists := FALSE;
END;
FUNCTION BBSListScript_Exists: Boolean;
VAR
FExists: Boolean;
BEGIN
FExists := Exist(General.MiscPath+'BBSLIST.SCR');
IF (NOT FExists) THEN
DisplayError('BBSLIST.SCR',FExists);
BBSListScript_Exists := FExists;
END;
FUNCTION BBSListAddScreens_Exists: Boolean;
VAR
FExistsH,
FExistsN,
FExistsT: Boolean;
BEGIN
FExistsH := TRUE;
FExistsN := TRUE;
FExistsT := TRUE;
IF (NOT ReadBuffer('BBSNH')) THEN
DisplayError('BBSNH',FExistsH);
IF (NOT ReadBuffer('BBSMN')) THEN
DisplayError('BBSMN',FExistsN);
IF (NOT ReadBuffer('BBSNT')) THEN
DisplayError('BBSNT',FExistsT);
BBSListAddScreens_Exists := (FExistsH) AND (FExistsN) AND (FExistsT);
END;
FUNCTION BBSListEditScreens_Exists: Boolean;
VAR
FExistsT,
FExistsM: Boolean;
BEGIN
FExistsT := TRUE;
FExistsM := TRUE;
IF (NOT ReadBuffer('BBSLET')) THEN
DisplayError('BBSLET',FExistsT);
IF (NOT ReadBuffer('BBSLEM')) THEN
DisplayError('BBSLEM',FExistsM);
BBSListEditScreens_Exists := (FExistsT) AND (FExistsM);
END;
PROCEDURE BBSList_Renumber;
VAR
BBSListFile: FILE OF BBSListRecordType;
BBSList: BBSListRecordType;
OnRec: Longint;
BEGIN
Assign(BBSListFile,General.DataPath+'BBSLIST.DAT');
Reset(BBSListFile);
Abort := FALSE;
OnRec := 1;
WHILE (OnRec <= FileSize(BBSListFile)) DO
BEGIN
Seek(BBSListFile,(OnRec - 1));
Read(BBSListFile,BBSList);
BBSList.RecordNum := OnRec;
Seek(BBSListFile,(OnRec - 1));
Write(BBSListFile,BBSList);
Inc(OnRec);
END;
Close(BBSListFile);
LastError := IOResult;
END;
PROCEDURE BBSList_Sort;
VAR
BBSListFile: FILE OF BBSListRecordType;
BBSList1,
BBSList2: BBSListRecordType;
S,
I,
J,
pl,
Gap: INTEGER;
BEGIN
IF (BBSList_Exists) THEN
BEGIN
Assign(BBSListFile,General.DataPath+'BBSLIST.DAT');
Reset(BBSListFile);
pl := FileSize(BBSListFile);
Gap := pl;
REPEAT;
Gap := (Gap DIV 2);
IF (Gap = 0) THEN
Gap := 1;
s := 0;
FOR I := 1 TO (pl - Gap) DO
BEGIN
J := (I + Gap);
Seek(BBSListFile,(i - 1));
Read(BBSListFile,BBSList1);
Seek(BBSListFile,(j - 1));
Read(BBSListFile,BBSList2);
IF (BBSList1.BBSName > BBSList2.BBSName) THEN
BEGIN
Seek(BBSListFile,(i - 1));
Write(BBSListFile,BBSList2);
Seek(BBSListFile,(j - 1));
Write(BBSListFile,BBSList1);
Inc(s);
END;
END;
UNTIL (s = 0) AND (Gap = 1);
Close(BBSListFile);
LastError := IOResult;
IF (PL > 0) THEN
BEGIN
NL;
Print('Sorted '+IntToStr(pl)+' BBS List entries.');
SysOpLog('Sorted the BBS Listing');
END;
END;
END;
PROCEDURE BBSList_Add;
VAR
Data2: Pointer;
BBSList: BBSListRecordType;
BEGIN
IF (BBSListScript_Exists) AND (BBSListAddScreens_Exists) THEN
BEGIN
NL;
IF PYNQ(' Add an entry to the BBS list? ',0,FALSE) THEN
BEGIN
FillChar(BBSList,SizeOf(BBSList),0);
BBSListScriptFile(BBSList);
IF (NOT Abort) THEN
BEGIN
PrintF('BBSNH');
ReadBuffer('BBSMN');
DisplayBuffer(BBSListMCI,@BBSList,Data2);
PrintF('BBSNT');
NL;
IF (PYNQ(' Save '+BBSList.BBSName+'? ',0,TRUE)) THEN
BEGIN
Assign(BBSListFile,General.DataPath+'BBSLIST.DAT');
IF (Exist(General.DataPath+'BBSLIST.DAT')) THEN
Reset(BBSListFile)
ELSE
Rewrite(BBSListFile);
Seek(BBSListFile,FileSize(BBSListFile));
BBSList.UserID := UserNum;
BBSList.DateAdded := GetPackDateTime;
BBSList.DateEdited := BBSList.DateAdded;
BBSList.RecordNum := (FileSize(BBSListFile) + 1);
Write(BBSListFile,BBSList);
Close(BBSListFile);
LastError := IOResult;
BBSList_Sort;
BBSList_Renumber;
SysOpLog('Added BBS Listing: '+BBSList.BBSName+'.');
END;
END;
END;
END;
END;
PROCEDURE BBSList_Delete;
VAR
Data2: Pointer;
BBSList: BBSListRecordType;
OnRec,
RecNum: Longint;
Found: Boolean;
BEGIN
IF (BBSList_Exists) AND (BBSListEditScreens_Exists) THEN
BEGIN
AllowContinue := FALSE;
Found := FALSE;
Abort := FALSE;
Assign(BBSListFile,General.DataPath+'BBSLIST.DAT');
Reset(BBSListFile);
OnRec := 1;
WHILE (OnRec <= FileSize(BBSListFile)) AND (NOT Abort) AND (NOT HangUp) DO
BEGIN
Seek(BBSListFile,(OnRec - 1));
Read(BBSListFile,BBSList);
IF (BBSList.UserID = UserNum) OR (CoSysOp) THEN
BEGIN
PrintF('BBSLDT');
ReadBuffer('BBSLEM');
DisplayBuffer(BBSListMCI,@BBSList,Data2);
NL;
IF (PYNQ(' Delete '+BBSLIST.BBSName+'? ',0,FALSE)) THEN
BEGIN
SysOpLog('Deleted BBS Listing: '+BBSList.BBSName+'.');
IF ((OnRec - 1) <= (FileSize(BBSListFile) - 2)) THEN
FOR RecNum := (OnRec - 1) TO (FileSize(BBSListFile) - 2) DO
BEGIN
Seek(BBSListFile,(RecNum + 1));
Read(BBSListFile,BBSList);
Seek(BBSListFile,RecNum);
Write(BBSListFile,BBSList);
END;
Seek(BBSListFile,(FileSize(BBSListFile) - 1));
Truncate(BBSListFile);
Dec(OnRec);
END;
Found := TRUE;
END;
Inc(OnRec);
END;
Close(BBSListFile);
LastError := IOResult;
BBSList_ReNumber;
IF (NOT Found) THEN
BEGIN
NL;
Print(' You may only delete BBS Listing''s that you have entered.');
SysOpLog('Tried to delete a BBS Listing.');
END;
END;
END;
PROCEDURE BBSList_Edit;
VAR
Data2: Pointer;
BBSList: BBSListRecordType;
OnRec: Longint;
Found: Boolean;
Edit : LongInt;
BEGIN
IF (BBSList_Exists) AND (BBSListEditScreens_Exists) AND (BBSListAddScreens_Exists) THEN
BEGIN
Assign(BBSListFile,General.DataPath+'BBSLIST.DAT');
Reset(BBSListFile);
AllowContinue := FALSE;
Found := FALSE;
Abort := FALSE;
OnRec := 1;
WHILE (NOT Abort) AND (NOT HangUp) DO
BEGIN
PrintF('BBSLEDT');
ReadBuffer('BBSLEM');
While OnRec <= FileSize(BBSListFile) Do
Begin
Seek(BBSListFile, OnRec -1);
Read(BBSListFile,BBSList);
DisplayBuffer(BBSListMCI,@BBSList,Data2);
Inc(OnRec);
End;
NL;
MPL(FileSize(BBSListFile));
InputLongIntWOC(' Edit which BBS? :',Edit,[],1,FileSize(BBSListFile));
Abort := (Edit <> 0 );
IF (Edit <= FileSize(BBSListFile)) AND (Edit > 0) THEN
BEGIN
Seek(BBSListFile,(Edit -1))
END
ELSE
BEGIN
Close(BBSListFile);
Exit;
END;
Read(BBSListFile,BBSList);
IF (BBSList.UserID = UserNum) OR (CoSysOp) OR (BBSList.SysopName = ThisUser.Name) THEN
BEGIN
PrintF('BBSLEH');
ReadBuffer('BBSLEM');
DisplayBuffer(BBSListMCI,@BBSList,Data2);
NL;
IF (PYNQ(' Would you like to edit this BBS Listing? ',0,TRUE)) THEN
BEGIN
BBSListScriptFile(BBSList);
IF (NOT Abort) THEN
BEGIN
PrintF('BBSNH');
ReadBuffer('BBSMN');
DisplayBuffer(BBSListMCI,@BBSList,Data2);
PrintF('BBSNT');
NL;
IF (PYNQ(' Would you like to save this BBS Listing? ',0,TRUE)) THEN
BEGIN
Seek(BBSListFile,(Edit -1));
BBSList.DateEdited := GetPackDateTime;
Write(BBSListFile,BBSList);
SysOpLog('Edited BBS Listing: '+BBSList.BBSName+'.');
END;
END;
END;
Found := TRUE;
END;
{Inc(OnRec);}
Exit;
END;
Close(BBSListFile);
LastError := IOResult;
IF (NOT Found) THEN
BEGIN
NL;
Print(' You may only edit BBS Listing''s that you have entered.');
SysOpLog('Tried to edit a BBS Listing.');
END;
END
ELSE
BEGIN
NL;
Print('There was an error displaying an ASCII file. Let the sysop know so they can investigate.');
SysOpLog('Some ASCII Files are missing for editing the bbslist. Investigate ...');
END;
END;
PROCEDURE BBSList_View;
VAR
Data2: Pointer;
BBSList: BBSListRecordType;
OnRec: Longint;
Cnt : Byte;
BEGIN
IF (BBSList_Exists) AND (BBSListAddScreens_Exists) THEN
BEGIN
Assign(BBSListFile,General.DataPath+'BBSLIST.DAT');
Reset(BBSListFile);
ReadBuffer('BBSMN');
AllowContinue := TRUE;
Abort := FALSE;
PrintF('BBSNH');
OnRec := 1;
Cnt := 1;
WHILE (OnRec <= FileSize(BBSListFile)) AND (NOT Abort) AND (NOT HangUp) DO
BEGIN
Seek(BBSListFile,(OnRec - 1));
Read(BBSListFile,BBSList);
DisplayBuffer(BBSListMCI,@BBSList,Data2);
Inc(OnRec);
Inc(Cnt);
If Cnt = (23 - 4) Then
Begin
PauseScr(True);
Cnt := 1;
End
Else
Begin
Cnt := Cnt;
End;
END;
Close(BBSListFile);
LastError := IOResult;
IF (NOT Abort) THEN
PrintF('BBSNT');
AllowContinue := FALSE;
SysOpLog('Viewed the BBS Listing.');
END;
END;
PROCEDURE BBSList_xView; (* Do we need xview *) {Yes -sk}
VAR
Data2: Pointer;
BBSList: BBSListRecordType;
OnRec: Longint;
Edit : Longint;
BEGIN
IF (BBSList_Exists) THEN (* Add BBSME & BBSEH exist checking here *)
BEGIN
Assign(BBSListFile,General.DataPath+'BBSLIST.DAT');
Reset(BBSListFile);
PrintF('BBSLEH');
ReadBuffer('BBSLEM');
OnRec := 1;
While OnRec <= FileSize(BBSListFile) Do
Begin
Seek(BBSListFile, OnRec -1);
Read(BBSListFile,BBSList);
DisplayBuffer(BBSListMCI,@BBSList,Data2);
Inc(OnRec);
End;
PrintF('BBSLET');
NL;
MPL(FileSize(BBSListFile));
InputLongIntWOC(' View which BBS? ',Edit,[],1,FileSize(BBSListFile));
Abort := (Edit <> 0 );
IF (Edit <= FileSize(BBSListFile)) AND (Edit > 0) THEN
BEGIN
Seek(BBSListFile,(Edit -1));
Read(BBSListFile,BBSList);
Close(BBSListFile);
END
ELSE
BEGIN
Close(BBSListFile);
Exit;
END;
IF (ReadBuffer('BBSME')) THEN
BEGIN
AllowContinue := TRUE;
Abort := FALSE;
PrintF('BBSEH');
WHILE (NOT Abort) AND (NOT HangUp) DO
BEGIN
DisplayBuffer(BBSListMCI,@BBSList,Data2);
PrintF('BBSET');
AllowContinue := FALSE;
{PauseScr(FALSE);}
SysOpLog('Viewed Extended BBS Listing of '+BBSList.BBSName+'.');
Exit;
END;
END;
{Close(BBSListFile);}
LastError := IOResult;
END;
END;
END.

1078
SOURCE/BOOT.PAS Normal file
View File

File diff suppressed because it is too large Load Diff

592
SOURCE/BULLETIN.PAS Normal file
View File

@ -0,0 +1,592 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D-,E-,F+,I-,L-,N-,O+,R-,S+,V-}
UNIT Bulletin;
INTERFACE
USES
Common;
FUNCTION FindOnlyOnce: Boolean;
FUNCTION NewBulletins: Boolean;
PROCEDURE Bulletins(MenuOption: Str50);
PROCEDURE UList(MenuOption: Str50);
PROCEDURE TodaysCallers(x: Byte; MenuOptions: Str50);
PROCEDURE RGQuote(MenuOption: Str50);
IMPLEMENTATION
USES
Dos,
Common5,
Mail1,
ShortMsg,
TimeFunc;
TYPE
LastCallerPtrType = ^LastCallerRec;
UserPtrType = ^UserRecordType;
PROCEDURE Bulletins(MenuOption: Str50);
VAR
Main,
Subs,
InputStr: ASTR;
BEGIN
NL;
IF (MenuOption = '') THEN
IF (General.BulletPrefix = '') THEN
MenuOption := 'BULLETIN;BULLET'
ELSE
MenuOption := 'BULLETIN;'+General.BulletPrefix;
IF (Pos(';',MenuOption) <> 0) THEN
BEGIN
Main := Copy(MenuOption,1,(Pos(';',MenuOption) - 1));
Subs := Copy(MenuOption,(Pos(';',MenuOption) + 1),(Length(MenuOption) - Pos(';',MenuOption)));
END
ELSE
BEGIN
Main := MenuOption;
Subs := MenuOption;
END;
PrintF(Main);
IF (NOT NoFile) THEN
REPEAT
NL;
{ Prt(FString.BulletinLine); }
lRGLngStr(16,FALSE);
ScanInput(InputStr,'ABCDEFGHIJKLMNOPQRSTUVWXYZ?');
IF (NOT HangUp) THEN
BEGIN
IF (InputStr = '?') THEN
PrintF(Main);
IF (InputStr <> '') AND NOT (InputStr[1] IN ['Q','?']) THEN
PrintF(Subs+InputStr);
END;
UNTIL (InputStr = 'Q') OR (HangUp);
END;
FUNCTION FindOnlyOnce: Boolean;
VAR
(*
DirInfo: SearchRec;
*)
DT: DateTime;
BEGIN
FindOnlyOnce := FALSE;
FindFirst(General.MiscPath+'ONLYONCE.*',AnyFile - Directory - VolumeID- DOS.Hidden,DirInfo);
IF (DosError = 0) THEN
BEGIN
UnPackTime(DirInfo.Time,DT);
IF (DateToPack(DT) > ThisUser.LastOn) THEN
FindOnlyOnce := TRUE;
END;
END;
FUNCTION NewBulletins: Boolean;
TYPE
BulletinType = ARRAY [0..255] OF Byte;
VAR
BulletinArray: ^BulletinType;
DT: DateTime;
(*
DirInfo: SearchRec;
*)
BullCount,
Biggest,
LenOfBullPrefix,
LenToCopy: Byte;
Found: Boolean;
PROCEDURE ShowBulls;
VAR
Counter,
Counter1,
Counter2: Byte;
BEGIN
FOR Counter := 0 TO BullCount DO
BEGIN
FOR Counter1 := 0 TO BullCount DO
IF (BulletinArray^[Counter] < BulletinArray^[Counter1]) THEN
BEGIN
Counter2 := BulletinArray^[Counter];
BulletinArray^[Counter] := BulletinArray^[Counter1];
BulletinArray^[Counter1] := Counter2;
END;
END;
Counter1 := 1;
Prt('|01[ |11');
FOR Counter2 := 0 TO (BullCount) DO
BEGIN
IF (Counter1 = 15) THEN
BEGIN
Prt(PadRightInt(BulletinArray^[Counter2],2));
IF (Counter2 < BullCount) THEN
Prt(' |01]'+^M^J+'|01[ |11')
ELSE
Prt(' |01]');
Counter1 := 0;
END
ELSE
BEGIN
Prt(PadRightInt(BulletinArray^[Counter2],2));
IF (Counter2 < BullCount) THEN
Prt('|07,|11 ')
ELSE
Prt(' |01]');
END;
Inc(Counter1);
END;
NL;
END;
BEGIN
New(BulletinArray);
FOR BullCount := 0 TO 255 DO
BulletinArray^[BullCount] := 0;
Found := FALSE;
Biggest := 0;
BullCount := 0;
LenOfBullPrefix := (Length(General.BulletPrefix) + 1);
FindFirst(General.MiscPath+General.BulletPrefix+'*.ASC',AnyFile - Directory - VolumeID - DOS.Hidden,DirInfo);
WHILE (DosError = 0) DO
BEGIN
IF (((Pos(General.BulletPrefix,General.MiscPath+General.BulletPrefix+'*.ASC') > 0) AND
(Pos('BULLETIN',AllCaps(DirInfo.Name)) = 0)) AND
(Pos('~',DirInfo.Name) = 0)) THEN
BEGIN
UnPackTime(DirInfo.Time,DT);
IF (DateToPack(DT) > ThisUser.LastOn) THEN
BEGIN
Found := TRUE;
LenToCopy := (Pos('.',DirInfo.Name) - 1) - Length(General.BulletPrefix);
BulletinArray^[BullCount] := StrToInt(Copy(DirInfo.Name,LenOfBullPrefix,LenToCopy));
IF (BulletinArray^[BullCount] > Biggest) THEN
Biggest := BulletinArray^[BullCount];
Inc(BullCount);
END;
END;
IF (BullCount > 254) THEN
Exit;
FindNext(DirInfo);
END;
IF (Found) THEN
BEGIN
Dec(BullCount);
ShowBulls;
END;
Dispose(BulletinArray);
NewBulletins := Found;
END;
FUNCTION UlistMCI(CONST S: ASTR; Data1,Data2: Pointer): STRING;
VAR
UserPtr: UserPtrType;
BEGIN
UlistMCI := S;
UserPtr := Data1;
CASE S[1] OF
'A' : CASE S[2] OF
'G' : UListMCI := IntToStr(AgeUser(UserPtr^.BirthDate));
END;
'D' : CASE S[2] OF
'K' : UListMCI := IntToStr(UserPtr^.DK);
'L' : UListMCI := IntToStr(UserPtr^.Downloads);
END;
'L' : CASE S[2] OF
'C' : UListMCI := UserPtr^.CityState;
'O' : UListMCI := ToDate8(PD2Date(UserPtr^.LastOn));
END;
'M' : CASE S[2] OF
'P' : UListMCI := IntToStr(UserPtr^.MsgPost);
END;
'N' : CASE S[2] OF
'O' : UListMCI := Userptr^.Note;
END;
'R' : CASE S[2] OF
'N' : UListMCI := UserPtr^.RealName;
END;
'S' : CASE S[2] OF
'X' : UListMCI := UserPtr^.Sex;
END;
'U' : CASE S[2] OF
'K' : UListMCI := IntToStr(UserPtr^.UK);
'L' : UListMCI := IntToStr(UserPtr^.Uploads);
'N' : UListMCI := Caps(UserPtr^.Name);
'1' : UListMCI := UserPtr^.UsrDefStr[1];
'2' : UListMCI := UserPtr^.UsrDefStr[2];
'3' : UListMCI := UserPtr^.UsrDefStr[3];
END;
END;
END;
PROCEDURE UList(MenuOption: Str50);
VAR
Junk: Pointer;
User: UserRecordType;
Cmd: Char;
TempStr: ASTR;
Gender: Str1;
State,
UState: Str2;
Age: Str3;
DateLastOn: Str8;
City,
UCity: Str30;
RName,
UName: Str36;
FN: Str50;
RecNum: Integer;
PROCEDURE Option(c1: Char; s1,s2: Str160);
BEGIN
Prompt('^4<^5'+c1+'^4>'+s1+': ');
IF (s2 <> '') THEN
Print('^5"^4'+s2+'^5"^1')
ELSE
Print('^5<<INACTIVE>>^1');
END;
BEGIN
IF (RUserList IN ThisUser.Flags) THEN
BEGIN
Print('You are restricted from listing users.');
Exit;
END;
Age := '';
City := '';
DateLastOn := '';
Gender := '';
RName := '';
State := '';
UName := '';
REPEAT
NL;
Print('^5User lister search options:');
NL;
Option('A','ge match string ',Age);
Option('C','ity match string ',City);
Option('D','ate last online match string',DateLastOn);
Option('G','ender match string ',Gender);
Option('R','eal name match string ',RName);
Option('S','tate match string ',State);
Option('U','ser name match string ',UName);
NL;
Prompt('^4Enter choice (^5A^4,^5C^4,^5D^4,^5G^4,^5R^4,^5S^4,^5U^4) [^5L^4]ist [^5Q^4]uit: ');
OneK(Cmd,'QACDGLRSU'^M,TRUE,TRUE);
NL;
IF (Cmd IN ['A','C','D','G','R','S','U']) THEN
BEGIN
TempStr := 'Enter new match string for the ';
CASE Cmd OF
'A' : TempStr := TempStr + 'age';
'C' : TempStr := TempStr + 'city';
'D' : TempStr := TempStr + 'date last online';
'G' : TempStr := TempStr + 'gender';
'R' : TempStr := TempStr + 'real name';
'S' : TempStr := TempStr + 'state';
'U' : TempStr := TempStr + 'user name';
END;
TempStr := TempStr + ' (<CR>=Make INACTIVE)';
Print('^4'+TempStr);
Prompt('^4: ');
END;
CASE Cmd OF
'A' : BEGIN
Mpl(3);
Input(Age,3);
END;
'C' : BEGIN
Mpl(30);
Input(City,30);
END;
'D' : BEGIN
Mpl(8);
InputFormatted('',DateLastOn,'##/##/##',TRUE);
IF (DayNum(DateLastOn) <> 0) AND (DayNum(DateLastOn) <= DayNum(DateStr)) THEN
BEGIN
Delete(DateLastOn,3,1);
Insert('-',DateLastOn,3);
Delete(DateLastOn,6,1);
Insert('-',DateLastOn,6);
END;
END;
'G' : BEGIN
Mpl(1);
Input(Gender,1);
END;
'R' : BEGIN
Mpl(36);
Input(RName,36);
END;
'S' : BEGIN
Mpl(2);
Input(State,2);
END;
'U' : BEGIN
Mpl(36);
Input(UName,36);
END;
END;
UNTIL (Cmd IN ['L','Q',^M]) OR (HangUp);
IF (Cmd IN ['L',^M]) THEN
BEGIN
Abort := FALSE;
Next := FALSE;
AllowContinue := TRUE;
IF (Pos(';',MenuOption) > 0) THEN
BEGIN
FN := Copy(MenuOption,(Pos(';',MenuOption) + 1),255);
MenuOption := Copy(MenuOption,1,(Pos(';',MenuOption) - 1));
END
ELSE
FN := 'USER';
IF (NOT ReadBuffer(FN+'M')) THEN
Exit;
PrintF(FN+'H');
Reset(UserFile);
RecNum := 1;
WHILE (RecNum <= (FileSize(UserFile) - 1)) AND (NOT Abort) AND (NOT HangUp) DO
BEGIN
LoadURec(User,RecNum);
UCity := (Copy(User.CityState,1,(Pos(',',User.CityState) - 1)));
UState := SQOutSP((Copy(User.CityState,(Pos(',',User.CityState) + 2),(Length(User.CityState)))));
IF (AACS1(User,RecNum,MenuOption)) AND NOT (Deleted IN User.SFlags) THEN
IF (Age = '') OR (Pos(Age,IntToStr(AgeUser(User.BirthDate))) > 0) THEN
IF (City = '') OR (Pos(City,AllCaps(UCity)) > 0) THEN
IF (DateLastOn = '') OR (Pos(DateLastOn,ToDate8(PD2Date(User.LastOn))) > 0) THEN
IF (Gender = '') OR (Pos(Gender,User.Sex) > 0) THEN
IF (RName = '') OR (Pos(RName,AllCaps(User.RealName)) > 0) THEN
IF (State = '') OR (Pos(State,AllCaps(UState)) > 0) THEN
IF (UName = '') OR (Pos(UName,User.Name) > 0) THEN
DisplayBuffer(UlistMCI,@User,Junk);
Inc(RecNum);
END;
Close(UserFile);
IF (NOT Abort) AND (NOT HangUp) THEN
PrintF(FN+'T');
AllowContinue := FALSE;
END;
SysOpLog('Viewed User Listing.');
LastError := IOResult;
END;
FUNCTION TodaysCallerMCI(CONST S: ASTR; Data1,Data2: Pointer): STRING;
VAR
LastCallerPtr: LastCallerPtrType;
s1: STRING[100];
BEGIN
LastCallerPtr := Data1;
TodaysCallerMCI := S;
CASE S[1] OF
'C' : CASE S[2] OF
'A' : TodaysCallerMCI := FormatNumber(LastCallerPtr^.Caller);
END;
'D' : CASE S[2] OF
'K' : TodaysCallerMCI := IntToStr(LastCallerPtr^.DK);
'L' : TodaysCallerMCI := IntToStr(LastCallerPtr^.Downloads);
END;
'E' : CASE S[2] OF
'S' : TodaysCallerMCI := IntToStr(LastCallerPtr^.EmailSent);
END;
'F' : CASE S[2] OF
'S' : TodaysCallerMCI := IntToStr(LastCallerPtr^.FeedbackSent);
END;
'L' : CASE S[2] OF
'C' : TodaysCallerMCI := LastCallerPtr^.Location;
'O' : BEGIN
s1 := PDT2Dat(LastCallerPtr^.LogonTime,0);
s1[0] := Char(Pos('m',s1) - 2);
s1[Length(s1)] := s1[Length(s1) + 1];
TodaysCallerMCI := s1;
END;
'T' : BEGIN
IF (LastCallerPtr^.LogoffTime = 0) THEN
S1 := 'Online'
ELSE
BEGIN
s1 := PDT2Dat(LastCallerPtr^.LogoffTime,0);
s1[0] := Char(Pos('m',s1) - 2);
s1[Length(s1)] := s1[Length(s1) + 1];
END;
TodaysCallerMCI := s1;
END;
END;
'M' : CASE S[2] OF
'P' : TodaysCallerMCI := IntToStr(LastCallerPtr^.MsgPost);
'R' : TodaysCallerMCI := IntToStr(LastCallerPtr^.MsgRead);
END;
'N' : CASE S[2] OF
'D' : TodaysCallerMCI := IntToStr(LastCallerPtr^.Node);
'U' : IF (LastCallerPtr^.NewUser) THEN
TodaysCallerMCI := '*'
ELSE
TodaysCallerMCI := ' ';
END;
'S' : CASE S[2] OF
'P' : IF (LastCallerPtr^.Speed = 0) THEN
TodaysCallerMCI := 'Local'
ELSE IF (Telnet) THEN
TodaysCallerMCI := 'Telnet'
ELSE
TodaysCallerMCI := IntToStr(LastCallerPtr^.Speed);
END;
'T' : CASE S[2] OF
'O' : WITH LastCallerPtr^ DO
TodaysCallerMCI := IntToStr((LogoffTime - LogonTime) DIV 60);
END;
'U' : CASE S[2] OF
'K' : TodaysCallerMCI := IntToStr(LastCallerPtr^.UK);
'L' : TodaysCallerMCI := IntToStr(LastCallerPtr^.Uploads);
'N' : TodaysCallerMCI := LastCallerPtr^.UserName;
END;
END;
END;
PROCEDURE TodaysCallers(x: Byte; MenuOptions: Str50);
VAR
Junk: Pointer;
LastCallerFile: FILE OF LastCallerRec;
LastCaller: LastCallerRec;
RecNum: Integer;
BEGIN
Abort := FALSE;
Next := FALSE;
AllowContinue := TRUE;
IF (MenuOptions = '') THEN
MenuOptions := 'LAST';
IF (NOT ReadBuffer(MenuOptions+'M')) THEN
Exit;
Assign(LastCallerFile,General.DataPath+'LASTON.DAT');
Reset(LastCallerFile);
IF (IOResult <> 0) THEN
Exit;
RecNum := 0;
IF (x > 0) AND (x <= FileSize(LastCallerFile)) THEN
RecNum := (FileSize(LastCallerFile) - x);
PrintF(MenuOptions+'H');
Seek(LastCallerFile,RecNum);
WHILE (NOT EOF(LastCallerFile)) AND (NOT Abort) AND (NOT HangUp) DO
BEGIN
Read(LastCallerFile,LastCaller);
IF (((LastCaller.LogonTime DIV 86400) <> (GetPackDateTime DIV 86400)) AND (x > 0)) OR
(((LastCaller.LogonTime DIV 86400) = (GetPackDateTime DIV 86400))) AND (NOT LastCaller.Invisible) THEN
DisplayBuffer(TodaysCallerMCI,@LastCaller,Junk);
END;
Close(LastCallerFile);
IF (NOT Abort) THEN
PrintF(MenuOptions+'T');
AllowContinue := FALSE;
SysOpLog('Viewed Todays Callers.');
LastError := IOResult;
END;
PROCEDURE RGQuote(MenuOption: Str50);
VAR
StrPointerFile: FILE OF StrPointerRec;
StrPointer: StrPointerRec;
RGStrFile: FILE;
F,
F1: Text;
MHeader: MHeaderRec;
S: STRING;
StrNum: Word;
TotLoad: LongInt;
BEGIN
IF (MenuOption = '') THEN
Exit;
Assign(StrPointerFile,General.LMultPath+MenuOption+'.PTR');
Reset(StrPointerFile);
TotLoad := FileSize(StrPointerFile);
IF (TotLoad < 1) THEN
Exit;
IF (TotLoad > 65535) THEN
Totload := 65535
ELSE
Dec(TotLoad);
Randomize;
StrNum := Random(Totload);
Seek(StrPointerFile,StrNum);
Read(StrPointerFile,StrPointer);
Close(StrPointerFile);
LastError := IOResult;
IF (Exist(General.MiscPath+'QUOTEHDR.*')) THEN
PrintF('QUOTEHDR')
ELSE
BEGIN
NL;
Print('|03[ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ[ |11And Now |03... |11A Quote For You! |03]ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ]');
NL;
END;
TotLoad := 0;
Assign(RGStrFile,General.LMultPath+MenuOption+'.DAT');
Reset(RGStrFile,1);
Seek(RGStrFile,(StrPointer.Pointer - 1));
REPEAT
BlockRead(RGStrFile,S[0],1);
BlockRead(RGStrFile,S[1],Ord(S[0]));
Inc(TotLoad,(Length(S) + 1));
IF (S[Length(S)] = '@') THEN
BEGIN
Dec(S[0]);
Prt(Centre(S));
END
ELSE
PrintACR(Centre(S));
UNTIL (TotLoad >= StrPointer.TextSize) OR EOF(RGStrFile);
Close(RGStrFile);
LastError := IOResult;
IF (Exist(General.MiscPath+'QUOTEFTR.*')) THEN
PrintF('QUOTEFTR')
ELSE
BEGIN
NL;
Print('|03[ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ]');
NL;
END;
IF (NOT General.UserAddQuote) THEN
PauseScr(FALSE)
ELSE IF (PYNQ('Would you like to add a quote? ',0,FALSE)) THEN
BEGIN
PrintF('QUOTE');
InResponseTo := '';
MHeader.Status := [];
IF (InputMessage(TRUE,FALSE,'New Quote',MHeader,General.LMultPath+MenuOption+'.TMP',78,500)) then
IF Exist(General.LMultPath+MenuOption+'.TMP') THEN
BEGIN
Assign(F,General.LMultPath+MenuOption+'.NEW');
Reset(F);
IF (IOResult <> 0) THEN
ReWrite(F)
ELSE
Append(F);
Assign(F1,General.LMultPath+MenuOption+'.TMP');
Reset(F1);
IF (IOResult <> 0) THEN
Exit;
WriteLn(F,'New quote from: '+Caps(ThisUser.Name)+' #'+IntToStr(UserNum)+'.');
WriteLn(F,'');
WriteLn(F,'$');
WHILE (NOT EOF(F1)) DO
BEGIN
ReadLn(F1,S);
WriteLn(F,S);
END;
WriteLn(F,'$');
WriteLn(F,'');
WriteLn(F);
Close(F);
Close(F1);
Kill(General.LMultPath+MenuOption+'.TMP');
NL;
Print('^7Your new quote was saved.');
PauseScr(FALSE);
SendShortMessage(1,Caps(ThisUser.Name)+' added a new quote to "'+MenuOption+'.NEW".');
END;
END;
END;
END.

5076
SOURCE/COMMON.PAS Normal file
View File

File diff suppressed because it is too large Load Diff

414
SOURCE/COMMON1.PAS Normal file
View File

@ -0,0 +1,414 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S-,V-}
UNIT Common1;
INTERFACE
FUNCTION CheckPW: Boolean;
PROCEDURE NewCompTables;
PROCEDURE Wait(b: Boolean);
PROCEDURE InitTrapFile;
PROCEDURE Local_Input1(VAR S: STRING; MaxLen: Byte; LowerCase: Boolean);
PROCEDURE Local_Input(VAR S: STRING; MaxLen: Byte);
PROCEDURE Local_InputL(VAR S: STRING; MaxLen: Byte);
PROCEDURE Local_OneK(VAR C: Char; S: STRING);
PROCEDURE SysOpShell;
PROCEDURE ReDrawForANSI;
IMPLEMENTATION
USES
Crt,
Common,
File0,
Mail0,
TimeFunc;
FUNCTION CheckPW: Boolean;
VAR
Password: STR20;
BEGIN
IF (NOT General.SysOpPWord) OR (InWFCMenu) THEN
BEGIN
CheckPW := TRUE;
Exit;
END;
CheckPW := FALSE;
{ Prompt(FString.SysOpPrompt); }
lRGLngStr(33,FALSE);
GetPassword(Password,20);
IF (Password = General.SysOpPW) THEN
CheckPW := TRUE
ELSE IF (InCom) AND (Password <> '') THEN
SysOpLog('--> SysOp Password Failure = '+Password+' ***');
END;
PROCEDURE NewCompTables;
VAR
FileCompArrayFile: FILE OF CompArrayType;
MsgCompArrayFile: FILE OF CompArrayType;
CompFileArray: CompArrayType;
CompMsgArray: CompArrayType;
Counter,
Counter1,
Counter2,
SaveReadMsgArea,
SaveReadFileArea: Integer;
BEGIN
SaveReadMsgArea := ReadMsgArea;
SaveReadFileArea := ReadFileArea;
Reset(FileAreaFile);
IF (IOResult <> 0) THEN
BEGIN
SysOpLog('Error opening FBASES.DAT (Procedure: NewCompTables)');
Exit;
END;
NumFileAreas := FileSize(FileAreaFile);
Assign(FileCompArrayFile,TempDir+'FACT'+IntToStr(ThisNode)+'.DAT');
ReWrite(FileCompArrayFile);
CompFileArray[0] := 0;
CompFileArray[1] := 0;
FOR Counter := 1 TO FileSize(FileAreaFile) DO
Write(FileCompArrayFile,CompFileArray);
Reset(FileCompArrayFile);
IF (NOT General.CompressBases) THEN
BEGIN
FOR Counter := 1 TO FileSize(FileAreaFile) DO
BEGIN
Seek(FileAreaFile,(Counter - 1));
Read(FileAreaFile,MemFileArea);
IF (NOT AACS(MemFileArea.ACS)) THEN
BEGIN
CompFileArray[0] := 0;
CompFileArray[1] := 0;
END
ELSE
BEGIN
CompFileArray[0] := Counter;
CompFileArray[1] := Counter;
END;
Seek(FileCompArrayFile,(Counter - 1));
Write(FileCompArrayFile,CompFileArray);
END;
END
ELSE
BEGIN
Counter2 := 0;
Counter1 := 0;
FOR Counter := 1 TO FileSize(FileAreaFile) DO
BEGIN
Seek(FileAreaFile,(Counter - 1));
Read(FileAreaFile,MemFileArea);
Inc(Counter1);
IF (NOT AACS(MemFileArea.ACS)) THEN
BEGIN
Dec(Counter1);
CompFileArray[0] := 0;
END
ELSE
BEGIN
CompFileArray[0] := Counter1;
Seek(FileCompArrayFile,(Counter - 1));
Write(FileCompArrayFile,CompFileArray);
Inc(Counter2);
Seek(FileCompArrayFile,(Counter2 - 1));
Read(FileCompArrayFile,CompFileArray);
CompFileArray[1] := Counter;
Seek(FileCompArrayFile,(Counter2 - 1));
Write(FileCompArrayFile,CompFileArray);
END;
END;
END;
Close(FileAreaFile);
LastError := IOResult;
LowFileArea := 0;
Counter1 := 0;
Counter := 1;
WHILE (Counter <= FileSize(FileCompArrayFile)) AND (Counter1 = 0) DO
BEGIN
Seek(FileCompArrayFile,(Counter - 1));
Read(FileCompArrayFile,CompFileArray);
IF (CompFileArray[0] <> 0) THEN
Counter1 := CompFileArray[0];
Inc(Counter);
END;
LowFileArea := Counter1;
HighFileArea := 0;
Counter1 := 0;
Counter := 1;
WHILE (Counter <= FileSize(FileCompArrayFile)) DO
BEGIN
Seek(FileCompArrayFile,(Counter - 1));
Read(FileCompArrayFile,CompFileArray);
IF (CompFileArray[0] <> 0) THEN
Counter1 := CompFileArray[0];
Inc(Counter);
END;
HighFileArea := Counter1;
Close(FileCompArrayFile);
LastError := IOResult;
Reset(MsgAreaFile);
IF (IOResult <> 0) THEN
BEGIN
SysOpLog('Error opening MBASES.DAT (Procedure: NewCompTables)');
Exit;
END;
NumMsgAreas := FileSize(MsgAreaFile);
Assign(MsgCompArrayFile,TempDir+'MACT'+IntToStr(ThisNode)+'.DAT');
ReWrite(MsgCompArrayFile);
CompMsgArray[0] := 0;
CompMsgArray[1] := 0;
FOR Counter := 1 TO FileSize(MsgAreaFile) DO
Write(MsgCompArrayFile,CompMsgArray);
Reset(MsgCompArrayFile);
IF (NOT General.CompressBases) THEN
BEGIN
FOR Counter := 1 TO FileSize(MsgAreaFile) DO
BEGIN
Seek(MsgAreaFile,(Counter - 1));
Read(MsgAreaFile,MemMsgArea);
IF (NOT AACS(MemMsgArea.ACS)) THEN
BEGIN
CompMsgArray[0] := 0;
CompMsgArray[1] := 0;
END
ELSE
BEGIN
CompMsgArray[0] := Counter;
CompMsgArray[1] := Counter;
END;
Seek(MsgCompArrayFile,(Counter - 1));
Write(MsgCompArrayFile,CompMsgArray);
END;
END
ELSE
BEGIN
Counter2 := 0;
Counter1 := 0;
FOR Counter := 1 TO FileSize(MsgAreaFile) DO
BEGIN
Seek(MsgAreaFile,(Counter - 1));
Read(MsgAreaFile,MemMsgArea);
Inc(Counter1);
IF (NOT AACS(MemMsgArea.ACS)) THEN
BEGIN
Dec(Counter1);
CompMsgArray[0] := 0;
END
ELSE
BEGIN
CompMsgArray[0] := Counter1;
Seek(MsgCompArrayFile,(Counter - 1));
Write(MsgCompArrayFile,CompMsgArray);
Inc(Counter2);
Seek(MsgCompArrayFile,(Counter2 - 1));
Read(MsgCompArrayFile,CompMsgArray);
CompMsgArray[1] := Counter;
Seek(MsgCompArrayFile,(Counter2 - 1));
Write(MsgCompArrayFile,CompMsgArray);
END;
END;
END;
Close(MsgAreaFile);
LastError := IOResult;
LowMsgArea := 0;
Counter1 := 0;
Counter := 1;
WHILE (Counter <= FileSize(MsgCompArrayFile)) AND (Counter1 = 0) DO
BEGIN
Seek(MsgCompArrayFile,(Counter - 1));
Read(MsgCompArrayFile,CompMsgArray);
IF (CompMsgArray[0] <> 0) THEN
Counter1 := CompMsgArray[0];
Inc(Counter);
END;
LowMsgArea := Counter1;
HighMsgArea := 0;
Counter1 := 0;
Counter := 1;
WHILE (Counter <= FileSize(MsgCompArrayFile)) DO
BEGIN
Seek(MsgCompArrayFile,(Counter - 1));
Read(MsgCompArrayFile,CompMsgArray);
IF (CompMsgArray[0] <> 0) THEN
Counter1 := CompMsgArray[0];
Inc(Counter);
END;
HighMsgArea := Counter1;
Close(MsgCompArrayFile);
LastError := IOResult;
ReadMsgArea := -1;
ReadFileArea := -1;
IF (NOT FileAreaAC(FileArea)) THEN
ChangeFileArea(CompFileArea(1,1));
IF (NOT MsgAreaAC(MsgArea)) THEN
ChangeMsgArea(CompMsgArea(1,1));
LoadMsgArea(SaveReadMsgArea);
LoadFileArea(SaveReadFileArea);
END;
PROCEDURE Wait(b: Boolean);
CONST
SaveCurrentColor: Byte = 0;
BEGIN
IF (B) THEN
BEGIN
SaveCurrentColor := CurrentColor;
{ Prompt(FString.lWait); }
lRGLngStr(4,FALSE);
END
ELSE
BEGIN
BackErase(LennMCI(lRGLngStr(4,TRUE){FString.lWait}));
SetC(SaveCurrentColor);
END;
END;
PROCEDURE InitTrapFile;
BEGIN
Trapping := FALSE;
IF (General.GlobalTrap) OR (TrapActivity IN ThisUser.SFlags) THEN
Trapping := TRUE;
IF (Trapping) THEN
BEGIN
IF (TrapSeparate IN ThisUser.SFlags) THEN
Assign(TrapFile,General.LogsPath+'TRAP'+IntToStr(UserNum)+'.LOG')
ELSE
Assign(TrapFile,General.LogsPath+'TRAP.LOG');
Append(TrapFile);
IF (IOResult = 2) THEN
BEGIN
ReWrite(TrapFile);
WriteLn(TrapFile);
END;
WriteLn(TrapFile,'***** Renegade User Audit - '+Caps(ThisUser.Name)+' on at '+DateStr+' '+TimeStr+' *****');
END;
END;
PROCEDURE Local_Input1(VAR S: STRING; MaxLen: Byte; LowerCase: Boolean);
VAR
C: Char;
B: Byte;
BEGIN
B := 1;
REPEAT
C := ReadKey;
IF (NOT LowerCase) THEN
C := UpCase(C);
IF (C IN [#32..#255]) THEN
IF (B <= MaxLen) THEN
BEGIN
S[B] := C;
Inc(B);
Write(C);
END
ELSE
ELSE
CASE C of
^H : IF (B > 1) THEN
BEGIN
Write(^H' '^H);
C := ^H;
Dec(B);
END;
^U,^X : WHILE (B <> 1) DO
BEGIN
Write(^H' '^H);
Dec(B);
END;
END;
UNTIL (C IN [^M,^N]);
S[0] := Chr(B - 1);
IF (WhereY <= Hi(WindMax) - Hi(WindMin)) THEN
WriteLn;
END;
PROCEDURE Local_Input(VAR S: STRING; MaxLen: Byte);
BEGIN
Local_Input1(S,MaxLen,FALSE);
END;
PROCEDURE Local_InputL(VAR S: STRING; MaxLen: Byte);
BEGIN
Local_Input1(S,MaxLen,TRUE);
END;
PROCEDURE Local_OneK(VAR C: Char; S: STRING);
BEGIN
REPEAT
C := UpCase(ReadKey)
UNTIL (Pos(C,S) > 0);
WriteLn(C);
END;
PROCEDURE SysOpShell;
VAR
SavePath: STRING;
SaveWhereX,
SaveWhereY,
SaveCurCo: Byte;
ReturnCode: Integer;
SaveTimer: LongInt;
BEGIN
SaveCurCo := CurrentColor;
GetDir(0,SavePath);
SaveTimer := Timer;
IF (UserOn) THEN
BEGIN
{ Prompt(FString.ShellDOS1); }
lRGLngStr(12,FALSE);
Com_Flush_Send;
Delay(100);
END;
SaveWhereX := WhereX;
SaveWhereY := WhereY;
Window(1,1,80,25);
TextBackGround(Black);
TextColor(LightGray);
ClrScr;
TextColor(LightCyan);
WriteLn('Type "EXIT" to return to Renegade.');
WriteLn;
TimeLock := TRUE;
ShellDOS(FALSE,'',ReturnCode);
TimeLock := FALSE;
IF (UserOn) THEN
Com_Flush_Recv;
ChDir(SavePath);
TextBackGround(Black);
TextColor(LightGray);
ClrScr;
TextAttr := SaveCurCo;
GoToXY(SaveWhereX,SaveWhereY);
IF (UserOn) THEN
BEGIN
IF (NOT InChat) THEN
FreeTime := ((FreeTime + Timer) - SaveTimer);
Update_Screen;
FOR SaveCurCo := 1 TO LennMCI(lRGLngStr(12,TRUE){FString.ShellDOS1}) DO
BackSpace;
END;
END;
PROCEDURE ReDrawForANSI;
BEGIN
IF (DOSANSIOn) THEN
BEGIN
DOSANSIOn := FALSE;
Update_Screen;
END;
TextAttr := 7;
CurrentColor := 7;
IF (OutCom) THEN
IF (OKAvatar) THEN
SerialOut(^V^A^G)
ELSE IF (OkANSI) THEN
SerialOut(#27+'[0m');
END;
END.

1313
SOURCE/COMMON2.PAS Normal file
View File

File diff suppressed because it is too large Load Diff

545
SOURCE/COMMON3.PAS Normal file
View File

@ -0,0 +1,545 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S-,V-,X-}
UNIT Common3;
INTERFACE
USES
Common;
PROCEDURE InputDefault(VAR S: STRING; v: STRING; MaxLen: Byte; InputFlags: InputFlagSet; LineFeed: Boolean);
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: 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);
PROCEDURE InputWNWC(DisplayStr: AStr; VAR InputStr: AStr; MaxLen: Byte; VAR Changed: Boolean);
PROCEDURE InputMain(VAR S: STRING; MaxLen: Byte; InputFlags: InputFlagSet);
PROCEDURE InputWC(VAR S: STRING; MaxLen: Byte);
PROCEDURE Input(VAR S: STRING; MaxLen: Byte);
PROCEDURE InputL(VAR S: STRING; MaxLen: Byte);
PROCEDURE InputCaps(VAR S: STRING; MaxLen: Byte);
IMPLEMENTATION
USES
Crt
{$IFDEF WIN32}
,RPScreen
{$ENDIF}
;
PROCEDURE InputDefault(VAR S: STRING; v: STRING; MaxLen: Byte; InputFlags: InputFlagSet; LineFeed: Boolean);
VAR
C: Char;
Counter: Byte;
BEGIN
MPL(MaxLen);
MCIAllowed := FALSE;
ColorAllowed := FALSE;
Prompt(v);
ColorAllowed := TRUE;
MCIAllowed := TRUE;
C := Char(GetKey);
IF (C <> #13) THEN
BEGIN
FOR Counter := 1 TO Length(v) DO
BackSpace;
Buf := C + Buf;
InputMain(S,MaxLen,InputFlags);
IF (S = '') THEN
BEGIN
S := v;
MPL(MaxLen);
Prompt(S);
END
ELSE IF (S = ' ') THEN
S := '';
END
ELSE
BEGIN
S := v;
IF NOT (NolineFeed IN InputFlags) THEN
NL;
END;
UserColor(1);
IF (LineFeed) THEN
NL;
END;
PROCEDURE InputFormatted(DisplayStr: AStr; VAR InputStr: STRING; Format: STRING; Abortable: Boolean);
VAR
c: Char;
i,
FarBack: Byte;
PROCEDURE UpdateString;
BEGIN
WHILE (NOT (Format[i] IN ['#','@']) AND (i <= Length(Format))) DO
BEGIN
OutKey(Format[i]);
InputStr := InputStr + Format[i];
Inc(i);
END;
END;
BEGIN
InputStr := '';
Prt(DisplayStr);
MPL(Length(Format));
i := 1;
UpdateString;
FarBack := i;
REPEAT
c := Char(GetKey);
IF (i <= Length(Format)) THEN
IF ((Format[i] = '@') AND (c IN ['a'..'z','A'..'Z'])) OR ((Format[i] = '#') AND (c IN ['0'..'9'])) THEN
BEGIN
c := UpCase(c);
OutKey(c);
InputStr := InputStr + c;
Inc(i);
UpdateString;
END;
IF (c = ^H) THEN
BEGIN
WHILE ((i > FarBack) AND NOT (Format[i - 1] IN ['#','@'])) DO
BEGIN
BackSpace;
Dec(InputStr[0]);
Dec(i);
END;
IF (i > FarBack) THEN
BEGIN
BackSpace;
Dec(InputStr[0]);
Dec(i);
END;
END;
UNTIL (HangUp) OR ((i > Length(Format)) OR (Abortable)) AND (c = #13);
UserColor(1);
NL;
END;
PROCEDURE InputLongIntWC(S: AStr; VAR L: LongInt; InputFlags: InputFlagSet; LowNum,HighNum: LongInt; VAR Changed: Boolean);
VAR
TempStr: Str10;
SaveL: LongInt;
TempL: Real;
BEGIN
SaveL := L;
IF (NOT (DisplayValue IN InputFlags)) THEN
Prt(S+' (^5'+IntToStr(LowNum)+'^4-^5'+IntToStr(HighNum)+'^4): ')
ELSE
Prt(S+' (^5'+IntToStr(LowNum)+'^4-^5'+IntToStr(HighNum)+'^4) [^5'+IntToStr(L)+'^4]: ');
MPL(Length(IntToStr(HighNum)));
TempStr := IntToStr(L);
InputMain(TempStr,Length(IntToStr(HighNum)),InputFlags);
IF (TempStr <> '') THEN
BEGIN
TempL := ValueR(TempStr);
IF ((Trunc(TempL) >= LowNum) AND (Trunc(TempL) <= HighNum)) THEN
L := Trunc(TempL)
ELSE
BEGIN
NL;
Print('^7The range must be from '+IntToStr(LowNum)+' to '+IntToStr(HighNum)+'!^1');
PauseScr(FALSE);
END;
END;
IF (SaveL <> L) THEN
Changed := TRUE;
END;
PROCEDURE InputLongIntWOC(S: AStr; VAR L: LongInt; InputFlags: InputFlagSet; LowNum,HighNum: LongInt);
VAR
Changed: Boolean;
BEGIN
Changed := FALSE;
InputLongIntWC(S,L,InputFlags,LowNum,HighNum,Changed);
END;
PROCEDURE InputWordWC(S: AStr; VAR W: SmallWord; InputFlags: InputFlagSet; LowNum,HighNum: Word; VAR Changed: Boolean);
VAR
TempStr: Str5;
SaveW: Word;
TempW: Longint;
BEGIN
SaveW := W;
IF (NOT (DisplayValue IN InputFlags)) THEN
Prt(S+' (^5'+IntToStr(LowNum)+'^4-^5'+IntToStr(HighNum)+'^4): ')
ELSE
Prt(S+' (^5'+IntToStr(LowNum)+'^4-^5'+IntToStr(HighNum)+'^4) [^5'+IntToStr(W)+'^4]: ');
MPL(Length(IntToStr(HighNum)));
TempStr := IntToStr(W);
InputMain(TempStr,Length(IntToStr(HighNum)),InputFlags);
IF (TempStr <> '') THEN
BEGIN
TempW := StrToInt(TempStr);
IF ((TempW >= LowNum) AND (TempW <= HighNum)) THEN
W := TempW
ELSE
BEGIN
NL;
Print('^7The range must be from '+IntToStr(LowNum)+' to '+IntToStr(HighNum)+'!^1');
PauseScr(FALSE);
END;
END;
IF (SaveW <> W) THEN
Changed := TRUE;
END;
PROCEDURE InputWordWOC(S: AStr; VAR W: SmallWord; InputFlags: InputFlagSet; LowNum,HighNum: Word);
VAR
Changed: Boolean;
BEGIN
Changed := FALSE;
InputWordWC(S,W,InputFlags,LowNum,HighNum,Changed);
END;
PROCEDURE InputIntegerWC(S: AStr; VAR I: SmallInt; InputFlags: InputFlagSet; LowNum,HighNum: Integer; VAR Changed: Boolean);
VAR
TempStr: Str5;
SaveI: Integer;
TempI: Longint;
BEGIN
SaveI := I;
IF (NOT (DisplayValue IN InputFlags)) THEN
Prt(S+' (^5'+IntToStr(LowNum)+'^4-^5'+IntToStr(HighNum)+'^4): ')
ELSE
Prt(S+' (^5'+IntToStr(LowNum)+'^4-^5'+IntToStr(HighNum)+'^4) [^5'+IntToStr(I)+'^4]: ');
MPL(Length(IntToStr(HighNum)));
TempStr := IntToStr(I);
InputMain(TempStr,Length(IntToStr(HighNum)),InputFlags);
IF (TempStr <> '') THEN
BEGIN
TempI := StrToInt(TempStr);
IF ((TempI >= LowNum) AND (TempI <= HighNum)) THEN
I := TempI
ELSE
BEGIN
NL;
Print('^7The range must be from '+IntToStr(LowNum)+' to '+IntToStr(HighNum)+'!^1');
PauseScr(FALSE);
END;
END;
IF (SaveI <> I) THEN
Changed := TRUE;
END;
PROCEDURE InputIntegerWOC(S: AStr; VAR I: SmallInt; InputFlags: InputFlagSet; LowNum,HighNum: Integer);
VAR
Changed: Boolean;
BEGIN
Changed := FALSE;
InputIntegerWC(S,I,InputFlags,LowNum,HighNum,Changed);
END;
PROCEDURE InputByteWC(S: AStr; VAR B: Byte; InputFlags: InputFlagSet; LowNum,HighNum: Byte; VAR Changed: Boolean);
VAR
TempStr: Str3;
SaveB: Byte;
TempB: Integer;
BEGIN
SaveB := B;
IF (NOT (DisplayValue IN InputFlags)) THEN
Prt(S+' (^5'+IntToStr(LowNum)+'^4-^5'+IntToStr(HighNum)+'^4): ')
ELSE
Prt(S+' (^5'+IntToStr(LowNum)+'^4-^5'+IntToStr(HighNum)+'^4) [^5'+IntToStr(B)+'^4]: ');
MPL(Length(IntToStr(HighNum)));
TempStr := IntToStr(B);
InputMain(TempStr,Length(IntToStr(HighNum)),InputFlags);
IF (TempStr <> '') THEN
BEGIN
TempB := StrToInt(TempStr);
IF ((TempB >= LowNum) AND (TempB <= HighNum)) THEN
B := TempB
ELSE
BEGIN
NL;
Print('^7The range must be from '+IntToStr(LowNum)+' to '+IntToStr(HighNum)+'!^1');
PauseScr(FALSE);
END;
END;
IF (SaveB <> B) THEN
Changed := TRUE;
END;
PROCEDURE InputByteWOC(S: AStr; VAR B: Byte; InputFlags: InputFlagSet; LowNum,HighNum: Byte);
VAR
Changed: Boolean;
BEGIN
Changed := FALSE;
InputByteWC(S,B,InputFlags,LowNum,HighNum,Changed);
END;
PROCEDURE InputWN1(DisplayStr: AStr; VAR InputStr: AStr; MaxLen: Byte; InputFlags: InputFlagSet; VAR Changed: Boolean);
VAR
SaveInputStr: AStr;
BEGIN
Prt(DisplayStr);
IF (NOT (ColorsAllowed IN InputFlags)) THEN
MPL(MaxLen);
SaveInputStr := InputStr;
InputMain(SaveInputStr,MaxLen,InputFlags);
IF (SaveInputStr = '') THEN
SaveInputStr := InputStr;
IF (SaveInputStr = ' ') THEN
IF PYNQ('Blank String? ',0,FALSE) THEN
SaveInputStr := ''
ELSE
SaveInputStr := InputStr;
IF (SaveInputStr <> InputStr) THEN
Changed := TRUE;
InputStr := SaveInputStr;
END;
PROCEDURE InputWNWC(DisplayStr: AStr; VAR InputStr: AStr; MaxLen: Byte; VAR Changed: Boolean);
BEGIN
InputWN1(DisplayStr,InputStr,MaxLen,[ColorsAllowed,InterActiveEdit],Changed);
END;
PROCEDURE InputMain(VAR S: STRING; MaxLen: Byte; InputFlags: InputFlagSet);
VAR
SaveS: STRING;
Is: STRING[2];
Cp,
Cl,
Counter: Byte;
c,
C1: Word;
InsertMode,
FirstKey: Boolean;
PROCEDURE MPrompt(S: STRING);
BEGIN
SerialOut(S);
IF (WantOut) THEN
Write(S);
END;
PROCEDURE Cursor_Left;
BEGIN
IF (NOT OkAvatar) THEN
SerialOut(#27'[D')
ELSE
SerialOut(^V^E);
IF (WantOut) THEN
GotoXY((WhereX - 1),WhereY);
END;
PROCEDURE Cursor_Right;
BEGIN
OutKey(S[Cp]);
Inc(Cp);
END;
{$IFDEF MSDOS}
PROCEDURE SetCursor(InsertMode: Boolean); ASSEMBLER;
ASM
cmp InsertMode,0
je @turnon
mov ch,0
mov Cl,7
jmp @goforit
@turnon:
mov ch,6
mov Cl,7
@goforit:
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;
IF (NOT (InterActiveEdit IN InputFlags)) OR NOT (Okansi OR OkAvatar) THEN
BEGIN
S := '';
Cp := 1;
Cl := 0;
END
ELSE
BEGIN
Cp := Length(S);
Cl := Length(S);
IF (Cp = 0) THEN
Cp := 1;
MPrompt(S);
IF (Length(S) > 0) THEN
BEGIN
Cursor_Left;
IF (Cp <= MaxLen) THEN (* Was Cp < MaxLen *)
Cursor_Right;
END;
FirstKey := TRUE;
END;
SaveS := S;
InsertMode := FALSE;
REPEAT
MLC := S;
SetCursor(InsertMode);
c := GetKey;
IF (FirstKey) AND (C = 32) THEN
C := 24;
FirstKey := FALSE;
CASE c OF
8 : IF (Cp > 1) THEN
BEGIN
Dec(Cl);
Dec(Cp);
Delete(S,Cp,1);
BackSpace;
IF (Cp < Cl) THEN
BEGIN
MPrompt(Copy(S,Cp,255)+' ');
FOR Counter := Cp TO (Cl + 1) DO
Cursor_Left;
END;
END;
24 : BEGIN
FOR Counter := Cp TO Cl DO
OutKey(' ');
FOR Counter := 1 TO Cl DO
BackSpace;
Cl := 0;
Cp := 1;
END;
32..255:
BEGIN
IF (NOT (NumbersOnly IN InputFlags)) THEN
BEGIN
IF (UpperOnly IN InputFlags) THEN
c := Ord(UpCase(Char(c)));
IF (CapWords IN InputFlags) THEN
IF (Cp > 1) THEN
BEGIN
IF (S[Cp - 1] IN [#32..#64]) THEN
c := Ord(UpCase(Char(c)))
ELSE IF (c IN [Ord('A')..Ord('Z')]) THEN
Inc(c,32);
END
ELSE
c := Ord(UpCase(Char(c)));
END;
IF (NOT (NumbersOnly IN InputFlags)) OR (c IN [45,48..57]) THEN
BEGIN
IF ((InsertMode) AND (Cl < MaxLen)) OR ((NOT InsertMode) AND (Cp <= MaxLen)) THEN
BEGIN
OutKey(Char(c));
IF (InsertMode) THEN
BEGIN
Is := Char(c);
MPrompt(Copy(S,Cp,255));
Insert(Is,S,Cp);
FOR Counter := Cp TO Cl DO
Cursor_Left;
END
ELSE
S[Cp]:= Char(c);
IF (InsertMode) OR ((Cp - 1) = Cl) THEN
Inc(Cl);
Inc(Cp);
IF (Trapping) THEN
Write(TrapFile,Char(c));
END;
END;
END;
F_END :
WHILE (Cp < (Cl + 1)) AND (Cp <= MaxLen) DO
Cursor_Right;
F_HOME :
WHILE (Cp > 1) DO
BEGIN
Cursor_Left;
Dec(Cp);
END;
F_LEFT :
IF (Cp > 1) THEN
BEGIN
Cursor_Left;
Dec(Cp);
END;
F_RIGHT :
IF (Cp <= Cl) THEN
Cursor_Right;
F_INS :
BEGIN
InsertMode := (NOT InsertMode);
SetCursor(InsertMode);
END;
F_DEL :
IF (Cp > 0) AND (Cp <= Cl) THEN
BEGIN
Dec(Cl);
Delete(S,Cp,1);
MPrompt(Copy(S,Cp,255)+' ');
FOR Counter := Cp TO (Cl + 1) DO
Cursor_Left;
END;
END;
S[0] := Chr(Cl);
UNTIL (c = 13) OR (HangUp);
IF ((Redisplay IN InputFlags) AND (S = '')) THEN
BEGIN
S := SaveS;
MPrompt(S);
END;
UserColor(1);
IF (NOT (NoLineFeed IN InputFlags)) THEN
NL;
MLC := '';
SetCursor(FALSE);
END;
PROCEDURE InputWC(VAR S: STRING; MaxLen: Byte);
BEGIN
InputMain(S,MaxLen,[ColorsAllowed]);
END;
PROCEDURE Input(VAR S: STRING; MaxLen: Byte);
BEGIN
InputMain(S,MaxLen,[UpperOnly]);
END;
PROCEDURE InputL(VAR S: STRING; MaxLen: Byte);
BEGIN
InputMain(S,MaxLen,[]);
END;
PROCEDURE InputCaps(VAR S: STRING; MaxLen: Byte);
BEGIN
InputMain(S,MaxLen,[CapWords]);
END;
END.

1051
SOURCE/COMMON4.PAS Normal file
View File

File diff suppressed because it is too large Load Diff

533
SOURCE/COMMON5.PAS Normal file
View File

@ -0,0 +1,533 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S-,V-}
UNIT Common5;
INTERFACE
USES
Common;
PROCEDURE FileAreaScanInput(DisplayStr: AStr; MaxLen: Byte; VAR S: AStr; CONST Allowed: AStr; MinNum,MaxNum: Integer);
PROCEDURE MsgAreaScanInput(DisplayStr: AStr; MaxLen: Byte; VAR S: AStr; CONST Allowed: AStr; MinNum,MaxNum: Integer);
IMPLEMENTATION
USES
Crt;
PROCEDURE ANSIG(X,Y: Byte);
BEGIN
IF (ComPortSpeed > 0) THEN
IF (OkAvatar) THEN
SerialOut(^V^H+Chr(Y)+Chr(X))
ELSE
SerialOut(#27+'['+IntToStr(Y)+';'+IntToStr(X)+'H');
IF (WantOut) THEN
GoToXY(X,Y);
END;
FUNCTION CmdExists(Num: Integer): Boolean;
VAR
Counter: Byte;
Found: Boolean;
BEGIN
Found := FALSE;
FOR Counter := 1 TO LightBarCounter DO
IF (LightBarArray[Counter].CmdToExec = Num) THEN
BEGIN
Found := TRUE;
Break;
END;
CmdExists := Found;
END;
PROCEDURE FileAreaScanInput(DisplayStr: AStr; MaxLen: Byte; VAR S: AStr; CONST Allowed: AStr; MinNum,MaxNum: Integer);
VAR
SaveS: AStr;
C: Char;
Counter,
SaveX,
SaveY: Byte;
W: Word;
GotCmd: Boolean;
BEGIN
Prt(DisplayStr);
MPL(MaxLen);
IF (LightBarFirstCmd) THEN
LightBarCmd := 1
ELSE
LightBarCmd := LightBarCounter;
IF (General.UseFileAreaLightBar) AND (FileAreaLightBar IN ThisUser.SFlags) THEN
BEGIN
SaveX := WhereX;
SaveY := WhereY;
ANSIG(LightBarArray[LightBarCmd].XPos,LightBarArray[LightBarCmd].YPos);
SetC(114);
Prompt(PadLeftStr(LightBarArray[LightBarCmd].CmdToShow,32));
ANSIG(SaveX,SaveY);
SetC(31);
END;
GotCmd := FALSE;
s := '';
REPEAT
W := GetKey;
IF (General.UseFileAreaLightBar) AND (FileAreaLightBar IN ThisUser.SFlags) THEN
BEGIN
IF (W = 13) AND (S = '') THEN
BEGIN
S := IntToStr(LightBarArray[LightBarCmd].CmdToExec);
GotCmd := TRUE;
END
ELSE IF (W = 91) THEN
BEGIN
IF (CmdExists(MinNum)) THEN
W := 0
ELSE
BEGIN
S := '[';
LightBarFirstCmd := FALSE;
GotCmd := TRUE
END;
END
ELSE IF (W = 93) THEN
BEGIN
IF (CmdExists(MaxNum)) THEN
W := 0
ELSE
BEGIN
S := ']';
LightBarFirstCmd := TRUE;
GotCmd := TRUE
END
END
ELSE IF (W = F_Home) AND (LightBarCmd <> 1) THEN
BEGIN
SaveX := WhereX;
SaveY := WhereY;
ANSIG(LightBarArray[LightBarCmd].XPos,LightBarArray[LightBarCmd].YPos);
SetC(10);
Prompt(PadLeftStr(LightBarArray[LightBarCmd].CmdToShow,32));
LightBarCmd := 1;
ANSIG(LightBarArray[LightBarCmd].XPos,LightBarArray[LightBarCmd].YPos);
SetC(114);
Prompt(PadLeftStr(LightBarArray[LightBarCmd].CmdToShow,32));
ANSIG(SaveX,SaveY);
SetC(31);
END
ELSE IF (W = F_End) AND (LightBarCmd <> LightBarCounter) THEN
BEGIN
SaveX := WhereX;
SaveY := WhereY;
ANSIG(LightBarArray[LightBarCmd].XPos,LightBarArray[LightBarCmd].YPos);
SetC(10);
Prompt(PadLeftStr(LightBarArray[LightBarCmd].CmdToShow,32));
LightBarCmd := LightBarCounter;
ANSIG(LightBarArray[LightBarCmd].XPos,LightBarArray[LightBarCmd].YPos);
SetC(114);
Prompt(PadLeftStr(LightBarArray[LightBarCmd].CmdToShow,32));
ANSIG(SaveX,SaveY);
SetC(31);
END
ELSE IF (W = F_Left) THEN
BEGIN
IF (LightBarCmd = 1) AND (LightBarArray[LightBarCmd].CmdToExec <> MinNum) THEN
BEGIN
S := '[';
LightBarFirstCmd := FALSE;
GotCmd := TRUE
END
ELSE IF (LightBarCmd > 1) THEN
BEGIN
SaveX := WhereX;
SaveY := WhereY;
ANSIG(LightBarArray[LightBarCmd].XPos,LightBarArray[LightBarCmd].YPos);
SetC(10);
Prompt(PadLeftStr(LightBarArray[LightBarCmd].CmdToShow,32));
Dec(LightBarCmd);
ANSIG(LightBarArray[LightBarCmd].XPos,LightBarArray[LightBarCmd].YPos);
SetC(114);
Prompt(PadLeftStr(LightBarArray[LightBarCmd].CmdToShow,32));
ANSIG(SaveX,SaveY);
SetC(31);
END;
END
ELSE IF (W = F_Right) THEN
BEGIN
IF (LightBarCmd = LightBarCounter) AND (LightBarArray[LightBarCmd].CmdToExec <> MaxNum) THEN
BEGIN
S := ']';
LightBarFirstCmd := TRUE;
GotCmd := TRUE
END
ELSE IF (LightBarCmd < LightBarCounter) THEN
BEGIN
SaveX := WhereX;
SaveY := WhereY;
ANSIG(LightBarArray[LightBarCmd].XPos,LightBarArray[LightBarCmd].YPos);
SetC(10);
Prompt(PadLeftStr(LightBarArray[LightBarCmd].CmdToShow,32));
Inc(LightBarCmd);
ANSIG(LightBarArray[LightBarCmd].XPos,LightBarArray[LightBarCmd].YPos);
SetC(114);
Prompt(PadLeftStr(LightBarArray[LightBarCmd].CmdToShow,32));
ANSIG(SaveX,SaveY);
SetC(31);
END;
END
ELSE IF (W = F_Up) THEN
BEGIN
IF (LightBarCmd = 1) AND (LightBarArray[LightBarCmd].CmdToExec <> MinNum) THEN
BEGIN
S := '[';
LightBarFirstCmd := FALSE;
GotCmd := TRUE
END
ELSE IF ((LightBarCmd - 2) >= 1) THEN
BEGIN
SaveX := WhereX;
SaveY := WhereY;
ANSIG(LightBarArray[LightBarCmd].XPos,LightBarArray[LightBarCmd].YPos);
SetC(10);
Prompt(PadLeftStr(LightBarArray[LightBarCmd].CmdToShow,32));
Dec(LightBarCmd,2);
ANSIG(LightBarArray[LightBarCmd].XPos,LightBarArray[LightBarCmd].YPos);
SetC(114);
Prompt(PadLeftStr(LightBarArray[LightBarCmd].CmdToShow,32));
ANSIG(SaveX,SaveY);
SetC(31);
END
END
ELSE IF (W = F_Down) THEN
BEGIN
IF (LightBarCmd = LightBarCounter) AND (LightBarArray[LightBarCmd].CmdToExec <> MaxNum) THEN
BEGIN
S := ']';
LightBarFirstCmd := TRUE;
GotCmd := TRUE
END
ELSE IF ((LightBarCmd + 2) <= LightBarCounter) THEN
BEGIN
SaveX := WhereX;
SaveY := WhereY;
ANSIG(LightBarArray[LightBarCmd].XPos,LightBarArray[LightBarCmd].YPos);
SetC(10);
Prompt(PadLeftStr(LightBarArray[LightBarCmd].CmdToShow,32));
Inc(LightBarCmd,2);
ANSIG(LightBarArray[LightBarCmd].XPos,LightBarArray[LightBarCmd].YPos);
SetC(114);
Prompt(PadLeftStr(LightBarArray[LightBarCmd].CmdToShow,32));
ANSIG(SaveX,SaveY);
SetC(31);
END;
END;
END;
C := UpCase(Char(W));
SaveS := s;
IF ((Pos(c,Allowed) <> 0) AND (s = '')) THEN
BEGIN
GotCmd := TRUE;
s := c;
END
ELSE IF (Pos(c,'0123456789') > 0) OR (c = '-') THEN
BEGIN
IF ((Length(s) < 6) OR ((Pos('-',s) > 0) AND (Length(s) < 11))) THEN
s := s + c;
END
ELSE IF ((s <> '') AND (c = ^H)) THEN
Dec(s[0])
ELSE IF (c = ^X) THEN
BEGIN
FOR Counter := 1 TO Length(s) DO
BackSpace;
s := '';
SaveS := '';
END
ELSE IF (c = #13) AND (S <> '') THEN
BEGIN
IF (S = '-') THEN
BEGIN
BackSpace;
S := '';
SaveS := '';
END
ELSE
GotCmd := TRUE;
END;
IF (Length(s) < Length(SaveS)) THEN
BackSpace;
IF (Length(s) > Length(SaveS)) THEN
Prompt(s[Length(s)]);
UNTIL (GotCmd) OR (HangUp);
IF (General.UseFileAreaLightBar) AND (FileAreaLightBar IN ThisUser.SFlags) THEN
BEGIN
SaveX := WhereX;
SaveY := WhereY;
ANSIG(LightBarArray[LightBarCmd].XPos,LightBarArray[LightBarCmd].YPos);
SetC(10);
Prompt(PadLeftStr(LightBarArray[LightBarCmd].CmdToShow,32));
ANSIG(SaveX,SaveY);
END;
UserColor(1);
NL;
END;
PROCEDURE MsgAreaScanInput(DisplayStr: AStr; MaxLen: Byte; VAR S: AStr; CONST Allowed: AStr; MinNum,MaxNum: Integer);
VAR
SaveS: AStr;
C: Char;
Counter,
SaveX,
SaveY: Byte;
W: Word;
GotCmd: Boolean;
BEGIN
Prt(DisplayStr);
MPL(MaxLen);
IF (LightBarFirstCmd) THEN
LightBarCmd := 1
ELSE
LightBarCmd := LightBarCounter;
IF (General.UseMsgAreaLightBar) AND (MsgAreaLightBar IN ThisUser.SFlags) THEN
BEGIN
SaveX := WhereX;
SaveY := WhereY;
ANSIG(LightBarArray[LightBarCmd].XPos,LightBarArray[LightBarCmd].YPos);
SetC(114);
Prompt(PadLeftStr(LightBarArray[LightBarCmd].CmdToShow,32));
ANSIG(SaveX,SaveY);
SetC(31);
END;
GotCmd := FALSE;
s := '';
REPEAT
W := GetKey;
IF (General.UseMsgAreaLightBar) AND (MsgAreaLightBar IN ThisUser.SFlags) THEN
BEGIN
IF (W = 13) AND (S = '') THEN
BEGIN
S := IntToStr(LightBarArray[LightBarCmd].CmdToExec);
GotCmd := TRUE;
END
ELSE IF (W = 91) THEN
BEGIN
IF (CmdExists(MinNum)) THEN
W := 0
ELSE
BEGIN
S := '[';
LightBarFirstCmd := FALSE;
GotCmd := TRUE
END;
END
ELSE IF (W = 93) THEN
BEGIN
IF (CmdExists(MaxNum)) THEN
W := 0
ELSE
BEGIN
S := ']';
LightBarFirstCmd := TRUE;
GotCmd := TRUE
END
END
ELSE IF (W = F_Home) AND (LightBarCmd <> 1) THEN
BEGIN
SaveX := WhereX;
SaveY := WhereY;
ANSIG(LightBarArray[LightBarCmd].XPos,LightBarArray[LightBarCmd].YPos);
SetC(10);
Prompt(PadLeftStr(LightBarArray[LightBarCmd].CmdToShow,32));
LightBarCmd := 1;
ANSIG(LightBarArray[LightBarCmd].XPos,LightBarArray[LightBarCmd].YPos);
SetC(114);
Prompt(PadLeftStr(LightBarArray[LightBarCmd].CmdToShow,32));
ANSIG(SaveX,SaveY);
SetC(31);
END
ELSE IF (W = F_End) AND (LightBarCmd <> LightBarCounter) THEN
BEGIN
SaveX := WhereX;
SaveY := WhereY;
ANSIG(LightBarArray[LightBarCmd].XPos,LightBarArray[LightBarCmd].YPos);
SetC(10);
Prompt(PadLeftStr(LightBarArray[LightBarCmd].CmdToShow,32));
LightBarCmd := LightBarCounter;
ANSIG(LightBarArray[LightBarCmd].XPos,LightBarArray[LightBarCmd].YPos);
SetC(114);
Prompt(PadLeftStr(LightBarArray[LightBarCmd].CmdToShow,32));
ANSIG(SaveX,SaveY);
SetC(31);
END
ELSE IF (W = F_Left) THEN
BEGIN
IF (LightBarCmd = 1) AND (LightBarArray[LightBarCmd].CmdToExec <> MinNum) THEN
BEGIN
S := '[';
LightBarFirstCmd := FALSE;
GotCmd := TRUE
END
ELSE IF (LightBarCmd > 1) THEN
BEGIN
SaveX := WhereX;
SaveY := WhereY;
ANSIG(LightBarArray[LightBarCmd].XPos,LightBarArray[LightBarCmd].YPos);
SetC(10);
Prompt(PadLeftStr(LightBarArray[LightBarCmd].CmdToShow,32));
Dec(LightBarCmd);
ANSIG(LightBarArray[LightBarCmd].XPos,LightBarArray[LightBarCmd].YPos);
SetC(114);
Prompt(PadLeftStr(LightBarArray[LightBarCmd].CmdToShow,32));
ANSIG(SaveX,SaveY);
SetC(31);
END;
END
ELSE IF (W = F_Right) THEN
BEGIN
IF (LightBarCmd = LightBarCounter) AND (LightBarArray[LightBarCmd].CmdToExec <> MaxNum) THEN
BEGIN
S := ']';
LightBarFirstCmd := TRUE;
GotCmd := TRUE
END
ELSE IF (LightBarCmd < LightBarCounter) THEN
BEGIN
SaveX := WhereX;
SaveY := WhereY;
ANSIG(LightBarArray[LightBarCmd].XPos,LightBarArray[LightBarCmd].YPos);
SetC(10);
Prompt(PadLeftStr(LightBarArray[LightBarCmd].CmdToShow,32));
Inc(LightBarCmd);
ANSIG(LightBarArray[LightBarCmd].XPos,LightBarArray[LightBarCmd].YPos);
SetC(114);
Prompt(PadLeftStr(LightBarArray[LightBarCmd].CmdToShow,32));
ANSIG(SaveX,SaveY);
SetC(31);
END;
END
ELSE IF (W = F_Up) THEN
BEGIN
IF (LightBarCmd = 1) AND (LightBarArray[LightBarCmd].CmdToExec <> MinNum) THEN
BEGIN
S := '[';
LightBarFirstCmd := FALSE;
GotCmd := TRUE
END
ELSE IF ((LightBarCmd - 2) >= 1) THEN
BEGIN
SaveX := WhereX;
SaveY := WhereY;
ANSIG(LightBarArray[LightBarCmd].XPos,LightBarArray[LightBarCmd].YPos);
SetC(10);
Prompt(PadLeftStr(LightBarArray[LightBarCmd].CmdToShow,32));
Dec(LightBarCmd,2);
ANSIG(LightBarArray[LightBarCmd].XPos,LightBarArray[LightBarCmd].YPos);
SetC(114);
Prompt(PadLeftStr(LightBarArray[LightBarCmd].CmdToShow,32));
ANSIG(SaveX,SaveY);
SetC(31);
END
END
ELSE IF (W = F_Down) THEN
BEGIN
IF (LightBarCmd = LightBarCounter) AND (LightBarArray[LightBarCmd].CmdToExec <> MaxNum) THEN
BEGIN
S := ']';
LightBarFirstCmd := TRUE;
GotCmd := TRUE
END
ELSE IF ((LightBarCmd + 2) <= LightBarCounter) THEN
BEGIN
SaveX := WhereX;
SaveY := WhereY;
ANSIG(LightBarArray[LightBarCmd].XPos,LightBarArray[LightBarCmd].YPos);
SetC(10);
Prompt(PadLeftStr(LightBarArray[LightBarCmd].CmdToShow,32));
Inc(LightBarCmd,2);
ANSIG(LightBarArray[LightBarCmd].XPos,LightBarArray[LightBarCmd].YPos);
SetC(114);
Prompt(PadLeftStr(LightBarArray[LightBarCmd].CmdToShow,32));
ANSIG(SaveX,SaveY);
SetC(31);
END;
END;
END;
C := UpCase(Char(W));
SaveS := s;
IF ((Pos(c,Allowed) <> 0) AND (s = '')) THEN
BEGIN
GotCmd := TRUE;
s := c;
END
ELSE IF (Pos(c,'0123456789') > 0) OR (c = '-') THEN
BEGIN
IF ((Length(s) < 6) OR ((Pos('-',s) > 0) AND (Length(s) < 11))) THEN
s := s + c;
END
ELSE IF ((s <> '') AND (c = ^H)) THEN
Dec(s[0])
ELSE IF (c = ^X) THEN
BEGIN
FOR Counter := 1 TO Length(s) DO
BackSpace;
s := '';
SaveS := '';
END
ELSE IF (c = #13) AND (S <> '') THEN
BEGIN
IF (S = '-') THEN
BEGIN
BackSpace;
S := '';
SaveS := '';
END
ELSE
GotCmd := TRUE;
END;
IF (Length(s) < Length(SaveS)) THEN
BackSpace;
IF (Length(s) > Length(SaveS)) THEN
Prompt(s[Length(s)]);
UNTIL (GotCmd) OR (HangUp);
IF (General.UseMsgAreaLightBar) AND (MsgAreaLightBar IN ThisUser.SFlags) THEN
BEGIN
SaveX := WhereX;
SaveY := WhereY;
ANSIG(LightBarArray[LightBarCmd].XPos,LightBarArray[LightBarCmd].YPos);
SetC(10);
Prompt(PadLeftStr(LightBarArray[LightBarCmd].CmdToShow,32));
ANSIG(SaveX,SaveY);
END;
UserColor(1);
NL;
END;
END.

1029
SOURCE/CUSER.PAS Normal file
View File

File diff suppressed because it is too large Load Diff

772
SOURCE/DOORS.PAS Normal file
View File

@ -0,0 +1,772 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S+,V-}
UNIT Doors;
INTERFACE
USES
Common;
PROCEDURE DoDoorFunc(DropFileType: Char; MenuOption: Str50);
IMPLEMENTATION
USES
ExecBat,
Events,
File0,
Mail0,
SysOp12,
TimeFunc;
PROCEDURE ShowUserName(RName: Boolean; VAR First,Last: AStr);
BEGIN
First := '';
Last := '';
IF (RName) THEN
BEGIN
IF (Pos(' ',ThisUser.RealName) = 0) THEN
BEGIN
First := ThisUser.RealName;
Last := '';
END
ELSE
BEGIN
First := Copy(ThisUser.RealName,1,(Pos(' ',ThisUser.RealName) - 1));
Last := Copy(ThisUser.RealName,(Length(First) + 2),Length(ThisUser.RealName));
END;
END
ELSE
BEGIN
IF (Pos(' ',ThisUser.Name) = 0) THEN
BEGIN
First := ThisUser.Name;
Last := '';
END
ELSE
BEGIN
First := Copy(ThisUser.Name,1,(Pos(' ',ThisUser.Name) - 1));
Last := Copy(ThisUser.Name,(Length(First) + 2),Length(ThisUser.Name));
END;
END;
END;
(*
START POS SAVED
& LENGTH AS DESCRIPTION OF DATA
--------- ------ --------------------------------------------
1, 2 ASCII "-1" always used by FeatherNet PRO!
3, 2 ASCII " 0" always used By FeatherNet PRO!
5, 2 ASCII "-1" if page allowed or 0 if not.
7, 2 ASCII User Number in Users file
9, 1 ASCII "Y" if Expert or "N"if Not
10, 2 ASCII "-1" if Error Correcting modem, "0" if not
12, 1 ASCII "Y" if Graphics Mode or "N" if Not
13, 1 ASCII "A" is always placed here by FeatherNet PRO!
14, 5 ASCII The DTE speed or PC to Modem baud rate
19, 5 ASCII The connect baud rate:"300-38400" or "Local"
24, 2 MKI$ User's Record # in "USERS" file
26, 15 ASCII User's FIRST Name padded with spaces
41, 12 ASCII User's Password
53, 2 MKI$ Time user logged on in Mins: (60 x Hr)+Mins
55, 2 MKI$ User's Time on today in minutes
57, 5 ASCII Time user logged on in HH:MM format. Ex: "12:30"
62, 2 MKI$ Time user allowed today in minutes
64, 2 ASCII Daily D/L Limit from pwrd file
66, 1 Chr$ Conference the user has last joined
67, 5 Bitmap Areas user has been in
72, 5 Bitmap Areas user has scanned
77, 2 MKI$i An mki$(0) used by FeatherNet PRO!
79, 2 MKI$ Currently a value of 0 is here (MKI$(0))
81, 4 ASCII 4 Spaces are placed here
85, 25 ASCII User's Full name placed here.
110, 2 MKI$ Number of minutes user has left today
112, 1 chr$ Node user is on (actual character)
113, 5 ASCII Scheduled EVENT time
118, 2 ASCII A "-1" if EVENT is active or a " 0"
120, 2 ASCII " 0" is Placed here by FeatherNet PRO!
122, 4 MKS$ Time of day in secs format when user is on
126, 1 ASCII The Com port this node uses (0 - 8)
127, 2 ASCII Flag to let FNET PRO! know type of file xfer
129, 1 CHAR Ansi Detected Flag - Char[0] or Char[1]
130, 13 ASCII Unused by FeatherNet PRO! - SPACE filled
143, 2 MKI$ Last Area User was in (0 - 32766 possible)
145 BITMAP Not Currently Used by FeatherNet PRO!
--------------------------------------------------------------------------------
Some BASIC functions:
CHR$
Writes a character (8 bit value). One byte.
MKI$
Writes a short integer (16 bit value). Low byte then high byte.
MKS$
I didn't want to research this, and am writing four zeroes. Anyone know?
--------------------------------------------------------------------------------
*)
PROCEDURE Write_PCBoard_Sys(RName: Boolean);
VAR
DoorFile: FILE;
S,
UN: STRING[50];
i: Integer;
PROCEDURE Dump(x: STRING);
BEGIN
BlockWrite(DoorFile,x[1],Length(x));
END;
BEGIN
UN := AOnOff(RName,ThisUser.RealName,ThisUser.Name);
Assign(DoorFile,Liner.DoorPath+'PCBOARD.SYS');
ReWrite(DoorFile,1);
Dump(AOnOff(WantOut,'-1',' 0'));
Dump(AOnOff(FALSE,'-1',' 0'));
Dump(AOnOff(SysOpAvailable,'-1',' 0'));
Dump(' 0 ');
Dump(AOnOff(Reliable,'-1',' 0'));
Dump(Copy(ShowYesNo(OkANSI OR OKAvatar),1,1));
Dump('A');
Dump(PadLeftInt(ComPortSpeed,5));
Dump(AOnOff((ComPortSpeed = 0),'Local',PadLeftInt(ComPortSpeed,5)));
BlockWrite(DoorFile,UserNum,2);
Dump(PadLeftStr(Copy(UN,1,Pos(' ',UN) - 1),15));
Dump(PadLeftStr('PASSWORD',12));
i := 0;
BlockWrite(DoorFile,i,2);
BlockWrite(DoorFile,i,2);
Dump('00:00');
i := General.TimeAllow[ThisUser.SL];
BlockWrite(DoorFile,i,2);
i := General.DLKOneDay[ThisUser.SL];
BlockWrite(DoorFile,i,2);
Dump(#0#0#0#0#0#0);
Dump(Copy(S,1,5));
i := 0;
BlockWrite(DoorFile,i,2);
BlockWrite(DoorFile,i,2);
Dump(' ');
Dump(PadLeftStr(UN,25));
i := (NSL DIV 60);
BlockWrite(DoorFile,i,2);
Dump(Chr(ThisNode)+'00:00');
Dump(AOnOff(FALSE,'-1',' 0'));
Dump(AOnOff(FALSE,'-1',' 0'));
Dump(#0#0#0#0);
S := AOnOff((ComPortSpeed = 0),'0',IntToStr(Liner.Comport));
S := S[1]+#0#0;
IF (OkANSI OR OKAvatar) THEN
S := S + #1
ELSE
S := S + #0;
Dump(S);
Dump(DateStr);
i := 0;
BlockWrite(DoorFile,i,2);
Dump(#0#0#0#0#0#0#0#0#0#0);
Close(DoorFile);
LastError := IOResult;
END;
(*
Node name The name of the system.
Sysop f.name The sysop's name up to the first space.
Sysop l.name The sysop's name following the first space.
Com port The serial port the modem is connected to, or 0 if logged in on console.
Baud rate The current port (DTE) rate.
Networked The number "0"
User's first name The current user's name, up to the first space.
User's last name The current user's name, following the first space.
City Where the user lives, or a blank line if unknown.
Terminal type The number "0" if TTY, or "1" if ANSI.
Security level The number 5 for problem users, 30 for regular users, 80 for Aides, and 100 for Sysops.
Minutes remaining The number of minutes left in the current user's account, limited to 546 to keep from
overflowing other software.
FOSSIL The number "-1" if using an external serial driver or "0" if using internal serial routines.
*)
PROCEDURE Write_DorInfo1_Def(RName: Boolean);
VAR
DoorFile: Text;
First,
Last: AStr;
BEGIN
Assign(DoorFile,Liner.DoorPath+'DORINFO1.DEF');
ReWrite(DoorFile);
WriteLn(DoorFile,StripColor(General.BBSName));
First := Copy(General.SysOpName,1,(Pos(' ',General.SysOpName) - 1));
Last := SQOutSp(Copy(General.SysOpName,(Length(First) + 1),Length(General.SysOpName)));
WriteLn(DoorFile,First);
WriteLn(DoorFile,Last);
WriteLn(DoorFile,'COM'+AOnOff((ComPortSpeed = 0),'0',IntToStr(Liner.Comport)));
WriteLn(DoorFile,IntToStr(ComPortSpeed)+' BAUD,N,8,1');
WriteLn(DoorFile,'0');
ShowUserName(RName,First,Last);
WriteLn(DoorFile,AllCaps(First));
WriteLn(DoorFile,AllCaps(Last));
WriteLn(DoorFile,ThisUser.CityState);
WriteLn(DoorFile,AOnOff((OkANSI OR OKAvatar),'1','0'));
WriteLn(DoorFile,ThisUser.SL);
WriteLn(DoorFile,(NSL DIV 60));
WriteLn(DoorFile,'0');
Close(DoorFile);
LastError := IOResult;
END;
(*
0 Line 1 : Comm type (0=local, 1=serial, 2=telnet)
0 Line 2 : Comm or socket handle
38400 Line 3 : Baud rate
Mystic 1.07 Line 4 : BBSID (software name and version)
1 Line 5 : User record position (1-based)
James Coyle Line 6 : User's real name
g00r00 Line 7 : User's handle/alias
255 Line 8 : User's security level
58 Line 9 : User's time left (in minutes)
1 Line 10: Emulation *See Below
1 Line 11: Current node number
* The following are values we've predefined for the emulation:
0 = Ascii
1 = Ansi
2 = Avatar
3 = RIP
4 = Max Graphics { Not Used by RG }
*)
PROCEDURE Write_Door32_Sys(RName: Boolean);
VAR
DoorFile: Text;
FUNCTION ShowSpeed: AStr;
BEGIN
IF (TelNet) THEN
ShowSpeed := '2'
ELSE IF (ComportSpeed <> 0) THEN
ShowSpeed := '1'
ELSE
ShowSpeed := '0'
END;
FUNCTION ShowEmulation: AStr;
BEGIN
IF (OkRIP) THEN
ShowEmulation := '3'
ELSE IF (OKAvatar) THEN
ShowEmulation := '2'
ELSE IF (OkANSI) THEN
ShowEmulation := '1'
ELSE
ShowEmulation := '0';
END;
BEGIN
Assign(DoorFile,Liner.DoorPath+'DOOR32.SYS');
ReWrite(DoorFile);
WriteLn(DoorFile,ShowSpeed);
WriteLn(DoorFile,SockHandle);
WriteLn(DoorFile,ComPortSpeed);
WriteLn(DoorFile,'Renegade BBS '+General.Version); (* Was General.BBSName *)
WriteLn(DoorFile,UserNum);
WriteLn(DoorFile,ThisUser.RealName);
WriteLn(DoorFile,AOnOff(RName,ThisUser.RealName,Caps(ThisUser.Name))); (* Was AllCaps Name and force real name missing *)
WriteLn(DoorFile,ThisUser.SL);
WriteLn(DoorFile,(NSL DIV 60));
WriteLn(DoorFile,ShowEmulation); (* Was "1" *)
WriteLn(DoorFile,ThisNode);
Close(DoorFile);
END;
(*
COM1: <-- Comm Port - COM0: = LOCAL MODE
2400 <-- Baud Rate - 300 to 38400
8 <-- Parity - 7 or 8
1 <-- Node Number - 1 to 99 (Default to 1)
19200 <-- DTE Rate. Actual BPS rate to use. (kg)
Y <-- Screen Display - Y=On N=Off (Default to Y)
Y <-- Printer Toggle - Y=On N=Off (Default to Y)
Y <-- Page Bell - Y=On N=Off (Default to Y)
Y <-- Caller Alarm - Y=On N=Off (Default to Y)
Rick Greer <-- User Full Name
Lewisville, Tx. <-- Calling From
214 221-7814 <-- Home Phone
214 221-7814 <-- Work/Data Phone
PASSWORD <-- Password
110 *<-- Security Level
1456 <-- Total Times On
03/14/88 <-- Last Date Called
7560 <-- Seconds Remaining THIS call (for those that particular)
126 <-- Minutes Remaining THIS call
GR <-- Graphics Mode - GR=Graph, NG=Non-Graph, 7E=7,E Caller
23 <-- Page Length
Y <-- User Mode - Y = Expert, N = Novice
1,2,3,4,5,6,7 <-- Conferences/Forums Registered In (ABCDEFG)
7 <-- Conference Exited To \cf1\f1 DOOR\cf0 From (G)
01/01/99 <-- User Expiration Date (mm/dd/yy)
1 <-- User File's Record Number
Y <-- Default Protocol - X, C, Y, G, I, N, Etc.
0 *<-- Total Uploads
0 *<-- Total Downloads
0 *<-- Daily Download "K" Total
999999 <-- Daily Download Max. "K" Limit
10/22/88 <-- Caller's Birthdate (kg)
G:\\GAP\\MAIN <-- Path to the MAIN directory (where User File is) (kg)
G:\\GAP\\GEN <-- Path to the GEN directory (kg)
Michael <-- Sysop's Name (name \cf1 BBS\cf0 refers to Sysop as) (kg)
Stud <-- Alias name (rc)
00:05 <-- Event time (hh:mm) (rc)
Y <-- If its an error correcting connection (Y/N) (rc)
N <-- ANSI supported & caller using NG mode (Y/N) (rc)
Y <-- Use Record Locking (Y/N) (rc)
14 <-- \cf1 BBS\cf0 Default Color (Standard IBM color code, ie, 1-15) (rc)
10 *<-- Time Credits In Minutes (positive/negative) (rc)
07/07/90 <-- Last New \cf1 Files\cf0 Scan Date (mm/dd/yy) (rc)
14:32 <-- Time of This Call (hh:mm) (rc)
07:30 <-- Time of Last Call (hh:mm) (rc)
6 <-- Maximum daily \cf1 files\cf0 available (rc)
3 *<-- \cf1 Files\cf0 d/led so far today (rc)
23456 *<-- Total "K" Bytes Uploaded (rc)
76329 *<-- Total "K" Bytes Downloaded (rc)
A File Sucker <-- User Comment (rc)
10 <-- Total Doors Opened (rc)
10283 <-- Total Messages Left (rc)
*)
PROCEDURE Write_Door_Sys(RName: Boolean);
VAR
DoorFile: Text;
FUNCTION ShowEmulation: AStr;
BEGIN
IF (OkRIP) THEN
ShowEmulation := 'RIP'
ELSE IF (OkANSI OR OKAvatar) THEN
ShowEmulation := 'GR'
ELSE
ShowEmulation := 'NG';
END;
BEGIN
Assign(DoorFile,Liner.DoorPath+'DOOR.SYS');
ReWrite(DoorFile);
WriteLn(DoorFile,'COM'+AOnOff((ComPortSpeed = 0),'0',IntToStr(Liner.Comport))+':');
WriteLn(DoorFile,ActualSpeed);
WriteLn(DoorFile,'8');
WriteLn(DoorFile,ThisNode);
WriteLn(DoorFile,ComPortSpeed);
WriteLn(DoorFile,Copy(ShowYesNo(WantOut),1,1));
WriteLn(DoorFile,'N');
WriteLn(DoorFile,Copy(ShowYesNo(SysOpAvailable),1,1));
WriteLn(DoorFile,Copy(ShowYesNo(Alert IN ThisUser.Flags),1,1));
WriteLn(DoorFile,AOnOff(RName,ThisUser.RealName,Caps(ThisUser.Name))); (* ThisUser.Name Was All Caps *)
WriteLn(DoorFile,ThisUser.CityState);
WriteLn(DoorFile,Copy(ThisUser.Ph,1,3)+' '+Copy(ThisUser.Ph,5,8));
WriteLn(DoorFile,Copy(ThisUser.Ph,1,3)+' '+Copy(ThisUser.Ph,5,8));
WriteLn(DoorFile,'PASSWORD');
WriteLn(DoorFile,ThisUser.SL);
WriteLn(DoorFile,ThisUser.LoggedOn);
WriteLn(DoorFile,DoorToDate8(PD2Date(ThisUser.LastOn))); (* Used - vice / for separator *)
WriteLn(DoorFile,NSL);
WriteLn(DoorFile,(NSL DIV 60));
WriteLn(DoorFile,ShowEmulation);
WriteLn(DoorFile,ThisUser.PageLen);
WriteLn(DoorFile,Copy(ShowYesNo(Novice IN ThisUser.Flags),1,1));
WriteLn(DoorFile,ShowConferences); (* Was AR Flags *)
WriteLn(DoorFile,ThisUser.LastConf); (* Was 7 *)
WriteLn(DoorFile,DoorToDate8(PD2Date(ThisUser.Expiration))); (* Was 12/31/99 *)
WriteLn(DoorFile,UserNum);
WriteLn(DoorFile,'Z');
WriteLn(DoorFile,ThisUser.Uploads);
WriteLn(DoorFile,ThisUser.Downloads);
WriteLn(DoorFile,ThisUser.DLKToday);
WriteLn(DoorFile,General.DLKOneDay[ThisUser.SL]); (* Was 999999 *)
WriteLn(DoorFile,DoorToDate8(PD2Date(ThisUser.BirthDate))); (* Used - vice / for separator *)
WriteLn(DoorFile,General.DataPath); (* Was "\" *)
WriteLn(DoorFile,General.DataPath); (* Was "\" *)
WriteLn(DoorFile,General.SysOpName);
WriteLn(DoorFile,Caps(ThisUser.Name));
(* Fix - Event Time *)
WriteLn(DoorFile,'00:00');
WriteLn(DoorFile,Copy(ShowYesNo(Reliable),1,1));
WriteLn(DoorFile,Copy(ShowYesNo(ANSIDetected AND (ShowEmulation = 'NG')),1,1)); (* Was 'N'*)
WriteLn(DoorFile,Copy(ShowYesNo(General.MultiNode),1,1));
(* Fix - Default User Color *)
WriteLn(DoorFile,'3');
(* Fix - Time Credits In Minutes (Positive/Negative *)
WriteLn(DoorFile,'0');
WriteLn(DoorFile,DoorToDate8(PD2Date(NewFileDate))); (* Used - vice / for separator *)
WriteLn(DoorFile,PD2Time24(TimeOn)); (* Was TimeStr *)
WriteLn(DoorFile,PD2Time24(ThisUser.LastOn)); (* Was 00:00 *)
WriteLn(DoorFile,General.DLOneDay[ThisUser.SL]);
WriteLn(DoorFile,ThisUser.DLToday);
WriteLn(DoorFile,ThisUser.UK);
WriteLn(DoorFile,ThisUser.DK);
WriteLn(DoorFile,ThisUser.Note);
(* Fix - Total Doors Opened *)
WriteLn(DoorFile,'0');
(* Fix - Total Messages Left *)
WriteLn(DoorFile,'0'); (* Was 10 *)
Close(DoorFile);
LastError := IOResult;
END;
(*
1 User number
MRBILL User alias
Bill User real name
User callsign (HAM radio)
21 User age
M User sex
16097.00 User gold
05/19/89 User last logon date
80 User colums
25 User width
255 User security level (0-255)
1 1 if Co-SysOp, 0 if not
1 1 if SysOp, 0 if not
1 1 if ANSI, 0 if not
0 1 if at remote, 0 if local console
2225.78 User number of seconds left till logoff
F:\WWIV\GFILES\ System GFILES directory (gen. txt files)
F:\WWIV\DATA\ System DATA directory
890519.LOG System log of the day
2400 User baud rate
2 System com port
MrBill's Abode (the original) System name
The incredible inedible MrBill System SysOp
83680 Time user logged on/# of secs. from midn.
554 User number of seconds on system so far
5050 User number of uploaded k
22 User number of uploads
42 User amount of downloaded k
1 User number of downloads
8N1 User parity
2400 Com port baud rate
7400 WWIVnet node number
*)
PROCEDURE Write_Chain_Txt(RName: Boolean);
VAR
DoorFile: Text;
TUsed: LongInt;
BEGIN
Assign(DoorFile,Liner.DoorPath+'CHAIN.TXT');
ReWrite(DoorFile);
WriteLn(DoorFile,UserNum);
WriteLn(DoorFile,AOnOff(RName,ThisUser.RealName,Caps(ThisUser.Name))); (* Was AllCaps Name and force real name missing *)
WriteLn(DoorFile,ThisUser.RealName);
WriteLn(DoorFile,'');
WriteLn(DoorFile,AgeUser(ThisUser.BirthDate));
WriteLn(DoorFile,ThisUser.Sex);
(* What is gold ??? *)
WriteLn(DoorFile,'00.00');
WriteLn(DoorFile,DoorToDate8(PD2Date(ThisUser.LastOn))); (* Used "-" vice "/" *)
WriteLn(DoorFile,ThisUser.LineLen);
WriteLn(DoorFile,ThisUser.PageLen);
WriteLn(DoorFile,ThisUser.SL);
WriteLn(DoorFile,AOnOff(CoSysOp,'1','0')); (* Was Sysop *)
WriteLn(DoorFile,AOnOff(SysOp,'1','0')); (* Was CoSysOp *)
WriteLn(DoorFile,AOnOff((OkANSI OR OKAvatar),'1','0'));
WriteLn(DoorFile,AOnOff(InCom,'1','0'));
WriteLn(DoorFile,NSL);
WriteLn(DoorFile,General.DataPath);
WriteLn(DoorFile,General.DataPath);
WriteLn(DoorFile,General.LogsPath+'SYSOP.LOG'); (* Was missing path to the LOG *)
WriteLn(DoorFile,ComPortSpeed);
WriteLn(DoorFile,AOnOff((ComportSpeed = 0),'0',IntToStr(Liner.ComPort))); (* Was Liner.ComPort *)
WriteLn(DoorFile,StripColor(General.BBSName));
WriteLn(DoorFile,General.SysOpName);
(* Fix - Time user logged on/# of secs. from midnight *)
WriteLn(DoorFile,(GetPackDateTime - TimeOn));
(* Fix - User number of seconds on system so far *)
WriteLn(DoorFile,TUsed);
WriteLn(DoorFile,ThisUser.UK);
WriteLn(DoorFile,ThisUser.Uploads);
WriteLn(DoorFile,ThisUser.DK);
WriteLn(DoorFile,ThisUser.Downloads);
WriteLn(DoorFile,'8N1');
(* Fix - Com port baud rate *)
WriteLn(DoorFile,''); (* Line was missing *)
WriteLn(DoorFile,'0'); (* Line was missing *)
Close(DoorFile);
LastError := IOResult;
END;
(*
User's Name The name of the currently logged in user, with all color codes removed.
Speed The number 0 for 2400 baud, 1 for 300 baud, 2 for 1200 baud, 3 for 9600 baud, or 5 for console or
other speed.
City The last line of the user's mailing address that has data in it, or blank if no lines have data.
Security Level The number 5 for problem users, 30 for normal users, 80 for Aides, and 100 for Sysops.
Time left The time left in the user's accounts, in minutes. In an attempt to keep from overflowing other
software's limits, no value larger than 546 minutes is written.
ANSI Color The word "COLOR" if the current user has ANSI color enabled or "MONO" if he does not.
Password The current user's password (but not initials).
Userlog Number The current user's slot in LOG.DAT. (Not that this means anything to Citadel.)
Time used The number of minutes this call has lasted. If there is no user logged in, the number 0.
Unknown Citadel writes nothing out. Our information lists this field as being "01:23".
Unknown Citadel writes nothing out. Our information lists this field as being "01:23 01/02/90".
Unknown Citadel writes nothing out. Our information lists this field as being "ABCDEFGH".
Unknown Citadel writes nothing out. Our information lists this field as being "0".
Unknown Citadel writes nothing out. Our information lists this field as being "99".
Unknown Citadel writes nothing out. Our information lists this field as being "0".
Unknown Citadel writes nothing out. Our information lists this field as being "9999".
Phone number The current user's phone number.
Unknown Citadel writes nothing out. Our information lists this field as being "01/01/90 02:34".
Expert The word "EXPERT" if helpful hints are turned off or "NOVICE" if they are on.
File transfer protocol The name of the user's default file transfer protocol, or a blank line if none is specified.
Unknown Citadel writes nothing out. Our information lists this field as being "01/01/90".
Times on The number of times the current user has logged onto the system.
Lines per screen The number of lines per screen, or 0 if the current user has screen pause turned off.
Last message read The new message pointer for the current room.
Total uploads The total number of files the user has uploaded.
Total downloads The total number of files the user has downloaded.
Excessively Stupid!!! The text "8 { Databits }". (There are two spaces between the "8" and the "{".)
User's location The text "LOCAL if logged in on console, or "REMOTE" if logged in over the modem.
Port The text "COM" followed by the serial port number of the modem. (For example, "COM1" if the modem is
on the first serial port.)
Speed The number 0 for 2400 baud, 1 for 300 baud, 2 for 1200 baud, 3 for 9600 baud, or 5 for other speed.
No attention is paid to whether the user is on console or not.
Unknown Citadel writes nothing out. Our information lists this field as being "FALSE".
Another stupid thing The text "Normal Connection".
Unknown Citadel writes nothing out. Our information lists this field as being "01/02/94 01:20".
Task number Citadel writes the number 0.
Door number Citadel writes the number 1.
*)
PROCEDURE Write_CallInfo_BBS(RName: Boolean);
VAR
DoorFile: Text;
FUNCTION ShowSpeed: AStr;
BEGIN
IF (ComPortSpeed = 300) THEN
ShowSpeed := '1'
ELSE IF (ComPortSpeed = 1200) THEN
ShowSpeed := '2'
ELSE IF (ComPortSpeed = 2400) THEN
ShowSpeed := '0'
ELSE IF (ComPortSpeed = 9600) THEN
ShowSpeed := '3'
ELSE IF (ComPortSpeed = 0) THEN
ShowSpeed := '5'
ELSE
ShowSpeed := '4';
END;
BEGIN
Assign(DoorFile,Liner.DoorPath+'CALLINFO.BBS');
ReWrite(DoorFile);
WITH ThisUser DO
BEGIN
WriteLn(DoorFile,AOnOff(RName,AllCaps(ThisUser.RealName),AllCaps(ThisUser.Name)));
WriteLn(DoorFile,ShowSpeed);
WriteLn(DoorFile,AllCaps(ThisUser.CityState));
WriteLn(DoorFile,ThisUser.SL);
WriteLn(DoorFile,NSL DIV 60);
WriteLn(DoorFile,AOnOff((OkANSI OR OKAvatar),'COLOR','MONO'));
WriteLn(DoorFile,'PASSWORD');
WriteLn(DoorFile,UserNum);
WriteLn(DoorFile,'0');
WriteLn(DoorFile,Copy(TimeStr,1,5));
WriteLn(DoorFile,Copy(TimeStr,1,5)+' '+DateStr);
WriteLn(DoorFile,'A');
WriteLn(DoorFile,'0');
WriteLn(DoorFile,'999999');
WriteLn(DoorFile,'0');
WriteLn(DoorFile,'999999');
WriteLn(DoorFile,ThisUser.Ph);
WriteLn(DoorFile,ToDate8(PD2Date(ThisUser.LastOn))+' 00:00');
WriteLn(DoorFile,AOnOff((Novice IN ThisUser.Flags),'NOVICE','EXPERT'));
WriteLn(DoorFile,'All');
WriteLn(DoorFile,'01/01/80');
WriteLn(DoorFile,ThisUser.LoggedOn);
WriteLn(DoorFile,ThisUser.PageLen);
WriteLn(DoorFile,'0');
WriteLn(DoorFile,ThisUser.Uploads);
WriteLn(DoorFile,ThisUser.Downloads);
WriteLn(DoorFile,'8 { Databits }');
WriteLn(DoorFile,AOnOff((InCom OR OutCom),'REMOTE','LOCAL'));
WriteLn(DoorFile,'COM'+AOnOff((InCom OR OutCom),IntToStr(Liner.Comport),'0'));
WriteLn(DoorFile,PD2Date(ThisUser.BirthDate));
WriteLn(DoorFile,ComPortSpeed);
WriteLn(DoorFile,AOnOff((InCom OR OutCom),'TRUE','FALSE'));
WriteLn(DoorFile,AOnOff(Reliable,'MNP/ARQ','Normal')+' Connection');
WriteLn(DoorFile,'12/31/99 23:59');
WriteLn(DoorFile,ThisNode);
WriteLn(DoorFile,'1');
END;
Close(DoorFile);
LastError := IOResult;
END;
PROCEDURE Write_SFDoors_Dat(RName: Boolean);
VAR
DoorFile: Text;
S: AStr;
BEGIN
Assign(DoorFile,Liner.DoorPath+'SFDOORS.DAT');
ReWrite(DoorFile);
WriteLn(DoorFile,UserNum);
WriteLn(DoorFile,AOnOff(RName,AllCaps(ThisUser.RealName),AllCaps(ThisUser.Name)));
WriteLn(DoorFile,'PASSWORD');
IF (RName) THEN
BEGIN
IF (Pos(' ',ThisUser.RealName) = 0) THEN
S := ThisUser.RealName
ELSE
S := Copy(ThisUser.RealName,1,(Pos(' ',ThisUser.RealName) - 1));
END
ELSE
BEGIN
IF (Pos(' ',ThisUser.Name) = 0) THEN
S := ThisUser.Name
ELSE
S := Copy(ThisUser.Name,1,(Pos(' ',ThisUser.Name) - 1));
END;
WriteLn(DoorFile,S);
WriteLn(DoorFile,ComPortSpeed);
WriteLn(DoorFile,AOnOff((ComPortSpeed = 0),'0',IntToStr(Liner.Comport)));
WriteLn(DoorFile,NSL DIV 60);
WriteLn(DoorFile,Timer); { seconds since midnight }
WriteLn(DoorFile,StartDir);
WriteLn(DoorFile,AOnOff((OkANSI OR OKAvatar),'TRUE','FALSE'));
WriteLn(DoorFile,ThisUser.SL);
WriteLn(DoorFile,ThisUser.Uploads);
WriteLn(DoorFile,ThisUser.Downloads);
WriteLn(DoorFile,General.TimeAllow[ThisUser.SL]);
WriteLn(DoorFile,'0'); { time on (seconds) }
WriteLn(DoorFile,'0'); { extra time (seconds) }
WriteLn(DoorFile,'FALSE');
WriteLn(DoorFile,'FALSE');
WriteLn(DoorFile,'FALSE');
WriteLn(DoorFile,Liner.InitBaud);
WriteLn(DoorFile,AOnOff(Reliable,'TRUE','FALSE'));
WriteLn(DoorFile,'A');
WriteLn(DoorFile,'A');
WriteLn(DoorFile,ThisNode);
WriteLn(DoorFile,General.DLOneDay[ThisUser.SL]);
WriteLn(DoorFile,ThisUser.DLToday);
WriteLn(DoorFile,General.DLKOneDay[ThisUser.SL]);
WriteLn(DoorFile,ThisUser.DLKToday);
WriteLn(DoorFile,ThisUser.UK);
WriteLn(DoorFile,ThisUser.DK);
WriteLn(DoorFile,ThisUser.Ph);
WriteLn(DoorFile,ThisUser.CityState);
WriteLn(DoorFile,General.TimeAllow[ThisUser.SL]);
Close(DoorFile);
LastError := IOResult;
END;
PROCEDURE DoDoorFunc(DropFileType: Char; MenuOption: Str50);
VAR
Answer: AStr;
ReturnCode: Integer;
DoorTime: LongInt;
UseRealName: Boolean;
BEGIN
IF (MenuOption = '') AND (InCom) THEN
Exit;
SaveURec(ThisUser,UserNum);
UseRealName := FALSE;
IF (Copy(AllCaps(MenuOption),1,2) = 'R;') THEN
BEGIN
UseRealName := TRUE;
MenuOption := Copy(MenuOption,3,(Length(MenuOption) - 2));
END;
Answer := FunctionalMCI(MenuOption,'','');
CASE DropFileType OF
'3' : BEGIN
lStatus_Screen(100,'Outputting DOOR32.SYS ...',FALSE,Answer);
Write_Door32_Sys(UseRealName);
END;
'P' : BEGIN
lStatus_Screen(100,'Outputting PCBOARD.SYS ...',FALSE,Answer);
Write_PCBoard_Sys(UseRealName);
END;
'C' : BEGIN
lStatus_Screen(100,'Outputting CHAIN.TXT ...',FALSE,Answer);
Write_Chain_Txt(UseRealName);
END;
'D' : BEGIN
lStatus_Screen(100,'Outputting DORINFO1.DEF ...',FALSE,Answer);
Write_DorInfo1_Def(UseRealName);
END;
'G' : BEGIN
lStatus_Screen(100,'Outputting DOOR.SYS ...',FALSE,Answer);
Write_Door_Sys(UseRealName);
END;
'S' : BEGIN
lStatus_Screen(100,'Outputting SFDOORS.DAT ...',FALSE,Answer);
Write_SFDoors_Dat(UseRealName);
END;
'W' : BEGIN
lStatus_Screen(100,'Outputting CALLINFO.BBS ...',FALSE,Answer);
Write_CallInfo_BBS(UseRealName);
END;
END;
IF (Answer = '') THEN
Exit;
Shel('Running "'+Answer+'"');
SysOpLog('Opened door '+Answer+' on '+DateStr+' at '+TimeStr);
IF (General.MultiNode) THEN
BEGIN
LoadNode(ThisNode);
SaveNAvail := (NAvail IN NodeR.Status);
Exclude(NodeR.Status,NAvail);
SaveNode(ThisNode);
END;
DoorTime := GetPackDateTime;
ShellDos(FALSE,Answer,ReturnCode);
DoorTime := (GetPackDateTime - DoorTime);
Shel2(FALSE);
IF (General.MultiNode) THEN
BEGIN
LoadNode(ThisNode);
IF (SaveNAvail) THEN
Include(NodeR.Status,NAvail);
SaveNode(ThisNode);
END;
NewCompTables;
SaveGeneral(TRUE);
LoadURec(ThisUser,UserNum);
LoadFileArea(FileArea);
LoadMsgArea(MsgArea);
ChDir(StartDir);
Com_Flush_Recv;
SysOpLog('Returned on '+DateStr+' at '+TimeStr+'. Spent '+FormattedTime(DoorTime));
END;
END.

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.

1109
SOURCE/EMAIL.PAS Normal file
View File

File diff suppressed because it is too large Load Diff

258
SOURCE/EVENTS.PAS Normal file
View File

@ -0,0 +1,258 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S+,V-}
UNIT Events;
INTERFACE
FUNCTION InTime(Tim,Tim1,Tim2: LongInt): Boolean;
FUNCTION CheckPreEventTime(EventNum: Integer; T: LongInt): Boolean;
FUNCTION CheckEventTime(EventNum: Integer; T: LongInt): Boolean;
FUNCTION CheckEvents(T: LongInt): Integer;
FUNCTION SysOpAvailable: Boolean;
IMPLEMENTATION
USES
Dos,
Common,
TimeFunc
{$IFDEF WIN32}
,Windows
{$ENDIF}
;
FUNCTION InTime(Tim,Tim1,Tim2: LongInt): Boolean;
BEGIN
InTime := TRUE;
WHILE (Tim >= 86400) DO
Dec(Tim,86400);
IF (Tim1 <> Tim2) THEN
IF (Tim2 > Tim1) THEN
IF (Tim <= (Tim1 * 60)) OR (Tim >= (Tim2 * 60)) THEN
InTime := FALSE
ELSE
ELSE
IF (Tim <= (Tim1 * 60)) AND (Tim >= (Tim2 * 60)) THEN
InTime := FALSE;
END;
(*
function checkeventday(i:integer; t:longint):boolean;
var
year,month,day,dayofweek:word;
e:integer;
begin
e := 0;
checkeventday := FALSE;
if not events[i]^.active then
exit;
with events[i]^ do
begin
getdate(year,month,day,dayofweek);
if (timer + t >= 86400.0) then
begin
inc(dayofweek);
e := 1;
if (dayofweek > 6) then
dayofweek := 0;
end;
if (monthly) then
begin
if (value(copy(date,4,2)) + e = execdays) then
checkeventday := TRUE;
end
else
begin
e := 1 shl (dayofweek + 1);
if (execdays and e = e) then
checkeventday:=TRUE;
end;
end;
end;
*)
FUNCTION lCheckEventDay(EventNum: Integer; T: LongInt): Boolean;
VAR
DayOfWeek,
Day: Byte;
BEGIN
lCheckEventDay := FALSE;
WITH MemEventArray[EventNum]^ DO
BEGIN
IF (NOT (EventIsActive IN EFlags)) THEN
Exit;
Day := 0;
GetDayOfWeek(DayOfWeek);
IF ((Timer + T) >= 86400) THEN
BEGIN
Inc(DayOfWeek);
IF (DayOfWeek > 6) THEN
DayOfWeek := 0;
Day := 1;
END;
IF (EventIsMonthly IN EFlags) THEN
BEGIN
IF ((StrToInt(Copy(DateStr,4,2)) + Day) = MemEventArray[EventNum]^.EventDayOfMonth) THEN
lCheckEventDay := TRUE;
END
ELSE IF (DayOfWeek IN EventDays) THEN
lCheckEventDay := TRUE;
END;
END;
(*
function checkpreeventtime(i:integer; t:longint):boolean;
begin
with events[i]^ do
if (offhooktime = 0) or
(durationorlastday=daynum(date)) or
((Enode > 0) and (Enode <> node)) or
(not events[i]^.active) or not
(checkeventday(i,t)) then
checkpreeventtime:=FALSE
else
checkpreeventtime:=intime(timer+t,exectime-offhooktime,exectime);
end;
*)
FUNCTION CheckPreEventTime(EventNum: Integer; T: LongInt): Boolean;
BEGIN
WITH MemEventArray[EventNum]^ DO
IF (NOT (EventIsActive IN EFlags)) OR
(EventPreTime = 0) OR
(PD2Date(EventLastDate) = DateStr) OR
((EventNode > 0) AND (EventNode <> ThisNode)) OR
NOT (lCheckEventDay(EventNum,T)) THEN
CheckPreEventTime := FALSE
ELSE
CheckPreEventTime := InTime((Timer + T),(EventStartTime - EventPreTime),EventStartTime);
(*
checkpreeventtime := intime(timer + t,exectime-offhooktime,exectime);
*)
END;
(*
function checkeventtime(i:integer; t:longint):boolean;
begin
with events[i]^ do
if (durationorlastday=daynum(date)) or
((Enode > 0) and (Enode <> node)) or
(not events[i]^.active) or not
(checkeventday(i,t)) then
checkeventtime:=FALSE
else
if (etype in ['A','C']) then
checkeventtime:=intime(timer+t,exectime,exectime+durationorlastday)
else
if (missed) then
checkeventtime := (((timer + t) div 60) > exectime)
else
checkeventtime := (((timer + t) div 60) = exectime);
end;
*)
FUNCTION CheckEventTime(EventNum: Integer; T: LongInt): Boolean;
BEGIN
WITH MemEventArray[EventNum]^ DO
IF (PD2Date(EventLastDate) = DateStr) OR
((EventNode > 0) AND (EventNode <> ThisNode)) OR
(NOT (EventIsActive IN EFlags)) OR
NOT (lCheckEventDay(EventNum,T)) THEN
CheckEventTime := FALSE
ELSE
IF (EventIsLogon IN EFlags) OR (EventIsChat IN EFlags) THEN
CheckEventTime := InTime((Timer + T),EventStartTime,(EventStartTime + EventFinishTime))
(*
checkeventtime := intime(timer + t,exectime,exectime+durationorlastday)
*)
ELSE
IF (EventIsMissed IN EFlags) THEN
CheckEventTime := (((Timer + T) DIV 60) > EventStartTime)
ELSE
CheckEventTime := (((Timer + T) DIV 60) = EventStartTime);
END;
(*
function checkevents(t:longint):integer;
var i:integer;
begin
for i := 1 to numevents do
with events[i]^ do
if (active) and ((Enode = 0) or (Enode = node)) then
if (checkeventday(i,t)) then begin
if (softevent) and (not inwfcmenu) then
checkevents:=0
else
checkevents:=i;
if (checkpreeventtime(i,t)) or (checkeventtime(i,t)) then begin
if (etype in ['D','E','P']) then exit;
if ((etype='A') and (not aacs(execdata)) and (useron)) then exit;
end;
end;
checkevents:=0;
end;
*)
FUNCTION CheckEvents(T: LongInt): Integer;
VAR
EventNum: Integer;
BEGIN
FOR EventNum := 1 TO NumEvents DO
WITH MemEventArray[EventNum]^ DO
IF (EventIsActive IN EFlags) AND ((EventNode = 0) OR (EventNode = ThisNode)) THEN
IF (lCheckEventDay(EventNum,T)) THEN
BEGIN
IF (EventIsSoft IN EFlags) AND (NOT InWFCMenu) THEN
CheckEvents := 0
ELSE
CheckEvents := EventNum;
IF (CheckPreEventTime(EventNum,T)) OR (CheckEventTime(EventNum,T)) THEN
BEGIN
IF (EventIsExternal IN EFlags) THEN
IF (EventIsShell IN EFlags) OR
(EventIsErrorLevel IN EFlags) OR
(EventIsPackMsgAreas IN EFlags) OR
(EventIsSortFiles IN EFlags) OR
(EventIsFilesBBS IN EFlags) THEN
Exit;
IF ((EventIsLogon IN EFlags) AND (NOT AACS(EventACS)) AND (UserOn)) THEN
Exit;
END;
END;
CheckEvents := 0;
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;
FOR EventNum := 1 TO NumEvents DO
WITH MemEventArray[EventNum]^ DO
IF (EventIsActive IN EFlags) AND (EventIsChat IN EFlags) AND (CheckEventTime(EventNum,0)) THEN
ChatOk := TRUE;
SysOpAvailable := ChatOk;
END;
END.

229
SOURCE/EXECBAT.PAS Normal file
View File

@ -0,0 +1,229 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S+,V-}
UNIT ExecBat;
INTERFACE
USES
Common,
MyIO;
PROCEDURE ExecWindow(VAR Ok: Boolean;
CONST Dir,
BatLine: AStr;
OkLevel: Integer;
VAR RCode: Integer);
PROCEDURE ExecBatch(VAR Ok: Boolean;
Dir,
BatLine: AStr;
OkLevel: Integer;
VAR RCode: Integer;
Windowed: Boolean);
PROCEDURE Shel(CONST s: AStr);
PROCEDURE Shel2(x: Boolean);
IMPLEMENTATION
USES
Crt,
Dos;
VAR
CurInt21: Pointer;
WindPos,
WindLo,
WindHi: Word;
WindAttr: Byte;
SaveX,
SaveY: Byte;
SavCurWind: Integer;
{$IFDEF MSDOS}
{$L EXECWIN}
PROCEDURE SetCsInts; EXTERNAL;
PROCEDURE NewInt21; EXTERNAL;
{$ENDIF}
PROCEDURE ExecWindow(VAR Ok: Boolean;
CONST Dir,
BatLine: AStr;
OkLevel: Integer;
VAR RCode: Integer);
VAR
SaveWindowOn: Boolean;
SaveCurWindow: Byte;
s: AStr;
{-Exec a program in a Window}
{$IFDEF Ver70}
VAR
TmpInt21 : Pointer;
{$ENDIF}
BEGIN
SaveCurWindow := General.CurWindow;
SaveWindowOn := General.WindowOn;
General.WindowOn := TRUE;
SaveX := WhereX;
SaveY := WhereY;
SaveScreen(Wind);
ClrScr;
lStatus_Screen(1,'',FALSE,s);
{Store global copies of Window data for interrupt handler}
WindAttr := 7;
WindLo := WindMin;
WindHi := WindMax;
{$IFDEF MSDOS}
{Assure cursor is in Window}
INLINE
(
{;get cursor pos}
$B4/$03/ { mov ah,3}
$30/$FF/ { xor bh,bh}
$CD/$10/ { int $10}
{;assure it's within Window}
$8B/$0E/>WindLo/ { mov cx,[>windlo]}
$38/$EE/ { cmp dh,ch ;row above minimum?}
$73/$02/ { jae okxlo ;jump IF so}
$88/$EE/ { mov dh,ch}
{okxlo:}
$38/$CA/ { cmp dl,cl ;col above minimum?}
$73/$02/ { jae okylo ;jump IF so}
$88/$CA/ { mov dl,cl}
{okylo:}
$8B/$0E/>WindHi/ { mov cx,[>windhi]}
$38/$EE/ { cmp dh,ch ;row below maximum?}
$76/$02/ { jbe okxhi ;jump IF so}
$88/$EE/ { mov dh,ch}
{okxhi:}
$38/$CA/ { cmp dl,cl ;col below maximum?}
$76/$02/ { jbe okyhi ;jump IF so}
$88/$CA/ { mov dl,cl}
{okyhi:}
$89/$16/>WindPos/ { mov [>windpos],dx ;save current position}
{;position cursor}
$B4/$02/ { mov ah,2}
$30/$FF/ { xor bh,bh}
$CD/$10); { int $10}
{Take over interrupt}
GetIntVec($21,CurInt21);
SetCsInts;
SetIntVec($21,@NewInt21);
{$ENDIF}
{$IFDEF Ver70}
{Prevent SwapVectors from undoing our int21 change}
TmpInt21 := SaveInt21;
SaveInt21 := @NewInt21;
{$ENDIF}
{Exec the program}
ExecBatch(Ok,Dir,BatLine,OkLevel,RCode,TRUE);
{$IFDEF Ver70}
SaveInt21 := TmpInt21;
{$ENDIF}
Window(1,1,MaxDisplayCols,MaxDisplayRows);
RemoveWindow(Wind);
{$IFDEF MSDOS}
{Restore interrupt}
SetIntVec($21,CurInt21);
{$ENDIF}
General.CurWindow := SaveCurWindow;
General.WindowOn := SaveWindowOn;
LastScreenSwap := (Timer - 5);
lStatus_Screen(General.CurWindow,'',FALSE,s);
GoToXY(SaveX,SaveY);
END;
PROCEDURE ExecBatch(VAR Ok: Boolean; { result }
Dir: AStr; { directory takes place in }
BatLine: AStr; { .BAT file line to execute }
OkLevel: Integer; { DOS errorlevel for success }
VAR RCode: Integer; { errorlevel returned }
Windowed: Boolean); { Windowed? }
VAR
BatchFile: Text;
SaveDir: AStr;
BName: STRING[20];
BEGIN
BName := 'TEMP'+IntToStr(ThisNode)+'.BAT';
GetDir(0,SaveDir);
Dir := BSlash(FExpand(Dir),FALSE);
Assign(BatchFile,BName);
ReWrite(BatchFile);
WriteLn(BatchFile,'@ECHO OFF');
WriteLn(BatchFile,Chr(ExtractDriveNumber(Dir) + 64)+':');
IF (Dir <> '') THEN
WriteLn(BatchFile,'CD '+Dir);
IF (NOT WantOut) THEN
BatLine := BatLine + ' > NUL';
WriteLn(BatchFile,BatLine);
WriteLn(BatchFile,':DONE');
WriteLn(BatchFile,Chr(ExtractDriveNumber(SaveDir) + 64)+':');
WriteLn(BatchFile,'CD '+SaveDir);
WriteLn(BatchFile,'Exit');
Close(BatchFile);
IF (WantOut) AND (NOT Windowed) THEN
Shel(BatLine);
IF (NOT WantOut) THEN
BName := BName + ' > NUL';
ShellDOS(FALSE,BName,RCode);
Shel2(Windowed);
ChDir(SaveDir);
Kill(BName);
IF (OkLevel <> -1) THEN
Ok := (RCode = OkLevel)
ELSE
Ok := TRUE;
LastError := IOResult;
END;
PROCEDURE Shel(CONST s: AStr);
BEGIN
SavCurWind := General.CurWindow;
SaveX := WhereX;
SaveY := WhereY;
SetWindow(Wind,1,1,80,25,7,0,0);
ClrScr;
TextBackGround(1);
TextColor(15);
ClrEOL;
Write(s);
TextBackGround(0);
TextColor(7);
WriteLn;
END;
PROCEDURE Shel2(x: Boolean);
BEGIN
ClrScr;
RemoveWindow(Wind);
IF (x) THEN
Exit;
GoToXY(SaveX,SaveY);
LastScreenSwap := (Timer - 5);
END;
END.

609
SOURCE/FILE0.PAS Normal file
View File

@ -0,0 +1,609 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S+,V-}
UNIT File0;
INTERFACE
USES
Common;
FUNCTION CompFileArea(FArea,ArrayNum: Integer): Integer;
FUNCTION GetCPS(TotalBytes,TransferTime: LongInt): LongInt;
PROCEDURE CountDown;
FUNCTION Align(CONST FName: Str12): Str12;
FUNCTION BadDownloadPath: Boolean;
FUNCTION BadUploadPath: Boolean;
PROCEDURE DisplayFileInfo(VAR F: FileInfoRecordType; Editing: Boolean);
FUNCTION FileAreaAC(FArea: Integer): Boolean;
PROCEDURE ChangeFileArea(FArea: Integer);
PROCEDURE LoadFileArea(FArea: Integer);
FUNCTION GetDirPath(MemFileArea: FileAreaRecordType): ASTR;
PROCEDURE LoadNewScanFile(VAR NewScanFile: Boolean);
PROCEDURE SaveNewScanFile(NewScanFile: Boolean);
PROCEDURE InitFileArea(FArea: Integer);
FUNCTION Fit(CONST FileName1,FileName2: Str12): Boolean;
PROCEDURE GetFileName(VAR FileName: Str12);
FUNCTION ISUL(CONST s: AStr): Boolean;
FUNCTION IsWildCard(CONST s: AStr): Boolean;
PROCEDURE NRecNo(FileInfo: FileInfoRecordType; VAR RN: Integer);
PROCEDURE LRecNo(Fileinfo: FileInfoRecordType; VAR RN: Integer);
PROCEDURE RecNo(FileInfo: FileInfoRecordType; FileName: Str12; VAR RN: Integer);
PROCEDURE LoadVerbArray(F: FileInfoRecordType; VAR ExtArray: ExtendedDescriptionArray; VAR NumExtDesc: Byte);
PROCEDURE SaveVerbArray(VAR F: FileInfoRecordType; ExtArray: ExtendedDescriptionArray; NumExtDesc: Byte);
IMPLEMENTATION
USES
Dos,
File1,
ShortMsg,
TimeFunc
{$IFDEF WIN32}
,Windows
{$ENDIF}
;
FUNCTION CompFileArea(FArea,ArrayNum: Integer): Integer;
VAR
FileCompArrayFile: FILE OF CompArrayType;
CompFileArray: CompArrayType;
BEGIN
Assign(FileCompArrayFile,TempDir+'FACT'+IntToStr(ThisNode)+'.DAT');
Reset(FileCompArrayFile);
Seek(FileCompArrayFile,(FArea - 1));
Read(FileCompArrayFile,CompFileArray);
Close(FileCompArrayFile);
CompFileArea := CompFileArray[ArrayNum];
END;
FUNCTION GetCPS(TotalBytes,TransferTime: LongInt): LongInt;
BEGIN
IF (TransferTime > 0) THEN
GetCPS := (TotalBytes DIV TransferTime)
ELSE
GetCPS := 0;
END;
(* Done - 01/01/07 Lee Palmer *)
FUNCTION Align(CONST FName: Str12): Str12;
VAR
F: Str8;
E: Str3;
Counter,
Counter1: Byte;
BEGIN
Counter := Pos('.',FName);
IF (Counter = 0) THEN
BEGIN
F := FName;
E := ' ';
END
ELSE
BEGIN
F := Copy(FName,1,(Counter - 1));
E := Copy(FName,(Counter + 1),3);
END;
F := PadLeftStr(F,8);
E := PadLeftStr(E,3);
Counter := Pos('*',F);
IF (Counter <> 0) THEN
FOR Counter1 := Counter TO 8 DO
F[Counter1] := '?';
Counter := Pos('*',E);
IF (Counter <> 0) THEN
FOR Counter1 := Counter TO 3 DO
E[Counter1] := '?';
Counter := Pos(' ',F);
IF (Counter <> 0) THEN
FOR Counter1 := Counter TO 8 DO
F[Counter1] := ' ';
Counter := Pos(' ',E);
IF (Counter <> 0) THEN
FOR Counter1 := Counter TO 3 DO
E[Counter1] := ' ';
Align := F+'.'+E;
END;
FUNCTION BadDownloadPath: Boolean;
BEGIN
IF (BadDLPath) THEN
BEGIN
NL;
Print('^7File area #'+IntToStr(FileArea)+': Unable to perform command.');
SysOpLog('^5Bad DL file path: "'+MemFileArea.DLPath+'".');
Print('^5Please inform the SysOp.');
SysOpLog('Invalid DL path (File Area #'+IntToStr(FileArea)+'): "'+MemFileArea.DLPath+'"');
END;
BadDownloadPath := BadDLPath;
END;
FUNCTION BadUploadPath: Boolean;
BEGIN
IF (BadULPath) THEN
BEGIN
NL;
Print('^7File area #'+IntToStr(FileArea)+': Unable to perform command.');
SysOpLog('^5Bad UL file path: "'+MemFileArea.Ulpath+'".');
Print('^5Please inform the SysOp.');
SysOpLog('Invalid UL path (File Area #'+IntToStr(FileArea)+'): "'+MemFileArea.Ulpath+'"');
END;
BadUploadPath := BadULPath;
END;
FUNCTION FileAreaAC(FArea: Integer): Boolean;
BEGIN
FileAreaAC := FALSE;
IF (FArea < 1) OR (FArea > NumFileAreas) THEN
Exit;
LoadFileArea(FArea);
FileAreaAC := AACS(MemFileArea.ACS);
END;
PROCEDURE ChangeFileArea(FArea: Integer);
VAR
PW: Str20;
BEGIN
IF (FArea < 1) OR (FArea > NumFileAreas) OR (NOT FileAreaAC(FArea)) THEN
Exit;
IF (MemFileArea.Password <> '') AND (NOT SortFilesOnly) THEN
BEGIN
NL;
Print('File area: ^5'+MemFileArea.AreaName+' #'+IntToStr(CompFileArea(FArea,0))+'^1');
NL;
Prt('Password: ');
GetPassword(PW,20);
IF (PW <> MemFileArea.Password) THEN
BEGIN
NL;
Print('^7Incorrect password!^1');
Exit;
END;
END;
FileArea := FArea;
ThisUser.LastFileArea := FileArea;
END;
PROCEDURE LoadFileArea(FArea: Integer);
VAR
FO: Boolean;
BEGIN
IF (ReadFileArea = FArea) THEN
Exit;
IF (FArea < 1) THEN
Exit;
IF (FArea > NumFileAreas) THEN
BEGIN
MemFileArea := TempMemFileArea;
ReadFileArea := FArea;
Exit;
END;
FO := (FileRec(FileAreaFile).Mode <> FMClosed);
IF (NOT FO) THEN
BEGIN
Reset(FileAreaFile);
LastError := IOResult;
IF (LastError > 0) THEN
BEGIN
SysOpLog('FBASES.DAT/Open Error - '+IntToStr(LastError)+' (Procedure: LoadFileArea - '+IntToStr(FArea)+')');
Exit;
END;
END;
Seek(FileAreaFile,(FArea - 1));
LastError := IOResult;
IF (LastError > 0) THEN
BEGIN
SysOpLog('FBASES.DAT/Seek Error - '+IntToStr(LastError)+' (Procedure: LoadFileArea - '+IntToStr(FArea)+')');
Exit;
END;
Read(FileAreaFile,MemFileArea);
LastError := IOResult;
IF (LastError > 0) THEN
BEGIN
SysOpLog('FBASES.DAT/Read Error - '+IntToStr(LastError)+' (Procedure: LoadFileArea - '+IntToStr(FArea)+')');
Exit;
END
ELSE
ReadFileArea := FArea;
IF (NOT FO) THEN
BEGIN
Close(FileAreaFile);
LastError := IOResult;
IF (LastError > 0) THEN
BEGIN
SysOpLog('FBASES.DAT/Close Error - '+IntToStr(LastError)+' (Procedure: LoadFileArea - '+IntToStr(FArea)+')');
Exit;
END;
END;
LastError := IOResult;
END;
FUNCTION GetDirPath(MemFileArea: FileAreaRecordType): AStr;
BEGIN
IF (FADirDLPath IN MemFileArea.FAFlags) THEN
GetDirPath := MemFileArea.DLPath+MemFileArea.FileName
ELSE
GetDirPath := General.DataPath+MemFileArea.FileName;
END;
PROCEDURE LoadNewScanFile(VAR NewScanFile: Boolean);
VAR
FileAreaScanFile: FILE OF Boolean;
Counter: Integer;
BEGIN
Assign(FileAreaScanFile,GetDirPath(MemFileArea)+'.SCN');
Reset(FileAreaScanFile);
IF (IOResult = 2) THEN
ReWrite(FileAreaScanFile);
IF (UserNum > FileSize(FileAreaScanFile)) THEN
BEGIN
NewScanFile := TRUE;
Seek(FileAreaScanFile,FileSize(FileAreaScanFile));
FOR Counter := FileSize(FileAreaScanFile) TO (UserNum - 1) DO
Write(FileAreaScanFile,NewScanFile);
END
ELSE
BEGIN
Seek(FileAreaScanFile,(UserNum - 1));
Read(FileAreaScanFile,NewScanFile);
END;
Close(FileAreaScanFile);
LastError := IOResult;
END;
PROCEDURE SaveNewScanFile(NewScanFile: Boolean);
VAR
FileAreaScanFile: FILE OF Boolean;
BEGIN
Assign(FileAreaScanFile,GetDirPath(MemFileArea)+'.SCN');
Reset(FileAreaScanFile);
Seek(FileAreaScanFile,(UserNum - 1));
Write(FileAreaScanFile,NewScanFile);
Close(FileAreaScanFile);
LastError := IOResult;
END;
PROCEDURE InitFileArea(FArea: Integer);
BEGIN
LoadFileArea(FArea);
IF ((Length(MemFileArea.DLPath) = 3) AND (MemFileArea.DLPath[2] = ':') AND (MemFileArea.DLPath[3] = '\')) THEN
BadDLPath := NOT ExistDrive(MemFileArea.DLPath[1])
ELSE IF NOT (FACDRom IN MemFileArea.FAFlags) THEN
BadDLPath := NOT ExistDir(MemFileArea.DLPath)
ELSE
BadDLPath := FALSE;
IF ((Length(MemFileArea.ULPath) = 3) AND (MemFileArea.ULPath[2] = ':') AND (MemFileArea.DLPath[3] = '\')) THEN
BadULPath := NOT ExistDrive(MemFileArea.ULPath[1])
ELSE IF NOT (FACDRom IN MemFileArea.FAFlags) THEN
BadULPath := NOT ExistDir(MemFileArea.ULPath)
ELSE
BadULPath := FALSE;
IF (NOT DirFileOpen1) THEN
IF (FileRec(FileInfoFile).Mode <> FMClosed) THEN
Close(FileInfoFile);
DirFileOpen1 := FALSE;
Assign(FileInfoFile,GetDirPath(MemFileArea)+'.DIR');
Reset(FileInfoFile);
IF (IOResult = 2) THEN
ReWrite(FileInfoFile);
IF (IOResult <> 0) THEN
BEGIN
SysOpLog('Error opening file: '+GetDirPath(MemFileArea)+'.DIR');
Exit;
END;
IF (NOT ExtFileOpen1) THEN
IF (FileRec(ExtInfoFile).Mode <> FMClosed) THEN
Close(ExtInfoFile);
ExtFileOpen1 := FALSE;
Assign(ExtInfoFile,GetDirPath(MemFileArea)+'.EXT');
Reset(ExtInfoFile,1);
IF (IOResult = 2) THEN
ReWrite(ExtInfoFile,1);
IF (IOResult <> 0) THEN
BEGIN
SysOpLog('Error opening file: '+GetDirPath(MemFileArea)+'.EXT');
Exit;
END;
LoadNewScanFile(NewScanFileArea);
FileAreaNameDisplayed := FALSE;
END;
PROCEDURE DisplayFileInfo(VAR F: FileInfoRecordType; Editing: Boolean);
VAR
TempStr: AStr;
Counter,
NumLine,
NumExtDesc: Byte;
FUNCTION DisplayFIStr(FIFlags: FIFlagSet): AStr;
VAR
TempStr1: AStr;
BEGIN
TempStr1 := '';
IF (FINotVal IN FIFlags) THEN
TempStr1 := TempStr1 + ' ^8'+'<NV>';
IF (FIIsRequest IN FIFlags) THEN
TempStr1 := TempStr1 + ' ^9'+'Ask (Request File)';
IF (FIResumeLater IN FIFlags) THEN
TempStr1 := TempStr1 + ' ^7'+'Resume later';
IF (FIHatched IN FIFlags) THEN
TempStr1 := TempStr1 + ' ^7'+'Hatched';
DisplayFIStr := TempStr1;
END;
BEGIN
Counter := 1;
WHILE (Counter <= 7) AND (NOT Abort) AND (NOT HangUp) DO
BEGIN
WITH F DO
BEGIN
IF (Editing) THEN
TempStr := IntToStr(Counter)+'. '
ELSE
TempStr := '';
CASE Counter OF
1 : TempStr := TempStr + 'Filename : ^0'+SQOutSp(FileName);
2 : IF (NOT General.FileCreditRatio) THEN
TempStr := TempStr + 'File size : ^2'+ConvertBytes(FileSize,FALSE)
ELSE
TempStr := TempStr + 'File size : ^2'+ConvertKB(FileSize DIV 1024,FALSE);
3 : BEGIN
TempStr := TempStr + 'Description : ^9'+Description;
PrintACR('^1'+TempStr);
IF (F.VPointer <> -1) THEN
BEGIN
LoadVerbArray(F,ExtendedArray,NumExtDesc);
NumLine := 1;
WHILE (NumLine <= NumExtDesc) AND (NOT Abort) AND (NOT HangUp) DO
BEGIN
PrintACR('^1'+AOnOff(Editing,PadLeftStr('',3),'')
+AOnOff(Editing AND (NumLine = 1),PadLeftStr('Extended',13),PadLeftStr('',13))
+AOnOff(Editing,PadRightInt(NumLine,3),PadRightStr('',3))
+' : ^9'+ExtendedArray[NumLine]);
Inc(NumLine);
END;
END;
IF (Editing) THEN
IF (F.VPointer = -1) THEN
PrintACR('^5 No extended description.');
END;
4 : TempStr := TempStr + 'Uploaded by : ^4'+Caps(OwnerName);
5 : TempStr := TempStr + 'Uploaded on : ^5'+PD2Date(FileDate);
6 : BEGIN
TempStr := TempStr + 'Times downloaded : ^5'+FormatNumber(Downloaded);
PrintACR('^1'+TempStr);
IF (NOT Editing) THEN
BEGIN
TempStr := 'Block size : 128-"^5'+IntToStr(FileSize DIV 128)+
'^1" / 1024-"^5'+IntToStr(FileSize DIV 1024)+'^1"';
PrintACR('^1'+TempStr);
TempStr := 'Time to download : ^5'+CTim(FileSize DIV Rate);
PrintACR('^1'+TempStr);
END;
END;
7 : TempStr := TempStr + 'File point cost : ^4'+AOnOff((FilePoints > 0),FormatNumber(FilePoints),'FREE')+
DisplayFIStr(FIFlags);
END;
IF (NOT (Counter IN [3,6])) THEN
PrintACR('^1'+TempStr+'^1');
END;
Inc(Counter);
END;
END;
FUNCTION Fit(CONST FileName1,FileName2: Str12): Boolean;
VAR
Counter: Byte;
Match: Boolean;
BEGIN
Match := TRUE;
FOR Counter := 1 TO 12 DO
IF (FileName1[Counter] <> FileName2[Counter]) AND (FileName1[Counter] <> '?') THEN
Match := FALSE;
IF (FileName2 = '') THEN
Match := FALSE;
Fit := Match;
END;
PROCEDURE GetFileName(VAR FileName: Str12);
BEGIN
MPL(12);
InputMain(FileName,12,[NoLineFeed,UpperOnly]);
IF (FileName <> '') THEN
NL
ELSE
BEGIN
MPL(12);
FileName := '*.*';
Print(FileName);
END;
FileName := Align(FileName);
END;
FUNCTION ISUL(CONST s: AStr): Boolean;
BEGIN
ISUL := ((Pos('/',s) <> 0) OR (Pos('\',s) <> 0) OR (Pos(':',s) <> 0) OR (Pos('|',s) <> 0));
END;
FUNCTION IsWildCard(CONST S: AStr): Boolean;
BEGIN
IsWildCard := ((Pos('*',S) <> 0) OR (Pos('?',S) <> 0));
END;
PROCEDURE LRecNo(FileInfo: FileInfoRecordType; VAR RN: Integer);
VAR
DirFileRecNum: Integer;
BEGIN
RN := 0;
IF (LastDIRRecNum <= FileSize(FileInfoFile)) AND (LastDIRRecNum >= 0) THEN
BEGIN
DirFileRecNum := (LastDIRRecNum - 1);
WHILE (DirFileRecNum >= 0) AND (RN = 0) DO
BEGIN
Seek(FileInfoFile,DirFileRecNum);
Read(FileInfoFile,FileInfo);
IF Fit(LastDIRFileName,FileInfo.FileName) THEN
RN := DirFileRecNum;
Dec(DirFileRecNum);
END;
LastDIRRecNum := RN;
END
ELSE
RN := -1;
LastError := IOResult;
END;
PROCEDURE NRecNo(FileInfo: FileInfoRecordType; VAR RN: Integer);
VAR
DirFileRecNum: Integer;
BEGIN
RN := 0;
IF (LastDIRRecNum < FileSize(FileInfoFile)) AND (LastDIRRecNum >= -1) THEN
BEGIN
DirFileRecNum := (LastDIRRecNum + 1);
WHILE (DirFileRecNum < FileSize(FileInfoFile)) AND (RN = 0) DO
BEGIN
Seek(FileInfoFile,DirFileRecNum);
Read(FileInfoFile,FileInfo);
IF Fit(LastDIRFileName,FileInfo.FileName) THEN
RN := (DirFileRecNum + 1);
Inc(DirFileRecNum);
END;
Dec(RN);
LastDIRRecNum := RN;
END
ELSE
RN := -1;
LastError := IOResult;
END;
PROCEDURE RecNo(FileInfo: FileInfoRecordType; FileName: Str12; VAR RN: Integer);
VAR
DirFileRecNum: Integer;
BEGIN
InitFileArea(FileArea);
FileName := Align(FileName);
RN := 0;
DirFileRecNum := 0;
WHILE (DirFileRecNum < FileSize(FileInfoFile)) AND (RN = 0) DO
BEGIN
Seek(FileInfoFile,DirFileRecNum);
Read(FileInfoFile,FileInfo);
IF Fit(FileName,FileInfo.FileName) THEN
RN := (DirFileRecNum + 1);
Inc(DirFileRecNum);
END;
Dec(RN);
LastDIRRecNum := RN;
LastDIRFileName := FileName;
LastError := IOResult;
END;
PROCEDURE LoadVerbArray(F: FileInfoRecordType; VAR ExtArray: ExtendedDescriptionArray; VAR NumExtDesc: Byte);
VAR
VerbStr: AStr;
TotLoad: Integer;
VFO: Boolean;
BEGIN
FillChar(ExtArray,SizeOf(ExtArray),0);
NumExtDesc := 1;
VFO := (FileRec(ExtInfoFile).Mode <> FMClosed);
IF (NOT VFO) THEN
Reset(ExtInfoFile,1);
IF (IOResult = 0) THEN
BEGIN
TotLoad := 0;
Seek(ExtInfoFile,(F.VPointer - 1));
REPEAT
BlockRead(ExtInfoFile,VerbStr[0],1);
BlockRead(ExtInfoFile,VerbStr[1],Ord(VerbStr[0]));
Inc(TotLoad,(Length(VerbStr) + 1));
ExtArray[NumExtDesc] := VerbStr;
Inc(NumExtDesc);
UNTIL (TotLoad >= F.VTextSize);
IF (NOT VFO) THEN
Close(ExtInfoFile);
END;
Dec(NumExtDesc);
LastError := IOResult;
END;
PROCEDURE SaveVerbArray(VAR F: FileInfoRecordType; ExtArray: ExtendedDescriptionArray; NumExtDesc: Byte);
VAR
LineNum: Byte;
VFO: Boolean;
BEGIN
VFO := (FileRec(ExtInfoFile).Mode <> FMClosed);
IF (NOT VFO) THEN
Reset(ExtInfoFile,1);
IF (IOResult = 0) THEN
BEGIN
F.VPointer := (FileSize(ExtInfoFile) + 1);
F.VTextSize := 0;
Seek(ExtInfoFile,FileSize(ExtInfoFile));
FOR LineNum := 1 TO NumExtDesc DO
IF (ExtArray[LineNum] <> '') THEN
BEGIN
Inc(F.VTextSize,(Length(ExtArray[LineNum]) + 1));
BlockWrite(ExtInfoFile,ExtArray[LineNum],(Length(ExtArray[LineNum]) + 1));
END;
IF (NOT VFO) THEN
Close(ExtInfoFile);
END;
LastError := IOResult;
END;
PROCEDURE CountDown;
VAR
Cmd: Char;
Counter: Byte;
SaveTimer: LongInt;
BEGIN
NL;
Print('Press <^5CR^1> to logoff now.');
Print('Press <^5Esc^1> to abort logoff.');
NL;
Prompt('|12Hanging up in: ^99');
SaveTimer := Timer;
Cmd := #0;
Counter := 9;
WHILE (Counter > 0) AND NOT (Cmd IN [#13,#27]) AND (NOT HangUp) DO
BEGIN
IF (NOT Empty) THEN
Cmd := Char(InKey);
IF (Timer <> SaveTimer) THEN
BEGIN
Dec(Counter);
Prompt(^H+IntToStr(Counter));
SaveTimer := Timer;
END
ELSE
{$IFDEF MSDOS}
ASM
Int 28h
END;
{$ENDIF}
{$IFDEF WIN32}
Sleep(1);
{$ENDIF}
END;
IF (Cmd <> #27) THEN
BEGIN
HangUp := TRUE;
OutCom := FALSE;
END;
UserColor(1);
END;
END.

1588
SOURCE/FILE1.PAS Normal file
View File

File diff suppressed because it is too large Load Diff

910
SOURCE/FILE10.PAS Normal file
View File

@ -0,0 +1,910 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S+,V-}
UNIT File10;
INTERFACE
USES
Common;
PROCEDURE CreditFileOwner(VAR User: UserRecordType; VAR FileInfo: FileInfoRecordType; Credit: Boolean; GotPts: Integer);
PROCEDURE EditFile(DirFileRecNum: Integer; VAR Cmd: Char; NoPrompt,IsPoints: Boolean);
PROCEDURE EditFiles;
PROCEDURE ValidateFiles;
IMPLEMENTATION
USES
Dos,
ArcView,
Common5,
File0,
File1,
File2,
File9,
Mail1,
SysOp3,
TimeFunc,
MiscUser;
PROCEDURE CreditFileOwner(VAR User: UserRecordType; VAR FileInfo: FileInfoRecordType; Credit: Boolean; GotPts: Integer);
VAR
FilePointsReceived: Integer;
BEGIN
IF (AllCaps(FileInfo.OwnerName) <> AllCaps(User.Name)) THEN
BEGIN
NL;
Print('^7File owner name does not match user name!^1');
Exit;
END;
IF (NOT General.FileCreditRatio) THEN
GotPts := 0
ELSE IF (GotPts = 0) THEN
BEGIN
FilePointsReceived := 0;
IF (General.FileCreditCompBaseSize <> 0) THEN
FilePointsReceived := ((FileInfo.FileSize DIV 1024) DIV General.FileCreditCompBaseSize);
GotPts := (FilePointsReceived * General.FileCreditComp);
IF (GotPts < 1) THEN
GotPts := 1;
END;
NL;
Print(AOnOff(Credit,'^1Awarding upload','^1Removing upload')+' credits:'+
' ^51 file'+
', '+ConvertKB(FileInfo.FileSize DIV 1024,FALSE)+
', '+IntToStr(GotPts)+' file points.^1');
SysOpLog(AOnOff(Credit,'^1Awarding upload','^1Removing upload')+' credits:'+
' ^51 file'+
', '+ConvertKB(FileInfo.FileSize DIV 1024,FALSE)+
', '+IntToStr(GotPts)+' file points.^1');
IF (Credit) THEN
BEGIN
IF (User.Uploads < 2147483647) THEN
Inc(User.Uploads);
IF ((User.UK + (FileInfo.FileSize DIV 1024)) < 2147483647) THEN
Inc(User.UK,(FileInfo.FileSize DIV 1024))
ELSE
User.UK := 2147483647;
IF ((User.FilePoints + GotPts) < 2147483647) THEN
Inc(User.FilePoints,GotPts)
ELSE
User.FilePoints := 2147483647;
Include(FileInfo.FIFlags,FIOwnerCredited);
END
ELSE
BEGIN
IF (User.Uploads > 0) THEN
Dec(User.Uploads);
IF ((User.UK - (FileInfo.FileSize DIV 1024)) > 0) THEN
Dec(User.UK,(FileInfo.FileSize DIV 1024))
ELSE
User.UK := 0;
IF ((User.FilePoints - GotPts) > 0) THEN
Dec(User.FilePoints,GotPts)
ELSE
User.FilePoints := 0;
Exclude(FileInfo.FIFlags,FIOwnerCredited);
END;
SaveURec(User,FileInfo.OwnerNum);
END;
PROCEDURE EditFile(DirFileRecNum: Integer; VAR Cmd: Char; NoPrompt,IsPoints: Boolean);
VAR
FF: FILE;
ExtText: Text;
User: UserRecordType;
Mheader: MheaderRec;
InputStr,
MoveFromDir,
MoveToDir: AStr;
LineNum,
NumExtDesc: Byte;
UNum,
NewFileArea,
SaveFileArea,
FArea,
NumFAreas,
Totload,
SaveFArea: Integer;
FSize: Longint;
SaveConfSystem,
SaveTempPause,
DontShowList,
Ok: Boolean;
PROCEDURE ToggleFIFlag(FIFlagT: FileInfoFlagType; VAR FIFlagS: FIFlagSet);
BEGIN
IF (FIFlagT IN FIFlagS) THEN
Exclude(FIFlagS,FIFlagT)
ELSE
Include(FIFlagS,FIFlagT);
END;
PROCEDURE ToggleFIFlags(C: Char; VAR FIFlagS: FIFlagSet);
BEGIN
CASE C OF
'V' : ToggleFIFlag(FiNotVal,FIFlagS);
'T' : ToggleFIFlag(FiIsRequest,FIFlagS);
'R' : ToggleFIFlag(FIResumeLater,FIFlagS);
'H' : ToggleFIFlag(FIHatched,FIFlagS);
END;
END;
BEGIN
Seek(FileInfoFile,DirFileRecNum);
Read(FileInfoFile,FileInfo);
IF (IOResult <> 0) THEN
Exit;
IF (FileInfo.OwnerNum < 1) OR (FileInfo.OwnerNum > (MaxUsers - 1)) THEN
FileInfo.OwnerNum := 1;
LoadURec(User,FileInfo.OwnerNum);
IF (IsPoints) THEN
BEGIN
NL;
DisplayFileInfo(FileInfo,TRUE);
NL;
Prt('File points for file (^50^4-^5999^4,^5<CR>^4=^5Skip^4,^5Q^4=^5Quit^4): ');
MPL(3);
Input(InputStr,3);
IF (InputStr <> '') THEN
BEGIN
IF (InputStr = 'Q') THEN
BEGIN
NL;
Print('Aborted.');
Abort := TRUE
END
ELSE IF (StrToInt(InputStr) >= 0) AND (StrToInt(InputStr) <= 999) THEN
BEGIN
FileInfo.FilePoints := StrToInt(InputStr);
Exclude(FileInfo.FIFlags,FINotVal);
Seek(FileInfoFile,DirFileRecNum);
Write(FileInfoFile,FileInfo);
CreditFileOwner(User,FileInfo,TRUE,FileInfo.FilePoints);
IF (FileInfo.OwnerNum = UserNum) THEN
User.FilePoints := ThisUser.FilePoints;
NL;
Prt('File points for user (^5-'+IntToStr(User.FilePoints)+'^4 to ^5999^4): ');
MPL(4);
Input(InputStr,4);
IF (InputStr <> '') AND (StrToInt(InputStr) >= -User.FilePoints) AND (StrToInt(InputStr) <= 999) THEN
BEGIN
Inc(User.FilePoints,StrToInt(InputStr));
IF (FileInfo.OwnerNum = UserNum) THEN
ThisUser.FilePoints := User.FilePoints;
SaveURec(User,FileInfo.OwnerNum);
END;
END;
END;
Exit;
END;
IF (NoPrompt) THEN
BEGIN
Exclude(FileInfo.FIFlags,FINotVal);
Seek(FileInfoFile,DirFileRecNum);
Write(FileInfoFile,FileInfo);
CreditFileOwner(User,FileInfo,TRUE,0);
Exit;
END;
DontShowList := FALSE;
REPEAT
Abort := FALSE;
Next := FALSE;
IF (NOT DontShowList) THEN
BEGIN
NL;
DisplayFileInfo(FileInfo,TRUE);
Abort := FALSE;
END
ELSE
DontShowList := FALSE;
NL;
Abort := FALSE;
IF (Next) THEN
Cmd := 'N'
ELSE
BEGIN
Prt('Edit files (^5?^4=^5Help^4): ');
OneK(Cmd,'Q1234567DEGHIMNPRTUVW?'^M,TRUE,TRUE);
END;
CASE Cmd OF
'1' : BEGIN
NL;
Prt('New file name: ');
MPL((SizeOf(FileInfo.FileName) - 1));
Input(InputStr,(SizeOf(FileInfo.FileName) - 1));
IF (InputStr = '') THEN
BEGIN
NL;
Print('Aborted.');
END
ELSE IF (SQOutSp(InputStr) = SQOutSp(FileInfo.FileName)) THEN
BEGIN
NL;
Print('^7You must specify a different file name!^1');
END
ELSE IF (Exist(MemFileArea.DLPath+InputStr) OR Exist(MemFileArea.ULPath+InputStr)) THEN
BEGIN
NL;
Print('^7That file name exists in the download or upload path!^1');
END
ELSE
BEGIN
IF (NOT Exist(MemFileArea.DLPath+FileInfo.FileName)) OR
(NOT Exist(MemFileArea.ULPath+FileInfo.FileName)) THEN
BEGIN
NL;
Print('That file name does not exist in the download or upload path.');
Ok := FALSE;
IF (CoSysOp) THEN
BEGIN
IF (NOT (FIIsRequest IN FileInfo.FIFlagS)) THEN
BEGIN
NL;
IF (PYNQ('Do you want to set this file to offline? ',0,FALSE)) THEN
BEGIN
FileInfo.FileSize := 0;
Include(FileInfo.FIFlagS,FIIsRequest);
END;
END;
NL;
IF (PYNQ('Do you want to rename the file anyway? ', 0,FALSE)) THEN
Ok := TRUE;
END;
END;
IF (Ok) THEN
BEGIN
IF (Exist(MemFileArea.DLPath+FileInfo.FileName)) THEN
BEGIN
Assign(FF,MemFileArea.DLPath+FileInfo.FileName);
ReName(FF,MemFileArea.DLPath+InputStr);
END
ELSE IF (Exist(MemFileArea.ULPath+FileInfo.FileName)) THEN
BEGIN
Assign(FF,MemFileArea.ULPath+FileInfo.FileName);
ReName(FF,MemFileArea.ULPath+InputStr);
END;
LastError := IOResult;
FileInfo.FileName := Align(InputStr);
END;
END;
END;
'2' : BEGIN
NL;
Print('Limit on file size restricted to 1.9 Gig.');
OK := TRUE;
IF (NOT Exist(MemFileArea.DLPath+FileInfo.FileName)) OR (NOT Exist(MemFileArea.ULPath+FileInfo.FileName)) THEN
BEGIN
NL;
IF (PYNQ('File does not exist, set to offline? ',0,FALSE)) THEN
BEGIN
FSize := 0;
Include(FileInfo.FIFlags,FiIsRequest);
OK := FALSE;
END;
END;
IF (Ok) THEN
BEGIN
NL;
IF PYNQ('Update with actual file size? ', 0,FALSE) THEN
BEGIN
FSize := 0;
IF (Exist(MemFileArea.DLPath+FileInfo.FileName)) THEN
FSize := GetFileSize(MemFileArea.DLPath+SQOutSp(FileInfo.FileName))
ELSE IF (Exist(MemFileArea.ULPath+FileInfo.FileName)) THEN
FSize := GetFileSize(MemFileArea.ULPath+SqOutSp(FileInfo.FileName));
END
ELSE
BEGIN
FSize := FileInfo.FileSize;
InputLongIntWOC('%LFNew file size in bytes',FSize,[DisplayValue,NumbersOnly],0,2147483647);
END;
END;
IF (FSize >= 0) AND (FSize <= 2147483647) THEN
FileInfo.FileSize := FSize;
END;
'3' : BEGIN
NL;
Print('New description: ');
Prt(': ');
MPL((SizeOf(FileInfo.Description) - 1));
InputMain(FileInfo.Description,(SizeOf(FileInfo.Description) - 1),[InteractiveEdit]);
END;
'4' : BEGIN
LoadURec(User,FileInfo.OwnerNum);
IF (AllCaps(FileInfo.OwnerName) <> AllCaps(User.Name)) THEN
BEGIN
NL;
Print('Previous owner was '+Caps(FileInfo.OwnerName)+' #'+IntToStr(FileInfo.OwnerNum));
NL;
LoadURec(User,1);
FileInfo.OwnerNum := 1;
FileInfo.OwnerName := AllCaps(User.Name);
END;
NL;
Print('New owner user number or name ('+Caps(FileInfo.OwnerName)+' #'+IntToStr(FileInfo.OwnerNum)+'): ');
Prt(': ');
MPL((SizeOf(FileInfo.OwnerName) - 1));
FindUser(UNum);
IF (UNum <= 0) THEN
BEGIN
NL;
Print('User not found.');
END
ELSE
BEGIN
LoadURec(User,UNum);
FileInfo.OwnerNum := UNum;
FileInfo.OwnerName := AllCaps(User.Name);
END;
END;
'5' : BEGIN
NL;
Prt('New upload file date ('+PD2Date(FileInfo.FileDate)+'): ');
InputFormatted('',InputStr,'##-##-####',TRUE);
IF (InputStr = '') THEN
BEGIN
NL;
Print('Aborted.');
END
ELSE
BEGIN
IF (DayNum(InputStr) = 0) OR (DayNum(InputStr) > DayNum(DateStr)) THEN
BEGIN
NL;
Print('^7Invalid date entered!^1');
END
ELSE
FileInfo.FileDate := Date2PD(InputStr);
END;
END;
'6' : InputLongIntWOC('%LFNew number of downloads',FileInfo.DownLoaded,[DisplayValue,NumbersOnly],0,2147483647);
'7' : InputIntegerWOC('%LFNew amount of file points',FileInfo.FilePoints,[NumbersOnly],0,999);
'D' : IF PYNQ('%LFAre you sure? ',0,FALSE) THEN
BEGIN
Deleteff(FileInfo,DirFileRecNum);
InitFileArea(FileArea);
Dec(LastDIRRecNum);
InputStr := 'Removed "'+SQOutSp(FileInfo.FileName)+'" from '+MemFileArea.AreaName;
IF (Exist(MemFileArea.DLPath+FileInfo.FileName) OR Exist(MemFileArea.ULPath+FileInfo.FileName)) THEN
BEGIN
NL;
IF PYNQ('Erase file also? ',0,FALSE) THEN
BEGIN
Kill(MemFileArea.DLPath+FileInfo.FileName);
Kill(MemFileArea.ULPath+FileInfo.FileName);
InputStr := InputStr+' [FILE DELETED]'
END;
END;
IF (NOT (FIOwnerCredited IN FileInfo.FIFlags)) THEN
Print('%LF^7Owner did not receive upload credit for this file!^1')
ELSE IF PYNQ('%LFRemove from ^5'+Caps(User.Name)+' #'+IntToStr(FileInfo.OwnerNum)+'^7''s ratio? ',0,FALSE) THEN
CreditFileOwner(User,FileInfo,FALSE,FileInfo.FilePoints);
SysOpLog(InputStr);
Cmd := 'N';
END;
'E' : BEGIN
OK := TRUE;
IF (FileInfo.VPointer <> -1) THEN
BEGIN
IF (NOT PYNQ('%LFDelete the extended description for this file? ',0,FALSE)) THEN
LoadVerbArray(FileInfo,ExtendedArray,NumExtDesc)
ELSE
BEGIN
FileInfo.VPointer := -1;
FileInfo.VTextSize := 0;
OK := FALSE;
END;
END
ELSE
BEGIN
IF (NOT PYNQ('%LFCreate an extended description for this file? ',0,FALSE)) THEN
BEGIN
FileInfo.VPointer := -1;
FileInfo.VTextSize := 0;
OK := FALSE
END
ELSE
BEGIN
FillChar(ExtendedArray,SizeOf(ExtendedArray),0);
NumExtDesc := 1;
END;
END;
IF (Ok) THEN
BEGIN
Assign(ExtText,TempDir+MemFileArea.FileName+'.TMP');
ReWrite(ExtText);
LineNum := 0;
REPEAT
Inc(LineNum);
IF (ExtendedArray[LineNum] <> '') THEN
WriteLn(ExtText,ExtendedArray[LineNum]);
UNTIL (LineNum = NumExtDesc);
Close(ExtText);
MHeader.Status := [];
InResponseTo := '';
IF (InputMessage(TRUE,FALSE,'Extended Description',
MHeader,TempDir+MemFileArea.FileName+'.TMP',50,99)) then
IF Exist(TempDir+MemFileArea.FileName+'.TMP') THEN
BEGIN
FillChar(ExtendedArray,SizeOf(ExtendedArray),0);
Assign(ExtText,TempDir+MemFileArea.FileName+'.TMP');
Reset(ExtText);
NumExtDesc := 0;
REPEAT
ReadLn(ExtText,InputStr);
IF (InputStr <> '') THEN
BEGIN
Inc(NumExtDesc);
ExtendedArray[NumExtDesc] := InputStr;
END;
UNTIL (NumExtDesc = MaxExtDesc) OR EOF(ExtText);
Close(ExtText);
IF (ExtendedArray[1] <> '') THEN
SaveVerbArray(FileInfo,ExtendedArray,NumExtDesc);
END;
Kill(TempDir+MemFileArea.FileName+'.TMP');
END;
Cmd := #0;
END;
'G' : IF (NOT General.FileDiz) THEN
Print('%LF^7This option is not active in the System Configuration!^1')
ELSE
BEGIN
IF (Exist(MemFileArea.ULPath+FileInfo.FileName)) THEN
InputStr := MemFileArea.ULPath+SQOutSp(FileInfo.FileName)
ELSE
InputStr := MemFileArea.DLPath+SQOutSp(FileInfo.FileName);
IF (NOT DizExists(InputStr)) THEN
Print('%LFFile has no internal description.')
ELSE
BEGIN
GetDiz(FileInfo,ExtendedArray,NumExtDesc);
IF (ExtendedArray[1] <> '') THEN
SaveVerbArray(FileInfo,ExtendedArray,NumExtDesc)
ELSE
BEGIN
FileInfo.VPointer := -1;
FileInfo.VTextSize := 0;
END;
END;
END;
'H' : ToggleFIFlags('H',FileInfo.FIFlagS);
'I' : IF (NOT ValidIntArcType(FileInfo.FileName)) THEN
BEGIN
NL;
Print('^7Not a valid archive type or not supported!^1')
END
ELSE
BEGIN
OK := FALSE;
IF Exist(MemFileArea.DLPath+FileInfo.FileName) THEN
BEGIN
ViewInternalArchive(MemFileArea.DLPath+SQOutSp(FileInfo.FileName));
OK := TRUE;
END
ELSE IF Exist(MemFileArea.ULPath+FileInfo.FileName) THEN
BEGIN
ViewInternalArchive(MemFileArea.ULPath+SQOutSp(FileInfo.FileName));
OK := TRUE;
END;
IF (NOT Ok) THEN
BEGIN
NL;
IF (PYNQ('File does not exist, set to offline? ',0,FALSE)) THEN
BEGIN
FileInfo.FileSize := 0;
ToggleFIFlags('T',FileInfo.FIFlagS);
END;
END;
Abort := FALSE;
END;
'M' : BEGIN
SaveFileArea := FileArea;
SaveConfSystem := ConfSystem;
IF (SaveConfSystem) THEN
NewCompTables;
SaveTempPause := TempPause;
TempPause := FALSE;
FArea := 1;
NumFAreas := 0;
LightBarCmd := 1;
LightBarFirstCmd := TRUE;
InputStr := '?';
REPEAT
SaveFArea := FArea;
IF (InputStr = '?') THEN
LFileAreaList(FArea,NumFAreas,5,FALSE);
{
%LFMove to which file area? (^5'+IntToStr(LowFileArea)+'^4-^5'+IntToStr(HighFileArea)+'^4)
[^5#^4,^5?^4=^5Help^4,^5Q^4=^5Quit^4]: @
}
FileAreaScanInput(LRGLngStr(76,TRUE),Length(IntToStr(HighFileArea)),InputStr,'Q[]?',LowFileArea,HighFileArea);
IF (InputStr <> 'Q') THEN
BEGIN
IF (InputStr = '[') THEN
BEGIN
Farea := (SaveFArea - ((PageLength - 5) * 2));
IF (FArea < 1) THEN
FArea := 1;
InputStr := '?';
END
ELSE IF (InputStr = ']') THEN
BEGIN
IF (FArea > NumFileAreas) THEN
FArea := SaveFArea;
InputStr := '?';
END
ELSE IF (InputStr = '?') THEN
BEGIN
{
$File_Message_Area_List_Help
%LF^1(^3###^1)Manual entry selection ^1(^3<CR>^1)Select current entry
^1(^3<Home>^1)First entry on page ^1(^3<End>^1)Last entry on page
^1(^3Left Arrow^1)Previous entry ^1(^3Right Arrow^1)Next entry
^1(^3Up Arrow^1)Move up ^1(^3Down Arrow^1)Move down
^1(^3[^1)Previous page ^1(^3]^1)Next page
%PA
}
LRGLngStr(71,FALSE);
FArea := SaveFArea;
END
ELSE IF (StrToInt(InputStr) < LowFileArea) OR (StrToInt(InputStr) > HighFileArea) THEN
BEGIN
NL;
Print('^7The range must be from '+IntToStr(LowFileArea)+' to '+IntToStr(HighFileArea)+'!^1');
PauseScr(FALSE);
InputStr := '?';
FArea := SaveFArea;
END
ELSE IF (StrToInt(InputStr) = FileArea) THEN
BEGIN
NL;
Print('^7You can not move a file to the same file area.^1');
PauseScr(FALSE);
InputStr := '?';
FArea := SaveFArea;
END
ELSE
BEGIN
NewFileArea := CompFileArea(StrToInt(InputStr),1);
IF (FileArea <> NewFileArea) THEN
ChangeFileArea(NewFileArea);
IF (FileArea <> NewFileArea) THEN
BEGIN
NL;
Print('^7You do not have access to this file area!^1');
PauseScr(FALSE);
InputStr := '?';
FArea := SaveFArea;
END
ELSE
BEGIN
FileArea := SaveFileArea;
LoadFileArea(FileArea);
IF Exist(MemFileArea.DLPath+FileInfo.FileName) THEN
MoveFromDir := MemFileArea.DLPath
ELSE
MoveFromDir := MemFileArea.ULPath;
LoadFileArea(NewFileArea);
MoveToDir := MemFileArea.ULPath;
NL;
IF (NOT PYNQ('Move file to '+MemFileArea.AreaName+'? ',0,FALSE)) THEN
BEGIN
InputStr := '?';
FArea := SaveFArea;
END
ELSE
BEGIN
OK := TRUE;
IF Exist(MoveToDir+SQoutSp(FileInfo.FileName)) THEN
BEGIN
NL;
Print('^7The file exists in the upload path!^1');
OK := FALSE;
END
ELSE IF (NOT Exist(MoveFromDir+SQOutSp(FileInfo.FileName))) THEN
BEGIN
NL;
Print('^7The file does not exist in the download path!^1');
OK := FALSE;
END;
IF (Ok) THEN
BEGIN
NL;
CopyMoveFile(FALSE,'^5Moving file: ',
MoveFromDir+SQOutSp(FileInfo.FileName),
MoveToDir+SQOutSp(FileInfo.FileName),
TRUE);
END;
NL;
Prompt('^5Moving records: ');
FileArea := SaveFileArea;
InitFileArea(FileArea);
IF (BadDownloadPath) THEN
Exit;
IF (FileInfo.VPointer <> -1) THEN
LoadVerbArray(FileInfo,ExtendedArray,NumExtDesc);
Deleteff(FileInfo,DirFileRecNum);
FileArea := NewFileArea;
InitFileArea(FileArea);
IF (BadDownloadPath) THEN
Exit;
IF (FileInfo.VPointer <> - 1) THEN
SaveVerbArray(FileInfo,ExtendedArray,NumExtDesc);
Seek(FileInfoFile,FileSize(FileInfoFile));
Write(FileInfoFile,FileInfo);
FileArea := SaveFileArea;
InitFileArea(FileArea);
Dec(LastDIRRecNum);
Print('Done!^1');
Cmd := 'N';
END;
END;
FileArea := SaveFileArea;
LoadFileArea(FileArea);
END;
END;
IF (InputStr = 'Q') THEN
Cmd := 'N';
UNTIL (Cmd = 'N') OR (HangUp);
ConfSystem := SaveConfSystem;
IF (SaveConfSystem) THEN
NewCompTables;
TempPause := SaveTempPause;
FileArea := SaveFileArea;
LoadFileArea(FileArea);
END;
'P' : ;
'Q' : Abort := TRUE;
'R' : ToggleFIFlags('R',FileInfo.FIFlagS);
'T' : ToggleFIFlags('T',FileInfo.FIFlagS);
'U' : IF (NOT CoSysOp) THEN
BEGIN
NL;
Print('^7You do not have the required access level for this option!^1')
END
ELSE
BEGIN
IF (FileInfo.OwnerNum < 1) OR (FileInfo.OwnerNum > (MaxUsers - 1)) THEN
BEGIN
LoadURec(User,1);
FileInfo.OwnerNum := 1;
FileInfo.OwnerName := AllCaps(User.Name);
END;
UserEditor(FileInfo.OwnerNum);
END;
'V' : BEGIN
ToggleFIFlags('V',FileInfo.FIFlagS);
IF (FINotVal IN FileInfo.FIFlags) THEN
BEGIN
IF (NOT (FIOwnerCredited IN FileInfo.FIFlags)) THEN
Print('%LF^7Owner did not receive upload credit for this file!^1')
ELSE
CreditFileOwner(User,FileInfo,FALSE,FileInfo.FilePoints);
END
ELSE
CreditFileOwner(User,FileInfo,TRUE,0);
END;
'W' : IF (NOT (FIOwnerCredited IN FileInfo.FIFlags)) THEN
Print('%LF^7Owner did not receive upload credit for this file!^1')
ELSE IF PYNQ('%LFWithdraw credit? ',0,FALSE) THEN
CreditFileOwner(User,FileInfo,FALSE,FileInfo.FilePoints);
'?' : BEGIN
NL;
Print('^31-7^1:Modify item');
LCmds(18,3,'Move file','Delete file');
LCmds(18,3,'Extended edit','Hatched toggle');
LCmds(18,3,'Previous file','Next file');
LCmds(18,3,'Resume toggle','Toggle availability');
LCmds(18,3,'Validation toggle','Withdraw credit');
LCmds(18,3,'Internal listing','Get Description');
LCmds(18,3,'Uploader','Quit');
DontShowList := TRUE;
END;
^M : Cmd := 'N';
ELSE
Next := TRUE;
END;
IF (NOT (Cmd IN ['P','N','Q'])) THEN
BEGIN
Seek(FileInfoFile,DirFileRecNum);
Write(FileInfoFile,FileInfo);
END;
UNTIL (Cmd IN ['P','N','Q']) OR (Abort) OR (Next) OR (HangUp);
END;
PROCEDURE EditFiles;
VAR
FileName,
SaveLastDirFileName: Str12;
Cmd: Char;
DirFileRecNum,
SaveLastDirFileRecNum: Integer;
FO: Boolean;
BEGIN
NL;
Print('File editor:');
{ Print(FString.lGFNLine1); }
lRGLngStr(28,FALSE);
{ Prt(FString.GFNLine2); }
lRGLngStr(29,FALSE);
GetFileName(FileName);
IF (FileName = '') OR (Pos('.',FileName) = 0) THEN
BEGIN
NL;
Print('Aborted.');
END
ELSE
BEGIN
SaveLastDirFileRecNum := LastDIRRecNum;
SaveLastDirFileName := LastDIRFileName;
FO := (FileRec(FileInfoFile).Mode <> FMClosed);
IF (FO) THEN
BEGIN
Close(FileInfoFile);
Close(ExtInfoFile);
END;
RecNo(FileInfo,FileName,DirFileRecNum);
IF (BadDownloadPath) THEN
Exit;
IF (DirFileRecNum = -1) THEN
BEGIN
NL;
Print('No matching files.');
END
ELSE
BEGIN
Abort := FALSE;
Next := FALSE;
WHILE (DirFileRecNum <> -1) AND (NOT Abort) AND (NOT HangUp) DO
BEGIN
EditFile(DirFileRecNum,Cmd,FALSE,FALSE);
IF (Cmd = 'Q') THEN
Abort := TRUE
ELSE
BEGIN
IF (Cmd = 'P') THEN
LRecNo(FileInfo,DirFileRecNum)
ELSE
NRecNo(FileInfo,DirFileRecNum);
END;
WKey;
END;
END;
Close(FileInfoFile);
Close(ExtInfoFile);
IF (FO) THEN
InitFileArea(FileArea);
LastDIRRecNum := SaveLastDirFileRecNum;
LastDIRFileName := SaveLastDirFileName;
LastCommandOvr := TRUE;
END;
LastError := IOResult;
END;
PROCEDURE ValidateFiles;
VAR
Cmd: Char;
FArea,
SaveFileArea: Integer;
SaveConfSystem: Boolean;
PROCEDURE ValFiles(FArea: Integer; Cmd1: Char; NoPrompt,IsPoints: Boolean);
VAR
DirFileRecNum: Integer;
Found,
FirstOne: Boolean;
BEGIN
IF (FileArea <> FArea) THEN
ChangeFileArea(FArea);
IF (FileArea = FArea) THEN
BEGIN
RecNo(FileInfo,'*.*',DirFileRecNum);
IF (BadDownloadPath) THEN
Exit;
LIL := 0;
CLS;
Cmd1 := #0;
Found := FALSE;
FirstOne := TRUE;
Prompt('^1Scanning ^5'+MemFileArea.AreaName+' #'+IntToStr(CompFileArea(FileArea,0))+'^1 ...');
WHILE (DirFileRecNum <> -1) AND (NOT Abort) AND (NOT HangUp) DO
BEGIN
Seek(FileInfoFile,DirFileRecNum);
Read(FileInfoFile,FileInfo);
IF (FINotVal IN FileInfo.FIFlagS) AND (NOT (FIResumeLater IN FileInfo.FIFlagS)) THEN
BEGIN
IF (FirstOne) THEN
BEGIN
NL;
FirstOne := FALSE;
END;
EditFile(DirFileRecNum,Cmd1,NoPrompt,IsPoints);
Found := TRUE;
END;
IF (Cmd1 = 'P') THEN
BEGIN
REPEAT
LRecNo(FileInfo,DirFileRecNum);
UNTIL (DirFileRecNum = -1) OR ((FINotVal IN FileInfo.FIFlags) AND NOT (FIResumeLater IN FileInfo.FIFlags));
END
ELSE
NRecNo(FileInfo,DirFileRecNum);
WKey;
END;
IF (NOT Found) THEN
BEGIN
LIL := 0;
BackErase(15 + LennMCI(MemFileArea.AreaName) + Length(IntToStr(CompFileArea(FileArea,0))));
END;
Close(FileInfoFile);
Close(ExtInfoFile);
END;
LastError := IOResult;
END;
BEGIN
NL;
Print('^4[^5M^4]anual, [^5A^4]utomatic, [^5P^4]oint entry, [^5Q^4]uit');
NL;
Prt('File validation: ');
OneK(Cmd,'QMAP',TRUE,TRUE);
IF (Cmd <> 'Q') THEN
BEGIN
SaveFileArea := FileArea;
SaveConfSystem := ConfSystem;
ConfSystem := FALSE;
IF (SaveConfSystem) THEN
NewCompTables;
TempPause := (Cmd <> 'A');
Abort := FALSE;
Next := FALSE;
NL;
IF (NOT InWFCMenu) AND (NOT PYNQ('Search all file areas? ',0,TRUE)) THEN
ValFiles(FileArea,Cmd,(Cmd = 'A'),(Cmd = 'P'))
ELSE
BEGIN
FArea := 1;
WHILE (FArea >= 1) AND (FArea <= NumFileAreas) AND (NOT Next) AND (NOT Abort) AND (NOT HangUp) DO
BEGIN
ValFiles(FArea,Cmd,(Cmd = 'A'),(Cmd = 'P'));
WKey;
IF (Next) THEN
BEGIN
Abort := FALSE;
Next := FALSE;
END;
Inc(FArea);
END;
END;
ConfSystem := SaveConfSystem;
IF (SaveConfSystem) THEN
NewCompTables;
FileArea := SaveFileArea;
LoadFileArea(FileArea);
END;
LastError := IOResult;
END;
END.

1249
SOURCE/FILE11.PAS Normal file
View File

File diff suppressed because it is too large Load Diff

963
SOURCE/FILE12.PAS Normal file
View File

@ -0,0 +1,963 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S+,V-}
UNIT File12;
INTERFACE
USES
Common;
FUNCTION CheckBatchUL(FileName: Str12): Boolean;
PROCEDURE EditBatchULQueue;
PROCEDURE ListBatchULFiles;
PROCEDURE RemoveBatchULFiles;
PROCEDURE ClearBatchULQueue;
PROCEDURE BatchUpload(BiCleanUp: Boolean; TransferTime: LongInt);
PROCEDURE BatchDLULInfo;
IMPLEMENTATION
USES
Dos,
Common5,
ExecBat,
File0,
File1,
File2,
File4,
TimeFunc;
FUNCTION CheckBatchUL(FileName: Str12): Boolean;
VAR
RecNum: LongInt;
FileFound: Boolean;
BEGIN
FileFound := FALSE;
IF (NumBatchULFiles > 0) THEN
BEGIN
Assign(BatchULFile,General.DataPath+'BATCHUL.DAT');
Reset(BatchULFile);
RecNum := 1;
WHILE (RecNum <= FileSize(BatchULFile)) AND (NOT FileFound) DO
BEGIN
Seek(BatchULFile,(RecNum - 1));
Read(BatchULFile,BatchUL);
IF (BatchUL.BULUserNum = UserNum) AND (BatchUL.BULFileName = SQOutSp(FileName)) THEN
FileFound := TRUE;
Inc(RecNum);
END;
Close(BatchULFile);
LastError := IOResult;
END;
CheckBatchUL := FileFound;
END;
PROCEDURE EditBatchULQueue;
VAR
Cmd: Char;
BEGIN
IF (NumBatchULFiles = 0) THEN
BEGIN
NL;
Print('The batch upload queue is empty.');
Exit;
END;
REPEAT
NL;
Prt('Batch upoad queue [^5C^4]lear, [^5L^4]ist batch, [^5R^4]emove a file, [^5Q^4]uit: ');
OneK(Cmd,'QCLR',TRUE,TRUE);
CASE Cmd OF
'C' : ClearBatchULQueue;
'L' : ListBatchULFiles;
'R' : RemoveBatchULFiles;
END;
UNTIL (Cmd = 'Q') OR (HangUp);
END;
PROCEDURE ListBatchULFiles;
VAR
TempStr: STRING;
FileNumToList: Byte;
TempBULVTextSize: Integer;
RecNum: LongInt;
BEGIN
IF (NumBatchULFiles = 0) THEN
BEGIN
NL;
Print('The batch upload queue is empty.');
Exit;
END;
Abort := FALSE;
Next := FALSE;
NL;
PrintACR('^4###:Filename.Ext Area Description^1');
PrintACR('^4===:============:=====:==================================================^1');
Assign(BatchULFile,General.DataPath+'BATCHUL.DAT');
Reset(BatchULFile);
Assign(BatchULF,General.DataPath+'BATCHUL.EXT');
Reset(BatchULF,1);
FileNumToList := 1;
RecNum := 1;
WHILE (RecNum <= FileSize(BatchULFile)) AND (NOT Abort) AND (NOT HangUp) DO
BEGIN
Seek(BatchULFile,(RecNum - 1));
Read(BatchULFile,BatchUL);
IF (BatchUL.BULUserNum = UserNum) THEN
BEGIN
PrintACR('^3'+PadRightInt(FileNumToList,3)+
'^4:^5'+Align(BatchUL.BULFileName)+
' '+AOnOff((BatchUL.BULSection = General.ToSysOpDir),'^7SysOp',PadRightInt(BatchUL.BULSection,5))+
' ^3'+BatchUL.BULDescription);
IF (BatchUL.BULVPointer <> -1) THEN
BEGIN
TempBULVTextSize := 0;
Seek(BatchULF,(BatchUL.BULVPointer - 1));
REPEAT
BlockRead(BatchULF,TempStr[0],1);
BlockRead(BatchULF,TempStr[1],Ord(TempStr[0]));
Inc(TempBULVTextSize,(Length(TempStr) + 1));
PrintACR('^3'+PadRightStr(TempStr,24)+'^1');
UNTIL (TempBULVTextSize >= BatchUL.BULVTextSize);
END;
Inc(FileNumToList);
END;
WKey;
Inc(RecNum);
END;
Close(BatchULFile);
Close(BatchULF);
LastError := IOResult;
PrintACR('^4===:============:=====:==================================================^1');
SysOpLog('Viewed the batch upload queue.');
END;
PROCEDURE RemoveBatchULFiles;
VAR
BatchULF1: FILE;
BatchUL1: BatchULRecordType;
TempStr: STRING;
InputStr: Str3;
Counter,
FileNumToRemove: Byte;
TotLoad: Integer;
TempVPointer,
RecNum,
RecNum1: LongInt;
BEGIN
IF (NumBatchULFiles = 0) THEN
BEGIN
NL;
Print('The batch upload queue is empty.');
Exit;
END;
InputStr := '?';
REPEAT
IF (InputStr = '?') THEN
ListBatchULFiles;
NL;
Prt('File to remove? (^51^4-^5'+IntToStr(NumBatchULFiles)+'^4) [^5?^4=^5List^4,^5<CR>^4=^5Quit^4]: ');
MPL(Length(IntToStr(NumBatchULFiles)));
ScanInput(InputStr,^M'?');
FileNumToRemove := StrToInt(InputStr);
IF (NOT (InputStr[1] IN ['?','-',^M])) THEN
IF (FileNumToRemove < 1) OR (FileNumToRemove > NumBatchULFiles) THEN
BEGIN
NL;
Print('^7The range must be from 1 to '+IntToStr(NumBatchULFiles)+'!^1');
InputStr := '?';
END
ELSE
BEGIN
Counter := 0;
Assign(BatchULFile,General.DataPath+'BATCHUL.DAT');
Reset(BatchULFile);
RecNum := 1;
WHILE (RecNum <= FileSize(BatchULFile)) DO
BEGIN
Seek(BatchULFile,(RecNum - 1));
Read(BatchULFile,BatchUL);
IF (BatchUL.BULUserNum = UserNum) THEN
BEGIN
Inc(Counter);
IF (Counter = FileNumToRemove) THEN
BEGIN
BatchUL.BULVPointer := -1;
BatchUL.BULVTextSize := 0;
Seek(BatchULFile,(RecNum - 1));
Write(BatchULFile,BatchUL);
Dec(NumBatchULFiles);
NL;
Print('Removed from batch upload queue: "^5'+BatchUL.BULFileName+'^1".');
SysOpLog('Batch UL Remove: "^5'+BatchUL.BULFileName+'^1".');
Assign(BatchULF,General.DataPath+'BATCHUL.EXT');
Reset(BatchULF,1);
Assign(BatchULF1,General.DataPath+'BATCHUL.EX1');
ReWrite(BatchULF1,1);
FOR RecNum1 := 0 TO (FileSize(BatchULFile) - 1) DO
BEGIN
Seek(BatchULFile,RecNum1);
Read(BatchULFile,BatchUL1);
IF (BatchUL1.BULVPointer <> -1) THEN
BEGIN
TempVPointer := (FileSize(BatchULF1) + 1);
Seek(BatchULF1,FileSize(BatchULF1));
TotLoad := 0;
Seek(BatchULF,(BatchUL1.BULVPointer - 1));
REPEAT
BlockRead(BatchULF,TempStr[0],1);
BlockRead(BatchULF,TempStr[1],Ord(TempStr[0]));
Inc(TotLoad,(Length(TempStr) + 1));
BlockWrite(BatchULF1,TempStr,(Length(TempStr) + 1));
UNTIL (TotLoad >= BatchUL1.BULVTextSize);
BatchUL1.BULVPointer := TempVPointer;
Seek(BatchULFile,RecNum1);
Write(BatchULFile,BatchUL1);
END;
END;
Close(BatchULF);
Erase(BatchULF);
Close(BatchULF1);
ReName(BatchULF1,General.DataPath+'BATCHUL.EXT');
Dec(RecNum);
FOR RecNum1 := RecNum TO (FileSize(BatchULFile) - 2) DO
BEGIN
Seek(BatchULFile,(RecNum1 + 1));
Read(BatchULFile,BatchUL);
Seek(BatchULFile,RecNum1);
Write(BatchULFile,BatchUL);
END;
Seek(BatchULFile,(FileSize(BatchULFile) - 1));
Truncate(BatchULFile);
END;
END;
Inc(RecNum);
END;
Close(BatchULFile);
LastError := IOResult;
IF (NumBatchULFiles <> 0) THEN
BEGIN
NL;
Print('^1Batch upload queue: ^5'+IntToStr(NumBatchULFiles)+' '+Plural('file',NumBatchULFiles));
END
ELSE
BEGIN
NL;
Print('The batch upload queue is now empty.');
SysOpLog('Cleared the batch upload queue.');
END;
END;
UNTIL (InputStr <> '?') OR (HangUp);
END;
PROCEDURE ClearBatchULQueue;
VAR
BatchULF1: FILE;
BatchUL1: BatchULRecordType;
TempStr: STRING;
TotLoad: Integer;
TempVPointer,
RecNum,
RecNum1: LongInt;
BEGIN
IF (NumBatchULFiles = 0) THEN
BEGIN
NL;
Print('The batch upload queue is empty.');
Exit;
END;
NL;
IF PYNQ('Clear batch upload queue? ',0,FALSE) THEN
BEGIN
NL;
Assign(BatchULFile,General.DataPath+'BATCHUL.DAT');
Reset(BatchULFile);
RecNum := 1;
WHILE (RecNum <= FileSize(BatchULFile)) DO
BEGIN
Seek(BatchULFile,(RecNum - 1));
Read(BatchULFile,BatchUL);
IF (BatchUL.BULUserNum = UserNum) THEN
BEGIN
BatchUL.BULVPointer := -1;
BatchUL.BULVTextSize := 0;
Seek(BatchULFile,(RecNum - 1));
Write(BatchULFile,BatchUL);
Dec(NumBatchULFiles);
Assign(BatchULF,General.DataPath+'BATCHUL.EXT');
Reset(BatchULF,1);
Assign(BatchULF1,General.DataPath+'BATCHUL.EX1');
ReWrite(BatchULF1,1);
FOR RecNum1 := 0 TO (FileSize(BatchULFile) - 1) DO
BEGIN
Seek(BatchULFile,RecNum1);
Read(BatchULFile,BatchUL1);
IF (BatchUL1.BULVPointer <> -1) THEN
BEGIN
TempVPointer := (FileSize(BatchULF1) + 1);
Seek(BatchULF1,FileSize(BatchULF1));
TotLoad := 0;
Seek(BatchULF,(BatchUL1.BULVPointer - 1));
REPEAT
BlockRead(BatchULF,TempStr[0],1);
BlockRead(BatchULF,TempStr[1],Ord(TempStr[0]));
Inc(TotLoad,(Length(TempStr) + 1));
BlockWrite(BatchULF1,TempStr,(Length(TempStr) + 1));
UNTIL (TotLoad >= BatchUL1.BULVTextSize);
BatchUL1.BULVPointer := TempVPointer;
Seek(BatchULFile,RecNum1);
Write(BatchULFile,BatchUL1);
END;
END;
Close(BatchULF);
Erase(BatchULF);
Close(BatchULF1);
ReName(BatchULF1,General.DataPath+'BATCHUL.EXT');
Print('Removed from batch upload queue: "^5'+BatchUL.BULFileName+'^1".');
SysOpLog('Batch UL Remove: "^5'+BatchUL.BULFileName+'^1".');
Dec(RecNum);
FOR RecNum1 := RecNum TO (FileSize(BatchULFile) - 2) DO
BEGIN
Seek(BatchULFile,(RecNum1 + 1));
Read(BatchULFile,BatchUL);
Seek(BatchULFile,RecNum1);
Write(BatchULFile,BatchUL);
END;
Seek(BatchULFile,(FileSize(BatchULFile) - 1));
Truncate(BatchULFile);
END;
Inc(RecNum);
END;
Close(BatchULFile);
LastError := IOResult;
NL;
Print('The batch upload queue is now empty.');
SysOpLog('Cleared the batch upload queue.');
END;
END;
PROCEDURE BatchUpload(BiCleanUp: Boolean; TransferTime: LongInt);
TYPE
TotalsRecordType = RECORD
FilesUL,
FilesULCredit: Byte;
BytesUL,
BytesULCredit,
PointsULCredit: LongInt;
END;
VAR
Totals: TotalsRecordType;
BatchUL1: BatchULRecordType;
BatchULF1: FILE;
(*
DirInfo: SearchRec;
*)
TempStr: STRING;
InputStr: AStr;
LineNum,
FileNumToList,
NumExtDesc: Byte;
TotLoad,
ReturnCode,
ProtocolNumber,
SaveFArea,
SaveFileArea,
NumFAreas,
FArea,
TempBULVTextSize: Integer;
TempVPointer,
RecNum,
RecNum1,
RefundTime,
TakeAwayRefundTime,
TotConversionTime: LongInt;
AutoLogOff,
AHangUp,
WentToSysOp,
SaveTempPause,
SaveConfSystem: Boolean;
PROCEDURE UpFile;
VAR
GotPts: Integer;
ConversionTime: LongInt;
ArcOk,
Convt: Boolean;
BEGIN
InitFileArea(FileArea);
ArcStuff(ArcOk,Convt,FileInfo.FileSize,ConversionTime,TRUE,TempDir+'UP\',FileInfo.FileName,FileInfo.Description);
Inc(TotConversionTime,ConversionTime);
UpdateFileInfo(FileInfo,FileInfo.FileName,GotPts);
IF (ArcOk) THEN
BEGIN
NL;
Star('Moving file to ^5'+MemFileArea.AreaName);
NL;
IF CopyMoveFile(FALSE,'',SQOutSp(TempDir+'UP\'+FileInfo.FileName),
SQOutSp(MemFileArea.ULPath+FileInfo.FileName),FALSE) THEN
BEGIN
IF (Totals.FilesULCredit < 255) THEN
Inc(Totals.FilesULCredit);
IF ((Totals.BytesULCredit + FileInfo.FileSize) < 2147483647) THEN
Inc(Totals.BytesULCredit,FileInfo.FileSize)
ELSE
Totals.BytesULCredit := 2147483647;
IF ((Totals.PointsULCredit + GotPts) < 2147483647) THEN
Inc(Totals.PointsULCredit,GotPts)
ELSE
Totals.PointsULCredit := 2147483647;
IF (AACS(General.ULValReq)) OR (General.ValidateAllFiles) THEN
Include(FileInfo.FIFlags,FIOwnerCredited);
WriteFV(FileInfo,FileSize(FileInfoFile),ExtendedArray);
Star(SQOutSp(FileInfo.FileName)+' successfully uploaded.');
SysOpLog('^3Batch uploaded: "^5'+SQOutSp(FileInfo.FileName)+'^3" to ^5'+MemFileArea.AreaName+'.');
END;
END
ELSE
BEGIN
Star('Upload not received.');
IF ((FileInfo.FileSize DIV 1024) >= General.MinResume) THEN
BEGIN
NL;
IF PYNQ('Save file for a later resume? ',0,TRUE) THEN
BEGIN
NL;
IF CopyMoveFile(FALSE,'^5Progress: ',TempDir+'UP\'+FileInfo.FileName,MemFileArea.ULPath+FileInfo.FileName,TRUE) THEN
BEGIN
Include(FileInfo.FIFlags,FIResumeLater);
WriteFV(FileInfo,FileSize(FileInfoFile),ExtendedArray);
END;
END;
END;
IF (NOT (FIResumeLater IN FileInfo.FIFlags)) THEN
Kill(TempDir+'UP\'+FileInfo.FileName);
SysOpLog('^3Errors batch uploading '+SQOutSp(FileInfo.FileName)+' - '+
AOnOff(FIResumeLater IN FileInfo.FIFlags,'file saved for resume','file deleted'));
END;
IF (NOT ArcOk) AND (NOT BiCleanUp) THEN
BEGIN
Inc(TakeAwayRefundTime,(FileInfo.FileSize DIV Rate));
Star('Time refund of '+FormattedTime(FileInfo.FileSize DIV Rate)+' will be taken away.');
END;
END;
BEGIN
IF (NOT CheckDriveSpace('Batch upload',MemFileArea.ULPath,General.MinSpaceForUpload)) THEN
Exit;
SaveFileArea := FileArea;
AutoLogOff := FALSE;
IF (BiCleanUp) THEN
RefundTime := 0
ELSE
BEGIN
NL;
Print('^5Batch upload (Statistics):^1');
NL;
Star('^1Total file(s) : ^5'+FormatNumber(NumBatchULFiles)+'^1');
IF (NumBatchULFiles = 0) THEN
BEGIN
PrintF('BATCHUL0');
IF (NoFile) THEN
BEGIN
NL;
Print('Warning! No upload batch files specified yet.');
Print('If you continue, and batch upload files, you will have to');
Print('enter file descriptions for each file after the batch upload');
Print('is complete.');
END;
END
ELSE
BEGIN
PrintF('BATCHUL');
IF (NoFile) THEN
BEGIN
NL;
Print('^1If you batch upload files IN ADDITION to the files already');
Print('specified in your upload batch queue, you must enter file');
Print('descriptions for them after the batch upload is complete.');
END;
END;
ProtocolNumber := DoProtocol(Protocol,TRUE,FALSE,TRUE,FALSE);
CASE ProtocolNumber OF
-1 : ;
-2 : Exit;
-3 : ;
-4 : ;
-5 : EditBatchULQueue;
ELSE
IF (InCom) THEN
BEGIN
PurgeDir(TempDir+'UP\',FALSE);
NL;
AutoLogOff := PYNQ('Auto-logoff after file transfer? ',0,FALSE);
NL;
Star('Ready to receive batch upload transfer.');
TimeLock := TRUE;
ExecProtocol('',
TempDir+'UP\',
FunctionalMCI(Protocol.EnvCmd,'','')
+#13#10+
General.ProtPath+FunctionalMCI(Protocol.ULCmd,'',''),
-1,
ReturnCode,
TransferTime);
TimeLock := FALSE;
NL;
Star('Batch upload transfer complete.');
RefundTime := (TransferTime * (General.ULRefund DIV 100));
Inc(FreeTime,RefundTime);
END;
END;
END;
Assign(BatchULFile,General.DataPath+'BATCHUL.DAT');
Reset(BatchULFile);
FillChar(Totals,SizeOf(Totals),0);
FindFirst(TempDir+'UP\*.*',AnyFile - Directory - VolumeID - Dos.Hidden - SysFile ,DirInfo);
WHILE (DosError = 0) DO
BEGIN
Inc(Totals.FilesUL);
Inc(Totals.BytesUL,DirInfo.Size);
FindNext(DirInfo);
END;
IF (Totals.FilesUL = 0) THEN
BEGIN
NL;
Print('No uploads detected!^1');
Exit;
END;
AHangUp := FALSE;
IF (HangUp) THEN
BEGIN
IF (ComPortSpeed > 0) THEN
BEGIN
lStatus_Screen(100,'Hanging up and taking phone off hook...',FALSE,InputStr);
DoPhoneHangUp(FALSE);
DoPhoneOffHook(FALSE);
ComPortSpeed := 0;
END;
HangUp := FALSE;
AHangUp := TRUE;
END;
IF (NOT AHangUp) THEN
BEGIN
NL;
Print('^5Batch upload (Totals):^1');
NL;
Star('^1Total file(s) : ^5'+FormatNumber(Totals.FilesUL)+'^1');
Star('^1Total size : ^5'+ConvertBytes(Totals.BytesUL,FALSE)+'^1');
Star('^1Upload time : ^5'+FormattedTime(TransferTime)+'^1');
Star('^1Transfer rate : ^5'+FormatNumber(GetCPS(Totals.BytesUL,TransferTime))+' cps^1');
Star('^1Time refund : ^5'+FormattedTime(RefundTime)+'^1');
IF (AutoLogOff) THEN
CountDown;
END;
TotConversionTime := 0;
TakeAwayRefundTime := 0;
RecNum := 1;
WHILE (RecNum <= FileSize(BatchULFile)) DO
BEGIN
Seek(BatchULFile,(RecNum - 1));
Read(BatchULFile,BatchUL);
IF (BatchUL.BULUserNum = UserNum) AND Exist(TempDir+'UP\'+BatchUL.BULFileName) THEN
BEGIN
FileInfo.FileName := BatchUL.BULFileName;
FileArea := BatchUL.BULSection;
NL;
Star('Found: "^5'+FileInfo.FileName+'^1"');
IF (General.FileDiz) AND (DizExists(TempDir+'UP\'+FileInfo.FileName)) THEN
GetDiz(FileInfo,ExtendedArray,NumExtDesc)
ELSE
BEGIN
FileInfo.Description := BatchUL.BULDescription;
FillChar(ExtendedArray,SizeOf(ExtendedArray),#0);
IF (BatchUL.BULVPointer <> 0) THEN
BEGIN
Assign(BatchULF,General.DataPath+'BATCHUL.EXT');
Reset(BatchULF,1);
LineNum := 1;
TempBULVTextSize := 0;
Seek(BatchULF,(BatchUL.BULVPointer - 1));
REPEAT
BlockRead(BatchULF,TempStr[0],1);
BlockRead(BatchULF,TempStr[1],Ord(TempStr[0]));
Inc(TempBULVTextSize,(Length(TempStr) + 1));
ExtendedArray[LineNum] := TempStr;
Inc(LineNum);
UNTIL (TempBULVTextSize >= BatchUL.BULVTextSize);
BatchUL.BULVPointer := -1;
BatchUL.BULVTextSize := 0;
Seek(BatchULFile,(RecNum - 1));
Write(BatchULFile,BatchUL);
END;
END;
UpFile;
Reset(BatchULF,1);
Assign(BatchULF1,General.DataPath+'BATCHUL.EX1');
ReWrite(BatchULF1,1);
FOR RecNum1 := 0 TO (FileSize(BatchULFile) - 1) DO
BEGIN
Seek(BatchULFile,RecNum1);
Read(BatchULFile,BatchUL1);
IF (BatchUL1.BULVPointer <> -1) THEN
BEGIN
TempVPointer := (FileSize(BatchULF1) + 1);
Seek(BatchULF1,FileSize(BatchULF1));
TotLoad := 0;
Seek(BatchULF,(BatchUL1.BULVPointer - 1));
REPEAT
BlockRead(BatchULF,TempStr[0],1);
BlockRead(BatchULF,TempStr[1],Ord(TempStr[0]));
Inc(TotLoad,(Length(TempStr) + 1));
BlockWrite(BatchULF1,TempStr,(Length(TempStr) + 1));
UNTIL (TotLoad >= BatchUL1.BULVTextSize);
BatchUL1.BULVPointer := TempVPointer;
Seek(BatchULFile,RecNum1);
Write(BatchULFile,BatchUL1);
END;
END;
Close(BatchULF);
Erase(BatchULF);
Close(BatchULF1);
ReName(BatchULF1,General.DataPath+'BATCHUL.EXT');
Dec(RecNum);
IF (RecNum >= 0) AND (RecNum <= (FileSize(BatchULFile) - 2)) THEN
FOR RecNum1 := RecNum TO (FileSize(BatchULFile) - 2) DO
BEGIN
Seek(BatchULFile,(RecNum1 + 1));
Read(BatchULFile,BatchUL);
Seek(BatchULFile,RecNum1);
Write(BatchULFile,BatchUL);
END;
Seek(BatchULFile,(FileSize(BatchULFile) - 1));
Truncate(BatchULFile);
Dec(NumBatchULFiles);
END;
Inc(RecNum);
END;
FindFirst(TempDir+'UP\*.*',AnyFile - Directory - VolumeID - Dos.Hidden - SysFile,DirInfo);
WHILE (DosError = 0) DO
BEGIN
FileInfo.FileName := DirInfo.Name;
NL;
Star('Found: "^5'+FileInfo.FileName+'^1"');
IF (General.SearchDup) THEN
IF (NOT FileSysOp) OR (PYNQ('Search for duplicates? ',0,FALSE)) THEN
IF (SearchForDups(FileInfo.FileName)) THEN
Exit;
IF (General.SearchDup) AND (SearchForDups(FileInfo.FileName)) THEN
BEGIN
Star('Deleting duplicate file: "^5'+FileInfo.FileName+'^1"');
Kill(TempDir+'UP\'+FileInfo.FileName);
END
ELSE
BEGIN
WentToSysOp := FALSE;
IF (General.FileDiz) AND (DizExists(TempDir+'UP\'+FileInfo.FileName)) THEN
GetDiz(FileInfo,ExtendedArray,NumExtDesc)
ELSE
BEGIN
GetFileDescription(FileInfo,ExtendedArray,NumExtDesc,WentToSysOp);
IF (AHangUp) THEN
BEGIN
FileInfo.Description := 'Not in upload batch queue - hungup after transfer';
FillChar(ExtendedArray,SizeOf(ExtendedArray),#0);
END;
END;
IF (WentToSysOp) THEN
FileArea := General.ToSysOpDir
ELSE
BEGIN
IF (AHangUp) THEN
FArea := SaveFileArea
ELSE
BEGIN
SaveConfSystem := ConfSystem;
ConfSystem := FALSE;
IF (SaveConfSystem) THEN
NewCompTables;
SaveTempPause := TempPause;
TempPause := FALSE;
FArea := 1;
NumFAreas := 0;
LightBarCmd := 1;
LightBarFirstCmd := TRUE;
InputStr := '?';
REPEAT
SaveFArea := FArea;
IF (InputStr = '?') THEN
LFileAreaList(FArea,NumFAreas,5,FALSE);
FileAreaScanInput('%LFMove to which file area? (^5'+IntToStr(LowFileArea)+'^4-^5'+IntToStr(HighFileArea)+'^4)'+
' [^5?^4=^5First^4,^5<CR>^4=^5Next^4]: ',Length(IntToStr(HighFileArea)),InputStr,'[]?',
LowFileArea,HighFileArea);
IF (InputStr = '[') THEN
BEGIN
FArea := (SaveFArea - ((PageLength - 5) * 2));
IF (FArea < 1) THEN
FArea := 1;
InputStr := '?';
END
ELSE IF (InputStr = ']') THEN
BEGIN
IF (FArea > NumFileAreas) THEN
FArea := SaveFArea;
InputStr := '?';
END
ELSE IF (InputStr = '?') THEN
BEGIN
NL;
Print('^1(^3###^1)Manual entry selection ^1(^3<CR>^1)Select current entry');
Print('^1(^3<Home>^1)First entry on page ^1(^3<End>^1)Last entry on page');
Print('^1(^3Left Arrow^1)Previous entry ^1(^3Right Arrow^1)Next entry');
Print('^1(^3Up Arrow^1)Move up ^1(^3Down Arrow^1)Move down');
Print('^1(^3[^1)Previous page ^1(^3]^1)Next page');
PauseScr(FALSE);
FArea := SaveFArea;
END
ELSE IF (StrToInt(InputStr) < LowFileArea) OR (StrToInt(InputStr) > HighFileArea) THEN
BEGIN
NL;
Print('^7The range must be from '+IntToStr(LowFileArea)+' to '+IntToStr(HighFileArea)+'!^1');
InputStr := '?';
FArea := 1
END
ELSE
BEGIN
FArea := CompFileArea(StrToInt(InPutStr),1);
IF (FArea <> FileArea) THEN
ChangeFileArea(FArea);
IF (FArea <> FileArea) THEN
BEGIN
NL;
Print('^7You do not have access to this file area.^1');
InputStr := '?';
FArea := 1
END
ELSE
BEGIN
InitFileArea(FArea);
IF (NOT AACS(MemFileArea.ULACS)) THEN
BEGIN
NL;
Print('^7You do not have the required upload access for this file area.^1');
InputStr := '?';
FArea := 1
END
ELSE IF ((NOT FileSysOp) AND (Exist(MemFileArea.ULPath+FileInfo.FileName)) OR
(Exist(MemFileArea.DLPath+FileInfo.FileName))) THEN
BEGIN
NL;
Print('^7The file already exists in the upload or download path.^1');
InputStr := '?';
FArea := 1
END
ELSE IF (FileSize(FileInfoFile) >= MemFileArea.MaxFiles) THEN
BEGIN
NL;
Print('^7This file area is full.^1');
InputStr := '?';
FArea := 1
END;
Close(FileInfoFile);
Close(ExtInfoFile);
END;
END;
UNTIL (NOT (InputStr[1] IN [^M,'?'])) OR (HangUp);
TempPause := SaveTempPause;
ConfSystem := SaveConfSystem;
IF (SaveConfSystem) THEN
NewCompTables;
END;
FileArea := FArea;
END;
UpFile;
END;
FindNext(DirInfo);
END;
lil := 0;
Dec(RefundTime,TakeAwayRefundTime);
Dec(FreeTime,TakeAwayRefundTime);
SysOpLog('^3 - Totals:'+
' '+FormatNumber(Totals.FilesUL)+' '+Plural('file',Totals.FilesUL)+
', '+ConvertBytes(Totals.BytesUL,FALSE)+
', '+FormattedTime(TransferTime)+' tt'+
', '+FormatNumber(GetCPS(Totals.BytesUL,Transfertime))+' cps'+
', '+FormattedTime(RefundTime)+' rt');
IF ((UploadsToday + Totals.FilesULCredit) < 2147483647) THEN
Inc(UploadsToday,Totals.FilesULCredit)
ELSE
UploadsToday := 2147483647;
IF ((UploadKBytesToday + (Totals.BytesULCredit DIV 1024)) < 2147483647) THEN
Inc(UploadKBytesToday,(Totals.BytesULCredit DIV 1024))
ELSE
UploadKBytesToday := 2147483647;
LIL := 0;
NL;
Print('^5Batch upload (Credits):^1');
NL;
Star('^1Total file(s) : ^5'+FormatNumber(Totals.FilesULCredit));
Star('^1Total size : ^5'+ConvertBytes(Totals.BytesULCredit,FALSE));
Star('^1Total file points : ^5'+FormatNumber(Totals.PointsULCredit));
Star('^1Time refund : ^5'+FormattedTime(RefundTime)+'^1');
IF (AACS(General.ULValReq)) OR (General.ValidateAllFiles) THEN
BEGIN
IF ((ThisUser.Uploads + Totals.FilesULCredit) < 2147483647) THEN
Inc(ThisUser.Uploads,Totals.FilesULCredit)
ELSE
ThisUser.Uploads := 2147483647;
IF (ThisUser.UK + (Totals.BytesULCredit DIV 1024) < 2147483647) THEN
Inc(ThisUser.UK,(Totals.BytesULCredit DIV 1024))
ELSE
ThisUser.UK := 2147483647;
IF ((ThisUser.FilePoints + Totals.PointsULCredit) < 2147483647) THEN
Inc(ThisUser.FilePoints,Totals.PointsULCredit)
ELSE
ThisUser.FilePoints := 2147483647;
END
ELSE
BEGIN
NL;
Print('^5You will receive upload credit after the SysOp validates the '+Plural('file',Totals.FilesULCredit)+'!');
Totals.FilesULCredit := 0;
Totals.BytesULCredit := 0;
Totals.PointsULCredit := 0;
END;
IF (ChopTime <> 0) THEN
BEGIN
ChopTime := ((ChopTime + RefundTime) - TakeAwayRefundTime);
FreeTime := ((FreeTime - RefundTime) + TakeAwayRefundTime);
NL;
Star('You will receive your time refund after the event.');
RefundTime := 0;
END;
SysOpLog('^3 - Credits:'+
' '+FormatNumber(Totals.FilesULCredit)+' '+Plural('file',Totals.FilesULCredit)+
', '+ConvertBytes(Totals.BytesULCredit,FALSE)+
', '+FormatNumber(Totals.PointsULCredit)+' fp'+
', '+FormattedTime(RefundTime)+' rt');
IF (NumBatchULFiles > 0) THEN
BEGIN
LIL := 0;
NL;
Print('^5Batch upload (Not Transferred):^1');
NL;
Star('^1Total file(s) : ^5'+FormatNumber(NumBatchULFiles));
SysOpLog('^3 - Not uploaded:'+
' '+FormatNumber(NumBatchULFiles)+' '+Plural('file',NumBatchULFiles));
END;
LIL := 0;
NL;
Star('Thanks for the '+Plural('file',Totals.FilesULCredit)+', '+Caps(ThisUser.Name)+'!');
PauseScr(False);
SaveURec(ThisUser,UserNum);
Close(BatchULFile);
IF (AHangUp) THEN
BEGIN
lStatus_Screen(100,'Hanging up phone again...',FALSE,InputStr);
DoPhoneHangUp(FALSE);
HangUp := TRUE;
END;
FileArea := SaveFileArea;
InitFileArea(FileArea);
END;
PROCEDURE BatchDLULInfo;
BEGIN
IF (NumBatchDLFiles <> 0) THEN
BEGIN
NL;
Print('^9>> ^3You have ^5'+FormatNumber(NumBatchDLFiles)+'^3 '+Plural('file',NumBatchDLFiles)+
' left in your batch download queue.^1');
END;
IF (NumBatchULFiles <> 0) THEN
BEGIN
NL;
Print('^9>> ^3You have ^5'+FormatNumber(NumBatchULFiles)+'^3 '+Plural('file',NumBatchULFiles)+
' left in your batch upload queue.^1');
END;
END;
END.

128
SOURCE/FILE13.PAS Normal file
View File

@ -0,0 +1,128 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S+,V-}
UNIT File13;
INTERFACE
PROCEDURE Sort;
IMPLEMENTATION
USES
Common,
File0;
PROCEDURE SortDir(NumFiles: Word);
VAR
FileInfo1: FileInfoRecordType;
NumSorted,
RecNum,
RecNum1,
Gap: Word;
BEGIN
Gap := NumFiles;
REPEAT;
Gap := (Gap DIV 2);
IF (Gap = 0) THEN
Gap := 1;
NumSorted := 0;
FOR RecNum := 1 TO (NumFiles - Gap) DO
BEGIN
RecNum1 := (RecNum + Gap);
Seek(FileInfoFile,(RecNum - 1));
Read(FileInfoFile,FileInfo);
Seek(FileInfoFile,(RecNum1 - 1));
Read(FileInfoFile,FileInfo1);
IF (FileInfo.FileName > FileInfo1.FileName) THEN
BEGIN
Seek(FileInfoFile,(RecNum - 1));
Write(FileInfoFile,FileInfo1);
Seek(FileInfoFile,(RecNum1 - 1));
Write(FileInfoFile,FileInfo);
Inc(NumSorted);
END;
END;
UNTIL (NumSorted = 0) AND (Gap = 1);
IF (IOResult <> 0) THEN
SysOpLog('Error sorting files!');
END;
PROCEDURE SortFiles(FArea: Integer; VAR TotFiles: LongInt; VAR TotAreas: Integer);
VAR
NumFiles: Word;
BEGIN
IF (FileArea <> FArea) THEN
ChangeFileArea(FArea);
IF (FileArea = FArea) THEN
BEGIN
InitFileArea(FileArea);
NumFiles := FileSize(FileInfoFile);
Prompt('^1Sorting ^5'+MemFileArea.AreaName+' #'+IntToStr(FileArea)+'^1 ('+FormatNumber(NumFiles)+
' '+Plural('file',NumFiles)+')');
IF (NumFiles <> 0) THEN
SortDir(NumFiles);
Close(FileInfoFile);
Close(ExtInfoFile);
Inc(TotAreas);
Inc(TotFiles,NumFiles);
NL;
END;
END;
PROCEDURE Sort;
VAR
FArea,
TotAreas,
SaveFileArea: Integer;
TotFiles: LongInt;
Global,
SaveConfSystem: Boolean;
BEGIN
NL;
IF (NOT SortFilesOnly) THEN
Global := PYNQ('Sort all file areas? ',0,FALSE)
ELSE
BEGIN
Global := TRUE;
CLS;
END;
NL;
TotFiles := 0;
TotAreas := 0;
IF (NOT Global) THEN
SortFiles(FileArea,TotFiles,TotAreas)
ELSE
BEGIN
SaveFileArea := FileArea;
SaveConfSystem := ConfSystem;
ConfSystem := FALSE;
IF (SaveConfSystem) THEN
NewCompTables;
Abort := FALSE;
Next := FALSE;
TempPause := FALSE;
FArea := 1;
WHILE (FArea >= 1) AND (FArea <= NumFileAreas) AND (NOT Abort) AND (NOT HangUp) DO
BEGIN
IF FileAreaAC(FArea) OR (SortFilesOnly) THEN
SortFiles(FArea,TotFiles,TotAreas);
WKey;
Inc(FArea);
END;
ConfSystem := SaveConfSystem;
IF (SaveConfSystem) THEN
NewCompTables;
FileArea := SaveFileArea;
LoadFileArea(FileArea);
END;
NL;
Print('Sorted '+FormatNumber(TotFiles)+' '+Plural('file',TotFiles)+
' in '+FormatNumber(TotAreas)+' '+Plural('area',TotAreas));
SysOpLog('Sorted file areas');
END;
END.

190
SOURCE/FILE14.PAS Normal file
View File

@ -0,0 +1,190 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S+,V-}
UNIT File14;
INTERFACE
USES
Common;
FUNCTION IsGIFExt(CONST FileName: AStr): Boolean;
FUNCTION IsGIFDesc(CONST Description: AStr): Boolean;
FUNCTION GetGIFSpecs(CONST FileName: AStr; Description: AStr; Which: Byte): AStr;
PROCEDURE AddGIFSpecs;
IMPLEMENTATION
USES
File0,
File11;
FUNCTION IsGIFExt(CONST FileName: AStr): Boolean;
VAR
TempFN: AStr;
BEGIN
TempFN := AllCaps(SQOutSp(StripName(FileName)));
IsGIFExt := (Copy(TempFN,(Length(TempFN) - 2),3) = 'GIF');
END;
FUNCTION IsGIFDesc(CONST Description: AStr): Boolean;
BEGIN
IsGIFDesc := (Pos('< Bad GIF >',Description) <> 0) OR
(Pos('< Missing GIF >',Description) <> 0) OR
((Description[1] = '(') AND (Pos('x',Description) IN [1..7]) AND (Pos('c)',Description) <> 0));
END;
FUNCTION GetGIFSpecs(CONST FileName: AStr; Description: AStr; Which: Byte): AStr;
VAR
F: FILE;
Buf: ARRAY [1..11] OF Byte;
Sig: AStr;
X,
Y,
C,
C1,
Counter,
NumRead: Word;
BEGIN
FillChar(Buf,SizeOf(Buf),0);
Sig := '';
X := 0;
Y := 0;
C := 0;
NumRead := 0;
Assign(F,FileName);
Reset(F,1);
IF (IOResult <> 0) THEN
Sig := '< Missing GIF >'
ELSE
BEGIN
BlockRead(F,Buf,SizeOf(Buf),NumRead);
Close(F);
IF (NumRead <> 11) THEN
Sig := '< Bad GIF >'
ELSE IF (Buf[1] <> Ord('G')) OR (Buf[2] <> Ord('I')) OR (Buf[3] <> Ord('F')) THEN
Sig := '< Missing GIF >';
END;
IF (Sig <> '< Bad GIF >') AND (Sig <> '< Missing GIF >') THEN
BEGIN
FOR Counter := 1 TO 6 DO
Sig := Sig + Chr(Buf[Counter]);
X := ((Buf[7] + Buf[8]) * 256);
Y := ((Buf[9] + Buf[10]) * 256);
C1 := ((Buf[11] AND 7) + 1);
C := 1;
FOR Counter := 1 TO C1 DO
C := (C * 2);
END;
IF (Which = 1) THEN
GetGIFSpecs := '^3'+Align(StripName(FileName))+
' ^5'+PadLeftStr(IntToStr(X)+'x'+IntToStr(Y),11)+
' '+PadLeftStr(IntToStr(C)+' colors',10)+
' '+AOnOff((Sig = '< Missing GIF >') OR (Sig = '< Bad GIF >'),'^8'+Sig+'^1','^7'+Sig+'^1')
ELSE IF (Which IN [2,3]) THEN
BEGIN
IF (Sig = '< Missing GIF >') THEN
GetGifSpecs := Copy('^8< Missing GIF > ^9'+Description,1,50)
ELSE IF (Sig = '< Bad GIF >') THEN
GetGIFSpecs := Copy('^8< Bad GIF > ^9'+Description,1,50)
ELSE
GetGIFSPecs := Copy('('+IntToStr(X)+'x'+IntToStr(Y)+','+IntToStr(C)+'c) '+Description,1,50);
END;
IF (Sig = '< Missing GIF >') OR (Sig = '< Bad GIF >') THEN
SysOpLog('^7Bad or missing GIF: "^5'+StripName(FileName)+'^7" in ^5'+MemFileArea.AreaName);
END;
PROCEDURE AddGIFSpecs;
VAR
FArrayRecNum: Byte;
FArea,
SaveFileArea: Integer;
TotalFiles: LongInt;
PROCEDURE AddFileAreaGIFSpecs(FArea: Integer; VAR FArrayRecNum1: Byte; VAR TotalFiles1: LongInt);
VAR
DirFileRecNum: Integer;
Found: Boolean;
BEGIN
IF (FileArea <> FArea) THEN
ChangeFileArea(FArea);
IF (FileArea = FArea) THEN
BEGIN
RecNo(FileInfo,'*.*',DirFileRecNum);
IF (BadDownloadPath) THEN
Exit;
IF (FAUseGifSpecs IN MemFileArea.FAFlags) THEN
BEGIN
LIL := 0;
CLS;
Found := FALSE;
Prompt('^1Scanning ^5'+MemFileArea.AreaName+' #'+IntToStr(CompFileArea(FArea,0))+'^1 ...');
WHILE (DirFileRecNum <> -1) AND (NOT Abort) AND (NOT HangUp) DO
BEGIN
Seek(FileInfoFile,DirFileRecNum);
Read(FileInfoFile,FileInfo);
IF (IsGIFExt(FileInfo.FileName) AND (NOT IsGIFDesc(FileInfo.Description))) THEN
BEGIN
FileInfo.Description := GetGIFSpecs(MemFileArea.DLPath+SQOutSp(FileInfo.FileName),FileInfo.Description,3);
WITH FArray[FArrayRecNum1] DO
BEGIN
FArrayFileArea := FileArea;
FArrayDirFileRecNum := DirFileRecNum;
END;
lDisplay_File(FileInfo,FArrayRecNum1,'',FALSE);
Inc(FArrayRecNum1);
IF (FArrayRecNum1 = 100) THEN
FArrayRecNum1 := 0;
Seek(FileInfoFile,DirFileRecNum);
Write(FileInfoFile,FileInfo);
Inc(TotalFiles1);
Found := TRUE;
END;
Wkey;
NRecNo(FileInfo,DirFileRecNum);
END;
IF (NOT Found) THEN
BEGIN
LIL := 0;
BackErase(15 + LennMCI(MemFileArea.AreaName) + Length(IntToStr(CompFileArea(FArea,0))));
END;
END;
Close(FileInfoFile);
Close(ExtInfoFile);
LastError := IOResult;
END;
END;
BEGIN
NL;
Print('Adding GIF Resolution to file descriptions -');
InitFArray(FArray);
FArrayRecNum := 0;
TotalFiles := 0;
Abort := FALSE;
Next := FALSE;
NL;
IF (NOT PYNQ('Search all file areas? ',0,FALSE)) THEN
AddFileAreaGIFSpecs(FileArea,FArrayRecNum,TotalFiles)
ELSE
BEGIN
SaveFileArea := FileArea;
FArea := 1;
WHILE (FArea >= 1) AND (FArea <= NumFileAreas) AND (NOT Abort) AND (NOT HangUp) DO
BEGIN
AddFileAreaGIFSpecs(FArea,FArrayRecNum,TotalFiles);
WKey;
Inc(FArea);
END;
FileArea := SaveFileArea;
LoadFileArea(FileArea);
END;
NL;
Print('Added GIF specifications to '+FormatNumber(TotalFiles)+' '+Plural('file',Totalfiles)+'.');
SysOpLog('Added GIF specifications to '+FormatNumber(TotalFiles)+' '+Plural('file',Totalfiles)+'.');
END;
END.

125
SOURCE/FILE2.PAS Normal file
View File

@ -0,0 +1,125 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S+,V-}
UNIT File2;
INTERFACE
USES
Common;
FUNCTION CopyMoveFile(CopyFile: Boolean; DisplayStr: AStr; CONST SrcName,DestName: AStr; CONST ShowProg: Boolean): Boolean;
IMPLEMENTATION
USES
Dos;
FUNCTION CopyMoveFile(CopyFile: Boolean; DisplayStr: AStr; CONST SrcName,DestName: AStr; CONST ShowProg: Boolean): Boolean;
VAR
Buffer: ARRAY [1..8192] OF Byte;
FromF,
ToF: FILE;
CurDir: AStr;
ProgressStr: Str3;
NumRead: Word;
TotalNumRead,
FileDate: LongInt;
OK,
Nospace: Boolean;
BEGIN
OK := TRUE;
NoSpace := FALSE;
GetDir(0,CurDir);
IF (ShowProg) THEN
Prompt(DisplayStr);
IF (NOT CopyFile) THEN
BEGIN
Assign(FromF,SrcName);
ReName(FromF,DestName);
LastError := IOResult;
IF (LastError <> 0) THEN
OK := FALSE
ELSE IF (ShowProg) THEN
Print('^5100%^1')
END;
IF (NOT OK) OR (CopyFile) THEN
BEGIN
OK := TRUE;
IF (SrcName = DestName) THEN
OK := FALSE
ELSE
BEGIN
Assign(FromF,SrcName);
Reset(FromF,1);
LastError := IOResult;
IF (LastError <> 0) THEN
OK := FALSE
ELSE
BEGIN
GetFTime(FromF,FileDate);
IF ((FileSize(FromF) DIV 1024) >= DiskKBFree(DestName)) THEN
BEGIN
Close(FromF);
NoSpace := TRUE;
OK := FALSE;
END
ELSE
BEGIN
Assign(ToF,DestName);
ReWrite(ToF,1);
LastError := IOResult;
IF (LastError <> 0) THEN
OK := FALSE
ELSE
BEGIN
SetFTime(ToF,FileDate);
IF (ShowProg) THEN
Prompt('^5 0%^1');
TotalNumRead := 0;
REPEAT
BlockRead(FromF,Buffer,SizeOf(Buffer),NumRead);
BlockWrite(ToF,Buffer,NumRead);
Inc(TotalNumRead,NumRead);
IF (ShowProg) AND (FileSize(FromF) > 0) THEN
BEGIN
Str(Trunc(TotalNumRead / FileSize(FromF) * 100):3,ProgressStr);
Prompt(^H^H^H^H+'^5'+ProgressStr+'%^1');
END;
UNTIL (NumRead < SizeOf(Buffer));
IF (ShowProg) THEN
BEGIN
UserColor(1);
NL;
END;
Close(ToF);
Close(FromF);
IF (NOT CopyFile) AND (OK) AND (NOT NoSpace) THEN
Kill(SrcName);
END;
END;
END;
END;
END;
ChDir(CurDir);
IF (NoSpace) THEN
BEGIN
IF (ShowProg) THEN
Print('^7destination drive full!^1');
SysOpLog('^7Error '+AOnOff(CopyFile,'copying','moving')+' (No-Space): "'+SrcName+'" to "'+DestName+'"!');
END
ELSE IF (NOT Ok) THEN
BEGIN
IF (ShowProg) THEN
Print('^7failed!^1');
SysOpLog('^7Error '+AOnOff(CopyFile,'copying','moving')+' (I/O): "'+SrcName+'" to "'+DestName+'"!');
END
ELSE
SysOpLog('^1'+AOnOff(CopyFile,'Copied','Moved')+' file: "^5'+SrcName+'^1" to "^5'+DestName+'^1".');
CopyMoveFile := (OK) AND (NOT NoSpace);
END;
END.

115
SOURCE/FILE3.PAS Normal file
View File

@ -0,0 +1,115 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S+,V-}
UNIT File3;
INTERFACE
PROCEDURE ReCheck;
IMPLEMENTATION
USES
Dos,
Common,
File0,
File1;
PROCEDURE CheckFiles(FArea: Integer; CheckDiz: Boolean);
VAR
FN: AStr;
NumExtDesc: Byte;
DirFileRecNum: Integer;
FSize: LongInt;
BEGIN
IF (FileArea <> FArea) THEN
ChangeFileArea(FArea);
IF (FileArea = FArea) THEN
BEGIN
RecNo(FileInfo,'*.*',DirFileRecNum);
IF (BadDownloadPath) THEN
Exit;
NL;
Print('^1Checking ^5'+MemFileArea.AreaName+' #'+IntToStr(CompFileArea(FArea,0))+'^1 ...');
WHILE (DirFileRecNum <> - 1) AND (NOT Abort) AND (NOT HangUp) DO
BEGIN
Seek(FileInfoFile,DirFileRecNum);
Read(FileInfoFile,FileInfo);
IF Exist(MemFileArea.DLPath+FileInfo.FileName) THEN
FN := MemFileArea.DLPath+SQOutSp(FileInfo.FileName)
ELSE
FN := MemFileArea.ULPath+SQOutSp(FileInfo.FileName);
FSize := GetFileSize(FN);
IF (FSize = 0) THEN
BEGIN
FileInfo.FileSize := 0;
Include(FileInfo.FIFlags,FIIsRequest);
END
ELSE
BEGIN
FileInfo.FileSize := FSize;
Exclude(FileInfo.FIFlags,FIIsRequest);
END;
IF (CheckDiz) AND (DizExists(FN)) THEN
BEGIN
FillChar(ExtendedArray,SizeOf(ExtendedArray),0);
GetDiz(FileInfo,ExtendedArray,NumExtDesc);
WriteFV(FileInfo,DirFileRecNum,ExtendedArray);
END;
Seek(FileInfoFile,DirFileRecNum);
Write(FileInfoFile,FileInfo);
NRecNo(FileInfo,DirFileRecNum);
END;
Close(FileInfoFile);
Close(ExtInfoFile);
END;
LastError := IOResult;
END;
PROCEDURE ReCheck;
VAR
SaveFileArea,
FArea: Integer;
CheckDiz,
SaveConfSystem,
SaveTempPause: Boolean;
BEGIN
CheckDiz := PYNQ('%LFReimport descriptions? ',0,FALSE);
SaveTempPause := TempPause;
TempPause := FALSE;
Abort := FALSE;
Next := FALSE;
NL;
IF (NOT PYNQ('Recheck all file areas? ',0,FALSE)) THEN
CheckFiles(FileArea,CheckDiz)
ELSE
BEGIN
SaveFileArea := FileArea;
SaveConfSystem := ConfSystem;
IF (SaveConfSystem) THEN
NewCompTables;
FArea := 1;
WHILE (FArea >= 1) AND (FArea <= NumFileAreas) AND (NOT Abort) AND (NOT HangUp) DO
BEGIN
Checkfiles(FArea,CheckDiz);
WKey;
Inc(FArea);
END;
ConfSystem := SaveConfSystem;
IF (SaveConfSystem) THEN
NewCompTables;
FileArea := SaveFileArea;
LoadFileArea(FileArea);
END;
TempPause := SaveTempPause;
END;
END.

251
SOURCE/FILE4.PAS Normal file
View File

@ -0,0 +1,251 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S+,V-}
UNIT File4;
INTERFACE
USES
Common;
PROCEDURE ExecProtocol(TextFN,
Dir,
BatLine: AStr;
OKLevel: Integer;
VAR ReturnCode: Integer;
VAR TransferTime: LongInt);
FUNCTION FindReturnCode(ProtCode: ProtocolCodeType; XBStat: PRFlagSet; ReturnCode: AStr): Boolean;
FUNCTION DoProtocol(VAR Protocol: ProtocolRecordType; UL,DL,Batch,Resume: Boolean): Integer;
IMPLEMENTATION
USES
ExecBat,
TimeFunc;
FUNCTION FindReturnCode(ProtCode: ProtocolCodeType; XBStat: PRFlagSet; ReturnCode: AStr): Boolean;
VAR
Counter: Byte;
Found: Boolean;
BEGIN
FindReturnCode := FALSE;
Found := FALSE;
FOR Counter := 1 TO 6 DO
IF (ProtCode[Counter] <> '') THEN
IF (Pos(ProtCode[Counter],Copy(ReturnCode,1,Length(ProtCode[Counter]))) <> 0) THEN
Found := TRUE;
IF (Found) AND (NOT (ProtXferOkCode IN Protocol.PRFlags)) THEN
Exit;
IF (NOT Found) AND (ProtXferOkCode IN Protocol.PRFlags) THEN
Exit;
FindReturnCode := Found;
END;
PROCEDURE ExecProtocol(TextFN,
Dir,
BatLine: AStr;
OKLevel: Integer;
VAR ReturnCode: Integer;
VAR TransferTime: LongInt);
VAR
SaveSwapShell,
ResultOk: Boolean;
BEGIN
IF (General.MultiNode) THEN
BEGIN
LoadNode(ThisNode);
SaveNAvail := (NAvail IN NodeR.Status);
Exclude(NodeR.Status,NAvail);
SaveNode(ThisNode);
END;
TransferTime := GetPackDateTime;
IF (TextFN <> '') THEN
BEGIN
AllowContinue := TRUE;
Abort := FALSE;
Next := FALSE;
CLS;
UserColor(1);
ReturnCode := 0;
PrintF(TextFN);
IF (NoFile) THEN
ReturnCode := 2;
NL;
PauseScr(FALSE);
UserColor(1);
AllowContinue := FALSE;
END
ELSE
BEGIN
SaveSwapShell := General.SwapShell;
General.SwapShell := FALSE;
ExecWindow(ResultOK,
Dir,
BatLine,
OKLevel,
ReturnCode);
General.SwapShell := SaveSwapShell;
END;
TransferTime := (GetPackDateTime - TransferTime);
IF (General.MultiNode) THEN
BEGIN
LoadNode(ThisNode);
IF (SaveNAvail) THEN
Include(NodeR.Status,NAvail);
SaveNode(ThisNode);
END;
END;
FUNCTION OkProt(Protocol: ProtocolRecordType; UL,DL,Batch,Resume: Boolean): Boolean;
VAR
ULDLCmdStr: AStr;
BEGIN
OkProt := FALSE;
WITH Protocol DO
BEGIN
IF (UL) THEN
ULDLCmdStr := ULCmd
ELSE IF (DL) THEN
ULDLCmdStr := DLCmd
ELSE
ULDLCmdStr := '';
IF (ULDLCmdStr = '') THEN
Exit;
IF (ULDLCmdStr = 'NEXT') AND ((UL) OR (Batch) OR (Resume)) THEN
Exit;
IF (ULDLCmdStr = 'ASCII') AND ((UL) OR (Batch) OR (Resume)) THEN
Exit;
IF (ULDLCmdStr = 'BATCH') AND ((Batch) OR (Resume)) AND (NOT Write_Msg) THEN
Exit;
IF (Batch <> (ProtIsBatch in PRFlags)) THEN
Exit;
IF (Resume <> (ProtIsResume in PRFlags)) THEN
Exit;
IF (ProtReliable in PRFlags) AND (NOT Reliable) THEN
Exit;
IF (NOT (ProtActive in PRFlags)) THEN
Exit;
IF (NOT AACS(ACS)) THEN
Exit;
END;
OkProt := TRUE;
END;
PROCEDURE ShowProts(VAR CmdStr: AStr; UL,DL,Batch,Resume: Boolean);
VAR
RecNum: Integer;
BEGIN
NoFile := TRUE;
IF (Resume) THEN
PrintF('PROTRES')
ELSE
BEGIN
IF (Batch) THEN
IF (UL) THEN
PrintF('PROTBUL')
ELSE
PrintF('PROTBDL')
ELSE IF (UL) THEN
PrintF('PROTSUL')
ELSE
PrintF('PROTSDL');
END;
Abort := FALSE;
Next := FALSE;
CmdStr := '';
RecNum := 1;
WHILE (RecNum <= NumProtocols) AND (NOT Abort) AND (NOT HangUp) DO
BEGIN
Seek(ProtocolFile,(RecNum - 1));
Read(ProtocolFile,Protocol);
IF (OkProt(Protocol,UL,DL,Batch,Resume)) THEN
BEGIN
IF (NoFile) AND (Protocol.Description <> '') THEN
Print(Protocol.Description);
IF (Protocol.CKeys = 'ENTER') then
CmdStr := CmdStr + ^M
ELSE
CmdStr := CmdStr + Protocol.CKeys[1];
END;
Inc(RecNum);
END;
IF (NoFile) THEN
NL;
END;
FUNCTION FindProt(Cmd: Char; UL,DL,Batch,Resume: Boolean): Integer;
VAR
ULDLCmdStr: AStr;
RecNum,
RecNum1: Integer;
BEGIN
RecNum1 := -99;
RecNum := 1;
WHILE (RecNum <= NumProtocols) AND (RecNum1 = -99) DO
BEGIN
Seek(ProtocolFile,(RecNum - 1));
Read(ProtocolFile,Protocol);
IF (Cmd = Protocol.Ckeys[1]) OR ((Cmd = ^M) AND (Protocol.Ckeys = 'ENTER')) THEN
IF (OkProt(Protocol,UL,DL,Batch,Resume)) THEN
BEGIN
IF (UL) THEN
ULDLCmdStr := Protocol.ULCmd
ELSE IF (DL) THEN
ULDLCmdStr := Protocol.DLCmd
ELSE
ULDLCmdStr := '';
IF (ULDLCmdStr = 'ASCII') THEN
RecNum1 := -1
ELSE IF (ULDLCmdStr = 'QUIT') THEN
RecNum1 := -2
ELSE IF (ULDLCmdStr = 'NEXT') THEN
RecNum1 := -3
ELSE IF (ULDLCmdStr = 'BATCH') THEN
RecNum1 := -4
ELSE IF (ULDLCmdStr = 'EDIT') THEN
RecNum1 := -5
ELSE IF (ULDLCmdStr <> '') THEN
RecNum1 := RecNum;
END;
Inc(RecNum);
END;
FindProt := RecNum1;
END;
FUNCTION DoProtocol(VAR Protocol: ProtocolRecordType; UL,DL,Batch,Resume: Boolean): Integer;
VAR
CmdStr: AStr;
Cmd: Char;
RecNum: Integer;
BEGIN
Reset(ProtocolFile);
REPEAT
ShowProts(CmdStr,UL,DL,Batch,Resume);
{ Prompt('%DFPROTLIST%^4Selection^2: ');}
lRGLngStr(17,FALSE);;
OneK(Cmd,CmdStr,TRUE,TRUE);
RecNum := FindProt(Cmd,UL,DL,Batch,Resume);
IF (RecNum = -99) THEN
BEGIN
NL;
Print('Invalid option.');
END
ELSE IF (RecNum >= 1) AND (RecNum <= NumProtocols) THEN
BEGIN
Seek(ProtocolFile,(RecNum - 1));
Read(ProtocolFile,Protocol);
END
UNTIL (RecNum <> -99) OR (HangUp);
Close(ProtocolFile);
LastError := IOResult;
DoProtocol := RecNum;
END;
END.

804
SOURCE/FILE5.PAS Normal file
View File

@ -0,0 +1,804 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S+,V-}
UNIT File5;
INTERFACE
PROCEDURE MiniDOS;
PROCEDURE UploadAll;
IMPLEMENTATION
USES
Dos,
Common,
Arcview,
Archive1,
ExecBat,
File0,
File1,
File2,
File8,
File9,
File11,
MultNode,
Sysop4;
PROCEDURE MiniDOS;
VAR
XWord: ARRAY [1..9] OF AStr;
(*
DirInfo: SearchRec;
*)
CurDir,
s,
s1: AStr;
Done,
NoCmd,
NoSpace,
Junk,
junk2,
junk3,
Found: Boolean;
TransferTime: LongInt;
PROCEDURE Parse(CONST s: AStr);
VAR
i,
j,
k: Integer;
BEGIN
FOR i := 1 TO 9 DO
XWord[i] := '';
i := 1;
j := 1;
k := 1;
IF (Length(s) = 1) THEN
XWord[1] := s;
WHILE (i < Length(s)) DO
BEGIN
Inc(i);
IF ((s[i] = ' ') OR (Length(s) = i)) THEN
BEGIN
IF (Length(s) = i) THEN
Inc(i);
XWord[k] := AllCaps(Copy(s,j,(i - j)));
j := (i + 1);
Inc(k);
END;
END;
END;
PROCEDURE VersionInfo;
BEGIN
NL;
Print('Renegade''s internal DOS emulator. Supported commands are limited.');
NL;
NL;
END;
FUNCTION DOSErrorMsg(ErrorNum: Byte): AStr;
VAR
S: AStr;
BEGIN
CASE ErrorNum OF
1 : S := 'The snytax of the command is incorrect.';
END;
DOSErrorMsg := S;
END;
PROCEDURE DoCmd(CONST Cmd: AStr);
VAR
F: FILE;
ps,
ns,
es,
op,
np,
s1,
s2,
s3: AStr;
NumFiles,
TSiz: LongInt;
i,
j: Byte;
RetLevel: Integer;
b,
Ok: Boolean;
BEGIN
Abort := FALSE;
Next := FALSE;
NoCmd := FALSE;
s := XWord[1];
IF (s = '?') OR (s = 'HELP') THEN
PrintF('DOSHELP')
ELSE IF (s = 'EDIT') THEN
BEGIN
IF ((Exist(XWord[2])) AND (XWord[2] <> '')) THEN
TEdit(XWord[2])
ELSE IF (XWord[2] = '') THEN
TEdit1
ELSE
TEdit(XWord[2]);
END
ELSE IF (s = 'EXIT') THEN
Done := TRUE
ELSE IF (s = 'DEL') THEN
BEGIN
IF ((NOT Exist(XWord[2])) AND (NOT IsWildCard(XWord[2]))) OR (XWord[2] = '') THEN
Print('File not found.')
ELSE
BEGIN
XWord[2] := FExpand(XWord[2]);
FindFirst(XWord[2],AnyFile - VolumeID - Directory,DirInfo);
IF (NOT IsWildCard(XWord[2])) OR (PYNQ('Are you sure? ',0,FALSE)) THEN
REPEAT
Kill(DirInfo.Name);
FindNext(DirInfo);
UNTIL (DOSError <> 0) OR (HangUp);
END;
END
ELSE IF (s = 'TYPE') THEN
BEGIN
PrintF(FExpand(XWord[2]));
IF (NoFile) THEN
Print('File not found.');
END
ELSE IF (Copy(s,1,3) = 'REN') THEN
BEGIN
IF ((NOT Exist(XWord[2])) AND (XWord[2] <> '')) THEN
Print('File not found.')
ELSE
BEGIN
XWord[2] := FExpand(XWord[2]);
Assign(F,XWord[2]);
ReName(F,XWord[3]);
IF (IOResult <> 0) THEN
Print('File not found.');
END
END
ELSE IF (s = 'DIR') THEN
BEGIN
b := TRUE;
FOR i := 2 TO 9 DO
IF (XWord[i] = '/W') THEN
BEGIN
b := FALSE;
XWord[i] := '';
END;
IF (XWord[2] = '') THEN
XWord[2] := '*.*';
s1 := CurDir;
XWord[2] := FExpand(XWord[2]);
FSplit(XWord[2],ps,ns,es);
s1 := ps;
s2 := ns + es;
IF (s2[1] = '.') THEN
s2 := '*' + s2;
IF (s2 = '') THEN
s2 := '*.*';
IF (Pos('.', s2) = 0) THEN
s2 := s2 + '.*';
IF (NOT IsWildCard(XWord[2])) THEN
BEGIN
FindFirst(XWord[2],AnyFile,DirInfo);
IF ((DOSError = 0) AND (DirInfo.Attr = Directory)) OR ((Length(s1) = 3) AND (s1[3] = '\')) THEN
BEGIN
s1 := BSlash(XWord[2],TRUE);
s2 := '*.*';
END;
END;
NL;
DosDir(s1,s2,b);
NL;
END
ELSE IF ((s = 'CD') OR (s = 'CHDIR')) AND (XWord[2] <> '') OR (Copy(s,1,3) = 'CD\') THEN
BEGIN
IF (Copy(s,1,3) = 'CD\') THEN
XWord[2] := Copy(s,3,Length(s)-2);
XWord[2] := FExpand(XWord[2]);
ChDir(XWord[2]);
IF (IOResult <> 0) THEN
Print('Invalid pathname.');
END
(* Done - Lee Palmer - 01/09/08 *)
ELSE IF (s = 'MD') OR (s = 'MKDIR') THEN
BEGIN
IF (XWord[2] = '') THEN
Print(DOSErrorMsg(1))
ELSE
BEGIN
FindFirst(XWord[2],AnyFile,DirInfo);
IF (DosError = 0) THEN
Print('A subdirectory or file '+XWord[2]+' already exists.')
ELSE
BEGIN
MkDir(XWord[2]);
IF (IOResult <> 0) THEN
Print('Access is denied.');
END;
END;
END
ELSE IF ((s = 'RD') OR (s = 'RMDIR')) THEN
BEGIN
(* Finish Me *)
IF (XWord[2] = '') THEN
Print(DOSErrorMsg(1))
ELSE
BEGIN
FindFirst(XWord[2],AnyFile,DirInfo);
IF (DosError <> 0) THEN
Print('The system cannot find the file specified.')
ELSE
BEGIN
Abort := FALSE;
Found := FALSE;
FindFirst(BSlash(XWord[2],TRUE)+'*.*',AnyFile,DirInfo);
WHILE (DosError = 0) AND (NOT Abort) AND (NOT HangUp) DO
BEGIN
IF (DirInfo.Name <> '.') AND (DirInfo.Name <> '..') THEN
BEGIN
Abort := TRUE;
Found := TRUE;
END;
FindNext(DirInfo);
END;
Abort := FALSE;
IF (Found) THEN
Print('The directory is not empty.')
ELSE
BEGIN
RmDir(XWord[2]);
IF (IOResult <> 0) THEN
Print('Access is denied.');
END;
END;
END;
END
ELSE IF (s = 'COPY') THEN
BEGIN
IF (XWord[2] <> '') THEN
BEGIN
IF (IsWildCard(XWord[3])) THEN
Print('Wildcards not allowed in destination parameter!')
ELSE
BEGIN
IF (XWord[3] = '') THEN
XWord[3] := CurDir;
XWord[2] := BSlash(FExpand(XWord[2]),FALSE);
XWord[3] := FExpand(XWord[3]);
FindFirst(XWord[3],AnyFile,DirInfo);
b := ((DOSError = 0) AND (DirInfo.Attr AND Directory = Directory));
IF ((NOT b) AND (Copy(XWord[3],2,2) = ':\') AND (Length(XWord[3]) = 3)) THEN
b := TRUE;
FSplit(XWord[2],op,ns,es);
op := BSlash(OP,TRUE);
IF (b) THEN
np := BSlash(XWord[3],TRUE)
ELSE
BEGIN
FSplit(XWord[3],np,ns,es);
np := BSlash(np,TRUE);
END;
j := 0;
Abort := FALSE;
Next := FALSE;
FindFirst(XWord[2],AnyFile - Directory - VolumeID,DirInfo);
WHILE (DOSError = 0) AND (NOT Abort) AND (NOT HangUp) DO
BEGIN
s1 := op + DirInfo.Name;
IF (b) THEN
s2 := np + DirInfo.Name
ELSE
s2 := np + ns + es;
IF CopyMoveFile(TRUE,s1+' -> '+s2+' :',s1,s2,TRUE) THEN
BEGIN
Inc(j);
NL;
END;
NL;
IF (NOT Empty) THEN
WKey;
FindNext(DirInfo);
END;
Print(' '+IntToStr(j)+' file(s) copied.');
END;
END;
END
ELSE IF (s = 'MOVE') THEN
BEGIN
IF (XWord[2] <> '') THEN
BEGIN
IF (IsWildCard(XWord[3])) THEN
Print('Wildcards not allowed in destination parameter!')
ELSE
BEGIN
IF (XWord[3] = '') THEN
XWord[3] := CurDir;
XWord[2] := BSlash(FExpand(XWord[2]),FALSE);
XWord[3] := FExpand(XWord[3]);
FindFirst(XWord[3],AnyFile,DirInfo);
b := ((DOSError = 0) AND (DirInfo.Attr AND Directory = Directory));
IF ((NOT b) AND (Copy(XWord[3],2,2) = ':\') AND (Length(XWord[3]) = 3)) THEN
b := TRUE;
FSplit(XWord[2],op,ns,es);
op := BSlash(op,TRUE);
IF (b) THEN
np := BSlash(XWord[3],TRUE)
ELSE
BEGIN
FSplit(XWord[3],np,ns,es);
np := BSlash(np,TRUE);
END;
j := 0;
Abort := FALSE;
Next := FALSE;
FindFirst(XWord[2],AnyFile - Directory - VolumeID,DirInfo);
WHILE (DOSError = 0) AND (NOT Abort) AND (NOT HangUp) DO
BEGIN
s1 := op + DirInfo.Name;
IF (b) THEN
s2 := np + DirInfo.Name
ELSE
s2 := np + ns + es;
CopyMoveFile(FALSE,s1+' -> '+s2+' :',s1,s2,TRUE);
BEGIN
Inc(j);
NL;
END;
IF (NOT Empty) THEN
WKey;
FindNext(DirInfo);
END;
Print(' '+IntToStr(j)+' file(s) moved.');
END;
END;
END
ELSE IF (s = 'CLS') THEN
CLS
ELSE IF (Length(s) = 2) AND (s[1] >= 'A') AND (s[1] <= 'Z') AND (s[2] = ':') THEN
BEGIN
GetDir(Ord(s[1]) - 64,s1);
IF (IOResult <> 0) THEN
Print('Invalid drive.')
ELSE
BEGIN
ChDir(s1);
IF (IOResult <> 0) THEN
BEGIN
Print('Invalid drive.');
ChDir(CurDir);
END;
END;
END
ELSE IF (s = 'VIEW') THEN
BEGIN
IF (XWord[2] = '') THEN
Print('Syntax is: "VIEW filename"')
ELSE
BEGIN
s1 := XWord[2];
IF (Pos('.',s1) = 0) THEN
s1 := s1 + '*.*';
ViewInternalArchive(s1);
END;
END
ELSE IF (s = 'SEND') AND (XWord[2] <> '') THEN
BEGIN
IF Exist(XWord[2]) THEN
UnlistedDownload(FExpand(XWord[2]))
ELSE
Print('File not found.');
END
ELSE IF (s = 'RECEIVE') THEN
BEGIN
Prt('File Name: ');
MPL(12);
Input(s,12);
s := StripName(s);
Receive(s,'',FALSE,Junk,junk2,junk3,TransferTime);
IF (Junk) THEN
SysOpLog('DOS emulator upload of: '+s);
END
ELSE IF (s = 'VER') THEN
VersionInfo
ELSE IF (s = 'DIRSIZE') THEN
BEGIN
NL;
IF (XWord[2] = '') THEN
Print('Needs a parameter.')
ELSE
BEGIN
NumFiles := 0;
TSiz := 0;
FindFirst(XWord[2],AnyFile,DirInfo);
WHILE (DOSError = 0) DO
BEGIN
Inc(TSiz,DirInfo.Size);
Inc(NumFiles);
FindNext(DirInfo);
END;
IF (NumFiles = 0) THEN
Print('No files found!')
ELSE
Print('"'+AllCaps(XWord[2])+'": '+IntToStr(NumFiles)+' files, '+ConvertBytes(TSiz,FALSE));
END;
NL;
END
ELSE IF (s = 'DISKFREE') THEN
BEGIN
IF (XWord[2] = '') THEN
j := ExtractDriveNumber(CurDir)
ELSE
j := ExtractDriveNumber(XWord[2]);
IF (DiskFree(j) = -1) THEN
Print('Invalid drive specification'^M^J)
ELSE
Print(^M^J + ConvertBytes(DiskFree(j),FALSE)+' free on '+Chr(j + 64)+':'^M^J);
END
ELSE IF (s = 'EXT') THEN
BEGIN
s1 := Cmd;
j := Pos('EXT',AllCaps(s1)) + 3;
s1 := Copy(s1,j,Length(s1) - (j - 1));
WHILE (s1[1] = ' ') AND (Length(s1) > 0) DO
Delete(s1,1,1);
IF (s1 <> '') THEN
BEGIN
Shel('Running "'+s1+'"');
ShellDOS(FALSE,s1,RetLevel);
Shel2(FALSE);
END;
END
ELSE IF (s = 'CONVERT') OR (s = 'CVT') THEN
BEGIN
IF (XWord[2] = '') THEN
BEGIN
NL;
Print(s+' - Renegade archive conversion command.');
NL;
Print('Syntax is: "'+s+' <Old Archive-name> <New Archive-extension>"');
NL;
Print('Renegade will convert from the one archive format to the other.');
Print('You only need to specify the 3-letter extension of the new format.');
NL;
END
ELSE
BEGIN
IF (NOT Exist(XWord[2])) OR (XWord[2] = '') THEN
Print('File not found.')
ELSE
BEGIN
i := ArcType(XWord[2]);
IF (i = 0) THEN
InvArc
ELSE
BEGIN
s3 := XWord[3];
s3 := Copy(s3,(Length(s3) - 2),3);
j := ArcType('FILENAME.'+s3);
FSplit(XWord[2],ps,ns,es);
IF (Length(XWord[3]) <= 3) AND (j <> 0) THEN
s3 := ps+ns+'.'+General.FileArcInfo[j].ext
ELSE
s3 := XWord[3];
IF (j = 0) THEN
InvArc
ELSE
BEGIN
Ok := TRUE;
ConvA(Ok,i,j,SQOutSp(FExpand(XWord[2])),SQOutSp(FExpand(s3)));
IF (Ok) THEN
Kill(SQOutSp(FExpand(XWord[2])))
ELSE
Star('Conversion unsuccessful.');
END;
END;
END;
END;
END ELSE IF (s = 'UNARC') OR (s = 'UNZIP') THEN
BEGIN
IF (XWord[2] = '') THEN
BEGIN
NL;
Print(s+' - Renegade archive de-compression command.');
NL;
Print('Syntax: '+s+' <ARCHIVE> [FILESPECS]');
NL;
Print('The archive type can be any archive format which has been');
Print('configured into Renegade via System Configuration.');
NL;
END
ELSE
BEGIN
i := ArcType(XWord[2]);
IF (NOT Exist(XWord[2])) THEN
Print('File not found.')
ELSE IF (i = 0) THEN
InvArc
ELSE
BEGIN
s3 := '';
IF (XWord[3] = '') THEN
s3 := ' *.*'
ELSE FOR j := 3 TO 9 DO
IF (XWord[j] <> '') THEN
s3 := s3 + ' '+XWord[j];
s3 := Copy(s3,2,Length(s3)-1);
ExecBatch(Junk,BSlash(CurDir,TRUE),General.ArcsPath+
FunctionalMCI(General.FileArcInfo[i].UnArcLine,XWord[2],s3),
0,
RetLevel,
FALSE);
END;
END;
END
ELSE IF ((s = 'ARC') OR (s = 'ZIP') OR (s = 'PKARC') OR (s = 'PKPAK') OR (s = 'PKZIP')) THEN
BEGIN
IF (XWord[2] = '') THEN
BEGIN
NL;
Print(s+' - Renegade archive compression command.');
NL;
Print('Syntax is: "'+s+' <Archive-name> Archive filespecs..."');
NL;
Print('The archive type can be ANY archive format which has been');
Print('configured into Renegade via System Configuration.');
NL;
END
ELSE
BEGIN
i := ArcType(XWord[2]);
IF (i = 0) THEN
InvArc
ELSE
BEGIN
s3 := '';
IF (XWord[3] = '') THEN
s3 := ' *.*'
ELSE FOR j := 3 TO 9 DO
IF (XWord[j] <> '') THEN
s3 := s3 + ' '+FExpand(XWord[j]);
s3 := Copy(s3,2,(Length(s3) - 1));
ExecBatch(Junk,
BSlash(CurDir,TRUE),
General.ArcsPath+FunctionalMCI(General.FileArcInfo[i].ArcLine,FExpand(XWord[2]),s3),
0,
RetLevel,
FALSE);
END;
END;
END
ELSE
BEGIN
NoCmd := TRUE;
IF (s <> '') THEN
Print('Bad command or file name.')
END;
END;
BEGIN
Done := FALSE;
NL;
Print('Type "EXIT" to return to Renegade');
NL;
VersionInfo;
REPEAT
GetDir(0,CurDir);
Prompt('^1'+CurDir+'>');
InputL(s1,128);
Parse(s1);
Check_Status;
DoCmd(s1);
IF (NOT NoCmd) THEN
SysOpLog('> '+s1);
UNTIL (Done) OR (HangUp);
ChDir(StartDir);
END;
PROCEDURE UploadAll;
VAR
FileName: Str12;
FArrayRecNum: Byte;
FArea,
SaveFileArea: Integer;
SearchAllFileAreas: Boolean;
PROCEDURE UploadFiles(FArea: Integer; FileName1: Str12; VAR FArrayRecNum1: Byte);
VAR
(*
DirInfo: SearchRec;
*)
Cmd: Char;
NumExtDesc: Byte;
DirFileRecNum,
GotPts,
Counter: Integer;
FSize: LongInt;
FlagAll,
Ok,
FirstOne,
GotDesc,
Found: Boolean;
BEGIN
FirstOne := TRUE;
FlagAll := FALSE;
IF (FileArea <> FArea) THEN
ChangeFileArea(FArea);
IF (FileArea = FArea) THEN
BEGIN
LoadFileArea(FileArea);
LIL := 0;
CLS;
Found := FALSE;
Prompt('^1Scanning ^5'+MemFileArea.AreaName+' #'+IntToStr(CompFileArea(FArea,0))+'^1 ...');
FindFirst(MemFileArea.DLPath+FileName1,AnyFile - VolumeID - Directory - DOS.Hidden,DirInfo);
WHILE (DOSError = 0) AND (NOT Abort) AND (NOT HangUp) DO
BEGIN
DirInfo.Name := Align(DirInfo.Name);
RecNo(FileInfo,DirInfo.Name,DirFileRecNum);
IF (BadDownloadPath) THEN
Exit;
IF (DirFileRecNum = -1) THEN
BEGIN
FSize := GetFileSize(MemFileArea.DLPath+DirInfo.Name);
IF (FSize = 0) THEN
BEGIN
FileInfo.FileSize := 0;
Include(FileInfo.FIFlags,FIIsRequest);
END
ELSE
BEGIN
FileInfo.FileSize := FSize;
Exclude(FileInfo.FIFlags,FIIsRequest);
END;
UpdateFileInfo(FileInfo,DirInfo.Name,GotPts);
IF (FirstOne) THEN
BEGIN
DisplayFileAreaHeader;
FirstOne := FALSE;
END;
GotDesc := FALSE;
IF (General.FileDiz) AND (DizExists(MemFileArea.DLPath+DirInfo.Name)) THEN
BEGIN
GetDiz(FileInfo,ExtendedArray,NumExtDesc);
Star('Complete.');
Prompt(' ^9'+PadRightInt(FArrayRecNum1,2)+' ^5'+DirInfo.Name+' ^4'+GetFileStats(FileInfo)+' ');
IF (FlagAll) THEN
Ok := TRUE
ELSE
BEGIN
Prt('Upload? (Yes,No,All,Quit): ');
OneK(Cmd,'QYNA',TRUE,TRUE);
Ok := (Cmd = 'Y') OR (Cmd = 'A');
FlagAll := (Cmd = 'A');
Abort := (Cmd = 'Q');
END;
GotDesc := TRUE;
END
ELSE
BEGIN
Prompt(' ^9'+PadRightInt(FArrayRecNum1,2)+' ^5'+DirInfo.Name+' ^4'+GetFileStats(FileInfo)+' ');
MPL(50);
InputL(FileInfo.Description,50);
Ok := TRUE;
IF (FileInfo.Description <> '') AND (FileInfo.Description[1] = '.') THEN
BEGIN
IF (Length(FileInfo.Description) = 1) THEN
BEGIN
Abort := TRUE;
Exit;
END;
Cmd := UpCase(FileInfo.Description[2]);
CASE Cmd OF
'D' : BEGIN
Kill(MemFileArea.DLPath+DirInfo.Name);
Ok := FALSE;
END;
'N' : BEGIN
Next := TRUE;
Exit;
END;
'S' : Ok := FALSE;
END;
END;
END;
Inc(FArrayRecNum1);
IF (FArrayRecNum1 = 100) THEN
FArrayRecNum1 := 0;
IF (Ok) THEN
BEGIN
IF (NOT GotDesc) THEN
BEGIN
FillChar(ExtendedArray,SizeOf(ExtendedArray),0);
Counter := 0;
REPEAT
Inc(Counter);
Prt(PadLeftStr('',28));
MPL(50);
InputL(ExtendedArray[Counter],50);
IF (ExtendedArray[Counter] = '') THEN
Counter := MaxExtDesc;
UNTIL (Counter = MaxExtDesc) OR (HangUp);
NL;
END;
WriteFV(FileInfo,FileSize(FileInfoFile),ExtendedArray);
SysOpLog('^3Uploaded "^5'+SQOutSp(DirInfo.Name)+'^3" to ^5'+MemFileArea.AreaName);
Found := TRUE;
END;
END;
Close(FileInfoFile);
Close(ExtInfoFile);
WKey;
FindNext(DirInfo);
END;
IF (NOT Found) THEN
BEGIN
LIL := 0;
BackErase(15 + LennMCI(MemFileArea.AreaName) + Length(IntToStr(CompFileArea(FArea,0))));
END;
END;
END;
BEGIN
NL;
Print('Upload files into file areas -');
NL;
SearchAllFileAreas := PYNQ('Search all file areas? ',0,FALSE);
NL;
IF NOT PYNQ('Search by file spec? ',0,FALSE) THEN
FileName := '*.*'
ELSE
BEGIN
NL;
Prompt('File name (^5<CR>^1=^5All^1): ');
GetFileName(FileName);
END;
NL;
Print('^1Enter . to end processing, .S to skip the file, .N to skip to');
Print('^1the next directory, and .D to delete the file.');
NL;
PauseScr(FALSE);
InitFArray(FArray);
FArrayRecNum := 0;
Abort := FALSE;
Next := FALSE;
IF (NOT SearchAllFileAreas) THEN
UploadFiles(FileArea,FileName,FArrayRecNum)
ELSE
BEGIN
SaveFileArea := FileArea;
FArea := 1;
WHILE (FArea >= 1) AND (FArea <= NumFileAreas) AND (NOT Abort) AND (NOT HangUp) DO
BEGIN
UploadFiles(FArea,FileName,FArrayRecNum);
WKey;
Inc(FArea);
END;
FileArea := SaveFileArea;
LoadFileArea(FileArea);
END;
END;
END.

995
SOURCE/FILE6.PAS Normal file
View File

@ -0,0 +1,995 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S+,V-}
UNIT File6;
INTERFACE
USES
Common;
FUNCTION CheckBatchDL(FileName: Str52): Boolean;
PROCEDURE EditBatchDLQueue;
PROCEDURE BatchDownload;
PROCEDURE ListBatchDLFiles;
PROCEDURE RemoveBatchDLFiles;
PROCEDURE ClearBatchDlQueue;
IMPLEMENTATION
USES
Dos,
Common5,
ExecBat,
File0,
File1,
File2,
File4,
File12,
MultNode,
ShortMsg,
TimeFunc;
FUNCTION CheckBatchDL(FileName: Str52): Boolean;
VAR
RecNum: LongInt;
FileFound: Boolean;
BEGIN
FileFound := FALSE;
IF (NumBatchDLFiles > 0) THEN
BEGIN
Assign(BatchDLFile,General.DataPath+'BATCHDL.DAT');
Reset(BatchDLFile);
RecNum := 1;
WHILE (RecNum <= FileSize(BatchDLFile)) AND (NOT FileFound) DO
BEGIN
Seek(BatchDLFile,(RecNum - 1));
Read(BatchDLFile,BatchDL);
IF (BatchDL.BDLUserNum = UserNum) AND (BatchDL.BDLFileName = FileName) THEN
FileFound := TRUE;
Inc(RecNum);
END;
Close(BatchDLFile);
LastError := IOResult;
END;
CheckBatchDL := FileFound;
END;
PROCEDURE EditBatchDLQueue;
VAR
Cmd: CHAR;
BEGIN
IF (NumBatchDLFiles = 0) THEN
BEGIN
NL;
Print('The batch download queue is empty');
Exit;
END;
REPEAT
NL;
Prt('Batch download queue [^5C^4=^5Clear Batch^4,^5L^4=^5List Batch^4,^5R^4=^5Remove a file^4,^5Q^4=^5Quit^4]: ');
OneK(Cmd,'QCLR',TRUE,TRUE);
CASE Cmd OF
'C' : ClearBatchDlQueue;
'L' : ListBatchDLFiles;
'R' : RemoveBatchDLFiles;
END;
UNTIL (Cmd = 'Q') OR (HangUp);
END;
PROCEDURE BatchDownload;
TYPE
TotalsRecordType = RECORD
FilesDL,
FilesDLRatio: Byte;
BytesDL,
BytesDLRatio,
PointsDL,
PointsDLRatio: LongInt;
END;
VAR
Totals: TotalsRecordType;
FileListTxt,
DLFListTxt: Text;
NewFileName: AStr;
SaveLastDirFileName: Str12;
NumExtDesc,
Counter,
Counter1: BYTE;
ReturnCode,
SaveFileArea,
DirFileRecNum,
ProtocolNumber,
SaveLastDirFileRecNum,
ToXfer: Integer;
RecNum,
RecNum1,
TransferTime: LongInt;
AutoLogOff,
FO: Boolean;
PROCEDURE AddNacc(BatchDL: BatchDLRecordType);
BEGIN
IF (BatchDL.BDLSection = -1) THEN
BEGIN
IF (IsFileAttach IN BatchDL.BDLFlags) THEN
MemFileArea.AreaName := 'File Attach'
ELSE IF (IsUnlisted IN BatchDL.BDLFlags) THEN
MemFileArea.AreaName := 'Unlisted Download'
ELSE IF (IsTempArc IN BatchDL.BDLFlags) THEN
MemFileArea.AreaName := 'Temporary Archive'
ELSE IF (IsQWK IN BatchDL.BDLFlags) THEN
MemFileArea.AreaName := 'QWK Download';
END
ELSE
BEGIN
SaveLastDirFileRecNum := LastDIRRecNum;
SaveLastDirFileName := LastDIRFileName;
FO := (FileRec(FileInfoFile).Mode <> FMClosed);
IF (FO) THEN
BEGIN
Close(FileInfoFile);
Close(ExtInfoFile);
END;
SaveFileArea := FileArea;
FileArea := BatchDL.BDLSection;
RecNo(FileInfo,StripName(BatchDL.BDLFileName),DirFileRecNum);
IF (BadDownloadPath) THEN
Exit;
IF (DirFileRecNum <> -1) THEN
BEGIN
Seek(FileInfoFile,DirFileRecNum);
Read(FileInfoFile,FileInfo);
Inc(FileInfo.Downloaded);
Seek(FileInfoFile,DirFileRecNum);
Write(FileInfoFile,FileInfo);
END;
Close(FileInfoFile);
Close(ExtInfoFile);
FileArea := SaveFileArea;
IF (FO) THEN
InitFileArea(FileArea);
LastDIRRecNum := SaveLastDirFileRecNum;
LastDIRFileName := SaveLastDirFileName;
END;
NL;
Star(StripName(BatchDL.BDLFileName)+' successfully downloaded.');
SysOpLog('^3Batch downloaded: "^5'+StripName(BatchDL.BDLFileName)+'^3" from ^5'+
MemFileArea.AreaName+'.');
LastError := IOResult;
END;
FUNCTION ReverseSlash(S: AStr): AStr;
VAR
Counter: Byte;
BEGIN
FOR Counter := 1 TO Length(S) DO
IF (S[Counter] = '/') THEN
S[Counter] := '\';
ReverseSlash := S;
END;
PROCEDURE UpdateSatistics(BatchDL: BatchDLRecordType);
BEGIN
IF (Totals.FilesDL < 255) THEN
Inc(Totals.FilesDL);
IF ((Totals.BytesDL + BatchDL.BDLFSize) < 2147483647) THEN
Inc(Totals.BytesDL,BatchDL.BDLFSize)
ELSE
Totals.BytesDL := 2147483647;
IF ((Totals.PointsDL + BatchDL.BDLPoints) < 2147483647) THEN
Inc(Totals.PointsDL,BatchDL.BDLPoints)
ELSE
Totals.PointsDL := 2147483647;
IF (NOT (IsNoRatio IN BatchDL.BDLFlags)) THEN
BEGIN
IF (Totals.FilesDLRatio < 255) THEN
Inc(Totals.FilesDLRatio);
IF ((Totals.BytesDLRatio + BatchDL.BDLFSize) < 2147483647) THEN
Inc(Totals.BytesDLRatio,BatchDL.BDLFSize)
ELSE
Totals.BytesDLRatio := 2147483647;
END;
IF (NOT (IsNoFilePoints IN BatchDL.BDLFlags)) THEN
IF ((Totals.PointsDLRatio + BatchDL.BDLPoints) < 2147483647) THEN
Inc(Totals.PointsDLRatio,BatchDL.BDLPoints)
ELSE
Totals.PointsDLRatio := 2147483647;
AddNacc(BatchDL);
WITH FileInfo DO
BEGIN
FileName := StripName(BatchDL.BDLFileName);
Description := '';
FilePoints := BatchDL.BDLPoints;
Downloaded := 0;
FileSize := 0;
OwnerNum := BatchDL.BDLUploader;
OwnerName := BatchDL.BDLOwnerName;
FileDate := 0;
VPointer := 0;
VTextSize := 0;
FIFlags := [];
END;
CreditUploader(FileInfo);
Dec(NumBatchDLFiles);
Dec(BatchDLTime,BatchDL.BDLTime);
Dec(BatchDLSize,BatchDL.BDLFSize);
Dec(BatchDLPoints,BatchDL.BDLPoints);
IF (BatchDL.BDLStorage = Copied) THEN
Kill(BatchDL.BDLFileName);
END;
PROCEDURE ChopOfSpace(VAR S: AStr);
BEGIN
WHILE (S[1] = ' ') DO
S := Copy(S,2,(Length(S) - 1));
IF (Pos(' ',S) <> 0) THEN
S := Copy(S,1,(Pos(' ',S) - 1));
END;
PROCEDURE FigureSucc;
VAR
TempLogTxt,
DLoadLogTxt: Text;
LogStr,
FileStr,
StatStr: AStr;
RecNum,
RecNum1: LongInt;
ToFile,
ReadLog,
FoundFile,
FoundReturnCode: Boolean;
BEGIN
ReadLog := FALSE;
ToFile := FALSE;
IF (Protocol.TempLog <> '') THEN
BEGIN
Assign(TempLogTxt,FunctionalMCI(Protocol.TempLog,'',''));
Reset(TempLogTxt);
IF (IOResult = 0) THEN
BEGIN
ReadLog := TRUE;
IF (FunctionalMCI(Protocol.DLoadLog,'','') <> '') THEN
BEGIN
Assign(DLoadLogTxt,FunctionalMCI(Protocol.DLoadLog,'',''));
Append(DLoadLogTxt);
IF (IOResult = 2) THEN
ReWrite(DLoadLogTxt);
ToFile := TRUE;
END;
SysOpLog('Start scan of: "^0'+AllCaps(FunctionalMCI(Protocol.TempLog,'',''))+'^1".');
WHILE (NOT EOF(TempLogTxt)) DO
BEGIN
ReadLn(TempLogTxt,LogStr);
IF (ToFile) THEN
WriteLn(DLoadLogTxt,LogStr);
FileStr := Copy(LogStr,Protocol.TempLogPF,((Length(LogStr) - Protocol.TempLogPF) - 1));
StatStr := Copy(LogStr,Protocol.TempLogPS,((Length(LogStr) - Protocol.TempLogPS) - 1));
FileStr := ReverseSlash(FileStr);
ChopOfSpace(FileStr);
FoundReturnCode := FALSE;
FoundFile := FALSE;
Reset(BatchDLFile);
RecNum := 1;
WHILE (RecNum <= FileSize(BatchDLFile)) AND (NOT FoundFile) DO
BEGIN
Seek(BatchDLFile,(RecNum - 1));
Read(BatchDLFile,BatchDL);
IF (BatchDL.BDLUserNum = UserNum) AND (Pos(AllCaps(BatchDL.BDLFileName),AllCaps(FileStr)) <> 0) THEN
BEGIN
FoundFile := TRUE;
IF (FindReturnCode(Protocol.DLCode,Protocol.PRFlags,StatStr)) THEN
BEGIN
FoundReturnCode := TRUE;
UpdateSatistics(BatchDL);
Dec(RecNum);
IF (RecNum >= 0) AND (RecNum <= (FileSize(BatchDLFile) - 2)) THEN
FOR RecNum1 := RecNum TO (FileSize(BatchDLFile) - 2) DO
BEGIN
Seek(BatchDLFile,(RecNum1 + 1));
Read(BatchDLFile,BatchDL);
Seek(BatchDLFile,RecNum1);
Write(BatchDLFile,BatchDL);
END;
Seek(BatchDLFile,(FileSize(BatchDLFile) - 1));
Truncate(BatchDLFile);
END;
END;
Inc(RecNum);
END;
IF (NOT FoundFile) THEN
SysOpLog('^7File not found: "^5'+BatchDL.BDLFileName+'^7"')
ELSE IF (NOT FoundReturnCode) THEN
SysOpLog('^7Return code not found: "^5'+BatchDL.BDLFileName+'^7"');
END;
SysOpLog('End scan of: "^0'+AllCaps(FunctionalMCI(Protocol.TempLog,'',''))+'^1".');
Close(TempLogTxt);
IF (ToFile) THEN
Close(DLoadLogTxt);
END;
END;
IF (NOT ReadLog) THEN
BEGIN
SysOpLog('Start scan of: "^0BATCHDL.DAT^1"');
Reset(BatchDLFile);
RecNum := 1;
WHILE (RecNum <= FileSize(BatchDLFile)) DO
BEGIN
Seek(BatchDLFile,(RecNum - 1));
Read(BatchDLFile,BatchDL);
IF (BatchDL.BDLUserNum = UserNum) THEN
BEGIN
UpdateSatistics(BatchDL);
Dec(RecNum);
IF (RecNum >= 0) AND (RecNum <= (FileSize(BatchDLFile) - 2)) THEN
FOR RecNum1 := RecNum TO (FileSize(BatchDLFile) - 2) DO
BEGIN
Seek(BatchDLFile,(RecNum1 + 1));
Read(BatchDLFile,BatchDL);
Seek(BatchDLFile,RecNum1);
Write(BatchDLFile,BatchDL);
END;
Seek(BatchDLFile,(FileSize(BatchDLFile) - 1));
Truncate(BatchDLFile);
END;
Inc(RecNum);
END;
SysOpLog('End scan of: "^0BATCHDL.DAT^1"');
END;
END;
BEGIN
IF (NumBatchDLFiles = 0) THEN
BEGIN
NL;
Print('The batch download queue is empty.');
Exit;
END;
NL;
Print('^5Batch download (Statistics):^1');
NL;
Star('^1Total file(s) : ^5'+FormatNumber(NumBatchDLFiles)+'^1');
Star('^1Total size : ^5'+ConvertBytes(BatchDLSize,FALSE)+'^1');
Star('^1Total file points : ^5'+FormatNumber(BatchDLPoints)+'^1');
Star('^1Download time : ^5'+CTim(BatchDLTime)+'^1');
Star('^1Time left online : ^5'+CTim(NSL)+'^1');
IF (BatchDLPoints > ThisUser.FilePoints) THEN
BEGIN
NL;
Print('^7Insufficient file points, remove file(s) from your batch queue!^1');
NL;
Print('^1Chargeable : ^5'+FormatNumber(BatchDLPoints)+'^1');
Print('^1Your account : ^5'+FormatNumber(ThisUser.FilePoints)+'^1');
NL;
EditBatchDLQueue;
Exit;
END;
IF (BatchDLTime > NSL) THEN
BEGIN
NL;
Print('^7Insufficient time left online, remove file(s) from your batch queue!^1');
NL;
EditBatchDLQueue;
Exit;
END;
ProtocolNumber := DoProtocol(Protocol,FALSE,TRUE,TRUE,FALSE);
CASE ProtocolNumber OF
-1 : ;
-2 : Exit;
-3 : ;
-4 : ;
-5 : EditBatchDLQueue;
ELSE
IF (InCom) THEN
BEGIN
Assign(BatchDLFile,General.DataPath+'BATCHDL.DAT');
Reset(BatchDLFile);
FillChar(Totals,SizeOf(Totals),0);
PurgeDir(TempDir+'UP\',FALSE);
IF Exist(FunctionalMCI(Protocol.TempLog,'','')) THEN
Kill(FunctionalMCI(Protocol.TempLog,'',''));
IF Exist(TempDir+'ARC\FILES.BBS') THEN
Kill(TempDir+'ARC\FILES.BBS');
IF Exist(FunctionalMCI(Protocol.DLFList,'','')) THEN
Kill(FunctionalMCI(Protocol.DLFList,'',''));
NL;
AutoLogOff := PYNQ('Auto-logoff after file transfer? ',0,FALSE);
NL;
IF PYNQ('Download file descriptions? ',0,FALSE) THEN
BEGIN
Assign(FileListTxt,TempDir+'ARC\FILES.BBS');
ReWrite(FileListTxt);
Writeln(FileListTxt,StripColor(General.BBSName)+' Batch Download File Listing');
WriteLn(FileListTxt);
Reset(BatchDLFile);
RecNum := 1;
WHILE (RecNum <= FileSize(BatchDLFile)) DO
BEGIN
Seek(BatchDLFile,(RecNum - 1));
Read(BatchDLFile,BatchDL);
IF (BatchDL.BDLUserNum = UserNum) THEN
BEGIN
IF (BatchDL.BDLSection = -1) THEN
WriteLn(FileListTxt,PadLeftStr(Align(StripName(BatchDL.BDLFileName)),14)+' [No Description Available]')
ELSE
BEGIN
SaveLastDirFileRecNum := LastDIRRecNum;
SaveLastDirFileName := LastDIRFileName;
FO := (FileRec(FileInfoFile).Mode <> FMClosed);
IF (FO) THEN
BEGIN
Close(FileInfoFile);
Close(ExtInfoFile);
END;
SaveFileArea := FileArea;
FileArea := BatchDL.BDLSection;
RecNo(FileInfo,StripName(BatchDL.BDLFileName),DirFileRecNum);
IF (BadDownloadPath) THEN
WriteLn(FileListTxt,PadLeftStr(Align(StripName(BatchDL.BDLFileName)),14)+' [Bad Download Path]')
ELSE IF (DirFileRecNum = -1) THEN
WriteLn(FileListTxt,PadLeftStr(Align(StripName(BatchDL.BDLFileName)),14)+' [File Not Found]')
ELSE
BEGIN
Seek(FileInfoFile,DirFileRecNum);
Read(FileInfoFile,FileInfo);
WriteLn(FileListTxt,PadLeftStr(Align(StripName(BatchDL.BDLFileName)),14)+FileInfo.Description);
IF (FileInfo.VPointer <> -1) THEN
BEGIN
LoadVerbArray(FileInfo,ExtendedArray,NumExtDesc);
FOR Counter1 := 1 TO NumExtDesc DO
IF (ExtendedArray[Counter1] <> '') THEN
WriteLn(FileListTxt,PadLeftStr('',14)+ExtendedArray[Counter1]);
END;
Close(FileInfoFile);
Close(ExtInfoFile);
FileArea := SaveFileArea;
IF (FO) THEN
InitFileArea(FileArea);
LastDIRRecNum := SaveLastDirFileRecNum;
LastDIRFileName := SaveLastDirFileName;
LastError := IOResult;
END;
WriteLn(FileListTxt);
END;
END;
Inc(RecNum);
END;
Close(FileListTxt);
WITH BatchDL DO
BEGIN
BDLFileName := TempDir+'ARC\FILES.BBS';
BDLOwnerName := Caps(ThisUser.Name);
BDLStorage := Disk;
BDLUserNum := UserNum;
BDLSection := -1;
BDLPoints := 0;
BDLUploader := UserNum;
BDLFSize := GetFileSize(TempDir+'ARC\FILES.BBS');
BDLTime := (BDLFSize DIV Rate);
BDLFlags := [];
END;
Seek(BatchDLFile,FileSize(BatchDLFILE));
Write(BatchDLFile,BatchDL);
Inc(NumBatchDLFiles);
Inc(BatchDLTime,BatchDL.BDLTime);
Inc(BatchDLSize,BatchDL.BDLFSize);
Inc(BatchDLPoints,BatchDL.BDLPoints);
NL;
Print('^1File : ^5FILES.BBS^1');
Print('^1Size : ^5'+ConvertBytes(BatchDL.BDLFSize,FALSE)+'^1');
Print('^1File points : ^5'+FormatNumber(BatchDL.BDLPoints)+'^1');
Print('^1Download time : ^5'+CTim(BatchDL.BDLTime)+'^1');
NL;
Print('^1New download time : ^5'+CTim(BatchDLTime)+'^1');
LastError := IOResult;
END;
Reset(BatchDLFile);
Counter1 := 0;
RecNum := 1;
WHILE (RecNum <= FileSize(BatchDLFile)) AND (Counter1 = 0) DO
BEGIN
Seek(BatchDLFile,(RecNum - 1));
Read(BatchDLFile,BatchDL);
IF (BatchDL.BDLUserNum = UserNum) AND (BatchDL.BDLStorage = CD) THEN
Inc(Counter1);
Inc(RecNum);
END;
IF (Counter1 <> 0) THEN
BEGIN
NL;
Print('Please wait, copying files from CD-ROM ... ');
Reset(BatchDLFile);
RecNum := 1;
WHILE (RecNum <= FileSize(BatchDLFile)) DO
BEGIN
Seek(BatchDLFile,(RecNum - 1));
Read(BatchDLFile,BatchDL);
IF (BatchDL.BDLUserNum = UserNum) AND (BatchDL.BDLStorage = CD) THEN
IF CopyMoveFile(TRUE,'',BatchDL.BDLFileName,
TempDir+'CD\'+StripName(BatchDL.BDLFileName),FALSE) THEN
BEGIN
BatchDL.BDLStorage := Copied;
BatchDL.BDLFileName := TempDir+'CD\'+StripName(BatchDL.BDLFileName);
Seek(BatchDLFile,(RecNum - 1));
Write(BatchDLFile,BatchDL);
END;
Inc(RecNum);
END;
END;
NewFileName := General.ProtPath+FunctionalMCI(Protocol.DLCmd,'','');
ToXfer := 0;
IF (Pos('%F',Protocol.DLCmd) <> 0) THEN
BEGIN
Reset(BatchDLFile);
RecNum := 1;
WHILE (RecNum <= FileSize(BatchDLFile)) DO
BEGIN
Seek(BatchDLFile,(RecNum - 1));
Read(BatchDLFile,BatchDL);
IF (BatchDL.BDLUserNum = UserNum) THEN
BEGIN
Inc(ToXFer);
NewFileName := FunctionalMCI(NewFileName,BatchDL.BDLFileName,'');
IF (Length(NewFileName) > Protocol.MaxChrs) THEN
BEGIN
SysOpLog('^7Exceeds maximum DOS char length: "^5'+NewFileName+'^1"');
RecNum := FileSize(BatchDLFile);
END;
END;
Inc(RecNum);
END;
END;
IF (Protocol.DLFList <> '') THEN
BEGIN
Assign(DLFListTxt,FunctionalMCI(Protocol.DLFList,'',''));
ReWrite(DLFListTxt);
Reset(BatchDLFile);
RecNum := 1;
WHILE (RecNum <= FileSize(BatchDLFile)) DO
BEGIN
Seek(BatchDLFile,(RecNum - 1));
Read(BatchDLFile,BatchDL);
IF (BatchDL.BDLUserNum = UserNum) THEN
BEGIN
WriteLn(DLFListTxt,BatchDL.BDLFileName);
Inc(ToXfer);
END;
Inc(RecNum);
END;
Close(DLFListTxt);
LastError := IOResult;
END;
NL;
Star('Ready to send batch download transfer.');
ExecProtocol('',
TempDir+'UP\',
FunctionalMCI(Protocol.EnvCmd,'','')
+#13#10+
NewFileName,
-1,
ReturnCode,
TransferTime);
NL;
Star('Batch download transfer complete.');
IF Exist(FunctionalMCI(Protocol.DLFList,'','')) THEN
Kill(FunctionalMCI(Protocol.DLFList,'',''));
IF Exist(TempDir+'ARC\FILES.BBS') THEN
BEGIN
Reset(BatchDLFile);
RecNum1 := -1;
RecNum := 1;
WHILE (RecNum <= FileSize(BatchDLFile)) AND (RecNum1 = -1) DO
BEGIN
Seek(BatchDLFile,(RecNum - 1));
Read(BatchDLFile,BatchDL);
IF ((BatchDL.BDLUserNum = UserNum) AND (BatchDL.BDLFileName = TempDir+'ARC\FILES.BBS')) THEN
BEGIN
Dec(NumBatchDLFiles);
Dec(BatchDLTime,BatchDL.BDLTime);
Dec(BatchDLSize,BatchDL.BDLFSize);
Dec(BatchDLPoints,BatchDL.BDLPoints);
IF (BatchDL.BDLStorage = Copied) THEN
Kill(BatchDL.BDLFileName);
RecNum1 := RecNum;
END;
Inc(RecNum);
END;
IF (RecNum1 <> -1) THEN
BEGIN
Dec(RecNum1);
FOR RecNum := RecNum1 TO (FileSize(BatchDLFile) - 2) DO
BEGIN
Seek(BatchDLFile,(RecNum + 1));
Read(BatchDLFile,BatchDL);
Seek(BatchDLFile,RecNum);
Write(BatchDLFile,BatchDL);
END;
Seek(BatchDLFile,(FileSize(BatchDLFile) - 1));
Truncate(BatchDLFile);
END;
Kill(TempDir+'ARC\FILES.BBS');
END;
FigureSucc;
IF Exist(FunctionalMCI(Protocol.TempLog,'','')) THEN
Kill(FunctionalMCI(Protocol.TempLog,'',''));
IF ((DownloadsToday + Totals.FilesDL) < 2147483647) THEN
Inc(DownloadsToday,Totals.FilesDL)
ELSE
DownloadsToday := 2147483647;
IF ((DownloadKBytesToday + (Totals.BytesDL DIV 1024)) < 2147483647) THEN
Inc(DownloadKBytesToday,(Totals.BytesDL DIV 1024))
ELSE
DownloadKBytesToday := 2147483647;
IF ((ThisUser.Downloads + Totals.FilesDLRatio) < 2147483647) THEN
Inc(ThisUser.Downloads,Totals.FilesDLRatio)
ELSE
ThisUser.Downloads := 2147483647;
IF ((ThisUser.DLToday + Totals.FilesDLRatio) < 2147483647) THEN
Inc(ThisUser.DLToday,Totals.FilesDLRatio)
ELSE
ThisUser.DLToday := 2147483647;
IF ((ThisUser.DK + (Totals.BytesDLRatio DIV 1024)) < 2147483647) THEN
Inc(ThisUser.DK,(Totals.BytesDLRatio DIV 1024))
ELSE
ThisUser.DK := 2147483647;
IF ((ThisUser.DLKToday + (Totals.BytesDLRatio DIV 1024)) < 2147483647) THEN
Inc(ThisUser.DLKToday,(Totals.BytesDLRatio DIV 1024))
ELSE
ThisUser.DLKToday := 2147483647;
IF ((ThisUser.FilePoints - Totals.PointsDLRatio) > 0) THEN
Dec(ThisUser.FilePoints,Totals.PointsDLRatio)
ELSE
ThisUser.FilePoints := 0;
LIL := 0;
NL;
Print('^5Batch download (Totals):^1');
NL;
Star('^1Total file(s) : ^5'+FormatNumber(Totals.FilesDL));
Star('^1Total size : ^5'+ConvertBytes(Totals.BytesDL,FALSE));
Star('^1Total file points : ^5'+FormatNumber(Totals.PointsDL));
Star('^1Download time : ^5'+FormattedTime(TransferTime));
Star('^1Transfer rate : ^5'+FormatNumber(GetCPS(Totals.BytesDL,TransferTime))+' cps');
SysOpLog('^3 - Totals:'+
' '+FormatNumber(Totals.FilesDL)+' '+Plural('file',Totals.FilesDL)+
', '+ConvertBytes(Totals.BytesDL,FALSE)+
', '+FormatNumber(Totals.PointsDL)+' fp'+
', '+FormattedTime(TransferTime)+' tt'+
', '+FormatNumber(GetCPS(Totals.BytesDL,Transfertime))+' cps.');
IF (Totals.FilesDL < Totals.FilesDLRatio) THEN
Totals.FilesDLRatio := Totals.FilesDL;
LIL := 0;
NL;
Print('^5Batch download (Charges):^1');
NL;
Star('^1Total file(s) : ^5'+FormatNumber(Totals.FilesDLRatio));
Star('^1Total size : ^5'+ConvertBytes(Totals.BytesDLRatio,FALSE));
Star('^1Total file points : ^5'+FormatNumber(Totals.PointsDLRatio));
SysOpLog('^3 - Charges:'+
' '+FormatNumber(Totals.FilesDLRatio)+' '+Plural('file',Totals.FilesDLRatio)+
', '+ConvertBytes(Totals.BytesDLRatio,FALSE)+
', '+FormatNumber(Totals.PointsDLRatio)+' fp.');
IF (NumBatchDLFiles > 0) THEN
BEGIN
Totals.BytesDL := 0;
Totals.PointsDL := 0;
Reset(BatchDLFile);
RecNum := 1;
WHILE (RecNum <= FileSize(BatchDLFile)) DO
BEGIN
Seek(BatchDLFile,(RecNum - 1));
Read(BatchDLFile,BatchDL);
IF (BatchDL.BDLUserNum = UserNum) THEN
BEGIN
Inc(Totals.BytesDL,BatchDL.BDLFSize);
Inc(Totals.PointsDL,BatchDL.BDLPoints);
END;
Inc(RecNum);
END;
LIL := 0;
NL;
Print('^5Batch download (Not Transferred):^1');
NL;
Star('^1Total file(s) : ^5'+FormatNumber(NumBatchDLFiles));
Star('^1Total size : ^5'+ConvertBytes(Totals.BytesDL,FALSE));
Star('^1Total file points : ^5'+FormatNumber(Totals.PointsDL));
SysOpLog('^3 - Not downloaded:'+
' '+FormatNumber(NumBatchDLFiles)+' '+Plural('file',NumBatchDLFiles)+
', '+ConvertBytes(Totals.BytesDL,FALSE)+
', '+FormatNumber(Totals.PointsDL)+' fp.');
END;
Close(BatchDLFile);
LIL := 0;
NL;
Print('^5Enjoy the file(s), '+Caps(ThisUser.Name)+'!^1');
PauseScr(FALSE);
SaveURec(ThisUser,UserNum);
IF (ProtBiDirectional IN Protocol.PRFlags) THEN
BatchUpload(TRUE,TransferTime);
IF (AutoLogOff) THEN
CountDown
END;
END;
END;
PROCEDURE ListBatchDLFiles;
VAR
FileNumToList: Byte;
RecNum: LongInt;
BEGIN
IF (NumBatchDLFiles = 0) THEN
BEGIN
NL;
Print('The batch download queue is empty.');
Exit;
END;
Abort := FALSE;
Next := FALSE;
NL;
PrintACR('^4###:FileName.Ext Area Pts Bytes hh:mm:ss^1');
PrintACR('^4===:============:=====:======:=============:========^1');
Assign(BatchDLFile,General.DataPath+'BATCHDL.DAT');
Reset(BatchDLFile);
FileNumToList := 1;
RecNum := 1;
WHILE (RecNum <= FileSize(BatchDLFile)) AND (NOT Abort) AND (NOT HangUp) DO
BEGIN
Seek(BatchDLFile,(RecNum - 1));
Read(BatchDLFile,BatchDL);
IF (BatchDL.BDLUserNum = UserNum) THEN
BEGIN
PrintACR('^3'+PadRightInt(FileNumToList,3)+
'^4:^5'+Align(StripName(BatchDL.BDLFileName))+
' '+AOnOff((BatchDL.BDLSection = -1),'^7 --- ','^5'+PadRightInt(CompFileArea(BatchDL.BDLSection,0),5))+
' ^4'+PadRightStr(FormatNumber(BatchDL.BDLPoints),6)+
' ^4'+PadRightStr(FormatNumber(BatchDL.BDLFSize),13)+
' ^7'+CTim(BatchDL.BDLTime)+
AOnOff(IsNoRatio IN BatchDL.BDLFlags,'^5 [No-Ratio]','')+
AOnOff(IsNoFilePoints IN BatchDL.BDLFlags,'^5 [No-Points]','')+'^1');
Inc(FileNumToList);
END;
WKey;
Inc(RecNum);
END;
Close(BatchDLFile);
LastError := IOResult;
PrintACR('^4===:============:=====:======:=============:========^1');
PrintACR('^3'+PadLeftStr('Totals:',22)+
' ^4'+PadRightStr(FormatNumber(BatchDLPoints),6)+
' '+PadRightStr(FormatNumber(BatchDLSize),13)+
' ^7'+CTim(BatchDLTime)+'^1');
SysOpLog('Viewed the batch download queue.');
END;
PROCEDURE RemoveBatchDLFiles;
VAR
InputStr: Str3;
Counter,
FileNumToRemove: Byte;
RecNum,
RecNum1: LongInt;
BEGIN
IF (NumBatchDLFiles = 0) THEN
BEGIN
NL;
Print('The batch download queue is empty.');
Exit;
END;
InputStr := '?';
REPEAT
IF (InputStr = '?') THEN
ListBatchDLFiles;
NL;
Prt('File to remove? (^51^4-^5'+IntToStr(NumBatchDLFiles)+'^4) [^5?^4=^5List^4,^5<CR>^4=^5Quit^4]: ');
MPL(Length(IntToStr(NumBatchDLFiles)));
ScanInput(InputStr,^M'?');
FileNumToRemove := StrToInt(InputStr);
IF (NOT (InputStr[1] IN ['?','-',^M])) THEN
IF (FileNumToRemove < 1) OR (FileNumToRemove > NumBatchDLFiles) THEN
BEGIN
NL;
Print('^7The range must be from 1 to '+IntToStr(NumBatchDLFiles)+'!^1');
InputStr := '?';
END
ELSE
BEGIN
Counter := 0;
Assign(BatchDLFile,General.DataPath+'BATCHDL.DAT');
Reset(BatchDLFile);
RecNum := 1;
WHILE (RecNum <= FileSize(BatchDLFile)) DO
BEGIN
Seek(BatchDLFile,(RecNum - 1));
Read(BatchDLFile,BatchDL);
IF (BatchDL.BDLUserNum = UserNum) THEN
BEGIN
Inc(Counter);
IF (Counter = FileNumToRemove) THEN
BEGIN
Dec(NumBatchDLFiles);
Dec(BatchDLTime,BatchDL.BDLTime);
Dec(BatchDLSize,BatchDL.BDLFSize);
Dec(BatchDLPoints,BatchDL.BDLPoints);
IF (BatchDL.BDLStorage = Copied) THEN
Kill(BatchDL.BDLFileName);
NL;
Print('Removed from batch download queue: "^5'+StripName(BatchDL.BDLFileName)+'^1".');
SysOpLog('Batch DL Remove: "^5'+StripName(BatchDL.BDLFileName)+'^1".');
Dec(RecNum);
FOR RecNum1 := RecNum TO (FileSize(BatchDLFile) - 2) DO
BEGIN
Seek(BatchDLFile,(RecNum1 + 1));
Read(BatchDLFile,BatchDL);
Seek(BatchDLFile,RecNum1);
Write(BatchDLFile,BatchDL);
END;
Seek(BatchDLFile,(FileSize(BatchDLFile) - 1));
Truncate(BatchDLFile);
RecNum := FileSize(BatchDLFile);
END;
END;
Inc(RecNum);
END;
Close(BatchDLFile);
LastError := IOResult;
IF (NumBatchDLFiles <> 0) THEN
BEGIN
NL;
Print('^1Batch download queue: ^5'+IntToStr(NumBatchDLFiles)+' '+Plural('file',NumBatchDLFiles)+
', '+ConvertBytes(BatchDLSize,FALSE)+
', '+FormatNumber(BatchDLPoints)+
' '+Plural('file point',BatchDLPoints)+', '+FormattedTime(BatchDLTime));
END
ELSE
BEGIN
BatchDLTime := 0;
BatchDLSize := 0;
BatchDLPoints := 0;
NL;
Print('The batch download queue is now empty.');
SysOpLog('Cleared the batch download queue.');
END;
END;
UNTIL (InputStr <> '?') OR (HangUp);
END;
PROCEDURE ClearBatchDLQueue;
VAR
RecNum,
RecNum1: LongInt;
BEGIN
IF (NumBatchDLFiles = 0) THEN
BEGIN
NL;
Print('The batch download queue is empty.');
Exit;
END;
NL;
IF PYNQ('Clear batch download queue? ',0,FALSE) THEN
BEGIN
NL;
Assign(BatchDLFile,General.DataPath+'BATCHDL.DAT');
Reset(BatchDLFile);
RecNum := 1;
WHILE (RecNum <= FileSize(BatchDLFile)) DO
BEGIN
Seek(BatchDLFile,(RecNum - 1));
Read(BatchDLFile,BatchDL);
IF (BatchDL.BDLUserNum = UserNum) THEN
BEGIN
Dec(NumBatchDLFiles);
Dec(BatchDLTime,BatchDL.BDLTime);
Dec(BatchDLSize,BatchDL.BDLFSize);
Dec(BatchDLPoints,BatchDL.BDLPoints);
IF (BatchDL.BDLStorage = Copied) THEN
Kill(BatchDL.BDLFileName);
Print('Removed from batch download queue: "^5'+StripName(BatchDL.BDLFileName)+'^1".');
SysOpLog('Batch DL Remove: "^5'+StripName(BatchDL.BDLFileName)+'^1".');
Dec(RecNum);
FOR RecNum1 := RecNum TO (FileSize(BatchDLFile) - 2) DO
BEGIN
Seek(BatchDLFile,(RecNum1 + 1));
Read(BatchDLFile,BatchDL);
Seek(BatchDLFile,RecNum1);
Write(BatchDLFile,BatchDL);
END;
Seek(BatchDLFile,(FileSize(BatchDLFile) - 1));
Truncate(BatchDLFile);
END;
Inc(RecNum);
END;
Close(BatchDLFile);
LastError := IOResult;
BatchDLTime := 0;
BatchDLSize := 0;
BatchDLPoints := 0;
NL;
Print('The batch download queue is now empty.');
SysOpLog('Cleared the batch download queue.');
END;
END;
END.

199
SOURCE/FILE7.PAS Normal file
View File

@ -0,0 +1,199 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S+,V-}
UNIT File7;
INTERFACE
PROCEDURE CheckFilesBBS;
IMPLEMENTATION
USES
DOS,
Common,
File0,
File1,
File10,
TimeFunc;
PROCEDURE AddToDirFile(FileInfo: FileInfoRecordType);
VAR
User: UserRecordType;
NumExtDesc: Byte;
BEGIN
LoadURec(User,1);
WITH FileInfo DO
BEGIN
(*
FileName := ''; Value Passed
Description := ''; Value Passed
*)
FilePoints := 0;
Downloaded := 0;
(*
FileSize := 0; Value Passed
*)
OwnerNum := 1;
OwnerName := AllCaps(User.Name);
FileDate := Date2PD(DateStr);
VPointer := -1;
VTextSize := 0;
FIFlags := [FIHatched];
END;
IF (NOT General.FileCreditRatio) THEN
FileInfo.FilePoints := 0
ELSE
BEGIN
FileInfo.FilePoints := 0;
IF (General.FileCreditCompBaseSize > 0) THEN
FileInfo.FilePoints := ((FileInfo.FileSize DIV 1024) DIV General.FileCreditCompBaseSize);
END;
FillChar(ExtendedArray,SizeOf(ExtendedArray),0);
IF (General.FileDiz) AND (DizExists(MemFileArea.DLPath+SQOutSp(FileInfo.FileName))) THEN
GetDiz(FileInfo,ExtendedArray,NumExtDesc);
WriteFV(FileInfo,FileSize(FileInfoFile),ExtendedArray);
IF (UploadsToday < 2147483647) THEN
Inc(UploadsToday);
IF ((UploadKBytesToday + (FileInfo.FileSize DIV 1024)) < 2147483647) THEN
Inc(UploadKBytesToday,(FileInfo.FileSize DIV 1024))
ELSE
UploadKBytesToday := 2147483647;
SaveGeneral(FALSE);
Print('^1hatched!');
SysOpLog(' Hatched: "^5'+SQOutSp(FileInfo.FileName)+'^1" to "^5'+MemFileArea.AreaName+'^1"');
LastError := IOResult;
END;
(* Sample FILES.BBS
TDRAW463.ZIP THEDRAW SCREEN EDITOR VERSION 4.63 - (10/93) A text-orient
ZEJNGAME.LST [4777] 12-30-01 ZeNet Games list, Updated December 29th, 2
*)
PROCEDURE CheckFilesBBS;
VAR
BBSTxtFile: Text;
TempStr: AStr;
FArea,
SaveFileArea,
DirFileRecNum: Integer;
Found,
FirstTime,
SaveTempPause: Boolean;
BEGIN
SysOpLog('Scanning for FILES.BBS ...');
SaveFileArea := FileArea;
SaveTempPause := TempPause;
TempPause := FALSE;
Abort := FALSE;
Next := FALSE;
FArea := 1;
WHILE (FArea >= 1) AND (FArea <= NumFileAreas) AND (NOT Abort) AND (NOT HangUp) DO
BEGIN
LoadFileArea(FArea);
FirstTime := TRUE;
Found := FALSE;
LIL := 0;
CLS;
Prompt('^1Checking ^5'+MemFileArea.AreaName+' #'+IntToStr(CompFileArea(FArea,0))+'^1 ...');
IF (Exist(MemFileArea.DLPath+'FILES.BBS')) THEN
BEGIN
Assign(BBSTxtFile,MemFileArea.DLPath+'FILES.BBS');
Reset(BBSTxtFile);
WHILE NOT EOF(BBSTxtFile) DO
BEGIN
ReadLn(BBSTxtFile,TempStr);
TempStr := StripLeadSpace(TempStr);
IF (TempStr <> '') THEN
BEGIN
FileInfo.FileName := Align(AllCaps(Copy(TempStr,1,(Pos(' ',TempStr) - 1))));
IF (FirstTime) THEN
BEGIN
NL;
NL;
FirstTime := FALSE;
END;
Prompt('^1Processing "^5'+SQOutSp(FileInfo.FileName)+'^1" ... ');
IF (NOT Exist(MemFileArea.DLPath+SQOutSp(FileInfo.FileName))) THEN
BEGIN
Print('^7missing!^1');
SysOpLog(' ^7Missing: "^5'+SQOutSp(FileInfo.FileName)+'^7" from "^5'+MemFileArea.AreaName+'^7"');
END
ELSE
BEGIN
FileArea := FArea;
RecNo(FileInfo,FileInfo.FileName,DirFileRecNum);
IF (BadDownloadPath) THEN
Exit;
IF (DirFileRecNum <> -1) THEN
BEGIN
Print('^7duplicate!^1');
SysOpLog(' ^7Duplicate: "^5'+SQOutSp(FileInfo.FileName)+'^7" from "^5'+MemFileArea.AreaName+'^7"');
END
ELSE
BEGIN
TempStr := StripLeadSpace(Copy(TempStr,Pos(' ',TempStr),Length(TempStr)));
IF (TempStr[1] <> '[') THEN
FileInfo.Description := Copy(TempStr,1,50)
ELSE
BEGIN
TempStr := StripLeadSpace(Copy(TempStr,(Pos(']',TempStr) + 1),Length(TempStr)));
FileInfo.Description := StripLeadSpace(Copy(TempStr,(Pos(' ',TempStr) + 1),50));
END;
FileInfo.FileSize := GetFileSize(MemFileArea.DLPath+SQOutSp(FileInfo.FileName));
AddToDirFile(FileInfo);
END;
Close(FileInfoFile);
Close(ExtInfoFile);
END;
Found := TRUE;
END;
END;
Close(BBSTxtFile);
IF (NOT (FACDROM IN MemFileArea.FAFlags)) THEN
Erase(BBSTxtFile);
END;
IF (NOT Found) THEN
BEGIN
LIL := 0;
BackErase(15 + LennMCI(MemFileArea.AreaName) + Length(IntToStr(CompFileArea(FArea,0))));
END;
Inc(FArea);
END;
TempPause := SaveTempPause;
FileArea := SaveFileArea;
LoadFileArea(FileArea);
LastError := IOResult;
END;
END.

607
SOURCE/FILE8.PAS Normal file
View File

@ -0,0 +1,607 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S+,V-}
UNIT File8;
INTERFACE
USES
Dos,
Common;
PROCEDURE Send(FileInfo: FileInfoRecordType;
DirFileRecNum: Integer;
DownloadPath: PathStr;
VAR TransferFlags: TransferFlagSet);
PROCEDURE Receive(FileName: Str12;
UploadPath: PathStr;
ResumeFile: Boolean;
VAR UploadOk,
KeyboardAbort,
AddULBatch: Boolean;
VAR TransferTime: LongInt);
IMPLEMENTATION
USES
Crt,
ExecBat,
File0,
File1,
File2,
File4,
File6,
File12,
TimeFunc;
{ CheckFileRatio
1 - File bad
2 - File + Batch bad
3 - File Bad - Daily
4 - File + Batch bad - Daily
}
PROCEDURE CheckFileRatio(FileInfo: FileInfoRecordType; VAR ProtocolNumber: Integer);
VAR
Counter: Byte;
RecNum: LongInt;
FileKBSize: LongInt;
Ratio: Real;
BadRatio,
DailyLimits: Boolean;
BEGIN
FileKbSize := (FileInfo.FileSize DIV 1024);
IF (NumBatchDLFiles > 0) THEN
BEGIN
Assign(BatchDLFile,General.DataPath+'BATCHDL.DAT');
Reset(BatchDLFile);
RecNum := 1;
WHILE (RecNum <= FileSize(BatchDLFile)) DO
BEGIN
Seek(BatchDLFile,(RecNum - 1));
Read(BatchDLFile,BatchDL);
IF (BatchDL.BDLUserNum = UserNum) AND (BatchDL.BDLFileName = FileInfo.FileName) THEN
IF (NOT (IsNoRatio IN BatchDL.BDLFlags)) THEN
Inc(FileKBSize,(BatchDL.BDLFSize DIV 1024));
Inc(RecNum);
END;
Close(BatchDLFile);
LastError := IOResult;
END;
BadRatio := FALSE;
IF (ThisUser.UK > 0) THEN
Ratio := ((FileKbSize + ThisUser.DK) / ThisUser.UK)
ELSE
Ratio := (FileKBSize + ThisUser.DK);
IF (General.DLKRatio[ThisUser.SL] > 0) AND (Ratio > General.DLKRatio[ThisUser.SL]) THEN
BadRatio := TRUE;
IF (ThisUser.Uploads > 0) THEN
Ratio := (((ThisUser.Downloads + NumBatchDLFiles) + 1) / ThisUser.Uploads)
ELSE
Ratio := ((ThisUser.Downloads + NumBatchDLFiles) + 1);
IF (General.DLRatio[ThisUser.SL] > 0) AND (Ratio > General.DLRatio[ThisUser.SL]) THEN
BadRatio := TRUE;
IF (NOT General.ULDLRatio) THEN
BadRatio := FALSE;
DailyLimits := FALSE;
IF (General.DailyLimits) THEN
IF ((ThisUser.DLKToday + FileKbSize) > General.DLKOneDay[ThisUser.SL]) OR
(((ThisUser.DLToday + NumBatchDLFiles) + 1) > General.DLOneDay[ThisUser.SL]) THEN
BEGIN
BadRatio := TRUE;
DailyLimits := TRUE;
END;
IF (AACS(General.NoDLRatio)) OR (FNoDLRatio IN ThisUser.Flags) THEN
BadRatio := FALSE;
LoadFileArea(FileArea);
IF (FANoRatio IN MemFileArea.FAFlags) THEN
BadRatio := FALSE;
Counter := 0;
IF (BadRatio) THEN
IF (NumBatchDLFiles = 0) THEN
Counter := 1
ELSE
Counter := 2;
IF (DailyLimits) AND (Counter > 0) THEN
Inc(Counter,2);
CASE Counter OF
1,3 : BEGIN
IF (Counter = 3) THEN
BEGIN
PrintF('DLTMAX');
IF (NoFile) THEN
BEGIN
{
NL;
Print('^5Your upload/download ratio is too poor to download this.');
}
NL;
lRGLngStr(27,FALSE);
NL;
Print('^1Today you have downloaded '+FormatNumber(ThisUser.DLToday)+' '+Plural('file',ThisUser.DLToday)+
'^1 totaling '+FormatNumber(ThisUser.DLKToday)+'k');
NL;
Print('^1The maximum you can download in one day is '+FormatNumber(General.DLOneDay[ThisUser.SL])+
' '+Plural('file',General.DLOneDay[ThisUser.SL])+
'^1 totaling '+FormatNumber(General.DLKOneDay[ThisUser.SL])+'k');
END;
END
ELSE
BEGIN
PrintF('DLMAX');
IF (NoFile) THEN
BEGIN
{
NL;
Print('^5Your upload/download ratio is too poor to download this.');
}
NL;
lRGLngStr(27,FALSE);
NL;
Print('^5You have downloaded: '+FormatNumber(ThisUser.DK)+'k in '+FormatNumber(ThisUser.Downloads)+
' '+Plural('file',ThisUser.Downloads));
Print('^5You have uploaded : '+FormatNumber(ThisUser.UK)+'k in '+FormatNumber(ThisUser.Uploads)+
' '+Plural('file',ThisUser.Uploads));
NL;
Print('^5 1 upload for every '+FormatNumber(General.DLRatio[ThisUser.SL])+
' downloads must be maintained.');
Print('^5 1k must be uploaded for every '+FormatNumber(General.DLKRatio[ThisUser.SL])+'k downloaded.');
END;
END;
END;
2,4 : BEGIN
IF (Counter = 4) THEN
PrintF('DLBTMAX')
ELSE
PrintF('DLBMAX');
IF (NoFile) THEN
BEGIN
{
NL;
Print('^5Your upload/download ratio is too poor to download this.');
}
NL;
lRGLngStr(27,FALSE);
NL;
Print('^5Assuming you download the files already in the batch queue,');
IF (Counter = 2) THEN
Print('^5your upload/download ratio would be out of balance.')
ELSE
Print('^5you would exceed the maximum download limits for one day.');
END;
END;
END;
IF (Counter IN [1..4]) THEN
BEGIN
SysOpLog('Download refused: Ratio out of balance: '+SQOutSp(FileInfo.FileName));
SysOpLog(' ULs: '+FormatNumber(ThisUser.UK)+'k in '+FormatNumber(ThisUser.Uploads)+
' '+Plural('file',ThisUser.Uploads)+
' - DLs: '+FormatNumber(ThisUser.DK)+'k in '+FormatNumber(ThisUser.Downloads)+
' '+Plural('file',ThisUser.Downloads));
ProtocolNumber := -2;
END;
END;
PROCEDURE BatchDLAdd(FileInfo: FileInfoRecordType; DownloadPath: Str40; TransferFlags: TransferFlagSet);
VAR
User: UserRecordType;
BEGIN
IF CheckBatchDL(DownloadPath+FileInfo.FileName) THEN
BEGIN
NL;
Print('^7This file is already in the batch download queue!^1');
END
ELSE IF (NumBatchDLFiles = General.MaxBatchDLFiles) THEN
BEGIN
NL;
Print('^7The batch download queue is full!^1');
END
ELSE IF ((BatchDLTime + (FileInfo.FileSize DIV Rate)) > NSL) THEN
BEGIN
NL;
Print('^7Insufficient time left online to add to the batch download queue!^1');
END
ELSE
BEGIN
Assign(BatchDLFile,General.DataPath+'BATCHDL.DAT');
IF (NOT Exist(General.DataPath+'BATCHDL.DAT')) THEN
ReWrite(BatchDLFile)
ELSE
Reset(BatchDLFile);
WITH BatchDL DO
BEGIN
BDLFileName := SQOutSp(DownloadPath+FileInfo.FileName);
IF (FileArea <> -1) THEN
BDLOwnerName := AllCaps(FileInfo.OwnerName)
ELSE
BEGIN
LoadURec(User,1);
BDLOwnerName := AllCaps(User.Name);
END;
IF (IsCDRom IN TransferFlags) THEN
BDLStorage := CD
ELSE
BDLStorage := Disk;
BDLUserNum := UserNum;
BDLSection := FileArea;
IF (FileArea <> -1) THEN
BDLPoints := FileInfo.FilePoints
ELSE
BDLPoints := 0;
IF (FileArea <> -1) THEN
BDLUploader := FileInfo.OwnerNum
ELSE
BDLUploader := 1;
BDLFSize := FileInfo.FileSize;
BDLTime := (FileInfo.FileSize DIV Rate);
IF (IsFileAttach IN TransferFlags) THEN
Include(BDLFlags,IsFileAttach)
ELSE IF (IsUnlisted IN TransferFlags) THEN
Include(BDLFlags,IsUnlisted)
ELSE IF (IsTempArc IN TransferFlags) THEN
Include(BDLFlags,IsTempArc)
ELSE IF (IsQWK IN TransferFlags) THEN
Include(BDLFlags,IsQWK);
IF (NOT ChargeFilePoints(FileArea)) THEN
Include(BDLFlags,IsNoFilePoints);
IF (NOT ChargeFileRatio(FileArea)) THEN
Include(BDLFlags,IsNoRatio);
END;
Seek(BatchDLFile,FileSize(BatchDLFile));
Write(BatchDLFile,BatchDL);
Close(BatchDLFile);
Inc(NumBatchDLFiles);
Inc(BatchDLSize,BatchDL.BDLFSize);
Inc(BatchDLTime,BatchDL.BDLTime);
Inc(BatchDLPoints,BatchDL.BDLPoints);
{
NL;
Print('^5File added to batch download queue.');
}
lRGLngStr(30,FALSE);
NL;
Print('^1Batch download queue:'+
' ^5'+IntToStr(NumBatchDLFiles)+' '+Plural('file',NumBatchDLFiles)+
', '+ConvertBytes(BatchDLSize,FALSE)+
', '+FormatNumber(BatchDLPoints)+' '+Plural('file point',BatchDLPoints)+
', '+FormattedTime(BatchDLTime)+'^1');
IF (IsFileAttach IN BatchDL.BDLFlags) THEN
MemFileArea.AreaName := 'File Attach'
ELSE IF (IsUnlisted IN BatchDL.BDLFlags) THEN
MemFileArea.AreaName := 'Unlisted Download'
ELSE IF (IsTempArc IN BatchDL.BDLFlags) THEN
MemFileArea.AreaName := 'Temporary Archive'
ELSE IF (IsQWK IN BatchDL.BDLFlags) THEN
MemFileArea.AreaName := 'QWK Download';
SysOpLog('Batch DL Add: "^5'+StripName(BatchDL.BDLFileName)+
'^1" from ^5'+MemFileArea.AreaName);
END;
END;
PROCEDURE Send(FileInfo: FileInfoRecordType;
DirFileRecNum: Integer;
DownloadPath: PathStr;
VAR TransferFlags: TransferFlagSet);
TYPE
TotalsRecordType = RECORD
FilesDL,
FilesDLRatio: Byte;
BytesDL,
BytesDLRatio,
PointsDL,
PointsDLRatio: LongInt;
END;
VAR
Totals: TotalsRecordType;
ReturnCode,
ProtocolNumber: Integer;
TransferTime: LongInt;
BEGIN
Exclude(TransferFlags,IsKeyboardAbort);
Exclude(TransferFlags,IsTransferOk);
IF (lIsAddDLBatch IN TransferFlags) THEN
ProtocolNumber := -4
ELSE
ProtocolNumber := DoProtocol(Protocol,FALSE,TRUE,FALSE,FALSE);
IF (IsCheckRatio IN TransferFlags) THEN
IF (-ProtocolNumber IN [1,4]) OR (NOT (-ProtocolNumber IN [2..3,5])) THEN
CheckFileRatio(FileInfo,ProtocolNumber);
CASE ProtocolNumber OF
-2 : BEGIN
NL;
Print('^1Aborted!');
Include(TransferFlags,IsKeyboardAbort);
END;
-3 : BEGIN
NL;
Print('^1Skipped!');
END;
-4 : BatchDLAdd(FileInfo,DownloadPath,TransferFlags);
-5 : ;
ELSE
IF (InCom) OR (ProtocolNumber = -1) THEN
BEGIN
IF (ProtocolNumber = -1) THEN
BEGIN
NL;
Print('^5Caution: ^1No check is made to ensure the file you selected for viewing^1');
Print('^1 is an ascii text file!');
NL;
IF (NOT PYNQ('Continue to view selected file? ',0,FALSE)) THEN
BEGIN
Include(TransferFlags,IsKeyboardAbort);
Exit;
END;
END;
IF (IsCDRom IN TransferFlags) THEN
BEGIN
NL;
Print('Please wait, copying file from CD-ROM ... ');
IF CopyMoveFile(TRUE,'',DownloadPath+SQOutSp(FileInfo.FileName),TempDir+'CD\'+SQOutSp(FileInfo.FileName),FALSE) THEN
DownloadPath := TempDir+'CD\';
END;
NL;
IF PYNQ('Auto-logoff after '+AOnOff(ProtocolNumber = -1,'viewing file','file transfer')+'? ',0,FALSE) THEN
Include(TransferFlags,IsAutoLogOff);
NL;
Star('Ready to '+AOnOff(ProtocolNumber = -1,'view','send')+': ^5'+SQOutSp(FileInfo.FileName)+'.');
ExecProtocol(AOnOff(ProtocolNumber = -1,DownloadPath+SQOutSp(FileInfo.FileName),''),
TempDir+'UP\',
FunctionalMCI(Protocol.EnvCmd,'','')+
#13#10
+General.ProtPath+FunctionalMCI(Protocol.DLCmd,DownloadPath+SQOutSp(FileInfo.FileName),''),
0,
ReturnCode,
TransferTime);
NL;
Star('File '+AOnOff(ProtocolNumber = -1,'viewing','download')+' complete.');
IF (ProtocolNumber = -1) THEN
BEGIN
IF (ReturnCode = 0) THEN
Include(TransferFlags,IsTransferOk);
END
ELSE
BEGIN
IF FindReturnCode(Protocol.DLCode,Protocol.PRFlags,IntToStr(ReturnCode)) THEN
Include(TransferFlags,IsTransferOk);
END;
IF (NOT (IsTransferOk IN TransferFlags)) THEN
BEGIN
NL;
Star(AOnOff(ProtocolNumber = -1,'Text view','Download')+' unsuccessful.');
SysOpLog('^7'+AOnOff(ProtocolNumber = -1,'Text view','Download')+' failed: "^5'+SQOutSp(FileInfo.FileName)+
'^7" from ^5'+MemFileArea.AreaName);
Include(TransferFlags,isPaused);
END
ELSE
BEGIN
LIL := 0;
SysOpLog('^3'+AOnOff(ProtocolNumber = -1,'Viewed','Downloaded')+' "^5'+SQOutSp(FileInfo.FileName)+
'^3" from ^5'+MemFileArea.AreaName+'.');
FillChar(Totals,SizeOf(Totals),0);
Inc(Totals.FilesDL);
Inc(Totals.BytesDL,FileInfo.FileSize);
Inc(Totals.PointsDL,FileInfo.FilePoints);
IF (ChargeFileRatio(FileArea)) THEN
BEGIN
Inc(Totals.FilesDLRatio);
Inc(Totals.BytesDLRatio,FileInfo.FileSize);
END;
IF (ChargeFilePoints(FileArea)) THEN
Inc(Totals.PointsDLRatio,FileInfo.FilePoints);
IF ((ThisUser.Downloads + Totals.FilesDLRatio) < 2147483647) THEN
Inc(ThisUser.Downloads,Totals.FilesDLRatio)
ELSE
ThisUser.Downloads := 2147483647;
IF ((ThisUser.DLToday + Totals.FilesDLRatio) < 2147483647) THEN
Inc(ThisUser.DLToday,Totals.FilesDLRatio)
ELSE
ThisUser.DLToday := 2147483647;
IF ((ThisUser.DK + (Totals.BytesDLRatio DIV 1024)) < 2147483647) THEN
Inc(ThisUser.DK,(Totals.BytesDLRatio DIV 1024))
ELSE
ThisUser.DK := 2147483647;
IF ((ThisUser.DLKToday + (Totals.BytesDLRatio DIV 1024)) < 2147483647) THEN
Inc(ThisUser.DLKToday,(Totals.BytesDLRatio DIV 1024))
ELSE
ThisUser.DLKToday := 2147483647;
IF ((ThisUser.FilePoints - Totals.PointsDLRatio) > 0) THEN
Dec(ThisUser.FilePoints,Totals.PointsDLRatio)
ELSE
ThisUser.FilePoints := 0;
IF ((DownloadsToday + Totals.FilesDL) < 2147483647) THEN
Inc(DownloadsToday,Totals.FilesDL)
ELSE
DownloadsToday := 2147483647;
IF ((DownloadKBytesToday + (Totals.BytesDL DIV 1024)) < 2147483647) THEN
Inc(DownloadKBytesToday,(Totals.BytesDL DIV 1024))
ELSE
DownloadKBytesToday := 2147483647;
SaveURec(ThisUser,UserNum);
LIL := 0;
NL;
Print('^5Download statistics (Totals):^1');
NL;
Star('File name : ^5'+SQOutSp(FileInfo.FileName));
Star('File size : ^5'+ConvertBytes(Totals.BytesDL,FALSE));
Star('File point(s) : ^5'+FormatNumber(Totals.PointsDL));
Star(AOnOff(ProtocolNumber = -1,'View time ','Download time ')+': ^5'+FormattedTime(TransferTime));
Star('Transfer rate : ^5'+FormatNumber(GetCPS(FileInfo.FileSize,Transfertime))+' cps');
SysOpLog('^3 - Totals:'+
' '+FormatNumber(Totals.FilesDL)+' '+Plural('file',Totals.FilesDL)+
', '+ConvertBytes(Totals.BytesDL,FALSE)+
', '+FormatNumber(Totals.PointsDL)+' fp'+
', '+FormattedTime(TransferTime)+
', '+FormatNumber(GetCPS(Totals.BytesDL,Transfertime))+' cps.');
LIL := 0;
NL;
Print('^5Download statistics (Charges):^1');
NL;
Star('File(s) : ^5'+FormatNumber(Totals.FilesDLRatio));
Star('File size : ^5'+ConvertBytes(Totals.BytesDLRatio,FALSE));
Star('File point(s) : ^5'+FormatNumber(Totals.PointsDLRatio));
SysOpLog('^3 - Charges:'+
' '+FormatNumber(Totals.FilesDLRatio)+' '+Plural('file',Totals.FilesDLRatio)+
', '+ConvertBytes(Totals.BytesDLRatio,FALSE)+
', '+FormatNumber(Totals.PointsDLRatio)+' fp.');
CreditUploader(FileInfo);
IF (DirFileRecNum <> -1) THEN
BEGIN
Inc(FileInfo.Downloaded);
Seek(FileInfoFile,DirFileRecNum);
Write(FileInfoFile,FileInfo);
LastError := IOResult;
END;
LIL := 0;
NL;
Print('^5Enjoy the file, '+Caps(ThisUser.Name)+'!^1');
PauseScr(FALSE);
END;
IF (ProtBiDirectional IN Protocol.PRFlags) AND (NOT OfflineMail) THEN
BatchUpload(TRUE,0);
IF (IsAutoLogoff IN TransferFlags) THEN
CountDown
END;
END;
END;
PROCEDURE Receive(FileName: Str12;
UploadPath: PathStr;
ResumeFile: Boolean;
VAR UploadOk,
KeyboardAbort,
AddULBatch: Boolean;
VAR TransferTime: LongInt);
VAR
ReturnCode,
ProtocolNumber: Integer;
BEGIN
UploadOk := TRUE;
KeyboardAbort := FALSE;
TransferTime := 0;
ProtocolNumber := DoProtocol(Protocol,TRUE,FALSE,FALSE,ResumeFile);
CASE ProtocolNumber OF
-1 : UploadOk := FALSE;
-2 : BEGIN
UploadOk := FALSE;
KeyboardAbort := TRUE;
END;
-3 : BEGIN
UploadOk := FALSE;
KeyboardAbort := TRUE;
END;
-4 : AddULBatch := TRUE;
-5 : UploadOk := FALSE;
ELSE
IF (NOT InCom) THEN
UploadOk := FALSE
ELSE
BEGIN
PurgeDir(TempDir+'UP\',FALSE);
NL;
Star('Ready to receive: ^5'+SQOutSp(FileName)+'.');
TimeLock := TRUE;
ExecProtocol('',
UploadPath,
FunctionalMCI(Protocol.EnvCmd,'','')+
#13#10+
General.ProtPath+FunctionalMCI(Protocol.ULCmd,SQOutSp(FileName),''),
0,
ReturnCode,
TransferTime);
TimeLock := FALSE;
NL;
Star('File upload complete.');
UploadOk := FindReturnCode(Protocol.ULCode,Protocol.PRFlags,IntToStr(ReturnCode));
END;
END;
END;
END.

420
SOURCE/FILE9.PAS Normal file
View File

@ -0,0 +1,420 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S+,V-}
UNIT File9;
INTERFACE
USES
Common;
PROCEDURE DosDir(CurDir: ASTR; CONST FSpec: Str12; Expanded: Boolean);
PROCEDURE DirF(Expanded: Boolean);
PROCEDURE DeleteFF(F: FileInfoRecordType; RN: Integer);
PROCEDURE ToggleFileAreaScanFlags;
PROCEDURE SetFileAreaNewScanDate;
IMPLEMENTATION
USES
Dos,
Common5,
File0,
File1,
TimeFunc;
PROCEDURE DosDir(CurDir: ASTR; CONST FSpec: Str12; Expanded: Boolean);
VAR
(*
DirInfo: SearchRec;
*)
DT: DateTime;
TempStr: ASTR;
AmPm: Str2;
Online: Byte;
NumFiles,
NumDirs,
BytesUsed: LongInt;
BEGIN
CurDir := BSlash(CurDir,TRUE);
Abort := FALSE;
Next := FALSE;
FindFirst(CurDir[1]+':\*.*',VolumeID,DirInfo);
IF (DOSError <> 0) THEN
TempStr := 'has no label.'
ELSE
TempStr := 'is '+DirInfo.Name;
PrintACR(' Volume in drive '+UpCase(CurDir[1])+' '+TempStr);
(* Add Serial Number if possible *)
NL;
PrintACR(' Directory of '+CurDir);
NL;
TempStr := '';
Online := 0;
NumFiles := 0;
NumDirs := 0;
BytesUsed := 0;
CurDir := CurDir + FSpec;
FindFirst(CurDir,AnyFile,DirInfo);
WHILE (DOSError = 0) AND (NOT Abort) AND (NOT HangUp) DO
BEGIN
IF (NOT (DirInfo.Attr AND Directory = Directory)) OR (FileSysOp) THEN
IF (NOT (DirInfo.Attr AND VolumeID = VolumeID)) THEN
IF ((NOT (DirInfo.Attr AND DOS.Hidden = DOS.Hidden)) OR (UserNum = 1)) THEN
IF ((DirInfo.Attr AND DOS.Hidden = DOS.Hidden) AND
(NOT (DirInfo.Attr AND Directory = Directory))) OR
(NOT (DirInfo.Attr AND DOS.Hidden = DOS.Hidden)) THEN
BEGIN
IF (Expanded) THEN
BEGIN
UnPackTime(DirInfo.Time,DT);
ConvertAmPm(DT.Hour,AmPm);
TempStr := ZeroPad(IntToStr(DT.Month))+
'/'+ZeroPad(IntToStr(DT.Day))+
'/'+IntToStr(DT.Year)+
' '+ZeroPad(IntToStr(DT.Hour))+
':'+ZeroPad(IntToStr(DT.Min))+
AmPm[1];
END;
IF ((DirInfo.Attr AND Directory) = Directory) THEN
BEGIN
TempStr := TempStr+PadRightStr('<DIR>',11);
TempStr := TempStr+PadRightStr('',14);
TempStr := TempStr+' '+DirInfo.Name;
Inc(NumDirs);
END
ELSE
BEGIN
TempStr := TempStr+' '+PadRightStr(FormatNumber(DirInfo.Size),23);
TempStr := TempStr+' '+DirInfo.Name;
Inc(NumFiles);
Inc(BytesUsed,DirInfo.Size);
END;
PrintACR(TempStr)
END
ELSE
BEGIN
Inc(Online);
IF ((DirInfo.Attr AND Directory) = Directory) THEN
BEGIN
TempStr := TempStr+PadLeftStr('['+DirInfo.Name+']',15);
Inc(NumDirs);
END
ELSE
BEGIN
TempStr := TempStr+PadLeftStr(DirInfo.Name,15);
Inc(NumFiles);
Inc(BytesUsed,DirInfo.Size);
END;
IF (Online = 5) THEN
BEGIN
PrintACR(TempStr);
TempStr := '';
Online := 0;
END;
END;
FindNext(DirInfo);
END;
IF (DOSError <> 0) AND (Online IN [1..5]) THEN
PrintACR(TempStr);
IF (NumFiles = 0) THEN
PrintACR('File Not Found')
ELSE
BEGIN
PrintACR(PadRightStr(FormatNumber(NumFiles),16)+' File(s)'+
PadRightStr(FormatNumber(BytesUsed),15)+' bytes');
PrintACR(PadRightStr(FormatNumber(NumDirs),16)+' Dir(s)'+
PadRightStr(FormatNumber(DiskFree(ExtractDriveNumber(CurDir))),16)+' bytes free');
END;
END;
PROCEDURE DirF(Expanded: Boolean);
VAR
FSpec: Str12;
BEGIN
NL;
Print('Raw directory.');
{ Print(FString.lGFNLine1); }
lRGLngStr(28,FALSE);
{ Prt(FString.GFNLine2); }
lRGLngStr(29,FALSE);
GetFileName(FSpec);
NL;
LoadFileArea(FileArea);
DosDir(MemFileArea.DLPath,FSpec,Expanded);
END;
PROCEDURE DeleteFF(F: FileInfoRecordType; RN: Integer);
VAR
ExtFile1: FILE;
S,
FN: STRING;
TotLoad,
DirFileRecNum: Integer;
TempVPointer: LongInt;
BEGIN
IF (RN <= FileSize(FileInfoFile)) AND (RN > -1) THEN
BEGIN
Seek(FileInfoFile,RN);
Read(FileInfoFile,F);
F.VPointer := -1;
F.VTextSize := 0;
Seek(FileInfoFile,RN);
Write(FileInfoFile,F);
Reset(ExtInfoFile,1);
IF (FADirDLPath IN MemFileArea.FAFlags) THEN
FN := MemFileArea.DLPath+MemFileArea.FileName
ELSE
FN := General.Datapath+MemFileArea.FileName;
Assign(ExtFile1,FN+'.EX1');
ReWrite(ExtFile1,1);
FOR DirFileRecNum := 0 TO (FileSize(FileInfoFile) - 1) DO
BEGIN
Seek(FileInfoFile,DirFileRecNum);
Read(FileInfoFile,F);
IF (F.VPointer <> -1) THEN
BEGIN
TempVPointer := (FileSize(ExtFile1) + 1);
Seek(ExtFile1,FileSize(ExtFile1));
TotLoad := 0;
Seek(ExtInfoFile,(F.VPointer - 1));
REPEAT
BlockRead(ExtInfoFile,S[0],1);
BlockRead(ExtInfoFile,S[1],Ord(S[0]));
Inc(TotLoad,(Length(S) + 1));
BlockWrite(ExtFile1,S,(Length(S) + 1));
UNTIL (TotLoad >= F.VTextSize);
F.VPointer := TempVPointer;
Seek(FileInfoFile,DirFileRecNum);
Write(FileInfoFile,F);
END;
END;
Close(ExtInfoFile);
Erase(ExtInfoFile);
Close(ExtFile1);
ReName(ExtFile1,FN+'.EXT');
IF (RN <> (FileSize(FileInfoFile) - 1)) THEN
FOR DirFileRecNum := RN TO (FileSize(FileInfoFile) - 2) DO
BEGIN
Seek(FileInfoFile,(DirFileRecNum + 1));
Read(FileInfoFile,F);
Seek(FileInfoFile,DirFileRecNum);
Write(FileInfoFile,F);
END;
Seek(FileInfoFile,(FileSize(FileInfoFile) - 1));
Truncate(FileInfoFile);
END;
LastError := IOResult;
END;
(* 1. Verify if CDROM's can have new files in them *)
PROCEDURE ToggleFileAreaScanFlags;
VAR
InputStr: Str11;
FirstFArea,
LastFArea,
FArea,
NumFAreas,
SaveFArea,
SaveFileArea: Integer;
SaveConfSystem,
SaveTempPause: Boolean;
PROCEDURE ToggleScanFlags(FArea1: Integer; ScanType: Byte);
BEGIN
IF (FileArea <> FArea1) THEN
ChangeFileArea(FArea1);
IF (FileArea = FArea1) THEN
BEGIN
LoadNewScanFile(NewScanFileArea);
IF (ScanType = 1) THEN
NewScanFileArea := TRUE
ELSE IF (ScanType = 2) THEN
NewScanFileArea := FALSE
ELSE IF (ScanType = 3) THEN
NewScanFileArea := (NOT NewScanFileArea);
SaveNewScanFile(NewScanFileArea);
END;
END;
BEGIN
SaveFileArea := FileArea;
SaveConfSystem := ConfSystem;
ConfSystem := FALSE;
IF (SaveConfSystem) THEN
NewCompTables;
SaveTempPause := TempPause;
TempPause := FALSE;
FArea := 1;
NumFAreas := 0;
LightBarCmd := 1;
LightBarFirstCmd := TRUE;
InputStr := '?';
REPEAT
SaveFArea := FArea;
IF (InputStr = '?') THEN
LFileAreaList(FArea,NumFAreas,5,TRUE);
{
%LFToggle new scan? [^5#^4,^5#^4-^5#^4,^5F^4=^5Flag ^4or ^5U^4=^5Unflag All^4,^5?^4=^5Help^4,^5Q^4=^5Quit^4]: @
}
FileAreaScanInput(LRGLngStr(74,TRUE),((Length(IntToStr(HighFileArea)) * 2) + 1),InputStr,'QFU[]?',LowFileArea,
HighFileArea);
IF (InputStr <> 'Q') THEN
BEGIN
IF (InputStr = '[') THEN
BEGIN
FArea := (SaveFArea - ((PageLength - 5) * 2));
IF (FArea < 1) THEN
FArea := 1;
InputStr := '?';
END
ELSE IF (InputStr = ']') THEN
BEGIN
IF (FArea > NumFileAreas) THEN
FArea := SaveFArea;
InputStr := '?';
END
ELSE IF (InputStr = '?') THEN
BEGIN
{
$File_Message_Area_List_Help
%LF^1(^3###^1)Manual entry selection ^1(^3<CR>^1)Select current entry
^1(^3<Home>^1)First entry on page ^1(^3<End>^1)Last entry on page
^1(^3Left Arrow^1)Previous entry ^1(^3Right Arrow^1)Next entry
^1(^3Up Arrow^1)Move up ^1(^3Down Arrow^1)Move down
^1(^3[^1)Previous page ^1(^3]^1)Next page
%PA
}
LRGLngStr(71,FALSE);
FArea := SaveFArea;
END
ELSE
BEGIN
FileArea := 0;
IF (InputStr = 'F') THEN
BEGIN
FOR FArea := 1 TO NumFileAreas DO
ToggleScanFlags(FArea,1);
{
%LFYou are now scanning all file areas.
}
LRGLngStr(86,FALSE);
Farea := 1;
InputStr := '?';
END
ELSE IF (InputStr = 'U') THEN
BEGIN
FOR FArea := 1 TO NumFileAreas DO
ToggleScanFlags(FArea,2);
{
%LFYou are now not scanning any file areas.
}
LRGLngStr(88,FALSE);
Farea := 1;
InputStr := '?';
END
ELSE
BEGIN
FirstFArea := StrToInt(InputStr);
IF (Pos('-',InputStr) = 0) THEN
LastFArea := FirstFArea
ELSE
BEGIN
LastFArea := StrToInt(Copy(InputStr,(Pos('-',InputStr) + 1),(Length(InputStr) - Pos('-',InputStr))));
IF (FirstFArea > LastFArea) THEN
BEGIN
FArea := FirstFArea;
FirstFArea := LastFArea;
LastFArea := FArea;
END;
END;
IF (FirstFArea < LowFileArea) OR (LastFArea > HighFileArea) THEN
BEGIN
{
%LF^7The range must be from %A1 to %A2!^1
}
LRGLngStr(90,FALSE);
Farea := SavefArea;
InputStr := '?';
END
ELSE
BEGIN
FirstFArea := CompFileArea(FirstFArea,1);
LastFArea := CompFileArea(LastFArea,1);
FOR FArea := FirstFArea TO LastFArea DO
ToggleScanFlags(FArea,3);
IF (FirstFArea = LastFArea) THEN
BEGIN
{
%LF^5%FB^3 will %FSbe scanned.
}
LRGLngStr(92,FALSE);
END;
Farea := SaveFArea;
InputStr := '?';
END;
END;
FileArea := SaveFileArea;
END;
END;
UNTIL (InputStr = 'Q') OR (HangUp);
ConfSystem := SaveConfSystem;
IF (SaveConfSystem) THEN
NewCompTables;
TempPause := SaveTempPause;
FileArea := SaveFileArea;
LoadFileArea(FileArea);
LastCommandOvr := TRUE;
END;
(* Done - Lee Palmer 06/18/06 *)
PROCEDURE SetFileAreaNewScanDate;
VAR
TempDate: Str10;
Key: CHAR;
BEGIN
{
NL;
Prt(FString.FileNewScan);
}
lRGLngStr(54,FALSE);
MPL(10);
Prompt(PD2Date(NewFileDate));
Key := Char(GetKey);
IF (Key = #13) THEN
BEGIN
NL;
TempDate := PD2Date(NewFileDate);
END
ELSE
BEGIN
Buf := Key;
DOBackSpace(1,10);
InputFormatted('',TempDate,'##/##/####',TRUE);
IF (TempDate = '') THEN
TempDate := PD2Date(NewFileDate);
END;
IF (DayNum(TempDate) = 0) OR (DayNum(TempDate) > DayNum(DateStr)) THEN
BEGIN
NL;
Print('^7Invalid date entered!^1');
END
ELSE
BEGIN
NL;
Print('New file scan date set to: ^5'+TempDate+'^1');
NewFileDate := Date2PD(TempDate);
SL1('Reset file new scan date to: ^5'+TempDate+'.');
END;
END;
END.

454
SOURCE/LINECHAT.PAS Normal file
View File

@ -0,0 +1,454 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S+,V-}
UNIT LineChat;
INTERFACE
USES
Common;
PROCEDURE RequestSysOpChat(CONST MenuOption: Str50);
PROCEDURE ChatFileLog(b: Boolean);
PROCEDURE SysOpLineChat;
IMPLEMENTATION
USES
Crt,
Dos,
Email,
Events,
TimeFunc;
PROCEDURE RequestSysOpChat(CONST MenuOption: Str50);
VAR
User: UserRecordType;
MHeader: MHeaderRec;
Reason: AStr;
Cmd: Char;
Counter: Byte;
UNum,
Counter1: Integer;
Chatted: Boolean;
BEGIN
IF (ChatAttempts < General.MaxChat) OR (CoSysOp) THEN
BEGIN
NL;
IF (Pos(';',MenuOption) <> 0) THEN
Print(Copy(MenuOption,(Pos(';',MenuOption) + 1),Length(MenuOption)))
ELSE
lRGLngStr(37,FALSE); { FString.ChatReason; }
Chatted := FALSE;
Prt(': ');
MPL(60);
InputL(Reason,60);
IF (Reason <> '') THEN
BEGIN
Inc(ChatAttempts);
SysOpLog('^4Chat attempt:');
SL1(Reason);
IF (NOT SysOpAvailable) AND AACS(General.OverRideChat) THEN
PrintF('CHATOVR');
IF (SysOpAvailable) OR (AACS(General.OverRideChat) AND PYNQ(^M^J'SysOp is not available. Override? ',0,FALSE)) THEN
BEGIN
lStatus_Screen(100,'Press [SPACE] to chat or [ENTER] for silence.',FALSE,Reason);
{ Print(FString.ChatCall1); }
lRGLngStr(14,FALSE);
Counter := 0;
Abort := FALSE;
NL;
REPEAT
Inc(Counter);
WKey;
IF (OutCom) THEN
Com_Send(^G);
{ Prompt(FString.ChatCall2); }
lRGLngStr(15,FALSE);
IF (OutCom) THEN
Com_Send(^G);
IF (ShutUpChatCall) THEN
Delay(600)
ELSE
BEGIN
{$IFDEF MSDOS}
FOR Counter1 := 300 DOWNTO 2 DO
BEGIN
Delay(1);
Sound(Counter1 * 10);
END;
FOR Counter1 := 2 TO 300 DO
BEGIN
Delay(1);
Sound(Counter1 * 10);
END;
NoSound;
{$ENDIF}
{$IFDEF WIN32}
Sound(3000, 200);
Sound(1000, 200);
Sound(3000, 200);
{$ENDIF}
END;
IF (KeyPressed) THEN
BEGIN
Cmd := ReadKey;
CASE Cmd OF
#0 : BEGIN
Cmd := ReadKey;
SKey1(Cmd);
END;
#32 : BEGIN
Chatted := TRUE;
ChatAttempts := 0;
SysOpLineChat;
END;
^M : ShutUpChatCall := TRUE;
END;
END;
UNTIL (Counter = 9) OR (Chatted) OR (Abort) OR (HangUp);
NL;
END;
lStatus_Screen(100,'Chat Request: '+Reason,FALSE,Reason);
IF (Chatted) THEN
ChatReason := ''
ELSE
BEGIN
ChatReason := Reason;
PrintF('NOSYSOP');
UNum := StrToInt(MenuOption);
IF (UNum > 0) THEN
BEGIN
InResponseTo := #1'Tried chatting';
LoadURec(User,UNum);
NL;
IF PYNQ('Send mail to '+Caps(User.Name)+'? ',0,FALSE) THEN
BEGIN
MHeader.Status := [];
SEmail(UNum,MHeader);
END;
END;
END;
TLeft;
END;
END
ELSE
BEGIN
PrintF('GOAWAY');
UNum := StrToInt(MenuOption);
IF (UNum > 0) THEN
BEGIN
InResponseTo := 'Tried chatting (more than '+IntToStr(General.MaxChat)+' times!)';
SysOpLog(InResponseTo);
MHeader.Status := [];
SEmail(UNum,MHeader);
END;
END;
END;
PROCEDURE ChatFileLog(b: Boolean);
VAR
s: AStr;
BEGIN
s := 'Chat';
IF (ChatSeparate IN ThisUser.SFlags) THEN
s := s + IntToStr(UserNum);
s := General.LogsPath+s+'.LOG';
IF (NOT b) THEN
BEGIN
IF (CFO) THEN
BEGIN
lStatus_Screen(100,'Chat recorded to '+s,FALSE,s);
CFO := FALSE;
IF (TextRec(ChatFile).Mode <> FMClosed) THEN
Close(ChatFile);
END;
END
ELSE
BEGIN
CFO := TRUE;
IF (TextRec(ChatFile).Mode = FMOutPut) THEN
Close(ChatFile);
Assign(ChatFile,s);
Append(ChatFile);
IF (IOResult = 2) THEN
ReWrite(ChatFile);
IF (IOResult <> 0) THEN
SysOpLog('Cannot open chat log file: '+s);
lStatus_Screen(100,'Recording chat to '+s,FALSE,s);
WriteLn(ChatFile);
WriteLn(ChatFile);
WriteLn(ChatFile,Dat);
WriteLn(ChatFile);
Writeln(ChatFile,'Recorded with user: '+Caps(ThisUser.Name));
WriteLn(ChatFile);
WriteLn(ChatFile,'Chat reason: '+AOnOff(ChatReason = '','None',ChatReason));
WriteLn(ChatFile);
WriteLn(ChatFile);
WriteLn(ChatFile,'------------------------------------');
WriteLn(ChatFile);
END;
END;
PROCEDURE InLi1(VAR S: STRING);
VAR
C,
C1: Char;
Counter,
Counter1,
CPos: Byte;
BEGIN
CPos := 1;
S := '';
IF (LastLineStr <> '') THEN
BEGIN
Prompt(LastLineStr);
S := LastLineStr;
LastLineStr := '';
CPos := (Length(S) + 1);
END;
REPEAT
C := Char(GetKey);
CheckHangUp;
CASE Ord(C) OF
32..255 :
IF (CPos < 79) THEN
BEGIN
S[CPos] := C;
Inc(CPos);
OutKey(C);
IF (Trapping) THEN
Write(TrapFile,C);
END;
16 : IF (OkANSI OR OkAvatar) THEN
BEGIN
C1 := Char(GetKey);
UserColor(Ord(C1) - 48);
END;
27 : IF (CPos < 79) THEN
BEGIN
S[CPos] := C;
Inc(CPos);
OutKey(C);
IF (Trapping) THEN
Write(TrapFile,C);
END;
8 : IF (CPos > 1) THEN
BEGIN
Dec(CPos);
BackSpace;
END;
24 : BEGIN
FOR Counter := 1 TO (CPos - 1) DO
BackSpace;
CPos := 1;
END;
7 : IF (OutCom) THEN
Com_Send(^G);
23 : IF (CPos > 1) THEN
REPEAT
Dec(CPos);
BackSpace;
UNTIL (CPos = 1) OR (S[CPos] = ' ');
9 : BEGIN
Counter := (5 - (CPos MOD 5));
IF ((CPos + Counter) < 79) THEN
FOR Counter1 := 1 TO Counter DO
BEGIN
S[CPos] := ' ';
Inc(CPos);
Prompt(' ');
END;
END;
END;
UNTIL ((C = ^M) OR (CPos = 79) OR (HangUp) OR (NOT InChat));
IF (NOT InChat) THEN
BEGIN
C := #13;
InChat := FALSE;
END;
S[0] := Chr(CPos - 1);
IF (C <> ^M) THEN
BEGIN
Counter := (CPos - 1);
WHILE (Counter > 0) AND (S[Counter] <> ' ') AND (S[Counter] <> ^H) DO
Dec(Counter);
IF (Counter > (CPos DIV 2)) AND (Counter <> (CPos - 1)) THEN
BEGIN
LastLineStr := Copy(S,(Counter + 1),(CPos - Counter));
FOR Counter1 := (CPos - 2) DOWNTO Counter DO
Prompt(^H);
FOR Counter1 := (CPos - 2) DOWNTO Counter DO
Prompt(' ');
S[0] := Chr(Counter - 1);
END;
END;
NL;
END;
PROCEDURE SysOpLineChat;
VAR
S: AStr;
Counter: Integer;
ChatTime: LongInt;
SaveEcho,
SavePrintingFile,
SaveMCIAllowed: Boolean;
BEGIN
UserColor(1);
SaveMCIAllowed := MCIAllowed;
MCIAllowed := TRUE;
ChatTime := GetPackDateTime;
DOSANSIOn := FALSE;
IF (General.MultiNode) THEN
BEGIN
LoadNode(ThisNode);
SaveNAvail := (NAvail IN Noder.Status);
Exclude(Noder.Status,NAvail);
SaveNode(ThisNode);
END;
SavePrintingFile := PrintingFile;
InChat := TRUE;
ChatCall := FALSE;
SaveEcho := Echo;
Echo := TRUE;
IF (General.AutoChatOpen) THEN
ChatFileLog(TRUE)
ELSE IF (ChatAuto IN ThisUser.SFlags) THEN
ChatFileLog(TRUE);
NL;
Exclude(ThisUser.Flags,Alert);
PrintF('CHATINIT');
IF (NoFile) THEN
(*
Prompt('^5'+FString.EnGage);
*)
lRGLNGStr(2,FALSE);
UserColor(General.SysOpColor);
WColor := TRUE;
IF (ChatReason <> '') THEN
BEGIN
lStatus_Screen(100,ChatReason,FALSE,S);
ChatReason := '';
END;
REPEAT
InLi1(S);
IF (S[1] = '/') THEN
S := AllCaps(S);
IF (Copy(S,1,6) = '/TYPE ') AND (SysOp) THEN
BEGIN
S := Copy(S,7,(Length(S) - 6));
IF (S <> '') THEN
BEGIN
PrintFile(S);
IF (NoFile) THEN
Print('*File not found*');
END;
END
ELSE IF ((S = '/HELP') OR (S = '/?')) THEN
BEGIN
IF (SysOp) THEN
Print('^5/TYPE d:\path\filename.ext^3: Type a file');
(*
Print('^5/BYE^3: Hang up');
Print('^5/CLS^3: Clear the screen');
Print('^5/PAGE^3: Page the SysOp and User');
Print('^5/Q^3: Exit chat mode'^M^J);
*)
lRGLngStr(65,FALSE);
END
ELSE IF (S = '/CLS') THEN
CLS
ELSE IF (S = '/PAGE') THEN
BEGIN
{$IFDEF MSDOS}
FOR Counter := 650 TO 700 DO
BEGIN
Sound(Counter);
Delay(4);
NoSound;
END;
REPEAT
Dec(Counter);
Sound(Counter);
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
BEGIN
Print('Hanging up ...');
HangUp := TRUE;
END
ELSE IF (S = '/Q') THEN
BEGIN
InChat := FALSE;
Print('Chat Aborted ...');
END;
IF (CFO) THEN
WriteLn(ChatFile,S);
UNTIL ((NOT InChat) OR (HangUp));
PrintF('CHATEND');
IF (NoFile) THEN
(*
Print('^5'+FString.lEndChat);
*)
lRGLngStr(3,FALSE);
IF (General.MultiNode) THEN
BEGIN
LoadNode(ThisNode);
IF (SaveNAvail) THEN
Include(Noder.Status,NAvail);
SaveNode(ThisNode);
END;
ChatTime := (GetPackDateTime - ChatTime);
IF (ChopTime = 0) THEN
Inc(FreeTime,ChatTime);
TLeft;
S := 'Chatted for '+FormattedTime(ChatTime);
IF (CFO) THEN
BEGIN
S := S+' -{ Recorded in Chat';
IF (ChatSeparate IN ThisUser.SFlags) THEN
S := S + IntToStr(UserNum);
S := S+'.LOG }-';
END;
SysOpLog(S);
InChat := FALSE;
Echo := SaveEcho;
IF ((HangUp) AND (CFO)) THEN
BEGIN
WriteLn(ChatFile);
WriteLn(ChatFile,'=> User disconnected');
WriteLn(ChatFile);
END;
PrintingFile := SavePrintingFile;
IF (CFO) THEN
ChatFileLog(FALSE);
IF (InVisEdit) THEN
Buf := ^L;
MCIAllowed := SaveMCIAllowed;
END;
END.

1194
SOURCE/LOGON.PAS Normal file
View File

File diff suppressed because it is too large Load Diff

895
SOURCE/MAIL0.PAS Normal file
View File

@ -0,0 +1,895 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S+,V-}
UNIT Mail0;
INTERFACE
USES
Common;
FUNCTION CompMsgArea(MArea: Integer; ArrayNum: Byte): Integer;
FUNCTION UseName(AnonNum: Byte; NameToUse: Str36): Str36;
PROCEDURE UpdateBoard;
PROCEDURE ExtractMsgToFile(MsgNum: Word; MHeader: MheaderRec);
PROCEDURE DumpQuote(MHeader: MHeaderRec);
PROCEDURE LoadHeader(MsgNum: Word; VAR MHeader: MHeaderRec);
PROCEDURE SaveHeader(MsgNum: Word; MHeader: MHeaderRec);
FUNCTION MsgAreaAC(MArea: Integer): Boolean;
PROCEDURE ChangeMsgArea(MArea: Integer);
PROCEDURE LoadMsgArea(MArea: Integer);
PROCEDURE LoadLastReadRecord(VAR LastReadRec: ScanRec);
PROCEDURE SaveLastReadRecord(LastReadRec: ScanRec);
PROCEDURE InitMsgArea(MArea: Integer);
PROCEDURE ReadMsg(Anum,MNum,TNum: Word);
FUNCTION HeaderLine(MHeader: MHeaderRec; MNum,TNum: Word; Line: byte; VAR FileOwner: Str36): STRING;
FUNCTION ToYou(MessageHeader: MHeaderRec): Boolean;
FUNCTION FromYou(MessageHeader: MHeaderRec): Boolean;
FUNCTION GetTagLine: Str74;
IMPLEMENTATION
USES
Dos,
File0,
File1,
Shortmsg,
TimeFunc;
TYPE
MHeaderRecPtrType = ^MHeaderRec;
FUNCTION CompMsgArea(MArea: Integer; ArrayNum: Byte): Integer;
VAR
MsgCompArrayFile: FILE OF CompArrayType;
CompMsgArray: CompArrayType;
BEGIN
Assign(MsgCompArrayFile,TempDir+'MACT'+IntToStr(ThisNode)+'.DAT');
Reset(MsgCompArrayFile);
Seek(MsgCompArrayFile,(MArea - 1));
Read(MsgCompArrayFile,CompMsgArray);
Close(MsgCompArrayFile);
CompMsgArea := CompMsgArray[ArrayNum];
END;
FUNCTION UseName(AnonNum: Byte; NameToUse: Str36): Str36;
BEGIN
CASE AnonNum OF
1,2 :
NameToUse := lRGLNGStr(0,TRUE); {FString.Anonymous;}
3 : NameToUse := 'Abby';
4 : NameToUse := 'Problemed Person';
ELSE
NameToUse := Caps(NameToUse);
END;
UseName := NameToUse;
END;
FUNCTION FromYou(MessageHeader: MHeaderRec): Boolean;
BEGIN
FromYou := FALSE;
IF (MessageHeader.From.UserNum = UserNum) OR
(AllCaps(MessageHeader.From.A1S) = ThisUser.Name) OR
(AllCaps(MessageHeader.From.Name) = ThisUser.Name) OR
(AllCaps(MessageHeader.From.A1S) = AllCaps(ThisUser.RealName)) THEN
FromYou := TRUE;
END;
FUNCTION ToYou(MessageHeader: MHeaderRec): Boolean;
BEGIN
ToYou := FALSE;
IF (MessageHeader.MTO.UserNum = UserNum) OR
(AllCaps(MessageHeader.MTO.A1S) = ThisUser.Name) OR
(AllCaps(MessageHeader.MTO.Name) = ThisUser.Name) OR
(AllCaps(MessageHeader.MTO.A1S) = AllCaps(ThisUser.RealName)) THEN
ToYou := TRUE;
END;
PROCEDURE UpdateBoard;
VAR
FO: Boolean;
BEGIN
IF (ReadMsgArea < 1) OR (ReadMsgArea > NumMsgAreas) THEN
Exit;
FO := (FileRec(MsgAreaFile).Mode <> FMClosed);
IF (NOT FO) THEN
BEGIN
Reset(MsgAreaFile);
LastError := IOResult;
IF (LastError > 0) THEN
BEGIN
SysOpLog('MBASES.DAT/Open Error - '+IntToStr(LastError)+' (Procedure: UpDateBoard - '+IntToStr(ReadMsgArea)+')');
Exit;
END;
END;
Seek(MsgAreaFile,(ReadMsgArea - 1));
LastError := IOResult;
IF (LastError > 0) THEN
BEGIN
SysOpLog('MBASES.DAT/Seek Error - '+IntToStr(LastError)+' (Procedure: UpDateBoard - '+IntToStr(ReadMsgArea)+')');
Exit;
END;
Read(MsgAreaFile,MemMsgArea);
LastError := IOResult;
IF (LastError > 0) THEN
BEGIN
SysOpLog('MBASES.DAT/Read Error - '+IntToStr(LastError)+' (Procedure: UpDateBoard - '+IntToStr(ReadMsgArea)+')');
Exit;
END;
Include(MemMsgArea.MAFlags,MAScanOut);
Seek(MsgAreaFile,(ReadMsgArea - 1));
LastError := IOResult;
IF (LastError > 0) THEN
BEGIN
SysOpLog('MBASES.DAT/Seek Error - '+IntToStr(LastError)+' (Procedure: UpDateBoard - '+IntToStr(ReadMsgArea)+')');
Exit;
END;
Write(MsgAreaFile,MemMsgArea);
LastError := IOResult;
IF (LastError > 0) THEN
BEGIN
SysOpLog('MBASES.DAT/Write Error - '+IntToStr(LastError)+' (Procedure: UpDateBoard - '+IntToStr(ReadMsgArea)+')');
Exit;
END;
IF (NOT FO) THEN
BEGIN
Close(MsgAreaFile);
LastError := IOResult;
IF (LastError > 0) THEN
BEGIN
SysOpLog('MBASES.DAT/Close Error - '+IntToStr(LastError)+' (Procedure: UpDateBoard - '+IntToStr(ReadMsgArea)+')');
Exit;
END;
END;
END;
PROCEDURE LoadHeader(MsgNum: Word; VAR MHeader: MHeaderRec);
VAR
FO: Boolean;
BEGIN
FO := FileRec(MsgHdrF).Mode <> FMClosed;
IF (NOT FO) THEN
BEGIN
Reset(MsgHdrF);
IF (IOResult = 2) THEN
BEGIN
ReWrite(MsgHdrF);
LastError := IOResult;
IF (LastError > 0) THEN
BEGIN
SysOpLog(MemMsgArea.FileName+'/ReWrite Error - '+IntToStr(LastError)+' (Procedure: LoadHeader - '+IntToStr(MsgNum)+')');
Exit;
END;
END;
END;
Seek(MsgHdrF,(MsgNum - 1));
LastError := IOResult;
IF (LastError > 0) THEN
BEGIN
SysOpLog(MemMsgArea.FileName+'/Seek Error - '+IntToStr(LastError)+' (Procedure: LoadHeader - '+IntToStr(MsgNum)+')');
Exit;
END;
Read(MsgHdrF,MHeader);
LastError := IOResult;
IF (LastError > 0) THEN
BEGIN
SysOpLog(MemMsgArea.FileName+'/Read Error - '+IntToStr(LastError)+' (Procedure: LoadHeader - '+IntToStr(MsgNum)+')');
Exit;
END;
IF (NOT FO) THEN
BEGIN
Close(MsgHdrF);
LastError := IOResult;
IF (LastError > 0) THEN
BEGIN
SysOpLog(MemMsgArea.FileName+'/Close Error - '+IntToStr(LastError)+' (Procedure: LoadHeader - '+IntToStr(MsgNum)+')');
Exit;
END;
END;
LastError := IOResult;
END;
PROCEDURE SaveHeader(MsgNum: Word; MHeader: MHeaderRec);
VAR
FO: Boolean;
BEGIN
FO := FileRec(MsgHdrF).Mode <> FMClosed;
IF (NOT FO) THEN
BEGIN
Reset(MsgHdrF);
IF (IOResult = 2) THEN
BEGIN
ReWrite(MsgHdrF);
LastError := IOResult;
IF (LastError > 0) THEN
BEGIN
SysOpLog(MemMsgArea.FileName+'/ReWrite Error - '+IntToStr(LastError)+
'(Procedure: SaveHeader - '+IntToStr(MsgNum)+')');
Exit;
END;
END;
END;
Seek(MsgHdrF,(MsgNum - 1));
LastError := IOResult;
IF (LastError > 0) THEN
BEGIN
SysOpLog(MemMsgArea.FileName+'/Seek Error - '+IntToStr(LastError)+' (Procedure: SaveHeader - '+IntToStr(MsgNum)+')');
Exit;
END;
Write(MsgHdrF,MHeader);
LastError := IOResult;
IF (LastError > 0) THEN
BEGIN
SysOpLog(MemMsgArea.FileName+'/Write Error - '+IntToStr(LastError)+' (Procedure: SaveHeader - '+IntToStr(MsgNum)+')');
Exit;
END;
IF (NOT FO) THEN
BEGIN
Close(MsgHdrF);
LastError := IOResult;
IF (LastError > 0) THEN
BEGIN
SysOpLog(MemMsgArea.FileName+'/Close Error - '+IntToStr(LastError)+' (Procedure: SaveHeader - '+IntToStr(MsgNum)+')');
Exit;
END;
END;
LastError := IOResult;
END;
FUNCTION MsgAreaAC(MArea: Integer): Boolean;
BEGIN
MsgAreaAC := FALSE;
IF (MArea <> -1) THEN
IF (MArea < 1) OR (MArea > NumMsgAreas) THEN
Exit;
LoadMsgArea(MArea);
MsgAreaAC := AACS(MemMsgArea.ACS);
END;
PROCEDURE ChangeMsgArea(MArea: Integer);
VAR
TempPassword: Str20;
BEGIN
IF (MArea < 1) OR (MArea > NumMsgAreas) OR (NOT MsgAreaAC(MArea)) THEN
Exit;
IF (MemMsgArea.Password <> '') THEN
BEGIN
NL;
Print('Message area: ^5'+MemMsgArea.Name+' #'+IntToStr(CompMsgArea(MArea,0))+'^1');
NL;
Prt('Password: ');
GetPassword(TempPassword,20);
IF (TempPassword <> MemMsgArea.Password) THEN
BEGIN
NL;
Print('^7Incorrect password!^1');
Exit;
END;
END;
MsgArea := MArea;
ThisUser.LastMsgArea := MsgArea;
END;
PROCEDURE LoadMsgArea(MArea: Integer);
VAR
FO: Boolean;
BEGIN
IF (MArea = -1) THEN
BEGIN
Assign(EmailFile,General.DataPath+'MEMAIL.DAT');
Reset(EmailFile);
Read(EmailFile,MemMsgArea);
Close(EmailFile);
ReadMsgArea := -1;
WITH LastReadRecord DO
BEGIN
LastRead := 0;
NewScan := TRUE;
END;
END;
IF (MArea < 1) OR (MArea > NumMsgAreas) OR (ReadMsgArea = MArea) THEN
Exit;
FO := (FileRec(MsgAreaFile).Mode <> FMClosed);
IF (NOT FO) THEN
BEGIN
Reset(MsgAreaFile);
LastError := IOResult;
IF (LastError > 0) THEN
BEGIN
SysOpLog('MBASES.DAT/Open Error - '+IntToStr(LastError)+' (Procedure: LoadMsgArea - '+IntToStr(MArea)+')');
Exit;
END;
END;
Seek(MsgAreaFile,(MArea - 1));
LastError := IOResult;
IF (LastError > 0) THEN
BEGIN
SysOpLog('MBASES.DAT/Seek Error - '+IntToStr(LastError)+' (Procedure: LoadMsgArea - '+IntToStr(MArea)+')');
Exit;
END;
Read(MsgAreaFile,MemMsgArea);
LastError := IOResult;
IF (LastError > 0) THEN
BEGIN
SysOpLog('MBASES.DAT/Read Error - '+IntToStr(LastError)+' (Procedure: LoadMsgArea - '+IntToStr(MArea)+')');
Exit;
END
ELSE
ReadMsgArea := MArea;
IF (NOT FO) THEN
BEGIN
Close(MsgAreaFile);
LastError := IOResult;
IF (LastError > 0) THEN
BEGIN
SysOpLog('MBASES.DAT/Close Error - '+IntToStr(LastError)+' (Procedure: LoadMsgArea - '+IntToStr(MArea)+')');
Exit;
END;
END;
LastError := IOResult;
END;
PROCEDURE LoadLastReadRecord(VAR LastReadRec: ScanRec);
VAR
MsgAreaScanFile: FILE OF ScanRec;
Counter: Integer;
BEGIN
Assign(MsgAreaScanFile,General.MsgPath+MemMsgArea.FileName+'.SCN');
Reset(MsgAreaScanFile);
IF (IOResult = 2) THEN
ReWrite(MsgAreaScanFile);
IF (IOResult <> 0) THEN
BEGIN
SysOpLog('Error opening file: '+General.MsgPath+MemMsgArea.FileName+'.SCN');
Exit;
END;
IF (UserNum > FileSize(MsgAreaScanFile)) THEN
BEGIN
WITH LastReadRec DO
BEGIN
LastRead := 0;
NewScan := TRUE;
END;
Seek(MsgAreaScanFile,FileSize(MsgAreaScanFile));
FOR Counter := FileSize(MsgAreaScanFile) TO (UserNum - 1) DO
Write(MsgAreaScanFile,LastReadRec);
END
ELSE
BEGIN
Seek(MsgAreaScanFile,(UserNum - 1));
Read(MsgAreaScanFile,LastReadRec);
END;
Close(MsgAreaScanFile);
LastError := IOResult;
END;
PROCEDURE SaveLastReadRecord(LastReadRec: ScanRec);
VAR
MsgAreaScanFile: FILE OF ScanRec;
BEGIN
Assign(MsgAreaScanFile,General.MsgPath+MemMsgArea.FileName+'.SCN');
Reset(MsgAreaScanFile);
Seek(MsgAreaScanFile,(UserNum - 1));
Write(MsgAreaScanFile,LastReadRec);
Close(MsgAreaScanFile);
LastError := IOResult;
END;
PROCEDURE InitMsgArea(MArea: Integer);
BEGIN
LoadMsgArea(MArea);
Assign(MsgHdrF,General.MsgPath+MemMsgArea.FileName+'.HDR');
Reset(MsgHdrF);
IF (IOResult = 2) THEN
ReWrite(MsgHdrF);
Close(MsgHdrF);
Assign(MsgTxtF,General.MsgPath+MemMsgArea.FileName+'.DAT');
Reset(MsgTxtF,1);
IF (IOResult = 2) THEN
ReWrite(MsgTxtF,1);
Close(MsgTxtF);
IF (MArea = -1) THEN
Exit;
LoadLastReadRecord(LastReadRecord);
END;
PROCEDURE DumpQuote(MHeader: MHeaderRec);
VAR
QuoteFile: Text;
DT: DateTime;
S: STRING;
S1: STRING[80];
Counter: Byte;
TempTextSize: Word;
BEGIN
IF (MHeader.TextSize < 1) THEN
Exit;
Assign(QuoteFile,'TEMPQ'+IntToStr(ThisNode));
ReWrite(QuoteFile);
IF (IOResult <> 0) THEN
BEGIN
SysOpLog('^7Error creating file: ^5TEMPQ'+IntToStr(ThisNode)+'^1!');
Exit;
END;
S := AOnOff(MARealName IN MemMsgArea.MAFlags,MHeader.From.Real,MHeader.From.A1S);
FOR Counter := 1 TO 2 DO
BEGIN
IF (Counter = 1) THEN
S1 := MemMsgArea.QuoteStart
ELSE
S1 := MemMsgArea.QuoteEnd;
S1 := Substitute(S1,'@F',UseName(MHeader.From.Anon,S));
S1 := Substitute(S1,'@T',UseName(MHeader.MTO.Anon,
AOnOff(MARealName IN MemMsgArea.MAFlags,
Caps(MHeader.MTO.Real),
Caps(MHeader.MTO.A1S))));
IF (MHeader.Origindate <> '') THEN
S1 := Substitute(S1,'@D',MHeader.Origindate)
ELSE
BEGIN
Packtodate(DT,MHeader.Date);
S1 := Substitute(S1,'@D',IntToStr(DT.Day)+
' '+Copy(MonthString[DT.Month],1,3)+
' '+Copy(IntToStr(DT.Year),3,2)+
' '+Zeropad(IntToStr(DT.Hour))+
':'+Zeropad(IntToStr(DT.Min)));
END;
S1 := Substitute(S1,'@S',AOnOff(MHeader.FileAttached = 0,
Substitute(S1,'@S',MHeader.Subject),
Substitute(S1,'@S',StripName(MHeader.Subject))));
S1 := Substitute(S1,'@B',MemMsgArea.Name);
IF (S1 <> '') THEN
WriteLn(QuoteFile,S1);
END;
WriteLn(QuoteFile);
S1 := S[1];
IF (Pos(' ',S) > 0) AND (Length(S) > Pos(' ',S)) THEN
S1 := S1 + S[Pos(' ',S) + 1]
ELSE IF (Length(S1) > 1) THEN
S1 := S1 + S[2];
IF (MHeader.From.Anon <> 0) THEN
S1 := '';
S1 := Copy(S1,1,2);
Reset(MsgTxtF,1);
Seek(MsgTxtF,(MHeader.Pointer - 1));
TempTextSize := 0;
REPEAT
BlockRead(MsgTxtF,S[0],1);
BlockRead(MsgTxtF,S[1],Ord(S[0]));
LastError := IOResult;
Inc(TempTextSize,Length(S) + 1);
IF (Pos('> ',Copy(S,1,4)) > 0) THEN
S := Copy(StripColor(S),1,78)
ELSE
S := Copy(S1+'> '+StripColor(S),1,78);
WriteLn(QuoteFile,S);
UNTIL (TempTextSize >= MHeader.TextSize);
Close(QuoteFile);
Close(MsgTxtF);
LastError := IOResult;
END;
PROCEDURE ExtractMsgToFile(MsgNum: Word; MHeader: MHeaderRec);
VAR
ExtTxtFile: Text;
FileOwner: Str36;
FileName: Str52;
MsgTxtStr: STRING;
Counter: Byte;
TempTextSize: Word;
StripColors: Boolean;
BEGIN
NL;
Print('Extract message to file:');
Prt(': ');
InputDefault(FileName,'MSG'+IntToStr(ThisNode)+'.TXT',52,[UpperOnly,NoLineFeed],TRUE);
IF (FileName = '') THEN
BEGIN
NL;
Print('Aborted!');
Exit;
END;
NL;
IF PYNQ('Are you sure? ',0,FALSE) THEN
BEGIN
NL;
StripColors := PYNQ('Strip color codes from output? ',0,FALSE);
Assign(ExtTxtFile,FileName);
Append(ExtTxtFile);
IF (IOResult = 2) THEN
BEGIN
ReWrite(ExtTxtFile);
IF (IOResult <> 0) THEN
BEGIN
Print('^7Unable to create file: ^5'+FileName+'!^1');
Exit;
END;
END;
LoadHeader(MsgNum,MHeader);
FOR Counter := 1 TO 6 DO
BEGIN
MsgTxtStr := HeaderLine(MHeader,MsgNum,HiMsg,Counter,FileOwner);
IF (MsgTxtStr <> '') THEN
IF (StripColors) THEN
WriteLn(ExtTxtFile,StripColor(MsgTxtStr))
ELSE
WriteLn(ExtTxtFile,MsgTxtStr);
END;
WriteLn(ExtTxtFile);
Reset(MsgTxtF,1);
Seek(MsgTxtF,(MHeader.Pointer - 1));
TempTextSize := 0;
REPEAT
BlockRead(MsgTxtF,MsgTxtStr[0],1);
BlockRead(MsgTxtF,MsgTxtStr[1],Ord(MsgTxtStr[0]));
LastError := IOResult;
Inc(TempTextSize,(Length(MsgTxtStr) + 1));
IF (StripColors) THEN
MsgTxtStr := StripColor(MsgTxtStr);
IF (MsgTxtStr[Length(MsgTxtStr)] = #29) THEN
BEGIN
Dec(MsgTxtStr[0]);
Write(ExtTxtFile,MsgTxtStr);
END
ELSE
WriteLn(ExtTxtFile,MsgTxtStr);
UNTIL (TempTextSize >= MHeader.TextSize);
WriteLn(ExtTxtFile);
Close(ExtTxtFile);
Close(MsgTxtF);
NL;
Print('Message extracted.');
END;
LastError := IOResult;
END;
FUNCTION MHeaderRecMCI(CONST S: ASTR; Data1,Data2: Pointer): STRING;
VAR
MHeaderPtr: MHeaderRecPtrType;
S1: STRING;
BEGIN
MheaderPtr := Data1;
MHeaderRecMCI := S;
CASE S[1] OF
'C' : CASE S[2] OF
'A' : ;{TodaysCallerMCI := FormatNumber(LastCallerPtr^.Caller);}
END;
END;
END;
FUNCTION HeaderLine(MHeader: MHeaderRec; MNum,TNum: Word; Line: byte; VAR FileOwner: Str36): STRING;
VAR
S,
S1: STRING;
Pub,
SeeAnon: Boolean;
BEGIN
Pub := (ReadMsgArea <> -1);
IF (Pub) THEN
SeeAnon := (AACS(General.AnonPubRead) OR MsgSysOp)
ELSE
SeeAnon := AACS(General.AnonPrivRead);
IF (MHeader.From.Anon = 2) THEN
SeeAnon := CoSysOp;
S := '';
CASE Line OF
1 : BEGIN
IF (MHeader.FileAttached > 0) THEN
InResponseTo := StripName(MHeader.Subject)
ELSE
InResponseTo := Mheader.Subject;
IF ((MHeader.From.Anon = 0) OR (SeeAnon)) THEN
LastAuthor := MHeader.From.UserNum
ELSE
LastAuthor := 0;
IF ((MHeader.From.Anon = 0) OR (SeeAnon)) THEN
S := PDT2Dat(MHeader.Date,MHeader.DayOfWeek)
ELSE
S := '[Unknown]';
S := '^1Date: ^9'+S;
S := PadLeftStr(S,39)+'^1Number : ^9'+IntToStr(MNum)+'^1 of ^9'+IntToStr(TNum);
END;
2 : BEGIN
IF (Pub) AND (MARealName IN MemMsgArea.MAFlags) THEN
S1 := MHeader.From.Real
ELSE
S1 := MHeader.From.A1S;
S := '^1From: ^5'+Caps(UseName(MHeader.From.Anon,S1));
FileOwner := Caps(UseName(MHeader.From.Anon,S1));
IF (NOT Pub) AND (Netmail IN MHeader.Status) THEN
BEGIN
S := S + '^2 ('+IntToStr(MHeader.From.Zone)+':'+IntToStr(MHeader.From.Net)+'/'+IntToStr(MHeader.From.Node);
IF (MHeader.From.Point > 0) THEN
S := S + '.'+IntToStr(MHeader.From.Point);
S := S + ')';
END;
S := PadLeftStr(S,38)+'^1 Area : ^5';
IF (LennMCI(MemMsgArea.Name) > 30) THEN
S := S + PadLeftStr(MemMsgArea.Name,30)
ELSE
S := S + MemMsgArea.Name;
END;
3 : BEGIN
IF (Pub) AND (MARealName IN MemMsgArea.MAFlags) THEN
S1 := Caps(MHeader.MTO.Real)
ELSE
S1 := Caps(MHeader.MTO.A1S);
S := '^1To : ^5'+UseName(MHeader.MTO.Anon,S1);
IF (NOT Pub) AND (Netmail IN MHeader.Status) THEN
BEGIN
S := S + '^2 ('+IntToStr(MHeader.MTO.Zone)+':'+IntToStr(MHeader.MTO.Net)+'/'+IntToStr(MHeader.MTO.Node);
IF (MHeader.MTO.Point > 0) THEN
S := S + '.'+IntToStr(MHeader.MTO.Point);
S := S + ')';
END;
S := PadLeftStr(S,38)+'^1 Refer #: ^5';
IF (MHeader.Replyto > 0) AND (MHeader.Replyto < MNum) THEN
S := S + IntToStr(MNum - MHeader.Replyto)
ELSE
S := S + 'None';
END;
4 : BEGIN
S := '^1Subj: ';
IF (MHeader.FileAttached = 0) THEN
S := S + '^5'+MHeader.Subject
ELSE
S := S + '^8'+StripName(MHeader.Subject);
S := PadLeftStr(S,38)+'^1 Replies: ^5';
IF (MHeader.Replies <> 0) THEN
S := S + IntToStr(MHeader.Replies)
ELSE
S := S + 'None';
END;
5 : BEGIN
S := '^1Stat: ^';
IF (MDeleted IN MHeader.Status) THEN
S := S + '8Deleted'
ELSE IF (Prvt IN MHeader.Status) THEN
S := S + '8Private'
ELSE IF (Pub) AND (UnValidated IN MHeader.Status) THEN
S := S + '8Unvalidated'
ELSE IF (Pub) AND (Permanent IN MHeader.Status) THEN
S := S + '5Permanent'
ELSE IF (MemMsgArea.MAType <> 0) THEN
IF (Sent IN MHeader.Status) THEN
S := S + '5Sent'
ELSE
S := S + '5Unsent'
ELSE
S := S + '5Normal';
IF (NOT Pub) AND (Netmail IN MHeader.Status) THEN
S := S + ' Netmail';
S := PadLeftStr(S,39) + '^1Origin : ^5';
IF (MHeader.Origindate <> '') THEN
S := S + MHeader.Origindate
ELSE
S := S + 'Local';
END;
6 : IF ((SeeAnon) AND ((MHeader.MTO.Anon + MHeader.From.Anon) > 0) AND (MemMsgArea.MAType = 0)) THEN
BEGIN
S := '^1Real: ^5';
IF (MARealName IN MemMsgArea.MAFlags) THEN
S := S + Caps(Mheader.From.Real)
ELSE
S := S + Caps(MHeader.From.Name);
S := S + '^1 to ^5';
IF (MARealName IN MemMsgArea.MAFlags) THEN
S := S + Caps(MHeader.MTO.Real)
ELSE
S := S + Caps(MHeader.MTO.Name);
END;
END;
HeaderLine := S;
END;
{ anum=actual, MNum=M#/t# <-displayed, TNum=m#/T# <- max? }
PROCEDURE ReadMsg(Anum,MNum,TNum: Word);
VAR
MHeader: MHeaderRec;
FileInfo: FileInfoRecordType;
TransferFlags: TransferFlagSet;
MsgTxtStr: AStr;
FileOwner: Str36;
DS: DirStr;
NS: NameStr;
ES: ExtStr;
SaveFileArea: Integer;
TempTextSize: Word;
BEGIN
AllowAbort := (CoSysOp) OR (NOT (MAForceRead IN MemMsgArea.MAFlags));
AllowContinue := TRUE;
LoadHeader(Anum,MHeader);
IF ((MDeleted IN Mheader.Status) OR (UnValidated IN MHeader.Status)) AND
NOT (CoSysOp OR FromYou(MHeader) OR ToYou(MHeader)) THEN
Exit;
Abort := FALSE;
Next := FALSE;
FOR TempTextSize := 1 TO 6 DO
BEGIN
MsgTxtStr := HeaderLine(MHeader,MNum,TNum,TempTextSize,FileOwner);
IF (TempTextSize <> 2) THEN
MCIAllowed := (AllowMCI IN MHeader.Status);
IF (MsgTxtStr <> '') THEN
PrintACR(MsgTxtStr);
MCIAllowed := TRUE;
END;
NL;
Reset(MsgTxtF,1);
IF (IOResult <> 0) THEN
BEGIN
SysOpLog('Error accessing message text.');
AllowAbort := TRUE;
Exit;
END;
IF (NOT Abort) THEN
BEGIN
Reading_A_Msg := TRUE;
MCIAllowed := (AllowMCI IN Mheader.Status);
TempTextSize := 0;
Abort := FALSE;
Next := FALSE;
UserColor(MemMsgArea.Text_Color);
IF (MHeader.TextSize > 0) THEN
IF (((MHeader.Pointer - 1) + MHeader.TextSize) <= FileSize(MsgTxtF)) AND (MHeader.Pointer > 0) THEN
BEGIN
Seek(MsgTxtF,(MHeader.Pointer - 1));
REPEAT
BlockRead(MsgTxtF,MsgTxtStr[0],1);
BlockRead(MsgTxtF,MsgTxtStr[1],Ord(MsgTxtStr[0]));
LastError := IOResult;
IF (LastError <> 0) THEN
BEGIN
SysOpLog('Error loading message text.');
TempTextSize := MHeader.TextSize;
END;
Inc(TempTextSize,(Length(MsgTxtStr) + 1));
IF (' * Origin: ' = Copy(MsgTxtStr,1,11)) THEN
MsgTxtStr := '^'+IntToStr(MemMsgArea.Origin_Color) + MsgTxtStr
ELSE IF ('---'= Copy(MsgTxtStr,1,3)) AND ((Length(MsgTxtStr) = 3) OR (MsgTxtStr[4] <> '-')) THEN
MsgTxtStr := '^'+IntToStr(MemMsgArea.Tear_Color) + MsgTxtStr
ELSE IF (Pos('> ',Copy(MsgTxtStr,1,5)) > 0) THEN
MsgTxtStr := '^'+IntToStr(MemMsgArea.Quote_Color)+ MsgTxtStr +'^'+IntToStr(MemMsgArea.Text_Color)
ELSE IF (Pos(#254,Copy(MsgTxtStr,1,5)) > 0) THEN
MsgTxtStr := '^'+IntToStr(MemMsgArea.Tear_Color) + MsgTxtStr;
PrintACR('^1'+MsgTxtStr);
UNTIL (TempTextSize >= MHeader.TextSize) OR (Abort) OR (HangUp);
END;
MCIAllowed := TRUE;
Reading_A_Msg := FALSE;
IF (DOSANSIOn) THEN
ReDrawForANSI;
END;
Close(MsgTxtF);
LastError := IOResult;
IF (MHeader.FileAttached > 0) THEN
IF (NOT Exist(MHeader.Subject)) THEN
BEGIN
NL;
Print('^7The attached file does not actually exist!^1');
END
ELSE
BEGIN
SaveFileArea := FileArea;
FileArea := -1;
FSplit(MHeader.Subject,DS,NS,ES);
WITH MemFileArea DO
BEGIN
AreaName := 'File Attach';
DLPath := DS;
ULPath := DS;
FAFlags := [FANoRatio];
END;
WITH FileInfo DO
BEGIN
FileName := Align(NS+ES);
Description := 'File Attach';
FilePoints := 0;
Downloaded := 0;
FileSize := GetFileSize(MHeader.Subject);
OwnerNum := SearchUser(StripColor(FileOwner),FALSE);
OwnerName := StripColor(FileOwner);
FileDate := MHeader.Date;
VPointer := -1;
VTextSize := 0;
FIFlags := [];
END;
TransferFlags := [IsFileAttach];
DLX(FileInfo,-1,TransferFlags);
IF (IsTransferOk IN TransferFLags) AND (NOT (IsKeyboardAbort IN TransferFlags)) THEN
SendShortMessage(MHeader.From.UserNum,Caps(ThisUser.Name)+' downloaded "^5'+StripName(MHeader.Subject)+
'^1" from ^5File Attach');
FileArea := SaveFileArea;
LoadFileArea(FileArea);
END;
AllowAbort := TRUE;
TempPause := (Pause IN ThisUser.Flags);
END;
(* Done: Lee Palmer 10/23/09 *)
FUNCTION GetTagLine: Str74;
VAR
StrPointerFile: FILE OF StrPointerRec;
RGStrFile: FILE;
StrPointer: StrPointerRec;
TagLine: Str74;
TempTextSize: Word;
StrNum: Word;
FSize: LongInt;
BEGIN
TagLine := '';
IF (NOT Exist(General.lMultPath+'TAGLINE.PTR')) OR (NOT Exist(General.LMultPath+'TAGLINE.DAT')) THEN
SL1('* TAGLINE.PTR or TAGLINE.DAT file(s) do not exist!')
ELSE
BEGIN
Assign(StrPointerFile,General.LMultPath+'TAGLINE.PTR');
Reset(StrPointerFile);
FSize := FileSize(StrPointerFile);
IF (FSize < 1) THEN
BEGIN
SL1('* TAGLINE.PTR does not contain any TagLines!');
Exit;
END;
IF (FSize > 65535) THEN
FSize := 65535
ELSE
Dec(FSize);
Randomize;
StrNum := Random(FSize);
Seek(StrPointerFile,StrNum);
Read(StrPointerFile,StrPointer);
Close(StrPointerFile);
LastError := IOResult;
Assign(RGStrFile,General.LMultPath+'TAGLINE.DAT');
Reset(RGStrFile,1);
Seek(RGStrFile,(StrPointer.Pointer - 1));
TempTextSize := 0;
REPEAT
BlockRead(RGStrFile,TagLine[0],1);
BlockRead(RGStrFile,TagLine[1],Ord(TagLine[0]));
Inc(TempTextSize,(Length(TagLine) + 1));
UNTIL (TempTextSize >= StrPointer.TextSize);
Close(RGStrFile);
LastError := IOResult;
END;
GetTagLine := TagLine;
END;
END.

2408
SOURCE/MAIL1.PAS Normal file
View File

File diff suppressed because it is too large Load Diff

1403
SOURCE/MAIL2.PAS Normal file
View File

File diff suppressed because it is too large Load Diff

477
SOURCE/MAIL3.PAS Normal file
View File

@ -0,0 +1,477 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S+,V-}
UNIT Mail3;
INTERFACE
PROCEDURE EditMessageText(MsgNum: Word);
PROCEDURE ForwardMessage(MsgNum: Word);
PROCEDURE MoveMsg(MsgNum: Word);
IMPLEMENTATION
USES
Dos,
Common,
Common5,
Mail0,
Mail1,
Mail4,
MsgPack,
MiscUser,
TimeFunc;
PROCEDURE EditMessageText(MsgNum: Word);
VAR
TempQuoteFile: Text;
MHeader: MHeaderRec;
MsgTempStr: STRING;
SaveFileAttached: Byte;
TempTextSize: Word;
FileDateTime1,
FileDateTime2: LongInt;
BEGIN
SysOpLog('Edited message #'+IntToStr(MsgNum)+' on '+MemMsgArea.Name);
Assign(TempQuoteFile,'TEMPQ'+IntToStr(ThisNode)+'.MSG');
ReWrite(TempQuoteFile);
LastError := IOResult;
IF (LastError <> 0) THEN
BEGIN
NL;
Print('Error creating TEMPQ'+IntToStr(ThisNode)+'.MSG file.');
SysOpLog('Error creating TEMPQ'+IntToStr(ThisNode)+'.MSG file.');
Exit;
END;
LoadHeader(MsgNum,MHeader);
Reset(MsgTxtF,1);
Seek(MsgTxtF,(MHeader.Pointer - 1));
TempTextSize := 0;
REPEAT
BlockRead(MsgTxtF,MsgTempStr[0],1);
BlockRead(MsgTxtF,MsgTempStr[1],Ord(MsgTempStr[0]));
LastError := IOResult;
IF (LastError <> 0) THEN
BEGIN
NL;
Print('Error reading from '+MemMsgArea.FileName+'.DAT file.');
SysOpLog('Error reading from '+MemMsgArea.FileName+'.DAT file.');
TempTextSize := MHeader.TextSize;
END;
Inc(TempTextSize,(Length(MsgTempStr) + 1));
WriteLn(TempQuoteFile,MsgTempStr);
LastError := IOResult;
IF (LastError <> 0) THEN
BEGIN
NL;
Print('Error writting to TEMPQ'+IntToStr(ThisNode)+'.MSG file.');
SysOpLog('Error writting to TEMPQ'+IntToStr(ThisNode)+'.MSG file.');
TempTextSize := MHeader.TextSize;
END;
UNTIL (TempTextSize >= MHeader.TextSize);
Close(MsgTxtF);
Close(TempQuoteFile);
GetFileDateTime('TEMPQ'+IntToStr(ThisNode)+'.MSG',FileDateTime1);
SaveFileAttached := MHeader.FileAttached;
IF NOT (InputMessage((ReadMsgArea <> -1),FALSE,'',MHeader,'TEMPQ'+IntToStr(ThisNode)+'.MSG',78,500)) THEN
BEGIN
Kill('TEMPQ'+IntToStr(ThisNode)+'.MSG');
Exit;
END;
MHeader.FileAttached := SaveFileAttached;
GetFileDateTime('TEMPQ'+IntToStr(ThisNode)+'.MSG',FileDateTime2);
IF (FileDateTime1 <> FileDateTime2) THEN
BEGIN
Assign(TempQuoteFile,'TEMPQ'+IntToStr(ThisNode)+'.MSG');
Reset(TempQuoteFile);
MHeader.TextSize := 0;
Reset(MsgTxtF,1);
MHeader.Pointer := (FileSize(MsgTxtF) + 1);
Seek(MsgTxtF,(MHeader.Pointer - 1));
REPEAT
ReadLn(TempQuoteFile,MsgTempStr);
LastError := IOResult;
IF (LastError <> 0) THEN
BEGIN
NL;
Print('Error reading from TEMPQ'+IntToStr(ThisNode)+'.MSG file.');
SysOpLog('Error reading from TEMPQ'+IntToStr(ThisNode)+'.MSG file.');
END;
Inc(MHeader.TextSize,(Length(MsgTempStr) + 1));
BlockWrite(MsgTxtF,MsgTempStr,(Length(MsgTempStr) + 1));
LastError := IOResult;
IF (LastError <> 0) THEN
BEGIN
NL;
Print('Error writting to '+MemMsgArea.FileName+'.DAT file.');
SysOpLog('Error writting to '+MemMsgArea.FileName+'.DAT file.');
END;
UNTIL (EOF(TempQuoteFile));
Close(MsgTxtF);
Close(TempQuoteFile);
SaveHeader(MsgNum,MHeader);
LastError := IOResult;
END;
Kill('TEMPQ'+IntToStr(ThisNode)+'.MSG');
END;
PROCEDURE ForwardMessage(MsgNum: Word);
VAR
MsgHdrF1: FILE OF MHeaderRec;
MsgTxtF1: FILE;
User: UserRecordType;
MHeader: MHeaderRec;
MsgTempStr: STRING;
SaveReadMsgArea,
Unum: Integer;
TempTextSize: Word;
TempPtr,
TempPtr1: LongInt;
ForwardOk,
SaveConfSystem: Boolean;
BEGIN
SaveReadMsgArea := ReadMsgArea;
SaveConfSystem := ConfSystem;
ConfSystem := FALSE;
IF (SaveConfSystem) THEN
NewCompTables;
NL;
Print('^5Forward message to which user (1-'+(IntToStr(MaxUsers - 1))+')?^1');
NL;
Print('Enter User Number, Name, or Partial Search String.');
Prt(': ');
lFindUserWS(UNum);
IF (UNum < 1) THEN
PauseScr(FALSE)
ELSE
BEGIN
LoadURec(User,UNum);
ForwardOk := TRUE;
IF (User.Name = ThisUser.Name) THEN
BEGIN
NL;
Print('^7You can not forward messages to yourself!^1');
ForwardOk := FALSE;
END
ELSE IF (NoMail IN User.Flags) AND (NOT CoSysOp) THEN
BEGIN
NL;
Print('^7The mailbox for this user is closed!^1');
ForwardOk := FALSE;
END
ELSE IF (User.Waiting >= General.MaxWaiting) AND (NOT CoSysOp) THEN
BEGIN
NL;
Print('^7The mailbox for this user is full!^1');
ForwardOk := FALSE;
END;
IF (NOT ForwardOk) THEN
PauseScr(FALSE)
ELSE
BEGIN
InitMsgArea(SaveReadMsgArea);
LoadHeader(MsgNum,MHeader);
Mheader.MTO.UserNum := UNum;
MHeader.MTO.A1S := User.Name;
MHeader.MTO.Name := User.Name;
MHeader.MTO.Real := User.RealName;
TempPtr := (MHeader.Pointer - 1);
Reset(MsgTxtF,1);
MHeader.Pointer := (FileSize(MsgTxtF) + 1);
Seek(MsgTxtF,FileSize(MsgTxtF));
IF (SaveReadMsgArea <> -1) THEN
BEGIN
LoadMsgArea(-1);
Assign(MsgHdrF1,General.MsgPath+MemMsgArea.FIleName+'.HDR');
Reset(MsgHdrF1);
IF (IOResult = 2) THEN
ReWrite(MsgHdrF1);
Assign(MsgTxtF1,General.MsgPath+MemMsgArea.FIleName+'.DAT');
Reset(MsgTxtF1,1);
IF (IOResult = 2) THEN
ReWrite(MsgTxtF1,1);
TempPtr1 := (FileSize(MsgTxtF1) + 1);
Seek(MsgTxtF1,FileSize(MsgTxtF1));
END;
UNum := 0;
MsgTempStr := 'Message forwarded from '+Caps(ThisUser.Name);
Inc(UNum,(Length(MsgTempStr) + 1));
IF (SaveReadMsgArea <> -1) THEN
BlockWrite(MsgTxtF1,MsgTempStr,(Length(MsgTempStr) + 1))
ELSE
BlockWrite(MsgTxtF,MsgTempStr,(Length(MsgTempStr) + 1));
MsgTempStr := 'Message forwarded on '+DateStr+' at '+TimeStr;
Inc(UNum,(Length(MsgTempStr) + 1));
IF (SaveReadMsgArea <> -1) THEN
BlockWrite(MsgTxtF1,MsgTempStr,(Length(MsgTempStr) + 1))
ELSE
BlockWrite(MsgTxtF,MsgTempStr,(Length(MsgTempStr) + 1));
MsgTempStr := '';
Inc(UNum,(Length(MsgTempStr) + 1));
IF (SaveReadMsgArea <> -1) THEN
BlockWrite(MsgTxtF1,MsgTempStr,(Length(MsgTempStr) + 1))
ELSE
BlockWrite(MsgTxtF,MsgTempStr,(Length(MsgTempStr) + 1));
TempTextSize := 0;
REPEAT
Seek(MsgTxtF,(TempPtr + TempTextSize));
BlockRead(MsgTxtF,MsgTempStr[0],1);
BlockRead(MsgTxtF,MsgTempStr[1],Ord(MsgTempStr[0]));
LastError := IOResult;
Inc(TempTextSize,(Length(MsgTempStr) + 1));
IF (SaveReadMsgArea <> - 1) THEN
BEGIN
Seek(MsgTxtF1,FileSize(MsgTxtF1));
BlockWrite(MsgTxtF1,MsgTempStr,(Length(MsgTempStr) + 1));
END
ELSE
BEGIN
Seek(MsgTxtF,FileSize(MsgTxtF));
BlockWrite(MsgTxtF,MsgTempStr,(Length(MsgTempStr) + 1));
END;
UNTIL (TempTextSize >= MHeader.TextSize);
Close(MsgTxtF);
IF (SaveReadMsgArea <> -1) THEN
BEGIN
Close(MsgTxtF1);
Close(MsgHdrF1);
END;
Inc(MHeader.TextSize,UNum);
IF (SaveReadMsgArea <> -1) THEN
BEGIN
InitMsgArea(-1);
MHeader.Pointer := TempPtr1;
END;
SaveHeader((HiMsg + 1),MHeader);
LoadURec(User,MHeader.MTO.UserNum);
Inc(User.Waiting);
SaveURec(User,MHeader.MTO.UserNum);
NL;
Print('Message forwarded to: ^5'+Caps(User.Name)+'^1');
PauseScr(FALSE);
SysOpLog('Message forwarded to: ^5'+Caps(User.Name));
END;
END;
ConfSystem := SaveConfSystem;
IF (SaveConfSystem) THEN
NewCompTables;
InitMsgArea(SaveReadMsgArea);
END;
PROCEDURE MoveMsg(MsgNum: Word);
VAR
MsgHdrF1: FILE OF MHeaderRec;
MsgTxtF1: FILE;
MHeader: MHeaderRec;
MsgTxtStr: STRING;
InputStr: Str5;
MArea,
NumMAreas,
SaveMArea,
NewMsgArea,
SaveReadMsgArea: Integer;
TempTextSize: Word;
SaveConfSystem: Boolean;
BEGIN
SaveReadMsgArea := ReadMsgArea;
SaveConfSystem := ConfSystem;
ConfSystem := FALSE;
IF (SaveConfSystem) THEN
NewCompTables;
MArea := 1;
NumMAreas := 0;
NewMsgArea := 0;
LightBarCmd := 1;
LightBarFirstCmd := TRUE;
InputStr := '?';
REPEAT
SaveMArea := MArea;
IF (InputStr = '?') THEN
MessageAreaList(MArea,NumMAreas,5,FALSE);
{
%LFMove to which area? (^50^4=^5Private^4,^5'+IntToStr(LowMsgArea)+'^4-^5'+IntToStr(HighMsgArea)+'^4)
[^5#^4,^5?^4=^5Help^4,^5Q^4=^5Quit^4]: @
}
MsgAreaScanInput(LRGLngStr(77,TRUE),Length(IntToStr(HighMsgArea)),InputStr,'Q[]?',LowMsgArea,HighMsgArea);
IF (InputStr <> 'Q') THEN
BEGIN
IF (InputStr = '[') THEN
BEGIN
MArea := (SaveMArea - ((PageLength - 5) * 2));
IF (MArea < 1) THEN
MArea := 1;
InputStr := '?';
END
ELSE IF (InputStr = ']') THEN
BEGIN
IF (MArea > NumMsgAreas) THEN
MArea := SaveMArea;
InputStr := '?';
END
ELSE IF (InputStr = '?') THEN
BEGIN
{
$File_Message_Area_List_Help
%LF^1(^3###^1)Manual entry selection ^1(^3<CR>^1)Select current entry
^1(^3<Home>^1)First entry on page ^1(^3<End>^1)Last entry on page
^1(^3Left Arrow^1)Previous entry ^1(^3Right Arrow^1)Next entry
^1(^3Up Arrow^1)Move up ^1(^3Down Arrow^1)Move down
^1(^3[^1)Previous page ^1(^3]^1)Next page
%PA
}
LRGLngStr(71,FALSE);
MArea := SaveMArea;
END
ELSE IF (StrToInt(InputStr) < 0) OR (StrToInt(InputStr) > HighMsgArea) THEN
BEGIN
NL;
Print('^7The range must be from 0 to '+IntToStr(HighMsgArea)+'!^1');
NL;
PauseScr(FALSE);
MArea := SaveMArea;
InputStr := '?';
END
ELSE
BEGIN
IF (InputStr = '0') THEN
NewMsgArea := -1
ELSE
NewMsgArea := CompMsgArea(StrToInt(InputStr),1);
IF (NewMsgArea = ReadMsgArea) THEN
BEGIN
NL;
Print('^7You can not move a message to the same area!^1');
NL;
PauseScr(FALSE);
MArea := SaveMArea;
InputStr := '?';
END
ELSE
BEGIN
InitMsgArea(NewMsgArea);
IF (NOT MsgAreaAC(NewMsgArea)) THEN
BEGIN
NL;
Print('^7You do not have access to this message area!^1');
NL;
PauseScr(FALSE);
MArea := SaveMArea;
InputStr := '?';
END
ELSE IF (NOT AACS(MemMsgArea.PostAcs)) THEN
BEGIN
NL;
Print('^7You do not have posting access to this message area!^1');
NL;
PauseScr(FALSE);
MArea := SaveMArea;
InputStr := '?';
END
ELSE
BEGIN
NL;
IF (NOT PYNQ('Move message to '+MemMsgArea.Name+'? ',0,FALSE)) THEN
BEGIN
MArea := SaveMArea;
InputStr := '?';
END
ELSE
BEGIN
InitMsgArea(SaveReadMsgArea);
LoadHeader(MsgNum,MHeader);
IF (NOT (MDeleted IN MHeader.Status)) THEN
Include(MHeader.Status,MDeleted);
SaveHeader(MsgNum,MHeader);
LoadMsgArea(NewMsgArea);
Assign(MsgHdrF1,General.MsgPath+MemMsgArea.FileName+'.HDR');
Reset(MsgHdrF1);
IF (IOResult = 2) THEN
ReWrite(MsgHdrF1);
Seek(MsgHdrF1,FileSize(MsgHdrF1));
Assign(MsgTxtF1,General.MsgPath+MemMsgArea.FileName+'.DAT');
Reset(MsgTxtF1,1);
IF (IOResult = 2) THEN
ReWrite(MsgTxtF1,1);
Reset(MsgTxtF,1);
Seek(MsgTxtF,(MHeader.Pointer - 1));
MHeader.Pointer := (FileSize(MsgTxtF1) + 1);
Seek(MsgTxtF1,FileSize(MsgTxtF1));
IF (MDeleted IN MHeader.Status) THEN
Exclude(MHeader.Status,MDeleted);
Write(MsgHdrF1,MHeader);
Close(MsgHdrF1);
TempTextSize := 0;
REPEAT
BlockRead(MsgTxtF,MsgTxtStr[0],1);
BlockRead(MsgTxtF,MsgTxtStr[1],Ord(MsgTxtStr[0]));
LastError := IOResult;
Inc(TempTextSize,(Length(MsgTxtStr) + 1));
BlockWrite(MsgTxtF1,MsgTxtStr,(Length(MsgTxtStr) + 1));
LastError := IOResult;
UNTIL (TempTextSize >= MHeader.TextSize);
Close(MsgTxtF1);
Close(MsgTxtF);
NL;
Print('The message was moved successfully.');
InputStr := 'Q';
END;
END;
ReadMsgArea := SaveReadMsgArea;
END;
END;
END;
UNTIL (InputStr = 'Q') OR (HangUp);
ConfSystem := SaveConfSystem;
IF (SaveConfSystem) THEN
NewCompTables;
InitMsgArea(SaveReadMsgArea);
END;
END.

485
SOURCE/MAIL4.PAS Normal file
View File

@ -0,0 +1,485 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S+,V-}
UNIT Mail4;
INTERFACE
USES
Common;
PROCEDURE MessageAreaList(VAR MArea,NumMAreas: Integer; AdjPageLen: Byte; ShowScan: Boolean);
PROCEDURE MessageAreaChange(VAR Done: Boolean; CONST MenuOption: Str50);
PROCEDURE ToggleMsgAreaScanFlags;
IMPLEMENTATION
USES
Crt,
Common5,
Mail0;
PROCEDURE MessageAreaList(VAR MArea,NumMAreas: Integer; AdjPageLen: Byte; ShowScan: Boolean);
VAR
ScanChar: Str1;
TempStr: AStr;
NumOnline,
NumDone: Byte;
SaveMsgArea: Integer;
BEGIN
SaveMsgArea := MsgArea;
Abort := FALSE;
Next := FALSE;
NumOnline := 0;
TempStr := '';
FillChar(LightBarArray,SizeOf(LightBarArray),0);
LightBarCounter := 0;
{
$New_Scan_Char_Message
ţ
$
}
IF (ShowScan) THEN
ScanChar := lRGLngStr(66,TRUE);
{
$Message_Area_Select_Header
%CL7ÚÄÄÄÄÄÂÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÂÄÄÄÄÄÂÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄż
7ł8 Num 7ł9 Name 7ł8 Num 7ł9 Name 7ł
7ŔÄÄÄÄÄÁÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÁÄÄÄÄÄÁÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄŮ
$
}
lRGLngStr(58,FALSE);
Reset(MsgAreaFile);
NumDone := 0;
WHILE (NumDone < (PageLength - AdjPageLen)) AND (MArea >= 1) AND (MArea <= NumMsgAreas) AND (NOT Abort) AND (NOT HangUp) DO
BEGIN
LoadMsgArea(MArea);
IF (ShowScan) THEN
LoadLastReadRecord(LastReadRecord);
IF (AACS(MemMsgArea.ACS)) OR (MAUnHidden IN MemMsgArea.MAFlags) THEN
BEGIN
IF (General.UseMsgAreaLightBar) AND (MsgAreaLightBar IN ThisUser.SFlags) THEN
BEGIN
Inc(LightBarCounter);
LightBarArray[LightBarCounter].CmdToExec := CompMsgArea(MArea,0);
LightBarArray[LightBarCounter].CmdToShow := MemMsgArea.Name;
IF (NumOnline = 0) THEN
BEGIN
LightBarArray[LightBarCounter].Xpos := 8;
LightBarArray[LightBarCounter].YPos := WhereY;
END
ELSE
BEGIN
LightBarArray[LightBarCounter].Xpos := 47;
LightBarArray[LightBarCounter].YPos := WhereY;
END;
END;
TempStr := TempStr + AOnOff(ShowScan AND LastReadRecord.NewScan,':'+ScanChar[1],' ')+
PadLeftStr(PadRightStr(';'+IntToStr(CompMsgArea(MArea,0)),5)+
+'< '+MemMsgArea.Name,37)+' ';
Inc(NumOnline);
IF (NumOnline = 2) THEN
BEGIN
PrintaCR(TempStr);
NumOnline := 0;
Inc(NumDone);
TempStr := '';
END;
Inc(NumMAreas);
END;
WKey;
Inc(MArea);
END;
Close(MsgAreaFile);
LastError := IOResult;
IF (NumOnline = 1) AND (NOT Abort) AND (NOT HangUp) THEN
PrintACR(TempStr)
ELSE IF (NumMAreas = 0) AND (NOT Abort) AND (NOT HangUp) THEN
LRGLngStr(68,FALSE);
{
%LF^7No message areas!^1'
}
MsgArea := SaveMsgArea;
LoadMsgArea(MsgArea);
END;
PROCEDURE MessageAreaChange(VAR Done: Boolean; CONST MenuOption: Str50);
VAR
InputStr: Str5;
Cmd: Char;
MArea,
NumMAreas,
SaveMArea: Integer;
SaveTempPause: Boolean;
BEGIN
IF (MenuOption <> '') THEN
CASE UpCase(MenuOption[1]) OF
'+' : BEGIN
MArea := MsgArea;
IF (MsgArea >= NumMsgAreas) THEN
MArea := 0
ELSE
REPEAT
Inc(MArea);
ChangeMsgArea(MArea);
UNTIL (MsgArea = MArea) OR (MArea >= NumMsgAreas);
IF (MsgArea <> MArea) THEN
BEGIN
{
%LFHighest accessible message area.
%PA
}
LRGLngStr(85,FALSE);
END
ELSE
LastCommandOvr := TRUE;
END;
'-' : BEGIN
MArea := MsgArea;
IF (MsgArea <= 0) THEN
MArea := 0
ELSE
REPEAT
Dec(MArea);
ChangeMsgArea(MArea);
UNTIL (MsgArea = MArea) OR (MArea <= 0);
IF (MsgArea <> MArea) THEN
BEGIN
{
%LFLowest accessible message area.
%PA
}
LRGLngStr(84,FALSE);
END
ELSE
LastCommandOvr := TRUE;
END;
'L' : BEGIN
SaveTempPause := TempPause;
TempPause := FALSE;
MArea := 1;
NumMAreas := 0;
Cmd := '?';
REPEAT
SaveMArea := MArea;
IF (Cmd = '?') THEN
MessageAreaList(MArea,NumMAreas,5,FALSE);
{
%LFMessage area list? [^5?^4=^5Help^4,^5Q^4=^5Quit^4]: @
}
LOneK(LRGLngStr(69,TRUE),Cmd,'Q?[]',TRUE,TRUE);
TempPause := FALSE;
IF (Cmd <> 'Q') THEN
BEGIN
IF (Cmd = '[') THEN
BEGIN
MArea := (SaveMArea - ((PageLength - 5) * 2));
IF (MArea < 1) THEN
MArea := 1;
Cmd := '?';
END
ELSE IF (Cmd = ']') THEN
BEGIN
IF (MArea > NumMsgAreas) THEN
MArea := SaveMArea;
Cmd := '?';
END
END
ELSE IF (Cmd = '?') THEN
BEGIN
{
$File_Message_Area_List_Help
%LF^1(^3###^1)Manual entry selection ^1(^3<CR>^1)Select current entry
^1(^3<Home>^1)First entry on page ^1(^3<End>^1)Last entry on page
^1(^3Left Arrow^1)Previous entry ^1(^3Right Arrow^1)Next entry
^1(^3Up Arrow^1)Move up ^1(^3Down Arrow^1)Move down
^1(^3[^1)Previous page ^1(^3]^1)Next page
%PA
}
LRGLngStr(71,FALSE);
MArea := SaveMArea;
END
UNTIL (Cmd = 'Q') OR (HangUp);
TempPause := SaveTempPause;
LastCommandOvr := TRUE;
END;
ELSE
BEGIN
IF (StrToInt(MenuOption) > 0) THEN
BEGIN
MArea := StrToInt(MenuOption);
IF (MArea <> MsgArea) THEN
ChangeMsgArea(MArea);
IF (Pos(';',MenuOption) > 0) THEN
BEGIN
CurMenu := StrToInt(Copy(MenuOption,(Pos(';',MenuOption) + 1),Length(MenuOption)));
NewMenuToLoad := TRUE;
Done := TRUE;
END;
LastCommandOvr := TRUE;
END;
END;
END
ELSE
BEGIN
SaveTempPause := TempPause;
TempPause := FALSE;
MArea := 1;
NumMAreas := 0;
LightBarCmd := 1;
LightBarFirstCmd := TRUE;
InputStr := '?';
REPEAT
SaveMArea := MArea;
IF (InputStr = '?') THEN
MessageAreaList(MArea,NumMAreas,5,FALSE);
{
%LFChange message area? [^5#^4,^5?^4=^5Help^4,^5Q^4=^5Quit^4]: @
}
MsgAreaScanInput(LRGLngStr(73,TRUE),Length(IntToStr(HighMsgArea)),InputStr,'Q[]?',LowMsgarea,HighMsgArea);
IF (InputStr <> 'Q') THEN
BEGIN
IF (InputStr = '[') THEN
BEGIN
MArea := (SaveMArea - ((PageLength - 5) * 2));
IF (MArea < 1) THEN
MArea := 1;
InputStr := '?';
END
ELSE IF (InputStr = ']') THEN
BEGIN
IF (MArea > NumMsgAreas) THEN
MArea := SaveMArea;
InputStr := '?';
END
ELSE IF (InputStr = '?') THEN
BEGIN
{
$File_Message_Area_List_Help
%LF^1(^3###^1)Manual entry selection ^1(^3<CR>^1)Select current entry
^1(^3<Home>^1)First entry on page ^1(^3<End>^1)Last entry on page
^1(^3Left Arrow^1)Previous entry ^1(^3Right Arrow^1)Next entry
^1(^3Up Arrow^1)Move up ^1(^3Down Arrow^1)Move down
^1(^3[^1)Previous page ^1(^3]^1)Next page
%PA
}
LRGLngStr(71,FALSE);
MArea := SaveMArea;
END
ELSE IF (StrToInt(InputStr) < LowMsgArea) OR (StrToInt(InputStr) > HighMsgArea) THEN
BEGIN
{
%LF^7The range must be from %A3 to %A4!^1
}
LRGLngStr(79,FALSE);
MArea := SaveMArea;
InputStr := '?';
END
ELSE
BEGIN
MArea := CompMsgArea(StrToInt(InputStr),1);
IF (MArea <> MsgArea) THEN
ChangeMsgArea(MArea);
IF (MArea = MsgArea) THEN
InputStr := 'Q'
ELSE
BEGIN
{
%LF^7You do not have access to this message area!^1
}
LRGLngStr(81,FALSE);
MArea := SaveMArea;
InputStr := '?';
END;
END;
END;
UNTIL (InputStr = 'Q') OR (HangUp);
TempPause := SaveTempPause;
LastCommandOvr := TRUE;
END;
END;
PROCEDURE ToggleMsgAreaScanFlags;
VAR
InputStr: Str11;
FirstMArea,
LastMArea,
MArea,
NumMAreas,
SaveMArea,
SaveMsgArea: Integer;
SaveConfSystem,
SaveTempPause: Boolean;
PROCEDURE ToggleScanFlags(MArea1: Integer; ScanType: Byte);
BEGIN
IF (MsgArea <> MArea1) THEN
ChangeMsgArea(MArea1);
IF (MsgArea = MArea1) THEN
BEGIN
LoadLastReadRecord(LastReadRecord);
IF (ScanType = 1) THEN
LastReadRecord.NewScan := TRUE
ELSE IF (ScanType = 2) THEN
BEGIN
IF (NOT (MAForceRead IN MemMsgArea.MAFlags)) THEN
LastReadRecord.NewScan := FALSE
ELSE
LastReadRecord.NewScan := TRUE;
END
ELSE IF (ScanType = 3) THEN
BEGIN
IF (NOT (MAForceRead IN MemMsgArea.MAFlags)) THEN
LastReadRecord.NewScan := (NOT LastReadRecord.NewScan)
ELSE
LastReadRecord.NewScan := TRUE;
END;
SaveLastReadRecord(LastReadRecord);
END;
END;
BEGIN
SaveMsgArea := MsgArea;
SaveConfSystem := ConfSystem;
ConfSystem := FALSE;
IF (SaveConfSystem) THEN
NewCompTables;
SaveTempPause := TempPause;
TempPause := FALSE;
MArea := 1;
NumMAreas := 0;
LightBarCmd := 1;
LightBarFirstCmd := TRUE;
InputStr := '?';
REPEAT
SaveMArea := MArea;
IF (InputStr = '?') THEN
MessageAreaList(MArea,NumMAreas,5,TRUE);
{
%LFToggle new scan? [^5#^4,^5#^4-^5#^4,^5F^4=^5Flag ^4or ^5U^4=^5Unflag All^4,^5?^4=^5Help^4,^5Q^4=^5Quit^4]: @
}
MsgAreaScanInput(LRGLngStr(75,TRUE),((Length(IntToStr(HighMsgArea)) * 2) + 1),InputStr,'QFU[]?',LowMsgArea,HighMsgArea);
IF (InputStr <> 'Q') THEN
BEGIN
IF (InputStr = '[') THEN
BEGIN
MArea := (SaveMArea - ((PageLength - 5) * 2));
IF (MArea < 1) THEN
MArea := 1;
InputStr := '?';
END
ELSE IF (InputStr = ']') THEN
BEGIN
IF (MArea > NumMsgAreas) THEN
MArea := SaveMArea;
InputStr := '?';
END
ELSE IF (InputStr = '?') THEN
BEGIN
{
$File_Message_Area_List_Help
%LF^1(^3###^1)Manual entry selection ^1(^3<CR>^1)Select current entry
^1(^3<Home>^1)First entry on page ^1(^3<End>^1)Last entry on page
^1(^3Left Arrow^1)Previous entry ^1(^3Right Arrow^1)Next entry
^1(^3Up Arrow^1)Move up ^1(^3Down Arrow^1)Move down
^1(^3[^1)Previous page ^1(^3]^1)Next page
%PA
}
LRGLngStr(71,FALSE);
MArea := SaveMArea;
END
ELSE
BEGIN
MsgArea := 0;
IF (InputStr = 'F') THEN
BEGIN
FOR MArea := 1 TO NumMsgAreas DO
ToggleScanFlags(MArea,1);
{
%LFYou are now reading all message areas.
}
LRGLngStr(87,FALSE);
MArea := 1;
InputStr := '?';
END
ELSE IF (InputStr = 'U') THEN
BEGIN
FOR MArea := 1 TO NumMsgAreas DO
ToggleScanFlags(MArea,2);
{
%LFYou are now not reading any message areas.
}
LRGLngStr(89,FALSE);
MArea := 1;
InputStr := '?';
END
ELSE IF (StrToInt(InputStr) > 0) THEN
BEGIN
FirstMArea := StrToInt(InputStr);
IF (Pos('-',InputStr) = 0) THEN
LastMArea := FirstMArea
ELSE
BEGIN
LastMArea := StrToInt(Copy(InputStr,(Pos('-',InputStr) + 1),(Length(InputStr) - Pos('-',InputStr))));
IF (FirstMArea > LastMArea) THEN
BEGIN
MArea := FirstMArea;
FirstMArea := LastMArea;
LastMArea := MArea;
END;
END;
IF (FirstMArea < LowMsgArea) OR (LastMArea > HighMsgArea) THEN
BEGIN
{
%LF^7The range must be from %A3 to %A4!^1
}
LRGLngStr(91,FALSE);
MArea := SaveMArea;
InputStr := '?';
END
ELSE
BEGIN
FirstMArea := CompMsgArea(FirstMArea,1);
LastMArea := CompMsgArea(LastMArea,1);
FOR MArea := FirstMArea TO LastMArea DO
ToggleScanFlags(MArea,3);
IF (FirstMArea = LastMArea) THEN
IF (NOT (MAForceRead IN MemMsgArea.MAFlags)) THEN
BEGIN
{
%LF^5%MB^3 will %MSbe scanned.
}
LRGLngStr(93,FALSE);
END
ELSE
BEGIN
{
%LF^5%MB^3 cannot be removed from your newscan.
}
LRGLngStr(94,FALSE);
END;
MArea := SaveMArea;
InputStr := '?';
END;
END;
MsgArea := SaveMsgArea;
END;
END;
UNTIL (InputStr = 'Q') OR (HangUp);
ConfSystem := SaveConfSystem;
IF (SaveConfSystem) THEN
NewCompTables;
TempPause := SaveTempPause;
MsgArea := SaveMsgArea;
LoadMsgArea(MsgArea);
LastCommandOvr := TRUE;
END;
END.

973
SOURCE/MAINT.PAS Normal file
View File

@ -0,0 +1,973 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S+,V-}
UNIT Maint;
INTERFACE
PROCEDURE LogonMaint;
PROCEDURE LogoffMaint;
PROCEDURE DailyMaint;
PROCEDURE UpdateGeneral;
IMPLEMENTATION
USES
Automsg,
Bulletin,
Common,
CUser,
Email,
Events,
File6,
File12,
Mail1,
Mail4,
ShortMsg,
TimeFunc,
Vote;
PROCEDURE LogonMaint;
VAR
LastCallerFile: FILE OF LastCallerRec;
LastCaller: LastCallerRec;
TempStr,
TempStr1: AStr;
Cmd: Char;
Counter,
Counter1: Integer;
RecNum: LongInt;
BSince: Boolean;
PROCEDURE UpdateUserInformation;
VAR
UpdateArray: ARRAY [0..10] OF Integer;
Counter,
Counter1: Integer;
BEGIN
FOR Counter := 0 TO 10 DO
UpdateArray[Counter] := 0;
Counter := 0;
IF (ThisUser.RealName = User_String_Ask) THEN
BEGIN
UpdateArray[1] := 10;
Inc(Counter);
END;
IF (ThisUser.Street = User_String_Ask) THEN
BEGIN
UpdateArray[2] := 1;
Inc(Counter);
END;
IF (ThisUser.CityState = User_String_Ask) THEN
BEGIN
UpdateArray[0] := 23;
UpdateArray[3] := 4;
Inc(Counter);
END;
IF (ThisUser.ZipCode = User_String_Ask) THEN
BEGIN
UpdateArray[0] := 23;
UpdateArray[4] := 14;
Inc(Counter);
END;
IF (ThisUser.BirthDate = User_Date_Ask) THEN
BEGIN
UpdateArray[5] := 2;
Inc(Counter);
END;
IF (ThisUser.Ph = User_Phone_Ask) THEN
BEGIN
UpdateArray[6] := 8;
Inc(Counter);
END;
IF (ThisUser.UsrDefStr[1] = User_String_Ask) THEN
BEGIN
UpdateArray[7] := 5;
Inc(Counter);
END;
IF (ThisUser.UsrDefStr[2] = User_String_Ask) THEN
BEGIN
UpdateArray[8] := 6;
Inc(Counter);
END;
IF (ThisUser.UsrDefStr[3] = User_String_Ask) THEN
BEGIN
UpdateArray[9] := 13;
Inc(Counter);
END;
IF (ThisUser.ForgotPWAnswer = User_String_Ask) THEN
BEGIN
UpdateArray[10] := 30;
Inc(Counter);
END;
IF (Counter <> 0) THEN
BEGIN
CLS;
NL;
Print('Please update the following information:');
Counter := 0;
WHILE (Counter <= 10) AND (NOT HangUp) DO
BEGIN
IF (UpDateArray[Counter] <> 0) THEN
BEGIN
Update_Screen;
CStuff(UpdateArray[Counter],1,ThisUser);
END;
Inc(Counter);
END;
NL;
Print('Thank you!');
NL;
PauseScr(FALSE);
END;
END;
FUNCTION CheckBirthday: Boolean;
VAR
BDate: LongInt;
BEGIN
BSince := FALSE;
BDate := Date2PD(Copy(PD2Date(ThisUser.BirthDate),1,6) + Copy(DateStr,7,4));
IF (BDate > ThisUser.LastOn) AND (BDate <= Date2PD(DateStr)) THEN
BEGIN
CheckBirthday := TRUE;
BSince := (BDate < Date2PD(DateStr));
END
ELSE
CheckBirthday := FALSE;
END;
PROCEDURE ShowBDay(CONST UserNumber: AStr);
BEGIN
IF (BSince) THEN
PrintF('BDYS'+UserNumber);
IF (NoFile) THEN
PrintF('BDAY'+UserNumber);
END;
PROCEDURE FindChopTime;
VAR
LNG,
LNG2,
LNG3: LongInt;
EventNum: Byte;
PROCEDURE OnlineTime;
BEGIN
PrintF('REVENT'+IntToStr(EventNum));
IF (NoFile) THEN
BEGIN
Print(^G);
NL;
Print('^8Note: ^5System event approaching.');
Print('System will be shut down in '+FormattedTime(NSL));
NL;
Print(^G);
PauseScr(FALSE);
END;
END;
BEGIN
IF (ExtEventTime <> 0) THEN
BEGIN
LNG := ExtEventTime;
IF (LNG < (NSL DIV 60)) THEN
BEGIN
ChopTime := (NSL - (LNG * 60)) + 120;
OnlineTime;
Exit;
END;
END;
LNG := 1;
LNG2 := (NSL DIV 60);
IF (LNG2 > 180) THEN
LNG2 := 180;
WHILE (LNG <= LNG2) DO
BEGIN
LNG3 := (LNG * 60);
EventNum := CheckEvents(LNG3);
IF (EventNum <> 0) THEN
BEGIN
ChopTime := (NSL - (LNG * 60)) + 60;
OnlineTime;
Exit;
END;
Inc(LNG,2);
END;
END;
BEGIN
IF (General.MultiNode) THEN
BEGIN
LoadNode(ThisNode);
IF AACS(General.Invisible) AND PYNQ(lRGLngStr(45,TRUE){FString.AskInvisibleLoginStr},0,FALSE) THEN
BEGIN
IsInvisible := TRUE;
Include(NodeR.Status,NInvisible);
SysOpLog('Selected invisible mode.');
END
ELSE
IsInvisible := FALSE;
FillChar(NodeR.Invited,SizeOf(NodeR.Invited),0);
FillChar(NodeR.Booted,SizeOf(NodeR.Booted),0);
FillChar(NodeR.Forget,SizeOf(NodeR.Forget),0);
Include(NodeR.Status,NAvail);
SaveNode(ThisNode);
Update_Node(RGNoteStr(37,TRUE),TRUE);
FOR Counter := 1 TO MaxNodes DO
BEGIN
LoadNode(Counter);
NodeR.Forget[ThisNode DIV 8] := NodeR.Forget[ThisNode DIV 8] - [ThisNode MOD 8];
SaveNode(Counter);
END;
END;
ConfSystem := TRUE;
IF (ThisUser.LastConf IN ConfKeys) THEN
CurrentConf := ThisUser.LastConf
ELSE
BEGIN
CurrentConf := '@';
ThisUser.LastConf := CurrentConf;
END;
PublicReadThisCall := 0;
ExtraTime := 0;
FreeTime := 0;
CreditTime := 0;
TimeOn := GetPackDateTime;
UserOn := TRUE;
Com_Flush_Recv;
lStatus_Screen(100,'Cleaning up work areas...',FALSE,TempStr);
PurgeDir(TempDir+'ARC\',FALSE);
PurgeDir(TempDir+'QWK\',FALSE);
PurgeDir(TempDir+'UP\',FALSE);
PurgeDir(TempDir+'CD\',FALSE);
DailyMaint;
IF (ComPortSpeed > 0) AND (NOT LocalIOOnly) THEN
Inc(TodayCallers);
IF (SLogSeparate IN ThisUser.SFlags) THEN
BEGIN
Assign(SysOpLogFile1,General.LogsPath+'SLOG'+IntToStr(UserNum)+'.LOG');
Append(SysOpLogFile1);
IF (IOResult = 2) THEN
BEGIN
ReWrite(SysOpLogFile1);
Append(SysOpLogFile1);
TempStr := '';
TempStr1 := '';
FOR Counter := 1 TO (26 + Length(ThisUser.Name)) DO
BEGIN
TempStr := TempStr + '_';
TempStr1 := TempStr1 + ' ';
END;
WriteLn(SysOpLogFile1,'');
WriteLn(SysOpLogFile1,' '+TempStr);
WriteLn(SysOpLogFile1,'>>'+TempStr1+'<<');
WriteLn(SysOpLogFile1,'>> Renegade SysOp Log for '+Caps(ThisUser.Name)+': <<');
WriteLn(SysOpLogFile1,'>>'+TempStr+'<<');
WriteLn(SysOpLogFile1,'');
END;
WriteLn(SysOpLogFile1);
TempStr := '^3Logon ^5['+Dat+']^4 (';
IF (ComPortSpeed > 0) THEN
BEGIN
TempStr := TempStr + IntToStr(ActualSpeed)+' baud';
IF (Reliable) THEN
TempStr := TempStr + '/Reliable)'
ELSE
TempStr := TempStr + ')';
IF (CallerIDNumber > '') THEN
BEGIN
IF (NOT Telnet) THEN
TempStr := TempStr + ' Number: '+CallerIDNumber
ELSE
TempStr := TempStr + ' IP Number: '+CallerIDNumber;
END;
END
ELSE
TempStr := TempStr + 'Keyboard)';
IF (General.StripCLog) THEN
TempStr := StripColor(TempStr);
WriteLn(SysOpLogFile1,TempStr);
Close(SysOpLogFile1);
END;
TempStr := '^3'+IntToStr(General.CallerNum)+'^4 -- ^0'+Caps(ThisUser.Name)+'^4 -- ^3'+'Today '+IntToStr(ThisUser.OnToday);
IF (Trapping) THEN
TempStr := TempStr + '^0*';
SL1(TempStr);
SaveGeneral(FALSE);
LastError := IOResult;
IF ((CoSysOp) AND (NOT FastLogon) AND (ComPortSpeed > 0)) THEN
BEGIN
IF PYNQ(lRGLngStr(57,TRUE){FString.QuickLogon},0,FALSE) THEN
FastLogon := TRUE;
NL;
END;
Assign(LastCallerFile,General.DataPath+'LASTON.DAT');
IF Exist(General.DataPath+'LASTON.DAT') THEN
Reset(LastCallerFile)
ELSE
ReWrite(LastCallerFile);
FillChar(LastCaller,SizeOf(LastCaller),#0);
WITH LastCaller DO
BEGIN
Node := ThisNode;
Caller := General.CallerNum;
UserName := Caps(ThisUser.Name);
UserID := UserNum;
Location := ThisUser.CityState;
IF (ComPortSpeed <> 0) THEN
Speed := ActualSpeed
ELSE
Speed := 0;
LogonTime := TimeOn;
LogoffTime := 0;
NewUser := WasNewUser;
Invisible := IsInvisible;
END;
IF AACS(General.LastOnDatACS) THEN
BEGIN
Seek(LastCallerFile,FileSize(LastCallerFile));
Write(LastCallerFile,LastCaller);
END;
Close(LastCallerFile);
LastError := IOResult;
SaveGeneral(TRUE);
IF (NOT FastLogon) AND (NOT HangUp) THEN
BEGIN
PrintF('LOGON');
Counter := 0;
REPEAT
Inc(Counter);
PrintF('LOGON'+IntToStr(Counter));
UNTIL (Counter = 9) OR (NoFile) OR (HangUp);
PrintF('SL'+IntToStr(ThisUser.SL));
PrintF('DSL'+IntToStr(ThisUser.DSL));
FOR Cmd := 'A' TO 'Z' DO
IF (Cmd IN ThisUser.AR) THEN
PrintF('ARLEVEL'+Cmd);
PrintF('USER'+IntToStr(UserNum));
IF (FindOnlyOnce) THEN
PrintF('ONCEONLY');
UpdateUserInformation;
IF (General.LogonQuote) THEN
RGQuote('LGNQUOTE');
IF (CheckBirthday) THEN
BEGIN
ShowBDay(IntToStr(UserNum));
IF (NoFile) THEN
ShowBDay('');
IF (NoFile) THEN
IF (BSince) THEN
BEGIN
NL;
Print('^3Happy Birthday, '+Caps(ThisUser.Name)+' !!!');
Print('^3(a little late, but it''s the thought that counts!)');
NL;
END
ELSE
BEGIN
NL;
Print('^3Happy Birthday, '+Caps(ThisUser.Name)+' !!!');
Print('^3You turned '+IntToStr(AgeUser(ThisUser.BirthDate))+' today!!');
NL;
END;
PauseScr(FALSE);
CLS;
END;
NL;
IF (General.AutoMInLogon) THEN
ReadAutoMsg;
NL;
IF (General.YourInfoInLogon) THEN
BEGIN
PrintF('YOURINFO');
NL;
END;
LIL := 0;
IF (General.BullInLogon) AND (NewBulletins) THEN
BEGIN
NL;
IF PYNQ(lRGLngStr(56,TRUE){FString.ShowBulletins},0,FALSE) THEN
Bulletins('')
ELSE
NL;
END;
IF (NOT (RVoting IN ThisUser.Flags)) THEN
BEGIN
Counter := UnVotedTopics;
IF (Counter > 0) THEN
BEGIN
NL;
Prompt('^5You have not voted on ^9'+IntToStr(Counter)+'^5 voting '+Plural('question',Counter));
NL;
END;
END;
IF Exist(General.DataPath+'BATCHDL.DAT') THEN
BEGIN
Assign(BatchDLFile,General.DataPath+'BATCHDL.DAT');
Reset(BatchDLFile);
RecNum := 1;
WHILE (RecNum <= FileSize(BatchDLFile)) DO
BEGIN
Seek(BatchDLFile,(RecNum - 1));
Read(BatchDLFile,BatchDL);
IF (BatchDL.BDLUserNum = UserNum) THEN
BEGIN
Inc(NumBatchDLFiles);
Inc(BatchDLTime,BatchDL.BDLTime);
Inc(BatchDLSize,BatchDL.BDLFSize);
Inc(BatchDLPoints,BatchDL.BDLPoints);
END;
Inc(RecNum);
END;
Close(BatchDLFile);
LastError := IOResult;
END;
IF Exist(General.DataPath+'BATCHUL.DAT') THEN
BEGIN
Assign(BatchULFile,General.DataPath+'BATCHUL.DAT');
Reset(BatchULFile);
RecNum := 1;
WHILE (RecNum <= FileSize(BatchULFile)) DO
BEGIN
Seek(BatchULFile,(RecNum - 1));
Read(BatchULFile,BatchUL);
IF (BatchUL.BULUserNum = UserNum) THEN
Inc(NumBatchULFiles);
Inc(RecNum);
END;
Close(BatchULFile);
LastError := IOResult;
END;
IF (NumBatchDLFiles > 0) AND (General.ForceBatchDL) THEN
REPEAT
NL;
Print('^4You must (^5D^4)ownload, (^5R^4)emove or (^5C^4)lear your batch queued files.');
NL;
Prt('Select option: ');
OneK(Cmd,'DRC',TRUE,TRUE);
CASE Cmd OF
'D' : BatchDownload;
'R' : RemoveBatchDLFiles;
'C' : ClearBatchDLQueue;
END;
UNTIL (NumBatchDLFiles = 0) OR (FileSysOp) OR (HangUp);
IF (NumBatchULFiles > 0) AND (General.ForceBatchUL) THEN
REPEAT
NL;
Print('^4You must (^5U^4)pload, (^5R^4)emove or (^5C^4)lear your batch queued files.');
NL;
Prt('Select option: ');
OneK(Cmd,'URC',TRUE,TRUE);
CASE Cmd OF
'U' : BatchUpload(FALSE,0);
'R' : RemoveBatchULFiles;
'C' : ClearBatchULQueue;
END;
UNTIL (NumBatchULFiles = 0) OR (FileSysOp) OR (HangUp);
BatchDLULInfo;
IF (LIL <> 0) THEN
PauseScr(FALSE);
NL;
Update_Screen;
END;
FindChopTime;
IF (SMW IN ThisUser.Flags) THEN
BEGIN
ReadShortMessage;
NL;
PauseScr(FALSE);
END;
IF ((Alert IN ThisUser.Flags) AND (SysOpAvailable)) THEN
ChatCall := TRUE;
IF (ThisUser.Waiting > 0) THEN
IF (RMsg IN ThisUser.Flags) THEN
ReadMail
ELSE
BEGIN
IF PYNQ('Read your private messages? ',0,TRUE) THEN
ReadMail;
END;
IF (General.PasswordChange > 0) THEN
IF ((DayNum(DateStr) - ThisUser.PasswordChanged) >= General.PasswordChange) THEN
BEGIN
PrintF('PWCHANGE');
IF (NoFile) THEN
BEGIN
NL;
Print('You must select a new password every '+IntToStr(General.PasswordChange)+' days.');
NL;
END;
CStuff(9,3,ThisUser);
END;
FastLogon := FALSE;
END;
PROCEDURE LogoffMaint;
VAR
HistoryFile: FILE OF HistoryRecordType;
LastCallerFile: FILE OF LastCallerRec;
History: HistoryRecordType;
LastCaller: LastCallerRec;
Counter: Integer;
TotTimeOn: LongInt;
BEGIN
Com_Flush_Send;
LoadNode(ThisNode);
WITH NodeR DO
BEGIN
User := 0;
UserName := '';
CityState := '';
Sex := 'M';
Age := 0;
LogonTime := 0;
GroupChat := FALSE;
ActivityDesc := '';
Status := [NActive];
Room := 0;
Channel := 0;
FillChar(Invited,SizeOf(Invited),0);
FillChar(Booted,SizeOf(Booted),0);
FillChar(Forget,SizeOf(Forget),0);
END;
SaveNode(ThisNode);
IF (UserNum > 0) THEN
BEGIN
PurgeDir(TempDir+'ARC\',FALSE);
PurgeDir(TempDir+'QWK\',FALSE);
PurgeDir(TempDir+'UP\',FALSE);
PurgeDir(TempDir+'CD\',FALSE);
SLogging := TRUE;
IF (Trapping) THEN
BEGIN
IF (HungUp) THEN
BEGIN
WriteLn(TrapFile);
WriteLn(TrapFile,'NO CARRIER');
END;
Close(TrapFile);
Trapping := FALSE;
END;
TotTimeOn := ((GetPackDateTime - TimeOn) DIV 60);
ThisUser.LastOn := GetPackDateTime;
Inc(ThisUser.LoggedOn);
ThisUser.Illegal := 0;
ThisUser.TTimeOn := (ThisUser.TTimeOn + TotTimeOn);
ThisUser.TLToday := (NSL DIV 60);
IF (ChopTime <> 0) THEN
Inc(ThisUser.TLToday,(ChopTime DIV 60));
ThisUser.LastMsgArea := MsgArea;
ThisUser.LastFileArea := FileArea;
IF ((UserNum >= 1) AND (UserNum <= (MaxUsers - 1))) THEN
SaveURec(ThisUser,UserNum);
IF (HungUp) THEN
SL1('^7-= Hung Up =-');
SL1('^4Read: ^3'+IntToStr(PublicReadThisCall)+'^4 / Time on: ^3'+IntToStr(TotTimeOn));
END;
LastError := IOResult;
SL1('^3Logoff node '+IntToStr(ThisNode)+' ^5'+'['+Dat+']');
Assign(HistoryFile,General.DataPath+'HISTORY.DAT');
Reset(HistoryFile);
IF (IOResult = 2) THEN
BEGIN
ReWrite(HistoryFile);
FillChar(History,SizeOf(History),0);
History.Date := Date2PD(DateStr);
END
ELSE
BEGIN
Seek(HistoryFile,(FileSize(HistoryFile) - 1));
Read(HistoryFile,History);
END;
Inc(History.Active,(GetPackDateTime - TimeOn) DIV 60);
IF (NOT LocalIOOnly) THEN
Inc(History.Callers);
IF (WasNewUser) THEN
Inc(History.NewUsers);
IF ((History.Posts + PublicPostsToday) < 2147483647) THEN
Inc(History.Posts,PublicPostsToday)
ELSE
History.Posts := 2147483647;
IF ((History.Email + PrivatePostsToday) < 2147483647) THEN
Inc(History.Email,PrivatePostsToday)
ELSE
History.Email := 2147483647;
IF ((History.FeedBack + FeedbackPostsToday) < 2147483647) THEN
Inc(History.FeedBack,FeedbackPostsToday)
ELSE
History.FeedBack := 2147483647;
IF ((History.Uploads + UploadsToday) < 2147483647) THEN
Inc(History.Uploads,UploadsToday)
ELSE
History.Uploads := 2147483647;
IF ((History.Downloads + DownloadsToday) < 2147483647) THEN
Inc(History.Downloads,DownloadsToday)
ELSE
History.Downloads := 2147483647;
IF ((History.UK + UploadKBytesToday) < 2147483647) THEN
Inc(History.UK,UploadKBytesToday)
ELSE
History.UK := 2147483647;
IF ((History.DK + DownloadKBytesToday) < 2147483647) THEN
Inc(History.DK,DownloadKBytesToday)
ELSE
History.DK := 2147483647;
IF (Exist(StartDir+'\CRITICAL.ERR')) THEN
BEGIN
Inc(History.Errors);
Kill(StartDir+'\CRITICAL.ERR');
END;
IF (ComPortSpeed <> 0) THEN
BEGIN
IF (ComportSpeed = 300) THEN
Inc(History.UserBaud[1])
ELSE IF (ComportSpeed = 600) THEN
Inc(History.UserBaud[2])
ELSE IF (ComportSpeed = 1200) THEN
Inc(History.UserBaud[3])
ELSE IF (ComportSpeed = 2400) THEN
Inc(History.UserBaud[4])
ELSE IF (ComportSpeed = 4800) THEN
Inc(History.UserBaud[5])
ELSE IF (ComportSpeed = 7200) THEN
Inc(History.UserBaud[6])
ELSE IF (ComportSpeed = 9600) THEN
Inc(History.UserBaud[7])
ELSE IF (ComportSpeed = 12000) THEN
Inc(History.UserBaud[8])
ELSE IF (ComportSpeed = 14400) THEN
Inc(History.UserBaud[9])
ELSE IF (ComportSpeed = 16800) THEN
Inc(History.UserBaud[10])
ELSE IF (ComportSpeed = 19200) THEN
Inc(History.UserBaud[11])
ELSE IF (ComportSpeed = 21600) THEN
Inc(History.UserBaud[12])
ELSE IF (ComportSpeed = 24000) THEN
Inc(History.UserBaud[13])
ELSE IF (ComportSpeed = 26400) THEN
Inc(History.UserBaud[14])
ELSE IF (ComportSpeed = 28800) THEN
Inc(History.UserBaud[15])
ELSE IF (ComportSpeed = 31200) THEN
Inc(History.UserBaud[16])
ELSE IF (ComportSpeed = 33600) THEN
Inc(History.UserBaud[17])
ELSE IF (ComportSpeed = 38400) THEN
Inc(History.UserBaud[18])
ELSE IF (ComportSpeed = 57600) THEN
Inc(History.UserBaud[19])
ELSE IF (ComportSpeed = 115200) THEN
Inc(History.UserBaud[20])
ELSE
Inc(History.UserBaud[0]);
END;
Seek(HistoryFile,(FileSize(HistoryFile) - 1));
Write(Historyfile,History);
Close(HistoryFile);
LastError := IOResult;
Assign(LastCallerFile,General.DataPath+'LASTON.DAT');
Reset(LastCallerFile);
IF (IOResult = 2) THEN
ReWrite(LastCallerFile);
FOR Counter := (FileSize(LastCallerFile) - 1) DOWNTO 0 DO
BEGIN
Seek(LastCallerFile,Counter);
Read(LastCallerFile,LastCaller);
IF (LastCaller.Node = ThisNode) AND (LastCaller.UserID = UserNum) THEN
WITH LastCaller DO
BEGIN
LogOffTime := GetPackDateTime;
Uploads := UploadsToday;
Downloads := DownloadsToday;
UK := UploadKBytesToday;
DK := DownloadKBytesToday;
MsgRead := PublicReadThisCall;
MsgPost := PublicPostsToday;
EmailSent := PrivatePostsToday;
FeedbackSent := FeedbackPostsToday;
Seek(LastCallerFile,Counter);
Write(LastCallerFile,LastCaller);
Break;
END;
END;
Close(LastCallerFile);
LastError := IOResult;
END;
PROCEDURE DailyMaint;
VAR
LastCallerFile: FILE OF LastCallerRec;
HistoryFile: FILE OF HistoryRecordType;
ShortMsgFile: FILE OF ShortMessageRecordType;
F: Text;
History: HistoryRecordType;
ShortMsg: ShortMessageRecordType;
TempStr: AStr;
Counter,
Counter1: Integer;
BEGIN
IF (Date2PD(General.LastDate) <> Date2PD(DateStr)) THEN
BEGIN
General.LastDate := DateStr;
SaveGeneral(FALSE);
(* Test code only *)
IF (NOT InWFCMenu) THEN
SysOpLog('Daily maintenance ran from Caller Logon.')
ELSE
SysOpLog('Daily maintenance ran from Waiting For Caller.');
(* End test code *)
IF (NOT InWFCMenu) THEN
lStatus_Screen(100,'Updating data files ...',FALSE,TempStr);
(* Test *)
IF Exist(General.DataPath+'LASTON.DAT') THEN
Kill(General.DataPath+'LASTON.DAT');
Assign(LastCallerFile,General.DataPath+'LASTON.DAT');
ReWrite(LastCallerFile);
Close(LastCallerFile);
Assign(ShortMsgFile,General.DataPath+'SHORTMSG.DAT');
Reset(ShortMsgFile);
IF (IOResult = 0) THEN
BEGIN
IF (FileSize(ShortMsgFile) >= 1) THEN
BEGIN
Counter := 0;
Counter1 := 0;
WHILE (Counter <= (FileSize(ShortMsgFile) - 1)) DO
BEGIN
Seek(ShortMsgFile,Counter);
Read(ShortMsgFile,ShortMsg);
IF (ShortMsg.Destin <> -1) THEN
IF (Counter = Counter1) THEN
Inc(Counter1)
ELSE
BEGIN
Seek(ShortMsgFile,Counter1);
Write(ShortMsgFile,ShortMsg);
Inc(Counter1);
END;
Inc(Counter);
END;
Seek(ShortMsgFile,Counter1);
Truncate(ShortMsgFile);
END;
Close(ShortMsgFile);
END;
LastError := IOResult;
Assign(HistoryFile,General.DataPath+'HISTORY.DAT');
IF NOT Exist(General.DataPath+'HISTORY.DAT') THEN
ReWrite(HistoryFile)
ELSE
BEGIN
Reset(HistoryFile);
Seek(HistoryFile,(FileSize(HistoryFile) - 1));
Read(HistoryFile,History);
Inc(General.DaysOnline);
Inc(General.TotalCalls,History.Callers);
Inc(General.TotalUsage,History.Active);
Inc(General.TotalPosts,History.Posts);
Inc(General.TotalDloads,History.Downloads);
Inc(General.TotalUloads,History.Uploads);
END;
IF (History.Date <> Date2PD(DateStr)) THEN
BEGIN
IF Exist(General.LogsPath+'SYSOP'+IntToStr(General.BackSysOpLogs)+'.LOG') THEN
Kill(General.LogsPath+'SYSOP'+IntToStr(General.BackSysOpLogs)+'.LOG');
FOR Counter := (General.BackSysOpLogs - 1) DOWNTO 1 DO
IF (Exist(General.LogsPath+'SYSOP'+IntToStr(Counter)+'.LOG')) THEN
BEGIN
Assign(F,General.LogsPath+'SYSOP'+IntToStr(Counter)+'.LOG');
Rename(F,General.LogsPath+'SYSOP'+IntToStr(Counter + 1)+'.LOG');
END;
SL1('');
SL1('Total mins active..: '+IntToStr(History.Active));
SL1('Percent of activity: '+SQOutSp(CTP(History.Active,1440))+' ('+IntToStr(History.Callers)+' calls)');
SL1('New users..........: '+IntToStr(History.NewUsers));
SL1('Public posts.......: '+IntToStr(History.Posts));
SL1('Private mail sent..: '+IntToStr(History.Email));
SL1('FeedBack sent......: '+IntToStr(History.FeedBack));
SL1('Critical errors....: '+IntToStr(History.Errors));
SL1('Downloads today....: '+IntToStr(History.Downloads)+'-'+ConvertKB(History.DK,FALSE));
SL1('Uploads today......: '+IntToStr(History.Uploads)+'-'+ConvertKB(History.UK,FALSE));
FillChar(History,SizeOf(History),0);
History.Date := Date2PD(DateStr);
Seek(HistoryFile,FileSize(HistoryFile));
Write(HistoryFile,History);
Close(HistoryFile);
IF (General.MultiNode) AND Exist(TempDir+'TEMPLOG.'+IntToStr(ThisNode)) THEN
BEGIN
Assign(F,General.LogsPath+'SYSOP.LOG');
Append(F);
IF (IOResult = 2) THEN
ReWrite(F);
Reset(SysOpLogFile);
WHILE NOT EOF(SysOpLogFile) DO
BEGIN
ReadLn(SysOpLogFile,TempStr);
WriteLn(F,TempStr);
END;
Close(SysOpLogFile);
Close(F);
Erase(SysOpLogFile);
END;
Assign(SysOpLogFile,General.LogsPath+'SYSOP.LOG');
Rename(SysOpLogFile,General.LogsPath+'SYSOP1.LOG');
Assign(SysOpLogFile,General.LogsPath+'SYSOP.LOG');
ReWrite(SysOpLogFile);
Close(SysOpLogFile);
SL1(^M^J' Renegade SysOp Log for '+DateStr+^M^J);
IF (General.MultiNode) THEN
Assign(SysOpLogFile,TempDir+'TEMPLOG.'+IntToStr(ThisNode))
ELSE
Assign(SysOpLogFile,General.LogsPath+'SYSOP.LOG');
Append(SysOpLogFile);
IF (IOResult = 2) THEN
ReWrite(SysOpLogFile);
Close(SysOpLogFile);
END
ELSE
Close(HistoryFile);
END;
END;
PROCEDURE UpdateGeneral;
VAR
HistoryFile: FILE OF HistoryRecordType;
History: HistoryRecordType;
Counter: LongInt;
BEGIN
Assign(HistoryFile,General.DataPath+'HISTORY.DAT');
Reset(HistoryFile);
IF (IOResult = 2) THEN
ReWrite(HistoryFile);
WITH General DO
BEGIN
DaysOnline := FileSize(HistoryFile);
TotalCalls := 0;
TotalUsage := 0;
TotalPosts := 0;
TotalDloads := 0;
TotalUloads := 0;
FOR Counter := 1 TO (FileSize(HistoryFile) - 1) DO
BEGIN
Read(HistoryFile,History);
Inc(TotalCalls,History.Callers);
Inc(TotalUsage,History.Active);
Inc(TotalPosts,History.Posts);
Inc(TotalDloads,History.Downloads);
Inc(TotalUloads,History.Uploads);
END;
IF (TotalUsage < 1) THEN
TotalUsage := 1;
IF (DaysOnline < 1) THEN
DaysOnline := 1;
END;
Close(HistoryFile);
LastError := IOResult;
SaveGeneral(FALSE);
IF (NOT InWFCMenu) THEN
BEGIN
NL;
Print('System averages have been updated.');
PauseScr(FALSE);
END;
END;
END.

1071
SOURCE/MENUS.PAS Normal file
View File

File diff suppressed because it is too large Load Diff

518
SOURCE/MENUS2.PAS Normal file
View File

@ -0,0 +1,518 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S+,V-}
UNIT Menus2;
INTERFACE
USES
Common;
PROCEDURE LoadMenu;
PROCEDURE ShowCmds(MenuOption: Str50);
FUNCTION OkSecurity(CmdToExec: Byte; VAR CmdNotHid: Boolean): Boolean;
PROCEDURE GenericMenu(ListType: Byte);
PROCEDURE ShowThisMenu;
IMPLEMENTATION
PROCEDURE LoadMenu;
VAR
Counter,
MenuNum: Integer;
TempCkeys: CHAR;
FoundMenu: Boolean;
BEGIN
IF (GlobalCmds > 0) THEN
Move(MemCmd^[((NumCmds - GlobalCmds) + 1)],MemCmd^[((MaxCmds - GlobalCmds) + 1)],(GlobalCmds * Sizeof(MemCmdRec)));
NumCmds := 0;
FoundMenu := FALSE;
Reset(MenuFile);
MenuNum := 1;
WHILE (MenuNum <= NumMenus) AND (NOT FoundMenu) DO
BEGIN
Seek(MenuFile,MenuRecNumArray[MenuNum]);
Read(MenuFile,MenuR);
IF (MenuR.MenuNum = CurMenu) THEN
BEGIN
FallBackMenu := MenuR.FallBack;
FoundMenu := TRUE;
END;
Inc(MenuNum);
END;
Dec(MenuNum);
IF (NOT FoundMenu) THEN
BEGIN
NL;
Print('That menu is missing, dropping to fallback ...');
SysOpLog('Menu #'+IntToStr(CurMenu)+' is missing - Dropping to FallBack #'+IntToStr(FallBackMenu));
IF (FallBackMenu > 0) THEN
BEGIN
FoundMenu := FALSE;
MenuNum := 1;
WHILE (MenuNum <= NumMenus) AND (NOT FoundMenu) DO
BEGIN
Seek(MenuFile,MenuRecNumArray[MenuNum]);
Read(MenuFile,MenuR);
IF (MenuR.MenuNum = FallBackMenu) THEN
BEGIN
CurMenu := FallBackMenu;
FallBackMenu := MenuR.FallBack;
FoundMenu := TRUE;
END;
Inc(MenuNum);
END;
Dec(MenuNum);
END;
IF (FallBackMenu = 0) OR (NOT FoundMenu) THEN
BEGIN
NL;
Print('Emergency System shutdown. Please call back later.');
NL;
Print('Critical error; hanging up.');
IF (FallBackMenu = 0) THEN
SysOpLog('FallBack menu is set to ZERO - Hung user up.')
ELSE
SysOpLog('FallBack #'+IntToStr(FallBackMenu)+' is MISSING - Hung user up.');
HangUp := TRUE;
END;
END;
IF (FoundMenu) THEN
BEGIN
Seek(MenuFile,MenuRecNumArray[MenuNum]);
Read(MenuFile,MenuR);
WITH MemMenu DO
BEGIN
FOR Counter := 1 TO 3 DO
LDesc[Counter] := MenuR.LDesc[Counter];
ACS := MenuR.ACS;
NodeActivityDesc := MenuR.NodeActivityDesc;
MenuFlags := MenuR.MenuFlags;
LongMenu := MenuR.LongMenu;
MenuNum := MenuR.MenuNum;
MenuPrompt := MenuR.MenuPrompt;
Password := MenuR.Password;
FallBack := MenuR.FallBack;
Directive := MenuR.Directive;
ForceHelpLevel := MenuR.ForceHelpLevel;
GenCols := MenuR.GenCols;
FOR Counter := 1 TO 3 DO
GCol[Counter] := MenuR.GCol[Counter];
END;
Update_Node(MemMenu.NodeActivityDesc,TRUE);
MQArea := FALSE;
FQArea := FALSE;
VQArea := FALSE;
RQArea := FALSE;
MenuKeys := '';
NumCmds := 1;
WHILE (NumCmds <= CmdNumArray[MenuNum]) DO
BEGIN
Read(MenuFile,MenuR);
WITH MemCmd^[NumCmds] DO
BEGIN
LDesc := MenuR.LDesc[1];
ACS := MenuR.ACS;
NodeActivityDesc := MenuR.NodeActivityDesc;
CmdFlags := MenuR.CmdFlags;
SDesc := MenuR.SDesc;
CKeys := MenuR.CKeys;
IF (CKeys = 'ENTER') THEN
TempCkeys := #13
ELSE IF (CKeys = 'UP_ARROW') THEN
TempCkeys := #255
ELSE IF (CKeys = 'DOWN_ARROW') THEN
TempCkeys := #254
ELSE IF (CKeys = 'LEFT_ARROW') THEN
TempCkeys := #253
ELSE IF (CKeys = 'RIGHT_ARROW') THEN
TempCkeys := #252
ELSE IF (Length(CKeys) > 1) THEN
TempCkeys := '/'
ELSE
TempCkeys := UpCase(CKeys[1]);
IF (Pos(TempCkeys,MenuKeys) = 0) THEN
MenuKeys := MenuKeys + TempCkeys;
CmdKeys := MenuR.CmdKeys;
IF (CmdKeys = 'M#') THEN
MQArea := TRUE
ELSE IF (CmdKeys = 'F#') THEN
FQArea := TRUE
ELSE IF (CmdKeys = 'V#') THEN
VQArea := TRUE
ELSE IF (CmdKeys = 'R#') THEN
RQArea := TRUE;
Options := MenuR.Options;
END;
Inc(NumCmds);
END;
END;
Dec(NumCmds);
Close(MenuFile);
LastError := IOResult;
IF (GlobalCmds > 0) THEN
BEGIN
Move(MemCmd^[((MaxCmds - GlobalCmds) + 1)],MemCmd^[(NumCmds + 1)],(GlobalCmds * Sizeof(MemCmdRec)));
Inc(NumCmds,GlobalCmds);
END;
END;
PROCEDURE ShowCmds(MenuOption: Str50);
VAR
TempStr,
TempStr1: AStr;
CmdToList,
Counter,
NumRows: Byte;
FUNCTION Type1(CTL: Byte): AStr;
BEGIN
Type1 := '^0'+PadRightInt(CTL,3)+
' ^3'+PadLeftStr(MemCmd^[CTL].CKeys,2)+
' ^3'+PadLeftStr(MemCmd^[CTL].CmdKeys,2)+
' '+PadLeftStr(MemCmd^[CTL].Options,15);
END;
BEGIN
IF (MenuOption = '') THEN
Exit;
IF (NumCmds = 0) THEN
Print('*** No commands on this menu ***')
ELSE
BEGIN
AllowAbort := TRUE;
MCIAllowed := FALSE;
Abort := FALSE;
Next := FALSE;
CLS;
NL;
CASE MenuOption[1] OF
'1' : BEGIN
PrintACR('^0###^4:^3KK ^4:^3CF^4:^3ACS ^4:^3CK^4:^3Options');
PrintACR('^4===:==============:==:==========:==:========================================');
CmdToList := 1;
WHILE (CmdToList <= NumCmds) AND (NOT Abort) AND (NOT HangUp) DO
BEGIN
PrintACR('^0'+PadRightInt(CmdToList,3)+
' ^3'+PadLeftStr(MemCmd^[CmdToList].CKeys,14)+
' '+AOnOff(Hidden IN MemCmd^[CmdToList].CmdFlags,'H','-')+
AOnOff(UnHidden IN MemCmd^[CmdToList].CmdFlags,'U','-')+
' ^9'+PadLeftStr(MemCmd^[CmdToList].ACS,10)+
' ^3'+PadLeftStr(MemCmd^[CmdToList].CmdKeys,2)+
' '+PadLeftStr(MemCmd^[CmdToList].Options,40));
Inc(CmdToList);
END;
END;
'2' : BEGIN
NumRows := ((NumCmds + 2) DIV 3);
TempStr := '^0###^4:^3KK^4:^3CK^4:^3Options ';
TempStr1 := '^4===:==:==:===============';
CmdToList := 1;
WHILE (CmdToList <= NumRows) AND (CmdToList < 3) DO
BEGIN
TempStr := TempStr+' ^0###^4:^3KK^4:^3CK^4:^3Options ';
TempStr1 := TempStr1 + ' ^4===:==:==:===============';
Inc(CmdToList);
END;
PrintACR(TempStr);
PrintACR(TempStr1);
CmdToList := 0;
REPEAT
Inc(CmdToList);
TempStr := Type1(CmdToList);
FOR Counter := 1 TO 2 DO
IF ((CmdToList + (Counter * NumRows)) <= NumCmds) THEN
TempStr := TempStr + ' '+Type1(CmdToList + (Counter * NumRows));
PrintACR('^1'+TempStr);
UNTIL ((CmdToList >= NumRows) OR (Abort) OR (HangUp));
END;
END;
AllowAbort := FALSE;
MCIAllowed := TRUE;
END;
END;
FUNCTION OkSecurity(CmdToExec: Byte; VAR CmdNotHid: Boolean): Boolean;
BEGIN
OkSecurity := FALSE;
IF (UnHidden IN MemCmd^[CmdToExec].CmdFlags) THEN
CmdNotHid := TRUE;
IF (NOT AACS(MemCmd^[CmdToExec].ACS)) THEN
EXIT;
OkSecurity := TRUE;
END;
PROCEDURE GenericMenu(ListType: Byte);
VAR
GColors: ARRAY [1..3] OF Byte;
Counter,
ColSiz,
NumCols: Byte;
FUNCTION GenColored(CONST Keys: AStr; Desc: AStr; Acc: Boolean): AStr;
VAR
j: Byte;
BEGIN
j := Pos(AllCaps(Keys),AllCaps(Desc));
IF (j <> 0) AND (Pos('^',Desc) = 0) THEN
BEGIN
Insert('^'+IntToStr(GColors[3]),Desc,((j + Length(Keys) + 1)));
Insert('^'+IntToStr(GColors[1]),Desc,j + Length(Keys));
IF (acc) THEN
Insert('^'+IntToStr(GColors[2]),Desc,j);
IF (j <> 1) THEN
Insert('^'+IntToStr(GColors[1]),Desc,j - 1);
END;
GenColored := '^'+IntToStr(GColors[3])+Desc;
END;
FUNCTION TCentered(c: Integer; CONST s: AStr): AStr;
CONST
SpaceStr = ' ';
BEGIN
c := (c DIV 2) - (LennMCI(s) DIV 2);
IF (c < 1) THEN
c := 0;
TCentered := Copy(SpaceStr,1,c) + s;
END;
PROCEDURE NewGColors(CONST S: STRING);
VAR
TempStr: STRING;
BEGIN
TempStr := SemiCmd(s,1);
IF (TempStr <> '') THEN
GColors[1] := StrToInt(TempStr);
TempStr := SemiCmd(s,2);
IF (TempStr <> '') THEN
GColors[2] := StrToInt(TempStr);
TempStr := SemiCmd(s,3);
IF (TempStr <> '') THEN
GColors[3] := StrToInt(TempStr);
END;
PROCEDURE GetMaxRight(VAR MaxRight: Byte);
VAR
CmdToList,
Len,
Onlin: Byte;
TempStr: AStr;
BEGIN
MaxRight := 0;
OnLin := 0;
TempStr := '';
FOR CmdToList := 1 TO NumCmds DO
IF (MemCmd^[CmdToList].CKeys <> 'GTITLE') THEN
BEGIN
Inc(OnLin);
IF (OnLin <> NumCols) THEN
TempStr := TempStr + PadLeftStr(MemCmd^[CmdToList].SDesc,ColSiz)
ELSE
BEGIN
TempStr := TempStr + MemCmd^[CmdToList].SDesc;
OnLin := 0;
Len := LennMCI(TempStr);
IF (Len > MaxRight) THEN
MaxRight := Len;
TempStr := '';
END;
END
ELSE
BEGIN
TempStr := '';
OnLin := 0;
END;
END;
PROCEDURE DoMenuTitles(MaxRight: Byte);
VAR
Counter1: Byte;
ShownAlready: Boolean;
BEGIN
IF (ClrScrBefore IN MemMenu.MenuFlags) THEN
BEGIN
CLS;
NL;
NL;
END;
IF (NOT (NoMenuTitle IN MemMenu.MenuFlags)) THEN
BEGIN
ShownAlready := FALSE;
FOR Counter1 := 1 TO 3 DO
IF (MemMenu.LDesc[Counter1] <> '') THEN
BEGIN
IF (NOT ShownAlready) THEN
BEGIN
NL;
ShownAlready := TRUE;
END;
IF (DontCenter IN MemMenu.MenuFlags) THEN
PrintACR(MemMenu.LDesc[Counter1])
ELSE
PrintACR(TCentered(MaxRight,MemMenu.LDesc[Counter1]));
END;
END;
NL;
END;
PROCEDURE GenTuto;
VAR
CmdToList,
MaxRight: Byte;
Acc,
CmdNotHid: Boolean;
BEGIN
Abort := FALSE;
Next := FALSE;
GetMaxRight(MaxRight);
DoMenuTitles(MaxRight);
IF (NoGlobalDisplayed IN MemMenu.MenuFlags) OR (NoGlobalUsed IN MemMenu.MenuFlags) THEN
Dec(NumCmds,GlobalCmds);
CmdToList := 0;
WHILE (CmdToList < NumCmds) AND (NOT Abort) AND (NOT HangUp) DO
BEGIN
Inc(CmdToList);
CmdNotHid := FALSE;
Acc := OkSecurity(CmdToList,CmdNotHid);
IF (((Acc) OR (UnHidden IN MemCmd^[CmdToList].CmdFlags)) AND (NOT (Hidden IN MemCmd^[CmdToList].CmdFlags))) THEN
IF (MemCmd^[CmdToList].CKeys = 'GTITLE') THEN
BEGIN
PrintACR(MemCmd^[CmdToList].LDesc);
IF (MemCmd^[CmdToList].Options <> '') THEN
NewGColors(MemCmd^[CmdToList].Options);
END
ELSE IF (MemCmd^[CmdToList].LDesc <> '') THEN
PrintACR(GenColored(MemCmd^[CmdToList].CKeys,MemCmd^[CmdToList].LDesc,Acc));
END;
IF (NoGlobalDisplayed IN MemMenu.MenuFlags) OR (NoGlobalUsed IN MemMenu.MenuFlags) THEN
Inc(NumCmds,GlobalCmds);
END;
PROCEDURE GenNorm;
VAR
TempStr,
TempStr1: AStr;
CmdToList,
Onlin,
MaxRight: Byte;
Acc,
CmdNotHid: Boolean;
BEGIN
TempStr1 := '';
OnLin := 0;
TempStr := '';
Abort := FALSE;
Next := FALSE;
GetMaxRight(MaxRight);
DoMenuTitles(MaxRight);
IF (NoGlobalDisplayed IN MemMenu.MenuFlags) OR (NoGlobalUsed IN MemMenu.MenuFlags) THEN
Dec(NumCmds,GlobalCmds);
CmdToList := 0;
WHILE (CmdToList < NumCmds) AND (NOT Abort) AND (NOT HangUp) DO
BEGIN
Inc(CmdToList);
CmdNotHid := FALSE;
Acc := OkSecurity(CmdToList,CmdNotHid);
IF (((Acc) OR (UnHidden IN MemCmd^[CmdToList].CmdFlags)) AND (NOT (Hidden IN MemCmd^[CmdToList].CmdFlags))) THEN
BEGIN
IF (MemCmd^[CmdToList].CKeys = 'GTITLE') THEN
BEGIN
IF (OnLin <> 0) THEN
PrintACR(TempStr);
PrintACR(TCentered(MaxRight,MemCmd^[CmdToList].LDesc));
TempStr := '';
OnLin := 0;
IF (MemCmd^[CmdToList].Options <> '') THEN
NewGColors(MemCmd^[CmdToList].Options);
END
ELSE
BEGIN
IF (MemCmd^[CmdToList].SDesc <> '') THEN
BEGIN
Inc(OnLin);
TempStr1 := GenColored(MemCmd^[CmdToList].CKeys,MemCmd^[CmdToList].SDesc,Acc);
IF (OnLin <> NumCols) THEN
TempStr1 := PadLeftStr(TempStr1,ColSiz);
TempStr := TempStr + TempStr1;
END;
IF (OnLin = NumCols) THEN
BEGIN
OnLin := 0;
PrintACR(TempStr);
TempStr := '';
END;
END;
END;
END;
IF (NoGlobalDisplayed IN MemMenu.MenuFlags) OR (NoGlobalUsed IN MemMenu.MenuFlags) THEN
Inc(NumCmds,GlobalCmds);
IF (OnLin > 0) THEN
PrintACR(TempStr);
END;
BEGIN
FOR Counter := 1 TO 3 DO
GColors[Counter] := MemMenu.GCol[Counter];
NumCols := MemMenu.GenCols;
CASE NumCols OF
2 : ColSiz := 39;
3 : ColSiz := 25;
4 : ColSiz := 19;
5 : ColSiz := 16;
6 : ColSiz := 12;
7 : ColSiz := 11;
END;
IF ((NumCols * ColSiz) >= ThisUser.LineLen) THEN
NumCols := (ThisUser.LineLen DIV ColSiz);
DisplayingMenu := TRUE;
IF (ListType = 2) THEN
GenNorm
ELSE
GenTuto;
DisplayingMenu := FALSE;
END;
PROCEDURE ShowThisMenu;
VAR
TempStr: AStr;
BEGIN
CASE CurHelpLevel OF
2 : BEGIN
DisplayingMenu := TRUE;
NoFile := TRUE;
TempStr := MemMenu.Directive;
IF (TempStr <> '') THEN
BEGIN
IF (Pos('@S',TempStr) > 0) THEN
PrintF(Substitute(TempStr,'@S',IntToStr(ThisUser.SL)));
IF (NoFile) THEN
PrintF(Substitute(TempStr,'@S',''));
END;
DisplayingMenu := FALSE;
END;
3 : BEGIN
DisplayingMenu := TRUE;
NoFile := TRUE;
TempStr := MemMenu.LongMenu;
IF (TempStr <> '') THEN
BEGIN
IF (Pos('@C',TempStr) <> 0) THEN
PrintF(Substitute(TempStr,'@C',CurrentConf));
IF (NoFile) AND (Pos('@S',TempStr) <> 0) THEN
PrintF(Substitute(TempStr,'@S',IntToStr(ThisUser.SL)));
IF (NoFile) THEN
PrintF(Substitute(TempStr,'@S',''));
END;
DisplayingMenu := FALSE;
END;
END;
IF ((NoFile) AND (CurHelpLevel IN [2,3])) THEN
GenericMenu(CurHelpLevel);
END;
END.

97
SOURCE/MENUS3.PAS Normal file
View File

@ -0,0 +1,97 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D-,E-,F+,I-,L-,N-,O+,R-,S+,V-}
UNIT Menus3;
INTERFACE
USES
Common;
PROCEDURE DoChangeMenu(VAR Done: BOOLEAN; VAR NewMenuCmd: ASTR; Cmd: CHAR; CONST MenuOption: Str50);
IMPLEMENTATION
PROCEDURE DoChangeMenu(VAR Done: BOOLEAN; VAR NewMenuCmd: ASTR; Cmd: CHAR; CONST MenuOption: Str50);
VAR
TempStr,
TempStr1: ASTR;
BEGIN
CASE Cmd OF
'^' : BEGIN
TempStr1 := MenuOption;
IF (Pos(';',TempStr1) <> 0) THEN
TempStr1 := Copy(TempStr1,1,(Pos(';',TempStr1) - 1));
IF (MenuOption <> '') THEN
BEGIN
TempStr := MenuOption;
IF (Pos(';',TempStr) <> 0) THEN
TempStr := Copy(TempStr,(Pos(';',TempStr) + 1),Length(TempStr));
IF (UpCase(TempStr[1]) = 'C') THEN
MenuStackPtr := 0;
IF (Pos(';',TempStr) = 0) OR (Length(TempStr) = 1) THEN
TempStr := ''
ELSE
TempStr := Copy(TempStr,(Pos(';',TempStr) + 1),Length(TempStr));
END;
IF (TempStr1 <> '') THEN
BEGIN
CurMenu := StrToInt(TempStr1);
IF (TempStr <> '') THEN
NewMenuCmd := AllCaps(TempStr);
Done := TRUE;
NewMenuToLoad := TRUE;
END;
END;
'/' : BEGIN
TempStr1 := MenuOption;
IF (Pos(';',TempStr1) <> 0) THEN
TempStr1 := Copy(TempStr1,1,Pos(';',TempStr1) - 1);
IF ((MenuOption <> '') AND (MenuStackPtr <> MaxMenus)) THEN
BEGIN
TempStr := MenuOption;
IF (Pos(';',TempStr) <> 0) THEN
TempStr := Copy(TempStr,(Pos(';',TempStr) + 1),Length(TempStr));
IF (UpCase(TempStr[1]) = 'C') THEN
MenuStackPtr := 0;
IF (Pos(';',TempStr) = 0) OR (Length(TempStr) = 1) THEN
TempStr := ''
ELSE
TempStr := Copy(TempStr,(Pos(';',TempStr) + 1),Length(TempStr));
IF (CurMenu <> StrToInt(TempStr1)) THEN
BEGIN
Inc(MenuStackPtr);
MenuStack[MenuStackPtr] := CurMenu;
END
ELSE
TempStr1 := '';
END;
IF (TempStr1 <> '') THEN
BEGIN
CurMenu := StrToInt(TempStr1);
IF (TempStr <> '') THEN
NewMenuCmd := AllCaps(TempStr);
Done := TRUE;
NewMenuToLoad := TRUE;
END;
END;
'\' : BEGIN
IF (MenuStackPtr <> 0) THEN
BEGIN
CurMenu := MenuStack[MenuStackPtr];
Dec(MenuStackPtr);
END;
IF (UpCase(MenuOption[1]) = 'C') THEN
MenuStackPtr := 0;
IF (Pos(';',MenuOption) <> 0) THEN
NewMenuCmd := AllCaps(Copy(MenuOption,(Pos(';',MenuOption) + 1),Length(MenuOption)));
Done := TRUE;
NewMenuToLoad := TRUE;
END;
END;
END;
END.

1
SOURCE/MISC/ONELE.ANS Normal file
View File

@ -0,0 +1 @@
%LF ﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄ ﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄ ﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄ%LF

1
SOURCE/MISC/ONELE.ASC Normal file
View File

@ -0,0 +1 @@
%LF |15ﾄﾄﾄ |07ﾄﾄ ﾄﾄ ﾄﾄ|08ﾄﾄﾄ ﾄﾄ ﾄﾄ ﾄ |03ﾄﾄ ﾄﾄ ﾄ ﾄ |11ﾄﾄ ﾄ ﾄ ﾄﾄ |03ﾄﾄ ﾄﾄ ﾄ ﾄ |08ﾄﾄﾄ ﾄﾄ ﾄﾄ|07 ﾄﾄﾄ ﾄﾄ |15ﾄﾄ ﾄﾄ%LF

7
SOURCE/MISC/ONELH.ANS Normal file
View File

@ -0,0 +1,7 @@
[?7hﾛﾛﾛﾛﾛﾛﾛﾟﾟﾟﾟﾟﾟﾟﾟﾟﾟﾟﾟﾟﾟﾟﾟﾟﾟﾟﾟﾟﾟ ﾟﾟﾛﾛﾛ ﾟﾟﾟﾟﾟﾟﾟﾟﾟﾟﾟﾟﾟﾟﾟﾟﾟﾟﾟﾟﾟﾟﾟﾟﾟﾟﾟﾟﾟﾟﾟﾟﾟﾟﾟﾛﾛﾛﾛﾛﾛﾛ
ﾟﾟﾟﾟﾟﾟﾟﾟ ｲｲﾛﾛﾛﾛﾛ ｲｲﾛﾛﾛﾛﾛ ｲｲﾛﾛﾛﾛ ｲﾛﾛ ｲﾛﾛ ｲｲﾛﾛﾛﾛﾛ ｲｲﾛﾛﾛﾛ ｲｲﾛﾛﾛﾛﾛ ｲｲﾛﾛﾛﾛ ﾟﾟﾟﾟﾟﾟﾟﾟ
ﾛﾛﾛﾛﾛﾛﾛﾛ ｲﾛﾛﾛﾛﾛﾛ ｲﾛﾛﾛﾛﾛﾛ ｲﾛﾛﾛ ﾟ ﾛﾛﾛ ﾛﾛﾛ ｲﾛﾛﾛﾛﾛﾛ ｲﾛﾛﾛ ﾟ ｲﾛﾛﾟﾛﾛﾛ ｲﾛﾛﾛ ﾟ ﾛﾛﾛﾛﾛﾛﾛﾛ
ﾛﾛﾛﾛﾛﾛﾛﾛ ﾛﾛﾛ ﾛﾛﾛ ﾛﾛﾛ ﾛﾛﾛ ﾛﾛﾛﾛﾛ ﾛﾛﾛ ﾛﾛﾛ ﾛﾛﾛ ﾛﾛﾛ ﾛﾛﾛﾛﾛ ﾛﾛﾛﾛﾛﾛﾛ ﾛﾛﾛﾛﾛﾛ ﾛﾛﾛﾛﾛﾛﾛﾛ
ﾛﾛﾛﾛﾛﾛﾛﾛ ﾛﾛﾛﾛﾛﾛﾛ ﾛﾛﾛ ﾛﾛﾛ ﾛﾛﾛﾛ ﾜ ﾛﾛﾛ ﾛﾛﾛ ﾛﾛﾛ ﾛﾛﾛ ﾛﾛﾛﾛ ﾜ ﾛﾛﾛ ﾛﾛ ﾜ ﾛﾛﾛﾛ ﾛﾛﾛﾛﾛﾛﾛﾛ
ﾜﾜﾜﾜﾜﾜﾜﾜ ﾛﾛﾛﾛﾛｲﾛ ﾛﾛﾛ ﾛｲﾛ ﾛﾛﾛﾛﾛｲ ﾛﾟﾛ ﾛﾟﾛ ﾛﾛﾛ ﾛｲﾛ ﾛﾛﾛﾛﾛｲ ﾛｲﾛ ﾛﾛｲ ﾛﾛﾛﾛﾛｰ ﾜﾜﾜﾜﾜﾜﾜﾜ
ﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄ ﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄ ﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄ%LF

12
SOURCE/MISC/ONELH.ASC Normal file
View File

@ -0,0 +1,12 @@
ﾛﾛﾛﾛﾛﾛ
ﾛﾛﾛﾟﾟﾟ ﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄ
ﾟﾟﾟ ﾜﾛﾛﾛﾟﾟﾛﾛﾛﾜ ﾟﾞﾛﾛﾛﾟﾛﾛﾛﾜ ﾜﾛﾛﾛﾟﾛﾛﾛﾛ ﾛﾛﾛﾛ ﾛﾛﾛﾛ ﾟﾞﾛﾛﾛﾟﾛﾛﾛﾜ ﾜﾛﾛﾛﾟﾛﾛﾛﾛ
ｰ ﾞﾛﾛﾛﾝ ﾞﾛﾛﾛﾝ ﾛﾛﾛﾛ ﾞﾛﾛﾛﾝ ﾞﾛﾛﾛﾝ ﾛﾛﾛﾛ ﾛﾛﾛﾛ ﾛﾛﾛﾛ ﾛﾛﾛﾛ ﾞﾛﾛﾛﾝ ﾞﾛﾛﾛﾝ ﾛﾛﾛﾛ ｰ
ﾟﾛ ｰｰﾛﾛ ﾛﾛｰｰ ﾛﾛﾛｰ ﾛﾛｰｰ ｰｰﾛﾛﾜﾜﾛﾛﾛﾛ ﾛﾛﾛｰ ﾛﾛﾛｰ ﾛﾛﾛｰ ﾛﾛｰｰ ｰｰﾛﾛﾜﾜﾛﾛﾛﾛ ﾟﾟﾛ
ﾛ ｱｱｰﾛ ﾛｰｱｱ ﾛｰｰｱ ﾛｰｱｱ ｱｱｰﾛ ﾜﾜﾜﾜ ﾛｰｰｱ ﾛｰｰｱ ﾛｰｰｱ ﾛｰｱｱ ｱｱｰﾛ ﾜﾜﾜﾜ ﾛ
ﾛﾜﾜﾞｲｱｱﾝ ﾞｱｱｲﾝ ｰｱｲｲ ﾞｱｱｲﾝ ﾞｲｱｱﾝ ﾛﾛｰﾛ ｰｱｲｲ ｰｱｲｲ ｰｱｲｲ ﾞｱｱｲﾝ ﾞｲｱｱﾝ ﾛﾛｰﾛ rlﾛ
ｰ ﾟﾛﾛﾛﾜﾜﾛﾛﾛﾟ ｲｲﾛﾛ ﾛﾛﾛﾟ ﾟﾛﾛﾛﾜｲｱｱｰ ｲｲﾛﾛﾜﾜ ｲｲﾛﾛ ｲｲﾛﾛ ﾛﾛﾛﾟ ﾟﾛﾛﾛﾜｲｱｱｰ v!ｰ
ﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄﾄ ﾜﾜﾜﾜﾛﾛ
ﾛﾛﾛﾛﾛﾛ

1
SOURCE/MISC/ONELM.ASC Normal file
View File

@ -0,0 +1 @@
|03~OL |11 ... |15~UN{16%LF

266
SOURCE/MISCUSER.PAS Normal file
View File

@ -0,0 +1,266 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S+,V-}
UNIT MiscUser;
INTERFACE
USES
Common;
PROCEDURE lFindUserWS(VAR UserNum: Integer);
PROCEDURE ChangeARFlags(MenuOption: Str50);
PROCEDURE ChangeACFlags(MenuOption: Str50);
PROCEDURE FindUser(VAR UserNum: Integer);
PROCEDURE InsertIndex(uname: AStr; UserNum: Integer; IsReal,IsDeleted: Boolean);
IMPLEMENTATION
USES
Dos;
PROCEDURE lFindUserWS(VAR UserNum: Integer);
VAR
User: UserRecordType;
UserIDX: UserIDXRec;
UserName: AStr;
Cmd: Char;
Counter,
NumIDX: Integer;
Done,
Asked: Boolean;
BEGIN
MPL(36);
Input(UserName,36);
IF (UserName = 'SYSOP') THEN
UserName := '1';
UserNum := StrToInt(UserName);
IF (UserNum > 0) THEN
BEGIN
IF (UserNum > (MaxUsers - 1)) THEN
BEGIN
NL;
Print('Unknown user.');
UserNum := 0
END
ELSE
LoadURec(User,UserNum);
END
ELSE IF (UserName = '') THEN
BEGIN
NL;
Print('Aborted.');
END
ELSE
BEGIN
Done := FALSE;
Asked := FALSE;
UserNum := SearchUser(UserName,CoSysOp);
IF (UserNum > 0) THEN
Exit;
Reset(UserIDXFile);
Counter := 0;
NumIDX := FileSize(UserIDXFile);
WHILE (Counter < NumIDX) AND (NOT Done) DO
BEGIN
Read(UserIDXFile,UserIDX);
Inc(Counter);
IF NOT (UserIDX.Deleted) AND (Pos(UserName,UserIDX.Name) <> 0) AND ((NOT UserIDX.RealName) OR (CoSysOp)) THEN
IF ((UserIDX.Name = UserName) OR (CoSysOp AND (UserIDX.Name = UserName))) AND (UserIDX.number <= (MaxUsers - 1)) THEN
UserNum := UserIDX.Number
ELSE
BEGIN
IF (NOT Asked) THEN
BEGIN
NL;
Asked := TRUE;
END;
Prompt('^1Did you mean ^3'+Caps(UserIDX.Name)+'^1? ');
OneK(Cmd,'QYN'^M,TRUE,TRUE);
Done := TRUE;
CASE Cmd OF
'Q' : UserNum := -1;
'Y' : UserNum := UserIDX.Number;
ELSE
Done := FALSE;
END;
END;
END;
Close(UserIDXFile);
IF (UserNum = 0) THEN
BEGIN
NL;
Print('User not found.');
END;
IF (UserNum = -1) THEN
UserNum := 0;
END;
LastError := IOResult;
END;
PROCEDURE ChangeARFlags(MenuOption: Str50);
VAR
Counter: Byte;
Changed: Boolean;
BEGIN
MenuOption := AllCaps(MenuOption);
FOR Counter := 1 TO (Length(MenuOption) - 1) DO
CASE MenuOption[Counter] OF
'+' : IF (MenuOption[Counter + 1] IN ['A'..'Z']) THEN
Include(ThisUser.AR,MenuOption[Counter + 1]);
'-' : IF (MenuOption[Counter + 1] IN ['A'..'Z']) THEN
Exclude(ThisUser.AR,MenuOption[Counter + 1]);
'!' : IF (MenuOption[Counter + 1] IN ['A'..'Z']) THEN
ToggleARFlag((MenuOption[Counter + 1]),ThisUser.AR,Changed);
END;
NewCompTables;
Update_Screen;
END;
PROCEDURE ChangeACFlags(MenuOption: Str50);
VAR
Counter: Byte;
Changed: Boolean;
BEGIN
MenuOption := AllCaps(MenuOption);
FOR Counter := 1 TO (Length(MenuOption) - 1) DO
CASE MenuOption[Counter] OF
'+' : Include(ThisUser.Flags,TACCH(MenuOption[Counter + 1]));
'-' : Exclude(ThisUser.Flags,TACCH(MenuOption[Counter + 1]));
'!' : ToggleACFlags(MenuOption[Counter + 1],ThisUser.Flags,Changed);
END;
NewCompTables;
Update_Screen;
END;
PROCEDURE FindUser(VAR UserNum: Integer);
VAR
User: UserRecordType;
TempUserName: Str36;
TempUserNum: Integer;
BEGIN
UserNum := 0;
TempUserName := '';
Input(TempUserName,36);
IF (TempUserName = 'NEW') THEN
BEGIN
UserNum := -1;
Exit;
END;
IF (TempUserName = '?') THEN
Exit;
WHILE (Pos(' ',TempUserName) <> 0) DO
Delete(TempUserName,Pos(' ',TempUserName),1);
WHILE (TempUserName[1] = ' ') AND (Length(TempUserName) > 0) DO
Delete(TempUserName,1,1);
IF (TempUserName = '') OR (HangUp) THEN
Exit;
UserNum := StrToInt(TempUserName);
IF (UserNum <> 0) THEN
BEGIN
IF (UserNum < 0) OR (UserNum > (MaxUsers - 1)) THEN
UserNum := 0
ELSE
BEGIN
LoadURec(User,UserNum);
IF (Deleted IN User.SFlags) THEN
UserNum := 0;
END;
END
ELSE IF (TempUserName <> '') THEN
BEGIN
TempUserNum := SearchUser(TempUserName,TRUE);
IF (TempUserNum <> 0) THEN
BEGIN
LoadURec(User,TempUserNum);
IF (NOT (Deleted IN User.SFlags)) THEN
UserNum := TempUserNum
ELSE
UserNum := 0;
END;
END;
END;
PROCEDURE InsertIndex(Uname: AStr; UserNum: Integer; IsReal,IsDeleted: Boolean);
VAR
UserIDX: UserIDXRec;
Current,
InsertAt: Integer;
SFO,
Done: Boolean;
PROCEDURE WriteIndex;
BEGIN
WITH UserIDX DO
BEGIN
FillChar(UserIDX,SizeOf(UserIDX),0);
Name := Uname;
Number := UserNum;
RealName := IsReal;
Deleted := IsDeleted;
Left := -1;
Right := -1;
Write(UserIDXFile,UserIDX);
END
END;
BEGIN
Done := FALSE;
Uname := AllCaps(Uname);
Current := 0;
SFO := (FileRec(UserIDXFile).Mode <> FMClosed);
IF (NOT SFO) THEN
Reset(UserIDXFile);
IF (FileSize(UserIDXFile) = 0) THEN
WriteIndex
ELSE
REPEAT
Seek(UserIDXFile,Current);
InsertAt := Current;
Read(UserIDXFile,UserIDX);
IF (Uname < UserIDX.Name) THEN
Current := UserIDX.Left
ELSE IF (Uname > UserIDX.Name) THEN
Current := UserIDX.Right
ELSE IF (UserIDX.Deleted <> IsDeleted) THEN
BEGIN
Done := TRUE;
UserIDX.Deleted := IsDeleted;
UserIDX.RealName := IsReal;
UserIDX.Number := UserNum;
Seek(UserIDXFile,Current);
Write(UserIDXFile,UserIDX);
END
ELSE
BEGIN
IF (UserNum <> UserIDX.Number) THEN
SysOpLog('Note: Duplicate user '+UName+' #'+IntToStr(UserIDX.Number)+' and '+UName+' #'+IntToStr(UserNum))
ELSE
BEGIN
UserIDX.RealName := FALSE;
Seek(UserIDXFile,Current); { Make it be his handle IF it's BOTH }
Write(UserIDXFile,UserIDX);
END;
Done := TRUE;
END;
UNTIL (Current = -1) OR (Done);
IF (Current = -1) THEN
BEGIN
IF (Uname < UserIDX.Name) THEN
UserIDX.Left := FileSize(UserIDXFile)
ELSE
UserIDX.Right := FileSize(UserIDXFile);
Seek(UserIDXFile,InsertAt);
Write(UserIDXFile,UserIDX);
Seek(UserIDXFile,FileSize(UserIDXFile));
WriteIndex;
END;
IF (NOT SFO) THEN
Close(UserIDXFile);
LastError := IOResult;
END;
END.

242
SOURCE/MSGPACK.PAS Normal file
View File

@ -0,0 +1,242 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D-,E-,F+,I-,L-,N-,O+,R-,S+,V-}
UNIT MsgPack;
INTERFACE
USES
Common;
PROCEDURE DoShowPackMessageAreas;
PROCEDURE PackMessageAreas;
IMPLEMENTATION
USES
Mail0;
PROCEDURE PackMessageArea(FN: Astr; MaxM: LongInt);
VAR
Buffer: ARRAY [1..4096] OF Char;
MsgHdrF1,
MsgHdrF2: FILE OF MheaderRec;
BrdF1,
BrdF2: FILE;
MHeader: MheaderRec;
Numm,
i,
IDX,
TotLoad,
Buffered: Word;
NeedPack: Boolean;
PROCEDURE OhShit;
BEGIN
SysOpLog('Error renaming temp files while packing.');
END;
BEGIN
NeedPack := FALSE;
FN := AllCaps(FN);
FN := General.MsgPath + FN;
Assign(BrdF1,FN+'.DAT');
Reset(BrdF1,1);
IF (IOResult <> 0) THEN
Exit;
Assign(MsgHdrF1,FN+'.HDR');
Reset(MsgHdrF1);
IF (IOResult <> 0) THEN
BEGIN
Close(BrdF1);
Exit
END;
IF (MaxM <> 0) AND (FileSize(MsgHdrF1) > MaxM) THEN
BEGIN
Numm := 0;
IDX := FileSize(MsgHdrF1);
WHILE (IDX > 0) DO
BEGIN
Seek(MsgHdrF1,(IDX - 1));
Read(MsgHdrF1,MHeader);
IF NOT (MDeleted IN MHeader.Status) THEN
Inc(Numm);
IF (Numm > MaxM) AND NOT (Permanent IN MHeader.Status) THEN
BEGIN
MHeader.Status := [MDeleted];
Seek(MsgHdrF1,(IDX - 1));
Write(MsgHdrF1,MHeader);
END;
Dec(IDX);
END;
END
ELSE
BEGIN
WHILE (FilePos(MsgHdrF1) < FileSize(MsgHdrF1)) AND (NOT NeedPack) DO
BEGIN
Read(MsgHdrF1,MHeader);
IF (MDeleted IN MHeader.Status) THEN
NeedPack := TRUE;
END;
IF (NOT NeedPack) THEN
BEGIN
Close(MsgHdrF1);
Close(BrdF1);
Exit;
END;
END;
LastError := IOResult;
Assign(BrdF2,FN+'.DA1');
ReWrite(BrdF2,1);
Assign(MsgHdrF2,FN+'.HD2');
ReWrite(MsgHdrF2);
Kill(FN+'.HD3');
Kill(FN+'.DA3');
LastError := IOResult;
IDX := 1;
i := 0;
WHILE (i <= FileSize(MsgHdrF1) - 1) DO
BEGIN
Seek(MsgHdrF1,i);
Read(MsgHdrF1,MHeader);
IF (MHeader.Pointer - 1 + MHeader.TextSize > FileSize(BrdF1)) OR
(MHeader.Pointer < 1) THEN
MHeader.Status := [MDeleted];
IF NOT (MDeleted IN MHeader.Status) THEN
BEGIN
Inc(IDX);
Seek(BrdF1,MHeader.Pointer - 1);
MHeader.Pointer := (FileSize(BrdF2) + 1);
Write(MsgHdrF2,MHeader);
TotLoad := 0;
IF (MHeader.TextSize > 0) THEN
WHILE (MHeader.TextSize > 0) DO
BEGIN
Buffered := MHeader.TextSize;
IF (Buffered > 4096) THEN
Buffered := 4096;
Dec(MHeader.TextSize,Buffered);
BlockRead(BrdF1,Buffer[1],Buffered);
BlockWrite(BrdF2,Buffer[1],Buffered);
LastError := IOResult;
END;
END;
Inc(i);
END;
LastError := IOResult;
Close(BrdF1);
Close(BrdF2);
Close(MsgHdrF1);
Close(MsgHdrF2);
ReName(BrdF1,FN+'.DA3'); { ReName .DAT to .DA3 }
IF (IOResult <> 0) THEN { Didn't work, abort }
BEGIN
OhShit;
Exit;
END;
ReName(BrdF2,FN+'.DAT'); { ReName .DA2 to .DAT }
IF (IOResult <> 0) THEN { Didn't work, abort }
BEGIN
OhShit;
ReName(BrdF1,FN+'.DAT'); { ReName .DA3 to .DAT }
Exit;
END;
ReName(MsgHdrF1,FN+'.HD3'); { ReName .HDR to .HD3 }
IF (IOResult <> 0) THEN { Didn't work, abort }
BEGIN
OhShit;
Erase(BrdF2); { Erase .DA2 }
ReName(BrdF1,FN+'.DAT'); { ReName .DA3 to .DAT }
Exit;
END;
ReName(MsgHdrF2,FN+'.HDR'); { ReName .HD2 to .HDR }
IF (IOResult <> 0) THEN { Didn't work, abort }
BEGIN
OhShit;
Erase(BrdF2); { Erase .DAT (new) }
Erase(MsgHdrF2); { Erase .HD2 (new) }
ReName(BrdF1,FN+'.DAT'); { ReName .DA3 to .DAT }
ReName(MsgHdrF1,FN+'.HDR'); { ReName .HD3 to .HDR }
Exit;
END;
Erase(MsgHdrF1);
Erase(BrdF1);
LastError := IOResult;
END;
PROCEDURE DoShowPackMessageAreas;
VAR
TempBoard: MessageAreaRecordType;
MArea: Integer;
BEGIN
TempPause := FALSE;
SysOpLog('Packed all message areas');
NL;
Star('Packing all message areas');
NL;
Print('^1Packing ^5Private Mail');
PackMessageArea('EMAIL',0);
Reset(MsgAreaFile);
IF (IOResult <> 0) THEN
Exit;
Abort := FALSE;
FOR MArea := 0 TO (FileSize(MsgAreaFile) - 1) DO
BEGIN
Seek(MsgAreaFile,MArea);
Read(MsgAreaFile,TempBoard);
Print('^1Packing ^5'+TempBoard.Name+'^5 #'+IntToStr(MArea + 1));
PackMessageArea(TempBoard.FIleName,TempBoard.MaxMsgs);
WKey;
IF (Abort) THEN
Break;
END;
Close(MsgAreaFile);
lil := 0;
END;
PROCEDURE PackMessageAreas;
BEGIN
NL;
IF PYNQ('Pack all message areas? ',0,FALSE) THEN
DoShowPackMessageAreas
ELSE
BEGIN
InitMsgArea(MsgArea);
SysOpLog('Packed message area ^5'+MemMsgArea.Name);
NL;
Print('^1Packing ^5'+MemMsgArea.Name+'^5 #'+IntToStr(CompMsgArea(MsgArea,0)));
PackMessageArea(MemMsgArea.FIleName,MemMsgArea.MaxMsgs);
END;
END;
END.

1321
SOURCE/MULTNODE.PAS Normal file
View File

File diff suppressed because it is too large Load Diff

708
SOURCE/MYIO.PAS Normal file
View File

@ -0,0 +1,708 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R+,S-,V-}
UNIT MyIO;
INTERFACE
TYPE
AStr = STRING[160];
WindowRec = ARRAY[0..8000] OF Byte;
ScreenType = ARRAY [0..3999] OF Byte;
Infield_Special_Function_Proc_Rec = PROCEDURE(c: Char);
CONST
Infield_Seperators: SET OF Char = [' ','\','.'];
Infield_Only_Allow_On: BOOLEAN = FALSE;
Infield_Arrow_Exit: BOOLEAN = FALSE;
Infield_Arrow_Exited: BOOLEAN = FALSE;
Infield_Arrow_Exited_Keep: BOOLEAN = FALSE;
Infield_Special_Function_On: BOOLEAN = FALSE;
Infield_Arrow_Exit_TypeDefs: BOOLEAN = FALSE;
Infield_Normal_Exit_Keydefs: BOOLEAN = FALSE;
Infield_Normal_Exited: BOOLEAN = FALSE;
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,
Infield_Out_FGrd,
Infield_Out_BkGd,
Infield_Inp_FGrd,
Infield_Inp_BkGd,
Infield_Last_Arrow,
Infield_Last_Normal: Byte;
Infield_Special_Function_Proc: infield_special_function_proc_rec;
Infield_Only_Allow,
Infield_Special_Function_Keys,
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);
PROCEDURE Infield(VAR s: AStr; Len: Byte);
FUNCTION l_yn: BOOLEAN;
FUNCTION l_pynq(CONST s: AStr): BOOLEAN;
PROCEDURE CWrite(CONST s: AStr);
PROCEDURE CWriteAt(x,y: Integer; CONST s: AStr);
FUNCTION CStringLength(CONST s: AStr): Integer;
PROCEDURE cwritecentered(y: Integer; CONST s: AStr);
PROCEDURE Box(LineType,TLX,TLY,BRX,BRY: Integer);
PROCEDURE SaveScreen(VAR Wind: WindowRec);
PROCEDURE RemoveWindow(VAR Wind: WindowRec);
PROCEDURE SetWindow(VAR Wind: WindowRec; TLX,TLY,BRX,BRY,TColr,BColr,BoxType: Integer);
IMPLEMENTATION
USES
Crt
{$IFDEF WIN32}
,RPScreen
,VpSysLow
{$ENDIF}
;
{$IFDEF WIN32}
VAR
SavedScreen: TScreenBuf;
{$ENDIF}
{$IFDEF MSDOS}
PROCEDURE CursorOn(b: BOOLEAN); ASSEMBLER;
ASM
cmp b, 1
je @turnon
mov ch, 9
mov cl, 0
jmp @goforit
@turnon:
mov ch, 6
mov cl, 7
@goforit:
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
SaveS: AStr;
c: Char;
SaveTextAttr,
SaveX,
SaveY: Byte;
i,
p,
z: Integer;
Ins,
Done,
NoKeyYet: BOOLEAN;
PROCEDURE gocpos;
BEGIN
GoToXY(x + p - 1,y);
END;
PROCEDURE Exit_W_Arrow;
VAR
i: Integer;
BEGIN
Infield_Arrow_Exited := TRUE;
Infield_Last_Arrow := Ord(c);
Done := TRUE;
IF (Infield_Arrow_Exited_Keep) THEN
BEGIN
z := Len;
FOR i := Len DOWNTO 1 DO
IF (s[i] = ' ') THEN
Dec(z)
ELSE
i := 1;
s[0] := chr(z);
END
ELSE
s := SaveS;
END;
PROCEDURE Exit_W_Normal;
VAR
i: Integer;
BEGIN
Infield_Normal_Exited := TRUE;
Infield_Last_Normal := Ord(c);
Done := TRUE;
IF (Infield_Arrow_Exited_Keep) THEN
BEGIN
z := Len;
FOR i := Len DOWNTO 1 DO
IF (s[i] = ' ') THEN
Dec(z)
ELSE
i := 1;
s[0] := chr(z);
END
ELSE
s := SaveS;
END;
BEGIN
SaveTextAttr := TextAttr;
SaveX := WhereX;
SaveY := WhereY;
SaveS := s;
Ins := FALSE;
Done := FALSE;
Infield_Arrow_Exited := FALSE;
GoToXY(x,y);
TextAttr := (Infield_Inp_BkGd * 16) + Infield_Inp_FGrd;
FOR i := 1 TO Len DO
Write(' ');
FOR i := (Length(s) + 1) TO Len DO
s[i] := ' ';
GoToXY(x,y);
Write(s);
p := 1;
gocpos;
NoKeyYet := TRUE;
REPEAT
REPEAT
c := ReadKey
UNTIL ((NOT Infield_Only_Allow_On) OR
(Pos(c,Infield_Special_Function_Keys) <> 0) OR
(Pos(c,Infield_Normal_Exit_Keys) <> 0) OR
(Pos(c,Infield_Only_Allow) <> 0) OR (c = #0));
IF ((Infield_Normal_Exit_Keydefs) AND
(Pos(c,Infield_Normal_Exit_Keys) <> 0)) THEN
Exit_W_Normal;
IF ((Infield_Special_Function_On) AND
(Pos(c,Infield_Special_Function_Keys) <> 0)) THEN
Infield_Special_Function_Proc(c)
ELSE
BEGIN
IF (NoKeyYet) THEN
BEGIN
NoKeyYet := FALSE;
IF (c IN [#32..#255]) THEN
BEGIN
GoToXY(x,y);
FOR i := 1 TO Len DO
BEGIN
Write(' ');
s[i] := ' ';
END;
GoToXY(x,y);
END;
END;
CASE c OF
#0 : BEGIN
c := ReadKey;
IF ((Infield_Arrow_Exit) AND (Infield_Arrow_Exit_TypeDefs) AND
(Pos(c,Infield_Arrow_Exit_Types) <> 0)) THEN
Exit_W_Arrow
ELSE
CASE c OF
#72,#80 :
IF (Infield_Arrow_Exit) THEN
Exit_W_Arrow;
#75 : IF (p > 1) THEN
Dec(p);
#77 : IF (p < Len + 1) THEN
Inc(p);
#71 : p := 1;
#79 : BEGIN
z := 1;
FOR i := Len DOWNTO 2 DO
IF ((s[i - 1] <> ' ') AND (z = 1)) THEN
z := i;
IF (s[z] = ' ') THEN
p := z
ELSE
p := Len + 1;
END;
#82 : Ins := NOT Ins;
#83 : IF (p <= Len) THEN
BEGIN
FOR i := p TO (Len - 1) DO
BEGIN
s[i] := s[i + 1];
Write(s[i]);
END;
s[Len] := ' ';
Write(' ');
END;
#115 : IF (p > 1) THEN
BEGIN
i := (p - 1);
WHILE ((NOT (s[i - 1] IN Infield_Seperators)) OR
(s[i] IN Infield_Seperators)) AND (i > 1) DO
Dec(i);
p := i;
END;
#116 : IF (p <= Len) THEN
BEGIN
i := p + 1;
WHILE ((NOT (s[i-1] IN Infield_Seperators)) OR
(s[i] IN Infield_Seperators)) AND (i <= Len) DO
Inc(i);
p := i;
END;
#117 : IF (p <= Len) THEN
FOR i := p TO Len DO
BEGIN
s[i] := ' ';
Write(' ');
END;
END;
gocpos;
END;
#27 : BEGIN
s := SaveS;
Done := TRUE;
END;
#13 : BEGIN
Done := TRUE;
z := Len;
FOR i := Len DOWNTO 1 DO
IF (s[i] = ' ') THEN
Dec(z)
ELSE
i := 1;
s[0] := chr(z);
END;
#8 : IF (p <> 1) THEN
BEGIN
Dec(p);
s[p] := ' ';
gocpos;
Write(' ');
gocpos;
END;
ELSE
IF ((c IN [#32..#255]) AND (p <= Len)) THEN
BEGIN
IF ((Ins) AND (p <> Len)) THEN
BEGIN
Write(' ');
FOR i := Len DOWNTO (p + 1) DO
s[i] := s[i - 1];
FOR i := (p + 1) TO Len DO
Write(s[i]);
gocpos;
END;
Write(c);
s[p] := c;
Inc(p);
END;
END;
END;
UNTIL (Done);
GoToXY(x,y);
TextAttr := (Infield_Out_BkGd * 16) + Infield_Out_FGrd;
FOR i := 1 TO Len DO
Write(' ');
GoToXY(x,y);
Write(s);
GoToXY(SaveX,SaveY);
TextAttr := SaveTextAttr;
Infield_Only_Allow_On := FALSE;
Infield_Special_Function_On := FALSE;
Infield_Normal_Exit_Keydefs := FALSE;
END;
PROCEDURE Infielde(VAR s: AStr; Len: Byte);
BEGIN
infield1(WhereX,WhereY,s,Len);
END;
PROCEDURE Infield(VAR S: AStr; Len: Byte);
BEGIN
S := '';
Infielde(S,Len);
END;
FUNCTION l_yn: BOOLEAN;
VAR
C: Char;
BEGIN
REPEAT
C := UpCase(ReadKey)
UNTIL (C IN ['Y','N',#13,#27]);
IF (C = 'Y') THEN
BEGIN
l_yn := TRUE;
WriteLn('Yes');
END
ELSE
BEGIN
l_yn := FALSE;
WriteLn('No');
END;
END;
FUNCTION l_pynq(CONST S: AStr): BOOLEAN;
BEGIN
TextColor(4);
Write(S);
TextColor(11);
l_pynq := l_yn;
END;
PROCEDURE CWrite(CONST S: AStr);
VAR
C: Char;
Counter: Byte;
LastB,
LastC: BOOLEAN;
BEGIN
LastB := FALSE;
LastC := FALSE;
FOR Counter := 1 TO Length(S) DO
BEGIN
C := S[Counter];
IF ((LastB) OR (LastC)) THEN
BEGIN
IF (LastB) THEN
TextBackGround(Ord(C))
ELSE IF (LastC) THEN
TextColor(Ord(C));
LastB := FALSE;
LastC := FALSE;
END
ELSE
CASE C OF
#2 : LastB := TRUE;
#3 : LastC := TRUE;
ELSE
Write(C);
END;
END;
END;
PROCEDURE CWriteAt(x,y: Integer; CONST s: AStr);
BEGIN
GoToXY(x,y);
CWrite(s);
END;
FUNCTION CStringLength(CONST s: AStr): Integer;
VAR
Len,
i: Integer;
BEGIN
Len := Length(s);
i := 1;
WHILE (i <= Length(s)) DO
BEGIN
IF ((s[i] = #2) OR (s[i] = #3)) THEN
BEGIN
Dec(Len,2);
Inc(i);
END;
Inc(i);
END;
CStringLength := Len;
END;
PROCEDURE cwritecentered(y: Integer; CONST s: AStr);
BEGIN
CWriteAt(40 - (CStringLength(s) DIV 2),y,s);
END;
{*
* ÚÄÄÄ¿ ÉÍÍÍ» °°°°° ±±±±± ²²²²² ÛÛÛÛÛ ÖÄÄÄ· ÕÍÍ͸
* ³ 1 ³ º 2 º ° 3 ° ± 4 ± ² 5 ² Û 6 Û º 7 º ³ 8 ³
* ÀÄÄÄÙ ÈÍÍͼ °°°°° ±±±±± ²²²²² ÛÛÛÛÛ ÓÄÄĽ ÔÍÍ;
*}
PROCEDURE Box(LineType,TLX,TLY,BRX,BRY: Integer);
VAR
TL,TR,BL,BR,HLine,VLine: Char;
i: Integer;
BEGIN
Window(1,1,MaxDisplayCols,MaxDisplayRows);
CASE LineType OF
1 : BEGIN
TL := #218;
TR := #191;
BL := #192;
BR := #217;
VLine := #179;
HLine := #196;
END;
2 : BEGIN
TL := #201;
TR := #187;
BL := #200;
BR := #188;
VLine := #186;
HLine := #205;
END;
3 : BEGIN
TL := #176;
TR := #176;
BL := #176;
BR := #176;
VLine := #176;
HLine := #176;
END;
4 : BEGIN
TL := #177;
TR := #177;
BL := #177;
BR := #177;
VLine := #177;
HLine := #177;
END;
5 : BEGIN
TL := #178;
TR := #178;
BL := #178;
BR := #178;
VLine := #178;
HLine := #178;
END;
6 : BEGIN
TL := #219;
TR := #219;
BL := #219;
BR := #219;
VLine := #219;
HLine := #219;
END;
7 : BEGIN
TL := #214;
TR := #183;
BL := #211;
BR := #189;
VLine := #186;
HLine := #196;
END;
8 : BEGIN
TL := #213;
TR := #184;
BL := #212;
BR := #190;
VLine := #179;
HLine := #205;
END;
ELSE
BEGIN
TL := #32;
TR := #32;
BL := #32;
BR := #32;
VLine := #32;
HLine := #32;
END;
END;
GoToXY(TLX,TLY);
Write(TL);
GoToXY(BRX,TLY);
Write(TR);
GoToXY(TLX,BRY);
Write(BL);
GoToXY(BRX,BRY);
Write(BR);
FOR i := (TLX + 1) TO (BRX - 1) DO
BEGIN
GoToXY(i,TLY);
Write(HLine);
END;
FOR i := (TLX + 1) TO (BRX - 1) DO
BEGIN
GoToXY(i,BRY);
Write(HLine);
END;
FOR i := (TLY + 1) TO (BRY - 1) DO
BEGIN
GoToXY(TLX,i);
Write(VLine);
END;
FOR i := (TLY + 1) TO (BRY - 1) DO
BEGIN
GoToXY(BRX,I);
Write(VLine);
END;
IF (LineType > 0) THEN
Window((TLX + 1),(TLY + 1),(BRX - 1),(BRY - 1))
ELSE
Window(TLX,TLY,BRX,BRY);
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);
BEGIN
SaveScreen(Wind); { save under Window }
Window(TLX,TLY,BRX,BRY); { SET Window size }
TextColor(TColr);
TextBackGround(BColr);
ClrScr; { clear window for action }
Box(BoxType,TLX,TLY,BRX,BRY); { Set the border }
END;
{$IFDEF MSDOS}
PROCEDURE Update_Logo(VAR Addr1,Addr2; BlkLen: Integer);
BEGIN
INLINE (
$1E/
$C5/$B6/ADDR1/
$C4/$BE/ADDR2/
$8B/$8E/BLKLEN/
$E3/$5B/
$8B/$D7/
$33/$C0/
$FC/
$AC/
$3C/$20/
$72/$05/
$AB/
$E2/$F8/
$EB/$4C/
$3C/$10/
$73/$07/
$80/$E4/$F0/
$0A/$E0/
$EB/$F1/
$3C/$18/
$74/$13/
$73/$19/
$2C/$10/
$02/$C0/
$02/$C0/
$02/$C0/
$02/$C0/
$80/$E4/$8F/
$0A/$E0/
$EB/$DA/
$81/$C2/$A0/$00/
$8B/$FA/
$EB/$D2/
$3C/$1B/
$72/$07/
$75/$CC/
$80/$F4/$80/
$EB/$C7/
$3C/$19/
$8B/$D9/
$AC/
$8A/$C8/
$B0/$20/
$74/$02/
$AC/
$4B/
$32/$ED/
$41/
$F3/$AB/
$8B/$CB/
$49/
$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.

284
SOURCE/NEWUSERS.PAS Normal file
View File

@ -0,0 +1,284 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S+,V-}
UNIT NewUsers;
INTERFACE
PROCEDURE NewUser;
PROCEDURE NewUserInit;
IMPLEMENTATION
USES
Common,
CUser,
EMail,
Mail0,
Menus,
MiscUser,
Script,
SysOp2G,
TimeFunc;
PROCEDURE NewUser;
VAR
Letter: Text;
User: UserRecordType;
UserIDX: UserIDXRec;
MHeader: MHeaderRec;
TempStr: STRING;
Cmd,
NewMenuCmd: AStr;
NewUserPassword: Str20;
SaveMenu,
PasswordAttemps,
CmdToExec: Byte;
Counter,
Counter1,
TempNewApp: Integer;
CmdNotHid,
CmdExists,
Done: Boolean;
BEGIN
SL1('* New user logon');
UserNum := 0;
Update_Node(RGNoteStr(36,TRUE){'New user logging on'},TRUE);
UserNum := -1;
IF (General.NewUserPW <> '') THEN
BEGIN
PasswordAttemps := 0;
NewUserPassword := '';
WHILE ((NewUserPassword <> General.NewUserPW) AND (PasswordAttemps < General.MaxLogonTries) AND (NOT HangUp)) DO
BEGIN
(*
Prt(FString.NewUserPassword);
*)
RGMainStr(10,FALSE);
GetPassword(NewUserPassword,20);
IF ((NewUserPassword <> '') AND (General.NewUserPW <> NewUserPassword)) THEN
BEGIN
(*
Print('Invalid password, keep trying ...');
*)
RGNoteStr(38,FALSE);
SL1('* Invalid new user password: '+NewUserPassword);
Inc(PasswordAttemps);
END;
END;
IF (PasswordAttemps >= General.MaxLogonTries) THEN
BEGIN
PrintF('NUPWFAIL');
IF (NoFile) THEN
(*
Print('You have exceeded the maximum new user logon attempts, hanging up ...');
*)
RGNoteStr(39,FALSE);
SL1('* Maximum new user logon attempts exceeded - hung user up.');
HangUp := TRUE;
END;
END;
IF (NOT HangUp) THEN
BEGIN
PrintF('NEWUSER');
Counter := 1;
WHILE (Counter <= 20) AND (NOT HangUp) DO
BEGIN
IF (General.NewUserToggles[Counter] <> 0) THEN
BEGIN
Update_Screen;
CStuff(General.NewUserToggles[Counter],1,ThisUser);
END;
Inc(Counter);
END;
Abort := FALSE;
Next := FALSE;
SaveMenu := CurMenu;
CurMenu := General.NewUserInformationMenu;
LoadMenuPW;
AutoExecCmd('FIRSTCMD');
REPEAT
MainMenuHandle(Cmd);
NewMenuCmd := '';
CmdToExec := 0;
Done := FALSE;
REPEAT
FCmd(Cmd,CmdToExec,CmdExists,CmdNotHid);
IF (CmdToExec <> 0) THEN
BEGIN
DoMenuCommand(Done,
MemCmd^[CmdToExec].CmdKeys,
MemCmd^[CmdToExec].Options,
NewMenuCmd,
MemCmd^[CmdToExec].NodeActivityDesc);
IF (MemCmd^[CmdToExec].CmdKeys = 'OQ') THEN
Abort := TRUE;
END;
UNTIL (CmdToExec = 0) OR (Done) OR (HangUp);
UNTIL (Abort) OR (Next) OR (HangUp);
CurMenu := SaveMenu;
NewMenuToLoad := TRUE;
LastError := IOResult;
END;
IF (NOT HangUp) THEN
BEGIN
(*
Prompt('Saving your information ... ');
*)
RGNoteStr(40,FALSE);
SysOpLog('Saving new user information ...');
Counter1 := 0;
Counter := 1;
Reset(UserIDXFile);
WHILE (Counter <= (FileSize(UserIDXFile) - 1)) AND (Counter1 = 0) DO
BEGIN
Read(UserIDXFile,UserIDX);
IF (UserIDX.Deleted) THEN
BEGIN
LoadURec(User,UserIDX.Number);
IF (Deleted IN User.SFlags) THEN
Counter1 := UserIDX.Number;
END;
Inc(Counter);
END;
Close(UserIDXFile);
LastError := IOResult;
IF (Counter1 > 0) THEN
UserNum := Counter1
ELSE
UserNum := MaxUsers;
WITH ThisUser DO
BEGIN
FirstOn := GetPackDateTime;
LastOn := FirstOn;
IF (CallerIDNumber <> '') THEN
BEGIN
CallerID := CallerIDNumber;
Note := CallerID;
END;
END;
SaveURec(ThisUser,UserNum);
AutoValidate(ThisUser,UserNum,'!');
InsertIndex(ThisUser.Name,UserNum,FALSE,FALSE);
InsertIndex(ThisUser.Realname,UserNum,TRUE,FALSE);
Inc(lTodayNumUsers);
SaveGeneral(TRUE);
(*
Print('^3Saved.');
*)
RGNoteStr(41,FALSE);
SysOpLog('Saved as user #'+IntToStr(UserNum));
UserOn := TRUE;
WasNewUser := TRUE;
END;
IF (NOT HangUp) THEN
BEGIN
CLS;
IF ((Exist(General.MiscPath+'NEWUSER.INF')) OR (Exist(General.DataPath+'NEWUSER.INF'))) THEN
ReadQ('NEWUSER');
Update_Screen;
TempNewApp := -1;
IF (General.NewApp <> -1) THEN
BEGIN
TempNewApp := General.NewApp;
IF (TempNewApp < 1) OR (TempNewApp > (MaxUsers - 1)) THEN
BEGIN
SL1('* Invalid user number for New User Application: '+IntToStr(General.NewApp));
TempNewApp := 1;
END;
END;
IF (TempNewApp <> -1) THEN
BEGIN
PrintF('NEWAPP');
IF (NoFile) THEN
(*
Print('You must now send a new user application letter to the SysOp.');
*)
RGNoteStr(42,FALSE);
InResponseTo := '\'+#1+RGNoteStr(43,TRUE); { 'New User Application' }
MHeader.Status := [];
SeMail(TempNewApp,MHeader);
END;
END;
IF (NOT HangUp) THEN
BEGIN
IF (Exist(General.MiscPath+'NEWLET.ASC')) THEN
BEGIN
FillChar(MHeader,SizeOf(MHeader),0);
InitMsgArea(-1);
Reset(MsgHdrF);
Seek(MsgHdrF,FileSize(MsgHdrF));
Reset(MsgTxtF,1);
Seek(MsgTxtF,FileSize(MsgTxtF));
MHeader.Pointer := (FileSize(MsgTxtF) + 1);
MHeader.TextSize := 0;
Assign(Letter,General.MiscPath+'NEWLET.ASC');
Reset(Letter);
ReadLn(Letter,MHeader.From.A1S);
ReadLn(Letter,MHeader.Subject);
WITH MHeader DO
BEGIN
From.UserNum := TempNewApp;
MTO.UserNum := UserNum;
MTO.A1S := ThisUser.Name;
Date := GetPackDateTime;
Status := [AllowMCI];
END;
WHILE NOT EOF(Letter) DO
BEGIN
ReadLn(Letter,TempStr);
Inc(MHeader.TextSize,(Length(TempStr) + 1));
BlockWrite(MsgTxtF,TempStr[0],(Length(TempStr) + 1));
END;
Close(Letter);
Close(MsgTxtF);
Write(MsgHdrF,MHeader);
Close(MsgHdrF);
LastError := IOResult;
ThisUser.Waiting := 1;
END;
END;
END;
PROCEDURE NewUserInit;
BEGIN
IF (General.ClosedSystem) THEN
BEGIN
PrintF('NONEWUSR');
IF (NoFile) THEN
(*
Print('This BBS is currently not accepting new users, hanging up ...');
*)
RGNoteStr(32,FALSE);
SL1('* Attempted logon when BBS closed to new users - hung user up.');
HangUp := TRUE;
END
ELSE
BEGIN
LoadURec(ThisUser,0);
WITH ThisUser DO
BEGIN
FirstOn := GetPackDateTime;
LastOn := FirstOn;
END;
InitTrapFile;
END;
END;
END.

652
SOURCE/NODELIST.PAS Normal file
View File

@ -0,0 +1,652 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D-,E-,F+,I-,L-,N-,O+,R-,S+,V-}
UNIT Nodelist;
INTERFACE
USES
Common;
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: 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;
IMPLEMENTATION
USES
Mail0;
TYPE
CompProc = FUNCTION(VAR ALine,Desire; L: Char): Integer;
DATRec = RECORD
Zone, { Zone of board }
Net, { Net Address of board }
Node, { Node Address of board }
Point: SmallInt; { Either Point number OR 0 }
CallCost, { Cost to sysop to send }
MsgFee, { Cost to user to send }
NodeFlags: SmallWord; { Node flags }
ModemType, { Modem TYPE }
PassWord: STRING[9];
Phone,
BName,
CName,
SName: STRING[39];
BaudRate, { Highest Baud Rate }
RecSize: Byte; { Size of the Node on FILE }
END;
IndxRefBlk = RECORD
IndxOfs, { Offset of STRING into block }
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: SmallWord; { Length of STRING }
KeyVal: LongInt; { Pointer to Data block }
END; { LeafRef }
CtlBlk = RECORD
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: 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: 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;
LNodeBlk = RECORD
IndxFirst, { Pointer to next lower level }
IndxBLink, { Pointer to previous link }
IndxFLink: LongInt; { Pointer to next link }
IndxCnt: SmallInt; { Count of Items IN block }
IndxStr: SmallWord; { Offset IN block of 1st str }
LeafRef: ARRAY [0..49] OF LeafRefBlk;
END;
PROCEDURE ToggleNetAttr(NetAttrT: NetAttr; VAR NetAttrS: NetAttribs);
BEGIN
IF (NetAttrT IN NetAttrS) THEN
Exclude(NetAttrS,NetAttrT)
ELSE
Include(NetAttrS,NetAttrT);
END;
PROCEDURE ToggleNetAttrs(C: CHAR; VAR NetAttrS: NetAttribs);
BEGIN
CASE C OF
'C' : ToggleNetAttr(Crash,NetAttrS);
'H' : ToggleNetAttr(Hold,NetAttrS);
'I' : ToggleNetAttr(InTransit,NetAttrS);
'K' : ToggleNetAttr(KillSent,NetAttrS);
'L' : ToggleNetAttr(Local,NetAttrS);
'P' : ToggleNetAttr(Private,NetAttrS);
END;
END;
FUNCTION GetNewAddr(DisplayStr: AStr; MaxLen: Byte; VAR Zone,Net,Node,Point: SmallWord): Boolean;
BEGIN
GetNewAddr := FALSE;
Prt(DisplayStr);
MPL(MaxLen);
Input(DisplayStr,MaxLen);
IF (DisplayStr = '') OR (Pos('/',DisplayStr) = 0) THEN
Exit;
IF (Pos(':',DisplayStr) > 0) THEN
BEGIN
Zone := StrToInt(Copy(DisplayStr,1,Pos(':',DisplayStr)));
DisplayStr := Copy(DisplayStr,Pos(':',DisplayStr)+1,Length(DisplayStr));
END
ELSE
Zone := 1;
IF (Pos('.',DisplayStr) > 0) THEN
BEGIN
Point := StrToInt(Copy(DisplayStr,Pos('.',DisplayStr)+1,Length(DisplayStr)));
DisplayStr := Copy(DisplayStr,1,Pos('.',DisplayStr)-1);
END
ELSE
Point := 0;
Net := StrToInt(Copy(DisplayStr,1,Pos('/',DisplayStr)));
Node := StrToInt(Copy(DisplayStr,Pos('/',DisplayStr)+1,Length(DisplayStr)));
GetNewAddr := TRUE;
END;
FUNCTION NetMail_Attr(NetAttribute: NetAttribs): Astr;
VAR
s: AStr;
BEGIN
s := '';
IF (Local IN NetAttribute) THEN
s := 'Local ';
IF (Private IN NetAttribute) THEN
s := s + 'Private ';
IF (Crash IN NetAttribute) THEN
s := s + 'Crash ';
IF (FileAttach IN NetAttribute) THEN
s := s + 'FileAttach ';
IF (InTransit IN NetAttribute) THEN
s := s + 'InTransit ';
IF (KillSent IN NetAttribute) THEN
s := s + 'KillSent ';
IF (Hold IN NetAttribute) THEN
s := s + 'Hold ';
IF (FileRequest IN NetAttribute) THEN
s := s + 'File Request ';
IF (FileUpdateRequest IN NetAttribute) THEN
s := s + 'Update Request ';
NetMail_Attr := s;
END;
FUNCTION CompName(VAR ALine,Desire; L: Char): Integer;
VAR
Key,
Desired: STRING[36];
Len: Byte ABSOLUTE L;
BEGIN
Key[0] := L;
Desired[0] := L;
Move(ALine,Key[1],Len);
Move(Desire,Desired[1],Len);
IF (Key > Desired) THEN
CompName := 1
ELSE IF (Key < Desired) THEN
CompName := -1
ELSE
CompName := 0;
END;
FUNCTION CompAddress(VAR ALine,Desire; L: Char): Integer;
TYPE
NodeType = RECORD
Zone,
Net,
Node,
Point: SmallWord;
END;
VAR
Key: NodeType ABSOLUTE ALine;
Desired: NodeType ABSOLUTE Desire;
Count: Byte;
K: Integer;
BEGIN
Count := 0;
REPEAT
Inc(Count);
CASE Count OF
1 : Word(K) := Key.Zone - Desired.Zone;
2 : Word(K) := Key.Net - Desired.Net;
3 : Word(K) := Key.Node - Desired.Node;
4 : BEGIN
IF (L = #6) THEN
Key.Point := 0;
Word(K) := Key.Point - Desired.Point;
END;
END;
UNTIL (Count = 4) OR (K <> 0);
Compaddress := K;
END;
PROCEDURE GetNetAddress(VAR SysOpName: AStr; VAR Zone,Net,Node,Point: SmallWord; var Fee: Word; GetFee: Boolean);
VAR
DataFile,
NDXFile: FILE;
s: STRING[36];
Location: LongInt;
Dat: DatRec;
Internet: Boolean;
FUNCTION FullNodeStr(NodeStr: AStr): STRING;
{ These constants are the defaults IF the user does NOT specify them }
CONST
DefZone = '1'; { Default Zone }
DefNet = '1'; { Default Net }
DefNode = '1'; { Default Node }
DefPoint = '0'; { Default Point }
BEGIN
IF (NodeStr[1] = '.') THEN
NodeStr := DefNode + NodeStr;
IF (Pos('/',NodeStr) = 0) THEN
IF (Pos(':',NodeStr) = 0) THEN
NodeStr := DefZone+':'+DefNet+'/'+NodeStr
ELSE
ELSE
BEGIN
IF (NodeStr [1] = '/') THEN
NodeStr := DefNet + NodeStr;
IF (Pos(':',NodeStr) = 0) THEN
NodeStr := DefZone + ':' + NodeStr;
IF (NodeStr[Length(NodeStr)] = '/') THEN
NodeStr := NodeStr + DefNode;
END;
IF (Pos('.',NodeStr) = 0) THEN
NodeStr := NodeStr+'.'+DefPoint;
FullNodeStr := NodeStr;
END;
FUNCTION MakeAddress(Z,Nt,N,P: Word): STRING;
TYPE
NodeType = RECORD { A Node address TYPE }
Len: Byte;
Zone,
Net,
Node,
Point: SmallWord;
END;
VAR
Address: NodeType;
S2: STRING ABSOLUTE Address;
BEGIN
WITH Address DO
BEGIN
Zone := Z;
Net := Nt;
Node := N;
Point := P;
Len := 8;
END;
MakeAddress := S2;
END;
FUNCTION MakeName(Name: AStr): STRING;
VAR
Temp: STRING[36];
Comma: STRING[2];
BEGIN
Temp := Caps(Name);
IF (Pos(' ', Name) > 0) THEN
Comma := ', '
ELSE
Comma := '';
MakeName := Copy(Temp, Pos(' ',Temp) + 1, Length(Temp) - Pos(' ',Temp))
+ Comma + Copy(Temp,1,Pos(' ',Temp) - 1) + #0;
END;
PROCEDURE UnPk(S1: STRING; VAR S2: STRING; Count: Byte);
CONST
UnWrk: ARRAY [0..38] OF Char = ' EANROSTILCHBDMUGPKYWFVJXZQ-''0123456789';
TYPE
CharType = RECORD
C1,
C2: Byte;
END;
VAR
U: CharType;
W1: Word ABSOLUTE U;
I,
J: Integer;
OBuf: ARRAY [0..2] OF Char;
Loc1,
Loc2: Byte;
BEGIN
S2 := '';
Loc1 := 1;
Loc2 := 1;
WHILE (Count > 0) DO
BEGIN
U.C1 := Ord(S1[Loc1]);
Inc(Loc1);
U.C2 := Ord(S1[Loc1]);
Inc(Loc1);
Count := Count - 2;
for J := 2 downto 0 DO
BEGIN
I := W1 MOD 40;
W1 := W1 DIV 40;
OBuf[J] := UnWrk[I];
END;
Move(OBuf,S2[Loc2],3);
Inc(Loc2,3);
END;
S2[0] := Chr(Loc2);
END;
FUNCTION GetData(VAR F1: FILE; SL: LongInt; VAR Dat: DATRec): Boolean;
TYPE
RealDATRec = RECORD
Zone, { Zone of board }
Net, { Net Address of board }
Node, { Node Address of board }
Point: SmallInt; { Either Point number OR 0 }
CallCost, { Cost to sysop to send }
MsgFee, { Cost to user to send }
NodeFlags: SmallWord; { Node flags }
ModemType, { Modem TYPE }
PhoneLen, { Length of Phone Number }
PassWordLen, { Length of Password }
BNameLen, { Length of Board Name }
SNameLen, { Length of Sysop Name }
CNameLen, { Length of City/State Name }
PackLen, { Length of Packed STRING }
Baud: Byte; { Highest Baud Rate }
Pack: ARRAY [1..160] of Char; { The Packed STRING }
END;
VAR
Data: RealDATRec;
Error: Boolean;
UnPack: STRING[160];
BEGIN
Seek(F1,SL);
{ Read everything at once to keep disk access to a minimum }
BlockRead(F1,Data,SizeOf(Data));
Error := (IOResult <> 0);
IF (NOT Error) THEN
WITH Dat,Data DO
BEGIN
Move(Data,Dat,15);
Phone := Copy(Pack,1,PhoneLen);
PassWord := Copy(Pack,(PhoneLen + 1),PasswordLen);
Move(Pack[PhoneLen + PasswordLen + 1],Pack[1],PackLen);
UnPk(Pack,UnPack,PackLen);
BName := Caps(Copy(UnPack,1,BNameLen));
SName := Caps(Copy(Unpack,(BNameLen + 1),SNameLen));
CName := Caps(Copy(UnPack,BNameLen + SNameLen + 1,CNameLen));
BaudRate := Baud;
RecSize := (PhoneLen + PassWordLen + PackLen) + 22;
END;
END;
PROCEDURE Get7Node(VAR F: FILE; SL: LongInt; VAR Buf);
BEGIN
Seek(F,SL);
BlockRead(F,Buf,512);
IF (IOResult <> 0) THEN
Halt(1);
END;
FUNCTION BTree(VAR F1: FILE; Desired: AStr; Compare: CompProc): LongInt;
LABEL
Return;
VAR
Buf: ARRAY [0..511] OF Char; { These four variables all occupy }
CTL: CTLBlk ABSOLUTE Buf; { the same memory location. Total }
INode: INodeBlk ABSOLUTE Buf; { of 512 bytes. }
LNode: LNodeBlk ABSOLUTE Buf; { --------------------------------- }
NodeCTL: CTLBlk; { Store the CTL block seperately }
ALine: STRING[160]; { Address from NDX FILE }
J,
K,
L,Count: Integer; { Temp integers }
TP: Word; { Pointer to location IN BUF }
Rec, { A temp RECORD IN the FILE }
FRec: LongInt; { The RECORD when found OR NOT }
BEGIN
FRec := -1;
Get7Node(F1,0,Buf);
IF (CTL.CTLBlkSize = 0) THEN GOTO
Return;
Move(Buf,NodeCTL,SizeOf(CTL));
Get7Node(F1,NodeCTL.CtlRoot * NodeCTL.CtlBlkSize,Buf);
WHILE (INode.IndxFirst <> -1) AND (FRec = -1) DO
BEGIN
Count := INode.IndxCnt;
IF (Count = 0) THEN GOTO
Return;
J := 0;
K := -1;
WHILE (J < Count) AND (K < 0) DO
BEGIN
TP := INode.IndxRef[J].IndxOfs;
L := INode.IndxRef[J].IndxLen;
{ ALine [0] := Chr (L); }
Move(Buf[TP],ALine[1],L);
K := Compare(ALine[1],Desired[1],Chr(L));
IF (K = 0) THEN
FRec := INode.IndxRef[J].IndxData
ELSE IF (K < 0) THEN
Inc(J);
END;
IF (FRec = -1) THEN
BEGIN
IF (J = 0) THEN
Rec := INode.IndxFirst
ELSE
Rec := INode.IndxRef[J - 1].IndxPtr;
Get7Node(F1,Rec * NodeCTL.CtlBlkSize,Buf);
END;
END;
IF (FRec = -1) THEN
BEGIN
Count := LNode.IndxCnt;
IF (Count <> 0) THEN
BEGIN
J := 0;
WHILE (J < Count) AND (FRec = -1) DO
BEGIN
TP := LNode.LeafRef[J].KeyOfs;
L := LNode.LeafRef[J].KeyLen;
{ ALine [0] := Chr (L); }
Move(Buf[TP],ALine[1],L);
K := Compare(ALine[1],Desired[1],Chr(L));
IF (K = 0) THEN
FRec := LNode.LeafRef[J].KeyVal;
Inc(J);
END;
END;
END;
Return :
BTree := FRec;
END;
FUNCTION Pull(VAR S: STRING; C: Char): STRING;
VAR
I: Byte;
BEGIN
I := Pos(C,S);
Pull := Copy(S,1,(I - 1));
Delete(S,1,I);
END;
BEGIN
NL;
Internet := FALSE;
IF NOT Exist(General.NodePath+'NODEX.DAT') OR
NOT Exist(General.NodePath+'SYSOP.NDX') OR
NOT Exist(General.NodePath+'NODEX.NDX') THEN
BEGIN
IF (GetFee) THEN
BEGIN
Fee := 0;
Exit;
END;
Print('Enter name of intended receiver.');
Prt(':');
InputDefault(SysOpName,SysOpName,36,[CapWords],TRUE);
IF (SysOpName = '') THEN
Exit;
IF (Pos('@',SysOpName) > 0) THEN
IF (PYNQ('Is this an Internet message? ',0,FALSE)) THEN
BEGIN
Internet := TRUE;
Zone := General.Aka[20].Zone;
Net := General.Aka[20].Net;
Node := General.Aka[20].Node;
Point := General.Aka[20].Point;
Fee := 0;
Exit;
END
ELSE
NL;
IF NOT GetNewAddr('Enter network address (^5Z^4:^5N^4/^5N^4.^5P^4 format): ',30,Zone,Net,Node,Point) THEN
Exit;
Exit;
END;
Assign(DataFile,General.NodePath+'NODEX.DAT');
IF (GetFee) THEN
BEGIN
s := IntToStr(Net)+'/'+IntToStr(Node);
IF (Zone > 0) THEN
s := IntToStr(Zone)+':'+s;
IF (Point > 0) THEN
s := s+'.'+IntToStr(Point);
s := FullNodeStr(s);
Assign(NDXFile,General.NodePath+'NODEX.NDX');
Reset(NDXFile,1);
Location := BTree(NDXFile,MakeAddress(StrToInt(Pull(S,':')),
StrToInt(Pull(S,'/')),StrToInt(Pull(S,'.')),
StrToInt(S)),Compaddress);
Close(NDXFile);
IF (Location <> -1) THEN
BEGIN
Reset(DataFile,1);
GetData(DataFile,Location,Dat);
Close(DataFile);
Fee := Dat.MsgFee;
END
ELSE
Fee := 0;
Exit;
END;
s := SysOpName;
SysOpName := '';
Fee := 0;
REPEAT
Print('Enter a name, a Fidonet address, or an Internet address.');
Prt(':');
InputDefault(s,s,36,[],TRUE);
IF (s = '') THEN
Break;
IF (Pos('/',s) > 0) THEN
BEGIN
s := FullNodeStr(s);
Assign(NDXFile,General.NodePath+'NODEX.NDX');
Reset(NDXFile,1);
Location := BTree(NDXFile,MakeAddress(StrToInt(Pull(S,':')),StrToInt(Pull(S,'/')),StrToInt(Pull(S,'.')),StrToInt(S)),
Compaddress);
Close(NDXFile);
END
ELSE
BEGIN
Assign(NDXFile,General.NodePath+'SYSOP.NDX');
Reset(NDXFile,1);
Location := BTree(NDXFile,MakeName(S),CompName);
Close(NDXFile);
END;
IF (Location <> -1) THEN
BEGIN
Reset(DataFile,1);
GetData(DataFile,Location,Dat);
Close(DataFile);
WITH Dat DO
BEGIN
Print('^1System: '+BName+' ('+IntToStr(Zone)+':'+IntToStr(Net)+'/'+IntToStr(Node)+')');
Print('SysOp : '+SName);
Print('Phone : '+Phone);
Print('Where : '+CName);
Print('Cost : '+IntToStr(MsgFee)+' credits');
END;
NL;
IF (Dat.MsgFee > (ThisUser.lCredit - ThisUser.Debit)) THEN
BEGIN
Print('You do not have enough credit to netmail this Node!');
s := '';
END
ELSE IF PYNQ('Is this correct? ',0,FALSE) THEN
BEGIN
SysOpName := Dat.Sname;
Zone := Dat.Zone;
Net := Dat.Net;
Node := Dat.Node;
Point := 0;
Fee := Dat.MsgFee;
END
ELSE
s := '';
END
ELSE IF (Pos('@',s) > 0) THEN
IF (NOT PYNQ('Is this an Internet message? ',0,FALSE)) THEN
BEGIN
Print('That name is not in the nodelist!'^M^J);
S := '';
END
ELSE
BEGIN
Internet := TRUE;
SysOpName := s;
Zone := General.Aka[20].Zone;
Net := General.Aka[20].Net;
Node := General.Aka[20].Node;
Point := General.Aka[20].Point;
Fee := 0;
END
ELSE
BEGIN
Print('That name is not in the nodelist!'^M^J);
S := '';
END
UNTIL (SysOpName <> '') OR (HangUp);
IF (NOT Internet) AND (Pos('/',s) = 0) AND (s <> '') THEN
BEGIN
NL;
Print('Enter name of intended receiver.');
Prt(':');
InputDefault(SysOpName,SysOpName,36,[CapWords],FALSE);
IF (SysOpName = '') THEN
Exit;
END;
LastError := IOResult;
END;
PROCEDURE ChangeFlags(VAR MsgHeader: MHeaderRec);
VAR
Cmd: Char;
BEGIN
IF (CoSysOp) AND (PYNQ('Change default netmail flags? ',0,FALSE)) THEN
BEGIN
Cmd := #0;
NL;
REPEAT
IF (Cmd <> '?') THEN
BEGIN
Print('^4Current flags: ^5'+NetMail_Attr(MsgHeader.NetAttribute));
NL
END;
Prt('Flag to change: ');
OneK(Cmd,'QPCAIKHRLU?'^M,TRUE,TRUE);
IF (Cmd IN ['?']) THEN
NL;
WITH MsgHeader DO
CASE Cmd OF
'L' : ToggleNetAttr(Local,NetAttribute);
'U' : ToggleNetAttr(FileUpdateRequest,NetAttribute);
'R' : ToggleNetAttr(FileRequest,NetAttribute);
'H' : ToggleNetAttr(Hold,NetAttribute);
'K' : ToggleNetAttr(KillSent,NetAttribute);
'I' : ToggleNetAttr(InTransit,NetAttribute);
'A' : ToggleNetAttr(FileAttach,NetAttribute);
'C' : ToggleNetAttr(Crash,NetAttribute);
'P' : ToggleNetAttr(Private,NetAttribute);
'?' : BEGIN
LCmds3(15,3,'Private','Crash','Attached File');
LCmds3(15,3,'InTransit','KillSent','Hold');
LCmds3(15,3,'Req file','Update Req','Local');
END;
END;
UNTIL (Cmd IN ['Q',^M]) OR (HangUp);
END;
NL;
END;
END.

1225
SOURCE/OFFLINE.PAS Normal file
View File

File diff suppressed because it is too large Load Diff

320
SOURCE/ONELINER.PAS Normal file
View File

@ -0,0 +1,320 @@
{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S+,V-}
Unit OneLiner;
INTERFACE
Uses
Common,
Timefunc,
Mail1;
Type
OneLinerRecordType = {$IFDEF WIN32} Packed {$ENDIF} Record
RecordNum : LongInt;
OneLiner : String[55];
UserID : LongInt;
UserName : String[36];
DateAdded,
DateEdited : UnixTime;
Anonymous : Boolean;
End;
PROCEDURE DoOneLiners;
PROCEDURE OneLiner_Add;
PROCEDURE OneLiner_View;
FUNCTION OneLiner_Random : STRING;
FUNCTION ToLower( S : STRING ) : STRING;
IMPLEMENTATION
VAR
OneLinerListFile : FILE OF OneLinerRecordType;
OneLineRec : OneLinerRecordType;
FUNCTION ToLower( S : STRING ) : STRING;
VAR
i : BYTE;
BEGIN
FOR i := 1 TO Length(S) DO
BEGIN
IF S[i] IN ['A'..'Z'] THEN
S[i] := Chr(Ord(S[i]) + 32);
END;
ToLower := S;
END;
FUNCTION OneLinerListMCI(CONST S: ASTR; Data1,Data2: Pointer): STRING;
VAR
OneLinerListPtr: ^OneLinerRecordType;
User: UserRecordType;
TmpStr : String;
BEGIN
OneLinerListPtr := Data1;
OneLinerListMCI := S;
CASE S[1] OF
'A' : CASE S[2] OF
'N' : OneLinerListMCI := ShowYesNo(OneLinerListPtr^.Anonymous); { Anon - Yes/No }
'T' : OneLinerListMCI := AonOff(OneLinerListPtr^.Anonymous, 'True', 'False'); { Anon - True/False }
END;
'D' : CASE S[2] OF
'A' : OneLinerListMCI := Pd2Date(OneLinerListPtr^.DateAdded); { Date Added }
'E' : OneLinerListMCI := Pd2Date(OneLinerListPtr^.DateEdited); { Date Edited - Not Used }
END;
'O' : CASE S[2] OF
'L' : OneLinerListMCI := OneLinerListPtr^.OneLiner; { The Oneliner }
END;
'R' : CASE S[2] OF
'N' : OneLinerListMCI := IntToStr(OneLinerListPtr^.RecordNum); { Oneliner Record Number }
END;
'U' : CASE S[2] OF
'#' : BEGIN { User ID }
IF (OneLinerListPtr^.Anonymous) THEN
OneLinerListMCI := '';
IF (OneLinerListPtr^.Anonymous) AND (SysOp) THEN
OneLinerListMCI := '#' + IntToStr(OneLinerListPtr^.UserID);
IF (NOT OneLinerListPtr^.Anonymous) THEN
OneLinerListMCI := '#' + IntToStr(OneLinerListPtr^.UserID);
END;
'1' : BEGIN { User ID Without # }
IF (OneLinerListPtr^.Anonymous) THEN
OneLinerListMCI := '';
IF (OneLinerListPtr^.Anonymous) AND (SysOp) THEN
OneLinerListMCI := IntToStr(OneLinerListPtr^.UserID);
IF (NOT OneLinerListPtr^.Anonymous) THEN
OneLinerListMCI := IntToStr(OneLinerListPtr^.UserID);
END;
'N' : BEGIN { User Name }
LoadURec(User,OneLinerListPtr^.UserID);
IF (OneLinerListPtr^.Anonymous) THEN
OneLinerListMCI := 'Anon';
IF (OneLinerListPtr^.Anonymous) AND (SysOp) THEN
OneLinerListMCI := Caps(User.Name) + ' ^4(^5A^4)';
IF (NOT OneLinerListPtr^.Anonymous) THEN
OneLinerListMCI := Caps(User.Name);
END;
'L' : BEGIN { User Name Lower }
LoadURec(User,OneLinerListPtr^.UserID);
IF (OneLinerListPtr^.Anonymous) THEN
OneLinerListMCI := 'anon';
IF (OneLinerListPtr^.Anonymous) AND (SysOp) THEN
OneLinerListMCI := ToLower(User.Name) + ' ^4(^5a^4)';
IF (NOT OneLinerListPtr^.Anonymous) THEN
OneLinerListMCI := ToLower(User.Name);
END;
'S' : BEGIN { User Name Short }
LoadURec(User,OneLinerListPtr^.UserID);
IF (OneLinerListPtr^.Anonymous) THEN
OneLinerListMCI := 'Anon';
IF (OneLinerListPtr^.Anonymous) AND (SysOp) THEN
OneLinerListMCI := Copy(User.Name,1,2) + ' ^4(^5A^4)';
IF (NOT OneLinerListPtr^.Anonymous) THEN
OneLinerListMCI := Copy(User.Name,1,2);
END;
'U' : BEGIN { User Name Short Lower }
LoadURec(User,OneLinerListPtr^.UserID);
IF (OneLinerListPtr^.Anonymous) THEN
OneLinerListMCI := 'anon';
IF (OneLinerListPtr^.Anonymous) AND (SysOp) THEN
OneLinerListMCI := ToLower(Copy(User.Name,1,2)) + ' ^4(^5a^4)';
IF (NOT OneLinerListPtr^.Anonymous) THEN
OneLinerListMCI := ToLower(Copy(User.Name,1,2));
END;
END;
END;
END;
FUNCTION OneLinerList_Exists: Boolean;
VAR
OneLinerListFile: FILE OF OneLinerRecordType;
FSize: Longint;
FExist: Boolean;
BEGIN
FSize := 0;
FExist := Exist(General.DataPath+'ONELINER.DAT');
IF (FExist) THEN
BEGIN
Assign(OneLinerListFile,General.DataPath+'ONELINER.DAT');
Reset(OneLinerListFile);
FSize := FileSize(OneLinerListFile);
Close(OneLinerListFile);
END;
IF (NOT FExist) OR (FSize = 0) THEN
BEGIN
NL;
PrintF('ONELH');
IF (NoFile) THEN
BEGIN
CLS; NL;
Print(Centre('^4' + General.BBSName + ' One Liners'));
Print(Centre('^5ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ'));
END;
Print(' ^4There are currently no One Liners.');
NL;
PrintF('ONELE');
IF (NoFile) THEN
Print(Centre('^5ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ'));
SysOpLog('^5* The ONELINER.DAT file is missing.');
END;
OneLinerList_Exists := (FExist) AND (FSize <> 0);
END;
PROCEDURE DisplayError(FName: ASTR; VAR FExists: Boolean);
BEGIN
NL;
PrintACR('|12ú |09The '+FName+'.* File is missing.');
PrintACR('|12ú |09Please, inform the Sysop!');
SysOpLog('The '+FName+'.* file is missing.');
FExists := FALSE;
END;
FUNCTION OneLinerAddScreens_Exists: Boolean;
VAR
FExistsH,
FExistsM,
FExistsE: Boolean;
BEGIN
FExistsH := TRUE;
FExistsM := TRUE;
FExistsE := TRUE;
(*IF (NOT ReadBuffer('ONELH')) THEN
DisplayError('ONELH',FExistsH); *)
IF (NOT ReadBuffer('ONELM')) THEN
DisplayError('ONELM',FExistsM);
(*IF (NOT ReadBuffer('ONELE')) THEN
DisplayError('ONELE',FExistsE); *)
OneLinerAddScreens_Exists := (*(FExistsH) AND *)(FExistsM) (*AND (FExistsE)*);
END;
Procedure AskOneLinerQuestions(VAR OneLinerList: OneLinerRecordType);
{Var MHeader : MHeaderRec; }
Begin
WHILE (NOT Abort) AND (NOT Hangup) DO
Begin
NL;
Print('^4 Enter your one liner');
Prt(' ^5:');
MPL(76);
InputMain(OneLinerList.OneLiner,(SizeOf(OneLinerList.OneLiner) - 1),[InterActiveEdit,ColorsAllowed]);
NL;
Abort := (OneLinerList.OneLiner = '');
IF (Abort) THEN
Exit
ELSE
OneLinerList.Anonymous := PYNQ('^4 Post Anonymous? ^5',0,FALSE);
Exit;
End;
End;
PROCEDURE OneLiner_Add;
VAR
Data2: Pointer;
OneLinerList: OneLinerRecordType;
BEGIN
IF (OneLinerAddScreens_Exists) THEN
BEGIN
NL;
OneLiner_View;
IF PYNQ('^4 Add a one liner? ^5',0, FALSE) THEN
BEGIN
FillChar(OneLinerList,SizeOf(OneLinerList),0);
AskOneLinerQuestions(OneLinerList);
IF (NOT Abort) THEN
BEGIN
PrintF('ONELH');
IF (NoFile) THEN
BEGIN
CLS; NL;
Print(Centre('^4' + General.BBSName + ' One Liners'));
Print(Centre('^5ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ'));
END;
Print(' ^4'+OneLinerList.OneLiner);
PrintF('ONELE');
IF (NoFile) THEN
Print(Centre('^5ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ'));
NL;
IF (PYNQ('^4 Add this oneliner? ^5',0,TRUE)) THEN
BEGIN
Assign(OneLinerListFile,General.DataPath+'ONELINER.DAT');
IF (Exist(General.DataPath+'ONELINER.DAT')) THEN
Reset(OneLinerListFile)
ELSE
Rewrite(OneLinerListFile);
Seek(OneLinerListFile,FileSize(OneLinerListFile));
OneLinerList.UserID := UserNum;
OneLinerList.DateAdded := GetPackDateTime;
OneLinerList.DateEdited := OneLinerList.DateAdded;
OneLinerList.RecordNum := (FileSize(OneLinerListFile) + 1);
Write(OneLinerListFile,OneLinerList);
Close(OneLinerListFile);
LastError := IOResult;
SysOpLog('Added Oneliner : '+OneLinerList.OneLiner+'.');
END;
END;
END;
END;
END;
PROCEDURE OneLiner_View;
VAR
Data2: Pointer;
OneLinerList: OneLinerRecordType;
OnRec: Longint;
Cnt : Byte;
BEGIN
IF (OneLinerList_Exists) AND (OneLinerAddScreens_Exists) THEN
BEGIN
Assign(OneLinerListFile,General.DataPath+'ONELINER.DAT');
Reset(OneLinerListFile);
ReadBuffer('ONELM');
AllowContinue := TRUE;
Abort := FALSE;
PrintF('ONELH');
IF (NoFile) THEN
BEGIN
CLS; NL;
Print(Centre('^4' + General.BBSName + ' One Liners'));
Print(Centre('^5ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ'));
NL;
END;
OnRec := 1;
Cnt := (FileSize(OneLinerListFile));
{WHILE (OnRec <= FileSize(OneLinerListFile)) AND (NOT Abort) AND (NOT HangUp) DO}
FOR Cnt := (FileSize(OneLinerListFile)) DOWNTO 1 DO
BEGIN
Seek(OneLinerListFile,(Cnt-1));
Read(OneLinerListFile,OneLinerList);
DisplayBuffer(OneLinerListMCI,@OneLinerList,Data2);
Inc(OnRec);
IF ((OnRec-1) = 10) THEN
Break
ELSE
OnRec := OnRec;
END;
Close(OneLinerListFile);
LastError := IOResult;
IF (NOT Abort) THEN
PrintF('ONELE');
IF (NoFile) THEN
Print(Centre('^5ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ'));
AllowContinue := FALSE;
SysOpLog('^5* ^4'+ ThisUser.Name + '^5 Viewed the OneLiners.');
END;
END;
Function OneLiner_Random : String;
Begin
End;
Procedure DoOneLiners; { To-Do : Variable Number of One Liners To Display }
Begin
OneLiner_Add;
End;
End.

1012
SOURCE/RECORDS.PAS Normal file
View File

File diff suppressed because it is too large Load Diff

578
SOURCE/RENEGADE.PAS Normal file
View File

@ -0,0 +1,578 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$IFDEF MSDOS}
{$M 35500,0,131072}
{$ENDIF}
{ R E N E G A D E }
{ =============== }
{$A+} { Align Data for faster execution }
{$B-} { Shortcut Boolean eval }
{$D+} { No Debug Info }
{$E-} { No Math-Co library }
{$F+} { Force Far Calls }
{$I-} { Disable I/O check }
{$L+} { Local Symbols, Ignored IF D-, don't need cause of D- }
{$N-} { No Math-Co use }
{$P+} { Allow OpenString }
{$O+} { Use Overlays? }
{$Q-} { No overflow check }
{$R-} { No range check }
{$S-} { Don't Check stack usage }
{$V-} { Variable string Length allowed }
{$X+} { Allow extended syntax }
PROGRAM Renegade;
USES
OverLay,
{ OvrUMB,}
Crt,
Dos,
Boot,
Common,
Common1,
Events,
File0,
File7,
File13,
Logon,
Mail0,
Maint,
Menus,
Menus2,
MsgPack,
MyIO,
NewUsers,
OffLine,
TimeFunc,
WfCMenu;
{$O MsgPack } {$O Common1 } {$O Common2 } {$O Common3 } {$O Boot }
{$O WfcMenu } {$O Timefunc } {$O Sysop1 } {$O Sysop2 } {$O Offline }
{$O Sysop2j } {$O Sysop2a } {$O Sysop2b } {$O Sysop2c } {$O Sysop2d }
{$O Sysop2e } {$O Sysop2f } {$O Sysop2l } {$O Sysop2g } {$O Sysop2i }
{$O Sysop2h } {$O File4 } {$O Sysop2k } {$O Sysop3 } {$O Sysop4 }
{$O Sysop6 } {$O Sysop7 } {$O Sysop7m } {$O Sysop8 } {$O Sysop2m }
{$O Sysop9 } {$O Sysop10 } {$O Sysop11 } {$O Mail0 } {$O Mail1 }
{$O Email } {$O Mail2 } {$O Mail3 } {$O Vote } {$O Nodelist }
{$O Mail4 } {$O Arcview } {$O File0 } {$O File1 } {$O File2 }
{$O File5 } {$O File6 } {$O File8 } {$O MultNode } {$O Script }
{$O File9 } {$O File10 } {$O File11 } {$O File12 } {$O File13 }
{$O File14 } {$O Archive1 } {$O Archive2 } {$O Archive3 } {$O Logon }
{$O Maint } {$O NewUsers } {$O TimeBank } {$O Bulletin } {$O MiscUser }
{$O ShortMsg } {$O CUser } {$O Doors } {$O ExecBat } {$O Automsg }
{$O MyIO } {$O Menus2 } {$O Menus3 } {$O LineChat } {$O Stats }
{$O Events } {$O BBSList } {$O Common4 } {$O File7 } {$O SplitCha }
{$O Sysop2o } {$O Sysop5 } {$O SysOp12 } {$O OneLiner }
CONST
NeedToHangUp: Boolean = FALSE;
VAR
ExitSave: Pointer;
GeneralF: FILE OF GeneralRecordType;
ByteFile: FILE OF Byte;
TextFile: Text;
S: Astr;
Counter: Byte;
Counter1: Integer;
PROCEDURE ErrorHandle;
VAR
TextFile: Text;
S: STRING[50];
BEGIN
ExitProc := ExitSave;
IF (ErrorAddr <> NIL) THEN
BEGIN
CHDir(StartDir);
IF (General.Multinode) AND (ThisNode > 0) THEN
Assign(SysOpLogFile,TempDir+'TEMPLOG.'+IntToStr(ThisNode) )
ELSE
Assign(SysOpLogFile,General.LogsPath+'SYSOP.LOG');
Append(SysOpLogFile);
S := '^8*>>^7 Runtime error '+IntToStr(ExitCode)+' at '+DateStr+' '+TimeStr+ '^8 <<*^5'+' (Check ERROR.LOG)';
WriteLn(SysOpLogFile,S);
Flush(SysOpLogFile);
Close(SysOpLogFile);
IF (TextRec(Trapfile).Mode = FMOutPut) THEN
BEGIN
WriteLn(Trapfile,S);
Flush(Trapfile);
Close(Trapfile);
END;
Assign(TextFile,'ERROR.LOG');
Append(TextFile);
IF (IOResult <> 0) THEN
ReWrite(TextFile);
WriteLn(TextFile,'ÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ');
WriteLn(TextFile,'Critical error Log file - Contains screen images at instant of error.');
WriteLn(TextFile,'The "²" character shows the cursor position at time of error.');
WriteLn(TextFile,'ÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ');
WriteLn(TextFile);
WriteLn(TextFile);
WriteLn(TextFile,'¯>¯ error #'+IntToStr(ExitCode)+' at '+DateStr+' '+TimeStr+' version: '+General.Version);
IF (UserOn) THEN
BEGIN
Write(TextFile,'¯>¯ User "'+AllCaps(ThisUser.name)+' #'+IntToStr(UserNum)+'" was on ');
IF (ComPortSpeed > 0) THEN
WriteLn(TextFile,'at '+IntToStr(ActualSpeed)+ 'baud')
ELSE
WriteLn(TextFile,'Locally');
END;
Close(TextFile);
ScreenDump('ERROR.LOG');
Assign(TextFile,'CRITICAL.ERR');
ReWrite(TextFile);
Close(TextFile);
SetFAttr(TextFile,Dos.Hidden);
Print('^8System malfunction.');
LoadNode(ThisNode);
Noder.Status := [];
Noder.User := 0;
SaveNode(ThisNode);
Com_Flush_Send;
Dtr(FALSE);
Com_DeInstall;
Halt(ExitErrors);
END;
END;
PROCEDURE ReadP;
VAR
d: astr;
Counter: Integer;
FUNCTION SC(s: astr; i: Integer): Char;
BEGIN
SC := UpCase(s[i]);
END;
BEGIN
Reliable := FALSE;
Telnet := FALSE;
CallerIDNumber := '';
Counter := 0;
WHILE (Counter < ParamCount) DO
BEGIN
Inc(Counter);
IF ((SC(ParamStr(Counter),1) = '-') OR (SC(ParamStr(Counter),1) = '/')) THEN
CASE SC(ParamStr(Counter),2) OF
'5' : TextMode(259);
'B' : AnswerBaud := StrToInt(Copy(ParamStr(Counter),3,255));
'C' : Reliable := (Pos(AllCaps(Liner.Reliable),AllCaps(ParamStr(Counter))) > 0);
'D' : OvrUseEms := FALSE;
'E' : IF (Length(ParamStr(Counter)) >= 4) THEN
BEGIN
d := AllCaps(ParamStr(Counter));
CASE d[3] OF
'E' : ExitErrors := StrToInt(Copy(d,4,(Length(d) - 3)));
'N' : ExitNormal := StrToInt(Copy(d,4,(Length(d) - 3)));
END;
END;
'H' : SockHandle := Copy(ParamStr(Counter),3,255);
'I' : BEGIN
CASE SC(ParamStr(Counter),3) OF
'D' : CallerIDNumber := Copy(ParamStr(Counter),4,255);
'P' : CallerIDNumber := Copy(ParamStr(Counter),4,255);
END;
END;
'L' : LocalIOOnly := TRUE;
'M' : BEGIN
MakeQWKFor := StrToInt(Copy(ParamStr(Counter),3,255));
LocalIOOnly := TRUE;
END;
'N' : ThisNode := StrToInt(Copy(ParamStr(Counter),3,255));
'P' : BEGIN
PackBasesOnly := TRUE;
LocalIOOnly := TRUE;
END;
'Q' : QuitAfterDone := TRUE;
'S' : BEGIN
SortFilesOnly := TRUE;
LocalIOOnly := TRUE;
END;
'F' : BEGIN
FileBBSOnly := TRUE;
LocalIOOnly := TRUE;
END;
'T' : BEGIN
IF (SC(ParamStr(Counter),3) <> 'C') THEN
HangUpTelnet := TRUE;
Telnet := TRUE;
END;
'U' : BEGIN
UpQWKFor := StrToInt(Copy(ParamStr(Counter),3,255));
LocalIOOnly := TRUE;
END;
'X' : ExtEventTime := StrToInt(Copy(ParamStr(Counter),3,255));
END;
END;
AllowAbort := TRUE;
END;
BEGIN
ClrScr;
TextColor(Yellow);
{$IFDEF MSDOS}
GetIntVec($14,Interrupt14);
{$ENDIF}
FileMode := 66;
{$IFDEF WIN32}
FileModeReadWrite := FileMode;
{$ENDIF}
ExitSave := ExitProc;
ExitProc := @ErrorHandle;
DirectVideo := FALSE;
CheckSnow := FALSE;
UserOn := FALSE;
UserNum := 0;
GetDir(0,StartDir);
DatFilePath := GetEnv('RENEGADE');
IF (DatFilePath <> '') THEN
DatFilePath := BSlash(DatFilePath,TRUE);
Assign(ByteFile,DatFilePath+'RENEGADE.DAT');
Reset(ByteFile);
IF (IOResult <> 0) THEN
BEGIN
WriteLn('Error opening RENEGADE.DAT.');
Halt;
END;
Counter := 0;
Seek(ByteFile,FileSize(ByteFile));
WHILE FileSize(ByteFile) < SizeOf(General) DO
Write(ByteFile,Counter);
Close(ByteFile);
Assign(GeneralF,DatFilePath+'RENEGADE.DAT');
Reset(GeneralF);
Read(GeneralF,General);
Close(GeneralF);
ReadP;
{$IFDEF MSDOS}
OvrFileMode := 0;
Write('Initializing RENEGADE.OVR ... ');
OvrInit('RENEGADE.OVR');
IF (OvrResult <> OvrOK) THEN
OvrInit(General.DataPath+'RENEGADE.OVR');
IF (OvrResult <> OvrOK) THEN
BEGIN
CASE OvrResult OF
OvrError : WriteLn('Program has no overlays.');
OvrNotFound : WriteLn('Overlay file not found.');
END;
Halt;
END
ELSE
WriteLn('Done.');
IF (General.UseEMS) AND (OvrUseEms) THEN
BEGIN
Write('Attempting to load overlays into XMS memory ... ');
{vrMovBufToUMB;}
IF (OvrResult <> OvrOK) THEN
BEGIN
WriteLn('Failed.');
Write('Attempting to load overlays into EMS memory ... ');
OvrInitEMS;
IF (OvrResult = OvrOK) THEN
BEGIN
WriteLn('Done.');
OverLayLocation := 1
END
ELSE
BEGIN
CASE OvrResult OF
OvrIOError : WriteLn('Overlay file I/O error.');
OvrNoEMSDriver : WriteLn('EMS driver not installed.');
OvrNoEMSMemory : WriteLn('Not enough EMS memory.');
END;
Halt;
END;
END
ELSE
BEGIN
WriteLn('Done.');
OverLayLocation := 2;
END;
END;
WriteLn('Initial size of the overlay buffer is '+FormatNumber(OvrGetBuf)+' bytes.');
{$ENDIF}
Init;
MaxDisplayRows := (Hi(WindMax) + 1);
MaxDisplayCols := (Lo(WindMax) + 1);
ScreenSize := 2 * MaxDisplayRows * MaxDisplayCols;
IF (ScreenSize > 8000) THEN
ScreenSize := 8000;
IF (FileBBSOnly) OR (PackBasesOnly) OR (SortFilesOnly) OR (MakeQWKFor > 0) OR (UpQWKFor > 0) THEN
BEGIN
WFCMDefine;
TempPause := FALSE;
IF (MakeQWKFor > 0) THEN
BEGIN
UserNum := MakeQWKFor;
LoadURec(ThisUser,MakeQWKFor);
NewFileDate := ThisUser.LastOn;
Downloadpacket;
SaveURec(ThisUser,MakeQWKFor);
END;
IF (UpQWKFor > 0) THEN
BEGIN
UserNum := UpQWKFor;
LoadURec(ThisUser,UpQWKFor);
Uploadpacket(TRUE);
SaveURec(ThisUser,UpQWKFor);
END;
IF (PackBasesOnly) THEN
BEGIN
DoShowPackMessageAreas;
NL;
Print('^5Message areas packed.');
END;
IF (SortFilesOnly) THEN
Sort;
IF (FileBBSOnly) THEN
CheckFilesBBS;
Halt(0);
END;
GetMem(MemCmd,MaxCmds * SizeOf(MemCmdRec));
REPEAT
IF (NeedToHangUp) THEN
BEGIN
NeedToHangUp := FALSE;
DoPhoneHangUp(FALSE);
END;
WFCMenus;
UserOn := FALSE;
UserNum := 0;
IF (NOT DoneDay) THEN
BEGIN
lStatus_Screen(100,'User logging in.',FALSE,S);
LastScreenSwap := 0;
IF (GetUser) THEN
NewUser;
IF (NOT HangUp) THEN
BEGIN
NumBatchDLFiles := 0;
NumBatchULFiles := 0;
BatchDLPoints := 0;
BatchDLSize := 0;
BatchDLTime := 0;
LogonMaint;
IF (NOT HangUp) THEN
BEGIN
NewFileDate := ThisUser.LastOn;
IF (MsgAreaAC(ThisUser.LastMsgArea)) THEN
MsgArea := ThisUser.LastMsgArea
ELSE
BEGIN
FOR Counter := 1 TO NumMsgAreas DO
IF (MsgAreaAC(Counter)) THEN
BEGIN
MsgArea := Counter;
Counter := NumMsgAreas;
END;
END;
IF (FileAreaAC(ThisUser.LastFileArea)) THEN
FileArea := ThisUser.LastFileArea
ELSE
BEGIN
FOR Counter := 1 TO NumFileAreas DO
IF (FileAreaAC(Counter)) THEN
BEGIN
FileArea := Counter;
Counter := NumFileAreas;
END;
END;
NewCompTables;
MenuStackPtr := 0;
FOR Counter := 1 TO MaxMenus DO
MenuStack[Counter] := 0;
IF (Novice in ThisUser.Flags) THEN
CurHelpLevel := 2
ELSE
CurHelpLevel := 1;
GlobalCmds := 0;
NumCmds := 0;
CurMenu := 0;
FallBackMenu := 0;
IF (General.GlobalMenu <> 0) THEN
BEGIN
CurMenu := General.GlobalMenu;
LoadMenu;
GlobalCmds := NumCmds;
END;
IF (ThisUser.UserStartMenu = 0) THEN
CurMenu := General.AllStartMenu
ELSE
CurMenu := ThisUser.UserStartMenu;
LoadMenu;
AutoExecCmd('FIRSTCMD');
END;
WHILE (NOT HangUp) DO
MenuExec;
END;
IF (QuitAfterDone) THEN
BEGIN
IF (ExitErrorLevel = 0) THEN
ExitErrorLevel := ExitNormal;
HangUp := TRUE;
DoneDay := TRUE;
NeedToHangUp := TRUE;
END;
LogOffMaint;
IF (General.Multinode) THEN
BEGIN
Assign(TextFile,General.LogsPath+'SYSOP.LOG');
IF Exist(General.LogsPath+'SYSOP.LOG') THEN
Append(TextFile)
ELSE
ReWrite(TextFile);
Reset(SysOpLogFile);
WHILE NOT EOF(SysOpLogFile) DO
BEGIN
ReadLn(SysOpLogFile,S);
WriteLn(TextFile,S);
END;
Close(SysOpLogFile);
Close(TextFile);
ReWrite(SysOpLogFile);
Close(SysOpLogFile);
LastError := IOResult;
END;
IF (Com_Carrier) AND (NOT DoneDay) THEN
IF (InCom) THEN
NeedToHangUp := TRUE;
END;
UNTIL (DoneDay);
FreeMem(MemCmd,MaxCmds * SizeOf(MemCmdRec));
IF (MCIBuffer <> NIL) THEN
Dispose(MCIBuffer);
IF (MemEventArray[NumEvents] <> NIL) THEN
FOR Counter1 := 1 TO NumEvents DO
IF (MemEventArray[Counter1] <> NIL) THEN
Dispose(MemEventArray[Counter1]);
IF (NeedToHangUp) THEN
BEGIN
IF (HangUpTelnet) THEN
DoTelnetHangUp(TRUE);
IF (NOT HangUpTelnet) THEN
DoPhoneHangUp(FALSE);
END;
IF (General.Multinode) THEN
BEGIN
Assign(TextFile,General.LogsPath+'SYSOP.LOG');
IF Exist(General.LogsPath+'SYSOP.LOG') THEN
Append(TextFile)
ELSE
ReWrite(TextFile);
Reset(SysOpLogFile);
WHILE NOT EOF(SysOpLogFile) DO
BEGIN
ReadLn(SysOpLogFile,S);
WriteLn(TextFile,S);
END;
Close(SysOpLogFile);
Close(TextFile);
ReWrite(SysOpLogFile);
Close(SysOpLogFile);
LastError := IOResult;
END;
IF (General.Multinode) THEN
Kill(TempDir+'TEMPLOG.'+IntToStr(ThisNode));
Window(1,1,MaxDisplayCols,MaxDisplayRows);
TextBackGround(0);
TextColor(7);
ClrScr;
TextColor(14);
IF (NewEchoMail) AND (ExitErrorLevel = 0) THEN
ExitErrorLevel := 2;
LoadNode(ThisNode);
Noder.Status := [];
SaveNode(ThisNode);
PurgeDir(TempDir,FALSE);
Com_DeInstall;
WriteLn('Exiting with errorlevel ',ExitErrorLevel);
Halt(ExitErrorLevel);
END.

2218
SOURCE/RENEMAIL.PAS Normal file
View File

File diff suppressed because it is too large Load Diff

927
SOURCE/RGLNG.PAS Normal file
View File

@ -0,0 +1,927 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
PROGRAM RGLNG;
USES
Crt,
Dos;
TYPE
StrPointerRec = RECORD
Pointer,
TextSize: LongInt;
END;
VAR
RGStrFile: FILE;
StrPointerFile: FILE OF StrPointerRec;
StrPointer: StrPointerRec;
F: Text;
S: STRING;
RGStrNum: LongInt;
Done,
Found: Boolean;
FUNCTION AllCaps(S: STRING): STRING;
VAR
I: Integer;
BEGIN
FOR I := 1 TO Length(S) DO
IF (S[I] IN ['a'..'z']) THEN
S[I] := Chr(Ord(S[I]) - Ord('a')+Ord('A'));
AllCaps := S;
END;
FUNCTION SQOutSp(S: STRING): STRING;
BEGIN
WHILE (Pos(' ',S) > 0) DO
Delete(s,Pos(' ',S),1);
SQOutSp := S;
END;
FUNCTION Exist(FN: STRING): Boolean;
VAR
DirInfo: SearchRec;
BEGIN
FindFirst(SQOutSp(FN),AnyFile,DirInfo);
Exist := (DOSError = 0);
END;
PROCEDURE CompileLanguageStrings;
BEGIN
WriteLn;
Write('Compiling language strings ... ');
Found := TRUE;
Assign(StrPointerFile,'RGLNGPR.DAT');
ReWrite(StrPointerFile);
Assign(RGStrFile,'RGLNGTX.DAT');
ReWrite(RGStrFile,1);
Assign(F,'RGLNG.TXT');
Reset(F);
WHILE NOT EOF(F) AND (Found) DO
BEGIN
ReadLn(F,S);
IF (S <> '') AND (S[1] = '$') THEN
BEGIN
Delete(S,1,1);
S := AllCaps(S);
RGStrNum := -1;
IF (S = 'ANONYMOUS_STRING') THEN
RGStrNum := 0
ELSE IF (S = 'ECHO_CHAR_FOR_PASSWORDS') THEN
RGStrNum := 1
ELSE IF (S = 'ENGAGE_CHAT') THEN
RGStrNum := 2
ELSE IF (S = 'END_CHAT') THEN
RGStrNum := 3
ELSE IF (S = 'SYSOP_WORKING') THEN
RGStrNum := 4
ELSE IF (S = 'PAUSE') THEN
RGStrNum := 5
ELSE IF (S = 'ENTER_MESSAGE_LINE_ONE') THEN
RGStrNum := 6
ELSE IF (S = 'ENTER_MESSAGE_LINE_TWO') THEN
RGStrNum := 7
ELSE IF (S = 'NEWSCAN_BEGIN') THEN
RGStrNum := 8
ELSE IF (S = 'NEWSCAN_DONE') THEN
RGStrNum := 9
ELSE IF (S = 'AUTO_MESSAGE_TITLE') THEN
RGStrNum := 10
ELSE IF (S = 'AUTO_MESSAGE_BORDER_CHARACTERS') THEN
RGStrNum := 11
ELSE IF (S = 'SYSOP_SHELLING_TO_DOS') THEN
RGStrNum := 12
ELSE IF (S = 'READ_MAIL') THEN
RGStrNum := 13
ELSE IF (S = 'PAGING_SYSOP') THEN
RGStrNum := 14
ELSE IF (S = 'CHAT_CALL') THEN
RGStrNum := 15
ELSE IF (S = 'BULLETIN_PROMPT') THEN
RGstrNum := 16
ELSE IF (S = 'PROTOCOL_PROMPT') THEN
RGStrNum := 17
ELSE IF (S = 'LIST_FILES') THEN
RGStrNum := 18
ELSE IF (S = 'SEARCH_FOR_NEW_FILES') THEN
RGStrNum := 19
ELSE IF (S = 'SEARCH_ALL_DIRS_FOR_FILE_MASK') THEN
RGStrNum := 20
ELSE IF (S = 'SEARCH_FOR_DESCRIPTIONS') THEN
RGStrNum := 21
ELSE IF (S = 'ENTER_THE_STRING_TO_SEARCH_FOR') THEN
RGStrNum := 22
ELSE IF (S = 'DOWNLOAD') THEN
RGStrNum := 23
ELSE IF (S = 'UPLOAD') THEN
RGStrNum := 24
ELSE IF (S = 'VIEW_INTERIOR_FILES') THEN
RGStrNum := 25
ELSE IF (S = 'INSUFFICIENT_FILE_CREDITS') THEN
RGStrNum := 26
ELSE IF (S = 'RATIO_IS_UNBALANCED') THEN
RGStrNum := 27
ELSE IF (S = 'ALL_FILES') THEN
RGStrNum := 28
ELSE IF (S = 'FILE_MASK') THEN
RGStrNum := 29
ELSE IF (S = 'FILE_ADDED_TO_BATCH_QUEUE') THEN
RGStrNum := 30
ELSE IF (S = 'BATCH_DOWNLOAD_FLAGGING') THEN
RGStrNum := 31
ELSE IF (S = 'READ_QUESTION_PROMPT') THEN
RGStrNum := 32
ELSE IF (S = 'SYSTEM_PASSWORD_PROMPT') THEN
RGStrNum := 33
ELSE IF (S = 'DEFAULT_MESSAGE_TO') THEN
RGStrNum := 34
ELSE IF (S = 'NEWSCAN_ALL') THEN
RGStrNum := 35
ELSE IF (S = 'NEWSCAN_DONE') THEN
RGStrNum := 36
ELSE IF (S = 'CHAT_REASON') THEN
RGStrNum := 37
ELSE IF (S = 'USER_DEFINED_QUESTION_ONE') THEN
RGStrNum := 38
ELSE IF (S = 'USER_DEFINED_QUESTION_TWO') THEN
RGStrNum := 39
ELSE IF (S = 'USER_DEFINED_QUESTION_THREE') THEN
RGStrNum := 40
ELSE IF (S = 'USER_DEFINED_QUESTION_EDITOR_ONE') THEN
RGStrNum := 41
ELSE IF (S = 'USER_DEFINED_QUESTION_EDITOR_TWO') THEN
RGStrNum := 42
ELSE IF (S = 'USER_DEFINED_QUESTION_EDITOR_THREE') THEN
RGStrNum := 43
ELSE IF (S = 'CONTINUE_PROMPT') THEN
RGStrNum := 44
ELSE IF (S = 'INVISIBLE_LOGIN') THEN
RGStrNum := 45
ELSE IF (S = 'CANT_EMAIL') THEN
RGStrNum := 46
ELSE IF (S = 'SEND_EMAIL') THEN
RGStrNum := 47
ELSE IF (S = 'SENDING_MASS_MAIL_TO') THEN
RGStrNum := 48
ELSE IF (S = 'SENDING_MASS_MAIL_TO_ALL_USERS') THEN
RGStrNum := 49
ELSE IF (S = 'NO_NETMAIL') THEN
RGStrNum := 50
ELSE IF (S = 'NETMAIL_PROMPT') THEN
RGStrNum := 51
ELSE IF (S = 'NO_MAIL_WAITING') THEN
RGStrNum := 52
ELSE IF (S = 'MUST_READ_MESSAGE') THEN
RGStrNum := 53
ELSE IF (S = 'SCAN_FOR_NEW_FILES') THEN
RGStrNum := 54
ELSE IF (S = 'NEW_SCAN_CHAR_FILE') THEN
RGStrNum := 55
ELSE IF (S = 'BULLETINS_PROMPT') THEN
RGStrNum := 56
ELSE IF (S = 'QUICK_LOGON') THEN
RGStrNum := 57
ELSE IF (S = 'MESSAGE_AREA_SELECT_HEADER') THEN
RGStrNum := 58
ELSE IF (S = 'FILE_AREA_SELECT_HEADER') THEN
RGStrNum := 59
ELSE IF (S = 'RECEIVE_EMAIL_HEADER') THEN
RGStrNum := 60
ELSE IF (S = 'VOTE_LIST_TOPICS_HEADER') THEN
RGStrNum := 61
ELSE IF (S = 'VOTE_TOPIC_RESULT_HEADER') THEN
RGStrNum := 62
ELSE IF (S = 'FILE_AREA_NAME_HEADER_NO_RATIO') THEN
RGStrNum := 63
ELSE IF (S = 'FILE_AREA_NAME_HEADER_RATIO') THEN
RGStrNum := 64
ELSE IF (S = 'SYSOP_CHAT_HELP') THEN
RGStrNum := 65
ELSE IF (S = 'NEW_SCAN_CHAR_MESSAGE') THEN
RGStrNum := 66
ELSE IF (S = 'FILE_AREA_SELECT_NO_FILES') THEN
RGStrNum := 67
ELSE IF (S = 'MESSAGE_AREA_SELECT_NO_FILES') THEN
RGStrNum := 68
ELSE IF (S = 'MESSAGE_AREA_LIST_PROMPT') THEN
RGStrNum := 69
ELSE IF (S = 'FILE_AREA_LIST_PROMPT') THEN
RGStrNum := 70
ELSE IF (S = 'FILE_MESSAGE_AREA_LIST_HELP') THEN
RGStrNum := 71
ELSE IF (S = 'FILE_AREA_CHANGE_PROMPT') THEN
RGStrNum := 72
ELSE IF (S = 'MESSAGE_AREA_CHANGE_PROMPT') THEN
RGStrNum := 73
ELSE IF (S = 'FILE_AREA_NEW_SCAN_TOGGLE_PROMPT') THEN
RGStrNum := 74
ELSE IF (S = 'MESSAGE_AREA_NEW_SCAN_TOGGLE_PROMPT') THEN
RGStrNum := 75
ELSE IF (S = 'FILE_AREA_MOVE_FILE_PROMPT') THEN
RGStrNum := 76
ELSE IF (S = 'MESSAGE_AREA_MOVE_MESSAGE_PROMPT') THEN
RGStrNum := 77
ELSE IF (S = 'FILE_AREA_CHANGE_MIN_MAX_ERROR') THEN
RGStrNum := 78
ELSE IF (S = 'MESSAGE_AREA_CHANGE_MIN_MAX_ERROR') THEN
RGStrNum := 79
ELSE IF (S = 'FILE_AREA_CHANGE_NO_AREA_ACCESS') THEN
RGStrNum := 80
ELSE IF (S = 'MESSAGE_AREA_CHANGE_NO_AREA_ACCESS') THEN
RGStrNum := 81
ELSE IF (S = 'FILE_AREA_CHANGE_LOWEST_AREA') THEN
RGStrNum := 82
ELSE IF (S = 'FILE_AREA_CHANGE_HIGHEST_AREA') THEN
RGStrNum := 83
ELSE IF (S = 'MESSAGE_AREA_CHANGE_LOWEST_AREA') THEN
RGStrNum := 84
ELSE IF (S = 'MESSAGE_AREA_CHANGE_HIGHEST_AREA') THEN
RGStrNum := 85
ELSE IF (S = 'FILE_AREA_NEW_SCAN_SCANNING_ALL_AREAS') THEN
RGStrNum := 86
ELSE IF (S = 'MESSAGE_AREA_NEW_SCAN_SCANNING_ALL_AREAS') THEN
RGStrNum := 87
ELSE IF (S = 'FILE_AREA_NEW_SCAN_NOT_SCANNING_ALL_AREAS') THEN
RGStrNum := 88
ELSE IF (S = 'MESSAGE_AREA_NEW_SCAN_NOT_SCANNING_ALL_AREAS') THEN
RGStrNum := 89
ELSE IF (S = 'FILE_AREA_NEW_SCAN_MIN_MAX_ERROR') THEN
RGStrNum := 90
ELSE IF (S = 'MESSAGE_AREA_NEW_SCAN_MIN_MAX_ERROR') THEN
RGStrNum := 91
ELSE IF (S = 'FILE_AREA_NEW_SCAN_AREA_ON_OFF') THEN
RGStrNum := 92
ELSE IF (S = 'MESSAGE_AREA_NEW_SCAN_AREA_ON_OFF') THEN
RGStrNum := 93
ELSE IF (S = 'MESSAGE_AREA_NEW_SCAN_AREA_NOT_REMOVED') THEN
RGStrNum := 94;
IF (RGStrNum = -1) THEN
BEGIN
WriteLn('Error!');
WriteLn;
WriteLn(^G^G^G'The following string definition is invalid:');
WriteLn;
WriteLn(' '+S);
Found := FALSE;
END
ELSE
BEGIN
Done := FALSE;
WITH StrPointer DO
BEGIN
Pointer := (FileSize(RGStrFile) + 1);
TextSize := 0;
END;
Seek(RGStrFile,FileSize(RGStrFile));
WHILE NOT EOF(F) AND (NOT Done) DO
BEGIN
ReadLn(F,S);
IF (S[1] = '$') THEN
Done := TRUE
ELSE
BEGIN
Inc(StrPointer.TextSize,(Length(S) + 1));
BlockWrite(RGStrFile,S,(Length(S) + 1));
END;
END;
Seek(StrPointerFile,RGStrNum);
Write(StrPointerFile,StrPointer);
END;
END;
END;
Close(F);
Close(RGStrFile);
Close(StrPointerFile);
IF (Found) THEN
WriteLn('Done!')
ELSE
BEGIN
Erase(StrPointerFile);
Erase(RGStrFile);
END;
END;
PROCEDURE CompileMainStrings;
BEGIN
WriteLn;
Write('Compiling main strings ... ');
Found := TRUE;
Assign(StrPointerFile,'RGMAINPR.DAT');
ReWrite(StrPointerFile);
Assign(RGStrFile,'RGMAINTX.DAT');
ReWrite(RGStrFile,1);
Assign(F,'RGMAIN.TXT');
Reset(F);
WHILE NOT EOF(F) AND (Found) DO
BEGIN
ReadLn(F,S);
IF (S <> '') AND (S[1] = '$') THEN
BEGIN
Delete(S,1,1);
S := AllCaps(S);
RGStrNum := -1;
IF (S = 'BAUD_OVERRIDE_PW') THEN
RGStrNum := 0
ELSE IF (S = 'CALLER_LOGON') THEN
RGStrNum := 1
ELSE IF (S = 'LOGON_AS_NEW') THEN
RGStrNum := 2
ELSE IF (S = 'USER_LOGON_PASSWORD') THEN
RGStrNum := 3
ELSE IF (S = 'USER_LOGON_PHONE_NUMBER') THEN
RGStrNum := 4
ELSE IF (S = 'SYSOP_LOGON_PASSWORD') THEN
RGStrNum := 5
ELSE IF (S = 'FORGOT_PW_QUESTION') THEN
RGStrNum := 6
ELSE IF (S = 'VERIFY_BIRTH_DATE') THEN
RGStrNum := 7
ELSE IF (S = 'LOGON_WITHDRAW_BANK') THEN
RGStrNum := 8
ELSE IF (S = 'SHUTTLE_LOGON') THEN
RGStrNum := 9
ELSE IF (S = 'NEW_USER_PASSWORD') THEN
RGStrNum := 10;
IF (RGStrNum = -1) THEN
BEGIN
WriteLn('Error!');
WriteLn;
WriteLn(^G^G^G'The following string definition is invalid:');
WriteLn;
WriteLn(' '+S);
Found := FALSE;
END
ELSE
BEGIN
Done := FALSE;
WITH StrPointer DO
BEGIN
Pointer := (FileSize(RGStrFile) + 1);
TextSize := 0;
END;
Seek(RGStrFile,FileSize(RGStrFile));
WHILE NOT EOF(F) AND (NOT Done) DO
BEGIN
ReadLn(F,S);
IF (S[1] = '$') THEN
Done := TRUE
ELSE
BEGIN
Inc(StrPointer.TextSize,(Length(S) + 1));
BlockWrite(RGStrFile,S,(Length(S) + 1));
END;
END;
Seek(StrPointerFile,RGStrNum);
Write(StrPointerFile,StrPointer);
END;
END;
END;
Close(F);
Close(RGStrFile);
Close(StrPointerFile);
IF (Found) THEN
WriteLn('Done!')
ELSE
BEGIN
Erase(StrPointerFile);
Erase(RGStrFile);
END;
END;
PROCEDURE CompileNoteStrings;
BEGIN
WriteLn;
Write('Compiling Note strings ... ');
Found := TRUE;
Assign(StrPointerFile,'RGNOTEPR.DAT');
ReWrite(StrPointerFile);
Assign(RGStrFile,'RGNOTETX.DAT');
ReWrite(RGStrFile,1);
Assign(F,'RGNOTE.TXT');
Reset(F);
WHILE NOT EOF(F) AND (Found) DO
BEGIN
ReadLn(F,S);
IF (S <> '') AND (S[1] = '$') THEN
BEGIN
Delete(S,1,1);
S := AllCaps(S);
RGStrNum := -1;
IF (S = 'INTERNAL_USE_ONLY') THEN
RGStrNum := 0
ELSE IF (S = 'ONLY_CHANGE_LOCALLY') THEN
RGStrNum := 1
ELSE IF (S = 'INVALID_MENU_NUMBER') THEN
RGStrNum := 2
ELSE IF (S = 'MINIMUM_BAUD_LOGON_PW') THEN
RGStrNum := 3
ELSE IF (S = 'MINIMUM_BAUD_LOGON_HIGH_LOW_TIME_PW') THEN
RGStrNum := 4
ELSE IF (S = 'MINIMUM_BAUD_LOGON_HIGH_LOW_TIME_NO_PW') THEN
RGStrNum := 5
ELSE IF (S = 'LOGON_EVENT_RESTRICTED_1') THEN
RGStrNum := 6
ELSE IF (S = 'LOGON_EVENT_RESTRICTED_2') THEN
RGStrNum := 7
ELSE IF (S = 'NAME_NOT_FOUND') THEN
RGStrNum := 8
ELSE IF (S = 'ILLEGAL_LOGON') THEN
RGStrNum := 9
ELSE IF (S = 'LOGON_NODE_ACS') THEN
RGStrNum := 10
ELSE IF (S = 'LOCKED_OUT') THEN
RGStrNum := 11
ELSE IF (S = 'LOGGED_ON_ANOTHER_NODE') THEN
RGStrNum := 12
ELSE IF (S = 'INCORRECT_BIRTH_DATE') THEN
RGStrNum := 13
ELSE IF (S = 'INSUFFICIENT_LOGON_CREDITS') THEN
RGStrNum := 14
ELSE IF (S = 'LOGON_ONCE_PER_DAY') THEN
RGStrNum := 15
ELSE IF (S = 'LOGON_CALLS_ALLOWED_PER_DAY') THEN
RGStrNum := 16
ELSE IF (S = 'LOGON_TIME_ALLOWED_PER_DAY_OR_CALL') THEN
RGStrNum := 17
ELSE IF (S = 'LOGON_MINUTES_LEFT_IN_BANK') THEN
RGStrNum := 18
ELSE IF (S = 'LOGON_MINUTES_LEFT_IN_BANK_TIME_LEFT') THEN
RGStrNum := 19
ELSE IF (S = 'LOGON_BANK_HANGUP') THEN
RGStrNum := 20
ELSE IF (S = 'LOGON_ATTEMPT_IEMSI_NEGOTIATION') THEN
RGStrNum := 21
ELSE IF (S = 'LOGON_IEMSI_NEGOTIATION_SUCCESS') THEN
RGStrNum := 22
ELSE IF (S = 'LOGON_IEMSI_NEGOTIATION_FAILED') THEN
RGStrNum := 23
ELSE IF (S = 'LOGON_ATTEMPT_DETECT_EMULATION') THEN
RGStrNum := 24
ELSE IF (S = 'LOGON_RIP_DETECTED') THEN
RGStrNum := 25
ELSE IF (S = 'LOGON_ANSI_DETECT_OTHER') THEN
RGStrNum := 26
ELSE IF (S = 'LOGON_ANSI_DETECT') THEN
RGStrNum := 27
ELSE IF (S = 'LOGON_AVATAR_DETECT_OTHER') THEN
RGStrNum := 28
ELSE IF (S = 'LOGON_AVATAR_DETECT') THEN
RGStrNum := 29
ELSE IF (S = 'LOGON_EMULATION_DETECTED') THEN
RGStrNum := 30
ELSE IF (S = 'SHUTTLE_LOGON_VALIDATION_STATUS') THEN
RGStrNum := 31
ELSE IF (S = 'LOGON_CLOSED_BBS') THEN
RGStrNum := 32
ELSE IF (S = 'NODE_ACTIVITY_WAITING_ONE') THEN
RGStrNum := 33
ELSE IF (S = 'NODE_ACTIVITY_WAITING_TWO') THEN
RGStrNum := 34
ELSE IF (S = 'NODE_ACTIVITY_LOGGING_ON') THEN
RGStrNum := 35
ELSE IF (S = 'NODE_ACTIVITY_NEW_USER_LOGGING_ON') THEN
RGStrNum := 36
ELSE IF (S = 'NODE_ACTIVITY_MISCELLANEOUS') THEN
RGStrNum := 37
ELSE IF (S = 'NEW_USER_PASSWORD_INVALID') THEN
RGStrNum := 38
ELSE IF (S = 'NEW_USER_PASSWORD_ATTEMPT_EXCEEDED') THEN
RGStrNum := 39
ELSE IF (S = 'NEW_USER_RECORD_SAVING') THEN
RGStrNum := 40
ELSE IF (S = 'NEW_USER_RECORD_SAVED') THEN
RGStrNum := 41
ELSE IF (S = 'NEW_USER_APPLICATION_LETTER') THEN
RGStrNum := 42
ELSE IF (S = 'NEW_USER_IN_RESPONSE_TO_SUBJ') THEN
RGStrNum := 43;
IF (RGStrNum = -1) THEN
BEGIN
WriteLn('Error!');
WriteLn;
WriteLn(^G^G^G'The following string definition is invalid:');
WriteLn;
WriteLn(' '+S);
Found := FALSE;
END
ELSE
BEGIN
Done := FALSE;
WITH StrPointer DO
BEGIN
Pointer := (FileSize(RGStrFile) + 1);
TextSize := 0;
END;
Seek(RGStrFile,FileSize(RGStrFile));
WHILE NOT EOF(F) AND (NOT Done) DO
BEGIN
ReadLn(F,S);
IF (S[1] = '$') THEN
Done := TRUE
ELSE
BEGIN
Inc(StrPointer.TextSize,(Length(S) + 1));
BlockWrite(RGStrFile,S,(Length(S) + 1));
END;
END;
Seek(StrPointerFile,RGStrNum);
Write(StrPointerFile,StrPointer);
END;
END;
END;
Close(F);
Close(RGStrFile);
Close(StrPointerFile);
IF (Found) THEN
WriteLn('Done!')
ELSE
BEGIN
Erase(StrPointerFile);
Erase(RGStrFile);
END;
END;
PROCEDURE CompileSysOpStrings;
BEGIN
WriteLn;
Write('Compiling sysop strings ... ');
Found := TRUE;
Assign(StrPointerFile,'RGSCFGPR.DAT');
ReWrite(StrPointerFile);
Assign(RGStrFile,'RGSCFGTX.DAT');
ReWrite(RGStrFile,1);
Assign(F,'RGSCFG.TXT');
Reset(F);
WHILE NOT EOF(F) AND (Found) DO
BEGIN
ReadLn(F,S);
IF (S <> '') AND (S[1] = '$') THEN
BEGIN
Delete(S,1,1);
S := AllCaps(S);
RGStrNum := -1;
IF (S = 'SYSTEM_CONFIGURATION_MENU') THEN
RGStrNum := 0
ELSE IF (S = 'MAIN_BBS_CONFIGURATION') THEN
RGStrNum := 1
ELSE IF (S = 'MAIN_BBS_CONFIGURATION_BBS_NAME') THEN
RGStrNum := 2
ELSE IF (S = 'MAIN_BBS_CONFIGURATION_BBS_PHONE') THEN
RGStrNum := 3
ELSE IF (S = 'MAIN_BBS_CONFIGURATION_TELNET_URL') THEN
RGStrNum := 4
ELSE IF (S = 'MAIN_BBS_CONFIGURATION_SYSOP_NAME') THEN
RGStrNum := 5
ELSE IF (S = 'MAIN_BBS_CONFIGURATION_SYSOP_CHAT_HOURS') THEN
RGStrNum := 6
ELSE IF (S = 'MAIN_BBS_CONFIGURATION_MINIMUM_BAUD_HOURS') THEN
RGStrNum := 7
ELSE IF (S = 'MAIN_BBS_CONFIGURATION_DOWNLOAD_HOURS') THEN
RGStrNum := 8
ELSE IF (S = 'MAIN_BBS_CONFIGURATION_MINIMUM_BAUD_DOWNLOAD_HOURS') THEN
RGStrNum := 9
ELSE IF (S = 'MAIN_BBS_CONFIGURATION_SYSOP_PASSWORD_MENU') THEN
RGStrNum := 10
ELSE IF (S = 'MAIN_BBS_CONFIGURATION_SYSOP_PASSWORD') THEN
RGStrNum := 11
ELSE IF (S = 'MAIN_BBS_CONFIGURATION_NEW_USER_PASSWORD') THEN
RGStrNum := 12
ELSE IF (S = 'MAIN_BBS_CONFIGURATION_BAUD_OVERRIDE_PASSWORD') THEN
RGStrNum := 13
ELSE IF (S = 'MAIN_BBS_CONFIGURATION_PRE_EVENT_TIME') THEN
RGStrNum := 14
ELSE IF (S = 'MAIN_BBS_CONFIGURATION_SYSTEM_MENUS') THEN
RGStrNum := 15
ELSE IF (S = 'MAIN_BBS_CONFIGURATION_SYSTEM_MENUS_GLOBAL') THEN
RGStrNum := 16
ELSE IF (S = 'MAIN_BBS_CONFIGURATION_SYSTEM_MENUS_START') THEN
RGStrNum := 17
ELSE IF (S = 'MAIN_BBS_CONFIGURATION_SYSTEM_MENUS_SHUTTLE') THEN
RGStrNum := 18
ELSE IF (S = 'MAIN_BBS_CONFIGURATION_SYSTEM_MENUS_NEW_USER') THEN
RGStrNum := 19
ELSE IF (S = 'MAIN_BBS_CONFIGURATION_SYSTEM_MENUS_MESSAGE_READ') THEN
RGStrNum := 20
ELSE IF (S = 'MAIN_BBS_CONFIGURATION_SYSTEM_MENUS_FILE_LISTING') THEN
RGStrNum := 21
ELSE IF (S = 'MAIN_BBS_CONFIGURATION_BULLETIN_PREFIX') THEN
RGStrNum := 22
ELSE IF (S = 'MAIN_BBS_CONFIGURATION_LOCAL_SECURITY') THEN
RGStrNum := 23
ELSE IF (S = 'MAIN_BBS_CONFIGURATION_DATA_PATH') THEN
RGStrNum := 24
ELSE IF (S = 'MAIN_BBS_CONFIGURATION_MISC_PATH') THEN
RGStrNum := 25
ELSE IF (S = 'MAIN_BBS_CONFIGURATION_MSG_PATH') THEN
RGStrNum := 26
ELSE IF (S = 'MAIN_BBS_CONFIGURATION_NODELIST_PATH') THEN
RGStrNum := 27
ELSE IF (S = 'MAIN_BBS_CONFIGURATION_LOG_PATH') THEN
RGStrNum := 28
ELSE IF (S = 'MAIN_BBS_CONFIGURATION_TEMP_PATH') THEN
RGStrNum := 29
ELSE IF (S = 'MAIN_BBS_CONFIGURATION_PROTOCOL_PATH') THEN
RGStrNum := 30
ELSE IF (S = 'MAIN_BBS_CONFIGURATION_ARCHIVE_PATH') THEN
RGStrNum := 31
ELSE IF (S = 'MAIN_BBS_CONFIGURATION_ATTACH_PATH') THEN
RGStrNum := 32
ELSE IF (S = 'MAIN_BBS_CONFIGURATION_STRING_PATH') THEN
RGStrNum := 33;
IF (RGStrNum = -1) THEN
BEGIN
WriteLn('Error!');
WriteLn;
WriteLn(^G^G^G'The following string definition is invalid:');
WriteLn;
WriteLn(' '+S);
Found := FALSE;
END
ELSE
BEGIN
Done := FALSE;
WITH StrPointer DO
BEGIN
Pointer := (FileSize(RGStrFile) + 1);
TextSize := 0;
END;
Seek(RGStrFile,FileSize(RGStrFile));
WHILE NOT EOF(F) AND (NOT Done) DO
BEGIN
ReadLn(F,S);
IF (S[1] = '$') THEN
Done := TRUE
ELSE
BEGIN
Inc(StrPointer.TextSize,(Length(S) + 1));
BlockWrite(RGStrFile,S,(Length(S) + 1));
END;
END;
Seek(StrPointerFile,RGStrNum);
Write(StrPointerFile,StrPointer);
END;
END;
END;
Close(F);
Close(RGStrFile);
Close(StrPointerFile);
IF (Found) THEN
WriteLn('Done!')
ELSE
BEGIN
Erase(StrPointerFile);
Erase(RGStrFile);
END;
END;
PROCEDURE CompileFileAreaEditorStrings;
BEGIN
WriteLn;
Write('Compiling file area editor strings ... ');
Found := TRUE;
Assign(StrPointerFile,'FAEPR.DAT');
ReWrite(StrPointerFile);
Assign(RGStrFile,'FAETX.DAT');
ReWrite(RGStrFile,1);
Assign(F,'FAELNG.TXT');
Reset(F);
WHILE NOT EOF(F) AND (Found) DO
BEGIN
ReadLn(F,S);
IF (S <> '') AND (S[1] = '$') THEN
BEGIN
Delete(S,1,1);
S := AllCaps(S);
RGStrNum := -1;
IF (S = 'FILE_AREA_HEADER_TOGGLE_ONE') THEN
RGStrNum := 0
ELSE IF (S = 'FILE_AREA_HEADER_TOGGLE_TWO') THEN
RGStrNum := 1
ELSE IF (S = 'FILE_AREA_HEADER_NO_FILE_AREAS') THEN
RGStrNum := 2
ELSE IF (S = 'FILE_AREA_EDITOR_PROMPT') THEN
RGStrNum := 3
ELSE IF (S = 'FILE_AREA_EDITOR_HELP') THEN
RGStrNum := 4
ELSE IF (S = 'NO_FILE_AREAS') THEN
RGStrNum := 5
ELSE IF (S = 'FILE_CHANGE_DRIVE_START') THEN
RGStrNum := 6
ELSE IF (S = 'FILE_CHANGE_DRIVE_END') THEN
RGStrNum := 7
ELSE IF (S = 'FILE_CHANGE_DRIVE_DRIVE') THEN
RGStrNum := 8
ELSE IF (S = 'FILE_CHANGE_INVALID_ORDER') THEN
RGStrNum := 9
ELSE IF (S = 'FILE_CHANGE_INVALID_DRIVE') THEN
RGStrNum := 10
ELSE IF (S = 'FILE_CHANGE_UPDATING_DRIVE') THEN
RGStrNum := 11
ELSE IF (S = 'FILE_CHANGE_UPDATING_DRIVE_DONE') THEN
RGStrNum := 12
ELSE IF (S = 'FILE_CHANGE_UPDATING_SYSOPLOG') THEN
RGStrNum := 13
ELSE IF (S = 'FILE_DELETE_PROMPT') THEN
RGStrNum := 14
ELSE IF (S = 'FILE_DELETE_DISPLAY_AREA') THEN
RGStrNum := 15
ELSE IF (S = 'FILE_DELETE_VERIFY_DELETE') THEN
RGStrNum := 16
ELSE IF (S = 'FILE_DELETE_NOTICE') THEN
RGStrNum := 17
ELSE IF (S = 'FILE_DELETE_SYSOPLOG') THEN
RGStrNum := 18
ELSE IF (S = 'FILE_DELETE_DATA_FILES') THEN
RGStrNum := 19
ELSE IF (S = 'FILE_DELETE_REMOVE_DL_DIRECTORY') THEN
RGStrNum := 20
ELSE IF (S = 'FILE_DELETE_REMOVE_UL_DIRECTORY') THEN
RGStrNum := 21
ELSE IF (S = 'FILE_INSERT_MAX_FILE_AREAS') THEN
RGStrNum := 22
ELSE IF (S = 'FILE_INSERT_PROMPT') THEN
RGStrNum := 23
ELSE IF (S = 'FILE_INSERT_AFTER_ERROR_PROMPT') THEN
RGStrNum := 24
ELSE IF (S = 'FILE_INSERT_CONFIRM_INSERT') THEN
RGStrNum := 25
ELSE IF (S = 'FILE_INSERT_NOTICE') THEN
RGStrNum := 26
ELSE IF (S = 'FILE_INSERT_SYSOPLOG') THEN
RGStrNum := 27
ELSE IF (S = 'FILE_MODIFY_PROMPT') THEN
RGStrNum := 28
ELSE IF (S = 'FILE_MODIFY_SYSOPLOG') THEN
RGStrNum := 29
ELSE IF (S = 'FILE_POSITION_NO_AREAS') THEN
RGStrNum := 30
ELSE IF (S = 'FILE_POSITION_PROMPT') THEN
RGStrNum := 31
ELSE IF (S = 'FILE_POSITION_NUMBERING') THEN
RGStrNum := 32
ELSE IF (S = 'FILE_POSITION_BEFORE_WHICH') THEN
RGStrNum := 33
ELSE IF (S = 'FILE_POSITION_NOTICE') THEN
RGStrNum := 34
ELSE IF (S = 'FILE_EDITING_AREA_HEADER') THEN
RGStrNum := 35
ELSE IF (S = 'FILE_INSERTING_AREA_HEADER') THEN
RGStrNum := 36
ELSE IF (S = 'FILE_EDITING_INSERTING_SCREEN') THEN
RGStrNum := 37
ELSE IF (S = 'FILE_EDITING_INSERTING_PROMPT') THEN
RGStrNum := 38
ELSE IF (S = 'FILE_AREA_NAME_CHANGE') THEN
RGStrNum := 39
ELSE IF (S = 'FILE_FILE_NAME_CHANGE') THEN
RGStrNum := 40
ELSE IF (S = 'FILE_DUPLICATE_FILE_NAME_ERROR') THEN
RGStrNum := 41
ELSE IF (S = 'FILE_USE_DUPLICATE_FILE_NAME') THEN
RGStrNum := 42
ELSE IF (S = 'FILE_OLD_DATA_FILES_PATH') THEN
RGStrNum := 43
ELSE IF (S = 'FILE_NEW_DATA_FILES_PATH') THEN
RGStrNum := 44
ELSE IF (S = 'FILE_RENAME_DATA_FILES') THEN
RGStrNum := 45
ELSE IF (S = 'FILE_DL_PATH') THEN
RGStrNum := 46
ELSE IF (S = 'FILE_SET_DL_PATH_TO_UL_PATH') THEN
RGStrNum := 47
ELSE IF (S = 'FILE_UL_PATH') THEN
RGStrNum := 48
ELSE IF (S = 'FILE_ACS') THEN
RGStrNum := 49
ELSE IF (S = 'FILE_DL_ACCESS') THEN
RGStrNum := 50
ELSE IF (S = 'FILE_UL_ACCESS') THEN
RGStrNum := 51
ELSE IF (S = 'FILE_MAX_FILES') THEN
RGStrNum := 52
ELSE IF (S = 'FILE_PASSWORD') THEN
RGStrNum := 53
ELSE IF (S = 'FILE_ARCHIVE_TYPE') THEN
RGStrNum := 54
ELSE IF (S = 'FILE_COMMENT_TYPE') THEN
RGStrNum := 55
ELSE IF (S = 'FILE_TOGGLE_FLAGS') THEN
RGStrNum := 56
ELSE IF (S = 'FILE_MOVE_DATA_FILES') THEN
RGStrNum := 57
ELSE IF (S = 'FILE_TOGGLE_HELP') THEN
RGStrNum := 58
ELSE IF (S = 'FILE_JUMP_TO') THEN
RGStrNum := 59
ELSE IF (S = 'FILE_FIRST_VALID_RECORD') THEN
RGStrNum := 60
ELSE IF (S = 'FILE_LAST_VALID_RECORD') THEN
RGStrNum := 61
ELSE IF (S = 'FILE_INSERT_EDIT_HELP') THEN
RGStrNum := 62
ELSE IF (S = 'FILE_INSERT_HELP') THEN
RGStrNum := 63
ELSE IF (S = 'FILE_EDIT_HELP') THEN
RGStrNum := 64
ELSE IF (S = 'CHECK_AREA_NAME_ERROR') THEN
RGStrNum := 65
ELSE IF (S = 'CHECK_FILE_NAME_ERROR') THEN
RGStrNum := 66
ELSE IF (S = 'CHECK_DL_PATH_ERROR') THEN
RGStrNum := 67
ELSE IF (S = 'CHECK_UL_PATH_ERROR') THEN
RGStrNum := 68
ELSE IF (S = 'CHECK_ARCHIVE_TYPE_ERROR') THEN
RGStrNum := 69
ELSE IF (S = 'CHECK_COMMENT_TYPE_ERROR') THEN
RGStrNum := 70;
IF (RGStrNum = -1) THEN
BEGIN
WriteLn('Error!');
WriteLn;
WriteLn('The following string definition is invalid:');
WriteLn;
WriteLn(' '+S);
Found := FALSE;
END
ELSE
BEGIN
Done := FALSE;
WITH StrPointer DO
BEGIN
Pointer := (FileSize(RGStrFile) + 1);
TextSize := 0;
END;
Seek(RGStrFile,FileSize(RGStrFile));
WHILE NOT EOF(F) AND (NOT Done) DO
BEGIN
ReadLn(F,S);
IF (S[1] = '$') THEN
Done := TRUE
ELSE
BEGIN
Inc(StrPointer.TextSize,(Length(S) + 1));
BlockWrite(RGStrFile,S,(Length(S) + 1));
END;
END;
Seek(StrPointerFile,RGStrNum);
Write(StrPointerFile,StrPointer);
END;
END;
END;
Close(F);
Close(RGStrFile);
Close(StrPointerFile);
IF (Found) THEN
WriteLn('Done!')
ELSE
BEGIN
Erase(StrPointerFile);
Erase(RGStrFile);
END;
END;
BEGIN
CLrScr;
WriteLn('Renegade Language String Compiler Version 3.1');
Writeln('Copyright 2009 - The Renegade Developement Team');
IF (NOT Exist('RGLNG.TXT')) THEN
BEGIN
WriteLn;
WriteLn(^G^G^G'RGLNG.TXT does not exist!');
Exit;
END;
IF (NOT Exist('RGMAIN.TXT')) THEN
BEGIN
WriteLn;
WriteLn(^G^G^G'RGMAIN.TXT does not exists!');
Exit;
END;
IF (NOT Exist('RGNOTE.TXT')) THEN
BEGIN
WriteLn;
WriteLn(^G^G^G'RGNOTE.TXT does not exists!');
Exit;
END;
IF (NOT Exist('RGSCFG.TXT')) THEN
BEGIN
WriteLn;
WriteLn(^G^G^G'RGSCFG.TXT does not exists!');
Exit;
END;
IF (NOT Exist('FAELNG.TXT')) THEN
BEGIN
WriteLn;
WriteLn(^G^G^G'FAELNG.TXT does not exists!');
Exit;
END;
CompileLanguageStrings;
CompileMainStrings;
CompileNoteStrings;
CompileSysOpStrings;
CompileFileAreaEditorStrings;
END.

103
SOURCE/RGQUOTE.PAS Normal file
View File

@ -0,0 +1,103 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
PROGRAM RGQUOTE;
USES
Crt,
Dos;
TYPE
StrPointerRec = RECORD
Pointer,
TextSize: LongInt;
END;
VAR
RGStrFile: FILE;
StrPointerFile: FILE OF StrPointerRec;
StrPointer: StrPointerRec;
F: Text;
S: STRING;
RGStrNum: LongInt;
Done,Found: Boolean;
FUNCTION AllCaps(S: STRING): STRING;
VAR
I: Integer;
BEGIN
FOR I := 1 TO Length(S) DO
IF (S[I] IN ['a'..'z']) THEN
S[I] := Chr(Ord(S[I]) - Ord('a')+Ord('A'));
AllCaps := S;
END;
FUNCTION Exist(FN: STRING): Boolean;
VAR
DirInfo: SearchRec;
BEGIN
FindFirst(FN,AnyFile,DirInfo);
Exist := (DosError = 0);
end;
BEGIN
CLrScr;
WriteLn('Renegade Quote String Compiler Version 1.0');
Writeln('Copyright 2006 - The Renegade Developement Team');
WriteLn;
IF (ParamCount < 1) THEN
Writeln(^G^G^G'Please specify a file name!')
ELSE IF (Pos('.',ParamStr(1)) = 0) THEN
WriteLn(^G^G^G'Please Specify a valid file name (Example: "Name.Ext")')
ELSE IF (Length(ParamStr(1)) > 12) THEN
Writeln(^G^G^G'The file name must not be longer then twelve characters!')
ELSE IF (NOT Exist(ParamStr(1))) THEN
WriteLn(^G^G^G'That file name was not found!')
ELSE
BEGIN
S := ParamStr(1);
Write('Compiling strings ... ');
Found := TRUE;
Assign(StrPointerFile,Copy(S,1,(Pos('.',S) - 1))+'.PTR');
ReWrite(StrPointerFile);
Assign(RGStrFile,Copy(S,1,(Pos('.',S) - 1))+'.DAT');
ReWrite(RGStrFile,1);
Assign(F,ParamStr(1));
Reset(F);
WHILE NOT EOF(F) DO
BEGIN
ReadLn(F,S);
IF (S <> '') AND (S[1] = '$') THEN
BEGIN
Delete(S,1,1);
S := AllCaps(S);
Done := FALSE;
WITH StrPointer DO
BEGIN
Pointer := (FileSize(RGStrFile) + 1);
TextSize := 0;
END;
Seek(RGStrFile,FileSize(RGStrFile));
WHILE NOT EOF(F) AND (NOT Done) DO
BEGIN
ReadLn(F,S);
IF (S[1] = '$') THEN
Done := TRUE
ELSE
BEGIN
Inc(StrPointer.TextSize,(Length(S) + 1));
BlockWrite(RGStrFile,S,(Length(S) + 1));
END;
END;
Seek(StrPointerFile,FileSize(StrPointerFile));
Write(StrPointerFile,StrPointer);
END;
END;
Close(F);
Close(RGStrFile);
Close(StrPointerFile);
WriteLn('Done!')
END;
END.

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.

431
SOURCE/SCRIPT.PAS Normal file
View File

@ -0,0 +1,431 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D-,E-,F+,I-,L-,N-,O+,R-,S+,V-}
UNIT Script;
INTERFACE
USES
Common;
PROCEDURE ReadQ(CONST FileN: AStr);
PROCEDURE ReadASW(UserN: Integer; FN: AStr);
PROCEDURE ReadASW1(MenuOption: Str50);
IMPLEMENTATION
USES
Dos,
Doors,
MiscUser,
SysOp2G,
TimeFunc;
PROCEDURE ReadQ(CONST FileN: AStr);
VAR
InFile,
OutFile,
OutFile1: Text;
C: Char;
OutP,
Lin,
S,
Mult,
Got,
LastInp,
InFileName,
OutFileName: AStr;
PS: PathStr;
NS: NameStr;
ES: ExtStr;
I,
X: Integer;
PROCEDURE GoToLabel(Got: AStr);
VAR
S: AStr;
BEGIN
Got := ':'+AllCaps(Got);
Reset(InFile);
REPEAT
ReadLn(InFile,S);
UNTIL (EOF(InFile)) OR (AllCaps(S) = Got);
END;
PROCEDURE DumpToFile;
VAR
NewOutFile: Text;
WriteOut: Boolean; { goes to false when passing OLD infoform }
BEGIN
Assign(NewOutFile,General.MiscPath+'INF'+IntToStr(ThisNode)+'.TMP');
ReWrite(NewOutFile);
Reset(OutFile);
WriteOut := TRUE;
WHILE (NOT EOF(OutFile)) DO
BEGIN
ReadLn(OutFile,S);
IF (Pos('User: '+Caps(ThisUser.Name), S) > 0) THEN
WriteOut := FALSE
ELSE IF (NOT WriteOut) THEN
IF (Pos('User: ', S) > 0) THEN
WriteOut := TRUE;
IF (WriteOut) THEN
WriteLn(NewOutFile,S);
END;
Reset(OutFile1);
WHILE (NOT EOF(OutFile1)) DO
BEGIN
ReadLn(OutFile1,S);
WriteLn(NewOutFile,S);
END;
Close(OutFile1);
Close(OutFile);
Close(NewOutFile);
Kill(General.MiscPath+NS+'.ASW');
Erase(OutFile1);
ReName(NewOutFile,General.MiscPath+NS+'.ASW');
LastError := IOResult;
END;
BEGIN
InFileName := FileN;
FSplit(InFileName,PS,NS,ES);
InFileName := PS+NS+'.INF';
IF (NOT Exist(InFileName)) THEN
BEGIN
InFileName := General.MiscPath+NS+'.INF';
IF (NOT Exist(InFileName)) THEN
BEGIN
S := '* Infoform not found: '+FileN;
SysOpLog(S);
Exit;
END;
IF (OkAvatar) AND Exist(General.MiscPath+NS+'.INV') THEN
InFileName := General.MiscPath+NS+'.INV'
ELSE IF (OkAnsi) AND Exist(General.MiscPath+NS+'.INA') THEN
InFileName := General.MiscPath+NS+'.INA';
END
ELSE IF (OkAvatar) AND Exist(PS+NS+'.INV') THEN
InFileName := PS+NS+'.INV'
ELSE IF (OkAnsi) AND Exist(PS+NS+'.INA') THEN
InFileName := PS+NS+'.INA';
Assign(InFile,InFileName);
Reset(InFile);
IF (IOResult <> 0) THEN
BEGIN
SysOpLog('* Infoform not found: '+FileN);
SysOpLog(S);
Exit;
END;
FSplit(InFileName,PS,NS,ES);
OutFileName := General.MiscPath+NS+'.ASW';
Assign(OutFile1,General.MiscPath+'TMP'+IntToStr(ThisNode)+'.ASW');
ReWrite(OutFile1);
SysOpLog('* Answered InfoForm "'+FileN+'"');
Assign(OutFile,OutFileName);
WriteLn(OutFile1,'User: '+Caps(ThisUser.name));
WriteLn(OutFile1,'Date: '+Dat);
WriteLn(OutFile1);
NL;
PrintingFile := TRUE;
REPEAT
Abort := FALSE;
X := 0;
REPEAT
Inc(X);
Read(InFile,OutP[X]);
IF EOF(InFile) THEN {check again incase avatar parameter}
BEGIN
Inc(X);
Read(InFile,OutP[X]);
IF EOF(InFile) THEN
Dec(X);
END;
UNTIL ((OutP[X] = ^M) AND NOT (OutP[X - 1] IN [^V,^Y])) OR (X = 159) OR EOF(InFile) OR HangUp;
OutP[0] := Chr(X);
IF (Pos(^[,OutP) > 0) OR (Pos(^V,OutP) > 0) THEN
BEGIN
CROff := TRUE;
CtrlJOff := TRUE;
END
ELSE
BEGIN
IF (OutP[X] = ^M) THEN
Dec(OutP[0]);
IF (OutP[1] = ^J) THEN
Delete(OutP,1,1);
END;
IF (Pos('*',OutP) <> 0) AND (OutP[1] <> ';') THEN
OutP := ';A'+OutP;
IF (Length(OutP) = 0) THEN
NL
ELSE
CASE OutP[1] OF
';' : BEGIN
IF (Pos('*',OutP) <> 0) THEN
IF (OutP[2] <> 'D') THEN
OutP := Copy(OutP,1,(Pos('*',OutP) - 1));
Lin := Copy(OutP,3,255);
I := (80 - Length(Lin));
S := Copy(OutP,1,2);
IF (S[1] = ';') THEN
CASE S[2] OF
'R','F','V','C','D','G','I','K','L','Q','S','T',';': I := 1; { DO nothing }
ELSE IF (Lin[1] = ';') THEN
Prompt(Copy(Lin,2,255))
ELSE
Prompt(Lin);
END;
S := #1#1#1;
CASE OutP[2] OF
'A' : InputL(S,I);
'B' : Input(S,I);
'C' : BEGIN
Mult := '';
I := 1;
S := Copy(OutP,Pos('"',OutP),(Length(OutP) - Pos('"',OutP)));
REPEAT
Mult := Mult + S[I];
Inc(I);
UNTIL (S[I] = '"') OR (I > Length(S));
Lin := Copy(OutP,(I + 3),(Length(S) - (I - 1)));
Prompt(Lin);
OneK(C,Mult,TRUE,TRUE);
S := C;
END;
'D' : BEGIN
DoDoorFunc(OutP[3],Copy(OutP,4,(Length(OutP) - 3)));
S := #0#0#0;
END;
'F' : BEGIN
ChangeARFlags(Copy(OutP,3,255));
OutP := #0#0#0
END;
'G' : BEGIN
Got := Copy(OutP,3,(Length(OutP) - 2));
GoToLabel(Got);
S := #0#0#0;
END;
'S' : BEGIN
Delete(OutP,1,3);
IF AACS(Copy(OutP,1,(Pos('"',OutP) - 1))) THEN
BEGIN
Got := Copy(OutP,(Pos(',',OutP) + 1),255);
GoToLabel(Got);
END;
S := #0#0#0;
END;
'H' : HangUp := TRUE;
'I' : BEGIN
Mult := Copy(OutP,3,(Length(OutP) - 2));
I := Pos(',',Mult);
IF (I <> 0) THEN
BEGIN
Got := Copy(Mult,(I + 1),(Length(Mult) - I));
Mult := Copy(Mult,1,(I - 1));
IF (AllCaps(LastInp) = AllCaps(Mult)) THEN
GoToLabel(Got);
END;
S := #1#1#1;
OutP := #0#0#0;
END;
'K' : BEGIN
Close(InFile);
Close(OutFile1);
Erase(OutFile1);
SysOpLog('* InfoForm aborted.');
PrintingFile := FALSE;
Exit;
END;
'L' : BEGIN
S := Copy(OutP,3,(Length(OutP) - 2));
WriteLn(OutFile1,MCI(S));
S := #0#0#0;
END;
'Q' : BEGIN
WHILE NOT EOF(InFile) DO
ReadLn(InFile,S);
S := #0#0#0;
END;
'R' : BEGIN
ChangeACFlags(Copy(OutP,3,255));
OutP := #0#0#0;
END;
'T' : BEGIN
S := Copy(OutP,3,(Length(OutP) - 2));
PrintF(S);
S := #0#0#0;
END;
'Y' : BEGIN
IF YN(0,TRUE) THEN
S := 'YES'
ELSE
S := 'NO';
IF (Lin[1] = ';') THEN
OutP := #0#0#0;
END;
'N' : BEGIN
IF YN(0,FALSE) THEN
S := 'YES'
ELSE
S := 'NO';
IF (Lin[1] = ';') THEN
OutP := #0#0#0
END;
'V' : IF (UpCase(OutP[3]) IN ['!'..'~']) THEN
AutoValidate(ThisUser,UserNum,UpCase(OutP[3]));
';' : S := #0#0#0;
END;
IF (S <> #1#1#1) THEN
BEGIN
IF (OutP <> #0#0#0) THEN
OutP := Lin + S;
LastInp := S;
END;
IF (S = #0#0#0) THEN
OutP := #0#0#0;
END;
':' : OutP := #0#0#0;
ELSE
PrintACR(OutP);
END;
IF (OutP <> #0#0#0) THEN
BEGIN
IF (Pos('%CL',OutP) <> 0) THEN
Delete(OutP,Pos('%CL',OutP),3);
WriteLn(OutFile1,MCI(OutP));
END;
UNTIL ((EOF(InFile)) OR (HangUp));
Close(OutFile1);
Close(InFile);
IF (HangUp) THEN
BEGIN
WriteLn(OutFile1);
WriteLn(OutFile1,'** HUNG UP **');
END
ELSE
DumpToFile;
PrintingFile := FALSE;
LastError := IOResult;
END;
PROCEDURE ReadASW(UserN: Integer; FN: AStr);
VAR
QF: Text;
User: UserRecordType;
QS: AStr;
PS: PathStr;
NS: NameStr;
ES: ExtStr;
UserFound: Boolean;
PROCEDURE ExactMatch;
BEGIN
Reset(QF);
REPEAT
ReadLn(QF,QS);
IF (Pos('User: '+Caps(User.Name),QS) > 0) THEN
UserFound := TRUE;
IF (NOT Empty) THEN
WKey;
UNTIL (EOF(QF)) OR (UserFound) OR (Abort);
END;
BEGIN
IF ((UserN >= 1) AND (UserN <= (MaxUsers - 1))) THEN
LoadURec(User,UserN)
ELSE
BEGIN
Print('Invalid user number.');
Exit;
END;
Abort := FALSE;
Next := FALSE;
FSplit(FN,PS,NS,ES);
FN := General.MiscPath+NS+'.ASW';
IF (NOT Exist(FN)) THEN
BEGIN
FN := General.DataPath+NS+'.ASW';
IF (NOT Exist(FN)) THEN
BEGIN
Print('Answers file not found.');
Exit;
END;
END;
Assign(QF,FN);
Reset(QF);
IF (IOResult <> 0) THEN
Print('"'+FN+'": unable to open.')
ELSE
BEGIN
UserFound := FALSE;
ExactMatch;
IF (NOT UserFound) AND (NOT Abort) THEN
Print('That user has not completed the questionnaire.')
ELSE
BEGIN
IF (CoSysOp) THEN
Print(QS);
REPEAT
WKey;
ReadLn(QF,QS);
IF (Copy(QS,1,6) <> 'Date: ') OR (CoSysOp) THEN
IF (Copy(QS,1,6) <> 'User: ') THEN
PrintACR(QS)
ELSE
UserFound := FALSE;
UNTIL EOF(QF) OR (NOT UserFound) OR (Abort) OR (HangUp);
END;
Close(QF);
END;
LastError := IOResult;
END;
PROCEDURE ReadASW1(MenuOption: Str50);
VAR
PS: PathStr;
NS: NameStr;
ES: ExtStr;
UserN: Integer;
BEGIN
IF (MenuOption = '') THEN
BEGIN
Prt('Enter filename: ');
MPL(8);
Input(MenuOption,8);
NL;
IF (MenuOption = '') THEN
Exit;
END;
FSplit(MenuOption,PS,NS,ES);
MenuOption := AllCaps(General.DataPath+NS+'.ASW');
IF (NOT Exist(MenuOption)) THEN
BEGIN
MenuOption := AllCaps(General.MiscPath+NS+'.ASW');
IF (NOT Exist(MenuOption)) THEN
BEGIN
Print('InfoForm answer file not found: "'+MenuOption+'"');
Exit;
END;
END;
NL;
Print('Enter the name of the user to view: ');
Prt(':');
LFindUserWS(UserN);
IF (UserN <> 0) THEN
ReadASW(UserN,MenuOption)
ELSE IF (CoSysOp) THEN
BEGIN
NL;
IF PYNQ('List entire answer file? ',0,FALSE) THEN
BEGIN
NL;
PrintF(NS+'.ASW');
END;
END;
END;
END.

79
SOURCE/SHORTMSG.PAS Normal file
View File

@ -0,0 +1,79 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S+,V-}
UNIT ShortMsg;
INTERFACE
USES
Common;
PROCEDURE ReadShortMessage;
PROCEDURE SendShortMessage(CONST UNum: Integer; CONST Message: AStr);
IMPLEMENTATION
PROCEDURE ReadShortMessage;
VAR
ShortMsgFile: FILE OF ShortMessageRecordType;
ShortMsg: ShortMessageRecordType;
RecNum: LongInt;
BEGIN
Assign(ShortMsgFile,General.DataPath+'SHORTMSG.DAT');
Reset(ShortMsgFile);
IF (IOResult = 0) THEN
BEGIN
UserColor(1);
RecNum := 0;
WHILE (RecNum <= (FileSize(ShortMsgFile) - 1)) AND (NOT HangUp) DO
BEGIN
Seek(ShortMsgFile,RecNum);
Read(ShortMsgFile,ShortMsg);
IF (ShortMsg.Destin = UserNum) THEN
BEGIN
Print(ShortMsg.Msg);
ShortMsg.Destin := -1;
Seek(ShortMsgFile,RecNum);
Write(ShortMsgFile,ShortMsg);
END;
Inc(RecNum);
END;
Close(ShortMsgFile);
UserColor(1);
END;
Exclude(ThisUser.Flags,SMW);
SaveURec(ThisUser,UserNum);
LastError := IOResult;
END;
PROCEDURE SendShortMessage(CONST UNum: Integer; CONST Message: AStr);
VAR
ShortMsgFile: FILE OF ShortMessageRecordType;
ShortMsg: ShortMessageRecordType;
User: UserRecordType;
BEGIN
IF (UNum >= 1) AND (UNum <= (MaxUsers - 1)) THEN
BEGIN
Assign(ShortMsgFile,General.DataPath+'SHORTMSG.DAT');
Reset(ShortMsgFile);
IF (IOResult = 2) THEN
ReWrite(ShortMsgFile);
Seek(ShortMsgFile,FileSize(ShortMsgFile));
WITH ShortMsg DO
BEGIN
Msg := Message;
Destin := UNum;
END;
Write(ShortMsgFile,ShortMsg);
Close(ShortMsgFile);
LoadURec(User,UNum);
Include(User.Flags,SMW);
SaveURec(User,UNum);
LastError := IOResult;
END;
END;
END.

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