eric
/
renegadebbs
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Initial commit

This commit is contained in:
R. Eric Wheeler 2016-03-05 11:28:50 -08:00
commit 6abf234ade
118 changed files with 67168 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
.gitignore vendored Normal file
View File

@ -0,0 +1,14 @@
*.CFG
*.CMD
*.old
*.OLD
*.TXT
*.TPU
*.tpu
*.ppu
*.PPU
*.VPI
*.vpi
SOURCE/ELECOM/
SOURCE/UNUSED/

1
README.md Normal file
View File

@ -0,0 +1 @@
# Renegade BBS

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);
InputLongIntWoc(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);
InputLongIntWoc(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.

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.

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

1019
SOURCE/RECORDS.PAS Normal file
View File

File diff suppressed because it is too large Load Diff

1019
SOURCE/RECORDS.bak Normal file
View File

File diff suppressed because it is too large Load Diff

586
SOURCE/RENEGADE.PAS Normal file
View File

@ -0,0 +1,586 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$IFDEF WIN64}
{$DEFINE WIN32}
{$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;
BBSVersion: Astr = '1.20.1/'
{$IFDEF LINUX} + 'Linux'; {$ENDIF}
{$IFDEF WIN32} + 'Win32'; {$ENDIF}
{$IFDEF WIN64} + 'Win64'; {$ENDIF}
{$IFDEF MSDOS} + 'Dos16'; {$ENDIF}
VAR
ExitSave: Pointer;
GeneralF: FILE OF GeneralRecordType;
ByteFile: FILE OF Byte;
TextFile: Text;
S: Astr;
Counter: Byte;
Counter1: Integer;
BBSVersion: Astr;
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.

580
SOURCE/RENEGADE.bak Normal file
View File

@ -0,0 +1,580 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$IFDEF WIN64}
{$DEFINE WIN32}
{$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

BIN
SOURCE/RENEMAIL.exe Normal file
View File

Binary file not shown.

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.

BIN
SOURCE/RGLNG.exe Normal file
View File

Binary file not shown.

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.

BIN
SOURCE/RGQUOTE.exe Normal file
View File

Binary file not shown.

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: Word);
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: Word);
procedure RPShowCursor;
function RPWhereXY: Word;
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: Word);
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: Word);
var
NumWritten: LongWord;
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: Word;
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.

59
SOURCE/SPAWNO.PAS Normal file
View File

@ -0,0 +1,59 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
UNIT SPAWNO;
INTERFACE
CONST
(* symbolic constants for specifying permissible swap locations *)
(* add/or together the desired destinations *)
Swap_Disk = 0;
Swap_XMS = 1;
Swap_EMS = 2;
Swap_Ext = 4;
Swap_All = $FF; (* swap to any available destination *)
(* error codes *)
ENotFound = 2;
ENoPath = 3;
EAccess = 5;
ENoMem = 8;
E2Big = 20;
EWriteFault = 29;
VAR
Spawno_Error: Integer; (* error code when Spawn returns -1 *)
PROCEDURE Init_Spawno(Swap_Dirs: STRING; Swap_Types: Integer; Min_Res: Integer; Res_Stack: Integer);
(* Min_Res = minimum number of paragraphs to keep resident
Res_Stack = minimum paragraphs of stack to keep resident
(0 = no change)
*)
FUNCTION Spawn(ProgName: STRING; Arguments: STRING; EnvSeg: Integer): Integer;
IMPLEMENTATION
{$IFDEF MSDOS}
{$L SPAWNTP.OBJ}
PROCEDURE Init_Spawno(Swap_Dirs: STRING; Swap_Types: Integer; Min_Res: Integer; Res_Stack: Integer); EXTERNAL;
FUNCTION Spawn(ProgName: STRING; Arguments: STRING; EnvSeg: Integer): Integer; EXTERNAL;
{$ENDIF}
{$IFDEF WIN32}
PROCEDURE Init_Spawno(Swap_Dirs: STRING; Swap_Types: Integer; Min_Res: Integer; Res_Stack: Integer);
BEGIN
WriteLn('REETODO SPAWNO Init_Spawno'); Halt;
END;
FUNCTION Spawn(ProgName: STRING; Arguments: STRING; EnvSeg: Integer): Integer;
BEGIN
WriteLn('REETODO SPAWNO Spawn'); Halt;
END;
{$ENDIF}
END.

1421
SOURCE/SPLITCHA.PAS Normal file
View File

File diff suppressed because it is too large Load Diff

457
SOURCE/STATS.PAS Normal file
View File

@ -0,0 +1,457 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S+,V-}
UNIT STATS;
INTERFACE
USES
Common;
TYPE
Top10UserRecordArray = RECORD
UNum: SmallInt;
Info: Real;
END;
Top20FileRecordArray = RECORD
DirNum,
DirRecNum: SmallInt;
Downloaded: LongInt;
END;
Top10UserArray = ARRAY [1..10] OF Top10UserRecordArray;
Top20FileArray = ARRAY [1..20] OF Top20FileRecordArray;
VAR
Top10User: Top10UserArray;
Top20File: Top20FileArray;
PROCEDURE GetUserStats(MenuOption: Str50);
IMPLEMENTATION
USES
File0,
File1,
File11;
FUNCTION MaxR(R,R1: Real): Real;
BEGIN
IF (R1 = 0.0) THEN
MaxR := R
ELSE
MaxR := R1;
END;
FUNCTION Center(S: AStr; Len: Byte; TF: Boolean): AStr;
VAR
Counter,
StrLength: Byte;
Which_Way: Boolean;
BEGIN
Which_Way := TF;
StrLength := Length(S);
FOR Counter := (StrLength + 1) TO Len DO
BEGIN
IF (Which_Way) THEN
BEGIN
S := ' ' + S;
Which_Way := FALSE;
END
ELSE
BEGIN
S := S + ' ';
Which_Way := TRUE;
END;
END;
Center := S;
END;
PROCEDURE InitTop10UserArray(VAR Top10User: Top10UserArray);
VAR
Counter: Byte;
BEGIN
FOR Counter := 1 TO 10 DO
BEGIN
Top10User[Counter].UNum := -1;
Top10User[Counter].Info := 0.0;
END;
END;
PROCEDURE InitTop20FileArray(VAR Top20User: Top20FileArray);
VAR
Counter: Byte;
BEGIN
FOR Counter := 1 TO 20 DO
BEGIN
Top20File[Counter].DirNum := -1;
Top20File[Counter].DirRecNum := -1;
Top20File[Counter].Downloaded := 0;
END;
END;
PROCEDURE SortUserDecending(VAR Top10User: Top10UserArray; UNum: Integer; Info: Real);
VAR
Counter,
Counter1: Byte;
BEGIN
IF (Info > 0.0) THEN
FOR Counter := 1 TO 10 DO
IF (Info >= Top10User[Counter].Info) THEN
BEGIN
FOR Counter1 := 10 DOWNTO (Counter + 1) DO
Top10User[Counter1] := Top10User[Counter1 - 1];
Top10User[Counter].UNum := UNum;
Top10User[Counter].Info := Info;
Counter := 10;
END;
END;
PROCEDURE SortFileDecending(VAR Top20File: Top20FileArray; DirNum,DirRecNum: Integer; Downloaded: LongInt);
VAR
Counter,
Counter1: Byte;
BEGIN
IF (Downloaded > 0) THEN
FOR Counter := 1 to 20 DO
IF (Downloaded >= Top20File[Counter].Downloaded) THEN
BEGIN
FOR Counter1 := 20 DOWNTO (Counter + 1) DO
Top20File[Counter1] := Top20File[Counter1 - 1];
Top20File[Counter].DirNum := DirNum;
Top20File[Counter].DirRecNum := DirRecNum;
Top20File[Counter].Downloaded := Downloaded;
Counter := 20;
END;
END;
PROCEDURE SearchTop10User(VAR Top10User: Top10UserArray; Cmd: Char; ExcludeUserNum: Integer);
VAR
User: UserRecordType;
UNum: Integer;
Info: Real;
BEGIN
InitTop10UserArray(Top10User);
Abort := FALSE;
Next := FALSE;
Reset(UserFile);
UNum := 1;
WHILE (UNum <= (FileSize(UserFile) - 1)) AND (NOT Abort) AND (NOT HangUp) DO
BEGIN
IF (ExcludeUserNum = 0) OR (UNum <> ExcludeUserNum) THEN
BEGIN
Seek(UserFile,UNum);
Read(UserFile,User);
IF (NOT (Deleted IN User.SFlags)) AND (NOT (LockedOut IN User.SFlags)) THEN
BEGIN
CASE Cmd OF
'A' : Info := User.TTimeOn;
'B' : Info := User.UK;
'C' : Info := User.DK;
'D' : Info := User.EmailSent;
'E' : Info := User.MsgPost;
'F' : Info := User.FeedBack;
'G' : Info := User.LoggedOn;
'H' : Info := User.Uploads;
'I' : Info := User.Downloads;
'J' : Info := User.FilePoints;
'K' : Info := (User.UK / MaxR(1.0,User.DK));
'L' : Info := (User.MsgPost / MaxR(1.0,User.LoggedOn));
END;
SortUserDecending(Top10User,UNum,Info);
END;
END;
Inc(UNum);
END;
Close(UserFile);
END;
PROCEDURE SearchTop20AreaFileSpec(FArea: Integer; VAR Top20File: Top20FileArray);
VAR
F: FileInfoRecordType;
DirFileRecNum: Integer;
BEGIN
IF (FileArea <> FArea) THEN
ChangeFileArea(FArea);
IF (FileArea = FArea) THEN
BEGIN
RecNo(F,'*.*',DirFileRecNum);
IF (BadDownloadPath) THEN
Exit;
WHILE (DirFileRecNum <> -1) AND (NOT Abort) AND (NOT HangUp) DO
BEGIN
Seek(FileInfoFile,DirFileRecNum);
Read(FileInfoFile,F);
IF (CanSee(F)) THEN
SortFileDecending(Top20File,FileArea,DirFileRecNum,F.Downloaded);
NRecNo(F,DirFileRecNum);
END;
Close(FileInfoFile);
Close(ExtInfoFile);
END;
END;
PROCEDURE SearchTop20GlobalFileSpec(VAR Top20File: Top20FileArray);
VAR
FArea,
SaveFileArea: Integer;
SaveConfSystem: Boolean;
BEGIN
InitTop20FileArray(Top20File);
SaveFileArea := FileArea;
SaveConfSystem := ConfSystem;
ConfSystem := FALSE;
IF (SaveConfSystem) THEN
NewCompTables;
Abort := FALSE;
Next := FALSE;
FArea := 1;
WHILE (FArea >= 1) AND (FArea <= NumFileAreas) AND (NOT Next) AND (NOT Abort) AND (NOT HangUp) DO
BEGIN
SearchTop20AreaFileSpec(FArea,Top20File);
WKey;
IF (Next) THEN
BEGIN
Abort := FALSE;
Next := FALSE;
END;
Inc(FArea);
END;
ConfSystem := SaveConfSystem;
IF (SaveConfSystem) THEN
NewCompTables;
FileArea := SaveFileArea;
LoadFileArea(FileArea);
END;
PROCEDURE DisplayTop10UserArray(Top10User: Top10UserArray; Title,Header: AStr; Decimal,Width: Byte);
VAR
User: UserRecordType;
TempStr: AStr;
Counter,
Counter1: Byte;
BEGIN
Abort := FALSE;
Next := FALSE;
CLS;
PrintACR('^5'+Center('-=[ Top 10 '+Title+' ]=-',78,TRUE));
NL;
PrintACR('^5## User Name '+Center(Header,55,TRUE));
NL;
Counter := 1;
WHILE (Counter <= 10) AND (NOT Abort) AND (NOT HangUp) DO
BEGIN
User.Name := '';
IF (Top10User[Counter].UNum >= 1) THEN
LoadURec(User,Top10User[Counter].UNum);
TempStr := '^5'+PadRightInt(Counter,2)+
' '+
AOnOff(User.Name = ThisUser.Name,'^7','^0')+
User.Name+' ^1';
FOR Counter1 := (Length(User.Name) + 1) TO 35 DO
TempStr := TempStr + '.';
TempStr := TempStr + ' '+AOnOff((Top10User[Counter].Info > 0.0),'^4'
+PadRightStr(RealToStr(Top10User[Counter].Info,0,Decimal),Width),'');
PrintACR(TempStr);
WKey;
Inc(Counter);
END;
NL;
PauseScr(FALSE);
END;
PROCEDURE DisplayTop20FileArray(Top20File: Top20FileArray);
VAR
F: FileInfoRecordType;
TempStr: AStr;
Counter,
SaveFileArea: Integer;
AddBatch: Boolean;
BEGIN
SaveFileArea := FileArea;
Abort := FALSE;
Next := FALSE;
CLS;
PrintACR('^5'+Center('-=[ Top 20 Files Downloaded ]=-',78,TRUE));
NL;
PrintACR('^5## Filename.Ext Number Downloads ## Filename.Ext Number Downloads');
NL;
FOR Counter := 1 to 10 DO
BEGIN
F.FileName := '';
IF (Counter <= 10) THEN
BEGIN
IF (Top20File[Counter].DirNum > 0) THEN
BEGIN
InitFileArea(Top20File[Counter].DirNum);
IF (BadDownloadPath) THEN
Exit;
Seek(FileInfoFile,Top20File[Counter].DirRecNum);
Read(FileInfoFile,F);
Close(FileInfoFile);
Close(ExtInfoFile);
END;
TempStr := '^5'+PadRightInt(Counter,2);
TempStr := TempStr + '^0'+PadRightStr(F.FileName,15);
IF (Top20File[Counter].Downloaded > 0) THEN
TempStr := TempStr + '^4'+PadRightInt(Top20File[Counter].Downloaded,12)
ELSE
TempStr := TempStr + ' ';
END;
TempStr := TempStr + ' ';
F.FileName := '';
IF ((Counter + 10) > 10) THEN
BEGIN
IF (Top20File[Counter + 10].DirNum > 0) THEN
BEGIN
InitFileArea(Top20File[Counter + 10].DirNum);
IF (BadDownloadPath) THEN
Exit;
Seek(FileInfoFile,Top20File[Counter + 10].DirRecNum);
Read(FileInfoFile,F);
Close(FileInfoFile);
Close(ExtInfoFile);
END;
TempStr := TempStr + '^5'+PadRightInt(Counter + 10,2);
TempStr := TempStr + '^0'+PadRightStr(F.FileName,15);
IF (Top20File[Counter + 10].Downloaded > 0) THEN
TempStr := TempStr + '^4'+PadRightInt(Top20File[Counter + 10].Downloaded,12)
END;
PrintACR(TempStr);
END;
NL;
PauseScr(FALSE);
(*
IF (PYNQ('Would you like to download one of these files? ',0,FALSE)) THEN
BEGIN
Counter := -1;
NL;
InputIntegerWOC('Download which file',Counter,1,20);
IF (Counter <> -1) THEN
IF (Top20File[Counter].DirNum <> -1) AND (Top20File[Counter].DirRecNum <> -1) THEN
BEGIN
InitFileArea(Top20File[Counter].DirNum);
IF (BadDownloadPath) THEN
Exit;
Seek(FileInfoFile,Top20File[Counter].DirRecNum);
Read(FileInfoFile,F);
NL;
DLX(F,Top20File[Counter].DirRecNum,FALSE,Abort);
Close(FileInfoFile);
Close(ExtInfoFile);
END;
END;
*)
FileArea := SaveFileArea;
LoadFileArea(FileArea);
END;
PROCEDURE GetUserStats(MenuOption: Str50);
VAR
Title,
Header: AStr;
Decimal,
Width: Byte;
ExcludeUserNum: Integer;
BEGIN
MenuOption := ALLCaps(MenuOption);
IF (MenuOption = '') OR (NOT (MenuOption[1] IN ['A'..'M'])) THEN
BEGIN
NL;
Print('Invalid menu option for user statistics, please inform the SysOp.');
PauseScr(FALSE);
SysOpLog('Invalid menu option for user statistics, valid options are A-M.');
END
ELSE IF (MenuOption[1] IN ['A'..'L']) THEN
BEGIN
ExcludeUserNum := 0;
IF (Pos(';',MenuOption) <> 0) THEN
ExcludeUserNum := StrToInt(Copy(MenuOption,(Pos(';',MenuOption) + 1),50));
SearchTop10User(Top10User,MenuOption[1],ExcludeUserNum);
CASE UpCase(MenuOption[1]) OF
'A' : BEGIN
Title := 'High Time Users';
Header := 'Minutes Online';
Decimal := 0;
Width := 10;
END;
'B' : BEGIN
Title := 'File Kbyte Uploaders';
Header := 'Kbytes Uploaded';
Decimal := 0;
Width := 10;
END;
'C' : BEGIN
Title := 'File Kbyte Downloaders';
Header := 'Kbytes Downloaded';
Decimal := 0;
Width := 10;
END;
'D' : BEGIN
Title := 'Private Message Senders';
Header := 'Private Messages Sent';
Decimal := 0;
Width := 10;
END;
'E' : BEGIN
Title := 'Public Message Posters';
Header := 'Messages Posted';
Decimal := 0;
Width := 10;
END;
'F' : BEGIN
Title := 'SysOp Feedback Senders';
Header := 'SysOp Feedback Sent';
Decimal := 0;
Width := 10;
END;
'G' : BEGIN
Title := 'All Time Callers';
Header := 'Calls To The System';
Decimal := 0;
Width := 10;
END;
'H' : BEGIN
Title := 'File Uploaders';
Header := 'Files Uploaded';
Decimal := 0;
Width := 10;
END;
'I' : BEGIN
Title := 'File Downloaders';
Header := 'Files Downloaded';
Decimal := 0;
Width := 10;
END;
'J' : BEGIN
Title := 'File Points';
Header := 'File Points On Hand';
Decimal := 0;
Width := 10;
END;
'K' : BEGIN
Title := 'Upload/Download Ratios';
Header := 'KB Uploaded for Each KB Downloaded';
Decimal := 2;
Width := 12;
END;
'L' : BEGIN
Title := 'Post/Call Ratios';
Header := 'Public Messages Posted Each Call';
Decimal := 2;
Width := 12;
END;
END;
DisplayTop10UserArray(Top10User,Title,Header,Decimal,Width);
END
ELSE IF (MenuOption[1] = 'M') THEN
BEGIN
SearchTop20GlobalFileSpec(Top20File);
DisplayTop20FileArray(Top20File);
END;
END;
END.

831
SOURCE/SYSOP1.PAS Normal file
View File

@ -0,0 +1,831 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S+,V-}
UNIT SysOp1;
INTERFACE
PROCEDURE ProtocolEditor;
IMPLEMENTATION
USES
Common;
PROCEDURE ProtocolEditor;
VAR
TempProtocol: ProtocolRecordType;
Cmd: Char;
RecNumToList: Integer;
SaveTempPause: Boolean;
PROCEDURE ToggleXBFlag(XBFlagT: ProtocolFlagType; VAR XBFlags: PRFlagSet);
BEGIN
IF (XBFlagT IN XBFlags) THEN
Exclude(XBFlags,XBFlagT)
ELSE
Include(XBFlags,XBFlagT);
END;
PROCEDURE ToggleXBFlags(C: Char; VAR XBFlags: PRFlagSet; VAR Changed: Boolean);
VAR
TempXBFlags: PRFlagSet;
BEGIN
TempXBFlags := XBFlags;
CASE C OF
'1' : ToggleXBFlag(ProtActive,XBFlags);
'2' : ToggleXBFlag(ProtIsBatch,XBFlags);
'3' : ToggleXBFlag(ProtIsResume,XBFlags);
'4' : ToggleXBFlag(ProtBiDirectional,XBFlags);
'5' : ToggleXBFlag(ProtReliable,XBFlags);
'6' : ToggleXBFlag(ProtXferOkCode,XBFlags);
END;
IF (XBFlags <> TempXBFlags) THEN
Changed := TRUE;
END;
PROCEDURE InitProtocolVars(VAR Protocol: ProtocolRecordType);
VAR
Counter: BYTE;
BEGIN
FillChar(Protocol,SizeOf(Protocol),0);
WITH Protocol DO
BEGIN
PRFlags := [ProtXferOkCode];
CKeys := '!';
Description := '<< New Protocol >>';
ACS := '';
TempLog := '';
DLoadLog := '';
ULoadLog := '';
DLCmd := '';
ULCmd := '';
FOR Counter := 1 TO 6 DO
BEGIN
DLCode[Counter] := '';
ULCode[Counter] := '';
END;
EnvCmd := '';
DLFList := '';
MaxChrs := 127;
TempLogPF := 0;
TempLogPS := 0;
END;
END;
PROCEDURE DeleteProtocol(TempProtocol1: ProtocolRecordType; RecNumToDelete: SmallInt);
VAR
RecNum: Integer;
BEGIN
IF (NumProtocols = 0) THEN
Messages(4,0,'protocols')
ELSE
BEGIN
RecNumToDelete := -1;
InputIntegerWOC('%LFProtocol to delete?',RecNumToDelete,[NumbersOnly],1,NumProtocols);
IF (RecNumToDelete >= 1) AND (RecNumToDelete <= NumProtocols) THEN
BEGIN
Reset(ProtocolFile);
Seek(ProtocolFile,(RecNumToDelete - 1));
Read(ProtocolFile,TempProtocol1);
Close(ProtocolFile);
LastError := IOResult;
Print('%LFProtocol: ^5'+TempProtocol1.Description);
IF PYNQ('%LFAre you sure you want to delete it? ',0,FALSE) THEN
BEGIN
Print('%LF[> Deleting protocol record ...');
Dec(RecNumToDelete);
Reset(ProtocolFile);
IF (RecNumToDelete >= 0) AND (RecNumToDelete <= (FileSize(ProtocolFile) - 2)) THEN
FOR RecNum := RecNumToDelete TO (FileSize(ProtocolFile) - 2) DO
BEGIN
Seek(ProtocolFile,(RecNum + 1));
Read(ProtocolFile,Protocol);
Seek(ProtocolFile,RecNum);
Write(ProtocolFile,Protocol);
END;
Seek(ProtocolFile,(FileSize(ProtocolFile) - 1));
Truncate(ProtocolFile);
Close(ProtocolFile);
LastError := IOResult;
Dec(NumProtocols);
SysOpLog('* Deleted Protocol: ^5'+TempProtocol1.Description);
END;
END;
END;
END;
FUNCTION CmdOk(Protocol: ProtocolRecordType): Boolean;
VAR
Ok1: Boolean;
BEGIN
Ok1 := TRUE;
WITH Protocol DO
IF (DLCmd = 'ASCII') OR (DLCmd = 'BATCH') OR (DLCmd = 'EDIT') OR
(DLCmd = 'NEXT') OR (DLCmd = 'QUIT') OR (ULCmd = 'ASCII') OR
(ULCmd = 'BATCH') OR (ULCmd = 'EDIT') OR (ULCmd = 'NEXT') OR
(ULCmd = 'QUIT') THEN
OK1 := FALSE;
CmdOk := Ok1;
END;
FUNCTION DLCodesEmpty(Protocol: ProtocolRecordType): Boolean;
VAR
Counter1: Byte;
BEGIN
DLCodesEmpty := TRUE;
FOR Counter1 := 1 TO 6 DO
IF (Protocol.DLCode[Counter1] <> '') THEN
DLCodesEmpty := FALSE;
END;
FUNCTION ULCodesEmpty(Protocol: ProtocolRecordType): Boolean;
VAR
Counter1: Byte;
BEGIN
ULCodesEmpty := TRUE;
FOR Counter1 := 1 TO 6 DO
IF (Protocol.ULCode[Counter1] <> '') THEN
ULCodesEmpty := FALSE;
END;
PROCEDURE CheckProtocol(Protocol: ProtocolRecordType; StartErrMsg,EndErrMsg: Byte; VAR Ok: Boolean);
VAR
Counter: Byte;
BEGIN
FOR Counter := StartErrMsg TO EndErrMsg DO
CASE Counter OF
1 : IF (Protocol.Ckeys = '') THEN
BEGIN
Print('%LF^7The command keys are invalid!^1');
Ok := FALSE;
END;
2 : IF (Protocol.Description = '<< New Protocol >>') THEN
BEGIN
Print('%LF^7The description is invalid!^1');
Ok := FALSE;
END;
3 : IF (CmdOk(Protocol)) AND (ProtIsBatch IN Protocol.PRFLags) AND (Protocol.TempLog <> '') AND
(Protocol.TempLogPF = 0) THEN
BEGIN
Print('%LF^7You must specify the file name position if you utilize the Temp Log.^1');
Ok := FALSE;
END;
4 : IF (CmdOk(Protocol)) AND (ProtIsBatch IN Protocol.PRFLags) AND (Protocol.TempLog <> '') AND
(Protocol.TempLogPS = 0) THEN
BEGIN
Print('%LF^7You must specify the status position if you utilize the Temp Log.');
Ok := FALSE;
END;
5 : IF (CmdOk(Protocol)) AND (ProtIsBatch IN Protocol.PRFLags) AND (Protocol.TempLog <> '') AND
(DLCodesEmpty(Protocol)) THEN
BEGIN
Print('%LF^7You must specify <D>L codes if you utilize the Temp. Log.^1');
Ok := FALSE;
END;
6 : IF (CMDOk(Protocol)) AND (ProtIsBatch IN Protocol.PRFlags) AND (Protocol.DLoadLog <> '') AND
(Protocol.TempLog = '') THEN
BEGIN
Print('%LF^7You must specify a Temp. Log if you utilize the <D>L Log.^1');
Ok := FALSE;
END;
7 : IF (CmdOk(Protocol)) AND (NOT (ProtIsBatch IN Protocol.PRFlags)) AND (Protocol.ULCmd <> '') AND
(ULCodesEmpty(Protocol)) THEN
BEGIN
Print('%LF^7You must specify <U>L Codes if you utilize the <U>L Command.^1');
Ok := FALSE;
END;
8 : IF (CmdOk(Protocol)) AND (NOT (ProtIsBatch IN Protocol.PRFlags)) AND (Protocol.DLCmd <> '') AND
(DLCodesEmpty(Protocol)) THEN
BEGIN
Print('%LF^7You must specify <D>L Codes if you utilize the <D>L Command.^1');
Ok := FALSE;
END;
9 : IF (CmdOk(Protocol)) AND (ProtIsBatch IN Protocol.PRFlags) AND (Protocol.DLCmd <> '') AND
(Protocol.DLFList = '') THEN
BEGIN
Print('%LF^7You must specify a DL File List if you utilize the <D>L Command.^1');
Ok := FALSE;
END;
10 : IF (CmdOk(Protocol)) AND (ProtIsBatch IN Protocol.PRFlags) AND (Protocol.DLCmd <> '') AND
(Protocol.MaxChrs = 0) THEN
BEGIN
Print('%LF^7You must specify the Max DOS Chars if you utilize the <D>L Command.^1');
Ok := FALSE;
END;
11 : IF (Protocol.ULCmd = '') AND (Protocol.DLCmd = '') THEN
BEGIN
Print('%LF^7You must specify a <U>L or <D>L Command.^1');
Ok := FALSE;
END;
12 : IF (CmdOk(Protocol)) AND (NOT (ProtIsBatch IN Protocol.PRFlags)) AND (Protocol.DLCmd = '') AND
(NOT DLCodesEmpty(Protocol)) THEN
BEGIN
Print('%LF^7You must specify a <D>L Command if you utilize <D>L Codes.^1');
Ok := FALSE;
END;
13 : IF (CmdOk(Protocol)) AND (NOT (ProtIsBatch IN Protocol.PRFlags)) AND (Protocol.ULCmd = '') AND
(NOT ULCodesEmpty(Protocol)) THEN
BEGIN
Print('%LF^7You must specify a <U>L Command if you utilize <U>L Codes.^1');
Ok := FALSE;
END;
14 : IF (CmdOk(Protocol)) AND (ProtIsBatch IN Protocol.PRFlags) AND (Protocol.TempLog = '') AND
(NOT DLCodesEmpty(Protocol)) THEN
BEGIN
Print('%LF^7You must specify a Temp Log if you utilize <D>L Codes.^1');
Ok := FALSE;
END;
END;
END;
PROCEDURE EditProtocol(TempProtocol1: ProtocolRecordType; VAR Protocol: ProtocolRecordType; VAR Cmd1: Char;
VAR RecNumToEdit: SmallInt; VAR Changed: Boolean; Editing: Boolean);
VAR
TempStr,
CmdStr: AStr;
Cmd2: Char;
Counter: Byte;
OK: Boolean;
BEGIN
WITH Protocol DO
REPEAT
IF (Cmd1 <> '?') THEN
BEGIN
MCIAllowed := FALSE;
Abort := FALSE;
Next := FALSE;
CLS;
IF (Editing) THEN
PrintACR('^5Editing protocol #'+IntToStr(RecNumToEdit)+' of '+IntToStr(NumProtocols))
ELSE
PrintACR('^5Inserting protocol #'+IntToStr(RecNumToEdit)+' of '+IntToStr(NumProtocols + 1));
NL;
PrintACR('^1!. Type/protocl: ^5'+
AOnOff(ProtActive IN PRFlags,'Active','INACTIVE')+' - '+
AOnOff(ProtIsBatch IN PRFlags,'Batch','Single')+
AOnOff(ProtIsResume IN PRFlags,' - Resume','')+
AOnOff(ProtBiDirectional IN PRFlags,' - Bidirectional','')+
AOnOff(ProtReliable IN PRFlags,' - Reliable only',''));
PrintACR('^11. Keys/descrip: ^5'+CKeys+'^1 / ^5'+AOnOff(Description = '','*None*',Description)+'^1');
PrintACR('^12. ACS required: ^5'+AOnOff(ACS = '','*None*',ACS)+'^1');
IF (CmdOk(Protocol)) AND (ProtIsBatch IN PRFLags) THEN
BEGIN
PrintACR('^13. Temp. log : ^5'+AOnOff(TempLog = '','*None*',TempLog));
IF (Protocol.TempLog <> '') THEN
PrintACR('^1 : File name position: ^5'+IntToStr(TempLogPF)+
' ^1/ Status position: ^5'+IntToStr(TempLogPS));
END;
IF (CmdOk(Protocol)) AND (ProtIsBatch IN PRFLags) THEN
BEGIN
PrintACR('^14. <U>L log : ^5'+AOnOff(ULoadLog = '','*None*',ULoadLog));
PrintACR('^1 <D>L log : ^5'+AOnOff(DLoadLog = '','*None*',DLoadLog));
END;
PrintACR('^15. <U>L command: ^5'+AOnOff(ULCmd = '','*None*',ULCmd));
PrintACR('^1 <D>L command: ^5'+AOnOff(DLCmd = '','*None*',DLCmd));
IF (ProtIsBatch IN PRFLags) AND (CMDOk(Protocol)) AND (Protocol.DLCmd <> '') THEN
PrintACR('^1 : DL File List: ^5'+AOnOff(DLFList = '','*None*',DLFList)+
' ^1/ Max DOS chars: ^5'+IntToStr(MaxChrs));
IF (CmdOk(Protocol)) THEN
PrintACR('^16. Codes mean : ^5'+AOnOff(ProtXferOkCode IN PRFlags,'Transfer Successful','Transfer Failed'));
IF (CmdOk(Protocol)) THEN
BEGIN
TempStr := '^17. <U>L codes :';
FOR Counter := 1 TO 3 DO
TempStr := TempStr + PadLeftStr('^1 ('+IntToStr(Counter)+') "^5'+ULCode[Counter]+'^1" ',13);
PrintACR(TempStr);
TempStr := '^1 :';
FOR Counter := 4 TO 6 DO
TempStr := TempStr + PadLeftStr('^1 ('+IntToStr(Counter)+') "^5'+ULCode[Counter]+'^1" ',13);
PrintACR(TempStr);
TempStr := '^1 <D>L codes :';
FOR Counter := 1 TO 3 DO
TempStr := TempStr + PadLeftStr('^1 ('+IntToStr(Counter)+') "^5'+DLCode[Counter]+'^1" ',13);
PrintACR(TempStr);
TempStr := '^1 :';
FOR Counter := 4 TO 6 DO
TempStr := TempStr + PadLeftStr('^1 ('+IntToStr(Counter)+') "^5'+DLCode[Counter]+'^1" ',13);
PrintACR(TempStr);
END;
IF (CmdOk(Protocol)) THEN
PrintACR('^18. Environ. cmd: ^5'+AOnOff(EnvCmd = '','*None*',EnvCmd));
MCIAllowed := TRUE;
END;
IF (NOT Editing) THEN
CmdStr := '!12345678'
ELSE
CmdStr := '!12345678[]FJL';
LOneK('%LFModify menu [^5?^4=^5Help^4]: ',Cmd1,'Q?'+CmdStr+^M,TRUE,TRUE);
CASE Cmd1 OF
'!' : BEGIN
REPEAT
Print('%LF^5Protocol types:^1');
Print('%LF^11. Protocol active : ^5'+ShowYesNo(ProtActive IN PRFlags));
Print('^12. Is batch protocol : ^5'+ShowYesNo(ProtIsBatch IN PRFlags));
Print('^13. Is resume protocol: ^5'+ShowYesNo(ProtIsResume IN PRFlags));
Print('^14. Is bidirectional : ^5'+ShowYesNo(ProtBiDirectional IN PRFlags));
Print('^15. For reliable only : ^5'+ShowYesNo(ProtReliable IN PRFlags));
LOneK('%LFNew protocol type? [^51^4-^55^4,^5<CR>^4=^5Quit^4]: ',Cmd1,^M'12345',TRUE,TRUE);
IF (Cmd1 IN ['1'..'5']) THEN
ToggleXBFlags(Cmd1,PRFlags,Changed);
UNTIL (Cmd1 = ^M) OR (HangUp);
Cmd1 := #0;
END;
'1' : BEGIN
REPEAT
Ok := TRUE;
TempProtocol1.Ckeys := CKeys;
InputWN1('%LFNew command keys: ',CKeys,(SizeOf(Ckeys) - 1),[InterActiveEdit],Changed);
CheckProtocol(Protocol,1,1,Ok);
IF (NOT Ok) THEN
Ckeys := TempProtocol1.Ckeys;
UNTIL (Ok) OR (HangUp);
REPEAT
Ok := TRUE;
TempProtocol1.Description := Description;
InputWNWC('%LFNew description: ',Description,(SizeOf(Description) - 1),Changed);
CheckProtocol(Protocol,2,2,Ok);
IF (NOT Ok) THEN
Description := TempProtocol1.Description;
UNTIL (Ok) OR (HangUp);
END;
'2' : InputWN1('%LFNew ACS: ',ACS,(SizeOf(ACS) - 1),[InterActiveEdit],Changed);
'3' : IF (CmdOk(Protocol)) AND (ProtIsBatch IN PRFlags) THEN
BEGIN
Print('%LFIf you specify a Temporary Log file, you must also');
Print('specify the "File Name" position, "Status" position and');
Print('the corresponding Batch <D>L Codes.');
InputWN1('%LFNew temporary log: ',TempLog,(SizeOf(TempLog) - 1),[InterActiveEdit],Changed);
IF (Protocol.TempLog = '') THEN
BEGIN
Protocol.TempLogPF := 0;
Protocol.TempLogPS := 0;
END;
IF (ProtIsBatch IN PRFLags) AND (CMDOk(Protocol)) AND (Protocol.TempLog <> '') THEN
BEGIN
REPEAT
Ok := TRUE;
TempProtocol1.TempLogPF := TempLogPF;
InputByteWC('%LFNew file name log position',TempLogPF,[DisplayValue,NumbersOnly],0,127,Changed);
CheckProtocol(Protocol,3,3,Ok);
IF (NOT Ok) THEN
TempLogPF := TempProtocol1.TempLogPF;
UNTIL (Ok) OR (HangUp);
REPEAT
Ok := TRUE;
TempProtocol1.TempLogPS := TempLogPS;
InputByteWC('%LFNew status log position',TempLogPS,[DisplayValue,NumbersOnly],0,127,Changed);
CheckProtocol(Protocol,4,4,Ok);
IF (NOT Ok) THEN
TempLogPS := TempProtocol1.TempLogPS;
UNTIL (Ok) OR (HangUp);
END;
END;
'4' : IF (CmdOk(Protocol)) AND (ProtIsBatch IN PRFlags) THEN
BEGIN
LOneK('%LFFile transfer type? [^5U^4=^5Upload^4,^5D^4=^5Download^4,^5<CR>^4=^5Quit^4]: ',
Cmd1,^M'UD',TRUE,TRUE);
CASE Cmd1 OF
'U' : BEGIN
Print('%LF^7The permanent batch upload log is not utilized by Renegade!^1');
PauseScr(FALSE);
END;
'D' : BEGIN
Print('%LFIf you specify a permanent batch download log, you must also');
Print('specify a temporary log.');
InputWN1('%LFNew permanent download log: ',DLoadLog,(SizeOf(DloadLog) - 1),
[InterActiveEdit],Changed);
END;
END;
Cmd1 := #0;
END;
'5' : BEGIN
TempStr := #0;
LOneK('%LFFile transfer type? [^5U^4=^5Upload^4,^5D^4=^5Download^4,^5<CR>^4=^5Quit^4]: ',
Cmd1,^M'UD',TRUE,TRUE);
IF (Cmd1 <> ^M) THEN
BEGIN
LOneK('%LFFile transfer method? [^5E^4=^5External^4,^5I^4=^5Internal^4,^5O^4=^5Off^4,^5<CR>^4=^5Quit^4]: ',
Cmd2,^M'EIO',TRUE,TRUE);
CASE Cmd2 OF
'E' : CASE Cmd1 OF
'U' : BEGIN
TempStr := ULCmd;
IF (CmdOk(Protocol)) AND (NOT (ProtIsBatch IN PRFlags)) THEN
BEGIN
Print('%LFIf you specify an external single upload protocol, you must also');
Print('specify single upload <U>L codes.');
END;
InputWN1('%LF^1New external upload protocol:%LF^4: ',TempStr,(SizeOf(DlCmd) - 1),
[InterActiveEdit],Changed);
END;
'D' : BEGIN
TempStr := DLCmd;
IF (CmdOk(Protocol)) THEN
IF (ProtIsBatch IN PRFlags) THEN
BEGIN
Print('%LFIf you specify an external batch download protocol, you must');
Print('also specify a batch file list and the maximum DOS characters');
Print('allowed on the DOS commandline.');
END
ELSE
BEGIN
Print('%LFIf you specify an external single download protocol, you must also');
Print('specify single download <D>L codes.');
END;
InputWN1('%LF^1New external download protocol:%LF^4: ',TempStr,(SizeOf(DlCmd) - 1),
[InterActiveEdit],Changed);
IF (TempStr = '') THEN
BEGIN
Protocol.DLFList := '';
Protocol.MaxChrs := 127;
END;
IF (CmdOk(Protocol)) AND (ProtIsBatch IN PRFlags) AND (TempStr <> '') THEN
BEGIN
REPEAT
Ok := TRUE;
TempProtocol1.DLFList := DLFList;
InputWN1('%LFNew batch file list: ',DLFList,(SizeOf(DLFList) - 1),
[InterActiveEdit],Changed);
CheckProtocol(Protocol,9,9,Ok);
IF (NOT Ok) THEN
DLFList := TempProtocol1.DLFList;
UNTIL (Ok) OR (HangUp);
REPEAT
Ok := TRUE;
TempProtocol1.MaxChrs := MaxChrs;
InputByteWC('%LFNew max DOS characters in commandline',MaxChrs,
[DisplayValue,NumbersOnly],0,127,Changed);
CheckProtocol(Protocol,10,10,Ok);
IF (NOT Ok) THEN
MaxChrs := TempProtocol1.MaxChrs;
UNTIL (Ok) OR (HangUp);
END;
END;
END;
'I' : BEGIN
Print('%LF^5Internal protocol types:^1');
NL;
LCmds(40,3,'ASCII','');
LCmds(40,3,'BATCH','');
LCmds(40,3,'EDIT','');
LCmds(40,3,'NEXT','');
LCmds(40,3,'QUIT','');
LOneK('%LFNew internal protocol? [^5A^4,^5B^4,^5E^4,^5N^4,^5Q^4,^5<CR>^4=^5Quit^4]: ',
Cmd2,^M'ABENQ',TRUE,TRUE);
IF (Cmd2 <> ^M) THEN
CASE Cmd2 OF
'A' : TempStr := 'ASCII';
'B' : TempStr := 'BATCH';
'E' : TempStr := 'EDIT';
'N' : TempStr := 'NEXT';
'Q' : TempStr := 'QUIT';
END;
IF (Cmd2 <> ^M) THEN
Changed := TRUE;
Cmd2 := #0;
END;
'O' : IF PYNQ('%LFSet to NULL string? ',0,FALSE) THEN
BEGIN
TempStr := '';
Changed := TRUE;
END;
END;
IF (TempStr <> #0) THEN
CASE Cmd1 OF
'D' : DLCmd := TempStr;
'U' : ULCmd := TempStr;
END;
IF (NOT CmdOk(Protocol)) THEN
BEGIN
TempLog := '';
ULoadLog := '';
DLoadLog := '';
FOR Counter := 1 TO 6 DO
BEGIN
ULCode[Counter] := '';
DLCode[Counter] := '';
END;
EnvCmd := '';
DLFList := '';
MaxChrs := 127;
TempLogPF := 0;
TempLogPS := 0;
END;
END;
Cmd1 := #0;
Cmd2 := #0;
END;
'6' : IF (CmdOk(Protocol)) THEN
ToggleXBFlags('6',PRFlags,Changed);
'7' : IF (CmdOk(Protocol)) THEN
BEGIN
LOneK('%LFFile transfer type? [^5U^4=^5Upload^4,^5D^4=^5Download^4,^5<CR>^4=^5Quit^4]: ',
Cmd1,'UD'^M,TRUE,TRUE);
CASE Cmd1 OF
'U' : BEGIN
IF (ProtIsBatch IN PRFlags) THEN
BEGIN
Print('%LF^7The batch upload codes are not utilized by Renegade!^1');
PauseScr(FALSE);
END
ELSE
BEGIN
Print('%LF^5New upload codes:^1');
FOR Counter := 1 TO 6 DO
InputWN1('%LFCode #'+IntToStr(Counter)+': ',ULCode[Counter],
(SizeOf(ULCode[Counter]) - 1),[InterActiveEdit],Changed);
END;
END;
'D' : BEGIN
Print('%LF^5New download codes:^1');
FOR Counter := 1 TO 6 DO
InputWN1('%LFCode #'+IntToStr(Counter)+': ',DLCode[Counter],
(SizeOf(DlCode[Counter]) - 1),[InterActiveEdit],Changed);
END;
END;
Cmd1 := #0;
END;
'8' : IF (CmdOk(Protocol)) THEN
InputWN1('%LFNew environment setup commandline:%LF: ',EnvCmd,(SizeOf(EnvCmd) - 1),[InterActiveEdit],Changed);
'[' : IF (RecNumToEdit > 1) THEN
Dec(RecNumToEdit)
ELSE
BEGIN
Messages(2,0,'');
Cmd1 := #0;
END;
']' : IF (RecNumToEdit < NumProtocols) THEN
Inc(RecNumToEdit)
ELSE
BEGIN
Messages(3,0,'');
Cmd1 := #0;
END;
'F' : IF (RecNumToEdit <> 1) THEN
RecNumToEdit := 1
ELSE
BEGIN
Messages(2,0,'');
Cmd1 := #0;
END;
'J' : BEGIN
InputIntegerWOC('%LFJump to entry?',RecNumToEdit,[NumbersOnly],1,NumProtocols);
IF (RecNumToEdit < 1) OR (RecNumToEdit > NumProtocols) THEN
Cmd1 := #0;
END;
'L' : IF (RecNumToEdit <> NumProtocols) THEN
RecNumToEdit := NumProtocols
ELSE
BEGIN
Messages(3,0,'');
Cmd1 := #0;
END;
'?' : BEGIN
Print('%LF^1<^3CR^1>Redisplay current screen');
Print('^31^1-^38^1:Modify item');
IF (NOT Editing) THEN
LCmds(20,3,'Quit and save','')
ELSE
BEGIN
LCmds(20,3,'[Back entry',']Forward entry');
LCmds(20,3,'First entry in list','Jump to entry');
LCmds(20,3,'Last entry in list','Quit and save');
END;
END;
END;
UNTIL (Pos(Cmd1,'Q[]FJL') <> 0) OR (HangUp);
END;
PROCEDURE InsertProtocol(TempProtocol1: ProtocolRecordType; RecNumToInsertBefore: SmallInt);
VAR
Cmd1: Char;
RecNum,
RecNumToEdit: SmallInt;
Ok,
Changed: Boolean;
BEGIN
IF (NumProtocols = MaxProtocols) THEN
Messages(5,MaxProtocols,'protocols')
ELSE
BEGIN
RecNumToInsertBefore := -1;
InputIntegerWOC('%LFProtocol to insert before?',RecNumToInsertBefore,[NumbersOnly],1,(NumProtocols + 1));
IF (RecNumToInsertBefore >= 1) AND (RecNumToInsertBefore <= (NumProtocols + 1)) THEN
BEGIN
Reset(ProtocolFile);
InitProtocolVars(TempProtocol1);
IF (RecNumToInsertBefore = 1) THEN
RecNumToEdit := 1
ELSE IF (RecNumToInsertBefore = (NumProtocols + 1)) THEN
RecNumToEdit := (NumProtocols + 1)
ELSE
RecNumToEdit := RecNumToInsertBefore;
REPEAT
OK := TRUE;
EditProtocol(TempProtocol1,TempProtocol1,Cmd1,RecNumToEdit,Changed,FALSE);
CheckProtocol(TempProtocol1,1,14,Ok);
IF (NOT OK) THEN
IF (NOT PYNQ('%LFContinue inserting protocol? ',0,TRUE)) THEN
Abort := TRUE;
UNTIL (OK) OR (Abort) OR (HangUp);
IF (NOT Abort) AND (PYNQ('%LFIs this what you want? ',0,FALSE)) THEN
BEGIN
Print('%LF[> Inserting protocol record ...');
Seek(ProtocolFile,FileSize(ProtocolFile));
Write(ProtocolFile,Protocol);
Dec(RecNumToInsertBefore);
FOR RecNum := ((FileSize(ProtocolFile) - 1) - 1) DOWNTO RecNumToInsertBefore DO
BEGIN
Seek(ProtocolFile,RecNum);
Read(ProtocolFile,Protocol);
Seek(ProtocolFile,(RecNum + 1));
Write(ProtocolFile,Protocol);
END;
FOR RecNum := RecNumToInsertBefore TO ((RecNumToInsertBefore + 1) - 1) DO
BEGIN
Seek(ProtocolFile,RecNum);
Write(ProtocolFile,TempProtocol1);
Inc(NumProtocols);
SysOpLog('* Inserted protocol: ^5'+TempProtocol1.Description);
END;
Close(ProtocolFile);
LastError := IOResult;
END;
END;
END;
END;
PROCEDURE ModifyProtocol(TempProtocol1: ProtocolRecordType; Cmd1: Char; RecNumToEdit: SmallInt);
VAR
SaveRecNumToEdit: Integer;
Ok,
Changed: Boolean;
BEGIN
IF (NumProtocols = 0) THEN
Messages(4,0,'protocols')
ELSE
BEGIN
RecNumToEdit := -1;
InputIntegerWOC('%LFProtocol to modify?',RecNumToEdit,[NumbersOnly],1,NumProtocols);
IF (RecNumToEdit >= 1) AND (RecNumToEdit <= NumProtocols) THEN
BEGIN
SaveRecNumToEdit := -1;
Cmd1 := #0;
Reset(ProtocolFile);
WHILE (Cmd1 <> 'Q') AND (NOT HangUp) DO
BEGIN
IF (SaveRecNumToEdit <> RecNumToEdit) THEN
BEGIN
Seek(ProtocolFile,(RecNumToEdit - 1));
Read(ProtocolFile,Protocol);
SaveRecNumToEdit := RecNumToEdit;
Changed := FALSE;
END;
REPEAT
Ok := TRUE;
EditProtocol(TempProtocol1,Protocol,Cmd1,RecNumToEdit,Changed,TRUE);
CheckProtocol(Protocol,1,14,Ok);
IF (NOT OK) THEN
BEGIN
PauseScr(FALSE);
IF (RecNumToEdit <> SaveRecNumToEdit) THEN
RecNumToEdit := SaveRecNumToEdit;
END;
UNTIL (OK) OR (HangUp);
IF (Changed) THEN
BEGIN
Seek(ProtocolFile,(SaveRecNumToEdit - 1));
Write(ProtocolFile,Protocol);
Changed := FALSE;
SysOpLog('* Modified protocol: ^5'+Protocol.Description);
END;
END;
Close(ProtocolFile);
LastError := IOResult;
END;
END;
END;
PROCEDURE PositionProtocol(TempProtocol1: ProtocolRecordType; RecNumToPosition: SmallInt);
VAR
RecNumToPositionBefore,
RecNum1,
RecNum2: SmallInt;
BEGIN
IF (NumProtocols = 0) THEN
Messages(4,0,'protocols')
ELSE IF (NumProtocols = 1) THEN
Messages(6,0,'protocols')
ELSE
BEGIN
RecNumToPosition := -1;
InputIntegerWOC('%LFPosition which protocol?',RecNumToPosition,[NumbersOnly],1,NumProtocols);
IF (RecNumToPosition >= 1) AND (RecNumToPosition <= NumProtocols) THEN
BEGIN
RecNumToPositionBefore := -1;
Print('%LFAccording to the current numbering system.');
InputIntegerWOC('%LFPosition before which protocol?',RecNumToPositionBefore,[NumbersOnly],1,(NumProtocols + 1));
IF (RecNumToPositionBefore >= 1) AND (RecNumToPositionBefore <= (NumProtocols + 1)) AND
(RecNumToPositionBefore <> RecNumToPosition) AND (RecNumToPositionBefore <> (RecNumToPosition + 1)) THEN
BEGIN
Print('%LF[> Positioning protocol records ...');
IF (RecNumToPositionBefore > RecNumToPosition) THEN
Dec(RecNumToPositionBefore);
Dec(RecNumToPosition);
Dec(RecNumToPositionBefore);
Reset(ProtocolFile);
Seek(ProtocolFile,RecNumToPosition);
Read(ProtocolFile,TempProtocol1);
RecNum1 := RecNumToPosition;
IF (RecNumToPosition > RecNumToPositionBefore) THEN
RecNum2 := -1
ELSE
RecNum2 := 1;
WHILE (RecNum1 <> RecNumToPositionBefore) DO
BEGIN
IF ((RecNum1 + RecNum2) < FileSize(ProtocolFile)) THEN
BEGIN
Seek(ProtocolFile,(RecNum1 + RecNum2));
Read(ProtocolFile,Protocol);
Seek(ProtocolFile,RecNum1);
Write(ProtocolFile,Protocol);
END;
Inc(RecNum1,RecNum2);
END;
Seek(ProtocolFile,RecNumToPositionBefore);
Write(ProtocolFile,TempProtocol1);
Close(ProtocolFile);
LastError := IOResult;
END;
END;
END;
END;
PROCEDURE ListProtocols(VAR RecNumToList1: Integer);
VAR
NumDone: Integer;
BEGIN
IF (RecNumToList1 < 1) OR (RecNumToList1 > NumProtocols) THEN
RecNumToList1 := 1;
Abort := FALSE;
Next := FALSE;
CLS;
PrintACR('^0 ###^4:^3ACS ^4:^3Description');
PrintACR('^4 ===:==========:=============================================================');
Reset(ProtocolFile);
NumDone := 0;
WHILE (NumDone < (PageLength - 5)) AND (RecNumToList1 >= 1) AND (RecNumToList1 <= NumProtocols)
AND (NOT Abort) AND (NOT HangUp) DO
BEGIN
Seek(ProtocolFile,(RecNumToList1 - 1));
Read(ProtocolFile,Protocol);
WITH Protocol DO
PrintACR(AOnOff((ProtActive IN PRFlags),'^5+','^1-')+
'^0'+PadRightInt(RecNumToList1,3)+
' ^9'+PadLeftStr(ACS,10)+
' ^1'+Description);
Inc(RecNumToList1);
Inc(Numdone);
END;
Close(ProtocolFile);
LastError := IOResult;
IF (NumProtocols = 0) THEN
Print('*** No protocols defined ***');
END;
BEGIN
SaveTempPause := TempPause;
TempPause := FALSE;
RecNumToList := 1;
Cmd := #0;
REPEAT
IF (Cmd <> '?') THEN
ListProtocols(RecNumToList);
LOneK('%LFProtocol editor [^5?^4=^5Help^4]: ',Cmd,'QDIMP?'^M,TRUE,TRUE);
CASE Cmd OF
^M : IF (RecNumToList < 1) OR (RecNumToList > NumProtocols) THEN
RecNumToList := 1;
'D' : DeleteProtocol(TempProtocol,RecNumToList);
'I' : InsertProtocol(TempProtocol,RecNumToList);
'M' : ModifyProtocol(TempProtocol,Cmd,RecNumToList);
'P' : PositionProtocol(TempProtocol,RecNumToList);
'?' : BEGIN
Print('%LF^1<^3CR^1>Next screen or redisplay current screen');
Print('^1(^3?^1)Help/First protocol');
LCmds(16,3,'Delete protocol','Insert protocol');
LCmds(16,3,'Modify protocol','Position protocol');
LCmds(16,3,'Quit','');
END;
END;
IF (Cmd <> ^M) THEN
RecNumToList := 1;
UNTIL (Cmd = 'Q') OR (HangUp);
TempPause := SaveTempPause;
LastError := IOResult;
END;
END.

746
SOURCE/SYSOP10.PAS Normal file
View File

@ -0,0 +1,746 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S+,V-}
UNIT SysOp10;
INTERFACE
PROCEDURE VotingEditor;
IMPLEMENTATION
USES
Common,
MiscUser;
PROCEDURE VotingEditor;
VAR
TempTopic: VotingRecordType;
Cmd: Char;
RecNumToList: Byte;
SaveTempPause: Boolean;
PROCEDURE InitTopicVars(VAR Topic: VotingRecordType);
VAR
User: UserRecordType;
Counter: Byte;
BEGIN
LoadURec(User,UserNum);
FillChar(Topic,SizeOf(Topic),0);
WITH Topic DO
BEGIN
Question1 := '<< New Voting Topic >>';
Question2 := '';
ACS := 'VV';
ChoiceNumber := 0;
NumVotedQuestion := 0;
CreatedBy := Caps(User.Name);
AddAnswersACS := General.AddChoice;
FOR Counter := 1 TO MaxChoices DO
WITH Answers[Counter] DO
BEGIN
Answer1 := '<< New Topic Choice >>';
Answer2 := '';
NumVotedAnswer := 0;
END;
END;
END;
PROCEDURE DeleteChoice(VAR Topic: VotingRecordType; RecNumToDelete: Byte; VAR Changed: Boolean);
VAR
User: UserRecordType;
RecNum,
RecNum1: Byte;
UNum: Integer;
BEGIN
IF (Topic.ChoiceNumber < 1) THEN
Messages(4,0,'topic choices')
ELSE
BEGIN
RecNum := 0;
InputByteWOC('%LFDelete which choice',RecNum,[Numbersonly],1,Topic.ChoiceNumber);
IF (RecNum >= 1) AND (RecNum <= Topic.ChoiceNumber) THEN
BEGIN
Dec(Topic.ChoiceNumber);
Dec(Topic.NumVotedQuestion,Topic.Answers[RecNum].NumVotedAnswer);
IF (RecNum < MaxChoices) THEN
FOR RecNum1 := RecNum TO Topic.ChoiceNumber DO
BEGIN
Topic.Answers[RecNum1].Answer1 := Topic.Answers[RecNum1 + 1].Answer1;
Topic.Answers[RecNum1].Answer2 := Topic.Answers[RecNum1 + 1].Answer2;
Topic.Answers[RecNum1].NumVotedAnswer := Topic.Answers[RecNum1 + 1].NumVotedAnswer;
END;
Reset(UserFile);
FOR UNum := 1 TO (FileSize(UserFile) - 1) DO
BEGIN
Seek(UserFile,Unum);
Read(UserFile,User);
IF (User.Vote[RecNumToDelete] = RecNum) THEN
User.Vote[RecNumToDelete] := 0
ELSE IF (User.Vote[RecNumToDelete] > RecNum) THEN
Dec(User.Vote[RecNumToDelete]);
Seek(UserFile,UNum);
Write(UserFile,User);
END;
Close(UserFile);
IF (ThisUser.Vote[RecNumToDelete] = RecNum) THEN
ThisUser.Vote[RecNumToDelete] := 0;
Changed := TRUE;
END;
END;
END;
PROCEDURE InsertChoice(VAR Topic: VotingRecordType; RecNumToEdit: Byte; VAR Changed: Boolean);
BEGIN
IF (Topic.ChoiceNumber >= MaxChoices) THEN
Messages(5,MaxChoices,'topic choices')
ELSE IF PYNQ('%LFAdd topic choice #'+IntToStr(Topic.ChoiceNumber + 1)+'? ',0,FALSE) THEN
BEGIN
InputWNWC('%LFChoice: ',Topic.Answers[Topic.ChoiceNumber + 1].Answer1,65,Changed);
IF (Topic.Answers[Topic.ChoiceNumber + 1].Answer1 <> '') THEN
BEGIN
Topic.Answers[Topic.ChoiceNumber + 1].NumVotedAnswer := 0;
InputWNWC(PadLeftStr('',6)+': ',Topic.Answers[Topic.ChoiceNumber + 1].Answer2,65,Changed);
Inc(Topic.ChoiceNumber);
END;
Changed := TRUE;
END;
END;
PROCEDURE CheckChoice(Topic: VotingRecordType; RecNum1: Byte; StartErrMsg,EndErrMsg: Byte; VAR Ok: Boolean);
VAR
Counter: Byte;
BEGIN
FOR Counter := StartErrMsg TO EndErrMsg DO
CASE Counter OF
1 : IF (Topic.Answers[RecNum1].Answer1 = '') OR (Topic.Answers[RecNum1].Answer1 = '<< New Topic Choice >>') THEN
BEGIN
Print('%LF^7The answer is invalid!^1');
OK := FALSE;
END;
END;
END;
PROCEDURE ModifyChoice(TempTopic1: VotingRecordType; VAR Topic: VotingRecordType; RecNumToEdit: Byte; VAR Changed: Boolean);
VAR
Cmd1: Char;
RecNum: Byte;
Ok: Boolean;
BEGIN
IF (Topic.ChoiceNumber < 1) THEN
Messages(4,0,'topic choices')
ELSE
BEGIN
RecNum := 0;
InputByteWOC('%LFModify which choice',RecNum,[Numbersonly],1,Topic.ChoiceNumber);
IF (RecNum >= 1) AND (RecNum <= Topic.ChoiceNumber) THEN
BEGIN
REPEAT
IF (Cmd1 <> '?') THEN
BEGIN
Abort := FALSE;
Next := FALSE;
Print('%CL^5Topic choice #'+IntToStr(RecNum)+' of '+IntToStr(Topic.ChoiceNumber));
NL;
PrintACR('^11. Choice: ^5'+Topic.Answers[RecNum].Answer1);
IF (Topic.Answers[RecNum].Answer2 <> '') THEN
PrintACR('^1 : ^5'+Topic.Answers[RecNum].Answer2);
PrintACR('^12. Voters: ^5'+IntToStr(Topic.Answers[RecNum].NumVotedAnswer));
END;
LOneK('%LFModify menu [^5?^4=^5Help^4]: ',Cmd1,'Q12[]FJL?'^M,TRUE,TRUE);
CASE Cmd1 OF
'1' : BEGIN
REPEAT
TempTopic1.Answers[RecNum].Answer1 := Topic.Answers[RecNum].Answer1;
Ok := TRUE;
InputWNWC('%LFNew choice: ',Topic.Answers[RecNum].Answer1,
(SizeOf(Topic.Answers[RecNum].Answer1) - 1),Changed);
CheckChoice(Topic,RecNum,1,1,Ok);
IF (NOT Ok) THEN
Topic.Answers[RecNum].Answer1 := TempTopic1.Answers[RecNum].Answer1;
UNTIL (Ok) OR (HangUp);
IF (Topic.Answers[RecNum].Answer1 <> '') THEN
InputWNWC(PadLeftStr('',10)+': ',Topic.Answers[Recnum].Answer2,
(SizeOf(Topic.Answers[RecNum].Answer2) - 1),Changed);
END;
'2' : InputIntegerWC('%LFNew number of voters',Topic.Answers[RecNum].NumVotedAnswer,[DisplayValue,NumbersOnly],0,
(MaxUsers - 1),Changed);
'[' : IF (RecNum > 1) THEN
Dec(RecNum)
ELSE
BEGIN
Messages(2,0,'');
Cmd1 := #0;
END;
']' : IF (RecNum < Topic.ChoiceNumber) THEN
Inc(RecNum)
ELSE
BEGIN
Messages(3,0,'');
Cmd1 := #0;
END;
'F' : IF (RecNum <> 1) THEN
RecNum := 1
ELSE
BEGIN
Messages(2,0,'');
Cmd1 := #0;
END;
'J' : BEGIN
InputByteWOC('%LFJump to entry',RecNum,[Numbersonly],1,Topic.ChoiceNumber);
IF (RecNum < 1) OR (RecNum > Topic.ChoiceNumber) THEN
Cmd1 := #0;
END;
'L' : IF (RecNum <> Topic.ChoiceNumber) THEN
RecNum := Topic.ChoiceNumber
ELSE
BEGIN
Messages(3,0,'');
Cmd1 := #0;
END;
'?' : BEGIN
Print('%LF^1<^3CR^1>Redisplay screen');
Print('^31-2^1:Modify item');
LCmds(20,3,'[Back entry',']Forward entry');
LCmds(20,3,'First entry in list','Jump to entry');
LCmds(20,3,'Last entry in list','Quit and save');
END;
END;
UNTIL (Cmd1 = 'Q') OR (HangUp);
END;
END;
END;
PROCEDURE ListChoices(VAR Topic: VotingRecordType; VAR RecNumToList1: Byte);
VAR
NumDone: Byte;
BEGIN
IF (RecNumToList1 < 1) OR (RecNumToList1 > Topic.ChoiceNumber) THEN
RecNumToList1 := 1;
Abort := FALSE;
Next := FALSE;
CLS;
PrintACR('^0##^4:^3Answer^4:^3Choice');
PrintACR('^4==:======:=====================================================================');
NumDone := 0;
WHILE (NumDone < (PageLength - 5)) AND (RecNumToList1 >= 1) AND (RecNumToList1 <= Topic.ChoiceNumber)
AND (NOT Abort) AND (NOT HangUp) DO
BEGIN
PrintACR('^0'+PadRightInt(RecNumToList1,2)+
' ^3'+PadRightInt(Topic.Answers[RecNumToList1].NumVotedAnswer,6)+
' ^5'+Topic.Answers[RecNumToList1].Answer1);
WKey;
Inc(RecNumToList1);
Inc(NumDone);
END;
IF (Topic.ChoiceNumber = 0) THEN
Print('*** No voting choices defined ***');
END;
PROCEDURE ChoiceEditor(TempTopic1: VotingRecordType; VAR Topic: VotingRecordType; Cmd1: Char;
RecNumToEdit: Byte; VAR Changed: Boolean);
VAR
RecNumToList1: Byte;
BEGIN
SaveTempPause := TempPause;
TempPause := FALSE;
RecNumToList1 := 1;
Cmd1 := #0;
REPEAT
IF (Cmd1 <> '?') THEN
ListChoices(Topic,RecNumToList1);
LOneK('%LFTopic choice editor [^5?^4=^5Help^4]: ',Cmd1,'QDIM?'^M,TRUE,TRUE);
CASE Cmd1 OF
^M : IF (RecNumToList1 < 1) OR (RecNumToList1 > Topic.ChoiceNumber) THEN
RecNumToList1 := 1;
'D' : DeleteChoice(Topic,RecNumToEdit,Changed);
'I' : InsertChoice(Topic,RecNumToEdit,Changed);
'M' : ModifyChoice(TempTopic1,Topic,RecNumToEdit,Changed);
'?' : BEGIN
Print('%LF^1<^3CR^1>Next screen or redisplay current screen');
Print('^1(^3?^1)Help/First topic choice');
LCmds(20,3,'Delete topic choice','Insert topic choice');
LCmds(20,3,'Modify topic choice','Quit');
END;
END;
IF (Cmd1 <> ^M) THEN
RecNumToList1 := 1;
UNTIL (Cmd1 = 'Q') OR (HangUp);
TempPause := SaveTempPause;
END;
PROCEDURE DeleteTopic(TempTopic1: VotingRecordType; RecNumToDelete: Byte);
VAR
User: UserRecordType;
RecNum: Integer;
BEGIN
IF (NumVotes = 0) THEN
Messages(4,0,'voting topics')
ELSE
BEGIN
RecNumToDelete := 0;
InputByteWOC('%LFVoting topic to delete',RecNumToDelete,[NumbersOnly],1,NumVotes);
IF (RecNumToDelete >= 1) AND (RecNumToDelete <= NumVotes) THEN
BEGIN
Reset(VotingFile);
Seek(VotingFile,(RecNumToDelete - 1));
Read(VotingFile,TempTopic1);
Close(VotingFile);
LastError := IOResult;
Print('%LF^1Voting topic: ^5'+TempTopic1.Question1);
IF (TempTopic1.Question2 <> '') THEN
Print('^1'+PadLeftStr('',12)+': ^5'+TempTopic1.Question2);
IF PYNQ('%LFAre you sure you want to delete it? ',0,FALSE) THEN
BEGIN
Print('%LF[> Deleting voting topic record ...');
Dec(RecNumToDelete);
Reset(VotingFile);
IF (RecNumToDelete >= 0) AND (RecNumToDelete <= (FileSize(VotingFile) - 2)) THEN
FOR RecNum := RecNumToDelete TO (FileSize(VotingFile) - 2) DO
BEGIN
Seek(VotingFile,(RecNum + 1));
Read(VotingFile,Topic);
Seek(VotingFile,RecNum);
Write(VotingFile,Topic);
END;
Seek(VotingFile,(FileSize(VotingFile) - 1));
Truncate(VotingFile);
Close(VotingFile);
LastError := IOResult;
SysOpLog('* Deleted topic: ^5'+TempTopic1.Question1);
IF (Topic.Question2 <> '') THEN
SysOpLog(PadLeftStr('',15)+': ^5'+TempTopic1.Question2);
Reset(UserFile);
FOR RecNum := 1 TO (FileSize(UserFile) - 1) DO
BEGIN
Seek(UserFile,RecNum);
Read(UserFile,User);
Move(User.Vote[RecNumToDelete + 1],User.Vote[RecNumToDelete],(MaxVotes - RecNumToDelete));
User.Vote[25] := 0;
Seek(UserFile,RecNum);
Write(UserFile,User);
END;
Close(UserFile);
LastError := IOResult;
Move(ThisUser.Vote[RecNumToDelete + 1],ThisUser.Vote[RecNumToDelete],(MaxVotes - RecNumToDelete));
ThisUser.Vote[25] := 0;
Dec(NumVotes);
END;
END;
END;
END;
PROCEDURE CheckTopic(Topic: VotingRecordType; StartErrMsg,EndErrMsg: Byte; VAR Ok: Boolean);
VAR
Counter,
Counter1: Byte;
BEGIN
FOR Counter := StartErrMsg TO EndErrMsg DO
CASE Counter OF
1 : IF (Topic.Question1 = '') OR (Topic.Question1 = '<< New Voting Topic >>') THEN
BEGIN
Print('%LF^7The question is invalid!^1');
OK := FALSE;
END;
2 : IF (Topic.ChoiceNumber = 0) THEN
BEGIN
Print('%LF^7You must setup choices for your topic!^1');
OK := FALSE;
END;
END;
END;
PROCEDURE EditTopic(TempTopic1: VotingRecordType; VAR Topic: VotingRecordType; VAR Cmd1: Char;
VAR RecNumToEdit: Byte; VAR Changed: Boolean; Editing: Boolean);
VAR
User: UserRecordType;
CmdStr: AStr;
Unum: Integer;
Ok: Boolean;
BEGIN
WITH Topic DO
REPEAT
IF (Cmd1 <> '?') THEN
BEGIN
Abort := FALSE;
Next := FALSE;
CLS;
IF (Editing) THEN
PrintACR('^5Editing voting topic #'+IntToStr(RecNumToEdit)+' of '+IntToStr(NumVotes))
ELSE
PrintACR('^5Inserting voting topic #'+IntToStr(RecNumToEdit)+' of '+IntToStr(NumVotes + 1));
NL;
PrintACR('^11. Topic : ^5'+Question1);
IF (Question2 <> '') THEN
PrintACR('^1'+PadLeftStr('',16)+': ^5'+Question2);
PrintACR('^12. Creator : ^5'+CreatedBy);
PrintACR('^13. ACS to vote : ^5'+AOnOff(ACS = '','*None*',ACS));
PrintACR('^14. ACS to add : ^5'+AOnOff(AddAnswersACS = '','*None*',AddAnswersACS));
PrintACR('^15. Total votes : ^5'+IntToStr(NumVotedQuestion));
Print('%LF^1[Choices on this topic: ^5'+IntToStr(ChoiceNumber)+'^1]');
END;
IF (NOT Editing) THEN
CmdStr := '12345C'
ELSE
CmdStr := '12345C[]FJL';
LOneK('%LFModify menu [^5C^4=^5Choice Editor^4,^5?^4=^5Help^4]: ',Cmd1,'Q?'+CmdStr+^M,TRUE,TRUE);
CASE Cmd1 OF
'1' : BEGIN
REPEAT
TempTopic1.Question1 := Question1;
Ok := TRUE;
InputWNWC('%LFNew topic: ',Question1,(SizeOf(Question1) - 1),Changed);
CheckTopic(Topic,1,1,Ok);
IF (NOT Ok) THEN
Question1 := TempTopic1.Question1;
UNTIL (Ok) OR (HangUp);
IF (Question1 <> '') THEN
InputWNWC(PadLeftStr('',9)+': ',Question2,(SizeOf(Question2) - 1),Changed);
END;
'2' : BEGIN
Print('%LF^5New creator of this topic (1-'+IntToStr(MaxUsers - 1)+')?^1');
Print('%LFEnter User Number, Name, or Partial Search String.');
Prt(': ');
lFindUserWS(Unum);
IF (Unum < 1) THEN
PauseScr(FALSE)
ELSE
BEGIN
LoadURec(User,UNum);
IF (CreatedBy <> Caps(User.Name)) THEN
IF (PYNQ('%LFSet the new creator name to '+Caps(User.Name)+'? ',0,FALSE)) THEN
BEGIN
CreatedBy := Caps(User.Name);
Changed := TRUE;
END;
END;
END;
'3' : InputWN1('%LFNew voting ACS: ',ACS,(SizeOf(ACS) - 1),[InterActiveEdit],Changed);
'4' : IF PYNQ('%LFAllow other users to add choices? ',0,FALSE) THEN
AddAnswersACS := ACS
ELSE
AddAnswersACS := General.AddChoice;
'5' : InputIntegerWOC('%LFNew number of voters',NumVotedQuestion,[DisplayValue,NumbersOnly],0,(MaxUsers - 1));
'C' : ChoiceEditor(TempTopic1,Topic,Cmd1,RecNumToEdit,Changed);
'[' : IF (RecNumToEdit > 1) THEN
Dec(RecNumToEdit)
ELSE
BEGIN
Messages(2,0,'');
Cmd1 := #0;
END;
']' : IF (RecNumToEdit < NumVotes) THEN
Inc(RecNumToEdit)
ELSE
BEGIN
Messages(3,0,'');
Cmd1 := #0;
END;
'F' : IF (RecNumToEdit <> 1) THEN
RecNumToEdit := 1
ELSE
BEGIN
Messages(2,0,'');
Cmd1 := #0;
END;
'J' : BEGIN
InputByteWOC('%LFJump to entry',RecNumToEdit,[NumbersOnly],1,NumVotes);
IF (RecNumToEdit < 1) OR (RecNumToEdit > NumVotes) THEN
Cmd1 := #0;
END;
'L' : IF (RecNumToEdit <> NumVotes) THEN
RecNumToEdit := NumVotes
ELSE
BEGIN
Messages(3,0,'');
Cmd1 := #0;
END;
'?' : BEGIN
Print('%LF^1<^3CR^1>Redisplay current screen');
Print('^31^1-^35^1,^3C^1:Modify item');
IF (NOT Editing) THEN
LCmds(20,3,'Quit and save','')
ELSE
BEGIN
LCmds(20,3,'[Back entry',']Forward entry');
LCmds(20,3,'First entry in list','Jump to entry');
LCmds(20,3,'Last entry in list','Quit and save');
END;
END;
END;
UNTIL (Pos(Cmd1,'Q[]FJL') <> 0) OR (HangUp);
END;
PROCEDURE InsertTopic(TempTopic1: VotingRecordType; Cmd1: Char; RecNumToInsertBefore: Byte);
VAR
RecNumToEdit: Byte;
Ok,
Changed: Boolean;
BEGIN
IF (NumVotes = MaxVotes) THEN
Messages(5,MaxVotes,'voting topics')
ELSE IF (PYNQ('%LFAdd voting topic #'+IntToStr(NumVotes + 1)+'? ',0,FALSE)) THEN
BEGIN
Reset(VotingFile);
InitTopicVars(TempTopic1);
RecNumToInsertBefore := (FileSize(VotingFile) + 1);
IF (RecNumToInsertBefore = 1) THEN
RecNumToedit := 1
ELSE IF (RecNumToInsertBefore = (NumVotes + 1)) THEN
RecNumToEdit := (NumVotes + 1)
ELSE
RecNumToEdit := RecNumToInsertBefore;
REPEAT
OK := TRUE;
EditTopic(TempTopic1,TempTopic1,Cmd1,RecNumToEdit,Changed,FALSE);
CheckTopic(TempTopic1,1,2,Ok);
IF (NOT OK) THEN
IF (NOT PYNQ('%LFContinue inserting topic? ',0,TRUE)) THEN
Abort := TRUE;
UNTIL (OK) OR (Abort) OR (HangUp);
IF (NOT Abort) AND (PYNQ('%LFIs this what you want? ',0,FALSE)) THEN
BEGIN
Print('%LF[> Inserting voting topic record ...');
Seek(VotingFile,FileSize(VotingFile));
Write(VotingFile,TempTopic1);
Close(VotingFile);
LastError := IOResult;
Inc(NumVotes);
SysOpLog('* Inserted topic: ^5'+TempTopic1.Question1);
IF (TempTopic1.Question2 <> '') THEN
SysOpLog(PadLeftStr('',16)+': ^5'+TempTopic1.Question2);
END;
END;
END;
PROCEDURE ModifyTopic(TempTopic1: VotingRecordType; Cmd1: Char; RecNumToEdit: Byte);
VAR
SaveRecNumToEdit: Byte;
Ok,
Changed: Boolean;
BEGIN
IF (NumVotes = 0) THEN
Messages(4,0,'voting topics')
ELSE
BEGIN
RecNumToEdit := 0;
InputByteWOC('%LFModify which topic',RecNumToEdit,[NumbersOnly],1,NumVotes);
IF (RecNumToEdit >= 1) AND (RecNumToEdit <= NumVotes) THEN
BEGIN
SaveRecNumToEdit := 0;
Cmd1 := #0;
Reset(VotingFile);
WHILE (Cmd1 <> 'Q') AND (NOT HangUp) DO
BEGIN
IF (SaveRecNumToEdit <> RecNumToEdit) THEN
BEGIN
Seek(VotingFile,(RecNumToEdit - 1));
Read(VotingFile,Topic);
SaveRecNumToEdit := RecNumToEdit;
Changed := FALSE;
END;
REPEAT
Ok := TRUE;
EditTopic(TempTopic1,Topic,Cmd1,RecNumToEdit,Changed,TRUE);
CheckTopic(Topic,1,2,Ok);
IF (NOT OK) THEN
BEGIN
PauseScr(FALSE);
IF (RecNumToEdit <> SaveRecNumToEdit) THEN
RecNumToEdit := SaveRecNumToEdit;
END;
UNTIL (Ok) OR (HangUp);
IF (Changed) THEN
BEGIN
Seek(VotingFile,(SaveRecNumToEdit - 1));
Write(VotingFile,Topic);
Changed := FALSE;
SysOpLog('* Modified topic: ^5'+Topic.Question1);
IF (Topic.Question2 <> '') THEN
SysOpLog(PadLeftStr('',16)+': ^5'+Topic.Question2);
END;
END;
Close(VotingFile);
LastError := IOResult;
END;
END;
END;
PROCEDURE ResetTopic(RecNumToReset: Byte);
VAR
User: UserRecordType;
RecNum: Byte;
UNum: Integer;
BEGIN
IF (NumVotes = 0) THEN
Messages(4,0,'voting topics')
ELSE
BEGIN
RecNumToReset := 0;
InputByteWOC('%LFReset which topic',RecNumToReset,[NumbersOnly],1,NumVotes);
IF (RecNumToReset >= 1) AND (RecNumToReset <= NumVotes) THEN
BEGIN
Reset(VotingFile);
Seek(VotingFile,(RecNumToReset - 1));
Read(VotingFile,Topic);
Close(VotingFile);
Print('%LF^1Voting topic: ^5'+Topic.Question1);
IF (Topic.Question2 <> '') THEN
Print('^1'+PadLeftStr('',12)+': ^5'+Topic.Question2);
IF PYNQ('%LFAre you sure you want to reset it? ',0,FALSE) THEN
BEGIN
Print('%LF[> Resetting voting topic record ...');
Reset(VotingFile);
Seek(VotingFile,(RecNumToReset - 1));
Read(VotingFile,Topic);
Topic.NumVotedQuestion := 0;
FOR RecNum := 1 TO Topic.ChoiceNumber DO
Topic.Answers[RecNum].NumVotedAnswer := 0;
Seek(VotingFile,(RecNumToReset - 1));
Write(VotingFile,Topic);
Close(VotingFile);
Reset(UserFile);
FOR UNum := 1 TO (FileSize(UserFile) - 1) DO
BEGIN
Seek(UserFile,Unum);
Read(UserFile,User);
User.Vote[RecNumToReset] := 0;
Seek(UserFile,UNum);
Write(UserFile,User);
END;
Close(UserFile);
ThisUser.Vote[RecNumToReset] := 0;
SysOpLog('* Reset topic: ^5'+Topic.Question1);
IF (Topic.Question2 <> '') THEN
SysOpLog(PadLeftStr('',13)+': ^5'+Topic.Question2);
END;
END;
END;
END;
PROCEDURE RecalculateTopics;
VAR
User: UserRecordType;
RecNum,
RecNum1: Byte;
UNum: Integer;
BEGIN
IF (NumVotes = 0) THEN
Messages(4,0,'voting topics')
ELSE IF (PYNQ('%LFRecalculate all voting topics? ',0,FALSE)) THEN
BEGIN
Print('%LF[> Recalculating all voting topics ...');
Reset(VotingFile);
FOR RecNum := 1 TO NumVotes DO
BEGIN
Reset(VotingFile);
Seek(VotingFile,(RecNum - 1));
Read(VotingFile,Topic);
Topic.NumVotedQuestion := 0;
FOR RecNum1 := 1 TO Topic.ChoiceNumber DO
Topic.Answers[RecNum1].NumVotedAnswer := 0;
Seek(VotingFile,(RecNum - 1));
Write(VotingFile,Topic);
END;
Close(VotingFile);
Reset(VotingFile);
Reset(UserFile);
FOR UNum := 1 TO (FileSize(UserFile) - 1) DO
BEGIN
Seek(UserFile,Unum);
Read(UserFile,User);
IF (Deleted IN User.SFlags) THEN
BEGIN
FOR RecNum := 1 TO MaxVotes DO
User.Vote[RecNum] := 0;
END
ELSE
BEGIN
FOR RecNum := 1 TO NumVotes DO
IF (User.Vote[RecNum] <> 0) THEN
BEGIN
Seek(VotingFile,(RecNum - 1));
Read(VotingFile,Topic);
Inc(Topic.NumVotedQuestion);
Inc(Topic.Answers[User.Vote[RecNum]].NumVotedAnswer);
Seek(VotingFile,(RecNum - 1));
Write(VotingFile,Topic);
END;
END;
Seek(UserFile,Unum);
Write(UserFile,User);
END;
Close(UserFile);
Close(VotingFile);
SysOpLog('* Recalculated all voting topics.');
END;
END;
PROCEDURE ListTopics(VAR RecNumToList1: Byte);
VAR
NumDone: Byte;
BEGIN
IF (RecNumToList1 < 1) OR (RecNumToList1 > NumVotes) THEN
RecNumToList1 := 1;
Abort := FALSE;
Next := FALSE;
CLS;
PrintACR('^0##^4:^3Votes^4:^3Topic');
PrintACR('^4==:=====:======================================================================');
Reset(VotingFile);
NumDone := 0;
WHILE (NumDone < (PageLength - 5)) AND (RecNumToList1 >= 1) AND (RecNumToList1 <= NumVotes)
AND (NOT Abort) AND (NOT HangUp) DO
BEGIN
Seek(VotingFile,(RecNumToList1 - 1));
Read(VotingFile,Topic);
WITH Topic DO
PrintACR('^0'+PadRightInt(RecNumToList1,2)+
'^3'+PadRightInt(NumVotedQuestion,6)+
'^5 '+Question1);
WKey;
Inc(RecNumToList1);
Inc(NumDone);
END;
Close(VotingFile);
LastError := IOResult;
IF (NumVotes = 0) THEN
Print('*** No voting topics defined ***');
END;
BEGIN
SaveTempPause := TempPause;
TempPause := FALSE;
RecNumToList := 1;
Cmd := #0;
REPEAT
IF (Cmd <> '?') THEN
ListTopics(RecNumToList);
LOneK('%LFVoting topic editor [^5?^4=^5Help^4]: ',Cmd,'QDIMRS?'^M,TRUE,TRUE);
CASE Cmd OF
^M : IF (RecNumToList < 1) OR (RecNumToList > NumVotes) THEN
RecNumToList := 1;
'D' : DeleteTopic(TempTopic,RecNumToList);
'I' : InsertTopic(TempTopic,Cmd,RecNumToList);
'M' : ModifyTopic(TempTopic,Cmd,RecNumToList);
'R' : ResetTopic(RecNumToList);
'S' : RecalculateTopics;
'?' : BEGIN
Print('%LF^1<^3CR^1>Next screen or redisplay current screen');
Print('^1(^3?^1)Help/First voting topic');
LCmds(20,3,'Delete voting topic','Insert voting topic');
LCmds(20,3,'Modify voting topic','Quit');
LCmds(20,3,'Reset voting topic','SRecalculate voting topics');
END;
END;
IF (Cmd <> ^M) THEN
RecNumToList := 1;
UNTIL (Cmd = 'Q') OR (HangUp);
TempPause := SaveTempPause;
LastError := IOResult;
END;
END.

77
SOURCE/SYSOP11.PAS Normal file
View File

@ -0,0 +1,77 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S+,V-}
UNIT SysOp11;
INTERFACE
PROCEDURE ChangeUser;
PROCEDURE ShowLogs;
IMPLEMENTATION
USES
Common,
TimeFunc,
MiscUser;
PROCEDURE ChangeUser;
VAR
UNum: Integer;
BEGIN
Prt('Change to which User (1-'+IntToStr(MaxUsers - 1)+'): ');
FindUser(UNum);
IF (UNum >= 1) THEN
BEGIN
SaveURec(ThisUser,UserNum);
LoadURec(ThisUser,UNum);
UserNum := UNum;
ChopTime := 0;
ExtraTime := 0;
FreeTime := 0;
IF (ComPortSpeed > 0) THEN
SysOpLog('---> ^7Switched accounts to: ^5'+Caps(ThisUser.Name));
Update_Screen;
NewCompTables;
LoadNode(ThisNode);
WITH NodeR DO
BEGIN
User := UserNum;
UserName := ThisUser.Name;
END;
SaveNode(ThisNode);
END;
END;
PROCEDURE ShowLogs;
VAR
TempStr: Str10;
Day: Word;
BEGIN
NL;
Print('SysOp Logs available for up to '+IntToStr(General.BackSysOpLogs)+' days ago.');
Prt('Date (MM/DD/YYYY) or # days ago (0-'+IntToStr(General.BackSysOpLogs)+') [0]: ');
Input(TempStr,10);
IF (Length(TempStr) = 10) AND (DayNum(TempStr) > 0) THEN
Day := (DayNum(DateStr) - DayNum(TempStr))
ELSE
Day := StrToInt(TempStr);
AllowContinue := TRUE;
IF (Day = 0) THEN
PrintF(General.LogsPath+'SYSOP.LOG')
ELSE
PrintF(General.LogsPath+'SYSOP'+IntToStr(Day)+'.LOG');
AllowContinue := FALSE;
IF (NoFile) THEN
BEGIN
NL;
Print('SysOp log not found.');
END;
IF (UserOn) THEN
SysOpLog('Viewed SysOp Log - '+AOnOff(Day = 0,'Today''s',IntToStr(Day)+' days ago'));
END;
END.

566
SOURCE/SYSOP12.PAS Normal file
View File

@ -0,0 +1,566 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S+,V-}
UNIT SysOp12;
INTERFACE
USES
Common;
FUNCTION FindConference(Key: Char; VAR Conference: ConferenceRecordType): Boolean;
FUNCTION ShowConferences: AStr;
PROCEDURE ChangeConference(MenuOption: Str50);
PROCEDURE ConferenceEditor;
IMPLEMENTATION
FUNCTION FindConference(Key: Char; VAR Conference: ConferenceRecordType): Boolean;
VAR
RecNumToList: Integer;
Found: Boolean;
BEGIN
Found := FALSE;
Reset(ConferenceFile);
RecNumToList := 1;
WHILE (RecNumToList <= NumConfKeys) AND (NOT Found) DO
BEGIN
Seek(ConferenceFile,(RecNumToList - 1));
Read(ConferenceFile,Conference);
IF (Key = Conference.Key) THEN
Found := TRUE;
Inc(RecNumToList);
END;
Close(ConferenceFile);
LastError := IOResult;
FindConference := Found;
END;
FUNCTION ShowConferences: AStr;
VAR
TempStr: AStr;
RecNumToList: Integer;
BEGIN
Abort := FALSE;
Next := FALSE;
TempStr := '';
Reset(ConferenceFile);
RecNumToList := 1;
WHILE (RecNumToList <= NumConfKeys) AND (NOT Abort) AND (NOT HangUp) DO
BEGIN
Seek(ConferenceFile,(RecNumToList - 1));
Read(ConferenceFile,Conference);
IF AACS(Conference.ACS) THEN
BEGIN
TempStr := TempStr + Conference.Key;
IF (RecNumToList < NumConfKeys) THEN
TempStr := TempStr + ',';
END;
Inc(RecNumToList);
END;
Close(ConferenceFile);
LastError := IOResult;
IF (TempStr[Length(TempStr)] = ',') THEN
Dec(TempStr[0]);
ShowConferences := TempStr;
END;
PROCEDURE DisplayConferenceRecords(RecNumToList: Integer; DisplayListNum: Boolean);
VAR
TempStr: AStr;
NumOnline: Byte;
BEGIN
AllowContinue := TRUE;
Abort := FALSE;
Next := FALSE;
CLS;
IF (DisplayListNum) THEN
BEGIN
PrintACR('^0##^4:^3C^4:^3Name ^0##^4:^3C^4:^3Name');
PrintACR('^4==:=:============================== ==:=:==============================');
END
ELSE
BEGIN
PrintACR(' ^3C^4:^3Name ^3C^4:^3Name');
PrintACR(' ^4=:============================== =:==============================');
END;
Reset(ConferenceFile);
TempStr := '';
NumOnline := 0;
RecNumToList := 1;
WHILE (RecNumToList <= NumConfKeys) AND (NOT Abort) AND (NOT HangUp) DO
BEGIN
Seek(ConferenceFile,(RecNumToList - 1));
Read(ConferenceFile,Conference);
IF (DisplayListNum) THEN
TempStr := TempStr + PadLeftStr('^0'+PadRightInt(RecNumToList,2)+
' ^3'+Conference.Key+
' ^5'+Conference.Name,37)
ELSE
TempStr := TempStr + PadLeftStr(' ^3'+Conference.Key+
' ^5'+Conference.Name,34);
Inc(NumOnline);
IF (NumOnline = 2) THEN
BEGIN
PrintaCR(TempStr);
NumOnline := 0;
TempStr := '';
END;
Inc(RecNumToList);
END;
Close(ConferenceFile);
LastError := IOResult;
AllowContinue := FALSE;
IF (NumOnline = 1) AND (NOT Abort) AND (NOT HangUp) THEN
PrintaCR(TempStr);
IF (NumConfKeys = 0) AND (NOT Abort) AND (NOT HangUp) THEN
Print('^7No conference records.');
END;
PROCEDURE ChangeConference(MenuOption: Str50);
VAR
OneKCmds: AStr;
Cmd: Char;
RecNumToList: Integer;
BEGIN
MenuOption := AllCaps(SQOutSp(MenuOption));
IF (MenuOption <> '') THEN
Cmd := MenuOption[1]
ELSE
Cmd := #0;
IF (Cmd <> #0) AND (Cmd <> '?') AND (NOT (Cmd IN ConfKeys)) THEN
BEGIN
Print('%NLCommand error, operation aborted!');
SysOpLog('^7Change conference cmd error, invalid options: "'+Cmd+'".');
Exit;
END;
IF (Cmd = '?') THEN
BEGIN
PrintF('CONFLIST');
IF (NoFile) THEN
DisplayConferenceRecords(RecNumToList,FALSE);
END
ELSE IF (Cmd IN ConfKeys) AND FindConference(Cmd,Conference) THEN
BEGIN
IF ((AACS(Conference.ACS))) THEN
BEGIN
CurrentConf := Cmd;
ThisUser.LastConf := CurrentConf;
END;
END
ELSE
BEGIN
OneKCmds := '';
FOR Cmd := '@' TO 'Z' DO
IF (Cmd IN ConfKeys) THEN
OneKCmds := OneKCmds + Cmd;
Print('%LF^4Current conference: ^5%CT - %CN');
REPEAT
LOneK('%LFJoin which conference? (^5?^4=^5List^4,<^5CR^4>=^5Quit^4): ',Cmd,^M'?'+OneKCmds,TRUE,TRUE);
IF (Cmd = '?') THEN
BEGIN
PrintF('CONFLIST');
IF (NoFile) THEN
DisplayConferenceRecords(RecNumToList,FALSE);
END
ELSE IF (Cmd IN ConfKeys) AND FindConference(Cmd,Conference) THEN
IF (NOT AACS(Conference.ACS)) THEN
Print('%LF^7You do not have the required access level for this conference!^1')
ELSE
BEGIN
CurrentConf := Cmd;
ThisUser.LastConf := CurrentConf;
PrintF('CONF'+Cmd);
IF (NoFile) THEN
Print('%LFJoined conference: ^5%CT - %CN');
Cmd := ^M;
END;
UNTIL (Cmd = ^M) OR (HangUp);
END;
NewCompTables;
END;
PROCEDURE ConferenceEditor;
VAR
TempConference: ConferenceRecordType;
Cmd: Char;
RecNumToList: Integer;
PROCEDURE InitConferenceVars(VAR Conference: ConferenceRecordType);
BEGIN
FillChar(Conference,SizeOf(Conference),0);
WITH Conference DO
BEGIN
Key := ' ';
Name := '<< New Conference Record >>';
ACS := ''
END;
END;
PROCEDURE DeleteConference(TempConference1: ConferenceRecordType; RecNumToDelete: SmallInt);
VAR
User: UserRecordType;
RecNum: Integer;
BEGIN
IF (NumConfKeys = 0) THEN
Messages(4,0,'conference records')
ELSE
BEGIN
RecNumToDelete := -1;
InputIntegerWOC('%LFConference record to delete?',RecNumToDelete,[NumbersOnly],1,NumConfKeys);
IF (RecNumToDelete >= 1) AND (RecNumToDelete <= NumConfKeys) THEN
BEGIN
Reset(ConferenceFile);
Seek(ConferenceFile,(RecNumToDelete - 1));
Read(ConferenceFile,TempConference1);
Close(ConferenceFile);
LastError := IOResult;
IF (TempConference1.Key = '@') THEN
BEGIN
Print('%LF^7You can not delete the general conference key!^1');
PauseScr(FALSE);
END
ELSE
BEGIN
Print('%LFConference record: ^5'+TempConference1.Name);
IF PYNQ('%LFAre you sure you want to delete it? ',0,FALSE) THEN
BEGIN
Print('%LF[> Deleting conference record ...');
FOR RecNum := 1 TO (MaxUsers - 1) DO
BEGIN
LoadURec(User,RecNum);
IF (User.LastConf = TempConference1.Key) THEN
User.LastConf := '@';
SaveURec(User,RecNum);
END;
Exclude(ConfKeys,TempConference1.Key);
Dec(RecNumToDelete);
Reset(ConferenceFile);
IF (RecNumToDelete >= 0) AND (RecNumToDelete <= (FileSize(ConferenceFile) - 2)) THEN
FOR RecNum := RecNumToDelete TO (FileSize(ConferenceFile) - 2) DO
BEGIN
Seek(ConferenceFile,(RecNum + 1));
Read(ConferenceFile,Conference);
Seek(ConferenceFile,RecNum);
Write(ConferenceFile,Conference);
END;
Seek(ConferenceFile,(FileSize(ConferenceFile) - 1));
Truncate(ConferenceFile);
Close(ConferenceFile);
LastError := IOResult;
Dec(NumConfKeys);
SysOpLog('* Deleted conference: ^5'+TempConference1.Name);
END;
END;
END;
END;
END;
PROCEDURE CheckConference(Conference: ConferenceRecordType; StartErrMsg,EndErrMsg: Byte; VAR Ok: Boolean);
VAR
Counter: Byte;
BEGIN
FOR Counter := StartErrMsg TO EndErrMsg DO
CASE Counter OF
1 : IF (Conference.Name = '') OR (Conference.Name = '<< New Conference Record >>') THEN
BEGIN
Print('%LF^7The description is invalid!^1');
OK := FALSE;
END;
END;
END;
PROCEDURE EditConference(TempConference1: ConferenceRecordType; VAR Conference: ConferenceRecordType; VAR Cmd1: Char;
VAR RecNumToEdit: SmallInt; VAR Changed: Boolean; Editing: Boolean);
VAR
CmdStr: AStr;
Ok: Boolean;
BEGIN
WITH Conference DO
REPEAT
IF (Cmd1 <> '?') THEN
BEGIN
Abort := FALSE;
Next := FALSE;
CLS;
IF (Editing) THEN
PrintACR('^5Editing conference record #'+IntToStr(RecNumToEdit)+' of '+IntToStr(NumConfKeys))
ELSE
PrintACR('^5Inserting conference record #'+IntToStr(RecNumToEdit)+' of '+IntToStr(NumConfKeys + 1));
NL;
PrintACR('^1A. Key : ^5'+Key);
PrintACR('^1B. Description: ^5'+Name);
PrintACR('^1C. ACS : ^5'+AOnOff(ACS = '','*None*',ACS));
END;
IF (NOT Editing) THEN
CmdStr := 'ABC'
ELSE
CmdStr := 'ABC[]FJL';
LOneK('%LFModify menu [^5?^4=^5Help^4]: ',Cmd1,'Q?'+CmdStr+^M,TRUE,TRUE);
CASE Cmd1 OF
'A' : BEGIN
Print('%LF^7You can not modify the conference key.');
PauseScr(FALSE);
END;
'B' : REPEAT
TempConference1.Name := Conference.Name;
OK := TRUE;
InputWNWC('%LFNew description: ',Name,(SizeOf(Name) - 1),Changed);
CheckConference(Conference,1,1,Ok);
IF (NOT Ok) THEN
Conference.Name := TempConference1.Name;
UNTIL (OK) OR (HangUp);
'C' : InputWN1('%LFNew ACS: ',ACS,(SizeOf(ACS) - 1),[InterActiveEdit],Changed);
'[' : IF (RecNumToEdit > 1) THEN
Dec(RecNumToEdit)
ELSE
BEGIN
Messages(2,0,'');
Cmd1 := #0;
END;
']' : IF (RecNumToEdit < NumConfKeys) THEN
Inc(RecNumToEdit)
ELSE
BEGIN
Messages(3,0,'');
Cmd1 := #0;
END;
'F' : IF (RecNumToEdit <> 1) THEN
RecNumToEdit := 1
ELSE
BEGIN
Messages(2,0,'');
Cmd1 := #0;
END;
'J' : BEGIN
InputIntegerWOC('%LFJump to entry',RecNumToEdit,[NumbersOnly],1,NumConfKeys);
IF (RecNumToEdit < 1) OR (RecNumToEdit > NumConfKeys) THEN
Cmd1 := #0;
END;
'L' : IF (RecNumToEdit <> NumConfKeys) THEN
RecNumToEdit := NumConfKeys
ELSE
BEGIN
Messages(3,0,'');
Cmd1 := #0;
END;
'?' : BEGIN
Print('%LF^1<^3CR^1>Redisplay current screen');
Print('^3A^1-^3C^1:Modify item');
IF (NOT Editing) THEN
LCmds(20,3,'Quit and save','')
ELSE
BEGIN
LCmds(20,3,'[Back entry',']Forward entry');
LCmds(20,3,'First entry in list','Jump to entry');
LCmds(20,3,'Last entry in list','Quit and save');
END;
END;
END;
UNTIL (Pos(Cmd1,'Q[]FJL') <> 0) OR (HangUp);
END;
PROCEDURE InsertConference(TempConference1: ConferenceRecordType; Cmd1: Char; RecNumToInsertBefore: SmallInt);
VAR
OneKCmds: AStr;
RecNum,
RecNumToEdit: SmallInt;
Ok,
Changed: Boolean;
BEGIN
IF (NumConfKeys = MaxConfKeys) THEN
Messages(5,MaxConfKeys,'conference records')
ELSE
BEGIN
RecNumToInsertBefore := -1;
InputIntegerWOC('%LFConference record to insert before?',RecNumToInsertBefore,[NumbersOnly],1,(NumConfKeys + 1));
IF (RecNumToInsertBefore >= 1) AND (RecNumToInsertBefore <= (NumConfKeys + 1)) THEN
BEGIN
OneKCmds := '';
FOR Cmd1 := '@' TO 'Z' DO
IF (NOT (Cmd1 IN ConfKeys)) THEN
OneKCmds := OneKCmds + Cmd1;
LOneK('%LFChoose conference key [^5@^4-^5Z^4,^5<CR>^4=^5Quit^4]: ',Cmd1,^M+OneKCmds,TRUE,TRUE);
IF (Cmd1 <> ^M) THEN
BEGIN
Reset(ConferenceFile);
InitConferenceVars(TempConference1);
TempConference1.Key := Cmd1;
IF (RecNumToInsertBefore = 1) THEN
RecNumToEdit := 1
ELSE IF (RecNumToInsertBefore = (NumConfKeys + 1)) THEN
RecNumToEdit := (NumConfKeys + 1)
ELSE
RecNumToEdit := RecNumToInsertBefore;
REPEAT
OK := TRUE;
EditConference(TempConference1,TempConference1,Cmd1,RecNumToEdit,Changed,FALSE);
CheckConference(TempConference1,1,1,Ok);
IF (NOT OK) THEN
IF (NOT PYNQ('%LFContinue inserting conference record? ',0,TRUE)) THEN
Abort := TRUE;
UNTIL (OK) OR (Abort) OR (HangUp);
IF (NOT Abort) AND (PYNQ('%LFIs this what you want? ',0,FALSE)) THEN
BEGIN
Print('%LF[> Inserting conference record ...');
Include(ConfKeys,Cmd1);
Seek(ConferenceFile,FileSize(ConferenceFile));
Write(ConferenceFile,Conference);
Dec(RecNumToInsertBefore);
FOR RecNum := ((FileSize(ConferenceFile) - 1) - 1) DOWNTO RecNumToInsertBefore DO
BEGIN
Seek(ConferenceFile,RecNum);
Read(ConferenceFile,Conference);
Seek(ConferenceFile,(RecNum + 1));
Write(ConferenceFile,Conference);
END;
FOR RecNum := RecNumToInsertBefore TO ((RecNumToInsertBefore + 1) - 1) DO
BEGIN
Seek(ConferenceFile,RecNum);
Write(ConferenceFile,TempConference1);
Inc(NumConfKeys);
SysOpLog('* Inserted conference: ^5'+TempConference1.Name);
END;
END;
Close(ConferenceFile);
LastError := IOResult;
END;
END;
END;
END;
PROCEDURE ModifyConference(TempConference1: ConferenceRecordType; Cmd1: Char; RecNumToEdit: SmallInt);
VAR
SaveRecNumToEdit: Integer;
Ok,
Changed: Boolean;
BEGIN
IF (NumConfKeys = 0) THEN
Messages(4,0,'conference records')
ELSE
BEGIN
RecNumToEdit := -1;
InputIntegerWOC('%LFConference record to modify?',RecNumToEdit,[NumbersOnly],1,NumConfKeys);
IF (RecNumToEdit >= 1) AND (RecNumToEdit <= NumConfKeys) THEN
BEGIN
SaveRecNumToEdit := -1;
Cmd1 := #0;
Reset(ConferenceFile);
WHILE (Cmd1 <> 'Q') AND (NOT HangUp) DO
BEGIN
IF (SaveRecNumToEdit <> RecNumToEdit) THEN
BEGIN
Seek(ConferenceFile,(RecNumToEdit - 1));
Read(ConferenceFile,Conference);
SaveRecNumToEdit := RecNumToEdit;
Changed := FALSE;
END;
REPEAT
Ok := TRUE;
EditConference(TempConference1,Conference,Cmd1,RecNumToEdit,Changed,TRUE);
CheckConference(Conference,1,1,Ok);
IF (NOT OK) THEN
BEGIN
PauseScr(FALSE);
IF (RecNumToEdit <> SaveRecNumToEdit) THEN
RecNumToEdit := SaveRecNumToEdit;
END;
UNTIL (OK) OR (HangUp);
IF (Changed) THEN
BEGIN
Seek(ConferenceFile,(SaveRecNumToEdit - 1));
Write(ConferenceFile,Conference);
Changed := FALSE;
SysOpLog('* Modified conference: ^5'+Conference.Name);
END;
END;
Close(ConferenceFile);
LastError := IOResult;
END;
END;
END;
PROCEDURE PositionConference(TempConference1: ConferenceRecordType; RecNumToPosition: SmallInt);
VAR
RecNumToPositionBefore,
RecNum1,
RecNum2: SmallInt;
BEGIN
IF (NumConfKeys = 0) THEN
Messages(4,0,'conference records')
ELSE IF (NumConfKeys = 1) THEN
Messages(6,0,'conference records')
ELSE
BEGIN
RecNumToPosition := -1;
InputIntegerWOC('%LFPosition which conference record?',RecNumToPosition,[NumbersOnly],1,NumConfKeys);
IF (RecNumToPosition >= 1) AND (RecNumToPosition <= NumConfKeys) THEN
BEGIN
RecNumToPositionBefore := -1;
Print('%LFAccording to the current numbering system.');
InputIntegerWOC('%LFPosition before which conference record?',RecNumToPositionBefore,
[NumbersOnly],1,(NumConfKeys + 1));
IF (RecNumToPositionBefore >= 1) AND (RecNumToPositionBefore <= (NumConfKeys + 1)) AND
(RecNumToPositionBefore <> RecNumToPosition) AND (RecNumToPositionBefore <> (RecNumToPosition + 1)) THEN
BEGIN
Print('%LF[> Positioning conference records ...');
Reset(ConferenceFile);
IF (RecNumToPositionBefore > RecNumToPosition) THEN
Dec(RecNumToPositionBefore);
Dec(RecNumToPosition);
Dec(RecNumToPositionBefore);
Seek(ConferenceFile,RecNumToPosition);
Read(ConferenceFile,TempConference1);
RecNum1 := RecNumToPosition;
IF (RecNumToPosition > RecNumToPositionBefore) THEN
RecNum2 := -1
ELSE
RecNum2 := 1;
WHILE (RecNum1 <> RecNumToPositionBefore) DO
BEGIN
IF ((RecNum1 + RecNum2) < FileSize(ConferenceFile)) THEN
BEGIN
Seek(ConferenceFile,(RecNum1 + RecNum2));
Read(ConferenceFile,Conference);
Seek(ConferenceFile,RecNum1);
Write(ConferenceFile,Conference);
END;
Inc(RecNum1,RecNum2);
END;
Seek(ConferenceFile,RecNumToPositionBefore);
Write(ConferenceFile,TempConference1);
Close(ConferenceFile);
LastError := IOResult;
END;
END;
END;
END;
BEGIN
Cmd := #0;
REPEAT
IF (Cmd <> '?') THEN
DisplayConferenceRecords(RecNumToList,TRUE);
LOneK('%LFConference editor [^5?^4=^5Help^4]: ',Cmd,'QDIMP?'^M,TRUE,TRUE);
CASE Cmd OF
'D' : DeleteConference(TempConference,RecNumToList);
'I' : InsertConference(TempConference,Cmd,RecNumToList);
'M' : ModifyConference(TempConference,Cmd,RecNumToList);
'P' : PositionConference(TempConference,RecNumToList);
'?' : BEGIN
Print('%LF^1<^3CR^1>Next Screen or redisplay screen');
Print('^1(^3?^1)Help/First conference');
LCmds(18,3,'Delete conference','Insert conference');
LCmds(18,3,'Modify conference','Position conference');
LCmds(18,3,'Quit','');
END;
END;
IF (Cmd <> ^M) THEN
RecNumToList := 1;
UNTIL (Cmd = 'Q') OR (HangUp);
LastError := IOResult;
END;
END.

95
SOURCE/SYSOP2.PAS Normal file
View File

@ -0,0 +1,95 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D-,E-,F+,I-,L-,N-,O+,R-,S+,V-}
UNIT SysOp2;
INTERFACE
PROCEDURE SystemConfigurationEditor;
IMPLEMENTATION
USES
Common,
SysOp2A,
SysOp2B,
SysOp2C,
SysOp2D,
SysOp2E,
SysOp2F,
SysOp2G,
SysOp2H,
SysOp2I,
SysOp2J,
SysOp2K,
SysOp2L,
SysOp2M,
SysOp2O,
Maint;
{
1. RGSysCfgStr(0,FALSE)
%CL^5System Configuration:^1
^1A. Main BBS Configuration B. Modem/Node Configuration
^1C. System ACS Settings D. System Variables
^1E. System Toggles F. File System Configuration
^1G. Subscription/Validation System H. Network Configuration
^1I. Offline Mail Configuration J. Color Configuration
^1K. Archive Configuration L. Credit System Configuration
^1M. New User Log-In Toggles
^11. Time allowed per %CD 2. Max calls per day
^13. UL/DL # files ratio 4. UL/DL K-bytes ratio
^15. Post/Call ratio 6. Max downloads per day
^17. Max download kbytes per day 8. Update System Averages
Enter selection [^5A^4-^5M^4,^51^4-^58^4,^5Q^4=^5Quit^4]: @
}
PROCEDURE SystemConfigurationEditor;
VAR
Cmd: Char;
BEGIN
REPEAT
SaveGeneral(TRUE);
WITH General DO
BEGIN
Abort := FALSE;
Next := FALSE;
RGSysCfgStr(0,FALSE);
OneK(Cmd,'QABCDEFGHIJKLM12345678'^M,TRUE,TRUE);
CASE Cmd OF
'A' : MainBBSConfiguration;
'B' : ModemConfiguration;
'C' : SystemACSSettings;
'D' : SystemGeneralVariables;
'E' : SystemFlaggedFunctions;
'F' : FileAreaConfiguration;
'G' : ValidationEditor;
'H' : NetworkConfiguration;
'I' : OffLineMailConfiguration;
'J' : ColorConfiguration;
'K' : ArchiveConfiguration;
'L' : CreditConfiguration;
'M' : NewUserTogglesConfiguration;
'1' : GetSecRange(1,TimeAllow);
'2' : GetSecRange(2,CallAllow);
'3' : GetSecRange(3,DLRatio);
'4' : GetSecRange(4,DLKratio);
'5' : GetSecRange(5,PostRatio);
'6' : GetSecRange(6,DLOneDay);
'7' : GetSecRange(7,DLKOneDay);
'8' : UpdateGeneral;
END;
END;
SaveGeneral(FALSE);
UNTIL (Cmd = 'Q') OR (HangUp);
END;
END.

427
SOURCE/SYSOP2A.PAS Normal file
View File

@ -0,0 +1,427 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S+,V-}
UNIT SysOp2A;
INTERFACE
PROCEDURE MainBBSConfiguration;
IMPLEMENTATION
USES
Crt,
Common,
SysOp7,
TimeFunc;
{
RGSysCfgStr(1,FALSE)
$Main_BBS_Configuration
%CL^5Main BBS Configuration:^1
^1A. BBS name/number : ^5%BN ^1(^5%BP^1)
^1B. Telnet Url : ^5%TN
^1C. SysOp's name : ^5%SN{15 ^1D. Renegade Version : ^5%VR
^1E. SysOp chat hours : ^5%CS ^1F. Minimum baud hours : ^5%BL
^1G. Regular DL hours : ^5%DH ^1H. Minimum baud DL hrs: ^5%BM
^1I. BBS Passwords : ^1J. Pre-event warning : ^5%ET seconds
^1K. System Menus : ^1L. Bulletin Prefix : ^5%PB
^1M. MultiNode support: ^5%MN ^1N. Network mode : ^5%NM
^10. Main data files dir. : ^5%PD
^11. Miscellaneous Files dir.: ^5%PM
^12. Message file storage dir: ^5%P1
^13. Nodelist (Version 7) dir: ^5%P2
^14. Log files/trap files dir: ^5%PL
^15. Temporary directory : ^5%PT
^16. Protocols directory : ^5%PP
^17. Archivers directory : ^5%P7
^18. File attach directory : ^5%PF
^19. RAM drive/MultiNode path: ^5%P3
Enter selection [^5A^4-^5N^4,^50^4-^59^4,^5Q^4=^5Quit^4]: @
$
RGSysCfgStr(2,TRUE)
$Main_BBS_Configuration_BBS_Name
%LFNew BBS name: @
$
RGSysCfgStr(3,TRUE)
$Main_BBS_Configuration_BBS_Phone
%LFNew BBS phone number: @
$
RGSysCfgStr(4,TRUE)
$Main_BBS_Configuration_Telnet_URL
%LF^4New Telnet Url:%LF^4: @
$
RGSysCfgStr(5,TRUE)
$Main_BBS_Configuration_SysOp_Name
%LFNew SysOp name: @
$
RGNoteStr(0,FALSE)
$Internal_Use_Only
%LF^7This is for internal use only.
%PA
$
RGNoteStr(1,FALSE)
$Only_Change_Locally
%LF^7This can only be changed locally.
%PA
$
RGSysCfgStr(6,TRUE)
$Main_BBS_Configuration_SysOp_Chat_Hours
%LFDo you want to declare sysop chat hours? @
$
RGSysCfgStr(7,TRUE)
$Main_BBS_Configuration_Minimum_Baud_Hours
%LFDo you want to declare hours people at the minimum baud can logon? @
$
RGSysCfgStr(8,TRUE)
$Main_BBS_Configuration_Download_Hours
%LFDo you want to declare download hours? @
$
RGSysCfgStr(9,TRUE)
$Main_BBS_Configuration_Minimum_Baud_Download_Hours
%LFDo you want to declare hours people at minimum baud can download? @
$
RGSysCfgStr(10,FALSE)
$Main_BBS_Configuration_SysOp_Password_Menu
%CL^5System Passwords:^1
^1A. SysOp password : ^5%P4
^1B. New user password : ^5%P5
^1C. Baud override password: ^5%P6
Enter selection [^5A^4-^5C^4,^5Q^4=^5Quit^4]: @
$
RGSysCfgStr(11,TRUE)
$Main_BBS_Configuration_SysOp_Password
%LFNew SysOp password: @
$
RGSysCfgStr(12,TRUE)
$Main_BBS_Configuration_New_User_Password
%LFNew new-user password: @
$
RGSysCfgStr(13,TRUE)
$Main_BBS_Configuration_Baud_Override_Password
%LFNew minimum baud rate override password: @
$
RGSysCfgStr(14,TRUE)
$Main_BBS_Configuration_Pre_Event_Time
%LFNew pre-event warning time@
$
RGSysCfgStr(15,FALSE)
$Main_BBS_Configuration_System_Menus
%CL^5System Menus:^1
^11. Global : ^5%M1
^12. All Start : ^5%M2
^13. Shutle logon : ^5%M3
^14. New user info: ^5%M4
^15. Message Read : ^5%M5
^16. File List : ^5%M6
Enter selection [^51^4-^56^4,^5Q^4=^5Quit^4]: @
$
RGSysCfgStr(16,TRUE)
$Main_BBS_Configuration_System_Menus_Global
%LFMenu for global commands (0=None)@
$
RGSysCfgStr(17,TRUE)
$Main_BBS_Configuration_System_Menus_Start
%LFMenu to start all users at@
$
RGSysCfgStr(18,TRUE)
$Main_BBS_Configuration_System_Menus_Shuttle
%LFMenu for shuttle logon (0=None)@
$
RGSysCfgStr(19,TRUE)
$Main_BBS_Configuration_System_Menus_New_User
%LFMenu for new user information@
$
RGSysCfgStr(20,TRUE)
$Main_BBS_Configuration_System_Menus_Message_Read
%LFMenu for message read@
$
RGSysCfgStr(21,TRUE)
$Main_BBS_Configuration_System_Menus_File_Listing
%LFMenu for file listing@
$
RGNoteStr(2,FALSE)
$Invalid_Menu_Number
%LF^7Invalid menu number.
%PA
$
RGSysCfgStr(22,TRUE)
$Main_BBS_Configuration_Bulletin_Prefix
%LFDefault bulletin prefix: @
$
RGNoteStr(1,FALSE)
$Only_Change_Locally
%LF^7This can only be changed locally.
%PA
$
RGSysCfgStr(23,TRUE)
$Main_BBS_Configuration_Local_Security
%LFDo you want local security to remain on? @
$
RGSysCfgStr(24,TRUE)
$Main_BBS_Configuration_Data_Path
%LF^4New data files path (^5End with a ^4"^5\^4"):%LF^4: @
$
RGSysCfgStr(25,TRUE)
$Main_BBS_Configuration_Misc_Path
%LF^4New miscellaneous files path (^5End with a ^4"^5\^4"):%LF^4: @
$
RGSysCfgStr(26,TRUE)
$Main_BBS_Configuration_Msg_Path
%LF^4New message files path (^5End with a ^4"^5\^4"):%LF^4: @
$
RGSysCfgStr(27,TRUE)
$Main_BBS_Configuration_NodeList_Path
%LF^4New nodelist files path (^5End with a ^4"^5\^4"):%LF^4: @
$
RGSysCfgStr(28,TRUE)
$Main_BBS_Configuration_Log_Path
%LF^4New sysop log files path (^5End with a ^4"^5\^4"):%LF^4: @
$
RGSysCfgStr(29,TRUE)
$Main_BBS_Configuration_Temp_Path
%LF^4New temporary files path (^5End with a ^4"^5\^4"):%LF^4: @
$
RGSysCfgStr(30,TRUE)
$Main_BBS_Configuration_Protocol_Path
%LF^4New protocol files path (^5End with a ^4"^5\^4"):%LF^4: @
$
RGSysCfgStr(31,TRUE)
$Main_BBS_Configuration_Archive_Path
%LF^4New archive files path (^5End with a ^4"^5\^4"):%LF^4: @
$
RGSysCfgStr(32,TRUE)
$Main_BBS_Configuration_Attach_Path
%LF^4New file attach files path (^5End with a ^4"^5\^4"):%LF^4: @
$
RGSysCfgStr(33,TRUE)
$Main_BBS_Configuration_MultNode_Path
%LF^4New multi-node files path (^5End with a ^4"^5\^4"):%LF^4: @
$
}
PROCEDURE GetTimeRange(CONST RGStrNum: LongInt; VAR LoTime,HiTime: SmallInt);
VAR
TempStr: Str5;
LowTime,
HighTime: Integer;
BEGIN
IF (NOT (PYNQ(RGSysCfgStr(RGStrNum,TRUE),0,FALSE))) THEN
BEGIN
LowTime := 0;
HighTime := 0;
END
ELSE
BEGIN
NL;
Print('All entries in 24 hour time. Hour: (0-23), Minute: (0-59)');
NL;
Prt('Starting time: ');
MPL(5);
InputFormatted('',TempStr,'##:##',TRUE);
IF (StrToInt(Copy(TempStr,1,2)) IN [0..23]) AND (StrToInt(Copy(TempStr,4,2)) IN [0..59]) THEN
LowTime := ((StrToInt(Copy(TempStr,1,2)) * 60) + StrToInt(Copy(TempStr,4,2)))
ELSE
LowTime := 0;
NL;
Prt('Ending time: ');
MPL(5);
InputFormatted('',TempStr,'##:##',TRUE);
IF (StrToInt(Copy(TempStr,1,2)) IN [0..23]) AND (StrToInt(Copy(TempStr,4,2)) IN [0..59]) THEN
HighTime := ((StrToInt(Copy(TempStr,1,2)) * 60) + StrToInt(Copy(TempStr,4,2)))
ELSE
HighTime := 0;
END;
NL;
Print('Hours: '+PHours('Always allowed',LowTime,HighTime));
NL;
IF PYNQ('Are you sure this is what you want? ',0,FALSE) THEN
BEGIN
LoTime := LowTime;
HiTime := HighTime;
END;
END;
PROCEDURE MainBBSConfiguration;
VAR
LineFile: FILE OF LineRec;
Cmd: Char;
Changed: Boolean;
BEGIN
Assign(LineFile,General.DataPath+'NODE'+IntToStr(ThisNode)+'.DAT');
Reset(LineFile);
Seek(LineFile,0);
Read(LineFile,Liner);
REPEAT
WITH General DO
BEGIN
Abort := FALSE;
Next := FALSE;
RGSysCfgStr(1,FALSE);
OneK(Cmd,'QABCDEFGHIJKLMN0123456789'^M,TRUE,TRUE);
CASE Cmd OF
'A' : BEGIN
InputWNWC(RGSysCfgStr(2,TRUE),BBSName,(SizeOf(BBSName) - 1),Changed);
InputFormatted(RGSysCfgStr(3,TRUE),BBSPhone,'###-###-####',FALSE);
END;
'B' : InputWN1(RGSysCfgStr(4,TRUE),Liner.NodeTelnetURL,(SizeOf(Liner.NodeTelnetURL) - 1),[InteractiveEdit],Changed);
'C' : InputWN1(RGSysCfgStr(5,TRUE),SysOpName,(SizeOf(SysOpName) - 1),[InterActiveEdit],Changed);
'D' : RGNoteStr(0,FALSE);
'E' : IF (InCom) THEN
RGNoteStr(1,FALSE)
ELSE
GetTimeRange(6,lLowTime,HiTime);
'F' : GetTimeRange(7,MinBaudLowTime,MinBaudHiTime);
'G' : GetTimeRange(8,DLLowTime,DLHiTime);
'H' : GetTimeRange(9,MinBaudDLLowTime,MinBaudDLHiTime);
'I' : BEGIN
REPEAT
RGSysCfgStr(10,FALSE);
OneK(Cmd,^M'ABC',TRUE,TRUE);
CASE Cmd OF
'A' : InputWN1(RGSysCfgStr(11,TRUE),SysOpPw,(SizeOf(SysOpPW) - 1),[InterActiveEdit,UpperOnly],Changed);
'B' : InputWN1(RGSysCfgStr(12,TRUE),NewUserPW,(SizeOf(SysOpPW) - 1),[InterActiveEdit,UpperOnly],Changed);
'C' : InputWN1(RGSysCfgStr(13,TRUE),MinBaudOverride,(SizeOf(SysOpPW) - 1),
[InterActiveEdit,UpperOnly],Changed);
END;
UNTIL (Cmd = ^M) OR (HangUp);
Cmd := #0;
END;
'J' : InputByteWOC(RGSysCfgStr(14,TRUE),EventWarningTime,[DisplayValue,NumbersOnly],0,255);
'K' : BEGIN
REPEAT
RGSysCfgStr(15,FALSE);
OneK(Cmd,^M'123456Q',TRUE,TRUE);
CASE Cmd OF
'1' : FindMenu(RGSysCfgStr(16,TRUE),GlobalMenu,0,NumMenus,Changed);
'2' : FindMenu(RGSysCfgStr(17,TRUE),AllStartMenu,1,NumMenus,Changed);
'3' : FindMenu(RGSysCfgStr(18,TRUE),ShuttleLogonMenu,0,NumMenus,Changed);
'4' : FindMenu(RGSysCfgStr(19,TRUE),NewUserInformationMenu,1,NumMenus,Changed);
'5' : FindMenu(RGSysCfgStr(20,TRUE),MessageReadMenu,1,NumMenus,Changed);
'6' : FindMenu(RGSysCfgStr(21,TRUE),FileListingMenu,1,NumMenus,Changed);
END;
UNTIL (Cmd IN [^M,'Q']) OR (HangUp);
Cmd := #0;
END;
'L' : InputWN1(RGSysCfgStr(22,TRUE),BulletPrefix,(SizeOf(BulletPrefix) - 1),[InterActiveEdit,UpperOnly],Changed);
'M' : IF (InCom) THEN
RGNoteStr(1,FALSE)
ELSE
BEGIN
MultiNode := (NOT MultiNode);
SaveGeneral(FALSE);
ClrScr;
Writeln('Please restart Renegade.');
Halt;
END;
'N' : BEGIN
NetworkMode := (NOT NetworkMode);
IF (NetworkMode) THEN
LocalSec := TRUE
ELSE
LocalSec := PYNQ(RGSysCfgStr(23,TRUE),0,FALSE);
END;
'0' : InputPath(RGSysCfgStr(24,TRUE),DataPath,TRUE,FALSE,Changed);
'1' : InputPath(RGSysCfgStr(25,TRUE),MiscPath,TRUE,FALSE,Changed);
'2' : InputPath(RGSysCfgStr(26,TRUE),MsgPath,TRUE,FALSE,Changed);
'3' : InputPath(RGSysCfgStr(27,TRUE),NodePath,TRUE,FALSE,Changed);
'4' : InputPath(RGSysCfgStr(28,TRUE),LogsPath,TRUE,FALSE,Changed);
'5' : InputPath(RGSysCfgStr(29,TRUE),TempPath,FALSE,FALSE,Changed);
'6' : InputPath(RGSysCfgStr(30,TRUE),ProtPath,TRUE,FALSE,Changed);
'7' : InputPath(RGSysCfgStr(31,TRUE),ArcsPath,TRUE,FALSE,Changed);
'8' : InputPath(RGSysCfgStr(32,TRUE),FileAttachPath,TRUE,FALSE,Changed);
'9' : InputPath(RGSysCfgStr(33,TRUE),lMultPath,TRUE,FALSE,Changed);
END;
END;
UNTIL (Cmd = 'Q') OR (HangUp);
Seek(LineFile,0);
Write(LineFile,Liner);
Close(LineFile);
LastError := IOResult;
END;
END.

230
SOURCE/SYSOP2B.PAS Normal file
View File

@ -0,0 +1,230 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D+,E-,L+,I-,L+,N-,O+,R-,S+,V-}
UNIT SysOp2B;
INTERFACE
PROCEDURE ModemConfiguration;
IMPLEMENTATION
USES
Common;
PROCEDURE ModemConfiguration;
VAR
LineFile: FILE OF LineRec;
Cmd: Char;
TempB: Byte;
Changed: Boolean;
PROCEDURE ToggleMFlag(MFlagT: ModemFlagType; VAR MFlags: MFlagSet);
BEGIN
IF (MFlagT IN MFlags) THEN
Exclude(MFlags,MFlagT)
ELSE
Include(MFlags,MFlagT);
END;
PROCEDURE ToggleMFlags(C: Char; VAR MFlags: MFlagSet; VAR Changed: Boolean);
VAR
SaveMFlags: MFlagSet;
BEGIN
SaveMFlags := MFlags;
CASE C OF
'7' : ToggleMFlag(LockedPort,MFlags);
'8' : ToggleMFlag(XONXOFF,MFlags);
'9' : ToggleMFlag(CTSRTS,MFlags);
END;
IF (MFlags <> SaveMFlags) THEN
Changed := TRUE;
END;
PROCEDURE NewModemString(CONST DisplayStr: AStr; VAR InputStr: AStr; Len: Byte);
VAR
Changed: Boolean;
BEGIN
Print('%LF^1Current modem '+DisplayStr+' string: "^5'+InputStr+'^1"');
Print('%LFUse: "|" for a carriage return');
Print(' "~" for a half-second delay');
Print(' "^" to toggle DTR off for 1/4 second');
InputWN1('%LF^1Enter new modem '+DisplayStr+' string:%LF^4: ',InputStr,Len,[InterActiveEdit],Changed);
END;
FUNCTION WhichBaud(B: Byte): AStr;
BEGIN
CASE B OF
1 : WhichBaud := 'CONNECT 300';
2 : WhichBaud := 'CONNECT 600';
3 : WhichBaud := 'CONNECT 1200';
4 : WhichBaud := 'CONNECT 2400';
5 : WhichBaud := 'CONNECT 4800';
6 : WhichBaud := 'CONNECT 7200';
7 : WhichBaud := 'CONNECT 9600';
8 : WhichBaud := 'CONNECT 12000';
9 : WhichBaud := 'CONNECT 14400';
10 : WhichBaud := 'CONNECT 16800';
11 : WhichBaud := 'CONNECT 19200';
12 : WhichBaud := 'CONNECT 21600';
13 : WhichBaud := 'CONNECT 24000';
14 : WhichBaud := 'CONNECT 26400';
15 : WhichBaud := 'CONNECT 28800';
16 : WhichBaud := 'CONNECT 31200';
17 : WhichBaud := 'CONNECT 33600';
18 : WhichBaud := 'CONNECT 38400';
19 : WhichBaud := 'CONNECT 57600';
20 : WhichBaud := 'CONNECT 115200';
END;
END;
BEGIN
Assign(LineFile,General.DataPath+'NODE'+IntToStr(ThisNode)+'.DAT');
Reset(LineFile);
Read(LineFile,Liner);
REPEAT
WITH Liner DO
BEGIN
Abort := FALSE;
Next := FALSE;
Print('%CL^5Modem/Node Configuration:');
NL;
PrintACR('^11. Maximum baud rate: ^5'+PadLeftInt(InitBaud,20)+
'^12. Port number : ^5'+IntToStr(ComPort));
PrintACR('^13. Modem init : ^5'+PadLeftStr(Init,20)+
'^14. Modem answer : ^5'+Answer);
PrintACR('^15. Modem HangUp : ^5'+PadLeftStr(HangUp,20)+
'^16. Modem offhook : ^5'+Offhook);
PrintACR('^17. COM port locking : ^5'+PadLeftStr(ShowOnOff(LockedPort IN MFlags),20)+
'^18. XON/XOFF flow : ^5'+ShowOnOff(XONXOFF IN MFlags));
PrintACR('^19. CTS/RTS flow : ^5'+PadLeftStr(ShowOnOff(CTSRTS IN MFlags),20)+
'^1A. ACS for this node: ^5'+LogonACS);
PrintACR('^1B. Drop file path : ^5'+PadLeftStr(DoorPath,20)+
'^1C. Answer on ring : ^5'+IntToStr(AnswerOnRing));
PrintACR('^1D. TeleConf Normal : ^5'+PadLeftStr(TeleConfNormal,20)+
'^1E. MultiRing only : ^5'+ShowOnOff(MultiRing));
PrintACR('^1F. TeleConf Anon : ^5'+PadLeftStr(TeleConfAnon,20));
PrintACR('^1G. TeleConf Global : ^5'+TeleConfGlobal);
PrintACR('^1H. TeleConf Private : ^5'+TeleConfPrivate);
PrintACR('^1I. IRQ string : ^5'+IRQ);
PrintACR('^1J. Address string : ^5'+Address);
PrintACR('^1R. Modem result codes');
Prt('%LFEnter selection [^51^4-^59^4,^5A^4-^5J^4,^5R^4,^5Q^4=^5Quit^4]: ');
OneK(Cmd,'Q123456789ABCDEFGHIJR'^M,TRUE,TRUE);
CASE Cmd OF
'1' : IF (InCom) THEN
BEGIN
Print('%LF^7This can only be changed locally.');
PauseScr(FALSE);
END
ELSE
BEGIN
Print('%LF^5Modem maximum baud rates:^1');
Print('%LF^1(^3A^1). 2400');
Print('^1(^3B^1). 9600');
Print('^1(^3C^1). 19200');
Print('^1(^3D^1). 38400');
Print('^1(^3E^1). 57600');
Print('^1(^3F^1). 115200');
LOneK('%LFModem speed? [^5A^4-^5F^4,^5<CR>^4=^5Quit^4]: ',Cmd,^M'ABCDEF',TRUE,TRUE);
CASE Cmd OF
'A' : InitBaud := 2400;
'B' : InitBaud := 9600;
'C' : InitBaud := 19200;
'D' : InitBaud := 38400;
'E' : InitBaud := 57600;
'F' : InitBaud := 115200;
END;
Cmd := #0;
END;
'2' : IF (InCom) THEN
BEGIN
Print('%LF^7This can only be changed locally.');
PauseScr(FALSE);
END
ELSE
BEGIN
TempB := ComPort;
InputByteWC('%LFCom port',TempB,[DisplayValue,NumbersOnly],0,64,Changed);
IF (Changed) THEN
IF PYNQ('%LFAre you sure this is what you want? ',0,FALSE) THEN
BEGIN
Com_DeInstall;
ComPort := TempB;
Com_Install;
END;
IF (NOT LocalIOOnly) AND (ComPort = 0) THEN
LocalIOOnly := TRUE;
END;
'3' : NewModemString('init',Init,(SizeOf(Init) - 1));
'4' : NewModemString('answer',Answer,(SizeOf(Answer) - 1));
'5' : NewModemString('hangup',HangUp,(SizeOf(HangUp) - 1));
'6' : NewModemString('offhook',Offhook,(SizeOf(Offhook) - 1));
'7' : ToggleMFlags('7',MFlags,Changed);
'8' : ToggleMFlags('8',MFlags,Changed);
'9' : ToggleMFlags('9',MFlags,Changed);
'A' : InputWN1('%LFNew ACS: ',LogonACS,(SizeOf(LogonACS) - 1),[InterActiveEdit],Changed);
'B' : InputPath('%LF^1Enter path to write door interface files to (^5End with a ^1"^5\^1"):%LF^4: ',
DoorPath,TRUE,FALSE,Changed);
'C' : InputByteWOC('%LFAnswer after ring number',AnswerOnRing,[DisplayValue,NumbersOnly],0,255);
'E' : MultiRing := NOT MultiRing;
'D' : InputWN1('%LF^1Enter new teleconference string:%LF^4: ',TeleConfNormal,(SizeOf(TeleConfNormal) - 1),
[ColorsAllowed,InterActiveEdit],Changed);
'F' : InputWN1('%LF^1Enter new teleconference string:%LF^4: ',TeleConfAnon,(SizeOf(TeleConfAnon) - 1),
[ColorsAllowed,InterActiveEdit],Changed);
'G' : InputWN1('%LF^1Enter new teleconference string:%LF^4: ',TeleConfGlobal,(SizeOf(TeleConfGlobal) - 1),
[ColorsAllowed,InterActiveEdit],Changed);
'H' : InputWN1('%LF^1Enter new teleconference string:%LF^4: ',TeleConfPrivate,(SizeOf(TeleConfPrivate) - 1),
[ColorsAllowed,InterActiveEdit],Changed);
'I' : InputWN1('%LFIRQ for %E MCI code: ',IRQ,(SizeOf(IRQ) - 1),[InterActiveEdit],Changed);
'J' : InputWN1('%LFAddress for %C MCI code: ',Address,(SizeOf(Address) - 1),[InterActiveEdit],Changed);
'R' : BEGIN
REPEAT
Abort := FALSE;
Next := FALSE;
Print('%CL^5Modem configuration - Result Codes');
NL;
PrintACR('^1A. NO CARRIER : ^5'+PadLeftStr(NOCARRIER,21)+'^1B. RELIABLE : ^5'+RELIABLE);
PrintACR('^1C. OK : ^5'+PadLeftStr(OK,21)+'^1D. RING : ^5'+RING);
PrintACR('^1E. CALLER ID : ^5'+PadLeftStr(CALLERID,21)+
'^1F. ID/User note : ^5'+ShowOnOff(UseCallerID));
FOR TempB := 1 TO MaxResultCodes DO
IF (NOT Odd(TempB)) THEN
Print('^1'+Chr(TempB + 70)+'. '+PadLeftStr(WhichBaud(TempB),14)+': ^5'+Connect[TempB])
ELSE
Prompt(PadLeftStr('^1'+Chr(TempB + 70)+'. '+PadLeftStr(WhichBaud(TempB),14)+': ^5'+Connect[TempB],40));
LOneK('%LFEnter selection [^5A^4-^5Z^4,^5<CR>^4=^5Quit^4]: ',Cmd,^M'ABCDEFGHIJKLMNOPQRSTUVWXYZ',TRUE,TRUE);
CASE Cmd OF
'A' : InputWN1('%LFEnter NO CARRIER string: ',NOCARRIER,(SizeOf(NOCARRIER) - 1),
[InterActiveEdit,UpperOnly],Changed);
'B' : InputWN1('%LFEnter RELIABLE string: ',RELIABLE,(SizeOf(RELIABLE) - 1),
[InterActiveEdit,UpperOnly],Changed);
'C' : InputWN1('%LFEnter OK string: ',OK,(SizeOf(OK) - 1),[InterActiveEdit,UpperOnly],Changed);
'D' : InputWN1('%LFEnter RING string: ',RING,(SizeOf(RING) - 1),[InterActiveEdit,UpperOnly],Changed);
'E' : InputWN1('%LFEnter Caller ID string: ',CALLERID,(SizeOf(CALLERID) - 1),
[InterActiveEdit,UpperOnly],Changed);
'F' : UseCallerID := NOT UseCallerID;
'G'..'Z' :
BEGIN
TempB := (Ord(Cmd) - 70);
IF (TempB IN [1..MaxResultCodes]) THEN
InputWN1('%LFEnter '+WhichBaud(TempB)+' string: ',Connect[TempB],(SizeOf(Connect[1]) - 1),
[InterActiveEdit,UpperOnly],Changed);
END;
END;
UNTIL (Cmd = ^M);
Cmd := #0;
END;
END;
END;
UNTIL (Cmd = 'Q') OR (HangUp);
Seek(LineFile,0);
Write(LineFile,Liner);
Close(LineFile);
LastError := IOResult;
END;
END.

124
SOURCE/SYSOP2C.PAS Normal file
View File

@ -0,0 +1,124 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D-,E-,F+,I-,L-,N-,O+,R-,S+,V-}
UNIT SysOp2C;
INTERFACE
PROCEDURE SystemACSSettings;
IMPLEMENTATION
USES
Common;
PROCEDURE SystemACSSettings;
VAR
TempACS: ACString;
Cmd: Char;
Changed: Boolean;
BEGIN
REPEAT
WITH General DO
BEGIN
Abort := FALSE;
Next := FALSE;
MCIAllowed := FALSE;
CLS;
Print('^5System ACS Settings:');
NL;
PrintACR('^1A. Full SysOp : ^5'+PadLeftStr(SOp,18)+
'^1B. Full Co-SysOp : ^5'+CSOp);
PrintACR('^1C. Msg Area SysOp : ^5'+PadLeftStr(MSOp,18)+
'^1D. File Area SysOp : ^5'+FSOp);
PrintACR('^1E. Change a vote : ^5'+PadLeftStr(ChangeVote,18)+
'^1F. Add voting choice: ^5'+AddChoice);
PrintACR('^1G. Post public : ^5'+PadLeftStr(NormPubPost,18)+
'^1H. Send e-mail : ^5'+NormPrivPost);
PrintACR('^1I. See anon pub post: ^5'+PadLeftStr(AnonPubRead,18)+
'^1J. See anon E-mail : ^5'+AnonPrivRead);
PrintACR('^1K. Global Anon post : ^5'+PadLeftStr(AnonPubPost,18)+
'^1L. E-mail anon : ^5'+AnonPrivPost);
PrintACR('^1M. See unval. files : ^5'+PadLeftStr(SeeUnVal,18)+
'^1N. DL unval. files : ^5'+DLUnVal);
PrintACR('^1O. No UL/DL ratio : ^5'+PadLeftStr(NoDLRatio,18)+
'^1P. No PostCall ratio: ^5'+NoPostRatio);
PrintACR('^1R. No DL credits chk: ^5'+PadLeftStr(NoFileCredits,18)+
'^1S. ULs auto-credited: ^5'+ULValReq);
PrintACR('^1T. MCI in TeleConf : ^5'+PadLeftStr(TeleConfMCI,18)+
'^1U. Chat at any hour : ^5'+OverRideChat);
PrintACR('^1V. Send Netmail : ^5'+PadLeftStr(NetMailACS,18)+
'^1W. "Invisible" Mode : ^5'+Invisible);
PrintACR('^1X. Mail file attach : ^5'+PadLeftStr(FileAttachACS,18)+
'^1Y. SysOp PW at logon: ^5'+SPW);
PrintACR('^1Z. Last On Add : ^5'+PadLeftStr(LastOnDatACS,18));
MCIAllowed := TRUE;
NL;
Prt('Enter selection [^5A^4-^5P^4,^5R^4-^5Z^4,^5Q^4=^5Quit^4]: ');
OneK(Cmd,'QABCDEFGHIJKLMNOPRSTUVWXYZ'^M,TRUE,TRUE);
IF (Cmd IN ['A'..'P','R'..'Z']) THEN
BEGIN
CASE Cmd OF
'A' : TempACS := SOp;
'B' : TempACS := CSOp;
'C' : TempACS := MSOp;
'D' : TempACS := FSOp;
'E' : TempACS := ChangeVote;
'F' : TempACS := AddChoice;
'G' : TempACS := NormPubPost;
'H' : TempACS := NormPrivPost;
'I' : TempACS := AnonPubRead;
'J' : TempACS := AnonPrivRead;
'K' : TempACS := AnonPubPost;
'L' : TempACS := AnonPrivPost;
'M' : TempACS := SeeUnVal;
'N' : TempACS := DLUnVal;
'O' : TempACS := NoDLRatio;
'P' : TempACS := NoPostRatio;
'R' : TempACS := NoFileCredits;
'S' : TempACS := ULValReq;
'T' : TempACS := TeleConfMCI;
'U' : TempACS := OverRideChat;
'V' : TempACS := NetMailACS;
'W' : TempACS := Invisible;
'X' : TempACS := FileAttachACS;
'Y' : TempACS := SPW;
'Z' : TempACS := LastOnDatACS;
END;
InputWN1('%LFNew ACS: ',TempACS,(SizeOf(ACString) - 1),[InterActiveEdit],Changed);
CASE Cmd OF
'A' : SOp := TempACS;
'B' : CSOp := TempACS;
'C' : MSOp := TempACS;
'D' : FSOp := TempACS;
'E' : ChangeVote := TempACS;
'F' : AddChoice := TempACS;
'G' : NormPubPost := TempACS;
'H' : NormPrivPost := TempACS;
'I' : AnonPubRead := TempACS;
'J' : AnonPrivRead := TempACS;
'K' : AnonPubPost := TempACS;
'L' : AnonPrivPost := TempACS;
'M' : SeeUnVal := TempACS;
'N' : DLUnVal := TempACS;
'O' : NoDLRatio := TempACS;
'P' : NoPostRatio := TempACS;
'R' : NoFileCredits := TempACS;
'S' : ULValReq := TempACS;
'T' : TeleConfMCI := TempACS;
'U' : OverRideChat := TempACS;
'V' : NetMailACS := TempACS;
'W' : Invisible := TempACS;
'X' : FileAttachACS := TempACS;
'Y' : SPW := TempACS;
'Z' : LastOnDatACS := TempACS;
END;
END;
END;
UNTIL (Cmd = 'Q') OR (HangUp);
END;
END.

348
SOURCE/SYSOP2D.PAS Normal file
View File

@ -0,0 +1,348 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D-,E-,F+,I-,L-,N-,O+,R-,S+,V-}
UNIT SysOp2D;
INTERFACE
PROCEDURE SystemGeneralVariables;
IMPLEMENTATION
USES
Common;
PROCEDURE SystemGeneralVariables;
VAR
Cmd: Char;
TempB,
MinByte,
MaxByte: Byte;
TempI,
MinInt,
MaxInt: SmallInt;
TempL,
MinLongInt,
MaxLongInt: LongInt;
FUNCTION DisplaySwapTo(SwapTo: Byte): Str4;
BEGIN
CASE SwapTo OF
0 : DisplaySwapTo := 'Disk';
1 : DisplaySwapTo := 'XMS';
2 : DisplaySwapTo := 'EMS';
4 : DisplaySwapTo := 'EXT';
255 : DisplaySwapTo := 'Any';
END;
END;
PROCEDURE DisplayMacroo(CONST S: AStr; MaxLen: Byte);
VAR
TempStr: AStr;
Counter: Byte;
BEGIN
TempStr := '';
Prompt('^5"^1');
FOR Counter := 1 TO Length(S) DO
IF (S[Counter] >= ' ') THEN
TempStr := TempStr + S[Counter]
ELSE
TempStr := TempStr + '^3^'+Chr(Ord(S[Counter]) + 64)+'^1';
Prompt(PadLeftStr(TempStr,MaxLen)+'^5"');
END;
PROCEDURE MMacroo(MacroNum: Byte);
VAR
S: AStr;
C: Char;
Counter: Byte;
BEGIN
Print('%CL^5Enter new F'+IntToStr(MacroNum + 1)+' macro now.');
Print('^5Enter ^Z to end recording. 100 character limit.%LF');
S := '';
Counter := 1;
REPEAT
C := Char(GetKey);
IF (C = ^H) THEN
BEGIN
C := #0;
IF (Counter >= 2) THEN
BEGIN
BackSpace;
Dec(Counter);
IF (S[Counter] < #32) THEN
BackSpace;
END;
END;
IF (Counter <= 100) AND (C <> #0) THEN
BEGIN
IF (C IN [#32..#255]) THEN
BEGIN
OutKey(C);
S[Counter] := C;
Inc(Counter);
END
ELSE IF (C IN [^A,^B,^C,^D,^E,^F,^G,^H,^I,^J,^K,^L,^M,^N,^P,^Q,^R,^S,^T,^U,^V,^W,^X,^Y,#27,#28,#29,#30,#31]) THEN
BEGIN
IF (C = ^M) THEN
NL
ELSE
Prompt('^3^'+Chr(Ord(C) + 64)+'^1');
S[Counter] := C;
Inc(Counter);
END;
END;
UNTIL ((C = ^Z) OR (HangUp));
S[0] := Chr(Counter - 1);
Print('%LF%LF^3Your F'+IntToStr(MacroNum + 1)+' macro is now:%LF');
DisplayMacroo(S,160);
Com_Flush_Recv;
IF (NOT PYNQ('%LFIs this what you want? ',0,FALSE)) THEN
Print('%LFMacro not saved.')
ELSE
BEGIN
General.Macro[MacroNum] := S;
Print('%LFMacro saved.');
END;
PauseScr(FALSE);
END;
BEGIN
REPEAT
WITH General DO
BEGIN
Abort := FALSE;
Next := FALSE;
Print('%CL^5System Variables:');
NL;
PrintACR('^1A. Max private sent per call: ^5'+PadLeftInt(MaxPrivPost,6)+
'^1 B. Max feedback sent per call: ^5'+PadLeftInt(MaxFBack,6));
PrintACR('^1C. Max public posts per call: ^5'+PadLeftInt(MaxPubPost,6)+
'^1 D. Max chat attempts per call: ^5'+PadLeftInt(MaxChat,6));
PrintACR('^1E. Normal max mail waiting : ^5'+PadLeftInt(MaxWaiting,6)+
'^1 F. CoSysOp max mail waiting : ^5'+PadLeftInt(CSMaxWaiting,6));
PrintACR('^1G. Max mass mail list : ^5'+PadLeftInt(MaxMassMailList,6)+
'^1 H. Logins before bday check : ^5'+PadLeftInt(BirthDateCheck,6));
PrintACR('^1I. Swap shell should use : ^5'+PadLeftStr(DisplaySwapTo(SwapTo),6)+
'^1 J. Number of logon attempts : ^5'+PadLeftInt(MaxLogonTries,6));
PrintACR('^1K. Password change in days : ^5'+PadLeftInt(PasswordChange,6)+
'^1 L. SysOp chat color : ^5'+PadLeftInt(SysOpColor,6));
PrintACR('^1M. User chat color : ^5'+PadLeftInt(UserColor,6)+
'^1 N. Min. space for posts : ^5'+PadLeftInt(MinSpaceForPost,6));
PrintACR('^1O. Min. space for uploads : ^5'+PadLeftInt(MinSpaceForUpload,6)+
'^1 P. Back SysOp Log keep days : ^5'+PadLeftInt(BackSysOpLogs,6));
PrintACR('^1R. Blank WFC menu minutes : ^5'+PadLeftInt(WFCBlankTime,6)+
'^1 S. Alert beep delay : ^5'+PadLeftInt(AlertBeep,6));
PrintACR('^1T. Number of system callers : ^5'+PadLeftInt(CallerNum,6)+
'^1 U. Minimum logon baud rate : ^5'+PadLeftInt(MinimumBaud,6));
PrintACR('^1V. Minimum D/L baud rate : ^5'+PadLeftInt(MinimumDLBaud,6)+
'^1 W. Sec''s between Time Slices : ^5'+PadLeftInt(SliceTimer,6));
PrintACR('^1X. TB max time allowed : ^5'+PadLeftInt(MaxDepositEver,6)+
'^1 Y. TB max per day deposit : ^5'+PadLeftInt(MaxDepositPerDay,6));
PrintACR('^1Z. TB max per day withdrawal: ^5'+PadLeftInt(MaxWithDrawalPerDay,6));
NL;
FOR TempB := 0 TO 9 DO
BEGIN
Prompt('^1'+IntToStr(TempB)+'. F'+IntToStr(TempB + 1)+' Macro :^5');
DisplayMacroo(Macro[TempB],21);
IF Odd(TempB) THEN
NL
ELSE
Prompt(' ');
END;
Prt('%LFEnter selection [^5A^4-^5P^4,^5R^4-^5Z^4,^50^4-^59^4,^5Q^4=^5Quit^4]: ');
OneK(Cmd,'QABCDEFGHIJKLMNOPRSTUVWXYZ1234567890'^M,TRUE,TRUE);
CASE Cmd OF
'0'..'9' :
MMacroo(Ord(Cmd) - Ord('0'));
'I' : BEGIN
Print('%LF^5Swap locations:^1');
Print('%LF^1(^3D^1)isk');
Print('^1(^3E^1)MS');
Print('^1(^3X^1)MS');
Print('^1(^3N^1)on XMS Extended');
Print('^1(^3A^1)ny');
lOneK('%LFSwap to which? [^5D^4,^5E^4,^5X^4,^5N^4,^5A^4,^5<CR>^4=^5Quit^4]: ',Cmd,'DEXNA'^M,TRUE,TRUE);
CASE Pos(Cmd,'DXENA') OF
1..3 : SwapTo := (Pos(Cmd,'DXE') - 1);
4 : SwapTo := 4;
5 : SwapTo := 255;
END;
Cmd := #0;
END;
'A'..'H','J'..'P','R'..'Z' :
BEGIN
CASE Cmd OF
'A' : BEGIN
MinByte := 0;
MaxByte := 255;
TempB := MaxPrivPost;
END;
'B' : BEGIN
MinByte := 0;
MaxByte := 255;
TempB := MaxFBack;
END;
'C' : BEGIN
MinByte := 0;
MaxByte := 255;
TempB := MaxPubPost;
END;
'D' : BEGIN
MinByte := 0;
MaxByte := 255;
TempB := MaxChat;
END;
'E' : BEGIN
MinByte := 0;
MaxByte := 255;
TempB := MaxWaiting;
END;
'F' : BEGIN
MinByte := 0;
MaxByte := 255;
TempB := CSMaxWaiting;
END;
'G' : BEGIN
MinByte := 2;
MaxByte := 255;
TempB := MaxMassMailList;
END;
'H' : BEGIN
MinInt := 0;
MaxInt := 365;
TempI := BirthDateCheck;
END;
'J' : BEGIN
MinByte := 0;
MaxByte := 255;
TempB := MaxLogonTries;
END;
'K' : BEGIN
MinInt := 0;
MaxInt := 32767;
TempI := PasswordChange;
END;
'L' : BEGIN
MinByte := 0;
MaxByte := 9;
TempB := SysOpColor;
END;
'M' : BEGIN
MinByte := 0;
MaxByte := 9;
TempB := UserColor;
END;
'N' : BEGIN
MinInt := 1;
MaxInt := 32767;
TempI := MinSpaceForPost;
END;
'O' : BEGIN
MinInt := 1;
MaxInt := 32767;
TempI := MinSpaceForUpload;
END;
'P' : BEGIN
MinByte := 1;
MaxByte := 255;
TempB := BackSysOpLogs;
END;
'R' : BEGIN
MinByte := 0;
MaxByte := 60;
TempB := WFCBlankTime;
END;
'S' : BEGIN
MinByte := 0;
MaxByte := 60;
TempB := AlertBeep;
END;
'T' : BEGIN
MinLongInt := 0;
MaxLongInt := 2147483647;
TempL := CallerNum;
END;
'U' : BEGIN
MinLongInt := 0;
MaxLongInt := 115200;
TempL := MinimumBaud;
END;
'V' : BEGIN
MinLongInt := 0;
MaxLongInt := 115200;
TempL := MinimumDLBaud;
END;
'W' : BEGIN
MinByte := 1;
MaxByte := 255;
TempB := SliceTimer;
END;
'X' : BEGIN
MinLongInt := 0;
MaxLongInt := 6000;
TempL := MaxDepositEver;
END;
'Y' : BEGIN
MinLongInt := 0;
MaxLongInt := 6000;
TempL := MaxDepositPerDay;
END;
'Z' : BEGIN
MinLongInt := 0;
MaxLongInt := 6000;
TempL := MaxWithdrawalPerDay
END;
END;
CASE Cmd OF
'H','K','N'..'O' :
InputIntegerWOC('%LFNew value',TempI,[NumbersOnly],MinInt,MaxInt);
'T'..'V','X'..'Z' :
InputLongIntWOC('%LFNew value',TempL,[DisplayValue,NumbersOnly],MinLongInt,MaxLongInt);
ELSE
InputByteWOC('%LFNew value',TempB,[NumbersOnly],MinByte,MaxByte);
END;
CASE Cmd OF
'A' : MaxPrivPost := TempB;
'B' : MaxFBack := TempB;
'C' : MaxPubPost := TempB;
'D' : MaxChat := TempB;
'E' : MaxWaiting := TempB;
'F' : CSMaxWaiting := TempB; (* Not Hooked Up *)
'G' : MaxMassMailList := TempB;
'H' : BEGIN
BirthDateCheck := TempI;
(*
IF (BirthDateCheck = 0) THEN
NewUserToggles[9] := 0
ELSE
NewUserToggles[9] := 2;
*)
END;
'J' : MaxLogonTries := TempB;
'K' : PasswordChange := TempI;
'L' : SysOpColor := TempB;
'M' : UserColor := TempB;
'N' : MinSpaceForPost := TempI;
'O' : MinSpaceForUpload := TempI;
'P' : BackSysOpLogs := TempB;
'R' : WFCBlankTime := TempB;
'S' : AlertBeep := TempB;
'T' : CallerNum := TempL;
'U' : MinimumBaud := TempL;
'V' : MinimumDLBaud := TempL;
'W' : SliceTimer := TempB;
'X' : MaxDepositEver := TempL;
'Y' : MaxDepositPerDay := TempL;
'Z' : MaxWithDrawalPerDay := TempL;
END;
END;
END;
END;
UNTIL (Cmd = 'Q') OR (HangUp);
END;
END.

159
SOURCE/SYSOP2E.PAS Normal file
View File

@ -0,0 +1,159 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D-,E-,F+,I-,L-,N-,O+,R-,S+,V-}
{ System Configuration - System Flagged Functions }
(* 1. Add checking for deleted users or forwarded mail to option 1 *)
UNIT SysOp2E;
INTERFACE
PROCEDURE SystemFlaggedFunctions;
IMPLEMENTATION
USES
Crt,
Common;
PROCEDURE SystemFlaggedFunctions;
VAR
Cmd,
Cmd1: Char;
LowNum,
HiNum,
TempInt: SmallInt;
BEGIN
REPEAT
WITH General DO
BEGIN
Abort := FALSE;
Next := FALSE;
Print('%CL^5System Flagged Functions:');
NL;
PrintACR('^1A. Handles allowed on system: ^5'+ShowOnOff(AllowAlias)+
'^1 B. Phone number in logon : ^5'+ShowOnOff(PhonePW));
PrintACR('^1C. Local security protection: ^5'+ShowOnOff(LocalSec)+
'^1 D. Use EMS for overlay file : ^5'+ShowOnOff(UseEMS));
PrintACR('^1E. Global activity trapping : ^5'+ShowOnOff(GlobalTrap)+
'^1 F. Auto chat buffer open : ^5'+ShowOnOff(AutoChatOpen));
PrintACR('^1G. AutoMessage in logon : ^5'+ShowOnOff(AutoMInLogon)+
'^1 H. Bulletins in logon : ^5'+ShowOnOff(BullInLogon));
PrintACR('^1I. User info in logon : ^5'+ShowOnOff(YourInfoInLogon)+
'^1 J. Strip color off SysOp Log : ^5'+ShowOnOff(StripCLog));
PrintACR('^1K. Offhook in local logon : ^5'+ShowOnOff(OffHookLocalLogon)+
'^1 L. Trap Teleconferencing : ^5'+ShowOnOff(TrapTeleConf));
PrintACR('^1M. Compress file/msg numbers: ^5'+ShowOnOff(CompressBases)+
' ^1 N. Use BIOS for video output : ^5'+ShowOnOff(UseBIOS));
PrintACR('^1O. Use IEMSI handshakes : ^5'+ShowOnOff(UseIEMSI)+
'^1 P. Refuse new users : ^5'+ShowOnOff(ClosedSystem));
PrintACR('^1R. Swap shell function : ^5'+ShowOnOff(SwapShell)+
'^1 S. Use shuttle logon : ^5'+ShowOnOff(ShuttleLog));
PrintACR('^1T. Chat call paging : ^5'+ShowOnOff(ChatCall)+
'^1 U. Time limits are per call : ^5'+ShowOnOff(PerCall));
PrintACR('^1V. SysOp Password checking : ^5'+ShowOnOff(SysOpPWord)+
'^1 W. Random quote in logon : ^5'+ShowOnOff(LogonQuote));
PrintACR('^1X. User add quote in logon : ^5'+ShowOnOff(UserAddQuote)+
'^1 Y. Use message area lightbar : ^5'+ShowOnOff(UseMsgAreaLightBar));
PrintACR('^1Z. Use file area lightbar : ^5'+ShowOnOff(UseFileAreaLightBar));
PrintACR('');
PrintACR('^11. New user message sent to : ^5'+AOnOff((NewApp = -1),'Off',PadLeftInt(NewApp,5)));
PrintACR('^12. Mins before TimeOut bell : ^5'+AOnOff((TimeOutBell = -1),'Off',PadLeftInt(TimeOutBell,3)));
PrintACR('^13. Mins before TimeOut : ^5'+AOnOff((TimeOut = -1),'Off',PadLeftInt(TimeOut,3)));
Prt('%LFEnter selection [^5A^4-^5P^4,^5R^4-^5Z^4,^51^4-^53^4,^5Q^4=^5Quit^4]: ');
OneK(Cmd,'QABCDEFGHIJKLMNOPRSTUVWXYZ123'^M,TRUE,TRUE);
CASE Cmd OF
'A' : AllowAlias := NOT AllowAlias;
'B' : BEGIN
PhonePW := NOT PhonePW;
IF (PhonePW) THEN
NewUserToggles[7] := 8
ELSE
NewUserToggles[7] := 0;
END;
'C' : LocalSec := NOT LocalSec;
'D' : BEGIN
UseEMS := NOT UseEMS;
IF (UseEMS) THEN
OvrUseEMS := TRUE
ELSE
OvrUseEMS := FALSE;
END;
'E' : GlobalTrap := NOT GlobalTrap;
'F' : AutoChatOpen := NOT AutoChatOpen;
'G' : AutoMInLogon := NOT AutoMInLogon;
'H' : BullInLogon := NOT BullInLogon;
'I' : YourInfoInLogon := NOT YourInfoInLogon;
'J' : StripCLog := NOT StripCLog;
'K' : OffHookLocalLogon := NOT OffHookLocalLogon;
'L' : TrapTeleConf := NOT TrapTeleConf;
'M' : BEGIN
CompressBases := NOT CompressBases;
IF (CompressBases) THEN
Print('%LFCompressing file/message areas ...')
ELSE
Print('%LFDe-compressing file/message areas ...');
NewCompTables;
END;
'N' : BEGIN
UseBIOS := NOT UseBIOS;
DirectVideo := NOT UseBIOS;
END;
'O' : UseIEMSI := NOT UseIEMSI;
'P' : ClosedSystem := NOT ClosedSystem;
'R' : SwapShell := NOT SwapShell;
'S' : ShuttleLog := NOT ShuttleLog;
'T' : ChatCall := NOT ChatCall;
'U' : PerCall := NOT PerCall;
'V' : SysOpPWord := NOT SysOpPWord;
'W' : LogonQuote := NOT LogonQuote;
'X' : UserAddQuote := NOT UserAddQuote;
'Y' : UseMsgAreaLightBar := NOT UseMsgAreaLightBar;
'Z' : UseFileAreaLightBar := NOT UseFileAreaLightBar;
'1'..'3' :
BEGIN
Prt('%LFSelect option [^5E^4=^5Enable^4,^5D^4=^5Disable^4,^5<CR>^4=^5Quit^4]: ');
OneK(Cmd1,^M'ED',TRUE,TRUE);
IF (Cmd1 IN ['E','D']) THEN
BEGIN
CASE Cmd1 OF
'E' : BEGIN
CASE Cmd OF
'1' : BEGIN
LowNum := 1;
HiNum := (MaxUsers - 1);
TempInt := NewApp;
END;
'2' : BEGIN
LowNum := 1;
HiNum := 20;
TempInt := TimeOutBell;
END;
'3' : BEGIN
LowNum := 1;
HiNum := 20;
TempInt := TimeOut;
END;
END;
InputIntegerWOC('%LFEnter value for this function',TempInt,[NumbersOnly],LowNum,HiNum);
END;
'D' : TempInt := -1;
END;
CASE Cmd OF
'1' : NewApp := TempInt;
'2' : TimeOutBell := TempInt;
'3' : TimeOut := TempInt;
END;
Cmd := #0;
END;
END;
END;
END;
UNTIL (Cmd = 'Q') OR (HangUp);
END;
END.

78
SOURCE/SYSOP2F.PAS Normal file
View File

@ -0,0 +1,78 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D-,E-,F+,I-,L-,N-,O+,R-,S+,V-}
UNIT SysOp2F;
INTERFACE
PROCEDURE FileAreaConfiguration;
IMPLEMENTATION
USES
Common;
PROCEDURE FileAreaConfiguration;
VAR
Cmd: Char;
BEGIN
REPEAT
WITH General DO
BEGIN
Abort := FALSE;
Next := FALSE;
Print('%CL^5File Area Configuration:');
NL;
PrintACR('^1A. Upload/download ratio system : ^5'+ShowOnOff(ULDLRatio));
PrintACR('^1B. File point system : ^5'+ShowOnOff(FileCreditRatio));
PrintACR('^1C. Daily download limits : ^5'+ShowOnOff(DailyLimits));
PrintACR('^1D. Test and convert uploads : ^5'+ShowOnOff(TestUploads));
PrintACR('^1E. File point rewarding system : ^5'+ShowOnOff(RewardSystem));
PrintACR('^1F. Search for/Use FILE_ID.DIZ : ^5'+ShowOnOff(FileDiz));
PrintACR('^1G. Recompress like archives : ^5'+ShowOnOff(Recompress));
PrintACR('^1H. Credit reward compensation ratio: ^5'+IntToStr(RewardRatio)+'%');
PrintACR('^1I. File point compensation ratio : ^5'+IntToStr(FileCreditComp)+' to 1');
PrintACR('^1J. Area file size per 1 file point : ^5'+IntToStr(FileCreditCompBaseSize)+'k');
PrintACR('^1K. Upload time refund percent : ^5'+IntToStr(ULRefund)+'%');
PrintACR('^1L. "To-SysOp" file area : ^5'+AOnOff(ToSysOpDir = 0,'*None*',IntToStr(ToSysOpDir)));
PrintACR('^1M. Auto-validate ALL files ULed? : ^5'+ShowYesNo(ValidateAllFiles));
PrintACR('^1N. Max k-bytes allowed in temp dir : ^5'+IntToStr(MaxInTemp));
PrintACR('^1O. Min k-bytes to save for resume : ^5'+IntToStr(MinResume));
PrintACR('^1P. Max batch download files : ^5'+IntToStr(MaxBatchDLFiles));
PrintACR('^1R. Max batch upload files : ^5'+IntToStr(MaxBatchUlFiles));
PrintACR('^1S. UL duplicate file search : ^5'+ShowOnOff(SearchDup));
PrintACR('^1T. Force batch download at login : ^5'+ShowOnOff(ForceBatchDL));
PrintACR('^1U. Force batch upload at login : ^5'+ShowOnOff(ForceBatchUL));
NL;
Prt('Enter selection [^5A^4-^5P^4,^5R^4-^5U^4,^5Q^4=^5Quit^4]: ');
OneK(Cmd,'QABCDEFGHIJKLMNOPRSTU'^M,TRUE,TRUE);
CASE Cmd OF
'A' : ULDLRatio := NOT ULDLRatio;
'B' : FileCreditRatio := NOT FileCreditRatio;
'C' : DailyLimits := NOT DailyLimits;
'D' : TestUploads := NOT TestUploads;
'E' : RewardSystem := NOT RewardSystem;
'F' : FileDiz := NOT FileDiz;
'G' : Recompress := NOT Recompress;
'H' : InputIntegerWOC('%LFNew percentage of file credits to reward',RewardRatio,[DisplayValue,NumbersOnly],0,100);
'I' : InputByteWOC('%LFNew file point compensation ratio',FileCreditComp,[DisplayValue,Numbersonly],0,100);
'J' : InputByteWOC('%LFNew area file size per 1 file Point',FileCreditCompBaseSize,[DisplayValue,NumbersOnly],0,255);
'K' : InputByteWOC('%LFNew upload time refund percent',ULRefund,[DisplayValue,NumbersOnly],0,100);
'L' : InputIntegerWOC('%LFNew "To-SysOp" file area (0=None)',ToSysOpDir,[DisplayValue,NumbersOnly],0,NumFileAreas);
'M' : ValidateAllFiles := NOT ValidateAllFiles;
'N' : InputLongIntWOC('%LFNew max k-bytes',MaxInTemp,[DisplayValue,NumbersOnly],0,2097151);
'O' : InputLongIntWOC('%LFNew min resume k-bytes',MinResume,[DisplayValue,NumbersOnly],0,2097151);
'P' : InputByteWOC('%LFNew max batch download files',MaxBatchDLFiles,[DisplayValue,NumbersOnly],1,255);
'R' : InputByteWOC('%LFNew max batch upload files',MaxBatchULFiles,[DisplayValue,NumbersOnly],1,255);
'S' : SearchDup := NOT SearchDup;
'T' : ForceBatchDL := NOT ForceBatchDL;
'U' : ForceBatchUL := NOT ForceBatchUL;
END;
END;
UNTIL (Cmd = 'Q') OR (HangUp);
END;
END.

884
SOURCE/SYSOP2G.PAS Normal file
View File

@ -0,0 +1,884 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S+,V-}
UNIT SysOp2G;
INTERFACE
USES
Common;
PROCEDURE AutoVal(VAR User: UserRecordType; UNum: Integer);
PROCEDURE AutoValidate(VAR User: UserRecordType; UNum: Integer; Level: Char);
PROCEDURE AutoValidationCmd(MenuOption: Str50);
PROCEDURE ValidationEditor;
IMPLEMENTATION
USES
ShortMsg,
SysOp7,
TimeFunc;
CONST
Settings: FlagSet = [RLogon,
RChat,
RValidate,
RUserList,
RAMsg,
RPostAN,
RPost,
REmail,
RVoting,
RMsg,
FNoDLRatio,
FNoPostRatio,
FNoCredits,
FNoDeletion];
FUNCTION ARMatch(SoftAR: Boolean; UserAR,NewAR: ARFlagSet): Boolean;
VAR
SaveUserAR: ARFlagSet;
Match: Boolean;
BEGIN
Match := FALSE;
SaveUserAR := UserAR;
IF (SoftAR) THEN
UserAR := (UserAR + NewAR)
ELSE
UserAR := NewAR;
IF (SaveUserAR = UserAR) THEN
Match := TRUE;
ARMatch := Match;
END;
FUNCTION ACMatch(SoftAC: Boolean; UserAC,NewAC: FlagSet): Boolean;
VAR
SaveUserAC: FlagSet;
Match: Boolean;
BEGIN
Match := FALSE;
SaveUserAC := UserAC;
IF (NOT SoftAC) THEN
UserAC := (UserAC - Settings);
UserAC := (UserAC + (NewAC * Settings));
IF (SaveUserAC = UserAC) THEN
Match := TRUE;
ACMatch := Match;
END;
PROCEDURE DisplayValidationRecords(VAR RecNumToList1: Integer);
VAR
TempStr: AStr;
NumDone,
NumOnline: Byte;
BEGIN
IF (RecNumToList1 < 1) OR (RecNumToList1 > NumValKeys) THEN
RecNumToList1 := 1;
Abort := FALSE;
Next := FALSE;
TempStr := '';
NumOnline := 0;
CLS;
PrintACR('^0##^4:^3K^4:^3Description ^0##^4:^3K^4:^3Description');
PrintACR('^4==:=:============================== ==:=:==============================');
Reset(ValidationFile);
NumDone := 0;
WHILE (NumDone < (PageLength - 5)) AND (RecNumToList1 >= 1) AND (RecNumToList1 <= NumValKeys)
AND (NOT Abort) AND (NOT HangUp) DO
BEGIN
Seek(ValidationFile,(RecNumToList1 - 1));
Read(ValidationFile,Validation);
TempStr := TempStr + '^0'+PadLeftStr(PadRightInt(RecNumToList1,2)+
' ^3'+Validation.Key+
' ^5'+Validation.Description,37);
Inc(NumOnline);
IF (NumOnline = 2) THEN
BEGIN
PrintaCR(TempStr);
NumOnline := 0;
Inc(NumDone);
TempStr := '';
END;
Inc(RecNumToList1);
END;
Close(ValidationFile);
LastError := IOResult;
IF (NumOnline = 1) AND (NOT Abort) AND (NOT HangUp) THEN
PrintaCR(TempStr);
IF (NumValKeys = 0) AND (NOT Abort) AND (NOT HangUp) THEN
Print('^7No validation records.');
END;
PROCEDURE AutoValidate(VAR User: UserRecordType; UNum: Integer; Level: Char);
VAR
RecNum,
RecNum1: Integer;
BEGIN
IF (NOT (Level IN ValKeys)) THEN
BEGIN
SysOpLog('^7Validation error, invalid level: "'+Level+'"!');
Exit;
END;
Reset(ValidationFile);
RecNum1 := -1;
RecNum := 1;
WHILE (RecNum <= NumValKeys) AND (RecNum1 = -1) DO
BEGIN
Seek(ValidationFile,(RecNum - 1));
Read(ValidationFile,Validation);
IF (Validation.Key = Level) THEN
RecNum1 := RecNum;
Inc(RecNum);
END;
Close(ValidationFile);
LastError := IOResult;
IF (Validation.Expiration = 0) AND (Validation.ExpireTo <> ' ') OR
(Validation.Expiration <> 0) AND (Validation.ExpireTo = ' ') THEN
BEGIN
SysOpLog('^7Validation error, expiration data invalid: "'+Level+'"!');
Exit;
END
ELSE IF (Validation.ExpireTo <> ' ') AND (NOT (Validation.ExpireTo IN ValKeys)) THEN
BEGIN
SysOpLog('^7Validation error, expire to level "'+Validation.ExpireTo+'" does not exists!');
Exit;
END;
User.Subscription := Level;
User.TLToday := General.TimeAllow[Validation.NewSL] - (General.TimeAllow[User.SL] - User.TLToday);
User.SL := Validation.NewSL;
User.DSL := Validation.NewDSL;
User.UserStartMenu := Validation.NewMenu;
IF (Validation.Expiration > 0) THEN
User.Expiration := (GetPackDateTime + (Validation.Expiration * 86400))
ELSE
User.Expiration := 0;
Inc(User.FilePoints,Validation.NewFP);
Inc(User.lCredit,Validation.NewCredit);
IF (Validation.ExpireTo IN [' ','!'..'~']) THEN
User.ExpireTo := Validation.ExpireTo;
IF (Validation.SoftAR) THEN
User.AR := (User.AR + Validation.NewAR)
ELSE
User.AR := Validation.NewAR;
IF (NOT Validation.SoftAC) THEN
User.Flags := (User.Flags - Settings);
User.Flags := (User.Flags + (Validation.NewAC * Settings));
SaveURec(User,UNum);
IF (UNum = UserNum) THEN
NewCompTables;
END;
PROCEDURE AutoVal(VAR User: UserRecordType; UNum: Integer);
VAR
TempAR: ARFlagSet;
TempAC: FlagSet;
Level: Char;
CmdKeys: AStr;
RecNum,
RecNum1,
RecNumToList: Integer;
BEGIN
CmdKeys := '';
FOR Level := '!' TO '~' DO
IF (Level IN ValKeys) THEN
CmdKeys := CmdKeys + Level;
RecNumToList := 1;
Level := '?';
REPEAT
IF (Level = '?') THEN
DisplayValidationRecords(RecNumToList);
Prt('%LFValidation level? (^5!^4-^5P^4,^5R^4-^5p^4,^5r^4-^5~^4) [^5?^4=^5First^4,^5<CR>^4=^5Next^4,^5Q^4=^5Quit^4]: ');
OneK1(Level,'Q'+CmdKeys+'?'^M,TRUE,TRUE);
IF (Level <> 'Q') THEN
BEGIN
IF (Level = ^M) THEN
BEGIN
Level := '?';
IF (RecNumToList < 1) OR (RecNumToList > NumValKeys) THEN
RecNumToList := 1
END
ELSE IF (Level = '?') THEN
RecNumToList := 1
ELSE
BEGIN
IF (Level IN ValKeys) THEN
BEGIN
Reset(ValidationFile);
RecNum1 := -1;
RecNum:= 1;
WHILE (RecNum <= NumValKeys) AND (RecNum1 = -1) DO
BEGIN
Seek(ValidationFile,(RecNum - 1));
Read(ValidationFile,Validation);
IF (Validation.Key = Level) THEN
RecNum1 := RecNum;
Inc(RecNum);
END;
Close(ValidationFile);
IF (Validation.Expiration = 0) AND (Validation.ExpireTo <> ' ') OR
(Validation.Expiration <> 0) AND (Validation.ExpireTo = ' ') THEN
BEGIN
Print('%LF^7The expiration days/expire to level is invalid!^1');
Level := #0;
END
ELSE IF (Validation.ExpireTo <> ' ') AND (NOT (Validation.ExpireTo IN ValKeys)) THEN
BEGIN
Print('%LF^7The expiration level does not exist for level: "'+Level+'"!^1');
Level := #0;
END
ELSE IF (User.SL = Validation.NewSL) AND (User.DSL = Validation.NewDSL) AND
ARMatch(Validation.SoftAR,User.AR,Validation.NewAR) AND
ACMatch(Validation.SoftAC,User.Flags,Validation.NewAC) THEN
BEGIN
Print('%LF^7This user is already validated at level "'+Level+'"!^1');
Level := #0;
END
ELSE
BEGIN
Print('%LF^1Description: ^5'+Validation.Description);
Print('%LF^1 < Old Settings > < New Settings >');
Print('%LF^1Sub: ^5'+PadLeftStr(User.Subscription,30)+'^1Sub: ^5'+Level);
Print('^1SL : ^5'+PadLeftInt(User.SL,30)+'^1SL : ^5'+IntToStr(Validation.NewSL));
Print('^1DSL: ^5'+PadLeftInt(User.DSL,30)+'^1DSL: ^5'+IntToStr(Validation.NewDSL));
TempAR := User.AR;
IF (Validation.SoftAR) THEN
TempAR := (TempAR + Validation.NewAR)
ELSE
TempAR := Validation.NewAR;
Print('^1AR : ^5'+PadLeftStr(DisplayARFlags(User.AR,'5','1'),30)+'^1AR : ^5'+DisplayArFlags(TempAR,'5','1'));
TempAC := User.Flags;
IF (NOT Validation.SoftAC) THEN
TempAC := (TempAC - Settings);
TempAC := (TempAC + (Validation.NewAC * Settings));
Print('^1AC : ^5'+PadLeftStr(DisplayACFlags(User.Flags,'5','1'),30)+'^1AC : ^5'+DisplayACFlags(TempAC,'5','1'));
Print('^1FP : ^5'+PadLeftInt(User.FilePoints,30)+'^1FP : ^5'+IntToStr(User.FilePoints + Validation.NewFP));
Print('^1Crd: ^5'+PadLeftInt(User.lCredit,30)+'^1Crd: ^5'+IntToStr(User.lCredit + Validation.NewCredit));
Print('^1Mnu: ^5'+PadLeftInt(User.UserStartMenu,30)+'^1Mnu: ^5'+IntToStr(Validation.NewMenu));
Print('^1ExD: ^5'+PadLeftStr(AOnOff((User.Expiration > 0),ToDate8(PD2Date(User.Expiration)),'Never'),30)+
'^1ExD: ^5'+AOnOff((Validation.Expiration > 0),
ToDate8(PD2Date(GetPackDateTime + (Validation.Expiration * 86400))),
'Never'));
Print('^1ExS: ^5'+PadLeftStr(AOnOff(User.ExpireTo = ' ','No Change',User.ExpireTo),30)+
'^1ExS: ^5'+AOnOff(Validation.ExpireTo = ' ','No Change',Validation.ExpireTo));
IF (NOT PYNQ('%LFContinue validating user at this level? ',0,FALSE)) THEN
Level := #0;
END;
END;
END;
END;
UNTIL (Level IN ValKeys) OR (Level = 'Q') OR (HangUp);
IF (Level IN ValKeys) THEN
BEGIN
AutoValidate(User,UNum,Level);
Print('%LFThis user was validated using validation level "'+Level+'".');
SendShortMessage(UNum,Validation.UserMsg);
LoadURec(User,UNum);
SysOpLog('Validated '+Caps(User.Name)+' with validation level "'+Level+'".');
END;
END;
PROCEDURE AutoValidationCmd(MenuOption: Str50);
VAR
Level: Char;
PW,
TempPW: Str20;
RecNum,
RecNum1: Integer;
BEGIN
IF (MenuOption = '') OR (Pos(';',MenuOption) = 0) OR
(Copy(MenuOption,(Pos(';',MenuOption) + 1),1) = '') OR
(Copy(MenuOption,1,(Pos(';',MenuOption) - 1)) = '') THEN
BEGIN
Print('%LF^7Command error, operation aborted!^1');
SysOpLog('^7Auto-validation command error, invalid options!');
Exit;
END;
PW := AllCaps(Copy(MenuOption,1,(Pos(';',MenuOption) - 1)));
MenuOption := Copy(MenuOption,(Pos(';',MenuOption) + 1),1);
Level := MenuOption[1];
IF (NOT (Level IN ValKeys)) THEN
BEGIN
Print('%LF^7Command error, operation aborted!^1');
SysOpLog('^7Auto-validation command error, level not found: '+Level+'!');
Exit;
END;
Reset(ValidationFile);
RecNum1 := -1;
RecNum:= 1;
WHILE (RecNum <= NumValKeys) AND (RecNum1 = -1) DO
BEGIN
Seek(ValidationFile,(RecNum - 1));
Read(ValidationFile,Validation);
IF (Validation.Key = Level) THEN
RecNum1 := RecNum;
Inc(RecNum);
END;
Close(ValidationFile);
LastError := IOResult;
IF (Validation.Expiration = 0) AND (Validation.ExpireTo <> ' ') OR
(Validation.Expiration <> 0) AND (Validation.ExpireTo = ' ') THEN
BEGIN
Print('%LF^7Command error, operation aborted!^1');
SysOpLog('^7Auto-validation command error, expiration data invalid: "'+Level+'"!');
Exit;
END
ELSE IF (Validation.ExpireTo <> ' ') AND (NOT (Validation.ExpireTo IN ValKeys)) THEN
BEGIN
Print('%LF^7Command error, operation aborted!^1');
SysOpLog('^7Auto-validation command error, expire to level "'+Validation.ExpireTo+'" does not exists!');
Exit;
END
ELSE IF (ThisUser.SL = Validation.NewSL) AND (ThisUser.DSL = Validation.NewDSL) AND
ARMatch(Validation.SoftAR,ThisUser.AR,Validation.NewAR) AND
ACMatch(Validation.SoftAC,ThisUser.Flags,Validation.NewAC) THEN
BEGIN
Print('%LF^7You have already been validated at this access level!^1');
SysOpLog('User error, previously validated at level: "'+Level+'".');
Exit;
END
ELSE IF (ThisUser.SL > Validation.NewSL) OR (ThisUser.DSL > Validation.NewDSL) THEN
BEGIN
Print('%LF^7This option would lower your access level!^1');
SysOpLog('User error, access would be lowered to level: "'+Level+'".');
Exit;
END;
Print('%LFPress <ENTER> to abort.');
Prt('%LFPassword: ');
GetPassword(TempPW,20);
IF (TempPW = '') THEN
BEGIN
Print('%LFAborted.');
Exit;
END;
IF (TempPW <> PW) THEN
BEGIN
Print('%LF^7Incorrect password entered!^1');
SysOpLog('User error, invalid password entered: "'+TempPW+'"');
Exit;
END;
AutoValidate(ThisUser,UserNum,Level);
lStatus_Screen(100,'This user has auto-validated '
+AOnOff(ThisUser.Sex = 'M','himself','herself')+' with level: "'+Level+'".',FALSE,TempPW);
PrintF('AUTOVAL');
IF (NoFile) THEN
Print('%LF'+Validation.UserMsg);
SysOpLog('This user has auto-validated '+AOnOff(ThisUser.Sex = 'M','himself','herself')+' with level: "'+Level+'".');
END;
PROCEDURE ValidationEditor;
VAR
TempValidation: ValidationRecordType;
Cmd: Char;
RecNumToList: Integer;
SaveTempPause: Boolean;
PROCEDURE InitValidateVars(VAR Validation: ValidationRecordType);
VAR
User: UserRecordType;
BEGIN
LoadURec(User,0);
FillChar(Validation,SizeOf(Validation),0);
WITH Validation DO
BEGIN
Key := ' ';
ExpireTo := ' ';
Description := '<< New Validation Record >>';
UserMsg := 'You have been validated, enjoy the system!';
NewSL := User.SL;
NewDSL := User.DSL;
NewMenu := 0;
Expiration := 0;
NewFP := 0;
NewCredit := 0;
SoftAR := TRUE;
SoftAC := TRUE;
NewAR := [];
NewAC := [];
END;
END;
PROCEDURE DeleteValidationLevel(TempValidation1: ValidationRecordType; RecNumToDelete: SmallInt);
VAR
User: UserRecordType;
RecNum: Integer;
BEGIN
IF (NumValKeys = 0) THEN
Messages(4,0,'validation records')
ELSE
BEGIN
RecNumToDelete := -1;
InputIntegerWOC('%LFValidation record to delete?',RecNumToDelete,[NumbersOnly],1,NumValKeys);
IF (RecNumToDelete >= 1) AND (RecNumToDelete <= NumValKeys) THEN
BEGIN
Reset(ValidationFile);
Seek(ValidationFile,(RecNumToDelete - 1));
Read(ValidationFile,TempValidation1);
Close(ValidationFile);
LastError := IOResult;
IF (TempValidation1.Key = '!') THEN
BEGIN
Print('%LFYou can not delete the new user validation key.');
PauseScr(FALSE);
END
ELSE
BEGIN
Print('%LFValidation: ^5'+TempValidation1.Description);
IF PYNQ('%LFAre you sure you want to delete it? ',0,FALSE) THEN
BEGIN
Print('%LF[> Deleting validation record ...');
FOR RecNum := 1 TO (MaxUsers - 1) DO
BEGIN
LoadURec(User,RecNum);
IF (User.ExpireTo = TempValidation1.Key) THEN
BEGIN
User.ExpireTo := ' ';
User.Expiration := 0;
END;
SaveURec(User,RecNum);
END;
Exclude(ValKeys,TempValidation1.Key);
Dec(RecNumToDelete);
Reset(ValidationFile);
IF (RecNumToDelete >= 0) AND (RecNumToDelete <= (FileSize(ValidationFile) - 2)) THEN
FOR RecNum := RecNumToDelete TO (FileSize(ValidationFile) - 2) DO
BEGIN
Seek(ValidationFile,(RecNum + 1));
Read(ValidationFile,Validation);
Seek(ValidationFile,RecNum);
Write(ValidationFile,Validation);
END;
Seek(ValidationFile,(FileSize(ValidationFile) - 1));
Truncate(ValidationFile);
Close(ValidationFile);
LastError := IOResult;
Dec(NumValKeys);
SysOpLog('* Deleted validation record: ^5'+TempValidation1.Description);
END;
END;
END;
END;
END;
PROCEDURE CheckValidationLevel(Validation: ValidationRecordType; StartErrMsg,EndErrMsg: Byte; VAR Ok: Boolean);
VAR
Counter: Byte;
BEGIN
FOR Counter := StartErrMsg TO EndErrMsg DO
CASE Counter OF
1 : IF (Validation.Description = '') OR (Validation.Description = '<< New Validation Record >>') THEN
BEGIN
Print('%LF^7The description is invalid!^1');
OK := FALSE;
END;
END;
END;
PROCEDURE EditValidationLevel(TempValidation1: ValidationRecordType; VAR Validation: ValidationRecordType; VAR Cmd1: Char;
VAR RecNumToEdit: SmallInt; VAR Changed: Boolean; Editing: Boolean);
VAR
User: UserRecordType;
CmdStr,
OneKCmds: AStr;
Cmd2: Char;
RecNumToList: Integer;
Ok,
SaveUpgrade: Boolean;
BEGIN
WITH Validation DO
REPEAT
IF (Cmd1 <> '?') THEN
BEGIN
Abort := FALSE;
Next := FALSE;
CLS;
IF (Editing) THEN
PrintACR('^5Editing validation record #'+IntToStr(RecNumToEdit)+' of '+IntToStr(NumValKeys))
ELSE
PrintACR('^5Inserting validation record #'+IntToStr(RecNumToEdit)+' of '+IntToStr(NumValKeys + 1));
NL;
PrintACR('^1A. Key : ^5'+Key);
PrintACR('^1B. Description: ^5'+Description);
PrintACR('^1C. User msg : ^5'+AOnOff(UserMsg = '','*None*',UserMsg));
PrintACR('^1D. New SL : ^5'+IntToStr(NewSL));
PrintACR('^1E. New DSL : ^5'+IntToStr(NewDSL));
PrintACR('^1G. AR : Flags: ^5'+DisplayARFlags(NewAR,'5','1')+
' ^1Upgrade: ^5'+AOnOff(SoftAR,'Soft','Hard'));
PrintACR('^1H. AC : Flags: ^5'+DisplayACFlags(NewAC,'5','1')+
' ^1Upgrade: ^5'+AOnOff(SoftAC,'Soft','Hard'));
PrintACR('^1I. New points : ^5'+IntToStr(NewFP));
PrintACR('^1K. New credit : ^5'+IntToStr(NewCredit));
PrintACR('^1M. Start menu : ^5'+IntToStr(NewMenu));
PrintACR('^1N. Expiration : Days: ^5'+AOnOff((Expiration > 0),IntToStr(Expiration),'No Expiration')+
' ^1Level: ^5'+AOnOff((ExpireTo IN ['!'..'~']),ExpireTo,'No Change'));
END;
IF (NOT Editing) THEN
CmdStr := 'ABCDEGHIKMN'
ELSE
CmdStr := 'ABCDEGHIKMN[]FJL';
LOneK('%LFModify menu [^5?^4=^5Help^4]: ',Cmd1,'Q?'+CmdStr+^M,TRUE,TRUE);
CASE Cmd1 OF
'A' : BEGIN
Print('%LF^7You can not modify the validation key.');
PauseScr(FALSE);
END;
'B' : IF (Validation.Key = '!') THEN
BEGIN
Print('%LF^7You can not modify the new user description.');
PauseScr(FALSE);
END
ELSE
REPEAT
TempValidation1.Description := Description;
Ok := TRUE;
InputWN1('%LFNew description: ',Description,(SizeOf(Description) - 1),[InterActiveEdit],Changed);
CheckValidationLevel(Validation,1,1,Ok);
IF (NOT Ok) THEN
Description := TempValidation1.Description;
UNTIL (Ok) OR (HangUp);
'C' : InputWN1('%LF^1New user message:%LF^4:',UserMsg,(SizeOf(UserMsg) - 1),[InterActiveEdit],Changed);
'D' : BEGIN
LoadURec(User,0);
REPEAT
InputByteWC('%LFEnter new SL',NewSL,[DisplayValue,NumbersOnly],User.SL,255,Changed);
UNTIL (NewSL >= User.SL) OR (HangUp);
END;
'E' : BEGIN
LoadURec(User,0);
REPEAT
InputByteWC('%LFEnter new DSL',NewDSL,[DisplayValue,NumbersOnly],User.DSL,255,Changed);
UNTIL (NewDSL >= User.DSL) OR (HangUp);
END;
'G' : BEGIN
REPEAT
Prt('%LFToggle which AR flag? ('+DisplayARFlags(NewAR,'5','4')+'^4)'+
' [^5*^4=^5All^4,^5?^4=^5Help^4,^5<CR>^4=^5Quit^4]: ');
OneK(Cmd1,^M'ABCDEFGHIJKLMNOPQRSTUVWXYZ*?',TRUE,TRUE);
IF (Cmd1 = '?') THEN
PrintF('ARFLAGS')
ELSE IF (Cmd1 IN ['A'..'Z']) THEN
ToggleARFlag(Cmd1,NewAR,Changed)
ELSE IF (Cmd1 = '*') THEN
FOR Cmd2 := 'A' TO 'Z' DO
ToggleARFlag(Cmd2,NewAr,Changed);
UNTIL (Cmd1 = ^M) OR (HangUp);
SaveUpgrade := SoftAR;
SoftAR := NOT PYNQ('%LFShould the AR upgrade be hard? ',0,FALSE);
IF (SaveUpgrade <> SoftAR) THEN
Changed := TRUE;
Cmd1 := #0;
END;
'H' : BEGIN
REPEAT
Prt('%LFToggle which AC flag? ('+DisplayACFlags(NewAC,'5','4')+'^4)'+
' [^5?^4=^5Help^4,^5<CR>^4=^5Quit^4]: ');
OneK(Cmd1,^M'LCVUA*PEKM1234?',TRUE,TRUE);
IF (Cmd1 = '?') THEN
PrintF('ACFLAGS')
ELSE IF (Cmd1 <> ^M) THEN
ToggleACFlags(Cmd1,NewAC,Changed);
UNTIL (Cmd1 = ^M) OR (HangUp);
SaveUpgrade := SoftAC;
SoftAC := NOT PYNQ('%LFShould the AC upgrade be hard? ',0,FALSE);
IF (SaveUpgrade <> SoftAC) THEN
Changed := TRUE;
Cmd1 := #0;
END;
'I' : InputLongIntWC('%LFEnter additional file points',NewFP,
[DisplayValue,NumbersOnly],0,2147483647,Changed);
'K' : InputLongIntWC('%LFEnter additional credit',NewCredit,[DisplayValue,NumbersOnly],0,2147483647,Changed);
'M' : FindMenu('%LFEnter start menu (^50^4=^5Default^4)',NewMenu,0,NumMenus,Changed);
'N' : IF (Validation.Key = '!') THEN
BEGIN
Print('%LF^7You can not modify the new user expiration days or level.');
PauseScr(FALSE);
END
ELSE
BEGIN
InputWordWC('%LFEnter days until expiration',Expiration,[DisplayValue,NumbersOnly],0,65535,Changed);
OneKCmds := '';
FOR Cmd2 := '!' TO '~' DO
IF (Cmd2 IN ValKeys) THEN
IF (NOT (Cmd2 = Key)) THEN
OneKCmds := OneKCmds + Cmd2;
Prt('%LFEnter expiration level (^5!^4-^5P^4,^5R^4-^5p^4,^5r^4-^5~^4) [^5<Space>^4=^5No Change^4]: ');
OneK1(Cmd1,^M' '+OneKCmds,TRUE,TRUE);
IF (Cmd1 = ' ') OR (Cmd1 IN ValKeys) THEN
BEGIN
IF (Cmd1 <> ExpireTo) THEN
Changed := TRUE;
ExpireTo := Cmd1;
END;
IF (Expiration = 0) THEN
BEGIN
ExpireTo := ' ';
Changed := TRUE;
END;
IF (ExpireTo = ' ') THEN
BEGIN
Expiration := 0;
Changed := TRUE;
END;
Cmd1 := #0;
Cmd2 := #0;
END;
'[' : IF (RecNumToEdit > 1) THEN
Dec(RecNumToEdit)
ELSE
BEGIN
Messages(2,0,'');
Cmd1 := #0;
END;
']' : IF (RecNumToEdit < NumValKeys) THEN
Inc(RecNumToEdit)
ELSE
BEGIN
Messages(3,0,'');
Cmd1 := #0;
END;
'F' : IF (RecNumToEdit <> 1) THEN
RecNumToEdit := 1
ELSE
BEGIN
Messages(2,0,'');
Cmd1 := #0;
END;
'J' : BEGIN
InputIntegerWOC('%LFJump to entry',RecNumToEdit,[NumbersOnly],1,NumValKeys);
IF (RecNumToEdit < 1) OR (RecNumToEdit > NumValKeys) THEN
Cmd1 := #0;
END;
'L' : IF (RecNumToEdit <> NumValKeys) THEN
RecNumToEdit := NumValKeys
ELSE
BEGIN
Messages(3,0,'');
Cmd1 := #0;
END;
'?' : BEGIN
Print('%LF^1<^3CR^1>Redisplay current screen');
Print('^3A^1-^3E^1,^3G^1-^3I^1,^3K^1,^3M^1-^3N^1:Modify item');
IF (NOT Editing) THEN
LCmds(20,3,'Quit and save','')
ELSE
BEGIN
LCmds(20,3,'[Back entry',']Forward entry');
LCmds(20,3,'First entry in list','Jump to entry');
LCmds(20,3,'Last entry in list','Quit and save');
END;
END;
END;
UNTIL (Pos(Cmd1,'Q[]FJL') <> 0) OR (HangUp);
END;
PROCEDURE InsertValidationLevel(TempValidation1: ValidationRecordType; Cmd1: Char; RecNumToInsertBefore: SmallInt);
VAR
OneKCmds: AStr;
RecNum,
RecNumToEdit: SmallInt;
Ok,
Changed: Boolean;
BEGIN
IF (NumValKeys = MaxValKeys) THEN
Messages(5,MaxValKeys,'validation records')
ELSE
BEGIN
RecNumToInsertBefore := -1;
InputIntegerWOC('%LFValidation record to insert before?',RecNumToInsertBefore,[NumbersOnly],1,(NumValKeys + 1));
IF (RecNumToInsertBefore >= 1) AND (RecNumToInsertBefore <= (NumValKeys + 1)) THEN
BEGIN
OneKCmds := '';
FOR Cmd1 := '!' TO '~' DO
IF (NOT (Cmd1 IN ValKeys)) AND (NOT (Cmd1 = 'Q')) AND (NOT (Cmd1 = 'q')) THEN
OneKCmds := OneKCmds + Cmd1;
Prt('%LFChoose validation key (^5!^4-^5P^4,^5R^4-^5p^4,^5r^4-^5~^4) [^5<CR>^4=^5Quit^4]: ');
OneK1(Cmd1,^M+OneKCmds,TRUE,TRUE);
IF (Cmd1 <> ^M) THEN
BEGIN
Reset(ValidationFile);
InitValidateVars(TempValidation1);
TempValidation1.Key := Cmd1;
IF (RecNumToInsertBefore = 1) THEN
RecNumToEdit := 1
ELSE IF (RecNumToInsertBefore = (NumValKeys + 1)) THEN
RecNumToEdit := (NumValKeys + 1)
ELSE
RecNumToEdit := RecNumToInsertBefore;
REPEAT
OK := TRUE;
EditValidationLevel(TempValidation1,TempValidation1,Cmd1,RecNumToEdit,Changed,FALSE);
CheckValidationLevel(TempValidation1,1,1,Ok);
IF (NOT OK) THEN
IF (NOT PYNQ('%LFContinue inserting validation record? ',0,TRUE)) THEN
Abort := TRUE;
UNTIL (OK) OR (Abort) OR (HangUp);
IF (NOT Abort) AND (PYNQ('%LFIs this what you want? ',0,FALSE)) THEN
BEGIN
Include(ValKeys,Cmd1);
Print('%LF[> Inserting validation record ...');
Seek(ValidationFile,FileSize(ValidationFile));
Write(ValidationFile,Validation);
Dec(RecNumToInsertBefore);
FOR RecNum := ((FileSize(ValidationFile) - 1) - 1) DOWNTO RecNumToInsertBefore DO
BEGIN
Seek(ValidationFile,RecNum);
Read(ValidationFile,Validation);
Seek(ValidationFile,(RecNum + 1));
Write(ValidationFile,Validation);
END;
FOR RecNum := RecNumToInsertBefore TO ((RecNumToInsertBefore + 1) - 1) DO
BEGIN
Seek(ValidationFile,RecNum);
Write(ValidationFile,TempValidation1);
Inc(NumValKeys);
SysOpLog('* Inserted validation record: ^5'+TempValidation1.Description);
END;
END;
Close(ValidationFile);
LastError := IOResult;
END;
END;
END;
END;
PROCEDURE ModifyValidationLevel(TempValidation1: ValidationRecordType; Cmd1: Char; RecNumToEdit: SmallInt);
VAR
SaveRecNumToEdit: Integer;
Ok,
Changed: Boolean;
BEGIN
IF (NumValKeys = 0) THEN
Messages(4,0,'validation records')
ELSE
BEGIN
RecNumToEdit := -1;
InputIntegerWOC('%LFValidation record to modify?',RecNumToEdit,[NumbersOnly],1,NumValKeys);
IF (RecNumToEdit >= 1) AND (RecNumToEdit <= NumValKeys) THEN
BEGIN
SaveRecNumToEdit := -1;
Cmd1 := #0;
Reset(ValidationFile);
WHILE (Cmd1 <> 'Q') AND (NOT HangUp) DO
BEGIN
IF (SaveRecNumToEdit <> RecNumToEdit) THEN
BEGIN
Seek(ValidationFile,(RecNumToEdit - 1));
Read(ValidationFile,Validation);
SaveRecNumToEdit := RecNumToEdit;
Changed := FALSE;
END;
REPEAT
Ok := TRUE;
EditValidationLevel(TempValidation1,Validation,Cmd1,RecNumToEdit,Changed,TRUE);
CheckValidationLevel(Validation,1,1,Ok);
IF (NOT OK) THEN
BEGIN
PauseScr(FALSE);
IF (RecNumToEdit <> SaveRecNumToEdit) THEN
RecNumToEdit := SaveRecNumToEdit;
END;
UNTIL (OK) OR (HangUp);
IF (Changed) THEN
BEGIN
Seek(ValidationFile,(SaveRecNumToEdit - 1));
Write(ValidationFile,Validation);
Changed := FALSE;
SysOpLog('* Modified validation record: ^5'+Validation.Description);
END;
END;
Close(ValidationFile);
LastError := IOResult;
END;
END;
END;
PROCEDURE PositionValidationLevel(TempValidation1: ValidationRecordType; RecNumToPosition: SmallInt);
VAR
RecNumToPositionBefore,
RecNum1,
RecNum2: SmallInt;
BEGIN
IF (NumValKeys = 0) THEN
Messages(4,0,'validation records')
ELSE IF (NumValKeys = 1) THEN
Messages(6,0,'validation records')
ELSE
BEGIN
RecNumToPosition := -1;
InputIntegerWOC('%LFPosition which validation record?',RecNumToPosition,[NumbersOnly],1,NumValKeys);
IF (RecNumToPosition >= 1) AND (RecNumToPosition <= NumValKeys) THEN
BEGIN
Print('%LFAccording to the current numbering system.');
RecNumToPositionBefore := -1;
InputIntegerWOC('%LFPosition before which validation record?',RecNumToPositionBefore,[NumbersOnly],1,(NumValKeys + 1));
IF (RecNumToPositionBefore >= 1) AND (RecNumToPositionBefore <= (NumValKeys + 1)) AND
(RecNumToPositionBefore <> RecNumToPosition) AND (RecNumToPositionBefore <> (RecNumToPosition + 1)) THEN
BEGIN
Print('%LF[> Positioning validation records ...');
Reset(ValidationFile);
IF (RecNumToPositionBefore > RecNumToPosition) THEN
Dec(RecNumToPositionBefore);
Dec(RecNumToPosition);
Dec(RecNumToPositionBefore);
Seek(ValidationFile,RecNumToPosition);
Read(ValidationFile,TempValidation1);
RecNum1 := RecNumToPosition;
IF (RecNumToPosition > RecNumToPositionBefore) THEN
RecNum2 := -1
ELSE
RecNum2 := 1;
WHILE (RecNum1 <> RecNumToPositionBefore) DO
BEGIN
IF ((RecNum1 + RecNum2) < FileSize(ValidationFile)) THEN
BEGIN
Seek(ValidationFile,(RecNum1 + RecNum2));
Read(ValidationFile,Validation);
Seek(ValidationFile,RecNum1);
Write(ValidationFile,Validation);
END;
Inc(RecNum1,RecNum2);
END;
Seek(ValidationFile,RecNumToPositionBefore);
Write(ValidationFile,TempValidation1);
Close(ValidationFile);
LastError := IOResult;
END;
END;
END;
END;
BEGIN
SaveTempPause := TempPause;
TempPause := FALSE;
RecNumToList := 1;
Cmd := #0;
REPEAT
IF (Cmd <> '?') THEN
DisplayValidationRecords(RecNumToList);
LOneK('%LFValidation editor [^5?^4=^5Help^4]: ',Cmd,'QDIMP?'^M,TRUE,TRUE);
CASE Cmd OF
^M : IF (RecNumToList < 1) OR (RecNumToList > NumValKeys) THEN
RecNumToList := 1;
'D' : DeleteValidationLevel(TempValidation,RecNumToList);
'I' : InsertValidationLevel(TempValidation,Cmd,RecNumToList);
'M' : ModifyValidationLevel(TempValidation,Cmd,RecNumToList);
'P' : PositionValidationLevel(TempValidation,RecNumToList);
'?' : BEGIN
Print('%LF^1<^3CR^1>Next screen or redisplay screen');
Print('^1(^3?^1)Help/First validation level');
LCmds(24,3,'Delete validation level','Insert validation level');
LCmds(24,3,'Modify validation level','Position validation level');
LCmds(24,3,'Quit','');
END;
END;
IF (Cmd <> ^M) THEN
RecNumToList := 1;
UNTIL (Cmd = 'Q') OR (HangUp);
TempPause := SaveTempPause;
LastError := IOResult;
END;
END.

135
SOURCE/SYSOP2H.PAS Normal file
View File

@ -0,0 +1,135 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S+,V-}
UNIT SysOp2H;
INTERFACE
PROCEDURE NetworkConfiguration;
IMPLEMENTATION
USES
Common,
NodeList;
PROCEDURE NetworkConfiguration;
VAR
Cmd: Char;
Counter: Byte;
Changed: Boolean;
BEGIN
REPEAT
WITH General DO
BEGIN
Abort := FALSE;
Next := FALSE;
Print('%CL^5Network Configuration:');
NL;
PrintACR('^1A. Net addresses');
PrintACR('^1B. Origin line : ^5'+Origin);
NL;
PrintACR('^1C. Strip IFNA kludge lines : ^5'+ShowYesNo(SKludge)+
'^1 1. Color of standard text : ^'+IntToStr(Text_Color)+IntToStr(Text_Color));
PrintACR('^1D. Strip SEEN-BY lines : ^5'+ShowYesNo(SSeenBy)+
'^1 2. Color of quoted text : ^'+IntToStr(Quote_Color)+IntToStr(Quote_Color));
PrintACR('^1E. Strip origin lines : ^5'+ShowYesNo(SOrigin)+
'^1 3. Color of tear line : ^'+IntToStr(Tear_Color)+IntToStr(Tear_Color));
PrintACR('^1F. Add tear/origin line : ^5'+ShowYesNo(AddTear)+
'^1 4. Color of origin line : ^'+IntToStr(Origin_Color)+IntToStr(Origin_Color));
NL;
PrintACR('^1G. Default Echomail path : ^5'+DefEchoPath);
PrintACR('^1H. Netmail path : ^5'+NetMailPath);
PrintACR('^1I. Netmail attributes : ^5'+NetMail_Attr(NetAttribute));
PrintACR('^1J. UUCP gate address : ^5'+PadLeftStr('^5'+IntToStr(AKA[20].Zone)+':'+IntToStr(AKA[20].Net)+
'/'+IntToStr(AKA[20].Node)+'.'+IntToStr(AKA[20].Point),20));
Prt('%LFEnter selection [^5A^4-^5J^4,^51^4-^54^4,^5Q^4=^5Quit^4]: ');
OneK(Cmd,'QABCDEFGHIJ1234'^M,TRUE,TRUE);
CASE Cmd OF
'A' : BEGIN
REPEAT
Abort := FALSE;
Next := FALSE;
Print('%CL^5Network Addresses:^1');
NL;
FOR Counter := 0 TO 19 DO
BEGIN
Prompt('^1'+Chr(Counter + 65)+'. Address #'+PadLeftInt(Counter,2)+' : '+
PadLeftStr('^5'+IntToStr(AKA[Counter].Zone)+
':'+IntToStr(AKA[Counter].Net)+
'/'+IntToStr(AKA[Counter].Node)+
'.'+IntToStr(AKA[Counter].Point),20));
IF (Odd(Counter)) THEN
NL;
END;
LOneK('%LFEnter selection [^5A^4-^5T^4,^5<CR>^4=^5Quit^4]: ',Cmd,^M'ABCDEFGHIJKLMNOPQRST',TRUE,TRUE);
IF (Cmd IN ['A'..'T']) THEN
GetNewAddr('%LFEnter new network address (^5Z^4:^5N^4/^5N^4.^5P^4 format): ',30,
AKA[(Ord(Cmd) - 65)].Zone,
AKA[(Ord(Cmd) - 65)].Net,
AKA[(Ord(Cmd) - 65)].Node,
AKA[(Ord(Cmd) - 65)].Point);
UNTIL (Cmd = ^M) OR (HangUp);
Cmd := #0;
END;
'B' : InputWN1('%LF^1Enter new origin line:%LF^4: ',Origin,50,[],Changed);
'C' : SKludge := NOT SKludge;
'D' : SSeenBy := NOT SSeenBy;
'E' : SOrigin := NOT SOrigin;
'F' : AddTear := NOT AddTear;
'G' : InputPath('%LF^1Enter new default echomail path (^5End with a ^1"^5\^1"):%LF^4:',DefEchoPath,TRUE,FALSE,Changed);
'H' : InputPath('%LF^1Enter new netmail path (^5End with a ^1"^5\^1"):%LF^4:',NetMailPath,TRUE,FALSE,Changed);
'I' : BEGIN
REPEAT
Print('%LF^1Netmail attributes: ^5'+NetMail_Attr(NetAttribute)+'^1');
LOneK('%LFToggle attributes (CHIKLP) [?]Help [Q]uit: ',Cmd,'QPCKHIL?',TRUE,TRUE);
CASE Cmd OF
'C','H','I','K','L','P' :
ToggleNetAttrS(Cmd,NetAttribute);
'?' : BEGIN
NL;
LCmds(22,3,'Crash mail','Hold');
LCmds(22,3,'In-Transit','Kill-Sent');
LCmds(22,3,'Local','Private');
END;
END;
UNTIL (Cmd = 'Q') OR (HangUp);
Cmd := #0;
END;
'J' : GetNewAddr('%LFEnter new UUCP Gate Address (^5Z^4:^5N^4/^5N^4.^5P^4 format): ',30,
AKA[20].Zone,
AKA[20].Net,
AKA[20].Node,
AKA[20].Point);
'1' : BEGIN
Prompt('%LF^5Colors: ');
ShowColors;
InputByteWC('%LFNew standard text color',Text_Color,[DisplayValue,NumbersOnly],0,9,Changed);
END;
'2' : BEGIN
Prompt('%LF^5Colors: ');
ShowColors;
InputByteWC('%LFNew quoted text color',Quote_Color,[DisplayValue,NumbersOnly],0,9,Changed);
END;
'3' : BEGIN
Prompt('%LF^5Colors: ');
ShowColors;
InputByteWC('%LFNew tear line color',Tear_Color,[DisplayValue,NumbersOnly],0,9,Changed);
END;
'4' : BEGIN
Prompt('%LF^5Colors: ');
ShowColors;
InputByteWC('%LFNew origin line color',Origin_Color,[DisplayValue,NumbersOnly],0,9,Changed);
END;
END;
END;
UNTIL (Cmd = 'Q') OR (HangUp);
END;
END.

61
SOURCE/SYSOP2I.PAS Normal file
View File

@ -0,0 +1,61 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D-,E-,F+,I-,L-,N-,O+,R-,S+,V-}
UNIT SysOp2I;
INTERFACE
PROCEDURE OfflineMailConfiguration;
IMPLEMENTATION
USES
Common;
PROCEDURE OfflineMailConfiguration;
VAR
Cmd: CHAR;
Changed: Boolean;
BEGIN
REPEAT
WITH General DO
BEGIN
Abort := FALSE;
Next := FALSE;
Print('%CL^5Offline Mail Configuration:');
NL;
PrintACR('^1A. QWK/REP Packet name : ^5'+PacketName);
PrintACR('^1B. Welcome screen name : ^5'+QWKWelcome);
PrintACR('^1C. News file name : ^5'+QWKNews);
PrintACR('^1D. Goodbye file name : ^5'+QWKGoodbye);
PrintACR('^1E. Local QWK/REP path : ^5'+QWKLocalPath);
PrintACR('^1F. Ignore time for DL : ^5'+ShowOnOff(QWKTimeIgnore));
PrintACR('^1G. Max total messages : ^5'+IntToStr(MaxQWKTotal));
PrintACR('^1H. Max msgs per base : ^5'+IntToStr(MaxQWKBase));
PrintACR('^1I. ACS for Network .REP: ^5'+QWKNetworkACS);
Prt('%LFEnter selection [^5A^4-^5I^4,^5Q^4=^5Quit^4]: ');
OneK(Cmd,'QABCDEFGHI'^M,TRUE,TRUE);
CASE Cmd OF
'A' : InputWN1('%LFQWK Packet name: ',PacketName,(SizeOf(PacketName) - 1),[InterActiveEdit],Changed);
'B' : InputWN1('%LF^1Welcome screen file d:\path\name (^5Do not enter ^1"^5.EXT^1"):%LF^4: ',
QWKWelcome,(SizeOf(QWKWelcome) - 1),
[UpperOnly,InterActiveEdit],Changed);
'C' : InputWN1('%LF^1News file d:\path\name (^5Do not enter ^1"^5.EXT^1"):%LF^4: ',QWKNews,(SizeOf(QWKNews) - 1),
[UpperOnly,InterActiveEdit],Changed);
'D' : InputWN1('%LF^1Goodbye file d:\path\name (^5Do not enter ^1"^5.EXT^1"):%LF^4: ',
QWKGoodbye,(SizeOf(QWKGoodBye) - 1),
[UpperOnly,InterActiveEdit],Changed);
'E' : InputPath('%LF^1Enter local QWK reader path (^5End with a ^1"^5\^1"):%LF^4:',QWKLocalPath,TRUE,FALSE,Changed);
'F' : QWKTimeIgnore := NOT QWKTimeIgnore;
'G' : InputWordWOC('%LFMaximum total messages in a QWK packet',MaxQWKTotal,[DisplayValue,NumbersOnly],0,65535);
'H' : InputWordWOC('%LFMaximum messages per base in a packet',MaxQWKBase,[DisplayValue,NumbersOnly],0,65535);
'I' : InputWN1('%LFNew ACS: ',QWKNetworkACS,(SizeOf(QWKNetworkACS) - 1),[InterActiveEdit],Changed);
END;
END;
UNTIL (Cmd = 'Q') OR (HangUp);
END;
END.

823
SOURCE/SYSOP2J.PAS Normal file
View File

@ -0,0 +1,823 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S+,V-}
UNIT SysOp2J;
INTERFACE
PROCEDURE ColorConfiguration;
IMPLEMENTATION
USES
Common,
File11,
File1,
Mail4,
TimeFunc;
PROCEDURE ColorConfiguration;
CONST
ColorName: ARRAY[0..7] OF STRING[7] = ('Black','Blue','Green','Cyan','Red','Magenta','Yellow','White');
VAR
TempScheme: SchemeRec;
Cmd: Char;
RecNumToList: Integer;
SaveTempPause: Boolean;
FUNCTION DisplayColorStr(Color: Byte): AStr;
VAR
TempStr: AStr;
BEGIN
TempStr := ColorName[Color AND 7]+' on '+ColorName[(Color SHR 4) AND 7];
IF ((Color AND 8) <> 0) THEN
TempStr := 'Bright '+TempStr;
IF ((Color AND 128) <> 0) THEN
TempStr := 'Blinking '+TempStr;
DisplayColorStr := TempStr;
END;
FUNCTION GetColor: Byte;
VAR
NewColor,
SaveOldColor,
TempColor,
Counter: Byte;
BEGIN
SetC(7);
NL;
FOR Counter := 0 TO 7 DO
BEGIN
SetC(7);
Prompt(IntToStr(Counter)+'. ');
SetC(Counter);
Prompt(PadLeftStr(ColorName[Counter],12));
SetC(7);
Prompt(PadRightInt((Counter + 8),2)+'. ');
SetC(Counter + 8);
Print(PadLeftStr(ColorName[Counter]+'!',9));
END;
InputByteWOC('%LFForeground',TempColor,[Numbersonly],0,15); (* Suppress Error *)
IF (TempColor IN [0..15]) THEN
NewColor := TempColor
ELSE
NewColor := 7;
NL;
FOR Counter := 0 TO 7 DO
BEGIN
SetC(7);
Prompt(IntToStr(Counter)+'. ');
SetC(Counter);
Print(PadLeftStr(ColorName[Counter],12));
END;
InputByteWOC('%LFBackground',TempColor,[NumbersOnly],0,7); (* Suppress Error *)
IF (TempColor IN [0..7]) THEN
NewColor := NewColor OR TempColor SHL 4;
IF PYNQ('%LFBlinking? ',0,FALSE) THEN
NewColor := NewColor OR 128;
SetC(7);
Prompt('%LFExample: ');
SetC(NewColor);
Print(DisplayColorStr(NewColor));
SetC(7);
GetColor := NewColor;
END;
PROCEDURE SystemColors(VAR TempScheme1: SchemeRec; Cmd1: Char; VAR Changed: Boolean);
VAR
Counter,
NewColor: Byte;
BEGIN
REPEAT
CLS;
NL;
FOR Counter := 1 TO 10 DO
BEGIN
SetC(7);
Prompt(PadRightInt((Counter - 1),2)+'. System color '+PadRightInt((Counter - 1),2)+': ');
SetC(TempScheme1.Color[Counter]);
Print(DisplayColorStr(Scheme.Color[Counter]));
END;
LOneK('%LFSystem color to change [^50^4-^59^4,^5<CR>^4=^5Quit^4]: ',Cmd1,^M'0123456789',TRUE,TRUE);
IF (Cmd1 IN ['0'..'9']) THEN
BEGIN
NewColor := GetColor;
IF PYNQ('%LFIs this correct? ',0,FALSE) THEN
BEGIN
TempScheme1.Color[Ord(Cmd1) - Ord('0') + 1] := NewColor;
Changed := TRUE;
END;
END;
UNTIL (Cmd1 = ^M) OR (HangUp);
END;
PROCEDURE FileColors(VAR TempScheme1: SchemeRec; Cmd1: Char; VAR Changed: Boolean);
VAR
F: FileInfoRecordType;
NewColor: Byte;
BEGIN
REPEAT
Abort := FALSE;
Next := FALSE;
FileAreaNameDisplayed := FALSE;
DisplayFileAreaHeader;
WITH F DO
BEGIN
FileName := 'RENEGADE.ZIP';
Description := 'Latest version of Renegade!';
FilePoints := 0;
Downloaded := 0;
FileSize := 2743;
OwnerNum := 1;
OwnerName:= 'Exodus';
FileDate := Date2Pd(DateStr);
VPointer := -1;
VTextSize := 0;
FIFlags := [];
END;
lDisplay_File(F,1,'',FALSE);
PrintACR(PadLeftStr('',28)+'This is the latest version available');
PrintACR(PadLeftStr('',28)+'Uploaded by: Exodus');
WITH F DO
BEGIN
FileName := 'RG .ZIP';
Description := 'Latest Renegade upgrade.';
FilePoints := 0;
Downloaded := 0;
FileSize := 2158;
OwnerNum := 2;
OwnerName := 'Nuclear';
FileDate := Date2PD(DateStr);
VPointer := -1;
VTextSize := 0;
FIFlags := [];
END;
lDisplay_File(F,2,'RENEGADE',FALSE);
PrintACR(PadLeftStr('',28)+'This is the latest upgrade available');
PrintACR(PadLeftStr('',28)+'Uploaded by: Nuclear');
NL;
LCmds3(20,3,'A Border','B File Name field','C Pts Field');
LCmds3(20,3,'D Size field','E Desc Field','F Area field');
NL;
LCmds3(20,3,'G File name','H File Points','I File size');
LCmds3(20,3,'J File desc','K Extended','L Status flags');
LCmds(20,3,'M Uploader','N Search Match');
LOneK('%LFFile color to change [^5A^4-^5N^4,^5<CR>^4=^5Quit^4]: ',Cmd1,^M'ABCDEFGHIJKLMN',TRUE,TRUE);
IF (Cmd1 IN ['A'..'N']) THEN
BEGIN
NewColor := GetColor;
IF PYNQ('%LFIs this correct? ',0,FALSE) THEN
BEGIN
TempScheme1.Color[Ord(Cmd1) - 54] := NewColor;
Changed := TRUE;
END;
END;
UNTIL (Cmd1 = ^M) OR (HangUp);
END;
PROCEDURE MsgColors(VAR TempScheme1: SchemeRec; Cmd1: Char; VAR Changed: Boolean);
VAR
NewColor: Byte;
BEGIN
REPEAT
Abort := FALSE;
Next := FALSE;
CLS; { starts at color 28 }
PrintACR('ÚÄÄÄÄÄÄÂÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÂÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÂÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÂÄÄÄÄÄÄÄÄ¿');
PrintACR('³ Msg# ³ Sender ³ Receiver ³ '+
'Subject ³! Posted ³');
PrintACR('ÀÄÄÄÄÄÄÁÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÁÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÁÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÁÄÄÄÄÄÄÄÄÙ');
PrintACR('''* "2# Exodus $Nuclear %Re: Renegade &01/01/93');
PrintACR('''> "3# Nuclear $Exodus %RG Update &01/01/93');
NL;
LCmds3(20,3,'A Border','B Msg Num field','C Sender Field');
LCmds3(20,3,'D Receiver field','E Subject Field','F Date field');
NL;
LCmds3(20,3,'G Msg Num','H Msg Sender','I Msg Receiver');
LCmds3(20,3,'J Subject','K Msg Date','L Status flags');
LOneK('%LFMessage color to change [^5A^4-^5L^4,^5<CR>^4=^5Quit^4]: ',Cmd1,^M'ABCDEFGHIJKL',TRUE,TRUE);
IF (Cmd1 IN ['A'..'L']) THEN
BEGIN
NewColor := GetColor;
IF PYNQ('%LFIs this correct? ',0,FALSE) THEN
BEGIN
TempScheme1.Color[Ord(Cmd1) - 37] := NewColor;
Changed := TRUE;
END;
END;
UNTIL (Cmd1 = ^M) OR (HangUp);
END;
PROCEDURE FileAreaColors(VAR TempScheme1: SchemeRec; Cmd1: Char; VAR Changed: Boolean);
VAR
NewColor: Byte;
FArea,
NumFAreas: Integer;
SaveConfSystem: Boolean;
BEGIN
SaveConfSystem := ConfSystem;
ConfSystem := FALSE;
IF (SaveConfSystem) THEN
NewCompTables;
REPEAT
Abort := FALSE;
Next := FALSE;
Farea := 1;
NumFAreas := 0;
LFileAreaList(FArea,NumFAreas,10,TRUE); { starts at 45 }
NL;
LCmds3(20,3,'A Border','B Base Num field','C Base Name Field');
NL;
LCmds3(20,3,'D Scan Indicator','E Base Number','F Base Name');
LOneK('%LFFile area color to change [^5A^4-^5F^4,^5<CR>^4=^5Quit^4]: ',Cmd1,^M'ABCDEF',TRUE,TRUE);
IF (Cmd1 IN ['A'..'F']) THEN
BEGIN
NewColor := GetColor;
IF PYNQ('%LFIs this correct? ',0,FALSE) THEN
BEGIN
TempScheme1.Color[Ord(Cmd1) - 20] := NewColor;
Changed := TRUE;
END;
END;
UNTIL (Cmd1 = ^M) OR (HangUp);
ConfSystem := SaveConfSystem;
IF (SaveConfSystem) THEN
NewCompTables;
END;
PROCEDURE MsgAreaColors(VAR TempScheme1: SchemeRec; Cmd1: Char; VAR Changed: Boolean);
VAR
NewColor: Byte;
MArea,
NumMAreas: Integer;
BEGIN
REPEAT
Abort := FALSE;
Next := FALSE;
MArea := 1;
NumMAreas := 0;
MessageAreaList(MArea,NumMAreas,5,TRUE); { starts at 55 }
NL;
LCmds3(20,3,'A Border','B Base Num field','C Base Name Field');
NL;
LCmds3(20,3,'D Scan Indicator','E Base Number','F Base Name');
LOneK('%LFMessage area color to change [^5A^4-^5F^4,^5<CR>^4=^5Quit^4]: ',Cmd1,^M'ABCDEF',TRUE,TRUE);
IF (Cmd1 IN ['A'..'F']) THEN
BEGIN
NewColor := GetColor;
IF PYNQ('%LFIs this correct? ',0,FALSE) THEN
BEGIN
TempScheme1.Color[Ord(Cmd1) - 10] := NewColor;
END;
END;
UNTIL (Cmd1 = ^M) OR (HangUp);
END;
PROCEDURE QWKColors(VAR TempScheme1: SchemeRec; Cmd1: Char; VAR Changed: Boolean);
VAR
NewColor: Byte;
BEGIN
REPEAT
Abort := FALSE;
Next := FALSE;
CLS; { starts at 115 }
Print(Centre('|The QWKÿSystem is now gathering mail.'));
NL;
PrintACR('sÚÄÄÄÄÄÂÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÂÄÄÄÄÄÄÄÄÄÂÄÄÄÄÄÄÂÄÄÄÄÄÄÄÄÄÂÄÄÄÄÄÂÄÄÄÄÄÄÂÄÄÄÄÄÄ¿');
PrintACR('s³t Num s³u Message base name s³v Short s³w Echo s³x Total '+
's³y New s³z Your s³{ Size s³');
PrintACR('sÀÄÄÄÄÄÁÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÁÄÄÄÄÄÄÄÄÄÁÄÄÄÄÄÄÁÄÄÄÄÄÄÄÄÄÁÄÄÄÄÄÁÄÄÄÄÄÄÁÄÄÄÄÄÄÙ');
PrintACR(' }1 ~General GENERAL €No <13>530 ‚328 ƒ13 „103k');
PrintACR(' }2 ~Not so general NSGEN €No <13>854 ‚ 86 ƒ15 „43k');
PrintACR(' }3 ~Vague VAGUE €No <13>985 ‚148 ƒ8 „74k');
NL;
LCmds3(20,3,'A Border','B Base num field','C Base name field');
LCmds3(20,3,'D Short field','E Echo field','F Total field');
LCmds3(20,3,'G New field','H Your field','I Size field');
NL;
LCmds3(20,3,'J Title','K Base Number','L Base name');
LCmds3(20,3,'M Short','N Echo flag','O Total Msgs');
LCmds3(20,3,'P New Msgs','R Your Msgs','S Msgs size');
LOneK('%LFQWK color to change [^5A^4-^5S^4,^5<CR>^4=^5Quit^4]: ',Cmd1,^M'ABCDEFGHIJKLMNOPRS'^M,TRUE,TRUE);
IF (Cmd1 IN ['A'..'P','R'..'S']) THEN
BEGIN
NewColor := GetColor;
IF PYNQ('%LFIs this correct? ',0,FALSE) THEN
IF (Cmd1 < 'Q') THEN
BEGIN
TempScheme1.Color[Ord(Cmd1) + 50] := NewColor;
Changed := TRUE;
END
ELSE
BEGIN
TempScheme1.Color[Ord(Cmd1) + 49] := NewColor;
Changed := TRUE;
END;
END;
UNTIL (Cmd1 = ^M) OR (HangUp);
END;
PROCEDURE EmailColors(VAR TempScheme1: SchemeRec; Cmd1: Char; VAR Changed: Boolean);
VAR
NewColor: Byte;
BEGIN
REPEAT
Abort := FALSE;
Next := FALSE;
CLS; { starts at 135 }
PrintACR('‡ÚÄÄÄÄÄÂÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÂÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÂÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ¿');
PrintACR('‡³ˆ Num ‡³‰ Date/Time ‡³Š Sender ‡³‹ Subject ‡³');
PrintACR('‡ÀÄÄÄÄÄÁÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÁÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÁÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÙ');
PrintACR(' Œ1 <13>01 Jan 1993 01:00a ŽExodus <13>Renegade');
PrintACR(' Œ1 <13>01 Jan 1993 01:00a ŽNuclear <13>Upgrades');
NL;
LCmds3(20,3,'A Border','B Number field','C Date/Time field');
LCmds(20,3,'D Sender field','E Subject field');
NL;
LCmds3(20,3,'F Number','G Date/Time','H Sender');
LCmds(20,3,'I Subject','');
LOneK('%LFEmail color to change [^5A^4-^5I^4,^5<CR>^4=^5Quit^4]: ',Cmd1,^M'QABCDEFGHI',TRUE,TRUE);
IF (Cmd1 IN ['A'..'I']) THEN
BEGIN
NewColor := GetColor;
IF PYNQ('%LFIs this correct? ',0,FALSE) THEN
BEGIN
TempScheme1.Color[Ord(Cmd1) + 70] := NewColor;
Changed := TRUE;
END;
END;
UNTIL (Cmd1 = ^M) OR (HangUp);
END;
PROCEDURE InitSchemeVars(VAR Scheme: SchemeRec);
BEGIN
WITH Scheme DO
BEGIN
Description := '<< New Color Scheme >>';
FillChar(Color,SizeOf(Color),7);
Color[1] := 15;
Color[2] := 3;
Color[3] := 13;
Color[4] := 11;
Color[5] := 9;
Color[6] := 14;
Color[7] := 31;
Color[8] := 4;
Color[9] := 132;
Color[10] := 10;
END;
END;
PROCEDURE DeleteScheme(TempScheme1: SchemeRec; RecNumToDelete: SmallInt);
VAR
User: UserRecordType;
RecNum: Integer;
BEGIN
IF (NumSchemes = 0) THEN
Messages(4,0,'color schemes')
ELSE
BEGIN
RecNumToDelete := -1;
InputIntegerWOC('%LFColor scheme to delete',RecNumToDelete,[NumbersOnly],1,NumSchemes);
IF (RecNumToDelete >= 1) AND (RecNumToDelete <= NumSchemes) THEN
BEGIN
Reset(SchemeFile);
Seek(SchemeFile,(RecNumToDelete - 1));
Read(SchemeFile,TempScheme1);
Close(SchemeFile);
LastError := IOResult;
Print('%LFColor scheme: ^5'+TempScheme1.Description);
IF PYNQ('%LFAre you sure you want to delete it? ',0,FALSE) THEN
BEGIN
Print('%LF[> Deleting color scheme record ...');
Dec(RecNumToDelete);
Reset(SchemeFile);
IF (RecNumToDelete >= 0) AND (RecNumToDelete <= (FileSize(SchemeFile) - 2)) THEN
FOR RecNum := RecNumToDelete TO (FileSize(SchemeFile) - 2) DO
BEGIN
Seek(SchemeFile,(RecNum + 1));
Read(SchemeFile,Scheme);
Seek(SchemeFile,RecNum);
Write(SchemeFile,Scheme);
END;
Seek(SchemeFile,(FileSize(SchemeFile) - 1));
Truncate(SchemeFile);
Close(SchemeFile);
LastError := IOResult;
Dec(NumSchemes);
SysOpLog('* Deleted color scheme: ^5'+TempScheme1.Description);
Inc(RecNumToDelete);
Print('%LFUpdating user records ...');
Reset(UserFile);
RecNum := 1;
WHILE (RecNum < FileSize(UserFile)) DO
BEGIN
LoadURec(User,RecNum);
IF (User.ColorScheme = RecNumToDelete) THEN
BEGIN
User.ColorScheme := 1;
SaveURec(User,RecNum);
END
ELSE IF (User.ColorScheme > RecNumTodelete) THEN
BEGIN
Dec(User.ColorScheme);
SaveURec(User,RecNum);
END;
Inc(RecNum);
END;
Close(UserFile);
LastError := IOResult;
END;
END;
END;
END;
PROCEDURE CheckScheme(Scheme: SchemeRec; StartErrMsg,EndErrMsg: Byte; VAR Ok: Boolean);
VAR
Counter: Byte;
BEGIN
FOR Counter := StartErrMsg TO EndErrMsg DO
CASE Counter OF
1 : IF (Scheme.Description = '') OR (Scheme.Description = '<< New Color Scheme >>') THEN
BEGIN
Print('%LF^7The description is invalid!^1');
OK := FALSE;
END;
END;
END;
PROCEDURE EditScheme(TempScheme1: SchemeRec; VAR Scheme: SchemeRec; VAR Cmd1: Char;
VAR RecNumToEdit: SmallInt; VAR Changed: Boolean; Editing: Boolean);
VAR
CmdStr: AStr;
Ok: Boolean;
BEGIN
WITH Scheme DO
REPEAT
IF (Cmd1 <> '?') THEN
BEGIN
Abort := FALSE;
Next := FALSE;
CLS;
IF (Editing) THEN
PrintACR('^5Editing color scheme #'+IntToStr(RecNumToEdit)+' of '+IntToStr(NumSchemes))
ELSE
PrintACR('^5Inserting color scheme #'+IntToStr(RecNumToEdit)+' of '+IntToStr(NumSchemes + 1));
NL;
PrintACR('^11. Description : ^5'+Scheme.Description);
Prompt('^12. System colors : ');
ShowColors;
PrintACR('^13. File listings');
PrintACR('^14. Message listings');
PrintACR('^15. File area listings');
PrintACR('^16. Message area listings');
PrintACR('^17. Offline mail screen');
PrintACR('^18. Private mail listing');
END;
IF (NOT Editing) THEN
CmdStr := '12345678'
ELSE
CmdStr := '12345678[]FJL';
LOneK('%LFModify menu [^5?^4=^5Help^4]: ',Cmd1,'Q?'+CmdStr++^M,TRUE,TRUE);
CASE Cmd1 OF
'1' : REPEAT
TempScheme1.Description := Description;
Ok := TRUE;
InputWN1('%LFNew description: ',Description,(SizeOf(Description) - 1),[InterActiveEdit],Changed);
CheckScheme(Scheme,1,1,Ok);
IF (NOT Ok) THEN
Description := TempScheme1.Description;
UNTIL (Ok) OR (HangUp);
'2' : SystemColors(Scheme,Cmd1,Changed);
'3' : FileColors(Scheme,Cmd1,Changed);
'4' : MsgColors(Scheme,Cmd1,Changed);
'5' : FileAreaColors(Scheme,Cmd1,Changed);
'6' : MsgAreaColors(Scheme,Cmd1,Changed);
'7' : QWKColors(Scheme,Cmd1,Changed);
'8' : EmailColors(Scheme,Cmd1,Changed);
'[' : IF (RecNumToEdit > 1) THEN
Dec(RecNumToEdit)
ELSE
BEGIN
Messages(2,0,'');
Cmd1 := #0;
END;
']' : IF (RecNumToEdit < NumSchemes) THEN
Inc(RecNumToEdit)
ELSE
BEGIN
Messages(3,0,'');
Cmd1 := #0;
END;
'F' : IF (RecNumToEdit <> 1) THEN
RecNumToEdit := 1
ELSE
BEGIN
Messages(2,0,'');
Cmd1 := #0;
END;
'J' : BEGIN
InputIntegerWOC('%LFJump to entry?',RecNumToEdit,[NumbersOnly],1,NumSchemes);
IF (RecNumToEdit < 1) OR (RecNumToEdit > NumSchemes) THEN
Cmd1 := #0;
END;
'L' : IF (RecNumToEdit <> NumSchemes) THEN
RecNumToEdit := NumSchemes
ELSE
BEGIN
Messages(3,0,'');
Cmd1 := #0;
END;
'?' : BEGIN
Print('%LF^1<^3CR^1>Redisplay current screen');
Print('^31^1-^38^1:Modify item');
IF (NOT Editing) THEN
LCmds(20,3,'Quit and save','')
ELSE
BEGIN
LCmds(20,3,'[Back entry',']Forward entry');
LCmds(20,3,'First entry in list','Jump to entry');
LCmds(20,3,'Last entry in list','Quit and save');
END;
END;
END;
UNTIL (Pos(Cmd1,'Q[]FJL') <> 0) OR (HangUp);
END;
PROCEDURE InsertScheme(TempScheme1: SchemeRec; Cmd1: Char; RecNumToInsertBefore: SmallInt);
VAR
User: UserRecordType;
RecNum,
RecNumToEdit: SmallInt;
Ok,
Changed: Boolean;
BEGIN
IF (NumSchemes = MaxSchemes) THEN
Messages(5,MaxSchemes,'color schemes')
ELSE
BEGIN
RecNumToInsertBefore := -1;
InputIntegerWOC('%LFColor scheme to insert before',RecNumToInsertBefore,[NumbersOnly],1,(NumSchemes + 1));
IF (RecNumToInsertBefore >= 1) AND (RecNumToInsertBefore <= (NumSchemes + 1)) THEN
BEGIN
Reset(SchemeFile);
InitSchemeVars(TempScheme1);
IF (RecNumToInsertBefore = 1) THEN
RecNumToEdit := 1
ELSE IF (RecNumToInsertBefore = (NumSchemes + 1)) THEN
RecNumToEdit := (NumSchemes + 1)
ELSE
RecNumToEdit := RecNumToInsertBefore;
REPEAT
OK := TRUE;
EditScheme(TempScheme1,TempScheme1,Cmd1,RecNumToEdit,Changed,FALSE);
CheckScheme(TempScheme1,1,1,Ok);
IF (NOT OK) THEN
IF (NOT PYNQ('%LFContinue inserting color scheme? ',0,TRUE)) THEN
Abort := TRUE;
UNTIL (OK) OR (Abort) OR (HangUp);
IF (NOT Abort) AND (PYNQ('%LFIs this what you want? ',0,FALSE)) THEN
BEGIN
Print('%LF[> Inserting color scheme record ...');
Seek(SchemeFile,FileSize(SchemeFile));
Write(SchemeFile,Scheme);
Dec(RecNumToInsertBefore);
FOR RecNum := ((FileSize(SchemeFile) - 1) - 1) DOWNTO RecNumToInsertBefore DO
BEGIN
Seek(SchemeFile,RecNum);
Read(SchemeFile,Scheme);
Seek(SchemeFile,(RecNum + 1));
Write(SchemeFile,Scheme);
END;
FOR RecNum := RecNumToInsertBefore TO ((RecNumToInsertBefore + 1) - 1) DO
BEGIN
Seek(SchemeFile,RecNum);
Write(SchemeFile,TempScheme1);
Inc(NumSchemes);
SysOpLog('* Inserted color scheme: ^5'+TempScheme1.Description);
END;
END;
Close(SchemeFile);
LastError := IOResult;
Inc(RecNumToInsertBefore);
Print('%LFUpdating user records ...');
Reset(UserFile);
RecNum := 1;
WHILE (RecNum < FileSize(UserFile)) DO
BEGIN
LoadURec(User,RecNum);
IF (User.ColorScheme >= RecNumToInsertBefore) THEN
BEGIN
Inc(User.ColorScheme);
SaveURec(User,RecNum);
END;
Inc(RecNum);
END;
Close(UserFile);
LastError := IOResult;
END;
END;
END;
PROCEDURE ModifyScheme(TempScheme1: SchemeRec; Cmd1: Char; RecNumToEdit: SmallInt);
VAR
SaveRecNumToEdit: Integer;
Ok,
Changed: Boolean;
BEGIN
IF (NumSchemes = 0) THEN
Messages(4,0,'color schemes')
ELSE
BEGIN
RecNumToEdit := -1;
InputIntegerWOC('%LFColor scheme to modify',RecNumToEdit,[NumbersOnly],1,NumSchemes);
IF (RecNumToEdit >= 1) AND (RecNumToEdit <= NumSchemes) THEN
BEGIN
SaveRecNumToEdit := -1;
Cmd1 := #0;
Reset(SchemeFile);
WHILE (Cmd1 <> 'Q') AND (NOT HangUp) DO
BEGIN
IF (RecNumToEdit <> SaveRecNumToEdit) THEN
BEGIN
Seek(SchemeFile,(RecNumToEdit - 1));
Read(SchemeFile,Scheme);
SaveRecNumToEdit := RecNumToEdit;
Changed := FALSE;
END;
REPEAT
Ok := TRUE;
EditScheme(TempScheme1,Scheme,Cmd1,RecNumToEdit,Changed,TRUE);
CheckScheme(Scheme,1,1,Ok);
IF (NOT OK) THEN
BEGIN
PauseScr(FALSE);
IF (RecNumToEdit <> SaveRecNumToEdit) THEN
RecNumToEdit := SaveRecNumToEdit;
END;
UNTIL (Ok) OR (HangUp);
IF (Changed) THEN
BEGIN
Seek(SchemeFile,(SaveRecNumToEdit - 1));
Write(SchemeFile,Scheme);
SysOpLog('* Modified color scheme: ^5'+Scheme.Description);
END;
END;
Close(SchemeFile);
LastError := IOResult;
END;
END;
END;
PROCEDURE PositionScheme(TempScheme1: SchemeRec);
VAR
User: UserRecordType;
RecNumToPosition,
RecNumToPositionBefore,
RecNum1,
RecNum2: SmallInt;
BEGIN
IF (NumSchemes = 0) THEN
Messages(4,0,'color schemes')
ELSE IF (NumSchemes = 1) THEN
Messages(6,0,'color schemes')
ELSE
BEGIN
RecNumToPosition := -1;
InputIntegerWOC('%LFPosition which color scheme',RecNumToPosition,[NumbersOnly],1,NumSchemes);
IF (RecNumToPosition >= 1) AND (RecNumToPosition <= NumSchemes) THEN
BEGIN
Print('%LFAccording to the current numbering system.');
RecNumToPositionBefore := -1;
InputIntegerWOC('%LFPosition before which color scheme',RecNumToPositionBefore,[NumbersOnly],1,(NumSchemes + 1));
IF (RecNumToPositionBefore >= 1) AND (RecNumToPositionBefore <= (NumSchemes + 1)) AND
(RecNumToPositionBefore <> RecNumToPosition) AND (RecNumToPositionBefore <> (RecNumToPosition + 1)) THEN
BEGIN
Print('%LF[> Positioning color scheme record ...');
Reset(SchemeFile);
IF (RecNumToPositionBefore > RecNumToPosition) THEN
Dec(RecNumToPositionBefore);
Dec(RecNumToPosition);
Dec(RecNumToPositionBefore);
Seek(SchemeFile,RecNumToPosition);
Read(SchemeFile,TempScheme1);
RecNum1 := RecNumToPosition;
IF (RecNumToPosition > RecNumToPositionBefore) THEN
RecNum2 := -1
ELSE
RecNum2 := 1;
WHILE (RecNum1 <> RecNumToPositionBefore) DO
BEGIN
IF ((RecNum1 + RecNum2) < FileSize(SchemeFile)) THEN
BEGIN
Seek(SchemeFile,(RecNum1 + RecNum2));
Read(SchemeFile,Scheme);
Seek(SchemeFile,RecNum1);
Write(SchemeFile,Scheme);
END;
Inc(RecNum1,RecNum2);
END;
Seek(SchemeFile,RecNumToPositionBefore);
Write(SchemeFile,TempScheme1);
Close(SchemeFile);
LastError := IOResult;
Inc(RecNumToPosition);
Inc(RecNumToPositionBefore);
Print('%LFUpdating user records ...');
Reset(UserFile);
RecNum1 := 1;
WHILE (RecNum1 < FileSize(UserFile)) DO
BEGIN
LoadURec(User,RecNum1);
IF (User.ColorScheme = RecNumToPosition) THEN
BEGIN
User.ColorScheme := RecNumToPositionBefore;
SaveURec(User,RecNum1);
END
ELSE IF (User.ColorScheme = RecNumToPositionBefore) THEN
BEGIN
User.ColorScheme := RecNumToPosition;
SaveURec(User,RecNum1);
END;
Inc(RecNum1);
END;
Close(UserFile);
LastError := IOResult;
END;
END;
END;
END;
PROCEDURE ListSchemes(VAR RecNumToList1: Integer);
VAR
NumDone: Integer;
BEGIN
IF (RecNumToList1 < 1) OR (RecNumToList1 > NumSchemes) THEN
RecNumToList1 := 1;
Abort := FALSE;
Next := FALSE;
CLS;
PrintACR('^0###^4:^3'+PadLeftStr('Description',30)+'^4:^3Colors');
PrintACR('^4===:==============================:============================');
Reset(SchemeFile);
NumDone := 0;
WHILE (NumDone < (PageLength - 5)) AND (RecNumToList1 >= 1) AND (RecNumToList1 <= NumSchemes)
AND (NOT Abort) AND (NOT HangUp) DO
BEGIN
Seek(SchemeFile,(RecNumToList1 - 1));
Read(SchemeFile,Scheme);
WITH Scheme DO
Prompt('^0'+PadRightInt(RecNumToList1,3)+
' ^5'+PadLeftStr(Description,30)+
' ');
ShowColors;
Inc(RecNumToList1);
Inc(NumDone);
END;
Close(SchemeFile);
LastError := IOResult;
IF (NumSchemes = 0) THEN
Print('*** No color schemes defined ***');
END;
BEGIN
SaveTempPause := TempPause;
TempPause := FALSE;
RecNumToList := 1;
Cmd := #0;
REPEAT
IF (Cmd <> '?') THEN
ListSchemes(RecNumToList);
LOneK('%LFColor scheme editor [^5?^4=^5Help^4]: ',Cmd,'QDIMP?'^M,TRUE,TRUE);
CASE Cmd OF
^M : IF (RecNumToList < 1) OR (RecNumToList > NumSchemes) THEN
RecNumToList := 1;
'D' : DeleteScheme(TempScheme,RecNumToList);
'I' : InsertScheme(TempScheme,Cmd,RecNumToList);
'M' : ModifyScheme(TempScheme,Cmd,RecNumToList);
'P' : PositionScheme(TempScheme);
'?' : BEGIN
Print('%LF^1<^3CR^1>Next screen or redisplay current screen');
Print('^1(^3?^1)Help/First color scheme');
LCmds(20,3,'Delete color scheme','Insert color scheme');
LCmds(20,3,'Modify color scheme','Position color scheme');
LCmds(20,3,'Quit','');
END;
END;
IF (CMD <> ^M) THEN
RecNumToList := 1;
UNTIL (Cmd = 'Q') OR (HangUp);
TempPause := SaveTempPause;
IF (ThisUser.ColorScheme < 1) OR (ThisUser.ColorScheme > FileSize(SchemeFile)) THEN
ThisUser.ColorScheme := 1;
Reset(SchemeFile);
Seek(SchemeFile,(ThisUser.ColorScheme - 1));
Read(SchemeFile,Scheme);
Close(SchemeFile);
LastError := IOResult;
END;
END.

363
SOURCE/SYSOP2K.PAS Normal file
View File

@ -0,0 +1,363 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S+,V-}
UNIT SysOp2K;
INTERFACE
PROCEDURE DisplayArcs;
PROCEDURE DisplayCmt;
PROCEDURE ArchiveConfiguration;
IMPLEMENTATION
USES
Common;
PROCEDURE DisplayArcs;
VAR
RecNumToList: Byte;
BEGIN
Abort := FALSE;
Next := FALSE;
PrintACR('^0 ##^4:^3Ext^4:^3Compression cmdline ^4:^3Decompression cmdline ^4:^3Success Code');
PrintACR('^4 ==:===:=========================:=========================:============');
RecNumToList := 1;
WHILE (RecNumToList <= NumArcs) AND (NOT Abort) AND (NOT HangUp) DO
BEGIN
WITH General.FileArcInfo[RecNumToList] DO
PrintACR(AOnOff(Active,'^5+','^1-')+
'^0'+PadRightInt(RecNumToList,2)+
' ^3'+PadLeftStr(Ext,3)+
' ^5'+PadLeftStr(ArcLine,25)+
' '+PadLeftStr(UnArcLine,25)+
' '+AOnOff(SuccLevel <> - 1,IntToStr(SuccLevel),'-1 (ignores)'));
Inc(RecNumToList);
END;
END;
PROCEDURE DisplayCmt;
VAR
RecNumToList: Byte;
BEGIN
FOR RecNumToList := 1 TO 3 DO
PrintACR('^1'+IntToStr(RecNumToList)+'. Archive comment file: ^5'+
AOnOff(General.FileArcComment[RecNumToList] <> '',
General.FileArcComment[RecNumToList],'*None*'));
END;
PROCEDURE ArchiveConfiguration;
VAR
TempArchive: FileArcInfoRecordType;
Cmd: Char;
RecNumToList: Byte;
Changed : Boolean;
FUNCTION DisplayArcStr(S: AStr): AStr;
BEGIN
IF (S <> '') THEN
DisplayArcStr := S
ELSE
DisplayArcStr := '*None*';
IF (S[1] = '/') THEN
BEGIN
S := '"'+S+'" - ';
CASE s[3] OF
'1' : DisplayArcStr := S + '*Internal* ZIP viewer';
'2' : DisplayArcStr := S + '*Internal* ARC/PAK viewer';
'3' : DisplayArcStr := S + '*Internal* ZOO viewer';
'4' : DisplayArcStr := S + '*Internal* LZH viewer';
'5' : DisplayArcStr := S + '*Internal* ARJ viewer';
END;
END;
END;
PROCEDURE InitArchiveVars(VAR Archive: FileArcInfoRecordType);
BEGIN
FillChar(Archive,SizeOf(Archive),0);
WITH Archive DO
BEGIN
Active := FALSE;
Ext := 'AAA';
ListLine := '';
ArcLine := '';
UnArcLine := '';
TestLine := '';
CmtLine := '';
SuccLevel := -1;
END;
END;
PROCEDURE DeleteArchive(TempArchive1: FileArcInfoRecordType; RecNumToDelete: Byte);
VAR
RecNum: Byte;
BEGIN
IF (NumArcs = 0) THEN
Messages(4,0,'archive records')
ELSE
BEGIN
RecNumToDelete := 0;
InputByteWOC('%LFArchive to delete?',RecNumToDelete,[NumbersOnly],1,NumArcs);
IF (RecNumToDelete >= 1) AND (RecNumToDelete <= NumArcs) THEN
BEGIN
TempArchive1 := General.FileArcInfo[RecNumToDelete];
Print('%LFArchive: ^5'+TempArchive1.Ext);
IF PYNQ('%LFAre you sure you want to delete it? ',0,FALSE) THEN
BEGIN
Print('%LF[> Deleting archive record ...');
FOR RecNum := RecNumToDelete TO (NumArcs - 1) DO
General.FileArcInfo[RecNum] := General.FileArcInfo[RecNum + 1];
General.FileArcInfo[NumArcs].Ext := '';
Dec(NumArcs);
SysOpLog('* Deleted archive: ^5'+TempArchive1.Ext);
END;
END;
END;
END;
PROCEDURE CheckArchive(Archive: FileArcInfoRecordType; StartErrMsg,EndErrMsg: Byte; VAR Ok: Boolean);
VAR
Counter: Byte;
BEGIN
FOR Counter := StartErrMsg TO EndErrMsg DO
CASE Counter OF
1 : IF (Archive.Ext = '') OR (Archive.Ext = 'AAA') THEN
BEGIN
Print('%LF^7The archive extension is invalid!^1');
OK := FALSE;
END;
END;
END;
PROCEDURE EditArchive(TempArchive1: FileArcInfoRecordType; VAR Archive: FileArcInfoRecordType; VAR Cmd1: Char;
VAR RecNumToEdit: Byte; VAR Changed1: Boolean; Editing: Boolean);
VAR
CmdStr: AStr;
Ok: Boolean;
BEGIN
WITH Archive DO
REPEAT
IF (Cmd1 <> '?') THEN
BEGIN
Abort := FALSE;
Next := FALSE;
CLS;
IF (Editing) THEN
PrintACR('^5Editing archive #'+IntToStr(RecNumToEdit)+
' of '+IntToStr(NumArcs))
ELSE
PrintACR('^5Inserting archive #'+IntToStr(RecNumToEdit)+' of '+IntToStr(NumArcs + 1));
NL;
PrintACR('^11. Active : ^5'+ShowYesNo(Active));
PrintACR('^12. Extension name : ^5'+Ext);
PrintACR('^13. Interior list method : ^5'+DisplayArcStr(ListLine));
PrintACR('^14. Compression cmdline : ^5'+DisplayArcStr(ArcLine));
PrintACR('^15. Decompression cmdline : ^5'+DisplayArcStr(UnArcLine));
PrintACR('^16. File testing cmdline : ^5'+DisplayArcStr(TestLine));
PrintACR('^17. Add comment cmdline : ^5'+DisplayArcStr(CmtLine));
PrintACR('^18. Errorlevel for success : ^5'++AOnOff(SuccLevel <> - 1,IntToStr(SuccLevel),'-1 (ignores)'));
END;
IF (NOT Editing) THEN
CmdStr := '12345678'
ELSE
CmdStr := '12345678[]FJL';
LOneK('%LFModify menu [^5?^4=^5Help^4]: ',Cmd1,'Q?'+CmdStr+^M,TRUE,TRUE);
CASE Cmd1 OF
'1' : BEGIN
Active := NOT Active;
Changed1 := TRUE;
END;
'2' : REPEAT
TempArchive1.Ext := Ext;
Ok := TRUE;
InputWN1('%LFNew extension: ',Ext,(SizeOf(Ext) - 1),[InterActiveEdit,UpperOnly],Changed1);
CheckArchive(Archive,1,1,Ok);
IF (NOT Ok) THEN
Ext := TempArchive1.Ext;
UNTIL (Ok) OR (HangUp);
'3' : InputWN1('%LFNew interior list method: ',ListLine,(SizeOf(ListLine) - 1),[InterActiveEdit],Changed1);
'4' : InputWN1('%LFNew compression command line: ',ArcLine,(SizeOf(ArcLine) - 1),[InterActiveEdit],Changed1);
'5' : InputWN1('%LFNew decompression command line: ',UnArcLine,(SizeOf(UnArcLine) - 1),
[InterActiveEdit],Changed1);
'6' : InputWN1('%LFNew file testing command line: ',TestLine,(SizeOf(TestLine) - 1),
[InterActiveEdit],Changed1);
'7' : InputWN1('%LFNew add comment command line: ',CmtLine,(SizeOf(CmtLine) - 1),[InterActiveEdit],Changed1);
'8' : InputIntegerWC('%LFNew errorlevel for success',SuccLevel,[DisplayValue,NumbersOnly],-1,255,Changed1);
'[' : IF (RecNumToEdit > 1) THEN
Dec(RecNumToEdit)
ELSE
BEGIN
Messages(2,0,'');
Cmd1 := #0;
END;
']' : IF (RecNumToEdit < NumArcs) THEN
Inc(RecNumToEdit)
ELSE
BEGIN
Messages(3,0,'');
Cmd1 := #0;
END;
'F' : IF (RecNumToEdit <> 1) THEN
RecNumToEdit := 1
ELSE
BEGIN
Messages(2,0,'');
Cmd1 := #0;
END;
'J' : BEGIN
InputByteWOC('%LFJump to entry?',RecNumToEdit,[NumbersOnly],1,NumArcs);
IF (RecNumToEdit < 1) OR (RecNumToEdit > NumArcs) THEN
Cmd1 := #0;
END;
'L' : IF (RecNumToEdit <> NumArcs) THEN
RecNumToEdit := NumArcs
ELSE
BEGIN
Messages(3,0,'');
Cmd1 := #0;
END;
'?' : BEGIN
Print('%LF^1<^3CR^1>Redisplay current screen');
Print('^31^1-^38^1:Modify item');
IF (NOT Editing) THEN
LCmds(20,3,'Quit and save','')
ELSE
BEGIN
LCmds(20,3,'[Back entry',']Forward entry');
LCmds(20,3,'First entry in list','Jump to entry');
LCmds(20,3,'Last entry in list','Quit and save');
END;
END;
END;
UNTIL (Pos(Cmd1,'Q[]FJL') <> 0) OR (HangUp);
END;
PROCEDURE InsertArchive(TempArchive1: FileArcInfoRecordType; Cmd1: Char; RecNumToInsertBefore: Byte);
VAR
RecNum,
RecNumToEdit: Byte;
Ok,
Changed1: Boolean;
BEGIN
IF (NumArcs = MaxArcs) THEN
Messages(5,MaxArcs,'archive records')
ELSE
BEGIN
RecNumToInsertBefore := 0;
InputByteWOC('%LFArchive to insert before?',RecNumToInsertBefore,[NumbersOnly],1,(NumArcs + 1));
IF (RecNumToInsertBefore >= 1) AND (RecNumToInsertBefore <= (NumArcs + 1)) THEN
BEGIN
InitArchiveVars(TempArchive1);
IF (RecNumToInsertBefore = 1) THEN
RecNumToEdit := 1
ELSE IF (RecNumToInsertBefore = (NumArcs + 1)) THEN
RecNumToEdit := (NumArcs + 1)
ELSE
RecNumToEdit := RecNumToInsertBefore;
REPEAT
OK := TRUE;
EditArchive(TempArchive1,TempArchive1,Cmd1,RecNumToEdit,Changed1,FALSE);
CheckArchive(TempArchive1,1,2,Ok);
IF (NOT OK) THEN
IF (NOT PYNQ('%LFContinue inserting archive? ',0,TRUE)) THEN
Abort := TRUE;
UNTIL (OK) OR (Abort) OR (HangUp);
IF (NOT Abort) AND (PYNQ('%LFIs this what you want? ',0,FALSE)) THEN
BEGIN
Print('%LF[> Inserting archive record ...');
IF (RecNumToInsertBefore <> (NumArcs + 1)) THEN
FOR RecNum := (NumArcs + 1) DOWNTO (RecNumToInsertBefore + 1) DO
General.FileArcInfo[RecNum] := General.FileArcInfo[RecNum - 1];
General.FileArcInfo[RecNumToInsertBefore] := TempArchive1;
Inc(NumArcs);
SysOpLog('* Inserted archive: ^5'+TempArchive1.Ext);
END;
END;
END;
END;
PROCEDURE ModifyArchive(TempArchive1: FileArcInfoRecordType; Cmd1: Char; RecNumToEdit: Byte);
VAR
Archive: FileArcInfoRecordType;
SaveRecNumToEdit: Byte;
OK,
Changed1: Boolean;
BEGIN
IF (NumArcs = 0) THEN
Messages(4,0,'archive records')
ELSE
BEGIN
RecNumToEdit := 0;
InputByteWOC('%LFArchive to modify?',RecNumToEdit,[NumbersOnly],1,NumArcs);
IF (RecNumToEdit >= 1) AND (RecNumToEdit <= NumArcs) THEN
BEGIN
SaveRecNumToEdit := 0;
Cmd1 := #0;
WHILE (Cmd1 <> 'Q') AND (NOT HangUp) DO
BEGIN
IF (SaveRecNumToEdit <> RecNumToEdit) THEN
BEGIN
Archive := General.FileArcInfo[RecNumToEdit];
SaveRecNumToEdit := RecNumToEdit;
Changed1 := FALSE;
END;
REPEAT
Ok := TRUE;
EditArchive(TempArchive1,Archive,Cmd1,RecNumToEdit,Changed1,TRUE);
CheckArchive(Archive,1,2,Ok);
IF (NOT OK) THEN
BEGIN
PauseScr(FALSE);
IF (RecNumToEdit <> SaveRecNumToEdit) THEN
RecNumToEdit := SaveRecNumToEdit;
END;
UNTIL (Ok) OR (HangUp);
IF (Changed1) THEN
BEGIN
General.FileArcInfo[SaveRecNumToEdit] := Archive;
Changed1 := FALSE;
SysOpLog('* Modified archive: ^5'+Archive.Ext);
END;
END;
END;
END;
END;
BEGIN
Cmd := #0;
REPEAT
IF (Cmd <> '?') THEN
BEGIN
CLS;
DisplayArcs;
NL;
DisplayCmt;
END;
LOneK('%LFArchive editor [^5?^4=^5Help^4]: ',Cmd,'QDIM123?'^M,TRUE,TRUE);
CASE Cmd OF
'D' : DeleteArchive(TempArchive,RecNumToList);
'I' : InsertArchive(TempArchive,Cmd,RecNumToList);
'M' : ModifyArchive(TempArchive,Cmd,RecNumToList);
'1'..'3' :
BEGIN
Changed := FALSE;
InputWNWC('%LFNew comment file #'+IntToStr(Ord(Cmd) - 48)+': ',General.FileArcComment[Ord(Cmd) - 48],40,Changed);
IF (Changed) THEN
SysOpLog('* Modified comment: ^5'+IntToStr(Ord(Cmd) - 48)+'.');
END;
'?' : BEGIN
Print('%LF^1<^3CR^1>Next screen or redisplay current screen');
Print('^1(^3?^1)Help/First archive');
Print('^31^1-^33^1:Modify Item');
LCmds(16,3,'Delete archive','Insert archive');
LCmds(16,3,'Modify archive','Quit');
END;
END;
UNTIL (Cmd = 'Q') OR (HangUp);
END;
END.

48
SOURCE/SYSOP2L.PAS Normal file
View File

@ -0,0 +1,48 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D-,E-,F+,I-,L-,N-,O+,R-,S+,V-}
UNIT SysOp2L;
INTERFACE
PROCEDURE CreditConfiguration;
IMPLEMENTATION
USES
Common;
PROCEDURE CreditConfiguration;
VAR
Cmd: Char;
BEGIN
REPEAT
WITH General DO
BEGIN
Abort := FALSE;
Next := FALSE;
CLS;
Print('^5Credit System Configuration:');
NL;
PrintACR('^1A. Charge/minute : ^5'+IntToStr(CreditMinute));
PrintACR('^1B. Message post : ^5'+IntToStr(CreditPost));
PrintACR('^1C. Email sent : ^5'+IntToStr(CreditEmail));
PrintACR('^1D. Free time at logon : ^5'+IntToStr(CreditFreeTime));
PrintACR('^1E. Internet mail cost : ^5'+IntToStr(CreditInternetMail));
Prt('%LFEnter selection [^5A^4-^5E^4,^5Q^4=^5Quit^4]: ');
OneK(Cmd,'QABCDE'^M,TRUE,TRUE);
CASE Cmd OF
'A' : InputIntegerWOC('%LFCredits charged per minute online',CreditMinute,[NumbersOnly],0,32767);
'B' : InputIntegerWOC('%LFCredits charged per message post',CreditPost,[NumbersOnly],0,32767);
'C' : InputIntegerWOC('%LFCredits charged per email sent',CreditEmail,[Numbersonly],0,32767);
'D' : InputIntegerWOC('%LFMinutes to give users w/o credits at logon',CreditFreeTime,[NumbersOnly],0,32767);
'E' : InputIntegerWOC('%LFCost for Internet mail messages',CreditInternetMail,[NumbersOnly],0,32767);
END;
END;
UNTIL (Cmd = 'Q') OR (HangUp);
END;
END.

134
SOURCE/SYSOP2M.PAS Normal file
View File

@ -0,0 +1,134 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D-,E-,F+,I-,L-,N-,O+,R-,S+,V-}
UNIT SysOp2M;
INTERFACE
PROCEDURE NewUserTogglesConfiguration;
IMPLEMENTATION
USES
Common;
PROCEDURE NewUserTogglesConfiguration;
VAR
TempStr: STRING[70];
Cmd: CHAR;
TempB: BYTE;
Changed: Boolean;
FUNCTION Toggle(NUToggle,CUSerNum: BYTE): BYTE;
BEGIN
IF (NUToggle = 0) THEN
Toggle := CUserNum
ELSE
Toggle := 0;
END;
BEGIN
REPEAT
CLS;
Abort := FALSE;
Next := FALSE;
MCIAllowed := FALSE;
WITH General DO
BEGIN
Print('^5New User Question Toggles Configuration:');
NL;
NewUserToggles[1] := 7;
PrintACR('^1A. Ask what the REAL NAME is : ^5'+ShowYesNo(NewUserToggles[2] <> 0));
PrintACR('^1B. Ask which COUNTRY from : ^5'+ShowYesNo(NewUserToggles[3] <> 0));
PrintACR('^1C. Ask what the ADDRESS is : ^5'+ShowYesNo(NewUserToggles[4] <> 0));
PrintACR('^1D. Ask what the CITY, STATE is : ^5'+ShowYesNo(NewUserToggles[5] <> 0));
PrintACR('^1E. Ask what the ZIP CODE is : ^5'+ShowYesNo(NewUserToggles[6] <> 0));
PrintACR('^1F. Ask what the PHONE NUMBER is : ^5'+ShowYesNo(NewUserToggles[7] <> 0));
PrintACR('^1G. Ask which Gender (Male/Female) : ^5'+ShowYesNo(NewUserToggles[8] <> 0));
PrintACR('^1H. Ask what the BIRTHDAY is : ^5'+ShowYesNo(NewUserToggles[9] <> 0));
PrintACR('^1I. Ask SysOp Question #1 : ^5'+ShowYesNo(NewUserToggles[10] <> 0));
PrintACR('^1J. Ask SysOp Question #2 : ^5'+ShowYesNo(NewUserToggles[11] <> 0));
PrintACR('^1K. Ask SysOp Question #3 : ^5'+ShowYesNo(NewUserToggles[12] <> 0));
PrintACR('^1L. Ask EMULATION that is required : ^5'+ShowYesNo(NewUserToggles[13] <> 0));
PrintACR('^1M. Ask SCREEN SIZE that is required : ^5'+ShowYesNo(NewUserToggles[14] <> 0));
PrintACR('^1N. Ask if Msg SCREEN CLEARING is needed: ^5'+ShowYesNo(NewUserToggles[15] <> 0));
PrintACR('^1O. Ask if SCREEN PAUSES are needed : ^5'+ShowYesNo(NewUserToggles[16] <> 0));
PrintACR('^1P. Ask if HOTKEYS are needed : ^5'+ShowYesNo(NewUserToggles[17] <> 0));
PrintACR('^1R. Ask if EXPERT MODE is needed : ^5'+ShowYesNo(NewUserToggles[18] <> 0));
NewUserToggles[19] := 9;
PrintACR('^1S. Ask FORGOT PW question : ^5'+ShowYesNo(NewUserToggles[20] <> 0));
IF (RGMainStr(6, TRUE) <> '') THEN
{PrintACR('^1 ('+ForgotPWQuestion+')');} PrintACR('^1 ('+ RGMainStr(6,TRUE) + ')');
END;
MCIAllowed := TRUE;
Prt('%LFEnter selection [^5A^4-^5P^4,^5R^4-^5S^4,^5Q^4=^5Quit^4]: ');
OneK(Cmd,'QABCDEFGHIJKLMNOPRS'^M,TRUE,TRUE);
WITH General DO
CASE Cmd OF
'A' : NewUserToggles[2] := Toggle(NewUserToggles[2],10);
'B' : NewUserToggles[3] := Toggle(NewUserToggles[3],23);
'C' : NewUserToggles[4] := Toggle(NewUserToggles[4],1);
'D' : NewUserToggles[5] := Toggle(NewUserToggles[5],4);
'E' : NewUserToggles[6] := Toggle(NewUserToggles[6],14);
'F' : BEGIN
NewUserToggles[7] := Toggle(NewUserToggles[7],8);
IF (NewUserToggles[7] <> 0) THEN
General.PhonePW := TRUE
ELSE
General.PhonePW := FALSE;
END;
'G' : NewUserToggles[8] := Toggle(NewUserToggles[8],12);
'H' : BEGIN
NewUserToggles[9] := Toggle(NewUserToggles[9],2);
(*
IF (NewUserToggles[9] = 0) THEN
General.BirthDateCheck := 0
ELSE
BEGIN
REPEAT
NL;
Prt('Logins before birthday check (0-255): ');
Ini(TempB);
IF (TempB < 0) OR (TempB > 255) THEN
BEGIN
NL;
Print('Invalid Range!');
PauseScr(FALSE);
END;
UNTIL (TempB >= 0) AND (TempB <= 255) OR (HangUp);
General.BirthDateCheck := TempB;
END;
*)
END;
'I' : NewUserToggles[10] := Toggle(NewUserToggles[10],5);
'J' : NewUserToggles[11] := Toggle(NewUserToggles[11],6);
'K' : NewUserToggles[12] := Toggle(NewUserToggles[12],13);
'L' : NewUserToggles[13] := Toggle(NewUserToggles[13],3);
'M' : NewUserToggles[14] := Toggle(NewUserToggles[14],11);
'N' : NewUserToggles[15] := Toggle(NewUserToggles[15],29);
'O' : NewUserToggles[16] := Toggle(NewUserToggles[16],24);
'P' : NewUserToggles[17] := Toggle(NewUserToggles[17],25);
'R' : NewUserToggles[18] := Toggle(NewUserToggles[18],28);
'S' : BEGIN
NewUserToggles[20] := Toggle(NewUserToggles[20],30);
(*)IF (NewUserToggles[20] = 0) THEN
ForgotPWQuestion := ''
ELSE
BEGIN
TempStr := General.ForgotPWQuestion;
REPEAT
InputWN1('%LFEnter question to ask user if they forget thier password:%LF: ',TempStr,70,
[InterActiveEdit],Changed);
UNTIL (TempStr <> '') OR (HangUp);
IF (Changed) THEN
ForgotPWQuestion := TempStr;
END; *)
END;
END;
UNTIL (Cmd = 'Q') OR (HangUp);
END;
END.

98
SOURCE/SYSOP2O.PAS Normal file
View File

@ -0,0 +1,98 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D-,E-,F+,I-,L-,N-,O+,R-,S+,V-}
UNIT SysOp2O;
INTERFACE
USES
Common;
PROCEDURE GetSecRange(CONST DisplayType: LongInt; VAR Sec: SecurityRangeType);
IMPLEMENTATION
PROCEDURE GetSecRange(CONST DisplayType: LongInt; VAR Sec: SecurityRangeType);
VAR
Cmd: Char;
Counter: Byte;
DisplayValue,
FromValue,
ToValue: SmallInt;
NewValue: LongInt;
PROCEDURE ShowSecRange(Start: Byte);
VAR
TempStr: AStr;
LineNum,
Counter1: Byte;
SecNum: Integer;
BEGIN
Abort := FALSE;
Next := FALSE;
LineNum := 0;
REPEAT
TempStr := '';
FOR Counter1 := 0 TO 7 DO
BEGIN
SecNum := Start + LineNum + Counter1 * 20;
IF (SecNum <= 255) THEN
BEGIN
TempStr := TempStr + '^1'+PadLeftInt(SecNum,3)+':^5'+PadLeftInt(Sec[SecNum],5);
IF (Counter1 <> 7) THEN
TempStr := TempStr + ' ';
END;
END;
PrintACR(TempStr);
Inc(LineNum);
UNTIL (LineNum > 19) OR (Abort) OR (HangUp);
END;
BEGIN
Abort := FALSE;
Next := FALSE;
DisplayValue := 0;
REPEAT
CLS;
CASE DisplayType OF
1 : Print('^5Time limitations:^1');
2 : Print('^5Call allowance per day:^1');
3 : Print('^5UL/DL # files ratio (# files can DL per UL):^1');
4 : Print('^5UL/DL K-bytes ratio (#k can DL per 1k UL):^1');
5 : Print('^5Post/Call ratio (posts per 100 calls) to have Z ACS flag set:^1');
6 : Print('^5Maximum number of downloads in one day:^1');
7 : Print('^5Maximum amount of downloads (in kbytes) in one day:^1');
END;
NL;
ShowSecRange(DisplayValue);
LOneK('%LFRange settings [^5S^4=^5Set^4,^5T^4=^5Toggle^4,^5Q^4=^5Quit^4]: ',Cmd,'QST'^M,TRUE,TRUE);
CASE Cmd OF
'S' : BEGIN
FromValue := -1;
InputIntegerWOC('%LFFrom?',FromValue,[NumbersOnly],0,255);
IF (FromValue >= 0) AND (FromValue <= 255) THEN
BEGIN
ToValue := -1;
InputIntegerWOC('%LFTo?',ToValue,[NumbersOnly],0,255);
IF (ToValue >= 0) AND (ToValue <= 255) THEN
BEGIN
NewValue := -1;
InputLongIntWOC('%LFValue to set?',NewValue,[NumbersOnly],0,32767);
IF (NewValue >= 0) AND (NewValue <= 32767) THEN
FOR Counter := FromValue TO ToValue DO
Sec[Counter] := NewValue;
END;
END;
END;
'T' : IF (DisplayValue = 0) THEN
DisplayValue := 160
ELSE
DisplayValue := 0;
END;
UNTIL (Cmd = 'Q') OR (HangUp);
END;
END.

1416
SOURCE/SYSOP3.PAS Normal file
View File

File diff suppressed because it is too large Load Diff

563
SOURCE/SYSOP4.PAS Normal file
View File

@ -0,0 +1,563 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D-,E-,F+,I-,L-,N-,O+,R-,S-,V-}
UNIT SysOp4;
INTERFACE
USES
Common;
PROCEDURE TEdit1;
PROCEDURE TEdit(CONST FSpec: AStr);
IMPLEMENTATION
USES
Dos;
PROCEDURE TEdit1;
VAR
FSpec: AStr;
Dir: DirStr;
Name: NameStr;
Ext: ExtStr;
BEGIN
NL;
Prt('File name: ');
IF (FileSysOp) THEN
BEGIN
MPL(50);
Input(FSpec,50);
END
ELSE
BEGIN
MPL(12);
Input(FSpec,12);
FSplit(FSpec,Dir,Name,Ext);
FSpec := Name+Ext;
END;
TEdit(FSpec);
END;
PROCEDURE TEdit(CONST FSpec: AStr);
TYPE
StrPtr = ^StrRec;
StrRec = RECORD
S: AStr;
Next,
Last: StrPtr;
END;
VAR
TopHeap: ^Byte;
Fil: Text;
Cur,
Nex,
Las,
Top,
Bottom,
Used: StrPtr;
S: AStr;
TotalLines,
CurLine,
I: Integer;
Done,
AllRead: Boolean;
PROCEDURE InLi(VAR S1: AStr);
VAR
C,
C1: Char;
Cp,
Rp,
CV,
CC: Integer;
PROCEDURE BKSpc;
BEGIN
IF (Cp > 1) THEN
BEGIN
IF (S1[Cp - 2] = '^') AND (S1[Cp - 1] IN ['0'..'9']) THEN
BEGIN
UserColor(1);
Dec(Cp);
END
ELSE IF (S1[Cp - 1] = #8) THEN
BEGIN
Prompt(' ');
Inc(Rp);
END
ELSE IF (S1[Cp - 1] <> #10) THEN
BEGIN
Prompt(#8+' '+#8);
Dec(Rp);
END;
Dec(Cp);
END;
END;
BEGIN
Rp := 1;
Cp := 1;
S1 := '';
IF (LastLineStr <> '') THEN
BEGIN
Prompt(LastLineStr);
S1 := LastLineStr;
LastLineStr := '';
Cp := (Length(S1) + 1);
Rp := Cp;
END;
REPEAT
C := Char(GetKey);
CASE C of
#32..#255 :
IF (Cp < StrLen) AND (Rp < ThisUser.LineLen) THEN
BEGIN
S1[Cp] := C;
Inc(Cp);
Inc(Rp);
OutKey(C);
END;
^H : BKSpc;
^S : BEGIN
CV := (5 - (Cp MOD 5));
IF ((Cp + CV) < StrLen) AND ((Rp + CV) < ThisUser.LineLen) THEN
FOR CC := 1 TO CV DO
BEGIN
Prompt(' ');
S1[Cp] := ' ';
Inc(Rp);
Inc(Cp);
END;
END;
^P : IF (OkANSI OR OkAvatar) AND (Cp < (StrLen - 1)) THEN
BEGIN
C1 := Char(GetKey);
IF (C1 IN ['0'..'9']) THEN
BEGIN
S1[Cp] := '^';
Inc(Cp);
S1[Cp] := C1;
Inc(Cp);
UserColor(Ord(S1[Cp - 1]));
END;
END;
^X : BEGIN
Cp := 1;
FOR CV := 1 TO (Rp - 1) DO
Prompt(#8+' '+#8);
UserColor(1);
Rp := 1;
END;
END;
UNTIL ((C = ^M) OR (Rp = ThisUser.LineLen) OR (HangUp));
S1[0] := Chr(Cp - 1);
IF (C <> ^M ) THEN
BEGIN
CV := (Cp - 1);
WHILE (CV > 1) AND (S1[CV] <> ' ') AND ((S1[CV] <> ^H) OR (S1[CV - 1] = '^')) DO
Dec(CV);
IF (CV > (Rp DIV 2)) AND (CV <> (Cp - 1)) THEN
BEGIN
LastLineStr := Copy(S1,(CV + 1),(Cp - CV));
FOR CC := (Cp - 2) DOWNTO CV DO
Prompt(^H);
FOR CC := (Cp - 2) DOWNTO CV DO
Prompt(' ');
S1[0] := Chr(CV - 1);
END;
END;
NL;
END;
FUNCTION NewPtr(VAR x: StrPtr): Boolean;
BEGIN
IF (Used <> NIL) THEN
BEGIN
x := Used;
Used := Used^.Next;
NewPtr := TRUE;
END
ELSE
BEGIN
IF (MaxAvail > 2048) THEN
BEGIN
New(x);
NewPtr := TRUE;
END
ELSE
NewPtr := FALSE;
END;
END;
PROCEDURE OldPtr(VAR x: StrPtr);
BEGIN
x^.Next := Used;
Used := x;
END;
PROCEDURE PLine(Cl: Integer; VAR Cp: StrPtr);
VAR
S1: AStr;
BEGIN
IF (NOT Abort) THEN
BEGIN
IF (Cp = NIL) THEN
S1 := ' ^5'+'[^3'+'END^5'+']'
ELSE
S1 := PadRightInt(Cl,4)+': '+Cp^.S;
PrintACR(S1);
END;
END;
PROCEDURE PL;
BEGIN
Abort := FALSE;
PLine(CurLine,Cur);
END;
BEGIN
{$IFDEF MSDOS}
Mark(TopHeap);
{$ENDIF}
{$IFDEF WIN32}
// REETODO Prepare to leak memory...
{$ENDIF}
Used := NIL;
Top := NIL;
Bottom := NIL;
AllRead := TRUE;
IF (FSpec = '') THEN
BEGIN
Print('Aborted.');
END
ELSE
BEGIN
Abort := FALSE;
Next := FALSE;
TotalLines := 0;
New(Cur);
Cur^.Last := NIL;
Cur^.S := '';
NL;
Assign(Fil,FSpec);
Reset(Fil);
IF (IOResult <> 0) THEN
BEGIN
ReWrite(Fil);
IF (IOResult <> 0) THEN
BEGIN
Print('Error reading file.');
Abort := TRUE;
END
ELSE
BEGIN
Close(Fil);
Erase(Fil);
Print('New file.');
TotalLines := 0;
Cur := NIL;
Top := Cur;
Bottom := Cur;
END;
END
ELSE
BEGIN
Abort := NOT NewPtr(Nex);
Top := Nex;
Print('^1Loading...');
WHILE ((NOT EOF(Fil)) AND (NOT Abort)) DO
BEGIN
Inc(TotalLines);
Cur^.Next := Nex;
Nex^.Last := Cur;
Cur := Nex;
ReadLn(Fil,S);
Cur^.S := S;
Abort := NOT NewPtr(Nex);
END;
Close(Fil);
Cur^.Next := NIL;
IF (TotalLines = 0) THEN
BEGIN
Cur := NIL;
Top := NIL;
END;
Bottom := Cur;
IF (Abort) THEN
BEGIN
NL;
Print(^G^G'|12WARNING: |10Not all of file read.^3');
NL;
AllRead := FALSE;
END;
Abort := FALSE;
END;
IF (NOT Abort) THEN
BEGIN
Print('Total lines: '+IntToStr(TotalLines));
Cur := Top;
IF (Top <> NIL) THEN
Top^.Last := NIL;
CurLine := 1;
Done := FALSE;
PL;
REPEAT
Prt(':');
Input(S,10);
IF (S = '') THEN
S := '+';
IF (StrToInt(S) > 0) THEN
BEGIN
I := StrToInt(S);
IF ((I > 0) AND (I <= TotalLines)) THEN
BEGIN
WHILE (I <> CurLine) DO
IF (I < CurLine) THEN
BEGIN
IF (Cur = NIL) THEN
BEGIN
Cur := Bottom;
CurLine := TotalLines;
END
ELSE
BEGIN
Dec(CurLine);
Cur := Cur^.Last;
END;
END
ELSE
BEGIN
Inc(CurLine);
Cur := Cur^.Next;
END;
PL;
END;
END
ELSE
CASE S[1] of
'?' : BEGIN
LCmds(14,3,'+Forward line','-Back line');
LCmds(14,3,'Top','Bottom');
LCmds(14,3,'Print line','List');
LCmds(14,3,'Insert lines','Delete line');
LCmds(14,3,'Replace line','Clear all');
LCmds(14,3,'Quit (Abort)','Save');
LCmds(14,3,'*Center line','!Memory Available');
END;
'!' : Print('Heap space available: '+IntToStr(MemAvail));
'*' : IF (Cur <> NIL) THEN
Cur^.S := #2+Cur^.S;
'+' : IF (Cur <> NIL) THEN
BEGIN
I := StrToInt(Copy(S,2,9));
IF (I = 0) THEN
I := 1;
WHILE (Cur <> NIL) AND (I > 0) DO
BEGIN
Cur := Cur^.Next;
Inc(CurLine);
Dec(I);
END;
PL;
END;
'-' : BEGIN
I := StrToInt(Copy(S,2,9));
IF (I = 0) THEN
I := 1;
IF (Cur = NIL) THEN
BEGIN
Cur := Bottom;
CurLine := TotalLines;
Dec(I);
END;
IF (Cur <> NIL) THEN
IF (Cur^.Last <> NIL) THEN
BEGIN
WHILE ((Cur^.Last <> NIL) AND (I > 0)) DO
BEGIN
Cur := Cur^.Last;
Dec(CurLine);
Dec(I);
END;
PL;
END;
END;
'B' : BEGIN
Cur := NIL;
CurLine := (TotalLines + 1);
PL;
END;
'C' : IF PYNQ('Clear workspace? ',0,FALSE) THEN
BEGIN
TotalLines := 0;
CurLine := 1;
Cur := NIL;
Top := NIL;
Bottom := NIL;
{$IFDEF MSDOS}
Release(TopHeap);
{$ENDIF}
{$IFDEF WIN32}
// REETODO Likely going to leak memory right about now
{$ENDIF}
END;
'D' : BEGIN
I := StrToInt(Copy(S,2,9));
IF (I = 0) THEN
I := 1;
WHILE (Cur <> NIL) AND (I > 0) DO
BEGIN
Las := Cur^.Last;
Nex := Cur^.Next;
IF (Las <> NIL) THEN
Las^.Next := Nex;
IF (Nex <> NIL) THEN
Nex^.Last := Las;
OldPtr(Cur);
IF (Bottom = Cur) THEN
Bottom := Las;
IF (Top = Cur) THEN
Top := Nex;
Cur := Nex;
Dec(TotalLines);
Dec(I);
END;
PL;
END;
'I' : BEGIN
Abort := FALSE;
Next := FALSE;
LastLineStr := '';
NL;
Print(' Enter "." on a separate line to exit insert mode.');
IF (OkANSI OR OkAvatar) THEN
Print('^2 ÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ^1');
Dec(ThisUser.LineLen,6);
S := '';
WHILE (S <> '.') AND (S <> '.'+#1) AND (NOT Abort) AND (NOT HangUp) DO
BEGIN
Prompt(PadRightInt(CurLine,4)+': ');
InLi(S);
IF (S <> '.') AND (S <> '.'+#1) THEN
BEGIN
Abort := NOT NewPtr(Nex);
IF (Abort) THEN
Print('Out of space.')
ELSE
BEGIN
Nex^.S := S;
IF (Top = Cur) THEN
IF (Cur = NIL) THEN
BEGIN
Nex^.Last := NIL;
Nex^.Next := NIL;
Top := Nex;
Bottom := Nex;
END
ELSE
BEGIN
Nex^.Next := Cur;
Cur^.Last := Nex;
Top := Nex;
END
ELSE
BEGIN
IF (Cur = NIL) THEN
BEGIN
Bottom^.Next := Nex;
Nex^.Last := Bottom;
Nex^.Next := NIL;
Bottom := Nex;
END
ELSE
BEGIN
Las := Cur^.Last;
Nex^.Last := Las;
Nex^.Next := Cur;
Cur^.Last := Nex;
Las^.Next := Nex;
END;
END;
Inc(CurLine);
Inc(TotalLines);
END
END;
END;
Inc(ThisUser.LineLen,6);
END;
'L' : BEGIN
Abort := FALSE;
Next := FALSE;
Nex := Cur;
I := CurLine;
WHILE (Nex <> NIL) AND (NOT Abort) AND (NOT HangUp) DO
BEGIN
PLine(I,Nex);
Nex := Nex^.Next;
Inc(I);
END;
END;
'P' : PL;
'R' : IF (Cur <> NIL) THEN
BEGIN
PL;
Prompt(PadRightInt(CurLine,4)+': ');
InLi(S);
Cur^.S := S;
END;
'Q' : Done := TRUE;
'S' : BEGIN
IF (NOT AllRead) THEN
BEGIN
UserColor(5);
Prompt('Not all of file read. ');
AllRead := PYNQ('Save anyway? ',0,FALSE);
END;
IF (AllRead) THEN
BEGIN
Done := TRUE;
Print('Saving ...');
SysOpLog('Saved "'+FSpec+'"');
ReWrite(Fil);
I := 0;
Cur := Top;
WHILE (Cur <> NIL) DO
BEGIN
WriteLn(Fil,Cur^.S);
Cur := Cur^.Next;
Dec(I);
END;
IF (I = 0) THEN
WriteLn(Fil);
Close(Fil);
END;
END;
'T' : BEGIN
Cur := Top;
CurLine := 1;
PL;
END;
END;
UNTIL ((Done) OR (HangUp));
END;
END;
{$IFDEF MSDOS}
Release(TopHeap);
{$ENDIF}
{$IFDEF WIN32}
// REETODO Likely going to leak memory right about now
{$ENDIF}
PrintingFile := FALSE;
LastError := IOResult;
END;
END.

553
SOURCE/SYSOP5.PAS Normal file
View File

@ -0,0 +1,553 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S+,V-}
UNIT SysOp5;
INTERFACE
PROCEDURE HistoryEditor;
IMPLEMENTATION
USES
Common,
TimeFunc;
PROCEDURE HistoryEditor;
CONST
MaxHistoryDates = 32767;
VAR
HistoryFile: FILE OF HistoryRecordType;
History: HistoryRecordType;
TempHistory: HistoryRecordType;
Cmd: Char;
RecNumToList,
NumHistoryDates: Integer;
SaveTempPause: Boolean;
PROCEDURE InitHistoryVars(VAR History: HistoryRecordType);
VAR
Counter: Byte;
BEGIN
FillChar(History,SizeOf(History),0);
WITH History DO
BEGIN
Date := 0;
FOR Counter := 0 TO 20 DO
UserBaud[Counter] := 0;
Active := 0;
Callers := 0;
NewUsers := 0;
Posts := 0;
EMail := 0;
FeedBack := 0;
Errors := 0;
Uploads := 0;
Downloads := 0;
UK := 0;
Dk := 0;
END;
END;
PROCEDURE LocateHistoryDate(DisplayStr: AStr; TempHistory1: HistoryRecordType; VAR DateToLocate: Str10;
VAR RecNum1: SmallInt; ShowErr,Searching: Boolean);
VAR
RecNum: Integer;
BEGIN
RecNum1 := -1;
InputFormatted(DisplayStr,DateToLocate,'##-##-####',TRUE);
IF (DateToLocate <> '') AND (Length(DateToLocate) = 10) THEN
BEGIN
IF (Searching) THEN
Reset(HistoryFile);
RecNum := 1;
WHILE (RecNum <= FileSize(HistoryFile)) AND (RecNum1 = -1) DO
BEGIN
Seek(HistoryFile,(RecNum - 1));
Read(HistoryFile,TempHistory1);
IF (PD2Date(TempHistory1.Date) = DateToLocate) THEN
RecNum1 := RecNum;
Inc(RecNum);
END;
IF (Searching) THEN
Close(HistoryFile);
IF (ShowErr) AND (RecNum1 = -1) THEN
BEGIN
Print('%LF^7The date entered is invalid!^1');
PauseScr(FALSE);
END;
END;
END;
PROCEDURE DeleteHistoryRecord(TempHistory1: HistoryRecordType; RecNumToDelete: SmallInt);
VAR
DateToDelete: Str10;
RecNum: Integer;
BEGIN
IF (NumHistoryDates = 0) THEN
Messages(4,0,'history dates')
ELSE
BEGIN
LocateHistoryDate('%LFHistory date to delete: ',TempHistory1,DateToDelete,RecNumToDelete,TRUE,TRUE);
IF (RecNumToDelete >= 1) AND (RecNumToDelete <= NumHistoryDates) THEN
BEGIN
Reset(HistoryFile);
Seek(HistoryFile,(RecNumToDelete - 1));
Read(HistoryFile,TempHistory1);
Close(HistoryFile);
LastError := IOResult;
IF (PD2Date(TempHistory1.Date) = DateStr) THEN
BEGIN
Print('%LF^7The current history date can not be deleted!^1');
PauseScr(FALSE);
END
ELSE
BEGIN
Print('%LFHistory date: ^5'+PD2Date(TempHistory1.Date));
IF PYNQ('%LFAre you sure you want to delete it? ',0,FALSE) THEN
BEGIN
Print('%LF[> Deleting history record ...');
Dec(RecNumToDelete);
Reset(HistoryFile);
IF (RecNumToDelete >= 0) AND (RecNumToDelete <= (FileSize(HistoryFile) - 2)) THEN
FOR RecNum := RecNumToDelete TO (FileSize(HistoryFile) - 2) DO
BEGIN
Seek(HistoryFile,(RecNum + 1));
Read(HistoryFile,History);
Seek(HistoryFile,RecNum);
Write(HistoryFile,History);
END;
Seek(HistoryFile,(FileSize(HistoryFile) - 1));
Truncate(HistoryFile);
Close(HistoryFile);
LastError := IOResult;
Dec(NumHistoryDates);
SysOpLog('* Deleted history date: ^5'+Pd2Date(TempHistory1.Date));
END;
END;
END;
END;
END;
PROCEDURE CheckHistoryRecord(History: HistoryRecordType; StartErrMsg,EndErrMsg: Byte; VAR Ok: Boolean);
VAR
Counter: Byte;
BEGIN
FOR Counter := StartErrMsg TO EndErrMsg DO
CASE Counter OF
1 : ;
END;
END;
PROCEDURE EditHistoryRecord(TempHistory1: HistoryRecordType; VAR History: HistoryRecordType; VAR Cmd1: Char;
VAR RecNumToEdit,SaveRecNumToEdit: SmallInt; VAR Changed: Boolean; Editing: Boolean);
VAR
CmdStr,
TempStr1: AStr;
DateToLocate: Str10;
RecNum: SmallInt;
Ok: Boolean;
BEGIN
WITH History DO
REPEAT
IF (Cmd1 <> '?') THEN
BEGIN
Abort := FALSE;
Next := FALSE;
CLS;
IF (Editing) THEN
PrintACR('^5Editing history record #'+IntToStr((NumHistoryDates + 1) - RecNumToEdit)+
' of '+IntToStr(NumHistoryDates))
ELSE
PrintACR('^5Inserting history record #'+IntToStr((NumHistoryDates + 1) - RecNumToEdit)+
' of '+IntToStr(NumHistoryDates + 1));
NL;
IF (Callers > 0) THEN
TempStr1 := IntToStr(Active DIV Callers)
ELSE
TempStr1 := '0';
PrintACR('^1A. Date : ^5'+PD2Date(Date)+AOnOff(RecNumToEdit = NumHistoryDates,' (Today)',''));
PrintACR('^1B. Minutes Active: ^5'+FormatNumber(Active));
PrintACR('^1C. Calls : ^5'+FormatNumber(Callers));
PrintACR('^1D. Percent Active: ^5'+SQOutSp(CTP(Active,1440)));
PrintACR('^1E. New Users : ^5'+FormatNumber(NewUsers));
PrintACR('^1G. Time/User : ^5'+TempStr1);
PrintACR('^1H. Public Posts : ^5'+FormatNumber(Posts));
PrintACR('^1I. Private Posts : ^5'+FormatNumber(EMail));
PrintACR('^1K. SysOp FeedBack: ^5'+FormatNumber(FeedBack));
PrintACR('^1M. Errors : ^5'+FormatNumber(Errors));
PrintACR('^1N. Uploads : ^5'+FormatNumber(Uploads));
PrintACR('^1O. Upload K : ^5'+FormatNumber(UK));
PrintACR('^1P. DownLoads : ^5'+FormatNumber(DownLoads));
PrintACR('^1R. Download K : ^5'+FormatNumber(DK));
PrintACR('^1S. Baud Rates');
END;
IF (NOT Editing) THEN
CmdStr := 'ABCDEGHIKMNOPRS'
ELSE
CmdStr := 'ABCDEGHIKMNOPRS[]FJL';
LOneK('%LFModify menu [^5?^4=^5Help^4]: ',Cmd1,'Q?'+CmdStr+^M,TRUE,TRUE);
CASE Cmd1 OF
'A' : IF (PD2Date(Date) = DateStr) THEN
BEGIN
Print('%LF^7The current history date can not be changed!^1');
PauseScr(FALSE);
END
ELSE
BEGIN
REPEAT
Ok := TRUE;
LocateHistoryDate('%LFNew history date: ',TempHistory1,DateToLocate,RecNum,FALSE,FALSE);
IF (DateToLocate <> '') AND (NOT (DateToLocate = PD2Date(History.Date))) THEN
BEGIN
IF (RecNum <> -1) THEN
BEGIN
Print('%LF^7The date entered is invalid!^1');
Ok := FALSE;
END
ELSE IF (DayNum(DateToLocate) > DayNum(DateStr)) THEN
BEGIN
Print('%LF^7The date can not be changed to a future date!^1');
Ok := FALSE;
END
ELSE IF (DateToLocate <> '') THEN
BEGIN
Date := Date2PD(DateToLocate);
Changed := TRUE;
END;
END;
UNTIL (Ok) OR (HangUp);
END;
'B' : InputLongIntWC('%LFNew minutes active for this date',Active,
[DisplayValue,NumbersOnly],0,2147483647,Changed);
'C' : InputLongIntWC('%LFNew number of system callers for this date',Callers,
[DisplayValue,NumbersOnly],0,2147483647,Changed);
'D' : BEGIN
Print('%LF^7This is for internal use only.');
PauseScr(FALSE);
END;
'E' : InputLongIntWC('%LFNew new user''s for this date',NewUsers,
[DisplayValue,NumbersOnly],0,2147483647,Changed);
'G' : BEGIN
Print('%LF^7This is for internal use only.');
PauseScr(FALSE);
END;
'H' : InputLongIntWC('%LFNew public message post''s this date',Posts,
[DisplayValue,NumbersOnly],0,2147483647,Changed);
'I' : InputLongIntWC('%LFNew private message post''s this date',Email,
[DisplayValue,NumbersOnly],0,2147483647,Changed);
'K' : InputLongIntWC('%LFNew sysop feedback sent this date',FeedBack,
[DisplayValue,NumbersOnly],0,2147483647,Changed);
'M' : InputLongIntWC('%LFNew system error''s this date',Errors,
[DisplayValue,NumbersOnly],0,2147483647,Changed);
'N' : InputLongIntWC('%LFNew user upload''s for this date',Uploads,
[DisplayValue,NumbersOnly],0,2147483647,Changed);
'O' : InputLongIntWC('%LFNew user kbytes uploaded this date',UK,
[DisplayValue,NumbersOnly],0,2147483647,Changed);
'P' : InputLongIntWC('%LFNew user download''s this date',Downloads,
[DisplayValue,NumbersOnly],0,2147483647,Changed);
'R' : InputLongIntWC('%LFNew user kbytes downloaded this date',DK,
[DisplayValue,NumbersOnly],0,2147483647,Changed);
'S' : BEGIN
REPEAT
Print('%CL^5User Baud Rates');
Print('%LF'+PadLeftStr('^1A. Telnet/Other: ^5'+FormatNumber(UserBaud[0]),32)+
'^1B. 300 Baud : ^5'+IntToStr(UserBaud[1]));
Print(PadLeftStr('^1C. 600 Baud : ^5'+IntToStr(UserBaud[2]),32)+
'^1D. 1200 Baud : ^5'+FormatNumber(UserBaud[3]));
Print(PadLeftStr('^1E. 2400 Baud : ^5'+FormatNumber(UserBaud[4]),32)+
'^1F. 4800 Baud : ^5'+FormatNumber(UserBaud[5]));
Print(PadLeftStr('^1G. 7200 Baud : ^5'+FormatNumber(UserBaud[6]),32)+
'^1H. 9600 Baud : ^5'+FormatNumber(UserBaud[7]));
Print(PadLeftStr('^1I. 12000 Baud : ^5'+FormatNumber(UserBaud[8]),32)+
'^1J. 14400 Baud : ^5'+FormatNumber(UserBaud[9]));
Print(PadLeftStr('^1K. 16800 Baud : ^5'+FormatNumber(UserBaud[10]),32)+
'^1L. 19200 Baud : ^5'+FormatNumber(UserBaud[11]));
Print(PadLeftStr('^1M. 21600 Baud : ^5'+FormatNumber(UserBaud[12]),32)+
'^1N. 24000 Baud : ^5'+FormatNumber(UserBaud[13]));
Print(PadLeftStr('^1O. 26400 Baud : ^5'+FormatNumber(UserBaud[14]),32)+
'^1P. 28800 Baud : ^5'+FormatNumber(UserBaud[15]));
Print(PadLeftStr('^1Q. 31200 Baud : ^5'+FormatNumber(UserBaud[16]),32)+
'^1R. 33600 Baud : ^5'+FormatNumber(UserBaud[17]));
Print(PadLeftStr('^1S. 38400 Baud : ^5'+FormatNumber(UserBaud[18]),32)+
'^1T. 57600 Baud : ^5'+FormatNumber(UserBaud[19]));
Print(PadLeftStr('^1U. 115200 Baud : ^5'+FormatNumber(UserBaud[20]),32));
LOneK('%LFModify menu [^5A^4-^5U^4,^5<CR>^4=^5Quit^4]: ',Cmd1,^M'ABCDEFGHIJKLMNOPQRSTU',TRUE,TRUE);
IF (Cmd1 <> ^M) THEN
InputLongIntWC('%LFNew value',UserBaud[Ord(Cmd1) - 65],
[DisplayValue,NumbersOnly],0,2147483647,Changed);
UNTIL (Cmd1 = ^M) OR (HangUp);
Cmd1 := #0;
END;
']' : IF (RecNumToEdit > 1) THEN
Dec(RecNumToEdit)
ELSE
BEGIN
Messages(3,0,'');
Cmd1 := #0;
END;
'[' : IF (RecNumToEdit < NumHistoryDates) THEN
Inc(RecNumToEdit)
ELSE
BEGIN
Messages(2,0,'');
Cmd1 := #0;
END;
'F' : IF (RecNumToEdit <> NumHistoryDates) THEN
RecNumToEdit := NumHistoryDates
ELSE
BEGIN
Messages(2,0,'');
Cmd1 := #0;
END;
'J' : BEGIN
RecNumToEdit := -1;
InputIntegerWOC('%LFJump to entry?',RecNumToEdit,[NumbersOnly],1,NumHistoryDates);
IF (RecNumToEdit < 1) OR (RecNumToEdit > NumHistoryDates) THEN
BEGIN
RecNumToEdit := SaveRecNumToEdit;
Cmd1 := #0;
END
ELSE
RecNumToEdit := ((NumHistoryDates - RecNumToEdit) + 1);
END;
'L' : IF (RecNumToEdit <> 1) THEN
RecNumToEdit := 1
ELSE
BEGIN
Messages(3,0,'');
Cmd1 := #0;
END;
'?' : BEGIN
Print('%LF^1<^3CR^1>Redisplay current screen');
Print('^3A^1-^3E^1,^3G^1-^3I^1,^3K^1,^3M^1-^3P^1,^3R^1-^3S^1:Modify item');
IF (NOT Editing) THEN
LCmds(20,3,'Quit and save','')
ELSE
BEGIN
LCmds(20,3,'[Back entry',']Forward entry');
LCmds(20,3,'First entry in list','Jump to entry');
LCmds(20,3,'Last entry in list','Quit and save');
END;
END;
END;
UNTIL (Pos(Cmd1,'Q[]FJL') <> 0) OR (HangUp);
END;
PROCEDURE InsertHistoryRecord(TempHistory1: HistoryRecordType; Cmd1: Char; RecNumToInsertBefore: SmallInt);
VAR
DateToInsert,
DateToInsertBefore: Str10;
RecNum,
RecNum1,
SaveRecNumToEdit: SmallInt;
Ok,
Changed: Boolean;
BEGIN
IF (NumHistoryDates = MaxHistoryDates) THEN
Messages(5,MaxHistoryDates,'history dates')
ELSE
BEGIN
LocateHistoryDate('%LFHistory date to insert before: ',TempHistory1,DateToInsertBefore,RecNumToInsertBefore,TRUE,TRUE);
IF (RecNumToInsertBefore >= 1) AND (RecNumToInsertBefore <= (NumHistoryDates + 1)) THEN
BEGIN
LocateHistoryDate('%LFNew history date to insert: ',TempHistory1,DateToInsert,RecNum1,FALSE,TRUE);
IF (RecNum1 <> -1) THEN
BEGIN
Print('%LF^7Duplicate date entered!^1');
PauseScr(FALSE);
END
ELSE IF (DayNum(DateToInsert) > DayNum(DateStr)) THEN
BEGIN
Print('%LF^7Future dates can not be entered!^1');
PauseScr(FALSE);
END
ELSE
BEGIN
IF (DayNum(DateToInsert) > DayNum(DateToInsertBefore)) THEN
Inc(RecNumToInsertBefore);
Reset(HistoryFile);
InitHistoryVars(TempHistory1);
TempHistory1.Date := Date2PD(DateToInsert);
IF (RecNumToInsertBefore = 1) THEN
RecNum1 := 0
ELSE IF (RecNumToInsertBefore = NumHistoryDates) THEN
RecNum1 := (RecNumToInsertBefore - 1)
ELSE
RecNum1 := RecNumToInsertBefore;
REPEAT
OK := TRUE;
EditHistoryRecord(TempHistory1,TempHistory1,Cmd1,RecNum1,SaveRecNumToEdit,Changed,FALSE);
CheckHistoryRecord(TempHistory1,1,1,Ok);
IF (NOT OK) THEN
IF (NOT PYNQ('%LFContinue inserting history date? ',0,TRUE)) THEN
Abort := TRUE;
UNTIL (OK) OR (Abort) OR (HangUp);
IF (NOT Abort) AND (PYNQ('%LFIs this what you want? ',0,FALSE)) THEN
BEGIN
Print('%LF[> Inserting history record ...');
Seek(HistoryFile,FileSize(HistoryFile));
Write(HistoryFile,History);
Dec(RecNumToInsertBefore);
FOR RecNum := ((FileSize(HistoryFile) - 1) - 1) DOWNTO RecNumToInsertBefore DO
BEGIN
Seek(HistoryFile,RecNum);
Read(HistoryFile,History);
Seek(HistoryFile,(RecNum + 1));
Write(HistoryFile,History);
END;
FOR RecNum := RecNumToInsertBefore TO ((RecNumToInsertBefore + 1) - 1) DO
BEGIN
Seek(HistoryFile,RecNum);
Write(HistoryFile,TempHistory1);
Inc(NumHistoryDates);
SysOpLog('* Inserted history date: ^5'+PD2Date(TempHistory1.Date));
END;
END;
Close(HistoryFile);
LastError := IOResult;
END;
END;
END;
END;
PROCEDURE ModifyHistoryRecord(TempHistory1: HistoryRecordType; Cmd1: Char; RecNumToEdit: SmallInt);
VAR
DateToEdit: Str10;
SaveRecNumToEdit: SmallInt;
Ok,
Changed: Boolean;
BEGIN
IF (NumHistoryDates = 0) THEN
Messages(4,0,'history dates')
ELSE
BEGIN
LocateHistoryDate('%LFHistory date to modify: ',TempHistory1,DateToEdit,RecNumToEdit,TRUE,TRUE);
IF (RecNumToEdit >= 1) AND (RecNumToEdit <= NumHistoryDates) THEN
BEGIN
SaveRecNumToEdit := -1;
Cmd1 := #0;
Reset(HistoryFile);
WHILE (Cmd1 <> 'Q') AND (NOT HangUp) DO
BEGIN
IF (SaveRecNumToEdit <> RecNumToEdit) THEN
BEGIN
Seek(HistoryFile,(RecNumToEdit - 1));
Read(HistoryFile,History);
SaveRecNumToEdit := RecNumToEdit;
Changed := FALSE;
END;
REPEAT
Ok := TRUE;
EditHistoryRecord(TempHistory1,History,Cmd1,RecNumToEdit,SaveRecNumToEdit,Changed,TRUE);
CheckHistoryRecord(History,1,1,Ok);
IF (NOT OK) THEN
BEGIN
PauseScr(FALSE);
IF (RecNumToEdit <> SaveRecNumToEdit) THEN
RecNumToEdit := SaveRecNumToEdit;
END;
UNTIL (OK) OR (HangUp);
IF (Changed) THEN
BEGIN
Seek(HistoryFile,(SaveRecNumToEdit - 1));
Write(HistoryFile,History);
Changed := FALSE;
SysOpLog('* Modified history date: ^5'+PD2Date(History.Date));
END;
END;
Close(HistoryFile);
LastError := IOResult;
END;
END;
END;
PROCEDURE ListHistoryDates(VAR RecNumToList1: Integer);
VAR
TempStr: AStr;
NumDone: Integer;
BEGIN
IF (RecNumToList1 < 1) OR (RecNumToList1 > NumHistoryDates) THEN
RecNumToList1 := NumHistoryDates;
Abort := FALSE;
Next := FALSE;
CLS;
PrintACR('^3 ^4:^3Mins ^4:^3 ^4:^3 ^4:^3#New^4:^3Tim/^4:^3Pub ^4:^3Priv^4:^3Feed^4:^3 ^4:^3'+
' ^4:^3 ^4:^3 ^4:^3');
PrintACR('^3 Date ^4:^3Activ^4:^3Call^4:^3%Activ^4:^3User^4:^3User^4:^3Post^4:^3Post'+
'^4:^3Back^4:^3Errs^4:^3#ULs^4:^3UL-k ^4:^3#DLs^4:^3DL-k');
PrintACR('^4========:=====:====:======:====:====:====:====:====:====:====:=====:====:=====');
Reset(HistoryFile);
NumDone := 0;
WHILE (NumDone < (PageLength - 6)) AND (RecNumToList1 >= 1) AND (RecNumToList1 <= NumHistoryDates)
AND (NOT Abort) AND (NOT HangUp) DO
BEGIN
Seek(HistoryFile,(RecNumToList1 - 1));
Read(HistoryFile,History);
WITH History DO
BEGIN
IF (Callers > 0) THEN
TempStr := PadRightInt(Active DIV Callers,4)
ELSE
TempStr := ' ';
PrintACR('^1'+AOnOff((RecNumToList1 = NumHistoryDates),'Today''s ',ToDate8(PD2Date(Date)))+
' '+PadRightInt(Active,5)+
' '+PadRightInt(Callers,4)+
' '+CTP(Active,1440)+
' '+PadRightInt(NewUsers,4)+
' '+TempStr+
' '+PadRightInt(Posts,4)+
' '+PadRightInt(EMail,4)+
' '+PadRightInt(FeedBack,4)+
' '+PadRightInt(Errors,4)+
' '+PadRightInt(Uploads,4)+
' '+PadRightInt(UK,5)+
' '+PadRightInt(DownLoads,4)+
' '+PadRightInt(DK,5));
END;
Dec(RecNumToList1);
Inc(NumDone);
END;
Close(HistoryFile);
LastError := IOResult;
IF (NumHistoryDates = 0) THEN
Print('*** No history dates defined ***');
END;
BEGIN
SaveTempPause := TempPause;
TempPause := FALSE;
Assign(HistoryFile,General.DataPath+'HISTORY.DAT');
Reset(HistoryFile);
NumHistoryDates := FileSize(HistoryFile);
Close(HistoryFile);
RecNumToList := NumHistoryDates;
Cmd := #0;
REPEAT
IF (Cmd <> '?') THEN
ListHistoryDates(RecNumToList);
LOneK('%LFHistory editor [^5?^4=^5Help^4]: ',Cmd,'QDIM?'^M,TRUE,TRUE);
CASE Cmd OF
^M : IF (RecNumToList < 1) OR (RecNumToList > NumHistoryDates) THEN
RecNumToList := NumHistoryDates;
'D' : DeleteHistoryRecord(TempHistory,RecNumToList);
'I' : InsertHistoryRecord(TempHistory,Cmd,RecNumToList);
'M' : ModifyHistoryRecord(TempHistory,Cmd,RecNumToList);
'?' : BEGIN
Print('%LF^1<^3CR^1>Next screen or redisplay current screen');
Print('^1(^3?^1)Help/First history date');
LCmds(20,3,'Delete history date','Insert history date');
LCmds(20,3,'Modify history date','Quit');
END;
END;
IF (Cmd <> ^M) THEN
RecNumToList := NumHistoryDates;
UNTIL (Cmd = 'Q') OR (HangUp);
TempPause := SaveTempPause;
LastError := IOResult;
END;
END.

1001
SOURCE/SYSOP6.PAS Normal file
View File

File diff suppressed because it is too large Load Diff

665
SOURCE/SYSOP7.PAS Normal file
View File

@ -0,0 +1,665 @@
{$IFDEF WIN32}
{$I DEFINES.INC}
{$ENDIF}
{$A+,B+,D+,E+,F+,I+,L+,N-,O+,R-,S+,V-}
UNIT SysOp7;
INTERFACE
USES
Common;
PROCEDURE FindMenu(DisplayStr: AStr;
VAR MenuNum: Byte;
LowMenuNum,
HighMenuNum: Byte;
VAR Changed: Boolean);
PROCEDURE MenuEditor;
IMPLEMENTATION
USES
Common5,
Menus2,
SysOp7M;
PROCEDURE DisplayMenus(VAR RecNumToList1: Integer; DisplayListNum: Boolean);
VAR
NumDone: Byte;
BEGIN
Abort := FALSE;
Next := FALSE;
AllowContinue := TRUE;
MCIAllowed := FALSE;
CLS;
IF (DisplayListNum) THEN
BEGIN
PrintACR('^0###^4:^3Menu #^4:^3Menu name');
PrintACR('^4===:======:====================================================================');
END
ELSE
BEGIN
PrintACR('^0Menu #^4:^3Menu name');
PrintACR('^4======:====================================================================');
END;
Reset(MenuFile);
NumDone := 0;
WHILE (NumDone < (PageLength - 7)) AND (RecNumToList1 >= 1) AND (RecNumToList1 <= NumMenus)
AND (NOT Abort) AND (NOT HangUp) DO
BEGIN
Seek(MenuFile,MenuRecNumArray[RecNumToList1]);
Read(MenuFile,MenuR);
WITH MenuR DO
BEGIN
IF (DisplayListNum) THEN
PrintACR('^0'+PadRightInt(RecNumToList1,3)+
' ^5'+PadRightInt(MenuNum,6)+
' ^3'+PadLeftStr(LDesc[1],68))
ELSE
PrintACR('^5'+PadRightInt(MenuNum,6)+
' ^3'+PadLeftStr(LDesc[1],68));
END;
Inc(RecNumToList1);
Inc(NumDone);
END;
Close(MenuFile);
LastError := IOResult;
MCIAllowed := TRUE;
AllowContinue := FALSE;
IF (NumMenus = 0) THEN
Print('*** No menus defined ***');
IF (DisplayListNum) THEN
PrintACR('%LF^1[Users start at menu number: ^5'+IntToStr(General.AllStartMenu)+'^1]');
END;
PROCEDURE FindMenu(DisplayStr: AStr;
VAR MenuNum: Byte;
LowMenuNum,
HighMenuNum: Byte;
VAR Changed: Boolean);
VAR
TempMenuR: MenuRec;
InputStr: AStr;
SaveMenuNum: Byte;
RecNum,
RecNum1,
RecNumToList: Integer;
BEGIN
SaveMenuNum := MenuNum;
RecNumToList := 1;
InputStr := '?';
REPEAT
IF (InputStr = '?') THEN
DisplayMenus(RecNumToList,FALSE);
Prt(DisplayStr+' (^5'+IntToStr(LowMenuNum)+'^4-^5'+IntToStr(HighMenuNum)+'^4)'+
' [^5?^4=^5First^4,^5<CR>^4=^5Next^4,^5Q^4=^5Quit^4): ');
MPL(Length(IntToStr(NumMenus)));
ScanInput(InputStr,'Q?'^M);
IF (InputStr = '-') THEN
InputStr := 'Q';
IF (InputStr <> 'Q') THEN
BEGIN
IF (InputStr = ^M) THEN
BEGIN
InputStr := '?';
IF (RecNumToList < 1) OR (RecNumToList > NumMenus) THEN
RecNumToList := 1
END
ELSE IF (InputStr = '?') THEN
RecNumToList := 1
ELSE IF (StrToInt(InputStr) < LowMenuNum) OR (StrToInt(InputStr) > HighMenuNum) THEN
Print('%LF^7The range must be from '+IntToStr(LowMenuNum)+' to '+IntToStr(HighMenuNum)+'!^1')
ELSE IF (InputStr = '0') AND (LowMenuNum = 0) THEN
BEGIN
MenuNum := StrToInt(InputStr);
InputStr := 'Q';
Changed := TRUE;
END
ELSE
BEGIN
RecNum1 := -1;
RecNum := 1;
Reset(MenuFile);
WHILE (RecNum <= NumMenus) AND (RecNum1 = -1) DO
BEGIN
Seek(MenuFile,MenuRecNumArray[RecNum]);
Read(MenuFile,TempMenuR);
IF (StrToInt(InputStr) = TempMenuR.MenuNum) THEN
RecNum1 := TempMenuR.MenuNum;
Inc(RecNum);
END;
Close(MenuFile);
IF (RecNum1 = -1) THEN
BEGIN
RGNoteStr(2,FALSE);
MenuNum := SaveMenuNum;
END
ELSE
BEGIN
MenuNum := StrToInt(InputStr);
InputStr := 'Q';
Changed := TRUE;
END;
END;
END;
UNTIL (InputStr = 'Q') OR (HangUp);
END;
PROCEDURE MenuEditor;
VAR
Cmd: Char;
SaveCurMenu: Byte;
RecNumToList: Integer;
SaveTempPause: Boolean;
FUNCTION DisplayMenuFlags(MenuFlags: MenuFlagSet; C1,C2: Char): AStr;
VAR
MenuFlagT: MenuFlagType;
TempS: AStr;
BEGIN
TempS := '';
FOR MenuFlagT := ClrScrBefore TO NoGlobalUsed DO
IF (MenuFlagT IN MenuFlags) THEN
TempS := TempS + '^'+C1+Copy('CDTNPAF12345',(Ord(MenuFlagT) + 1),1)
ELSE
TempS := TempS + '^'+C2+'-';
DisplayMenuFlags := TempS;
END;
PROCEDURE ToggleMenuFlag(MenuFlagT: MenuFlagType; VAR MenuFlags: MenuFlagSet);
BEGIN
IF (MenuFlagT IN MenuFlags) THEN
Exclude(MenuFlags,MenuFlagT)
ELSE
Include(MenuFlags,MenuFlagT);
END;
PROCEDURE ToggleMenuFlags(C: Char; VAR MenuFlags: MenuFlagSet; VAR Changed: Boolean);
VAR
TempMenuFlags: MenuFlagSet;
BEGIN
TempMenuFlags := MenuFlags;
CASE C OF
'C' : ToggleMenuFlag(ClrScrBefore,MenuFlags);
'D' : ToggleMenuFlag(DontCenter,MenuFlags);
'T' : ToggleMenuFlag(NoMenuTitle,MenuFlags);
'N' : ToggleMenuFlag(NoMenuPrompt,MenuFlags);
'P' : ToggleMenuFlag(ForcePause,MenuFlags);
'A' : ToggleMenuFlag(AutoTime,MenuFlags);
'F' : ToggleMenuFlag(ForceLine,MenuFlags);
'1' : ToggleMenuFlag(NoGenericAnsi,MenuFlags);
'2' : ToggleMenuFlag(NoGenericAvatar,MenuFlags);
'3' : ToggleMenuFlag(NoGenericRIP,MenuFlags);
'4' : ToggleMenuFlag(NoGlobalDisplayed,MenuFlags);
'5' : ToggleMenuFlag(NoGlobalUsed,MenuFlags);
END;
IF (MenuFlags <> TempMenuFlags) THEN
Changed := TRUE;
END;
PROCEDURE InitMenuVars(VAR MenuR: MenuRec);
BEGIN
FillChar(MenuR,SizeOf(MenuR),0);
WITH MenuR DO
BEGIN
LDesc[1] := '<< New Menu >>';
LDesc[2] := '';
LDesc[3] := '';
ACS := '';
NodeActivityDesc := '';
Menu := TRUE;
MenuFlags := [AutoTime];
LongMenu := '';
MenuNum := 0;
MenuPrompt := 'Command? ';
Password := '';
FallBack := 0;
Directive := '';
ForceHelpLevel := 0;
GenCols := 4;
GCol[1] := 4;
GCol[2] := 3;
GCol[3] := 5;
END;
END;
PROCEDURE DeleteMenu;
VAR
RecNumToDelete,
RecNum: SmallInt;
DeleteOk: Boolean;
BEGIN
IF (NumMenus = 0) THEN
Messages(4,0,'menus')
ELSE
BEGIN
RecNumToDelete := -1;
InputIntegerWOC('%LFMenu number to delete?',RecNumToDelete,[NumbersOnly],1,NumMenus);
IF (RecNumToDelete >= 1) AND (RecNumToDelete <= NumMenus) THEN
BEGIN
Reset(MenuFile);
Seek(MenuFile,MenuRecNumArray[RecNumToDelete]);
Read(MenuFile,MenuR);
Close(MenuFile);
LastError := IOResult;
DeleteOK := TRUE;
IF (MenuR.MenuNum = General.AllStartMenu) THEN
BEGIN
Print('%LFYou can not delete the menu new users start at.');
DeleteOK := FALSE;
END
ELSE IF (MenuR.MenuNum = General.NewUserInformationMenu) THEN
BEGIN
Print('%LFYou can not delete the new user information menu.');
DeleteOK := FALSE;
END
ELSE IF (MenuR.MenuNum = General.FileListingMenu) THEN
BEGIN
Print('%LFYou can not delete the file listing menu.');
DeleteOK := FALSE;
END
ELSE IF (MenuR.MenuNum = General.MessageReadMenu) THEN
BEGIN
Print('%LFYou can not delete the message read menu.');
DeleteOK := FALSE;
END
ELSE IF (CmdNumArray[RecNumToDelete] <> 0) THEN
BEGIN
Print('%LFThis menu is not empty.');
DeleteOK := FALSE;
END;
IF (NOT DeleteOK) THEN
PauseScr(FALSE)
ELSE
BEGIN
Print('%LFMenu: ^5'+MenuR.LDesc[1]);
IF PYNQ('%LFAre you sure you want to delete it? ',0,FALSE) THEN
BEGIN
Print('%LF[> Deleting menu record ...');
SysOpLog('* Deleted menu: ^5'+MenuR.LDesc[1]);
RecNumToDelete := MenuRecNumArray[RecNumToDelete]; { Convert To Real Record Number }
Reset(MenuFile);
IF (RecNumToDelete >= 0) AND (RecNumToDelete <= (FileSize(MenuFile) - 2)) THEN
FOR RecNum := RecNumToDelete TO (FileSize(MenuFile) - 2) DO
BEGIN
Seek(MenuFile,(RecNum + 1));
Read(MenuFile,MenuR);
Seek(MenuFile,RecNum);
Write(MenuFile,MenuR);
END;
Seek(MenuFile,(FileSize(MenuFile) - 1));
Truncate(MenuFile);
LoadMenuPointers;
Close(MenuFile);
LastError := IOResult;
END;
END;
END;
END;
END;
PROCEDURE InsertMenu;
VAR
RecNumToInsertBefore,
NewMenuNum,
RecNum: SmallInt;
BEGIN
IF (NumMenus = MaxMenus) THEN
Messages(5,MaxMenus,'menus')
ELSE
BEGIN
RecNumToInsertBefore := -1;
InputIntegerWOC('%LFMenu number to insert before?',RecNumToInsertBefore,[NumbersOnly],1,(NumMenus + 1));
IF (RecNumToInsertBefore >= 1) AND (RecNumToInsertBefore <= (NumMenus + 1)) THEN
BEGIN
Print('%LF[> Inserting menu record ...');
SysOpLog('* Inserted 1 menu.');
IF (RecNumToInsertBefore = (NumMenus + 1)) THEN
MenuRecNumArray[RecNumToInsertBefore] := (MenuRecNumArray[NumMenus] + CmdNumArray[NumMenus] + 1);
RecNumToInsertBefore := MenuRecNumArray[RecNumToInsertBefore]; {Convert To Real Record Number }
NewMenuNum := 0;
Reset(MenuFile);
RecNum := 1;
WHILE (RecNum <= NumMenus) DO
BEGIN
Seek(MenuFile,MenuRecNumArray[RecNum]);
Read(MenuFile,MenuR);
IF (MenuR.MenuNum > NewMenuNum) THEN
NewMenuNum := MenuR.MenuNum;
Inc(RecNum);
END;
FOR RecNum := 1 TO 1 DO
BEGIN
Seek(MenuFile,FileSize(MenuFile));
Write(MenuFile,MenuR);
END;
FOR RecNum := ((FileSize(MenuFile) - 1) - 1) DOWNTO RecNumToInsertBefore DO
BEGIN
Seek(MenuFile,RecNum);
Read(MenuFile,MenuR);
Seek(MenuFile,(RecNum + 1));
Write(MenuFile,MenuR);
END;
InitMenuVars(MenuR);
FOR RecNum := RecNumToInsertBefore TO ((RecNumToInsertBefore + 1) - 1) DO
BEGIN
Seek(MenuFile,RecNum);
MenuR.MenuNum := (NewMenuNum + 1);
Write(MenuFile,MenuR);
END;
LoadMenuPointers;
Close(MenuFile);
LastError := IOResult;
END;
END;
END;
PROCEDURE ModifyMenu;
VAR
TempMenuR: MenuRec;
Cmd1: Char;
SaveMenuNum: Byte;
RecNum,
RecNum1,
RecNumToModify,
SaveRecNumToModify: SmallInt;
Changed: Boolean;
BEGIN
IF (NumMenus = 0) THEN
Messages(4,0,'menus')
ELSE
BEGIN
RecNumToModify := -1;
InputIntegerWOC('%LFMenu number to modify?',RecNumToModify,[NumbersOnly],1,NumMenus);
IF (RecNumToModify >= 1) AND (RecNumToModify <= NumMenus) THEN
BEGIN
SaveRecNumToModify := -1;
Cmd1 := #0;
Reset(MenuFile);
WHILE (Cmd1 <> 'Q') AND (NOT HangUp) DO
BEGIN
IF (SaveRecNumToModify <> RecNumToModify) THEN
BEGIN
Seek(MenuFile,MenuRecNumArray[RecNumToModify]);
Read(MenuFile,MenuR);
SaveRecNumToModify := RecNumToModify;
Changed := FALSE;
END;
WITH MenuR DO
REPEAT
IF (Cmd1 <> '?') THEN
BEGIN
Abort := FALSE;
Next := FALSE;
MCIAllowed := FALSE;
CLS;
PrintACR('^5Menu #'+IntToStr(RecNumToModify)+' of '+IntToStr(NumMenus));
NL;
PrintACR('^11. Menu number : ^5'+IntToStr(MenuNum));
PrintACR('^12. Menu titles : ^5'+LDesc[1]);
IF (LDesc[2] <> '') THEN
PrintACR('^1 Menu title #2 : ^5'+LDesc[2]);
IF (LDesc[3] <> '') THEN
PrintACR('^1 Menu title #3 : ^5'+LDesc[3]);
PrintACR('^13. Help files : ^5'+AOnOff((Directive = ''),'*Generic*',Directive)+'/'+
AOnOff((LongMenu = ''),'*Generic*',LongMenu));
PrintACR('^14. Menu prompt : ^5'+MenuPrompt);
PrintACR('^15. ACS required : ^5"'+ACS+'"');
PrintACR('^16. Password : ^5'+AOnOff((Password = ''),'*None*',Password));
PrintACR('^17. Fallback menu : ^5'+IntToStr(FallBack));
PrintACR('^18. Forced ?-level: ^5'+AOnOff((ForceHelpLevel=0),'*None*',IntToStr(ForceHelpLevel)));
PrintACR('^19. Generic info : ^5'+IntToStr(GenCols)+' cols - '+IntToStr(GCol[1])+'/'+IntToStr(GCol[2])+
'/'+IntToStr(GCol[3]));
IF (General.MultiNode) THEN
PrintACR('^1N. Node activity : ^5'+NodeActivityDesc);
PrintACR('^1T. Flags : ^5'+DisplayMenuFlags(MenuFlags,'5','1'));
MCIAllowed := TRUE;
Print('%LF^1[Commands on this menu: ^5'+IntToStr(CmdNumArray[RecNumToModify])+'^1]');
IF (NumMenus = 0) THEN
Print('*** No menus defined ***');
END;
IF (General.MultiNode) THEN
LOneK('%LFModify menu [^5C^4=^5Command Editor^4,^5?^4=^5Help^4]: ',Cmd1,'Q123456789CNT[]FJL?'^M,TRUE,TRUE)
ELSE
LOneK('%LFModify menu [^5C^4=^5Command Editor^4,^5?^4=^5Help^4]: ',Cmd1,'Q123456789CT[]FJL?'^M,TRUE,TRUE);
CASE Cmd1 OF
'1' : BEGIN
REPEAT
SaveMenuNum := MenuNum;
RecNum1 := -1;
InputByteWC('%LFNew menu number',MenuNum,[DisplayValue,NumbersOnly],1,(NumMenus + 1),Changed);
IF (MenuNum <> SaveMenuNum) AND (MenuNum >= 1) AND (MenuNum <= (NumMenus + 1)) THEN
BEGIN
RecNum := 1;
WHILE (Recnum <= NumMenus) AND (RecNum1 = -1) DO
BEGIN
Seek(MenuFile,MenuRecNumArray[RecNum]);
Read(MenuFile,TempMenuR);
IF (MenuNum = TempMenuR.MenuNum) THEN
RecNum1 := TempMenuR.MenuNum;
Inc(RecNum);
END;
IF (RecNum1 <> -1) THEN
BEGIN
NL;
Print('^7Duplicate menu number!^1');
MenuNum := SaveMenuNum;
END;
END;
UNTIL (RecNum1 = -1) OR (HangUp);
Changed := TRUE;
END;
'2' : BEGIN
InputWNWC('%LFNew menu title #1: ',LDesc[1],
(SizeOf(LDesc[1]) - 1),Changed);
IF (LDesc[1] <> '') THEN
InputWNWC('New menu title #2: ',LDesc[2],
(SizeOf(LDesc[2]) - 1),Changed);
IF (LDesc[2] <> '') THEN
InputWNWC('New menu title #3: ',LDesc[3],
(SizeOf(LDesc[3]) - 1),Changed);
END;
'3' : BEGIN
InputWN1('%LFNew file displayed for help: ',Directive,(SizeOf(Directive) - 1),
[InterActiveEdit,UpperOnly],Changed);
InputWN1('%LFNew file displayed for extended help: ',LongMenu,(SizeOf(LongMenu) - 1),
[InterActiveEdit,UpperOnly],Changed);
END;
'4' : InputWNWC('%LFNew menu prompt: ',MenuPrompt,(SizeOf(MenuPrompt) - 1),Changed);
'5' : InputWN1('%LFNew menu ACS: ',ACS,(SizeOf(ACS) - 1),[InterActiveEdit],Changed);
'6' : InputWN1('%LFNew password: ',Password,(SizeOf(Password) - 1),[InterActiveEdit,UpperOnly],Changed);
'7' : BEGIN
SaveMenuNum := FallBack;
IF (Changed) THEN
BEGIN
Seek(MenuFile,MenuRecNumArray[SaveRecNumToModify]);
Write(MenuFile,MenuR);
Changed := FALSE;
END;
Close(MenuFile);
FindMenu('%LFNew fallback menu (^50^4=^5None^4)',SaveMenuNum,0,NumMenus,Changed);
Reset(MenuFile);
Seek(MenuFile,MenuRecNumArray[SaveRecNumToModify]);
Read(MenuFile,MenuR);
IF (Changed) THEN
FallBack := SaveMenuNum;
END;
'8' : InputByteWC('%LFNew forced menu help-level (0=None)',ForceHelpLevel,
[DisplayValue,NumbersOnly],0,3,Changed);
'9' : BEGIN
REPEAT
NL;
PrintACR('^1C. Generic columns : ^5'+IntToStr(GenCols));
PrintACR('^11. Bracket color : ^5'+IntToStr(GCol[1]));
PrintACR('^12. Command color : ^5'+IntToStr(GCol[2]));
PrintACR('^13. Description color: ^5'+IntToStr(GCol[3]));
PrintACR('^1S. Show menu');
LOneK('%LFSelect (CS,1-3,Q=Quit): ',Cmd1,'QCS123'^M,TRUE,TRUE);
CASE Cmd1 OF
'S' : BEGIN
IF (Changed) THEN
BEGIN
Seek(MenuFile,MenuRecNumArray[SaveRecNumToModify]);
Write(MenuFile,MenuR);
Changed := FALSE;
END;
Seek(MenuFile,MenuRecNumArray[SaveRecNumToModify]);
Read(MenuFile,MenuR);
CurMenu := MenuR.MenuNum;
LoadMenu;
Reset(MenuFile);
GenericMenu(2);
NL;
PauseSCR(FALSE);
Seek(MenuFile,MenuRecNumArray[SaveRecNumToModify]);
Read(MenuFile,MenuR);
END;
'C' : InputByteWC('%LFNew number of generic columns',GenCols,
[DisplayValue,NumbersOnly],0,7,Changed);
'1' : InputByteWC('%LFNew bracket color',GCol[1],[DisplayValue,NumbersOnly],0,9,Changed);
'2' : InputByteWC('%LFNew command color',GCol[2],[DisplayValue,NumbersOnly],0,9,Changed);
'3' : InputByteWC('%LFNew description color',GCol[3],[DisplayValue,NumbersOnly],0,9,Changed);
END;
UNTIL (Cmd1 IN ['Q',^M]) OR (HangUp);
Cmd1 := #0;
END;
'C' : BEGIN
IF (Changed) THEN
BEGIN
Seek(MenuFile,MenuRecNumArray[SaveRecNumToModify]);
Write(MenuFile,MenuR);
Changed := FALSE;
END;
CommandEditor(RecNumToModify,MenuNum,LDesc[1]);
SaveRecNumToModify := -1;
END;
'N' : IF (General.MultiNode) THEN
InputWNWC('%LF^1New node activity description:%LF^4: ',NodeActivityDesc,
(SizeOf(NodeActivityDesc) - 1),Changed);
'T' : BEGIN
REPEAT
LOneK('%LFToggle which flag? ('+DisplayMenuFlags(MenuFlags,'5','4')+'^4)'+
' [^5?^4=^5Help^4,^5<CR>^4=^5Quit^4]: ',Cmd1,^M'CDTNPAF12345?',TRUE,TRUE);
CASE Cmd1 OF
'C','D','T','N','P','A','F','1'..'5' :
ToggleMenuFlags(Cmd1,MenuFlags,Changed);
'?' : BEGIN
NL;
LCmds(21,3,'Clear screen','Don''t center titles');
LCmds(21,3,'No menu prompt','Pause before display');
LCmds(21,3,'Auto Time display','Force line input');
LCmds(21,3,'Titles not displayed','1 No ANS prompt');
LCmds(21,3,'2 No AVT prompt','3 No RIP prompt');
LCmds(21,3,'4 No Global disp','5 No global use');
END;
END;
UNTIL (Cmd1 = ^M) OR (HangUp);
Cmd1 := #0;
END;
'[' : IF (RecNumToModify > 1) THEN
Dec(RecNumToModify)
ELSE
BEGIN
Messages(2,0,'');
Cmd1 := #0;
END;
']' : IF (RecNumToModify < NumMenus) THEN
Inc(RecNumToModify)
ELSE
BEGIN
Messages(3,0,'');
Cmd1 := #0;
END;
'F' : IF (RecNumToModify <> 1) THEN
RecNumToModify := 1
ELSE
BEGIN
Messages(2,0,'');
Cmd1 := #0;
END;
'J' : BEGIN
InputIntegerWOC('%LFJump to entry?',RecNumToModify,[NumbersOnly],1,NumMenus);
IF (RecNumToModify < 1) AND (RecNumToModify > NumMenus) THEN
Cmd1 := #0;
END;
'L' : IF (RecNumToModify <> NumMenus) THEN
RecNumToModify := NumMenus
ELSE
BEGIN
Messages(3,0,'');
Cmd1 := #0;
END;
'?' : BEGIN
Print('%LF^1<^3CR^1>Redisplay screen');
Print('^31-9,C,N,T^1:Modify item');
LCmds(16,3,'[Back entry',']Forward entry');
LCmds(16,3,'Command Editor','First entry in list');
LCmds(16,3,'Jump to entry','Last entry in list');
LCmds(16,3,'Quit and save','');
END;
END;
UNTIL (Pos(Cmd1,'QC[]FJL') <> 0) OR (HangUp);
IF (Changed) THEN
BEGIN
Seek(MenuFile,MenuRecNumArray[SaveRecNumToModify]);
Write(MenuFile,MenuR);
Changed := FALSE;
SysOpLog('* Modified menu: ^5'+Menur.LDesc[1]);
END;
END;
Close(MenuFile);
LastError := IOResult;
END;
END;
END;
BEGIN
LoadMenuPointers;
SaveTempPause := TempPause;
TempPause := FALSE;
RecNumToList := 1;
Cmd := #0;
REPEAT
IF (Cmd <> '?') THEN
DisplayMenus(RecNumToList,TRUE);
LOneK('%LFMenu editor [^5?^4=^5Help^4]: ',Cmd,'QDIM?'^M,TRUE,TRUE);
CASE Cmd OF
^M : IF (RecNumToList < 1) OR (RecNumToList > NumMenus) THEN
RecNumToList := 1;
'D' : DeleteMenu;
'I' : InsertMenu;
'M' : ModifyMenu;
'?' : BEGIN
Print('%LF^1<^3CR^1>Redisplay screen');
LCmds(12,3,'Delete menu','Insert menu');
LCmds(12,3,'Modify menu','Quit');
END;
END;
IF (CMD <> ^M) THEN
RecNumToList := 1;
UNTIL (Cmd = 'Q') OR (HangUp);
TempPause := SaveTempPause;
LastError := IOResult;
LoadMenuPointers;
IF (UserOn) THEN
BEGIN
SaveCurMenu := CurMenu;
NumCmds := 0;
GlobalCmds := 0;
IF (General.GlobalMenu > 0) THEN
BEGIN
CurMenu := General.GlobalMenu;
LoadMenu;
GlobalCmds := NumCmds;
END;
CurMenu := SaveCurMenu;
LoadMenu;
END;
END;
END.

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